TITLE	LISP INTERPRETER	3A(1)-2
	SUBTTL	NOTES TO SYSTEM PROGRAMMERS		

;%%	VERSION DEFINITIONS:

	LSPWHO==2	;%% UCI 
	LSPVER==3	;%% MAJOR VERSION
	LSPMIN==1	;%% MINOR VERSION
	LSPEDT==1	;%% EDIT LEVEL

;	ASSEMBLY SWITCHES OF INTEREST
;
;	SWITCH		EXPLANATION,  COMMENTS  ETC.
;	ALTMOD		FOR ALTMODE CHARACTER. OLD WAS 175
;			NOW IT'S 33 FOR 506
;	QALLOW		ENABLES  ACCESS  TO QMANGR, ONLY  IF YOUR
;			SYSTEM SUPPORTS QUEUE. SEVERAL SWITCHES 
;			ASSOCIATED WITH  THE  CODE
;	OLDNIL		OLD STANFORD NIL. CODE TO MAKE CAR AND CDR
;			OF NIL INCOMPLETE AS OF 8/30/73
;	NONUSE		OLD STANFORD VERSIONS  OF  MEMQ, AND  ETC.
;			THAT  RETURNED  T OR NIL.
;	REALLC		PROGRAM-CONTROLLED DYNAMIC REALLOCATION
;			ROUTINE AND RELATED FUNCTIONS
;	SYSPRG		PROJECT NUMBER IF NOT ON SYS:.
;	SYSPN		PROGRAMMER NUMBER IF NOT ON SYS:
;	SYSDEV		DEVICE LOCATION OF SYSTEM.
;			NOTE THAT  THE ABOVE THREE ARE WHERE LISP
;			EXPECTS  TO  FIND THE  LOADER,THE
;			SYMBOL TABLE AND THE NORMAL HI-SEGMENT.
;			THE FUNCTION (SETSYS ...) ONLY CHANGES THE
;			EXPECTED LOCATION OF THE HI-SEG
;%%	SYSNAM		NAME OF EXPECTED HIGH SEGMENT
;%%			AND LISP LOADER AND SYMBOL TABLE
;%%	INUMIN		LOWEST ADDRESS AVAILABLE FOR USE AS
;%%			AN INUM
;%%	BCKETS		NUMBER OF HASH BUCKETS
;%%	SHRST		LOWEST ADDRESS IN HIGH SEGMENT
;%%	SYSUNV		SEARCH SYSTEM UNIVERSAL LIBRARIES

;	**USE  FOLLOWING AT OWN  RISK**

;	HASH		NUMBER OF  HASH BUCKETS  WHEN STARTING
;	ALVINE		STANFORD EDITOR (WHO WOULD WANT IT?)
;			1 FOR ALVINE, 0 FOR NO ALVINE
;	STPGAP		ANOTHER  STANFORD  EDITOR

;	COMMENTS:
;
;	THERE ARE BASICALLY TWO SETS OF COMMENTS IN THE CODE:
;	THOSE IN LOWER CASE ARE ORIGINAL STANFORD COMMENTS; 
;	THOSE OF A SEMI-COLON FOLLOWED BY TWO $'S,
;	TWO #'S, OR TWO %'S ARE UCI ADDITIONS,
;	CHANGES, OR ADDITIONAL COMMENTS
;	($'S ARE USUALLY DARYLE LEWIS, 
;	#'S ARE GENERALLY JEFF JACOBS,
;	AND %'S ARE GENERALLY BILL EARL).


	PAGE
		SUBTTL AC DEFINITIONS AND EXTERNALS 		


	IFNDEF	SYSUNV,<SYSUNV==1>	;[1]

IFNDEF	SHRST		<SHRST==400000>	;[1]

	TWOSEG	SHRST	;[1]

IFN SYSUNV,<	;[1]
	SEARCH	MACTEN
	SEARCH	UUOSYM		;[1]

.JBVER==137		;%% SYSTEM VERSION LOCATION	;[1]

	LOC	.JBVER	;%% SET STANDARD SYSTEM VERSION	;[1]
	VRSN.	(LSP)	;%% GENERATE VERSION>	;[1]

	RELOC	SHRST	;[1]

	OLDNIL==1		;## NOT COMPLETE

IFNDEF	NONUSE		<NONUSE==0>
IFN	SHRST-400000	<QALLOW==0>
IFNDEF	QALLOW		<QALLOW==1>
IFNDEF	REALLC		<REALLC==0>	;%% NORMALLY OFF TO SAVE SPACE
					;%% CHANGE FOR EXTENDED SYSTEM
;SYSPRG==667	;PPN OF LISP SYSTEM - SET TO 0 FOR SYS:
;SYSPN==2	;SAME HERE
IFNDEF SYSPRG,<SYSPRG==0
	       SYSPN==0>
IFNDEF	SYSPN,<SYSPN==1>
;ALVINE==1		;1 FOR ALVINE, 0 FOR NO ALVINE
IFNDEF ALVINE,<ALVINE==0>
;HASH==1		;1 FOR SETTING # OF HASH BUCKETS AT SYS. INIT. TIME
IFNDEF HASH,<HASH==0>
;STPGAP==1		;1 FOR STOPGAP, 0 TO DELETE IT
IFNDEF STPGAP,<STPGAP==0>
IF1,<PURGE CDR,DF>
MLON
IFNDEF	INUMIN, <INUMIN=SHRST-1> ;%% [1]
INUM0=777777-<<777777-INUMIN>/2> ;%% [1]
IFNDEF BCKETS,<BCKETS==177>
IFE SYSPRG,<
	IFNDEF	SYSDEV<DEFINE SYSDEV <SIXBIT /SYS/>>
		>
IFN SYSPRG,<
	IFNDEF	SYSDEV<DEFINE SYSDEV <SIXBIT /DSK/>>
		>
IFNDEF SYSNAM,<DEFINE SYSNAM <SIXBIT /LISP/>>

;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	
S=11		;$$NOW USED FOR ATOM RELOCATION AND GARBAGE COLLECTOR
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

;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 SKPINC [TTYUUO 13,]
OPDEF SKPINL	[TTCALL 14,]	;## BETTER FOR TALK THAN SKPINC
OPDEF TALK [PUSHJ P,TTYCLR]	;## TURN OF CONTROL O

;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

;channel data
CHNAM==0	;name of channel
CHDEV==1	;name of device
CHPPN==2	;ppn for input channel
CHOCH==3	;oldch for input channels
IFN STPGAP,<
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
>
IFE STPGAP,<
CHDAT==4
POINTR==5
COUNT==6
>
CHLL==2		;linelength for output channel
CHHP==3		;hposit for output channels

;special ASCII characters
IFNDEF ALTMOD,<ALTMOD==33>
SPACE==40	;space
IGCRLF==31	;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

;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
EXTERNAL JOBOPC ;$$FOR NEW REENTER FEATURES
EXTERNAL JOBHRL ;HIGH SEGMENT BOUNDARY


;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

;RE-ENTER CONTROL CHARACTERS
CNTLH==10
CNTLE==5
CNTLB==2
CNTLZ==32
CNTLG==7
CNTLR==22	;CH TO RESTORE SYSTEM OBLIST 3/28/73

;system uuos
APRINI==16
RESET==0
STIME==27
DEVCHR==4
EXIT==12
CORE==11
SETUWP==36
GETSEG==40
;REMOTE MACRO

	DEFINE REMOTE (TX)
<	HERE1 <TX>>

	DEFINE HERE1 (NEW,OLD,%G)
<	DEFINE %G
<	NEW>
	DEFINE REMOTE (TX)
<	HERE1 <TX>,<OLD
%G
>>>
	DEFINE HERE
<	DEFINE HERE1 (XX,YY)
<	YY>
	REMOTE>
SALL
	PAGE

		SUBTTL TOP LEVEL AND INITIALIZATION  

REMOTE<
LISPGO:	SKIPE	GCFLG	;$$CHECK FO GARBAGE COLLECTION
	PUSHJ	P,GCING	;$$QUEUE THE REQUEST
	CAME	0,STNIL	;$$UNBIND STACK IF REGS LOOK OK
	JRST	GETHGH	;GO GET HIGH SEGMENT
	MOVE	B,SC2
	PUSHJ	P,UBD	;$$UNBIND STACK
	JRST STRT	;go to re-allocator
GETHGH:	CALLI	RESET
	MOVSI	A,1
	CALLI	A,CORE		;ELIMINATE ANY OLD HIGH SEGS.
	HALT
	MOVEI	A,HGHDAT
	CALLI	A,GETSEG	;GET THE PROPER HIGH SEG
	HALT
	MOVEI	A,DEBUGO	;SET THE REE ADDRESS
	HRRM	A,JOBREN
	JRST	STRT		;GO TO ALLOCATE STORAGE
HGHDAT:	SYSDEV
	SYSNAM
	0
	0
	XWD	SYSPRG,SYSPN
	0>


DDT:	SETOM	ERINT	;$$SET CONTROL H WITHOUT GOING THRU REE
	JRST	@JOBOPC	;$$AND CONTINUE

DEBUGO:	SKIPE	GCFLG#	;CHECK GARBASE COLLECT.
	PUSHJ	P,GCING	;QUEUE INTERRUPT
	INCHRW	0	;READ THE CONTROL CHARACTER
	CAIN	0,CNTLR
			; RESTORES SYSTEM OBLIST
	JRST	[HRRI	0,OBTBL(S)
		 HRRM	0,VOBLIST(S)
		 JRST	DEBUGO+2]
			; AND TRIES FOR ANOTHER CONTROL CHARACTER
	CAIN	0,CNTLH
	JRST   [MOVE 0,STNIL
		JRST DDT]
	CAIN	0,CNTLE
	JRST   [MOVE 0,STNIL
		MOVEI 1,NIL
		JRST ERR]
	CAIN	0,CNTLB
	JRST   [MOVE 0,STNIL
		SETOM ERINT
		PUSHJ P,SPDLPT
		PUSHJ P,SPREDO
		JRST LSPRET]
	CAIN	0,CNTLZ
	JRST   [MOVE 0,STNIL
		JRST LSPRET]
	CAIN	0,CNTLG
	JRST   [MOVE 0,STNIL
		JRST RERX]
	JRST	DEBUGO+2	;NOT A CONTROL CHARACTER
				;MUST BE SOMETHING IN THE BUFFER SO TRY AGAIN

START:	CALLI RESET	;random initializations for lisp interupts
	MOVE [JSR UUOH]
	MOVEM JOB41
	MOVEI APRINT
	MOVEM JOBAPR
	MOVEI APRFLG
	CALLI APRINI
	SETZM GCFLG
	HRRZI 17,1
	IFN ALVINE,<SETZB 0,PSAV1>
	IFE ALVINE,<SETZ 0,>
	BLT 17,17	;clear acs 
	MOVE S,ATMOV	;$$SET UP RELOCATION FOR INTERNAL ATOMS (FOOLIST)
LSPRT1:	SETZM	BIOCHN(S)	;$$CLEAR VARS FOR BREAK PACKAGE
	SETZM	BPMPT(S)	;$$(#%IOCHNAS%#, #%PROMPTS%#, AND #%INDENT)
	MOVEI	A,INUM0
	MOVEM	A,BINDNT(S)
	SETZM	ERINT#	;$$TURN OFF INTERRUPT FLAG
	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


	MOVE A,LSPRMP#	;$$INITIALIZE TO TOP LEVEL PROMPT
			;$$CAN BE CHANGED BY INITPROMPT
	PUSHJ P,PROMPT	;$$

	SETZM	SMAC	;$$CLEAR SPLICE LIST (JUST IN CASE)
	MOVE S,ATMOV	;$$SET UP RELOCATION FOR INTERNAL ATOMS (FOOLIST)
	PUSHJ P,TTYRET	;(outc nil t)(inc nil t)return output for gc message
IFN OLDNIL	<HRROI	0,CNIL2(S)>	;INITIALIZE  NIL
IFE OLDNIL	<SETZ	0,	>
	MOVEM 0,STNIL#		;$$SAVE FOR REG CHECK AT START TIME
	MOVEI	A,CNIL2(S)	;## GET PROP  LIST  OF NIL
	MOVEM	A,NILPRP#	;##  AND SAVE IT FOR  GET ETC.

IFN HASH,<
	SKIPE HASHFG#
	JRST REHASH	;rehash if necessary>

	SKIPN F	
	PUSHJ P,AGC	;garbage collect only if necessary
	SKIPN BSFLG#	;initial bootstrap for macros
	JRST BOOTS
	SKIPE A,INITF
	CALLF (A)	;evaluate initialization function
	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:	MOVE S,ATMOV#	;$$MAKE SURE REL STAYS
				;$$SET UP - BELT AND SUSPENDERS TECHNIQUE
	PUSHJ P,READ	;this is the top level of lisp
	PUSHJ P,EVAL
	PUSHJ P,PRINT
	PUSHJ P,TERPRI
	JRST LISP1

INITFL:	EXCH	A,INITF1#	;## NEW INIT FILE LIST
	POPJ	P,		;## RETURN THE OLD ONE

INITFN:	EXCH A,INITF#
	POPJ P,

;return from lisp error
LSPRET:	PUSHJ P,TERPRI
	MOVE B,SC2	;RETURN FROM BELL
	PUSHJ P,UBD	;unbind specpdl
	JRST LSPRT1

.RSET:	EXCH A,RSTSW#
	POPJ P,

COMMENT %
	;## OLD BOOTSTRAP CODE FOR INIT FILE, REPLACED BELOW
;BOOTSTRAPPER FOR USER'S INIT FILE
BOOTS:	SETOM BSFLG
	MOVE A,[POINT 7,[ASCII /(ERRSET[INC(INPUT DSK:(INIT.LSP]NIL)[(EVAL(READ]/]]
	MOVEM A,BOOPT#
	MOVEI A,BSTYI
	PUSHJ P,READP1
	PUSHJ P,EVAL
	JUMPE A,BOOTOT
	MOVEI A,BSTYI
	PUSHJ P,READP1
	PUSH P,A
	MOVE A,(P)
	PUSHJ P,ERRSET
	CAIE A,$EOF$(S)
	JRST .-3
BOOTOT:	PUSHJ P,EXCISE
	JRST ERR

BSTYI:	ILDB A,BOOPT
	POPJ P,
	%

	;## NEW IMPROVED BOOTSTRAPPER FOR USER'S INITFILE(S)
	;## ALLOWS MORE THAN ONE FILE. FIRST FILE IS READ IN
	;## OR IF NOT FOUND BEHAVES AS BEFORE (I.E. NO ERROR MESSAGE)
	;## REMAINING FILES WILL CAUSE AN ERROR MESSAGE IF NOT FOUND.
	;## THUS IF THE USER IS USING THIS TO REALLY SET UP HIS OWN
	;## SYSTEM, HE WILL KNOW ABOUT A FAILURE, BUT THE FIRST
	;## FILES EXISTENCE IS STILL OPTIONAL

BOOTS:	SETOM	BSFLG#		;## INDICATE BOOTSTRAP DONE
	SKIPN	T,INITF1#	;## GET INIT FILE LIST IF IT EXISTS
	JRST	BOOTOT		;## NOPE, EXCISE AND RETURN
	MOVEI	A,TRUTH(S)	;## USE CHANNEL T
	PUSHJ	P,INPUT2	;## SET UP
	PUSHJ	P,ININIT	;## LOOK UP
	JUMPN	A,BOOTOK	;## IT'S THERE, GO TO IT
	JUMPE	T,BOOTOT	;## NOT THERE AND NO OTHERS REQUESTED
	PUSHJ	P,SETINA	;## SET UP FOR THE REST
	PUSHJ	P,ININIT	;## LOOK UP (SECOND FILE IN LIST)
	JUMPE	A,AIN.7		;## NOT THERE, ERROR MESSAGE
BOOTOK:	MOVEI	A,TRUTH(S)	;##(INC T NIL)
	SETZ	B,
	PUSHJ	P,INC		;## SELECT
	MOVEI	A,READAT(S)	;## SET UP [(EVAL (READ))]
	PUSHJ	P,NCONS		;## (READ)
	PUSHJ	P,NCONS		;## ((READ))
	MOVEI	B,EVALAT(S)
	PUSHJ	P,XCONS		;##(EVAL(READ))
	PUSHJ	P,NCONS		;## [(EVAL(READ))]
	PUSH	P,A
	MOVE	A,(P)
	PUSHJ	P,ERRSET	;## AN EVAL-READ LOOP. PROTECTED AGAINST
	CAIE	A,$EOF$(S)	;## ALL ERRS EXCEPT $EOF$ AND ERRORX
	JRST	.-3		;## LOOP
BOOTOT:	PUSHJ	P,EXCISE
	JRST	ERR
	PAGE
	SUBTTL APR INTERRUPT ROUTINES 
;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
	SUBTTL UUO HANDLER AND SUBR CALL ROUTINES 

UUOMIN==1
UUOMAX==4

REMOTE<UUOH:	X		;jsr location
		JRST	UUOH2>
UUOH2:	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)
	CAIN TT,SUBR(S)
	JRST @UUST(R)
	CAIN TT,FSUBR(S)
	JRST @UUFST(R)
	CAIN TT,LSUBR(S)
	JRST @UULT(R)
	CAIN TT,EXPR(S)
	JRST @UUET(R)
	CAIN TT,FEXPR(S)
	JRST @UUFET(R)
	HRRZ T,(T)
	JUMPN T,UUOH1
	PUSH P,A
	PUSH P,B
	HRRZ A,JOBUUO
	MOVEI B,VALUE(S)
	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!/]
	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
	HRRZ	D,UUOH
	CAIG	D,SHRST
	JRST	.+3
	SKIPE	WRTSTS
	JRST	.+3
REMOTE<UUOCL:	TLNN TT,2000>	;2000 means no clobber
	XCT	UUOCL
	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
	MOVEI B,CQUOTE(S)
	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
	MOVNS T
	DPB T,[POINT 4,JOBUUO,ACFLD]
	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)
	JRST	@UUOS7A	;OR ILIST
REMOTE<UUOS7A:	ARGPDL>

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

	PAGE
	SUBTTL ERROR HANDLER AND BACKTRACE 
;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
REMOTE<ERRSW:	-1>	;0 means no prnt on error		*
PAGE
;subroutine to search oblist for closest function to address in r
ERSUB3:
	MOVEI A,QST(S)
IFN OLDNIL<	HRROI NIL,CNIL2(S)>
IFE OLDNIL<	SETZ	NIL,	>

	HRLZ B,INT1
	MOVNS B
	SETZB AR2A,GOBF
	PUSH P,JOBAPR
	MOVEI C,[	SETOM GOBF
			JRST ERRO2G]
	HRRM C,JOBAPR
	HRRZ	C,VOBLIST(S)	;## GET CURRENT OBLIST
	HRRM	C,RHX5
	HRRM	C,RHX2		;## AND UPDATE LOCATIONS WHICH REF OBLIST
	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)
	CAIN AR1,LSUBR(S)
	JRST ERRO2H
	CAIE AR1,SUBR(S)
	CAIN AR1,FSUBR(S)
	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:	MOVEI A,APRFLG
	CALLI A,APRINI	;enable interupts
	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:	MOVE P,ERRTN	;IF IN ERRSET, RESTORE P TO THAT LEVEL
	SKIPN P
	MOVE P,C2	;else to top level
	SETOM UUO2#	;$$ AND DON'T ENTER ERRORX

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

;USER ENTRY TO ERROR HANDLER, PRINTS ARG IF NON-NIL
.ERROR:	JUMPE	A,ERREND
	SKIPN	ERRSW
	JRST	ERREND
	PUSHJ	P,ERRIO
	PUSHJ	P,TERPRI
	PUSHJ	P,PRINC
	JRST	ERREND
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:
IFN ALVINE,<
	SKIPE BACTRF
	PUSHJ P,BKTRC	;print backtrace
>
	PUSHJ P,OUTRET	;return to previous device
ERREND:	SETZ	A,		;## %CLRBFI USED TO BE HERE(FOR ERR NIL)
	SKIPN	UUO2		;$$NO ERRORX IF OVERFLOW ERROR
	JRST	.+3
	SETZM	UUO2		;$$RESET TO ZERO
	JRST	RERX		;$$BOUNCE BACK TO ERRORX
	SKIPN	RSTSW		;$$NEW *RSET FEATURE
	JRST	ERR		;$$IF (*RSET NIL) UNBIND AND GO TO TOP LEVEL
	SKIPN	ERRSW		;$$NO ERRORX IF NO MESSAGE
	JRST	ERR		;$$
	PUSHJ	P,%CLRBFI	;## CLEAR TTY BUFFER. ELIMINATE FLUSHING
				;##  OF TYPE AHEAD
	MOVEI	A,ERRORX(S)	;$$ELSE SET TO CALL ERROR HANDLER
	MOVEI	B,NIL		;$$CREATE FORM (ERRORX)
CEV:	PUSHJ	P,CONS		;$$
	JRST	EVAL		;$$AND EVALUATE IT


ERR:	SETZM	INHERR		;CLEAR RERX FLAG JUST IN CASE
	CAIN A,ERRORX(S)	;$$BOUNCE TO ERRORX IF A=ERRORX
	JRST RERX
ERR2:	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
	SKIPN	INHERR#
	JRST ERRP4	;and proceed

RERX:	SETZM	INHERR	;$$ POP TO A BREAK ERRSET
	MOVE	B,ERRSW
	CAIE	B,ERRORX(S)
	SETOM	INHERR
	JRST	ERR2

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
	SETZM INHERR	;CLEAR RERX FLAG
	JRST ERR1

SYSCLR:	SETZM BSFLG	;FUNCTION TO MAKE SYSTEM LOOK NEW
	SETZM	CONSVA	;## RESET CONS COUNT
	SETZM	GCTIM	;## RESET GC TIME
	JRST	EXCISE	;## EXCISE
PAGE
;error messages




RMERR:	MOVE A,T	;$$ BAD READ MACRO, GET THE NAME
	PUSHJ P,EPRINT	;$$
	ERR1 [SIXBIT /UNDEFINED READ MACRO!/]
BNDERR:	PUSHJ P,EPRINT		;$$ATTEMPT TO REBIND NIL OR T
	ERR1 [SIXBIT /CANNOT BE RE-BOUND!/]

RPAERR:	PUSHJ	P,EPRINT	;$$PRINT OUT OFFENDING ITEM
	ERR1 [SIXBIT /IS AN ATOM, CAN'T BE RPLACA'D!/]

RPDERR:	PUSHJ	P,EPRINT	;$$
	ERR1 [SIXBIT /CAN'T BE RPLACD'D (NIL OR INUM)!/]

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!/]
UNDTAC: HRRZ A,(C)
UNDTAG:	PUSHJ P,EPRINT
	ERR1 [SIXBIT /UNDEFINED FUNCTION - APPLY!/]
SETERR:	PUSHJ P,EPRINT		;$$BAD SET OR SETQ
	ERR1 [SIXBIT /CAN'T BE SET TO A VALUE - SET OR SETQ!/]
EG1:	PUSHJ P,EPRINT
	ERR1 [SIXBIT /UNDEFINED PROG TAG-GO!/]
EG2:	PUSHJ P,EPRINT
	ERR1 [SIXBIT /GO WITH NO PROG!/]
EG3:	ERR1 [SIXBIT /RETURN WITH NO PROG!/]
PAGE
IFN ALVINE,<

;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
	CAIGE A,FS(S)
	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,
	PAGE
	SUBTTL TYI  AND TYO  
;input
ITYI:	PUSHJ P,TYI	;## RETURN ASCII VALUE OF INPUT  CH
FIXI:	ADDI A,INUM0
	POPJ P,

TYI:	MOVEI AR1,1	;## TO TEST FOR LINED TYPESEQUENCE #, ETC
	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		;##  IF CH  IN OLDCH
	JRST	TYI1		;## TAKE CARE OF IT
TYID:	XCT	TYI2		;##  INPUT A CHARACTER
REMOTE<TYI2:	JRST TTYI>	;sosg x for other device input
	;other device input
	JRST TYI2X
TYI3B:	ILDB A,@TYI3#		;pointer
	XCT	TYI3A		;## SEE IF LINED TYPE WORD
REMOTE<TYI3A:	TDNN AR1,@X>	;pointer
	POPJ	P,		;## NO, OK

IFN STPGAP,<
	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 TYID

REMOTE<	TYI2X:	INPUT X,
	TYI2Y:	STATZ X,740000
		ERR1 AIN.8	;input error
	TYI2Z:	STATO X,20000
		JRST TYI3B	;continue with file
TYIEOF:		JRST	TYI2Q		;END OF FILE>
TYI2Q:	PUSH P,T
	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
	PUSHJ P,ININIT	;## INIT THE FILE
	JUMPE A,AIN.7	;## CAN'T FIND FILE, ERROR
	POP P,AR1
	POP P,R
	POP P,C
	POP P,T
	JRST TYI

TYI2E:	PUSHJ P,INCNT	;(inc nil t)
	TALK
	MOVEI A,$EOF$(S)	;we are done
	JRST ERR

IFN STPGAP,<
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>

REMOTE<	OLDCH:	0
IFN STPGAP,<
	PGNUM:	0
	LINUM:	0
		0>>	;zero to terminate num10

;TTYECHO - COMPLEMENTS THE TTY: ECHO BIT AND RETURNS T IF THE ECHO
;	   IS BEING TURNED ON AND NIL IF IT IS BEING TURNED OFF
;	 - TAKES NO ARGUMENTS
ECHO:	SETO	A,
	TTYUUO	6,A	;GET STATUS BITS
	TLC	A,4	;COMPLEMENT THE ECHO BIT
	TTYUUO	7,A	;RESTORE THE BITS
	TLNE	A,4	;TEST TO GET FINAL VALUE
	JRST	FALSE
	JRST	TRUE

;CLRBFI - CLEARS TTY INPUT BUFFER FOR USER ERRORS
;       - 0 ARGS AND RETURNS NIL
%CLRBFI:CLRBFI		;CLEAR BUFFER
	SETZM	SMAC	;CLEAR SPLICE LIST
	SETZM	OLDCH	;CLEAR LAST CHAR.
	JRST	FALSE
PAGE
;teletype input

ERRCH:	MOVEI	A,-INUM0(A)	;## CHANGE BELL CHARACTER
	EXCH	A,ERRCHR	;## RETURN OLD CHARACTER
	JRST	FIX1A		;## CONVERT IT

REMOTE	<
	ERRCHR:	BELL
	>

TTYI:	SKIPE DDTIFG		;## DDT MODE?
	JRST TTYID
	INCHSL A	;single char if line has been typed
	JRST 	[OUTCHR PROMCH#	;$$OUTPUT PROMPT CHARACTER		
		INCHWL A	;wait for a line
		JRST .+1]

TTYXIT:	CAME	A,ERRCHR	;## BELL, NEED NOT BE ^G
	POPJ	P,
IFN ALVINE,<
	SKIPE PSAV1#	;bell from alvine?
	JRST [	MOVE P,PSAV1	;yes, return to alvine
		JRST @ED1];$$DOUBLY IMPROVED MAGIC>
	MOVEI	A,NIL	;$$ RETURN NIL AS THE VALUE
	JRST	RERX	;$$ RETURN TO AN ERRORX ERRSET

TTYID:	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,


PROMPT:	SKIPN A
	SKIPA A,PROMCH
	MOVEI A,-INUM0(A)	;$$CHANGE FROM INUM
	EXCH A,PROMCH#		;$$CHANGE PROMPT CHARACTER AND RETURN OLD ONE
	MOVEI A,INUM0(A)	;$$CHANGE TO INUM
	POPJ P,	;$$


INTPRP:	SKIPN A
	SKIPA A,LSPRMP
	EXCH A,LSPRMP#		;$$ EXCHANGE FOR OLD TOP LEVEL PROMPT
	POPJ P,			;$$

READP:	SKPINC		;$$ T IFF A CHARACTER HAS BEEN TYPED
	JRST	FALSE	;$$ (DOES NOT CHECK OLDCH)
	JRST	TRUE

UNTYI:	MOVEI	B,-INUM0(A)	;$$ UN-READ A CHARACTER (PUT IT IN OLDCH)
	MOVEM	B,OLDCH
	POPJ	P,		;$$ RETURN ARG AS VALUE
PAGE
	;output
ITYO:	SUBI A,INUM0
	PUSHJ P,TYO
	JRST FIXI

TYO:	CAIG A,CR
	JRST TYO3
	SOSGE CHCT
	JRST TYO1
	JRST	TYOD
REMOTE<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

REMOTE<
LINL:	TTYLL
CHCT:	TTYLL>

;teletype output
TTYO:	OUTCHR A	;output single character in a
	POPJ P,
PAGE
REMOTE<DDTIFG:	TRUTH>
DDTIN:	EXCH A,DDTIFG
	POPJ P,


TTYRET:	PUSHJ P,OUTCNT
	JRST INCNT
;THIS IS THE NEW, FAST, AND SHORT ROUTINE TO TURN OFF CONTROL O
TTYCLR:	SKPINL	;## SKPINL FIXES RUBOUT PROBLEM IN TYPE AHEAD
	JFCL
	POPJ	P,

REMOTE<
TTOCH:	0
IFN STPGAP,<
	0	;tty page number  always zero
	0	;tty line number -- always zero
>
TTOLL:	TTYLL
TTOHP:	TTYLL>
	PAGE
	SUBTTL INPUT AND OUTPUT INITIALIZATION AND CONTROL 
;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

;##	SUBROUTINE TO TEST FOR A DEVICE OR QUEUE. USED BY I/O ROUTINES
;##	AND THE QUEUE ROUTINES. LEAVES A=0 IF NOT AN ATOM AND B=0
;##	DEVICE OR QUEUE.

DEVCHK:	PUSHJ	P,NXTIO		;## MAKE SIXBIT IF AN ATOM
	LDB	B,[POINT 6,A,35];## GET LAST CHAR
	CAIN	B,':'		;## DEVICE?
	TRZA	A,77		;## YES, CLEAR CHAR BUT LEAVE B INTACT
	SETZ	B,		;## NO, CLEAR B
	POPJ	P,		;## DONE, IF A=0 OR B=0, NOT A DEVICE

;##	SUBROUTINE TO PARSE THE I/O SPECIFICATION. DEFAULT IS DSK IF
;##	NO DEVICE SPECIFIED.
IOSUB:	MOVEM	T,DEVDAT#	;## SAVE ARG FOR ERRORS
	SKIPE	DEV		;## DEVICE ALREADY SPECIFIED?
	JRST	IOSUB1		;## YES, FORGET DEFAULT
	SETZM	PPN		;## CLEAR PPN
	MOVSI	A,'DSK'		;## STORE DSK AS DEFAULT
	MOVEM	A,DEV
IOSUB1:	PUSHJ	P,DEVCHK	;## SEE IF DEVICE SPECIFIED
	JUMPE	A,IOPPN		;## NON-ATOMIC ARG, MUST BE PPN OR (FILE.EXT)
	JUMPE	B,IOFIL		;## NOT A DEVICE, MUST BE FILE NAME
	SETZM PPN
IODEV2:	MOVEM A,DEV
IODEV3:	PUSHJ P,INXTIO
IOPPN:	JUMPN A,IOFIL	;not ppn or (fil.ext)
	PUSHJ P,PPNEXT
	JUMPN A,IOEXT	;(fil.ext)
	HLRZ A,(T)
	PUSHJ	P,CNVPPN	;## CONVERT PPN
	MOVEM	A,PPN
	JRST IODEV3		;%% DON'T ZAP DEVICE NAME FOR PPN

IOFIL:	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,
		;##  LEFT HALF OF  A CHANNEL TABLE ENTRY IS THE  REMAINING
		;## FILE LIST. RH POINTS TO EXTENDED HEADER.

REMOTE<
CHTAB=.-FSTCH
	BLOCK NIOCH>

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
	SETZ	D,	;SPECIAL RELOCATION - SEE LOAD
	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:	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 (R)
PAGE
INPUT1:	PUSHJ P,CHNSUB	;determine channel name
	MOVEI	AR1,(A)		;## SAVE CH NAME
	EXCH	AR1,(P)		;## EXHANGE WITH RETURN ADDR
	PUSH	P,AR1		;## AND STUFF THE RETURN ADDR. IN
INPUT2:	PUSHJ	P,TABSRC	;## GET PHYSICAL CHANNEL NUMBER
	MOVEM	A,CHANNEL	;## SAVE IT
	SETZM	DEV		;## CLEAR DEV SO THAT WE CAN
				;## DEFAULT IF APPROPRIATE
	JRST	SETIN1		;## SET UP FOR INITIALIZTION

INPUT:	PUSHJ	P,INPUT1
	PUSHJ	P,ININIT
INFAIL:	JUMPE	A,AIN.7		;## CAN'T FIND FILE
	JRST	POPAJ

BINPUT:	PUSHJ	P,INPUT1	;## IMAGE BINARY INPUT
	PUSHJ	P,BNINIT
	JRST	INFAIL

ISFILE:	JUMPE	A,.+5		;## ROUTINE TO TELL USER IF A FILE EXISTS
	PUSH	P,A		;## SAVE A IF NON-NIL
	MOVEI	A,(B)		;## GET THE FILE NAME
	PUSHJ	P,NCONS		;## (FILNAM)
	POP	P,B		;## GET THE DEVICE BACK
	PUSHJ	P,XCONS		;## (DEV FILNAM) OR (FILNAM) WHEN HERE
	PUSH	P,A		;## SAVE IT FOR RETURN
	PUSHJ	P,RENSUB	;## SEE IF IT'S THERE
	PUSH	P,A		;## SAVE THE ANSWER
	PUSHJ	P,RENCLR	;## CLEAR THE CHANNEL
	POP	P,A		;## ANSWER IN A
	JUMPN	A,POPAJ		;## IF NON-NIL, THEN IT'S THERE
	POP	P,B		;## POP ANSWER OFF
	POPJ	P,		;## AND RETURN NIL

RENSUB:	MOVEM	A,DEVDAT	;## SAVE IT FOR ERROR MSGS
	PUSHJ	P,GENSYM	;## DON'T CLOBBER CURRENT CHANNELS
	MOVE	T,DEVDAT	;## GET IT BACK
	PUSHJ	P,INPUT2	;## SET UP AND OPEN
	JRST	ININIT		;## AND INIT

RENAME:	PUSHJ	P,RENSUB	;## RENAME SETUP
	JUMPE	A,RENCLR	;## NIL IF CAN'T FIND FILE
	PUSHJ	P,SETINA	;## PROCESS THE NEW NAME
	XCT	RNAME		;## EXECUTE
	JRST	RENCLR		;## RETURN NIL IF FAILURE
	PUSHJ	P,RENCLR	;## CLEAR CHANNEL
	JRST	TRUE		;## AND RETURN T IF GOOD

REMOTE	<
RNAME:	RENAME	X,LOOKIN	;## RENAME FILE
	>
DELERR:	PUSHJ	P,AIOP
	PUSHJ	P,RENCLR	;## KILL THE CHANNEL
	ERR1	[SIXBIT /CAN'T DELETE FILE !/]

DELETE:	PUSHJ	P,RENSUB	;## FIRST SETUP(ALLOWS DEFAULT TO DSK:)
	JRST	.+2		;## ALREADY INIT'ED
DELET1:	PUSHJ	P,ININIT	;## INIT AND LOOKUP
	JUMPE	A,DELET2	;## IF FILE NOT THERE IGNORE
	SETZM	LOOKIN		;## BLAST FILE NAME
	SETZM	EXT		;## AND EXTENSION
	XCT	RNAME		;## AND RENAME OUT OF EXISTENCE
	JRST	DELERR		;## RENAME FAILURE
DELET2:	JUMPE	T,RENCLR	;## DONE
	MOVEM	T,DEVDAT	;## SAVE REST OF LIST FOR MSGS.
	PUSHJ	P,SETINA	;## PROCESS NEXT FILE
	JRST	DELET1		;## AND DO IT AGAIN

RENCLR:	PUSH	P,CHANNEL	;## CLEAR CHANNEL
	SETO	B,		;## FAKE (INC RENCHANNEL T)
	PUSHJ	P,IOSEL		;## RELEASE THE CHANNEL
	JRST	POPAJ		;## RETURN NIL (IOSEL CHANGED THINGS)


	;## TO LOOK UP A UFD FOR DIRECTORY FNS. SUBR

UFDINP:	PUSH	P,A
	MOVEI	T,(B)
	PUSHJ	P,TABSRC
	MOVEM	A,CHANNEL	;## HAVE A CHANNEL
	MOVE	A,[XWD 'DSK','UFD']
	HRLZM	A,EXT
	HLLZM	A,DEV
	SETZ	B,
	AOBJP	B,.+1		;## UFD'S SHOULD BE ON [1,1]
	MOVEM	B,PPN
	SKIPN	A,T
	PUSHJ	P,MYPPN		;## IF B=NIL, DEFAULT TO USER'S PPN
	MOVEM	A,DEVDAT
	PUSHJ	P,CNVPPN	;## CONVERT PPN
	SETZ	T,		;## ZAP T (NO MORE FILES)
	PUSHJ	P,SETIN2	;## SETUP 
	PUSHJ	P,BNINIT	;## INIT AS BINARY
	JUMPE	A,ERR		;## ERR NIL IF NOT THERE
	PUSHJ	P,ININBF	;## SET UP BUFFERS
	JRST	POPAJ		;## RETURN CHANNEL
MYPPN:	GETPPN	A,		;## GET PPN
	CAI			;## WIERD SKIP RETURN ON THIS UUO
	HLRZ	C,A		;## ASSUME PPN'S ARE INUMS
	HRRZI	A,INUM0(A)	;## CONVERT
	PUSHJ	P,NCONS	
	HRRZI	B,INUM0(C)
	JRST	XCONS		;## (PROJ PRGRM)

CNVPPN:	MOVS	A,(A)		;## ASSUME PPNS INUMS
	HRRI	A,-INUM0(A)	;## LH=CDR, RH=CAR
	MOVSS	A		;## SWAP HALVES
	HLR	A,(A)		;## RH=CADR NOW
	HRRI	A,-INUM0(A)
	POPJ	P,


SETINA:	MOVE	A,CHANNEL	;## FOR ROUTINES THAT PROCESS MORE
	HRRZ	C,CHTAB(A)	;## AND KEEP THE CHANNEL IN CHANNEL

SETIN:	MOVEM A,CHANNEL
	MOVE A,CHDEV(C)
	MOVEM A,DEV
	MOVE A,CHPPN(C)
	MOVEM A,PPN
SETIN1:	PUSHJ P,IOSUB	;get device and file name
SETIN2:	MOVEM A,LOOKIN	;file name
	MOVE A,DEV
	MOVEM	A,BDEV		;## ALLOW IMAGE BINARY MODE
	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,BNINIT,ACFLD]	;## FOR IMAGE BINARY
	DPB A,[POINT 4,RNAME,ACFLD]	;## FOR RENAME
	DPB A,[POINT 4,INLOOK,ACFLD]
	DPB A,[POINT 4,ININBF,ACFLD]
	HLLZS	EXT		;%% CLEAR RIGHT HALF
	SETZM	LOOKIN+2	;%% CLEAR THIRD WORD
	HRRZ B,CHTAB(A)
	HRLM T,CHTAB(A)		;save remaining file name list
	MOVEI A,CHDAT(B)
	MOVEM A,DEV1		;pointer to bufdat
	MOVEM	A,BDEV1		;## IMAGE BINARY MODE
	POPJ	P,		;## SET UP FOR INITIALIZTION
REMOTE<

BNINIT:	INIT	X,13		;## INIT DEVICE IN IMAGE BINARY
BDEV:	X
BDEV1:	X
	JRST	AIN.7		;## CAN'T INIT
	JRST	INITOK
ININIT:	INIT X,
DEV:	X
DEV1:	X
	JRST AIN.7		;cant init
INITOK:	PUSH B,DEV
	PUSH B,PPN
INLOOK:	LOOKUP X,LOOKIN
	JRST	FALSE		;## LET SOMEONE ELSE HANDLE THE ERROR
	JRST IRET1>

IRET1:	PUSH B,[0]	;oldch

IFN STPGAP,<
	PUSH B,[0]	;line number
	PUSH B,[0]	;page number
	>

	ADDI B,4
	HRRM B,JOBFF
	JRST	ININBF

REMOTE<
ININBF:	INBUF X,NIOB
	JRST	TRUE	;## RETURN FROM GOOD LOOKUP WITH T


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
	SETZM	DEV	;## CLEAR DEV FOR DEFAULT TO DSK:
	PUSHJ P,IOSUB	;get device and file name
	MOVEM A,ENTR	;file name
	HLLZS	ENTR+1	;%% CLEAR RIGHT HALF
	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
	JRST AOUT2
REMOTE<
AOUT2:	INIT X,
AOUT3:	X
	X
	JRST AOUT.4	;cant init
	PUSH B,DEV
OUTENT:	ENTER X,ENTR
	JRST OUTERR	;cant enter
	JRST ORET1>
ORET1:	PUSH B,[LPTLL]		;linelength
	PUSH B,[LPTLL]		;chrct
	IFE STPGAP,<	ADDI B,4>
	IFN STPGAP,<	ADDI B,6>
	HRRM B,JOBFF
	XCT OUTOBF
REMOTE<
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
IOSEL1:	DPB C,[POINT 4,RLS,ACFLD]
	XCT RLS
REMOTE<
RLS:	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(S)

INC:	PUSH P,INCH#
	PUSHJ P,IOSEL
	JUMPN B,INC2	;released channel
	SKIPN C
	MOVEI C,TTOCH-CHOCH	;tty deselect
IFN STPGAP,<
	MOVEI B,CHOCH(C)
	HRLI B,OLDCH
	BLT B,CHLINE(C)		;save channel data
>
IFE STPGAP,<
	MOVE B,OLDCH
	MOVEM B,CHOCH(C)
>
	JRST	INC2+1
INC2:	SETZM	INCH		;CLEAR CHANNEL NOW IN CASE OF BREAK
	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:
IFN STPGAP,<
	MOVSI B,CHOCH(A)
	HRRI B,OLDCH
	BLT B,LINUM	;restore channel data
>
IFE STPGAP,<
	MOVE B,CHOCH(A)
	MOVEM B,OLDCH
>
	MOVEM T,TYI2
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)
	JRST	OUTC2+1
OUTC2:	SETZM	OUTCH		;CLEAR CHANNEL NOW IN CASE OF BREAK
	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
	PAGE
	SUBTTL	QMANGR INTERFACE

;## 	CODE TO ALLOW LISP USER'S TO CALL DEC'S  QMANGR, ALLOWING
;## 	PRINTING OF FILES AND CREATION OF JOBS
;## 	SCANS ARG LIST SETTING UP THE APPROPRIATE PARAMETERS. IT
;## 	SAVE THE PDLS, SWAPS HI-SEGS FOR SYS:QMANGR AND
;## 	DOES A PUSHJ TO 400010. IT ALSO CHANGES JOBREN SO
;## 	THAT THE USER CAN RECOVER IN CASE OF QMANGR ERRORS.
;## 	ST WILL ALSO STILL WORK. REG 17 (SP) IS USED AS QMANGR'S
;## 	PDL. CORE IS CONTRACTED AFTER RETURN FROM QMANGR AND QUEUE
;## 	RESTORES APPROPRIATE REGS AND RETURNS NIL. ALTHOUGH
;## 	CODE FOR EXTENDED SWITCHES IS INCLUDED, MOST OF
;## 	IT IS TURNED OFF. USE AT YOUR OWN RISK. NOTE THAT
;## 	/LIST, /AFTER AND /DEAD REQUIRE SPECIAL CODE
;## 	THAT IS NOT INCLUDED. SEE APPROPRIATE
;## 	DEC DOCUMENTATION FOR FURTHER INFO. 6/12/73


IFN QALLOW <
	IFNDEF	QSWEXT	<QSWEXT=0>	;## IF NOT DEFINED THEN DEFAULT IS NO EXTENDED 
	IFE	QSWEXT	<NSWS==QTABL1>;## NUMBER OF ALLOWED SWITCHES
	IFN	QSWEXT	<NSWS==QTABL2>;## LENGTH OF EXTENDED TABLE
	IFNDEF	QLSTOK	<QLSTOK==0>
	IFNDEF	QTIME	<QTIME==0>


	;%% THE FOLLOWING CODE IS AN ILLUSTRATION OF HOW
	;%% EASY IT IS TO LOSE TRYING TO INTERFACE TO
	;%% DEC SOFTWARE.  THE FOLLOWING DEFINITIONS ALLOW
	;%% TOO FEW WORDS FOR THE CURRENT FILE PARAMETER 
	;%% AREA; SEE THE DEFINITIONS AS COPIED FROM
	;%% THE QMANGR SOURCE BELOW.
	COMMENT &
	INPPAR==32	;## NUMBER OF WORDS IN INP AREA FOR INPUT REQUEST
	OUTPAR==24	;## NUMBER WORDS IN MAIN AREA FOR OUTPUT REQUEST
	DIFPAR==INPPAR-OUTPAR	;##  DIFFERENCE IN LENGTHS FOR MAIN AREA TYPES
	FILPAR==14	;## NUMBER WORDS IN FILE PARAMTER AREA




			;## LOCATIONS IN PARAMETER AREAS
	;## MAIN AREA
	Q.MEM==0		;## MEMORY FOR QMANGR
	Q.OPR==1		;## REQUESTED OPERATION
	Q.LEN==2		;## RH=NUMBER OF FILES IN REQUEST
	Q.DEV==3		;## REQUESTED QUEUE
	Q.PPN==4		;## PPN REQUESTING
	Q.JOB==5		;## JOB NAME
	Q.SEQ==6		;## JOB SEQUENCE #
	Q.PRI==7		;## EXTERNAL PRIORITY
	Q.PDEV==10		;## 
	Q.TIME==11		;## 
	Q.CREA==12		;## 
	Q.AFTR==13		;## AFTER PARAMETER
	Q.DEAD==14		;## DEADLINE PARAMETER
	Q.CNO==15
	Q.USER==16		;## AND 17
	;## INPUT SECTION OF MAIN PARAMETER AREA
	Q.IDEP==20			;## RESTART AND DEPENDENCY PARAMTERS
	Q.ILIM==21		;## CORE AND CPU, +1 IS LPT LIMIT AND CDP LIMIT
				;## +2 IS PTP LIMIT AND PLOT LIMIT
	Q.IDDI==24		;## THRU 31
	Q.IEND==31		;## LAST LOC OF INP AREA
	;## OUTPUT SEECTION OF MAIN PARAMETER AREA
	Q.OFRM==20		;## FORM PARAMTER
	Q.OSIZ==21		;## LH=LIMIT
	Q.ONOT==22
	Q.OEND==23		;## LAST LOC OF OUTPUT AREA
	;## FILE PARAMETER AREA (ONE FOR EACH FILE)
	Q.FSTR==0		;## FILE STRUCTURE
	Q.FDIR==1		;## THRU 6, DIRECTORY
	Q.FNAM==7		;## FILE NAME
	Q.FEXT==10		;## FILE EXTENSION
	Q.FRNM==11		;## RENAME NAME (0)
	Q.FBIT==12	
	Q.FMOD==13		;## SPACING, FILE DISPOSAL, COPIES
	&			;%% END OF DELETED DEFINITIONS

	;%% THE FOLLOWING ARE AS COPIED FROM QMANGR (VERSION 34)
	;%% ON 24 OCTOBER 1973

	QDEFST==.		;%% WHERE TO RELOC TO AFTERWARDS
	RELOC	0		;%% TO SAVE CORE AND AVOID CONFUSION
				;%% COMMENTS BELOW ARE AS COPIED 
				;%% FROM QMANGR
	PHASE	0
Q.ZER:!			;START OF QUEUE PARAMETER AREA
Q.MEM:!	 BLOCK	1	;HOLD XWD WINDOW BLOCK,WINDOW WORD INDEX
Q.OPR:!	 BLOCK	1	;OPERATION CODE
    QO.CRE==1		;CREATION OPERATION
    QO.LST==4		;LIST OPERATION
    QO.MOD==5		;MODIFY OPERATION
    QO.KIL==6		;KILL OPERATION
    QO.DEL==10		;DELETE OPERATION
    QO.REQ==11		;REQUEUE OPERATION
    QO.FLS==12		;FAST LIST OPERATION
Q.LEN:!	 BLOCK	1	;LENGTHS IN AREA
Q.DEV:!	 BLOCK	1	;DESTINATION DEVICE
Q.PPN:!	 BLOCK	1	;PPN ORIGINATING REQUEST
Q.JOB:!	 BLOCK	1	;JOB NAME
Q.SEQ:!	 BLOCK	1	;JOB SEQUENCE NUMBER
Q.PRI:!	 BLOCK	1	;EXTERNAL PRIORITY
Q.PDEV:! BLOCK	1	;PROCESSING DEVICE
Q.TIME:! BLOCK	1	;PROCESSING TIME OF DAY
Q.CREA:! BLOCK	1	;CREATION TIME
Q.AFTR:! BLOCK	1	;AFTER PARAMETER
Q.DEAD:! BLOCK	1	;DEADLINE TIMES
Q.CNO:!	 BLOCK	1	;CHARGE NUMBER
Q.USER:! BLOCK	2	;USER'S NAME

Q.I:!			;START OF INPUT QUEUE AREA
Q.IDEP:! BLOCK	1	;DEPENDENCY WORD
Q.ILIM:! BLOCK	3	;JOB LIMITS
Q.IL:!			;END OF AREA NEEDED TO READ FOR MASTER QUEUE
Q.IDDI:! BLOCK	6	;JOB'S DIRECTORY
Q.II:!			;START OF INPUT FILES AREA

	PHASE	Q.I
Q.O:!			;START OF OUTPUT QUEUE AREA
Q.OFRM:! BLOCK	1	;FORMS REQUEST
Q.OSIZ:! BLOCK	1	;LIMIT WORD
Q.OL:!			;END OF AREA NEEDED TO READ FOR MASTER QUEUE
Q.ONOT:! BLOCK	2	;ANNOTATION
Q.FF:!
	PHASE	0
Q.F:!			;DUPLICATED AREA FOR EACH REQUESTED FILE
Q.FSTR:! BLOCK	1	;FILE STRUCTURE
Q.FDIR:! BLOCK	6	;ORIGINAL DIRECTORY
Q.FNAM:! BLOCK	1	;ORIGINAL NAME
Q.FEXT:! BLOCK	1	;ORIGINAL EXTENSION
Q.FRNM:! BLOCK	1	;RENAMED FILE NAME (0 IF NOT)
Q.FBIT:! BLOCK	1	;BIT 0=PRESERVED BY QUEUE, REST=STARTING BIT
Q.FMOD:! BLOCK	1	;FILE SWITCHES
X.LOG==1B1	;FILE IS LOG FILE
X.NEW==1B2	;OK IF FILE DOESNT EXIST YET
Q.FRPT:!BLOCK	2		;/REPORT

Q.FLEN==.-Q.F
	DEPHASE
	PHASE	0
Q.FDRM:! BLOCK	6	;DIRECTORY MASK FOR MODIFY
Q.FNMM:! BLOCK	1	;FILE NAME MASK FOR MODIFY
Q.FEXM:! BLOCK	1	;EXTENSION MASK FOR MODIFY
Q.FMDM:! BLOCK	1	;MODIFIER MASK FOR MODIFY
Q.FMLN==.-Q.F	;LENGTH OF MODIFY BLOCK

	DEPHASE
	RELOC	QDEFST		;%% MAKE UP FOR INCREASE IN LOCATION 
				;%% COUNTER

	INPPAR==Q.II		;%% SIZE OF MINIMUM INPUT AREA
	OUTPAR==Q.FF		;%% SIZE OF MINIMUM OUTPUT AREA
	OUTPR1==OUTPAR-1	;%% MACRO DOESN'T LIKE EXPRESSIONS
	DIFPAR==INPPAR-OUTPAR	;%% DIFFERENCE IN AREAS
	FILPAR==Q.FLEN		;%% FILE DATA AREA
	LOWLEN==^D110		;## AREA NEED FOR PARAMETER
				;## AREA TO QMANGR
	LHLEN==OUTPR1*1B26+FILPAR ;## LH OF Q.LEN DEFAULTS
	NQS==6			;## NUMBER OF QUEUES


		;## QUEUE ERRORS

QILLSW:	HLRZ	A,(T)		;## GET SWITCH THAT  CAUSED ERROR
	PUSHJ	P,PRINT
	STRTIP	[SIXBIT /  =ILL. SWITCH SPEC.!/]
	PUSHJ	P,CONCOR	;## SAVE THAT CORE
QERR1:	ERR1	[SIXBIT /ERROR IN QUEUE REQUEST!/]



QUEUE:	SKIPN	T,A		;## ERROR IF NO ARGS
	JRST	QERR1
	PUSHJ	P,DEVCHK	;## SEE IF QUEUE SPECIFIED
	JUMPE	A,NOQUE		;## IF A=0 THEN NOT A QUEUE
	JUMPE	B,NOQUE		;## IF B=0 THEN NOT A QUEUE
	MOVE	AR2A,A
	HLRZ	B,A		;## GET FIRST THREEE LETTERS
	MOVEI	C,NQS		;## GET NUMBER OF PERMISSIBLE QUEUES
	SOJL	C,NOQUE		;## IF EXHAUSTED TABLE, THEN  NO QUEUE
	MOVE	A,QSTABL(C)	;## PERMISSIBLE QUEUES
	JSP	R,CHKGO		;## JUMP TO ROUTINE THAT COMPARES RH AND GO
				;## TO LH OF A IFF RH(A)=B
	JRST	.-3		;## LOOP



	;## TABLE OF PERMISSIBLE QUEUES AND WHERE TO GO ON EACH

QSTABL:	XWD	INPREQ, 'INP'
	XWD	OUTREQ,	'LPT'
	XWD	OUTREQ,	'PTP'
	XWD	OUTREQ,	'PTP'
	XWD	OUTREQ,	'CDP'
	XWD	OUTREQ,	'PLT'

OUTREQ:	TDZA	A,A		;## HERE TO PROCESS OUTPUT REQUEST(CLEAR A)
INPREQ:	MOVEI	A,DIFPAR	;## HERE TO PROCESS INPUT REQUEST
	JRST	QGOOD		;## FOUND A QUEUE
NOQUE:	MOVSI	AR2A,'LPT'	;## HERE IF NO QUEUE, DEFAULT=LPT
	TDZA	A,A		;## CLEAR A AND SKIP
QGOOD:	HRRZ	T,(T)		;## HERE IF QUEUE SPECIFIED
	ADDI	A,OUTPAR	;## A IS ZERO OR INPPAR
QSETUP:	PUSH	P,B		;## B CONTAINS THREE LETTERS(OR BLANK). SAVE IT
	HRLZI	TT,(A)		;## SAVE LNENGTH OF AREA
	PUSHJ	P,TEMCOR	;## EXPAND CORE
	HRRI	TT,(A)		;## START ADDR OF MAIN AREA
	MOVE	A,TT
	PUSHJ	P,CLRBLK	;## CLEAR AREA
	MOVEM	AR2A,Q.DEV(TT)
	MOVEI	C,LHLEN		;## GET LENGTHS FOR HEADER AND FILE AREAS
	MOVE	A,[XWD 500,500]
	HRLZM	A,Q.OSIZ(TT)	;## ASSUME OUTPUT HERE
	POP	P,B		;## RESTORE LEFT THREE LETTERS
	CAIE	B,'INP'		;## WAS IT AN INPUT REQUEST?
	JRST	QUEUE1		;## NO SHOULD  BE OK
	ADDI	C,DIFPAR_9	;## UPDATE HEADER LENGTH
	MOVEM	A,Q.ILIM+1(TT)	;## MAX PAGES AND CARD PUNCH
	MOVEM	A,Q.ILIM+2(TT)	;## MAX PAPER TAPE AND  PLOTTER
	HRLI	A,^D256
	MOVEM	A,Q.ILIM(TT)	;## MAX CORE AND CPU(CORMAX MAY HAVE TO BE
				;##  CHECKED HERE)
	MOVSI	A,400000	;## SET BIT 0 FOR NOT RESTARTABLE
	HLLZM	A,Q.IDEP(TT)	;## NOT RESTARTABLE(NO DEPEND OR UNIQUENESS)
QUEUE1:	MOVSM	C,Q.LEN(TT)	;## SET HEADER AND FILE AREA LENGTHS
	GETPPN	A,		;## SET REQUESTING PPN
	CAI			;## WEIRD SKIP RETURN ON THIS UUO
	MOVEM	A,Q.PPN(TT)
	SETZ	REL,		;## CLEAR REG FOR FILE AREA
	MOVEI	A,20	;## PRIORITY DEFAULT
	MOVEM	A,Q.PRI(TT)
	AOSA	Q.OPR(TT)	;## SET DEFAULT FOR REQUEST TYPE=/CREATE
	;##  BASIC LOOP FOR HANDLING THE SWITCHES

QLOOP:	HRRZ	T,(T)		;## HERE IF ROUTINE DID NOT MOVE ARG 
QSELF:	JUMPE	T,QDONE
	PUSHJ	P,DEVCHK	;## SEE IF DEVICE OR ATOMIC FILE NAME?
	JUMPN	B,QFILEA	;## IF B#0 THEN DEVICE
	JUMPN	A,QFILE		;## IF A#0 THEN ATOMIC FILE
	HLRZ	C,(T)		;## WELL, SEE IF SWITCH
	HRRZ	A,(C)		;## CDAR
	PUSHJ	P,ATOM		;## ATOM?
	JUMPN	A,QFILE		;## YES, THEREFORE(FILE.EXT)
	HLRZ	B,(C)		;## CAAR
	SUBI	B,(S)		;## STRIP OFF RELOCATION
	HRRZI	C,NSWS		;## GET NUMBER OF SWITCHES
QLOOP1:	SOJL	C,QFILE		;## IF NO SWITCH, GO QFILE
	MOVE	A,QTABLE(C)	;## GET MEMBER OF TABLE
	JSP	R,CHKGO
	JRST	.-3		;## LOOP


	;## DISPATCH TABLE FOR SWITCHES

QTABLE:
	PHASE 1
	XWD	QCOPIE,COPIES	;## /COPIES
	XWD	QCPU,CPU	;## /CPU
	XWD	QFORMS,FORMS	;## /FORMS
	XWD	QLIMIT,LIMIT	;## /LIMIT
QTABL1:	XWD	QDISP,DISP	;## /DISP (FILE DISPOSITION)

	;## EXTENDED SWITCHES

IFN QSWEXT   <
	IFE QLSTOK	<XWD QILLSW, LISTAT>
	IFN QLSTOK	<XWD QLIST, LISTAT>

	IFE QTIME <
	XWD	QILLSW,AFTER	;## /AFTER ILLEGAL (SEE ABOVE)
	XWD	QILLSW,DEAD	;## /DEAD (DEADLINE)
		>

	IFN QTIME <
	XWD	QAFTR,AFTER
	XWD	QDEAD,DEAD
		>
	XWD	QCORE,COREAT
	XWD	QMOD,MODIFY	;## /MODIFY
	XWD	QKILL,KILL	;## /KILL
	XWD	QJOB,JOB	;## /JOB
	XWD	QDEPND,DEPEND	;## /DEPEND
	XWD	QRSTR,RSTRT	;## /RESTART
	XWD	QUNIQ,UNIQUE	;## /UNIQUE
	XWD	QCORE,COREAT	;## /COREE
	XWD	QPAGES,PAGES	;## /PAGES
	XWD	QPLOT,PLOT	;## /PLOT
	XWD	QPTAPE,PTAPE	;## /PTAPE
	XWD	QCARDS,CARDS	;## /CARDS
	XWD	QSEQ,SEQ	;## /SEQ
	XWD	QPRIOR,PRIOR	;## /PRIOR (PRIORITY)
	XWD	QSPACE,SPACE	;## /SPACE (SPACING)
	XWD	QLIMIT,LIMIT	;## /LIMIT
QTABL2:	XWD	QHEAD,HEAD	;## /HEAD (HEADERS)
	>
	DEPHASE

	;##  DISPATCHING THE VARIOUS SWITCHES

IFN QSWEXT <QLIST:	HRRZI	A,4		;## HERE FOR LIST REQUEST
	CAIA
QMOD:	HRRZI	A, 5		;## /MODIFY
	CAIA
QKILL:	HRRZI	A, 6		;## /KILL
	HRRZM	A, Q.OPR(TT)
	JRST	QLOOP
	>

	;##  INPUT QUEUE ONLY SWITCHES
	;##  PUTS BYTE POINTER INTO  B  AND  THEN CHECKS TO SEE  IF SWITCH VALID IN
	;##  THIS CONTEXT (I.E. ARE WE PROCESSING AN INPUT REQUEST?)
	;##  IF NOT VALID, SKIPS THE SWITCH(MAY BE CHANGED LATER)

IFN QSWEXT <
QPLOT:	JSP	R,RINPCH
	AOJA	B, QCARD+1
QPTAPE:	JSP	R, LINPCH
	AOJA	B, .+4
QCARDS:	JSP	R, RINPCH
	AOJA	B, .+4
QPAGES:	JSP	R, LINPCH
	AOJA	B, .+4
	>

QCPU:	JSP	R, RINPCH
	AOJA	B,QARG


IFN QSWEXT <
QCORE:	JSP	R, LINPCH
	AOJA	B,QARG
QDEPND:	JSP	R, RINPCH
	JRST	QARG
	>

			;##  OUTPUT  QUEUE ONLY  SWITCHES
QFORMS:	JSP	R, OUTCHK
	PUSH	P,QSXARG	;## CONVERT ARG TO SIXBIT
	MOVEM	A, Q.OFRM(TT)	;## MAKE SIXBIT IF FORMS
	JRST	QLOOP
QLIMIT:	JSP	R, OUTCHK
	MOVE	B,LINP
	AOJA	B,QARG

OUTCHK:	HLRZ	A,Q.DEV(TT)	;## GET REQUEST TYPE (THREE LETTERS)
	CAIE	A,'INP'		;## ERROR IF INPUT REQUEST
	JRST	(R)
	JRST	QILLSW

QCOPIE:	JSP	R, FILECH	;## CHECK IF WE HAVE SET UP A FILE AREA
	MOVE	B,[POINT 6,Q.FMOD(REL),35]	;## BYTE POINTER
	JRST	QARG


		;## FOR DISPOSITION, 1=PRESERVE,  2=RENAME, 3=DELETE,
		;## FIRST THREE LETTERS OF ARG TO SWITCH   UNIQUELY  IDENTIFY
		;## ILLEGAL ARG CAUSES ERROR
QDISP:	JSP	R,FILECH	;## BE SURE FILE AREA SET UP
	PUSHJ	P,QSXARG	;## MAKE ARG SIXBIT
	HLRZ	C,A		;## GET FIRST THREE LETTERS
	SETZ	A,		;## CLEAR A
	CAIN	C,'DEL'		;## DELETE AFTER OUTPUT!
	AOJA	A,.+2		;## YES!
	CAIN	C,'REN'	;## RENAME FILE OUT OF UFD?
	AOJA	A,.+3
	CAIE	C,'PRE'		;## PRESERVE IT
	JRST	QILLSW		;## HERE IF BAD ARGUMENT
	ADDI	A,1
	MOVE	B, [POINT 3, Q.FMOD(REL), 29]
	JRST	QARG+1		;## ARG ALREADY IN A
				;## HERE WHEN SWITCH DETERMINED AND BITE POINTER IN B
QGTARG:	MOVEI	A,(T)
	PUSHJ	P,CADAR
	SUBI	A,INUM0		;## ARG SHOULD BE AN INUM
	POPJ	P,
QARG:	PUSHJ	P,QGTARG	;## GET ARGUMENT
	DPB	A,B		;## 
	JRST	QLOOP		;## ALWAYS RETURN TO QLOOP

			;## HERE TO SEE IF INP QUEUE FOR EXTENDED PART OF MAIN AREA

LINPCH:	MOVE	B,LINP		;## GET LH BITE POINTER
	CAIA
RINPCH:	MOVE	B,RINP		;## GET RH BITE POINTER
	HLRZ	A,Q.DEV(TT)	;## GET QUEUE SPEC
	CAIN	A,'INP'		;## INP?
	JRST	(R)		;## YES
	JRST	QILLSW
LINP:	POINT	18, Q.IDEP(TT),17		;## BYTE POINTER FOR LEFT HALF OF EXTENDED MAIN AREA
RINP:	POINT	18, Q.IDEP(TT),35		;## BYTE POINT FOR RH OF EXTENDED MAIN AREA


			;## HERE TO BE SURE FILE AREA HAS BEEN SET UP

FILECH:	JUMPN	REL,(R)		;## REL NONZERO IF FILE AREA SET UP
	PUSH	P,R
	JRST	FILARE
			;## HERE TO FIND FILE SPECIFICATION


QFILEA:	HRRZ	T,(T)		;## GET CDR
	SETZ	B,		;## CLEAR B
	JRST	QFILEB
QFILE:	MOVSI	A,'DSK'		;## DEFAULT IS DSK
	CAIE	REL,0		;## AREA SET UP?
	SKIPA	A,Q.FSTR(REL)	;## GET CURRENT DEVICE
	SKIPA	B,Q.PPN(TT)	;## GET USER'S PPN IF NOT SET UP
	MOVE	B,Q.FDIR(REL)	;## GET CURRENT PPN
QFILEB:	MOVEM	B,PPN		;## SET PPN
	MOVEM	A,DEV		;## HANG ON TO DEVICE
	JUMPE	T,QSELF		;## IF NIL THEN DONE
	PUSHJ	P,NXTIO		;## FAKE IOSUB SEQUENCE
	PUSHJ	P,IOPPN
	PUSH	P,A		;## IOPPN RETURNS FILE NAME IN A
	CAIE	REL,0		;## AREA SET UP?
	SKIPE	Q.FNAM(REL)	;## AREA SET UP, BUT NO FILE NAME?(PRECEDING SWITCHES)
	PUSHJ	P,FILARE	;## SET UP AREA
	MOVE	A,DEV		;## GET DEVICEE
	MOVEM	A,Q.FSTR(REL)	;## SET FILE STRUCTURE
	MOVE	A,EXT		;## GET EXTENSION
	MOVEM	A,Q.FEXT(REL)	;## SET IT
	MOVE	A,PPN		;## GET PPN
	MOVEM	A,Q.FDIR(REL)
	;## SET IT(DIRECTORY)
	POP	P,Q.FNAM(REL)	;## RESTORE NAME
	JRST	QSELF		;## T HAS BEEN RESET BY IO ROUTINES!



			;## HERE TO SET UP FILE AREA


FILARE:	AOS	Q.LEN(TT)	;## ADD ONE TO NUMBER FILES IN REQUEST
	HRLZI	A,FILPAR
	ADD	TT,A		;## ADD TO LENGTH OF PARAMETER AREA
	HRRZI	A,FILPAR
	PUSHJ	P,EXPCOR
	JUMPE	REL,FILDEF	;## SET DEFAULST IF NO PREVIOUS FILE AREA
	HRL	A,REL
	HRRZI	B,(A)		;## SET UP FOR BLT OF PREVIOUS AREA
	ADDI	B,FILPAR-1	;## FINAL DESTINATION ADDRESS
	HRRZI	REL,(A)		;## NEW FILE AREA
	BLT	A,(B)
	SETZM	Q.FNAM(REL)
	POPJ	P,
FILDEF:	HRRZI	REL,(A)
	HRLI	A,FILPAR
	PUSHJ	P,CLRBLK
	HRLZI	A,'DSK'
	MOVEM	A,Q.FSTR(REL)
	MOVE	A,[EXP 1B5+1B20+1B26+1B29+1]	;## DEFAULTS FOR Q.FMOD
	MOVEM	A,Q.FMOD(REL)
	POPJ	P,

			;## HERE WHEN FINISHED


QDONE:	MOVE	AR1,OUTPAR+Q.FNAM(TT)	;## GET FIRST FILE NAME
	HLRZ	A,Q.DEV(TT)	;## GET FIRST THREE LETTERS OF Q AGAIN
	CAIE	A,'INP'		;## INPUT QUEUE?
	JRST	QDONEB		;## NO
	MOVE	AR1,INPPAR+Q.FNAM(TT)	;## GET CORRCT FILE NAME
	HRRZ	A,Q.LEN(TT)	;## GET NUMBER OF FILES SPECIFIED
	SOJG	A,QDONEC	;## GREATER THAN ONE MEANS THAT USER
				;## SPECIFIED A LOG FILE
	PUSHJ	P,FILARE	;## WE HAVE TO SET UP LOG FILE
	HRRZI	A,'LOG'	;## CHANGE EXTENSION TO .LOG
	HRLZM	A,Q.FEXT(REL)
	MOVEM	AR1,Q.FNAM(REL)	;## SET TO INP FILE NAME
QDONEC:	HRRI	A,3
	DPB	A,[POINT 2,INPPAR+FILPAR+Q.FMOD(TT),2];## SET BITS
				;## INDICATING LOG FILE AND DOESN'T EXIST
				;## (AVOIDS ERROR MSGS FROM QMANGR)
				;## IN SECOND FILE IN CASE USER STUPIDLY SET
				;## UP MORE THAN TWO
QDONEB:	SKIPE	Q.JOB(TT)	;## SPECIFIED NAME 
	JRST	QDONE1		;## YES, DONE
	MOVEM	AR1,Q.JOB(TT)
QDONE1:	MOVE	C,[EXP 'QMANGR'];## SEGMENT NAME
	MOVEI	B,400010
	MOVE	A,TT
	PUSHJ	P,NEWHI
	PUSHJ	P,CONCOR	;## CONTRACT CORE
	JRST	FALSE		;## RETURN NIL


;## ROUTINE TO SWAP HI-SEGMENTS. REGISTER A CONTAINS ARG TO NEXT HI-SEG, B CONTAINS
;## LOCATION TO JUMP TO IN NEW HI-SEG. REGS ARE ARG BLOCK  TO GETSEG  UUO
;## TO THE GET SEG

NEWHI:	PUSH	P,SP		;## HAVE TO SAVE SP, SINCE MOST
				;## SYSTEM PROGS USE 17 FOR THEIR PDL
	MOVEM	A,HIARGS#	;## SAVE ARG TO HI-SEG
	HRRZM	B,HIADDR#	;## SAVE ADDR TO HI-SEG
	PUSH	P,JOBFF		;%% SAVE OLD VALUE 
				;%% (DON'T ASK WHY)
	HLRZ	B,A		;%% CALCULATE NEW VALUE
	ADDI	B,1(A)		;%%
	MOVEM	B,JOBFF		;%% RESET SO QMANGR WON'T WRITE
				;%% OVER ARGUMENT BLOCK.
				;%% JUST BECAUSE LISP IGNORES JOBFF
				;%% DOESN'T MEAN ANYONE ELSE DOES
	MOVEM	P,PSAVE#	;## SAVE P (CAN'T USE SP)
	MOVE	SP,P		;## USE RPDL
	HRRZI	A,OLDHI		;## REE WILL RESTORE AND CONTINUE
	MOVEM	A,JOBREN
	MOVEM	A,JOBREN	;## SET FAKE REE ADDRESS
	HRLZI	B,'SYS'		;## SYS: IS LOCATION OF NEW HI-SEG
	MOVEI	A,B		;## B IS STARTING LOCATION OF BLOCK TO GETSEG
	SETZB	AR1,AR2A	;## CLEAR REST OF BLOCK
	SETZB	T,TT		;## DITTO
	MOVEM	SP,SAVSP#	;## SAVE SP AROUND GETSEG (WHICH CLOBBERS ACS)
	JRST	NEWHI1		;## GO DO  IT

				;## HERE TO GET THAT HI-SEG

REMOTE <
NEWHI1:	CALLI	A,GETSEG
	JRST	@JOBREN		;## FAILED JOBREN HAS LOC OF RESTORE LISP HI-SEG
	MOVE	SP,SAVSP
	MOVE	A,HIARGS
	PUSHJ	SP,@HIADDR	;## JUMP TO HI-SEG
OLDHI:	MOVEI	A,HGHDAT
	CALLI	A,GETSEG
	HALT			;## YOU'RE DEAD IF YOU ARE HERE
ENDHI:	JRST	RESTOR		;## JUMP TO RESTORE THINGS
	>


RESTOR:	MOVE	P,PSAVE
	POP	P,JOBFF		;%% RESTORE OLD VALUE
	POP	P,SP
	MOVE	0,STNIL
	MOVE	S,ATMOV
	HRRZI	A,DEBUGO
	MOVEM	A,JOBREN
	POPJ	P,


TEMCOR:	HRRZ	B,CORUSE	;## GET CURRENT CORUSE. THIS ROUTINE EXPANDS CORE
				;## BUT SAVE INFO SO THAT IT CAN BE CONTRACTED LATER
	HRL	B,JOBREL	;## GET CURRENT CORE EXTENT
	MOVEM	B,OLDCU		;## SAVE IT (SEE LOADER INTERFACE)
EXPCOR:	SETZ	D,		;## D IS A RELOC REG
	JRST	MORCOR		;## EXPAND CORE

CONCOR:	MOVS	B,OLDCU		;## CONTRACTS CORE, OPPOSITE TEMCOR
	HLRZM	B,CORUSE
	HRRZI	B,(B)		;## CLEAR LH
	PUSHJ	P,MOVDWN	;## MOVE SYMBOL TABLE
	CALLI	B,CORE		;## CONTRACT (B SHOULD BE UNCHANGED
	CAI
	POPJ	P,		;## DONE


QSXARG:	MOVEI	A,(T)
	PUSHJ	P,CADAR		;## GET ARGUMENT TO SWITCH
	JRST	SIXMAK		;## CONVERT  IT TO SIXBIT



CLRBLK:	SETZM	(A)		;## CLEAR FIRST WORD
	HLRZ	B,A		;## LH OF A CONTAINS LENGTH
	ADD	B,A
	HRL	A,A
	AOJ	A,		;## RH NOW CONTAINS SOURCE+1
	BLT	A,-1(B)		;## BLT CLEARS BLOCK
	POPJ	P,
	;## PICKUP


CHKGO:	CAIN	B,(A)		;## SEE IF RH(A)=(B)
	HLRZ	R,A		;## WHERE TO GO
	JRST	(R)		;## NO, RETURN
	>

	PAGE
	SUBTTL	PRINT

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)
	CAIN B,PNAME(S)
	JRST PRINN
	CAIN B,FIXNUM(S)
	JRST PRINI1
	CAIN B,FLONUM(S)
	JRSTF @[XWD 0,PRINO]	; TURN OFF DIVIDE CHECK AND UNDERFLOW
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
	HRRZ C,VBASE(S)
	SUBI C,INUM0
	JUMPGE A,PRINI2
	XCT "-",CTY
	MOVNS A
PRINI2:	MOVEI B,"."-"0"
	HRLM B,(P)
	CAIN C,TEN
	SKIPE %NOPOINT(S)
	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
	JUMPN A,@PRIN5#
	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
REMOTE<
TYOI:	X
	JRST TYOI2>
TYOI2:	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,34]
	PUSHJ P,FP3
	MOVEI A,"E"
	PUSHJ P,(R)
	MOVE A,FP4C#
	IORI A,51
	PUSHJ P,(R)
	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

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

;magic scanner table bit definitions

;bit 0=0 iff slashified as nth id character
;bit 1=0 iff slashified as 1st 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

REMOTE<
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
REMOTE<CHRTAB:
TABIN (0,0,1,1,1,1,1,0,< >)	
;null
LET (<        >)
IGNORE (<     >)		
;tab,lf,vtab,ff,cr
LET (<           >)	
;16 to 30
TABIN (0,0,0,0,0,0,0,0,< >)
;igmrk
TABIN (0,0,0,0,0,0,0,0,< >)
;32 THE OLD IGMRK, WILL ALLOW THE CHAR. TO WORK ON READS BUT NOT TYI
	IFE	ALTMOD-33 <
	DELIMIT (< >,3)
>			;%% NEW ALTMODE (5S06 MONITOR)
	IFN	ALTMOD-33 <
	LET (< >)
>			;%% OLD ALTMODE (5S04 OR EARLIER MONITOR)
LET (<    >)
;## 34 TO 37
IGNORE (< >)			
;space
LET (< >)			
;!
TABIN (0,0,9,2,2,2,2,0,< >)	
;"
LET (< $%  >)			
;#$%&'
DELIMIT (< >,0)
DELIMIT (< >,1)
;()
LET (< >)			
;*
TABIN (1,1,14,2,3,4,2,0,< >)	
;+
IGNORE (< >)			
;,
TABIN (1,1,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 (<  >)			
;{|
	IFE	ALTMOD-175 <
	DELIMIT (< >,3)			
>		;%% OLD ALTMODE (5S04 MONITOR)
	IFN	ALTMOD-175 <
	LET (< >)
>		;%% } - ORDINARY CHARACTER (5S06 MONITOR)
	LET (< >)
		;~
	DELIMIT (< >,6)			
		;rubout
>
PAGE
READCH:	PUSHJ P,TYI
	MOVSI AR1,AR1
	PUSHJ P,EXPL1
	JRST CAR

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

RDNAM:	SETOM	NOINFG		;## READ ROUTINE THAT DOES NOT INTERN
	JRST	READ+1		;##

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:	SKIPE SMAC#	;$$ CHECK FOR A SPLICE MACRO LIST
	JRST PSMAC	;$$ GET ITEM FROM SPLICE MACRO LIST
	SETZB T,R
	HRLI C,(POINT 7,0,35)
	HRRI C,(SP)
	MOVEM C,ORGSTK#		;SAVE FOR BACKING UP ON + AND -
	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
	JRST RMACRO	;10	MACRO
	JRST SMACRO	;11	SPLICE MACRO
	JRST RDNPLS	;12	+

;a real dotted pair
RDOT2:	MOVEM A,OLDCH
	MOVE A,ORGSGN	;ORGSGN NORMALLY CONTAINS A "." AT THIS POINT
RATOM3:	LDB B,RDFLD
	HRRI R,DELCLS	;delimiter
	AOS (P)		;non-atom (ie a delimiter)
	POPJ P,

;dot handler
RDOT:	MOVEM A,ORGSGN	;INCASE SOMETHING ELSE DEFINED AS "."
	PUSHJ P,TYID
	LDB B,DOTFLD
	JRST DOTAB(B)

DOTAB:	PUSHJ P,COMMENT	;0	comment
	JRST RDOT+1	;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
;LINEREAD - RETURNS ALL THE EXPRESSIONS ON ONE LINE AS A LIST
;
LINRD:	PUSHJ	P,READ
	HRRZ	B,A
	SKIPE	SMAC		;CHECK THE SPLICE LIST
	JRST	LRMORE
	SKIPN	A,OLDCH
LRTY:	PUSHJ	P,TYID		;NEED A CHARACTER
	MOVEM	A,OLDCH		;SAVE IT
	LDB	C,RATFLD	;THIS KLUDGE IS TO AVOID MAKING ANOTHER TABLE ENTRY
	CAIN	C,7		;SPECIAL CHECK FOR "."
	JRST	LRTY1		;IGNORE IT
	CAILE	C,3		;ELIMINATE MOST POSSIBILITIES
	JRST	LRMORE		;MORE ON THE LINE
	JUMPE	C,LREND		;END LINE ON COMMENT - THINK ABOUT IT, ITS RIGHT
	LDB	C,RDFLD
	JRST	LR1(C)
LR1:	JRST	LPIG		;0	MORE TO FIGURE OUT
	JRST	LRTY1		;1	IGNORE
	JRST	LRMORE		;2	MORE ON THE LINE
	SUBI	A,ALTMOD	;3	CHECK ALTMOD
	JUMPN	A,LRTY1		;4	IGNORE "]" AND "."
	JUMPN	A,LRMORE	;5	MORE ON "@"
	JRST	LREND
LPIG:	CAIN	A,"("		;THESE SPECIAL CHECK COULD SCREW UP READ MACROS
	JRST	LRMORE
	CAIE	A,TAB
	CAIL	A,40		;READ MORE IF SPACE, COMMA, OR TAB
	JRST [	HRLI B,-1	;SET SPQCE FLAG AND TRY AGAIN
		JRST LRTY]
	CAIE	A,CR		;ALWAYS IGNORE CR.S
	TLZE	B,-1		;EOL - IF SPACE FLAG THEN DO A PEEKC
	JRST	LRTY
LREND:	HRRZ	A,B		;FINALLY GOT THERE
	JRST	NCONS
LRMORE:	HRLI	B,0
	PUSH	P,B		;MORE TO GO, PUSH
	PUSHJ	P,LINRD		;AND CALL YOURSELF
	POP	P,B
	JRST	XCONS
LRTY1:	HRLI	B,0		;CLEAR SPACE FLAG
	JRST	LRTY

PAGE

	;## FUNCTIONS TO READ A FILE.EXT
	;## READ A FILE.EXT FROM THE UFD

FLTYIA:	XCT	TYI2		;## GET NEXT WORD, IGNORE OLDCH
	JRST	[SETZ AR1,
		 JRST TYI2X ]	;%% INPUT SOME MORE, CLEARING TEST REG.
	ILDB	A,@TYI3		;## AND LOAD WORD
	POPJ	P,


RDFIL1:	PUSHJ	P,FLTYIA	;##  FILE NAME NOT THERE, SKIP OVER EXT
RDFILE:	SETZM	NOINFG		;## ## INTERN
	PUSHJ	P,FLTYIA		;## GET FILE NAME WORD
	PUSHJ	P,SIXATM	;## MAKE IT AN ATOM
	JUMPL	A,RDFIL1	;## A=-1 IF EMPTY 
	PUSH	P,A
	PUSHJ	P,FLTYIA		;## GET EXTENSION
	HRRI	A,0		;## CLEAR RH
	PUSHJ	P,SIXATM
	JUMPL	A,POPAJ		;## NO EXTENSION, RETURN 
	POP	P,B		;## GET FILE BACK
	JRST	XCONS		;## RETURN FILE.EXT

	;## ROUTINE TO TAKE ONE WORD OF SIXBIT AND MAKE IT AN ATOM
	;## IGNORES TRAILING BLANKS, BUT INCLUDES INSERTED BLANKS. NO
	;## READ MACROS, ETC.

SIXATM:	SKIPN	B,A
	JRST	SXATER		;## INDICATE WORD EMPTY
	MOVEI	T,5		;##  OF CHS PERMISSIBLE IN FULL WORD
				;## NAME T=0 IF FIRST WORD DONE
	MOVE	AR1,[POINT 6,B,5]	;## AR1 HAS PTR TO LOAD BYTE
					;## FROM B TO C
	PUSHJ	P,SIXAT1	;## MAKE THE PNAME LIST
	PUSHJ	P,NCONS
	MOVEI	B,PNAME(S)	;## MAKE PNAME
	PUSHJ	P,XCONS
	PUSHJ	P,ACONS		;## VOILA,  AN  ATOM
	SKIPE	NOINFG	;## NOINFG=0 MEANS INTERN
	POPJ	P,
	JRST	INTERN

SXATER:	SETO	A,		;## RETURN -1 IN A IF B EMPTY
	POPJ	P,
SIXAT1:	MOVE	AR2A,[POINT  7,0,35]	;## POINTER TO MOVE C TO  A
	SETZ	A,		;## CLEAR A
SIXAT2:	SETZ	C,
	JUMPE	B,SIXDON	;## DONE IF B EMPTY
	LDB	C,AR1
	LSH	B,6		;## LEFT SHIFT B, REMAINING CH'S IN B
	HRRI	C,40(C)		;## ADD 40  TO C
	IDPB	C,AR2A		;## PUT  IT IN  A
	SOJG	T,SIXAT2	;## IF T>0, STILL IN FIRST WORD OF PNAME
SIXAT3:	PUSHJ	P,FWCONS
	PUSH	P,A
	JRST	SIXAT1		;## TRY FOR THAT SIXTH CH.
SIXDON:	JUMPN	A,SIXAT3		;## IF A NOT EMTPY, DO ANOTHER FWCONS AND
				;## END UP HERE WITH A=0.
	POP	P,A
	PUSHJ	P,NCONS
	JUMPGE	T,CPOPJ		;## IF T>=0, THEN ONLY ONE WORD
	POP	P,B
	JRST	XCONS		;## DONE
	PAGE
;NEW AND SUPER BITCHEN READ MACROS
;
RMACRO:
	IFN ALVINE,<
	SKIPE PSAV1	;$$ ARE WE IN ALVINE?
	JRST RATOM2	;$$ YES, IGNORE>
RMAC2:	IDPB A,C	;$$ CONVERT THE CHAR. TO AN ATOM
	PUSHJ P,IDEND	;$$
	PUSHJ P,INTER0	;$$
	MOVEM A,T	;$$ SAVE ATOM IN CASE OF ERROR
	MOVEI B,READMACRO(S)	;$$ GET THE FUNCTION NAME
	PUSHJ P,GET	;$$
	JUMPE A,RMERR	;$$ UNDEFINED READ MACRO
	PUSHJ P,NCONS	;$$ CONVERT TO A FORM
	PUSH P,PSAV	;$$
	PUSHJ P,EVAL	;$$ EVALUATE THE FORM
	POP P,PSAV	;$$
	POPJ P,	;$$ RETURN

;SPECIAL PROCESSING OF SPLICE MACROS
SMACRO:
IFN ALVINE,<
	SKIPE PSAV1	;$$ ARE WE IN ALVINE?
	JRST RATOM2	;$$ YES, IGNORE>
	PUSHJ P,RMAC2	;$$ EVALUATE THE MACRO
	MOVEM A,SMAC	;$$ SAVE THE SPLICE LIST
	JRST RATOM	;$$ START OVER

;GET AN ITEM OFF OF THE SPLICE LIST
PSMAC:	MOVE A,SMAC	;$$
	PUSHJ P,ATOM	;$$ IS SPLICE LIST AN ATOM?
	JUMPN A,[	MOVE A,SMAC	;$$ YES, SIMULATE . <ATOM>
			PUSHJ P,NCONS	;$$
			MOVEM A,SMAC	;$$
			MOVEI B,4	;$$
			JRST RATOM3+1]	;$$
	MOVE B,@SMAC	;$$
	HLRZ A,B	;$$ RETURN NEXT ITEM OF SPLICE LIST
	HRRZM B,SMAC	;$$ ADVANCE SPLICE LIST
	POPJ P,	;$$ RETURN
	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
RDNPLS:	MOVEM A,ORGSGN#		;SAVE SIGN IN CASE OF BACKUP
	JRST RDNUM+1

;exponent scanner
RDE:	CAME	C,ORGSTK	;FOR +E AND -E TYPE OF ATOMS
	JRST	.+3
	MOVEM	A,OLDCH
	JRST	KLDG1
	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

;pname unmaker
PNAMUK:
	MOVEI B,PNAME(S)
	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 
	IDIV B,INT1	;compute hash code 
REMOTE<
INT1:	BCKETS
RHX2:
XXX1:	XWD B+1,OBTBL>
	PUSH P,C		;## SAVE C
	HRRZ	C,VOBLIST(S)	;## THIS GETS THE CURRENT VALUE OF OBLIST(THE ATOM)
	HRRM	C,RHX2	;## ASSUMES THAT ALL REFERENCE TO OBLIST GOES
	HRRM	C,RHX5	;## IE INTERN, REMOB ETC GOES THROUGH THIS SECTION.
	POP P,C		;##RHX2 AND RHX5 ARE HOPEFULLY THE ONLY TWO WORDS
			;##WHICH ARE USED TO REFERENCE TABLE 3/28/73
	HLRZ TT,@RHX2	;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:	MOVEI	B,PNAME(S)	;## USE GET FOR GETTING PNAME
	PUSHJ	P,GET		;## (GET ATOM @PNAME)
	JUMPE	A,NOPNAM	;## NO PRINT NAME
	MOVE C,IDPTR	;found pname
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,

	PAGE
;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
	CAME C,ORGSTK	;BIG KLUDGE FOR + AND -
	JRST .+5
KLDG1:	MOVE A,ORGSGN	;ENTER HERE TO BACK UP IN THE CASE OF +E OR -E
	IDPB A,C
	PUSHJ P,TYIA
	JRST RDID+2
	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
	MOVE A,VIBASE(S)	;ibase integrer
	SUBI A,INUM0
	PUSHJ P,NUM
NUMAK4:
	MOVEI B,FIXNUM(S)
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
	MOVEI B,FLONUM(S)
	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
	IMUL A,NUM1#
	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
REMOTE<
RHX5:
XXX2:	XWD B,OBTBL>
	HLRZ C,@RHX5
	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
	PAGE
;ROUTINE TO ALLOW ARBITRARY MODIFICATION AND READING OF THE
;READ CHARACTER-TABLE BY LISP FUNCTIONS
;TAKES TWO ARGUMENTS A,B
;	IF B = NIL IT RETURNS THE CONTENTS OF CHARACTER TABLE
;	LOCATION SPECIFIED BY A
;	OTHERWISE IT CHANGES THE CHARACTER TABLE ENTRY SPECIFIED BY A
;	TO THE BIT PATTERN SPECIFIED BY B, AND RETURNS THE
;	PREVIOUS VALUE

MODCHR:	PUSH	P,B	;$$SAVE BIT PATTERN FOR TABLE
	PUSHJ	P,NUMVAL	;$$GET POSITION IN TABLE
	POP	P,B	;$$
	MOVE	T,CHRTAB(A)	;$$GET OLD TABLE VALUE
	JUMPE	B,MCEXIT	;$$IF B=NIL THEN JUST RETURN OLD TABLE VALUE
	PUSH	P,A	;$$SAVE TABLE POSITION

	MOVEI	A,(B)	;$$
	PUSHJ	P,NUMVAL	;$$GET NEW BIT PATTERN
	POP	P,B	;$$GET TABLE POSITION
	MOVEM	A,CHRTAB(B)	;$$CHANGE TABLE
MCEXIT:	MOVE	A,T	;$$RETURN OLD TABLE VALUE
	JRST	FIX1A	;$$CONVERT TO BINARY AND EXIT

;FUNCTION TO DETERMINE THE ASCII VALUE OF A CHARACTER
;	CHRVAL TAKES AN ATOM AS ITS ARGUMENT AND USES THE FIRST
;	CHARACTER OF THE PRINT NAME
CHRVAL:	MOVEI B,PNAME(S)	;$$ GET PRINT NAME
	PUSHJ P,GET	;$$
	HLRZ A,(A)	;$$
	MOVE A,(A)	;$$ FIRST WORD OF PRINT NAME
	LSH A,-35	;$$ SHIFT TO GET FIRST CHARACTER
	JRST FIX1A	;$$ CONVERT TO INTEGER

;FUNCTION TO SET BITS FOR A READ MACRO
;	A IS THE CHAR. ATOM AND B ARE THE STATUS BITS,
;	IF B=NIL NO MODIFICATION IS MADE
;	THE OLD STATUS BITS ARE RETURNED
SETCHR:	MOVE TT,B	;$$
	PUSHJ P,CHRVAL	;$$ CONVERT CHAR. TO INUM
	MOVEI B,-INUM0(A)	;$$ CONVERT INUM TO BINARY
	LDB A,[POINT 5,CHRTAB(B),5]	;$$ LOAD OLD BITS
	JUMPE TT,FIX1A	;$$ NO CHANGE IF B = NIL
	MOVEI TT,-INUM0(TT)	;$$ CONVERT STATUS TO BINARY
	DPB TT,[POINT 5,CHRTAB(B),5]	;$$ SET NEW BITS
	JRST FIX1A	;$$ RETURN


	PAGE
	SUBTTL LISP INTERPRETER SUBROUTINES   

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
	MOVEI B,PNAME(S)
	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,

CONSP:	JUMPE	A,CPOPJ		;## DONE IF NIL
	CAILE A,INUMIN
	JRST FALSE
	HLLE B,(A)
	AOJE B,FALSE
IFN NONUSE	<JRST	TRUE>	;## T IF NONUSEFUL DESIRED
IFE NONUSE	<POPJ	P,>	;## THE CELL OTHERWISE
PATOM:	CAIL A,@GCP1
	JRST TRUE
	CAIL A,@GCPP1
ATOM:	CAILE A,INUMIN
	JRST TRUE
	JUMPE	A,TRUE		;## FAST CHECK FOR NIL
	CAIGE	A,@GCP1		;## LO-END OF FWS, CAN'T ADD TO 0
	HLLE A,(A)
	AOJE A,TRUE
	JRST FALSE
PAGE
NEQ:	CAMN A,B
	JRST FALSE
	JRST TRUE
EQ:	CAMN A,B
	JRST TRUE
	JRST FALSE

LENGTH:	MOVEI B,0
LNGTH1:	CAIE	A,NIL		;## DONE IF NIL
	CAIL A,@FWSO		;## FWSO  IS  FULL SPACE ORIGIN,
				;## ELIMINATE ILL MEM REF
	JRST FIX1
	HLLE C,(A)
	AOJE C,FIX1
	HRRZ A,(A)
	AOJA B,LNGTH1

LAST:	HRRZ B,(A)
	CAIE	B,NIL		;## IF NIL DONE
	CAIL	B,@FWSO		;## ANOTHER  POTENTIAL ILL MEM GONE
	POPJ P,
	HLLE B,(B)
	AOJE B,CPOPJ
	HRRZ A,(A)
	JRST LAST

;(LITATOM X) = (AND (ATOM X) (NOT (NUMBERP X)))
LITATOM:MOVE	B,A
	PUSHJ	P,ATOM
	JUMPE	A,CPOPJ
	MOVE	A,B
	PUSHJ	P,NUMBERP
	JRST	NOT
	PAGE
;NEW RPLACD AND RPLACA WHICH CHECK SO AS NOT TO  CLOBBER NIL AND ATOMS
RPLACA:	CAIE	A,NIL		;## TEST FOR NIL
	CAILE	A,INUMIN	;$$
	JRST	RPAERR	;$$ ATTEMPT TO RPLACA A SMALL NUMBER
	HLL	A,(A)	;$$TEST FOR OTHER ATOMS
	TLC	A,-1	;$$
	TLZN	A,-1	;$$ATOM CARS ARE -1
	JRST	RPAERR	;$$ATTEMPT TO RPLACA AN ATOM
	HRLM	B,(A)	;$$STANDARD CODE FOR RPLACA
	POPJ	P,	;$$

RPLACD:	CAIG	A,INUMIN	;$$CHECK FOR SMALL BER
	JUMPN	A,.+2	;$$CHECK FOR NIL
	JRST	RPDERR	;$$ATTEMPT TO RPLACD NIL  OR A SMALL NUMBER
	HRRM	B,(A)	;$$OLD RPLACD CODE
	POPJ	P,	;$$

ZEROP:	PUSHJ P,NUMVAL
NOT:
NULL:	JUMPN A,FALSE
TRUE:
	MOVEI A,TRUTH(S)
	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

	;## IF WE ARE USING NEW NIL, THEN GET IS FOR SYSTEM ONLY AND
	;## USRGET IS THE  USERS. IF NEW NIL, THEN GET MUST GET NIL'S
	;## PROPERTY LIST

IFE OLDNIL<
USRGET:	JUMPE	A,CPOPJ		;## ALWAYS NIL>
GET:
IFE OLDNIL<	CAIE	A,NIL
		SKIPA	A,NILPRP>
	HRRZ A,(A)
GET1:	MOVS D,(A)
	CAIN B,(D)
	JRST CADR
	HLRZ A,D
	HRRZ A,(A)
	JUMPN A,GET1
	POPJ P,

GETL:	JUMPE B,FALSE	;$$ NIL LIST - NIL ANSWER
IFE OLDNIL	<JUMPE	A,CPOPJ>	;## TEST FOR NIL
	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)
	CAIE A,FIXNUM(S)
	CAIN A,FLONUM(S)
	JRST TRUE
NUMBP2:	JRST FALSE	;bignums change this to JRST BIGNP
STRINGP: MOVE	B,A	;= T IF A IS A STRING
	PUSHJ	P,ATOM
	JUMPE	A,CPOPJ
	MOVE	A,B
	PUSHJ	P,NUMBERP	;MUST NO BE A NUMBER
	JUMPN	A,FALSE
	MOVE	A,B
	PUSHJ	P,CHRVAL	;GET THE FIRST CHARACTER
	CAIE	A,42+INUM0	;CHECK FOR "
	JRST	FALSE
	JRST	TRUE
PAGE
PUTPROP:
IFN OLDNIL	 <MOVE T,A>
IFE OLDNIL	<SKIPN	T,A		;## CAN'T PUTPROP TO NIL
		 ERR1	[SIXBIT /CAN'T PUT PROP ON NIL !/]>
	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:
	CAIE C,VALUE(S)
	JRST CSET1
	HRRZ T,(B)
	HLRZ A,(A)
	HRRM T,(A)
	JRST PROG2

CSET1:	HRLM B,(A)
PROG2:	MOVE A,B
PROG1:	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
COMMENT	?
	;## OLD SUBST AND COPY CODE THAT DID NOT WORK AS IT WAS
	;## NOT PROTECTED FROM THE GARBAGE COLLECTOR. NASTY, NASTY.
	;## REPLACED BY COMPILED LISP CODE
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
	CAIE	C,NIL		;## TEST FOR NIL
	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

COPY:	MOVEI B,INUM0	;$$ (SUBST 0 0 A)
	MOVEI C,INUM0
	EXCH A,C
	JRST SUBST
	?
; NTHCHAR = THE BTH CHARACTER OF A.
NTHCHAR:MOVE	T,B
	SUBI	T,INUM0
	JUMPE	T,FALSE		;FAIL IF = 0
	PUSH	P,A
	MOVEM	T,ORGSGN
	JUMPG	T,NTH3
	PUSHJ	P,%FLATSIZEC
	MOVEI	T,1-INUM0(A)
	ADDB	T,ORGSGN
NTH3:	MOVE	A,(P)
	PUSHJ	P,LITATOM
	JUMPN	A,NTH4
	POP	P,A
	HRROI	R,NTH5		;I HOPE THIS IS RIGHT
	PUSHJ	P,PRINTA
	HLRZ	A,ORGSGN
	JRST	NTH6
NTH5:	SOSN	ORGSGN
	HRLOM	A,ORGSGN
	POPJ	P,
NTH4:	MOVE	T,ORGSGN
	POP	P,A
	MOVEI	B,PNAME(S)
	PUSHJ	P,GET
	JUMPE	A,CPOPJ		;FAIL IF NO PRINT NAME
NTH1:	CAIG	T,5
	JRST	NTH2
	HRRZ	A,(A)
	JUMPE	A,FALSE		;FAIL IF NO NTH CHARACTER
	SUBI	T,5
	JRST	NTH1
NTH2:	HLRZ	A,(A)
	IMULI	T,-7
	LSH	T,14
	ADDI	T,440700
	HRL	A,T
	LDB	A,A
	JUMPE	A,FALSE
NTH6:	PUSHJ	P,AASCII+1	;CONVERT TO AN ATOM
	JRST	INTERN		;INTERN IT
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
IFN NONUSE<MEMBER:
	>
MEMB0:	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

IFE NONUSE<MEMQ:
	>
MEMB:	EXCH	A,B		;## NEW MEMQ THAT RETURN TAIL
	JUMPE A,FALSE
	MOVS C,(A)
	CAIN B,(C)
	POPJ	P,
	HLRZ A,C
	CAMGE	A,FWSO		;##THIS WILL ELIMINATE MOST (MAYBE ALL)
				;## ILLEGAL MEM REFS FROM MEMQ
				;##AND ASSOCIATED ROUTINES. FWSO IS FWS ORIGIN
	JUMPN A,MEMQ+1
	POPJ	P,



;NEW MEM-FUNCTIONS THAT RETURN THE TAIL OF THE LIST STARTING WHERE
;	THE ELEMENT IS FOUND

IFE NONUSE<MEMBER:
	>
MEMBR.:	PUSHJ P,MEMB0
	SKIPE A
	MOVE A,SUBBS
	POPJ P,

IFN NONUSE<
MEMQ:	PUSHJ P,MEMB
	SKIPE A
	JRST	TRUE
	POPJ P,


;AND OR FUNCTIONS (AND#, OR#) THAT RETURN THE EXPRESSION
;	THAT CAUSED THE FUNCTION TO EVALUATE TO TRUE

AND.:	PUSHJ P,AND
	SKIPA
OR.:	PUSHJ P,OR
	HRRZ A,2(P)
	POPJ P,
	>

AND:
	HRLI A,TRUTH(S)
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
IFN	NONUSE <
	SKIPE A
	MOVEI A,TRUTH(S)
	>
	POPJ P,
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

REMOTE<
GNUM:	ASCII /G0000/>

CSYM:	HLRZ A,(A)
	PUSH P,A
	MOVEI B,PNAME(S)
	PUSHJ P,GET
	JUMPE A,NOPNAM
	HLRZ A,(A)
	MOVE A,(A)
	MOVEM A,GNUM
	JRST POPAJ
PAGE
LIST:	MOVEI B,CEVAL(S)
	PUSH P,B
	PUSH P,A
	MOVNI T,2
	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)
	PUSH	P,SP	;$$SAVE SP POINTER TO RESTORE AFTER ARGUMENT EVALUATED
	PUSHJ	P,EVAL	;EVALUATE ARGUMENT
	POP	P,SP	;$$RESTORE SP POINTER AFTER EVAL
ILIST3:	POP P,TT
	HLRE T,TT
	EXCH A,(P)
	HRRZ A,(A)
	SOS T
	JUMPN A,ILIST1
ILIST2:	JRST (TT)

;FAST MAPC FOR 2 ARGS - CALLED BY LAP CODE ONLY
.MAPC:	PUSH	P,A
	JUMPE	B,PRETB
	HLRZ	A,(B)
	HRRZ	B,(B)
	PUSH	P,B
	CALLF	1,@-1(P)
	POP	P,B
	JRST	.MAPC+1

;FAST MAP FOR 2 ARGS - CALLED BY LAP CODE ONLY
.MAP:	PUSH	P,A
	JUMPE	B,PRETB
	MOVE	A,B
	HRRZ	B,(B)
	PUSH	P,B
	CALLF	1,@-1(P)
	POP	P,B
	JRST	.MAP+1

PRETB:	SUB	P,[XWD 1,1]
	JRST	PROG2
	PAGE
; NEW AND SUPER POWERFUL MAP FUNCTIONS
MAPCON:	TLZ	T,100000
	JRST	MAPLIST
MAPCAN:	TLZA	T,100000
MAPC:	TLZA	T,400000
MAPCAR:	TLZA	T,400000
MAP:	TLZ	T,200000
; INITIALIZE
MAPLIST:SETCA	T,T
	MOVEI	A,(CALLF)
	DPB	T,[POINT 4,A,30]
	MOVE	B,P
	MOVE	AR1,T
	HRL	AR1,T
	SUB	B,AR1
	PUSH	P,B
	HRLM	A,(B)
	PUSH	P,T
	PUSH	P,
	HRLZM	P,(P)
; SET UP TO GET ARGUMENTS
MAPL2:	HRRZ	T,-1(P)
	MOVEI	TT,-3(P)
; MOVE ARGS TO REGS
MPL3:	MOVE	D,(TT)
	JUMPE	D,MPDN
	MOVEM	D,(T)
	MOVE	D,(D)
	SKIPGE	-1(P)
	HLRZM	D,(T)
	HRRZM	D,(TT)
	SUBI	TT,1
	SOJG	T,MPL3
	XCT	(TT)	; CALL THE FUNCTION
	LDB	C,[POINT 2,-1(P),2]
	TRNE	C,2
	JRST	MAPL2
; ATTACH TO OUTPUT LIST
	SKIPN	C
	PUSHJ	P,NCONS
	JUMPE A,MAPL2
	HLR	B,(P)
	HRRM	A,(B)
	SKIPE	C
	PUSHJ	P,LAST
	HRLM	A,(P)
	JRST	MAPL2
; POP STACK AND RETURN
MPDN:	POP	P,AR1
	MOVE	P,-1(P)
	POP	P,B
SUBS4:	HRRZ	A,AR1
	POPJ	P,
;PA3:	0	;THE REG. PDL POINTER
;PA4:	0	;Lh=pntr to prog less bound var list	
		;RH=NEXT PROG STATEMENT

PROG:	PUSH P,PA3#
	PUSH P,PA4#
	HLRZ TT,(A)	;## TT HAS VARIABLE LIST
	HRRZ A,(A)	;## A HAS PROG BODY
	HRRM A,PA4
	HRLM A,PA4

	MOVE T,SP	;$$ADJUST SPDLSAV POINTER TO INCLUDE EVAL BLIP
	SUB T,[XWD 2,2]	;$$SO PA3,PA4 CAN BE RESTORED
	MOVEM	T,SPSV#	;$$BY UNBIND
	JRST	PG7B	;$$GO CHECK IF ANY VARIABLES TO BIND

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

PG1:	HRRZ T,PA4
	JUMPE T,PG4	;## IF END OF PROG, QUITE
	HLRZ A,(T)	;## A HAS FIRST STATEMENT
	HRRZ T,(T)	;## T KEEPS THE REST
	CAIE	A,NIL	;## TEST FOR NIL
	CAILE A,INUMIN	;## ALLOW INUMS FOR PROG LABELS 3/28/73
	JRST	PG1+1	;## NOW WE CAN SKIP OVER THIS TYPE OF ATOM
	HLLE B,(A)	;## IS IT A ATOM?
	AOJE B,PG1+1	;## JA, SO JUMP
	HRRM T,PA4	;## SAVE REST OF BODY

	PUSH P,SP	;$$SAVE SPDL TO RESTORE AFTER EVAL
	PUSHJ P,EVAL	;## EVAL THE STATEMENT
	POP P,SP	;$$RESTORE SPDL AFTER EVAL

	JRST PG1

PGO:	SKIPN	PA3	;## ERROR IF NO PROG
	JRST	EG2
	MOVE	P,PA3	;## BACK UP ON RPDL
	MOVE	B,1(P)	;## GET FORM
	PUSHJ	P,UBD
	HRLZI	C,(POPJ P,)	;## NEW CODE TO ALLOW BREAKING
			;## AND TRACING OF GO
	PUSHJ	P,DOSET	;##
	HLRZ	T,PA4
PG5:	JUMPE T,EG1	;## ERROR IF NO TAG FOUND
	HLRZ TT,(T)	;## GET THE CAR
	HRRZ T,(T)	;## SAVE UP THE REST OF THE BODY
	CAIN TT,(A)
	JRST PG1+1	;FOUND TAG
	JRST PG5	;## TRY AGAIN
	
RETURN:	SKIPN PA3
	JRST EG3
	MOVE P,PA3
	MOVE B,1(P)
	PUSHJ P,UBD
	HRLZI	C,(POPJ P,)	;## NEW CODE TO ALLOW BREAKING
				;## AND TRACING OF RETURN
	PUSHJ	P,DOSET		;##
	JRST	PG4+1

PG4:	SETZ A,
	PUSHJ P,UNBIND
ERRP4:	POP P,PA4
	POP P,PA3
	POPJ P,

GO:	HLRZ A,(A)
	CAIE	A,NIL		;## TEST FOR NIL
	CAILE	A,INUMIN	;## IS IT AN INUM?(NOW VALID)
	JRST	PGO		;## SEE IF IT IS THE ONE
	HLLE B,(A)	;## IS IT AN ATOM
	AOJE B,PGO
	PUSHJ P,EVAL
	JRST GO+1


SETQ:	HLRZ B,(A)
	PUSH P,B
	PUSHJ P,CADR
	PUSHJ P,EVAL
	MOVE B,A
	POP P,A
SET:	SKIPE	A		;$$ MUST BE NON-NIL
	CAILE	A,INUMIN	;$$ AND NOT AN INUM
	JRST	SETERR		;$$
	HLRE	AR1,(A)		;$$ AND AN ATOM
	AOJN	AR1,SETERR	;$$
	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	;ENTRY FOR ALL TYPES OF PROGN'S
	HLRZ A,(T)
	HRRZ T,(T)	;$$
	JUMPE T,EVAL	;$$ SAVE STACK SPACE IF NO IMPLIED PROG
	PUSH P,T	;$$
	PUSHJ P,EVAL
	POP P,T
	JRST COND2+2	;$$ BECAUSE OF THE LAST CHANGE


;LEXORDER - TRUE IF A IS ALPHAMERICALLY LESS THAT OR EQUAL TO B

LEXORD:	MOVE TT,A
	PUSHJ P,NUMBERP
	JUMPN A,LEX2	;1ST ARG IS A NUMBER
	MOVE A,B
	PUSHJ P,NUMBERP
	EXCH A,TT
	JUMPN TT,FALSE	;1ST=NOT-NUM, 2ND=NUM, DEFINE AS NIL
	MOVE T,B
	MOVEI B,PNAME(S)
	PUSHJ P,GET
	EXCH A,T
	PUSHJ P,GET
LEX1:	JUMPE T,TRUE
	JUMPE A,CPOPJ
	HLRZ AR1,(A)
	MOVE AR1,(AR1)
	HLRZ AR2A,(T)
	MOVE AR2A,(AR2A)
	LSH AR1,-1
	LSH AR2A,-1
	CAMLE AR1,AR2A
	JRST TRUE
	CAME AR1,AR2A
	JRST FALSE
	HRRZ A,(A)
	HRRZ T,(T)
	JRST LEX1
LEX2:	MOVE A,B
	PUSHJ P,NUMBERP
	EXCH A,TT
	JUMPE TT,TRUE	;1ST=NUM, 2ND=NOT-NUM, DEFINE AS TRUE
	PUSHJ P,.GREAT	;BOTH NUMBERS, DO (NOT (*GREAT A B))
	JRST NOT


PROGN:	MOVE	T,A	;$$ PROGN
	MOVEI	A,NIL
	JRST	COND2+1	;$$ IMPLIED PROG DOES THE REST
	PAGE
	SUBTTL ARITHMETIC SUBROUTINES 

;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

.MAX:	MOVEI D,.GREAT
	SKIPA
.MIN:	MOVEI D,.LESS
	MOVE AR1,A
	MOVE AR2A,B
	PUSHJ P,(D)
	SKIPN A
	MOVE AR1,AR2A
	MOVE A,AR1
	POPJ P,
PAGE
MAKNUM:
	CAIE	B,FLONUM(S)	;## DEFAULT TO FIXNUM, NOT FLONUM
	JRST FIX1A
FLO1A:
	MOVEI B,FLONUM(S)
	PUSHJ P,FWCONS
	JRST ACONS-1

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

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

NUMAG1:	MOVEM A,AR1
	HRRZ A,(A)
	HLRZ B,(A)
	HRRZ A,(A)
	CAIE B,FIXNUM(S)
	CAIN B,FLONUM(S)
	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
	CAIE B,FLONUM(S)
	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

NUMTYP:	PUSHJ	P,NUMVAL	;## NUMVAL LEAVES TYPE IN B
	MOVEI	A,(B)		;## GET THE TYPE
	POPJ	P,

INUMP:	CAIG	A,INUMIN	;##  INUM IF > INUMIN
	JRST	FALSE		;## NO, RETURN NIL
	POPJ	P,		;## RETURN USEFUL VALUE
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)
	CAIE T,FIXNUM(S)
	JRST OPA6
	SKIPA A,(A)
OPA2:
	MOVEI T,FIXNUM(S)
	CAILE B,INUMIN
	JRST OPB2
	HRRZ B,(B)
	HRRZ TT,(B)
	HLRZ B,(B)
	CAIE B,FIXNUM(S)
	JRST OPA5
	SKIPA TT,(TT)
OPB2:	HRREI TT,-INUM0(B)
	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)
	CAIE B,FLONUM(S)
	JRST OPB3
	CAIE T,FLONUM(S)
	JRST NUMV3
	MOVE A,(A)
	MOVE TT,(TT)
OPR:	JFCL 17,.+1
	XCT 1(C)	;flt pt op
	JFCL 10,FLOOV
	JRST FLO1A

OPA5:
	CAIE B,FLONUM(S)
	JRST NUMV3
	PUSHJ P,FLOAT
	JRST OPR-1

OPB3:
	CAIE B,FIXNUM(S)
	JRST NUMV3
	SKIPA TT,(TT)
OPB7:	HRREI TT,-INUM0(B)
	MOVEI B,FIXNUM(S)
	CAIE T,FLONUM(S)
	JRST NUMV3
	MOVE A,(A)
	EXCH A,TT
	PUSHJ P,FLOAT
	EXCH A,TT
	JRST OPR
	PAGE
	SUBTTL EXPLODE, READLIST AND FRIENDS 

%FLATSIZEC:	SKIPA R,.+1	;$$ FLATSIZEC - (LENGTH (EXPLODEC))
FLATSIZE:	HRRZI R,FLAT2
	SETZM	FLAT1
	PUSHJ P,PRINTA
	MOVE	A,FLAT1#
	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
	HRRZ	TT,MKNAM3#
	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)
	MOVEI B,PNAME(S)
	PUSHJ P,GET
	HLRZ A,(A)
	LDB A,[POINT 7,(A),6]
	JRST MKNAM4

MKNAM6:	MOVEI A," "
	HLLOS MKNAM3
	JRST MKNAM4

;	A COUPLE OF FUNCTIONS SO THAT THE PROGRAMMER MAY RETURN CELLS TO THE FREE LIST
FREE:	MOVEM	F,(A)	;$$ RETURN A SINGLE CELL TO FREE LIST
	HRRZ	F,A
	JRST	FALSE
FREELI:	JUMPE	A,CPOPJ	;$$ RETURN A LIST TO THE FREE LIST
	HRRZ	B,(A)
	MOVEM	F,(A)
	HRRZ	F,A
	MOVE	A,B
	JRST	FREELI

	PAGE
	SUBTTL EVAL APPLY  -- THE INTERPRETER  

APPLY.:	CAILE A,INUMIN	;$$ AN APPLY TO HANDLE ANY FUNCTION TYPE
	JRST UNDTAG
	HLRZ T,(A)
	CAIE T,-1
	JRST GAPP
	HRRZ T,(A)
AAGN:	JUMPE T,GAPP
	HLRZ TT,(T)
	HRRZ T,(T)
	CAIN TT,FSUBR(S)
	JRST	[MOVE A,B
		 HLRZ T,(T)
		 JRST (T)]
	CAIN TT,FEXPR(S)
	JRST [	HLRZ T,(T)
		HRL T,A
		PUSH P,T
		MOVE A,B
		JRST APPL.2]
	CAIN TT,MACRO(S)
	JRST [	PUSHJ P,CONS
		JRST EVAL]
	CAIN TT,EXPR(S)
	JRST GAPP
	CAIN TT,SUBR(S)
	JRST GAPP
	CAIE TT,LSUBR(S)
	JRST AAGN
GAPP:	HRREI T,-2
	PUSH P,A
	PUSH P,B
	JRST APPLY

	PAGE
EV3:	HLRZ A,(AR1)
	MOVEI B,VALUE(S)
	PUSHJ P,GET
	JUMPE A,UNDFUN	;function object has no definition
	HRRZ A,(A)
REMOTE<
XXX4:
UBDPTR:	UNBOUND>
	HLRZ	B,(AR1)		;$$GET ORIGINAL FN NAME
	CAME	A,B		;$$IF VALUE IS THE SAME THE WE HAVE A LOOP
	CAMN A,UBDPTR
	JRST UNDFUN
	HRRZ B,(AR1)	;eval (cons (cdr a)(cdr ar1))
	PUSHJ P,CONS
	JRST XXEVAL
PAGE
OEVAL:	AOJN T,AEVAL
	POP P,A
EVAL:	PUSH	P,SP	;$$SAVE SPDL
	PUSHJ	P,XXEVAL	;$$GO DO EVALUATION AS USUAL
	POP	P,SP	;$$RESTORE SPDL
	POPJ	P,	;$$AND RETURN TO CALLER

XXEVAL:	HRRZM A,AR1
	CAILE A,INUMIN
	JRST CPOPJ

;$$CODE TO PUT EVAL BLIP ON SPECIAL PDL

	PUSH P,B	;$$SAVE WHAT WAS IN B
	HRRZI	B,-1(P)	;$$GET RPDL POINTER AND OFFSET
	HRLI B,UNBOUND(S)	;$$ SET UP RPDL POINTER
	PUSH SP,B	;$$ SAVE RPDL POINTER ON SPDL
	PUSH	SP,A	;$$SAVE EVAL FORM ON SPDL
	POP	P,B	;$$AND GO OON
	HLRZ	T,(A)	;;;;;;;;;;;;; 


	SKIPN ERINT#	;$$CHECK IF DDT (CONTROL H) INTERRUPT OCCURRED
	JRST .+4	;$$SKIP OVER INTERRUPT FEATURE
	SETZM	ERINT#	;$$TURN OFF INTERRUPT FLAG
	PUSHJ P,EPRINT	;$$PRINT OUT WHAT WAS INTERRUPTED
	ERR1 [SIXBIT /WAS JUST INTERRUPTED - NOW IN ERRORX!/]

	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)
	CAIE TT,FLONUM(S)
	CAIN TT,FIXNUM(S)
	POPJ P,
EVBIG:	HRRZ AR1,(AR1)		;bignums know about me
	CAIE TT,VALUE(S)
		JRST EV5
	HLRZ AR1,(AR1)
	HRRZ AR1,(AR1)
	CAIN AR1,UNBOUND(S)
	JRST UNBVAR
	MOVEM AR1,A
	POPJ P,
PAGE
;	HANDLER OF ALISTS AND SPDL CONTEXT POINTERS

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
	JUMPGE	T,AEVAL6	;$$SKIP ANY EVAL BLIP CRAP
AEVAL4:	CAMN C,T
	JRST AEVAL6	;thru with block
	POP C,AR1
	TLNE	AR1,-1		;$$ TEST FOR EVAL BLIP
	JRST	.+3
	SUB	C,[XWD 1,1]	;$$ FOUND ONE, SKIP RPDL WORD
	JRST	AEVAL4
	MOVSS AR1
	PUSH SP,(AR1)	;save value cell
	HLRM AR1,(AR1)	;store previous value in value cell
	HRLM AR1,(SP)	;save pointer to spec pdl loc
	JRST AEVAL4

	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
	JUMPL	A,.+5	;MAKE SURE IT IS A VALID STACK POINTER
	MOVS	T,SC2	;IT'S NOT, MAKE IT VALID
	ADD	T,A
	ADD	A,SC2
	HRL	A,T
	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)
	CAIN TT,SUBR(S)
	JRST ESB
	CAIN TT,LSUBR(S)
	JRST EELS
	CAIN TT,EXPR(S)
	JRST AEXP
	CAIN TT,FSUBR(S)
	JRST EFS
	CAIN TT,MACRO(S)
	JRST EFM
	CAIE TT,FEXPR(S)
	JRST EE2

	HLRZ T,(T)
	HLL T,(AR1)
	PUSH P,T
	HRRZ A,(A)
APPL.2:	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,[UNBIND]
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
	MOVEI B,FUNARG(S)
	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,[UNBIND]
	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 UNDTAC
	HLRZ A,(B)
	CAIN A,-1
	JRST IAP1	;fn is atomic
	CAIN A,LAMBDA(S)
	JRST IAPLMB
	CAIN A,FUNARG(S)
	JRST APFNG
	CAIN A,LABEL(S)
	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)
	CAIN TT,EXPR(S)
	JRST IAPXPR
	CAIN TT,LSUBR(S)
	JRST IAP6
	CAIE TT,SUBR(S)
	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:	MOVEI A,NIL	;$$SETUP FOR IMPLIED PROG
	PUSH SP,SPSV
	MOVE T,B	;$$SETUP FOR IMPLIED PROG
	PUSHJ P,COND2+1	;$$INSTEAD OF EVAL
	JRST UNBIND

IAP69:	POP P,(P)
	MOVEI A,NIL	;$$SETUP FOR IMPLIED PROG
	MOVE T,B	;$$
	JRST COND2+1	;$$INSTEAD OF 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)
	MOVEI B,VALUE(S)
	PUSHJ P,GET
	JUMPE A,UNDTAC
	HRRZ A,(A)
	HRRZ B,(C)	;$$GET ORIGINAL FN NAME
	CAME A,B	;$$IF THE VALUE IS THE SAME THEN WE HAVE A LOOP
	CAIN A,UNBOUND(S)
	JRST UNDTAC
	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
	MOVEI A,NIL	;$$ MORE FOR IMPLIED PROG
	MOVE T,B	;$$
	PUSHJ P,COND2+1	;$$ INSTEAD OF EVAL
	HRRZ T,%ARG
	POP P,%ARG
	SUBI T,1-INUM0(P)
	HRLI T,-1(T)
	ADD P,T
	JRST UNBIND

ARG:	HRRZ A,@%ARG
	POPJ P,

REMOTE<%ARG:	XWD A,0>
SETARG:	HRRZM B,@%ARG
	JRST PROG2
PAGE
BIND:	JUMPE A,BNDERR	;$$CAN'T REBIND NIL
	CAIN A,TRUTH(S)	;$$SHOULDN'T REBIND T
	JRST BNDERR	;$$
	PUSH P,B
	HRRZM A,BIND3#
BIND2:
	MOVEI B,VALUE(S)	;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)

	HRRM AR1,(A)	;$$THIS WAS HHRZM AR1,(A) WHICH CLOBBERED ATOM POINTER IN MY SYSTEM
POPBJ:	POP P,B
	POPJ P,

BIND1:
	MOVEI B,UNBOUND(S)

	MOVE A,BIND3	;$$SET UP ATOM POINTER FROM SPECIAL CELL
			;$$THIS WAS MOVEI A,0
	PUSHJ P,CONS
	HRRZ B,@BIND3
	PUSHJ P,CONS
	MOVEI B,VALUE(S)
	PUSHJ P,XCONS
	HRRM A,@BIND3
		MOVE A,BIND3
	JRST BIND2

UBD:	CAMG SP,B
	POPJ P,


	HLRZ	TT,(SP)	;$$SKIP OVER EVAL BLIPS ETC.
	JUMPE	TT,.+2	;$$IF EQUAL TO 0 IT WAS AN EVAL BLIP
	JRST	PJUBND
	SUB	SP,[XWD 2,2]	;$$DECREMENT SPDL
	JRST	UBD		;$$GO BACK AND CHECK

PJUBND:	PUSHJ P,UNBIND
	JRST UBD

UNBIND:
SPECSTR:	MOVE TT,(SP)
	CAMN	SP,SC2	;$$CHECK TO AVOID OVERSHOOT
	POPJ	P,	;$$

	SUB SP,[XWD 1,1]
	JUMPGE TT,UNBIND	;syncronize stack
UNBND1:	CAMN SP,TT
	POPJ P,
	POP SP,T


	CAIN T,(T)	;$$CHECK TO SKIP OVER NEW ITEMS PUT ON SPDL
			;$$ALL SUCH ITEMS HAVE 0 LEFT HAND SIDES
	JRST PROGUB	;$$THIS IS AN EVAL BLIP - CHECK IF A PROG

	MOVSS T

	HLRM T,(T)	;$$CHANGED FROM HLRZM T,(T) TO PROTECT NEW ATOM POINTER

	JRST UNBND1


PROGUB:	HLRZ T,(T)	;$$CHECK FOR A PROG
	CAIE T,PROGAT+1(S)	;$$CHECK IF IT IS A PROG
	JRST PROGU1	;$$NOT A PROG, SKIP IT AND GO ON
	MOVE T,(SP)	;$$GET THE RPDL POINTER FOR PROG INTO T
	ADDI T,2	;$$INCREMENT TO GET TO WHERE PA3,PA4 SAVED
	POP T,PA4	;$$RESTORE PA4
	POP T,PA3	;$$AND PA3 FROM WHERE THEY WERE SAVED
PROGU1:	POP SP,T	;$$ POP RPDL POINTER
	JRST UNBND1	;$$AND GO ON WITH THE UNBINDING



SPECBIND:	MOVE TT,SP
SPEC1:	LDB R,[POINT 13,(T),ACFLD]
	CAILE R,17
	JRST SPECX
	SKIPE R
	MOVE R,(R)
	HLL R,@(T)	;$$AGAIN SAVE THE POOR LITTLE ATOM POINTER
	EXCH R,@(T)
	HRLI 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,
	PAGE
	SUBTTL ARRAY SUBROUTINES  

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)
	MOVEM A,VBPORG(S)
	POPJ P,

ARRAYS:	PUSH P,A
	MOVE A,VBPORG(S)
	SUBI A,INUM0
	MOVEM A,BPPNR
	MOVE A,VBPEND(S)
	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
	MOVEI C,SUBR(S)
	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
	ADD	AR2A,A		;%% SOME PEOPLE HAVE PROBLEMS
	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
GTBLK:	MOVNI C,-INUM0(A)	;##COMPUTE NEGATIVE LENGTH
	MOVE A,VBPORG(S)	;## GET BPORG
	HRRI A,-INUM0(A)	;## CONVERT
	HRLM C,(A)		;## MOVE TO BPORG INFO FOR (GC)
	HRRM A,(A)		;##
	AOS R,(A)		;## ADD ONE TO INFO AND MOVE TO R
	SUBI R,1		;## SET PUSH DOWN POINTER(ASSUME POINTER BLOCK)
	CAIN B,0		;## IS IT A POINTER BLOCK?
	SUBI R,1		;## NO
	MOVE AR1,VBPEND(S)	;## GET BPEND
	MOVNI AR1,-INUM0(AR1)	;## CONVERT TO NEGATIVE
	ADD AR1,R		;## BPORG-BPEND +(0 OR 1)
	HRLI R,(AR1)		;## MOVE TO R FOR TESTING FOR BPS EXCEEDED
	PUSH R,[0]		;## CLEAR THE SPACE, NOTE THAT IF IT IS NOT
	AOJN C,.-1		;## WE WILL ALSO CLEAR THE INFO LOCATION
	HRRZI R,INUM0+1(R)	;## COMPUTE NEW BPORG
	HRRM R,VBPORG(S) 
	CAIN B,0		;## IF IT WAS NOT A POINTER BLOCK, DONE
	POPJ P,
	MOVE B,GCMKL		;## GET GC'S LIST
	PUSHJ P,CONS		;## CONS
	MOVEM A,GCMKL		;## SAVE IT
	HLRZ A,(A)		;GET THE OLD BPORG BACK
	AOJA A,.-5		;## ADD ONE AND RETURN


BLKLST:	PUSH	P,A		;## SAVE LIST
	CAIE	B,0		;## BLK LENGTH GIVEN
	SKIPA	A,B		;## YES
	PUSHJ	P,LENGTH	;## NO, USE LENGTH OF LIST
	MOVEI	B,(A)		;## GET A POINTER BLOCK FROM GTBLK
	PUSHJ	P,GTBLK
	POP	P,B		;## GET LIST BACK
	PUSH	P,A
	HRRZI	R,-1(A)		;## SET UP PDL
	HLRE	C,(R)		;## NEG LENGTH FROM GC INFO.
BLKLS1:	HRRI	A,1(A)		;## BUMP A FOR CDR

IFN	OLDNIL<			;## IF(CDR NIL)#NIL
	TRNE	B,-1		;## END OF LIST?
	SKIPA	B,(B)		;## NO
	SETZ	B,		;## YES,  REST  OF BLOCK IS NIL
	>

IFE OLDNIL<
	MOVE	B,(B)		;##  IF  (CDR  NIL )=NIL
	>

	HLL	A,B		;## GET (CAR LIST)
	PUSH	R,A		;## AND STORE
	AOJL	C,BLKLS1	;## SEE IF DONE
	HLLZM	A,(R)		;## SET (CDR (LAST BLOCK)) TO NIL
	JRST	POPAJ		;## AND RETURN POINTER TO THE BLOCK


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,
	
	PAGE
	SUBTTL EXAMINE, DEPOSIT , ETC 

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
	XCT BOOLI
REMOTE<
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:PUSHJ P,NUMVAL
	MOVE A,(A)
	JRST FIX1A

DEPOSIT: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

	PAGE
	SUBTTL GARBAGE COLLECTER   

;garbage collector

GC:	PUSHJ P,AGC
	JRST FALSE

AGC:	SETOM	GCFLG	;SET GCFLAG INCASE OF USER CONTROL-C
	MOVEM R,RGC#
GCPK1:	PUSH P,PA3
	PUSH P,PA4
IFE OLDNIL	<PUSH	P,NILPRP	;##  PROP LIST OF NIL>
	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
	PUSH	P,INITF1	;## INIT FILE LIST
GCPK2:	PUSH P,[XWD 0,GCP6]	;this is a return address
	JRST GCP4
REMOTE<
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
	JRST GCRET1>
GCRET1:	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#
	MOVE C,GCP3#	;.=bottom of reg pdl
GCP6B:	MOVE S,P
	HLL C,P
	MOVEI B,0
GC1:	CAMN C,S
	POPJ P,
	HRRZ A,(C)
GCPI:	CAMGE A,GCP#	;.=bottom of bit tables
REMOTE<
GCPP1:
XXX5:FS>
	CAMGE A,GCPP1
	JRST GCEND
	CAML A,GCP1#	;.=bottom of full word space (fws)
	JRST GCMFW
	MOVE F,(A)
	LSHC A,-5
	ROT B,5
	MOVE AR1,GCBT(B)
	TDOE AR1,@GCBTP2	;bit tab- (fs_-5), .=magic number for sync
	JRST GCEND
	MOVEM AR1,@GCBTP1	;bit tab- (fs_-5)
	PUSH P,F
	HLRZ A,F
	JRST GCPI
REMOTE<
GCBTP1:	XWD A,0
GCBTP2:	XWD A,0
GCMFWS:	XWD A,0>

GCMFW:	MOVEI AR1,@GCMFWS	;.=- 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 GCPI
REMOTE<
	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
	JRST	XXX3
REMOTE<
XXX3:	MOVEI R,FS	;$$ANOTHER FOOLIST REMNANT
GCBTL1:	HRLI R,X	;-(32-<fs&37>
	MOVE S,(D)
GCBTL2:	ROT S,X	;fs&37
	AOBJN D,GFSP1
	JRST GFSPR>
GFSPR:	MOVE A,C1GCS
	MOVE B,C2GCS
	PUSHJ P,GCS0
	SKIPN GCGAGV
	JRST GCSPI1
	MOVE B,F
	PUSHJ P,GCPNT
	STRTIP [SIXBIT / FREE STG,!/]
	MOVE B,FF
	PUSHJ P,GCPNT
	STRTIP [SIXBIT / FULL WORDS AVAILABLE_!/]
GCSPI1:	HRLZ S,GCSP1#	;bottom of reg pdl+1
	BLT S,NACS+3	;reload ac's
	SUB P,[XWD GCPK2-GCPK1,GCPK2-GCPK1]	;restore p
	AOSN	GCFLG		;CHECK FLAG FOR PENDING INTERRUPT
	JRST	GCEXIT		;NO- SO NORMAL EXIT
	POP	P,JOBOPC	;INTERRUPT WILL CONTINUE FROM THE GC RETURN
	PUSH	P,GCFLG		;GC WILL RETURN TO THE INTERRUPT POINT
	SETZM	GCFLG		;CLEAR GCFLG
GCEXIT:	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
	MOVE S,ATMOV	;$$RESTORE ATOM OFFSET RELOCATOR (FOOLIST)
			;$$HOPEFULLY S IS USED ONLY BY GC AND ATOM RELOCATION

	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,

REMOTE<
C1GCS:	0	;(- length of fws) bottom of fws
C2GCS:	XWD 100,0	;.=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

	IFN	REALLC <
;%%	NEW ROUTINES TO COUNT AVAILABLE
;%%	FREE SPACE AND FULL WORD SPACE

FSCNT:	TDZA	C,C		;%% INITIALIZE
FWCNT:	MOVEI	C,1		;%%
	MOVE	B,F(C)		;%% FREE LIST START
	SETZ	A,		;%% COUNTER
	JUMPE	B,FIX1A		;%% WHEN DONE, NO MORE POINTER
	HRRZ	B,(B)		;%%
	AOJA	A,.-2		;%%
>

GCING:	OUTSTR	[ASCIZ /
GARBAGE COLLECTING
/]
	POP	P,GCFLG	;CAN'T INTERRUPT GC, QUEUE UP THE REQUEST
	JRST	@JOBOPC
	
	PAGE
	SUBTTL	SYMBOL TABLE ACCESSING ROUTINES


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



	;## NEW ROUTINES FOR CONVERTING  SYMBOLS TO CONS CELL

SYMERR:	MOVE	A,B
SYMER1:	PUSHJ	P,EPRINT		;## PRINT OFFENDER
	ERR1	[SIXBIT /NOT A CONS CELL !/]
	;## **CAUSES ERROR IF NOT IN FREE STORAGE**
RGTSYM:	PUSHJ	P,GETSYM
	PUSHJ	P,NUMVAL	;## CONVERT TO REAL ADDRESS
	ADDI	A,(S)		;## ADD  RELOCATION
	CAIL	A,FS(S)		;## LESS THAN FS(S) IS NOT CONS CELL
	CAML	A,FWSO		;## FS(S)<= A < FWSO IS A CONS CELL
	JRST	SYMER1
	POPJ	P,

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


	;## ROUTINE TO STORE A CONS CELL SO THAT IT CAN BE
	;## REFERENCED VIA  ,CELL(S) I.E. THRU INDEX REG. S
	;## ERROR IF NOT LEGITIMATE CONS CELL
RPTSYM:	CAIL	B,FS(S)		;## FS(S) =< B <FWSO IS A LEGIT
	CAML	B,FWSO		;## CONS CELL, ALL ELSE IS ERROR
	JRST	SYMERR		;## ERROR
	SUBI	B,(S)		;## STRIP OF RELOCATION

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

PATCH:	BLOCK 20

	PAGE
	SUBTTL	SPRINT -- THE PRETTY PRINTER


;THIS IS THE NEW IMPROVED VERSION OF SPRINT
 
;  0(P) = A
; -1(P) = B
; -2(P) = C
; -3(P) = M
; -4(P) = N
; -5(P) = X


SPRINT:	SUBI B,INUM0
SPRNT2:	PUSH P,A
	PUSH P,B
	SETZM M#
	SETZM CSW#
	MOVEM P,STP#
	MOVEI B,0
	PUSHJ P,DEPTH
	SKIPN B,M
	JRST .+6
	MOVE A,LINL
	SUB A,B
	SUB A,B
		IDIV A,B
	CAILE A,14
	MOVEI A,14
	MOVEM A,CUT#
	MOVE A,0(P)
	IDIV A,LINL
	CAIG B,0
	ADD B,LINL
	MOVEM B,0(P)
	MOVEI C,0
	JRST .+3
 
ISPRIN:	PUSH P,A
	PUSH P,B
	PUSH P,C
	PUSH P,[0]
	PUSH P,[0]
	PUSH P,[0]
	MOVE A,B
	SUB B,LINL
	JUMPLE B,.+3
	MOVE A,B
	MOVEM A,-4(P)
	PUSHJ P,POS
	MOVE A,-5(P)
	PUSHJ P,PATOM
	JUMPE A,.+4
SPRN1:	MOVE A,-5(P)
	PUSHJ P,PRIN1
	JRST SPRN22
	MOVE B,LINL
	SUB B,-4(P)
	ADDI B,1
	MOVEM B,0(P)
	SUB B,-3(P)
	MOVE A,-5(P)
	PUSHJ P,FLATLE
	JUMPN A,SPRN1
	MOVEI A,50
	PUSHJ P,TYO
	AOS -4(P)
	SOS 0(P)
	HRRZ A,@-5(P)
	PUSHJ P,PATOM
	JUMPN A,SPRN13
	HLRZ A,@-5(P)
	CAIN A,LAMBDA(S)
	JRST LAM
	CAIN A,PROGAT+1(S)
	JRST PRG
	PUSHJ P,PATOM
	JUMPE A,SPRN3
	HLRZ A,@-5(P)
	PUSHJ P,PRIN1
	MOVE A,0(P)
	SUB A,CHCT
	MOVEM A,-1(P)
	CAIG A,24
	JRST SPRN4
	JRST SPRN12+4
SPRN3:	MOVE B,0(P)
	CAILE B,20
	MOVEI B,20
	HLRZ A,@-5(P)
	PUSHJ P,FLATLE
	JUMPE A,SPRN12
	MOVEM A,-1(P)
SPRN4:	HRRZ A,@-5(P)
	MOVEM A,-2(P)
	HRRZ A,0(A)
	PUSHJ P,PATOM
	JUMPN A,SPRN8
	MOVE B,-1(P)
	CAMG B,CUT
	JRST SPRN2
	SKIPE CSW
	JRST SPRN8
	MOVE A,0(P)
	SUB A,B
	SUBI A,1
	MOVEM A,-1(P)
	JRST SPRN5
SPRN2:	HLRZ A,@-5(P)
	PUSHJ P,PATOM
	JUMPN A,.+3
	HLRZ A,@-5(P)
	PUSHJ P,PRIN1
	HRRZ A,@-5(P)
	MOVEM A,-5(P)
	MOVE A,-4(P)
	ADD A,-1(P)
	ADDI A,1
	MOVEM A,-4(P)
	JRST SPRN12
SPRN5:	MOVE B,-1(P)
	HLRZ A,@-2(P)
	PUSHJ P,FLATLE
	JUMPE A,SPRN8
	HRRZ A,@-2(P)
	MOVEM A,-2(P)
	HRRZ A,0(A)
	PUSHJ P,PATOM
	JUMPE A,SPRN5
	HRRZ B,@-2(P)
	JUMPN B,.+3
	MOVE B,-1(P)
	SOJA B,SPRN7
	HRRZ A,@-2(P)
	PUSHJ P,FLATSI
	SUBI A,INUM0-4
	SUB A,-1(P)
	MOVN B,A
SPRN7:	SUB B,-3(P)
	HLRZ A,@-2(P)
	PUSHJ P,FLATLE
	JUMPN A,SPRN18
SPRN8:	HLRZ A,@-5(P)
	PUSHJ P,PATOM
	JUMPN A,.+3
SPRN9:	HLRZ A,@-5(P)
	PUSHJ P,PRIN1
	HRRZ A,@-5(P)
	MOVEM A,-5(P)
	CAMN A,-2(P)
	JRST SPRN11
	MOVE A,-4(P)
	PUSHJ P,POS
	JRST SPRN9
SPRN11:	HRRZ A,@-5(P)
	PUSHJ P,PATOM
	JUMPN A,SPRN13
SPRN12:	MOVEI C,0
	MOVE B,-4(P)
	HLRZ A,@-5(P)
	PUSHJ P,ISPRIN
	HRRZ A,@-5(P)
	MOVEM A,-5(P)
	JRST SPRN11
SPRN13:	HRRZ A,@-5(P)
	JUMPE A,.+4
	PUSHJ P,FLATSI
	SUBI A,INUM0-3
	ADDM A,-3(P)
	AOS -3(P)
	MOVE C,-3(P)
	MOVE B,-4(P)
	HLRZ A,@-5(P)
	PUSHJ P,ISPRIN
SPRN16:	HRRZ A,@-5(P)
	JUMPE A,SPRN17
	MOVEI A,40
	PUSHJ P,TYO
	MOVEI A,56
	PUSHJ P,TYO
	MOVEI A,40
	PUSHJ P,TYO
	HRRZ A,@-5(P)
	PUSHJ P,PRIN1
SPRN17:	MOVEI A,51
	PUSHJ P,TYO
	JRST SPRN22
SPRN18:	HLRZ A,@-5(P)
	PUSHJ P,PATOM
	JUMPN A,.+3
	HLRZ A,@-5(P)
	PUSHJ P,PRIN1
	MOVEI A,40
	PUSHJ P,TYO
	HRRZ A,@-5(P)
	MOVEM A,-5(P)
	MOVE A,LINL
	SUB A,CHCT
	ADDI A,1
	MOVEM A,-4(P)
	HRRZ A,@-5(P)
	PUSHJ P,PATOM
	JUMPN A,SPRN21
SPRN19:	HLRZ A,@-5(P)
	PUSHJ P,PRIN1
	HRRZ A,@-5(P)
	MOVEM A,-5(P)
	HRRZ A,0(A)
	PUSHJ P,PATOM
	JUMPN A,.+4
	MOVE A,-4(P)
	PUSHJ P,POS
	JRST SPRN19
	MOVE A,-4(P)
	PUSHJ P,POS
SPRN21:	HLRZ A,@-5(P)
	PUSHJ P,PRIN1
	JRST SPRN16
LAM:	PUSHJ P,PRIN1
	HRRZ A,@-5(P)
	MOVEM A,-5(P)
	MOVE B,-4(P)
	MOVEM B,-1(P)
	HLRZ A,0(A)
	PUSHJ P,PATOM
	MOVEI B,6
	CAIE A,NIL
	ADDI B,1
	ADDM B,-4(P)
	HRRZ A,@-5(P)
	PUSHJ P,PATOM
	JUMPN A,SPRN13
	MOVEI C,0
	MOVE B,-4(P)
	HLRZ A,@-5(P)
	PUSHJ P,ISPRIN
	MOVE B,-1(P)
	MOVEM B,-4(P)
	JRST SPRN12+4
PRG:	PUSHJ P,PRIN1
	HRRZ A,@-5(P)
	MOVEM A,-5(P)
	MOVE A,-4(P)
	MOVEM A,-1(P)
	MOVEI A,5
	ADDM A,-4(P)
	HRRZ A,@-5(P)
	PUSHJ P,PATOM
	JUMPN A,SPRN13
	MOVEI C,0
		MOVE B,-4(P)
	HLRZ A,@-5(P)
	PUSHJ P,ISPRIN
	MOVE A,0(P)
	SUBI A,5
	MOVEM A,-2(P)
PRG1:	HRRZ A,@-5(P)
	MOVEM A,-5(P)
	HRRZ A,0(A)
	PUSHJ P,PATOM
	JUMPN A,PRG3
	HLRZ A,@-5(P)
	PUSHJ P,PATOM
	JUMPE A,PRG2
	MOVE A,-1(P)
	PUSHJ P,POS
	HLRZ A,@-5(P)
	PUSHJ P,PRIN1
	JRST PRG1
	PRG2:	MOVE A,CHCT
	CAMG A,-2(P)
	PUSHJ P,TERPRI
	MOVEI C,0
	MOVE B,-4(P)
	HLRZ A,@-5(P)
	PUSHJ P,ISPRIN
	JRST PRG1
PRG3:	HLRZ A,@-5(P)
	PUSHJ P,PATOM
	JUMPE A,SPRN13
	MOVE B,-1(P)
	MOVEM B,-4(P)
	JRST SPRN13
SPRN22:	MOVEI A,NIL
	SUB P,[XWD 6,6]
	POPJ P,
 
POS:	PUSH P,A
	PUSH P,[0]
	MOVE A,LINL
	SUB A,CHCT
	ADDI A,1
	PUSH P,A
	CAMN A,-2(P)
	JRST POS4
	CAMG A,-2(P)
	JRST .+4
	PUSHJ P,TERPRI
	MOVEI A,1
	MOVEM A,0(P)
	SUBI A,1
	LSH A,-3
	ADDI A,1
	LSH A,3
	ADDI A,1
	MOVEM A,-1(P)
	CAMLE A,-2(P)
	JRST POS3
POS2:	MOVEI A,11
	PUSHJ P,TYO
	MOVE A,-1(P)
	MOVEM A,0(P)
	ADDI A,10
	JRST POS2-3
POS3:	AOS A,0(P)
	CAMLE A,-2(P)
	JRST POS4
	MOVEI A,40
	PUSHJ P,TYO
	JRST POS3
POS4:	SUB P,[XWD 3,3]
	POPJ P,
 
FLATLE:	JUMPLE B,ABORT+1
	SETZM M
	MOVEM B,N#
	MOVEM P,STP
SCAN:	PUSH P,A
	PUSHJ P,PATOM
	JUMPN A,EXIT1-6
NA:	AOS A,M
	CAMLE A,N
	JRST ABORT
	HLRZ A,@0(P)
	PUSHJ P,SCAN
	HRRZ A,@0(P)
	MOVEM A,0(P)
	JUMPN A,.+3
	AOS A,M
	JRST EXIT1-2
	MOVE A,0(P)
	PUSHJ P,PATOM
	JUMPE A,NA
	MOVEI A,4
	ADDB A,M
	CAMLE A,N
	JRST ABORT
	MOVE A,0(P)
	PUSHJ P,FLATSI
	SUBI A,INUM0
	ADDB A,M
	CAMLE A,N
	JRST ABORT
EXIT1:	SUB P,[XWD 1,1]
	POPJ P,
ABORT:	MOVE P,STP
	MOVEI A,NIL
	POPJ P,
 
DEPTH:	PUSH P,A
	PUSH P,B
	PUSHJ P,PATOM
	JUMPN A,D2
	AOS A,0(P)
	CAMLE A,LINL
	JRST OUT+1
	CAMLE A,M
	MOVEM A,M
	MOVE A,-1(P)
	PUSH P,A
	PUSH P,[0]
D1:	HLRZ A,@-3(P)
	MOVE B,-2(P)
	PUSHJ P,DEPTH
	HRRZ A,@-3(P)
	MOVEM A,-3(P)
	MOVE B,-1(P)
	SETCMB C,0(P)
	JUMPN C,.+3
	HRRZ B,0(B)
	MOVEM B,-1(P)
	CAMN A,B
	JRST OUT
	PUSHJ P,PATOM
	JUMPE A,D1
	SUB P,[XWD 2,2]
D2:	SUB P,[XWD 2,2]
	POPJ P,
	OUT:	SETOM CSW
	MOVE P,STP
	JRST @1(P)
;
;
;(TAB X) TABS TO POSITION X DOING A (TERPRI) IF NECESSARY
;
.TAB:	PUSHJ	P,NUMVAL
	PUSHJ	P,POS		;LET POS IN SPRINT DO THE WORK
	JRST	FALSE

	PAGE
	SUBTTL ALVINE AND LOADER INTERFACES   

;interface to alvine

IFN ALVINE,<
ED:	MOVE 10,EDA
	JRST (10)
	PUSH P,A
	HRRZ A,CORUSE
	HRRM A,LST
	AOS A
	HRRM A,EDA#


	HRRM	A,ED1	;$$SAVE REENTRY TO EDITOR
	AOS	ED1#	;$$

	MOVSI A,(SIXBIT /ED/)
	SETZ	D,	;THAT RELOCATION AGAIN - SEE BELOW
	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:
IFN ALVINE<
	MOVEI A,ED+2
	HRRM A,EDA>
	MOVE A,JRELO
	SETZM LDFLG#	;initial loader symbol table flag
	CALLI A,CORE
	JRST .+1
	JSP R,IOBRST
	JRST TRUE

PAGE

;	lisp loader interface
;	REG. D IS USED SINCE VARIABLES ARE MOVE WHEN LISP IS REENTRANT
LOAD:	AOS B,CORUSE
	MOVEM B,OLDCU#
	MOVEM A,LDPAR#
	JUMPE A,LOAD2
	MOVE B,VBPORG(S)
	SUBI B,INUM0
LOAD2:	MOVEM B,RVAL#	;final destination of loaded code
	MOVSI A,(SIXBIT /LOD/)
	SETZ	D,
	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
	MOVE D,A	;THIS IS THE RELOCATION, THE LOADER WILL SAVE IT
	BLT A,(B)	;blt up low lisp
	HLL A,NAME+3(D)	;-length(loader)
	HRRI A,137-1
	PUSHJ P,SYSINP
	SKIPE LDFLG(D)
	JRST LOAD3
	SETOM LDFLG(D)
	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(D)	;-length(symbols)
	ADDB A,B
	HLL A,NAME+3(D)	;symbol table iowd
	PUSHJ P,SYSINP
	HRRM B,JOBSYM
	HLLZ A,NAME+3(D)
	ADDM A,JOBSYM
	SKIPA
LOAD3:	SOS JOBSYM	;want jobsym to point one below 1st symbol
	MOVE 3,HVAL(D)	;h
	MOVE 5,RVAL(D)	;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#(D)	;last location loaded(in final area)
	MOVE T,OLDCU(D)
	MOVE A,JOBSYM
	MOVEM A,JOBSYM(T)
	MOVE A,JOBREL
	MOVEM A,JOBREL(T)	;update jobrel
	HRLZ 0,LOWLSP(D)
	SOS LODSIZ(D)
	AOBJN 0,.+1
	BLT 0,@LODSIZ(D)	;blt down low lisp
	MOVE 0,@LOWLSP	;EVERY THING IS FIXED, DON'T NEED REG. D ANYMORE
	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
	CALLI C,CORE	;contract core
	JRST .+1
	JRST START

BINLD:	MOVEI C,INUM0(B)
	CAML C,VBPEND(S)
	JRST [	SETOM BPSFLG	;bps exceeded
		JRST START]
	MOVEM C,VBPORG(S)	;updat bporg
	SOS C,OLDCU	;old top of core
	JRST LDRET2

	PAGE

SYSINI:	MOVEM A,NAME+1(D)
	;%% FOLLOWING IS OLD, NON-PATCHABLE CHANNEL OPEN
	COMMENT &
	IFN SYSPRG,<	MOVE A,[XWD SYSPRG,SYSPN]
			MOVEM A,NAME+3(D)>
	IFE SYSPRG,<	SETZM NAME+3(D)>
	INIT	17
	SYSDEV
	0
	JRST AIN.4+1
	&		;%% END OF OLD CODE
	;%% NEW PATCHABLE CODE (DEVICE NAME IN LOW SEGMENT)
	MOVE	A,SYSIN1(D)	;%% PICK UP PPN
REMOTE<
SYSIN1:	XWD	SYSPRG,SYSPN	;%% KEEP IN LOW SEGMENT
>
	MOVEM	A,NAME+3(D)	;%% RESET VALUE HERE
	MOVEI	A,17		;%% SET DATA MODE 
	MOVEM	A,SYSIN0(D)	;%%
	OPEN	0,SYSIN0(D)	;%% OPEN CHANNEL 0 TO READ FILE
	JRST	AIN.4+1		;%% ERROR IN OPEN IF HERE
REMOTE<
SYSIN0:	17			;%% DUMP MODE I/O
	SYSDEV			;%% INITIALLY SYSTEM DEVICE
				;%% MAY BE PATCHED
				;%% NOTE THAT THIS MAY REMAIN "SYS"
				;%% WHEN HGHDAT IS CHANGED TO
				;%% SOMETHING ELSE
	0			;%% NO BUFFERING
>
	LOOKUP NAME(D)
	JRST AIN.7+1
	MOVE	A,[IOWD 1,NAME+3]	;KLUDGE BECAUSE OF REG. D
	ADD	A,D
	MOVEM	A,INLOW(D)
	INPUT	INLOW(D)	;INPUT SIZE OF FILE
REMOTE<
INLOW:	IOWD 1,NAME+3
	0>
	HLRO A,NAME+3(D)
	POPJ P,

REMOTE<
NAME:	SYSNAM
	0
	0
	0>

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

REMOTE<
LST:	0
	0>
PAGE
MOVDWN:	HRLM	B,JOBSA	;##SAVE NEW JOBSA
	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(D)
	SUBM	A,B	;NEEDED-JOBSYM-CORUSE(IE.  NEEDED-FREE)
	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(D)
	ADDM A,CORUSE(D)
	MOVE A,B
	POP P,B
	POPJ P,
PAGE
	SUBTTL HIGH SEGMENT FUNCTIONS

REMOTE<VHGHORG:BHORG>
HGHCOR:	JUMPE	A,NOWRT	;EXPAND CORE AND SET WRITE STATUS
	PUSHJ	P,NUMVAL
	JUMPLE	A,FALSE
	CLEARB	C,WRTSTS
	CALLI	C,SETUWP
UWPERR:	ERR1	[SIXBIT /CAN'T CHANGE HIGH SEG. WRITE PROTECT!/]
	MOVE	B,VHGHORG
	ADD	B,A
	HRRZ	C,JOBHRL
	CAMG	B,C
	JRST	TRUE
	HRLZ	A,B
	CALLI	A,CORE
	ERR1	[SIXBIT /CAN'T EXPAND HIGH SEGMENT!/]
	JRST	TRUE
NOWRT:	MOVEI	A,1
	MOVEM	A,WRTSTS
	CALLI	A,SETUWP
	JRST	UWPERR
	JRST	TRUE

HGHORG:	SKIPE	A	;SET HIGH ORG. TO A AND RETURN OLD ORG.
	PUSHJ	P,NUMVAL
	PUSH	P,A
	MOVE	A,VHGHORG
	MOVEI	B,FIXNUM(S)
	PUSHJ	P,MAKNUM
	POP	P,B
	SKIPE	B
	MOVEM	B,VHGHORG
	POPJ	P,

HGHEND:	HRRZ	A,JOBHRL	;GET VALUE OF END OF HIGH SEG.
	MOVEI	B,FIXNUM(S)
	JRST	MAKNUM

;SETS THE GETSEG INFO. SO USER CAN HAVE OWN HIGH SEG.
SETSYS:	MOVE	T,A	;MOVE ARGUMENT FOR UIOSUB
	SETZM	DEV	;## ALLOW DEFAULT TO DSK:
	PUSHJ	P,IOSUB	;BREAKS DOWN THE SPECIFICATION
	MOVEM	A,HGHDAT+1	;SAVE THE FILE NAME
	MOVE	A,DEV		;GET THE DEVICE AND SAVE IT
	MOVEM	A,HGHDAT
	MOVE	A,PPN		;GET THE PPN AND SAVE IT
	MOVEM	A,HGHDAT+4
	JRST	FALSE		;RETURN NIL

REMOTE<WRTSTS: 1>

	PAGE
	SUBTTL REALLOC CODE     


	IFN	REALLC <
;%%	DYNAMIC REALLOCTION ROUTINE
;%%
;%%	ARGUMENTS:
;%%	 A = FULL WORD SPACE INCREMENT
;%%	 B = BINARY PROGRAM SPACE INCREMENT
;%%	 C = REGULAR PUSHDOWN LIST INCREMENT
;%%	 AR1 = SPECIAL PUSHDOWN LIST INCREMENT
;%%	 AR2A = FREE SPACE INCREMENT
;%%
;%%	ACTION:
;%%	 1) PERFORMS AN EXCISE
;%%	 2) ALLOCATES ADDITIONAL CORE AS REQUIRED
;%%		(IF IMPOSSIBLE, SIGNALS "CAN'T EXPAND CORE")
;%%	 5) UNBINDS ALL VARIABLES ON THE SPECIAL STACK
;%%	    AND CLEARS BOTH STACKS
;%%	 4) REALLOCATES SPACE ACCORDING TO SPECIFICATIONS
;%%		(NOTE THAT TOTAL CORE USED WILL BE ROUNDED
;%%		 UP TO A MULTIPLE OF 1K WORDS, AND ANY EXCESS
;%%		 WILL BE APPORTIONED TO FWS, RPDL, SPDL, AND 
;%%		 FS.)
;%%	 5) RESTARTS THE SYSTEM AT THE TOP LEVEL
;%%

REALL1:	JUMPE	A,.+2		;%%NO CONVERSION IF NIL
	PUSHJ	P,NUMVAL	;%%CONVERT TO BINARY
	ADDI	T,(A)		;%%ADD TO TOTAL BEING ACCUMULATED
	EXCH	A,(P)		;%%PUSH ON STACK
	JRST	(A)		;%%AND RETURN

REALLOC:
	SETZ	T,		;%% CLEAR ACCUMULATOR FOR ALLOC TOTAL
	MOVE	TT,B		;%% SAVE SECOND ARG DURING FIRST CALL
	PUSHJ	P,REALL1	;%% PROCESS FIRST ARG
	MOVE	A,TT		;%%
	PUSHJ	P,REALL1	;%% PROCESS SECOND ARG
	MOVE	A,C		;%%
	PUSHJ	P,REALL1	;%% PROCESS THIRD ARG
	MOVE	A,AR1		;%%
	PUSHJ	P,REALL1	;%% PROCESS FOURTH ARG
	MOVE	A,AR2A		;%%
	PUSHJ	P,REALL1	;%% PROCESS FIFTH ARG
	MOVE	A,-4(P)		;%% PICK UP FWS INCREMENT
	ADD	A,SFWS		;%% MAKE NEW TOTAL FWS
	IDIVI	A,44		;%% CALCULATE SPACE FOR BIT TABLE
	ADDI	T,1(A)		;%% ADD TO TOTAL
	MOVEM	T,(P)		;%% SAVE TOTAL (FS AMOUNT NOT NEEDED)
	PUSHJ	P,EXCISE	;%% CLEAR BUFFERS, ETC.
	POP	P,A		;%% GET TOTAL BACK
	SETZ	D,		;%% CLEAR RELOCATION REGISTER
				;%% (HERE WE GO AGAIN)
	PUSHJ	P,MORCOR	;%% ALLOCATE THE ADDITIONAL SPACE
	MOVE	B,SC2		;%% CLEAR STACKS AND UNBIND VARIABLES
	PUSHJ	P,UBD		;%%
	HRRZ	B,JOBREL	;%% GET NEW HIGH LIMIT
	CAMGE	B,JRELO#	;%% DID CORE GET SMALLER?
	HALT	.		;%% YES -- WE QUIT
	MOVEM	B,JRELO#	;%% RESET LIMIT
	HRLM	B,JOBSA		;%% 
	IFN	ALVINE <
	MOVEI	A,ED+2		;%%INDICATE ED WAS OVERWRITTEN
	HRRM	A,EDA		;%%SO THEY WILL BE RELOADED IF NEEDED
>
	SETZM	LDFLG		;%% INDICATE SYMBOLS GONE [1]
	MOVE	A,SFWS		;%% SAVE OLD VALUE
	MOVEM	A,OSFWS		;%%
	MOVE	A,FSO		;%%
	MOVEM	A,OFSO		;%%
	POP	P,A		;%% SPDL INCREMENT
	ADDM	A,SSPDL		;%% CHANGE TOTAL
	MOVN	AR2A,A		;%% SAVE JUST IN CASE
	POP	P,A		;%% RPDL INCREMENT
	ADDM	A,SRPDL		;%% CHANGE TOTAL
	MOVN	AR1,A		;%% SAVE AGAIN
	POP	P,A		;%% BPS TOTAL
	MOVEM	A,FSMOVE	;%% HOW MUCH TO MOVE FS
	ADDM	A,FSO		;%% NEW FS ORIGIN
	ADDM	A,SBPS		;%% BPS INCREMENT
	POP	P,A		;%% FWS INCREMENT
	ADDM	A,SFWS		;%% ADD TO TOTAL
	JRST	REALL2		;%% JUMP INTO REGULAR ALLOCATOR
				;%% (ALL DATA OFF STACK)
>


STRT:
INALLC:	HRRZ	A,JOBREL	;SEE IF CORE WAS EXPANDED
	CAMN	A,JRELO#	;OR NOT
	JRST	OUTALC		;NO EXPANSION - DON'T REALLOCATE
	CAMG	A,JRELO#	;CHECK TO SEE IF IT GOT SMALLER!
	JRST	4,0		;YES - BITCH
	MOVEM	A,JRELO#	;SAVE NEW CORE BOUND
	HRLM	A,JOBSA
IFN ALVINE,<
	MOVEI	F,ED+2		;INDICATE THAT ED WAS OVERWRITTEN
	HRRM	F,EDA		;SO ED AND GRINDEF WILL BE READ IN IF NEEDED>
	SETZM	LDFLG		;%% INDICATE SYMBOLS GONE [1]
INAGN:	SETZM	NOALIN#		;SET UP TO ASK FOR ALLOCATION
	OUTSTR	[ASCIZ /
ALLOC? (Y OR N) /]		;ASK USER IF HE WISHES TO SET UP
	INCHRW	C		;THE ALLOCATION INCREMENTS
	CAIGE	C,"O"
	SETOM	NOALIN#		;SET FLAG SO NO INPUT IS DONE LATER
SETFWS:	MOVE	A,SFWS#		;SAVE OLD SIZE OF FWS
	MOVEM	A,OSFWS#

	SKIPN	NOALIN		;SKIP QUESTIONS IF AUTOMATIC
	OUTSTR	[ASCIZ /
FULL WORD SP. = /]
	JSP	R,ALLNUM
	JUMPN	A,.+3
	SKIPE	INITFW#
	ADDI	A,440		;INITIAL ALLOCATION FOR FWS

	ADDM	A,SFWS#		;ADD EITHER USER INCREMENT OR 0 TO SFWS

	MOVE	A,FSO#		;SAVE OLD FS ORIGIN
	MOVEM	A,OFSO#		;FOR RELOCATION


	SKIPN	NOALIN		;SKIP IF USER DONE
	OUTSTR [ASCIZ /
BIN. PROG. SP. = /]
	JSP	R,ALLNUM
	ADDM	A,SBPS#
	MOVEM	A,FSMOVE#	;THE INCREMENT TO SBPS IS THE AMOUNT BY
	ADDM	A,FSO#		;THE FREE SPACE IS MOVED - UPDATE ORIGIN



	SKIPN	NOALIN		;SKIPIF USER DONE
	OUTSTR [ASCIZ /
REG. PDL. = /]
	JSP	R,ALLNUM
	JUMPN	A,.+3
	SKIPE	INITFW#		;CHECK IF INITIAL ALLOCATION
	ADDI	A,1000
	ADDM	A,SRPDL#
	MOVN	AR1,A		;SAVE IN CASE OF OVERFLOW


	SKIPN	NOALIN		;SKIP IF USER DONE
	OUTSTR [ASCIZ /
SPEC. PDL. = /]
	JSP	R,ALLNUM
	JUMPN	A,.+3
	SKIPE	INITFW#	;CHECK FOR INITIAL ALLOCATION
	ADDI	A,1000
	ADDM	A,SSPDL#
	MOVN	AR2A,A		;SAVE IN CASE OF OVERFLOW
IFN HASH,<
	SKIPN	INITFW
	SETOM	NOALIN
	SKIPN	NOALIN
	OUTSTR	[ASCIZ /
HASH = /]
	JSP	R,ALLNUM
	CAIG	A,BCKETS
	JRST	OCR
	HRRM	A,INT1
	MOVNS	A
	HRRM	A,RH4
	SETOM	HASHFG>
OCR:	OUTSTR	[ASCIZ /
/]
REALL2:	MOVE	A,JRELO#	;COMPUTE SIZE OF AVAILABLE CORE
	SUBI	A,FS		;SO THAT EXTRA CORE CAN BE DISTRIBUTED

	SUB	A,SBPS	;TAKE OFF CORE ALLOCATED FOR BPS
	SUB	A,SFS#		;TAKE OFF CORE IN PREVIOUS FS
	SUB	A,SBT#		;AND ASSOCIATED BIT TABLE
	SUB	A,SFWS		;TAKE OFF CORE NOW ALLOCATED TO FWS
	SUB	A,SRPDL		;TAKE OFF CORE NOW ALLOCATED TO RPDL
	SUB	A,SSPDL		;TAKE OFF CORE NOW ALLOCATED TO SPDL

	MOVE	F,SFWS		;ESTIMATE SIZE NEEDED FOR BTF
	IDIVI	F,44
	ADDI	F,1
	SUB	A,F		;AND TAKE IT OFF TOTAL
	MOVEM	F,SBTF#		;ALSO SAVE TO RESTORE LATER
	JUMPGE	A,ALOK		;MAKE SURE NO OVERFLOW
	OUTSTR	[ASCIZ /ALLOCATIONS ARE TOO LARGE
/]				; IF SO THEN RETRY
	MOVE	A,OSFWS
	MOVEM	A,SFWS		;RESTORE SIZE OF FWS
	MOVN	A,FSMOVE
	ADDM	A,SBPS		;RESET SIZE OF BPS
	ADDM	A,FSO		;AND FS ORGIN
	ADDM	AR1,SRPDL	;RESET STACKS
	ADDM	AR2A,SSPDL
	JRST	INAGN

ALOK:	MOVE	B,A		;NOW CAN ALLOCATE EXCESS CORE
ACHLOC:	ASH	B,-4		;1/16 TO FWS
	ADDM	B,SFWS
	SUB	A,B		;TAKE IT OFF REMAINING CORE
	SKIPE	INITFW
	SETZ	B,
	ASH	B,-4		;1/64 TO PDLS
	ADDM	B,SSPDL
	SUB	A,B
	ADDM	B,SRPDL
	SUB	A,B		;AND TAKE IT OFF REMAINING CORE

	MOVE	T,SFWS		;CALCULATE ACTUAL SIZE OF BTF
	IDIVI	T,44
	ADDI	T,1
	ADD	A,SBTF		;REMOVE ESTIMATED LOSS FOR BTF
	MOVEM	T,SBTF
	SUB	A,T		;AND TAKE OFF ACTUAL LOSS TO BTF

	ADD	A,SFS		;ADD BACK ON SPACE FROM OLD FS
	ADD	A,SBT		;AND ASSOCIATED BT
				;GIVING NEW SPACE AVAILABLE FOR
				;FS AND BT
	MOVE	TT,A
	IDIVI	TT,41		;SBS = SFS/32.  = (SBS + SFS)/33.

	ADDI	TT,1
	MOVEM	TT,SBT

	SUB	A,TT		;TAKE OFF SBT FROM REMAINING CORE
	MOVEM	A,SFS		;GIVING AVAILABLE SFS


				;SET UP REGISTERS FOR GC ETC. SETUP

	MOVE	A,SFWS		;A _ SFWS
	MOVEI	B,FS
	ADD	B,SFS
	ADD	B,SBPS		;B _ NFWSO (ORIGIN OF NEW FULL WORD SPACE)
	MOVE	C,SRPDL		;C _ SRPDL
	MOVE	F,OSFWS		;F _ OLD SIZE OF FWS




	HRRM	B,GCP1		;GCP1 _ NFWSO
	MOVN	SP,B		;-NEW BOTTOM OF FWS

	HRRM	SP,GCMFWS
	HRLZM	A,C1GCS
	MOVNS	C1GCS		;-NEW LENGTH OF FWS
	HRRM	B,C1GCS		;HAVE FWS POINTER AND COUNT FOR SWEEP

	ADD	B,A		;NEW FIRST WORD OF BT (FS BIT TABLE)


	MOVE	SP,FSO		;SP _ NEW ORIGIN OF FS

	LSH	SP,-5
	SUBM	B,SP		;NUMBER USED TO FIND BIT TABLE WORD
	HRRM	SP,GCBTP1	;FROM FS WORD ADDRESS
	HRRM	SP,GCBTP2

	HRLM	B,C3GC		;BOTTOM OF BIT TABLES
	HRRM	B,GCP2
	HRRM	B,GCP		;(ALSO UPPER BOUND ON FWS AND FS)

	MOVNI	SP,-2(TT)	;-SIZE OF BT (TT = SBT)
	HRLM	SP,C3GCS	;IOWD FOR BIT TABLE SWEEP
	HRRM	B,C3GCS
	MOVE	SP,FSO
	ANDI	SP,37		;MASK OUT ALL BU LAST FIVE BITS
	HRRM	SP,GCBTL2	;MAGIC NUMBER TO POSITION
	SUBI	SP,40
	HRRM	SP,GCBTL1

	ADDI	B,1		;B _ B + 1
	HRRM	B,C3GC		;BOTTOM OF FS BIT TABLE + 1
	ADDI	B,-2(TT)	;GET BOTTOM OF BTF - 1, POINTER IS INCREMENTED
	HRRM	B,C2GCS		;BEFORE USE

	ADDI	B,1		;B _ B + 1
	HRRM	B,C2GC		;BOTTOM OF FWS BIT TABLE + 1
	ADDI	B,-1(T)		;SINCE T IS NOW SIZE OF BTF, NOT SBTF-1

	HRRM	B,GCP5		;TOP OF BIT TABLES
	ADDI	B,1		;BOTTOM OF REG PDL

	MOVE	S,ATMOV		;## S NOT SET IF LISP STARTED WITH CORE
				;## ALREADY EXPANDED, SO RESET IT
	HRRZI	A,OBTBL(S)	;GET OBLIST POINTER
				;## RHX2 IS NO LONGER PURE, WE WANT THE SYSTEM OBLIST
				;## THIS IS IT (I HOPE)3/28/73
	ADD	A,FSMOVE	;INCREMENT TO
				;ACCOUNT FOR MOVE OF FS
	MOVEM	A,(B)
	HRRM	B,GCP3		;ROOM FOR ACS DURING GC
	ADDI	B,1		;B _ B + 1
	HRRM	B,GCSP1
	HRRM	B,GCP4		;ROOM FOR ACS
	ADDI	B,10		;B _ B + 10
	HRRM	B,GCP41		;TOP OF AC AREA
	ADDI	B,1		;B _ B + 1
	HRRM	B,C2		;SET UP RPDL POINTER
	MOVNI	A,-20(C)	;A _ - (C -20) = -(SRPDL - 20)
	HRLM	A,C2		;THIS IS THE ACTUAL SIZE OF RPDL
				;TAKING INTO ACCOUNT THE AC AREA
	
	HRRZ	A,JRELO#	;TOP OF CORE - FOR SPDL PTR

	MOVN	B,SSPDL
	ADD	A,B
	HRL	A,B

	MOVEM	A,SC2#	;SET UP SPDL POINTER (I HOPE)
	MOVN	A,A	;CREATE OFFSET FOR STACK POINTERS
	ADDI	A,INUM0
	HRRZM	A,SPNM#
	SETZM	INITFW	;TURN OFF INITIAL ALLOCATION FLAG


	

			;RELOCATE THE FULL WORD SPACE
			;GCP1 HOLDS POINTER TO ORIGIN OF NEW FWS
			;FWSO# HOLDS POINTER TO ORIGIN OF OLD FWS
			;AND F HOLDS SIZE OF OLD FWS (AMOUNT TO BE MOVED)

	MOVSI	B,F
	HRR	B,GCP1
	MOVE	C,FWSO#
	HRRZI	AR2A,-1(C)	;TAKE THE OPPORTUNITY TO GET ADDRESS
				;OF END OF OLD FS (USED LATER)
	HRLI	C,F
	MOVE	A,@C	;GET WORD FROM END OF OLD FWS
	MOVEM	A,@B	;AND MOVE TO END OF NEW FWS
	SOJGE	F,.-2	;F COUNTS DOWN WORDS IN OLDFWS
			;END OF FWS RELOCATION

	MOVE	FF,FSMOVE	;GET FAST ACCESS TO RELOCATE SIZE FOR FS
	HRRZ	F,AR2A
	ADD	F,FF		;AND FIND WHERE TO PUT WORDS FROM
				;END OF OLD FS IN NEW FS



	HRRZ	AR1,GCP1	;COMPUTE FWS RELOCATION CONSTANT
	SUB	AR1,FWSO



			;RELOCATE FS - ALSO RELOCATE ALL
			;POINTERS TO FS AND TO FWS

REL1:	HLRZ	A,(AR2A)	;GET CAR POINTER OF OLD FS WORD
	JSP	R,REL4
	HRLM	A,(F)		;MOVE CAR TO NEW POSITION
	HRRZ	A,(AR2A)	;GET CDR PTR
	JSP	R,REL4		;CHECK FOR FS RELOCATE
	HRRM	A,(F)
	SUBI	F,1		;F _ F -1
	CAMLE	AR2A,OFSO	;CHECK TO SEE IF DONE
	SOJA	AR2A,REL1	;NO - GO LOOP
	HRRZ	A,GCMKL		;RELOCATE ARRAYS
	JSP	R,REL4
	HRRZ	D,A
	MOVEM	D,GCMKL
REL5:	HLRZ	AR2A,(D)
	MOVE	AR2A,(AR2A)
REL6:	HLRZ	A,(AR2A)
	JSP	R,REL4
	HRLM	A,(AR2A)
	HRRZ	A,(AR2A)
	JSP	R,REL4
	HRRM	A,(AR2A)
	AOBJN	AR2A,REL6
	HRRZ	D,(D)
	JUMPN	D,REL5
	SETZM	BIND3		;JUST IN CASE
	SKIPE	INITF		;DON'T FORGET THE INITFN
	ADDM	FF,INITF
	SKIPE	INITF1		;## DON'T FORGET THE INIT FILES
	ADDM	FF,INITF1	;##
	SKIPE	NOUUOF		;RELOCATE FLAGS
	ADDM	FF,NOUUOF
	SKIPE	BACTRF
	ADDM	FF,BACTRF
	SKIPE	GCGAGV
	ADDM	FF,GCGAGV
	SKIPE	RSTSW
	ADDM	FF,RSTSW
	JRST	RELFOO

REL4:	CAMGE	A,EFWSO		;SEE IF BEYOND END OF FWS
	CAMGE	A,OFSO		;OK - SEE IF MAYBE IN FS
	JRST	(R)
	CAMGE	A,FWSO		;SEE IF IN FWS
	JRST	.+3
	ADD	A,AR1		;RELOCATE FWS POINTER
	JRST	(R)
	ADD	A,FF		;RELOCATE FS POINTER
	JRST	(R)





RELFOO:	MOVE	S,SBPS		;S IS THE RELOCATOR FOR MOST MACRO
	MOVEM	S,ATMOV		;REFERENCES TO ATOMS AND FS
	MOVE	A,FSMOVE	;NOW IS THE TIME FOR ALL GOOD MEN TO
	ADDM	A,VBPEND(S)	;SET BPEND
IFE OLDNIL<	ADDM	A,NILPRP>	;## RESET NIL
	HRR	B,VOBLIST(S)	;## GET CURRENT VALUE OF OBLIST
	HRRM	B,RHX5		;## RESET WORD THAT POSTINDEXES OFF B
	HRRM	B,RHX2		;## RESET WORD POSTINDEXING OFF C
	ADDM	A,XXX3		;## RESET WIERD CODE 
	ADDM	A,XXX4		;## RESET UNBOUND
	ADDM	A,XXX5		;## RESET FS (SAME WORD AS FS),ALSO GCPP1
	MOVE	A,GCP1
	HRRZM	A,FWSO
	MOVE	A,C3GCS
	HRRZM	A,EFWSO#
OUTALC:	CLEARB	F,DDTIFG
	JSP	R,IOBRST
	JRST	START






		;SUBROUTINE FOR NUMBER INPUT
		;%% RETURNS 0 IF NOALIN # 0
		;%% SETS NOALIN # 0 IF ALTMOD IS INPUT
		;%% RETURNS 0 IF A BLANK IS INPUT
		;%% IGNORES OTHER NON-NUMERIC CHARACTERS EXCEPT
		;%% AS TERMINATORS OF NUMBERS


ALLNUM:	SETZB	A,ALLNM1#	;%% CLEAR A AND FIRST TIME FLAG
	SKIPE	NOALIN#
	JRST	(R)
	INCHRW	C
	CAIN	C,RUBOUT
	JRST	[OUTSTR [ASCIZ /XXX /]
		 JRST ALLNUM]
	CAIL	C,"0"
	CAILE	C,"9"
	JRST	BANGCK
	SETOM	ALLNM1#		;%% NOT FIRST TIME NOW
	ASH	A,3
	ADDI	A,-"0"(C)
	JRST	ALLNUM+3

BANGCK:	CAIE	C,15		;%% TERMINATE ON CR OR
	CAIN C,40		;%% TERMINATE ON BLANK
	JRST	(R)		;%%
	CAIN	C,ALTMOD	;%% ALTMODE (TERMINATOR)?
	JRST	[SETOM NOALIN#
		 JRST (R) ] 	;%% YES--TURN ON SWITCH AND RETURN
	SKIPE	ALLNM1#		;%% IGNORE LEADING JUNK?
	JRST	(R)		;%% NO--RETURN
	JRST	ALLNUM+3	;%% YES--LOOP


PAGE




IFN HASH,<
REHASH:
	MOVEI A,BFWS(S)
	PUSH P,A
	HRRM A,RHX2
	HRRM A,RHX5
	MOVS B,RH4#
	ADD B,S	;$$PUT IN ATOM MOVE OFFSET IN B, SINCE CAN'T
			;$$DOUBLE INDEX - THIS REMOVES THE FOO PROBLEM
			;$$IN THE NEXT THREE FOO'S

	HRRZI A,BFWS+1(B)
	MOVEM A,BFWS(B)
	AOBJN B,.-2
	SETZM BFWS(B)
	MOVSI AR2A,-BCKETS
	HRR AR2A,S	;$$PUT IN ATOM MOVE OFFSET IN AR2A TO AVOID
			;$$DOUBLE INDEXING WITH S IN REMOVING FOO
			;$$PROBLEM
RH1:
	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
	MOVEM A,OBLIST(S)
	JRST START>

	PAGE
	SUBTTL NEW FUNCTIONS TO MAKE USE OF MODIFIED SPECIAL PDL FOR ERRORS

;$$ROUTINE TO GET POINTER TO SPDL AND MAKE IT INTO AN INUM
SPDLPT:	HRRZ	A,SP	;$$CREATE A POINTER TO THE CURRENT TOP OF STACK
	ADD	A,SPNM
	POPJ	P,		;$$


;$$ROUTINE TO GET LEFT HAND SIDE OF SPDL ITEM INDICATED BY AN INUM FROM SPDLPT
SPDLFT:	SUB	A,SPNM	;$$CONVERT TO ADDRESS
	HLRE	A,(A)	;$$GET LEFT HAND ITEM
	JUMPL	A,TRUE		;$$IF IT IS NEGATIVE IT CAME FROM A STACK
				;$$POINTER AND WE RETURN T INSTEAD
	HRRZI	A,(A)		;$$CLEAR OUT LEFT HAND OF AC
	POPJ	P,		;$$RETURN - RETURNS NIL FOR LHS = 0

;$$ROUTINE TO GIVE RIGHT HAND SIDE OF SPDL ENTRY SPECIFIED BY AN INUM FROM SPDLPT
SPDLRT:	SUB	A,SPNM		;$$CONVERT TO AN ADDRESS
	HRRZ	A,(A)	;$$ALL RHS ITEMS ARE LEGAL, NO NEED FOR CHECK
	POPJ	P,		;$$

;$$ROUTINE TO GET POINTER TO NEXT EVAL BLIP ON SPDL
NEXTEV:	SUB	A,SPNM	;$$GET POINTER INSTEAD OF INUM
	HRRZ	T,SC2	;$$GET POINTER TO BOTTOM OF SPDL

SPDNLP:	CAMG	A,T	;$$CHECK IF HIT THE BOTTOM OF SPDL
	JRST	FALSE	;$$RETURN NIL IF NO MORE INTERESTING WORDS
	HLL	A,(A)	;$$TEST FOR WORD WITH 0 LHS
	TLZE	A,-1	;$$
	SOJA	A,SPDNLP	;$$NOT AN INTERESTING WORD, LOOK AGAIN
	ADD	A,SPNM	;$$FOUND AN INTERESTING WORD, CHANGE POINTER TO INUM
	POPJ	P,	;$$


;$$ROUTINE TO EVALUATE A VARIABLE IN AN EARLIER CONTEXT
;$$	MORE EFFICIENT THAN EVAL WITH ALIST
EVALV:	MOVE	C,A		;$$ MOVE AROUND FOR ATOM CHECK
	PUSHJ	P,ATOM	;$$
	EXCH	A,C		;$$
	SUB	B,SPNM		;$$
EVALV1:	CAIN	B,(SP)		;$$CHECK FOR END OF SPDL
	JRST	GETV		;$$VARIABLE NOT REBOUND - GET CURRENT VALUE
	SKIPGE	,(B)		;$$CHECK TO AVOID SPDL POINTERS ON  STACK
	AOJA	B,EVALV1	;$$
	HLRZ	T,(B)		;$$T_CAR(B)
	SKIPE	C		;$$
	HLRZ	T,(T)		;$$GET CAR OF SPECIAL CELL - ATOM POINTER
	CAIE	T,(A)		;$$COMPARE WITH ATOM TO BE EVALUATED
	AOJA	B,EVALV1	;$$NOT IT, LOOK SOME MORE
	HRRZ	A,(B)		;$$GET VALUE FROM SPDL
	POPJ	P,		;$$

GETV:	JUMPE	C,GETV1
	MOVEI	B,VALUE(S)		;$$ATOM NOT REBOUND, VALUE THEN IS 
	PUSHJ	P,GET		;$$
	JUMPE	A,UNBOND	;$$NOT BOUND AT ALL, GIVE UNBVAR MESSAGE
GETV1:	HRRZ	A,(A)		;$$GET CDR OF SPECIAL CELL
	POPJ	P,		;$$

UNBOND:	HRRZI	A,UNBOUND(S)	;$$RETURN ATOM UNBOUND
	POPJ	P,		;$$

;$$ROUTINE TO CLEAR SPECIAL PDL TO POSITION SPECIFIED BY INUM
CLRSPD:	MOVEI	B,-2-INUM0(A)	;$$ -2 TO GET OVER EVAL BLIP
	HLRZ	TT,SC2#	;$$GET REAL SPD POINTER WITH A LHS
	ADD	TT,B	;$$FIND OUT HOW MANY WORDS ARE USED
	ADD	B,SC2	;$$
	HRL	B,TT	;$$SET UP SPD POINTER
	JRST	UBD		;$$UBD DOES ALL THE WORK

;$$ROUTINE TO RETURN FROM SPECIAL PDL CONTEXT, SPECIFIED BY AN
;$$EVAL BLIP, WITH A GIVEN VALUE
OUTVAL:	PUSHJ	P,NEXTEV	;$$FORCE TO AN EVAL BLIP
	JUMPE	A,FALSE		;$$ NO EVAL BLIP, RETURN NIL
	HRLZI	C,(POPJ P,)	;$$ SET TYPE OF RETURN
	JRST	SPRE1		;$$ FINISH UP IN SPREDO


;$$ROUTINE TO RE-EVALUATE EXPRESSION FROM AN EVAL BLIP AND GO ON FROM
;$$ THAT CONTEXT (NOT A USER CALLABLE FUNCTION)
REVAL1:	HRRZ	P,1(SP)		;$$ RPDL POINTER IS UP ONE
	HRRZ	T,C2#		;$$
	HLRZ	TT,C2#		;$$
	ADD	TT,P		;$$
	SUB	TT,T		;$$
	HRL	P,TT		;$$
DOSET:	MOVE D,ERRTN	;$$ POP ERRSETS, LOAD CURRENT ERRSET
	SKIPE D		;$$DONE IF EMPTY
	CAMG D,P		;$$ COMPARE TO CURRENT RPDL
	XCT C		;$$ DONE, DO A STRANGE EXIT
	SUB D,[XWD 1,1]	;$$ GO DOWN A WORD
	POP D,ERRSW	;$$
	POP D,ERRTN	;$$
	SUB D,[XWD 2,2]	;$$ SKIP PROG JUNK
	JRST DOSET	;$$ TRY AGAIN



;$$ROUTINE TO CLEAR SPD TO A GIVEN POINT AND REDO FROM THERE
;$$ A CONTAINS AN SPD INUM POINTER, FORCE IT TO BE EVAL BLIP POINTER

SPREDO:	PUSHJ	P,NEXTEV	;$$FORCE TO EVAL BLIP POINTER
	JUMPE	A,CPOPJ		;$$RETURN NIL IF NO EVAL BLIP
	MOVE	B,A	;$$GET THE EXPRESSION
	SUB	B,SPNM
	HRRZ	B,(B)
	MOVE	C,[JRST EVAL]	;$$SET RETURN
SPRE1:	PUSH	P,B		;$$SAVE SPDL POINTER
	PUSHJ	P,CLRSPD	;$$CLEAR OUT SPD - INCLUDES RESTORING PROGS
	POP	P,A		;$$
	JRST	REVAL1

;$$ SPREVAL - SIMILAR TO OUTVAL BUT EVALUATES THE GIVEN VALUE
;$$AS OF THE SPECIFIED CONTEXT, EQUIVALENT TO:
;$$ (PROG2 (RPLACD (NUMVAL (SETQ A (NEXTEV A))) B) (SPREDO B))
;
SPREVAL:PUSHJ P,NEXTEV		;$$FORCE TO AN EVAL-BLIP
	JUMPE	A,CPOPJ		;$$RETURN NIL IF NO EVAL-BLIP
	JRST	SPRE1-1		;$$LET SPREDO FINISH UP


;$$COMPUTES A LISP POINTER TO A STACK ENTRY
STKPTR:	SUB	A,SPNM
	POPJ	P,

PAGE
	SUBTTL LOW SEGMENT INCLUDING REMOTE CODE
	RELOC	0
	HERE
VAR
XALL
	PAGE
	SUBTTL LISP ATOMS AND OBLIST	
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>)
ZY==<ZY-1>/5
Q1(ZY,ZZ)
>

DEFINE Q1 (N,Z)<
IFN N,<XWD Z,[Q1(N-1,Z+1)]>
IFE N,<XWD Z,0>>


;## ARGS ARE A=NAME, B=PROP NAME, C'A=THE PROPERTY, D=LABEL OF ATOM

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 [PSTRCT(A)],0>
LIST>

;## ARGS ARE: D'A=PROPERTY, B=PROP NAME, C=NAME

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 [PSTRCT(C)],0>
LIST>

DEFINE LENGTH (A,B)
<A==0
IRPC B,<A==A+1>>

;## ATOM WITH SYM PROPERTY =V'ATOM LOCATION
DEFINE ML1 (A)<IRP A,<
V'A:	XWD	-1,.+1
	XWD	FIXNUM,[A]
	MKAT A,SYM,V
>>

;## SIMILAR TO ML1, EXCEPT %C=THE SYM PROP

DEFINE MKSY1 (A,B,%C)<
XLIST
%C:	XWD	-1,.+1
	XWD	FIXNUM,[A]
	PUTOB B,.+1
	XWD	-1,.+1
	XWD	SYM,.+1
	XWD	%C,.+1
	XWD	PNAME,.+1
	XWD	[PSTRCT(B)],0
LIST>

;##  ATOM WITH NO PROPS WITH  LABEL SAME AS ATOM NAME

DEFINE ML (A)<
XLIST
IRP A,<PUTOB A,.+1
A:	XWD -1,.+1
	XWD PNAME,.+1
	XWD [PSTRCT(A)],0>
LIST>
;## CREATE ATOM WITH NO LABEL OR PROPS. USED FOR COMMON ATMS IN SYSTEM

DEFINE MK (A)<
XLIST
IRP A,<PUTOB A,.+1
	XWD -1,.+1
	XWD PNAME,.+1
	XWD [PSTRCT(A)],0>
LIST>

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

PAGE
;## GENERATE # FNS ONLY IF NONUSEFUL VALUES DESIRED
IFN NONUSE<
MKAT1 MEMBR.,SUBR,MEMBER#
MKAT1 MEMB,SUBR,MEMQ#
MKAT1 AND.,FSUBR,AND#
MKAT1 OR.,FSUBR,OR#
	>
MKAT<RPLACA,RPLACD,MINUS,TERPRI,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<STRINGP,ATOM,PATOM,EQ,PRIN1,PRINT,RETURN,EXPLODE,SASSOC,ASSOC>,SUBR
MKAT<GCGAG,CHRCT,LINELENGTH,NUMBERP,EQUAL,GET,INTERN,MEMBER>,SUBR
MKAT<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,GC,GETL,BAKGAG,MEMQ>,SUBR
MKAT<PUTPROP,PRINC,FLATSIZE,ERR,EXAMINE,DEPOSIT,LSH>,SUBR
MKAT<NCONS,XCONS,REMPROP,ARG,SETARG,NOUUO,MINUSP>,SUBR
MKAT<OUTC,INC,DDTIN,INITFN,EXCISE,REMAINDER,ABS>,SUBR
MKAT<PROG1,SPRINT,LITATOM,NTHCHAR>,SUBR
IFN STPGAP,<MAKAT<PGLINE>,SUBR>

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

;$$ REDEF. FOR NEW MAP FUNCTIONS
MKAT<MAPCAN,MAPCON,MAPLIST,MAPCAR,MAP,MAPC>,LSUBR
;$$ GIVE MAPCAN THE DOUBLE NAME MAPCONC
MKAT1 MAPCAN,LSUBR,MAPCONC

PROGAT:	MKAT<PROG>,FSUBR

;##LIST STARTS HERE
MKAT LIST,FSUBR,,LISTAT:

MKAT <PROGN,COND,SETQ,INPUT,OUTPUT,SETSYS>,FSUBR 
IFN ALVINE,<MKAT<GRINDEF>,FSUBR
	    MKAT<ED>,SUBR>
IFE ALVINE,<MK<GRINDEF>>
MKAT<ERRSET,REMOB,OR,GO,ARRAY,STORE>,FSUBR
MKAT<AND,DEFPROP,CSYM,EXARRAY>,FSUBR
MKAT1 QUOTE,FSUBR,FUNCTION
MKAT1 %CLRBFI,SUBR,CLRBFI
MKAT1 .ERROR,SUBR,ERROR
MKAT1 LINRD,SUBR,LINEREAD
MKAT1 UNBOND,SUBR,UNBOUND
MKAT1 ECHO,SUBR,TTYECHO
MKAT1 FUNCT,FSUBR,*FUNCTION
MKAT <APPEND,NCONC,BOOLE,APPLY>,LSUBR

;## LABELS ON READ AND LISP EVAL FOR BOOTS
MKAT READ,SUBR,,READAT:
MKAT EVAL,LSUBR,O,EVALAT:
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 [PSTRCT(T)],0
VTRUTH:	TRUTH

	PUTOB NIL,0
CNIL2:	XWD VALUE,.+1
	XWD VNIL,.+1
	XWD PNAME,.+1
	XWD [PSTRCT(NIL)],0
VNIL:	NIL
MKSY1 %LCALL,*LCALL
MKSY1 %AMAKE,*AMAKE
MKSY1 %UDT,*UDT
MKSY1 .MAPC,*MAPC
MKSY1 .MAP,*MAP
MKAT1 %NOPOINT,VALUE,*NOPOINT
%NOPOINT:	NIL


UNBOUND:	XWD -1,.+1
	XWD PNAME,.+1
	XWD [PSTRCT(UNBOUND)],0
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
MKAT1 RPTSYM,SUBR,*RPUTSYM
MKAT1 RGTSYM,SUBR,*RGETSYM

ML1 <SPECBIND,SPECSTR,FIX1A,NSTR>

	PUTOB NUMVAL,.+1
	XWD -1,.+1
	XWD SUBR,.+1
	XWD NUMVAL,.+1
	XWD SYM,.+3
	XWD FIXNUM,[NUMVAL]
	XWD -1,.-1
	XWD .-1,.+1
	XWD PNAME,.+1
	XWD [PSTRCT(NUMVAL)],0

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


;## QUEUE ATOMS AND OTHER NEW FNS.

MKAT<GTBLK,ERRCH,RDNAM>,SUBR
MKAT<INUMP,NUMTYPE>,SUBR
MKAT<UFDINP,RDFILE,MYPPN,BLKLST>,SUBR
MKAT<RENAME,DELETE,INITFL>,FSUBR
IFN	QALLOW<			;%% [1]
ML<DISP,CPU,FORMS,LIMIT,COPIES>;;##
MKAT<QUEUE>,FSUBR;		;##
		>		;%% [1]
MK<SUBST,COPY,*RENAME,FILBAK,LBK,DIR>
MKAT1 ISFILE,SUBR,LOOKUP
MK<NO BACKUP >

IFN	QALLOW<		;%% [1]
;## MOST OF THE EXTENDED SWITCHES (NOT ALL)
IFN	QSWEXT<
	ML<DEAD,AFTER>
	ML<MODIFY,KILL,JOB,DEPND,UNIQUE>
	ML<PAGES,PLOT,PTAPE,CARD,SEQ,PRIOR,SPACE,LIMIT,HEAD>
	>		;##END OF EXTENDED SWITCHES
		>	;%% END OF QALLOW CONDITIONAL [1]

;$$ATOMS FOR DEFINITIONS OF FUNCTIONS FOR NEW SPDL PACKAGE

	ML ERRORX
	MKAT1 INTPRP,SUBR,INITPROMPT
	MKAT1 LSPRET,FSUBR,**TOP**
	MKAT<PROMPT,READP,UNTYI,STKPTR,SPREDO,SPREVAL>,SUBR
	MKAT<MEMB,NEXTEV>,SUBR
	MKAT<SPDLFT,SPDLRT,SPDLPT>,SUBR
	MKAT<EVALV,OUTVAL>,SUBR

	IFN	REALLC <
;%% NEW DYNAMIC REALLOCATION FUNCTION
	MKAT1 REALLO,SUBR,REALLOC
	MKAT<FWCNT,FSCNT>,SUBR
>

;$$ MORE EXTENSIONS INCLUDING READ MACROS
	ML READMACRO
	MKAT1 %FLATSIZEC,SUBR,FLATSIZEC
	MKAT <NEQ,CONSP,CHRVAL,SETCHR,MODCHR,LEXORDER>,SUBR 
	MKAT <FREE,FREELIST,SYSCLR,HGHCOR,HGHORG,HGHEND>,SUBR
	MKAT1 FALSE,FSUBR,SPECIAL
	MKAT1 FALSE,FSUBR,NOCALL
	MKAT1 FALSE,FSUBR,DECLARE
	MKAT1 FALSE,FSUBR,NILL
	MKAT1 APPLY.,SUBR,APPLY#
	MKAT1 .MAX,SUBR,*MAX
	MKAT1 .MIN,SUBR,*MIN

;$$ THE BREAK VARIABLES WHICH TELL ABOUT DEPTH IN THE BREAK PACKAGE
	MKAT1 BIOCHN,VALUE,#%IOCHANS%#
	MKAT1 BPMPT,VALUE,#%PROMPTS%#
	MKAT1 BINDNT,VALUE,#%INDENT
BIOCHN:	NIL
BPMPT:	NIL
BINDNT:	INUM0

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 [PSTRCT(?)],0

VBPORG:	INUM0
VBPEND:	INUM0

;MKAT ACHLOC,SYM
;DONT KNOW WHATS UP HERE, IF NEEDED CHECK ACHLOC
;%% THIS WAS A PREDECESSOR TO THE FUNCTIONS UNDER SWITCH "REALLC"
;%% NO LONGER USEFUL

PAGE
;
;	ALL THE ATOMS IN THE WHOLE SYSTEM
MK<USERERRORX,RPUTSYM,RGETSYM>
MK<A,ADD,AFTER,ALIAS,ARGPRINT,ASSOC#,ATM,B,BEFORE,BELOW,BEND1,BF,BI,BIND>
MK<BK,BKE,BKEV,BKEVAL,BKF,BKFNLIST,BKFV,BKPOS,BKPROG,BKSETQ,BKV>
MK<BLOCK,BLOCKED,BO,BORG1,BREAK>
MK<BREAKMACROS,BREAK0,BREAK1,BREAK1ERX,BRKAPPLY>
MK<BRKCOMS,BRKEXP,BRKFN,BRKTYPE,BRKWHEN,BROKEN,BROKENFNS>
MK<BY,C,CAIE,CAIN,CALL,CALLF,CALLF@,CAME,CAMN,CAN'T,CHANGE>
MK<CHNGDFLG,CLEARB,CLEARM,COM,COM0>
MK<COMS,COMSQ,COPYFLG,CPTR,D,DE,DEFSYM,DELETE,DF>
MK<DIFFERENCE,DIFFERENT EXPRESSION,DM,DREVERSE,DRM,DSKIN>
MK<DSKOUT,DSM,DSUBST,E,EDIT,EDIT-SAVE>
MK<EDIT4E,EDIT4F,EDIT4F1,EDIT:,EDITBF,EDIT1,EDITCOMSL>
MK<EDITE,EDITF,EDITFNS,EDITFPAT>
MK<EDITL,EDITL0,EDITL1,EDITMACROS,EDITMBD,EDITMV>
MK<EDITOPS,EDITQF,EDITRACEFN,EDITXTR,EMBED,ENTER ,ERXACTION>
MK<EX,EXCH,EXTRACT,F,F=,FF,FILES-LOADED,FINDFLAG,FNDBRKPT,FOR,FOUND>
MK<FROM,FROM?=,FS,FUNTYPE,G,GETSYM,GREATERP,GRINL,GVAL>
MK<GWD,HERE,HLLZS@,HLRZ,HLRZ@,HRLM@,HRRM,HRRM@,HRRZ,HRRZ@,HRRZS@>
MK<I,IF,IN,INSERT,INSIDE,JCALL,JCALLF,JCALLF@,JRST,JSP>
MK<JUMPE,JUMPN,KLIST,L,L0,L11,L12,LAP,LAPEVAL,LAPLST,LASTAIL>
MK<LASTPOS,LASTWORD,LASTP1,LASTP2,LASTVALUE,LC,LCFLG,LCL,LDIFF,LESSP>
MK<LEXPR,LI,LO,LP,LPQ,LPTLENGTH,LSUBST>
MK<M,MARK,MARKLST,MAX,MAXLEVEL,MAXLEVEL EXCEEDED>
MK<MAXLOOP,MAXLOOP EXCEEDED,MBD,MIN,MOVE,MOVEI,MOVEM>
MK<MOVNI,MV,N,N?,NAMESCHANGED,NEX,NOT BLOCKED,NOT EDITABLE>
MK<NOTHING SAVED,NTH,NX,OCCURRENCES,OK,OLDPROMPT,OPS,ORF,ORR>
MK<P,PLEV,PLUS,POP,POPJ,PP,PREVEV,PRINLEV,PRINTLEV>
MK<PUSH,PUSHJ,PUTSYM,QLIST,QUOTIENT,R,READBUF>
MK<REDEFINED,REMOVE,REPACK,REPLACE,RETFROM,RI,RO> ;##REMOVE MARKER
MK<S,SAVE,SECOND,SELECTQ,SN,SOJE,SOJN>
MK<START,STKCOUNT,STKNAME,STKNTH>
MK<STKSRCH,STOP,SUB,SUBPAIR,SURROUND,SW>
MK<TAILP,TCONC,TDZA,TEST,THIRD,THROUGH,THRU,TIMES,TO>
MK<TOFLG,TOPFLG,TRACE,TRACEDFNS,TTY:,TYPE,UNBLOCK,UNBREAK>
MK<UNBREAK0,UNBREAKABLEFNS,UNDEF,UNDO>
MK<UNDOLST,UNDOLST1,UNDONE,UNFIND,UNTRACE,UP>
MK<UPFINDFLG,USE,USERMACROS,WHEN,WITH,X,XTR,Y,ZZ>
MK<@,<\>,<\#\ >,<\P>,^,^^,_,__, ,   ,  ?, . ,< . UNBOUND)>>
MK<- LOCATION UNCERTAIN, = ,!  ,!0,!NX,!UNDO,!VALUE,##>
MK<#1,#2,#3,$%DOTFLG,%%BKPOS,%%CMDL,%%V>
MK<%DEFINE,%DEREAD,%DEVP,%ERDEPTH,%LOOKDPTH,%PREVFN%>
MK<%PRINFN,%READIN,&,& ,<(>,<(DEFPROP >,<)>,*,*ANY*,*RSETERX,-->
MK<-IN-,::,:::,/BREAK1,:,=,==,?=,??>
MK<... , ...],BINARY PROGRAM SPACE EXCEEDED>
MK<NOT A TAIL - LDIFF,NO EVAL BLIP - RETFROM>
MK<BAD ARGUMENT - LCONC,BAD ARGUMENT - TCONC>
MK<DSK:,INIT,LSP,NOT IN SYMBOL TABLE,& UNHAPPY>
MK<ARGUMENTS NOT FOUND,NOT BREAKABLE FUNCTION,ARGUMENT LIST?>
MK<AROUND,BREAKIN,EDBRK,BROKEN-IN,EDVAL,DREMOVE,LCONC,SUBLIS>
MK<EDITDSUBST,MAKEFN,FNDEF,LXPD,WHERE,MESS>
MK<SHOULD BE LIST,SHOULD BE LIST OF ATOMIC ARGUMENTS>
MK<FSUBR -- TAKES ONLY ONE ARGUMENT,UNBREAKABLE UNLESS 'IN' SOMETHING>
MK<EDITV,GRINPROPS,=EDITV,EDITP,ARGS,EDITFINDP>

;%% MORE NEW SYSTEM FUNCTIONS
MK<Q,%%MSGFLAG,-,SUBFUN1*RSETERX,SUBFUN2*RSETERX>

;ATOMS OF GENERATED FUNCTIONS
MK<SUBFUN1ARGPRINT,SUBFUN1BREAKIN0,SUBFUN1EDITCONT,SUBFUN1EDITL1,SUBFUN1EDOR>
MK<SUBFUN1EDVAL,SUBFUN1ERRCOM>
BFWS:
EFWS:	0
RELOC
XLIST
LIT
LIST
BHORG:	0
RELOC
	PAGE

		SUBTTL LISP STORAGE ALLOCATOR (ONCE ONLY) 


ALLOC:	CLEARM	0,SBPS		;SET UP INITIAL ALLOCATIONS FOR SPACE
	HRRZI	A,BFWS-FS	;THIS IS THE SIZE OF THE ORIGINAL FS
	HRRZM	A,SFS
	HRRZI	A,EFWS-BFWS	;THIS ALLOWS ONLY THE INITIAL
	HRRZM	A,SFWS		;FWS
	HRRZI	A,0		;THE INITIAL ALLOCATION FOR SPDL
	HRRZM	A,SSPDL
	HRRZM	A,SRPDL		;AND FOR RPDL IS SET UP IN INALLC
	HRRZI	A,FS
	HRRZM	A,FSO		;THIS SETS UP INITIAL FS POINTER
	HRRZI	A,BFWS		;THIS SETS UP INITIAL FWS ORIGIN POINTER
	HRRZM	A,FWSO#

	HRRZI	A,EFWS
	HRRZM	A,EFWSO#


	MOVEI	A,FS
	ADDM	A,VBPORG	;SET UP VARIABLE FOR BPS ORIGIN
	SOS	A
	ADDM	A,VBPEND

	MOVE	A,JOBREL
	HRLM	A,JOBSA
	CALLI 	RESET
	MOVEI	A,DDT
	CALLI	A,2	;SET UP DDT REENTRY POINT FOR AUTOMATIC CONTROL H
	MOVEI	A,LISPGO
	HRRM	A,JOBSA

	SETOM	INITFW#		;FLAG FOR STANDARD INITIALIZATION OF
	SETZM	JRELO#		;OF SIZES, AND TO INDICATE CORE WAS EXPANDED

	JRST	INALLC


DEFINE MKENT (A)<
INTERNAL A>
;##DEBUG QUEUE
MKENT <CADAR,ATMOV,CADAR,CORUSE,DEBUGO,DEV>
IFN	QALLOW<			;%% [1]
MKENT <COPIES>			;%% [1]
		>		;%% [1]
MKENT <EXT,HGHDAT,INUM0,INUMIN,IOPPN,LISTAT,MORCOR,MOVDWN>
MKENT <NXTIO,OLDCU,SIXMAK,STNIL>

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>
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>
MKENT <TYO,ITYO,IGSTRT,NOINFG,CHRTAB,EVAL,OEVAL,.APPEND,INPUT,OUTPUT>
IFN ALVINE,<MKENT<PSAV1,BKTRC>>

;%% RECENT ADDITIONS
MKENT <FLTYIA,SIXATM,BNINIT,RDFILE,UFDINP,MYPPN>
IFN	QALLOW<		;%% [1]
MKENT <QUEUE>			;%% [1]
		>		;%% [1]
MKENT <SYSIN0,SYSIN1,SYSINI,SYSINP>
	IFN	REALLC <
MKENT <FWCNT,FSCNT,REALLO>
>

;$$ FOR ALAN'S DIRECT ACCESS INPUT
MKENT <ININBF,TYI2,TYIA,INCH>

;## FOR BILL'S DIRECT ACCESS INPUT/OUTPUT
MKENT <AIN.2,AIN.4,AIN.7,AOUT.2,CHANNE>
MKENT <CHNSUB,CHTAB,DEVDAT,ENTR,IOSUB>
MKENT <LOOKIN,OUTCH,OUTERR,POPAJ,PPN,SMAC>
MKENT <TABSR1,TABSRC,TYI2E,TYI2Z,TYI3B,TYO2X>
MKENT <TYO5,AIOP,SETIN>

;$$ FOR ALVINE
MKENT <PROMPT,INUM0,MEMQ,UNBOUND>

;%% FOR THE MODIFIED ARITHMETIC PACKAGE
MKENT <FIXNUM,FLONUM>

PAGE
	END ALLOC