pl0-pas.txt.pas

Pascal语言写的扩充PL0文法编译器

            skip(colon); constant(high, x); mustbe(intip, x);
            if low>high then error(123);
            if sym=comma then
                 arraytyp(elemtip)
            else begin
                 skip(rbrack); skip(ofsym); typ(elemtip)
                 end;
            size:= (high-low+1)*ttab[elemtip].size
  end   end;
begin if sym=ident then begin
          i:= position; if itab[i].kind<>tipe then error(124);
          t:= itab[i].tip; getsym
      end else begin
          if tx=tmax then error(125); tx:= tx+1; t:= tx;
          if sym=arraysym then begin
              getsym; check(lbrack); arraytyp(t)
          end else begin
              skip(recordsym);
              if lev=lmax then error(126); lev:= lev+1;
              namelist[lev]:= 0; check(ident); sz:= 0;
              repeat enter(id, field, 0); i:= ix; getsym;
                     while sym=comma do begin
                         getsym; check(ident); enter(id, field, 0);
                         getsym
                     end;
                     j:= ix; skip(colon); typ(ft);
                     repeat itab[i].tip:= ft; itab[i].offset:= sz;
                            sz:= sz+ttab[ft].size; i:= i+1
                     until i>j;
                    if sym=semicolon then getsym else check(endsym)
              until sym<>ident;
              ttab[t].size:= sz; ttab[t].kind:= records;
              ttab[t].fields:= namelist[lev]; lev:= lev-1;
              skip(endsym)
end   end end;

procedure typedeclaration;
  var a: alfa; t: integer;
begin a:= id; getsym; skip(eql); typ(t); skip(semicolon);
      enter(a, tipe, t)
end;

procedure vardeclaration;
  var p, q, t: integer;
begin enter(id, varbl, 0); p:= ix; getsym;
      while sym=comma do begin
          getsym; check(ident); enter(id, varbl, 0); getsym
      end;
      q:= ix; skip(colon); typ(t); skip(semicolon);
      repeat with itab[p] do begin
          vlevel:= lev; dx:= dx-ttab[t].size; tip:= t;
          vadr:= dx; refpar:= false
        end;
        p:= p+1
      until p>q
end;

procedure funcdeclaration(isf: boolean);
  var f, p, ps, odx: integer;
  procedure paramlist;
    var r: boolean; t: integer;
  begin if sym=varsym then begin r:= true; getsym end else r:= false;
        check(ident); p:= ix; enter(id, varbl, 0); getsym;
        while sym=comma do begin
            getsym; check(ident); enter(id, varbl, 0); getsym
        end;
        skip(colon); check(ident); typ(t);
        while p<ix do begin
            p:= p+1; itab[p].tip:= t; itab[p].refpar:= r;
            if r then ps:= ps+1 else ps:= ps+ttab[t].size
  end   end;
begin getsym; check(ident); enter(id, funkt, 0); getsym; f:= ix;
      itab[f].flevel:= lev; itab[f].fadr:= codelabel; gen1(jump, 0);
      if lev=lmax then error(127); lev:= lev+1; namelist[lev]:= 0;
      ps:= 1; odx:= dx;
      if sym=lparen then begin
          repeat getsym; paramlist until sym<>semicolon;
          skip(rparen)
      end;
      if lev>1 then dx:= -1
               else dx:= 0;
      itab[f].resultadr:= ps; p:= f;
      while p<ix do begin
          p:= p+1;
          with itab[p] do begin
              if refpar then ps:= ps-1 else ps:= ps-ttab[tip].size;
              vlevel:= lev; vadr:= ps
      end end;
      if isf then begin
          skip(colon); check(ident); typ(itab[f].tip);
          if ttab[itab[f].tip].kind<>simple then error(128)
      end;
      skip(semicolon);
      itab[f].lastpar:= ix; itab[f].inside:= true;
      block(itab[f].fadr);
      itab[f].inside:= false;
      gen1(exit, itab[f].resultadr-dx);
      lev:= lev-1; dx:= odx;
      skip(semicolon)
end;

procedure block{l: integer};
  var d, odx, oix: integer;
begin odx:= dx; oix:= ix;
      if sym=constsym then begin
          getsym; check(ident);
          repeat constdeclaration until sym<>ident
      end;
      if sym=typesym then begin
          getsym; check(ident);
          repeat typedeclaration until sym<>ident
      end;
      if sym=varsym then begin
          getsym; check(ident);
          repeat vardeclaration until sym<>ident
      end;
      while sym in [funcsym, procsym] do funcdeclaration(sym=funcsym);
      if l+1=codelabel then cx:= cx-1 else code[l].a:= codelabel;
      if lev=0 then
          gen1(sets, dx)
      else begin
          d:= dx-odx; dx:= odx;  gen1(adjs, d)
      end;
      statement;
      if lev<>0 then gen1(adjs, odx-dx); ix:= oix
end;

procedure listcode;
  var i: integer;
begin for i:= 0 to cx-1 do begin
          write(i, ' :    ');
          case code[i].op of
            add  : writeln('add');
            neg  : writeln('neg');
            mul  : writeln('mul');
            divd : writeln('divd');
            remd : writeln('remd');
            div2 : writeln('div2');
            rem2 : writeln('rem2');
            eqli : writeln('eqli');
            neqi : writeln('neqi');
            lssi : writeln('lssi');
            leqi : writeln('leqi');
            gtri : writeln('gtri');
            geqi : writeln('geqi');
            dupl : writeln('dupl');
            swap : writeln('swap');
            andb : writeln('andb');
            orb  : writeln('orb');
            load : writeln('load');
            stor : writeln('stor');
            hhalt : writeln('hhalt');
            wri  : writeln('wri');
            wrc  : writeln('wrc');
            wrl  : writeln('wrl');
            rdi  : writeln('rdi');
            rdc  : writeln('rdc');
            rdl  : writeln('rdl');
            eol  : writeln('eol');
            ldc  : writeln('ldc   ', code[i].a);
            ldla : writeln('ldla  ', code[i].a);
            ldl  : writeln('ldl   ', code[i].a);
            ldg  : writeln('ldg   ', code[i].a);
            stl  : writeln('stl   ', code[i].a);
            stg  : writeln('stg   ', code[i].a);
            move : writeln('move  ', code[i].a);
            copy : writeln('copy  ', code[i].a);
            addc : writeln('addc  ', code[i].a);
            mulc : writeln('mulc  ', code[i].a);
            jump : writeln('jump  ', code[i].a);
            jumpz: writeln('jumpz ', code[i].a);
            call : writeln('call  ', code[i].a);
            adjs : writeln('adjs  ', code[i].a);
            sets : writeln('sets  ', code[i].a);
            exit : writeln('exit  ', code[i].a)
end end   end;

begin { compile }
      word[beginsym ]:= 'begin     '; word[endsym   ]:= 'end       ';
      word[ifsym    ]:= 'if        '; word[thensym  ]:= 'then      ';
      word[elsesym  ]:= 'else      '; word[whilesym ]:= 'while     ';
      word[dosym    ]:= 'do        '; word[casesym  ]:= 'case      ';
      word[repeatsym]:= 'repeat    '; word[untilsym ]:= 'until     ';
      word[forsym   ]:= 'for       '; word[tosym    ]:= 'to        ';
      word[downtosym]:= 'downto    '; word[notsym   ]:= 'not       ';
      word[divsym   ]:= 'div       '; word[modsym   ]:= 'mod       ';
      word[andsym   ]:= 'and       '; word[orsym    ]:= 'or        ';
      word[constsym ]:= 'const     '; word[varsym   ]:= 'var       ';
      word[typesym  ]:= 'type      '; word[arraysym ]:= 'array     ';
      word[ofsym    ]:= 'of        '; word[recordsym]:= 'record    ';
      word[progsym  ]:= 'program   '; word[funcsym  ]:= 'function  ';
      word[procsym  ]:= 'procedure ';
      ttab[intip].size:= 1; ttab[intip].kind:= simple;
      ttab[chartip].size:= 1; ttab[chartip].kind:= simple;
      ttab[booltip].size:= 1; ttab[booltip].kind:= simple;
      tx:= 3; namelist[-1]:= 0; lev:= -1; ix:= 0;
      enter('false     ', konst, booltip); itab[ix].val:= ord(false);
      enter('true      ', konst, booltip); itab[ix].val:= ord(true);
      enter('maxint    ', konst, intip);   itab[ix].val:= 32767;
      enter('integer   ', tipe, intip);
      enter('char      ', tipe, chartip);
      enter('boolean   ', tipe, booltip);
      enter('abs       ', funkt, intip);
      itab[ix].flevel:= -1; itab[ix].fadr:= fabs; itab[ix].inside:= false;
      enter('sqr       ', funkt, intip);
      itab[ix].flevel:= -1; itab[ix].fadr:= fsqr; itab[ix].inside:= false;
      enter('odd       ', funkt, booltip);
      itab[ix].flevel:= -1; itab[ix].fadr:= fodd; itab[ix].inside:= false;
      enter('chr       ', funkt, chartip);
      itab[ix].flevel:= -1; itab[ix].fadr:= fchr; itab[ix].inside:= false;
      enter('ord       ', funkt, intip);
      itab[ix].flevel:= -1; itab[ix].fadr:= ford; itab[ix].inside:= false;
      enter('write     ', funkt, 0);
      itab[ix].flevel:= -1; itab[ix].fadr:= fwrite;
      enter('writeln   ', funkt, 0);
      itab[ix].flevel:= -1; itab[ix].fadr:= fwriteln;
      enter('read      ', funkt, 0);
      itab[ix].flevel:= -1; itab[ix].fadr:= fread;
      enter('readln    ', funkt, 0);
      itab[ix].flevel:= -1; itab[ix].fadr:= freadln;
      enter('eoln      ', funkt, booltip);
      itab[ix].flevel:= -1; itab[ix].fadr:= feoln; itab[ix].inside:= false;
      namelist[0]:= 0; lev:= 0; cc:= 0; ll:= 0; getch; getsym;
      labeled:= true; cx:= 0; dx:= amax+1;
      skip(progsym); skip(ident); check(lparen);
      repeat getsym; check(ident);
             if (id<>'input     ') and (id<>'output    ') then error(129);
             getsym
      until sym<>comma;
      skip(rparen); skip(semicolon); gen1(jump, 0); block(0); gen0(hhalt);
      check(period);
      listcode
end;

procedure interpret;
  var pc, sp, j, k, n: integer; i: instr; c: char; h: boolean;
begin pc:= 0; h:= false;
      repeat i:= code[pc]; pc:= pc+1;
        case i.op of
          add  : begin m[sp+1]:= m[sp+1]+m[sp]; sp:= sp+1 end;
          neg  : m[sp]:= -m[sp];
          mul  : begin m[sp+1]:= m[sp+1]*m[sp]; sp:= sp+1 end;
          divd : begin m[sp+1]:= m[sp+1] div m[sp]; sp:= sp+1 end;
          remd : begin m[sp+1]:= m[sp+1] mod m[sp]; sp:= sp+1 end;
          div2 : m[sp]:= m[sp] div 2;
          rem2 : m[sp]:= m[sp] mod 2;
          eqli : begin m[sp+1]:= ord(m[sp+1]=m[sp]); sp:= sp+1 end;
          neqi : begin m[sp+1]:= ord(m[sp+1]<>m[sp]); sp:= sp+1 end;
          lssi : begin m[sp+1]:= ord(m[sp+1]<m[sp]); sp:= sp+1 end;
          leqi : begin m[sp+1]:= ord(m[sp+1]<=m[sp]); sp:= sp+1 end;
          gtri : begin m[sp+1]:= ord(m[sp+1]>m[sp]); sp:= sp+1 end;
          geqi : begin m[sp+1]:= ord(m[sp+1]>=m[sp]); sp:= sp+1 end;
          dupl : begin sp:= sp-1; m[sp]:= m[sp+1] end;
          swap : begin k:= m[sp]; m[sp]:= m[sp+1]; m[sp+1]:= k end;
          andb : begin if m[sp]=0 then m[sp+1]:= 0; sp:= sp+1 end;
          orb  : begin if m[sp]=1 then m[sp+1]:= 1; sp:= sp+1 end;
          load : m[sp]:= m[m[sp]];
          stor : begin m[m[sp]]:= m[sp+1]; sp:= sp+2 end;
          hhalt: h:= true;
          wri  : begin write(output, m[sp+1]: m[sp]); sp:= sp+2 end;
          wrc  : begin write(output, chr(m[sp])); sp:= sp+1 end;
          wrl  : writeln(output);
          rdi  : begin read(input, m[m[sp]]); sp:= sp+1 end;
          rdc  : begin read(input, c); m[m[sp]]:= ord(c); sp:= sp+1 end;
          rdl  : readln(input);
          eol  : begin sp:= sp-1; m[sp]:= ord(eoln(input)) end;
          ldc  : begin sp:= sp-1; m[sp]:= i.a end;
          ldla : begin sp:= sp-1; m[sp]:= sp+1+i.a end;
          ldl  : begin sp:= sp-1; m[sp]:= m[sp+1+i.a] end;
          ldg  : begin sp:= sp-1; m[sp]:= m[i.a] end;
          stl  : begin m[sp+i.a]:= m[sp]; sp:= sp+1 end;
          stg  : begin m[i.a]:= m[sp]; sp:= sp+1 end;
          move : begin k:= m[sp]; j:= m[sp+1]; sp:= sp+2; n:= i.a;
                       repeat n:= n-1; m[k+n]:= m[j+n] until n=0
                 end;
          copy : begin j:= m[sp]; n:= i.a; sp:= sp-n+1;
                       repeat n:= n-1; m[sp+n]:= m[j+n] until n=0
                 end;
          addc : m[sp]:= m[sp]+i.a;
          mulc : m[sp]:= m[sp]*i.a;
          jump : pc:= i.a;
          jumpz: begin if m[sp]=0 then pc:= i.a; sp:= sp+1 end;
          call : begin sp:= sp-1; m[sp]:= pc; pc:= i.a end;
          adjs : sp:= sp+i.a;
          sets : sp:= i.a;
          exit : begin pc:= m[sp]; sp:= sp+i.a end;
        end
      until h
end;

begin
      assign(infile, 'test.pas');
      reset(infile);
      compile;
      interpret;
end.