Google
 

Trailing-Edge - PDP-10 Archives - decus_20tap1_198111 - decus/20-0002/loader.mac
There are 9 other files named loader.mac in the archive. Click here to see a list.
COMMENT    VALID 00113 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00010 00002	SUBTTL	RP GRUEN/NGP/WFW/DMN  V.052	7-SEP-70
C00014 00003	SUBTTL	DEFAULT ASSEMBLY SWITCH SETTINGS
C00017 00004	SUBTTL	ACCUMULATOR ASSIGNMENTS
C00019 00005	FLAGS	F(0 - 17)
C00022 00006	MORE FLAGS IN F (18-35)
C00024 00007	IFE K,<	TITLE	LOADER - LOADS MACRO AND FORTRAN FOUR>
C00026 00008	SUBTTL	CCL INITIALIZATION
C00029 00009	RPGS3:	MOVEI	CTLBUF	
C00031 00010	SUBTTL NORMAL INITIALIZATION
C00039 00011	LOADER SCAN FOR FILE NAMES
C00045 00012	SUBTTL	CHARACTER HANDLING
C00048 00013	OUTPUT SPECIFICATION DELIMITER <=> OR <LEFT ARROW>
C00053 00014	RIGHT SQUARE BRACKET (PROJ-PROG NUMBERS)
C00056 00015	IFN SYMARG,<
C00059 00016	SUBTTL	TERMINATION
C00064 00017	SUBTTL	PRINT FINAL MESSAGE
C00070 00018	SUBTTL	SET UP JOBDAT
C00083 00019	SUBTTL	BLT SYMBOL TABLE INTO HIGH SEGMENT
C00087 00020	NOBLT:	HRRZ	Q,HILOW	GET HIGHEST LOC LOADED
C00089 00021	SUBTTL	WRITE DUMP FILE
C00092 00022	SUBTTL	WRITE CHAIN FILES
C00095 00023	SUBTTL	SPECIAL CHAINB
C00099 00024	SMTBFX:	TLNE N,PPCSW	IF NOT CUTTING BACK SYMBOL TABLE
C00104 00025	SUBTTL	EXPAND CORE
C00107 00026	SUBTTL	SWITCH HANDLING
C00108 00027	DISPATCH TABLE FOR SWITCHES
C00112 00028	 PAIRED SWITCHES ( +,-)
C00115 00029	IFN REENT,<	 H SWITCH --- EITHER /H OR /NH
C00117 00030	SWITCH MODE NUMERIC ARGUMENT
C00119 00031	ATTEMPT TO CHAIN WITH SPECIFIED HALF OF JOBCHN = 0
C00120 00032	SUBTTL	CHARACTER CLASSIFICATION TABLE DESCRIPTION:
C00122 00033	BYTE POINTERS TO CHARACTER CLASSIFICATION TABLE
C00125 00034	SUBTTL	INITIALIZE LOADING OF A FILE
C00129 00035	SUBTTL	LIBRARY SEARCH CONTROL AND LOADER CONTROL
C00132 00036		LIB CONTROLS THE LIBRARY SEARCH OF ONE FILE
C00134 00037	IFN SAILSW,<
C00137 00038	SUBTTL	LDDT LOADS <SYS:DDT.REL> AND SETS SYMSW
C00140 00039	SUBTTL	EOF TERMINATES LOADING OF A FILE
C00142 00040	SUBTTL	LOAD SUBROUTINE
C00145 00041	SUBTTL	LOAD PROGRAMS AND DATA 		(BLOCK TYPE 1)
C00148 00042	SUBTTL	LOAD SYMBOLS 			(BLOCK TYPE 2)
C00150 00043		LOCAL SYMBOL
C00153 00044		GLOBAL DEFINITION MATCHES REQUEST
C00156 00045		COMBINE TWO REQUEST CHAINS
C00159 00046	FIXWL:	HRLZ	T,W		UPDATE VALUE OF LEFT HALF
C00161 00047		PATCH VALUES INTO CHAINED REQUEST
C00163 00048	SUBTTL	HIGH-SEGMENT 			(BLOCK TYPE 3)
C00167 00049	SUBTTL	HIGHEST RELOCATABLE POINT 	(BLOCK TYPE 5)
C00172 00050	SUBTTL	EXPAND HIGH SEGMENT
C00174 00051	SUBTTL	PROGRAM NAME 			(BLOCK TYPE 6)
C00177 00052	COMPILER TYPE - DO SPECIAL FUNCTION FOR IT
C00178 00053	SUBTTL	STARTING ADDRESS 		(BLOCK TYPE 7)
C00179 00054	SUBTTL	ONE PASS LOCAL DEFINITION 	(BLOCK TYPE 10)
C00181 00055	SUBTTL	LVAR FIX-UP 			(BLOCK TYPE 13)
C00184 00056	SUBTTL	FAIL LOADER
C00189 00057	IFN FAILSW,<	POLISH FIXUPS FOR FAIL	(BLOCK TYPE 11)
C00194 00058	HANDLE OPERANDS. THIS GETS COMPLICATED BECAUSE OF THE PRESENCE OF
C00196 00059	HAVE ENOUGH OPERANDS FOR THE CURRENT OPERATOR
C00199 00060	FINALLY WE GET TO STORE THIS MESS
C00202 00061	ALSTR1:
C00210 00062	POLSAT:	PUSH P,C	SAVE SYMBOL
C00215 00063	STRSAT:	MOVE W,C	GET VALUE TO STORE IN W
C00216 00064	SUBTTL LIBRARY INDEX 			(BLOCK TYPE 14)
C00219 00065	INDEX4:	ADDM	T,ABUF1
C00223 00066	THSBLK:	SUB	A,LSTBLK	GET WORD DIFFERENCE
C00225 00067	SUBTTL	ALGOL OWN BLOCK (TYPE 15)
C00228 00068	SUBTTL	SAIL BLOCK TYPE 16 AND 17
C00230 00069	SUBTTL	SYMBOL TABLE SEARCH SUBROUTINES
C00232 00070	SUBTTL	RELOCATION AND BLOCK INPUT
C00235 00071	SUBTTL	PRINT STORAGE MAP SUBROUTINE
C00240 00072	PRMP1A:	PUSHJ	P,TAB
C00244 00073	SUBTTL	LIST UNDEFINED AND MULTIPLY DEFINED GLOBALS
C00246 00074	SUBTTL	ENTER FILE ON AUXILIARY OUTPUT DEVICE
C00248 00075	SUBTTL	PRINT SUBROUTINES
C00249 00076	IFN NAMESW,<
C00250 00077		ACCUMULATORS USED: Q,T,D
C00253 00078	SUBTTL	SYMBOL PRINT - RADIX 50
C00255 00079	OTOD:	IBP	N
C00256 00080	SUBTTL	ERROR MESSAGE PRINT SUBROUTINE
C00258 00081	ERRPT8:	TLO	F,FCONSW	INSURE TTY OUTPUT
C00259 00082	SUBTTL	INPUT - OUTPUT INTERFACE
C00261 00083	SUBTTL	IMPURE CODE
C00262 00084	SUBTTL	DATA STORAGE
C00264 00085	PT1:	BLOCK 1
C00266 00086	SUBTTL	BUFFER HEADERS AND HEADER HEADERS
C00268 00087	SUBTTL	FORTRAN DATA STORAGE
C00270 00088	SUBTTL	REMAP UUO
C00272 00089	SUBTTL	LISP LOADER
C00273 00090	SUBTTL	 FORTRAN FOUR LOADER
C00275 00091	SUBTTL	PROCESS TABLE ENTRIES
C00277 00092	SUBTTL	STORE WORD AND SET BIT TABLE
C00280 00093	SUBTTL	PROCESS END CODE WORD
C00285 00094	PRSTWX:	PUSHJ	P,WORDPR	GET A WORD PAIR
C00286 00095	SUBTTL	BEGIN HERE PASS2 TEXT PROCESSING
C00288 00096	TABDIS:	XWD 11,PCONS		CONSTANTS
C00290 00097	SUBTTL	ROUTINES TO PROCESS POINTERS
C00293 00098	NCO:	PUSHJ	P,SWAPSY
C00295 00099	SWAPSY:	MOVEI	T,0		SET TO EXCHANGE DEFS
C00296 00100	SUBTTL	END OF PASS2
C00299 00101	FBLKD:	TLOE	N,BLKD1		IS THIS FIRST BLOCK DATA?
C00303 00102	CONPOL:	ADD	T,ITC	CONSTANT BASE
C00305 00103	DODONE:	POP	P,-1(P)	BACK UP ADDRESS
C00307 00104	DREAD:	TLNE	N,RCF		NEW REPEAT COUNT NEEDED
C00309 00105	SUBTTL	ROUTINE TO SKIP FORTRAN OUTPUT
C00312 00106	SUBTTL	LISP LOADER
C00313 00107	SYMSRT - SORT SYMBOL TABLE FOR RAID
C00319 00108	SYMSRT
C00322 00109	NOW, HOW BIG IS SYMBOL TABLE GOING TO BE?
C00325 00110	PASS 2 - COPY SYMBOL NAMES TO NEW SYMBOL TABLE.  BUILD BN/BS AREAS
C00329 00111	WE SORT THINGS HERE
C00333 00112	CALL WITH 2=FIRST ADDRESS IN RANGE, 3=ADDRESS OF LAST ITEM IN RANGE
C00336 00113	SYLPOP:	HRL	6,PD		PD COPIED TO LH OR ARGUMENT
C00338 ENDMK
C;

SUBTTL	RP GRUEN/NGP/WFW/DMN  V.052	7-SEP-70

; RFS 11-30-70
;	TURNED ON FAILSW,SAILSW FOR NIH USAGE.
; DCS 1-24-71
;	ADDITIONS FOR SAIL (SHARED EXECS, UPDATED STANSW)

; REG 7-17-71
;	TURN ON REENT FEATURES

; REG 3-23-74
;	MOVED BLOCK TYPES 15 AND 16 TO 16 AND 17

; REG 2-20-75
;	ADDED SORTSY SWITCH, ETC.

; TVR 30-AUG-75
;	TURNED OFF SORTSY FOR LISP LOADER

	VLOADER==52
	VPATCH==0		;DEC PATCH LEVEL
	VCUSTOM==<SIXBIT /   SG1/>		;NON-DEC PATCH LEVEL
				;SAISEG VERSION 1

	LOC <JOBVER==137>
	XWD VCUSTOM,VLOADER+1000*VPATCH
	RELOC

COMMENT	*	ASSEMBLY FEATURE SWITCHES (ACTION WHEN NON-ZERO)

	SWITCHES ON (NON-ZERO) IN DEC VERSION
SEG2SW		GIVES TWO SEGMENT CODE (IF MACRO ALLOWS IT)
PURESW		GIVES PURE CODE (VARIABLES IN LOW SEG)
REENT		GIVES REENTRANT CAPABILITY PDP-10
	(REENT=0 FOR PDP-10/30 OR PDP-6 OR EARLY PDP-10)
RPGSW		INCLUDE CCL FEATURE
TEMP		INCLUDE TMPCOR FEATURE
DMNSW		 SYMBOL TABLE WILL BE MOVED DOWN FROM TOP OF CORE
KUTSW		 GIVES CORE CUTBACK ON /K
EXPAND		 FOR AUTOMATIC CORE EXPANSION
PP		ALLOW PROJ-PROG #
DIDAL		GIVES DIRECT ACCESS LIBRARY SEARCH MODE
ALGSW		WILL LOAD ALGOL OWN BLOCK (TYPE 15)

	SWITCHES OFF (ZERO) IN DEC VERSION
K		GIVES 1KLOADER - NO F4
L		 FOR LISP LOADER
SPMON		GIVES SPMON LOADER (MONITOR LOADER)
TEN30		FOR 10/30 LOADER
STANSW		 GIVES STANFORD FEATURES
LNSSW		GIVES LNS VERSION
FAILSW		INCLUDE PROVISIONS FOR SPECIAL FAIL FIXUPS.
LDAC		 MEANS LOAD CODE INTO ACS
	(LDAC DOES NOT WORK WITH KUTSW=1.CORE UUO CLEARS JOBBLT)
WFWSW		GIVES BLOCK TYPE 13 (VARIABLS INTO LOW SEG)
SYMARG		ACCEPT SYMBOLIC (GLOBAL) ARGUMENTS FOR SWITCHES
SPCHN		WILL DO SPECIAL OVERLAYING
SAILSW		GIVES BLOCK TYPE 15 (FORCE LOAD OF REL FILES)
		AND 16 (FORCE SEARCH OF LIBRARIES) FOR SAIL
SORTSY		SORTS SYMBOL TABLE FOR RAID ON XXX COMMAND SWITCH
SILENT		FORCES LISP LOADER TO BE SILENT
*

COMMENT/
AT STANFORD WE USE
	STANSW, SAILSW, FAILSW, SORTSY, AND REENT ALL ON
	L,ALGSW, PURESW AND SEG2SW ALL OFF
/
	STANSW==1
	SAILSW==1
	FAILSW==1
	REENT==1
	ALGSW==0
	PURESW==0
	SEG2SW==0
	SORTSY==1

SUBTTL	DEFAULT ASSEMBLY SWITCH SETTINGS

IFNDEF SPMON,<SPMON=0>
IFN SPMON,<	TEN30==1
		K==1>

IFNDEF L,<L=0>
IFNDEF SILENT,<SILENT=0>

IFNDEF TEN30,<TEN30=0>

IFN TEN30!L,<	RPGSW=0
		PP=0
IFNDEF DMNSW,<	DMNSW=0>
DIDAL==1
IFNDEF DIDAL,<	DIDAL=0>
		ALGSW=0
		PURESW=0
		REENT=0
		LDAC=0
		KUTSW=0
		SEG2SW=0
		NAMESW=0>
IFN TEN30,<	EXPAND=0>

IFNDEF SORTSY,<SORTSY==0>
IFNDEF	K,<K=0>

STANSW==1
IFNDEF STANSW,<STANSW=0>
IFN STANSW,<	FAILSW=1
		TEMP==1
		REENT==1>

IFNDEF LNSSW,<LNSSW=0>
IFN LNSSW,<LDAC=1
	PP=0>

FAILSW==1
IFNDEF FAILSW,<FAILSW=0>

IFNDEF RPGSW,<RPGSW==1>
IFN RPGSW,<PP==1>	;REQUIRE DISK FOR CCL
IFE RPGSW,<TEMP=0>

IFNDEF PP,<PP==1>
IFN L,<PP==1
       SORTSY==0>

IFNDEF TEMP,<TEMP==1>

IFNDEF NAMESW,<NAMESW==1>

IFNDEF LDAC,<LDAC=0>
IFN LDAC,<KUTSW=0>

IFNDEF KUTSW,<KUTSW==1>

IFNDEF EXPAND,<	IFN K,<EXPAND==0>
		IFE K,<EXPAND==1>>

IFNDEF DMNSW,<DMNSW==1>
IFN DMNSW!LDAC,<IFNDEF SYMPAT,<SYMPAT==20>
	IFN LDAC,<IFG 20-SYMPAT,<SYMPAT==20>>>

IFNDEF REENT,<REENT==1>
IFE REENT,<PURESW=0
	SEG2SW=0>
IFG STANSW,<SEG2SW==0
	PURESW==0>

IFDEF TWOSEG,<IFNDEF SEG2SW,<SEG2SW==1>>
IFNDEF SEG2SW,<SEG2SW==0>
IFN SEG2SW,<PURESW==1>

IFNDEF PURESW,<PURESW==1>

IFNDEF WFWSW,<WFWSW==0>

IFN K,<SYMARG=0
	SPCHN=0>

IFNDEF SYMARG,<SYMARG==0>

IFNDEF SPCHN,<SPCHN==0>

IFNDEF DIDAL,<DIDAL==1>

IFNDEF ALGSW,<ALGSW==0>

SAILSW==1
IFNDEF SAILSW,<SAILSW==0>

IFN SORTSY,<SORTSY==1>	;NORMALIZE TO 1 OR 0  SEE LD9

SUBTTL	ACCUMULATOR ASSIGNMENTS
	F=0		;FLAGS IN BOTH HALVES OF F
	N=1		;FLAGS IN LH, PROGRAM NAME POINTER IN RH
	X=2		;LOADER OFFSET
	H=3		;HIGHEST LOC LOADED
	S=4		;UNDEFINED POINTER
	R=5		;RELOCATION CONSTANT
	B=6		;SYMBOL TABLE POINTER
	D=7
	T=10
	V=T+1
	W=12		;VALUE
	C=W+1 		;SYMBOL
	E=C+1 		;DATA WORD COUNTER
	Q=15		;RELOCATION BITS
	A=Q+1 		;SYMBOL SEARCH POINTER
	P=17		;PUSHDOWN POINTER


;MONITOR LOCATIONS IN THE USER AREA

JOBDA==140
JOBHDA==10

EXTERN	JOBDDT,JOBFF,JOBSA,JOBREL,JOBSYM,JOBUSY,JOB41
IFN REENT,<	EXTERN	JOBHRL,JOBCOR>
IFE K,<EXTERN	JOBCHN		;RH = PROG BREAK OF FIRST BLOCK DATA
				;LH = PROG BREAK OF FIRST F4 PROG>
IFN RPGSW,<	EXTERN	JOBERR>
IFN LDAC,<	EXTERN	JOBBLT>
IFN FAILSW,<	EXTERN	JOBAPR>

NEGOFF==400		;NEGATIVE OFFSET OF HIGH SEGMENT


IFN FAILSW,<;LENGTH OF PUSHDOWN LIST FOR POLISH FIXUPS
PPDL==60>

;FLAGS	F(0 - 17)
	CSW==1	 		;ON - COLON SEEN
	ESW==2	 		;ON - EXPLICIT EXTENSION IDENT.
	SKIPSW==4		;ON - DO NOT LOAD THIS PROGRAM
	FSW==10			;ON - SCAN FORCED TO COMPLETION
	FCONSW==20		;ON - FORCE CONSOLE OUTPUT
IFN REENT,<HIPROG==40	;LOADING HI PROGRAM, SET BY HISEG. CLEARED BY EOF>
	ASW==100		;ON - LEFT ARROW ILLEGAL
	FULLSW==200		;ON - STORAGE EXCEEDED
	SLIBSW==400		;ON - LIB SEARCH IN THIS PROG
	RMSMSW==1000		;REMEMBER IF LOADING WITH SYMBOLS DURING LIB SEARCH
	REWSW==2000		;ON - REWIND AFTER INIT
	LIBSW==4000		;ON - LIBRARY SEARCH MODE
	NAMSSW==10000		;NAME BLOCK HAS BEEN SEEN FOR THIS PROG
	ISW==20000		;ON - DO NOT PERFORM INIT
	SYMSW==40000		;ON - LOAD LOCAL SYMBOLS
	DSW==100000		;ON - CHAR IN IDENTIFIER
	NSW==200000		;ON - SUPPRESS LIBRARY SEARCH
	SSW==400000		;ON - SWITCH MODE


;FLAGS	N(0 - 17)
	ALLFLG==1		;ON - LIST ALL GLOBALS
	ISAFLG==2		;ON - IGNORE STARTING ADDRESSES
	COMFLG==4		;ON - SIZE OF COMMON SET
IFE K,<	F4SW==10		;F4 IN PROGRESS
	RCF==20			;READ DATA COUNT
	SYDAT==40;		SYMBOL IN DATA>
	SLASH==100		;SLASH SEEN
IFE K,<	BLKD1==200		;ON- FIRST BLOCK DATA SEEN
	PGM1==400		;ON FIRST F4 PROG SEEN
	DZER==1000		;ON - ZERO SECOND DATA WORD>
	EXEQSW==2000		;IMMEDIATE EXECUTION
	DDSW==4000		;GO TO DDT
IFN RPGSW,<RPGF==10000		;IN RPG MODE>
	AUXSWI==20000		;ON - AUX. DEVICE INITIALIZED
	AUXSWE==40000		;ON - AUX. DEVICE ENTERED
IFN PP,<PPSW==100000		;ON - READING PROJ-PROG #>
IFN PP!SPCHN,<PPCSW==200000	;ON - READING PROJ #>
IFN FAILSW,<HSW==400000		;USED IN BLOCK 11 POLISH FIXUPS>

;MORE FLAGS IN F (18-35)
IFN REENT,<
SEENHI==1		;HAVE SEEN HI STUFF
NOHI==2			;LOAD AS NON-REENTRANT>
IFN RPGSW,<NOTTTY==4	;DEV "TTY" IS NOT A TTY>
NOHI6==10		;PDP-6 TYPE SYSTEM
IFN DMNSW,<HISYM==20	;BLT SYMBOLS INTO HIGH SEGMENT>
SEGFL==40		;LOAD INTO HI-SEG>
IFN DIDAL,<XFLG==100		;INDEX IN CORE (BLOCK TYPE 14)
LSTLOD==200		;LAST PROG WAS LOADED
DTAFLG==400		;LIBRARY DEVICE IS A DTA (NEEDED FOR INDEXING)>
IFN DMNSW,<DMNFLG==1000>	;SYMBOL TABLE TO BE MOVED DOWN
IFN REENT,<VFLG==2000	;DO LIB SEARCH OF IMP40.REL BEFORE LIB40>
IFN SYMARG,<ARGFL==4000	;TREAT $%. AS RADIX-50 CHAR.>
TWOFL==10000		;TWO SEGMENTS IN THIS BINARY FILE
LOCAFL==20000		;PRINT LOCAL SYMBOLS IN MAP
TTYFL==40000			;AUX. DEV. IS TTY


IFE K,<F4FL==400000		;FORTRAN SEEN>
COBFL==200000			;COBOL SEEN
IFN ALGSW,<ALGFL==100000	;ALGOL SEEN>

DEFINE ERROR (X,Y)<
JSP A,ERRPT'X
SIXBIT Y>


IFE K,<	TITLE	LOADER - LOADS MACRO AND FORTRAN FOUR>
IFN K,<	TITLE	1KLOAD - LOADS MACRO>

IFN PURESW,<
IFE SEG2SW,<HISEG>
IFN SEG2SW,<TWOSEGMENTS
	RELOC	400000>>



IFN SPCHN,<
DSKBLK==200	;LENGTH OF DISK BLOCKS
VECLEN==^D25	;LENGTH OF VECTOR TABLE FOR OVERLAYS>

IFN SAILSW,<
RELLEN==^D40	;#NUMBER OF REL FILES OR LIBRARIES (MUST BE SAME)>

;CALLI DEFINITIONS

OPDEF	RESET	[CALLI	 0]
OPDEF	SETDDT	[CALLI	 2]
OPDEF	DDTOUT	[CALLI	 3]
OPDEF	DEVCHR	[CALLI	 4]
OPDEF	CORE	[CALLI	11]
OPDEF	EXIT	[CALLI	12]
OPDEF	UTPCLR	[CALLI	13]
OPDEF	DATE	[CALLI	14]
OPDEF	MSTIME	[CALLI	23]
OPDEF	PJOB	[CALLI	30]
OPDEF	SETUWP	[CALLI	36]
OPDEF	REMAP	[CALLI	37]
OPDEF	GETSEG	[CALLI	40]
IFE STANSW,<
OPDEF	SETNAM	[CALLI	43]
>
IFN STANSW,<
OPDEF	SETNAM	[CALLI	400002]
OPDEF	SHOWIT	[CALLI	400011]
>
OPDEF	TMPCOR	[CALLI	44]


	MLON
IFDEF SALL,<	SALL>

SUBTTL	CCL INITIALIZATION
IFN RPGSW,<
BEG:	JRST	LD	;NORMAL INITIALIZATION
RPGSET:	RESET		;RESET UUO.
IFN TEMP,<MOVEI F,CTLBUF-1	;USE CCL BUFFER FOR COMMANDS
	HRRM F,CTLIN+1		;DUMMY UP BYTE POINTER
	HRLI F,-200	;MAKE IT AN IOWD
	MOVEM F,TMPFIL+1
	MOVSI F,(SIXBIT /LOA/)
	MOVEM F,TMPFIL
	MOVE N,[XWD 2,TMPFIL]	;POINTER FOR TMPCOR READ
	TMPCOR	N,		;READ AND DELETE LOA FILE
	JRST RPGTMP		;NO SUCH FILE IN CORE, TRY DISK
	IMULI N,5		;GET CHAR COUNT
	ADDI N,1
	MOVEM N,CTLIN+2		;STORE IN BUFFER HEADER
	MOVEI N,700		;BYTE POINTER FOR LOA FILE
	HRLM N,CTLIN+1		;BYTE POINTER NOW COMPLETE
	SETOM TMPFLG		;MARK THAT A TMPCOR READ WAS DONE
	SETZM NONLOD		;NOT YET STARTED SCAN
	JRST RPGS3C		;GET BACK IN MAIN STREAM

RPGTMP:	SETZM TMPFLG		;MARK AS NOT TMP	>;IFN TEMP
	INIT	17,1		;SET UP DSK FOR COMMAND FILE INPUT.
	SIXBIT /DSK/
	XWD 0,CTLIN
	JRST	NUTS		;CAN'T INIT, GET INPUT FROM TTY.
	MOVEI	F,3
	PJOB	N,		;GET JOB NUMBER
LUP:	IDIVI	N,12		;STRIP OFF LAST DIGIT
	ADDI	N+1,"0"-40	;CONVERT TO SIXBIT
	LSHC	N+1,-6		;SAVE
	SOJG	F,LUP		;3 DIGITS YET?
	HLLZ	N+2		;YES.
	HRRI	'LOA'		;LOADER NAME PART OF FILE NAME.
	MOVEM	CTLNAM
	MOVSI	'TMP'		;AND EXTENSION.
	MOVEM	CTLNAM+1
	SETZM	CTLNAM+3
	LOOKUP	17,CTLNAM	;FILE THERE?
	JRST	NUTS		;NO.
	INIT	16,1		;GET SET TO DELETE FILE
	SIXBIT	/DSK/
	0
	JRST	RPGS3A		;GIVE UP
	SETZM	CTLNAM+3	;PUT STUFF BACK AS IT WAS
	LOOKUP	16,CTLNAM
	JRST	RPGS3B
	SETZM	CTLNAM		;SET FOR RENAME
	SETZM	CTLNAM+3	;(FOR STANFORD, MAKE THE PPN MATCH)
	RENAME	16,CTLNAM
	JFCL			;IGNORE FAILURE
RPGS3B:	RELEASE	16,		;GET RID OF DEVICE
RPGS3A:	SETZM	NONLOD		;TO INDICATE WE HAVE NOT YET STARTED TO SCAN
				;COMMAND IN FILE.

RPGS3:	MOVEI	CTLBUF	
	MOVEM	JOBFF
	INBUF	17,1		;SET UP BUFFER.
RPGS3C:	TTCALL	3,[ASCIZ /LOADING/]	;PRINT MESSAGE THAT WE ARE STARTING.
	SKIPE	NONLOD		;CONTIUATION OF COMMAND?
	JRST	RPGS2		;YES, SPECIAL SETUP.
CCLCHN:	MOVSI	N,RPGF		;@ CHAIN FILES CYCLE FROM HERE
	JRST	CTLSET		;SET UP TTY

RPGS1:	PUSHJ	P,[TLNE F,ESW	;HERE FROM FOO@ COMMAND, STORE NAME.
		   JRST LDDT3	;SAVE EXTENSION.
		   TLZE F,CSW!DSW  ;AS NAME
		   MOVEM W,DTIN	;STORE AS NAME
		   SETZM W,DTIN1	;TRY BLANK EXTENSION FIRST.
		   JRST LDDT4]
	MOVEM	0,SVRPG		;SAVE 0 JUST IN CASE
	SETZM	NONLOD		;DETERMINE IF CONTINUATION.
	MOVEI	0,2(B)		;BY SEEING IF ANY SYMBOLS LOADED.
	CAME	0,JOBREL
	SETOM	NONLOD		;SET TO -1 AND SKIP CALLI
IFN TEMP,<SETZM TMPFLG>
	MOVE 	0,ILD1
	MOVEM	0,RPG1
	OPEN	17,OPEN1		;KEEP IT PURE
	JRST	[MOVE	W,RPG1
		JRST	ILD5]
	LOOKUP	17,DTIN		;THE FILE NAME.
	JRST	[MOVE	0,SVRPG	;RESTORE AC0=F
		TLOE	F,ESW	;WAS EXT EXPLICIT?
		JRST	ILD9	;YES, DON'T TRY AGAIN.
		MOVEM	0,SVRPG	;SAVE AC0 AGAIN
		MOVSI	0,(SIXBIT /TMP/)	;TRY TMP INSTEAD
		MOVEM	0,DTIN1
		PUSHJ P,LDDT4	;SET UP PPN
		JRST	.-1]	;TRY AGAIN
	JRST	RPGS3

RPGS2:	MOVSI	0,RPGF	;SET FLAG
	IORM	0,F.C+N
	TLO	N,RPGF
	MOVE	0,SVRPG
	JRST	LD2Q		;BACK TO INPUT SCANNING.

>


SUBTTL NORMAL INITIALIZATION

LD:
IFE RPGSW,<
BEG:	>;RPGSW

IFN L,<		HRRZM	0,LSPXIT
		HRRZM	W,LSPREL	;BY TVR AFTER DBA AFTER JRA FOR UCI
		MOVEI	0,0
		HRRZM	R,RINITL
IFN SILENT,<
		MOVEM	N,INBYTP	;SAVE BYTE POINTER
		MOVEM	S,INBYTC	;AND THE BYTE COUNT
>
		RESET			>;IFN L

IFE L,<
IFN RPGSW,<	HLLZS	JOBERR		;MAKE SURE ITS CLEAR.>;RPGSW

		RESET			;INITIALIZE THIS JOB
NUTS:		SETZ	N,		;CLEAR N
CTLSET:		SETZB	F,S		;CLEAR THESE AS WELL
		HLRZ	X,JOBSA		;TOP OF LOADER
		HRLI	X,V		;PUT IN INDEX
		HRRZI	H,JOBDA(X)	;PROGRAM BREAK
		MOVE	R,[XWD W,JOBDA]	;INITIAL RELOCATION  >;IFE L

IFN SORTSY,<	SETZM DOSORT>	;INITIALLY, DON'T SORT SYMBOLS

	MOVSI	E,(SIXBIT /TTY/)
	DEVCHR	E,
	TLNN	E,10		;IS IT A REAL TTY?

IFE RPGSW,<	EXIT		>;NO, EXIT IF NOT TTY.  ;NOT RPGSW

IFN RPGSW,<JRST	[TLNN	F,RPGF	;IN CCL MODE?
		EXIT		;NO, EXIT IF NOT TTY
		TRO F,NOTTTY	;SET FLAG
		JRST	LD1]	;SKIP INIT  >;RPGSW

	INIT	3,1 		;INITIALIZE CONSOLE
	'TTY   '
	XWD	BUFO,BUFI
CALLEX:	EXIT			;DEVICE ERROR, FATAL TO JOB
	MOVEI     E,TTY1
	MOVEM     E,JOBFF
	INBUF     3,1
	OUTBUF    3,1 		;INITIALIZE OUTPUT BUFFERS
	OUTPUT    3,			;DO INITIAL REDUNDANT OUTPUT


IFE L,<
LD1:		HRRZ	B,JOBREL	;MUST BE JOBREL FOR LOADING REENTRANT
		HRRZM	B,HISTRT
		SUBI	B,2		;INITIALIZE SYMBOL TABLE POINTER
		CAILE	H,1(B)		;TEST CORE ALLOCATION
		JRST	[HRRZ	B,JOBREL;TOP OF CORE
			ADDI	B,2000	;1K MORE
			CORE	B,	;TRY TO GET IT
			EXIT		;INSUFFICIENT CORE, FATAL TO JOB
			JRST	LD1]	;TRY AGAIN 	>;IFE L


IFN L,<

;The following has to lose in certain circumstances, since executing CORE UUO
;does not affect JOBSYM, hence will loop getting more core until the system
;has no more to offer, at which time it EXITs. --- TVR
;(Now prints error message - Feb76)

		MOVE	B,JOBSYM	;INSTEAD OF JOBREL FOR SYMBOL TABLE FIXUPS
		TRNN	B,1		;MAKE IT POINT TO A FREE LOCATION
		SUBI	B,1		;(just like JOBREL).
		HRRZM	B,HISTRT
		SUBI	B,2		;INITIALIZE SYMBOL TABLE POINTER
		CAILE	H,1(B)		;TEST CORE ALLOCATION
		JRST	[OUTSTR	[ASCIZ/
Error in LISP Loader: Called with H greater than JOBSYM. /]
			HALT 	.]	;TRY AGAIN >;IFN L

IFN EXPAND,< IFE STANSW ,<SETZ S,
	CORE	S,		;GET PERMITTED CORE
	JFCL
	LSH	S,12
	SUBI	S,1		;CONVERT TO NUMBER OF WORDS
	MOVEM	S,ALWCOR	;SAVE IT FOR XPAND TEST>>
IFN STANSW,<
	MOVEI	S,-1		;THERE IS ALWAYS CORE AT STANFORD!!
	MOVEM	S,ALWCOR         >

IFN PURESW,<MOVE S,[XWD HICODE,LOWCOD]
	BLT S,LOWCOD+CODLN-1>
IFE L,<	MOVS	E,X 		;SET UP BLT POINTER
	HRRI	E,1(X)>
IFN L,<MOVS E,H
	HRRI E,1(H)>
	SETZM     -1(E) 		;ZERO FIRST WORD
	BLT	E,(B)		;ZERO CORE UP TO THE SYMBOL AREA
	HRRZ	S,B 		;INITIALIZE UNDEF. POINTER
	HRRZ T,B		;Initialize pointer to end of globals
	HRLI T,-2
	MOVEM T,GLBEND
	MOVEI T,GLBEND
	MOVEM T,GLBENP		;AND POINTER POINTER
	HRR	N,B 		;INITIALIZE PROGRAM NAME POINTER
IFE L,<	HRRI	R,JOBDA		;INITIALIZE THE LOAD ORIGIN
	MOVE	E,COMM		;SET .COMM. AS THE FIRST PROGRAM
	MOVEM     E,1(B)		;STORE IN SYMBOL TABLE
	HRRZM     R,2(B)		;STORE COMMON ORIGIN>
	MOVEI     E,F.C		;INITIALIZE STATE OF THE LOADER
	BLT	E,B.C
	SETZM	MDG		;MULTIPLY DEFINED GLOBAL COUNT
	SETZM	STADDR		;CLEAR STARTING ADDRESS
IFN REENT,<MOVSI W,1
	MOVEM W,HVAL1
	MOVEM W,HVAL
	MOVEM X,LOWX
	SETZM HILOW
	MOVEM R,LOWR
	HRRZI	W,1	
IFE STANSW,<	SETUWP	W,		;SETUWP UUO.
	TRO	F,NOHI6		;PDP-6 COMES HERE.>
	MOVEM	F,F.C		;PDP-10 COMES HERE.>
IFE L,< IFN STANSW,< TRO F,DMNFLG	;ASSUME /B IS SAID...
	MOVEM   F,F.C		;AND SAVE>>
IFN SAILSW,<MOVE W,[XWD -RELLEN-1,LIBFLS-1]	;SET UP POINTERS
	MOVEM W,LIBPNT#	;IN THE FORM OF AOBJN WORDS
	MOVE W,[XWD -RELLEN-1,PRGFLS-1]
	MOVEM W,PRGPNT#>
IFE L,<	MOVSI	W,254200	;STORE HALT IN JOB41
	MOVEM	W,JOB41(X)	;...>
IFN L,<	MOVE W,JOBREL
	HRRZM W,OLDJR>
IFN SPCHN,<SETZM CHNACB	;USED AS DEV INITED FLAG TOO>
IFN NAMESW,<SETZM	CURNAM>
IFN STANSW,<SETZM OPEN4+1 >	;EXISTENCE OF A DUMP DEVICE IS USED AS A FLAG
IFN FAILSW,<MOVEI W,440000	;SET UP THE SPECIAL BITS OF HEADNUM(ADD+POLISH)
	MOVEM	W,HEADNM
	SETZM	POLSW	;SWITCH SAYS WE ARE DOING POLISH
	MOVEI	W,PDLOV	;ENABLE FOR PDL OV
	MOVEM	W,JOBAPR
	MOVEI	W,200000
	CALLI	W,16
	SETZM LINKTB	;ZERO OUT TABLE OF LINKS
	MOVE W,[XWD LINKTB,LINKTB+1]
	BLT W,LINKTB+20>
IFN DMNSW,<MOVEI W,SYMPAT
	MOVEM W,KORSP>
IFN KUTSW,< IFE STANSW,<SETOM CORSZ>>
IFN KUTSW,< IFN STANSW,<SETZM CORSZ>> ;ASSUME  /K FOR KIDS...
IFN RPGSW,<JRST LD2Q>
LD2:	IFN RPGSW,<MOVSI B,RPGF ;HERE ON ERRORS, TURN OFF RPG
	ANDCAM B,F.C+N	;IN CORE>

;LOADER SCAN FOR FILE NAMES

LD2Q:	MOVSI     B,F.C		;RESTORE ACCUMULATORS
	BLT	B,B
	MOVE	P,PDLPT		;INITIALIZE PUSHDOWN LIST
	SETZM     BUFI2		;CLEAR INPUT BUFFER POINTER
IFE PP,<	SETZM     ILD1		;CLEAR INPUT DEVICE NAME>
IFN PP,<	MOVSI	T,(SIXBIT /DSK/)	;ASSUME DSK.
	MOVEM	T,ILD1
	SETZM	OLDDEV	;TO MAKE IT GO BACK AFTER /D FOR LIBSR>
	SETZM     DTIN		;CLEAR INPUT FILE NAME

LD2B:	RELEAS    1,			;RELEASE BINARY INPUT DEVICE
IFN RPGSW,<	TLNE	N,RPGF		;NOT IF DOING CCL STUFF
	JRST	LD2BA>
IFN SILENT,<
	SKIPE	INBYTP		;DO WE HAVE CHARACTERS WAITING
	JRST	LD2BA		;IFSO, THEN SKIP THEM
>;IFN SILENT
	MOVEI     T,"*"
	IDPB	T,BUFO1		;OUTPUT ASTERISK TO START INPUT
	OUTPUT    3,
LD2BA:	TLZ	F,FULLSW+ASW+ISW+CSW+ESW+SKIPSW+SLIBSW+REWSW
LD2BP:	TLNE	F,LIBSW		;WAS LIBRARY MODE ON?
	TLO	F,SKIPSW	;YES, NORMAL MODE IS SKIPPING

LD2D:	IFN PP,<SETZM	PPN		;DON'T REMEMBER PPN FROM ONE FILE TO NEXT.
LD2DB:	SKIPE	W,OLDDEV		;RESET DEVICE IF NEEDED.
	CAMN	W,ILD1		;IS IT SAME?
	JRST	LD2DA		;YES, FORGET IT.
	TLZ	F,ISW+DSW+FSW+REWSW
	MOVEM	W,ILD1>
LD2DA:	MOVEI     W,0 		;INITIALIZE IDENTIFIER SCAN
	MOVEI     E,6 		;INITIALIZE CHARACTER COUNTER
	MOVE	V,LSTPT		;INITIALIZE BYTE POINTER TO W
	TLZ	F,SSW+DSW+FSW	;LEAVE SWITCH MODE
LD3:	IFN RPGSW,<TLNE N,RPGF	;CHECK RPG FEATURE
	JRST	RPGRD>
IFN SILENT,<SKIPE T,INBYTP
	JRST	BYTRD>
	SOSG	BUFI2		;DECREMENT CHARACTER COUNTER
	INPUT     3,			;FILL TTY BUFFER
	ILDB	T,BUFI1		;LOAD T WITH NEXT CHARACTER
LD3AA:	CAIN	T,175	;OLD ALTMOD
	MOVEI	T,33	;NEW ONE
	CAIL	T,140	;LOWER CASE?
	TRZ	T,40	;CONVERT TO UPPER CASE
	MOVE	Q,T
	HRLM	Q,LIMBO		;SAVE THIS CHAR.
	MOVSS	LIMBO		;AND LAST ONE
	IDIVI     Q,11		;TRANSLATE TO 4 BIT CODE
	LDB	Q,LD8(A)		;LOAD CLASSIFICATION CODE
	CAIGE     Q,4 		;MODIFY CODE IF .GE. 4
	TLNN	F,SSW		;MODIFY CODE IF SWITCH MODE OFF
	ADDI	Q,4 		;MODIFY CLASS. CODE FOR DISPATCH
IFN SYMARG,<CAIL Q,20			;SKIP UNLESS SECOND FORM OF DISPATCH
	JRST	LD3AB			;DIFFERENT DISPATCH>
	HRRZ	A,LD3A(Q)		;LOAD RH DISPATCH ENTRY
	CAIL	Q,10		;SKIP IF CORRECT DISPATCH ENTRY
	HLRZ	A,LD3A-10(Q)	;LOAD LH DISPATCH ENTRY
	JRST	@A			;JUMP TO INDICATED LOCATION

;COMMAND DISPATCH TABLE

LD3A:	XWD	LD3,LD7B		;IGNORED CHAR, BAD CHAR (SWITCH)
	XWD	LD6A,LD6		;</> OR <(>, LETTER (SWITCH)
	XWD	LD5,LD6C		;<:>, DIGIT (SWITCH ARG.)
	XWD	LD5A,LD6D		;<.>, ESCAPE SWITCH MODE <)>
	XWD	LD5C,LD7		;<=> OR <L. ARROW>, BAD CHAR.
	XWD	LD5B,LD4		;<,>, ALPHABETIC CHAR.
	XWD	LD5D,LD4		;<CR.>, NUMERIC CHAR.
	XWD	LD5E1,LD7		;<ALT MODE>, BAD CHAR. <)>
IFN SYMARG,<XWD LD7,LD10		;BAD CHAR,&>

IFN RPGSW,<
RPGRD1:	MOVNI T,5
	ADDM T,CTLIN+2
	AOS	CTLIN+1
RPGRD:	SOSG	CTLIN+2	;CHECK CHARACTER COUNT.
	JRST	[IFN TEMP,<SKIPE TMPFLG	;TMPCOR UUO READ DONE?
		JRST LD2	;YES, JUST LEAVE>
		IN 17,0
		JRST .+1
		STATO 17,740000
		JRST LD2
		JSP A,ERRPT
		SIXBIT /ERROR WHILE READING COMMAND FILE%/
		JRST LD2]
	IBP	CTLIN+1	;ADVANCE POINTER
	MOVE	T,@CTLIN+1	;AND CHECK FOR LINE #
	TRNE	T,1
	JRST	RPGRD1
	LDB	T,CTLIN+1	;GET CHR
	JRST	LD3AA		;PASS IT ON>
IFN SYMARG,<
LD3AB:	ROT	Q,-1			;CUT Q IN HALF
	HRRZ	A,LD3A(Q)		;PULL OFF RIGHT HALF OF TABLE ENTRY
	JUMPGE	Q,@A			;WHICH IS CORRECT FOR EVEN ENTRIES
	HLRZ	A,LD3A(Q)		;BUT USE LEFT HALF FOR ODD ENTRIES
	JRST	@A>

IFN SILENT,<
BYTRD:	SKIPN	INBYTC		; ARE WE FINISHED?
	JRST	DONBYT		; YEP
	ILDB	T,INBYTP	; PICK UP THE CHARACTER FROM INPUT BYTE PTR IN T
	SKIPN	T		; END OF THE STRING?
	JRST	DONBYT		; NULLS TERMINATE THEM TOO
	SOS	INBYTC
	JRST	LD3AA
DONBYT:	SETZM	INBYTP		; FORCE TTY INPUT NEXT TIME
	MOVEI	T,33		; NEW MODEL ALTMODE
	JRST	LD3AA
>

SUBTTL	CHARACTER HANDLING

;ALPHANUMERIC CHARACTER, NORMAL MODE
LD4:	SOJL	E,LD3		;JUMP IF NO SPACE FOR CHAR IN W
	CAIGE	T,141		;WORRY ABOUT LOWER CASE LETTERS
	SUBI	T,40		;CONVERT FROM ASCII TO SIXBIT
	IDPB	T,V 		;DEPOSIT CHAR OF IDENTIFIER IN W
	TLO	F,DSW		;SET IDENTIFIER FLAG
	JRST	LD3 		;RETURN FOR NEXT CHARACTER

;DEVICE IDENTIFIER DELIMITER <:>

LD5:	PUSH	P,W 		;SAVE W
	TLOE	F,CSW		;TEST AND SET COLON FLAG
	PUSHJ     P,LDF		;FORCE LOADING
	POP	P,W 		;RESTORE W
	TLNE	F,ESW		;TEST SYNTAX
	JRST	LD7A		;ERROR, MISSING COMMA ASSUMED
	JUMPE     W,LD2D		;JUMP IF NULL DEVICE IDENTIFIER
	MOVEM     W,ILD1		;STORE DEVICE IDENTIFIER
IFN PP,<MOVEM	W,OLDDEV	;WE HAVE A NEW ONE, DO IGNORE OLD.>
	TLZ	F,ISW+DSW+FSW+REWSW	;CLEAR OLD DEVICE FLAGS
	JRST	LD2D		;RETURN FOR NEXT IDENTIFIER

;FILE NAME EXTENSION IDENTIFIER DELIMITER <.>
LD5A:	IFN SYMARG,<
	TRNE	F,ARGFL		;IS "." SPECIAL
	JRST	LD4		;YES,RADIX-50>
	TLOE	F,ESW		;TEST AND SET EXTENSION FLAG
	JRST	LD7A		;ERROR, TOO MANY PERIODS
	TLZE	F,CSW+DSW	;SKIP IF NULL IDENT AND NO COLON
	MOVEM     W,DTIN	;STORE FILE IDENTIFIER
	JRST	LD2D		;RETURN FOR NEXT IDENTIFIER

;INPUT SPECIFICATION DELIMITER <,>
LD5B:
IFN PP,<TLZE	N,PPCSW			;READING PP #?
	JRST	[
IFE STANSW,<	HRLM	D,PPN		;STORE PROJ #
		JRST	LD6A1		];GET PROG #>
IFN STANSW,<	PUSHJ	P,RJUST		;RIGHT JUSTIFY W
		HRLM	W,PPN		;STORE PROJ NAME
		JRST	LD2DB		];GET PROG NAME>
	PUSHJ	P,RBRA		;CHECK FOR MISSING RBRA>
	SETOM	LIMBO		;USED TO INDICATE COMMA SEEN
	TLZN	F,FSW		;SKIP IF PREV. FORCED LOADING
	PUSHJ     P,FSCN2		;LOAD (FSW NOT SET)
	JRST	LD2BP		;RETURN FOR NEXT IDENTIFIER

LD5B1:	TLNE	F,ESW		;TEST EXTENSION FLAG
	JRST	LDDT3		;EXPLICIT EXTENSION IDENTIFIER
	TLZN	F,CSW+DSW		;SKIP IF IDENT. OR COLON
	POPJ	P,
	MOVEM     W,DTIN		;STORE FILE IDENTIFIER
	JRST	LDDT2		;ASSUME <.REL> IN DEFAULT CASE

;OUTPUT SPECIFICATION DELIMITER <=> OR <LEFT ARROW>
;OR PROJ-PROG # BRACKETS <[> AND <]>, OR '^'

LD5C:
IFN SPCHN!STANSW,<CAIN T,"="	;DO A /= AS SWITCH
	TLNN F,SSW
	SKIPA
	JRST LD6>
IFN RPGSW,<CAIN T,"@"	;CHECK FOR * COMMAND.
	JRST	RPGS1>
IFN PP,<CAIN	T,"["			;PROJ-PROG #?
	JRST	[TLO	N,PPSW+PPCSW	;SET FLAGS
		MOVEM	W,PPNW		;SAVE W
		MOVEM	E,PPNE		;SAVE E
		MOVEM	V,PPNV		;SAVE V
IFE STANSW,<	JRST	LD6A2]>		;READ NUMBERS AS SWITCHES
IFN STANSW,<	JRST	LD2DB]>
	CAIN	T,"]"			;END OF PP #?
	JRST	[PUSHJ	P,RBRA		;PROCESS RIGHT BRACKET
		JRST	LD3]		;READ NEXT IDENT>
IFN STANSW,< CAIE T,"^"			;WRITE DMP FILE?
	     TDZA T,T			;NO.  MUST BE "="
	     MOVEI T,SAVFIL-DTOUT >	;YES. SET OFFSET TO FILENAME BLOCK
IFE STANSW,< SETZ T,>
	TLOE	F,ASW			;TEST AND SET LEFT ARROW FLAG
	JRST	LD7A			;ERROR, MISPLACED LEFT ARROW
	PUSHJ     P,LD5B1		;STORE IDENTIFIER
	TLZN	F,ESW			;TEST EXTENSION FLAG
IFN STANSW,< JRST [MOVSI W,'MAP' 	;ASSUME <.MAP> IN DEFAULT CASE
		   JUMPE T,.+1
		   MOVSI W,'DMP'	;USE DIFFERENT EXT. FOR DUMP FILES
		   JRST .+1] >
IFE STANSW,< MOVSI     W,'MAP' >	;ASSUME <.MAP> IN DEFAULT CASE
	MOVEM     W,DTOUT1(T)		;STORE FILE EXTENSION IDENTIFIER
	MOVE	W,DTIN			;LOAD INPUT FILE IDENTIFIER
	MOVEM     W,DTOUT(T)		;USE AS OUTPUT FILE IDENTIFIER
IFN SPCHN,<MOVEM W,CHNENT	;AND FOR SPECAIL CHAINING>
IFN PP,<MOVE	W,PPN			;PROJ-PROG #
	MOVEM	W,DTOUT+3(T)		;...>
	MOVE	W,ILD1			;LOAD INPUT DEVICE IDENTIFIER
IFN STANSW,< JUMPN T,LD5S >		;DMP FILE USES DIFFERENT CHANNEL
	MOVEM	W,LD5C1			;USE AS OUTPUT DEVICE IDENTIFIER
IFN PP,<SKIPE	W,OLDDEV		;RESTORE OLD
	MOVEM	W,ILD1>
;INITIALIZE AUXILIARY OUTPUT DEVICE
	TRZ	F,TTYFL
	TLZE	N,AUXSWI+AUXSWE		;FLUSH CURRENT DEVICE
	RELEASE	2,			;...
	DEVCHR	W,			;IS DEVICE A TTY?
	TLNE	W,10			;...
	JRST	[TRO	F,TTYFL		;TTY IS AUX. DEV.
		JRST	LD2D]		;YES, SKIP INIT
	OPEN	2,OPEN2			;KEEP IT PURE
	JRST	ILD5A
	TLNE	F,REWSW			;REWIND REQUESTED?
	UTPCLR	2,			;DECTAPE REWIND
	TLZE	F,REWSW			;SKIP IF NO REWIND REQUESTED
	MTAPE	2,1			;REWIND THE AUX DEV
	MOVEI	E,AUX			;SET BUFFER ORIGIN
	MOVEM     E,JOBFF
	OUTBUF	2,1			;INITIALIZE SINGLE BUFFER
	TLO	N,AUXSWI			;SET INITIALIZED FLAG
IFN LNSSW,<EXCH	E,JOBFF
	SUBI	E,AUX
	IDIV	C,E
	OUTBUF	2,(C)>
	JRST	LD2D			;RETURN TO CONTINUE SCAN

IFN STANSW,<
LD5S:	CAMN W,[SIXBIT/SYS/]		;DON'T WRITE DUMP FILES ON SYS: !!!
	MOVSI W,'DSK'			;(USE DSK: INSTEAD)
	MOVEM W,OPEN4+1
IFN PP,<SKIPE	W,OLDDEV		;RESTORE OLD DEVICE
	MOVEM	W,ILD1>
	OPEN	4,OPEN4			;KEEP IT PURE
	JRST	ILD5A
	TLNE	F,REWSW			;REWIND REQUESTED?
	UTPCLR	4,			;DECTAPE REWIND
	TLZE	F,REWSW			;SKIP IF NO REWIND REQUESTED
	MTAPE	4,1			;REWIND THE AUX DEV
	ENTER 4,SAVFIL
	JRST LD5SFL
	JRST LD2D
LD5SFL:	ERROR ,</ENTER FAILED ON DUMP FILE@/>
	JRST LD2 >

;RIGHT SQUARE BRACKET (PROJ-PROG NUMBERS)
IFN PP,<
RBRA:	TLZN	N,PPSW		;READING PP #?
	POPJ	P,		;NOPE, RETURN
	TLZE	N,PPCSW		;COMMA SEEN?
	JRST	LD7A		;NOPE, INDICATE ERROR
IFE STANSW,<HRRM	D,PPN		;STASH PROG NUMBER
		TLZ	F,SSW	;AND TURN OFF SWITCH MODE>
IFN STANSW,<PUSHJ	P,RJUST		;RIGHT JUSTIFY W
	HRRM	W,PPN		;STASH PROG NAME>
	MOVE	W,PPNW		;PICKUP OLD IDENT
	MOVE	E,PPNE		;RESTORE CHAR COUNT
	MOVE	V,PPNV		;RESTORE BYTE PNTR
	POPJ	P,		;TRA 1,4

;RIGHT JUSTIFY W

IFN STANSW,<
RJUST:	JUMPE	W,LD7A		;NOTHING TO RIGHT JUSTIFY
	TRNE	W,77		;IS W RJUSTED YET?
	POPJ	P,		;YES, TRA 1,4
	LSH	W,-6		;NOPE, TRY AGAIN
	JRST	.-3		;...>>

IFN SYMARG,<
;& SELECTS A SYMBOL RATHER THAN ANUMBER FOR A SWITCH ARGUMENT
;& MUST ALSO FOLLOW THW SYMBOL; THE FORM IS /&SYMBOL&SWITHCH
LD10:	TRC	F,ARGFL		;SET OR CLEAR SPECIAL CHARS.
	TLCE	F,SSW		;IF IN SWITCH MODE, EXIT TO GET IDENTIFIER
	JRST	LD10B
	PUSHJ	P,ASCR50	;IF NOT, REENTER IT, CONVERT IDENTIFIER TO R50
	PUSHJ	P,SDEF		;AND SEE IF IT EXISTS
	JRST	LD10A		;YES IT DOES
	PUSHJ	P,PRQ		;NO, COMPLAIN. OUTPUT ?
	PUSHJ	P,SPACE		;FOLLOWED BY A SPACE
	PUSHJ	P,PRNAME	;FOLLOWED BY THIS SYMBOL
	ERROR	0,</ DOESN'T EXIST@/>
	JRST	LD2
LD10A:	MOVE	D,2(A)		;SET D=VALUE OF SYMBOL AS NUMERIC ARG
	TLZ	F,DSW!FSW
	MOVEI	E,6		;INITIALIZE NEW IDENTIFIER SCAN
	MOVE	V,LSTPT		;(W IS ALREADY 0)
	JRST	LD3		;NOW EAT SWITCH AND CONTINUE PROCESSING COMMAND
LD10B:	PUSHJ	P,FSCN1		;FORCE SCAN TO COMPLETION TO MAKE SURE FILE IS LOADED
	JRST	LD2DA>

IFN SYMARG,<
;CONVERT SYMBOL IN W TO RADIX-50 IN C
;ALSO USES A
ASCR50:	MOVEI	A,0
R50A:	MOVEI	C,0
	ROTC	W,6		;C IS NEXT SIXBIT CHAR
	CAIGE	C,20
	JRST	R50B		;UNDER 20, MAY BE ., $, OR %
	CAILE	C,31
	JRST	R50C		;OVER 31
	SUBI	C,20-1		;IS NUMBER
R50D:	IMULI	A,50
	ADD	A,C
	JUMPN	W,R50A		;LOOP FOR ALL CHARS
	MOVE	C,A		;WIND UP WITH CHAR IN C
	TLO	C,040000	;MAKE IT GLOBAL DEFINITION
	POPJ	P,
R50B:	JUMPE	C,R50D		;OK IF SPACE
	CAIE	C,16		;TEST IF .
	JRST	.+3		;NO
	MOVEI	C,45		;YES
	JRST	R50D
	CAIE	C,4		;SKIP IF $
R50E:	MOVEI	C,5		;ASSUME % IF NOTHING ELSE
	ADDI	C,42
	JRST	R50D
R50C:	CAIGE	C,41
	JRST	R50E		;BETWEEN 31 AND 41
	CAILE	C,72
	JRST	R50E		;OVER 72
	SUBI	C,41-13		;IS LETTER
	JRST	R50D>

;DEFINE PUTS A SYMBOL IN THE UNDEFINED SYMBOL TABLE
;SO LOADER CAN SCAN LIBRARY AND LOAD PROGRAMS BEFORE THEY ARE REQUESTED
;THE FORM IS /&SYMBOL# WHERE SYMBOL IS CONVERTED TO RADIX-50
IFN SYMARG,<
DEFINE:	PUSHJ	P,ASCR50	;CONVRT TO R-50
	MOVEI	W,-2(S)		;WHERE SYMBOL WILL GO
	CAIG	W,(H)		;ENOUGH ROOM
IFN EXPAND,<PUSHJ P,[PUSHJ P,XPAND
		TLOA	F,FULLSW
		JRST	POPJM3
		POPJ	P,]>
IFE EXPAND,<TLO	F,FULLSW>
	SUB	S,SE3		;ADJUST POINTER
	MOVEM	C,1(S)		;R-50 SYMBOL
	SETZM	2(S)		;VALUE
	TLZ	F,DSW!SSW	;TURN OFF SWITCHES
	JRST	LD2D		;CONTINUE TO SCAN
>

SUBTTL	TERMINATION
;LINE TERMINATION <CARRIAGE RETURN>

LD5D:
IFN PP,<PUSHJ	P,RBRA		;CHECK FOR UNTERMINATED PP #>
	SKIPGE	LIMBO		;WAS LAST CHAR. BEFORE CR A COMMA?
	TLO	F,DSW		;YES ,SO LOAD ONE MORE FILE
	PUSHJ   P,FSCN		;FORCE SCAN TO COMPLETION
	JRST	LD2B		;RETURN FOR NEXT LINE

;TERMINATE LOADING <ALT MODE>

LD5E:	JUMPE	D,LD5E1		;ENTER FROM G COMMAND
	TLO	N,ISAFLG	;AND IGNORE ANY STARTING ADDRESS TO COME
	HRRZM	D,STADDR	;USE NUMERIC STARTING ADDRESS
LD5E1:
IFE SILENT,<
	PUSHJ	P,CRLF		;START A NEW LINE
>;IFE SILENT
IFN RPGSW,<RELEASE 17,0		;RELEASE COMMAND DEVICE>
	PUSHJ	P,SASYM		;SETUP JOBSA,JOBFF,JOBSYM,JOBUSY
	MOVE	W,[SIXBIT ?LOADER?]	;FINAL MESSAGE
	PUSHJ P,BLTSET		;SETUP FOR FINAL BLT
IFN NAMESW,<HRRZ	W,HISTRT	;IN CASE NO NAME SET, USE FIRST LOADED
	MOVE	W,-1(W)
	SKIPN	CURNAM
	PUSHJ	P,LDNAM
	SKIPE	W,CURNAM
	CAMN	W,[SIXBIT /MAIN/]	;FORTRAN MAIN PROG, OR MACRO NO TITLE
	SKIPE	W,PRGNAM	;USE BINARY FILE NAME IN EITHER CASE
	MOVEM W,CURNAM
	SETNAM	W,			;SETNAME>
IFN L,<	MOVE W,LSPREL	;BY TVR AFTER DBA AFTER JRA FOR UCI
	RELEASE 1,0	;Release .REL file channel (and avoid wonderful
			;timing race whereby LISP gets clobbered by system
			;reading in another buffer between the time the LOADER
			;returns to LISP and LISP does a RESET.  TVR Apr76
	JRST @LSPXIT>
IFE L,<		;NONE OF THIS NEEDED FOR LISP
IFN STANSW,< SKIPE OPEN4+1	;DUMP FILE TO BE MADE?
	     PUSHJ P,WRTSAV	;YES >
	RELEASE	2,		;RELEASE AUX. DEV.
	RELEASE 1,0	;INPUT DEVICE
	RELEASE 3,0	;TTY
IFN SPCHN,<RELEASE 4,0	;SPECIAL CHAINING CHANEL>
IFN PURESW,<
	MOVE	V,[XWD HHIGO,HIGO]
	BLT	V,HIGONE	;MOVE DOWN CODE TO EXIT>
	TLNN N,EXEQSW	;DO WE WANT TO START
	JRST LD5E3
IFN RPGSW,<TLNN N,RPGF	;IF IN RPG MODE
	JRST LD5E2
	HRRZ C,JOBERR	;CHECK FOR ERRORS
	JUMPE C,LD5E2	;NONE
EXDLTD:	TTCALL 3,[ASCIZ /?EXECUTION DELETED
/]
	JRST LD5E3>
LD5E2:	HRRZ W,JOBSA(X)
	TLNE N,DDSW	;SHOULD WE START DDT??
	HRRZ W,JOBDDT(X)
IFN RPGSW,<	TLNE	N,RPGF	;IF IN RPG MODE
	JUMPE	W,[TTCALL 3,[ASCIZ /?NO STARTING ADDRESS
/]
		JRST	EXDLTD]>
	JUMPE	W,LD5E3	;ANYTHING THERE?
	TLOA W,(JRST)	;SET UP A JRST
LD5E3:	SKIPA W,CALLEX	;NO OR NO EXECUTE, SET CALLI 12
	TTCALL 3,[ASCIZ /EXECUTION
/]
IFN LDAC,<	HRLZ P,BOTACS	;SET UP FOR ACBLT
	MOVEM W,JOBBLT+1(X)	;SET JOBBLT
	MOVE W,[BLT P,P]
	MOVEM W,JOBBLT(X)>

	MOVSI LSTAC,LODACS	;SET UP TO BLT BLT CODE INTO ACS
	BLT LSTAC,LSTAC

IFN KUTSW,<SKIPGE E,CORSZ	;DO WE WANT CORE ADJUST
	MOVE CORAC,JFCLAC	;NO, CLEAR COREUUO>

IFE LDAC,<MOVE LSTAC,W		;SET END CONDITION>

IFN REENT,<
	MOVSI	V,LD		;DOES IT HAVE HISEG
	JUMPG	V,HINOGO	;NO,DON'T DO CORE UUO
	MOVSI	V,1		;SET HISEG CORE NON-ZERO
	JRST	HIGO		;AND GO>
IFE REENT,<JRST 0>

LODACS:	PHASE 0
	BLT Q,(A)	;BLT CODE DOWN
IFN KUTSW,<CORAC:	CORE E,	;CUT BACK CORE
JFCLAC:	JFCL	;SHOULD NEVER HAVE AN ERROR SINCE REDUCING CORE>
LSTAC: IFN LDAC,<JRST JOBBLT>
IFE LDAC,<EXIT>
DEPHASE
> ;;;;END OF IFE L AT BEGINNING OF THIS PAGE

SUBTTL	PRINT FINAL MESSAGE
; SET UP BLT AC'S, SETDDT, RELEAS

BLTSET:	IFN RPGSW,<IFE K,<
	JUMPE	W,.+4	;NO MESSAGE FROM CHAIN IN CCL@>>
IFE SILENT,<
	PUSHJ P,FCRLF	;A RETURN
	PUSHJ P,PWORD	;AND CHAIN OR LOADER
	PUSHJ P,SPACE
>;IFN SILENT
IFN FAILSW,<MOVSI Q,-20	;FINISH UP LINK STUFF
FREND:	HLRZ V,LINKTB+1(Q)
	JUMPE V,NOEND
	HRRZ A,LINKTB+1(Q)
IFN REENT,<CAMGE V,HVAL1
	SKIPA X,LOWX
	MOVE X,HIGHX>
IFN L,<CAML V,RINITL>
	HRRM A,@X	;PUT END OF LINK CHAIN IN PROPER PLACE
NOEND:	AOBJN Q,FREND
IFN REENT,<MOVE X,LOWX	;RESET THINGS>>
IFN KUTSW,<SKIPGE C,CORSZ	;NEG MEANS DO NOT KUT BACK CORE
	JRST NOCUT
	JUMPE C,MINCUT	;0 IS KUT TO MIN. POSSIBLE
	LSH C,12	;GET AS A NUMBER OF WORDS
	SUBI C,1
	CAMG C,JOBREL	;DO WE NEED MORE THAN WE HAVE??
	JRST TRYSML	;NO, SEE IF NUMBER REQUESTED IS TOO SMALL
	MOVEI Q,0
	CORE Q,
	JFCL		;WE JUST WANT TO KNOW HOW MUCH
	HRRZS Q
	CAMGE Q,CORSZ
	JRST CORERR
	JRST NOCUT1	;SET FOR DO NOT CHANGE SIZE
TRYSML:	CAIG C,(R)	;IS DESIRED AMOUNT BIGGER THAN NEEDED
MINCUT:	HRRZ C,R	;GET MIN AMOUNT
	IORI C,1777	;CONVERT TO A 1K MULTIPLE
IFN DMNSW,<	TRNN F,DMNFLG	;DID WE MOVE SYMBOLS??
	SKIPN JOBDDT(X)	;IF NOT IS DDT THERE??
	JRST	.+2>
IFE DMNSW,<SKIPE JOBDDT(X)	;IF NO SYMBOL MOVING JUST CHECK DDT>
	JRST NOCUT	;DO NOT CUT IF SYMBOLS AT TOP AND DDT
NOCUT1:	MOVEM C,JOBREL(X)	;SAVE FOR CORE UUO
	MOVEM C,CORSZ	;SAVE AWAY FOR LATER
	JRST	.+2
NOCUT:	SETOM CORSZ	;SET FOR NO CUT  BACK>
IFN RPGSW,<IFE K,<
	JUMPE	W,NOMAX	;NO MESSAGE IF CHAIN IN CCL@>>
IFN L,<HRRZ Q,JOBREL
	SUB Q,OLDJR	;PROPER SIZE>
IFE SILENT,<
IFE L,<HRRZ Q,JOBREL(X)>
IFE STANSW,<LSH Q,-12	;GET CORE SIZE TO PRINT>
IFN STANSW,<LSH Q,-11	;GET CORE SIZE TO PRINT IN PAGES!>
	ADDI Q,1
	PUSHJ P,RCNUM
IFN REENT,<MOVE Q,HVAL
	SUB Q,HVAL1
	HRRZS Q
	JUMPE	Q,NOHY		;NO HIGH SEGMENT
	MOVEI	T,"+"-40	;THERE IS A HISEG
	PUSHJ	P,TYPE
IFE STANSW,<LSH Q,-12	;GET CORE SIZE TO PRINT>
IFN STANSW,<LSH Q,-11	;GET CORE SIZE TO PRINT IN PAGES!>
	ADDI	Q,1
	PUSHJ	P,RCNUM
NOHY:>>
IFE STANSW,<MOVE W,[SIXBIT /K CORE/]>
IFN STANSW,<MOVE W,[SIXBIT / PAGES/]>
IFE SILENT,<
	PUSHJ P,PWORD
	PUSHJ P,CRLF
>
IFE L,<
IFN RPGSW,<TLNE N,RPGF	
	JRST NOMAX	;DO NOT PRINT EXTRA JUNK IN RPG MODE>
	MOVE Q,JOBREL
	LSH Q,-12
	ADDI Q,1
	PUSHJ P,RCNUM	;PRINT MAX LOW CORE SIZE
IFN REENT,<	SKIPE Q,JOBHRL	;GET SIZE OF HIGH SEGMENT
	PUSHJ P,[MOVEI Q,400001(Q) ;CLEAR HIGH ORDER BIT
		MOVEI T,"+"-40	;PRINT A HIGH CORE PART
		PUSHJ P,TYPE
		LSH Q,-12
		JRST RCNUM]>
	MOVE W,[SIXBIT /K MAX/]
	PUSHJ P,PWORD
IFN DMNSW,<TRNN F,DMNFLG>
	SKIPN JOBDDT(X)
	SKIPA Q,JOBREL(X)
	MOVEI Q,1(S)	;FIND THE AMOUNT OF SPACE LEFT OVER
	SUB Q,JOBFF(X)
	PUSHJ P,RCNUM
	MOVE W,[SIXBIT / WORDS/]
	PUSHJ P,PWORD
	MOVE W,[SIXBIT / FREE/]
	PUSHJ P,PWORD
	PUSHJ P,CRLF	>
NOMAX:
IFE L,<	MOVE W,JOBDDT(X)	>
IFN L,<	SKIPN W,JOBDDT	;Don't overwrite old setting of JOBDDT!
	MOVE W,LSPDDT >	;JOBDDT has to be kept in a special place for LISP - TVR
	SETDDT W,
IFE TEN30,<HRLI Q,20(X)	;SET UP BLT FOR CODE
	HRRI Q,20>
IFN TEN30,<HRLI Q,JOBDDT(X)
	HRRI Q,JOBDDT>
	HRRZ A,R
	POPJ P,		;WE HAVE SET R UP BY CLEVER CODE IN SASYM

IFN KUTSW,<
CORERR:	TTCALL 3,[ASCIZ /?NOT ENOUGH CORE
/]
	EXIT>

SUBTTL	SET UP JOBDAT

SASYM:	TLNN	F,NSW
	PUSHJ	P,LIBF		;SEARCH LIBRARY IF REQUIRED
	PUSHJ	P,FSCN		;FORCE END OF SCAN

IFN ALGSW,<	MOVE	C,[RADIX50 44,%OWN]
		MOVE	W,%OWN		;GET VALUE
		TRNE	F,ALGFL		;IF ALGOL PROG LOADED
		PUSHJ	P,SYMPT		;DEFINE %OWN>

IFN RPGSW,<	HLRE	A,S
		MOVNS	 A
		LSH	A,-1
		ADD	A,JOBERR
		HRRM	A,JOBERR>

	PUSHJ	P,PMS1		;PRINT UNDEFS
	HRRZ	A,H		;DON'T CLOBBER H IF STILL INSERTING SYMBOLS
	SUBI	A,(X)		;HIGHEST LOC LOADED INCLUDES LOC STMTS
	CAILE	A,(R)		;CHECK AGAINST R
	HRR	R,A		;AND USE LARGER

IFE L,<	HRRZ	A,STADDR	;GET STARTING ADDRESS
	HRRM	A,JOBSA(X)	;STORE STARTING ADDRESS
	HRRZM	R,JOBFF(X)	;AND CURRENT END OF PROG
	HRLM	R,JOBSA(X)	>;IFE L


Comment $  By REG, intended for his future amusement

At this point, the core image of the loader looks as follows:

------------------------------
| Loader code, ddt           |
| and symbols, if you're     |
| so lucky to be debugging   |
------------------------------   LOWX[ 11,,origin of lower in loader
| Low segment code that's    |	 R [ 12,,highest address loaded in lower
| been loaded.               |
|                            |
------------------------------
| some free space            |
------------------------------   B [ -count,,first symbol address-1
| symbol table (old style)   |   (note the count is not the symbol table size!)
|                            |	 (but, B turns into an IOWD before calling symsrt)
|                            |
|                            |   HISTRT [last loc in symbol table, addr of remap
------------------------------   HIGHX [ 11,,origin of upper in loader+400000
| High segment code          |   HVAL [ 12,,highest address in upper
|                            |   HVAL1 [ 400000 = upper segment origin
------------------------------
| some free space            |
------------------------------   JOBREL


After calling SYMSRT the core image looks like:


------------------------------
| Loader code, ddt           |
| and symbols, if you're     |
| so lucky to be debugging   |
------------------------------   LOWX[ 11,,origin of lower in loader
| Low segment code that's    |	 R [ 12,,highest address loaded in lower
| been loaded.               |
|                            |
------------------------------
| some free space            |
|                            |
|                            |
|                            |
------------------------------   HIGHX [ 11,,origin of upper in loader+400000
| High segment code          |   HVAL [ 12,,highest address in upper
|                            |
------------------------------
| some free space            |
------------------------------   B [ IOWD for new symbol table
| symbol table (new style)   |   S [ 0,,address of symbols-1
|                            |
|                            |
------------------------------   JOBREL

If we're loading symbols into the upper, blt the symbols down adjacent to the top
of the code loaded in the upper.   If we're loading symbols in the lower, and
there is an upper, we must make sure there's room between the lower and upper
for the new symbols to fit into.   (If there's no room, BLT the upper and the
symbols up (a multiple of 1K) to make room for the symbols.)  Then BLT the
symbols into the hole and cut back core size to flush the copy of the symbols
that are above the upper.

$

IFN DMNSW,<	MOVE	C,[RADIX50 44,PAT..]	;MARK PATCH SPACE FOR RPG
		MOVEI	W,(R)
		SKIPE	JOBDDT(X)		;BUT ONLY IF DDT LOADED
		PUSHJ	P,SYMPT
IFN REENT,<	TRNE	F,HISYM			;SHOULD SYMBOLS GO IN HISEG?
		JRST	BLTSYM			;YES>
>;IFN DMNSW

IFN DMNSW!LDAC,<				;ONLY ASSEMBLE IF EITHER SET

IFE LDAC,<	TRNN	F,DMNFLG		;GET EXTRA  SPACE IF SYMBOLS
		JRST	NODDT			;MOVED OR IF LOADING ACS>;IFE LDAC

IFE DMNSW,<	MOVEI	A,20			;FOR LOADING ACS>

IFN DMNSW,<	MOVE	A,KORSP
IFN LDAC,<	TRNN	F,DMNFLG		;ONLY 20 IF SYMBOLS NOT MOVED
		MOVEI	A,20			>;IFN LDAC
>;IFN DMNSW

		ADDI	A,(R)		;GET ACTUAL PLACE TO PUT END OF SPACE
		ADDI	A,(X)
		CAIL	A,(S)		;DO NOT OVERWRITE SYMBOLS
IFE EXPAND,<	PUSHJ	P,MORCOR	>
IFN EXPAND,<	JRST	[PUSHJ P,XPAND
			PUSHJ P,MORCOR
			JRST .-1]	>;IFN EXPAND

IFN LDAC,<	HRRM	R,BOTACS	;SAVE BOTTOM OF WHERE WE PUT ACS
		HRRZ	A,R
		ADDI	A,(X)
		HRL	A,X		;SET UP BLT FROM (X) TO R(X)
		MOVEI	Q,17(A)
		BLT	A,(Q)>		;IFN LDAC
>;IFN DMNSW!LDAC

IFN DMNSW,<	TRNN	F,DMNFLG	;NOW THE CODE TO MOVE SYMBOLS
		JRST	NODDT
		HLLZ	A,GLBEND	;INCLUDE LOCALS, ETC. IN SYMBOL TABLE
		ADD	B,A

IFN SORTSY,<	PUSH	P,[0]		;FLAG NOT TO SHRINK CORE AFTER SYMSORT
		SKIPN	DOSORT		;NEW FORMAT SYMBOL TABLE?
		JRST	NOSRTY		;NO
		PUSHJ	P,SYMSRT	;SORT SYMBOLS.
		HRRZ	Q,HVAL		;JOBREL OF HIGH SEGMENT
		SUB	Q,HVAL1		;MINUS HIGH SEGMENT ORIGIN
		HRRZ	Q,Q
		JUMPE	Q,NOSRTY	;JUMP IF THERE'S NO HIGH SEGMENT TO WORRY
		HRRZM	B,0(P)		;STORE FLAG FOR SHRINKING CORE.
		HLLZ	Q,S		;COMPUTE LENGTH OF SYMBOL TABLE
		ADD	Q,B
		HLROS	Q
		MOVNS	Q		;Q_POSITIVE WORD COUNT OF ALL SYMBOLS
		HRRZ	A,R		;HIGHEST ADDRESS LOADED IN LOWER
		ADD	A,KORSP		;PLUS PATCH SPACE
		ADDI	A,(X)		;ABS ADDRESS IN LOADER'S CORE IMAGE.
		ADDI	Q,(A)		;Q_1+LAST ADDR. NEEDED FOR SYMBOLS.

		HRRZ	W,HIGHX		;RELOCATION OF HIGH SEGMENT
		SUB	W,HVAL1		;MINUS ADDR OF ORIGIN = ABS ADDRESS OF HI
		SUBI	Q,(W)		;AMOUNT OF EXTRA ROOM NEEDED
		JUMPLE	Q,NOSRTY	;JUMP IF NO EXTRA ROOM IS NEEDED.
		TRO	Q,1777		;ROUND UP TO A 1K BOUNDARY
		ADDI	Q,1
		MOVE	A,Q		;REMEMBER RELOCATION AMOUNT.
		ADD	Q,JOBREL
		CORE	Q,
		JRST	MORCOR		;LOSE.
		PUSH	P,A		;SAVE RELOCATION AMOUNT.

		MOVE	Q,JOBREL
		SUBI	Q,1777		;FIRST DESTINATION ADDRESS
SRTBL1:		MOVN	A,(P)		;-AMOUNT ADDED
		ADDI	A,(Q)		;SOURCE ADDRESS
		CAIGE	A,(W)		;CONTINUE AS LONG AS SOURCE ADDRESS IS HIGH
		JRST	SRTBL2		;DONE WITH BLTS.
		MOVSI	A,(A)
		HRRI	A,(Q)
		BLT	A,1777(Q)	;MOVE 1K UPWARDS
		SUBI	Q,2000		;DECREMENT DESTINATION ADDRESS
		JRST	SRTBL1		;SEE ABOUT MOVING ANOTHER 1K

SRTBL2:		POP	P,A		;AMOUNT WE MOVED THINGS
		ADD	B,A
		ADD	S,A		;ANNOUNCE WE MOVED THE SYMBOLS
		ADDM	A,HIGHX		;ALSO, WE MOVED THE UPPER.
		ADDM	A,HISTRT	;NEW ADDR FOR REMAP
		ADDM	A,(P)		;AND WE MOVED THE SHRINK BOUNDARY

>;IFN SORTSY


NOSRTY:	HRRZ	A,R		;HIGHEST ADDRESS LOADED IN LOWER
	ADD	A,KORSP		;PLUS PATCH SPACE
	MOVE	W,A		;SAVE RELATIVE DESTINATION
	ADDI	A,(X)		;DESTINATION OF BLT.
	HLLZ	Q,S		;COMPUTE LENGTH OF SYMBOL TABLE
	ADD	Q,B
	HLROS	Q
	MOVNS	Q		;POSITIVE WORD COUNT OF ALL SYMBOLS
	ADDI	Q,-1(A)		;GET PLACE TO STOP BLT
	HRLI	A,1(S)		;SOURCE OF BLT
	SUBI	W,1(S)		;DEST-SOURCE = AMT BY WHICH TO CHANGE S AND B
	BLT	A,(Q)		;MOVE SYMBOL TABLE

IFN SORTSY,<	POP	P,A
		JUMPE	A,NOSRTZ
		CORE	A,	;SHRINK CORE.  REMOVE EXTRA COPY OF SYMBOL TABLE
		JFCL		;THIS SHOULDN'T HAPPEN.
		MOVEI	A,1(Q)	;THIS THE FIRST ADDRESS PAST BLT
		CAMLE	A,HISTRT	;IS IT BELOW UPPER?
		JRST	NOSRTZ		;NO. (MUST BE RIGHT AT BOUNDARY)
		SETZM	1(Q)
		CAML	A,HISTRT	;IS IT BELOW WORD BELOW UPPER?
		JRST	NOSRTZ		;NO.  DON'T BLT
		MOVSI	A,1(Q)		;ZERO BETWEEN SYMBOLS AND HIGH SEGMENT
		HRRI	A,2(Q)		;
		BLT	A,@HISTRT
NOSRTZ:
>;IFN SORTSY

	ADD	S,W
	ADD	B,W		;CORRECT S AND B FOR MOVE (RELOCATED TO USER SPACE)
	HRRI	R,1(Q)		;SET R TO POINT TO END OF SYMBOLS
	SUBI	R,(X)
	SKIPN	JOBDDT(X)	;SKIP IF DDT IS LOADED
	JRST	NODDT		;NO DDT.  DO LEAVE SYMBOLS.
	HRRM	R,JOBFF(X)
	HRLM	R,JOBSA(X)	;AND SAVE AWAY NEW JOBFF
IFN LDAC,<	SKIPA		>;SKIP THE ADD TO R
NODDT:
>;IFN DMNSW

IFN LDAC,<	ADDI R,20	>;MAKE SURE R IS CORRECT FOR BLT

	MOVE	A,B
	ADDI	A,1		;SET UP JOBSYM, JOBUSY
IFE L,<	MOVEM	A,JOBSYM(X)>
IFN L,<	MOVEM	A,JOBSYM>
	MOVE	A,S
	ADDI	A,1

IFN L,<	MOVEM	A,JOBUSY	>

IFE L,<	MOVEM	A,JOBUSY(X)
	MOVE	A,HISTRT	;TAKE POSSIBLE REMAP INTO ACCOUNT
	MOVEM	A,JOBREL(X)	;SET UP FOR IMEDIATE EXECUTION
IFN REENT,<	SKIPE	A,HILOW	;SET UP TOP LOC OF LOW CORE EXCLUDING BLOCKS
		SUBI	A,1(X)	;IF NON-ZERO THEN IT NEEDS RELOCATION
		HRLM	A,JOBCOR(X)
		TRNN	F,SEENHI
		POPJ	P,
		HRRZ	A,HVAL
		HRRZM	A,JOBHRL(X)
IFE STANSW,<	SUB	A,HVAL1		;DON'T PUT SHIT IN LH AT STANFORD
		HRLM	A,JOBHRL(X)>	;IFE STANSW
>;IFN REENT
>;IFE L
	POPJ	P,

SUBTTL	BLT SYMBOL TABLE INTO HIGH SEGMENT
IFN DMNSW&REENT,<
BLTSYM:	MOVE	Q,HVAL		;GET ORIGIN OF HISEG
	CAMN	Q,HVAL1		;HAS IT CHANGED?
	JRST	NOBLT		;NO
	HLLZ	A,GLBEND	;INCLUDE LOCALS, ETC. IN SYMBOL TABLE
	ADD	B,A
IFN SORTSY,<	SKIPE	DOSORT
		PUSHJ	P,SYMSRT	>
	HLLZ	Q,S		;COMPUTE LENGTH OF SYMBOL TABLE
	HLR	S,S		;PUT NEG COUNT IN BOTH HALVES
	JUMPE	S,.+2		;SKIP IF S IS ZERO
	HRLI	S,-1(S)		;SUB 1 FROM LEFT TO FIX CARRY PROBLEM
	ADD	Q,B		;IOWD TO ALL SYMBOLS
	HLRO	Q,Q		;-WC OF ALL SYMBOLS
	MOVN	Q,Q		;+WC OF ALL SYMS
	ADD	Q,HVAL		;ADD LENGTH OF HISEG
	SUB	Q,HVAL1		;BUT REMOVE ORIGIN
	ADD	Q,HISTRT	;START OF HISEG IN CORE
	HRRZ	Q,Q		;Q=LAST PHYSICAL ADDR. NEEDED FOR SYMBOLS

;The following is a kludge to fix to a bug.  If there's a new format symbol
;table and HVAL is so close to a 1K boundary that adding KORSP will put it
;over then the BLT at BLTSY0 will overlap the source and destination incorrectly.
;This is because the code assume the symbols are located entirely below the
;upper (in the loader's core image), whereas sorted symbols are located
;entirely above the upper.

;It should be fixed to BLT symbols up 1K before entering BLTSY0, but instead,
;since the symbol patch space isn't useful with new format, the problem is
;eliminated by not adding in KORSP.

IFN SORTSY,<	SKIPE	DOSORT	
		JRST	BLTSY0	>

	ADD	Q,KORSP		;PLUS  SPACE FOR SYMBOL PATCHES

	CORE	Q,		;EXPAND IF NEEDED
	PUSHJ	P,MORCOR
	MOVE	Q,JOBREL
BLTSY0:	PUSH	P,B		;SAVE B (IOWD TO SYMBOLS)
	SOJ	B,		;REMOVE CARRY FROM ADD TO FOLLOW.  -WC,,ADDR-2
	MOVSS	B		;SWAP SYMBOL POINTER  ADDR-2,,-WC
	ADD	B,Q		;ADDR-1,,FIRST DESTINATION OF BLT.
	HRRM	B,(P)		;SAVE NEW B (-WC,,FIRST DEST. OF BLT)
	ADD	B,S		;INCASE ANY UNDEFS. (S IS -WC,,-WC OF UNDEFS)
	BLT	B,(Q)		;MOVE SYMBOLS
	POP	P,B		;GET NEW B
	SUB	B,HISTRT	;MAKE IT RELATIVE TO OUR UPPER'S ORIGIN
	ADD	B,HVAL1		;BUT ABS WITH RESPECT TO UPPER AFTER REMAP
	SOJ	B,		;REMOVE CARRY
	ADDI	S,(B)		;SET UP JOBUSY
BLTSY1:	MOVE	Q,JOBREL
	SUB	Q,HISTRT
	ADD	Q,HVAL1
	SUBI	Q,1		;ONE TOO HIGH
	MOVEM	Q,HVAL
	JRST	NODDT


NOBLT:	HRRZ	Q,HILOW	;GET HIGHEST LOC LOADED
	HRRZ	A,S	;GET BOTTOM OF UNDF SYMBOLS
	SUB	A,KORSP	;DON'T FORGET PATCH SPACE
	IORI	A,1777	;MAKE INTO A K BOUND
	IORI	Q,1777
	CAIN	A,(Q)	;ARE THEY IN SAME K
IFN EXPAND,<JRST	[PUSHJ	P,XPAND>
		PUSHJ	P,MORCOR
IFN EXPAND,<	JRST	NOBLT]>
	MOVEM	Q,HISTRT	;SAVE AS START OF HIGH
	MOVEI	A,400000	;HISEG ORIGIN
	MOVEM	A,HVAL1		;SAVE AS ORIGIN
	SUB	S,HISTRT	;GET POSITION OF UNDF POINTER
	ADDI	S,377777	;RELATIVE TO ORG
	SUB	B,HISTRT	;SAME FOR SYM POINTER
	ADDI	B,377777
	TRO	F,SEENHI	;SO JOBHRL WILL BE SET UP
	JRST	BLTSY1		;AND USE COMMON CODE
>

IFN DMNSW!LDAC,<
MORCOR:	ERROR ,</MORE CORE NEEDED#/>
	EXIT>

SUBTTL	WRITE DUMP FILE

IFE STANSW,<XLIST>
IFN L,<XLIST>			;NONE OF THIS FOR LISP
IFN STANSW,< IFE L,<
	HINAME=134		;NOT KNOWN IN JOBDAT
	HILOC=135
	EXTERNAL JOBSAV,JOBS41

; SWAP UUO does not know about segments,   so we have to fake it.
; Writes out core from JOBSAV+1(X) to JOBFF and the segment.  The
; mess should be replaced with
;	MOVSI V,SWPBLK
;	SWAP V,
;	HALT .
; And code at LD5S should be changed not to do OPEN and ENTER but
; rather put the args, into SWPBLK which should replace the block
; called SAVFIL.  Then it will be done right.

WRTSAV:	MOVE	V,JOB41(X)		;SAVE JOB41
	MOVEM	V,JOBS41(X)

IFN KUTSW,<	SKIPL	V,CORSZ		;NEG MEANS DO NOT KUT BACK CORE
		CAMGE	V,JOBREL(X)
		MOVE	V,JOBREL(X)
		MOVEM	V,JOBCOR(X)	;GUARANTEE THIS MUCH WHEN LOADED >;KUTSW

	SETZM	HILOC(X)	;ASSUME NO SEGMENT.
	SETZM	IOWDPP+1
	SETZM	IOWDPP+2
	MOVEI	V,JOBSAV+1	;-SIZE OF LOWER
	SUB	V,JOBFF(X)
	ANDCMI	V,1		;MAKE SURE THAT THE WC IS EVEN! REG
	HRLI	V,JOBSAV(X)	;FIRST LOCATION OF SAVE
	MOVSM	V,IOWDPP
	MOVE	V,HVAL1		;HIGH SEGMENT EXISTS?
	SUB	V,HVAL
	JUMPE	V,WRTSA2	;NO
	HRL	V,HISTRT	;YES, MAKE IOWD
	ANDCMI	V,1		;MAKE SURE THAT THE WC IS EVEN! REG
	MOVSM	V,IOWDPP+1
	MOVE	V,CURNAM	;SET SEGMENT NAME
	MOVEM	V,HINAME(X)
	HLRO	V,IOWDPP	;-WC OF LOWER.
	MOVM	V,V		;WC OF LOWER.
	TRZE	V,177		;SKIP IF RECORD BOUNDARY.
	ADDI	V,200		;ADVANCE TO NEXT RECORD
	ADDI	V,JOBSAV+1	;CORE ADDRESS OF FIRST DISK RECORD THAT'S FREE
	MOVEM	V,HILOC(X)	;UPPER SEG ORGIN IN DMP FILE.
WRTSA2:	OUT	4,IOWDPP
	JRST	WRTSA3		;NO ERRORS
	ERROR	0,</WRITE ERROR ON DUMP FILE@/>
	RELEAS	4,
	HALT	CPOPJ

WRTSA3:	PUSH	P,Q		;SAVE Q (SETUP BY BLTSET)
	RELEAS	4,
	MOVE	W,['SAVED ']
	PUSHJ	P,PWORD
	MOVE	W,OPEN4+1
	PUSHJ	P,PFWORD
	MOVEI	T,':'
	PUSHJ	P,TYPE
	MOVE	W,SAVFIL
	PUSHJ	P,PFWORD
	MOVEI	T,'.'
	PUSHJ	P,TYPE
	HLLZ	W,SAVFIL+1
	PUSHJ	P,PFWORD
	POP	P,Q
	JRST	CRLF

>>	LIST

SUBTTL	WRITE CHAIN FILES

IFE K,<			;DONT INCLUDE IN 1KLOAD
CHNC:	SKIPA	A,JOBCHN(X)	;CHAIN FROM BREAK OF FIRST BLOCK DATA
CHNR:	HLR	A,JOBCHN(X)	;CHAIN FROM BREAK OF FIRST F4 PROG
IFN ALGSW,<TRNE	F,ALGFL		;IF ALGOL LOADING
	POPJ	P,		;JUST RETURN>
	HRRZS	A		;ONLY RIGHT HALF IS SIGNIFICANT
	JUMPE	A,LD7C		;DON'T CHAIN IF ZERO
	TLNN	N,AUXSWI	;IS THERE AN AUX DEV?
	JRST	LD7D		;NO, DON'T CHAIN
	PUSH	P,A		;SAVE WHEREFROM TO CHAIN
	JUMPE	D,.+2		;STARTING ADDR SPECIFIED?
	HRRZM	D,STADDR	;USE IT
	CLOSE	2,		;INSURE END OF MAP FILE
	TLZ	N,AUXSWI+AUXSWE	;INSURE NO PRINTED OUTPUT
	PUSHJ	P,SASYM		;DO LIB SEARCH, SETUP JOBSA, ETC.
IFN RPGSW,<TLNE	N,RPGF		;IF IN CCL MODE
	TDZA	W,W		;NO MESSAGES>
	MOVE	W,[SIXBIT ?CHAIN?]	;FINAL MESSAGE
	PUSHJ	P,BLTSET	;SETUP BLT PNTR, SETDDT, RELEAS
	POP	P,A		;GET WHEREFROM
	HRRZ	W,R		;CALCULATE MIN IOWD NECESSARY
	SKIPE	JOBDDT(X)	;IF JOBDDT KEEP SYMBOLS
	CAILE	W,1(S)
	JRST	CHNLW1
	HRRZ	W,JOBREL	;NEED SYMBOLS AND THEY HAVE NOT MOVED DOWN
	SUBI	W,(X)		;BECAUSE WE WILL NOT HAVE BLITTED
	SUBI	B,-1(X)		;SYMBOL TABLE WILL COME OUT IN A
	MOVEM	B,JOBSYM(X)	;DIFFERENT PLACE
CHNLW1:	MOVNS	W
	ADDI	W,-7(A)
	ADDI	A,-7(X)
	PUSH	A,W	;SAVE LENGTH
	HRLI	W,-1(A)
	MOVSM	W,IOWDPP	;...
	SETZM	IOWDPP+1	;JUST IN CASE
	PUSH	A,JOBCHN(X)
	PUSH	A,JOBSA(X)	;SETUP SIX WORD TABLE
	PUSH	A,JOBSYM(X)	;...
	PUSH	A,JOB41(X)
	PUSH	A,JOBDDT(X)
	SETSTS	2,17		;SET AUX DEV TO DUMP MODE
	MOVSI	W,435056	;USE .CHN AS EXTENSION
	MOVEM	W,DTOUT1	;...
	PUSHJ	P,IAD2		;DO THE ENTER
	OUTPUT	2,IOWDPP	;WRITE THE CHAIN FILE
	STATZ	2,IOBAD!IODEND
	JRST	LOSEBIG
	CLOSE	2,
	STATZ	2,IOBAD!IODEND
IFN RPGSW,<JRST	LOSEBIG
	TLNE	N,RPGF		;IF IN CCL MODE
	JRST	CCLCHN		;LOAD NEXT LINK
	EXIT>
LOSEBI:	TTCALL	3,[ASCIZ /?DEVICE ERROR/]
	EXIT>

SUBTTL	SPECIAL CHAINB
IFE SPCHN,<	XLIST	>
IFN SPCHN,<
CHNBG:
	PUSHJ	P,FSCN1A		;FORCE SCAN TO COMPLETION FOR CURRENT FILE
	TLNN N,AUXSWI	;IS THERE AN AUX DEV??
	JRST LD7D
	HRLZI	W,-1(R)		;CHNTAB-L = ADDRESS OF VECTOR TABLE
	HRRI	W,1		;CHNTAB-R = NEXT DISK BLOCK TO RITE INTO
	MOVEM	W,CHNTAB
	MOVE	C,[RADIX50 4,OVTAB]	;DEFINE GLOBAL SYMBOL OVTAB
	MOVEI	W,(R)		;TO HAVE VALUE THE BEGINNING OF THE VECTOR TABLE
	PUSHJ	P,SYMPT
	ADDI	R,VECLEN	;RESERVE SPACE FOR VECTOR TABLE
	MOVE	C,[RADIX50 4,OVBEG]	;OVBEG IS BEGINNING OF OVERLAY AREA
	MOVEI	W,(R)
	PUSHJ	P,SYMPT
	HRRZM	R,BEGOV		;AND SAVE IN OVBEG
	OPEN	4,CHNOUT	;OPEN FILE FOR CHAIN
	JRST	ILD5		;CANT OPEN CHAIN FILE
	ENTER	4,CHNENT	;ENTER CHAIN FILE
	JRST	IMD3		;NO CAN DO
	HRRZ	W,N
	SUB	W,HISTRT	;KEEP N RIGHT HALF AS RELATIVE TO HISTRT
	HRRZM W,CHNACN	;SAVE FOR RESTORING
	MOVEM B,CHNACB	;ALSO B R IS SAVED IN BEGOV
	POPJ	P,

CHNENS:	TLOA N,PPCSW	;THIS FLAG UNUSED AT THIS POINT
CHNEN:	TLZ N,PPCSW	;ON TO NOT DELETE NEW SYMBOLS
	SKIPN CHNACB	;WILL BE NON-ZERO IF WE SAW A /<  (> TO KEEP  MACRO HAPPY)
	JRST LD7D	;ERROR MESSAGE
	PUSHJ P,FSCN1A		;LOAD LIB (IF DESIRED) AND FORCE SCAN
	SKIPL Q,S	;CHECK SYMBOL TABLE FOR MISSED UNDEFS
	JRST NOER	;NONE THERE
	MOVEI E,0	;COUNT OF ERRORS
ONCK:
	IFN FAILSW,<SKIPL V,1(Q)	;IF HIGH ORDER BIT IS ON
	TLNN V,740000	;OR IF ALL CODE BITS 0
	JRST NXTCK	;THEN NOT TO BE CHECKED>
	MOVE V,2(Q)	;GET FIXUP WORD
	TLNE V,100000	;BIT INDICATES SYMBOL TABLE FIXUP
	JRST SMTBFX
IFN FAILSW,<TLNE V,40000	;BIT INDICATES POLISH FIXUP
	JRST POLCK>
	TLZE V,740000	;THESE BITS WOULD MEAN ADDITIVE
	JRST	[JSP A,CORCKL
		JRST NXTCK]	;ONLY TRY FIRST LOCATION
CORCK:	JSP A,CORCKL
	HRRZ V,@X	;THE WAY TO LINK
CORCKL:	IFN REENT,<CAMGE V,HVAL1>
	CAMGE V,BEGOV
	SKIPA	;NOT IN BAD RANGE
	JRST ERCK	;BAD, GIVE ERROR
	JUMPE V,NXTCK	;CHAIN HAS RUN OUT
IFN REENT,<CAMGE V,HVAL1	;GET CORRECT LINK
	SKIPA X,LOWX
	MOVE X,HIGHX>
	XCT (A)		;TELLS US WHAT TO DO
	JRST CORCKL	;GO ON WITH NEXT LINK

SMTBFX:	TLNE N,PPCSW	;IF NOT CUTTING BACK SYMBOL TABLE
	JRST NXTCK	;THE ALL OK
	ADD V,HISTRT	;GET PLACE TO POINT TO
	HRRZS V
	HLRE D,CHNACB	;OLD LENGTH OF TABLE (NEGATIVE)
	HLRE T,B	;NEW LENGTH
	SUB D,T		;-OLD LEN+NEW LEN
	ADDI D,(B)	;OLD BOTTOM=NEW BOTTOM+NEW LEN-OLD LEN
	CAIG V,(D)	;IS IT IN THE PART WE ARE KEEPING
	JRST ERCK
	JRST NXTCK	;YES
IFN FAILSW,<POLCK:	HLRZ C,V	;FIND HEADER
	PUSHJ P,SREQ
	SKIPA
	JRST LOAD4A	;SHOULD BE THERE
	HRL C,2(A)	;NOW FIRST OPERATOR (STORE)
	MOVSS C
	PUSHJ P,SREQ
	SKIPA
	JRST LOAD4A
	ANDI C,37	;GET OPERATION
	HRRZ V,2(A)	;DESTINATION
	JRST @CKSMTB-15(C)	;DISPATCH
CKSMTB:	EXP SMTBFX,SMTBFX,SMTBFX,CORCK,LCORCK,CORCK,NXTCK
LCORCK:	JSP A,CORCKL
	HLRZ V,@X>
ERCK:	MOVE C,1(Q)	;GET SYMBOL NAME
	PUSHJ P,FCRLF	;FORCE CRLF AND OUTPUT ON TTY
	PUSHJ P,PRNAME	;PRINT IT
	ADDI E,1	;MARK ERROR
NXTCK:	ADD Q,SE3	;TRY ANOTHER
	JUMPL Q,ONCK
IFN REENT,<PUSHJ P,RESTRX	;GET PROPER X BACK>
	JUMPE E,NOER	;DID ANYTHING GO WRONG??
	ERROR	,</UNDEFINED GLOBAL(S) IN LINK@/>
	JRST LD2	;GIVE UP
NOER:	MOVE A,BEGOV	;GET START OF OVERLAY
	ADDI A,(X)	;GET ACTUAL CURRENT LOCATION
IFN REENT,<HRRZ W,HILOW	;AND END OF OVERLAY+1
	HRRZM A,HILOW	;RESET>
IFE REENT,<HRRZ W,R
	ADDI R,(X)	;A GOOD GUESS>
	SUBM A,W	;W=-LENGTH
	SUBI A,1	;SET TO BASE-1 (FOR IOWD)
	HRL A,W		;GET COUNT
	MOVEM A,IOWDPP
	HRR A,CHNTAB	;BLOCK WE ARE WRITING ON
	HLRZ V,CHNTAB	;POINTER TO SEGMENT TABLE
	ADDI V,1	;NEXT LOCATION
	HRLM V,CHNTAB	;REMEMBER IT
	CAML V,BEGOV	;CHECK FOR OVERRUN
	JRST	[ERROR </?TOO MANY LINKS@/>
		JRST LD2];GIVE UP
	MOVEM A,@X	;PUT INTO TABLE
	MOVN W,W	;GET POSITIVE LENGTH
	ADDI W,DSKBLK-1
	IDIVI W,DSKBLK	;GET NUMBER OF BLOCKS
	ADDM W,CHNTAB	;AND UPDATE
	TLZE N,PPCSW
	JRST NOMVB	;DO NOT ADJUST SYMBOLS
	HLRE W,CHNACB	;GET OLD LENGTH OF DEF SYMBOLS
	HLRE C,B	;AND NEW LENGTH
	SUB W,C		;-OLD LEN+NEW LEN
	HRRZ C,B	;SAVE POINTER TO CURRENT S
	ADD S,W
	HRL W,W
	ADD B,W		;UPDATE B (COUNT AND LOC)
	JUMPGE S,UNLNKD	;JUST IN CASE NOTHING TO MOVE
	HRRZ A,B	;PLACE TO PUT UNDEFS
UNLNK:	MOVE W,(C)
	MOVEM W,(A)	;TRANSFER
	SUBI A,1
	CAIE A,(S)	;HAVE WE MOVED LAST WORD??
	SOJA C,UNLNK	;NO, CONTINUE
UNLNKD:	HRRZ W,CHNACN	;GET SAVED N
	ADD W,HISTRT
	HRR N,W	;AND RESET IT
NOMVB:	HRR R,BEGOV	;PICK UP BASE OF AREA
	OUTPUT 4,IOWDPP	;DUMP IT
	STATZ 4,IOBAD!IODEND	;AND ERROR CHECK
	JRST LOSEBI
	HRRZ V,R	;GET AREA TO ZERO
	MOVEI W,@X
	CAIL W,1(S)	;MUST MAKE SURE SOME THERE
	POPJ P,	;DONE
	SETZM (W)
	CAIL W,(S)
	POPJ P,
	HRLS W
	ADDI W,1
	BLT W,(S)	;ZERO WORLD
	POPJ P,
>
	LIST

SUBTTL	EXPAND CORE

IFN EXPAND,<
XPAND:	TLNE	F,FULLSW	;IF CORE  EXCEEDED
	POPJ	P,		;DON'T WASTE TIME  ON  CORE UUO
	PUSH	P,Q
	HRRZ	Q,JOBREL
	ADDI	Q,2000
XPAND1:	PUSH P,H	;GET SOME REGISTERS TO USE
	PUSH P,X
	PUSH P,N
	PUSH	P,JOBREL	;SAVE PREVIOUS SIZE
	CAMG	Q,ALWCOR	;CHECK TO SEE IF RUNNING OVER
	CORE Q,
	JRST XPAND6
IFE K,<	HRRZ H,MLTP	;GET LOWEST LOCATION
	TLNN N,F4SW	;IS FORTRAN LOADING>
	MOVEI H,1(S)	;NO, USE S
	POP	P,X	;LAST JOBREL
	HRRZ	Q,JOBREL;NEW JOBREL
	SUBI	Q,(X)	;GET DIFFERENCE
	HRLI	Q,X	;PUT X IN INDEX FIELD
XPAND2:	MOVE N,(X)
	MOVEM N,@Q
	CAMLE X,H	;TEST FOR END
	SOJA X,XPAND2
	HRLI	H,-1(Q)
	TLC	H,-1	;MAKE IT NEGATIVE
	SETZM (H)	;ZERO NEW CORE
	AOBJN H,.-1
	MOVEI H,(Q)
XPAND8:	ADD	S,H
	ADD	B,H
	ADDM H,GLBEND	;It better not be in an AC when XPAND is called!!!
	ADDM H,HISTRT	;UPDATE START OF HISEG
IFN REENT,<ADDM H,HIGHX	;AND STORE LOCATION
	TLNE F,HIPROG
	ADDM H,-1(P)	;X IS CURRENTLY IN THE STACK>
	POP P,N
	ADD N,H
IFE K,<	TLNN N,F4SW	;F4?
	JRST	XPAND3
	ADDM H,PLTP
	ADDM H,BITP
	ADDM H,SDSTP
	ADDM H,MLTP
	TLNE N,SYDAT
	ADDM H,V>
XPAND3:	AOSA -3(P)
XPAND5:	POP P,N
	POP P,X
	POP P,H
	POP	P,Q
	POPJ P,

XPAND6:	POP	P,A	;CLEAR JOBREL OUT OF STACK
	ERROR	,</MORE CORE NEEDED#/>
	JRST XPAND5

XPAND7:	PUSHJ	P,XPAND
	JRST	SFULLC
	JRST	POPJM2

XPAND9:	PUSH	P,Q		;SAVE Q
	HRRZ	Q,JOBREL	;GET CORE SIZE
	ADDI	Q,(V)		;ADD XTRA NEEDED
	JRST	XPAND1		;AND JOIN COMMON CODE

POPJM3:	SOS	(P)		;POPJ TO CALL-2
POPJM2:	SOS	(P)		;POPJ TO CALL-1
	SOS	(P)		;SAME AS POPJ TO
	POPJ	P,		;NORMAL POPJ MINUS TWO
>


SUBTTL	SWITCH HANDLING

;ENTER SWITCH MODE

LD6A:
IFN STANSW,< CAIE T,"%"		;ACCEPT '%' AS WELL AS '/' >
	CAIN	T,57		;WAS CHAR A SLASH?
	TLO	N,SLASH		;REMEBER THAT
LD6A2:	TLO	F,SSW		;ENTER SWITCH MODE
LD6A1:	SETZB	D,C	;ZERO TWO REGS FOR DECIMAL AND OCTAL
	JRST	LD3		;EAT A SWITCH

;ALPHABETIC CHARACTER, SWITCH MODE

LD6:
	CAIL	T,141		;ACCEPT LOWER CASE SWITCHES
	SUBI	T,40
IFN SPCHN!STANSW,<XCT	LD6B-74(T)	;EXECUTE SWITCH FUNCTION>
IFE SPCHN!STANSW,<XCT	LD6B-101(T)	;EXECUTE SWITCH FUNCTION>
	TLZE	N,SLASH	;SWITCH MODE ENTERED W/ SLASH?
	JRST	LD6D		;LEAVE SWITCH MODE
	JRST	LD6A1		;STAY IN SWITCH MODE


;DISPATCH TABLE FOR SWITCHES

;	THE INSTRUCTION AT THE CHARACTER LOCATION IS EXECUTED

COMMENT/
AT STANFORD MAP SWITCHES < TO H
AND > TO V	(THIS WILL BE OVERRIDDEN IF SOMEONE TRIES SPCHN=1)
WHAT A CROCK:	FW/

LD6B:
IFN SPCHN,<PUSHJ P,CHNBG	;LESS THAN - BEGINNING OF OVERLAY
	PUSHJ	P,CHNENS	;= - PUT OUT CHAIN RETAINING SYMBOLS
	PUSHJ	P,CHNEN		;GREATER THAN - END OF OVERLAY
IFN SORTSY,<PUSHJ P,SETSRT;>JRST LD7B	;? - SORT SYMBOL TABLE (ELSE ERROR)
	JRST	LD7B		;@ - ERROR>;END IFN SPCHN

IFG STANSW-SPCHN,<PUSHJ P,HSET	;< BECOMES H
	PUSHJ P,RHTCRK		;= - LOSING COMPATABILITY MODE (OLD SYMBOL FORMAT)
	PUSHJ P,VSWTCH		;> BECOMES V
IFN SORTSY,<PUSHJ P,SETSRT;>JRST LD7B	;? - SORT SYMBOL TABLE (ELSE ERROR)
	JRST	LD7B>
	PUSHJ	P,ASWTCH	;A - LIST ALL GLOBALS
IFN DMNSW,<PUSHJ P,DMN2		;B - BLOCKS DOWN SYMBOL TABLE >
IFE DMNSW,<JRST	LD7B		;B - ERROR>
IFE K,<	PUSHJ	P,CHNC		;C - CHAIN, START W/ COMMON>
IFN K,<	JRST	LD7B		;C - ILLEGAL IN 1KLOAD>
	PUSHJ   P,LDDT		;D - DEBUG OPTION, LOAD DDT
	TLO	N,EXEQSW	;E - LOAD AND GO
	PUSHJ    P,LIBF		;F - LIBRARY SEARCH
	PUSHJ    P,LD5E		;G - GO INTO EXECUTION
IFE STANSW,<IFN REENT,< PUSHJ P,HSET		;H - REENTRANT. PROGRAM>
	IFE REENT,<JFCL				;NOT REENT AND NOT STANFORD>>
IFN STANSW,<PUSHJ P,LDDTQX			;H - LOAD AND START RAID>
	PUSHJ	P,ISWTCH	;I - IGNORE STARTING ADDRESSES
	TLZ	N,ISAFLG	;J - USE STARTING ADDRESSES
IFE KUTSW,<JRST	LD7B		;K - ERROR>
IFN KUTSW,<MOVEM C,CORSZ	;K - SET DESIRED CORE SIZE>
	PUSHJ	P,LSWTCH	;L - ENTER LIBRARY SEARCH
	PUSHJ   P,PRMAP		;M - PRINT STORAGE MAP
	TLZ	F,LIBSW+SKIPSW	;N - LEAVE LIBRARY SEARCH
	HRR	R,D		;O - NEW PROGRAM ORIGIN
	PUSHJ	P,PSWTCH	;P - PREVENT AUTO. LIB. SEARCH
	TLZ	F,NSW		;Q - ALLOW AUTO. LIB. SEARCH
IFE K,<	PUSHJ	P,CHNR		;R - CHAIN, START W/ RESIDENT>
IFN K,<	JRST	LD7B		;R - ILLEGAL IN 1KLOAD>
	PUSHJ	P,SSWTCH	;S - LOAD WITH SYMBOLS
	PUSHJ	P,LDDTX		;T - LOAD AND GO TO DDT
	PUSHJ   P,PMS		;U - PRINT UNDEFINED LIST
IFE STANSW,<IFN REENT,<PUSHJ P,VSWTCH	;V - LOAD REENTRANT LIB40>
	IFE REENT,<JRST LD7B	;V -NO REENT, NO STANFORD: ERROR>>
IFN STANSW,<PUSHJ P,LDDTQ	;V - LOAD RAID>
	TLZ	F,SYMSW+RMSMSW	;W - LOAD WITHOUT SYMBOLS
	TLZ	N,ALLFLG	;X - DO NOT LIST ALL GLOBALS
IFE SAILSW,<
	TLO	F,REWSW		;Y - REWIND BEFORE USE
>
IFN SAILSW,<
	PUSHJ	P,SEGLOD	;Y - LOAD SYS:SAILOW FOR 2-SGMT SAIL
>
	JRST	LDRSTR		;Z - RESTART LOADER


; PAIRED SWITCHES ( +,-)

ASWTCH:	JUMPL	D,.+2		;SKIP IF /-A
	TLOA	N,ALLFLG	;LIST ALL GLOBALS
	TLZ	N,ALLFLG	;DON'T
	POPJ	P,

IFN SORTSY,<
SETSRT:	SETZM	DOSORT		;ASSUME /-?
	SKIPL	D
	SETOM	DOSORT		;SET /? SEEN
	POPJ	P,
>

ISWTCH:	JUMPL	D,.+2		;SKIP IF /-I
	TLOA	N,ISAFLG	;IGNORE STARTING ADDRESSES
	TLZ	N,ISAFLG	;DON'T
	POPJ	P,

LSWTCH:	JUMPL	D,.+2		;SKIP IF /-L
	TLOA	F,LIBSW!SKIPSW	;ENTER LIBRARY SEARCH
	TLZ	F,LIBSW!SKIPSW	;DON'T
	POPJ	P,

PSWTCH:	JUMPL	D,.+2		;SKIP IF /-P
	TLOA	F,NSW		;PREVENT AUTO. LIB SEARCH
	TLZ	F,NSW		;ALLOW
	POPJ	P,

SSWTCH:	JUMPL	D,.+2		;SKIP IF /-S
	TLOA	F,SYMSW!RMSMSW	;LOAD WITH SYMBOLS
	TLZ	F,SYMSW!RMSMSW	;DON'T
	POPJ	P,

IFN REENT,<
VSWTCH:	JUMPL	D,.+2		;SKIP IF /-V
	TROA	F,VFLG		;SEARCH RE-ENTRANT LIBRARY
	TRZ	F,VFLG		;DON'T
	POPJ	P,>

IFN SAILSW,<
SEGLOD:	PUSHJ	P,FSCN1		;FORCE SCAN TO COMPLETION
	HRRZ	W,R		;CHECK LEGAL
	CAILE	W,140		; (MUST BE NOTHING LOADED EARLIER)
	JRST	[ERROR ,<./Y MUST APPEAR BEFORE ANY FILES ARE LOADED`.>
		 JRST  LD2]	;TRY AGAIN
	MOVE	W,[SIXBIT /SAILOW/] ;WILL LOAD SAILOW NOW
	ADD	W,D		;SAILOW, SAILOX, SAILOY, DEPENDING
	;ON ARG -- W FOR SAIL, X FOR OSAIL, Y FOR NSAIL
	TLZ	F,SYMSW!RMSMSW	;SET SWITCHES (SEE LDDT)
	PUSHJ	P,LDDT1		;SET SYS AS DEVICE, PREPARE
	PUSHJ	P,LDF		;LOAD SAILOW
	POPJ	P,		;AFRAID OF `JRST LDF'
>; END OF SEGMENT LOADING OPTION

IFN STANSW,<		;MAKE RUSSELL HAPPY BY DISTRIBUTING GLOBALS LIKE WE USED TO
RHTCRK:	HLLZ C,GLBEND
	ADD B,C		;INCLUDE CURRENT STUFF
	HRRZS GLBEND	;NO MORE STUFF HERE
	MOVEI C,B
	MOVEM C,GLBENP	;NOW MAKE EVERYONE LOOK AT B INSTEAD
	POPJ P,
>; END OF RHTCRK

IFN REENT,<	; H SWITCH --- EITHER /H OR /NH
HSET:	JUMPE	D,SETNUM	;/H ALWAYS LEGAL
	CAIGE	D,2		;WANT TO CHANGE SEGMENTS
	JRST	SETSEG		;YES,GO DO IT
	TRNN	F,SEENHI	;STARTED TO LOAD YET?
	JRST	HCONT		;NO, CONTINUE.
	ERROR	,<?/H ILLEGAL AFTER FIRST HISEG FILE IS LOADED@?>>

LDRSTR:	ERROR	0,</LOADER RESTARTED@/>
	JRST	LD		;START AGAIN
IFN REENT,<
REMPFL:	ERROR	,</?LOADER REMAP FAILURE@/>
	JRST LDRSTR
HCONT:	HRRZ C,D
	ANDCMI C,1777
	CAIL C,400000
	CAIG C,(H)
	JRST COROVL	;BEING SET LOWER THEN 400000 OR MORE THAN TO OF LOW SEG
;;;	HRRZM C,HVAL1	;WE HAVE REMOVED THE ODD BITS TO MAKE A 1K MULT
; ABOVE REMOVED BY JBR 12/10/75
	ADDI C,JOBHDA
	CAILE C,(D)	;MAKE SURE OF ENOUGH ROOM
	MOVE D,C
	HRLI D,W	;SET UP W IN LEFT HALF
	MOVEM D,HVAL
	MOVEI C,400000	;; JBR 12/10/75
	MOVEM C,HVAL1	;; JBR 12/10/75
	POPJ P,		;RETURN.

COROVL:	ERROR	,</HISEG STARTING ADDRESS TOO LOW@/>
	JRST LDRSTR
SETNUM:	TRO	F,NOHI	;SET NO-HIGH-SEG SWITCH.
	POPJ	P,>

;SWITCH MODE NUMERIC ARGUMENT

LD6C:	LSH	D,3 		;BUILD OCTAL NUMERIC ARGUMENT
	ADDI	D,-60(T)
	IMULI C,^D10
	ADDI C,-"0"(T)	;ACCUMULATE DEC AND OCTAL
	JRST	LD3

;EXIT FROM SWITCH MODE

LD6D:	TLZ	F,SSW		;CLEAR SWITCH MODE FLAG
	TLNE	F,FSW		;TEST FORCED SCAN FLAG
	JRST	LD2D		;SCAN FORCED, START NEW IDENT.
	JRST	LD3 		;SCAN NOT FORCED, USE PREV IDENT
;ILLEGAL CHARACTER, NORMAL MODE

LD7:	IFN SYMARG,<
	CAIN	T,"#"		;DEFINING THIS SYMBOL
	JRST	DEFINE		;YES 
	TRNN	F,ARGFL		;TREAT AS SPECIAL
	JRST	.+4		;NO
	CAIE	T,"$"
	CAIN	T,"%"
	JRST	LD4		;YES>
	CAIN	T,"Z"-100	;TEST FOR ^Z
	JRST	LD5E1		;TREAT AS ALTMODE FOR BATCH
	ERROR	8,</CHAR.%/>
	JRST	LD2	;TRY TO CONTINUE

;SYNTAX ERROR, NORMAL MODE

LD7A:	ERROR	8,</SYNTAX%/>
	JRST	LD2

;ILLEGAL CHARACTER, SWITCH MODE

LD7B:	CAIN T,"-"	;SPECIAL CHECK FOR -
	JRST	[SETOB C,D
		JRST LD3]
	CAIN	T,"Z"-100	;CHECK FOR /^Z
	JRST	LD5E1		;SAME AS ^Z
	ERROR	8,</SWITCH%/>
	JRST	LD2

;ATTEMPT TO CHAIN WITH SPECIFIED HALF OF JOBCHN = 0

IFE K,<
LD7C:	ERROR	,<?UNCHAINABLE AS LOADED@?>
	JRST	LD2

;ATTEMP TO CHAIN WITHOUT SPECIFYING DEVICE

LD7D:	ERROR	,<?NO CHAIN DEVICE@?>
	JRST	LD2>

IFN DMNSW,<
DMN2:
IFN ALGSW,<TRNE	F,ALGFL		;IF LOADING ALGOL
	POPJ	P,		;JUST RETURN>
	CAIN	D,1		;SPECIAL CASE
	TROA	F,HISYM		;YES ,BLT SYMBOLS INTO HISEG
	JUMPL	D,.+2
	TROA	F,DMNFLG	;TURN ON /B
IFN KUTSW,<TRZA	F,DMNFLG	;TURN OFF IF /-B
	SETZM	CORSZ		;SET TO CUT BACK CORE>
IFE KUTSW,<TRZ	F,DMNFLG	;TURN OFF IF /-B>
	CAMLE D,KORSP
	MOVEM D,KORSP
	POPJ	P,		 ;RETURN>


SUBTTL	CHARACTER CLASSIFICATION TABLE DESCRIPTION:

;	EACH CHARACTER HAS ASSOCIATED WITH IT A FOUR BIT BYTE
;	PACKED IN THE CHARACTER CLASSIFICATION TABLE.  THE CHARACTER
;	CLASSIFICATION CODES ARE ORDERED IN SUCH A WAY AS TO GIVE
;	DELIMITERS OF HIGHER PRECEDENCE LOWER CLASSIFICATION NUMBERS.
;	CERTAIN CHARACTERS HAVE NO EFFECT ON THE COMMAND STRING, AND
;	THEREFORE DO NOT EFFECT ORDERING OF DELIMITERS.  FOUR CODES
;	ARE RESERVED FOR ALTERNATE DISPATCHES WHILE THE SWITCH MODE IS
;	IN EFFECT.


;CLASSIFICATION BYTE CODES:

;	BYTE DISP CLASSIFICATION

;	00 - 00  ILLEGAL CHARACTER, SWITCH MODE
;	01 - 01  ALPHABETIC CHARACTER, SWITCH MODE
;	02 - 02  NUMERIC CHARACTER, SWITCH MODE
;	03 - 03  SWITCH MODE ESCAPE, SWITCH MODE

;	00 - 04  ILLEGAL CHARACTER, NORMAL MODE
;	01 - 05  ALPHABETIC CHARACTER, NORMAL MODE
;	02 - 06  NUMERIC CHARACTER, NORMAL MODE
;	03 - 07  SWITCH MODE ESCAPE, NORMAL MODE

;	04 - 10  IGNORED CHARACTER
;	05 - 11  ENTER SWITCH MODE CHARACTER
;	06 - 12  DEVICE IDENTIFIER DELIMITER
;	07 - 13  FILE EXTENSION DELIMITER
;	10 - 14  OUTPUT SPECIFICATION DELIMITER
;	11 - 15  INPUT SPECIFICATION DELIMITER
;	12 - 16  LINE TERMINATION
;	13 - 17  JOB TERMINATION

;BYTE POINTERS TO CHARACTER CLASSIFICATION TABLE

LD8:	POINT     4,LD9(Q),3
	POINT     4,LD9(Q),7
	POINT     4,LD9(Q),11
	POINT     4,LD9(Q),15
	POINT     4,LD9(Q),19
	POINT     4,LD9(Q),23
	POINT     4,LD9(Q),27
	POINT     4,LD9(Q),31
	POINT     4,LD9(Q),35

;CHARACTER CLASSIFICATION TABLE

LD9:	BYTE	(4)4,0,0,0,0,0,0,0,0			;00-10
	BYTE	(4)4,4,4,4,12,0,0,0,0			;11-21
	BYTE	(4)0,0,0,0,0,0,0,0,0			;22-32
	BYTE	(4)13,0,0,0,0,4,0,4,0			;33-43
IFE SYMARG,<IFN STANSW,<BYTE	(4)0,5,0,0,5,3,0,0,11>	;44-54
	    IFE STANSW,<BYTE	(4)0,0,0,0,5,3,0,0,11>
IFN SYMARG,<	BYTE	(4)0,0,14,0,5,3,0,0,11>
	BYTE	(4)0,7,5,2,2,2,2,2,2			;55-65
IFE SPCHN!STANSW,<	BYTE	(4)2,2,2,2,6,0,0,10,0>	;66-76
IFN SPCHN!STANSW,<	BYTE	(4)2,2,2,2,6,0,1,10,1>
IFE RPGSW,<	BYTE	(4)SORTSY,0,1,1,1,1,1,1,1>	;77-107
IFN RPGSW,<	BYTE (4) SORTSY,10,1,1,1,1,1,1,1>	;77-107
	BYTE	(4)1,1,1,1,1,1,1,1,1			;110-120
	BYTE	(4)1,1,1,1,1,1,1,1,1			;121-131
IFE PP,<BYTE	(4)1,0,0,0,0,10,0,1,1>			;132-142
IFN PP,<IFN STANSW,<IFE L,< BYTE    (4)1,10,0,10,10,10,0,1,1>>	;Activate '^'
	IFE STANSW,< BYTE    (4)1,10,0,10,0,10,0,1,1>>
	IFN L,< BYTE         (4)1,10,0,10,0,10,0,1,1>>
	BYTE	(4)1,1,1,1,1,1,1,1,1			;143-153
	BYTE	(4)1,1,1,1,1,1,1,1,1			;154-164
	BYTE	(4)1,1,1,1,1,1,0,0,13			;165-175
	BYTE	(4)13,4					;176-177

SUBTTL	INITIALIZE LOADING OF A FILE

ILD:	MOVEI     W,BUF1		;LOAD BUFFER ORIGIN
	MOVEM     W,JOBFF
	TLOE	F,ISW		;SKIP IF INIT REQUIRED
	JRST	ILD6		;DONT DO INIT
ILD7:	OPEN	1,OPEN3			;KEEP IT PURE
	JRST	ILD5B
IFN STANSW,<
	MOVEI W,1
	SHOWIT W,		;Display input file's ststus on wholine
>;STANSW
ILD6:	TLZE	F,REWSW		;SKIP IF NO REWIND
	MTAPE	1,1		;REWIND
ILD2:	LOOKUP    1,DTIN		;LOOK UP FILE FROM DIRECTORY
	JRST	ILD3		;FILE NOT IN DIRECTORY

IFE LNSSW,<
IFE K,<
	IFN STANSW,<	IFE L,<	INBUF 1,23>	;STANFORD, NOT LISP
			IFN L,< INBUF 1,2>	;STANFORD, LISP >;IFN STANSW
	IFE STANSW,<	INBUF     1,2 		;SET UP BUFFERS	>;IFE STANSW
>;IFE K
IFN K,<	INBUF	1,1		;SET UP BUFFER>
>;IFE LNSSW

IFN LNSSW,<INBUF	1,1
	MOVEI	W,BUF1
	EXCH	W,JOBFF
	SUBI	W,BUF1
IFE K,<	MOVEI	C,4*203+1>
IFN K,<	MOVEI	C,203+1>
	IDIV	C,W
	INBUF	1,(C)
>;IFN LNSSW

	TLO	F,ASW		;SET LEFT ARROW ILLEGAL FLAG
	TLZ	F,ESW		;CLEAR EXTENSION FLAG
	POPJ	P,

;	LOOKUP FAILURE

ILD3:	TLOE	F,ESW		;SKIP IF .REL WAS ASSUMED
	JRST	ILD4		;FATAL LOOKUP FAILURE
	SETZM     DTIN1		;ZERO FILE EXTENSION
	JRST	ILD2		;TRY AGAIN WITH NULL EXTENSION

ILD4:	IFE REENT,<IFE TEN30,<	;PDP-6 ONLY
	MOVE	W,[SIXBIT /LIB40/]
	CAME	W,DTIN		;WAS THIS A TRY FOR LIB40?
	JRST	ILD4A		;NO
	TRZ	W,(SIXBIT / 0/)	;YES
	MOVEM	W,DTIN		;TRY LIB4
	PUSHJ	P,LDDT2		;USE .REL EXTENSION
	TLZ	F,ESW		;...
	JRST	ILD2		;GO TRY AGAIN
ILD4A:>>
IFN PP,<MOVSI	W,(SIXBIT /DSK/)
	CAMN	W,ILD1		;TRIED DSK ONCE?
	JRST	ILD9		;YES, FILE DOES NOT EXIST
	MOVEM	W,ILD1		;SET IT UP
	SETZM	PPN		;CLEAR OLD VALUE
	PUSHJ	P,LDDT2		;SET UP .REL
	TLZ	F,ESW		;SO WE CAN TRY BLANK EXT
	JRST	ILD7		;OPEN DSK,TRY AGAIN>

ILD9:	ERROR	,</CANNOT FIND#/>
	JRST	LD2

;	DEVICE SELECTION ERROR

ILD5A:	SKIPA	W,LD5C1
ILD5B:	MOVE	W,ILD1
ILD5:	TLO	F,FCONSW	;INSURE TTY OUTPUT
	PUSHJ	P,PRQ		;START W/ ?
	PUSHJ   P,PWORD		;PRINT DEVICE NAME
	ERROR	7,</UNAVAILABLE@/>
	JRST	LD2

SUBTTL	LIBRARY SEARCH CONTROL AND LOADER CONTROL

;LIBF ENABLES A LIBRARY SEARCH OF <SYS:LIB4.REL>

LIBF:	PUSHJ     P,FSCN1		;FORCE SCAN TO COMPLETION
	PUSH P,ILD1	;SAVE DEVICE NAME
	PUSHJ	P,LIBF1			;LOAD SYS:JOBDAT.REL
IFN SAILSW,<LIBAGN:	PUSHJ P,SALOAD	;LOAD RELS AND SEARCH LIBS>
IFN REENT,<TRNN	F,SEENHI	;IF ANY HISEG LOADED NO RE-ENT OP SYSTEM
	TRNN F,VFLG
	JRST LIBF3
IFN ALGSW,<TRNE	F,ALGFL	;SPECIAL ACTION IF LOADING ALGOL
	JRST	[MOVE C,[RADIX50 44,%ALGDR]
		MOVEI W,400010	;JOBHDA
		PUSHJ P,SYMPT	;DEFINE IT
		JRST	LIBF3]	;DON'T LOAD IMP40>
	MOVE W,[SIXBIT /IMP40/]
	PUSHJ P,LIBF2
LIBF3:>
	TRNN	F,COBFL			;COBOL SEEN?
	SKIPA	W,[SIXBIT /LIB40/]	;FIRST TRY AT NAME
	MOVE	W,[SIXBIT /LIBOL/]	;YES, SEARCH COBOL'S LIBRARY ONLY
	PUSHJ	P,LIBF2			;LOAD SYS:LIB40.REL
IFN SAILSW,<MOVE W,LIBPNT	;SEE IF ANY MORE TO DO
	CAME W,[XWD -RELLEN-1,LIBFLS-1]
	JRST LIBAGN
	MOVE W,PRGPNT	;IT COULD BE DANGEROUS TO LOAD PROGRAMS HERE
	CAME W,[XWD -RELLEN-1,PRGFLS-1]
	JRST LIBAGN	;MORE TO DO, TRY AGAIN>
	POP P,ILD1	;CALL TO LDDT1 WILL PUT IT IN OLDDEV
LIBF1:	MOVE	W,[SIXBIT /JOBDAT/]	;LOAD SYS:JOBDAT.REL
LIBF2:	PUSHJ     P,LDDT1
LIBGO:	JUMPGE    S,EOF2		;JUMP IF NO UNDEFINED GLOBALS
	TLO	F,SLIBSW+SKIPSW	;ENABLE LIBRARY SEARCH
	TLZ	F,SYMSW	;DISABLE LOADING WITH SYMBOLS
	JRST	LDF 		;INITIALIZE LOADING LIB4

;	LIB CONTROLS THE LIBRARY SEARCH OF ONE FILE

LIB:	JUMPGE  S,EOF1		;JUMP IF NO UNDEFINED GLOBALS
	TLO	F,SKIPSW	;SET SKIPSW TO IGNORE MODE
IFN DIDAL,<TRNE	F,XFLG		;INDEX IN CORE?
	JRST	INDEX1		;YES>
	JRST	LOAD		;CONTINUE LIB. SEARCH

LIB1:	CAIE	A,4 		;TEST FOR ENTRY BLOCK
	JRST	LIB29		;NOT AN ENTRY BLOCK, IGNORE IT
LIB2:	PUSHJ   P,RWORD		;READ ONE DATA WORD
	MOVE	C,W
	TLO	C,040000		;SET CODE BITS FOR SEARCH
	PUSHJ     P,SREQ
	TLZA	F,SKIPSW		;REQUEST MATCHES ENTRY, LOAD
	JRST	LIB2		;NOT FOUND
LIB3:	PUSHJ     P,RWORD		;READ AND IGNORE ONE DATA WORD
	JRST	LIB3		;LOOP TO IGNORE INPUT

LIB29:
IFN DIDAL,<CAIN	A,14		;INDEX BLOCK?
	JRST	INDEX0		;YES>
LIB30:	HRRZ	C,W		;GET WORD COUNT
	JUMPE	C,LOAD1		;IF NUL BLOCK RETURN
	CAILE	C,^D18		;ONLY ONE SUB-BLOCK
	JRST	LIB3		;NO,SO USE OLD SLOW METHOD
	AOJA	C,LIB31		;ONE FOR RELOCATION WORD

BLOCK0:	HRRZ	C,W		;GET WORD COUNT
	JUMPE	C,LOAD1		;NOISE WORD
LIB31:	CAML	C,BUFR2		;DOES BLOCK OVERLAP BUFFERS?
	SOJA	C,LIB32		;YES,ALLOW FOR INITIAL ILDB
	ADDM	C,BUFR1		;ADD TO BYTE POINTER
	MOVNS	C		;NEGATE
	ADDM	C,BUFR2		;TO SUBTRACT C FROM WORD COUNT
	JRST	LOAD1		;GET NEXT BLOCK

LIB32:	SUB	C,BUFR2		;ACCOUNT FOR REST OF THIS BUFFER
	PUSHJ	P,WORD+1	;GET ANOTHER BUFFERFUL
	JRST	LIB31		;TRY AGAIN

IFN SAILSW,<

COMMENT * BLOCK TYPE 15 AND 16 USED TO SPECIFY PROGRAMS AND
LIBRARIES WHICH MUST BE LOADED (SEARCHED) IF THE PROGRAM
IN WHICH THE BLOCK APPEARS IS LOADED. IT IS NOW TIME TO
LOAD AND SEARCH THESE FILES. IF ANY MAKE REQUESTS, THEY ARE ADDED
TO THE END. WE WILL COME BACK AND LOOK AGAIN IN CASE A
LIBRARY PROGRAM LOAD A REL PROGRAM. ORIGINAL CODE BY DCS*

SALOAD:	MOVE T,[XWD -RELLEN-1,PRGFLS-1]	;TO RESET WITH AT END
	MOVEI D,PRGPNT	;OINTER TO UPPER LIMIT
	PUSHJ P,PRGPRG	;LOAD THEM IF ANY

;NOW FOR LIBRARY SEARCH

	MOVE T,[XWD -RELLEN-1,LIBFLS-1]
	MOVEI D,LIBPNT

PRGPRG:	MOVEM D,LODLIM#	;SAVE POINTER TO LIMIT
	MOVEM T,LODSTP#	;START FOR RESETTING
PRGBAK:	MOVEM T,LODPNT#	;AND START
	CAMN T,@LODLIM	;GOTTEN TO END YET?
	JRST PRGDON	;YES, DUMP IT
	SKIPN W,PRGDEV(T)	;IS DEVICE SPECIFIED?
	MOVSI W,(SIXBIT /DSK/)	;NO, DSK
	MOVEM W,ILD1	;WHERE WE INIT FROM
	MOVSI W,(SIXBIT /REL/)	;EXTENSION
	MOVEM W,DTIN1
	MOVE W,PRGFIL(T)
	MOVEM W,DTIN	;FILE NAME
	MOVE W,PRGPPN(T)	;THE PROJECT PROG
	MOVEM W,DTIN+3
	PUSH P,JRPRG	;A RETURN ADDRESS
	TLZ F,ISW	;FORCE NEW INIT
	HRRZ T,LODLIM
	CAIN T,LIBPNT	;WHICH ONE
	JRST LIBGO
	JRST LDF
PRGRET:	MOVE T,LODPNT	;RETURNS HERE, GET NEXT ONE
	AOBJN T,PRGBAK

PRGDON:	MOVE T,LODSTP	;RESTE POINTER IN CASE MORE ON OTHER LIBS
	MOVEM T,@LODLIM
JRPRG:	POPJ P,PRGRET	;PUSHED TO GET A RETURN ADDRESS

PRGFIL==1	;REL INDEX FOR FILE NAMES
PRGPPN==RELLEN+1	;AND FOR PPNS
PRGDEV==2*RELLEN+1	;AND FOR DEVICES
>	;END OF IFN SAILSW

SUBTTL	LDDT LOADS <SYS:DDT.REL> AND SETS SYMSW


IFN STANSW,<
LDDTQQ:	'RAID  '
	'NRAID '
	'RAID  '
	'ORAID '

LDDTQX:	TLO	N,DDSW+EXEQSW		;WILL START RAID AFTER LOADING
LDDTQ:	PUSH	P,D			;SAVE ARG
	PUSHJ	P,FSCN1			;SEE BELOW
;;%##% RHT MAKE /NV LOAD NRAID
	HRRZ	D,(P)			;GET ARGUMENT
	CAILE	D,3
	MOVEI	D,0
	MOVE	W,LDDTQQ(D)
IFN SORTSY,<	TRNN	D,1
		SETOM	DOSORT>		;FLAG TO SORT SYMBOLS TOO.
;;%##% ^

IFN DMNSW,<SETZM (P);ELSE>POP P,D	;/0D FOR DMN2 (BELOW) !?!
	JRST	LDDT11			;JOIN FORCES
>;IFN STANSW

LDDTX:
IFN ALGSW,<TRNE	F,ALGSW
	POPJ	P,>
	TLO	N,DDSW+EXEQSW		;T - LOAD AND GO TO DDT
LDDT:
IFN ALGSW,<TRNE	F,ALGFL
	POPJ	P,>
IFN DMNSW,<	PUSH	P,D		;SAVE INCASE /NNND >
	PUSHJ     P,FSCN1		;FORCE SCAN TO COMPLETION
	MOVSI     W,444464		;FILE IDENTIFIER <DDT>
LDDT11:	TLZ	F,SYMSW!RMSMSW	;DON'T LOAD DDT WITH LOCAL SYMBOLS
	PUSHJ     P,LDDT1
	PUSHJ     P,LDF		;LOAD <SYS:DDT.REL>
	TLO	F,SYMSW!RMSMSW		;ENABLE LOADING WITH SYMBOLS
IFN DMNSW,<	POP	P,D	;RESTORE D
	JRST	DMN2		;MOVE SYMBOL TABLE >
IFE DMNSW,<	POPJ	P,>

LDDT1:	MOVEM     W,DTIN		;STORE FILE IDENTIFIER
IFN PP,<MOVE	W,ILD1		;SAVE OLD DEV
	MOVEM	W,OLDDEV>
	MOVSI     W,637163		;DEVICE IDENTIFIER <SYS>
	MOVEM     W,ILD1		;STORE DEVICE IDENTIFIER
	TLZ	F,ISW+LIBSW+SKIPSW+REWSW	;CLEAR OLD FLAGS
LDDT2:	MOVSI     W,624554		;EXTENSION IDENTIFIER <.REL>
LDDT3:	MOVEM     W,DTIN1		;STORE EXTENSION IDENTIFIER
LDDT4:IFN PP,<EXCH W,PPN	;GET PROJ-PROG #
	MOVEM W,DTIN+3
	EXCH	W,PPN	;W MUST BE SAVED SINCE IT MAY BE USED LATER>
	POPJ	P,

SUBTTL	EOF TERMINATES LOADING OF A FILE

EOF:	MOVE	P,PDSAV		;RESTORE PUSHDOWN POINTER
EOF1:	TLZ F,SLIBSW!SKIPSW	;CLEAR ONE FILE LIB. SEARCH FLAG
IFN DIDAL,<TRZ	F,XFLG!LSTLOD	;CLEAR DIDAL FLAGS>
EOF2:	TLNE F,RMSMSW	;IF REMEMBER LOADING WITH SYMBOLS IS ON
	TLO F,SYMSW	;THEN RESTORE SYMBOL LOADING STATE
	POPJ	P,

;	FORCE SCAN TO COMPLETION, LOAD IF NECESSARY

FSCN:	PUSHJ     P,FSCN1		;FORCED LOAD BEFORE TEST
	TLNN	F,FULLSW		;TEST FOR OVERLAP
	POPJ	P,			;NO OVERLAP, RETURN
	MOVE	W,H 		;FETCH CORE SIZE REQUIRED
	SUBI W,1(S) ; COMPUT DEFICIENCY
	JUMPL     W,EOF2		;JUMP IF NO OVERLAP
	TLO	F,FCONSW		;INSURE TTY OUTPUT
	PUSHJ	P,PRQ			;START WITH ?
	PUSHJ     P,PRNUM0		;INFORM USER
	ERROR	7,</WORDS OF OVERLAP#/>
	JRST	LD2 		;ERROR RETURN

IFN SPCHN,<FSCN1A:	TLNN F,NSW
	PUSHJ P,LIBF>
FSCN1:	TLON	F,FSW		;SKIP IF NOT FIRST CALL TO FSCN
	TLNN	F,CSW+DSW+ESW	;TEST SCAN FOR COMPLETION
	POPJ	P,
FSCN2:	PUSHJ     P,LD5B1		;STORE FILE OR EXTENSION IDENT.

;	LOADER CONTROL, NORMAL MODE

LDF:	PUSHJ     P,ILD		;INITIALIZE LOADING

SUBTTL	LOAD SUBROUTINE

LOAD:	MOVEM   P,PDSAV		;SAVE PUSHDOWN POINTER
IFN WFWSW,<SETZM VARLNG		;LENGTH OF VARIABLE AREA-ADDED TO RELOC>
IFN ALGSW,<SETZM OWNLNG		;LENGTH OF OWN AREA-ADDED TO RELOC>
IFN FAILSW,<SETZM LFTHSW	;RESET LOAD LEFT HALF FIXUP SW>
LOAD1:	MOVE	P,PDSAV		;RESTORE PUSHDOWN POINTER
LOAD1A:	PUSHJ	P,WORD		;INPUT BLOCK HEADER WORD
	MOVNI	E,400000(W) 	;WORD COUNT - FROM RH OF HEADER
	HLRZ	A,W 		;BLOCK TYPE - FROM LH OF HEADER
IFN FAILSW,<SKIPN POLSW		;ERROR IF STILL DOING POLISH>
	CAIL	A,DISPL*2	;TEST BLOCK TYPE NUMBER
	JRST	LOAD4		;ERROR, ILLEGAL BLOCK TYPE
	TLNE	F,SKIPSW	;BLOCK OK - TEST LOAD STATUS
	JRST	LIB1		;RETURN TO LIB. SEARCH CONTROL
	HRRZ	T,LOAD2(A)	;LOAD RH DISPATCH ENTRY
	CAIL	A,DISPL		;SKIP IF CORRECT
	HLRZ	T,LOAD2-DISPL(A);LOAD LH DISPATCH ENTRY
	TLNE	F,FULLSW	;TEST CORE OVERLAP INDICATOR
	SOJG	A,HIGH0		;IGNORE BLOCK IF NOT TYPE 1
	JRST	@T		;DISPATCH TO BLOCK SUBROUTINE

;DISPATCH TABLE - BLOCK TYPES
IFE FAILSW,<POLFIX==LOAD4A
	LINK==LOAD4A>
IFE WFWSW,<LVARB==LOAD4A>
IFE DIDAL,<INDEX==LOAD4A>
IFE ALGSW,<ALGBLK==LOAD4A>

;DEC STANDARD NOW INCLUDES BLOCKS 16 AND 17 AS LDPRG AND LDLIB.  REG 3-23-74

LOAD2:	XWD	LOCD,	BLOCK0	;10,,0
	XWD	POLFIX,	PROG	;11,,1
	XWD	LINK,	SYM	;12,,2
	XWD	LVARB,	HISEG	;13,,3
	XWD	INDEX,	LIB30	;14,,4
	XWD	ALGBLK,	HIGH	;15,,5
	XWD	LDPRG,	NAME	;16,,6
	XWD	LDLIB,	START	;17,,7

	DISPL==.-LOAD2

;ERROR EXIT FOR BAD HEADER WORDS

LOAD4:	IFE K,<
	CAIN	A,400		;FORTRAN FOUR BLOCK
	JRST	F4LD>
LOAD4A:	MOVE	W,A		;GET BLOCK TYPE
	ERROR	,</ILL. FORMAT BLOCK TYPE !/>
	PUSHJ	P,PRNUM		;PRINT BLOCK TYPE
	JRST	ILC1		;PRINT SUBROUTINE NAME

SUBTTL	LOAD PROGRAMS AND DATA 		(BLOCK TYPE 1)

PROG:	MOVEI V,-1(W) 		;LOAD BLOCK LENGTH
	PUSHJ P,RWORD		;READ BLOCK ORIGIN
	ADD V,W 		;COMPUTE NEW PROG. BREAK
IFN REENT,<TLNN F,HIPROG
	JRST PROGLW	;NOT HIGH SEGMENT
PROG3:	CAMGE W,HVAL1	;CHECK TO SEE IF IN TOP SEG
	JRST LOWCOR
	MOVE T,JOBREL	;CHECK FOR OVERFLOW ON HIGH
	CAIL T,@X
	JRST PROG2
	PUSHJ P,HIEXP
	JRST FULLC
	JRST PROG3>

PROGLW:	MOVEI T,@X
	CAMG H,T	;COMPARE WITH PREV. PROG. BREAK
	MOVE H,T
	TLNE F,FULLSW
	JRST FULLC	;NO ERROR MESSAGE
IFN REENT,<CAML H,HVAL1
	JRST COROVL	;WE HAVE OVERFLOWED THE LOW SEGMENT
	CAMLE T,HILOW
	MOVEM T,HILOW	;HIGHEST LOW CODE LOADED INTO>
	CAILE H,1(S)  ; SKIP IF SUFFICIENT CORE AVAILABLE
IFN EXPAND,<JRST [PUSHJ P,XPAND>
		JRST FULLC
IFN REENT,<	TLNE F,HIPROG
		SUBI W,2000	;HISEG LOADING LOW SEG>
IFN EXPAND,<	JRST .-1]>
PROG2:	MOVE V,W
PROG1:	PUSHJ P,RWORD		;READ DATA WORD
IFN TEN30,<CAIN V,41	;CHANGE FOR 10/30 JOBDAT
	MOVEI V,JOB41	;JOB41 IS DIFFERENT
	CAIN V,74	;SO IS JOBDAT
	MOVEI V,JOBDDT>
IFN L,<	CAMGE V,RINITL	;CHECK FOR BAD STORE
	JRST [	CAIN V,JOBDDT	;SPECIAL HACK TO SET JOBDDT
		MOVEM W,LSPDDT	;FOR LISP LOADER - TVR
		JRST STLSPD ] >
	MOVEM     W,@X		;STORE DATA WORD IN PROG. AT LLC
STLSPD:	AOJA	V,PROG1		;ADD ONE TO LOADER LOC. COUNTER

IFN REENT,<
LOWCOR:	SUB V,HIGHX	;RELOC FOR PROPER
	ADD V,LOWX	;LOADING OF LOW SEQMENT
	SUB W,HIGHX
	ADD W,LOWX
	JRST PROGLW>

SUBTTL	LOAD SYMBOLS 			(BLOCK TYPE 2)

SYM:	PUSHJ	P,PRWORD	;READ TWO DATA WORDS
	PUSHJ	P,SYMPT;		PUT INTO TABLE
IFN REENT,<PUSHJ P,RESTRX>
	JRST	SYM

SYMPT:	TLNE C,200000	;GLOBAL REQUEST? WFW
	JUMPL C,SYM3	;CHECK FOR 60 NOT JUST HIGH BIT WFW
	TLNN C,100000	;LOCAL OR BLOCK NAME?
	TLNN	C,40000
	JRST	SYM1A		;LOCAL SYMBOL
;	TLNE C,100000
;	JRST SYM1B
	PUSHJ     P,SREQ		;GLOBAL DEF., SEARCH FOR REQUEST
	JRST	SYM2		;REQUEST MATCHES
	PUSHJ     P,SDEF		;SEARCH FOR MULTIPLE DEFINITIONS
	JRST	SYM1		;MULTIPLY DEFINED GLOBAL
	JRST	SYM1BG

;	PROCESS MULTIPLY DEFINED GLOBAL

SYM1:	CAMN	W,2(A)		;COMPARE NEW AND OLD VALUE
	POPJ	P,;
IFN L,<	EXCH W,2(A)	;I don't know about the rest of you guys, but I want to 
	>		; use the new value.  DWP 6/5/74
	AOS	MDG		;COUNT MULTIPLY DEFINED GLOBALS
	PUSHJ	P,PRQ		;START W/ ?
	PUSHJ     P,PRNAM		;PRINT SYMBOL AND VALUE
IFN RPGSW,<MOVE W,JOBERR	;RECORD THIS AS AN ERROR
	ADDI W,1
	HRRM W,JOBERR>
	MOVE	W,2(A)		;LOAD OLD VALUE
	PUSHJ     P,PRNUM		;PRINT OLD VALUE
	ERROR	7,</MUL. DEF. GLOBAL IN PROG.  !/>
	MOVE	C,SBRNAM	;GET PROGRAM NAME
	PUSHJ	P,PRNAME	;PRINT R-50 NAME
	ERROR	0,</#/>
	POPJ	P,		;IGNORE MUL. DEF. GLOBAL SYM

;	LOCAL SYMBOL

SYM1A:	TLNN	F,SYMSW		;SKIP IF LOAD LOCALS SWITCH ON
	POPJ	P,;		IGNORE LOCAL SYMBOLS
SYM1B:	CAIL	H,(S)		;STORE DEFINED SYMBOL
IFN EXPAND,<	PUSHJ P,XPAND7>
IFE EXPAND,<	JRST SFULLC>
SYM1C:	IFE K,<
	TLNE	N,F4SW;		FORTRAN FOUR REQUIRES A BLT
	PUSHJ 	P,MVDWN;	OF THE TABLES>
	MOVEI	A,-2(S)		;LOAD A TO SAVE INST. AT SYM2
	MOVE T,@GLBENP
;BUG TRAP
	TLNE C,040000		;Trap off globals
	TLNE C,300000
	JRST SYM1D
	HALT SYM1DG
;END BUG TRAP
SYM1D:	SUBI	S,2;		UPDATE UNDEFINED POINTER
	SUB B,[XWD 2,0]		;TO PREVENT PDLOV IF NO GLOBALS
	POP	B,2(A)		;MOVE UNDEFINED VALUE POINTER
	POP	B,1(A)		;MOVE UNDEFINED SYMBOL
	ADD B,[XWD 4,0]		;COMPENSATE FOR POP
	POP T,2(B)		;MOVE GLOBAL VALUE POINTER
	POP T,1(B)		;MOVE GLOBAL SYMBOL
SYM1E:	MOVEM W,2(T)		;STORE VALUE
	MOVEM C,1(T)		;STORE SYMBOL
	MOVEM T,@GLBENP
	POPJ	P,

;	GLOBAL SYMBOL

SYM1BG:	CAIL	H,(S)		;STORE DEFINED SYMBOL
IFN EXPAND,<	PUSHJ P,XPAND7>
IFE EXPAND,<	JRST SFULLC>
	IFE K,<
	TLNE	N,F4SW;		FORTRAN FOUR REQUIRES A BLT
	PUSHJ 	P,MVDWN;	OF THE TABLES>
	MOVEI	A,-2(S)		;LOAD A TO SAVE INST. AT SYM2
;BUG TRAP
	TLNE C,040000		;Trap off non-globals
	TLNE C,300000
	HALT SYM1D
;END BUG TRAP
SYM1DG:	SUBI	S,2;		UPDATE UNDEFINED POINTER
	TLC B,400000		;AVOID PDLOV IF NO GLOBALS YET
	POP	B,2(A)		;MOVE UNDEFINED VALUE POINTER
	POP	B,1(A)		;MOVE UNDEFINED SYMBOL
	TLC B,400000
	MOVEM   W,2(B)		;STORE VALUE
	MOVEM  C,1(B)		;STORE SYMBOL
	POPJ	P,

;	GLOBAL DEFINITION MATCHES REQUEST

SYM2:	PUSH	P,SYM2C	;NEXT MUST BE A SUBROUTINE FOR LATER, SET RETURN
SYM2B:	MOVE	V,2(A)		;LOAD REQUEST POINTER
	PUSHJ	P,REMSYM
	JUMPL V,SYM2W	;ADDITIVE REQUEST? WFW
	PUSHJ     P,SYM4A		;REPLACE CHAIN WITH DEFINITION
SYM2W1:	PUSHJ P,SREQ	;LOOK FOR MORE REQUESTS FOR THIS SYMBOL
	JRST SYM2B	;FOUND MORE
	MOVE A,SVA	;RESTORE A
SYM2C:	POPJ	P,SYM1DG	;RETURN, SEE SYM2 FOR USE OF ADDRESS

;	REQUEST MATCHES GLOBAL DEFINITION

SYM2A:	MOVE	V,W 		;LOAD POINTER TO CHAIN
	MOVE	W,2(A)		;LOAD VALUE
	JUMPL V,FIXWP	;HANDLE ATTITIVE REQUEST WFW
	JRST SYM4A

;	PROCESS GLOBAL REQUEST

SYM3:	TLNE	C,040000;		COMMON NAME
	JRST	SYM1B
	TLC	C,640000;		PERMUTE BITS FROM 60 TO 04
	PUSHJ     P,SDEF		;SEARCH FOR GLOBAL DEFINITION
	JRST	SYM2A		;MATCHING GLOBAL DEFINITION
	JUMPL W,SYM3X1	;ADDITIVE FIXUP WFW
	PUSHJ     P,SREQ		;SEARCH FOR EXISTING REQUEST WFW
	JRST	SYM3A		;EXISTING REQUEST FOUND WFW
SYM3X1:	TLNN W,100000	;CHECK SYMBOL TABLE FIXUP
	JRST	 SYM3X2	;NO
	MOVE	 V,1(B)	;MUST BE LAST SYMBOL DEFINED. GET SYMBOL
	XOR	 V,W		;CHECK FOR IDENTITY
	TDNE	 V,[XWD 77777,-1]	;BUT IGNORE HIGH 3 BITS
	POPJ	 P,		;NOT SAME, ASSUME NOT LOADED LOCAL
	MOVE V,1(B)		;Trap fixups to globals
	TLNE V,040000
	JRST SYM3X2		;We'll worry about finding the symbol at SYM2W
	HRRI	 W,2(B)		;GET LOCATION IN RIGHT HALF
	TLO	 W,1
	SUB	 W,HISTRT		;AND MAKE RELATIVE
;IFN FAILSW,<TLZ	W,040000>	;No longer needed, see SYM2W
SYM3X2:	CAIL	H,(S)		;STORE REQUEST IN UNDEF. TABLE WFW
IFN EXPAND,<	PUSHJ P,XPAND7>
IFE EXPAND,<	JRST SFULLC>
SYM3X:	IFE K,<
	TLNE	N,F4SW;		FORTRAN FOUR
	PUSHJ	P,MVDWN;		ADJUST TABLES IF F4>
	SUB	S,SE3		;ADVANCE UNDEFINED POINTER
	MOVEM     W,2(S)		;STORE UNDEFINED VALUE POINTER
	MOVEM     C,1(S)		;STORE UNDEFINED SYMBOL
	POPJ	P,;

;	COMBINE TWO REQUEST CHAINS

SYM3A:	SKIPL 2(A)	;IS IT ADDITIVE WFW
	JRST SYM3A1	;NO, PROCESS WFW
SYM3A4:	PUSHJ P,SDEF2	;YES, CONTINUE WFW
	JRST SYM3A	;FOUND ANOTHER WFW
	JRST SYM3X2	;REALLY NO CHAIN THERE WFW
SYM3A1:	SKIPE	V,2(A)	;IF ADDRESS OF CHAIN IS 0, THROW IT AWAY
	JRST	SYM3A2	;AND USE THE NEW ONE, ELSE ADD THE CHAINS
	MOVEM	W,2(A)	;W IS ADDRESS OF NEW CHAIN,STORE ON TOP OF OLD 0
	POPJ	P,
SYM3A2:	
SYM3A3:	MOVE A,2(A)
SYM3B:	HRRZ V,A
IFN L,<CAMGE V,RINITL
	HALT>
IFN REENT,<CAMGE V,HVAL1
	SKIPA X,LOWX
	MOVE X,HIGHX>
	HRRZ A,@X ; LOAD NEXT ADDRESS IN CHAIN
	JUMPN A,SYM3B  ; JUMP IF NOT THE LAST ADDR. IN CHAIN
	HRRM	W,@X		;COMBINE CHAINS
	POPJ	P,;

;WFW PATCH FOR ADDITIVE GLOBAL REQUESTS

FIXWP:	TLNN	 V,100000	;CHECK FOR SYMBOL TABLE FIXUP
	JRST	 FIXW
	MOVE	 T,1(B)	;SYMBOL FIXUP, MUST BE LAST SYMBOL DEFINED
	XOR	 T,V		;CHECK FO SAME
	TDNE	 T,[XWD 77777,-1]	;EXCEPT FOR HIGH CODE BITS
	POPJ	 P,		;ASSUME NON-LOADED LOCAL
	HRRI	 V,2(B)		;GET LOCATION
	SUBI	 V,(X)		;SO WE CAN USE @X
	JRST FIXW1
FIXW:	IFN REENT,<HRRZ T,V
	CAMGE T,HVAL1
	SKIPA X,LOWX
	MOVE X,HIGHX>
IFN L,<	HRRZ T,V
	CAMGE R,RINITL
	POPJ P,>
FIXW1:	TLNE	V,200000	;IS IT LEFT HALF
	JRST FIXWL
	MOVE T,@X	;GET WORD
	ADD T,W		;VALUE OF GLOBAL
	HRRM T,@X	;FIX WITHOUT CARRY
	MOVSI	D,200000	;SET UP TO REMOVE DEFERED INTERNAL IF THERE
	JRST	SYMFIX

FIXWL:	HRLZ	T,W		;UPDATE VALUE OF LEFT HALF
	ADDM	T,@X		;BY VALUE OF GLOBAL
	MOVSI	D,400000	;LEFT DEFERED INTERNAL
SYMFIX:	TLNN V,100000	;CHECK FOR SYMBOL TABLE FIXUP
	POPJ P,		;NO, RETURN
	ADDI V,(X)	;GET THE LOCATION
SYMFX1:	MOVE T,-1(V)	;GET THE SYMBOL NAME
	TLNN T,40000	;CHECK TO SEE IF INTERNAL
	POPJ P,		;NO, LEAVE
	ANDCAB D,-1(V)	;REMOVE PROPER BIT
	TLNE D,600000	;IS IT STILL DEFERED?
	POPJ P,		;YES, ALL DONE
	EXCH C,D	;NO, CHECK FOR A REQUEST FOR IT
	PUSHJ P,SREQ
	JRST CHNSYM	;YES, WILL HAVE TO CALL THE FIXUP ROUTINE
	MOVE C,D	;GET C BACK
	POPJ P,
CHNSYM:	PUSH P,D	;HAS THE OLD C IN IT
	PUSH P,W	;WE MAY NEED IT LATER
	MOVE W,(V)	;GET VALUE
	PUSHJ P,SYM2B	;CALL THE FOUND GLOBAL TO MATCH REQUEST ROUTINE
	POP P,W
	POP P,C		;RESTORE FOR CALLER
	POPJ P,		;AND GO AWAY

SYM2W:	TLNN V,100000	;SYMBOL TABLE?
	JRST SYM2WA
	TLNE V,40000	;GLOBAL?
	JRST [	EXCH C,V
		PUSHJ P,SDEF
		JRST [	MOVE C,V
			HRRI V,2(A)
			JRST SYM2WB ]
		EXCH C,V
		HALT . ]
	ADD V,HISTRT	;MAKE ABSOLUTE
SYM2WB:	SUBI V,(X)	;GET READY TO ADD X
	PUSHJ P,FIXW1
	JRST SYM2W1

SYM2WA:	IFN FAILSW,<
	TLNE V,40000	;CHECK FOR POLISH
	JRST POLSAT>
	PUSHJ P,FIXW	;DO FIXUP
	JRST SYM2W1	;AND LOOK FOR MORE REQUESTS

;END WFW PATCH

;	PATCH VALUES INTO CHAINED REQUEST

SYM4:	IFN L,<CAMGE V,RINITL
	POPJ P,>
IFN REENT,<CAMGE V,HVAL1
	SKIPA X,LOWX
	MOVE X,HIGHX>
	HRRZ	T,@X	;LOAD NEXT ADDRESS IN CHAIN
	HRRM	W,@X		;INSERT VALUE INTO PROGRAM
	MOVE	V,T
SYM4A:	JUMPN     V,SYM4		;JUMP IF NOT LAST ADDR. IN CHAIN
	POPJ	P,

IFE	K,<
MVDWN:	HRRZ T,MLTP
IFN EXPAND,<	SUBI T,2>
	CAIG	T,(H);		ANY ROOM LEFT?
IFN EXPAND,<	JRST	[PUSHJ P,XPAND>
			TLOA F,FULLSW
IFN EXPAND,<		JRST MVDWN
			POPJ P,]>
	TLNE	F,SKIPSW+FULLSW
	POPJ	P,	;	ABORT BLT
	HRREI	T,-2
	ADDM	T,PLTP;		ADJUST PROGRAMMER LABEL POINTER
	ADDM	T,BITP;		AND BIT TABLE POINTER
	ADDM	T,SDSTP;	FIRST DATA STATEMENT
	ADDM	T,LTC
	ADDM	T,ITC
	TLNE	N,SYDAT
	ADDM	T,V
	ADDB	T,MLTP;		AND FINALLY TO MADE LABEL TABLE
	HRLS	T;		SET UP BLT POINTER
	ADD	T,[XWD 2,0]
	BLT	T,(S)
	POPJ	P,
>

SUBTTL	HIGH-SEGMENT 			(BLOCK TYPE 3)
;THIS PROGRAM IS INTENDED FOR HI SEGMENT IF RUNNING ON A PDP-10.
; THIS BLOCK TYPE OCCURS AFTER ENTRY AND NAME BLOCKS.

HISEG:	PUSHJ	P,WORD		;GOBBLE UP A WORD.
	JUMPE	W,HISEG2	;MACRO V36
	PUSHJ	P,WORD		;GET THE OFSET
IFE REENT,<HISEG2==LOAD1A
	JUMPGE	W,LOAD1A	;NOT TWO SEG PROG.>
IFN REENT,<JUMPE W,HISEG2	;IGNORE ZERO
	JUMPG	W,HISEG3	;NEG. IF TWOSEG PSEUDO-OP>
	TRO	F,TWOFL		;SET FLAG
IFN REENT,<
	TRNE	F,NOHI!NOHI6	;TWO SEGMENTS LEGAL?
	JRST	ONESEG		;LOAD AS ONE SEGMENT
HISEG3:	HRRZ	D,W		;GET START OF HISEG 
	JUMPE	D,.+2		;NOT SPECIFIED
	PUSHJ	P,HCONT		;AS IF /H
HISEG2:	PUSHJ	P,HISEG1
	JRST	LOAD1		;GET NEXT BLOCK
FAKEHI:				;AS IF BLOCK TYPE 3
HISEG1:	TRNE F,NOHI!NOHI6	;LOAD REENT?
	POPJ P,
	TLOE F,HIPROG		;LOADING HI PROG
	POPJ P,			;IGNORE 2'ND HISEG
	TRON F,SEENHI		;HAVE WE LOADED ANY OTHER HI STUFF?
	PUSHJ P,SETUPH		;NO,SET UP HI SEG.
	MOVEM R,LOWR
	MOVE R,HIGHR
	HRRM R,2(N)		;CALL THIS THE START OF THE PROGRAM
	MOVE X,HIGHX
	POPJ P,

SETUPH:	MOVE X,HVAL1
	CAIGE X,-1		;SEE IF IT HAS BEEN CHANGED FROM ORIG
	JRST SEENHS		;YES, MUST HAVE SEEN /H
	MOVEI X,400000
	MOVEM X,HVAL1
	CAIG X,(H)		;HAVE WE RUN OVER WITH THE LOW SEG
	JRST COROVL
	ADDI X,JOBHDA
	HRLI X,W
	MOVEM X,HVAL
SEENHS:	MOVE X,HVAL
	MOVEM X,HIGHR
	HRRZ X,JOBREL
	SUB X,HVAL1
	ADDI X,1
	HRLI X,V
	MOVEM X,HIGHX
	POPJ P,

SETSEG:	TRZ F,NOHI!SEGFL	;ALLOW HI-SEG
	JUMPL D,.+2		;/-H TURNS OFF NOHI ONLY
	TRO F,SEGFL		;/1H FORCES  HI
	POPJ P,
>

ONESEG:	HLRZ	D,W		;GET LENGTH OF HISEG
	SUBI	D,(W)		;REMOVE OFSET
	JUMPLE	D,TWOERR	;LENGTH NOT AVAILABLE
	MOVEM	R,LOWR		;SAVE LOW SEGMENT RELOCATION
	ADDM	D,LOWR		;ADD TO LOW SEG RELOCATION
	HRRZM	W,HVAL1		;SO RELOC WILL WORK
	JRST	LOAD1		;GET NEXT BLOCK

TWOERR:	ERROR	7,</HIGH SEGMENT ILLEGAL#/>
	JRST	LDRSTR

SUBTTL	HIGHEST RELOCATABLE POINT 	(BLOCK TYPE 5)
SFULLC:	TLOE	F,FULLSW	;PREVIOUS OVERFLOW?
	JRST	FULLC		;YES, DON'T PRINT MESSAGE
	ERROR	,<?SYMBOL TABLE OVERLAP#?>
FULLC:	TLO	F,FULLSW	;CORE OVERLAP ERROR RETURN
IFE K,<	TLNE	N,F4SW
	POPJ	P,>
	JRST	LIB3		;LOOK FOR MORE
HIGH2:	PUSHJ	P,RWORD		;GET HISEG BREAK
	TRZ	F,TWOFL		;CLEAR FLAG NOW
IFE REENT,<	MOVE	R,LOWR
	JRST	HIGH2A>
IFN REENT,<	TRNE	F,NOHI!NOHI6	;SINGLE SEGMENT LOAD?
	JRST	[MOVE	R,LOWR	;YES,GET LARGER RELOC
		MOVE	W,HVAL	;ORIGINAL VALUE
		MOVEM	W,HVAL1	;RESET
		JRST	HIGH2A]	;CONTINUE AS IF LOW ONLY
	HRR	R,W		;PUT BREAK IN R
	CAMLE	R,HVAL
	MOVEM	R,HVAL
	MOVEM	R,HIGHR
	MOVE	R,LOWR		;NEXT WORD IS LOW SEG BREAK
	TLZ	F,HIPROG	;CLEAR HIPROG
	PUSHJ	P,PRWORD	;GET WORD PAIR
	HRR	R,C		;GET LOW SEG BREAK
	MOVEM	R,LOWR		;SAVE IT
	MOVE	R,HIGHR		;GET HIGH BREAK
	JRST	HIGHN3		;AND JOIN COMMON CODE>

HIGH0:	CAIE	A,4		; TEST FOR END BLOCK (OVERLAP)
	JRST	LIB30

HIGH:	TRNE	F,TWOFL		;IS THIS A TWO SEGMENT PROGRAM?
	JRST	HIGH2		;YES
HIGH2A:	PUSHJ	P,PRWORD	;READ TWO DATA WORDS.
IFN REENT,<	TLZE F,HIPROG
	JRST HIGHNP>
IFN WFWSW,<ADD C,VARLNG		;IF LOW SEG THEN VARIABLES GO AT END>
IFN ALGSW,<ADD	C,OWNLNG	;ADD IN LENGTH OF OWN BLOCK>
	CAMGE C,W	;CHECK 2ND WORD (LOC PROG BRK IF PRESENT)
	MOVE C,W
	HRR R,C		;SET NEW PROGRAM BREAK
HIGH31:	ADDI C,(X)
	CAIG H,(C)
	MOVEI H,(C)	;SET UP H
	CAILE	H,1(S)	;TEST PROGRAM BREAK
IFN EXPAND,<PUSHJ P,[	PUSHJ P,XPAND
			TLOA F,FULLSW
			JRST POPJM2
			POPJ	P,]>
IFE EXPAND,<TLO	F,FULLSW>
HIGH3:	MOVEI A,F.C
	BLT A,B.C
IFN REENT,<TRNE	F,NOHI!NOHI6	;ONE SEGMENT PROGRAM?
	JRST	HIGHN4		;YES
	HRLZ	W,HIGHR		;GET HIGH PROG BREAK
	JUMPE	W,[HRRZ	W,R	;NO HIGH SEGMENT YET
		JRST	.+2]	;SO USE LOW RELOCATION ONLY
	HRR	W,LOWR		;GET LOW BREAK
	SETZ	C,		;ZERO SYMBOL NAME
	PUSHJ	P,SYM1B		;PUT IN SYMBOL TABLE
	MOVEM	S,F.C+S		;SAVE NEW S AND B
	MOVEM	B,F.C+B		;INCASE OF ERROR
HIGHN4:>
	TLZ	F,NAMSSW	;RELAX, RELOCATION BLOCK FOUND
	TLNE	F,SLIBSW+LIBSW	;NORMAL MODE EXIT THROUGH LOAD1
	JRST	LIB 		;LIBRARY SEARCH EXIT
	JRST LOAD1
IFN REENT,<
HIGHNP:	HRR R,C
HIGHN1:	CAMLE R,HVAL
	MOVEM R,HVAL
	MOVEM R,HIGHR
HIGHN3:	PUSH P,W	;SAVE W,CONTAIN HIGHEST ABSOLUTE ADDRESS
	ADD W,LOWX	;LOC PROG BRK
	CAIGE H,(W)	;CHECK FOR TOP OF LOW CORE
	MOVEI H,(W)
	POP P,W		;RESTORE
	CAML H,HVAL1
	JRST COROVL	;OVERFLOW OF LOW SEGMENT
HIGHN2:	HRRZ R,HVAL
	SUB R,HVAL1
	ADD R,HISTRT
	CAMLE R,JOBREL
	JRST [	PUSHJ P,HIEXP
		JRST FULLC
		JRST HIGHN2	]
	MOVE R,LOWR
	MOVE X,LOWX
IFN WFWSW,<ADD R,VARLNG	;VARIABLES IN LOW SEG>
IFN ALGSW,<ADD R,OWNLNG	;OWN BLOCK IN LOW SEGMENT>
	HRRZ C,R
	CAIGE	C,(W)	;IS ABSOLUTE LOCATION GREATER
	HRR	R,W	;YES USE IT
	HRRZ 	C,R	;SET UP C AGAIN
	JRST HIGH31	;GO CHECK PROGRAM BREAK

SUBTTL	EXPAND HIGH SEGMENT

HIEXP:	TLNE	F,FULLSW
	POPJ	P,
IFN EXPAND,<PUSH P,Q>
	PUSH P,H
	PUSH P,X
	PUSH P,N
IFE K,<HRRZ X,MLTP
	TLNN N,F4SW>
	MOVEI X,1(S)
	HRRZ N,X
	SUB N,H
	CAILE N,1777
	JRST MOVHI
IFE EXPAND,<POPJ P,>
IFN EXPAND,<HRRZ N,JOBREL
	ADDI N,2000
	CAMG	N,ALWCOR
	CORE N,
	JRST XPAND6
	PUSHJ P,ZTOP
	POP P,N
	JRST XPAND3>

MOVHI:	MOVEI N,-2000(X)
	HRL N,X
	HRRZ X,JOBREL
	BLT N,-2000(X)
	PUSHJ P,ZTOP
	MOVNI H,2000
IFN EXPAND,<JRST XPAND8>
IFE EXPAND,<ADDM H,HISTRT
	ADDM H,S
	ADDM H,B
	ADDM H,HIGHX
	TLNE F,HIPROG
	ADDM H,-1(P)
	POP P,N
	SUBI N,2000	;ADJUST POINTER TO NAME
IFE K,<	TLNN F4SW
	JRST HIXP1
	ADDM H,PLTP
	ADDM H,BITP
	ADDM H,SDSTP
	ADDM H,MLTP
	TLNE N,SYDAT
	ADDM H,V
HIXP1:>
	POP P,X
	POP P,H
	AOS (P)
	POPJ P,>

ZTOP:	HRRZ N,JOBREL
	MOVEI X,-1776(N)
	HRLI X,-1777(N)
	SETZM -1(X)
	BLT X,(N)
	POPJ P,>

SUBTTL	PROGRAM NAME 			(BLOCK TYPE 6)

NAME:	TLOE	F,NAMSSW	;HAVE WE SEEN TWO IN A ROW?
	JRST	NAMERR		;YES, NO END BLOCK SEEN
	PUSHJ	P,PRWORD	;READ TWO DATA WORDS
	MOVEM	C,SBRNAM	;SAVE SUBROUTINE NAME
NCONT:	HLRE	V,W		;GET COMPILER TYPE
	HRRZS	W		;CLEAR TYPE
	JUMPL	V,.+3
	CAIGE	V,CMPLEN-CMPLER	;ONLY IF LEGAL TYPE
	XCT	CMPLER(V)	;DO SPECIAL FUNCTION
	TLOE	N,COMFLG	;SKIP IF COMMON NOT PREV. SET
	JRST	NAME1		;SIZE OF COMMON PREV. SET
	MOVEM   W,COMSAV	;STORE LENGTH OF COMMON
	JUMPE   W,[		;JUMP IF NO COMMON IN THIS JON
		MOVE T,@GLBENP	;We'll need the global pointer (but if we get
		JRST NAME2 ]	;it and call XPAND, we'll lose big!).
	HRRI	R,@R		;FIRST PROGRAM SET LOAD ORIGIN
NAME1:	CAILE	H,-1(S)		;TEST FOR AVAIL. SYMBOL SPACE
IFN EXPAND,<	PUSHJ P,XPAND7>
IFE EXPAND,<	JRST SFULLC>
	MOVE T,@GLBENP		;Pick up pointer to end of globals
	SUBI	S,2 		;UPDATE UNDEF. TABLE POINTER
	SUB B,[XWD 2,0]		;TO PREVENT PDLOV
	POP	B,2(S)
	POP	B,1(S)
	ADD B,[XWD 4,0]		;COMPENSATE FOR POPS
	POP T,2(B)
	POP T,1(B)
NAME1A:	HRRZ	V,N 		;POINTER TO PREVIOUS NAME
	SUBM	T,V 		;COMPUTE RELATIVE POSITIONS
	HRLM	V,2(N)		;STORE FORWARD POINTER
	HRR	N,T 		;UPDATE NAME POINTER
NAME2:	MOVEM   C,1(T)		;STORE PROGRAM NAME
	HRRZM	R,2(T)		;STORE PROGRAM ORIGIN
	MOVEM T,@GLBENP		;Save up pointer to end of globals
	CAMG	W,COMSAV	;CHECK COMMON SIZE
IFE REENT,<JRST	LIB3		;COMMON OK>
IFN REENT,<JRST [TRNE F,SEGFL	;LOAD LOW IN HI-SEG
		PUSHJ P,FAKEHI	;YES
		JRST	LIB3]>
	SKIPA	C,COMM
ILC:	MOVE	C,1(A)		;NAME
	PUSH	P,C		;SAVE COMMON NAME
	ERROR	,</ILL. COMMON !/>
	POP	P,C
	PUSHJ	P,PRNAME
ILC1:	SKIPN	SBRNAM
	JRST	ILC2
	ERROR	0,</ PROG. !/>
	MOVE	C,SBRNAM	;RECOVER SUBROUTINE NAME
	PUSHJ	P,PRNAME
ILC2:	ERROR	0,</ #/>
	JRST	LD2

NAMERR:	SETZM	DTIN		;CLEAR WRONG FILE NAME FOR MESSAGE
	ERROR	,</NO END BLOCK !/>
	JRST	ILC1


;COMPILER TYPE - DO SPECIAL FUNCTION FOR IT

DEFINE CTYPE (CONDITION,TRUE,FALSE)
<IFN CONDITION,<TRUE>
IFE CONDITION,<FALSE>>

CMPLER:	CTYPE 1,JFCL,JFCL		;0 MACRO
	CTYPE K-1,<TRO F,F4FL>,JFCL	;1 FORTRAN
	CTYPE 1,<TRO F,COBFL>,JFCL	;2 COBOL
	CTYPE ALGSW,<PUSHJ P,ALGNAM>,JFCL	;3 ALGOL
					;4 NELIAC
					;5 PL/1
CMPLEN:


SUBTTL	STARTING ADDRESS 		(BLOCK TYPE 7)


START:	PUSHJ	P,PRWORD	;READ TWO DATA WORDS
	TLNN	N,ISAFLG	;SKIP IF IGNORE SA FLAG ON
	HRRZM	C,STADDR	;SET STARTING ADDRESS
IFN STANSW&REENT,<
	MOVE W,DTIN+2
	TLNN N,ISAFLG
	MOVEM W,PRGCRD		;SAVE DATE & TIME FOR SETCRD>
IFN NAMESW,<
	MOVE	W,DTIN		;PICK UP BINARY FILE NAME
	TLNN N,ISAFLG
	MOVEM	W,PRGNAM	;SAVE IT
	MOVE	W,1(N)		;SET UP NAME OF THIS PROGRAM
	TLNN	N,ISAFLG	;DONT SET NAME IF IGNORING SA'S
	PUSHJ	P,LDNAM>
	PUSHJ	P,PRWORD	;**OBSCURE RETURN TO LOAD1**

IFN REENT,<
RESTRX:	TLNE F,HIPROG
	SKIPA X,HIGHX
	MOVE X,LOWX
	POPJ P,>

SUBTTL	ONE PASS LOCAL DEFINITION 	(BLOCK TYPE 10)

				;PMP PATCH FOR LEFT HALF FIXUPS
IFN FAILSW!WFWSW,<
LOCDLH:	IFN L,<CAMGE V,RINITL
	POPJ P,>
IFN REENT,<CAMGE V,HVAL1
	SKIPA X,LOWX
	MOVE X,HIGHX>
	HLRZ T,@X	;LOAD NEXT ADDRESS IN CHAIN
	HRLM W,@X	;INSERT VALUE INTO PROGRAM
	MOVE V,T
LOCDLF:	JUMPN V,LOCDLH	;JUMP IF NOT LAST ADDR. IN CHAIN
	POPJ	P,>
IFN FAILSW,<
LOCDLI:	PUSHJ	P,LOCDLF
IFN REENT,<PUSHJ P,RESTRX>
	AOSA LFTHSW	;TURN OFF LEFT HALF FIX SW (WAS -1) AND SKIP
LOCDLG:	SETOM LFTHSW	;TURN ON LEFT HALF FIX SW>
			;END PMP PATCH
LOCD:	PUSHJ     P,RWORD		;READ ONE DATA WORD
	HLRZ	V,W 		;STORAGE POINTER IN LEFT HALF
IFN FAILSW,<
	SKIPE LFTHSW	;LEFT HALF CHAINED? PMP
	JRST LOCDLI	;YES PMP
	CAMN W,[-1]	;LEFT HALF NEXT? PMP
	JRST LOCDLG	;YES, SET SWITCH PMP>
	PUSHJ     P,SYM4A		;LINK BACK REFERENCES
IFN REENT,<PUSHJ P,RESTRX>
	JRST	LOCD

SUBTTL	LVAR FIX-UP 			(BLOCK TYPE 13)
IFN WFWSW,<
LVARB:	PUSHJ P,PRWORD	;THE FIRST TWO WORDS IN THE BLOCK
	MOVEM W,VARLNG	;AR SPECIAL. SECOND IS LENGTH OF VARIABLES
IFN REENT,<	TLNE F,HIPROG
		MOVE C,LOWR	;USE LOW RELOC IF LOADING HI SEG>
		;ELSE C HAS RELOC FOR THIS PROGRAM, USE IT
	HRRZM C,VARREL	;THIS IS LOCATION 0 OF VARIABLE AREA
LVLP:	PUSHJ P,PRWORD	;THINGS COME IN PAIRS
	TLNE C,200000	;BIT ON IF SYMBOL TABLE FIXUP
	JRST LVSYM
	HLRZ V,W	;NO GET LOC FROM LEFTH HALF OF SECOND
	ADD W,VARREL	;AND RELOCATE VARIABLE
	TLNE C,400000	;ON FOR LEFT HALF
	JRST	[PUSHJ P,LOCDLF	;TAKE CARE OF IT
IFN REENT,<	JRST LVLCOM]	;RESET X>
IFE REENT,<	JRST LVLP]	;MUST BE LOW SEG X OK>
	PUSHJ P,SYM4A	;RIGHT HALF CHAIN
IFN REENT,<LVLCOM:	PUSHJ P,RESTRX>
	JRST LVLP
LVSYM:	MOVE V,B	;GET SYMBOL TABLE POINTER
	ADD C,VARREL	;VALUE IS IN FIRST WORD FOR THESE
	TLZ W,740000	;MAKE SURE NO BITS ON
	ADDI V,2	;CORRECT POINTER TO SYMBOL TABLE
SRSYM:	MOVE A,-1(V)	;GET A NAME
	TLZN A,740000	;CHECK FOR PROGRAM NAME
	JRST LVLP	;LEAVE (PROBABLY A NON-LOADED LOCAL)
	CAMN A,W	;IS IT THE RIGHT ONE??
	JRST LVSYMD	;YES
	ADD V,SE3	;CHECK NEXT ONE
	JUMPL V,SRSYM	;BUT ONLY IF SOME ARE THERE
	JRST LVLP	;GIVE UP
LVSYMD:	TLNE C,400000	;WHICH HALF??
	JRST LVSYML	;LEFT
	ADD C,(V)	;ADDITIVE FIXUP
	HRRM C,(V)
	MOVSI D,200000	;DEFERED BITS
LVSM1:	PUSHJ P,COMSFX	;GO TAKE CARE OF IT
	JRST LVLP	;NEXT PLEASE
LVSYML:	HRLZS C
	ADDM C,(V)	;WE DON'T HAVE TO WORRY ABOUT OVERFLOW HERE
	MOVSI D,400000	;LEFT DEFERED BITS
	JRST LVSM1	;GO WORRY ABOUT DEFERED INTERNALS>

SUBTTL	FAIL LOADER
;ONLY LIST IF FAILSW=1
	XLIST
IFN FAILSW,<LIST>
REPEAT 0,<IF POLISH FIXUPS CONTAIN GLOBAL REQUESTS WHICH
CAN NOT BE SATISFIED WHEN THEY ARE SEEN, THEY MUST BE
SAVED UNTIL THESE GLOBAL SYMBOLS BECOME DEFINED.
THE POLISH FIXUP IS SAVED IN THE UNDEFINED TABLE (POINTED
TO BY S). THE FIXUP IS SAVED IN TWO WORD BLOCKS THE FIRST
WORD OF WHICH (THE ONE WHICH WOULD NORMALL CONTAIN THE SYMBOL)
HAS SPECIAL BITS ON SO IT WILL NOT BE FOUND BY A SEARCH FOR
A GLOBAL REQUEST. SINCE THE UNDEFINED TABLE MAY BE
SHUFFELED INTO A RANDOM ORDER, IT IS NOT POSSIBLE TO KEEP
ALL OF A POLISH FIXUP TOGETHER OR TO HAVE POINTERS IN
THE USUAL SENCE FROM ONE TWO WORD BLOCK TO ANOTHER.
SUFFICIENT INFORMATION IS THEREFORE GIVEN TO DETERMINE
WHAT THE FIRST WORD OF THE NEXT DESIRED BLOCK IS AND THIS
BLOCK IS FOUND BY SEARCHING THE UNDEFINED TABLE FOR A MATCH.
EACH POLISH FIXUP WHICH IS ENTERED INTO THE UNDEFINED
TABLE IS GIVEN A UNIQUE NUMBER CALLED THE "HEAD NUMBER".
EACH ELEMENT OF THE FIXUP (EITHER OPERAND OR OPERATOR)
IS ASSIGNED A NUMBER CALLED THE "OP NUMBER". THUS
THE OP NUMBER AND HEAD NUMBER TOGETHER DETERMINE
A SPECIFIC ELEMENT OF A SPECIFIC FIXUP. EACH ELEMENT
(TWO WORD BLOCK) IS ARRANGED AS FOLLOWS:
WORD 1:
	BITS 0-4  THESE ARE THE USUAL CODE BITS OF A RADIX50
		SYMBOL AND CONTAIN 44 TO DISTINGUISH
		AN ELEMENT OF A POLISH FIXUP FROM OTHER
		SYMBOLS IN THE UNDEFINED TABLE
	BITS 5-17 THE HEAD NUMBER OF THIS FIXUP
	BITS 18-30 THE OP NUMBER OF THIS ELEMENT
	BITS 31-35 THE OPERAND FOR THIS ELEMENT 
		OPERAND 2 INDICATES A WORD OF DATA
WORD 2:
	IF THE OPERAND IS 2 THIS WORD CONTAINS THE DATA

	IF THIS IS NOT A DATA OPERATOR THEN THE LEFT AND
	RIGHT HALVES OF THIS WORD POINT TO THE TWO OPERANDS
	THE CONTENTS OF THE HALF WORD IS THE RIGHT HALF
	OF THE FIRST WORD OF THE BLOCK POINTED
	TO. THUS THE LEFT HALF OF THE FIRST WORD COMBINED
	WITH ONE OF THESE HALF WORDS IS THE FIRST WORD
	OF THE BLOCK POINTED TO AND CAN BE FOUND BY SEARCHING

EACH FIXUP ALSO HAS A HEADER BLOCK. THIS BLOCK CONTAINS THE
FOLLOWING INFORMATION:
WORD 1:
	BITS 0-17 0
	BITS 18-21  44 
	BITS 22-35 THE HEAD NUMBER OF THIS FIXUP

WORD 2:
	BITS 0-17 A COUNT OF THE NUMBER OF UNDEFINED
		GLOBALS REMAINING IN THIS FIXUP
	BITS 18-35 A HALF WORD POINTER OF THE
		SAME TYPE FOUND IN OTHER ELEMENTS POINTING
		TO THE FIRST ELEMENT OF POLISH
		WHICH WILL BE THE STORE OPERATOR

THE REQUESTS FOR THE GLOBAL SYMBOLS NEEDED BY THE FIXUP ARE
ENTERED AS FOLLOWS:

WORD 1:
	BITS 0-4  04
	BITS 5-35  RADIX 50 FOR THE NAME OF THE SYMBOL
(NOTE THIS IS JUST A STANDARD GLOBAL REQUEST)

WORD 2:
	BITS 0-4 44 (THIS IDENTIFIES IT AS "ADITIVE TYPE"
		AND BIT 4 INDICATES POLISH)
	BITS 5-17 THE HEAD NUMBER OF THE FIXUP
		(THIS GIVES ENOUGH INFORMATION TO FIND THE HEADER
		BLOCK AND UPDATE THE COUNT WHEN THE REQUEST IS
		SATISFIED)
	BITS 18-35  A HALF WORD POINTER TO THE ELEMENT OF THE
		FIXUP INTO WHICH THE VALUE OF
		THE SYMBOL SHOULD BE STORED
>

IFN FAILSW,<	;POLISH FIXUPS FOR FAIL	(BLOCK TYPE 11)

Comment 

REG 10/22/74 TO ADD 3 NEW POLISH OPERATORS.  JFFO,ABS, AND REMAINDER.

JFR 3-28-76
New sub items in Polish loader blocks (type 11):

Store operators:

	-7	MOVEM op1,(op2)
	-10	store op1 as the value of link (block type 12) op2
		[linkend of -op2 if op2 negative]

Operators:
	20	maximum
	21	minimum
	22	if op1=op2 then -1 else 0
	23	fetch value of link  op1  [linkend -op1 if op1 negative]
	24	definition characteristic--consider operand as
		RADIX50 and return 0 if unknown, 1 if known but
		undefined, -1 if known and defined
	25	skip  op2  half-words of Polish if op1 neq op2;
		skip forwards if op2 positive and backwards(LINK-10 only)
		if op2 negative; the skipping is done after relocation
		words are taken into account; in any case, return 0.
	26	skip to just beyond the next END block if op1 neq 0
	27	MOVE--get loader's current idea of what will be in
		location  op1  when loading is complete (not counting
		linkend processing)

Each Polish block must contain a store operator, even if it is a dummy
and will never be executed.  Link numbers are specified as half-word
quantities.  To fetch the current value of link 1 and store as linkend 2,
the polish block would look like
	11,,3	;polish block,,3 data words
	0	;no relocation
	23,,0	;fetch link/linkend,,half-word operand is next
	1,,-10	;link #1,,store link/linkend
	-2,,0	;linkend #2,,filler




PDLOV:	SKIPE POLSW	;PDL OV ARE WE DOING POLISH?
	JRST COMPOL	;YES
	ERROR ,</PUSHDOWN OVERFLOW#/>
	JRST LD2
COMPOL:	ERROR ,</POLISH TOO COMPLEX#/>
	JRST LD2


;READ A HALF WORD AT A TIME

RDHLF:	TLON N,HSW	;WHICH HALF
	JRST NORD
	PUSHJ P,RWORD	;GET A NEW ONE
	TLZ N,HSW	;SET TO READ OTEHR HALF
	MOVEM W,SVHWD	;SAVE IT
	HLRZS W		;GET LEFT HALF
	POPJ P,		;AND RETURN
NORD:	HRRZ W,SVHWD	;GET RIGHT HALF
	POPJ P,		;AND RETURN


POLFIX:	MOVE D,[IOWD PPDL,PPDB]	;SET UP THE POLISH PUSHDOWN LIST
	SETOM POLSW	;WE ARE DOING POLISH
	TLO N,HSW	;FIX TO READ A WORD THE FIRST TIME
	SETOM GLBCNT	;NUMBER OF GLOBALS IN THIS FIXUP
	SETOM OPNUM	;NUMBER OF OPERANDS AND OPERATORS THIS FIXUP
	MOVEI W,MXPLOP	;START WITH FAKE OPERATOR SO STORE WILL NOT HACK

RPOL0:	PUSH D,W		;SAVE OPERATOR IN STACK
	MOVE V,DESTB-3(W)	;GET NUMBER OF OPERANDS NEEDED
	MOVEM V,SVSAT		;ALSO SAVE IT
RPOL:	PUSHJ P,RDHLF		;GET A HALF WORD
	TRNE W,400000		;IS IT A STORE OP?
	JRST STOROP		;YES, DO IT
IFN WFWSW,<CAIN W,15
MAKE ASSEMBLY ERROR MESSAGE - THIS CODE NO LONGER WORKS WITH FAIL - REG 
	JRST	[PUSHJ P,RDHLF	;THIS TRICK FOR VARIABLES
		ADD W,VARREL	;HOPE SOMEONE HAS DONE
		HRRZ C,W	;A BLOCK TYPE 13
		JRST HLFOP]>
	CAIGE W,3		;0,1,2 ARE OPERANDS
	JRST OPND
	CAILE W,MXPLOP-1	;OPERATOR IN RANGE?
	JRST LOAD4A		;ILL FORMAT
	JRST RPOL0		;GO STACK OPERATOR

;HANDLE OPERANDS. THIS GETS COMPLICATED BECAUSE OF THE PRESENCE OF
;GLOBAL REQUESTS

OPND:	MOVE A,W	;GET THE OPERAND TYPE HERE
	PUSHJ P,RDHLF	;THIS IS AT LEAST PART OF THE OPERAND
	MOVE C,W	;GET IT INTO C
	JUMPE A,HLFOP	;0 IS HALF-WORD OPERAND
	PUSHJ P,RDHLF	;NEED FULL WORD, GET SECOND HALF
	HRL C,W		;GET HALF IN RIGHT PLACE
	MOVSS C		;WELL ALMOST RIGHT
	SOJE A,HLFOP	;1 IS FULL WORD, 2 IS GLOBAL REQUEST
	PUSHJ P,SDEF	;SEE IF IT IS ALREADY DEFINED
	JRST 	[MOVE C,2(A)	;YES, WE WIN
		JRST HLFOP]
	AOSN GLBCNT	;NO, INCREMENT NUMBER OF GLOBALS THIS FIXUP
	AOS HEADNM	;INCREMENT FIXUP NUMBER IF FIRST GLOBAL
	AOS W,OPNUM	;GET AN OPERAND NUMBER
	LSH W,5		;SPACE FOR TYPE
	IORI W,2	;TYPE 2 IS GLOBAL 
	HRL W,HEADNM	;GET FIXUP NUMBER
	PUSHJ P,SYM3X2	;AND PUT INTO UDEFINED AREA ALONG WITH NAME
	MOVE C,W	;ALSO PUT THAT PART OF THE FIXUP IN
	PUSHJ P,SYM3X2
	SKIPA A,[400000]	;SET UP GLOBAL FLAG
HLFOP:	MOVEI A,0	;VALUE OPERAND FLAG
HLFOP1:	SOJL V,CSAT	;ENOUGH OPERANDS SEEN?
	PUSH D,C	;NO, SAVE VALUE(OR GLOBAL NAME)
	HRLI A,400000	;PUT IN A VALUE MARKER
	PUSH D,A	;TO THE STACK
	JRST RPOL	;GET MORE POLISH


;HAVE ENOUGH OPERANDS FOR THE CURRENT OPERATOR

CSAT:	HRRZS A		;KEEP ONLY THE GLOBAL-VALUE HALF
	SKIPN SVSAT	;IS IT UNARY
	JRST UNOP	;YES, NO NEED TO GET 2ND OPERAND
	HRL A,(D)	;GET GLOBAL VALUE MARKER FOR 2ND OP
	POP D,W
	POP D,W		;VALUE OR GLOBAL NAME
UNOP:	POP D,V		;OPERATOR
	JUMPN A,GLOB	;IF EITHER IS A GLOBAL HANDLE SPECIALLY
	XCT OPTAB-3(V)	;IF BOTH VALUES JUST XCT
	MOVE C,W	;GET THE CURRENT VALUE
SETSAT:	SKIPG V,(D)	;IS THERE A VALUE IN THE STACK
	MOVE V,-2(D)	;YES, THIS MUST BE THE OPERATOR
	MOVE V,DESTB-3(V)	;GET NUMBER OF OPERANDS NEEDED
	MOVEM V,SVSAT	;SAVE IT HERE
	SKIPG (D)	;WAS THERE AN OPERAND
	SUBI V,1	;HAVE 1 OPERAND ALREADY
	JRST HLFOP1	;GO SEE WHAT WE SHOULD DO NOW

;HANDLE GLOBALS
GLOB:	TRNE A,-1	;IS IT IN RIGHT HALF
	JRST TLHG	;NO, NEED TO PUT THIS VALUE INTO THE FIXUP LIST
	PUSH P,W	;SAVE FOR A WHILE
	MOVE W,C	;THE VALUE
	AOS C,OPNUM	;GET AN OPERAND NUMBER
	LSH C,5		;AND PUT IN TYPE
	IORI C,2	;VALUE TYPE
	HRL C,HEADNM	;THE FIXUP NUMBER
	PUSHJ P,SYM3X2
	POP P,W		;RETRIEVE THE OTHER VALUE
TLHG:	SKIPE SVSAT	;WAS THIS A UNARY OPERATOR
	TLNE A,-1	;WAS THERE A GLOBAL IN LEFT HALF
	JRST GLSET
	PUSH P,C	;SAVE THE FIRST OPERAND
	AOS C,OPNUM	;SEE ABOVE
	LSH C,5
	IORI C,2
	HRL C,HEADNM
	PUSHJ P,SYM3X2
	MOVE W,C
	POP P,C

GLSET:	EXCH C,W	;GET THEM IN THE OTHER ORDER
	HRL W,C		;SET UP THE OPERATOR LINK
	AOS C,OPNUM
	LSH C,5		;SPACE FOR THYPE
	IOR C,V		;THE OPERATOR
	HRL C,HEADNM
	PUSHJ P,SYM3X2	;INTO THE UNDEF LIST
	MOVEI A,400000	;SET UP AS A GLOBAL VALUE
	JRST SETSAT	;AND SET UP FOR NEXT OPERATOR

;FINALLY WE GET TO STORE THIS MESS

STOROP:	MOVE T,-2(D)	;THIS SHOULD BE THE FAKE OPERATOR
	CAIE T,MXPLOP	;IS IT?
	JRST LOAD4A	;NO, ILL FORMAT
	HRRZ T,(D)	;GET THE VALUE TYPE
	CAILE W,-7
	JUMPN T,GLSTR	;AND TREAT GLOBALS SPECIAL
	MOVE A,W	;THE TYPE OF STORE OPERATOR
	CAIL W,-6
	CAILE W,-4
	 JRST .+2	;NOT A SYMBOL TABLE STORE
	PUSHJ P,FSYMT	;SYMBOL TABLE STORE.  (MAY CLOBBER A TO ZERO)
	PUSHJ P,RDHLF	;GET THE ADDRESS
	MOVE V,W	;SET UP FOR FIXUPS
	POP D,W		;GET THE VALUE
	POP D,W		;AFTER IGNORING THE FLAG
	PUSHJ P,@STRTAB+10(A)	;CALL THE CORRECT FIXUP ROUTINE
COMSTR:	SETZM POLSW	;ALL DONE WITH POLISH
IFN REENT,<PUSHJ P,RESTRX>
	MOVE T,OPNUM	;CHECK ON SIZES
	MOVE V,HEADNM
	CAIG V,477777
	CAILE T,17777
	JRST COMPOL	;TOO BIG, GIVE ERROR
	PUSHJ P,RWORD	;THIS SHOULD GET US OUT (I.E RUN OUT COUNT)
	JRST LOAD4A	;IF NOT, SOMETHING IS WRONG

STRTAB:	EXP T11LNK,T11MVM,ALSYM,LFSYM,RHSYM,ALSTR,LOCDLF,SYM4A,FAKESY

GLSTR:	MOVE A,W
	CAIGE A,-3
	PUSHJ P,FSYMT	;SYMBOL TABLE STORE OP.  (MAY CLOBBER A TO ZERO)
	PUSHJ P,RDHLF	;GET THE STORE LOCATION
	MOVEI A,MXPLOP+10(A)	;REFORM TO MAKE LARGE POSITIVE INDEX TO OPTAB
	POP D,V		;GET VALUE
	POP D,V
	HRLM V,W	;SET UP STORAGE ELEMENT
	AOS C,OPNUM
	LSH C,5
	IOR C,A
	HRL C,HEADNM
	PUSHJ P,SYM3X2
	MOVE W,C	;NOW SET UP THE HEADER
	AOS V,GLBCNT	;WHICH HAS NUMBER OF GLOBALS
	HRLM V,W
	HRRZ C,HEADNM
	PUSHJ P,SYM3X2
	JRST COMSTR	;AND FINISH

ALSTR1:

IFN L,<	CAMGE V,RINITL
	POPJ P,>

IFN REENT,<CAMGE V,HVAL1
	SKIPA X,LOWX
	MOVE X,HIGHX>

	HRRZ T,@X
	MOVEM W,@X	;FULL WORD FIXUPS
	MOVE V,T
ALSTR:	JUMPN V,ALSTR1
	POPJ P,

;NUMBER OF ARGS-1 FOR EACH POLISH OPERATOR. AND 100 TO TERMINATE LIST
DESTB:	EXP 1,1,1,1,1,1,1,1,0,0,0,1,0,1,1,1,0,0,1,0,0,100

OPTAB:	ADD W,C
	SUB W,C
	IMUL W,C
	IDIV W,C
	AND W,C
	IOR W,C
	LSH W,(C)
	XOR W,C
	SETCM W,C
	MOVN W,C
	PUSHJ P,JFFOOP
	PUSHJ P,REMOP
	MOVM W,C
	PUSHJ P,MAXOP
	PUSHJ P,MINOP
	PUSHJ P,EQOP
	PUSHJ P,LNKOP
	PUSHJ P,DEFOP
	PUSHJ P,SKPOP
	PUSHJ P,SKEOP
	PUSHJ P,MOVOP
MXPLOP==.-OPTAB+3		;1 MORE THAN LARGEST LEGAL OPERATOR NUMBER
	REPEAT 11,<JRST STRSAT>	;11 STORE OPERATORS,
				;-1 TO -10 & 0 (SEE FSYMT&FNOLOC)
				;SEE ALSO GLSTR

JFFOOP:	PUSH P,C+1		;JFFO OP (LIKE ^L IN MACRO-10)
	JFFO C,.+2
	MOVEI C+1,44
	MOVE W,C+1
	POP P,C+1
	POPJ P,

REMOP:	IDIV W,C		;REMAINDER
	MOVE W,C
	POPJ P,

MAXOP:	CAMGE W,C
	 MOVE W,C
	POPJ P,

MINOP:	CAMLE W,C
	 MOVE W,C
	POPJ P,

EQOP:	CAME	W,C
	 TDZA W,W
	SETO W,
	POPJ P,

LNKOP:	HRREI C,(C)		;SIGN EXTEND
	JUMPGE	C,.+2
	 SKIPA W,[HLRZ W,LINKTB(C)]	;FETCH LINK END
	MOVE W,[HRRZ W,LINKTB(C)]	;FETCH LINK
	MOVM C,C
	CAILE C,20
	 JRST LOAD4A	;RANGE CHECK
	XCT W
	POPJ P,

DEFOP:			;DEFINITION STATUS OF SYMBOL IN C
	MOVEI W,1	;ASSUME WE'VE SEEN IT BUT IT'S UNDEFINED
	PUSHJ P,SDEF	;LOOK FOR MATCH OF SYMBOL IN C
	SKIPA W,[-1]	;IS DEFINED
	PUSHJ P,SREQ	;NOT DEFINED. IS IT REQUESTED?
	POPJ P,		;YES, SO RETURN 1
	MOVEI W,0	;NO, SO RETURN 0
	POPJ P,

SKPOP:		;SKIP (C) HALFWORDS OF POLISH IF (W) NEQ 0, RETURN 0
	TDZN W,W
	 POPJ P,	;W WAS ZERO
	JUMPL C,LOAD4A	;WE CANT GO BACKWARDS
	JUMPE C,.-2	;FOR SKIP OF ZERO WORDS
	PUSH P,C	;SAVE COUNT ON STACK
	PUSHJ P,RDHLF	;READ A HALF WORD
	SOSLE (P)	;DECR COUNT
	 JRST .-2	;NOT DONE YET
	POP P,W		;ADJUST STACK, LOAD ZERO RETURN VALUE
	POPJ P,

SKEOP:		;SKIP TO BEYOND NEXT END BLOCK IF (C) NEQ 0
	MOVE W,C
	TDZN W,W
	 POPJ P,	;OPERAND WAS ZERO
	JRST .+2	;JUMP INTO LOOP
	PUSHJ P,RWORD	;GET NEXT WORD
	TRNE E,377777	;HAS PRESENT BLOCK ENDED?
	 JRST .-2	;NO
	SETZM POLSW	;DONE LOADING POLISH
SKEOP2:	PUSHJ P,WORD	;GET HEADER WORD
	HLRZ C,W	;BLOCK TYPE
	CAIE C,5	;END?
	 JRST SKEOP1	;NO
	MOVNI E,400000(W)	;CONTROL WORD
	PUSHJ P,RWORD	;READ WORD OF END BLOCK
	JRST .-1	;UNTIL DONE
SKEOP1:	MOVEI C,(W)	;WORD COUNT
	JUMPE C,SKEOP2	;NOISE WORD
	CAIG C,22	;ONE SUBBLOCK?
	 AOJA C,SKE.1	;YES, COUNT ITS RELOC BITS
	IDIVI C,22	;WHOLE BLOCKS
	IMULI C,23	;WORDS IN WHOLE BLOCKS
	JUMPE C+1,.+2	;IF NO REMAINDER
	ADDI C,1(C+1)	;PARTIAL BLOCK HAS RELOC BITS
SKE.1:
	CAML C,BUFR2	;DOES BLOCK OVERLAP BUFFERS?
	SOJA C,SKE32	;YES,ALLOW FOR INITIAL ILDB
	ADDM C,BUFR1	;ADD TO BYTE POINTER
	MOVNS C		;NEGATE
	ADDM C,BUFR2	;TO SUBTRACT C FROM WORD COUNT
	JRST SKEOP2	;GET NEXT BLOCK
SKE32:	SUB C,BUFR2	;ACCOUNT FOR REST OF THIS BUFFER
	PUSHJ P,WORD+1	;GET ANOTHER BUFFERFUL
	JRST SKE.1	;TRY AGAIN


MOVOP:	MOVEI V,(C)	;ADDRESS
IFN REENT,<
	CAMGE V,HVAL1	;CHECK SEG ADDR
	 SKIPA X,LOWX
	MOVE X,HIGHX
>;IFN REENT
	MOVE W,@X
IFN REENT,<
	PUSHJ P,RESTRX
>;IFN REENT
	POPJ P,

FSYMT:	PUSHJ P,RDHLF	;FIRST HALF OF SYMBOL
	HRL V,W
	PUSHJ P,RDHLF
	HRR V,W
	PUSH D,A	;SAVE STORE TYPE
	PUSHJ P,RDHLF	;GET BLOCK NAME
	HRL C,W
	PUSHJ P,RDHLF
	HRR C,W
	TLO C,140000	;MAKE BLOCK NAME
	PUSHJ P,SDEF	;FIND IT
	CAMN A,@GLBENP
	JRST FNOLOC	;MUST NOT BE LOADING LOCALS
FSLP:	LDB C,[POINT 32,-1(A),35]	;GET NAME
	CAMN C,V
	JRST FNDSYM
	SUB A,SE3
	CAME A,@GLBENP	;ALL DONE?
	JRST FSLP	;NO
FNOLOC:	POP D,A
	MOVEI A,0	;SET FOR A FAKE FIXUP (CALLS FAKESY BY USING STRTAB+6)
	AOS (P)
	POPJ P,

FNDSYM:	MOVEI W,(A)	;LOC OF SYMBOL
	SUB W,HISTRT
	POP D,A
	AOS (P)
	POPJ P,

LFSYM:	ADD V,HISTRT	;STORE IN LEFT HALF OF SYMBOL VALUE
	HRLM W,(V)
	MOVSI D,400000	;LEFT HALF
	JRST COMSFX

RHSYM:	ADD V,HISTRT	;STORE IN RIGHT HALF OR SYMBOL VALUE
	HRRM W,(V)
	MOVSI D,200000
	JRST COMSFX

FAKESY:	POPJ P,		;IGNORE SYMBOL TABLE STORES TO NON-EX SYMBOLS.

T11LNK:	HRREI V,(V)	;SIGN EXTEND
	JUMPGE V,.+2
	 SKIPA C,[HRLM W,@LINKTB(V)]	;LINKEND
	MOVE C,[HRRM W,@LINKTB(V)]	;LINK
	MOVM V,V
	CAIL V,20
	 JRST LOAD4A
	XCT C
	POPJ P,

T11MVM:
IFN REENT,<
	CAMGE V,HVAL1	;CHECK SEG ADDR
	 SKIPA X,LOWX
	MOVE X,HIGHX
>;IFN REENT
	MOVEM W,@X
IFN REENT,<
	PUSHJ P,RESTRX
>;IFN REENT
	POPJ P,

POLSAT:	PUSH P,C	;SAVE SYMBOL
	MOVE C,V	;POINTER
	PUSHJ P,SREQ	;GO FIND IT
	SKIPA
	JRST LOAD4A	;SOMETHING IS ROTTEN IN DENMARK
	MOVEM W,2(A)	;STORE VALUE
	HLRZS C		;NOW FIND HEADER
	PUSHJ P,SREQ
	SKIPA
	JRST LOAD4A
	HRLZI V,-1	;AND DECREMENT COUNT
	ADDB V,2(A)
	TLNN V,-1	;IS IT NOW 0
	JRST PALSAT	;YES, GO DO POLISH
	POP P,C		;RESTORE SYMBOL
	JRST SYM2W1	;AND RETURN

PALSAT:	PUSH P,W	;SAVE VALUE
	MOVEM C,HDSAV	;SAVE THE HEADER NUMBER
	MOVE D,[IOWD PPDL,PPDB]	;SET UP A PDL
	MOVE C,V	;GET THE POINTER
	HRL C,HDSAV	;AND THE FIXUP NUMBER
	PUSHJ P,REMSYM	;REMOVE THE HEADER FORM EXISTANCE
	PUSHJ P,SREQ	;GO FINE THE NEXT LINK
	SKIPA
	JRST LOAD4A	;LOSE
	ANDI C,37	;GET OPERATOR TYPE
	HRRZ V,2(A)	;PLACE TO STORE
	PUSH D,V
	PUSH D,[XWD 400000,0]
	PUSH D,C	;THIS HAD BETTER BE A STORE OR WE ARE IN TROUBLE
	HLRZ C,2(A)	;GET POINTER TO POLISH CHAIN
PSAT1:	PUSHJ P,REMSYM	;REMOVE SYMBOL
PSAT2:	HRL C,HDSAV	;GET FIXUP NUMBER
	PUSHJ P,SREQ	;LOOK FOR IT
	SKIPA
	JRST LOAD4A
	ANDI C,37	;THE OPERATOR NUMBER
	CAIN C,2	;IS IT AN OPERAND?
	JRST PSOPD	;YES, GO PROCESS
	PUSH D,C	;YES STORE IT
	SKIPN DESTB-3(C)	;IS IT UNARY
	JRST PSUNOP	;YES
	HLRZ C,2(A)	;GET FIRST OPERAND
	HRLI C,600000	;AND MARK AS VALUE
	PUSH D,C
PSUNOP:	HRRZ C,2(A)	;OTHER OPERAND
	JRST PSAT1	;AND AWAY WE GO

PSOPD:	MOVE C,2(A)	;THIS IS A VALUE
	PUSHJ P,REMSYM	;GET RID OF THAT PART OF THE CHAIN
PSOPD1:	SKIPG V,(D)	;IS THERE A VALUE IN THE STACK
	JRST PSOPD2	;YES, TAKE GOOD CARE OF IT
COMOP:	POP D,V		;NO, GET THAT OPERATOR OUT OF THERE
	XCT OPTAB-3(V)	;AND DO IT
	MOVE C,W	;GET RESULT IN RIGHT PLACE
	JRST PSOPD1	;AND TRY FOR MORE

PSOPD2:	TLNE V,200000	;IS IT A POINTER
	JRST DBLOP	;YES, NEEDS MORE WORK
	MOVE W,C	;NO, ONE WE HAVE IS FIRST OPND, GET IT INTO W
	POP D,C		;VALUE POINTER
	POP D,C		;2ND OPERAND INTO C
	JRST COMOP	;GO PROCESS OPERATOR

DBLOP:	EXCH C,(D)	;PUT VALUE IN STACK AND RETRIEV POINTER
	PUSH D,[XWD 400000,0]	;MARK AS VALUE
	JRST PSAT2	;AND GO LOOK FOR MORE TROUBLE

;LINK AND LINKEND BLOCKS ARE DONE HERE.
LINK:	PUSHJ P,PRWORD	;GET TWO WORDS
	JUMPLE C,ENDLNK	;THIS IS AN END OF LINK WORD
	CAILE C,20	;IS IT IN RANGE?
	JRST LOAD4A
	HRRZ V,W	;GET THE ADDRESS
IFN REENT,<
	CAMGE	V,HVAL1		;CHECK HISEG ADDRESS
	SKIPA	X,LOWX		;LOW SEGMENT
	MOVE	X,HIGHX		;HIGH SEGMENT BASE
>;IF REENT
	HRRZ W,LINKTB(C)	;GET CURRENT LINK
IFN L,<	CAML V,RINITL	;LOSE>
	HRRM W,@X	;PUT INTO CORE
	HRRM V,LINKTB(C)	;SAVE LINK FOR NEXT ONE
IFN REENT,<
	PUSHJ	P,RESTRX	;RESTORE X
>;IF REENT
	JRST LINK	;GO BACK FOR MORE

ENDLNK:	MOVNS C		;GET ENTRY NUMBER
	JUMPE C,LOAD4A	;0 IS A LOSER
	CAILE C,20	;CHECK RANGE
	JRST LOAD4A
	HRLM W,LINKTB(C)	;SAVE END OF LINK INFO
	JRST LINK	;MORE

STRSAT:	MOVE W,C	;GET VALUE TO STORE IN W
	MOVE C,V	;GET OPERATOR HERE
	POP D,V
	POP D,V		;GET ADDRESS TO STORE
	PUSHJ P,@STRTAB-MXPLOP(C)
IFN REENT,<PUSHJ P,RESTRX>
	POP P,W	;RESTORE THINGS
	POP P,C
	JRST SYM2W1

ALSYM:	ADD V,HISTRT
	MOVEM W,(V)
	MOVSI D,600000
>;IFN FAILSW (PAGE 57)
	LIST		;END OF FAILSW CODE
IFN FAILSW!WFWSW,<
COMSFX:	IFN REENT,<PUSHJ P,SYMFX1	;WAS IFE, I THINK THAT'S WRONG -- DCS
	JRST RESTRX>
IFE REENT,<JRST SYMFX1>>		;WAS IFN, I THINK THAT'S WRONG -- DCS

REMSYM:	MOVE T,1(S)
	MOVEM T,1(A)
	MOVE T,2(S)
	MOVEM T,2(A)
	ADD S,SE3
	MOVEM A,SVA
	POPJ P,


SUBTTL LIBRARY INDEX 			(BLOCK TYPE 14)

	COMMENT	*	DIRECT ACCESS LIBRARY SEARCH MODE
	INDEX WRITTEN BY FUDGE2.SEE DIDAL DOC (100-540-001-00)
	DESIGN AND CODING BY D.M.NIXON	JUL-AUG 1970
	*

IFN DIDAL,<

INDEX8:	POP	P,LSTBLK	;SET UP LSTBLK FOR NEXT PROG
	PUSHJ	P,WORD		;READ FIRST WORD
	HLRZ	A,W		;BLOCK TYPE ONLY
	CAIE	A,14		;IS IT AN INDEX?
	JRST	INDEXE		;NO, ERROR
	JRST	INDEX9		;DON'T SET FLAG AGAIN

INDEX0:	TRO	F,XFLG		;SIGNAL INDEX IN CORE
	MOVEI	A,1		;START ON BLOCK 1 (DSK)
	HRROM	A,LSTBLK	;BUT INDICATE AN INDEX
	MOVE	A,ILD1		;INPUT DEVICE
	DEVCHR	A,
	TLNE	A,100		;IS IT A DTA?
	TRO	F,DTAFLG	;YES
INDEX9:	MOVEI	A,AUX+2		;AUX BUFFER
	HRLI	A,4400		;MAKE BYTE POINTER
	MOVEM	A,ABUF1		;AND SAVE IT
	HRL	A,BUFR1		;INPUT BUFFER
	BLT	A,AUX+201	;STORE BLOCK
	TRO	F,LSTLOD	;AND FAKE LAST PROG READ
INDEX1:	ILDB	T,ABUF1
	HLRE	A,T		;GET WORD COUNT
	JUMPL	A,INDEX3	;END OF BLOCK IF NEGATIVE
	CAIE	A,4		;IS IT ENTRY
	JRST	INDEX
	HRRZS	T		;WORD COUNT ONLY
INDEX2:	ILDB	C,ABUF1		;GET NEXT SYMBOL
	TLO	C,040000	;
	PUSHJ	P,SREQ		;SEARCH FOR IT
	SOJA	T,INDEX4	;REQUEST MATCHES
	SOJG	T,INDEX2	;KEEP TRYING
	ILDB	T,ABUF1		;GET POINTER WORD
	TRZN	F,LSTLOD	;WAS LAST PROG LOADED?
	JRST	INDEX1		;NO
	TRNN	F,DTAFLG	;ALWAYS SAVE IF DTA???
	SKIPL	LSTBLK		;SKIP IF LAST BLOCK WAS AN INDEX
	MOVEM	T,LSTBLK	;SAVE POINTER FOR CALCULATIONS
	JRST	INDEX1		;GET NEXT PROG

INDEX4:	ADDM	T,ABUF1
	ILDB	A,ABUF1
	PUSH	P,A		;SAVE THIS BLOCK
	TROE	F,LSTLOD	;DID WE LOAD LAST  PROG?
	JRST	[SKIPGE	LSTBLK	;WAS LAST BLOCK AN INDEX?
		JRST	NXTBLK	;YES, SO GET NEXT ONE
		MOVEM	A,LSTBLK
		JRST	LOAD1]	;NEXT PROG IS ADJACENT
	HRRZ	T,LSTBLK	;GET LAST BLOCK NUMBER
	CAIN	T,(A)		;IN THIS BLOCK?
	JRST	THSBLK		;YES
NXTNDX:	TRNE	F,DTAFLG	;DIFFERENT TEST FOR DTA
	JRST	NXTDTA		;CHECK IF NEXT BUFFER IN CORE
	CAIN	T,-1(A)		;NEXT BLOCK?
	JRST	NXTBLK		;YES,JUST DO INPUT
INDEX5:	USETI	1,(A)		;SET ON BLOCK
	WAIT	1,		;LET I/O FINISH
	MOVSI	C,(1B0)		;CLEAR RING USE BIT IF ON
; ***** THE EQUIV. OF THE NEXT INSTR. MAY WELL BE IN LATER VERSIONS.
; ***** IT WAS MISSING, AND FOULED UP THE INDEX STUFF. (DCS 7-7-71)
	HLLM	C,BUFR		;INDICATE VIRGIN BUFFER
	HRRZ	T,BUFR
	SKIPL	(T)
	JRST	NXTBLK		;ALL DONE NOW
	ANDCAM	C,(T)		;CLEAR USE BIT
	HRRZ	T,(T)		;GET NEXT BUFFER
	JRST	.-4		;LOOP

NXTDTA:	WAIT	1,		;LET I/O RUN TO COMPLETION
	HRRZ	T,BUFR		;GET POINTER TO CURRENT BUFFER
	HLRZ	T,1(T)		;FIRST DATA WORD IS LINK
	CAIE	T,(A)		;IS IT BLOCK WE WANT?
	JRST	INDEX5		;NO
NXTBLK:	IN	1,
	JRST	NEWBLK		;IT IS NOW
	JRST	WORD3		;EOF OR ERROR

NEWBLK:	MOVE	A,(P)		;GET CURRENT BLOCK
	JUMPL	A,INDEX8	;JUST READ AN INDEX
	HLRZS	A		;GET WORD COUNT
COMMENT *  DCS -- 3/15/71
	This code required modification to work with DEC's FUDGE2
  (with /X) at Stanford.  I don't know the formats, so I don't know
  if the bugs are unique to Stanford.
	In particular, the special 0 test seems to cause all the
  trouble -- removing it fixed it.  However, my fix may well foul
  up with Dectapes (see the SPR for "details?").
*
COMMENT  JFR 9-24-75	Fix to work with corrected FUDGE2.
	SKIPL	LSTBLK		;WAS LAST BLOCK AN INDEX?
	 JRST	INDEX6		;NO
	HRRZ	T,AUX+3		;GET FIRST ENTRY BLOCK TYPE COUNT
	HRRZ	T,AUX+4(T)	;GET FIRST POINTER WORD
	MOVEM	T,LSTBLK	;SOME WHERE TO STORE IT
	JRST	INDEX6
IFN 0,<	;JFR
; 0 TEST REMOVED HERE -- DCS
	SKIPL	LSTBLK		;WAS LAST BLOCK AN INDEX?
	AOJA	A,INDEX6	;NO, ALWAYS ONE WORD OUT THEN
	HRRZ	T,AUX+3		;GET FIRST ENTRY BLOCK TYPE COUNT
	HRRZ	T,AUX+4(T)	;GET FIRST POINTER WORD
	MOVEM	T,LSTBLK	;SOME WHERE TO STORE IT
	HRRZ	T,(P)		;GET CURRENT BLOCK NUMBER
	CAME	T,LSTBLK		;SAME BLOCK
	AOJA	A,INDEX6	;NO
	TRNN	F,DTAFLG	;BUFR2 OK IF DTA
	SOS	BUFR2		;ONE WORD TOO MANY THOUGH
	JRST	INDEX6		;YES, WORD COUNT WILL BE CORRECT
; IF A IS 0, INDEX6INDEX7 -- DCS
>;IFN 0	JFR

THSBLK:	SUB	A,LSTBLK	;GET WORD DIFFERENCE
	MOVSS	A		;INTO RIGHT HALF
INDEX6:	ADDM	A,BUFR1
	MOVNS	A
	ADDM	A,BUFR2
INDEX7:	POP	P,LSTBLK	;STORE THIS AS LAST BLOCK READ
	JRST	LOAD1

INDEX3:	HRRE	A,T		;GET BLOCK # OF NEXT INDEX
	JUMPL	A,EOF		;FINISHED IF -1
	PUSH	P,T		;STACK THIS BLOCK
	HRRZ	T,LSTBLK	;GET LAST BLOCK
	JRST	NXTNDX		;CHECK IF NEXT BUFFER IN CORE

INDEX:	IN	1,		;GET NEXT BUFFER
	SOSA	BUFR2		;O.K. RETURN, BUT 1 WORD TOO MANY
	JRST	WORD3		;ERROR OR EOF
	PUSHJ	P,WORD		;READ FIRST WORD
INDEXE:	TRZE	F,XFLG		;INDEX IN CORE?
	TTCALL	3,[ASCIZ /LIBRARY INDEX INCONSISTENT - CONTINUING
/]				;WARNING MESSAGE
	JRST	LOAD1A+1	;AND CONTINUE
>

SUBTTL	ALGOL OWN BLOCK (TYPE 15)

IFN ALGSW,<
ALGBLK:	PUSHJ P,RWORD		;READ 3RD WORD
	HLRZ	V,W		;GET START OF OWN BLOCK
	MOVEI	C,(W)		;GET LENGTH OF OWN BLOCK
	MOVEM	C,OWNLNG	;SAVE IT TO FIX RELOC AT END
	PUSHJ	P,ALGB2		;FIX AND CHECK PROG BREAK
	ADDI	V,(R)		;RELOCATE
	MOVEI	W,(V)		;GET CURRENT OWN ADDRESS
	EXCH	W,%OWN		;SAVE FOR NEXT TIME
	MOVEM	W,@X		;STORE LAST OWN ADDRESS IN LEFT HALF
ALGB1:	PUSHJ	P,RWORD		;GET DATA WORD
	HLRZ	V,W		;GET ADDRESS TO FIX UP
	HRRZS	W		;RIGHT HALF ONLY
	ADD	W,%OWN		;ADD IN ADDRESS OF OWN BLOCK
	ADDM	W,@X		;FIX UP RIGHT HALF
	JRST	ALGB1		;LOOP TIL DONE

ALGNAM:	JUMPE	W,CPOPJ		;NOT ALGOL MAIN PROG
	TROE	F,ALGFL		;SET ALGOL SEEN FLAG
	JRST	ALGER1		;ONLY ONE ALGOL MAIN PROG ALLOWED
IFN REENT,<TRNN F,SEENHI	;ANYTHING IN HIGH SEGMENT?>
	CAME	R,[XWD W,JOBDA]	;ANYTHING LOADED IN LOW SEGMENT?
	JRST	ALGER2		;YES, ERROR ALSO
	SETZM	%OWN		;INITIALISE OWN AREA POINTER
IFN REENT,<TRO	F,VFLG		;DEFAULT RE-ENTRANT OP-SYSTEM>
ALGB2:	ADDI	H,(W)		;FIX PROG BREAK
IFN REENT,<CAML	H,HILOW
	MOVEM	H,HILOW		;HIGHEST LOW CODE LOADED>
	CAILE	H,1(S)		;SKIP IF SUFFICIENT CORE AVAILABLE
IFN EXPAND,<JRST [PUSHJ P,XPAND>
		JRST	FULLC
IFN EXPAND,<	JRST	.+1]>
	POPJ	P,

ALGER1:	ERROR	,</ONLY ONE ALGOL MAIN PROGRAM ALLOWED#/>
	JRST	LD2

ALGER2:	ERROR	,</ALGOL MAIN PROGRAM MUST BE LOADED FIRST#/>
	JRST	LD2

>

SUBTTL	SAIL BLOCK TYPE 16 AND 17

COMMENT * BLOCK TYPE 16 AND 17. SIXBIT FOR  FIL,PPN,DEV
IN THE BLOCK. SEARCH TABLE FOR ALREADY REQUESTED. IF NOT
ENTER REQUEST. ORIGINAL CODE BY DCS REWRITTEN BY WFW*

LDPRG:	MOVEI D,PRGFLS-1	;SET UP SOMETHING WE CAN SEARCH WITH
	MOVE W,PRGPNT	;AND CURRENT POINTER
	PUSHJ P,LDSAV	;GO ENTER (WILL NOT RETURN IF RUNS OUT)
	MOVEM D,PRGPNT
	JRST LDPRG	;BACK FOR MORE
LDLIB:	MOVEI D,LIBFLS-1
	MOVE W,LIBPNT
	PUSHJ P,LDSAV
	MOVEM D,LIBPNT
	JRST LDLIB	;LOOKS JUST LIKE THE LAST ONE, DOESN'T IT

LDSAV:	HRLI D,-RELLEN-1	;GET AOBJN SET UP
	MOVEM W,LODPN2#	;SAV IT
	PUSHJ P,PRWORD	;GET FILE,PPN
	MOVE A,W	;SAVE ONE
	PUSHJ P,RWORD	;AND DEVICE
FILSR:	CAMN D,LODPN2
	JRST FENT	;HAVE GOTTEN THERE, ENTER FILE
	CAME C,PRGFIL(D)	;CHECK FOR MATCH
	JRST NOMT	;NOT FILE
	CAME A,PRGPPN(D)
	JRST NOMT	;NO PPN
	CAME W,PRGDEV(D)
NOMT:	AOBJN D,FILSR	;AND NOT DEVICE SHOULD ALWAYS JUMP
	MOVE D,LODPN2
	POPJ P,		;JUST RETURN CURRENT POINTER
FENT:	MOVE D,LODPN2	;ENTER IT
	AOBJP D,WRONG	;THAT IS IF NOT TOO MANY
	MOVEM C,PRGFIL-1(D)	;HAVE ALREADY INDEXED
	MOVEM A,PRGPPN-1(D)	;HENCE THE -1
	MOVEM W,PRGDEV-1(D)
	POPJ P,
WRONG:	ERROR ,</TOO MANY DEMANDED FILES#/>
	JRST LD2

SUBTTL	SYMBOL TABLE SEARCH SUBROUTINES

;	ENTERED WITH SYMBOL IN C
;	RETURN IS WITH POINTER IN A IF MATCHING SYMBOL FOUND
;	OTHERWISE, A SKIP ON RETURN OCCURS

;	Rewritten by TVR

SREQ:	JUMPGE  S,CPOPJ1	;JUMP IF NO UNDEF. SYMBOLS
	MOVE   A,S 		;LOAD REQUEST SEARCH POINTER
	JRST SDEF1
SDEF:	MOVE	A,B 		;LOAD DEF. SYMBOL SEARCH POINTER
	TLNE C,040000		;Is it a global?
	TLNE C,300000
	MOVE A,@GLBENP		;Yes, use global pointer
SDEF1:	TLNE N,F4SW		;FORTRAN search can be faster
	JRST SDEFF4
	PUSH P,T		;Save T just in case
	MOVE T,C		;Keep around half-killed for compare
	TLC T,400000
SDEF1A:	CAMN C,1(A)		;Compare with symbol
	JRST SDEFRT		;Gotcha!  Non-skip return
	CAMN T,1(A)
	JRST [	TLO C,400000	;If suppressed, set same in symbol
		MOVEM C,1(A)	;table
		JRST SDEFRT ]
	ADD A,SE3
	JUMPL A,SDEF1A		;End test, try next symbol 
	AOS -1(P)		;Symbol not found skips on return
SDEFRT:	POP P,T			;Restore T
	POPJ P,
SDEF2:	ADD A,SE3		;WFW jumps into middle of old symbol table
	JRST SDEF1		;search routines, we'll comply
SDEFF4:	CAMN C,1(A)		;A faster loop for FORTRASH
	POPJ P,
	ADD A,SE3
	JUMPL A,SDEFF4
IFE K,<	JRST	CPOPJ1		;SYMBOL NOT FOUND SKIPS ON RETURN>
IFN K,<
CPOPJ1:	AOS	(P)
	POPJ	P,>

SUBTTL	RELOCATION AND BLOCK INPUT

PRWORD: PUSHJ   P,RWORD		;READ A WORD PAIR
	MOVE	C,W 		;LOAD C WITH FIRST DATA WORD
	TRNE	E,377777		;TEST FOR END OF BLOCK
	JRST	RWORD1		;INPUT SECOND WORD OF PAIR
	MOVEI   W,0 		;NO SECOND WORD, ASSUME ZERO
	POPJ	P,

RWORD:	TRNN	E,377777	;TEST FOR END OF BLOCK
	JRST	LOAD1		;RETURN TO LOAD THE NEXT BLOCK
RWORD1: AOBJN   E,RWORD2	;JUMP IF DATA WORD NEXT
	PUSHJ   P,WORD		;READ CONTROL WORD
	MOVE	Q,W 		;DON'T COUNT RELOCATION WORDS
	HRLI	E,-22		;SET RELOCATION WORD BYTE COUNT
RWORD2:	PUSHJ   P,WORD		;READ INPUT WORD
	JUMPGE  Q,RWORD3	;TEST LH RELOCATION BIT
	TRNN	F,TWOFL		;POSSIBLE TWO SEGMENTS?
	JRST	RWORD5		;NO
	MOVSS	W
	PUSHJ	P,CHECK		;USE CORRECT RELOCATION
	HRRI	W,@R
	MOVSS	W
	JRST	RWORD3		;AND TEST RIGHT HALF
RWORD5:	HRLZ	T,R
	ADD	W,T 		;LH RELOCATION
RWORD3:	TLNN	Q,200000	;TEST RH RELOCATION BIT
	JRST	RWORD4		;NOT RELOCATABLE
	TRNE	F,TWOFL		;POSSIBLE TWO SEGMENTS?
	PUSHJ	P,CHECK		;USE CORRECT RELOCATION
	HRRI	W,@R		;RH RELOCATION
RWORD4:	LSH	Q,2
	POPJ	P,

;this kludge decides whether to use HISEG or LOWSEG relocation.
;addresses greater than HVAL1-NEGOFF (NEGOFF=400) are given
;high segment relocation.

CHECK:	MOVE	T,HVAL1		;START OF HISEGMENT
	CAIG	T,NEGOFF(W)	;IN HISEG?
	JRST	CHECK1
	HRRI	W,@LOWR		;USE LOW SEG RELOC
	JRST	CPOPJ1		;SKIP RETURN

CHECK1:	PUSH	P,W		;DON'T CLOBBER LEFT HALF
	SUBI	W,(T)		;REMOVE HIGH SEGMENT OFSET
	HLL	W,(P)
	SUB	P,[1,,1]
	POPJ	P,

SUBTTL	PRINT STORAGE MAP SUBROUTINE

PRMAP:	CAIN	D,1		;IF /1M PRINT LOCAL SYMBOLS
	TROA	F,LOCAFL	;YES,TURN ON FLAG
	TRZ	F,LOCAFL	;CLEAR JUST IN CASE
	PUSHJ	P,FSCN1		;LOAD OTHER FILES FIRST
	PUSHJ	P,CRLFLF	;START NEW PAGE
	HRRZ	W,R
IFN REENT,<CAIG	W,JOBDA	;LOADED INTO LOW SEGMENT
	JRST	NOLOW		;DON'T PRINT IF NOTHING THERE>
	PUSHJ     P,PRNUM0
IFE REENT,<ERROR 7,<?IS THE PROGRAM BREAK@?>>
IFN REENT,<ERROR 7,<?IS THE LOW  SEGMENT BREAK@?>
	PUSHJ	P,CRLF		;CR-LF ON ALL BUT TTY	
NOLOW:	MOVE	W,HVAL		;HISEG BREAK
	CAMG	W,HVAL1		;HAS IT CHANGED
	JRST	NOHIGH		;NO HI-SEGMENT
	TLO	F,FCONSW	;FORCE OUT HI-SEG BREAK ALSO
	PUSHJ	P,PRNUM0
	ERROR	7,<?IS THE HIGH SEGMENT BREAK@?>
	PUSHJ	P,CRLF
NOHIGH:>
IFE NAMESW,<	MOVE	W,DTOUT	;OUTPUT NAME >
IFN NAMESW,<	SKIPN	W,DTOUT
	MOVE	W,CURNAM	;USE PROGRAM NAME>
	JUMPE	W,.+3		;DON'T PRINT IF NOT THERE
	PUSHJ	P,PWORD
	PUSHJ	P,SPACES	;SOME SPACES
	ERROR	0,<?STORAGE MAP!?>
	PUSHJ	P,SPACES		;SOME SPACES
	PUSH	P,N
	PUSH	P,E
	MOVE	N,[POINT 6,DBUF] ;INITIALIZE DATE POINTER
	MSTIME	Q,		;GET THE TIME
	IDIVI	Q,^D60*^D1000
	IDIVI	Q,^D60
	PUSH	P,A		;SAVE MINUTES
	PUSHJ	P,OTOD1		;STORE HOURS
	POP	P,Q		;GET MINUTES
	PUSHJ	P,OTOD		;STORE MINUTES
	DATE	E,		;GET DATE
	IDIVI	E,^D31		;GET DAY
	ADDI	Q,1
	PUSHJ	P,OTOD		;STORE DAY
	IDIVI	E,^D12		;GET MONTH
	ROT	Q,-1		;DIV BY 2
	HRR	A,DTAB(Q)	;GET MNEMONIC
	TLNN	Q,400000
	HLR	A,DTAB(Q)	;OTHER SIDE
	HRRM	A,DBUF+1	;STORE IT
	MOVEI	Q,^D64(E)	;GET YEAR
	MOVE	N,[POINT 6,DBUF+2]
	PUSHJ	P,OTOD		;STORE IT
	POP	P,E
	POP	P,N
	PUSHJ	P,DBUF1
	PUSHJ	P,CRLF
	SKIPN	STADDR		;PRINT STARTING ADDRESS
	JRST	NOADDR		;NO ADDRESS SEEN
	ERROR	0,</STARTING ADDRESS !/>
	PUSHJ	P,SP1
	MOVE	W,STADDR		;GET ST. ADDR.
	PUSHJ	P,PRNUM0		;PRINT IT
IFN NAMESW,<
	PUSHJ	P,SP1
	MOVE	W,[SIXBIT / PROG /]
	PUSHJ	P,PWORD
	MOVE	W,CURNAM		;PROG NAME
	PUSHJ	P,PWORD
	PUSHJ	P,SP1
	MOVE	W,ERRPT6		;SIXBIT / FILE /
	PUSHJ	P,PWORD
	MOVE	W,PRGNAM		;FILE NAME
	PUSHJ	P,PWORD>
NOADDR:	IFN REENT,<
	HRRZ	A,HVAL1		;GET INITIAL HIGH START
	ADDI	A,JOBHDA	;ADD IN OFFSET
	HRLI	A,JOBDA		;LOW START
	MOVSM	A,SVBRKS	;INITIAL BREAKS>
	HLRE	A,B
	MOVNS     A
	ADDI	A,(B)
PRMAP1: SUBI	A,2
IFN REENT,<SKIPN C,1(A)		;LOAD SYMBOL SKIP IF REAL SYMBOL
	JRST	PRMAP4		;IGNORE ZERO NAME(TWOSEG BREAKS)>
IFE REENT,<MOVE	C,1(A)		;LOAD SYMBOL>
	TLNN	C,300000	;TEST FOR LOCAL SYMBOL
	JRST	.+4		;GLOBAL  (NOT LOCAL ANYWAY)
	TRNN	F,LOCAFL	;PRINT LOCAL SYMBOLS?
	JRST	PRMAP4		;IGNORE LOCAL SYMBOLS
	TLC	C,140000	;MAKE IT LOOK LIKE INTERN
	TLNE	C,040000
	JRST	PRMP1A
	PUSHJ	P,CRLF
	PUSHJ	P,CRLF
	SETZM	TABCNT
	JRST	PRMP1B

PRMP1A:	PUSHJ	P,TAB
PRMP1B:	PUSHJ   P,PRNAM1	;PRINT SYMBOL AND VALUE
	TLNE	C,040000
	JRST	PRMAP4		;GLOBAL SYMBOL
	HLRE	C,W 		;POINTER TO NEXT PROG. NAME
	HRRZS W		;SO WE ONLY HAVE THE HALF WE WANT
PRMAP7:	JUMPL C,PRMP7A
IFN REENT,<SKIPN 1(B)		;IS IT A ZERO SYMBOL
	JRST	[MOVE	C,B	;SET UP C
		JRST	PRMAP2]	;AND GO
	HRRZ	T,HVAL	;GET TO OF HI PART
	CAML	W,HVAL1	;IS PROGRAM START UP THERE??
	JRST	PRMAP6	;YES
	HRRZ	T,HILOW	;GET HIGHEST LOCATION LOADED IN LOW
	SUBI	T,(X)	;REMOVE OFFSET
	CAIE	T,(W)	;EQUAL IF ZERO LENGTH PROG>
	HRRZ T,R	;GET LOW, HERE ON LAST PROG
	JRST PRMAP6	;GO

PRMP7A:	ADDI C,2(A)	;POINTER TO NEXT PROGRAM NAME
PRMAP2:	IFN REENT,<
	SKIPE	1(C)	;THIS IS A TWO SEG  FILE
	JRST	PRMP2A	;NO
	MOVE	T,2(C)	;GET PROG BREAKS
	TLNN	T,-1		;IF NO HIGH STUFF YET
	HLL	T,SVBRKS	;FAKE IT
	SUB	T,SVBRKS	;SUBTRACT LAST  BREAKS
	HRRZ	W,T	;LOW BREAK
	PUSH	P,W	;SAVE IT
	JUMPGE	T,.+2	;IF NEGATIVE
	TDZA	W,W	;MAKE ZERO (FIRST TIME THRU)
	HLRZ	W,T	;GET HIGH BREAK
	PUSHJ	P,PRNUM	;PRINT IT
	PUSHJ	P,TAB	;AND TAB
	POP	P,W	;LOW BREAK
	PUSHJ	P,PRNUM
	MOVE	T,2(C)
	CAMN	C,B		;EQUAL IF LAST PROG
	SETZ	C,		;SIGNAL END
	TLNN	T,-1
	HLL	T,SVBRKS
	CAMN	T,SVBRKS	;ZERO LENGTT IF EQUAL
	JRST	PRMP6A		;SEE IF LIST ALL ON
	MOVEM	T,SVBRKS	;SAVE FOR NEXT TIME
	JRST	PRMAP3	;AND CONTINUE
PRMP2A:>
	HRRZ T,(C)	;GET ITS STARTING ADRESS
IFN REENT,<CAMGE W,HVAL1	;MAKE SURE BOTH IN SAME SEGMENT
	CAMGE T,HVAL1
	CAMGE T,W
	JRST	[HLRE T,(C)	;NO TRY NEXT ONE DOWN
		JUMPE T,@PRMAP7	;END GO USE PROG BREAK
		ADDI C,(T)
		JRST PRMAP2]	;CHECK THIS ONE>
PRMAP6:	SUBM	T,W 		;SUBTRACT ORIGIN TO GET LENGTH
	PUSHJ     P,PRNUM		;PRINT PROGRAM LENGTH
	PUSHJ     P,CRLF
PRMP6A:	TLNN	N,ALLFLG		;SKIP IF LIST ALL MODE IS ON
	TRNE	W,777777		;SKIP IF ZERO LENGTH PROGRAM
	JRST	PRMAP3
	HLRE	C,2(A)		;GET BACK CORRECT LOCATION IF 0 LENGTH
	JUMPE   C,PRMAP5	;JUMP IF LAST PROGRAM
	ADDI	C,2(A)		;IN CASE WE SKIPPED SOME PROGRAMS
	SKIPA   A,C		;SKIP GLOBALS, ZERO LENGTH PROG.
PRMAP3:   PUSHJ     P,CRLF
PRMAP4:   CAILE     A,(B)		;TEST FOR END OF SYMBOL TABLE
	JRST	PRMAP1
PRMAP5:	PUSHJ	P,CRLF	;GIVE AN XTRA CR-LF


SUBTTL	LIST UNDEFINED AND MULTIPLY DEFINED GLOBALS

	PUSHJ	P,PMS1		;PRINT UNDEFINED SYMBOLS

;LIST NUMBER OF MULTIPLY DEFINED GLOBALS

PMS3:	SKIPN	W,MDG		;ANY MULTIPLY DEFINED GLOBALS
	JRST	PMS4		;NO, EXCELSIOR
	PUSHJ	P,FCRLF		;ROOM AT THE TOP
	PUSHJ	P,PRQ		;PRINT ?
	PUSHJ	P,PRNUM0	;NUMBER OF MULTIPLES
	ERROR	7,<?MULTIPLY DEFINED GLOBALS@?>
PMS4:	TLNE	N,AUXSWE	;AUXILIARY OUTPUT DEVICE?
	OUTPUT	2,		;INSURE A COMPLETE BUFFER
	POPJ	P,		;RETURN

;LIST UNDEFINED GLOBALS

PMS1:	PUSHJ	P,FSCN1		;LOAD FILES FIRST
	JUMPGE	S,CPOPJ		;JUMP IF NO UNDEFINED GLOBALS
	PUSHJ	P,FCRLF		;START THE MESSAGE
	PUSH	P,S		;SAVE POINTER TO UNDEFINEDS
	MOVEI	W,0		;COUNT UNDEF SYMBOLS.
PMS1A:	SKIPL	A,1(S)
	TLNN	A,40000
	JRST	.+2
	ADDI	W,1
	ADD	S,SE3
	JUMPL	S,PMS1A
	PUSHJ	P,PRNUM0	;NOTE THIS IS AN OCTAL PRINTER
	ERROR	7,</UNDEFINED GLOBALS@/>
	POP	P,S		;RESTORE.
	MOVE	A,S 		;POINTER TO UNDEFS
PMS2:	SKIPL	W,1(A)
	TLNN	W,40000
	JRST	PMS2A
	PUSHJ	P,FCRLF
	PUSHJ	P,PRNAM0		;PRINT SYMBOL AND POINTER
PMS2A:	ADD	A,SE3
	JUMPL   A,PMS2
CPOPJ:	POPJ	P,

PMS:	PUSHJ	P,PMS1	;PRINT UNDEFINED SYMBOLS
	JUMPGE	S,CPOPJ		;NO UNDEFINED SYMBOLS
	PUSHJ	P,CRLF		;NEW LINE,MAKE ? VISIBLE
	PUSHJ	P,PRQ		;FIX FOR BATCH TO PRINT ALL SYMBOLS
	JRST	CRLF		;SPACE AFTER LISTING
SUBTTL	ENTER FILE ON AUXILIARY OUTPUT DEVICE

IAD2:	PUSH	P,A		;SAVE A FOR RETURN
	MOVE	A,LD5C1		;GET AUX. DEV.
	DEVCHR	A,		;GET DEVCHR
	TLNN	A,4		;DOES IT HAVE A DIRECTORY
	JRST	IAD2A		;NO SO JUST RETURN
	MOVE	A,DTOUT		;GET OUTPUT NAME
	CAME	A,[SIXBIT /JOBDAT/] ;DON'T USE JOBDAT
	JUMPN	A,IAD2A		;USE ANYTHING NON-ZERO
	MOVSI	A,(SIXBIT /DSK/) ;DEFAULT DEVICE
	CAMN	A,LD5C1		;IS IT AUX. DEV.
	JRST	.+5		;YES LEAVE WELL ALONE
	CLOSE	2,		;CLOSE OLD AUX. DEV.
	MOVEM	A,LD5C1		;SET IT TO DSK
	OPEN	2,OPEN2		;OPEN IT FOR DSK
	JRST	IMD4		;FAILED
IFN NAMESW,<	SKIPN	A,CURNAM	;USE PROG NAME>
	MOVSI	A,(SIXBIT /MAP/)	;AN UNLIKELY NAME
	MOVEM	A,DTOUT		;SO ENTER WILL NOT FAIL
IAD2A:	POP	P,A		;RECOVER A
	SETZM	DTOUT+2		;CLEAR PROTECTION (LEVEL D)
	ENTER	2,DTOUT		;WRITE FILE NAME IN DIRECTORY
	JRST	IMD3		;NO MORE DIRECTORY SPACE
	POPJ	P,

IMD3:	ERROR	,</DIR. FULL@/>
	JRST	LD2

IMD4:	MOVE	P,[XWD -40,PDLST]	;RESTORE STACK
	TLZ	N,AUXSWE!AUXSWI	;NO AUX.DEV.NOW
	ERROR	,</NO MAP DEVICE@/>
	JRST	PRMAP5		;CONTINUE TO LOAD


SUBTTL	PRINT SUBROUTINES

;PRINT THE 6 DIGIT OCTAL ADDRESS IN W

;	ACCUMULATORS USED: D,T,V

PRNAM0:   MOVE	C,1(A)		;LOAD SYMBOL
PRNAM1:   MOVE	W,2(A)		;LOAD VALUE
PRNAM:	PUSHJ     P,PRNAME
PRNUM:
	TRNN	F,TTYFL
	PUSHJ	P,SP1
	PUSHJ	P,SP1 
PRNUM0:   MOVE	V,PRNUM2		;LOAD BYTE POINTER TO RH. OF W
	MOVNI     D,6 		;LOAD CHAR. COUNT
PRNUM1:   ILDB	T,V 		;LOAD DIGIT TO BE OUTPUT
	ADDI	T,60		;CONVERT FROM BINARY TO ASCII
	PUSHJ     P,TYPE2
	AOJL	D,PRNUM1		;JUMP IF MORE DIGITS REMAIN
	POPJ	P,

PRNUM2:   XWD	220300,W


IFN NAMESW,<
LDNAM:	MOVE T,[POINT 6,CURNAM]	;POINTER
	MOVNI D,6	;SET COUNT
	TLZ W,740000	;REMOVE CODE BITS
SETNAM:	IDIVI W,50	;CONVERT FROM RAD 50
	HRLM C,(P)
	AOJGE D,.+2
	PUSHJ P,SETNAM
	HLRZ C,(P)
	JUMPE C,INAM
	ADDI C,17
	CAILE C,31
	ADDI C,7
	CAIG C,72	;REMOVE SPECIAL  CHARS. (. $ %)
	IDPB C,T
INAM:	POPJ P,	>


;YE OLDE RECURSIVE NUMBER PRINTER
;PRINTS Q, WITH LEADING ZEROES SUPPRESSED; USES A AND T

RCNUM:	IDIVI Q,12		;RADIX DECIMAL
	ADDI A,"0"
	HRLM A,(P)
	JUMPE Q,.+2
	PUSHJ P,RCNUM
	HLRZ T,(P)
	JRST TYPE2


SPACES:	PUSHJ	P,SP1
SP1:	PUSHJ	P,SPACE
SPACE:	MOVEI   T,40
	JRST	TYPE2

;	ACCUMULATORS USED: Q,T,D

PWORD:	MOVNI   Q,6 		;SET CHARACTER COUNT TO SIX
PWORD1: MOVE	D,LSTPT		;ENTER HERE WITH Q PRESET
PWORD2: ILDB	T,D 		;LOAD NEXT CHAR. TO BE OUTPUT
	PUSHJ     P,TYPE		;OUTPUT CHARACTER
	AOJL	Q,PWORD2
	POPJ	P,

PFWORD:	MOVNI Q,6		;PRINT FILE NAME
	MOVE D,LSTPT
PWORD3:	ILDB T,D
	JUMPE T,CPOPJ
	PUSHJ P,TYPE
	AOJL Q,PWORD3
	POPJ P,

;TYPEOUT SUBROUTINE - THE CHARACTER SUPPLIED IN T IS CONVERTED TO ASCII
;AND IS OUTPUT ON THE CONSOLE AND/OR THE SPECIFIED LOADER MAP OUTPUT
;DEVICE

CRLFLF:	PUSHJ	P,CRLF
FCRLF:	TLO	F,FCONSW	;INSURE TTY OUTPUT
CRLF:	MOVEI   T,15		;CARRIAGE RETURN LINE FEED
	PUSHJ   P,TYPE2
	TRCA	T,7		;CR.XOR.7=LF
TYPE:	MOVEI   T,40(T)		;CONVERT SIXBIT TO ASCII
TYPE2:	TLNN	N,AUXSWI	;IS THER AN AUXILIARY DEVICE?
	JRST	TYPE3		;NO, DONT OUTPUT TO IT
	TLON	N,AUXSWE	;IS AUX. DEV. ENTERED?
	PUSHJ	P,IAD2		;NOPE, DO SO!
	SOSG	ABUF2		;SPACE LEFT IN BUFFER?
	OUTPUT	2,		;CREATE A NEW BUFFER
	IDPB	T,ABUF1		;DEPOSIT CHARACTER
	TLNN	F,FCONSW	;FORCE OUTPUT TO CONSOLE TOO?
	POPJ	P,		;NOPE
TYPE3:	IFN RPGSW,<
	TRNE	F,NOTTTY	;IF TTY IS ANOTHER DEVICE
	POPJ	P,		;DON'T OUTPUT TO IT>
	SKIPN	BUFO2		;END OF BUFFER
	OUTPUT	3,		;FORCE OUTPUT NOW
	IDPB	T,BUFO1		;DEPOSIT CHARACTER
	CAIN	T,12		;END OF LINE
	OUTPUT	3,		;FORCE AN OUTPUT
	POPJ	P,

SUBTTL	SYMBOL PRINT - RADIX 50

;	ACCUMULATORS USED: D,T

PRNAME: MOVE	T,C 		;LOAD SYMBOL
	TLZ	T,740000	;ZERO CODE BITS
	PUSH	P,T
	PUSH	P,C
	MOVEI	C,6
	MOVEI	D,1
	IDIVI	T,50
	JUMPN	V,.+2
	IMULI	D,50
	SOJN	C,.-3
	POP	P,C
	POP	P,T
	IMUL	T,D
	MOVNI   D,6 		;LOAD CHAR. COUNT
SPT:	IDIVI   T,50		;THE REMAINDER IS THE NEXT CHAR.
	HRLM	V,(P)		;STORE IN LH. OF PUSHDOWN LIST
	AOJGE   D,.+2		;SKIP IF NO CHARS. REMAIN
	PUSHJ   P,SPT		;RECURSIVE CALL FOR NEXT CHAR.
	HLRZ	T,(P)		;LOAD FROM LH. OF PUSHDOWN LIST
	JUMPE   T,TYPE		;BLANK
	ADDI	T,60-1
	CAILE   T,71
	ADDI	T,101-72
	CAILE   T,132
	SUBI	T,134-44
	CAIN	T,43
	MOVEI   T,56
	JRST	TYPE2

TAB1:	SETZM	TABCNT
	PUSHJ	P,CRLF
TAB:	AOS	T,TABCNT
	CAIN	T,5
	JRST	TAB1
	TRNE	F,TTYFL
	JRST	SP1
	MOVEI	T,11
	JRST	TYPE2


OTOD:	IBP	N
OTOD1:	IDIVI	Q,^D10
	ADDI	Q,20		;FORM SIXBIT
	IDPB	Q,N
	ADDI	A,20
	IDPB	A,N
	POPJ	P,

DTAB:	SIXBIT	/JANFEB/
	SIXBIT	/MARAPR/
	SIXBIT	/MAYJUN/
	SIXBIT	/JULAUG/
	SIXBIT	/SEPOCT/
	SIXBIT	/NOVDEC/


SUBTTL	ERROR MESSAGE PRINT SUBROUTINE

;	FORM OF CALL:

;	JSP	A,ERRPT
;	SIXBIT    /<MESSAGE>/

;	ACCUMULATORS USED: T,V,C,W

ERRPT:	TLO	F,FCONSW	;INSURE TTY OUTPUT
	PUSHJ	P,CRLF		;ROOM AT THE TOP
	PUSHJ	P,PRQ		;START OFF WITH ?
ERRPT0: PUSH	P,Q 		;SAVE Q
	SKIPA   V,ERRPT5
ERRPT1: PUSHJ   P,TYPE
	ILDB	T,V
	CAIN	T,"@"-40
	JRST	ERRPT4
	CAIN	T,"%"-40
	JRST	ERRPT9
	CAIN	T,"!"-40
	JRST	ERRP42		;JUST RETURN,LEAVE FCONSW ON
	CAIE	T,"#"-40
	JRST	ERRPT1
	SKIPN   C,DTIN
	JRST	ERRPT4
	MOVNI   Q,14
	MOVEI   W,77
ERRPT2: TDNE	C,W
	JRST	ERRPT3
	LSH	W,6
	AOJL	Q,ERRPT2
ERRPT3: MOVE	W,ERRPT6
	PUSHJ   P,PWORD1
	SKIPN   W,DTIN1
	JRST	ERRPT4
	LSH	W,-6
	TLO	W,160000
	MOVNI   Q,4
	PUSHJ   P,PWORD1
ERRPT4: PUSHJ   P,CRLF
ERRP41:	TLZ	F,FCONSW	;ONE ERROR PER CONSOLE
ERRP42:	POP	P,Q		;***DMN*** FIX FOR ILC MESSAGE
	AOJ	V,		;PROGRAM BUMMERS BEWARE:
	JRST	@V		;V HAS AN INDEX OF A

ERRPT5: POINT     6,0(A)
ERRPT6: SIXBIT    / FILE /

ERRPT8:	TLO	F,FCONSW	;INSURE TTY OUTPUT
	PUSHJ	P,PRQ		;START WITH ?
	CAIGE	T,140		;IS IT A NON-PRINTING CHAR?
	CAIL	T,40
	JRST	ERRP8
	PUSH	P,T
	MOVEI     T,136		;UP ARROW
	PUSHJ     P,TYPE2
	POP	P,T
	TRC	T,100		;CONVERT TO PRINTING CHAR.
ERRP8:	PUSHJ     P,TYPE2
ERRPT7:   PUSHJ     P,SPACE
	JRST	ERRPT0

ERRPT9: MOVEI   V,@V
	PUSH	P,V
	ERROR	7,<?ILLEGAL -LOADER@?>
	POP	P,V
	JRST	ERRP41

;PRINT QUESTION MARK

PRQ:	PUSH	P,T		;SAVE
	MOVEI	T,"?"		;PRINT ?
	PUSHJ	P,TYPE2		;...
	POP	P,T		;RESTORE
	POPJ	P,		;RETURN

SUBTTL	INPUT - OUTPUT INTERFACE

;BINARY INPUT SUBROUTINE - RETURNS A WORD IN W
IFE K,<
WORDPR:	PUSHJ	P,WORD		;GET FIRST WORD OF PAIR
	MOVE	C,W		;KEEP IT HANDY>
WORD:	SOSGE	BUFR2		;SKIP IF BUFFER NOT EMPTY
	JRST	WORD2
WORD1:	ILDB	W,BUFR1		;PICK UP 36 BIT WORD
	POPJ	P,

WORD2:	IN	1,		;GET NEXT BUFFER LOAD
	JRST	WORD		;DATA OK - CONTINUE LOADING
WORD3:	STATZ	1,IODEND	;TEST FOR EOF
	JRST	EOF 		;END OF FILE EXIT
	ERROR	,< /INPUT ERROR#/>
	JRST	LD2 		;GO TO ERROR RETURN


SE3:	XWD	2,2 		;SYMBOL POINTER INCREMENT
PDLPT:	XWD	-41,PDLST-1;	INITIAL PUSHDOWN POINTER
COMM:	SQUOZE    0,.COMM.
LSTPT:	POINT	6,W		;CHARACTER POINTER TO W

IOBKTL==40000
IOIMPM==400000
IODERR==200000
IODTER==100000
IODEND==20000

IOBAD==IODERR!IODTER!IOBKTL!IOIMPM


SUBTTL	IMPURE CODE
IFN SEG2SW,<	RELOC
LOWCOD:	RELOC>
IFN PURESW,<HICODE:
IFN SEG2SW,<	PHASE LOWCOD>
IFE SEG2SW,<	PHASE	140>>


DBUF1:	JSP	A,ERRPT7
DBUF:	SIXBIT	/TI:ME DY-MON-YR @/
	POPJ	P,

;DATA FOR PURE OPEN UUO'S

IFN SPCHN,<
CHNENT:	0
	SIXBIT .CHN.
	0
	0
CHNOUT:	17
	SIXBIT /DSK/
	0
>
IFN RPGSW,<
OPEN1:	EXP	1
RPG1:	Z
	XWD	0,CTLIN
>

OPEN2:	EXP	1
LD5C1:	Z
	XWD	ABUF,0

OPEN3:	EXP	14
ILD1:	Z
	XWD	0,BUFR

IFN STANSW,<
OPEN4:	EXP	17
	Z
	Z >

IFN PURESW,<DEPHASE
CODLN=.-HICODE>

SUBTTL	DATA STORAGE

IFN PURESW,<
IFE SEG2SW,<LOC 140>
IFN SEG2SW,<RELOC>
LOWCOD:	BLOCK CODLN>

PDSAV:	BLOCK 1			;SAVED PUSHDOWN POINTER
COMSAV: BLOCK 1			;LENGTH OF COMMON
MDG:	BLOCK 1			;COUNTER FOR MUL DEF GLOBALS
GLBEND:	BLOCK 1			;Pointer to end of globals in symbol table
GLBENP:	BLOCK 1			;PNTR TO ABOVE, OR TO B (SEE RHTCRK)
PDLST:	BLOCK	40

F.C:	BLOCK 1
	BLOCK 1	;STORE N HERE
	BLOCK 1	;STORE X HERE
	BLOCK 1	;STORE H HERE
	BLOCK 1	;STORE S HERE
	BLOCK 1	;STORE R HERE
B.C:	BLOCK 1

STADDR:	BLOCK 1	;HOLDS STARTING ADDRESS

IFN NAMESW,<
PRGNAM:	BLOCK 1	;STORE BINARY FILE NAME-USED TO MAKE SYSTAT MORE MEANINGFUL
>
IFN REENT,<
IFN STANSW,<
PRGCRD:	BLOCK 1	;SAVE DATE & TIME FOR SETCRD UUO>
HIGHX:	BLOCK 1
HIGHR:	BLOCK 1	;HOLD X AND R WHILE LOADING LOW SEG PIECES
LOWX:	BLOCK 1
HILOW:	BLOCK 1	;HIGHEST NON-BLOCK STMT IN LOW SEG
HVAL:	BLOCK 1	;ORG OF HIGH SEG>
HVAL1:	BLOCK 1	;ACTUAL ORG OF HIGH SEG
LOWR:	BLOCK 1	;HOLD X AND R WHILE LOADING HISEG PIECES
IFN KUTSW,<CORSZ:	BLOCK 1>
IFN DMNSW,<KORSP:	BLOCK 1>
IFN LDAC,<BOTACS:	BLOCK 1>
IFN WFWSW,<VARLNG:	BLOCK 1
VARREL:	BLOCK 1>
IFN SAILSW,<LIBFLS:	BLOCK	RELLEN*3
PRGFLS:	BLOCK	RELLEN*3>

PT1:	BLOCK 1
SVA:	BLOCK 1
IFN RPGSW,<
NONLOD:	BLOCK 1
SVRPG:	BLOCK 1
IFN TEMP,<
TMPFIL:	BLOCK 2
TMPFLG:	BLOCK 1>
>
IFN  NAMESW,<
CURNAM:	BLOCK 1
>
IFN PP,<
OLDDEV:	BLOCK 1
PPN:	BLOCK 1
PPNE:	BLOCK 1
PPNV:	BLOCK 1
PPNW:	BLOCK 1
	>
IFN FAILSW,<
GLBCNT:	BLOCK 1
HDSAV:	BLOCK 1
HEADNM:	BLOCK 1
LFTHSW:	BLOCK 1
OPNUM:	BLOCK 1
POLSW:	BLOCK 1
SVHWD:	BLOCK 1
SVSAT:	BLOCK 1
PPDB:	BLOCK PPDL+1
LINKTB:	BLOCK 21
>
HISTRT:	BLOCK 1	;JOBREL AT START OF LOADING
IFN L,<
LSPXIT:	BLOCK 1
LSPREL:	BLOCK 1	;BY TVR AFTER DBA AFTER JRA FOR UCI
LSPDDT:	BLOCK 1	;Special location for JOBDDT for LISP Loader
RINITL:	BLOCK 1
OLDJR:	BLOCK 1>
IFN SPCHN,<
CHNTAB:	BLOCK 1
BEGOV:	BLOCK 1
CHNACN:	BLOCK 1
CHNACB:	BLOCK 1>
TABCNT:	BLOCK 1
LIMBO:	BLOCK	1	;WHERE OLD CHARS. ARE STORED
IFN DIDAL,<LSTBLK:	BLOCK	1	;POINTER TO LAST PROG LOADED>
IFN EXPAND,<ALWCOR:	BLOCK	1	;CORE AVAILABLE TO USER>
IFN ALGSW,<%OWN: BLOCK	1	;ADDRESS OF ALGOL OWN AREA
	OWNLNG:	BLOCK	1	;LENGTH OF OWN BLOCK>
IFN REENT,<SVBRKS:	BLOCK	1	;XWD HIGH,LOW (PROG BREAKS)>
IFN SILENT,<
INBYTP:	BLOCK	1
INBYTC:	BLOCK	1
>;IFN SILENT

SUBTTL	BUFFER HEADERS AND HEADER HEADERS

BUFO:	BLOCK 1			;CONSOLE INPUT HEADER HEADER
BUFO1:	BLOCK 1
BUFO2:	BLOCK 1

BUFI:	BLOCK 1			;CONSOLE OUTPUT HEADER HEADER
BUFI1:	BLOCK 1
BUFI2:	BLOCK 1

ABUF:	BLOCK 1			;AUXILIARY OUTPUT HEADER HEADER
ABUF1:	BLOCK 1
ABUF2:	BLOCK 1

BUFR:	BLOCK 1			;BINARY INPUT HEADER HEADER
BUFR1:	BLOCK 1
BUFR2:	BLOCK 1

DTIN:	BLOCK 1			;DECTAPE INPUT BLOCK
DTIN1:	BLOCK 3

DTOUT:	BLOCK 1			;DECTAPE OUTPUT BLOCK
DTOUT1: BLOCK 3

IFN STANSW, <
SAVFIL:	BLOCK 4			;FILE NAME BLOCK FOR DUMP FILE >

	TTYL==52			;TWO TTY BUFFERS
IFN STANSW,< TTYL==70   ;;;STANFORD, JUST TO BE DIFFERENT, HAS BIG TTY BFRS>

IFE LNSSW,<
IFE K,<	BUFL==406		;TWO DTA BUFFERS FOR LOAD
IFN STANSW,<IFE L,<BUFL==23*203>>;STANFORD, NOT LISP, USE 7 BUFFERS >;IFE K
IFN K,<	BUFL==203		;ONE DTA BUFFER FOR LOAD	>;IFN K
	ABUFL==203		;ONE DTA BUFFER FOR AUX DEV
>;IFE LNSSW

IFN LNSSW,<
IFE K,<BUFL==4*203+1>
IFN K,<BUFL==203+1>
ABUFL==2*203+1>

TTY1:	BLOCK   TTYL		;TTY BUFFER AREA
BUF1:	BLOCK	BUFL		;LOAD BUFFER AREA
AUX:	BLOCK	ABUFL		;AUX BUFFER AREA


IFN RPGSW,<
CTLIN:	BLOCK 3
CTLNAM:	BLOCK 3
CTLBUF:	BLOCK 203+1
>

SUBTTL	FORTRAN DATA STORAGE

IFN STANSW,<PATCH:	BLOCK	20		;STANFORD HAS SEMI-INFINITE CORE>

IFE K,<
TOPTAB:	BLOCK 1	;TOP OF TABLES
CTAB:	BLOCK 1;	COMMON
ATAB:	BLOCK 1;	ARRAYS
STAB:	BLOCK 1;	SCALARS
GSTAB:	BLOCK 1;	GLOBAL SUBPROGS
AOTAB:	BLOCK 1;	OFFSET ARRAYS
CCON:	BLOCK 1;	CONSTANTS
PTEMP:	BLOCK 1;	PERMANENT TEMPS
TTEMP:	BLOCK 1;	TEMPORARY TEMPS
COMBAS:	BLOCK 1;	BASE OF COMMON
LLC:	BLOCK 1;	PROGRAM ORIGIN
BITP:	BLOCK 1;	BIT POINTER
BITC:	BLOCK 1;	BIT COUNT
PLTP:	BLOCK 1;	PROGRAMMER LABEL TABLE
MLTP:	BLOCK 1;	MADE LABEL TABLE
SDS:	BLOCK 1	;START OF DATA STATEMENTS
SDSTP:	BLOCK 1	;START OF DATA STATEMENTS POINTER
BLKSIZ:	BLOCK 1;	BLOCK SIZE
MODIF:	BLOCK 1;	ADDRESS MODIFICATION +1
SVFORH:	BLOCK 1	;SAVE H WHILE LOADING F4 PROGRAMS

IOWDPP:	BLOCK 3>
SBRNAM:	BLOCK 1

IFE K,<
CT1:	BLOCK 1		;TEMP FOR C
LTC:	BLOCK 1
ITC:	BLOCK 1
ENC:	BLOCK 1
WCNT:	BLOCK 1		;DATA WORD COUNT
RCNT:	BLOCK 1		;DATA REPEAT COUNT

LTCTEM:	BLOCK 1		;TEMP FOR LTC
DWCT:	BLOCK 1		;DATA WORD COUNT>

	VAR	;DUMP VARIABLES
IFN PURESW,<RELOC>


SUBTTL	REMAP UUO
IFN REENT,<
IFN PURESW,<HHIGO:	PHASE	BUF1	;DON'T NEED BUF1 NOW>

HIGO:	CORE	V,		;CORE UUO
	JFCL			;NEVER FAILS
HINOGO:	MOVE	D,HVAL
	CAMG	D,HVAL1		;ANYTHING IN HI-SEG
	JRST	0		;NO
IFN STANSW,<MOVE V,PRGCRD
	TLZ	V,777000	;NO PROTECTION
	CALLI	V,400073	;SET DATE & TIME WHICH WILL BE COPIED TO UPPER>
SEGAG2:	MOVE	V,HISTRT	;NOW REMAP THE HISEG.
	REMAP	V,		;REMAP UUO.
IFN STANSW,< JRST SEGAGN	;Type error message and let him try again.>
IFE STANSW,<
IFN PURESW,< JRST HIGET >	;FATAL ERROR.
IFE PURESW,< JRST REMPFL >	;FATAL ERROR.>
HIRET:	JRST	0		;EXECUTE CODE IN ACC'S

IFN STANSW,<
SEGAGN:	TTCALL	3,SEGAGM	;Tell him REMAP failed and that he can try again.
	EXIT	1,
	JRST	SEGAG2		;Now try again.

SEGAGM:	ASCIZ	/
?REMAP FAILED TO MAKE UPPER SEGMENT.  PROBABLY NO JOB SLOTS AVAILABLE.
Type CONTINUE to retry the REMAP./ >

IFN PURESW,<
HIGET:	HRRZI	V,SEGBLK	;DATA FOR
	GETSEG	V,		;GETSEG UUO
	SKIPA			;CANNOT CONTINUE NO HISEG
	JRST	REMPFL		;REGAINED LOADER HISEG
				;GO PRINT MESSAGE
	TTCALL	3,SEGMES	;PRINT SEGMES
	EXIT			;AND DIE

SEGBLK:	SIXBIT	/SYS/
	SIXBIT	/LOADER/
	EXP	0,0,0,0


SEGMES:	ASCIZ	/?CANNOT FIND LOADER.SHR
/

HIGONE:	DEPHASE>>

SUBTTL	LISP LOADER

;END HERE IF 1K LOADER REQUESTED.
IFN K,<IFE L,<END BEG>
IFE L,<	XLIST	>

IFN L,<    LIT
		VAR
	LODMAK:	MOVEI A,LODMAK
	MOVEM A,137
	INIT 17
	SIXBIT /DSK/
	0
	HALT
	ENTER LMFILE
	HALT
	OUTPUT [IOWD 1,LMLST	;OUTPUT LENGTH OF FILE
		0]
	OUTPUT LMLST
	STATZ 740000
	HALT
	RELEASE
	CALL [SIXBIT /EXIT/]

LMFILE:	SIXBIT /LISP/
	SIXBIT /LOD/
	0
	0

LMLST:	IOWD LODMAK+1-LD,137
	0

	END LODMAK>>


	LIST

SUBTTL	 FORTRAN FOUR LOADER

F4LD:	TLNE	F,SKIPSW!FULLSW ;ARE WE IN SKIP MODE
	JRST	REJECT		;YES,DON'T LOAD ANY OF THIS
	MOVEI	W,-2(S);	GENERATE TABLES
	CAIG	W,(H)		;NEED TO EXPAND?
IFN EXPAND,<PUSHJ P,[PUSHJ P,XPAND
		TLOA	F,FULLSW
		JRST	POPJM3
		POPJ	P,]>
IFE EXPAND,<	TLO	F,FULLSW>
;IFN REENT,<TRO	F,F4FL!VFLG	;RE-ENTRANT LIB40>
	TLO	N,F4SW;		SET FORTRAN FOUR FLAG
	HRRZ	V,R;		SET PROG BREAK INTO V
	MOVEM	V,LLC;		SAVE FIRST WORD ADDRESS
	HRRZM	W,MLTP;		MADE LABELS
	HRRZM	W,PLTP;		PROGRAMMER LABELS
	ADD	W,[POINT 1,1];	GENERATE BIT-BYTE POINTER
	MOVEM	W,BITP
	MOVEM	W,SDSTP;	FIRST DATA STATEMENT
	AOS	SDSTP;
	HRREI	W,-^D36;	BITS PER WORDUM
	MOVEM	W,BITC;		BIT COUNT
	PUSHJ	P,BITWX		;MAKE SURE OF ENOUGH SPACE
	MOVE	W,[JRST ALLOVE]	;LAST DATA STATEMENT
	MOVEM	W,(S)

TEXTR:	PUSHJ	P,WORD;		TEXT BY DEFAULT
	HLRZ	C,W
	CAIN	C,-1
	JRST	HEADER;		HEADER
	MOVEI	C,1;		RELOCATABLE
	TLNN	F,FULLSW!SKIPSW ;DON'T LOAD IF EITHER SET
	PUSHJ	P,BITW;		SHOVE AND STORE
	JRST	TEXTR;		LOOP FOR NEXT WORD

ABS:	SOSG	BLKSIZ;	MORE TO GET
	JRST	TEXTR;		NOPE
ABSI:	PUSHJ	P,WORD;
	MOVEI	C,0;		NON-RELOCATABLE
	TLNN	F,FULLSW!SKIPSW ;DON'T LOAD IF EITHER SET
	PUSHJ	P,BITW;		TYPE 0
	JRST	ABS

SUBTTL	PROCESS TABLE ENTRIES

MDLB:	TLNE	F,FULLSW+SKIPSW;	MADE LABEL PROC
	JRST	GLOBDF;		NO ROOM AT THE IN
	HLRZ	C,MLTP;		GET PRESENT SIZE
	CAMGE	C,BLKSIZ;	IF NEW SIZE BIGGER, STR-R-RETCH
	PUSHJ	P,SMLT
	HRRZ	C,MLTP;		GET BASE
MLPLC:	ADD	C,BLKSIZ;	MAKE INDEX
	TLNN	F,FULLSW+SKIPSW;	DONT LOAD
	HRRZM	V,(C);		PUT AWAY DEFINITION
GLOBDF:	PUSHJ	P,WORD
	TLNE	F,FULLSW+SKIPSW	;SKIPPING THIS PROG?
	JRST	TEXTR		;YES, DON'T DEFINE
	MOVEI	C,(V);		AND LOC
	EXCH	W,C
	PUSHJ	P,SYMXX;	PUT IN DDT-SYMBOL TABLE
	PUSHJ	P,BITWX
	JRST	TEXTR

PLB:	TLNE	F,FULLSW+SKIPSW
	JRST	GLOBDF
	HLRZ	C,PLTP;		PRESENT SIZE
	CAMGE	C,BLKSIZ
	PUSHJ	P,SPLT
	HRRZ	C,PLTP
	JRST	MLPLC

SUBTTL	STORE WORD AND SET BIT TABLE

BITW:	MOVEM	W,@X;		STORE AWAY OFFSET
	IDPB	C,BITP;		STORE BIT
	AOSGE	BITC;		STEP BIT COUNT
	AOJA	V,BITWX;	SOME MORE ROOM LEFT
	HRREI	C,-^D36;	RESET COUNT
	MOVEM	C,BITC
	SOS	PLTP
	SOS	BITP;		ALL UPDATED
IFE EXPAND,<HRL	C,MLTP
	SOS	MLTP
	HRR	C,MLTP>
IFN EXPAND,<HRRZ	C,MLTP;		TO ADDRESS
	SUBI	C,1
	CAIG C,(H)
	PUSHJ P,[PUSHJ P,XPAND
		POPJ P,
		ADDI C,2000
		JRST POPJM2]
	SOS	MLTP
	HRLI C,1(C)>
	HRRZ	T,SDSTP;	GET DATA POINTER
	BLT	C,-1(T);	MOVE DOWN LISTS
	AOJ	V,;		STEP LOADER LOCATION
BITWX:	IFN REENT,<
	TLNE	F,HIPROG
	JRST	FORTHI>
	CAIGE H,@X
	MOVEI H,@X	;KEEP H SET RIGHT FOR HISEG STUFF
BITWX2:	HRRZ	T,MLTP
	CAIG	T,(H);		OVERFLOW CHECK
IFE EXPAND,<TLO	F,FULLSW>
IFN EXPAND,<PUSHJ P,	[PUSHJ P,XPAND
			TLOA F,FULLSW
			JRST POPJM3
			POPJ P,]>
	POPJ	P,;

SMLT:	SUB	C,BLKSIZ;	STRETCH
	MOVS	W,MLTP		;LEFT HALF HAS OLD BASE
	ADD	C,MLTP		;RIGHT HALF HAS NEW BASE
IFN EXPAND,<	HRRZS C	;GET RID OF COUNT
		CAIG C,(H)
		PUSHJ P,[PUSHJ P,XPAND
			POPJ P,
			ADD W,[XWD 2000,0]
			ADDI C,2000
			JRST POPJM2]>
	HRRM C,MLTP		;PUT IN NEW MLTP
	HLL	C,W		;FORM BLT POINTER
	ADDI	W,(C)		;LAST ENTRY OF MLTP
	HRL	W,BLKSIZ	;NEW SIZE OF MLTP
	HLLM	W,MLTP		;...
SLTC:	BLT	C,0(W);		MOVE DOWN (UP?)
	POPJ	P,;

SPLT:	SUB	C,BLKSIZ
	MOVS	W,MLTP;
	ADDM	C,PLTP
	ADD	C,MLTP
IFN EXPAND,<	HRRZS C
		CAIG C,(H)
		PUSHJ P,[PUSHJ P,XPAND
			POPJ P,
			ADD W,[XWD 2000,0]
			ADDI C,2000
			JRST POPJM2]>
	HRRM C,MLTP		;PUT IN NEW MLTP
	HLL	C,W
	HLRZ	W,PLTP		;OLD SIZE OF PL TABLE
	ADD	W,PLTP		;NEW BASE OF PL TABLE
	HRL	W,BLKSIZ	;NEW SIZE OF PL TABLE
	HLLM	W,PLTP		;INTO POINTER
	JRST	SLTC


IFN REENT,<
FORTHI:	HRRZ T,JOBREL	;CHECK FOR CORE OVERFLOW
	CAIGE T,@X
	PUSHJ	P,[PUSHJ P,HIEXP
		TLOA F,FULLSW
		JRST POPJM3	;CHECK AGAIN
		POPJ P,]
	JRST BITWX2>

SUBTTL	PROCESS END CODE WORD

ENDS:	PUSHJ	P,WORD;		GET STARTING ADDRESS
	JUMPE	W,ENDS1;	NOT MAIN
	ADDI	W,(R);		RELOCATION OFFSET
	TLNE	N,ISAFLG;	IGNORE STARTING ADDRESS
	JRST ENDS1
	HRRZM	W,STADDR	;STORE STARTING ADDRESS
IFN STANSW&REENT,<MOVE W,DTIN+2
	MOVEM W,PRGCRD		;DATE & TIME FOR SETCRD>
IFN NAMESW,<MOVE W,1(N)	;SET UP NAME
	PUSHJ	P,LDNAM
	MOVE W,DTIN
	MOVEM W,PRGNAM>
ENDS1:	PUSHJ	P,WORDPR	;DATA STORE SIZE
	HRRZM	C,PTEMP		;NUMBER OF PERMANENT TEMPS
	MOVEM	V,CCON;		START OF CONSTANTS AREA
	JUMPE	W,E1;		NULL
	MOVEM	W,BLKSIZ	;SAVE COUNT
	MOVEI	W,0(V)		;DEFINE CONST.
	MOVE	C,CNR50		;...
	TLNN	F,SKIPSW!FULLSW
	PUSHJ	P,SYMPT		;...
	PUSHJ	P,GSWD		;STORE CONSTANT TABLE
E1:	MOVEI	W,0(V);		GET LOADER LOC
	EXCH	W,PTEMP;	STORE INTO PERM TEMP POINTER
	ADD	W,PTEMP;	FORM TEMP TEMP ADDRESS
	MOVEM	W,TTEMP;	POINTER
	MOVEM	V,GSTAB;	STORE LOADER LOC IN GLOBSUB
	MOVEM H,SVFORH
	MOVE	C,TTR50		;DEFINE %TEMP.
	TLNE	F,SKIPSW!FULLSW
	JRST	E1A
	PUSHJ	P,SYMPT		;...
	MOVE	C,PTR50		;DEFINE (IF EXTANT) TEMP.
	MOVEI	W,0(V)		;...
	CAME	W,TTEMP		;ANY PERM TEMPS?
	PUSHJ	P,SYMPT		;YES, DEFINE
E1A:	PUSHJ	P,WORD;		NUMBER OF GLOBSUBS
	JUMPE	W,E11
	MOVEM	W,BLKSIZ	;SIZE OF GLOBSUB
	PUSHJ	P,GSWD		;STORE GLOBSUB TABLE
E11:	MOVEM	V,STAB;		SCALARS
	PUSHJ	P,WORD;		HOW MANY?
	JUMPE	W,E21;		NONE
	PUSHJ	P,GSWDPR	;STORE SCALAR TABLE
E21:	MOVEM	V,ATAB;		ARRAY POINTER
	PUSHJ	P,WORD;		COMMENTS FOR SCALARS APPLY
	JUMPE	W,E31
	PUSHJ	P,GSWDPR	;STORE ARRAY TABLE
E31:	MOVEM	V,AOTAB;	ARRAYS OFFSET
	PUSHJ	P,WORD;		SAME COMMENTS AS ABOVE
	JUMPE	W,E41
	PUSHJ	P,GSWDPR	;STORE ARRAY OFFSET TABLE
E41:	PUSHJ	P,WORD;		TEMP, SCALAR, ARRAY SIZE
	TLNE	F,FULLSW!SKIPSW	;SKIPPING THIS PROG?
	MOVEI	W,0		;DON'T ACCEPT GLOB SUBPROG REQUESTS
	MOVEM	V,CTAB;		SETUP COMMON TABLE POINTER
	ADD	W,GSTAB;	GLOBAL SUBPROG BASE
	MOVEM	W,COMBAS;	START OF COMMON
	PUSHJ	P,WORD;		COMMON BLOCK SIZE
	HRRZM	W,BLKSIZ
	JUMPE	W,PASS2;	NO COMMON
COMTOP:	PUSHJ	P,WORDPR	;GET A COMMON PAIR
	TLNE	F,SKIPSW!FULLSW	;IF SKIPPING
	JRST	COMCO1		;DON'T USE
	PUSHJ	P,SDEF;		SEARCH
	JRST	COMYES;		ALREADY THERE
	HRLS	W
	HRR	W,COMBAS;	PICK UP THIS COMMON LOC
	TLNN	F,SKIPSW!FULLSW
	PUSHJ	P,SYMXX;	DEFINE IT
	MOVS	W,W;		SWAP HALFS
	ADD	W,COMBAS;	UPDATE COMMON LOC
	HRRM	W,COMBAS;	OLD BASE PLUS NEW SIZE
	HLRZS	W;		RETURN ADDRESS
	TLZ	C,400000
	TLNN F,SKIPSW!FULLSW
	PUSHJ	P,SYMXX
COMCOM:	PUSHJ	P,CWSTWX	;STORE A WORD PAIR
COMCO1:	SOS	BLKSIZ
	SOSLE	BLKSIZ
	JRST	COMTOP
	JRST	PASS2

COMYES:	HLRZ	C,2(A);		PICK UP DEFINITION
	CAMLE	W,C;		CHECK SIZE
	JRST	ILC;		ILLEGAL COMMON
	MOVE	C,1(A);		NAME
	HRRZ	W,2(A);	BASE
	JRST	COMCOM

PRSTWX:	PUSHJ	P,WORDPR	;GET A WORD PAIR
CWSTWX:	EXCH	C,W		;SPACE TO STORE FIRST WORD OF PAIR?
	PUSHJ	P,WSTWX		;...
	EXCH	C,W		;THERE WAS; IT'S STORED
WSTWX:	TLNE	F,FULLSW!SKIPSW	;SPACE FOR ANOTHER WORD?
	POPJ	P,		;NOPE, RETURN
	MOVEM	W,@X		;YES, STORE IT.
	AOJA	V,BITWX		;TELL THE TABLES ABOUT IT; THEN RETURN


GSWD:	PUSHJ	P,WORD		;GET WORD FROM TABLE
	PUSHJ	P,WSTWX		;STASH IT
	SOSE	BLKSIZ		;FINISHED?
	JRST	GSWD		;NOPE, LOOP
	POPJ	P,		;TRA 1,4

GSWDPR:	MOVEM	W,BLKSIZ	;KEEP COUNT
GSWDP1:	PUSHJ	P,PRSTWX	;GET AND STASH A PAIR
	SOS	BLKSIZ		;FINISHED?
	SOSLE	BLKSIZ		;...
	JRST	GSWDP1		;NOPE, LOOP
	POPJ	P,		;TRA 1,4
SUBTTL	BEGIN HERE PASS2 TEXT PROCESSING

PASS2:	ADDI V,(X)
IFN REENT,<TLNE F,HIPROG
	HRRZ V,H>
	MOVEM V,TOPTAB	;SAVE FOR OVERLAP CHECKING
	TLNE	F,FULLSW+SKIPSW;	ABORT?
	JRST	ALLOVE;		YES
	MOVE	V,LLC		;PICK UP PROGRAM ORIGIN
	CAML	V,CCON		;IS THIS A PROGRAM?
	JRST	FBLKD		;NO, GO LOOK FOR FIRST BLK DATA
	TLOE	N,PGM1		;YES, IS THIS FIRST F4 PROG?
	JRST	NOPRG		;NO
	HRR	W,COMBAS	;YES, PLACE PROG BREAK IN LH
IFE L,<IFN REENT,<TLNN F,HIPROG	;DON'T BOTHER IF IN HISEG, CHAIN NOT SMART ENOUGH>
	HRLM	W,JOBCHN(X)	;FOR CHAIN>
NOPRG:	HRRZ	W,PLTP;		GET PROG TABLE BASE
	HLRZ	C,PLTP;		AND SIZE
	ADD	W,C;		COMPUTE END OF PROG TABLE
	ADD	W,[POINT 1,1];	AND BEGINNING OF BIT TABLE
	EXCH	W,BITP;		SWAP POINTERS
PASS2B:	ILDB	C,BITP;		GET A BIT
	JUMPE	C,PASS2C;	NO PASS2 PROCESSING
	PUSHJ	P,PROC;		PROCESS A TAG
	JRST	PASS2B;		MORE TO COME
	JRST	ENDTP;

PROC:	LDB	C,[POINT 6,@X,23];	TAG
	SETZM	MODIF;		ZERO TO ADDRESS MODIFIER
	TRZE	C,40
	AOS	MODIF
	MOVEI	W,TABDIS;	HEAD OF TABLE
	HRLI W,-TABLNG	;SET UP FOR AOBJN
	HLRZ	T,(W);		GET ENTRY
	CAME	T,C;		CHECK
	AOBJN W,.-2
	JUMPGE W,LOAD4A	;RAN OUT OF ENTRIES
	HRRZ	W,(W);		GET DISPATCH
	LDB	C,[POINT 12,@X,35]
	JRST	(W);		DISPATCH


PASS2C:	PUSHJ	P,PASS2A
	JRST	PASS2B
	JRST	ENDTP

TABDIS:	XWD 11,PCONS;		CONSTANTS
	XWD 06,PGS;		GLOBAL SUBPROGRAMS
	XWD 20,PST;		SCALARS
	XWD 22,PAT;		ARRAYS
	XWD 01,PATO;		ARRAYS OFFSET
	XWD 00,PPLT;		PROGRAMMER LABELS
	XWD 31,PMLT;		MADE LABESL
	XWD 26,PPT;		PERMANENT TEMPORARYS
	XWD 27,PTT;		TEMPORARY TEMPORARYS
TABLNG==.-TABDIS
;DISPATCH ON A HEADER

HEADER:	CAMN	W,[EXP -2];	END OF PASS ONE
	JRST	ENDS
	LDB	C,[POINT 12,W,35];	GET SIZE
	MOVEM	C,BLKSIZ
	ANDI	W,770000
	JUMPE	W,PLB;	PROGRAMMER LABEL
	CAIN	W,500000;	ABSOLUTE BLOCK
	JRST	ABSI;
	CAIN	W,310000;	MADE LABEL
	JRST	MDLB;		MADE LABEL
	CAIN	W,600000
	JRST	GLOBDF
	CAIN	W,700000;	DATA STATEMENT
	JRST	DATAS
	JRST	LOAD4A;		DATA STATEMENTS WILL GO HERE

TTR50:	RADIX50	10,%TEMP.
PTR50:	RADIX50	10,TEMP.
CNR50:	RADIX50	10,CONST.

SUBTTL	ROUTINES TO PROCESS POINTERS

PCONS:	ADD	C,CCON;		GENERATE CONSTANT ADDRESS
	SOJA	C,PCOMX		;ADJUST FOR 1 AS FIRST ENTRY

PSTA:	PUSHJ	P,SWAPSY	;NON-COMMON SCALARS AND ARRAYS
	ADDI	C,(R);		RELOCATE
PCOM1:	PUSHJ	P,SYDEF		;...
PCOMX:	ADD	C,MODIF		;ADDR RELOC FOR DP
	HRRM	C,@X;		REPLACE ADDRESS
PASS2A:	AOJ	V,;		STEP READOUT POINTER
	CAML	V,CCON		;END OF PROCESSABLES?
CPOPJ1:	AOS	(P);		SKIP
	POPJ	P,;

PAT:	SKIPA	W,ATAB		;ARRAY TABLE BASE
PST:	MOVE	W,STAB		;SCALAR TABLE  BASE
	ROT	C,1		;SCALE BY 2
	ADD	C,W		;ADD IN TABLE BASE
	ADDI	C,-2(X);	TABLE ENTRY
	HLRZ	W,(C);		CHECK FOR COMMON
	JUMPE	W,PSTA;		NO COMMON
	PUSHJ	P,COMDID	;PROCESS COMMON
	JRST	PCOM1

COMDID:	LSH	W,1		;PROCESS COMMON TABLE ENTRIES
	ADD	W,CTAB;		COMMON TAG
	ADDI	W,-2(X);	OFFSET
	PUSHJ	P,SWAPSY;	GET SYMBOL AND SET TO DEFINED
	ADD	C,1(W);		BASE OF COMMON
	SUBI	W,-2(X)		;MAKE W RELATIVE SO WHEN TBLCHK CALLS XPAND WE WIN
	POPJ	P,		;RETURN

PATO:	ROT	C,1
	ADD	C,AOTAB;	ARRAY OFFSET
	MOVEM	C,CT1;		SAVE CURRENT POINTER (LEAVE RELATIVE IN CASE OF XPAND)
	ADDI	C,-2(X);	LOADER OFFSET
	HRRZ	C,1(C);		PICK UP REFERENCE POINTER
	ANDI	C,7777;	MASK TO ADDRESS
	ROT	C,1;		ALWAYS A ARRAY
	ADDI	C,-2(X)
	ADD	C,ATAB
	HLRZ	W,(C);		COMMON CHECK
	JUMPE	W,NCO
	PUSHJ	P,COMDID	;PROCESS COMMON
	PUSHJ	P,SYDEF		;CAN CAUSE CALL TO XPAND, SO AVOID ABSOLUTE ADDRESSES
	MOVE	C,CT1
	ADDI	C,-2(X)		;RELOCATE C AGAIN (AVOID LOSSAGE IF XPAND WAS CALLED)
	HRRE	C,(C)
	ADDI	W,-2(X)		;RELOCATE W AGAIN (AVOID LOSSAGE IF XPAND WAS CALLED)
	ADD	C,1(W)
	JRST	PCOMX

NCO:	PUSHJ	P,SWAPSY;
	ADDI	C,(R)		;DEFINE SYMBOL IN TRUE LOC
	PUSHJ	P,SYDEF		;...
	MOVE	C,CT1
	ADDI	C,-2(X)
	HRRZ	C,(C)		;OFFSET ADDRESS PICKUP
	ADDI	C,(R)		;WHERE IT WILL BE
	JRST	PCOMX		;STASH ADDR AWAY

PTT:	ADD	C,TTEMP;	TEMPORARY TEMPS
	SOJA	C,PCOMX		;ADJUST FOR 1 AS FIRST ENTRY

PPT:	ADD	C,PTEMP;	PERMANENT TEMPS
	SOJA	C,PCOMX		;ADJUST FOR 1 AS FIRST ENTRY

PGS:	ADD	C,GSTAB;	GLOBSUBS
	ADDI	C,-1(X);	OFFSET
	MOVE	C,(C)
	TLC	C,640000;	MAKE A REQUEST
	PUSHJ P,TBLCHK		;CHECK FOR OVERLAP
	MOVEI	W,(V);		THIS LOC
	HLRM	W,@X;		ZERO RIGHT HALF
	PUSHJ	P,SYMXX
	JRST	PASS2A

SYDEF:	TLNE	N,SYDAT		;SYMBOL WANTS DEFININITION?
	POPJ	P,		;NO, GO AWAY
	PUSH	P,C		;SAVE THE WORLD
	PUSH	P,W
	PUSHJ P,TBLCHK	;CHECK FOR OVERLAP
	MOVE	W,C
	SKIPE	C,T	;PICKUP VALUE
	PUSHJ	P,SYMXX
	POP	P,W
	POP	P,C
	POPJ	P,;

PMLT:	ADD	C,MLTP
	JRST	.+2
PPLT:	ADD	C,PLTP
	HRRZ	C,(C)
	JRST	PCOMX

SYMXX:	PUSH	P,V
	PUSHJ	P,SYMPT
	POP	P,V
IFE REENT,<POPJ	P,>
IFN REENT,<JRST RESTRX>

SWAPSY:	MOVEI	T,0;		SET TO EXCHANGE DEFS
	EXCH	T,1(C);		GET NAME
	HRRZ	C,(C)		;GET VALUE
	POPJ	P,
TBLCHK:	HRRZ W,MLTP	;GETT TOP OV TABLES
	SUBI W,2
	CAMG W,TOPTAB	;WILL IT OVERLAP
IFE EXPAND,<TLO F,FULLSW>
IFN EXPAND,<JRST [PUSHJ P,XPAND
		TLOA F,FULLSW
		JRST TBLCHK
		POPJ P,]>
	POPJ P,

SUBTTL	END OF PASS2

ALLOVE:	TLZ	N,F4SW		;END OF F4 PROG
	HRRZ V,SDSTP	;GET READY TO ZERO OUT DATA STMTS
	SETZM (V)	;AT LEAST ONE THERE
	CAIL V,(S)	;IS THERE MORE THAN ONE??
	JRST NOMODS	;NO
	HRLS V
	ADDI V,1	;SET UP BLT
	BLT V,(S)	;ZERO OUT ALL OF IT
NOMODS:	MOVE H,SVFORH
	TLNE	F,FULLSW!SKIPSW
	JRST	HIGH3A
	HRR	R,COMBAS	;TOP OF THE DATA
	CAMG	H,SDS		;HIGHEST LOC GREATER THAN DATA STATEMENTS?
	JRST	HIGH3A		;NO, RETURN
	ADDI	H,1(S)		;YES, SET UP MEANINGFUL ERROR COMMENT
	SUB	H,SDS		;...
	TLO	F,FULLSW	;INDICATE OVERFLO
HIGH3A:	IFN REENT,<SETZ	W,	;CAUSES TROUBLE OTHERWISE
	TLZE F,HIPROG
	JRST HIGHN1
	HRRZ V,GSTAB
	MOVEI V,@X
	CAMLE V,HILOW
	MOVEM V,HILOW>
	HRRZ C,R
	JRST	HIGH31		;RETURN

DATAS:	TLNE	F,FULLSW+SKIPSW
	JRST	DAX
	MOVEI	C,(S)		;ADDR OF WORD UNDER SYMBOL TABLE
	MOVN	W,BLKSIZ	;HOW FAR DOWN TO BLT
	ADDM	W,PLTP		;UPDATE TABLE POINTERS
	ADDM	W,BITP		;...
	ADDM	W,SDSTP		;...
	ADD	C,W		;RH(C):= WHEN TO STOP BLT
	HRL	C,MLTP		;SOURCE OF BLTED DATA
	ADD	W,MLTP		;UPDATE, GET DESTINATION OF BLT DATA
IFN EXPAND,<	HRRZS W	;GET RID OF LEFT HALF
		CAIG W,(H)
		PUSHJ P,[PUSHJ P,XPAND
			POPJ P,
			ADDI W,2000
			ADD C,[XWD 2000,2000]
			JRST POPJM2]>
	HRRM	W,MLTP	;NO SET THIS SO EXTRA CORE NOT ZEROED
	HLL	W,C		;FORM BLT POINTER
	BLT	W,-1(C)		;MOVE TABLES DOWN (BUT NOT JRST ALLOVE)
	PUSHJ	P,BITWX
DAX:	PUSHJ	P,WORD;		READ ONE WORD
	TLNN	F,FULLSW+SKIPSW
	MOVEM	W,(C)
	SOSLE	BLKSIZ		;COUNT OF DATA SEQUENCE SIZE
	AOJA	C,DAX		;INCREMENT DATA SEQUENCE DEPOSIT LOC
	JRST	TEXTR;		DONE

FBLKD:	TLOE	N,BLKD1		;IS THIS FIRST BLOCK DATA?
	JRST	ENDTP		;NO
	HRR	V,COMBAS	;PLACE PROG BREAK IN RH FOR
IFE L,<IFN REENT,<	TLNN F,HIPROG>
	HRRM	V,JOBCHN(X)	;CHAIN>
ENDTP:	TLNE	F,FULLSW+SKIPSW
	JRST	ALLOVE
	HRR	V,GSTAB
ENDTP0:	CAML	V,STAB;		ANY MORE GLOBSUBS
	JRST	ENDTP2;		NO
	MOVE	C,@X;		GET SUBPROG NAME
	PUSHJ	P,SREQ;		IS IT ALLREADY REQUESTED
	AOJA	V,ENDTP0;	YES
	PUSHJ	P,SDEF;		OR DEFINED
	AOJA	V,ENDTP0;	YES
	PUSHJ	P,TBLCHK
	MOVEI	W,0		;PREPARE DUMMY LINK
	TLNN	F,FULLSW+SKIPSW	;ABORT
	PUSHJ	P,SYM3X;	PUT IN DUMMY REQUEST
	PUSHJ	P,BITWX;	OVERLAP CHECK
	AOJA	V,ENDTP0
ENDTP2:	SETZM	PT1
ENDTPW:	HRRZ	V,SDSTP
IFN EXPAND,<IFN REENT,<TLNE F,HIPROG
		JRST ENDTPI>
		SUBI V,(X)
		CAMG V,COMBAS
		JRST	[SUB V,COMBAS
			MOVNS	V
			PUSHJ P,XPAND9
			TLO F,FULLSW
			JRST .+1]
ENDTPH:		HRR V,SDSTP>
	HRRZM	V,SDS		;DATA STATEMENT LOC
ENDTP1:	SUBI	V,(X);		COMPENSATE FOR OFFSET
	MOVE	W,@X;	GET WORD
	TLNE	W,-1;		NO LEFT HALF IMPLIES COUNT
	JRST	DODON;		DATA DONE
	ADD	W,[MOVEI W,3]
	ADDI	W,@X
	EXCH	W,@X
	AOJ	V,
	ADD	W,@X;		ITEMS COUNT
	MOVEM	W,ITC
	MOVE	W,[MOVEM W,LTC]
	MOVEM	W,@X;		SETUP FOR DATA EXECUTION
	AOJ	V,
	MOVSI	W,(MOVEI W,0)
	EXCH	W,@X
	MOVEM	W,ENC;		END COUNT
	AOJ	V,
	MOVEI	W,@X
	ADDM	W,ITC
LOOP:	MOVE	W,@X
	HLRZ	T,W;		LEFT HALF INST.
	ANDI	T,777000
	CAIN	T,254000	;JRST?
	JRST	WRAP		;END OF DATA
	CAIN	T,260000	;PUSHJ?
	JRST	PJTABL(W)	;DISPATCH VIA TABLE
	CAIN	T,200000;	MOVE?
	AOJA	V,INNER
	CAIN	T,270000;	ADD?
	JRST	ADDOP
	CAIN	T,221000;	IMULI?
	AOJA	V,LOOP
	CAIE	T,220000;	IMUL?
	JRST	LOAD4A;		NOTA
INNER:	HRRZ	T,@X;		GET ADDRESS
	TRZE	T,770000;	ZERO TAG?
	SOJA	T,CONPOL;	NO, CONSTANT POOL
	JUMPE T,FORCNF
	SUB	T,PT1;		SUBTRACT INDUCTION NUMBER
	ASH	T,1
	SUBI T,1
	HRRM	T,@X
	HLRZ	T,@X
	ADDI	T,P
	HRLM	T,@X
	AOJA	V,LOOP
IFN EXPAND,<IFN REENT,<ENDTPI:	HRRZ V,COMBAS
	MOVEI V,@X
	CAMLE V,JOBREL
	JRST	[PUSHJ P,HIEXP
		TLOA F,FULLSW
		JRST ENDTPI
		JRST ENDTPH]
	JRST ENDTPH>>
FORCNF:	ERROR	,</FORTRAN CONFUSED ABOUT DATA STATEMENTS#/>
	JRST LD2

CONPOL:	ADD	T,ITC;	CONSTANT BASE
	HRRM	T,@X
	AOJA	V,LOOP

ADDOP:	HRRZ	T,@X
	TRZE	T,770000
	SOJA	T,CONPOL
SKIPIN:	AOJA	V,LOOP

PJTABL:	JRST	DWFS		;PUSHJ 17,0
	AOSA	PT1		;INCREMENT DO COUNT
	SOSA	PT1;		DECREMENT DO COUNT
	SKIPA	W,[EXP DOINT.]
	MOVEI	W,DOEND.
	HRRM	W,@X
	AOJA	V,SKIPIN	;SKIP A WORD

DWFS:	MOVEI	W,DWFS.
	HRRM	W,@X
	AOJ	V,
	TLO	N,SYDAT
	PUSHJ	P,PROC;		PROCESS THE TAG
	JRST	LOAD4A		;DATA STATEMENT BELOW CODE TOP
	JRST	LOOP		;PROPER RETURN

DOINT.:	POP	P,V;		GET ADDRESS OF INITIAL VALUE
	PUSH	P,(V);		STORE INDUCTION VARIABLE
	AOJ	V,
	PUSH	P,V;		INITIAL ADDRESS
	JRST	(V)

DOEND.:	HLRE	T,@(P)		;RETAIN SIGN OF INCREMENT
	ADDM	T,-2(P);	INCREMENT
	HRRZ	T,@(P);		GET FINAL VALUE
	SUB	T,-2(P)		;FINAL - CURRENT
	IMUL	T,@(P)		;INCLUDE SIGN OF INCREMENT
	JUMPL	T,DODONE	;SIGN IS ONLY IMPORTANT THING
	POP	P,(P);		BACK UP POINTER
	JRST	@(P)

DODONE:	POP	P,-1(P);	BACK UP ADDRESS
	POP	P,-1(P)
	JRST	CPOPJ1		;RETURN

WRAP:	MOVE	W,ENC;		NUMBER OF CONSTANTS
	ADD	W,ITC;		CONSTANT BASE
	MOVEI	C,(W);		CHAIN
	HRRM	C,@X
	MOVEI	V,(W);		READY TO GO
	JRST	ENDTP1

DODON:	TLZ	N,RCF!SYDAT!DZER	;DATA STATEMENT FLAGS
	MOVE	W,PTEMP		;TOP OF PROG
	ADDI	W,(X)		;+OFFSET
	HRRZ C,SDS
IFE EXPAND,<SUBI C,(X)	;CHECK FOR ROOM
	CAMGE C,COMBAS	;IS IT THERE
	TLO F,FULLSW	;NO (DONE EARLIER IF EXPAND)
	HRRZ C,SDS>
	SUBI C,1	;GET ONE LESS (TOP LOCATION TO ZERO)
IFN REENT,<TLNE F,HIPROG
	MOVE C,JOBREL>
SECZER:	CAMLE	W,C		;ANY DATA TO ZERO?
	JRST	@SDS		;NO, DO DATA STATEMENTS
				;FULLSW IS ON IF COMBAS GT. SDS
	TLNN	F,FULLSW+SKIPSW	;SHOULD WE ZERO?
	SETZM	(W)		;YES, DO SO
	TLON	N,DZER		;GO BACK FOR MORE?
	AOJA	W,SECZER	;YES, PLEASE
	HRLI	W,-1(W)		;SET UP BLT POINTER TO ZERO DATA
	TLNN	F,FULLSW+SKIPSW	;SHOULD WE ZERO?
	BLT	W,(C)		;YES, DO SO
	JRST	@SDS		;GO DO DATA STATEMENTS

DATAOV:	ERROR	0,</DATA STATEMENT OVERFLOW#/>
	JRST	LD2

DREAD:	TLNE	N,RCF;		NEW REPEAT COUNT NEEDED
	JRST	FETCH;		NO
	MOVE	W,LTC
	MOVEM	W,LTCTEM
	MOVE	W,@LTC;		GET A WORD
	HLRZM	W,RCNT;		SET REPEAT COUNT
	HRRZM	W,WCNT;		SET WORD COUNT
	POP	W,(W);		SUBTRACT ONE FROM BOTH HALFS
	HLLM	W,@LTC;		DECREMENT REPEAT COUNT
	AOS	W,LTC;		STEP READOUT
	TLO	N,RCF
FETCH:	MOVE	W,@LTC
	AOS	LTC
	SOSE	WCNT
	POPJ	P,;
	SOSN	RCNT
	JRST	DOFF.
	MOVE	V,LTCTEM;	RESTORE READOUT
	MOVEM	V,LTC
DOFF.:	TLZ	N,RCF;		RESET DATA REPEAT FLAG
	POPJ	P,;

DWFS.:	MOVE	T,(P)
	AOS	(P)
	MOVE	T,(T);		GET ADDRESS
	HLRZM	T,DWCT;		DATA WORD COUNT
	HRRZS	T
	ADDI	T,(W);		OFFSET
IFN REENT,<HRRZS T		;CLEAR LEFT HALF INCASE OF CARRY
	CAML T,HVAL1
	JRST	[ADD T,HIGHX
		HRRZS T	;MUST GET RID OF LEFT HALF
		CAMLE T,JOBREL
		JRST DATAOV	;IN CASE FORTRAN GOOFS ON LIMITS
		JRST DWFS.1]
	ADD T,LOWX
	HRRZS T>
IFE REENT,<ADDI T,(X)>
	CAML T,SDS
	JRST DATAOV
DWFS.1:	PUSHJ	P,DREAD		;GET A DATA WORD
	HRRZS T
IFN REENT,<CAMG T,JOBREL	;JUST TO MAKE SURE>
	CAMN T,SDS
	JRST DATAOV
	TLNN	F,FULLSW+SKIPSW	;LOAD THE NEXT DATA ITEM?
	MOVEM	W,(T)		;YES, STORE IT
	SOSE	W,DWCT;		STEP DOWN AND TEST
	AOJA T,DWFS.1		;ONE MORE TIME, MOZART BABY!
	POPJ	P,

SUBTTL	ROUTINE TO SKIP FORTRAN OUTPUT

;SUBSECTION OF THE ROUTINE TO HANDLE OUTPUT FROM THE
;FORTRAN IV COMPILER. THE MAIN OBJECT OF THE ROUTINE IS TO
;LOOK FOR THE END BLOCK. CODE TAKEN FROM FUDGE2.

MACHCD:	HRRZ	C,W		;GET THE WORD COUNT
	PUSHJ	P,WORD		;INPUT A WORD
	SOJG	C,MACHCD	;LOOP BACK FOR REST OF THE BLOCK
				;GO LOOK FOR NEXT BLOCK

REJECT:	PUSHJ	P,WORD		;READ A FORTRAN BLOCK HEADER
	TLC	W,-1		;TURN ONES TO ZEROES IN LEFT HALF
	TLNE	W,-1		;WAS LEFT HALF ALL ONES?
	JRST	REJECT		;NO, IT WAS CALCULATED MACHINE CODE
	CAIN	W,-2		;YES, IS RIGHT HALF = 777776?
	JRST	ENDST		;YES, PROCESS F4 END BLOCK
	LDB	C,[POINT 6,W,23];GET CODE BITS FROM BITS 18-23
	TRZ	W,770000	;THEN WIPE THEM OUT
	CAIE	C,70		;IS IT A DATA STATEMENT?
	CAIN	C,50		;IS IT ABSOLUTE MACHINE CODE?
	JRST	MACHCD		;YES, TREAT IT LIKE DATA STATEMENTS
	PUSHJ	P,WORD		;NO, ITS A LABEL OF SOME SORT
	JRST	REJECT		;WHICH CONSISTS OF ONE WORD
				;LOOK FOR NEXT BLOCK HEADER

ENDST:	MOVEI	C,1		;TWO WORDS, FIVE TABLES, ONE WORD, ONE TABLE
	MOVEI	T,6		;TO GO
F4LUP1:	PUSHJ	P,WORD		;GET TABLE MEMBER
F4LUP3:	SOJGE	C,F4LUP1	;LOOP WITHIN A TABLE
	JUMPL	T,LOAD1		;LAST TABLE - RETURN
	SOJG	T,F4LUP2	;FIRST TWO WORDS AND FIVE TABLES
	JUMPE	T,F4LUP1	;COMMON LENGTH WORD
F4LUP2:	PUSHJ	P,WORD		;READ HEADER WORD
	MOVE	C,W		;COUNT TO COUNTER
	JRST	F4LUP3		;STASH

SUBTTL	LISP LOADER


IFN L,<
	LIT
	VAR
LODMAK:	MOVEI A,LODMAK
	MOVEM A,137
	INIT 17
	SIXBIT /DSK/
	0
	HALT
	ENTER LMFILE
	HALT
	OUTPUT [IOWD 1,LMLST	;OUTPUT LENGTH OF FILE
		0]
	OUTPUT LMLST
	STATZ 740000
	HALT
	RELEASE
	CALL [SIXBIT /EXIT/]

LMFILE:	SIXBIT /LISP/
	SIXBIT /LOD/
	0
	0

LMLST:	IOWD LODMAK+1-LD,137
	0

	END LODMAK>

IFE SORTSY,<	END	BEG>

SUBTTL	SYMSRT - SORT SYMBOL TABLE FOR RAID
;THE REMAINDER OF THIS ASSEMBLY IS CONDITIONAL ON SORTSY SWITCH NON ZERO.


COMMENT $
		Symbol Table Format

Word 		Description
  0		-1		flags new format symbol table
  1		BN		relative pointer to Block Names
  2		BS		relative pointer to Block Structure
  3		FULLV		relative pointer to full word values
  4		FREES		relative pointer to free space
  5		CLASS1		relative pointer to first class 1 symbol
  6		CLASS2		relative pointer to first class 2 symbol
  7		CLASS3		relative pointer to first class 3 symbol
 10		CLASS4		relative pointer to first class 4 symbol
 11		LASTV		relative pointer to first word beyond
					the symbol table
 BN		table of RADIX50 block and program names
 BS		table of block and program structure (see below)
 FULLV		table of full word values pointed to by class 4 symbols
 FREES		free space for adding symbols.  initially zero
 CLASS1		Pairs of words for each class 1 symbol.
		First word is RADIX50 of symbol name with type flags
		Second word: Byte(13)bnum(5)0(18)value
		where bnum is an index to BN and BS table.
		Class 1 symbols have values in the range 0 to 377777.

 CLASS2		Same as CLASS1 space, except class2 symbols have
		values in the range of 400000 to 777777.

 CLASS3		Same as CLASS1 space, except class3 symbols have
		non-zero values with zero right halves.  The left
		half of the value is stored in the right half of
		the value word of the symbol entry.

 CLASS4		Pairs of words for each class 4 symbol.
		First word is RADIX50 of symbol name with type flags
		Second word: Byte(13)bnum(5)14(18)vp.
		Bnum is an index to BN and BS table.
		Vp is a pointer, relative to beginning of symbol table,
		to a word in the FULLV table that contains the value.
		Note that the index field is set to 14, so that if 14
		contains the address of the symbol table, you may
		indirect through this word.
		Class 4 values are all values not contained in the
		other classes.


Values are sorted by arithmetic order in each class.  Class 3 values
are considered as right-half quantities while being sorted.

Block Structure space:

All pointers in BS space are relative to BS space (and may be used
to index BN space).  BN (block name) space comes before BS space
in the symbol table.

Words corresponding to program names have left-half links to the next
program name.  Zero terminates this list.  Right-halves are zero. 
Word zero of BS space always corresponds to a program name. 

Words corresponding to block names have left-half links to the BS
space word corresponding to the program containing this block.  The
right-half links to the block immediately containing this block.  The
outermost block's right-half link points to the program name word. 
All blocks that are associated with a particular program are entered
immediately following that program name, and before the next program
name.

$

;SYMSRT
;CALLING:
;	MOVE	S,[IOWD POINTER TO UNDEF GLOBALS]
;	MOVE	B,[IOWD POINTER TO SYMBOLS]
;	PUSHJ	17,SYMSRT
;	RETURN HERE ALWAYS.  B CONTAINS NEW IOWD.  RH OF S ALSO SET FROM RH OF B.
;	(LH OF S IS ZEROED)
;NO OTHER ACS ARE CLOBBERED.

SYMSRT:	MOVEM	16,SRTSAC+16
	MOVEI	16,SRTSAC
	BLT	16,SRTSAC+15
	HLLZ	B,B		;KEEP ONLY COUNT OF DEFINED SYMBOLS
	ADD	B,S		;IOWD TO ALL SYMBOLS, INCLUDING UNDEF GLOBALS
	JUMPGE	S,SYMSX2	;JUMP IF THERE ARE NO UNDEF GLOBALS
SYMSX1:	SKIPL	A,1(S)		;SKIP IF THIS ISN'T A GLOBAL SYMBOL NAME
	TLNN	A,40000		;SKIP IF THIS IS A GLOBAL UNDEF SYMBOL
	SETZM	1(S)		;NOT A GLOBAL SYMBOL-FLUSH SYMBOL NAME
	SETZM	2(S)		;SET SYMBOL VALUE TO 0
	ADD	S,SE3
	JUMPL	S,SYMSX1
SYMSX2:	

;PASS 1 - LOOK THRU THE OLD SYMBOL TABLE AND COUNT VARIOUS THINGS.

	SETZM	CLASST		;ZERO CLASS COUNTERS
	MOVE	2,[CLASST,,CLASST+1]
	BLT	2,CLASST+4

	MOVEI	16,1(B)		;ADDR
	HLRO	15,B		;-N
	MOVN	15,15		;N
	HRL	15,15		;N,,N
	ADD	16,15		;N,,ADDR+N
	SUB	16,[2,,2]	;N-2,,ADDR+N-2.  GOD HELP YOU IF RESULT IS NEGATIVE
	MOVEM	16,OPTR		;SAVE POINTER
SYMLP1:	SKIPN	15,(16)		;GET RADIX50
	JRST	SYLP1Z		;NOTHING THERE.
	MOVE	14,1(16)	;14_VALUE; 15_RADIX50
	MOVEI	2,0		;ASSUME "CLASS 0" = BLOCK/PROGRAM NAME
	LDB	13,[POINT 4,15,3]	;GET SYMBOL TYPE
	JUMPE	13,SYLP1A		;0 IS PROGRAM NAME
	CAIN	13,3
	JRST	SYLP1A			;14 IS BLOCK NAME
	PUSHJ	P,CLASS		;2_CLASS TYPE (1,2,3 OR 4)
SYLP1A:	AOS	CLASST(2)	;COUNT EACH SYMBOL CLASS
SYLP1Z:	SUB	16,[2,,2]
	JUMPG	16,SYMLP1
;;FALL OFF PAGE

;NOW, HOW BIG IS SYMBOL TABLE GOING TO BE?
	MOVE	2,CLASST	;NUMBER OF PROGRAM/BLOCK NAMES
	ADD	2,CLASST+1	;PLUS CLASS 1
	ADD	2,CLASST+2	;PLUS CLASS 2
	ADD	2,CLASST+3	;PLUS CLASS 3
	ADD	2,CLASST+4	;PLUS CLASS 4
	LSH	2,1		;TIMES 2
	ADD	2,CLASST+4	;PLUS THIRD WORD FOR EACH CLASS 4 SYMBOL
	ADD	2,KORSP		;PLUS USER REQUESTED SYMBOL PATCH SPACE
	ADDI	2,12		;PLUS OVERHEAD WORDS AT FRONT OF TABLE
	MOVE	1,JOBREL
	MOVN	3,2
	HRL	1,3		;-WC,,MA-1 OF NEW SYMBOL TABLE
	MOVEM	1,NPTR		;SAVE IOWD POINTER TO NEW SYMBOLS
	HRRZM	1,NBASE		;SET BASE OF NEW SYMBOL TABLE
	AOS	NBASE		;DIRECT POINTER TO NEW TABLE
	ADD	1,2		;LAST ADDRESS NEEDED
	MOVE	3,1		;SAVE THIS (IS LAST ADDRESS FOR BLT)
	CORE	1,		;GET SOME CORE
	PUSHJ	P,MORCOR	;LOSE.
	MOVE	1,NBASE
	SETZM	(1)
	HRL	1,1		;NBASE,,NBASE
	ADDI	1,1		;SOURCE,,DEST FOR BLT
	BLT	1,(3)		;ZERO NEW CORE SPACE FOR SYMBOL TABLE
	MOVE	1,NBASE		;GET BASE ADDRESS AGAIN
	SETOM	(1)		;-1 FLAGS THE NEW FORMAT SYMBOLS
	MOVEI	3,12		;POINTER TO BN
	MOVEM	3,1(1)		;BN POINTER
	ADD	3,CLASST	;PLUS NUMBER OF BN'S
	MOVEM	3,2(1)		;GIVES POINTER TO BS'S
	ADD	3,CLASST	;PLUS NUMBER OF BS'S (= NUMBER OF BN'S)
	MOVEM	3,3(1)		;GIVES POINTER TO FV'S
	ADD	3,CLASST+4	;PLUS NUMBER OF FV'S
	MOVEM	3,4(1)		;GIVES POINTER TO FF
	ADD	3,KORSP		;PLUS AMOUNT OF FREE SPACE
	MOVEM	3,5(1)		;GIVES POINTER TO CLASS1
	ADD	3,CLASST+1
	ADD	3,CLASST+1	;PLUS 2*CLASS1 SPACES
	MOVEM	3,6(1)		;POINTER TO CLASS2 SPACE
	ADD	3,CLASST+2
	ADD	3,CLASST+2
	MOVEM	3,7(1)		;POINTER TO CLASS3 SPACE
	ADD	3,CLASST+3
	ADD	3,CLASST+3
	MOVEM	3,10(1)		;POINTER TO CLASS4 SPACE
	ADD	3,CLASST+4
	ADD	3,CLASST+4
	MOVEM	3,11(1)		;POINTER TO THE END OF THE AREA.


;PASS 2 - COPY SYMBOL NAMES TO NEW SYMBOL TABLE.  BUILD BN/BS AREAS

;1 STILL CONTAINS NBASE

	SETZM	CLASST		;ZERO CLASS COUNTERS
	MOVE	2,[CLASST,,CLASST+1]
	BLT	2,CLASST+4

	SETOM	SVSTK
	SETOM	ID
	SETZM	PD

	MOVE	16,OPTR		;GET POINTER TO OLD TABLE
SYMLP2:	SKIPN	15,(16)		;GET RADIX50
	JRST	SYLP2Z		;NOTHING THERE.
	MOVE	14,1(16)	;14_VALUE; 15_RADIX50
	LDB	13,[POINT 4,15,3]	;GET SYMBOL TYPE
	JUMPE	13,SYLP2B		;0 IS PROGRAM NAME
	CAIN	13,3
	JRST	SYLP2C			;14 IS BLOCK NAME
	PUSHJ	P,CLASS			;2_CLASS TYPE (1,2,3 OR 4)
	AOS	3,CLASST(2)	;COUNT CLASS TYPE
	CAIN	2,3		;CLASS 3 SYMBOL?
	MOVSS	1(16)		;YES.  SWAP HALVES TO MAKE THE SORT WORK RIGHT.
	LSH	3,1		;DOUBLE COUNT TO MAKE INDEX.
	ADDI	2,4(1)		;GET ADDRESS OF BASE OF CLASS
	ADD	3,(2)		;RELATIVE ADDRESS IN NEW SYMBOL TABLE+2
	ADDI	3,(1)		;ABSOLUTE ADDRESS+2
	MOVEM	15,-2(3)	;STORE RADIX50 OF SYMBOL
	HRLZ	14,ID		;GET BLOCK ID
	LSH	14,5		;MOVE IT OVER TO MAKE ROOM FOR INDEX/INDIRECT
	HRRI	14,1(16)	;POINTER TO THE VALUE CELL
	MOVEM	14,-1(3)	;STUFF IN NEW SYMBOL TABLE
	JRST	SYLP2Z		;LOOP.

SYLP2B:	MOVE	6,PD
	MOVEI	14,0		;ARGUMENT TO SYLPOP
	CAMGE	6,ID		;IF PD .LT. ID THERE WERE NESTED BLOCKS
	PUSHJ	P,SYLPOP	;POP NESTED BLOCKS BELONGING TO PREVIOUS PD
	AOS	6,ID		;COUNT NEW PROGRAM ID
	MOVE	11,1(1)		;GET BASE OF BN AREA
	ADDI	11,(1)
	ADDI	11,(6)		;PLUS CURRENT INDEX
	MOVEM	15,(11)		;STORE CURRENT PROGRAM NAME IN BN SPACE
	MOVE	7,PD		;GET PD OF PREVIOUS PROGRAM
	MOVEM	6,PD		;STORE NEW PD
	MOVE	11,2(1)		;GET POINTER TO BS SPACE
	ADDI	11,(1)
	ADDI	11,(7)
	HRLZM	6,(11)		;LH POINTER TO CURRENT ID IN PREVIOUS PROG'S WORD
	JRST	SYLP2Z		;GET NEXT


SYLP2C:	AOS	6,ID		;COUNT NEW BLOCK
	MOVE	11,1(1)		;GET BASE OF BN AREA
	ADDI	11,(1)
	ADDI	11,(6)		;PLUS CURRENT INDEX
	MOVEM	15,(11)		;STORE CURRENT BLOCK NAME IN BN SPACE
	PUSHJ	P,SYLPOP	;14 HAS BLOCK LEVEL.
SYLP2Z:	SUB	16,[2,,2]
	JUMPG	16,SYMLP2

	MOVE	6,PD
	MOVE	11,2(1)		;GET BASE OF BS AREA
	ADDI	11,(1)
	ADDI	11,(6)		;PLUS CURRENT INDEX
	SETZB	14,(11)		;FINISH BS LINKAGE FOR LAST PROGRAM
	CAMGE	6,ID
	PUSHJ	P,SYLPOP	;FINISH DANGLING BLOCK STRUCTURE
;;FALL OFF PAGE

;WE SORT THINGS HERE
	MOVE	2,5(1)			;FIRST ADDRESS FOR CLASS1
	MOVE	3,6(1)			;FIRST ADDRESS BEYOND CLASS1
	ADDI	2,(1)			;MAKE ADDRESSES ABSOLUTE
	ADDI	3,-2(1)			;MAKE ADDRESS WITHIN CLASS
	CAILE	3,(2)			;DON'T SORT EMPTY RANGE OR ONLY ONE ELEMENT
	PUSHJ	P,SSORT			;SORT RANGE
	MOVE	2,6(1)			;FIRST ADDRESS FOR CLASS2
	MOVE	3,7(1)			;FIRST ADDRESS BEYOND CLASS2
	ADDI	2,(1)			;MAKE ADDRESSES ABSOLUTE
	ADDI	3,-2(1)			;MAKE ADDRESS WITHIN CLASS
	CAILE	3,(2)			;DON'T SORT EMPTY RANGE OR ONLY ONE ELEMENT
	PUSHJ	P,SSORT			;SORT RANGE
	MOVE	2,7(1)			;FIRST ADDRESS FOR CLASS3
	MOVE	3,10(1)			;FIRST ADDRESS BEYOND CLASS3
	ADDI	2,(1)			;MAKE ADDRESSES ABSOLUTE
	ADDI	3,-2(1)			;MAKE ADDRESS WITHIN CLASS
	CAILE	3,(2)			;DON'T SORT EMPTY RANGE OR ONLY ONE ELEMENT
	PUSHJ	P,SSORT			;SORT RANGE
	MOVE	2,10(1)			;FIRST ADDRESS FOR CLASS4
	MOVE	3,11(1)			;FIRST ADDRESS BEYOND CLASS4
	ADDI	2,(1)			;MAKE ADDRESSES ABSOLUTE
	ADDI	3,-2(1)			;MAKE ADDRESS WITHIN CLASS
	CAILE	3,(2)			;DON'T SORT EMPTY RANGE OR ONLY ONE ELEMENT
	PUSHJ	P,SSORT			;SORT RANGE


;COPY SYMBOL VALUES TO NEW TABLE
	MOVE	2,5(1)			;FIRST CLASS1 VALUE
	MOVE	3,10(1)			;FIRST BEYOND CLASS3
	ADDI	2,(1)			;MAKE ADDRESSES ABSOLUTE
	ADDI	3,(1)
SYMLP3:	CAIL	2,(3)			;AT THE END YET?
	JRST	SYML3A			;YES.
	MOVE	4,@1(2)			;GET VALUE
	HRRM	4,1(2)			;REPLACE POINTER WITH VALUE
	ADDI	2,2
	JRST	SYMLP3

SYML3A:	MOVE	2,10(1)			;FIRST CLASS4 VALUE
	MOVE	3,11(1)			;FIRST BEYOND CLASS4
	MOVE	4,3(1)			;ADDRESS OF FULL WORD SPACE
	ADDI	2,(1)			;MAKE ADDRESSES ABSOLUTE
	ADDI	3,(1)
	ADDI	4,(1)
	MOVE	5,3(1)			;RELATIVE ADDRESS OF FULL WORD SPACE
	HRLI	5,14			;SET INDEX FIELD
SYML3B:	CAIL	2,(3)			;AT THE END YET?
	JRST	SYMXIT			;YES. - ALL DONE
	MOVE	6,@1(2)			;GET VALUE
	MOVEM	6,(4)			;STORE IN FULL WORD SPACE
	DPB	5,[POINT 23,1(2),35]	;STORE RELATIVE POINTER TO SYMBOL. AND INDEX
	ADDI	2,2			;ADVANCE TO NEXT SYMBOL
	ADDI	4,1			;ADVANCE ABSOLUTE POINTER TO FULL WD SPACE
	AOJA	5,SYML3B		;ADVANCE RELATIVE POINTER TO FULL WD SPACE

SYMXIT:	MOVSI	16,SRTSAC
	BLT	16,16
	MOVE	B,NPTR		;RETURN NEW POINTER
	HRRZ	S,NPTR		;CHANGE S TOO.
; LEAVE BLANK SPACE FOR RAID AND UNDEFINED TABLE FOR DDT
;	SETZM	KORSP		;EXTRA SPACE IS NOW INSIDE THE SYM. TABLE.
	POPJ	P,

;CALL WITH 2=FIRST ADDRESS IN RANGE, 3=ADDRESS OF LAST ITEM IN RANGE
;THIS IS QUICKSORT WITHOUT STRAIGHT INSERTION SORT FOR SMALL SUBFILES.

SSORT:	MOVEI	4,(2)			;LEFT POINTER
	MOVEI	5,(3)			;RIGHT POINTER
	MOVE	6,@1(4)			;"KEY LEFT" ELEMENT
MRST1:	CAML	6,@1(5)			;IF "KEY LEFT" .GT. "KEY RIGHT"
	JRST	MRST2			;NEED TO EXCHANGE (OR MAYBE STOP?)
	SUBI	5,2			;MOVE RIGHT SIDE TOWARD CENTER
	JRST	MRST1			;LOOP

MRST2:	CAIN	4,(5)			;REACHED THE MIDDLE YET?
	JRST	MRST4			;YES. NOW TIME TO SORT THE SUBFILES.
	MOVE	7,(4)			;EXCHANGE
	EXCH	7,(5)
	MOVEM	7,(4)
	MOVE	7,1(4)
	EXCH	7,1(5)
	MOVEM	7,1(4)
MRST3:	ADDI	4,2			;MOVE LEFT END TOWARD CENTER
	CAMLE	6,@1(4)
	JRST	MRST3			;"KEY RIGHT" .GT. "KEY LEFT"
	CAIN	4,(5)			;REACHED THE MIDDLE YET?
	JRST	MRST4			;YES. NOW TIME TO SORT THE SUBFILES.
	MOVE	7,(4)			;EXCHANGE
	EXCH	7,(5)
	MOVEM	7,(4)
	MOVE	7,1(4)
	EXCH	7,1(5)
	MOVEM	7,1(4)
	SUBI	5,2			;MOVE RIGHT SIDE TOWARD CENTER
	JRST	MRST1			;LOOP

MRST4:	MOVEI	6,(3)
	SUBI	6,(2)
	JUMPE	6,CPOPJ			;IF 2=3, THE ONE ELEMENT FILE IS SORTED
	LSH	6,-1			;C=1/2 SIZE OF ORIGINAL FILE.
	MOVEI	7,(3)
	SUBI	7,(5)			;D=SIZE OF RIGHT SUBFILE
	CAILE	6,(7)			;IF D .GT. C THEN SORT LEFT SUBFILE FIRST.
	JRST	MRST5			;C .GT. D SORT RIGHTSUBFILE FIRST.
	MOVSI	6,2(4)
	HRRI	6,(3)			;LEFT EDGE,,RIGHT EDGE OF RIGHTSUBFILE
	MOVEI	3,(4)			;SET RIGHT EDGE OF SMALL SUBFILE
	JRST	MRST6

MRST5:	MOVSI	6,(2)
	HRRI	6,-2(4)
	MOVEI	2,(4)
MRST6:	PUSH	P,6			;STUFF ON STACK.
	PUSHJ	P,SSORT			;!
	POP	P,6
	MOVEI	3,(6)
	HLRZ	2,6
	JRST	SSORT

SYLPOP:	HRL	6,PD		;PD COPIED TO LH OR ARGUMENT
	SKIPGE	7,SVSTK		;GET "STACK TOP"
	JRST	SYLPSH		;STACK IS EMPTY.  TIME TO PUSH
SYLPP1:	ADD	7,2(1)		;GET STACK ADDRESS
	ADDI	7,(1)
	HRRZ	10,(7)
	CAMG	10,14		;IS STACK LEVEL GREATER THAN BLOCK LEVEL?
	JRST	SYLPSH		;NO. WE CAN PUSH NEW ENTRY
	HLRE	10,(7)		;GET NEW STACK TOP TO 10
	MOVEM	10,SVSTK	;SAVE NEW STACK TOP
	MOVEM	6,(7)		;STORE NEW STUFF IN STACK
	SKIPL	7,10
	JRST	SYLPP1		;LOOP UNTIL NO STACK OR WE FIND THE PLACE
	JUMPLE	14,CPOPJ	;STACK EMPTIED.  ONLY PUSH ITEM IF REAL
SYLPSH:	HRL	14,SVSTK	;OLD STACK POINTER,,BLOCK LEVEL
	HRRZM	6,SVSTK		;STORE NEW TOP OF STACK
	ADD	6,2(1)
	ADDI	6,(1)
	MOVEM	14,(6)		;STUFF DATA ON TOP OF STACK.
	POPJ	P,


CLASS:	MOVEI	2,1		;ASSUME CLASS 1
	JUMPL	14,CLASS3	;IF NEGATIVE IT MUST BE CLASS 3 OR 4
	CAIGE	14,400000	;LOWER SEGMENT
	POPJ	P,		;CLASS 1
	CAIG	14,777777	;UPPER SEGMENT
	AOJA	2,CPOPJ		;YES - CLASS 2
CLASS3:	MOVEI	2,3		;CLASS 3 OR 4
	TRNE	14,777777	;ANYTHING IN RH?
	MOVEI	2,4		;YES. THIS IS CLASS 4
	POPJ	P,

SRTSAC:	BLOCK	20		;SAVE ACS DURING SORT
NBASE:	0
OPTR:	0
NPTR:	0			;POINTER TO NEW SYMBOLS
CLASST:	BLOCK	5		;"CLASS 0" THRU CLASS 4
PD:	0
ID:	0
SVSTK:	0
DOSORT:	0			;SET TO -1 WHEN /? SWITCH IS SEEN

	END	BEG