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] <dec>, <dec>, ... 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; { <pdec>,<pdec>, ... }
            var d:tree;

            function pdec:tree;  {  <identifier> = <expression> }
               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;
         chansy: begin insymbol; e:=newnode(newchan) 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=}-3)
   end{expression};

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

   for sym:=word to eofsy do oprpriority[sym]:=0;

   oprpriority[parallelsy]:=-3; oprpriority[choicesy]:=-2; {process operators}
   oprpriority[sequencesy]:=-1;
   oprpriority[inputsy]   := 0; oprpriority[outputsy]:= 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 Parallel Functional Language L.A. Monash Comp Sci 8/4/93');
   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 Parallel Functional Language. \fP}
{ Do not remove: This program is released under Gnu `copyleft' General }
{ Public Licence (GPL)    -- L.Allison, CSSE, Monash Uni., .au, 7/2004 }