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

(********************* 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.