%EXTERNALROUTINESPEC PROMPT(%STRING(15) S)
%EXTERNALROUTINESPEC CLOSE STREAM(%INTEGER N)
%EXTERNALROUTINESPEC DEFINE(%STRING(63) S)
%EXTERNALROUTINE LISP INTP(%INTEGER SPACE, INITMODE)
!
! ***** READ  ROUTINES *****
!
%INTEGERFNSPEC RATOM
%INTEGERFNSPEC READ SEXP(%STRING(15) PMPT)
!
! ***** PRINT ROUTINES *****
!
%ROUTINESPEC PRINT CHARS(%STRING(72) PHRASE)
%STRING(15)%FNSPEC NUMBER(%INTEGER I)
%STRING(72)%FNSPEC PNAME(%INTEGER INDEX)
%ROUTINESPEC PRINT(%INTEGER INDEX)
!
! ***** LISP  ROUTINES *****
!
%INTEGERFNSPEC PUSH(%INTEGER INDEX)
%INTEGERFNSPEC CONS(%INTEGER CAR, CDR)
%INTEGERFNSPEC EVAL(%INTEGER FORM)
%INTEGERFNSPEC EVLIST(%INTEGER ARGS)
%INTEGERFNSPEC APPLY(%INTEGER FN, ARGS)
%INTEGERFNSPEC NUMBERP(%INTEGERNAME N)
%INTEGERFNSPEC MATOM(%STRING(72) PNAME)
%INTEGERFNSPEC PUT(%INTEGER ATOM, VALUE, PROPERTY)
%ROUTINESPEC INIT LISP
%ROUTINESPEC GARBAGE COLLECT
%ROUTINESPEC LOOP(%STRING(15) PMPT, %INTEGER TERM)
!
! ***** LISP MACHINE *****
!
%CONSTINTEGER  LONG BASE=256,   LONG MASK=X'FF00',  LONG TAIL=511
%CONSTINTEGER  NAME BASE=512,   NAME MASK=X'FE00',  NAME TAIL=2047
%CONSTINTEGER STACK BASE=1024, STACK MASK=X'FB00', STACK TAIL=1535
%CONSTINTEGER SHORT BASE=2048, SHORT MASK=X'F800', SHORT TAIL=4095
%CONSTINTEGER  LIST BASE=4096,                      LIST TAIL=X'7FFF'
%CONSTINTEGER  ATOM BASE=256
%CONSTINTEGER  CHAR BASE=1919
%CONSTINTEGER  ZERO BASE=3072
!
! ***** LISP MACHINE STORE *****
!
%RECORDFORMAT LISPINFO(%INTEGER X1, X2, X3, X4, X5, X6, X7, X8, %C
                                CONST, LONG HEAD, %C
                                PNAME SPACE, PNAME BASE, PNAME HEAD, %C
                                NAME, NAME HEAD, %C
                                STACK, GLOBAL, %C
                                LIST, LIST HEAD, LIST COUNT)
%RECORDNAME LISPFILE(LISPINFO)
      LISPFILE==RECORD(SPACE)
!
      %IF INITMODE>0 %START
         LISPFILE_CONST=X'1000';  LISPFILE_LONG HEAD=LONG BASE
         LISPFILE_PNAME SPACE=LISPFILE_CONST+4*(LONG TAIL-LONG BASE+1)
         LISPFILE_PNAME BASE=LISPFILE_PNAME SPACE
         LISPFILE_PNAME HEAD=LISPFILE_PNAME BASE
         LISPFILE_NAME=X'4000'
         LISPFILE_NAME HEAD=NAME BASE
         LISPFILE_STACK=X'A000'
         LISPFILE_GLOBAL=STACK TAIL
         LISPFILE_LIST=X'10000'
      %FINISH
%INTEGERARRAYNAME CONST
%INTEGERARRAYFORMAT CONSTF(LONG BASE:LONG TAIL)
      CONST==ARRAY(SPACE+LISPFILE_CONST,CONSTF)
      %INTEGERNAME LONG HEAD;  LONG HEAD==LISPFILE_LONG HEAD
%BYTEINTEGERARRAYNAME PNAME SPACE
%BYTEINTEGERARRAYFORMAT PNAMEF(0:8191)
      PNAME SPACE==ARRAY(SPACE+LISPFILE_PNAME SPACE,PNAMEF)
      %INTEGERNAME PNAME HEAD;  PNAME HEAD==LISPFILE_PNAME HEAD
      %INTEGER PNAME TAIL;  PNAME TAIL=ADDR(PNAME SPACE(8191))
%RECORDFORMAT ATOM CELL(%HALFINTEGER BIND, PROP, FUNC, %C
                        %BYTEINTEGER FORM, %STRINGNAME PNAME)
%RECORDARRAYNAME  NAME (ATOM CELL)
%RECORDARRAYFORMAT NAMEF(NAME BASE:NAME TAIL) (ATOM CELL)
      NAME==ARRAY(SPACE+LISPFILE_NAME,NAMEF)
      %INTEGERNAME NAME HEAD;  NAME HEAD==LISPFILE_NAME HEAD
      %INTEGERNAME GLOBAL;  GLOBAL==LISPFILE_GLOBAL
      ! FIXUP 'PNAME' ADDRESSES
      %RECORDNAME ATOM(ATOM CELL)
      %INTEGER I, FIXUP
      FIXUP=ADDR(PNAME SPACE(0))-LISPFILE_PNAME BASE
      LISPFILE_PNAME BASE=LISPFILE_PNAME BASE+FIXUP
      LISPFILE_PNAME HEAD=LISPFILE_PNAME HEAD+FIXUP
      %IF NAME HEAD>NAME BASE %START
         %CYCLE I=NAME BASE,1,NAME HEAD-1
            ATOM==NAME(I)
            ATOM_PNAME==STRING(ADDR(ATOM_PNAME)+FIXUP)
            ATOM_BIND=STACK TAIL %UNLESS GLOBAL<=ATOM_BIND<=STACK TAIL
         %REPEAT
      %FINISH
      %CYCLE I=CHAR BASE,1,NAME TAIL
         ATOM==NAME(I)
         ATOM_BIND=STACK TAIL %UNLESS GLOBAL<=ATOM_BIND<=STACK TAIL
      %REPEAT
%RECORDFORMAT LISP CELL(%HALFINTEGER CAR, CDR)
%RECORDARRAYNAME LIST (LISP CELL)
%RECORDARRAYFORMAT LISTF(0:LIST TAIL) (LISP CELL)
      LIST==ARRAY(SPACE+LISPFILE_LIST,LISTF)
      %INTEGERNAME LIST HEAD;  LIST HEAD==LISPFILE_LIST HEAD
      %INTEGERNAME LIST COUNT;  LIST COUNT==LISPFILE_LIST COUNT
%RECORDFORMAT STACK FRAME(%HALFINTEGER BACK, BIND, LINK)
%RECORDARRAYNAME STACK(STACK FRAME)
%RECORDARRAYFORMAT  STACKF(STACK BASE:STACK TAIL) (STACK FRAME)
      STACK==ARRAY(SPACE+LISPFILE_STACK,STACKF)
!
! ***** INTERPRETER WORKING STORAGE *****
!
%INTEGER LOCAL;   LOCAL=STACK BASE
%INTEGER FRONT;   FRONT=LOCAL
%INTEGERARRAY AUXS(0:1023)
%INTEGER AUXP;  AUXP=0
!
%INTEGER INFILE, OUTFILE
%INTEGER SEXP, FLAG, PROGFLAG, RESET, ERRVAL, NILLIST
%STRING(72) LINE, PLABEL;  %STRING(15) PMPT;  PMPT="READ:"
!
! *****   CONSTANTS  *****
!
%CONSTSTRING(1) SNL = "
"
%OWNSTRING(5) ERRORS="ERROR"
%CONSTINTEGER ERROR=0, ERROR1=1, ERROR2=2, ERROR3=3, ERROR4=4
%CONSTINTEGER NIL=512, QUOTE=513
%CONSTINTEGER LABEL=514, LAMBDA=515
%CONSTINTEGER APVAL=516, SUBR=517, FSUBR=518, EXPR=519, FEXPR=520
%CONSTINTEGER EXIT=521, EVLN=X'820A', STARS=523
%CONSTINTEGER T=2003, PERCENT=1956
!
%CONSTINTEGER NORMAL=0, SETUP=1, INSTREAM=2, OUTSTREAM=3;     ! I/O STREAMS
!
!
       PLABEL="";  LINE="";  PROGFLAG=0;  FLAG=0
       INIT LISP %IF INITMODE>0
       NILLIST=CONS(NIL,NIL);  LIST(NILLIST)_CDR=PUSH(NILLIST)
       INFILE=MATOM(".TT");  OUTFILE=INFILE
!
%ROUTINE INIT LISP
%RECORDNAME ATOM(ATOM CELL)
%RECORDNAME CELL(LISP CELL)
%RECORDNAME FRAME(STACK FRAME)
%INTEGER I
       %CYCLE I=LONG HEAD,1,LONG TAIL-1
          CONST(I)=I+1
       %REPEAT
       CONST(LONG TAIL)=0
       %CYCLE I=NAME BASE,1,NAME TAIL
          ATOM==NAME(I)
          ATOM_BIND=STACK TAIL
          ATOM_PROP=NIL
          ATOM_FUNC=0;  ATOM_FORM=0
          ATOM_PNAME==ERRORS
       %REPEAT
       SELECT INPUT(SETUP)
       RESET=0
       %CYCLE I=NIL,1,STARS
          SEXP=RATOM;                   ! READ IN KNOWN ATOMS
       %REPEAT
       %CYCLE I=0,1,LIST BASE-1
          CELL==LIST(I)
          CELL_CAR=ERROR3;  CELL_CDR=ERROR3
       %REPEAT
       LIST HEAD=LIST BASE;  LIST COUNT=LIST TAIL-LIST HEAD
       %CYCLE I=LIST BASE,1,LIST TAIL-1
          LIST(I)_CAR=I+1
       %REPEAT
       LIST(LIST TAIL)=0
       SEXP=PUT(RATOM,RATOM,RATOM) %UNTIL SEXP=NIL;    ! INITIALIZE  FROM INITLISP.
       STACK(FRONT)_BIND=ERROR
       FRAME==STACK(GLOBAL)
       FRAME_LINK=GLOBAL
       FRAME_BIND=ERROR1
       AUXS(AUXP)=ERROR
       I=EVAL(READ SEXP("")) %UNTIL I=NIL
       SELECT INPUT(NORMAL)
%END
%ROUTINE GARBAGE COLLECT
%RECORDNAME CELL(LISP CELL)
%INTEGER I
!
%ROUTINE MARK(%INTEGER INDEX)
%HALFINTEGERNAME CAR
       %WHILE INDEX>=LIST BASE %AND LIST(INDEX)_CAR&X'8000'=0 %CYCLE
          CAR==LIST(INDEX)_CAR;  INDEX=LIST(INDEX)_CDR
          CAR<-CAR!X'8000'
          MARK(CAR&X'7FFF') %IF CAR&X'7FFF'>=LIST BASE
       %REPEAT
%END
       %CYCLE I=NAME BASE,1,NAME HEAD-1
          MARK(NAME(I)_PROP)
       %REPEAT
       %CYCLE I=CHAR BASE,1,NAME TAIL
          MARK(NAME(I)_PROP)
       %REPEAT
       %CYCLE I=STACK BASE,1,FRONT
          MARK(STACK(I)_BIND)
       %REPEAT
       %CYCLE I=GLOBAL,1,STACK TAIL
          MARK(STACK(I)_BIND)
       %REPEAT
       %IF AUXP>0 %START
          %CYCLE I=0,1,AUXP-1
             MARK(AUXS(I))
          %REPEAT
       %FINISH
          LIST COUNT=0;  LIST HEAD=0
       %CYCLE I=LIST BASE,1,LIST TAIL
          CELL==LIST(I)
          %IF CELL_CAR&X'8000'#0 %THEN CELL_CAR<-CELL_CAR&X'7FFF' %ELSE %START
             LIST COUNT=LIST COUNT+1
             CELL_CAR=LIST HEAD;  LIST HEAD=I
          %FINISH
       %REPEAT
%END
%INTEGERFN MATOM(%STRING(72) PNAME)
%RECORDNAME ATOM(ATOM CELL)
%INTEGER INDEX
       %RESULT=CHAR BASE+BYTE INTEGER(ADDR(PNAME)+1)&X'7F' %C
          %IF LENGTH(PNAME)=1
       %IF NAME HEAD>NAME BASE %START
          %CYCLE INDEX=NAME BASE,1,NAME HEAD-1
             %RESULT=INDEX %IF PNAME=NAME(INDEX)_PNAME
          %REPEAT
       %FINISH
       %UNLESS NAME HEAD<CHAR BASE %C
          %AND PNAME HEAD+LENGTH(PNAME)+1<PNAME TAIL %START
          PRINT STRING("
ATOM ERROR:   NO MORE SPACE FOR NAMES
");       %RESULT=ERROR
       %FINISH
       ATOM==NAME(NAME HEAD)
       ATOM_PNAME==STRING(PNAME HEAD)
       PNAME HEAD=PNAME HEAD+LENGTH(PNAME)+1
       ATOM_PNAME=PNAME
       INDEX=NAME HEAD
       NAME HEAD=NAME HEAD+1
       %RESULT=INDEX
%END
%INTEGERFN MNUMB(%INTEGER VALUE)
%INTEGER INDEX
       %RESULT=VALUE+ZERO BASE %IF -1023<=VALUE<=1023
       %UNLESS LONG BASE<=LONG HEAD<=LONG TAIL %START
          PRINT STRING("
ATOM ERROR:   NO MORE ROOM FOR LONG CONSTANTS
");       %RESULT=ERROR
       %FINISH
       INDEX=LONG HEAD;                           ! NEXT FREE CONST HOLE
       LONG HEAD=LONG HEAD+1
       CONST(INDEX)=VALUE
       %RESULT=INDEX
%END
%INTEGERFN RATOM
%CONSTBYTEINTEGERARRAY CODE(0:127) = %C
X'80', X'80', X'80', X'80', X'80', X'80', X'80', X'80',
X'80', X'80', X'80', X'80', X'80', X'80', X'80', X'80',
X'80', X'80', X'80', X'80', X'80', X'80', X'80', X'80',
X'80', X'89', X'80', X'80', X'80', X'80', X'80', X'80',
X'80', X'21', X'22', X'23', X'88', X'25', X'26', X'84',
X'81', X'83', X'2A', X'2B', X'2C', X'2D', X'82', X'88',
X'30', X'31', X'32', X'33', X'34', X'35', X'36', X'37',
X'38', X'39', X'3A', X'3B', X'3C', X'3D', X'3E', X'3F',
X'84', X'41', X'42', X'43', X'44', X'45', X'46', X'47',
X'48', X'49', X'4A', X'4B', X'4C', X'4D', X'4E', X'4F',
X'50', X'51', X'52', X'53', X'54', X'55', X'56', X'57',
X'58', X'59', X'5A', X'85', X'5C', X'87', X'5E', X'5F',
X'60', X'61', X'62', X'63', X'64', X'65', X'66', X'67',
X'68', X'69', X'6A', X'6B', X'6C', X'6D', X'6E', X'6F',
X'70', X'71', X'72', X'73', X'74', X'75', X'76', X'77',
X'78', X'79', X'7A', X'7B', X'7C', X'7D', X'7E', X'7F'
%CONSTINTEGER ESCAPE=X'88', EOF=X'89'
%OWNINTEGER CHAR=X'80';  %STRING(72) PNAME
%INTEGER TYPE, SIGN, VALUE
       TYPE=0;  VALUE=0;  SIGN=1;  PNAME=""
       %CYCLE
          %IF CHAR&X'80'#0 %THEN %START;          ! SEPERATOR
             %IF PNAME#"" %THEN %START;           ! TERMINATOR
                %RESULT=MATOM(PNAME) %IF TYPE<2;  ! SYMBOLIC ATOM
                %RESULT=MNUMB(SIGN*VALUE);        ! NUMERIC ATOM
             %FINISH
             VALUE=CHAR&X'7F'
             CHAR=X'80' %AND %RESULT=VALUE  %C
                %IF CHAR#X'80';                   ! BREAK CHARACTER
          %FINISH %ELSE %START;                   ! NORMAL CHARACTER
             %IF 0<=TYPE<=2 %THEN %START;         ! POSSIBLY NUMERIC
                %IF '0'<=CHAR<='9' %THEN %START;  ! YES FOR NOW
                   TYPE=2;  VALUE=10*VALUE+CHAR-'0'
                %FINISH %ELSE %START;             ! POSSIBLY SIGNED
                   %IF TYPE=0 %AND (CHAR='+' %OR CHAR='-') %THEN %START
                      TYPE=1;  SIGN=-1 %IF CHAR='-'
                   %FINISH %ELSE TYPE=-1;         ! NOT NUMERIC
                %FINISH
             %FINISH
             PNAME<-PNAME.TO STRING(CHAR);        ! ALWAYS SYMBOLIC
          %FINISH
          %UNTIL CHAR#EOF %CYCLE
             READ CH(CHAR);  CHAR=CODE(CHAR); ! NEXT SYMBOL
             SELECT INPUT(NORMAL) %IF CHAR=EOF
          %REPEAT
          READ CH(CHAR) %AND TYPE=-1 %IF CHAR=ESCAPE
       %REPEAT
%END
%INTEGERFN READ SEXP(%STRING(15) PMPT)
%INTEGERFNSPEC CELL(%INTEGER CAR)
%INTEGERFNSPEC HEAD
%INTEGERFNSPEC TAIL
%INTEGER COLAPSE
%INTEGERFN CELL(%INTEGER CAR)
%INTEGER CDR
       %IF CAR>=ATOM BASE %THEN %START;          ! HEAD NOT IN ERROR
          AUXS(AUXP)=CAR;  AUXP=AUXP+1;  CDR=TAIL;  AUXP=AUXP-1
          %RESULT=CONS(CAR,CDR) %IF CDR>=ATOM BASE;! TAIL NOT IN ERROR
       %FINISH
       %RESULT=ERROR
%END
%INTEGERFN HEAD
%CONSTSTRING(1) %ARRAY CHAR(0:7)  = %C
 " ", "(", ".", ")", "'", "[", " ", "]"
%SWITCH SW(0:3)
%INTEGER TEMP, RESULT
       TEMP=RATOM
       ->SW(TEMP&3) %UNLESS TEMP>=ATOM BASE;      ! HANDLE BY CASE
       %RESULT=TEMP;                              ! ATOM
SW(0): %RESULT=CONS(QUOTE,CONS(HEAD,NIL));        ! "
SW(1): RESULT=TAIL;                               ! '(' OR '['
       COLAPSE=0 %IF TEMP>=4;                     ! '['
       %RESULT=RESULT
SW(2):                                            ! '.' OR ')'
SW(3): PRINT STRING("
READ ERROR:   S-EXPRESSION BEGINS WITH A ".CHAR(TEMP)."
");    %RESULT=ERROR
%END
%INTEGERFN TAIL
%SWITCH SW(0:3)
%INTEGER TEMP, RESULT
       %RESULT=NIL %IF COLAPSE>0;                 ! COLAPSE BACK TO '['
       TEMP=RATOM;                                ! SEPERATOR
       ->SW(TEMP&3) %UNLESS TEMP>=ATOM BASE;      ! HANDLE BY CASE
       %RESULT=CELL(TEMP);                        ! ATOM
SW(0): %RESULT=CELL(CONS(QUOTE,CONS(HEAD,NIL)))
SW(1): RESULT=TAIL;                               ! '(' OR '['
       COLAPSE=0 %IF TEMP>=4;                     ! '['
       %RESULT=CELL(RESULT)
SW(2): TEMP=HEAD;                                 ! '.'
       %RESULT=TEMP %IF TAIL=NIL
       PRINT STRING("
READ ERROR:   DOTTED PAIR NOT ENCLOSED IN BRACKETS
");    %RESULT=ERROR
SW(3): COLAPSE=1 %IF TEMP>=4;  %RESULT=NIL;       ! ')' OR ']'
%END
       COLAPSE=0
       PROMPT(PMPT)
       %RESULT=HEAD
%END
%ROUTINE PRINT CHARS(%STRING(72) PHRASE)
       PHRASE<-PLABEL.PHRASE %AND PLABEL="" %IF PLABEL#""
       %IF LENGTH(LINE)+LENGTH(PHRASE)>=72 %OR PHRASE="" %THEN %START
          PRINT STRING(LINE.SNL); LINE="";        ! OUTPUT LINE
       %FINISH
       LINE=LINE.PHRASE;                          ! APPEND PHRASE
%END
%STRING(15)%FN NUMBER(%INTEGER VALUE)
%STRING(72) PNAME; %STRING(1) SIGN
%INTEGER REM
       %IF VALUE<0 %THEN SIGN="-" %AND VALUE=-VALUE %C
          %ELSE SIGN=""
       PNAME=""
       %UNTIL VALUE=0 %CYCLE;                     ! PRINT ALL SIGNIFICANT DIGITS
          REM=VALUE;  VALUE=VALUE//10
          REM=REM-10*VALUE;                       ! RIGHT HAND DIGIT
          PNAME=TO STRING(REM+'0').PNAME
       %REPEAT
       %RESULT=SIGN.PNAME
%END
%STRING(72)%FN PNAME(%INTEGER INDEX)
       %IF INDEX>=LONG BASE %THEN %START
          %IF INDEX>=NAME BASE %THEN %START
             %RESULT=NUMBER(INDEX-ZERO BASE) %IF INDEX>=SHORT BASE
             %RESULT=TO STRING(INDEX-CHAR BASE) %IF INDEX>=CHAR BASE
             %RESULT=NAME(INDEX)_P NAME
          %FINISH %ELSE %RESULT=NUMBER(CONST(INDEX))
       %FINISH %ELSE %RESULT="ERROR"
%END
%ROUTINE PRINT(%INTEGER INDEX)
%INTEGERARRAY LINE POS(0:7)
%BYTEINTEGER R FLAG, LINE 1
%INTEGER LEVEL, I
%ROUTINE L PAREN
%OWNBYTEINTEGERARRAY BLANKS(0:72) = ' '(73)
%INTEGER INDEX, PADDING
       LINE POS(LEVEL)=LENGTH(LINE) %IF LEVEL<8 %AND LINE POS(LEVEL)=0
       %IF R FLAG>0 %THEN %START;                 ! START OF NEW PHRASE
          PRINT STRING(LINE.SNL);  LINE 1=0;      ! OUTPUT LINE
          %IF LEVEL<8 %THEN INDEX=LEVEL %ELSE INDEX=7
          PADDING=LINE POS(INDEX)-LENGTH(PLABEL)
          PADDING=0 %IF PADDING<0
          BLANKS(0)=PADDING
          LINE=STRING(ADDR(BLANKS(0)));          ! INDENT NEW PHRASE
       %FINISH
       LEVEL=LEVEL+1 %IF LINE 1=0;  R FLAG=0
       PRINT CHARS("(")
%END
%ROUTINE R PAREN
       PRINT CHARS(")")
       LINE POS(LEVEL)=0 %IF 0<LEVEL<8
       LEVEL=LEVEL-1 %IF LEVEL>0
       R FLAG=1
%END
%ROUTINE PRINT SEXP(%INTEGER INDEX)
%RECORDNAME CELL(LISP CELL)
%INTEGER CAR, CDR
       %IF INDEX>=LIST BASE %THEN %START;         ! LIST CELL
          CELL==LIST(INDEX)
          CAR=CELL_CAR;  CDR=CELL_CDR;            ! MAP ONTO CELL
          L PAREN;  PRINT SEXP(CAR);              ! START OF LIST
          %IF CDR>=LIST BASE %THEN %START
             %CYCLE;                              ! PRINT TAIL
                INDEX=CDR;  CELL==LIST(INDEX)
                CAR=CELL_CAR;  CDR=CELL_CDR
                LINE<-LINE." " %IF PLABEL="";     ! PRINT SPACE
                %EXIT %IF CDR<LIST BASE;          ! END OF LIST
                %IF CAR=NIL %THEN %START;         ! PRINT EMPTY LIST
                   L PAREN; LINE<-LINE." "; R PAREN
                %FINISH %ELSE PRINT SEXP(CAR);    ! PRINT CAR
             %REPEAT
             PRINT SEXP(CAR)
          %FINISH
          PRINTCHARS(" . ") %AND  PRINTCHARS(PNAME(CDR)) %AND RFLAG=0 %C
             %IF CDR#NIL;                      ! DOTTED PAIR
          R PAREN;                             ! CLOSE LIST
       %FINISH %ELSE %START;                   ! ATOM
          %IF R FLAG=1 %THEN R FLAG=2 %AND PLABEL<-PNAME(INDEX)." " %C
             %ELSE PRINT CHARS(PNAME(INDEX)) %AND R FLAG=0
       %FINISH
%END
       LINE 1=1;  R FLAG=0
       LEVEL=0;  LINE POS(0)=4;                   ! INITIAL INDENTATION
       %CYCLE I=1,1,7
          LINE POS(I)=0
       %REPEAT
       PRINT SEXP(INDEX)
%END
%INTEGERFN PUT(%INTEGER ATOM, BIND, PROP)
%CONSTBYTEINTEGERARRAY MASK(516:520) = 3, 6, 2, 5, 1
%RECORDNAME PROP CELL, BIND CELL(LISP CELL)
%HALFINTEGERNAME HOLE;  %INTEGER ID
       %RESULT=ERROR3 %C
          %UNLESS NAME BASE<=ATOM<=NAME TAIL %C
             %AND NAME BASE<=PROP<=NAME TAIL
       HOLE==NAME(ATOM)_PROP
       %CYCLE;                              ! SEARCH PROPERTY LIST
          HOLE=CONS(PROP,CONS(BIND,NIL)) %AND %EXIT %C
             %IF HOLE<LIST BASE;            ! NOT ON LIST
          PROP CELL==LIST(HOLE);  BIND CELL==LIST(PROP CELL_CDR)
          BIND CELL_CAR=BIND %AND %EXIT %C
             %IF PROP CELL_CAR=PROP;        ! PROPERTY FOUND
          HOLE==BIND CELL_CDR;              ! TRY NEXT ENTRY
       %REPEAT
       %IF APVAL<=PROP<=FEXPR %THEN %START;  ! FUNCTION DEFENITION
          NAME(ATOM)_FORM=MASK(PROP)
          %IF SUBR<=PROP<=FSUBR %START
             ID=BIND;  %RESULT=ERROR3 %UNLESS NUMBERP(ID)=T
             NAME(ATOM)_FUNC=ID
          %FINISH %ELSE NAME(ATOM)_FUNC=BIND
       %FINISH
       %RESULT=BIND
%END
%INTEGERFN NUMBERP(%INTEGERNAME VALUE)
       VALUE=CONST(VALUE) %AND %RESULT=T %IF VALUE&LONG MASK=LONG BASE
       VALUE=VALUE-ZERO BASE %AND %RESULT=T %C
          %IF VALUE&SHORT MASK=SHORT BASE
       %RESULT=NIL
%END
%INTEGERFN EQUAL(%INTEGER ARG1, ARG2)
       %RESULT=T %IF ARG1=ARG2 %C
          %OR (NUMBERP(ARG1)=T=NUMBERP(ARG2) %AND ARG1=ARG2) %C
          %OR (ARG1>=LIST BASE %AND ARG2>=LIST BASE %C
             %AND EQUAL(LIST(ARG1)_CAR,LIST(ARG2)_CAR)=T %C
             %AND EQUAL(LIST(ARG1)_CDR,LIST(ARG2)_CDR)=T)
       %RESULT=NIL
%END
%%ROUTINE XPRINT(%STRING(72) MESS, %INTEGER FORM)
%STRING(72) SAVE
       SAVE=LINE
       LINE=MESS
       PRINT(FORM);  PRINT CHARS("")
       LINE=SAVE
%END
%INTEGERFN TRACE(%STRING(16) MESS, %INTEGER FORM)
       XPRINT(MESS,FORM)
       %RESULT=FORM
%END
%ROUTINE BIND(%INTEGER SYMB, ENTRY, BIND)
%RECORDNAME ATOM(ATOM CELL)
%RECORDNAME FRAME(STACK FRAME)
       %UNLESS NAME BASE<=SYMB<LIST BASE %START
          PRINT STRING("
BIND ERROR:   ELEMENT OF NAME LIST NOT AN ATOM ")
          XPRINT("",SYMB);  %RETURN
       %FINISH
       XPRINT("
BIND ERROR:   NAME LIST ENTRY HAS CONSTANT BINDING, NAME=",SYMB) %C
          %AND %RETURN %IF NAME(SYMB)_FORM=3
       %UNLESS GLOBAL>FRONT %START
          PRINT STRING("
BIND ERROR:  STACK OVERFLOW
");       %RETURN
       %FINISH
       FRAME==STACK(ENTRY)
       ATOM==NAME(SYMB)
       %UNLESS BIND>=ATOM BASE %START
          PRINT STRING("
BIND ERROR:   UNASSIGNED ARGUMENT ")
          XPRINT("",SYMB);  BIND=ERROR
       %FINISH
       FRAME_BIND=BIND
       FRAME_BACK=SYMB
       FRAME_LINK=ATOM_BIND
       ATOM_BIND=ENTRY
%END
%ROUTINE BINDLIST(%INTEGERNAME NAMES, ARGS)
%RECORDNAME CELL, ARGC(LISP CELL)
       STACK(FRONT)_LINK=LOCAL
       STACK(FRONT)_BACK=0
       LOCAL=FRONT
       FRONT=FRONT+1
       %WHILE NAMES>=LIST BASE %CYCLE
          CELL==LIST(NAMES);  ARGC==LIST(ARGS)
          BIND(CELL_CAR,FRONT,ARGC_CAR)
          FRONT=FRONT+1
          NAMES=CELL_CDR;  ARGS=ARGC_CDR
       %REPEAT
%END
%INTEGERFN UNBIND(%INTEGER RESULT)
%RECORDNAME FRAME(STACK FRAME)
       %WHILE FRONT>LOCAL %CYCLE
          FRONT=FRONT-1
          FRAME==STACK(FRONT)
          NAME(FRAME_BACK)_BIND=FRAME_LINK %IF FRAME_BACK>0
       %REPEAT
       FRONT=LOCAL
       LOCAL=STACK(FRONT)_LINK
       %RESULT=RESULT
%END
%INTEGERFN PUSH(%INTEGER INDEX)
       AUXS(AUXP)=INDEX
       AUXP=AUXP+1
       %RESULT=INDEX
%END
%INTEGERFN PCONS(%INTEGER CAR, CDR)
       AUXP=AUXP-1
       %RESULT=CONS(CAR,CDR)
%END
%INTEGERFN CONS(%INTEGER CAR, CDR)
%RECORDNAME CELL(LISP CELL)
%INTEGER INDEX
       %IF LIST COUNT<=100 %OR LIST HEAD<LIST BASE%THEN %START
          AUXS(AUXP)=CAR;  AUXS(AUXP+1)=CDR;  AUXP=AUXP+2
          GARBAGE COLLECT;  AUXP=AUXP-2
          PRINT STRING("
LISP  NOTE:   LESS THAN 1000 FREE CELLS REMAINING - FREE SOMETHING
")          %AND LOOP("FREE:",PERCENT) %IF LIST COUNT<=1000
       %FINISH
       PRINT STRING("
LISP ERROR:   NO MORE FREE SPACE LEFT
")       %AND %RESULT=ERROR %IF LIST HEAD<LIST BASE
       LIST COUNT=LIST COUNT-1
       INDEX=LIST HEAD
       CELL==LIST(INDEX)
       LIST HEAD=CELL_CAR
       CELL_CAR=CAR;  CELL_CDR=CDR
       %RESULT=INDEX
%END
%INTEGERFN PROG(%INTEGER NAMES, BODY)
%RECORDNAME CELL(LISP CELL)
%INTEGER PROGLIST, RESULT
       BINDLIST(NAMES,NILLIST)
       PROGFLAG=PROGFLAG+4;                         ! IN PROG
       PROGLIST=BODY
       %WHILE BODY>=LIST BASE %CYCLE;               ! EVALUATE BODY
          CELL==LIST(BODY)
          %IF CELL_CAR>=LIST BASE %THEN %START;     ! NOT A PLABEL
             RESULT=EVAL(CELL_CAR);                 ! SO EVALUATE
             %IF PROGFLAG&3#0 %THEN %START;         ! RETURN OR GO
                PROGFLAG=PROGFLAG&(\3)-4 %AND %RESULT=UNBIND(RESULT) %C
                   %IF PROGFLAG&1#0;                ! RETURN
                CELL==LIST(PROGLIST)
                PROGFLAG=PROGFLAG&(\3)
                %WHILE CELL_CAR#RESULT %CYCLE;      ! SCAN FOR LABEL
                   PROGFLAG=PROGFLAG-4 %AND %RESULT=UNBIND(ERROR) %C
                      %IF CELL_CDR<LIST BASE;       ! NOT FOUND
                   CELL==LIST(CELL_CDR)
                %REPEAT
             %FINISH
          %FINISH
          BODY=CELL_CDR
       %REPEAT
       PROGFLAG=PROGFLAG-4;  %RESULT=UNBIND(RESULT);         ! FELL THROUGH
%END
%STRING(72)%FN PACK(%INTEGER INDEX)
%STRING(72) PACKED
%INTEGER CAR
       PACKED=""
       %WHILE INDEX>=LIST BASE %CYCLE;   ! CDR DOWN THE LIST
          CAR=LIST(INDEX)_CAR;  INDEX=LIST(INDEX)_CDR
          %IF CAR>=LIST BASE %THEN PACKED<-PACKED.PACK(CAR) %C
             %ELSE PACKED<-PACKED.PNAME(CAR)
       %REPEAT
       PACKED<-PACKED.PNAME(INDEX) %UNLESS INDEX=NIL
       %RESULT=PACKED
%END
%INTEGERFN REVERSE(%INTEGER CURR)
%RECORDNAME CELL(LISP CELL)
%INTEGER LAST
       LAST=NIL
       %WHILE CURR>=LIST BASE %CYCLE
          CELL==LIST(CURR)
          LAST=CONS(CELL_CAR,LAST);  CURR=CELL_CDR
       %REPEAT
       %RESULT=LAST
%END
%INTEGERFN FUNC(%RECORDNAME ATOM, %INTEGER ARGS)
%RECORDSPEC ATOM(ATOM CELL)
%RECORDNAME CELL(LISP CELL)
%RECORDNAME FRAME(STACK FRAME)
%SWITCH TYPE(0:3), FUNC(0:90)
%STRING(72) LINE
%INTEGER ARG1, ARG2, ARG3, SYMB
%HALFINTEGERNAME HOLE
       ->TYPE(ATOM_FORM&3)
TYPE(3): ! APVAL
TYPE(0): ! NO FUNCTION DEFENITION ON PROPERTY LIST
       %RESULT=ERROR2 %UNLESS ATOM_BIND<GLOBAL;  ! NOR ON ALIST
       ARGS=EVLIST(ARGS)
       %RESULT=APPLY(STACK(ATOM_BIND)_BIND,ARGS)
TYPE(1): ! EXPR OR FEXPR
       %RESULT=APPLY(ATOM_FUNC,ARGS)
TYPE(2): ! SUBR OR FSUBR
       CELL==LIST(ARGS);  ARG1=CELL_CAR
       CELL==LIST(CELL_CDR);  ARG2=CELL_CAR
       CELL==LIST(CELL_CDR);  ARG3=CELL_CAR
       ->FUNC(ATOM_FUNC)
FUNC(0): ! QUOTE
       %RESULT=ARG1
FUNC(1): ! CAR
       %RESULT=LIST(ARG1)_CAR
FUNC(2): ! CDR
       %RESULT=LIST(ARG1)_CDR
FUNC(3): ! CAAR
       %RESULT=LIST(LIST(ARG1)_CAR)_CAR
FUNC(4): ! CADR
       %RESULT=LIST(LIST(ARG1)_CDR)_CAR
FUNC(5): ! CDAR
       %RESULT=LIST(LIST(ARG1)_CAR)_CDR
FUNC(6): ! CDDR
       %RESULT=LIST(LIST(ARG1)_CDR)_CDR
FUNC(7): ! CONS
       %RESULT=CONS(ARG1,ARG2)
FUNC(8): ! LIST
       %RESULT=ARGS
FUNC(9): ! COND
       %WHILE ARGS>=LIST BASE %CYCLE
          CELL==LIST(LIST(ARGS)_CAR)
          ARG1=EVAL(CELL_CAR)
          %IF ARG1#NIL %START
             %WHILE CELL_CDR>=LIST BASE %CYCLE
                CELL==LIST(CELL_CDR);  ARG1=EVAL(CELL_CAR)
             %REPEAT
             %RESULT=ARG1

          %FINISH
          ARGS=LIST(ARGS)_CDR
       %REPEAT
       %RESULT=NIL
FUNC(10): ! AND
       %WHILE ARGS>=LIST BASE %CYCLE
          CELL==LIST(ARGS)
          %RESULT=NIL %UNLESS EVAL(CELL_CAR)#NIL
          ARGS=CELL_CDR
       %REPEAT
       %RESULT=T
FUNC(11): ! OR
       %WHILE ARGS>=LIST BASE %CYCLE
          CELL==LIST(ARGS)
          %RESULT=T %IF EVAL(CELL_CAR)#NIL
          ARGS=CELL_CDR
       %REPEAT
       %RESULT=NIL
FUNC(12): ! NULL
       %IF ARG1=NIL %THEN %RESULT=T %ELSE %RESULT=NIL
FUNC(13): ! ATOM
       %IF ATOM BASE<=ARG1<LIST BASE %THEN %RESULT=T %ELSE %RESULT=NIL
FUNC(14): ! NUMBERP
       %RESULT=NUMBERP(ARG1)
FUNC(56): ! EVENP
       %IF NUMBERP(ARG1)=T %AND ARG1&1=0 %THEN %RESULT=T 
       %RESULT=NIL
FUNC(55): ! ONEP
       ARG1=ARG1-1
FUNC(15): ! ZEROP
       %IF ARG1=ZERO BASE %THEN %RESULT=T %ELSE %RESULT=NIL
FUNC(16): ! EQ
       %IF ARG1=ARG2 %THEN %RESULT=T %ELSE %RESULT=NIL
FUNC(17): ! EQUAL
       %RESULT=EQUAL(ARG1,ARG2)
FUNC(18): ! LESSP
       %IF NUMBERP(ARG1)=T=NUMBERP(ARG2) %AND ARG1<ARG2 %C
          %THEN %RESULT=T %ELSE %RESULT=NIL
FUNC(19): ! GREATERP
       %IF NUMBERP(ARG1)=T=NUMBERP(ARG2) %AND ARG1>ARG2 %C
          %THEN %RESULT=T %ELSE %RESULT=NIL
FUNC(20): ! MEMB
       %WHILE ARG2>=LIST BASE %CYCLE
          CELL==LIST(ARG2)
          %RESULT=T %IF ARG1=CELL_CAR
          ARG2=CELL_CDR
       %REPEAT
       %RESULT=NIL
FUNC(21): ! MEMBER
       %WHILE ARG2>=LIST BASE %CYCLE
          CELL==LIST(ARG2)
          %RESULT=T %IF EQUAL(ARG1,CELL_CAR)=T
          ARG2=CELL_CDR
       %REPEAT
       %RESULT=NIL
FUNC(22): ! ASSOC
       %WHILE ARG2>=LIST BASE %CYCLE
          CELL==LIST(ARG2)
          %RESULT=CELL_CAR %IF EQUAL(ARG1,LIST(CELL_CAR)_CAR)=T
          ARG2=CELL_CDR
       %REPEAT
       %RESULT=NIL
FUNC(23): ! PLUS
       ARG1=0
       %WHILE ARGS>=LIST BASE %CYCLE
          CELL==LIST(ARGS)
          ARG2=CELL_CAR
          %IF NUMBERP(ARG2)=T %THEN ARG1=ARG1+ARG2 %ELSE %RESULT=ERROR3
          ARGS=CELL_CDR
       %REPEAT
       %RESULT=MNUMB(ARG1)
FUNC(24): ! DIFFERENCE
       %IF NUMBERP(ARG1)=T=NUMBERP(ARG2) %THEN %RESULT=MNUMB(ARG1-ARG2)
       %RESULT=ERROR3
FUNC(25): ! TIMES
       ARG1=1
       %WHILE ARGS>=LIST BASE %CYCLE
          CELL==LIST(ARGS);  ARG2=CELL_CAR
          %IF NUMBERP(ARG2)=T %THEN ARG1=ARG1*ARG2 %ELSE %RESULT=ERROR3
          ARGS=CELL_CDR
       %REPEAT
       %RESULT=MNUMB(ARG1)
FUNC(26): ! QUOTIENT
       %IF NUMBERP(ARG1)=T=NUMBERP(ARG2) %THEN %RESULT=MNUMB(ARG1//ARG2)
       %RESULT=ERROR3
FUNC(27): ! ADD1
       %IF NUMBERP(ARG1)=T %THEN %RESULT=MNUMB(ARG1+1) 
       %RESULT=ERROR3
FUNC(28): ! SUB1
       %IF NUMBERP(ARG1)=T %THEN %RESULT=MNUMB(ARG1-1) 
       %RESULT=ERROR3
FUNC(30): ! SELECTQ
       ARG1=EVAL(ARG1)
       ARGS=LIST(ARGS)_CDR
       %CYCLE
          ARG3=ARGS;  ARGS=LIST(ARG3)_CDR
          %EXIT %IF ARGS<LIST BASE
          CELL==LIST(LIST(ARG3)_CAR);  ARG2=CELL_CAR;  ARG3=CELL_CDR
          %WHILE ARG2>=LIST BASE %CYCLE
             CELL==LIST(ARG2)
             ->EXIT %IF CELL_CAR=ARG1
             ARG2=CELL_CDR
          %REPEAT
          %EXIT %IF ARG2=ARG1
       %REPEAT
EXIT:  %WHILE ARG3>=LIST BASE %CYCLE
          CELL==LIST(ARG3)
          ARG1=EVAL(CELL_CAR);  ARG3=CELL_CDR
       %REPEAT
       %RESULT=ARG1
FUNC(31): ! PUT
       %RESULT=PUT(ARG1,ARG3,ARG2)
FUNC(32): ! PROP
       %RESULT=ERROR3 %UNLESS NAME BASE<=ARG1<=NAME TAIL
       %RESULT=NAME(ARG1)_PROP
FUNC(33): ! REM
       %RESULT=ERROR3 %C
          %UNLESS NAME BASE<=ARG1<=NAME TAIL %C
             %AND NAME BASE<=ARG2<=NAME TAIL
       ATOM==NAME(ARG1)
       HOLE==ATOM_PROP
       %WHILE HOLE>=LIST BASE %CYCLE
          CELL==LIST(HOLE)
          %IF CELL_CAR=ARG2 %START
             CELL==LIST(CELL_CDR)
            ATOM_FORM=0 %IF CELL_CAR=ATOM_FUNC
             HOLE=CELL_CDR
             %RESULT=T
          %FINISH
          HOLE==LIST(CELL_CDR)_CDR
       %REPEAT
       %RESULT=NIL
FUNC(34): ! GET
       %RESULT=ERROR3 %C
          %UNLESS NAME BASE<=ARG1<=NAME TAIL %C
             %AND NAME BASE<=ARG2<=NAME TAIL
       ARGS=NAME(ARG1)_PROP
       %WHILE ARGS>=LIST BASE %CYCLE
          CELL==LIST(ARGS)
          %RESULT=LIST(CELL_CDR)_CAR %IF CELL_CAR=ARG2
          ARGS=LIST(CELL_CDR)_CDR
       %REPEAT
       %RESULT=NIL
FUNC(35): ! PUTPROP, DEFPROP
       %RESULT=PUT(ARG1,ARG2,ARG3)
FUNC(36): ! EVAL
       %RESULT=EVAL(ARG1)
FUNC(37): ! EVLIS
       %RESULT=EVLIST(ARGS)
FUNC(38): ! APPLY
       %RESULT=APPLY(ARG1,ARG2)
FUNC(39): ! ERRSET
       ARG1=CONS(EVAL(ARG1),NIL)
       ARG1=ERRVAL %AND RESET=0 %IF RESET=2
       %RESULT=ARG1
FUNC(40): ! RPLACA
       %RESULT=ERROR3 %IF ARG1<LIST BASE
       LIST(ARG1)_CAR=ARG2
       %RESULT=ARG2
FUNC(41): ! RPLACD
       %RESULT=ERROR3 %IF ARG1<LIST BASE
       LIST(ARG1)_CDR=ARG2
       %RESULT=ARG2
FUNC(42): ! NCONC
       %RESULT=ARG2 %IF ARG1=NIL
       %RESULT=ERROR3 %UNLESS ARG1>=LIST BASE
       ARGS=ARG1;                       ! REMEMBER A
       ARG1=LIST(ARG1)_CDR %WHILE LIST(ARG1)_CDR>=LIST BASE;    ! CDR DOWN A
       LIST(ARG1)_CDR=ARG2;  %RESULT=ARGS
FUNC(44): ! SETQ
       ARG2=EVAL(ARG2)
FUNC(45): ! SET
       %RESULT=ERROR3 %UNLESS NAME BASE<=ARG1<=NAME TAIL
       ARG3=NAME(ARG1)_BIND
       %IF ARG3<STACK TAIL %THEN %START
          STACK(ARG3)_BIND=ARG2
       %FINISH %ELSE %START
          GLOBAL=GLOBAL-1
          BIND(ARG1,GLOBAL,ARG2)
       %FINISH
       %RESULT=ARG2
FUNC(46): ! UNPACK
       %RESULT=ERROR3 %UNLESS ATOM BASE<=ARG1<LIST BASE
       LINE=PNAME(ARG1);  ARG2=NIL
       %CYCLE ARG1=ADDR(LINE)+LENGTH(LINE),-1,ADDR(LINE)+1
          SYMB=BYTE INTEGER(ARG1)
          %IF '0'<=SYMB<='9' %THEN SYMB=ZERO BASE+SYMB-'0' %C
             %ELSE SYMB=CHAR BASE+SYMB
          ARG2=CONS(SYMB,ARG2)
       %REPEAT
       %RESULT=ARG2
FUNC(47): ! PACKLIST
       %RESULT=MATOM(PACK(ARG1))
FUNC(48): ! PROG2
       %RESULT=ARG2
FUNC(49): ! PROGN
       %WHILE ARGS>=LIST BASE %CYCLE
          CELL==LIST(ARGS)
          ARG1=EVAL(CELL_CAR);  ARGS=CELL_CDR
       %REPEAT
       %RESULT=ARG1
FUNC(50): ! PROG
       %RESULT=PROG(ARG1,LIST(ARGS)_CDR)
FUNC(52): ! RETURN
       PROGFLAG=PROGFLAG!1
       %RESULT=ARG1
FUNC(53): ! GO
       PROGFLAG=PROGFLAG!2
       %RESULT=ARG1
FUNC(54): ! REVERSE
       %RESULT=REVERSE(ARG1)
!FUNC(55): ! TAKEN
!FUNC(56): ! TAKEN
FUNC(60): ! PROMPT
       %RESULT = ERROR3 %UNLESS NAME BASE<=ARG1<=NAME TAIL
       PMPT=PNAME(ARG1);  %RESULT=ARG1
FUNC(61): ! READCH
       %IF ATOM BASE<=ARG1<LIST BASE %THEN PROMPT(PNAME(ARG1)) %C
          %ELSE PROMPT(PMPT)
       READ CH(SYMB)
       %IF '0'<=SYMB<='9' %THEN %RESULT=MNUMB(SYMB-'0') %C
          %ELSE %RESULT=MATOM(TO STRING(SYMB))
FUNC(62): ! READ
       %RESULT=READ SEXP(PNAME(ARG1)) %IF ATOM BASE<=ARG1<LIST BASE
       %RESULT=READ SEXP(PMPT)
FUNC(63): ! PRINC
       PRINT(ARG1);  %RESULT=ARG1
FUNC(64): ! PRINT
       PRINT(ARG1);  PRINT CHARS("");  %RESULT=ARG1
FUNC(65): ! TERPRI
      PRINT CHARS("");  ARG1=NIL %UNLESS ARG1>=ATOM BASE;  %RESULT=ARG1
FUNC(66): ! INUNIT
       SELECT INPUT(ARG1) %AND %RESULT=MNUMB(ARG1) %C
          %IF NUMBERP(ARG1)=T
       %RESULT=ERROR3
FUNC(67): ! OUTUNIT
       SELECT OUTPUT(ARG1) %AND %RESULT=MNUMB(ARG1) %C
          %IF NUMBERP(ARG1)=T
       %RESULT=ERROR3
FUNC(68): ! INPUT
       %RESULT=ERROR3 %UNLESS NAME BASE<=ARG1<=NAME TAIL
       SELECT INPUT(0);  CLOSE STREAM(2)
       ARG2=INFILE;  INFILE=ARG1
       DEFINE("ST2,".NAME(INFILE)_PNAME)
       SELECT INPUT(2)
       %RESULT=ARG2
FUNC(69): ! OUTPUT
       %RESULT=ERROR3 %UNLESS NAME BASE<=ARG1<=NAME TAIL
       SELECT OUTPUT(0);  CLOSE STREAM(3)
       ARG2=OUTFILE;  OUTFILE=ARG1
       DEFINE("ST3,".NAME(OUTFILE)_PNAME)
       SELECT OUTPUT(3)
       %RESULT=ARG2
FUNC(70): ! TRACE
       %RESULT=ERROR3 %UNLESS NAME BASE<=ARG1<=NAME TAIL
       ATOM==NAME(ARG1)
       ATOM_FORM=ATOM_FORM!8
       %RESULT=ARG1
FUNC(71): ! UNTRACE
       %RESULT=ERROR3 %UNLESS NAME BASE<=ARG1<=NAME TAIL
       ATOM==NAME(ARG1)
       ATOM_FORM=ATOM_FORM&(\8)
       %RESULT=ARG1
FUNC(72): ! BREAK
       %RESULT=ERROR3 %UNLESS NAME BASE<=ARG1<=NAME TAIL
       NAME(ARG1)_FORM=NAME(ARG1)_FORM!16
       %RESULT=ARG1
FUNC(73): ! UNBREAK
       %RESULT=ERROR3 %UNLESS NAME BASE<=ARG1<=NAME TAIL
       NAME(ARG1)_FORM=NAME(ARG1)_FORM&(\16)
       %RESULT=ARG1
FUNC(74): ! $DELETE
       %RESULT=ERROR3 %UNLESS NAME BASE<=ARG1<=NAME TAIL
       ATOM==NAME(ARG1)
       ATOM_BIND=STACK TAIL;  ATOM_PROP=NIL;  ATOM_FUNC=0;  ATOM_FORM=0
       %RESULT=ARG1
FUNC(75): ! PEEK
          %IF NUMBERP(ARG1)=T %AND FRONT-ARG1>STACK BASE %C
             %THEN ARG1=FRONT-ARG1 %ELSE ARG1=STACK BASE
       %RESULT=STARS %IF FRONT=ARG1
       %CYCLE ARG1=FRONT-1,-1,ARG1
          FRAME==STACK(ARG1)
          LINE<-PNAME(FRAME_BACK&X'FFF')."         "
          BYTE INTEGER(ADDR(LINE))=9
          %IF FRAME_BACK&X'8000'#0 %C
             %THEN LINE=LINE."* " %ELSE LINE=LINE."= "
          XPRINT(LINE,FRAME_BIND)
       %REPEAT
       %RESULT=STARS
FUNC(77): ! GARB
       GARBAGE COLLECT
       %RESULT=MNUMB(LIST COUNT)
FUNC(78): ! RESET
       PMPT="READ:";  RESET=1;  ERRVAL=NIL;  %RESULT=PERCENT
FUNC(79): ! ERR
       ERRVAL=ARG1;  RESET=2;  %RESULT=PERCENT
FUNC(80): ! OBLIST
       ARG2=NIL
       %CYCLE ARG1=NAME HEAD-1,-1,NAME BASE
          ARG2=CONS(ARG1,ARG2)
       %REPEAT
       %RESULT=ARG2
FUNC(81): ! ALIST
       ARG2=NIL;  ARG3=NIL
       %IF FRONT>STACK BASE %START
          %CYCLE ARG1=STACK BASE,1,FRONT-1
             FRAME==STACK(ARG1)
             ARG2=CONS(CONS(FRAME_BACK,FRAME_BIND),ARG2) %C
                %IF NAME BASE<=FRAME_BACK<=NAME TAIL
          %REPEAT
       %FINISH
       %IF GLOBAL<STACK TAIL %START
          %CYCLE ARG1=STACK TAIL-1,-1,GLOBAL
             FRAME==STACK(ARG1)
             ARG3=CONS(CONS(FRAME_BACK,FRAME_BIND),ARG3)
          %REPEAT
       %FINISH
       %RESULT=CONS(ARG2,ARG3)
FUNC(82): ! ASCII
      %RESULT=ERROR3 %UNLESS NUMBERP(ARG1)=T %AND 0<=ARG1<=127
      %RESULT=MATOM(TOSTRING(ARG1))
%END
%INTEGERFN EVAL(%INTEGER FORM)
%RECORDNAME CELL(LISP CELL)
%RECORDNAME ATOM(ATOM CELL)
%RECORDNAME FRAME(STACK FRAME)
%INTEGER CAR, CDR
!
%INTEGERFN POP(%INTEGER INDEX)
       AUXP=AUXP-1
       %RESULT=INDEX
%END
!
%INTEGERFN BREAK(%INTEGER RESULT)
%SWITCH ERROR(0:4)
%INTEGER SEXP
       %RESULT=RESULT %IF RESULT>=ATOM BASE %OR RESET#0
       SELECT INPUT(0);  SELECT OUTPUT(0)
       XPRINT("EVAL ERROR:   ",FORM)
       ->ERROR(RESULT)
ERROR(1):
       PRINT STRING("    ATOM IS NOT BOUND TO A VALUE
");    ->LOOP
ERROR(2):
       XPRINT("    FUNCTION NOT DEFINED = ",CAR);  ->LOOP
ERROR(3):
       XPRINT("    ARGUMENT NOT OF THE CORRECT FORM IN ",CDR);  ->LOOP
ERROR(4):
       PRINT STRING("    NO TRUE LEFT HAND SIDE IN COND
")
ERROR(0):
LOOP:  LOOP("   %:",PERCENT)
       %RESULT=PERCENT %IF RESET#0
       SEXP=READ SEXP("EVAL:");  SEXP=FORM %IF SEXP=PERCENT
       %RESULT=EVAL(SEXP)
%END
!
       %RESULT=PERCENT %IF RESET#0
       FRAME==STACK(FRONT)
       FRAME_BACK<-EVLN; FRAME_BIND=FORM
       %IF FORM>=LIST BASE %THEN %START;          ! FORM IS A LIST
          CELL==LIST(FORM)
          CAR=CELL_CAR;  CDR=CELL_CDR
          %IF NAME BASE<=CAR<=NAME TAIL %THEN %START
             ATOM==NAME(CAR)
             CDR=EVLIST(CDR) %IF ATOM_FORM&4#0;                ! EXPR/SUBR
             FORM=PUSH(FORM);  FRAME_BACK<-CAR!X'8000';  FRAME_BIND=CDR
             %IF ATOM_FORM&16#0 %THEN %START
                 SELECT INPUT(0);  SELECT OUTPUT(0)
                 XPRINT("LISP BREAK:   ",FORM)
                FRONT=FRONT+1;  LOOP("   %:",PERCENT);  FRONT=FRONT-1
             %FINISH
             %RESULT=POP(BREAK(TRACE("<--- ".PNAME(CAR)." ", %C
                FUNC(ATOM,TRACE("---> ".PNAME(CAR)." ",CDR))))) %C
                   %IF ATOM_FORM&8#0
             %RESULT=POP(BREAK(FUNC(ATOM,CDR)));         ! FORM OF APPLY
          %FINISH
          CDR=EVLIST(CDR)
          %RESULT=BREAK(APPLY(CAR,CDR));         ! FUNCTION IS A LIST
       %FINISH
       %IF NAME BASE<=FORM<=NAME TAIL %THEN %START
          ATOM==NAME(FORM)
          %RESULT=ATOM_FUNC %IF ATOM_FORM&7=3
          %RESULT=BREAK(STACK(ATOM_BIND)_BIND);   ! RETURN BINDING
       %FINISH
       %RESULT=FORM;                              ! CONSTANT
%END
%INTEGERFN EVLIST(%INTEGER ARGS)
%RECORDNAME CELL(LISP CELL)
%INTEGER TEMP
       %RESULT=ARGS %UNLESS ARGS>=LIST BASE
       CELL==LIST(ARGS)
       FRONT=FRONT+1
       TEMP=PCONS(PUSH(EVAL(CELL_CAR)),EVLIST(CELL_CDR))
       FRONT=FRONT-1
       %RESULT=TEMP
%END
%INTEGERFN APPLY(%INTEGER FN, ARGS)
%RECORDNAME CELL(LISP CELL)
%INTEGER CAR, CADR, CADDR
       %IF FN>=LIST BASE %THEN %START
          CELL==LIST(FN);  CAR=CELL_CAR
          CELL==LIST(CELL_CDR);  CADR=CELL_CAR
          CELL==LIST(CELL_CDR);  CADDR=CELL_CAR
          %IF CAR=LABEL %THEN %START
             BIND(CADR,FRONT,CADDR)
             FRONT=FRONT+1
             %RESULT=APPLY(CADDR,ARGS) 
          %FINISH
          %IF CAR=LAMBDA %THEN %START
             BINDLIST(CADR,ARGS)
             BIND(CADR,FRONT,ARGS) %AND FRONT=FRONT+1 %IF CADR#NIL
             %RESULT=UNBIND(EVAL(CADDR))
          %FINISH
          %RESULT=APPLY(EVAL(FN),ARGS)
       %FINISH
       %IF NAME BASE<=FN<=NAME TAIL %THEN %START
             %RESULT=FUNC(NAME(FN),ARGS)
       %FINISH
       %RESULT=ERROR
%END
%ROUTINE LOOP(%STRING(15) PMPT, %INTEGER TERM)
%INTEGER VALUE
       %CYCLE
          RESET=0
          VALUE=EVAL(READ SEXP(PMPT))
          %RETURN %IF VALUE=TERM
          PRINT(VALUE) %AND PRINT CHARS("") %UNLESS RESET#0
       %REPEAT
%END
       LOOP("LISP:",EXIT)
%END
%ENDOFFILE