Appendix.


program prolog(input, output);

{ System dependent... procedure setlinebuffering; external; } {was on Sun c2007}

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}
#include "env.type.P"      {Environments}

var prog:tree;

#include "tree.P"          {Manipulate trees and nodes}
#include "syntax.P"        {The Parser}
#include "env.P"           {Manipulate Environments}
#include "syntax.print.P"  {Print a Parse Tree}
#include "execute.P"       {interpreter}

begin { setlinebuffering; { system dependent }
      prog:=parser;
      writeln; writeln(' --- end of parsing --- ');
      printtree(prog, nil); writeln; writeln(' --- running --- ');
      execute(prog);
      99:writeln; writeln(' --- finished --- ')
end.

{\fB Prolog Interpreter, Main Program. \fP}
{ L. Allison, Dept. Computer Science, Monash University, Australia 3800 }
{ http://www.csse.monash.edu.au/~lloyd/tildeLogic/Prolog.toy/ }
{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  }




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




procedure getch;
   const tab = 9;
begin if eof then begin ch:='.'; theword:='     ' end
      else if eoln then
      begin readln; writeln; ch:=' ';
            lineno:=lineno+1; write(lineno:3, ': ')
      end
      else begin 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='and       ' then sy:=andsy
            else if theword='not       ' then sy:=notsy
            else if theword[1] in ['a'..'z'] then sy:=LCword
            else sy:=UCword
      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 in  [ '?', '.', ',', ':', '<', '&', '(', ')', '[', ']' ] then
         case ch of
            '<': begin getch;
                       if ch='=' then begin getch; sy:=impliedby end
                       else error('not <=    ')
                 end;
            ':': begin getch;
                       if ch='-' then begin getch; sy:=impliedby end
                       else sy:=colon
                 end;
            '?', '.', ',', '(', ')', '[', ']', '&':
                 begin case ch of
                       '?': sy:=question;
                       '.': sy:=dot;    ',': sy:=comma;
                       '(': sy:=open;   ')': sy:=close;
                       '[': sy:=sqopen; ']': sy:=sqclose;
                       '&': sy:=andsy
                       end{case};
                       getch
                 end
         end{case}

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

{\fB Lexical Analysis. \fP}


[Previous Page] [Index] © L. Allison, Dept. Computer Science, Monash University