project1.dpr

数据结构中编译器的算法

program Project1;

{$APPTYPE CONSOLE}

uses
  SysUtils;

//begin
  { TODO -oUser -cConsole Main : Insert code here }
//end.

//program PL0;
 { PL/0 compile program which generates codes }

 label 99;

 const
  norw    = 13;   { the number of reserve words}
  txmax   = 100;  { the length of id table }
  nmax    = 3;    { max number of digits in an integer }
  al      = 10;   { the length of id }
  amax    = 2047; { the maximum address }
  levmax  = 3;    { the maximum depth of sub-functions }
  cxmax   = 200;  { the size of the code arrays }

 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, dosym, callsym, constsym, varsym, procsym);
  alfa   = packed array[1..al] of char;
  object1   = (constant, variable, process);
  symset = set of symbol;
  fct    = (lit, opr, lod, sto, cal, int, jmp, jpc); { function }
  instruction =
   record
    f: fct;       { function code }
    l: 0..levmax; { level }
    a: 0..amax;   { relative address }
   end;
  {
    LIT 0,a: Load constant a
    OPR 0,a: Operate operator a
    LOD l,a: Load varible a which at level l, relative address a     
    STO l,a: Save varible a to level l, relative address a
    CAL l,a: Call procedure at level l
    INT 0,a: Regsiter t increased by a
    JMP 0,a: Jump to address a
    JPC 0,a: Jump to address a with certain condiction
  }

 var
  ch:      char;     { the latest read character }
  sym:     symbol;   { the latest read sumbol }
  id:      alfa;     { the latest read id }
  num:     integer;  { the latest read number }
  cc:      integer;  { coount the characters }
  ll:      integer;  { the length of a line }
  kk, err: integer;
  cx:      integer;  { the index of the codes }
  line:    array[1..81] of char;
  a:       alfa;
  code:    array[0..cxmax] of instruction;
  word:    array[1..norw] of string;
  wsym:    array[1..norw] of symbol;
  ssym:    array[char]of symbol;
  //mnemonic:array[fct] of packed array[1..5] of char;
  mnemonic:array[fct] of string;
  declbegsys,statbegsys,facbegsys: symset;
  table:   array[0..txmax] of
            record
             name:alfa;
             case kind: object1 of
              constant: (val: integer);
              variable,process:(level,adr:integer)
            end;

 procedure error(n:integer);
  begin
   writeln('****',' ':cc-1,'^',n:2);
   err:=err+1;
  end;

 procedure getsym;
  var
   i,j,k:integer;
  procedure getch;
   begin { getch }
    if cc=ll then
     begin
      if eof(input) then
       begin
        writeln('PROGRAM INCOMPLETE');
       // goto 99;
       end;

      ll:=0;
      cc:=0;
      write(cx:5,' ');
      while not(eoln(input)) do
       begin
        ll:=ll+1;
        read(ch);
        write(ch);
        line[ll]:=ch;
       end;

      writeln;
      ll:=ll+1;
      read(line[ll]);
      end;
    cc:=cc+1;
    ch:=line[cc];
   end; { getch }

  begin { getsym }
   while ch = ' ' do getch;

   if ch in ['a'..'z'] then
    begin { ids or reserve words }
     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
    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;  { index of data }
   tx0:integer; { index of start ids }
   cx0:integer; { index of start codes }

  procedure enter(k:object1);
   begin { put mass into id table }
    tx:=tx+1;
    with table[tx] do
     begin
      name:=id;
      kind:=k;
      case k of
       constant:
        begin
         if num>amax then
          begin error(30); num:=0; end;
         val:=num;
        end;

       variable:
        begin
         level:=lev;
         adr:=dx;
         dx:=dx+1;
        end;

       process: level:=lev;
      end;
     end;
   end; { enter }

  function position(id:alfa):integer;
   var
    i:integer;
   begin { search id in the id 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; { constadeclaration }

  procedure vardeclaration;
   begin { vardeclaration }
    if sym=ident then
     begin
      enter(variable);
      getsym;
     end
    else error(4);
   end; { vardeclaration }

  procedure listcode;
   var
    i:integer;
   begin { list the codes generated by this program }
    for i:=cx0 to cx-1 do
     with code[i] do writeln(i,mnemonic[f]:5,l:3,a:5);
   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 { factor }
       test(facbegsys,fsys,24);
       while sym in facbegsys do
        begin { while }
         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);
              process : error(21);
             end;
           getsym;
          end

         else if sym=number then
          begin
           if num>amax then
            begin
             error(30);
             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,[lparen],23);
        end; { while }
      end; { factor }

     begin { term }
      factor(fsys+[times,slash]);
      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 { condition }
     if sym=oddsym then
      begin
       getsym;
       expression(fsys);
       gen(opr,0,6);
      end

     else
      begin
       expression([eql,neq,lss,gtr,leq,geq]+fsys);
       if not(sym in [eql,neq,lss,leq,gtr,geq]) then error(20)
        else
         begin
          relop:=sym;
          getsym;
          expression(fsys);