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;