%begin %EXTERNALROUTINESPEC PROMPT(%STRING(15) S) !*-%EXTERNALROUTINE LISP INTP(%INTEGER SPACE, INITMODE) %const %integer initmode = 1 ! ! ***** 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=16_FF00, LONG TAIL=511 %CONSTINTEGER NAME BASE=512, NAME MASK=16_FE00, NAME TAIL=2047 %CONSTINTEGER STACK BASE=1024, STACK MASK=16_FB00, STACK TAIL=1535 %CONSTINTEGER SHORT BASE=2048, SHORT MASK=16_F800, SHORT TAIL=4095 %CONSTINTEGER LIST BASE=4096, LIST TAIL=16_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) !*- %RECORD (lispinfo) %NAME LISPFILE !*- LISPFILE==RECORD(SPACE) !*- ! !*- %IF INITMODE>0 %START !*- LISPFILE_CONST=16_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=16_4000 !*- LISPFILE_NAME HEAD=NAME BASE !*- LISPFILE_STACK=16_A000 !*- LISPFILE_GLOBAL=STACK TAIL !*- LISPFILE_LIST=16_10000 !*- %FINISH !*- %INTEGERARRAYNAME CONST !*- %INTEGERARRAYFORMAT CONSTF(LONG BASE:LONG TAIL) !*- CONST==ARRAY(SPACE+LISPFILE_CONST,CONSTF) %integer %array const (long base:long tail) %integer long head = long base !*- %INTEGERNAME LONG HEAD; LONG HEAD==LISPFILE_LONG HEAD !*- %BYTEINTEGERARRAYNAME PNAME SPACE !*- %BYTEINTEGERARRAYFORMAT PNAMEF(0:8191) !*- PNAME SPACE==ARRAY(SPACE+LISPFILE_PNAME SPACE,PNAMEF) %byte %integer %array pname space (0:8191) %integer pname base; pname base = addr(pname space(0)) %integer pname tail; pname tail=addr(pname space(8191)) %integer pname head; pname head=pname base !*- %INTEGERNAME PNAME HEAD; PNAME HEAD==LISPFILE_PNAME HEAD !*- %INTEGER PNAME TAIL; PNAME TAIL=ADDR(PNAME SPACE(8191)) %RECORDFORMAT ATOM CELL(%SHORT %INTEGER BIND, PROP, FUNC, %C %BYTEINTEGER FORM, %STRING(*) %NAME PNAME) !*- %RECORD (atom cell) %ARRAY %NAME NAME !*- %RECORDARRAYFORMAT NAMEF(NAME BASE:NAME TAIL) (ATOM CELL) !*- NAME==ARRAY(SPACE+LISPFILE_NAME,NAMEF) %record (atom cell) %array name (name base:name tail) %integer name head = name base, global = stack tail !*- %INTEGERNAME NAME HEAD; NAME HEAD==LISPFILE_NAME HEAD !*- %INTEGERNAME GLOBAL; GLOBAL==LISPFILE_GLOBAL !*- ! FIXUP 'PNAME' ADDRESSES !*- %RECORD (atom cell) %NAME ATOM !*- %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 !*- %for I=NAME BASE,1,NAME HEAD-1 %cycle !*- ATOM==NAME(I) !*- ATOM_PNAME==STRING(ADDR(ATOM_PNAME)+FIXUP) !*- ATOM_BIND=STACK TAIL %UNLESS GLOBAL<=ATOM_BIND<=STACK TAIL !*- %REPEAT !*- %FINISH !*- %for I=CHAR BASE,1,NAME TAIL %cycle !*- ATOM==NAME(I) !*- ATOM_BIND=STACK TAIL %UNLESS GLOBAL<=ATOM_BIND<=STACK TAIL !*- %REPEAT %RECORDFORMAT LISP CELL(%SHORT %INTEGER CAR, CDR) !*- %RECORD (lisp cell) %ARRAY %NAME LIST !*- %RECORDARRAYFORMAT LISTF(0:LIST TAIL) (LISP CELL) !*- LIST==ARRAY(SPACE+LISPFILE_LIST,LISTF) %record (lisp cell) %array list (0:list tail) %integer list head, list count !*- %INTEGERNAME LIST HEAD; LIST HEAD==LISPFILE_LIST HEAD !*- %INTEGERNAME LIST COUNT; LIST COUNT==LISPFILE_LIST COUNT %RECORDFORMAT STACK FRAME(%SHORT %INTEGER BACK, BIND, LINK) !*- %RECORD (stack frame) %ARRAY %NAME STACK !*- %RECORDARRAYFORMAT STACKF(STACK BASE:STACK TAIL) (STACK FRAME) !*- STACK==ARRAY(SPACE+LISPFILE_STACK,STACKF) %record (stack frame) %array stack (stack base:stack tail) open input (1,"dra0:[iay.utils]initfile.txt") ! ! ***** INTERPRETER WORKING STORAGE ***** ! %INTEGER LOCAL; LOCAL=STACK BASE %INTEGER FRONT; FRONT=LOCAL %integer hole head = 0, hole tail = 0 %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 ***** ! %OWNSTRING(5) ERRORS="ERROR" %CONSTINTEGER ERROR=0, ERROR1=1, ERROR2=2, ERROR3=3, ERROR4=4, error5=5 %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=16_820A, funarg=523, STARS=524 %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 %RECORD (atom cell) %NAME ATOM %RECORD (lisp cell) %NAME CELL %RECORD (stack frame) %NAME FRAME %INTEGER I %for I=LONG HEAD,1,LONG TAIL-1 %cycle CONST(I)=I+1 %REPEAT CONST(LONG TAIL)=0 %for I=NAME BASE,1,NAME TAIL %cycle 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 %for I=NIL,1,STARS %cycle SEXP=RATOM; ! READ IN KNOWN ATOMS %REPEAT %for I=0,1,LIST BASE-1 %cycle CELL==LIST(I) CELL_CAR=ERROR3; CELL_CDR=ERROR3 %REPEAT LIST HEAD=LIST BASE; LIST COUNT=LIST TAIL-LIST HEAD %for I=LIST BASE,1,LIST TAIL-1 %cycle 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 %RECORD (lisp cell) %NAME CELL %INTEGER I ! %ROUTINE MARK(%INTEGER INDEX) %SHORT %INTEGERNAME CAR %WHILE INDEX>=LIST BASE %AND LIST(INDEX)_CAR&16_8000=0 %CYCLE CAR==LIST(INDEX)_CAR; INDEX=LIST(INDEX)_CDR CAR<-CAR!16_8000 MARK(CAR&16_7FFF) %IF CAR&16_7FFF>=LIST BASE %REPEAT %END %for I=NAME BASE,1,NAME HEAD-1 %cycle MARK(NAME(I)_PROP) %REPEAT %for I=CHAR BASE,1,NAME TAIL %cycle MARK(NAME(I)_PROP) %REPEAT %for I=STACK BASE,1,FRONT %cycle MARK(STACK(I)_BIND) %REPEAT %for I=GLOBAL,1,STACK TAIL %cycle MARK(STACK(I)_BIND) %REPEAT %IF AUXP>0 %START %for I=0,1,AUXP-1 %cycle MARK(AUXS(I)) %REPEAT %FINISH LIST COUNT=0; LIST HEAD=0 %for I=LIST BASE,1,LIST TAIL %cycle CELL==LIST(I) %IF CELL_CAR&16_8000#0 %THEN CELL_CAR<-CELL_CAR&16_7FFF %ELSE %START LIST COUNT=LIST COUNT+1 CELL_CAR=LIST HEAD; LIST HEAD=I %FINISH %REPEAT %END %INTEGERFN MATOM(%STRING(72) PNAME) %RECORD (atom cell) %NAME ATOM %INTEGER INDEX %RESULT=CHAR BASE+BYTE INTEGER(ADDR(PNAME)+1)&16_7F %C %IF LENGTH(PNAME)=1 %IF NAME HEAD>NAME BASE %START %for INDEX=NAME BASE,1,NAME HEAD-1 %cycle %RESULT=INDEX %IF PNAME=NAME(INDEX)_PNAME %REPEAT %FINISH %UNLESS NAME HEAD=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="" %cycle; ! PRINT ALL SIGNIFICANT DIGITS REM=VALUE; VALUE=VALUE//10 REM=REM-10*VALUE; ! RIGHT HAND DIGIT PNAME=TO STRING(REM+'0').PNAME %repeat %until value = 0 %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 00 R FLAG=1 %END %ROUTINE PRINT SEXP(%INTEGER INDEX) %RECORD (lisp cell) %NAME 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 %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) %RECORD (atom cell) %NAME ATOM %RECORD (stack frame) %NAME FRAME %UNLESS NAME BASE<=SYMB=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) %RECORD (lisp cell) %NAME CELL, ARGC 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) %RECORD (stack frame) %NAME FRAME %WHILE FRONT>LOCAL %CYCLE FRONT=FRONT-1 FRAME==STACK(FRONT) NAME(FRAME_BACK)_BIND=FRAME_LINK %IF FRAME_BACK&16_8000=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) %RECORD (lisp cell) %NAME CELL %INTEGER INDEX %IF LIST COUNT<=100 %OR LIST HEAD=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 %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) %RECORD (lisp cell) %NAME 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(%RECORD (atom cell) %NAME ATOM, %INTEGER ARGS) %RECORD (lisp cell) %NAME CELL %RECORD (stack frame) %NAME FRAME %SWITCH TYPE(0:3), FUNC(0:90) %STRING(72) LINE %INTEGER ARG1, ARG2, ARG3, SYMB, save1, save2 %SHORT %INTEGERNAME HOLE ->TYPE(ATOM_FORM&3) TYPE(3): ! APVAL TYPE(0): ! NO FUNCTION DEFENITION ON PROPERTY LIST %RESULT=ERROR2 %UNLESS ATOM_BINDFUNC(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<=ARG1ARG2 %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 %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 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=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(57): ! function %result=cons(funarg,cons(arg1,cons(mnumb(front),nil))) func(58): ! funarg %result=error3 %unless numberp(arg2) = t save1=hole tail; save2=hole head hole tail=arg2; hole head=front arg1=eval(arg1) hole tail=save1; hole head=save2 %result=arg1 FUNC(60): ! PROMPT %RESULT = ERROR3 %UNLESS NAME BASE<=ARG1<=NAME TAIL PMPT=PNAME(ARG1); %RESULT=ARG1 FUNC(61): ! READCH %IF ATOM BASE<=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 close input; SELECT INPUT(0) ARG2=INFILE; INFILE=ARG1 open input (2,name(infile)_pname) SELECT INPUT(2) %RESULT=ARG2 FUNC(69): ! OUTPUT %RESULT=ERROR3 %UNLESS NAME BASE<=ARG1<=NAME TAIL close output; SELECT OUTPUT(0) ARG2=OUTFILE; OUTFILE=ARG1 open output (3,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 %for ARG1=FRONT-1,-1,ARG1 %cycle FRAME==STACK(ARG1) LINE<-PNAME(FRAME_BACK&16_FFF)." " BYTE INTEGER(ADDR(LINE))=9 %IF FRAME_BACK&16_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 %for ARG1=NAME HEAD-1,-1,NAME BASE %cycle ARG2=CONS(ARG1,ARG2) %REPEAT %RESULT=ARG2 FUNC(81): ! ALIST ARG2=NIL; ARG3=NIL %IF FRONT>STACK BASE %START %for ARG1=STACK BASE,1,FRONT-1 %cycle FRAME==STACK(ARG1) ARG2=CONS(CONS(FRAME_BACK,FRAME_BIND),ARG2) %C %IF NAME BASE<=FRAME_BACK<=NAME TAIL %REPEAT %FINISH %IF GLOBAL=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 "); ->cont ERROR(2): XPRINT(" FUNCTION NOT DEFINED = ",CAR); ->cont ERROR(3): XPRINT(" ARGUMENT NOT OF THE CORRECT FORM IN ",CDR); ->cont ERROR(4): PRINT STRING(" NO TRUE LEFT HAND SIDE IN COND "); ->cont error(5): print string(" Stack Overflow - (reset) invoked "); reset=1; %result=percent ERROR(0): cont: 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 %result=break(error5) %unless front+1 < global 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) FRONT=FRONT+1 %AND CDR=EVLIST(CDR) %AND FRONT=FRONT-1 %C %IF ATOM_FORM&4#0; ! EXPR/SUBR FORM=PUSH(FORM); FRAME_BACK<-CAR!16_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 FRONT=FRONT+1; CDR=EVLIST(CDR); FRONT=FRONT-1 %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 bind=atom_bind bind=stack(bind)_link %while hole tail <= bind <= hole head %RESULT=BREAK(STACK(bind)_BIND); ! RETURN BINDING %FINISH %RESULT=FORM; ! CONSTANT %END %INTEGERFN EVLIST(%INTEGER ARGS) %RECORD (lisp cell) %NAME CELL %RESULT=ARGS %UNLESS ARGS>=LIST BASE CELL==LIST(ARGS) %RESULT=PCONS(PUSH(EVAL(CELL_CAR)),EVLIST(CELL_CDR)) %END %INTEGERFN APPLY(%INTEGER FN, ARGS) %RECORD (lisp cell) %NAME 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 %of %program