home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
RBBS in a Box Volume 1 #2
/
RBBS_vol1_no2.iso
/
050z
/
lisp.pas
< prev
next >
Wrap
Pascal/Delphi Source File
|
1985-05-27
|
23KB
|
831 lines
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
Modified for TURBO by R. Stearns, M. Covington
Date started : 05/21/85
Date finished : 05/21/85
Modified for readability by R. Stearns
Date started : 05/22/85
Date finished :
}
const
maxnode = 1000;
type
longstr = string[255];
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 }
curline : longstr; { the current input line }
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 }
{ The function trim and procedure getch provided to circumvent some of the }
{ peculiarities of TURBO Pascal terminal I/O }
{ This function returns its argument with all trailing blanks removed }
function trim(s: longstr) : longstr;
var
i : integer;
begin
i := length(s);
while((i>0) and (s[i]=' ')) do i := i-1;
trim := copy(s,1,i);
end;
{ This procedure returns, in ch, the next character of input from the kbd }
procedure getch(var ch : char);
begin
while (curline='') do begin
write('? ');
readln(curline);
curline := trim(curline)+' ';
end;
ch := upcase(curline[1]);
curline := copy(curline,2,length(curline)-1);
end;
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 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.');
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 argument of replaceh is an atom.');
6 : writeln(' 1st argument of replacet is an atom.');
7 : writeln(' argument of head is an atom.');
8 : writeln(' argument of tail is an atom.');
9 : writeln(' 1st argument 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 }
halt;
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 getch(ch);
if ch in ['(','.',')'] then
begin
case ch of
'(' : sym := lparen;
'.' : sym := period;
')' : sym := rparen
end; { case }
getch(ch);
end
else
begin
sym := atom;
id := ' ';
i := 0;
repeat
i := i + 1;
if i < 11 then id[i] := ch;
getch(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 { <atom> }
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 { (<s-expr> <s-expr> ... <s-expr> ) }
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;
curline := '';
getch(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);
while not ptr^.anatom or (ptr^.name <> 'FIN ') do begin
writeln;
writeln(' * Value * ');
printexpr(eval(ptr, alist));
writeln;
writeln;
ptr := nil;
garbageman;
writeln;
writeln;
writeln(' * EVAL * ');
nextsym;
readexpr(ptr);
writeln;
end;
writeln;
writeln;
writeln(' Total number of garbage collections = ', numberofgcs:1,'.');
writeln;
writeln(' Free nodes left upon exit = ', freenodes:1,'.');
writeln;
end. { lisp }
'.');
writeln;
writeln(' Free nodes left upon exit = ', freenodes:1,'.');
write