project1.dpr

数据结构中编译器的算法

          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 { assign valve to something that is not varible }
         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=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=process
           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(process);
        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; { the s tart address of the codes }
    end;
   cx0:=cx;
   gen(int,0,dx);
   statement([semicolon,endsym]+fsys);
   gen(opr,0,0); { return }
   test(fsys,[],8);
   listcode;
  end; { block }

 procedure interpret;
  const
   stacksize = 500;
  var
   p,b,t:integer; { registers for program, base and stack address }
   i:instruction; { register for instruction }
   s:array[1..stacksize] of integer; { to store data }

  function base(l:integer):integer;
   var
    b1:integer;
   begin
    b1:=b; { to find the base address of the level at l along the link }
    while l>0 do
     begin
      b1:=s[b1];
      l:=l-1;
     end;
    base:=b1;
   end; { base }

  begin { interpret }
   writeln(' START PL/0');
   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 { operate }
        0: { return }
         begin
          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;
       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 { generate new block mark }
        s[t+1]:=base(l);
        s[t+2]:=b;
        s[t+3]:=p;
        b:=t+1;
        p:=a;
       end;
      int:
       begin
        t:=t+a;
       end;
      jmp:
       begin
        p:=a;
       end;
      jpc:
       begin
        if s[t]=0 then p:=a;
        t:=t-1;
       end;
     
     end; { with }
   until p=0;
   writeln(' END PL/0');
  end; { interpret }

 begin { Main }
  
  { Main procedure }
  for ch:='A' to ';' do ssym[ch]:=nul;
  word[ 1] := 'begin';{'BEGIN';}
  word[ 2] := 'call';{'CALL';}
  word[ 3] := 'const';{'CONST';}
  word[ 4] := 'do';{'DO';}
  word[ 5] := 'end';{'END';}
  word[ 6] := 'if';{'IF';}
  word[ 7] := 'odd';{'ODD';}
  word[ 8] := 'procedure';{'PROCEDURE';}
  word[ 9] := 'then';{'THEN';}
  word[10] := 'var';{'VAR';}
  word[11] := 'while';{'WHILE';}
  
  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] := thensym;
  wsym[10] := varsym;
  wsym[11] := whilesym;

  ssym['+'] := plus;
  ssym['-'] := minus;
  ssym['*'] := times;
  ssym['/'] := slash;
  ssym['('] := lparen;
  ssym[')'] := rparen;
  ssym['='] := eql;
  ssym[','] := comma;
  ssym['.'] := period;
 
  ssym['#'] := neq;
  
  ssym['<'] := lss;
  ssym['>'] := gtr;


 // ssym['<='] := leq;
 // ssym['>='] := geq;


  
   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];//, m_readsym, m_writesym];
  facbegsys  := [ident, number, lparen];

{  page(output);}
  err:=0;
  cc:=0;
  cx:=0;
  ll:=0;
  ch:=' ';
  kk:=al;
  getsym;

  block(0,0,[period]+declbegsys+statbegsys);
  if sym<>period then error(9);
  if err=0
   then interpret
   else writeln('ERRORS IN PL/0 PROGRAM');

   goto 99;

99: writeln;

 end. { Main }