SUBTTL	RP GRUEN/NGP/WFW/DMN  V.052	7-SEP-70
; RFS 11-30-70
;	TURNED ON FAILSW,SAILSW FOR NIH USAGE.


	VLOADER==52
	VPATCH==0		;DEC PATCH LEVEL
	VCUSTOM==0		;NON-DEC PATCH LEVEL

	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
*
     

SUBTTL	DEFAULT ASSEMBLY SWITCH SETTINGS

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

IFNDEF L,<L=0>

IFNDEF TEN30,<TEN30=0>

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

IFNDEF	K,<K=0>

IFNDEF STANSW,<STANSW=0>
IFN STANSW,<	LDAC=1
		FAILSW=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>

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>

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>
     

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==↑D5	;#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]
OPDEF	SETNAM	[CALLI	43]
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>
	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	(SIXBIT /LOA/)	;LOADER NAME PART OF FILE NAME.
	MOVEM	CTLNAM
	MOVSI	(SIXBIT /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
	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:>
IFN L,< HRRZM 0,LSPXIT
	MOVEI 0,0
	HRRZM R,RINITL
	RESET>
IFE L,<IFN RPGSW,<
	HLLZS	JOBERR		;MAKE SURE ITS CLEAR.>
	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
	MOVSI	E,(SIXBIT /TTY/)
	DEVCHR	E,
	TLNN	E,10		;IS IT A REAL TTY?
IFN RPGSW,<JRST	[TLNN	F,RPGF	;IN CCL MODE?>
		EXIT		;NO, EXIT IF NOT TTY
IFN RPGSW,<	TRO F,NOTTTY	;SET FLAG
		JRST	LD1]	;SKIP INIT>
	INIT	3,1 		;INITIALIZE CONSOLE
	SIXBIT    /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
LD1:
IFE L,<	HRRZ	B,JOBREL	;MUST BE JOBREL FOR LOADING REENTRANT>
IFN L,<	MOVE	B,JOBSYM	;USED INSTEAD OF JOBREL FOR SYMBOL TABLE FIXUPS>
	HRRZM	B,HISTRT
	SUB	B,SE3		;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
IFN EXPAND,<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 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
	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	
	SETUWP	W,		;SETUWP UUO.
	TRO	F,NOHI6		;PDP-6 COMES HERE.
	MOVEM	F,F.C		;PDP-10 COMES HERE.>
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 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,<SETOM CORSZ>
     

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

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

LD5C:
IFN SPCHN,<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>
	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
	MOVSI     W,554160		;ASSUME <.MAP> IN DEFAULT CASE
	MOVEM     W,DTOUT1		;STORE FILE EXTENSION IDENTIFIER
	MOVE	W,DTIN			;LOAD INPUT FILE IDENTIFIER
	MOVEM     W,DTOUT		;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		;...>
	MOVE	W,ILD1			;LOAD INPUT DEVICE IDENTIFIER
	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

     

;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:	PUSHJ	P,CRLF		;START A NEW LINE
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
	RELEASE	2,		;RELEASE AUX. DEV.
	RELEASE 1,0	;INPUT DEVICE
	RELEASE 3,0	;TTY
IFN SPCHN,<RELEASE 4,0	;SPECIAL CHAINING CHANEL>
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
	SETNAM	W,			;SETNAME>
IFN L,<JRST @LSPXIT>
     

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 NONE 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
     

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@>>
	PUSHJ P,FCRLF	;A RETURN
	PUSHJ P,PWORD	;AND CHAIN OR LOADER
	PUSHJ P,SPACE
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 L,<HRRZ Q,JOBREL(X)
	LSH Q,-12	;GET CORE SIZE TO PRINT
	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
	LSH	Q,-12
	ADDI	Q,1
	PUSHJ	P,RCNUM
NOHY:>>
	MOVE W,[SIXBIT /K CORE/]
	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:	MOVE W,JOBDDT(X)
	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	;DO NOT 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)>
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!LDAC,<		;ONLY ASSEMBLE IF EITHER SET
IFE LDAC,<	TRNN F,DMNFLG	;GET EXTRA  SPACE IF SYMBOLS
	JRST	NODDT	;MOVED OR IF LOADING ACS>
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>>
	ADDI A,(R)	;GET ACTUAL PLACE TO PUT END OF SPACE
	ADDI A,(X)
	CAIL A,(S)	;DO NOT OVERWRITE SYMBOLS
IFN EXPAND,<JRST [PUSHJ P,XPAND>
		PUSHJ P,MORCOR
IFN EXPAND,<	JRST .-1]>
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 DMNSW,<TRNN F,DMNFLG	;NOW THE CODE TO MOVE SYMBOLS
	JRST NODDT
	HRRZ A,R
	ADD A,KORSP
	MOVE W,A	;SAVE POINTER TO FINAL LOC OF UNDEFS
	ADDI A,(X)
	HLLZ Q,S	;COMPUTE LENGTH OF SYMBOL TABLE
	ADD Q,B
	HLROS Q
	MOVNS Q
	ADDI Q,-1(A)	;GET PLACE TO STOP BLT
	HRLI A,1(S)	;WHERE TO BLT FROM
	SUBI W,1(S)	;GET AMOUNT TO CHANGE S AND B BY
	BLT A,(Q)	;MOVE SYMBOL TABLE
	ADD S,W
	ADD B,W	;CORRECT S AND B FOR MOVE
	SKIPN JOBDDT(X)	;IS DDT LOADED
	JRST NODDT	;NO DO NOT RESET R
	HRRI R,1(Q)	;SET R TO POINT TO END OF SYMBOLS
	SUBI R,(X)
	HRRM R,JOBFF(X)
	HRLM R,JOBSA(X)	;AND SAVE AWAY NEW JOBFF
IFN LDAC,<SKIPA>	;SKIP THE ADD TO R
NODDT:>
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
IFE L,<MOVEM A,JOBUSY(X)
	MOVE A,HISTRT	;TAKE POSSIBLE REMAP INTO ACCOUNT
	MOVEM A,JOBREL(X)	;SET UP FOR IMEDIATE EXECUTION>
IFN L,<MOVEM A,JOBUSY>
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
	HRRM A,JOBHRL(X)
	SUB A,HVAL1
	HRLM A,JOBHRL(X)>
	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	Q,S	;COMPUTE LENGTH OF SYMBOL TABLE
	HLRS	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
	HLROS	Q
	MOVNS	Q
	ADD	Q,HVAL	;ADD LENGTH OF HISEG
	SUB	Q,HVAL1	;BUT REMOVE ORIGIN
	ADD	Q,HISTRT	;START OF HISEG IN CORE
	HRRZS	Q	;CLEAR INDEX FROM Q
	ADD	Q,KORSP	;SAVE SPACE FOR SYMBOL PATCHES
	CORE	Q,	;EXPAND IF NEEDED
	PUSHJ	P,MORCOR
	PUSH	P,B	;SAVE B
	SOJ	B,	;REMOVE CARRY FROM ADD TO FOLLOW
	MOVSS	B	;SWAP SYMBOL POINTER
	ADD	B,JOBREL
	HRRM	B,(P)	;SAVE NEW B
	MOVE	Q,JOBREL
	ADD	B,S	;INCASE ANY UNDEFS.
	BLT	B,(Q)	;MOVE SYMBOLS
	POP	P,B	;GET NEW B
	SUB	B,HISTRT
	ADD	B,HVAL1
	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 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,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:	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,<XCT	LD6B-74(T)	;EXECUTE SWITCH FUNCTION>
IFE SPCHN,<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

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
	JRST	LD7B		;? - ERROR
	JRST	LD7B		;@ - ERROR>
	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
IFN REENT,<PUSHJ P,HSET		;H - REENTRANT. PROGRAM>
IFE REENT,<JFCL			;JUST IGNORE /H>
	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
IFN REENT,<PUSHJ P,VSWTCH	;V - LOAD REENTRANT LIB40>
IFE REENT,<JRST	LD7B		;V - ERROR>
	TLZ	F,SYMSW+RMSMSW	;W - LOAD WITHOUT SYMBOLS
	TLZ	N,ALLFLG	;X - DO NOT LIST ALL GLOBALS
	TLO	F,REWSW		;Y - REWIND BEFORE USE
	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,

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 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
	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
	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 CLASSIFIACTION TABLE

LD9:	BYTE	(4)4,0,0,0,0,0,0,0,0
	BYTE	(4)4,4,4,4,12,0,0,0,0
	BYTE	(4)0,0,0,0,0,0,0,0,0
	BYTE	(4)13,0,0,0,0,4,0,4,0
IFE SYMARG,<	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
IFE SPCHN,<	BYTE	(4)2,2,2,2,6,0,0,10,0>
IFN SPCHN,<	BYTE	(4)2,2,2,2,6,0,1,10,1>
IFE RPGSW,<	BYTE	(4)0,0,1,1,1,1,1,1,1>
IFN RPGSW,<	BYTE (4) 0,10,1,1,1,1,1,1,1>
	BYTE	(4)1,1,1,1,1,1,1,1,1
	BYTE	(4)1,1,1,1,1,1,1,1,1
IFE PP,<BYTE	(4)1,0,0,0,0,10,0,1,1>
IFN PP,<BYTE	(4)1,10,0,10,0,10,0,1,1>
	BYTE	(4)1,1,1,1,1,1,1,1,1
	BYTE	(4)1,1,1,1,1,1,1,1,1
	BYTE	(4)1,1,1,1,1,1,0,0,13
	BYTE	(4)13,4
     

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
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,<	INBUF     1,2 		;SET UP BUFFERS>
IFN K,<	INBUF	1,1		;SET UP BUFFER>>
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)>
	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

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>
	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!SAILSW,<ALGBLK==LOAD4A>
IFE SAILSW,<LDLIB==LOAD4A>

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	LDLIB,	NAME	;16,,6
	XWD	LOAD4A,	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,<CAML V,RINITL	;CHECK FOR BAD STORE>
	MOVEM     W,@X		;STORE DATA WORD IN PROG. AT LLC
	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,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	SYM1B

;	PROCESS MULTIPLY DEFINED GLOBAL

SYM1:	CAMN	W,2(A)		;COMPARE NEW AND OLD VALUE
	POPJ	P,;
	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
SYM1D:	SUBI	S,2;		UPDATE UNDEFINED POINTER
	POP	B,2(A)		;MOVE UNDEFINED VALUE POINTER
	POP	B,1(A)		;MOVE UNDEFINED SYMBOL
	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,SYM1D	;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
	HRRI	 W,2(B)		;GET LOCATION IN RIGHT HALF
	TLO	 W,1
	SUB	 W,HISTRT		;AND MAKE RELATIVE
IFN FAILSW,<TLZ	W,040000>
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:	IFN FAILSW,<
	TLNE V,40000	;CHECK FOR POLISH
	JRST POLSAT>
	TLNN V,100000	;SYMBOL TABLE?
	JRST SYM2WA
	ADD V,HISTRT	;MAKE ABSOLUTE
	SUBI V,(X)	;GET READY TO ADD X
	PUSHJ P,FIXW1
	JRST SYM2W1
SYM2WA:	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,</TWO SEGMENTS 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>
	HRR R,C		;SET NEW PROGRAM BREAK
	CAMGE C,W	;CHECK 2ND WORD (LOC PROG BRK IF PRESENT)
	MOVE C,W
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,NAME2		;JUMP IF NO COMMON IN THIS JOB
	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>
	SUBI	S,2 		;UPDATE UNDEF. TABLE POINTER
	POP	B,2(S)
	POP	B,1(S)
	HRRZ	V,N 		;POINTER TO PREVIOUS NAME
	SUBM	B,V 		;COMPUTE RELATIVE POSITIONS
	HRLM	V,2(N)		;STORE FORWARD POINTER
	HRR	N,B 		;UPDATE NAME POINTER
NAME2:	MOVEM   C,1(B)		;STORE PROGRAM NAME
	HRRZM	R,2(B)		;STORE PROGRAM ORIGIN
	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 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>
IFN 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 <BLOCK TYPE 11>

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
	MOVEI V,100	;IN CASE OF ON OPERATORS
	MOVEM V,SVSAT
	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
	PUSH D,[15]	;FAKE OPERATOR SO STORE WILL NOT HACK

RPOL:	PUSHJ P,RDHLF	;GET A HLAF WORD
	TRNE W,400000	;IS IT A STORE OP?
	JRST STOROP	;YES, DO IT
IFN WFWSW,<CAIN W,15
	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,14	;14 IS HIGHEST OPERATOR
	JRST LOAD4A	;ILL FORMAT
	PUSH D,W	;SAVE OPERATOR IN STACK
	MOVE V,DESTB-3(W)	;GET NUMBER OF OPERANDS NEEDED
	MNVEM V,SVSAT	;ALSO SAVE IT
	JRST RPOL	;BACK FOR MORE

     

;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,15	;IS IT
	JRST LOAD4A	;NO, ILL FORMAT
	HRRZ T,(D)	;GET THE VALUE TYPE
	JUMPN T,GLSTR	;AND TREAT GLOBALS SPECIAL
	MOVE A,W	;THE TYPE OF STORE OPERATOR
	CAIGE A,-3
	PUSHJ P,FSYMT
	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+6(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 ALSYM,LFSYM,RHSYM,ALSTR,LOCDLF,SYM4A,FAKESY

GLSTR:	MOVE A,W
	CAIGE A,-3
	PUSHJ P,FSYMT
	PUSHJ P,RDHLF	;GET THE STORE LOCATION
	MOVEI A,23(A)
	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,
DESTB:	EXP 1,1,1,1,1,1,1,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
	REPEAT 7,<JRST STRSAT>


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,B
	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,B	;ALL DONE?
	JRST FSLP	;NO
FNOLOC:	POP D,A
	MOVEI A,0	;SET FOR A FAKE FIXUP
	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
	HRLM W,(V)
	MOVSI D,400000	;LEFT HALF
	JRST COMSFX
RHSYM:	ADD V,HISTRT
	HRRM W,(V)
	MOVSI D,200000
	JRST COMSFX
FAKESY:	POPJ P,		;IGNORE
     

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:	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
	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
	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-15(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
>
	LIST		;END OF FAILSW CODE
IFN FAILSW!WFWSW,<
COMSFX:	IFE REENT,<PUSHJ P,SYMFX1
	JRST RESTRX>
IFN REENT,<JRST SYMFX1>>

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 DEC BASTARDS DON'T READ THEIR OWN MANUALS *****
	HLLM	C,BUFR		;INDICATE VIRGIN BUFFER
; ****** END OF THE CURRENT DEC IDIOCY **********:
	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
	JUMPE	A,[TRNN	F,DTAFLG	;WORD COUNT OK IF ON DTA
		SOS	BUFR2
		JRST	INDEX7]
	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 TO MANY THOUGH
	JRST	INDEX6		;YES, WORD COUNT WILL BE CORRECT

     

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:
IFN SAILSW,<TRNN F,ALGFL	;IF NOT ALGOL
	JRST	LDPRG		;MUST BE SAIL BLOCK TYPE 15>
	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 15

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

IFN SAILSW,<
IFE ALGSW<ALGBLK:>
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

SREQ:	JUMPGE  S,CPOPJ1	;JUMP IF NO UNDEF. SYMBOLS
	SKIPA   A,S 		;LOAD REQUEST SEARCH POINTER
SDEF:	MOVE	A,B 		;LOAD DEF. SYMBOL SEARCH POINTER
SDEF1:	CAMN	C,1(A)
	POPJ	P,		;SYMBOLS MATCH, RETURN
IFE K,<	TLNE	N,F4SW		;ARE WE IN FORTRAN?
	JRST	SDEF2		;YES,JUST TRY NEXT SYMBOL>
	TLC	C,400000	;MIGHT BE SUPPRESSED  INTERNAL
	CAMN	C,1(A)		;WAS IT?
	JRST	[TLO C,400000	;YES, SO ENSURE IT'S SUPPRESSED
		MOVEM C,1(A)	;STORE SUPPRESSED DEFINITION
		POPJ	P,]	;YES
	TLC	C,400000	;NO,TRY NEXT SYMBOL
SDEF2:	ADD	A,SE3
	JUMPL   A,SDEF1
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,

CHECK:	MOVE	T,HVAL1		;START OF HISEGMENT
	CAIG	T,NEGOFF(W)	;IN HISEG?
	JRST	[SUBI	W,(T)	;YES REMOVE OFSET
		POPJ	P,]
	HRRI	W,@LOWR		;USE LOW SEG RELOC
	JRST	CPOPJ1		;SKIP RETURN
     

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
	HLRE	W,S 		;COMPUTE NO. OF UNDEF. GLOBALS
	MOVMS     W
	LSH	W,-1		;<LENGTH OF LIST>/2
	PUSHJ     P,PRNUM0
	ERROR	7,</UNDEFINED GLOBALS@/>
	MOVE	A,S 		;LOAD UNDEF. POINTER
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,


;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 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
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,<
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
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)>
     

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

	TTYL==52			;TWO TTY BUFFERS
IFE LNSSW,<
IFE K,<	BUFL==406		;TWO DTA BUFFERS FOR LOAD>
IFN K,<	BUFL==203		;ONE DTA BUFFER FOR LOAD>
	ABUFL==203		;ONE DTA BUFFER FOR AUX DEV>
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 2>
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
	MOVE	V,HISTRT	;NOW REMAP THE HISEG.
	REMAP	V,		;REMAP UUO.
	JRST	HIGET		;FATAL ERROR.
HIRET:	JRST	0		;EXECUTE CODE IN ACC'S

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
/

IFN PURESW,<HIGONE:	DEPHASE>>
     

SUBTTL	LISP LOADER

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

IFN L,<LODMAK:	MOVEI A,LODMAK
	MOVEM A,137	;SET UP TO SAVE THE LISP LOADER
	INIT 17
	SIXBIT /DSK/
	0
	HALT
	ENTER LMFILE
	HALT
	MOVNI A,LD
	HRLZS A
	ADDM A,LMLST	;BECAUSE MACRO WON'T TAKE POLISH FIXUPS
	OUTPUT LMLST
	STATZ 740000
	HALT
	RELEASE
	EXIT
LMFILE:	SIXBIT /LISP/
	SIXBIT /LOD/
	0
	0
LMLST:	IOWD LODMAK+1,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 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
	POPJ	P,		;RETURN

PATO:	ROT	C,1
	ADD	C,AOTAB;	ARRAY OFFSET
	ADDI	C,-2(X);	LOADER OFFSET
	MOVEM	C,CT1;		SAVE CURRENT POINTER
	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
	MOVE	C,CT1
	HRRE	C,(C)
	ADD	C,1(W)
	JRST	PCOMX
     

NCO:	PUSHJ	P,SWAPSY;
	ADDI	C,(R)		;DEFINE SYMBOL IN TRUE LOC
	PUSHJ	P,SYDEF		;...
	MOVE	C,CT1
	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

IFE L,<	END	BEG>

IFN L,<LODMAK:	MOVEI A,LODMAK
	MOVEM A,137	;SET UP TO SAVE THE LISP LOADER
	INIT 17
	SIXBIT /DSK/
	0
	HALT
	ENTER LMFILE
	HALT
	MOVNI A,LD
	HRLZS A
	ADDM A,LMLST	;BECAUSE MACRO WON'T TAKE POLISH FIXUPS
	OUTPUT LMLST
	STATZ 740000
	HALT
	RELEASE
	EXIT
LMFILE:	SIXBIT /LISP/
	SIXBIT /LOD/
	0
	0
LMLST:	IOWD LODMAK+1,137
	0
	END LODMAK>