program pl0(fa,fa1,fa2);
(*pl0 compiler with code generation*)

label 99;

const norw=13;
      txmax=100;
      nmax=14;
      al=10;
      amax=2047;
      levmax=3;
      cxmax=200;

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;
      obj = (constant,variable,procedur);
      symset = set of symbol;
      fct = (lit,opr,lod,sto,cal,int,jmp,jpc);
      instruction = packed record
                      f : fct;
                      l : 0..levmax;
                      a : 0..amax;
                    end;


var
  fa : text;
  fa1,fa2 : text;
  listswitch : boolean;
  ch : char;
  sym : symbol;
  id : alfa;


  num : integer;   (* last munber 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 "arry[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 : obj of
                              constant : (val:integer);
                              variable, procedur : (level,adr,size:integer)
                    (*"size" lacking in original. I think it belongs here*)
                            end;
  fin,fout:text;
  fname:alfa;
  err:integer;
  procedure error(n:integer);
  begin
    writeln (' * * * * ', ' ' : cc-1,'!',n:2);
    writeln (fa1,' * * * * ' , ' ' : cc-1, '!', n:2);
    err:=err+1
  end  (*error*);
 procedure getsym;
 var i,j,k:integer;
   procedure getch;        (**************  getch   *******************)
   begin
     if cc=ll then
     begin
       if eof(fin) then
       begin
         write('program incomplete');
         (********************************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]);
       writeln(fa1);
     end;
     cc:=cc+1;
     ch:=line[cc]
   end(*getch*);


 begin(*getsym*)
   while ch='' do getch;
   if ch in ['a'..'z'] then
   begin               (*id 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
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:=geq
                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;   (* initial table index *)
   cx0:integer;   (* initial code  index*)
procedure enter(k:obj);
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  (*list code generated for this block*)
  if listswitch then
  begin
    for i:=cx0 to cx-1 do
      with code[i] do
      begin
        writeln(fa,i:4,mnemonic[f]:5,1: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);