program PL0Comp(input,output);
{PL/0 compiler with code generation}
{label 99;}
const norw=11;     {no. of reserved words}
      txmax=100;   {length of indentifier table}
      nmax=14;     {max. no. of digits in numbers}
      al=10;       {length of identifiers}
      amax=2047;   {maximum address}
      levmax=3;    {maximum 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,
        dosym, callsym, constsym, varsym, procsym);
     alfa1= packed array[1..al] of char;
     PLobject=(constant, variable, PLprocedure);
     symset=set of symbol;
     fct=(lit, opr, lod, sto, cal, int, jmp, jpc);    {function}
     instruction=packed record
                     f:fct;          {function code}
                     l:0..levmax;    {level}
                     a:0..amax;      {displacement address}
                 end;
  {  LIT 0,a : load constant a
     OPR 0,a : execute operation a
     LOD l,a : load variable l,a
     STO l,a : store variable l,a
     CAL l,a : call procedure a at level l
     INT 0,a : increment t-register by a
     JMP 0,a : jump to a
     JPC 0,a : jump conditional to a    }
var ch,ch1,dummy :char; {last character read}
    sym :symbol;    {last symbol read}
    id  :alfa1;      {last identifier read}
    num :integer;   {last number read}
    cc  :integer;   {character count}
    ll  :integer;   {line length}
    kk,ii  :integer;
    cx  :integer;   {code allocation index}
    err :integer;
    line :array[1..81] of char;
    a    :alfa1;
    code :array[0..cxmax] of instruction;
    word :array[1..norw] of alfa1;
    wsym :array[1..norw] of symbol;
    ssym :array[char] of symbol;
    mnemonic :array[fct] of
                packed array[1..5] of char;
    declbegsys, statbegsys, facbegsys :symset;
    table :array[0..txmax] of
             record name :alfa1;
                    dummy:integer;
              case kind :PLobject of
                    constant :(val :integer);
               variable, PLprocedure :(level, adr :integer)
             end;
    
   { table1 :array[0..txmax] of alfa1;
    table2 :array[0..txmax] of
             record 
              case kind :PLobject of
                    constant :(val :integer);
               variable, PLprocedure :(level, adr :integer)
             end;
  }

procedure ERROR(n:integer);
begin {Writeln(output,' ****',' ':cc-1,'^',n:2);}
      writeln(' ****',' ':cc-1,'^',n:2); err:=err+1
end{ERROR};

procedure GETSYM;
  var i, j, k :integer;
  
  procedure GETCH;
  begin if cc=ll then
     begin if eof(input) then
         begin write(output,'PROGRAM INCOMPLETE'); halt;
         end;
         ll:=0; cc:=0; write(output,cx:5,' ');
         while not(eoln(input)) do
            begin ll:=ll+1; read(input,ch); write(output,ch); line[ll]:=ch
            end;
         writeln(output); ll:=ll+1; read(input,line[ll]); {read(input,dummy);}
     end;
     cc:=cc+1; ch:=line[cc]
  end {getch};

  begin{GETSYM}
  while (ch=' ') do GETCH;
    if ch in ['A'..'Z'] then
    begin {identifier or reserved word} 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(output,' PROGRAM TOO LONG');}
              write(' PROGRAM TOO LONG'); halt;
        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;   {initial table index}
   cx0 :integer;   {initial code index}

  procedure ENTER(k:PLobject);
  begin {ENTER PLobject into table}
    tx:=tx+1; 
    {table1[tx]:=id;} 
    with table[tx] do
    begin kind:=k;
      name:=id;
      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;
      PLprocedure : level:=lev
      end
    end
  end{ENTER};

  function POSITION(id:alfa1):integer;
  var i:integer;
  begin {find identifier id in table}
  table[1].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{list code generated for this block}
    for i:=cx0 to cx-1 do
      with code[i] do begin
        Writeln(output,i,mnemonic[f]:5, l:3, a:5);
        writeln(i,'  ',mnemonic[f]:5, l:3, a:5)
      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=1 then ERROR(11) else
              with table[i] do
              case kind of
                constant :GEN(lit,0,val);
                variable :GEN(lod,lev-level,adr);
                PLprocedure :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,[lparen],23)
          end
        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
      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);
            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=1 then ERROR(11) else
      if table[i].kind<>variable then
          begin{assignment to non-variable} 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=1 then ERROR(11) else
          with table[i] do
            if kind=PLprocedure 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(PLprocedure); 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;{start adr of code}
    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;  {program-, base-, topstack-registers}
      i :instruction;  {instruction register}
      s :array[1..stacksize] of integer; {datastore}

  function BASE(l:integer):integer;
    var b1 :integer;
  begin b1:=b; {find base l levels down}
    while l > 0 do
      begin b1:=s[b1]; l:=l-1
      end;
    BASE:=b1
  end{BASE};

begin{INTERPRET} {writeln(output,' START PL/0');}
                 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    {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;
       end;
    lod :begin t:= t+1; s[t]:= s[BASE(l)+a]
         end;
    sto :begin s[BASE(l)+a]:= s[t]; {writeln(output,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 :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 ;
  {Write(output,' END PL/0');}
  write(' END PL/0');
end{INTERPRET};

begin{main program}
  for ch1:='A' to ';' do ssym[ch1] := nul;
  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] := 'THEN      ';     word[10] := 'VAR       ';
  word[11] := '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];
  facbegsys:=[ident, number, lparen];
  cc:=0; cx:=0; ll:=0; ch:=' '; kk:=al; err:=0;
  GETSYM;
  BLOCK(0,1,[period]+declbegsys+statbegsys);
  if sym<>period then ERROR(9);
  if err = 0 then INTERPRET else begin
    write(' ERRORS IN PL/0 PROGRAM');
  end;
  writeln
end.
   




