Google
 

Trailing-Edge - PDP-10 Archives - decuslib10-01 - 43,50073/lisp.mac
Click 43,50073/lisp.mac to see without markup as text/plain
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
SALL


; WHEN THE FOLLOWING TWO SWITCHES ARE OFF (0), THE ONLY DIFFERENCES FROM
;	STANFORD 1.6 ARE:
;		  1)  OCTAL PPNS,
;		  2)  EXPLICIT I/O FOR SOS-LINKAGE,
;		  3)  THE '*' PROMPT-CHAR CAN BE DYNAMICALLY CHANGED, TO
;			CONSIST OF UP TO 4 CHARACTERS;
;		  4)  THE SUBR CORE(N) IS USED TO INCREASE (OR PARTIALLY CUT) CORE;
;		  5)  THE SUBR ALLOC() JUST GOES TO LISPGO TO ALLOC NEW CORE;
;		6)  A SWITCH FOR ALTMODE TO BE 33 OR 175.


TENEX==0	;WHEN OFF, WILL ASSEMBLE FOR DECUS 10/50 LISP.
;TENEX==1	;WHEN ON, THIS HAS THE FOLLOWING EFFECTS:
		; 1)  THE 10X PSI IS ENABLED FOR 10/50 ^O (SIMULATED);
		; 2)  THE 'SYS:' DIRECTORY IS NOT PRESUMED TO BE <SYSTEM>,
		;	BUT RATHER THE DEFAULT IS <LISP> ... IF THIS
		;	IS NOT FOUND, THE USER IS ASKED FOR A DIR-NAME.
		; 3)  THE SWAPOUT FOR THE SOS-LINK IS DONE AS AN INFERIOR FORK,
		;	WHICH RETURNS THROUGH LISPGO -- ALLOCATING ANY HI-CORE.
		; 4)  THE SUBR SETSYS IS USED TO DYNAMICALLY CHANGE 'SYS:';
		; 5)  THE INITIAL START-UP QUESTIONS ARE SLIGHTLY CHANGED.


VBP==1		;THIS HAS THE CORRECTIVE EFFECT THAT BPS-SPACE IS NOT LIMITED TO
		;	<64K AS WITH STANFORD, BUT MAY EXTEND TO 128K.
		; 1)  BPS (VBPORG, VBPEND) USED BY: ARRAY AND LOAD, PRINCIPALLY.
		; 2)  EXAMINE AND DEPOSIT NOW WORK >64K LIMIT.


DECUS==1-TENEX	;THIS SETS THE ASCII CODE FOR ALTMODE.


;AN ADDITIONAL PAIR OF SUBRS ARE RDBLK AND WRBLK, USED FOR MANIPULATING
;	OVERLAY-BLOCKS IN BPS-SPACE TO AND FRO DISK-FILES.




INUMIN=377777
INUM0=<INUMIN+777777>/2
BCKETS==77
INITCORE==^D11*2000-1	;INITIAL STARTING CORE SIZE FOR TENEX.

PAGE
;accumulator definitions

;'sacred' means sacred to the interpreter
;'marked' means marked from by the garbage collector
;'protected' means protected during garbage collection

NIL=0	;sacred, marked, protected	;atom head of NIL
A=1	;marked, protected	;results of functions and first arg of subrs
B=A+1	;marked, protected	;second arg of subrs
C=B+1	;marked, protected	;third arg of subrs
AR1=4	;marked, protected	;fourth arg of subrs
AR2A=5	;marked, protected	;fifth arg of subrs
T=6	;marked, protected	;minus number of args in LSUBR call
TT=7	;marked, protected
REL=10	;marked, protected	;rarely used
S=11	;rarely used
D=12	
R=13	;protected
P=14	;sacred, protected	;regular push down stack pointer
F=15	;sacred			;free storage list pointer
FF=16	;sacred			;full word list pointer
SP=17	;sacred, protected	;special pushdown stack pointer

NACS==5	;number of argument acs


X==0	;X indicates impure (modified) code locations
TEN==^D10

PAGE
;UUO definitions

	;UUOs used to call functions from compiled code
	;the number of arguments is given by the ac field 
	;the address is a pointer either to the function 
	;name or the code of the function

OPDEF FCALL [34B8]	;ordinary function call-may be changed to PUSHJ
OPDEF JCALL [35B8]	;terminal function call-may be changed to JRST
OPDEF CALLF [36B8]	;like call but may not be changed to PUSHJ
OPDEF JCALLF [37B8]	;like jcall but may not be changed to JRST

;error UUOs 

OPDEF ERR1 [1B8]	;ordinary lisp error	;gives backtrace
OPDEF ERR2 [2B8]	;space overflow error	;no backtrace
OPDEF ERR3 [3B8]	;ill. mem. ref.
OPDEF STRTIP [4B8]	;print error message and continue

;system UUOs

OPDEF TTYUUO [51B8]
OPDEF INCHRW [TTYUUO 0,]
OPDEF OUTCHR [TTYUUO 1,]
OPDEF OUTSTR [TTYUUO 3,]
OPDEF INCHWL [TTYUUO 4,]
OPDEF INCHSL [TTYUUO 5,]
OPDEF CLRBFI [TTYUUO 11,]
OPDEF TALK [PUSHJ P,TTYCLR]	;this is to turn off control O.
				;when ttyser lets you do this
				;easily, change me
IFN TENEX, <
OPDEF	JSYS	[104B8]
OPDEF	AIC	[JSYS	131]
OPDEF	ATI	[JSYS	137]
OPDEF	CFOBF	[JSYS	101]
OPDEF	CFORK	[JSYS	152]
OPDEF	DEBRK	[JSYS	136]
OPDEF	DOBE	[JSYS	104]
OPDEF	GET	[JSYS	200]
OPDEF	GJINF	[JSYS	 13]
OPDEF	GTJFN	[JSYS	 20]
OPDEF	IIC	[JSYS	132]
OPDEF	KFORK	[JSYS	153]
OPDEF	RIR	[JSYS	144]
OPDEF	SFRKV	[JSYS	201]
OPDEF	SIR	[JSYS	125]
OPDEF	STDIR	[JSYS	 40]
OPDEF	WFORK	[JSYS	163]
	   >

PAGE
;I/O bits and constants

TTYLL==105	;teletype linelength 
LPTLL==160	;line printer linelength
MLIOB==203	;max length of I/O buffer
NIOB==2		;no of I/O buffers per device
NIOCH==17	;number of I/O channels
FSTCH==1	;first I/O channel
TTCH==0		;teletype I/O channel
BLKSIZE==NIOB*MLIOB+COUNT+1
INB==2
OUTB==1
AVLB==40
DIRB==4

;special ASCII characters

IFN TENEX,< ALTMOD==175 >
IFN DECUS,< ALTMOD==33 >
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	;ac field
XFLD==21	;index field
OPFLD==10	;opcode field
ADRFLD==43	;adress field

PAGE
;external and internal symbols

EXTERNAL JOB41	;instruction to be executed on UUO
EXTERNAL JOBAPR	;address of APR interupt routines
EXTERNAL JOBCNI	;interupt condition flags
EXTERNAL JOBFF	;first location beyond program
EXTERNAL JOBREL	;address of last legal instruction in core image
EXTERNAL JOBREN	;reentry address
EXTERNAL JOBSA	;starting address
EXTERNAL JOBSYM	;address of symbol table
EXTERNAL JOBTPC	;program counter at time of interupt
EXTERNAL JOBUUO	;uuo is put here with effective address computed

;apr flags
PDOV==200000	;push down list overflow
MPV==20000	;memory protection violation
NXM==10000	;non-existant memory referenced
APRFLG==PDOV+MPV+NXM	;any of the above

;system uuos
APRINI==16
RESET==0
STIME==27
DEVCHR==4
EXIT==12
CORE==11

PAGE
;foolst macros:  these get relocated (RH addr) relative to FF.

DEFINE FOO <
XLIST
BAZ (\FOOCNT)
LIST
	>

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

FOOCNT=0
		SUBTTL TOP LEVEL AND INITIALIZATION  --- PAGE 2


LISPGO:	SETOM	RETFLG#		;enter via INITFN
	JRST	STRT		;go to re-allocator

DEBUGO:	SETZM	RETFLG		;clear return flag to allow INITFN to be changed
IFE TENEX,<			;entry point to get into read-eval-print loop
	JRST	LISP1X >	;  without unbinding spec pdl.
IFN TENEX,<			;FIX ACS, SINCE MAY BE IN PA1050 FILE
	JRST	REETNX >	;  AT TIME OF ^C (WITH ITS ACS).


START:	CALLI	RESET		;random initializations for lisp interupts
	MOVE	A,[JSR UUOH]
	MOVEM	A,JOB41
	MOVEI	A,APRINT
	MOVEM	A,JOBAPR
	JSR	APRSET		;SET UP INTERRUPTS (+ 10X IF USED FOR ^O).
REETNX:
	HRRZI 17,1
	SETZB 0,PSAV1
	BLT 17,17	;clear acs 
LSPRT1:	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
	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 APR INTERRUPT ROUTINES --- PAGE 3
;arithmetic processor interupts
;mem. protect. violation, nonex. mem. or pdl overflow

APRINT:	MOVE R,JOBCNI	;get interupt bits
	TRNE R,MPV+NXM	;what kind
	ERR3 @JOBTPC	;an ill mem ref-will become JRST ILLMEM
	JUMPN NIL,MES21	;a pdl overflow
	STRTIP [SIXBIT /_PDL OVERFLOW FROM GC - CAN'T CONTINUE!/]
	JRST START

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 !/]

ILLMEM:	LDB R,[POINT 4,@JOBTPC,XFLD]	;get index field of bad word
	CAIE R,F	;does  it contain f
	ERR3 @JOBTPC	;no! error
	PUSHJ P,AGC	;yes! garbage collect
	JRST @JOBTPC	;and continue


PAGE

INTERNAL  TYID,LISP1,APRSET,LISPGO	;FOR CMPBIN.MAC


APRSET:	0			;SET UP NECESSARY INTERRUPTS.
	MOVEI	A,APRFLG	;	(ACCS A & B ARE FREE).
	CALLI	A,APRINI	;THIS DOES THE 10/50 SETUP.
IFN TENEX, <
	HRRZI	1,400000	;FORK HANDLE FOR THIS FORK.
	RIR			;GET THE PA1050 FILE'S LEVTAB,,CHNTAB.
	MOVE	1,[XWD 1,CHANL0];LEVEL 1 TO OVERRIDE PA1050'S USAGE.
	MOVEM	1,0(2)		;SET CHANNEL 0 ADDRESS.
	MOVSI	1,"O"-100
	ATI
	MOVSI	2,(1B0)		;*******  EXTEND.LAP PATCHES HERE  **********
	HRRZI	1,400000
	AIC
	SETZM	OFLAG
>
	JRST	@APRSET



;********** CHANNEL 0 INTRP CODE **********

IFN TENEX, <
CHANL0:	MOVEM	1,AC1SV
	SETCMM	OFLAG
	HRRZI	1,101		;FILE DESIG. FOR PRIM OUTPUT DEV.
	CFOBF			;CLEAR THE OUTPUT BUFFER
	MOVE	1,AC1SV
	DEBRK		;DISMISS PSEUDO INTRP.

AC1SV:	0

OFLAG::	0
>
		SUBTTL UUO HANDLER AND SUBR CALL ROUTINES --- PAGE 4

UUOMIN==1
UUOMAX==4

UUOH:	X		;jsr location
	MOVEM T,TSV#
	MOVEM TT,TTSV#
		LDB T,[POINT 9,JOBUUO,OPFLD]	;get opcode
	CAIGE T,34	;is it a function call
	JRST ERROR	;or a LISP error
	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
ERROR:
IFE TENEX,< MOVEI A,APRFLG
	    CALLI A,APRINI >	;enable interupts
IFN TENEX,< JSR APRSET >
	LDB A,[POINT 9,JOBUUO,OPFLD]	;get opcode
	CAIL A,UUOMIN	;what
	CAILE A,UUOMAX	;is it?
	JRST ILLUUO	;an illegal opcode
	JRST @ERRTAB-UUOMIN(A)	;or LISP error
ERRTAB:	ERROR1	;1	;ordinary LISP error
	ERRORG	;2	;space overflow error
	ERROR2	;3	;ill. mem. ref.
	STRTYP	;4	;print error message and continue
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 @UUOH
PAGE
ERROR2:	HRRZ A,JOBUUO
	MOVEI B,[SIXBIT / ILL MEM REF FROM !/]
	JRST ERSUB2

ILLUUO:	HRRZ A,UUOH
	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	[CLRBFI	;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

DOTERR:	SETZM OLDCH
	ERR1 [	SIXBIT /DOT CONTEXT ERROR!/]
UNDFUN:	HLRZ A,(AR1)
	PUSHJ P,EPRINT
	ERR1 [SIXBIT /UNDEFINED FUNCTION!/]
UNBVAR:	PUSHJ P,EPRINT
	ERR1 [SIXBIT /UNBOUND VARIABLE - EVAL!/]
NONNUM:	ERR1 [SIXBIT /NON-NUMERIC ARGUMENT!/]
NOPNAM:	ERR1 [SIXBIT /NO PRINT NAME - INTERN!/]
NOLIST:	ERR1 [SIXBIT /NO LIST-MAKNAM!/]
TOMANY:	ERR1 [SIXBIT /TOO MANY ARGUMENTS SUPPLIED - APPLY!/]
TOOFEW:	ERR1 [SIXBIT /TOO FEW ARGUMENTS SUPPLIED - APPLY!/]
UNDTAG:	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)
	CAILE B,(JCALLF 17,@(17))
	CAIN B,(PUSHJ P,)	;tests for various types of calls
	CAIGE B,(FCALL)
	SOJA D,BKTR2		;not a proper function call
	PUSH P,-1(A)	;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
	TLNE R,17
	HRRZ R,ERSUB3	;qst -- cant handle indexed calls
	HRRZS R
	HLRO B,(R)
	AOSN B
	JRST [	HRRZ 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
	 JRST TYI4
	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

TYI4:
FOO	SKIPN	VFECHO
	 POPJ	P,
	JRST	TTYO	;FILE-INPUT ECHO TO TTY.

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
	PUSHJ P,FIX1A	;(may be larger than INUM size - 99999).
	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
	INCHSL A	;single char if line has been typed
	JRST 	[TALK		;turn off control o, this
				;  can be omitted when ttyser is fixed
		OUTSTR	PCHAR	;output THE PROMPT-CHAR(S).
		INCHWL	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
	INCHRW A	;single character input ddt submode style
	CAIE A,RUBOUT
	JRST TTYXIT
	OUTCHR ["\"]	;echo backslash
	SKIPE PSAV
	JRST RDRUB	;rubout in read resets to top level of read
	MOVEI A,RUBOUT	
	POPJ P,

PCHAR:	ASCIZ	/*/	;INITIAL (DEFAULT) PROMPT-CHAR.


SETPCH:	PUSHJ	P,PNAMUK
	MOVE	A,1(SP)	;(FIRST WORD OF PNAME OF ARG).
	TRZ	A,377	;(INSURE NULL AT END OF STRING).
	MOVEM	A,PCHAR
	JRST	TRUE

PAGE			;output ROUTINES.
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

PAGE
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:
IFN TENEX, <SKIPE OFLAG ;IS ^O FLAG SET? 
	JRST	CNTLOB>	;  YES.
	OUTCHR	A	;OUTPUT SINGLE CHARACTER IN A
	POPJ P,
IFN TENEX, <
CNTLOB:	PUSH	P,A
	HRRZI	1,101	;  TO PRINCIPAL OUTPUT DEVICE (TTY)
	CFOBF		;CLEAR ITS OUTPUT BUFFER
	JRST	POPAJ
>
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:
IFE TENEX, <
	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
	   >
IFN TENEX, <		;TURN ^O OFF IF IT'S ON
	PUSH	P,A
	HRRZI  1,101
	DOBE		;WAIT UNTIL OUTBUF EMPTY !!!!
	SKIPN	OFLAG	;SEE IF ^O STILL ON NOW, IF EVER.
	JRST	POPAJ	; OFF---READY OR NOT, BACK WE GO.
	SETZM	OFLAG	;TO LET TERPRI AND ANYTHING ELSE OUT.
	OUTSTR	[ASCIZ /
/]
	JRST	POPAJ
	   >

TOBUF:	BLOCK 3

TTOBUF:	BLOCK 33

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:	JUMPE T,NXTIO
	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	;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
	PUSHJ P,IOPPNX				;**********KRK
	HRLM A,PPN	;project number
	HLRZ A,(T)
	PUSHJ P,CADR	;cadar is programmer number
	PUSHJ P,SIXMAK
	PUSHJ P,SIXRT
	PUSHJ P,IOPPNX				;**********KRK
	HRRM A,PPN	;programmer number
	HRLZI A,(SIXBIT /DSK/)	;disk is assumed
	JRST IODEV2

IOPPNX:	ROTC	A,-3				;**********KRK
	LSH	A,-3				;**********KRK
	ROTC	A,-3				;**********KRK
	LSH	A,-3				;**********KRK
	ROTC	A,-3				;**********KRK
	CLEAR	A,				;**********KRK
	ROTC	A,9				;**********KRK
	POPJ	P,	;BASE MUST BE 8		 **********KRK
			;  DURING INPUT INST	 **********KRK

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 NIOCH				;*

;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 -NIOCH,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+NIOCH+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:	MOVEM A,CHANNEL
	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
IFN TENEX, <		;shunt SYS: to <LISP>'s dir (or wherever).
	HRLZI	A,(SIXBIT /SYS/)
	CAME	A,DEV
	JRST	ININIT
	HRLZI	A,(SIXBIT /DSK/)
	MOVEM	A,DEV
	MOVE	A,SYSNUM#
	MOVEM	A,PPN
>
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,NIL	;(INC NIL T)
	MOVEI B,TRUTH

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
	MOVE A,CHTAB(A)	;get channel name
	HRRZ A,(A)
	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
	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,FP7B
	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
IFN TENEX,< LET (< >) >
IFN DECUS,< DELIMIT (< >,3) >
;33 -- POTENTIAL ALTMODE.
LET (<    >)
;34 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 (<  >)			
;{
IFN TENEX,< DELIMIT (< >,3) >
IFN DECUS,< LET (< >) >
;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 DOTERR	;dot context error

RDT:	PUSHJ P,RDTX
	PUSH P,A
	PUSHJ P,RATOM
	JRST DOTERR
	CAIN B,1
	JRST POPAJ
	CAIE B,3
	JRST DOTERR
	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:	TDZA A,A
IDEND1:	IDPB A,C
	TLNE C,760000
	JRST IDEND1 
	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:	MOVE C,CURBUC	;
	HLRZ B,@RHX2
	PUSHJ P,CONS	;cons it into the oblist
	HRLM A,@RHX2
	JRST CAR
CURBUC:	0 

;pname unmaker
PNAMUK:
FOO	MOVEI B,PNAME
	PUSHJ P,GET
	JUMPE A,NOPNAM
	MOVE C,SP
PNAMU3:	HLRZ B,(A)
	PUSH C,(B)
	HRRZ A,(A)
	JUMPN A,PNAMU3 
	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)	;get first word of pname 
	LSH B,-1	;right justify it 
INT1:	IDIVI B,BCKETS+X	;compute hash code 
RHX2:
FOO	HLRZ TT,OBTBL(B+1)	;get bucket 
	MOVEM B+1,CURBUC	;save bucket number 
	MOVE T,TT 
	JRST MAKID1

MAKID3:	MOVE TT,T	;save previous atom 
	HRRZ T,(T)	;get next atom 
MAKID1:	JUMPE T,CPOPJ1	;not in oblist
	HLRZ A,(T)	;next id in oblist
MAKID4:	HRRZ A,(A)
	JUMPE A,NOPNAM	;no print name
	MOVE A,(A)
	HLRZ C,A
FOO	CAIE C,PNAME
	JRST MAKID4
	MOVE C,IDPTR	;found pname
	HLRZ A,(A)
MAKID5:	JUMPE A,MAKID3	;not the one
	MOVS A,(A)
	MOVE B,(A)
	ANDCAM AR1,(C)	;clear low bit
	CAME B,(C)
	JRST MAKID3	;not the one
	HLRZ A,A	;ok so far
	AOBJN C,MAKID5
	JUMPN A,MAKID3	;not the one
	HLRZ A,(T)	;this is it
	HLRZ B,(TT) 
	HRLM A,(TT) 
	HRLM B,(T) 
	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	;clear carry0 flag 
	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,CURBUC
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,

;new consing routines-not finished yet
;acons:	troa b,-1
;ncons:	trz b,-1
;cons:	exch b,a
;xcons:	hrl a,b
;	exch a,(f) 
;	exch a,f
;	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,NIL
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
	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
PAGE
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

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,NOPNAM
	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,[POINT 1,-2(P),1]
	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 NONNUM

NUMV3:	JRST NONNUM		;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,NOLIST
	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,UNDFUN	;function object has no definition
	HRRZ A,(A)
UBDPTR:
FOO	CAIN A,UNBOUND
	JRST UNDFUN
	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 UNDFUN
	HLRO TT,(T)
	AOJE TT,EE2		;car (x) is atomic
	JRST EXP3

EE1:
EV5:	HRRZ AR1,(AR1)
	JUMPE AR1,UNBVAR
	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 UNBVAR
	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
	MOVEI A,UNBIND
	EXCH A,(P)
	JRST EVAL
PAGE
AEVAL1:	SKIPGE AEVAL2
	SKIPN B,-1(P)
	JRST ABIND3	;done with binding

			;alist binding
	MOVE A,B
	PUSHJ P,REVERSE
	SKIPA
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,TOOFEW	;special case for fexprs
	AOJN R,TOOFEW
	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 UNDTAG
	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,TOMANY	;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,UNDTAG
	HRRZ A,(A)
FOO	CAIN A,UNBOUND
	JRST UNDTAG
	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
	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)
IFE VBP,< MOVEI A,INUM0+1(R) >	;STANFORD'S SMALL-CORE METHOD.
IFN VBP,< MOVEI A,1(R)
	  PUSHJ P,FIX1A >
FOO	MOVEM A,VBPORG
	POPJ P,


ARRAYS:	PUSH P,A
FOO	MOVE A,VBPORG
IFE VBP,< SUBI A,INUM0 >
IFN VBP,< PUSHJ P,NUMVAL >
	MOVEM A,BPPNR
FOO	MOVE A,VBPEND
IFE VBP,< MOVNI A,-INUM0-2(A) >
IFN VBP,< PUSHJ P,NUMVAL
	  MOVN  A,A
	  ADDI  A,2 >
	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:
IFE VBP,< MOVE A,-INUM0(A) >
IFN VBP,< PUSHJ P,NUMVAL
	  MOVE  A,(A) >
	JRST FIX1A

DEPOSIT:
IFE VBP,< MOVEI C,-INUM0(A)
	  MOVE A,B >
IFN VBP,< MOVE  C,B
	  PUSHJ P,NUMVAL
	  EXCH  A,C >
	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,UBDPTR	;special atom UNBOUND; not on OBLIST
	PUSH P,MKNAM3
	PUSH P,GCMKL	;i/o channel input lists and arrays
	PUSH P,BIND3
	PUSH P,INITF
GCPK2:	PUSH P,[XWD 0,GCP6]	;this is a return address
GCP4:	MOVEI S,X	;pdlac, .=bottom of reg pdl + 1
GCP41:	BLT S,X	;save ACs 0 through 10 at bottom of regpdl	;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 -NIOCH,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,NIL	;will become movei f,-1
	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

XLIST
VAR
LIT
LIST
PAGE;	lisp loader interface

LOAD:	AOS	B,CORUSE
	MOVEM	B,OLDCU#
	MOVEM	A,LDPAR#
	JUMPE	A,LOAD2
IFE VBP, <
FOO	MOVE	B,VBPORG
	SUBI	B,INUM0
	 >
IFN VBP, <
FOO	MOVE	A,VBPORG
	PUSHJ	P,NUMVAL
	MOVE	B,A
	 >
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,START	;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 START

PAGE
BINLD:
IFE VBP,<
	MOVEI	C,INUM0(B)
FOO	CAML	C,VBPEND
	 JRST	BPSERR
FOO	MOVEM	C,VBPORG	;update bporg
	>
IFN VBP,< PUSH	P,A
	  PUSH	P,B
	  HRRZ	A,B
	  PUSHJ P,FIX1A
	  PUSH  P,A
FOO	  MOVE	B,VBPEND
	  PUSHJ P,.LESS
	  JUMPE A,BPSERR
FOO	  POP	P,VBPORG
	  POP	P,B
	  POP	P,A
	>
	SOS	C,OLDCU		;old top of core
	JRST	LDRET2
BPSERR:	SETOM	BPSFLG		;bps exceeded
	JRST	START


SYSINI:	MOVEM A,NAME+1
IFE TENEX, <	SETZM NAME+3 >
IFN TENEX, <	MOVE  A,SYSNUM
		MOVEM A,NAME+3  >
	INIT 17
IFE TENEX, <	SIXBIT /SYS/ >
IFN TENEX, <	SIXBIT /DSK/ >
	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,

PAGE
SUBTTL SOSLINK INLINE WITH LISP MAIN --- PAGE 18.1
; SECTION 18.1 IS USED BY LISP.SOS (I.E., FILEIN & EDFUN) AS DESCRIBED IN THE
;   1.6 MANUAL.  10/50 USERS (DECUS) PROBABLY DO NOT HAVE AN EDITOR LINKAGE.



INTERNAL %FPAGE,%NEXTTYI	;THESE ALSO USED BY REDUCE 2.

%FPAGE:	SUBI	1,INUM0		;FIND-PAGE N, IN THE FILE.
	PUSH	P,1
LOOP:	MOVE	1,0(P)
	SOJE	1,QQEND
ILOOP:	PUSHJ	P,TYI
	CAIE	1,14
	JRST	ILOOP
	SOS	0(P)
	JRST	LOOP
QQEND:	SUB	P,[XWD 1,1]
	POPJ	P,

%NEXTTYI: PUSHJ	P,TYI
	MOVEM	1,OLDCH
	JRST	FIX1A


PAGE


INTERNAL %SOSSWAP

%SOSSWAP:
IFE TENEX,< POPJ P, >
IFN TENEX,<
	HRLZM	1,DEV		;MAKES NONZERO (FOR IOFIL CHECK)
				;  STORES POINTER TO FILE OR TO (FILE.EXT) .
	SUBI	2,INUM0		;(PAGE # .LT. 2^16, OF COURSE).
	PUSH	P,2
	MOVE	1,3
	SUBI	4,INUM0
	LSH	4,^D16		;ERGO, 2 BECOMES 400000
	MOVEM	4,AC4SAV

	MOVE	4,[XWD 10700,3]
	PUSHJ	P,NUMVAL	;(LINE # .LT. 99999).
MKLIN1: IDIVI	1,^D10
	ADDI	2,60
	DPB	2,4
	ADD	4,[XWD 70000,0]
	TLNN	4,400000
	JRST	MKLIN1
	MOVE	1,3
	TRO	1,1

	PUSH	P,1
	MOVEI	T,DEV		;T HAS PNTR TO (PNTR . NIL) .
	PUSHJ	P,IOSUB		;RETURNS FILENM IN A
	MOVE	2,[XWD 6,ACSAV]
	BLT	2,ACSAV+11	;SAVE ACCS 6-17 JUST IN CASE.
	POP	P,15
	POP	P,16
	MOVEM	P,ACSAV-6+14
	MOVE	14,A
	MOVE	13,EXT		;SET BY IOSUB
	HRR	13,AC4SAV	;00/01/02 == GET,R-O,CREATE.
	MOVEI	11,NIL
	CALLI	11,24		;GETPPN UUO
	  >		;******** END OF IFN TENEX. ********

;HIGH ACCS FOR SOS ARE NOW SET ... TO WIT:
;
;ACC 11	= PPN
;    12	= (UNUSED).
;    13 = EXT,,FLAGS	;BITS 18-19 = 0 (GET FILE), 1 (READ-ONLY), 2 (CREATE IT)
;    14 = FILENM
;    15 = LINE #, IN ASCID FORM (BIT 35 ON);
;    16 = PAGE #.
PAGE

IFN 0, <		;USE LABORIOUS METHOD OF MAKING CORE-IMAGE.
			;  == FOR 10/50 SYSTEMS...VESTIGIAL.

;SWAP IS NOT DECLARED INTERNAL/SUBR (THO IT COULD BE).

;FIRST SAVES ALL ACCUMULATORS AS FILE 'QQSVAC.TMP'
;SAV -- SWAPS OUT (EFFECTIVELY) 116 THRU MIN(LH(E+2),JOBREL)
;    -- MUST GO TO THE DISK (& WILL, REGARDLESS OF DEVICE).
;    -- USES 1;  DOES NOT SAVE ANY HIGH SEGMENT !!!
;    -- THE FORMAT IS A NON-ZERO-COMPRESS (75--END).
;    -- THE ACCS ARE RESTORED IF A RUN IS NOT DONE.
;RUN -- USES THE DEC RUN-UUO WHICH DESTROYS THE ACCUMULATORS
;    -- THEREFORE, IF YOU WISH TO PASS ARGUMENTS (IN THE ACCS)
;    --   TO THE NEW PROGRAM, PICK THEM UP FROM THE TMP FILE.


EXTERNAL JOBCOR,JOBS41,JOBDDT
SLOC==74
JOBSDD==114


SWAP:	MOVEI	1,ACBLK
	BLT	1,ACBLK+17   ;CAN'T OUTPUT FROM BELOW LOC 115
	MOVE	1,[XWD ACSAV,6]	;RESTORE UNCLOBBERED HI-ACCS
	BLT	1,17
	CALLI	1,30	;PJOB
	IDIVI	1,^D10
	LSH	1,6
	OR	1,2
	LSH	1,^D24
	OR	1,[SIXBIT/00SVAC/]
	MOVEM	1,ACHEAD
	ADDI	1,5460-4143	;'LP' - 'AC'

	INIT	17	;DUMP MODE
	 SIXBIT /DSK/
	 0		;NO BUFFERS
	 JRST	AOUT.4+1

	SETZM	ACHEAD+2
	SETZM	ACHEAD+3
	ENTER	ACHEAD
	 ERR1	SWOUT2
	OUTPUT	[IOWD 20,ACBLK
		   0]
	STATZ	740000
	 ERR1	SWOUT2
	CLOSE	
	STATZ	740000
	 ERR1	SWOUT2

	MOVEM	1,IOFILE
	SETZM	IOFILE+2
	SETZM	IOFILE+3
	ENTER	IOFILE
	 ERR1	SWOUT2

	HRRZ	2,JOBCOR
	MOVEM	2,OLDCOR
	MOVE	2,JOBREL
	HRRM	2,JOBCOR
	SUBI	2,SLOC	;NOT OUTPUTTING FIRST 0-SLOC LOCS
	MOVEM	2,1	;N WORDS OF DATA
	MOVN	2,2
	SUBI	2,1	;-(N+1) == DATA + NULL HEADER WORD
	HRLM	2,OLIST

	MOVE	2,JOBREL
	HRRM	2,MVX+^D9	;HIGHEST LOC BEFORE RELOC = DITTO BLT
	ADDI	2,2000
	CALLI	2,CORE	;SPACE TO RELOCATE INTO
	 ERR1	SWOUT2

	MOVE	3,[XWD MVX,MV]
	BLT	3,MVE
	MOVE	3,[XWD 216,116]
	JRST	MV

MVX:	PHASE 4
MV:	MOVE	2,SLOC(1)
	MOVEM	2,SLOC+100(1)	;MOVE 100 UPWARD
	SOJG	1,MV
	SETZM	SLOC+100	;NULL HEADER WORD
	MOVE	2,JOBDDT
	MOVEM	2,JOBSDD+100
	MOVE	2,JOB41
	MOVEM	2,JOBS41+100
	OUTPUT	OLIST+100	;AT RELOCATED IOWD
	BLT	3,0-0		;MOVE BACK DOWN
MVE:	JRST	MVY
	DEPHASE

MVY:	MOVE	2,[XWD ACSAV,6]
	BLT	2,17	;RESTORE AGAIN OVER CODE
	HRRZ	2,MVX+^D10
	CALLI	2,CORE	;REDUCE CORE BY 1K TO PREVIOUS
	 STRTIP	[SIXBIT/WOULDN'T REDUCE CORE_!/]

	STATZ	740000	;NOW CHECK FOR OUTPUT ERRORS
	 ERR1	SWOUT2
	CLOSE	0,
	STATZ	740000
	 ERR1	SWOUT2
	RELEAS	0,

	MOVE	2,OLDCOR
	HRRM	2,JOBCOR
	


RUNUUO:	SETZM	NEWCOR
	MOVSI	1,1	;SA INC
	HRRI	1,DEVC2
	CLRBFI		;DELETE CR,LF IF ANY...DISTURB SOS.

	CALLI	1,35	;RUN UUO
	HALT		;  POSSIBLY RECOVERABLE, BUT EXIT ANYWAY



ACBLK:	BLOCK 20
DEVC2:	SIXBIT/SYS/
	SIXBIT/SOS/
	SIXBIT/SAV/
	0
	0
NEWCOR:	
OLDCOR:	0-0
IOFILE:
ACHEAD:	SIXBIT/QQSVAC/
	SIXBIT/TMP/
	0
	0
OLIST:	XWD	0-0,SLOC+100-1
	0
SWOUT2:	SIXBIT /COULDN'T SWAP SUCCESSFULLY_!/

	   >		;******** CLOSE OF  IFN 0,  FROM SWAP: ********.
PAGE

IFN TENEX, <		;EASIER WITH TENEX

SWAP:
	HRLZI	1,1		;SET B17
	MOVE	2,[POINT 7,FILSOS]
	GTJFN
	 JRST	SOSER1
	HRRZ	3,1		;AC1(RH) NOW HAS DESIRED JFN.

	HRLZI	1,40000		;BIT 3 TO USE AC2.
	MOVEI	2,0		;VIRTUAL ADDRESS OF ACCS.
	CFORK			;CREATE INFERIOR FORK.
	 JRST	SOSER2
				;AC1 HAS RELATIVE F HANDLE.
	EXCH	1,3
	HRL	1,3		;SET UP (LH) WITH HANDLE
	GET

	HRRZ	1,3
	MOVEI	2,2		;INDEX INTO ENTRY-VEC
	SFRKV			;START THAT FORK

				;AC1 HAS INFERIOR-F HANDLE!
	WFORK			;CURRENT FORK WAITS UNTIL THE
				;  INFERIOR FORK TERMINATES.

	KFORK			;INF-FORK STILL EXISTS, SO!

SWAPEX:	SETOM	RETFLG		;START. REALLY SHOULDN'T REALLOC, BUT
	JRST	LISPGO		;  THIS DOES SO FOR NOW.

FILSOS:	ASCIZ	/<SUBSYS>SOS.SAV/

SOSER1:	OUTSTR	FILSOS
	OUTSTR	[ASCIZ / NOT FOUND
/]
SOSER2:	OUTSTR	[ASCIZ /COULDN'T SOSSWAP/]
	JRST	SWAPEX

	   >			;CLOSE OF IFN TENEX.


AC4SAV:	0
ACSAV:	BLOCK 12


PAGE
SUBTTL BPS SWAPPING ROUTINES	     --- PAGE 18.2

INTERNAL RDBLK, WRBLK

RDBLK:
IFE TENEX, <
	SETZM	PPN
	HRLZI	C,(SIXBIT/DSK/)
	CAIE	B,NIL		;NIL?
	 HRLZI	C,(SIXBIT/SYS/)
	MOVEM	C,.+2
	   >
IFN TENEX, <
	SETZ	C,
	CAIE	B,NIL
	 MOVE	C,SYSNUM
	MOVEM	C,PPN
	   >
	INIT	17
	 SIXBIT	/DSK/
	 0
	 JRST	AIN.4+1
	HRLZM	A,DEV
	MOVEI	T,DEV
	PUSHJ	P,IOSUB
	MOVEM	A,LOOKIN
	LOOKUP	LOOKIN
	 JRST	AIN.7+1
	INPUT	[IOWD	1,LST
		 0]
	 JRST	SYSINP+1

WRBLK:	INIT	17
	 SIXBIT	/DSK/
	 0
	 JRST	AOUT.4+1
	HRLZM	A,DEV
	MOVE	A,B		;IN CASE ADDRESSES OVER 64K.
	PUSHJ	P,NUMVAL
	EXCH	A,C
	PUSHJ	P,NUMVAL
	SUBI	C,1
	SUBM	C,A	;A_ -(A-(C-1)) == ARG1:ARG2 INCLUSIVE
	HRL	C,A
	MOVEM	C,LST
	MOVEI	T,DEV
	PUSHJ	P,IOSUB
	MOVEM	A,ENTR
	CLEARM	ENTR+2	;CREATION DATE
	ENTER	ENTR
	 JRST	OUTERR+1
	OUTPUT	[IOWD	1,LST
		 0]
	OUTPUT	LST
	CLOSE
	STATZ	740000
	 JRST	TYO2X+2
	POPJ	P,
PAGE
SUBTTL TENEX AUXILIARY ROUTINES      --- PAGE 18.3


INTERNAL  TCORE

TALLOC:	JRST	LISPGO		;== DOING ^C AND START, PRESUMABLY WITH
				;   A CORE N, == TCORE WITHIN LISP.


TCORE:	SUBI	A,INUM0		;== ^C, CORE N, REENTER.
	CAIG	A,0
	 JRST	TCORE0		;JUST RETURN CURRENT CORE SIZE(S)
	CAILE	A,^D124		;LIMIT .LT. 124K OR SO, ALLOWING FOR I/O BUFFS
	 JRST	TCORE3
	LSH	A,^D10
	SUBI	A,1
	CAML	A,JRELO
	 JRST	TCORE1		;LARGER THAN CURRENT LISP AREA ALLOC.
	OUTSTR	[ASCIZ /
CANT CUT CORE INTO ALLOCATED SPACE/]
	JRST	TCORE0+1	;RETURN MINIMUM SIZE
TCORE0:	CAIE	A,0
	 SKIPA	A,JRELO		;-1 GIVES CURRENT LISP-ALLOC AREA
TCORET:	HRRZ	A,JOBREL	; 0 GIVES CURRENT TOTAL CORE ASSIGNED
	ADDI	A,1
	LSH	A,-^D10
	ADDI	A,INUM0
	POPJ	P,
TCORE1:	CAML	A,JOBREL
	 JRST	TCORE2		;LARGER THAN CURRENT CORE, SO EXPAND.
	PUSH	P,A		;  ELSE CONTRACT SOMEWHAT.
	PUSHJ	P,EXCISE
	STRTIP	[SIXBIT /EXCISED !/]
	POP	P,A
TCORE2:	CALLI	A,CORE
TCORE3:	 ERR1	[SIXBIT /CANT EXPAND CORE !/]
	JRST	TCORET


IFN TENEX, <

INTERNAL SETSYS

SETSYS:	SUBI	A,INUM0		;CHANGE SYS: <DIR> NUMBER.
	CAIG	A,0
	 SKIPA	A,SYSNUM
	MOVEM	A,SYSNUM
	JRST	FIXI
	   >
		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 START
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<%FPAGE,%NEXTTYI,%SOSSWAP,RDBLK,WRBLK,SETPCHAR>,SUBR
MKAT<CORE,ALLOC>,SUBR,T
IFN TENEX,<	MKAT<SETSYS>,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:
MKAT INUM0,SYM

	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,FECHO>,VALUE,V

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

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

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

IFE VBP, <
VBPORG:	INUM0
VBPEND:	INUM0
	 >
IFN VBP, <
VBPORG:	0
VBPEND:	0
	 >

MKAT ACHLOC,SYM

BFWS:
XLIST
LIT
LIST
EFWS:	0

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

SBPS:	2000

ALLNUM:	MOVSI A,400000		;high bit on for no digits
	INCHRW C
	CAIN C,RUBOUT
	 JRST	[OUTSTR [ASCIZ /XXX /]
		JRST ALLNUM]
	CAIL C,"0"
	CAILE C,"9"
	 POPJ P,
	TLZ A,400000		;turn off hi bit on digit
	IMULI A,10
	ADDI A,-"0"(C)
	JRST ALLNUM+1

ALLPDL:	BLOCK 10

ALLOC:	MOVEI P,ALLPDL-1
IFN TENEX, <			;LISP.SAV SIZE LT DESIRED STARTING SIZE.
	MOVEI	A,INITCORE
	CAMG	A,JOBREL
	 JRST	.+3		;IF JOBREL.GT.INIT, DON'T REDUCE CORE.
	CALLI	A,CORE
	 HALT
	   >
	MOVE A,JOBREL	
	HRRZM A,JRELO
	HRLM A,JOBSA
IFN TENEX, <
	OUTSTR [ASCIZ /
TOTAL K-CORE= /]
	MOVEI	A,^D10
	HRRM	A,ALLNUM+10	;CHANGE INPUT RADIX TO DECIMAL.
	PUSHJ	P,ALLNUM
	JUMPLE	A,ALLTNX
	ADDI	A,INUM0
	PUSHJ	P,TCORE
	MOVE	A,JOBREL
	HRRZM	A,JRELO
	HRLM	A,JOBSA
ALLTNX:	MOVEI	A,^D8
	HRRM	A,ALLNUM+10	;CHANGE BACK TO OCTAL
	   >
	CALLI RESET
IFN TENEX, <
	HRRZI	1,1		;MATCH EXACTLY
	HRROI	2,[ASCIZ/LISP/	;(PERHAPS SHOULD PEEK FOR 'SYS:(LISP.LSP)' EARLY).
		   0]		;(LEAVE ROOM FOR LONGER DIR-NAME PATCH).
	STDIR
	 JFCL
	 GJINF			;IN DESPERATION, USE HIS LOGIN DIR #.
	HRRZM	1,SYSNUM
	OUTSTR	[ASCIZ /
CHANGE SYS: /]
	PUSHJ	P,ALLNUM
	SKIPLE	A
	 HRRM	A,SYSNUM
	   >
	OUTSTR [ASCIZ /
ALLOC? /]
	INCHRW C
	CAIGE C,"O"
	JRST ALLC00
	OUTSTR [ASCIZ /
FULL WDS=/]
	PUSHJ P,ALLNUM
	SKIPGE A
	MOVEI A,400
	HRRM A,ALLC02
	OUTSTR [ASCIZ /
BIN.PROG.SP=/]
	PUSHJ P,ALLNUM
	SKIPGE A
	MOVEI A,2000
	HRRZM A,SBPS
	OUTSTR [ASCIZ /
SPEC.PDL=/]
	PUSHJ P,ALLNUM
	SKIPGE A
	MOVEI A,1000
	HRRM A,ALLC20
	MOVNS A
	HRRM A,ALLC21
	OUTSTR [ASCIZ /
REG. PDL=/]
	PUSHJ P,ALLNUM
	SKIPGE A
	MOVEI A,1000
	HRRM A,ALLC30
	OUTSTR [ASCIZ /
HASH=/]
	PUSHJ P,ALLNUM
	CAIG A,BCKETS
	JRST ALLC00
	HRRM A,INT1
	MOVNS A
	HRRM A,RH4
	SETOM HASHFG
ALLC00:	MOVEI A,DEBUGO
	HRRM A,JOBREN
	MOVEI A,LISPGO
	HRRM A,JOBSA
	OUTSTR [ASCIZ /
/]
	MOVEI A,FS
IFN VBP,< PUSHJ P,FIX1A >
	ADDM A,VBPORG
IFN VBP,< MOVEI A,FS >
	ADD A,SBPS
	HRRZM A,FSO
	SOS A
IFN VBP,< PUSHJ P,FIX1A >
	ADDM A,VBPEND	;(IFN TENEX, VBPEND IS 0 AT LOAD TIME).
	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