us]);
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.
注：本站部分文章源于互联网，版权归原作者所有！如有侵权，请原作者与本站联系，本站将立即删除！ 本站文章除特别注明外均可转载，但需注明出处！ [MinTao学以致用网] 
