PROGRAM LISP;
LABEL 101, 102;
CONST MAXNODE = 1000;
TYPE
  INPUTSYMBOL = (ATOM, PERIOD, LPAREN, RPAREN);
  RWORDS = (RHSYM, RTSYM, HEADSYM, TAILSYM, EQSYM, QUOTESYM,
     ATOMSYM, CONDSYM, LABELSYM, LAMBDASYM, COPYSYM, APPENDSYM, CONCSYM,
     CONSSYM);
STATUSTYPE = (UNMARKED, LEFT, RIGHT, MARKED);
SYMBEXPPTR = ^SYMBOLICEXPRESSION;
ALFA = PACKED ARRAY [1 .. 10] OF CHAR;
SYMBOLICEXPRESSION = RECORD
      STATUS : STATUSTYPE;
      NEXT   : SYMBEXPPTR;
 CASE ANATOM : BOOLEAN OF
      TRUE   : (NAME : ALFA;
               CASE ISARESERVEDWORD : BOOLEAN OF
                    TRUE : (RESSYM : RWORDS));
      FALSE  : (HEAD, TAIL : SYMBEXPPTR)
 END;
VAR
  LOOKAHEADSYM, SYM : INPUTSYMBOL ;
  ID : ALFA;
  ALREADYPEEKED : BOOLEAN ;
  CH : CHAR ;
  PTR : SYMBEXPPTR;
  FREELIST, NODELIST, ALIST : SYMBEXPPTR;
  NILNODE, TNODE : SYMBOLICEXPRESSION;
  RESWORD : RWORDS;
  RESERVED : BOOLEAN ;
  RESWORDS : ARRAY [RWORDS] OF ALFA;
  FREENODES : INTEGER;
  NUMBEROFGCS : INTEGER;
PROCEDURE GARBAGEMAN;
  PROCEDURE MARK(VAR 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
    END;
  PROCEDURE COLLECTFREENODES;
    VAR TEMP : SYMBEXPPTR;
    BEGIN
      WRITE(' 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 FREENODES AFTER COLLECTION = ',FREENODES:1,'.')
  END;
BEGIN
  NUMBEROFGCS := NUMBEROFGCS + 1; WRITELN;
  WRITELN('GARBAGE COLLECTION.'); WRITELN; MARK(ALIST);
  IF PTR <> NIL THEN MARK(PTR); COLLECTFREENODES
END;
PROCEDURE POP(VAR SPTR : SYMBEXPPTR);
  BEGIN
    IF FREELIST = NIL THEN
      BEGIN
        WRITELN('NOT ENOUGH SPACE TO EVALUATE THE EXPRESSION');
        GOTO 102
      END;
    FREENODES := FREENODES - 1; SPTR := FREELIST;
    FREELIST := FREELIST^.HEAD
  END;
PROCEDURE ERROR(NUMBERS : INTEGER);
  BEGIN
    WRITELN; WRITE('eRROR ',NUMBERS:1,',');
    CASE NUMBERS OF
      1 : WRITELN(' ATOM OR ( EXPECTED IN THE S-EXPR.');
      2 : WRITELN(' ATOM, (, OR ) EXPECTED IN THE S-EXPR.');
      3 : WRITELN(' LABEL AND LAMBDA ARE NOT NAMES OF FUNCTIONS.');
      4 : WRITELN(') 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(' , OR ) EXPECTED IN CONCATENATE.');
      11 : WRITELN('END OF FILE ENCOUNTERED BEFORE A "FIN" CARD.');
      12 : WRITELN('LAMBDA OR LABEL EXPECTED.')
    END;
    IF NUMBERS IN [11] THEN GOTO 102 ELSE GOTO 101
  END;
PROCEDURE BACKINPUT;
  BEGIN
    ALREADYPEEKED := TRUE; LOOKAHEAD := SYM; SYM := LPAREN
  END;
PROCEDURE NEXTSYM;
  VAR I : INTEGER;
  BEGIN
    IF ALREADYPEEKED
    THEN BEGIN SYM := LOOKAHEADSYM; ALREADYPEEKED := FALSE END
    ELSE
      BEGIN
        WHILE CH = ' ' DO
          BEGIN IF EOLN THEN WRITELN; READ(CH);
          END;
        IF CH IN ['(','.',')']
        THEN
          BEGIN
            CASE CH OF
              '(': SYM := LPAREN;
              '.': SYM := PERIOD;
              ')': SYM := RPAREN;
            END;
            IF EOLN THEN WRITELN; READ(CH);
          END
        ELSE
          BEGIN
            SYM := ATOM; ID := '          '; I := 0;
            REPEAT
              I := I + 1; IF I<11 THEN ID[I] := CH;
              IF EOLN THEN WRITELN; READ(CH)
            UNTIL CH IN [' ','(','.',')'];
            RESWORD := RHSYM;
            WHILE (ID <> RESWORDS[RESWORD]) AND (RESWORD <> CONSSYM) DO
              RESWORD := SUCC(RESWORD);
            RESERVED := ID = RESWORDS[RESWORD]
          END
      END
  END;
PROCEDURE READEXPR(VAR SPTR : SYMBEXPPTR);
  VAR NXT : SYMBEXPPTR;
  BEGIN
    POP(SPTR); NXT := SPTR^.NEXT;
    CASE SYM OF
      RPAREN, PERIOD : ERROR(1);
      ATOM:
        WITH SPTR^ DO
          BEGIN
            ANATOM := TRUE; NAME := ID; ISARESERVEDWORD := RESERVED;
            IF RESERVED THEN RESSYM := RESWORD
          END;
      LPAREN:
        WITH SPTR^ DO
          BEGIN
            NEXTSYM;
            IF SYM = PERIOD THEN ERROR(2)
            ELSE
              IF SYM = RPAREN THEN SPTR^ := NILNODE
              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
                      BACKINPUT; READEXPR(TAIL)
                    END
                END
          END
    END;
    SPTR^.NEXT := NXT
  END;
PROCEDURE PRINTNAME(VAR NAME : ALFA);
  VAR I : INTEGER;
  BEGIN
    I := 1;
    REPEAT
      WRITE(NAME[I]);
      I := I + 1;
    UNTIL (NAME[I] = ' ') OR (I = 11);
    WRITE(' ')
  END;
PROCEDURE PRINTEXPR(SPTR : SYMBEXPPTR);
  LABEL 103;
  BEGIN
    IF SPTR^.ANATOM THEN PRINTNAME(SPTR^.NAME)
    ELSE
      BEGIN
        WRITE('(');
     103: 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 103 END
          END
      END
END;
FUNCTION EVAL(E, ALIST : SYMBEXPPTR) : SYMBEXPPTR;
  VAR TEMP, CAROFE, CAAROFE : SYMBEXPPTR;
  FUNCTION REPLACEH(SPTR1, SPTR2 : SYMBEXPPTR) : SYMBEXPPTR;
    BEGIN
      IF SPTR1^.ANATOM THEN ERROR(5) ELSE SPTR1^.HEAD := SPTR2;
      REPLACEH := SPTR1
    END;
  FUNCTION REPLACET(SPTR1, SPTR2 : SYMBEXPPTR) : SYMBEXPPTR;
    BEGIN
      IF SPTR1^.ANATOM THEN ERROR(6) ELSE SPTR1^.TAIL := SPTR2;
      REPLACET := SPTR1
    END;
  FUNCTION HEAD(SPTR : SYMBEXPPTR) : SYMBEXPPTR;
    BEGIN
      IF SPTR^.ANATOM THEN ERROR(7) ELSE HEAD := SPTR^.HEAD
    END;
  FUNCTION TAIL(SPTR : SYMBEXPPTR) : SYMBEXPPTR;
    BEGIN
      IF SPTR^.ANATOM THEN ERROR(8) ELSE TAIL := SPTR^.TAIL
    END;
  FUNCTION CONS(SPTR1, SPTR2 : SYMBEXPPTR) : SYMBEXPPTR;
    VAR TEMP : SYMBEXPPTR;
    BEGIN
      POP(TEMP); TEMP^.ANATOM := FALSE; TEMP^.HEAD := SPTR1;
      TEMP^.TAIL := SPTR2; CONS := TEMP;
    END;
  FUNCTION COPY(SPTR : SYMBEXPPTR) : SYMBEXPPTR;
    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;
  FUNCTION APPEND(SPTR1, SPTR2 : SYMBEXPPTR) : SYMBEXPPTR;
    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;
  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;
  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;
  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;
  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;
  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;
  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;
  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 : 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))
            END
        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
              ELSE
                EVAL := EVAL(CONS(EVAL(CAROFE,ALIST),TAIL(E)),ALIST)
            END
          END
  END;
PROCEDURE INITIALIZE;
  VAR I : INTEGER;
  TEMP, NXT : SYMBEXPPTR;
  BEGIN
    ALREADYPEEKED := FALSE; READ(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;
    FREELIST := NIL;
    FOR I := 1 TO MAXNODE DO
      BEGIN
        NEW(NODELIST); NODELIST^.NEXT := FREELIST;
        NODELIST^.HEAD := FREELIST; NODELIST^.STATUS := UNMARKED;
        FREELIST := NODELIST
      END;
    RESWORDS[RHSYM]     := 'REPLACEH  ';
    RESWORDS[RTSYM]     := 'REPLACET  ';
    RESWORDS[HEADSYM]   := 'CAR       ';
    RESWORDS[TAILSYM]   := 'CDR       ';
    RESWORDS[COPYSYM]   := 'COPY      ';
    RESWORDS[APPENDSYM] := 'APPEND    ';
    RESWORDS[CONCSYM]   := 'CONC      ';
    RESWORDS[CONSSYM]   := 'CONS      ';
    RESWORDS[EQSYM]     := 'EQ        ';
    RESWORDS[QUOTESYM]  := 'QUOTESYM  ';
    RESWORDS[ATOMSYM]   := 'ATOM      ';
    RESWORDS[CONDSYM]   := 'COND      ';
    RESWORDS[LABELSYM]  := 'LABEL     ';
    RESWORDS[LAMBDASYM] := 'LAMBDA    ';
    POP(ALIST); ALIST^.ANATOM := FALSE; ALIST^.STATUS := UNMARKED;
    POP(ALIST^.TAIL); NXT := ALIST^.TAIL^.NEXT;
    POP(ALIST^.HEAD);
    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);
    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;
BEGIN
IOTRAP(FALSE);
  WRITELN(' * EVAL * '); INITIALIZE; NEXTSYM; READEXPR(PTR);
  READLN; WRITELN;
  WHILE NOT PTR^.ANATOM OR (PTR^.NAME <> 'FIN       ') DO
    BEGIN
      WRITELN; WRITELN(' * VALUE * ');
      PRINTEXPR(EVAL(PTR, ALIST));
 101: WRITELN; WRITELN; IF EOF THEN ERROR(11);
      PTR := NIL;
      GARBAGEMAN; WRITELN; WRITELN;
      WRITELN('EVAL'); NEXTSYM; READEXPR(PTR); READLN;
      WRITELN
    END;
102: WRITELN; WRITELN;
     WRITELN('TOTAL NUMBER OF GARBAGE COLLECTIONS = ',NUMBEROFGCS:1,
           '.');
     WRITELN;
     WRITELN('FREENODES LEFT UPON EXIT = ',FREENODES:1,'.');
     WRITELN
END.
