Google
 

Trailing-Edge - PDP-10 Archives - decuslib20-02 - decus/20-0039/lisp.mac
There are 5 other files named lisp.mac in the archive. Click here to see a list.
		SUBTTL AC DEFINITIONS AND EXTERNALS 		--- PAGE 1
TITLE LISP INTERPRETER
IF1,<PURGE CDR,DF>
MLON
INUMIN=377777
INUM0=<INUMIN+777777>/2
BCKETS==77

;AC DEFINITIONS
NIL=0
A=1
B=A+1
C=B+1
T=6
TT=7
REL=10
FF=16
AR1=4
F=15
P=14
D=12
S=11
AR2A=5
R=13
SP=17
NACS==5

X==0	;X INDICATES IMPURE (MODIFIED) CODE LOCATIONS
TEN==^D10

;UUO DEFINITIONS
OPDEF JCALLF [37B8]
OPDEF CALLF [36B8]
OPDEF JCALL [35B8]
OPDEF FCALL [34B8]
OPDEF ERR1 [1B8]
OPDEF ERR2 [2B8]
OPDEF ERR3 [3B8]
OPDEF STRTIP [4B8]
OPDEF TTYUUO [51B8]
OPDEF TALK [PUSHJ P,TTYCLR]	;THIS IS TO TURN OFF CONTROL O.
				;WHEN TTYSER LETS YOU DO THIS
				;EASILY, CHANGE ME

;I/O BITS AND CONSTANTS
TTYLL==105
LPTLL==160
MLOB==203	;MAX LENGTH OF I/O BUFFER
NIOB==2	;NO OF I/O BUFFERS PER DEVICE
NCH==17	;NO OF I/O CHANNELS
FSTCH==1	;FIRST I/O CHANNEL
TTCH==0		;TTY I/O CHANNEL
BLKSIZE==NIOB*MLOB+COUNT+1
INB==2
OUTB==1
AVLB==40
DIRB==4

;SPECIAL ASCII CHARACTERS
ALTMOD==175
SPACE==40	;SPACE
IGCRLF==32	;IGNORED CR-LF
RUBOUT==177
LF==12
CR==15
TAB==11
BELL==7
DBLQT==42	;DOUBLE QUOTE "

;BYTE POINTER FIELD DEFINITIONS
ACFLD==14
XFLD==21
OPFLD==10
ADRFLD==43

;EXTERNAL AND INTERNAL SYMBOLS
EXTERNAL JOBSYM,JOBAPR,JOBCNI,JOBTPC,JOBREL,JOBREN,JOBFF
EXTERNAL JOBSA,JOBAPR,JOBUUO,JOB41
;APR FLAGS
PDOV==200000
MPV==20000
NXM==10000
APRFLG==PDOV+MPV+NXM

;SYSTEM UUOS
APRINI==16
RESET==0
DDTINP==1
STIME==27
DEVCHR==4
EXIT==12
CORE==11
PAGE
;FOOLST MACROS
DEFINE FOO <
XLIST
BAZ (\FOOCNT)
LIST
	>

DEFINE BAZ (X)
<FOOCNT=FOOCNT+1
FOO'X:
>

FOOCNT=0


		SUBTTL TOP LEVEL AND INITIALIZATION  --- PAGE 2

LISPGO:	JRST START
	JRST LISP1X	;ENTRY POINT TO GET INTO READ-EVAL-PRINT LOOP
				;WITHOUT UNBINDING SPEC PDL
START:	SETZM RETFLG#	;CLEAR RETURN FLAG TO ALLOW INITFN TO BE CHANGED
	CALLI RESET	;RANDOM INITIALIZATIONS FOR LISP INTERUPTS
	MOVE [JSR UUOH]
	MOVEM JOB41
	MOVEI APRINT
	MOVEM JOBAPR
	MOVEI APRFLG
	CALLI APRINI
	HRRZI 17,1
	SETZB 0,PSAV1
	BLT 17,17	;CLEAR ACS 
	SETOM ERRSW	;PRINT ERROR MESSAGES
	CLEARM ERRTN	;RETURN TO TOP LEVEL ON ERRORS
	SETOM PRVCNT#	;INITIALIZE COUNTER FOR ERRIO
	MOVE P,C2#	;INITIAL REG PDL PTR
	MOVE SP,SC2#	;INITIAL SPEC PDL PTR
LISP1X:	PUSHJ P,TTYRET	;(OUTC NIL T)(INC NIL T)RETURN OUTPUT FOR GC MESSAGE
FOO	HRROI 0,CNIL2	;INITIALIZE NIL
	SKIPE HASHFG#
	JRST REHASH	;REHASH IF NECESSARY
	SKIPN FF+X	
	PUSHJ P,AGC	;GARBAGE COLLECT ONLY IF NECESSARY
	SKIPN BSFLG#	;INITIAL BOOTSTRAP FOR MACROS
	JRST BOOTS
LSPRT1:	SKIPE RETFLG	;TEST FOR ERROR RETURN
	JRST [	SKIPE A,INITF
		CALLF (A)	;EVALUATE INITIALIZATION FUNCTION
		SETZM RETFLG
		JRST .+1]
LISP2:	PUSHJ P,TTYRET		;RETURN ALL I/O TO TTY
	PUSHJ P,TERPRI
	SKIPE GOBF#	;GARBAGED OBLIST FLAG
	STRTIP [SIXBIT /GARBAGED OBLIST_!/]
	SETZM GOBF
	SKIPE BPSFLG#
	JRST BINER2	;BINARY PROGRAM SPACE EXCEEDED BY LOADER
LISP1:	PUSHJ P,READ	;THIS IS THE TOP LEVEL OF LISP
	PUSHJ P,EVAL
	PUSHJ P,PRINT
	PUSHJ P,TERPRI
	JRST LISP1
PAGE
INITFN:	EXCH A,INITF#
	POPJ P,

;RETURN FROM LISP ERROR OR BELL
LSPRET:	PUSHJ P,TERPRI
	SKIPE PSAV1#	;BELL FROM ALVINE?
	JRST [	MOVE P,PSAV1	;YES, RETURN TO ALVINE
		HRRZ REL,ED
		JRST 1(REL)]	;IMPROVED MAGIC
	MOVE B,SC2
	PUSHJ P,UBD	;UNBIND SPECPDL
	SETOM RETFLG	;SET RETURN FLAG
	JRST LSPRT1

.RSET:	EXCH A,RSTSW#
	POPJ P,

;BOOTSTRAPPER FOR MACRO DEFINITIONS
BOOTS:	SETOM BSFLG
	MOVEI A,BSTYI
	PUSHJ P,READP1
	PUSHJ P,EVAL
	PUSHJ P,READ
	JRST .-2

BSTYI:	ILDB A,[POINT 7,[ASCII /(INC(INPUT SYS:(LISP.LSP)))/]]
	POPJ P,

		SUBTTL PROCESSOR INTERRUPT SERVICE  --- PAGE 3

APRINT:	MOVE R,JOBCNI	;GET MAGIC PROCESSOR BITS
	TRNE R,MPV+NXM
	ERR3 @JOBTPC	;IT WAS AN ILL MEM REF
	JUMPN NIL,MES21
	STRTIP [SIXBIT /_PDL OVERFLOW FROM GC - CAN'T CONTINUE!/]
	JRST LISPGO

MES21:	SETZM JOBUUO
	SKIPL P
	STRTIP [SIXBIT /_REG !/]
	SKIPL SP
	STRTIP [SIXBIT /_SPEC !/]
	SKIPE JOBUUO
SPDLOV:	ERR2 [SIXBIT /PUSHDOWN CAPACITY EXCEEDED !/]
	TRNE R,PDOV
	SKIPE JOBUUO
	HALT		;LISP SHOULD NOT BE HERE
BINER2:	SETZM BPSFLG
	ERR2 [SIXBIT /BINARY PROGRAM SPACE EXCEEDED !/]

		SUBTTL UUO HANDLER AND SUBR CALL ROUTINES --- PAGE 4

UUOMAX==4

UUOH:
ERROR:	X		;JSR LOCATION
	MOVEM T,TSV#
	MOVEM TT,TTSV#
	LDB T,[POINT 9,JOBUUO,OPFLD]
	CAIGE T,34
	JRST ERRA
	HLRE R,@JOBUUO
	AOJN R,UUOS
	LDB T,[POINT 4,JOBUUO,ACFLD]
	CAILE T,15
	MOVEI R,-15(T)
	HRRZ T,@JOBUUO
UUOH1:	HLRZ TT,(T)
	HRRZ T,(T)
FOO	CAIN TT,SUBR
	JRST @UUST(R)
FOO	CAIN TT,FSUBR
	JRST @UUFST(R)
FOO	CAIN TT,LSUBR
	JRST @UULT(R)
FOO	CAIN TT,EXPR
	JRST @UUET(R)
FOO	CAIN TT,FEXPR
	JRST @UUFET(R)
	HRRZ T,(T)
	JUMPN T,UUOH1
	PUSH P,A
	PUSH P,B
	HRRZ A,JOBUUO
FOO	MOVEI B,VALUE
	PUSHJ P,GET
	JUMPN A,[	HRRZ TT,(A)
			POP P,B
			POP P,A
			JRST UUOEX1]
	HRRZ A,JOBUUO
	PUSHJ P,EPRINT
	ERR1 [SIXBIT /UNDEFINED UUO!/]
PAGE
	SKIPA T,TT
UUOSBR:	HLRZ T,(T)
	MOVE TT,JOBUUO
	HRLI T,(PUSHJ P,)
	TLNE TT,1000	;1000 MEANS NO PUSH
	TLCA T,34600	;<PUSHJ P,>XOR<JRST>
	PUSH P,UUOH
	SOS UUOH
UUOCL:	TLNN TT,2000+X	;2000 MEANS NO CLOBBER
	MOVEM T,@UUOH
	MOVE TT,TTSV
	EXCH T,TSV
	JRST @TSV

UUOS:	HRRZ TT,JOBUUO
	CAILE TT,@GCPP1
	CAIL TT,@GCP1
	JRST UUOSBR-1
	JRST .+2
UUOEXP:	HLRZ TT,(T)
UUOEX1:	LDB T,[POINT 5,JOBUUO,ACFLD]
	TRZN T,20
	PUSH P,UUOH
	PUSH P,TT
	JUMPE T,IAPPLY
	CAIN T,17
	MOVEI T,1
	MOVNS T
	HRLZ TT,T
	PUSH P,A(TT)
	AOBJN TT,.-1
	JRST IAPPLY
PAGE
ARGPDL:	LDB T,[POINT 4,JOBUUO,ACFLD]
	MOVNS T
	HRLZ R,T
ARGP1:	JUMPE R,(TT)
	PUSH P,A(R)
	AOBJN R,.-1
	JRST (TT)

QTIFY:	PUSHJ P,NCONS
FOO	MOVEI B,CQUOTE
	JRST XCONS

QTLFY:	MOVEI A,0
QTLFY1:	JUMPE T,(TT)
	EXCH A,(P)
	PUSHJ P,QTIFY
	POP P,B
	PUSHJ P,CONS
	AOJA T,QTLFY1

PDLARG:	JRST .+NACS+2(T)
	POP P,A+5
	POP P,A+4
	POP P,A+3
	POP P,A+2
	POP P,A+1
	POP P,A
	JRST (TT)

NOUUO:	MOVSI B,(TLNN TT,)
	SKIPE A
	MOVSI B,(TLNA)
	HLLM B,UUOCL
	EXCH A,NOUUOF#
	POPJ P,
PAGE
;R=0 => COMPILER CALLING A -
;R=1 => COMPILER CALLING A LSUBR
;R=2 => COMPILER CALLING F TYPE
UUST:	UUOSBR
	UUOS1	;CALLING L ITS A SUBR
	UUOS2	;CALLING F


UUFST:	UUOS9	;CALLING - ITS A F
	UUOS10	;CALLING L
	UUOSBR

UULT:	UUOS7	;CALLING - ITS A L
	UUOSBR
	UUOS8

UUET:	UUOEXP
	UUOS5	;CALLING L ITS AN EXPR
	UUOS6	;CALLING F ITS AN EXPR

UUFET:	UUOS3	;CALLING - ITS A FEXPR
	UUOS4	;CALLING L
	UUOEXP	

UUOS1:	HLRZ R,(T)
	MOVE T,TSV
	JSP TT,PDLARG
	JRST (R)

UUOS3:	PUSH P,(T)
	JSP TT,ARGPDL
UUOS4A:	JSP TT,QTLFY
	MOVEI TT,1
	DPB TT,[POINT 4,JOBUUO,ACFLD]
UUOS6A:	POP P,TT
	HLRZS TT
	JRST UUOEX1

UUOS4:	PUSH P,(T)
	MOVE T,TSV
	JRST UUOS4A
PAGE
UUOS5:	HLRZ R,(T)
	MOVE T,TSV
	JSP TT,PDLARG
	MOVE TT,R
	JRST UUOEX1

UUOS6:	PUSH P,(T)
	PUSH P,UUOH
	PUSH P,JOBUUO
	JSP TT,ILIST
	JSP TT,PDLARG
	POP P,JOBUUO
	POP P,UUOH
	JRST UUOS6A
UUOS8:	SKIPA TT,CILIST
UUOS7:	MOVEI TT,ARGPDL
	HRRM TT,UUOS7A
	MOVE TT,JOBUUO
	TLNN TT,1000
	PUSH P,UUOH
	HLRZ TT,(T)
UUOS7A:	JRST ARGPDL+X	;OR ILIST

UUOS9:	PUSH P,T
	JSP TT,ARGPDL
UUS10A:	JSP TT,QTLFY
	MOVSI T,2000
	IORM T,JOBUUO
	POP P,T
	JRST UUOSBR

UUOS10:	PUSH P,T
	MOVE T,TSV
	JRST UUS10A


		SUBTTL ERROR HANDLER AND BACKTRACE --- PAGE 5
;SUBROUTINE TO PRINT SIXBIT ERROR MESSAGE
ERRSUB:	MOVSI A,(POINT 6,0)
	HRR A,JOBUUO
	MOVEM A,ERRPTR#
ERRORB:	ILDB A,ERRPTR
	CAIN A,01	;CONVERSION FROM SIXBIT
	POPJ P,
	CAIN A,77
	JRST [	PUSHJ P,TERPRI
		JRST ERRORB]
	ADDI A,40
	PUSHJ P,TYO
	JRST ERRORB

;SUBROUTINE TO RETURN OUTPUT TO PREVIOUSLY SELECTED DEVICE
OUTRET:	SKIPL PRVCNT	;IF PRVCNT<0 THEN THERE WAS NO DEVICE DESELECT
	SOSL PRVCNT	;WHEN PRVCNT GOES NEGATIVE, THEN RESELECT
	POPJ P,
	PUSH P,PRVSEL#		;PREVIOUSLY SELECTED OUTPUT
	POP P,TYOD
	POPJ P,

;SUBROUTINE TO FORCE ERROR MESSAGES OUT ON TTY
ERRIO:	MOVE B,ERRSW
	CAIE B,INUM0	;INUM0 SPECIFIES TO PRINT MESSAGE ON SELECTED DEVICE
	AOSLE PRVCNT	;ONLY IF PRVCNT ALREADY <0 DOES DESELECTION OCCUR
	POPJ P,	
	TALK		;UNDO CONTROL O
	MOVE B,[JRST TTYO]
	EXCH B,TYOD
	MOVEM B,PRVSEL
	POPJ P,

ERRTN:	0	;0 => TOP LEVEL				*
	;- => PDL TO RESET TO - STORED BY ERRORSET
	;+ => STRING TYO POUT RTN FLAG
ERRSW:	-1	;0 MEANS NO PRNT ON ERROR		*
PAGE
;SUBROUTINE TO SEARCH OBLIST FOR CLOSEST FUNCTION TO ADDRESS IN R
ERSUB3:
FOO	MOVEI A,QST
FOO	HRROI NIL,CNIL2
	HRLZ B,INT1
	MOVNS B
	SETZB AR2A,GOBF
	PUSH P,JOBAPR
	MOVEI C,[	SETOM GOBF
			JRST ERRO2G]
	HRRM C,JOBAPR
	HLRZ C,@RHX5
ERRO2B:	JUMPE C,[	AOBJN B,.-1
			POP P,JOBAPR	;OBLIST DONE, RESTORE
			JRST PRINC]	;PRINT CLOSEST MATCH
	HLRZ TT,(C)
ERRO2C:	HRRZ TT,(TT)
	JUMPE TT,ERRO2G
	HLRZ AR1,(TT)
FOO	CAIN AR1,LSUBR
	JRST ERRO2H
FOO	CAIE AR1,SUBR
FOO	CAIN AR1,FSUBR
	JRST ERRO2H
	HRRZ TT,(TT)
	JRST ERRO2C

ERRO2H:	HRRZ TT,(TT)
	HLRZ TT,(TT)
	CAMLE TT,AR2A	;LE TO PREFER CAR TO QUOTE
	CAMLE TT,R
	JRST ERRO2G
	MOVE AR2A,TT
	HLRZ A,(C)
ERRO2G:	HRRZ C,(C)
	JRST ERRO2B
PAGE
;DISPATCHER FOR ERROR MESSAGE UUOS
ERRA:	MOVEI A,APRFLG
	CALLI A,APRINI
	LDB A,[POINT 9,JOBUUO,OPFLD]
	CAIG A,UUOMAX
	JRST .+1(A)
	JRST BADERR	;0 OR >4
	JRST ERROR1	;1
	JRST ERRORG	;2
	JRST ERROR2	;3
	JRST STRTYP	;4
ERRORG:	SKIPN P,ERRTN	;IF IN ERRSET, RESTORE P TO THAT LEVEL
	MOVE P,C2	;ELSE TO TOP LEVEL
			;AND ATTEMPT TO PRINT MESSAGE

ERROR1:	SKIPN ERRSW
	JRST ERREND	;DONT PRINT MESSAGE, CALL (ERR NIL)
	PUSHJ P,ERRIO	;PRINT MESSAGE ON TTY
	PUSHJ P,TERPRI
	PUSHJ P,ERRSUB	;PRINT THE MESSAGE
	JRST ERRBK	;GO THE BACKTRACE

STRTYP:	PUSHJ P,ERRIO
	PUSHJ P,ERRSUB	;PRINT MESSAGE AND CONTINUE
	PUSHJ P,OUTRET
	JRST @ERROR
PAGE

ERROR2:	HRRZ A,JOBUUO
	MOVEI B,[SIXBIT / ILL MEM REF FROM !/]
	JRST ERSUB2

BADERR:	HRRZ A,ERROR
	MOVEI B,[SIXBIT / ILL UUO FROM !/]
ERSUB2:	SKIPN ERRSW
	JRST ERREND	;DONT PRINT MESSAGE
	PUSH P,A
	PUSH P,B
	PUSHJ P,ERRIO
	PUSHJ P,TERPRI
	PUSHJ P,PRINL2	;PRINT NUMBER
	POP P,A
	STRTIP (A)	;PRINT MESSAGE
	POP P,R
	PUSHJ P,ERSUB3	;PRINT NEAREST OBLIST MATCH
ERRBK:	SKIPE BACTRF#
	PUSHJ P,BKTRC	;PRINT BACKTRACE
	PUSHJ P,OUTRET	;RETURN TO PREVIOUS DEVICE
ERREND:	MOVEI A,0	;(ERR NIL)
	SKIPN ERRTN
	JRST	[TTYUUO 11,	;CLEAR INPUT BUFFER
		SKIPE RSTSW
		JRST LISP2	;(*RSET T) GOES TO READ-EVAL-PRINT LOOP WITHOUT UNBIND
		JRST LSPRET]	;UNBIND AND GO TO TOP LEVEL
ERR:	SKIPN ERRTN
	JRST LSPRET	;NOT IN AN ERRSET, OR BAD ERROR -- GO TO TOP LEVEL
	MOVE P,ERRTN
ERR1:	POP P,B
	PUSHJ P,UBD	;UNBIND TO PREVIOUS ERRSET
	POP P,ERRSW
	POP P,ERRTN
	JRST ERRP4	;AND PROCEED

ERRSET:	PUSH P,PA3
	PUSH P,PA4
	PUSH P,ERRTN
	PUSH P,ERRSW
	PUSH P,SP
	MOVEM P,ERRTN
	HRRZ C,(A)
	HLRZ C,(C)
	MOVEM C,ERRSW
	HLRZ A,(A)
	PUSHJ P,EVAL
	PUSHJ P,NCONS
	JRST ERR1
PAGE
;ERROR MESSAGES

ER2:	SETZM OLDCH
	ERR1 [	SIXBIT /DOT CONTEXT ERROR!/]
QA2A:	HLRZ A,(AR1)
	PUSHJ P,EPRINT
	ERR1 [SIXBIT /UNDEFINED FUNCTION!/]
QA8:	PUSHJ P,EPRINT
	ERR1 [SIXBIT /UNBOUND VARIABLE - EVAL!/]
E5:	ERR1 [SIXBIT /NON-NUMERIC ARGUMENT!/]
E6:	ERR1 [SIXBIT /NO PRINT NAME - INTERN!/]
E7:	ERR1 [SIXBIT /NO LIST-MAKNAM!/]
QF2:	ERR1 [SIXBIT /TOO MANY ARGUMENTS SUPPLIED - APPLY!/]
QF3:	ERR1 [SIXBIT /TOO FEW ARGUMENTS SUPPLIED - APPLY!/]
QA1:	PUSHJ P,EPRINT
	ERR1 [SIXBIT /UNDEFINED FUNCTION - APPLY!/]
EG1:	HRRZ A,T
	PUSHJ P,EPRINT
	ERR1 [SIXBIT /UNDEFINED PROG TAG-GO!/]
PAGE
;BACKTRACE SUBROUTINE
BKTRC:	MOVEI D,-1(P)
	MOVN A,BACTRF
	ADDI A,INUM0
	JUMPL A,[	ADD A,P	;BACKTRACE SPECIFIC NUMBER 
			JRST .+3]
	SKIPN A,ERRTN	;BACKTRACE TO PREVIOUS ERRSET
	MOVE A,C2	;OR TOP LEVEL
	HRRZM A,BAKLEV#
	STRTIP [SIXBIT /_BACKTRACE_!/]
BKTR2:	CAMG D,BAKLEV
	JRST FALSE	;DONE 
	HRRZ A,(D)	;GET PDL ELEMENT
FOO	CAIGE A,FS
	JUMPN A,.+2	;THIS IS (HOPEFULLY) A TRUE PROGRAM ADDRESS
	SOJA D,BKTR2	;NOT A PROGRAM ADDRESS, CONTINUE
	CAIN A,ILIST3
	JRST BKTR1A	;ARGUMENT EVALUATION 
BKTR1B:	CAIN A,CPOPJ
	JRST [	HLRZ A,(D)	;CALLING A FUNCTION
		PUSHJ P,PRINC
		XCT "-",CTY
		STRTIP [SIXBIT /ENTER !/]
		SOJA D,BKTR2]
	HLRZ B,-1(A)
	TRZ B,20
	CAILE B,(JCALLF)
	CAIN B,(PUSHJ P,)	;TESTS FOR VARIOUS TYPES OF CALLS
	CAIGE B,(FCALL)
	SOJA D,BKTR2		;NOT A PROPER FUNCTION CALL
	MOVEI R,@-1(A)		;LOOKS OK
	PUSH P,R	;SAVE OBJECT OF FUNCTION CALL
	MOVEI R,-1(A)	;LOCATION OF FUNCTION CALL
	PUSHJ P,ERSUB3		;PRINT CLOSEST OBLIST MATCH
	MOVEI A,"-"
	PUSHJ P,TYO
	POP P,R
	HLRO B,(R)
	AOSN B
	JRST [	MOVE A,R	;WAS CALLING AN ATOMIC FUNCTION
		PUSHJ P,PRINC	;PRINT ITS NAME
		JRST .+2]
	PUSHJ P,ERSUB3	;WAS CALLING A CODE LOCATION -- PRINT CLOSEST MATCH
	MOVEI A," "
	PUSHJ P,TYO
BKTR1:	SOJA D,BKTR2	;CONTINUE

BKTR1A:	HRRZ B,-1(D)
	CAIE B,EXP2
	CAIN B,ESB1
	JRST .+2
	JRST BKTR1B	;HUM, NOT REALLY EVALUATING ARGUMENTS
	HLRE B,-1(D)
	ADD B,D
	HLRZ A,-3(B)
	JUMPE A,BKTR1
	PUSHJ P,PRINC
	XCT "-",CTY
	STRTIP [SIXBIT /EVALARGS !/]
	JRST BKTR1

BAKGAG:	EXCH A,BACTRF
	POPJ P,

		SUBTTL TYI  AND TYO  --- PAGE 6
;INPUT
ITYI:	PUSHJ P,TYI
FIXI:	ADDI A,INUM0
	POPJ P,

TYI:	MOVEI AR1,1
	PUSHJ P,TYIA
	JUMPE A,.-1
	CAME A,IGSTRT	;START OF COMMENT OR IGNORED CR-LF
	POPJ P,
	PUSHJ P,COMMENT
	JRST TYI+1

TYIA:	SKIPE A,OLDCH
	JRST TYI1
TYID:
TYI2:	JRST TTYI+X	;SOSG X FOR OTHER DEVICE INPUT
	;OTHER DEVICE INPUT
	JRST TYI2X
TYI3:	ILDB A,X		;POINTER
TYI3A:	TDNN AR1,@X	;POINTER
	POPJ P,
	MOVE A,@TYI3A
	CAMN A,[<ASCII /     />+1]	;PAGE MARK FOR STOPGAP
	AOSA PGNUM	;INCREMENT PAGE NUMBER
	MOVEM A,LINUM
	MOVNI A,5
	ADDM A,@TYI2	;ADJUST CHARACTER COUNT FOR LINE NUMBER
	AOS @TYI3	;INCREMENT BYTE POINTER OVER LINE NUMBER AND TAB
	JRST TYI2

TYI2X:	INPUT X,
TYI2Y:	STATZ X,740000
	ERR1 AIN.8	;INPUT ERROR
TYI2Z:	STATO X,20000
	JRST TYI3	;CONTINUE WITH FILE
	PUSH P,T	;END OF FILE
	PUSH P,C
	PUSH P,R
	PUSH P,AR1
	MOVE A,INCH
	HRRZ C,CHTAB(A)	;GET LOCATION OF DATA FOR THIS CHANNEL
	HLRZ T,CHTAB(A)	;INLST	-- REMAINING FILES TO INPUT
	JUMPE T,TYI2E	;NONE LEFT -- STOP
	PUSHJ P,SETIN	;START NEXT INPUT
	POP P,AR1
	POP P,R
	POP P,C
	POP P,T
	JRST TYI

TYI2E:	PUSHJ P,INCNT	;(INC NIL T)
	TALK		;TURN OFF CONTROL O
FOO	MOVEI A,$EOF$	;WE ARE DONE
	JRST ERR

PGLINE:	MOVE C,[POINT 7,LINUM]
	PUSHJ P,NUM10	;CONVERT ASCII LINE NUMBER TO A INTEGER
	ADDI A,INUM0
	MOVE B,PGNUM
	ADDI B,INUM0+1
	JRST XCONS

OLDCH:	0
PGNUM:	0
LINUM:	0
	0	;ZERO TO TERMINATE NUM10
PAGE
;TELETYPE INPUT

TTYI:	SKIPE DDTIFG
	JRST TTYID
	TTYUUO 5,A	;SINGLE CHAR IF LINE HAS BEEN TYPED
	JRST 	[TALK		;TURN OFF CONTROL O, THIS
				;CAN BE OMITTED WHEN TTYSER IS FIXED
		TTYUUO 1,["*"] ;OUTPUT *
		TTYUUO 4,A	;WAIT FOR A LINE
		JRST .+1]
TTYXIT:	CAIN A,BELL
	JRST LSPRET	;BELL RETURNS TO TOP LEVEL
	POPJ P,

TTYID:	TALK		;TURN OFF CONTROL O, REMOVE THIS WHEN TTYSER WORKS
	TTYUUO 0,A	;SINGLE CHARACTER INPUT DDT SUBMODE STYLE
	CAIE A,RUBOUT
	JRST TTYXIT
	TTYUUO 1,["\"]	;ECHO BACKSLASH
	SKIPE PSAV
	JRST RDRUB	;RUBOUT IN READ RESETS TO TOP LEVEL OF READ
	MOVEI A,RUBOUT	
	POPJ P,
PAGE	;OUTPUT
ITYO:	SUBI A,INUM0
	PUSHJ P,TYO
	JRST FIXI

TYO:	CAIG A,CR
	JRST TYO3
	SOSGE CHCT
	JRST TYO1
TYOD:	JRST TTYO+X	;SOSG X FOR OTHER DEVICE
			;OTHER DEVICE OUTPUT
	JRST TYO2X
TYO5:	IDPB A,X
	POPJ P,

TYO2X:	OUT X,
	JRST TYO5
	ERR1 [SIXBIT /OUTPUT ERROR!/]

TYO1:	PUSH P,A	;LINELENGTH EXCEEDED
	MOVEI A,IGCRLF	;INORED CR-LF
	PUSHJ P,TYOD
	PUSHJ P,TERPRI	;FORCE OUT A CR-LF, WITH SPECIAL MARK
	POP P,A
	SOSA CHCT
TYO4:	POP P,B
	JRST TYOD

TYO3:	CAIGE A,TAB
	JUMPN A,TYO+2	;EVERYTHING BETWEEN 0(NULL) AND 11(TAB) DECREMENT CHCT
	PUSH P,B
	MOVE B,LINL
	CAIN A,TAB
	JRST [	SUB B,CHCT
		IORI B,7	;SIMULATE TAB EFFECT ON CHCT
		SUB B,LINL
		SETCAM B,CHCT
		JRST TYO4]
	CAIN A,CR
	MOVEM B,CHCT	;RESET CHCT AFTER A CR
	JRST TYO4

LINELENGTH:
	JUMPE A,LINEL1
	SUBI A,INUM0
	HRRM A,LINL
	HRRM A,CHCT
LINEL1:	HRRZ A,LINL
	JRST FIXI

CHRCT:	MOVE A,CHCT
	JRST FIXI

LINL:	TTYLL				;*
CHCT:	TTYLL				;*

;TELETYPE OUTPUT
TTYO:	TTYUUO 1,A	;OUTPUT SINGLE CHARACTER IN A
	POPJ P,
PAGE
DDTIFG:	TRUTH
DDTIN:	EXCH A,DDTIFG
	POPJ P,


TTYRET:	PUSHJ P,OUTCNT
	JRST INCNT

;ALL OF THIS CRAP IS TO TURN OFF CONTROL O. LOSE-LOSE-LOSE
TTYCLR:	RELEASE TTCH,
	INIT TTCH,1
	SIXBIT /TTY/
	XWD TOBUF,0
	HALT
	PUSH P,A
	MOVEI A,TTOBUF-1
	MOVEM A,JOBFF
	OUTBUF TTCH,1
	OUTPUT TTCH,	;SET UP BUFFER
	MOVEI A,0
	IDPB A,TOBUF+1	;PLANT A NULL CHARACTER
	AOS TOBUF+2
	OUTPUT TTCH,	;OUTPUT IT
	JRST POPAJ

TOBUF:	BLOCK 3

TTOBUF:	BLOCK 23

TTOCH:	0					;*
	0	;TTY PAGE NUMBER  ALWAYS ZERO
	0	;TTY LINE NUMBER -- ALWAYS ZERO

TTOLL:	TTYLL					;*
TTOHP:	TTYLL					;*

		SUBTTL INPUT AND OUTPUT INITIALIZATION AND CONTROL --- PAGE 7
;CONVERT ASCII TO SIXBIT FOR DEVICE INITIALIZATION ROUTINES
SIXMAK:	SETZM SIXMK2#
	MOVE AR1,[POINT 6,SIXMK2]
	HRROI R,SIXMK1
	PUSHJ P,PRINTA	;USE PRINT TO UNPACK ASCII CHARACTERS
	MOVE A,SIXMK2
	POPJ P,

SIXMK1:	ADDI A,40
	TLNN AR1,770000
	POPJ P,		;LAST CHARACTER POSITION -- IGNORE REMAINING CHARS
	CAIN A,"."+40	
	MOVEI A,0	;IGNORE DOTS AT END OF NUMBERS FOR DECIMAL BASE
	CAIN A,":"+40
	HRLI AR1,(POINT 6,0,29)	;DEPOSIT : IN LAST CHAR POSITION
	IDPB A,AR1
	POPJ P,

;SUBROUTINE TO PROCESS NEXT ITEM IN FILE NAME LIST
INXTIO:	HRRZ T,(T)
NXTIO:	HLRZ A,(T)
	PUSHJ P,ATOM
	JUMPE A,CPOPJ	;NON-ATOMIC
	HLRZ A,(T)
	JRST SIXMAK	;MAKE SIXBIT IF ATOMIC

;RIGHT NORMALIZE SIXBIT
	LSH A,-6
SIXRT:	TRNN A,77
	JRST .-2
	POPJ P,
PAGE
IOSUB:	PUSHJ P,NXTIO
	MOVEM T,DEVDAT#
	LDB B,[POINT 6,A,35]
	JUMPE A,IOPPN+1	;NON-ATOMIC ITEM, MUST BE PPN OR (FILE.EXT)
	CAIE B,":"-40
	JRST IOFIL	;NOT A DEVICE NAME -- MUST BE FILE NAME
	TRZ A,77	;CLEAR OUT THE :
	SETZM PPN
IODEV2:	MOVEM A,DEV
	PUSHJ P,INXTIO
IOPPN:	JUMPN A,IOFIL	;NOT PPN OR (FIL.EXT)
	PUSHJ P,PPNEXT
	JUMPN A,IOEXT	;(FIL.EXT)
	HLRZ A,(T)
	HLRZ A,(A)	;CAAR IS PROJECT NUMBER
	PUSHJ P,SIXMAK
	PUSHJ P,SIXRT
	HRLM A,PPN	;PROJECT NUMBER
	HLRZ A,(T)
	PUSHJ P,CADR	;CADAR IS PROGRAMMER NUMBER
	PUSHJ P,SIXMAK
	PUSHJ P,SIXRT
	HRRM A,PPN	;PROGRAMMER NUMBER
	HRLZI A,(SIXBIT /DSK/)	;DISK IS ASSUMED
	JRST IODEV2

IOFIL:	SKIPN DEV
	JRST AIN.1	;NO DEVICE NAMED
	JUMPN A,IOFIL2	;WAS IT AN ATOM
	JUMPE T,CPOPJ	;NO, WAS IT NIL (END)
	PUSHJ P,PPNEXT
	JUMPE A,CPOPJ	;SEE A PPN, NO FILE NAMED
IOEXT:	HLRZ A,(T)	;(FILE.EXT)
	HRRZ A,(A)	;GET CDR == EXTENSION
	PUSHJ P,SIXMAK
	HLLM A,EXT
	HLRZ A,(T)
	HLRZ A,(A)	;GET CAR = FILE NAME
	PUSHJ P,SIXMAK
FIL:	PUSH P,A
	PUSHJ P,INXTIO
	JRST POPAJ

IOFIL2:	CAIN B,":"-40
	POPJ P,		;SAW A :,NOT FILE NAME
	SETZM EXT	;FILE NAME -- CLEAR EXTENSION
	JRST FIL

PPNEXT:	JUMPE T,CPOPJ	;END OF FILE NAME LIST
	HLRZ A,(T)
	HRRZ A,(A)	;CDAR
	JRST ATOM	;PPN IFF (NOT(ATOM(CDAR L)))

CHNSUB:	MOVE T,A
	HLRZ A,(T)
	PUSHJ P,ATOM
	JUMPE A,TRUE	;NON-ATOMIC HEAD OF LIST -- NO CHANNEL NAMED
	HLRZ A,(T)
	PUSHJ P,SIXMAK
	ANDI A,77
	CAIN A,":"-40
	JRST TRUE	;DEVICE NAME, ASSUME CHANNEL NAME T
	HLRZ A,(T)	;CHANNEL NAME -- RETURN IT
	HRRZ T,(T)
	POPJ P,

CHTAB=.-FSTCH
	BLOCK NCH				;*

;CHANNEL DATA
CHNAM==0	;NAME OF CHANNEL
CHDEV==1	;NAME OF DEVICE
CHPPN==2	;PPN FOR INPUT CHANNEL
CHOCH==3	;OLDCH FOR INPUT CHANNELS
CHPAGE==4	;PAGE NUMBER FOR INPUT
CHLINE==5	;LINE NUMBER FOR INPUT
CHDAT==6	;DEVICE DATA
POINTR==7	;BYTE POINTER FOR DEVICE BUFFER
COUNT==10	;CHARACTER COUNT FOR DEVICE BUFFER
CHLL==2		;LINELENGTH FOR OUTPUT CHANNEL
CHHP==3		;HPOSIT FOR OUTPUT CHANNELS
PAGE
;SEARCH FOR CHANNEL NAME IN CHTAB
TABSR1:	MOVE A,[XWD -NCH,FSTCH]
	MOVE C,CHTAB(A)
	CAME B,CHNAM(C)
	AOBJN A,.-2
	CAMN B,CHNAM(C)
	POPJ P,	;FOUND IT!!!
	JRST FALSE	;LOST

;SEARCH FOR CHANNEL NAME IN CHTAB, AND IF NOT THERE FIND A FREE CHANNEL, AND
;IF NO FREE CHANNEL, ALLOCATE A NEW BUFFER AND CHANNEL
TABSRC:	MOVE B,A
	PUSHJ P,TABSR1
	JUMPN A,DEVCLR	;FOUND THE CHANNEL
	PUSH P,B
	MOVE B,0
	PUSHJ P,TABSR1	;FIND A PHYSICAL CHANNEL NO. FOR A FREE CHANNEL
	JUMPE A,[ERR1 [SIXBIT $NO I/O CHANNELS LEFT !$]]
	POP P,B
	JUMPN C,DEVCLR	;FOUND FREE CHANNEL WHICH HAD BUFFER SPACE PREVIOUSLY
	PUSH P,A	;MUST ALLOCATE NEW BUFFER
	MOVEI A,BLKSIZ
	PUSHJ P,MORCOR	;EXPAND CORE FOR BUFFER IF NECESSARY
	MOVE C,A
	POP P,A
	HRRM C,CHTAB(A)
DEVCLR:	HRRZ C,CHTAB(A)
	HRRZM B,CHNAM(C)	;STORE NAME
	HRRZM A,CHANNEL#
	POPJ P,

;SUBROUTINE TO RESET ALL I/O CHANNELS	-- USED BY EXCISE AND REALLOC
IOBRST:	X	;JSR LOCATION
	HRRZ A,JOBREL
	HRLM A,JOBSA
	MOVEM A,CORUSE#
	MOVEM A,JOBSYM
	SETZM CHTAB+FSTCH
	MOVE A,[XWD CHTAB+FSTCH,CHTAB+FSTCH+1]
	BLT A,CHTAB+NCH+FSTCH-1	;CLEAR CHANNEL TABLE
	JRST @IOBRST
PAGE
INPUT:	PUSHJ P,CHNSUB	;DETERMINE CHANNEL NAME
	PUSH P,A
	PUSHJ P,TABSRC	;GET PHYSICAL CHANNEL NUMBER
	PUSHJ P,SETIN	;INIT DEVICE
	JRST POPAJ

SETIN:	MOVE A,CHDEV(C)
	MOVEM A,DEV
	MOVE A,CHPPN(C)
	MOVEM A,PPN
	PUSHJ P,IOSUB	;GET DEVICE AND FILE NAME
	MOVEM A,LOOKIN	;FILE NAME
	MOVE A,DEV
	CALLI A,DEVCHR
	TLNN A,INB
	JRST AIN.2	;NOT INPUT DEVICE
	TLNN A,AVLB
	JRST AIN.4	;NOT AVAILABLE
	MOVE A,CHANNEL
	DPB A,[POINT 4,ININIT,ACFLD]	;SET UP CHANNEL NUMBERS
	DPB A,[POINT 4,INLOOK,ACFLD]
	DPB A,[POINT 4,ININBF,ACFLD]
	HRRZ B,CHTAB(A)
	HRLM T,CHTAB(A)		;SAVE REMAINING FILE NAME LIST
	MOVEI A,CHDAT(B)
	MOVEM A,DEV+1		;POINTER TO BUFDAT
ININIT:	INIT X,
DEV:	X
	X
	JRST AIN.7		;CANT INIT
	PUSH B,DEV
	PUSH B,PPN
INLOOK:	LOOKUP X,LOOKIN
	JRST AIN.7		;CANT FIND FILE
	PUSH B,[0]	;OLDCH
	PUSH B,[0]	;LINE NUMBER
	PUSH B,[0]	;PAGE NUMBER
	ADDI B,4
	HRRM B,JOBFF
ININBF:	INBUF X,NIOB
	JRST TRUE

ENTR:
LOOKIN:	BLOCK 4
EXT=LOOKIN+1
PPN=LOOKIN+3	
PAGE
OUTPUT:	PUSHJ P,CHNSUB	;GET CHANNEL NAME
	PUSH P,A
	TRO A,400000	;SET BIT FOR OUTPUT
	PUSHJ P,TABSRC	;GET PHYSICAL CHANNEL NUBER
	PUSHJ P,IOSUB	;GET DEVICE AND FILE NAME
	MOVEM A,ENTR	;FILE NAME
	SETZM ENTR+2	;ZERO CREATION DATE
	MOVE A,CHANNEL
	DPB A,[POINT 4,AOUT2,ACFLD]	;SETUP CHANNEL NUMBERS
	DPB A,[POINT 4,OUTENT,ACFLD]
	DPB A,[POINT 4,OUTOBF,ACFLD]
	HRRZ B,CHTAB(A)
	MOVEI A,CHDAT(B)
	HRLM A,AOUT3+1
	MOVE A,DEV
	MOVEM A,AOUT3
	CALLI A,DEVCHR
	TLNN A,OUTB
	JRST AOUT.2	;NOT OUTPUT DEVICE
	TLNN A,AVLB
	JRST AOUT.4	;NOT AVAILABLE
AOUT2:	INIT X,
AOUT3:	X
	X
	JRST AOUT.4	;CANT INIT
	PUSH B,DEV
OUTENT:	ENTER X,ENTR
	JRST OUTERR	;CANT ENTER
	PUSH B,[LPTLL]		;LINELENGTH
	PUSH B,[LPTLL]		;CHRCT
	ADDI B,6
	HRRM B,JOBFF
OUTOBF:	OUTBUF X,NIOB
	JRST POPAJ

OUTERR:	PUSHJ P,AIOP
	LDB A,[POINT 3,ENTR+1,35]
	CAIE A,2
	ERR1 [SIXBIT /DIRECTORY FULL !/]
	ERR1 [SIXBIT /FILE IS WRITE PROTECTED !/]
PAGE
IOSEL:	MOVE C,-1(P)
	JUMPE C,CPOPJ	;TTY 
	JUMPE B,IOSELZ	;DONT RELEASE
	DPB C,[POINT 4,.+1,ACFLD]
	RELEASE X,		;RELEASE CHANNEL
	HRRZS CHTAB(C)		;RELEASE CHANNEL TABLE ENTRY
	MOVEM 0,@CHTAB(C)	;BLAST CHANNEL NAME
	SETZM -1(P)
IOSELZ:	HRRZ C,CHTAB(C)
	POPJ P,
PAGE
INCNT:	MOVEI A,0	;(INC NIL T)
	MOVEI B,1

INC:	PUSH P,INCH#
	PUSHJ P,IOSEL
	JUMPN B,INC2	;RELEASED CHANNEL
	SKIPN C
	MOVEI C,TTOCH-CHOCH	;TTY DESELECT
	MOVEI B,CHOCH(C)
	HRLI B,OLDCH
	BLT B,CHLINE(C)		;SAVE CHANNEL DATA
INC2:	JUMPE A,ITTYRE		;SELECT TTY
	MOVE B,A
	PUSHJ P,TABSR1		;DETERMINE PHYSICAL CHANNEL NUMBER
	JUMPE A,[ERR1 [SIXBIT/NO INPUT - INC!/]]
	HRRZM A,INCH
	DPB A,[POINT 4,TYI2X,ACFLD]	;SET UP CHANNEL NUMBERS
	DPB A,[POINT 4,TYI2Y,ACFLD]
	DPB A,[POINT 4,TYI2Z,ACFLD]
	HRRZ A,CHTAB(A)
	MOVEI T,COUNT(A)
	HRLI T,(SOSG)
	MOVEI B,POINTR(A)
	HRRM B,TYI3	;SET UP TYI PARAMETERS
	HRRM B,TYI3A
INC3:	MOVSI B,CHOCH(A)
	HRRI B,OLDCH
	BLT B,LINUM	;RESTORE CHANNEL DATA
	MOVEM T,TYID
IOEND:	POP P,A
	JUMPE A,CPOPJ
	HRRZ A,@CHTAB(A)	;GET CHANNEL NAME
	TRZ A,400000	;CLEAR OUTPUT BIT
	POPJ P,

ITTYRE:	SETZM INCH
	MOVE T,[JRST TTYI]	;RESELECT TTY
	MOVEI A,TTOCH-CHOCH
	JRST INC3
PAGE
OUTCNT:	MOVEI A,0	;(OUTC NIL T)
	MOVEI B,1

OUTC:	PUSH P,OUTCH#
	PUSHJ P,IOSEL
	JUMPN B,OUTC2	;CLOSED THIS FILE
	SKIPN C
	MOVEI C,TTOLL-CHLL	;TTY DESELECT
	MOVE B,CHCT
	MOVEM B,CHHP(C)		;SAVE CHANNEL DATA
	MOVE B,LINL
	MOVEM B,CHLL(C)
OUTC2:	JUMPE A,OTTYRE		;RETURN TO TTY
	TRO A,400000		;SET OUTPUT BIT
	MOVE B,A
	PUSHJ P,TABSR1		;DETERMINE PHYSICAL CHANNEL NUMBER
	JUMPE A,[ERR1 [SIXBIT /NO OUTPUT - OUTC!/]]
	DPB A,[POINT 4,TYO2X,ACFLD]	;SET UP TYO2 CHANNEL NUMBERS
	HRRZM A,OUTCH
	HRRZ A,CHTAB(A)
	MOVEI B,POINTR(A)
	HRRM B,TYO5	;SET UP TYO2 PARAMETERS
	MOVEI T,COUNT(A)
	HRLI T,(SOSG)
OUTC3:	MOVE B,CHLL(A)
	MOVEM B,LINL
	MOVE B,CHHP(A)
	MOVEM B,CHCT
	MOVEM T,TYOD
	JRST IOEND

OTTYRE:	SETZM OUTCH
	MOVE T,[JRST TTYO]
	MOVEI A,TTOLL-CHLL	;TTY RESELECT
	JRST OUTC3
PAGE
AIN.1:	PUSHJ P,AIOP
	ERR1 [SIXBIT $ILLEGAL I/O ARG!$]
AOUT.2:
AIN.2:	PUSHJ P,AIOP
	ERR1 [SIXBIT /ILLEGAL DEVICE!/]
AOUT.4:
AIN.4:	PUSHJ P,AIOP
	ERR1 [SIXBIT /DEVICE NOT AVAILABLE !/]
AIN.7:	PUSHJ P,AIOP
	ERR1 [SIXBIT /CAN'T FIND FILE - INPUT!/]

AIN.8:	SIXBIT /INPUT ERROR!/

AIOP:	MOVE A,DEVDAT
	JRST EPRINT

		SUBTTL PRINT     --- PAGE 8

EPRINT:	SKIPN ERRSW
	POPJ P,
	PUSHJ P,ERRIO
	PUSHJ P,PRINT
	JRST OUTRET

PRINT:	MOVEI R,TYO
	PUSHJ P,TERPRI
	PUSHJ P,PRIN1
	XCT " ",CTY
	POPJ P,

PRINC:	SKIPA R,.+1
PRIN1:	HRRZI R,TYO
	PUSH P,A
	PUSHJ P,PRINTA
	JRST POPAJ

PRINTA:	PUSH P,A
	MOVEI B,PRIN3
	SKIPGE R
	MOVEI B,PRIN4
	HRRM B,PRIN5
	PUSHJ P,PATOM
	JUMPN A,PRINT1
	XCT "(",CTY
PRINT3:	HLRZ A,@(P)
	PUSHJ P,PRINTA
	HRRZ A,@(P)
	JUMPE A,PRINT2
	MOVEM A,(P)
	XCT " ",CTY
	PUSHJ P,PATOM
	JUMPE A,PRINT3
	XCT ".",CTY
	XCT " ",CTY
	PUSHJ P,PRIN1A
PRINT2:	XCT ")",CTY
	JRST POPAJ

PRINT1:	PUSHJ P,PRIN1A
	JRST POPAJ
PAGE
PRIN1A:	MOVE A,-1(P)
	CAILE A,INUMIN
	JRST PRINIC
	JUMPE A,PRIN1B
	CAIGE A,@GCP1
	CAIGE A,@GCPP1
	JRST PRINL
PRIN1B:	HRRZ A,(A)
	JUMPE A,PRINL
	HLRZ B,(A)
	HRRZ A,(A)
FOO	CAIN B,PNAME
	JRST PRINN
FOO	CAIN B,FIXNUM
	JRST PRINI1
FOO	CAIN B,FLONUM
	JRST PRINO
BPR:	JRST PRIN1B	;BIGNUMS CHANGE HERE TO JRST BPRINT
	JRST PRIN1B

PRINL2:	MOVEI R,TYO
	JRST PRINL1

PRINL:	XCT "#",CTY
	HRRZ A,-1(P)
PRINL1:	MOVEI C,8
	JRST PRINI3

PRINI1:	SKIPA A,(A)
PRINIC:	SUBI A,INUM0
FOO	HRRZ C,VBASE
	SUBI C,INUM0
	JUMPGE A,PRINI2
	XCT "-",CTY
	MOVNS A
PRINI2:	MOVEI B,"."-"0"
	HRLM B,(P)
	CAIN C,TEN
FOO	SKIPE %NOPOINT
	JRST .+2
	PUSH P,PRINI4
PRINI3:	JUMPL A,[	MOVEI B,0	;CASE OF -2^35
			MOVEI A,1
			DIVI A,(C)
			JRST .+2]
	IDIVI A,0(C)
	HRLM B,(P)
	SKIPE A
	PUSHJ P,.-3
PRINI4:	JRST FP7A1

PRINN:	HLRZ A,(A)
	MOVEI C,2(SP)
	PUSHJ P,PNAMU3
	PUSH C,[0]
	HRLI C,(POINT 7,0,35)
	HRRI C,2(SP)
	ILDB A,C
	JUMPE A,CPOPJ		;SPECIAL CASE OF NULL CHARACTER
	CAIN A,DBLQT
	JRST PSTR	;STRING
PRIN2X:	LDB B,[POINT 1,CHRTAB(A),1]
	JUMPL R,PRIN4	;NEVER SLASH
	JRST PRIN2(B)	;1 FOR NO SLASH

PRIN3:	SKIPL CHRTAB(A)	;<0 FOR NO SLASH
PRIN2:	XCT "/",CTY
PRIN4:	PUSHJ P,(R)
	ILDB A,C
PRIN5:	JUMPN A,PRIN3	;PRIN4 FOR NEVER SLASH
	POPJ P,

PSTR:	MOVS B,(C)
	CAIN B,(<ASCII /"/>)
	JRST PRIN2X	;SPECIAL CASE OF /"
PSTR3:	SKIPL R		;DONT PRINT " IF NO SLASHIFY
PSTR2:	PUSHJ P,(R)
	ILDB A,C
	CAIE A,DBLQT
	JUMPN A,PSTR2
	JUMPN A,PSTR3
	POPJ P,

TERPRI:	PUSH P,A
	MOVEI A,CR
	PUSHJ P,TYO
	MOVEI A,LF
CTYO:	PUSHJ P,TYO
	JRST POPAJ

CTY:	JSA A,TYOI
TYOI:	X
	PUSH P,A
	LDB A,[POINT 6,-1(A),ACFLD]
	PUSHJ P,(R)
	POP P,A
	JRA A,(A)

PRINO:	MOVE A,(A)
	CLEARB B,C
	JUMPG A,FP1
	JUMPE A,FP3
	MOVNS A
	XCT "-",CTY
FP1:	CAMGE A,FT01
	JRST FP4
	CAML A,FT8
	AOJA B,FP4

FP3:	MULI A,400
	ASHC B,-243(A)
	MOVE A,B
	CLEARM FPTEM#
	PUSHJ P,FP7
	XCT ".",CTY
	MOVNI T,8
	ADD T,FPTEM
	MOVE B,C

FP3A:	MOVE A,B
	MULI A,TEN
	PUSHJ P,FP7B
	SKIPE B
	AOJL T,FP3A
	POPJ P,

FP4:	MOVNI C,6
	MOVEI TT,0
FP4A:	ADDI TT,1(TT)
	XCT FCP(B)
	TRZA TT,1
	FMPR A,@FCP+1(B)
	AOJN C,FP4A
	PUSH P,TT
	MOVNI B,-2(B)
	DPB B,[POINT 2,FP4C,11]
	PUSHJ P,FP3
	MOVEI A,"E"
	PUSHJ P,(R)
FP4C:	XCT "+"+X,CTY
	POP P,A
FP7:	JUMPE A,FP7A1
	IDIVI A,TEN
	AOS FPTEM
	HRLM B,(P)
	JUMPE A,FP7A1
	PUSHJ P,FP7

FP7A1:	HLRE A,(P)
FP7B:	ADDI A,"0"
	JRST (R)

	353473426555	;1E32
	266434157116	;1E16
FT8:	1.0E8
	1.0E4
	1.0E2
	1.0E1
FT:	1.0E0
	026637304365	;1E-32
	113715126246	;1E-16
	146527461671	;1E-8
	163643334273	;1E-4
	172507534122	;1E-2
FT01:	175631463146	;1E-1
FT0:
FCP:	CAMLE A,FT0(C)
	CAMGE A,FT(C)
	XWD C,FT0


		SUBTTL SUPER FAST TABLE DRIVEN READ 	14-MAY-69      PAGE 9

;MAGIC SCANNER TABLE BIT DEFINITIONS

;BIT 0=0 IFF SLASHIFIED AS 1ST ID CHARACTER
;BIT 1=0 IFF SLASHIFIED AS NTH ID CHARACTER
;BITS 2-5	RATAB INDEX
;BITS 6-8	DOTAB INDEX
;BITS 9-10	STRTAB INDEX
;BITS 11-13	IDTAB INDEX
;BITS 14-16	EXPTAB INDEX
;BITS 17-19	RDTAB INDEX
;BITS 20-25	ASCII TO RADIX 50 CONVERSION

IGSTRT:	IGCRLF
IGEND:	LF

RATFLD:	POINT 4,CHRTAB(A),5
STRFLD:	POINT 2,CHRTAB(A),10
IDFLD:	POINT 3,CHRTAB(A),13
DOTFLD:
NUMFLD:	POINT 3,CHRTAB(A),8
EXPFLD:	POINT 3,CHRTAB(A),16
RDFLD:	POINT 3,CHRTAB(A),19
R50FLD:	POINT 6,CHRTAB(A),25

;MAGIC STATE FLAGS IN T
EXP==1		;EXPONENT 
NEXP==2		;NEGATIVE EXPONENT
SAWDOT==4	;SAW A DOT (.)
MINSGN==10	;NEGATIVE NUMBER

IDCLS==0	;IDENTIFIER
STRCLS==1	;STRING
NUMCLS==2	;NUMBER
DELCLS==3	;DELIMITER

PAGE
;MACROS FOR SCANNER TABLE

DEFINE RAD50 (X)<
IFB <X>,<R50VAL=0>
IFLE <"X"-"9">,<IFGE <"X"-"0">,<R50VAL="X"-"0"+1>>
IFIDN <"X"><".">,<R50VAL=45>
IFGE <"X"-"A">,<R50VAL="X"-"A"+13>>

DEFINE TABIN (S1,SN,R,D,S,I,E,RD,R50)<
XLIST
IRPC R50<	RAD50 (R50)
	BYTE (1)S1,SN(4)R(3)D(2)S(3)I,E,RD(6)R50VAL>
LIST>

DEFINE LET (X)<
TABIN (1,1,5,2,3,4,2,0,X)>

DEFINE DELIMIT (X,Y)<
TABIN (0,0,2,2,3,2,2,Y,X)>

DEFINE IGNORE (X)<
TABIN (0,0,3,2,3,2,2,0,X)>
PAGE
CHRTAB:
TABIN (0,0,1,1,1,1,1,0,< >)	
;NULL
LET (<        >)
IGNORE (<     >)		
;TAB,LF,VTAB,FF,CR
LET (<            >)	
;16 TO 31
TABIN (0,0,0,0,0,0,0,0,< >)
;IGMRK
LET (<     >)
;33 TO 37
IGNORE (< >)			
;SPACE
LET (< >)			
;!
TABIN (0,0,9,2,2,2,2,0,< >)	
;"
LET (< $%  >)			
;#$%&'
DELIMIT (< >,0)
DELIMIT (< >,1)
;()
LET (< >)			
;*
TABIN (1,0,3,2,3,4,2,0,< >)	
;+
IGNORE (< >)			
;,
TABIN (1,0,6,2,3,4,2,0,< >)	
;-
TABIN (0,0,7,3,3,2,2,4,<.>)
TABIN (0,0,4,2,3,3,2,0,< >)	
;/
TABIN (1,0,8,5,3,4,3,0,<0123456789>)
LET (<      >)			
;:;<=>?
TABIN (1,0,2,2,3,4,2,5,< >)	
;@
LET (<ABCD>)
TABIN (1,1,5,4,3,4,2,0,<E>)
LET (<FGHIJKLMNOPQRSTUVWXYZ>)
DELIMIT (< >,2)			
;[
LET (< >)			
;\
DELIMIT (< >,3)			
;]
LET (<   >)			
;^_`
LET (<ABCDEFGHIJKLMNOPQRSTUVWXYZ>)	
;LOWER CASE
LET (<  >)			
;{
DELIMIT (< >,3)			
;ALTMODE
LET (< >)
;~
DELIMIT (< >,6)			
;RUBOUT
PAGE
READCH:	PUSHJ P,TYI
	MOVSI AR1,AR1
	PUSHJ P,EXPL1
	JRST CAR

READP1:	SETZM NOINFG
READ0:	PUSH P,TYID
	PUSH P,OLDCH
	SETZM OLDCH#
	HRLI A,(JRST)
	MOVEM A,TYID
	PUSHJ P,READ+1
	POP P,OLDCH
	POP P,TYID
	POPJ P,

RDRUB:	MOVEI A,CR
	PUSHJ P,TTYO
	MOVEI A,LF
	PUSHJ P,TTYO
	SKIPA P,PSAV#
READ:	SETZM NOINFG#	;0 MEANS INTERN
	MOVEM P,PSAV
	PUSHJ P,READ1
	SETZM PSAV
	POPJ P,

READ1:	PUSHJ P,RATOM
	POPJ P,		;ATOM
	XCT RDTAB2(B)
	JRST READ1	;TRY AGAIN

RDTAB2:	JRST READ2	;0	(
	JFCL		;1	)
	JRST READ4	;2	[
	JFCL		;3	],$
	JFCL		;4	.
	JRST RDQT	;5	@

READ2:	PUSHJ P,RATOM
	JRST READ2A	;ATOM
	XCT RDTAB(B)

READ2A:	PUSH P,A
	PUSHJ P,READ2
	POP P,B
	JRST XCONS

RDTAB:	PUSHJ P,READ2	;0	(
	JRST FALSE	;1	)
	PUSHJ P,READ4	;2	[
	JRST READ5	;3	],$
	JRST RDT	;4	.
	PUSHJ P,RDQT	;5	@

RDTX:	PUSHJ P,RATOM
	POPJ P,	;ATOM
	XCT RDTAB2(B)
	JRST ER2	;DOT CONTEXT ERROR

RDT:	PUSHJ P,RDTX
	PUSH P,A
	PUSHJ P,RATOM
	JRST ER2
	CAIN B,1
	JRST POPAJ
	CAIE B,3
	JRST ER2
	MOVEM A,OLDCH
	JRST POPAJ


READ4:	PUSHJ P,READ2
	MOVE B,OLDCH
	CAIE B,ALTMOD
TYI1:	SETZM OLDCH	;KILL THE ]
	POPJ P,

READ5:	MOVEM A,OLDCH	;SAVE ] OR $
	JRST FALSE	;AND RETURN NIL


RDQT:	PUSHJ P,READ1
	JRST QTIFY
PAGE
;ATOM PARSER

COMMENT:	PUSHJ P,TYID
	CAME A,IGEND
	JRST COMMENT
	POPJ P,

RATOM:	SETZB T,R
	HRLI C,(POINT 7,0,35)
	HRRI C,(SP)
	MOVEI AR1,1
RATOM2:	PUSHJ P,TYIA
	LDB B,RATFLD
	JRST RATAB(B)

RATAB:	PUSHJ P,COMMENT	;0	COMMENT
	JRST RATOM2	;1	NULL
	JRST RATOM3	;2	DELIMIT
	JRST RATOM2	;3	IGNORE
	PUSHJ P,TYI	;4	/
	JRST RDID	;5	LETTER
	JRST RDNMIN	;6	-
	JRST RDOT	;7	.
	JRST RDNUM	;8	DIGIT
	JRST RDSTR	;9	STRING

;A REAL DOTTED PAIR
RDOT2:	MOVEM A,OLDCH
	MOVEI A,"."
RATOM3:	LDB B,RDFLD
	HRRI R,DELCLS	;DELIMITER
	AOS (P)		;NON-ATOM (IE A DELIMITER)
	POPJ P,

;DOT HANDLER
RDOT:	PUSHJ P,TYID
	LDB B,DOTFLD
	JRST DOTAB(B)

DOTAB:	PUSHJ P,COMMENT	;0	COMMENT
	JRST RDOT	;1	NULL
	JRST RDOT2	;2	DELIMIT
	JRST RDOT2	;3	DOT
	JRST RDOT2	;4	E
	MOVEI B,0	;5	DIGIT
	IDPB B,C
	TLO T,SAWDOT
	JRST RDNUM
PAGE
;STRING SCANNER
STRTAB:	PUSHJ P,COMMENT	;0	COMMENT
	JRST RDSTR+1	;1	NULL
	JRST STR2	;2	DELIMIT
RDSTR:	IDPB A,C	;3	STRING ELEMENT
	PUSHJ P,TYID
	LDB B,STRFLD
	JRST STRTAB(B)

STR2:	MOVEI A,DBLQT
	HRRI R,STRCLS	;STRING
	IDPB A,C
NOINTR:	PUSHJ P,IDEND	;NO INTERN
	PUSHJ P,IDSUB
	JRST PNAMAK


;IDENTIFIER SCANNER
IDTAB:	PUSHJ P,COMMENT	;0	
	JRST RDID+1	;1	NULL
	JRST MAKID	;2	DELIMIT
	PUSHJ P,TYI	;3	/
RDID:	IDPB A,C	;4	LETTER OR DIGIT
	PUSHJ P,TYID
	LDB B,IDFLD	
	JRST IDTAB(B)

PAGE
;NUMBER SCANNER
NUMTAB:	PUSHJ P,COMMENT	;0	COMMENT
	JRST RDNUM+1	;1	NULL
	JRST NUMAK	;2	DELIMIT
	JRST RDNDOT	;3	DOT
	JRST RDE	;4	E
RDNUM:	IDPB A,C	;5	DIGIT
	PUSHJ P,TYID
	LDB B,NUMFLD
	JRST NUMTAB(B)

RDNDOT:	TLOE T,SAWDOT
	JRST NUMAK	;TWO DOTS - DELIMIT
	MOVEI A,0
	JRST RDNUM

RDNMIN:	TLO T,MINSGN
	JRST RDNUM+1

;EXPONENT SCANNER
RDE:	TLO T,EXP
	MOVEI A,0
	IDPB A,C
	PUSHJ P,TYID
	CAIN A,"-"
	TLOA T,NEXP
	CAIN A,"+"
	JRST RDE2+1
	JRST RDE2+2

EXPTAB:	PUSHJ P,COMMENT	;0
	JRST RDE2+1	;1	NULL
	JRST NUMAK	;2	DELIMIT
RDE2:	IDPB A,C	;3	DIGIT
	PUSHJ P,TYID
	LDB B,EXPFLD
	JRST EXPTAB(B)
PAGE
;SEMANTIC ROUTINES
;IDENTIFIER INTERNER AND BUILDER

IDEND:	SKIPA A,[0]
	IDPB A,C
	TLNE C,760000
	JRST .-2
	POPJ P,

MAKID:	MOVEM A,OLDCH
	PUSHJ P,IDEND
	SKIPE NOINFG
	JRST NOINTR	;DONT INTERN IT
INTER0:	PUSHJ P,IDSUB
	PUSHJ P,INTER1	;IS IT IN OBLIST
	POPJ P,		;FOUND
	PUSHJ P,PNAMAK	;NOT THERE
MAKID2:	MOVEI C,X	;
	HLRZ B,@RHX2
	PUSHJ P,CONS	;CONS IT INTO THE OBLIST
	HRLM A,@RHX2
	JRST CAR


;PNAME UNMAKER
PNAMUK:
FOO	MOVEI B,PNAME
	PUSHJ P,GET
	JUMPE A,E6
PNAMU2:	MOVE C,SP
PNAMU3:	MOVS B,(A)
	PUSH C,(B)
	HLRZ A,B
	JUMPN A,.-3
	POPJ P,

;IDSUB CONSTRUCTS A IOWD POINTER FOR A PRINT NAME
IDSUB:	HRRZS C
	CAML C,JRELO	;TOP OF SPEC PDL
	JRST SPDLOV
	MOVNS C
	ADDI C,(SP)
	HRLI C,1(SP)
	MOVSM C,IDPTR#
	POPJ P,

PAGE		;IDENTIFIER INTERNER
INTER1:	MOVE B,1(SP)
	LSH B,-1
INT1:	IDIVI B,BCKETS+X
RHX2:
FOO	HLRZ TT,OBTBL(B+1)
	HRRM B+1,MAKID2
	JRST MAKID3+1

MAKID3:	HRRZ TT,(TT)
	JUMPE TT,CPOPJ1	;NOT IN OBLIST
	HLRZ A,(TT)	;NEXT ID IN OBLIST
MAKID4:	HRRZ A,(A)
	JUMPE A,E6	;NO PRINT NAME
	MOVE A,(A)
	HLRZ T,A
FOO	CAIE T,PNAME
	JRST MAKID4
	MOVE T,IDPTR	;FOUND PNAME
	HLRZ A,(A)
MAKID5:	JUMPE A,MAKID3	;NOT THE ONE
	MOVS A,(A)
	MOVE B,(A)
	ANDCAM AR1,(T)	;CLEAR LOW BIT
	CAME B,(T)
	JRST MAKID3	;NOT THE ONE
	HLRZ A,A	;OK SO FAR
	AOBJN T,MAKID5
	JUMPN A,MAKID3	;NOT THE ONE
	HLRZ A,(TT)	;THIS IS IT
	POPJ P,

;PNAME BUILDER
PNAMAK:	MOVE T,IDPTR
	PUSHJ P,NCONS
	MOVE TT,A
	MOVE C,A
PNAMB:	MOVE A,(T)
	TRZ A,1		;CLEAR LOW BIT!!!!!
	PUSHJ P,FWCONS
	PUSHJ P,NCONS
	HRRM A,(TT)
	MOVE TT,A
	AOBJN T,PNAMB
	MOVE A,C
	HRLZS (A)
	JRST PNGNK1+1
PAGE
;NUMBER BUILDER
NUMAK:	MOVEM A,OLDCH
	HRRI R,NUMCLS	;NUMBER
	MOVEI A,0
	IDPB A,C
	IDPB A,C
	HRRZS C
	CAML C,JRELO	;TOP OF SPEC PDL
	JRST SPDLOV
	MOVSI C,(POINT 7,0,35)
	HRRI C,(SP)
	TLNE T,SAWDOT+EXP
	JRST NUMAK2	;DECIMAL NUMBER OR FLT PT
FOO	MOVE A,VIBASE	;IBASE INTEGRER
	SUBI A,INUM0
	PUSHJ P,NUM
NUMAK4:
FOO	MOVEI B,FIXNUM
NUMAK6:	TLNE T,MINSGN
	MOVNS A
	JRST MAKNUM

NUMAK2:	PUSHJ P,NUM10
	MOVEM A,TT
	TLNN T,SAWDOT
	JRST [	PUSHJ P,FLOAT	;FLT PT WITHOUT FRACTION
		MOVE TT,A
		JRST NUMAK3]
	PUSHJ P,NUM10	;FRACTION PART
	EXCH A,TT
	TLNN T,EXP
	JUMPE AR2A,NUMAK4	;NO EXPONENT AND NO FRACTION
	PUSHJ P,FLOAT
	EXCH A,TT
	PUSHJ P,FLOAT
	MOVEI AR1,FT01
	PUSHJ P,FLOSUB
	FMPR A,B
	FADRM A,TT
NUMAK3:	PUSHJ P,NUM10	;EXPONENT PART
	MOVE AR2A,A
	MOVEI AR1,FT-1
	TLNE T,NEXP
	MOVEI AR1,FT01	;-EXPONENT
	PUSHJ P,FLOSUB
	FMPR TT,B	;POSITIVE EXPONENT
FOO	MOVEI B,FLONUM
	MOVE A,TT
	JFCL 10,FLOOV
	JRST NUMAK6

FLOSUB:	MOVSI B,(1.0)
	TRZE AR2A,1
	FMPR B,(AR1)
	JUMPE AR2A,CPOPJ
	LSH AR2A,-1
	SOJA AR1,FLOSUB+1

;VARIABLE RADIX INTEGER BUILDER

NUM10:	MOVEI A,TEN
NUM:	HRRM A,NUM1
	JFCL 10,.+1
	SETZB A,AR2A
NUM2:	ILDB B,C
	JUMPE B,CPOPJ	;DONE
NUM1:	IMULI A,X
	ADDI A,-"0"(B)
NUM3:	JFCL 10,FIXOV	;BIGNUMS CHANGE THIS TO JFCL 10,RDBNM
	AOJA AR2A,NUM2
PAGE
INTERN:	MOVEM A,AR2A
	PUSHJ P,PNAMUK
	PUSHJ P,IDSUB
	MOVEI AR1,1
	PUSHJ P,INTER1		;IS IT IN OBLIST
	POPJ P,			;FOUND IT
	MOVE A,AR2A		;NOT THERE
	JRST MAKID2		;PUT IT THERE

REMOB:	JUMPE A,FALSE
	MOVEI AR1,1
	PUSH P,A
	HLRZ A,(A)
	PUSHJ P,INTERN
	HLRZ B,@(P)
	CAME A,B
	JRST REMOB2
	HRRZ B,MAKID2
RHX5:
FOO	HLRZ C,OBTBL+X(B)
	HLRZ T,(C)
	CAMN T,A
	JRST [	HRRZ TT,(C)
		HRLM TT,@RHX5
		JRST REMOB2]
REMOB3:	MOVE TT,C
	HRRZ C,(C)
	HLRZ T,(C)
	CAME T,A
	JRST REMOB3
	HRRZ T,(C)
	HRRM T,(TT)
REMOB2:	POP P,A
	HRRZ A,(A)
	JRST REMOB

		SUBTTL LISP INTERPRETER SUBROUTINES   --- PAGE 10

CADDDR:	SKIPA A,(A)
CADDAR:	HLRZ A,(A)
CADDR:	SKIPA A,(A)
CADAR:	HLRZ A,(A)
CADR:	SKIPA A,(A)
CAAR:	HLRZ A,(A)
CAR:	HLRZ A,(A)
	POPJ P,

CDDDDR:	SKIPA A,(A)
CDDDAR:	HLRZ A,(A)
CDDDR:	SKIPA A,(A)
CDDAR:	HLRZ A,(A)
CDDR:	SKIPA A,(A)
CDAR:	HLRZ A,(A)
CDR:	HRRZ A,(A)
	POPJ P,

CAADDR:	SKIPA A,(A)
CAADAR:	HLRZ A,(A)
CAADR:	SKIPA A,(A)
CAAAR:	HLRZ A,(A)
	JRST CAAR

CDADDR:	SKIPA A,(A)
CDADAR:	HLRZ A,(A)
CDADR:	SKIPA A,(A)
CDAAR:	HLRZ A,(A)
	JRST CDAR

CAAADR:	SKIPA A,(A)
CAAAAR:	HLRZ A,(A)
	JRST CAAAR

CDDADR:	SKIPA A,(A)
CDDAAR:	HLRZ A,(A)
	JRST CDDAR

CDAADR:	SKIPA A,(A)
CDAAAR:	HLRZ A,(A)
	JRST CDAAR

CADADR:	SKIPA A,(A)
CADAAR:	HLRZ A,(A)
	JRST CADAR
PAGE

QUOTE:	HLRZ A,(A)	;CAR AND QUOTE DUPLICATED FOR BACKTRACE
	POPJ P,

AASCII:	PUSHJ P,NUMVAL
	LSH A,^D29
	PUSHJ P,FWCONS
	PUSHJ P,NCONS
PNGNK1:	PUSHJ P,NCONS
FOO	MOVEI B,PNAME
	PUSHJ P,XCONS
ACONS:	TROA B,-1
NCONS:	TRZA B,-1
XCONS:	EXCH B,A
CONS:	AOS CONSVAL
	HRL B,A
	SKIPN A,F
	JRST [	HLR A,B
		PUSHJ P,AGC
		JRST .-1]
	MOVE F,(F)
	MOVEM B,(A)
	POPJ P,

PATOM:	CAIL A,@GCP1
	JRST TRUE
	CAIL A,@GCPP1
ATOM:	CAILE A,INUMIN
	JRST TRUE
	HLLE A,(A)
	AOJE A,TRUE
	JRST FALSE
PAGE
EQ:	CAMN A,B
	JRST TRUE
	JRST FALSE

LENGTH:	MOVEI B,0
LNGTH1:	CAILE A,INUMIN
	JRST FIX1
	HLLE C,(A)
	AOJE C,FIX1
	HRRZ A,(A)
	AOJA B,LNGTH1

LAST:	HRRZ B,(A)
	CAILE B,INUMIN
	POPJ P,
	HLLE B,(B)
	AOJE B,CPOPJ
	HRRZ A,(A)
	JRST LAST

RPLACA:	HRLM B,(A)
	POPJ P,

RPLACD:	HRRM B,(A)
	POPJ P,

ZEROP:	PUSHJ P,NUMVAL
NOT:
NULL:	JUMPN A,FALSE
TRUE:
FOO	MOVEI A,TRUTH
	POPJ P,

FW0CNS:	MOVEI A,0
FWCONS:	JUMPN FF,FWC1
	EXCH A,FWC0#
	PUSHJ P,AGC
	EXCH A,FWC0
FWC1:	EXCH A,(FF)
	EXCH A,FF
	POPJ P,

PAGE
SASSOC:	PUSHJ P,SAS1
	JCALLF 0,(C)
	POPJ P,

SAS0:	HLRZ B,T
SAS1:	JUMPE B,CPOPJ
	MOVS T,(B)
	MOVS TT,(T)
	CAIE A,(TT)
	JRST SAS0
	HRRZ A,T
CPOPJ1:	AOS (P)
	POPJ P,

ASSOC:	PUSHJ P,SAS1
FALSE:	MOVEI A,0
CPOPJ:	POPJ P,

REVERSE:	MOVE T,A
	MOVEI A,0
	JUMPE T,CPOPJ
	HLRZ B,(T)
	HRRZ T,(T)
	PUSHJ P,XCONS
	JUMPN T,.-3
	POPJ P,


REMPROP:	HRRZ T,(A)
	MOVS TT,(T)
	CAIN B,(TT)
	JRA TT,REMP1
	HLRZ A,TT
	HRRZ T,(A)
	JUMPN T,REMPROP+1
	JRST FALSE

REMP1:	HRRM TT,(A)
	JRST TRUE
PAGE
GET:	HRRZ A,(A)
	MOVS D,(A)
	CAIN B,(D)
	JRST CADR
	HLRZ A,D
	HRRZ A,(A)
	JUMPN A,GET+1
	POPJ P,

GETL:	HRRZ A,(A)
GETL0:	HLRZ T,(A)
	MOVE C,B
GETL1:	MOVS TT,(C)
	CAIN T,(TT)
	POPJ P,
	HLRZ C,TT
	JUMPN C,GETL1
	HRRZ A,(A)
	HRRZ A,(A)
	JUMPN A,GETL0
	POPJ P,

NUMBERP:	CAILE A,INUMIN
	JRST TRUE
	HLLE T,(A)
	AOJN T,FALSE
NUMP2:	HRRZ A,(A)
	HLRZ A,(A)
FOO	CAIE A,FIXNUM
FOO	CAIN A,FLONUM
	JRST TRUE
NUMBP2:	JRST FALSE	;BIGNUMS CHANGE THIS TO JRST BIGNP
PAGE
PUTPROP:	MOVE T,A
	HRRZ A,(A)
CSET3:	MOVS TT,(A)
	HLRZ A,TT
	CAIN C,(TT)
	JRST CSET2
	HRRZ A,(A)
	JUMPN A,CSET3
	HRRZ A,(T)
	PUSHJ P,XCONS
	HRRZ B,C
	PUSHJ P,XCONS
	HRRM A,(T)
	JRST CADR

CSET2:
FOO	CAIE C,VALUE
	JRST CSET1
	HRRZ T,(B)
	HLRZ A,(A)
	HRRM T,(A)
	JRST PROG2

CSET1:	HRLM B,(A)
PROG2:	MOVE A,B
	POPJ P,

DEFPROP:	
	HRRZ B,(A)
	HRRZ C,(B)
	HLRZ A,(A)
	HLRZ B,(B)
	HLRZ C,(C)
	PUSH P,A
	PUSHJ P,PUTPROP
	JRST POPAJ
PAGE
EQUAL:	MOVE C,P
EQUAL1:	CAMN A,B
	JRST TRUE
	MOVE T,A
	MOVE TT,B
	PUSHJ P,ATOM
	EXCH A,B
	PUSHJ P,ATOM
	CAMN A,B
	JRST EQUAL3
EQUAL4:	MOVE P,C
	JRST FALSE

EQUAL3:	JUMPN A,EQ2
	PUSH P,T
	PUSH P,TT
	HLRZ A,(T)
	HLRZ B,(TT)
	PUSHJ P,EQUAL1
	JUMPE A,EQUAL4
	POP P,B
	POP P,A
	HRRZ A,(A)
	HRRZ B,(B)
	JRST EQUAL1

EQ2:	PUSH P,T
	MOVE A,T
	PUSHJ P,NUMBERP
	JUMPE A,EQUAL4
	MOVE A,TT
	PUSHJ P,NUMBERP
	JUMPE A,EQUAL4
	MOVE A,(P)
	MOVEM C,(P)
	MOVE B,TT
	JSP C,OP
	JUMPL COMP3
	JUMPL COMP3

COMP3:	POP P,C
	CAME A,TT
	JRST EQUAL4
	JRST TRUE
PAGE
SUBS5:	HRRZ A,SUBAS
	POPJ P,

SUBST:	MOVEM A,SUBAS#
	MOVEM B,SUBBS#
SUBS0A:	MOVE A,SUBAS
	MOVE B,SUBBS
	PUSH P,C
	MOVE A,C
	PUSHJ P,EQUAL
	POP P,C
	JUMPN A,SUBS5
	CAILE C,INUMIN
	JRST EV6A
	HLLE T,(C)
	AOJN T,SUBS2
EV6A:	MOVE A,C
	POPJ P,

SUBS2:	PUSH P,C
	HLRZ C,(C)
	PUSHJ P,SUBS0A
	EXCH A,(P)
	HRRZ C,(A)
	PUSHJ P,SUBS0A
	POP P,B
	JRST XCONS
PAGE
NCONC:	TDZA R,R
APPEND:	MOVEI R,.APPEND-.NCONC
	JUMPE T,FALSE
	POP P,B
APP2:	AOJE T,PROG2
	POP P,A
	PUSHJ P,.NCONC(R)
	MOVE B,A
	JRST APP2

.NCONC:	JUMPE A,PROG2
	MOVE TT,A
	MOVE C,TT
	HRRZ TT,(C)
	JUMPN TT,.-2
	HRRM B,(C)
	POPJ P,

.APPEND:	JUMPE A,PROG2
	MOVEI C,AR1
	MOVE TT,A
APP1:	HLRZ A,(TT)
	PUSH P,B
	PUSHJ P,CONS	;SAVES B
	POP P,B
	HRRM A,(C)
	MOVE C,A
	HRRZ TT,(TT)
	JUMPN TT,APP1
	JRST SUBS4

MEMBER:	MOVEM A,SUBAS
MEMB1:	JUMPE B,FALSE
	MOVEM B,SUBBS
	MOVE A,SUBAS
	HLRZ B,(B)
	PUSHJ P,EQUAL
	JUMPN A,CPOPJ
	MOVE B,SUBBS
	HRRZ B,(B)
	JRST MEMB1

MEMQ:	JUMPE B,FALSE
	MOVS C,(B)
	CAIN A,(C)
	JRST TRUE
	HLRZ B,C
	JUMPN B,MEMQ+1
	JRST FALSE
PAGE
AND:
FOO	HRLI A,TRUTH
OR:	HLRZ C,A
	PUSH P,C
ANDOR:	HRRZ C,A
	JUMPE C,AOEND
	MOVSI C,(SKIPE (P))
	TLNE A,-1
	MOVSI C,(SKIPN (P))
	XCT C
	JRST AOEND
	MOVEM A,(P)
	HLRZ A,(A)
	PUSHJ P,EVAL
	EXCH A,(P)
	HRR A,(A)
	JRST ANDOR

AOEND:	POP P,A
	SKIPE A
FOO	MOVEI A,TRUTH
	POPJ P,
PAGE
GENSYM:	MOVE B,[POINT 7,GNUM,34]
	MOVNI C,4
	MOVEI TT,"0"

GENSY2:	LDB T,B
	AOS T
	DPB T,B
	CAIG T,"9"
	JRST GENSY1
	DPB TT,B
	ADD B,[XWD 70000,0]
	AOJN C,GENSY2

GENSY1:	MOVE A,GNUM
	PUSHJ P,FWCONS
	PUSHJ P,NCONS
	JRST PNGNK1

GNUM:	ASCII /G0000/			;*

CSYM:	HLRZ A,(A)
	PUSH P,A
FOO	MOVEI B,PNAME
	PUSHJ P,GET
	JUMPE A,E6
	HLRZ A,(A)
	MOVE A,(A)
	MOVEM A,GNUM
	JRST POPAJ
PAGE
LIST:	MOVE B,A
FOO	MOVEI A,CEVAL
	JRST MAPCAR

EELS:	HLRZ TT,(T)	;INTERPRET LSUBR CALL
	HRRZ A,(AR1)
ILIST:	MOVEI T,0
	JUMPE A,ILIST2
ILIST1:	PUSH P,A
	HLRZ A,(A)
	PUSH P,TT
	HRLM T,(P)
	PUSHJ P,EVAL
ILIST3:	POP P,TT
	HLRE T,TT
	EXCH A,(P)
	HRRZ A,(A)
	SOS T
	JUMPN A,ILIST1
ILIST2:	JRST (TT)

MAPC:	TLO A,400000
MAP:	TLOA A,200000
MAPCAR:	TLO A,400000
MAPLIST:	JUMPE B,FALSE
	PUSH P,A
	PUSH P,B
	PUSH P,B
	HRLZM P,(P)
MAPL2:	MOVE A,-1(P)
	SKIPGE -2(P)
	HLRZ A,(A)
	CALLF 1,@-2(P)
	LDB C,[XWD 420100,-2(P)]
	JUMPN C,MAP1
	PUSHJ P,NCONS
	HLR B,(P)
	HRRM A,(B)
	HRLM A,(P)
MAP1:	HRRZ B,@-1(P)
	MOVEM B,-1(P)
	JUMPN B,MAPL2
	POP P,AR1
	SUB P,[XWD 2,2]
SUBS4:	HRRZ A,AR1
	POPJ P,0
PAGE
PA3:	0	;LH=0=>RH =NEXT PROG STATEMENT		*
	;LH - =>RH = TAG TO GO TO
PA4:	0	;LH=-1,RH=PNTR TO PROG LESS BOUND VAR LIST	*
	;LH=+,RH RETURN VALUE
	;2.1=>DONT DO UNBND

PROG:	PUSH P,PA3
	PUSH P,PA4
	HLRZ TT,(A)
	HRRZ A,(A)
	HRROM A,PA4
	MOVEM A,PA3
	JUMPE TT,PG0
	MOVSI C,1
FOO	MOVEI B,VALUE
	MOVEM SP,SPSV#
	ANDCAM C,PA4

PG7A:	HLRZ A,(TT)
	MOVEI AR1,0
	PUSHJ P,BIND
	HRRZ TT,(TT)
	JUMPN TT,PG7A
	PUSH SP,SPSV

PG0:	SKIPA T,PA3
PG5A:	MOVE T,A
PG1:	JUMPE T,PG2
	HLRZ A,(T)
	HRRZ T,(T)
	HLLE B,(A)
	AOJE B,PG1
	MOVEM T,PA3
	PUSHJ P,EVAL
	SKIPL A,PA4
	JRST PG4	;RETURN
	SKIPL T,PA3
	JRST PG1
PG5:	JUMPE A,EG1
	HLRZ TT,(A)
	HRRZ A,(A)
	CAIN TT,(T)
	JRST PG5A	;FOUND TAG
	JRST PG5

PG2:	TDZA A,A
PG4:	HRRZS A
	MOVSI B,1
	TDNN B,PA4
	PUSHJ P,UNBIND
ERRP4:	POP P,PA4
	POP P,PA3
	POPJ P,


GO:	HLRZ A,(A)
	HRROM A,PA3
	HLLE B,(A)
	AOJE B,FALSE
	PUSHJ P,EVAL
	JRST GO+1


RETURN:	HLL A,PA4
	TLZ A,-2
	MOVEM A,PA4
	POPJ P,

SETQ:	HLRZ B,(A)
	PUSH P,B
	PUSHJ P,CADR
	PUSHJ P,EVAL
	MOVE B,A
	POP P,A
SET:	MOVE AR1,B
	PUSHJ P,BIND
	SUB SP,[XWD 1,1]
	MOVE A,AR1
	POPJ P,

CON2:	HRRZ A,(T)
COND:	JUMPE A,CPOPJ	;ENTRY
	PUSH P,A
	HLRZ A,(A)
	HLRZ A,(A)
	PUSHJ P,EVAL
	POP P,T
	JUMPE A,CON2
	HLRZ T,(T)
COND2:	HRRZ T,(T)
	JUMPE T,CPOPJ
	PUSH P,T
	HLRZ A,(T)
	PUSHJ P,EVAL
	POP P,T
	JRST COND2

		SUBTTL ARITHMETIC SUBROUTINES --- PAGE 11

;MACRO EXPANDER -- (FOO A B C) => (*FOO (*FOO A B) C)
EXPAND:	MOVE C,B
	HRRZ A,(A)
	PUSHJ P,REVERSE
	JRST EXPA1

EXPN1:	MOVE C,B
EXPA1:	HRRZ T,(A)
	HLRZ A,(A)
	JUMPE T,CPOPJ
	PUSH P,A
	MOVE A,T
	PUSHJ P,EXPA1
	EXCH A,(P)
	PUSHJ P,NCONS
	POP P,B
	PUSHJ P,XCONS
	MOVE B,C
	JRST XCONS

PAGE

ADD1:	CAILE A,INUMIN
	CAIL A,-2
	SKIPA B,[INUM0+1]
	AOJA A,CPOPJ
.PLUS:	JSP C,OP
	ADD A,TT
	FADR A,TT

SUB1:	CAILE A,INUMIN+1
	SOJA A,CPOPJ
	MOVEI B,INUM0+1
.DIF:	JSP C,OP
	SUB A,TT
	FSBR A,TT

.TIMES:	JSP C,OP
	IMUL A,TT
	FMPR A,TT

.QUO:	CAIN B,INUM0
	JRST ZERODIV
	JSP C,OP
	IDIV A,TT
	FDVR A,TT

.GREAT:	EXCH A,B
	JUMPE B,FALSE
.LESS:	JUMPE A,CPOPJ
	JSP C,OP
	JRST COMP2	;BIGNUMS KNOW ABOUT ME
	JRST COMP2

COMP2:	CAML A,TT
	JRST FALSE
	JRST TRUE
PAGE
MAKNUM:
FOO	CAIN B,FIXNUM
	JRST FIX1A
FLO1A:
FOO	MOVEI B,FLONUM
	PUSHJ P,FWCONS
	JRST ACONS-1

FIX1B:	SUBI A,INUM0
FOO	MOVEI B,FIXNUM
	PUSHJ P,FWCONS
	JRST ACONS-1

NUMVLX:	JFCL 17,.+1
NUMVAL:	CAIG A,INUMIN
	JRST NUMAG1
	SUBI A,INUM0
FOO	MOVEI B,FIXNUM
	POPJ P,

NUMAG1:	MOVEM A,AR1
	HRRZ A,(A)
	HLRZ B,(A)
	HRRZ A,(A)
FOO	CAIE B,FIXNUM
FOO	CAIN B,FLONUM
	SKIPA A,(A)
NUMV4:	SKIPA A,AR1
	POPJ P,
NUMV2:	PUSHJ P,EPRINT	;BIGNUMS KNOW ABOUT ME
	JRST E5

NUMV3:	JRST E5		;BIGNUMS CHANGE ME TO JRST BIGDIS
PAGE
FLOAT:	IDIVI A,400000
	SKIPE A
	TLC A,254000
	TLC B,233000
	FADR A,B
	POPJ P,

FIX:	PUSH P,A
	PUSHJ P,NUMVAL
FOO	CAIE B,FLONUM
	JRST POPAJ
	MULI A,400
	TSC A,A
	JFCL 17,.+1
	ASH B,-243(A)
FIX2:	JFCL 10,FIXOV	;BIGNUMS CHANGE ME TO JFCL 10,BFIX
	POP P,A
FIX1:	MOVE A,B
	JRST FIX1A

MINUSP:	PUSHJ P,NUMVAL
	JUMPGE A,FALSE
	JRST TRUE

MINUS:	PUSHJ P,NUMVLX
	MOVNS A
	JFCL 10,@OPOV
	JRST MAKNUM

ABS:	PUSHJ P,NUMVLX
	MOVMS A
	JRST MINUS+2
PAGE
DIVIDE:	CAIN B,INUM0
	JRST ZERODIV
	JSP C,OP
	JUMPN RDIV		;BIGNUMS KNOW ABOUT ME
	JRST ILLNUM
RDIV:	IDIV A,TT
	PUSH P,B
	PUSHJ P,FIX1A
	EXCH A,(P)
	PUSHJ P,FIX1A
	POP P,B
	JRST XCONS

REMAINDER:
	PUSHJ P,DIVIDE
	JRST CDR

FIXOV:	ERR1 [SIXBIT /INTEGER OVERFLOW!/]
ZERODIV:ERR1 [SIXBIT /ZERO DIVISOR!/]
FLOOV:	ERR1 [SIXBIT /FLOATING OVERFLOW!/]
ILLNUM:	ERR1 [SIXBIT /NON-INTEGRAL OPERAND!/]

GCD:	JSP C,OP
	JUMPA GCD2	;BIGNUMS KNOW ABOUT ME
	JRST ILLNUM
GCD2:	MOVMS A
	MOVMS TT
;EUCLID'S ALGORITHM
GCD3:	CAMG A,TT
	EXCH A,TT
	JUMPE TT,FIX1A
	IDIV A,TT
	MOVE A,B
	JRST GCD3
PAGE
;GENERAL ARITHMETIC OP CODE ROUTINE FOR MIXED TYPES

OP:	CAIG A,INUMIN
	JRST OPA1
	SUBI A,INUM0
	CAIG B,INUMIN
	JRST OPA2
	HRREI TT,-INUM0(B)
	XCT (C)	;INUM OP  (CANNOT CAUSE OVERFLOW)
FIX1A:	ADDI A,INUM0
	CAILE A,INUMIN
	CAIL A,-1
	JRST FIX1B
	POPJ P,

OPA1:	HRRZ A,(A)
	HLRZ T,(A)
	HRRZ A,(A)
FOO	CAIE T,FIXNUM
	JRST OPA6
	SKIPA A,(A)
OPA2:
FOO	MOVEI T,FIXNUM
	CAILE B,INUMIN
	JRST OPB2
	HRRZ B,(B)
	HRRZ TT,(B)
	HLRZ B,(B)
FOO	CAIE B,FIXNUM
	JRST OPA5
	SKIPA TT,(TT)
OPB2:	HRREI TT,-INUM0(B)
	MOVE AR1,A
	JFCL 17,.+1
	XCT (C)	;FIXED PT OP
OPOV:	JFCL 10,FIXOV	;BIGNUMS CHANGE THIS TO JFCL 10,FIXOVL
	JRST FIX1A

OPA6:	CAILE B,INUMIN
	JRST OPB7
	HRRZ B,(B)
	HRRZ TT,(B)
	HLRZ B,(B)
FOO	CAIE B,FLONUM
	JRST OPB3
FOO	CAIE T,FLONUM
	JRST NUMV3
	MOVE A,(A)
	MOVE TT,(TT)
OPR:	JFCL 17,.+1
	XCT 1(C)	;FLT PT OP
	JFCL 10,FLOOV
	JRST FLO1A

OPA5:
FOO	CAIE B,FLONUM
	JRST NUMV3
	PUSHJ P,FLOAT
	JRST OPR-1

OPB3:
FOO	CAIE B,FIXNUM
	JRST NUMV3
	SKIPA TT,(TT)
OPB7:	HRREI TT,-INUM0(B)
FOO	MOVEI B,FIXNUM
FOO	CAIE T,FLONUM
	JRST NUMV3
	MOVE A,(A)
	EXCH A,TT
	PUSHJ P,FLOAT
	EXCH A,TT
	JRST OPR

		SUBTTL EXPLODE, READLIST AND FRIENDS --- PAGE 12

FLATSIZE:	HLLZS FLAT1
	MOVEI R,FLAT2
	PUSHJ P,PRINTA
FLAT1:	MOVEI A,X			;*
	JRST FIX1A
FLAT2:	AOS FLAT1
	POPJ P,


%EXPLODE:	SKIPA R,.+1
EXPLODE:	HRRZI R,EXPL1
	MOVSI AR1,AR1
	PUSHJ P,PRINTA
	JRST SUBS4

EXPL1:	PUSH P,B
	PUSH P,C
	ANDI A,177
	CAIL A,"0"
	CAILE A,"9"
	JRST EXPL2
	ADDI A,INUM0-"0"
	JRST EXPL4

EXPL2:	PUSH P,AR1
	PUSH P,TT
	PUSH P,T
	LSH A,35
	MOVE C,SP
	PUSH C,A
	MOVEI AR1,1
	PUSHJ P,INTER0
	POP P,T
	POP P,TT
	POP P,AR1
EXPL4:	PUSHJ P,NCONS
	HLR B,AR1
	HRRM A,(B)
	HRLM A,AR1
	POP P,C
	JRST POPBJ
PAGE
READLIST:	TDZA T,T
MAKNAM:	MOVNI T,1
	MOVEM T,NOINFG
	PUSH P,OLDCH
	SETZM OLDCH
	JUMPE A,E7
	HRRM A,MKNAM3
	MOVEI A,MKNAM2
	PUSHJ P,READ0
	HRRZ T,MKNAM3
	CAIE T,-1
	JUMPN T,[ERR1 [SIXBIT /MORE THAN ONE S-EXPRESSION-MKNAM!/]]
	POP P,OLDCH
	POPJ P,

MKNAM2:	PUSH P,B
	PUSH P,T
	PUSH P,TT
MKNAM3:	MOVEI TT,X
	JUMPE TT,MKNAM6
	CAIN TT,-1
	ERR1 [SIXBIT /READ UNHAPPY-MAKNAM!/]
	HRRZ B,(TT)
	HRRM B,MKNAM3
	HLRZ A,(TT)
	CAIGE A,INUMIN
	JRST MKNAM5
	SUBI A,INUM0-"0"
MKNAM4:	POP P,TT
	POP P,T
	JRST POPBJ

MKNAM5:	HLRZ A,(TT)
FOO	MOVEI B,PNAME
	PUSHJ P,GET
	HLRZ A,(A)
	LDB A,[POINT 7,(A),6]
	JRST MKNAM4

MKNAM6:	MOVEI A," "
	HLLOS MKNAM3
	JRST MKNAM4

		SUBTTL EVAL APPLY  -- THE INTERPRETER  --- PAGE 13
EV3:	HLRZ A,(AR1)
FOO	MOVEI B,VALUE
	PUSHJ P,GET
	JUMPE A,QA2A	;FUNCTION OBJECT HAS NO DEFINITION
	HRRZ A,(A)
UBDPTR:
FOO	CAIN A,UNBOUND
	JRST QA2A
	HRRZ B,(AR1)	;EVAL (CONS (CDR A)(CDR AR1))
	PUSHJ P,CONS
	JRST EVAL

OEVAL:	AOJN T,AEVAL
	POP P,A
EVAL:	HRRZM A,AR1
	CAILE A,INUMIN
	JRST CPOPJ
	HLRZ T,(A)
	CAIN T,-1
	JRST EE1		;X IS ATOMIC
	CAILE T,INUMIN
	JRST QA2A
	HLRO TT,(T)
	AOJE TT,EE2		;CAR (X) IS ATOMIC
	JRST EXP3

EE1:
EV5:	HRRZ AR1,(AR1)
	JUMPE AR1,QA8
	HLRZ TT,(AR1)
FOO	CAIE TT,FLONUM
FOO	CAIN TT,FIXNUM
	POPJ P,
EVBIG:	HRRZ AR1,(AR1)		;BIGNUMS KNOW ABOUT ME
FOO	CAIE TT,VALUE
	JRST EV5
	HLRZ AR1,(AR1)
	HRRZ AR1,(AR1)
FOO	CAIN AR1,UNBOUND
	JRST QA8
	MOVEM AR1,A
	POPJ P,
PAGE
ALIST:	SKIPE  A,-1(P)
	PUSHJ P,NUMBERP
	MOVEM SP,SPSV
	JUMPN A,AEVAL7	;NUMBER
	MOVE C,SC2	;BOTTOM OF SPEC PDL
	MOVEM C,AEVAL5#
	SETOM AEVAL2
AEVAL8:	MOVE C,SP
AEVAL6:	CAMN C,AEVAL5	;BOTTOM SPEC PDL
	JRST AEVAL1	;DONE
	POP C,T		;POINTER FOR NEXT BLOCK
AEVAL4:	CAMN C,T
	JRST AEVAL6	;THRU WITH BLOCK
	POP C,AR1
	MOVSS AR1
	PUSH SP,(AR1)	;SAVE VALUE CELL
	HLRZM AR1,(AR1)	;STORE PREVIOUS VALUE IN VALUE CELL
	HRLM AR1,(SP)	;SAVE POINTER TO SPEC PDL LOC
	JRST AEVAL4

FNGUBD:	EXCH A,(P)	;SPEC PDL POINTER
	PUSHJ P,NUMVAL
	MOVE D,A
	POP SP,TT	;END OF BLOCK TO REBIND
FNGUB2:	CAMN SP,TT
	JRST POPAJ	;DONE
	POP SP,T
	MOVSS T		;POINTER TO VALUE CELL
	HRLM T,(T)
	SKIPGE 1(D)
	AOBJN D,.-1	;SKIP OVER SPEC PDL POINTERS
	PUSH D,(T)	;PUT VALUE CELL IN SPEC PDL
	HLRZM T,(T)	;RESTORE VALUE CELL
	JRST FNGUB2

AEVAL:	PUSHJ P,ALIST
	POP P,A
	EXCH A,(P)
	PUSH P,[FNGUBD]
	JRST EVAL
PAGE
AEVAL1:	SKIPGE AEVAL2
	SKIPN B,-1(P)
	JRST ABIND3	;DONE WITH BINDING

			;ALIST BINDING
	MOVE A,B
	PUSHJ P,REVERSE
ABIND2:	MOVE A,B
	HRRZ B,(A)
	HLRZ A,(A)
	HRRZ AR1,(A)
	HLRZ A,(A)
	PUSHJ P,BIND
	JUMPN B,ABIND2
ABIND3:	PUSH SP,SPSV
	POPJ P,

;SPEC PDL BINDING
AEVAL7:	MOVE A,-1(P)
	PUSHJ P,NUMVAL
	CLEARM AEVAL2
	MOVEM A,AEVAL5	;POINT TO UNBIND TO
	JRST AEVAL8

AEVAL2:	0	;0 FOR NUMBER, -1 FOR A-LIST		*
PAGE

EE2:	HRRZ T,(T)
	JUMPE T,EV3
	HLRZ TT,(T)
	HRRZ T,(T)
FOO	CAIN TT,SUBR
	JRST ESB
FOO	CAIN TT,LSUBR
	JRST EELS
FOO	CAIN TT,EXPR
	JRST AEXP
FOO	CAIN TT,FSUBR
	JRST EFS
FOO	CAIN TT,MACRO
	JRST EFM
FOO	CAIE TT,FEXPR
	JRST EE2

	HLRZ T,(T)
	HLL T,(AR1)
	PUSH P,T
	HRRZ A,(A)
	TLO A,400000
	PUSH P,A
	MOVNI T,1
	JRST IAPPLY

AEXP:	HLRZ T,(T)
	HLL T,(AR1)
EXP3:	PUSH P,T
	HRRZ A,(AR1)
CILIST:	JSP TT,ILIST
EXP2:	JRST IAPPLY

EFS:	HLRZ T,(T)
	HRRZ A,(AR1)
	JRST (T)
PAGE
ESB:	HRRZ A,(AR1)
UUOS2:	HLRZ T,(T)
	HLL T,(AR1)
	PUSH P,T
	JSP TT,ILIST
ESB1:	JRST .+NACS+1(T)
	POP P,A+4
	POP P,A+3
	POP P,A+2
	POP P,A+1
POPAJ:	POP P,A
	POPJ P,

EFM:	HLRZ T,(T)
	CALLF 1,(T)
	JRST EVAL
PAGE

APPLY:	MOVEI TT,AP2
	CAME T,[-3]
	JRST PDLARG
	MOVEM T,APFNG1#
	PUSHJ P,ALIST
	MOVE T,APFNG1
	JSP TT,PDLARG
	PUSH P,C	;SPEC PDL POINTER
	PUSH P,[FNGUBD]
AP2:	PUSH P,A
	MOVEI T,0
AP3:	JUMPE B,IAPPLY	;ALL ARGS PUSHED; B HAS ARG LIST
	HLRZ C,(B)
	PUSH P,C	;PUSH ARG
	HRRZ B,(B)
	SOJA T,AP3

IAP4:	JUMPGE D,QF3	;SPECIAL CASE FOR FEXPRS
	AOJN R,QF3
	PUSH P,B
	MOVE A,SP
	PUSHJ P,FIX1A
	EXCH A,(P)
	MOVE B,A
	MOVNI R,2
	SOJA T,IAP5

FUNCT:	PUSH P,A
	MOVE A,SP
	PUSHJ P,FIX1A
	POP P,B
	HLRZ B,(B)
	PUSHJ P,XCONS
FOO	MOVEI B,FUNARG
	JRST XCONS
PAGE
APFNG:	SOS T
	MOVEM T,APFNG1
	JSP TT,PDLARG	;GET ARGS AND FUNARG LIST
	HRRZ A,(A)
	HRRZ D,(A)	;A-LIST POINTER
	HLRZ A,(A)	;FUNCTION
	HRLZ R,APFNG1	;NO. OF ARGS
	PUSH P,D
	PUSH P,[FNGUBD]
	JSP TT,ARGP1	;REPLACE ARGS AND FN NAME
	PUSH P,D	;A-LIST POINTER
	PUSHJ P,ALIST	;SET UP SPEC PDL
	POP P,D
	AOS T,APFNG1

;FALLS THROUGH
PAGE
;FALLS IN

IAPPLY:	MOVE C,T	;STATE OF WORLD AT ENTRANCE
	ADDI C,(P)	;T HAS - NUMBER OF ARGS ON PDL
ILP1A:	HRRZ B,(C)	;NEXT PDL SLOT HAS FUNCTION- POSS FUN NAME IN LH
	CAILE B,INUMIN
	JRST QA1
	HLRZ A,(B)
	CAIN A,-1
	JRST IAP1	;FN IS ATOMIC
FOO	CAIN A,LAMBDA
	JRST IAPLMB
FOO	CAIN A,FUNARG
	JRST APFNG
FOO	CAIN A,LABEL
	JRST APLBL
	PUSH P,T
	MOVE A,B
	PUSHJ P,EVAL
	POP P,T
	MOVE C,T
	ADDI C,(P)
ILP1B:	MOVEM A,(C)
	JRST ILP1A

IAPXPR:	HLRZ A,(B)
	JRST ILP1B
IAP1:	HRRZ B,(B)
	JUMPE B,IAP2
	HLRZ TT,(B)
	HRRZ B,(B)
FOO	CAIN TT,EXPR
	JRST IAPXPR
FOO	CAIN TT,LSUBR
	JRST IAP6
FOO	CAIE TT,SUBR
	JRST IAP1
	HLRZ B,(B)
	MOVEM B,(C)
	JRST ESB1
PAGE
IAPLMB:	HRRZ B,(B)
	HLRZ TT,(B)
	MOVEM SP,SPSV
	HRRZ B,(B)
	HLRZ D,(TT)
	CAIN D,-1
	JUMPN TT, IAP3
	MOVE R,T
IPLMB1:	JUMPE T,IPLMB2	;NO MORE ARGS
	JUMPE TT,QF2	;TOO MANY ARGS SUPPLIED
IAP5:	HLRZ A,(TT)
	MOVEI AR1,1(T)
	ADD AR1,P
	HLLZ D,(AR1)
	HRLM A,(AR1)
	HRRZ TT,(TT)
	AOJA T,IPLMB1
PAGE


IPLMB2:	JUMPN TT,IAP4	;TOO FEW ARGS SUPPLIED
	JUMPE R,IAP69
IPLMB4:	POP P,AR1
	HLRZ A,AR1
	AOJG R,IPLMB3
	PUSHJ P,BIND
	JRST IPLMB4
IPLMB3:	SKIPE BACTRF
	JRST APBK1
APBK2:	HLRZ A,(B)
	PUSH SP,SPSV
	PUSHJ P,EVAL
	JRST UNBIND

IAP69:	POP P,(P)
	HLRZ A,(B)
	JRST EVAL

APBK1:	HRRI AR1,CPOPJ 
	TLNE AR1,-1
	PUSH P,AR1
	JRST APBK2
IAP6:	MOVEI TT,CPOPJ
	MOVEM TT,(C)
	HLRZ B,(B)
	JRST (B)

APLBL:	MOVEM SP,SPSV
	HRRZ B,(B)
	HLRZ A,(B)
	HRRZ B,(B)
	HLRZ AR1,(B)
	MOVEM AR1,(C)
	PUSHJ P,BIND
	MOVEI A,APLBL1
	EXCH A,-1(C)
	EXCH A,LBLAD#
	HRLI A,LBLAD
	PUSH SP,A
	PUSH SP,SPSV
	JRST IAPPLY
APLBL1:	PUSH P,LBLAD
	JRST SPECSTR

IAP2:	HRRZ A,(C)
FOO	MOVEI B,VALUE
	PUSHJ P,GET
	JUMPE A,QA1
	HRRZ A,(A)
FOO	CAIN A,UNBOUND
	JRST QA1
	JRST ILP1B

IAP3:	MOVNI AR1,-INUM0(T)	;LEXPR CALL
	MOVE A,TT
	PUSHJ P,BIND
	PUSH P,ARG
	SUBI C,INUM0
	HRRM C,ARG
	PUSH SP,SPSV
	HLRZ A,(B)
	PUSHJ P,EVAL
	HRRZ T,ARG
	POP P,ARG
	SUBI T,1-INUM0(P)
	HRLI T,-1(T)
	ADD P,T
CUNBIN:	JRST UNBIND

ARG:	HRRZ A,X(A)				;*
	POPJ P,

SETARG:	HRRZM B,@ARG
	JRST PROG2
PAGE
BIND:	PUSH P,B
	HRRZM A,BIND3#
BIND2:
FOO	MOVEI B,VALUE	;BIND ATOM IN A TO VALUE IN AR1,SAVE
	PUSHJ P,GET	;OLD BINDING ON S PDL
	JUMPE A,BIND1	;ADD VALUE CELL
	PUSH SP,(A)
	HRLM A,(SP)
	HRRZM AR1,(A)
POPBJ:	POP P,B
	POPJ P,

BIND1:
FOO	MOVEI B,UNBOUND
	MOVEI A,0
	PUSHJ P,CONS
	HRRZ B,@BIND3
	PUSHJ P,CONS
FOO	MOVEI B,VALUE
	PUSHJ P,XCONS
	HRRM A,@BIND3
	MOVE A,BIND3
	JRST BIND2

UBD:	CAMN SP,B
	POPJ P,
	PUSHJ P,UNBIND
	JRST UBD

UNBIND:
SPECSTR:	MOVE TT,(SP)
	SUB SP,[XWD 1,1]
	JUMPGE TT,.-2	;SYNCRONIZE STACK
UNBND1:	CAMN SP,TT
	POPJ P,
	POP SP,T
	MOVSS T
	HLRZM T,(T)
	JRST UNBND1

SPECBIND:	MOVE TT,SP
SPEC1:	LDB R,[POINT 13,(T),ACFLD]
	CAILE R,17
	JRST SPECX
	SKIPE R
	MOVE R,(R)
	EXCH R,@(T)
	HRL R,(T)
	PUSH SP,R
	AOJA T,SPEC1
SPECX:	PUSH SP,TT
	JRST (T)

;RANDOM SPECIAL CASE COMPILER RUN TIME ROUTINES

%AMAKE:	PUSH P,A	;MAKE ALIST FOR FSUBR THAT REQUIRES IT
	MOVE A,SP
	PUSHJ P,FIX1A
	MOVE B,A
	JRST POPAJ

%UDT:	PUSHJ P,PRINT	;ERROR PRINT FOR UNDEFINED COMPUTED GO TAG
	STRTIP [SIXBIT /UNDEFINED COMPUTED GO TAG IN !/]
	HRRZ R,(P)
	PUSHJ P,ERSUB3
	JRST ERREND

%LCALL:	MOVN A,T	;SET UP ROUTINE FOR COMPILE LSUBR
	ADDI A,INUM0
	ADDI T,(P)
	PUSH P,T
	PUSHJ P,(3)
	POP P,T
	SUBI T,(P)
	HRLI T,-1(T)
	ADD P,T
	POPJ P,

		SUBTTL ARRAY SUBROUTINES  --- PAGE 14

ARRERR=-1

ARRAY:	PUSHJ P,ARRAYS
	HRRI AR2A,1(R)
	MOVE A,AR2A
	PUSH R,[0]
	AOBJN A,.-1
ARREND:	MOVE A,BPPNR#
	MOVEM AR2A,-1(A)
	MOVEI A,INUM0+1(R)
FOO	MOVEM A,VBPORG
	POPJ P,

ARRAYS:	PUSH P,A
FOO	MOVE A,VBPORG
	SUBI A,INUM0
	MOVEM A,BPPNR
FOO	MOVE A,VBPEND
	MOVNI A,-INUM0-2(A)
	ADD A,BPPNR	;BPORG-BPEND+2
	HRLM A,BPPNR
	POP P,A
	HRRZ AR1,(A)	;(CDR L)
	HLRZ A,(A)	;(CAR L)NAME
	HRRZ B,BPPNR
	ADDI B,2
FOO	MOVEI C,SUBR
	PUSHJ P,PUTPROP
	HLRZ A,(AR1)	;(CADR L)MODE
	PUSH P,AR1
	PUSHJ P,EVAL	;EVAL MODE
	POP P,AR1
	MOVEM A,AMODE#
	MOVEI C,44
	JUMPE A,ARRY1
	MOVEI C,-INUM0(A)
	CAILE A,INUMIN
	JRST ARRY1
	MOVEI C,22
	HRRZ A,BPPNR
	MOVE B,GCMKL
	PUSHJ P,CONS
	MOVEM A,GCMKL
ARRY1:	MOVEM C,BSIZE#
	MOVEI A,44
	IDIV A,C
	MOVEM A,NBYTES#
	HRRZ A,(AR1)	;(CDDR L)BOUND PAIR LIST
	JSP TT,ILIST
	AOS R,BPPNR
	MOVEI AR1,1	;AR1 IS ARRAY SIZE
	MOVEI AR2A,0	;AR2A IS CUMULATIVE RESIDUE
	AOJGE T,ARRYS	;SINGLE DIMENSION
	MOVEI D,A-1
	SUB D,T	;D IS NEXT AC FOR ARRAY CODE GENERATION
ARRY2:	PUSHJ P,ARRB0
	TLC TT,(IMULI)
	DPB D,[POINT 4,TT,ACFLD]
	PUSH R,TT
	CAIN D,A
	JRST ARRY3
	MOVSI TT,(ADD)
	ADDI TT,1(D)
	DPB D,[POINT 4,TT,ACFLD]
	PUSH R,TT
	SOJA D,ARRY2

ARRB0:	POP P,TT
	EXCH TT,(P)
	CAILE TT,INUMIN
	JRST ARRB1
	HLRZ A,(TT)
	HRRZ TT,(TT)
	SUBI TT,(A)
	ADDI TT,1
	JRST ARRB2

ARRB1:	MOVEI A,INUM0
	SUB TT,A
ARRB2:	IMUL A,AR1
	IMULB AR1,TT
	ADDM A,AR2A
	POPJ P,

ARRY3:	PUSH R,[ADD A,B]
ARRYS:	PUSHJ P,ARRB0
	HRRZ TT,BPPNR
	MOVEM AR2A,(TT)
	HRLI TT,(SUB A,)
	PUSH R,TT
	PUSH R,[JUMPL A,ARRERR]
	MOVE TT,AR1
	HRLI TT,(CAIL A,)
	PUSH R,TT
	PUSH R,[JRST ARRERR]
	IDIV AR1,NBYTES	;CALC #WORDS IN ARRAY
	SKIPE AR2A	;CORRECT FOR REMAINDER NON-ZERO
	ADDI AR1,1
	MOVE TT,NBYTES
	SOJE TT,ARRY6
	ADDI TT,1
	HRLI TT,(IDIVI A,)
	PUSH R,TT
	MOVN TT,BSIZE
	LSH TT,14
	HRLI TT,(IMULI B,)
	PUSH R,TT
	MOVEI TT,44+200
	SUB TT,BSIZE
	LSH TT,6
ARRY6:	ADD TT,BSIZE
	LSH TT,6
	SKIPE AR2A,AMODE
	CAIL AR2A,INUMIN
	ADDI TT,40	;MODE NOT = T
	TLC TT,(HRLZI C,)
	PUSH R,TT
	MOVEI TT,4(R)
	HRLI TT,(ADDI C,(A))
	PUSH R,TT
	PUSH R,[LDB A,C]
	HRLZI AR2A,(POPJ P,)
	SKIPN TT,AMODE
	MOVE AR2A,[JRST FLO1A]
	CAIL TT,INUMIN
	MOVE AR2A,[JRST FIX1A]
	PUSH R,AR2A
	MOVS AR2A,AR1
	MOVNS AR2A
	POPJ P,

PAGE
EXARRAY:	PUSH P,A
	HLRZ A,(A)
	PUSHJ P,GETSYM
	JUMPE A,POPAJ
	PUSHJ P,NUMVAL
	EXCH A,(P)
	PUSHJ P,ARRAYS
	POP P,A
	HRRM A,-2(R)
	HRR AR2A,A
	JRST ARREND

STORE:	PUSH P,A
	PUSHJ P,CADR
	PUSHJ P,EVAL	;VALUE TO STORE
	EXCH A,(P)
	HLRZ A,(A)
	PUSHJ P,EVAL	;BYTE POINTER RETURNED IN C
	POP P,A
NSTR:	PUSH P,A
	TLNE C,40
	PUSHJ P,NUMVAL	;NUMERICAL ARRAY
	DPB A,C
	POP P,A
	POPJ P,

		SUBTTL EXAMINE, DEPOSIT , ETC --- PAGE 15

BOOLE:	MOVE TT,T
	ADDI TT,2(P)
	MOVE A,-1(TT)
	SUBI A,INUM0
	DPB A,[POINT 4,BOOLI,OPFLD-2]
	PUSHJ P,BOOLG
	MOVE C,A
BOOLL:	PUSHJ P,BOOLG
BOOLI:	CLEARB C,A
	JRST BOOLL

BOOLG:	CAIL TT,(P)
	JRST BOOL1
	MOVE A,(TT)
	PUSHJ P,NUMVAL
	AOJA TT,CPOPJ

BOOL1:	HRLI T,-1(T)
	ADD P,T
	POP P,B
	JRST FIX1A

EXAMINE:	MOVE A,-INUM0(A)
	JRST FIX1A

DEPOSIT:	MOVEI C,-INUM0(A)
	MOVE A,B
	PUSHJ P,NUMVAL
	MOVEM A,(C)
	JRST MAKNUM

LSH:	MOVEI C,-INUM0(B)
	PUSHJ P,NUMVAL
	LSH A,(C)
	JRST FIX1A

		SUBTTL GARBAGE COLLECTER   --- PAGE 16

;GARBAGE COLLECTOR

GC:	PUSHJ P,AGC
	JRST FALSE

AGC:	MOVEM R,RGC#
GCPK1:	PUSH P,PA3
	PUSH P,PA4
	PUSH P,[CNIL2]
	PUSH P,UBDPTR
	PUSH P,MKNAM3
	PUSH P,GCMKL	;I/O CHANNEL INPUT LISTS AND ARRAYS
	PUSH P,BIND3
GCPK2:	PUSH P,[XWD 0,GCP6]
GCP4:	MOVEI S,X	;PDLAC, .=BOTTOM OF REG PDL + 1
GCP41:	BLT S,X	;PDLAC+N
GCP2:	CLEARB 0,X	;GC INDICATOR, INIT. FOR BIT TABLE ZERO
	MOVE A,C3GC
GCP5:	BLT A,X	;ZERO BIT TABLES, .=TOP OF BIT TABLES
	SKIPN GCGAGV
	JRST GCP5A
	SKIPN F
	STRTIP [SIXBIT /_FREE STG EXHAUSTED_!/]
	SKIPN FF
	STRTIP [SIXBIT /_FULL WORD SPACE EXHAUSTED_!/]

GCP5A:	MOVEI TT,1
	MOVEI A,0
	CALLI A,STIME	;TIME
	MOVNS A
	ADDM A,GCTIM#
GCP3:	MOVEI C,X	;.=BOTTOM OF REG PDL
GCP6B:	MOVE S,P
	HLL C,P
	MOVEI B,0
GC1:	CAMN C,S
	POPJ P,
	HRRZ A,(C)

GCP:	CAIGE A,X	;.=BOTTOM OF BIT TABLES
GCPP1:
FOO	CAIGE A,FS
	JRST GCEND
GCP1:	CAIL A,X	;.=BOTTOM OF FULL WORD SPACE (FWS)
	JRST GCMFWS
	MOVE F,(A)
	LSHC A,-5
	ROT B,5
	MOVE AR1,GCBT(B)
GCBTP2:	TDOE AR1,X(A)	;BIT TAB- (FS_-5), .=MAGIC NUMBER FOR SYNC
	JRST GCEND
GCBTP1:	MOVEM AR1,X(A)	;BIT TAB- (FS_-5)
	PUSH P,F
	HLRZ A,F
	JRST GCP

GCMFWS:	MOVEI AR1,X(A)	;.=- BOTTOM OF FWS
	IDIVI AR1,44
	MOVNS AR2A
	LSH AR2A,36
	ADD AR2A,C2GC
	DPB TT,AR2A
GCEND:	CAMN P,S
	AOJA C,GC1
	POP P,A
	HRRZS A
	JRST GCP

GCMKL:	XWD 0,[XWD [XWD -NCH,CHTAB+FSTCH],0]
C2GC:	XWD 430100+AR1,X	;.=BOTTOM OF FWS BIT TABLE
C3GC:	0	;(BOTTOM BIT TABLE)BOTTOM BIT TABLE+1
GCBT:	XWD 400000,0
ZZ==1B1
XLIST
REPEAT ^D31,<ZZ
ZZ==ZZ/2>
LIST
GCP6:	HRRZ R,SC2
GCP6C:	CAIL R,(SP)	;MARK SP
	JRST GCP6A
	PUSH P,(R)
	HRRZ C,P
	PUSHJ P,GCP6B
	SUB P,[XWD 1,1]
	AOJA R,GCP6C

GCP6A:	HRRZ R,GCMKL	;MARK ARRAYS
GCP6D:	JUMPE R,GCSWP
	HLRZ A,(R)
	MOVE D,(A)
GCP6E:	PUSH P,(D)
	HRRZ C,P
	PUSH P,(D)
	MOVSS (P)
	PUSHJ P,GCP6B
	SUB P,[XWD 2,2]
	AOBJN D,GCP6E
	HRRZ R,(R)
	JRST GCP6D

GFSWPP:
PHASE 0
GFSP1==.
	JUMPL S,.+3
	HRRZM F,(R)
	HRRZ F,R
	ROT S,1
	AOBJN R,.-4
	MOVE S,(D)
	HRLI R,-40
	AOBJN D,GFSP1

LPROG==.
	JRST GFSPR

DEPHASE
;GARBAGE COLLECTOR SWEEP

GCSWP:	MOVSI R,GFSWPP
	BLT R,LPROG
	MOVEI F,0
	MOVE D,C3GCS
FOO	MOVEI R,FS
GCBTL1:	HRLI R,X	;-(32-<FS&37>
	MOVE S,(D)
GCBTL2:	ROT S,X	;FS&37
	AOBJN D,GFSP1
GFSPR:	MOVE A,C1GCS
	MOVE B,C2GCS
	PUSHJ P,GCS0
	SKIPN GCGAGV
	JRST GCSP1
	MOVE B,F
	PUSHJ P,GCPNT
	STRTIP [SIXBIT / FREE STG,!/]
	MOVE B,FF
	PUSHJ P,GCPNT
	STRTIP [SIXBIT / FULL WORDS AVAILABLE_!/]
GCSP1:	HRLZI S,X	;BOTTOM OF REG PDL+1
	BLT S,NACS+3	;RELOAD AC'S
	SUB P,[XWD GCPK2-GCPK1,GCPK2-GCPK1]	;RESTORE P
	JUMPE F,[ERR2 [SIXBIT /NO FREE STG LEFT!/]]
	JUMPE FF,[ERR2 [SIXBIT /NO FW STG LEFT!/]]
	MOVE R,RGC
	MOVEI A,0
	CALLI A,STIME	;TIME
	ADDM A,GCTIM
	POPJ P,

GCS0:	MOVEI FF,0
GCS1:	ILDB C,B
	JUMPN C,GCS2
	HRRZM FF,(A)
	HRRZ FF,A
GCS2:	AOBJN A,GCS1
	POPJ P,

C1GCS:	0	;(- LENGTH OF FWS) BOTTOM OF FWS
C2GCS:	XWD 100,X	;.=BOTTOM OF FWS BIT TABLE
C3GCS:	0	;-N WDS IN BT,,BT
GCGAG:	EXCH A,GCGAGV#
	POPJ P,

GCTIME:	MOVE A,GCTIM
	JRST FIX1A

TIME:	MOVEI A,0
	CALLI A,STIME
	JRST FIX1A

SPEAK:	MOVE A,CONSVAL#
	JRST FIX1A

GCPNT:	MOVEI R,TTYO
	MOVEI A,0
	JUMPE B,PRINL1
	HRRZ B,(B)
	AOJA A,.-2

		SUBTTL GETSYM     --- PAGE 17

R50MAK:	PUSHJ P,PNAMUK
	PUSH C,[0]
	HRLI C,700
	HRRI C,(SP)
	MOVEI B,0
MK3:	ILDB A,C
	LDB A,R50FLD
	CAMGE B,[50*50*50*50*50]
	SKIPN A
	POPJ P,
	IMULI B,50
	ADD B,A
	JRST MK3

GETSYM:	PUSHJ P,R50MAK
	TLO B,040000	;04 FOR GLOBALS
	MOVE C,JOBSYM
MK7:	CAMN B,(C)
	JRST MK10	;FOUND
	AOBJP C,.+2
	AOBJN C,MK7
	TLC B,140000	;10 FOR LOCALS
	TLNE B,100000
	JRST MK7-1
	JRST FALSE

MK10:	MOVE A,1(C)	;VALUE
	JRST FIX1A

PUTSYM:	PUSH P,B
	PUSHJ P,R50MAK
	MOVE A,B
	TLO A,040000	;MAKE GLOBAL
	SKIPL JOBSYM
	AOS JOBSYM	;INCREMENT INITIAL SYMBOL TABLE POINTER
	MOVN B,[XWD 2,2]
	ADDB B,JOBSYM
	MOVEM A,(B)	;NAME
	POP P,1(B)	;VALUE
	JRST FALSE

		SUBTTL ALVINE AND LOADER INTERFACES   --- PAGE 18

;INTERFACE TO ALVINE

ED:	MOVEI 10,X
	JRST (10)
	PUSH P,A
	HRRZ A,CORUSE
	HRRM A,LST
	AOS A
	HRRM A,ED
	MOVSI A,(SIXBIT /ED/)
	PUSHJ P,SYSINI
	HRLM A,LST	
	MOVNS A
	PUSHJ P,MORCOR
	PUSHJ P,SYSINP+1
	POP P,A
	JRST ED

GRINDEF:	PUSH P,A
	PUSHJ P,ED
	POP P,A
	JRST 2(10)

EXCISE:	MOVEI A,ED+2
	HRRM A,ED
	MOVE A,JRELO
	SETZM LDFLG#	;INITIAL LOADER SYMBOL TABLE FLAG
	CALLI A,CORE
	JRST .+1
	JSR IOBRST
	JRST TRUE

VAR
LIT
PAGE;	LISP LOADER INTERFACE

LOAD:	AOS B,CORUSE
	MOVEM B,OLDCU#
	MOVEM A,LDPAR#
	JUMPE A,LOAD2
FOO	MOVE B,VBPORG
	SUBI B,INUM0
LOAD2:	MOVEM B,RVAL#	;FINAL DESTINATION OF LOADED CODE
	MOVSI A,(SIXBIT /LOD/)
	PUSHJ P,SYSINI
	SUBI A,150	;EXTRA ROOM FOR LOCATIONS 0 TO 137 AND SLOP
	PUSH P,A
	MOVNS A		;LENGTH(LOADER)
	HRRZM A,LODSIZ#
	PUSHJ P,MORCOR	;EXPAND CORE FOR LOADER
	MOVEM A,LOWLSP#	;LOCATION OF BLT'ED LOW LISP
	MOVN B,(P)	;LENGTH(LOADER)
	ADD B,A
	MOVEM B,HVAL#	;TEMPORARY DESTINATION OF LOADED CODE
	HRLI A,0
	BLT A,(B)	;BLT UP LOW LISP
	HLL A,NAME+3	;-LENGTH(LOADER)
	HRRI A,137-1
	PUSHJ P,SYSINP
	SKIPE LDFLG
	JRST LOAD3
	SETOM LDFLG
	MOVSI A,(SIXBIT /SYM/)
	PUSHJ P,SYSINI
	MOVNS A		;LENGTH SYMBOLS
	PUSHJ P,MORCOR	;EXPAND CORE FOR SYMBOLS
	SKIPGE B,JOBSYM
	SOS B		;IF NO SYMBOL TABLE, USE ORIGINAL JOBSYM
	HLRZ A,NAME+3	;-LENGTH(SYMBOLS)
	ADDB A,B
	HLL A,NAME+3	;SYMBOL TABLE IOWD
	PUSHJ P,SYSINP
	HRRM B,JOBSYM
	HLLZ A,NAME+3
	ADDM A,JOBSYM
	SKIPA
LOAD3:	SOS JOBSYM	;WANT JOBSYM TO POINT ONE BELOW 1ST SYMBOL
	MOVE 3,HVAL	;H
	MOVE 5,RVAL	;R
	MOVE 2,3
	SUB 2,5		;X=H-R
	HRLI 5,12	;(W)
	HRLI 2,11	;(V)
	SETZB 1,4
	JSP 0,140	;CALL THE LOADER
	MOVEM 5,RLAST#	;LAST LOCATION LOADED(IN FINAL AREA)
	MOVE T,OLDCU
	MOVE A,JOBSYM
	MOVEM A,JOBSYM(T)
	MOVE A,JOBREL
	MOVEM A,JOBREL(T)	;UPDATE JOBREL
	HRLZ 0,LOWLSP
	SOS LODSIZ
	AOBJN 0,.+1
	BLT 0,@LODSIZ	;BLT DOWN LOW LISP
	MOVE 0,@LOWLSP
	MOVE B,RLAST
	MOVE A,RVAL
	HRL A,HVAL
	SKIPE LDPAR
	JRST BINLD
	MOVE C,RLAST	;NEW CORUSE
LDRET2:	BLT A,(B)	;BLT DOWN LOADED CODE
	HRRZM C,CORUSE	;TOP OF CODE LOADED
	MOVEI B,1
	ANDCAM B,JOBSYM
	SUB C,JOBSYM	;LENGTH OF FREE CORE
	ORCMI C,776000
	AOJGE C,LISPGO	;NO CONTRACTION
	ADD C,JOBREL	;NEW TOP OF CORE
	MOVE B,C
	PUSHJ P,MOVDWN
	HRLM C,JOBSA
	CALLI C,CORE	;CONTRACT CORE
	JRST .+1
	JRST LISPGO

BINLD:	MOVEI C,INUM0(B)
FOO	CAML C,VBPEND
	JRST [	SETOM BPSFLG	;BPS EXCEEDED
		JRST LISPGO]
FOO	MOVEM C,VBPORG	;UPDAT BPORG
	SOS C,OLDCU	;OLD TOP OF CORE
	JRST LDRET2

SYSINI:	MOVEM A,NAME+1
	SETZM NAME+3
	INIT 17
	SIXBIT /SYS/
	0
	JRST AIN.4+1
	LOOKUP NAME
	JRST AIN.7+1
	INPUT [IOWD 1,NAME+3	;INPUT SIZE OF FILE
		0]
	HLRO A,NAME+3
	POPJ P,

NAME:	SIXBIT /LISP/
	0
	0
	0

SYSINP:	MOVEM A,LST
	INPUT LST
	STATZ 740000
	ERR1 AIN.8
	RELEASE
	POPJ P,

LST:	0
	0
PAGE
MOVDWN:	HLRZ A,JOBSYM
	JUMPE A,MOVS1
	ADDI A,1(B)
	HRL A,JOBSYM
	HRRM A,JOBSYM
	BLT A,(B)	;DOWNWARD BLT
	POPJ P,

MOVSYM:	MOVE B,JOBREL
	HRLM B,JOBSA
	HLRE A,JOBSYM
	JUMPE A,MOVS1
	ADDI B,1(A)	;NEW BOTTOM OF SYMBOL TABLE
	MOVNI A,1(A)
	ADD A,JOBSYM	;LAST LOC OF OLD SYMBOL TABLE
	HRRM B,JOBSYM
	PUSH P,C
	MOVE B,JOBREL	;LAST LOC OF NEW SYMBOL TABLE
	MOVE C,(A)	;SIMULATED UPWARD BLT
	MOVEM C,(B)
	SUBI B,1
	ADDI A,-1	;LF+1,RT-1
	JUMPL A,.-4
	POP P,C
	POPJ P,

MOVS1:	HRRZM B,JOBSYM
	POPJ P,

;ENTER WITH SIZE NEEDED IN A
;EXIT WITH POINTER IN A TO CORE

MORCOR:	PUSH P,B
	HRRZ B,JOBSYM
	SUB B,CORUSE
	SUBM A,B
	JUMPL B,EXPND2
	ADD B,JOBREL	;NEW CORE SIZE
	CALLI B,CORE	;EXPAND CORE
	ERR1 [SIXBIT /CANT EXPAND CORE !/]
	PUSH P,A
	PUSHJ P,MOVSYM
	POP P,A
EXPND2:	MOVE B,CORUSE
	ADDM A,CORUSE
	MOVE A,B
	POP P,B
	POPJ P,

		SUBTTL REALLOC CODE     --- PAGE 19

;RELOCATOR CODE MOVED FROM STRANGE POSITION
STRT:	MOVE A,JOBREL
	HRLM A,JOBSA
	MOVEM A,JOSV#	;NEW TOP OF CORE
	SUB A,JRELO#	;LENGTH OF EXTRA CORE
	JUMPE A,RREL4	;NO EXPANSION
	SKIPG A
	JRST 4,0	;SMALLER CORE -- BITCH
	MOVEI F,ED+2
	HRRM F,ED
	MOVE F,EFWSO#
	SUB F,FWSO#	;OLD LENGTH OF FWS
	HRRZS B,A
ACHLOC:	ASH A,-2	;1/4 OF NEW CORE TO FWS
	ADD A,F	;NEW LENGTH OF FWS
	MOVE C,B
	ASH C,-6	;1/64 OF NEW CORE TO EACH PDL
	MOVE AR1,C
	HRL AR1,C
	HLRZ AR2A,SC2	;-OLD LENGTH OF SPEC PDL
	ADD AR2A,JOSV	;NEW BOTTOM OF SPEC PDL
	HLL AR2A,SC2	;OLD LENGTH OF SPEC PDL
	SUB AR2A,AR1	;NEW POINTER FOR SPEC PDL
	MOVEM AR2A,SC2
	MOVNS C2	;OLD REG PDL POINTER
	HLRZ AR1,C2	;OLD LENGTH OF REG PDL
	ADD C,AR1	;NEW LENGTH OF REG PDL
	HRRZ B,AR2A	;NEW BOTTOM OF REG PDL
	SUB B,FSO#
	MOVEI T,44	;1/36 SPACE FOR FWS BIT TABLES
	IDIVM A,T	;NEW LENGTH OF FWS BIT TABLES
	AOS T		
	SUB B,T
	SUB B,A
	SUB B,C
	MOVEI TT,41	;1/33 SPACE FOR FS BIT TABLE
	IDIVM B,TT	;NEW LENGTH OF FS BIT TABLE
	SUBI B,1(TT)	;NEW LENGTH OF FS
	ADD B,FSO	;NEW BOTTOM OF FS
	HRRM B,GCP1
	MOVN SP,B	;- NEW BOTTOM OF FWS
	HRRM SP,GCMFWS
	HRLZM A,C1GCS
	MOVNS C1GCS	;- NEW LENGTH OF FWS
	HRRM B,C1GCS
	ADDI B,-1(A)	;NEW TOP OF FWS
	AOS B
	MOVE SP,FSO
	LSH SP,-5
	SUBM B,SP
	HRRM SP,GCBTP2	;MAGIC NUMBER FOR BIT TABLE REFERENCES
	HRRM SP,GCBTP1
	HRLM B,C3GC	;BOTTOM OF BIT TABLES --- FOR BIT TABLE ZEROING
	HRRM B,GCP2
	HRRM B,GCP
	MOVNI SP,-1(TT)
	HRLM SP,C3GCS
	HRRM B,C3GCS	;IOWD FOR BIT TABLE SWEEP
	AOS B
	MOVE SP,FSO
	ANDI  SP,37
	HRRM SP,GCBTL2	;MAGIC NUMBER TO POSITION BIT TABLE WORD
	SUBI SP,^D32
	HRRM SP,GCBTL1
	HRRM B,C3GC	;BOTTOM OF BIT TABLE
	ADDI B,-1(TT)
	HRRM B,C2GCS	;BOTTOM OF FWS BIT TABLE
	AOS B
	HRRM B,C2GC
	ADDI B,-1(T)
	HRRM B,GCP5	;TOP OF BIT TABLES
	AOS B		;BOTTOM OF REG PDL
	HRRZ A,RHX2	;OBLIST POINTER
	MOVEM A,(B)
	HRRM B,GCP3	;ROOM FOR ACS
	AOS B
	HRRM B,GCSP1
	HRRM B,GCP4	;ROOM FOR ACS
	ADDI B,10
	HRRM B,GCP41	;TOP OF AC AREA
	AOS B
	HRRM B,C2	;REG PDL BOTTOM
	MOVNI A,-20(C)
	HRLM A,C2	;REG PDL SIZE
	HRRZ A,JOSV
	HRRZM A,JRELO	;NEW TOP OF CORE
	MOVE A,GCP1
	HRRM A,.+4
	MOVE A,FWSO
	HRRM A,.+1
	MOVE A,.(F)	;OLD BOTTOM OF FWS	*
	MOVEM A,.(F)	;NEW BOTTOM OF FWS	*
	SOJGE F,.-2	;F HAS LENGTH (OLD) OF FWS
	HRRZ AR1,GCP1
	SUB AR1,FWSO	;DISPLACEMENT FOR FWS
	MOVE AR2A,FSO	;BOTTOM OF FS

RREL1:	HLRZ A,(AR2A)
	CAMG A,EFWSO
	CAMGE A,FWSO
	JRST RREL2
	ADD A,AR1
	HRLM A,(AR2A)	;FIX CAR POINTER
RREL2:	HRRZ A,(AR2A)
	CAMG A,EFWSO
	CAMGE A,FWSO
	JRST RREL3
	ADD A,AR1
	HRRM A,(AR2A)	;FIX CDR POINTER
RREL3:	CAMGE AR2A,FWSO
	AOJA AR2A,RREL1
	MOVE A,GCP1	;BOTTOM OF FWS
	HRRZM A,FWSO
	MOVE A,C3GC	;BOTTOM OF BIT TABLE + 1
	HRRZM A,EFWSO
RREL4:
	CLEARB F,DDTIFG
	JSR IOBRST
	JRST LISPGO
PAGE
RLOCA:	MOVE B,AR1
	HRLI AR1,BFWS
	HRRI AR1,FS(B)
	HRRZI AR2A,EFWS-BFWS(AR1)
	BLT AR1,(AR2A)
	MOVEI AR1,FS-BFWS(B)
	MOVEI AR2A,BFWS-1

REL1:	HLRZ A,(AR2A)
	CAILE A,EFWS
	JRST REL2
	CAIGE A,BFWS
	JSP R,REL4
	ADD A,AR1
REL2:	HRLM A,(F)
	HRRZ A,(AR2A)
	CAILE A,EFWS
	JRST REL3
	CAIGE A,BFWS
	JSP R,REL4
	ADD A,AR1
REL3:	HRRM A,(F)
	SOS F
	CAILE AR2A,FS
	SOJA AR2A,REL1
	JRST RREL4

REL4:	CAIL A,FS
	ADD A,FF
	JRST 1(R)

REHASH:
FOO	MOVEI A,BFWS
	PUSH P,A
	HRRM A,RHX2
	HRRM A,RHX5
RH4:	MOVSI B,X				;*
FOO	HRRZI A,BFWS+1(B)
FOO	MOVEM A,BFWS(B)
	AOBJN B,.-2
FOO	SETZM BFWS(B)
	MOVSI AR2A,-BCKETS
RH1:
FOO	HLRZ C,OBTBL(AR2A)
RH3:	JUMPE C,RH2
	HLRZ A,(C)
	PUSH P,C
	PUSH P,AR2A
	PUSHJ P,INTERN
	POP P,AR2A
	POP P,C
	HRRZ C,(C)
	JRST RH3
RH2:	AOBJN AR2A,RH1
	SETZM HASHFG
	POP P,A
	HRRM A,@GCP3
FOO	MOVEM A,OBLIST
	JRST START

		SUBTTL LISP ATOMS AND OBLIST    --- PAGE 20

VAR
LIT
FS:

DEFINE MAKBUC (A,%B)
<DEFINE OBT'A <%B=.>
XWD %B,IFN <<BCKETS-1>-A>,<.+1>
IF1 <%B=0>>

DEFINE ADDOB (A,C,%B)
<OBT'A
DEFINE OBT'A<%B=.>
IF1 <%B=0>
XWD C,%B>

DEFINE PUTOB (A,B)
<ZZ==<ASCII /A/>_<-1>
ZZ==-ZZ/BCKETS*BCKETS+ZZ
ADDOB \ZZ,B>

DEFINE PSTRCT (A)
<ZZ==[ASCII /A/]
LENGTH ZY,A
REPEAT <ZY-1>/5,<XWD ZZ,.+1
ZZ==ZZ+1>
XWD ZZ,0>

DEFINE MKAT (A,B,C,D)
<XLIST
IRP A< PUTOB A,.+1
D	XWD -1,.+1
	XWD B,.+1
	XWD C'A,.+1
	XWD PNAME,.+1
	XWD .+1,0
	PSTRCT A>
LIST>

DEFINE MKAT1 (A,B,C,D)
<XLIST
IRP C <PUTOB C,.+1
	XWD -1,.+1
	XWD B,.+1
	XWD D'A,.+1
	XWD PNAME,.+1
	XWD .+1,0
	PSTRCT C>
LIST>
DEFINE LENGTH (A,B)
<A==0
IRPC B,<A==A+1>>
DEFINE ML1 (A)<IRP A,<
V'A=	INUM0+A
	MKAT A,SYM,V
>>


DEFINE ML (A)<
XLIST
IRP A,<PUTOB A,.+1
A:	XWD -1,.+1
	XWD PNAME,.+1
	XWD .+1,0
	PSTRCT A>
LIST>

OBTBL:
OBLIST:	ZZ==0
XLIST
REPEAT BCKETS,<MAKBUC \ZZ
ZZ==ZZ+1>
LIST

PAGE
MKAT<RPLACA,RPLACD,MINUS,TERPRI,READ,CAR,CDR,CAAR>,SUBR
MKAT<CADR,CDAR,CDDR,CAAAR,CAADR,CADAR,CADDR,CDAAR,CDADR,CDDAR,CDDDR>,SUBR
MKAT<CAAAAR,CAAADR,CAADAR,CAADDR,CADAAR,CADADR,CADDAR,CADDDR,CDAAAR>,SUBR
MKAT<CDAADR,CDADAR,CDADDR,CDDAAR,CDDADR,CDDDAR,CDDDDR,MAKNUM,CONS>,SUBR
MKAT<ATOM,EQ,PRIN1,PRINT,RETURN,EXPLODE,SASSOC,ASSOC>,SUBR
MKAT<GCGAG,CHRCT,LINELENGTH,NUMBERP,EQUAL,SUBST,GET,INTERN,MEMBER>,SUBR
MKAT<ED,LOAD,MAKNAM,READCH,NOT,NULL,GENSYM,ZEROP,DIVIDE,GCD>,SUBR
MKAT<TIME,FIX,SET,PROG2,LENGTH,READLIST,LAST,ADD1,SUB1>,SUBR
MKAT<GCTIME,REVERSE,SPEAK,MAPLIST,GC,GETL,BAKGAG,MEMQ>,SUBR
MKAT<PUTPROP,PRINC,FLATSIZE,ERR,MAPCAR,EXAMINE,DEPOSIT,LSH>,SUBR
MKAT<NCONS,XCONS,REMPROP,ARG,SETARG,NOUUO,MINUSP,MAP,MAPC>,SUBR
MKAT<OUTC,INC,DDTIN,INITFN,EXCISE,REMAINDER,ABS>,SUBR
MKAT<PGLINE>,SUBR

MKAT EXPLODEC,SUBR,%
MKAT TYO,SUBR,I
	MKAT TYI,SUBR,I
CEVAL=.+1
MKAT1 EVAL,SUBR,*EVAL

MKAT <LIST,COND,PROG,SETQ,INPUT,OUTPUT,GRINDEF>,FSUBR
MKAT<ERRSET,REMOB,OR,GO,ARRAY,STORE>,FSUBR
MKAT<AND,DEFPROP,CSYM,EXARRAY>,FSUBR
MKAT1 QUOTE,FSUBR,FUNCTION
MKAT1 FUNCT,FSUBR,*FUNCTION
MKAT <APPEND,NCONC,BOOLE,APPLY>,LSUBR

MKAT EVAL,LSUBR,O
MKAT ASCII,SUBR,A
MKAT QUOTE,FSUBR,,CQUOTE:

	PUTOB T,.+1
TRUTH:	XWD -1,.+1
	XWD VALUE,.+1
	XWD VTRUTH,.+1
	XWD PNAME,.+1
	XWD .+1,0
	PSTRCT T
VTRUTH:	TRUTH

	PUTOB NIL,0
CNIL2:	XWD VALUE,.+1
	XWD VNIL,.+1
	XWD PNAME,.+1
	XWD .+1,0
	PSTRCT NIL
VNIL:	NIL
MKAT1 LCALL,SYM,*LCALL,INUM0+%
MKAT1 AMAKE,SYM,*AMAKE,INUM0+%
MKAT1 UDT,SYM,*UDT,INUM0+%
MKAT1 %NOPOINT,VALUE,*NOPOINT
%NOPOINT:	NIL


UNBOUND:	XWD -1,.+1
	XWD PNAME,.+1
	XWD .+1,0
	PSTRCT UNBOUND
PAGE
MKAT1 EXPN1,SUBR,*EXPAND1
MKAT1 EXPAND,SUBR,*EXPAND
MKAT1 PLUS,SUBR,*PLUS,.
MKAT1 DIF,SUBR,*DIF,.
MKAT1 QUO,SUBR,*QUO,.
MKAT1 TIMES,SUBR,*TIMES,.
MKAT1 APPEND,SUBR,*APPEND,.
MKAT1 RSET,SUBR,*RSET,.
MKAT1 GREAT,SUBR,*GREAT,.
MKAT1 LESS,SUBR,*LESS,.
MKAT1 PUTSYM,SUBR,*PUTSYM
MKAT1 GETSYM,SUBR,*GETSYM

ML1 <SPECBIND,SPECSTR,FIX1A,NSTR>

	PUTOB NUMVAL,.+1
	XWD -1,.+1
	XWD SUBR,.+1
	XWD NUMVAL,.+1
	XWD SYM,.+1
	XWD NUMVAL+INUM0,.+1
	XWD PNAME,.+1
	XWD .+1,0
	PSTRCT NUMVAL





MKAT <OBLIST,BASE,IBASE,BPEND,BPORG>,VALUE,V

VOBLIST:	OBLIST
VBASE:	8+INUM0
VIBASE:	8+INUM0

ML <PNAME,FIXNUM,FLONUM,VALUE,LAMBDA,SUBR,FSUBR,EXPR,FEXPR,SYM,
$EOF$,LABEL,FUNARG,LSUBR,MACRO>

	PUTOB ?,.+1
QST:	XWD -1,.+1
	XWD PNAME,.+1
	XWD .+1,0
	PSTRCT ?

VBPORG:	INUM0
VBPEND:	INUM0

MKAT ACHLOC,SYM

BFWS:
LIT
EFWS:	0


		SUBTTL LISP STORAGE ALLOCATOR (ONCE ONLY) --- PAGE 21

SBPS:	2000

ALLTYO:	HRLOI A,700+A
	HLLM A,(P)
	ILDB C,(P)
	JUMPE C,ALLPOP
	PUSHJ P,ALLTYC
	JRST .-3

ALLTYI:	PUSH P,A
	MOVE A,C
	PUSHJ P,TTYI
	MOVE C,A
	POP P,A
ALLPOP:	POPJ P,0

ALLTYC:	PUSH P,A
	MOVE A,C
	PUSHJ P,TTYO
	POP P,A
	POPJ P,0


ALLNUM:	MOVSI A,400000
	PUSHJ P,ALLTYI
	CAIN C,RUBOUT
	JRST ALLRUB
	CAIL C,60
	CAIL C,72
	POPJ P,
	TLZ A,400000
	IMULI A,10
	ADDI A,-60(C)
	JRST ALLNUM+1

ALLPDL:	BLOCK 10

ALLRUB:	PUSHJ P,ALLTYO
	ASCII /X/
	JRST ALLNUM
ALLOC:	MOVEI P,ALLPDL-1
	MOVE A,JOBREL	;CHANGE TO JOBSYM FOR DEBUGGING
	HRRZM A,JRELO
	HRLM A,JOBSA
	CALLI 0
	CALLI 5
	PUSHJ P,ALLTYO
	ASCII /
ALLOC? /
	PUSHJ P,ALLTYI
	CAIGE C,60
	JRST ALLC00
	PUSHJ P,ALLTYO
	ASCII /
FULL WDS=/
	PUSHJ P,ALLNUM
	SKIPGE A
	MOVEI A,400
	HRRM A,ALLC02
	PUSHJ P,ALLTYO
	ASCII /
BIN.PROG.SP=/
	PUSHJ P,ALLNUM
	SKIPGE A
	MOVEI A,2000
	HRRZM A,SBPS
	PUSHJ P,ALLTYO
	ASCII /
SPEC.PDL=/
	PUSHJ P,ALLNUM
	SKIPGE A
	MOVEI A,1000
	HRRM A,ALLC20
	MOVNS A
	HRRM A,ALLC21
	PUSHJ P,ALLTYO
	ASCII /
REG. PDL=/
	PUSHJ P,ALLNUM
	SKIPGE A
	MOVEI A,1000
	HRRM A,ALLC30
	PUSHJ P,ALLTYO
	ASCII /
HASH=/
	PUSHJ P,ALLNUM
	CAIG A,BCKETS
	JRST ALLC00
	HRRM A,INT1
	MOVNS A
	HRRM A,RH4
	SETOM HASHFG
ALLC00:	MOVEI A,STRT
	HRRM A,JOBREN
	MOVEI A,LISPGO
	HRRM A,JOBSA
	PUSHJ P,ALLTYO
	ASCII /
/
	MOVEI A,FS
	ADDM A,VBPORG
	ADD A,SBPS
	HRRZM A,FSO
	SOS A
	ADDM A,VBPEND
	MOVE A,JRELO
ALLC20:	SUBI A,1000
ALLC21:	HRLI A,-1000
	MOVEM A,SC2
	SUB A,FSO
	HRRZS B,A
	ASH A,-4
ALLC02:	ADDI A,400
	MOVE C,B
	ASH C,-6
ALLC30:	ADDI C,1000
;STG ORDER PRGM BPS FS FWS BT BTF PDLAC PDL SP 
	MOVEI T,44
	IDIVM A,T
	AOS T		;SIZE OF BTF
	SUB B,T
	SUB B,A
	SUB B,C		;REMAINING STORAGE
	MOVEI TT,^D32+1
	IDIVM B,TT	;BT SIZE -1
	SUBI B,1(TT)	;FREE STORAGE SIZE
	ADD B,SBPS
	HRRZ AR1,B
	ADDI B,FS
	HRRZM B,FWSO
	HRRM B,GCP1	;B HAC TOP OF FS
	MOVN SP,B
	HRRM SP,GCMFWS
	HRLZM A,C1GCS	;LENGTH OF FWS
	MOVNS C1GCS
	HRRM B,C1GCS
	ADDI B,-1(A)	;BOTTOM OF BT-1
	AOS B
	MOVE SP,FSO
	MOVE FF,SBPS
	MOVEI F,BFWS-1(FF)
	LSH SP,-5
	SUBM B,SP
	HRRM SP,GCBTP2
	HRRM SP,GCBTP1
	HRLM B,C3GC
	HRRM B,GCP2
	HRRM B,GCP
	HRRZM B,EFWSO
	MOVNI SP,-1(TT)
	HRLM SP,C3GCS
	HRRM B,C3GCS
	AOS B
	MOVE SP,FSO
	ANDI SP,37
	HRRM SP,GCBTL2
	SUBI SP,^D32
	HRRM SP,GCBTL1
	HRRM B,C3GC
	ADDI B,-1(TT)
	HRRM B,C2GCS
	AOS B
	HRRM B,C2GC
	ADDI B,-1(T)

	HRRM B,GCP5
	AOS B
	MOVEI A,OBTBL
	ADD A,SBPS
	MOVEM A,(B)
	HRRM B,GCP3
	AOS B
	HRRM B,GCSP1
	HRRM B,GCP4
	ADDI B,10
	HRRM B,GCP41
	AOS B
	HRRM B,C2
	MOVNI A,-20(C)
	HRLM A,C2

	MOVEI C,FOOLST
REL5:	MOVE B,(C)
	HRRZ A,(B)
	ADD A,FF
	HRRM A,(B)
	HLR B,B
	HRRZ A,(B)
	ADD A,FF
	HRRM A,(B)
	CAIGE C,EFOLST-1
	AOJA C,REL5
	JRST RLOCA


I=0
DEFINE GARP (A,B)
<XWD FOO'A,FOO'B>

FOO	0
FOOLST:
XLIST
REPEAT <FOOCNT/2>,<
GARP (\I,\<I+1>)
I=I+2>
LIST

EFOLST:

DEFINE MKENT (A)<
INTERNAL A>

MKENT <EVBIG,NUMBP2,OPOV,NUMV2,NUMV3,NUMV4,OPR,FLOOV,FIX2>
MKENT <NUM1,NUM3,BPR,FWCONS,FALSE,TRUE,FW0CNS,NCONS>
MKENT <READ,READP1,MAKNUM,PRIN1,PRINT,EXPLODE,SASSOC,EQUAL,SUBST>
MKENT <CHCT,LINL,OLDCH,FLATSIZE,TYI,RATOM,CHRCT,TYOD>
MKENT <GET,INTERN,REMOB,MAKNAM,GENSYM,FIX,LENGTH,READLIST,PATOM>
MKENT <LAST,INC,OUTC,FIX1A,NUMVAL,REVERSE,MAPLIST,GC,GETL,PUTPROP>
MKENT <ERR,MAPCAR,REMPROP,LIST,SETQ,ERRSET,REMOB,ARRAY,APPEND>
MKENT <SPECBIND,SPECSTR,XCONS,ATOM,READCH,SET,NCONC,PRINC>
MKENT <CONS,ACONS,CTY,FP7A1,TERPRI,LSPRET,PSAV1,BKTRC>
MKENT <TYO,ITYO,IGSTRT,NOINFG,CHRTAB,EVAL,OEVAL,.APPEND,INPUT,OUTPUT>

PAGE
	END ALLOC