lisp.pas

{+		PASCAL/Z COMPILER OPTIONS		+}
{++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{$C- <<< CONTROL-C KEYPRESS CHECKING OFF >>>		 }	
{$F- <<< FLOATING POINT ERROR CHECKING OFF >>>		 }
{$M- <<< INTEGER MULT & DIVD ERROR CHECKING OFF >>>      }
{++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
PROGRAM LISP {VERSION 1.7};
{
+  PROGRAM TITLE:	THE ESSENCE OF A LISP INTERPRETER.
+  WRITTEN BY:		W. TAYLOR AND L. COX
+
+  WRITTEN FOR:		US DEPT OF ENERGY
+			CONTRACT # W-7405-ENG-48
+
+	FIRST DATA STARTED : 10/29/76
+	LAST DATE MODIFIED : 12/10/76
+
+ ENTERED BY RAY PENLEY 8 DEC 80.
+ -SOME IDENTIFIERS HAVE BEEN SLIGHTLY MODIFIED BECAUSE OF THE
+  LIMITATION ON IDENTIFIER LENGTH OF 8 CHARACTERS.
+
+ MODIFIED BY LANFRANCO EMILIANI IN THE PERIOD MARS-MAY 1983 :
+	- TO REMOVE THE TWO JUMPS OUT OF PROCEDURES PRESENT IN THE
+	  ZUG VOL # 14 VERSION;
+	- TO REMOVE TWO BUGS PRESENT IN THAT VERSION;
+	- TO PROVIDE ADDITIONAL FEATURES.
+
+ REFER TO LISP.DOC FOR A DESCRIPTION OF THE MAIN FEATURES OF THE
+ INTERPRETER AND HOW TO OPERATE IT.
+ 
+ REFER TO THE COMMENTS IN THE ZUG VOL # 14 VERSION FOR SPECIFIC
+ EXPLANATORY NOTES CONCERNING THE MOST SIGNIFICANT PROCEDURES OR
+ FUNCTIONS.
+
}
LABEL
  1,	{ USED TO RECOVER AFTER AN ERROR BY THE USER }
  2;	{ IN CASE THE END OF FILE IS REACHED BEFORE A FIN CARD }

CONST
  MAXNODE = 1000;
{}INPUT = 0;	{ Pascal/Z = console as input }
{}IDLENGTH = 10;

TYPE
{}ALFA = ARRAY [1..IDLENGTH] OF CHAR;
  INPUTSYMBOL = (ATOM, PERIOD, LPAREN, RPAREN);
  RESERVEWORDS = (	ANDSYM,
			APPENDSYM,
			ATOMSYM,
			HEADSYM,
			TAILSYM,
			CONDSYM,
			CONSSYM,
			COPYSYM,
			DEFEXPSYM,
			DEFFEXPSYM,
			DEFMACSYM,
			EQSYM,
			EQUALSYM,
			EVALSYM,
			FLAMBDASYM,
			FUNARGSYM,
			FUNCTSYM,
			GOSYM,
			LABELSYM,
			LAMBDASYM,
			LASTSYM,
			LENGTHSYM,
			LISTSYM,
			NOTSYM,
			NULLSYM,
			ORSYM,
			PROGSYM,
			PROG2SYM,
			PROGNSYM,
			QUOTESYM,
			RELACEHSYM,
			RELACETSYM,
			REMOBSYM,
			RETURNSYM,
			REVERSESYM,
			SETSYM,
			SETQSYM,
			TRACESYM,
			UNTRACESYM	);
  STATUSTYPE = (UNMARKED, LEFT, RIGHT, MARKED);
  SYMBEXPPTR = ^SYMBOLICEXPRESSION;
  SYMBOLICEXPRESSION = RECORD
			 STATUS : STATUSTYPE;
			 NEXT   : SYMBEXPPTR;
			 CASE ANATOM: BOOLEAN OF
			   TRUE: (NAME: ALFA;
				  CASE ISARESERVEDWORD: BOOLEAN OF
				    TRUE: (RESSYM: RESERVEWORDS));
			   FALSE: (HEAD, TAIL: SYMBEXPPTR)
			END;

VAR
  END_FREELIST  : BOOLEAN;
  ERR_COND	: BOOLEAN;
  TRACE_ON      : BOOLEAN;
  NESTCOUNT     : INTEGER;

{ 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 THE ATOM THAT WAS LAST READ }
  ALREADYPEEKED	: BOOLEAN;	{ TELLS 'NEXTSYM' WHETHER WE HAVE PEEKED }
  CH		: CHAR;		{ THE LAST CHAR READ FROM INPUT }
  PTR		: SYMBEXPPTR;	{ POINTER TO THE EXPRESSION BEING EVALUATED }
  TEMP		: SYMBEXPPTR;

	{ 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;{ POINTER TO THE ASSOCIATION LIST }

	{ TWO NODES WHICH HAVE CONSTANT VALUES }

  NILNODE,
  TNODE	: SYMBOLICEXPRESSION;

	{ VARIABLES USED TO IDENTIFY ATOMS WITH PRE-DEFINED MEANINGS }

  RESWORD	: RESERVEWORDS;
  RESERVED	: BOOLEAN;
  RESWORDS	: ARRAY [RESERVEWORDS] OF ALFA;
  FREENODES	: INTEGER; { NUMBER OF CURRENTLY FREE NODES KNOWN }
  NUMBEROFGCS	: INTEGER; { # OF GARBAGE COLLECTIONS MADE }

  INFILE        : TEXT;


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 { OF CASE }
  END { OF MARK };

  PROCEDURE COLLECTFREENODES;
  VAR
    TEMP: SYMBEXPPTR;
  BEGIN
{
    WRITELN(' NUMBER OF FREE 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 {WHILE};
{
    WRITELN(' NUMBER OF FREE NODES AFTER COLLECTION = ', FREENODES:1,'.');
}
  END { OF COLLECTFREENODES };

BEGIN{ GARBAGEMAN }
  NUMBEROFGCS := NUMBEROFGCS + 1;
{ WRITELN; WRITELN(' GARBAGE COLLECTION. '); WRITELN; }
  MARK(ALIST);
  IF ( PTR <> NIL ) THEN MARK(PTR);
  COLLECTFREENODES
END{ OF GARBAGEMAN };

PROCEDURE POP(VAR SPTR: SYMBEXPPTR);
LABEL 1;
BEGIN
  IF ( FREELIST = NIL ) THEN BEGIN
    WRITELN(' NOT ENOUGH SPACE TO EVALUATE THE EXPRESSION.');
    END_FREELIST := TRUE;
    GOTO 1;
  END;
  FREENODES := FREENODES - 1;
  SPTR := FREELIST;
  FREELIST := FREELIST^.HEAD;
1:
END{ OF POP };


PROCEDURE ERROR(NUMBER: INTEGER);
BEGIN
  WRITELN; WRITE('  ERROR   ', NUMBER:1, ', ');
  CASE NUMBER 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, LAMBDA, FLAMBDA, ETC. ARE NOT FUNCTIONS NAMES.');
    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 HEAD IS AN ATOM.');
    8: WRITELN('ARGUMENT TAIL IS AN ATOM.');
    9: WRITELN('1ST ARGUMENT OF APPEND IS NOT A LIST.');
   10: WRITELN('LABEL OR LAMBDA OR FLAMBDA ETC. EXPECTED.');
   11: WRITELN('NAME OF VARIABLE IS NOT AN ATOM.');
   12: WRITELN('ARGUMENT OF LENGTH IS NOT A LIST.');
   13: WRITELN('ARGUMENT OF PROG IS NOT A LIST.');
   14: WRITELN('LOOP IDENTIFIER NOT FOUND.');
  END{CASE};
  ERR_COND := TRUE
END { OF ERROR };

PROCEDURE BACKUPINPUT;
BEGIN
  ALREADYPEEKED := TRUE; LOOKAHEADSYM := SYM; SYM := LPAREN
END{ OF BACKUPINPUT };

PROCEDURE NEXTSYM1;
VAR	I: INTEGER;
BEGIN
  IF ( ALREADYPEEKED ) THEN BEGIN
      SYM := LOOKAHEADSYM; ALREADYPEEKED := FALSE
  END
  ELSE
    BEGIN
      WHILE ( CH=' ' ) DO BEGIN
	IF ( EOLN(INFILE) ) THEN READLN(INFILE);
        READ(INFILE, CH);
      END{WHILE};
      IF ( CH IN ['(','.',')'] ) THEN BEGIN
	CASE CH OF
	  '(': SYM := LPAREN;
	  '.': SYM := PERIOD;
	  ')': SYM := RPAREN
	END{CASE};
	IF ( EOLN(INFILE) ) THEN READLN(INFILE);
        READ(INFILE, CH);
      END
      ELSE BEGIN
	SYM := ATOM; ID := '          ';
	I := 0;
	REPEAT
	  I := I + 1;
	  IF ( I < (IDLENGTH+1) ) THEN ID[I] := CH;
	  IF ( EOLN(INFILE) ) THEN READLN(INFILE);
          READ(INFILE, CH);
	UNTIL ( CH IN [' ','(','.',')'] );
	RESWORD := ANDSYM;
	WHILE (ID <> RESWORDS[RESWORD]) AND (RESWORD <> UNTRACESYM) DO
	  RESWORD := SUCC(RESWORD);
	RESERVED := ( ID=RESWORDS[RESWORD] )
      END
    END  
END{ OF NEXTSYM1 };

PROCEDURE READEXP1(VAR SPTR: SYMBEXPPTR);
LABEL 1;
VAR	NXT: SYMBEXPPTR;
BEGIN
IF (ERR_COND) OR (END_FREELIST) THEN GOTO 1 ELSE
  BEGIN
  POP(SPTR);
  IF END_FREELIST THEN GOTO 1;
  NXT := SPTR^.NEXT;
  CASE SYM OF
    RPAREN, PERIOD: BEGIN ERROR(1); GOTO 1 END;
    ATOM:
	WITH SPTR^ DO BEGIN {  <ATOM>  }
	  ANATOM := TRUE; NAME := ID; ISARESERVEDWORD := RESERVED;
	  IF ( RESERVED ) THEN RESSYM := RESWORD
	END;
    LPAREN:
	WITH SPTR^ DO BEGIN
          NEXTSYM1;
	  IF ( SYM=PERIOD ) THEN BEGIN ERROR(2); GOTO 1 END
	  ELSE
	    IF ( SYM=RPAREN ) THEN SPTR^ := NILNODE {   () = NIL   }
	    ELSE BEGIN
		ANATOM := FALSE; READEXP1(HEAD); NEXTSYM1;
		IF ( SYM=PERIOD ) THEN BEGIN {   ( <S-EXPR> . <S-EXPR> )   }
		   NEXTSYM1; READEXP1(TAIL); NEXTSYM1;
		   IF (SYM<>RPAREN) THEN BEGIN ERROR(4); GOTO 1 END
		END
		ELSE BEGIN {   ( <S-EXPR> <S-EXPR> ... <S-EXPR> )   }
		  BACKUPINPUT; READEXP1(TAIL)
		END
	    END
	END{WITH}
  END{CASE};
  SPTR^.NEXT := NXT;
  END;
1:
END{ OF READEXP1 };

PROCEDURE NEXTSYM;
VAR	I: INTEGER;
BEGIN
  IF ( ALREADYPEEKED ) THEN BEGIN
      SYM := LOOKAHEADSYM; ALREADYPEEKED := FALSE
  END
  ELSE
    BEGIN
      WHILE ( CH=' ' ) DO BEGIN
	IF ( EOLN(INPUT) ) THEN READLN;
	READ(CH);
      END{WHILE};
      IF ( CH IN ['(','.',')'] ) THEN BEGIN
	CASE CH OF
	  '(': SYM := LPAREN;
	  '.': SYM := PERIOD;
	  ')': SYM := RPAREN
	END{CASE};
	IF ( EOLN(INPUT) ) THEN READLN;
	READ(CH);
      END
      ELSE BEGIN
	SYM := ATOM; ID := '          ';
	I := 0;
	REPEAT
	  I := I + 1;
	  IF ( I < (IDLENGTH+1) ) THEN ID[I] := CH;
	  IF (EOLN (INPUT) ) THEN READLN;
	  READ(CH);
	UNTIL ( CH IN [' ','(','.',')'] );
	RESWORD := ANDSYM;
	WHILE (ID <> RESWORDS[RESWORD]) AND (RESWORD <> UNTRACESYM) DO
	  RESWORD := SUCC(RESWORD);
	RESERVED := ( ID=RESWORDS[RESWORD] )
      END
    END  
END{ OF NEXTSYM };

PROCEDURE READEXPR(VAR SPTR: SYMBEXPPTR);
LABEL 1;
VAR	NXT: SYMBEXPPTR;
BEGIN
IF (ERR_COND) OR (END_FREELIST) THEN GOTO 1 ELSE
  BEGIN
  POP(SPTR);
  IF END_FREELIST THEN GOTO 1;
  NXT := SPTR^.NEXT;
  CASE SYM OF
    RPAREN, PERIOD: BEGIN ERROR(1); GOTO 1 END;
    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 BEGIN ERROR(2); GOTO 1 END
	  ELSE
	    IF ( SYM=RPAREN ) THEN SPTR^ := NILNODE {   () = NIL   }
	    ELSE BEGIN
		ANATOM := FALSE; READEXPR(HEAD); NEXTSYM;
		IF ( SYM=PERIOD ) THEN BEGIN {   ( <S-EXPR> . <S-EXPR> )   }
		   NEXTSYM;  READEXPR(TAIL); NEXTSYM;
		   IF (SYM<>RPAREN) THEN BEGIN ERROR(4); GOTO 1 END
		END
		ELSE BEGIN {   ( <S-EXPR> <S-EXPR> ... <S-EXPR> )   }
		  BACKUPINPUT; READEXPR(TAIL)
		END
	    END
	END{WITH}
  END{CASE};
  SPTR^.NEXT := NXT;
  END;
1:
END{ OF READEXPR };

PROCEDURE PRINTNAME(NAME: ALFA);
VAR	I: INTEGER;
BEGIN
  I := 0;
  REPEAT
    I := I + 1;
    WRITE(NAME[I])
  UNTIL (NAME[I]=' ') OR ( I=IDLENGTH );
  IF ( I=IDLENGTH ) THEN WRITE(' ')
END{ OF PRINTNAME };

PROCEDURE PRINTEXPR(SPTR : SYMBEXPPTR);
LABEL 1, 2;
BEGIN
IF (ERR_COND) OR (END_FREELIST) THEN GOTO 2 ELSE
 BEGIN
  IF ( SPTR^.ANATOM ) THEN
    PRINTNAME(SPTR^.NAME)
  ELSE BEGIN
    WRITE('(');
 1: PRINTEXPR(SPTR^.HEAD);
    IF ( SPTR^.TAIL^.ANATOM ) AND ( SPTR^.TAIL^.NAME='NIL       ') THEN
      WRITE(')')
    ELSE IF ( SPTR^.TAIL^.ANATOM ) THEN BEGIN
      WRITE('.'); PRINTEXPR(SPTR^.TAIL); WRITE(')')
    END
    ELSE BEGIN
      SPTR := SPTR^.TAIL;
      GOTO 1
    END
  END
 END;
2:
END{ OF PRINTEXPR };


PROCEDURE TRACENTER(ID : ALFA);
VAR 	J : INTEGER;
BEGIN
NESTCOUNT := NESTCOUNT + 1;
FOR J := 0 TO NESTCOUNT DO WRITE('  ');
WRITE('ENTERING : ');
FOR J := 1 TO IDLENGTH DO WRITE(ID[J]);
WRITELN
END{ OF TRACENTER };

PROCEDURE TRACEXIT(ID : ALFA);
VAR 	J : INTEGER;
BEGIN
FOR J := 0 TO NESTCOUNT DO WRITE('  ');
WRITE('EXITING  : ');
FOR J := 1 TO IDLENGTH DO WRITE(ID[J]);
WRITELN;
NESTCOUNT := NESTCOUNT - 1
END{ OF TRACEXIT };

FUNCTION EVAL( E : SYMBEXPPTR; VAR ALIST : SYMBEXPPTR ): SYMBEXPPTR;
LABEL 1;
VAR	TEMP, CAROFE, CAAROFE: SYMBEXPPTR;

  FUNCTION MKATOM(ID : ALFA): SYMBEXPPTR;
  LABEL 1;
  VAR	TEMP: SYMBEXPPTR;
  BEGIN
    IF TRACE_ON THEN TRACENTER('MKATOM    ');
    POP(TEMP);
    IF END_FREELIST THEN GOTO 1;
    RESWORD := APPENDSYM;
    WHILE (ID <> RESWORDS[RESWORD]) AND (RESWORD <> SETQSYM) DO
      RESWORD := SUCC(RESWORD);
    RESERVED := ( ID = RESWORDS[RESWORD] );
    WITH TEMP^ DO BEGIN
      ANATOM := TRUE;
      NAME := ID;
      ISARESERVEDWORD := RESERVED;
      IF (RESERVED) THEN RESSYM := RESWORD
    END;
    MKATOM := TEMP;
  1:
  IF TRACE_ON THEN TRACEXIT('MKATOM    ')
  END{ OF MKATOM };

  FUNCTION REPLACEH(SPTR1, SPTR2: SYMBEXPPTR): SYMBEXPPTR;
  LABEL 1;
  BEGIN
  IF TRACE_ON THEN TRACENTER('REPLACEH  ');
  IF (ERR_COND) OR (END_FREELIST) THEN GOTO 1 ELSE
    BEGIN
    IF ( SPTR1^.ANATOM ) THEN BEGIN ERROR(5); GOTO 1 END
    ELSE SPTR1^.HEAD := SPTR2;
    REPLACEH := SPTR1;
    END;
  1:
  IF TRACE_ON THEN TRACEXIT('REPLACEH  ')
  END{ OF REPLACEH };

  FUNCTION REPLACET(SPTR1, SPTR2: SYMBEXPPTR): SYMBEXPPTR;
  LABEL 1;
  BEGIN
  IF TRACE_ON THEN TRACENTER('REPLACET  ');
  IF (ERR_COND) OR (END_FREELIST) THEN GOTO 1 ELSE
    BEGIN
    IF ( SPTR1^.ANATOM ) THEN BEGIN ERROR(6); GOTO 1 END
    ELSE SPTR1^.TAIL := SPTR2;
    REPLACET := SPTR1;
    END;
  1:
  IF TRACE_ON THEN TRACEXIT('REPLACET  ')
  END{ OF REPLACET };

  FUNCTION HEAD(SPTR: SYMBEXPPTR): SYMBEXPPTR;
  LABEL 1;
  BEGIN
  IF TRACE_ON THEN TRACENTER('CAR       ');
  IF (ERR_COND) OR (END_FREELIST) THEN GOTO 1 ELSE
    BEGIN
    IF ( SPTR^.ANATOM ) THEN BEGIN ERROR(7); GOTO 1 END
    ELSE HEAD := SPTR^.HEAD;
    END;
  1:
  IF TRACE_ON THEN TRACEXIT('CAR       ')
  END{ OF HEAD };

  FUNCTION TAIL(SPTR: SYMBEXPPTR): SYMBEXPPTR;
  LABEL 1;
  BEGIN
  IF TRACE_ON THEN TRACENTER('CDR       ');
  IF (ERR_COND) OR (END_FREELIST) THEN GOTO 1 ELSE
    BEGIN
    IF ( SPTR^.ANATOM ) THEN BEGIN ERROR(8); GOTO 1 END
    ELSE TAIL := SPTR^.TAIL;
    END;
  1:
  IF TRACE_ON THEN TRACEXIT('CDR       ')
  END{ OF TAIL };

  FUNCTION CONS(SPTR1, SPTR2: SYMBEXPPTR): SYMBEXPPTR;
  LABEL 1;
  VAR	TEMP: SYMBEXPPTR;
  BEGIN
  IF TRACE_ON THEN TRACENTER('CONS      ');
  IF (ERR_COND) OR (END_FREELIST) THEN GOTO 1 ELSE
    BEGIN
    POP(TEMP);
    IF END_FREELIST THEN GOTO 1;
    TEMP^.ANATOM := FALSE; TEMP^.HEAD := SPTR1;
    TEMP^.TAIL := SPTR2; CONS := TEMP;
    END;
  1:
  IF TRACE_ON THEN TRACEXIT('CONS      ')
  END{ OF CONS };

  FUNCTION COPY(SPTR: SYMBEXPPTR): SYMBEXPPTR;
  LABEL 1;
  VAR	TEMP, NXT: SYMBEXPPTR;
  BEGIN
  IF TRACE_ON THEN TRACENTER('COPY      ');
  IF (ERR_COND) OR (END_FREELIST) THEN GOTO 1 ELSE
    BEGIN
    IF ( SPTR^.ANATOM ) THEN BEGIN
	POP(TEMP);
	IF END_FREELIST THEN GOTO 1;
	NXT := TEMP^.NEXT; TEMP^ := SPTR^;
 	TEMP^.NEXT := NXT; COPY := TEMP
    END
    ELSE
	COPY := CONS(COPY(SPTR^.HEAD), COPY(SPTR^.TAIL));
    END;
  1:
  IF TRACE_ON THEN TRACEXIT('COPY      ')
  END{ OF COPY };

  FUNCTION APPEND(SPTR1, SPTR2: SYMBEXPPTR): SYMBEXPPTR;
  LABEL 1;
  BEGIN
  IF TRACE_ON THEN TRACENTER('APPEND    ');
  IF (ERR_COND) OR (END_FREELIST) THEN GOTO 1 ELSE
    BEGIN
    IF ( SPTR1^.ANATOM ) THEN
      IF ( SPTR1^.NAME<>'NIL       ' ) THEN BEGIN ERROR(9); GOTO 1 END
      ELSE APPEND := SPTR2
    ELSE
      APPEND := CONS(COPY(SPTR1^.HEAD), APPEND(SPTR1^.TAIL,SPTR2));
    END;
  1:
  IF TRACE_ON THEN TRACEXIT('APPEND    ')
  END{ OF APPEND };

  FUNCTION LIST(SPTR1: SYMBEXPPTR): SYMBEXPPTR;
  LABEL 1;
  VAR
    NILPTR: SYMBEXPPTR;
  BEGIN
  IF TRACE_ON THEN TRACENTER('LIST      ');
  IF (ERR_COND) OR (END_FREELIST) THEN GOTO 1 ELSE
    BEGIN
    IF NOT SPTR1^.ANATOM THEN 
      LIST := CONS(EVAL(SPTR1^.HEAD, ALIST), LIST(SPTR1^.TAIL))
    ELSE BEGIN
      IF SPTR1^.NAME <> 'NIL       ' THEN BEGIN
        NEW(NILPTR);
        WITH NILPTR^ DO BEGIN
	  ANATOM := TRUE; NAME := 'NIL       '
	  END {WITH};
	LIST := CONS(EVAL(SPTR1, ALIST), NILPTR)
	END
      ELSE LIST := SPTR1
      END
    END;
  1:
  IF TRACE_ON THEN TRACEXIT('LIST      ')
  END{ OF LIST };

  FUNCTION EQQ(SPTR1, SPTR2: SYMBEXPPTR): SYMBEXPPTR;
  LABEL 1;
  VAR	TEMP, NXT: SYMBEXPPTR;
  BEGIN
  IF TRACE_ON THEN TRACENTER('EQ        ');
  IF (ERR_COND) OR (END_FREELIST) THEN GOTO 1 ELSE
    BEGIN
    POP(TEMP);
    IF END_FREELIST THEN GOTO 1;
    NXT := TEMP^.NEXT;
    IF ((SPTR1^.ANATOM) AND (SPTR2^.ANATOM) AND (SPTR1^.NAME=SPTR2^.NAME))
       OR (SPTR1 = SPTR2) THEN TEMP^ := TNODE
    ELSE TEMP^ := NILNODE;
    TEMP^.NEXT := NXT; EQQ := TEMP;
    END;
  1:
  IF TRACE_ON THEN TRACEXIT('EQ        ')
  END{ OF EQQ };

  FUNCTION EQUAL(SPTR1, SPTR2 : SYMBEXPPTR): SYMBEXPPTR;
  LABEL 1;
  VAR   TEMP, NXT : SYMBEXPPTR;
  BEGIN
  IF TRACE_ON THEN TRACENTER('EQUAL     ');
  IF (ERR_COND) OR (END_FREELIST) THEN GOTO 1 ELSE
    BEGIN
    POP(TEMP);
    IF END_FREELIST THEN GOTO 1;
    NXT := TEMP^.NEXT;
    IF (SPTR1^.ANATOM) THEN BEGIN
	IF (SPTR2^.ANATOM) THEN TEMP := EQQ(SPTR1, SPTR2)
	ELSE TEMP^ := NILNODE
	END
    ELSE BEGIN
	IF SPTR2^.ANATOM THEN TEMP^ := NILNODE
	ELSE BEGIN
	    TEMP := EQUAL(HEAD(SPTR1), HEAD(SPTR2));
	    IF ( TEMP^.NAME = 'T         ' ) THEN
	    TEMP := EQUAL(TAIL(SPTR1), TAIL(SPTR2))
	    ELSE BEGIN
		TEMP^ := NILNODE
	    END
	END
    END;
    TEMP^.NEXT := NXT;
    EQUAL := TEMP
    END;
  1:
  IF TRACE_ON THEN TRACEXIT('EQUAL     ')
  END{ OF EQUAL };

  FUNCTION NULL(SPTR : SYMBEXPPTR) : SYMBEXPPTR;
  LABEL 1;
  VAR   TEMP, NXT : SYMBEXPPTR;
  BEGIN
  IF TRACE_ON THEN TRACENTER('NULL      ');
  IF (ERR_COND) OR (END_FREELIST) THEN GOTO 1 ELSE
    BEGIN
    POP(TEMP);
    IF END_FREELIST THEN GOTO 1;
    NXT := TEMP^.NEXT; TEMP^ := NILNODE; TEMP^.NEXT := NXT;
    NULL := EQQ(SPTR, TEMP)
    END;
  1:
  IF TRACE_ON THEN TRACEXIT('NULL      ')
  END{ OF NULL };

  FUNCTION ET(SPTR: SYMBEXPPTR): SYMBEXPPTR;
  LABEL 1;
  VAR	TEMP: SYMBEXPPTR;
  BEGIN
  IF TRACE_ON THEN TRACENTER('AND       ');
  IF (ERR_COND) OR (END_FREELIST) THEN GOTO 1 ELSE
    BEGIN
    IF (SPTR^.ANATOM) AND (SPTR^.NAME = 'NIL       ') THEN 
    ET := MKATOM('T         ')
    ELSE BEGIN
      TEMP := EVAL(HEAD(SPTR), ALIST);
      IF (TEMP^.ANATOM) AND (TEMP^.NAME = 'NIL       ') THEN ET := TEMP
      ELSE ET := ET(TAIL(SPTR))
      END
    END;
  1:
  IF TRACE_ON THEN TRACEXIT('AND       ')
  END{ OF ET };

  FUNCTION OU(SPTR: SYMBEXPPTR): SYMBEXPPTR;
  LABEL 1;
  VAR	TEMP: SYMBEXPPTR;
  BEGIN
  IF TRACE_ON THEN TRACENTER('OR        ');
  IF (ERR_COND) OR (END_FREELIST) THEN GOTO 1 ELSE
    BEGIN
    IF (SPTR^.ANATOM) AND (SPTR^.NAME = 'NIL       ') THEN OU := SPTR
    ELSE BEGIN
      TEMP := EVAL(HEAD(SPTR), ALIST);
      IF (TEMP^.ANATOM) AND (TEMP^.NAME <> 'NIL       ') THEN
      OU := MKATOM('T         ')
      ELSE OU := OU(TAIL(SPTR))
      END
    END;
  1:
  IF TRACE_ON THEN TRACEXIT('OR        ')
  END{ OF OU };

  FUNCTION ATOM(SPTR : SYMBEXPPTR): SYMBEXPPTR;
  LABEL 1;
  VAR	TEMP, NXT: SYMBEXPPTR;
  BEGIN
  IF TRACE_ON THEN TRACENTER('ATOM      ');
  IF (ERR_COND) OR (END_FREELIST) THEN GOTO 1 ELSE
    BEGIN
    POP(TEMP);
    IF END_FREELIST THEN GOTO 1;
    NXT := TEMP^.NEXT;
    IF ( SPTR^.ANATOM ) THEN
      TEMP^ := TNODE
    ELSE
      TEMP^ := NILNODE;
    TEMP^.NEXT := NXT; ATOM := TEMP;
    END;
  1:
  IF TRACE_ON THEN TRACEXIT('ATOM      ')
  END{ OF ATOM };

  FUNCTION LAST(SPTR: SYMBEXPPTR): SYMBEXPPTR;
  LABEL 1;
  VAR 	TEMP: SYMBEXPPTR;
  BEGIN
  IF TRACE_ON THEN TRACENTER('LAST      ');
  IF (ERR_COND) OR (END_FREELIST) THEN GOTO 1 ELSE
    BEGIN
    IF (SPTR^.ANATOM) THEN LAST := SPTR ELSE
      BEGIN
      TEMP := TAIL(SPTR);
      IF (TEMP^.ANATOM) AND (TEMP^.NAME = 'NIL       ') THEN
        LAST := HEAD(SPTR) ELSE LAST := LAST(TEMP)
      END
    END;
  1:
  IF TRACE_ON THEN TRACEXIT('LAST      ')
  END{ OF LAST };

  FUNCTION REVERSE(SPTR: SYMBEXPPTR): SYMBEXPPTR;
  LABEL 1;
  VAR	TEMP: SYMBEXPPTR;
  BEGIN
  IF TRACE_ON THEN TRACENTER('REVERSE   ');
  IF (ERR_COND) OR (END_FREELIST) THEN GOTO 1 ELSE
    BEGIN
    TEMP := NULL(SPTR);
    IF (TEMP^.NAME = 'T         ') THEN REVERSE := SPTR ELSE
    REVERSE := APPEND(REVERSE(TAIL(SPTR)), 
	       CONS(HEAD(SPTR), MKATOM('NIL       ')))
    END;
  1:
  IF TRACE_ON THEN TRACEXIT('REVERSE   ')
  END{ OF REVERSE };

  FUNCTION LENGTH(SPTR: SYMBEXPPTR): SYMBEXPPTR;
  LABEL 1;
  VAR	TEMP: SYMBEXPPTR;
	IDENTIFIER: ALFA;
	J: INTEGER;
  BEGIN
  IF TRACE_ON THEN TRACENTER('LENGTH    ');
  IF (ERR_COND) OR (END_FREELIST) THEN GOTO 1 ELSE
    BEGIN
    J := 0;
    TEMP := SPTR;
    IF (TEMP^.ANATOM) THEN BEGIN
      IF (TEMP^.NAME = 'NIL       ') THEN J := 0 ELSE BEGIN
     	ERROR(12); GOTO 1 END
      END
    ELSE REPEAT
      J := J + 1;
      TEMP := TAIL(TEMP)
      UNTIL (TEMP^.ANATOM) AND (TEMP^.NAME = 'NIL       ');
    IDENTIFIER := '          ';
    IDENTIFIER[1] := CHR( (J DIV 100) + 48); {LIMIT FOR J IS 999}
    IDENTIFIER[2] := CHR((J - ((J DIV 100)*100)) DIV 10 + 48);
    IDENTIFIER[3] :=
      CHR( J - ((J DIV 100)*100) - ((J DIV 10)*10) +  48);
    LENGTH := MKATOM(IDENTIFIER)
    END;
  1:
  IF TRACE_ON THEN TRACEXIT('LENGTH    ')
  END{ OF LENGTH };

  FUNCTION LOOKUP(KEY, ALIST: SYMBEXPPTR): SYMBEXPPTR;
  LABEL 1;
  VAR
    TEMP: SYMBEXPPTR;
  BEGIN
  IF TRACE_ON THEN TRACENTER('LOOKUP    ');
  IF (ERR_COND) OR (END_FREELIST) THEN GOTO 1 ELSE
    BEGIN
    TEMP := EQQ( HEAD( HEAD(ALIST)), KEY);
    IF ( TEMP^.NAME='T         ' ) THEN
      LOOKUP := TAIL(HEAD(ALIST))
    ELSE
      LOOKUP := LOOKUP(KEY, TAIL(ALIST))
    END;
  1:
  IF TRACE_ON THEN TRACEXIT('LOOKUP    ')
  END{ OF LOOKUP };

  FUNCTION BINDARGS(NAMES, VALUES, ENV: SYMBEXPPTR): SYMBEXPPTR;
  LABEL 1;
  VAR
    TEMP, TEMP2: SYMBEXPPTR;
  BEGIN
  IF TRACE_ON THEN TRACENTER('BINDARGS  ');
  IF (ERR_COND) OR (END_FREELIST) THEN GOTO 1 ELSE
    BEGIN
    IF ( NAMES^.ANATOM ) AND (NAMES^.NAME='NIL       ') THEN
      BINDARGS := ENV
    ELSE BEGIN
        TEMP := CONS( HEAD(NAMES), EVAL(HEAD(VALUES), ENV) );
	TEMP2 := BINDARGS(TAIL(NAMES), TAIL(VALUES), ENV);
	BINDARGS := CONS(TEMP, TEMP2)
    END
    END;
  1:
  IF TRACE_ON THEN TRACEXIT('BINDARGS  ')
  END{ OF BINDARGS };

  FUNCTION BINDARG1(NAMES, VALUES, ENV: SYMBEXPPTR): SYMBEXPPTR;
  LABEL 1;
  VAR
    TEMP, TEMP2: SYMBEXPPTR;
  BEGIN
  IF TRACE_ON THEN TRACENTER('BINDARG1  ');
  IF (ERR_COND) OR (END_FREELIST) THEN GOTO 1 ELSE
    BEGIN
    IF ( NAMES^.ANATOM ) AND ( NAMES^.NAME='NIL       ') THEN
      BINDARG1 := ENV
    ELSE BEGIN
	TEMP := CONS( HEAD(NAMES), HEAD(VALUES) );
	TEMP2 := BINDARG1( TAIL(NAMES), TAIL(VALUES), ENV);
        BINDARG1 := CONS(TEMP, TEMP2)
    END
    END;
  1:
  IF TRACE_ON THEN TRACEXIT('BINDARG1  ')
  END{ OF BINDARG1 };

  FUNCTION EVCON(CONDPAIRS: SYMBEXPPTR): SYMBEXPPTR;
  LABEL 1;
  VAR
    TEMP: SYMBEXPPTR;
  BEGIN
  IF TRACE_ON THEN TRACENTER('EVCON     ');
  IF (ERR_COND) OR (END_FREELIST) THEN GOTO 1 ELSE
    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;
  1:
  IF TRACE_ON THEN TRACEXIT('EVCON     ')
  END{ OF EVCON };

  FUNCTION MKFUNARG(SPTR : SYMBEXPPTR) : SYMBEXPPTR;
  VAR
    TEMP : SYMBEXPPTR;
  BEGIN
  IF TRACE_ON THEN TRACENTER('MKFUNARG  ');
  IF (SPTR^.ANATOM) AND (NOT SPTR^.ISARESERVEDWORD) THEN
    TEMP := CONS(MKATOM('FUNARG    '), CONS(EVAL(SPTR, ALIST), ALIST))
  ELSE
    TEMP := CONS(MKATOM('FUNARG    '), CONS(SPTR, ALIST));
  MKFUNARG := TEMP;
  IF TRACE_ON THEN TRACEXIT('MKFUNARG  ')
  END{ OF MKFUNARG };

  FUNCTION ASSOC(KEY, S_TABLE : SYMBEXPPTR) : SYMBEXPPTR;
  LABEL 1;
  VAR
    TEMP1, TEMP2 : SYMBEXPPTR;
  BEGIN
  IF TRACE_ON THEN TRACENTER('ASSOC     ');
  IF (ERR_COND) OR (END_FREELIST) THEN GOTO 1 ELSE
    BEGIN
    TEMP1 := EQQ(HEAD(HEAD(S_TABLE)), KEY);
    IF (TEMP1^.NAME = 'T         ') THEN
      ASSOC := HEAD(S_TABLE)
    ELSE
      BEGIN
      TEMP2 := HEAD(HEAD(TAIL(S_TABLE)));
      IF NOT (TEMP2^.ANATOM) OR (TEMP2^.NAME <> 'NIL       ') THEN
      ASSOC := ASSOC(KEY, TAIL(S_TABLE))
      ELSE
      ASSOC := HEAD(TAIL(S_TABLE))
      END
    END;
  1:
  IF TRACE_ON THEN TRACEXIT('ASSOC     ')
  END{OF ASSOC};

  PROCEDURE SETT(SPTR1, SPTR2 : SYMBEXPPTR; VAR ALIST : SYMBEXPPTR);
  LABEL 1;
  VAR
    TEMP1, TEMP2, TEMP3, NXT : SYMBEXPPTR;
  BEGIN
  IF TRACE_ON THEN TRACENTER('SETT      ');
  IF (ERR_COND) OR (END_FREELIST) THEN GOTO 1 ELSE
    BEGIN
    IF NOT SPTR1^.ANATOM THEN BEGIN
      ERROR(11);
      GOTO 1
      END;
    TEMP1 := ASSOC(SPTR1, ALIST);
    TEMP2 := HEAD(TEMP1);
    IF (TEMP2^.ANATOM) AND (TEMP2^.NAME = 'NIL       ') THEN
    {VARIABLE NOT LOCATED IN THE ALIST}
      BEGIN
      POP(TEMP3);
      IF END_FREELIST THEN GOTO 1;
      TEMP3^.ANATOM := FALSE; TEMP3^.STATUS := UNMARKED;
      TEMP3^.TAIL := ALIST; ALIST := TEMP3;
      POP(ALIST^.HEAD);
      IF END_FREELIST THEN GOTO 1;
      WITH ALIST^.HEAD^ DO BEGIN
        ANATOM := FALSE; STATUS := UNMARKED;
        HEAD := COPY(SPTR1);
        TAIL := COPY(SPTR2)
	END
      END
    ELSE  {VARIABLE LOCATED IN THE ALIST}
      TEMP1^.TAIL := COPY(SPTR2)
    END;
  1:
  IF TRACE_ON THEN TRACEXIT('SETT      ')
  END{OF SETT};

  PROCEDURE REMOB(KEY: SYMBEXPPTR; VAR S_TABLE: SYMBEXPPTR);
  LABEL 1;
  VAR	TEMP1, TEMP2, TEMP3: SYMBEXPPTR;
  BEGIN
  IF TRACE_ON THEN TRACENTER('REMOB     ');
  IF (ERR_COND) OR (END_FREELIST) THEN GOTO  1 ELSE
    BEGIN
    TEMP1 := EQQ(HEAD(HEAD(S_TABLE)), KEY);
    IF (TEMP1^.NAME = 'T         ') THEN S_TABLE := TAIL(S_TABLE)
    ELSE BEGIN
      TEMP2 := HEAD(TAIL(S_TABLE));
      IF NOT (TEMP2^.ANATOM) OR (TEMP2^.NAME <> 'NIL       ') THEN
      BEGIN TEMP3 := TAIL(S_TABLE); REMOB(KEY, TEMP3) END;
      S_TABLE := CONS(HEAD(S_TABLE), TEMP3)
      END
    END;
  1:
  IF TRACE_ON THEN TRACEXIT('REMOB     ')
  END{ OF REMOB };

  FUNCTION PROG(SPTR: SYMBEXPPTR): SYMBEXPPTR;
  LABEL 1;
  VAR	TEMP1, TEMP2, TEMP3, AUX: SYMBEXPPTR;
  BEGIN
  IF (ERR_COND) OR (END_FREELIST) THEN GOTO 1 ELSE
    BEGIN
    IF TRACE_ON THEN TRACENTER('PROG      ');
    IF SPTR^.ANATOM THEN BEGIN ERROR(13); GOTO 1 END ELSE
      BEGIN
      {ZEROING THE LIST OF VARIABLES}
      AUX:= HEAD(SPTR);
      WHILE NOT (AUX^.ANATOM) OR (AUX^.NAME <> 'NIL       ') DO BEGIN
	SETT(HEAD(AUX), MKATOM('NIL       '), ALIST);
	AUX := TAIL(AUX)
	END {WHILE};
      {CARRYING OUT THE PROGRAM}
      TEMP3 := TAIL(SPTR);
      REPEAT
	TEMP1 := HEAD(TEMP3);
	{SKIP ATOMS}
	IF TEMP1^.ANATOM THEN TEMP1 := HEAD(TAIL(TEMP3));
	TEMP2 := EVAL(TEMP1, ALIST);
	IF NOT TEMP2^.ANATOM THEN BEGIN

        TEMP := HEAD(TEMP2);
        IF TEMP^.ANATOM THEN BEGIN
	  IF TEMP^.NAME = 'RETURN    ' THEN BEGIN
	    PROG := MKATOM('NIL       '); GOTO 1 END ELSE BEGIN
	    IF TEMP^.NAME = 'GO        ' THEN BEGIN
	      {GO TO THE TOP OF THE LIST}
              AUX := TAIL(SPTR);
              {LOOK FOR THE TAG}
	      TEMP1 := HEAD(AUX);
	      TEMP := HEAD(TAIL(TEMP2));
	      WHILE NOT (TEMP1^.ANATOM) OR
		(TEMP1^.NAME <> TEMP^.NAME) DO BEGIN
		  AUX := TAIL(AUX);
		  IF (AUX^.ANATOM) AND (AUX^.NAME = 'NIL       ') THEN
		    BEGIN ERROR(14); GOTO 1 END;
		  TEMP1 := HEAD(AUX)
		END {WHILE};
	      TEMP3 := AUX
	    END
	  END
	END

        END;
        TEMP3 := TAIL(TEMP3)
        UNTIL (TEMP3^.ANATOM) AND (TEMP3^.NAME = 'NIL       ');
      PROG := TEMP2
      END
    END;
  1:
  IF TRACE_ON THEN TRACEXIT('PROG      ')
  END{ OF PROG };

  FUNCTION PROG2(SPTR1, SPTR2: SYMBEXPPTR): SYMBEXPPTR;
  LABEL 1;
  VAR	TEMP: SYMBEXPPTR;
  BEGIN
  IF TRACE_ON THEN TRACENTER('PROG2     ');
  IF (ERR_COND) OR (END_FREELIST) THEN GOTO 1 ELSE
    BEGIN
    TEMP := EVAL(SPTR1, ALIST);
    TEMP := EVAL(SPTR2, ALIST);
    PROG2 := TEMP
    END;
  1:
  IF TRACE_ON THEN TRACEXIT('PROG2     ')
  END{ OF PROG2 };

  FUNCTION PROGN(SPTR: SYMBEXPPTR): SYMBEXPPTR;
  LABEL 1;
  VAR	TEMP1, TEMP2, TEMP3: SYMBEXPPTR;
  BEGIN
  IF TRACE_ON THEN TRACENTER('PROGN     ');
  IF (ERR_COND) OR (END_FREELIST) THEN GOTO 1 ELSE
    BEGIN
    IF (SPTR^.ANATOM) THEN PROGN := EVAL(SPTR, ALIST) ELSE
      BEGIN
      TEMP3 := SPTR;
	REPEAT
	TEMP1 := HEAD(TEMP3);
	TEMP2 := EVAL(TEMP1, ALIST);
	TEMP3 := TAIL(TEMP3)
	UNTIL (TEMP3^.ANATOM) AND (TEMP3^.NAME = 'NIL       ');
      PROGN := TEMP2
      END
    END;
  1:
  IF TRACE_ON THEN TRACEXIT('PROGN     ')
  END{ OF PROGN };

  BEGIN	{   * E V A L *   }
  IF TRACE_ON THEN TRACENTER('EVAL      ');
  IF (ERR_COND) OR (END_FREELIST) THEN GOTO 1 ELSE
    BEGIN
    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, FUNARGSYM, FLAMBDASYM:
			  BEGIN ERROR(3); GOTO 1 END;

	       TRACESYM : BEGIN TRACE_ON := TRUE;
				EVAL := MKATOM('NIL       ')
				END;

	       UNTRACESYM : BEGIN TRACE_ON := FALSE;
				  EVAL := MKATOM('NIL       ')
				  END;

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

               EQUALSYM : EVAL := EQUAL(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));

	       LISTSYM  : EVAL := LIST(TAIL(E));

	       ANDSYM   : EVAL := ET(TAIL(E));

  	       ORSYM    : EVAL := OU(TAIL(E));

	       NULLSYM, NOTSYM :
			  EVAL := NULL(EVAL(HEAD(TAIL(E)), ALIST));

	       EVALSYM  : EVAL := EVAL(EVAL(HEAD(TAIL(E)), ALIST), ALIST);

	       APPENDSYM : EVAL := APPEND(EVAL(HEAD(TAIL(E)),ALIST),
					  EVAL(HEAD(TAIL(TAIL(E))), ALIST));

	       RELACEHSYM : EVAL := REPLACEH(EVAL(HEAD(TAIL(E)),ALIST),
					   EVAL(HEAD(TAIL(TAIL(E))), ALIST));

	       RELACETSYM : EVAL := REPLACET(EVAL(HEAD(TAIL(E)),ALIST),
					   EVAL(HEAD(TAIL(TAIL(E))), ALIST));

	       LASTSYM  : EVAL := LAST(EVAL(HEAD(TAIL(E)), ALIST));

	       LENGTHSYM : EVAL := LENGTH(EVAL(HEAD(TAIL(E)), ALIST));

	       REVERSESYM : EVAL := REVERSE(EVAL(HEAD(TAIL(E)), ALIST));

	       FUNCTSYM : EVAL := MKFUNARG(HEAD(TAIL(E)));

	       SETSYM :
                  BEGIN
		    TEMP := EVAL(HEAD(TAIL(TAIL(E))), ALIST);
		    SETT(EVAL(HEAD(TAIL(E)), ALIST), TEMP, ALIST);
		    EVAL := TEMP
                  END;
	       SETQSYM :
		  BEGIN
		    TEMP := EVAL(HEAD(TAIL(TAIL(E))), ALIST);
		    SETT(HEAD(TAIL(E)), TEMP, ALIST);
		    EVAL := TEMP
		  END;
	       DEFEXPSYM :
                  BEGIN
                    TEMP := HEAD(TAIL(E));
		    SETT(TEMP,
		    CONS(MKATOM('LAMBDA    '), TAIL(TAIL(E))),
		    ALIST);
		    EVAL := TEMP
		  END;
	       DEFFEXPSYM :
		  BEGIN
		    TEMP := HEAD(TAIL(E));
		    SETT(TEMP,
		    CONS(MKATOM('FLAMBDA   '), TAIL(TAIL(E))),
		    ALIST);
		    EVAL := TEMP
		  END;
	       REMOBSYM :
		  BEGIN
		    REMOB(HEAD(TAIL(E)), ALIST);
		    EVAL := MKATOM('NIL       ')
                  END;
	       GOSYM    : EVAL := CONS(MKATOM('GO        '), TAIL(E));
	       RETURNSYM: EVAL := CONS(MKATOM('RETURN    '),
				       MKATOM('NIL       '));
	       PROGSYM  : EVAL := PROG(TAIL(E));
	       PROG2SYM : EVAL := PROG2(HEAD(TAIL(E)),
					HEAD(TAIL(TAIL(E))));

	       PROGNSYM : EVAL := PROGN(TAIL(E));

	     END{CASE}
         ELSE
	   BEGIN
	     CAAROFE := HEAD(CAROFE);
	     IF ( CAAROFE^.ANATOM ) AND ( CAAROFE^.ISARESERVEDWORD ) THEN
	       IF NOT (CAAROFE^.RESSYM IN [LABELSYM, LAMBDASYM, FUNARGSYM,
		 FLAMBDASYM]) THEN BEGIN ERROR(10); GOTO 1 END
	       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),
				ALIST);
			EVAL := EVAL( HEAD( TAIL( TAIL(CAROFE))), TEMP)
		      END;
		   FUNARGSYM:
		      BEGIN
			TEMP := TAIL(TAIL(CAROFE));
			EVAL := EVAL(CONS(HEAD(TAIL(CAROFE)), TAIL(E)),
				TEMP)
		      END;
                   FLAMBDASYM:
		      BEGIN
			TEMP := BINDARG1(HEAD(TAIL(CAROFE)), TAIL(E),
				ALIST);
		        EVAL := EVAL( HEAD( TAIL( TAIL(CAROFE))), TEMP)
		      END;
		 END{ CASE }
	     ELSE
	       EVAL := EVAL(CONS(EVAL(CAROFE, ALIST), TAIL(E)), ALIST)
          END   
      END
  END;
1:
IF TRACE_ON THEN TRACEXIT('EVAL      ')
END{ OF EVAL };

PROCEDURE INITIALIZE;
VAR	I: INTEGER;
	TEMP, NXT: SYMBEXPPTR;
BEGIN
  END_FREELIST := FALSE;
  ERR_COND := FALSE;
  TRACE_ON := FALSE;
  NESTCOUNT := 0;
  ALREADYPEEKED := FALSE;
  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[ ANDSYM      ] := 'AND       ';
  RESWORDS[ APPENDSYM   ] := 'APPEND    ';
  RESWORDS[ ATOMSYM     ] := 'ATOM      ';
  RESWORDS[ HEADSYM     ] := 'CAR       ';
  RESWORDS[ TAILSYM     ] := 'CDR       ';
  RESWORDS[ CONDSYM     ] := 'COND      ';
  RESWORDS[ CONSSYM     ] := 'CONS      ';
  RESWORDS[ COPYSYM     ] := 'COPY      ';
  RESWORDS[ DEFEXPSYM   ] := 'DEFEXP    ';
  RESWORDS[ DEFFEXPSYM  ] := 'DEFFEXP   ';
  RESWORDS[ DEFMACSYM   ] := 'DEFMACRO  ';
  RESWORDS[ EQSYM       ] := 'EQ        ';
  RESWORDS[ EQUALSYM    ] := 'EQUAL     ';
  RESWORDS[ EVALSYM     ] := 'EVAL      ';
  RESWORDS[ FLAMBDASYM  ] := 'FLAMBDA   ';
  RESWORDS[ FUNARGSYM   ] := 'FUNARG    ';
  RESWORDS[ FUNCTSYM    ] := 'FUNCTION  ';
  RESWORDS[ GOSYM       ] := 'GO        ';
  RESWORDS[ LABELSYM    ] := 'LABEL     ';
  RESWORDS[ LAMBDASYM   ] := 'LAMBDA    ';
  RESWORDS[ LASTSYM     ] := 'LAST      ';
  RESWORDS[ LENGTHSYM   ] := 'LENGTH    ';
  RESWORDS[ LISTSYM     ] := 'LIST      ';
  RESWORDS[ NOTSYM      ] := 'NOT       ';
  RESWORDS[ NULLSYM     ] := 'NULL      ';
  RESWORDS[ ORSYM       ] := 'OR        ';
  RESWORDS[ PROGSYM     ] := 'PROG      ';
  RESWORDS[ PROG2SYM    ] := 'PROG2     ';
  RESWORDS[ PROGNSYM    ] := 'PROGN     ';
  RESWORDS[ QUOTESYM    ] := 'QUOTE     ';
  RESWORDS[ RELACEHSYM  ] := 'REPLACEH  ';
  RESWORDS[ RELACETSYM  ] := 'REPLACET  ';
  RESWORDS[ REMOBSYM    ] := 'REMOB     ';
  RESWORDS[ RETURNSYM   ] := 'RETURN    ';
  RESWORDS[ REVERSESYM  ] := 'REVERSE   ';
  RESWORDS[ SETSYM      ] := 'SET       ';
  RESWORDS[ SETQSYM     ] := 'SETQ      ';
  RESWORDS[ TRACESYM    ] := 'TRACE     ';
  RESWORDS[ UNTRACESYM  ] := 'UNTRACE   ';
{
	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;
  RESET('INITLISP', INFILE);
  READ(INFILE, CH);
  NEXTSYM1;
  READEXP1(PTR);
  WHILE NOT ( PTR^.ANATOM ) OR ( PTR^.NAME<>'FIN       ' ) DO BEGIN
    TEMP := EVAL(PTR, ALIST);
    NEXTSYM1;
    READEXP1(PTR);
    {CALL THE} GARBAGEMAN
    END;
  WRITELN;
  WRITELN('                                  R E A D Y');
  WRITELN;
  READ(CH);
END{ OF INITIALIZE };



BEGIN{+		LISP MAIN PROGRAM		+}
  INITIALIZE;
  NEXTSYM;
  READEXPR(PTR);
  WHILE NOT ( PTR^.ANATOM ) OR ( PTR^.NAME<>'FIN       ' ) DO BEGIN
    IF NOT TRACE_ON THEN WRITE('  ');
    PRINTEXPR( EVAL(PTR, ALIST) );
{   NESTCOUNT := 0;  }
    IF END_FREELIST THEN GOTO 2;
1:  ERR_COND := FALSE;
    IF ( EOF(INPUT) ) THEN BEGIN
	WRITELN('END OF FILE ENCOUNTERED BEFORE A "FIN" CARD.');
	GOTO 2
	END;
    PTR := NIL;
    WRITELN; WRITELN;
    { CALL THE } GARBAGEMAN;
    NEXTSYM;
    READEXPR(PTR);
    IF ERR_COND THEN GOTO 1;
    IF END_FREELIST THEN GOTO 2;
  END;
2:WRITELN; WRITELN;
  WRITELN(' TOTAL NUMBER OF GARBAGE COLLECTIONS = ', NUMBEROFGCS:1,'.');
  WRITELN;
  WRITELN(' FREE NODES LEFT UPON EXIT = ', FREENODES:1, '.');
  WRITELN
END { OF LISP }.