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; 
    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. 
  
  


			   
			   

                       标签：
                   
                   
版权申明：本站文章部分自网络，如有侵权，请联系：west999com@outlook.com

特别注意：本站所有转载文章言论不代表本站观点，本站所提供的摄影照片，插画，设计作品，如需使用，请与原作者联系，版权归原作者所有