%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=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 00 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 %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=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 %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) %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_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(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 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=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