path: root/lang/prolog/1.8.7/src/prolog

PACKET  prolog                                   (* Autor: P.Heyderhoff *) 
DEFINES                                          (* Date:  03.07.1987   *) 
        prolog, prolog again: 
 
{ GLOBALS } 
 
LET { Stacksize parameter } 
    limit = 800; 
 
LET { nil-POINTER } 
    nil = 0; 
 
LET { bootstrap rules } 
    boot = """|"".""!"".""MOD"".""-"".""+"".""*"".""/"".bye.listing. 
call(X).write(X).writeq(X).read(X).get(X).get0(X).put(X).incr(X). 
assertz(X).asserta(X).retract(X).var(X). 
X IS Y.X=X.X<>Y.X<=Y.X==Y.X=..Y.clause(X,_).name(X,Y). 
arg(X,Y,Z).functor(X,Y,Z).elan(X).elan(X,Y)"; 
 
LET { bootstrap symbols, see: boot } 
    cons=1, cut=2, mod=3, {TOKEN: minus=4, plus=5, times=6, slash=7} 
    bye=8, list=9, call=10, xpar=11, 
    writ=12, wriq=13, read=14, get=15, get0=16, put0=17, 
    incr=18, ass=19, assa=20, retr=21, vari=22, 
    is=23, ypar=24, dif=26, leq=27, eq=28, univ=29, clau=30, claupar=31, 
    nam=32, argi=33, zpar=34, func=35, 
    elan=36, build ins=33; 
 
LET { TOKENS } 
    stroke=1, exclamation=2, colon=3, minus=4, plus=5, times=6, slash=7, 
    underscore=8, less=9, equal=10, uneq=11, grt=12, eqeq=13, 
    eqdotdot=14, period=15, comma=17, semicolon=18, 
    open paren=19, close paren=20, open bracket=21, close bracket=22, 
    end of input=23, boldvar=24, number=25, identifier=26; 
 
LET { SYMBOLTYPES } 
    tag=1, bold=2, num=3, tex=4, operator=5, delimiter=6, end of file=7, 
    within com=8, within tex=9; 
 
INT CONST integer:= -1, var:= -2; 
 
LET TOKEN = INT; 
 
LET SYMBOLTYPE = INT; 
 
LET SYMBOL = INT; 
LET SYMBOLTABLE = THESAURUS; 
 
LET TERMS = INT; 
{ LET TERMSCELL = STRUCT (TERM first, 
                          TERMS rest); } 
LET TERM = STRUCT (SYMBOL symbol, 
                   TERMS arguments, 
                   INT arity); 
 
LET CLAUSES = INT; 
{ LET CLAUSESCELL = STRUCT (TERMS first, 
                            CLAUSES rest); } 
LET FRAME = INT; 
LET FRAMECELL = STRUCT (TERM call, 
                        FRAME father, 
                        TERMS subgoals, { remaining } 
                        ENVIRONMENT environment, 
                        EXPRESSIONS reset, 
                        CLAUSES rest { potential rules }, 
                        FRAME level ); 
 
LET ENVIRONMENT = INT; 
LET ENVIRONMENTCELL = STRUCT (SUBSTITUTION first, 
                              ENVIRONMENT rest); 
LET SUBSTITUTION = STRUCT (TERM variable, 
                           TERM substitute, 
                           FRAME others); 
 
LET FRAMESTACK = STRUCT (FRAME frame, goalframe, removed goal, 
                         INT last tp, last kp, last fp, last np); 
 
LET EXPRESSIONS = INT; 
 
LET EXPRESSION = STRUCT (TERM term, 
                         FRAME index); 
 
TEXT VAR tcsymbol, tcarguments, tcarity, tcrest; INT VAR tp; 
 
TEXT VAR kcfirst, kcrest; INT VAR kp; 
 
ROW limit FRAMECELL VAR fc; INT VAR fp; 
 
ROW limit ENVIRONMENTCELL VAR nc; INT VAR np; 
 
ROW limit FRAMESTACK VAR fsc; INT VAR fsp; 
 
ROW limit EXPRESSION VAR ec; INT VAR ep; 
 
ROW limit CLAUSES VAR freec; INT VAR freep; 
 
SYMBOL VAR look ahead value; 
TEXT   VAR look ahead symbol, ahead symbol; 
BOOL   VAR look ahead empty,  ahead empty; 
INT    VAR look ahead token,  ahead symboltype; 
 
SYMBOL VAR pattern; 
 
TERMS VAR ts; 
 
TERM VAR t, t2, t3; 
 
CLAUSES VAR k, kl, knowledge base, candidates; 
 
FRAME VAR root, cut level, res frame; 
 
SYMBOLTABLE VAR symboltable, reset symboltable; 
 
FILE VAR file; 
 
BOOL VAR from file, tracing, testing, found, quoting, free of errors, finish; 
 
INT  VAR i, j, reset tp, reset kp, reset freep, anonym value, 
         inference level, inference count, rule count; 
 
TEXT VAR command; 
 
REAL VAR start time:= 0.0; 
 
PROC init globals: 
   tp := nil; kp:= nil; 
   tracing:= FALSE; 
   testing:= FALSE; 
   symboltable:= empty thesaurus; 
   reset symboltable:= symboltable; 
   reset tp:= nil; 
   reset kp:= nil; 
   reset freep:= nil; 
   knowledge base:= nil; 
   from file:= FALSE; 
   inference count:= 0; 
   tcsymbol:=""; 
   tcarguments:=""; 
   tcarity:=""; 
   tcrest:=""; 
   kcfirst:=""; 
   kcrest:=""; 
   quoting:= TRUE 
ENDPROC init globals; 
 
PROC init prooftree: 
   root := nil; 
   freep:= reset freep; 
   fp:= nil; fsp:= nil; np:= nil; ep:= nil; tp:= reset tp; kp:= reset kp; 
   symboltable:= reset symboltable; 
   free of errors:= TRUE; 
   candidates:= nil; 
   new (fp, root); 
   fc(root):= FRAMECELL:(t, nil, nil, nil, nil, nil, 0); 
   anonym value:= 0; 
   collect heap garbage; 
   finish:= FALSE 
ENDPROC init proof tree; 
  
PROC prolog (TEXT CONST knowledge): 
   line; 
   last param (knowledge); 
   init globals; 
   bootstrap; 
   IF   exists (knowledge) THEN consult (knowledge) FI; 
   IF   free of errors 
   THEN prolog again 
   FI; 
   last param (knowledge). 
 
 bootstrap: 
   TERMS VAR clauses:= nil; 
   init proof tree; 
   look ahead empty:= TRUE; ahead empty:= TRUE; 
   scan (boot); 
   WHILE look ahead <> end of input 
   REP read clause; 
       assertz (clauses); 
       clauses:= nil 
   PER; 
   reset tp:= tp; 
   reset kp:= kp; 
   reset symboltable:= symboltable. 
 
 read clause: 
   TERM VAR term; 
   read term (term); 
   IF   look ahead = period 
   THEN remove token 
   FI; 
   insert term in clauses. 
 
 insert term in clauses: 
   TERMS VAR tmp; 
   new tp (tmp); 
   replace(tcsymbol,tmp,term.symbol); 
   replace(tcarguments,tmp,term.arguments); 
   replace(tcarity,tmp,term.arity); 
   replace(tcrest,tmp, clauses); 
   clauses:= tmp. 
 
 remove token: 
   look ahead empty:= TRUE. 
 
ENDPROC prolog; 
 
BOOL PROC prolog (TEXT CONST query, TEXT VAR answer): 
   disable stop; 
   init prooftree; 
   read goals; 
   BOOL VAR result:= NOT prove; 
   answer is value of last variable; 
   result . 
 
 read goals: 
   scan (query); 
   look ahead empty:= TRUE; ahead empty:= TRUE; 
   from file:= FALSE; 
   fc(root).subgoals:= nil; 
   read terms (fc(root).subgoals); 
   IF   look ahead = period 
   THEN remove token 
   FI; 
   IF   look ahead <> end of input 
   THEN syntax error ("unexpected characters after last goal") 
   FI. 
 
 answer is value of last variable: 
   IF fc(root).environment <> nil 
   THEN 
        value (nc(fc(root).environment).first.variable, t, root); 
        file:= sequential file (output, "$$"); 
        sysout ("$$"); 
        write term backward (t); 
        sysout (""); 
        input (file); 
        getline (file, answer); 
        forget ("$$", quiet) 
   ELSE answer:= "" 
   FI . 
 
 remove token: 
   look ahead empty:= TRUE. 
 
ENDPROC prolog; 
 
PROC prolog again: 
   disable stop; 
   lernsequenz auf taste legen ("q","bye"13""); 
   write (""13""10""5"?- "); 
   REP 
         init proof tree; 
         initiate read terms (fc(root).subgoals, "-"); 
         read goals; 
         prove goals; 
   UNTIL finish 
   PER; 
   lernsequenz auf taste legen ("q","break"13""). 
   
 read goals: 
   IF   is error 
   THEN c:= "?" 
   ELIF look ahead = open bracket 
   THEN remove token; 
        read consult list 
   ELSE read terms (fc(root).subgoals); 
        IF   look ahead = period 
        THEN remove token 
        FI; 
        IF   look ahead <> end of input 
        THEN syntax error ("unexpected characters after last goal") 
        FI 
   FI. 
 
 prove goals: 
   IF  tracing THEN inference level:= 0; line FI; 
   inference count:= 0; 
   start time:= clock (0); 
   REP 
        IF   c <> "?" CAND prove 
        THEN IF tracing THEN line FI; 
             write ("   no"13""10""5"?- "); 
             LEAVE prove goals 
        ELSE IF tracing THEN inference level:= 0 FI; 
             get cursor (i,j); IF i > 1 THEN line FI; 
             IF   is error 
             THEN put error; clear error; putline (""4""{cleop}); 
                  free of errors:= FALSE; 
                  sysout (""); sysin (""); 
                  putline ("type '?' to get explanations"); 
                  putline ("type ';' to try next alternative"); 
                  putline ("type any other key to stop") 
             ELSE write answers 
             FI; 
             get cursor (i, j); 
             write (""10""10""13""5"?- "); 
             getchar (c); 
             TEXT VAR c; 
             SELECT pos ("?;",c) OF 
             CASE 1:    write ("?"); 
                        inform 
             CASE 2:    write (""13""5""3""3""); 
                        get cursor (j, k); 
                        cursor (i, k); 
                        putline (";"); 
             OTHERWISE  IF c >= " " COR c = ""27"" THEN push (c) FI; 
                        LEAVE prove goals 
             END SELECT; 
             IF tracing THEN line FI; 
             IF   is error 
             THEN put error; clear error; putline (""4""{cleop}) 
             FI 
        FI 
   PER. 
 
 write answers: 
   write ("   "); 
   IF   fc(root).environment = nil 
   THEN IF free of errors THEN put ("yes") ELSE put ("no") FI 
   ELSE write environment list (root) 
   FI. 
 
 remove token: 
   look ahead empty:= TRUE. 
 
ENDPROC prolog again; 
 
PROC prolog: prolog (last param) ENDPROC prolog; 
  
BOOL PROC prove: 
   enable stop; 
   initialize prove; 
   find potential candidates. 
 
 handle remaining subgoals: 
   { all subgoals to the left are solved } 
   IF   subgoals remain 
   THEN get candidates 
   ELSE LEAVE prove WITH FALSE 
   FI. 
 
 find potential candidates: 
   REP  try one candidate PER; TRUE. 
 
 try one candidate: 
   { all candidates tried do not unify with the current goal } 
   IF   head of one candidate unifies with the current goal 
   THEN push frame; 
        handle remaining subgoals 
   ELSE backtrack to the parent of the current goal 
   FI. 
 
 backtrack to the parent of the current goal: 
   { none of the candidates unify with the current goal } 
   IF   prooftree exhausted 
   THEN LEAVE prove WITH TRUE 
   ELSE pop frame 
   FI. 
 
 prooftree exhausted: fsp = 1. 
 
 initialize prove: 
   TERM VAR curr call; 
   FRAME VAR curr frame, top frame; 
   EXPRESSIONS VAR last ep; 
   IF   fsp = nil 
   THEN curr frame:= root; 
        push frame; 
        handle remaining subgoals 
   ELSE IF tracing THEN line FI; 
        backtrack to the parent of the current goal 
   FI. 
 
 head of one candidate unifies with the current goal: 
   son  { curr frame is the resulting next son }. 
  
 subgoals remain: 
   select frame {(curr frame, curr call)}. 
 
 push frame: 
   fsp INCR 1; 
   fsc(fsp).frame:= curr frame; 
   fsc(fsp).goalframe:= nil; 
   fsc(fsp).last tp:= tp; 
   fsc(fsp).last kp:= kp; 
   fsc(fsp).last fp:= fp; 
   fsc(fsp).last np:= np. 
 
 pop frame: 
   { fsp <> nil } 
   top frame:= fsc(fsp).frame; 
   curr frame:= fc(top frame).father; 
   reinsert current call as subgoal; 
   curr call:= fc(top frame).call; 
   candidates:= fc(top frame).rest; 
   cut level:= fc(top frame).level; 
   tp:= fsc(fsp).last tp; 
   kp:= fsc(fsp).last kp; 
   fp:= fsc(fsp).last fp; 
   np:= fsc(fsp).last np; 
   fsp DECR 1; 
   IF   tracing CAND inference level > 0 CAND NOT testing 
   THEN write (""13""5""3""5""); inference level DECR 1 
   FI; 
   undo bindings (fc(top frame).reset). 
 
 reinsert current call as subgoal:  
   IF   fsc(fsp).goalframe <> nil 
   THEN fc(fsc(fsp).goalframe).subgoals:= fsc(fsp).removed goal 
   FI. 
  
 select frame: 
   REP 
       IF   next call 
       THEN LEAVE select frame WITH TRUE 
       FI; 
       curr frame:= fc(curr frame).father 
   UNTIL curr frame = nil PER; 
   FALSE. 
 
 next call: 
   ts:= fc(curr frame).subgoals; 
   IF   ts = nil 
   THEN FALSE 
   ELSE remove subgoals; TRUE 
   FI. 
 
 remove subgoals: 
   curr call:= TERM:(tcsymbolISUBts, tcargumentsISUBts, tcarityISUBts); 
   fc(curr frame).subgoals:= (tcrestISUB(ts)) ; 
   fsc(fsp).goalframe:= curr frame; 
   fsc(fsp).removed goal:= ts. 
 
 get candidates: 
   initialize clauses; 
   WHILE more knowledge 
   REP  find next clause candidate in knowledge base PER 
   { candidates = a list of clauses which may be unifiable with curr call } . 
 
 initialize clauses: 
   fc(curr frame).level:= cut level; 
   cut level:= curr frame; 
   IF   curr call.arity = var 
   THEN IF   bound (curr call, curr frame, curr call, ts) THEN FI; 
        IF   curr call.arity = var 
        THEN take goal itself as candidate; LEAVE get candidates 
        FI 
   FI; 
   k:= knowledge base; 
   found:= FALSE; 
   candidates:= nil. 
 
 take goal itself as candidate: 
   new kp (candidates); 
   replace (kcfirst, candidates, goal itself); 
   replace (kcrest, candidates, nil). 
 
 goal itself: 
   new tp (ts); 
   replace(tcsymbol,ts,curr call.symbol); 
   replace(tcarguments,ts, curr call.arguments); 
   replace(tcarity,ts, curr call.arity); 
   replace(tcrest,ts, nil); 
   ts. 
 
 find next clause candidate in knowledge base: 
   IF   (tcsymbolISUB((kcfirstISUB(k)) )) = curr call.symbol 
   THEN found:= TRUE; 
        IF   (tcarityISUB((kcfirstISUB(k)) ))  = curr call.arity 
        THEN insert clause in candidates 
        FI 
   ELIF found 
   THEN LEAVE get candidates 
   FI; 
   k:= (kcrestISUB(k)) . 
 
 more knowledge: k <> nil. 
 
 insert clause in candidates: 
   kl:= candidates; 
   new kp (candidates); 
   replace(kcfirst,candidates,kcfirstISUBk); 
   replace(kcrest, candidates, kl). 
 
 son: 
   { If rules has n sons, then this refinement will return TRUE the first 
     n times, it is called and FALSE forever after. 
     IF son then curr frame has become a frame for the next son. 
     So this refinement helps to construct the prooftree. 
   } 
 
   IF   candidates = nil 
   THEN FALSE 
   ELSE create next son 
   FI. 
 
 create next son: 
   initialize son; 
   REP try to unify curr call with candidates 
   UNTIL candidates exhausted PER; 
   { not unified } 
   forget son. 
  
 initialize son: 
   last ep:= ep; 
   new (fp, res frame); 
   fc(res frame).environment:= nil. 
 
 try to unify curr call with candidates: 
   k:= (kcfirstISUB(candidates)) ; 
   IF 
   unify (curr call, 
          curr frame, 
          TERM:(tcsymbolISUBk, tcargumentsISUBk, tcarityISUBk), 
          res frame) 
   THEN 
        IF tracing THEN trace unification results FI; 
        apply rule; 
        fill result frame 
   ELSE remove curr call from candidates 
   FI. 
 
 candidates exhausted: candidates = nil. 
 
 forget son: 
   fp DECR 1; FALSE. 
 
 fill result frame: 
   ts:= (kcfirstISUB(candidates)) ; 
   fc(res frame):= FRAMECELL:(curr call, 
                              curr frame, 
                              tcrestISUBts, 
                              fc(res frame).environment, 
                              last ep, 
                              (kcrestISUB(candidates)) , 
                              cut level); 
   curr frame:= res frame; 
   LEAVE son WITH TRUE. 
 
 remove curr call from candidates: 
   candidates:= (kcrestISUB(candidates)) ; 
   LEAVE try to unify curr call with candidates. 
  
 apply rule: 
   SELECT   curr call.symbol OF 
   CASE cons: {cons, to construct lists, see PROC unify} 
   CASE cut:  fc(res frame):= FRAMECELL:(curr call, curr frame, nil, 
                fc(res frame).environment, last ep, nil, cut level); 
              curr frame:= res frame; 
              FOR ts FROM fp DOWNTO cut level 
              REP fc(ts).rest:= nil PER; 
              LEAVE son WITH TRUE 
   CASE bye:  IF   curr call.arity = 0 
              THEN push (""13""); 
                   finish:= TRUE 
              FI 
   CASE list: IF   curr call.arity = 0 COR curr call.arity = 1 
              THEN found:= TRUE; 
                   IF   curr call.arity = 0 
                   THEN pattern:= cut 
                   ELSE value (argfirst, t, curr frame); 
                        pattern:= t.symbol 
                   FI; 
                   write knowledgebase (knowledge base) 
              FI 
   CASE call: undo bindings (last ep); 
              new tp (ts); 
              replace(tcrest,ts, fc(curr frame).subgoals); 
              fc(curr frame).subgoals:= ts; 
              value (argfirst, t, curr frame); 
              t.arguments:= revers (t.arguments); 
              replace(tcsymbol,ts, t.symbol); 
              replace(tcarguments,ts, t.arguments); 
              replace(tcarity,ts, t.arity); 
              LEAVE son WITH TRUE 
   CASE xpar: {X parameter of call} 
   CASE writ: IF   curr call.arity = 1 
              THEN value (argfirst, t, curr frame); 
                   quoting:= FALSE; 
                   write term backward (t); write (" "); 
                   quoting:= TRUE 
              FI 
   CASE wriq: IF   curr call.arity = 1 
              THEN value (argfirst, t, curr frame); 
                   write term backward (t); write (" ") 
              FI 
   CASE read: IF   curr call.arity <> 1 
              THEN 
              ELIF argfirst.arity = var 
              THEN initiate read terms (ts, 
                      name (symboltable,argfirst.symbol)); 
                   read term (t); 
                   nc(fc(curr frame).environment).first.substitute:= t 
              ELSE syntax error ("read parameter must be variable") 
              FI 
   CASE get0, get: 
              IF   curr call.arity <> 1 
              THEN 
              ELIF argfirst.arity = var 
              THEN getchar (command); 
                   WHILE curr call.symbol = get 
                   CAND code(command) < 32 
                   REP getchar (command) PER; 
                   t.arity:= integer; 
                   t.arguments:= nil; 
                   t.symbol:= code (command); 
                   nc(fc(curr frame).environment).first.substitute:= t 
              ELSE syntax error ("get parameter must be variable") 
              FI 
   CASE put0: value (argfirst, t, curr frame); 
              IF   curr call.arity = 1 CAND t.arity = integer 
              THEN write (code (t.symbol)) 
              FI 
   CASE incr: IF   curr call.arity = 1 
              THEN 
                   value(argfirst, t, curr frame); 
                   t.symbol INCR 1; 
                   IF   t.arity = integer 
                  CAND argfirst.arity = var 
                   THEN k:= fc(curr frame).environment; 
                        nc(k).first.substitute:= t; 
                   ELSE syntax error ("integer variable expected") 
              FI   FI 
   CASE ass:  IF   curr call.arity = 1 
              THEN value (argfirst,t,currframe); 
                   IF   t.symbol = nil 
                   CAND t.arguments > nil 
                   THEN assertz (t.arguments); 
                        IF   free of errors 
                        THEN reset tp:= tp; 
                             reset kp:= kp; 
                             reset symboltable:= symboltable 
                        FI 
                   ELSE syntax error ("parameter must be a list") 
              FI   FI 
   CASE assa: IF   curr call.arity = 1 
              THEN value (argfirst,t,currframe); 
                   IF   t.symbol = nil 
                   CAND t.arguments > nil 
                   THEN asserta (t.arguments); 
                        IF   free of errors 
                        THEN reset tp:= tp; 
                             reset kp:= kp; 
                             reset symboltable:= symboltable 
                        FI 
                   ELSE syntax error ("parameter must be a list") 
              FI   FI 
   CASE retr: IF   curr call.arity = 1 
              THEN value (argfirst,t,currframe); 
                   IF   t.symbol = nil 
                   CAND t.arguments > nil 
                   THEN i:= rule count; 
                        retract (t.arguments); 
                        IF   i <> rule count 
                        THEN remove curr call from candidates 
                        FI 
                   ELSE syntax error ("parameter must be a list") 
              FI   FI 
   CASE vari: IF   curr call.arity = 1 
              THEN value (argfirst, t, curr frame); 
                   IF   t.arity <> var 
                   THEN remove curr call from candidates 
                   FI 
              FI 
   CASE is:   IF   curr call.arity = 2 
              THEN disable stop; 
                   t.symbol:= arith (TERM:(tcsymbolISUBargrest, 
                                           tcargumentsISUBargrest, 
                                           tcarityISUBargrest), 
                                     curr frame); 
                   IF is error THEN put error; clear error FI; 
                   enable stop; 
                   t.arity := integer; 
                   t.arguments:= nil; 
                   IF   unify (argfirst, curr frame, t, curr frame) 
                   THEN LEAVE apply rule 
              FI   FI; 
              remove curr call from candidates 
   CASE ypar: {Y parameter of is} 
   CASE dif:  IF   curr call.arity = 2 CAND 
              unify (argfirst, 
                     curr frame, 
                     TERM:(tcsymbolISUBargrest, 
                           tcargumentsISUBargrest, 
                           tcarityISUBargrest), 
                     curr frame) 
              THEN remove curr call from candidates 
              FI 
   CASE leq:  IF   curr call.arity = 2 
              THEN get operands; 
                   IF   t.arity = integer 
                   THEN IF   t.symbol <= t2.symbol 
                        THEN LEAVE apply rule 
                        FI 
                   ELIF name (symboltable,  t.symbol)  <= 
                        name (symboltable, t2.symbol) 
                   THEN LEAVE apply rule 
              FI   FI; 
              remove curr call from candidates 
   CASE eq:   IF   curr call.arity = 2 
              THEN get operands; 
                   IF   NOT ( t = t2 ) 
                   THEN remove curr call from candidates 
              FI   FI 
   CASE univ: IF   curr call.arity = 2 
              CAND np > fsc(fsp).last np 
              THEN 
                   get operands; 
                   IF   t2.arity = var CAND t.arity >= 0 
                   THEN new tp (ts); 
                        replace (tcsymbol,ts,t.symbol); 
                        replace (tcarguments, ts, nil); 
                        replace (tcarity,ts,0); 
                        replace (tcrest,ts,revers(t.arguments)); 
                        nc(np).first.substitute.arguments:= ts; 
                        nc(np).first.substitute.symbol:= nil; 
                        nc(np).first.substitute.arity:= t.arity + 1 
                   ELIF t.arity = var CAND t2.arity > 0 
                   CAND t2.symbol <= cons 
                   THEN np DECR 1; 
                        t2. arguments:= revers(t2.arguments); 
                        nc(np).first.substitute.symbol:= 
                          tcsymbol ISUB t2.arguments; 
                        nc(np).first.substitute.arguments:= 
                          tcrest ISUB t2.arguments; 
                        nc(np).first.substitute.arity:= t2.arity - 1; 
                        np INCR 1 
                   ELSE syntax error ("wrong parameter after =..") 
              FI   FI 
   CASE clau: get operands; 
              IF   curr call.arity = 2 
              THEN 
                   IF   t.arity < 0 
                   THEN syntax error ("clause with wrong parameter") 
                   ELSE find clause; 
                        k:= tcrest ISUB (kcfirstISUBk); 
                        t3.symbol:= nil; 
                        t3.arguments:= k; 
                        t3.arity:= no of terms (k); 
                        IF   NOT unify (t2, res frame, 
                                        t3, curr frame) 
                        THEN remove curr call from candidates 
                        FI 
                   FI 
              FI 
   CASE claupar: { anonymous parameter of clause } 
   CASE nam:  IF   curr call.arity = 2 
              THEN get operands; 
                   IF   t.arity = var 
                   CAND t2.symbol = nil 
                   THEN command:= ""; 
                        k:= t2.arguments; 
                        REP command:= code (tcsymbolISUBk) + command; 
                            k:= tcrestISUBk 
                        UNTIL k <= nil PER; 
                        t.symbol:= link (symboltable, command); 
                        IF   t.symbol = 0 
                        THEN insert (symboltable, command, t.symbol); 
                        FI; 
                        t.arity:= 0; 
                        t.arguments:= nil; 
                        nc(fc(curr frame).environment).first.substitute:= t 
                   ELIF t2.arity = var 
                   CAND t.arity = 0 
                   THEN command:= name (symboltable, t.symbol); 
                        ts:= nil; 
                        FOR k FROM 1 UPTO length(command) 
                        REP new tp (i); 
                            IF   ts = nil 
                            THEN ts:= i 
                            ELSE replace (tcrest, j, i) 
                            FI; 
                            j:= i; 
                            replace (tcrest, i, nil); 
                            replace (tcarity, i, integer); 
                            replace (tcarguments, i, nil); 
                            replace (tcsymbol, i, code (command SUB k)) 
                        PER; 
                        t3.arity:= length(command); 
                        t3.arguments:= ts; 
                        t3.symbol:= nil; 
                        IF unify (t2, res frame, t3, curr frame) THEN FI 
                   ELSE syntax error ("name insufficient parameters") 
              FI   FI 
   CASE argi: get operands; 
              IF   curr call.arity = 3 
              THEN k:= argrest; 
                   value (TERM:(tcsymbolISUB(tcrestISUB(k)), 
                                tcargumentsISUB(tcrestISUB(k)), 
                                tcarityISUB(tcrestISUB(k))), 
                          t3, 
                          curr frame); 
                   IF   t.arity <> integer COR t2.arity <= 0 
                   COR  t.symbol <= 0 COR t.symbol > t2.arity 
                   THEN syntax error ("arg with wrong parameter") 
                   ELSE 
                        FOR k FROM t2.arity DOWNTO ( t.symbol + 1) 
                        REP  IF   t2.arguments <= nil 
                             THEN syntax error ("out of range"); 
                                  LEAVE apply rule 
                             FI; 
                             t2.arguments:= tcrestISUB(t2.arguments) 
                        PER; 
                        IF   t3.arity = var 
                        THEN nc(fc(curr frame).environment).first.substitute 
                             := TERM:(tcsymbolISUBt2.arguments, 
                                      tcargumentsISUBt2.arguments, 
                                      tcarityISUBt2.arguments) 
                        ELIF NOT unify (TERM:(tcsymbolISUBt2.arguments, 
                                              tcargumentsISUBt2.arguments, 
                                              tcarityISUBt2.arguments), 
                                        curr frame, 
                                        t3, 
                                        curr frame) 
                        THEN remove curr call from candidates 
                        FI 
                   FI 
              FI 
   CASE zpar: {z parameter of arg} 
   CASE func: IF   curr call.arity = 3 
              THEN 
                   get operands; 
                   k:= argrest; 
                   value (TERM:(tcsymbolISUB(tcrestISUB(k)), 
                                tcargumentsISUB(tcrestISUB(k)), 
                                tcarityISUB(tcrestISUB(k))), 
                          t3, 
                          curr frame); 
                   IF   t2.arity = var 
                   THEN IF   t3.arity = var 
                        THEN 
                             t2.symbol:= argfirst.symbol; 
                             t2.arity := 0; 
                             nc(nc(fc(curr frame).environment).rest).first. 
                               substitute:= t2; 
                             k:= tcrestISUB(k); 
                             t3.symbol:= argfirst.arity; 
                             t3.arity := integer; 
                             nc(fc(curr frame).environment).first. 
                               substitute:= t3 
                        ELIF t3.arity = integer 
                        CAND t.arity = t3.symbol 
                        THEN t.arity:= 0; 
                             t.arguments:= nil; 
                             nc(fc(curr frame).environment).first. 
                               substitute:= t 
                        ELSE remove curr call from candidates 
                        FI 
                   ELIF ( t.arity = var)  
                   CAND (t2.arity = 0) 
                   CAND (t3.arity = integer) 
                   THEN  t2.arity:= t3.symbol; 
                        FOR k FROM 1 UPTO t3.symbol 
                        REP new tp (ts); 
                            replace (tcarity, ts, var); 
                            anonym value DECR 1; 
                            replace (tcsymbol, ts, anonym value); 
                            replace (tcarguments, ts, nil); 
                            replace (tcrest, ts, t2.arguments); 
                            t2.arguments:= ts 
                        PER; 
                        nc(fc(curr frame).environment).first. 
                          substitute:= t2 
                   ELIF t2.arity <= 0 
                   THEN IF   t.symbol = t2.symbol 
                        THEN IF   t.arity  = t3.symbol 
                             CAND t3.arity = integer 
                             THEN 
                             ELIF t3.arity = var 
                             THEN t3.arity := integer; 
                                  t3.symbol:= t.arity; 
                                  nc(fc(curr frame).environment).first. 
                                    substitute:= t3 
                             ELSE remove curr call from candidates 
                             FI 
                        ELSE remove curr call from candidates 
                        FI 
                   ELSE syntax error ("wrong functor parameters") 
              FI   FI 
   CASE elan: disable stop; 
              lernsequenz auf taste legen ("q","break"13""); 
              SELECT 
              pos("consult,reconsult,sysout,sysin,forget,trace,line,abolish," 
                  ,name (symboltable, argfirst.symbol) + ",") OF 
              CASE 01: consult (arg1) 
              CASE 09: reconsult (arg1) 
              CASE 19: sysout (arg1) 
              CASE 26: sysin (arg1) 
              CASE 32: forget (arg1, quiet) 
              CASE 39: trace (arg1) 
              CASE 45: line 
              CASE 50: value (TERM:(tcsymbolISUBargrest, 
                                    tcargumentsISUBargrest, 
                                    tcarityISUBargrest), 
                                    t, 
                                    curr frame); 
                       abolish (t.symbol) 
              OTHERWISE do (elan command) 
              ENDSELECT; 
              lernsequenz auf taste legen ("q","bye"13""); 
              IF is error THEN put error; clear error FI; 
              enable stop 
   END SELECT. 
 
 get operands: 
   value (argfirst, t, curr frame); 
   value (TERM:(tcsymbolISUBargrest, 
                tcargumentsISUBargrest, 
                tcarityISUBargrest), 
          t2, 
          curr frame). 
 
 argfirst:TERM:(tcsymbolISUBcurr call.arguments, 
                tcargumentsISUBcurr call.arguments, 
                tcarityISUBcurr call.arguments). 
 
 argrest:       tcrestISUBcurr call.arguments. 
 
 arg1: value (TERM:(tcsymbolISUBargrest, 
                    tcargumentsISUBargrest, 
                    tcarityISUBargrest), 
              t, 
              curr frame); 
       name(symboltable, t.symbol). 
 
find clause: 
   k:= knowledgebase; 
   WHILE k <> nil 
   REP 
       ts:= kcfirstISUBk; 
       IF   TERM:(tcsymbolISUBts,tcargumentsISUBts,tcarityISUBts) = t 
       THEN LEAVE find clause 
       FI; 
       k:= kcrestISUBk 
   PER; 
   remove curr call from candidates; 
   LEAVE apply rule. 
 
 elan command: 
   command:= ""; 
   ts:= curr call.arguments; 
   WHILE ts <> nil 
   REP value (TERM:(tcsymbolISUBts, 
                    tcargumentsISUBts, 
                    tcarityISUBts), 
              t, 
              curr frame); 
       command CAT name (symboltable, t.symbol); 
       found:= ts = curr call.arguments; 
       ts:= tcrestISUB(ts); 
       IF   found 
       THEN IF ts > nil THEN command CAT "(""" FI 
       ELIF ts = nil 
       THEN command CAT """)" 
       ELSE command CAT """,""" 
       FI 
   PER; 
   command. 
 
 trace unification results: 
   inference level INCR 1; 
   write term (curr call); write ("="); 
   value (TERM:(tcsymbolISUB(kcfirstISUB(candidates)) , 
                tcargumentsISUB(kcfirstISUB(candidates)) , 
                tcarityISUB(kcfirstISUB(candidates)) ), t, res frame); 
   write term backward (t); 
   IF   testing 
   THEN ts:= ep; 
        IF ts > last ep THEN write (" with ") FI; 
        list expressions 
   FI; 
   line. 
 
 list expressions: 
   WHILE ts > last ep 
   REP  k:= fc(ec(ts).index).environment; 
        WHILE nc(k).first.variable.symbol <> ec(ts).term.symbol 
        REP k:= nc(k).rest PER; 
        write term (ec(ts).term); write ("="); 
        write term (nc(k).first.substitute); write (" "); 
        ts DECR 1 
   PER. 
 
ENDPROC prove; 
  
BOOL PROC unify (TERM CONST t1, FRAME CONST f1, 
                 TERM CONST t2, FRAME CONST f2): 
 
   { Unifies the expressions <t1,f1^.environment> and <t2,f2^.environment>, 
     If unification succeeds, both environments are updated. } 
 
{}{inference count INCR 1;} 
   IF   f1 = f2 CAND t1 = t2 
   THEN TRUE 
   ELIF t1.arity = var 
   THEN TERM  VAR t; 
        FRAME VAR f; 
        IF   bound (t1, f1, t,  f) 
        THEN unify (t,  f,  t2, f2) 
     {  ELIF occurs (t1, f1, t2, f2) THEN FALSE } 
        ELSE bind expression 1; 
             push expression 1; 
             TRUE 
        FI 
   ELIF t2.arity = var 
   THEN IF   bound (t2, f2, t,  f) 
        THEN unify (t,  f,  t1, f1) 
     {  ELIF occurs (t2, f2, t1, f1) THEN FALSE } 
        ELSE bind expression 2; 
             push expression 2; 
             TRUE 
        FI 
   ELIF t1.symbol = t2.symbol 
   CAND t1.arity  = t2.arity 
   THEN constant or compound term 
   ELIF t1.symbol = cons CAND t2.symbol = nil 
   CAND t1.arity  = 2    CAND t2.arguments > nil 
   CAND unify (TERM:(tcsymbolISUBt1.arguments, 
                     tcargumentsISUBt1.arguments, 
                     tcarityISUBt1.arguments), 
               f1, 
               TERM:(tcsymbolISUBt2.arguments, 
               tcargumentsISUBt2.arguments, 
               tcarityISUBt2.arguments), 
               f2) 
   THEN construct list 1 
   ELIF t2.symbol = cons CAND t1.symbol = nil 
   CAND t2.arity  = 2    CAND t1.arguments > nil 
   CAND unify (TERM:(tcsymbolISUBt2.arguments, 
                     tcargumentsISUBt2.arguments, 
                     tcarityISUBt2.arguments), 
               f2, 
               TERM:(tcsymbolISUBt1.arguments, 
                     tcargumentsISUBt1.arguments, 
                     tcarityISUBt1.arguments), 
               f1) 
   THEN construct list 2 
   ELSE FALSE 
   FI. 
 
constant or compound term: 
   { arguments of t1 and t2 are properly instantiated by the parser } 
   EXPRESSIONS VAR last ep:= ep; 
   TERMS VAR x:= t1.arguments, y:= t2.arguments; 
   WHILE x <> nil 
   REP IF   unify (TERM:(tcsymbolISUBx, tcargumentsISUBx, tcarityISUBx), 
                   f1, 
                   TERM:(tcsymbolISUBy, tcargumentsISUBy, tcarityISUBy), 
                   f2) 
       THEN x:= tcrestISUB(x); 
            y:= tcrestISUB(y) 
       ELSE undo bindings (last ep); 
            LEAVE unify WITH FALSE 
       FI 
   PER; 
   TRUE. 
 
 construct list 1: 
   last ep:= ep; 
   IF   t2.symbol = cons 
   THEN TERM VAR tail:= TERM:(tcsymbolISUB(tcrestISUB(t2.arguments)), 
                              tcargumentsISUB(tcrestISUB(t2.arguments)), 
                              tcarityISUB(tcrestISUB(t2.arguments))); 
   ELSE tail:= TERM: (nil, (tcrestISUB(t2.arguments)) , 
                      no of terms (t2.arguments) - 1); 
   FI; 
   IF   bound (TERM:(tcsymbolISUB(tcrestISUB(t1.arguments)) , 
                     tcargumentsISUB(tcrestISUB(t1.arguments)) , 
                     tcarityISUB(tcrestISUB(t1.arguments)) ), 
               f1, 
               t, 
               f) 
   THEN IF   unify (t, f, tail, f2) 
        THEN TRUE 
        ELSE undo bindings (last ep); FALSE 
        FI 
   ELSE bind tail 1; 
        push tail 1; 
        TRUE 
   FI. 
 
 construct list 2: 
   last ep:= ep; 
   IF   t1.symbol = cons 
   THEN tail:= TERM:(tcsymbolISUB(tcrestISUB(t1.arguments)) , 
                     tcargumentsISUB(tcrestISUB(t1.arguments)) , 
                     tcarityISUB(tcrestISUB(t1.arguments)) ); 
   ELSE tail:= TERM: (nil, tcrestISUB(t1.arguments), 
                      no of terms (t1.arguments) - 1); 
   FI; 
   IF   bound (TERM:(tcsymbolISUB(tcrestISUB(t2.arguments)) , 
                     tcargumentsISUB(tcrestISUB(t2.arguments)) , 
                     tcarityISUB(tcrestISUB(t2.arguments)) ), 
               f2, 
               t, 
               f) 
   THEN IF   unify (t, f, tail, f1) 
        THEN TRUE 
        ELSE undo bindings (last ep); FALSE 
        FI 
   ELSE bind tail 2; 
        push tail 2; 
        TRUE 
   FI. 
  
 bind expression 1: 
   { bind the expression <t1, f1> to <t2, f2> in the environment <f1> } 
   new environment n; 
   nc(n).first:= SUBSTITUTION:(t1, t2, f2); 
   nc(n).rest :=fc(f1).environment; 
   fc(f1).environment:= n. 
 
 bind expression 2: 
   new environment n; 
   nc(n).first:= SUBSTITUTION:(t2, t1, f1); 
   nc(n).rest :=fc(f2).environment; 
   fc(f2).environment:= n. 
 
 bind tail 1: 
   new environment n; 
   nc(n).first:= SUBSTITUTION:( 
                    TERM:(tcsymbolISUB(tcrestISUB(t1.arguments)), 
                          tcargumentsISUB(tcrestISUB(t1.arguments)) , 
                          tcarityISUB(tcrestISUB(t1.arguments)) ), 
                    tail, 
                    f2); 
   nc(n).rest :=fc(f1).environment; 
   fc(f1).environment:= n. 
 
 bind tail 2: 
   new environment n; 
   nc(n).first:= SUBSTITUTION:( 
                    TERM:(tcsymbolISUB(tcrestISUB(t2.arguments)) , 
                    tcargumentsISUB(tcrestISUB(t2.arguments)) , 
                    tcarityISUB(tcrestISUB(t2.arguments)) ), 
                    tail, 
                    f1); 
   nc(n).rest :=fc(f2).environment; 
   fc(f2).environment:= n. 
 
 push expression 1: 
   ep INCR 1; 
   ec(ep):= EXPRESSION:(t1, f1). 
 
 push expression 2: 
   ep INCR 1; 
   ec(ep):= EXPRESSION:(t2, f2). 
 
 push tail 1: 
   ep INCR 1; 
   ec(ep):= EXPRESSION:(TERM:(tcsymbolISUB(tcrestISUB(t1.arguments)) , 
                              tcargumentsISUB(tcrestISUB(t1.arguments)) , 
                              tcarityISUB(tcrestISUB(t1.arguments)) ), 
                        f1). 
 
 push tail 2: 
   ep INCR 1; 
   ec(ep):= EXPRESSION:(TERM:(tcsymbolISUB(tcrestISUB(t2.arguments)) , 
                              tcargumentsISUB(tcrestISUB(t2.arguments)) , 
                              tcarityISUB(tcrestISUB(t2.arguments)) ), 
                        f2). 
 
 new environment n: 
   ENVIRONMENT VAR n; 
   IF np = limit THEN pegeloverflow ELSE np INCR 1; n:= np FI 
ENDPROC unify; 
 
BOOL OP = (TERM CONST t1, t2): { INLINE; } 
   { Two terms are equal iff their printed representations are 
     indistinguishable. Don't confuse with equal expressions. } 
 
   IF   ( t1.symbol = t2.symbol ) 
   CAND ( t1.arity  = t2.arity  ) 
   THEN IF   t1.arguments = 0 
        THEN terms are variables or constants 
        ELSE terms are compound 
        FI 
   ELSE FALSE 
   FI. 
 
 terms are variables or constants: TRUE. 
 
 terms are compound: 
   TERMS VAR x:= t1.arguments, 
             y:= t2.arguments; 
   WHILE x <> nil 
   REP   IF   recursive equal (TERM:(tcsymbolISUBx, 
                                     tcargumentsISUBx, 
                                     tcarityISUBx), 
                               TERM:(tcsymbolISUBy, 
                                     tcargumentsISUBy, 
                                     tcarityISUBy)) 
         THEN x:= tcrestISUB(x); 
              y:= tcrestISUB(y) 
         ELSE LEAVE = WITH FALSE 
         FI 
   PER;  TRUE. 
ENDOP =; 
 
BOOL PROC recursive equal (TERM CONST t1, t2): t1=t2 
ENDPROC recursive equal; 
  
PROC undo bindings (EXPRESSIONS CONST last ep): 
   { Remove the binding for each of the expressions } 
   WHILE ep > last ep 
   REP remove matching substitutions; 
       remove expression 
   PER. 
 
 remove matching substitutions: 
   { with variable equal to term t from environment env } 
   TERM VAR t:= ec(ep).term; 
   ENVIRONMENT VAR n:= env, last:= nil; 
   WHILE n <> nil 
   REP IF   nc(n).first.variable.symbol = t.symbol 
       THEN forget n 
       ELSE last:= n 
       FI; 
       n:= nc(n).rest 
   PER. 
 
 forget n: 
   IF   last = nil 
   THEN env := nc(n).rest 
   ELSE nc(last).rest:= nc(n).rest 
   FI; 
   IF n = np THEN np DECR 1 FI. 
 
 env: fc(ec(ep).index).environment.  
 
 remove expression: 
   { Removes the first expression from e recovering the space used } 
   ep DECR 1. 
 
END PROC undo bindings; 
 
PROC consult (TEXT CONST knowledge): 
   { asserts the clauses from the file into knowledge base } 
{} enable stop; 
   IF   NOT exists (knowledge) 
   THEN syntax error ("consulting file not existing"); LEAVE consult 
   FI; 
   last param (knowledge); 
   TERMS VAR clauses; 
   BOOL VAR single:= TRUE; 
   rule count:= 0; 
   initiate read terms (knowledge, clauses); 
   WHILE look ahead <> end of input 
   REP rule count INCR 1; 
       cout (rule count); 
       read clause; 
       assertz (clauses); 
       clauses:= nil 
   PER; 
   remove token; 
   IF   anything noted 
   THEN modify (file); 
        note edit (file) 
   FI; 
   IF   free of errors 
   THEN reset tp:= tp; 
        reset kp:= kp; 
        reset symboltable:= symboltable; 
        put (rule count) 
   ELSE put (0); from file:= FALSE 
   FI; 
   putline ("rules inserted."); 
   line . 
 
 read clause: 
   TERM VAR term; 
   IF   single 
   THEN read term (term); 
        IF   term.arity = var 
        THEN syntax error ("clause starts with variable") 
        ELIF name (symboltable, term.symbol) = ":-" 
        THEN read terms (clauses); 
             call terms (clauses); 
             LEAVE consult 
        FI; 
        IF   look ahead = colon 
        THEN remove token; 
             read terms (clauses) 
        FI 
   ELIF look ahead = semicolon 
   THEN remove token; 
        read terms (clauses) 
   FI; 
   IF   look ahead = semicolon 
   THEN single:= FALSE 
   ELIF look ahead = period 
   THEN single:= TRUE; 
        remove token 
   ELSE syntax error ("period or semicolon expected") 
   FI; 
   insert term in clauses. 
 
 insert term in clauses: 
   TERMS VAR tmp; 
   new tp (tmp); 
   replace(tcsymbol,tmp,term.symbol); 
   replace(tcarguments,tmp,term.arguments); 
   replace(tcarity,tmp,term.arity); 
   replace(tcrest,tmp, clauses); 
   clauses:= tmp. 
 
 remove token: 
   look ahead empty:= TRUE. 
 
END PROC consult; 
 
PROC reconsult (TEXT CONST knowledge): 
   { asserts the clauses from the file into knowledge base } 
{} enable stop; 
   IF   NOT exists (knowledge) 
   THEN syntax error ("reconsulting file not existing"); LEAVE reconsult 
   FI; 
   last param (knowledge); 
   TERMS VAR clauses; 
   BOOL VAR single:= TRUE; 
   rule count:= 0; 
   initiate read terms (knowledge, clauses); 
   WHILE look ahead <> end of input 
   REP rule count INCR 1; 
       cout (rule count); 
       read clause; 
       abolish (tcsymbol ISUB clauses); 
       clauses:= nil 
   PER; 
   remove token; 
   consult (knowledge). 
 
 read clause: 
   TERM VAR term; 
   IF   single 
   THEN read term (term); 
        IF   term.arity = var 
        THEN syntax error ("clause starts with variable") 
        ELIF name (symboltable, term.symbol) = ":-" 
        THEN read terms (clauses); 
             call terms (clauses); 
             LEAVE reconsult 
        FI; 
        IF   look ahead = colon 
        THEN remove token; 
             read terms (clauses) 
        FI 
   ELIF look ahead = semicolon 
   THEN remove token; 
        read terms (clauses) 
   FI; 
   IF   look ahead = semicolon 
   THEN single:= FALSE 
   ELIF look ahead = period 
   THEN single:= TRUE; 
        remove token 
   ELSE syntax error ("period or semicolon expected") 
   FI; 
   insert term in clauses. 
 
 insert term in clauses: 
   TERMS VAR tmp; 
   new tp (tmp); 
   replace(tcsymbol,tmp,term.symbol); 
   replace(tcarguments,tmp,term.arguments); 
   replace(tcarity,tmp,term.arity); 
   replace(tcrest,tmp, clauses); 
   clauses:= tmp. 
 
 remove token: 
   look ahead empty:= TRUE. 
 
END PROC reconsult; 
 
PROC assertz (TERMS CONST clause): 
   { Inserts the clause into the knowledge base before the first clause 
     beginning with the same functor. 
     Clauses beginning with the same functor are assumed to be listed 
     consecutively. 
   } 
   CLAUSES VAR c1, c2, c3; 
   IF   free of errors 
   THEN IF   freep > nil 
        THEN c3:= freec(freep); 
             freep DECR 1; 
             IF reset freep > freep THEN reset freep:= freep FI 
        ELSE new kp (c3) 
        FI; 
        replace(kcfirst,c3, clause); 
        IF   knowledge base = nil 
        COR  (tcsymbolISUB((kcfirstISUB(knowledgebase)) )) = 
             (tcsymbolISUB(clause)) 
        THEN insert on top 
        ELSE c1:= knowledge base; 
             REP find and insert clause PER 
        FI 
   FI. 
 
 find and insert clause: 
   c2:= (kcrestISUB(c1)) ; 
   IF   c2 = nil 
   THEN insert on top 
   ELIF (tcsymbolISUB((kcfirstISUB(c2)) )) = (tcsymbolISUB(clause)) 
   THEN insert before 
   FI; 
   c1:= c2. 
 
 insert on top: 
   replace(kcrest,c3, knowledge base); 
   knowledge base:= c3; 
   LEAVE assertz. 
 
 insert before: 
   replace(kcrest,c3, c2); 
   replace(kcrest,c1, c3); 
   LEAVE assertz. 
 
ENDPROC assertz; 
  
PROC asserta (TERMS CONST clause): 
   { Inserts the clause into the knowledge base after the last clause 
     beginning with the same functor. 
     Clauses beginning with the same functor are assumed to be listed 
     consecutively. 
   } 
   CLAUSES VAR c1, c2, c3; 
   IF   free of errors 
   THEN IF   freep > nil 
        THEN c3:= freec(freep); 
             freep DECR 1; 
             IF reset freep > freep THEN reset freep:= freep FI 
        ELSE new kp (c3) 
        FI; 
        replace(kcfirst,c3, clause); 
        IF   knowledge base = nil 
        THEN replace(kcrest,c3, knowledge base); 
             knowledge base:= c3 
        ELSE c1:= knowledge base; 
             REP find and insert clause PER 
        FI 
   FI. 
 
 find and insert clause: 
   c2:= (kcrestISUB(c1)) ; 
   IF   c2 = nil 
   THEN append after c1 
   ELIF (tcsymbolISUB((kcfirstISUB(c2)) )) = (tcsymbolISUB(clause)) 
   THEN insert behind 
   FI; 
   c1:= c2. 
 
 append after c1: 
   replace(kcrest,c1, clause); 
   LEAVE asserta. 
 
 insert behind: 
   REP  c1:= c2; 
        c2:= (kcrestISUB(c1)) ; 
   UNTIL (tcsymbolISUB((kcfirstISUB(c2)) )) <> (tcsymbolISUB(clause)) 
   PER; 
   replace(kcrest,c3, c2); 
   replace(kcrest,c1, c3); 
   LEAVE asserta. 
 
ENDPROC asserta; 
  
PROC retract (TERMS CONST clause): 
   { Retracts the clause from the knowledge base. } 
   CLAUSES VAR c1:= knowledge base, c2; 
   IF   free of errors 
   THEN IF   c1 = nil 
        THEN rule count DECR 1 
        ELIF c1 > build ins CAND terms eq ((kcfirstISUB(c1)) , clause) 
        THEN retract top 
        ELSE REP find and retract clause PER 
        FI 
   FI. 
 
 find and retract clause: 
   c2:= (kcrestISUB(c1)) ; 
   IF   c2 = nil 
   THEN rule count DECR 1; 
        LEAVE retract 
   ELIF c2 > build ins CAND terms eq ((kcfirstISUB(c2)) , clause)  
   THEN retract c2 
   FI; 
   c1:= c2. 
 
 retract top: 
   freep INCR 1; 
   reset freep:= freep; 
   freec(freep):= knowledge base; 
   knowledge base:= (kcrestISUB(knowledge base)) ; 
   LEAVE retract. 
 
 retract c2: 
   replace(kcrest,c1, (kcrestISUB(c2)) ); 
   freep INCR 1; 
   reset freep:= freep; 
   freec(freep):= c2; 
   LEAVE retract. 
 
ENDPROC retract; 
  
PROC abolish (SYMBOL CONST clause): 
   { Retracts all the clauses with this name from the knowledge base. } 
{} enable stop; 
   CLAUSES VAR c1:= knowledge base, c2; 
   IF   free of errors 
   THEN REP 
          IF   c1 = nil 
          THEN rule count DECR 1; 
               LEAVE abolish 
          ELIF c1 = knowledgebase CAND c1 > build ins 
          CAND (tcsymbol ISUB(kcfirstISUBc1)) = clause 
          THEN retract top; 
               c1:= knowledgebase 
          ELSE find and retract clause 
          FI 
        PER 
   FI. 
 
 find and retract clause: 
   c2:= kcrestISUBc1 ; 
   IF   c2 = nil 
   THEN rule count DECR 1; 
        LEAVE abolish 
   ELIF c2 > build ins 
   CAND (tcsymbol ISUB(kcfirstISUBc2)) = clause  
   THEN retract c2 
   ELSE c1:= c2 
   FI. 
 
 retract top: 
   freep INCR 1; 
   reset freep:= freep; 
   freec(freep):= knowledge base; 
   knowledge base:= (kcrestISUB(knowledge base)). 
 
 retract c2: 
   replace(kcrest,c1, (kcrestISUB(c2)) ); 
   freep INCR 1; 
   reset freep:= freep; 
   freec(freep):= c2. 
 
ENDPROC abolish; 
  
BOOL PROC terms eq (TERMS CONST a, b): 
   IF   a = b 
   THEN TRUE 
   ELIF a = 0 COR b = 0 
   THEN FALSE 
   ELIF TERM:(tcsymbolISUBa, 
              tcargumentsISUBa, 
              tcarityISUBa) = 
        TERM:(tcsymbolISUBb, 
              tcargumentsISUBb, 
              tcarityISUBb) 
   THEN terms eq ((tcrestISUB(a)) , (tcrestISUB(b)) ) 
   ELSE FALSE 
   FI 
ENDPROC terms eq; 
 
PROC value (TERM CONST t, TERM VAR r, FRAME CONST f): 
   { sets r to the value of t in f^.environment } 
{} enable stop; 
   IF   t.arguments = 0 
   THEN IF   t.arity = var 
        THEN variable term 
        ELSE constant term 
        FI 
   ELSE compound term 
   FI. 
 
 constant term: r:= t. 
 
 variable term: 
   TERM VAR t1, t2; 
   FRAME VAR f1; 
   IF   bound (t, f, t1, f1) 
   THEN value (t1, r, f1) 
   ELSE r:= t 
   FI. 
 
 compound term: 
   INT VAR step:= 3; 
   TERMS VAR ts:= t.arguments; 
   r.arguments:= nil; 
   WHILE ts <> nil 
   REP  value (TERM:(tcsymbolISUBts, 
                     tcargumentsISUBts, 
                     tcarityISUBts), 
               t1, 
               f); 
        IF   stepping 
        CAND step = 1 CAND t.symbol = cons CAND t1.symbol = nil 
        THEN step:= 0; 
             value (t1, t2, f); 
             ts:= t2.arguments 
        ELSE ts:= tcrestISUB(ts); 
             push term in arguments 
        FI; 
   PER; 
   IF   step = 0 
   THEN r.symbol:= nil 
   ELSE r.symbol:= t.symbol 
   FI; 
   r.arity:= no of terms (r.arguments). 
 
 stepping: 
   IF step > 1 THEN step DECR 1; TRUE ELSE FALSE FI. 
 
 push term in arguments: 
   TERMS VAR term; 
   new tp (term); 
   replace(tcsymbol,term, t1.symbol); 
   replace(tcarguments,term, t1.arguments); 
   replace(tcarity,term, t1.arity); 
   replace(tcrest,term, r.arguments); 
   r.arguments:= term. 
ENDPROC value; 
 
BOOL PROC bound (TERM CONST t1, FRAME CONST f1, 
                 TERM VAR   t2, FRAME VAR   f2): 
   { returns TRUE iff the expression <t1, f1^.environment> is bound and 
     assigns <t2, f2^.environment> the expression to which it is bound. } 
   ENVIRONMENT VAR n:= fc(f1).environment; 
   SUBSTITUTION VAR sub; 
   WHILE n <> nil 
   REP sub:= nc(n).first; 
       IF   t1.symbol = sub.variable.symbol 
       THEN t2:= sub.substitute; 
            f2:= sub.others; 
            LEAVE bound WITH TRUE 
       ELSE n:= nc(n).rest 
       FI 
   PER; 
   FALSE 
ENDPROC bound; 
  
PROC append term (TERM CONST appendix, TERMS VAR list): 
   TERMS VAR term, last term; 
   IF   list = nil 
   THEN new tp (term); 
        list:= term 
   ELSE term:= list; 
        REP  last term:= term; 
             term:= tcrestISUB(term) 
        UNTILterm = nil PER; 
        new tp (term); 
        replace(tcrest,last term, term); 
   FI; 
   replace(tcsymbol,term,appendix.symbol); 
   replace(tcarguments,term,appendix.arguments); 
   replace(tcarity,term,appendix.arity); 
   replace(tcrest,term, nil) 
END PROC append term; 
 
TERMS PROC revers (TERMS CONST ts): 
   IF   ts <= nil 
   THEN ts 
   ELSE TERMS VAR reverted:= revers ((tcrestISUB(ts)) ); 
        append term (TERM:(tcsymbolISUBts, 
                           revers (tcargumentsISUBts), 
                           tcarityISUBts), 
                     reverted); 
        reverted 
   FI 
ENDPROC revers; 
 
PROC call terms (TERMS VAR ts): 
  TEXT VAR old:= sysout; 
  forget ("$sysin$",quiet); 
  sysout ("$sysin$"); 
  WHILE ts > nil 
  REP write term (TERM:(tcsymbolISUBts, 
                        tcargumentsISUBts, 
                        tcarityISUBts)); 
      line; 
      ts:= tcrestISUB(ts) 
  PER; 
  write ("elan(sysin,())."); 
  sysout (old); 
  sysin  ("$sysin$") 
ENDPROC call terms; 
 
PROC write environment list (FRAME CONST frame): 
   write environment list (frame, fc(frame).environment); 
ENDPROC write environment list; 
 
PROC write environment list (FRAME CONST frame, ENVIRONMENT CONST en): 
   IF en <> nil 
   THEN write environment list (frame, nc(en).rest); 
        write term (nc(en).first.variable);   write (" = "); 
        value (nc(en).first.variable, t, frame); 
        write term backward (t); 
        IF en <> fc(frame).environment THEN write (", ") FI 
   FI 
ENDPROC write environment list; 
 
PROC write knowledge base (CLAUSES CONST k): 
   TERMS VAR t:= (kcfirstISUB(k)) ; 
   IF   t > nil CAND k <= reset kp CAND k > build ins 
   CAND (pattern = cut COR pattern = (tcsymbolISUB(t)) 
        ) 
   THEN found:= FALSE; 
        IF   (kcrestISUB(k))  > nil 
        THEN write knowledge base ((kcrestISUB(k)) ) 
        FI; 
        write term (TERM:(tcsymbolISUBt, tcargumentsISUBt, tcarityISUBt)); 
        t:= (tcrestISUB(t)) ; 
        IF   t > nil 
        THEN write (":- "); 
             write terms 
        FI; 
        write ("."); 
        line 
   ELIF (found COR k <= build ins) CAND (kcrestISUB(k))  > nil 
   THEN write knowledge base ((kcrestISUB(k)) ) 
   FI. 
 
 write terms: 
   BOOL VAR once:= FALSE; 
   WHILE t <> nil 
   REP  IF once THEN write (", ") ELSE once:= TRUE FI; 
        write term (TERM:(tcsymbolISUBt, tcargumentsISUBt, tcarityISUBt)); 
        t:= (tcrestISUB(t)) ; 
   PER. 
ENDPROC write knowledge base; 
 
PROC write symbol (TERM CONST t): 
   TEXT VAR w1, w2:= name (symboltable, t.symbol); 
   IF   quoting 
   THEN scan (w2); 
        next symbol (w1, i); INT VAR i; 
        IF   w1 = w2 CAND i <> num 
        THEN write (w2) 
        ELSE write (""""); write (w2); write ("""") 
        FI 
   ELSE write (w2) 
   FI 
ENDPROC write symbol; 
 
PROC write term backward (TERM CONST t): 
   IF   t.arity = integer 
   THEN write (text (t.symbol)) 
   ELIF t.symbol <= cons 
   THEN IF   t.symbol < 0 
        THEN write ("_"+text(-t.symbol)) 
        ELSE write ("["); 
             write subterms backward (t, t.arguments); write ("]") 
        FI 
   ELSE 
        write symbol (t); 
        IF   t.arguments <> nil 
        THEN compound term 
        FI 
   FI. 
 
 compound term: 
   write ("("); write subterms backward (t, t.arguments); write (")"). 
 
ENDPROC write term backward;  
 
PROC write subterms backward (TERM CONST t, TERMS CONST ts): 
   IF   ts = nil 
   THEN 
   ELSE write subterms backward (t, (tcrestISUB(ts)) ); 
        write term backward ( 
              TERM:(tcsymbolISUBts, tcargumentsISUBts, tcarityISUBts)); 
        IF   ts <> t.arguments 
        THEN IF t.symbol = cons THEN write ("|") ELSE write (",") FI 
        FI 
   FI 
ENDPROC write subterms backward; 
 
PROC write term (TERM CONST t): 
   IF   t.arity = integer 
   THEN write (text (t.symbol)) 
   ELIF t.symbol <= cons 
   THEN IF   t.symbol < 0 
        THEN write ("_"+text(-t.symbol)) 
        ELSE write ("["); write terms; write ("]") 
        FI 
   ELSE 
        write symbol (t); 
        IF   t.arguments <> nil 
        THEN compound term 
        FI 
   FI. 
 
 compound term: 
   write ("("); write terms; write (")"). 
 
 write terms: 
   TERMS VAR ts:= t.arguments; 
   WHILE ts <> nil 
   REP  write term ( 
              TERM:(tcsymbolISUBts, tcargumentsISUBts, tcarityISUBts)); 
        ts:= tcrestISUB(ts); 
        IF   ts <> nil 
        THEN IF t.symbol = cons THEN write ("|") ELSE write (",") FI 
        FI 
   PER. 
 
ENDPROC write term;  
 
PROC read consult list: 
   TERM VAR t; 
   TERMS CONST old tp:= tp; 
   WHILE filename read REP PER; 
   IF   look ahead <> close bracket 
   THEN syntax error ("closing bracket expected") 
   FI; 
   remove token; 
   reset symboltable:= symboltable; 
   TERMS CONST ts:= tp; 
   tp:= old tp; 
   consult list (ts); 
   from file:= FALSE. 
 
 filename read: 
   BOOL VAR was minus:= FALSE; 
   IF   look ahead = minus 
   THEN remove token; 
        was minus:= TRUE 
   FI; 
   IF   look ahead = identifier 
   THEN new tp (tp); 
        read term (t); 
        replace(tcsymbol,tp, t.symbol); 
        replace(tcarguments,tp, t.arguments); 
        replace(tcarity,tp, t.arity); 
        IF was minus THEN replace(tcarity,tp, var); 
        FI; 
        IF   NOT exists (name (symboltable, (tcsymbolISUB(tp)) 
                        )) 
        THEN syntax error ("file does not exist"); FALSE 
        ELIF look ahead = comma THEN remove token; TRUE 
        ELSE TRUE 
        FI 
   ELSE FALSE 
   FI . 
 
 remove token: 
   look ahead empty:= TRUE. 
ENDPROC read consult list; 
 
PROC consult list (TERMS CONST ts): 
   IF   ts > tp 
   THEN TERM VAR term:= 
        TERM:(tcsymbolISUBts, tcargumentsISUBts, tcarityISUBts); 
        consult list (ts-1); 
        IF   free of errors 
        THEN TEXT VAR fname:= name (symboltable, term.symbol); 
             IF   term.arity = var 
             THEN put ("reconsulting"); putline (fname); reconsult (fname) 
             ELSE put (  "consulting"); putline (fname);   consult (fname) 
             FI 
        FI 
   FI 
ENDPROC consult list; 
 
PROC initiate read terms (TERMS VAR ts, TEXT CONST prompter): 
   enable stop; 
   look ahead empty:= TRUE; ahead empty:= TRUE; 
   from file:= FALSE; 
   TEXT VAR inputline; 
   IF   prompter = "-" 
   THEN inputline:= "" 
   ELSE inputline:= ""13"" 
   FI; 
   REP 
       WHILE sysin = "" CAND is escape 
       REP   write (""13""15"gib kommando: "); 
             get command; 
             IF   inputline = "" 
             THEN write (""14""3""3"") 
             ELSE write (""14""13""10""); 
                  IF   prompter = "-" 
                  THEN lernsequenz auf taste legen ("k", inputline); 
                  FI; 
                  disable stop; 
                  lernsequenz auf taste legen ("q","break"13""); 
                  do (inputline); 
                  lernsequenz auf taste legen ("q","bye"13""); 
                  IF   is error 
                  THEN put (errormessage); clear error 
                  FI; 
                  enable stop; 
             FI; 
             write (""13""10""5"?"); 
             write (prompter); 
             write (" ") 
       PER; 
       getline (inputline); 
       IF   inputline <> "" 
       CAND (inputline SUB length (inputline)) <> "." 
       THEN inputline CAT "." 
       FI; 
       scan (inputline); 
       ts:= nil 
   UNTIL inputline <> "" PER; 
   IF   prompter = "-" 
   THEN lernsequenz auf taste legen ("k", inputline) 
   FI. 
 
 is escape: 
   REP  IF   inputline = ""13"" 
        THEN write (""13""10""5"?"); 
             write (prompter); 
             write (" ") 
        ELIF inputline = "?" 
        THEN putline ("?"); inform; push (""13"") 
        FI; 
        getchar (inputline) 
   UNTIL pos ("?"13"", inputline) = 0 
   PER; 
   IF   inputline = ""27"" 
   THEN getchar (inputline); 
        IF   inputline = ""27"" 
        THEN TRUE 
        ELSE push (inputline); push (""27""); FALSE 
        FI 
   ELSE push (inputline); FALSE 
   FI. 
 
 get command: 
   getchar (inputline); 
   IF   inputline = ""27"" 
   THEN getchar (inputline); 
        IF   inputline = ""27"" 
        THEN inputline:= ""; 
             line 
        ELSE push (inputline); 
             push (""27""); 
             getline (inputline) 
        FI 
   ELSE push (inputline); 
        getline (inputline) 
   FI. 
 
ENDPROC initiate read terms; 
 
PROC initiate read terms (TEXT CONST knowledge, TERMS VAR ts): 
   look ahead empty:= TRUE; ahead empty:= TRUE; 
   file:= sequential file (input, knowledge); 
   from file:= TRUE; 
   scan (file); 
   ts:= nil 
ENDPROC initiate read terms; 
 
PROC read terms (TERMS VAR ts): 
   { the actual parameter for ts should be initiated < ts:=nil > 
     at top level of recursion 
   } 
   TERM VAR t; 
   WHILE look ahead <> close paren CAND look ahead <> close bracket 
    CAND look ahead <> period 
   REP  read term (t); 
        append term (t, ts) 
   UNTIL end of list PER. 
 
 end of list: 
   IF   look ahead = comma 
   THEN remove comma; 
        FALSE 
   ELSE TRUE 
   FI. 
 
 remove comma: look ahead empty:= TRUE. 
 
ENDPROC read terms; 
  
PROC read term (TERM VAR t): 
   IF   look ahead = open paren 
   THEN remove token; 
        read term (t); 
        transform infix to prefix (t, 0); 
        IF   look ahead = close paren 
        THEN remove token 
        ELSE syntax error ("closing parentheses missing") 
        FI 
   ELSE read prefix term (t); 
        transform infix to prefix (t, 0) 
   FI . 
 
 remove token: look ahead empty:= TRUE . 
ENDPROC read term; 
 
PROC transform infix to prefix (TERM VAR t, INT CONST last prio): 
     SELECT look ahead OF 
     CASE minus, plus, times, slash, less, equal, uneq, grt, eqeq, eqdotdot, 
          boldvar: 
          operator:= look ahead value; 
          IF   last prio <= priority (operator) 
          THEN 
               remove token; 
               IF   look ahead = open paren 
               THEN read term (t2); 
               ELSE read prefix term (t2); 
               FI; 
               IF   last prio < priority (operator) 
               THEN transform infix to prefix (t2, priority (operator)); 
               FI; 
               form result; 
               transform infix to prefix (t, last prio) 
          FI 
     ENDSELECT. 
 
 form result: 
     second operand; 
     first operand; 
     prefix. 
 
second operand: 
     TERMS VAR p2; 
     TERM VAR t2; 
     new tp (p2); 
     replace(tcsymbol, p2, t2.symbol); 
     replace(tcarguments, p2, t2.arguments); 
     replace(tcarity, p2, t2.arity); 
     replace(tcrest, p2, nil). 
 
first operand: 
     TERMS VAR p1; 
     new tp (p1); 
     replace(tcsymbol, p1, t.symbol); 
     replace(tcarguments, p1, t.arguments); 
     replace(tcarity, p1, t.arity); 
     replace(tcrest, p1, p2). 
 
prefix: 
     INT VAR operator; 
     t.symbol:= operator; 
     t.arguments:= p1; 
     t.arity:= 2. 
 
 remove token: 
   look ahead empty:= TRUE. 
 
ENDPROC transform infix to prefix; 
 
INT PROC priority (INT CONST operator): 
   SELECT operator OF 
   CASE times, slash, mod:  7 
   CASE minus, plus:        6 
   CASE 9,10,11,12,13:      5 
   OTHERWISE                2 
   ENDSELECT 
ENDPROC priority; 
 
PROC read prefix term (TERM VAR t): 
   SELECT look ahead OF 
   CASE exclamation:  term is cut 
   CASE bold var:     term is a variable 
   CASE underscore:   term is anonym 
   CASE number:       term is number 
   CASE identifier, 
        minus, plus, times, slash, less, equal, uneq, grt, eqeq, eqdotdot: 
                      IF   look ahead = minus 
                      THEN remove token; 
                           IF   look ahead = number  {monadic minus} 
                           THEN look ahead value:= - look ahead value; 
                                term is number; 
                                LEAVE read prefix term 
                           FI 
                      ELSE remove token 
                      FI; 
                      term is identifier; 
                      IF   look ahead = open paren 
                      THEN term is compound 
                    { ELSE term is a constant } 
                      FI 
   CASE open bracket: term is list 
   CASE colon:        term is colon 
   OTHERWISE          syntax error ("wrong expression"); 
                      t:= TERM:(nil, nil, 0) 
   ENDSELECT. 
 
 term is cut: 
   remove token; 
   t:= TERM:(cut, nil, 0). 
 
 term is a variable: 
   remove token; 
   t:= TERM:(look ahead value, nil, var). 
 
 term is anonym: 
   remove token; 
   anonym value DECR 1; 
   t:= TERM:(anonym value, nil, var). 
 
 term is number: 
   remove token; 
   t:= TERM:(look ahead value, nil, integer). 
 
 term is identifier: 
   t:= TERM:(look ahead value, nil, 0). 
 
 term is list: 
   remove token; 
   t:= TERM:(nil, nil, 0); 
   IF   look ahead = close bracket 
   THEN remove token 
   ELSE non empty list 
   FI. 
 
 non empty list: 
   TERM VAR t1; 
   read term (t1); 
   append term (t1, t.arguments); 
   IF   look ahead = close bracket 
   THEN remove token; 
        t.arity:= 1 
   ELSE list with more than one element 
   FI. 
 
 list with more than one element: 
   IF   look ahead = stroke 
   THEN t.symbol:= cons 
   ELIF look ahead <> comma CAND look ahead <> colon 
   THEN syntax error ("comma missing") 
   FI; 
   term is compound list. 
 
 term is compound list: 
   remove token; 
   read terms (t.arguments); 
   t.arity:= no of terms (t.arguments); 
   IF   look ahead = close bracket 
   THEN remove token 
   ELSE syntax error ("closing bracket missing") 
   FI. 
 
 term is compound: 
   remove token; 
   read terms (t.arguments); 
   t.arity:= no of terms (t.arguments); 
   IF   look ahead = close paren 
   THEN remove token 
   ELSE syntax error ("closing parentheses missing") 
   FI. 
 
 term is colon: 
   remove token; 
   INT VAR i:= link (symboltable, ":-"); 
   IF   i = 0 
   THEN insert (symboltable, ":-", i) 
   FI; 
   t:= TERM:(i, nil, 0). 
 
 remove token: 
   look ahead empty:= TRUE. 
 
ENDPROC read prefix term;  
 
INT PROC no of terms (TERMS CONST ts): 
   INT VAR i:= 0, t:=ts; 
   WHILE t <> nil 
   REP  t:= (tcrestISUB(t)) ; 
        i INCR 1 
   PER; 
   i 
ENDPROC no of terms; 
  
INT PROC arith (TERM CONST term, FRAME CONST curr frame):  
   TERM VAR t; 
   IF   term.arity = var 
   THEN value (term, t, curr frame) 
   ELSE t:= term 
   FI; 
   IF   t.arity = integer 
   THEN t.symbol 
   ELIF t.arity = var 
   THEN syntax error ("free variable in arith expression"); 0 
   ELIF t.arity = 1 
   THEN SELECT t.symbol OF 
        CASE plus:    arith (t1, curr frame) 
        CASE minus: - arith (t1, curr frame) 
        OTHERWISE syntax error ("unknown arith operator"); 0 
        ENDSELECT 
   ELIF t.arity = 2 
   THEN SELECT t.symbol OF 
        CASE plus:  arith (t1, curr frame)  +  arith (t2, curr frame) 
        CASE minus: arith (t1, curr frame)  -  arith (t2, curr frame) 
        CASE times: arith (t1, curr frame)  *  arith (t2, curr frame) 
        CASE slash: arith (t1, curr frame) DIV arith (t2, curr frame) 
        CASE mod:   arith (t1, curr frame) MOD arith (t2, curr frame) 
        OTHERWISE syntax error ("unknown arith operator"); 0 
        ENDSELECT 
   ELSE syntax error ("wrong arith expression"); 0 
   FI. 
 
 t1: TERM:(tcsymbolISUBt.arguments, 
           tcargumentsISUBt.arguments, 
           tcarityISUBt.arguments) . 
 
 t2: TERM:(tcsymbolISUB(tcrestISUB(t.arguments)) , 
           tcargumentsISUB(tcrestISUB(t.arguments)) , 
           tcarityISUB(tcrestISUB(t.arguments)) ) . 
 
ENDPROC arith; 
 
TOKEN PROC look ahead : 
   { Returns the token in the look ahead.  
     If the look ahead is empty it calls the scanner 
     to get the next symbol, 
     which is then placed into the look ahead. 
   } 
   SYMBOLTYPE VAR symboltype; 
   IF   look ahead empty 
   THEN look ahead empty:= FALSE; 
        get next symbol; 
        store the symbol 
   FI; 
   look ahead token. 
 
 get next symbol: 
   IF   ahead empty 
   THEN IF   from file 
        THEN next symbol (file, look ahead symbol, symboltype) 
        ELSE next symbol (look ahead symbol, symboltype) 
        FI 
   ELSE ahead empty:= TRUE; 
        look ahead symbol:= ahead symbol; 
        symboltype:= ahead symboltype 
   FI. 
 
 store the symbol: 
   SELECT symboltype OF 
   CASE tag,tex:     look ahead token:= identifier; 
                     IF   look ahead symbol = "" 
                     THEN look ahead value:= 0; 
                     ELSE install 
                     FI 
   CASE num:         look ahead token:= number; 
                     look ahead value:= int(look ahead symbol) 
   CASE bold:        look ahead token:= bold var; 
                     install 
   CASE operator:    look ahead token:= 
                     pos  ("|!:-+*/_<=<>==..", look ahead symbol); 
                     IF   look ahead token = equal 
                     THEN get next symbol; 
                          IF   symboltype = operator 
                          CAND look ahead symbol = "=" 
                          THEN look ahead token:= eqeq; 
                               look ahead symbol:= "==" 
                          ELIF look ahead symbol = "." 
                          THEN get next symbol; 
                               IF   look ahead symbol = "." 
                               THEN look ahead token:= eqdotdot; 
                                    look ahead symbol:= "=.." 
                               ELSE syntax error ("second period missing") 
                               FI 
                          ELSE ahead symbol:= look ahead symbol; 
                               ahead symboltype:= symboltype; 
                               ahead empty:= FALSE; 
                               look ahead symbol:= "="; 
                               look ahead token := equal 
                          FI 
                     FI; 
                     IF   look ahead token > 3 
                     THEN install 
                     FI 
   CASE delimiter:   look ahead token:= 
                     pos ("|!:-+*/_<=<>==..,;()[]", look ahead symbol); 
                     SELECT look ahead token OF 
                     CASE colon: minus must follow 
                     CASE 0:     syntax error ("wrong delimiter") 
                     ENDSELECT 
   CASE endoffile:   look ahead token:= end of input 
   CASE within com:  look ahead token:= end of input; 
                     syntax error ("within comment") 
   CASE within tex:  look ahead token:= end of input; 
                     syntax error ("within text") 
   ENDSELECT. 
 
 minus must follow: 
   get next symbol; 
   IF  look ahead symbol <> "-" 
   THEN syntax error ("minus after colon expected") FI. 
 
 install: 
   look ahead value:= link (symboltable, look ahead symbol); 
   IF   look ahead value = 0 
   THEN insert(symboltable,look ahead symbol,look ahead value) 
   FI. 
ENDPROC look ahead; 
 
PROC inform: 
   enable stop; 
   put ("  "); 
   put (clock(0) - start time); put ("SEC"); 
   IF   inference count > 0 CAND clock(0) > start time 
   THEN 
        put (inference count); put ("inferences"); 
        put (int (real (inference count) / (clock(0) - start time))); 
        put ("LIPS") 
   FI; 
   FOR k FROM 2 UPTO fsp 
   REP line; 
       FRAME CONST f:= fsc(k).frame; 
       INT CONST ind:= fc(f).level; 
       IF   ind <= 40 
       THEN write (ind*" ") 
       ELSE write (text(ind) + ":  ") 
       FI; 
       value (fc(f).call, t, fc(f).father); 
       write term backward (t) 
   PER; 
   IF   testing 
   THEN put(tp); put(kp); put(fp); put(fsp); put(np); put(ep) 
   FI; 
   line 
ENDPROC inform; 
 
PROC syntax error (TEXT CONST message): 
   free of errors:= FALSE; 
   write ("!- "); 
   write note (message); 
   write note (" at '"); 
   write note (look ahead symbol); 
   write note ("' "); 
   IF   from file 
   THEN write note ("in rule "); write note (rule count); 
        write note ("line "); write note (lineno(file) - 1) 
   FI; 
   look ahead empty:= TRUE; 
   line; note line 
ENDPROC syntax error; 
 
PROC write note (TEXT CONST t): 
     write (t); 
     IF from file THEN note (t) FI 
ENDPROC write note; 
 
PROC write note (INT CONST i): 
     put (i); 
     IF from file THEN note (i) FI 
ENDPROC write note; 
 
PROC trace (TEXT CONST on): 
     testing:= test on; 
     tracing:= trace on. 
     trace on: pos (on, "on") > 0. 
     test on : pos (on, "test") > 0 
ENDPROC trace; 
 
PROC new kp (INT VAR pointer): 
     kp INCR 1; pointer:= kp; 
     IF   length (kcfirst) < 2*kp 
     THEN IF   kp > 15990 
          THEN pegel overflow 
          ELSE kcfirst CAT "1234567890123456"; 
               kcrest  CAT "1234567890123456"; 
     FI   FI 
ENDPROC new kp; 
 
PROC new tp (INT VAR pointer): 
     tp INCR 1; pointer:= tp; 
     IF   length (tcsymbol) < 2*tp 
     THEN IF   tp = 15990 
          THEN pegel overflow 
          ELSE tcsymbol CAT "1234567890123456"; 
               tcarguments CAT "1234567890123456"; 
               tcarity CAT "1234567890123456"; 
               tcrest CAT "1234567890123456" 
     FI   FI 
ENDPROC new tp; 
 
PROC new (INT VAR pegel, pointer): 
     IF   pegel = limit 
     THEN pegel overflow 
     ELSE pegel INCR 1; pointer:= pegel 
     FI 
ENDPROC new; 
 
PROC pegeloverflow: line; write ("   "); 
     put(tp); put(kp); put(fp); put(fsp); put(np); put(ep); 
     errorstop ("pegeloverflow") 
ENDPROC pegeloverflow; 
  
 
{                                                            
Programmtransformation: 
 
   PASCAL mit Pointer ==>  ELAN 
 
 
1. Rekursive Datentypen: 
 
   type t = ^tcell;   ==>  LET T = INT; 
 
                         { schwache Datenabstraktion mit LET ist besser, 
                           weil keine neuen Zugriffsprozeduren erforderlich. 
 
                           GLOBAL: 
                         } 
                           LET nil = 0, limit <= 500; 
                           ROW limit TCELL VAR tc;     { t cell     } 
                           INT VAR tp:= nil;           { t pegel    } 
 
 
2. Deklaration: 
 
   var x : t;         ==>  T VAR x;    { Type checking selber machen ! } 
 
 
3. Pointer-Initialisierung: 
 
   x:= nil;           ==>  x:= nil; 
 
 
4. Allokation: 
 
   new (x);           ==>  new (tp,x); 
 
   dispose (x);       ==>  kommt nicht vor 
 
 
5. Applikation: 
 
   x^.feld            ==>  TERMSCELL:(TERM:(tcsymbolISUBx, tcargumentsISUBx, tcarityISUBx), tcrestISUBx).feld 
 
   WITH               ==>  Refinement verwenden 
 
{ Programmtransformation  ROW limit TERMSCELL VAR tc => TEXT VAR } 
   T1; 
   "new (tp, " CA "new tp ("; 
   T1; 
   REP 
        col(1); 
        D    "tc("; 
        IF   at ("tc(tc(") 
        THEN D "tc("; 
             attest; 
             col(1); 
             D "tc(" 
        FI; 
        attest 
   UNTIL eof PER 
.  
attest: 
IF   at ("tc("+any**1+").first."+any**2+":="+any**3+";"+any**4) 
THEN C ("replace(tc"+match(2)+","+match(1)+","+match(3)+");"+match(4)) 
ELIF at ("tc("+any**1+").rest:="+any**3+";"+any**4) 
THEN C ("replace(tcrest,"+match(1)+","+match(3)+");"+match(4)) 
ELIF at ("tc("+any**1+").first:="+any**3+";"+any**4) 
THEN C ("replace(tcsymbol,"+match(1)+","+match(3)+ 
   ".symbol); replace(tcarguments,"+match(1)+","+match(3)+ 
   ".arguments); replace(tcarity,"+match(1)+","+match(3)+ 
   ".arity);"+match(4)) 
ELIF at ("tc("+any**1+").first."+any**2+" "+any**4) 
THEN C ("(tc"+match(2)+"ISUB("+match(1)+")) "+match(4)) 
ELIF at ("tc("+any**1+").rest"+any**4) 
THEN C ("(tcrestISUB("+match(1)+")) "+match(4)) 
ELIF at ("tc("+any**1+").first).first"+any**4) 
THEN C ("TERM:(tcsymbolISUB"+match(1)+ 
   ").first, tcargumentsISUB"+match(1)+ 
   ").first, tcarityISUB"+match(1)+").first)"+match(4)) 
ELIF at ("tc("+any**1+").first"+any**4) 
THEN C ("TERM:(tcsymbolISUB"+match(1)+ 
   ", tcargumentsISUB"+match(1)+", tcarityISUB"+match(1)+")"+match(4)) 
ELIF at ("tc("+any**1+"):= TERMSCELL:("+any**2+","+any**3+")"+any**4) 
THEN C ("replace(tcsymbol,"+match(1)+","+match(2)+ 
   ".symbol); replace(tcarguments,"+match(1)+","+match(2)+ 
   ".arguments); replace(tcarity,"+match(1)+","+match(2)+ 
   ".arity); replace(tcrest,"+match(1)+","+match(3)+")"+match(4)) 
ELIF at ("tc("+any**1+")"+any**4) 
THEN C ("TERMSCELL:(TERM:(tcsymbolISUB"+match(1)+ 
              ", tcargumentsISUB"+match(1)+", tcarityISUB"+match(1) 
         +"), tcrestISUB"+match(1)+")" +match(4)) 
ELIF NOT eof 
THEN stop 
FI; 
col(col-1); D("*"); C "" 
.  
 
}  
 
END PACKET prolog; 
  
{ TEST } 
lernsequenz auf taste legen ("7",""124""); 
lernsequenz auf taste legen ("ü",""91""); 
lernsequenz auf taste legen ("+",""93"");