Appendix.

{System dependent, this as per Sun:} {procedure setlinebuffering; external;}

program functional(input, output);

label 99; {error failure; stop}

type alfa = packed array [1..10] of char;

#include "lex.type.P"      {Lexical Types}
#include "syntax.type.P"   {Syntactic Types}

var prog:tree;

#include "syntax.print.P"  {Print a Parse Tree}
#include "syntax.P"        {The Parser}
#include "lazy.exec.P"     {The Interpreter}

begin {setlinebuffering;} { -- System dependent, this as per Sun pre 2016}
      prog:=parser;
      writeln; writeln(' --- end of parsing --- ');
      printtree(prog); writeln; writeln(' --- running --- ');
      execute(prog);
      99:writeln; writeln(' --- finished --- ')
end.

{\fB Lazy Functional Language Interpreter, Main Program. \fP}
{ L. Allison, Dept. Computer Science, Monash University Australia 3168 }
{ http://www.csse.monash.edu.au/~lloyd/tildeFP/Lambda/ }
{Do not remove: Lazy.p, Strict.p, lazy.*.P, strict.*.P, lex.*.P, & syntax.*.P }
{ are released under Gnu `copyleft' General Public Licence (GPL)              }

Routines necessary to complete the parser and interpreter follow.

procedure getch;
   const tab = 9;
begin if eof then begin ch:='.'; theword:='     ' end
      else {not eof} if eoln then
      begin readln; writeln; ch:=' ';
            lineno:=lineno+1; write(lineno:3, ': ')
      end
      else begin {not eof and not eoln} read(ch); write(ch);
                 if ord(ch)=tab then ch:=' '
           end
end{getch};

procedure insymbol;
   const blank='          ';
   var len:integer;
begin repeat while ch=' ' do getch;
             if ch='{' then  { comment }
             begin repeat getch
                   until (ch='}') or eof;
                   getch
             end
      until not( ch in [' ', '{'] );
      if eof then sy:=eofsy
      
      else if ch in ['a'..'z', 'A'..'Z'] then                             {xyz}
      begin theword:=blank;
            len:=0;
            while ch in ['a'..'z', 'A'..'Z', '0'..'9'] do
            begin len:=len+1;
                  if len<=10 then theword[len] := ch;
                  getch
            end; {not ch in ['a'..'z', '0'..'9']}
            if      theword='hd        ' then sy:=hdsy  {not efficient}
            else if theword='tl        ' then sy:=tlsy
            else if theword='lambda    ' then sy:=lambdasy
            else if theword='if        ' then sy:=ifsy
            else if theword='then      ' then sy:=thensy
            else if theword='else      ' then sy:=elsesy
            else if theword='let       ' then sy:=letsy
            else if theword='in        ' then sy:=insy
            else if theword='rec       ' then sy:=recsy
            else if theword='or        ' then sy:=orsy
            else if theword='and       ' then sy:=andsy
            else if theword='not       ' then sy:=notsy
            else if theword='nil       ' then sy:=nilsy
            else if theword='null      ' then sy:=nullsy
            else if theword='true      ' then sy:=truesy
            else if theword='false     ' then sy:=falsesy
            else sy:=word
      end{alphanums}
      
      else if ch in ['0'..'9'] then                            {123}
      begin theint:=0;
            while ch in ['0'..'9'] do
            begin theint:=theint*10+ord(ch)-ord('0'); getch
            end;
            sy:=numeral
      end
      
      else if ch='''' then
      begin getch;
            theword:=blank; theword[1]:=ch; getch;
            if ch='''' then                             { 'z'   charliteral}
               begin getch; sy:=charliteral end
            else error('char lit  ')
      end
      
      else if ch in ['=', '<', '>', '+', '-', '*', '/',
                     '.', ',', ':', '(', ')', '[', ']', '"' ] then
         case ch of
            '<': begin getch;
                       if ch='=' then begin getch; sy:=le end
                       else if ch='>' then begin getch; sy:=ne end
                       else sy:=lt
                 end;
            '>': begin getch;
                       if ch='=' then begin getch; sy:=ge end
                       else sy:=gt
                 end;
            '(': begin getch;
                       if ch=')' then begin getch; sy:=empty end
                       else sy:=open
                 end;
            ':': begin getch;
                       if ch=':' then begin getch; sy:=conssy end
                       else sy:=colon
                 end;
            '=', '+', '-', '*', '/', '.', ',',
            ')', '[', ']', '"':
                 begin case ch of
                       '+': sy:=plus;
                       '-': sy:=minus;
                       '=': sy:=eq;
                       '*': sy:=times;
                       '/': sy:=over;
                       '.': sy:=dot;
                       ',': sy:=comma;
                       '(': sy:=open;  ')': sy:=close;
                       '[': sy:=sqopen; ']': sy:=sqclose;
                       '"': sy:=quote
                       end{case};
                       getch
                 end
         end{case}

      else error('bad symbol')
end{insymbol};

{\fB Lexical Analysis. \fP}

{Do not remove: Lazy.p, Strict.p, lazy.*.P, strict.*.P, lex.*.P, & syntax.*.P }
{ are released under Gnu `copyleft' General Public Licence (GPL)              }
{ - L. Allison, CSSE, Monash Uni., .au, 7/2003.                               }




function parser:tree;
   const applicpriority=7;

   var lineno :integer;                      { state vars for parser}
       ch:char; sy:symbol; theword:alfa; theint:integer;

       oprpriority:array[symbol]of integer;
       startsexp, unoprs, binoprs, rightassoc :set of symbol;
       sym :symbol;

   function newnode(k:SyntaxClass):tree;
      var p:tree;
   begin new(p); p^.tag:=k; newnode:=p end;

   procedure error(m:alfa);
   begin writeln;
         writeln('error:', m, ' lineno=', lineno:1,
                 ' ch=<', ch, '>(', ord(ch):1, ') sy=', ord(sy):1,
                 ' last word=<', theword, '>');
         writeln; write('skip :');
         while not eof do
            if eoln then begin readln; writeln; write('skip :') end
            else begin read(ch); write(ch) end;
         goto 99 {error abort}
   end{error};

#include "lex.insym.P"  {Lexical Analysis Routines}

   procedure check(s:symbol; m:alfa);
   begin if sy=s then insymbol else error(m) end;

   function syis(s:symbol):boolean;
   begin if sy=s then begin syis:=true; insymbol end else syis:=false end;

   function expression:tree;  { --- parse an expression --- }

      function param:tree;
         var p:tree;
      begin if sy=word then          { lambda x .... }
            begin p:=newnode(ident);
                  p^.id:=theword
            end
            else if sy=empty then    { lambda () ... }
               p:=newnode(emptycon)
            else error('f param   ');
            insymbol;
            param:=p
      end;

      function pdecs:tree; {  [rec] , , ... in exp }
         var d:tree;
             isrec:boolean;

         function cons( isrec:boolean; h,t:tree):tree;
            var p:tree;
         begin p:=newnode(declist); p^.recursive:=isrec;
               p^.hd:=h; p^.tl:=t; cons:=p
         end;

         function pdeclist(isrec:boolean) :tree; { ,, ... }
            var d:tree;

            function pdec:tree;  {   =  }
               var d:tree;
            begin if sy=word then
                  begin d:=newnode(decln);
                        d^.name:=theword; insymbol; check(eq,'= expected');
                        d^.val :=expression
                  end
                  else error('dec, no id');
                  pdec:=d
            end{pdec};

         begin {pdeclist             dec, dec, ..., dec }
            d:=pdec;
            if syis(comma) then pdeclist:=cons(isrec,d,pdeclist(isrec))
                           else pdeclist:=cons(isrec,d,nil)
         end{pdeclist};

      begin {pdecs}
         isrec:=syis(recsy);    { [rec] pdeclist  in exp }
         d:=newnode(block);
         d^.decs:=pdeclist(isrec);
         check(insy, 'in expectd');
         d^.exp := expression;
         pdecs := d
      end{pdecs};

      function exp(priority:integer):tree;
         var e, a :tree;
      begin {exp}
         if priority < applicpriority then
         begin e := exp( priority+1 );
               if (sy in binoprs*rightassoc)and(oprpriority[sy]=priority) then
               begin a:=e; e:=newnode(binexp);
                     e^.binopr:=sy; insymbol;
                     e^.left:=a; e^.right:=exp(priority)
               end
               else
               while (sy in binoprs-rightassoc) and (oprpriority[sy]=priority)  do
               begin a:=e; e:=newnode(binexp);
                     e^.binopr:=sy; insymbol;
                     e^.left:=a; e^.right:= exp(priority+1)
               end
         end

         else if priority=applicpriority then {application   f g h x}
         begin e:=exp(priority+1);
               while sy in startsexp - binoprs do {need () in   f(-3)}
               begin a:=e; e:=newnode(application);
                     e^.fun:=a; e^.aparam:=exp(priority+1)
               end
         end

         else {operands}if sy in unoprs then
         begin e:=newnode(unexp);
               e^.unopr:=sy; insymbol;
               e^.unarg:=exp(priority)
         end

         else if sy in startsexp then  case sy of

         word:   begin e:=newnode(ident); e^.id:=theword; insymbol end;
         numeral:begin e:=newnode(intcon); e^.n:=theint; insymbol end;
         charliteral:begin e:=newnode(charcon); e^.ch:=theword[1]; insymbol end;
         empty:  begin insymbol; e:=newnode(emptycon) end;
         nilsy:  begin insymbol; e:=newnode(nilcon) end;
         truesy: begin e:=newnode(boolcon); e^.b:=true; insymbol end;
         falsesy:begin e:=newnode(boolcon); e^.b:=false; insymbol end;

         open:   begin insymbol; e:=expression; check(close,') expected') end;

         letsy:  begin insymbol; e:=pdecs end;

         ifsy:begin insymbol; e:=newnode(ifexp);
                    e^.e1:=expression; check(thensy,'no then   ');
                    e^.e2:=expression; check(elsesy,'no else   ');
                    e^.e3:=expression
              end;

         lambdasy:begin insymbol; e:=newnode(lambdaexp);
                        e^.fparam:=param; check(dot,'. expected');
                        e^.body:=expression
                  end;
         end{case}

         else error('bad opernd');

         exp:=e
      end {exp};

   begin{expression}
      expression:=exp({priority=}1)
   end{expression};

begin {parser}
   unoprs     := [minus, hdsy, tlsy, nullsy, notsy];
   binoprs    := [conssy..over];
   rightassoc := [conssy];
   startsexp  := unoprs + [word..falsesy, open, letsy, ifsy, lambdasy];

   for sym:=word to eofsy do oprpriority[sym]:=0;
   oprpriority[conssy]:=1;
   oprpriority[orsy]:=2;        oprpriority[andsy]:=3;
   for sym:=eq to ge do oprpriority[sym]:=4;
   oprpriority[plus]:=5;         oprpriority[minus]:=5;
   oprpriority[times]:=6;        oprpriority[over]:=6;

   lineno := 1;
   writeln(' Simple Functional Language   L.A. Monash Comp Sci 10/2/87');
   write(lineno:3, ': ');
   ch:=' '; theword := '-start----'; theint:=maxint; insymbol;

   parser := expression; {a program is a single expression}

   check(eofsy, 'prog+junk ');
   writeln
end{parser};

{\fB Parser for Functional Language. \fP}

{Do not remove: Lazy.p, Strict.p, lazy.*.P, strict.*.P, lex.*.P, & syntax.*.P }
{ are released under Gnu `copyleft' General Public Licence (GPL)              }
{ - L. Allison, CSSE, Monash Uni., .au, 7/2003.                               }




function mkvalue(t:ValueClass):Value;
   var p:Value;
begin new(p); p^.tag:=t; mkvalue:=p
end;

function mkint(nn:integer):Value;
   var p:Value;
begin new(p); p^.tag:=intval; p^.n:=nn; mkint:=p
end;

function mkbool(bb:boolean):Value;
   var p:Value;
begin new(p); p^.tag:=boolval; p^.b:=bb; mkbool:=p
end;

function mkchar( cc:char ):Value;
   var p:Value;
begin new(p); p^.tag:=charval; p^.ch:=cc; mkchar:=p
end;

function mkfunc( code:tree; rho:Env ):Value;
   var p:Value;
begin new(p); with p^ do begin tag:=funcval; e:=code; r:=rho end; mkfunc:=p
end;

function defer(x:tree; rho:Env):Value;  {form closure}
   var p:Value;
begin new(p); with p^ do begin tag:=deferval; e:=x; r:=rho end; defer:=p
end {defer};

function cons( h, t :Value ):Value;
   var p :Value;
begin new(p); with p^ do begin tag:=listval; hd:=h; tl:=t end; cons:=p
     ;conscells := conscells + 1  {statistics}
end;

{\fB Make Various Values. \fP}




function U( opr:symbol; v:Value ):Value;    { U :Value -> Value }
{PRE: v^.tag <> deferval}
begin case opr of
      minus: if v^.tag=intval then U:=mkint(-v^.n)
             else error('- non int ');
      notsy: if v^.tag=boolval then U:=mkbool(not v^.b)
             else error('not ~bool ');
      hdsy:  if v^.tag=listval then
                begin force(v^.hd); U:=v^.hd end
             else error('hd ~list  ');
      tlsy:  if v^.tag=listval then
                begin force(v^.tl); U:=v^.tl end
             else error('tl ~list  ');
      nullsy:if v^.tag=listval     then U:=mkbool(false)
             else if v^.tag=nilval then U:=mkbool(true)
             else error('null ~list')
      end
end {U};

{\fB Execute Unary Operators \fP}




function O( opr:symbol; v1, v2 :Value ):Value;    { O :Value^2 -> Value }
   var abs1, abs2, intAns :integer; boolAns :boolean;
begin case opr of
      eq, ne, lt, le, gt, ge:
         begin if [v1^.tag] * [v2^.tag] * [intval, boolval, charval] <> [] then
               case v1^.tag of
               intval:  begin abs1:=v1^.n;       abs2:=v2^.n end;
               boolval: begin abs1:=ord(v1^.b);  abs2:=ord(v2^.b)  end;
               charval: begin abs1:=ord(v1^.ch); abs2:=ord(v2^.ch) end
               end
               else error('rel ops   ');
               case opr of
               eq: boolAns:=abs1= abs2;   ne: boolAns:=abs1<>abs2;
               le: boolAns:=abs1<=abs2;   lt: boolAns:=abs1< abs2;
               ge: boolAns:=abs1>=abs2;   gt: boolAns:=abs1> abs2
               end;
               O:=mkbool(boolAns)
         end;        
      plus, minus, times, over:
         begin if [v1^.tag, v2^.tag] = [intval] then
               case opr of
               plus:  intAns:=v1^.n +   v2^.n;
               minus: intAns:=v1^.n -   v2^.n;
               times: intAns:=v1^.n *   v2^.n;
               over:  intAns:=v1^.n div v2^.n
               end
               else error('arith opr ');
               O:=mkint(intAns)
         end;
      andsy, orsy:
         begin if [v1^.tag, v2^.tag] = [boolval] then
               case opr of
               andsy: boolAns:=v1^.b and v2^.b;
               orsy:  boolAns:=v1^.b or  v2^.b
               end
               else error('bool opr  ');
               O:=mkbool(boolAns)
         end;
      conssy: { deferred params } O:=cons(v1, v2)
      end
end {O};

{\fB Execute Binary Operators. \fP}

{Do not remove: Lazy.p, Strict.p, lazy.*.P, strict.*.P, lex.*.P, & syntax.*.P }
{ are released under Gnu `copyleft' General Public Licence (GPL)              }
{ - L. Allison, CSSE, Monash Uni., .au, 7/2003.                               }