perm filename UT[RUT,LSP] blob sn#345128 filedate 1978-03-22 generic text, type T, neo UTF8
00010		TITLE	LISP INTERPRETER	3A(1)-2
00020		SUBTTL	NOTES TO SYSTEM PROGRAMMERS		
00030	
00040	;	COMMENTS:
00050	;
00060	;	THERE ARE SEVERAL SETS OF COMMENTS IN THE CODE:
00070	;	THOSE IN LOWER CASE ARE ORIGINAL STANFORD COMMENTS; 
00080	;	THOSE OF A SEMI-COLON FOLLOWED BY TWO $'S,
00090	;	TWO #'S, OR TWO %'S ARE UCI ADDITIONS,
00100	;	CHANGES, OR ADDITIONAL COMMENTS
00110	;	($'S ARE USUALLY DARYLE LEWIS, 
00120	;	#'S ARE GENERALLY JEFF JACOBS,
00130	;	AND %'S ARE GENERALLY BILL EARL).
00140	;***	*** COMMENTS ARE RUTGERS MODIFICATIONS (RICK LEFAIVRE)
00150	;[UT]	[UT] COMMENTS WERE MADE AT UNIV. OF TEXAS (RICH COHEN)
00160	;	&& COMMENTS WERE MADE BY RICH COHEN
00170	;WMT	WMT COMMENTS WERE MADE AT UT BY MABRY TYSON
00180	
00190	;%%	VERSION DEFINITIONS:
00200	
00210		LSPWHO==3	;WMT  UT
00220		LSPVER==7	;%% MAJOR VERSION
00230		LSPMIN==3	;%% MINOR VERSION
00240		LSPEDT==2	;%% EDIT LEVEL
00250	
00260	;	ASSEMBLY SWITCHES OF INTEREST
00270	;
00280	;	SWITCH		EXPLANATION,  COMMENTS  ETC.
00290	;	------		----------------------------------
00300	;	ALTMOD		FOR ALTMODE CHARACTER. OLD WAS 175
00310	;			NOW IT'S 33 FOR 506
00320	;	QALLOW		ENABLES  ACCESS  TO QMANGR, ONLY  IF YOUR
00330	;			SYSTEM SUPPORTS QUEUE. SEVERAL SWITCHES 
00340	;			ASSOCIATED WITH  THE  CODE
00350	;***	OLDNIL		OLD STANFORD NIL.  IF OFF CAR AND CDR OF
00360	;			NIL ARE NIL A LA INTERLISP
00370	;	NONUSE		OLD STANFORD VERSIONS  OF  MEMQ, AND  ETC.
00380	;			THAT  RETURNED  T OR NIL.
00390	;	REALLC		PROGRAM-CONTROLLED DYNAMIC REALLOCATION
00400	;			ROUTINE AND RELATED FUNCTIONS
00410	;	SYSPRG		PROJECT NUMBER IF NOT ON SYS:.
00420	;	SYSPN		PROGRAMMER NUMBER IF NOT ON SYS:
00430	;	SYSDEV		DEVICE LOCATION OF SYSTEM.
00440	;			NOTE THAT  THE ABOVE THREE ARE WHERE LISP
00450	;			EXPECTS  TO  FIND THE  LOADER,THE
00460	;			SYMBOL TABLE AND THE NORMAL HI-SEGMENT.
00470	;			THE FUNCTION (SETSYS ...) ONLY CHANGES THE
00480	;			EXPECTED LOCATION OF THE HI-SEG
00490	;%%	SYSNAM		NAME OF EXPECTED HIGH SEGMENT
00500	;%%			AND LISP LOADER AND SYMBOL TABLE
00510	;%%	INUMIN		LOWEST ADDRESS AVAILABLE FOR USE AS
00520	;%%			AN INUM
00530	;%%	BCKETS		NUMBER OF HASH BUCKETS
00540	;%%	SHRST		LOWEST ADDRESS IN HIGH SEGMENT
00550	;***	SPRNT		SYSTEM-SUPPLIED SPRINT
00560	;%%	SYSUNV		SEARCH SYSTEM UNIVERSAL LIBRARIES
00570	;WMT	RANDOM		ALLOW RANDOM I/O
00580	
00590	;	COMMENTS:
00600	;WMT	SFDFLG		Allow SFDs
00610	
00620	;	**USE  FOLLOWING AT OWN  RISK**
00630	
00640	;	HASH		NUMBER OF  HASH BUCKETS  WHEN STARTING
00650	;	ALVINE		STANFORD EDITOR (WHO WOULD WANT IT?)
00660	;			1 FOR ALVINE, 0 FOR NO ALVINE
00670	;	STPGAP		ANOTHER  STANFORD  EDITOR
00680	;***	BIGNMS		BIGNUM PACKAGE (IF ON NORMAL INTEGERS ARE
00690	;***			REDUCED FROM 36 TO 35 SIG. BITS FOR I/O)
00700	
00710		PAGE
     
00010			SUBTTL AC DEFINITIONS AND EXTERNALS 		
00020	
00030	;WMT - UT'S OWN PERSONAL SET UP
00040	DEFINE SYSDEV <SIXBIT /LSP/>	;WMT- AT UT, LSP:=[5,100]
00050	DEFINE SYSNAM <SIXBIT /LSP7C1/>	;WMT- VERSION NUMBER = 7C(1)
00060	;	USING THIS TYPE NAME TO ALLOW FOR DIFFERENT VERSION OF
00070	;	LISP SIMULTANEOUSLY SO TRANSITIONS ARE SMOOTHER
00080	SHRST=600000	;WMT- UT WANTS LOTS OF ROOM
00090	SFDFLG=0	;WMT- UT WANTS SFDS
00100	REALLC=1	;WMT- UT WANTS TO REALLOC
00110	RANDOM=1	;WMT- UT WANTS RANDOM I/O
00120	;WMT - END OF UT SET UP
00130	
00140	IFNDEF	SYSUNV		<SYSUNV==1>	;[1]
00150	
00160	IFNDEF	SHRST		<SHRST==400000>	;[1]
00170	
00180		TWOSEG SHRST	;[1]
00190	
00200	IFN SYSUNV,<	;[1]
00210		SEARCH	MACTEN
00220		SEARCH	UUOSYM		;[1]
00230	>
00240	
00250	
00260	IFNDEF	OLDNIL		<OLDNIL==0>	;*** NEW NIL COMPLETED 8/76
00270	IFNDEF	NONUSE		<NONUSE==0>
00280	IFN	SHRST-400000	<QALLOW==0>
00290	IFNDEF	QALLOW		<QALLOW==1>
00300	IFNDEF	SFDFLG		<SFDFLG==1>	;WMT-1 MEANS NO SFDS
00310	IFNDEF	REALLC		<REALLC==0>	;%% NORMALLY OFF TO SAVE SPACE
00320						;%% CHANGE FOR EXTENDED SYSTEM
00330	IFNDEF	SPRNT		<SPRNT==0>	;*** USE SPRINT IN PP PACKAGE
00340	IFNDEF	PNAMES		<PNAMES==1>	;*** PNAMES IN HIGH SEGMENT
00350	IFNDEF	SYSPRG		<SYSPRG==0	;*** LOC. OF HIGH SEGMENT
00360				 SYSPN==0>
00370	IFE SYSPRG,<IFNDEF SYSDEV,<DEFINE SYSDEV <SIXBIT /SYS/>>>
00380	IFN SYSPRG,<IFNDEF SYSDEV,<DEFINE SYSDEV <SIXBIT /DSK/>>>
00390	IFNDEF SYSNAM,<DEFINE SYSNAM <SIXBIT /ILISP/>>	;***
00400	
00410	IFNDEF ALVINE		<ALVINE==0>	;1 FOR ALVINE, 0 FOR NO ALVINE
00420	IFNDEF HASH		<HASH==0>	;1 FOR SETTING # OF HASH BUCKETS AT SYS INIT TIME
00430	IFNDEF STPGAP		<STPGAP==0>	;1 FOR STOPGAP, 0 TO DELETE IT
00440	IFNDEF BIGNMS		<BIGNMS==0>	;*** 1 TO ALLOW BIGNUM MODIFICATIONS
00450	IF1,<PURGE CDR,DF>
00460	MLON
00470	IFNDEF	INUMIN		<INUMIN=SHRST-1> ;%% [1]
00480	INUM0=777777-<<777777-INUMIN>/2> ;%% [1]
00490	IFNDEF BCKETS		<BCKETS==177>
00500	IFNDEF RANDOM		<RANDOM==0>	;WMT- 1 TO ALLOW RANDOM I/O
00510	
00520		PAGE
     
00010	;accumulator definitions
00020	;`sacred' means sacred to the interpreter
00030	;`marked' means marked from by the garbage collector
00040	;`protected' means protected during garbage collection
00050	
00060	NIL=0	;sacred, marked, protected	;atom head of NIL
00070	A=1	;marked, protected	;results of functions and first arg of subrs
00080	B=A+1	;marked, protected	;second arg of subrs
00090	C=B+1	;marked, protected	;third arg of subrs
00100	AR1=4	;marked, protected	;fourth arg of subrs
00110	AR2A=5	;marked, protected	;fifth arg of subrs
00120	T=6	;marked, protected	;minus number of args in LSUBR call
00130	TT=7	;marked, protected
00140	REL=10	;marked, protected	
00150	S=11		;$$NOW USED FOR ATOM RELOCATION AND GARBAGE COLLECTOR
00160	D=12	
00170	R=13	;protected
00180	P=14	;sacred, protected	;regular push down stack pointer
00190	F=15	;sacred	;free storage list pointer
00200	FF=16	;sacred	;full word list pointer
00210	SP=17	;sacred, protected	;special pushdown stack pointer
00220	
00230	NACS==5	;number of argument acs
00240	
00250	X==0	;X indicates impure (modified) code locations (*** Obsolete)
00260	TEN==↑D10
00270	
00280	;UUO definitions
00290	;UUOs used to call functions from compiled code
00300	;the number of arguments is given by the ac field 
00310	;the address is a pointer either to the function 
0320	;name or the code of the function
00330	OPDEF FCALL [34B8]	;ordinary function call-may be changed to PUSHJ
00340	OPDEF JCALL [35B8]	;terminal function call-may be changed to JRST
00350	OPDEF CALLF [36B8]	;like call but may not be changed to PUSHJ
00360	OPDEF JCALLF [37B8]	;like jcall but may not be changed to JRST
00370	
00380	;error UUOs (*** Modified for interface with smart ERRORX)
00390	OPDEF ERR1 [1B8]	;"correctable" lisp error; message can be suppressed
00400	OPDEF ERR2 [2B8]	;"serious" lisp error; no message suppression
00410	OPDEF ERR3 [3B8]	;space overflow error; no break to ERRORX
00420	OPDEF ERR4 [4B8]	;ill. mem. ref.; "serious" error with special print
00430	OPDEF STRTIP [5B8]	;print error message and continue
00440	
00450	;system UUOs
00460	OPDEF SKPINL [TTCALL 14,]	;## BETTER FOR TALK THAN SKPINC
00470	OPDEF TALK   [PUSHJ P,TTYCLR+1]	;## TURN OF CONTROL O
00480	
00490	;I/O bits and constants
00500	TTYLL==105	;teletype linelength 
00510	LPTLL==160	;line printer linelength
00520	MLIOB==203	;max length of I/O buffer
00530	IFE RANDOM,<NIOB==2>	;no of I/O buffers per device
00540	IFN RANDOM,<NIOB==1	;WMT
00550		BFCHRS==1200>	;WMT- # OF CHARS IN A BUFFER
00560	NIOCH==17	;number of I/O channels
00570	FSTCH==1	;first I/O channel
00580	TTCH==0		;teletype I/O channel
00590	IFN SFDFLG,<SFDLEN==0>	;WMT
00600	IFE SFDFLG,<SFDLEN==5>	;WMT-DEPTH OF SFD NESTING
00610	BLKSIZE==NIOB*MLIOB+COUNT+1
00620	INB==2
00630	OUTB==1
00640	AVLB==40
00650	DIRB==4
00660	
00670	;channel data
00680	CHNAM==0	;name of channel
00690	IFE RANDOM,<CHDEV==CHNAM+1>	;name of device
00700	IFN RANDOM,<CHBUFS==CHNAM+1	;WMT- NUMBER OF BUFFER LOADS
00710		    CHDEV==CHBUFS+1>
00720	CHFILE==CHDEV+1	;WMT- NAME OF FILE
00730	CHEXT==CHFILE+1	;WMT- EXTENSION
00740	CHPPN==CHEXT+1	;ppn for input channel
00750	 CHLL==CHEXT+1		;linelength for output channel
00760	 CHHP==CHLL+1		;hposit for output channels
00770	CHOCH==CHPPN+1+SFDLEN	;oldch for input channels
00780	IFN STPGAP,<
00790	CHPAGE==CHOCH+1	;page number for input
00800	CHLINE==CHPAGE+1 ;line number for input
00810	CHDAT==CHLINE+1	;device data
00820	>
00830	IFE STPGAP,<
00840	CHDAT==CHOCH+1
00850	>
00860	;WMT- CHDAT,POINTR,COUNT MUST BE CONSECUTIVE FOR I/O
00870	POINTR==CHDAT+1			;byte pointer for device buffer
00880	COUNT==POINTR+1			;character count for device buffer
00890	
00900	;special ASCII characters
00910	IFNDEF ALTMOD,<ALTMOD==33>
00920	SPACE==40	;space
00930	IGCRLF==31	;ignored cr-lf
00940	RUBOUT==177
00950	LF==12
00960	CR==15
00970	TAB==11
00980	BELL==7
00990	DBLQT==42	;double quote "
01000	
01010	;*** ↑C INTERRUPT CHARACTERS
01020	CNTLH==10
01030	CNTLE==5
01040	CNTLB==2
01050	CNTLZ==32
01060	CNTLG==7
01070	CNTLR==22	;CH TO RESTORE SYSTEM OBLIST 3/28/73
01080	QMARK==77
01090	CNTLF==6
01100	CNTLD==4
01110	CNTLX==30
01120	
01130	;byte pointer field definitions
01140	ACFLD==14	;ac field
01150	XFLD==21	;index field
01160	OPFLD==10	;opcode field
01170	ADRFLD==43	;adress field
01180	
01190	;external and internal symbols
01200	
01210	;EXTERNAL .JB41	;instruction to be executed on UUO
01220	;EXTERNAL .JBAPR ;address of APR interupt routines
01230	EXTERNAL .JBCNI	;interupt condition flags
01240	EXTERNAL .JBFF	;first location beyond program
01250	EXTERNAL .JBREL	;address of last legal instruction in core image
01260	;EXTERNAL .JBREN ;reentry address
01270	;EXTERNAL .JBSA	;starting address
01280	EXTERNAL .JBSYM	;address of symbol table
01290	EXTERNAL .JBTPC	;program counter at time of interupt
01300	EXTERNAL .JBUUO	;uuo is put here with effective address computed
01310	EXTERNAL .JBOPC ;$$FOR NEW REENTER FEATURES
01320	EXTERNAL .JBHRL ;HIGH SEGMENT BOUNDARY
01330	;EXTERNAL .JBINT ;↑C INTERRUPT BLOCK ADDRESS
01340	;EXTERNAL .JBVER ;VERSION NUMBER
01350	
01360	.JB41==41	;WMT-THESE  MUST BE HERE FOR PASS 1 FOR LOC'S
01370	.JBAPR==125
01380	.JBREN=124
01390	.JBSA==120
01400	.JBINT==134
01410	.JBVER==137
01420	
01430	
01440	;apr flags
01450	PDOV==200000	;push down list overflow
01460	MPV==20000	;memory protection violation
01470	NXM==10000	;non-existant memory referenced
01480	APRFLG==PDOV+MPV+NXM	;any of the above
01490	
01500	;REMOTE MACRO
01510	;WMT- MODIFIED TO PUT CODE WHERE IT CAME FROM FOR CREF
01520	
01530	DEFINE REMOTE (TX)
01540	<	RELOC
01550	XALL
01560		TX
01570	SALL
01580		RELOC
01590	>
01600	
01610	
01620	DEFINE HERE
01630	<>
01640	
01650	COMMENT &  WMT-  HERE IS THE OLD REMOTE/HERE MACROS.
01660		DEFINE REMOTE (TX)
01670	<	HERE1 <TX>>
01680	
01690		DEFINE HERE1 (NEW,OLD,%G)
01700	<	DEFINE %G
01710	<	NEW>
01720		DEFINE REMOTE (TX)
01730	<	HERE1 <TX>,<OLD
01740	%G
01750	>>>
01760		DEFINE HERE
01770	<	DEFINE HERE1 (XX,YY)
01780	<	YY>
01790		REMOTE>
01800		END OF OLD REMOTE/HERE MACROS &
01810	SALL
01820		PAGE
     
00010		SUBTTL START, EXIT, AND ↑C TRAP ROUTINES
00020	
00030	;*** This is all new as of 10/10/76 - RAL
00040	
00050	;*** Set up memory locations in Job Data Area
00060	
00070		LOC .JB41
00080		JSR UUOH
00090		LOC .JBSA
00100		XWD X,START	;(MUST BE RESET SINCE CLOBBERED BY INITIAL LOAD)
00110		LOC .JBREN
00120		XWD 0,REENTR
00130		LOC .JBAPR
00140		XWD 0,APRINT	;(Reset at STRT just in case)
00150		LOC .JBINT
00160		XWD 0,CCBLK	;(Ditto)
00170		LOC .JBVER
00180		VRSN.	(LSP)	;%% GENERATE VERSION	;[1]
00190	
00200		RELOC 0
00210		RELOC
00220	
00230	
00240	REMOTE<
00250	
00260	;*** Location of sharable high segment.  Changed via SETSYS.
00270	HGHDAT:	SYSDEV
00280		SYSNAM
00290		0
00300		0
00310		XWD SYSPRG,SYSPN
00320		0
00330	
00340	CCBLK:	XWD 4,CCINT	;Interrupt Block
00350		XWD 0,2		;Only Handles ↑C
00360		0		;PC Goes Here
00370		X		;Other Junk Goes Here
00380	
00390	CCFLAG:	0
00400	GCFLAG:	0
00410	CCONV:	0		;WMT - FLAG TO INTERRUPT ON ↑C BEFORE MONITOR
00420	ERINT:	0
00430	FORCEC:	0		;WMT- FLAG TO FORCE CONVERSATION AFTER REENTER
00440	
00450		PAGE
     
00010	;WMT - MOVED A LOT OF THIS INTO LOW SEGMENT.  PROBLEMS WERE OCCURING
00020	;	ON A ↑C DURING PAGING (WHILE IN PFH).  AUTOMATICALLY
00030	;	JUMPING BACK TO THE GARBAGE COLLECTOR OR CONTINUING VIA
00040	;	A ↑H MIGHT GET INTO AN INFINITE LOOP AS INTERRUPT ADDRESS
00050	;	WAS IN PFH BUT PFH GOT CALLED AGAIN (CLOBBERING IT'S
00060	;	LOCAL DATA) IN ORDER TO ACCESS THIS CODE.  WHEN YOU JUMP
00070	;	BACK INTO THE MIDDLE OF PFH IT RETURNS BACK INTO THIS CODE
00080	;	SOMEWHERE CAUSING LOOPING.
00090	;	PAGE 0 IS NOT PAGED SO IT SHOULD BE OK.
00100	
00110	;*** START Entry Point
00120	START:	SKIPE GCFLAG		;DID HE SOMEHOW GET OUT WHILE GCING?
00130		JRST GCING1		;WMT- YES, TELL HIM SO
00140		SKIPE CCFLAG		;DID HE SOMEHOW GET OUT WITHOUT EXITING?
00150		JRST START3
00160		PUSH P,.JBOPC		;YES: SIMULATE A ↑C INTERRUPT
00170		POP P,CCFLAG
00180	START3:	RESET
00190		HRRZ 0,.JBREL		;WMT- CHECK TO SEE IF YOU NEED TO ALLOC
00200		CAMN 0,JRELO		;WMT-  COMPARE IT WITH LAST TIME
00210		JRST START1
00220		MOVEI 0,ALLOC
00230		MOVEM 0,CCFLAG		;WMT- IF DIFF, SET STARTING ADDRESS TO ALLOC
00240	START1:	HRRZ 0,.JBHRL		;WMT-CHECK TO SEE IF WE HAVE HIGH SEG.
00250		JUMPN 0,START2		;WMT- YES. JUST KEEP IT.
00260		MOVEI 0,HGHDAT
00270		GETSEG 0,		;GET SHARABLE HI-SEG
00280		HALT .
00290	
00300	START2:	MOVSI 17,ACCUMS		;RESTORE ACCUMS
00310		BLT 17,17
00320		SETZM CCBLK+2		;ENABLE ↑C INTERRUPT TRAPPING
00330		JRST CCCONT		;AND EITHER CONTINUE OR ALLOC
00340	
00350	;WMT- REENTER ENTRY POINT 
00360	REENTR:	SETOM	FORCEC		;WMT- FORCE A CONVERSATION
00370		SKIPE	CCFLAG		;WMT- CHECK TO SEE IF EXITED OK
00380		JRST	CCINT		;WMT-   YES
00390		PUSH	P,.JBOPC	;WMT- NO, SET FLAG UP RIGHT
00400		POP	P,CCFLAG
00410	;*** ↑C INTERRUPT HANDLER
00420	CCINT:	SKIPE GCFLAG		;GARBAGE COLLECTING?
00430		JRST GCING		;YES: FINISH UP FIRST
00440		SKIPE CCFLAG		;ALREADY INTERRUPTED?
00450		JRST .+3		;YES: ALREADY SAVED CONTINUE ADDR
00460		MOVE 0,CCBLK+2		;NO
00470		MOVEM 0,CCFLAG		;SAVE CONTINUE ADDRESS
00480		SETZM CCBLK+2		;RE-ENABLE ↑C TRAPPING
00490	;FALLS THROUGH
00500		PAGE
     
00010	;FALLS THROUGH
00020		SKIPE	FORCEC		;WMT- SHOULD WE FORCE CONVERSATION
00030		JRST	CCINT1-1	;WMT-   YES
00040		SKIPN	CCONV		;WMT-DOES HE WANT TALK BEFORE EXIT
00050		JRST	CCEXIT		;WMT- NO, GO EXIT
00060		SETZM	FORCEC		;WMT- CLEAR FORCE CONVERSATION FLAG
00070	CCINT1:	CLRBFI
00080		OUTSTR CCMSG
00090		INCHRW	0		;READ THE INTERRUPT CHARACTER
00100		XCT	OCR		;GIVE HIM A CR/LF
00110		CLRBFI			;WMT- IN CASE OF CRLF
00120	CCTLR:	CAIN	0,CNTLR
00130		JRST	CNTLRH		;WMT-MAKE SURE IT'S IN PAGE 0
00140	CCTLH:	CAIN	0,CNTLH
00150		JRST	CNTLHH		;WMT-MAKE SURE IT'S IN PAGE 0
00160	CCTLE:	CAIN	0,CNTLE
00170		JRST   [MOVE 0,STNIL
00180			MOVEI 1,NIL
00190			SETZM CCFLAG
00200			JRST ERR]
00210	CCTLB:	CAIN	0,CNTLB
00220		JRST   [MOVE 0,STNIL
00230			SETOM ERINT
00240			SETZM CCFLAG
00250			PUSHJ P,SPDLPT
00260			PUSHJ P,SPREDO
00270			JRST LSPRET]	;WMT- CHANGED FROM STRT
00280	CCTLD:	CAIN	0,CNTLD		;*** CHANGED FROM ↑Z
00290		JRST   [MOVE 0,STNIL
00300			SETZM CCFLAG
00310			JRST LSPRET]	;WMT- CHANGED FROM STRT
00320	CCTLG:	CAIN	0,CNTLG
00330		JRST   [MOVE 0,STNIL
00340			MOVEI 1,NIL	;WMT- MAKE SURE (ERRSET - ERRORX) CATCHES NIL
00350			SETZM CCFLAG
00360			JRST RERX]
00370	CCTLX:	CAIN	0,CNTLX
00380		JRST	CNTLXH		;WMT-MAKE SURE IT'S IN PAGE 0
00390		CAIN	0,CR
00400		JRST	CCCONT		;*** IGNORE ↑C
00410		CAIE	QMARK
00420		JRST	CCINT1		;*** TRY AGAIN
00430		OUTSTR	HLPMSG
00440	
00450	;	TALK			;WMT- THIS WOULD LEAVE PAGE 0
00460		JRST CCINT1
00470	
00480		PAGE
     
00010	; FALLS THROUGH
00020	CCEXIT:				;WMT- SAME AS ↑X
00030	CNTLXH:				;WMT - HANDLER FOR ↑X
00040		JRST DOEX2
00050	CNTLRH:	HRRI 0,OBTBL(S)		;WMT- HANDLER FOR ↑R (RESTORE OBLIST)
00060		HRRM 0,VOBLIST(S)
00070		OUTSTR CNTLRM
00080		JRST CCINT1
00090	CNTLHH: SETOM ERINT		;WMT- HANDLER FOR ↑H
00100	;*** CONTINUE AFTER ↑C
00110	CCCONT:	MOVE 0,STNIL		;RESTORE 0
00120		PUSH P,CCFLAG
00130		SETZM CCFLAG
00140		POPJ P,
00150	
00160	;*** ↑C HIT WHILE GARBAGE COLLECTING
00170	GCING1:	PUSH P,.JBOPC		;WMT- SAVE INTERRUPTED ADDRESS
00180		JRST .+2
00190	GCING:	PUSH P,CCBLK+2		;SAVE CONTINUE ADDRESS
00200		SETZM CCBLK+2		;RE-ENABLE INTERRUPT
00210		PUSH P,A
00220		AOS A,CCFLAG		;INCR # OF INTERRUPTIONS THIS GC
00230		CAIL A,5		;IF HE REALLY WANTS OUT KILL GC
00240		JRST KILLGC		;(PRIMARILY PROTECTION AGAINST GC BUGS)
00250		POP P,A			;OTHERWISE RESTORE A, PRINT MESSAGE,
00260		OUTSTR GCINGM		;WMT- MAKE SURE THIS IS IN PAGE 0
00270		POPJ P,			;AND CONTINUE WITH GC
00280	>
00290	
00300	CCON:	EXCH A,CCONV		;TURN ON/OFF CC FLAG
00310		POPJ P,
00320	
00330	;*** EXIT Function - This and ↑X interrupt are only legal ways to leave LISP
00340	;*** (EXIT T)   = Keep High Segment
00350	;*** (EXIT NIL) = Remove High Segment
00360	DOEXIT:	POP P,CCFLAG		;SAVE RETURN (SIMULATING ↑C)
00370		JUMPN A,DOEX2
00380		JRST DOEX1
00390	REMOTE<
00400	DOEX1:	SETOM CCBLK+2		;DISABLE ↑C TRAPPING IF NO HI-SEG AROUND
00410		MOVSI 0,1
00420		CORE 0,			;REMOVE HI-SEGMENT
00430		HALT
00440	DOEX2:	MOVEI 0,ACCUMS		;SAVE ACCUMS
00450		BLT 0,ACCUMS+17
00460		EXIT 1,
00470		JRST START1		;GO CONTINUE IF HE CONT'S
00480	
00490	ACCUMS:	BLOCK 20		;ROOM FOR ACCS
00500		>
00510	
00520		PAGE
     
00010	;WMT - MESSAGES THAT NEED TO BE IN PAGE 0
00020	
00030	REMOTE <
00040	HLPMSG:	ASCIZ /
00050	CR = Continue (Ignore ↑C)
00060	↑D = Return to Top Level
00070	↑X = Exit to Monitor via (EXIT T)
00080	↑H = Break Next Fn Call
00090	↑B = Back Up and Break Last Fn Call
00100	↑G = (ERR @ERRORX)
00110	↑E = (ERR NIL)
00120	↑R = Restore System OBLIST
00130	/
00140	CCMSG:	ASCIZ /
00150	Interrupt (?=help): /
00160	CNTLRM:	ASCIZ /OBLIST restored/
00170	GCINGM:	ASCIZ /
00180	Garbage Collecting . . ./
00190	OCRM:	ASCIZ /
00200	/
00210	OCR:	OUTSTR OCRM
00220	>
00230		PAGE
     
00010		SUBTTL INITIALIZATION AND TOP LEVEL
00020	
00030	STRT:	RESET		;random initializations for lisp interupts
00040		MOVEI APRINT
00050		MOVEM .JBAPR
00060		MOVEI APRFLG
00070		APRENB
00080		MOVEI CCBLK	;*** SET ↑C TRAP LOC
00090		HRRM .JBINT
00100		SETZM CCBLK+2
00110		SETZM CCFLAG
00120		SETZM GCFLAG
00130		IFN ALVINE,<SETZM PSAV1>
00140		MOVE S,ATMOV	;$$SET UP RELOCATION FOR INTERNAL ATOMS (FOOLIST)
00150	;WMT-  PUT LSPRET BACK IN SO THAT OPEN CHANNELS DO NOT GET
00160	;	CLOBBERED BY AN ERROR OR A ↑↑ OR A ↑
00170	LSPRET:	MOVE P,C2#	;initial reg pdl ptr
00180		MOVE B,SC2
00190		PUSHJ P,UBD	;unbind specpdl
00200		SETZM	BIOCHN(S)	;$$CLEAR VARS FOR BREAK PACKAGE
00210		SETZM	BPMPT(S)	;$$(#%IOCHNAS%#, #%PROMPTS%#, AND #%INDENT)
00220		MOVEI	A,INUM0
00230		MOVEM	A,BINDNT(S)
00240		SETZM	ERINT	;$$TURN OFF INTERRUPT FLAG
00250		SETOM ERRSW	;print error messages
00260		SETZM ERRTN#	;return to top level on errors
00270		SETOM PRVCNT#	;initialize counter for errio
00280		MOVE A,LSPRMP	;$$INITIALIZE TO TOP LEVEL PROMPT
00290		PUSHJ P,PROMPT	;$$CAN BE CHANGED BY INITPROMPT
00300		SETZM SMAC	;$$CLEAR SPLICE LIST (JUST IN CASE)
00310	IFN OLDNIL	<HRROI	0,CNIL2(S)>	;INITIALIZE  NIL
00320	IFE OLDNIL	<SETZ	0,	>
00330		MOVEM 0,STNIL#		;*** SAVE FOR RESTORATION AFTER ↑C
00340	IFE OLDNIL	<MOVEI	A,FAKNIL(S)	;*** GET FAKE ATOM HEADER OF NIL
00350			 MOVEM	A,NILHD#>	;*** AND SAVE IT FOR GC
00360	
00370	IFN HASH,<
00380		SKIPE HASHFG#
00390		JRST REHASH	;rehash if necessary>
00400	
00410		PUSHJ P,TTYRET	;(outc nil t)(inc nil t)return output for gc message
00420		PUSHJ P,TERPRI	;*** CR BEFORE INITS CALLED
00430		SKIPN F	
00440		PUSHJ P,AGC	;garbage collect only if necessary
00450		SKIPE GOBF#	;garbaged oblist flag
00460		STRTIP [SIXBIT /GARBAGED OBLIST←!/]
00470		SETZM GOBF
00480		SKIPE BPSFLG#
00490		JRST BINER2	;binary program space exceeded by loader
00500	
00510		SKIPN BSFLG#	;initial bootstrap for macros
00520		JRST BOOTS
00530		SKIPE A,INITF
00540		CALLF (A)	;evaluate initialization function
00550		PUSHJ P,TTYRET	;return all i/o to tty
00560		PUSHJ P,TERPRI
00570	
00580	LISP1:	MOVE S,ATMOV#	;$$MAKE SURE REL STAYS
00590				;$$SET UP - BELT AND SUSPENDERS TECHNIQUE
00600		SETOM TOPFLG#	;*** SET TOP-LEVEL FLAG (GETS CR BEFORE PROMPT IF TTY READ)
00610		PUSHJ P,READ	;this is the top level of lisp
00620		SETZM TOPFLG	;*** CLEAR TOP-LEVEL FLAG JUST IN CASE
00630		PUSHJ P,EVAL
00640		PUSHJ P,PRINT
00650		PUSHJ P,TERPRI
00660		JRST LISP1
00670	
00680	INITFL:	EXCH	A,INITF1#	;## NEW INIT FILE LIST
00690		POPJ	P,		;## RETURN THE OLD ONE
00700	
00710	INITFN:	EXCH A,INITF#
00720		POPJ P,
00730	
00740	.RSET:	EXCH A,RSTSW#
00750		POPJ P,
00760	
00770	COMMENT %
00780		;## OLD BOOTSTRAP CODE FOR INIT FILE, REPLACED BELOW
00790	;BOOTSTRAPPER FOR USER'S INIT FILE
00800	BOOTS:	SETOM BSFLG
00810		MOVE A,[POINT 7,[ASCII /(ERRSET[INC(INPUT DSK:(INIT.LSP]NIL)[(EVAL(READ]/]]
00820		MOVEM A,BOOPT#
00830		MOVEI A,BSTYI
00840		PUSHJ P,READP1
00850		PUSHJ P,EVAL
00860		JUMPE A,BOOTOT
00870		MOVEI A,BSTYI
00880		PUSHJ P,READP1
00890		PUSH P,A
00900		MOVE A,(P)
00910		PUSHJ P,ERRSET
00920		CAIE A,$EOF$(S)
00930		JRST .-3
00940	BOOTOT:	PUSHJ P,EXCISE
00950		JRST ERR
00960	
00970	BSTYI:	ILDB A,BOOPT
00980		POPJ P,
00990		%
01000	
01010		;## NEW IMPROVED BOOTSTRAPPER FOR USER'S INITFILE(S)
01020		;## ALLOWS MORE THAN ONE FILE. FIRST FILE IS READ IN
01030		;## OR IF NOT FOUND BEHAVES AS BEFORE (I.E. NO ERROR MESSAGE)
01040		;## REMAINING FILES WILL CAUSE AN ERROR MESSAGE IF NOT FOUND.
01050		;## THUS IF THE USER IS USING THIS TO REALLY SET UP HIS OWN
01060		;## SYSTEM, HE WILL KNOW ABOUT A FAILURE, BUT THE FIRST
01070		;## FILES EXISTENCE IS STILL OPTIONAL
01080	
01090	BOOTS:	SETOM	BSFLG#		;## INDICATE BOOTSTRAP DONE
01100		SKIPN	T,INITF1#	;## GET INIT FILE LIST IF IT EXISTS
01110		JRST	BOOTOT		;## NOPE, EXCISE AND RETURN
01120		MOVEI	A,TRUTH(S)	;## USE CHANNEL T
01130		PUSHJ	P,INPUT2	;## SET UP
01140		PUSHJ	P,ININIT	;## LOOK UP
01150		JUMPN	A,BOOTOK	;## IT'S THERE, GO TO IT
01160		JUMPE	T,BOOTOT	;## NOT THERE AND NO OTHERS REQUESTED
01170		PUSHJ	P,SETINA	;## SET UP FOR THE REST
01180		PUSHJ	P,ININIT	;## LOOK UP (SECOND FILE IN LIST)
01190		JUMPE	A,AIN.7		;## NOT THERE, ERROR MESSAGE
01200	BOOTOK:	MOVEI	A,TRUTH(S)	;##(INC T NIL)
01210		SETZ	B,
01220		PUSHJ	P,INC		;## SELECT
01230	BOOTLP:	PUSH	P,[.+5]		;*** NEW CODE FOR NEW ERRSET
01240		JSP	R,ERRST1	;*** SET UP STACK
01250		PUSHJ	P,READ
01260		PUSHJ	P,EVAL
01270		JRST	.-2		;## A READ-EVAL LOOP. PROTECTED AGAINST
01280		CAIE	A,$EOF$(S)	;## ALL ERRS EXCEPT $EOF$ AND ERRORX
01290		JRST	BOOTLP		;## LOOP
01300	BOOTOT:	PUSHJ	P,EXCISE
01310		JRST	STRT		;*** GO TO TOP LEVEL
01320		PAGE
     
00010		SUBTTL APR INTERRUPT ROUTINES 
00020	
00030	;arithmetic processor interupts
00040	;mem. protect. violation, nonex. mem. or pdl overflow
00050	
00060	APRINT:	MOVE R,.JBCNI	;get interupt bits
00070		TRNE R,MPV+NXM	;what kind
00080		ERR4 @.JBTPC	;an ill mem ref-will become JRST ILLMEM
00090		SKIPN GCFLAG	;*** pdl overflow - CHECK IF GCING
00100		JRST MES21	;*** NO
00110	KILLGC:	MOVE S,ATMOV	;*** JUST IN CASE
00120		STRTIP [SIXBIT /←PDL OVERFLOW FROM GC - CAN'T CONTINUE!/]
00130		SETZB F,GCFLAG	;*** FORCE A GC FROM TOP-LEVEL
00140		SKIPE CCFLAG
00150		JRST CCSTRT	;*** FIRST INTERRUPT IF ↑C HIT
00160		JRST STRT
00170	
00180	MES21:	SETZM .JBUUO
00190		SKIPL P
00200		STRTIP [SIXBIT /←REG !/]
00210		SKIPL SP
00220		STRTIP [SIXBIT /←SPEC !/]
00230		SKIPE .JBUUO
00240	SPDLOV:	ERR3 [SIXBIT /PUSHDOWN CAPACITY EXCEEDED !/]
00250		TRNE R,PDOV
00260		SKIPE .JBUUO
00270		HALT	.	;lisp should not be here
00280	BINER2:	SETZM BPSFLG
00290		ERR3 [SIXBIT /BINARY PROGRAM SPACE EXCEEDED !/]
00300	
00310	COMMENT %
00320	;*** THIS CODE EVIDENTLY BELONGS TO THE "NEW" CONS ROUTINES, AND
00330	;*** SINCE NOBODY ELSE USES IT . . .
00340	;WMT - WARNING: THIS CODE SEEMS TO DEPEND ON END OF FREE LIST
00350	;	BEING AN ILL MEM REF.  THE ADDRESS 777777 WON'T WORK IF
00360	;	THE SYSTEM IS VIRTUAL.
00370	ILLMEM:	LDB R,[POINT 4,@.JBTPC,XFLD]	;get index field of bad word
00380		CAIE R,F	;does  it contain f
00390		ERR3 @.JBTPC	;no! error
00400		PUSHJ P,AGC	;yes! garbage collect
00410		JRST @.JBTPC	;and continue
00420	%
00430		PAGE
     
00010		SUBTTL UUO HANDLER AND SUBR CALL ROUTINES 
00020	
00030	UUOMIN==1
00040	UUOMAX==5
00050	
00060	REMOTE<
00070	UUOH:	X		;jsr location
00080		JRST	UUOH2>
00090	UUOH2:	MOVEM T,TSV#
00100		MOVEM TT,TTSV#
00110		LDB T,[POINT 9,.JBUUO,OPFLD]	;get opcode
00120		CAIGE T,34	;is it a function call
00130		JRST ERROR	;or a LISP error
00140		HLRE R,@.JBUUO
00150		AOJN R,UUOS	;jump if arg is not an atom
00160		PUSHJ P,CHKREC	;WMT-CHECK FOR PDL OVERFLOW
00170		LDB T,[POINT 4,.JBUUO,ACFLD]
00180		CAILE T,15
00190		MOVEI R,-15(T)
00200		HRRZ T,@.JBUUO
00210	UUOH1:	HLRZ TT,(T)
00220		HRRZ T,(T)
00230		CAIN TT,SUBR(S)
00240		JRST @UUST(R)
00250		CAIN TT,FSUBR(S)
00260		JRST @UUFST(R)
00270		CAIN TT,LSUBR(S)
00280		JRST @UULT(R)
00290		CAIN TT,EXPR(S)
00300		JRST @UUET(R)
00310		CAIN TT,FEXPR(S)
00320		JRST @UUFET(R)
00330		HRRZ T,(T)
00340		JUMPN T,UUOH1
00350		PUSH P,A
00360		PUSH P,B
00370		HRRZ A,.JBUUO
00380		MOVEI B,VALUE(S)
00390		PUSHJ P,GET
00400		JUMPN A,[	HRRZ TT,(A)
00410				POP P,B
00420				POP P,A
00430				JRST UUOEX1]
00440	UUOERR:	HRRZ A,.JBUUO
00450		PUSHJ P,EPRINT+2
00460		ERR2 [SIXBIT /UNDEFINED FUNCTION - UUO CALL!/]	;***
00470		SKIPA T,TT
00480	UUOSBR:	HLRZ T,(T)
00490		JUMPE T,UUOERR	;*** IF FUNC PROP. IS NIL, ERROR
00500		MOVE TT,.JBUUO
00510		HRLI T,(PUSHJ P,)
00520		TLNE TT,1000	;1000 means no push
00530		TLCA T,34600	;<PUSHJ P,>xor<JRST>
00540		PUSH P,UUOH
00550		SOS UUOH
00560		HRRZ	D,UUOH
00570		CAIG	D,SHRST
00580		JRST	.+3
00590		SKIPE	WRTSTS
00600		JRST	.+3
00610	REMOTE<
00620	UUOCL:	TLNN TT,2000>	;2000 means no clobber
00630		XCT	UUOCL
00640		MOVEM T,@UUOH
00650		MOVE TT,TTSV
00660		EXCH T,TSV
00670		JRST @TSV
00680	
00690	UUOS:	HRRZ TT,.JBUUO
00700		CAILE TT,@GCPP1
00710		CAIL TT,@GCP1
00720		JRST UUOSBR-1
00730		JRST .+2
00740	UUOEXP:	HLRZ TT,(T)
00750	UUOEX1:	LDB T,[POINT 5,.JBUUO,ACFLD]
00760		TRZN T,20
00770		PUSH P,UUOH
00780		PUSH P,TT
00790		JUMPE T,IAPPLY
00800		CAIN T,17
00810		MOVEI T,1
00820		MOVNS T
00830		HRLZ TT,T
00840		PUSH P,A(TT)
00850		AOBJN TT,.-1
00860		JRST IAPPLY
00870	PAGE
     
00010	ARGPDL:	LDB T,[POINT 4,.JBUUO,ACFLD]
00020		MOVNS T
00030		HRLZ R,T
00040	ARGP1:	JUMPE R,(TT)
00050		PUSH P,A(R)
00060		AOBJN R,.-1
00070		JRST (TT)
00080	
00090	QTIFY:	PUSHJ P,NCONS
00100		MOVEI B,CQUOTE(S)
00110		JRST XCONS
00120	
00130	QTLFY:	MOVEI A,0
00140	QTLFY1:	JUMPE T,(TT)
00150		EXCH A,(P)
00160		PUSHJ P,QTIFY
00170		POP P,B
00180		PUSHJ P,CONS
00190		AOJA T,QTLFY1
00200	
00210	PDLARG:	JRST .+NACS+2(T)
00220		POP P,A+5
00230		POP P,A+4
00240		POP P,A+3
00250		POP P,A+2
00260		POP P,A+1
00270		POP P,A
00280		JRST (TT)
00290	
00300	NOUUO:	MOVSI B,(TLNN TT,)
00310		SKIPE A
00320		MOVSI B,(TLNA)
00330		HLLM B,UUOCL
00340		EXCH A,NOUUOF#
00350		POPJ P,
00360	PAGE
     
00010	;r=0 => compiler calling a -
00020	;r=1 => compiler calling a lsubr
00030	;r=2 => compiler calling f type
00040	
00050	UUST:	UUOSBR
00060		UUOS1	;calling l its a subr
00070		UUOS2	;calling f
00080	
00090	UUFST:	UUOS9	;calling - its a f
00100		UUOS10	;calling l
00110		UUOSBR
00120	
00130	UULT:	UUOS7	;calling - its a l
00140		UUOSBR
00150		UUOS8
00160	
00170	UUET:	UUOEXP
00180		UUOS5	;calling l its an expr
00190		UUOS6	;calling f its an expr
00200	
00210	UUFET:	UUOS3	;calling - its a fexpr
00220		UUOS4	;calling l
00230		UUOEXP	
00240	
00250	UUOS1:	HLRZ R,(T)
00260		MOVE T,TSV
00270		JSP TT,PDLARG
00280		JRST (R)
00290	
00300	UUOS3:	PUSH P,(T)
00310		JSP TT,ARGPDL
00320	UUOS4A:	JSP TT,QTLFY
00330		MOVEI TT,1
00340		DPB TT,[POINT 4,.JBUUO,ACFLD]
00350	UUOS6A:	POP P,TT
00360		HLRZS TT
00370		JRST UUOEX1
00380	
00390	UUOS4:	PUSH P,(T)
00400		MOVE T,TSV
00410		JRST UUOS4A
00420	PAGE
     
00010	UUOS5:	HLRZ R,(T)
00020		MOVE T,TSV
00030		JSP TT,PDLARG
00040		MOVNS T
00050		DPB T,[POINT 4,.JBUUO,ACFLD]
00060		MOVE TT,R
00070		JRST UUOEX1
00080	
00090	UUOS6:	PUSH P,(T)
00100		PUSH P,UUOH
00110		PUSH P,.JBUUO
00120		JSP TT,ILIST
00130		JSP TT,PDLARG
00140		POP P,.JBUUO
00150		POP P,UUOH
00160		JRST UUOS6A
00170	UUOS8:	SKIPA TT,CILIST
00180	UUOS7:	MOVEI TT,ARGPDL
00190		HRRM TT,UUOS7A
00200		MOVE TT,.JBUUO
00210		TLNN TT,1000
00220		PUSH P,UUOH
00230		HLRZ TT,(T)
00240		JRST @UUOS7A	;OR ILIST
00250	REMOTE<
00260	UUOS7A:	ARGPDL>
00270	
00280	UUOS9:	PUSH P,T
00290		JSP TT,ARGPDL
00300	UUS10A:	JSP TT,QTLFY
00310		MOVSI T,2000
00320		IORM T,.JBUUO
00330		POP P,T
00340		JRST UUOSBR
00350	
00360	UUOS10:	PUSH P,T
00370		MOVE T,TSV
00380		JRST UUS10A
00390	
00400		PAGE
     
00010		SUBTTL ERROR HANDLER AND BACKTRACE 
00020	;subroutine to print sixbit error message
00030	ERRSUB:	MOVSI A,(POINT 6,0)
00040		HRR A,.JBUUO
00050		MOVEM A,ERRPTR#
00060	ERRORB:	ILDB A,ERRPTR
00070		CAIN A,01	;conversion from sixbit
00080		POPJ P,
00090		CAIN A,77
00100		JRST [	PUSHJ P,TERPRI
00110			JRST ERRORB]
00120		ADDI A,40
00130		PUSHJ P,TYO
00140		JRST ERRORB
00150	
00160	;subroutine to return output to previously selected device
00170	OUTRET:	SKIPL PRVCNT	;if prvcnt<0 then there was no device deselect
00180		SOSL PRVCNT	;when prvcnt goes negative, then reselect
00190		POPJ P,
00200		PUSH P,PRVSEL#		;previously selected output
00210		POP P,TYOD
00220		POPJ P,
00230	
00240	;subroutine to force error messages out on tty
00250	ERRIO:	TALK		;*** UNDO ↑O (MOVED FROM BELOW)
00260		MOVE B,ERRSW
00270		CAIE B,INUM0	;inum0 specifies to print message on selected device
00280		AOSLE PRVCNT	;only if prvcnt already <0 does deselection occur
00290		POPJ P,	
00300		MOVE B,[JRST TTYO]
00310		EXCH B,TYOD
00320		MOVEM B,PRVSEL
00330		POPJ P,
00340	
00350	;ERRTN:	0	;0 => top level				*
00360		;- => pdl to reset to - stored by errorset
00370		;+ => string tyo pout rtn flag
00380	REMOTE<
00390	ERRSW:	-1>	;0 means no prnt on error
00400	PAGE
     
00010	;subroutine to search oblist for closest function to address in r
00020	ERSUB3:
00030		MOVEI A,QST(S)
00040	IFN OLDNIL<	HRROI NIL,CNIL2(S)>
00050	IFE OLDNIL<	SETZ	NIL,	>
00060	
00070		HRLZ B,INT1
00080		MOVNS B
00090		SETZB AR2A,GOBF
00100		PUSH P,.JBAPR
00110		MOVEI C,[	SETOM GOBF
00120				JRST ERRO2G]
00130		HRRM C,.JBAPR
00140		HRRZ	C,VOBLIST(S)	;## GET CURRENT OBLIST
00150		HRRM	C,RHX5
00160		HRRM	C,RHX2		;## AND UPDATE LOCATIONS WHICH REF OBLIST
00170		HLRZ C,@RHX5
00180	ERRO2B:	JUMPE C,[	AOBJN B,.-1
00190				POP P,.JBAPR	;oblist done, restore
00200				JRST PRINC]	;print closest match
00210		HLRZ TT,(C)
00220	ERRO2C:	HRRZ TT,(TT)
00230		JUMPE TT,ERRO2G
00240		HLRZ AR1,(TT)
00250		CAIN AR1,LSUBR(S)
00260		JRST ERRO2H
00270		CAIE AR1,SUBR(S)
00280		CAIN AR1,FSUBR(S)
00290		JRST ERRO2H
00300		HRRZ TT,(TT)
00310		JRST ERRO2C
00320	
00330	ERRO2H:	HRRZ TT,(TT)
00340		HLRZ TT,(TT)
00350		CAMLE TT,AR2A	;le to prefer car to quote
00360		CAMLE TT,R
00370		JRST ERRO2G
00380		MOVE AR2A,TT
00390		HLRZ A,(C)
00400	ERRO2G:	HRRZ C,(C)
00410		JRST ERRO2B
00420	PAGE
     
00010	;dispatcher for error message uuos
00020	ERROR:	MOVEI A,APRFLG
00030		APRENB A,	;enable interupts
00040		SETOM ERRTYP#	;*** SET FLAG FOR "SERIOUS" ERROR
00050		LDB A,[POINT 9,.JBUUO,OPFLD]	;get opcode
00060		CAIL A,UUOMIN	;what
00070		CAILE A,UUOMAX	;is it?
00080		JRST ILLUUO	;an illegal opcode
00090		JRST @ERRTAB-UUOMIN(A)	;or LISP error
00100	ERRTAB:	ERROR1	;1	;"correctable" LISP error
00110		ERROR2	;2	;"serious" LISP error
00120		ERROR3	;3	;space overflow error
00130		ERROR4	;4	;ill. mem. ref.
00140		STRTYP	;5	;print error message and continue
00150	
00160	ERROR3:	MOVE P,ERRTN	;IF IN ERRSET, RESTORE P TO THAT LEVEL
00170		SKIPN P
00180		MOVE P,C2	;else to top level
00190		SETOM UUO2#	;$$ AND DON'T ENTER ERRORX
00200	ERROR2:	SKIPN ERRSW
00210		JRST ERREND
00220		JRST ERRPRI	;*** "SERIOUS" ERRORS ALWAYS PRINT MESSAGE BEFORE BREAKING
00230	
00240	ERROR1:	SKIPN ERRSW
00250		JRST ERREND	;dont print message, call (err nil)
00260		SETZM ERRTYP	;*** CHANGE FLAG TO "CORRECTABLE" ERROR
00270		MOVE A,RSTSW	;*** CHECK *RSET FLAG TO CHECK FOR PRINT
00280		CAIN A,ERRORX(S) ;*** @ERRORX = NO
00290		JRST ERREND
00300	ERRPRI:	PUSHJ P,ERRIO	;print message on tty
00310		PUSHJ P,TERPRI
00320		PUSHJ P,ERRSUB	;print the message
00330		JRST ERRBK	;go the backtrace
00340	
00350	STRTYP:	PUSHJ P,ERRIO
00360		PUSHJ P,ERRSUB	;print message and continue
00370		PUSHJ P,OUTRET
00380		JRST @UUOH
00390	
00400	;USER ENTRY TO ERROR HANDLER, PRINTS ARG IF NON-NIL
00410	.ERROR:	SETOM ERRTYP	;*** SET FLAG FOR "SERIOUS" ERROR
00420		JUMPE	A,ERREND
00430		SKIPN	ERRSW
00440		JRST	ERREND
00450		PUSHJ	P,ERRIO
00460		PUSHJ	P,TERPRI
00470		PUSHJ	P,PRINC
00480		JRST	ERREND
00490	PAGE
     
00010	ERROR4:	HRRZ A,.JBUUO
00020		MOVEI B,[SIXBIT / ILL MEM REF FROM !/]
00030		JRST ERSUB2
00040	
00050	ILLUUO:	HRRZ A,UUOH
00060		MOVEI B,[SIXBIT / ILL UUO FROM !/]
00070	
00080	ERSUB2:	SKIPN ERRSW
00090		JRST ERREND	;dont print message
00100		PUSH P,A
00110		PUSH P,B
00120		PUSHJ P,ERRIO
00130		PUSHJ P,TERPRI
00140		PUSHJ P,PRINL2	;print number
00150		POP P,A
00160		STRTIP (A)	;print message
00170		POP P,R
00180		PUSHJ P,ERSUB3	;print nearest oblist match
00190	ERRBK:
00200	IFN ALVINE,<
00210		SKIPE BACTRF
00220		PUSHJ P,BKTRC	;print backtrace
00230	>
00240		PUSHJ P,OUTRET	;return to previous device
00250	
00260	ERREND:	SETZ	A,		;## %CLRBFI USED TO BE HERE(FOR ERR NIL)
00270		SKIPN	UUO2		;$$NO ERRORX IF OVERFLOW ERROR
00280		JRST	.+3
00290		SETZM	UUO2		;$$RESET TO ZERO
00300		JRST	RERX		;$$BOUNCE BACK TO ERRORX
00310		SKIPE	RSTSW		;$$NEW *RSET FEATURE
00320		SKIPN	ERRSW		;***CHECK ERRSET FLAG
00330		JRST	ERR		;$$IF (*RSET NIL) UNBIND AND GO TO TOP LEVEL
00340		PUSHJ	P,%CLRBFI	;## CLEAR TTY BUFFER. ELIMINATE FLUSHING
00350		SKIPE	A,ERRTYP	;*** GET ERROR TYPE FLAG
00360		MOVEI	A,TRUTH(S)	;*** NZ = SERIOUS, Z = CORRECTABLE
00370		PUSHJ	P,NCONS		;*** SET TO PASS FLAG TO ERRORX
00380		MOVEI	B,ERRORX(S)	;$$SET TO CALL ERROR HANDLER
00390		PUSHJ	P,XCONS		;$$CREATE FORM (ERRORX flag)
00400		JRST	EVAL		;$$AND EVALUATE IT
00410	PAGE
     
00010	ERR:	SETZM	INHERR		;CLEAR RERX FLAG JUST IN CASE
00020		CAIN A,ERRORX(S)	;$$BOUNCE TO ERRORX IF A=ERRORX
00030		JRST RERX
00040	ERR2:	SKIPN ERRTN
00050		JRST LSPRET	;not in an errset, or bad error -- go to top level
00060				;WMT- CHANGED FROM STRT
00070		MOVE P,ERRTN
00080	ERR1:	POP P,B
00090		PUSHJ P,UBD	;unbind to previous errset
00100		POP P,ERRSW
00110		POP P,ERRTN
00120		SKIPN	INHERR#
00130		JRST ERRP4	;and proceed
00140	
00150	RERX:	SETZM	INHERR	;$$ POP TO A BREAK ERRSET
00160		MOVE	B,ERRSW
00170		CAIE	B,ERRORX(S)
00180		SETOM	INHERR
00190		JRST	ERR2
00200	
00210	ERRSET:	MOVE B,A	;*** New ERRSET with entry points for
00220		HRRZ A,(B)	;*** in-line compiled ERRSET code
00230		CAIN A,0
00240		SKIPA A,[1]	;*** (USE T (1) FOR ERR FLAG IF MISSING)
00250		HLRZ A,(A)
00260		JSP R,ERRST1
00270		HLRZ A,(B)	;*** GET EXPRESSION AND EVALUATE IT
00280		PUSHJ P,EVAL
00290		JRST ERRST2	;*** NO ERROR, SO GO UNDO STACK
00300	
00310	ERRST1:	PUSH P,PA3	;*** SET UP STACK FOR ERROR TRAP
00320		PUSH P,PA4	;*** (CALLED FROM COMPILED CODE)
00330		PUSH P,ERRTN	;*** NOTE THAT THE COMPILER HAS FAITH IN THE
00340		PUSH P,ERRSW	;*** FACT THAT 5 ITEMS ARE PUSHED - DON'T
00350		PUSH P,SP	;*** DISAPPOINT HIM
00360		MOVEM P,ERRTN
00370		MOVEM A,ERRSW
00380		JRST (R)
00390	
00400	ERRST2:	PUSHJ P,NCONS	;*** COME HERE FOR NON-ERROR RETURN
00410				;*** (CALLED FROM COMPILED CODE)
00420		SETZM INHERR	;CLEAR RERX FLAG
00430		JRST ERR1
00440	
00450	SYSCLR:	SETZM BSFLG	;FUNCTION TO MAKE SYSTEM LOOK NEW
00460		SETZM	CONSVA	;## RESET CONS COUNT
00470		SETZM	GCTIM	;## RESET GC TIME
00480		JRST	EXCISE	;## EXCISE
00490	PAGE
     
00010	;error messages
00020	
00030	
00040	
00050	
00060	RMERR:	MOVE A,T	;$$ BAD READ MACRO, GET THE NAME
00070		PUSHJ P,EPRINT+2	;$$
00080		ERR2 [SIXBIT /UNDEFINED READ MACRO!/]
00090	
00100	BNDERR:	PUSHJ P,EPRINT+2	;$$ATTEMPT TO REBIND NIL OR T (*** OR ILLEGAL VAR)
00110		ERR2 [SIXBIT /CAN'T BE USED AS VARIABLE!/]
00120	
00130	RPAERR:	PUSHJ	P,EPRINT+2	;$$PRINT OUT OFFENDING ITEM
00140		ERR2 [SIXBIT /IS AN ATOM, CAN'T BE RPLACA'D!/]
00150	
00160	RPDERR:	PUSHJ	P,EPRINT+2	;$$
00170		ERR2 [SIXBIT /CAN'T BE RPLACD'D (NIL OR INUM)!/]
00180	
00190	DOTERR:	SETZM OLDCH
00200		ERR2 [	SIXBIT /DOT CONTEXT ERROR!/]
00210	UNDFUN:	HLRZ A,(AR1)
00220		PUSHJ P,EPRINT
00230		ERR1 [SIXBIT /UNDEFINED FUNCTION!/]
00240	UNBVAR:	PUSHJ P,EPRINT
00250		ERR1 [SIXBIT /UNBOUND VARIABLE - EVAL!/]
00260	NONNUM:	ERR1 [SIXBIT /NON-NUMERIC ARGUMENT!/]
00270	NOPNAM:	ERR2 [SIXBIT /NO PRINT NAME - INTERN!/]
00280	NOLIST:	ERR2 [SIXBIT /NO LIST - MAKNAM!/]
00290	TOMANY:	ERR1 [SIXBIT /TOO MANY ARGUMENTS SUPPLIED - APPLY!/]
00300	TOOFEW:	ERR1 [SIXBIT /TOO FEW ARGUMENTS SUPPLIED - APPLY!/]
00310	UNDTAC: HRRZ A,(C)
00320	UNDTAG:	PUSHJ P,EPRINT
00330		ERR1 [SIXBIT /UNDEFINED FUNCTION - APPLY!/]
00340	SETERR:	PUSHJ P,EPRINT+2		;$$BAD SET OR SETQ
00350		ERR2 [SIXBIT /CAN'T BE SET TO A VALUE - SET OR SETQ!/]
00360	EG1:	PUSHJ P,EPRINT
00370	;???? WMT - SHOULD THIS BE ERR2?
00380		ERR1 [SIXBIT /UNDEFINED PROG TAG - GO!/]
00390	EG2:	PUSHJ P,EPRINT+2
00400		ERR2 [SIXBIT /GO WITH NO PROG!/]
00410	EG3:	ERR2 [SIXBIT /RETURN WITH NO PROG!/]
00420	ARRERR:	ERR2 [SIXBIT /ARRAY SUBSCRIPT OUT OF BOUNDS!/]	;***
00430	PAGE
     
00010	IFN ALVINE,<
00020	
00030	;backtrace subroutine
00040	BKTRC:	MOVEI D,-1(P)
00050		MOVN A,BACTRF
00060		ADDI A,INUM0
00070		JUMPL A,[	ADD A,P	;backtrace specific number 
00080				JRST .+3]
00090		SKIPN A,ERRTN	;backtrace to previous errset
00100		MOVE A,C2	;or top level
00110		HRRZM A,BAKLEV#
00120		STRTIP [SIXBIT /←BACKTRACE←!/]
00130	BKTR2:	CAMG D,BAKLEV
00140		JRST FALSE	;done 
00150		HRRZ A,(D)	;get pdl element
00160		CAIGE A,FS(S)
00170		JUMPN A,.+2	;this is (hopefully) a true program address
00180		SOJA D,BKTR2	;not a program address, continue
00190		CAIN A,ILIST3
00200		JRST BKTR1A	;argument evaluation 
00210	BKTR1B:	CAIN A,CPOPJ
00220		JRST [	HLRZ A,(D)	;calling a function
00230			PUSHJ P,PRINC
00240			XCT "-",CTY
00250			STRTIP [SIXBIT /ENTER !/]
00260			SOJA D,BKTR2]
00270		HLRZ B,-1(A)
00280		CAILE B,(JCALLF 17,@(17))
00290		CAIN B,(PUSHJ P,)	;tests for various types of calls
00300		CAIGE B,(FCALL)
00310		SOJA D,BKTR2		;not a proper function call
00320		PUSH P,-1(A)	;save object of function call
00330		MOVEI R,-1(A)	;location of function call
00340		PUSHJ P,ERSUB3		;print closest oblist match
00350		MOVEI A,"-"
00360		PUSHJ P,TYO
00370		POP P,R
00380		TLNE R,17
00390		HRRZ R,ERSUB3	;qst -- cant handle indexed calls
00400		HRRZS R
00410		HLRO B,(R)
00420		AOSN B
00430		JRST [	HRRZ A,R	;was calling an atomic function
00440			PUSHJ P,PRINC	;print its name
00450			JRST .+2]
00460		PUSHJ P,ERSUB3	;was calling a code location -- print closest match
00470		MOVEI A," "
00480		PUSHJ P,TYO
00490	BKTR1:	SOJA D,BKTR2	;continue
00500	
00510	BKTR1A:	HRRZ B,-1(D)
00520		CAIE B,EXP2
00530		CAIN B,ESB1
00540		JRST .+2
00550		JRST BKTR1B	;hum, not really evaluating arguments
00560		HLRE B,-1(D)
00570		ADD B,D
00580		HLRZ A,-3(B)
00590		JUMPE A,BKTR1
00600		PUSHJ P,PRINC
00610		XCT "-",CTY
00620		STRTIP [SIXBIT /EVALARGS !/]
00630		JRST BKTR1
00640			;*** TURNED OFF UNLESS ALVINING
00650	BAKGAG:	EXCH A,BACTRF#
00660		POPJ P,
00670	>
00680		PAGE
     
00010		SUBTTL TYI AND TYO  
00020	;input
00030	ITYI:	PUSHJ P,TYI	;## RETURN ASCII VALUE OF INPUT  CH
00040	FIXI:	ADDI A,INUM0
00050		POPJ P,
00060	
00070	TYI:	MOVEI AR1,1	;## TO TEST FOR LINED TYPESEQUENCE #, ETC
00080		PUSHJ P,TYIA
00090		JUMPE A,.-1
00100		CAME A,IGSTRT	;start of comment or ignored cr-lf
00110		POPJ P,
00120		PUSHJ P,COMMENT
00130		JRST TYI+1
00140	
00150	TYIA:	SKIPE A,OLDCH		;##  IF CH  IN OLDCH
00160		JRST	TYI1		;## TAKE CARE OF IT
00170	TYID:	XCT	TYI2		;##  INPUT A CHARACTER
00180	REMOTE<
00190	TYI2:	JRST TTYI>		;sosg x for other device input
00200					;other device input
00210		JRST TYI2X
00220	TYI3B:	ILDB A,@TYI3#		;pointer
00230		XCT	TYI3A		;## SEE IF LINED TYPE WORD
00240	REMOTE<
00250	TYI3A:	TDNN AR1,@X>		;pointer
00260		JRST	CHKLC		;## NO, OK
00270	
00280	IFN STPGAP,<
00290		MOVE A,@TYI3A
00300		CAMN A,[<ASCII /     />+1]	;page mark for stopgap
00310		AOSA PGNUM	;increment page number
00320		MOVEM A,LINUM
00330	>
00340		MOVNI A,5
00350		ADDM A,@TYI2	;adjust character count for line number
00360		AOS @TYI3	;increment byte pointer over line number and tab
00370		JRST TYID
00380	
00390	REMOTE<
00400	TYI2X:	INPUT X,
00410	TYI2Y:	STATZ X,740000
00420		ERR2 AIN.8	;input error
00430	IFN RANDOM,<
00440	TYI2W:	AOS X>		;WMT- INCREMENT BUFFER COUNT
00450	TYI2Z:	STATO X,20000
00460		JRST TYI3B	;continue with file
00470	TYIEOF:	JRST TYI2Q	;END OF FILE
00480	>
00490	TYI2Q:	SKIPN INREAD#		;WMT-WARN IF UNEXPEXTED EOF
00500		JRST TYI2Q1
00510		MOVE A,INCH		;WMT- GET PATH OF INPUT CHANNEL
00520		PUSHJ P,CHNPT1		;WMT-  GO GET IT
00530		PUSHJ P,EPRNT1		;WMT- PRINT IT OUT.
00540		STRTIP [SIXBIT /WARNING-EOF HIT DURING A READ←!/]
00550		SETZM INREAD		;WMT-CLEAR IT
00560	TYI2Q1:	PUSH P,T
00570		PUSH P,C
00580		PUSH P,R
00590		PUSH P,AR1
00600		MOVE A,INCH
00610		HRRZ C,CHTAB(A)	;get location of data for this channel
00620		HLRZ T,CHTAB(A)	;inlst	-- remaining files to input
00630		JUMPE T,TYI2E	;none left -- stop
00640		PUSHJ P,SETIN	;start next input
00650		PUSHJ P,ININIT	;## INIT THE FILE
00660		JUMPE A,AIN.7	;## CAN'T FIND FILE, ERROR
00670		POP P,AR1
00680		POP P,R
00690		POP P,C
00700		POP P,T
00710		JRST TYI
00720	
00730	TYI2E:	PUSHJ P,INCNT	;(inc nil t)
00740	;***	TALK Removed to allow output from several files to be suppressed with one ↑O
00750		MOVEI A,$EOF$(S)	;we are done
00760		JRST ERR
00770	
00780	IFN STPGAP,<
00790	PGLINE:	MOVE C,[POINT 7,LINUM]
00800		PUSHJ P,NUM10	;convert ascii line number to a integer
00810		ADDI A,INUM0
00820		MOVE B,PGNUM
00830		ADDI B,INUM0+1
00840		JRST XCONS>
00850	
00860	REMOTE<
00870	OLDCH:	0
00880	IFN STPGAP,<
00890	PGNUM:	0
00900	LINUM:	0
00910		0>>	;zero to terminate num10
00920	
00930	;TTYECHO - COMPLEMENTS THE TTY: ECHO BIT AND RETURNS T IF THE ECHO
00940	;	   IS BEING TURNED ON AND NIL IF IT IS BEING TURNED OFF
00950	;	 - TAKES NO ARGUMENTS
00960	ECHO:	SETO	A,
00970		GETLCH	A	;GET STATUS BITS
00980		TLC	A,4	;COMPLEMENT THE ECHO BIT
00990		SETLCH	A	;RESTORE THE BITS
01000		TLNE	A,4	;TEST TO GET FINAL VALUE
01010		JRST	FALSE
01020		JRST	TRUE
01030	
01040	;CLRBFI - CLEARS TTY INPUT BUFFER FOR USER ERRORS
01050	;       - 0 ARGS AND RETURNS NIL
01060	%CLRBFI:CLRBFI		;CLEAR BUFFER
01070		SETZM	SMAC	;CLEAR SPLICE LIST
01080		SETZM	OLDCH	;CLEAR LAST CHAR.
01090		JRST	FALSE
01100	PAGE
     
00010	;teletype input
00020	
00030	TTYI:	SKIPE DDTIFG		;## DDT MODE?
00040		JRST TTYID
00050		move	a,linl		; reset chrct on a read			[ut]
00060		movem	a,chct		; (this has caused problems in the past)
00070		SKPINC		;*** this gets rid of redundant prompts
00080		JRST DOPROM	;*** when line is almost full
00090	TTYINC:	INCHWL A	;***
00100	
00110	TTYXIT:	CAMN	A,ERRCHR	;## BELL, NEED NOT BE ↑G
00120		JRST TTYERC
00130		SKIPN PSAV	;*** CHECK FOR SPECIAL CNTRL CHARS ONLY IN READ
00140		JRST CHKLC	;WMT-CHECK FOR LC INPUT
00150		CAMN A,RERCHR
00160		JRST DORUB		;*** RESTART READ
00170		CAME A,EDCHR
00180		JRST CHKLC	;WMT-CHECK FOR LC INPUT
00190		SETOM EDFLAG#		;*** SET FLAG FOR EDIT
00200		JRST TTYI		;*** AND IGNORE CHAR
00210	
00220	DOPROM:	SKIPE TLKFLG#		;*** DO WE NEED A TALK (FIRST PROMPT)
00230		TALK
00240		SETZM TLKFLG		;*** NO TALK ON SUBSEQUENT PROMPTS
00250		SKIPE TOPFLG		;*** DO WE NEED A TERPRI (TOP-LEVEL READ)
00260		PUSHJ P,TERPRI
00270		SETZM TOPFLG		;*** ONLY ONCE PER TOP-LEVEL READ
00280	ASKINP:	MOVE	A,PROMX	;&& ISSUE PROMPT TO USER
00290		CAIGE	A,INUMIN	;&& SKIP IF INUM
00300		JRST	ASKIN1		;&& ELSE ITS AN ATOM
00310		MOVEI	A,-INUM0(A)	;&& CONVERT FROM INUM0
00320		OUTCHR	A		;&& ISSUE PROMPT CHAR
00330		JRST	TTYINC
00340	ASKIN1:	PUSH	P,C		;&& MUST PRESERVE REG. C
00350		SETCM	C,(A)		;&& CHECK ATOM HEADER
00360		TLNE	C,777777	;&&  (CAR OF AN ATOM)
00370		  JRST	[POP	P,C	;&& --NOT AN ATOM
00380			 ERR1	[SIXBIT /PROMPT NO LONGER AN ATOM!/]]
00390		MOVEI	B,PNAME(S)
00400		PUSHJ	P,GET		;&& GET ATOM'S PNAME
00410		PUSH	P,C+1		;&& SAVE REG. TO RESTORE LATER
00420		SETZ	C+1,		;&& ASSURE NULL CHAR FOR OUTSTR
00430	ASKIN2:	HLRZ	B,(A)		;&& B := CAR A
00440		MOVE	C,(B)		;&& GET A FULL WORD OF PRINT NAME
00450		OUTSTR	C		;&& TYPE IT
00460		HRR	A,(A)		;&& A := CDR A
00470		TRNE	A,777777	;&& IS A = NIL ?
00480		  JRST	ASKIN2		;&& NO...MORE PROMPT TO TYPE
00490		POP	P,C+1		;&& MUST RESTORE REGISTERS
00500		POP	P,C		;&& LIKEWISE
00510		JRST	TTYINC		;WMT- GO READ CHAR
00520	
00530	CHKLC:	CAIL A,"a"	;WMT-CHECK FOR LOWER CASE
00540		CAILE  A,"z"	;WMT-LOOK FOR LOWER CASE
00550		POPJ P,		;WMT-WAS NOT LOWER CASE
00560		SKIPE %TTYUC(S)	;WMT-DO NOTHING IF NIL
00570		SUBI A,"a"-"A"	;WMT-MAKE IT UPPER CASE
00580		POPJ	P,	;WMT-ALL DONE
00590	
00600	TTYERC:
00610	IFN ALVINE,<
00620		SKIPE PSAV1#	;bell from alvine?
00630		JRST [	MOVE P,PSAV1	;yes, return to alvine
00640			JRST @ED1];$$DOUBLY IMPROVED MAGIC>
00650		MOVEI	A,NIL	;$$ RETURN NIL AS THE VALUE
00660		JRST	RERX	;$$ RETURN TO AN ERRORX ERRSET
00670	
00680	TTYID:	INCHRW A	;single character input ddt submode style
00690		CAIE A,RUBOUT
00700		JRST TTYXIT
00710		OUTCHR ["\"]	;echo backslash
00720	DORUB:	SKIPE PSAV
00730		JRST RDRUB	;rubout in read resets to top level of read
00740		POPJ P,
00750	
00760	ERRCH:	MOVEI	A,-INUM0(A)	;## CHANGE BELL CHARACTER
00770		EXCH	A,ERRCHR	;## RETURN OLD CHARACTER
00780		JRST	FIX1A		;## CONVERT IT
00790	
00800	EDITCH:	MOVEI A,-INUM0(A)	;*** CHANGE EDIT CHARACTER
00810		EXCH A,EDCHR
00820		JRST FIX1A
00830	
00840	RERDCH:	MOVEI A,-INUM0(A)	;*** CHANGE REREAD CHARACTER
00850		EXCH A,RERCHR
00860		JRST FIX1A
00870	
00880	REMOTE	<
00890	ERRCHR:	BELL
00900	EDCHR:	CNTLF
00910	RERCHR:	CNTLZ
00920	PROMCH:	"*"
00930	PROMX:	"*"+INUM0
00940	LSPRMP:	"*"+INUM0>
00950	
00960	PROMPT:	SKIPN	A		;&& SKIP IF NON-NIL
00970		  JRST	PROMP1		;&& RETURN CURRENT PROMPT
00980		PUSH	P,A		;&& SAVE ARG
00990		CAIGE	A,INUMIN	;&& TEST WHETHER INUM OR ATOM
01000		  PUSHJ	P,ATOM		;&& (SUBR ATOM BASHES REG. A)
01010		SKIPN	A		;&& SKIP IF ONE OR THE OTHER
01020		  JRST	[POP 	P,A
01030			 PUSHJ	P,EPRINT
01040			 ERR1	[SIXBIT /NEW PROMPT NOT ATOMIC!/]]
01050		POP	P,A		;&& GET BACK ARG IF ATOM BASHED IT
01060		EXCH	A,PROMX		;&& SAVE NEW PROMPT
01070		POPJ	P,		;&& AND RETURN OLD ONE
01080	PROMP1:	MOVE	A,PROMX		;&& JUST RETURN CURRENT PROMPT
01090		POPJ	P,
01100	
01110	
01120	INTPRP:	SKIPN A
01130		SKIPA A,LSPRMP
01140		EXCH A,LSPRMP		;$$ EXCHANGE FOR OLD TOP LEVEL PROMPT
01150		POPJ P,			;$$
01160	
01170	READP:	SKPINC		;$$ T IFF A CHARACTER HAS BEEN TYPED
01180		JRST	FALSE	;$$ (DOES NOT CHECK OLDCH)
01190		JRST	TRUE
01200	
01210	UNTYI:	MOVEI	B,-INUM0(A)	;$$ UN-READ A CHARACTER (PUT IT IN OLDCH)
01220		MOVEM	B,OLDCH
01230		POPJ	P,		;$$ RETURN ARG AS VALUE
01240	
01250	DDTIN:	EXCH A,DDTIFG#
01260		POPJ P,
01270	PAGE
     
00010		;output
00020	ITYO:	SUBI A,INUM0
00030		PUSHJ P,TYO
00040		JRST FIXI
00050	
00060	TYO:	CAIG A,CR
00070		JRST TYO3
00080		SOSGE CHCT
00090		JRST TYO1
00100		JRST	TYOD
00110	REMOTE<
00120	TYOD:	JRST TTYO+X	;sosg x for other device
00130				;other device output
00140		JRST TYO2V
00150	TYO5:	IDPB A,X
00160		POPJ P,
00170	
00180	TYO2V:
00190	IFN RANDOM,<
00200	TYO2W:	AOS X>		;WMT- INCREMENT BUFFER COUNT
00210	TYO2X:	OUT X,
00220		JRST TYO5
00230		ERR2 [SIXBIT /OUTPUT ERROR!/]
00240	>
00250	
00260	TYO1:	PUSH P,A	;linelength exceeded
00270		MOVEI A,IGCRLF	;inored cr-lf
00280		PUSHJ P,TYOD
00290		PUSHJ P,TERPRI	;force out a cr-lf, with special mark
00300			POP P,A
00310		SOSA CHCT
00320	TYO4:	POP P,B
00330		JRST TYOD
00340	
00350	TYO3:	CAIGE A,TAB
00360		JUMPN A,TYO+2	;everything between 0(null) and 11(tab) decrement chct
00370		PUSH P,B
00380		MOVE B,LINL
00390		CAIN A,TAB
00400		JRST [	SUB B,CHCT
00410			IORI B,7	;simulate tab effect on chct
00420			SUB B,LINL
00430			SETCAM B,CHCT
00440			JRST TYO4]
00450		CAIN A,CR
00460		MOVEM B,CHCT	;reset chct after a cr
00470		JRST TYO4
00480	
00490	LINELENGTH:
00500		JUMPE A,LINEL1
00510		SUBI A,INUM0
00520		HRRM A,LINL
00530		HRRM A,CHCT
00540	LINEL1:	HRRZ A,LINL
00550		JRST FIXI
00560	
00570	CHRCT:	MOVE A,CHCT
00580		comment	&
00590	
00600		This new code doesn't seem to work.  Don't know yet whether
00610		it's bad code, or a TRMOP. bug.
00620	
00630		HRRZ B,TYOD		;WMT- UPDATE WHERE YOU ARE IF TTY:
00640		CAIE B,TTYO		; ARE WE LOOKING AT TTY:?
00650		JRST FIXI		; NO
00660		SETO C,			; GET THIS JOB NUMBER
00670		TRMNO. C,		; AND NOW THE TERMINAL #
00680		JRST FIXI		; HUH? OH, WELL..
00690		MOVE D,[XWD 2,B]	; ARGUMENTS
00700		MOVEI B,1011		; READ THE CARRIAGE POSITION
00710		TRMOP. D,
00720		JRST FIXI
00730		MOVE A,LINL		; LINELENGTH
00740		SUB A,D			;- CURRENT POSITION
00750		MOVEM A,CHCT		;= CHARACTERS LEFT
00760	&
00770		JRST FIXI
00780	
00790	REMOTE<
00800	LINL:	TTYLL
00810	CHCT:	TTYLL>
00820	PAGE
     
00010	;teletype output
00020	TTYO:	OUTCHR A	;output single character in a
00030		POPJ P,
00040	
00050	TTYRET:	PUSHJ P,OUTCNT
00060		JRST INCNT
00070	
00080	;*** NEW ROUTINE TO TURN OFF CNTRL-O - ELIMINATES PROBLEM WHEREBY ↑O
00090	;*** WAS STRUCK AFTER ERROR MESSAGE, ETC., WAS ALREADY PRINTED
00100	;*** (I.E., WHILE LAST BUFFER WAS BEING DUMPED) SO TALK COULDN'T UNDO IT.
00110	;*** WE NOW WAIT FOR ALL OUTPUT TO BE FLUSHED BEFORE TURNING OFF ↑O
00120	TTYCLR:	SETZ A,			;USER ENTRY POINT (RETURNS NIL)
00130		PUSH P,A		;SYSTEM ENTRY POINT (SAVES A)
00140		SKIPA A,PJOBNO	;WMT- AVOID DOING THE UUO REPEATEDLY
00150		PJOB A,		;GET JOB #
00160		MOVEM A,PJOBNO	;WMT- SAVE JOB NUMBER
00170		TRMNO. A,		;GET UDX FOR CONTROLLING TERMINAL
00180		  JRST TTYCL2		;ERROR - FORGET IT
00190		MOVEM A,TRMTAB+1	;STICK UDX INTO TRMTAB
00200	TTYCL1:	MOVE A,[XWD 2,TRMTAB]
00210		TRMOP. A,		;CHECK IF OUTPUT BUFFER EMPTIED
00220		  JRST TTYCL2		;YES - CAN NOW TURN OFF ↑O
00230		MOVEI A,144		;NO - WAIT 100 MSEC.  MAIN EFFECT IS TO GIVE
00240		HIBER A,		;UP CONTROL OF MACHINE WHILE BUFFER IS FLUSHED
00250		  JRST TTYCL2		;ERROR - FORGET IT
00260		  JRST TTYCL1		;CHECK IT AGAIN
00270	TTYCL2:	SKPINL			;THIS CLEARS ↑O BIT
00280		JFCL
00290		JRST POPAJ
00300	REMOTE<
00310	PJOBNO:	0		;WMT- HIS JOB NUMBER
00320	TRMTAB:	2		;(.TOSOP)
00330		200000+X>	;(UDX)
00340	
00350	REMOTE<
00360	TTOCH:	0
00370	IFN STPGAP,<
00380		0	;tty page number  always zero
00390		0	;tty line number -- always zero
00400	>
00410	TTOLL:	TTYLL
00420	TTOHP:	TTYLL>
00430		PAGE
     
00010		SUBTTL INPUT AND OUTPUT INITIALIZATION AND CONTROL 
00020	;convert ascii to sixbit for device initialization routines
00030	SIXMAK:	SETZM SIXMK2#
00040		MOVE AR1,[POINT 6,SIXMK2]
00050		HRROI R,SIXMK1
00060		PUSHJ P,PRINTA	;use print to unpack ascii characters
00070		MOVE A,SIXMK2
00080		POPJ P,
00090	
00100	SIXMK1:	ADDI A,40
00110		TLNN AR1,770000
00120		POPJ P,		;last character position -- ignore remaining chars
00130		CAIN A,"."+40	
00140		MOVEI A,0	;ignore dots at end of numbers for decimal base
00150		CAIN A,":"+40
00160		HRLI AR1,(POINT 6,0,29)	;deposit : in last char position
00170		IDPB A,AR1
00180		POPJ P,
00190	
00200	;subroutine to process next item in file name list
00210	INXTIO:	JUMPE T,NXTIO
00220		HRRZ T,(T)
00230	NXTIO:	HLRZ A,(T)
00240		PUSHJ P,ATOM
00250		JUMPE A,CPOPJ	;non-atomic
00260		HLRZ A,(T)
00270		JRST SIXMAK	;make sixbit if atomic
00280	
00290	;right normalize sixbit
00300		LSH A,-6
00310	SIXRT:	TRNN A,77
00320		JRST .-2
00330		POPJ P,
00340	PAGE
     
00010	;##	SUBROUTINE TO TEST FOR A DEVICE OR QUEUE. USED BY I/O ROUTINES
00020	;##	AND THE QUEUE ROUTINES. LEAVES A=0 IF NOT AN ATOM AND B=0
00030	;##	DEVICE OR QUEUE.
00040	
00050	DEVCHK:	PUSHJ	P,NXTIO		;## MAKE SIXBIT IF AN ATOM
00060		LDB	B,[POINT 6,A,35];## GET LAST CHAR
00070		CAIN	B,':'		;## DEVICE?
00080		TRZA	A,77		;## YES, CLEAR CHAR BUT LEAVE B INTACT
00090		SETZ	B,		;## NO, CLEAR B
00100		POPJ	P,		;## DONE, IF A=0 OR B=0, NOT A DEVICE
00110	
00120	;##	SUBROUTINE TO PARSE THE I/O SPECIFICATION. DEFAULT IS DSK IF
00130	;##	NO DEVICE SPECIFIED.
00140	IOSUB:	MOVEM	T,DEVDAT#	;## SAVE ARG FOR ERRORS
00150		SKIPE	DEV		;## DEVICE ALREADY SPECIFIED?
00160		JRST	IOSUB1		;## YES, FORGET DEFAULT
00170		SETZM	PPN		;## CLEAR PPN
00180	IFE SFDFLG,< SETZM PPN+1>	;WMT-CLEAR A SFD LOCATION
00190		MOVSI	A,'DSK'		;## STORE DSK AS DEFAULT
00200		MOVEM	A,DEV
00210	IOSUB1:	PUSHJ	P,DEVCHK	;## SEE IF DEVICE SPECIFIED
00220		JUMPE	A,IOPPN		;## NON-ATOMIC ARG, MUST BE PPN OR (FILE.EXT)
00230		JUMPE	B,IOFIL2	;## NOT A DEVICE, MUST BE FILE NAME
00240		SETZM PPN
00250	IFE SFDFLG,< SETZM PPN+1>	;WMT-CLEAR A SFD LOCATION
00260		MOVEM A,DEV
00270	IODEV3:	PUSHJ P,INXTIO
00280	IOPPN:	JUMPN A,IOFIL2	;not ppn or (fil.ext)
00290		PUSHJ P,PPNEXT
00300		JUMPN A,IOEXT	;(fil.ext)
00310		HLRZ A,(T)
00320		PUSHJ	P,CNVPPN	;## CONVERT PPN
00330	IFN SFDFLG,< MOVEM A,PPN>	;WMT-SAVE PPN
00340		JRST IODEV3		;%% DON'T ZAP DEVICE NAME FOR PPN
00350	
00360	COMMENT &  WMT-NO PATH HERE
00370	IOFIL:	JUMPN A,IOFIL2	;was it an atom
00380		JUMPE T,CPOPJ	;no, was it nil (end)
00390		PUSHJ P,PPNEXT
00400		JUMPE A,CPOPJ	;see a ppn, no file named
00410	  END OF NO PATH COMMENT &
00420	IOEXT:	HLRZ A,(T)	;(file.ext)
00430		HRRZ A,(A)	;get cdr == extension
00440		PUSHJ P,SIXMAK
00450		HLLM A,EXT
00460		HLRZ A,(T)
00470		HLRZ A,(A)	;get car = file name
00480		PUSHJ P,SIXMAK
00490	FIL:	PUSH P,A
00500		PUSHJ P,INXTIO
00510		JRST POPAJ
00520	
00530	IOFIL2:	CAIN B,":"-40
00540		POPJ P,		;saw a :,not file name
00550		SETZM EXT	;file name -- clear extension
00560		JRST FIL
00570	
00580	PPNEXT:	JUMPE T,CPOPJ	;end of file name list
00590			HLRZ A,(T)
00600		HRRZ A,(A)	;cdar
00610		JRST ATOM	;ppn iff (not(atom(cdar l)))
00620	
00630	CHNSUB:	MOVE T,A
00640		HLRZ A,(T)
00650		PUSHJ P,ATOM
00660		JUMPE A,TRUE	;non-atomic head of list -- no channel named
00670		HLRZ A,(T)
00680		PUSHJ P,SIXMAK
00690		ANDI A,77
00700		CAIN A,":"-40
00710		JRST TRUE	;device name, assume channel name t
00720		HLRZ A,(T)	;channel name -- return it
00730		HRRZ T,(T)
00740		POPJ P,
00750			;##  LEFT HALF OF  A CHANNEL TABLE ENTRY IS THE  REMAINING
00760			;## FILE LIST. RH POINTS TO EXTENDED HEADER.
00770	
00780	REMOTE<
00790	CHTAB=.-FSTCH
00800		BLOCK NIOCH>
00810	
00820	PAGE
     
00010	;search for channel name in chtab
00020	TABSR1:	MOVE A,[XWD -NIOCH,FSTCH]
00030		MOVE C,CHTAB(A)
00040		CAME B,CHNAM(C)
00050		AOBJN A,.-2
00060		CAMN B,CHNAM(C)
00070		POPJ P,	;found it!!!
00080		JRST FALSE	;lost
00090	
00100	;search for channel name in chtab, and if not there find a free channel, and
00110	;if no free channel, allocate a new buffer and channel
00120	TABSRC:	MOVE B,A
00130		PUSHJ P,TABSR1
00140		JUMPN A,DEVCLR	;found the channel
00150		PUSH P,B
00160		MOVE B,0
00170		PUSHJ P,TABSR1	;find a physical channel no. for a free channel
00180		JUMPE A,[ERR2 [SIXBIT $NO I/O CHANNELS LEFT !$]]
00190		POP P,B
00200		JUMPN C,DEVCLR	;found free channel which had buffer space previously
00210		PUSH P,A	;must allocate new buffer
00220		MOVEI A,BLKSIZ
00230		SETZ	D,	;SPECIAL RELOCATION - SEE LOAD
00240		PUSHJ P,MORCOR	;expand core for buffer if necessary
00250		MOVE C,A
00260		POP P,A
00270		HRRM C,CHTAB(A)
00280	DEVCLR:	HRRZ C,CHTAB(A)
00290		MOVEM	B,CHNAM(C)	;[UT] (LH)=INPUT/OUTPUT BIT,(RH)=PTR TO CHNL NAME
00300		HRRZM A,CHANNEL#
00310		POPJ P,
00320	
00330	;subroutine to reset all i/o channels	-- used by excise and realloc
00340	IOBRST:	HRRZ A,.JBREL
00350		HRLM A,.JBSA
00360		MOVEM A,CORUSE#
00370		HRRZ B,.JBSYM		;WMT
00380		CAIG B,SHRST		;WMT- MAKE SURE IT ISN'T IN HIGH SEG
00390		MOVEM A,.JBSYM
00400		SETZM CHTAB+FSTCH
00410		MOVE A,[XWD CHTAB+FSTCH,CHTAB+FSTCH+1]
00420		BLT A,CHTAB+NIOCH+FSTCH-1	;clear channel table
00430		JRST (R)
00440	PAGE
     
00010	INPUT1:	PUSHJ	P,CHNSUB	;determine channel name
00020		MOVEI	AR1,(A)		;## SAVE CH NAME
00030		EXCH	AR1,(P)		;## EXHANGE WITH RETURN ADDR
00040		PUSH	P,AR1		;## AND STUFF THE RETURN ADDR. IN
00050	INPUT2:	PUSHJ	P,TABSRC	;## GET PHYSICAL CHANNEL NUMBER
00060		MOVEM	A,CHANNEL	;## SAVE IT
00070		SETZM	DEV		;## CLEAR DEV SO THAT WE CAN
00080					;## DEFAULT IF APPROPRIATE
00090		JRST	SETIN1		;## SET UP FOR INITIALIZTION
00100	
00110	INPUT:	PUSHJ	P,INPUT1
00120		PUSHJ	P,ININIT
00130	INFAIL:	JUMPE	A,AIN.7		;## CAN'T FIND FILE
00140		JRST	POPAJ
00150	
00160	COMMENT &  WMT- NO PATH HERE
00170	BINPUT:	PUSHJ	P,INPUT1	;## IMAGE BINARY INPUT
00180		PUSHJ	P,BNINIT
00190		JRST	INFAIL
00200	  END OF NO PATH COMMENT &
00210	
00220	ISFILE:	JUMPE	A,.+5		;## ROUTINE TO TELL USER IF A FILE EXISTS
00230		PUSH	P,A		;## SAVE A IF NON-NIL
00240		MOVEI	A,(B)		;## GET THE FILE NAME
00250		PUSHJ	P,NCONS		;## (FILNAM)
00260		POP	P,B		;## GET THE DEVICE BACK
00270		PUSHJ	P,XCONS		;## (DEV FILNAM) OR (FILNAM) WHEN HERE
00280		PUSH	P,A		;## SAVE IT FOR RETURN
00290		PUSHJ	P,RENSUB	;## SEE IF IT'S THERE
00300		PUSH	P,A		;## SAVE THE ANSWER
00310		PUSHJ	P,RENCLR	;## CLEAR THE CHANNEL
00320		POP	P,A		;## ANSWER IN A
00330		JUMPN	A,POPAJ		;## IF NON-NIL, THEN IT'S THERE
00340		JRST	POPBJ		;## POP ANSWER OFF AND RETURN NIL
00350	
00360	RENSUB:	MOVEM	A,DEVDAT	;## SAVE IT FOR ERROR MSGS
00370		PUSHJ	P,GENSYM	;## DON'T CLOBBER CURRENT CHANNELS
00380		MOVE	T,DEVDAT	;## GET IT BACK
00390		PUSHJ	P,INPUT2	;## SET UP AND OPEN
00400		JRST	ININIT		;## AND INIT
00410	
00420	RENAME:	PUSHJ	P,RENSUB	;## RENAME SETUP
00430		JUMPE	A,RENCLR	;## NIL IF CAN'T FIND FILE
00440	IFE SFDFLG,<	;WMT- GET OLD FILES PATH SO YOU CAN RENAME PROPERLY
00450		MOVE	A,CHANNEL	;WMT- CHANNEL NUMBER
00460		HRRZM	A,SFDBLK	;WMT- THIS ARG TO PATH WILL GET CHANNEL'S PATH
00470		MOVE	A,[XWD SFDLEN+4,SFDBLK]
00480		PATH.	A,		;WMT- GO DO IT
00490		JRST	RENCLR		;WMT- FAILED???
00500		MOVE	A,CHANNEL	;WMT- PUT PATH INTO CHANNEL PATH
00510		HRRZ	C,CHTAB(A)
00520		MOVE	A,[XWD PPN,CHPPN] ;WMT- SET UP BLT TO MOVE IT
00530		ADDI	A,(C)		;WMT- INDEX
00540		BLT	A,CHPPN+SFDLEN(C) ;WMT- TRANSFER PATH
00550		>
00560		PUSHJ	P,SETINA	;## PROCESS THE NEW NAME
00570		XCT	RNAME		;## EXECUTE
00580		JRST	RENCLR		;## RETURN NIL IF FAILURE
00590		PUSHJ	P,RENCLR	;## CLEAR CHANNEL
00600		JRST	TRUE		;## AND RETURN T IF GOOD
00610	
00620	REMOTE	<
00630	RNAME:	RENAME	X,LOOKIN	;## RENAME FILE
00640		>
00650	DELERR:	PUSHJ	P,AIOP
00660		PUSHJ	P,RENCLR	;## KILL THE CHANNEL
00670		ERR2	[SIXBIT /CAN'T DELETE FILE !/]
00680	
00690	DELETE:	PUSHJ	P,RENSUB	;## FIRST SETUP(ALLOWS DEFAULT TO DSK:)
00700		JRST	.+2		;## ALREADY INIT'ED
00710	DELET1:	PUSHJ	P,ININIT	;## INIT AND LOOKUP
00720		JUMPE	A,DELET2	;## IF FILE NOT THERE IGNORE
00730		SETZM	LOOKIN		;## BLAST FILE NAME
00740		SETZM	EXT		;## AND EXTENSION
00750		XCT	RNAME		;## AND RENAME OUT OF EXISTENCE
00760		JRST	DELERR		;## RENAME FAILURE
00770	DELET2:	JUMPE	T,RENCLR	;## DONE
00780		MOVEM	T,DEVDAT	;## SAVE REST OF LIST FOR MSGS.
00790		PUSHJ	P,SETINA	;## PROCESS NEXT FILE
00800		JRST	DELET1		;## AND DO IT AGAIN
00810	
00820	RENCLR:	PUSH	P,CHANNEL	;## CLEAR CHANNEL
00830		SETO	B,		;## FAKE (INC RENCHANNEL T)
00840		PUSHJ	P,IOSEL		;## RELEASE THE CHANNEL
00850		JRST	POPAJ		;## RETURN NIL (IOSEL CHANGED THINGS)
00860	
00870	
00880		;## TO LOOK UP A UFD FOR DIRECTORY FNS. SUBR
00890	
00900	UFDINP:	PUSH	P,A
00910		MOVEI	T,(B)
00920		PUSHJ	P,TABSRC
00930		MOVEM	A,CHANNEL	;## HAVE A CHANNEL
00940		MOVE	A,[XWD 'DSK','UFD']
00950		HRLZM	A,EXT
00960		HLLZM	A,DEV
00970	IFN SFDFLG,<
00980		SETZ	B,
00990		AOBJP	B,.+1		;## UFD'S SHOULD BE ON [1,1]
01000		MOVEM	B,PPN>
01010		SKIPN	A,T
01020	IFN SFDFLG,< PUSHJ P,MYPPN>	;## IF B=NIL, DEFAULT TO USER'S PPN
01030	IFE SFDFLG,<PUSHJ P,PATH>	;WMT-IF B=NIL, DEFAULT TO USER'S PATH
01040		MOVEM	A,DEVDAT
01050		PUSHJ	P,CNVPPN	;## CONVERT PPN
01060		SETZ	T,		;## ZAP T (NO MORE FILES)
01070	IFE SFDFLG,<
01080		JUMPE C,NOSFD		;WMT-IF NO SFD'S
01090		MOVEI B,'SFD'		;WMT-ELSE EXT IS .SFD
01100		HRLZM B,EXT
01110		SETZ A,			;WMT-LAST SFD SHOULD BE 0
01120		EXCH A,PPN(C)		;WMT-A IS FILE(SFD) NAME
01130		JRST FDLU
01140	NOSFD:	MOVE A,[XWD 1,1]	;WMT-UFD'S ON 1,1
01150		EXCH A,PPN
01160	FDLU:>
01170		PUSHJ	P,SETIN2	;## SETUP 
01180		PUSHJ	P,BNINIT	;## INIT AS BINARY
01190		JUMPE	A,ERR		;## ERR NIL IF NOT THERE
01200		PUSHJ	P,ININBF	;## SET UP BUFFERS
01210		JRST	POPAJ		;## RETURN CHANNEL
01220	MYPPN:	GETPPN	A,		;## GET PPN
01230		CAI			;## WIERD SKIP RETURN ON THIS UUO
01240		HLRZ	C,A		;## ASSUME PPN'S ARE INUMS
01250		HRRZI	A,INUM0(A)	;## CONVERT
01260		PUSHJ	P,NCONS	
01270		HRRZI	B,INUM0(C)
01280		JRST	XCONS		;## (PROJ PRGRM)
01290	
01300	CNVPPN:	MOVS	A,(A)		;## ASSUME PPNS INUMS
01310		HRRI	A,-INUM0(A)	;## LH=CDR, RH=CAR
01320	IFN SFDFLG,<
01330		MOVSS	A		;## SWAP HALVES
01340		HLR	A,(A)		;## RH=CADR NOW
01350		HRRI	A,-INUM0(A)
01360		POPJ	P,>
01370	
01380	IFE SFDFLG,<
01390		HRLZM	A,PPN		;WMT-SAVE PROJ# IN PPN
01400		MOVSS	A		;WMT-SWAP HALVES AGAIN
01410		MOVS	A,(A)		;WMT-AND AGAIN (CDR)
01420		HRRI	A,-INUM0(A)	;WMT-PROG#
01430		HRRM	A,PPN		;WMT-SAVE PROG# IN PPN
01440		HLRZS	A		;WMT-A IS NOW CDDR
01450		MOVNI	C,SFDLEN	;WMT-COUNT OF SFDS
01460		PUSH	P,A		;WMT-RESERVE SOME ROOM
01470	NXTSFD:	JUMPE	A,ENDSFD	;WMT-DONE WITH SFDS
01480		MOVS	A,(A)		;WMT-GET CDR,,CAR
01490		HLRZM	A,(P)		;WMT-SAVE CDR
01500		HRLM	C,(P)		;WMT- AND INDEX
01510		MOVEI	A,(A)		;WMT-ONLY WANT CAR
01520		PUSHJ	P,SIXMAK	;WMT-MAKE IT SIXBIT
01530		HLRE	C,(P)		;WMT- RETRIEVE INDEX
01540		MOVEM	A,PPN+1+SFDLEN(C);WMT-SAVE THIS SFD
01550		HRRZ	A,(P)		;WMT-RESTORE A
01560		AOJL	C,NXTSFD	;WMT-INCREMENT AND GO GET MORE
01570	ENDSFD:	SETZM	PPN+1+SFDLEN(C)	;WMT-GUARANTEE A 0 SFD
01580		ADDI	C,SFDLEN	;WMT-SFD COUNT
01590		MOVEI	B,SFDBLK
01600		MOVEM	B,LPPN		;WMT-MAKE SURE IT POINTS TO PATH BLOCK
01610		JRST	POPBJ>		;WMT-RETURN NIL,CLEAR STACK
01620	
01630	;WMT-SOME STUFF FOR PATHS
01640	IFE SFDFLG,<
01650	PATH:	;FSUBR- RETURN PRESENT PATH IF ARG=NIL 
01660		;  ELSE IF ONE ARG THEN RETURN PATH OF THAT CHANNEL
01670		;  ELSE SET PATH TO ARG
01680		;  RETURNS PRESENT PATH UNLESS YOU COULDN'T SET PATH IN WHICH
01690		;  CASE IT RETURNS NIL
01700		JUMPE	A,GETPTH
01710		HRRZ	B,(A)		;WMT-CHECK FOR ONE ARG
01720		JUMPE	B,CHNPTH	;WMT- ONE ARG, PRESUME A CHANNEL
01730		PUSH	P,A		;WMT-SAVE ARG
01740		PUSHJ	P,CNVPPN	;WMT-FILL LOOK UP BLOCK IN
01750		HRRZI	A,-2		;WMT-0,,-2 SETS PATH
01760		PUSHJ	P,PATH1		;WMT-GO DO IT
01770		JUMPE	A,POPBJ		;WMT-IF NIL, THEN IGNORE POP AND RETURN
01780		JRST	POPAJ		;WMT-ELSE RETURN ARGUMENT
01790	
01800	PATH1:	SETZM	SFDBLK+1	;WMT-USE ALREADY EXISTING SCAN SWITCH
01810	PATH2:	MOVEM	A,SFDBLK	;WMT-LOAD PATH ARGUMENT
01820		MOVE	B,[XWD SFDLEN+4,SFDBLK] ;WMT-AC FOR PATH
01830		PATH.	B,		;WMT-GO DO IT
01840		JRST	FALSE		;WMT-PATH UUO FAILED, RETURN NIL
01850		JRST	TRUE		;WMT-ALL IS COOL
01860	
01870	GETPTH:	HRRZI	A,-1		;WMT-0,,-1 GETS THE PATH
01880		PUSHJ	P,PATH1		;WMT-GO GET PATH
01890		JUMPE	A,CPOPJ		;WMT-HUH?
01900	; THIS RETURNS A PATH THAT IS IN PPN....  AS (PROJ# PROG# SFD1 ...)
01910	GTPTH3:	PUSH	P,[NIL]		;WMT-END OF VALUE LIST
01920		MOVEI	B,SFDLEN	;WMT-COME FROM BOTTOM UP
01930	GTPTH2:	MOVE	A,PPN(B)	;WMT-GET SFD
01940		JUMPE	A,GTPTH1	;WMT-A 0 SFD
01950		PUSH	P,B		;WMT-SAVE INCREMENT
01960		PUSHJ	P,SIXATM	;WMT-MAKE AN ATOM
01970		POP	P,B		;WMT-RETRIEVE INDEX
01980		EXCH	B,(P)		;WMT-GET VALUE LIST, SAVE INDEX
01990		PUSHJ	P,CONS		;WMT-CONS ON NEW ONE
02000		EXCH	A,(P)		;WMT-SAVE VALUE, GET INDEX
02010		SKIPA	B,A		;WMT-MOVE INDEX TO B AND SKIP
02020	GTPTH1:	SETZM	(P)		;WMT-MAKE SURE VALUE LIST IS NIL IF NO SFD
02030		SOJG	B,GTPTH2	;WMT-ARE WE DONE?
02040		HRRZ	A,PPN		;WMT-YES, NOW WORK ON PROG. NUM
02050		MOVEI	A,INUM0(A)	;WMT-MAKE INTO AN INUM
02060		POP	P,B		;WMT-GET SFD LIST
02070		PUSHJ	P,CONS		;WMT-CONS ON PROG NUM
02080		MOVE	B,A
02090		HLRZ	A,PPN		;WMT-NOW GET PROJ NUM
02100		MOVEI	A,INUM0(A)	;WMT-MAKE INUM
02110		JRST	CONS		;WMT-CONS IT ON AND RETURN
02120	
02130	; RETURNS (DEV: (PATH) (FILE.EXT)(FILE2.EXT)...)
02140	; FOR CHANNEL IT IS CALLED WITH
02150	; FOR TTY IT RETURNS (TTY:)
02160	
02170	CHNPTH:	HLRZ	B,(A)		;WMT- GET ARG
02180		JUMPE	B,PTHTTY	;WMT-CHECK FOR TTY: CASE
02190		PUSHJ	P,TABSR1	;WMT- GET PHYSICAL CHANNEL #
02200		JUMPN	A,CHNPT1	;WMT-	FOUND IT AS INPUT
02210		TLO	B,400000	;WMT- LOOK FOR IT AS OUTPUT
02220		PUSHJ	P,TABSR1
02230		JUMPE	A,CPOPJ		;WMT- ERROR. RETURN NIL
02240	CHNPT1:	HRRZM	A,SFDBLK	;WMT- ARGUMENT FOR PATH.
02250		HRRZ	C,CHTAB(A)	;WMT- POINTER TO DATA
02260		PUSH	P,C		;WMT-	SAVE IT
02270		DMOVE	A,CHFILE(C)	;WMT- NAME OF FILE
02280		PUSH	P,B		;WMT- (SAVE EXTENSION)
02290		PUSHJ	P,SIXATM	;WMT-   MAKE AN ATOM
02300		EXCH	A,(P)		;WMT-   AND SAVE
02310					;WMT- AND GET EXTENSION
02320		JUMPE	A,.+5		;WMT-	CHECK IF NONE
02330		PUSHJ	P,SIXATM	;WMT-	MAKE ATOM
02340		MOVE	B,(P)		;WMT- GET FILE
02350		PUSHJ	P,XCONS		;WMT- MAKE (FILE . EXT)
02360		MOVEM	A,(P)		;WMT-	SAVE IT
02370	
02380		MOVE	A,[XWD SFDLEN+4,SFDBLK]  ;WMT- ARG FOR PATH.
02390		PATH.	A,		;WMT- GO GET CHANNEL PATH
02400		ERR2	[SIXBIT /CAN'T GET PATH !/]
02410		PUSHJ	P,GTPTH3	;WMT- MAKE INTO PATH EXPRESSION
02420		EXCH	A,(P)		;WMT- SAVE IT
02430		PUSHJ	P,NCONS		;WMT- MAKE  ((FILE . EXT))
02440		POP	P,B		;WMT- GET PATH AGAIN
02450		PUSHJ	P,XCONS		;WMT- MAKE ((PATH) (FILE.EXT))
02460		EXCH	A,(P)		;WMT- SAVE AND GET CHANNEL DATA
02470		MOVE	A,CHDEV(A)	;WMT- GET DEVICE
02480		PUSHJ	P,SIXCAT	;WMT-	MAKE ATOM
02490		POP	P,B		;WMT- GET REST
02500		JRST	CONS		;WMT- RETURN (DEV (PATH)(FILE.EXT))
02510	PTHTTY:	MOVSI	A,'TTY'		;WMT- NIL CHANNEL NAME = TTY
02520		PUSHJ	P,SIXCAT	;WMT- GET NAME
02530		JRST	NCONS		;WMT- MAKE LIST
     
00010	SCAN:	; TURNS OFF SCAN SWITCH IF ARG IS NIL, ELSE TURNS IT ON
00020		;  RETURNS NIL OR NON-NIL ACCORDING TO WHAT IT WAS BEFORE
00030		PUSH	P,A		;WMT-SAVE ARG
00040		HRRZI	A,-1		;WMT-WANT DEFAULT PATH
00050		PUSHJ	P,PATH1
00060		MOVEI	A,2		;WMT-BIT 34 INDICATES /SCAN
00070		TDZN	A,SFDBLK+1	;WMT-IF SCAN IS ON, SETS A TO NIL AND SKIPS
00080		MOVEI	A,TRUTH(S)	;WMT-HERE T IS NO SCAN, NIL IS SCAN
00090		CAMN	A,(P)		;WMT-SEE IF SAME AS ASKED FOR
00100		JRST	STSCAN		;WMT-SAME, THUS MUST SET AS PER REQUEST
00110		SKIPE	(P)		;WMT-NOPE, BUT MAYBE NON-NIL VERSUS T
00120		JUMPN	A,STSCAN	;WMT-NEITHER NIL, MUST SET SCAN
00130		JRST	POPAJ		;WMT-WANTED WHAT IT WAS ALREADY,GIVE BAK ARG
00140	STSCAN:	MOVEI	A,3		;WMT-SET SCAN SWITCHES
00150		ANDCMM	A,SFDBLK+1	;WMT-FLIP BITS 34,35, ZERO 0-33
00160		HRRZI	A,-2		;WMT-0,,-2 SETS PATH (AND SCAN)
00170		PUSHJ	P,PATH2		;WMT-GO SET IT
00180		POP	P,A		;WMT-RETURN NOT ARGUMENT
00190		JRST	NOT>
     
00010	SETINA:	MOVE	A,CHANNEL	;## FOR ROUTINES THAT PROCESS MORE
00020		HRRZ	C,CHTAB(A)	;## AND KEEP THE CHANNEL IN CHANNEL
00030	
00040	SETIN:	MOVEM A,CHANNEL
00050		MOVE A,CHDEV(C)
00060		MOVEM A,DEV
00070	IFN SFDFLG,<
00080		MOVE A,CHPPN(C)
00090		MOVEM A,PPN>
00100	IFE SFDFLG,<
00110		MOVE A,[XWD PPN,CHPPN]	;WMT-SET CHANNEL PATH
00120		ADDI A,(C)		;WMT-INDEX
00130		MOVSS A			;WMT-PUT IN RIGHT ORDER
00140		BLT A,PPN+SFDLEN	;WMT-TRANSFER PATH
00150		MOVEI A,SFDBLK		;WMT-RESET LPPN
00160		MOVEM A,LPPN
00170		SETZM SFDBLK+1>		;WMT-USE DEFAULT SCAN
00180	SETIN1:	PUSHJ P,IOSUB	;get device and file name
00190	SETIN2:	MOVEM A,LOOKIN	;file name
00200		MOVE A,DEV
00210		MOVEM	A,BDEV		;## ALLOW IMAGE BINARY MODE
00220		DEVCHR A,
00230		TLNN A,INB
00240		JRST AIN.2	;not input device
00250		TLNN A,AVLB
00260		JRST AIN.4	;not available
00270		MOVE A,CHANNEL
00280		DPB A,[POINT 4,ININIT,ACFLD]	;set up channel numbers
00290		DPB A,[POINT 4,BNINIT,ACFLD]	;## FOR IMAGE BINARY
00300		DPB A,[POINT 4,RNAME,ACFLD]	;## FOR RENAME
00310		DPB A,[POINT 4,INLOOK,ACFLD]
00320		DPB A,[POINT 4,ININBF,ACFLD]
00330		HLLZS	EXT		;%% CLEAR RIGHT HALF
00340		SETZM	LOOKIN+2	;%% CLEAR THIRD WORD
00350		HRRZ B,CHTAB(A)
00360		HRLM T,CHTAB(A)		;save remaining file name list
00370		MOVE A,DEV		;WMT-SAVE CHANNEL DEVICE
00380		MOVEM A,CHDEV(B)
00390		MOVE A,LOOKIN		;WMT- FILE NAME
00400		MOVEM A,CHFILE(B)	;WMT- SAVE IT
00410		MOVE A,EXT		;WMT- EXTENSION
00420		MOVEM A,CHEXT(B)	;WMT- SAVE IT
00430	IFN SFDFLG,<
00440		MOVE A,PPN		;WMT-SAVE CHANNEL PPN
00450		MOVEM A,CHPPN(B)>
00460	IFE SFDFLG,<
00470		MOVE A,[XWD PPN,CHPPN]	;WMT-SAVE CHANNEL PATH
00480		ADDI A,(B)		;WMT-INDEX
00490		BLT A,CHPPN+SFDLEN(B)>	;WMT-SAVE WHOLE PATH
00500	IFN RANDOM,< SETZM CHBUFS(B)>	;WMT- ZERO BUFFER COUNT
00510		MOVEI A,CHDAT(B)
00520		MOVEM A,DEV1		;pointer to bufdat
00530		MOVEM	A,BDEV1		;## IMAGE BINARY MODE
00540		POPJ	P,		;## SET UP FOR INITIALIZTION
00550	REMOTE<
00560	
00570	BNINIT:	INIT	X,13		;## INIT DEVICE IN IMAGE BINARY
00580	BDEV:	X
00590	BDEV1:	X
00600		JRST	AIN.7		;## CAN'T INIT
00610		JRST	INITOK
00620	ININIT:	INIT X,
00630	DEV:	X
00640	DEV1:	X
00650		JRST AIN.7		;cant init
00660	INITOK:
00670	;	PUSH B,DEV		;WMT-ALREADY DID THIS (SET CHDEV)
00680	;	PUSH B,PPN		;WMT-ALREADY DID THIS (SET CHPPN)
00690	;WMT- A TEMPORARY PATCH UNTIL MONITOR GETS FIXED
00700	;	IT WON'T LOOK UP PROPERLY IF SFD BLOCK IS ALL 0'S
00710		SKIPN	PPN		;WMT-SFD BLOCK IS NOT ALL 0'S
00720		SETZM	LPPN		;WMT-MAKE MONITOR KNOW YOU WANT DEFAULT
00730	INLOOK:	LOOKUP X,LOOKIN
00740		JRST	FALSE		;## LET SOMEONE ELSE HANDLE THE ERROR
00750		JRST IRET1>
00760	
00770	IRET1:	ADDI B,CHOCH-1		;WMT- POINT TO OLDCH
00780	IFE SFDFLG,<MOVEI A,SFDBLK	;WMT-IN CASE LOOKUP CHANGES LPPN
00790	    	    MOVEM A,LPPN>	;WMT
00800		PUSH B,[0]	;oldch
00810	
00820	IFN STPGAP,<
00830		PUSH B,[0]	;page number
00840		PUSH B,[0]	;line number
00850		ADDI B,COUNT+1-CHLINE	;WMT- SET B TO POINT TO FIRST LOC AFTER COUNT
00860		>
00870	
00880	IFE STPGAP,<ADDI B,COUNT+1-CHOCH>	;WMT
00890		HRRM B,.JBFF
00900		JRST	ININBF
00910	
00920	REMOTE<
00930	ININBF:	INBUF X,NIOB
00940		JRST	TRUE	;## RETURN FROM GOOD LOOKUP WITH T
00950	
00960	
00970	ENTR:
00980	IFN SFDFLG,<
00990	LOOKIN:	BLOCK 4
01000	EXT=LOOKIN+1
01010	
01020	PPN=LOOKIN+3>
01030	IFE SFDFLG,<
01040	LOOKIN:	Z
01050	EXT:	Z
01060		Z
01070	LPPN:	SFDBLK		;WMT-EXTENDED LOOKUP
01080	SFDBLK:	0,,-1		;WMT-PATH BLOCK
01090		Z		;WMT-WORD FOR SCAN SWITCHES
01100	PPN:	Z
01110		BLOCK SFDLEN
01120		Z>		;WMT-GUARANTEE ZERO
01130	>
01140	PAGE
     
00010	OUTPUT:	PUSHJ P,CHNSUB	;get channel name
00020		PUSH P,A
00030		TLO A,400000	;WMT-set bit for output IN LH
00040				;WMT-RH WON'T DO IF LOW SEG>400000
00050		PUSHJ P,TABSRC	;get physical channel nuber
00060		SETZM	DEV	;## CLEAR DEV FOR DEFAULT TO DSK:
00070		PUSHJ P,IOSUB	;get device and file name
00080		MOVEM A,ENTR	;file name
00090		HLLZS	ENTR+1	;%% CLEAR RIGHT HALF
00100		SETZM ENTR+2	;zero creation date
00110		MOVE A,FPROTE(S) ;WMT-PICK UP PROTECTION DESIRED
00120		MOVEI A,-INUM0(A);WMT-GET REAL VALUE
00130		DPB A,[POINT 9,ENTR+2,8];SHOVE BOTTOM 9 BITS AS FILE PROTECTION
00140		MOVE A,CHANNEL
00150		DPB A,[POINT 4,AOUT2,ACFLD]	;setup channel numbers
00160		DPB A,[POINT 4,OUTENT,ACFLD]
00170		DPB A,[POINT 4,OUTOBF,ACFLD]
00180	IFN RANDOM,< SETZM CHBUFS(A)>	;WMT- ZERO BUFFER COUNT
00190		HRRZ B,CHTAB(A)
00200		MOVE A,ENTR		;WMT-FILE NAMEE
00210		MOVEM A,CHFILE(B)	;WMT-  SAVE IT
00220		MOVE A,ENTR+1		;WMT-EXTENSION
00230		MOVEM A,CHEXT(B)	;WMT-  SAVE IT
00240		MOVEI A,CHDAT(B)
00250		HRLM A,AOUT3+1
00260		MOVE A,DEV
00270		MOVEM A,AOUT3
00280		DEVCHR A,
00290		TLNN A,OUTB
00300		JRST AOUT.2	;not output device
00310		TLNN A,AVLB
00320		JRST AOUT.4	;not available
00330		JRST AOUT2
00340	REMOTE<
00350	AOUT2:	INIT X,
00360	AOUT3:	X
00370		X
00380		JRST AOUT.4	;cant init
00390	IFN CHDEV-CHNAM-1,<ADDI B,CHDEV-CHNAM-1> ;WMT- IF CHDEV.NE.CHNAM+1
00400		PUSH B,DEV
00410	;WMT-  PATCH TO BYPASS MONITOR BUG WHEN LOOKING UP WITH PATH BLOCK
00420	;	THAT IS ALL ZEROES
00430		SKIPN	PPN	; SKIP IF NOT ALL ZEROES
00440		SETZM	LPPN	; MAKE IT DEFAULT PATH
00450	OUTENT:	ENTER X,ENTR
00460		JRST OUTERR	;cant enter
00470		JRST ORET1>
00480	ORET1:	ADDI B,CHLL-CHDEV-1	;WMT- ALIGN FOR NEXT PUSH
00490		PUSH B,[LPTLL]		;linelength
00500		PUSH B,[LPTLL]		;chrct
00510		ADDI B,COUNT+1-CHHP	;WMT- POINT TO JUST AFTER COUNT
00520		HRRM B,.JBFF
00530		XCT OUTOBF
00540	REMOTE<
00550	OUTOBF:	OUTBUF X,NIOB
00560	>
00570		JRST POPAJ
00580	
00590	OUTERR:	PUSHJ P,AIOP
00600		LDB A,[POINT 3,ENTR+1,35]
00610		CAIE A,2
00620		ERR1 [SIXBIT /DIRECTORY FULL !/]
00630		ERR2 [SIXBIT /FILE IS WRITE PROTECTED !/]
00640	PAGE
     
00010	IOSEL:	MOVE C,-1(P)
00020		JUMPE C,CPOPJ	;tty 
00030		JUMPE B,IOSELZ	;dont release
00040	IOSEL1:	DPB C,[POINT 4,RLS,ACFLD]
00050		XCT RLS
00060	REMOTE<
00070	RLS:	RELEASE X,		;release channel
00080	>
00090		HRRZS CHTAB(C)		;release channel table entry
00100		MOVEM 0,@CHTAB(C)	;blast channel name
00110		SETZM -1(P)
00120	IOSELZ:	HRRZ C,CHTAB(C)
00130		POPJ P,
00140	PAGE
     
00010	INCNT:	MOVEI A,NIL	;(INC NIL T)
00020		MOVEI B,TRUTH(S)
00030	
00040	INC:	CAMN A,INCH		;*** If trying to select the TTY and it
00050		JUMPE A,[MOVE T,[JRST TTYI] ;*** is already selected, don't bother
00060			 MOVEM T,TYI2	;WMT- IN CASE READLIST CLOBBERED IT
00070			 JRST CPOPJ]	;WMT
00080		PUSH P,INCH#
00090		PUSHJ P,IOSEL
00100		JUMPN B,INC2	;released channel
00110		SKIPN C
00120		MOVEI C,TTOCH-CHOCH	;tty deselect
00130	IFN STPGAP,<
00140		MOVEI B,CHOCH(C)
00150		HRLI B,OLDCH
00160		BLT B,CHLINE(C)		;save channel data
00170	>
00180	IFE STPGAP,<
00190		MOVE B,OLDCH
00200		MOVEM B,CHOCH(C)
00210	>
00220		JRST	INC2+1
00230	INC2:	SETZM	INCH		;CLEAR CHANNEL NOW IN CASE OF BREAK
00240		JUMPE A,ITTYRE		;select tty
00250		MOVE B,A
00260		PUSHJ P,TABSR1		;determine physical channel number
00270		JUMPE A,[ERR1 [SIXBIT/NO INPUT - INC!/]]
00280		HRRZM A,INCH
00290		DPB A,[POINT 4,TYI2X,ACFLD]	;set up channel numbers
00300		DPB A,[POINT 4,TYI2Y,ACFLD]
00310		DPB A,[POINT 4,TYI2Z,ACFLD]
00320		HRRZ A,CHTAB(A)
00330		MOVEI T,COUNT(A)
00340		HRLI T,(SOSG)
00350		MOVEI B,POINTR(A)
00360		HRRM B,TYI3	;set up tyi parameters
00370		HRRM B,TYI3A
00380	IFN RANDOM,<
00390		MOVEI B,CHBUFS(A)	;WMT-SET TO INCREMENT BUFFER COUNT
00400		HRRM B,TYI2W>
00410	INC3:
00420	IFN STPGAP,<
00430		MOVSI B,CHOCH(A)
00440		HRRI B,OLDCH
00450		BLT B,LINUM	;restore channel data
00460	>
00470	IFE STPGAP,<
00480		MOVE B,CHOCH(A)
00490		MOVEM B,OLDCH
00500	>
00510		MOVEM T,TYI2
00520	IOEND:	POP P,A
00530		JUMPE A,CPOPJ
00540		MOVE A,CHTAB(A)	;get channel name
00550		HRRZ A,(A)
00560		POPJ P,
00570	
00580	ITTYRE:	SETZM INCH
00590		MOVE T,[JRST TTYI]	;reselect tty
00600		MOVEI A,TTOCH-CHOCH
00610		JRST INC3
00620				;*** RETURN CURRENT INPUT CHANNEL
00630	GETICH:	MOVE A,INCH
00640		JRST IOEND+1
00650	PAGE
     
00010	OUTCNT:	MOVEI A,0	;(outc nil t)
00020		MOVEI B,1
00030	
00040	OUTC:	CAMN A,OUTCH		;*** If trying to select the TTY and it
00050		JUMPE A,CPOPJ		;*** is already selected, don't bother
00060		PUSH P,OUTCH#
00070		PUSHJ P,IOSEL
00080		JUMPN B,OUTC2	;closed this file
00090			SKIPN C
00100		MOVEI C,TTOLL-CHLL	;tty deselect
00110		MOVE B,CHCT
00120		MOVEM B,CHHP(C)		;save channel data
00130		MOVE B,LINL
00140		MOVEM B,CHLL(C)
00150		JRST	OUTC2+1
00160	OUTC2:	SETZM	OUTCH		;CLEAR CHANNEL NOW IN CASE OF BREAK
00170		JUMPE A,OTTYRE		;return to tty
00180		TLO A,400000		;WMT-set output bit
00190		MOVE B,A
00200		PUSHJ P,TABSR1		;determine physical channel number
00210		JUMPE A,[ERR1 [SIXBIT /NO OUTPUT - OUTC!/]]
00220		DPB A,[POINT 4,TYO2X,ACFLD]	;set up tyo2 channel numbers
00230		HRRZM A,OUTCH
00240		HRRZ A,CHTAB(A)
00250		MOVEI B,POINTR(A)
00260		HRRM B,TYO5	;set up tyo2 parameters
00270		MOVEI T,COUNT(A)
00280		HRLI T,(SOSG)
00290	IFN RANDOM,<
00300		MOVEI B,CHBUFS(A)	;WMT-SET TO INCREMENT BUFFER LOADS
00310		HRRM B,TYO2W>
00320	OUTC3:	MOVE B,CHLL(A)
00330		MOVEM B,LINL
00340		MOVE B,CHHP(A)
00350		MOVEM B,CHCT
00360		MOVEM T,TYOD
00370		JRST IOEND
00380	
00390	OTTYRE:	SETZM OUTCH
00400		MOVE T,[JRST TTYO]
00410		MOVEI A,TTOLL-CHLL	;tty reselect
00420		JRST OUTC3
00430				;*** RETURN CURRENT OUTPUT CHANNEL
00440	GETOCH:	MOVE A,OUTCH
00450		JRST IOEND+1
00460	PAGE
     
00010	AOUT.2:
00020	AIN.2:	PUSHJ P,AIOP
00030		ERR2 [SIXBIT /ILLEGAL DEVICE!/]
00040	AOUT.4:
00050	AIN.4:	PUSHJ P,AIOP
00060		ERR2 [SIXBIT /DEVICE NOT AVAILABLE !/]
00070	AIN.7:
00080		IFN SFDFLG,<PUSHJ P,AIOP>
00090		IFE SFDFLG,<PUSHJ P,AIOP1>
00100		ERR1 [SIXBIT /CAN'T FIND FILE - INPUT!/]
00110	
00120	AIN.8:	SIXBIT /INPUT ERROR!/
00130	
00140	AIOP1:	MOVE A,INCH
00150		PUSHJ P,IOEND+1
00160		PUSHJ P,CHNPTH
00170		JRST EPRINT
00180	
00190	AIOP:	MOVE A,DEVDAT
00200		JRST EPRINT
00210		PAGE
     
00010	; RANDOM I/O FUNCTIONS
00020	
00030	IFN RANDOM,<
00040	; GTOPOS GETS THE POSITION OF THE CHARACTER ABOUT TO BE OUTPUT.
00050	; GTIPOS GETS THE POSITION OF THE CHARACTER ABOUT TO BE INPUT.
00060	; THEY RETURN A NUMBER CORRESPONDING TO THE BYTE POSITION OF THE
00070	;	CHARACTER IN THE FILE.
00080	; SETPOS SETS THE POSITION OF THE INPUT CHANNEL TO INPUT THE
00090	;	CHARACTER IN THE BYTE POSITION INDICATED BY IT'S ARG.
00100	GTOPOS:	SKIPA	A,OUTCH		;WMT-GET POSITION ON OUTPUT CHANNEL
00110	GTIPOS:	MOVE	A,INCH		;WMT-GET POSITION OF INPUT CHANNEL
00120		JUMPE	A,CPOPJ		;WMT-  EXIT IF TTY:
00130		HRRZ	A,CHTAB(A)
00140		MOVE	B,CHBUFS(A)	;WMT-# OF BUFLOADS
00150		SUBI	B,1
00160		IMULI	B,BFCHRS	;WMT-GET TO CHARACTERS
00170		PUSH	P,B		;WMT- SAVE FOR A WHILE
00180		SKIPGE	B,CHDAT(A)	;WMT- GET THE POSITION OF HEAD OF BUFFER
00190		JRST	NODAT		;WMT- BUT LOOK OUT FOR UNLOADED BUFFER
00200		PUSHJ	P,GTCPOS	;WMT- GET BYTE POSITION IN BUFFER
00210	NODAT1:	POP	P,A		;WMT- GET CHARS IN PREVIOUS BUFFERS
00220		ADD	A,C		;WMT- COMPUTE TOTAL CHARS.
00230		JRST	MAKNUM
00240	NODAT:	SETZB	C,0(P)		;WMT- CLEAR ALL IF NO BUFFER LOADED
00250		JRST	NODAT1		;WMT- AND CLEAN UP (RETURN 0)
00260	
00270	SETPOS:	PUSH	P,A		;WMT-SAVE ARGUMENT
00280		PUSHJ	P,NUMVAL	;WMT-GET NUMERIC VALUE OF ARG
00290		MOVE	B,A
00300		MOVE	A,INCH		;WMT-DO IT ON INPUT CHANNEL
00310		JUMPE	A,POPBJ		;WMT-RETURN NIL IF ON TTY:
00320		HRRZ	A,CHTAB(A)
00330		SETZM	CHOCH(A)	;WMT- CLEAR OUT OLD CHAR.
00340		IDIVI	B,BFCHRS	;WMT-GO BACK TO BUFFERLOADS.
00350		PUSH	P,C		;WMT-SAVE EXCESS BYTES
00360		ADDI	B,1		;WMT- FIRST BUFFER IS 1
00370		CAMN	B,CHBUFS(A)	;WMT-CHECK TO SEE IF AT RIGHT BUFFER
00380		SKIPGE	C,CHDAT(A)	;WMT- WATCH OUT FOR EMPTY BUFFER
00390		JRST	STUPOS		;WMT- GO DO USETI
00400		MOVE	B,C		;WMT- FOR GTCPOS
00410		PUSHJ	P,GTCPOS	;WMT- GET CHANNEL BYTE POSITION
00420		MOVE	A,INCH		;WMT- CHANNEL NUMBER
00430		MOVE	A,CHTAB(A)	;WMT- CHANNEL INFO
00440		ADDM	C,COUNT(A)	;WMT- UNDO BACK TO BEGINNING OF BUFFER
00450		MOVE	B,CHDAT(A)	;WMT- POINTER TO BUF.HEADER
00460		ADDI	B,1		;WMT- POINT TO WORD BEFORE BUF. STORAGE
00470		HRLI	B,00700		;WMT- POINT TO ZEROTH BIT POSITION
00480		MOVEM	B,POINTR(A)	;WMT-POINT BEFORE ALL DATA
00490	
00500	USETIR:	MOVE	B,COUNT(A)	;WMT-PICK UP NUMBER OF CHARS READ
00510		POP	P,C		;WMT- RETRIEVE CHARS IN THIS BUFFER
00520		SUB	B,C		;WMT- KNOCK OFF THIS NUMBER
00530		ADDI	B,1		;WMT-    ALIGN IT RIGHT
00540		MOVEM	B,COUNT(A)	;WMT-  AND RESTORE IT
00550		MOVE	B,C
00560		IDIVI	B,5		;WMT-COMPUTE WORDS, CHARS
00570		;WMT- PRESUME POINTER POINTS TO START OF BUFFER -1
00580		ADDI	B,1
00590		ADDM	B,POINTR(A)	;WMT-POINT TO RIGHT WORD
00600		IMULI	C,7
00610		MOVNS	C
00620		ADDI	C,44		;WMT- GET TO RIGHT POSITION
00630		DPB	C,[POINT 6,POINTR(A),5] ;WMT- DEPOSIT IN POINTER
00640		JRST	POPAJ		;WMT-RETURN ARGUMENT
00650	
00660	STUPOS:	MOVEM	B,CHBUFS(A)	;WMT-SAVE BUFFER LOADS
00670		HRRM	B,USETIX	;WMT- TELL USETI HOW MUCH TO DO
00680		MOVE	C,INCH		;WMT- GET INPUT CHANNEL
00690		DPB	C,[POINT 4,USETIX,ACFLD] ;WMT-SET USETI UP FOR CHANNEL
00700		DPB	C,[POINT 4,USETIY,ACFLD]
00710		DPB	C,[POINT 4,USETIZ,ACFLD]
00720		JRST	USETIX		;WMT- GO POSITION AND INPUT FILE
00730	REMOTE<
00740	USETIX:	USETI	X,X		;WMT- POSITION FILE
00750	USETIY:	INPUT	X,		;WMT- DO INPUT
00760	USETIZ:	STATZ	X,740000	;WMT- INPUT ERROR?
00770		ERR2	AIN.8		;WMT-    YES
00780		JRST	USETIR
00790	>
00800	
00810	; GTCPOS COMPUTES BYTE POSITION WITHIN THE BUFFER
00820	GTCPOS:	ADDI	B,2		;WMT- HEAD OF BUFFER IS HERE
00830		HRRZ	C,POINTR(A)	;WMT-SEE WHERE IT POINTS
00840		SUB	C,B		;WMT-  INTO BUFFER
00850		IMULI	C,5		;WMT-CONVERT INTO CHARS.
00860		SKIPE	CHOCH(A)	;WMT-SEE IF ANY EXTRAS
00870		SUBI	C,1		;WMT-    TAKE CARE OF IT
00880		LDB	A,[POINT 6,POINTR(A),5] ;WMT- UPDATE POINTER
00890		MOVNS	A
00900		ADDI	A,44		;WMT- COMPUTE BYTE POSITION
00910		IDIVI	A,7
00920		ADD	C,A		;WMT- COMPUTE POSITION IN THIS BUFFER
00930		POPJ	P,		;WMT- RETURN BYTES ALREADY PROCESSED
00940	>
00950	PAGE
     
00010	
00020		SUBTTL	QMANGR INTERFACE
00030	
00040	;## 	CODE TO ALLOW LISP USER'S TO CALL DEC'S  QMANGR, ALLOWING
00050	;## 	PRINTING OF FILES AND CREATION OF JOBS
00060	;## 	SCANS ARG LIST SETTING UP THE APPROPRIATE PARAMETERS. IT
00070	;## 	SAVE THE PDLS, SWAPS HI-SEGS FOR SYS:QMANGR AND
00080	;## 	DOES A PUSHJ TO 400010. IT ALSO CHANGES .JBREN SO
00090	;## 	THAT THE USER CAN RECOVER IN CASE OF QMANGR ERRORS.
00100	;## 	ST WILL ALSO STILL WORK. REG 17 (SP) IS USED AS QMANGR'S
00110	;## 	PDL. CORE IS CONTRACTED AFTER RETURN FROM QMANGR AND QUEUE
00120	;## 	RESTORES APPROPRIATE REGS AND RETURNS NIL. ALTHOUGH
00130	;## 	CODE FOR EXTENDED SWITCHES IS INCLUDED, MOST OF
00140	;## 	IT IS TURNED OFF. USE AT YOUR OWN RISK. NOTE THAT
00150	;## 	/LIST, /AFTER AND /DEAD REQUIRE SPECIAL CODE
00160	;## 	THAT IS NOT INCLUDED. SEE APPROPRIATE
00170	;## 	DEC DOCUMENTATION FOR FURTHER INFO. 6/12/73
00180	
00190	
00200	IFN QALLOW <
00210		IFNDEF	QSWEXT	<QSWEXT=0>	;## IF NOT DEFINED THEN DEFAULT IS NO EXTENDED 
00220		IFE	QSWEXT	<NSWS==QTABL1>;## NUMBER OF ALLOWED SWITCHES
00230		IFN	QSWEXT	<NSWS==QTABL2>;## LENGTH OF EXTENDED TABLE
00240		IFNDEF	QLSTOK	<QLSTOK==0>
00250		IFNDEF	QTIME	<QTIME==0>
00260	
00270	
00280		;%% THE FOLLOWING CODE IS AN ILLUSTRATION OF HOW
00290		;%% EASY IT IS TO LOSE TRYING TO INTERFACE TO
00300		;%% DEC SOFTWARE.  THE FOLLOWING DEFINITIONS ALLOW
00310		;%% TOO FEW WORDS FOR THE CURRENT FILE PARAMETER 
00320		;%% AREA; SEE THE DEFINITIONS AS COPIED FROM
00330		;%% THE QMANGR SOURCE BELOW.
00340		COMMENT &
00350		INPPAR==32	;## NUMBER OF WORDS IN INP AREA FOR INPUT REQUEST
00360		OUTPAR==24	;## NUMBER WORDS IN MAIN AREA FOR OUTPUT REQUEST
00370		DIFPAR==INPPAR-OUTPAR	;##  DIFFERENCE IN LENGTHS FOR MAIN AREA TYPES
00380		FILPAR==14	;## NUMBER WORDS IN FILE PARAMTER AREA
00390	
00400	
00410	
00420	
00430				;## LOCATIONS IN PARAMETER AREAS
00440		;## MAIN AREA
00450		Q.MEM==0		;## MEMORY FOR QMANGR
00460		Q.OPR==1		;## REQUESTED OPERATION
00470		Q.LEN==2		;## RH=NUMBER OF FILES IN REQUEST
00480		Q.DEV==3		;## REQUESTED QUEUE
00490		Q.PPN==4		;## PPN REQUESTING
00500		Q.JOB==5		;## JOB NAME
00510		Q.SEQ==6		;## JOB SEQUENCE #
00520		Q.PRI==7		;## EXTERNAL PRIORITY
00530		Q.PDEV==10		;## 
00540		Q.TIME==11		;## 
00550		Q.CREA==12		;## 
00560		Q.AFTR==13		;## AFTER PARAMETER
00570		Q.DEAD==14		;## DEADLINE PARAMETER
00580		Q.CNO==15
00590		Q.USER==16		;## AND 17
00600		;## INPUT SECTION OF MAIN PARAMETER AREA
00610		Q.IDEP==20			;## RESTART AND DEPENDENCY PARAMTERS
00620		Q.ILIM==21		;## CORE AND CPU, +1 IS LPT LIMIT AND CDP LIMIT
00630					;## +2 IS PTP LIMIT AND PLOT LIMIT
00640		Q.IDDI==24		;## THRU 31
00650		Q.IEND==31		;## LAST LOC OF INP AREA
00660		;## OUTPUT SEECTION OF MAIN PARAMETER AREA
00670		Q.OFRM==20		;## FORM PARAMTER
00680		Q.OSIZ==21		;## LH=LIMIT
00690		Q.ONOT==22
00700		Q.OEND==23		;## LAST LOC OF OUTPUT AREA
00710		;## FILE PARAMETER AREA (ONE FOR EACH FILE)
00720		Q.FSTR==0		;## FILE STRUCTURE
00730		Q.FDIR==1		;## THRU 6, DIRECTORY
00740		Q.FNAM==7		;## FILE NAME
00750		Q.FEXT==10		;## FILE EXTENSION
00760		Q.FRNM==11		;## RENAME NAME (0)
00770		Q.FBIT==12	
00780		Q.FMOD==13		;## SPACING, FILE DISPOSAL, COPIES
00790		&			;%% END OF DELETED DEFINITIONS
00800	
00810		;%% THE FOLLOWING ARE AS COPIED FROM QMANGR (VERSION 34)
00820		;%% ON 24 OCTOBER 1973
00830	
00840		QDEFST==.		;%% WHERE TO RELOC TO AFTERWARDS
00850		RELOC	0		;%% TO SAVE CORE AND AVOID CONFUSION
00860					;%% COMMENTS BELOW ARE AS COPIED 
00870					;%% FROM QMANGR
00880		PHASE	0
00890	Q.ZER:!			;START OF QUEUE PARAMETER AREA
00900	Q.MEM:!	 BLOCK	1	;HOLD XWD WINDOW BLOCK,WINDOW WORD INDEX
00910	Q.OPR:!	 BLOCK	1	;OPERATION CODE
00920	    QO.CRE==1		;CREATION OPERATION
00930	    QO.LST==4		;LIST OPERATION
00940	    QO.MOD==5		;MODIFY OPERATION
00950	    QO.KIL==6		;KILL OPERATION
00960	    QO.DEL==10		;DELETE OPERATION
00970	    QO.REQ==11		;REQUEUE OPERATION
00980	    QO.FLS==12		;FAST LIST OPERATION
00990	Q.LEN:!	 BLOCK	1	;LENGTHS IN AREA
01000	Q.DEV:!	 BLOCK	1	;DESTINATION DEVICE
01010	Q.PPN:!	 BLOCK	1	;PPN ORIGINATING REQUEST
01020	Q.JOB:!	 BLOCK	1	;JOB NAME
01030	Q.SEQ:!	 BLOCK	1	;JOB SEQUENCE NUMBER
01040	Q.PRI:!	 BLOCK	1	;EXTERNAL PRIORITY
01050	Q.PDEV:! BLOCK	1	;PROCESSING DEVICE
01060	Q.TIME:! BLOCK	1	;PROCESSING TIME OF DAY
01070	Q.CREA:! BLOCK	1	;CREATION TIME
01080	Q.AFTR:! BLOCK	1	;AFTER PARAMETER
01090	Q.DEAD:! BLOCK	1	;DEADLINE TIMES
01100	Q.CNO:!	 BLOCK	1	;CHARGE NUMBER
01110	Q.USER:! BLOCK	2	;USER'S NAME
01120	
01130	Q.I:!			;START OF INPUT QUEUE AREA
01140	Q.IDEP:! BLOCK	1	;DEPENDENCY WORD
01150	Q.ILIM:! BLOCK	3	;JOB LIMITS
01160	Q.IL:!			;END OF AREA NEEDED TO READ FOR MASTER QUEUE
01170	Q.IDDI:! BLOCK	6	;JOB'S DIRECTORY
01180	Q.II:!			;START OF INPUT FILES AREA
01190	
01200		PHASE	Q.I
01210	Q.O:!			;START OF OUTPUT QUEUE AREA
01220	Q.OFRM:! BLOCK	1	;FORMS REQUEST
01230	Q.OSIZ:! BLOCK	1	;LIMIT WORD
01240	Q.OL:!			;END OF AREA NEEDED TO READ FOR MASTER QUEUE
01250	Q.ONOT:! BLOCK	2	;ANNOTATION
01260	Q.FF:!
01270		PHASE	0
01280	Q.F:!			;DUPLICATED AREA FOR EACH REQUESTED FILE
01290	Q.FSTR:! BLOCK	1	;FILE STRUCTURE
01300	Q.FDIR:! BLOCK	6	;ORIGINAL DIRECTORY
01310	Q.FNAM:! BLOCK	1	;ORIGINAL NAME
01320	Q.FEXT:! BLOCK	1	;ORIGINAL EXTENSION
01330	Q.FRNM:! BLOCK	1	;RENAMED FILE NAME (0 IF NOT)
01340	Q.FBIT:! BLOCK	1	;BIT 0=PRESERVED BY QUEUE, REST=STARTING BIT
01350	Q.FMOD:! BLOCK	1	;FILE SWITCHES
01360	X.LOG==1B1	;FILE IS LOG FILE
01370	X.NEW==1B2	;OK IF FILE DOESNT EXIST YET
01380	Q.FRPT:!BLOCK	2		;/REPORT
01390	
01400	Q.FLEN==.-Q.F
01410		DEPHASE
01420		PHASE	0
01430	Q.FDRM:! BLOCK	6	;DIRECTORY MASK FOR MODIFY
01440	Q.FNMM:! BLOCK	1	;FILE NAME MASK FOR MODIFY
01450	Q.FEXM:! BLOCK	1	;EXTENSION MASK FOR MODIFY
01460	Q.FMDM:! BLOCK	1	;MODIFIER MASK FOR MODIFY
01470	Q.FMLN==.-Q.F	;LENGTH OF MODIFY BLOCK
01480	
01490		DEPHASE
01500		RELOC	QDEFST		;%% MAKE UP FOR INCREASE IN LOCATION 
01510					;%% COUNTER
01520	
01530		INPPAR==Q.II		;%% SIZE OF MINIMUM INPUT AREA
01540		OUTPAR==Q.FF		;%% SIZE OF MINIMUM OUTPUT AREA
01550		OUTPR1==OUTPAR-1	;%% MACRO DOESN'T LIKE EXPRESSIONS
01560		DIFPAR==INPPAR-OUTPAR	;%% DIFFERENCE IN AREAS
01570		FILPAR==Q.FLEN		;%% FILE DATA AREA
01580		LOWLEN==↑D110		;## AREA NEED FOR PARAMETER
01590					;## AREA TO QMANGR
01600		LHLEN==OUTPR1*1B26+FILPAR ;## LH OF Q.LEN DEFAULTS
01610		NQS==6			;## NUMBER OF QUEUES
01620	
01630	
01640			;## QUEUE ERRORS
01650	
01660	QILLSW:	HLRZ	A,(T)		;## GET SWITCH THAT  CAUSED ERROR
01670		PUSHJ	P,PRINT
01680		STRTIP	[SIXBIT /  =ILL. SWITCH SPEC.!/]
01690		PUSHJ	P,CONCOR	;## SAVE THAT CORE
01700	QERR1:	ERR2	[SIXBIT /ERROR IN QUEUE REQUEST!/]
01710	
01720	
01730	
01740	QUEUE:	SKIPN	T,A		;## ERROR IF NO ARGS
01750		JRST	QERR1
01760		PUSHJ	P,DEVCHK	;## SEE IF QUEUE SPECIFIED
01770		JUMPE	A,NOQUE		;## IF A=0 THEN NOT A QUEUE
01780		JUMPE	B,NOQUE		;## IF B=0 THEN NOT A QUEUE
01790		MOVE	AR2A,A
01800		HLRZ	B,A		;## GET FIRST THREEE LETTERS
01810		MOVEI	C,NQS		;## GET NUMBER OF PERMISSIBLE QUEUES
01820		SOJL	C,NOQUE		;## IF EXHAUSTED TABLE, THEN  NO QUEUE
01830		MOVE	A,QSTABL(C)	;## PERMISSIBLE QUEUES
01840		JSP	R,CHKGO		;## JUMP TO ROUTINE THAT COMPARES RH AND GO
01850					;## TO LH OF A IFF RH(A)=B
01860		JRST	.-3		;## LOOP
01870	
01880	
01890	
01900		;## TABLE OF PERMISSIBLE QUEUES AND WHERE TO GO ON EACH
01910	
01920	QSTABL:	XWD	INPREQ, 'INP'
01930		XWD	OUTREQ,	'LPT'
01940		XWD	OUTREQ,	'PTP'
01950		XWD	OUTREQ,	'PTP'
01960		XWD	OUTREQ,	'CDP'
01970		XWD	OUTREQ,	'PLT'
01980	
01990	OUTREQ:	TDZA	A,A		;## HERE TO PROCESS OUTPUT REQUEST(CLEAR A)
02000	INPREQ:	MOVEI	A,DIFPAR	;## HERE TO PROCESS INPUT REQUEST
02010		JRST	QGOOD		;## FOUND A QUEUE
02020	NOQUE:	MOVSI	AR2A,'LPT'	;## HERE IF NO QUEUE, DEFAULT=LPT
02030		TDZA	A,A		;## CLEAR A AND SKIP
02040	QGOOD:	HRRZ	T,(T)		;## HERE IF QUEUE SPECIFIED
02050		ADDI	A,OUTPAR	;## A IS ZERO OR INPPAR
02060	QSETUP:	PUSH	P,B		;## B CONTAINS THREE LETTERS(OR BLANK). SAVE IT
02070		HRLZI	TT,(A)		;## SAVE LNENGTH OF AREA
02080		PUSHJ	P,TEMCOR	;## EXPAND CORE
02090		HRRI	TT,(A)		;## START ADDR OF MAIN AREA
02100		MOVE	A,TT
02110		PUSHJ	P,CLRBLK	;## CLEAR AREA
02120		MOVEM	AR2A,Q.DEV(TT)
02130		MOVEI	C,LHLEN		;## GET LENGTHS FOR HEADER AND FILE AREAS
02140		MOVE	A,[XWD 500,500]
02150		HRLZM	A,Q.OSIZ(TT)	;## ASSUME OUTPUT HERE
02160		POP	P,B		;## RESTORE LEFT THREE LETTERS
02170		CAIE	B,'INP'		;## WAS IT AN INPUT REQUEST?
02180		JRST	QUEUE1		;## NO SHOULD  BE OK
02190		ADDI	C,DIFPAR←9	;## UPDATE HEADER LENGTH
02200		MOVEM	A,Q.ILIM+1(TT)	;## MAX PAGES AND CARD PUNCH
02210		MOVEM	A,Q.ILIM+2(TT)	;## MAX PAPER TAPE AND  PLOTTER
02220		HRLI	A,↑D256
02230		MOVEM	A,Q.ILIM(TT)	;## MAX CORE AND CPU(CORMAX MAY HAVE TO BE
02240					;##  CHECKED HERE)
02250		MOVSI	A,400000	;## SET BIT 0 FOR NOT RESTARTABLE
02260		HLLZM	A,Q.IDEP(TT)	;## NOT RESTARTABLE(NO DEPEND OR UNIQUENESS)
02270	QUEUE1:	MOVSM	C,Q.LEN(TT)	;## SET HEADER AND FILE AREA LENGTHS
02280		GETPPN	A,		;## SET REQUESTING PPN
02290		CAI			;## WEIRD SKIP RETURN ON THIS UUO
02300		MOVEM	A,Q.PPN(TT)
02310		SETZ	REL,		;## CLEAR REG FOR FILE AREA
02320		MOVEI	A,20	;## PRIORITY DEFAULT
02330		MOVEM	A,Q.PRI(TT)
02340		AOSA	Q.OPR(TT)	;## SET DEFAULT FOR REQUEST TYPE=/CREATE
02350		;##  BASIC LOOP FOR HANDLING THE SWITCHES
02360	
02370	QLOOP:	HRRZ	T,(T)		;## HERE IF ROUTINE DID NOT MOVE ARG 
02380	QSELF:	JUMPE	T,QDONE
02390		PUSHJ	P,DEVCHK	;## SEE IF DEVICE OR ATOMIC FILE NAME?
02400		JUMPN	B,QFILEA	;## IF B#0 THEN DEVICE
02410		JUMPN	A,QFILE		;## IF A#0 THEN ATOMIC FILE
02420		HLRZ	C,(T)		;## WELL, SEE IF SWITCH
02430		HRRZ	A,(C)		;## CDAR
02440		PUSHJ	P,ATOM		;## ATOM?
02450		JUMPN	A,QFILE		;## YES, THEREFORE(FILE.EXT)
02460		HLRZ	B,(C)		;## CAAR
02470		SUBI	B,(S)		;## STRIP OFF RELOCATION
02480		HRRZI	C,NSWS		;## GET NUMBER OF SWITCHES
02490	QLOOP1:	SOJL	C,QFILE		;## IF NO SWITCH, GO QFILE
02500		MOVE	A,QTABLE(C)	;## GET MEMBER OF TABLE
02510		JSP	R,CHKGO
02520		JRST	.-3		;## LOOP
02530	
02540	
02550		;## DISPATCH TABLE FOR SWITCHES
02560	
02570	QTABLE:
02580		PHASE 1
02590		XWD	QCOPIE,COPIES	;## /COPIES
02600		XWD	QCPU,CPU	;## /CPU
02610		XWD	QFORMS,FORMS	;## /FORMS
02620		XWD	QLIMIT,LIMIT	;## /LIMIT
02630	QTABL1:	XWD	QDISP,DISP	;## /DISP (FILE DISPOSITION)
02640	
02650		;## EXTENDED SWITCHES
02660	
02670	IFN QSWEXT   <
02680		IFE QLSTOK	<XWD QILLSW, LISTAT>
02690		IFN QLSTOK	<XWD QLIST, LISTAT>
02700	
02710		IFE QTIME <
02720		XWD	QILLSW,AFTER	;## /AFTER ILLEGAL (SEE ABOVE)
02730		XWD	QILLSW,DEAD	;## /DEAD (DEADLINE)
02740			>
02750	
02760		IFN QTIME <
02770		XWD	QAFTR,AFTER
02780		XWD	QDEAD,DEAD
02790			>
02800		XWD	QCORE,COREAT
02810		XWD	QMOD,MODIFY	;## /MODIFY
02820		XWD	QKILL,KILL	;## /KILL
02830		XWD	QJOB,JOB	;## /JOB
02840		XWD	QDEPND,DEPEND	;## /DEPEND
02850		XWD	QRSTR,RSTRT	;## /RESTART
02860		XWD	QUNIQ,UNIQUE	;## /UNIQUE
02870		XWD	QCORE,COREAT	;## /COREE
02880		XWD	QPAGES,PAGES	;## /PAGES
02890		XWD	QPLOT,PLOT	;## /PLOT
02900		XWD	QPTAPE,PTAPE	;## /PTAPE
02910		XWD	QCARDS,CARDS	;## /CARDS
02920		XWD	QSEQ,SEQ	;## /SEQ
02930		XWD	QPRIOR,PRIOR	;## /PRIOR (PRIORITY)
02940		XWD	QSPACE,SPACE	;## /SPACE (SPACING)
02950		XWD	QLIMIT,LIMIT	;## /LIMIT
02960	QTABL2:	XWD	QHEAD,HEAD	;## /HEAD (HEADERS)
02970		>
02980		DEPHASE
02990	
03000		;##  DISPATCHING THE VARIOUS SWITCHES
03010	
03020	IFN QSWEXT <QLIST:	HRRZI	A,4		;## HERE FOR LIST REQUEST
03030		CAIA
03040	QMOD:	HRRZI	A, 5		;## /MODIFY
03050		CAIA
03060	QKILL:	HRRZI	A, 6		;## /KILL
03070		HRRZM	A, Q.OPR(TT)
03080		JRST	QLOOP
03090		>
03100	
03110		;##  INPUT QUEUE ONLY SWITCHES
03120		;##  PUTS BYTE POINTER INTO  B  AND  THEN CHECKS TO SEE  IF SWITCH VALID IN
03130		;##  THIS CONTEXT (I.E. ARE WE PROCESSING AN INPUT REQUEST?)
03140		;##  IF NOT VALID, SKIPS THE SWITCH(MAY BE CHANGED LATER)
03150	
03160	IFN QSWEXT <
03170	QPLOT:	JSP	R,RINPCH
03180		AOJA	B, QCARD+1
03190	QPTAPE:	JSP	R, LINPCH
03200		AOJA	B, .+4
03210	QCARDS:	JSP	R, RINPCH
03220		AOJA	B, .+4
03230	QPAGES:	JSP	R, LINPCH
03240		AOJA	B, .+4
03250		>
03260	
03270	QCPU:	JSP	R, RINPCH
03280		AOJA	B,QARG
03290	
03300	
03310	IFN QSWEXT <
03320	QCORE:	JSP	R, LINPCH
03330		AOJA	B,QARG
03340	QDEPND:	JSP	R, RINPCH
03350		JRST	QARG
03360		>
03370	
03380				;##  OUTPUT  QUEUE ONLY  SWITCHES
03390	QFORMS:	JSP	R, OUTCHK
03400		PUSH	P,QSXARG	;## CONVERT ARG TO SIXBIT
03410		MOVEM	A, Q.OFRM(TT)	;## MAKE SIXBIT IF FORMS
03420		JRST	QLOOP
03430	QLIMIT:	JSP	R, OUTCHK
03440		MOVE	B,LINP
03450		AOJA	B,QARG
03460	
03470	OUTCHK:	HLRZ	A,Q.DEV(TT)	;## GET REQUEST TYPE (THREE LETTERS)
03480		CAIE	A,'INP'		;## ERROR IF INPUT REQUEST
03490		JRST	(R)
03500		JRST	QILLSW
03510	
03520	QCOPIE:	JSP	R, FILECH	;## CHECK IF WE HAVE SET UP A FILE AREA
03530		MOVE	B,[POINT 6,Q.FMOD(REL),35]	;## BYTE POINTER
03540		JRST	QARG
03550	
03560	
03570			;## FOR DISPOSITION, 1=PRESERVE,  2=RENAME, 3=DELETE,
03580			;## FIRST THREE LETTERS OF ARG TO SWITCH   UNIQUELY  IDENTIFY
03590			;## ILLEGAL ARG CAUSES ERROR
03600	QDISP:	JSP	R,FILECH	;## BE SURE FILE AREA SET UP
03610		PUSHJ	P,QSXARG	;## MAKE ARG SIXBIT
03620		HLRZ	C,A		;## GET FIRST THREE LETTERS
03630		SETZ	A,		;## CLEAR A
03640		CAIN	C,'DEL'		;## DELETE AFTER OUTPUT!
03650		AOJA	A,.+2		;## YES!
03660		CAIN	C,'REN'	;## RENAME FILE OUT OF UFD?
03670		AOJA	A,.+3
03680		CAIE	C,'PRE'		;## PRESERVE IT
03690		JRST	QILLSW		;## HERE IF BAD ARGUMENT
03700		ADDI	A,1
03710		MOVE	B, [POINT 3, Q.FMOD(REL), 29]
03720		JRST	QARG+1		;## ARG ALREADY IN A
03730					;## HERE WHEN SWITCH DETERMINED AND BITE POINTER IN B
03740	QGTARG:	MOVEI	A,(T)
03750		PUSHJ	P,CADAR
03760		SUBI	A,INUM0		;## ARG SHOULD BE AN INUM
03770		POPJ	P,
03780	QARG:	PUSHJ	P,QGTARG	;## GET ARGUMENT
03790		DPB	A,B		;## 
03800		JRST	QLOOP		;## ALWAYS RETURN TO QLOOP
03810	
03820				;## HERE TO SEE IF INP QUEUE FOR EXTENDED PART OF MAIN AREA
03830	
03840	LINPCH:	MOVE	B,LINP		;## GET LH BITE POINTER
03850		CAIA
03860	RINPCH:	MOVE	B,RINP		;## GET RH BITE POINTER
03870		HLRZ	A,Q.DEV(TT)	;## GET QUEUE SPEC
03880		CAIN	A,'INP'		;## INP?
03890		JRST	(R)		;## YES
03900		JRST	QILLSW
03910	LINP:	POINT	18, Q.IDEP(TT),17		;## BYTE POINTER FOR LEFT HALF OF EXTENDED MAIN AREA
03920	RINP:	POINT	18, Q.IDEP(TT),35		;## BYTE POINT FOR RH OF EXTENDED MAIN AREA
03930	
03940	
03950				;## HERE TO BE SURE FILE AREA HAS BEEN SET UP
03960	
03970	FILECH:	JUMPN	REL,(R)		;## REL NONZERO IF FILE AREA SET UP
03980		PUSH	P,R
03990		JRST	FILARE
04000				;## HERE TO FIND FILE SPECIFICATION
04010	
04020	
04030	QFILEA:	HRRZ	T,(T)		;## GET CDR
04040	IFN SFDFLG,< SETZ B,		;## CLEAR B
04050		JRST	QFILEB>
04060	IFE SFDFLG,<JRST QFILED>	;WMT-USE DEFAULT PATH
04070	IFN SFDFLG,<
04080	QFILE:	MOVSI	A,'DSK'		;## DEFAULT IS DSK
04090		CAIE	REL,0		;## AREA SET UP?
04100		SKIPA	A,Q.FSTR(REL)	;## GET CURRENT DEVICE
04110		SKIPA	B,Q.PPN(TT)	;## GET USER'S PPN IF NOT SET UP
04120		MOVE	B,Q.FDIR(REL)	;## GET CURRENT PPN
04130	QFILEB:	MOVEM	B,PPN		;## SET PPN
04140		MOVEM	A,DEV>		;## HANG ON TO DEVICE
04150	
04160	IFE SFDFLG,<
04170	QFILE:	JUMPE	REL,QFILEC	;WMT-AREA SET UP?
04180		MOVE	A,Q.FSTR(REL)	;WMT-NO, GET DEVICE
04190		MOVE	B,[XWD Q.FDIR,PPN] ;WMT-MOVE PATH IN
04200		ADDI	B,(REL)		;WMT-INDEX
04210		BLT	B,PPN+SFDLEN	;WMT-MOVE THEM IN
04220		JRST	QFILEB
04230	QFILEC:	MOVSI	A,'DSK'		;WMT-DEFAULT DEVICE
04240	QFILED:	SETZM	PPN		;WMT-USE DEFAULT PATH
04250	QFILEB:	MOVEM	A,DEV>
04260	
04270		JUMPE	T,QSELF		;## IF NIL THEN DONE
04280		PUSHJ	P,NXTIO		;## FAKE IOSUB SEQUENCE
04290		PUSHJ	P,IOPPN
04300		PUSH	P,A		;## IOPPN RETURNS FILE NAME IN A
04310		CAIE	REL,0		;## AREA SET UP?
04320		SKIPE	Q.FNAM(REL)	;## AREA SET UP, BUT NO FILE NAME?(PRECEDING SWITCHES)
04330		PUSHJ	P,FILARE	;## SET UP AREA
04340		MOVE	A,DEV		;## GET DEVICEE
04350		MOVEM	A,Q.FSTR(REL)	;## SET FILE STRUCTURE
04360		MOVE	A,EXT		;## GET EXTENSION
04370		MOVEM	A,Q.FEXT(REL)	;## SET IT
04380	IFN SFDFLG,<
04390		MOVE	A,PPN		;## GET PPN
04400		MOVEM	A,Q.FDIR(REL)>
04410	IFE SFDFLG,<
04420		MOVE A,[XWD PPN,Q.FDIR]	;WMT-MOVE IT ALL IN
04430		ADDI	B,(REL)		;WMT-INDEX
04440		BLT	A,Q.FDIR+SFDLEN(REL)>
04450		;## SET IT(DIRECTORY)
04460		POP	P,Q.FNAM(REL)	;## RESTORE NAME
04470		JRST	QSELF		;## T HAS BEEN RESET BY IO ROUTINES!
04480	
04490	
04500	
04510				;## HERE TO SET UP FILE AREA
04520	
04530	
04540	FILARE:	AOS	Q.LEN(TT)	;## ADD ONE TO NUMBER FILES IN REQUEST
04550		HRLZI	A,FILPAR
04560		ADD	TT,A		;## ADD TO LENGTH OF PARAMETER AREA
04570		HRRZI	A,FILPAR
04580		PUSHJ	P,EXPCOR
04590		JUMPE	REL,FILDEF	;## SET DEFAULST IF NO PREVIOUS FILE AREA
04600		HRL	A,REL
04610		HRRZI	B,(A)		;## SET UP FOR BLT OF PREVIOUS AREA
04620		ADDI	B,FILPAR-1	;## FINAL DESTINATION ADDRESS
04630		HRRZI	REL,(A)		;## NEW FILE AREA
04640		BLT	A,(B)
04650		SETZM	Q.FNAM(REL)
04660		POPJ	P,
04670	FILDEF:	HRRZI	REL,(A)
04680		HRLI	A,FILPAR
04690		PUSHJ	P,CLRBLK
04700		HRLZI	A,'DSK'
04710		MOVEM	A,Q.FSTR(REL)
04720		MOVE	A,[EXP 1B5+1B20+1B26+1B29+1]	;## DEFAULTS FOR Q.FMOD
04730		MOVEM	A,Q.FMOD(REL)
04740		POPJ	P,
04750	
04760				;## HERE WHEN FINISHED
04770	
04780	
04790	QDONE:	MOVE	AR1,OUTPAR+Q.FNAM(TT)	;## GET FIRST FILE NAME
04800		HLRZ	A,Q.DEV(TT)	;## GET FIRST THREE LETTERS OF Q AGAIN
04810		CAIE	A,'INP'		;## INPUT QUEUE?
04820		JRST	QDONEB		;## NO
04830		MOVE	AR1,INPPAR+Q.FNAM(TT)	;## GET CORRCT FILE NAME
04840		HRRZ	A,Q.LEN(TT)	;## GET NUMBER OF FILES SPECIFIED
04850		SOJG	A,QDONEC	;## GREATER THAN ONE MEANS THAT USER
04860					;## SPECIFIED A LOG FILE
04870		PUSHJ	P,FILARE	;## WE HAVE TO SET UP LOG FILE
04880		HRRZI	A,'LOG'	;## CHANGE EXTENSION TO .LOG
04890		HRLZM	A,Q.FEXT(REL)
04900		MOVEM	AR1,Q.FNAM(REL)	;## SET TO INP FILE NAME
04910	QDONEC:	HRRI	A,3
04920		DPB	A,[POINT 2,INPPAR+FILPAR+Q.FMOD(TT),2];## SET BITS
04930					;## INDICATING LOG FILE AND DOESN'T EXIST
04940					;## (AVOIDS ERROR MSGS FROM QMANGR)
04950					;## IN SECOND FILE IN CASE USER STUPIDLY SET
04960					;## UP MORE THAN TWO
04970	QDONEB:	SKIPE	Q.JOB(TT)	;## SPECIFIED NAME 
04980		JRST	QDONE1		;## YES, DONE
04990		MOVEM	AR1,Q.JOB(TT)
05000	QDONE1:	MOVE	C,[EXP 'QMANGR'];## SEGMENT NAME
05010		MOVEI	B,400010
05020		MOVE	A,TT
05030		PUSHJ	P,NEWHI
05040		PUSHJ	P,CONCOR	;## CONTRACT CORE
05050		SKIPN	CCFLAG		;*** ↑C HIT DURING QUEUE?
05060		JRST	FALSE		;## RETURN NIL
05070		POP	P,CCFLAG	;*** YES: GO INTERRUPT NOW
05080		JRST	CCINT1
05090	
05100	
05110	;## ROUTINE TO SWAP HI-SEGMENTS. A CONTAINS ARG TO NEXT HI-SEG, B CONTAINS
05120	;## LOCATION TO JUMP TO IN NEW HI-SEG. REGS ARE ARG BLOCK TO GETSEG UUO
05130	
05140	NEWHI:	PUSH	P,SP		;## HAVE TO SAVE SP, SINCE MOST
05150					;## SYSTEM PROGS USE 17 FOR THEIR PDL
05160		MOVEM	A,HIARGS#	;## SAVE ARG TO HI-SEG
05170		HRRZM	B,HIADDR#	;## SAVE ADDR TO HI-SEG
05180		PUSH	P,.JBFF		;%% SAVE OLD VALUE 
05190					;%% (DON'T ASK WHY)
05200		HLRZ	B,A		;%% CALCULATE NEW VALUE
05210		ADDI	B,1(A)		;%%
05220		MOVEM	B,.JBFF		;%% RESET SO QMANGR WON'T WRITE
05230					;%% OVER ARGUMENT BLOCK.
05240					;%% JUST BECAUSE LISP IGNORES .JBFF
05250					;%% DOESN'T MEAN ANYONE ELSE DOES
05260		MOVEM	P,PSAVE#	;## SAVE P (CAN'T USE SP)
05270		MOVE	SP,P		;## USE RPDL
05280		MOVEI	A,CCINTQ	;*** SET NEW ↑C TRAP LOCATION
05290		HRRM	A,CCBLK		;***
05300		HRLZI	B,'SYS'		;## SYS: IS LOCATION OF NEW HI-SEG
05310		MOVEI	A,B		;## B IS STARTING LOCATION OF BLOCK TO GETSEG
05320		SETZB	AR1,AR2A	;## CLEAR REST OF BLOCK
05330		SETZB	T,TT		;## DITTO
05340		MOVEM	SP,SAVSP#	;## SAVE SP AROUND GETSEG (WHICH CLOBBERS ACS)
05350		JRST	NEWHI1		;## GO DO  IT
05360	
05370					;## HERE TO GET THAT HI-SEG
05380	
05390	REMOTE <
05400	NEWHI1:	GETSEG	A,
05410		JRST	OLDHI		;## FAILED (GIVE UP)
05420		MOVE	SP,SAVSP
05430		MOVE	A,HIARGS
05440		PUSHJ	SP,@HIADDR	;## JUMP TO HI-SEG
05450	OLDHI:	MOVEI	A,HGHDAT
05460		GETSEG	A,
05470		HALT			;## YOU'RE DEAD IF YOU ARE HERE
05480	ENDHI:	JRST	RESTOR		;## JUMP TO RESTORE THINGS
05490	
05500	CCINTQ:	SETOM	CCFLAG		;*** ↑C HIT: SET FLAG TO CAUSE DELAYED TRAP
05510		SETZM	CCBLK+2		;*** RE-ENABLE ↑C TRAPPING
05520		JRST	OLDHI		;*** AND GO GET LISP'S HI-SEG
05530		>
05540	
05550	
05560	RESTOR:	MOVE	P,PSAVE
05570		POP	P,.JBFF		;%% RESTORE OLD VALUE
05580		POP	P,SP
05590		MOVE	0,STNIL
05600		MOVE	S,ATMOV
05610		MOVEI	A,CCINT		;*** RESTORE ↑C INTERRUPT LOC
05620		HRRM	A,CCBLK		;***
05630		POPJ	P,
05640	
05650	
05660	TEMCOR:	HRRZ	B,CORUSE	;## GET CURRENT CORUSE. THIS ROUTINE EXPANDS CORE
05670					;## BUT SAVE INFO SO IT CAN BE CONTRACTED LATER
05680		HRL	B,.JBREL	;## GET CURRENT CORE EXTENT
05690		MOVEM	B,OLDCU		;## SAVE IT (SEE LOADER INTERFACE)
05700	EXPCOR:	SETZ	D,		;## D IS A RELOC REG
05710		JRST	MORCOR		;## EXPAND CORE
05720	
05730	CONCOR:	MOVS	B,OLDCU		;## CONTRACTS CORE, OPPOSITE TEMCOR
05740		HLRZM	B,CORUSE
05750		HRRZI	B,(B)		;## CLEAR LH
05760		PUSHJ	P,MOVDWN	;## MOVE SYMBOL TABLE
05770		CORE B,		;## CONTRACT (B SHOULD BE UNCHANGED
05780		CAI
05790		POPJ	P,		;## DONE
05800	
05810	
05820	QSXARG:	MOVEI	A,(T)
05830		PUSHJ	P,CADAR		;## GET ARGUMENT TO SWITCH
05840		JRST	SIXMAK		;## CONVERT  IT TO SIXBIT
05850	
05860	
05870	
05880	CLRBLK:	SETZM	(A)		;## CLEAR FIRST WORD
05890		HLRZ	B,A		;## LH OF A CONTAINS LENGTH
05900		ADD	B,A
05910		HRL	A,A
05920		ADDI	A,1		;## RH NOW CONTAINS SOURCE+1
05930		BLT	A,-1(B)		;## BLT CLEARS BLOCK
05940		POPJ	P,
05950		;## PICKUP
05960	
05970	
05980	CHKGO:	CAIN	B,(A)		;## SEE IF RH(A)=(B)
05990		HLRZ	R,A		;## WHERE TO GO
06000		JRST	(R)		;## NO, RETURN
06010		>
06020	
06030		PAGE
     
00010		SUBTTL	PRINT
00020	
00030	EPRINT:	MOVE B,RSTSW		;*** DON'T PRINT IF *RSET = @ERRORX
00040		CAIE B,ERRORX(S)	;***
00050		SKIPN ERRSW		;*** ENTER HERE FOR "SERIOUS" PRINT
00060		POPJ P,
00070	EPRNT1:	PUSHJ P,ERRIO
00080		PUSHJ P,PRINT
00090		JRST OUTRET
00100	
00110	PRINT:	MOVEI R,TYO
00120		PUSHJ P,TERPRI
00130		PUSHJ P,PRIN1
00140		XCT " ",CTY
00150		POPJ P,
00160	
00170	PRINC:	SKIPA R,.+1
00180	PRIN1:	HRRZI R,TYO		;LH(R) .NE. 0 if PRINC
00190		PUSH P,A
00200		PUSHJ P,PRINTA
00210		JRST POPAJ
00220	
00230	PRINTA:	PUSH P,A
00240		MOVEI B,PRIN3
00250		SKIPGE R
00260		MOVEI B,PRIN4
00270		HRRM B,PRIN5
00280		PUSHJ P,PATOM
00290		JUMPN A,PRINT1
00300		XCT "(",CTY
00310	PRINT3:	HLRZ A,@(P)
00320		PUSHJ P,PRINTA
00330		HRRZ A,@(P)
00340		JUMPE A,PRINT2
00350		MOVEM A,(P)
00360		XCT " ",CTY
00370		PUSHJ P,PATOM
00380		JUMPE A,PRINT3
00390		XCT ".",CTY
00400		XCT " ",CTY
00410		PUSHJ P,PRIN1A
00420	PRINT2:	XCT ")",CTY
00430		JRST POPAJ
00440	
00450	PRINT1:	PUSHJ P,PRIN1A
00460		JRST POPAJ
00470	PAGE
     
00010	PRIN1A:	MOVE A,-1(P)
00020		CAILE A,INUMIN
00030		JRST PRINIC
00040	IFE OLDNIL <
00050		CAIN A,NIL		;*** IF NEW NIL THEN
00060		MOVEI A,FAKNIL(S)	;*** GET FAKE ATOM HEADER
00070	>
00080		CAIGE A,@GCP1
00090		CAIGE A,@GCPP1
00100		JRST PRINL
00110	PRIN1B:	HRRZ A,(A)
00120		JUMPE A,PRINL
00130		HLRZ B,(A)
00140		HRRZ A,(A)
00150		CAIN B,PNAME(S)
00160		JRST PRINN
00170		CAIN B,FIXNUM(S)
00180		JRST PRINI1
00190		CAIN B,FLONUM(S)
00200		JRSTF @[XWD 0,PRINO]	; TURN OFF DIVIDE CHECK AND UNDERFLOW
00210	IFN BIGNMS<
00220	BPR:	JRST PRIN1B	;bignums change here to JRST BPRINT>
00230		JRST PRIN1B
00240	
00250	PRINL2:	MOVEI R,TYO
00260		JRST PRINL1
00270	
00280	PRINL:	XCT "#",CTY
00290		HRRZ A,-1(P)
00300	PRINL1:	MOVEI C,8
00310		JRST PRINI3
00320	
00330	PRINI1:	SKIPA A,(A)
00340	PRINIC:	SUBI A,INUM0
00350		HRRZ C,VBASE(S)
00360		SUBI C,INUM0
00370	IFE BIGNMS<
00380		JUMPL C,[MOVNS C	;*** NEW -BASE FEATURE
00390			 JRST PRINI2]>
00400		JUMPGE A,PRINI2
00410		XCT "-",CTY
00420		MOVNS A
00430	PRINI2:	SKIPE %NOPOINT(S)	;*** NEW CODE TO PROVIDE OCTAL POINT
00440		JRST PRINI3
00450		MOVEI B,"."-"0"
00460		CAIN C,TEN
00470		JRST .+4
00480		CAIE C,10
00490		JRST PRINI3
00500		MOVEI B,"Q"-"0"
00510		HRLM B,(P)
00520		PUSH P,PRINI4
00530	PRINI3:	LSHC A,-↑D35		;*** USE DIV FOR 1ST DIVIDE IN CASE
00540		LSH B,-1		;*** 36 BITS OF SIGNIFICANCE
00550		DIVI A,0(C)		;***
00560		JRST .+2		;***
00570		IDIVI A,0(C)
00580		HRLM B,(P)
00590		SKIPE A
00600		PUSHJ P,.-3
00610	PRINI4:	JRST FP7A1
00620	
00630	PRINN:	HLRZ A,(A)
00640		MOVEI C,2(SP)
00650		PUSHJ P,PNAMU3
00660		PUSH C,[0]
00670		HRLI C,(POINT 7,0,35)
00680		HRRI C,2(SP)
00690		ILDB A,C
00700		JUMPE A,CPOPJ		;special case of null character
00710		LDB B,RATFLD		;*** SEE IF THIS CHAR STARTS A STRING
00720		CAIN B,STRBEG		;***
00730		JRST PSTR	;string
00740	PRIN2X:	LDB B,[POINT 1,CHRTAB(A),1]
00750		JUMPL R,PRIN4	;never slash
00760		JRST PRIN2(B)	;1 for no slash
00770	
00780	PRIN3:	SKIPL CHRTAB(A)	;<0 for no slash
00790	PRIN2:	JRST PRINSL	;*** GO PRINT A SLASH OR ITS EQUIVALENT
00800	PRIN4:	PUSHJ P,(R)
00810		ILDB A,C
00820		JUMPN A,@PRIN5#
00830		POPJ P,
00840	
00850	PRINSL:	MOVE A,SLASHC	;*** GET MOST RECENTLY-USED SLASH CHARACTER
00860		PUSHJ P,(R)
00870		LDB A,C
00880		JRST PRIN4
00890	REMOTE<
00900	SLASHC:	"/">
00910	
00920	PSTR:	LDB B,[POINT 7,(C),13]	;*** GET THE SECOND CHARACTER OF THE PNAME
00930		JUMPE B,PRIN2X		;*** IF NOT THERE THIS IS /", NOT A STRING
00940	PSTR3:	SKIPL R		;dont print " if no slashify
00950	PSTR2:	PUSHJ P,(R)
00960		ILDB A,C
00970		LDB B,STRFLD		;*** SEE IF THIS CHAR ENDS A STRING
00980		CAIE B,STREND		;***
00990		JUMPN A,PSTR2
01000		JUMPN A,PSTR3
01010		POPJ P,
01020	
01030	TERPRI:	PUSH P,A
01040		MOVEI A,CR
01050		PUSHJ P,TYO
01060		MOVEI A,LF
01070		PUSHJ P,TYO
01080		JRST POPAJ
01090	
01100	CTY:	JSA A,TYOI
01110	REMOTE<
01120	TYOI:	X
01130		JRST TYOI2>
01140	TYOI2:	PUSH P,A
01150		LDB A,[POINT 6,-1(A),ACFLD]
01160		PUSHJ P,(R)
01170		POP P,A
01180		JRA A,(A)
01190	
01200	PRINO:	MOVE A,(A)
01210		CLEARB B,C
01220		JUMPG A,FP1
01230		JUMPE A,FP3
01240		MOVNS A
01250		XCT "-",CTY
01260	FP1:	CAMGE A,FT01
01270		JRST FP4
01280		CAML A,FT8
01290		AOJA B,FP4
01300	
01310	FP3:	MULI A,400
01320		ASHC B,-243(A)
01330		MOVE A,B
01340		CLEARM FPTEM#
01350		PUSHJ P,FP7
01360		XCT ".",CTY
01370		MOVNI T,8
01380		ADD T,FPTEM
01390		MOVE B,C
01400	
01410	FP3A:	MOVE A,B
01420		MULI A,TEN
01430		PUSHJ P,FP7B
01440		SKIPE B
01450		AOJL T,FP3A
01460		POPJ P,
01470	
01480	FP4:	MOVNI C,6
01490		MOVEI TT,0
01500	FP4A:	ADDI TT,1(TT)
01510		XCT FCP(B)
01520		TRZA TT,1
01530		FMPR A,@FCP+1(B)
01540		AOJN C,FP4A
01550		PUSH P,TT
01560		MOVNI B,-2(B)
01570		DPB B,[POINT 2,FP4C,34]
01580		PUSHJ P,FP3
01590		MOVEI A,"E"
01600		PUSHJ P,(R)
01610		MOVE A,FP4C#
01620		IORI A,51
01630		PUSHJ P,(R)
01640		POP P,A
01650	FP7:	JUMPE A,FP7A1
01660		IDIVI A,TEN
01670		AOS FPTEM
01680		HRLM B,(P)
01690		JUMPE A,FP7A1
01700		PUSHJ P,FP7
01710	
01720	FP7A1:	HLRE A,(P)
01730	FP7B:	ADDI A,"0"
01740		JRST (R)
01750	
01760		353473426555	;1e32
01770		266434157116	;1e16
01780	FT8:	1.0E8
01790		1.0E4
01800		1.0E2
01810		1.0E1
01820	FT:	1.0E0
01830		026637304365	;1e-32
01840		113715126246	;1e-16
01850		146527461671	;1e-8
01860		163643334273	;1e-4
01870		172507534122	;1e-2
01880	FT01:	175631463146	;1e-1
01890	FT0:
01900	FCP:	CAMLE A,FT0(C)
01910			CAMGE A,FT(C)
01920		XWD C,FT0
01930	
01940		PAGE
     
00010		SUBTTL SUPER FAST TABLE DRIVEN READ 	14-MAY-69      
00020	
00030	;magic scanner table bit definitions
00040	
00050	;bit 0=0 iff slashified as nth id character
00060	;bit 1=0 iff slashified as 1st id character
00070	;bits 2-5	ratab index (scanning for atom)
00080	;bits 6-8	dotab (and numfld) index (after dot or in number)
00090	;bits 9-10	strtab index (in string)
00100	;bits 11-13	idtab index (in atomic symbol)
00110	;bits 14-16	exptab index (in exponent)
00120	;bits 17-19	rdtab index (type of delimiter)
00130	;bits 20-25	ascii to radix 50 conversion
00140	
00150	REMOTE<
00160	IGSTRT:	IGCRLF
00170	IGEND:	LF
00180	
00190	RATFLD:	POINT 4,CHRTAB(A),5
00200	STRFLD:	POINT 2,CHRTAB(A),10
00210	IDFLD:	POINT 3,CHRTAB(A),13
00220	>
00230	DOTFLD:
00240	NUMFLD:	POINT 3,CHRTAB(A),8
00250	EXPFLD:	POINT 3,CHRTAB(A),16
00260	RDFLD:	POINT 3,CHRTAB(A),19
00270	R50FLD:	POINT 6,CHRTAB(A),25
00280	
00290	;magic state flags in t
00300	EXP==1		;exponent 
00310	NEXP==2		;negative exponent
00320	SAWDOT==4	;saw a dot (.)
00330	MINSGN==10	;negative number
00340	SAWQ==20	;*** SAW A Q (OCTAL POINT)
00350	
00360	IDCLS==0	;identifier
00370	STRCLS==1	;string
00380	NUMCLS==2	;number
00390	DELCLS==3	;delimiter
00400	
00410	PAGE
     
00010	;macros for scanner table
00020	
00030	DEFINE RAD50 (X)<
00040	IFB <X>,<R50VAL=0>
00050	IFLE <"X"-"9">,<IFGE <"X"-"0">,<R50VAL="X"-"0"+1>>
00060	IFIDN <"X"><".">,<R50VAL=45>
00070	IFGE <"X"-"A">,<R50VAL="X"-"A"+13>>
00080	
00090	DEFINE TABIN (S1,SN,R,D,S,I,E,RD,R50)<
00100	XLIST
00110	IRPC R50<	RAD50 (R50)
00120		BYTE (1)S1,SN(4)R(3)D(2)S(3)I,E,RD(6)R50VAL>
00130	LIST>
00140	
00150	DEFINE LET (X)<
00160	TABIN (1,1,5,2,3,4,2,0,X)>
00170	
00180	DEFINE DELIMIT (X,Y)<
00190	TABIN (0,0,2,2,3,2,2,Y,X)>
00200	
00210	DEFINE IGNORE (X)<
00220	TABIN (0,0,3,2,3,2,2,0,X)>
00230	PAGE
     
00010	REMOTE<CHRTAB:
00020	TABIN (0,0,1,1,1,1,1,0,< >)	
00030	;null
00040	LET (<        >)
00050	IGNORE (<     >)		
00060	;tab,lf,vtab,ff,cr
00070	LET (<           >)	
00080	;16 to 30
00090	TABIN (0,0,0,0,0,0,0,0,< >)
00100	;igmrk
00110	TABIN (0,0,0,0,0,0,0,0,< >)
00120	;32 THE OLD IGMRK, WILL ALLOW THE CHAR. TO WORK ON READS BUT NOT TYI
00130		IFE	ALTMOD-33 <
00140		DELIMIT (< >,3)
00150	>			;%% NEW ALTMODE (5S06 MONITOR)
00160		IFN	ALTMOD-33 <
00170		LET (< >)
00180	>			;%% OLD ALTMODE (5S04 OR EARLIER MONITOR)
00190	LET (<    >)
00200	;## 34 TO 37
00210	IGNORE (< >)			
00220	;space
00230	LET (< >)			
00240	;!
00250	TABIN (0,0,9,2,2,2,2,0,< >)	
00260	;"
00270	LET (< $%  >)			
00280	;#$%&'
00290	DELIMIT (< >,0)
00300	DELIMIT (< >,1)
00310	;()
00320	LET (< >)			
00330	;*
00340	TABIN (1,1,14,2,3,4,2,0,< >)	
00350	;+
00360	IGNORE (< >)			
00370	;,
00380	TABIN (1,1,6,2,3,4,2,0,< >)	
00390	;-
00400	TABIN (0,0,7,3,3,2,2,4,<.>)
00410	TABIN (0,0,4,2,3,3,2,0,< >)	
00420	;/
00430	TABIN (1,0,8,5,3,4,3,0,<0123456789>)
00440	LET (<      >)			
00450	;:;<=>?
00460	TABIN (1,0,2,2,3,4,2,5,< >)	
00470	;@
00480	LET (<ABCD>)
00490	TABIN (1,1,5,4,3,4,2,0,<E>)
00500	LET (<FGHIJKLMNOP>)
00510	;*** SPECIAL ENTRY FOR Q = OCTAL POINT
00520	TABIN (1,1,5,6,3,4,2,0,<Q>)
00530	LET (<RSTUVWXYZ>)
00540	DELIMIT (< >,2)			
00550	;[
00560	LET (< >)			
00570	;\
00580	DELIMIT (< >,3)			
00590	;]
00600	LET (<   >)			
00610	;↑←`
00620	LET (<ABCDEFGHIJKLMNOPQRSTUVWXYZ>)	
00630	;lower case
00640	LET (<  >)			
00650	;{|
00660		IFE	ALTMOD-175 <
00670		DELIMIT (< >,3)			
00680	>		;%% OLD ALTMODE (5S04 MONITOR)
00690		IFN	ALTMOD-175 <
00700		LET (< >)
00710	>		;%% ⎇ - ORDINARY CHARACTER (5S06 MONITOR)
00720		LET (< >)
00730			;}
00740		DELIMIT (< >,6)			
00750			;rubout
00760	>
00770	PAGE
     
00010	READCH:	PUSHJ P,TYI
00020		MOVSI AR1,AR1
00030		PUSHJ P,EXPL1
00040		JRST CAR
00050	
00060	READP1:	SETZM NOINFG
00070	READ0:	PUSH P,TYI2
00080		PUSH P,OLDCH
00090		SETZM OLDCH#
00100		HRLI A,(JRST)
00110		MOVEM A,TYI2
00120		PUSHJ P,READ+1
00130		POP P,OLDCH
00140		POP P,TYI2
00150		POPJ P,
00160	
00170	RDNAM:	SETOM	NOINFG		;## READ ROUTINE THAT DOES NOT INTERN
00180		JRST	READ+1		;##
00190	
00200	RDRUB:	MOVEI A,CR
00210		PUSHJ P,TTYO
00220		MOVEI A,LF
00230		PUSHJ P,TTYO
00240		SKIPA P,PSAV#
00250	READ:	SETZM NOINFG#	;0 means intern
00260		SETZM EDFLAG	;*** CLEAR AUTO EDIT FLAG
00270		SETOM TLKFLG	;*** SET TO DO A TALK IF TTY READ
00280		MOVEM P,PSAV
00290		PUSHJ P,READ1
00300		SETZM PSAV
00310		SETZM INREAD		;WMT-CLEAR INDICATOR THAT YOU'RE IN READ
00320		SKIPN EDFLAG	;*** AUTO EDIT KEY STRUCK?
00330		POPJ P,
00340		PUSHJ P,QTIFY	;*** YES: CONSTRUCT (EDITEXPR @exp)
00350		PUSHJ P,NCONS
00360		MOVEI B,EDITEXPR(S)
00370		PUSHJ P,XCONS
00380		JRST EVAL	;*** AND GO EDIT EXPR BEFORE RETURNING IT
00390	
00400	READ1:	PUSHJ P,RATOM
00410		POPJ P,		;atom
00420		XCT RDTAB2(B)
00430		JRST READ1	;try again
00440	
00450	RDTAB2:	JRST READ2	;0	(
00460		JFCL		;1	)
00470		JRST READ4	;2	[
00480		JFCL		;3	],$
00490		JFCL		;4	.
00500		JRST RDQT	;5	@
00510	
00520	READ2:	SETOM INREAD		;WMT-NOTE THAT YOU'RE IN READ
00530		PUSHJ P,RATOM
00540		JRST READ2A	;atom
00550		XCT RDTAB(B)
00560	
00570	READ2A:	PUSH P,A
00580		PUSHJ P,READ2
00590		JRST POPBXC
00600	
00610	RDTAB:	PUSHJ P,READ2	;0	(
00620		JRST FALSE	;1	)
00630		PUSHJ P,READ4	;2	[
00640		JRST READ5	;3	],$
00650		JRST RDT	;4	.
00660		PUSHJ P,RDQT	;5	@
00670	
00680	RDTX:	PUSHJ P,RATOM
00690		POPJ P,	;atom
00700		XCT RDTAB2(B)
00710		JRST DOTERR	;dot context error
00720	
00730	RDT:	PUSHJ P,RDTX
00740		PUSH P,A
00750		PUSHJ P,RATOM
00760		JRST DOTERR
00770		CAIN B,1
00780		JRST POPAJ
00790		CAIE B,3
00800		JRST DOTERR
00810		MOVEM A,OLDCH
00820		JRST POPAJ
00830	
00840	
00850	READ4:	PUSHJ P,READ2
00860		MOVE B,OLDCH
00870		CAIE B,ALTMOD
00880	TYI1:	SETZM OLDCH	;kill the ]
00890		POPJ P,
00900	
00910	READ5:	MOVEM A,OLDCH	;save ] or $
00920		JRST FALSE	;and return nil
00930	
00940	
00950	RDQT:	PUSHJ P,READ1
00960		JRST QTIFY
00970	PAGE
     
00010	;atom parser
00020	
00030	COMMENT: PUSHJ P,TYID
00040		CAME A,IGEND
00050		JRST COMMENT
00060		POPJ P,
00070	
00080	RATOM:	SKIPE SMAC#	;$$ CHECK FOR A SPLICE MACRO LIST
00090		JRST PSMAC	;$$ GET ITEM FROM SPLICE MACRO LIST
00100		SETZB T,R
00110		HRLI C,(POINT 7,0,35)
00120		HRRI C,(SP)
00130		MOVEM C,ORGSTK#		;SAVE FOR BACKING UP ON + AND -
00140		MOVEI AR1,1
00150	RATOM2:	PUSHJ P,TYIA
00160		LDB B,RATFLD
00170		JRST RATAB(B)
00180	
00190	SLCHAR==4	;*** SLASH ENTRY FOR MODCHR
00200	STRBEG==↑D9	;*** STRING START FOR PRINT
00210	RATAB:	PUSHJ P,COMMENT	;0	comment
00220		JRST RATOM2	;1	null
00230		JRST RATOM3	;2	delimit
00240		JRST RATOM2	;3	ignore
00250		PUSHJ P,TYI	;4	/
00260		JRST RDID	;5	letter
00270		JRST RDNMIN	;6	-
00280		JRST RDOT	;7	.
00290		JRST RDNUM	;8	digit
00300		JRST RDSTR0	;9	string
00310		JRST RMACRO	;10	MACRO
00320		JRST SMACRO	;11	SPLICE MACRO
00330		JRST RDNPLS	;12	+
00340	
00350	;a real dotted pair
00360	RDOT2:	MOVEM A,OLDCH
00370		MOVE A,ORGSGN	;ORGSGN NORMALLY CONTAINS A "." AT THIS POINT
00380	RATOM3:	LDB B,RDFLD
00390		HRRI R,DELCLS	;delimiter
00400		AOS (P)		;non-atom (ie a delimiter)
00410		POPJ P,
00420	
00430	;dot handler
00440	RDOT:	MOVEM A,ORGSGN	;INCASE SOMETHING ELSE DEFINED AS "."
00450		PUSHJ P,TYID
00460		LDB B,DOTFLD
00470		JRST DOTAB(B)
00480	
00490	DOTAB:	PUSHJ P,COMMENT	;0	comment
00500		JRST RDOT+1	;1	null
00510		JRST RDOT2	;2	delimit
00520		JRST RDOT2	;3	dot
00530		JRST RDOT2	;4	e
00540		JRST .+2	;5	digit
00550		JRST RDOT2	;6	Q (***)
00560		MOVEI B,0
00570		IDPB B,C
00580		TLO T,SAWDOT
00590		JRST RDNUM
00600	PAGE
     
00010	;string scanner
00020	STREND==2	;*** STRING DELIMITER FOR PRINT
00030	RDSTR0:	PUSH P,%TTYUC(S)	;WMT-SAVE %TTYUC
00040		SETZM %TTYUC(S)		;WMT-CLEAR TO ZERO
00050		JRST RDSTR		;WMT
00060	STRTAB:	PUSHJ P,COMMENT	;0	comment
00070		JRST RDSTR+1	;1	null
00080		JRST STR2	;2	delimit
00090	RDSTR:	IDPB A,C	;3	string element
00100		PUSHJ P,TYID
00110		LDB B,STRFLD
00120		JRST STRTAB(B)
00130	
00140	STR2:	POP P,%TTYUC(S)	;WMT-RESTORE %TTYUC
00150		HRRI R,STRCLS	;string
00160		IDPB A,C
00170		SKIPE INTSTR(S)	;*** ARE WE INTERNING STRINGS?
00180		JRST MAKID+1	;*** YES
00190	NOINTR:	PUSHJ P,IDEND	;no intern
00200		PUSHJ P,IDSUB
00210		JRST PNAMAK
00220	
00230	
00240	;identifier scanner
00250	IDTAB:	PUSHJ P,COMMENT	;0	
00260		JRST RDID+1	;1	null
00270		JRST MAKID	;2	delimit
00280		PUSHJ P,TYI	;3	/
00290	RDID:	IDPB A,C	;4	letter or digit
00300		PUSHJ P,TYID
00310		LDB B,IDFLD	
00320		JRST IDTAB(B)
00330	PAGE
     
00010	;LINEREAD - RETURNS ALL THE EXPRESSIONS ON ONE LINE AS A LIST
00020	;
00030	LINRD:	JUMPE	T,LINRD1	;WMT- DO INITIAL READ IF NO ARGS
00040		MOVE	A,0(P)		;WMT- GET FIRST ARG
00050		MOVNS	T
00060		HRLI	T,(T)
00070		SUB	P,T		;WMT- MAKE STACK RIGHT
00080		JUMPE	A,LINRD1	;WMT- DO INITIAL READ IF ARG=NIL
00090		CLRBFI			;WMT- CLEAR FROM PREVIOUS INPUT
00100		SETZB	B,SMAC		;WMT- CLEAR SPLICE INPUT
00110		JRST	LRTY		;WMT- GO INPUT A CHARACTER
00120	LINRD1:	PUSHJ	P,READ
00130		HRRZ	B,A
00140		SKIPE	SMAC		;CHECK THE SPLICE LIST
00150		JRST	LRMORE
00160		SKIPN	A,OLDCH
00170	LRTY:	PUSHJ	P,TYID		;NEED A CHARACTER
00180		MOVEM	A,OLDCH		;SAVE IT
00190		LDB	C,RATFLD	;THIS KLUDGE IS TO AVOID MAKING ANOTHER TABLE ENTRY
00200		CAIN	C,7		;SPECIAL CHECK FOR "."
00210		JRST	LRTY1		;IGNORE IT
00220		CAILE	C,3		;ELIMINATE MOST POSSIBILITIES
00230		JRST	LRMORE		;MORE ON THE LINE
00240		JUMPE	C,LREND		;END LINE ON COMMENT - THINK ABOUT IT, ITS RIGHT
00250		LDB	C,RDFLD
00260		JRST	LR1(C)
00270	LR1:	JRST	LPIG		;0	MORE TO FIGURE OUT
00280		JRST	LRTY1		;1	IGNORE
00290		JRST	LRMORE		;2	MORE ON THE LINE
00300		SUBI	A,ALTMOD	;3	CHECK ALTMOD
00310		JUMPN	A,LRTY1		;4	IGNORE "]" AND "."
00320		JUMPN	A,LRMORE	;5	MORE ON "@"
00330		JRST	LREND
00340	LPIG:	CAIN	A,"("		;THESE SPECIAL CHECK COULD SCREW UP READ MACROS
00350		JRST	LRMORE
00360		CAIE	A,TAB
00370		CAIL	A,40		;READ MORE IF SPACE, COMMA, OR TAB
00380		JRST [	HRLI B,-1	;SET SPQCE FLAG AND TRY AGAIN
00390			JRST LRTY]
00400		CAIE	A,CR		;ALWAYS IGNORE CR.S
00410		TLZE	B,-1		;EOL - IF SPACE FLAG THEN DO A PEEKC
00420		JRST	LRTY
00430	LREND:	HRRZ	A,B		;FINALLY GOT THERE
00440	;	SETZM	OLDCH		;WMT- EAT THE BREAK CHARACTER
00450	;WMT-  I DON'T KNOW WHY I HAD THAT INSTRUCTION THERE.
00460		JRST	NCONS
00470	LRMORE:	HRLI	B,0
00480		PUSH	P,B		;MORE TO GO, PUSH
00490		PUSHJ	P,LINRD1	;AND CALL YOURSELF
00500		JRST	POPBXC
00510	LRTY1:	HRLI	B,0		;CLEAR SPACE FLAG
00520		JRST	LRTY
00530	
00540	PAGE
     
00010		;## FUNCTIONS TO READ A FILE.EXT
00020		;## READ A FILE.EXT FROM THE UFD
00030	
00040	FLTYIA:	XCT	TYI2		;## GET NEXT WORD, IGNORE OLDCH
00050		JRST	[SETZ AR1,
00060			 JRST TYI2X ]	;%% INPUT SOME MORE, CLEARING TEST REG.
00070		ILDB	A,@TYI3		;## AND LOAD WORD
00080		POPJ	P,
00090	
00100	
00110	RDFIL1:	PUSHJ	P,FLTYIA	;##  FILE NAME NOT THERE, SKIP OVER EXT
00120	RDFILE:	SETZM	NOINFG		;## ## INTERN
00130		PUSHJ	P,FLTYIA		;## GET FILE NAME WORD
00140		PUSHJ	P,SIXATM	;## MAKE IT AN ATOM
00150		JUMPL	A,RDFIL1	;## A=-1 IF EMPTY 
00160		PUSH	P,A
00170		PUSHJ	P,FLTYIA		;## GET EXTENSION
00180		HRRI	A,0		;## CLEAR RH
00190		PUSHJ	P,SIXATM
00200		JUMPL	A,POPAJ		;## NO EXTENSION, RETURN 
00210	POPBXC:	POP	P,B		;## GET FILE BACK
00220		JRST	XCONS		;## RETURN FILE.EXT
00230	
00240	SIXCAT:	;WMT-MAKES A DEVICE NAME FROM  LEFT JUSTIFIED SIXBIT
00250		MOVE B,[POINT 6,A]	;WMT-GO THROUGH EACH CHAR
00260		ILDB C,B
00270		JUMPN C,.-1		;WMT- UNTIL YOU GET TO END
00280		MOVEI C,':'		;WMT-LOAD A COLON
00290		DPB C,B			;WMT- INTO NEXT POSITION
00300	;	JRST SIXATM		;WMT- AND MAKE ATOM
00310	; FALLS THROUGH
00320	
00330		;## ROUTINE TO TAKE ONE WORD OF SIXBIT AND MAKE IT AN ATOM
00340		;## IGNORES TRAILING BLANKS, BUT INCLUDES INSERTED BLANKS. NO
00350		;## READ MACROS, ETC.
00360	
00370	SIXATM:	SKIPN	B,A
00380		JRST	SXATER		;## INDICATE WORD EMPTY
00390		MOVEI	T,5		;##  OF CHS PERMISSIBLE IN FULL WORD
00400					;## NAME T=0 IF FIRST WORD DONE
00410		MOVE	AR1,[POINT 6,B,5]	;## AR1 HAS PTR TO LOAD BYTE
00420						;## FROM B TO C
00430		PUSHJ	P,SIXAT1	;## MAKE THE PNAME LIST
00440		PUSHJ	P,NCONS
00450		MOVEI	B,PNAME(S)	;## MAKE PNAME
00460		PUSHJ	P,XCONS
00470		PUSHJ	P,ACONS		;## VOILA,  AN  ATOM
00480		SKIPE	NOINFG		;## NOINFG=0 MEANS INTERN
00490		POPJ	P,
00500		JRST	INTERN
00510	
00520	SXATER:	SETO	A,		;## RETURN -1 IN A IF B EMPTY
00530		POPJ	P,
00540	SIXAT1:	MOVE	AR2A,[POINT  7,0,35]	;## POINTER TO MOVE C TO  A
00550		SETZ	A,		;## CLEAR A
00560	SIXAT2:	SETZ	C,
00570		JUMPE	B,SIXDON	;## DONE IF B EMPTY
00580		LDB	C,AR1
00590		LSH	B,6		;## LEFT SHIFT B, REMAINING CH'S IN B
00600		HRRI	C,40(C)		;## ADD 40  TO C
00610		IDPB	C,AR2A		;## PUT  IT IN  A
00620		SOJG	T,SIXAT2	;## IF T>0, STILL IN FIRST WORD OF PNAME
00630	SIXAT3:	PUSHJ	P,FWCONS
00640		PUSH	P,A
00650		JRST	SIXAT1		;## TRY FOR THAT SIXTH CH.
00660	SIXDON:	JUMPN	A,SIXAT3	;## IF A NOT EMPTY, DO ANOTHER FWCONS AND
00670					;## END UP HERE WITH A=0.
00680		POP	P,A
00690		PUSHJ	P,NCONS
00700		JUMPGE	T,CPOPJ		;## IF T>=0, THEN ONLY ONE WORD
00710		JRST	POPBXC		;## DONE
00720		PAGE
     
00010	;NEW AND SUPER BITCHEN READ MACROS
00020	;
00030	RMACRO:
00040		IFN ALVINE,<
00050		SKIPE PSAV1	;$$ ARE WE IN ALVINE?
00060		JRST RATOM2	;$$ YES, IGNORE>
00070	RMAC2:	IDPB A,C	;$$ CONVERT THE CHAR. TO AN ATOM
00080		PUSHJ P,IDEND	;$$
00090		PUSHJ P,INTER0	;$$
00100		MOVEM A,T	;$$ SAVE ATOM IN CASE OF ERROR
00110		MOVEI B,READMACRO(S)	;$$ GET THE FUNCTION NAME
00120		PUSHJ P,GET	;$$
00130		JUMPE A,RMERR	;$$ UNDEFINED READ MACRO
00140		PUSHJ P,NCONS	;$$ CONVERT TO A FORM
00150		PUSH P,PSAV	;$$
00160		PUSHJ P,EVAL	;$$ EVALUATE THE FORM
00170		POP P,PSAV	;$$
00180		POPJ P,	;$$ RETURN
00190	
00200	;SPECIAL PROCESSING OF SPLICE MACROS
00210	SMACRO:
00220	IFN ALVINE,<
00230		SKIPE PSAV1	;$$ ARE WE IN ALVINE?
00240		JRST RATOM2	;$$ YES, IGNORE>
00250		PUSHJ P,RMAC2	;$$ EVALUATE THE MACRO
00260		MOVEM A,SMAC	;$$ SAVE THE SPLICE LIST
00270		JRST RATOM	;$$ START OVER
00280	
00290	;GET AN ITEM OFF OF THE SPLICE LIST
00300	PSMAC:	MOVE A,SMAC	;$$
00310		PUSHJ P,ATOM	;$$ IS SPLICE LIST AN ATOM?
00320		JUMPN A,[	MOVE A,SMAC	;$$ YES, SIMULATE . <ATOM>
00330				PUSHJ P,NCONS	;$$
00340				MOVEM A,SMAC	;$$
00350				MOVEI B,4	;$$
00360				JRST RATOM3+1]	;$$
00370		MOVE B,@SMAC	;$$
00380		HLRZ A,B	;$$ RETURN NEXT ITEM OF SPLICE LIST
00390		HRRZM B,SMAC	;$$ ADVANCE SPLICE LIST
00400		POPJ P,	;$$ RETURN
00410		PAGE
     
00010	;number scanner
00020	NUMTAB:	PUSHJ P,COMMENT	;0	comment
00030		JRST RDNUM+1	;1	null
00040		JRST NUMAK	;2	delimit
00050		JRST RDNDOT	;3	dot
00060		JRST RDE	;4	e
00070		JRST RDNUM	;5	digit
00080		JRST RDQ	;6	Q (***)
00090	RDNUM:	IDPB A,C
00100		PUSHJ P,TYID
00110		LDB B,NUMFLD
00120		JRST NUMTAB(B)
00130	
00140	RDNDOT:	TLOE T,SAWDOT
00150		JRST NUMAK	;two dots - delimit
00160		MOVEI A,0
00170		JRST RDNUM
00180	
00190	RDQ:	TLNE T,SAWDOT		;*** SAW A Q - IS IT OCTAL POINT?
00200		JRST NUMAK		;*** NO - DELIMITER
00210		TLO T,SAWQ		;*** YES
00220		PUSHJ P,TYID		;*** GO GET DELIMITER
00230		JRST NUMAK		;*** AND MAKE NUMBER
00240	
00250	RDNMIN:	TLO T,MINSGN
00260	RDNPLS:	MOVEM A,ORGSGN#		;SAVE SIGN IN CASE OF BACKUP
00270		JRST RDNUM+1
00280	
00290	;exponent scanner
00300	RDE:	CAME	C,ORGSTK	;FOR +E AND -E TYPE OF ATOMS
00310		JRST	.+3
00320		MOVEM	A,OLDCH
00330		JRST	KLDG1
00340		TLO T,EXP
00350		MOVEI A,0
00360		IDPB A,C
00370		PUSHJ P,TYID
00380		CAIN A,"-"
00390		TLOA T,NEXP
00400		CAIN A,"+"
00410		JRST RDE2+1
00420		JRST RDE2+2
00430	
00440	EXPTAB:	PUSHJ P,COMMENT	;0
00450		JRST RDE2+1	;1	null
00460		JRST NUMAK	;2	delimit
00470	RDE2:	IDPB A,C	;3	digit
00480		PUSHJ P,TYID
00490		LDB B,EXPFLD
00500		JRST EXPTAB(B)
00510	PAGE
     
00010	;semantic routines
00020	;identifier interner and builder
00030	
00040	IDEND:	TDZA A,A
00050	IDEND1:	IDPB A,C
00060		TLNE C,760000
00070		JRST IDEND1 
00080		POPJ P,
00090	
00100	MAKID:	MOVEM A,OLDCH
00110		SKIPE NOINFG
00120		JRST NOINTR	;dont intern it
00130		PUSHJ P,IDEND	;*** (MOVED FROM JUST AFTER MAKID)
00140	INTER0:	PUSHJ P,IDSUB
00150		PUSHJ P,INTER1	;is it in oblist
00160		POPJ P,		;found
00170		PUSHJ P,PNAMAK	;not there
00180	MAKID2:	MOVE C,CURBUC#	;
00190		HLRZ B,@RHX2
00200		PUSHJ P,CONS	;cons it into the oblist
00210		HRLM A,@RHX2
00220		JRST CAR
00230	
00240	;pname unmaker
00250	PNAMUK:
00260		MOVEI B,PNAME(S)
00270		PUSHJ P,GET
00280		JUMPE A,NOPNAM
00290		MOVE C,SP
00300	PNAMU3:	HLRZ B,(A)
00310		PUSH C,(B)
00320		HRRZ A,(A)
00330		JUMPN A,PNAMU3 
00340		POPJ P,
00350	
00360	;idsub constructs a iowd pointer for a print name
00370	IDSUB:	HRRZS C
00380		CAML C,JRELO	;top of spec pdl
00390		JRST SPDLOV
00400		MOVNS C
00410		ADDI C,(SP)
00420		HRLI C,1(SP)
00430		MOVSM C,IDPTR#
00440		POPJ P,
00450	
00460	PAGE
     
00010	;identifier interner
00020	INTER1:	MOVE B,1(SP)	;get first word of pname 
00030		LSH B,-1	;right justify it 
00040		IDIV B,INT1	;compute hash code 
00050	REMOTE<
00060	INT1:	BCKETS
00070	RHX2:
00080	XXX1:	XWD B+1,OBTBL>
00090		PUSH P,C		;## SAVE C
00100		HRRZ	C,VOBLIST(S)	;## THIS GETS THE CURRENT VALUE OF OBLIST(THE ATOM)
00110		HRRM	C,RHX2	;## ASSUMES THAT ALL REFERENCE TO OBLIST GOES
00120		HRRM	C,RHX5	;## IE INTERN, REMOB ETC GOES THROUGH THIS SECTION.
00130		POP P,C		;##RHX2 AND RHX5 ARE HOPEFULLY THE ONLY TWO WORDS
00140				;##WHICH ARE USED TO REFERENCE TABLE 3/28/73
00150		HLRZ TT,@RHX2	;get bucket 
00160		MOVEM B+1,CURBUC	;save bucket number 
00170		MOVE T,TT 
00180		JRST MAKID1
00190	
00200	MAKID3:	MOVE TT,T	;save previous atom 
00210		HRRZ T,(T)	;get next atom 
00220	MAKID1:	JUMPE T,CPOPJ1	;not in oblist
00230		HLRZ A,(T)	;next id in oblist
00240		PUSHJ P,CMPNAM	;*** GO COMPARE PNAMES
00250		JRST MAKID3	;*** NOT THE SAME - TRY NEXT
00260		HLRZ A,(T)	;this is it
00270		HLRZ B,(TT) 
00280		HRLM A,(TT) 	;(*** BUBBLE TOWARDS FRONT)
00290		HRLM B,(T) 
00300		POPJ P,
00310	
00320	;*** PNAME COMPARER
00330	CMPNAM:	MOVEI	B,PNAME(S)	;## USE GET FOR GETTING PNAME
00340		PUSHJ	P,GET		;## (GET ATOM @PNAME)
00350		JUMPE	A,NOPNAM	;## NO PRINT NAME
00360		MOVE C,IDPTR	;found pname
00370	CMPNM1:	JUMPE A,CPOPJ	;not the one
00380		MOVS A,(A)
00390		MOVE B,(A)
00400		ANDCAM AR1,(C)	;clear low bit
00410		CAME B,(C)
00420		JRST CPOPJ	;not the one
00430		HLRZ A,A	;ok so far
00440		AOBJN C,CMPNM1
00450		JUMPE A,CPOPJ1	;PNAMEs match
00460		POPJ P,		;not the one
00470	
00480		PAGE
     
00010	;pname builder
00020	PNAMAK:	MOVE T,IDPTR
00030		PUSHJ P,NCONS
00040		MOVE TT,A
00050		MOVE C,A
00060	PNAMB:	MOVE A,(T)
00070		TRZ A,1		;clear low bit!!!!!
00080		PUSHJ P,FWCONS
00090		PUSHJ P,NCONS
00100		HRRM A,(TT)
00110		MOVE TT,A
00120		AOBJN T,PNAMB
00130		MOVE A,C
00140		HRLZS (A)
00150		JRST PNGNK1+1
00160	PAGE
     
00010	;number builder
00020	NUMAK:	MOVEM A,OLDCH
00030		HRRI R,NUMCLS	;number
00040		CAME C,ORGSTK	;BIG KLUDGE FOR + AND -
00050		JRST .+5
00060	KLDG1:	MOVE A,ORGSGN	;ENTER HERE TO BACK UP IN THE CASE OF +E OR -E
00070		IDPB A,C
00080		PUSHJ P,TYIA
00090		JRST RDID+2
00100		MOVEI A,0
00110		IDPB A,C
00120		IDPB A,C
00130		HRRZS C
00140		CAML C,JRELO	;top of spec pdl
00150		JRST SPDLOV
00160		MOVSI C,(POINT 7,0,35)
00170		HRRI C,(SP)
00180		TLNE T,SAWDOT+EXP
00190		JRST NUMAK2	;decimal number or flt pt
00200		MOVE A,VIBASE(S)	;ibase integer
00210		SUBI A,INUM0
00220		TLNE T,SAWQ		;*** CHECK IF OCTAL POINT SEEN
00230		MOVEI A,10		;*** YES: BASE = 8
00240		PUSHJ P,NUM
00250	NUMAK4:
00260		MOVEI B,FIXNUM(S)
00270	NUMAK6:	TLNE T,MINSGN
00280		MOVNS A
00290		JRST MAKNUM
00300	
00310	NUMAK2:	PUSHJ P,NUM10
00320		MOVEM A,TT
00330		TLNN T,SAWDOT
00340		JRST [	PUSHJ P,FLOAT	;flt pt without fraction
00350			MOVE TT,A
00360			JRST NUMAK3]
00370		SETZ AR2A,		;*** CLEAR NUMBER COUNTER
00380		PUSHJ P,NUM10	;fraction part
00390		EXCH A,TT
00400		TLNN T,EXP
00410		JUMPE AR2A,NUMAK4	;no exponent and no fraction
00420		PUSHJ P,FLOAT
00430		EXCH A,TT
00440		PUSHJ P,FLOAT
00450		MOVEI AR1,FT01
00460		PUSHJ P,FLOSUB
00470		FMPR A,B
00480		FADRM A,TT
00490	NUMAK3:	PUSHJ P,NUM10	;exponent part
00500	IFE BIGNMS<
00510		JFCL 10,.+1	;*** CLEAR THE FLAG>
00520		MOVE AR2A,A
00530		MOVEI AR1,FT-1
00540		TLNE T,NEXP
00550		MOVEI AR1,FT01	;-exponent
00560		PUSHJ P,FLOSUB
00570		FMPR TT,B	;positive exponent
00580		MOVEI B,FLONUM(S)
00590		MOVE A,TT
00600		JFCL 10,FLOOV
00610		JRST NUMAK6
00620	
00630	FLOSUB:	MOVSI B,(1.0)
00640		TRZE AR2A,1
00650		FMPR B,(AR1)
00660		JUMPE AR2A,CPOPJ
00670		LSH AR2A,-1
00680		SOJA AR1,FLOSUB+1
00690	
00700	;variable radix integer builder
00710	;*** CHANGED TO HANDLE 36-BIT INTEGERS (UNLESS BIGNMS SWITCH ON)
00720	;*** ANYTHING OVER 36-BITS IS NOW IGNORED INSTEAD OF CAUSING ERROR
00730	
00740	NUM10:	MOVEI A,TEN
00750	NUM:	HRRM A,NUM1
00760	IFN BIGNMS< JFCL 10,.+1>	;CLEAR FLAG IF CONCERNED ABOUT OVERFLOW
00770		SETZB A,B		;A=NUMBER, B=OVERFLOW
00780	NUM2:	ILDB D,C
00790		JUMPE D,NUM4
00800	IFN BIGNMS< IMUL A,NUM1#>	;IMUL TO CHECK FOR OVERFLOW
00810	IFE BIGNMS<
00820		MUL A,NUM1#		;MUL FOR 36 BITS
00830		EXCH A,B>
00840		ADDI A,-"0"(D)
00850	IFN BIGNMS<
00860	NUM3:	JFCL 10,FIXOV		;bignums change this to jfcl 10,rdbnm>
00870	IFE BIGNMS<
00880		TLZE A,400000		;ADD THE 36TH BIT TO OVERFLOW REG.
00890	;WMT- IS THIS NEXT INSTRUCTION RIGHT??????
00900		AOJ B>
00910		AOJA AR2A,NUM2
00920	NUM4:
00930	IFE BIGNMS<
00940		LSH A,1			;MOVE HI-ORDER BIT INTO RESULT
00950		ROTC A,-1>
00960		POPJ P,
00970	PAGE
     
00010	INTERN:	MOVEM A,AR2A
00020		PUSHJ P,PNAMUK
00030		PUSHJ P,IDSUB
00040		MOVEI AR1,1
00050		PUSHJ P,INTER1		;is it in oblist
00060		POPJ P,			;found it
00070		MOVE A,AR2A		;not there
00080		JRST MAKID2		;put it there
00090	
00100	REMOB:	JUMPE A,FALSE
00110		MOVEI AR1,1
00120		PUSH P,A
00130		HLRZ A,(A)
00140		PUSHJ P,INTERN
00150		HLRZ B,@(P)
00160		CAME A,B
00170		JRST REMOB2
00180		CAIN A,NIL		;*** AVERT POTENTIAL DISASTER
00190		ERR2 [SIXBIT /CAN'T REMOB NIL!/]
00200		HRRZ B,CURBUC
00210	REMOTE<
00220	RHX5:
00230	XXX2:	XWD B,OBTBL>
00240		HLRZ C,@RHX5
00250		HLRZ T,(C)
00260		CAMN T,A
00270		JRST [	HRRZ TT,(C)
00280			HRLM TT,@RHX5
00290			JRST REMOB2]
00300	REMOB3:	MOVE TT,C
00310		HRRZ C,(C)
00320		HLRZ T,(C)
00330		CAME T,A
00340		JRST REMOB3
00350		HRRZ T,(C)
00360		HRRM T,(TT)
00370	REMOB2:	POP P,A
00380		HRRZ A,(A)
00390		JRST REMOB
00400	
00410	;*** ROUTINE TO COMPARE PNAMES FOR EQUALITY WITHOUT INTERNING
00420	EQSTR:	MOVE C,[JUMPE A,EQSTR1]	;WMT- EXTEND EQSTR TO BE LIKE EQUAL
00430		MOVEM C,EQUALX		;WMT- TELL EQUAL TO USE EQSTR
00440		JRST EQUAL0
00450	EQSTR1:	MOVE A,(P)		;WMT- SAVE FOR EQUAL
00460		MOVEM C,(P)		;WMT- SAVE EXIT P
00470		PUSHJ P,PNAMUK		;GET PNAME OF 1ST ARG
00480		PUSHJ P,IDSUB
00490		MOVEI AR1,1
00500		MOVE 1,TT		;WMT- GET SECOND ARGUMENT
00510		PUSHJ P,CMPNAM		;GO DO COMPARE
00520		JRST COMP3A		;WMT- DIFFERENT. GO CLEAN UP
00530		JRST COMP3B		;WMT- SAME. GO ON.
00540		PAGE
     
00010	;ROUTINE TO ALLOW ARBITRARY MODIFICATION AND READING OF THE
00020	;READ CHARACTER-TABLE BY LISP FUNCTIONS
00030	;TAKES TWO ARGUMENTS A,B
00040	;	IF B = NIL IT RETURNS THE CONTENTS OF CHARACTER TABLE
00050	;	LOCATION SPECIFIED BY A
00060	;	OTHERWISE IT CHANGES THE CHARACTER TABLE ENTRY SPECIFIED BY A
00070	;	TO THE BIT PATTERN SPECIFIED BY B, AND RETURNS THE
00080	;	PREVIOUS VALUE
00090	
00100	MODCHR:	PUSH	P,B	;$$SAVE BIT PATTERN FOR TABLE
00110		PUSHJ	P,NUMVAL	;$$GET POSITION IN TABLE
00120		POP	P,B	;$$
00130		MOVE	T,CHRTAB(A)	;$$GET OLD TABLE VALUE
00140		JUMPE	B,MCEXIT	;$$IF B=NIL THEN JUST RETURN OLD TABLE VALUE
00150		PUSH	P,A	;$$SAVE TABLE POSITION
00160	
00170		MOVEI	A,(B)	;$$
00180		PUSHJ	P,NUMVAL	;$$GET NEW BIT PATTERN
00190		POP	P,B	;$$GET TABLE POSITION
00200		MOVEM	A,CHRTAB(B)	;$$CHANGE TABLE
00210		LDB	A,[POINT R,CHRTAB(B),5]	;*** IS THIS A SLASH CHAR?
00220		CAIN	A,SLCHAR		;***
00230		MOVEM	B,SLASHC		;*** SAVE FOR SUBSEQUENT PRINTING
00240	MCEXIT:	MOVE	A,T	;$$RETURN OLD TABLE VALUE
00250		JRST	FIX1A	;$$CONVERT TO BINARY AND EXIT
00260	
00270	;FUNCTION TO DETERMINE THE ASCII VALUE OF A CHARACTER
00280	;	CHRVAL TAKES AN ATOM AS ITS ARGUMENT AND USES THE FIRST
00290	;	CHARACTER OF THE PRINT NAME
00300	CHRVAL:	MOVEI B,PNAME(S)	;$$ GET PRINT NAME
00310		PUSHJ P,GET	;$$
00320		HLRZ A,(A)	;$$
00330		MOVE A,(A)	;$$ FIRST WORD OF PRINT NAME
00340		LSH A,-35	;$$ SHIFT TO GET FIRST CHARACTER
00350		JRST FIX1A	;$$ CONVERT TO INTEGER
00360	
00370	;FUNCTION TO SET BITS FOR A READ MACRO
00380	;	A IS THE CHAR. ATOM AND B ARE THE STATUS BITS,
00390	;	IF B=NIL NO MODIFICATION IS MADE
00400	;	THE OLD STATUS BITS ARE RETURNED
00410	SETCHR:	MOVE TT,B	;$$
00420		PUSHJ P,CHRVAL	;$$ CONVERT CHAR. TO INUM
00430		MOVEI B,-INUM0(A)	;$$ CONVERT INUM TO BINARY
00440		LDB A,[POINT 5,CHRTAB(B),5]	;$$ LOAD OLD BITS
00450		JUMPE TT,FIX1A	;$$ NO CHANGE IF B = NIL
00460		MOVEI TT,-INUM0(TT)	;$$ CONVERT STATUS TO BINARY
00470		DPB TT,[POINT 5,CHRTAB(B),5]	;$$ SET NEW BITS
00480		JRST FIX1A	;$$ RETURN
00490	
00500	
00510		PAGE
     
00010		SUBTTL LISP INTERPRETER SUBROUTINES   
00020	
00030	CADDDR:	SKIPA A,(A)
00040	CADDAR:	HLRZ A,(A)
00050	CADDR:	SKIPA A,(A)
00060	CADAR:	HLRZ A,(A)
00070	CADR:	SKIPA A,(A)
00080	CAAR:	HLRZ A,(A)
00090	CAR:	HLRZ A,(A)
00100		POPJ P,
00110	
00120	CDDDDR:	SKIPA A,(A)
00130	CDDDAR:	HLRZ A,(A)
00140	CDDDR:	SKIPA A,(A)
00150	CDDAR:	HLRZ A,(A)
00160	CDDR:	SKIPA A,(A)
00170	CDAR:	HLRZ A,(A)
00180	CDR:	HRRZ A,(A)
00190		POPJ P,
00200	
00210	CAADDR:	SKIPA A,(A)
00220	CAADAR:	HLRZ A,(A)
00230	CAADR:	SKIPA A,(A)
00240	CAAAR:	HLRZ A,(A)
00250		JRST CAAR
00260	
00270	CDADDR:	SKIPA A,(A)
00280	CDADAR:	HLRZ A,(A)
00290	CDADR:	SKIPA A,(A)
00300	CDAAR:	HLRZ A,(A)
00310		JRST CDAR
00320	
00330	CAAADR:	SKIPA A,(A)
00340	CAAAAR:	HLRZ A,(A)
00350		JRST CAAAR
00360	
00370	CDDADR:	SKIPA A,(A)
00380	CDDAAR:	HLRZ A,(A)
00390		JRST CDDAR
00400	
00410	CDAADR:	SKIPA A,(A)
00420	CDAAAR:	HLRZ A,(A)
00430		JRST CDAAR
00440	
00450	CADADR:	SKIPA A,(A)
00460	CADAAR:	HLRZ A,(A)
00470		JRST CADAR
00480	PAGE
     
00010	QUOTE:	HLRZ A,(A)	;car and quote duplicated for backtrace
00020		POPJ P,
00030	
00040	AASCII:	PUSHJ P,NUMVAL
00050		LSH A,↑D29
00060		PUSHJ P,FWCONS
00070		PUSHJ P,NCONS
00080	PNGNK1:	PUSHJ P,NCONS
00090		MOVEI B,PNAME(S)
00100		PUSHJ P,XCONS
00110	ACONS:	TROA B,-1
00120	NCONS:	TRZA B,-1
00130	XCONS:	EXCH B,A
00140	CONS:	AOS CONSVAL
00150		HRL B,A
00160		SKIPN A,F
00170		JRST [	HLR A,B
00180			PUSHJ P,AGC
00190			JRST .-1]
00200		MOVE F,(F)
00210		MOVEM B,(A)
00220		POPJ P,
00230	
00240	;new consing routines-not finished yet
00250	;acons:	troa b,-1
00260	;ncons:	trz b,-1
00270	;cons:	exch b,a
00280	;xcons:	hrl a,b
00290	;	exch a,(f) 
00300	;	exch a,f
00310	;	popj p,
00320	
00330	CONSP:	JUMPE	A,CPOPJ		;## DONE IF NIL
00340		CAIGE A,@GCP1		;*** MUST BE IN FS
00350		CAIGE A,@GCPP1		;***
00360		JRST FALSE
00370		HLLE B,(A)
00380		AOJE B,FALSE
00390	IFN NONUSE	<JRST	TRUE>	;## T IF NONUSEFUL DESIRED
00400	IFE NONUSE	<POPJ	P,>	;## THE CELL OTHERWISE
00410	PATOM:	CAIGE A,@GCP1		;*** T IF NOT IN FS
00420		CAIGE A,@GCPP1
00430		JRST TRUE
00440		JRST PATOM1
00450	ATOM:	CAILE A,INUMIN
00460		JRST TRUE
00470		JUMPE	A,TRUE		;## FAST CHECK FOR NIL
00480		CAIGE	A,@GCP1		;## LO-END OF FWS
00490		CAIGE	A,@GCPP1	;*** LO-END OF FS
00500		JRST FALSE		;*** NOT IN FS
00510	PATOM1:	HLLE A,(A)
00520		AOJE A,TRUE
00530	FALSE:	MOVEI A,NIL
00540	CPOPJ:	POPJ P,
00550	PAGE
     
00010	NEQ:	CAMN A,B
00020		JRST FALSE
00030		JRST TRUE
00040	EQ:	CAMN A,B
00050		JRST TRUE
00060		JRST FALSE
00070	
00080	LENGTH:	MOVEI B,0
00090	LNGTH1:	JUMPE A,FIX1		;## DONE IF NIL
00100		CAIL A,@FWSO		;## FWSO  IS  FULL SPACE ORIGIN,
00110					;## ELIMINATE ILL MEM REF
00120		JRST FIX1
00130		HLLE C,(A)
00140		AOJE C,FIX1
00150		HRRZ A,(A)
00160		AOJA B,LNGTH1
00170	
00180	LAST:	HRRZ B,(A)
00190		CAIE	B,NIL		;## IF NIL DONE
00200		CAIL	B,@FWSO		;## ANOTHER  POTENTIAL ILL MEM GONE
00210		POPJ P,
00220		HLLE B,(B)
00230		AOJE B,CPOPJ
00240		HRRZ A,(A)
00250		JRST LAST
00260	
00270	;(LITATOM X) = (AND (ATOM X) (NOT (NUMBERP X)))
00280	LITATOM: MOVE	B,A
00290		PUSHJ	P,ATOM
00300		JUMPE	A,CPOPJ
00310		MOVE	A,B
00320		PUSHJ	P,NUMBERP
00330		JRST	NOT
00340		PAGE
     
00010	;NEW RPLACD AND RPLACA WHICH CHECK SO AS NOT TO  CLOBBER NIL AND ATOMS
00020	RPLACA:	CAIE	A,NIL		;## TEST FOR NIL
00030		CAILE	A,INUMIN	;$$
00040		JRST	RPAERR	;$$ ATTEMPT TO RPLACA A SMALL NUMBER
00050		HLL	A,(A)	;$$TEST FOR OTHER ATOMS
00060		TLC	A,-1	;$$
00070		TLZN	A,-1	;$$ATOM CARS ARE -1
00080		JRST	RPAERR	;$$ATTEMPT TO RPLACA AN ATOM
00090		HRLM	B,(A)	;$$STANDARD CODE FOR RPLACA
00100		POPJ	P,	;$$
00110	
00120	RPLACD:	CAIG	A,INUMIN	;$$CHECK FOR SMALL BER
00130		JUMPN	A,.+2	;$$CHECK FOR NIL
00140		JRST	RPDERR	;$$ATTEMPT TO RPLACD NIL  OR A SMALL NUMBER
00150		HRRM	B,(A)	;$$OLD RPLACD CODE
00160		POPJ	P,	;$$
00170	
00180	ZEROP:	PUSHJ P,NUMVAL
00190	NOT:
00200	NULL:	JUMPN A,FALSE
00210	TRUE:
00220		MOVEI A,TRUTH(S)
00230		POPJ P,
00240	
00250	FW0CNS:	MOVEI A,0
00260	FWCONS:	JUMPN FF,FWC1
00270		EXCH A,FWC0#
00280		PUSHJ P,AGC
00290		EXCH A,FWC0
00300	FWC1:	EXCH A,(FF)
00310		EXCH A,FF
00320		POPJ P,
00330	
00340	PAGE
     
00010	SASSOC:	PUSHJ P,SAS1
00020		SKIPA A,C		;*** USE APPLY INSTEAD OF UUO
00030		POPJ P,
00040		MOVEI B,NIL
00050		JRST AP2
00060	
00070	ASSOC:	PUSHJ P,SAS1
00080		MOVEI A,NIL
00090		POPJ P,
00100	
00110	SAS0:	HLRZ B,T
00120	SAS1:	JUMPE B,CPOPJ
00130		MOVS T,(B)
00140		MOVS TT,(T)
00150		CAIE A,(TT)
00160		JRST SAS0
00170		HRRZ A,T
00180	CPOPJ1:	AOS (P)
00190		POPJ P,
00200	
00210	REVERSE: MOVE T,A
00220		MOVEI A,0
00230		JUMPE T,CPOPJ
00240		HLRZ B,(T)
00250		HRRZ T,(T)
00260		PUSHJ P,XCONS
00270		JUMPN T,.-3
00280		POPJ P,
00290	
00300	REMPROP:
00310	IFE OLDNIL<	CAIN A,NIL	;*** IF NEW NIL GET FAKE ATOM HEADER
00320			MOVEI A,FAKNIL(S)>
00330		HRRZ T,(A)
00340	REMP2:	MOVS TT,(T)
00350		CAIN B,(TT)
00360		JRA TT,REMP1
00370		HLRZ A,TT
00380		HRRZ T,(A)
00390		JUMPN T,REMP2
00400		JRST FALSE
00410	
00420	REMP1:	HRRM TT,(A)
00430		JRST TRUE
00440	PAGE
     
00010	GET:
00020	IFE OLDNIL<	CAIN	A,NIL	;*** IF NEW NIL GET FAKE ATOM HEADER
00030			MOVEI	A,FAKNIL(S)>
00040		HRRZ A,(A)
00050	GET1:	MOVS D,(A)
00060		CAIN B,(D)
00070		JRST CADR
00080		HLRZ A,D
00090		HRRZ A,(A)
00100		JUMPN A,GET1
00110		POPJ P,
00120	
00130	GETL:	JUMPE B,FALSE	;$$ NIL LIST - NIL ANSWER
00140	IFE OLDNIL<	CAIN A,NIL	;*** IF NEW NIL GET FAKE ATOM HEADER
00150			MOVEI A,FAKNIL(S)>
00160		HRRZ A,(A)
00170	GETL0:	HLRZ T,(A)
00180		MOVE C,B
00190	GETL1:	MOVS TT,(C)
00200		CAIN T,(TT)
00210		POPJ P,
00220		HLRZ C,TT
00230		JUMPN C,GETL1
00240		HRRZ A,(A)
00250		HRRZ A,(A)
00260		JUMPN A,GETL0
00270		POPJ P,
00280	
00290	NUMBERP:PUSHJ P,NUMTYP		;WMT- GO GET TYPE OF NUMBER
00300		JUMPN A,TRUE		; IF IT HAD A TYPE
00310	NUMBP2:	JRST FALSE	;bignums change this to JRST BIGNP
00320	
00330	STRINGP: PUSHJ	P,LITATOM	;*** LEAVES A IN B
00340		JUMPDβQ,CPOPJ		;***
00350		MOVE	A,B
00360		PUSHJ	P,CHRVAL	;GET THE FIRST CHARACTER
00370		SUBI	A,INUM0		;***
00380		LDB	B,RATFLD	;*** SEE IF DEFINED AS STRING START
00390		CAIE	B,STRBEG	;***
00400		JRST	FALSE
00410		JRST	TRUE
00420	
00430	PUTPROP:
00440	IFE OLDNIL<	CAIN A,NIL	;*** IF NEW NIL GET FAKE ATOM HEADER
00450			MOVEI A,FAKNIL(S)>
00460		MOVE T,A
00470		HRRZ A,(A)
00480	CSET3:	MOVS TT,(A)
00490		HLRZ A,TT
00500		CAIN C,(TT)
00510		JRST CSET2
00520		HRRZ A,(A)
00530		JUMPN A,CSET3
00540		HRRZ A,(T)
00550		PUSHJ P,XCONS
00560		HRRZ B,C
00570		PUSHJ P,XCONS
00580		HRRM A,(T)
00590		JRST CADR
00600	
00610	CSET2:	CAIE C,VALUE(S)
00620		JRST CSET1
00630		HRRZ T,(B)
00640		HLRZ A,(A)
00650		HRRM T,(A)
00660		JRST PROG2
00670	
00680	CSET1:	HRLM B,(A)
00690	PROG2:	MOVE A,B
00700	PROG1:	POPJ P,
00710	PAGE
     
00010	DEFPROP:
00020		HRRZ B,(A)
00030		HRRZ C,(B)
00040		HLRZ A,(A)
00050		HLRZ B,(B)
00060		HLRZ C,(C)
00070		PUSH P,A
00080		PUSHJ P,PUTPROP
00090		JRST POPAJ
00100	
00110	;*** New Super (DEFLIST <l> <defval> <prop>)
00120	DEFLIST: HRRZ B,(A)
00130		HRRZ C,(B)
00140		JUMPN C,.+4
00150		MOVE C,B		;*** MISSING <defval> ==> T
00160		MOVEI B,TRUTH(S)
00170		SKIPA
00180		HLRZ B,(B)
00190		HLRZ A,(A)
00200		HLRZ C,(C)
00210		JUMPE A,CPOPJ
00220		PUSH P,B		;*** SAVE DEFAULT VALUE
00230		PUSH P,C		;*** SAVE PROPERTY
00240	DEFL1:	PUSH P,A		;*** SAVE LIST
00250		HLRZ A,(A)		;*** GET ATOM OR (ATOM VALUE) PAIR
00260		HLLE AR1,(A)		;*** ATOM OR PAIR?
00270		AOJE AR1,.+5		;*** ATOM - USE DEFAULT VALUE
00280		HRRZ B,(A)		;*** PAIR - USE VALUE GIVEN
00290		HLRZ B,(B)
00300		HLRZ A,(A)
00310		SKIPA
00320		HRRZ B,-2(P)
00330		HRRZ C,-1(P)
00340		PUSHJ P,PUTPROP
00350		POP P,A
00360		HRRZ A,(A)
00370		JUMPN A,DEFL1
00380		SUB P,[XWD 2,2]
00390		JRST CPOPJ
00400	
00410	;*** (DEFP A B C) = (PROGN (PUTPROP @A (GET @B @C) @C) @A)
00420	DEFP:	HLRZ B,(A)
00430		PUSH P,B
00440		HRRZ B,(A)
00450		HLRZ A,(B)
00460		HRRZ B,(B)
00470		HLRZ B,(B)
00480		PUSHJ P,GET
00490		MOVE C,B
00500		MOVE B,A
00510		MOVE A,0(P)
00520		PUSHJ P,PUTPROP
00530		JRST POPAJ
00540	
00550	;*** (DEFV A B) = (PROGN (SETQ A @B) @A)
00560	DEFV:	HRRZ B,(A)
00570		HLRZ B,(B)
00580		HLRZ A,(A)
00590		PUSH P,A
00600		PUSHJ P,SET
00610		JRST POPAJ
00620	PAGE
     
00010	EQUAL:	MOVE C,[JUMPE A,EQUAL4]	;WMT- FAIL IF NON-NUMERIC ATOMS THAT AREN'T EQ
00020		MOVEM C,EQUALX		;WMT-
00030	EQUAL0:	MOVE C,P
00040	EQUAL1:	CAMN A,B
00050		JRST TRUE
00060		DMOVE T,A
00070		PUSHJ P,ATOM
00080		EXCH A,B
00090		PUSHJ P,ATOM
00100		CAMN A,B
00110		JRST EQUAL3
00120	EQUAL4:	MOVE P,C
00130		JRST FALSE
00140	
00150	REMOTE<
00160	EQUALX:	JUMPE A,EQUAL4>		;WMT- DO THIS IF NON-NUMERIC, NON-EQ ATOMS
00170	
00180	EQUAL3:	PUSH P,T
00190		JUMPN A,EQ2
00200		PUSH P,TT
00210		HLRZ A,(T)
00220		HLRZ B,(TT)
00230		PUSHJ P,EQUAL1
00240		JUMPE A,EQUAL4
00250		POP P,B
00260		POP P,A
00270		HRRZ A,(A)
00280		HRRZ B,(B)
00290		JRST EQUAL1
00300	
00310	EQ2:	MOVE A,T
00320		PUSHJ P,NUMBERP
00330		XCT EQUALX		;WMT- DO SOMETHING DIFFERENT IF EQSTR
00340		MOVE A,TT
00350		PUSHJ P,NUMBERP
00360		JUMPE A,EQUAL4
00370		MOVE A,(P)
00380		MOVEM C,(P)
00390		MOVE B,TT
00400		JSP C,OP
00410		JRST COMP3		;*** CHANGED FROM JUMPL 7/27/76
00420		JRST COMP3		;*** DITTO
00430	
00440	COMP3B:	SKIPA A,TT		;WMT- EQSTR SUCCEEDED. MAKE THIS WORK
00450	COMP3A:	SETCM A,TT		;WMT- EQSTR FAILED. MAKE THIS FAIL
00460	COMP3:	POP P,C
00470		CAME A,TT
00480		JRST EQUAL4
00490		JRST TRUE
00500	PAGE
     
00010	COMMENT	?
00020		;## OLD SUBST AND COPY CODE THAT DID NOT WORK AS IT WAS
00030		;## NOT PROTECTED FROM THE GARBAGE COLLECTOR. NASTY, NASTY.
00040		;## REPLACED BY COMPILED LISP CODE
00050	SUBS5:	HRRZ A,SUBAS
00060		POPJ P,
00070	
00080	SUBST:	MOVEM A,SUBAS#
00090		MOVEM B,SUBBS#
00100	SUBS0A:	MOVE A,SUBAS
00110		MOVE B,SUBBS
00120		PUSH P,C
00130		MOVE A,C
00140		PUSHJ P,EQUAL
00150		POP P,C
00160		JUMPN A,SUBS5
00170		CAIE	C,NIL		;## TEST FOR NIL
00180		CAILE C,INUMIN
00190		JRST EV6A
00200		HLLE T,(C)
00210		AOJN T,SUBS2
00220	EV6A:	MOVE A,C
00230		POPJ P,
00240	
00250	SUBS2:	PUSH P,C
00260		HLRZ C,(C)
00270		PUSHJ P,SUBS0A
00280		EXCH A,(P)
00290		HRRZ C,(A)
00300		PUSHJ P,SUBS0A
00310		POP P,B
00320		JRST XCONS
00330	
00340	COPY:	MOVEI B,INUM0	;$$ (SUBST 0 0 A)
00350		MOVEI C,INUM0
00360		EXCH A,C
00370		JRST SUBST
00380		?
00390	PAGE
     
00010	; NTHCHAR = THE BTH CHARACTER OF A.
00020	;	*** USED TO TREAT LITATOMS AS A SPECIAL CASE FOR EFFICIENCY
00030	;	*** BUT STRINGS WERE HANDLED INCORRECTLY.  FIXED TO HANDLE
00040	;	*** ALL OBJECTS VIA PRINTA
00050	NTHCHAR: SUBI	B,INUM0
00060		JUMPGE	B,NTH3
00070		MOVEM	B,ORGSGN
00080		PUSH	P,A
00090		PUSHJ	P,%FLATSIZEC
00100		MOVEI	B,1-INUM0(A)
00110		ADD	B,ORGSGN
00120		POP	P,A
00130	NTH3:	JUMPLE	B,FALSE		;*** IN CASE N = 0 OR IS TOO BIG (NEG)
00140		MOVEM	B,ORGSGN
00150		HRROI	R,NTH5		;I HOPE THIS IS RIGHT
00160		PUSHJ	P,PRINTA
00170		HLRZ	A,ORGSGN
00180		JUMPE	A,FALSE		;*** IN CASE N TOO BIG (POS)
00190		PUSHJ	P,AASCII+1	;CONVERT TO AN ATOM
00200		JRST	INTERN		;INTERN IT
00210	NTH5:	SOSN	ORGSGN
00220		HRLOM	A,ORGSGN
00230		POPJ	P,
00240	PAGE
     
00010	NCONC:	TDZA R,R
00020	APPEND:	MOVEI R,.APPEND-.NCONC
00030		JUMPE T,FALSE
00040		POP P,B
00050	APP2:	AOJE T,PROG2
00060		POP P,A
00070		PUSHJ P,.NCONC(R)
00080		MOVE B,A
00090		JRST APP2
00100	
00110	.NCONC:	JUMPE A,PROG2		;*** THIS IS *NCONC
00120		MOVE TT,A
00130		MOVE C,TT
00140		HRRZ TT,(C)
00150		JUMPN TT,.-2
00160		HRRM B,(C)
00170		POPJ P,
00180	
00190	.APPEND: JUMPE A,PROG2		;*** THIS IS *APPEND
00200		MOVEI C,AR1
00210		MOVE TT,A
00220	APP1:	HLRZ A,(TT)
00230		PUSH P,B
00240		PUSHJ P,CONS	;saves b
00250		POP P,B
00260		HRRM A,(C)
00270		MOVE C,A
00280		HRRZ TT,(TT)
00290		JUMPN TT,APP1
00300		JRST SUBS4
00310	PAGE
     
00010	;NEW MEM-FUNCTIONS THAT RETURN THE TAIL OF THE LIST STARTING WHERE
00020	;	THE ELEMENT IS FOUND
00030	
00040	IFE NONUSE<MEMBER:
00050		>
00060	MEMBR.:	PUSHJ P,MEMB0
00070		SKIPE A
00080		MOVE A,SUBBS
00090		POPJ P,
00100	
00110	IFN NONUSE<MEMBER:
00120		>
00130	MEMB0:	MOVEM A,SUBAS#
00140	MEMB1:	JUMPE B,FALSE
00150		MOVEM B,SUBBS#
00160		MOVE A,SUBAS
00170		HLRZ B,(B)
00180		PUSHJ P,EQUAL
00190		JUMPN A,CPOPJ
00200		MOVE B,SUBBS
00210		HRRZ B,(B)
00220		JRST MEMB1
00230	
00240	IFN NONUSE<
00250	MEMQ:	PUSHJ P,MEMB
00260		SKIPE A
00270		JRST	TRUE
00280		POPJ P,
00290		>
00300	IFE NONUSE<MEMQ:
00310		>
00320	MEMB:	EXCH	A,B		;## NEW MEMQ THAT RETURN TAIL
00330		JUMPE A,FALSE
00340		MOVS C,(A)
00350		CAIN B,(C)
00360		POPJ	P,
00370		HLRZ A,C		;*** DOES NOT WORK WITH NON-LISTS
00380		JUMPN A,MEMB+1
00390		POPJ	P,
00400	
00410	
00420	
00430	PAGE
     
00010	IFN NONUSE<
00020	;AND OR FUNCTIONS (AND#, OR#) THAT RETURN THE EXPRESSION
00030	;	THAT CAUSED THE FUNCTION TO EVALUATE TO TRUE
00040	
00050	AND.:	PUSHJ P,AND
00060		SKIPA
00070	OR.:	PUSHJ P,OR
00080		HRRZ A,2(P)
00090		POPJ P,
00100		>
00110	
00120	AND:	HRLI A,TRUTH(S)
00130	OR:	HLRZ C,A
00140		PUSH P,C
00150	ANDOR:	HRRZ C,A
00160		JUMPE C,AOEND
00170		MOVSI C,(SKIPE (P))
00180		TLNE A,-1
00190		MOVSI C,(SKIPN (P))
00200		XCT C
00210		JRST AOEND
00220		MOVEM A,(P)
00230		HLRZ A,(A)
00240		PUSHJ P,EVAL
00250		EXCH A,(P)
00260		HRR A,(A)
00270		JRST ANDOR
00280	
00290	AOEND:	POP P,A
00300	IFN	NONUSE <
00310		SKIPE A
00320		MOVEI A,TRUTH(S)
00330		>
00340		POPJ P,
00350	PAGE
     
00010	GENSYM:	MOVE B,[POINT 7,GNUM,34]
00020		MOVNI C,4
00030		MOVEI TT,"0"
00040	
00050	GENSY2:	LDB T,B
00060		AOS T
00070		DPB T,B
00080		CAIG T,"9"
00090		JRST GENSY1
00100		DPB TT,B
00110		ADD B,[XWD 70000,0]
00120		AOJN C,GENSY2
00130	
00140	GENSY1:	MOVE A,GNUM
00150		PUSHJ P,FWCONS
00160		PUSHJ P,NCONS
00170		JRST PNGNK1
00180	
00190	REMOTE<
00200	GNUM:	ASCII /G0000/>
00210	
00220	CSYM:	HLRZ A,(A)
00230		PUSH P,A
00240		MOVEI B,PNAME(S)
00250		PUSHJ P,GET
00260		JUMPE A,NOPNAM
00270		HLRZ A,(A)
00280		MOVE A,(A)
00290		MOVEM A,GNUM
00300		JRST POPAJ
00310	PAGE
     
00010	LIST:	MOVEI B,CEVAL(S)
00020		PUSH P,B
00030		PUSH P,A
00040		MOVNI T,2
00050		JRST MAPCAR
00060	
00070	EELS:	HLRZ TT,(T)	;interpret lsubr call
00080		JUMPE TT,UNDFUN	;*** NIL NOT A VALID PROPERTY
00090		HRRZ A,(AR1)
00100	ILIST:	MOVEI T,0
00110		JUMPE A,ILIST2
00120	ILIST1:	PUSH P,A
00130		HLRZ A,(A)
00140		PUSH P,TT
00150		HRLM T,(P)
00160		PUSHJ	P,EVAL	;EVALUATE ARGUMENT
00170	ILIST3:	POP P,TT
00180		HLRE T,TT
00190		EXCH A,(P)
00200		HRRZ A,(A)
00210		SOS T
00220		JUMPN A,ILIST1
00230	ILIST2:	JRST (TT)
00240	
00250	;FAST MAPC FOR 2 ARGS - CALLED BY LAP CODE ONLY
00260	.MAPC:	PUSH	P,A
00270		JUMPE	B,PRETB
00280		HLRZ	A,(B)
00290		HRRZ	B,(B)
00300		PUSH	P,B
00310		CALLF	1,@-1(P)
00320		POP	P,B
00330		JRST	.MAPC+1
00340	
00350	;FAST MAP FOR 2 ARGS - CALLED BY LAP CODE ONLY
00360	.MAP:	PUSH	P,A
00370		JUMPE	B,PRETB
00380		MOVE	A,B
00390		HRRZ	B,(B)
00400		PUSH	P,B
00410		CALLF	1,@-1(P)
00420		POP	P,B
00430		JRST	.MAP+1
00440	
00450	PRETB:	SUB	P,[XWD 1,1]
00460		JRST	PROG2
00470		PAGE
     
00010	; NEW AND SUPER POWERFUL MAP FUNCTIONS
00020	MAPCON:	TLZ	T,100000
00030		JRST	MAPLIST
00040	MAPCAN:	TLZA	T,100000
00050	MAPC:	TLZA	T,400000
00060	MAPCAR:	TLZA	T,400000
00070	MAP:	TLZ	T,200000
00080	; INITIALIZE
00090	MAPLIST:SETCA	T,T		; RH(T) NOW = # ARGS FOR MAP
00100		HRRZ	A,T		; GET NUMBER OF ARGS TO MAP
00110		CAIGE	A,1		; WE NEED AT LEAST A FUN. AND 1 ARG.
00120		 ERR1	[SIXBIT /TOO FEW ARGUMENTS - MAP!/]
00130		MOVEI	A,(CALLF)
00140		DPB	T,[POINT 4,A,30]
00150		MOVE	B,P
00160		MOVE	AR1,T
00170		HRL	AR1,T
00180		SUB	B,AR1
00190		PUSH	P,B
00200		HRLM	A,(B)
00210		PUSH	P,T
00220		PUSH	P,
00230		HRLZM	P,(P)
00240	; SET UP TO GET ARGUMENTS
00250	MAPL2:	MOVE	T,-1(P)	; GET # ARGS FOR FUN CALL
00260		MOVEI	TT,-3(P)	; GET ADDR OF REG. FOR LAST (TOPMOST) ARG
00270	; MOVE ARGS TO REGS
00280	MPL3:	MOVE	D,(TT)	; PICK AN ARG FROM IN THE STACK
00290		TLNE	T,40000		;WMT-SKIP IF FIRST TIME THRU ARGS
00300	MPL4:	HRRZ	D,(D)		;WMT-TAKE CDR
00310		JUMPE	D,MPDN		; (WE'RE DONE IF IT'S NIL)
00320	; [UT]	CHECK FOR WELL FORMED LIST (IE., NOT AN ATOM)
00330		CAILE	D,INUMIN	;					[UT]
00340		 JRST	MAPERR		; IT'S AN INUM				[UT]
00350		HLLE	R,(D)		; GET LEFT HALF (-1 FOR ATOM HEADER)	[UT]
00360		AOJE	R,MAPERR	; ZERO => IT WAS AN ATOM HEADER		[UT]
00370	;WMT-CHANGES TO MAKE RPLACD WORK DURING MAP,MAPLIST,MAPCON
00380		HRRZM	D,(TT)		;WMT-STORE IT BACK FOR NEXT TIME
00390		MOVEM	D,(T)		; PUT ARG IN APPROPRIATE REG.
00400		MOVE	D,(D)		; GET FIRST CONS CELL OF LIST
00410		TLNE	T,400000	; SKIP TO USE FULL LIST(MAP,MAPLIST,MAPCON)
00420		HLRZM	D,(T)		; ELSE USE CAR OF LIST (MAPCAR,MAPC,MAPCAN)
00430		COMMENT &	(ABOVE CODE DOES THIS BETTER)
00440	; [UT]	CHECK THAT WE'RE NOT MAPPING DOWN AN ILL-FORMED LIST
00450		HRRZS	D,D		; CHECK CDR IS NOT A NON-NIL ATOM	[UT]
00460		EXCH	A,D		; SAVE REG.A IN CASE IT'S ALREADY SET	[UT]
00470		CAIE	A,0		; SKIP IF NIL				[UT]
00480		PUSHJ	P,PATOM		; THOROUGH ATOM CHECK			[UT]
00490		CAIN	A,TRUTH(S)	; WAS IT A NON-NIL ATOM?		[UT]
00500		 JRST	MAPERR		; YES--MAP ARG NOT A LIST		[UT]
00510		EXCH	A,D		; RESTORE AND CONTINUE...		[UT]
00520	&
00530		SUBI	TT,1
00540		SUBI	T,1		;WMT-SUBTRACT ONE FROM # OF ARGS
00550		TRNE	T,777777	;WMT-ARE WE THROUGH?
00560		JRST	MPL3		;WMT-NOPE, DO NEXT ARG
00570		TLON	T,40000		;WMT-MARK THAT YOU'VE DONE LIST ONCE
00580		HLLM	T,-1(P)		;WMT-SAVE MARK FOR LATER
00590		XCT	(TT)	; CALL THE FUNCTION
00600		LDB	C,[POINT 2,-1(P),2]
00610		TRNE	C,2
00620		JRST	MAPL2
00630	; ATTACH TO OUTPUT LIST
00640		SKIPN	C
00650		PUSHJ	P,NCONS
00660		JUMPE A,MAPL2
00670		HLR	B,(P)
00680		HRRM	A,(B)
00690		SKIPE	C
00700		PUSHJ	P,LAST
00710		HRLM	A,(P)
00720		JRST	MAPL2
00730	; POP STACK AND RETURN
00740	MPDN:	POP	P,AR1
00750		MOVE	P,-1(P)
00760		POP	P,B
00770	SUBS4:	HRRZ	A,AR1
00780		POPJ	P,
00790	
00800	MAPERR:	ERR1	[SIXBIT /ILL-FORMED ARGUMENT - MAP!/]
00810	
00820	;PA3:	0	;THE REG. PDL POINTER
00830	;PA4:	0	;Lh=pntr to prog less bound var list	
00840			;RH=NEXT PROG STATEMENT
00850	
00860	PROG:	PUSH P,PA3#
00870		PUSH P,PA4#
00880		HLRZ TT,(A)	;## TT HAS VARIABLE LIST
00890		HRRZ A,(A)	;## A HAS PROG BODY
00900		HRRM A,PA4
00910		HRLM A,PA4
00920	
00930		MOVE T,SP	;$$ADJUST SPDLSAV POINTER TO INCLUDE EVAL BLIP
00940		SUB T,[XWD 2,2]	;$$SO PA3,PA4 CAN BE RESTORED
00950		MOVEM	T,SPSV#	;$$BY UNBIND
00960		JRST	PG7B	;$$GO CHECK IF ANY VARIABLES TO BIND
00970	
00980	PG7A:	HLRZ A,(TT)
00990		MOVEI AR1,0
01000		PUSHJ P,BIND
01010		HRRZ TT,(TT)
01020	PG7B:	JUMPN TT,PG7A
01030		PUSH SP,SPSV
01040		MOVEM P,PA3
01050	
01060	PG1:	HRRZ T,PA4
01070		JUMPE T,PG4	;## IF END OF PROG, QUIT
01080		HLRZ A,(T)	;## A HAS FIRST STATEMENT
01090		HRRZ T,(T)	;## T KEEPS THE REST
01100		CAIE	A,NIL	;## TEST FOR NIL
01110		CAILE A,INUMIN	;## ALLOW INUMS FOR PROG LABELS 3/28/73
01120		JRST	PG1+1	;## NOW WE CAN SKIP OVER THIS TYPE OF ATOM
01130		HLLE B,(A)	;## IS IT A ATOM?
01140		AOJE B,PG1+1	;## JA, SO JUMP
01150		HRRM T,PA4	;## SAVE REST OF BODY
01160	
01170		PUSHJ P,EVAL	;## EVAL THE STATEMENT
01180	
01190		JRST PG1
01200	
01210	PGO:	SKIPN	PA3	;## ERROR IF NO PROG
01220		JRST	EG2
01230		MOVE	P,PA3	;## BACK UP ON RPDL
01240		MOVE	B,2(P)	;*** GET SP PUSHED BY EVAL
01250		PUSHJ	P,UBD
01260		HRLZI	C,(POPJ P,)	;## NEW CODE TO ALLOW BREAKING
01270				;## AND TRACING OF GO
01280		PUSHJ	P,DOSET	;##
01290		HLRZ	T,PA4
01300	PG5:	JUMPE T,EG1	;## ERROR IF NO TAG FOUND
01310		HLRZ TT,(T)	;## GET THE CAR
01320		HRRZ T,(T)	;## SAVE UP THE REST OF THE BODY
01330		CAIN TT,(A)
01340		JRST PG1+1	;FOUND TAG
01350		JRST PG5	;## TRY AGAIN
01360		
01370	RETURN:	SKIPN PA3
01380		JRST EG3
01390		MOVE P,PA3
01400		MOVE B,2(P)	;*** GET SP PUSHED BY EVAL
01410		PUSHJ P,UBD
01420		HRLZI	C,(POPJ P,)	;## NEW CODE TO ALLOW BREAKING
01430					;## AND TRACING OF RETURN
01440		PUSHJ	P,DOSET		;##
01450		JRST	PG4+1
01460	
01470	PG4:	SETZ A,
01480		PUSHJ P,UNBIND
01490	ERRP4:	POP P,PA4
01500		POP P,PA3
01510		POPJ P,
01520	
01530	GO:	HLRZ A,(A)
01540		CAIE	A,NIL		;## TEST FOR NIL
01550		CAILE	A,INUMIN	;## IS IT AN INUM?(NOW VALID)
01560		JRST	PGO		;## SEE IF IT IS THE ONE
01570		HLLE B,(A)	;## IS IT AN ATOM
01580		AOJE B,PGO
01590		PUSHJ P,EVAL
01600		JRST GO+1
01610	
01620	SETQ:	HLRZ B,(A)
01630		PUSH P,B
01640		PUSHJ P,CADR
01650		PUSHJ P,EVAL
01660		MOVE B,A
01670		POP P,A
01680	SET:	SKIPE	A		;$$ MUST BE NON-NIL
01690		CAILE	A,INUMIN	;$$ AND NOT AN INUM
01700		JRST	SETERR		;$$
01710		HLRE	AR1,(A)		;$$ AND AN ATOM
01720		AOJN	AR1,SETERR	;$$
01730		MOVE AR1,B
01740		PUSHJ P,BIND
01750		SUB SP,[XWD 1,1]
01760	RETAR1:	MOVE A,AR1
01770		POPJ P,
01780	
01790	CON2:	HRRZ A,(T)
01800	COND:	JUMPE A,CPOPJ	;entry
01810		PUSH P,A
01820		HLRZ A,(A)
01830		HLRZ A,(A)
01840		PUSHJ P,EVAL
01850		POP P,T
01860		JUMPE A,CON2
01870		HLRZ T,(T)
01880	COND2:	HRRZ T,(T)
01890		JUMPE T,CPOPJ	;ENTRY FOR ALL TYPES OF PROGN'S
01900		HLRZ A,(T)
01910		HRRZ T,(T)	;$$
01920		JUMPE T,EVAL	;$$ SAVE STACK SPACE IF NO IMPLIED PROG
01930		PUSH P,T	;$$
01940		PUSHJ P,EVAL
01950		POP P,T
01960		JRST COND2+2	;$$ BECAUSE OF THE LAST CHANGE
01970	
01980	
01990	;LEXORDER - TRUE IF A IS ALPHAMERICALLY LESS THAT OR EQUAL TO B
02000	
02010	LEXORD:	MOVE TT,A
02020		PUSHJ P,NUMBERP
02030		JUMPN A,LEX2	;1ST ARG IS A NUMBER
02040		MOVE A,B
02050		PUSHJ P,NUMBERP
02060		EXCH A,TT
02070		JUMPN TT,FALSE	;1ST=NOT-NUM, 2ND=NUM, DEFINE AS NIL
02080		MOVE T,B
02090		MOVEI B,PNAME(S)
02100		PUSHJ P,GET
02110		EXCH A,T
02120		PUSHJ P,GET
02130	LEX1:	JUMPE T,TRUE
02140		JUMPE A,CPOPJ
02150		HLRZ AR1,(A)
02160		MOVE AR1,(AR1)
02170		HLRZ AR2A,(T)
02180		MOVE AR2A,(AR2A)
02190		LSH AR1,-1
02200		LSH AR2A,-1
02210		CAMLE AR1,AR2A
02220		JRST TRUE
02230		CAME AR1,AR2A
02240		JRST FALSE
02250		HRRZ A,(A)
02260		HRRZ T,(T)
02270		JRST LEX1
02280	LEX2:	MOVE A,B
02290		PUSHJ P,NUMBERP
02300		EXCH A,TT
02310		JUMPE TT,TRUE	;1ST=NUM, 2ND=NOT-NUM, DEFINE AS TRUE
02320		PUSHJ P,.GREAT	;BOTH NUMBERS, DO (NOT (*GREAT A B))
02330		JRST NOT
02340	
02350	
02360	PROGN:	MOVE	T,A	;$$ PROGN
02370		MOVEI	A,NIL
02380		JRST	COND2+1	;$$ IMPLIED PROG DOES THE REST
02390		PAGE
     
00010		SUBTTL ARITHMETIC SUBROUTINES 
00020	
00030	;macro expander -- (foo a b c) => (*foo (*foo a b) c)
00040	EXPAND:	MOVE C,B
00050		HRRZ A,(A)
00060		PUSHJ P,REVERSE
00070		JRST EXPA1
00080	
00090	EXPN1:	MOVE C,B
00100	EXPA1:	HRRZ T,(A)
00110		HLRZ A,(A)
00120		JUMPE T,CPOPJ
00130		PUSH P,A
00140		MOVE A,T
00150		PUSHJ P,EXPA1
00160		EXCH A,(P)
00170		PUSHJ P,NCONS
00180		POP P,B
00190		PUSHJ P,XCONS
00200		MOVE B,C
00210		JRST XCONS
00220	
00230	PAGE
     
00010	ADD1:	CAILE A,INUMIN
00020		CAIL A,-2
00030		SKIPA B,[INUM0+1]
00040		AOJA A,CPOPJ
00050	.PLUS:	JSP C,OP
00060		ADD A,TT
00070		FADR A,TT
00080	
00090	SUB1:	CAILE A,INUMIN+1
00100		SOJA A,CPOPJ
00110		MOVEI B,INUM0+1
00120	.DIF:	JSP C,OP
00130		SUB A,TT
00140		FSBR A,TT
00150	
00160	.TIMES:	JSP C,OP
00170		IMUL A,TT
00180		FMPR A,TT
00190	
00200	.QUO:	CAIN B,INUM0
00210		JRST ZERODIV
00220		JSP C,OP
00230		IDIV A,TT
00240		FDVR A,TT
00250	
00260	.GREAT:	EXCH A,B
00270		JUMPE B,FALSE
00280	.LESS:	JUMPE A,CPOPJ
00290		JSP C,OP
00300		JRST COMP2	;bignums know about me
00310		JRST COMP2
00320	
00330	COMP2:	CAML A,TT
00340		JRST FALSE
00350		JRST TRUE
00360	
00370	.MAX:	MOVEI D,.GREAT
00380		SKIPA
00390	.MIN:	MOVEI D,.LESS
00400		MOVE AR1,A
00410		MOVE AR2A,B
00420		PUSHJ P,(D)
00430		SKIPN A
00440		MOVE AR1,AR2A
00450		JRST RETAR1
00460	PAGE
     
00010	MAKNUM:
00020		CAIE	B,FLONUM(S)	;## DEFAULT TO FIXNUM, NOT FLONUM
00030		JRST FIX1A
00040	FLO1A:
00050		MOVEI B,FLONUM(S)
00060		PUSHJ P,FWCONS
00070		JRST ACONS-1
00080	
00090	FIX1B:	SUBI A,INUM0
00100		MOVEI B,FIXNUM(S)
00110		PUSHJ P,FWCONS
00120		JRST ACONS-1
00130	
00140	NUMVLX:	JFCL 17,.+1
00150	NUMVAL:	CAIG A,INUMIN
00160		JRST NUMAG1
00170		SUBI A,INUM0
00180		MOVEI B,FIXNUM(S)
00190		POPJ P,
00200	
00210	NUMAG1:	MOVE REL,A		;*** CH FROM AR1
00220		HRRZ A,(A)
00230		HLRZ B,(A)
00240		HRRZ A,(A)
00250		CAIE B,FIXNUM(S)
00260		CAIN B,FLONUM(S)
00270		SKIPA A,(A)
00280	NUMV4:	SKIPA A,REL		;*** DITTO
00290		POPJ P,
00300	NUMV2:	PUSHJ P,EPRINT	;bignums know about me
00310		JRST NONNUM
00320	
00330	NUMV3:	JRST NONNUM		;bignums change me to JRST BIGDIS
00340	PAGE
     
00010	FLOAT:	IDIVI A,400000
00020		SKIPE A
00030		TLC A,254000
00040		TLC B,233000
00050		FADR A,B
00060		POPJ P,
00070	
00080	FIX:	PUSH P,A
00090		PUSHJ P,NUMVAL
00100		CAIE B,FLONUM(S)
00110		JRST POPAJ
00120		MULI A,400
00130		TSC A,A
00140		JFCL 17,.+1
00150		ASH B,-243(A)
00160	FIX2:	JFCL 10,FIXOV	;bignums change me to jfcl 10,bfix
00170		POP P,A
00180	FIX1:	MOVE A,B
00190		JRST FIX1A
00200	
00210	MINUSP:	PUSHJ P,NUMVAL
00220		JUMPGE A,FALSE
00230		JRST TRUE
00240	
00250	MINUS:	PUSHJ P,NUMVLX
00260		MOVNS A
00270		JFCL 10,@OPOV
00280		JRST MAKNUM
00290	
00300	ABS:	PUSHJ P,NUMVLX
00310		MOVMS A
00320		JRST MINUS+2
00330	
00340	NUMTYP:	CAILE A,INUMIN		;WMT- IS IT AN INUM?
00350		JRST NUMTY1
00360		HLLE T,(A)
00370		AOJN T,FALSE
00380		HRRZ A,(A)
00390		HLRZ A,(A)
00400		CAIE A,FIXNUM(S)
00410		CAIN A,FLONUM(S)
00420		POPJ P,
00430		JRST FALSE
00440	NUMTY1:	MOVEI A,INUM(S)		; IT'S AN INUM
00450		POPJ	P,
00460	
00470	INUMP:	CAIG	A,INUMIN	;##  INUM IF > INUMIN
00480		JRST	FALSE		;## NO, RETURN NIL
00490		POPJ	P,		;## RETURN USEFUL VALUE
00500	PAGE
     
00010	DIVIDE:	CAIN B,INUM0
00020		JRST ZERODIV
00030		JSP C,OP
00040		JRST RDIV		;bignums know about me
00050		JRST ILLNUM
00060	RDIV:	IDIV A,TT
00070		PUSH P,B
00080		PUSHJ P,FIX1A
00090		EXCH A,(P)
00100		PUSHJ P,FIX1A
00110		POP P,B
00120		JRST XCONS
00130	
00140	REMAINDER:
00150		PUSHJ P,DIVIDE
00160		JRST CDR
00170	
00180	FIXOV:	ERR2 [SIXBIT /INTEGER OVERFLOW!/]
00190	ZERODIV:ERR2 [SIXBIT /ZERO DIVISOR!/]
00200	FLOOV:	ERR2 [SIXBIT /FLOATING OVERFLOW!/]
00210	ILLNUM:	ERR2 [SIXBIT /NON-INTEGRAL OPERAND!/]
00220	
00230	GCD:	JSP C,OP
00240		JRST GCD2	;bignums know about me
00250		JRST ILLNUM
00260	GCD2:	MOVMS A
00270		MOVMS TT
00280	;euclid's algorithm
00290	GCD3:	CAMG A,TT
00300		EXCH A,TT
00310		JUMPE TT,FIX1A
00320		IDIV A,TT
00330		MOVE A,B
00340		JRST GCD3
00350	PAGE
     
00010	;general arithmetic op code routine for mixed types
00020	
00030	OP:	CAIG A,INUMIN
00040		JRST OPA1
00050		SUBI A,INUM0
00060		CAIG B,INUMIN
00070		JRST OPA2
00080		HRREI TT,-INUM0(B)
00090		XCT (C)	;inum op  (cannot cause overflow)
00100	FIX1A:	ADDI A,INUM0
00110		CAILE A,INUMIN
00120		CAIL A,-1
00130		JRST FIX1B
00140		POPJ P,
00150	
00160	OPA1:	HRRZ A,(A)
00170		HLRZ T,(A)
00180		HRRZ A,(A)
00190		CAIE T,FIXNUM(S)
00200		JRST OPA6
00210		SKIPA A,(A)
00220	OPA2:
00230		MOVEI T,FIXNUM(S)
00240		CAILE B,INUMIN
00250		JRST OPB2
00260		HRRZ B,(B)
00270		HRRZ TT,(B)
00280		HLRZ B,(B)
00290		CAIE B,FIXNUM(S)
00300		JRST OPA5
00310		SKIPA TT,(TT)
00320	OPB2:	HRREI TT,-INUM0(B)
00330		JFCL 17,.+1
00340		XCT (C)	;fixed pt op
00350	OPOV:	JFCL 10,FIXOV	;bignums change this to jfcl 10,fixovl
00360		JRST FIX1A
00370	
00380	OPA6:	CAILE B,INUMIN
00390		JRST OPB7
00400		HRRZ B,(B)
00410		HRRZ TT,(B)
00420		HLRZ B,(B)
00430		CAIE B,FLONUM(S)
00440		JRST OPB3
00450		CAIE T,FLONUM(S)
00460		JRST NUMV3
00470		MOVE A,(A)
00480		MOVE TT,(TT)
00490	OPR:	JFCL 17,.+1
00500		XCT 1(C)	;flt pt op
00510		JFCL 10,FLOOV
00520		JRST FLO1A
00530	
00540	OPA5:
00550		CAIE B,FLONUM(S)
00560		JRST NUMV3
00570		PUSHJ P,FLOAT
00580		JRST OPR-1
00590	
00600	OPB3:
00610		CAIE B,FIXNUM(S)
00620		JRST NUMV3
00630		SKIPA TT,(TT)
00640	OPB7:	HRREI TT,-INUM0(B)
00650		MOVEI B,FIXNUM(S)
00660		CAIE T,FLONUM(S)
00670		JRST NUMV3
00680		MOVE A,(A)
00690		EXCH A,TT
00700		PUSHJ P,FLOAT
00710		EXCH A,TT
00720		JRST OPR
00730		PAGE
     
00010		SUBTTL EXPLODE, READLIST AND FRIENDS 
00020	
00030	%FLATSIZEC: SKIPA R,.+1	;$$ FLATSIZEC - (LENGTH (EXPLODEC))
00040	FLATSIZE: HRRZI R,FLAT2
00050		SETZM	FLAT1
00060		PUSHJ P,PRINTA
00070		MOVE	A,FLAT1#
00080		JRST FIX1A
00090	FLAT2:	AOS FLAT1
00100		POPJ P,
00110	
00120	
00130	%EXPLODE: SKIPA R,.+1
00140	EXPLODE: HRRZI R,EXPL1
00150		MOVSI AR1,AR1
00160		PUSHJ P,PRINTA
00170		JRST SUBS4
00180	
00190	EXPL1:	PUSH P,B
00200		PUSH P,C
00210		ANDI A,177
00220		CAIL A,"0"
00230		CAILE A,"9"
00240		JRST EXPL2
00250		ADDI A,INUM0-"0"
00260		JRST EXPL4
00270	
00280	EXPL2:	PUSH P,AR1
00290		PUSH P,TT
00300		PUSH P,T
00310		LSH A,35
00320		MOVE C,SP
00330		PUSH C,A
00340		MOVEI AR1,1
00350		PUSHJ P,INTER0
00360		POP P,T
00370		POP P,TT
00380		POP P,AR1
00390	EXPL4:	PUSHJ P,NCONS
00400		HLR B,AR1
00410		HRRM A,(B)
00420		HRLM A,AR1
00430		POP P,C
00440		JRST POPBJ
00450	PAGE
     
00010	READLIST: TDZA T,T
00020	MAKNAM:	MOVNI T,1
00030		MOVEM T,NOINFG
00040		PUSH P,OLDCH
00050		SETZM OLDCH
00060		JUMPE A,NOLIST
00070		HRRM A,MKNAM3
00080		MOVEI A,MKNAM2
00090		PUSHJ P,READ0
00100		HRRZ T,MKNAM3
00110		CAIE T,-1
00120		JUMPN T,[ERR2 [SIXBIT /MORE THAN ONE S-EXPRESSION-MKNAM!/]]
00130		POP P,OLDCH
00140		POPJ P,
00150	MKNAM2:	PUSH P,B
00160		PUSH P,T
00170		PUSH P,TT
00180		HRRZ	TT,MKNAM3#
00190		JUMPE TT,MKNAM6
00200		CAIN TT,-1
00210		ERR2 [SIXBIT /READ UNHAPPY-MAKNAM!/]
00220		HRRZ B,(TT)
00230		HRRM B,MKNAM3
00240		HLRZ A,(TT)
00250		CAIGE A,INUMIN
00260		JRST MKNAM5
00270		SUBI A,INUM0-"0"
00280	MKNAM4:	POP P,TT
00290		POP P,T
00300		JRST POPBJ
00310	MKNAM5:	HLRZ A,(TT)
00320		MOVEI B,PNAME(S)
00330		PUSHJ P,GET
00340		HLRZ A,(A)
00350		LDB A,[POINT 7,(A),6]
00360		JRST MKNAM4
00370	MKNAM6:	MOVEI A," "
00380		HLLOS MKNAM3
00390		JRST MKNAM4
00400	
00410	;A COUPLE OF FUNCTIONS SO THAT THE PROGRAMMER MAY RETURN CELLS TO THE FREE LIST
00420	FREE:	MOVEM	F,(A)	;$$ RETURN A SINGLE CELL TO FREE LIST
00430		HRRZ	F,A
00440		JRST	FALSE
00450	FREELI:	JUMPE	A,CPOPJ	;$$ RETURN A LIST TO THE FREE LIST
00460		HRRZ	B,(A)
00470		MOVEM	F,(A)
00480		HRRZ	F,A
00490		MOVE	A,B
00500		JRST	FREELI
00510		PAGE
     
00010		SUBTTL EVAL APPLY  -- THE INTERPRETER  
00020	
00030	APPLY.:	CAILE A,INUMIN	;$$ AN APPLY TO HANDLE ANY FUNCTION TYPE
00040		JRST UNDTAG
00050		JUMPE A,UNDTAG		;*** NIL NOT A FUNCTION
00060		CAMGE A,FSO	;WMT- CHECK FOR FUNCTION IN BPS
00070		JRST APPBPS	;WMT-  IT MAY BE	3/4/77
00080		HLRZ T,(A)
00090		CAIE T,-1
00100		JRST AP2		;*** ALL AP2'S CH. FROM 'GAPP'
00110		HRRZ T,(A)
00120	AAGN:	JUMPE T,AP2		;***
00130		HLRZ TT,(T)
00140		HRRZ T,(T)
00150		CAIN TT,FSUBR(S)
00160		JRST	[HLRZ T,(T)
00170			 JUMPE T,UNDTAG	;*** DON'T ALLOW FSUBR PROP. OF NIL
00180			 MOVE A,B
00190			 JRST (T)]
00200		CAIN TT,FEXPR(S)
00210		JRST [	HLRZ T,(T)
00220			HRL T,A
00230			PUSH P,T
00240			MOVE A,B
00250			JRST APPL.2]
00260		CAIN TT,MACRO(S)
00270		JRST [	PUSHJ P,CONS
00280			JRST EVAL]
00290		CAIN TT,EXPR(S)
00300		JRST AP2		;***
00310		CAIE TT,SUBR(S)
00320		CAIN TT,LSUBR(S)
00330		JRST AP2		;***
00340		JRST AAGN
00350	
00360	COMMENT %
00370	;*** NO NEED TO DO THIS:
00380	GAPP:	HRREI T,-2
00390		PUSH P,A
00400		PUSH P,B
00410		JRST APPLY
00420	%
00430	
00440	APPBPS:	CAIGE A,FS	;WMT- IS IT REALLY IN BPS
00450		JRST UNDTAG	;WMT-  NO
00460		JRST AP2	;WMT- YES, HANDLE LIKE SUBR	3/4/77
00470	
00480		PAGE
     
00010	EV3:	HLRZ A,(AR1)
00020		MOVEI B,VALUE(S)
00030		PUSHJ P,GET
00040		JUMPE A,UNDFUN	;function object has no definition
00050		HRRZ A,(A)
00060	REMOTE<
00070	XXX4:
00080	UBDPTR:	UNBOUND>
00090		HLRZ	B,(AR1)		;$$GET ORIGINAL FN NAME
00100		CAME	A,B		;$$IF VALUE IS THE SAME THEN WE HAVE A LOOP
00110		CAMN A,UBDPTR
00120		JRST UNDFUN
00130		HRRZ B,(AR1)	;eval (cons (cdr a)(cdr ar1))
00140		PUSHJ P,CONS
00150		JRST XXEVAL
00160	
00170	;[UT] CHECK PDL SPACE LEFT, IF TOO LITTLE WE HAVE A
00180	;     RECURSION LIMIT ERROR
00190	
00200	CHKREC:	PUSH	P,A		;SAVE A IN CASE IT'S NEEDED
00210		HLRE	A,P		;GET NEG. REG PDL WORDS REMAINING
00220		SETCA	A,		;BUT WE NEED A POSITIVE NUMBER
00230		CAMGE	A,REGLIM	;MORE THAN 100 WORDS LEFT?
00240		  JRST	RLXERR		;NO--RECURSION LIMIT EXCEEDED
00250		HLRE	A,SP		;NOW CHECK SPEC PDL
00260		SETCA	A,
00270		CAML 	A,SPELIM	;SKIP IF FEWER THAN 100 WORDS LEFT
00280		  JRST	NORLX		;NO ERROR--CLEAR OLD RLXFLG IF STILL SET
00290		SKIPA	A,[0]		;WMT-SET FLAG TO TELL WHICH BLEW
00300	RLXERR:	SETO	A,		;WMT-SET FLAG TO TELL WHICH BLEW
00310		SKIPE	RLXFLG#		;HAVE WE JUST PASSED THE LIMIT?
00320		  JRST	NORLX+1		;NO--WE'VE BEEN HERE BEFORE, LEAVE FLG
00330		SETOM	RLXFLG		;JUST PASSED LIMIT, NOTE FOR NEXT TIME
00340		SKIPE	A,		;WMT-WHICH ERROR IS IT
00350		STRTIP	[SIXBIT /←REG !/]
00360		SKIPN	A,
00370		STRTIP	[SIXBIT /←SPEC !/]
00380		POP	P,A		;RESTORE REG. IN CASE IT'S NEEDED
00390		ERR1	[SIXBIT /PDL LIMIT EXCEEDED!/]
00400	
00410	NORLX:	SETZM	RLXFLG		;CLEAR RLX FLAG, PLENTY PDL SPACE NOW
00420		JRST	POPAJ
00430	
00440	PAGE
     
00010	OEVAL:	AOJN T,AEVAL	;(THIS IS LISP EVAL)
00020		POP P,A
00030				;(THIS IS LISP *EVAL)
00040	EVAL:	PUSH	P,SP	;$$SAVE SPDL  (*** USED BY GO AND RETURN)
00050		PUSHJ	P,XXEVAL ;$$GO DO EVALUATION AS USUAL
00060		POP	P,SP	;$$RESTORE SPDL
00070		POPJ	P,	;$$AND RETURN TO CALLER
00080	
00090	XXEVAL:	HRRZM A,AR1
00100		JUMPE A,CPOPJ	;*** FAST EVAL FOR NIL
00110		CAILE A,INUMIN
00120		JRST CPOPJ
00130	
00140	;$$CODE TO PUT EVAL BLIP ON SPECIAL PDL
00150	
00160		PUSH P,B	;$$SAVE WHAT WAS IN B
00170		HRRZI	B,-1(P)	;$$GET RPDL POINTER AND OFFSET
00180		HRLI B,UNBOUND(S) ;$$ SET UP RPDL POINTER
00190		PUSH SP,B	;$$ SAVE RPDL POINTER ON SPDL
00200		PUSH	SP,A	;$$SAVE EVAL FORM ON SPDL
00210		POP	P,B	;$$AND GO ON
00220		HLRZ	T,(A)	;;;;;;;;;;;;; 
00230		PUSHJ	P,CHKREC	;WMT-CHECK FOR PDL OVERFLOW
00240		SKIPN ERINT	;$$CHECK IF DDT (CONTROL H) INTERRUPT OCCURRED
00250		JRST .+4	;$$SKIP OVER INTERRUPT FEATURE
00260		SETZM	ERINT	;$$TURN OFF INTERRUPT FLAG
00270		PUSHJ P,EPRINT+2 ;$$PRINT OUT WHAT WAS INTERRUPTED
00280		ERR2 [SIXBIT /WAS JUST INTERRUPTED - NOW IN ERRORX!/]
00290		CAIN T,-1
00300		JRST EE1		;x is atomic
00310		JUMPE T,UNDFUN		;*** NIL NOT A FUNCTION
00320		CAILE T,INUMIN
00330		JRST UNDFUN
00340		HLRO TT,(T)
00350		AOJE TT,EE2		;car (x) is atomic
00360		JRST EXP3
00370	EE1:
00380	EV5:	HRRZ AR1,(AR1)
00390		JUMPE AR1,UNBVAR
00400		HLRZ TT,(AR1)
00410		CAIE TT,FLONUM(S)
00420		CAIN TT,FIXNUM(S)
00430		POPJ P,
00440	EVBIG:	HRRZ AR1,(AR1)		;bignums know about me
00450		CAIE TT,VALUE(S)
00460			JRST EV5
00470		HLRZ AR1,(AR1)
00480		HRRZ AR1,(AR1)
00490		CAIN AR1,UNBOUND(S)
00500		JRST UNBVAR
00510		JRST RETAR1
00520	PAGE
     
00010	;	HANDLER OF ALISTS AND SPDL CONTEXT POINTERS
00020	;***	SEVERAL CHANGES TO MAKE POINTERS SAME AS SPDL POINTERS
00030	
00040	ALIST:	MOVEM SP,SPSV
00050		SKIPN A,-1(P)	;*** GET ALIST OR SPDL POINTER
00060		JRST ALIST2	;*** NIL - FORGET IT
00070		CAILE A,INUMIN
00080		JRST ASPEC	;*** IT'S A POINTER
00090		PUSHJ P,REVERSE	;*** IT'S AN ALIST (UGH)
00100		SKIPA		;*** NO LONGER UNBINDS ENTIRE SPDL
00110	ALIST1:	MOVE A,B	;*** JUST BINDS VARS IN ALIST
00120		HRRZ B,(A)
00130		HLRZ A,(A)
00140		HRRZ AR1,(A)
00150		HLRZ A,(A)
00160		PUSHJ P,BIND
00170		JUMPN B,ALIST1
00180	ALIST2:	PUSH SP,SPSV
00190		POPJ P,
00200	
00210	ASPEC:	MOVEI A,-INUM0(A)	;*** CONVERT TO ACTUAL STACK POINTER
00220		HLRZ TT,SC2		;*** (WITH VALID LHS)
00230		ADD TT,A
00240		ADD A,SC2
00250		HRL A,TT
00260		MOVE C,SP
00270	ASPEC1:	CAMG C,A	;*** CHECK IF UNBOUND TO DESIRED POINT
00280		JRST ALIST2	;done
00290		POP C,T		;pointer for next block
00300		JUMPGE	T,ASPEC1	;$$SKIP ANY EVAL BLIP CRAP
00310	ASPEC2:	CAMN C,T
00320		JRST ASPEC1	;thru with block
00330		POP C,AR1
00340		TLNE	AR1,-1		;$$ TEST FOR EVAL BLIP
00350		JRST	.+3
00360		SUB	C,[XWD 1,1]	;$$ FOUND ONE, SKIP RPDL WORD
00370		JRST	ASPEC2
00380		MOVSS AR1
00390		PUSH SP,(AR1)	;save value cell
00400		HLRM AR1,(AR1)	;store previous value in value cell
00410		HRLM AR1,(SP)	;save pointer to spec pdl loc
00420		JRST ASPEC2
00430	
00440	AEVAL:	PUSHJ P,ALIST
00450		POP P,A
00460		MOVEI A,UNBIND
00470		EXCH A,(P)
00480		JRST EVAL
00490	PAGE
     
00010	EE2:	HRRZ T,(T)
00020		JUMPE T,EV3
00030		HLRZ TT,(T)
00040		HRRZ T,(T)
00050		CAIN TT,SUBR(S)
00060		JRST ESB
00070		CAIN TT,LSUBR(S)
00080		JRST EELS
00090		CAIN TT,EXPR(S)
00100		JRST AEXP
00110		CAIN TT,FSUBR(S)
00120		JRST EFS
00130		CAIN TT,MACRO(S)
00140		JRST EFM
00150		CAIE TT,FEXPR(S)
00160		JRST EE2
00170	
00180		HLRZ T,(T)
00190		HLL T,(AR1)
00200		PUSH P,T
00210		HRRZ A,(A)
00220	APPL.2:	TLO A,400000
00230		PUSH P,A
00240		MOVNI T,1
00250		JRST IAPPLY
00260	
00270	AEXP:	HLRZ T,(T)
00280		HLL T,(AR1)
00290	EXP3:	PUSH P,T
00300		HRRZ A,(AR1)
00310	CILIST:	JSP TT,ILIST
00320	EXP2:	JRST IAPPLY
00330	
00340	EFS:	HLRZ T,(T)
00350		JUMPE T,UNDFUN		;*** DON'T ALLOW FSUBR PROP. OF NIL
00360		HRRZ A,(AR1)
00370		JRST (T)
00380	PAGE
     
00010	ESB:	HRRZ A,(AR1)
00020	UUOS2:	HLRZ T,(T)
00030		JUMPE T,UNDFUN		;*** DON'T ALLOW SUBR PROP. OF NIL
00040		HLL T,(AR1)
00050		PUSH P,T
00060		JSP TT,ILIST
00070	ESB1:	CAMGE T,[-NACS]		;*** CHECK FOR TOO MANY ARGS
00080		JRST TOMANY		;***
00090		JRST .+NACS+1(T)
00100		POP P,A+4
00110		POP P,A+3
00120		POP P,A+2
00130		POP P,A+1
00140	POPAJ:	POP P,A
00150		POPJ P,
00160	
00170	EFM:	HLRZ T,(T)
00180		CALLF 1,(T)
00190		JRST EVAL
00200	PAGE
     
00010	APPLY:	MOVEI TT,AP2	;(THIS IS LISP APPLY)
00020		CAME T,[-3]
00030		JRST PDLARG
00040		MOVEM T,APFNG1#
00050		PUSHJ P,ALIST
00060		MOVE T,APFNG1
00070		JSP TT,PDLARG
00080		PUSH P,[UNBIND]
00090	AP2:	PUSH P,A	;(THIS IS LISP *APPLY)
00100		MOVEI T,0
00110	AP3:	JUMPE B,IAPPLY	;all args pushed; b has arg list
00120		HLRZ C,(B)
00130		PUSH P,C	;push arg
00140		HRRZ B,(B)
00150		SOJA T,AP3
00160	
00170	IAP4:	JUMPGE D,TOOFEW	;special case for fexprs
00180		AOJN R,TOOFEW
00190		HRRZ A,SP
00200		ADD A,SPNM	;*** MAKE IT A SPDL POINTER
00210		PUSH P,A
00220		MOVNI R,2
00230		SOJA T,IAP5
00240	
00250	FUNCT:	HLRZ B,(A)
00260		HRRZ A,SP
00270		ADD A,SPNM	;*** MAKE IT A SPDL POINTER
00280		PUSHJ P,XCONS
00290		MOVEI B,FUNARG(S)
00300		JRST XCONS
00310	PAGE
     
00010	APFNG:	SOS T
00020		MOVEM T,APFNG1
00030		JSP TT,PDLARG	;get args and funarg list
00040		HRRZ A,(A)
00050		HRRZ D,(A)	;a-list pointer
00060		HLRZ A,(A)	;function
00070		HRLZ R,APFNG1	;no. of args
00080		PUSH P,[UNBIND]
00090		JSP TT,ARGP1	;replace args and fn name
00100		PUSH P,D	;a-list pointer
00110		PUSHJ P,ALIST	;set up spec pdl
00120		POP P,D
00130		AOS T,APFNG1
00140	
00150	;falls through
00160	PAGE
     
00010	;falls in
00020	
00030	IAPPLY:	MOVE C,T	;state of world at entrance
00040		ADDI C,(P)	;t has - number of args on pdl
00050	ILP1A:	HRRZ B,(C)	;next pdl slot has function- poss fun name in lh
00060		JUMPE B,UNDTAC	;*** NIL NOT A FUNCTION
00070		CAILE B,INUMIN
00080		JRST UNDTAC
00090		CAMGE B,FSO	;WMT- CHECK FOR FUNCTION TO BE IN BPS
00100		JRST IAPBPS	;WMT-  IT MAY BE	3/4/77
00110		HLRZ A,(B)
00120		CAIN A,-1
00130		JRST IAP1	;fn is atomic
00140		CAIN A,LAMBDA(S)
00150		JRST IAPLMB
00160		CAIN A,FUNARG(S)
00170		JRST APFNG
00180		CAIN A,LABEL(S)
00190		JRST APLBL
00200		PUSH P,T
00210		MOVE A,B
00220		PUSHJ P,EVAL
00230		POP P,T
00240		MOVE C,T
00250		ADDI C,(P)
00260	ILP1B:	MOVEM A,(C)
00270		JRST ILP1A
00280	
00290	IAPXPR:	HLRZ A,(B)
00300		JRST ILP1B
00310	IAP1:	HRRZ B,(B)
00320		JUMPE B,IAP2
00330		HLRZ TT,(B)
00340		HRRZ B,(B)
00350		CAIN TT,EXPR(S)
00360		JRST IAPXPR
00370		CAIN TT,LSUBR(S)
00380		JRST IAP6
00390		CAIE TT,SUBR(S)
00400		JRST IAP1
00410		HLRZ B,(B)
00420		JUMPE B,UNDTAC		;*** DON'T ALLOW SUBR PROP. OF NIL
00430	IAP1A:	MOVEM B,(C)
00440		JRST ESB1
00450	
00460	IAPBPS:	CAIGE B,FS	;WMT- IS IT REALLY IN BPS
00470		JRST UNDTAC	;WMT-  NO
00480		JRST IAP1A	;WMT- YES, HANDLE LIKE SUBR	3/4/77
00490	
00500	PAGE
     
00010	IAPLMB:	HRRZ B,(B)
00020		HLRZ TT,(B)
00030		MOVEM SP,SPSV
00040		HRRZ B,(B)
00050		HLRZ D,(TT)
00060		CAIN D,-1
00070		JUMPN TT, IAP3
00080		MOVE R,T
00090	IPLMB1:	JUMPE T,IPLMB2	;no more args
00100		JUMPE TT,TOMANY	;too many args supplied
00110	IAP5:	HLRZ A,(TT)
00120		MOVEI AR1,1(T)
00130		ADD AR1,P
00140		HLLZ D,(AR1)
00150		HRLM A,(AR1)
00160		HRRZ TT,(TT)
00170		AOJA T,IPLMB1
00180	PAGE
     
00010	IPLMB2:	JUMPN TT,IAP4	;too few args supplied
00020		JUMPE R,IAP69
00030	IPLMB4:	POP P,AR1
00040		HLRZ A,AR1
00050		AOJG R,IPLMB3
00060		PUSHJ P,BIND
00070		JRST IPLMB4
00080	IPLMB3:
00090	IFN ALVINE,<
00100		SKIPE BACTRF		;*** ONLY IF ALVINING
00110		JRST	[HRRI AR1,CPOPJ 
00120			 TLNE AR1,-1
00130			 PUSH P,AR1
00140			 JRST .+1]>
00150		MOVEI A,NIL	;$$SETUP FOR IMPLIED PROG
00160		PUSH SP,SPSV
00170		MOVE T,B	;$$SETUP FOR IMPLIED PROG
00180		PUSHJ P,COND2+1	;$$INSTEAD OF EVAL
00190		JRST UNBIND
00200	
00210	IAP69:	POP P,(P)
00220		MOVEI A,NIL	;$$SETUP FOR IMPLIED PROG
00230		MOVE T,B	;$$
00240		JRST COND2+1	;$$INSTEAD OF EVAL
00250	
00260	IAP6:	HLRZ B,(B)
00270		JUMPE B,UNDTAC		;*** DON'T ALLOW LSUBR PROP. OF NIL
00280		MOVEI TT,CPOPJ
00290		MOVEM TT,(C)
00300		JRST (B)
00310	
00320	APLBL:	MOVEM SP,SPSV
00330		HRRZ B,(B)
00340		HLRZ A,(B)
00350		HRRZ B,(B)
00360		HLRZ AR1,(B)
00370		MOVEM AR1,(C)
00380		PUSHJ P,BIND
00390		MOVEI A,APLBL1
00400		EXCH A,-1(C)
00410		EXCH A,LBLAD#
00420		HRLI A,LBLAD
00430		PUSH SP,A
00440		PUSH SP,SPSV
00450		JRST IAPPLY
00460	APLBL1:	PUSH P,LBLAD
00470		JRST SPECSTR
00480	
00490	IAP2:	HRRZ A,(C)
00500		MOVEI B,VALUE(S)
00510		PUSHJ P,GET
00520		JUMPE A,UNDTAC
00530		HRRZ A,(A)
00540		HRRZ B,(C)	;$$GET ORIGINAL FN NAME
00550		CAME A,B	;$$IF THE VALUE IS THE SAME THEN WE HAVE A LOOP
00560		CAIN A,UNBOUND(S)
00570		JRST UNDTAC
00580		JRST ILP1B
00590	
00600	IAP3:	MOVNI AR1,-INUM0(T)	;lexpr call
00610		MOVE A,TT
00620		PUSHJ P,BIND
00630		PUSH P,%ARG
00640		SUBI C,INUM0
00650		HRRM C,%ARG
00660		PUSH SP,SPSV
00670		MOVEI A,NIL	;$$ MORE FOR IMPLIED PROG
00680		MOVE T,B	;$$
00690		PUSHJ P,COND2+1	;$$ INSTEAD OF EVAL
00700		HRRZ T,%ARG
00710		POP P,%ARG
00720		SUBI T,1-INUM0(P)
00730		HRLI T,-1(T)
00740		ADD P,T
00750		JRST UNBIND
00760	
00770	ARG:	HRRZ A,@%ARG
00780		POPJ P,
00790	
00800	REMOTE<
00810	%ARG:	XWD A,0>
00820	SETARG:	HRRZM B,@%ARG
00830		JRST PROG2
00840	PAGE
     
00010	BIND:	JUMPE A,BNDERR	;$$CAN'T REBIND NIL
00020		CAIE A,TRUTH(S)	;$$SHOULDN'T REBIND T
00030		CAILE A,INUMIN	;*** INUMS AREN'T NICE VARIABLES
00040		JRST BNDERR	;$$
00050		HLRE T,(A)	;*** NOR ARE NON-LITATOMS
00060		AOJN T,BNDERR	;***
00070		PUSH P,B
00080		HRRZM A,BIND3#
00090	BIND2:
00100		MOVEI B,VALUE(S)	;bind atom in a to value in ar1,save
00110		PUSHJ P,GET	;old binding on s pdl
00120		JUMPE A,BIND1	;add value cell
00130		PUSH SP,(A)
00140		HRLM A,(SP)
00150	
00160		HRRM AR1,(A)	;$$THIS WAS HHRZM AR1,(A) WHICH CLOBBERED ATOM POINTER IN MY SYSTEM
00170		SETZM BIND3	;*** SO GC WON'T MARK GARBAGE
00180	POPBJ:	POP P,B
00190		POPJ P,
00200	
00210	BIND1:
00220		MOVEI B,UNBOUND(S)
00230	
00240		MOVE A,BIND3	;$$SET UP ATOM POINTER FROM SPECIAL CELL
00250				;$$THIS WAS MOVEI A,0
00260		PUSHJ P,CONS
00270		HRRZ B,@BIND3
00280		PUSHJ P,CONS
00290		MOVEI B,VALUE(S)
00300		PUSHJ P,XCONS
00310		HRRM A,@BIND3
00320		MOVE A,BIND3
00330		JRST BIND2
00340	
00350	UBD:	CAMG SP,B
00360		POPJ P,
00370	
00380		HLRZ	TT,(SP)	;$$SKIP OVER EVAL BLIPS ETC.
00390		JUMPN	TT,PJUBND	;$$IF EQUAL TO 0 IT WAS AN EVAL BLIP
00400		SUB	SP,[XWD 2,2]	;$$DECREMENT SPDL
00410		JRST	UBD		;$$GO BACK AND CHECK
00420	PJUBND:	PUSHJ P,UNBIND
00430		JRST UBD
00440	
00450	UNBIND:
00460	SPECSTR: MOVE TT,(SP)
00470		CAMN	SP,SC2	;$$CHECK TO AVOID OVERSHOOT
00480		POPJ	P,	;$$
00490	
00500		SUB SP,[XWD 1,1]
00510		JUMPGE TT,UNBIND	;syncronize stack
00520	UNBND1:	CAMN SP,TT
00530		POPJ P,
00540		POP SP,T
00550	
00560	
00570		CAIN T,(T)	;$$CHECK TO SKIP OVER NEW ITEMS PUT ON SPDL
00580				;$$ALL SUCH ITEMS HAVE 0 LEFT HAND SIDES
00590		JRST PROGUB	;$$THIS IS AN EVAL BLIP - CHECK IF A PROG
00600	
00610		MOVSS T
00620	
00630		HLRM T,(T)	;$$CHANGED FROM HLRZM T,(T) TO PROTECT NEW ATOM POINTER
00640	
00650		JRST UNBND1
00660	
00670	
00680	PROGUB:	HLRZ T,(T)	;$$CHECK FOR A PROG
00690		CAIE T,PROGAT+1(S)	;$$CHECK IF IT IS A PROG
00700		JRST PROGU1	;$$NOT A PROG, SKIP IT AND GO ON
00710		MOVE T,(SP)	;$$GET THE RPDL POINTER FOR PROG INTO T
00720		ADDI T,2	;$$INCREMENT TO GET TO WHERE PA3,PA4 SAVED
00730		POP T,PA4	;$$RESTORE PA4
00740		POP T,PA3	;$$AND PA3 FROM WHERE THEY WERE SAVED
00750	PROGU1:	POP SP,T	;$$ POP RPDL POINTER
00760		JRST UNBND1	;$$AND GO ON WITH THE UNBINDING
00770	
00780	
00790	
00800	SPECBIND: MOVE TT,SP
00810	SPEC1:	LDB R,[POINT 13,(T),ACFLD]
00820		CAILE R,17
00830		JRST SPECX
00840		SKIPE R
00850		MOVE R,(R)
00860		HLL R,@(T)	;$$AGAIN SAVE THE POOR LITTLE ATOM POINTER
00870		EXCH R,@(T)
00880		HRLI R,@(T)
00890		PUSH SP,R
00900		AOJA T,SPEC1
00910	SPECX:	PUSH SP,TT
00920		JRST (T)
00930	
00940	;random special case compiler run time routines
00950	
00960	%AMAKE:	HRRZ B,SP	;make alist for fsubr that requires it
00970		ADD B,SPNM	;*** MAKE IT A SPDL POINTER
00980		POPJ P,
00990	
01000	%UDT:	PUSHJ P,EPRNT1	;error print for undefined computed go tag
01010		STRTIP [SIXBIT /UNDEFINED COMPUTED GO TAG IN !/]
01020		HRRZ R,(P)
01030		PUSHJ P,ERSUB3
01040		SETOM ERRTYP	;*** SET "SERIOUS" ERROR
01050		JRST ERREND
01060	
01070	%LCALL:	MOVN A,T	;set up routine for compile lsubr
01080		ADDI A,INUM0
01090		ADDI T,(P)
01100		PUSH P,T
01110		PUSHJ P,(3)
01120		POP P,T
01130		SUBI T,(P)
01140		HRLI T,-1(T)
01150		ADD P,T
01160		POPJ P,
01170		PAGE
     
00010		SUBTTL ARRAY SUBROUTINES  
00020	
00030	;*** MODIFIED TO HANDLE CASE WHERE BPS EXTENDS BEYOND 177777
00040	ARRAY:	PUSHJ P,ARRAYS
00050		HRRI AR2A,1(R)
00060		MOVE A,AR2A	; CUMULATED SIZE
00070		PUSH R,[0]	; FILL THEM ALL WITH NIL'S
00080		AOBJN A,.-1
00090	ARREND:	MOVE A,BPPNR#
00100		MOVEM AR2A,-1(A)
00110		MOVEI A,1(R)
00120		PUSHJ P,FIX1A		;*** FIXED TO HANDLE NON-INUMS
00130		EXCH A,VBPORG(S)	;*** RETURN ADDRESS OF ARRAY
00140		POPJ P,
00150	
00160	ARRAYS:	PUSH P,A
00170		MOVE A,VBPORG(S)
00180		PUSHJ P,NUMVAL		;*** FIXED TO HANDLE NON-INUMS
00190		MOVEM A,BPPNR
00200		MOVE A,VBPEND(S)
00210		PUSHJ P,NUMVAL		;*** DITTO
00220		MOVNI A,-2(A)	
00230		ADD A,BPPNR	;bporg-bpend+2
00240		HRLM A,BPPNR	;= BPORG-BPEND+2,,BPORG
00250		POP P,A
00260		HRRZ AR1,(A)	;(cdr l)
00270		HLRZ A,(A)	;(car l)name
00280		HRRZ B,BPPNR
00290		ADDI B,2
00300		MOVEI C,SUBR(S)
00310		PUSHJ P,PUTPROP	;(PUTPROP<NAME><BPORG>SUBR)
00320		HLRZ A,(AR1)	;(cadr l)mode
00330		PUSH P,AR1
00340		PUSHJ P,EVAL	;eval mode
00350		POP P,AR1
00360		MOVEM A,AMODE#	; STORE MODE AWAY
00370		MOVEI C,44	; C IS BITS/ELEMENT
00380		JUMPE A,ARRY1	; NIL=REAL NUMBERS MODE
00390		MOVEI C,-INUM0(A)
00400		CAILE A,INUMIN
00410		JRST ARRY1	; NUMERIC MODE
00420		MOVEI C,22	; NON-NUMERIC = T = S-EXPRS 2/WORD
00430		HRRZ A,BPPNR
00440		MOVE B,GCMKL
00450		PUSHJ P,CONS	; CONS BPORG ONTO GCMKL
00460		MOVEM A,GCMKL
00470	ARRY1:	MOVEM C,BSIZE#	; NUMBER OF BITS/ELEMENT
00480		MOVEI A,44
00490		IDIV A,C
00500		MOVEM A,NBYTES#	; NUMBER OF ELEMENTS/WORD
00510		HRRZ A,(AR1)	;(cddr l)bound pair list
00520		JSP TT,ILIST	; PUTS REVERSE OF SIZES ONTO STACK,T=-# OF DIMS.
00530		AOS R,BPPNR	; R=BPORG-BPEND+2,,BPORG+1
00540		MOVEI AR1,1	;ar1 is array size
00550		MOVEI AR2A,0	;ar2a is cumulative residue
00560		AOJGE T,ARRYS	;single dimension
00570		MOVEI D,A-1
00580		SUB D,T	;d is next ARGUMENT ac for array code generation
00590	ARRY2:	PUSHJ P,ARRB0	;BUILDS IMULI (D),OFFSET/ ADD(D),(D)+1
00600		TLC TT,(IMULI)
00610		DPB D,[POINT 4,TT,ACFLD]
00620		PUSH R,TT
00630		CAIN D,A
00640		JRST ARRY3
00650		MOVSI TT,(ADD)
00660		ADDI TT,1(D)
00670		DPB D,[POINT 4,TT,ACFLD]
00680		PUSH R,TT
00690		SOJA D,ARRY2
00700	
00710	ARRB0:	POP P,TT	; REMOVE ELEMENT ON STACK BELOW EXIT
00720		EXCH TT,(P)
00730		CAILE TT,INUMIN	; IS IT A NUMBER
00740		JRST ARRB1	; YES
00750		HLRZ A,(TT)	; NO, A DOTTED PAIR
00760		HRRZ TT,(TT)
00770	;	SUBI TT,(A)
00780	;	ADDI TT,1
00790	;	JRST ARRB2
00800		SKIPA TT,1(TT)	;WMT
00810	
00820	ARRB1:	MOVEI A,INUM0
00830	;	SUB TT,A
00840		SUBI TT,(A)	;WMT
00850	;WMT- TT HAS THE LENGTH, A IS THE LOWER BOUND AS AN INUM
00860		IMUL A,AR1	;WMT- WAS ARRB2:
00870		IMULB AR1,TT
00880	;%%	ADDM A,AR2A
00890		ADD	AR2A,A		;%% SOME PEOPLE HAVE PROBLEMS
00900		POPJ P,
00910	
00920	ARRY3:	PUSH R,[ADD A,B]
00930	ARRYS:	PUSHJ P,ARRB0
00940		HRRZ TT,BPPNR
00950		MOVEM AR2A,(TT)
00960		HRLI TT,(SUB A,)
00970		PUSH R,TT
00980		PUSH R,[JUMPL A,ARRERR]
00990		MOVE TT,AR1
01000		HRLI TT,(CAIL A,)
01010		PUSH R,TT
01020		PUSH R,[JRST ARRERR]
01030		IDIV AR1,NBYTES	;calc #words in array
01040		SKIPE AR2A	;correct for remainder non-zero
01050		ADDI AR1,1
01060		MOVE TT,NBYTES
01070		SOJE TT,ARRY6
01080		ADDI TT,1
01090		HRLI TT,(IDIVI A,)
01100		PUSH R,TT
01110		MOVN TT,BSIZE
01120		LSH TT,14
01130		HRLI TT,(IMULI B,)
01140		PUSH R,TT
01150		MOVEI TT,44+200
01160		SUB TT,BSIZE
01170		LSH TT,6
01180	ARRY6:	ADD TT,BSIZE
01190		LSH TT,6
01200		SKIPE AR2A,AMODE
01210		CAIL AR2A,INUMIN
01220		ADDI TT,40	;mode not = t
01230		TLC TT,(HRLZI C,)
01240		PUSH R,TT
01250		MOVEI TT,4(R)
01260		HRLI TT,(ADDI C,(A))
01270		PUSH R,TT
01280		PUSH R,[LDB A,C]
01290		HRLZI AR2A,(POPJ P,)
01300		SKIPN TT,AMODE
01310		MOVE AR2A,[JRST FLO1A]
01320		CAIL TT,INUMIN
01330		MOVE AR2A,[JRST FIX1A]
01340		PUSH R,AR2A
01350		MOVS AR2A,AR1
01360		MOVNS AR2A
01370		POPJ P,
01380	
01390	PAGE
     
00010	;*** MODIFIED TO HANDLE CASE WHEN BPS EXTENDS BEYOND 177777
00020	GTBLK:	PUSH P,B		;*** SAVE GC FLAG
00030		MOVNI C,-INUM0(A)	;##COMPUTE NEGATIVE LENGTH
00040		MOVE A,VBPORG(S)	;## GET BPORG
00050		PUSHJ P,NUMVAL		;## CONVERT (*** FIXED FOR NON-INUMS)
00060		HRLM C,(A)		;## MOVE TO BPORG INFO FOR (GC)
00070		HRRM A,(A)		;##
00080		PUSH P,A		;*** SAVE ADDR OF BLOCK
00090		AOS R,(A)		;## ADD ONE TO INFO AND MOVE TO R
00100		SUBI R,1		;## SET PUSH DOWN POINTER(ASSUME POINTER BLOCK)
00110		SKIPN -1(P)		;## IS IT A POINTER BLOCK? (***)
00120		SUBI R,1		;## NO
00130		MOVE A,VBPEND(S)	;## GET BPEND
00140		PUSHJ P,NUMVAL		;## CONVERT (*** FIXED FOR NON-INUMS)
00150		MOVNS A			;*** CONVERT TO NEGATIVE
00160		ADD A,R			;## BPORG-BPEND +(0 OR 1) (***)
00170		HRLI R,(A)		;## MOVE TO R FOR TESTING FOR BPS EXCEEDED
00180		PUSH R,[0]		;## CLEAR THE SPACE, NOTE THAT IF IT IS NOT
00190		AOJN C,.-1		;	c WE WILL ALSO CLEAR THE INFO LOCATION
00200		HRRZI A,1(R)		;## COMPUTE NEW BPORG (***)
00210		PUSHJ P,FIX1A		;*** FIXED FOR NON-INUMS
00220		HRRM A,VBPORG(S) 
00230		POP P,A			;*** GET ADDRESS OF BLOCK
00240		POP P,B			;*** GET GC FLAG
00250		CAIN B,0		;## IF IT WAS NOT A POINTER BLOCK, DONE
00260		POPJ P,
00270		MOVE B,GCMKL		;## GET GC'S LIST
00280		PUSHJ P,CONS		;## CONS
00290		MOVEM A,GCMKL		;## SAVE IT
00300		HLRZ A,(A)		;GET THE OLD BPORG BACK
00310		AOJA A,.-5		;## ADD ONE AND RETURN
00320	
00330	
00340	BLKLST:	PUSH	P,A		;## SAVE LIST
00350		CAIE	B,0		;## BLK LENGTH GIVEN
00360		SKIPA	A,B		;## YES
00370		PUSHJ	P,LENGTH	;## NO, USE LENGTH OF LIST
00380		MOVEI	B,(A)		;## GET A POINTER BLOCK FROM GTBLK
00390		PUSHJ	P,GTBLK
00400		POP	P,B		;## GET LIST BACK
00410		PUSH	P,A
00420		HRRZI	R,-1(A)		;## SET UP PDL
00430		HLRE	C,(R)		;## NEG LENGTH FROM GC INFO.
00440	BLKLS1:	HRRI	A,1(A)		;## BUMP A FOR CDR
00450	
00460	IFN	OLDNIL<			;## IF(CDR NIL)#NIL
00470		TRNE	B,-1		;## END OF LIST?
00480		SKIPA	B,(B)		;## NO
00490		SETZ	B,		;## YES,  REST  OF BLOCK IS NIL
00500		>
00510	
00520	IFE OLDNIL<
00530		MOVE	B,(B)		;##  IF  (CDR  NIL )=NIL
00540		>
00550	
00560		HLL	A,B		;## GET (CAR LIST)
00570		PUSH	R,A		;## AND STORE
00580		AOJL	C,BLKLS1	;## SEE IF DONE
00590		HLLZM	A,(R)		;## SET (CDR (LAST BLOCK)) TO NIL
00600		JRST	POPAJ		;## AND RETURN POINTER TO THE BLOCK
00610	
00620	
00630	EXARRAY: PUSH P,A
00640		HLRZ A,(A)
00650		PUSHJ P,GETSYM
00660		JUMPE A,POPAJ
00670		PUSHJ P,NUMVAL
00680		EXCH A,(P)
00690		PUSHJ P,ARRAYS
00700		POP P,A
00710		HRRM A,-2(R)
00720		HRR AR2A,A
00730		JRST ARREND
00740	
00750	STORE:	PUSH P,A
00760		PUSHJ P,CADR
00770		PUSHJ P,EVAL	;value to store
00780		EXCH A,(P)
00790		HLRZ A,(A)
00800		PUSHJ P,EVAL	;byte pointer returned in c
00810		POP P,A
00820	NSTR:	PUSH P,A
00830		TLNE C,40
00840		PUSHJ P,NUMVAL	;numerical array
00850		DPB A,C
00860		JRST POPAJ
00870		
00880		PAGE
     
00010		SUBTTL EXAMINE, DEPOSIT , ETC 
00020	
00030	BOOLE:	MOVE TT,T
00040		ADDI TT,2(P)
00050		MOVE A,-1(TT)
00060		SUBI A,INUM0
00070		DPB A,[POINT 4,BOOLI,OPFLD-2]
00080		PUSHJ P,BOOLG
00090		MOVE C,A
00100	BOOLL:	PUSHJ P,BOOLG
00110		XCT BOOLI
00120	REMOTE<
00130	BOOLI:	CLEARB C,A>
00140		JRST BOOLL
00150	
00160	BOOLG:	CAIL TT,(P)
00170		JRST BOOL1
00180		MOVE A,(TT)
00190		PUSHJ P,NUMVAL
00200		AOJA TT,CPOPJ
00210	
00220	BOOL1:	HRLI T,-1(T)
00230		ADD P,T
00240		POP P,B
00250		JRST FIX1A
00260	
00270	EXAMINE: PUSHJ P,NUMVAL
00280		MOVE A,(A)
00290		JRST FIX1A
00300	
00310	DEPOSIT: MOVE C,B
00320		PUSHJ P,NUMVAL
00330		EXCH A,C
00340		PUSHJ P,NUMVAL
00350		MOVEM A,(C)
00360		JRST MAKNUM
00370	
00380	LSH:	MOVEI C,-INUM0(B)
00390		PUSHJ P,NUMVAL
00400		LSH A,(C)
00410		JRST FIX1A
00420	
00430		PAGE
     
00010		SUBTTL GARBAGE COLLECTER   
00020	
00030	;garbage collector
00040	
00050	GC:	MOVEI R,1	;*** COPY NIL INTO ACS 1-10 SO GARBAGE
00060		BLT R,10	;*** WON'T BE MARKED
00070		PUSHJ P,AGC
00080		JRST FALSE
00090	
00100	AGC:	SETOM	GCFLAG	;SET GCFLAG INCASE OF USER CONTROL-C
00110		MOVEM R,RGC#
00120	GCPK1:	PUSH P,PA3
00130		PUSH P,PA4
00140	IFE OLDNIL	<PUSH	P,NILHD		;*** FAKE ATOM HEADER OF NIL>
00150		PUSH P,UBDPTR	;special atom UNBOUND; not on OBLIST
00160		PUSH P,MKNAM3
00170		PUSH P,GCMKL	;i/o channel input lists and arrays
00180		PUSH P,BIND3
00190		PUSH P,INITF
00200		PUSH P,INITF1	;## INIT FILE LIST
00210	GCPK2:	PUSH P,[XWD 0,GCP6]	;this is a return address
00220		JRST GCP4
00230	REMOTE<
00240	GCP4:	MOVEI S,X	;pdlac, .=bottom of reg pdl + 1
00250	GCP41:	BLT S,X	;save ACs 0 through 10 at bottom of regpdl	;pdlac+n
00260	GCP2:	CLEARB 0,X	;gc indicator, init. for bit table zero
00270		MOVE A,C3GC
00280	GCP5:	BLT A,X	;zero bit tables, .=top of bit tables
00290		JRST GCRET1>
00300	GCRET1:	SKIPN GCGAGV
00310		JRST GCP5A
00320		SKIPN F
00330		STRTIP [SIXBIT /←FREE STG EXHAUSTED←!/]
00340		SKIPN FF
00350		STRTIP [SIXBIT /←FULL WORD SPACE EXHAUSTED←!/]
00360	
00370	GCP5A:	MOVEI TT,1
00380		MOVEI A,0
00390		RUNTIM A,	;time
00400		MOVNS A
00410		ADDM A,GCTIM#
00420		MOVE C,GCP3#	;.=bottom of reg pdl
00430	GCP6B:	MOVE S,P
00440		HLL C,P
00450		MOVEI B,0
00460	GC1:	CAMN C,S
00470		POPJ P,
00480		HRRZ A,(C)
00490	GCPI:	CAMGE A,GCP#	;.=bottom of bit tables
00500	REMOTE<
00510	GCPP1:
00520	XXX5:	FS>
00530		CAMGE A,GCPP1
00540		JRST GCEND
00550		CAML A,GCP1#	;.=bottom of full word space (fws)
00560		JRST GCMFW
00570		MOVE F,(A)
00580		LSHC A,-5
00590		ROT B,5
00600		MOVE AR1,GCBT(B)
00610		TDOE AR1,@GCBTP2	;bit tab- (fs←-5), .=magic number for sync
00620		JRST GCEND
00630		MOVEM AR1,@GCBTP1	;bit tab- (fs←-5)
00640		PUSH P,F
00650		HLRZ A,F
00660		JRST GCPI
00670	REMOTE<
00680	GCBTP1:	XWD A,0
00690	GCBTP2:	XWD A,0
00700	GCMFWS:	XWD A,0>
00710	
00720	GCMFW:	MOVEI AR1,@GCMFWS	;.=- bottom of fws
00730		IDIVI AR1,44
00740		MOVNS AR2A
00750		LSH AR2A,36
00760		ADD AR2A,C2GC
00770		DPB TT,AR2A
00780	GCEND:	CAMN P,S
00790		AOJA C,GC1
00800		POP P,A
00810		HRRZS A
00820		JRST GCPI
00830	REMOTE<
00840	GCMKL:	XWD 0,[XWD [XWD -NIOCH,CHTAB+FSTCH],0]
00850	C2GC:	XWD 430100+AR1,X	;.=bottom of fws bit table
00860	C3GC:	0>	;(bottom bit table)bottom bit table+1
00870	GCBT:	XWD 400000,0
00880	ZZ==1B1
00890	XLIST
00900	REPEAT ↑D31,<ZZ
00910	ZZ==ZZ/2>
00920	LIST
00930	GCP6:	HRRZ R,SC2
00940	GCP6C:	CAILE R,(SP)	;mark sp (***Ch. from CAIL 4/24/77)
00950		JRST GCP6A
00960		PUSH P,(R)
00970		HRRZ C,P
00980		PUSHJ P,GCP6B
00990		SUB P,[XWD 1,1]
01000		AOJA R,GCP6C
01010	
01020	GCP6A:	HRRZ R,GCMKL	;mark arrays
01030	GCP6D:	JUMPE R,GCSWP
01040		HLRZ A,(R)
01050		MOVE D,(A)
01060	GCP6E:	PUSH P,(D)
01070		HRRZ C,P
01080		PUSH P,(D)
01090		MOVSS (P)
01100		PUSHJ P,GCP6B
01110		SUB P,[XWD 2,2]
01120		AOBJN D,GCP6E
01130		HRRZ R,(R)
01140		JRST GCP6D
01150	
01160	GFSWPP:
01170	PHASE 0
01180	GFSP1==.
01190		JUMPL S,.+3
01200		HRRZM F,(R)
01210		HRRZ F,R
01220		ROT S,1
01230		AOBJN R,.-4
01240		MOVE S,(D)
01250		HRLI R,-40
01260		AOBJN D,GFSP1
01270	
01280	LPROG==.
01290		JRST GFSPR
01300	
01310	DEPHASE
01320	;garbage collector sweep
01330	
01340	GCSWP:	MOVSI R,GFSWPP
01350		BLT R,LPROG
01360		MOVEI F,NIL	;will become movei f,-1
01370		MOVE D,C3GCS
01380		JRST	XXX3
01390	REMOTE<
01400	XXX3:	MOVEI R,FS	;$$ANOTHER FOOLIST REMNANT
01410	GCBTL1:	HRLI R,X	;-(32-<fs&37>
01420		MOVE S,(D)
01430	GCBTL2:	ROT S,X	;fs&37
01440		AOBJN D,GFSP1
01450		JRST GFSPR>
01460	GFSPR:	MOVE A,C1GCS
01470		MOVE B,C2GCS
01480		PUSHJ P,GCS0
01490		MOVE	B,FF		; GET POINTER TO FULL SPACE LIST
01500		PUSHJ	P,CNTLST	; AND GO COUNT IT
01510		MOVEM	A,LFWCNT	; SAVE COUNT FOR LATER
01520		AOS	INSFUL		; ASSUME INSUFFICIENT FULL SPACE ERROR...
01530		CAMLE	A,FULLIM	; COMPARE WITH MIN. THRESHOLD FOR FULL WORDS
01540		 SETOM	INSFUL		; CLEAR FLAG IF SUFFICIENT SPACE
01550		MOVE	B,F		; GET POINTER TO FREE SPACE LIST
01560		PUSHJ	P,CNTLST	; COUNT FREE SPACE
01570		AOS	INSFRE		; ASSUME INSUFFICIENT FREE SPACE
01580		CAMLE	A,FRELIM	; COMPARE WITH MIN. TRHESHOLD FOR FREE SPACE
01590		 SETOM	INSFRE		; CLEAR FLAG IS SUFFICIENT SPACE RECLAIMED
01600		MOVEM	A,LFSCNT	; SAVE COUNT FOR LATER
01610		SKIPN	GCGAGV		; GC GAG ON ?
01620		 JRST	GCSPI1		;  YES...DON'T GIVE RESULTS OF GC.
01630		MOVEI	R,TTYO		; SET ADDRESS OF TTY OUTPUT ROUTINE
01640		PUSHJ	P,PRINL1	; GO PRINT LENGTH OF FREE SPACE LIST
01650		STRTIP	[SIXBIT / FREE STG,!/]
01660		MOVE	A,LFWCNT	; RESTORE COUNT OF FULL SPACE LIST
01670		MOVEI	R,TTYO		; AND OUTPUT ROUTINE
01680		PUSHJ	P,PRINL1	; NOW PRINT OUT LENGTH OF FULL WORD LIST
01690		STRTIP [SIXBIT / FULL WORDS AVAILABLE←!/]
01700	GCSPI1:	HRLZ S,GCSP1#	;bottom of reg pdl+1
01710		BLT S,NACS+3	;reload ac's
01720		SUB P,[XWD GCPK2-GCPK1,GCPK2-GCPK1]	;restore p
01730		MOVE R,RGC
01740		MOVEI A,0
01750		RUNTIM A,	;time
01760		ADDM A,GCTIM
01770		MOVE S,ATMOV	;$$RESTORE ATOM OFFSET RELOCATOR (FOOLIST)
01780				;$$HOPEFULLY S IS USED ONLY BY GC AND ATOM RELOCATION
01790		SKIPE CCFLAG	;*** ↑C HIT WHILE GCING?
01800		PUSHJ P,GCINT	;*** YES: GO INTERRUPT
01810		SETZM GCFLAG	;CLEAR GCFLAG
01820		JUMPE F,[ERR3 [SIXBIT /NO FREE STG LEFT!/]]
01830		JUMPE FF,[ERR3 [SIXBIT /NO FW STG LEFT!/]]
01840		SKIPN	INSFRE		; DID INSUFF. FREE SPACE FLAG JUST GET SET?
01850		 ERR2	[SIXBIT /NOT ENOUGH FREE STG. LEFT!/]
01860		SKIPN	INSFUL		; DID INSUFF. FULL SPACE FLAG JUST GET SET?
01870		 ERR2	[SIXBIT /NOT ENOUGH FULL WORDS LEFT!/]
01880		POPJ P,
01890	
01900	GCINT:	POP P,CCFLAG	;*** ↑C - GET CONTINUE ADDR
01910		SETZM GCFLAG	;*** CLEAR GCFLAG
01920		JRST CCINT1	;*** AND ENTER ↑C TRAP ROUTINE
01930	
01940	; [UT]	ADDED CODE TO CHECK FOR INSUFFICIENT SPACE RECLAIMED BY GARBAGE
01950	;	COLLECTION, AND QUIT BEFORE RUNNING OUT COMPLETELY.
01960	
01970	;	SWITCHES  HAVE FOLLOWING SETTINGS:
01980	;				-1	=>	CLEAR
01990	;				0	=>	JUST SET (GIVE MSG THIS TIME)
02000	;				>0	=>	PREVIOUSLY SET (NO MSG)
02010	REMOTE	<
02020	INSFRE:	EXP	-1		; FLAG TO INDICATE INSUFFICIENT FREE SPACE
02030	INSFUL:	EXP	-1>		; FLAG TO INDICATE INSUFFICIENT FULL SPACE
02040	
02050	GCS0:	MOVEI FF,0
02060	GCS1:	ILDB C,B
02070		JUMPN C,GCS2
02080		HRRZM FF,(A)
02090		HRRZ FF,A
02100	GCS2:	AOBJN A,GCS1
02110		POPJ P,
02120	
02130	REMOTE<
02140	C1GCS:	0	;(- length of fws) bottom of fws
02150	C2GCS:	XWD 100,0	;.=bottom of fws bit table
02160	C3GCS:	0	;-n wds in bt,,bt
02170	>
02180	GCGAG:	EXCH A,GCGAGV#
02190		POPJ P,
02200	
02210	GCTIME:	MOVE A,GCTIM
02220		JRST FIX1A
02230	
02240	TIME:	MOVEI A,0
02250		RUNTIM A,
02260		JRST FIX1A
02270	
02280	DTIME:	MSTIME A,	;*** TIME OF DAY
02290		JRST FIX1A
02300	
02310	DODATE:	DATE A,		;*** DATE IN FORM (MO DAY YEAR-1900)
02320		IDIVI A,↑D31
02330		MOVEI T,INUM0+1(B)	;day
02340		IDIVI A,↑D12
02350		MOVEI TT,INUM0+1(B)	;month
02360		ADDI A,INUM0+↑D64	;year-1900
02370		PUSHJ P,NCONS
02380		MOVE B,T
02390		PUSHJ P,XCONS
02400		MOVE B,TT
02410		JRST XCONS
02420	
02430	SPEAK:	MOVE A,CONSVAL#
02440		JRST FIX1A
02450	
02460	CNTLST:	SETZ	A,		; COUNT LENGTH OF LIST POINTED BY REG B.
02470		JUMPE	B,CPOPJ		; LIST SHOULD END WITH NIL...BE CAREFUL!!
02480		HRRZ	B,(B)		; LOOK AT NEXT ELEMENT OF LIST
02490		AOJA	A,.-2		; AND LOOK AT THAT
02500	
02510	; [UT]	REVISED ROUTINES TO COUNT AVAILABLE FREE SPACE AND FULL SPACE
02520	;
02530	FSCNT:	TRZA	B,-1		; COUNT FREE SPACE (SET UP TO GET FS PTR)
02540	FWCNT:	MOVEI	B,1		; COUNT FULL SPACE (SET UP TO GET FULL SP. PTR)
02550		MOVE	B,F(B)		; GET ONE POINTER OR THE OTHER
02560		PUSHJ	P,CNTLST	; COUNT LENGTH OF THAT LIST
02570		JRST	FIX1A		; AND CONVERT IT TO A NUMBER
02580	
02590	; [UT]	SET MINIMUM SPACE THRESHOLDS
02600	;WMT- LIMIT SETTING CODE
02610	RPDLIM:	PUSHJ	P,SETLIM	; REG PDL LIMIT
02620	SPDLIM:	PUSHJ	P,SETLIM	; SPEC PDL LIMIT
02630	FSLIM:	PUSHJ	P,SETLIM	; FREE SPACE LIMIT
02640	FWLIM:	PUSHJ	P,SETLIM	; FULL SPACE LIMIT
02650	; THOSE PUSHJ'S ARE JUST TO SAVE .+1, THERE WILL BE NO POPJ
02660	SETLIM:	PUSHJ	P,NUMVAL	; GO GET VALUE
02670		POP	P,B		; GET BACK   FLAGS,,ADDRESS
02680		SUBI	B,SPDLIM	; COMPUTE INDEX
02690		EXCH	A,REGLIM(B)	; HERE IS WHERE IT'S STORED
02700		JRST	FIX1A		; GO MAKE A NUMBER OUT OF IT
02710	
02720	REMOTE<
02730	REGLIM:	DEC	100		; REGULAR PUSH DOWN LIMIT
02740	SPELIM:	DEC	100		; SPECIAL PUSH DOWN LIMIT
02750	FRELIM:	DEC	100		; FREE LIST LIMIT
02760	FULLIM:	DEC	20		; FULL LIST LIMIT
02770	LFWCNT:	Z			; LAST FREE WORD COUNT
02780	LFSCNT:	Z>			; LAST FREE SPACE COUNT
02790	
02800	GCWORDS:MOVE	A,LFWCNT	;WMT-GET LAST FREE WORD COUNT
02810		PUSHJ	P,FIX1A		;WMT-MAKE INTEGER
02820		PUSH	P,A
02830		MOVE	A,LFSCNT	;WMT-DO THE SAME FOR FREE SPACE COUNT
02840		PUSHJ	P,FIX1A
02850		POP	P,B
02860		JRST	CONS		;WMT-RETURN (LFSCNT . LFWCNT)
02870		
02880		PAGE
     
00010		SUBTTL	SYMBOL TABLE ACCESSING ROUTINES
00020	
00030	
00040	R50MAK:	PUSHJ P,PNAMUK
00050		PUSH C,[0]
00060		HRLI C,700
00070		HRRI C,(SP)
00080		MOVEI B,0
00090	MK3:	ILDB A,C
00100		LDB A,R50FLD
00110		CAMGE B,[50*50*50*50*50]
00120		SKIPN A
00130		POPJ P,
00140		IMULI B,50
00150		ADD B,A
00160		JRST MK3
00170	
00180	
00190	
00200		;## NEW ROUTINES FOR CONVERTING  SYMBOLS TO CONS CELL
00210	
00220	SYMERR:	MOVE	A,B
00230	SYMER1:	PUSHJ	P,EPRINT		;## PRINT OFFENDER
00240		ERR2	[SIXBIT /NOT A CONS CELL !/]
00250		;## **CAUSES ERROR IF NOT IN FREE STORAGE**
00260	RGTSYM:	PUSHJ	P,GETSYM
00270		JUMPE	A,CPOPJ		;*** FORGET IT IF NOT THERE
00280		PUSHJ	P,NUMVAL	;## CONVERT TO REAL ADDRESS
00290		ADDI	A,(S)		;## ADD  RELOCATION
00300		CAIL	A,FS(S)		;## LESS THAN FS(S) IS NOT CONS CELL
00310		CAML	A,FWSO		;## FS(S)<= A < FWSO IS A CONS CELL
00320		JRST	SYMER1
00330		JRST	FIX1A		;*** CONVERT BACK TO A NUMBER
00340	
00350	GETSYM:	PUSHJ P,R50MAK
00360		TLO B,040000	;04 for globals
00370		MOVE C,.JBSYM
00380	MK7:	CAMN B,(C)
00390		JRST MK10	;found
00400		AOBJP C,.+2
00410		AOBJN C,MK7
00420		TLC B,140000	;10 for locals
00430		TLNE B,100000
00440		JRST MK7-1
00450		JRST FALSE
00460	
00470	MK10:	MOVE A,1(C)	;value
00480		JRST FIX1A
00490	
00500	
00510		;## ROUTINE TO STORE A CONS CELL SO THAT IT CAN BE
00520		;## REFERENCED VIA  ,CELL(S) I.E. THRU INDEX REG. S
00530		;## ERROR IF NOT LEGITIMATE CONS CELL
00540	RPTSYM:	CAIL	B,FS(S)		;## FS(S) =< B <FWSO IS A LEGIT
00550		CAML	B,FWSO		;## CONS CELL, ALL ELSE IS ERROR
00560		JRST	SYMERR		;## ERROR
00570		SUBI	B,(S)		;## STRIP OFF RELOCATION
00580	
00590	PUTSYM:	PUSH P,B
00600		PUSHJ P,R50MAK
00610		MOVE A,B
00620		TLO A,040000	;make global
00630		SKIPL .JBSYM
00640		AOS .JBSYM	;increment initial symbol table pointer
00650		MOVN B,[XWD 2,2]
00660		ADDB B,.JBSYM
00670		MOVEM A,(B)	;name
00680		POP P,1(B)	;value
00690		JRST FALSE
00700	
00710	PATCH:	BLOCK 20
00720	
00730		PAGE
     
00010		SUBTTL	SPRINT -- THE PRETTY PRINTER
00020		IFN	SPRNT,<		;*** REPLACED BY COMPILED CODE
00030	
00040	
00050	;THIS IS THE NEW IMPROVED VERSION OF SPRINT
00060	 
00070	;  0(P) = A
00080	; -1(P) = B
00090	; -2(P) = C
00100	; -3(P) = M
00110	; -4(P) = N
00120	; -5(P) = X
00130	
00140	
00150	SPRINT:	SUBI B,INUM0
00160	SPRNT2:	PUSH P,A
00170		PUSH P,B
00180		SETZM M#
00190		SETZB B,CSW#
00200		MOVEM P,STP#
00210		PUSHJ P,DEPTH
00220		SKIPN B,M
00230		JRST .+6
00240		MOVE A,LINL
00250		SUB A,B
00260		SUB A,B
00270		IDIV A,B
00280		CAILE A,14
00290		MOVEI A,14
00300		MOVEM A,CUT#
00310		MOVE A,0(P)
00320		IDIV A,LINL
00330		CAIG B,0
00340		ADD B,LINL
00350		MOVEM B,0(P)
00360		MOVEI C,0
00370		JRST .+3
00380	 
00390	ISPRIN:	PUSH P,A
00400		PUSH P,B
00410		PUSH P,C
00420		PUSH P,[0]
00430		PUSH P,[0]
00440		PUSH P,[0]
00450		MOVE A,B
00460		SUB B,LINL
00470		JUMPLE B,.+3
00480		MOVE A,B
00490		MOVEM A,-4(P)
00500		PUSHJ P,POS
00510		MOVE A,-5(P)
00520		PUSHJ P,PATOM
00530		JUMPN A,SPRN1
00540		MOVE B,LINL
00550		SUB B,-4(P)
00560		ADDI B,1
00570		MOVEM B,0(P)
00580		SUB B,-3(P)
00590		MOVE A,-5(P)
00600		PUSHJ P,FLATLE
00610		JUMPN A,SPRN1
00620		MOVEI A,50
00630		PUSHJ P,TYO
00640		AOS -4(P)
00650		SOS 0(P)
00660		PUSHJ P,SPRN94
00670		JUMPN A,SPRN13
00680		HLRZ A,@-5(P)
00690		CAIN A,LAMBDA(S)
00700		JRST LAM
00710		CAIN A,PROGAT+1(S)
00720		JRST PRG
00730		PUSHJ P,PATOM
00740		JUMPN A,SPRN3
00750		MOVE B,0(P)
00760		CAILE B,20
00770		MOVEI B,20
00780		HLRZ A,@-5(P)
00790		PUSHJ P,FLATLE
00800		JUMPE A,SPRN12
00810		MOVEM A,-1(P)
00820	SPRN4:	HRRZ A,@-5(P)
00830		MOVEM A,-2(P)
00840		PUSHJ P,SPRN92
00850		JUMPN A,SPRN8
00860		MOVE B,-1(P)
00870		CAMG B,CUT
00880		JRST SPRN2
00890		SKIPE CSW
00900		JRST SPRN8
00910		MOVE A,0(P)
00920		SUB A,B
00930		SUBI A,1
00940		MOVEM A,-1(P)
00950	SPRN5:	MOVE B,-1(P)
00960		HLRZ A,@-2(P)
00970		PUSHJ P,FLATLE
00980		JUMPE A,SPRN8
00990		HRRZ A,@-2(P)
01000		MOVEM A,-2(P)
01010		PUSHJ P,SPRN92
01020		JUMPE A,SPRN5
01030		HRRZ B,@-2(P)
01040		JUMPN B,.+3
01050		MOVE B,-1(P)
01060		SOJA B,SPRN7
01070		HRRZ A,@-2(P)
01080		PUSHJ P,FLATSI
01090		SUBI A,INUM0-4
01100		SUB A,-1(P)
01110		MOVN B,A
01120	SPRN7:	SUB B,-3(P)
01130		HLRZ A,@-2(P)
01140		PUSHJ P,FLATLE
01150		JUMPN A,SPRN18
01160	SPRN8:	PUSHJ P,SPRN98
01170	SPRN9:	HRRZ A,@-5(P)
01180		MOVEM A,-5(P)
01190		CAMN A,-2(P)
01200		JRST SPRN11
01210		PUSHJ P,POS6
01220		PUSHJ P,SPRN99
01230		JRST SPRN9
01240	SPRN2:	PUSHJ P,SPRN97
01250		MOVE A,-1(P)
01260		ADDI A,1
01270		ADDM A,-4(P)
01280	SPRN12:	PUSHJ P,SPRN95
01290	SPRN23:	HRRZ A,@-5(P)
01300		MOVEM A,-5(P)
01310	SPRN11:	PUSHJ P,SPRN94
01320		JUMPE A,SPRN12
01330	SPRN13:	HRRZ A,@-5(P)
01340		JUMPE A,.+4
01350		PUSHJ P,FLATSI
01360		SUBI A,INUM0-3
01370		ADDM A,-3(P)
01380		AOS -3(P)
01390		MOVE C,-3(P)
01400		PUSHJ P,SPRN96
01410	SPRN16:	HRRZ A,@-5(P)
01420		JUMPE A,SPRN17
01430		MOVEI A,40
01440		PUSHJ P,TYO
01450		MOVEI A,56
01460		PUSHJ P,TYO
01470		MOVEI A,40
01480		PUSHJ P,TYO
01490		HRRZ A,@-5(P)
01500		PUSHJ P,PRIN1
01510	SPRN17:	MOVEI A,51
01520		PUSHJ P,TYO
01530		JRST SPRN22
01540	SPRN18:	PUSHJ P,SPRN98
01550		MOVEI A,40
01560		PUSHJ P,TYO
01570		MOVE A,LINL
01580		SUB A,CHCT
01590		ADDI A,1
01600		PUSHJ P,SPRN93
01610		JUMPN A,SPRN21
01620	SPRN19:	PUSHJ P,SPRN99
01630		PUSHJ P,SPRN91
01640		JUMPN A,.+3
01650		PUSHJ P,POS6
01660		JRST SPRN19
01670		PUSHJ P,POS6
01680	SPRN21:	PUSHJ P,SPRN99
01690		JRST SPRN16
01700	LAM:	PUSHJ P,PRIN1
01710		HRRZ A,@-5(P)
01720		MOVEM A,-5(P)
01730		MOVE B,-4(P)
01740		MOVEM B,-1(P)
01750		HLRZ A,0(A)
01760		PUSHJ P,PATOM
01770		MOVEI B,6
01780		CAIE A,NIL
01790		ADDI B,1
01800		ADDM B,-4(P)
01810		PUSHJ P,SPRN94
01820		JUMPN A,SPRN13
01830		PUSHJ P,SPRN95
01840		MOVE B,-1(P)
01850		MOVEM B,-4(P)
01860		JRST SPRN23
01870	PRG:	PUSHJ P,PRIN1
01880		MOVE A,-4(P)
01890		MOVEM A,-1(P)
01900		ADDI A,5
01910		PUSHJ P,SPRN93
01920		JUMPN A,SPRN13
01930		PUSHJ P,SPRN95
01940		MOVE A,0(P)
01950		SUBI A,5
01960		MOVEM A,-2(P)
01970	PRG1:	PUSHJ P,SPRN91
01980		JUMPN A,PRG3
01990		HLRZ A,@-5(P)
02000		PUSHJ P,PATOM
02010		JUMPE A,PRG2
02020		MOVE A,-1(P)
02030		PUSHJ P,POS
02040		PUSHJ P,SPRN99
02050		JRST PRG1
02060	PRG2:	MOVE A,CHCT
02070		CAMG A,-2(P)
02080		PUSHJ P,TERPRI
02090		PUSHJ P,SPRN95
02100		JRST PRG1
02110	PRG3:	HLRZ A,@-5(P)
02120		PUSHJ P,PATOM
02130		JUMPE A,SPRN13
02140		MOVE B,-1(P)
02150		MOVEM B,-4(P)
02160		JRST SPRN13
02170	SPRN1:	MOVE A,-5(P)
02180		PUSHJ P,PRIN1
02190	SPRN22:	SUB P,[XWD 6,6]
02200		JRST FALSE
02210	SPRN3:	PUSHJ P,SPRN99
02220		MOVE A,0(P)
02230		SUB A,CHCT
02240		MOVEM A,-1(P)
02250		CAIG A,24
02260		JRST SPRN4
02270		JRST SPRN23
02280	SPRN91:	HRRZ A,@-6(P)
02290		MOVEM A,-6(P)
02300	SPRN92:	HRRZ A,(A)
02310		JRST PATOM
02320	SPRN93:	MOVEM A,-5(P)
02330		HRRZ A,@-6(P)
02340		MOVEM A,-6(P)
02350	SPRN94:	HRRZ A,@-6(P)
02360		JRST PATOM
02370	SPRN95:	MOVEI C,0
02380	SPRN96:	MOVE B,-5(P)
02390		HLRZ A,@-6(P)
02400		JRST ISPRIN
02410	SPRN97:	HLRZ A,@-6(P)
02420		PUSHJ P,PATOM
02430		JUMPN A,.+3
02440		HLRZ A,@-6(P)
02450		PUSHJ P,PRIN1
02460		HRRZ A,@-6(P)
02470		MOVEM A,-6(P)
02480		POPJ P,
02490	SPRN98:	HLRZ A,@-6(P)
02500		PUSHJ P,PATOM
02510		JUMPN A,CPOPJ
02520	SPRN99:	HLRZ A,@-6(P)
02530		JRST PRIN1
02540	>				;***
02550	 
02560	POS6:	MOVE A,-5(P)
02570	POS:	PUSH P,A
02580		PUSH P,[0]
02590		MOVE A,LINL
02600		SUB A,CHCT
02610		ADDI A,1
02620		PUSH P,A
02630		CAMN A,-2(P)
02640		JRST POS4
02650		CAMG A,-2(P)
02660		JRST .+4
02670		PUSHJ P,TERPRI
02680		MOVEI A,1
02690		MOVEM A,0(P)
02700		SUBI A,1
02710		LSH A,-3
02720		ADDI A,1
02730		LSH A,3
02740		ADDI A,1
02750		MOVEM A,-1(P)
02760		CAMLE A,-2(P)
02770		JRST POS3
02780	POS2:	MOVEI A,11
02790		PUSHJ P,TYO
02800		MOVE A,-1(P)
02810		MOVEM A,0(P)
02820		ADDI A,10
02830		JRST POS2-3
02840	POS5:	MOVEI A,40
02850		PUSHJ P,TYO
02860	POS3:	AOS A,0(P)
02870		CAMG A,-2(P)
02880		JRST POS5
02890	POS4:	SUB P,[XWD 3,3]
02900		POPJ P,
02910	 
02920		IFN	SPRNT,<		;***
02930	FLATLE:	JUMPLE B,ABORT+1
02940		SETZM M
02950		MOVEM B,N#
02960		MOVEM P,STP
02970	SCN:	PUSH P,A
02980		PUSHJ P,PATOM
02990		JUMPN A,EXIT1-6
03000	NA:	AOS A,M
03010		CAMLE A,N
03020		JRST ABORT
03030		HLRZ A,@0(P)
03040		PUSHJ P,SCN
03050		HRRZ A,@0(P)
03060		MOVEM A,0(P)
03070		JUMPN A,.+3
03080		AOS A,M
03090		JRST EXIT1-2
03100		MOVE A,0(P)
03110		PUSHJ P,PATOM
03120		JUMPE A,NA
03130		MOVEI A,4
03140		ADDB A,M
03150		CAMLE A,N
03160		JRST ABORT
03170		MOVE A,0(P)
03180		PUSHJ P,FLATSI
03190		SUBI A,INUM0
03200		ADDB A,M
03210		CAMLE A,N
03220		JRST ABORT
03230	EXIT1:	SUB P,[XWD 1,1]
03240		POPJ P,
03250	ABORT:	MOVE P,STP
03260		JRST FALSE
03270	 
03280	DEPTH:	PUSH P,A
03290		PUSH P,B
03300		PUSHJ P,PATOM
03310		JUMPN A,D2
03320		AOS A,0(P)
03330		CAMLE A,LINL
03340		JRST OUT+1
03350		CAMLE A,M
03360		MOVEM A,M
03370		MOVE A,-1(P)
03380		PUSH P,A
03390		PUSH P,[0]
03400	D1:	HLRZ A,@-3(P)
03410		MOVE B,-2(P)
03420		PUSHJ P,DEPTH
03430		HRRZ A,@-3(P)
03440		MOVEM A,-3(P)
03450		MOVE B,-1(P)
03460		SETCMB C,0(P)
03470		JUMPN C,.+3
03480		HRRZ B,0(B)
03490		MOVEM B,-1(P)
03500		CAMN A,B
03510		JRST OUT
03520		PUSHJ P,PATOM
03530		JUMPE A,D1
03540		SUB P,[XWD 2,2]
03550	D2:	SUB P,[XWD 2,2]
03560		POPJ P,
03570	OUT:	SETOM CSW
03580		MOVE P,STP
03590		JRST @1(P)
03600	>				;***
03610	;
03620	;
03630	;(TAB X) TABS TO POSITION X DOING A (TERPRI) IF NECESSARY
03640	;
03650	.TAB:	PUSHJ	P,NUMVAL
03660		PUSHJ	P,POS		;LET POS IN SPRINT DO THE WORK
03670		JRST	FALSE
03680	
03690		PAGE
     
00010		SUBTTL ALVINE AND LOADER INTERFACES   
00020	
00030	;interface to alvine
00040	
00050	IFN ALVINE,<
00060	ED:	MOVE 10,EDA
00070		JRST (10)
00080		PUSH P,A
00090		HRRZ A,CORUSE
00100		HRRM A,LST
00110		AOS A
00120		HRRM A,EDA#
00130	
00140	
00150		HRRM	A,ED1	;$$SAVE REENTRY TO EDITOR
00160		AOS	ED1#	;$$
00170	
00180		MOVSI A,(SIXBIT /ED/)
00190		SETZ	D,	;THAT RELOCATION AGAIN - SEE BELOW
00200		PUSHJ P,SYSINI
00210		HRLM A,LST	
00220		MOVNS A
00230		PUSHJ P,MORCOR
00240		PUSHJ P,SYSINP+1
00250		POP P,A
00260		JRST ED
00270	GRINDEF:PUSH P,A
00280		PUSHJ P,ED
00290		POP P,A
00300		JRST 2(10)>
00310	
00320	EXCISE:
00330	IFN ALVINE<
00340		MOVEI A,ED+2
00350		HRRM A,EDA>
00360		MOVE A,JRELO
00370		SETZM LDFLG#	;initial loader symbol table flag
00380		CORE A,
00390		JRST .+1
00400		JSP R,IOBRST
00410		JRST TRUE
00420	
00430	PAGE
     
00010	;	lisp loader interface
00020	;***	MODIFIED TO HANDLE CASE WHERE BPS EXTENDS BEYOND 177777
00030	LOAD:	MOVEM A,LDPAR#
00040		AOS A,CORUSE
00050		MOVEM A,OLDCU#
00060		SKIPN LDPAR
00070		JRST LOAD2
00080		MOVE A,VBPORG(S)
00090		PUSHJ P,NUMVAL		;*** FIXED FOR NON-INUM ADDRESSES
00100	LOAD2:	MOVEM A,RVAL#	;final destination of loaded code
00110		MOVSI A,(SIXBIT /LOD/)
00120		SETZ	D,
00130		PUSHJ P,SYSINI
00140		SUBI A,150	;extra room for locations 0 to 137 and slop
00150		PUSH P,A
00160		MOVNS A		;length(loader)
00170		HRRZM A,LODSIZ#
00180		PUSHJ P,MORCOR	;expand core for loader
00190		MOVEM A,LOWLSP#	;location of blt'ed low lisp
00200		MOVN B,(P)	;length(loader)
00210		ADD B,A
00220		MOVEM B,HVAL#	;temporary destination of loaded code
00230		HRLI A,0
00240		MOVE D,A	;THIS IS THE RELOCATION, THE LOADER WILL SAVE IT
00250		BLT A,(B)	;blt up low lisp
00260		MOVEI A,CCBLKL(D)	;***
00270		HRRM A,.JBINT		;*** SET NEW ↑C TRAP BLOCK
00280		HLL A,NAME+3(D)	;-length(loader)
00290		HRRI A,137-1
00300		PUSHJ P,SYSINP
00310		SKIPE LDFLG(D)
00320		JRST LOAD3
00330		SETOM LDFLG(D)
00340		MOVSI A,(SIXBIT /SYM/)
00350		PUSHJ P,SYSINI
00360		MOVNS A		;length symbols
00370		PUSHJ P,MORCOR	;expand core for symbols
00380		SKIPGE B,.JBSYM
00390		SOS B		;if no symbol table, use original .JBsym
00400		HLRZ A,NAME+3(D)	;-length(symbols)
00410		ADDB A,B
00420		HLL A,NAME+3(D)	;symbol table iowd
00430		PUSHJ P,SYSINP
00440		HRRM B,.JBSYM
00450		HLLZ A,NAME+3(D)
00460		ADDM A,.JBSYM
00470		JRST .+2
00480	LOAD3:	SOS .JBSYM	;want .JBsym to point one below 1st symbol
00490		MOVE 3,HVAL(D)	;h
00500		MOVE 5,RVAL(D)	;r
00510		MOVE 2,3
00520		SUB 2,5		;x=h-r
00530		HRLI 5,12	;(w)
00540		HRLI 2,11	;(v)
00550		SETZB 1,4
00560		JSP 0,140	;call the loader
00570		MOVEM 5,RLAST#(D)	;last location loaded(in final area)
00580		MOVE T,OLDCU(D)
00590		MOVE A,.JBSYM
00600		MOVEM A,.JBSYM(T)
00610		MOVE A,.JBREL
00620		MOVEM A,.JBREL(T)	;update .JBrel
00630		HRLZ 0,LOWLSP(D)
00640		SOS LODSIZ(D)
00650		AOBJN 0,.+1
00660		BLT 0,@LODSIZ(D)	;blt down low lisp
00670		MOVE 0,@LOWLSP	;EVERY THING IS FIXED, DON'T NEED REG. D ANYMORE
00680		HRRZ D,RLAST
00690		MOVE C,RVAL
00700		HRL C,HVAL
00710		SKIPE LDPAR
00720		JRST BINLD
00730		MOVE B,RLAST	;new coruse
00740	LDRET2:	BLT C,(D)	;blt down loaded code
00750		HRRZM B,CORUSE	;top of code loaded
00760		MOVEI D,1
00770		ANDCAM D,.JBSYM
00780		SUB B,.JBSYM	;length of free core
00790		ORCMI B,776000
00800		AOJGE B,STRT	;no contraction
00810		ADD B,.JBREL	;new top of core
00820		PUSHJ P,MOVDWN
00830		CORE B,		;contract core
00840		JRST .+1
00850		JRST STRT
00860	
00870	BINLD:	MOVE A,VBPEND(S)
00880		PUSHJ P,NUMVAL		;*** FIXED FOR NON-INUM ADDRESSES
00890		CAML D,A
00900		JRST [	SETOM BPSFLG	;bps exceeded
00910			JRST STRT]
00920		MOVE A,D
00930		PUSHJ P,FIX1A		;*** FIXED FOR NON-INUM ADDRESSES
00940		MOVEM A,VBPORG(S)	;updat bporg
00950		SOS B,OLDCU		;old top of core
00960		JRST LDRET2
00970	
00980	CCLINT:	HRRZ D,.JBINT		;*** ↑C HIT DURING LOAD
00990		SUBI D,CCBLKL		;*** COMPUTE OFFSET SINCE NOT RESTORED
01000		HRLZ 0,LOWLSP(D)
01010		SOS LODSIZ(D)
01020		SETZM CCBLKL+2(D)
01030		AOBJN 0,.+1
01040		BLT 0,@LODSIZ(D)	;*** NOTE THIS RESTORES NORMAL .JBINT
01050		MOVE 0,@LOWLSP
01060		SETZM LDFLG		;*** INDICATE SYMBOLS LOST
01070	CCSTRT:	MOVEI A,STRT
01080		MOVEM A,CCFLAG		;*** SET TO RE-START
01090		JRST CCINT1		;*** GO TO TRAP ROUTINE
01100	
01110	REMOTE<
01120	CCBLKL:	XWD 4,CCLINT		;*** LOADER ↑C INTERRUPT BLOCK
01130		XWD 0,2
01140		0
01150		X>
01160		PAGE
     
00010	SYSINI:	MOVEM A,NAME+1(D)
00020		;%% FOLLOWING IS OLD, NON-PATCHABLE CHANNEL OPEN
00030		COMMENT &
00040		IFN SYSPRG,<	MOVE A,[XWD SYSPRG,SYSPN]
00050				MOVEM A,NAME+3(D)>
00060		IFE SYSPRG,<	SETZM NAME+3(D)>
00070		INIT	17
00080		SYSDEV
00090		0
00100		JRST AIN.4+1
00110		&		;%% END OF OLD CODE
00120	
00130		;%% NEW PATCHABLE CODE (DEVICE NAME IN LOW SEGMENT)
00140		MOVE	A,SYSIN1(D)	;%% PICK UP PPN
00150	REMOTE<
00160	SYSIN1:	XWD	SYSPRG,SYSPN	;%% KEEP IN LOW SEGMENT
00170	>
00180		MOVEM	A,NAME+3(D)	;%% RESET VALUE HERE
00190		MOVEI	A,17		;%% SET DATA MODE 
00200		MOVEM	A,SYSIN0(D)	;%%
00210		OPEN	0,SYSIN0(D)	;%% OPEN CHANNEL 0 TO READ FILE
00220		JRST	AIN.4+1		;%% ERROR IN OPEN IF HERE
00230	REMOTE<
00240	SYSIN0:	17			;%% DUMP MODE I/O
00250		SYSDEV			;%% MAY BE PATCHED
00260					;%% NOTE THAT THIS MAY REMAIN "SYS"
00270					;%% WHEN HGHDAT IS CHANGED TO
00280					;%% SOMETHING ELSE
00290		0			;%% NO BUFFERING
00300	>
00310		LOOKUP NAME(D)
00320		JRST AIN.7+1
00330		MOVE	A,[IOWD 1,NAME+3]	;KLUDGE BECAUSE OF REG. D
00340		ADD	A,D
00350		MOVEM	A,INLOW(D)
00360		INPUT	INLOW(D)	;INPUT SIZE OF FILE
00370	REMOTE<
00380	INLOW:	IOWD 1,NAME+3
00390		0>
00400		HLRO A,NAME+3(D)
00410		POPJ P,
00420	
00430	REMOTE<
00440	NAME:	SYSNAM
00450		0
00460		0
00470		0>
00480	
00490	SYSINP:	MOVEM A,LST(D)
00500		INPUT LST(D)
00510		STATZ 740000
00520		ERR2 AIN.8
00530		RELEASE
00540		POPJ P,
00550	
00560	REMOTE<
00570	LST:	0
00580		0>
00590	PAGE
     
00010	MOVDWN:	HRLM	B,.JBSA	;##SAVE NEW .JBSA
00020		HLRZ A,.JBSYM
00030		JUMPE A,MOVS1
00040		ADDI A,1(B)
00050		HRL A,.JBSYM
00060		HRRM A,.JBSYM
00070		BLT A,(B)	;downward blt
00080		POPJ P,
00090	
00100	MOVSYM:	MOVE B,.JBREL
00110		HRLM B,.JBSA
00120		HLRE A,.JBSYM
00130		JUMPE A,MOVS1
00140		ADDI B,1(A)	;new bottom of symbol table
00150		MOVNI A,1(A)
00160		ADD A,.JBSYM	;last loc of old symbol table
00170		HRRM B,.JBSYM
00180		PUSH P,C
00190		MOVE B,.JBREL	;last loc of new symbol table
00200		MOVE C,(A)	;simulated upward blt
00210		MOVEM C,(B)
00220		SUBI B,1
00230		ADDI A,-1	;lf+1,rt-1
00240		JUMPL A,.-4
00250		POP P,C
00260		POPJ P,
00270	
00280	MOVS1:	HRRZM B,.JBSYM
00290		POPJ P,
00300	
00310	;enter with size needed in a
00320	;exit with pointer in a to core
00330	
00340	MORCOR:	PUSH P,B
00350		HRRZ B,.JBSYM
00360		CAIL B,SHRST		;WMT- WHAT IF SYMBOLS IN HIGH SEG?
00370		MOVE B,.JBREL		;WMT-    ACT LIKE THERE ARE NONE
00380		SUB B,CORUSE(D)
00390		SUBM	A,B	;NEEDED-(.JBSYM-CORUSE) (IE. NEEDED-FREE)
00400		JUMPL B,EXPND2
00410		ADD B,.JBREL	;new core size
00420		CORE B,		;expand core
00430		ERR2 [SIXBIT /CANT EXPAND CORE !/]
00440		PUSH P,A
00450		HRRZ B,.JBSYM		;WMT
00460		CAIG B,SHRST		;WMT- DON'T MOVE SYMS IF IN HIGH SEG
00470		PUSHJ P,MOVSYM
00480		POP P,A
00490	EXPND2:	MOVE B,CORUSE(D)
00500		ADDM A,CORUSE(D)
00510		MOVE A,B
00520		JRST POPBJ
00530	PAGE
     
00010		SUBTTL HIGH SEGMENT FUNCTIONS
00020	
00030	HGHCOR:	JUMPE	A,NOWRT	;EXPAND CORE AND SET WRITE STATUS
00040		PUSHJ	P,NUMVAL
00050		JUMPLE	A,FALSE
00060		SETZ	C,
00070		SETUWP C,
00080	UWPERR:	ERR2	[SIXBIT /CAN'T CHANGE HIGH SEG. WRITE PROTECT!/]
00090		SETZM	WRTSTS		;*** MOVED TO AFTER SETUWP CHECK
00100		MOVE	B,VHGHORG
00110		ADD	B,A
00120		HRRZ	C,.JBHRL
00130		CAMG	B,C
00140		JRST	TRUE
00150		HRLZ	A,B
00160		CORE A,
00170		ERR2	[SIXBIT /CAN'T EXPAND HIGH SEGMENT!/]
00180		JRST	TRUE
00190	NOWRT:	MOVEI	A,1
00200		MOVEM	A,WRTSTS
00210		SETUWP A,
00220		JRST	UWPERR
00230		JRST	TRUE
00240	
00250	HGHORG:	SKIPE	A	;SET HIGH ORG. TO A AND RETURN OLD ORG.
00260		PUSHJ	P,NUMVAL
00270		PUSH	P,A
00280		MOVE	A,VHGHORG
00290		PUSHJ	P,FIX1A		;WMT-
00300		POP	P,B
00310		SKIPE	B
00320		MOVEM	B,VHGHORG
00330		POPJ	P,
00340	
00350	HGHEND:	HRRZ	A,.JBHRL	;GET VALUE OF END OF HIGH SEG.
00360		JRST	FIX1A		;WMT
00370	
00380	;SETS THE GETSEG INFO. SO USER CAN HAVE OWN HIGH SEG.
00390	SETSYS:	MOVE	T,A	;MOVE ARGUMENT FOR UIOSUB
00400		SETZM	DEV	;## ALLOW DEFAULT TO DSK:
00410		PUSHJ	P,IOSUB	;BREAKS DOWN THE SPECIFICATION
00420		MOVEM	A,HGHDAT+1	;SAVE THE FILE NAME
00430		MOVE	A,DEV		;GET THE DEVICE AND SAVE IT
00440		MOVEM	A,HGHDAT
00450		MOVE	A,PPN		;GET THE PPN AND SAVE IT
00460		MOVEM	A,HGHDAT+4
00470		JRST	FALSE		;RETURN NIL
00480	REMOTE<
00490	WRTSTS: 1
00500	VHGHORG: BHORG>
00510		PAGE
     
00010		SUBTTL REALLOC CODE     
00020	
00030	
00040		IFN	REALLC <
00050	;%%	DYNAMIC REALLOCTION ROUTINE
00060	;%%
00070	;%%	ARGUMENTS:
00080	;%%	 A = FULL WORD SPACE INCREMENT
00090	;%%	 B = BINARY PROGRAM SPACE INCREMENT
00100	;%%	 C = REGULAR PUSHDOWN LIST INCREMENT
00110	;%%	 AR1 = SPECIAL PUSHDOWN LIST INCREMENT
00120	;%%	 AR2A = FREE SPACE INCREMENT
00130	;%%
00140	;%%	ACTION:
00150	;%%	 1) PERFORMS AN EXCISE
00160	;%%	 2) ALLOCATES ADDITIONAL CORE AS REQUIRED
00170	;%%		(IF IMPOSSIBLE, SIGNALS "CAN'T EXPAND CORE")
00180	;%%	 5) UNBINDS ALL VARIABLES ON THE SPECIAL STACK
00190	;%%	    AND CLEARS BOTH STACKS
00200	;%%	 4) REALLOCATES SPACE ACCORDING TO SPECIFICATIONS
00210	;%%		(NOTE THAT TOTAL CORE USED WILL BE ROUNDED
00220	;%%		 UP TO A MULTIPLE OF 1K WORDS, AND ANY EXCESS
00230	;%%		 WILL BE APPORTIONED TO FWS, RPDL, SPDL, AND 
00240	;%%		 FS.)
00250	;%%	 5) RESTARTS THE SYSTEM AT THE TOP LEVEL
00260	;%%
00270	
00280	REALL1:	JUMPE	A,.+2		;%%NO CONVERSION IF NIL
00290		PUSHJ	P,NUMVAL	;%%CONVERT TO BINARY
00300		ADDI	T,(A)		;%%ADD TO TOTAL BEING ACCUMULATED
00310		EXCH	A,(P)		;%%PUSH ON STACK
00320		JRST	(A)		;%%AND RETURN
00330	
00340	REALLOC:
00350		SETZ	T,		;%% CLEAR ACCUMULATOR FOR ALLOC TOTAL
00360		MOVE	TT,B		;%% SAVE SECOND ARG DURING FIRST CALL
00370		PUSHJ	P,REALL1	;%% PROCESS FIRST ARG
00380		MOVE	A,TT		;%%
00390		PUSHJ	P,REALL1	;%% PROCESS SECOND ARG
00400		MOVE	A,C		;%%
00410		PUSHJ	P,REALL1	;%% PROCESS THIRD ARG
00420		MOVE	A,AR1		;%%
00430		PUSHJ	P,REALL1	;%% PROCESS FOURTH ARG
00440		MOVE	A,AR2A		;%%
00450		PUSHJ	P,REALL1	;%% PROCESS FIFTH ARG
00460		MOVE	A,-4(P)		;%% PICK UP FWS INCREMENT
00470		ADD	A,SFWS		;%% MAKE NEW TOTAL FWS
00480		IDIVI	A,44		;%% CALCULATE SPACE FOR BIT TABLE
00490		ADDI	T,1(A)		;%% ADD TO TOTAL
00500		MOVEM	T,(P)		;%% SAVE TOTAL (FS AMOUNT NOT NEEDED)
00510		PUSHJ	P,EXCISE	;%% CLEAR BUFFERS, ETC.
00520		POP	P,A		;%% GET TOTAL BACK
00530		SETZ	D,		;%% CLEAR RELOCATION REGISTER
00540					;%% (HERE WE GO AGAIN)
00550		PUSHJ	P,MORCOR	;%% ALLOCATE THE ADDITIONAL SPACE
00560		MOVE	B,SC2		;%% CLEAR STACKS AND UNBIND VARIABLES
00570		PUSHJ	P,UBD		;%%
00580		HRRZ	B,.JBREL	;%% GET NEW HIGH LIMIT
00590		CAMGE	B,JRELO#	;%% DID CORE GET SMALLER?
00600		HALT	.		;%% YES -- WE QUIT
00610		MOVEM	B,JRELO#	;%% RESET LIMIT
00620		HRLM	B,.JBSA		;%% 
00630	IFN	ALVINE <
00640		MOVEI	A,ED+2		;%%INDICATE ED WAS OVERWRITTEN
00650		HRRM	A,EDA		;%%SO THEY WILL BE RELOADED IF NEEDED
00660	>
00670		SETZM	LDFLG		;%% INDICATE SYMBOLS GONE [1]
00680		MOVE	A,SFWS		;%% SAVE OLD VALUE
00690		MOVEM	A,OSFWS		;%%
00700		MOVE	A,FSO		;%%
00710		MOVEM	A,OFSO		;%%
00720		POP	P,A		;%% SPDL INCREMENT
00730		ADDM	A,SSPDL		;%% CHANGE TOTAL
00740		MOVN	AR2A,A		;%% SAVE JUST IN CASE
00750		POP	P,A		;%% RPDL INCREMENT
00760		ADDM	A,SRPDL		;%% CHANGE TOTAL
00770		MOVN	AR1,A		;%% SAVE AGAIN
00780		POP	P,A		;%% BPS TOTAL
00790		MOVEM	A,FSMOVE	;%% HOW MUCH TO MOVE FS
00800		ADDM	A,FSO		;%% NEW FS ORIGIN
00810		ADDM	A,SBPS		;%% BPS INCREMENT
00820		POP	P,A		;%% FWS INCREMENT
00830		ADDM	A,SFWS		;%% ADD TO TOTAL
00840		JRST	REALL2		;%% JUMP INTO REGULAR ALLOCATOR
00850					;%% (ALL DATA OFF STACK)
00860	>
00870	
00880	ALLOC:	MOVE	B,SC2		;*** ACCUMS ARE OK IF HERE
00890		PUSHJ	P,UBD		;*** SO UNBIND VARS FIRST
00900	INALLC:	HRRZ	A,.JBREL	;SEE IF CORE WAS EXPANDED
00910		CAMN	A,JRELO#	;OR NOT
00920		JRST	OUTALC		;NO EXPANSION - DON'T REALLOCATE
00930		CAMG	A,JRELO#	;CHECK TO SEE IF IT GOT SMALLER!
00940		 JRST	[OUTSTR	[ASCIZ	/CORE SIZE HAS BEEN REDUCED - CANNOT RUN
00950	/]
00960			 HALT	.]	; BITCH ABOUT IT!
00970		MOVEM	A,JRELO#	;SAVE NEW CORE BOUND
00980		HRLM	A,.JBSA
00990	IFN ALVINE,<
01000		MOVEI	F,ED+2		;INDICATE THAT ED WAS OVERWRITTEN
01010		HRRM	F,EDA		;SO ED AND GRINDEF WILL BE READ IN IF NEEDED>
01020		SETZM	LDFLG		;%% INDICATE SYMBOLS GONE [1]
01030	INAGN:	SETZM	NOALIN#		;SET UP TO ASK FOR ALLOCATION
01040		OUTSTR	[ASCIZ /
01050	ALLOC? (Y OR N) /]		;ASK USER IF HE WISHES TO SET UP
01060		INCHRW	C		;THE ALLOCATION INCREMENTS
01070		CAIE	C,"N"		;LOOK FOR N,n,Y,y
01080		CAIN	C,"n"
01090		JRST	NSTFWS		; DON'T ASK FOR INPUT
01100		CAIE	C,"Y"
01110		CAIN	C,"y"
01120		JRST	SETFWS
01130		JRST	INAGN		; NOT EXPECTED INPUT
01140	NSTFWS:	SETOM	NOALIN		; SET FLAG SO NO INPUT IS DONE LATER
01150	SETFWS:	MOVE	A,SFWS#		;SAVE OLD SIZE OF FWS
01160		MOVEM	A,OSFWS#
01170	
01180		SKIPN	NOALIN		;SKIP QUESTIONS IF AUTOMATIC
01190		OUTSTR	[ASCIZ /
01200	FULL WORD SP. = /]
01210		JSP	R,ALLNUM
01220		JUMPN	A,.+3
01230		SKIPE	INITFW#
01240		ADDI	A,440		;INITIAL ALLOCATION FOR FWS
01250	
01260		ADDM	A,SFWS#		;ADD EITHER USER INCREMENT OR 0 TO SFWS
01270	
01280		MOVE	A,FSO#		;SAVE OLD FS ORIGIN
01290		MOVEM	A,OFSO#		;FOR RELOCATION
01300	
01310		SKIPN	NOALIN		;SKIP IF USER DONE
01320		OUTSTR [ASCIZ /
01330	BIN. PROG. SP. = /]
01340		JSP	R,ALLNUM
01350		JUMPN	A,.+3
01360		SKIPE	INITFW
01370		ADDI	A,10		;*** MAKE SURE THERE'S  A LITTLE BPS
01380		ADDM	A,SBPS#
01390		MOVEM	A,FSMOVE#	;THE INCREMENT TO SBPS IS THE AMOUNT BY
01400		ADDM	A,FSO#		;THE FREE SPACE IS MOVED - UPDATE ORIGIN
01410	
01420		SKIPN	NOALIN		;SKIPIF USER DONE
01430		OUTSTR [ASCIZ /
01440	REG. PDL. = /]
01450		JSP	R,ALLNUM
01460		JUMPN	A,.+3
01470		SKIPE	INITFW#		;CHECK IF INITIAL ALLOCATION
01480		ADDI	A,1000
01490		ADDM	A,SRPDL#
01500		MOVN	AR1,A		;SAVE IN CASE OF OVERFLOW
01510	
01520		SKIPN	NOALIN		;SKIP IF USER DONE
01530		OUTSTR [ASCIZ /
01540	SPEC. PDL. = /]
01550		JSP	R,ALLNUM
01560		JUMPN	A,.+3
01570		SKIPE	INITFW#	;CHECK FOR INITIAL ALLOCATION
01580		ADDI	A,1000
01590		ADDM	A,SSPDL#
01600		MOVN	AR2A,A		;SAVE IN CASE OF OVERFLOW
01610	IFN HASH,<
01620		SKIPN	INITFW
01630		SETOM	NOALIN
01640		SKIPN	NOALIN
01650		OUTSTR	[ASCIZ /
01660	HASH = /]
01670		JSP	R,ALLNUM
01680		CAIG	A,BCKETS
01690		JRST	OCR
01700		HRRM	A,INT1
01710		MOVNS	A
01720		HRRM	A,RH4
01730		SETOM	HASHFG>
01740	REALL2:	MOVE	A,JRELO#	;COMPUTE SIZE OF AVAILABLE CORE
01750		SUBI	A,FS		;SO THAT EXTRA CORE CAN BE DISTRIBUTED
01760	
01770		SUB	A,SBPS		;TAKE OFF CORE ALLOCATED FOR BPS
01780		SUB	A,SFS#		;TAKE OFF CORE IN PREVIOUS FS
01790		SUB	A,SBT#		;AND ASSOCIATED BIT TABLE
01800		SUB	A,SFWS		;TAKE OFF CORE NOW ALLOCATED TO FWS
01810		SUB	A,SRPDL		;TAKE OFF CORE NOW ALLOCATED TO RPDL
01820		SUB	A,SSPDL		;TAKE OFF CORE NOW ALLOCATED TO SPDL
01830	
01840		MOVE	F,SFWS		;ESTIMATE SIZE NEEDED FOR BTF
01850		IDIVI	F,44
01860		ADDI	F,1
01870		SUB	A,F		;AND TAKE IT OFF TOTAL
01880		MOVEM	F,SBTF#		;ALSO SAVE TO RESTORE LATER
01890		JUMPGE	A,ALOK		;MAKE SURE NO OVERFLOW
01900		OUTSTR	[ASCIZ /ALLOCATIONS ARE TOO LARGE
01910	/]				; IF SO THEN RETRY
01920		MOVE	A,OSFWS
01930		MOVEM	A,SFWS		;RESTORE SIZE OF FWS
01940		MOVN	A,FSMOVE
01950		ADDM	A,SBPS		;RESET SIZE OF BPS
01960		ADDM	A,FSO		;AND FS ORGIN
01970		ADDM	AR1,SRPDL	;RESET STACKS
01980		ADDM	AR2A,SSPDL
01990		CLRBFI			;*** CLEAR OUT ANY GARBAGE
02000		JRST	INAGN
02010	
02020	ALOK:	MOVE	B,A		;NOW CAN ALLOCATE EXCESS CORE
02030	ACHLOC:	ASH	B,-4		;1/16 TO FWS
02040		ADDM	B,SFWS
02050		SUB	A,B		;TAKE IT OFF REMAINING CORE
02060		SKIPE	INITFW
02070		SETZ	B,
02080		ASH	B,-4		;1/64 TO PDLS
02090		ADDM	B,SSPDL
02100		SUB	A,B
02110		ADDM	B,SRPDL
02120		SUB	A,B		;AND TAKE IT OFF REMAINING CORE
02130	
02140		MOVE	T,SFWS		;CALCULATE ACTUAL SIZE OF BTF
02150		IDIVI	T,44
02160		ADDI	T,1
02170		ADD	A,SBTF		;REMOVE ESTIMATED LOSS FOR BTF
02180		MOVEM	T,SBTF
02190		SUB	A,T		;AND TAKE OFF ACTUAL LOSS TO BTF
02200	
02210		ADD	A,SFS		;ADD BACK ON SPACE FROM OLD FS
02220		ADD	A,SBT		;AND ASSOCIATED BT
02230					;GIVING NEW SPACE AVAILABLE FOR
02240					;FS AND BT
02250		MOVE	TT,A
02260		IDIVI	TT,41		;SBS = SFS/32.  = (SBS + SFS)/33.
02270	
02280		ADDI	TT,1
02290		MOVEM	TT,SBT
02300	
02310		SUB	A,TT		;TAKE OFF SBT FROM REMAINING CORE
02320		MOVEM	A,SFS		;GIVING AVAILABLE SFS
02330	
02340					;SET UP REGISTERS FOR GC ETC. SETUP
02350	
02360		MOVE	A,SFWS		;A ← SFWS
02370		MOVEI	B,FS
02380		ADD	B,SFS
02390		ADD	B,SBPS		;B ← NFWSO (ORIGIN OF NEW FULL WORD SPACE)
02400		MOVE	C,SRPDL		;C ← SRPDL
02410		MOVE	F,OSFWS		;F ← OLD SIZE OF FWS
02420	
02430		HRRM	B,GCP1		;GCP1 ← NFWSO
02440		MOVN	SP,B		;-NEW BOTTOM OF FWS
02450	
02460		HRRM	SP,GCMFWS
02470		HRLZM	A,C1GCS
02480		MOVNS	C1GCS		;-NEW LENGTH OF FWS
02490		HRRM	B,C1GCS		;HAVE FWS POINTER AND COUNT FOR SWEEP
02500	
02510		ADD	B,A		;NEW FIRST WORD OF BT (FS BIT TABLE)
02520	
02530		MOVE	SP,FSO		;SP ← NEW ORIGIN OF FS
02540	
02550		LSH	SP,-5
02560		SUBM	B,SP		;NUMBER USED TO FIND BIT TABLE WORD
02570		HRRM	SP,GCBTP1	;FROM FS WORD ADDRESS
02580		HRRM	SP,GCBTP2
02590	
02600		HRLM	B,C3GC		;BOTTOM OF BIT TABLES
02610		HRRM	B,GCP2
02620		HRRM	B,GCP		;(ALSO UPPER BOUND ON FWS AND FS)
02630	
02640		MOVNI	SP,-2(TT)	;-SIZE OF BT (TT = SBT)
02650		HRLM	SP,C3GCS	;IOWD FOR BIT TABLE SWEEP
02660		HRRM	B,C3GCS
02670		MOVE	SP,FSO
02680		ANDI	SP,37		;MASK OUT ALL BU LAST FIVE BITS
02690		HRRM	SP,GCBTL2	;MAGIC NUMBER TO POSITION
02700		SUBI	SP,40
02710		HRRM	SP,GCBTL1
02720	
02730		ADDI	B,1		;B ← B + 1
02740		HRRM	B,C3GC		;BOTTOM OF FS BIT TABLE + 1
02750		ADDI	B,-2(TT)	;GET BOTTOM OF BTF - 1, POINTER IS INCREMENTED
02760		HRRM	B,C2GCS		;BEFORE USE
02770	
02780		ADDI	B,1		;B ← B + 1
02790		HRRM	B,C2GC		;BOTTOM OF FWS BIT TABLE + 1
02800		ADDI	B,-1(T)		;SINCE T IS NOW SIZE OF BTF, NOT SBTF-1
02810	
02820		HRRM	B,GCP5		;TOP OF BIT TABLES
02830		ADDI	B,1		;BOTTOM OF REG PDL
02840	
02850		MOVE	S,ATMOV		;## S NOT SET IF LISP STARTED WITH CORE
02860					;## ALREADY EXPANDED, SO RESET IT
02870		HRRZI	A,OBTBL(S)	;GET OBLIST POINTER
02880					;## RHX2 NO LONGER PURE, WE WANT THE SYSTEM OBLIST
02890					;## THIS IS IT (I HOPE)3/28/73
02900		ADD	A,FSMOVE	;INCREMENT TO
02910					;ACCOUNT FOR MOVE OF FS
02920		MOVEM	A,(B)
02930		HRRM	B,GCP3		;ROOM FOR ACS DURING GC
02940		ADDI	B,1		;B ← B + 1
02950		HRRM	B,GCSP1
02960		HRRM	B,GCP4		;ROOM FOR ACS
02970		ADDI	B,10		;B ← B + 10
02980		HRRM	B,GCP41		;TOP OF AC AREA
02990		ADDI	B,1		;B ← B + 1
03000		HRRM	B,C2		;SET UP RPDL POINTER
03010		MOVNI	A,-20(C)	;A ← - (C -20) = -(SRPDL - 20)
03020		HRLM	A,C2		;THIS IS THE ACTUAL SIZE OF RPDL
03030					;TAKING INTO ACCOUNT THE AC AREA
03040		
03050		HRRZ	A,JRELO#	;TOP OF CORE - FOR SPDL PTR
03060	
03070		MOVN	B,SSPDL
03080		ADD	A,B
03090		HRL	A,B
03100	
03110		MOVEM	A,SC2#	;SET UP SPDL POINTER (I HOPE)
03120		MOVN	A,A	;CREATE OFFSET FOR STACK POINTERS
03130		ADDI	A,INUM0
03140		HRRZM	A,SPNM#
03150		SETZM	INITFW	;TURN OFF INITIAL ALLOCATION FLAG
03160	
03170	
03180	
03190				;RELOCATE THE FULL WORD SPACE
03200				;GCP1 HOLDS POINTER TO ORIGIN OF NEW FWS
03210				;FWSO# HOLDS POINTER TO ORIGIN OF OLD FWS
03220				;AND F HOLDS SIZE OF OLD FWS (AMOUNT TO BE MOVED)
03230	
03240		MOVSI	B,F
03250		HRR	B,GCP1
03260		MOVE	C,FWSO#
03270		HRRZI	AR2A,-1(C)	;TAKE THE OPPORTUNITY TO GET ADDRESS
03280					;OF END OF OLD FS (USED LATER)
03290		HRLI	C,F
03300		MOVE	A,@C	;GET WORD FROM END OF OLD FWS
03310		MOVEM	A,@B	;AND MOVE TO END OF NEW FWS
03320		SOJGE	F,.-2	;F COUNTS DOWN WORDS IN OLDFWS
03330				;END OF FWS RELOCATION
03340	
03350		MOVE	FF,FSMOVE	;GET FAST ACCESS TO RELOCATE SIZE FOR FS
03360		HRRZ	F,AR2A
03370		ADD	F,FF		;AND FIND WHERE TO PUT WORDS FROM
03380					;END OF OLD FS IN NEW FS
03390	
03400	
03410		HRRZ	AR1,GCP1	;COMPUTE FWS RELOCATION CONSTANT
03420		SUB	AR1,FWSO
03430	
03440	
03450				;RELOCATE FS - ALSO RELOCATE ALL
03460				;POINTERS TO FS AND TO FWS
03470	
03480	REL1:	HLRZ	A,(AR2A)	;GET CAR POINTER OF OLD FS WORD
03490		JSP	R,REL4
03500		HRLM	A,(F)		;MOVE CAR TO NEW POSITION
03510		HRRZ	A,(AR2A)	;GET CDR PTR
03520		JSP	R,REL4		;CHECK FOR FS RELOCATE
03530		HRRM	A,(F)
03540		SUBI	F,1		;F ← F -1
03550		CAMLE	AR2A,OFSO	;CHECK TO SEE IF DONE
03560		SOJA	AR2A,REL1	;NO - GO LOOP
03570		HRRZ	A,GCMKL		;RELOCATE ARRAYS
03580		JSP	R,REL4
03590		HRRZ	D,A
03600		MOVEM	D,GCMKL
03610	REL5:	HLRZ	AR2A,(D)
03620		MOVE	AR2A,(AR2A)
03630	REL6:	HLRZ	A,(AR2A)
03640		JSP	R,REL4
03650		HRLM	A,(AR2A)
03660		HRRZ	A,(AR2A)
03670		JSP	R,REL4
03680		HRRM	A,(AR2A)
03690		AOBJN	AR2A,REL6
03700		HRRZ	D,(D)
03710		JUMPN	D,REL5
03720		SETZM	BIND3		;JUST IN CASE
03730		SKIPE	INITF		;DON'T FORGET THE INITFN
03740		ADDM	FF,INITF
03750		SKIPE	INITF1		;## DON'T FORGET THE INIT FILES
03760		ADDM	FF,INITF1	;##
03770		SKIPE	NOUUOF		;RELOCATE FLAGS
03780		ADDM	FF,NOUUOF
03790	IFN ALVINE<
03800		SKIPE	BACTRF		;*** ONLY IF ALVINING
03810		ADDM	FF,BACTRF>
03820		SKIPE	GCGAGV
03830		ADDM	FF,GCGAGV
03840		SKIPE	RSTSW
03850		ADDM	FF,RSTSW
03860		SKIPE	DDTIFG		;*** RELOCATE DDT FLAG
03870		ADDM	FF,DDTIFG	;***
03880	;	JRST	RELFOO		;WMT
03890	RELFOO:	MOVE	S,SBPS		;S IS THE RELOCATOR FOR MOST MACRO
03900		MOVEM	S,ATMOV		;REFERENCES TO ATOMS AND FS
03910		MOVE	A,FSMOVE
03920	IFE OLDNIL<	ADDM A,NILHD>	;## RESET NIL HEAD
03930		HRR	B,VOBLIST(S)	;## GET CURRENT VALUE OF OBLIST
03940		HRRM	B,RHX5		;## RESET WORD THAT POSTINDEXES OFF B
03950		HRRM	B,RHX2		;## RESET WORD POSTINDEXING OFF C
03960		ADDM	A,XXX3		;## RESET WIERD CODE 
03970		ADDM	A,XXX4		;## RESET UNBOUND
03980		ADDM	A,XXX5		;## RESET FS (SAME WORD AS FS),ALSO GCPP1
03990		MOVE	A,GCP1
04000		HRRZM	A,FWSO
04010		MOVE	A,C3GCS
04020		HRRZM	A,EFWSO#
04030		SETZB	F,FF		;*** CLEAR F TO FORCE GC
04040		MOVE	SP,SC2		;*** INIT SPDL POINTER FOR UBD IN STRT
04050		MOVE	P,C2		;*** INIT PDL POINTER
04060		MOVE	A,VBPEND(S)	;*** GET OLD BPEND
04070		PUSHJ	P,NUMVAL	;*** (FIXED FOR POSSIBLE NON-INUM)
04080		ADD	A,FSMOVE	;*** INCREMENT IT
04090		PUSHJ	P,FIX1A		;*** CONVERT IT BACK (CAN CAUSE GC)
04100		MOVEM	A,VBPEND(S)	;*** AND STORE IT
04110	OUTALC:	JSP	R,IOBRST
04120		JRST	STRT
04130	
04140	REL4:	CAMGE	A,EFWSO		;SEE IF BEYOND END OF FWS
04150		CAMGE	A,OFSO		;OK - SEE IF MAYBE IN FS
04160		JRST	(R)
04170		CAMGE	A,FWSO		;SEE IF IN FWS
04180		JRST	.+3
04190		ADD	A,AR1		;RELOCATE FWS POINTER
04200		JRST	(R)
04210		ADD	A,FF		;RELOCATE FS POINTER
04220		JRST	(R)
04230	
04240	
04250	PAGE
     
00010			;SUBROUTINE FOR NUMBER INPUT
00020			;%% RETURNS 0 IF NOALIN # 0
00030			;%% SETS NOALIN # 0 IF ALTMOD IS INPUT
00040			;%% RETURNS 0 IF A BLANK IS INPUT
00050			;%% IGNORES OTHER NON-NUMERIC CHARACTERS EXCEPT
00060			;%% AS TERMINATORS OF NUMBERS
00070	
00080	BANGCK:	CAIN	C,15		;%% TERMINATE ON CR OR
00090		INCHRW	C		;WMT-EAT LF AFTER CR
00100		CAIE	C,12		;WMT-TERMINATE ON LF
00110		CAIN	C,40		;%% TERMINATE ON BLANK
00120		JRST	(R)		;%%
00130		CAIN	C,ALTMOD	;%% ALTMODE (TERMINATOR)?
00140		JRST	[SETOM NOALIN#
00150			 JRST (R) ] 	;%% YES--TURN ON SWITCH AND RETURN
00160		OUTSTR	[ASCIZ/XXX	/] ;WMT-ANY GARBAGE CAUSES RESTART
00170	;	JRST	ALLNUM		;WMT-START OVER
00180	
00190	
00200	ALLNUM:	SETZ	A,		;%% CLEAR A
00210		SKIPE	NOALIN#
00220		JRST	(R)
00230		INCHRW	C
00240		CAIL	C,"0"
00250		CAILE	C,"7"
00260		JRST	BANGCK
00270		ASH	A,3
00280		ADDI	A,-"0"(C)
00290		JRST	ALLNUM+3
00300	
00310	
00320	PAGE
     
00010	IFN HASH,<
00020	REHASH:
00030		MOVEI A,BFWS(S)
00040		PUSH P,A
00050		HRRM A,RHX2
00060		HRRM A,RHX5
00070		MOVS B,RH4#
00080		ADD B,S	;$$PUT IN ATOM MOVE OFFSET IN B, SINCE CAN'T
00090				;$$DOUBLE INDEX - THIS REMOVES THE FOO PROBLEM
00100				;$$IN THE NEXT THREE FOO'S
00110	
00120		HRRZI A,BFWS+1(B)
00130		MOVEM A,BFWS(B)
00140		AOBJN B,.-2
00150		SETZM BFWS(B)
00160		MOVSI AR2A,-BCKETS
00170		HRR AR2A,S	;$$PUT IN ATOM MOVE OFFSET IN AR2A TO AVOID
00180				;$$DOUBLE INDEXING WITH S IN REMOVING FOO
00190				;$$PROBLEM
00200	RH1:
00210		HLRZ C,OBTBL(AR2A)
00220	RH3:	JUMPE C,RH2
00230		HLRZ A,(C)
00240		PUSH P,C
00250		PUSH P,AR2A
00260		PUSHJ P,INTERN
00270		POP P,AR2A
00280		POP P,C
00290		HRRZ C,(C)
00300		JRST RH3
00310	RH2:	AOBJN AR2A,RH1
00320		SETZM HASHFG
00330		POP P,A
00340		HRRM A,@GCP3
00350		MOVEM A,OBLIST(S)
00360		JRST STRT>
00370	
00380		PAGE
     
00010		SUBTTL NEW FUNCTIONS TO MAKE USE OF MODIFIED SPECIAL PDL FOR ERRORS
00020	
00030	;$$ROUTINE TO GET POINTER TO SPDL AND MAKE IT INTO AN INUM
00040	SPDLPT:	HRRZ	A,SP	;$$CREATE A POINTER TO THE CURRENT TOP OF STACK
00050		ADD	A,SPNM
00060		POPJ	P,		;$$
00070	
00080	
00090	;$$ROUTINE TO GET LEFT HAND SIDE OF SPDL ITEM INDICATED BY AN INUM FROM SPDLPT
00100	SPDLFT:	SUB	A,SPNM	;$$CONVERT TO ADDRESS
00110		HLRE	A,(A)	;$$GET LEFT HAND ITEM
00120		JUMPL	A,TRUE		;$$IF IT IS NEGATIVE IT CAME FROM A STACK
00130					;$$POINTER AND WE RETURN T INSTEAD
00140		HRRZI	A,(A)		;$$CLEAR OUT LEFT HAND OF AC
00150		POPJ	P,		;$$RETURN - RETURNS NIL FOR LHS = 0
00160	
00170	;$$ROUTINE TO GIVE RIGHT HAND SIDE OF SPDL ENTRY SPECIFIED BY AN INUM FROM SPDLPT
00180	SPDLRT:	SUB	A,SPNM		;$$CONVERT TO AN ADDRESS
00190		HRRZ	A,(A)	;$$ALL RHS ITEMS ARE LEGAL, NO NEED FOR CHECK
00200		POPJ	P,		;$$
00210	
00220	;$$ROUTINE TO GET POINTER TO NEXT EVAL BLIP ON SPDL
00230	NEXTEV:	SUB	A,SPNM	;$$GET POINTER INSTEAD OF INUM
00240		HRRZ	T,SC2	;$$GET POINTER TO BOTTOM OF SPDL
00250	
00260	SPDNLP:	CAMG	A,T	;$$CHECK IF HIT THE BOTTOM OF SPDL
00270		JRST	FALSE	;$$RETURN NIL IF NO MORE INTERESTING WORDS
00280		HLL	A,(A)	;$$TEST FOR WORD WITH 0 LHS
00290		TLZE	A,-1	;$$
00300		SOJA	A,SPDNLP	;$$NOT AN INTERESTING WORD, LOOK AGAIN
00310		ADD	A,SPNM	;$$FOUND AN INTERESTING WORD, CHANGE POINTER TO INUM
00320		POPJ	P,	;$$
00330	
00340	
00350	;$$ROUTINE TO EVALUATE A VARIABLE IN AN EARLIER CONTEXT
00360	;$$	MORE EFFICIENT THAN EVAL WITH ALIST
00370	EVALV:	MOVE	C,A		;$$ MOVE AROUND FOR ATOM CHECK
00380		PUSHJ	P,ATOM	;$$
00390		EXCH	A,C		;$$
00400		SUB	B,SPNM		;$$
00410	EVALV1:	CAIL	B,(SP)		;$$CHECK FOR END OF SPDL (*** CH FRM CAIN)
00420		JRST	GETV		;$$VARIABLE NOT REBOUND - GET CURRENT VALUE
00430		SKIPGE	,(B)		;$$CHECK TO AVOID SPDL POINTERS ON  STACK
00440		AOJA	B,EVALV1	;$$
00450		HLRZ	T,(B)		;$$T←CAR(B)
00460		SKIPE	C		;$$
00470		HLRZ	T,(T)		;$$GET CAR OF SPECIAL CELL - ATOM POINTER
00480		CAIE	T,(A)		;$$COMPARE WITH ATOM TO BE EVALUATED
00490		AOJA	B,EVALV1	;$$NOT IT, LOOK SOME MORE
00500		HRRZ	A,(B)		;$$GET VALUE FROM SPDL
00510		POPJ	P,		;$$
00520	
00530	GETV:	JUMPE	C,CDR
00540		MOVEI	B,VALUE(S)		;$$ATOM NOT REBOUND, VALUE THEN IS 
00550		PUSHJ	P,GET		;$$
00560		JUMPE	A,UNBOND	;$$NOT BOUND AT ALL, GIVE UNBVAR MESSAGE
00570		JRST	CDR		;$$GET CDR OF SPECIAL CELL
00580	
00590	UNBOND:	HRRZI	A,UNBOUND(S)	;$$RETURN ATOM UNBOUND
00600		POPJ	P,		;$$
00610	
00620	;$$ROUTINE TO CLEAR SPECIAL PDL TO POSITION SPECIFIED BY INUM
00630	CLRSPD:	MOVEI	B,-2-INUM0(A)	;$$ -2 TO GET OVER EVAL BLIP
00640		HLRZ	TT,SC2#	;$$GET REAL SPD POINTER WITH A LHS
00650		ADD	TT,B	;$$FIND OUT HOW MANY WORDS ARE USED
00660		ADD	B,SC2	;$$
00670		HRL	B,TT	;$$SET UP SPD POINTER
00680		JRST	UBD		;$$UBD DOES ALL THE WORK
00690	
00700	;$$ROUTINE TO RETURN FROM SPECIAL PDL CONTEXT, SPECIFIED BY AN
00710	;$$EVAL BLIP, WITH A GIVEN VALUE
00720	OUTVAL:	PUSHJ	P,NEXTEV	;$$FORCE TO AN EVAL BLIP
00730		JUMPE	A,FALSE		;$$ NO EVAL BLIP, RETURN NIL
00740		HRLZI	C,(POPJ P,)	;$$ SET TYPE OF RETURN
00750		JRST	SPRE1		;$$ FINISH UP IN SPREDO
00760	
00770	
00780	;$$ROUTINE TO RE-EVALUATE EXPRESSION FROM AN EVAL BLIP AND GO ON FROM
00790	;$$ THAT CONTEXT (NOT A USER CALLABLE FUNCTION)
00800	REVAL1:	HRRZ	P,1(SP)		;$$ RPDL POINTER IS UP ONE
00810		HRRZ	T,C2#		;$$
00820		HLRZ	TT,C2#		;$$
00830		ADD	TT,P		;$$
00840		SUB	TT,T		;$$
00850		HRL	P,TT		;$$
00860	DOSET:	MOVE D,ERRTN	;$$ POP ERRSETS, LOAD CURRENT ERRSET
00870		SKIPE D		;$$DONE IF EMPTY
00880		CAMG D,P	;$$ COMPARE TO CURRENT RPDL
00890		XCT C		;$$ DONE, DO A STRANGE EXIT
00900		SUB D,[XWD 1,1]	;$$ GO DOWN A WORD
00910		POP D,ERRSW	;$$
00920		POP D,ERRTN	;$$
00930		JRST DOSET	;$$ TRY AGAIN
00940	
00950	
00960	
00970	;$$ROUTINE TO CLEAR SPD TO A GIVEN POINT AND REDO FROM THERE
00980	;$$ A CONTAINS AN SPD INUM POINTER, FORCE IT TO BE EVAL BLIP POINTER
00990	
01000	SPREDO:	PUSHJ	P,NEXTEV	;$$FORCE TO EVAL BLIP POINTER
01010		JUMPE	A,CPOPJ		;$$RETURN NIL IF NO EVAL BLIP
01020		MOVE	B,A		;$$GET THE EXPRESSION
01030		SUB	B,SPNM
01040		HRRZ	B,(B)
01050		MOVE	C,[JRST XXEVAL]	;$$SET RETURN (***Ch. from EVAL 4/24/77)
01060	SPRE1:	PUSH	P,B		;$$SAVE SPDL POINTER
01070		PUSHJ	P,CLRSPD	;$$CLEAR OUT SPD - INCLUDES RESTORING PROGS
01080		POP	P,A		;$$
01090		JRST	REVAL1
01100	
01110	;$$ SPREVAL - SIMILAR TO OUTVAL BUT EVALUATES THE GIVEN VALUE
01120	;$$AS OF THE SPECIFIED CONTEXT, EQUIVALENT TO:
01130	;$$ (PROG2 (RPLACD (NUMVAL (SETQ A (NEXTEV A))) B) (SPREDO B))
01140	;
01150	SPREVAL:PUSHJ P,NEXTEV		;$$FORCE TO AN EVAL-BLIP
01160		JUMPE	A,CPOPJ		;$$RETURN NIL IF NO EVAL-BLIP
01170		JRST	SPRE1-1		;$$LET SPREDO FINISH UP
01180	
01190	
01200	;$$COMPUTES A LISP POINTER TO A STACK ENTRY
01210	STKPTR:	SUB	A,SPNM
01220		POPJ	P,
01230	
01240	PAGE
     
00010		SUBTTL LOW SEGMENT INCLUDING REMOTE CODE
00020		XALL
00030		RELOC		;WMT- WAS RELOC 0
00040		HERE
00050		VAR
00060		PAGE
     
00010		SUBTTL LISP ATOMS AND OBLIST	
00020	FS:
00030	
00040	DEFINE MAKBUC (A,%B)
00050	<DEFINE OBT'A <%B=.>
00060	XWD %B,IFN <<BCKETS-1>-A>,<.+1>
00070	IF1 <%B=0>>
00080	
00090	DEFINE ADDOB (A,C,%B)
00100	<OBT'A
00110	DEFINE OBT'A<%B=.>
00120	IF1 <%B=0>
00130	XWD C,%B>
00140	
00150	DEFINE PUTOB (A,B)
00160	<ZZ==<ASCII +A+>←<-1>
00170	ZZ==-ZZ/BCKETS*BCKETS+ZZ
00180		ADDOB \ZZ,B>
00190	
00200	DEFINE PSTRCT (A)
00210	<ZZ==[ASCII +A+]
00220	LENGTH(ZY,<A>)
00230	ZY==<ZY-1>/5
00240	Q1(ZY,ZZ)
00250	>
00260	
00270	DEFINE Q1 (N,Z)<
00280	IFN N,<XWD Z,[Q1(N-1,Z+1)]>
00290	IFE N,<XWD Z,0>>
00300	
00310	
00320	;## ARGS ARE A=NAME, B=PROP NAME, C'A=THE PROPERTY, D=LABEL OF ATOM
00330	
00340	DEFINE MKAT (A,B,C,D)
00350	<XLIST
00360	IRP A< PUTOB A,.+1
00370	D	XWD -1,.+1
00380		XWD B,.+1
00390		XWD C'A,.+1
00400		XWD PNAME,.+1
00410		XWD [PSTRCT(A)],0>
00420	LIST>
00430	
00440	;## ARGS ARE: D'A=PROPERTY, B=PROP NAME, C=NAME
00450	
00460	DEFINE MKAT1 (A,B,C,D)
00470	<XLIST
00480	IRP C <PUTOB C,.+1
00490		XWD -1,.+1
00500		XWD B,.+1
00510		XWD D'A,.+1
00520		XWD PNAME,.+1
00530		XWD [PSTRCT(C)],0>
00540	LIST>
00550	
00560	DEFINE LENGTH (A,B)
00570	<A==0
00580	IRPC B,<A==A+1>>
00590	
00600	;## ATOM WITH SYM PROPERTY =V'ATOM LOCATION
00610	DEFINE ML1 (A)<IRP A,<
00620	V'A:	XWD	-1,.+1
00630		XWD	FIXNUM,[A]
00640		MKAT A,SYM,V
00650	>>
00660	
00670	;## SIMILAR TO ML1, EXCEPT %C=THE SYM PROP
00680	
00690	DEFINE MKSY1 (A,B,%C)<
00700	XLIST
00710	%C:	XWD	-1,.+1
00720		XWD	FIXNUM,[A]
00730		PUTOB B,.+1
00740		XWD	-1,.+1
00750		XWD	SYM,.+1
00760		XWD	%C,.+1
00770		XWD	PNAME,.+1
00780		XWD	[PSTRCT(B)],0
00790	LIST>
00800	
00810	;##  ATOM WITH NO PROPS WITH  LABEL SAME AS ATOM NAME
00820	
00830	DEFINE ML (A)<
00840	XLIST
00850	IRP A,<PUTOB A,.+1
00860	A:	XWD -1,.+1
00870		XWD PNAME,.+1
00880		XWD [PSTRCT(A)],0>
00890	LIST>
00900	;## CREATE ATOM WITH NO LABEL OR PROPS. USED FOR COMMON ATMS IN SYSTEM
00910	
00920	DEFINE MK (A)<
00930	XLIST
00940	IRP A,<PUTOB A,.+1
00950		XWD -1,.+1
00960		XWD PNAME,.+1
00970		XWD [PSTRCT(A)],0>
00980	LIST>
00990	
01000	OBTBL:
01010	OBLIST:	ZZ==0
01020	XLIST
01030	REPEAT BCKETS,<MAKBUC \ZZ
01040	ZZ==ZZ+1>
01050	LIST
01060	
01070	PAGE
     
00010	;## GENERATE # FNS ONLY IF NONUSEFUL VALUES DESIRED
00020	IFN NONUSE<
00030	MKAT1 MEMBR.,SUBR,MEMBER#
00040	MKAT1 MEMB,SUBR,MEMQ#
00050	MKAT1 AND.,FSUBR,AND#
00060	MKAT1 OR.,FSUBR,OR#
00070		>
00080	MKAT<RPLACA,RPLACD,MINUS,TERPRI,CAR,CDR,CAAR>,SUBR
00090	MKAT<CADR,CDAR,CDDR,CAAAR,CAADR,CADAR,CADDR,CDAAR,CDADR,CDDAR,CDDDR>,SUBR
00100	MKAT<CAAAAR,CAAADR,CAADAR,CAADDR,CADAAR,CADADR,CADDAR,CADDDR,CDAAAR>,SUBR
00110	MKAT<CDAADR,CDADAR,CDADDR,CDDAAR,CDDADR,CDDDAR,CDDDDR,MAKNUM,CONS>,SUBR
00120	MKAT<STRINGP,ATOM,PATOM,EQ,PRIN1,PRINT,RETURN,EXPLODE,SASSOC,ASSOC>,SUBR
00130	MKAT<GCGAG,CCON,CHRCT,LINELENGTH,NUMBERP,EQUAL,GET,INTERN,MEMBER>,SUBR
00140	MKAT<LOAD,MAKNAM,READCH,NOT,NULL,GENSYM,ZEROP,DIVIDE,GCD>,SUBR
00150	MKAT<TIME,FIX,SET,PROG2,LENGTH,READLIST,LAST,ADD1,SUB1>,SUBR
00160	MKAT<GCTIME,REVERSE,SPEAK,GC,GETL,MEMQ>,SUBR
00170	MKAT<PUTPROP,PRINC,FLATSIZE,ERR,EXAMINE,DEPOSIT,LSH>,SUBR
00180	MKAT<NCONS,XCONS,REMPROP,ARG,SETARG,NOUUO,MINUSP>,SUBR
00190	MKAT<OUTC,INC,DDTIN,INITFN,EXCISE,REMAINDER,ABS>,SUBR
00200	MKAT<PROG1,LITATOM,NTHCHAR>,SUBR
00210	IFN SPRNT,<MKAT<SPRINT>,SUBR>;***
00220	IFN STPGAP,<MKAT<PGLINE>,SUBR>
00230	IFN RANDOM,<					;WMT
00240	MKAT1 GTOPOS,SUBR,UGETO
00250	MKAT1 GTIPOS,SUBR,UGETI
00260	MKAT1 SETPOS,SUBR,USETI
00270	>
00280	
00290	MKAT EXPLODEC,SUBR,%
00300	MKAT TAB,SUBR,.
00310	MKAT TYO,SUBR,I
00320	MKAT TYI,SUBR,I
00330	CEVAL=.+1
00340	MKAT1 EVAL,SUBR,*EVAL
00350	
00360	;$$ REDEF. FOR NEW MAP FUNCTIONS
00370	MKAT<MAPCAN,MAPCON,MAPLIST,MAPCAR,MAP,MAPC>,LSUBR
00380	;$$ GIVE MAPCAN THE DOUBLE NAME MAPCONC
00390	MKAT1 MAPCAN,LSUBR,MAPCONC
00400	
00410	PROGAT:	MKAT<PROG>,FSUBR
00420	
00430	;##LIST STARTS HERE
00440	MKAT LIST,FSUBR,,LISTAT:
00450	
00460	MKAT <PROGN,COND,SETQ,INPUT,OUTPUT,SETSYS>,FSUBR 
00470	;?????? IS SETQ RIGHT HERE?
00480	IFN ALVINE,<MKAT<GRINDEF>,FSUBR
00490		    MKAT<ED,BAKGAG>,SUBR>
00500	MKAT<ERRSET,REMOB,OR,GO,ARRAY,STORE>,FSUBR
00510	MKAT<AND,DEFPROP,CSYM,EXARRAY>,FSUBR
00520	MKAT1 QUOTE,FSUBR,FUNCTION
00530	MKAT1 %CLRBFI,SUBR,CLRBFI
00540	MKAT1 .ERROR,SUBR,ERROR
00550	MKAT1 LINRD,LSUBR,LINEREAD
00560	MKAT1 UNBOND,SUBR,UNBOUND
00570	MKAT1 ECHO,SUBR,TTYECHO
00580	MKAT1 FUNCT,FSUBR,*FUNCTION
00590	MKAT <APPEND,NCONC,BOOLE,APPLY>,LSUBR
00600	
00610	;## LABELS ON READ AND LISP EVAL FOR BOOTS
00620	MKAT READ,SUBR,,READAT:
00630	MKAT EVAL,LSUBR,O,EVALAT:
00640	MKAT PREVIOUS,VALUE,,PREVAT:
00650	PREVIOUS: NIL		;WMT-LAST VALUE AT TOP LEVEL OF LISP
00660		MKAT FPROTECTION,VALUE
00670	FPROTE:	INUM0		;WMT-FILE PROTECTION ON ALL OUTPUT FILES
00680	
00690	MKAT ASCII,SUBR,A
00700	MKAT QUOTE,FSUBR,,CQUOTE:
00710	MKAT INUM0,SYM
00720	
00730		PUTOB T,.+1
00740	TRUTH:	XWD -1,.+1
00750		XWD VALUE,.+1
00760		XWD VTRUTH,.+1
00770		XWD PNAME,.+1
00780		XWD [PSTRCT(T)],0
00790	VTRUTH:	TRUTH
00800	
00810		PUTOB NIL,0
00820	FAKNIL:	XWD -1,.+1	;*** FAKE NIL ATOM HEADER FOR ACCESSING PRP LST
00830	CNIL2:	XWD VALUE,.+1
00840		XWD VNIL,.+1
00850		XWD PNAME,.+1
00860		XWD [PSTRCT(NIL)],0
00870	VNIL:	NIL
00880	
00890	MKSY1 %LCALL,*LCALL
00900	MKSY1 %AMAKE,*AMAKE
00910	MKSY1 %UDT,*UDT
00920	MKSY1 .MAPC,*MAPC
00930	MKSY1 .MAP,*MAP
00940	MKAT1 %NOPOINT,VALUE,*NOPOINT
00950	%NOPOINT:	NIL
00960	
00970	MKAT1 %TTYUC,VALUE,*TTYUC
00980	%TTYUC:		NIL
00990	
01000	UNBOUND: XWD -1,.+1
01010		XWD PNAME,.+1
01020		XWD [PSTRCT(UNBOUND)],0
01030	PAGE
     
00010	MKAT1 EXPN1,SUBR,*EXPAND1
00020	MKAT1 EXPAND,SUBR,*EXPAND
00030	MKAT1 PLUS,SUBR,*PLUS,.
00040	MKAT1 DIF,SUBR,*DIF,.
00050	MKAT1 QUO,SUBR,*QUO,.
00060	MKAT1 TIMES,SUBR,*TIMES,.
00070	MKAT1 APPEND,SUBR,*APPEND,.
00080	MKAT1 RSET,SUBR,*RSET,.
00090	MKAT1 GREAT,SUBR,*GREAT,.
00100	MKAT1 LESS,SUBR,*LESS,.
00110	MKAT1 PUTSYM,SUBR,*PUTSYM
00120	MKAT1 GETSYM,SUBR,*GETSYM
00130	MKAT1 RPTSYM,SUBR,*RPUTSYM
00140	MKAT1 RGTSYM,SUBR,*RGETSYM
00150	
00160	ML1 <SPECBIND,SPECSTR,FIX1A,NSTR>
00170	
00180		PUTOB NUMVAL,.+1
00190		XWD -1,.+1
00200		XWD SUBR,.+1
00210		XWD NUMVAL,.+1
00220		XWD SYM,.+3
00230		XWD FIXNUM,[NUMVAL]
00240		XWD -1,.-1
00250		XWD .-1,.+1
00260		XWD PNAME,.+1
00270		XWD [PSTRCT(NUMVAL)],0
00280	
00290	MKAT <OBLIST,BASE,IBASE,BPEND,BPORG>,VALUE,V
00300	
00310	
00320	;## QUEUE ATOMS AND OTHER NEW FNS.
00330	
00340	MKAT<GTBLK,ERRCH,RDNAM>,SUBR
00350	MKAT<INUMP,NUMTYPE>,SUBR
00360	MKAT<UFDINP,RDFILE,MYPPN,BLKLST>,SUBR
00370	MKAT<RENAME,DELETE,INITFL>,FSUBR
00380	IFN	QALLOW<			;%% [1]
00390	ML<DISP,CPU,FORMS,LIMIT,COPIES>;;##
00400	MKAT<QUEUE>,FSUBR;		;##
00410			>		;%% [1]
00420	MKAT1 ISFILE,SUBR,LOOKUP
00430	
00440	IFN	QALLOW<		;%% [1]
00450	;## MOST OF THE EXTENDED SWITCHES (NOT ALL)
00460	IFN	QSWEXT<
00470		ML<DEAD,AFTER>
00480		ML<MODIFY,KILL,JOB,DEPND,UNIQUE>
00490		ML<PAGES,PLOT,PTAPE,CARD,SEQ,PRIOR,SPACE,LIMIT,HEAD>
00500		>		;##END OF EXTENDED SWITCHES
00510			>	;%% END OF QALLOW CONDITIONAL [1]
00520	
00530	;$$ATOMS FOR DEFINITIONS OF FUNCTIONS FOR NEW SPDL PACKAGE
00540	
00550		ML ERRORX
00560		MKAT1 INTPRP,SUBR,INITPROMPT
00570			;WMT- STRT CHANGED TO LSPRET
00580		MKAT1 LSPRET,FSUBR,**TOP**
00590		MKAT<PROMPT,READP,UNTYI,STKPTR,SPREDO,SPREVAL>,SUBR
00600		MKAT<MEMB,NEXTEV>,SUBR
00610		MKAT<SPDLFT,SPDLRT,SPDLPT>,SUBR
00620		MKAT<EVALV,OUTVAL>,SUBR
00630	
00640		IFN	REALLC <
00650	;%% NEW DYNAMIC REALLOCATION FUNCTION
00660		MKAT1 REALLO,SUBR,REALLOC
00670	>
00680	; [UT]	ADDITIONS
00690		MKAT	<GCWORDS,RPDLIM,SPDLIM,FSLIM,FWLIM,FWCNT,FSCNT>,SUBR
00700	IFE SFDFLG,<	;WMT
00710		MKAT	PATH,FSUBR
00720		MKAT	SCAN,SUBR
00730	>
00740	
00750	;$$ MORE EXTENSIONS INCLUDING READ MACROS
00760		ML READMACRO
00770		MKAT1 %FLATSIZEC,SUBR,FLATSIZEC
00780		MKAT <NEQ,CONSP,CHRVAL,SETCHR,MODCHR,LEXORDER>,SUBR
00790		MKAT <FREE,FREELIST,SYSCLR,HGHCOR,HGHORG,HGHEND>,SUBR
00800		MKAT1 FALSE,FSUBR,SPECIAL
00810		MKAT1 FALSE,FSUBR,NOCALL
00820		MKAT1 FALSE,FSUBR,DECLARE
00830		MKAT1 FALSE,FSUBR,NILL
00840		MKAT1 APPLY.,SUBR,APPLY#
00850		MKAT1 .MAX,SUBR,*MAX
00860		MKAT1 .MIN,SUBR,*MIN
00870	
00880	;*** NEW RUTGERS FUNCTIONS
00890		MKAT1 DOEXIT,SUBR,EXIT
00900		MKAT1 TTYCLR,SUBR,TALK
00910		MKAT1 GETICH,SUBR,INCH
00920		MKAT1 GETOCH,SUBR,OUTCH
00930		MKAT <DTIME,EQSTR,EDITCH>,SUBR
00940		MKAT1 DODATE,SUBR,DATE
00950		MKSY1 ERRST1,*ERRSET1
00960		MKSY1 ERRST2,*ERRSET2
00970		MKAT1 .NCONC,SUBR,*NCONC
00980		MKAT1 AP2,SUBR,*APPLY
00990		MKAT <DEFLIST,DEFP,DEFV>,FSUBR
01000		MKAT1 RERDCH,SUBR,REREADCH
01010		MKAT1 PROGN,FSUBR,NOCOMPILE
01020		ML EDITEXPR
01030		MKAT1 INTSTR,VALUE,INTERNSTR
01040	INTSTR:	NIL
01050	
01060	;$$ THE BREAK VARIABLES WHICH TELL ABOUT DEPTH IN THE BREAK PACKAGE
01070		MKAT1 BIOCHN,VALUE,#%IOCHANS%#
01080		MKAT1 BPMPT,VALUE,#%PROMPTS%#
01090		MKAT1 BINDNT,VALUE,#%INDENT
01100	BIOCHN:	NIL
01110	BPMPT:	NIL
01120	BINDNT:	INUM0
01130	
01140	VOBLIST: OBLIST
01150	VBASE:	8+INUM0
01160	VIBASE:	8+INUM0
01170	
01180	;WMT - ADD INUM AS AN ATOM (VALUE OF NUMTYP)
01190	ML <PNAME,INUM,FIXNUM,FLONUM,VALUE,LAMBDA,SUBR,FSUBR,EXPR,FEXPR,SYM,∨
01200	$EOF$,LABEL,FUNARG,LSUBR,MACRO>
01210	
01220		PUTOB ?,.+1
01230	QST:	XWD -1,.+1
01240		XWD PNAME,.+1
01250		XWD [PSTRCT(?)],0
01260	
01270	VBPORG:	INUM0
01280	VBPEND:	INUM0
01290	
01300	;MKAT ACHLOC,SYM
01310	;DONT KNOW WHATS UP HERE, IF NEEDED CHECK ACHLOC
01320	;%% THIS WAS A PREDECESSOR TO THE FUNCTIONS UNDER SWITCH "REALLC"
01330	;%% NO LONGER USEFUL
01340	
01350	PAGE
     
00010	;
00020	;***	ALL THE ATOMS IN COMPILED LISP ROUTINES
00030	;***	(GETS PNAMES INTO HI SEG)
00040	
00050	IFN PNAMES <	;*** OFF TO BUILD A STRIPPED SYSTEM.
00060	
00070	MK<XTR,  ?," *COMMENT*",DPRINT,BRKWHEN,EDITXTR,F:>
00080	MK<" has no properties on PRETTYPROPS.",ENTER,BKPOS,CURRCOL,PPCOM>
00090	MK<EXPBPS,SUBLIS,MOVEI,HLRZ@,UNFIND,UNBLOCK,GRINPROPS,MISER,NOTANY>
00100	MK<JUMPE,STKNAME,INSERT,MAXLOOP EXCEEDED,MAXLOOP,LPTLENGTH,F=,TIMER>
00110	MK<Functions-Loaded,DSUBST,TIMES,UPFINDFLG>
00120	MK<FSUBR -- TAKES ONLY ONE ARGUMENT,PREVEV,NOTHING SAVED,UNDOLST>
00130	MK<INTERSECTION,SUBSET,INTERNL,COMSQ,RETFROM,Nothing-Saved,MOVEM>
00140	MK<LASTPOS,USERERRORX,EXTRACT,STKCOUNT,UNDONE,AROUND,PRINLEV,RGETSYM>
00150	MK<HRRZ@,BF,REMPROPS,EXPFS, ...],DSKOUT,LESSP>
00160	MK<" unbreakable unless IN something.",DE,P:,DF,REMOVE,MOVNI,BI,LSUBST>
00170	MK<UNION,JUMPN,UNTRACEV,PUSHJ,UNTRACE,LASTVALUE,EXPFWS,LEXPR,N?>
00180	MK<SHOULD BE LIST OF ATOMIC ARGUMENTS,SHOULD BE LIST,BK,LASTWORD,EVERY>
00190	MK<BRKTYPE,USERMACROS,SPRINT,NOTEVERY,GETSYM,LC,PRINTLEV,IF,PRINTMACRO>
00200	MK<PRINTC,HLLZS@,UNSAVE,START,V:,PUTLIST,BO,PRETTYPROPS,PRETTYFLG,DM>
00210	MK<STRING TOO SHORT - SUBSTRING,CAIE,SUBST,DO,SUBSTRING,QUOTIENT>
00220	MK<THROUGH,"not editable.",LI," not in Symbol Table.",broken,STKNTH,FP>
00230	MK<THROW,IN,CAME,PPL*,FUNTYPE,STKSRCH,FS,OK,BY,RI,LO,HRRZS@,CAIN>
00240	MK<LP,CALL,EX,SURROUND,DSK:,BIND,"[",CAMN,%%V,PP,RPUTSYM,RO,"]",",MV>
00250	MK<TO,TTYMSG,&,UP,HERE,NX,DIRF,PUTSYM,<)>,EXCH,BKEV,*,%%GCTIME>
00260	MK<BAD ARGUMENT - LCONC,BAD ARGUMENT - TCONC,BKFV,SW,... >
00270	MK<- LOCATION UNCERTAIN,<\P>,MARK,ARGS,:::,File-Dumped,SAVE>
00280	MK<$%DOTFLG," . ",SOJE,%%SPEAK,COMS,TDZA,INIT,FROM,%%TIME,SOME,UNDO>
00290	MK<"*WARNING - NOCALL Function ",MOVE,PLEV,LXPD,:,POPJ,HRRM>
00300	MK<"NON-NUMERIC COUNT - RPTQ",SOJN,↑↑,COPY,TTY:,=,WITH,*ANY*,>
00310	MK<"BINARY PROGRAM SPACE EXCEEDED",←←,". . . ",%DEFINE>
00320	MK<" is not a breakable function.",@," is being unbroken.",None-Found,A>
00330	MK<PUSH,B,TEST,%CATCH,HLRZ,C,"No Backup: ",%READIN,TYPE,D,E,JRST,THRU>
00340	MK<PLUS,##,F,RPTN," to ",%ERDEPTH,%DEREAD,!NX,STOP,HRRZ,I,RPTQ,ADD>
00350	MK</BREAK1,PP*,L,M,N,P,!0,R,*RENAME,S,not,BKE,BKF,MBD,#1>
00360	MK<**,NOT A TAIL - LDIFF,#2,NOT BLOCKED,EDIT-SAVE,#3,%DEVP,X>
00370	MK<Y,!UNDO,BFP,--,NO EVAL BLIP - RETFROM,Z,!VALUE,EDIT4E,<\>,%LOOKDPTH>
00380	MK<LCL,PP-LABELS,<\#\>,LAP,↑,←,EMBED," Redefined.",DIFFERENCE,%PRINFN,   >
00390	MK<DIFFERENT EXPRESSION,FILBAK,DIR,!  ,PP-COMMENT,EDIT:,LABELS,CHANGE>
00400	MK<%PREVFN%,BKV,CALLF@," ",PP-FORMAT,DRM,CALLF,MIN,%TRSET,%TRSETQ>
00410	MK<=EDITV,BRACKETS,PP-MISER,CATCH,DSM,MAKEFN,PP-VALUE,MAX,BREAK1>
00420	MK<BREAKIN,BREAK0,BREAKMACROS,BREAK,LDIFF,JCALL,FOR,ORF,MSG,*NOPOINTDSK>
00430	MK<JCALLF@,JCALLF,CLEARM,MEMBFN,Redefined,CLEARB,*RSETERX,PEEKC,SUB>
00440	MK<NTH,EDITCOMSL,GETDEF,ALIAS,NEX,EDITDSUBST,<"(">,*PG*,EDITE,REPACK>
00450	MK<BLOCKED,BLOCK,ADDPROP,DELIM,PPL,<")">,JSP,FNDBRKPT,SELECTQ,USE>
00460	MK<EDITFPAT,LPQ,EDITFINDP,EDITF,EDITFNS,PP-RMACS,PP-LSEG,SPACES, . >
00470	MK<BKFNLIST,ALLFNS,POP,"Set ",BEFORE,LSP,HGHIN,TRACEVFNS,TRACEVed>
00480	MK<TRACEV,TRACEDFNS,TRACE,LCONC,-IN-,BRKAPPLY,BRKCOMS,COMMENTFLG>
00490	MK<COMMENT,NCONC1,OPS,AFTER,ORR,EDITL,::,EDITL0,UNDEF,GREATERP>
00500	MK<BROKENFNS,BROKEN-IN,HRLM@,ERXACTION,BRKFN,FROM?=,EDITMV,EDITMBD>
00510	MK<EDITMACROS,MAPATOMS,QSP,DSKLENGTH,NAMESCHANGED,Broken,REPLACE>
00520	MK<GRINDEF,FILES-LOADED,LAPKLST,EDITOPS,LASTAIL,EDITOF,EDITP,DREVERSE>
00530	MK<MAXLEVEL EXCEEDED,MAXLEVEL,DREMOVE,EDITQF,MARKLST,DUMPATOMS>
00540	MK<TCONC,SECOND,==,EDITRACEFN,PUT,BKSET,BKSETQ,HRRM@,BELOW,DSKIN>
00550	MK<REMLIST,ASSOC#,?=,PRINAC,PRINA,TAILP,LAPQLST, = ,THIRD,SUBPAIR>
00560	MK<UNBREAK0,UNBREAKABLEFNS,ARGUMENT LIST?,ARGPRINT,BRKEXP>
00570	MK<ARGUMENTS NOT FOUND,OCCURRENCES,??,UNBREAK,EDITV,GRINL,***,LAPSLST>
00580	MK<LAPLST,E:,FORMS:,MBD:,PRINL,PRINLC,NOPRETTYPROPS,EDIT,LINES>
00590	MK<" Not Yet Defined.">
00600	MK<%%DTIME," conses",<" msec clock, ">,<" msec GC), ">,<" msec CPU (">>
00610	MK<" can't be broken into."," not found in ">
00620	MK<%EDITPLEV,%BKPRINLEV,BREAK0B>  ;WMT
00630	>
00640	
00650	BFWS:
00660	EFWS:	0
00670	RELOC
00680	XLIST	;*** LITERALS (INCLUDING HI-SEG FWS) ARE HERE
00690	LIT
00700	LIST
00710	BHORG:	0
00720	RELOC
00730		PAGE
     
00010			SUBTTL LISP STORAGE ALLOCATOR (ONCE ONLY) 
00020	
00030	
00040	FIRST:	CLEARM	0,SBPS		;SET UP INITIAL ALLOCATIONS FOR SPACE
00050		HRRZI	A,BFWS-FS	;THIS IS THE SIZE OF THE ORIGINAL FS
00060		HRRZM	A,SFS
00070		HRRZI	A,EFWS-BFWS	;THIS ALLOWS ONLY THE INITIAL
00080		HRRZM	A,SFWS		;FWS
00090		HRRZI	A,0		;THE INITIAL ALLOCATION FOR SPDL
00100		HRRZM	A,SSPDL
00110		HRRZM	A,SRPDL		;AND FOR RPDL IS SET UP IN INALLC
00120		HRRZI	A,FS
00130		HRRZM	A,FSO		;THIS SETS UP INITIAL FS POINTER
00140		HRRZI	A,BFWS		;THIS SETS UP INITIAL FWS ORIGIN POINTER
00150		HRRZM	A,FWSO#
00160	
00170		HRRZI	A,EFWS
00180		HRRZM	A,EFWSO#
00190	
00200	
00210		MOVEI	A,FS
00220		ADDM	A,VBPORG	;SET UP VARIABLE FOR BPS ORIGIN
00230		SOS	A
00240		ADDM	A,VBPEND
00250	
00260		MOVE	A,.JBREL
00270		HRLM	A,.JBSA
00280		RESET
00290		MOVEI	A,START
00300		HRRM	A,.JBSA		;SET STARTING ADDR
00310		HRRZS	.JBHRL		;*** SET TO SAVE ENTIRE HI-SEG
00320	
00330		SETOM	INITFW#		;FLAG FOR STANDARD INITIALIZATION OF
00340		SETZM	JRELO#		;SIZES, AND TO INDICATE CORE WAS EXPANDED
00350	
00360		JRST	INALLC
00370		PAGE
     
00010		SUBTTL INTERNAL SYMBOLS FOR MACRO REFERENCES
00020	
00030	
00040	DEFINE MKENT (A)<
00050	INTERNAL A>
00060	;##DEBUG QUEUE
00070	MKENT <CADAR,ATMOV,CADAR,CORUSE,DEV>
00080	IFN	QALLOW<			;%% [1]
00090	MKENT <COPIES>			;%% [1]
00100			>		;%% [1]
00110	MKENT <EXT,HGHDAT,INUM0,INUMIN,IOPPN,LISTAT,MORCOR,MOVDWN>
00120	MKENT <NXTIO,OLDCU,SIXMAK,STNIL>
00130	
00140	IFN BIGNMS<
00150	MKENT <EVBIG,NUMBP2,OPOV,NUMV2,NUMV3,NUMV4,FIX2,NUM1,NUM3,BPR>>
00160	MKENT <OPR,FLOOV,FWCONS,FALSE,TRUE,FW0CNS,NCONS>
00170	MKENT <READ,READP1,MAKNUM,PRIN1,PRINT,EXPLODE,SASSOC,EQUAL>
00180	MKENT <CHCT,LINL,OLDCH,FLATSIZE,TYI,RATOM,CHRCT,TYOD>
00190	MKENT <GET,INTERN,REMOB,MAKNAM,GENSYM,FIX,LENGTH,READLIST,PATOM>
00200	MKENT <LAST,INC,OUTC,FIX1A,NUMVAL,REVERSE,MAPLIST,GC,GETL,PUTPROP>
00210	MKENT <ERR,MAPCAR,REMPROP,LIST,SETQ,ERRSET,REMOB,ARRAY,APPEND>
00220	MKENT <SPECBIND,SPECSTR,XCONS,ATOM,READCH,SET,NCONC,PRINC>
00230			;WMT- STRT CHANGED TO LSPRET
00240	MKENT <CONS,ACONS,CTY,FP7A1,TERPRI,LSPRET>
00250	MKENT <TYO,ITYO,IGSTRT,NOINFG,CHRTAB,EVAL,OEVAL,.APPEND,INPUT,OUTPUT>
00260	IFN ALVINE,<MKENT<PSAV1,BKTRC>>
00270	
00280	;%% RECENT ADDITIONS
00290	MKENT <FLTYIA,SIXATM,BNINIT,RDFILE,UFDINP,MYPPN>
00300	IFN	QALLOW<		;%% [1]
00310	MKENT <QUEUE>			;%% [1]
00320			>		;%% [1]
00330	MKENT <SYSIN0,SYSIN1,SYSINI,SYSINP>
00340		IFN	REALLC <
00350	MKENT <FWCNT,FSCNT,REALLO>
00360	>
00370	
00380	;$$ FOR ALAN'S DIRECT ACCESS INPUT
00390	MKENT <ININBF,TYI2,TYIA,INCH>
00400	
00410	;## FOR BILL'S DIRECT ACCESS INPUT/OUTPUT
00420	MKENT <AIN.2,AIN.4,AIN.7,AOUT.2,CHANNE>
00430	MKENT <CHNSUB,CHTAB,DEVDAT,ENTR,IOSUB>
00440	MKENT <LOOKIN,OUTCH,OUTERR,POPAJ,PPN,SMAC>
00450	MKENT <TABSR1,TABSRC,TYI2E,TYI2Z,TYI3B,TYO2X>
00460	MKENT <TYO5,AIOP,SETIN>
00470	
00480	;$$ FOR ALVINE
00490	MKENT <PROMPT,INUM0,MEMQ,UNBOUND>
00500	
00510	;%% FOR THE MODIFIED ARITHMETIC PACKAGE
00520	MKENT <FIXNUM,FLONUM>
00530	
00540	;WMT
00550	MKENT <CCTLR,CCTLH,CCTLE,CCTLB,CCTLD,CCTLG,CCTLX>
00560	MKENT <SFS,SFWS,SRPDL,SSPDL,SBPS>
00570	
00580	PAGE
00590		END FIRST
00600	
00610	β