(********************* 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,min[1] [2] 下一页 |
