{++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{+              PASCAL/Z COMPILER OPTIONS               +}
{++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{$C- <<< CONTROL-C KEYPRESS CHECKING OFF >>>             }
{$F- <<< FLOATING POINT ERROR CHECKING OFF >>>           }
{$M- <<< INTEGER MULT & DIVD ERROR CHECKING OFF          }
{++++++++++++++++++++++++++++++++++++++++++++++++++++++++}


(* LAST EDITED: 11/29/81 rep *)

PROGRAM LISP {INPUT,OUTPUT};
{
+  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.
}
       {++++++++++++++++++++++++++++++++++++++++++++++++}
       {+      RESERVED WORDS TABLE LISP               +}
       {++++++++++++++++++++++++++++++++++++++++++++++++}
{
       'APPEND    '    <
       'ATOM      '    <  A VARIABLE OR LITERAL USED IN A LIST.
       'REPLACEH  '    <
       'REPLACET  '    <
       'CAR       '    <  THE FIRST ELEMENT OF A LIST.
       'COND      '    <
       'COPY      '    <
       'CONC      '    <
       'CONS      '    <
       'EQ        '    <
       'QUOTE     '    <
       'LABEL     '    <
       'LAMBDA    '    <  FIRST ELEMENT OF A USER DEFINED FUNCTION.
       'CDR       '    <  ALL ELEMENTS OF A LIST EXCEPT THE FIRST ELEMENT.
       'FIN       '    <  FINISHED.

}

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 = 600;
{}INPUT = 0;    { Pascal/Z = console as input }
{}IDLENGTH = 10;

TYPE
{}ALFA = ARRAY [1..10] OF CHAR;
 INPUTSYMBOL = (ATOM, PERIOD, LPAREN, RPAREN);
 RESERVEWORDS = (RELACEHSYM, RELACETSYM, HEADSYM, TAILSYM, EQSYM, QUOTESYM,
                 ATOMSYM, CONDSYM, LABELSYM, LAMBDASYM, COPYSYM, APPENDSYM,
                 CONCSYM, CONSSYM);
 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;

{
       Symbolicexpression is the record structure used to implement
       a LISP list.  This record has a tag field 'ANATOM' which tells
       which kind of node a particular node represents (i.e. an atom
       or a pair of pointers 'HEAD' and 'TAIL'), 'ANATOM' is always
       checked before accessing either the name field or the head and
       tail fields of a node.  Two pages ahead there are three diagrams
       which should clarify the data structure.
}

{       THE GLOBAL VARIABLES    }

VAR
{}DUMMY         : CHAR;         { required in the Pascal/Z version }

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

       { THE GLOBAL LISTS OF LISP NODES }

 FREELIST,     { POINTER TO THE LINEAR LIST OF FREE NODES }
 NODELIST,     { POINTER USED TO MAKE A LINEAS 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 }
{

                                        \
                                         \
       THE ATOM 'A' IS                 ---\---
       REPRESENTED BY --->             I     I
                                       I  A  I
                                       I     I
                                       -------


                                  \
                                   \
                               -----\-----
       THE DOTTED PAIR         I    I    I
       '(A.B)' IS              I  / I \  I
       REPESENTED BY --->      I /  I  \ I
                               -/-------\-
                               /         \
                          ----/----   ----\----
                          I       I   I       I
                          I   A   I   I   B   I
                          I       I   I       I
                          ---------   ---------


                                  \
                                   \
                               -----\-----
       THE LIST '(AB)'         I    I    I
       IS REPRESENTED          I  / I \  I
       BY --->                 I /  I  \ I
                               -/-------\-
                               /         \
                          ----/----       \
                          I       I        \
                          I   A   I    -----\-----
                          I       I    I    I    I
                          ---------    I   /I\   I
                                       I  / I \  I
                                       --/-----\--
                                        /       \
                                   ----/---- ----\----
                                   I       I I       I
                                   I   B   I I  NIL  I
                                   I       I I       I
                                   --------- ---------
}
(*      *       THE GARBAGE COLLECTOR        *          *)
{
In  general  there are two approaches to maintaining lists of available space
in list processing systems... The  reference counter technique and the garbage
collector technique.

The reference counter technique requires that for  each  node  or  record  we
maintain  a  count  of  the number of nodes which reference or point to it and
update this count continuously. ie.  with  every  manipulation  In general, if
circular or ring structures are permitted to develope this technique will  not
be  able  to  reclaim  rings which are no longer in use and have been isolared
from the active structure.

The alternative method, garbage  collection,  does not function continuously,
but is activated only when further storage is required and none is  available.
The complete process consists of two stages.  A marking stage which identifies
nodes  still  reachable (in use) and a collection stage where all nodes in the
system are examined and those not in  use  are merged into a list of available
space.  This is the technique we have chosen to implement here for reasons  of
simplicity and to enhance the interactive nature of out system.

The  marking  stage  is  theoretically simple, especially in LISP programming
systems where all records are essentially the same size.  All that is required
is a traversal of the active  list  structure, each time marking nodes 1 level
deeper into the tree on each pass.  This is both crude and inefficient.

Another alternative procedure which could be used would use a recursive  walk
of  the  tree  structure to mark the nodes in use.  This requires the use of a
stack to store  back  pointers  to  branches  not  taken.    This algorithm is
efficient, but tend to  be  self  defeating  in  the  folowing  manner.    The
requisite  stack  could  become  quite large (requiring significant amounts of
storage).  However, the  reason  we  are  performing garbage collection in the
first place is due to  an  insufficiency  of  storage  space.    Therefore  an
usdesirable  situation  is likely to arise where the garbage collector's stack
cannot expand to perform the marking  pass.  Even though there are significant
amounts of free space waiting to be reclaimed.

A solution to this dilema came when it was realized that space in  the  nodes
themselves  (i.e.  the  left  and right pointers) could be used in lieu of the
explicit stack.  In this way  the  stack  information can be embedded into the
list itself as it is traversed.  This algorithm has been  discussed  in  Knuth
and  in  Berztiss:  Data  Structures,  Theory  and  Practice (2nd ed.), and is
implemented below.

Since Pascal does not allow structures to be addressed both with pointers and
as indexed arrays, an additional field has been added to sequentially link the
nodes.  This pointer field is  set  on initial creation, and remains invarient
throughout the run.  Using this field, we can simulate a linear  pass  through
the  nodes  for  the  collection  stage.    Of  course, a marker field is also
required.
}
(*      *       *       *       *       *       *       *)

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);
BEGIN
 IF ( FREELIST = NIL ) THEN BEGIN
   WRITELN(' NOT ENOUGH SPACE TO EVALUATE THE EXPRESSION.');
{}  GOTO 2;
 END;
 FREENODES := FREENODES - 1;
 SPTR := FREELIST;
 FREELIST := FREELIST^.HEAD;
END{ OF POP };


{       INPUT / OUTPUT UTILITY ROUTINES          }

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 AND LAMBDA ARE NOT NAMES OF FUNCTIONS.');
   4: WRITELN('RPAREN EXPECTED IN THE S-EXPR.');
   5: WRITELN('1ST ARGUMENT OF REPLACEH IS AN ATOM.');
   6: WRITELN('1ST ARGUMENT OF REPLACET IS AN ATOM.');
   7: WRITELN('ARGUMENT HEAD IS AN ATOM.');
   8: WRITELN('ARGUMENT TAIL IS AN ATOM.');
   9: WRITELN('1ST ARGUMENT OF APPEND IS NOT A LIST.');
  10: WRITELN('COMMA OR RPAREN EXPECTED IN CONCATENATE.');
  11: WRITELN('END OF FILE ENCOUNTERED BEFORE A "FIN" CARD.');
  12: WRITELN('LAMBDA OR LABEL EXPECTED.');
 END{CASE};
{}IF NUMBER IN [11] THEN
   GOTO 2
 ELSE
   GOTO 1
END { OF ERROR };

PROCEDURE BACKUPINPUT;
{       PUTS A LEFT PARENTHESIS INTO THE STREAM OF INPUT
       SYMBOLS.  THIS MAKES PROCEDURE READEXPR EASIER
       THAN IT OTHERWISE WOULD BE.
}
BEGIN
 ALREADYPEEKED := TRUE; LOOKAHEADSYM := SYM; SYM := LPAREN
END{ OF BACKUPINPUT };

PROCEDURE NEXTSYM;
{       READS THE NEXT SYMBOL FROM THE INPUT FILE.  A SYMBOL IS DEFINED
       BY THE GOLBAL TYPE "INPUTSYMBOL".  THE GLOBAL VARIABLE 'SYM'
       RETURNS THE TYPE OF THE NEXT SYMBOL READ.  THE GLOBAL VARIABLE
       'ID' RETURNS THE NAME OF AN ATOM IF THE SYMBOL IS AN ATOM.  IF
       THE SYMBOL IS A RESERVED WORD THE GLOBAL VARIABLE 'RESERVED' IS
       SET TO TRUE AND THE GLOBAL VARIABLE 'RESWORD' TELLS WHICH RESERVED
       WORD WAS READ.
}
VAR     I: INTEGER;
BEGIN
 IF ( ALREADYPEEKED ) THEN BEGIN
     SYM := LOOKAHEADSYM; ALREADYPEEKED := FALSE
 END
 ELSE
   BEGIN
     WHILE ( CH=' ' ) DO BEGIN
       IF ( EOLN(INPUT) ) THEN WRITELN;
       READ(CH);
     END{WHILE};
     IF ( CH IN ['(','.',')'] ) THEN BEGIN
       CASE CH OF
         '(': SYM := LPAREN;
         '.': SYM := PERIOD;
         ')': SYM := RPAREN
       END{CASE};
       IF ( EOLN(INPUT) ) THEN WRITELN;
       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 WRITELN;
         READ(CH);
       UNTIL ( CH IN [' ','(','.',')'] );
       RESWORD := RELACEHSYM;
       WHILE (ID <> RESWORDS[RESWORD]) AND (RESWORD <> CONSSYM) DO
         RESWORD := SUCC(RESWORD);
       RESERVED := ( ID=RESWORDS[RESWORD] )
     END
   END
END{ OF NEXTSYM };

PROCEDURE READEXPR(VAR SPTR: SYMBEXPPTR);
{
       THIS PROCEDURE RECURSIVELY READS IN THE NEXT SYMBOLIC EXPRESSION
       FROM THE INPUT FILE.  WHEN CALLED THE GLOBAL VARIABLE 'SYM' MUST
       BE THE FIRST SYMBOL IN THE SYMBOLIC EXPRESSION TO BE READ.  A
       POINTER TO THE SYMBOLIC EXPRESSION READ IS RETURNED VIA THE
       VARIABLE PARAMETER SPTR.
       EXPRESSIONS ARE READ AND STORED IN THE APPROPRIATE STRUCTURE
       USING THE FOLLOWING GRAMMAR FOR SYMBOLIC EXPRESSIONS:

       <s-expr> ::= <atom>
                or ( <s-expr> . <s-expr> )
                or ( <s-expr> <s-expr> ... <s-expr> )

       WHERE ... MEANS AN ARBITRARY NUMBER OF. (I.E. ZERO OR MORE.)
       TO PARSE USING THE THIRD RULE, THE IDENTITY
               (ABC ... Z) = (A . (BC ... Z))
       IS UTILIZED.  AN EXTRA LEFT PARENTHESIS IS INSERTED INTO THE
       INPUT STREAM AS IF IT OCCURED AFTER THE IMAGINARY DOT.  WHEN
       IT COMES TIME TO READ THE IMAGINARY MATCHING RIGHT PARENTHESIS
       IT IS JUST NOT READ (BECAUSE IT IS NOT THERE).
}
VAR     NXT: SYMBEXPPTR;
BEGIN
 POP(SPTR);
 NXT := SPTR^.NEXT;
 CASE SYM OF
   RPAREN, PERIOD: ERROR(1);
   ATOM:
       WITH SPTR^ DO BEGIN {  <ATOM>  }
         ANATOM := TRUE; NAME := ID; ISARESERVEDWORD := RESERVED;
         IF ( RESERVED ) THEN RESSYM := RESWORD
       END;
   LPAREN:
       WITH SPTR^ DO BEGIN
         NEXTSYM;
         IF ( SYM=PERIOD ) THEN ERROR(2)
         ELSE
           IF ( SYM=RPAREN ) THEN SPTR^ := NILNODE {   () = NIL   }
           ELSE BEGIN
               ANATOM := FALSE; READEXPR(HEAD); NEXTSYM;
               IF ( SYM=PERIOD ) THEN BEGIN {   ( <S-EXPR> . <S-EXPR> )   }
                  NEXTSYM;  READEXPR(TAIL); NEXTSYM;
                  IF ( SYM<>RPAREN ) THEN ERROR(4)
               END
               ELSE BEGIN {   ( <S-EXPR> <S-EXPR> ... <S-EXPR> )   }
                 BACKUPINPUT; READEXPR(TAIL)
               END
           END
       END{WITH}
 END{CASE};
 SPTR^.NEXT := NXT;
END{ OF READEXPR };

PROCEDURE PRINTNAME(NAME: ALFA);
{
       PRINTS THE NAME OF AN ATOM WITH ONE TRAILING BLANK.
}
VAR     I: INTEGER;
BEGIN
 I := 1;
 REPEAT
   WRITE(NAME[I]);
   I := I + 1
 UNTIL (NAME[I]=' ') OR ( I=11 );
 WRITE(' ');
END{ OF PRINTNAME };

PROCEDURE PRINTEXPR(SPTR: SYMBEXPPTR);
{
       THE ALGORITHM FOR THIS PROCEDURE WAS PROVIDED BY WEISSMAN'S LISP
       1.5 PRIMER, PG 125.  THIS PROCEDURE PRINTS THE SYMBOLIC
       EXPRESSION POINTED TO BY THE ARGUMENT 'SPTR' IN THE LIST LIST
       NOTATION. (THE SAME NOTATION IN WHICH EXPRESSIONS ARE READ.)
}
LABEL 1;
BEGIN
 IF ( SPTR^.ANATOM ) THEN
   PRINTNAME(SPTR^.NAME)
 ELSE BEGIN
   WRITE('(');
1: WITH SPTR^ DO BEGIN
       PRINTEXPR(HEAD);
       IF ( TAIL^.ANATOM ) AND (TAIL^.NAME='NIL       ') THEN
         WRITE(')')
       ELSE IF ( TAIL^.ANATOM ) THEN BEGIN
         WRITE('.'); PRINTEXPR(TAIL); WRITE(')')
       END
       ELSE BEGIN
         SPTR := TAIL;
         GOTO 1
       END
   END{WITH}
 END
END{ OF PRINTEXPR };

{       END OF I/O UTILITY ROUTINES     }


{       THE EXPRESSION EVALUATOR EVAL      }

FUNCTION EVAL( E, ALIST: SYMBEXPPTR ): SYMBEXPPTR;
{
Function eval evaluates the LISP expression 'e' using the association
list 'alist'. This function uses the following several local functions
to do so. The algorithm is a Pascal version of the classical LISP
problem of writing the LISP eval routine in pure LISP. The LISP version
of the code is as follows:

(lambda (e alist)
  cond
    ((atom a) (lookup e alist))
    ((atom (car e))
      (cond ((eq (car e) (quote quote))
          (cadr e))
        ((eq (car e) (quote atom))
          (atom (eval (card e) alist)
        ((eq (car e) (quote eq))
          (eq (eval (cadr e) alist)))
        ((eq (car e) (quote car))
          (car (eval (cadr e) alist)))
        ((eq (car e) (quote cdr))
          (cdr (eval (cadr e) alist)))
        ((eq (car e) (quote cons)
          (cons (eval (cadr e) alist)
            (eval (caddr e) alist)
        ((eq (car e) (quote cond)
          (evcon (cdr e))

(t (eval (cons (lookup (car e) alist)
          (cdr e)) alist )))
    ((eq (caar e) (quote label))
      (eval (cons (caddr e)
        (cdr e)
      (cons (cons (cadar e) (car e))
        alist) ))
  ((eq (caar e) (quote lambda))
    (eval (caddar e)
      (bindargs (cadar e) (cdr e) )))))


       The resulting Pascal code follows:
}
VAR     TEMP, CAROFE, CAAROFE: SYMBEXPPTR;
{
       The first ten of the following local functions implement
       ten of the primitives which operate on the LISP data
       structure. The last three ; 'lookup', 'bindargs', and 'evcon'
       are used by 'eval' to interpret a LISP expresson.
}
 FUNCTION REPLACEH(SPTR1, SPTR2: SYMBEXPPTR): SYMBEXPPTR;
 BEGIN
   IF ( SPTR1^.ANATOM ) THEN ERROR(5)
   ELSE SPTR1^.HEAD := SPTR2;
   REPLACEH := SPTR1;
 END{ OF REPLACEH };

 FUNCTION REPLACET(SPTR1, SPTR2: SYMBEXPPTR): SYMBEXPPTR;
 BEGIN
   IF ( SPTR1^.ANATOM ) THEN ERROR(6)
   ELSE SPTR1^.TAIL := SPTR2;
   REPLACET := SPTR1;
 END{ OF REPLACET };

 FUNCTION HEAD(SPTR: SYMBEXPPTR): SYMBEXPPTR;
 BEGIN
   IF ( SPTR^.ANATOM ) THEN ERROR(7)
   ELSE HEAD := SPTR^.HEAD;
 END{ OF HEAD };

 FUNCTION TAIL(SPTR: SYMBEXPPTR): SYMBEXPPTR;
 BEGIN
   IF ( SPTR^.ANATOM ) THEN ERROR(8)
   ELSE TAIL := SPTR^.TAIL;
 END{ OF TAIL };

 FUNCTION CONS(SPTR1, SPTR2: SYMBEXPPTR): SYMBEXPPTR;
 VAR   TEMP: SYMBEXPPTR;
 BEGIN
   POP(TEMP);
   TEMP^.ANATOM := FALSE; TEMP^.HEAD := SPTR1;
   TEMP^.TAIL := SPTR2; CONS := TEMP;
 END{ OF CONS };

 FUNCTION COPY(SPTR: SYMBEXPPTR): SYMBEXPPTR;
 {
       THIS FUNCTION CREATES A COPY OF THE STRUCTURE
       POINTED TO BY THE PARAMETER 'SPTR'
 }
 VAR   TEMP, NXT: SYMBEXPPTR;
 BEGIN
   IF ( SPTR^.ANATOM ) THEN BEGIN
       POP(TEMP);
       NXT := TEMP^.NEXT; TEMP^ := SPTR^;
       TEMP^.NEXT := NXT; COPY := TEMP
   END
   ELSE
       COPY := CONS(COPY(SPTR^.HEAD), COPY(SPTR^.TAIL));
 END{ OF COPY };

 FUNCTION APPEND(SPTR1, SPTR2: SYMBEXPPTR): SYMBEXPPTR;
 {
       THE RECURSIVE ALGORITHM IS FROM WEISSMAN, PG 97.
 }
 BEGIN
   IF ( SPTR1^.ANATOM ) THEN
     IF ( SPTR1^.NAME<>'NIL       ' ) THEN ERROR(9)
     ELSE APPEND := SPTR2
   ELSE
     APPEND := CONS(COPY(SPTR1^.HEAD), APPEND(SPTR1^.TAIL,SPTR2));
 END{ OF APPEND };

 FUNCTION CONC(SPTR1: SYMBEXPPTR): SYMBEXPPTR;
 {
       This function serves as the basic concatenation mechanism
       for variable numbers of list expressions in the input stream.
       The concatenation is handled recursively, using the identity:
          conc(a,b,c,d) = conc(a,cons(b,cons(c,(cons(d,nil))))

       The routine is called when a conc(..... command has been
       recognized on input, and its single argument is the first
       expression in the chain.  It has the side effect of reading
       all following input up to the parenthesis closing the
       conc command.

       The procedure consists of the following steps-
         1. call with 1st expression as argument.
         2. read the next expression.
         3. if the expression just read was not the last, recurse.
         4. otherwise... unwind.
}
 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{WITH};
       CONC := CONS(SPTR1, NILPTR);
     END
     ELSE
       ERROR(10);
 END{ OF CONC };

 FUNCTION EQQ(SPTR1, SPTR2: SYMBEXPPTR): SYMBEXPPTR;
 VAR   TEMP, NXT: SYMBEXPPTR;
 BEGIN
   POP(TEMP);
   NXT := TEMP^.NEXT;
   IF ( SPTR1^.ANATOM ) AND ( SPTR2^.ANATOM ) THEN
     IF ( SPTR1^.NAME=SPTR2^.NAME ) THEN
       TEMP^ := TNODE
     ELSE if ( sptr1=sptr2 ) then
       temp^ := tnode
     else
       temp^ := nilnode;
   TEMP^.NEXT := NXT; EQQ := TEMP;
 END{ OF EQQ };

 FUNCTION ATOM(SPTR: SYMBEXPPTR): SYMBEXPPTR;
 VAR   TEMP, NXT: SYMBEXPPTR;
 BEGIN
   POP(TEMP);
   NXT := TEMP^.NEXT;
   IF ( SPTR^.ANATOM ) THEN
     TEMP^ := TNODE
   ELSE
     TEMP^ := NILNODE;
   TEMP^.NEXT := NXT; ATOM := TEMP;
 END{ OF ATOM };

 FUNCTION LOOKUP(KEY, ALIST: SYMBEXPPTR): SYMBEXPPTR;
 VAR
   TEMP: SYMBEXPPTR;
 BEGIN
   TEMP := EQQ( HEAD( HEAD(ALIST)), KEY);
   IF ( TEMP^.NAME='T         ' ) THEN
     LOOKUP := TAIL(HEAD(ALIST))
   ELSE
     LOOKUP := LOOKUP(KEY, TAIL(ALIST))
 END{ OF LOOKUP };

 FUNCTION BINDARGS(NAMES, VALUES: SYMBEXPPTR): SYMBEXPPTR;
 VAR
   TEMP, TEMP2: SYMBEXPPTR;
 BEGIN
   IF ( NAMES^.ANATOM ) AND (NAMES^.NAME='NIL       ') THEN
     BINDARGS := ALIST
   ELSE BEGIN
       TEMP := CONS( HEAD(NAMES), EVAL(HEAD(VALUES), ALIST) );
       TEMP2 := BINDARGS(TAIL(NAMES), TAIL(VALUES));
       BINDARGS := CONS(TEMP, TEMP2)
   END
 END{ OF BINDARGS };

 FUNCTION EVCON(CONDPAIRS: SYMBEXPPTR): SYMBEXPPTR;
 VAR
   TEMP: SYMBEXPPTR;
 BEGIN
   TEMP := EVAL( HEAD(HEAD(CONDPAIRS)),ALIST );
   IF ( TEMP^.ANATOM ) AND (TEMP^.NAME='NIL       ') THEN
     EVCON := EVCON( TAIL(CONDPAIRS) )
   ELSE
     EVCON := EVAL( HEAD(TAIL(HEAD(CONDPAIRS))),ALIST )
 END{ OF EVCON };


 BEGIN {   * E V A L *   }
   IF ( E^.ANATOM ) THEN EVAL := LOOKUP(E, ALIST)
   ELSE
     BEGIN
       CAROFE := HEAD(E);
       IF ( CAROFE^.ANATOM ) THEN
          IF NOT ( CAROFE^.ISARESERVEDWORD ) THEN
            EVAL := EVAL( CONS(LOOKUP(CAROFE,ALIST),TAIL(E)), ALIST )
          ELSE
            CASE CAROFE^.RESSYM OF

              LABELSYM, LAMBDASYM: ERROR(3);

              QUOTESYM : EVAL := HEAD(TAIL(E));

              ATOMSYM  : EVAL := ATOM(EVAL(HEAD(TAIL(E)),ALIST));

              EQSYM    : EVAL := EQQ(EVAL(HEAD(TAIL(E)),ALIST),
                                     EVAL(HEAD(TAIL(TAIL(E))), ALIST));

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

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

              CONSSYM  : EVAL := CONS(EVAL(HEAD(TAIL(E)),ALIST),
                                      EVAL(HEAD(TAIL(TAIL(E))), ALIST));

              CONDSYM  : EVAL := EVCON(TAIL(E));

              CONCSYM  : {};

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

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;
{
       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[ APPENDSYM   ] := 'APPEND    ';
 RESWORDS[ ATOMSYM     ] := 'ATOM      ';
 RESWORDS[ HEADSYM     ] := 'CAR       ';
 RESWORDS[ TAILSYM     ] := 'CDR       ';
 RESWORDS[ CONDSYM     ] := 'COND      ';
 RESWORDS[ COPYSYM     ] := 'COPY      ';
 RESWORDS[ CONCSYM     ] := 'CONC      ';
 RESWORDS[ CONSSYM     ] := 'CONS      ';
 RESWORDS[ EQSYM       ] := 'EQ        ';
 RESWORDS[ LABELSYM    ] := 'LABEL     ';
 RESWORDS[ LAMBDASYM   ] := 'LAMBDA    ';
 RESWORDS[ QUOTESYM    ] := 'QUOTE     ';
 RESWORDS[ RELACEHSYM  ] := 'REPLACEH  ';
 RESWORDS[ RELACETSYM  ] := 'REPLACET  ';
{
       INITIALIZE THE A-LIST WITH  T  AND  NIL
}
 POP(ALIST);
 ALIST^.ANATOM := FALSE;
 ALIST^.STATUS := UNMARKED;
 POP(ALIST^.TAIL);
 NXT := ALIST^.TAIL^.NEXT;
 ALIST^.TAIL^ := NILNODE;
 ALIST^.TAIL^.NEXT := NXT;
 POP(ALIST^.HEAD);
{
       BIND NIL TO THE ATOM NIL
}
 WITH ALIST^.HEAD^ DO BEGIN
   ANATOM := FALSE; STATUS := UNMARKED; POP(HEAD);
   NXT := HEAD^.NEXT; HEAD^ := NILNODE; HEAD^.NEXT := NXT;
   POP(TAIL); NXT := TAIL^.NEXT; TAIL^ := NILNODE;
   TAIL^.NEXT := NXT
 END;
 POP(TEMP);
 TEMP^.ANATOM := FALSE;
 TEMP^.STATUS := UNMARKED;
 TEMP^.TAIL := ALIST;
 ALIST := TEMP;
 POP(ALIST^.HEAD);
{
       BIND  T  TO THE ATOM  T
}
 WITH ALIST^.HEAD^ DO BEGIN
   ANATOM := FALSE;  STATUS := UNMARKED; POP(HEAD);
   NXT := HEAD^.NEXT; HEAD^ := TNODE; HEAD^.NEXT := NXT;
   POP(TAIL); NXT := TAIL^.NEXT; TAIL^ := TNODE;
   TAIL^.NEXT := NXT
 END
END{ OF INITIALIZE };



BEGIN{+         LISP MAIN PROGRAM               +}
 WRITELN(' * EVAL *');
 INITIALIZE;
 NEXTSYM;
 READEXPR(PTR);
{}READLN(DUMMY);
 WRITELN;
 WHILE NOT ( PTR^.ANATOM ) OR ( PTR^.NAME<>'FIN       ' ) DO BEGIN
   WRITELN;
   WRITELN(' * VALUE *');
   PRINTEXPR( EVAL(PTR, ALIST) );
1:  WRITELN;
   WRITELN;
   IF ( EOF(INPUT) ) THEN ERROR(11);
   PTR := NIL;
   { CALL THE } GARBAGEMAN;
   WRITELN; WRITELN;
   WRITELN(' * EVAL *');
   NEXTSYM;
   READEXPR(PTR);
{}  READLN(DUMMY);
   WRITELN;
 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 }.

You are viewing proxied material from gopher.floodgap.com. The copyright of proxied material belongs to its original authors. Any comments or complaints in relation to proxied material should be directed to the original authors of the content concerned. Please see the disclaimer for more details.