/LISP FOR PS/8 /RELEASE 3 /THIS IS A MODIFICATION OF DECUS 8-102A. /THE CCITT2 CODE SECTION HAS BEEN DELETED. /THE FOLLOWING ROUTINES HAVE BEEN ADDED: / /A TIMES ROUTINE /A CLEAR ROUTINE /AN EXIT ROUTINE /A LINEPRINTER ROUTINE /A BUFFERED TELETYPE INPUT ROUTINE WITH /LINE-EDITING CAPABILITIES; /ROUTINES TO CHANGE THE INPUT AND OUTPUT /TO PS/8 ASCII FILES ON ANY DEVICE. /THE SYSTEM WAS MOVED TO FIELD 1 IN /ORDER TO LEAVE ROOM FOR DEVICE HANDLERS /IN FIELD 0. /MODIFIED BY LARRY DAVIS /WASHINGTON UNIVERSITY /ST. LOUIS, MISSOURI /JANUARY 28,1972. /MODIFIED SLIGHTLY ON MARCH 9,1972 /FUNCTION ZEXPR WAS ADDED. /CORRECTED AND MODIFIED ON MAY 15, 1973 /BY TORBJORN ALM /AUTOCODE AB /SOLNA, SWEDEN /A NUMBER OF ARITHMETIC AND LOGICAL ZEXPR /FUNCTIONS HAVE BEEN ADDED, SOME OF WHICH /USE EAE, MODE A(PDP-8/I AND -8/E). / /THE FOLLOWING DEFINITIONS HAD TO BE MADE /FOR THE ASSEMBLER RSF=6011 RRB=6012 RFC=6014 KLSF=6351 KLLS=6356 LEND=7577 /LAST LIST LOCATION. /LP08 - LS8E PSKF=6661 PCLF=6662 PSTB=6664 /EAE-MODE A CAM=7621 MQA=7501 MQL=7421 SWP=7521 SCA=7441 SCL=7641 MUY=7405 DVI=7407 NMI=7411 SHL=7413 ASR=7415 LSR=7417 FIELD 0 *34 PQUOTI, QUOTIENT /POINTER TO QUOTIENT CELL IN FIELD 1 ZA1P, 0 /POINTER TO 1ST ARGUMENT. TEMPAD, 0 /TEMPORARY STORAGE USED BY /SEVERAL ROUTINES. ZA2P, 0 /POINTER TO 2ND ARGUMENT. PLRET2, LRET2 /POINTER TO LISP RETURN ADDRESS. ZA3P, 0 /POINTER TO 3RD ARGUMENT. /RETURN TO LISP SYSTEM WITH NO ARGUMENT. ZRET2, CDF CIF 10 JMP I PLRET2 /RETURN TO LISP SYSTEM WITH A NUMERICAL VALUE /WHICH IS IN THE ACCUMULATOR. ZVRET2, CDF CIF 10 JMP I .+1 RMASK+2 *100 PA1P, A1P PA2P, A2P PA3P, A3P NUMB, 0 /IF FIRST ARGUMENT TO IOPEN OR /OOPEN WAS A NUMBER,STORE HERE. NUMB1, 0 /NUMBER FOR OUTPUT OPENING. /INPUT FILE NAME. INDEV1, 0 INDEV2, 0 INFIL1, 0 0 0 0 /OUTPUT FILE NAME. OUDEV1, 0 OUDEV2, 0 OUFIL1, 0 0 0 0 PPINNAME,INDEV1 PPOUTNAM,OUDEV1 PNAME, 0 /POINTER TO NEXT WORD FOR /STORING FILE NAME. P1ERR, ERR /POINTER TO THE ERROR ROUTINE. PGETNAM,GETNAM IHNDLR, 0 /POINTER TO INPUT HANDLER OHNDLR, 0 /POINTER TO OUTPUT HANDLER. FINPTR, 0 PFILN1, INFIL1 PFILN2, OUFIL1 /RETURN FROM SUBROUTINE IN FIELD 0. F1RET, TAD KN3 DCA RLOCA /SAVE RETURN ADDRESS CIF CDF 10 TAD I RLOCA /RETURN ADDRESS DCA RLOCA TAD RVAL /VALUE TO RETURN WITH JMP I RLOCA RLOCA, 0 RVAL, 0 KOUTCHAR,0 /REPLACED BY A POINTER TO OUTPUT ROUTINE P1LPTOUT,LPTOUT P1FOCHAR,FOCHAR KN3, -3 K7700A, 7700 /LOCATION OF USR FI7400, 7400 /THE FOLLOWING WOULD NOT FIT ON GETNAM PAGE. KP77, 77 KP3600, 3600 KM6, -6 K36, 36 TMNAM, 0 NCTR, 0 PNAME1, 0 /ERROR IN OPENING OR CLOSING A FILE. ERROR1, CLA CDF CIF 10 JMS I P1ERR /PRINT ERROR MESSAGE /AND RESTART. /ERROR IN OUTPUTTING A CHARACTER OUERR1, CLA TAD P1OUTSUB /RESET OUTPUT TO TTY CDF CIF 10 DCA I PPOUTCH JMS I P1ERR P1OUTSUB,OUTSUB PPOUTCH,POUTCH PTARG1, 0 PTARG2, 0 /DEFAULT DEVICE NAME. K6546, 6546 /"DS" K55, 55 /"K" *200 /THIS ROUTINE IS THE BUFFERED TELETYPE /INPUT ROUTINE. IT WILL BUFFER UP TO A /CARRIAGE RETURN. /ON A LINE, THE FOLLOWING CHARACTERS /HAVE SPECIAL MEANING. /A RUBOUT DELETES THE PREVIOUS CHARACTER /A ^U DELETES THE WHOLE CURRENT LINE. /A ^R DOES A JMP 3001 /A ^C DOES A JMP 3000 /A CARRIAGE RETURN ECHOES A CARRIAGE RETURN /LINE FEED PAIR. /AN ALTMODE IS THE SAME AS A CARRIAGE /RETURN, AND INSERTS A CARRIAGE RETURN /IN THE CODE. HOWEVER,IT DOES NOT ECHO. /NOTE: CHARACTERS ARE NOT TRANSMITTED /UNTIL A CARRIAGE RETURN OR ALTMODE OCCURS. BTTY, 0 ISZ BTTY /SKIP OVER ADDRESS. CLA TAD TFLAG SMA CLA JMP TREAD /BUFFER EMPTY. READ IN. ISZ TFLAG NOP CRRET, TAD I CPOINT /GET NEXT CHARACTER IN /BUFFER. ISZ CPOINT BRET, CDF CIF 10 JMP I BTTY /RETURN WITH CHAR IN AC. /BUFFER EMPTY-READ IN A NEW BUFFER. TREAD, CLA TAD BPOINT DCA CPOINT /INITIALIZE BUFFER POINTER. DCA TFLAG /SAY NO CHARACTERS TYPED YET. RLOOP, KSF JMP .-1 /WAIT TILL SOMETHING TYPED. KRB /READ CHARACTER DCA TMCHAR /SAVE CHARACTER TAD TMCHAR TAD KM377 SNA JMP RUBOUT /HAD RUBOUT. IAC IAC SNA JMP ALTM /HAD ALTMODE.SAME AS C.R. TAD K150 SNA JMP CNTRU /HAD ^U TAD KP3 SNA JMP CNTRR /HAD ^R TAD KP17 SNA JMP I PCNTRC /HAD ^C TAD KM12 SNA CLA JMP CRET /HAD CARRIAGE RETURN. TAD KMLASTL /NEGATIVE OF LAST /BUFFER LOCATION + 1. TAD CPOINT /SEE IF BUFFER IS FULL. SMA CLA JMP RLOOP /BUFFER IS FULL. IGNORE /ANYTHING BUT CONTROL /CHARACTERS. CLA CMA /-1 IN AC. TAD TFLAG /SAY ONE MORE CHAR. IN /BUFFER. DCA TFLAG TAD TMCHAR /NOW PUT CHAR IN BUFFER. JMS ECHO /ECHO IF SPECIFIED. DCA I CPOINT ISZ CPOINT /POINT TO NEXT BUFFER LOCATION JMP RLOOP /GET NEXT CHARACTER. TFLAG, 0 /CONTAINS THE NEGATIVE OF THE /NUMBER OF CHARACTERS REMAINING /IN THE BUFFER. PCNTRC, CNTRC KMLASTL,-LASTL-2 CPOINT, 0 /POINTER TO THE NEXT BUFFER /LOCATION. BPOINT, TBUF /POINTER TO THE FIRST LOCATION /IN THE BUFFER. /ECHO TTY CHAR IF MODE SPECIFIES THIS. ECHO, 0 DCA TEMP /SAVE AC TEMPORARILY CDF 10 TAD I PMODE /GET MODE CDF 0 AND KP45 SZA CLA JMP ECHO1 TAD TEMP TSF JMP .-1 /WAIT TILL TTY FREE TLS JMP I ECHO ECHO1, TAD TEMP /NO ECHO JMP I ECHO CNTU, 336 /STRING FOR CONTROL U 325 K215, 215 KP212, 212 CRET, JMS TSTRING K215 /TYPE C.R. AND L.F. ALTM, TAD K215 /NOW PUT C.R. IN BUFFER DCA I CPOINT TAD BPOINT /NOW RESET BUFFER POINTER DCA CPOINT JMP CRRET /NOW RETURN WITH 1ST CHAR. CNTRU, JMS TSTRING CNTU JMP TREAD /REINITIALIZE BUFFER. RUBOUT, TAD BPOINT /SEE IF ANY CHARS IN BUFFER CIA TAD CPOINT SNA CLA JMP RLOOP /NO CHARS IN BUFFER. IGNORE CLA CMA TAD CPOINT /RESET BUFFER POINTER DCA CPOINT ISZ TFLAG /RESET CHARACTER COUNTER NOP TAD K334 JMS ECHO /ECHO BACKSLASH CLA JMP RLOOP /RETURN /TSTRING WILL TYPE A CHARACTER STRING WHICH /IS ENDED BY A NEGATIVE NUMBER. TSTRING,0 CLA TAD I TSTRING /GET ADDRESS OF STRING DCA TMSTR ISZ TSTRING TSLOOP, CLA TAD I TMSTR /GET NEXT CHARACTER IN STRING SPA CLA JMP I TSTRING /RETURN. HAD DELIMITER. TAD I TMSTR JMS ECHO /TYPE CHARACTER ISZ TMSTR /INCREMENT POINTER JMP TSLOOP TMSTR, 0 /POINTER TO STRING. PMODE, MODE TMCHAR, 0 /STORE CHARACTER TEMPORARILY TEMP, 0 KM12, -12 KP17, 17 KP3, 3 KM377, -377 K334, 334 K150, 150 KP45, 45 /MASK FOR CHECKING ECHO. CNTR, 336 /STRING FOR CONTROL R 322 CNTRR, JMS TSTRING /TYPE ^R. CNTR CLA DCA I PTFLAG /CLEAR BUFFER CDF CIF 10 /BACK TO FIELD 10 JMP I .+1 INIT1 /RESTART,BUT DON'T CLEAR. CNTC, 336 /STRING FOR CONTROL C 303 CNTRC, JMS I PTSTRING CNTC CLA DCA I PTFLAG /CLEAR BUFFER. CDF CIF 10 JMP I .+1 INIT /RESTART AND CLEAR. PTSTRING,TSTRING PTFLAG, TFLAG PAGE /LINEPRINTER SUBROUTINE. /THIS SUBROUTINE IS CURRENTLY FOR THE /KLEINSCHMIDT LINE PRINTER. /IT CONTAINS THE CHARACTER TO PRINT ON /THE KLEINSCHMIDT IN THE ACCUMULATOR ON /ENTRY. LPTOUT, 0 JMP LPTLS8 /STANDARD LPT DCA TCHAR TAD TCHAR TAD KM215 /SEE IF C.R. SNA TAD K22 /HAD CARRIAGE RETURN /CONVERT THE CODE. TAD KPL3 /SEE IF LINE FEED. SNA TAD K22 /HAD LINE FEED. CONVERT /THE CODE. TAD K212 KLLS /PRINT ON KLEINSCHMIDT KLSF /SKIP IF KLEINSCHMIDT DONE JMP .-1 CLA TAD TCHAR JMP I LPTOUT /RETURN. TCHAR, 0 KPL3, 3 KM215, -215 K22, 22 K212, 212 LPTLS8, PCLF PSTB /NORMAL LS8/LE8 PRINTER CODE PSKF /FOR USE OF KLEINSMIDT PRINTER JMP .-1 /INSERT 7000 INTO 601 JMP I LPTOUT /EXIT PAGE /GET FILE NAME SUBROUTINE. GETNAM, 0 CDF 10 /CHANGE TO FIELD OF CELLS. CLA TAD PNAME DCA PNAME1 /SAVE POINTER TO NAME. DCA NUMB /ZERO FLAG WHICH TELLS /IF FIRST ARGUMENT WAS A /NUMBER OR NOT. TAD I PA1P /GET FIRST ARGUMENT POINTER DCA PTARG1 /POINTER TO CDR PART OF 1ST /ARGUMENT. TAD PTARG1 IAC DCA PTARG2 /POINTER TO CAR PART OF 1ST /ARGUMENT. CLA CMA /SEE IF IT IS A NUMBER. TAD I PTARG2 SNA JMP ARG1N /FIRST ARGUMENT WAS A NUMBER. IAC /RESTORE ARGUMENT /SEE IF IT IS AN ATOM CLL RAR SNL JMP ERROR1 /FIRST ARGUMENT WAS NOT AN /ATOM. RAL /RESTORE ADDRESS /PICK UP DEVICE NAME DCA PTARG2 TAD I PTARG2 JMS SAVNAM /SAVE THIS NAME. /GET NEXT TWO CHARACTERS CLA CMA TAD PTARG2 DCA PTARG2 /POINT TO CDR PART TAD I PTARG2 SNA JMP GETFLN /NO MORE OF NAME. IAC /POINT TO NAME PART. DCA PTARG2 TAD I PTARG2 GETFLN, JMS SAVNAM /SAVE 2ND WORD OF /DEVICE NAME. /NOW GET FILE NAME. TAD I PA2P DCA PTARG1 /SAVE ADDRESS OF CDR PART /OF 2ND ARGUMENT. TAD PTARG1 IAC DCA PTARG2 /SAVE CAR PART OF 2ND ARG CLA CMA TAD I PTARG2 /SEE IF NUMBER SNA JMP ARG2N /IT WAS A NUMBER, SO ZERO /FILE NAME. IAC /SEE IF IT IS AN ATOM CLL RAR SNL JMP ERROR1 /ERROR-SECOND ARGUMENT WAS /NOT AN ATOM. RAL DCA PTARG2 /SAVE POINTER TO CAR PART. CLA CMA TAD PTARG2 DCA PTARG1 /SAVE POINTER TO CDR PART. TAD I PTARG2 /GET 1ST 2 CHARS OF NAME JMS SAVNAM TAD I PTARG1 /GET POINTER TO NEXT CELL SNA JMP ARG22 /NIL.ZERO REST OF NAME. DCA PTARG1 TAD PTARG1 IAC DCA PTARG2 /POINTER TO CAR PART TAD I PTARG2 /GET SECOND PAIR OF /CHARACTERS OF NAME. JMS SAVNAM TAD I PTARG1 /GET POINTER TO CDR PART SNA JMP GETEXT /NIL. ZERO REST OF NAME. IAC DCA PTARG2 TAD I PTARG2 /GET 3RD PAIR OF /CHARACTERS OF NAME. GETEXT, JMS SAVNAM /NOW PICK UP EXTENSION. TAD I PA3P DCA PTARG1 /ADDRESS OF CDR PART OF /THIRD ARGUMENT. TAD PTARG1 IAC DCA PTARG2 /SAVE ADDRESS OF CAR PART CLA CMA TAD I PTARG2 /SEE IF NUMBER. SNA JMP SAVEXT IAC /SEE IF IT IS AN ATOM. CLL RAR SNL JMP ERROR1 /3RD ARGUMENT WAS NOT ATOMIC RAL DCA PTARG2 /SAVE POINTER TO ATOM NAME. TAD I PTARG2 /GET EXTENSION. SAVEXT, JMS SAVNAM /CONVERT INTERNAL CHARACTERS TO 6-BIT ASCII. /IF 0, LEAVE 0. OTHERWISE, ADD 36 AND MASK. CDF 0 CLA TAD KM6 /GO THROUGH LOOP 6 TIMES. DCA NCTR /LOOP COUNTER. NMLOOP, TAD I PNAME1 /GET NEXT WORD OF NAME. AND K7700A SZA TAD KP3600 CLL RTR RTR RTR /SWAP CHARACTERS. DCA TMNAM /HAVE ASCII FOR HIGH-ORDER CHAR TAD I PNAME1 AND KP77 SZA TAD K36 AND KP77 /HAVE ASCII FOR LOW CHAR. CLL RTL RTL RTL TAD TMNAM /HAVE BOTH IN ASCII. DCA I PNAME1 ISZ PNAME1 /POINT TO NEXT WORD OF NAME ISZ NCTR /INCREMENT LOOP COUNTER JMP NMLOOP CDF 10 JMP I GETNAM /RETURN. /FIRST ARGUMENT WAS A NUMBER. ARG1N, TAD I PTARG1 /GET THE NUMBER. DCA NUMB TAD K6546 /"DS" JMS SAVNAM /DSK IS DEFAULT DEVICE NAME. TAD K55 JMP GETFLN /SECOND ARGUMENT WAS A NUMBER-ZERO THE FILE NAME. ARG2N, JMS SAVNAM ARG22, JMS SAVNAM JMP GETEXT /STORE AC IN FIELD 0 LOCATION POINTED TO /BY PNAME, AND INCREMENT PNAME. SAVNAM, 0 CDF 0 DCA I PNAME ISZ PNAME CDF 10 JMP I SAVNAM PAGE /OPEN AN INPUT FILE. IOPENR, 0 CLA TAD PPINNAME DCA PNAME /SET POINTER TO INPUT NAME JMS I PGETNAM /GET THE FILE'S DEVICE, /NAME,AND EXTENSION. /MOVE THE DEVICE NAME. TAD INDEV1 DCA ASDEV1 TAD INDEV2 DCA ASDEV2 /SET LOCATION FOR DEVICE HANDLER TO BE /LOADED INTO. TAD PINDBUF DCA ASPAG /ALLOW 2 PAGE HANDLERS. /LOAD THE DEVICE HANDLER CDF 0 CIF 10 JMS I K7700A /CALL USR 1 /FETCH DEVICE HANDLER. ASDEV1, 0 /DEVICE NAME. ASDEV2, 0 /THIS IS CHANGED TO THE /DEVICE NUMBER. ASPAG, 0 /LOCATION OF HANDLER. JMP ASERR /ERROR-COULD NOT FIND THE /DEVICE NAME. /NOW LOOK UP THE FILE. CLA TAD PFILN1 DCA FLUNAM TAD ASDEV2 /LOAD DEVICE NUMBER. CIF 10 JMS I K7700A /CALL USR 2 /LOOKUP FILE. FLUNAM, 0 /POINTER TO THE FILE /NAME. REPLACED BY BLOCK #. FLUCNT, 0 /REPLACED BY LENGTH AS A /NEGATIVE NUMBER. JMP ASERR /ERROR IN LOOKUP. CLA CMA DCA FICHCT /SET INPUT CHARACTER COUNT /FOR A READ ON FIRST CALL. TAD FLUNAM /GET FILE STARTING /BLOCK NUMBER. DCA FINREC TAD ASPAG /GET HANDLER ENTRY POINT. DCA IHNDLR TAD FIN10 DCA FINTMP /SAY ON PROPER PART OF WORD. /MOVE INPUT POINTER TO GCHAR SUBROUTINE. TAD KGCHAR CDF 10 DCA I P1PINSUB CDF 0 DCA RVAL /ZERO RETURN VALUE. /I.E. RETURN NIL. TAD IOPENR JMP F1RET /RETURN. PINDBUF,INDBUF+1 /LOCATION TO LOAD DEVICE /HANDLER , WITH BIT 1 SET /TO ALLOW 2-PAGE HANDLERS. /ERROR IN OPENING INPUT FILE. ASERR, CLA CDF CIF 10 JMS I P1ERR /GET A CHARACTER ROUTINE GTCHAR, 0 CLA FNXTCH, ISZ FICHCT /BUMP CHARACTER COUNT. JMP FIGET /SEE IF OUT OF DATA TAD FLUCNT SMA JMP ERROR2 /OUT OF DATA. CLA JMS I IHNDLR /BUFFER EMPTY. READ IN /A NEW BUFFER. FI200, 200 /READ IN 2 PAGES. FINBUF, INBUFL /BUFFER LOCATION. FINREC, 0 /REPLACED BY BLOCK #. JMP ERROR2 /ERROR IN READING. ISZ FLUCNT /INCREMENT BLOCK COUNT. NOP ISZ FINREC /INCREMENT BLOCK NUMBER. CLA CMA TAD FINBUF DCA FINPTR /POINTER TO NEXT BUFFER /CHARACTER. TAD FI7200 /SAVE CHARACTER COUNT. DCA FICHCT FIGET, TAD FINTMP /GET HIGH-ORDER BIT BUFFER. SPA /ON THIRD CHAR? JMP FITHRD /YES-OUTPUT COMBINED HIGH- /ORDER BITS. FI7200, CLA ISZ FINPTR TAD I FINPTR AND FI7400 RAL CLL TAD FINTMP /PUT THE HIGH-ORDER BITS ONTO /THE HOB BUFFER. FINXX, RTL RTL DCA FINTMP TAD I FINPTR /GET CHARACTER. AND KP377 CDF CIF 10 JMP I GTCHAR /RETURN. FITHRD, DCA I FINPTR /FUDGE 3RD CHARACTER INTO BUFFER CLL CML JMP FINXX /RESET FINTMP TO 10. /ERROR IN READING INPUT FILE. ERROR2, CLA CDF CIF 10 TAD K1INSUB /RESET INPUT TO TTY DCA I P1PINSUB JMS I P1ERR /GIVE ERROR MESSAGE FICHCT, 0 /INPUT CHARACTER COUNT. FINTMP, 0 /HIGH-ORDER BITS BUFFER. FIN10, 10 P1PINSUB,PINSUB K1INSUB,INSUB KGCHAR, GCHAR KP377, 377 PAGE /OPEN AN OUTPUT FILE OOPENR, 0 CLA /MOVE POINTER FROM BASIC OUTPUT ROUTINE. CDF 10 TAD KPCHAR DCA I KPOUTCH CDF 0 TAD PPOUTNAME DCA PNAME /SET POINTER TO OUTPUT NAME. JMS I PGETNAM /GET THE FILE'S DEVICE,NAME, /AND EXTENSION TAD NUMB DCA NUMB1 /MOVE TO NUMB1 TAD NUMB1 SZA JMP OSPEC /SPECIAL OUTPUT DEVICE SPECIFIED. /MOVE THE DEVICE NAME. TAD OUDEV1 DCA OSDEV1 TAD OUDEV2 DCA OSDEV2 TAD POUDBUF /LOCATION FOR OUTPUT /DEVICE HANDLER. DCA OSPAG /LOAD THE DEVICE HANDLER. CDF 0 CIF 10 JMS I K7700A /CALL USR 1 /FETCH DEVICE HANDLER OSDEV1, 0 /DEVICE NAME. OSDEV2, 0 /THIS IS REPLACED BY DEVICE # OSPAG, 0 /PAGE TO LOAD HANDLER INTO. JMS OUERR /ERROR-COULD NOT FIND THE /DEVICE NAME. /NOW ENTER THE FILE CLA DCA I KFOCCNT /ZERO COUNT OF # OF BLOCKS WRITTEN TAD PFILN2 DCA FOONAM /POINTER TO FILE NAME TAD OSDEV2 /DEVICE NUMBER CIF 10 JMS I K7700A /CALL USR 3 /ENTER. FOONAM, 0 /POINTER TO FILE NAME. FOOCNT, 0 /LENGTH OF FILE. JMP OUERR /ERROR RETURN TAD FOONAM /GET STARTING BLOCK NUMBER DCA FOUREC JMS FOSETP /SET UP POINTERS. TAD OSPAG /HANDLER LOCATION DCA OHNDLR /SET POINTER TO PROPER VALUE ROUTINE TAD P1FOCHAR ORET, DCA KOUTCHAR DCA RVAL /RETURN NIL. TAD OOPENR JMP F1RET /RETURN. /WANT TO OUTPUT TO LINEPRINTER. OSPEC, CLA TAD P1LPTOUT JMP ORET /ERROR OPENING OUTPUT FILE. OUERR, CDF CIF 10 JMS I P1ERR KPCHAR,PCHAR KPOUTCH,POUTCH POUDBUF,OUDBUF /POINTER TO OUTPUT DEVICE LOCATION /PUT A CHARACTER ROUTINE. PTCHAR, 0 JMS I KOUTCHAR/GO TO OUTPUT ROUTINE. CDF CIF 10 JMP I PTCHAR /RETURN. /OUTPUT A CHARACTER TO OUTPUT FILE. FOCHAR, 0 DCA TEMOUT /SAVE AC TO RESTORE ON RETURN. TAD TEMOUT DCA FOUTMP FOLOOP, ISZ FOUJMP ISZ FOCHCT /BUMP CHARACTER COUNT FOJMP, JMP FOUJMP /TAKE A BRANCH OF THE /THREE WAY JUMP. JMS I OHNDLR /BUFFER FULL. WRITE IT OUT. 4200 /WRITE 2 PAGES FOUBUF, OUBUF /BUFFER LOCATION. FOUREC, 0 /BLOCK NUMBER JMP OUERR1 /WRITE ERROR. ISZ FOUREC /INCREMENT BLOCK NUMBER. ISZ I KFOCCNT /INCREMENT COUNT OF /BLOCKS WRITTEN. JMS FOSETP /RESET POINTERS. ISZ FOOCNT /INCREMENT COUNT OF BLOCKS JMP FOLOOP /NOW GO PUT THE CHARACTER /INTO THE NEW BUFFER. JMP OUERR1 /ERROR-NO MORE ROOM FOR FILE FOUJMP, JMP . /THREE WAY SWITCH. JMP FOUCH1 JMP FOUCH2 FOUCH3, TAD FOUTMP RTL RTL DCA FOUTMP TAD FOUTMP AND FI7400 TAD I FOPOLD /PUT HIGH-ORDER BITS /OF CHARACTER 3 DCA I FOPOLD /INTO HIGH-ORDER BITS /OF CHARACTER 1. TAD FOUTMP RTL RTL AND FI7400 TAD I FOUPTR /PUT LOW-ORDER BITS /OF CHARACTER 3 DCA I FOUPTR /INTO HIGH-ORDER BITS OF /CHARACTER 2. TAD FOJMP DCA FOUJMP ISZ FOUPTR JMP DFEXIT /RETURN. FOUCH2, TAD FOUPTR DCA FOPOLD /SAVE POINTER TO CHAR 1. ISZ FOUPTR FOUCH1, TAD FOUTMP DCA I FOUPTR /STORE CHAR 1 OR 2 DFEXIT, TAD TEMOUT /RESTORE AC JMP I FOCHAR /RETURN. PLPTOUT,LPTOUT /POINTER TO LINE PRINTER /ROUTINE. FOSETP, 0 TAD FO7177 DCA FOCHCT /INITIALIZE OUTPUT CHARACTER /COUNT. TAD FOUBUF DCA FOUPTR /POINTER TO BUFFER. TAD FOJMP DCA FOUJMP /SET 3-WAY SWITCH. JMP I FOSETP FO7177, 7177 /WRITE 600 CHARACTERS/BUFFER. TEMOUT, 0 /STORE CHARACTER TEMPORARILY FOUTMP, 0 FOCHCT, 0 /OUTPUT CHARACTER COUNT. FOPOLD, 0 FOUPTR, 0 /POINTER TO NEXT LOCATION /IN OUTPUT BUFFER. KFOCCNT,FOCCNT PAGE /CLOSE INPUT FILE-JUST RESET POINTER TO /TELETYPE. ICLOSR, 0 CLA TAD KPTTYIN /POINTER TO TTY INPUT /ROUTINE. CDF 10 DCA I PPINSUB DCA RVAL /RETURN NIL TAD ICLOSR JMP F1RET /RETURN. KPTTYIN,INSUB PPINSUB,PINSUB /CLOSE OUTPUT FILE. IF SPECIAL OUTPUT DEVICE, /JUST RESET POINTER. OTHERWISE,OUTPUT ^Z /AND CLOSE OUTPUT FILE. OCLOSR, 0 CLA TAD NUMB1 SZA JMP CNGPT /SPECIAL OUTPUT-CHANGE POINTER /OUTPUT A ^Z TAD K232 JMS I PFOCHAR CDF 0 /WRITE OUT THE LAST BLOCK. CLA TAD I KFOUBUF DCA COUBUF TAD I KFOUREC DCA COUREC /BLOCK NUMBER JMS I OHNDLR 4200 /WRITE 2 PAGES. COUBUF, 0 /BUFFER LOCATION COUREC, 0 /BLOCK NUMBER JMP I KOUERR /ERROR. ISZ FOCCNT /INCREMENT COUNT OF /BLOCKS WRITTEN. CIF 10 CLA TAD I POSDEV2 /GET DEVICE NUMBER. JMS I K7700A /CALL USR 4 /CLOSE FILE FOCNAM, OUFIL1 /FILE NAME LOCATION. FOCCNT, 0 /CLOSING LENGTH. JMP I POUERR /ERROR. CNGPT, CLA TAD P1OUTSUB/POINTER TO OUTPUT ROUTINE CDF 10 DCA I PPOUTCH /RESET POINTER TO OUTPUT ROUTINE DCA RVAL /RETURN NIL TAD OCLOSR JMP F1RET /RETURN. PFOCHAR,FOCHAR POSDEV2,OSDEV2 /POINTER TO OUTPUT DEVICE #. POUERR, OUERR K232, 232 /CODE FOR ^Z. KFOUBUF,FOUBUF KFOUREC,FOUREC KOUERR, OUERR /MOVE A1P,A2P,AND A3P TO /ZA1P,ZA2P,AND ZA3P RESPECTIVELY. /RETURNS WITH DATA FIELD =10. MOVARG, 0 CDF 10 CLA TAD I PA1P DCA ZA1P TAD I PA2P DCA ZA2P TAD I PA3P DCA ZA3P JMP I MOVARG /ZEXPR ROUTINE. JUMPS TO /THE LOCATION SPECIFIED AS THE /FIRST ARGUMENT, WITH POINTERS TO THE /SECOND AND THIRD ARGUMENTS IN /FIELD 0 LOCATIONS ZA2P AND ZA3P. ZEXPR0, JMS MOVARG /MOVE THE ARGUMENT /POINTERS. TAD I A1P /GET ADDRESS TO TRANSFER TO. DCA TEMPAD TAD I A2P /HAVE 2ND ARGUMENT IN AC. CDF 0 JMP I TEMPAD /GO TO THIS ROUTINE. /CHANGE FIELD 0 LOCATION SPECIFIED IN AC. CNGLOC, DCA TEMPAD /SAVE ADDRESS. CDF 10 TAD I ZA3P CNGLOZ, DCA I TEMPAD /CHANGE LOCATION. JMP ZRET2 /RETURN. /RETURN WITH THE CONTENTS OF THE ADDRESS SPECIFIED IN /THE ACCUMULATOR. GETCON, DCA TEMPAD TAD I TEMPAD JMP ZVRET2 /RETURN THIS NUMERICAL VALUE. /PRINT CHARACTER SPECIFIED IN 2ND ARGUMENT /ON THE LINE PRINTER. PRLPT, JMS I PLPT /HAVE CHAR IN AC ON ENTRY. CLA /RETURN VALUE NIL. JMP ZRET2 /RETURN. PLPT, LPTOUT /POINTER TO LINE PRINTER ROUTINE. /CHANGE FIELD 2 LOCATION SPECIFIED IN AC CNGLO2, DCA TEMPAD /SAVE ADDRESS CDF 10 TAD I ZA3P /GET VALUE TO BE SAVED CDF 20 JMP CNGLOZ /CHANGE FIELD 3 LOCATION SPECIFIED IN AC CNGLO3, DCA TEMPAD /SAVE ADDRESS CDF 10 TAD I ZA3P /GET VALUE TO BE SAVED CDF 30 JMP CNGLOZ /GET FIELD 2 CONTENT OF ADDRESS IN AC GETCO2, CDF 20 /SET DF JMP GETCON /GET FIELD 3 CONTENT OF ADDRESS IN AC GETCO3, CDF 30 /SET DF JMP GETCON /XOR OF ARG2 AND AND ARG3 XORX, CDF 10 /RESET DF WITH ARG2 IN AC TAD I A3P /ADD ARG3 DCA TEMPAD /TEMPAD = A+B TAD I A3P /GET ARG2 AND I A2P /MASK WITH ARG3 CMA TAD TEMPAD /AC = A+B-(A.B)=A.XOR.B JMP ZVRET2 /OR OF ARG2 AND ARG3. NO EAE ORX, CDF 10 /RESET DF, ARG2 IN AC CMA / DCA TEMPAD / TAD I A3P /A.OR.B = CMA / AND TEMPAD /.NOT.(.NOT.A.AND..NOT.B) CMA / JMP ZVRET2 /RETURN VALUE /OR OF ARG2 AND ARG3, MODE A EAE OREAEX, MQL /ARG2 TO MQ CDF 10 /RESET DF TAD I A3P /ARG3 TO AC MQA /AC.OR.MQ TO AC JMP ZVRET2 /RETURN VALUE *2000 /LOGICAL SHIFT ARG2*(2**ARG3), NO EAE LFTSHX, DCA TEMPAD /SAVE ARG2 CDF 10 /RESTORE DF TAD I A3P /GET ARG3 SNA /ARG3=0? JMP NOSHIFT /YES RETURN ARG2 SPA /N > 0? JMP RIGHTSH /NO, RIGHT SHIFTS CMA IAC /LEFT SHIFTLOOP DCA TEMPAX /SAVE COUNT TAD TEMPAD CLL RAL ISZ TEMPAX JMP .-2 JMP ZVRET2 /RETURN VALUE NOSHIFT, TAD TEMPAD /PICK UP ARG2 JMP ZVRET2 /RETURN IT RIGHTSH, DCA TEMPAX /STORE COUNT TAD TEMPAD /GET ARG2 CLL RAR /SHIFT RIGHT ISZ TEMPAX /STEP COUNT JMP .-2 /ONCE MORE JMP ZVRET2 /RETURN VALUE /LOGICAL SHIFT ARG2*(2**ARG3), EAE VERSION LFTEAX, DCA TEMPAD /STORE ARG2 CDF 10 /RESTORE DF TAD I A3P /GET ARG3 SNA JMP NOSHIFT /ARG3=0 SPA JMP RIGEAS /ARG3 > 0, RIGHT SHIFT CMA IAC /SUBTRACT BY ONE CMA DCA LFTSHC CAM /CLEAR MQ TAD TEMPAD SHL /SHIFT IT LEFT LFTSHC, .-. JMP ZVRET2 /RETURN RESULT RIGEAS, CMA /CHANGE SIGN AND BACK ONE DCA RIGSHC /STORE IN SHIFTCOUNT TAD TEMPAD /GET ARG2 LSR /LOGICAL RIGHT SHIFT RIGSHC, .-. JMP ZVRET2 /RETURN VALUE /REMAINDER (ARG2 ARG3) IS RETURNED /QUOTIENT IS RETURNED IN 15 /RETREIVED BY EXPR(3172 15 -1) / TEMPAX, 0 /TEMP STORAGE REMX, DCA TEMPAD /STORE ARG2 CDF 10 /RESTORE DF DCA I PQUOTI /CLEAR QUOTIENT TAD I A3P /GET ARG3 SNA /=0? JMP FEX /YES, ERROR DCA TEMPAX /STORE ARG3 TAD TEMPAX /GET IT AGAIN CLL CML CMA IAC /-ARG3, 13 BITS TAD TEMPAD /ADD ARG2 SZL SPA /STILL GREATER JMP .+4 /NO, READY DCA TEMPAD /STORE NEW ONE ISZ I PQUOTI /STEP QUOTIENT JMP .-7 /ONCE MORE CLA TAD TEMPAD /GET LAST REM JMP ZVRET2 /RETURN IT /REMAINDER, EAE VERSION REMEAE, MQL /ARG2 TO MQ CDF 10 /RESTORE DF TAD I A3P /GET ARG3 DCA .+2 /STORE IN 2:ND WORD REMDVI, DVI /DIVIDE ARG2/ARG3 .-. SZL /OVERFLOW JMP FEX /YES SWP /LET AC AND MQ EXCHANGE CONTENT DCA I PQUOTI /AC - QUOTIENT MQA CLA /MQ - REMAINDER JMP ZVRET2 /PRODUCT, EAE VERSION FOR QUICK TIMES TIMEAE, MQL /ARG2 TO MQ CDF 10 /GET DF TAD I A3P /GET ARG3 DCA .+2 /STORE IN 2:ND WORD MUY /ARG2*ARG3, 12 BITS .-. / MQA CLA /12 LAST BITS TO AC JMP ZVRET2 /RETURN IT FEX, CLA CIF CDF 10 JMS I P1ERR /PRODUCT, TWO. WORD RESULT /ARG2*ARG3+<15> - <15>, RESULT TIMEXT, MQL /ARG2 TO MQ CDF 10 /RESTORE DF TAD I A3P /GET ARG3 DCA .+3 /STORE IN 2:ND WORD TAD I PQUOTI /GET <15> MUY /MULTIPLY .-. / DCA I PQUOTI /STORE FIRST WORD MQA /GET 2:ND ONE JMP ZVRET2 /RETURN IT /QUOTIENT, TWO WORD NOMINATOR /(<15>,ARG)/ARG3 - RESULT,<15> /ARG3 > <15> / REMEXT, MQL /ARG2 TO MQ CDF 10 /RESTORE DF TAD I A3P /GET ARG3 DCA REMDVI+1 /STORE IND 2:ND WORD TAD I PQUOTI /<15> TO AC JMP REMDVI /DIVIDE *2200 /13 BIT ADDER, UNSIGNED, EAE INDEPENDENT /<15> + ARG2 + ARG3 => <15>(CARRY), RESULT /<15> IS THE QUOTIENT CELL, USED FOR CARRY ADDWCA, CDF 10 /RESET DF CLL /CLEAR LINK BIT TAD I A3P /ADD ARG2 TAD I PQUOTI /ADD OLD CARRY DCA TEMPAX /SAVE AC IN TEMPAX RAL /LINK TO AC DCA I PQUOTI /STORE IN <15> TAD TEMPAX /GET SUM TO AC JMP ZVRET2 /RETURN VALUE /BINARY PUNCH ROUTINE /IF ARG3 >=0,PUNCH ARG2, ARG3 /IF ARG3<0, PUNCH ARG2. -ARG3 TIMES STUTX, DCA TEMPAD /SAVE ARG2 CDF 10 /RESTORE DF TAD TEMPAD /GET ARG2 JMS STANSA /PUT IT TAD I A3P /GET ARG3 SPA />=0? JMP STUX /NO, REPEAT JMS STANSA /PUT IT JMP ZRET2 /EXIT STUX, DCA TEMPAX /SAVE COUNT JMP .+3 /BYPASS ONCE TAD TEMPAD /GET ARG2 JMS STANSA /PUT IT ONCE MORE ISZ TEMPAX /STEP COUNT JMP .-3 /ONCE MORE JMP ZRET2 /EXIT STANSA, 0 /BASIC PUNCH ROUTINE 6026 6021 JMP .-1 P7600, 7600 /CLA AND A CONSTANT JMP I STANSA SETDEC, CDF 10 /SET DECIMAL MODE TAD SETDA /1037 DCA I SETDA+1 /2506 TAD SETDA+2 /1750 DCA I SETDA+3 /2034 TAD SETDA+4 /144 DCA I SETDA+5 /2035 TAD SETDA+6 /12 DCA I SETDA+7 /2036 TAD SETDA+10/7061 DCA I SETDA+11/2046 JMP ZRET2 /EXIT SETOCT, CDF 10 /SET OCTAL UNSIGNED MODE TAD SETOA /7000 DCA I SETDA+1 /2506 TAD SETOA+1 /1000 DCA I SETDA+3 /2034 TAD SETOA+2 /100 DCA I SETDA+5 /2035 TAD SETOA+3 /10 DCA I SETDA+7 /2036 TAD SETOA+4 /7000 DCA I SETDA+11/2046 JMP ZRET2 SETDA, 1037; RDNUM1; 1750; K1000; 144; K100 12; K10; 7061; PRNTA5 SETOA, 7000; 1000; 100; 10; 7000 CPAGE, AND P7600 /MASK OUT PAGE CMA IAC DCA TEMPAD /STORE NEGATIVE ARG2 MASKED CDF 10 TAD I A2P /GET ARG 2 TAD I A3P /ADD ARG 3 AND P7600 /MASK OUT PAGE DCA STANSA /SAVE IT A WHILE TAD STANSA /PIC IT UP TAD TEMPAD /COMPARE WITH MASKED ARG 2 SZA CLA JMP CPAGE1 /NOT SAME PAGE TAD I A2P /SAME PAGE, GET ARG 2 JMP ZVRET2 /EXIT CPAGE1, TAD STANSA /NOT SAME PAGE, GET NEXT PAGE START JMP ZVRET2 /EXIT *5400 /BEGINNING OF TELETYPE INPUT BUFFER. TBUF, 0 *5577 /END OF TELETYPE INPUT BUFFER. LASTL, 0 *5600 OUBUF, 0 /LOCATION OF OUTPUT BUFFER. *6200 INBUFL, 0 /LOCATION OF INPUT BUFFER *6600 OUDBUF,0 /LOCATION TO LOAD OUTPUT DEVICE HANDLER *7200 INDBUF, 0 /LOCATION TO LOAD INPUT DEVICE HANDLER FIELD 1 /PAGE ZERO LOCATIONS /LOCATION 102 IS STILL UNUSED. *0 NIL, 0 /ATOM NIL NIL1, 0 K2, 2 K3, 3 K4, 4 K5, 5 GCCNT, 0 /CUMULATIVE NUMBER OF TIMES THE /GARBAGE COLLECTOR HAS BEEN CALLED K77, 77 XR10, 0 /THESE FOUR INDEX REGISTERS XR11, 0 /ARE USED BY SEVERAL PARTS XR12, 0 /OF THE LISP SYSTEM. XR13, 0 CHAR, 0 /INPUT CHARACTER BUFFER QUOTIENT, 0 /USED BY ZEXPR ROUTINES FOR /MULTIPLY AND DIVIDE AND MULTIPLE /PRECISION INTEGER ARITHMETIC ROUTINES. LINCNT, 0 /LINE COUNT, COUNTING FROM -77 TO 0. CGENSYM,0 /COUNTER USED BY GENSYM L20, PAPVAL /THESE LOCATIONS ARE TEMP1, 0 /USED FOR STORING DIFFERENT L22, 0 /THINGS AT DIFFERENT TIMES. L23, 0 PTRUE, TRUE /POINTER TO THE ATOM "T" ALP, 0 /POINTER TO THE ASSOCIATION LIST POBJST, OBJST /POINTER TO THE START OF THE /OBJECT LIST SP, 0 /STACK POINTER FLIST, 0 /POINTER TO THE NEXT CELL IN /THE FREE LIST. L31, 0 /THESE LOCATIONS ARE USED L32, 0 /FOR STORING VALUES L33, 0 PB1ARG, B1ARG /POINTER TO THE BEGINNING OF THE /SYSTEM SUBROUTINES WITH /ONE ARGUMENT. A1P, 0 /POINTER TO THE FIRST ARGUMENT PB2ARG, B2ARG /POINTER TO THE BEGINNING OF THE /SYSTEM SUBROUTINES WITH TWO /ARGUMENTS. A2P, 0 /POINTER TO THE SECOND ARGUMENT PB3ARG, B3ARG /POINTER TO THE BEGINNING OF THE /SYSTEM SUBROUTINES WITH THREE /ARGUMENTS. A3P, 0 /POINTER TO THE THIRD ARGUMENT POBJ, OBJ /POINTER TO OBJECT. PSOBJ, SOBJ /POINTER TO THE SYSTEM OBJECT LIST PBEG, LBEG /POINTER TO THE BEGINNING OF /THE LIST SPACE LLEN, LBEG-LEND /-LENGTH OF THE LIST SPACE PSYMT, SYMT /POINTER TO THE ATOMIC SYMBOL TABLE PDISP, DISP /POINTER TO THE DISPATCH ROUTINE PASSOC, ASSOC /POINTER TO ASSOC ROUTINE PCKUSER,CKUSER /POINTER TO ROUTINE WHICH /CHECKS TO SEE IF IT IS USER- /DEFINED. PGETARG,GETARG /POINTER TO THE ROUTINE TO /GET AN ARGUMENT. PGETTOP,GETTOP /POINTER TO GETTOP ROUTINE PCDR, CDR /POINTER TO CDR ROUTINE PGARB, GARB /POINTER TO ROUTINE WHICH /CHECKS TO SEE IF A GARBAGE /COLLECTION IS NECESSARY. PLIST1, LIST1 PLIST5, LIST5 PERR, ERR /POINTER TO THE ERROR ROUTINE PGET, GET /POINTER TO THE GET ROUTINE PPRINCC,PRINCC /POINTER TO THE PRINT CHARACTER ROUTINE PPRINT, PRINT /POINTER TO THE PRINT /S-EXPRESSION ROUTINE PREAD, READ /POINTER TO THE READ /S-EXPRESSION ROUTINE PRDPCK, RDPCK /POINTER TO THE READ AND /PACK 2 CHARACTERS ROUTINE PFETCHC,FETCHC /POINTER TO THE FETCH A /CHARACTER ROUTINE PTERPRI,TERPRI /POINTER TO THE PRINT A /CARRIAGE RETURN AND LINE /FEED ROUTINE PA1PPL1,A1PPL1 PLOOKUP,LOOKUP PCAR, CAR /POINTER TO THE CAR ROUTINE INRET, 0 /RETURN ADDRESS FROM THE /INPUT ROUTINE. /PAGE ZERO ROUTINES AND POINTERS /TELETYPE INPUT ROUTINE TTYIN, CDF CIF 0 /GO TO BUFFERED TTYIN ROUTINE. JMS I .+1 BTTY JMP I INRET /RETURN. PINSUB, INSUB /POINTER TO THE BASIC /INPUT ROUTINE. PSCR6, SCR6 /POINTER TO THE SCALE RIGHT /SIX ROUTINE 0 /THIS LOCATION IS UNUSED. PSETM2, SETM2 /POINTER TO THE ROUTINE TO /SET THE ACCUMULATOR TO -2 /LISP NUMBER ROUTINE. CHECKS TO SEE IF /ARGUMENT IS A NUMBER. RETURNS NIL IF IT /IS NOT. OTHERWISE, IT RETURNS A POINTER TO "TRUE". NUMBER, 0 TAD A1P DCA XR11 CMA TAD I XR11 SNA CLA TAD PTRUE /HAD A NUMBER JMP I NUMBER /LISP ATOM ROUTINE. CHECKS TO SEE IF THE ARGUMENT /IS AN ATOM. IF IT IS , RETURNS A POINTER TO /"TRUE". OTHERWISE, RETURNS NIL. ATOM, 0 JMS I PA1PPL1 IAC AND I TEMP1 SZA CLA TAD PTRUE /IT WAS AN ATOM. JMP I ATOM /RETURN. /POP ROUTINE. POPS THE STACK. RETURNS WITH /THE PREVIOUS CONTENTS OF THE TOP OF THE /STACK IN THE AC. POP, 0 CLA TAD SP /STACK POINTER DCA XR10 TAD I SP DCA SP /RESET THE STACK /POINTER TO POINT TO /CELL BEFORE THIS. TAD I XR10 /GET THE CONTENTS OF /THE POPPED CELL. JMP I POP /PUSH ROUTINE. PUSHES THE CONTENTS OF THE /ACCUMULATOR ON THE TOP OF THE STACK. PUSH, 0 ISZ FLIST /FLIST NOW POINTS TO THE /DATA PART OF THE NEXT FREE /CELL. DCA I FLIST /PUSH THE AC. TAD SP DCA L23 CMA TAD FLIST /AC NOW CONTAINS POINTER /TO THIS CELL. DCA SP /SAVE THE POINTER TO /TO THE TOP OF THE STACK. TAD I SP /POINTER TO THE NEXT /CELL AVAILABLE IN FREE LIST DCA FLIST /RESET FREE LIST POINTER TAD L23 /POINTER TO PREVIOUS TOP /OF STACK. DCA I SP /NOTE THAT THE STACK IS /MERELY A LIST IN THE FREE /SPACE. JMS I PGARB /SEE IF FREE SPACE IS /EXHAUSTED, AND IF SO, /INITIATE A GARBAGE COLLECT. JMP I PUSH /RETURN. /NUCEL ROUTINE. /CONS ROUTINE. GETS A NEW CELL FROM THE FREE /LIST, AND PLACES C(A1P) IN THE BOTTOM HALF, /AND PLACES C(A2P) IN THE TOP HALF. /RETURNS A POINTER TO THE CELL. NUCEL, CONS, 0 ISZ FLIST /POINT TO BOTTOM OF NEXT CELL TAD A1P DCA I FLIST /SAVE C(A1P) IN BOTTOM OF CELL CMA TAD FLIST DCA A1P /SAVE POINTER TO THIS CELL TAD I A1P /POINTER TO NEXT CELL IN /FREE SPACE. DCA FLIST /RESET THE FREE LIST POINTER TAD A2P DCA I A1P /SAVE C(A2P) IN TOP OF CELL DCA A2P JMS I PGARB /SEE IF FREE SPACE IS EXHAUSTED, /AND IF SO, INITIATE A /GARBAGE COLLECT. TAD A1P /POINTER TO THE CELL JMP I CONS /POP A1P AND EV,AND RETURN WITH A1P IN AC. LRET1, JMS POP /POP EV AND RETURN LRET2, DCA A1P /SAVE AC TEMPORARILY /POP EV, AND LOAD A1P IN AC. LRET3, JMS POP DCA EV /LOAD A1P AND RETURN LRET4, TAD A1P JMP I EV /EVALUATE SUBROUTINE EV, 0 JMS ATOM /CHECK IF IT IS AN ATOM SNA CLA JMP EV1 /HAD AN ATOM JMS I PCKUSER /SEE IF IT IS A USER-DEFINED /FUNCTION. JMP LRET4 /SYSTEM FUNCTION JMS NUMBER /HAD USER-DEFINED FUNCTION. /SEE IF IT IS A NUMBER. SZA CLA JMP LRET4 /IT WAS A NUMBER TAD L20 JMS I PLOOKUP SNL JMS I PERR /VALUE OF THIS VARIABLE /IS NOT DEFINED. JMP I EV /RETURN PROU9, ROU9 PFEXPR, FEXPR /DISPATCH ROUTINE. CALLED BY EVALQUOTE, WITH /A POINTER TO THE FIRST S-EXPRESSION IN A1P /AND A POINTER TO THE SECOND S-EXPRESSION IN A2P. DISP, 0 TAD DISP DCA EV /SAVE RETURN ADDRESS. TAD A2P /POINTER TO SECOND /S-EXPRESSION DISP14, DCA L33 CLA CMA JMP EV2 EV1, TAD A1P DCA L31 TAD I TEMP1 DCA A1P TAD I L31 DCA L33 EV2, DCA L32 TAD A1P /POINTER TO 1ST S-EXPRESSION EV3, SNA JMP I EV /NIL FUNCTION-RETURN NIL DCA A1P JMS NUMBER /SEE IF 1ST ARGUMENT WAS /A NUMBER SZA CLA JMS I PERR /ERROR- A NUMBER IS /STANDING IN THE PLACE OF /A FUNCTION TAD I A1P DCA A2P JMS ATOM SNA CLA JMP EV4 /NOT AN ATOM JMS I PCKUSER /SEE IF USER-DEFINED JMP EV5 /SYSTEM-DEFINED FUNCTION TAD L22 /USER-DEFINED JMS I PLOOKUP SZL JMP EV3 TAD PFEXPR DCA A2P TAD L31 DCA A1P JMS I PGET SNL JMP I PROU9 DCA L31 TAD ALP /GET ASSOCIATION LIST POINTER DCA A1P DCA A2P JMS NUCEL /PUT A1P AND A2P IN A CELL DCA A2P /SAVE POINTER TO THIS CELL TAD L33 DCA A1P JMS NUCEL DCA L33 TAD L31 DCA A1P JMP EV1-2 T, JMS I PGETARG DCA A1P JMP EV+1 PSYSSUBS,SYSSUBS K33, 33 EV5, TAD PSYSSUBS CLL CML CIA TAD A1P SZL CLA JMP I A2P TAD EV JMS PUSH /PREPARE FOR RECURSION TAD A1P JMS PUSH JMS I PLIST1 JMS POP DCA L31 TAD K33 DCA XR11 JMP EV7 EV6, TAD L33 SNA JMS I PERR /BUILT IN FUNCTION HAS /TOO FEW ARGUMENTS DCA XR10 TAD I L33 DCA 33 TAD I XR10 DCA I XR11 EV7, TAD I XR11 CLL CML CIA TAD L31 SNL CLA JMP EV6 TAD L33 SZA CLA JMS I PERR /BUILT-IN FUNCTION HAS /TOO MANY ARGUMENTS TAD I L31 DCA TEMP1 /SAVE ADDRESS OF FUNCTION JMS I TEMP1 /GO TO BUILT-IN FUNCTION JMP LRET2 /RETURN EVA4, TAD L33 JMS PUSH TAD EV JMS PUSH ISZ L32 JMP EVA1 JMS EV DCA A1P JMS POP DCA EV JMS POP JMP DISP14 EVA1, JMS EV DCA A1P JMS POP DCA EV JMS POP JMP EV2-1 EV4, TAD I TEMP1 CLL CML CIA TAD PSOBJ SNA JMP EVA19 TAD K4 SZA CLA JMP I PEVA4 JMS PUSHA JMS I PLIST1 JMS I PGETTOP TAD I TEMP1 DCA ALP TAD I XR10 DCA I L23 JMP EVA6 PEVA4, EVA4 K3600, 3600 FUNC1, TAD L22 JMS I PLOOKUP SNL JMS I PERR /ERROR-THIS FUNCTIONAL /ARGUMENT IS NO FUNCTION. SKP /LIPS FUNCTI ROUTINE. FUNCTI, JMS I PGETARG DCA A1P JMS ATOM SZA CLA JMP FUNC1 TAD I A1P DCA A1P TAD ALP DCA A2P JMS NUCEL DCA A2P TAD K3600 DCA A1P JMS NUCEL JMP I EV /PUSHA ROUTINE PUSHA, 0 TAD EV JMS PUSH TAD ALP JMS PUSH TAD A2P JMS PUSH JMP I PUSHA /LISP PROG ROUTINE. PROG, TAD L33 DCA A2P DCA L33 EVA19, JMS PUSHA JMS I PLIST1 EVA6, JMS I PGETTOP TAD TEMP1 DCA L31 TAD I TEMP1 DCA TEMP1 EVA11, TAD I XR10 SNA JMP EVA8 DCA XR10 TAD I XR10 DCA A1P TAD L33 SZA JMP EVA9 TAD I TEMP1 SZA CLA JMP EVA10 JMS I PERR /ERROR-LAMBDA FORM HAS /TOO FEW ARGUMENTS. EVA9, DCA XR11 TAD I L33 DCA L33 TAD I XR11 EVA10, DCA A2P JMS NUCEL JMS I PSETM2 TAD XR10 DCA XR10 TAD ALP DCA A2P JMS NUCEL DCA ALP JMP EVA11 EVA8, TAD L33 SZA CLA JMS I PERR /LAMBDA FORM AHS TOO /MANY ARGUMENTS. TAD I TEMP1 SZA CLA JMP EVA12 ISZ TEMP1 TAD I TEMP1 DCA A1P JMP EVA13 EVA12, TAD TEMP1 JMS PUSH EVA14, JMS I PGETTOP SNL JMP EVA15 TAD I TEMP1 DCA I L23 TAD I XR10 DCA A1P JMS ATOM SNA JMS EV JMP EVA14 /CKPROG ROUTINE CKPROG, 0 TAD I EV CIA TAD CKPROG-1 SZA CLA JMS I PERR /ERROR-GO,RETURN,OR COND /WITH UNDEFINED VALUE HAS /BEEN ENCOUNTERED OUTSIDE OF /A PROG. JMP I CKPROG /LISP GO ROUTINE. GO, JMS CKPROG JMS I PGETARG DCA A2P TAD I SP DCA XR10 TAD I XR10 DCA A1P JMS I PGET SNL JMS I PERR /ERROR-GO HAS UNKNOWN /LABEL JMS I PGETTOP TAD A1P DCA I L23 JMP EVA14 /LISP RETURN ROUTINE RETURN, JMS CKPROG JMS I PGETARG EVA15, DCA A1P JMS POP EVA13, JMS POP EVAL1, JMS EV EVAL2, DCA A1P JMS POP DCA ALP JMP LRET3 /LISP EVAL ROUTINE EVAL, 0 TAD EVAL JMS PUSH TAD ALP JMS PUSH TAD A2P DCA ALP JMP EVAL1 /LISP APPLY ROUTINE. APPLY, 0 TAD APPLY JMS PUSH TAD ALP JMS PUSH TAD A3P DCA ALP JMS I PDISP JMP EVAL2 /LISP COND ROUTINE COND, TAD EV JMS PUSH TAD L33 JMS PUSH JMP COND1 COND3, JMS I PGETTOP TAD I TEMP1 DCA I L23 COND1, JMS I PGETTOP SNL JMP COND2 TAD I XR10 DCA XR10 TAD I XR10 DCA A1P JMS EV SNA CLA JMP COND3 JMS I PGETTOP TAD I XR10 DCA A1P TAD I A1P DCA XR10 TAD I XR10 COND2, DCA A1P JMS POP JMS POP DCA EV SZL JMP EV+1 JMS I PCKPROG JMP I EV PCKPROG,CKPROG /LISP LIST ROUTINE. LIST, TAD EV LIST6, DCA LIST1 SKP LIST1, 0 TAD L33 ISZ L32 /IF L32 IS -1 RETURN. SNA /IF L33 IS 0 RETURN JMP I LIST1 JMS PUSH LIST2, JMS I PGETTOP TAD LIST1 DCA I L23 SNL JMP LIST4 TAD I XR10 DCA A1P TAD I TEMP1 JMS PUSH JMS EV DCA LIST1 JMP LIST2 LIST3, TAD L33 DCA I A1P TAD A1P LIST4, DCA L33 LIST5, TAD SP DCA A1P JMS POP DCA TEMP1 TAD TEMP1 CLL CML CIA SZA TAD PSOBJ SNL SNA CLA JMP LIST3 TAD L33 JMP I TEMP1 /LISP SET ROUTINE. SET, 0 TAD A2P DCA L33 TAD ALP /ASSOCIATION LIST POINTER DCA A2P JMS I PASSOC SNA JMS I PERR /ERROR- FIRST ARGUMENT OF /SET OR SETQ IS NOT ATOMIC DCA TEMP1 TAD L33 DCA I TEMP1 TAD L33 JMP I SET /RETURN /LISP SETQ ROUTINE SETQ, TAD EV JMS PUSH TAD L33 DCA XR10 TAD I L33 DCA L33 TAD I XR10 JMS PUSH JMS I PGETARG DCA A1P JMS EV DCA A2P JMS POP DCA A1P JMS SET JMP LRET2 /RETURN /LISP CDR ROUTINE. CDR, 0 TAD A1P SZA CLA TAD I A1P /GET CDR JMP I CDR /RETURN. /LISP STOP ROUTINE. STOP, HLT JMP I EV /RETURN TO EVALQUOTE /WHEN CONTINUE PUSHED. /LISP QUOTE ROUTINE QUOTE, JMS GETARG JMP I EV /LISP RPLACAR ROUTINE. REPLACE THE CAR PART. RPLACA, 0 JMS ATOM SZA CLA IAC TAD A2P DCA I TEMP1 TAD A1P JMP I RPLACA /GETARG ROUTINE. GETARG, 0 CLA CMA /-1 IN AC TAD L33 DCA XR10 TAD I L33 ISZ XR10 SZA CLA JMS I PERR /ERROR-WRONG NUMBER OF /ARGUMENTS IN THIS FUNCTION TAD I XR10 JMP I GETARG /LISP EQ ROUTINE. EQ, 0 JMS NUMBER /SEE IF ARGUMENT IS A NUMBER SZA CLA JMS SWAP JMS NUMBER SZA CLA JMP EQ1 TAD A1P CIA TAD A2P JMP EQ2 EQ1, TAD I A1P CIA TAD I A2P EQ2, SNA CLA /SKIP IF NOT EQUAL TAD PTRUE /POINTER TO "T" JMP I EQ /LISP NULL ROUTINE. NULL, 0 DCA A2P JMS EQ JMP I NULL /SWAP ROUTINE. SWAPS A1P AND A2P. SWAP, 0 TAD A1P DCA XR11 TAD A2P DCA A1P TAD XR11 DCA A2P JMP I SWAP /LISP EQUAL ROUTINE. EQUAL, 0 TAD EQUAL JMS PUSH /PREPARE FOR RECURSION EQUAL2, JMS ATOM SNA CLA JMS SWAP JMS ATOM SNA CLA JMP EQUAL1 JMS EQ JMP LRET2 EQUAL1, TAD I A1P JMS PUSH TAD I A2P JMS PUSH TAD I XR11 DCA A1P TAD I TEMP1 DCA A2P JMS EQUAL DCA A3P JMS POP DCA A1P JMS POP DCA A2P TAD A3P SZA CLA JMP EQUAL2 JMP LRET2 /LISP GET ROUTINE. GET, 0 GET1, JMS I PCKUSER JMP I GET TAD A1P DCA XR10 TAD I A1P DCA A1P TAD I XR10 CLL CIA TAD A2P SZA CLA JMP GET1 TAD A1P DCA XR11 TAD I XR11 JMP I GET /LISP ASSOC ROUTINE. ASSOC, 0 ASSOC1, CLA CLL TAD A2P SNA JMP I ASSOC /RETURN DCA XR10 TAD I A2P DCA A2P TAD I XR10 DCA XR10 TAD I XR10 CIA TAD A1P SZA JMP ASSOC1 CLL CMA TAD XR10 JMP I ASSOC /RETURN /LOOKUP ROUTINE. LOOKUP, 0 DCA L23 TAD ALP DCA A2P JMS ASSOC /LOOK UP THE 1ST ARG SNL JMP LKUP1 DCA TEMP1 TAD I TEMP1 JMP I LOOKUP LKUP1, TAD A1P DCA L31 TAD L23 DCA A2P JMS GET JMP I LOOKUP /LISP RPLACDR ROUTINE. REPLACE CDR PART. RPLACD, 0 TAD A2P DCA I A1P TAD A1P JMP I RPLACD /LISP DEFLIS ROUTINE. DEFLIS, 0 TAD DEFLIS JMS PUSH TAD A2P DCA A3P DEFL2, TAD A1P DCA L31 JMS I PCKUSER JMP I PLIST5 JMS I PCAR DCA A1P TAD A1P DCA A2P JMS I PCAR DCA A1P TAD A3P DCA I TEMP1 JMS ATOM SNA CLA JMS I PERR /ERROR-FIRST ELEMENT OF A /PAIR IN DEFINE OF DEFLIS /IS NOT A NAME. JMS I PCKUSER JMP DEFL4 TAD I A1P DCA L33 JMS RPLACD JMS PUSH TAD I A2P DCA A2P TAD L33 DCA XR10 TAD I XR10 CIA TAD A3P SZA CLA JMP DEFL1 TAD I L33 DCA L33 TAD I L33 SKP DEFL1, TAD L33 DCA I A2P DEFL3, TAD I L31 DCA A1P JMP DEFL2 DEFL4, TAD I TEMP1 DCA A1P JMS NUCEL JMS PUSH TAD I POBJST DCA A2P JMS NUCEL DCA I POBJST JMP DEFL3 /LISP DEFINE ROUTINE. DEFINE, 0 TAD L22 DCA A2P JMS DEFLIS JMP I DEFINE /THIS SECTION IS FOR C....R ROUTINES ROU2, 0 ISZ XR11 JMP ROU1 TAD XR10 JMS I PSCR6 ROU3, CLL CML CIA JMP I ROU2 JMS INRET /ROUTINE TO RETURN WITH /SINGLE CHARACTER+X AND /MASK THE TAPE READER. JMP I .+1 RMASK ROU1, CMA DCA XR11 TAD TEMP1 SNA JMP I ROU2 DCA XR10 TAD I TEMP1 DCA TEMP1 TAD I XR10 DCA XR10 TAD K77 AND XR10 JMP ROU3 K16, 16 KA, 43 /CONSTANT FOR "A" KC, 45 /CONSTANT FOR "C" ROU4, 0 JMS I PGETTOP CMA TAD I XR10 DCA TEMP1 IAC DCA L23 DCA XR11 JMS ROU2 TAD KC SZA CLA ROU8, JMS I PERR /ERROR-NAME IN POSITION /OF A FUNCTION WHICH IS /NOT A FUNCTION. ROU7, JMS ROU2 TAD KA SNA CML SZA TAD K3 SZA /SKIP IF D JMP ROU6 TAD L23 RAL DCA L23 JMP ROU7 ROU6, TAD K16 /46+16=64="R" SNA JMS ROU2 SZA JMP ROU8 JMP I ROU4 ROU9, TAD EV JMS PUSH TAD L31 JMS PUSH JMS ROU4 JMS I PLIST1 JMS I PGETARG DCA A1P JMS ROU4 ROU11, TAD L23 CLL RAR SZA JMP ROU10 JMS POP JMP LRET3 ROU10, DCA L23 SNL JMS I PCDR SZL JMS CAR DCA A1P JMP ROU11 PLIST6, LIST6 /PLUS1 SUBROUTINE. PLUS1, 0 DCA A2P IAC DCA A1P TAD EV JMS PUSH JMS NUCEL JMS PUSH TAD PLUS1 JMP I PLIST6 PLUS2, 0 CLA TAD L33 SNA JMP LRET1 DCA XR10 TAD I L33 DCA L33 TAD I XR10 DCA A1P JMS I PGETTOP TAD I TEMP1 JMP I PLUS2 /LISP PLUS ROUTINE. PLUS, JMS PLUS1 PLUS3, JMS PLUS2 TAD I A1P DCA I TEMP1 JMP PLUS3 /LISP MINUS ROUTINE. MINUS, JMS PLUS1 MINUS2, JMS PLUS2 TAD I A1P CIA DCA I TEMP1 JMP MINUS2 /LISP LESSP ROUTINE. LESSP, 0 TAD I A2P CLL CML CIA SMA CLL DCA L23 TAD I A1P SPA CML TAD L23 SZL CLA TAD PTRUE JMP I LESSP /LISP CAR ROUTINE CAR, 0 JMS ATOM SZA CLA JMS I PERR /ERROR-THE CAR OF AN ATOM /HAS BEEN TAKEN. JMS I PSETM2 AND I TEMP1 JMP I CAR /SCR6 ROUTINE. SCALES AC RIGHT 6 PLACES. SCR6, 0 CLL RTR CLL RTR CLL RTR STL AND K77 JMP I SCR6 /LISP EXPR ROUTINE. EXPR, 0 TAD I A1P /ADDRESS TO JUMP TO. DCA EXPR TAD I A2P /GET 2ND ARGUMENT IN AC JMP I EXPR /JUMP TO THIS ROUTINE. /GETTOP ROUTINE. PLACES THE TOP ELEMENT OF THE /STACK IN TEMP1 AND XR10 WITHOUT POPPING /THE STACK. GETTOP, 0 CLA CLL CML IAC /AC=1,LINK=1 TAD SP DCA L23 /STACK POINTER+1 TAD I L23 /ITEM ON TOP OF STACK DCA TEMP1 TAD TEMP1 SNA CLL DCA XR10 JMP I GETTOP /LISP GENSYM ROUTINE. GENSYM, 0 TAD GENSYM DCA I PREAD DCA L32 DCA L23 TAD CGENSY AND K17 DCA TEMP1 TAD CGENSY RTL AND GEN1 TAD TEMP1 TAD GEN2 DCA GEN3 TAD CGENSY RTR AND GEN1 TAD GEN2 DCA GEN4 ISZ CGENSY TAD GEN5 DCA XR10 DCA A2P JMS NUCEL DCA L33 JMP I GEN6 GEN5, GEN7 GEN6, NXTA6 GEN7, GEN4+1 GEN4, 0 0 GEN3, 0 K17, 17 GEN1, 1700 GEN2, 5151 0 0 /GARBAGE COLLECTION ROUTINES. /IF A GARBAGE COLLECTION IS NECESSARY, /THIS WILL GO THROUGH AND MARK ALL CELLS /REACHABLE FROM THE OBJECT LIST,SP, /A1P,A2P,A3P,ALP,L31,AND L33. IF THE CELL /HAS THE CDR PART =1 (IMPLIES THIS IS A /NUMBER), THE SYSTEM WILL CHANGE THE 1 TO A 5. /OTHERWISE,THIS WILL SET THE RIGHT-MOST /BIT OF THE CDR PART TO 1. WHEN ALL /REACHABLE CELLS HAVE BEEN MARKED, THE COLLECTION /STARTS. ALL CELLS WITH CDR PART 1 WILL BE /COLLECTED (UNMARKED NUMBERS), AND ALL CELLS /WITHOUT THE RIGHTMOST BIT OF THE CDR PART /SET WILL BE COLLECTED. THE OTHER CELLS /WILL BE UNMARKED. PAGE GL1, 0 /POINTER TO THE NEXT CELL /IN THE OBJECT LIST. GL2, 0 KM4, -4 GARB4, TAD K5 /CELL IS A NUMBER /REPLACE THE 1 WITH 5. DCA I GL2 GARB3, CLA CLL CMA /-1 IN AC TAD XR12 DCA GL2 TAD I GL2 /MOVE TO NEXT CELL IN /OBJECT LIST. SNA JMP I GMARK DCA GL1 /POINTER TO NEXT CELL /IN OBLIST DCA I GL2 CMA TAD GL2 DCA XR12 GARB2, JMS GMARKS SZA JMP GARB5 GARB6, TAD I GL2 RAR SNL JMP GARB7 CLL RAL DCA GL1 JMS GMARKS JMP .-2 GMARK, 0 SKP GARB7, RAL DCA GL1 JMP GARB2 GARB5, DCA I XR12 TAD I XR12 SZA CLA JMP GARB6 /PRINT ERROR SYMBOL GAR4, TAD KCAT /NOW HAVE EITHER SYMBOL /FOR "@" OR "?" IN AC JMS I PPRINCC HLT JMP I .+1 /REINITIALIZE WHEN CONTINUE /IS PRESSED. INIT2+4 KCAT, 42 /CHARACTER FOR "@" /ROUTINES CALL GARB TO SEE IF FREE SPACE IS /EXHAUSTED. IF IT IS,GARB INITIATES A /GARBAGE COLLECT. GARB, 0 TAD FLIST SZA CLA JMP I GARB /STILL ROOM LEFT. RETURN ISZ GCCNT /INCREMENT GARBAGE /COLLECTOR COUNT AND /START GARBAGE COLLECTION. NOP TAD PSYMT DCA XR12 /POINTER TO THE SYSTEM /ATOMIC SYMBOL TABLE TAD PL23 DCA GLCNT TAD I POBJST /POINTER TO THE /START OF THE OBJECT LIST /FIRST MARK CELLS POINTED TO BY THE OBJECT LIST /THEN MARK CELLS POINTED TO BY ALP,SP,L31,L33, /A1P,A2P,AND A3P. JMP GARB1 PL23, L23 KMA3P, -A3P /TO SEE IF AT END OF POINTERS. GLCNT, 0 GARB8, ISZ GLCNT ISZ GLCNT TAD I GLCNT GARB1, JMS GMARK /MARK THE CELLS TAD GLCNT TAD KMA3P SZA CLA JMP GARB8 /HAVE NOW MARKED ALL THE CELLS. NOW COLLECT AND /UNMARK. TAD LLEN CLL CML RAR /LENGTH/2 DCA GL1 /NEGATIVE COUNT OF NUMBER /OF CELLS IN FREE LIST TAD PBEG DCA XR12 /XR12 POINTS TO THE NEXT /CELL TO EXAMINE TAD XR12 DCA XR13 /XR13 POINTS TO THE CURRENT /CELL. GAR3, TAD I XR12 DCA GL2 CMA TAD I XR12 SNA JMP GARB9 /COLLECT THE CELL TAD KM4 SZA CLA JMP GAR1 /SEE IF BIT 11 IS MARKED ISZ XR13 /REPLACE 5 WITH 1 IAC JMP GAR2 /CHECK IF BIT 11 IS MARKED,AND IF NOT, /COLLECT THE CELL. GAR1, TAD GL2 RAR SNL JMP GARB9 /CELL WAS NOT MARKED. COLLECT. CLL RAL /UNMARK CELL. DCA I XR13 ISZ XR13 GAR5, ISZ GL1 /INCREMENT COUNT OF CELLS /STILL TO GO THROUGH. JMP GAR3 TAD FLIST /DONE COLLECTING. SZA CLA JMP I GARB /RETURN CLA CMA /NO MORE FREE SPACE. /PRINT "?" AND HALT JMP GAR4 /COLLECT THE CELL. GARB9, CLA TAD FLIST DCA I XR13 TAD XR13 DCA FLIST GAR2, DCA I XR13 /ZERO CAR PART JMP GAR5 GMARKS, 0 TAD GL1 CLL CML CIA TAD PBEG SNL CLA JMP GARB3 /POINTS TO SYSTEM AREA- /DON'T MARK. IAC TAD GL1 DCA GL2 /POINTS TO SECOND WORD /OF CELL. CMA TAD I GL2 /POINTER TO NAME. SNA JMP GARB4 /VALUE WAS 1.THIS CELL /IS A NUMBER. REPLACE BY 5. TAD KM4 SNA CLA JMP GARB3 /VALUE WAS 5. CELL /IS ALREADY MARKED. TAD I GL1 RAR SZL JMP GARB3 /CELL IS ALREADY MARKED RAL /NOT MARKED-MARK IT. ISZ I GL1 JMP I GMARKS /PRINT NAME OF ATOM ROUTINE. PRINTB, DCA L23 DCA A3P TAD L23 /POINTER TO ATOM PRINTD, DCA TEMP1 TAD I TEMP1 ISZ A3P SZA ISZ A3P SZA JMP PRINTD ISZ TEMP1 TAD I TEMP1 AND KKM100 /AND WITH 7700 TO GET /SECOND CHARACTER. SZA CLA ISZ A3P TAD A3P JMS PROOM /SEE IF THERE IS ROOM /ON THIS LINE FOR THE /ATOM PRINTE, TAD L23 SNA JMP PRINTF /NIL-SO RETURN /FROM PRINTING ATOM DCA XR10 TAD I L23 DCA L23 TAD I XR10 JMS PRINTC /PRINT THE ONE OR TWO /CHARACTERS IN ACCUMULATOR JMP PRINTE /GET NEXT PAIR OF CHARACTERS. KKM100, -100 KLOC, KLOC /TABLE USED IN CONVERTING /A NUMBER TO 4 CHARACTERS. K1000, 1750 /THESE 3 LOCATIONS ARE CHANGED K100, 144 /FOR OCTAL PRINTING K10, 12 0 /THIS TERMINATES THE TABLE PRINTA, CLL CMA CML /PRINT ATOM ROUTINE- /FIRST SEE IF ATOM IS /A NUMBER. TAD I TEMP1 /IF IT IS A NUMBER, POINTER /WILL BE 1. SZA JMP PRINTB /NOT A NUMBER. TAD I A1P /HAD A NUMBER. GET IT. SPA PRNTA5, CML CIA /***THIS IS CHANGED FOR /***PRINTING WITHOUT SIGN. DCA L23 /SAVE THE NUMBER. TAD KLOC /TABLE POINTER DCA L33 SZL TAD KMIN /HAD A NEGATIVE NUMBER. DCA TEMP1 /STORE CHARACTER FOR SIGN DCA A2P SNL /SKIP IF NEGATIVE NUMBER. PRNTA1, ISZ A2P ISZ L33 TAD I L33 /GET NUMBER YOU ARE /GOING TO SUBTRACT. CLL CIA TAD L23 /ADD OUR NUMBER. SNL CLA JMP PRNTA1 /THE SUBTRACTION /CONSTANT WAS TOO LARGE. TAD A2P /WE HAVE USED A2P /TO TELL HOW MANY DIGITS /WE WILL HAVE TO PRINT. CIA TAD K5 JMS PROOM /SEE IF THERE IS ROOM /ON THE CURRENT LINE /TO PRINT THE NUMBER. JMP PRNTA2 KMIN, 17 /CHARATER FOR "-" K21, 21 /(CHARACTER FOR 0)-1 PRNTA3, CLL CML CIA TAD L23 SNL DCA L23 SNL CLA JMP PRNTA4 ISZ L33 PRNTA2, TAD TEMP1 JMS PRINTC /PRINT THE SIGN TAD K21 DCA TEMP1 PRNTA4, ISZ TEMP1 TAD I L33 SZA JMP PRNTA3 TAD L23 TAD TEMP1 JMS PRINTC /RETURN FROM PRINT ROUTINE PRINTF, TAD A1P JMP I PRINT KM3, -3 KM27, -27 K236, 236 POUTCH, OUTSUB /PRINTC ROUTINE. DECODES THE CHARACTER /IN THE RIGHT-HAND 6 BITS OF AC, /AND PRINTS IT. DECODES THE CHARACTER /IN THE LEFT-HAND 6 BITS OF AC, /AND PRINTS IT. IGNORES ZEORES. PRINTC, 0 SNA JMP I PRINTC /RETURN IF ZERO. DCA POP /SAVE TEMPORARILY TAD POP AND K77 DCA TEMP1 TAD TEMP1 /NOW CONVERT THE CHARACTER /TO ASCII FROM THE INTERNAL /CODE. TAD KM3 SZA /SKIP IF 3 (I.E. IF /IT IS A LINE FEED) TAD KM3 SNA CLA /SKIP IF IT IS NOT /A CARRIAGE RETURN OR /LINE FEED. TAD KM27 TAD TEMP1 /ADD CHARACTER TAD K236 /NOW HAVE ASCII CHARACTER JMS I POUTCH /GO TO THE OUTPUT ROUTINE CLA TAD POP JMS I PSCR6 /NOW HAVE 2ND CHARACTER /IN RIGHT-HAND 6 BITS. JMP PRINTC+1 /TERPRI ROUTINE. PRINTS A CARRIAGE RETURN /AND A LINE FEED. TERPRI, 0 TAD KKM100 DCA LINCNT /REINITIALIZE THE LINE COUNT TAD K306 JMS PRINTC /PRINT CARRIAGE RETURN /AND LINE FEED. JMP I TERPRI K306, 306 /INTERNAL CODE FOR CARRIAGE /RETURN AND LINE FEED. /ROUTINE TO PRINT A SINGLE CHARACTER WHOSE /INTERNAL REPRESENTATION IS IN X. JMS I PPRINCC JMP LRET2 /ROUTINE TO SEE IF THERE IS ROOM ON THE /CURRENT LINE FOR THE PRINTING WHICH IS /NECESSARY. ENTER WITH THE NUMBER OF /CHARACTERS NECESSARY TO PRINT. PROOM, 0 TAD LINCNT DCA LINCNT /LINCNT IS MODIFIED /BY THE CONTENTS OF /THE AC ON ENTRY TO PROOM TAD LINCNT SPA CLA /SKIP IF NOT ENOUGH /ROOM ON CURRENT LINE. JMP I PROOM /RETURN JMS TERPRI /GO TO A NEW LINE. SKP /LISP PRINT ROUTINE. /WILL PRINT THE S-EXPRESSION POINTED TO /BY A1P. PRINT, 0 JMS ATOM /SEE IF IT IS AN ATOM SZA CLA JMP PRINTA /IT WAS AN ATOM TAD PRINT /NOT AN ATOM. PREPARE /FOR RECURSION. JMS PUSH TAD A1P JMS PUSH /HAVE NOW SAVED /RETURN AND POINTER /TO S-EXPRESSION. TAD KLP JMS PRINCC /PRINT A LEFT PARENTHESIS TAD A1P JMP PRINT1 KLP, 12 /INTERNAL CODE FOR LEFT /PARENTHESIS KRP, 13 /INTERNAL CODE FOR RIGHT /PARENTHESIS KPER, 20 /INTERNAL CODE FOR PERIOD. /PRINCC ROUTINE. WILL PRINT A CHARACTER AND /INCREMENT COUNT. PRINCC, 0 ISZ LINCNT JMP PRINC1 /NOT AT END OF LINE DCA L23 /AT END OF A LINE. /SAVE THE CHARACTER /TEMPORARILY. JMS I PTERPRI /PRINT A C.R. AND L.F. TAD L23 /RESTORE CHARACTER SNA JMP I PRINCC /HAD A BLANK AT END OF /LINE. DO NOT PRINT IT. ISZ LINCNT /INCREMENT LINE COUNT PRINC1, SNA TAD K2 /HAD A BLANK- CHANGE TO /THE OTHER CODE FOR BLANK JMS I PPRIN /PRINT THE CHARACTER JMP I PRINCC /RETURN PPRIN, PRINTC PRINT4, JMS I PPRINT /CALL PRINT AGAIN. /HAD ATOM IN A LIST. JMS POP PRINT1, JMS PRTERM /PRINT THE NEXT TERM SNA CLA /SKIP IF NOT ATOM. JMP PRINT4 /HAD ATOM PRINT5, JMS I PPRINT /CALL PRINT AGAIN JMS POP JMS PRTERM SNA CLA JMP PRINT4 /HAD ATOM JMS PRINCC /PRINT THE CHARACTER JMP PRINT5 PRTERM, 0 SNA JMP PRINT3 /AT END OF A SUBEXPRESSION, /SO PRINT A RIGHT PARENTHESIS DCA A1P JMS ATOM SZA CLA JMP PRINT2 /HAD AN ATOM-PRINT /A PERIOD. TAD I A1P /NOT AN ATOM JMS PUSH TAD I TEMP1 DCA A1P JMS ATOM JMP I PRTERM /RETURN PRINT2, TAD KPER /PRINT A PERIOD JMS PRINCC JMS I PPRINT /CALL PRINT ROUTINE AGAIN CLA PRINT3, TAD KRP /PRINT A RIGHT PARENTHESIS JMS PRINCC JMP LRET1 /POP AND RETURN /FETCHC WILL USE THE BASIC INPUT ROUTINE /TO READ A CHARACTER. THEN IT WILL /CONVERT THE CHARACTER TO THE SPECIAL /SIX-BIT INTERNAL CHARACTER CODE. /FOR ASCII CHARACTERS WITH A CODE OF LESS /THAN 236, THE INTERNAL CODE IS FOUND /BY SUBTRACTING 207. /FOR ASCII CHARACTERS WITH A CODE OF /GREATER THAN OR EQUAL TO 236, THE INTERNAL /CODE IS FOUND BY SUBTRACTING 236. /THIS SUBROUTINE RETURNS TO THE LOCATION /AFTER THE CALL IF LEADER-TRAILER WAS FOUND /AND RETURNS TO THE SECOND LOCATION AFTER /THE CALL FOR ANY OTHER CHARACTER. /ON RETURN, THE CHARACTER WILL BE BOTH /IN THE ACCUMULATOR AND IN THE LOCATION /CHAR. /CONSTANTS USED. PCHMODE,CHMODE /POINTER TO ROUTINE TO /CHECK THE MODE WITH THE /PARAMETER AND SKIP IF /THE APPROPRIATE BITS ARE /NOT SET. POUTSUB,OUTSUB /POINTER TO THE BASIC OUTPUT /ROUTINE. K27, 27 K141, 141 K177, 177 KM177, -177 FETCH2, TAD CHAR /HAD ASCII CODE. CONVERT /TO INTERNAL FORM. TAD KM177 SNA JMP FETCH4 /IGNORE RUBOUTS. TAD K141 SPA /SKIP IF CHARACTER /WAS >=236. TAD K27 /CHARACTER WAS <236 FETCH1, ISZ FETCHC /THE NORMAL RETURN IS /TWO LOCATIONS AFTER /THE CALL. THE LOCATION /AFTER THE CALL IS THE /RETURN FOR LEADER TRAILER /OR HEADER TAPE. SKP CNGTTY, RDASCII /THIS LOCATION IS /USED AS A TRANSFER /POINTER TO EITHER THE /CODE FOR ASCII OR THE /CODE FOR CCITT2.IT IS /INITIALLY SET FOR ASCII. DCA CHAR /SAVE THE CODED CHARACTER /IN CHAR. TAD CHAR /RETURN WITH IT ALSO /IN THE AC. JMP I FETCHC /RETURN FETCHC, 0 /THIS IS THE SUBROUTINE /ENTRY POINT. CLA TAD CHAR /IF CHAR IS NON-ZERO, SZA /THE PREVIOUS CHARACTER /READ HAS NOT YET BEEN /USED. RETURN IT. JMP FETCH1 /RETURN CHAR. FETCH4, JMS I PINSUB /GO TO THE BASIC INPUT ROUTINE AND K177 /MASK OFF HIGH-ORDER BIT. SZA JMP I CNGTTY /GO TO EITHER ASCII OR /CCITT2 SECTION. JMS CNGTTY /CHANGE POINTER TO POINT TO /ASCII SECTION. HAD LEADER-TRAILER /OR HEADER TAPE. RDASCII,DCA CHAR /SAVE MASKED CHARACTER JMP FETCH2 /ASCII /LISP TIMES ROUTINE /ACCEPTS AN INFINITE NUMBER OF ARGUMENTS. TIMES, CLA IAC /SET PRODUCT TO 1 INITIALLY JMS I PPLUS1 /SET UP CELLS FOR RETURN TLOOP, CLA TAD L33 SNA JMP LRET1 /HAD NIL POINTER. ALL OF THE /TERMS OF THE PRODUCT HAVE /BEEN USED. /RETURN. DCA XR10 TAD I L33 DCA L33 /POINT TO NEXT ARGUMENT. TAD I XR10 /GET ADDRESS OF ARGUMENT. DCA A1P JMS I PGETTOP TAD I TEMP1 /GET PREVIOUSLY SAVE PRODUCT. DCA A2P /SAVE PREVIOUS VALUE TAD I A1P /GET CURRENT ARGUMENT JMS MULT /GET PRODUCT DCA I TEMP1 /SAVE RESULT AS NEW PRODUCT JMP TLOOP PPLUS1, PLUS1 MULT, 0 DCA A1P TAD KM14 DCA FETCHC MULTL, CLL RAL DCA A3P /TEMPORARY RESULT TAD A1P CLL RAL DCA A1P SZL TAD A2P /BIT WAS 1, SO ADD. TAD A3P ISZ FETCHC JMP MULTL /LOOP NOT DONE. JMP I MULT /RETURN KM14, -14 /LISP EXIT ROUTINE. RETURNS TO PS/8 /MONITOR AT 7600. EXIT, CDF CIF 0 JMP I .+1 7600 /LOCATION OF MONITOR. /IOPEN ROUTINE. /HAS THREE ARGUMENTS. IOPEN, 0 CDF CIF 0 JMS I .+1 IOPENR /GET A CHARACTER FROM THE OPEN INPUT /FILE ROUTINE. RETURNS WITH THE /CHARACTER IN THE ACCUMULATOR. GCHAR, 0 CDF CIF 0 JMS I PGTCHAR JMP I INRET /RETURN. PGTCHAR,GTCHAR /WRITE A CHARACTER FROM THE AC TO THE /OPEN OUTPUT FILE ROUTINE. RETURNS /WITH THE ACCUMULATOR UNCHANGED. PCHAR, 0 CDF CIF 0 JMS I PPTCHAR JMP I PCHAR PPTCHAR,PTCHAR /POINTER TO THE ROUTINE. /OOPEN ROUTINE. /HAS THREE ARGUMENTS. OOPEN, 0 CDF CIF 0 JMS I .+1 OOPENR /ICLOSE ROUTINE. /HAS NO ARGUMENTS. ICLOSE, 0 CDF CIF 0 JMS I .+1 ICLOSR /POINTER TO ICLOSE ROUTINE /OCLOSE ROUTINE. /HAS NO ARGUMENTS. OCLOSE, 0 CDF CIF 0 JMS I .+1 OCLOSR /POINTER TO OCLOSE ROUTINE KM20, -20 0 /UNUSED****************** /THE RDTST ROUTINE WILL USE THE FETCHC /ROUTINE TO READ A CHARACTER. IT WILL RETURN /TO THE LOCATION AFTER THE CALL IF A /DELIMITER IS FOUND, AND WILL RETURN TO TWO /LOCATIONS AFTER THE CALL OTHERWISE. /IF NO DELIMITER WAS FOUND, RDTST RETURNS /WITH THE CHARACTER IN THE ACCUMULATOR. /A ZERO IMPLIES THAT A QUOTE WAS FOUND. /IF A DELIMITER WAS FOUND, THE ACCUMULATOR /WILL BE ZERO, AND A3P WILL POINT /TO THE ROUTINE FOR THE DELIMITER FOUND. RDTST, 0 JMS I PFETCHC /FETCH A CHARACTER JMS I PERR /ERROR- LEADER-TRAILER /CANNOT OCCUR IN A /LISP EXPRESSION. /NOW CHECK TO SEE IF THE CHARACTER IS A DELIMITER TAD KM20 SNA JMP RDTST2 /HAD A PERIOD TAD K5 SNA JMP RDTST1 /HAD A CLOSING PARENTHESIS IAC SZA JMP RDTST5 IAC /HAD AN OPENING PARENTHESIS RDTST1, IAC /HAD CLOSING PARENTHESIS RDTST2, IAC /HAD PERIOD RDTST3, TAD PREAD6 /HAD INTERNAL CODE OF 10 /OR LESS. DCA A3P /SAVE POINTER TO APPROPRIATE /JUMP INSTRUCTION. JMP I RDTST /RETURN PREAD6, READ6 /POINTER TO FIRST OF JUMPS. RDTST5, IAC SNA JMP RDTST6 /HAD QUOTE SPA CLA JMP RDTST3 /HAD INTERNAL CODE OF /10 OR LESS, E.G. CARRIAGE /RETURN OR LINE FEED OR BLANK. TAD CHAR /NO DELIMITER. PUT CHARACTER /IN ACCUMULATOR RDTST6, ISZ RDTST /SKIP DELIMITER RETURN JMP I RDTST /RETURN /READ WILL READ IN AN S-EXPRESSION. /IT IS A FUNCTION OF NO ARGUMENTS. /ALL IDENTIFIERS READ FOR THE FIRST TIME /ARE PUT ON THE OBLIST. IDENTIFIERS MAY /CONSIST OF ANY NUMBER OF CHARACTERS /AND ANY CHARACTER EXCEPT LEFT PARENTHESIS, /RIGHT PARENTHESIS,DOT,SPACE,CARRIAGE /RETURN,LINE-FEED, BLANK, AND APOSTROPHE. /HOWEVER, THESE CHARACTERS CAN BE /"QUOTED" BY PRECEDING THEM WITH ' /THEN, THEY MAY BE A CHARACTER OF A NAME. /A NAME MUST START WITH A LETTER. AN /OBJECT STARTING WITH A DIGIT OR /A PLUS SIGN OR A MINUS SIGN IS REGARDED /AS A NUMBER (EXCEPT WHEN PRECEDED BY ' ). READ2, DCA CHAR /COME HERE WHEN A /DELIMITER IS FOUND. JMP I A3P /RDTST PLACED A JUMP /TO THE APPROPRIATE /DELIMITER ROUTINE IN /A3P. /NOW GO TO THIS ROUTINE. READ6, JMP READ1 /DELIMITER WAS A C.R. /OR L.F. OR SPACE JMP READ7 /DELIMITER WAS PERIOD. JMP READ9 /DELIMITER WAS RIGHT /PARENTHESIS TAD READ /DELIMITER WAS RIGHT /PARENTHESIS. JMP READ8 READ7, JMS READ /HAD PERIOD. READ5, DCA L33 JMS READ READ8, JMS PUSH /HAD (, SO PUSH /PREVIOUS VALUE OF READ, /AND GO READ AGAIN. JMP READ5 PREAD8, READ8 READ9, TAD READ /HAD ')' CIA TAD PREAD8 SZA /SKIP IF CLOSING PARENTHESIS /RIGHT AFTER OPENING /PARENTHESIS. JMS I PERR /ERROR-CLOSING PARENTHESIS /CANNOT OCCUR HERE. JMP I PLIST5 K4012, 4012 K3744, 3744 READ, 0 CLA CMA DCA TEMP1 /-1 IN TEMP1 /-1 INDICATES THAT THE NUMBER /DOES NOT NEED TO BE COMPLEMENTED. /IF A MINUS SIGN IS FOUND, /THIS IS CHANGED TO ZERO. READ1, JMS RDTST /GET A CHARACTER,AND SEE /IF IT IS A DELIMITER. JMP READ2 /HAD A DELIMITER /SEE IF IT WAS A NUMBER TAD K3744 SMA TAD K4012 SPA JMP RDEXP /NOT A NUMBER. /HAD A DIGIT OR PLUS OR MINUS, SO KEEP PICKING /UP DIGITS TILL NUMBER IS COMPLETE. NO CHECK /IS MADE FOR OVERFLOW OR UNDERFLOW. RDNUM, DCA A2P DCA CHAR /ZERO CHAR SO NEXT CHARACTER /CAN BE READ. JMS I PFETCHC /READ NEXT CHARACTER JMS I PERR /ERROR- LEADER TRAILER /AFTER A NUMBER HAS BEEN FOUND. /NOW SEE IF THIS IS ALSO A DIGIT. TAD K3744 SMA TAD K4012 SPA JMP READD /AT END OF NUMBER DCA A1P /HAD ANOTHER DIGIT /MULTIPLY PREVIOUS NUMBER BY 10 (OR 8 FOR OCTAL) TAD A2P CLL RTL RDNUM1, TAD A2P /THIS IS CHANGED TO A NOP /FOR OCTAL READING. CLL RAL /NOW HAVE 10 (OR 8) /TIMES THE PREVIOUS NUMBER TAD A1P /NOW ADD THIS DIGIT JMP RDNUM READD, CLA IAC /HAVE COMPLETED THE NUMBER DCA A1P TAD A2P ISZ TEMP1 /SKIP IF NO MINUS SIGN CIA /HAD A MINUS SIGN. DCA A2P JMS NUCEL /BOTTOM HALF IS 1 IF /CELL IS A NUMBER. /TOP HALF CONTAINS THE /ACTUAL NUMBER. JMP I READ /RETURN WITH AC POINTING /TO THE CELL CONTAINING THE /NUMBER. RDEXP1, TAD CHAR /HAD A PLUS SIGN OR /A MINUS SIGN TO /GET HERE. DCA L32 DCA CHAR JMS RDTST /READ THE NEXT CHARACTER JMP RDEXP2 /HAD A DELIMITER-A PLUS / BY ITSELF IS A VALID /NAME. JMP READ1 /NO DELIMITER, SO IT MUST /BE A NUMBER, SO IGNORE /THE PLUS OR MINUS SIGN. RDEXP, TAD K3 /SEE IF IT WAS A /MINUS SIGN. SNA ISZ TEMP1 /HAD A MINUS SIGN. /THEN SKIP THE NEXT /INSTRUCTION. TAD K2 /SEE IF IT WAS A /PLUS SIGN. SNA CLA JMP RDEXP1 /HAD A PLUS SIGN OR /A MINUS SIGN. JMS I PRDPCK /READ AND PACK THE TWO /NEXT CHARACTERS. /IF A DELIMITER IS /FOUND AFTER ONLY ONE /CHARACTER, L32 /WILL ONLY CONTAIN THIS /ONE CHARATER. OTHERWISE /IT WILL CONTAIN BOTH CHARS. RDEXP2, TAD I POBJST /POINTER TO THE BEGINNING /OF THE OBJECT LIST DCA L33 JMS I PGTATOM JMP RDEXP3 PGTATOM, GTATOM READN6, JMS I PRDPCK /READ NEXT 2 CHARACTERS. TAD I L23 RDEXP3, DCA L23 /POINTER TO ATOM TAD L32 /USER CHARACTERS SNA CLA JMP READ3 /END OF USER CHARACTERS READ4, TAD L23 SNA JMP READN5 DCA XR10 TAD I XR10 CIA TAD L32 /SEE IF OUR CHARACTERS /MATCH THOSE IN THE /CURRENT ATOM. SNA CLA JMP I PREADN6 /YES, THEY MATCH. GET /MORE OF ATOM AND COMPARE /AGAIN. READN5, JMS NXTATOM /NO MATCH. GET POINTER /TO NEXT OBJECT, AND SEE /IF IT MATCHES. JMP READ4 PREADN6, READN6 READN7, JMS NXTATOM READ3, TAD L23 SZA CLA JMP READN7 JMS GTATOM /HAD NIL CIA TAD READN8 /ADD POINTER TO "NIL" SNA CLA JMP I READN9 CMA TAD XR10 JMP I READN9 READN8, NILN /POINTER TO "NIL" READN9, RDEXP1-1 GTATOM, 0 /SUBROUTINE TO GO DOWN /A LIST TILL IT FINDS AN /ATOM. SNA TAD L33 SKP RAL DCA XR10 TAD I XR10 RAR SNL JMP .-5 /NOT AN ATOM. CLL RAL /CHOP OFF ATOM MARK. JMP I GTATOM CKUSER, 0 /SEE IF C(A1P)>=OBJ /IF SO, SKIP NEXT /INSTRUCTION. TAD A1P CLL CMA CML TAD POBJ SZL CLA ISZ CKUSER JMP I CKUSER /NXTATOM ROUTINE. GOES DOWN A LIST AND GETS /THE NEXT ATOM. NXTATOM,0 TAD L33 DCA A1P NXTA1, JMS CKUSER JMP NXTA5 /C (L33) = OBJ SNA TAD PSOBJ /HAD NIL- GO THROUGH /SYSTEM NAMES. DCA A1P NXTA2, JMS GTATOM DCA A3P /SAVE POINTER TO /ATOM POINTED TO BY L33 TAD A1P JMS GTATOM NXTA3, DCA A2P /SAVE POINTER TO ATOM /NAME. TAD A3P CIA TAD L23 SZA CLA JMP NXTA4 TAD A1P DCA L33 /SAVE POINTER TO NEW /ATOM TAD A2P DCA L23 /SAVE POINTER TO NEW /ATOM NAME. JMP I NXTATOM /RETURN. NXTA4, TAD A2P SNA JMP NXTA1 DCA XR11 /HAVE TO RETRACE STEPS TAD A3P DCA XR10 TAD I XR10 CIA TAD I XR11 SZA CLA JMP NXTA1 TAD I A3P DCA A3P TAD I A2P JMP NXTA3 NXTA5, ISZ A1P ISZ A1P JMS CKUSER JMP NXTA2 /STILL ON THE SYSTEM /OBJECT LIST. /COULD NOT FIND THE NAME ON THE OBJECT LIST, /SO PUT IT ON. JMS GTATOM DCA XR10 DCA A2P JMS NUCEL /CELL POINTING TO THE /NEW OBJECT DCA L33 TAD I POBJST DCA A2P JMS NUCEL NXTA6, DCA I POBJST /ADD THIS TO THE OBJECT LIST TAD L33 IAC DCA A1P IAC NEWAT1, TAD FLIST DCA I A1P TAD XR10 CIA TAD L23 SNA CLA JMP NEWAT3 TAD XR10 DCA TEMP1 TAD I XR10 DCA A1P TAD I TEMP1 DCA XR10 NEWAT2, JMS NUCEL CLA JMP NEWAT1 NEWAT3, TAD L32 /HAVE NEW PACKED CHARACTERS SNA JMP NEWAT4 /DONE WITH THIS OBJECT DCA A1P JMS I PRDPCK JMP NEWAT2 /COME HERE WHEN THE NEW OBJECT HAS BEEN /COMPLETELY READ IN AND ADDED TO THE /OBJECT LIST. NEWAT4, DCA I A1P /PUT NIL AT /LAST CELL POINTER. TAD L33 /POINTER TO THE LIST. JMP I READN9 /RETURN. PAGE /STARTING AT INIT, THE WHOLE SYSTEM IS /CLEARED. THE OBLIST IS EMPTIED AND /THE GENSYM COUNT IS ZEROED. INIT, JMP CLEAR /STARTING AT INIT1, THE SYSTEM IS /CLEARED, BUT THE SYSTEM WILL KEEP /OBLIST AND ALL PROPERTIES OF /THE OBJECTS. INIT1, TLS /THIS IS TO SET FLAG INIT2, TAD K2 CHNGMD, RFC /CLEAR HIGH SPEED /READER FLAG DCA MODE /SET THE MODE DCA CHAR /INITIALIZE CHARACTER BUFFER /THIS LOOP ZEROES THE CDR PART OF /THE PERMANENT ATOMS WHICH ARE AT THE /END OF NAMES. TAD PSYMT DCA XR12 DCA I XR12 TAD I XR12 SZA CLA JMP .-3 INIT3, CLA DCA ALP /CLEAR ASSOCIATION LIST /POINTER DCA SP /CLEAR STACK POINTER DCA A1P /CLEAR POINTER TO /FIRST ARGUMENT DCA A2P /CLEAR POINTER TO /SECOND ARGUMENT DCA A3P /CLEAR POINTER TO /THIRD ARGUMENT DCA L31 DCA L33 JMS I PTERPRI /PRINT CARRIAGE RETURN /AND LINE FEED. JMS I PFETCHC /READ A CHARACTER JMP .-1 /IGNORE LEADER CLA IAC DCA MODE1 JMS I PREAD /READ IN THE FIRST S-EXPRESSION DCA A1P /SAVE POINTER TO THE S-EXPRESSION JMS NUMBER /SEE IF THE S-EXPRESSION /WAS A NUMBER SNA CLA /SKIP IF IT WAS A NUMBER. JMP NONUMB TAD I A1P /YES, IT WAS A NUMBER JMP CHNGMD /CHANGE THE MODE, /AND RESTART EVALQUOTE /SETM2 SETS THE ACCUMULATOR TO 7776 (-2) SETM2, 0 CLA CLL CMA RAL JMP I SETM2 /WE HAVE FOUND THE FIRST S-EXPRESSION AND IT /WAS NOT A NUMBER. NOW GET THE SECOND /S-EXPRESSION. NONUMB, TAD A1P JMS PRINTS /PRINT THE S-EXPRESSION IF /MODE BIT 1 WAS SELECTED. JMS PUSH /PUSH DOWN POINTER TO FIRST /S-EXPRESSION JMS I PREAD /READ IN THE SECOND S-EXPRESSION JMS PRINTS /PRINT THE SECOND S-EXPRESSION /IF MODE BIT 1 WAS SELECTED. ISZ MODE1 DCA A2P /SAVE POINTER TO SECOND /S-EXPRESSION JMS I PGETTOP TAD TEMP1 /GETTOP PLACES THE VALUE /WHICH WAS AT THE TOP /OF THE STACK INTO TEMP1, /WITHOUT POPPING STACK. DCA A1P /A1P NOW POINTS TO 1ST /S-EXPRESSION TAD A2P JMS PUSH /PUSH POINTER TO SECOND /S-EXPRESSION JMS I PDISP /GO TO THE APPROPRIATE ROUTINE /I.E.,EVALUATE THE EXPRESSIONS. JMS PRINTS /PRINT THE RESULT IF THE /PROPER MODE BIT WAS SELECTED. JMP INIT3 /GET THE NEXT EVALQUOTE /PAIR. /INITIALIZE THE WHOLE SYSTEM CLEAR, TAD POBJ DCA I POBJST /INITIALIZE THE OBJECT LIST DCA CGENSY /CLEAR THE GENSYM COUNT TAD PBEG DCA XR10 /POINTER TO FIRST CELL OF /LIST SPACE TAD LLEN CLL CML RAR /HAVE NUMBER OF CELLS DCA TEMP1 /SET UP LOOP COUNTER /NOW LINK TOGETHER THE LIST SPACE DCA I XR10 DCA I XR10 CMA TAD XR10 ISZ TEMP1 JMP .-5 /NOT DONE YET DCA FLIST /ADDRESS OF LAST CELL JMP INIT1 /SUBROUTINE TO PRINT AN S-EXPRESSION IF /THIS IS SPECIFIED BY THE MODE PRINTS, 0 JMS CHMODE /CHECK THE MODE MODE1 JMP PRINSR /DO NOT PRINT THE S-EXPRESSION DCA A1P SNL JMS I PTERPRI /PRINT A CARRIAGE RETURN /AND LINE FEED JMS I PPRINCC /PRINT A CHARACTER JMS I PPRINT /PRINT THE S-EXPRESSION PRINSR, JMP I PRINTS /SUBROUTINE TO CHECK TO SEE IF THE MODE /HAS THE BITS SPECIFIED BY THE ARGUMENT /SELECTED. IF SO, SKIPS /THE NEXT LOCATION. CHMODE, 0 DCA ATOM /SAVE AC TEMPORARILY TAD I CHMODE /GET ARGUMENT DCA NUMBER TAD MODE AND I NUMBER ISZ CHMODE SZA CLA ISZ CHMODE TAD MODE1 RAR CLA TAD ATOM /RESTORE AC. JMP I CHMODE PPSTOP, PSTOP /PRINT AN ERROR MESSAGE AND RESTART MODE1, ERR, 0 0001 /THIS CLEARS THE AC. JMS I PTERPRI /PRINT A CARRIAGE RETURN /AND LINE FEED. TAD PPSTOP JMS PNTERR /PRINT "STOP" TAD PERR JMS PNTERR /PRINT ADDRESS CALLED FROM TAD L31 JMS PNTERR /PRINT THE REST OF THE /CURRENT S-EXPRESSION. JMP INIT2 /PRINT THE LIST OR NUMBER POINTED TO BY AC. PNTERR, 0 DCA A1P JMS I PPRINT /LISP PRINT ROUTINE CLA JMS I PPRINCC JMP I PNTERR MODE, 0 /MODE WORD. /BASIC INPUT ROUTINE INSUB, 0 TAD INSUB DCA INRET JMS CHMODE /SEE IF LOW-SPEED READER K4 JMP TTYIN /LOW-SPEED READER PTRIN, RSF /HIGH-SPEED READER JMP .-1 RFC RRB /READ CHARACTER JMP I INRET 0 /ROUTINE TO RETURN SWITCH REGISTER +FIRST /ARGUMENT MASKED BY SECOND ARGUMENT LAS SKP DCA A2P RMASK, TAD I A2P /GET MASK AND I A3P /LOGICAL AND OF 1ST /AND 2ND ARGUMENTS DCA A2P IAC DCA A1P JMS NUCEL /PUT RESULT IN A CELL /IT IS A NUMBER. JMP LRET2 /RETURN DCA TEMP1 TAD I A3P DCA I TEMP1 JMP LRET2 PPNIL, PNIL /POINTER TO POINTER TO /NIL. /THE FOLLOWING ROUTINE PUTS A1P +1 IN TEMP1 IF /A1P IS NON-ZERO. IF A1P IS ZERO, PUTS POINTER /TO "NIL" IN TEMP1. A1PPL1, 0 /A1P PLUS ONE ROUTINE CLA TAD A1P SNA TAD PPNIL IAC DCA TEMP1 JMP I A1PPL1 /BASIC OUTPUT ROUTINE OUTSUB, 0 TSF JMP .-1 /WAIT TILL TELETYPE FREE TLS /TYPE CHARACTER IN AC. JMP I OUTSUB /RETURN /RDPCK WILL READ IN 2 CHARACTERS AND PACK THEM /IN LOCATION L32. RDPCK, 0 DCA L32 /CLEAR L32 JMS GETC /GET A CHARACTER DCA L32 DCA CHAR /CLEAR CHARACTER BUFFER. JMS GETC /GET A CHARACTER CLL RTL CLL RTL CLL RTL TAD L32 /ADD PREVIOUS CHARACTER /TO THIS CHARACTER. GET /SECOND CHARACTER IN /LEFT-HAND 6 BITS AND /FIRST CHARACTER IN RIGHT- /HAND 6 BITS. DCA L32 DCA CHAR /CLEAR CHARACTER BUFFER JMP I RDPCK /RETURN. PRDTST, RDTST /POINTER TO RDTEST ROUTINE /GETC WILL FETCH A CHARACTER. IF IT IS /A QUOTE, IT WILL DIRECTLY FETCH THE /NEXT CHARACTER WITHOUT CLASSIFYING IT. /IF A DELIMITER IS FOUND, RETURN /WILL BE TO ROUTINE WHICH CALLED RDPCK. GETC, 0 JMS I PRDTST /READ A CHARACTER AND /SEE IF IT IS A DELIMITER JMP I RDPCK /HAD A DELIMITER SZA JMP I GETC /NOT A QUOTE DCA CHAR /WAS QUOTE. CLEAR CHARACTER /BUFFER. JMS I PFETCHC /GET A CHARACTER /WITHOUT TESTING TO /SEE IF IT IS A DELIMITER JMS I PERR /ERROR-LEADER TRAILER /HAS BEEN FOUND AFTER QUOTE JMP I GETC /RETURN /APVAL FUNCTION APVAL, JMS I PFETCHC /GET A CHARACTER NOP /DON'T CARE IF IT /IS LEADER-TRAILER. SNA CLA TAD PTRUE JMP I EV /ZEXPR ROUTINE. JUMPS TO FIELD 0 ADDRESS /SPECIFIED IN 1ST ARGUMENT. ZEXPR, 0 CIF 0 JMP I .+1 ZEXPR0 /NOW COME THE SYSTEM NAMES. THEY ARE IN /THE FORM OF A LIST. THE FIRST SECTION HAS /THE CDR POINTER NIL. 0 SYMT, 0 0 NL, 56 /"L" 0 NY, 73 /"Y" 0 NN, 60 /"N" 0 NC, 45 /"C" 0 NOM, 5761 /"OM" 0 NR, 64 /"R" 0 NSE, 4765 /"SE" 0 NND, 4660 /"ND" 0 NNS, 6560 /"NS" 0 NNE, 4760 /"NE" 0 NIS, 6553 /"IS" 0 NEQ, 6347 /"EQ" 0 NAL, 5643 /"AL" 0 NPR, 6462 /"PR" 0 NRG, 5164 /"RG" 0 NTI, 5366 /"TI" 0 NYM, 5773 /"YM" 0 NT, 66 /"T" 0 NGO, 6151 /"GO" 0 NDA, 4346 /"DA" 0 NP, 62 /"P" 0 NST, 6665 /"ST" 0 NS, 65 /"S" 0 NLL, 5656 /"LL" 0 NER, 6447 /"ER" 0 NUS, 6567 /"US" 0 NOG, 5161 /"OG" 0 NE, 47 /"E" 0 NAD, 4643 /"AD" 0 NRN, 6064 /"RN" 0 NCA, 4345 /"CA" 0 NCD, 4645 /"CD" 0 NTQ, 6366 /"TQ" 0 N1OP, 6261 /"OP" 0 NRI, 5364 /"RI" 0 NIT, 6653 /"IT" 0 0 /THIS IS STILL THE SYSTEM NAME TABLE. /THESE NAMES DO NOT HAVE THEIR /CDR PART NULL. NILN, NL-1 NNIL, 5360 /"NI" NPLY-1 NAPPLY, 6243 /"AP" NY-1 NPLY, 5662 /"PL" NIT-1 NEXIT, 7247 /"EX" NMES-1 NTIMES, 5366 /"TI" NS-1 NMES, 4757 /"ME" NVAL-1 NAPVAL, 6243 /"AP" NL-1 NVAL, 4370 /"VA" NSOC-1 NASSOC, 6543 /"AS" NC-1 NSOC, 6165 /"SO" NOM-1 NATOM, 6643 /"AT" NR-1 NCAR, 4345 /"CA" NR-1 NCDR, 4645 /"CD" NND-1 NCOND, 6145 /"CO" NNS-1 NCONS, 6145 /"CO" NFINE-1 NDEFINE,4746 /"DE" NNE-1 NFINE, 5350 /"FI" NFLIS-1 NDEFLIS,4746 /"DE" NIS-1 NFLIS, 5650 /"FL" NUAL-1 NEQUAL, 6347 /"EQ" NL-1 NUAL, 4367 /"UA" NAL-1 NEVAL, 7047 /"EV" NPR-1 NEXPR, 7247 /"EX" NXPR-1 NFEXPR, 4750 /"FE" NXPR-1 NZEXPR, 4774 /"ZE" NR-1 NXPR, 6272 /"XP" NNARG-1 NFUNARG,6750 /"FU" NRG-1 NNARG, 4360 /"NA" NNCTI-1 NFUNCTI,6750 /"FU" NTI-1 NNCTI, 4560 /"NC" NNSYM-1 NGENSYM,4751 /"GE" NYM-1 NNSYM, 6560 /"NS" NT-1 NGET, 4751 /"GE" NMBDA-1 NLAMBDA,4356 /"LA" NDA-1 NMBDA, 4457 /"MB" NSSP-1 NLESSP, 4756 /"LE" NP-1 NSSP, 6565 /"SS" NST-1 NLIST, 5356 /"LI" NNUS-1 NMINUS, 5357 /"MI" NS-1 NNUS, 6760 /"NU" NLL-1 NNULL, 6760 /"NU" NMBER-1 NNUMBER,6760 /"NU" NER-1 NMBER, 4457 /"MB" NLIST-1 NOBLIST,4461 /"OB" NPEN-1 NIOPEN, 6153 /"IO" NPEN-1 NOOPEN, 6161 /"OO" NN-1 NPEN, 4762 /"PE" NLOSE-1 NICLOSE,4553 /"IC" NLOSE-1 NOCLOSE,4561 /"OC" NSE-1 NLOSE, 6156 /"LO" NEAR-1 NCLEAR, 5645 /"CL" NR-1 NEAR, 4347 /"EA" NUS-1 NPLUS, 5662 /"PL" NINT-1 NPRINT, 6462 /"PR" NT-1 NINT, 6053 /"IN" NOG-1 NPROG, 6462 /"PR" NOTE-1 NQUOTE, 6763 /"QU" NE-1 NOTE, 6661 /"OT" NAD-1 NREAD, 4764 /"RE" NTURN-1 NRETURN,4764 /"RE" NRN-1 NTURN, 6766 /"TU" NLACA-1 NRPLACA,6264 /"RP" NCA-1 NLACA, 4356 /"LA" NLACD-1 N1RPLACD,6264 /"RP" NCD-1 NLACD, 4356 /"LA" NT-1 NSET, 4765 /"SE" NTQ-1 NSETQ, 4765 /"SE" N1OP-1 NSTOP, 6665 /"ST" NRPRI-1 NTERPRI,4766 /"TE" NRI-1 NRPRI, 6264 /"RP" /NOW COMES THE SYSTEM OBJECT LIST. /THE FIRST CELL POINTS TO THE ADDRESS OF /THE ROUTINE, AND THE SECOND CELL POINTS /TO THE NAME OF THE ROUTINE. /THESE FIRST ONES ARE NOT SUBROUTINES SOBJ, LAMBDA, 0 /THIS HAS NO ADDRESS NLAMBDA PNIL, 0 NNIL FUNARG, 0 NFUNARG TRUE, T NT PAPVAL, APVAL NAPVAL COND NCOND FEXPR, 0 NFEXPR FUNCTI NFUNCTI GO NGO CLEAR NCLEAR LIST NLIST MINUS NMINUS PLUS NPLUS PROG NPROG QUOTE NQUOTE RETURN NRETURN EXIT NEXIT TIMES NTIMES SETQ NSETQ /THE FOLLOWING ARE SUBROUTINES WITH /NO ARGUMENTS. PSTOP, B0ARG, STOP NSTOP SYSSUBS,GENSYM NGENSYM READ NREAD ICLOSE NICLOSE OCLOSE NOCLOSE TERPRI NTERPRI /THE FOLLOWING HAVE 1 ARGUMENT B1ARG, ATOM NATOM CAR NCAR CDR NCDR DEFINE NDEFINE NULL NNULL NUMBER NNUMBER PRINT NPRINT /THE FOLLOWING HAVE 2 ARGUMENTS B2ARG, ASSOC NASSOC CONS NCONS DEFLIS NDEFLIS EQ NEQ EQUAL NEQUAL EVAL NEVAL GET NGET LESSP NLESSP RPLACA NRPLACA RPLACD N1RPLACD SET NSET /THE FOLLOWING HAVE 3 ARGUMENTS B3ARG, APPLY NAPPLY IOPEN NIOPEN OOPEN NOOPEN EXPR NEXPR ZEXPR NZEXPR /THIS IS THE OBJECT LIST OBJ, 0 .+1 .+2 NOBLIST .+2 PAPVAL 0 OBJST OBJST, OBJ /POINTER TO THE OBJECT LIST LBEG, 0 /BEGINNING OF THE LIST /SPACE -1 /THE LIST SPACE GETS CHAINED TOGETHER BY CLEAR. $