^Semantics^ ^examples^ >prolog programs> & more on >logic>

# Prolog Semantics Expressed in Algol-68

See L. Allison, A Practical Introduction to Denotational Semantics, CUP, Cambridge Computer Science Texts V23, 1986.

```
( print((newline," progch9.a68:Prolog Semantics 9/5/85 L.A.", newline));

#-----------------------------------------------------------------------------#
#lexical domains#
MODE ALFA = [1:10]CHAR;
INT  ident = 1, numeral = 2, varsy = 3,   #e.g.  fred, 99, X #
ifsy = 4, qmark = 5,                 #      :-    ?     #
open = 6, close = 7,
comma = 8,stopsy = 9;

#-----------------------------------------------------------------------------#
#syntactic domains#
MODE PROG = STRUCT(CLIST c, QUERY q);

MODE CLIST = REF CLISTNODE,
RULE  = STRUCT(PRED head, PLIST rhs);
MODE CLISTNODE = STRUCT(CLAUSE h, CLIST t);
MODE CLAUSE = UNION(PRED # a fact #, RULE);

MODE APPLIC = STRUCT(ALFA id, ALIST args);    # f(x,g(4,y)) #

MODE PLIST = REF PLISTNODE;
MODE PLISTNODE = STRUCT(PRED h, PLIST t);
MODE PRED   = UNION(APPLIC, ALFA);               # odd(7).  OR   p. #

MODE QUERY = PLIST;

MODE ALIST = REF ALISTNODE;
MODE ALISTNODE = STRUCT(ATOM h, ALIST t);

MODE NAME = STRUCT(INT tag, ALFA id);  # < ident,fred >  OR  < varsy,FRED > #
MODE ATOM = UNION(INT, NAME, APPLIC,    # numeral | ident | IDENT | f(args) #
LOCN #NB. LOCN for VALUE not ATOM#);

#-------------------------------------------------------------------------#
# I/O #
LOC INT line no := 1;
LOC BOOL end of input := FALSE;
print((newline, line no, "->"));

OP =       =(ALFA a, b)BOOL:
(LOC BOOL eq:=TRUE;
FOR i TO UPB a WHILE eq DO eq:=a[i]=b[i] OD;
eq
);

PROC getch = CHAR:
(LOC CHAR ch; LOC FILE si:=stand in;
PROC gc = CHAR:
(LOC FILE si2 := si;
PROC eof = (REF FILE f)BOOL:
(print(("< EOF>", newline)); ch:=".";
end of input := TRUE; GOTO eoflab
);
on logical file end(si2, eof);
get(si2, ch); print(ch);
eoflab: ch
);
PROC eol = (REF FILE f)BOOL:
(ch:=" "; newline(f); line no +:=1;
print((newline, line no, "->")); GOTO eolnlab
);
on line end(si, eol);
ch:=gc;
eolnlab: ch
) # getch #;
#-----------------------------------------------------------------------------#
#lexical#
LOC CHAR ch:=getch; #current character#
LOC INT  sy; # current symbol code #
LOC ALFA word; # holds characters of a var or ident #
LOC INT  n; # value if sy=numeral #

PROC error = (STRING m)VOID:
(print((newline, " error:", m, " lineno=", whole(line no,0),
"  ch=", ch, " sy=", sy, " n=", n));
IF end of input THEN print(" end of input file") FI;
GOTO stop
);

PROC check = (INT sym, STRING message)VOID:
IF sy=sym THEN insymbol ELSE error(message) FI;

PROC insymbol = VOID:
(PROC letter = (CHAR ch)BOOL:
(ch >= "a" AND ch <= "z") OR (ch >= "A" AND ch <= "Z");
PROC capital = (CHAR ch)BOOL:
ch >= "A" AND ch <= "Z";
PROC digit = (CHAR ch)BOOL:
ch >= "0" AND ch <= "9";
LOC BOOL looked ahead := FALSE;

WHILE ch=" " DO ch:=getch OD; # ch~=" " #
FOR i FROM LWB word TO UPB word DO word[i]:=" " OD;
IF letter(ch) THEN
looked ahead := TRUE; word[1]:=ch; ch:=getch; LOC INT l:=1;
WHILE letter(ch) OR digit(ch) DO
l+:=1;
IF l <= UPB word THEN word[l]:=ch FI;
ch:=getch
OD;
IF capital(word[1]) THEN sy:=varsy ELSE sy:= ident FI
ELIF digit(ch) THEN
WHILE digit(ch) DO
n:=n*10+ ABS ch - ABS "0"; ch:=getch
OD;
sy:=numeral

ELIF ch="(" THEN sy:=open
ELIF ch=")" THEN sy:=close
ELIF ch="?" THEN sy:=qmark
ELIF ch="," THEN sy:=comma
ELIF ch="." THEN sy:=stopsy
ELIF ch=":" THEN
ch:=getch;
IF ch="-" THEN sy:=ifsy ELSE error(" no - after : ") FI

ELSE error(" in insymbol ")
FI;
IF NOT looked ahead THEN ch:=getch FI
) # insymbol #;
#-----------------------------------------------------------------------------#
#syntax#
PROC parser = PROG:
( PROC p clist = CLIST: # list of >=0 clauses #
IF sy = qmark THEN NIL
ELSE CLAUSE h = p clause;
HEAP CLISTNODE := (h, p clist)
FI;

PROC p clause = CLAUSE:
( PRED head = p pred;
IF sy = stopsy THEN insymbol; head
ELIF sy = ifsy THEN
insymbol;
PLIST rhs = p plist;
check(stopsy, " no . after rule ");
ELSE error(" . or :- expected in p clause"); SKIP
FI
);

PROC p plist = PLIST:  # list of >=0 predicates #
IF sy = stopsy THEN NIL
ELSE
PRED h = p pred;
HEAP PLISTNODE:=(h,IF sy = comma THEN
insymbol;
p plist
ELSE NIL FI
)
FI;

PROC p pred = PRED:
IF sy = ident THEN
ALFA id = word;
insymbol;
IF sy = open THEN
insymbol;
ALIST args = p alist;
check(close, " ) expected ");
APPLIC (id, args)
ELSE id
FI
ELSE error(" identifier expected"); SKIP
FI;

PROC p alist = ALIST:  # list of >=1 atoms #
( ATOM h = p atom;
IF sy = comma THEN
insymbol;
HEAP ALISTNODE := (h, p alist)
ELSE HEAP ALISTNODE := (h, NIL)
FI
);

PROC p atom = ATOM:
IF sy = numeral THEN
INT v = n;
insymbol;
n
ELIF sy = varsy THEN
ALFA id = word;
insymbol;
NAME (varsy, id)
ELIF sy = ident THEN
ALFA id = word;
insymbol;
IF sy = open THEN
insymbol;
ALIST args = p alist;
check(close, " ) expected");
APPLIC (id, args)
ELSE NAME (ident, id)
FI
ELSE error(" p atom: numeral, var or ident expected"); SKIP
FI;

PROC p query = QUERY:
( check(qmark, " ? expected");
PLIST q = p plist;
check(stopsy, " . expected after query");
q
);

insymbol;
CLIST facts = p clist;
(facts, p query)
)#parser#;
#-----------------------------------------------------------------------------#
#semantics domains#
MODE VALUE   = ATOM,
VLIST = ALIST;

MODE ANS     = REF ANSCELL;
MODE ANSCELL = STRUCT(VALUE h, ANS t);

MODE LOCN = STRUCT(INT l, dontcare);

MODE ENV   = PROC(ALFA)LOCN,
STORE = PROC(LOCN)VALUE;

MODE DATABASE = PROC(PRED, DATABASE, QCONT, INT, STORE)ANS;
MODE QCONT    = PROC(INT,STORE)ANS;
MODE CLCONT  = PROC(DATABASE)ANS;

OP =   = (LOCN a,b)BOOL: l OF a = l OF b;

PROC show = (ANS a)VOID:
( PROC show2 = (ANS a,BOOL top level)VOID:
( PROC s = (VALUE a)VOID:
CASE a IN
(INT n): print(whole(n,0)),
(NAME n):FOR i TO UPB id OF n WHILE (id OF n)[i] ~= " " DO
print((id OF n)[i])
OD,
(APPLIC f):(FOR i TO UPB id OF f WHILE (id OF f)[i] ~= " " DO
print((id OF f)[i])
OD;
print("(");
show2(args OF f, FALSE);
print(")")
),
(LOCN ln): print(("L-", whole(l OF ln, 0)  ))
ESAC;

IF a ISNT NIL THEN
s(h OF a);
IF t OF a ISNT NIL THEN
print(","); IF top level THEN print(newline) FI;
show2(t OF a, top level)
FI FI
) #show2#;
show2(a, TRUE)
) #show#;

PROC append = (ANS a,b) ANS:
IF a IS NIL THEN b
ELIF b IS NIL THEN a
ELSE HEAP ANSCELL := (h OF a, append(t OF a, b))
FI;

MODE ALFAS = REF STRUCT(ALFA id, ALFAS t);

PROC length = (ALFAS l)INT:
IF l IS NIL THEN 0 ELSE 1+length(t OF l) FI;

PROC index = (ALFA key, ALFAS l)INT:
IF l IS NIL THEN -max int
ELIF key = id OF l THEN 1
ELSE 1+index(key, t OF l)
FI;

PROC vars in pred = (PRED p)ALFAS:
CASE p IN
(APPLIC a): vars in alist(args OF a),
(ALFA a):NIL
ESAC;

PROC vars in clause = (CLAUSE c)ALFAS:
CASE c IN
(PRED p): vars in pred(p),
(RULE r): merge(vars in pred(head OF r), vars in plist(rhs OF r) )
ESAC;

PROC vars in plist = (PLIST l)ALFAS:
IF l IS NIL THEN NIL
ELSE merge(vars in pred(h OF l), vars in plist(t OF l))
FI;

PROC vars in alist = (ALIST l)ALFAS:
IF l IS NIL THEN NIL
ELSE merge(vars in atom(h OF l), vars in alist(t OF l))
FI;

PROC vars in atom = (ATOM a)ALFAS:
CASE a IN
(NAME n): IF tag OF n = varsy THEN
HEAP STRUCT(ALFA id,ALFAS t):=(id OF n, NIL)
ELSE NIL FI,
(APPLIC f): vars in alist(args OF f)
OUT NIL
ESAC;

PROC merge = (ALFAS a,b)ALFAS:
IF a IS NIL THEN b
ELIF b IS NIL THEN a
ELIF index(id OF a, b)>0 THEN
merge(t OF a, b)
ELSE HEAP STRUCT(ALFA id,ALFAS t):=(id OF a, merge(t OF a, b))
FI;

PROC map e val = (ENV e, VALUE v)VALUE:
CASE v IN
(NAME n):IF tag OF n=ident THEN v
ELSE e(id OF n)
FI,
(APPLIC f):APPLIC(id OF f, map e vlist(e, args OF f))
OUT v
ESAC;

PROC map e vlist = (ENV e, VLIST l)VLIST:
IF l IS NIL THEN NIL
ELSE HEAP ALISTNODE := (map e val(e, h OF l), map e vlist(e, t OF l))
FI;

PROC map e pred = (ENV e, PRED  p)PRED:
CASE p IN
(APPLIC f):APPLIC(id OF f, map e vlist(e, args OF f)),
(ALFA   a):p
ESAC;

PROC map e plist = (ENV e, PLIST l)PLIST:
IF l IS NIL THEN NIL
ELSE HEAP PLISTNODE := (map e pred(e, h OF l), map e plist(e, t OF l))
FI;
#-----------------------------------------------------------------------------#
#semantic functions#
QCONT yes = (INT l, STORE s)ANS:
HEAP ANSCELL := (NAME(ident,ALFA("y","e","s","*","*","*","*","*","*","*")),
NIL);

ALFA unset id = ("*","u","n","s","e","t","*","*","*","*");
VALUE unset = NAME(ident, unset id);

PROC not set = (VALUE v)BOOL:
CASE v IN
(NAME n): (tag OF n = ident) AND (id OF n = unset id)
OUT FALSE
ESAC;

DATABASE start d = (PRED p, DATABASE d, QCONT c, INT l, STORE s)ANS:
( PROC map s val = (VALUE v)VALUE:
CASE v IN
(LOCN l): IF not set(s(l)) THEN v ELSE map s val(s(l)) FI,
(APPLIC f): APPLIC(id OF f, map s list(args OF f))
OUT v
ESAC;
PROC map s list = (VLIST l)VLIST:
IF l IS NIL THEN NIL
ELSE HEAP ALISTNODE := (map s val(h OF l), map s list(t OF l))
FI;

CASE p IN
(ALFA x): (
#debug# print("?");FOR i TO UPB x DO print(x[i]) OD;
NIL),
(APPLIC f):IF id OF f = ALFA("w","r","i","t","e"," "," "," "," "," ") THEN
HEAP ANSCELL := (map s val(h OF args OF f), c(l,s))
ELSE
#debug# print("?");
#debug# FOR i TO UPB id OF f DO print((id OF f)[i]) OD;
#debug# print("(...)");
NIL
FI
ESAC
);

STORE start s = (LOCN ln)VALUE: unset;

PROC ppp = (PROG p)ANS:
( CLCONT ask = (DATABASE d)ANS:
( ALFAS vars = vars in plist(q OF p);
INT n vars = length(vars);
ENV e = (ALFA a)LOCN:
(index(a,vars), 0);

qqq(map e plist(e,q OF p), d, yes, n vars, start s)
);

#debug#print(" P[");
ddd(c OF p, start d, ask)
);

PROC qqq = (QUERY q, DATABASE d, QCONT c, INT l, STORE s)ANS:
IF q IS NIL THEN
c(l, s)
ELSE
QCONT ask tail = (INT l, STORE s)ANS:
qqq(t OF q, d, c, l, s);

#debug# print(" Q[");
d(h OF q, d, ask tail, l, s)
FI;

PROC ddd = (UNION(CLIST,CLAUSE) f, DATABASE d, CLCONT k)ANS:
CASE f IN
(CLIST f):IF f IS NIL THEN k(d)
ELSE CLCONT do tail = (DATABASE d)ANS:
ddd(t OF f, d, k);
ddd(h OF f, d, do tail)
FI,
(CLAUSE f):
CASE f IN
(PRED p):  ddd( RULE(p,NIL), d, k),
(RULE r): ( #  head:-rhs.   e.g. p:-q,r.   #
DATABASE new d = (PRED p, DATABASE final d,
QCONT c, INT l, STORE s)ANS:
( ALFAS vars = vars in clause(f);
INT n vars = length(vars);
INT l2 = l+n vars;
STORE s2 = (LOCN ln)VALUE:
IF l OF ln > l THEN unset ELSE s(ln) FI;
ENV e = (ALFA a)LOCN:
(index(a,vars)+l,0);
QCONT ask body = (INT l, STORE s)ANS:
qqq(map e plist(e,rhs OF r), final d, c, l, s);

append( d(p, final d, c, l, s),
)#new d#;
#debug#print(":-");
k(new d)
)
ESAC
ESAC;

PROC uuu pred = (PRED a,b, QCONT c, INT l, STORE s)ANS:
CASE a IN
(ALFA pa): CASE b IN
(ALFA pb): IF pa=pb THEN c(l,s) ELSE NIL FI
OUT NIL
ESAC,
(APPLIC fa):CASE b IN
(APPLIC fb): IF id OF fa = id OF fb THEN
uuu list(args OF fa, args OF fb, c, l, s)
ELSE NIL
FI
OUT NIL
ESAC
ESAC;

PROC uuu list = (VLIST a,q, QCONT c, INT l, STORE s)ANS:
IF (a IS NIL) OR (q IS NIL) THEN
IF a IS q THEN c(l,s) ELSE NIL FI
ELSE QCONT do tail = (INT l, STORE s)ANS:
uuu list(t OF a, t OF q, c, l, s);
uuu(h OF a, h OF q, do tail, l, s)
FI;

PROC uuu = (VALUE a, q, QCONT c, INT l, STORE s)ANS:
( PROC update = (LOCN x, VALUE v)ANS:
IF not set(s(x)) THEN
PROC new s = (LOCN x2)VALUE:
IF x=x2 THEN v ELSE s(x2) FI;
c(l, new s)
ELSE uuu(s(x), v, c, l, s)
FI;

CASE q IN
(NAME nq):# must be an ident #
CASE a IN
(LOCN la):update(la, q),
(NAME na):IF id OF nq = id OF na THEN c(l,s) ELSE NIL FI
OUT NIL
ESAC,
(LOCN lq):update(lq, a),
(INT nq):CASE a IN
(LOCN la):update(la,q),
(INT na): IF nq=na THEN c(l,s) ELSE NIL FI
OUT NIL
ESAC,
(APPLIC fq):CASE a IN
(LOCN la):update(la, q),
(APPLIC fa): IF id OF fq = id OF fa THEN
uuu list(args OF fq,args OF fa,c,l,s)
ELSE NIL
FI
OUT NIL
ESAC
ESAC
) # uuu#;

show( ppp(parser) )
)

```

© L. Allison, School of Computer Science and Software Engineering, Monash University, Australia 3800.
Created with "vi (Linux & IRIX)",   charset=iso-8859-1