program LISP; { The essence of a LISP Interpreter. written by W. Taylor and L. Cox First date started : 10/29/76 Last date modified : 12/10/76 } label 1, { used to recover after an error by the user } 2; { in case the end . file is reached before a fin card } const maxnode = 1000; type inputsymbol = (atom, period, lparen, rparen); reservedwords = (replacehsym, replacetsym, headsym, tailsym, eqsym, quotesym, atomsym, condsym, labelsym, lambdasym, copysym, appendsym, concsym, conssym); statustype = (unmarked, left, right, marked); symbexpptr = ^symbolicexpression; alfa = array [1 .. 10] of char; symbolicexpression = record status : statustype; next : symbexpptr; case anatom : boolean of true : (name : alfa; case isareservedword : boolean of true : (ressym : reservedwords)); false : (head, tail : symbexpptr) end; { Symbolicexpression is the record structure used to implement a LISP list. This record has a tag field 'anatom' which tells which kind of node a particular node represents (i.e. an atom or a pair of pointers 'head' and 'tail'). 'Anatom' is always checked before accessing either the name field or the head and tail fields of a node. Two pages ahead there are three diagrams which should clarify the data structure. } { T h e g l o b a l v a r i a b l e s } var { Variables which pass information from the scanner to the read routine. } lookaheadsym, { used to save a symbol when we back up } sym : inputsymbol; { the symbol that was last scanned } id : alfa; { name of atom that was last read } alreadypeeked : boolean; { tells 'nextsym' whether we haved peeked } ch : char; { the last character read from input } ptr : symbexpptr; { the pointer to expression being evaluated } { the global lists of LISP nodes } freelist, { pointer to the linear list of free nodes } nodelist, { pointer used to make a linear scan of all the nodes during garbage collection } alist : symbexpptr; { two nodes which have constant values } nilnode, tnode : symbolicexpression; { variables used to identify atoms with pre-defined meanings } resword : reservedwords; reserved : boolean; reswords : array [reservedwords] of alfa; freenodes : integer; { number of currently free nodes known } numberofgcs : integer; { number of garbage collections made } procedure garbageman; procedure mark(list : symbexpptr); var father, son, current : symbexpptr; begin father := nil; current := list; son := current; while current <> nil do with current^ do case status of unmarked: if anatom then status := marked else if (head^.status <> unmarked) or (head = current) then if (tail^.status <> unmarked) or (tail = current) then status := marked else begin status := right; son := tail; tail := father; father := current; current := son end else begin status := left; son := head; head := father; father := current; current := son end; left: if tail^.status <> unmarked then begin status := marked; father := head; head := son; son := current end else begin status := right; current := tail; tail := head; head := son; son := current end; right: begin status := marked; father := tail; tail := son; son := current end; marked: current := father end { case } end; { mark } procedure collectfreenodes; var temp : symbexpptr; begin writeln(' number of nodes before collection = ', freenodes:1 ,'.'); freelist := nil; freenodes := 0; temp := nodelist; while temp <> nil do begin if temp^.status <> unmarked then temp^.status := unmarked else begin freenodes := freenodes + 1; temp^.head := freelist; freelist := temp end; temp := temp^.next end; writeln(' number of free nodes after collection = ', freenodes:1, '.'); end; { collectfreenodes } begin { garbageman } numberofgcs := numberofgcs + 1; writeln; writeln(' garbage collection. '); writeln; mark(alist); if ptr <> nil then mark(ptr); collectfreenodes end; { grabageman } procedure pop(var sptr : symbexpptr); begin if freelist = nil then begin writeln(' not enough space to evaluate the expression.'); { goto 2 } end; freenodes := freenodes - 1; sptr := freelist; freelist := freelist^.head end; { pop } { i n p u t / o u t p u t u t i l i t y r o u t i n e s } procedure error(numbers : integer); begin writeln; write(' Error ',numbers:1,','); case numbers of 1 : writeln(' atom or lparen expected in the s-expr.'); 2 : writeln(' atom, lparen, or rparen expected in the s-expr.'); 3 : writeln(' label and lambda are not names of functions.'); 4 : writeln(' rparen expected in the s-expr.'); 5 : writeln(' 1st arguement of replaceh is an atom.'); 6 : writeln(' 1st arguement of replacet is an atom.'); 7 : writeln(' arguement of head is an atom.'); 8 : writeln(' arguement of tail is an atom.'); 9 : writeln(' 1st arguement of append is not a list.'); 10 : writeln(' comma or rparen expected in concatenate.'); 11 : writeln(' end of file encountered before a "fin" card.'); 12 : writeln(' lambda or label expected.') end; { case } if numbers in [11] then goto 2 else goto 1 end; { error } { procedure backupinput puts a left parenthesis into the stream of input symbols. this makes procedure readexpr easier than it otherwise would be. } procedure backupinput; begin alreadypeeked := true; lookaheadsym := sym; sym := lparen end; { backupinput } procedure nextsym; var i : integer; begin if alreadypeeked then begin sym := lookaheadsym; alreadypeeked := false end else begin while ch = ' ' do begin if eoln then writeln; read(ch); (* write(ch); *) end; if ch in ['(','.',')'] then begin case ch of '(' : sym := lparen; '.' : sym := period; ')' : sym := rparen end; { case } if eoln then writeln; read(ch) (* write(ch) *) end else begin sym := atom; id := ' '; i := 0; repeat i := i + 1; if i < 11 then id[i] := ch; if eoln then writeln; read(ch) (* write(ch) *) until ch in [' ', '(', '.', ')']; resword := replacehsym; while (id <> reswords[resword]) and (resword <> conssym) do resword := succ(resword); reserved := id = reswords[resword] end end end; { nextsym } procedure readexpr(var sptr : symbexpptr); var nxt : symbexpptr; begin pop(sptr); nxt := sptr^.next; case sym of rparen, period : error(1); atom : with sptr^ do begin { } anatom := true; name := id; isareservedword := reserved; if reserved then ressym := resword end; lparen : with sptr^ do begin nextsym; if sym = period then error(2) else if sym = rparen then sptr^ := nilnode { () = nil } else begin anatom := false; readexpr(head); nextsym; if sym = period then begin nextsym; readexpr(tail); nextsym; if sym <> rparen then error(4) end else begin { ( ... ) } backupinput; readexpr(tail) end end end { with } end; { case } sptr^.next := nxt end; { readexpr } procedure printname(name : alfa); { procedure printname prints the name of an atom with one trailing blank. } var i : integer; begin i := 1; repeat write(name[i]); i := i + 1; until (name[i] = ' ') or (i = 11); write(' ') end; { printname } procedure printexpr(sptr : symbexpptr); { The algorithm for this procedure was provided by Weissman's LISP 1.5 primer, p 125. This procedure prints the symbolic expression pointed to by the argument 'sptr' in the LISP list notation. } label 1; begin if sptr^.anatom then printname(sptr^.name) else begin write('('); 1: with sptr^ do begin printexpr(head); if tail^.anatom and (tail^.name = 'NIL ') then write(')') else if tail^.anatom then begin write('.'); printexpr(tail); write(')') end else begin sptr := tail; goto 1 end end end end; { printexpr } { e n d o f i / o u t i l i t y r o u t i n e s } { T h e e x p r e s s i o n e v a l u a t e r e v a l } function eval(e, alist : symbexpptr) : symbexpptr; { evaluate 'e' using the association list 'alist' (lambda (e alist) cond ((atom e) (lookup e alist)) ((atom (car e)) (cond ((eq (car e) (quote quote)) (cadr e)) ((eq (car e) (quote atom)) (atom (eval (cadr e) alist) ((eq (car e) (quote eq)) (eq (eval (cadr e) alist))) ((eq (car e) (quote car)) (car (eval (cadr e) alist))) ((eq (car e) (quote cdr)) (cdr (eval (cadr e) alist))) ((eq (car e) (quote cons) (cons (eval (cadr e) alist) (eval (caddr e) alist) ((eq (car e) (quote cond) (evcon (cdr e)) (t (eval (cons (lookup (car e) alist) (cdr e)) alist))) ((eq (caar e) (quote label)) (eval (cons (caddar e) (cdr e) (cons (cons (cadar e) (car e)) alist) )) ((eq (caar e) (quote lambda)) (eval (caddr e) (bindargs (cadar e) (cdr e) ))))) The resulting Pascal code follows: } var temp, carofe, caarofe : symbexpptr; { The first ten of the following local functions implement ten LISP primitives. The last three are used by eval. } function replaceh(sptr1, sptr2 : symbexpptr) : symbexpptr; begin if sptr1^.anatom then error(5) else sptr1^.head := sptr2; replaceh := sptr1 end; { replaceh } function replacet(sptr1, sptr2 : symbexpptr) : symbexpptr; begin if sptr1^.anatom then error(6) else sptr1^.tail := sptr2; replacet := sptr1 end; { replacet } function head(sptr : symbexpptr) : symbexpptr; begin if sptr^.anatom then error(7) else head := sptr^.head end; { head } function tail(sptr : symbexpptr) : symbexpptr; begin if sptr^.anatom then error(8) else tail := sptr^.tail end; { tail } function cons(sptr1, sptr2 : symbexpptr) : symbexpptr; var temp : symbexpptr; begin pop(temp); temp^.anatom := false; temp^.head := sptr1; temp^.tail := sptr2; cons := temp end; { cons } function copy(sptr : symbexpptr) : symbexpptr; { This function creates a copy of the structure pointed to by the parameter 'sptr' } var temp, nxt : symbexpptr; begin if sptr^.anatom then begin pop(temp); nxt := temp^.next; temp^ := sptr^; temp^.next := nxt; copy := temp end else copy := cons(copy(sptr^.head), copy(sptr^.tail)) end; { copy } function append(sptr1, sptr2 : symbexpptr) : symbexpptr; { The recursive algorithym is from Weissman, p. 97. } begin if sptr1^.anatom then if sptr1^.name <> 'NIL ' then error(9) else append := sptr2 else append := cons(copy(sptr1^.head), append(sptr1^.tail, sptr2)) end; { append } function conc(sptr1 : symbexpptr) : symbexpptr; var sptr2, nilptr : symbexpptr; begin if sym <> rparen then begin nextsym; readexpr(sptr2); nextsym; conc := cons(sptr1, conc(sptr2)); end else if sym = rparen then begin new(nilptr); with nilptr^ do begin anatom := true; name := 'NIL ' end; conc := cons(sptr1, nilptr); end else error(10) end; { conc } function eqq(sptr1, sptr2 : symbexpptr) : symbexpptr; var temp, nxt : symbexpptr; begin pop(temp); nxt := temp^.next; if sptr1^.anatom and sptr2^.anatom then if sptr1^.name = sptr2^.name then temp^ := tnode else temp^ := nilnode else if sptr1 = sptr2 then temp^ := tnode else temp^ := nilnode; temp^.next := nxt; eqq := temp end; { eqq } function atom(sptr : symbexpptr) : symbexpptr; var temp, nxt : symbexpptr; begin pop(temp); nxt := temp^.next; if sptr^.anatom then temp^ := tnode else temp^ := nilnode; temp^.next := nxt; atom := temp end; { atom } function lookup(key, alist : symbexpptr) : symbexpptr; var temp : symbexpptr; begin temp := eqq(head(head(alist)), key); if temp^.name = 'T ' then lookup := tail(head(alist)) else lookup := lookup(key, tail(alist)) end; { lookup } function bindargs(names, values : symbexpptr) : symbexpptr; var temp, temp2 : symbexpptr; begin if names^.anatom and (names^.name = 'NIL ') then bindargs := alist else begin temp := cons(head(names), eval(head(values), alist)); temp2 := bindargs(tail(names), tail(values)); bindargs := cons(temp, temp2) end end; { bindargs } function evcon(condpairs : symbexpptr) : symbexpptr; var temp : symbexpptr; begin temp := eval(head(head(condpairs)), alist); if temp^.anatom and (temp^.name = 'NIL ') then evcon := evcon(tail(condpairs)) else evcon := eval(head(tail(head(condpairs))), alist) end; { evcon } begin { e v a l } if e^.anatom then eval := lookup(e, alist) else begin carofe := head(e); if carofe^.anatom then if not carofe^.isareservedword then eval := eval(cons(lookup(carofe, alist), tail(e)), alist) else case carofe^.ressym of labelsym, lambdasym : error(3); quotesym : eval := head(tail(e)); atomsym : eval := atom(eval(head(tail(e)), alist)); eqsym : eval := eqq(eval(head(tail(e)), alist), eval(head( tail(tail(e))), alist)); headsym : eval := head(eval(head(tail(e)), alist)); tailsym : eval := tail(eval(head(tail(e)), alist)); conssym : eval := cons(eval(head(tail(e)), alist), eval(head( tail(tail(e))), alist)); condsym : eval := evcon(tail(e)); appendsym: eval := append(eval(head(tail(e)), alist), eval(head( tail(tail(e))), alist)); replacehsym: eval := replaceh(eval(head(tail(e)), alist), eval( head(tail(tail(e))), alist)); replacetsym: eval := replacet(eval(head(tail(e)), alist), eval(head( tail(tail(e))), alist)) end { case } else begin caarofe := head(carofe); if caarofe^.anatom and caarofe^.isareservedword then if not (caarofe^.ressym in [labelsym, lambdasym]) then error(12) else case caarofe^.ressym of labelsym : begin temp := cons(cons(head(tail(carofe)), head(tail( tail(carofe)))), alist); eval := eval(cons(head(tail(tail(carofe))), tail(e)),temp) end; lambdasym : begin temp := bindargs(head(tail(carofe)), tail(e)); eval := eval(head(tail(tail(carofe))), temp) end end { case } else eval := eval(cons(eval(carofe, alist), tail(e)), alist) end end end; { e v a l } procedure initialize; var i : integer; temp, nxt : symbexpptr; begin alreadypeeked := false; read(ch); (* write(ch); *) numberofgcs := 0; freenodes := maxnode; with nilnode do begin anatom := true; next := nil; name := 'NIL '; status := unmarked; isareservedword := false end; with tnode do begin anatom := true; next := nil; name := 'T '; status := unmarked; isareservedword := false end; { - - - - allocate storage and mark it free } freelist := nil; for i := 1 to maxnode do begin new(nodelist); nodelist^.next := freelist; nodelist^.head := freelist; nodelist^.status := unmarked; freelist := nodelist; end; { - - - - initialize reserved word table } reswords[replacehsym] := 'REPLACEH '; reswords[replacetsym] := 'REPLACET '; reswords[headsym] := 'CAR '; reswords[tailsym] := 'CDR '; reswords[copysym] := 'COPY '; reswords[appendsym] := 'APPEND '; reswords[concsym] := 'CONC '; reswords[conssym] := 'CONS '; reswords[eqsym] := 'EQ '; reswords[quotesym] := 'QUOTE '; reswords[atomsym] := 'ATOM '; reswords[condsym] := 'COND '; reswords[labelsym] := 'LABEL '; reswords[lambdasym] := 'LAMBDA '; { - - - - initialize the a-list with t and nil } pop(alist); alist^.anatom := false; alist^.status := unmarked; pop(alist^.tail); nxt := alist^.tail^.next; alist^.tail^ := nilnode; alist^.tail^.next := nxt; pop(alist^.head); { - - - - bind nil to the atom nil } with alist^.head^ do begin anatom := false; status := unmarked; pop(head); nxt := head^.next; head^ := nilnode; head^.next := nxt; pop(tail); nxt := tail^.next; tail^ := nilnode; tail^.next := nxt end; pop(temp); temp^.anatom := false; temp^.status := unmarked; temp^.tail := alist; alist := temp; pop(alist^.head); { - - - - bind t to the atom t } with alist^.head^ do begin anatom := false; status := unmarked; pop(head); nxt := head^.next; head^ := tnode; head^.next := nxt; pop(tail); nxt := tail^.next; tail^ := tnode; tail^.next := nxt end; end; { initialize } { >>>>>>>>>>>>>>> l i s p <<<<<<<<<<<<<<<< } begin writeln(' * EVAL * '); initialize; nextsym; readexpr(ptr); readln; writeln; while not ptr^.anatom or (ptr^.name <> 'FIN ') do begin writeln; writeln(' * value * '); printexpr(eval(ptr, alist)); 1: writeln; writeln; if eof then error(11); ptr := nil; { call the } garbageman; writeln; writeln; writeln(' * EVAL * '); nextsym; readexpr(ptr); readln; writeln; end; 2: writeln; writeln; writeln(' total number of garbage collections = ', numberofgcs:1, '.'); writeln; writeln(' free nodes left upon exit = ', freenodes:1,'.'); writeln; end. { lisp } n(