LISP=5000 / / These defines make the binary output of the / assembler match the original binary tape. / LISTIN=3 PROG=7 EVER2=40 EVEVAL=41 FREE=42 EVFREE=42 EVBEG=43 EVLEN=44 EVOUT=45 EVIN=46 PUSH=47 POP=50 EV=51 TEST=52 CVBIN=53 CVDEC=54 CNLIST=55 LILIST=55 EQLIST=55 EVTABL=55 ACLST1=55 ACLST2=56 SHLIST=55 EVAL=JMS I EVEVAL HLT=JMS I EVER2 MQA=7501 MQL=7421 MUL=7405 DIV=7407 SHL=7413 SL1=7541 LSR=7417 ICF=6342 EFC=6324 *LISP-0200 EJECT/INIT ROUTINE 100-120 /THIS ROUTINE IS CALLED AT THE BEGINNING OF PROGRAM EXECUTION. /IT INITIALIZES THE LIST STORAGE, ETC. AINIT, 0 CLA TAD I AINIT /SET PARAMETERS DCA I AIPNT ISZ AINIT ISZ AIPNT ISZ AICNTR JMP .-5 STA TAD I AINIT /GET PD LIST SIZE ISZ AINIT TAD FAINIT DCA I AIPTR TAD I AIPTR CIA DCA I AIMIN STA TAD I AIMIN DCA I AIMIN2 STA /SET SUBLOC TAD AINIT DCA I AILOC TAD I AINIT /SKIP TO END SNA JMP .+5 CIA DCA I AINIT ISZ AINIT JMP .-6 DCA I AIWRK /CLEAR TABLE OF WORKING LOCATIONS ISZ AIWRK ISZ AIREF JMP .-3 TAD AIEVAL /ADJUST VALUES DCA EVEVAL TAD AIERR DCA EVER2 TAD AIPUSH /SET MACH LINKS DCA PUSH TAD AIPOP DCA POP TAD AIEV DCA EV TAD AITEST DCA TEST TAD AIDECB DCA CVBIN TAD AIBIND DCA CVDEC TAD EVBEG /IF PD LIST OVERLAPS STORAGE AREA, ADJUST CIA / STORAGE SIZE. TAD EVLEN TAD I AIPTR IAC SMA JMP .+4 CIA TAD EVLEN DCA EVLEN CLA TAD EVLEN /SET ABS VAL TO NEXT LOWEST EVEN VAL IF NECESSARY. CIA RAR CLL RAL CIA DCA EVLEN TAD EVBEG /SET VAL TO NEXT EVEN LOCATION IF NECESSARY. RAR SZL IAC CLL RAL DCA EVBEG JMP I AINIT AIEVAL, LEVAL AICNTR, -4 AIERR, ERR AIPNT, EVBEG AIWRK, WORK AIREF, WORK-ENDWRK AIPUSH, LPUSH AIPOP, LPOP AIEV, EVAL2 AITEST, ATEST AIDECB, DECBIN AIBIND, BINDEC FAINIT, ENDINT AILOC, EVLOC AIPTR, STPTR AIMIN, STMIN AIMIN2,COMIN PAGE ENDINT=. /Commented out by VRS: *.-1 EJECT PAGE/100-140 POP1=POP PUSH1=PUSH RET1, EVRET EV1=EV TEST1=TEST /LISTIN2 ROUTINE /INPUTS A LIST AND RETURNS A REFERENCE TO IT. ALSTIN, JMS I LITEST /REALLY? JMP I LIRET /NO JMS INCHR /READ A CHAR INTO INBUFF JMS INLIST /GET A LIST OR AN ATOM JMP I LIRET /RETURN LIRET=RET1 LITEST=TEST1 INLIST, 0 JMS I INPUSH INLIST JMS I INPUSH LILIST JMS I INPUSH LILAST TAD INBUFF TAD INMCL /-')' SNA HLT /')' CANNOT OCCUR HERE TAD INDIF /')'-'(' SZA CLA JMP INAT /READ IN AN ATOM TAD LIALST /A(LILIST) DCA LILAST / INTO LILAST INBACK, JMS INCHR /READ A CHAR INTO INBUFF DCA I LILAST /NIL INTO L(LILAST) TAD INBUFF TAD INMCL /-')' SNA CLA JMP INRET /RETURN JMS I INEXTR /EXTRACT DCA INCELL / INTO CELL TAD INCELL /A(CELL+1) INTO L(LAST) IAC DCA I LILAST TAD INCELL /A(CELL) INTO LAST DCA LILAST JMS INLIST /GET A LIST DCA I LILAST / INTO L(INLAST) ISZ LILAST /INLAST=INLAST+1 JMP INBACK INAT, JMS I INAM /GET AN ATOM INTO LILIST INRET, TAD LILIST JMS I INPOP LILAST JMS I INPOP LILIST JMS I INPOP INLIST JMP I INLIST INCHR, 0 /GET A CHARACTER TAD INBUF2 /SHIFT BUFFER DCA INBUFF DCA INBUF2 TAD INBUFF /BUFFER EMPTY? SZA CLA JMP INARND JMS I EVIN DCA INBUFF TAD INBUFF TAD INMQUT /-"'" SZA CLA JMP .+4 JMS I EVIN TAD IN4000 DCA INBUFF TAD INBUFF JMS I INQCTL /CONTROL? JMP INARND /NO TAD INBUFF /YES: SET BUFF2 TO BUFF DCA INBUF2 TAD INSP /SET BUFF TO SPACE DCA INBUFF INARND, TAD INBUFF /PRES CHAR = ' '? TAD INMSP /-' ' SZA CLA JMP INZIP /NO TAD INLCHR/YES: LAST CHAR = CONTROL ( '(',')',' ' )? JMS I INQCTL /CONTROL? JMP INZIP /NO JMP INCHR+1 INZIP, TAD INBUFF /LAST CHAR = PRES CHAR DCA INLCHR JMP I INCHR LILAST, 0 INAM, INATOM INQCTL, INCTLQ INBUFF, 0 INBUF2, 0 INMCL, -51 INMSP, -40 INSP, 40 INMQUT, -47 INDIF, 51-50 INDIF2, 50-40 INEXTR, XTRACT INCELL, 0 INLCHR, 40 LIALST, LILIST IN4000, 4000 INPUSH=PUSH1 INPOP=POP1 /NOT ROUTINE /IF ARG VAL=0 THEN RETURNS 1; ELSE RETURNS 0. ANOT, JMS I NTEV /GET AN ARG JMS I NTTEST /REALLY? JMP I NTRET /NO SNA CLA /VALUE T? IAC /NO: RETURN T JMP I NTRET /ELSE RETURN F NTEV=EV NTTEST=TEST NTRET=RET1 /ENTRY ROUTINE /USED IN CONJUNCTION WITH QUOTE. ENTERS THE ROUTINE INDICATED / BY THE CONTENTS OF THE CONTENTS OF THE CELL FOLLOWING / THE CALL ON 'ENTRY'. AENTRY, JMS I EV DCA ENSAV ISZ I ENEVAL TAD I ENEVAL DCA ENLOC TAD ENSAV DCA I ENLOC STA TAD I ENEVAL DCA I ENEVAL JMS I EV JMP I ENRET ENEVAL, LEVAL ENLOC, 0 ENSAV, 0 ENRET=RET1 PAGE /Added by VRS EJECT PAGE/100-160 EV2=EV PUSH2=PUSH POP2=POP /EVAL ROUTINE /CONTROLLING SUBROUTINE WHICH GOVERNS THE LIST PROCESSING / FUNCTIONS LEVAL,0 STA TAD LEVAL DCA LEVAL JMS EVAL2 ISZ LEVAL JMP I LEVAL /EVAL2 ROUTINE /ACTUALLY MAIN ROUTINE. THIS DOES THE ACTUAL CALLING, ETC.. EVAL2,0 JMS I EVPUSH EVAL2 ISZ LEVAL JMS EVPRIM JMP EVSTAN TAD I LEVAL TAD EVTAB DCA EVTMP TAD I EVTMP DCA EVTMP JMP I EVTMP EVRET, JMS I EVPOP EVAL2 JMP I EVAL2 EVERR, TAD LEVAL HLT JMP EVRET EVSTAN, JMS EVFUN JMP EVON TAD LEVAL DCA EVSAVE TAD I LEVAL DCA LEVAL JMP I EVENT /ENTER: GETS ARGUMENTS, PUSHES ARG LOCS. EVR1, JMS I EVPUSH /PUSH RETURN-TO-MAIN EVSAVE JMS I EVTEST /ARE WE REALLY EXECUTING? SKP /NO JMS EVAL2 /EVALUATE THE FUNCTION JMS I EVPOP /POP RETURN-TO-MAIN LEVAL DCA EVPTR /SAVE THE VALUE JMP I EVEXIT /EXIT: POPS ARG LOCS EVR2, TAD EVPTR JMP EVRET EVON, TAD I LEVAL DCA EVTMP TAD I EVTMP JMP EVRET EVAND1, 7740 EVTAB, TAB EVSAVE, 0 EVLOC, 0/SET BY INIT EVENT, AENTER EVEXIT, AEXIT EVPTR,0 EVTMP, 0 EVPUSH=PUSH2 EVPOP=POP2 EVTEST=TEST /SKIP-IF-FUNCTION SUBROUTINE EVFUN, 0 TAD EVLOC DCA EVPTR ISZ EVPTR TAD I EVPTR SNA JMP I EVFUN TAD I LEVAL SZA CLA JMP .-6 ISZ EVFUN JMP I EVFUN /SKIP-IF-PRIMITIVE SUBROUTINE EVPRIM, 0 TAD I LEVAL AND EVAND1 SZA CLA JMP I EVPRIM ISZ EVPRIM JMP I EVPRIM /TL ROUTINE /RETURNS THE RIGHT POINTER OF THE CELL POINTED TO BY THE ARG ATL, JMS I TLEV /GET ARG JMS I TLTEST JMP EVRET RAR SNL CLA /RETURN 0 IF IT POINTS TO AN ATOM CLL RAL SNA JMP EVRET IAC DCA TLTMP TAD I TLTMP RAR CLL CML RAL JMP EVRET TLTMP, 0 TLTEST=EVTEST TLEV=EV2 /ATOM ROUTINE /RETURNS +1 IF THE ARGUMENT POINTS TO AN ATOM OR IS NULL. /RETURNS 0 OTHERWISE. AATOM, JMS I AAEV /GET ARG JMS I AATEST JMP EVRET CLL RAR /SEE IF NULL SNA CLL /YES CML CLA RAL JMP EVRET AATEST=EVTEST AAEV=EV2 /GO ROUTINE /TRANSFERS CONTROL TO SPECIFIED LOCATION. AGO, ISZ LEVAL/INCREMENT POINTER JMS EVFUN/FUNCTION? SKP /NO JMP .+3/YES JMS EVPRIM/PRIMITIVE? JMP .+7/NO STA /YES TAD LEVAL DCA LEVAL JMS EVAL2 DCA I GOVAL JMP AGO JMS I TEST/REALLY? JMP EVRET/NO STA /YES;RESET POINTER TAD I LEVAL DCA LEVAL JMP EVRET GOVAL, BGVAL /ENTER PATCH AEPAT, JMS EVPRIM /PRIMITIVE? SKP /NO JMP I AEGO /YES JMS EVFUN /FUNCTION? TAD I LEVAL /NO JMP I AEGO AEGO, AEPATB PAGE /Added by VRS EJECT PAGE/100-180 EV3=EV POP3=POP PUSH3=PUSH RET3, EVRET /CONS ROUTINE /FORMS A NEW CELL WHOSE DOWN POINTER POINTS TO THE FIRST /PARAMETER, AND WHOSE RIGHT POINTER POINTS TO THE SECOND /PARAMETER. THE SECOND PARAMETER MUST BE ZERO OR A LIST /REFERENCE (1 IN BIT 11). ACONS, JMS I ACPUSH /RECURSIVE SELF-PROTECTION ACLST1 JMS I ACEV /GET ARGUMENT DCA ACLST1 JMS I ACEV /GET 2ND ARG DCA ACLST2 /ARGUMENT PROTECTION JMS I ACTEST JMP ACEXIT JMS I ACXTR DCA ACVAL TAD ACLST1 DCA I ACVAL ISZ ACVAL TAD ACLST2 SNA JMP ACOK RAR SNL HLT /INVALID ARGUMENT RAL ACOK, DCA I ACVAL DCA ACLST2 TAD ACVAL ACEXIT, JMS I ACPOP ACLST1 JMP I ACRET ACVAL, 0 ACRET=RET3 ACTMP, 0 ACXTR, XTRACT ACTEST, ATEST ACPUSH=PUSH3 ACPOP=POP3 ACEV=EV3 /INATOM ROUTINE INATOM, 0 TAD LILLST /SET BLD TO A(LILIST) DCA INBLD INEXEL, DCA I INBLD /SET L(BLD) TO NIL JMS INCTL /SKIP IF BUFF NOT ' ', ERROR EXIT IF '(' OR ')' JMP INOUT /RETURN MQL /SET MQ TAD I INLBUF SHL 5 DCA INSAVE /STORE SHIFTED CHAR IN INSAVE JMS I INCHRL /GET ANOTHER JMS INCTL /CONTROL? JMP INAR2 /YES: SKIP NEXT PART TAD I INLBUF /GET CHAR AND IN77 /MASK OFF TAD INSAVE /ADD INSAVE DCA INSAVE /STORE JMS I INCHRL /GET ANOTHER INAR2, JMS XTRACT /EXTRACT DCA INCEL2 / INTO INCELL TAD INCEL2 /INCELL TO L(INBLD) DCA I INBLD TAD INCEL2 /INCELL+1 INTO INBLD IAC DCA INBLD TAD INSAVE /CHARS INTO L(CELL) DCA I INCEL2 JMP INEXEL INOUT, TAD I LILIST /IS IT 0? TAD INM0 SNA CLA DCA LILIST/YES: RETURN NIL JMP I INATOM INCTL, 0 TAD I INLBUF TAD I INLMCL /-')' SNA HLT TAD I INLDIF /')'-'(' SNA HLT TAD I INLDF2 /'('-' ' SZA CLA ISZ INCTL JMP I INCTL INCTLQ, 0 /SKIP IF CONTROL TAD I INLMCL /-')' SNA ISZ INCTLQ TAD I INLDIF /')'-'(' SNA ISZ INCTLQ TAD I INLDF2 /'('-' ' SNA CLA ISZ INCTLQ JMP I INCTLQ LILLST, LILIST INBLD, 0 INSAVE, 0 IN77, 77 INM0, -6000 INLMCL, INMCL INLDIF, INDIF INLDF2, INDIF2 INLBUF, INBUFF INCHRL, INCHR INCEL2, 0 /XTRACT ROUTINE /EXTRACTS A CELL FROM THE FREE LIST AND RETURNS THE ADDRESS OF /THIS CELL. HD & TL OF THE CELL ARE SET TO NIL. XTRACT, 0 TAD FREE SNA JMP XTARND DCA XTVAL TAD I FREE DCA FREE DCA I XTVAL/SET TL(CELL) TO NIL. (HD(CELL) ALREADY SET TO NIL) STA TAD XTVAL JMP I XTRACT XTARND, JMS I XTCOL JMP XTRACT+1 XTVAL, 0 XTCOL, COLECT /WORK LOCATIONS FOR ENTER/EXIT WORK, 0 PAGE *.-1 ENDWRK=.+1 PAGE /Added by VRS EJECT PAGE/100-200 POP4=POP PUSH4=PUSH /GARBAGE COLLECTOR /CALLED WHEN FREE STRING EXHAUSTED COLN, 0/NUMBER OF COLLECTIONS PERFORMED. COLECT, 0 ISZ COLN /INCREMENT NUMBER OF COLLECTIONS NOP /PASS 1--SET 11TH BIT OF POINTERS TO 1 TAD EVLEN DCA COCNT TAD EVBEG IAC DCA CONDX COLADD, TAD I CONDX RAR CLL CML RAL DCA I CONDX ISZ CONDX ISZ CONDX ISZ COCNT ISZ COCNT JMP COLADD /PASS II--UNMARK ALL CELLS IN USE TAD CODTAB DCA COAUTO COLOOP, TAD I COAUTO ISZ COAUTO CMA SNA JMP I COLLON /CHECK THE PUSH DOWN LIST CMA DCA .+2 JMS COMAIN 0 JMP COLOOP /PASS III--COLLECT ALL CELLS NOT IN USE COLNXT, TAD EVLEN DCA COCNT TAD EVBEG IAC DCA CONDX COLZOT, TAD I CONDX RAR SNL CLA JMP COLEND /IN USE--DO NOT FREE TAD EVFREE SZA CLA JMP COLARND /NOT FIRST PASS TAD CONDX /FIRST PASS DCA EVFREE TAD EVFREE DCA COLAST JMP COLEND COLARND, TAD CONDX DCA I COLAST TAD I COLAST DCA COLAST STA /SET HD OF COLLECTED CELL TO NIL. TAD CONDX DCA COI DCA I COI COLEND, ISZ CONDX ISZ CONDX ISZ COCNT ISZ COCNT JMP COLZOT DCA I COLAST TAD EVFREE SNA CLA HLT /NO MORE STORAGE AREA AVAILABLE--ENLARGE AREA JMP I COLECT /COMAIN ROUTINE--RECURSIVE /UNMARK A LIST OR AN ATOM COMAIN,0 /ENTER LINKAGES JMS I COPUSH /SAVE PARAMETER COI TAD I COMAIN DCA COI ISZ COMAIN JMS I COPUSH /SAVE RETURN ADDRESSES COMAIN TAD COI /SEE IF ARGUMENT IS IN RANGE JMS I COGOOD JMP CORET /NOT IN RANGE; EXIT COLAHA, TAD COI /CHECK IF NULL CLL RAR SNA JMP CORET SNL /CHECK IF ATOM JMP COATOM CLL RAL /REMOVE LIST INDICATOR JMS COCOMP DCA COI TAD I COI DCA .+2 JMS COMAIN 0 ISZ COI /SET COI TO POINT TO TL TAD I COI CLL RAR CLL CML RAL DCA COI JMP COLAHA COATOM, RAL SNA JMP CORET JMS COCOMP IAC DCA CONDX TAD I CONDX JMP COATOM+1 CORET, JMS I COPOP /POP RETURN ADDRESSES AND PARAMETER VALUE COMAIN JMS I COPOP COI JMP I COMAIN /COCOMP ROUTINE /SETS THE USE INDICATOR OFF FOR THE CELL WHOSE ADDRESS IS IN / THE AC. COCOMP, 0 IAC DCA COCNT TAD I COCNT RAR CLL RAL DCA I COCNT CMA TAD COCNT JMP I COCOMP /DECLARATIVES COGOOD, CORANG COCNT, 0 CONDX, 0 CODTAB, EVTABL COLAST, 0 COI, 0 COAUTO, 0 COPUSH=PUSH4 COPOP=POP4 COLLON, COLON PAGE /Added by VRS EJECT PAGE/100-220 EV5=EV POP5=POP PUSH5=PUSH /ENTER SUBROUTINE /SETS UP LINKAGES FOR SUBROUTINES /FORM IS: / F1 / F2 / . / . / . / END /WHERE FI ARE FORMAL VARIABLE LOCATIONS WHICH MUST APPEAR IN / THE LIST REFERENCE TABLE. /STACK USAGE: T1,A1,...,TN,AN,F1,F2,...,FN WHERE AI=0 IF / ARGI IN CALLING CODE IS NOT SIMPLE, AI=ADDRESS OF ARGI / OTHERWISE. AENTER, JMS I AEPUSH /RECURSIVE SELF-PROTECTION AEPNT JMS I AEPUSH / " AEREF JMS I AEPUSH / " AETMP JMS I AEPUSH / " AESCR /SWITCH POINTERS TAD I AEVAL /LEVAL DCA AEPNT TAD I AESAVE DCA I AEVAL /SCAN THE PARAMETERS I: PUSH TEMP LOCS, MOVE ARGS TO TEMP LOCS, / PUSH SIMPLE ARG ADDRESSES TAD AEPNT DCA AETMP TAD AEWORK DCA AEREF AESCAN, TAD I AETMP DCA AESCR TAD I AESCR CMA SNA CLA /-1? JMP AEON /YES JMS I AEPUSH /NO: PUSH A TEMP LOC AEREF, 0 ISZ I AEVAL JMP I .+1 /JUMP TO PATCH ROUTINE--DETERMINE IF ARG IS AEPAT /SIMPLE OR NOT. AEPATB, DCA AESCR STA TAD I AEVAL DCA I AEVAL JMS I AEEV /GET AN ARG DCA I AEREF JMS I AEPUSH /PUSH INDICATOR AESCR ISZ AETMP ISZ AEREF JMP AESCAN /SCAN THE PARAMETERS II: PUSH FORMAL VARIABLES, MOVE FROM / TEMP LOCS TO FORMAL VARIABLES. AEON, TAD AEPNT DCA AETMP TAD AEWORK DCA AEREF AESC2, TAD I AETMP DCA AELOC TAD I AELOC /IS IT -1? CMA SNA CLA JMP AEREST JMS I AEPUSH /PUSH FORMAL VARIABLE AELOC, 0 TAD I AEREF DCA I AELOC ISZ AETMP ISZ AEREF JMP AESC2 /RESTORE POINTERS AEREST, TAD I AEVAL DCA I AESAVE TAD AETMP DCA I AEVAL JMP I AER1 AER1, EVR1 AEPNT, 0 AETMP, 0 AESCR, 0 AEVAL, LEVAL AESAVE, EVSAVE AEWORK, WORK AEPUSH=PUSH5 AEEV=EV5 /EXIT SUBROUTINE /SEE ENTER COMMENTS FOR NOTES. AEXIT, /MOVE FORMAL VARIABLES TO TEMP LOCATIONS, POP FORMAL / VARIABLES DCA AECNT /SET CNT=0 TAD AEPNT DCA AESCR TAD AEREF DCA AEREF2 AESC10, STA TAD AETMP DCA AETMP STA TAD AEREF2 DCA AEREF2 ISZ AECNT TAD I AESCR DCA AELOC2 TAD I AELOC2 /IS IT -1? CMA SNA CLA JMP AEXEL /YES: GO ON TAD I AETMP /NO: MOVE DCA AELOC2 TAD I AELOC2 DCA I AEREF2 JMS I AEPOP AELOC2, 0 ISZ AESCR JMP AESC10 /REPLACE SIMPLE PARAMETERS WITH TEMP LOCS, POP TEMP LOCS AEXEL, TAD AECNT CIA DCA AECNT TAD AEREF DCA AEREF2 AESC11, STA TAD AEREF2 DCA AEREF2 ISZ AECNT /THROUGH? SKP JMP AEFINI /YES: RETURN JMS I AEPOP /NO: POP ARG ADDRESS AEA TAD AEA /IS IT 0? SNA CLA JMP .+3 /YES: DON'T REPLACE TAD I AEREF2 /NO: REPLACE DCA I AEA JMS I AEPOP /POP A TEMP LOC AEREF2, 0 JMP AESC11 AEFINI, /POP & RETURN JMS I AEPOP AESCR JMS I AEPOP AETMP JMS I AEPOP AEREF JMS I AEPOP AEPNT JMP I AER2 AER2, EVR2 AECNT=AELOC AEPOP=POP5 AEA=AESCR PAGE /Added by VRS EJECT PAGE/100-240 EV6=EV POP6=POP PUSH6=PUSH RET6, EVRET TEST6=TEST /EQ ROUTINE /COMPARES BOTH ARGUMENTS. IF THEY ARE EQUAL, THEN IT RETURNS /1 (I.E., TRUE); ELSE RETURNS 0 (I.E., FALSE). /BOTH ARGUMENTS MUST BE ATOMS. AEQ, JMS I EQPUSH /RECURSIVE SELF PROTECTION EQLIST JMS I EQEV /GET 1ST ARGUMENT DCA EQLIST JMS I EQEV /GET 2ND ARGUMENT DCA EQP2 JMS I EQTEST /REALLY JMP EQNO /NO EQON, TAD EQLIST /SEE IF ATOM OR NULL CLL RAR SNA CLA JMP EQYEP /NULL SZL HLT /NOT ATOM TAD EQP2 /SEE IF ATOM OR NULL CLL RAR SNA CLA JMP EQNO /NULL SZL HLT /NOT ATOM TAD I EQLIST /SEE IF = CIA TAD I EQP2 SZA CLA JMP EQNO /NOT = ISZ EQLIST ISZ EQP2 TAD I EQLIST DCA EQLIST TAD I EQP2 DCA EQP2 JMP EQON EQYEP, TAD EQP2 /SEE IF ATOM OR NULL CLL RAR SNA CLA IAC /NULL: RETURN 1(T) SZL HLT /NOT ATOM EQNO, JMS I EQPOP /NO; RETURN 0(F) EQLIST JMP I EQRET EQP2, 0 EQTEST=TEST6 EQRET=RET6 EQPUSH=PUSH6 EQPOP=POP6 EQEV=EV6 /COND ROUTINE /EVALUATES EVEN ARGUMENTS /IF ONE OF THESE IS TRUE, THEN RETURNS THE VALUE OF THE /FOLLOWING ARGUMENT; AFTER A TRUE HAS BEEN ENCOUNTERED, /EVALUATION OF SUBSEQUENT ARGUMENTS CEASES. ACOND, JMS I CNPUSH /RECURSIVE SELF PROTECTION CNLIST JMS I CNPUSH /RECURSIVE SELF PROTECTION CNSW2 JMS I CNPUSH /RECURSIVE SELF PROTECTION CNMODE TAD CNSW /SAVE SWITCH DCA CNSW2 TAD CNSW /SET MODE DCA CNMODE CNGO, TAD CNMODE /SET SWITCH DCA CNSW JMS I CNEV /GET NEXT EVEN ARG CMA /-1? SNA JMP CNEND /YES CMA /NO DCA CNSW /SET SWITCH TAD CNMODE /MODE = 0? SNA CLA DCA CNSW /YES: SET SWITCH = 0 JMS I CNEV /GET NEXT ODD ARG DCA CNSAVE TAD CNSW /SW = 1? SNA CLA JMP CNGO /NO: GO BACK DCA CNMODE /YES: SET MODE = 0 TAD CNSAVE /SET RETURN VALUE DCA CNLIST JMP CNGO CNEND, TAD CNSW2 /RESTORE SWITCH DCA CNSW TAD CNLIST JMS I CNPOP CNMODE JMS I CNPOP CNSW2 JMS I CNPOP CNLIST JMP I CNRET CNSW, 1 CNSW2, 0 CNMODE, 0 CNSAVE, 0 CNPUSH=PUSH6 CNPOP=POP6 CNEV=EV6 CNRET=RET6 /SKIP-IF-CNSW=1 SUBROUTINE ATEST, 0 DCA ATSAVE TAD CNSW SNA CLA /SKIP IF CNSW=1 JMP I ATEST /NO SKIP IF CNSW=0 TAD ATSAVE ISZ ATEST JMP I ATEST ATSAVE, 0 /SET ROUTINE /SETS THE CONTENTS OF THE CELL FOLLOWING THE SET INSTRUCTION TO /THE VALUE OF THE SUBSEQUENT PARAETER. RETURNS THE SECOND /PARAMETER. ASET, JMS I ASPUSH /RECURSIVE SELF-PROTECTION AS1 ISZ I ASEVAL TAD I ASEVAL DCA AS1 TAD I AS1 DCA AS1 JMS I ASEV /GET PARAMETER JMS I ASTEST JMP ASZOT DCA I AS1 TAD I AS1 ASZOT, JMS I ASPOP AS1 JMP I ASRET ASEVAL, LEVAL AS1, 0 ASRET=RET6 ASTEST=TEST6 ASPUSH=PUSH6 ASPOP=POP6 ASEV=EV6 PAGE /Added by VRS EJECT PAGE/100-260 EV7=EV POP7=POP PUSH7=PUSH /LISTOUT ROUTINE /OUTPUTS THE LIST POINTED TO BY THE ARGUMENT ALSTOT, JMS I ALEV /GET ARG DCA .+4 JMS I ALYAC1 /REALLY? JMP ALYAC2 /NO JMS OUTLST /YES; OUTPUT A LIST 0 TAD .-1 /RETURN ARGUMENT AS VALUE ALYAC2, JMP I ALZOT AL77, 77 ALZOT, EVRET ALYAC1, ATEST ALEV=EV7 /OUTLIST ROUTINE--MAIN OUTLST, 0 JMS I OUPUSH OUI TAD I OUTLST DCA OUI ISZ OUTLST JMS I OUPUSH OUTLST TAD OUI CLL RAR SNA /NULL? JMP OUNIL /YES SNL /NO; ATOM? JMP OUATOM /YES CLL /NO; REMOVE LIST INDICATOR RAL DCA OUI TAD OUOP /'(' JMS I EVOUT OURENT, TAD OUI DCA OUIT TAD OUI SNA JMP OUDONE IAC DCA OUI TAD I OUI RAR CLL RAL CLL DCA OUI TAD I OUIT DCA OUIT TAD OUIT DCA .+2 JMS OUTLST 0 TAD OUI SNA CLA JMP OUDONE TAD OUSP /' ' JMS I EVOUT JMP OURENT OUDONE, TAD OUCL /')' JMS I EVOUT JMP OUWHAK OUATOM, RAL SNA CLA JMP OUWHAK TAD I OUI JMS I EVOUT TAD OUI IAC DCA OUI TAD I OUI DCA OUI TAD OUI JMP OUATOM+1 OUNIL, TAD OUZERO /IF NULL ATOM, PRINT 0 JMS I EVOUT OUWHAK, JMS I OUPOP /RETURN OUTLST JMS I OUPOP OUI JMP I OUTLST OUI, 0 OUIT, 0 OUOP, 50 /'(' OUSP, 40 /' ' OUCL, 51/')' OUZERO, 6000 /'0', SHIFTED, STRIPPED & PACKED OUPUSH=PUSH7 OUPOP=POP7 /STACK OPERATIONS /PUSH ROUTINE /PUSHES THE VALUES OF THE ARGUMENT LIST ONTO THE STACK. /AC IS CLEARED ON EXIT. LPUSH, 0 CLA LPBACK, ISZ STPTR TAD STPTR TAD STMAX SNA CLA HLT /NOT ENOUGH STACK STORAGE PROVIDED TAD I LPUSH DCA STLOC TAD I STLOC DCA I STPTR ISZ LPUSH JMP I LPUSH /POP ROUTINE /SAME AS PUSH EXCEPT THAT IT POPS THE LIST INTO THE ARGUMENT /LOCATIONS. /AC ON EXIT = AC ON ENTRY LPOP, 0 DCA STSAV LPRET, TAD I LPOP DCA STLOC ISZ LPOP TAD I STPTR DCA I STLOC CMA TAD STPTR DCA STPTR TAD STPTR TAD STMIN SPA CLA HLT /MORE POPS THAN PUSHES TAD STSAV JMP I LPOP STSAV, 0 STLOC, 0 STCNT, 0 STPTR, 0/SET BY INIT STMIN, 0/SET BY INIT STMAX, -ENDINT PAGE /Added by VRS EJECT PAGE/100-280 EV9=EV POP9=POP PUSH9=PUSH RET9, EVRET TEST9=TEST /TABLE OF LISP SYSTEM ROUTINES TAB, AAND /0 0 AHD /1 1 ATL /2 2 ALSTIN /3 3 ALSTOT /4 4 ANULL /5 5 AATOM /6 6 APROG /7 7 AEQ /8 10 ACOND /9 11 EVERR /10 12 ASET /11 13 ABEGIN /12 14 ARETURN /13 15 ASETHD /14 16 ASETTL /15 17 ACONS /16 20 AOR /17 21 AGO /18 22 AMACH /19 23 APLUS /20 24 AMINUS /21 25 ATIMES /22 26 ANUMBER /23 27 AGREATP /24 30 AIF /25 31 APAUSE /26 32 ANOT /27 33 AEXIT2 /28 34 AQUOTE /29 35 AENTRY /30 36 EVERR /31 37 /GARBAGE COLLECTOR PATCH COLON, TAD I COSTK DCA COYAP COLZAP, TAD COYAP TAD COMIN SPA CLA JMP I COLZIP TAD I COYAP JMS CORANG JMP COLEXL TAD I COYAP DCA .+2 JMS I COLPAT 0 COLEXL, STA TAD COYAP DCA COYAP JMP COLZAP CORANG, 0 /SKIP-IF-ARG-IN-RANGE SUB CIA TAD EVBEG CIA SPA JMP CORON /NOT IN RANGE TAD EVLEN SPA ISZ CORANG /IN RANGE CORON, CLA JMP I CORANG COLPAT, COMAIN COSTK, STPTR COMIN, 0/SET BY INIT COLZIP, COLNXT COYAP, 0 /AND & OR ROUTINES AAND, /COMPUTES THE LOGICAL "AND" OF AN INDEFINATE SET OF ARGS. IAC DCA LOSW TAD ANSUB ANON, DCA LOSUB JMP LOGDO ANSUB, AND LOSW AOR, /COMPUTES THE LOGICAL "OR" OF AN INDEFINATE SET OF ARGS. DCA LOSW TAD ORSUB JMP ANON ORSUB, JMP OROR OROR, CMA DCA ORTMP TAD LOSW CMA AND ORTMP CMA JMP LOSUB+1 ORTMP, 0 /MAIN ROUTINE LOGDO, JMS I LOPUSH /RECURSIVE SELF PROTECTION LOSW JMS I LOPUSH /RECURSIVE SELF PROTECTION LOSUB JMS I LOEV /GET AN ARG JMS I LOPOP LOSUB JMS I LOPOP LOSW CMA /-1? SNA JMP LOEND /YES CMA /NO JMS I LOTEST /REALLY? JMP LOGDO /NO LOSUB, 0 /SUPLIED BY AND & OR DCA LOSW JMP LOGDO LOEND, TAD LOSW JMP I LORET LOSW, 0 /SUPLIED BY AND & OR LOPUSH=PUSH9 LOPOP=POP9 LOEV=EV9 LORET=RET9 LOTEST=TEST9 /GREATP ROUTINE /RETURNS T IF FIRST ARG IS GREATER NUMERICALLY THAN SECOND / ARG. RETURNS F OTHERWISE. NO TEST IS MADE TO SEE IF / ARGS ARE ACTUALLY NUMERICAL (OR IF THEY ARE BOTH ATOMS). AGREATP, JMS I GRPUSH /RECURSIVE SELF-PROTECTION GRA JMS I GREV /GET 1ST ARG JMS I GRDECB /CONVERT TO BINARY DCA GRA JMS I GREV /GET SECOND ARG JMS I GRDECB /CONVERT TO BINARY CIA TAD GRA SL1 CLA IAC /-B+A>0 IMPLIES T JMS I GRPOP /ELSE F GRA JMP I GRRET GRA, 0 GRDECB, DECBIN GRPUSH=PUSH9 GRPOP=POP9 GREV=EV9 GRRET=RET9 PAGE /Added by VRS EJECT PAGE/100-300 EV10=EV POP10=POP PUSH10=PUSH RET10, EVRET TEST10=TEST /HD ROUTINE /RETURNS THE DOWN POINTER OF THE CELL POINTED TO BY IT'S ARG AHD, JMS I AHEV /GET ARG RAR SNL CLA CLL RAL SNA JMP I AHRET DCA AHTMP TAD I AHTMP JMP I AHRET AHTMP,0 AHRET=RET10 AHEV=EV10 /MACH ROUTINE /TRANSFERS CONTROL TO SPECIFIED LOCATION AMACH, ISZ I MAEVAL TAD I MAEVAL DCA MATMP TAD I MATMP DCA MATMP JMS I MATMP JMP I MARET MATMP, 0 MAEVAL, LEVAL MARET=RET10 /PLUS, MINUS, TIMES ROUTINES APLUS, /COMPUTES THE SUM OF AN INDEFINATE NUMBER OF ARGS. TAD PLSUB DCA ARSUB DCA ARSUM JMP ARDO PLSUB, TAD ARSUM AMINUS, /NEGATES ITS ARGUMENT JMS I AREV /GET AN ARGUMENT JMS I ARTEST /REALLY JMP I ARRET /NO JMS DECBIN /CONVERT TO BINARY CIA /NEGATE IT JMP ARON ATIMES, /COMPUTES THE PRODUCT OF AN INDEFINATE NUMBER OF ARGS. IAC DCA ARSUM TAD TISUB DCA ARSUB JMP ARDO TISUB, JMP TIMTIM TIMTIM, MQL MUL ARSUM, 0 CLA MQA JMP ARSUB+1 /MAIN ARITMETIC ROUTINE ARDO, JMS I ARPUSH /RECURSIVE SELF PROTECTION ARSUM JMS I ARPUSH /RECURSIVE SELF PROTECTION ARSUB JMS I AREV /GET AN ARG JMS I ARPOP ARSUB JMS I ARPOP ARSUM CMA /-1? SNA JMP AREND /YES CMA /NO JMS DECBIN /CONVERT TO BINARY ARSUB, 0 /SUPPLIED BY ARITH SUBS DCA ARSUM JMP ARDO AREND, JMS I ARTEST /REALLY? JMP I ARRET /NO TAD ARSUM /CONVERT TO DECIMAL ARON, JMS I ARBIND JMP I ARRET ARBIND, BINDEC ARPUSH=PUSH10 ARPOP=POP10 ARRET=RET10 AREV=EV10 ARTEST=TEST10 /NUMBER ROUTINE /RETURNS 1 (T) IF ARG IS NUMBER; RETURNS 0 (F) OTHERWISE. ANUMBER, JMS I NUEV /GET ARG JMS DECBIN /CONVERT TO BINARY CLA TAD DERR /ERROR? SNA CLA IAC /NO: SET TO T JMP I NURET /YES: SET TO F & RETURN NUEV=EV10 NURET=RET10 /DECBIN ROUTINE /CONVERTS A CHARACTER CODED ATOM TO BINARY DECBIN, 0 CLL RAR/ATOM? SZL HLT /NO RAL /YES DCA DETMP DCA DERR DCA DETTL DEBAK, TAD DETMP SNA CLA /NULL? JMP DECEND /YES: EXIT TAD I DETMP LSR 5 JMS DECON TAD I DETMP AND DE77 JMS DECON ISZ DETMP TAD I DETMP DCA DETMP JMP DEBAK DECEND, TAD DETTL JMP I DECBIN DECON, 0 SNA /LAST? JMP DECEND /YES TAD DEM72 /-72 SMA ISZ DERR /NOT A NUMBER TAD DEDIF /72-60 SPA ISZ DERR /NOT A NUMBER DCA DELOC TAD DETTL /MULTIPLY BY 10 MQL MUL 12 CLA MQA TAD DELOC /ADD DIGIT DCA DETTL JMP I DECON DEM72, -72 DEDIF, 72-60 DELOC, 0 DE77, 77 DETMP, 0 DERR, 0 DETTL, 0 PAGE /Added by VRS EJECT PAGE/100-320 PUSH11=PUSH POP11=POP RET11, EVRET EV11=EV TEST11=TEST EVAL11, LEVAL /NULL ROUTINE /RETURNS +1 IF THE CELL POINTED TO BY THE ARGUMENT IS NULL. /RETURNS 0 OTHERWISE. ANULL, JMS I ANEV /GET ARG JMS I ANTEST JMP I ANRET RAR CLL SNA CLA IAC JMP I ANRET ANTEST=TEST11 ANEV=EV11 ANRET=RET11 /PROG ROUTINE /PERMITS IN-LINE CODING OF LISP INSTRUCTIONS /VALUE RETURNED IS THAT OF LAST ARGUMENT /FORM: / PROG / T1 / T2 / . / . / . / END / (INSTRUCTIONS) / END /WHERE TI IS A TEMPORARY WORKING LOCATION WHICH IS PUSHED / DOWN ON ENTRY TO PROG & SET TO NULL. IT IS POPPED ON / EXIT. APROG, JMS I PRPUSH /RECURSIVE SELF-PROTECTION PRPNT TAD I PREVAL /PUSH THE TEMP LOCATIONS & SET THEM TO NULL DCA PRPNT DCA I PR1 PRLP1, ISZ PRPNT TAD I PRPNT DCA PRTMP TAD I PRTMP /-1? CMA SNA CLA JMP PRON JMS I PRPUSH PRTMP, 0 DCA I PRTMP JMP PRLP1 PRON, TAD PRPNT DCA I PREVAL PRON2, JMS I PREV /GET AN ARGUMENT CMA SNA /END? JMP PRZOT /YES CMA /NO DCA I PR1 JMP PRON2 PRZOT, STA /POP TEMP LOCS TAD PRPNT DCA PRPNT TAD I PRPNT TAD PRMPROG SNA CLA JMP PRZAP TAD I PRPNT DCA PRTMP2 JMS I PRPOP PRTMP2, 0 JMP PRZOT PRZAP, TAD I PR1 JMS I PRPOP PRPNT JMP I PRRET PRPNT, 0 PR1, BGVAL PREVAL=EVAL11 PRMPROG, -PROG PRPUSH=PUSH11 PRPOP=POP11 PREV=EV11 PRRET=RET11 /BINDEC ROUTINE BINDEC, 0 /CONVERTS A BINARY WORD TO A CHARACTER CODED ATOM. DCA BIN1 /SAVE DCA BINCTR /INITIALIZE DCA BINSW TAD BININS DCA BINARR TAD I BINEV /SAVE DCA BINSAV TAD EVIN /SAVE INPUT ROUTINE DCA BININ TAD BINSUB DCA EVIN EVAL /CONVERT LISTIN DCA BINCTR /SAVE TAD BININ /RESTORE INPUT ROUTINE DCA EVIN TAD BINSAV /RESTORE DCA I BINEV TAD BINCTR JMP I BINDEC /RETURN BIN1, 0 BININ, 0 BINCTR, 0 BINSW, 0 BININS, TAD BIN10P BINEV=EVAL11 BINSAV, 0 BINSTR, 0 BINSUB, BINBIN BINBIN, 0 /CONVERSION SUBROUTINE. LEADING ZEROS STRIPPED. TAD BINCTR /0 IS CONVETED TO 0. TAD BINM3 SNA /LAST? ISZ BINSW /YES SMA SZA CLA /THROUGH? JMP BINRET /YES ISZ BINCTR /INCREMENT COUNTER BINARR, TAD BIN10P /GET DIVISOR ISZ .-1 DCA .+3 TAD BIN1 /GET DIVIDEND MQL DIV /DIVIDE 0 DCA BIN1 MQA /GET REMAINDER DCA BINLOC TAD BINSW /SWITCH SET? SZA CLA JMP BINON /YES TAD BINLOC /NO; = 0? SNA CLA JMP BINBIN+1 /YES ISZ BINSW /NO BINON, TAD BINLOC TAD BIN60 /MAKE STRIPPED ASCII CHAR JMP I BINBIN /RETURN BINRET, TAD BIN40 /BL JMP I BINBIN BINM3, -3 BINLOC, 0 BIN40, 40 BIN60, 60 DECIMAL BIN10P, 1000 100 10 1 OCTAL PAGE /Added by VRS EJECT PAGE/100-340 PUSH12=PUSH POP12=POP EV12=EV RET12, EVRET EVAL12, LEVAL TEST12=TEST /SETHD & SETTL ROUTINES ASETHD, /WILL SET THE DOWN POINTER TO THE ARGUMENT. TAD SHTYPE SHON, DCA DOITS JMP DOIT SHTYPE, CLL RAL ASETTL, /WILL SET THE NEXT POINTER TO THE ARGUMENT. TAD STTYPE JMP SHON STTYPE, CLL CML RAL /MAIN ROUTINE. NOT DEFINED FOR NULL ARGUMENTS, OR FOR / ATOMIC ARGUMENTS. DOIT, JMS I SHPUSH /RECURSIVE SELF-PROTECTION SHLIST JMS I SHEV /1ST ARGUMENT DCA SHLIST /SAVE IT JMS I SHPUSH /RECURSIVE SELF-PROTECTION DOITS JMS I SHEV /2ND ARGUMENT JMS I SHPOP DOITS DCA SH1 /SAVE IT JMS I SHTEST /REALLY? JMP SHRETR /NO TAD DOITS/SETHD OR SETTL? CIA TAD STTYPE SZA CLA JMP .+5/SETHD TAD SH1/GET 2ND ARG CLL RAR SNL CLA HLT /2ND ARG OF SETTL NOT A LIST TAD SHLIST /GET 1ST ARG RAR SNL /ATOM? HLT /YES SNA /NULL? HLT /YES DOITS, 0 /PUT IN BY SETHD & SETTL DCA SHLIST /SAVE IT TAD SH1 /GET 2ND ARG DCA I SHLIST /SET HEAD OR TAIL, AS SPECIFIED TAD I SHLIST /RETURN 2ND ARG AS VALUE SHRETR, JMS I SHPOP /POP & RETURN SHLIST JMP I SHRET SH1, 0 SHEV=EV12 SHPUSH=PUSH12 SHPOP=POP12 SHRET=RET12 SHTEST=TEST12 /IF ROUTINE /IF FIRST ARGUMENT IS T, THEN RETURNS (EXECUTES) SECOND ARG. / ELSE DOES NOT EXECUTE SECOND ARG. AIF, JMS I IFPUSH /RECURSIVE SELF-PROTECTION IFSAVE TAD I IFSW /SAVE SWITCH DCA IFSAVE JMS I IFEV /GET CONDITION DCA I IFSW /SAVE IT TAD IFSAVE /COND SW=1? SNA CLA DCA I IFSW /NO: SET SWITCH=0 JMS I IFEV /GET VALUE DCA IFVAL TAD IFSAVE /RESTORE SWITCH DCA I IFSW TAD IFVAL /RETURN VALUE JMS I IFPOP IFSAVE JMP I IFRET IFSW, CNSW IFSAVE, 0 IFVAL, 0 IFPUSH=PUSH12 IFPOP=POP12 IFEV=EV12 IFRET=RET12 /BEGIN ROUTINE /SIMILAR TO PROG, BUT WITHOUT THE AUTOMATIC PUSH-DOWN ABEGIN, JMS I BGEV /GET AN ARG CMA /-1? SNA JMP BGEND /YES CMA /NO DCA BGVAL /SAVE VALUE JMP ABEGIN /TRY AGAIN BGEND, TAD BGVAL JMP I BGRET BGVAL, 0 BGEV=EV12 BGRET=RET12 /RETURN ROUTINE /FOR USE IN THE IMMEDIATE RANGE OF A PROG. THIS WILL CAUSE / THE PROG TO 'DROP THROUGH', RETURNING AS THE PROG VALUE / THE VALUE OF THE RETURN ARGUMENT. ARETURN, JMS I REPUSH /RECURSIVE SWITCH PROTECTION CNSW JMS I REEV /GET RETURN VALUE JMS I RETEST /REALLY? JMP REARND /NO DCA I RE1 DCA I RESW /SET SWITCH VALUE F JMS I REPUSH /RECURSIVE SELF PROTECTION RE1, BGVAL JMS I REEV /GET NEXT JMS I REPOP /RECURSIVE SELF PROTECTION BGVAL CMA SZA CLA JMP .-7 STA /RETURN -1 REARND, JMS I REPOP RESW, CNSW JMP I RERET RETEST=TEST12 REPUSH=PUSH12 REPOP=POP12 REEV=EV12 RERET=RET12 /ERR ROUTINE /THIS ROUTINE CALLED WHENEVER A HLT IS NORMALLY EXECUTED. ERR, 0 CLA TAD ERR /DISPLAY ERROR ADDRESS MQL TAD I EREVAL/DISPLAY POINTER ADDRESS 7402 /HLT JMP ERR+1 EREVAL=EVAL12 /EXIT, PAUSE ROUTINES AEXIT2, JMS I STTEST JMP I STRET ICF /CLEAR INK FLAG TCF /CLEAR PRINT FLAG EFC /CLEAR ERASE FLAG JMP I .+1 7600 APAUSE, JMS I STTEST JMP I STRET MQL TAD I STEVAL 7402 JMP I STRET STEVAL=EVAL12 STRET=RET12 STTEST=TEST12 /QUOTE ROUTINE /PREVENTS THE EVALUATION OF ITS ARGUMENT. HAS AS ITS VALUE / THE CONTENTS OF THE CELL FOLLOWING THE CALL ON 'QUOTE' AQUOTE, ISZ I QUEVAL TAD I QUEVAL DCA QUTMP TAD I QUTMP JMP I QURET QUEVAL=EVAL12 QUTMP, 0 QURET=RET12 $