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
      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
         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) )
)