This file comprises two P test programs and the Pascal source of the simple
recursive-descent P compiler/interpreter separated by asterisks.
Copyright (c) P.C.Capon & P.J.Jinks 1988
May be copied for educational purposes only, with the copyright notice
attached.
*******************************************************************************
{ runs correctly - figure 2.1 }
VAR S, N, T;
BEGIN
  S := 0;   {sum}
  N := 0;   {number of items}
  T := READ;
  WHILE T <> 0 {not end of file} DO BEGIN
    S := S + T;
    N := N + 1;
    T := READ;
  END;
  WRITE (N);
  WRITE (S);
  IF N <> 0 THEN
    WRITE (S / N); {average}
END.

2 3 4 5 6 7 8 0
******************************************************************************
{ fails at run time - figure 5.2 }
VAR S, N, T;
BEGIN
  S := 0;   {sum}
  N := 0;   {number of items}
  T := READ;
  WHILE T <> 0 {not end of file} DO BEGIN
    S := S + T;
    N := N + 1;
    T := READ;
  END;
  WRITE (N);
  WRITE (S);
  IF N <> 0 THEN
    WRITE (S / N); {average}
  T := 0;
  T := T / T;
END.

2 3 4 5 6 7 8 0
******************************************************************************
program run (input,output);

{Copyright (c) P.C.Capon & P.J.Jinks 1988}
{may be copied for educational purposes only,}
{with the copyright notice attached.}

label 999;
 
const
  linewidth = 256;
  namechars = 6;
  nulop = 0;
  readproc = 1; writeproc = 2; {call operands}
  stack = 1; unstack = 2; nooperand = 3; {special operands}
  maxcode = 500;
  maxstack = 100;
  maxvar = 26;
 
type
  lexemetype = (dot, constant, identifier, comma, assign,
             semicolon, lbracket, rbracket, addop, mulop, relop,
             beginlexeme, readlexeme, writelexeme, iflexeme,
             thenlexeme, whilelexeme, dolexeme, varlexeme,
             endlexeme, unknown);
  addvaltype = (add, sub);
  mulvaltype = (mul, divd);
  relvaltype = (eq, ne, gt, lt, ge, le);
  nametype = packed array [1..namechars] of char;
  lexemevaltype = record
    case lexemetype of
    constant:   (constval: integer);
    identifier: (idval: char);
    addop:      (addval: addvaltype);
    mulop:      (mulval: mulvaltype);
    relop:      (relval: relvaltype);
    end;
  lexemesettype = set of lexemetype;
  functiontype = (accload, accstore, stackaccload, accplus,
               accminus, minusacc, acctimes, accdiv, divacc,
               stop, call, acccompare, br,
               breq, brne, brlt, brle, brge, brgt);
  optypetype = (specialop, constop, varop, labelop);
  calltype = readproc..writeproc;
  mode = specialop .. varop;
  data = integer;
  address = 0..maxcode;
  inst = record
    case funct: functiontype of
    accload, accstore, stackaccload, accplus, accminus, minusacc,
    acctimes, accdiv, divacc, acccompare:
          (accmode: mode; accval: data);
    br, breq, brne, brlt, brle, brge, brgt:
          (brval: address);
    call: (callval: calltype);
    stop: ();
    end;
 
var
  linesize: 0..linewidth; {number of chars in line}
  linepos: integer; {position of next char in line}
  line: array[1..linewidth] of char;
  lexeme, firstlexeme, lastlexeme: lexemetype;
  lexemeval: lexemevaltype;
  errors: boolean;
  lexemes: array [lexemetype] of nametype;
  startexp, startblock: lexemesettype;
  variables: array['A'..'Z'] of -1..maxint;
  {-1=undefined, 0=not used, >0=address}
  nextvariable: 1..maxint; {address of next variable declared}
  accinuse: boolean;
  codepos: 0..maxint; {position to plant next piece of code}
  forwardadd, reverseadd: array [addvaltype] of functiontype;
  forwardmul, reversemul: array [mulvaltype] of functiontype;
  normalskip, reverseskip: array [relvaltype] of functiontype;
  fnnames: array [functiontype] of nametype;
  store: array [address] of inst;
  branchset: set of breq..brgt;
  machinestack: array [0..maxstack] of data;
  pc: -1..maxcode;
  acc: data;
  sf: -1..maxstack;
  stoprun: boolean;
  vars: array [1..maxvar] of
    record
    defined: boolean;
    varval: data;
    end;
 
{ procedures and functions }
 
procedure error (n :integer);
begin
  write('^':linepos - 1);
  case n of
  1  : writeln('end of input encountered');
  2  : writeln('line too long, max width= ', linewidth);
  3  : {unexpected symbol};
  4  : writeln('unknown character');
  5  : writeln('= expected after :');
  6  : writeln('unknown keyword');
  7  : writeln('lexeme skipped after error');
  8  : writeln('variable already declared');
  9  : writeln('variable not declared');
  10 : writeln('code overflow');
  end;
  errors := true;
end;
 
procedure getlexeme;
  var ch: char;
      name: nametype;
      charno: integer;
 
function nextch:char;
begin
  if linepos>linesize then
    if eof then begin
      error(1); {end of file encountered}
      goto 999; {fatal error}
      end
    else begin
      linesize := 1;
      while (not eoln) and (linesize<linewidth) do begin
        read(line[linesize]);
        write(line[linesize]);
        linesize := linesize + 1;
      end;
      writeln;
      if eoln then begin
        line[linesize] := ' ';
        readln;
        end
      else begin
        linesize := linesize - 1;
        error(2); {line too long}
      end;
      linepos := 1;
    end;
  nextch := line[linepos];
end;
 
function getch: char;
begin
  getch := nextch;
  linepos := linepos + 1;
end;
 
begin {getlexeme}
  { ignore spaces and comments }
  while nextch in [' ','{'] do begin
    ch := getch;
    if ch = '{' then
      repeat
      until getch='}';
  end;
  ch := getch;
  if ch in ['0'..'9'] then begin { try to recognise a constant }
    lexeme := constant;
    lexemeval.constval := ord(ch) - ord('0');
    end
  else if ch in ['A'..'Z'] then
    { try to recognise an identifier or keyword }
    if not (nextch in ['A'..'Z']) then begin
      lexeme := identifier;
      lexemeval.idval := ch;
      end
    else begin {try to recognise read,write,if,then,var,begin or end}
      for charno := 2 to namechars do
        name[charno] := ' ';
      charno := 2;
      name[1] := ch;
      while nextch in ['A'..'Z'] do
        if charno <= namechars then begin
          name[charno] := getch;
          charno := charno + 1;
          end
        else
          ch := getch;
      lexeme := beginlexeme;
      while (lexeme <= endlexeme) and (name <> lexemes[lexeme]) do
        lexeme := succ (lexeme);
      if lexeme > endlexeme then begin
        lexeme := unknown;
        error(6); {unknown name}
      end;
    end
  else begin { try to recognise:- , ; := ( ) + - * / <=> }
    if ch in [',',';',':','(',')','+','-','*','/','<','=','>','.']
        then
      case ch of
      '.': lexeme := dot;
      ',': lexeme := comma;
      ';': lexeme := semicolon;
      ':': if nextch = '=' then begin
             ch := getch;
             lexeme := assign;
             end
           else begin
             error(5); {: not followed by =}
             lexeme := unknown;
           end;
      '(': lexeme := lbracket;
      ')': lexeme := rbracket;
      '+': begin lexeme := addop; lexemeval.addval := add end;
      '-': begin lexeme := addop; lexemeval.addval := sub end;
      '*': begin lexeme := mulop; lexemeval.mulval := mul end;
      '/': begin lexeme := mulop; lexemeval.mulval := divd end;
      '<': begin
             lexeme := relop;
             ch := nextch;
             if ch = '=' then begin
               ch := getch;
               lexemeval.relval := le;
               end
             else if ch = '>' then begin
               ch := getch;
               lexemeval.relval := ne;
               end
             else
               lexemeval.relval := lt;
           end;
      '=': begin lexeme := relop; lexemeval.relval := eq end;
      '>': begin
             lexeme := relop;
             if nextch = '=' then begin
               ch := getch;
               lexemeval.relval := ge;
               end
             else
               lexemeval.relval := gt;
           end;
      end
    else begin
      lexeme := unknown;
      error (4); {unknown characters}
    end;
  end;
end; {getlexeme}
 
procedure declid;
begin
  if variables[lexemeval.idval] > 0 then
    error(8) {variable already declared}
  else begin
    variables[lexemeval.idval] := nextvariable;
    nextvariable := nextvariable + 1;
  end;
end;
 
procedure checkid;
begin
  if variables[lexemeval.idval] = 0 then begin
    error(9); {variable not declared}
    variables[lexemeval.idval] := -1;
    { to stop further error messages }
  end;
end;
 
procedure listaline (pos: address);
begin
  with store[pos] do begin
    write (pos:3,' : ',fnnames[funct],' ');
    case funct of
    accload,accstore,stackaccload,accplus,accminus,minusacc,
    acctimes,accdiv,divacc,acccompare:
      case accmode of
      varop    :write ('variable ', accval:1);
      constop  :write ('constant ', accval:1);
      specialop: 
        case accval of
        stack    :write ('stack    ');
        unstack  :write ('unstack  ');
        nooperand:;
        end;
      end;
    br, brne, breq, brlt, brle, brge, brgt:
      write (brval :1);
    call:
      if callval = readproc then
        write ('read')
      else if callval = writeproc then
        write ('write')
      else
        write (callval :3);
    stop:;
    end;
  end;
  writeln;
end;
 
procedure listing;
  var i: address;
begin
  writeln ;
  writeln ('assembly listing of compiled code');
  writeln ('=================================');
  writeln ;
  for i := 0 to codepos - 1 do
    listaline (i);
  writeln;
end;
 
procedure plant(fn: functiontype; optype: optypetype;
                 opval: integer);
begin
  if codepos >= maxcode then begin
    error (10);
    codepos := 0; {not very satisfactory, but adequate}
  end;
  with store [codepos] do begin
    funct := fn;
    case optype of
      specialop:
        begin
          accmode := specialop;
          accval := opval;
        end;
      labelop:
        if fn = call then
          callval := opval
        else
          brval := opval;
      constop:
        begin
          accval := opval;
          accmode := constop;
        end;
      varop:
        begin
          accval := opval;
          accmode := varop;
        end;
      end;
      write ('plant ');
      listaline (codepos);
      codepos := codepos + 1;
 end;
end;
 
procedure plantforwardlabel(pos: integer);
begin
  writeln('label: used from ', pos);
  store[pos].brval := codepos;
end;
 
function saveforwardlabel: integer;
begin
  writeln('label used');
  saveforwardlabel := codepos;
end;
 
function savelabel: integer;
begin
  writeln('label:');
  savelabel := codepos;
end;
 
procedure plantaccload (optype: optypetype; opval: integer);
begin
  if optype <> specialop then
    if accinuse then
      plant (stackaccload, optype, opval)
    else
      plant (accload, optype, opval);
  accinuse := true;
end;
 
function checkorskip (okset, stopset: lexemesettype): boolean;
  var alexeme: lexemetype;
      orflag: boolean;
begin
  if lexeme in okset then
    checkorskip := true
  else begin
    checkorskip := false;
    error(3); {okset expected}
    orflag := false;
    for alexeme := firstlexeme to lastlexeme do
      if alexeme in okset then begin
        if orflag then
          write(' or ');
        orflag := true;
        write(lexemes[alexeme]);
      end;
    writeln(' expected');
    if stopset <> [] then
      while not (lexeme in stopset) do begin
        error(7); {lexeme skipped after error}
        getlexeme;
      end;
  end;
end;
 
procedure idlist (stopset: lexemesettype);
  var ignore, finish: boolean;
begin
  repeat
    if checkorskip([identifier], stopset + [semicolon, comma]) then
      begin
      declid;
      getlexeme;
    end;
    ignore := checkorskip([semicolon, comma], 
              stopset + [comma, identifier]);
    finish := not (lexeme in [comma, identifier]);
    if lexeme = comma then
      getlexeme;
  until finish;
  if lexeme = semicolon then
    getlexeme;
end;
 
procedure expression (stopset: lexemesettype; var optype: optypetype;
                      var opval: integer); forward;
 
procedure factor (stopset: lexemesettype; var optype: optypetype;
                  var opval: integer);
begin
  optype := specialop;
  if checkorskip(startexp, stopset) then
    if lexeme = identifier then begin
      checkid;
      optype := varop;
      opval := variables[lexemeval.idval];
      getlexeme;
      end
    else if lexeme = constant then begin
      optype := constop;
      opval := lexemeval.constval;
      getlexeme;
      end
    else if lexeme = lbracket then begin
      getlexeme;
      expression(stopset + [rbracket], optype, opval);
      if checkorskip([rbracket], stopset) then
        getlexeme;
      end
    else if lexeme = readlexeme then begin
      getlexeme;
      if accinuse then
        plant(accstore, specialop, stack);
      plant(call, labelop, readproc);
      accinuse := true;
      optype := specialop;
    end;
end;
 
procedure term (stopset: lexemesettype; var optype: optypetype;
                var opval: integer);
  var operator: mulvaltype;
      roptype: optypetype;
      ropval: integer;
begin
    factor(stopset + [mulop], optype, opval);
    while lexeme = mulop do begin
      plantaccload (optype, opval);
      optype := specialop;
      operator := lexemeval.mulval;
      getlexeme;
      factor(stopset + [mulop], roptype, ropval);
      if roptype = specialop then
        plant(reversemul[operator], specialop, unstack)
      else
        plant(forwardmul[operator], roptype, ropval);
    end;
end;
 
procedure expression;
  var operator: addvaltype;
      roptype: optypetype;
      ropval: integer;
begin
    term(stopset + [addop], optype, opval);
    while lexeme = addop do begin
      plantaccload (optype, opval);
      optype := specialop;
      operator := lexemeval.addval;
      getlexeme;
      term(stopset + [addop], roptype, ropval);
      if roptype = specialop then
        plant(reverseadd[operator], specialop, unstack)
      else
        plant(forwardadd[operator], roptype, ropval);
    end;
end;
 
procedure block (stopset: lexemesettype); forward;
 
procedure comparison(stopset: lexemesettype; var iflabel: integer);
  var compareop: relvaltype;
      optype: optypetype;
      opval: integer;
begin
  expression(stopset + [relop], optype, opval);
  plantaccload (optype, opval);
  if checkorskip([relop], stopset + startexp) then begin
    compareop := lexemeval.relval;
    getlexeme;
    end
  else
    compareop := eq;
  expression(stopset + startblock - [identifier], optype, opval);
  if optype <> specialop then begin
    plant(acccompare, optype, opval);
    iflabel := saveforwardlabel;
    plant(normalskip[compareop], labelop, nulop);
    end
  else begin
    plant(acccompare, specialop, unstack);
    iflabel := saveforwardlabel;
    plant(reverseskip[compareop], labelop, nulop);
  end;
end;
 
procedure statement (stopset: lexemesettype);
  var assignto: integer;
      optype: optypetype;
      opval, iflabel, whilelabel: integer;
begin
  accinuse := false;
  if checkorskip(stopset + startblock, stopset) then
    if lexeme = identifier then begin
      checkid;
      assignto := variables[lexemeval.idval];
      getlexeme;
      if checkorskip([assign], stopset + startexp) then
        getlexeme;
      expression(stopset, optype, opval);
      plantaccload (optype, opval);
      plant(accstore, varop, assignto);
      end
    else if lexeme = iflexeme then begin
      getlexeme;
      comparison(stopset + [thenlexeme] + startblock - [identifier],
                 iflabel);
      if checkorskip([thenlexeme], stopset + startblock) then
        getlexeme;
      block(stopset);
      plantforwardlabel(iflabel);
      end
    else if lexeme = whilelexeme then begin
      getlexeme;
      whilelabel := savelabel;
      comparison(stopset + [dolexeme] + startblock - [identifier],
                 iflabel);
      if checkorskip([dolexeme], stopset + startblock) then
        getlexeme;
      block(stopset);
      plant(br, labelop, whilelabel);
      plantforwardlabel(iflabel);
      end
    else if lexeme = writelexeme then begin
      getlexeme;
      if checkorskip([lbracket], stopset + [rbracket] + startexp) then
        getlexeme;
      expression(stopset + [rbracket], optype, opval);
      plantaccload (optype, opval);
      if checkorskip([rbracket], stopset) then
        getlexeme;
      plant(accstore, specialop, stack);
      plant(call, labelop, writeproc);
    end;
end;
 
procedure block;
  var ignore: boolean;
begin
  ignore := checkorskip(stopset + startblock, stopset + startblock);
  if lexeme = beginlexeme then begin
    getlexeme;
    block(stopset + [semicolon, endlexeme]);
    ignore := checkorskip([semicolon, endlexeme],
                         stopset + [semicolon] + startblock);
    while lexeme in ([semicolon] + startblock) do begin
      if lexeme = semicolon then
        getlexeme;
      block(stopset + [semicolon, endlexeme]);
      ignore := checkorskip([semicolon, endlexeme],
                           stopset + [semicolon] + startblock);
    end;
    if lexeme = endlexeme then
      getlexeme;
    end
  else
    statement(stopset);
end;
 
procedure prog; { recognise p program }
begin
  if lexeme = varlexeme then begin
    getlexeme;
    idlist([beginlexeme, semicolon, dot]);
  end;
  repeat
    block([dot]);
  until checkorskip([dot],[]);
end;
 
procedure runerror(message: packed array [lo..hi:integer] of char);
  var i : integer;
begin
  writeln;
  write ('*** runtime error - ');
  for i := lo to hi do
    write (message [i]);
  writeln (' at address ',pc:1,' ***');
  writeln;
  for i := 1 to maxvar do
    if vars[i].defined then
      writeln ('variable ',i:2,' = ',vars[i].varval:1);
  writeln;
  writeln ('accumulator = ',acc:1);
  writeln;
  writeln ('stack front = ', sf);
  for i := 0 to sf do
    writeln ('stack item ', i, ' =', machinestack [i]);
goto 999;
end;
 
procedure push (d : data);
begin
  if sf = maxstack then
    runerror ('stack overflow');
  sf := sf + 1;
  machinestack [sf] := d;
end;
 
function pop : data;
begin
  if sf = -1 then
    runerror ('stack underflow');
  pop := machinestack [sf];
  sf := sf - 1;
end;
 
function getop : data;
begin
  with store [pc] do
    case accmode of
    specialop:
      if accval = unstack then
        getop := pop
      else
        runerror ('illegal operand');
    constop: getop := accval;
    varop:
      if vars[accval].defined then
        getop := vars[accval].varval
      else
        runerror ('undefined variable');
    end; { case }
end;
 
procedure interpret; { a single instruction }
  var operand : data;
begin
  pc := pc + 1;
  with store[pc] do begin
    case funct of
    accload: 
      acc := getop;
    stackaccload:
      begin
        push (acc);
        acc := getop;
      end;
    accplus:
      acc := acc + getop;
    accminus:
      acc := acc - getop;
    minusacc:
      acc := getop - acc;
    acctimes:
      acc := acc * getop;
    accdiv:
      begin
        operand := getop;
        if operand = 0 then
          runerror ('division by zero');
        acc := acc div operand;
      end;
    divacc:
      begin
        if acc = 0 then
          runerror ('division by zero');
        acc := getop div acc;
      end;
    accstore:
      with store[pc] do
        case accmode of
        constop:
          runerror('illegal operand');
        varop:
          with vars [accval] do begin
            defined := true;
            varval  := acc;
          end;
        specialop:
          if accval = stack then
            push (acc)
          else
            runerror ('illegal operand');
        end;
    acccompare:
      begin
        operand := getop;
        if acc = operand then
          branchset := [breq]
        else
          branchset := [brne];
        if acc < operand then
          branchset := branchset + [brlt]
        else
          branchset := branchset + [brge];
        if acc <= operand then
          branchset := branchset + [brle]
        else
          branchset := branchset + [brgt];
      end;
    brne, breq, brle, brlt, brgt, brge:
      if funct in branchset then
        pc := brval - 1;
    br:
      pc := brval - 1;
    call:
      if callval = readproc then
        read (acc)
      else if callval = writeproc then
        writeln (pop:1)
      else
        runerror ('illegal call operand');
    stop:
      stoprun := true;
    end; { case }
  end; { with }
end; { interpret }
 
procedure init;
var
  i: 0..maxvar;
  ch : char;
begin
  linesize := 0;
  linepos := 1;
  errors := false;
  firstlexeme := dot;
  lexemes[dot]           := '.     ';
  lexemes[constant]      := 'digit ';
  lexemes[identifier]    := 'name  ';
  lexemes[comma]         := ',     ';
  lexemes[assign]        := ':=    ';
  lexemes[semicolon]     := ';     ';
  lexemes[lbracket]      := '(     ';
  lexemes[rbracket]      := ')     ';
  lexemes[addop]         := '+ or -';
  lexemes[mulop]         := '* or /';
  lexemes[relop]         := '<=>   ';
  lexemes[beginlexeme]   := 'BEGIN ';
  lexemes[readlexeme]    := 'READ  ';
  lexemes[writelexeme]   := 'WRITE ';
  lexemes[iflexeme]      := 'IF    ';
  lexemes[thenlexeme]    := 'THEN  ';
  lexemes[whilelexeme]   := 'WHILE ';
  lexemes[dolexeme]      := 'DO    ';
  lexemes[varlexeme]     := 'VAR   ';
  lexemes[endlexeme]     := 'END   ';
  lexemes[unknown]       := '?     ';
  lastlexeme := unknown;
  startexp := [lbracket, identifier, constant, readlexeme];
  startblock := [beginlexeme, identifier, iflexeme, whilelexeme,
                 writelexeme];
  nextvariable := 1;
  for ch := 'A' to 'Z' do
    variables[ch] := 0;
  codepos := 0;
  forwardadd[add]  := accplus;
  forwardadd[sub]  := accminus;
  reverseadd[add]  := accplus;
  reverseadd[sub]  := minusacc;
  forwardmul[mul]  := acctimes;
  forwardmul[divd] := accdiv;
  reversemul[mul]  := acctimes;
  reversemul[divd] := divacc;
  normalskip[eq] := brne;
  normalskip[ne] := breq;
  normalskip[gt] := brle;
  normalskip[lt] := brge;
  normalskip[ge] := brlt;
  normalskip[le] := brgt;
  reverseskip[eq] := brne;
  reverseskip[ne] := breq;
  reverseskip[gt] := brge;
  reverseskip[lt] := brle;
  reverseskip[ge] := brgt;
  reverseskip[le] := brlt;
  fnnames[accload]      := 'acc=  ';
  fnnames[accstore]     := 'acc=> ';
  fnnames[stackaccload] := '<acc= ';
  fnnames[accplus]      := 'acc+  ';
  fnnames[accminus]     := 'acc-  ';
  fnnames[minusacc]     := '-acc  ';
  fnnames[acctimes]     := 'acc*  ';
  fnnames[accdiv]       := 'acc/  ';
  fnnames[divacc]       := '/acc  ';
  fnnames[call]         := 'call  ';
  fnnames[acccompare]   := 'accom ';
  fnnames[br]           := 'br    ';
  fnnames[breq]         := 'breq  ';
  fnnames[brne]         := 'brne  ';
  fnnames[brlt]         := 'brlt  ';
  fnnames[brle]         := 'brle  ';
  fnnames[brge]         := 'brge  ';
  fnnames[brgt]         := 'brgt  ';
  fnnames[stop]         := 'stop  ';
  pc := -1;
  acc := 0;
  sf := -1;
  branchset := [];
  for i := 1 to maxvar do
    vars [i].defined := false;
  stoprun := false;
end;
 
begin
  init;
  getlexeme;
  prog;
  plant (stop, specialop, nooperand);
  if not errors then begin
    listing;
    repeat
      interpret;
    until stoprun;
  end;
999:
end.