荔园在线
荔园之美，在春之萌芽，在夏之绽放，在秋之收获，在冬之沉淀
[回到开始]
[上一篇][下一篇]
发信人: playboy (为了钱，努力！), 信区: Program
标 题: LG的PL0
发信站: BBS 荔园晨风站 (Wed Jan 12 09:02:57 2000), 站内信件
program pl0(input,optput);
(* pl0 compiler with code generation *)
(* label 99; *)
const norw=15; (*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,repeatsym,untilsym);
alfa=packed array[1..al] of char;
pl0_object=(constant,variable,procedur);
(*wirth used the word "procedure" 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 l,a load variable l,a
sto l,a store variable l,a
cal l,a call procedure a at level l
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 "arrar[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:pl0_object 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[al];
err:integer;
function StrComp(s1,s2:alfa):integer;
var
flag:boolean;
i:integer;
begin
flag:=false;
i:=1;
repeat
if s1[i]<s2[i] then begin
flag:=true;
strcomp:=-1;
end
else if s1[i]>s2[i]
then begin
flag:=true;
strcomp:=1;
end;
i:=i+1;
until (flag or (i>al));
if not flag
then strcomp:=0;
end; (* end StrComp *)
procedure error(n:integer);
begin
writeln('****',' ':cc-1,'!',n:2);
writeln(fa1,'****',' ':cc-1,'!',n:2);
err:=err+1
end (*error*);
procedure getsym;
var i,j,k:integer;
procedure getch;
begin
if cc=ll
then
begin
if eof(fin)
then
begin
write('program incomplete');
(*goto 99*)
close(fin);
writeln;
halt; (* Pl0 stop *)
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;
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 (*id or reserved word*)
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;
for i:=1 to al do
id[i]:=a[i];
i:=1;
j:=norw;
repeat
k:=(i+j) div 2;
if (strcomp(id,word[k])<=0)
then j:=k-1;
if (strcomp(id,word[k])>=0)
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*)
close(fin);
writeln;
halt; (* Pl0 stop *)
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 ailocation index*)
tx0:integer; (*initial table index*)
cx0:integer; (*initial code index*)
procedure enter(k:pl0_object);
var
tmp:integer;
begin (*enter object into table*)
tx:=tx+1;
with table[tx] do
begin
for tmp:=1 to al do
name[tmp]:=id[tmp];
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,tmp:integer;
begin (*find identidier in table*)
for tmp:=1 to al do
table[0].name[tmp]:=id[tmp];
i:=tx;
while StrComp(table[i].name,id)<>0 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 (*list code generated for this block*)
if listswitch
then
begin
for i:=cx0 to cx-1 do
with code[i] do
begin
writeln(i:4,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(*ststement*)
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
else
if sym=repeatsym
then
begin
cx1:=cx;
getsym;
statement(fsys);
if sym=semicolon
then begin
getsym;
if sym=untilsym
then getsym
else error(36);
end
else error(5);
condition(fsys);
gen(jpc,0,cx1);
end;
test(fsys,[],19)
end (*ststement*);
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 l 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]) 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 because 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]:='repeat ';
word[11]:='then ';word[12]:='until ';
word[13]:='var '; word[14]:='while ';
word[15]:='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]:=repeatsym;
wsym[11]:=thensym; wsym[12]:=untilsym;
wsym[13]:=varsym; wsym[14]:=whilesym;
wsym[15]:=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,repeatsym];
facbegsys:=[ident,number,lparen];
(*page(output)*)
assign(fa1,'error.txt');
rewrite(fa1);
write('Input file? ');
write(fa1,'Input file? ');
readln(fname);
writeln(fa1,fname);
assign(fin,fname);
reset(fin);
write('List object code ? ');
readln(fname);
writeln(fa1,'List object code ? ');
listswitch:=(fname[1]='y');
err:=0;
cc:=0; cx:=0; ll:=0;
ch:=' '; kk:=al;
getsym;
assign(fa,'code.txt');
assign(fa2,'result.txt');
rewrite(fa);
rewrite(fa2);
block(0,0,[period]+declbegsys+statbegsys);
if sym<> period
then error(9);
if err=0
then interpret
else write('errors in PL/0 program');
(* 99:
close(fin);
writeln *)
close(fa);
close(fa1);
close(fin);
writeln
end.
--
☆ 来源:．BBS 荔园晨风站 bbs.szu.edu.cn．[FROM: bbs@210.39.3.80]
[回到开始]
[上一篇][下一篇]
荔园在线首页 友情链接：深圳大学 深大招生 荔园晨风BBS S-Term软件 网络书店