;;;   **************************************************************
;;;   ***** MACLISP ****** FASLOAD  ********************************
;;;   **************************************************************
;;;   ** (C) COPYRIGHT 1981 MASSACHUSETTS INSTITUTE OF TECHNOLOGY **
;;;   ****** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) *******
;;;   **************************************************************

	PGBOT FSL

SUBTTL	HAIRY RELOCATING LOADER (FASLOAD)

;;; BUFFER PARAMETERS
LLDAT==:770		;LENGTH OF LOADER'S ATOMTABLE ARRAY
ILDAT==:1000		;AMOUNT TO INCREMENT ATOMTABLE ARRAY
LLDSTB==:400		;SIZE OF LDPUT'S SYMBOL TABLE ARRAY (IN 2-WD ENTRIES)

;;; PDL OFFSETS
LDAGEN==:0		;SAR FOR ATOMTABLE
LDPRLS==:-1		;PURE CLOBBERING LIST
LDDDTP==:-2		;DDT FLAG
LDBGEN==:-3		;SAR FOR I/O BUFFER
LDNPDS==:4		;NUMBER OF REGPDL SLOTS TAKE UP BY FASLOAD TEMPORARIES

;;; FASLOAD USES AN ARRAY OF ATOMS TO AVOID CONSTANTLY CREATING
;;; THE SAME ATOMS OVER AND OVER; IN PARTICULAR, THIS SAVES MUCH
;;; TIME IN INTERN FOR ATOMIC SYMBOLS. THIS TABLE IS CREATED
;;; INCREMENTALLY DURING THE LOAD FROM DATA IN THE FASL FILE.  THE
;;; ARRAY HAS ONE ONE-WORD ENTRY FOR EACH ATOM. ENTRY 0 IS FOR NIL;
;;; THE OTHERS MAY BE IN ANY ORDER. THE FORMAT OF EACH ATOMTABLE
;;; ENTRY IS AS FOLLOWS: 
;;;	4.9-4.1	IF NON-ZERO, THE THE LEFT HALF OF THE ENTRY
;;;		(4.9-3.1) CONTAINS THE ADDRESS OF THE VALUE
;;;		CELL OF THE ATOM (SYMBOLS ONLY). THIS WORKS
;;;		BECAUSE ALL VALUE CELLS ARE ABOVE ADDRESS 777.
;;;		NOTE THAT OTHER LEFT HALF BITS DESCRIBED HERE
;;;		HAVE MEANING ONLY IF BITS 4.9-4.1 ARE ZERO.
;;;	3.4	THIS BIT IS TURNED ON IF THE ATOM IS PROTECTED
;;;		FROM THE GARBAGE COLLECTOR BECAUSE IT IS POINTED
;;;		BY SOME LIST STRUCTURE WHICH IS PROTECTED. THIS
;;;		IS A HACK SO THAT USELESS ENTRIES WON'T BE MADE
;;;		IN THE GC PROTECTION ARRAY (SEE GCPRO).
;;;	3.3-3.2	INDICATES THE TYPE OF ATOM: 0 => SYMBOL,
;;;		1 => FIXNUM, 2 => FLONUM, 3 => BIGNUM.
;;;	3.1	THIS BIT IS TURNED ON IF THE ATOM IS EVER
;;;		REFERENCED, DIRECTLY OR INDIRECTLY, BY COMPILED
;;;		CODE (IT MIGHT NOT BE IF USED ONLY IN MUNGABLES).
;;;		IT INDICATES THAT THE ATOM MUST SOMEHOW BE
;;;		PROTECTED FROM THE FEROCIOUS GARBAGE COLLECTOR.
;;;		2.9-1.1	CONTAINS THE ADDRESS OF THE ATOM. (SURPRISE!)
;;; NOTE THAT ONCE AN ATOM IS IN THE TABLE, THE FASL FILE WILL
;;; REFER TO THE ATOM BY ITS TABLE INDEX, SO THAT IT CAN BE
;;; RETRIEVED EXTREMELY QUICKLY.
;;; FORMAT OF FASL FILES:
;;;
;;; THE "NEW" FASLOAD SCHEME (AS OF 1/31/73) USES A NEW FORMAT FOR
;;; ITS FILES. A FASL FILE CONSISTS OF TWO HEADER WORDS, FOLLOWED BY
;;; A SERIES OF FASL BLOCKS; THE TWO HEADER WORDS ARE BOTH SIXBIT,
;;; THE FIRST BEING "*FASL+" (FOR HISTORICAL REASONS, "*FASL* IS
;;; ALSO ACCEPTED) AND THE SECOND THE CONTENTS OF LOCATION LDFNM2 IN
;;; THE LISP WHICH ASSEMBLED THE FILE (A VERSION NUMBER IN SIXBIT). 
;;; EACH FASL BLOCK CONSISTS OF A WORD OF NINE FOUR-BIT RELOCATION
;;; BYTES, FOLLOWED BY NINE PIECES OF FASL DATA.  THE LENGTH OF EACH
;;; DATA ITEM IS DEPENDENT ON THE RELOCATION TYPE; THUS FASLBLOCKS
;;; ARE OF VARYING LENGTH.  THE LAST BLOCK MAY HAVE FEWER THAN NINE
;;; DATA ITEMS.  THE RELOCATION TYPES AND THE FORMATS OF THE
;;; ASSOCIATED DATA ITEMS ARE AS FOLLOWS: 
;;;
;;;	TYPE 0	ABSOLUTE
;;; ONE ABSOLUTE WORD TO BE LOADED.
;;;
;;;	TYPE 1	RELOCATABLE
;;; ONE WORD, THE RIGHT HALF OF WHICH IS RELOCATABLE; I.E. AT LOAD
;;; TIME THE LOAD OFFSET IS TO BE ADDED TO THE RIGHT HALF. 
;;;
;;;	TYPE 2	SPECIAL
;;; A WORD TO BE LOADED, WHOSE RIGHT HALF CONTAINS THE INDEX OF AN
;;; ATOM (HOPEFULLY OF TYPE PNAME) THE ADDRESS OF THE VALUE CELL OF
;;; WHICH IS TO REPLACE THE RIGHT HALF OF THE LOADED WORD. (IF NO
;;; VALUE CELL EXISTS, ONE IS TO BE CREATED.)
;;;
;;;	TYPE 3	SMASHABLE CALL
;;; SIMILAR TO TYPE 4 (Q.V.) EXCEPT THAT THE INSTRUCTION IS ONE OF
;;; THE SERIES OF CALL UUOS WHICH MAY BE "SMASHED" FOR PURIFICATION
;;; PURPOSES. AT PRESENT THESE UUOS ARE: CALL, JCALL, NCALL, NJCALL. 
;;;
;;;	TYPE 4	QUOTED ATOM
;;; ONE WORD TO BE LOADED WHOSE RIGHT HALF CONTAINS THE INDEX OF AN
;;; ATOM WHOSE ADDRESS IS TO REPLACE THE RIGHT HALF OF THE WORD
;;; LOADED. 
;;;
;;;	TYPE 5	QUOTED LIST
;;; A SERIES OF WORDS REPRESENTING AN S-EXPRESSION TO BE CONSTRUCTED
;;; BY THE LOADER. THE FORMAT OF THESE WORDS IS BEST EXPLAINED BY
;;; THE ALGORITHM USED TO CONTRUCT THE S-EXPRESSION: THE LOADER
;;; EXAMINES BITS 4.7-4.9 OF SUCCESSIVELY READ WORDS, AND DISPATCHES
;;; ON THEM: 
;;; 0	THE ATOM WHOSE INDEX IS IN THE RIGHT HALF OF THE WORD
;;;	IS PUSHED ONTO A STACK. 
;;; 1	THE LOADER POPS AS MANY ITEMS OFF THE STACK AS
;;;	SPECIFIED BY THE NUMBER IN THE RIGHT HALF OF THE WORD
;;;	AND MAKES A LIST OF THEM, SO THAT THE LAST ITEM POPPED
;;;	BECOMES THE FIRST ITEM OF THE LIST; THIS LIST IS THEN
;;;	PUSHED ONTO THE STACK. 
;;; 2	THE LOADER POPS ONE ITEM OFF THE STACK AND PROCEEDS AS
;;;	FOR 1, EXCEPT THAT THE ITEM FIRST POPPED IS USED TO
;;;	END THE LIST INSTEAD IF NIL. (THIS ALLOWS FOR DOTTED
;;;	PAIRS.)
;;; 3	THE TOP ITEM ON THE STACK IS EVALUATED AND STORED BACK
;;;	ON THE TOP OF THE STACK. 
;;; 4	THE RIGHT HALF OR THE WORD SPECIFIES THE LENGTH OF A
;;;	HUNK TO BE MADE BY TAKING THAT MANY ITEMS FROM THE TOP
;;;	OF THE STACK;  THIS HUNK IS THEN PUSHED BACK. 
;;; 5	UNUSED.
;;; 6	UNUSED.
;;; 7	THE LEFT HALF OF THE WORD SHOULD BE -1 OR -2,
;;;	INDICATING THE SECOND LAST WORD OF THE DATA; IF -1,
;;;	THE RIGHT HALF OF THIS WORD AND THE ADDRESS OF (WHAT
;;;	SHOULD BE) THE SINGLE ITEM ON THE STACK (WHICH IS
;;;	POPPED OFF) ARE MADE RESPECTIVELY INTO THE LEFT AND
;;;	RIGHT HALVES OF A WORD TO BE LOADED INTO BINARY
;;;	PROGRAM SPACE; IF -2, THE S-EXPRESSION IS PLACED INTO
;;;	THE NEXT SLOT OF THE ATOMTABLE (SEE TYPE 12).  THE ONE
;;;	WORD REMAINING IS THE HASH KEY OF THE S-EXPRESSION AS
;;;	COMPUTED BY SXHASH; THIS IS USED BY THE LOADER TO SAVE
;;;	GCPRO SOME WORK. 
;;;
;;;	TYPE 6	GLOBALSYM
;;; ONE WORD; THE RIGHT HALF IS AN INDEX INTO THE TABLE LSYMS IN
;;; LISP. THE INDICATED VALUE IS RETRIEVED, NEGATED IF BIT 4.9 OF
;;; THE DATA WORD IS 1, AND ADDED TO THE RIGHT HALF OF THE LAST
;;; WORD LOADED INTO BINARY PROGRAM SPACE.  THIS ALLOWS LAP CODE
;;; TO REFER TO SELECTED LOCATIONS INTERNAL TO LISP WITHOUT
;;; GETTING SYMBOLS FROM DDT. 
;;;
;;;	TYPE 7	GETDDTSYM
;;; IF THE FIRST WORD IS -1, THEN THE LOAD OFFSET IF ADDED INTO
;;; THE LEFT HALF OF THE WORD MOST RECENTLY LOADED INTO BINARY
;;; PROGRAM SPACE (THIS IS HOW LEFT HALF RELOCATION IS
;;; ACCOMPLISHED).  OTHERWISE, THE FIRST WORD CONTAINS IN BITS
;;; 1.1-4.5 A SYMBOL IN SQUOZE CODE. THE LOADER GETS THE VALUE OF
;;; THIS SYMBOL FROM DDT IF POSSIBLE, NEGATES IT IF BIT 4.9 IS 1,
;;; THEN ADDS THE RESULT TO THE FIELD OF THE LAST WORD LOADED AS
;;; SPECIFIED BY BITS 4.6-4.7: 
;;;	3 = ENTIRE WORD
;;;	2 = AC FIELD ONLY
;;;	1 = RIGHT HALF ONLY
;;;	0 = ENTIRE WORD, BUT SWAP HALVES OF VALUE BEFORE ADDING.
;;; THESE FOUR FIELDS CORRESPOND TO OPCODE, AC, ADDRESS, AND INDEX
;;; FIELDS RESPECTIVELY IN A LAP INSTRUCTION.  IF BIT 4.8 IS A 1,
;;; THEN ANOTHER WORD FOLLOWS, CONTAINING THE VALUE OF THE SYMBOL
;;; AS OBTAINED FROM DDT AT ASSEMBLE TIME. IF THE VERSION NUMBER
;;; OF THAT LISP (AS DETERMINED FROM THE SECOND FILE HEADER WORD)
;;; IS THE SAME AS THAT OF THE LISP BEING LOADED INTO, THEN THIS
;;; VALUE IS USED AND DDT IS NOT CONSULTED AT LOAD TIME; THIS IS
;;; FOR SPEED. IF THE VERSION NUMBERS ARE DIFFERENT, THEN DDT IS
;;; CONSULTED. 
;;;
;;;	TYPE 10	ARRAY REFERENCE
;;; ONE WORD TO BE LOADED, WHOSE RIGHT HALF CONTAINS THE ATOMINDEX
;;; OF AN ATOMIC SYMBOL. IF THE SYMBOL HAS AN ARRAY PROPERTY, IT
;;; IS FETCHED; OTHERWISE ONE IS CREATED. THE RIGHT HALF OF THE
;;; WORD TO BE LOADED IS REPLACED WITH THE ADDRESS OF THE SECOND
;;; WORD OF THE ARRAY POINTER (I.E. OF THE TTSAR).  IN THIS WAY
;;; ACCESSES TO ARRAYS CAN BE OPEN-CODED. 
;;;
;;;	TYPE 11	UNUSED
;;;
;;;	TYPE 12	ATOMTABLE INFO
;;; A HEADER WORD, POSSIBLY FOLLOWED BY OTHERS, DEPENDING ON BITS
;;; 4.7-4.9: 
;;; 0	THE RIGHT HALF IS THE NUMBER OF WORDS FOLLOWING, WHICH
;;;	CONSTITUTE THE PNAME OF A PNAME-TYPE ATOM, IN THE
;;;	ORDER OF THEIR APPEARANCE ON A PROPERTY LIST. THE ATOM
;;;	IS INTERNED. 
;;; 1	THE ONE WORD FOLLOWING IS THE VALUE OF A FIXNUM TO BE
;;;	CREATED. 
;;; 2	THE FOLLOWING WORD IS THE VALUE OF A FLONUM. 
;;; 3	THE RIGHT HALF IS THE NUMBER OF FIXNUM COMPONENTS OF A
;;;	BIGNUM FOLLOWING, MOST SIGNIFICANT WORD FIRST.  BIT 3.1
;;;	IS THE SIGN OF THE BIGNUM.
;;; 4	THE FOLLOWING TWO WORDS ARE A DOUBLE-PRECISION NUMBER.
;;; 5	THE FOLLOWING TWO WORDS ARE A COMPLEX NUMBER.
;;; 6	THE FOLLOWING FOUR WORDS ARE A DUPLEX NUMBER.
;;; 7	UNUSED.
;;; THE ATOM THUS CREATED IS ASSIGNED A PLACE IN THE ATOMTABLE
;;; MAINTAINED BY THE LOADER (AS AN ARRAY) USING CONSECUTIVE
;;; LOCATIONS; FROM THAT POINT ON OTHER DATA ITEMS REFERRING TO
;;; THAT ITEM CAN DO SO BY THE INDEX OF THE ATOM IN THIS TABLE. 
;;; SEE ALSO TYPES 5 AND 16, WHICH ALSO MAKE ENTRIES IN THE
;;; ATOMTABLE. 
;;;
;;;	TYPE 13	ENTRY INFO
;;; TWO WORDS. THE LEFT HALF OF THE FIRST WORD IS THE ATOMINDEX
;;; OF THE NAME OF THE FUNCTION BEING DEFINED; THE RIGHT HALF
;;; THAT OF THE SUBR TYPE (THE PROPERTY UNDER WHICH TO CREATE THE
;;; ENTRY POINT, E.G. SUBR OR FSUBR).  THE RIGHT HALF OF THE
;;; SECOND WORD IS THE LOCATION OF THE ENTRY POINT AS A
;;; RELOCATABLE POINTER: THE LOAD OFFSET MUST BE ADDED TO IT. THE
;;; LEFT HALF OF THE SECOND WORD CONTAINS THE ARGS PROPERTY, IN
;;; INTERNAL ARGS PROPERTY FORMAT, AS SPECIFIED IN THE ORIGINAL
;;; LAP CODE BY THE ARGS CONSTRUCT. 
;;;
;;;	TYPE 14	LOC
;;; THE WORD IS A RELOCATABLE QUANTITY SPECIFYING WHERE TO
;;; CONTINUE LOADING.  IT IS NOT PERMITTED TO LOC BELOW THE
;;; ORIGIN OF THE ASSEMBLY. IF THE LOC IS TO A LOCATION HIGHER
;;; THAN ANY YET LOADED INTO, THEN FASLOAD ZEROS OUT ALL WORDS
;;; ABOVE THAT HIGHEST LOCATION UP TO THE LOCATION SPECIFIED. 
;;; FASLOAD KEEPS TRACK OF THE HIGHEST LOCATION EVER LOADED INTO;
;;; THIS VALUE PLUS ONE BECOMES THE VALUE OF BPORG AT THE END OF
;;; ASSEMBLY, REGARDLESS OF THE STATE OF THE LOCATION POINTER
;;; WHEN LOADING TERMINATES.  THIS TYPE IS NEVER USED BY LAP
;;; CODE, BUT ONLY BY MIDAS .FASL CODE. 
;;;
;;;	TYPE 15	PUTDDTSYM
;;; FIRST WORD, THE SYMBOL IN SQUOZE CODE.  IF BIT 4.9=0, THE
;;; SYMBOL IS DEFINED TO DDT IF POSSIBLE WITH THE ADDRESS OF THE
;;; WORD OF BINARY PROGRAM SPACE ABOUT TO BE LOADED INTO AS ITS
;;; VALUE.  IF BIT 4.9=1, THE VALUE IS GOBBLED FROM THE FOLLOWING
;;; WORD. BIT 4.8 (OF THE WORD CONTAINING THE SQUOZE) MEANS
;;; RELOCATE THE LEFT HALF OF THE VALUE BY THE LOAD OFFSET, AND
;;; BIT 4.7 LIKEWISE FOR THE RIGHT HALF.  WHETHER OR NOT THE
;;; SYMBOL ACTUALLY GETS PUT IN DDT'S SYMBOL TABLE IS A FUNCTION
;;; OF THREE CONDITIONS: FIRST, THAT THERE IS A DDT WITH A SYMBOL
;;; TABLE; SECOND, THE VALUE OF THE LISP VARIABLE "SYMBOLS"; 
;;; THIRD, BIT 4.6 OF THE FIRST PUTDDTSYM WORD. THE FIRST
;;; CONDITION OF COURSE MUST BE SATISFIED. IF SO, THEN THE SYMBOL
;;; IS PUT IN THE SYMBOL TABLE ONLY IF SYMBOLS HAS A NON-NIL
;;; VALUE. FURTHERMORE, IF THAT VALUE IS THE ATOM SYMBOLS ITSELF,
;;; THEN THE SYMBOL IS PUT ONLY IF BIT 4.6 IS ON (INDICATING A
;;; "GLOBAL" SYMBOL). 
;;;
;;;	TYPE 16	EVAL MUNGEABLE
;;; A SERIES OF WORDS SIMILAR TO THOSE FOR TYPE 5, BUT WITH NO
;;; FOLLOWING HASH KEY. AN S-EXPRESSION IS CONSTRUCTED AND
;;; EVALUATED. THIS IS USED FOR THE SO-CALLED "MUNGEABLES" IN A
;;; FILE OF LAP CODE.  IF THE LEFT HALF OF THE LAST WORD IS -1,
;;; THE VALUE IS THROWN AWAY. IF IT IS -2, THE VALUE IS ENTERED
;;; IN THE ATOMTABLE. 
;;;
;;;	TYPE 17	END OF BINARY
;;; ONE WORD, WHICH MUST BE "*FASL+" (OR "*FASL*") IN SIXBIT.
;;; THIS SHOULD BE THE LAST DATA WORD IN THE FILE. ANY RELOCATION
;;; BYTES LEFT OVER AFTER A TYPE 17 ARE IGNORED.  THIS SHOULD BE
;;; FOLLOWED EITHER BY END OF FILE OR A WORD FULL OF ^C'S. 

;;; INTERNAL AUTOLOAD ROUTINE

IALB:	HRRZ A,(A)		;SUBR 1
	MOVEI B,QA%DDD
	PUSHJ P,MERGEF
	JRST LOAD


FASLOAD:
	JSP TT,FWNACK
	FA01234,,QFASLOAD
	SKIPE FASLP
	 JRST LDALREADY
	PUSH P,FLP		;FOR DEBUGGING PURPOSES
	PUSH P,FXP		.SEE LDEOMM
	PUSH P,SP
10$	SETOM LDEOFP		;FLAG FOR CRUFTY D10 DUMP MODE I/O EOF
	PUSHJ P,FIL6BT
	MOVE T,DFNWD			;DEFAULT FILE-NAME WORD - "*"
	MOVE TT,DFFNWD			;DEFAULT FASL-FILE-NAME WORD - "FASL"
20$	SKIPE -L.6VRS-L.6EXT+1(FXP) 	    ;EXTENSION (2ND FILE NAME) NULL?
	 CAMN T,-L.6VRS-L.6EXT+1(FXP) 	    ;  OR EQUAL TO *?  IF EITHER CASE,
	  MOVEM TT,-L.6VRS-L.6EXT+1(FXP)    ;  THEN USE  "FASL"
IFN D20,[
	MOVE TT,[ASCII \0\]
	SKIPE -L.6VRS+1(FXP) 		    ;VERSION NUMBER NULL?
	 CAMN T,-L.6VRS+1(FXP) 		    ;  OR EQUAL TO *?  IF EITHER CASE,
	  MOVEM TT,-L.6VRS+1(FXP)	    ;  THEN USE  "0"
]		;END OF IFN D20
	PUSHJ P,DMRGF
	PUSHJ P,6BTNML
	MOVEI B,TRUTH
	MOVE AR2A,VFEXDEFAULT
	JSP T,SPECBIND
	   0 A,LDFNAM		   ;Must bind LDFNAM for recursive fasloading
	   0 B,VNORET
	   0 AR2A,VFEXITFUNCTIONS
	       FASLP
	PUSH P,[LDXXY1]
	PUSH P,A
	PUSH P,[QFIXNUM]
	MOVNI T,2
	JRST $OPEN
LDXXY1:	MOVEM A,FASLP
	PUSH P,A		   ;Save the file to be hacked on for exit
	JSP TT,UNWINC		   ;Arrange to do stuff on finish
	  CAIA			   ;  Do the FASLOAD
	    JRST EOFEV		   ;    And go do the associated cleanup,
				   ;	including closing the file.

	PUSH P,A
	HRRZM A,LDBSAR
	MOVE A,LDFNAM
	SETZM LDTEMP		;CROCK!

;FALLS THROUGH

;FALLS IN

;;; COME HERE TO "DO IT SOME MORE"

LDDISM:	PUSHJ P,LDGDDT		;SET UP DDT FLAG:  0 => NO DDT; 
	PUSH P,TT		;-1,,0 => DDT, NO SYMBOLS; 1,,X => DDT, SYMBOLS
				;X MAY BE 0, OR SAR FOR SYMBOL TABLE ARRAY
				; (SEE LDPUT)
	SKIPN F,VPURE		;SET UP CALL PURIFY FLAGS:
				;400000,,XXX => NO PURIFY HACKERY
	 TLOA F,400000		;200000,,XXX => SUBST XCTS FOR CALLS,
				; PUT CALLS IN SEPARATE PAGES
				;100000 BIT MEANS FASLOAD INTO HISEG (D10 ONLY)
	  HRRZ F,VPURCLOBRL	;0,,<PURE LIST> => SUBST PUSHJS AND
				; JRSTS FOR CALLS
	PUSH P,F		;	ANY CALLS NOT IMMEDIATELY SMASHABLE
	MOVE A,VPURE		;	ARE CONSED ONTO THE PURE LIST
	PUSHJ P,FIXP		;LEAVES VALUE IN TT IF INDEED FIXNUM
	JUMPE A,LDXXX1
	MOVSI F,200000
	IORM F,(P)
IFN <PAGING-1>*HISEGMENT,[
	JUMPGE TT,LDXQQ7	;IF PURE IS A NEGATIVE FIXNUM, DO HISEG HACKERY
IFE SAIL,[
	HRROI T,.GTSGN		;FIND WHETHER HISEG SHARABLE (FROM
	GETTAB T,		;6.03 MONITOR CALLS)
	 JRST .+2
	TLNN T,(SN%SHR)
]	;END OF IFE SAIL
SA$	SKIPL .JBHRL		;IS HISEG CURRENTLY WRITE-PROTECTED?
	 JRST LDXQQ5
	PUSH FXP,TT
	LOCKI			;LOCK OUT INTS AROUND USE OF TMPC
	SKIPN SGANAM
	 JSP T,FASLUH
	MOVEI T,.IODMP
	MOVE TT,SGADEV
	SETZ D,
	OPEN TMPC,T		;OPEN UP .SHR FILE DEVICE IN DUMP MODE
	 JSP T,FASLUH
	MOVE T,SGANAM
	MOVE TT,SGAEXT
	SETZ D,
	MOVE R,SGAPPN
	LOOKUP TMPC,T
	 JSP T,FASLUR
SA$	MOVS T,R
SA%	JUMPGE R,FASLUR
SA%	HLRE T,R
	MOVNS T			;T GETS LENGTH OF .SHR FILE
	PUSHJ P,LDRIHS		;GO READ IN HIGH SEGMENT (FROM WITHIN LOSEG!)

LDRTHS:	RELEASE TMPC,		;FLUSH TEMP CHANNEL
	UNLOCKI
	POP FXP,TT
	MOVE F,SVPRLK		;CAN NOW USE SAVED PURE SEGMENTS FROM LAST TIME
	SETZM SVPRLK
	MOVEM F,PRSGLK
LDXQQ5:	MOVSI F,100000
	IORM F,(P)		;SET FLAG SAYING WE'RE HACKING THE HISEG
	MOVMS TT
	PUSHJ P,LDXHHK		;SET UP XCT PAGES USING HISEG 
	MOVE A,V.PURE
	PUSHJ P,FIXP		;LEAVES VALUE IN TT IN INDEED FIXNUM
	JUMPE A,LDXXX1		;IF FIXNUM, IT IS AN ESTIMATE OF PURE FREE STG
	CAIG TT,10		;IF 10 OR LESS, MULTIPLY BY 1024.
	 LSH TT,12
	CAILE TT,0		;CHECK FOR REASONABLENESS
	 CAILE TT,MEMORY+.RL1-ENDHI
	  JRST LDYERR
	MOVSI D,-NFF-1
	SUB TT,PFSSIZ(D)	;SUBTRACT FROM ESTIMATE THE CURRENT
	AOBJN D,.-1		; SIZES OF EXISTING PURE AREAS
	MOVE D,PRSGLK
LDXQQ2:	JUMPE D,LDXQQ3		;ALSO ACCOUNT FOR ANY PURE SEGMENTS
	SUBI TT,SEGSIZ		; ALREADY IN THE FREELIST
	LDB D,[SEGBYT,,GCST(D)]
	JRST LDXQQ2

LDXQQ3:	JUMPLE TT,LDXXX1	;JUMP IF GUESSTIMATE ALREADY SATISFIED
	ADDI TT,SEGSIZ-1	;ROUND UP TO AN INTEGRAL
	ANDI TT,SEGMSK		; NUMBER OF SEGMENTS
	MOVE D,HBPORG
	ADDI D,SEGSIZ-1		;ALSO ROUND UP HISEG BPORG
	ANDI D,SEGMSK
	MOVE R,D
	ADD D,TT
	SUBI D,1
	TLNE D,-1
	 JRST FASLNX		;COMPLAIN IF NOT ENOUGH MEMORY
	MOVEM D,HBPORG		;UPDATE HISEG BPORG PAST ALLOCATED SEGMENTS
	AOS HBPORG
	CAMG D,HBPEND
	 JRST LDXQQ6
	MOVEM D,HBPEND		;IF NEW HISEG BPORG TOO LARGE,
SA%	HRLZI D,(D)
SA%	CORE D,
SA$	CORE2 D,		; MUST REQUEST MORE CORE FOR HISEG
	 JRST FASLNX		;COMPLAIN IF NOT ENOUGH MEMORY
LDXQQ6:	LSH R,-SEGLOG		;UPDATE SEGMENT TABLES,
	LSH TT,-SEGLOG		; AND ADD PURE SEGMENTS TO FREELIST
	MOVE D,[$XM+PUR,,QRANDOM]
	MOVE F,PRSGLK
LDXQQ8:	MOVEM D,ST(R)
	SETZM GCST(R)
	DPB F,[SEGBYT,,GCST(R)]
	MOVEI F,(R)
	ADDI R,1
	SOJG TT,LDXQQ8
	MOVEM F,PRSGLK
	JRST LDXXX1
]		;END OF IFN <PAGING-1>*HISEGMENT

IFN D10*<PAGING-1>,[
LDXQQ7:
HS%	MOVMS TT
	PUSHJ P,LDXHAK		;SET UP XCT HACK PAGES WITHOUT HISEG
]	;END IFN D10*<PAGING-1>

;FALLS THROUGH

;FALLS IN

LDXXX1:	MOVE TT,[-LLDAT+1,,1]	;INIT ATOMTABLE AOBJN INDEX
	MOVEM TT,LDAAOB
	MOVEI TT,LLDAT		;CREATE ATOMTABLE ARRAY
	MOVSI A,400000
	PUSHJ P,MKLSAR
	PUSH P,A		;SAVE SAR OF ATOM-TABLE ARRAY FOR GC PROTECTION
	HRRZM B,LDASAR		;SAVE ADDRESS OF SAR
	PUSHJ P,LDLRSP		;LOCKI, AND SET UP ARRAY POINTERS
	SETZ TT,		;ENTRY 0 IN ATOMTABLE IS FOR NIL
	SETZM @LDAPTR
	MOVEI TT,LDFERR		;INIT ADDRESS FOR PREMATURE EOF
	MOVEM TT,LDEOFJ
	SKIPE F,LDTEMP		;IF LDTEMP IS NON-NIL, IT IS THE SAVED I/O BUFFER POINTER
	 JRST LDXXX9
	JSP T,LDGTW1		;GET FIRST WORD OF FILE
	TRZ TT,1		;COMPATIBILITY CROCK
	CAME TT,[SIXBIT \*FASL*\]	;IT BETTER BE THIS VALUE!
	 JSP D,LDFERR
LDXXX9:	JSP T,LDGTWD		;GET VERSION OF LISP FILE WAS ASSEMBLED IN
	XOR TT,LDFNM2
	MOVEM TT,LDF2DP		;NON-ZERO IFF VERSIONS DIFFERENT
	MOVE AR1,[000400,,LDBYTS]	;INIT RELOCATION BYTES POINTER
	SETZM LDHLOC
	HRRZ R,@VBPORG
HS$ 10$	MOVE TT,LDPRLS(P)
HS$ 10$	TLNE TT,100000		;SKIP UNLESS LOADING INTO HISEG
HS$ 10$	 HRRZ R,HBPORG
	HRRM R,LDOFST		;INITIALIZE LOAD OFFSET
	JRST LDABS0		;R HAS ADDRESS TO LOAD NEXT WORD INTO

SUBTTL	ROUTINE TO SET UP PAGES FOR XCT HACK (NON-PAGING, FIXED NUMBER OF SLOTS)
IFE PAGING,[
;;;	TT HAS NUMBER OF WORDS (1K BLOCKS IF <8) DESIRED.

LDXHHK:	HRROS (P)		;THIS ENTRY USES THE HISEG
LDXHAK:	SKIPE LDXSIZ		;MAYBE WE NEED TO SET UP PAGES FOR XCT HACKERY
	 POPJ P,		;IF NOT, JUST EXIT
	JUMPLE TT,LDXERR
	CAIG TT,10		;IF 10 OR LESS, MULTIPLY BY 1024.
	 LSH TT,12
	ADDI TT,PAGSIZ-1	;ROUND UP TO A WHOLE NUMBER OF PAGES
	ANDI TT,PAGMSK
	TLNE TT,-1
	 JRST LDXERR
	PUSH FXP,TT
	MOVE D,(FXP)		;GET ESTIMATED NUMBER OF LINKS
	MOVEM D,LDXSIZ		;SAVE AS SIZE OF XCT AREA
	MOVEM D,LDXSM1		;ALSO NEED THAT VALUE MINUS 1
	SOS LDXSM1
	MOVE TT,@VBPORG		;CREATE TWO AREAS IN BPS THAT BIG:
	HRRZ T,TT		; THE FIRST FOR THE XCTS TO POINT TO,
	ADD TT,D		; THE SECOND TO RESTORE THE FIRST FROM
	HRL T,TT
	MOVE R,(P)
	TLNE R,1
	 HRL T,HBPORG
	MOVEM T,LDXBLT		;SAVE BLT POINTER FOR RESTORING
	TLNN R,1		;USING HISEG, DON'T TAKE SECOND AREA FROM LOSEG
	 ADD TT,D		;ADD IN FOR SECOND AREA
	JSP T,FXCONS		;NEW VALUE FOR BPORG
	PUSH P,A
	TLNN R,1
	 LSH D,1
	MOVE TT,D
	PUSHJ P,LGTSPC		;NOW TRY TO GET REQUIRED CORE
	JUMPE TT,FASLNX
	MOVE R,-1(P)
	TLNN R,1
	 JRST LDXHK3
	MOVE D,(FXP)		;GOBBLE SECOND AREA OUT OF HISEG
	ADD D,HBPORG
	TLNN D,-1
	 JRST LDXHK2
LDXHK1:	SETZM LDXSIZ		;HAVEN'T REALLY WON AFTER ALL
	JRST FASLNX

LDXHK2:	MOVEM D,HBPORG
	SUBI D,1
	CAMG D,HBPEND		;MAY NEED TO EXTEND HISEG
	 JRST LDXHK3
	MOVEM D,HBPEND
SA%	HRLZI D,(D)
SA%	CORE D,
SA$	CORE2 D,
	 JRST LDXHK1
LDXHK3:	POP P,VBPORG		;GIVE BPORG NEW VALUE
	MOVE T,LDXBLT		;ZERO OUT BOTH AREAS
	MOVE TT,@VBPORG
	HRL T,T
	SETZM (T)
	ADDI T,1
	BLT T,-1(TT)
	TLNN R,1
	 JRST LDXHK5
	MOVS T,LDXBLT		;WHEN USING HISEG, NEED AN EXTRA
	MOVE TT,HBPORG		; BLT TO ZERO OUT SECOND AREA
	BLT T,-1(TT)
LDXHK5:	HRRZ T,LDXBLT		;SET UP LDXDIF WITH THE DIFFERENCE
	HLRZ TT,LDXBLT		; BETWEEN THE ORIGINS OF AREA 1 AND
	SUB T,TT	.SEE LDPRC6
	HRRM T,LDXDIF		; AREA 2 TO MAKE INSTALLING ENTRIES EASIER
	POPI FXP,1
	JRST TRUE
]		;END IFE PAGING

SUBTTL PAGING, VARIABLE NUMBER OF XCT PAGES, DYNAMICALLY ALLOCATED
IFN PAGING,[
LDXHAK:	PUSH FXP,AR1		;AR1 MUST BE PRESERVED, AT ALL COSTS!
	LOCKI			;INTERRUPTS MUST BE OFF OVER CALL TO GRBSEG
	PUSHJ P,GRBSEG		;GET ONE SEGMENT OF TYPE RANDOM
	 JRST LDXIRL		;RELEASE INTERRUPTS AND GIVE NON-SKIP RETURN
	UNLOCKI
	PUSHJ P,GRBPSG		;GET ONE PURE SEGMENT INTO AC T
	POP FXP,AR1
	LSH T,SEGLOG		;MAKE PURE SEGMENT INTO ADDRESS
	HRRZM T,LDXPSP(TT)	;REMEMBER PURE SEGMENT ADDRESS
	HRLI T,(T)		;BUILD A BLT POINTER TO ZERO PURE PAGE
	HRRZI D,SEGSIZ-1(T)	;LAST LOC TO ZERO
	SETZM (T)		;ZERO FIRST LOC
	ADDI T,1
	BLT T,(D)		;AND ALL THE REST
	HRLZI T,LDXOFS(TT)	;BUILD BLT POINTER TO CLEAR NEW IMPURE SEG
	HRRI T,LDXOFS+1(TT)
	SETZM LDXOFS(TT)
	BLT T,SEGSIZ-1(TT)	;CLEAR THE WHOLE SEGMENT
	MOVNI T,LDHSH1+1	;NUMBER OF ENTRIES IN TABLE
	IMULI T,LDX%FU		;MAKE INTO NEGATIVE PERCENTAGE
	PUSH FXP,TT
	IDIVI T,100.
	POP FXP,TT
	MOVEM T,LDXLPC		;AND THE COUNT
	MOVE T,LDXLPL		;REMEMBER LOC OF LAST PAGE USED
	MOVEM TT,LDXLPL		;SAVE THIS PAGE LOCATION
	JUMPE T,LDXFLC		;STORE IN POINTER LOC IF NO PREVIOUS SEGMENTS
	HRLM TT,(T)		;LINK INTO LIST
	AOS (P)
	POPJ P,
LDXFLC:	MOVEM TT,LDXPNT
	AOS (P)
	POPJ P,
LDXIRL:	UNLOCKI
	POP FXP,AR1
	POPJ P,
]	;END IFN PAGING

SUBTTL	MAIN FASLOAD LOOP

;;; FROM THIS POINT ON, UNTIL A FATAL ERROR OCCURS OR LOCATION LDFEND IS REACHED,
;;; THESE ACCUMULATORS ARE DEDICATED TO THE FOLLOWING PURPOSES:
;;;	AR1	BYTE POINTER FOR GETTING SUCCESSIVE RELOCATION TYPES
;;;	R	AOBJN POINTER FOR PUTTING WORDS INTO BINARY PROGRAM SPACE
;;;	F	AOBJN INDEX FOR ACCESSING WORDS FROM INPUT BUFFER ARRAY

LDREL:	HRRI TT,@LDOFST		;[RELOCATABLE WORD]
LDABS:	MOVEM TT,(R)		;[ABSOLUTE WORD]
LDABS1:	AOBJN R,LDBIN		;JUMP IF ROOM LEFT OF WHAT WE GRABBED
LDABS0:
10$	MOVE TT,LDPRLS(P)	;FOR D10, MUST PASS LDPRLS IN TT TO LDGTSP
	PUSHJ P,LDGTSP
	PUSHJ P,LDRSPT
LDBIN:	SKIPE INTFLG		;[LOAD BINARY WORD (OR SOME OTHER MESS)]
	 PUSHJ P,LDTRYI		;GIVE A POOR INTERRUPT A CHANCE IN LIFE
	TLNN AR1,770000
	 JRST LDBIN2		;OUT OF RELOCATION BYTES - MUST GET MORE
LDBIN1:	JSP T,LDGTWD		;GET WORD FROM INPUT FILE
	ILDB T,AR1		;GET CORRESPONDING RELOCATION BYTE
	JSP D,@LDTTBL(T)	; - IT TELLS US WHERE TO GO

LDBIN2:	JSP T,LDGTWD		;GET WORD OF RELOCATION BYTES
	MOVEM TT,LDBYTS
	SOJA AR1,LDBIN1		;INIT BYTE POINTER AND GO GET DATA WORD

LDTTBL:	LDABS		;  0  ABSOLUTE
	LDREL		;  1  RELOCATABLE
	LDSPC		;  2  SPECIAL
	LDPRC		;  3  PURIFIABLE CALL
	LDQAT		;  4  QUOTED ATOM
	LDQLS		;  5  QUOTED LIST
	LDGLB		;  6  GLOBALSYM PATCH
	LDGET		;  7  GET DDT SYMBOL PATCH
	LDAREF		; 10  ARRAY REFERENCE
	LDFERR		; 11  UNUSED
	LDATM		; 12  ATOMTABLE ENTRY
	LDENT		; 13  ENTRY POINT INFO
	LDLOC		; 14  LOC TO ANOTHER PLACE
	LDPUT		; 15  PUT DDT SYMBOL
	LDEVAL		; 16  EVALUATE MUNGEABLE
	LDBEND		; 17  END OF BINARY

;;; LOADER GET SPACE ROUTINE.  PUTS SOME DISTANCE BETWEEN BPORG AND BPEND.
;;; R MUST BE SET UP ALREADY.  FOR D10, TT MUST HAVE LDPRLS.
;;; THE LEFT HALF OF R IS ADJECTED TO REFLECT THE SPACE OBTAINED.

LDGTSP:
HS$ 10$	TLNE TT,100000		;CHECK IF LOADING INTO HISEG
HS$ 10$	 JRST LDGSP3		;IF SO, EXPAND THAT
	MOVE TT,@VBPEND		;SEE IF ENOUGH ROOM LEFT TO GRAB MORE
	SUB TT,@VBPORG
	SUBI TT,100		;RANDOMLY CHOSEN QUANTITY
	JUMPGE TT,LDGSP1	;YES - GO GRAB IT
	SOVEFX AR1 D R F
	MOVEI TT,4*PAGSIZ	;GET MANY BLOCKS OF BPS
LDGS0A:	MOVEM TT,GAMNT
	PUSHJ P,GTSPC1
	JUMPN TT,LDGS0H
	MOVE TT,GAMNT
	CAIG TT,100
	 JRST FASLNC
	MOVEI TT,100
	JRST LDGS0A

LDGS0H:	RSTRFX F R D AR1
LDGSP1:	MOVEI TT,(R)
	ADDI TT,PAGSIZ		;TRY TO GOBBLE <PAGSIZ>
	CAMLE TT,@VBPEND	; WORDS, BUT IN ANY CASE
	 MOVE TT,@VBPEND	; NO MORE THAN BEYOND BPEND
	JSP T,FIX1A
	MOVEM A,VBPORG
	MOVEI TT,(R)
	SUB TT,@VBPORG
	HRLI R,(TT)		;INIT AOBJN POINTER IN R
	POPJ P,

IFE PAGING+<1-D10>,[
LDGSP3:	MOVE TT,HBPEND
	SUBI TT,(R)		;DO NOT MERGE THIS WITH FOLLOWING SUBI! MAYBE R>777700
	SUBI TT,100		;RANDOMLY CHOSEN QUANTITY
	JUMPGE TT,LDGSP6
	MOVE TT,HBPEND
	ADDI TT,4*PAGSIZ
	TLNE TT,-1
	 MOVSI TT,(MEMORY)
	ADDI TT,PAGSIZ-1
	ANDCMI TT,#PAGMSK	;*NOT* SAME AS  ANDI TT,PAGMSK  !!!
	MOVE T,TT
	SUBI T,1
	CAMG T,HBPEND
	 JRST LDGSP4
SA%	HRLZI T,(T)
SA%	CORE T,
SA$	CORE2 T,
	 JRST FASLNC
	MOVE AR2A,[$XM+PUR,,QRANDOM]
	AOS B,HBPEND
	MOVEI C,(B)
	SUBI C,(TT)
	LSHC B,-SEGLOG
	HRLI B,(C)
LDGSP5:	MOVEM AR2A,ST(B)
	SETZM GCST(B)
	AOBJN B,LDGSP5
LDGSP4:	MOVEM TT,HBPEND
	SOS HBPEND
LDGSP6:	MOVE TT,HBPEND
	MOVEM TT,HBPORG
	SUBM R,TT
	HRLI R,(TT)
	POPJ P,
]		;END OF IFE IFE PAGING+<1-D10>

SUBTTL	SPECIAL VALUE CELL AND QUOTED ATOM REFERENCES

LDSPC:	MOVE T,TT		;[SPECIAL]
	HLR TT,@LDAPTR		;GET ADDRESS OF SPECIAL CELL
	TRNE TT,777000		;WAS SUCH AN ADDRESS REALLY THERE?
	 JRST LDABS		;YES, WIN
	TRNE TT,6		;NO, IF THIS ATOM ISN'T A SYMBOL
	 JSP D,LDFERR		; THEN LOSE!!!
	HRRZ TT,T		;IS THERE AN ATOM THERE AT ALL
	HRRZ A,@LDAPTR
	SKIPN D,A
	 JSP D,LDFERR		;NO, LOSE
	HLRZ B,(A)
	HRRZ A,(B)
	CAIE A,SUNBOUND
	 JRST LDSPC1
	PUSH P,D		;NONE THERE - MUST MAKE ONE
	MOVEI B,QUNBOUND
	JSP TT,MAKVC		;RETURN SY2 POINTER IN B
LDSPC1:	HLRZ TT,(B)		;GET SYMBOL FLAG BITS
	TRO TT,SY.CCN\SY.OTC	;NEEDED-BY-COMPILED-CODE, OTHER THAN CALL
	TRNN TT,SY.PUR		;WAS VALUE CELL PURE?
	 HRLM TT,(B)		;NO, THEN MUST PROTECT VALUE CELL
	MOVE TT,T		;SAVE ADDRESS OF VALUE CELL
	HRLM A,@LDAPTR		; IN ATOMTABLE
	HRR TT,A		;AT LAST WE WIN
	JRST LDABS

LDQAT:	MOVE D,@LDAPTR		;[QUOTED ATOM]
	TRNE D,-1		;DON'T HACK ANYTHING FOR NIL
	 TLNE D,777000		;EXIT IF SPECIAL, OR SYM BLK ALREADY HACKED
	  JRST LDQATX
	TLON D,1		;ELSE TURN ON REFERENCE BIT
	 MOVEM D,@LDAPTR
	TLNE D,6		;IF NON-SYMBOL, THEN MAYBE GCPROTECT IT
	 JRST LDQAT1
	HLRZ T,(D)		;IF SYMBOL, THEN MAYBE SET ITS "CCN" BITS
	HLL T,(T)		;FETCH SYMBOL BITS
	TLO T,SY.CCN\SY.OTC	;FLAG SYMBOL AS NEEDED FOR OTHER THAN CALL
	TLNN T,SY.PUR		;DON'T TRY TO WRITE IF PURE
	 HLLM T,(T)
LDQATX:	HRRI TT,(D)
	JRST LDABS

LDQAT1:	TLOE D,10		;IF NON-SYMBOL, AND IF NOT YET GC PROTECTED
	 JRST LDQATX
	MOVEI A,(D)
	CAIGE A,IN0+XHINUM
	 CAIGE A,IN0-XLONUM
	  CAIA
	   JRST LDQAT2
	PUSHJ P,SAVX3
	PUSH P,AR1
	PUSHJ P,%GCPRO
	PUSHJ P,LDRSPT
	POP P,AR1
	PUSHJ P,RSTX3
	HRRI D,(A)
LDQAT2:	MOVEM D,@LDAPTR
	JRST LDQATX



SUBTTL	QUOTED LIST REFERENCES

LDQLS:	MOVSI D,11		;[QUOTED LIST]
	SKIPL LDPRLS(P)		;CAN'T COUNT ON ANYTHING IN PURE
	 MOVSI D,1		; FREE STORAGE PROTECTING ANYTHING
	PUSHJ P,LDLIST		;GOBBLE UP A LIST
	MOVEM TT,(R)		;PUT WORD IN BPS
	JSP T,LDGTWD		;GET HASH KEY FOR LIST
	TLZ A,-1
	SKIPE VGCPRO
	 JRST LDQLS4
	PUSH FXP,D
	PUSH FXP,AR1
	TLZ A,-1
	SKIPE D,TT
	 JRST LDQLS3
	PUSH P,A
	PUSH FXP,R		   ;SXHSH0 can call user code!
	PUSH FXP,F		   ;So we had better save all our state
	PUSH FXP,AR1		   ;From the ferocious user code!
	PUSHJ P,SXHSH0
	POP FXP,AR1
	POP FXP,F
	POP FXP,R
	POP P,A
LDQLS3:	SKIPN V.PURE		;SKIP FOR PURE HACKERY
	 JRST LDQLS1
	PUSH FXP,D		;SAVE HASH KEY
	PUSH P,A		;SAVE LIST
	MOVNI T,1		;THIS MEANS JUST LOOKUP
	PUSHJ P,LDGPRO
	POP P,B
	POP FXP,D
	JUMPN A,LDQLS2		;ON GCPRO LIST, SO USE IT
	MOVE A,B
	PUSHJ P,PURCOPY		;NOT ON GCPRO LIST, SO PURCOPY IT
LDQLS1:	MOVEI T,1		;THIS MEANS PROTECT OR HAND BACK COPY
	PUSHJ P,LDGPRO		;PROTECT LIST FROM FEROCIOUS GC!
LDQLS2:	POP FXP,AR1
	POP FXP,D
LDQLS5:	JUMPE D,LDEVL7		;MAYBE THIS LIST GOES INTO ATOMTABLE
	HRRM A,(R)		;SAVE ADDRESS OF LIST (WHICH MAY
	JRST LDABS1		; BE DIFFERENT NOW) BACK INTO WORD

LDQLS4:	JSP T,LDQLPRO
	JRST LDQLS5

LDQLPRO:
	CAIL A,IN0-XLONUM	;JUST EXIT IF INUM
	 CAILE A,IN0+XHINUM-1
	  JRST .+2
	   JRST (T)
	HRRZ B,LDEVPRO
	JUMPE B,LDQPR1
LDQPR0:	HLRZ TT,(B)
	CAIN A,(TT)
	 JRST (T)		;JUST EXIT IF ALREADY THERE
	HRRZ B,(B)
	JUMPN B,LDQPR0
LDQPR1:	HRRZ B,LDEVPRO		;GC-PROTECT HAPPENS BY PUSHING ONTO A LIST
	PUSHJ P,CONS
	MOVEM A,LDEVPRO
	JRST %CAR

LDGPRO:	SKIPE GCPSAR		;PROTECT SOMETHING ON THE GCPSAR
	 JRST .GCPRO
	PUSHJ P,.GCPRO		;THE LOOKUP CAUSES THE CREATION OF A NEW ARRAY
	JRST LDRSPT		;SO WE HAVE TO RESTORE PTRS AFTERWARDS


SUBTTL	PURIFIABLE CALL

LDPRC:	MOVE D,@LDAPTR		;[PURIFIABLE CALL]
	TRNN D,-1		;MUST HAVE NON-NIL ATOM TO CALL
	 JSP D,LDFERR
	TLNE D,777000
	 JRST LDPRC1		;JUMP IF ATOM HAS SPECIAL CELL
	TLNE D,6
	 JSP D,LDFERR		;LOSE IF NUMBER
	TLO D,1			;ELSE TURN ON REFERENCE BIT
	MOVEM D,@LDAPTR
	HLRZ T,(D)		;FETCH SY2 DATA
	HLL T,(T)
	TLO T,SY.CCN		;ONLY CCN, NOT OTC!!
	TLNN T,SY.PUR		;ONLY IF IMPURE
	 HLLM T,(T)
LDPRC1:	HRR TT,D		;PUT ADDRESS OF ATOM IN CALL
	SKIPGE T,LDPRLS(P)	;SKIP FOR PURIFYING HACKERY
	 JRST LDABS		;OTHERWISE WE'RE DONE
	TLNN T,200000		;SKIP FOR XCT STUFF
	 SETZ T,		;ELSE DO ORDINARY SMASH
	PUSHJ P,PRCHAK		;*** SMASH! ***
	 JRST LDABS1
	MOVEI A,(R)		;NOT SMASHED - CONS ONTO PURE LIST
	MOVE B,LDPRLS(P)
	PUSHJ P,CONS
	MOVEM A,LDPRLS(P)
	JRST LDABS1

;;; ROUTINE TO CLOBBER A CALL INTO BPS, POSSIBLY DOING XCT HACK.
;;;	SKIPS ON *** FAILURE *** TO CLOBBER.
;;;	T NON-ZERO => TRY XCT HACK; OTHERWISE ORDINARY SMASH.
;;;	TT HAS UUO INSTRUCTION TO HACK.
;;;	R HAS ADDRESS TO PUT UUO INTO.
;;;	MUST PRESERVE AR1, R, F.
IFE PAGING,[
;VERSION FOR NON-PAGING ONLY, NEWER VERSION SUPPORTS EXTENDABLE NUMBER OF SEGMENTS
PRCHAK:	JUMPE T,LDPRC5		;T ZERO => ORDINARY SMASH
	MOVE T,TT		;SAVE CALL IN T
	IDIV TT,LDXSM1		;COMPUTE HASH CODE FOR CALL
	MOVNM D,LDTEMP		;SAVE NEGATIVE THEREOF
	HLRZ TT,LDXBLT
	ADD D,TT		;ADDRESS TO BEGIN SEARCH
	CAMN T,(D)		;WE MAY WIN IMMEDIATELY
	 JRST LDPRC7
	SKIPN (D)
	 JRST LDPRC6
	ADD TT,LDXSM1		;ELSE MAKE UP AN AOBJN POINTER
	SUBI TT,-1(D)		; AND SEARCH FOR MATCHING CALL
	MOVNI TT,(TT)
	HRL D,TT
LDPRC2:	CAMN T,(D)
	 JRST LDPRC7		;FOUND MATCHING CALL
	SKIPN (D)
	 JRST LDPRC6		;FOUND EMPTY SLOT
	AOBJN D,LDPRC2
	HRLZ D,LDTEMP		;WRAPPED OFF THE END OF THE XCT AREA
	HLR D,LDXBLT		; - MAKE UP NEW AOBJN POINTER
LDPRC3:	CAMN T,(D)		;SECOND COPY OF THE LOOP
	 JRST LDPRC7		;FOUND MATCHING CALL
	SKIPN (D)
	 JRST LDPRC6		;FOUND EMPTY SLOT
	AOBJN D,LDPRC3
LDPRC4:	MOVE TT,T		;TOTAL LOSS - MUST DO SMASH
LDPRC5:	HRRZ AR2A,R		;PUT ADDRESS OF CALL IN AR2A
	MOVEM TT,(AR2A)		;PUT CALL IN THAT PLACE
	JRST LDSMSH		;NOW TRY TO SMASH IT, EXITING WITH SKIP ON FAILURE

LDPRC6:	SKIPG LDXSIZ		;FOUND EMPTY SLOT
	 JRST LDPRC4		;CAN'T USE IT IF PAGES PURIFIED
	MOVEM T,(D)		;SAVE CALL INTO XCT AREA 2
	MOVEM T,@LDXDIF		;ALSO SAVE INTO AREA 1
LDPRC7:	ADD D,LDXDIF		;MAKE UP AN XCT TO POINT TO
	HRLI D,(XCT)		; CALL IN AREA 1
	MOVEM D,(R)
	POPJ P,
]		;END IFE PAGING

IFN PAGING,[
;NEW STYLE SEARCH FOR PROPER LINK LOCATION; ADDS A NEW UUOLINKS SEGMENT IF
; OUT OF SPACE OR IF PARTIALLY EMPTY UUOLINK SEGMENT HAS BEEN PURIFIED
PRCHAK:	JUMPN T,PRCHA1		;DON'T SMASH IMMEDIATLY IF T NON-ZERO
PRCSMS:	HRRZ AR2A,R		;PUT ADDRESS OF CALL IN AR2A
	MOVEM TT,(AR2A)		;PUT CALL IN THAT PLACE
	JRST LDSMSH		;TRY TO SMASH IT, EXITING WITH SKIP ON FAILURE
PRCHA1:	PUSH FXP,R		;NEED D/R PAIR OF ACS
	MOVE D,TT		;GET COPY OF THE CALL
	IDIVI D,LDHSH1		;COMPUTE FIRST HASH VALUE
	MOVEM R,LDXHS1
	MOVE D,TT		;THEN THE SECOND HASH VALUE
	IDIVI D,LDHSH2
	AOS R			;IT BEING ZERO COULD BE A DISASTER
	MOVEM R,LDXHS2
	SKIPN T,LDXPNT		;GET POINTER
	 JRST PRCH2A		;FIRST TIME THROUGH ALWAYS ADD NEW SEGMENT
PRCH1A:	HRRZ D,LDXPSP(T)	;GET POINTER TO PURE PAGE
	MOVEI R,LDXOFS(D)	;POINTER TO FIRST WORD OF DATA
	ADDI D,SEGSIZ-1		;THIS IS THE LAST WORD IN THE SEGMENT
	ADD R,LDXHS1		;START FROM THE FIRST HASH VALUE
PRCH1B:	CAMN TT,(R)		;MATCH?
	 JRST PRCHA3		;YUP, SO USE THIS SLOT
	SKIPN (R)		;END OF CHAIN?
	 JRST PRCHA4		;YES, ON TO NEXT SEGMENT
	ADD R,LDXHS2		;STEP BY HASH VALUE
	CAILE R,(D)		;MUST NOT RUN OFF END OF SEGMENT
	 SUBI R,LDHSH1		;SO TAKE IT MOD LDHSH1
	JRST PRCH1B		;AND TRY THIS SLOT
PRCHA4:	HLRZ D,LDXPSP(T)	;GET POINTER TO NEXT SEGMENT
	JUMPE D,PRCHA2
	MOVEI T,(D)
	JRST PRCH1A
PRCHA3:	HRRZ D,LDXPSP(T)	;SUBTRACTING THIS WILL GIVE ABSOLUTE SEG OFFSET
	SUBM R,D
	ADDI D,(T)		;THEN PRODUCE POINTER TO FROB TO XCT
	POP FXP,R		;RESTORE POINTER TO CODE
	HRLI D,(XCT)
	MOVEM D,(R)		;THEN STORE THE NEW INSTRUCTION
	POPJ P,

;GET HERE WITH C(R) POINTING TO SLOT TO ADD NEW ENTRY TO IN PURE TABLE, DUE TO
; THE DESIGN OF THE MECHANISM, IN THE CASES THAT R IS INVALID, A NEW UUO PAGE
; WILL HAVE TO BE ADDED AND R WILL NOT BE USED.  IF THAT IS CHANGED, THIS
; ROUTINE MUST BE FIXED
PRCHA2:	AOSLE LDXLPC		;IF THIS SEGMENT IS FULL
	 JRST PRCH2A		; ADD A NEW ONE
	MOVEM TT,(R)		;STORE THE CALL IN THE POTENTIALLY PURE SEGMENT
	HRRZ D,LDXPSP(T)	;THEN BUILD POINTER TO IMPURE SEGMENT
	SUBM R,D
	ADDI D,(T)		;D CONTAINS ADR IN IMPURE SEGMENT
	MOVEM TT,(D)		;STORE THE CALL INSTRUCTION THERE
	POP FXP,R		;GET ADR OF ACTUAL CODE
	HRLI D,(XCT)		;THEN INSTRUCTION TO PLANT THERE
	MOVEM D,(R)
	POPJ P,
PRCH2A:	PUSH FXP,TT		;SAVE TT OVER SEGMENT GRAB
	PUSHJ P,LDXHAK		;ADD A NEW SEGMENT
	 LERR [SIXBIT \CANNOT ADD NEW UUOLINKS SEGMENT - FASLOAD!\]
	POP FXP,TT
	MOVE T,LDXLPL		;GET POINTER TO THE PAGE JUST ADDED
	MOVEI D,LDXOFS(T)	;FIRST DATA ADR
	ADD D,LDXHS1		;ADR TO INSTALL CALL INTO
	MOVEM TT,(D)		;STORE THE CALL TO BE POTENTIALLY SMASHED
	HRLI D,(XCT)		;THE XCT INSTRUCTION
	POP FXP,R
	MOVEM D,(R)		;PLANT IN CODE
	HRRZ D,LDXPSP(T)	;PURE SEGMENT POINTER
	ADD D,LDXHS1
	ADDI D,LDXOFS
	MOVEM TT,(D)		;PLANT CALL IN POTENTIALLY PURE SEGMENT
	POPJ P,

;HERE TO TRY TO SMASH CALL IN IMPURE SEGMENT.  CALLED ONLY IF FLAG IS SET.
; POINTER TO WORD IN THE SEGMENT IS IN D.  DESTROYS A, B, C, T
PRTRTS:	HRRZ AR2A,D		;PUT ADDRESS OF CALL IN AR2A
	PUSH FXP,D		;SAVE VALUABLE AC'S
	PUSH FXP,TT
	PUSH FXP,T
	PUSHJ P,LDSMSH		;TRY TO SMASH THE CALL
	 JFCL			;WE DON'T REALLY CARE IF IT WINS OR NOT
	POP FXP,T
	POP FXP,TT
	POP FXP,D
	POPJ P,
]		;END IFN PAGING

;;; SMASH A CALL-TYPE UUO IN MEMORY TO BE A PUSHJ OR JRST OR WHATEVER.
;;; AR2A HAS THE LOCATION OF THE CALL.
;;; RETURN SKIPS IF IT CAN'T BE SMASHED.
;;; DESTROYS A, B, C, T, TT, D; SAVES AR1, AR2A, R, F.
;;; MUST NOT USER ANY PDL EXCEPT THE REGPDL (P).
.SEE PURIFY

LDSMSH:	MOVE T,(AR2A)
	LSH T,-33		;T GETS THE CALL UUO OPCODE
	CAIL T,CALL_-33
	 CAILE T,CALL_-33+NUUOCLS
	  POPJ P,		;RETURN IF NOT REALLY A CALL
	HRRZ A,(AR2A)
	MOVEI B,SBRL
	PUSHJ P,GETLA		;TRY TO GET SUBR, FSUBR, OR LSUBR PROP
	LDB D,[270400,,(AR2A)]
	JUMPE A,LDSMNS		;JUMP IF NOT ANY OF THOSE
	HLRZ B,(A)
	HRRZ T,(AR2A)
	HLRZ T,(T)
	HLRZ T,1(T)		;GET ARGS PROPERTY FOR FUNCTION NAME
	SOJL T,LDZA2		;JUMP IF THERE ISN'T ANY
	CAIG T,NACS		;ARGS PROPERTY IS SCREWY IF THIS SKIPS!
	 TLOA T,(CAIE D,)	;IF ARGS PROP OK, TEST FOR THAT EXACT NUMBER OF ARGS IN UUO
LDZA2:	  MOVE T,[CAILE D,NACS]	;IF NO OR BAD ARGS PROP, JUST CHECK FOR RANGE
	CAIN B,QFSUBR
	 MOVE T,[CAIE D,17]
	CAIN B,QLSUBR
	 MOVE T,[CAIE D,16]
	XCT T			;AC FIELD OF CALL IS 0-5 FOR SUBRS, 16 LSUBR, 17 FSUBR
	 JRST POPJ1		;SKIP RETURN IF CALL DOESN'T MATCH FUNCTION TYPE OR # ARGS
	HRRZ A,(A)		;ELSE WIN - SMASH THE CALL
	HLRZ A,(A)		;SUBR ADDRESS NOW IN A
	SKIPA TT,(AR2A)
LDZAOK:	 HRLI A,(@)		.SEE ASAR
	MOVSI T,(PUSHJ P,)	;CALL BECOMES PUSHJ
	TLNE TT,20000
	 ADDI A,1		;HACK NCALLS CORRECTLY - ENTER AT ROUTINE+1
	TLNE TT,1000
	 MOVSI T,(JRST)		;JCALL BECOMES JRST
LDZA1:	IOR T,A
	MOVEM T,(AR2A)		;***SMASH!***
	POPJ P,

LDSMNS:	HRRZ A,(AR2A)		;TRY TO GET ARRAY PROPERTY
	MOVEI B,QARRAY
	PUSHJ P,$GET
	MOVEI T,(A)
	LSH T,-SEGLOG
	MOVE T,ST(T)
	TLNN T,SA
	 JRST POPJ1		;LOSE IF NOT SAR
	LDB T,[TTSDIM,,TTSAR(A)]
	CAIE T,(D)		;MUST HAVE CORRECT NUMBER OF ARGS
	 JRST POP1J
	MOVSI T,TTS<CN>
	IORM T,TTSAR(A)		;SET "COMPILED-CODE-NEEDS-ME" BIT IN SAR
	MOVE TT,(AR2A)
	TLNN TT,20000
	 JRST LDZAOK
	MOVSI T,(ACALL)		;FOR AN NCALL-TYPE UUO, SMASH IT TO
	TLNE TT,1000		; BE A CROCKISH ACALL OR AJCALL
	 MOVSI T,(AJCALL)
	JRST LDZA1


SUBTTL	GETDDTSYM HACKERY

LDGET:	CAMN TT,XC-1
	 JRST LDLHRL
	MOVE D,TT		;[GET DDT SYMBOL PATCH]
	TLNN D,200000		;MAYBE THE ASSEMBLER LEFT US A VALUE?
	 JRST LDGET2
	JSP T,LDGTWD		;FETCH IT THEN
	SKIPE LDF2DP
	 JRST LDGET2		;CAN'T USE IT IF VERSIONS DIFFER
LDGET1:	TLNE D,400000		;MAYBE NEGATE SYMBOL?
	 MOVNS TT
	LDB D,[400200,,D]	;GET FIELD NUMBER
	XCT LDXCT(D)		;HASH UP VALUE FOR FIELD
	MOVE T,LDMASK(D)	;ADD INTO FIELD
	ADD TT,-1(R)		; MASKED APPROPRIATELY
	AND TT,T
	ANDCAM T,-1(R)
	IORM TT,-1(R)
	JRST LDBIN

LDGET2:	UNLOCKI			;UNLOCK INTERRUPTS
	PUSH FXP,.		;RANDOM FXP SLOT
	PUSH FXP,AR1		;SAVE UP ACS
	PUSH FXP,D
	PUSH FXP,R
	PUSH FXP,F
	MOVEI R,0
	TLZ D,740000
REPEAT LOG2LL5,[
	CAML D,LAPFIV+<1_<LOG2LL5-.RPCNT-1>>(R)
	 ADDI R,1_<LOG2LL5-.RPCNT-1>
]		;END OF REPEAT LOG2LL5
	CAME D,LAPFIV(R)	;IF DDTSYM REQUEST IS FOR A GLOBAL SYM
	 JRST LDGT5A		;THEN FIND IT IN THE LAPFIV TABLE, AND GET ITS 
	LSHC R,-2		;GLOBALSYM INDEX FROM THE PERMUTATION TABLE
	LSH F,-42
	LDB TT,LDGET6(F)
	MOVE TT,LSYMS(TT)
	JRST LDGT5B
LDGT5A:	MOVEI TT,R70
	CAMN D,[SQUOZE 0,R70]
	 JRST LDGT5B
	PUSHJ P,UNSQOZ		;CONVERT SQUOZE TO A LISP SYMBOL
	MOVEI C,(A)
	MOVEI B,QSYM		;TRY TO FIND SYM PROPERTY
	PUSHJ P,$GET
	JUMPN A,LDGETJ		;WIN
IFN ITS,[
	JSP T,SIDDTP		;MAYBE WE CAN GET VALUE FROM DDT?
	 JRST LDGETX
	LDB T,[004000,,-2(FXP)]
	.BREAK 12,[..RSYM,,T]
	JUMPE T,LDGETX		;LOSE, LOSE, LOSE
]		;END OF IFN ITS
IFN D10,[
	SKIPN .JBSYM"
	 JRST LDGETX
	LDB D,[004000,,-2(FXP)]
LDGET4:	MOVE TT,D
	IDIVI D,50
	JUMPE R,LDGET4
	PUSHJ P,GETDDJ
	JRST LDGETX
]		;END OF IFN D10
LDGT5B:	MOVEM TT,-4(FXP)	;WIN, WIN - USE RANDOM FXP SLOT
	MOVEI A,-4(FXP)		; TO FAKE UP A FIXNUM
	JRST LDGETJ

LDGETX:	MOVEI A,(C)
	PUSHJ P,NCONS
	MOVEI B,QGETDDTSYM	;DO A FAIL-ACT
	PUSHJ P,XCONS
	PUSHJ P,LDGETQ
LDGETJ:	POP FXP,F		;RESTORE ACS
	POP FXP,R
	POP FXP,D
	POP FXP,AR1
	PUSHJ P,LDLRSP		;LOCKI AND RESTORE ARRAY POINTERS
	MOVE TT,(A)
	PUSHJ P,TYPEP		;FIGURE OUT WHAT WE GOT BACK
	POP FXP,-1(FXP)		;POP RANDOM SLOT (REMEMBER THE LOCKI!)
	CAIN A,QFIXNUM
	JRST LDGET1
LDGETV:	CAIN A,QFLONUM		;USE A FLONUM IF WE GET ONE
	JRST LDGET1
LDGETW:	PUSHJ P,LDGDDT		;FOR ANYTHING ELSE TRY DDT AGAIN
	MOVEM TT,LDDDTP(P)
	JRST LDGET2


LDGET6: REPEAT 4,[<11_24.>+<<<3-.RPCNT>*11>_30.> LAP5P(R)
]

IFN ITS,[
LDGDDT:	JSP T,SIDDTP
	 JRST ZPOPJ		;0 => TOP LEVEL, OR NOT INFERIOR TO DDT
	.BREAK 12,[..RSTP,,TT]	;-1,,0 => INFERIOR TO DDT, BUT NO SYMBOL TABLE
	SKIPN TT		;1,,0 => INFERIOR TO DDT WITH SYMBOL TABLE
	 TLOA TT,-1
	  MOVSI TT,1
	POPJ P,
]		;END OF IFN ITS

IFN D20,[
LDGDDT==:ZPOPJ			;FOR NOW, NEVER A DDT
]		;END IFN D20


IFN D10,[
LDGDDT:	SKIPE TT,.JBSYM"
	 MOVSI TT,1
	POPJ P,
]		;END OF IFN D10

LDXCT:	MOVSS TT	;INDEX FIELD
	HRRZS TT	;ADDRESS FIELD
	LSH TT,23.	;AC FIELD
	JFCL		;OPCODE FIELD

LDMASK:	-1		;INDEX FIELD
	0,,-1		;ADDRESS FIELD
	0 17,		;AC FIELD
	-1		;OPCODE FIELD

LDLHRL:	HRLZ TT,LDOFST
	ADDM TT,-1(R)
	JRST LDBIN

SUBTTL	ARRAY, GLOBALSYM, AND ATOMTABLE ENTRY STUFF

LDAREF:	PUSH FXP,TT		;[ARRAY REFERENCE]
	MOVE D,@LDAPTR
	TLNN D,777001
	 TLO D,11
	MOVEM D,@LDAPTR
	TRNN D,-1
	 JRST LDARE1		;SKIP IF HACKING 'NIL'
	TLNE D,777000		;IF NO VC THEN MUST HACK SYMBOL
	 JRST LDARE1
	HLRZ T,(D)
	HLL T,(T)
	TLO T,SY.CCN\SY.OTC	;COMPILED CODE NEEDS, OTHER THAN CALL REF
	TLNN T,SY.PUR		;CAN'T WRITE IF PURE
	 HLLM T,(T)
LDARE1:	MOVEI A,(D)
	PUSHJ P,TTSR+1		;NCALL TO TTSR
	HLL TT,(FXP)
	SUB FXP,R70+1
	JRST LDABS


LDGLB:	SKIPL TT		;[GLOBALSYM PATCH]
	 SKIPA TT,LSYMS(TT)	;GET VALUE OF GLOBAL SYMBOL
	  MOVN TT,LSYMS(TT)	;OR MAYBE NEGATIVE THEREOF
	ADD TT,-1(R)		;ADD TO ADDRESS FIELD OF
	HRRM TT,-1(R)		; LAST WORD LOADED
	JRST LDBIN

LDATM:	LDB T,[410300,,TT]	;[ATOMTABLE ENTRY]
	JRST LDATBL(T)

LDATBL:	JRST LDATPN		;PNAME
	JRST LDATFX		;FIXNUM
	JRST LDATFL		;FLONUM
BG$	JRST LDATBN		;BIGNUM
BG%	JRST LDATER
DB$	JRST LDATDB		;DOUBLE
DB%	JRST LDATER
CX$	JRST LDATCX		;COMPLEX
CX%	JRST LDATER
DX$	JRST LDATDX		;DUPLEX
DX%	JRST LDATER
	.VALUE			;UNDEFINED

LDATPN:	MOVEI D,(TT)		;[ATOMTABLE PNAME ENTRY]
	PUSH FXP,R
	CAILE D,LPNBUF
	 JRST LDATP2
	MOVEI C,PNBUF-1
LDATP1:	JSP T,LDGTWD
	ADDI C,1
	MOVEM TT,(C)
	SOJG D,LDATP1
	SETOM LPNF
	JRST LDATP4

LDATP2:	PUSH FXP,D
LDATP3:	JSP T,LDGTWD
	JSP T,FWCONS
	PUSH P,A
	SOJG D,LDATP3
	POP FXP,T
	MOVNS T
	PUSHJ FXP,LISTX
	SETZM LPNF
LDATP4:	PUSH FXP,AR1
	PUSHJ P,RINTERN
	POP FXP,AR1
	POP FXP,R
LDATP8:	MOVE TT,LDAAOB
	MOVEM A,@LDAPTR
	AOBJP TT,LDAEXT
	MOVEM TT,LDAAOB
	JRST LDBIN

LDATFX:	JSP T,LDGTWD		;[ATOMTABLE FIXNUM ENTRY]
	PUSH FXP,TT
	MOVEI A,(FXP)
	PUSH P,AR1
	PUSHJ P,GCLOOK
	POP P,AR1
	POP FXP,TT
	SKIPE A
LDATX0:	 TLOA A,10
	  JRST LDATX2
LDATX1:	TLO A,2
	JRST LDATP8

LDATX2:	SKIPE V.PURE
	 JRST LDATX3
	JSP T,FXCONS
	JRST LDATX1
LDATX3:	PUSHJ P,PFXCONS
	JRST LDATX0

LDATFL:	JSP T,LDGTWD		;[ATOMTABLE FLONUM ENTRY]
	PUSH FLP,TT
	MOVEI A,(FLP)
	PUSH P,AR1
	PUSHJ P,GCLOOK
	POP P,AR1
	POP FLP,TT
	SKIPE A
LDATL0:	 TLOA A,10
	  JRST LDATL2
LDATL1:	TLO A,4
	JRST LDATP8

LDATL2:	SKIPE V.PURE
	 JRST LDATL3
	JSP T,FLCONS
	JRST LDATL1
LDATL3:	PUSHJ P,PFLCONS
	JRST LDATL0

IFN BIGNUM,[
LDATBN:	PUSH FXP,TT		;[ATOMTABLE BIGNUM ENTRY]
	MOVEI D,(TT)
	MOVEI B,NIL
LDATB1:	JSP T,LDGTWD
	SKIPE V.PURE
	 JRST LDATB2
	JSP T,FWCONS
	PUSHJ P,CONS
	JRST LDATB3

LDATB2:	PUSHJ P,PFXCONS
	PUSHJ P,PCONS
LDATB3:	MOVE B,A
	SOJG D,LDATB1
	POP FXP,TT
	TLNE TT,1
	 TLO A,-1
	SKIPE V.PURE
	 JRST LDATB6
	PUSH P,AR1
	PUSHJ P,BNCONS
	PUSH P,A		;SAVE NEWLY-CONSTRUCTED BIGNUM
	PUSHJ P,GCLOOK		;SEE IF ONE ALREADY AVAILABLE
	POP P,B		
	POP P,AR1
	JUMPN A,LDATB8
	MOVE A,B
	JRST LDATB7

LDATB6:	PUSHJ P,PBNCONS
LDATB8:	TLO A,10
LDATB7:	TLO A,6
	JRST LDATP8
]		;END OF IFN BIGNUM

LDAEXT:	MOVE T,TT		;[ATOMTABLE EXTEND]
	HRLI T,-ILDAT
	MOVEM T,LDAAOB
	ADDI TT,ILDAT
	ASH TT,1
	UNLOCKI		.SEE ERROR5	;.REARRAY MAY PULL AN ERINT
	PUSH FXP,AR1
	PUSH FXP,R
	PUSH FXP,F
	PUSH P,[LDRFRF]
	PUSH P,LDASAR
	PUSH P,[TRUTH]
	PUSH FXP,TT
	MOVEI A,(FXP)
	PUSH P,A
	MOVNI T,3
	JRST .REARRAY
LDRFRF:	SUB FXP,R70+1		;[RETURN FROM .REARRAY FUNCTION]
	POP FXP,F
	POP FXP,R
	POP FXP,AR1
	PUSHJ P,LDLRSP
	JRST LDBIN

SUBTTL	ENTRY POINT

LDENT:	HRRZ C,@LDAPTR		;[ENTRY POINT INFO]
	MOVSS TT
	HRRZ A,@LDAPTR
	PUSH P,A
	PUSH P,C
	SKIPN B,VFASLOAD
	 JRST LDNRDF
	CAIN B,TRUTH		;IF C(FASLOAD) IS T
	 MOVEI B,SBRL		;THEN USE (SUBR LSUBR FSUBR)
	HRRZ A,(P)		;IS PROPERTY BEING DEFINED ONE OF INTEREST?
	PUSHJ P,MEMQ1
	JUMPE A,LDNRDF		;NOPE, SO PRINT NO MESSAGES
	MOVE B,VFASLOAD
	CAIN B,TRUTH		;IF C(FASLOAD) IS T
	 MOVEI B,SBRL		;THEN USE (SUBR LSUBR FSUBR)
	HRRZ A,-1(P)		;ATOM THAT IS BEING HACKED
	PUSHJ P,GETL		;DID THIS PREVIOUSLY HAVE A PROP OF INTEREST?
	JUMPE A,LDNRDF		;NOPE, NO MESSAGES TO BE PRINTED
	PUSH P,A
	PUSH FXP,AR1
	PUSH FXP,R
	PUSH FXP,F
	MOVEI A,TRUTH
	JSP T,SPECBIND
	   0 A,V%TERPRI
	STRT 17,[SIXBIT \^M;CAUTION#!  !\]
	MOVE A,-2(P)
	PUSHJ P,MSGFCK
	TLO AR1,200000
	PUSHJ P,$PRIN1		;SAVES AR1
	HRRZ B,@(P)
	HLRZ B,(B)
	MOVEI TT,[SIXBIT \, A SYSTEM !\]
10%	CAIL B,ENDFUN
10$	CAIGE B,BEGFUN
	 MOVEI TT,[SIXBIT \, A USER !\]
	STRT 17,(TT)
	HLRZ A,@(P)
	PUSHJ P,$PRIN1		;AR1 IS STILL GOOD
	HRRZ TT,@(P)
	HLRZ TT,(TT)
	MOVEI T,(TT)
	LSH T,-SEGLOG
	HRRZ T,ST(T)
	CAIE T,QRANDOM
	 JRST LDENT4
	STRT 17,[SIXBIT \ AT !\]	;USE OF PRINL4 HERE DEPENDS ON PRIN1
	PUSHJ P,PRINL4			; LEAVING ADDRESS OF TYO IN R (AND FILES IN AR1)
LDENT4:	STRT 17,[SIXBIT \, IS BEING REDEFINED^M;    AS A !\]
	HRRZ A,-1(P)
	PUSHJ P,$PRIN1
	STRT 17,[SIXBIT \ BY FASL FILE !\]
	MOVE A,LDFNAM
	PUSHJ P,$PRIN1
	PUSHJ P,TERP1
	PUSHJ P,UNBIND
	POP FXP,F
	POP FXP,R
	POP FXP,AR1
	SUB P,R70+1
LDNRDF:	MOVE B,(P)
	MOVE A,-1(P)
	PUSHJ P,REMPROP
	POP P,C
	MOVE A,(P)
	JSP T,LDGTWD
	PUSH FXP,TT
	MOVEI B,@LDOFST
	CAILE B,(R)
	 JSP D,LDFERR
	PUSHJ P,PUTPROP
	POP FXP,TT
	HLRZ T,TT
	HLRZ B,@(P)
	HLRZ D,1(B)
	CAIN D,(T)			;NEEDN'T DO IT IF ALREADY SAME
	 JRST LDPRG3
	JUMPN T,LDPARG
	MOVEI D,1(B)			;IF COMPLR DIDN'T HAVE ANY INFO
	LSH D,-SEGLOG			;BOUT ARGS, THEN CLOBBER ONLY IF
	MOVE D,ST(D)			;IT IS IMPURE
	TLNE D,ST.PUR
	 JRST LDPRG3
LDPARG:					;ELSE TRY TO CLOBBER IT IN
PURTRAP LDPRG9,B,	HRLM T,1(B)
LDPRG3:	SUB P,R70+1
	JRST LDBIN

SUBTTL	PUTDDTSYM FROM FASL FILE

;;; THE WORD IN TT HAS SQUOZE FOR DEFINED SYMBOL, PLUS FOUR BITS:
;;;	4.9	1 => FOLLOWING WORD IS VALUE, 0 => LOAD LOC IS VALUE
;;;	4.8	LH IS RELOCATABLE
;;;	4.7	RH IS RELOCATABLE
;;;	4.6	IS GLOBAL (0 => SYMBOLS = 'T LOADS, BUT = 'SYMBOLS DOES NOT)

LDPUT:	SKIPN A,V$SYMBOLS
	 JRST LDPUT3		;FORGET IT IF "SYMBOLS" IS () 
	CAIE A,Q$SYMBOLS
	 JRST LDPUT7
	TLNN TT,40000		;IF "SYMBOLS" IS BOUND TO "SYMBOLS", THEN
	 JRST LDPUT3		; LOAD ONLY GLOBALS
LDPUT7:
IFE ITS,[ 
	SKIPN .JBSYM"
	 JRST LDPUT3
	PUSH FXP,AR1
]		;END OF IFE ITS
	JUMPL TT,LDPUT2
	MOVE D,R
LDPUT0:
IT%	PUSH FXP,D
IT%	PUSH FXP,F
	TLZ TT,740000
	TLO T,%SYGBL+%SYHKL	;GLOBAL AND HALF-KILLED
IFN ITS,[
	SKIPG A,LDDDTP(P)
	 JRST LDBIN		;FORGET IT IF DDT HAS NO SYMBOL TABLE
	MOVE T,TT
	TRNE A,-1		;MAY HAVE TO CREATE SYMBOL TABLE ARRAY
	 JRST LDPUT5
	UNLOCKI
	PUSH FXP,AR1
	PUSHJ P,SAVX5
	MOVEI TT,LLDSTB*2+1
	MOVSI A,-1
	PUSHJ P,MKFXAR
	PUSHJ P,RSTX5
	POP FXP,AR1
	PUSHJ P,LDLRSP
	HRRM A,LDDDTP(P)
LDPUT4:	MOVSI TT,-LLDSTB	;USE TT FOR TWO THINGS HERE!
	MOVEM TT,@TTSAR(A)
LDPUT5:	SETZ TT,
	AOS TT,@TTSAR(A)	;GET AOBJN POINTER
	JUMPGE TT,LDPUT4
	MOVEM T,@TTSAR(A)	;SAVE SQUOZE FOR SYMBOL
	ADD TT,R70+1
	MOVEM D,@TTSAR(A)	;SAVE ITS VALUE
	MOVE T,TT
	SETZ TT,
	MOVEM T,@TTSAR(A)	;SAVE BACK INCREMENTED AOBJN PTR
	JUMPL T,LDBIN
	PUSHJ P,LDPUTM		;MAY BE TIME TO OUTPUT BUFFER
]		;END OF IFN ITS
IFN D10,[
LDPUT1:	MOVE T,TT
	IDIVI TT,50
	JUMPE D,LDPUT1
	MOVEI B,-1(FXP)
	MOVSI R,400000
	PUSHJ P,PUTDD0
	POP FXP,F
	POP FXP,R
	POP FXP,AR1
]		;END OF IFN D10
	JRST LDBIN


IFN ITS,[
LDPUTM:	SETZ TT,
	MOVN T,@TTSAR(A)
	MOVSI T,(T)
	HRR T,TTSAR(A)
	AOSGE T
	 .BREAK 12,[..SSTB,,T]
	POPJ P,
]		;END OF IFN ITS,

LDPUT2:	MOVE D,TT
	JSP T,LDGTWD
	EXCH TT,D
	TLNN TT,100000
	 JRST LDPT2A
	MOVE T,LDOFST
	ADD T,D
	HRRM T,D
LDPT2A:	TLNN TT,200000
	 JRST LDPUT0
	HRLZ T,LDOFST
	ADD D,T
	JRST LDPUT0

LDPUT3:	JUMPGE TT,LDBIN		;DON'T WANT TO PUT DDT SYM, BUT
	JSP T,LDGTWD		; MAYBE NEED TO FLUSH EXTRA WORD
	JRST LDBIN


LDLOC:	MOVEI TT,@LDOFST
	MOVEI D,(R)
	CAMLE D,LDHLOC
	 MOVEM D,LDHLOC
	CAMG TT,LDHLOC
	 JRST LDLOC5
	MOVE D,LDHLOC
	SUBI D,(R)
	MOVSI D,(D)
	ADD R,D
	HRR R,LDHLOC
	SETZ TT,
	SUB F,R70+1		;BEWARE THIS BACK-UP CROCK!
	ADD AR1,[040000,,]
	JRST LDABS

LDLOC5:	HRRZ D,LDOFST
	CAIGE TT,(D)
	 JSP D,LDFERR
	MOVEI D,(TT)
	SUBI D,(R)
	MOVSI D,(D)
	ADD R,D
	HRRI R,(TT)
	JRST LDBIN


SUBTTL	EVALUATE MUNGEABLE

LDEVAL:	SETZ D,			;[EVALUATE MUNGEABLE]
	PUSHJ P,LDLIST		;IF D IS LEFT 0 AFTER LDLIST, THEN WANT ENTRY INTO ATOMTABLE
	MOVEI B,(P)		;B HAS ADDR OF FASLOAD TEMPS ON STACK
	PUSH P,A
	PUSHJ P,LDEV0
	SUB P,R70+1
	JUMPN D,LDBIN
;;; THIS WILL PUT A MUNGEABLE/SQUIDIFIED SYMBOL ONTO THE LDEVPRO LIST, DUE TO
;;; THE BUG IN THE GC NOTED IN LISP BUG MAIL OF 9/2/79 BY JONL.
	SKOTT A,SY
	 JRST LDEVL7
	SKIPE B,V.PURE
	 CAIN B,QSYMBOL
	  JRST LDEVL6		;NO PURE COPY NEEDED
	PUSHJ P,PURCOPY
	JRST LDEVL7
LDEVL6:	JSP T,LDQLPRO		;PUSHES GOODY ONTO THE LDEVPRO LIST
LDEVL7:	TLO A,16		;AND GOES OFF TO ENTER INTO THE ATOMTABLE
	SKOTT A,SY+FL+FX
	 JRST LDATP8
	TLNE TT,SY
	 TLZ A,6
	TLNE TT,FX
	 TLZ A,4
	TLNE TT,FL
	 TLZ A,2
	 JRST LDATP8

LDEV0:	UNLOCKI			;EVALUATES AN S-EXPRESSION IN A
	JUMPE D,LDEV2		;ALLOWS FOR RECURSIVE FASLOADING
	SETZM FASLP		;EXCEPT WHEN EVALUATING FOR ENTRY INTO ATOMTABLE
	PUSH P,A
	MOVE C,LDPRLS(B)
	TLNN C,600000
	 HRRZM C,VPURCLOBRL
IFN D10*HISEGMENT,[
	TLNN C,100000
	 JRST LDEV4
	HRRZM R,HBPORG
	JRST LDEV5
LDEV4:
]		;END OF IFN D10*HISEGMENNT
	MOVEI TT,(R)
	JSP T,FXCONS
	MOVEM A,VBPORG
LDEV5:	HRRZ TT,LDOFST		;IN CASE EVALUATION CHANGES BPORG,
	SUBI TT,(R)		; MUST CHANGE LDOFST TO BE AN
	HRRM TT,LDOFST		; ABSOLUTE QUANTITY
	MOVNI T,LFTMPS
	PUSH FXP,BFTMPS+LFTMPS(T)
	AOJL T,.-1
	POP P,A
LDEV2:
	PUSH FXP,B
	PUSH FXP,AR1
	PUSH FXP,D
	PUSH FXP,R
	PUSH FXP,F
	PUSHJ P,EVAL
	POP FXP,F
	POP FXP,R
	POP FXP,D
	POP FXP,AR1
	POP FXP,B
	JUMPE D,LDEV1
HS$ 10$	MOVE C,LDPRLS(B)
HS$ 10$	TLNE C,100000
HS$ 10$	 SKIPA R,HBPORG
	  MOVE R,@VBPORG
	HRRZ T,LDBGEN(B)
	MOVEM T,FASLP
	MOVEI T,LFTMPS-1
	POP FXP,BFTMPS(T)
	SOJGE T,.-1
	HRRZ TT,LDOFST		;NOW RE-RELOCATE THE LOAD OFFSET
	ADDI TT,(R)
	HRRM TT,LDOFST
	HRRZ T,VPURCLOBRL
	HRRM T,LDPRLS(B)
LDEV1:	PUSH P,A
10$	MOVE TT,LDPRLS(B)	;FOR D10, PASS LDPRLS IN TT TO LDGTSP
	PUSHJ P,LDGTSP
	POP P,A
	JRST LDLRSP		;GET SPACE, LOCKI, AND RESTORE PTRS

SUBTTL	END OF FASLOAD FILE


LDBEND:	TRZ TT,1		;CROCK!
	CAME TT,[SIXBIT \*FASL*\]
	 JSP D,LDFERR
	MOVEI TT,LDFEND
	MOVEM TT,LDEOFJ
IFN ITS,[
	SKIPLE A,LDDDTP(P)
	 TRNN A,-1
	  CAIA
	   PUSHJ P,LDPUTM	;MAYBE HAVE TO FORCE LDPUT'S BUFFER
]		;END OF IFN ITS
	HLLZS LDDDTP(P)		;WILL USE FOR SWITCH LATER
	JSP T,LDGTWD
	TRZ TT,1		;COMPATIBILITY CROCK
	CAME TT,[SIXBIT \*FASL*\]
	 JRST LDBEN1
	HLLOS LDDDTP(P)
	MOVEM F,LDTEMP
	JRST LDFEND

LDBEN1:	TRZ TT,1
	CAME TT,[14060301406]
10%	 JSP D,LDFERR
10$	 JUMPN TT,LDFERR
LDFEND:	TLZ R,-1		;END OF FILE
	CAMGE R,LDHLOC
	 MOVE R,LDHLOC
	HRRZS TT,R
IFE PAGING,[
	MOVE C,LDPRLS(P)
	TLNN C,100000
	 JRST LDFEN2
	HRRZM R,HBPORG
	JRST LDFEN3

LDFEN2:	JSP T,FXCONS
	MOVEM A,VBPORG
LDFEN3:
]		;END OF IFE PAGING
IFN PAGING,[
	JSP T,FXCONS
	MOVE D,(A)
	EXCH A,VBPORG
	MOVE TT,(A)
	SKIPL LDPRLS(P)
	 JRST LDZPUR
	HLLOS NOQUIT
	ANDI TT,PAGMSK
	ANDI D,PAGMSK
	LSHC TT,-PAGLOG
	SUBI D,(TT)
	ROT TT,-4
	ADDI TT,(TT)
	ROT TT,-1
	TLC TT,770000
	ADD TT,[450200,,PURTBL]
	MOVEI T,1
LDNPUR:	TLNN TT,730000
	 TLZ TT,770000
	IDPB T,TT
	SOJGE D,LDNPUR
	PUSHJ P,CZECHI
LDZPUR:
]		;END OF IFN PAGING
	PUSH FXP,F		;SAVE POINTER TO I/O BUFFER

;FALLS THROUGH

;FALLS IN

;;; "GROVELING" OVER THE ATOMTABLE USED TO OCCUR HERE, TO GCPROTECT
;;;  BY PLACEING IN THE GCPSAR ANY ATOM NOT OTHERWISE PROTECTED.  BUT
;;;  NOWADAYS, THEY ARE ALL PROTECTED, EITHER BY BEING POINTED TO BY
;;;  SOME PROTECTED LIST STRUCTURE, OR BY THE CODE AT LDQATX.

SUBTTL	SMASH DOWN PURE LIST

LDSDPL:	SKIPL TT,LDPRLS(P)	;[SMASH DOWN PURE LIST]
	 TLNE TT,200000
	  JRST LDEOMM
	MOVEM TT,VPURCLOBRL
	MOVEI F,VPURCLOBRL
LDSDP1:	SKIPN TT,LDPRLS(P)
	 JRST LDEOMM
	SKIPN INTFLG
	 JRST LDSDP2
	SKIPE INTFLG
	 PUSHJ P,LDTRYI
LDSDP2:	HRRZ T,(TT)
	MOVEM T,LDPRLS(P)
	HLRZ AR2A,(TT)
	PUSHJ P,LDSMSH
	 JRST LDSDP3
	HRRZ F,(F)
	JRST LDSDP1
LDSDP3:	MOVE TT,LDPRLS(P)
	HRRM TT,(F)
	JRST LDSDP1

SUBTTL	END OF FASLOAD, AND RANDOM ROUTINES

;[END OF MOBY MESS!!!]

LDEOMM:	POP FXP,LDTEMP		;GET POINTER TO I/O BUFFER
	MOVE TT,LDDDTP(P)
	MOVE A,LDBSAR
	TRNE TT,-1
	 JRST LDEOM1
	PUSHJ P,$CLOSE		;CLOSE FILE ARRAY
	SETZM LDBSAR
	MOVE A,VBPORG
IFN D10*HISEGMENT,[
	MOVE TT,HBPORG
	MOVE T,LDPRLS(P)
	TLNE T,100000
	 JSP T,FXCONS
]		;END OF D10*HISEGMENT
	UNLOCKI
	POPI P,LDNPDS
	SETZM -LERSTP-1(P)	   ;Flag that we have completed our read
	JSP TT,UNWINE		   ;Perform our cleanup handling, etc
	PUSHJ P,UNBIND
	HRRZ TT,-3(P)		   ;For debugging purposes,
	HRRZ D,-2(P)		   ; make sure PDLs are okay
	HRRZ R,-1(P)
	POPI P,3+1
	JRST PDLCHK

LDEOM1:	UNLOCKI
	POPI P,LDNPDS		;POP OFF REGPDL SLOTS, BUT
	PUSH P,A		;PUT LDBSAR BACK ON PDL
	JRST LDDISM


LDTRYI:	UNLOCKI			;[TRY AN INTERRUPT]
LDLRSP:	LOCKI			;[LOCKI AND RESTORE POINTERS]
LDRSPT:	HRRZ TT,LDASAR		;[RESTORE ARRAY POINTERS]
	HRRZ TT,TTSAR(TT)
	HRRM TT,LDAPTR
	HRRZ TT,LDBSAR
IFE D10,[
	HRRZ TT,TTSAR(TT)
	HRRM TT,LDBPTR
]	;END IFE QIO*D10
.ELSE	HLLZS LDBPTR
	POPJ P,

LDLIST:	MOVEI C,-1(P)		.SEE LDOWL
	JRST LDLIS1

LDLIS0:	JSP T,LDGTWD
LDLIS1:	LDB T,[410300,,TT]	;[CONSTRUCT LIST]
	JRST LDLTBL(T)

LDLTBL:	JRST LDLATM		;ATOM
	JRST LDLLST		;LIST
	JRST LDLDLS		;DOTTED LIST
	JRST LDOWL		;EVALUATE TOP FROB ON STACK
IFN HNKLOG, JRST LDLHNK		;HUNK
.ELSE	JRST FASHNE
REPEAT 2, .VALUE
	JRST LDLEND		;END OF LIST

LDLATM:	MOVE A,@LDAPTR		;FOR ATOM, MAYBE SET USAGE BIT,
	TLNN A,777011		; THEN SHOVE ON STACK
	 IOR A,D
	MOVEM A,@LDAPTR
	PUSH P,A
	TRNN A,-1
	 JRST LDLIS0		;SKIP SY2 CHECK IF SYMBOL 'NIL'
	TLNN A,777006		;IF HAS VALUE CELL, OR IS NUMBER, DON'T DO SY2
	 TLNN D,1		;IF SETTING USAGE BIT THEN ALSO DO SO IN SY2
	  JRST LDLIS0
	HLRZ T,(A)		;GET SY2 WORD
	HLL T,(T)
	TLO T,SY.CCN\SY.OTC	;MUST FLAG ATOM AS NEEDED
	TLNN T,SY.PUR		;SET MEMORY UNLESS PURIFIED
	 HLLM T,(T)
	JRST LDLIS0

LDLLST:	TDZA A,A		;FOR LIST, USE NIL AS END
LDLDLS:	POP P,A			;FOR DOTTED LIST, USE TOP ITEM
	HRRZS TT
	JUMPE TT,LDLLS3
LDLLS1:	POP P,B			;NOW POP N THINGS AND CONS THEM UP
	PUSHJ P,XCONS
	SOJG TT,LDLLS1
LDLLS3:	PUSH P,A
	SKIPE INTFLG
	 PUSHJ P,LDTRYI
	JRST LDLIS0

LDOWL:	MOVE A,(P)
	MOVEI B,(C)		;B HAS ADDR OF FASLOAD TEMPS ON STACK
	PUSH P,C
	PUSHJ P,LDEV0
	POP P,C
	MOVEM A,(P)
	JRST LDLIS0

IFN HNKLOG,[
LDLHNK:	ANDI TT,-1		;FLUSH LH CONTROL BITS
	PUSH FXP,D
	PUSHJ FXP,ALHNKL	;(TT) HAS NUMBER OF ITEMS WANTED
	POP FXP,D
	PUSH P,A		; POP THEM OFF PDL INTO A HUNK
	JRST LDLIS0		;SAVES C
]		;END OF IFN HNKLOG

LDLEND:	HLRZ D,TT
	TRC D,777776
	TRNE D,777776
	 JSP D,LDFERR
	POP P,A
	MOVSS TT
	HRRI TT,(A)
	POPJ P,

;;; SECOND FILE NAME OF THIS LISP WHEN ASSEMBLED (VERSION NUMBER
;;; THIS LOCATION IS REFERENCED BY FASLAP WHEN CREATING A BINARY
;;; FILE. IT CONTAINS THE VALUE OF .FNAM2 PLUS EXTRA BITS
;;; TO DISTINGUISH SOME CONDITIONAL ASSEMBLY FLAGS.
;;; THE CONTENTS OF THIS LOCATION ARE PRIMARILY USED TO DETERMINE
;;; WHETHER FASLOAD MAY USE VALUES OF DDT SYMBOLS SUPPLIED BY
;;; FASLAP; IT DOES SO ONLY IF FASLAP'S VERSION NUMBER, AS
;;; DETERMINED BY THIS LOCATION, IS THE SAME AS FASLOAD'S.

ZZ==-1
ZZZ==0

;;; 2nd item used to be "ML", but it really meant "ITS"
;;; 3rd item used to be "BIBOP", but is now for D20
IRP X,,[D10,ITS,D20,BIGNUM,CMU,SAIL,HISEGMENT,PAGING]
ZZ==ZZ_1
ZZZ==<ZZZ_1>\X
TERMIN

LDFNM2:	<.FNAM2&ZZ>\ZZZ

EXPUNGE ZZ ZZZ

IFN ITS,[
LDGTW0:	SUB F,FB.BFL(TT)
	HRLZI F,(F)
	HRRI F,FB.BUF
LDGTWD:	MOVE TT,@LDBPTR
	AOBJN F,(T)
LDGTW1:	HRRZ TT,LDBSAR
	HRRZ TT,TTSAR(TT)
	PUSH FXP,FB.IBP(TT)
	MOVE F,FB.BFL(TT)
	SUBI F,1
	.CALL LDGTW9
	 .LOSE 1400
	POPI FXP,1
	ADDI F,1
	CAME F,FB.BFL(TT)
	 SOJA F,LDGTW0
	JSP D,@LDEOFJ

LDGTW9:	SETZ
	SIXBIT \SIOT\		;"STRING" I/O TRANSFER
	      ,,F.CHAN(TT)	;CHANNEL #
	      ,,0(FXP)		;BYTE POINTER
	400000,,F		;BYTE COUNT
];END IFN ITS

IFN D20,[
LDGTW0:	SUB F,FB.BFL(TT)	;MAKE F INTO AOBJN POINTER
	HRLZI F,(F)
	HRRI F,FB.BUF		;POINTING INTO THE BUFFER
LDGTWD:	AOBJP F,LDGTW1
	SUBI F,1		;READJUST TO ACCESS CORRECT WORD
	MOVE TT,@LDBPTR
	AOJA F,(T)		;FIXUP AOBJN POINTER THEN RETURN
LDGTW1:	HRRZ TT,LDBSAR
	HRRZ TT,TTSAR(TT)
	PUSHJ FXP,SAV3		;SAVE ACS WHICH WILL BE DESTROYED
	HRRZ 1,F.JFN(TT)	;JFN INTO AC 1
	MOVE 2,FB.IBP(TT)	;BYTE POINTER INTO AC 2
	MOVN 3,FB.BFL(TT)	;READ THIS MANY BYTES
	SIN			;DO THE INPUT
	 ERJMP LDGTWE		;WE CAN IGNORE ERROR IF IT IS EOF
LDGTE1:	MOVN F,3		;GET POSITIVE NUMBER OF BYTES LEFT UNREAD
	PUSHJ FXP,RST3		;RESTORE SAVED ACS
	CAME F,FB.BFL(TT)	;DID WE READ ANYTHING?
	 SOJA F,LDGTW0		;YES, SO EMPTY THE BUFFER BEFORE GIVING EOF
	JSP D,@LDEOFJ

;;; ON TENEX, GETER CLOBBERS ACS 4 THROUGH 10!  ARGGH...
LDGTWE:	PUSHJ FXP,SAV5M3	;SAVE ALL ACS CLOBBERED BY GETER JSYS
	PUSHJ P,SAVX5
	MOVEI 1,.FHSLF		;GET OUR LAST ERROR
	GETER
	PUSHJ P,RSTX5
	PUSHJ FXP,RST5M3	;AND RESTORE ACS
	HRRZS 2			;ONLY WANT ERROR CODE
	CAIN 2,IOX4		;EOF?
	 JRST LDGTE1
	MOVEI 1,.PRIOU		;OUTPUT ERROR TO PRIMARY OUTPUT CHANNEL
	HRLOI 2,.FHSLF		;LAST ERROR FOR OUR PROCESS
	SETZ 3,			;NO LIMIT TO AMOUNT OF OUTPUT
	ERSTR
	 .LOSE			;FAILED
	 .LOSE			;FAILED
	PUSHJ FXP,RST3		;RESTORE SAVED AC'S
	JSP D,@LDEOFJ		;MAKE BELIEVE WE HIT EOF
]		;END IFN D20

IFN D10,[
LDGTW0:	POP P,AR1
	POP P,T
	MOVE TT,FB.HED(TT)	;GET BUFFER HEADER ADDRESS
	MOVN F,2(TT)		;NUMBER OF WORDS IN BUFFER
	HRLZI F,-1(F)
	ADDI F,1		;NOW THE ACTUAL FIRST WORD
LDGTWD:	MOVE TT,LDBSAR		;GET POINTER TO SAR
	HRRZ TT,TTSAR(TT)
	MOVE TT,FB.HED(TT)	;GET PTR TO BUFFER HEADER
	HRRZ TT,1(TT)		;GET PTR TO FIRST WORD OF BUFFER - 1
	HRLI TT,F		;INDEXED OFF OF F
	MOVE TT,@TT
	AOBJN F,(T)
LDGTW1:	PUSH P,T
	PUSH P,AR1
	MOVE AR1,LDBSAR
	MOVE TT,TTSAR(AR1)	;WAIT! YOU LOSER, TT MUST HAVE TTSAR IN IT
	MOVE T,F.CHAN(TT)
	LSH T,27
IFE SAIL,[
	TLNN TT,TTS.BM
	 JRST LDGTW6		;$DEV5R
	PUSH FLP,F
	HRRZ T,FB.HED(TT)	;MAYBE BUFFER HAS BEEN RELOCATED? THEN FOR
	MOVSI F,(BF.IOU) 
	ANDCAB F,@(T)		;TURNS OFF BUFFER-IN-USE BIT AND ADVANCES BUFFER
	SKIPGE (F)		;BF.IOU MUST BE BIT 4.9 FOR THIS TO WORK
	 JRST LDGTW4 		;$DEV5S 
	MOVSI T,TTS.BM
	ANDCAM T,TTSAR(AR1)	;TURN OFF "BUFFER-MOVED" BIT, BUT LEAVE BUF ADDR IN F
	MOVE T,F.CHAN(TT)	;$DEV5Q:
	LSH T,27
	HRR T,F
	POP FLP,F
]	;END OF IFE SAIL
LDGTW6:	TLO T,(IN 0,)		;$DEV5R:
	XCT T			;READ A NEW BUFFERFUL
	 JRST LDGTW0		;$DEV5M	(?)	;SUCCESS!
	POP P,AR1
	POP P,T
	JSP D,@LDEOFJ

IFE SAIL,[
LDGTW4: HRRZ T,FB.HED(TT)
	HRRZM F,(T)		;STORE CURRENT BUFFER ADDR IN CONTROL BLOCK
	TLZ F,-1
	ADD F,[4400,,1]
	MOVEM F,1(T)		;CONSTRUCT NEW BP FOR BUFFER
	MOVE F,(F)
	MOVEM F,2(T)		;STORE NEW BYTE COUNT INITO BUFFERCONTROL-BLOCK
	POP FLP,F
	JRST LDGTW0
]	;END OF IFE SAIL

]	;END OF IFN D10

PGTOP FSL,[FASLOAD]