/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
	TAD I	A1P	/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.

$