PL0编译器TurboPascal版再现

(********************* PL0 编译程序Turbo Pascal代码 *********************)
program pl0(fa,fa1,fa2
);
(* PL0 compile with code generation *)
 
label 99
;
     
(* Turbo Pascal do not support goto between different
         blocks so, the 'goto' command in getch are replaced
         by procedure exitp !! in another way, 'label 99' do
         not work !!                  Lin Wei       2001  *)
 
const norw=13;      
(* of reserved words *)
     
txmax=100;    
(* length of identifier table *)
     
nmax=14;      
(* max number of digits in numbers *)
     
al=10;        
(* length of identifiers *)
     
amax=2047;    
(* maximum address *)
     
levmax=3;     
(* max depth of block nesting *)
     
cxmax=200;    
(* size of code array *)
 
type symbol=(nul,ident,number,plus,minus,times,slash,oddsym
,
            
eql,neq,lss,leq,gtr,geq,lparen,rparen,comma
,
            
semicolon,period,becomes,beginsym,endsym,ifsym
,
            
thensym,whilesym,writesym,readsym,dosym,callsym
,
            
constsym,varsym,procsym
);
    
alfa=packed array[1..al] of char
;
    
objects=(constant,variable,procedur
);
    
(* wirth used the word "procedure"and"object" there, which won't work! *)
    
symset=set of symbol
;
    
fct=(lit,opr,lod,sto,cal,int,jmp,jpc
);
    
instruction=
packed record
                   
f:fct;       
(* function code *)
                   
l:0..levmax
(* level *)
                   
a:0..amax;   
(* displacement addr *)
                
end
;
             
(* lit 0,a load constant a
                 opr 0,a execute opr a
                 lod 1,a load variable 1,a
                 sto 1,a store variable 1,a
                 cal 1,a call procedure at level 1
                 int 0,a increment t -register by a
                 jmp 0,a jump to a
                 jpc 0,a jump conditional to a *)
 
var fa:text
;
   
fa1,fa2:text
;
   
listswitch:boolean;   
(* true set list object code *)
   
ch:char;              
(* last char read *)
   
sym:symbol;           
(* last symbol read *)
   
id:alfa;              
(* last identifier read *)
   
num:integer;          
(* last number read *)
   
cc:integer;           
(* character count *)
   
ll:integer;           
(* line length *)
   
kk:integer
;
   
cx:integer;           
(* code allocation index *)
   
line:array[1..81] of char
;
   
a:alfa
;
   
code:array[0..cxmax] of instruction
;
   
word:array[1..norw] of alfa
;
   
wsym:array[1..norw] of symbol
;
   
ssym:array[' '..'^'] of symbol
;
       
(* wirth uses "array[char]" here *)
   
mnemonic:array[fct] of packed array[1..5] of char
;
   
declbegsys, statbegsys, facbegsys:symset
;
   
table:array[0..txmax]
of record
           
name:alfa
;
           
case kind:objects
of
             
constant:(val:integer
);
             
variable,procedur:(level,adr,size:integer
)
           
(* "size" lacking in original. I think it belongs here *)
         
end
;
   
fin,fout:text
;
   
fname:string
;
   
err:integer
;
   
endf:boolean
;
 
procedure error(n:integer
);
begin
 
writeln('****','':cc-1,'!',n:2
);
 
writeln(fa1,'****','':cc-1,'!',n:2
);
 
err:=err+1
;
end;
(* error *)
 
procedure exitp
;
begin
 
endf:=true
;
 
close(fin
);
 
writeln
;
 
exit
;
end
;
 
procedure getsym
;
var i,j,k:integer
;
 
 
procedure getch
;
 
begin
    if
cc=ll
then begin
      if
eof(fin)
then begin
        
write('program incomplete'
);
        
close(fin
);
        
writeln
;
        
exitp
;
        
(*goto 99;*)
     
end
;
     
ll:=0
;
     
cc:=0
;
     
write(cx:4,' '
);
     
write(fa1,cx:4,' '
);
     
while not eoln(fin)
do begin
       
ll:=ll+1
;
       
read(fin,ch
);
       
write(ch
);
       
write(fa1,ch
);
       
line[ll]:=ch
;
     
end
;
     
writeln
;
     
ll:=ll+1
;
     
(* read(fin,line[ll]); repleaced by two lines below *)
     
line[ll]:=' '
;
     
readln(fin
);
     
writeln(fa1
);
   
end
;
   
cc:=cc+1
;
   
ch:=line[cc
];
 
end;
(* getch *)
 
begin
(* getsym *)
 
while ch=' ' do getch
;
 
if ch in ['a'..'z']
then begin
    
k:=0
;
    
repeat
       if
k<al
then begin
         
k:=k+1
;
         
a[k]:=ch
;
      
end
;
      
getch
;
    
until not(ch in ['a'..'z','0'..'9'
]);
    
if k>=kk then kk:=k
    
else repeat
           
a[kk]:=' '
;
           
kk:=kk-1
;
         
until kk=k
;
    
id:=a
;
    
i:=1
;
    
j:=norw
;
    
repeat
      
k:=(i+j) div 2
;
      
if id<=word[k] then j:=k-1
;
      
if id>=word[k] then i:=k+1
;
    
until i>j
;
    
if i-1>j then sym:=wsym[k] else sym:=ident
;
 
end else if ch in ['0'..'9'] then begin
(* number *)
   
k:=0
;
   
num:=0
;
   
sym:=number
;
   
repeat
     
num:=10*num+(ord(ch)-ord('0'
));
     
k:=k+1
;
     
getch
;
   
until not(ch in['0'..'9'
]);
   
if k>nmax then error(30
);
 
end else if ch=':'
then begin
   
getch
;
   
if ch='='
then begin
      
sym:=becomes
;
      
getch
;
   
end else sym:=nul
;
 
end else if ch='<'
then begin
   
getch
;
   
if ch='='
then begin
      
sym:=leq
;
      
getch
;
   
end else sym:=lss
;
 
end else if ch='>'
then begin
   
getch
;
   
if ch='='
then begin
      
sym:=geq
;
      
getch
;
   
end else sym:=gtr
;
 
end else begin
   
sym:=ssym[ch
];
   
getch
;
 
end
;
end;
(* getsym *)
 
procedure gen(x:fct;y,z:integer
);
begin
  if
cx>cxmax
then begin
    
write('program too long'
);
    
(*goto 99;*)
 
end
;
 
with code[cx]
do begin
      
f:=x
;
      
l:=y
;
      
a:=z
;
 
end
;
 
cx:=cx+1
;
end;
(* gen *)
 
procedure test(s1,s2:symset;n:integer
);
begin
  if not
(sym in s1)
then begin
    
error(n
);
    
s1:=s1+s2
;
    
while not(sym in s1) do getsym
;
 
end
;
end;
(* test *)
 
procedure block(lev,tx:integer;fsys:symset
);
var dx:integer;  
(* data allocation index *)
   
tx0:integer
(* inital table index *)
   
cx0:integer
(* inital code index *)
   
procedure enter(k:objects
);
   
begin
(* enter object into table *)
     
tx:=tx+1
;
     
with table[tx]
do begin
       
name:=id
;
       
kind:=k
;
       
case k
of
         
constant:
begin
                      if
num>amax then begin error(31); num:=0; end
;
                     
val:=num
;
                   
end
;
         
variable:
begin
                     
level:=lev
;
                     
adr:=dx
;
                     
dx:=dx+1
;
                   
end
;
         
procedur: level:=lev
;
       
end
;
     
end
;
   
end;
(* enter *)
 
   
function position(id:alfa):integer
;
   
var i:integer
;
   
begin
(* find identifier in table *)
     
table[0].name:=id
;
     
i:=tx
;
     
while table[i].name<>id do i:=i-1
;
     
position:=i
;
   
end;
(* position *)
 
   
procedure constdeclaration
;
   
begin
      if
sym=ident
then begin
        
getsym
;
        
if sym in [eql,becomes]
then begin
            if
sym=becomes then error(1
);
           
getsym
;
           
if sym=number
then begin
              
enter(constant
);
              
getsym
;
           
end else error(2
);
        
end else error(3
);
     
end else error(4
);
   
end;
(* constdeclaration *)
 
   
procedure vardeclaration
;
   
begin
      if
sym=ident
then begin
        
enter(variable
);
        
getsym
;
     
end else error(4
);
   
end;
(* vardeclaration *)
 
   
procedure listcode
;
   
var i:integer
;
   
begin
      if
listswitch
then begin
         for
i:=cx0 to cx-1
do
             with
code[i]
do begin
                 
writeln(i,mnemonic[f]:5,l:3,a:5
);
                 
writeln(fa,i:4,mnemonic[f]:5,l:3,a:5
);
            
end
;
     
end
;
   
end;
(* listcode *)
 
   
procedure statement(fsys:symset
);
   
var i,cx1,cx2:integer
;
       
procedure expression(fsys:symset
);
       
var addop:symbol
;
           
procedure term(fsys:symset
);
           
var mulop:symbol
;
               
procedure factor(fsys:symset
);
               
var i:integer
;
               
begin
                 
test(facbegsys,fsys,24
);
                 
while sym in facbegsys
do begin
                    if
sym=ident
then begin
                      
i:=position(id
);
                      
if i=0 then error(11
)
                      
else with table[i]
do
                         case
kind
of
                          
constant:gen(lit,0,val
);
                          
variable:gen(lod,lev-level,adr
);
                          
procedur:error(21
);
                        
end
;
                      
getsym
;
                   
end else if sym=number
then begin
                        if
num>amax
then begin
                          
error(31
);
                          
num:=0
;
                       
end
;
                       
gen(lit,0,num
);
                       
getsym
;
                   
end else if sym=lparen
then begin
                       
getsym
;
                       
expression([rparen]+fsys
);
                       
if sym=rparen then getsym
                        else error(22
);
                   
end
;
                   
test(fsys,facbegsys,23
);
                 
end
;
               
end;
(* factor *)
 
           
begin
(* term *)
             
factor([times,slash]+fsys
);
             
while sym in [times,slash]
do begin
               
mulop:=sym
;
               
getsym
;
               
factor(fsys+[times,slash
]);
               
if mulop=times then gen(opr,0,4) else gen(opr,0,5
)
             
end
;
           
end;
(* term *)
 
       
begin
(* expression *)
         
if sym in [plus,minus]
then begin
            
addop:=sym
;
            
getsym
;
            
term(fsys+[plus,minus
]);
            
if addop=minus then gen(opr,0,1
);
         
end else term(fsys+[plus,minus
]);
         
while sym in [plus,minus]
do begin
           
addop:=sym
;
           
getsym
;
           
term(fsys+[plus,minus
]);
           
if addop=plus then gen(opr,0,2) else gen(opr,0,3
);
         
end
;
       
end;
(* expression *)
 
       
procedure condition(fsys:symset
);
       
var relop:symbol
;
       
begin
          if
sym=oddsym
then begin
            
getsym
;
            
expression(fsys
);
            
gen(opr,0,6
);
         
end else begin
            
expression([eql,neq,lss,leq,gtr,geq]+fsys
);
            
if not(sym in [eql,neq,lss,leq,gtr,geq]) then error(20
)
            
else begin
              
relop:=sym
;
              
getsym
;
              
expression(fsys
);
              
case relop
of
                
eql:gen(opr,0,8
);
                
neq:gen(opr,0,9
);
                
lss:gen(opr,0,10
);
                
geq:gen(opr,0,11
);
                
gtr:gen(opr,0,12
);
                
leq:gen(opr,0,13
);
              
end
;
            
end
;
         
end
;
       
end;
(* condition *)
 
   
begin
(* statement *)
     
if sym=ident
then begin
        
i:=position(id
);
        
if i=0 then error(11
)
        
else if table[i].kind<>variable
then begin
          
error(12
);
          
i:=0
;
        
end
;
        
getsym
;
        
if sym=becomes then getsym else error(13
);
        
expression(fsys
);
        
if i<>0 then with table[i] do gen(sto,lev-level,adr
);
     
end else if sym=readsym
then begin
        
getsym
;
        
if sym<>lparen then error(34
)
        
else repeat
               
getsym
;
               
if sym=ident then i:=position(id
)
               
else i:=0
;
               
if i=0 then error(35
)
               
else with table[i]
do begin
                 
gen(opr,0,16
);
                 
gen(sto,lev-level,adr
);
               
end
;
               
getsym
;
        
until sym<>comma
;
        
if sym<>rparen
then begin
           
error(33
);
           
while not(sym in fsys) do getsym
;
        
end else getsym
;
     
end else if sym=writesym
then begin
        
getsym
;
        
if sym=lparen
then begin
            repeat
             
getsym
;
             
expression([rparen,comma]+fsys
);
             
gen(opr,0,14
);
           
until sym<>comma
;
           
if sym<>rparen then error(33) else getsym
;
        
end
;
        
gen(opr,0,15
);
     
end else if sym=callsym
then begin
        
getsym
;
        
if sym<>ident then error(14
)
        
else begin
          
i:=position(id
);
          
if i=0 then error(11) else with table[i]
do
              if
kind=procedur then gen(cal,lev-level,adr
)
             
else error(15
);
          
getsym
;
        
end
;
     
end else if sym=ifsym
then begin
        
getsym
;
        
condition([thensym,dosym]+fsys
);
        
if sym=thensym then getsym
         else error(16
);
        
cx1:=cx
;
        
gen(jpc,0,0
);
        
statement(fsys
);
        
code[cx1].a:=cx
;
     
end else if sym=beginsym
then begin
        
getsym
;
        
statement([semicolon,endsym]+fsys
);
        
while sym in [semicolon]+statbegsys
do begin
           if
sym=semicolon then getsym
           else error(10
);
          
statement([semicolon,endsym]+fsys
);
        
end
;
        
if sym=endsym then getsym else error(17
);
     
end else if sym=whilesym
then begin
        
cx1:=cx
;
        
getsym
;
        
condition([dosym]+fsys
);
        
cx2:=cx
;
        
gen(jpc,0,0
);
        
if sym=dosym then getsym else error(18
);
        
statement(fsys
);
        
gen(jmp,0,cx1
);
        
code[cx2].a:=cx
;
     
end
;
     
test(fsys,[],19
);
   
end;
(* statement *)
 
begin
(* block *)
 
dx:=3
;
 
tx0:=tx
;
 
table[tx].adr:=cx
;
 
gen(jmp,0,0
);
 
if lev>levmax then error(32
);
 
repeat
    if
sym=constsym
then begin
      
getsym
;
      
repeat
        
constdeclaration
;
        
while sym=comma
do begin
          
getsym
;
          
constdeclaration
;
        
end
;
        
if sym=semicolon then getsym else error(5
);
      
until sym<>ident
;
   
end
;
   
if sym=varsym
then begin
      
getsym
;
      
repeat
;
        
vardeclaration
;
        
while sym=comma
do begin
          
getsym
;
          
vardeclaration
;
        
end
;
        
if sym=semicolon then getsym else error(5
);
      
until sym<>ident
;
   
end
;
   
while sym=procsym
do begin
     
getsym
;
     
if sym=ident
then begin
        
enter(procedur
);
        
getsym
;
     
end else error(4
);
     
if sym=semicolon then getsym else error(5
);
     
block(lev+1,tx,[semicolon]+fsys
);
     
if sym=semicolon
then begin
        
getsym
;
        
test(statbegsys+[ident,procsym],fsys,6
);
     
end else error(5
);
   
end
;
   
test(statbegsys+[ident],declbegsys,7
);
 
until not(sym in declbegsys
);
 
code[table[tx0].adr].a:=cx
;
 
with table[tx0]
do begin
      
adr:=cx
;
      
size:=dx
;
 
end
;
 
cx0:=cx
;
 
gen(int,0,dx
);
 
statement([semicolon,endsym]+fsys
);
 
gen(opr,0,0
);
 
test(fsys,[],8
);
 
listcode
;
end;
(* block *)
 
procedure interpret
;
const stacksize=500
;
var p,b,t:integer;
(* program base topstack registers *)
   
i:instruction
;
   
s:array[1..stacksize] of integer;
(* datastore *)
 
   
function base(l:integer):integer
;
   
var bl:integer
;
   
begin
     
bl:=b;
(* find base 1 level down *)
     
while l>0
do begin
       
bl:=s[bl
];
       
l:=l-1
;
     
end
;
     
base:=bl
;
   
end;
(* base *)
 
begin
 
writeln('start pl0'
);
 
t:=0; b:=1; p:=0
;
 
s[1]:=0; s[2]:=0; s[3]:=0
;
 
repeat
   
i:=code[p
];
   
p:=p+1
;
   
with i do case f
of
     
lit: begin t:=t+1; s[t]:=a; end
;
     
opr: case a of
(* operator *)
            
0: begin
(* return *)
                 
t:=b-1
;
                 
p:=s[t+3
];
                 
b:=s[t+2
];
               
end
;
            
1: s[t]:=-s[t
];
            
2: begin t:=t-1; s[t]:=s[t]+s[t+1]; end
;
            
3: begin t:=t-1; s[t]:=s[t]-s[t+1]; end
;
            
4: begin t:=t-1; s[t]:=s[t]*s[t+1]; end
;
            
5: begin t:=t-1; s[t]:=s[t] div s[t+1]; end
;
            
6: s[t]:=ord(odd(s[t
]));
            
8: begin t:=t-1; s[t]:=ord(s[t]=s[t+1]); end
;
            
9: begin t:=t-1; s[t]:=ord(s[t]<>s[t+1]); end
;
            
10:begin t:=t-1; s[t]:=ord(s[t]<s[t+1]); end
;
            
11:begin t:=t-1; s[t]:=ord(s[t]>=s[t+1]); end
;
            
12:begin t:=t-1; s[t]:=ord(s[t]>s[t+1]); end
;
            
13:begin t:=t-1; s[t]:=ord(s[t]<=s[t+1]); end
;
            
14:begin write(s[t]); write(fa2,s[t]); t:=t-1; end
;
            
15:begin writeln; writeln(fa2); end
;
            
16:begin t:=t+1; write('?'); write(fa2,'?'); readln(s[t
]);
               
writeln(fa2,s[t]); end
;
          
end
;
     
lod: begin t:=t+1; s[t]:=s[base(l)+a]; end
;
     
sto: begin s[base(l)+a]:=s[t]; (* writeln(s[t]) *) t:=t-1; end
;
     
cal: begin (* generat new block mark *) s[t+1]:=base(l); s[t+2]:=b
;
          
s[t+3]:=p; b:=t+1; p:=a; end
;
     
int: t:=t+a
;
     
jmp: p:=a
;
     
jpc: begin if s[t]=0 then p:=a; t:=t-1; end
;
   
end;
(* with, case *)
 
until p=0
;
 
close(fa2
);
end;
(* interpret *)
 
begin
(* main *)
 
for ch:=' ' to '!' do ssym[ch]:=nul
;
 
(* changed bacause of different character set
     note the typos below in the original where
     the alfas were not given the correct space *)
 
word[1]:='begin     'word[2]:='call      '
;
 
word[3]:='const     'word[4]:='do        '
;
 
word[5]:='end       'word[6]:='if        '
;
 
word[7]:='odd       'word[8]:='procedure '
;
 
word[9]:='read      'word[10]:='then      '
;
 
word[11]:='var       '; word[12]:='while     '
;
 
word[13]:='write     '
;
 
 
wsym[1]:=beginsym;   wsym[2]:=callsym
;
 
wsym[3]:=constsym;   wsym[4]:=dosym
;
 
wsym[5]:=endsym;     wsym[6]:=ifsym
;
 
wsym[7]:=oddsym;     wsym[8]:=procsym
;
 
wsym[9]:=readsym;    wsym[10]:=thensym
;
 
wsym[11]:=varsym;    wsym[12]:=whilesym
;
 
wsym[13]:=writesym
;
 
 
ssym['+']:=plus;     ssym['-']:=minus
;
 
ssym['*']:=times;    ssym['/']:=slash
;
 
ssym['(']:=lparen;   ssym[')']:=rparen
;
 
ssym['=']:=eql;      ssym[',']:=comma
;
 
ssym['.']:=period;   ssym['#']:=neq
;
 
ssym[';']:=semicolon
;
 
 
mnemonic[lit]:='lit  'mnemonic[opr]:='opr  '
;
 
mnemonic[lod]:='lod  'mnemonic[sto]:='sto  '
;
 
mnemonic[cal]:='cal  'mnemonic[int]:='int  '
;
 
mnemonic[jmp]:='jmp  'mnemonic[jpc]:='jpc  '
;
 
 
declbegsys:=[constsym,varsym,procsym
];
 
statbegsys:=[beginsym,callsym,ifsym,whilesym
];
 
facbegsys:=[ident,number,lparen
];
 
 
(* page(output) *)
 
endf:=false
;
 
assign(fa1,'PL0.txt'
);
 
rewrite(fa1
);
 
write('input file? '
);
 
write(fa1,'input file?'
);
 
readln(fname
);
 
writeln(fa1,fname
);
 
(* openf(fin,fname,'r'); ==> *)
 
assign(fin,fname); reset(fin
);
 
write('list object code ?'
);
 
readln(fname
);
 
write(fa1,'list object code ?'
);
 
listswitch:=(fname[1]='y'
);
 
err:=0
;
 
cc:=0; cx:=0; ll:=0
;
 
ch:=' '; kk:=al
;
 
getsym
;
 
assign(fa,'PL0-1.txt'
);
 
assign(fa2,'PL0-2.txt'
);
 
rewrite(fa
);
 
rewrite(fa2
);
 
block(0,0,[period]+declbegsys+statbegsys
);
 
close(fa
);
 
close(fa1
);
 
if sym<>period then error(9
);
 
if err=0 then interpret else write('error in pl/0 program'
);
99:
(* this line is not work in turbo pascal so replace by
       procedure exitp: see the memo at the top *)
 
close(fin
);
 
writeln
;
end

 
  • 0
    点赞
  • 0
    收藏
    觉得还不错? 一键收藏
  • 1
    评论
评论 1
添加红包

请填写红包祝福语或标题

红包个数最小为10个

红包金额最低5元

当前余额3.43前往充值 >
需支付:10.00
成就一亿技术人!
领取后你会自动成为博主和红包主的粉丝 规则
hope_wisdom
发出的红包
实付
使用余额支付
点击重新获取
扫码支付
钱包余额 0

抵扣说明:

1.余额是钱包充值的虚拟货币,按照1:1的比例进行支付金额的抵扣。
2.余额无法直接购买下载,可以购买VIP、付费专栏及课程。

余额充值