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