function parser:tree;

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

   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 sequence( function item:tree; sep :symbol ):tree; { >=1 of }
      var s :tree;
      function rest:tree;
         var r :tree;
      begin if syis(sep) then
            begin r := cons(item, nil); r^.tl := rest
            end
            else r:=nil;
            rest := r
      end  {rest};
   begin s := cons(item, nil); s^.tl := rest;
         sequence := s
   end {sequence};

   function prog :tree; { ------------------------- parse a program --------- }
      var p :tree;

      function Pterm :tree; forward;

      function Pterms :tree; { optional  (1, x, Y, g(1,h)) }
         var p :tree;
      begin if syis(open) then
            begin p := sequence(Pterm, comma);
                  check(close, ') expected')
            end
            else p:=nil;
            Pterms := p
      end   {Pterms};

      function Pterm { :tree -- forwarded}; { constant `x' or func f(1,g(y)) }
         var f :tree; id :alfa;
      begin if sy=LCword then
            begin id := theword; insymbol;
                  if sy = open then                                { function }
                  begin f:=newnode(func); f^.id:=id; f^.params := Pterms
                  end
                  else                                             { constant }
                  begin f:=newnode(constant); f^.cid:=id
                  end
            end
            
            else if sy=UCword then                                 { Variable }
            begin f := newnode(variable); f^.vid := theword; f^.index := 0;
                  insymbol
            end
            
            else if sy=numeral then                        { integer constant }
            begin f := newnode(intcon); f^.n := theint; insymbol
            end
            
            else error('no term   ');
            Pterm := f
      end   {Pterm};

      function Patom :tree; { eg. parent(fred, M, D) }
         var p :tree;
      begin if sy=LCword then
            begin p := newnode(predicate); p^.id:=theword; insymbol;
                  p^.params := Pterms
            end
            else error('no predcte');
            Patom := p
      end   {Patom};

      function Pliteral :tree; { eg. not equal(X,Y)  or eg. equal(X,Y) }
         var l :tree;
      begin if syis(notsy) then
            begin l:=newnode(negate); l^.l := Patom end
            else l := Patom;
            Pliteral := l
      end   {Pliteral};
      
      function Prule :tree; { `p<=q and s.'   or   `parents(c,m,d).' }
         var r :tree;
      begin r := newnode(rule);
            r^.lhs := Patom;
            if syis(impliedby) then r^.rhs := sequence(Pliteral, andsy)
            else r^.rhs := nil;
            check(dot, '. expected');
            Prule := r
      end   {Prule};

      function Prules :tree; { optional list of rules }
         var r :tree;
      begin if sy=LCword then
            begin r:=cons(Prule, nil); r^.tl := Prules end
            else r:=nil;
            Prules := r
      end   {Prules};

   begin {prog}
      p := newnode(progrm);
      p^.facts := Prules;
      check(question, '? expected');
      p^.query := sequence(Pliteral, andsy); check(dot, 'missing . ');
      prog := p
   end   {prog};

begin {parser}
   lineno := 1;
   writeln(' Simple Prolog L.A. Monash Comp Sci 2/8/89');
   write(lineno:3, ': ');
   ch:=' '; theword := '-start----'; theint:=maxint; insymbol;
   
   parser := prog;
   
   check(eofsy, 'prog+junk ');
   writeln
end{parser};

{\fB Parser for Prolog-S. \fP}
{Do not remove: Main.p, env*P, execute.P, unify.P, rename.P, prove.P, lex*P, }
{ syntax*P, tree.P are released under Gnu `copyleft' General Public Licence  }
{ - L. Allison, CSSE, Monash Uni., .au, 7/2003.                              }