begin;
comment ALGOL 60 version of program lisp(input,output).
*** version 1, March 28, l988 ***
*** author: F.E.J. Kruseman Aretz ***
*** Philips Research Laboratory Eindhoven ***
;
integer MAXIDF, MAXNBR, MAXSTRUCT;
MAXIDF := 200;
MAXNBR := 200;
MAXSTRUCT := 2000;
begin;
integer SYM, SHIFT, LASTIDF, LASTNBR, D24, D25, FREE, INDENTATION, LINEWIDTH, DUMMY, F, ARGS, P, ID, OLP, T, NILV, QUOTE, COND, LAMBDA, DEFINE, CAR, CDR, CONS, EQUAL, ATOM, NUMBERP, LESSP, GREATERP, ADD1, SUB1, ADD, MINUS, TIMESV, DIVF;
integer array IDF[0 : MAXIDF, 0 : 9], ALIST[0 : MAXIDF];
real array NBR[0 : MAXNBR];
integer array A, D[1 : MAXSTRUCT];
Boolean array M[1 : MAXSTRUCT];
comment *** error handling ***
;
procedure ERRORHANDLER(ERRORSTRING);
string ERRORSTRING;
begin;
NLCR;
NLCR;
PRINTTEXT("+++ error: ");
PRINTTEXT(ERRORSTRING);
goto EX;
;
end ERRORHANDLER;
comment *** representation dependent functions ***
;
procedure COLLECTGARBAGE;
begin;
integer I, J;
FREE := 0;
for I := 1 step 1 until MAXSTRUCT do
M[I] := true;
NLCR;
PRINTTEXT("garbage collector: ");
MARK(OLP);
for I := 0 step 1 until LASTIDF - 1 do
MARK(ALIST[I]);
for I := 1 step 1 until MAXSTRUCT do
if M[I] then begin;
A[I] := FREE;
FREE := I;
end ;
if FREE = 0 then ERRORHANDLER("free list exhausted");
I := 1;
J := FREE;
for J := CARF(J) while J 
0 do I := I + 1;
ABSFIXT(4, 0, I);
NLCR;
end COLLECTGARBAGE;
procedure MARK(REF);
value REF;
integer REF;
begin;
WORK: if REF < D24 then begin;
if M[REF] then begin;
M[REF] := false;
MARK(A[REF]);
REF := D[REF];
goto WORK;
end ;
end ;
end MARK;
integer procedure CREATEIDF;
begin;
integer I, J;
I := 0;
for DUMMY := 0 while I < LASTIDF do
begin;
for J := 0 step 1 until 9 do
if IDF[LASTIDF, J] IDF[I, J] then goto DIFF;
goto OLD;
DIFF: I := I + 1;
end ;
NEW: I := LASTIDF;
ALIST[I] := NILV;
LASTIDF := LASTIDF + 1;
if LASTIDF = MAXIDF then begin;
for I := 0 step 1 until 99 do
begin;
NLCR;
WRITE(D25 + I);
end ;
ERRORHANDLER("too much identifiers");
end ;
OLD: CREATEIDF := D25 + I;
end CREATEIDF;
integer procedure CREATENUM(X);
real X;
begin;
integer I;
NBR[LASTNBR] := X;
I := 0;
for DUMMY := 0 while I < LASTNBR do
begin;
if NBR[LASTNBR] = NBR[I] then goto OLD;
I := I + 1;
end ;
NEW: I := LASTNBR;
LASTNBR := LASTNBR + 1;
if LASTNBR = MAXNBR then ERRORHANDLER("too much numbers");
OLD: CREATENUM := D24 + I;
end CREATENUM;
Boolean procedure ATOMF(X);
value X;
integer X;
begin;
ATOMF := X > D24;
end ATOMF;
Boolean procedure NUMBERPF(X);
value X;
integer X;
begin;
NUMBERPF := X > D24 
X < D25;
end NUMBERPF;
procedure GETIDFVAL(X, IDF);
value X;
integer X, IDF;
begin;
IDF := X - D25;
end GETIDFVAL;
real procedure NUMVAL(X);
value X;
integer X;
begin;
NUMVAL := NBR[X - D24];
end NUMVAL;
integer procedure CARF(X);
value X;
integer X;
begin;
if X > D24 then ERRORHANDLER("car undefined for atomic lisp value");
CARF := A[X];
end CARF;
integer procedure CDRF(X);
value X;
integer X;
begin;
if X > D24 then ERRORHANDLER("cdr undefined for atomic lisp value");
CDRF := D[X];
end CDRF;
integer procedure CONSF(X, Y);
value X, Y;
integer X, Y;
begin;
integer N;
if FREE = 0 then COLLECTGARBAGE;
N := FREE;
FREE := A[FREE];
A[N] := X;
D[N] := Y;
CONSF := N;
end CONSF;
procedure RETURNCELL(X);
value X;
integer X;
begin;
A[X] := FREE;
FREE := X;
end ;
procedure RETURNLIST(X);
value X;
integer X;
begin;
for DUMMY := 0 while X NILV do
begin;
RETURNCELL(X);
X := D[X];
end ;
end RETURNLIST;
procedure RECYCLE(X);
value X;
integer X;
begin;
for DUMMY := 0 while ¬ATOMF(X) do
begin;
RECYCLE(A[X]);
RETURNCELL(X);
X := D[X];
end ;
end RECYCLE;
Boolean procedure EQUALF(X, Y);
value X, Y;
integer X, Y;
begin;
switch S := STR, NUM, ID;
WORK: if X ÷ D24 = Y ÷ D24 then begin;
goto S[X ÷ D24 + 1];
ID: NUM: EQUALF := X = Y;
goto EX;
STR: if EQUALF(A[X], A[Y]) then begin;
X := D[X];
Y := D[Y];
goto WORK;
end else EQUALF := false;
end else EQUALF := false;
EX: ;
end EQUALF;
comment *** input procedures ***
;
integer procedure RESYM;
begin;
integer S;
S := READ;
if S = 122 
S = 124 then begin;
SHIFT := S;
RESYM := RESYM;
end else if S = 16 then RESYM := 93 else if S = 26 then RESYM := 119 else if S = 8 SHIFT = 124 then RESYM := 98 else if S = 25 SHIFT = 124 then RESYM := 99 else if S = 107 then RESYM := 88 else if S = 32 then RESYM := 0 else begin;
S := S ÷ 32 
32 + S - S ÷ 16 16;
if S = 0 then ERRORHANDLER("eof");
RESYM := if S < 10 then S else if S < 64 then S - 6 else if S < 96 then S - 46 else S - 87;
end ;
end RESYM;
procedure NEXTSYM;
begin;
SYM := RESYM;
PRSYM(SYM);
end NEXTSYM;
procedure SKIPSPACES;
begin;
for DUMMY := 0 while SYM = 93 SYM = 118 SYM = 119 do NEXTSYM;
end SKIPSPACES;
integer procedure NUMBER;
begin;
real X;
Boolean SIGNED;
X := 0;
SIGNED := (SYM = 65);
if SIGNED then begin;
NEXTSYM;
if SYM > 9 then ERRORHANDLER("digit expected in input");
end ;
for DUMMY := 0 while SYM < 10 do
begin;
X := 10 X + SYM;
NEXTSYM;
end ;
NUMBER := CREATENUM(if SIGNED then -X else X);
end NUMBER;
integer procedure IDENTIFIER;
begin;
integer I;
IDF[LASTIDF, 0] := SYM;
NEXTSYM;
for I := 1 step 1 until 9 do
IDF[LASTIDF, I] := 93;
I := 0;
for DUMMY := 0 while SYM < 64 I < 9 do
begin;
I := I + 1;
IDF[LASTIDF, I] := SYM;
NEXTSYM;
end ;
for DUMMY := 0 while SYM < 64 do NEXTSYM;
IDENTIFIER := CREATEIDF;
end IDENTIFIER;
integer procedure NEXTITEM;
begin;
integer LV, OP;
SKIPSPACES;
if SYM < 10 SYM = 65 then NEXTITEM := NUMBER else if SYM < 64 then NEXTITEM := IDENTIFIER else if SYM = 98 then begin;
NEXTSYM;
SKIPSPACES;
if SYM = 99 then begin;
NEXTITEM := NILV;
NEXTSYM;
end else begin;
OP := OLP;
OLP := CONSF(NILV, OP);
LV := A[OLP] := CONSF(NILV, NILV);
NEXTITEM := LV;
A[LV] := NEXTITEM;
SKIPSPACES;
if SYM = 88 then begin;
NEXTSYM;
D[LV] := NEXTITEM;
SKIPSPACES;
if SYM 99 then ERRORHANDLER("close missing for dotted pair in input");
end else for DUMMY := 0 while SYM 99 do
begin;
LV := D[LV] := CONSF(NILV, NILV);
A[LV] := NEXTITEM;
SKIPSPACES;
end ;
NEXTSYM;
OLP := OP;
end ;
;
end else if SYM = 120 then begin;
NEXTSYM;
OP := OLP;
OLP := CONSF(NILV, OLP);
LV := A[OLP] := CONSF(NILV, NILV);
NEXTITEM := LV;
A[LV] := QUOTE;
LV := D[LV] := CONSF(NILV, NILV);
A[LV] := NEXTITEM;
OLP := OP;
end else ERRORHANDLER("illegal symbol in input");
end NEXTITEM;
comment *** output procedures ***
;
procedure PRSYM(SYM);
value SYM;
integer SYM;
begin;
switch SW := A0, A1, A2, A3, A4, A5, A6, A7, A8, A9, A, B, C, D, E, F, G, H, I, J, K, L, M, N, O, P, Q, R, S, T, U, V, W, X, Y, Z;
if SYM = 93 then SPACE(1) else if SYM = 88 then PRINTTEXT(".") else if SYM = 98 then PRINTTEXT("(") else if SYM = 99 then PRINTTEXT(")") else if SYM = 119 then NLCR else begin;
if SYM > 35 then ERRORHANDLER("illegal output symbol");
goto SW[SYM + 1];
A0: PRINTTEXT("0");
goto EX;
A1: PRINTTEXT("1");
goto EX;
A2: PRINTTEXT("2");
goto EX;
A3: PRINTTEXT("3");
goto EX;
A4: PRINTTEXT("4");
goto EX;
A5: PRINTTEXT("5");
goto EX;
A6: PRINTTEXT("6");
goto EX;
A7: PRINTTEXT("7");
goto EX;
A8: PRINTTEXT("8");
goto EX;
A9: PRINTTEXT("9");
goto EX;
A: PRINTTEXT("a");
goto EX;
B: PRINTTEXT("b");
goto EX;
C: PRINTTEXT("c");
goto EX;
D: PRINTTEXT("d");
goto EX;
E: PRINTTEXT("e");
goto EX;
F: PRINTTEXT("f");
goto EX;
G: PRINTTEXT("g");
goto EX;
H: PRINTTEXT("h");
goto EX;
I: PRINTTEXT("i");
goto EX;
J: PRINTTEXT("j");
goto EX;
K: PRINTTEXT("k");
goto EX;
L: PRINTTEXT("l");
goto EX;
M: PRINTTEXT("m");
goto EX;
N: PRINTTEXT("n");
goto EX;
O: PRINTTEXT("o");
goto EX;
P: PRINTTEXT("p");
goto EX;
Q: PRINTTEXT("q");
goto EX;
R: PRINTTEXT("r");
goto EX;
S: PRINTTEXT("s");
goto EX;
T: PRINTTEXT("t");
goto EX;
U: PRINTTEXT("u");
goto EX;
V: PRINTTEXT("v");
goto EX;
W: PRINTTEXT("w");
goto EX;
X: PRINTTEXT("x");
goto EX;
Y: PRINTTEXT("y");
goto EX;
Z: PRINTTEXT("z");
end ;
EX: ;
end PRSYM;
procedure ANALYSE(X, R);
value X;
integer X, R;
begin;
integer N, L;
Boolean SIMPLE;
if NUMBERPF(X) then begin;
real DG, V, ABSV;
V := NUMVAL(X);
if V > 0 then begin;
ABSV := V;
L := 1;
end else begin;
ABSV := -V;
L := 2;
end ;
DG := 10;
for DUMMY := 0 while DG < ABSV do
begin;
L := L + 1;
DG := 10 DG;
end ;
R := CREATENUM(L);
end else if ATOMF(X) then begin;
GETIDFVAL(X, ID);
N := 10;
for DUMMY := 0 while IDF[ID, N - 1] = 93 do N := N - 1;
R := CREATENUM(N);
end else if ISLIST(X) then begin;
INDENTATION := INDENTATION + 1;
ANALYSELIST(X, R, L, SIMPLE);
INDENTATION := INDENTATION - 1;
if SIMPLE INDENTATION + L < LINEWIDTH then begin;
RECYCLE(R);
R := CREATENUM(L);
end ;
end else begin;
INDENTATION := INDENTATION + 1;
OLP := CONSF(NILV, OLP);
R := A[OLP] := CONSF(NILV, NILV);
ANALYSE(CARF(X), A[R]);
ANALYSE(CDRF(X), D[R]);
INDENTATION := INDENTATION - 1;
if ATOMF(A[R]) ATOMF(D[R]) then begin;
L := NUMVAL(CARF(R)) + NUMVAL(CDRF(R)) + 5;
if INDENTATION + L < LINEWIDTH then begin;
RECYCLE(R);
R := CREATENUM(L);
end ;
end ;
RETURNCELL(OLP);
OLP := D[OLP];
end ;
end ANALYSE;
procedure ANALYSELIST(X, R, L, SIMPLE);
value X;
integer X, R, L;
Boolean SIMPLE;
begin;
if X = NILV then begin;
R := NILV;
L := 1;
SIMPLE := true;
end else begin;
OLP := CONSF(NILV, OLP);
R := A[OLP] := CONSF(NILV, NILV);
ANALYSE(CARF(X), A[R]);
ANALYSELIST(CDRF(X), D[R], L, SIMPLE);
if SIMPLE ATOMF(A[R]) then L := NUMVAL(A[R]) + L + 1 else SIMPLE := false;
RETURNCELL(OLP);
OLP := D[OLP];
end ;
end ANALYSELIST;
Boolean procedure ISLIST(X);
value X;
integer X;
begin;
WORK: if ATOMF(X) then ISLIST := EQUALF(X, NILV) else begin;
X := CDRF(X);
goto WORK;
end ;
end ISLIST;
procedure WRITENUMBER(X);
value X;
integer X;
begin;
integer N, D, V;
V := NUMVAL(X);
if V < 0 then V := -V;
D := 10;
for DUMMY := 0 while D < V do
D := D 10;
for D := D ÷ 10 while D > 0.5 do
begin;
N := V ÷ D;
PRSYM(N);
V := V - D N;
end ;
end WRITENUMBER;
procedure WRITEIDENTIFIER(X);
value X;
integer X;
begin;
integer I;
GETIDFVAL(X, ID);
for I := 0 step 1 until 9 do
if IDF[ID, I] 93 then PRSYM(IDF[ID, I]);
end WRITEIDENTIFIER;
procedure WRITELIST(X, R);
value X, R;
integer X, R;
begin;
integer A, IND;
Boolean SIMPLE, NL;
PRSYM(98);
if ATOMF(R) then begin;
for DUMMY := 0 while X NILV do
begin;
WRITEVALUE(CARF(X), R);
X := CDRF(X);
if X NILV then PRSYM(93);
end ;
end else begin;
INDENTATION := INDENTATION + 1;
IND := INDENTATION;
for DUMMY := 0 while X NILV do
begin;
A := CARF(R);
SIMPLE := ATOMF(A);
if SIMPLE then NL := NUMVAL(A) + INDENTATION > LINEWIDTH else NL := INDENTATION > IND;
if NL then begin;
INDENTATION := IND;
NLCR;
SPACE(IND);
end else if INDENTATION > IND then PRSYM(93);
WRITEVALUE(CARF(X), A);
if SIMPLE then INDENTATION := INDENTATION + NUMVAL(A) + 1 else INDENTATION := LINEWIDTH + 1;
X := CDRF(X);
R := CDRF(R);
end ;
INDENTATION := IND - 1;
NLCR;
SPACE(INDENTATION);
end ;
PRSYM(99);
end WRITELIST;
procedure WRITEPAIR(X, R);
value X, R;
integer X, R;
begin;
PRSYM(98);
if ATOMF(R) then begin;
WRITEVALUE(CARF(X), R);
PRINTTEXT(" . ");
WRITEVALUE(CDRF(X), R);
end else begin;
INDENTATION := INDENTATION + 1;
WRITEVALUE(CARF(X), CARF(R));
NLCR;
SPACE(INDENTATION - 1);
PRINTTEXT(" . ");
NLCR;
SPACE(INDENTATION);
WRITEVALUE(CDRF(X), CDRF(R));
NLCR;
SPACE(INDENTATION);
end ;
PRSYM(99);
end WRITEPAIR;
procedure WRITEVALUE(X, R);
value X, R;
integer X, R;
begin;
if NUMBERPF(X) then WRITENUMBER(X) else if ATOMF(X) then WRITEIDENTIFIER(X) else if ISLIST(X) then WRITELIST(X, R) else WRITEPAIR(X, R);
end WRITEVALUE;
procedure WRITE(X);
value X;
integer X;
begin;
integer R;
INDENTATION := 0;
ANALYSE(X, R);
WRITEVALUE(X, R);
RECYCLE(R);
end WRITE;
comment *** interpreter proper ***
;
integer procedure ASSOC(X);
value X;
integer X;
begin;
integer AX;
GETIDFVAL(X, ID);
AX := ALIST[ID];
if AX = NILV then ERRORHANDLER("identifier has no value");
ASSOC := CARF(AX);
end ASSOC;
procedure PAIRLIS(X, Y);
value X, Y;
integer X, Y;
begin;
for DUMMY := 0 while ¬EQUALF(X, NILV) do
begin;
GETIDFVAL(CARF(X), ID);
ALIST[ID] := CONSF(CARF(Y), ALIST[ID]);
X := CDRF(X);
Y := CDRF(Y);
end ;
end PAIRLIS;
procedure DEPAIRLIS(X);
value X;
integer X;
begin;
for DUMMY := 0 while ¬EQUALF(X, NILV) do
begin;
GETIDFVAL(CARF(X), ID);
ALIST[ID] := CDRF(ALIST[ID]);
X := CDRF(X);
end ;
end DEPAIRLIS;
integer procedure EVAL(E);
value E;
integer E;
begin;
integer CARE;
WORK: if ATOMF(E) then begin;
if EQUALF(E, NILV) EQUALF(E, T) NUMBERPF(E) then EVAL := E else EVAL := ASSOC(E);
end else begin;
CARE := CARF(E);
if EQUALF(CARE, COND) then begin;
E := EVCON(CDRF(E));
goto WORK;
end else if EQUALF(CARE, QUOTE) then EVAL := CARF(CDRF(E)) else begin;
OLP := CONSF(NILV, OLP);
A[OLP] := EVLIST(CDRF(E));
EVAL := APPLY(CARE, A[OLP]);
RETURNLIST(A[OLP]);
RETURNCELL(OLP);
OLP := CDRF(OLP);
end ;
end ;
end EVAL;
integer procedure APPLY(F, X);
value F, X;
integer F, X;
begin;
WORK: if ATOMF(F) then begin;
if EQUALF(F, CAR) then APPLY := CARF(CARF(X)) else if EQUALF(F, CDR) then APPLY := CDRF(CARF(X)) else if EQUALF(F, CONS) then APPLY := CONSF(CARF(X), CARF(CDRF(X))) else if EQUALF(F, EQUAL) then begin;
if EQUALF(CARF(X), CARF(CDRF(X))) then APPLY := T else APPLY := NILV;
end else if EQUALF(F, ATOM) then begin;
if ATOMF(CARF(X)) then APPLY := T else APPLY := NILV;
end else if EQUALF(F, NUMBERP) then begin;
if NUMBERPF(CARF(X)) then APPLY := T else APPLY := NILV;
end else if EQUALF(F, LESSP) then begin;
if NUMVAL(CARF(X)) < NUMVAL(CARF(CDRF(X))) then APPLY := T else APPLY := NILV;
end else if EQUALF(F, GREATERP) then begin;
if NUMVAL(CARF(X)) > NUMVAL(CARF(CDRF(X))) then APPLY := T else APPLY := NILV;
end else if EQUALF(F, ADD) then APPLY := CREATENUM(NUMVAL(CARF(X)) + 1) else if EQUALF(F, SUB1) then APPLY := CREATENUM(NUMVAL(CARF(X)) - 1) else if EQUALF(F, ADD) then APPLY := CREATENUM(NUMVAL(CARF(X)) + NUMVAL(CARF(CDRF(X)))) else if EQUALF(F, MINUS) then APPLY := CREATENUM(NUMVAL(CARF(X)) - NUMVAL(CARF(CDRF(X)))) else if EQUALF(F, TIMESV) then APPLY := CREATENUM(NUMVAL(CARF(X)) NUMVAL(CARF(CDRF(X)))) else if EQUALF(F, DIVF) then APPLY := CREATENUM(NUMVAL(CARF(X)) ÷ NUMVAL(CARF(CDRF(X)))) else begin;
F := ASSOC(F);
goto WORK;
end ;
end else begin;
PAIRLIS(CARF(CDRF(F)), X);
APPLY := EVAL(CARF(CDRF(CDRF(F))));
DEPAIRLIS(CARF(CDRF(F)));
end ;
end APPLY;
integer procedure EVCON(X);
value X;
integer X;
begin;
integer R;
WORK: R := CARF(X);
if EQUALF(EVAL(CARF(R)), NILV) then begin;
X := CDRF(X);
goto WORK;
end else EVCON := CARF(CDRF(R));
end EVCON;
integer procedure EVLIST(X);
value X;
integer X;
begin;
integer RES;
if EQUALF(X, NILV) then EVLIST := NILV else begin;
OLP := CONSF(NILV, OLP);
A[OLP] := RES := CONSF(NILV, NILV);
A[RES] := EVAL(CARF(X));
D[RES] := EVLIST(CDRF(X));
EVLIST := RES;
RETURNCELL(OLP);
OLP := CDRF(OLP);
end ;
end EVLIST;
comment *** initialization ***
;
procedure CREATE(LV);
integer LV;
begin;
SKIPSPACES;
LV := IDENTIFIER;
;
end CREATE;
procedure INIT;
begin;
integer I, J;
D24 := 16777216;
D25 := 33554432;
LASTIDF := 0;
SYM := 93;
NILV := D25 + 1;
CREATE(T);
CREATE(NILV);
CREATE(QUOTE);
CREATE(COND);
CREATE(LAMBDA);
CREATE(DEFINE);
CREATE(CAR);
CREATE(CDR);
CREATE(CONS);
CREATE(EQUAL);
CREATE(ATOM);
CREATE(NUMBERP);
CREATE(LESSP);
CREATE(GREATERP);
CREATE(ADD1);
CREATE(SUB1);
CREATE(ADD);
CREATE(MINUS);
CREATE(TIMESV);
CREATE(DIVF);
OLP := NILV;
FREE := 1;
LASTNBR := 0;
LINEWIDTH := 40;
for I := 1 step 1 until MAXSTRUCT - 1 do
A[I] := I + 1;
A[MAXSTRUCT] := 0;
end INIT;
comment *** main program ***
;
procedure FUNCTIONDEFINITIONS(X, A, R);
value X;
integer X, A, R;
begin;
integer CARX, LR;
if EQUALF(X, NILV) then R := NILV else begin;
CARX := CARF(X);
A := CONSF(CONSF(CARF(CARX), CARF(CDRF(CARX))), A);
FUNCTIONDEFINITIONS(CDRF(X), A, LR);
R := CONSF(CARF(CARX), LR);
end ;
end FUNCTIONDEFINITIONS;
PRINTTEXT("Lisp interpreter version 1, Oktober 2004");
NLCR;
NLCR;
INIT;
for DUMMY := 0 while true do
begin;
OLP := CONSF(NILV, OLP);
A[OLP] := P := CONSF(NILV, NILV);
A[P] := F := NEXTITEM;
D[P] := ARGS := NEXTITEM;
NLCR;
if EQUALF(F, DEFINE) then begin;
ARGS := CARF(ARGS);
PRSYM(98);
for DUMMY := 0 while ¬EQUALF(ARGS, NILV) do
begin;
P := CARF(ARGS);
WRITE(CARF(P));
GETIDFVAL(CARF(P), ID);
ALIST[ID] := CONSF(CARF(CDRF(P)), NILV);
ARGS := CDRF(ARGS);
if ¬EQUALF(ARGS, NILV) then SPACE(1);
end ;
PRSYM(99);
end else begin;
P := APPLY(F, ARGS);
NLCR;
WRITE(P);
end ;
OLP := CDRF(OLP);
end ;
EX: ;
end ;
end;