The PL/0 compiler/interpreter

The PL/0 compiler/interpreter

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
      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 = 0 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 = 0 then
            error(11)
          else
            with table[i] do
              if kind = prozedure 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(prozedure);
        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
  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(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('End PL/0');
end (*interpret*);

begin (*main program*)
  for ch:= 'A' to ';' do
    ssym[ch]:= 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];
  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
    write('errors in PL/0 Program');
99:
  writeln
end.

Kilder

• Guide to the PL/0 Compiler, http://www.cs.rochester.edu/courses/254/PLzero/guide.pdf

---

February 9, 2006. Birger Nielsen, bnielsen@daimi.au.dk, drinker of tea. This document: http://www.246.dk/pl0.html