This series quotes Wirth constantly — “Wirth’s own device”, “the shape Wirth’s getsym had”, “he patched the address field by hand”. This appendix is so that those references mean something: it is his compiler, complete, as published.

Read it. It is 500 lines of Pascal, it compiles a real language, it interprets what it compiles, and it was written when the machine it ran on had less memory than a modern keyboard’s firmware. Very little published software repays reading this well.

Provenance

PL/0 appeared in Algorithms + Data Structures = Programs (1975 — the English edition only; the German Algorithmen und Datenstrukturen does not carry it), and the full Pascal source below appeared in Compilerbau (1977). Later editions changed language: the 1984 third edition rewrote the compiler in Modula and added print statements, and after Oberon was conceived, PL/0 was succeeded as the teaching language by Oberon-0.

The source below is the 1975/77 Pascal version.

Attribution. PL/0 — the language, the compiler, and the source below — is the work of Niklaus Wirth (1934–2024), and the text is his, from Algorithms + Data Structures = Programs (Prentice-Hall, 1975) and Compilerbau (Teubner, 1977). It is reproduced here unmodified, for study, which is the purpose it was written and published for; the listing has been reprinted in teaching material for five decades on that understanding. No claim of ownership is made over it, and nothing in this series is a substitute for the books — if this appendix sends you to them, it has done its job. Wirth himself made his later compiler books freely available on his ETH Zürich page, in the same spirit of open teaching this appendix relies on. Should any rights holder prefer this listing not appear here, write to info@mica-dev.com and it will be removed.

Everything in this series other than this appendix — the two twins, the chapters, and the commentary below — is original work and is not Wirth’s, though the design it follows plainly is.

What to look at first

Six things in this listing changed how compilers are written. If you read nothing else, read these.

1. getsym — the scanner, and getch nested inside it. The lookahead character ch is a global, refilled by an inner procedure that also echoes the source line as it reads it — which is how the listing and the diagnostics line up on a printer. Note kk, the identifier-padding index: names are fixed-width packed array [1..10] of char, so comparison is a single Pascal = on a whole array.

2. The binary search over word.

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

Two comparisons per step and a termination test that doubles as the found test. This is the code chapter 4 calls “Wirth’s own lookup device”, and both twins still do exactly this.

3. position and its sentinel.

function position(id: alfa): integer;
   var i: integer;
begin {find indentifier id in table}
   table[0].name := id; i := tx;
   while table[i].name <> id do i := i-1;
   position := i
end {position};

The name being searched for is written into slot 0 before the search, so the backward loop is guaranteed to terminate without a bounds test — and a return of 0 means “not found”. One assignment removes a comparison from every iteration.

The twins do not keep this trick, and it is worth knowing why: it writes to the table in order to read it, which makes position unable to take a const parameter and makes two searches unsafe to run at once. In 1975 that was free; today the compiler’s bounds check costs nothing and the sentinel costs thread-safety.

4. test — the entire error-recovery strategy, in four lines.

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};

That is what chapter 6 is about, and the twins’ parser_expect / Expect is this procedure with better messages.

5. The nesting of statement, expression, term, factor. They are declared inside each other, so each sees the enclosing one’s fsys and locals. Precedence is that nesting. And notice the shape of factor: it calls expression, which is three levels out — the recursion that makes parentheses work.

6. The backpatch, written by hand, twice.

cx1 := cx; gen(jpc, 0, 0);
statement(fsys); code[cx1].a := cx

The jump is emitted with a target of 0, the position is remembered in cx1, and after the body is generated the address field is patched with the position now known. That is what the seam in chapter 7 replaces with new_label / place_label — and the reason it is worth replacing is visible here: the caller has to know that a jump has an address field.

Where his procedures went

WirthIn this series
getsym, getchscanner — chapter 4
table, enter, positionsymbols — chapter 5
block, statement, expression, term, factor, condition, testparser — chapter 6
gen, code, mnemonic, listcodepcode, the emitter half — chapter 8
interpret, basepcode, the interpreter half — chapter 8
errordiagnostics
—spectra, the second back end — chapter 9
main programthe driver

Everything the twins have that Wirth does not is in the last two rows. Everything else is his design, restructured but not redesigned.

Three honest curiosities

Reading original source is more instructive when you notice the human parts.

varible. Wirth’s own spelling, in the type declaration and everywhere it is used:

object = (constant,varible,proc);

A typo, propagated consistently for fifty years of reprints, and harmless because a compiler does not care how you spell your own enumerators. It is a useful reminder of what “correct code” does and does not mean.

cx0 := 0{cx}; — an expression commented out in place, evidence of an edit made and half-undone before publication. cx0 is then used only by listcode, so setting it to 0 makes each block list all code generated so far rather than its own.

ssym['['] := leq; ssym[']'] := geq; — [ and ] stand for <= and >=. Not a design statement about brackets: the scanner recognizes single characters through one array indexed by the character, and two-character operators would have needed a second lookahead. := gets that lookahead because it must; the comparisons get square brackets instead. The twins recognize <= and >= properly, which costs six lines.

One caution about published grammars

Some references print PL/0’s statement rule with two extra alternatives:

statement = [ ident ":=" expression | "call" ident
            | "?" ident | "!" expression
            | ... ] .

? ident reads a value and ! expression writes one. The 1975 Pascal source below does not implement them — search statement and you will find no case for either. They come from later variants, added by Wirth in the Modula edition and by many others since, precisely because the “every store prints” rule is charming but limiting.

The twins follow the original: no input, no output statement, and every store prints. If you want ! and ?, that is exercise 5 in chapter 11.

The source

program pl0(input,output);
{pl/0 compiler with code generation}
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,varible,proc);
    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 varible l,a
    sto l,a  :  store varible 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);
              varible, proc: (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 write(' 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; readln; ll := ll + 1; 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
   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(30); num :=0 end;
                      val := num
                   end;
         varible: begin level := lev; adr := dx; dx := dx + 1;
                  end;
         proc: level := lev
         end
      end
   end {enter};

   function position(id: alfa): integer;
      var i: integer;
   begin {find indentifier 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(varible); 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:5, mnemonic[f]:5, 1: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);
                        varible: gen(lod, lev-level, adr);
                        proc: error(21)
                     end;
                     getsym
                  end else
                  if sym = number then
                  begin if num >  amax then
                           begin error(30); 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 <> varible then
            begin {assignment to non-varible} 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=proc 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(proc); 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 := 0{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 := chr(0) to chr(255) 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.

The 1975 grammar, as published

program = block .

block = [ const ident = number {, ident = number} ;]
        [ var ident {, ident} ;]
        { procedure ident ; block ; } statement .

statement = [ ident := expression | call ident
              | begin statement {; statement } end
              | if condition then statement
              | while condition do statement ].

condition = odd expression |
            expression (=|#|<|<=|>|>=) expression .

expression = [ +|-] term { (+|-) term}.

term = factor {(*|/) factor}.

factor = ident | number | ( expression )

Read it beside the twins

The most valuable hour you can spend with this series is to put this listing on one side of the screen and sdk/pl0/c/parser.c on the other, and read statement in both.

They are the same procedure. One has globals, goto 99, and gen(jpc, 0, 0) followed by a hand patch; the other has a struct, a returned failure, and a named label. Nothing about the parse changed in fifty years — and that is the point the whole series is making.

Back to: the chapter list, or on to chapter 7 — The seam.