| >> & more on >> |
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); # OR #
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((" ", 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
looked ahead := TRUE; n:=0;
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 ");
RULE (head, rhs)
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),
uuu pred(map e pred(e,head OF r), p, ask body, l2, s2))
)#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
emanROC 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) )
)