program PL0 (input,output);
(*PL/0 compiler with code generation*)
(*Program 5.6 in Algorithms + Data Structures = Programs*)
(*Almost identical with the version in Compilerbau*)
(*Author: Niklaus Wirth*)
label 
  99;
const
  norw = 11;      (*no. of reserved words*)
  txmax = 100;    (*length of identifier 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);
  alfa =    packed array[1..al] of char;
  object = (constant,variable,prozedure);
  symset = set of symbol;
  fct =    (lit,opr,lod,sto,cal,int,jmp,jpc);   (*functions*)
  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: char;    (*last character read*)
  sym: symbol; (*last symbol read*)
  id: alfa;    (*last identifier read*)
  num: integer;(*last number read*)
  cc: integer; (*character count*)
  ll: integer; (*line length*)
  kk,err: 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[char] of symbol;
  mnemonic: array[fct] of 
              packed array[1..5] of char;
  declbegsys,statbegsys,facbegsys: symset;
  table: 
    array[0..txmax] of
    record 
      name: alfa;
      case kind: object of
      constant: (val: integer);
      variable,prozedure: (level,adr: integer)
    end;

procedure error(n: integer);
begin
  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
        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 (*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
(*extra stuff added to support <=*)
        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:= gtr
          end
          else
(*end of extra stuff*)
      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:object);
  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;
        prozedure:
          level:= lev;
      end
    end
  end (*enter*);

  function position(id: alfa): integer;
  var
    i: integer;
  begin (*find identifier id 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*)
    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
          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);
                  prozedure:  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