Oakland CPM Archive/oakcpm.iso/sigm/vol148/lisp.pas

Pascal/Delphi Source File | 1984-04-29 | 35.9 KB | 1,383 lines

{+        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 }.