perm filename GOGOL[S,AIL]13 blob sn#069786 filedate 1973-11-10 generic text, type C, neo UTF8
COMMENT ⊗   VALID 00057 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00005 00002	HISTORY
C00011 00003	Command File Descriptions
C00013 00004	Conditional Assembly Switches, Macros
C00017 00005	Titles, Versions
C00018 00006	AC Definitions
C00019 00007	CDB, SIMIO Indices For IOSER, OTHER INDICES
C00023 00008	Base (Low Segment) Data Descriptions -- Macros, Compil spec
C00025 00009	Base (Low Segment) Data Descriptions - Params, Links, Size specs
C00033 00010	Initialization Routines, Data
C00035 00011	Sailor, Reent --  Allocation, Main Program Control
C00039 00012	.SEG2. -- Get a second segment
C00042 00013	
C00045 00014	
C00048 00015	
C00049 00016	 Segment-Fetching Data
C00052 00017	
C00053 00018	 %ALLOC -- Main Allocation Routine
C00059 00019	
C00066 00020	
C00070 00021	
C00073 00022	  Utility Subroutines for allocation
C00075 00023	%UUOLNK -- UUO Handler (Dispatch Vector Just Below)
C00077 00024	 ILLUUO, PDLOV, ERR UUO Handlers
C00083 00025	SERVICE ROUTINES FOR ERRR
C00087 00026	SERVICE ROUTINES TO DSPATC (PART OF ERRR)
C00092 00027	DSCR PRINT
C00104 00028	  Special Printing Routines For Error Handler
C00107 00029	  Code to Handle Linkage to Editors
C00112 00030	
C00116 00031	 DECPNT, OCTPNT, FIX, FLOAT UUOs
C00119 00032	 DSPLIN, etc.for Disp. Text Line on Error (Compiler)
C00121 00033	SAVE, RESTR, INSET -- General Utility Routines
C00128 00034	Core Service Routines -- General Description
C00132 00035	 Special AC Declarations
C00133 00036	  Utility Routines
C00138 00037	
C00142 00038	 CORGET
C00146 00039	
C00148 00040	 CORINC, CANINC
C00153 00041	 CORREL
C00158 00042	 CORPRT, CORBIG
C00161 00043	String Garbage Collector Routines 
C00166 00044	
C00169 00045	
C00174 00046	
C00178 00047	
C00182 00048	
C00184 00049	
C00186 00050	
C00188 00051	Some Runtime Routines Which Could Go Nowhere Else
C00189 00052	 Kounter Routines
C00191 00053	
C00197 00054	
C00201 00055	REAL←LOGS(INTEGER_BASE,REAL_EXPONENT)
C00208 00056	
C00214 00057	
C00216 ENDMK
C⊗;
COMMENT ⊗HISTORY
AUTHOR,FAIL,REASON
031  102100000003  ⊗;
DEFINE .VERSION <102100000003>

COMMENT ⊗
VERSION 17-1(3) 7-27-73 BY KVL PUTS IN SOME XX'S FOR HOLDING .LOG FILE INFO
VERSION 17-1(2) 7-27-73 BY KVL DECLARE ERSCPD IN LOWER
VERSION 17-1(1) 7-26-73 BY RHT ****** VERSION 17 STRIKES HERE *******
VERSION 16-2(65) 7-13-73 BY JRL HERE CORGET AND FRIENDS
VERSION 16-2(64) 7-13-73 
VERSION 16-2(63) 7-13-73 
VERSION 16-2(62) 6-28-73 BY JRL BUG #MW# PPMAX NOT EXTERALED IN SAILUP(EXPORT ONLY)
VERSION 16-2(61) 5-3-73 BY RHT ADD EXTRA THREE XX CELLS FOR INTRPT SYS
VERSION 16-2(60) 2-27-73 BY JRL REMOVE ..RVAL FROM XX AREA
VERSION 16-2(59) 2-12-73 BY JRL ADD ..RVAL TO XX AREA
VERSION 16-2(58) 1-8-73 BY JRL BUG #KV# CHECK FOR NULL INILNK IN .UNIT
VERSION 16-2(57) 12-2-72 BY RHT ENLARGE HERE TABLE
VERSION 16-2(56) 12-1-72 BY RHT ADD DEFSSS,DEFPSS,DEFQNT,DEFPRI TO XX AREA
VERSION 16-2(55) 11-30-72 BY RHT ADD XX ENTRY FOR NOPOLL
VERSION 16-2(54) 11-22-72 BY JRL BUG #KL# STACSV SAVED TOO MANY AC'S IN TOO FEW LOCATIONS
VERSION 16-2(53) 11-22-72 
VERSION 16-2(52) 11-22-72 
VERSION 16-2(51) 11-17-72 BY RHT MAKE USER INITIALIZATION A SEPARATE PROCEDURE
VERSION 16-2(50) 11-10-72 BY JRL ADD PROPS TO XX AREA
VERSION 16-2(49) 10-12-72 BY RHT ADD PPMAX FOR EXPO VERSION (NEEDED BY ED LNKG)
VERSION 16-2(48) 10-5-72 BY JRL MAKE GLUSER INTERNAL
VERSION 16-2(47) 10-3-72 BY RHT MAKE USER INIT WORK RIGHT
VERSION 16-2(46) 9-24-72 BY JRL FIX LIB ENTRIES FOR PROC. STR GAR COL
VERSION 16-2(45) 9-21-72 BY RHT SCREW UP THE COMPIL MACRO
VERSION 16-2(44) 9-21-72 BY JRL ADD SPRPDA TO SGC COMPIL MACRO
VERSION 16-2(43) 9-11-72 BY JRL ADD GINFTB,GDATM TO LOWER WHEN NO GLOB
VERSION 16-2(42) 9-5-72 BY JRL BAD FIX TO SGLKBK PROBLEM
VERSION 16-2(41) 8-21-72 BY RHT PUT IN JRL'S STACSV &STACRS
VERSION 16-2(40) 8-7-72 BY RHT CHANGE INILNK STUFF
VERSION 16-2(39) 8-7-72 BY KVL PRINT MSG BEFORE CANT CONTINUE ANY FURTHER MSG (P24)
VERSION 16-2(38) 7-3-72 BY DCS BUG #IC# ADD NEW MEANING TO NOSHRK(USER)
VERSION 16-2(37) 7-3-72 BY DCS BUG #IB# MAKE DEFAULT SYSTEM STACK SIZE BIGGER
VERSION 16-2(36) 7-2-72 BY JRL HAVE %ALLOC CALL LPINI IF NEEDED
VERSION 16-2(35) 6-20-72 BY DCS BUG #HU# BETTER TTY PRINTOUT
VERSION 16-2(34) 5-16-72 BY DCS BUG #HI# %ARRSRT TESTS RIGHT BIT FOR STR ARRAY NOW
VERSION 16-2(33) 5-11-72 BY DCS BUG #HE# MODIFY VERSION CHECKING, INSTALL VERSION 16
VERSION 15-6(23-32) 5-3-72 VARIOUS FIXES
VERSION 15-6(14-22) 2-21-72 VARIOUS FIXES
VERSION 15-6(13) 2-19-72 BY RHT THE BRAVE NEW WORLD
VERSION 15-2(12) 2-5-72 BY DCS BUG #GI# REMOVE TOPSTR
VERSION 15-2(11) 2-2-72 BY DCS BUG #GI# LEAVE SOME SLOP IN REMCHR SO CAT'LL BE MORE EFFICIENT
VERSION 15-2(10) 2-1-72 BY DCS REPLACE (FIXED) %ALLOC BLOCK ACCESSES BY SYMBOLIC HEAD-DEFINED ONES
VERSION 15-2(9) 1-30-72 BY DCS REPLACE %ALLOC -- INITIAL ALLOCATION
VERSION 15-2(8) 1-14-72 BY DCS BUG #GA# SEGMENTS HAVE .SEG EXTENSIONS, NOT .REL
VERSION 15-2(7) 1-3-72 BY DCS BUG #FX# REMOVE NEED FOR COM2, REORGANIZE SEGMENT-GETTING STUFF
VERSION 15-2(6) 12-26-71 BY DCS BUG #FU# REENABLE ACCESS FROM ERR UUO TO FTDEBUGGER
VERSION 15-2(5) 12-24-71 BY DCS BUG #FT# DSPLIN BETTER, TV AS VALID EDITOR
VERSION 15-2(4) 12-22-71 BY DCS BUG #FF# SIXPRT(14-15) TO ERR, IOERR ROUTS
VERSION 15-2(3) 12-22-71 BY DCS BUG #FS# REMOVE SAILRUN, COM2, ASSUME COMPILER
VERSION 15-2(2) 12-2-71 BY DCS ADD VERSION SETUP CODE
VERSION 15-2(1) 12-2-71 BY DCS INSTALL VERSION NUMBER

⊗;
SUBTTL	Command File Descriptions
	LSTON	(GOGOL)
COMMENT ⊗

The following command files make runtime routines:

1.	RUN
	One assembly, get a non-library, non-2d-segment runtime package

RUNTIM=CALLIS(LR)+HEAD+ORDER+GOGOL+STRSER+IOSER+NWORLD+LEPRUN+MESPRO+WRDGET

2.	SGMNT
	Makes the non-global UPPER.REL and SAILOW.REL, which when
	loaded and run and stuff become SAISGn.SEG and SAILOW.REL,
	the 2d segment runtime routines

TAILOR=HEAD+FILSPC+TAILOR/NOLO
LOWER=CALLIS+HEAD+LOW+FILSPC+GOGOL/NOLO
TAILOR.REL,UPPER=CALLIS+HEAD+UP.FAI+ORDER+GOGOL+STRSER+IOSER+
          NWORLD+LEPRUN+MESPRO+WRDGET

5.	GSGMNT
	Makes the global model SAILOW AND UPPER, otherwise like
	 SGMNT

Same, but add GLB after HEAD in all three.

6.	SCISS.SAI
	This SAIL program, when run, uses the runtime files to
	 make a LIBSAI.REL file, the SAIL (lower-segment) library
⊗
SUBTTL	Conditional Assembly Switches, Macros
DSCR ** CONDITIONAL ASSEMBLY SWITCHES **
⊗

STSW(UPPER,0)		;NOT UPPER OR LOWER IF NEITHER SET
STSW(LOWER,0)
STSW(GLOBSW,0)		;ONLY GLOBAL IF SOMEBODY ELSE SAID SO
STSW(SEGS,0)
STSW(RENSW,0)		;RE-ENTRANT LIBRARY (HISEG) IF ON
STSW(LEAPSW,1)		;ASSUME LEAP
EXPO <
STSW(APRISW,1)		;THE APR INTERRUPT PACKAGE IS TO BE USED
>;EXPO
NOEXPO <
STSW(APRISW,0)		;USUALLY USE THE MOORER PACKAGE
>;NOEXPO

DSCR COMPIL(NAM,ENTRIES,EXTERNALS,DESCRIPTION,INTERNALS,HINHB)
CAL MACRO
PAR NAM IS 3 CHAR NAME -- TITLE WILL BE SAINAM
 ENTRIES ARE LIST OF ENTRIES CONTAINED IN THIS
  LIBRARY ASSEMBLY (INTERNALS IF NOT LIBRARY SETUP)
 EXTERNALS (OPTIONAL) ARE EXTERNALS NEEDED FOR THIS ENTRY.
 DESCRIPTION IS OPTIONAL, AND IS USED IN THE SUBTTL
  IF PRESENT.
 INTERNALS (OPTIONAL) DESCRIBE INTERNALS WHICH ARE NEVER ENTRIES.
 HINHB (OPTIONAL ANYTHING), IF NON-BLANK, INHIBITS THE HISEG)
DES IF MAKING A LIBRARY, AND IF THIS FILE IS DESIRED
  (SEE SCISS PROGRAM), A FILE OF THE NAME SAINAM.FAI
  WILL BE MADE CONTAINING ALL THE PROGRAM TEXT FROM THE
  COMPIL MACRO TO THE ENDCOM MACRO WHICH SHOULD FOLLOW
  THE CODE FOR THIS ENTRY.  ENDCOM DOES AN END IF
  IN LIBRARY COMPILE MODE.
RES THE MACRO EXPANDS TO PROVIDE A TITLE AND THE
  APPROPRIATE ENTRIES AND EXTERNALS FOR THIS ASSEMBLY.
  ALSO A SUBTTL CONTAINING THE TITLE AND OPTIONAL
  DESCRIPTION IS PROVIDED.
⊗
DEFINE COMPIL ' (NAM,ENT,EXT,DSCRP,INT,HINHB,DUMMY) <
IFIDN <DUMMY>,<> <
SUBTTL SAI'NAM -- DSCRP

IFE ALWAYS,<
	IFDIF <><ENT>,<ENTRY ENT>
	TITLE	SAI'NAM
REN <
	IFIDN <><HINHB>,<HISEG		;LOAD TO UPPER IF POSSIBLE>
>;REN
	IFDIF <><EXT>,<EXTERN EXT>
>;IFE ALWAYS
NOLOW <
	IFDIF <><INT>,<INTERN INT>
IFN ALWAYS,<
IFDIF <NAM><LOR>,<
IFDIF <><ENT>,<INTERNAL ENT>
>>
>;NOLOW
>;IFIDN <DUMMY>
>

DEFINE COMPXX ' (NAM,ENT,EXT,DSCRP,INT,HINHB) 
	<COMPIL(<NAM>,<ENT>,<EXT>,<DSCRP>,<INT>,<HINHB>)>

DEFINE ENDCOM (NAM) <
IFE ALWAYS,<
	END
>;IFE ALWAYS
>
; SWITCHES TO CONTROL LIBRARY COMPILATION

IFNDEF ALWAYS,<↓ALWAYS←←1>

IFN ALWAYS,<DEFINE ENTINT (X) <INTERNAL X>>
IFE ALWAYS,<DEFINE ENTINT (X) <ENTRY X>>

SUBTTL	Titles, Versions
DSCR  TITLES, VERSIONS
⊗
IFN ALWAYS,<
;  "TITLE	UPPER"	IS FOUND IN UP.FAI FILE TO MAKE OUTER PROG TITLED
LOW <
	TITLE LOWER
>;LOW
NOUP <
NOLOW <
	TITLE RUNTIM -- SAIL RUNTIME ROUTINES
>;NOLOW

JOBVER←←137
	LOC	JOBVER
;;#HE# DCS 5-11-72 (1-2) MODIFY VERSION STUFF
	.VERSION&777777000000	;CURRENT VERSION NUMBER (LH ONLY)
;;#HE# (1-2)
	RELOC
	LOC	124		;SET UP REENTER ADDRESS
	REENT
	RELOC
>;NOUP
>;ALWAYS≠0
EXTERNAL JOBHRL
SUBTTL	AC Definitions
DSCR  AC DEFINITIONS
⊗

; AC DEFINITIONS FOR SERVICE AND RUNTIME ROUTINES

; ALL	    UUO ROUTS,	    IOSER		COMMENTS
;	    CORE ROUTS,
;	    STRING GC,
;	    ALLOCATION

↓FF←←0
↓A←1						;TEMPS FOR ALLES
↓B←2						; (SOMETIMES SAVED)
↓C←3
↓D←4
		↓E←5		↓X←5		;MORE TEMPS
		↓Q1←6		↓Y←6
		↓Q2←7		↓Z←7
		↓Q3←10		↓Q←10
		↓T←11		↓CDB←11		;CHANNEL DATA BLOCK PTR
		↓T1←12		↓CHNL←12	;CHNL # FOR IOSER
↓LPSA←13					;TEMP, PARAM AC
↓TEMP←14					;TEMP ONLY
↓USER←15					;→USER TABLE FOR RNTRNT ROUTS
↓SP←16						;STRING STACK
↓P←17						;SYSTEM STACK
SUBTTL	CDB, SIMIO Indices For IOSER, OTHER INDICES

DSCR -- CDB, SIMIO INDICES FOR IOSER
DES The I/O routines obtain their information from the user via a
  channel number -- the same kind used by the system. In order to
  find byte pointers, counts, file names, etc., the channel number is
  used to index into a block of core called a CDB (Channel Data Block).
  This CDB is filled with good data during the OPEN operation.
 The CDB, and all I/O buffers, are obtained from CORGET.
 The CHANS table in the GOGTAB area is a 20 word block containing
  pointers to the appropriate CDB's.
 Since channel numbers must appear in the AC field of IO instructions,
  one must construct IO insts. in impure places to retain re-entrancy.
  XCT INDEX,SIMIO executes the appropriate IO instruction with the
  channel number from AC CHNL, used by all routines.  See SIMIO for
  operational details.
⊗

;  SIMIO INDICES		        FORMAT OF CDBs

DMODE	←← 0	    ↔↓IOSTATUS ←← 0	;DATA MODE		;RETURN STATUS
DNAME	←← 1	    ↔↓IOIN     ←← 1	;DEVICE			;BUFFERED INPUT
BFHED	←← 2	    ↔↓IODIN    ←← 2	;HEADER POINTERS	;DUMP INPUT
		     ↓IOOUT    ←← 3     			;BUFMODE OUT.
OBPNT	←← 3	    ↔↓IODOUT   ←← 4	;OUTPUT BUF. PTR	;DUMP OUTPUT
OBP	←← 4	    ↔↓IOCLOSE  ←← 5	;OUTPUT BYTE PTR	;CLOSE FILE
OCOWNT	←← 5	    ↔↓IORELEASE←← 6	;OUTPUT BYTE CNT	;RELEASE FILE
ONAME	←← 6	    ↔↓IOINBUF  ←← 7	;OUTPUT FILE NAM	;INBUF
OBUF	←← 7	    ↔↓IOOUTBUF ←←10	;OUTPUT BUFFER LOC.	;OUTBUF
		    ↔↓IOSETI   ←←11				;USETI
IBPNT	←←10	    ↔↓IOSETO   ←←12	;SAME FOR INPUT		;USETO
IBP	←←11	    ↔						;  13 UNUSED
ICOWNT	←←12	    ↔↓IOOPEN   ←←14				;OPEN CHANNEL
INAME	←←13	    ↔↓IOLOOKUP ←←15				;LOOKUP FILE
IBUF	←←14	    ↔↓IOENTER  ←←16				;ENTER FILE
		    ↔↓IORENAME ←←17				;RENAME FILE

ICOUNT	←←15	;INPUT DATA COUNT LIMIT ADDRESS
BRCHAR	←←16	;XWD TTYDEV FLAG, INPUT BREAK CHAR ADDR
TTYDEV  ←←16	;LH -1 IF DEVICE IS A TTY -- USED BY OUT
ENDFL	←←17	;INPUT END OF FILE FLAG ADDR
ERRTST	←←20	;USER ERROR BITS SPECIFICATION WORD
PGNNO	←←20	;PAGE NUMBER FOR DISPLAY FEATURE (IF FEATURE NOT INCLUDED)
NOEXPO <
PGNNO	←←21	;SAME THING IF IT IS INCLUDED
>;NOEXPO
↑IOTLEN	←←PGNNO+1	;LENGTH OF TABLE ENTRY

↓LUPDL←30			;LENGTH OF UUO PDL
↓MINPDS←←=64			;SMALLEST ALLOWABLE SYSTEM PDL SIZE
↓DEFPDS←←=192			;DEFAULT PDL SIZE
SUBTTL	Base (Low Segment) Data Descriptions -- Macros, Compil spec

DSCR DATA DESCRIPTIONS, TAILORED FOR TWO SEGMENT OPERATION
⊗

NOUP <
DEFINE SGLK (ROUT,NAM,INT) <
 XX	(NAM,ROUT,INT)	;NAME OF STRING DSCRPTR GENERATING ROUTINE
 XX	(,0,)		;PLACE TO PUT A LINK
 LINK	%SGROT,.-1	;WHEREWITHAL TO GENERATE SAID LINK
>
>;NOUP
UP <
DEFINE SGLK (ROUT,NAM) <
 XX	(NAM,ROUT,)
 XX	(,0,)
>
>;UP

DEFINE XX  (A,B,C,D) <
	IFDIF <A><>,<↓ A :> B
	IFDIF <C><>,< C A >
>
UP <
III←←140
	DEFINE XX (A,B,C,D) <
	IFDIF <A><>,<↓ A ← III >
	III ←← III + 1
	IFDIF <D><>,<III←III+D-1>
>
>;UP


COMPIL(LOR,<SAILOR,.SEG2.>
	    ,<%UUOLNK,%ALLOC,%SPGC,%STRMRK,%ARRSRT,K.OUT,K.ZERO,JOBSA>
	    ,<BASE DATA, INITIALIZATION CONTROL>
	    ,<X11,X22,X33,X44>,INHIBIT)
;;%AH% RHT (1 OF 1) ADDED JOBSO TO ABOVE SET OF EXTERNALS
SUBTTL	Base (Low Segment) Data Descriptions - Params, Links, Size specs

; UNIVERSAL VARIABLES -- BASES OF MAJOR DATA STRUCTURES, GLOBAL FLAGS

XX	(GOGTAB,0,INTERNAL)	;→USER TABLE
XX	(DATM,0,INTERNAL)	;XWD 3,→DATUM TABLE
XX	(LKSTAT,0,INTERNAL)	;STATUS OF GLOBAL LEAP MODEL INTERLOCK (SHOULD BE IN GOGTAB
XX	(INFTB,0,INTERNAL)	;XWD 2,→INFOTAB TABLE
XX	(.SKIP.,0,INTERNAL)	;RECORD AUX RESULTS OF RUNTIMES
XX	(RPGSW,0,INTERNAL)	;SET IF (JOBSA)+1 USED TO START
XX	(%RENSW,0,INTERNAL)	;SET IF USER WANTS TO RENTER FOR ALLOC
XX	(CONFIG,0,INTERNAL)	;0 FOR RUNTIME, <0 FOR COMPILER
XX	(ERRSPC,0,INTERNAL)	;ADDR OF COMPILER'S ERROR AUGMENTOR
XX	(RUNNER,0,INTERNAL)	;THE CURRENTLY RUNNING PROCESS(IF HAVE THEM)
XX	(INTRPT,0,INTERNAL)	;MASK FOR INTERRUPT POLLING
XX	(PROPS,0,INTERNAL)	;BYTE POINTER FOR ACCESSING PROPS(ITEM) ITEM IN 3
XX	(NOPOLL,0,INTERNAL)	;≠0 →→ IGNORE CALL TO DDFINT
XX	(DEFSSS,0,INTERNAL)	;DEFAULT S-STACK SIZE -- SET BY MAINPR
XX	(DEFPSS,0,INTERNAL)	;DEFAULT P-STACK SIZE (FOR PROCESSES) -- DITTO
XX	(DEFPRI,0,INTERNAL)	;DEFAULT PRIORITY -- DITTO
XX	(DEFQNT,0,INTERNAL)	;DEFAULT QUANTUM -- DITTO
XX	(%ERFLG,0,INTERNAL)	
XX	(%ERCHAN,0)		;TO HOLD THE CHANNAL NUMBER THAT IS OPEN FOR LOGGING
XX	(%ERFIL,<BLOCK 4>,INTERNAL,4)		;TO HOLD NAME OF LOG FILE
XX	(%ERBUF,0)		;BUFFER POINTER FOR DUMP MODE BUFFER OF ERRR
XX	(%ERCNTR,0)		;STORE PLACE FOR COUNT OF CHARS IN BUFFER 
XX	(%ERPNTR,0)		;STORE PLACE FOR BP FOR SENDING TO LOG FILE
NOEXPO	<
IFE APRISW <
XX	(XJBCNI,0,INTERNAL)	;JOBCNI TYPE THING FOR MOORER SYS (MOD BY F.WRIGHT)
XX	(XJBTPC,0,INTERNAL)	;JOBTPC THING, ETC
XX	(XJBAPR,0,INTERNAL)	;JOBAPR THING, ETC
>;IFE APRISW
IFN APRISW <
XX	(S10PAR,0)
XX	(S11PAR,0)
XX	(S12PAR,0)
>;IFN APRISW
>;NOEXPO
XX	(S1PARE,0)		;SPARE LOWER LOCATIONS
XX	(S2PARE,0)		
XX	(S3PARE,0)
XX	(S4PARE,0)
XX	(S5PARE,0)
XX	(S6PARE,0)
XX	(S7PARE,0)
XX	(S8PARE,0)
XX	(S9PARE,0)

GLOB <
XX	(GSPARE,<BLOCK 2>,,2)
>;GLOB
NOGLOB <
XX	(GDATM,0,INTERNAL)	;DUMMY GLOBAL DATUM TABLE SHOULD ALWAYS BE ZERO
GPROPS←GINFTB←GDATM			;DUMMY GLOBAL INFOTAB DITTO
	INTERNAL GINFTB,GPROPS
>;NOGLOB

; STATIC LINKAGES -- FEATURE PROVIDED BY LOADER
; THESE ARE THE BASES OF ONE-WAY LINKED LISTS WHICH ALLOW ACCESS
; TO SELECTED DATA IN ALL LOADED MODULES

XX	(STLNK,0,INTERNAL)	;1 ALL STRINGS TIED TOGETHER FOR STRNGC
XX	(SPLNEK,0,INTERNAL)	;2 ALL SPACE REQUESTS (PDLS, ETC.)
XX	(SETLET,0,INTERNAL)	;3 ALL SET VARIABLES TIED TOGETHER
XX	(SGROT,0,INTERNAL)	;4 LIST OF STRNGC SORTER GENERATORS
XX	(KTLNK,0,INTERNAL)	;5 ALL COUNTER BLOCKS
XX	(INILNK,0,INTERNAL)	;  INITIALIZATION ROUTINES (LPINI ONLY NOW)

 SYSPHS←←2			;TWO SYSTEM PHASES
 USRPHS←←1			;TWO USER PHASES (FOR NOW)

; THESE OPS INFORM THE LOADER OF THE ABOVE BASE LOCATIONS.

NOUP <
	LINKEND %STLNK,STLNK
	LINKEND	%SPLNK,SPLNEK
	LINKEND	%SETLK,SETLET
	LINKEND	%SGROT,SGROT
	LINKEND	%KTLNK,KTLNK
	LINKEND %INLNK,INILNK
>;NOUP

; SOME ROUTINES WHICH GO ON THE SGROT LIST (SEE SGLK)
;↑SGLKBK
SGLK	(%ARRSRT,SGLKBK,INTERNAL);ROUTINE TO COLLECT STRING ARRAYS
SGLK	(%STRMRK)		;ROUTINE TO COLLECT STRING VARIABLES
SGLK	(%SPGC)			;ROUTINE TO COLLECT STRING STACK


;HERE IS THE LIST OF DEFAULT SPACE ALLOCATION ENTRIES
XX	(%SPL,<BLOCK $SPREQ-2>,INTERNAL,$SPREQ-2);DUMMY FIXED ADDR STUFF
XX	(%STDLST,<BLOCK 2>,INTERNAL,2) 	 ;BASE OF BUILT-IN REQUESTS
XX	(,<XWD WNTPDP!MINSZ!USRTB,DEFPDS>) ;SYSTEM_PDL (SPECIAL, SEE BELOW)
XX	(,<XWD	[ASCIZ /SYSTEM_PDL/],PDL>)
XX	(,<XWD	WNTPDP!USRTB!MINSZ,50>)	 ;STRING STACK
XX	(,<XWD	[ASCIZ /STRING_PDL/],SPDL>)
XX	(,<XWD	WNTADR!WNTEND!USRTB!MINSZ,2000>);STRING_SPACE
XX	(,<XWD	[ASCIZ /STRING_SPACE/],ST>)
XX	(,0)			;THAT'S ALL
;	LINK	%SPLNK,%SPL	;%ALLOC DOES THIS EXPLICITLY SO THIS
				;BLOCK WILL BE FIRST

;SOME RANDOM GLOBALLY USEFUL THINGS, WHICH UNFORTUNATELY HAVE TO
;BE IN FIXED LOCATIONS (FOR THE RUNTIMES TO FIND)

XX	(ALLPDP,<IOWD 20,ALLPDL>,INTERNAL);USED FOR A WHILE DURING ALLOC
XX	(ALLPDL,<BLOCK 20>,INTERNAL,20)	  ;AND IN PROCESS TERMINATION
XX	(%ALLCHR,0,INTERNAL)
XX	(%OCTRET,0,INTERNAL)
XX	(DPYSW,0,INTERNAL)	;ON IF CONSOLE IS DPY
XX	(%UACS,<BLOCK 20>,INTERNAL,20) ;UUOCON ACS
XX	(%UPDL,<BLOCK LUPDL+1>,INTERNAL,LUPDL+1) ;UUOCON PDL
NOEXPO <
XX	(PGDS,<PGDS0>,INTERNAL)	;PIECE OF GLASS FOR LINE BREAK ON INPUT
XX	(,7,)
XX	(PGDS0,0,)
XX	(,<AIVECT (300,200)>,)
XX	(,<ASCID /PAGE/>,)
XX	(,<ASCID /     />,)
XX	(,<ASCID /LINE />,)
XX	(,<ASCID /     />,)
XX	(,<DPYJMP PGDS0>,)
>;NOEXPO

;SOME WONDERFULLY USEFUL CONSTANTS

XX	(X11,<XWD 1,1>,INTERNAL)
XX	(X22,<XWD 2,2>,INTERNAL)
XX	(X33,<XWD 3,3>,INTERNAL)
XX	(X44,<XWD 4,4>,INTERNAL)

;SINCE UUO TRIGGERING IS NON-RE-ENTRANT, THIS IS THE PLACE WHERE IT HAPPENS

XX	(UUO0,0,INTERNAL)		;JSR RETURN STORED HERE
	↓UUCOR←UUO0
NOUP <
	JRST	%UUOLNK			;GO HANDLE UUO
>;NOUP

LOW <
	EXTERNAL LPINI
LPLK:	0
	LPINI
	0
LINK %INLNK,LPLK
>;LOW

EXPO <
XX	(PPMAX,<BLOCK 3>,INTERNAL,3)	;FOR SCREWY EDITOR LINKAGE
>;EXPO

IFN APRISW <
XX	(APRACS,<BLOCK 20>,INTERNAL)	;APR INTERRUPT AC STORAGE
>;IFN APRISW

SUBTTL	Initialization Routines, Data

COMMENT ⊗ The Run-Time I/O handling routines are re-entrant. This
 means that any modifiable words or parameters particular to a given
 user must come from the user's core image.  The pointer to this area
 will be found in GOGTAB in the lower segment.  The I/O routines use
 some of the AC'S in standard ways, described above with AC definitions.
⊗

DSCR SAILOR -- ALLOCATION AND INITIALIZATION ROUTINES
CAL JSR
DES

 Part of this is not yet reentrant. In particular,
	it is called by a JSR SAILOR
 The functions of this routine are:

1. Get a second segment, if this is a SAISEG-program
2. Process space requests, allow user-override if REENTER used
   to start.
3. Use %ALLOC to allocate requested regions.
4. Clear Kounters
5. Change starting and re-entry addresses,
6. PUSHJ to user program
7. Record Kounters, RESET and quit.
⊗
SUBTTL Sailor, Reent --  Allocation, Main Program Control

NOUP <
;SAIL job calls SAILOR first time, with RPGSW set up already

INTERNAL SAILOR
↑SAILOR: 0			;JSR to SAILOR
	JRST	FRSTRT		;GET A SEGMENT, START UP

; REENTER to manually change allocation, and to flush REQUIREd segments

↑REENT:	SETOM	%RENSW		;RE-ENTER -- ASK FOR NEW ALLOC

;SAIL STARTS HERE WHEN USER TYPES S<T<A<R<T>>>> AGAIN

↑RESTRT:TDZA	TEMP,TEMP	;ESTABLISH OPERATING MODE
	MOVNI	TEMP,1		;RPG MODE
	MOVEM	TEMP,RPGSW	;RECORD IT
FRSTRT:	JSP	P,.SEG2.	;GET SECOND SEGMENT

STRT:	CALLI
	SETZM	GOGTAB		;FORCE CORSER RE-INITIALIZATION
	SETNIT			;GET TEMP STACK, IF NECESSARY
	SETZM	%ERFLGS		;INITIALIZE ERR HANDLER
	JSP	16,%ALLOC	;ALLOCATE AREAS
	MOVEI	A,RESTRT	;CHANGE JOBSA AND JOBREN
	HRRM	A,JOBSA		;"S" USES OLD ALLOCATION
	MOVEI	A,REENT		;"REE" ASKS QUESTIONS AGAIN
	MOVEM	A,JOBREN
	PUSHJ	P,K.ZERO	;ZERO OUT THE COUNTERS
	PUSHJ	P,INILST	;GO DO ALL OTHER INITIALIZATIONS
	PUSHJ	P,@SAILOR	;CALL USER PROGRAM
	PUSHJ	P,K.OUT		;WRITE OUT THE COUNTERS
	TERPRI	<
END OF SAIL EXECUTION>
	CALL6	(0,RESET)	;CLEAR THE I/O WORLD
	CALL6	(1,EXIT)	;QUIT QUIETLY

INILST:	
	SKIPN	TEMP,INILNK
	POPJ	P,
	MOVE	USER,GOGTAB	;JUST TO BE SURE
	SKIPA	A,[XWD -SYSPHS,0]	;XWD #SYS PHASES,0
DOPHS:	HRRZ	TEMP,INILNK	;LIST OF THEM
NXLNK:	
	PUSH	P,TEMP		;SAVE LINK
NXIN:	ADDI 	TEMP,1		;LOOK AT NNEXT ENTRY
	SKIPN	B,(TEMP)	;END OF LINK LIST
	JRST	NXIN.1		;YES
	HLRZ	C,B		;PHASE NUMBER OF THIS
	CAIE	C,(A)		;THIS PHASE
	JRST	NXIN		;NO
	PUSH	P,A
	PUSH	P,TEMP
	PUSH	P,USER
	PUSHJ	P,(B)
	POP	P,USER
	POP	P,TEMP
	POP	P,A
	JRST	NXIN		;GO DO NEXT IN THIS
NXIN.1:	POP	P,TEMP
	HRRZ	TEMP,(TEMP)
	JUMPN	TEMP,NXLNK
NXPHS:	AOBJN	A,DOPHS		;GO ON TO NEXT PHASE
	POPJ	P,		;

INTERNAL .UINIT
.UINIT:	MOVE	A,[XWD -USRPHS,400000] ;DO USER PHASES
;; #KV# MAKE SURE LINK NON-NULL
	SKIPN  INILNK
	POPJ	P,
;; #KV#
	JRST	DOPHS
SUBTTL	.SEG2. -- Get a second segment

COMMENT ⊗   Initialize the second segment, if there is none and if desired.
 This occurs when the program is first started. This is a dummy routine
 if not a SAISEG-program
⊗

INTERNAL .SEG2.
.SEG2.:
LOW <
	SKIPE	JOBHRL		;IS THERE A SEGMENT?
>;LOW
	 JRST	 (P)		; YES, GO AHEAD (OR ALWAYS, IF NOLOW)
>;NOUP

LOW <

COMMENT ⊗ Now, if global model, get segment specifications from space blocks
of compiled programs (via REQUIRE verbs in source code). 
Segment name business is ignored in EXPO version, since segment and file
names are always equivalent (philosophical differences).
⊗

SEGTR:				;TRY AGAIN
GLOB <

	SKIPN	%RENSW		;IS LINK-TABLE AND/OR PREVIOUSLY COLLECTED
				; INFORMATION INVALID??
	 JRST	 SEG3		;NO
	FOR II⊂(SEGDEV,SEGFIL,SEGPPN,NMSAV) <
	SETZM	II
>
	JRST	ASKEM		;CLEAR ALL NON-USER SPECIFIED INFO

SEG3:	SKIPN	B,SPLNEK	;A SPACE BLOCK AROUND??
	 JRST	 ASKEM		; NO
GSGLP:	SKIPE	A,$SGD(B)	;DEVICE REQUEST
	MOVEM	A,SEGDEV
	SKIPE	TEMP,$SGF(B)	;FILE NAME FOR UPPER SEGMENT
	MOVEM	TEMP,SEGFIL
	SKIPE	TEMP,$SGPP(B)	;PPN FOR SAME
	MOVEM	TEMP,SEGPPN
	SKIPE	TEMP,$SGNM(B)	;SEGMENT NAME (UNUSED IN EXPO VERSION)
	MOVEM	TEMP,NMSAV
	SKIPE	B,(B)		;GO DOWN LINKED LIST
	 JRST	 GSGLP		; UNTIL EMPTY
>;GLOB

COMMENT ⊗ If not enough information was supplied (global model only),
ask questions of user to obtain file names, etc.  Also (NOEXPO only),
try to ATTSEG to a segment of the desired name. In the EXPO version,
all this is combined in the GETSEG below.
⊗
NOEXPO <	;SEGMENT NAME NOT USEFUL TO EXPO SYSTEM
GLOB <
	SKIPE	A,NMSAV		;DID WE GET A SEGMENT?
	 JRST	 GOTEM		; YES, TRY TO LINK TO IT

ASKEM:	TERPRI	<SEGMENT LOGICAL NAME?>
	JSR	GGNAM		;GET A SEGMENT NAME.
GOTEM:	MOVEM	A,NMSAV
>;GLOB
NOGLOB <
	MOVE	A,[FILXXX]	;TRY TO FIND IT.
>;NOGLOB
	CALLI	A,400016	;ATTSEG.
	SKIPA			;NO LUCK
	JRST	(P)		;OK, DONE
	HRRZ	B,A		;GET FAILURE CODE.
	CAIE	B,1		;AMBIGUITY?
	JRST	GETSE		;NO -- GET THE SEGMENT.
	HLRZS	A
	CALLI	A,400016	;ATTSEG.
	JSP	A,ERSEG
	JRST	(P)		;OK, GOT IT
>;NOEXPO
EXPO <
ASKEM:				;MISPLACED LABEL
>;EXPO
GETSE:	CALLI
GLOB <
	SKIPE	A,SEGFIL	;WAS ONE "REQUIRE"D?
	 JRST	 THSFL		; YES, USE IT
	TERPRI	<SEGMENT FILE NAME?>
	MOVE	A,[FILXXX]	;DEFAULT
	JSR	GGNAM	
THSFL:	MOVEM	A,SEGFIL	;NAME OF SEGMENT.
THSFL1:	SKIPE	A,SEGDEV	;WAS A DEVICE REQUESTED?
	 JRST	 THSDV		; YES
	TERPRI	<DEVICE?>
	MOVE	A,[SGDEVC]	;DEFAULT DEVICE
	JSR	GGNAM
	MOVEM	A,SEGDEV
	CAMN	A,['DSK   ']	;ASK FOR PPN IF DISK
	SKIPE	SEGPPN		;AND PPN=0
	JRST	THSDV		;DON'T ASK, ALREADY THERE
	TERPRI	<PPN?>
	MOVE	A,[SGPPNN]	;DEFAULT PPN
	JSR	GGNAM
	MOVEM	A,SEGPPN
	JRST	THSFL1		;NOW HAVE A DEVICE
THSDV:	MOVEM	A,INTT
	MOVE	A,[XWD SEGDEV,DEVSEG]	;MOVE LOOKUP SPEC IN
	BLT	A,SEGNAM+3
>;GLOB
NOGLOB <
	SETZM	SEGNAM+2
	MOVE	TEMP,[SGPPNN]
	MOVEM	TEMP,SEGNAM+3	;SET UP PPN
	HLLZS	SEGNAM+1
>;NOGLOB

COMMENT ⊗ Now work is nearly done in EXPO system, but all sorts of hair 
remains otherwise.  In either case, now get segment in, get it into 2d 
segment, name it right

⊗
NOEXPO <
	INIT	1,17
INTT:	SGDEVC			;GO GET THE RAW SEGMENT
	0
	JSP	A,ERSEG
	LOOKUP	1,SEGNAM
	JSP	A,ERSEG
	MOVS	A,SEGNAM+3	;WORD COUNT
	HRLM	A,LIOD		;WORD COUNT FOR DUMP MODE.
	MOVNS	A
	HRRO	D,JOBREL	;FOR LATER
	HRRM	D,LIOD		;PLACE TO START DUMP MODE INPUT.
	ADD	A,JOBREL	;TO GET THE AMOUNT OF CORE NEEDED.
	CALLI	A,11		;CORE UUO ----
	JSP	A,ERSEG
LOP22:	INPUT	1,[LIOD: IOWD 200,%UPDL
		    0]
GLOB <
	TLZ	D,-1		;NO, MAKE IT WRITEABLE IF GLOBAL MODEL.
>;GLOB
IFN NOPROT,<
	TLZ	D,-1		;MAKE WRITEABLE IF REQUESTED TO
>;NOPROT≠0
	CALL	D,[SIXBIT/REMAP/]	;
	JSP	A,ERSEG
NOGLOB <
	MOVE	A,[FILXXX]
>;NOGLOB
GLOB <
	MOVE	A,NMSAV
>;GLOB
	CALLI	A,400036	;SETNM2
	JRST	[MOVEI	A,0
		 CALLI	A,400015	;CORE2
	 	 JSP	A,ERSEG
GLOB <
		 SETOM	%RENSW	;FORCE TTY RITUAL
>;GLOB
		 JRST	SEGTR]		;TRY AGAIN.
	CALLI
>;NOEXPO

EXPO <
	SETZM	SEGNAM+4		;CLEAR LAST TWO WORDS OF GETSEG BLOCK
	SETZM	SEGNAM+5
	MOVEI	A,DEVSEG		;GET READY
	MOVEM	P,SAVPP
	CALL	A,[SIXBIT /GETSEG/]	;GET THE SEGMENT
	 JSP	 A,ERSEG		; COULDN'T
	MOVE	P,SAVPP
; NO WAY TO RENAME 2D SEGMENT, SO DON'T WORRY ABOUT IT
>;EXPO

	JRST	(P)			;RETURN
>;LOW

EXPO <
NOUP <
INTERNAL TYPER.,OVPCWD,ERRMSG
;THESE ARE BECUSE OF LIB40 CHANGES
; MADE CAPRICIOUSLY BY DEC
TYPER.:
ERRMSG:
OVPCWD:	JFCL
	ERR	<SOME FORTRAN ROUTINE HAS SEEN FIT TO COMPLAIN
ABOUT YOUR STYLE.  COMPLAIN TO DEC THAT THEIR ERROR MESSAGE
PROCEDURE IS NOT SUFFICIENTLY GENERAL TO ALLOW GRACEFUL INTERFACE
WITH SAIL.>
>;NOUP
>;EXPO
SUBTTL	 Segment-Fetching Data

LOW <

NMSAV:	0			;SAVE LOGICAL SEGMENT NAME HERE
SEGDEV: 0			;SAVE UPPER SEGMENT DEVICE NAME HERE
SEGFIL:	0			;SAVE UPPER SEGMENT FILE NAME HERE
NOEXPO <
	SIXBIT /SEG/		;ALWAYS
>;NOEXPO
EXPO <
	SIXBIT	/SHR/		;DIFFERENT STROKES FOR ....
>;EXPO
	0
SEGPPN: 0			;SAVE UPPER SEGMENT PPN HERE

DEVSEG:	SGDEVC			;USED ONLY BY EXPO'S GETSEG
SEGNAM:	FILXXX
NOEXPO <
	SIXBIT/SEG/
>;NOEXPO
EXPO <
	SIXBIT /SHR/
>;EXPO
	0
	SGPPNN			;SPECIFIED PPN DEFAULT
EXPO <
	0 ↔0			;SIX WORD BLOCK FOR GETSEG
SAVPP:	0			;P SAVED HERE OVER GETSEG
>;EXPO
ERSEG:	TERPRI	<SAIL SEGMENT LOADING ERROR>
GLOB<
	SETOM	%RENSW		;FORCE TTY RITUAL
>;GLOB

	CALLI 12

GLOB <
GGNAM:	0
	TTCALL	4,C		;INCHWL.
	CAIE	C,15		;IF NOTHING SPECIFIED,
	MOVEI	A,0		; USE THE DEFAULT
	SKIPA	B,[POINT 6,A]
GGGO:	TTCALL	C		;GET CHAR
	CAIN	C,15
	JRST	[TTCALL C ↔ JRST @GGNAM]	;RETURN ON CR.
	CAILE	C,140
	SUBI	C,40		;CONVERT LOWER CASE.
	SUBI	C,40		; → SIXBIT
	IDPB	C,B		;SAVE IT.
	JRST	GGGO
>;GLOB
>;LOW
ENDCOM(LOR)
LOW <
	END
>;LOW
COMPIL(LUP,<%UUOLNK,%ALLOC,SAVE,RESTR,STACSV,STACRS,INSET>
	   ,<CORGET,STCLER,%UACS,GOGTAB,%UPDL,CONFIG,%ALLCHR>
	   ,<INITIALIZATION ROUTINES, UUO HANDLER, UTILITY ROUTINES>)
IFE ALWAYS,<
INTERNAL %ALLOC
; MORE EXTERNALS
EXTERNAL	ALLPDP,ERRSPC,SETLET,DPYSW,INILNK
EXTERNAL	SPLNEK,UUO0,%OCTRET,%ERFIL,%ERFLGS,%ERFIL,%ERCNTR,%ERPNTR,%ERBUF
EXTERNAL	X11,X22,X44,CORINC,%STDLS,%SPL,KTLNK

;; #MW# EXPORT NEEDS PPMAX
EXPO <
EXTERNAL PPMAX
>;EXPO

>;IFE ALWAYS

NOLOW <			;PUT IN UPPER SEGMENT AND ALL THAT FOLLOWS....
UP <

;IF YOU CHANGE ANYTHING ABOVE THIS POINT, YOU WILL
;HAVE TO RELOAD.  THIS IS THE UPPER SEGMENT DISPATCH TABLE FOR
;INTERNAL SYMBOLS.

	USE	DSPCH		;A PC FOR VECTOR JRSTS
	USE
	BLOCK =200		;SPACE FOR THE JRSTS.
>;UP

SUBTTL	 %ALLOC -- Main Allocation Routine

DSCR %ALLOC
CAL JSP 16,%ALLOC
DES Processes space reqests, allocates the storage for stacks,
 string space, etc.  Sets certain universal environmental variables

 The SPLNEK list, created by the LOADER from compiled requests, contains
 REQUEST blocks.  Space requests begin at location $SPREQ within each
 block.  The entries consist of two-word entries, viz:

		   -----------------------------
 →- SPLNEK ptr -→ |		| →next block	| --→
		   -----------------------------
		  |				|
		  |    fixed LEAP allocation	|
		  |	     data		|
		  |				|
		  |	     ... 		|
		   -----------------------------
	$SPREQ:	  |OP1    |INDX	| SIZe request	|
		  |- - - - - - - - - - - - - - -|
 		  | TEXt addr   | RESult ADdRess| (if ¬STDSPC --
		   -----------------------------    see below)
		  |OP2 ...	|   etc.	|
		   -----------------------------
		  |   ... more ops ...		|
		   -----------------------------
		  |      0 terminates		|
		   -----------------------------

 OP is a 12-bit field (0:11), whose bits are interpreted as:
   0  STDSPC  if 1, get TEX,RESADR spec from standard entry
	      indexed by INDX field -- this is only a 1-word wntry.
   1  WNTADR  requests that the address of the allocated core be
	      returned in the specified RESADR field. RESADR is
	      then incremented.
   2  WNTEND  requests that the address of the first word not in the
	      allocated area be placed in RESADR field. RESADR bumped.
   3  WNTPDP  requests that a PDP computed from address and length be
	      returned in like manner.
   4  USRTB  indicates that the RESADRs are indices into the user
	      table -- (GOGTAB) should be added before use.
   5  MINSZ   indicates that the size specified here should be REPLACED
	      by the first subsequent non-zero request (not ADDED).
	      Default value for this area -- anything overrides.

 INDX is a 6-bit field (12:17) used if STDSPC to cause the address to be
   obtained from a spec (with its own OP and addr words) built into GOGOL.
   This allows push-down list, string space, etc., sizes to be requested by
   object modules without knowing the locations of their descriptors.
   The indices represent:
  1  SYSPD    System push-down list (P)
  2  SYSSPD   String push-down list (SP)
  3  STRSP    String space size.

 SIZ replaces any previous request with MINSZ on.  Otherwise, its value is
   added to an accumulated size for this address.  The final result will
   specify the size of the area.
  SIZ<0 causes current entry to be disregarded.

 TEX is the address of an ASCIZ string describing the use of the area.
   It is used when the user REENTERs to ask him how much space he wants.
   A non-zero value means that no overriding is possible for this area.

 These requests are accumulated on the stack in two-word entries as:
		   -----------------------------
	$SPREQ:	  |OP1    |INDX	| RESult ADdRess|
		  |- - - - - - - - - - - - - - -|
 		  | TEXt addr   | accum size    |
		   -----------------------------   
  Inconsistencies in request bits are not likely to be detected.

 %ALLOC first processes the entire list, collecting cumulative information
   about each RESADR requested, summing the size requests (with mods as
   described for MINSZ above).  Then it allocates space for each requested
   area, allowing the user to override each if he REENTERed, and if there
   is TEXt for that area.  It finishes by performing some useful but 
   uninteresting bookkeeping.
⊗

; Get a Stack to hold requests in

HERE (%ALLOC)
	MOVEI	C,MINPDS		;ABOUT 64 WORDS
	PUSHJ	P,CORGET		;THIS USUALLY INITS THE USER TABLE
	 ERR	 <NO CORE FOR ALLOCATION>
	PUSHJ	P,PDPMAK		;A PUSH-DOWN POINTER
	MOVE	P,B			;DITCH THE ALLOC PDL
	MOVEM	B,PDL(USER)		;STORE TEMPORARILY
	PUSH	P,16			;THE RETURN ADDRESS
	ADD	P,X22			;ONE DUMMY ENTRY TO TERMINATE
	SETZM	-1(P)			;0 TERMINATES IT

; Loop to search the space request blocks
; Until further notice:
;  T is →next allocation block.
;  T1 is →next entry specification
;  Q1 is modified T1 -- accounts for STDSPC specifications
;  Q2 is incoming OP-size word
;  A  is →next candidate stack list element
;  Q3 and TEMP used to do RESADR search in already-requested stack list


	MOVE	T,SPLNEK		;LIST OF BLOCKS
	MOVEM	T,%SPL			;LINK BUILT-IN BLOCK EXPLICITLY
	MOVEI	T,%SPL			;ALLOCATE IT FIRST
%AL1:	MOVEI	T1,$SPREQ(T)		;→FIRST REQUEST
%AL2:	SKIPN	Q2,(T1)			;OP WORD
	 JRST	 NXTELT			;NO MORE THIS BLOCK
	MOVE	Q1,T1			;SAVE ADDRESS OF REQUEST
	TLNN	Q2,STDSPC		;A BUILT-IN RESADR/TEXT?
	 AOJA	 T1,DRCT		; NO, GET IT HERE

; T1 incremented because 2-word entry -- Q1 still → 1st word
; Here, there is only a 1-word entry -- the actual RESADR spec
;  found by indexing into table.

	LDB	Q1,[POINT 6,Q2,17]	;THE INDEX
	LSH	Q1,1			;2-WORD ENTRIES ALL
	ADDI	Q1,%STDLST		;HERE'S WHERE THEY LIVE
	HLL	Q2,(Q1)			;USE STANDARD BITS FROM HERE ON
	TLZ	Q2,MINSZ		;NEVER USED FOR MIN WHEN BY INDEX

; Now find the corresponding entry in the accumulated stack entries
;   or add a new entry

DRCT:	HRRZ	Q3,1(Q1)		;ADDRESS OF RESULT
	TLZE	Q2,USRTB		;RESULT IN THE USER TABLE?
	ADD	Q3,GOGTAB		;YES
	MOVEI	A,-1(P)			;FOR SEARCH DOWN STACK
	JRST	%AL4			;GO SEARCH

%AL3:	CAIN	Q3,(TEMP)		;SAME ADDR?
	 JRST	 %AL5			;YES, UPDATE
	SUBI	A,2			;BACK UP ONE
%AL4:	SKIPE	TEMP,(A)		;NEXT SAVED OP WORD
	 JRST	 %AL3			;TRY THIS ONE

; First occurrence of this address, make a place for it

	MOVEI	A,1(P)			;BACK TO THE TOP
	ADD	P,X22			;NEW ENTRY
	SETZM	(A)
	SETZM	1(A)			;VIRGIN ENTRY

COMMENT ⊗
NMIN means MINSZ  on in new spec, OMIN means it's on in stack spec
NSIZ mean that new size≠0, OSIZ etc. -- then
 NMIN∧¬OSIZ		⊃⊃ OSIZ←NSIZ, OMIN←TRUE
 NMIN∧ OSIZ		⊃⊃ no change

¬NMIN∧NSIZ∧OMIN		⊃⊃ OSIZ←NSIZ, OMIN←FALSE
¬NMIN∧¬NSIZ∧OMIN	⊃⊃ no change
¬NMIN∧¬OMIN		⊃⊃ OSIZ←NSIZ+OSIZ, OMIN←FALSE

In the sequel,
 A→current stack entry, T,T1,Q1 unchanged,
 Q2 is NEWSIZ, will be accum SIZ and TEXt addr.
 Q3 is NEWBITS,,RESADR, will be accumulated same.
 TEMP will be old TEX,,SIZ word, LPSA old BITS,,ADR
⊗

%AL5:	HLL	Q3,Q2		;NEW BITS,,RESADR
	HRRES	Q2		;NEW SIZE
	MOVE	TEMP,1(A)	;OLD TEX,,SIZ
	MOVE	LPSA,(A)	;OLD BITS,,ADR
	JUMPL	Q2,AOJBAK	;NO ACTION ON NEGATIVE SIZE
	TLNE	Q3,MINSZ	;BEGIN THE HAIRY CASE STUDY
	 JRST	 INMIN		;MIN ON IN NEW

; ¬NMIN
	TLZN	LPSA,MINSZ	;¬NMIN, OMIN? -- OMIN←FALSE
	 JRST	 ADDIT		;¬NMIN∧¬OMIN, ADD
	JUMPN	Q2,%AL6		;¬NMIN∧ OMIN, NSIZ?
	TLOA	Q3,MINSZ	;¬NMIN∧ OMIN∧¬NSIZ, NMIN←TRUE, NSIZ+OSIZ=OSIZ
%AL6:	HLLZS	TEMP	;¬NMIN∧OMIN∧NSIZ, OSIZ←FALSE,NSIZ+OSIZ=NSIZ,NMIN←FALSE
	JRST	ADDIT		;¬NMIN∧ OMIN, EITHER NSIZ OR OSIZ

; NMIN
INMIN:	TRNE	TEMP,-1		;OSIZ?
	TLZA	Q3,MINSZ	;NMIN∧OSIZ, OSIZ unchg, NMIN←FALSE
	TLZA	LPSA,MINSZ	;NMIN∧¬OSIZ, OSIZ←NSIZ, NMIN←TRUE
	MOVEI	Q2,0		;NMIN∧OSIZ again, OSIZ unchg over add

ADDIT:	OR	Q3,LPSA		;COLLECT BITS
	ADD	Q2,TEMP		;AND SIZE
	TLNN	Q2,-1		;ANY TEXT ADDR?
	HLL	Q2,1(Q1)	;NO, GET FROM OLD IF ANY
	MOVEM	Q3,(A)		;PUT NEW AWAY
	MOVEM	Q2,1(A)
AOJBAK:	AOJA	T1,%AL2		;NEXT ELEMENT THIS BLOCK

NXTELT:	SKIPN	T,(T)		;NEXT BLOCK IN ALLOC LIST?
	 JRST	 NOELT		;NO MORE.
LEP <
	SKIPL	$ITNO(T)	;LEAP REQUESTED?
	JRST	%AL1		;NO.
	MOVE	B,GOGTAB	;WILL PLAY WITH USER TABLE
	SETOM	HASMSK(B)	;SOMEONE WANTS LEAP.
>;LEP
	JRST 	%AL1		;CONTINUE DOWN ALLOC BLOCKS.
NOELT:

; SINCE SYSTEM_PDL ALREADY ALLOCATED AND IN USE, INCREMENT IT IF THE
;  REQUEST EXCEEDS THE DEFAULT
	MOVE	TEMP,PDL(USER)
	PUSH	P,4(TEMP)
	PUSH	P,5(TEMP)	;MAKE SURE P-REQUEST ON TOP
	SETZM	4(TEMP)		;AND THAT IT DOESN'T HAPPEN TWICE

; NOW ALLOCATE THE SPACES, GET OVERRIDES
	SETZM	%ALLCHR		;NO QUESTIONS YET
	SKIPN	%RENSW		;WAS THERE A REENTER?
	 JRST	 NONTR		; NO
	TERPRI
	PRINT	<ALLOC? >
	TTCALL	0,B		;ASK LEADING QUESTION AND GET ANSWER
	TERPRI
	TRZ	B,40		; SO CAN USE LOWER CASE
	CAIN	B,"Y"		;YES?
	SETOM	%ALLCHR		;YES
	CAIN	B,"N"		;NO, BUT LET ME SEE IT?
	AOS	%ALLCHR		;RIGHT
	SETZM	%OCTRET		;WHEN ON, NO MORE ASKING
NONTR:
ALOC:	SKIPN	T,-1(P)		;WERE THERE ANY ENTRIES?
	 JRST	 DONEE		; MAYBE, BUT NONE LEFT
	MOVS	A,(P)		;SIZE, TEXT
	TRNE	A,-1
	SKIPL	%ALLCHR		;IF TEXT ADDR AND WANTS TO DO IT,
	 JRST	 NOASK		; MUST ASK QUESTIONS

	OUTSTR	(A)		;PRINT IT
	PRINT	<= >
	PUSHJ	P,DECIN
	HRL	A,C		;REPLACE REQUESTED SIZE BY OVERRIDE
NOASK:	HLRZ	C,A		;IN CASE NOBODY ELSE DID
	JUMPE	C,PRIN		;DON'T ALLOCATE 0 AREAS
	HRRZ	TEMP,T		;DEST ADDR
	CAIE	TEMP,PDL(USER)	;THE ONE AND ONLY?
	 JRST	 NOEXP		; NO

;THIS IS THE SYSTEM_PDL REQUEST -- IT MUST OVERLAY THE CURRENTLY
; ALLOCATED STACK
	HRRZ	B,PDL(USER)	;GET PREV INITIAL CORGET ADDRESS
	CAIGE	C,MINPDS	;MUST BE BIGGER
	 MOVEI	 C,MINPDS	; SO MAKE IT BIGGER
	HRL	A,C		;KEEP EVERYBODY UP TO DATE
	ADDI	B,1		;CORGET ADDR
	CAIG	C,MINPDS
	 JRST	 PDPRET		;NO PROBLEM
	SUBI	C,MINPDS	;AMOUNT TO INCREASE BY
;;#  # 4-28-72 DCS UPDATE P'S SIZE FIELD
	HRLZ	TEMP,C		;UPDATE P RIGHT NOW
	SUB	P,TEMP		;SIZE FIELD ONLY
;;#  # 4-28
	PUSHJ	P,CORINC	;INCREMENT TO PROPER SIZE
	 ERR	 <DRYROT -- NO CORE FOR SYSTEM_PDL>
	ADDI	C,MINPDS	;TOTAL SIZE
	JRST	PDPRET
NOEXP:	PUSHJ	P,CORGET	;GET A BLOCK
	 ERR	 <NO CORE AT ALLOCATION>
PDPRET:	TLNN	T,WNTADR	;WANT THE ADDRESS STORED?
	 JRST	 .+3
	MOVEM	B,(T)		;YES, STORE IT
	ADDI	T,1
	TLNN	T,WNTEND
	 JRST	 NOND
	MOVE	D,C		;SIZE
	ADD	D,B		;END ADDR
	MOVEM	D,(T)
	ADDI	T,1
NOND:	PUSHJ	P,PDPMAK
	TLNE	T,WNTPDP
	MOVEM	B,(T)		;WANTS PDP
PRIN:	SKIPN	%ALLCHR		;ARE WE BLABBING?
	 JRST	 SUBJMP		;NOPE
	OUTSTR	(A)
	PRINT	<: >
	HLRZ	C,A		;SIZE AGAIN
	DECPNT	C		;TOTAL ALLOC FOR THIS ONE
	TERPRI
SUBJMP:	SUB	P,X22		;SO MUCH FOR THAT ONE	
	JRST	ALOC		;GET THE NEXT

DONEE:	SKIPN	%ALLCHR		;BLABBING?
	 JRST	 .+3		; NO
	TERPRI↔TERPRI
	SUB	P,X44		;→RETURN ADDRESS (DUMMY AND SYSPDL ENTRIES)

; FINAL BOOKKEEPING

	SETZM	%RENSW		;DON'T ASK EACH TIME
	MOVE	SP,SPDL(USER)	;STRING STACK POINTER
	MOVE	B,ST(USER)	;STRING SPACE BEGINNING
	MOVN	C,-1(B)		;SIZE
	SUBI	C,3		;MINUS OVERHEAD
	MOVEM	C,STMAX(USER)	;SIZE OF STRING SPACE DATA
	HRLI	B,(<POINT 7,0>)
	MOVEM	B,TOPBYTE(USER)	;NEXT FREE BYTE
	IMUL	C,[-5]		;NUMBER OF FREE CHARS
;;#GI# DCS 2-2-72 (1-3) MAKE CAT BETTER -- THIS LEAVES SOME ROOM
	ADDI	C,=15		;LEAVE SOME SLOP FOR INSET, ETC.
;;#GI# (1-3)
	MOVEM	C,REMCHR(USER)
	SKIPE	CONFIG		;COMPILER?
	 SETOM	 SGLIGN(USER)	; YES, STRNGC AND FRIENDS MUST ALIGN STRINGS
	HRROI	TEMP,KTLNK
	POP	TEMP,KNTLNK(USER)
	POP	TEMP,SGROUT(USER)
	POP	TEMP,SETLNK(USER)
	POP	TEMP,SPLNK(USER)
	POP	TEMP,STRLNK(USER);TRANSFER LISTS TO USER TABLE
	PUSHJ	P,STCLER	;CLEAR OUT ALL STRINGS
	MOVEI	TEMP,7		;INITIAL DIGS SETTING
	MOVEM	TEMP,DIGS(USER) ;FOR FLOATING POINT OUTPUT
	MOVEI	TEMP,CHANS(USER);IF CHNL HAS A VALID CHANNEL #,
	HRLI	TEMP,CHNL	; @CDBLOC(USER) REFERS TO ITS
	MOVEM	TEMP,CDBLOC(USER);CDB ADDR IN THE CHANS TABLE
NOEXPO <
	MOVNI	TEMP,1		;FIND OUT IF ON A DPY
	TTCALL	6,TEMP
	MOVEM	TEMP,DPYSW	;NEG IF DPY
>;NOEXPO
;;#HE# DCS 5-11-72 (2-2) MODIFY VERSION CHECKING, STORAGE METHODS
IFNDEF JOBVER,<EXTERNAL JOBVER>
	MOVEI	LPSA,SPLNEK	;For each element of the space
CHKVRS:	SKIPN	LPSA,(LPSA)	; list, if there is a non-zero 
	POPJ	P,		; version request, use it (lh is
	SKIPN	TEMP,$VRNO(LPSA); SAIL version, rh is user version).
	 JRST	 CHKVRS		;But if there was a previous non-zero
	HLL	TEMP,JOBVER	; request, and if it is not the
	EXCH	TEMP,JOBVER	; same as this one, complain first.
	TRNE	TEMP,-1
	CAMN	TEMP,JOBVER
	 JRST	 CHKVRS
	ERR	<VERSION NUMBER MISMATCH>,1
	 JRST	 CHKVRS
;;#HE# (2-2)


PDPMAK:	MOVNS	C
	SUBI	B,1		;PDP
	HRL	B,C
	POPJ	P,
>;NOLOW
COMMENT ⊗  Utility Subroutines for allocation
⊗
DECIN:
OCTIN:	AOS	(P)
	SKIPE	%OCTRET		;IMMEDIATE RETURN?
	 POPJ	 P,		; YES

	SETZB	C,D
OCTIN1:	TTCALL	0,B
	CAIN	B,177		;RUBOUT?
	 JRST	 RUB		;AYE, THERE'S THE RUB
	CAIN	B,"U"-100	;↑U?
	 JRST	 CTRLU		;INDEED
	CAIN	B,175		;ALTMODE?
	 JRST	 SETRET
	CAIN	B,12		;LINE FEED?
	 JRST	 EPOP		;YES
	CAIL	B,"0"
	CAILE	B,"9"		;I KNOW IT'S CALLED OCTIN,
	 JRST	 OCTIN1		; BUT INPUT IS IN DECIMAL!!
	SETOM	D		;FOUND SOMETHING LIKE A NUMBER
	IMULI	C,=10		;GOOD OLD NUMBER CONVERSION
	ADDI	C,-"0"(B)
	JRST	OCTIN1		;THIS IS A LOOP

SETRET:	SETOM	%OCTRET		;WILL RETURN IMMEDIATELY HENCEFORTH
	TERPRI

EPOP:	SKIPE	D		;FIND ANYTHING?
	SOS	(P)		;YES
CPOPJ:	POPJ	P,

RUB:
CTRLU:	TTCALL	3,[BYTE (7) "↑","U",15,12] ;WON'T THE USER BE
	JRST	OCTIN		;START OVER
SUBTTL	%UUOLNK -- UUO Handler (Dispatch Vector Just Below)

BEGIN UUOS

NOLOW <			;INCLUDE IN UPPER SEGMENT.....
HERE(%UUOLNK)
↑UUOCON:MOVEM	17,%UACS+17		;NOTICE UUO0 IS ABOVE HERE
	MOVEI	17,%UACS
	BLT	17,%UACS+16
	MOVE	P,[XWD -LUPDL,%UPDL]	;SET UP SPECIAL UUO PDL
	MOVE	A,JOBUUO		;GET THE INSTRUCTION
	LDB	B,[POINT 9,A,8]		;GET UUO NUMBER.
	TRNE	B,-1≠17			;CHECK IN RANGE
	JRST	UUOTBL			;ILLUUO
	XCT	UUOTBL(B)		;GO DO RIGHT THING.
	MOVSI	17,%UACS
	BLT	17,17			;RELOAD ACCUMULATORS.
	JRST	2,@UUO0

; UUO TABLE

↑↑UUOTBL:PUSHJ	P,ILLUUO	;0
	PUSHJ	P,PDLOQ 	;1
	PUSHJ	P,FLOAQ 	;2
	PUSHJ	P,FIXQ   	;3
	PUSHJ	P,IOERRR  	;4
	PUSHJ	P,ERRR		;5
	PUSHJ	P,PSIX		;6 -- SIXBIT PRINT.
	PUSHJ	P,ARERRR	;7 -- ARRAY ERROR
	PUSHJ	P,PRINT.	;10 -- PRINT MSG
	PUSHJ	P,DECPNQ	;11
	PUSHJ	P,OCTPNQ	;12
	PUSHJ	P,FLTPNQ	;13
	PUSHJ	P,ILLUUO	;14
	PUSHJ	P,ILLUUO	;15

FLTPNQ:	TERPRI	(<WELL ONE FLOATING PT NUMBER IS 1.0>)
	JRST	GODDT
SUBTTL	 ILLUUO, PDLOV, ERR UUO Handlers

DSCR ERROR UUOS
PAR AC FIELD IS INDEX INTO ERROR ROUTINE
SID SAVES THE WORLD
	THE FOLLOWING ACS ARE SACROSANT: ERFLGS(0),RSPPNT(11),P, SP
	THE OTHERS ARE MORE OR LESS SAVED OVER ROUTINE CALLS
DES THE ASCIZ STRING INDICATED BY THE EFFECTIVE ADDRESS IS TYPED OR LOGGED OUT.
 THE ERROR ROUTINE INDICATED BY THE AC FIELD IS EXECUTED.
 IF `GO' IS NOT ON, THE USER IS ALLOWED TO RESPOND WITH ONE OF SEVERAL
 ALTERNATIVES.  ONE ALTERNATIVE IS CONTINUATION IF THE AC FIELD OF THE
 UUO WAS ODD. OTHERWISE, NO CONTINUATION IS POSSIBLE.  THE ACS AT THE
 TIME OF CALL ARE RESTORED IF CONTINUATION OR `DDT' IS CHOSEN.
⊗
ERFLGS←0 	;AC FOR ERRFLAGS
RSPPNT←11	;AC FOR USERERR BP TO RESPONSE STRING
CNTR←13		;AC FOR CHAR COUNT W.R.T DUMP MODE LOGGING
CNTR1←14	;AC FOR 0 WHEN USEING CNTR AS DUMP MODE COMMAND LIST
PNTR←15		;AC FOR BP W.R.T. DUMP MODE LOGGING
F←6		;ANOTHER AC

IOERRR:	MOVE	ERFLGS,%ERFLGS
	TLO	ERFLGS,AUTO	;MAKE IT COME BACK SILENTLY
	TLZ	ERFLGS,QUIET	;MAKE IT PRINT
	MOVEM	ERFLGS,%ERFLGS
	TLNE	A,740		;ANY ACS AT ALL?
	   TLOA	A,740		;MAKE A 15 -- CONT AND PRINTS LPSA AS SIXBIT
	TLO	A,040		;MAKE A 1 -- CONTINUABLE
	PUSHJ	P,ERRR		;PRINTS MSG AND MAYBE LOG SOME STUFF, RETURN
	CALLI			;AVOID CLOSING FILES
	CALL6	EXIT		;USED TO BE CALL [SIXBIT /EXIT/]

ILLUUO:	SKIPA	A,[10B12+[ASCIZ /ILLEGAL UUO  /]]
PDLOQ:	MOVEI	A,[ASCIZ /PDL OVERFLOW/]
ERRR:   MOVE	ERFLGS,%ERFLGS  	;GET FLAGS
	TLO	ERFLGS,ERRNOW		;INDICATE ERROR IN PROGRESS FOR PRINT
	TLNE	A,40			;BIT ONE OF AC FIELD ON?
	TLOA	ERFLGS,CONT		;YES -CONTINUABLE
	TLZ	ERFLGS,CONT!QUIET	;FATAL - ALWAYS PRINT
	MOVEM	ERFLGS,%ERFLGS
	PUSHJ	P,ERPRIN		;GO PRINT MSG & FRIENDS
	TLNE	ERFLGS,AUTO		;AUTOMATIC CONTINUE?
	PUSHJ	P,GOTRY			;YEP, GO BYE BYE
	TLNN	ERFLGS,KEEP		;KEEP TYPE AHEAD IF ¬K
	TTCALL	11,			;NOPE
	SKIPA				;DON'T PRINT A CRLF THE FIRST TIME
PROMPT:	TTCALL	3,CRLF..
	MOVEI	A,"?"		;PRINT ? FOR IRRECOVERABLE ERRORS,
	TLNE	ERFLGS,CONT	;CAN CONTINUE?
EXPO <
	MOVEI	A,"↑"		;SOMETHING PRINTABLE
>;EXPO
NOEXPO <
	MOVEI	A,"→"		;YES
>;NOEXPO
	TTCALL	1,A		;PRINT IT
NOPROM:
NOEXPO <
	SKIPGE	DPYSW		;ON A DPY?
	DPYOUT	7,DPYMBK	; FLASHING INSTRUCTIONS
>;NOEXPO
	 PUSHJ	P,FAKETTY	;GET A CHAR WITH TTCALL 0 OR ILDP TO B
NOEXPO <
	SKIPGE	DPYSW
	DPYOUT	7,[0↔0]		;TURN OFF ALL THAT FLASHING
>;NOEXPO
	PUSHJ	P,DSPATC	;GO DO THE RIGHT THINGS
	MOVEM	ERFLGS,%ERFLGS	;REMEMBER
	TLNN	ERFLGS,MINUS	;DONOT PROMPT IF WE RECEIVED A MINUS
	TRNE	ERFLGS,-1	;OR IF WE'RE NOT ON A TTY
	JRST	NOPROM
	JRST	PROMPT

DSCR ARRAY ERROR UUO
PAR ARRAY NAME STRING DESCRIPTOR ADDRESS IS EFFECTIVE ADDR
 INDEX NUMBER IS AC FIELD.
DES ARRAY NAME, INDEX NUMBER ARE PRINTED. THEN ERROR UUO CODE
 IS ENTERED AS ABOVE.
⊗

ARERRR:
	MOVE	ERFLGS,%ERFLGS
	TLO	ERFLGS,ERRNOW
	TLZ	ERFLGS,CONT
	MOVEM	ERFLGS,%ERFLGS
	MOVEI	A,[ASCIZ /INVALID INDEX NO. /]
	PUSHJ	P,PRINT.+1
	LDB	A,[POINT 4,JOBUUO,12]
	PUSHJ	P,DECPLD
	MOVEI	A,[ASCIZ / FOR ARRAY /]
	PUSHJ	P,PRINT.+1
	TLNE	ERFLGS,NUMBS
	 PUSHJ	P,PRNUM.
	PUSHJ	P,PRASC
	JRST    PROMPT

DSCR SIXBIT PRINT UUO
PAR UUO ADR IS ADDR OF SIX BIT
DES PRINTS OR LOGS THE MOTHER ACCORDING TO %ERFLGS
EXCEPT THAT IT WONT LOG ANYTHING UNLESS LOG IS ALREADY OPEN
⊗
PSIX:	HRLI	A,(<POINT 6,0>) ;UUO ADDR IS ADDR OF SIXBIT
	MOVE	ERFLGS,%ERFLGS
	JRST	SIXPRT
;SERVICE ROUTINES FOR ERRR

ERPRIN:
NOEXPO <
	PUSHJ	P,PPRESET		;TURN ON PP 0, RESET POSITION
>;NOEXPO
	PUSHJ	P,PRINT.+1		;PRINT MSG
	MOVE	A,JOBUUO		;TO BE SAFE
	LDB	F,[POINT 3,A,11] 	;DISPATCH INDEX
	PUSHJ	P,@URTBL(F)		;CALL ERROR ROUTINE - PUTS STUFF ON SP
	MOVEI	A,0			;INFO FOR MYERR
	SKIPE	ERRSPC			;SPECIAL ERROR ROUTINE??
	 PUSHJ	P,@ERRSPC		;YES -- GO DO IT.
	MOVEI	A,CRLF..
	PUSHJ	P,PRINT.+1		;PRINT A CRLF
	TLNE	ERFLGS,NUMBS		;DOES HE WANT NUMBERS?
	 PUSHJ	P,PRNUM.		;YEP
	POPJ	P,			;END OF ERPRIN

CRLF..: ASCIZ /
/

DSPATC:	CAIL	B,"a"		;lower case?
	SUBI	B,40		;YES, CONVERT TO UPPER
	CAIN	B,15		;CR
	  JRST 	[PUSHJ	P,FAKETTY	;EAT THE LEFTOVER LF
		JRST	GOTRY]
	CAIN	B,12		;LF
	  JRST ATCNTI
	CAIN	B,"K"
	  JRST SETKP
	CAIN	B,"Q"
	  JRST SETQT
	CAIN	B,"N"
	  JRST SETNUM
	CAIN	B,"L"
	  JRST SETLOG
	CAIN	B,"F"
	  JRST SETFL
	CAIN	B,"-"
  	  JRST SETMN
	CAIN	B,"S"
	  JRST STRTIT
	CAIN	B,"X"
	  JRST EXME
	CAIN	B,"E"
	  JRST EDIT
	CAIN	B,"T"
	  JRST TVEDIT
	CAIN	B,"D"
	  JRST GODDT
	CAIN	B,"B"
	  JRST GODEB
	CAIN	B,"C"
	  JRST	GOTRY
	CAIN	B,"A"
	  JRST	ATCNTI
	TTCALL	3,[ASCIZ /HUH? MODES ARE K,Q,N,L (OR F), OR THE NEGATIVES THEREOF.
ACTIVATION REPLIES ARE [CR],[LF],C,A,E,T,D,X,S, OR B.
/]
	POPJ	P,

PRNUM.:	MOVEI	A,[ASCIZ /CALLED FROM /]
	PUSHJ	P,PRINT.+1
	HRRZ 	A,UUO0
	SUBI	A,1
	PUSHJ	P,OCTPLD		;GENERATE DIGITS
	SKIPGE	CONFIG			;RUNTIMES OR GAG
	 JRST	NEARDUN
	MOVEI	A,[ASCIZ /  LAST SAIL CALL AT /]
	PUSHJ	P,PRINT.+1
	MOVE	A,GOGTAB
	HRRZ 	A,UUO1(A)
	SOS	A
	PUSHJ	P,OCTPLD		;GENERATE SOME MORE DIGITS
NEARDUN:MOVEI	A,CRLF..
	JRST	PRINT.+1
;SERVICE ROUTINES TO DSPATC (PART OF ERRR)

GOTRY:	TLZ	ERFLGS,MINUS        	;KILL OFF ANY MINUSES
	TLNE	ERFLGS,CONT		;CAN CONTINUE?
	JRST	GOAHED			;YEP
	TTCALL	3,[ASCIZ /CAN'T CONTINUE
/]
	POPJ	P,

ATCNTI: TLZN	ERFLGS,MINUS	
	TLOA	ERFLGS,AUTO
	TLZ	ERFLGS,AUTO
	JRST 	GOTRY+1

GOAHED:	TLZ	ERFLGS,ERRNOW		;TELL PRINT IS COOL NOW    
	SKIPL	CONFIG			;RUNTIMES?
	PUSHJ	P,CLOSLG		;CLOSE LOGFILE
	MOVEM	ERFLGS,%ERFLGS		;UPDATE BITS
	SUB	P,X11			;ADJUST STACK
	POPJ	P,			;GO AWAY
	

SETKP:	TLZN	ERFLGS,MINUS
	TLOA	ERFLGS,KEEP
	TLZ	ERFLGS,KEEP
	POPJ	P,

SETQT:	TLZN	ERFLGS,MINUS
	TLOA	ERFLGS,QUIET
	TLZA	ERFLGS,QUIET
	POPJ	P,			;GO AWAY - HE WANTS QUIET
DOOVER:	PUSH	P,ERFLGS		;SAVE
	MOVE	A,JOBUUO		;RESET UP A
	TLZ	ERFLGS,LOGGIN		;DON'T RELOG
	PUSHJ	P,ERPRIN  		;PRINT AGAIN - DON'T BOTHER GETTING %ERFLGS
	POP	P,ERFLGS		;RESTORE
	POPJ	P,			

SETNUM:	TLZE	ERFLGS,MINUS
	TLZA	ERFLGS,NUMBS
	TLOA	ERFLGS,NUMBS
	POPJ	P,			;GO AWAY, HE DOESNOT WANT NUMBERS
	JRST	DOOVER			;PRINT AGAIN
	
SETFL:	PUSHJ	P,COMON			;TAKE  CARE OF UNUSUAL CONDITIONS
	PUSHJ	P,GETFIL		;GET THE FILE NAME IN CNTR, EXT IN CNTR1
	 JRST	SETLOG			;HE DIDN'T SPECIFY A FILE
	MOVEM	CNTR,%ERFIL		;STORE NAME
	JUMPE 	CNTR1,NAMIT		;USE DEFAULT EXTENSION
	HLLZM	CNTR1,%ERFIL+1		;STORE EXT
	JRST	SETLF
	
COMON:  TLZE	ERFLGS,MINUS	
	JRST	[TLZ	ERFLGS,LOGGIN
		JRST	CLOSLG]
	TLZE	ERFLGS,LOGOPN		;FORCES REOPENEING THE FILE WITH NEW NAME
	 JRST   CLOSLG
	POPJ	P,

SETLOG:	PUSHJ	P,COMON			;TAKE CARE OF ..
	SKIPL	CONFIG
	JRST	[MOVEI	A,0
		GETNAM	A,		;IF RUNTIME THEN GET JOBS NAME
		MOVEM	A,%ERFIL
		JRST NAMIT]
NAMIT:	MOVE 	A,[SIXBIT /LOG/]
	HLLZM	A,%ERFIL+1
SETLF:  TLO	ERFLGS,LOGGIN
	PUSH	P,ERFLGS		;SAVE FLAGS
	TLO	ERFLGS,QUIET
	MOVE	A,JOBUUO		;SET UP A AGAIN
	PUSHJ	P,ERPRIN  		;PRINT AGAIN
	POP	P,A			;RESTORE FLAGS
	TLNN	A,QUIET
	TLZ	ERFLGS,QUIET
	POPJ	P,

SETMN:	TLO	ERFLGS,MINUS
	POPJ	P,    

STRTIT:	PUSHJ	P,CLOSLG
	HRRZ	A,JOBSA
	JRST	(A)

EXME:	PUSHJ	P,CLOSLG
	MOVSI	17,%UACS
	BLT	17,17
	CALL6	EXIT

GODDT:	PUSHJ	P,CLOSLG
	SKIPN	A,JOBDDT
	JRST    [TTCALL 3,[ASCIZ /NO DDT/]
		POPJ	P,]
	TLNE	A,40			;RAID VERSION 1?
	 JRST	BRKDDT			;YES, TRY A BREAKPOINT
	MOVE	0,[XWD %UACS+1,1]
	BLT	0,16
	MOVE	0,%UACS
	JRST	@JOBDDT			;BYE

BRKDDT:	MOVE	A,-6(A)			;ADR OF $I
	MOVEM	A,%ERFIL+2		;A SAFE PLACE
	MOVE	0,[XWD %UACS+1,1]
	BLT	0,16
	MOVE	0,%UACS
	JSR	@%ERFIL+2
	MOVE	ERFLGS,%ERFLGS
	SETZM	%ERFIL+2
	MOVE	RSPPNT,[POINT 7,%ERFIL+2]
	POPJ	P,			;HE MANAGED TO GET BACK!!

GODEB:	SKIPL	CONFIG		;COMPILER
	JRST	[TTCALL	3,[ASCIZ /SORRY - NO RUNTIME DEBUGGER YET/]
		POPJ	P,]
       	SKIPE	A,ERRSPC	;IS THERE A COMPILER ROUTINE?
	SKIPN	A,-1(A)		;YES, IS THERE AN FTDEBUGGER?
	  JRST	[TTCALL 3,[ASCIZ /SORRY - THIS COMPILER HAS NO DEBUGGER IN IT/]
		POPJ	P,]
	TTCALL  3,[ASCIZ /YOU ARE IN THE COMPILER DEBUGGER
/]
	PUSH	P,ERFLGS
	TLZ	ERFLGS,QUIET!LOGGIN
	MOVEM	ERFLGS,%ERFLGS
	PUSHJ	P,(A)		;GO DEBUG
	POP	P,ERFLGS
	POPJ	P,



DSCR PRINT
PAR  A POINTS TO SOME ASCIZ
SID UPDATES ERFLGS, DESTROYS B,C,D
DES THE ASCIZ STRING INDICATED BY A IS
TYPED OR LOGGED OUT, DEPENDING ON THE BITS ON IN %ERFLGS.
IF THE FILE IS NOT OPEN FOR LOGGING, IT IS OPENED W.R.T %ERFIL.
IF THE UUO IS CALLED IN THE RUNTIMES, THE FILE IS CLOSED AFTER
THE OUTPUT IS DONE.
⊗
INTERNAL PRINT.

↑↑PRINT.:
        MOVE	ERFLGS,%ERFLGS		;GET FLAGS
	TLNN	ERFLGS,QUIET		
	TTCALL	3,(A)			;PRINT
	TLNN	ERFLGS,LOGGIN	
	POPJ	P,			;NO LOGGING
	TLNN	ERFLGS,LOGOPN		;FILE OPEN ALREADY
	JRST	OPNLOG			;NOPE
	MOVE	CNTR,%ERCNTR
	MOVE	PNTR,%ERPNTR
	MOVE	7,[POINT 7,(A)]	
GG..:	ILDB	B,7			;GET BYTE
	JUMPE	B,FOOFIN		;DONE
	PUSHJ	P,PUTCH0		;LOG IT OUT - B CONTAINS THE CHARACTER
	TLNE	ERFLGS,LOGOPN		;MAKE SURE EVERYTHING WAS OK
	JRST 	GG..
	POPJ	P,			;THIS IS AN ERROR RECOVERY...
	
FOOFIN:	SKIPGE	CONFIG			;RUNTIME?
	 POPJ	P,			;NOPE
	TLNN	ERFLGS,ERRNOW		;ARE WE IN ERRR?
	 JRST 	CLOSLG			;NOPE, CLOSE THE LOG FILE
	POPJ 	P,

OPNLOG:	TLNE	ERFLGS,BUFOPN		;DO WE HAVE A BUFFER?
	JRST	OPENIT			;YEP
	MOVEI	C,201			;SIZE
	PUSHJ	P,CORGET		;GET
	JRST	[TTCALL	3,[ASCIZ /CORGET FAILURE/]
		JRST	EREXIT]
        MOVEM	B,%ERBUF	
	TLO	ERFLGS,BUFOPN
OPENIT:	MOVE	C,[CHNSTS 17,14]
	MOVEI	D,17
    GG:	XCT	C			;TEST CHANNAL
	TRNN	14,40000		;IS IT OPEN ALREADY?
	JRST	DD			;NOPE - WE ARE DONE
	ADD	C,[XWD -40,0]		;BUMP AC NUMBER 
	SOJGE	D,GG			;BUMP CONTER
	TTCALL	3,[ASCIZ /NO CHANNEL FOR LOG FILE/]
	JRST	EREXIT

    DD:	LSH 	D,5			;GET AC # INTO AC# FIELD (SORT OF)
	HRLM	D,%ERCHAN		;STORE HIM AWAY
	MOVE	C,[OPEN 0,ADRBOY]
	TLO	C,(D)			;GIVE APPROPO CHANNEL NUMBR
	XCT	C			;DO THE OPEN
        JRST	[TTCALL	3,[ASCIZ /OPEN FAILURE/]
		JRST	EREXIT]
	SETZM	%ERFIL+3
	MOVE	C,[LOOKUP  0,%ERFIL]	
	TLO	C,(D)
	XCT	C
	JRST	[HRRZ	C,%ERFIL+1		;HE HASN'T A LOG FILE...
		JUMPN	C,[TTCALL  3,[ASCIZ /LOOKUP FAILURE/]
			   JRST	EREXIT]
	       	SETZM  %ERFIL+3   		;RESTORE PPN
		SETZM	%ERFIL+2		;CREATION DATE CURRENT
		MOVE	C,[ENTER 0,%ERFIL]
		TLO	C,(D)
		XCT	C
		JRST	ENTRER
		MOVE	PNTR,[POINT 7,0]
		HRR	PNTR,%ERBUF
		MOVNI	CNTR,1200
		JRST	GETEXI]
	MOVS	B,%ERFIL+3
	MOVNS	B
	HRRZ	CNTR,B
	LSH	B,-7			;NOW B IS THE CURNT RECORD NUMBER -1
	TRZ	CNTR,-200		;NOW CNTER IS THE NUMBER OF WORDS IN LAST REC
	MOVE	PNTR,[POINT 7,0]
	HRR	PNTR,%ERBUF		;PNTS TO EMPTY BUFFER
	ADD	PNTR,CNTR
	SUBI	CNTR,200		;NEG. NUMBER OF WORDS LEFT
	IMULI	CNTR,5			;NEG. NUMBER OF CHARS LEFT
	MOVEM	CNTR,%ERCNTR
	SETZM	%ERFIL+3
	SETZM	%ERFIL+2		;MAKE CREATION DATE CURRENT
	MOVE	C,[ENTER 0,%ERFIL]
	TLO	C,(D)
	XCT	C
	JRST	ENTRER
	MOVE	C,[USETI 0,1(B)]		
	TLO	C,(D)
	XCT	C
	HRLI	CNTR,-200
	HRR	CNTR,%ERBUF
	SOJ	CNTR,
	MOVEI	CNTR1,0
	MOVE	C,[IN 0,CNTR]
	TLO	C,(D)
	XCT	C			;TO GET BUFFERS SET UP AN BYTE COUNT
	SKIPA	C,[STATZ 0,750000]	;EOF?
	JRST	ITSOK
	TLO	C,(D)
	XCT	C
	JRST 	ITSOK			;YEP - EOF IS FAR OUT
	TTCALL	3,[ASCIZ  /INPUT FAILURE/]	;BUT DEVICE ERROR IS A BUMMER
	JRST	EREXIT
		 
ITSOK:	MOVE	C,[USETI 0,1(B)]		
	MOVE	CNTR,%ERCNTR
	TLO	C,(D)
	XCT	C
GETEXI:	TLO	ERFLGS,LOGOPN
	MOVEM	ERFLGS,%ERFLGS
	MOVEM	CNTR,%ERCNTR
	MOVEM	PNTR,%ERPNTR
	JRST	GG..-1			;BACK TO DADDY PRINT.


PUTCHR:	TLNN	ERFLGS,LOGOPN
	 POPJ	P,
	MOVE	CNTR,%ERCNTR
	MOVE	PNTR,%ERPNTR
PUTCH0:	
       	AOSGE	CNTR
	JRST	[IDPB	B,PNTR
		JRST	STRPOP]
	HRLI	CNTR,-200
	HRR	CNTR,%ERBUF
	SOJ	CNTR,
	MOVEI	CNTR1,0
	MOVE	D,[OUT 0,CNTR]		
	IOR	D,%ERCHAN
	XCT	D
	SKIPA	PNTR,[POINT 7,0]	
	JRST	[TTCALL  3,[ASCIZ /OUTPUT FAILURE/]
		 JRST   EREXIT+1]
	HRR	PNTR,%ERBUF
	IDPB	B,PNTR
	MOVNI	CNTR,1177		;AN EMPTY BUFFER MINUS ONE
	JRST	STRPOP

ENTRER:	TTCALL	3,[ASCIZ /ENTER FAILURE/]
EREXIT:	SUB	P,X11			;EXIT OPNLOG
	TTCALL	3,[ASCIZ / -- LOGGING ABORTED
/]
	TLZ	ERFLGS, LOGGIN
	JRST	EEXX			;EXIT PRINT (OR PUTCH0)
 
CLOSLG:	TLNN	ERFLGS,LOGOPN
	JRST	[MOVEM	ERFLGS,%ERFLGS
		POPJ	P,	]	;NOTHING OPEN
	MOVE	CNTR,%ERCNTR
	MOVE	PNTR,%ERPNTR
	ADDI	CNTR,1200		;CNTR IS NOW THE # OF CHARS IN THE BUF
	MOVNS	CNTR			; NEG.
	IDIVI	CNTR,5			;CNTR IS NOW THE NEGATIVE # OF WORDS IN  BUF -1
	HRLI	CNTR,-1(CNTR)
	HRR	CNTR,%ERBUF
	SOJ	CNTR,			;IOWD HAS BUFADR-1 IN RH
	MOVEI	CNTR1,0			;MAKE DAMN SURE THAT CNTR2 IS THE NEXT LOC AFTER CNTR
	IDPB	CNTR1,PNTR		
	IDPB	CNTR1,PNTR		
	IDPB	CNTR1,PNTR		
	IDPB	CNTR1,PNTR		
	IDPB	CNTR1,PNTR		
	HLLZ	C,%ERCHAN		;GET THE GOOD CHANNEL
	TDO	C,[OUT    0,CNTR]	
	XCT	C
EEXX:	SKIPA	C,%ERCHAN		;HOPE THE RIGHT HALF IS EMPTY
	TTCALL	3,[ASCIZ /OUTPUT TO LOG FILE FAILED - WILL CONTINUE TRYING TO LOG
/]
	TDO	C,[RELEAS 0,0]		;AND TELL IT TO GO TO HELL
	XCT	C
     	TLZ	ERFLGS,LOGOPN		;TELL WORLD
	MOVEM	ERFLGS,%ERFLGS	
STRPOP:	MOVEM	CNTR,%ERCNTR
	MOVEM	PNTR,%ERPNTR
 	POPJ	P,			;EXIT CLOSLG,PRINT.,OR PUTCHR, OR WHATEVER

ADRBOY:	17
	SIXBIT /DSK/
	0
SUBTTL	  Special Printing Routines For Error Handler

DSCR UUO ERROR MESSAGE ROUTINES AND THEIR INDICES (AC FIELD OF UUO)
⊗

↑↑URTBL:UPOPJ			; 0- 1 -- NO ACTION
	.PRSM			; 2- 3 -- PRINT SYMBOL PTD TO BY LPSA (SAIL)
	PRASC			; 4- 5 -- PRINT SYMBOL PTD TO BY UUO INSTR
	ACPRT			; 6- 7 -- PRNT VAL OF AC IN INSTR PRECDNG UUO
	UUOPRT			;10-11 -- PRINT THE UUO
	AC1PRT			;12-13 -- PRINT AC FIELD ASSUMING RETURN FROM
				; 	  CALL IS IN UUO1(GOGTAB)
	SIXPRT			;14-15 --PRINT LPSA AS SIXBIT

UUOPRT: HLRZ	A,40		;LH
	PUSHJ	P,OCTPLD	;GENERATE ASCIZ
	HRRZ	A,40		;RH
	JRST	OCTPLD		;IT TOO

DSCR PRSYM -- PRINT SYMBOL NAME
PAR SAIL SEMANTICS BLOCK ADDRESS IN LPSA
RES TYPES $PNAME STRING FROM BLOCK
SID DESTROYS A,B
⊗


	$PNAME ←← 1

PRASC:	MOVE 	A,JOBUUO	;→STRING DESCRITPOR
	HRRZ	C,(A)		;#CHARACTERS
	MOVE	A,1(A)		;STRING BP
	MOVEI	E,0		;NO ADJUSTMENT
	JRST	PRSL1		;WON'T WORK FOR ZERO LENGTH STRINS

PRSL:	ILDB	B,A		;CHARACTER
	ADDI	B,(E)		;ADJUSTMENT
	TLNN	ERFLGS,QUIET	
	TTCALL	1,B		;TYPE IT
      	TLNE	ERFLGS,LOGGIN	
	PUSHJ	P,PUTCHR	;LOG IT
PRSL1:	SOJGE	C,PRSL
UPOPJ:	POPJ	P,


SIXPRT:	MOVE 	A,[POINT 6,LPSA];GET FROM HERE
	MOVEI	E,40		;ADJUSTMENT
	MOVEI	C,6		;PRINT 6 CHARS
	JRST	PRSL1

.PRSM:	MOVEI	A,%UACS	
	MOVE	A,LPSA(A)	;GET CONTENTS OF OLD LPSA INTO A
	HRRI	A,$PNAME(A)	;GET → TO SPRING DESCRIPTOR
	JRST	PRASC+1

AC1PRT:	MOVE	A,GOGTAB	;GET USER TABLE PTR
	SKIPA	A,UUO1(A)	;SOMEONE STORED RIGHT THING HERE
ACPRT:	HRRZ	A,UUO0
	LDB	A,[POINT 4,-2(A),12] ;AC # FROM PREV INSTR
	ADDI	A,%UACS
	JRST	DECPLD-1	;PRINT IT IN DECIMAL

SUBTTL	  Code to Handle Linkage to Editors

;SERVICE ROUTINE TO GET A FILENAME

GETFIL:	PUSHJ	P,FAKETTY	;GET A CHARACTER
	CAIN	B," "		;DELETE LEADING BLANKS
	JRST	GETFIL
MKNAMM:	CAIN	B,15		;GO BACK ON CR
	 POPJ	P,		;HE DIDN'T SPECIFY A FILE NAME...
	MOVEI	CNTR,0		;INITIZLIZE
	MOVEI	CNTR1,0		;INITIALIZE
	TRNN	ERFLGS,-1	;GETTING CHARS FROM A TTY?
	 TTCALL	14,0		;YEP - WAIT FOR A WHOLE LINE
	MOVE	C,[POINT 6,CNTR] ;COLLECT FILE NAME HERE
MKNLP:	CAIE	B," "		;DONE?
	CAIN	B,15
	 JRST	 GUDBYE		; YES
	SUBI	B,40
	CAIN	B,"."-40
	SKIPA	C,[POINT 6,CNTR1] ;ADJUST TO GET EXTENSION
	IDPB	B,C		;CHAR OF FILENAME
	PUSHJ	P,FAKETTY
	JRST	MKNLP


GUDBYE:	CAIN	B,15
	PUSHJ	P,FAKETTY
	AOS	(P)
	POPJ	P,

;SERVICE ROUTINE TO GET A CHARACTER FROM TTY OR RH(ERFLGS)

FAKETTY:
	TRNN	ERFLGS,-1	;ANY ADR?
	 JRST	[TTCALL 0,B
		POPJ	P,]	;NOPE, USE YOUR TTY
	TLNN	ERFLGS,MADEPT	;GOT A BYTE POINTER ALREADY?
	 PUSHJ	P,MAKPNT	;NOPE, MAKE A BYTE POINTER
	ILDB	B,RSPPNT	;RPSPNT IS BP TO ReSPonse STRING
	SKIPE	B		;IS IT 0?
	POPJ	P,		;NOPE, ALL IS COOL
	TTCALL	3,[ASCIZ /BAD RESPONSE STRING TO USERERR - USING TTY INSTEAD:/]
	TTCALL	0,B
	HLLZS	%ERFLGS
	HLLZS	ERFLGS
	POPJ	P,
	
	
	
MAKPNT:	MOVE	RSPPNT,[POINT 7,0]
	HRR	RSPPNT,%ERFLGS
	TLO	ERFLGS,MADEPT
	MOVEM	ERFLGS,%ERFLGS
	POPJ	P,
	

;ACTUAL LINKERS START HERE

TVEDIT:	TDZA	13,13		;FLAG AS TV
EDIT:	MOVNI	13,1
	PUSH	P,13
	SETZB	13,14		;PREPARE FOR PROVIDING
	SETZB	15,16		;STOPGAP WITH FILE NAME,
	SETZB	11,12		; PAGE AND LINE NUMBERS, SEQUENTIAL LINE #
	PUSHJ	P,GETFIL	;GET THE FILE NAME IN 13, EXT IN 14 - NO SKIP IF <CRLF>
	JRST	AUTO..		;HE DIDN'T SPECIFY NAME
	JRST	GTIT

AUTO..:	PUSHJ 	P,FAKETTY	;SNARF UP LINE FEED AFTER CR
	MOVEI	A,1
	SKIPE	ERRSPC
	 PUSHJ	 P,@ERRSPC	;SPECIAL FOR COMPILER....
	JRST	GTIT		;GET QQSVED.RPG


GTIT:	POP	P,A		;TV/SOS FLAG
	EXCH	13,14		;EXT IN REG PRECEDING NAME?
;HERE TO RUN ANY PROGRAM, EITHER SOS OR COMPIL.
; REGISTERS HAVE GOODIES IN THEM:
;		13	FILE EXTENSION IN SIXBIT
;		14	FILE NAME IN SIXBIT
;		15	LINE NUMBER IN ASCII.
;		16	PAGE NUMBER (BINARY)
;IF AC 14 IS ZERO, THIS MEANS NO FILE HAS BEEN
; SPECIFIED, AND WE WILL USE "COMPIL" TO REPEAT THE
; LAST EDIT COMMAND (THIS IS NOT A FEATURE ON MOST
; STANDARD DEC SYSTEMS -- SEE R SPROULL)
NOEXPO <
	MOVEI	P,2
	LOAD6	(2,<SYS>)	;ASSUME GET TO EDITOR VIA RPG
	LOAD6	(4,<DMP>)
	MOVEI	6,0
	MOVEI	5,777777	;TELLS RPG: "EDIT"
	LOAD6	(3,<RPG>)
	JUMPE	14,SWAPIT
	MOVEI	5,1		;START AT RPG LOC IN EDITOR
	LOAD6	(3,<SOS>)	;NOW ASSUME SOS
	JUMPL	A,SWAPIT	;YES
	LOAD6	(3,<ETV>)	;NO, TV
	MOVE	15,12		;GET SEQUENTIAL LINE NUMBER
SWAPIT:	CALL6	(P,SWAP)	;SEE YOU AROUND
>;NOEXPO
; ELSE FALL INTO EXPO VERSION ....

COMMENT ⊗ EXPORT VERSION OF EDITOR-INTERFACE
 PROVIDED BY R. SPROULL, 11-18-70
  SEE HIM FOR DETAILS ON DIDDLES TO CCL AND EDIT10
⊗
EXPO <
	JUMPN	14,EDITG	;IF FILE, FIRE UP SOS
	MOVE	P,[XWD -1,[SIXBIT /SYS/
			   SIXBIT /COMPIL/
			  0 ↔ 0 ↔ 0 ↔ 0 ]]
	CALL6	(P,RUN)		;GO RUN IT.
	JRST	4,0
EDITG:	PUSHJ	P,RPGDSK ;SET UP FOR FILE
	MOVE	2,14 	;GET THE FILE
	PUSHJ	P,SXCON
	MOVEI	1,"."
	SKIPN	2,13     ;EXTENSION
	JRST	NOEXT
	PUSHJ	P,OUT1
	HLLZS	2	;EXTENSION.
	PUSHJ	P,SXCON
NOEXT:	SKIPN	11		;PROJ,PROG #
	JRST	NOPPN
	MOVEI	1,"["
	PUSHJ	P,OUT1
	HLRZ	1,11
	PUSHJ	P,OCTO	;OUTPUT OCTAL
	MOVEI	1,","
	PUSHJ	P,OUT1
	HRRZ	1,11
	PUSHJ	P,OCTO
	MOVEI	1,"]"
	PUSHJ	P,OUT1
NOPPN:	PUSHJ	P,CRLF
	JUMPE	15,GOED10	;IF NO LINE NUMBER, DO NOT DO THIS.
	MOVEI	1,"P"
	PUSHJ	P,OUT1
	MOVE	2,15		;LINE NUMBER
	TRZ	2,1	;FOR SURE?
ASCO:	MOVEI	1,0
	LSHC	1,7
	PUSHJ	P,OUT1
	JUMPN	2,ASCO
	MOVEI	1,"/"
	PUSHJ	P,OUT1
	MOVE	1,16	;PAGE NUMBER
	PUSHJ	P,OUTDEC
	PUSHJ	P,CRLF
GOED10:	MOVE	1,PPMAX+2 ;SIZE
	ADDI	1,4
	IDIVI	1,5	  ;TO WORDS
	MOVNS	1
	HRLS	1
	HRR	1,PPMAX	  ;BUFFER START
	ADDI	1,1
	MOVEM	1,PPMAX+2
	MOVSI	1,'EDT'
	EXCH	1,PPMAX+1
	MOVE	2,[XWD 3,PPMAX+1]
	CALLI	2,44	;WRITE IT
	JRST	DSKIT
EDT10R:	MOVE	P,[XWD 1,[SIXBIT /SYS/
			  SIXBIT /SOS/
			  0↔0↔0↔0]]
	CALL6	(P,RUN)
	JRST	4,.
DSKIT:	SETSTS	1,16	;DO NOT LOSE BUFFERS
	MOVEM	1,PPMAX+1
	CALLI	2,30	;JOB NUMBER
	MOVSI	1,'EDT'	;TO FILE NAME
	MOVEI	4,3
DGLP:	IDIVI	2,=10
	IORI	1,20(3)
	ROT	1,-6	
	SOJG	4,DGLP
	MOVSI	2,'TMP'
	SETZB	3,4
	ENTER	1,1
	CALLI	12		;FATAL
	SETSTS	1,0
	CLOSE	1,0		;FINISH
	JRST	EDT10R
RPGDSK:	CALLI
	INIT	1,0
	SIXBIT	/DSK/
	XWD	PPMAX,0
	CALLI	12
	OUTBUF	1,0
	OUTPUT	1,0
	SETZM	PPMAX+2
	MOVEI	1," "
OUT1:	AOS	PPMAX+2
	IDPB	1,PPMAX+1
	POPJ	P,
SXCON:	MOVEI	1,0
	LSHC	1,6
	ADDI	1,40
	PUSHJ	P,OUT1
	JUMPN	2,SXCON
	POPJ	P,
OCTO:	IDIVI	1,10
	HRLM	2,(P)
	SKIPE	1
	PUSHJ	P,OCTO
	HLRZ	1,(P)
	ADDI	1,"0"
	JRST	OUT1
OUTDEC:	IDIVI	1,=10
	HRLM	2,(P)
	SKIPE	1
	PUSHJ	P,OUTDEC
	HLRZ	1,(P)
	ADDI	1,"0"
	JRST	OUT1
CRLF:	MOVEI	1,15
	PUSHJ	P,OUT1
	MOVEI	1,12
	JRST	OUT1
>;EXPO
SUBTTL	 DECPNT, OCTPNT, FIX, FLOAT UUOs

DSCR OCTPNT, DECPNT UUO'S
PAR ADDR OF WORD TO BE PROCESSED IS EFFECTIVE ADDR
RES DECPNT -- WORD TYPED IN DECIMAL
 OCTPNT -- OCTAL
⊗


OCTPNQ:	MOVEI	ERFLGS,0		;NOT QUIET AND NOT LOGGING
        HRRZ	A,(A)
OCTPLD:	MOVEI	C,10			;KEEP RADIX IN C.
	JRST 	PNT.			;TRANSLATE AND LOAD BYTES

DECPNQ:	MOVEI	ERFLGS,0		;NOT QUIET AND NOT LOGGING
       	MOVE	A,(A)
DECPLD:	MOVEI	C,=10
	HRRZI	B,"-"			;MIGHT NEED THIS
	JUMPGE	A,PNT.			; GREATER 0.
	IDPB	B,D			; SAV AWAY A "-"
	MOVMS	A			; FOO1 ← ABS(FOO1);
PNT.:	IDIV	A,C	;FAMOUS DEC RECURSIVE NUMBER PRINTER.
	IORI	B,"0"
	HRLM	B,(P)
	SKIPE	A
	PUSHJ	P,PNT.
	HLRZ	B,(P)
	TLNN	ERFLGS,QUIET
     	TTCALL	1,B
	TLNE	ERFLGS,LOGGIN
	PUSHJ	P,PUTCHR		;LOGS OUT THE CHAR IN B
	POPJ	P,

DSCR FIX UUO (FIXQ)
PAR EFFECTIVE ADDR → WORD TO BE CONVERTED
RES FIXED POINT EQUIVALENT IN AC SPECIFIED IN AC FIELD OF UUO
⊗
FIXQ:	TRNN	A,777760	;IN AC?
	ADDI	A,%UACS		;YES
	MOVE	B,(A)		;GET ARGUMENT
	MULI	B,400	;THIS ALGORITHM STOLEN FROM F4.
	TSC	B,B
	EXCH	B,C
	ASH	B,-243(C)
	JRST	FXFLT		;STORE IN RIGHT PLACE.
	POPJ	P,

DSCR FLOAT UUO (FLOAQ)
RES LIKE FIX, BUT RETURNS FLOATING POINT EQUIVALENT OF ITS ARGUMENT
⊗
FLOAQ:	TRNN	A,777760	;IN AC?
	ADDI	A,%UACS		;YES
	MOVE	B,(A)		;GET ARGUMENT
	IDIVI	B,1B18
	SKIPE	B
	TLC	B,254000
	TLC	C,233000
	FAD	B,C
FXFLT:
	LDB	A,[POINT 4,A,12] ;RESULT REGISTER
	MOVEM	B,%UACS(A)	;STORE RESULT
	POPJ	P,

BEND UUOS
SUBTTL	 DSPLIN, etc.for Disp. Text Line on Error (Compiler)

DSCR DPYCLR
CAL PUSHJ
RES RESETS III DPY STATE IF A III DPY IS AROUND
⊗

NOEXPO <
↑DSPCLR:
	SKIPGE	DPYSW
	DPYCLR
	POPJ	P,

>;NOEXPO


NOEXPO <
↑↑DPYMBK:	DPYMSG
	DPYSVV-DPYMSG+1		;DPYOUT HEADER BLOCK

DPYMSG:	0
	AIVECT	(=100,=400)	;MOVE TO RIGHTOF RAID SCREEN
	ASCID	/HUH? MODES ARE K,N,Q,L,F, OR NEGATIVES THEREOF.
/
	RIVECT	(=612,0)	;GET OUT THERE AGAIN
	ASCID 	(ACTIVATION RESPONSES ARE [CR],[LF],C,A,S,E,T,X,D, OR B.
(
DPYSVV:	DPYJMP	DPYMSG

↑PPRESET:
	SKIPL	DPYSW		;ON A DPY?
	POPJ	P,		;NO, DON'T BOTHER
	OPDEF	PPIOT [702B8]
	PPIOT	1,400000
	DPYPOS	(-200)		;RESET X POS
	DPYSIZ	(3,5)		;RESET GLITCHES
        POPJ	P,    
>;NOEXPO
SUBTTL	SAVE, RESTR, INSET -- General Utility Routines

DSCR SAVE
CAL PUSHJ
DES This routine saves registers 0-CHNL (12) in the user
 RACS area. It also saves the return
 address (-1(P)) in UUO1(USER), for traditional reasons,
 for the error message printout routines.
 Register USER is loaded but not saved, as is register
 TEMP
⊗
↑SAVE:	MOVE	USER,GOGTAB	;→USER RE-ENTRANT TABLE
	HRRZI	TEMP,RACS(USER)	;XWD FF,SAVEADDR
	BLT	TEMP,RACS+CHNL(USER) ;SAVE FF THRU CHNL
	MOVE	TEMP,-1(P)	;RETURN ADDR FROM I/O CALL
	MOVEM	TEMP,UUO1(USER)	;STORE RETURN
	POPJ	P,

DSCR RESTR
PAR LPSA -- XWD FOR ADJUSTING P-STACK (#PARAMS+RETURN ADDR)
CAL JRST
RES ACS are restored from RACS, stack is adjusted using LPSA,
 return is made through UUO1(USER)
⊗

↑RESTR:	MOVSI	TEMP,RACS(USER)	;XWD SAVEADDR,FF
	BLT	TEMP,CHNL	;RESTORE
	SUB	P,LPSA		;ADJUST STACK
	JRST	@UUO1(USER)	;RETURN

DSCR STACSV
CAL PUSHJ
DES SAVES ACS 0-13 IN AREA STACS
SID DESTROYS 14,15
⊗
;; #KL# BY JRL (11-22-72) SAVE ONLY AC'S 0-13
↑STACSV:
	MOVE	15,GOGTAB
	HRRZI	14,STACS(15)
	BLT	14,STACS+13(15)
	POPJ	P,

DSCR STACRS
CAL PUSHJ
DES RESTORES ACS 0-13 FROM AREA STACS
⊗

;; #KL# RESTORE ONLY 0-13
↑STACRS:	MOVE	15,GOGTAB
	HRLZI	14,STACS(15)
	BLT	14,13
	POPJ	P,



DSCR INSET
CAL PUSHJ
RES String Space is adjusted so that next created string will start
 on a full-word boundary.
SID USER→GOGTAB
DES REMCHR is first adjusted, and STRNGC called if necessary.
 Then TOPBYTE is adjusted.
⊗


↑INSET:	MOVE	USER,GOGTAB	;MAKE SURE
;;#GI# DCS 2-5-72 REMOVE TOPSTR
	HLL	TEMP,TOPBYTE(USER)
	HRRI	TEMP,[BYTE (7) 0,4,3,2,1,0]
	ILDB	TEMP,TEMP	;ADJUSTMENT NEEDED.
	ADDM	TEMP,REMCHR(USER)	;UPDATE REMCHR.
	SKIPL	TEMP,TOPBYTE(USER)
	ADDI	TEMP,1
	HRLI	TEMP,440700	;POINT 7, WORD
	MOVEM	TEMP,TOPBYTE(USER)	;AND SAVE
	POPJ	P,
>;NOLOW
ENDCOM(LUP)
COMPIL(COR,<CORREL,CORGET,CORINC,CANINC,CORBIG>
	   ,<GOGTAB>
	   ,<CORGET, CORREL, ... -- CORE ALLOCATION ROUTINES>)
SUBTTL	Core Service Routines -- General Description

DSCR BEGIN CORSER
⊗
IFN ALWAYS,<BEGIN CORSER>
Comment ⊗ These are the core allocation routines for both the compiler
	and the code it compiles.  Core comes in "BLOCKs."  A block may be any
	(reasonable) length, and has the following format:

HEAD:	→PREV,,→NEXT		;if block not in use, free storage list pointers
		SIZE		;GREATER 0 if free, LESS0 if in use
	<SIZE-3 data words>	;whatever is to go here
	x00000,,→HEAD		;x=1 if in use, 0 if free

→PREV is zero if this block is first on free storage list. →NEXT is zero if last

In the beginning, the world starts out as one big block, occupying space from
	the end of the (GOGTAB→) user table to @JOBREL. Once a MOVE USER,GOGTAB
	has been done, LOWC(USER) and TOP(USER) indicate the total size of
	available core. FRELST(USER) → the first (only) block in free storage.
 
If GOGTAB is 0, CORGET will create a user table and make the remaining space
	look like a BLOCK.  It will create a user table and point GOGTAB at it.
	It also assures that DDT symbols are below JOBSA(lh).  Then it sets
	JOBFF to =76K out of pure spite.  Now CORGET operations may be issued.

CORGET is called with the desired size in SIZ (C). The free storage list is
	searched for the first free block (BLK) satisfying the request. The
	required block is taken from lower addresses of BLK and BLK is adjusted.
	If requested size is within a few words of the free size, all of BLK is
	given to the user. The resultant address is returned in THIS (B).

If there is no block on FRELST(USER) big enough, or if ATTOP(USER) ≠ 0, CORGET
	checks XPAND(USER) for permission (0) to expand core.  If granted, a new
	block is formed at the top after obtaining more core. It is merged with
	the top block if it is free, then the requested block is allocated from
	it.  CORGET is simple.

CORGET skips if it is successful. It does not skip if it needs to expand and
	either XPAND(USER) ≠ 0 or the CORE UUO fails.

The secret is CORREL. No compacting is done, but CORREL will merge a returning
	block with any neighboring free block.  It can do this because it can
	tell the status of each neighbor by looking at the size (POS if free)
	field or x-bit (off if free).  This tends to reduce checkerboarding.

CORREL is called with a pointer to the block to be released in THIS (B).
	It returns nothing, nor does it ever skip.

CORBIG returns in SIZ the size of the largest available block. ⊗
NOLOW <			;INCLUDE IN UPPER SEGMENT.
SUBTTL	 Special AC Declarations

DEBCOR ←←0		;SWITCH FOR CORE DEBUGGING ROUTINES.
;  ACS  

SIZ	←←  3			;SIZE OF BLOCK BEING OBTAINED OR RELEASED
THIS	←←  2			;POINTER TO SAME
NEXT	←←  1			;POINTER TO SUCCESSOR
PREV	←←  5			;POINTER TO PREDECESSOR
LAST	←←  6			;POINTER TO NEXT-HIGHER NEIGHBOR

TRIVIAL ←←=10			;AMOUNT WE'RE WILLING TO WASTE
SUBTTL	  Utility Routines

DSCR UNLINK
CAL PUSHJ
PAR →Core block to be removed in AC THIS (2)
RES block is removed from CORSER free storage list
SID ACs NEXT (1) and PREV (5) are given appropriate values
⊗

UNLINK:	
	HRRZ	NEXT,(THIS)		;→NEXT BLOCK
	HLRZ	PREV,(THIS)		;→PREVIOUS BLOCK
	SKIPN	PREV			;IF A PREV BLOCK DOES NOT EXIST,
	 MOVEI	 PREV,FRELST(USER)	; USE FRELST POINTER
	HRRM	NEXT,(PREV)		;CHANGE ITS NEXT FIELD
	SKIPE	NEXT			;IF A NEXT BLOCK EXISTS,
	 HRLM	 PREV,(NEXT)		; CHANGE ITS PREV FIELD
	POPJ	P,			;BLOCK IN "THIS" IS NO LONGER ON FRELST

DSCR RELINK
CAL PUSHJ
PAR AC THIS → core block to be placed on free storage list
 AC LAST → last word of block +1
 AC SIZ has size of this block
DES block is placed on CORSERs free storage list
SID AC NEXT (1) is given the appropriate value
⊗

RELINK:
	HRRZM	THIS,-1(LAST)		;X-BIT ← 0, RH ← PTR TO HEAD
	MOVEM	SIZ,1(THIS)		;GREATER 0 SIZE FIELD ⊃ FREE BLOCK
	SKIPE	NEXT,FRELST(USER)	;PLACE NEW BLOCK ON FRONT OF FRELST
	 HRLM	 THIS,(NEXT)		; IF THERE IS ONE
	HRRZM	NEXT,(THIS)		;POINT TO NEXT FROM THIS
	HRRZM	THIS,FRELST(USER)	;UPDATE FRELST POINTER
	POPJ	P,			;RETURN

DSCR CORE2I
CAL PUSHJ
DES Initializes second segment core if there is a global model
⊗

GLOB <
IFN 0,<
↑GLCOR:	
	SKIPE	GLBPNT
	POPJ	P,		;ALREADY INITIALIZED.
	MOVEM	16,GLUSER+LEABOT+16
	MOVEI	16,GLUSER+LEABOT
	BLT	16,GLUSER+LEABOT+15
				;SHALL NOT CLOBBER ACCUMULATOR 1.
	MOVEI	3,3(13)  	;GET SIZE REQUIRED.PLUS SOME BECAUSE BLT LOSES.
	PUSHJ	P,CORE2		;GET SECOND SEGMENT CORE.
	JRST	[TERPRI <NO CORE FOR GLOBAL MODEL>
		 CALLI	12]
	SUBI	2,1
	MOVEM	2,GLBPNT	;AND RECORD IT.
	SETZM	1(2)		;FIRST WORD.
	HRRI	2,2(2)		;SECOND WORD.
	HRLI	2,-1(2)		;FIRST WORD.
	ADDI	3,-2(2)		;LENGTH.
	BLT	2,(3)		;ZERO IT.....
	MOVSI	16,GLUSER+LEABOT
	BLT	16,16		;RESTORE ALL LOADER'S AC'S AGAIN.
	POPJ	P, 		;AND GO AWAY.
>
↑CORE2I: 
	PUSH	P,USER
	MOVE	USER,[XWD GLUSER+LEABOT+20,GLUSER+LEABOT+21]
	SETZM	GLUSER+LEABOT+20
	BLT	USER,GLUSER+ZAPEND
	POP	P,USER		;NOW DATA AREA IS ZERO.
	MOVEI	USER,GLUSER	;SET UP FOR CORE2.
	PUSHJ	P,JUSTSAVE	;AND SAVE AC'S
	SETOM	CORLOK			;THE LOCK ...
	SETOM	GLBPNT			;AND THE SWITCH SAYING INITED.
	MOVE	THIS,TOP2		;LAST ADDRESS IN SEC. SEG USED.
	ADDI	THIS,1
	MOVEM	THIS,LOWC(USER)		;SAVE FOR LATER
	PUSHJ	P,NEWB2			;AND LINK UP.
	JRST	BUFRST			;ALL DONE INITIALIZING.

DSCR 2d SEGMENT CORE CONTROL STORAGE
⊗

CORLOK:	0

CR2BEG:	BLOCK ZAPEND-ZAPBEG+1		;AREA FOR ALL OTHERS.

↑↑GLUSER←CR2BEG-ZAPBEG			;AND THE MAGIC INDEX.
	INTERNAL GLUSER

>;GLOB


DSCR BUFRST
CAL PUSHJ or JRST
RES restores ACs from CORSER routines, and returns
⊗

BUFRST:	
IFN DEBCOR,<
	SKIPE	PRTCOR			;SHOULD WE DEBUG?
	JFCL
>
	MOVSI	TEMP,BUFACS(USER)
	BLT	TEMP,LAST
	POPJ	P,

DSCR BUFSAV
CAL PUSHJ
RES Saves ACs for CORSER routine
 Initializes CORSER storage, obtains USER TABLE if GOGTAB is 0
⊗

BUFSAV:	
GLOB <
	SKIPN	GLBPNT		;HAS GLOBAL MODEL BEEN INITIALIZED?
	 PUSHJ	P,CORE2I		;NO --INITIALIZE IT.
>;GLOB
	SKIPE	USER,GOGTAB		;CAN WE GO AHEAD?
	 JRST	 JUSTSAVE		; YES

Comment ⊗ Use SALTAB and forget the rest if SALTAB is there. Otherwise
	set up a user table.  Don't use THIS or SIZ (B or C). ⊗

NOEXPO <
	MOVEI	TEMP,=76*=1024		;ONE REALLY MUST KNOW WHAT HE
>;NOEXPO
EXPO <
	MOVEI	TEMP,-1			;FOR MAX CORE 
>;EXPO
	MOVEM	TEMP,JOBFF		; IS DOING
 
;	SKIPE	USER,SALTAB		;OTHERS CAN SPECIFY SAIL SPACE
;	MOVEM	USER,GOGTAB		;SET UP GOGTAB IF SALTAB NON-ZERO
;	JUMPN	USER,JUSTSAVE		;DON'T GO THRU SAIL's ALLOCATION

; ASSUME THAT THE WORLD IS NEW

	HLRZ	USER,JOBSA		;USER TABLE ADDRESS
	MOVEM	USER,GOGTAB		;THIS TIME FOR SURE
	SKIPN	JOBDDT			;IF DDT IS IN CORE,
	 JRST	 NODDT			; MAKE SURE ITS SYMBOLS ARE PROTECTED
	HRRZ	TEMP,JOBSYM		;IF JOBSYM IS BELOW JOBFF, THEN 
	CAML	TEMP,USER		; ASSUME ALL SYMBOLS ARE BELOW.
	 TERPRI	 <YOUR SYMBOLS ARE SOON TO BE OBLITERATED>


NODDT:	MOVEI	TEMP,ENDREN-CLER+=2000(USER)	;MAKE SURE
	CAMGE	TEMP,JOBREL		; ENOUGH CORE EXISTS
	 JRST	 CORTHER		; FOR USER TABLE

	CALL6	(TEMP,CORE)		;GET ENOUGH
	 CORERR	 <DRYROT -- NO ROOM FOR USER TABLE>

CORTHER:
	SETZM	(USER)			;CLEAR USER TABLE
	HRL	TEMP,USER
	HRRI	TEMP,1(USER)
	BLT	TEMP,ENDREN-CLER(USER)
	MOVEI	THIS,ENDREN-CLER(USER)	;SET UP LIMITS OF FREE SPACE
	MOVEM	THIS,LOWC(USER)		; BOTTOM
	PUSHJ	P,NEWBLK		;MAKE NEW AREA INTO A FREE BLOCK
	JRST	JUSTSAVE		;SAVE ACS

GLOB <
NEWB2:	CALLI	LAST,SEGSIZUUO		;FIND OUT HOW BIG.
	TRO	LAST,400000		;SINCE ANDY DOES NOT GIVE ME THIS.
	JRST	NEWB1
>;GLOB
NEWBLK:	
	HRRZ	LAST,JOBREL		;END OF BIG BLOCK
NEWB1:	SETZM	(THIS)			;POINTERS WORD IN BIG BLOCK
	ADDI	LAST,1			;CONFORM TO "LAST" STANDARDS
	MOVEM	LAST,TOP(USER)		;TOP OF FREE SPACE
	PUSH	P,SIZ			;SAVE SIZE
	MOVE	SIZ,LAST		;COMPUTE SIZE OF NEW BLOCK
	SUB	SIZ,THIS		;SIZE OF BIG BLOCK
	PUSHJ	P,RELINK		;PUT ON FREE STORAGE LIST
	POP	P,SIZ			;GET SIZ BACK
	POPJ	P,


JUSTSAVE:
	MOVEI	TEMP,BUFACS(USER)
	BLT	TEMP,BUFACS+LAST(USER)
IFN DEBCOR,<
	SKIPE	PRTCOR			;SHOULD WE DEBUG?
	PUSHJ	P,CORPRT		; YES
>
	POPJ	P,


IFN DEBCOR,<
↑PRTCOR:	0
>
SUBTTL	 CORGET

DSCR CORGET
CAL PUSHJ
PAR size of desired block in AC  C (3)
RES 	SUCCESS: addr of block in B, skip-return
	FAILURE: no-skip
SID none, except when called with GOGTAB 0 -- should only be done by experts
DES a block of at least the required size is obtained using first-fit algorithm.
	Up to 10 extra words may be returned, but this is not reflected in C.
⊗

HERE(CORGET)
IFN DEBCOR,<
	SKIPE	PRTCOR
	 TERPRI	 <CORGET: >		;TELL THE PEOPLE WHO YOU ARE
>
	PUSHJ	P,BUFSAV		;SAVE AC'S, INITIALIZE WORLD PERHAPS
GLOB <
	SKIPN	USCOR2(USER)		;ARE WE INSTRUCTED TO USE CORE2?
	JRST	COR21			;NOPE -- GO AHEAD.
↑↑CORE2: SKIPN	GLBPNT			;HAS IT BEEN INITIALIZED?
	 PUSHJ	P,CORE2I		;NO -- BUT NOW.
	AOSE	CORLOK			;CAN WE GET THROUGH THE LOCK?
	JRST	[SOS CORLOK		;APPARENTLY NOT.
		 PUSHJ	P,WAITQQ	;WAIT
		 JRST .-1]
	MOVEI	USER,GLUSER		;USE THIS VERSION OF USER.
	PUSHJ	P,JUSTSAVE		;JUST SAVE THE ACCUMULATORS.
>;GLOB


COR21:	ADDI	SIZ,3			;3 WORDS FOR CONTROL INFO
	SKIPE	ATTOP(USER)		;IF USER REQUESTS IT, GET BLOCK
	 JRST	 EXPAND			; AT TOP OF CORE

	MOVEI	THIS,FRELST(USER)	;THIS WILL POINT TO THE FIRST GOOD BLOCK

GETLUP:	HRRZ	THIS,(THIS)		;→NEXT FREE BLOCK
	JUMPE	THIS,EXPAND		;TRY TO EXPAND CORE, NONE EXIST YET
	CAMLE	SIZ,1(THIS)		;WILL IT FIT?
	 JRST	 GETLUP			; NO, TRY NEXT

GETCOR:	AOS	(P)			;SUCCESS GUARANTEED
	HRRZM	THIS,BUFACS+THIS(USER)	;RESULT(ALMOST)
	PUSHJ	P,UNLINK		;UNLINK THIS BLOCK
	MOVE	LAST,1(THIS)		;REAL BLOCK SIZE
	CAIGE	LAST,TRIVIAL(SIZ)	;IS DIFFERENCE NEGLIGIBLE?
	 JRST	 [MOVSI TEMP,400000	;YES, USE WHOLE THING --
		  ADD   LAST,THIS	; MARK X-BIT TO INDICATE IN USE
		  HLLM	TEMP,-1(LAST)
		  JRST	GETOUT]		;AND GO FINISH OUT

	MOVEM	SIZ,1(THIS)		;NEW SIZE FOR RESULT
	HRRZ	TEMP,THIS		;SAVE START OF BLOCK (RESULT)
	ADD	THIS,SIZ		;NEW START FOR REMAINING FREE STUFF
	SUB	LAST,SIZ		;NEW SIZE FOR REMAINS
	MOVE	SIZ,LAST
	ADD	LAST,THIS		;NEW END FOR REMAINS
	HRLI	TEMP,400000		;TURN X-BIT ON
	MOVEM	TEMP,-1(THIS)		;IN USER'S BRAND NEW BLOCK
	PUSHJ	P,RELINK		;RELINK REMAINS, RESTORE ACS


GETOUT:	PUSHJ	P,GETRST		;RESTORE ACS
	SETZM	(THIS)			;PTR RETRIEVED FROM STORAGE
	MOVNS	1(THIS)			;SIZE NEG ⊃ IN USE
	ADDI	THIS,2			;USER DOESN'T SEE THIS HEADER
IFN DEBCOR,<
	SKIPE	PRTCOR
	PUSHJ	P,CORPRT
>
	POPJ	P,			;HERE'S YOUR BLOCK!

EXPAND:	SKIPE	XPAND(USER)		;IS IT ALLOWED TO EXPAND?
	 JRST	 GETRST			; NO, ERROR RETURN
	PUSH	P,SIZ			;SAVE TOTAL SIZE
	HRRZ	THIS,TOP(USER)		;THIS→NEW BLOCK IF NEXT LOWER IS USED
	SKIPGE	-1(THIS)		;IS TOP BLOCK FREE?
	 JRST	 GETMOR			; NO, USE WHAT YOU HAVE
	HRRZ	THIS,-1(THIS)		;UNLINK THE
	PUSHJ	P,UNLINK		; TOP BLOCK

GETMOR:	MOVE	TEMP,THIS
	ADDI	TEMP,=1024(SIZ)		;GET MORE AND THEN SOME
	POP	P,SIZ			;GET THIS BACK BEFORE YOU FORGET
GLOB <
	CAIN	USER,GLUSER		;THIS IS HOW WE TELL
	JRST	[CALLI TEMP,CORE2UUO	;GET SOME CORE
		 JRST  GETRST		;HE SPAT UPON OUR HUMBLE REQUEST.
		 PUSHJ	P,NEWB2		;LINK IT UP
		 JRST  .+4]
>;GLOB
	CALL6	(TEMP,CORE)		;ASK FOR MORE
	 JRST	 GETRST			;CAN'T GET IT
	PUSHJ	P,NEWBLK		;MAKE TOP LOOK LIKE FREE BLOCK
	CAMLE	SIZ,1(THIS)		;NOW SHOULD FIT
	 CORERR	 <DRYROT -- EXPAND CODE GLUBBED UP>
	JRST	GETCOR			;GO GET BLOCK

GETRST:	
GLOB <
	PUSHJ	P,BUFRST		;RESTORE ACCUMULATORS.
	CAIN	USER,GLUSER		;WAS IT CORE2?
	SOS	CORLOK			;YES -- BACK UP COUNT.
	MOVE	USER,GOGTAB		;RESET IT TO USUAL.
	POPJ	P,			;
>;GLOB
	 JRST BUFRST
SUBTTL	 CORINC, CANINC

DSCR CORINC 
CAL PUSHJ
PAR AC B -- Addr of block to be incremented
 AC C -- amount if increase desired
RES SUCCESS: skip-return, extra core has been granted
 FAILURE: no-skip
SID none
⊗

HERE(CORINC)
IFN DEBCOR,<
	SKIPE	PRTCOR
	 TERPRI	 <CORINC:>
>
	PUSHJ	P,JUSTSAVE		;SAVE ACS
	MOVNI	FF,1			;WANT TO DO IT
	JRST	INCR

DSCR CANINC
CAL PUSHJ
PAR same as CORINC
RES No extra core is ever actually obtained
 if entire request can be granted, skip-return
 if some extra words available, no-skip, C contains possible increment
 if no extra words available, no-skip, C contains 0
SID none except as described above
⊗

HERE(CANINC)
IFN DEBCOR,<
	SKIPE	PRTCOR
	 TERPRI	 <CANINC: >
>
	PUSHJ	P,BUFSAV
	MOVEI	FF,0			;JUST WANT TO SEE IF IT'S POSSIBLE

; IF BLOCK IS AT TOP, CAN ALWAYS DO IT

INCR:	SUBI	THIS,2			;POINT AT REAL BLOCK HEAD
GLOB <
	TRNE	THIS,400000		;CHECK TO SEE IF CORE2
	CORERR	<NO CANINC SECOND SEGMENT SPACE>
>;GLOB
	HRRZ	LAST,THIS		;CHECK AT TOP
	SUB	LAST,1(THIS)		; ADDR OF END (SIZE IS NEG)
	CAMGE	LAST,TOP(USER)		;TOP BLOCK?
	 JRST	 MIDDLE		; NO
	JUMPE	FF,YESINC		;SUCCESS
	MOVNS	1(THIS)			;MAKE IT LOOK FREE
	ADD	SIZ,1(THIS)		;TOTAL SIZE
	HRRZS	-1(LAST)		;MAKE END LOOK FREE
	JRST	EXPAND			;EXPAND AND RETURN

MIDDLE:	SKIPGE	TEMP,1(LAST)		;NEXT BLOCK FREE?
	 JRST	 NONEATALL		; NO, FAILURE
	SUBI	TEMP,3			;AVAILABLE SIZE
	CAMLE	SIZ,TEMP		;IS THERE ENOUGH?
	 JRST	 MAYBE			; NO, FAILURE MAYBE

	JUMPE	FF,YESINC		;ALL OK, CAN DO, REPORT IT
CRXXB:	MOVNS	TEMP,1(THIS)		;MAKE IT LOOK FREE
	PUSH	P,(THIS)		;WILL RESTORE THIS IN CASE SOMEONE USED
	PUSH	P,THIS			;SAVE SIZE
	PUSH	P,SIZ			;AND POINTER
	ADDM	TEMP,(P)		;TOTAL SIZE DESIRED AFTER RETURN
	MOVE	SIZ,TEMP		;SIZE OF CURRENT "THIS"
	HRRZ	THIS,LAST		;MERGE "THIS" WITH "LAST"
	PUSHJ	P,UNLINK		;TAKE IT OFF FRELST
	ADD	LAST,1(THIS)		;AND INCREASE
	ADD	SIZ,1(THIS)
	MOVE	THIS,-1(P)		;RETRIEVE CURRENT BLOCK.
	PUSHJ	P,RELINK		;AND NOW RELINK ON FRELST.
	POP	P,SIZ
	POP	P,THIS
	PUSHJ	P,GETCOR		;GET THE BLOCK AGAIN, ONLY BIGGER
	 CORERR	 <DRYROT -- NEAR CRXXB>		;CAN'T HAPPEN
	POP	P,-2(THIS)		;GET POINTER WORD BACK
	AOS	(P)			;SUCCESS
	POPJ	P,			;BUFRST DONE BY GETCOR

YESINC:	AOS	(P)			;REPORT SUCCESS
IFN DEBCOR,<
	SKIPE	PRTCOR
	PUSHJ	P,CORPRT
>
	JRST	BUFRST

MAYBE:	ADDI	TEMP,3(LAST)		;GET TOP OF NEXT BLOCK AND SEE
	CAMGE	TEMP,TOP(USER)		;IF IT IS THE TOP ONE.
	 JRST	 NOTENUF		;NO  -- FAIL UTTERLY.
	JUMPE	FF,YESINC		;GOT IT IF ONLY GOING TO HERE.
	PUSH	P,SIZ			;SAVE AMOUNT REQUESTED.
	MOVEI	SIZ,-3(TEMP)		;THIS IS THE SIZE OF THE BLOCK WE
	SUB	SIZ,LAST		;KNOW WE CAN GET.
	MOVN	TEMP,SIZ
	ADDM	TEMP,(P)		;(P) NOW HAS EXTRA REQUIRED.
	PUSHJ	P,CRXXB			;AND WE DO SOO
	 CORERR	<DRYROT NEAR MAYBE>		; CAN'T HAPPEN.
	POP	P,SIZ			;RETRIEVE SIZE.
	MOVNI	FF,1			;SINCE CRXXB DESTROYED IT.
	JRST	INCR			;AND GO THROUGH AGAIN
					;THIS TIME IT WILL BE THE TOP BLOCK.


NOTENUF:
	SUBI	TEMP,3(LAST)		;UNDO WHAT WAS DONE ABOVE
	SKIPA	SIZ,TEMP		;CAN'T DO ALL, BUT CAN DO THIS MUCH

NONEATALL:
	MOVEI	SIZ,0			;CAN'T DO ANYTHING
	MOVEM	SIZ,BUFACS+SIZ(USER)
	JRST	BUFRST

SUBTTL	 CORREL

DSCR CORREL
CAL PUSHJ
PAR addr of block to be released in B
RES block is released to free storage
SID none
DES the block is merged with any adjoining free blocks
⊗

HERE(CORREL)
IFN DEBCOR,<
	SKIPE	PRTCOR
	 TERPRI	 <CORREL: >
>
	SKIPN	USER,GOGTAB		;MUST BE SET UP HERE
	 CORERR	 <DRYROT -- CORREL CALLED WITH INITIALIZED WORLD>
GLOB <
	TRNN	THIS,400000		;IS IT SECOND SEGMENT ADDRESS?
	JRST	NOSGR			;NO
	MOVEI	USER,GLUSER		;USE THIS ONE.
	AOSE	CORLOK			;SEE IF WE CAN GET IN.
	JRST	[SOS CORLOK
		 PUSHJ	P,WAITQQ
		 JRST .-1]
NOSGR:
>;GLOB
	PUSHJ	P,JUSTSAVE		;SAVE ACS

; MERGE WITH LOWER NEIGHBOR (ADDRESS-WISE) IF POSSIBLE

	SUBI	THIS,2			;USER THINKS IT STARTED 2 PAST
	MOVN	SIZ,1(THIS)		;SIZE OF THIS BLOCK
	MOVE	LAST,SIZ		;ADDRESS OF UPPER
	ADD	LAST,THIS		;  NEIGHBOR

	CAMGE	THIS,LOWC(USER)		;IS ADDRESS IN RANGE?
	 CORERR	 <DRYROT -- ADDR TO CORREL TOO LOW>
	CAME	THIS,LOWC(USER)		;CAN THERE BE A LOWER BLOCK
	SKIPGE	-1(THIS)		; AND IF SO, IS IT FREE?
	 JRST	 UPPET			; NO, LOOK FOR UPPER BLOCK

	HRRZ	THIS,-1(THIS)		;→LOWER BLOCK
	PUSHJ	P,UNLINK		;UNLINK IT FROM LIST
	ADD	SIZ,1(THIS)		;INCREASE SIZE
	
; MERGE WITH UPPER NEIGHBOR IF POSSIBLE

UPPET:	CAMLE	LAST,TOP(USER)
	 CORERR	 <DRYROT -- ADDR TO CORREL TOO HIGH>

	CAME	LAST,TOP(USER)		;IS THERE AN UPPER BLOCK?
	SKIPGE	1(LAST)			;AND IF SO, IS IT FREE?
	 JRST	 LNKRET			; NO, RELINK AND GO AWAY

UPPR:	PUSH	P,THIS
	HRRZ	THIS,LAST		;THIS → UPPER NEIGHBOR
	PUSHJ	P,UNLINK			;GET IT OUT
	ADD	LAST,1(THIS)		; INCREASE EXTENT
	ADD	SIZ,1(THIS)		; AND TOTAL SIZE
	POP	P,THIS			; GET HEADER POINTER BACK
LNKRET:	
GLOB <
	CAIN	USER,GLUSER
	JRST	LNKRT		;IF SEC SEGMENT, NEVER SHRINK
>;GLOB
;;#IC# 7-3-72 DCS (1-1) ADD NEW MEANING TO NOSHRK(USER)
	SKIPL	TEMP,NOSHRK(USER)	;If NOSHRK(USER) is:
	CAMG	LAST,JOBREL		;  <0, CORREL should not reduce core;
	 JRST	 LNKRT			;  >0, its RH indicates the amount of
	JUMPN	TEMP,.+2		;      free space which should be
	 MOVEI	 TEMP,=2046		;      protected from release;
	HRRZS	TEMP			;  =0, at least 2K should be protected.
	CAIGE	TEMP,4			;Only the first and third alternatives
	 MOVEI	 TEMP,4			;  were previously available.
	CAMGE	SIZ,TEMP		;Don't bother if there is already
	 JRST	 LNKRT			;  less free space available than
	ADDI	TEMP,(THIS)		;  desired
;;#IC# (1-1)
	CALL6	(TEMP,CORE)
	 ERR	 <DRYROT --CORSER&LNKRET>
	MOVE	LAST,JOBREL	; AND  2) ADJUST BLOCK TO INDICATE
	ADDI	LAST,1
	MOVEM	LAST,TOP(USER)		;AND RECORD NEW RESULTS.
	MOVE	SIZ,LAST	;          THE CHANGE BEFORE RELINKING
	SUB	SIZ,THIS
LNKRT:
	PUSHJ	P,RELINK		;PUT IT BACK
IFN DEBCOR,<
	SKIPE	PRTCOR
	PUSHJ	P,CORPRT
>
	JRST	GETRST			;AND GO AWAY

SUBTTL	 CORPRT, CORBIG

IFN DEBCOR,<
↑CORPRT:
	SETZM	TOTFRE#			;TOTAL FREE STORAGE COUNT
	TERPRI	<FREE STORAGE: >
	PUSH	P,LPSA
	MOVE	USER,GOGTAB		;THIS STUFF IS DEBUGGING
	MOVEI	LPSA,FRELST(USER)	;JUNK FOR CORGET AND FRIENDS

CPLUP:	HRRZ	LPSA,(LPSA)		;IT SHOULD BE INTUITIVELY
	JUMPE	LPSA,DUNNN		;OBVIOUS
	PRINT	<START = >
	OCTPNT	LPSA
	MOVE	TEMP,1(LPSA)
	ADDM	TEMP,TOTFRE
	PRINT	<  SIZE =  >
	OCTPNT	TEMP
	ADD	TEMP,LPSA
	PRINT	<  END =  >
	OCTPNT	TEMP
	TERPRI
	JRST	CPLUP

DUNNN:
	PRINT	<TOTAL FREE SIZE = >
	OCTPNT	TOTFRE
	SETOM	PRTCOR
	TERPRI
	CAMLE	THIS,JOBREL
	JRST	DUNMOR
	TERPRI	<THIS BLOCK: >
	PRINT	<"THIS" = >
	MOVE	TEMP,THIS
	OCTPNT	TEMP
	PRINT	<  C-SIZE = >
	HRRZ	TEMP,SIZ
	OCTPNT	TEMP
	CAML	THIS,JOBREL
	JRST	DUNMOR
	HRREI	LPSA,-2(THIS)
	JUMPLE	LPSA,DUNMOR
	PRINT	<  BLOCK-SIZE = >
	MOVN	TEMP,1(LPSA)
	OCTPNT	TEMP

DUNMOR:	TERPRI
	POP	P,LPSA
	TTCALL	11,
	TTCALL	TEMP
	TERPRI
	POPJ	P,

>

DSCR CORBIG
CAL PUSHJ
PAR NONE
RES LARGEST AVAILABLE BLOCK IN SIZ (3,C)
SID THIS (2,B) MUNGED
⊗

HERE(CORBIG) SKIPN	USER,GOGTAB
	CORERR	<CORBIG: INITIALIZED WORLD>
	MOVEI	SIZ,0	;"ZERO-LENGTH" BLOCK
	MOVEI	THIS,FRELST(USER)
BIGLUP:	HRRZ	THIS,(THIS)
	JUMPE	THIS,BIGDUN	;END OF FREELIST?
	CAMGE	SIZ,1(THIS)
	MOVE	SIZ,1(THIS)	;FIND MAX
	JRST	BIGLUP
BIGDUN:	SUBI	SIZ,3		;WHAT HE SEES
	POPJ	P,



Comment  ⊗ No other core routines should be necessary to provide
	gross control over allocation.  Programs obtaining
	space from CORGET can carve the blocks up if necessary.
	Please put your core back when you're done with it.

					Thank You,
					The Management

⊗
>;NOLOW
ENDCOM (COR)
IFN ALWAYS,<
BEND CORSER
>

COMPIL(SGC,<STRNGC,STRGC,STCLER,SGINS,SGREM,%SPGC1,%ARSR1>
	   ,<GOGTAB,X11,CORGET,CORREL,CORINC,X22,CORBIG,SPRPDA>
	   ,<STRING GARBAGE COLLECTOR ROUTINES>
	   ,<%SPGC,%STRMRK,%ARRSRT>)
;String Garbage Collector Routines 

NOLOW <			;INCLUDE IN UPPER SEGMENT.

BKSZ←←=25  BKOFF←←=23 MLT←←5


↑.CORERR:
	CORERR	<NO CORE FOR ALLOCATION>

DSCR STRGC(# chars desired);
CAL SAIL 
RES calls string garbage collector with #chars in -1(p)..i.e.a formal param.
⊗

HERE (STRGC)
	EXCH	A,-1(P)		;THE DESIRED A IS HERE
	MOVE	USER,GOGTAB
	MOVEM	RF,RACS+RF(USER);SAVE F REGISTER WHERE GC CAN FIND.
	PUSHJ	P,STRNGC	;COLLECT TRASH
	SUB	P,X22		;BACK UP STACK
	MOVNS	A
	ADDM	A,REMCHR(USER)
	MOVE	A,1(P)		;GET ORIGINAL "A" BACK
	JRST	2,@2(P)		;RETURN



DSCR STRNGC
CAL PUSHJ
PAR A -- number of new characters needed
 REMCHR(USER) -- has been updated by that number of chars
RES String space is compacted, new REMCHR is updated by C(A).
 Restarts if not enough room left
SID none
DES STRNGC is a two-pass process. In the first, all string descriptors
 are found and sorted into ascending sequence with respect to the locations
 of their respective texts.  String descriptors are found via the generating
 routines, described in CALSG. 
 	In the second pass, all string texts are moved down to fill any
 unused space. All descriptors are adjusted to reflect the new locations.
⊗

↑STRNGC: MOVE	USER,GOGTAB	;GET USER TABLE POINTER

	MOVEM	12,SGACS+12(USER)
	MOVEI	12,SGACS(USER)
	BLT	12,SGACS+11(USER)

;              →→→→→→ OBTAIN SPACE, INITIALIZE GARBAGE COLLECTOR ←←←←←←

	HRRZ	TEMP,TOPBYTE(USER) ;MAKE SURE DIDN'T OVERFLOW

; **** BUG TRAP
	CAMG	TEMP,STTOP(USER)
	CAMGE	TEMP,ST(USER)
	 ERR	 <DRYROT AT STRNGC>
; **** EBT

	SUB	TEMP,ST(USER)	;CREATE A DIVISOR FOR DISTRIBUTION
	ADDI	TEMP,5		; OF DESCRIPTORS DURING SGSORT
	MOVEM	TEMP,INKY(USER)
	SKIPE	XPAND(USER)	;ALLOWED TO EXPAND?
	 JRST	 INSIDE		; NO
	SETOM	ATTOP(USER)	;WANT BLOCK OFF THE TOP FOR SAFETY
	MOVEI	C,=400		;REASONABLE SIZE
	PUSHJ	P,CORGET	;IF CAN'T GET IT, TROUBLE
	SKIPA			;TRY TO GET WHAT YOU CAN
	JRST	CORROK		;GOT IT
INSIDE:	SETZM	ATTOP(USER)	;CAN'T EXPAND
	PUSHJ	P,CORBIG	;HOW MUCH CAN WE HAVE?
	PUSHJ	P,CORGET	;GET THAT AMOUNT
	ERR	<DRYROT - STRNGC CAN'T GET CORE>
CORROK:	SETZM	ATTOP(USER)	;NOW CAN GET ANYWHERE
	MOVEM	B,STBUCK(USER)	;SAVE → TO BLOCK
	SETZM	(B)
	HRLS	B
	ADDI	B,1
	MOVEI	TEMP,BKOFF(B)
	BLT	B,(TEMP)
	MOVE	B,STBUCK(USER)
	ADDI	B,BKSZ		;FIRST BKSZ WORDS IS "BUCKET" LIST
	MOVNI	C,-BKSZ(C)
	JUMPGE	C,.CORERR	;BAD THING
	HRL	B,C
	SUB	B,X11		;IOWD FOR WORD ALLOC IN STRNGC
	MOVEM	B,SGFRE(USER)	;FREE SPACE POINTER

	HRRZ	A,ST(USER)
	HRLI	A,(<POINT 7,0>)
	MOVEM	A,TOPBYTE(USER)		;FIRST(USER) NEW OK POSITION
	SETZM	NUMCHR(USER)		;TOTAL # CHARS PREVIOUSLY MOVED

;		→→→→→→  SORT THE STRINGS ←←←←←←←←←
DSCR CALSG
PAR linked list of routine addresses based at SGROUT(USER)
RES each routine in list is called to provide string descriptors
 to the sorting routine, SGSORT.
SID SGSORT uses B,C,D,E,TEMP, accepts input in A. Generating
 routines may use A-T1 (12) and TEMP for their own devices.
 Q1 through T1 will not be changed by calls on SGSORT.
DES Each generating routine should do the following:
 1) Place a string descriptor in A
 2) PUSHJ P,SGSORT or PUSHJ P,@-1(P) (addr provided on stack)
 3) Repeat the process if it knows about more strings, else return
 4) Return with a POPJ (and a flourish)

The `standard' generating routines are:
 SPSG -- collects the string stack
 STRMRK -- collects string variables linked through SGLINK(USER)
 ARRMRK -- collects string arrays found in ARRPDL
 RINGSORT -- collects PNAMES from semantic blocks in compiler
 DEFSRT -- collects saved input strings during macro recursion in compiller
These routines should provide sufficient examples.

⊗


CALSG:	MOVEI	T,SGROUT(USER)		;GET LINKED LIST OF ROUTINE NAMES
	PUSH	P,T			;SAVE FIRST POINTER
	PUSH	P,[SGSORT]		;PROVIDE ACCESS TO SORTING ROUTINE
↑CALSGL:
	SKIPN	T,@-1(P)		;GO DOWN LIST UNTIL DONE
	JRST	ALLCOL			;DONE
	HRRZM	T,-1(P)			;SAVE NEW POINTER
	PUSHJ	P,@-1(T)		;CALL GENERATOR ROUTINE
	JRST	CALSGL			;DO MORE THAN ONCE


;	     →→→→→→ SORT THE SP STACK ←←←←←←

HERE(%SPGC)	HRRZ	A,SPDL(USER)	;START AT BASE OF STACK
↑%SPGC1:ADDI	A,1
	JRST	SGTST		;AND WORK UP TO CURRENT POINTER
STRNGSTACKMARKLOOP:
	PUSHJ	P,SGSORT	;SORT IT INTO LIST
SGTST:
	CAIGE	A,(SP)		;DONE?
	 JRST	 STRNGSTACKMARKLOOP ;NO
GPOPJ:	POPJ	P,		;YES, GO ON TO NEXT TYPE

;      →→→→→→ SAIL COMPILER SPECIAL SORTERS ARE IN COMSER ←←←←←

; 	         →→→→→→ SORT THE VARIABLES ←←←←←←

HERE (%STRMRK)
	SKIPN	T,STRLNK(USER)	;GET LINK
	 POPJ	 P,		; NO STRINGS AT ALL
STMKL1:	HRRZ	A,-1(T)		;→1ST STRING
	HLRZ	Q2,-1(T)	;# STRINGS THIS PROC
	JRST	SOJLP		;GO LOOP
STMKLP:	
;	SKIPN	-2(T)		;PROCEDURE ACTIVE?
;	 SETZM	 (A)		; NO, MAKE NULL STRINGS

Comment ⊗ Due to certain social pressures (WFW LIVES ON)
	strings in inactive blocks remain over garbage collection  ⊗

	PUSHJ	P,SGSORT	;SORT VARIABLES INTO LIST
SOJLP:	SOJGE	Q2,STMKLP	;SORT UNTIL DONE WITH THIS PROC (SGSORT INCRS A)

STRMK4:	HRRZ	T,(T)		;NEXT PROCEDURE
	JUMPN	T,STMKL1	; IF THERE IS ONE
	POPJ	P,		;DONE


COMMENT ⊗
		→→→→→→  SORT STRING ARRAYS ←←←←←←


	THIS ROUTINE TRIPS DOWN THE DYNAMIC LINKS, LOOKING INTO
	PROCEDURE DESCRIPTORS FOR STRING ARRAYS WHICH MIGHT HAVE BEEN ALLOCATED.
	THEN IT LOOKS FOR ANY ARRAYS OWNED BY LEAP.  THE FIRST
	WORD OF EACH ARRAY BLOCK IS THE NUMBER OF DIMENSIONS IF THE
	ARRAY IS A STRING ARRAY. THE WORD JUST PREVIOUS TO IT IS THE
	(NEGATIVE) SIZE OF THE ARRAY.
⊗

INTERNAL %ARRSRT
HERE (%ARRSRT)
	HRRZ	RF,RACS+RF(USER);REAL RF WITH LH= 0
↑%ARSR1:
PROCDO:	HLRZ	Q1,1(RF)	;FETCH PDA
	CAIN	Q1,SPRPDA	;IS IT SPROUTER??
	POPJ	P,		;YES
	MOVE	Q1,PD.LLW(Q1)	;WE HAVE TO DO SOMETHING -- PT AT LVI
CHK:	SKIPN	T,(Q1)		;GET ENTRY
	JRST	GODOWN		;0 MEANS OF PROC DESCR
;;#HI#↓ 5-15-72 DCS WAS TESTING 200000 (TYPE 4?) BIT, WRONG BIT!
	TLC	T,100000	;TYPE 2? (STRING ARRAY)
	TLNE	T,740000	;
	AOJA	Q1,CHK		;NO
	SKIPN	A,@T		;THERE??
	AOJA	Q1,CHK		;NO
;;#  # 5-3-72 DCS
	SUBI	A,1		;A→2D WORD, FIRST ENTRY -- DCS 5-3-72
;;#  #
	SKIPL	Q2,-1(A)	;BETTER BE THERE
	ERR	<DRYROT AT ARRSRT>
	PUSHJ	P,ARPUTX	;GO SORT IT
	AOJA	Q1,CHK

GODOWN:	HRRZ	RF,(RF)		;NOTE THAT RESTR WILL PUT RF BACK
	CAIE	RF,-1		;
	JRST	PROCDO 		;-1 WILL SAY END


LARR:	SKIPN	T1,ARYLS(USER)	;LEAPING LISTS
	POPJ	P,		;NONE
LAR1:	
	HLRZ	Q2,(T1)		;GET ADDRESS
;;#  # 5-3-72 DCS SET UP A
	MOVEI	A,-1(Q2)	;A→1ST WORD, FIRST ENTRY
;;#  #
	SKIPL	Q2,-2(Q2)		;BE SURE
	ERR	<LEAPING DRYROT AT ARRSRT>
	PUSHJ	P,ARPUTX	;GO SORT IT

LAR2:	HRRZ	T1,(T1)		;MERRILY WE LINK ALONG
	JUMPN	T1,LAR1		;
	POPJ	P,		;HOME AT LAST

ARPUTX:	
	HRRZS	Q2		;YES, GET TOTAL SIZE
	LSH	Q2,-1		;NUMBER OF STRINGS

	JRST	ARSLP


ARS3:	
	 PUSHJ	 P,SGSORT	; BUT COLLECT NON-CONSTANTS 
ARSLP:	SOJGE	Q2,ARS3		;A INCREMENTED IN SGSORT, LOOP UNTIL DONE
	POPJ	P,		;ALL DONE WITH THIS ARRAY.

;  SUBROUTINE ENTERED WITH A → A STRING DESCRIPTOR.  CONVERTS
;  IT TO GARBAGE COLLECTOR FORMAT.  USES B, C.D,E,TEMP
;  START CONTAINS FIRST #CHARS FOR BEGINNING OF STRING SPACE.
; WARNING ***** CLOBBERS B,C,D,E,TEMX  **********

SGSORT:	

	HLLZ	B,(A)		;GET STRING NUMBER
	JUMPE	B,SGSRT		; DON'T COLLECT CONSTANTS OR NULL STRINGS

	HRRZ	D,1(A)		;MAKE SURE STRING IN RANGE
	HRRE	C,(A)		;CHECK LENGTH CONSISTENCY

; *** BUG TRAP
	JUMPE	C,DONBUG 	;DON'T WORRY MUCH ABOUT NULL STRINGS
	JUMPL	C,BUGG
	CAMG	D,STTOP(USER)
	CAMGE	D,ST(USER)
BUGG:	 ERR	 <DRYROT AT SGSORT>,1
DONBUG:
; *** EBT

	HLLZ	B,1(A)		;GET POINTER AND SIZE FIELDS OF BP
	HRRI	B,[BYTE (7) 0,1,2,3,4,5]
	ILDB	B,B		;#CHARS REPRESENTED BY POINTER
				;C HAS ADDR FILED OF BP (SEE ABOVE)
	SUB	D,ST(USER)		; - STRING SPACE BASE
	IMULI	D,5		;#CHARS
	ADD	B,D		; + CHARS IN POINTER
	MOVEM	B,1(A)		; TO BP WORD
	ADD	C,B		; + #CHARS FIELD (D LOADED ABOVE)
	HRRZM	C,(A)		;TO #CHARS WORD
	MOVE	D,B		;NOW DISTRIBUTE STRING TO PROPER
	IMULI	D,MLT		; LIST TO SPEED SORT
	IDIV	D,INKY(USER)	; SEE ABOVE FOR INKY CALC
	ADD	D,STBUCK(USER)	;D→PROPER "BUCKET" ENTRY

; *** BUG TRAP
	MOVE	TEMP,STBUCK(USER)
	CAML	D,TEMP
	CAIL	D,BKSZ(TEMP)
	 ERR	 <DRYROT AT SGSLUP>,1
; *** EBT


;  A→ STRING DESCRIPTOR (MARKED)  -- D→BUCKET LIST THIS STRING
;  B IS START COUNT [=1(A)] -- C IS END COUNT [=(A)]

SGSLUP:	MOVE	E,D		;E←CDR(E), IN FACT
	HRRZ	D,(E)		;D←CDR(E)
	SKIPN	D		;DONE?
	JRST	INSERT		; YES, INSERT AT END
	HLRZ	TEMP,(D)	;TEMP←CAR(D)
	CAMGE	B,1(TEMP)	;NEW START LESS?
	JRST	INSERT		;YES, INSERT THIS ONE IN FRONT OF IT
	CAME	B,1(TEMP)	;NEW START SAME?
	JRST	SGSLUP		;NO, GREATER

; EQUAL START COUNTS, ARRANGE BY END COUNT, DESCENDING SEQUENCE

	CAMG	C,(TEMP)	;NEW END GT OLD?
	JRST	SGSLUP		;NO, CONTINUE
;	(JRST	INSERT)		;YES

INSERT:
	MOVE	TEMP,SGFRE(USER)
	AOBJN	TEMP,STILMOR	;EXPAND LINK SPACE
SGXPND:	
	PUSH	P,TEMP
	MOVE	B,STBUCK(USER)	;→CURRENT FWS BLOCK
	MOVEI	C,=100		;GET 100 MORE
	PUSHJ	P,CORINC	;EXPAND THE BLOCK
	 ERR	<NO CORE FOR ALLOCATION>
	POP	P,TEMP
	SUB	TEMP,[(100)]	;THERE IS MORE

STILMOR:
	MOVEM	TEMP,SGFRE(USER)
	HRLM	A,(TEMP)
	HRRM	D,(TEMP)
	HRRM	TEMP,(E)
SGSRT:	ADDI	A,2		;AUTO-INDEXING
	POPJ	P,

;  FIND A DISJOINT STRING GROUP, MOVE IT BACK.
;  MARK POINTERS APPROPRIATELY.

ALLCOL:	SUB	P,X22		;REMOVE JUNK PUT ON BY CALSG

SGSWEP:
	SETZB	T,T1		;IN CASE NO STRINGS AT ALL
	MOVEI	Q2,1		;INIT STRING NO.
	MOVE	Q3,STBUCK(USER) ;WORK UP BUCKET LIST, HANDLING
	MOVEI	FF,BKSZ(Q3)	;EVERYTHING IN THE PATH
	SUBI	Q3,1
	PUSHJ	P,FSTSTR	;A→FIRST LIST
	HLRZ	Q1,(A)		;Q1 → FIRST MARKED DESCRIPTOR
	JRST	SGFX1		;JUMP INTO THINGS

SGFIX:	PUSHJ	P,NXTSTR	;A→NEXT LIST ELEMENT
	HLRZ	Q1,(A)		;Q1 → NEXT DESCRIPTOR
	CAMG	T1,1(Q1)	;INCLUDED IN OR OVERLAPPING THIS STRING
	 JRST	 SGBLT		; NO, MOVE OLD BEFORE HANDLING NEW
	PUSHJ	P,FIXPTR	;FIX UP DESCRIPTOR
	CAMGE	T1,TEMP		;OVERLAPPING STRING
	 MOVE	 T1,TEMP	; YES, USE BIGGER END POINT
	JRST	SGFIX		;CONTINUE

SGBLT:	ADDI	Q2,1		;INCREMENT STRING NUMBER
	MOVN	B,T
	ADD	B,T1		;TOTAL STRING SIZE
	SKIPN	SGLIGN(USER)	;HAVE TO ALIGN TO FW BDRY?
	 JRST	 NOLIGN		; NO
	ADDI	B,4		;YES, DO IT
	IDIVI	B,5
	IMULI	B,5		;NOW MULT OF 5 CHARS, BIG ENOUGH
NOLIGN:
	ADDM	B,NUMCHR(USER)	;NUMBER USED SO FAR
	MOVE	C,T		;STARTING COUNT FOR STRING
	PUSHJ	P,MKBPT		;PICK UP FROM HERE
	MOVE	T,TOPBYTE(USER) ;PUT DOWN HERE
	JUMPE	B,SGBLT1	;DON'T DO IT IF NOT NECESSARY
BLTLUP:	ILDB	D,C
	IDPB	D,T		;WHEEE!
	SOJG	B,BLTLUP	;MOVE 'EM ON OUT
	MOVEM	T,TOPBYTE(USER)	;RESTORE IT

SGBLT1:	JUMPE	A,STSTAT	;LAST ONE
SGFX1:	MOVE	T,1(Q1)		;INITIALIZE START OF STRING,
	MOVE	T1,(Q1)		; END OF STRING,
	MOVE	E,T		; OFFSET FOR BP FIXUPS
	SUB	E,NUMCHR(USER)	; (THIS IS THE OFFSET)
	PUSHJ	P,FIXPTR	;FIX UP THIS DESCRIPTOR
	JRST	SGFIX		;CONTINUE

NXTSTR:	HRRZ	A,(A)		;A←CDR(A)
	JUMPN	A,APOPJ		; GOT ONE, DONE
FSTSTR:	AOS	A,Q3		;END OF THAT LIST, LOOK AT NEXT
	CAMGE	A,FF		;OOOPS, THERE ARE NO MORE!
	 JRST	 NXTSTR		; YES THERE ARE
	SUB	P,X11		;DON'T RETURN, BUT MARK DONE,
	MOVEI	A,0		; AND GO OFF FOR LAST 
	JRST	SGBLT		; NOSTALGIC MOVE

FIXPTR:	MOVE	TEMP,(Q1)
	SUB	TEMP,1(Q1)		;SIZE OF STRING FOR THIS DESCRIPTOR
	HRL	TEMP,Q2		;ADD STRING NUMBER
	EXCH	TEMP,(Q1)		;PUT FIRST WORD AWAY
	MOVE	C,1(Q1)		;START COUNT
	SUB	C,E		;ADJUST TO NEW LOCATION
	PUSHJ	P,MKBPT		;MAKE A BYTE POINTER
	MOVEM	C,1(Q1)		;THIS BABY IS READY TO FLY!
APOPJ:	POPJ	P,		;ALL DONE

; MKBPT TAKES A #CHARS IN C, MAKES A BYTE POINTER RELATIVE TO ST
; OUT OF IT, LEAVES IT IN C -- DESTROYS D

MKBPT:	IDIVI	C,5		;WORD # IN C, CHAR OFLOW IN D
	ADD	C,ST(USER)		;REAL WORD #
	HLL	C,[POINT 7,0
		   POINT 7,0,6
		   POINT 7,0,13
		   POINT 7,0,20
		   POINT 7,0,27](D)  ;POINTER PART
	POPJ	P,

; FINISH UP

STSTAT:	
	SKIPN	SGLIGN(USER)	;HAVE TO LINE UP TOPBYTE?
	 JRST	 NORCLR		;NO
	MOVE	C,T1		;END CHAR # OF LAST STRING
	SUB	C,E		;ADJUST BY THE WINNING OFFSET
	PUSHJ	P,MKBPT		;MAKE A BP FOR TO BE TOPBYTE
	MOVEM	C,TOPBYTE(USER)	;FOR THE RIDICULOUS, DEMANDING SAIL
	PUSHJ	P,RESCLR	;CLEAR REST OF STRING SPACE
;;#GI# DCS 2-5-72 REMOVE TOPSTR
NORCLR:	AOS	SGCCNT(USER)
	MOVN	B,STMAX(USER)
	IMULI	B,5
	ADD	B,NUMCHR(USER)
;;#GI# DCS 2-2-72 (2-3) LEAVE SOME SLOP SO ONE NEEDN'T FEAR INSET
	ADDI	B,=15		;SOME SLOP
	ADD	B,SGACS+A(USER)	;#CHARS WHICH CAUSED THIS MESS IN FIRST PLACE
	MOVEM	B,REMCHR(USER)
;;#GI (2-3)
	JUMPGE	 B,[ERR (<STRING SPACE EXHAUSTED, WILL RESTART>,1)
		    JRST @JOBREN]  ;RE-ALLOCATE
	MOVE	B,STBUCK(USER)	;RELEASE IT
	PUSHJ	P,CORREL
	HRLZI	12,SGACS(USER)
	BLT	12,12
	POPJ	P,


COMMENT ⊗Sgins, Sgrem ⊗

DSCR SGINS
CAL PUSHJ
PAR PUSH P,[routine name]
 PUSH P,[addr of 2-word block]
RES block is used to place routine in the list of descriptor generators
 for CALSG.
SID stack adjusted
⊗

↑↑SGINS:
	PUSH	P,-2(P)		;ADDR OF ROUTINE
	PUSHJ	P,SGREM		;NEVER LET IT BE IN TWICE
	MOVE	USER,GOGTAB
	POP	P,UUO1(USER)
	POP	P,LPSA		;→LINK BLOCK FOR NEW ROUTINE
	POP	P,-1(LPSA)	;PUT ROUTINE ADDRESS AWAY
	HRL	LPSA,SGROUT(USER);GET OLD LINK POINTER
	HLRM	LPSA,(LPSA)	;PUT IN NEW LINK POSITION
	HRRM	LPSA,SGROUT(USER);PUT NEW POINTER IN LINK HEAD
	JRST	@3(P)		;RETURN

DSCR SGREM
CAL PUSHJ
PAR PUSH P,[routine addr]
RES routine is removed from list of descriptor generators, if it was on it
⊗

↑↑SGREM:
	MOVE	USER,GOGTAB
	POP	P,UUO1(USER)
	POP	P,TEMP		;ADDR TO BE REMOVED
	MOVEI	LPSA,SGROUT(USER);HEAD OF LIST
SGRL:	MOVE	USER,LPSA	;PREV←THIS
	SKIPN	LPSA,(USER)	;THIS←(PREV)
	 JRST	 @2(P)		;DIDN'T FIND IT
	CAME	TEMP,-1(LPSA)	;IS THIS THE ROUTINE?
	 JRST	 SGRL		;NO, GET NEXT
	HRRZ	TEMP,(LPSA)	;YES, REMOVE IT FROM LIST
	HRRM	TEMP,(USER)
	JRST	@2(P)


DSCR STCLER
CAL PUSHJ
RES Clears all string variables on STRLNK(USER) to null strings
DES compiler only
⊗

↑STCLER:
	SKIPE	SGLIGN(USER)		;CLEAR REST?
	PUSHJ	P,RESCLR	;CLEAR REST OF STRING SPACE
	SKIPN	T,STRLNK(USER)	;PARALLELS STRNGC'S LOOP
	POPJ	P,		;CLOSELY
	PUSH	P,B		;JUST IN CASE
	HRLZI	B,-1		;FOR TESTING STRING NO.
STC1:	HRRZ	A,-1(T)
	HLRZ	Q2,-1(T)
STCLLP:	SOJL	Q2,STCLD1
	TDNE	B,(A)		;DON'T COLLECT STRING CONSTANTS
	SETZM	(A)
	ADDI	A,2
	JRST	STCLLP
STCLD1:	;SETZM	-2(T)		;***** CAN'T DO THIS UNLESS PATSW IS
				; *** ON IN COMPILER!!!!!
	HRRZ	T,(T)
	JUMPN	T,STC1
	POP	P,B
	POPJ	P,

DSCR RESCLR
CAL PUSHJ 
DES Used after STRNGC. Clears remaining string space to 0 (compiler only)
⊗
RESCLR:	SKIPL	A,TOPBYTE(USER)	;CAN ZERO FIRST WORD IF 440700
	ADDI	A,1		;ELSE START AT NEXT
	SETZM	(A)
	HRLS	A
	ADDI	A,1		;BLT WORD
	MOVE	B,STTOP(USER)	;END OF STRING SPACE
	BLT	A,-1(B)		;ZERO!!
	POPJ	P,

INTERNAL BRKMSK
↑BRKMSK:	0
	FOR @& JJ←=17,0,-1 <
	<1 ⊗ (JJ+=18)> + (1 ⊗ JJ)>
>;NOLOW
ENDCOM (SGC)
IFN ALWAYS,<
NOLOW <
	↑CORGET←CORGET
>;NOLOW
>;IFN ALWAYS
SUBTTL	GOGOL
SUBTTL	Some Runtime Routines Which Could Go Nowhere Else

DSCR BEGIN GOGOL
DES RUN-TIME ROUTINES WILL BE DESCRIBED BY SAIL MANUAL CALLING SEQUENCES ONLY
⊗
NOLOW <
IFN ALWAYS,<BEGIN GOGOL>
>;NOLOW
COMPIL(KNT,<K.ZERO,K.OUT>,<GETCHAN,GOGTAB>
      ,<K.ZERO, K.OUT -- PERFORMANCE COUNTING ROUTINES>)
COMMENT ⊗ Kounter Routines⊗
DSCR K.ZERO -- Zero out counters
CAL PUSHJ  P,K.ZERO
RES The counter arrays of the sail program loaded are  set  to  zero.
K.ZERO  determines  the location of the counter blocks via the loader
link chain (5) whose head is in the location KNTLNK(USER).  If  there
are  no  counters,  the  routine  is  essentially  a  NO-OP.  SID All
registers used by K.ZERO are saved on entry and restored on exit. SEE
K.OUT
⊗

HERE(K.ZERO)
	PUSH	P,2		;SAVE REGISTER 2
	MOVE	USER,GOGTAB
	SKIPN	2,KNTLNK(USER)	;GET LINK TO COUNTERSS
	JRST	K.ZR2		;THERE ARE NONE
	PUSH	P,3		;SAVE OTHER REGS NEEDED
	PUSH	P,4
	PUSH	P,5
K.Z1:	MOVE	3,2(2)		;GET SECOND IOWD OF HEADER BLOCK
	MOVEI	4,2(3)		;GET <.KOUNT+1>
	HRLI	4,-1(4)		;GET READY FOR BLT
	HLRO	5,3		;GET -COUNT
	MOVN	5,5		;MAKE THAT +COUNT
	HRLI	5,3		;PUT AN INDEX FIELD OF 3
	SETZM	-1(4)		;ZERO THE FIRST COUNTER
	BLT	4,@5		;ZERO THE REST
	SKIPE	2,(2)		;GET THE NEXT SET OF COUNTERS
	JRST	K.Z1		;ZERO THEM
	POP	P,5		;RESTORE THE REGISTERS
	POP	P,4
	POP	P,3
K.ZR2:	POP	P,2
	POPJ	P,		;RETURN

DSCR K.OUT -- Write out counters
CAL PUSHJ P,K.OUT
RES The values of the statement counters are written out to the
 disk.  The IOWDs used to write them are also written out in
 order to be able to know how many to read back in.  The filename
 is obtained from the header block of the first program loaded.
 The data blocks have the following form:

		--------------------------
		|   SIXBIT /FILNAM/	 |
		--------------------------
		|   LINK to other blocks |
		--------------------------
		|   IOWD  1,.+1		 |
		--------------------------
		|   IOWD  n,.KOUNT	 |
		--------------------------
		|   0			 |
		--------------------------
    .KOUNT:	|   1st counter		 |
		--------------------------
		|   . . .		 |

		|   . . .		 |
		--------------------------
		|   nth counter		 |
		--------------------------

SID No registers are permanently modified.
⊗
HERE(K.OUT)
	MOVE	USER,GOGTAB
	SKIPN	KNTLNK(USER)	;ARE THERE ANY COUNTERS
	POPJ	P,		;NO


COMMENT	⊗	First save registers 0-16
⊗

	MOVEM	16,17(P)	;SAVE IN THE STACK
	MOVEI	16,1(P)		;GET READY TO STORE 0-15
	BLT	16,16(P)	;DO IT
	ADD	P,[XWD 17,17]	;ADJUST STACK POINTER
	TLNN	P,400000	;CHECK FOR OVERFLOW
	ERR	<PDL overflow in K.OUT routine>


COMMENT ⊗	Before the counters can be written out, it
	is necessary to chain the blocks together in the
	proper direction.  Recall that there will be multiple
	blocks only if the core image is the result of loading
	multiple compilatons.
⊗

	MOVE	2,KNTLNK(USER)	;GET LINK TO LAST BLOCK
	SKIPN	1,(2)		;GET LINK TO PREV.
	JRST	.+5		;THAT'S ALL
	MOVEI	0,1(2)		;GET ADDR OF 1st IOWD OF THIS BLOCK
	MOVEM	0,3(1)		;STORE BELOW 2nd IOQS OF PREV BLOCK
	MOVE	2,1		;CONTINUE
	JRST	.-5


COMMENT ⊗	At this point, 1(2) contains the start of a dump
	mode command chain that will write out all of the counters.
	-1(2) contains the filename for the counter file.
⊗

	PUSHJ	P,GETCHAN	;GET AN AVAILABLE CHANNEL
	JUMPL	1,K.OERR	;NONE AVAILABLE
	MOVE	0,[XWD K.OD1,3] ;MOVE CODE TO REGISTERS
	BLT	0,16		;SO THAT IT CAN BE SAFELY MODIFIED
	DPB	1,[POINT 4,3,12]  ;STORE CHANNEL NUMBER IN OPEN INSTR
	DPB	1,[POINT 4,5,12]  ;STORE CHANNEL NUMBER IN ENTER INSTR
	MOVE	10,-1(2)	;PICK UP FILE NAME
	JRST	3		;OPEN AND ENTER,HOPEFULLY RETURNING TO .+1
K.O1:	MOVE	0,[XWD K.OD2,3] ;DO IT AGAIN
	BLT	0,7
	DPB	1,[POINT 4,3,12]  ;OUT INSTRUCTION
	DPB	1,[POINT 4,6,12]  ;RELEAS INSTRUCTION
	JRST	3


COMMENT ⊗	The counters have been written out to the disk.  It's
	time to restore the registers and go home.
⊗

K.O2:	MOVSI	16,-16(P)	;PREPARE TO RESTORE REGS 
	BLT	16,16		; FROM THE STACK
	SUB	P,[XWD 17,17]	;ADJUST STACK POINTER
	POPJ	P,		;RETURN

K.OERR:	IOERR	<I/O error in writing counter file>


COMMENT ⊗	The following instructions are moved into 
	registers before they are executed, since the "channel"
	portion of them must be modified at run time.
⊗

K.OD1:	OPEN	0,14		;(3) OPEN DISK ON SPECIFIED CHANNEL
	JRST	K.OERR		;(4) TROUBLE
	ENTER	0,10		;(5)
	JRST	K.OERR		;(6) RIGHT HERE IN RIVER CITY
	JRST	K.O1		;(7) READY TO WRITE 'EM OUT
	0			;(10) FILLED IN WITH FILE NAME
	SIXBIT 	/KNT/		;(11) EXTENSION
	0			;(12)
	0			;(13)
	17			;(14) DUMP MODE
	SIXBIT	/DSK/		;(15) DEVICE DISK
	0			;(16) NO BUFFERS

K.OD2:	OUT	0,1(2)		;(3) WRITE OUT COUNTERS
	JRST	6		;(4) ALL OK
	JRST	K.OERR		;(5) PROBLEMS
	RELEAS	0		;(6) CLOSE FILE
	JRST	K.O2		;(7) GO BACK TO K.OUT

ENDCOM (KNT)
COMPIL(POW,<FPOW,POW,LOGS,FLOGS>,<X11,X33>,<POW, FPOW, LOGS, FLOGS -- EXPON. ROUTINES>)


DSCR BEGIN UTILS
⊗
IFN ALWAYS,<	BEGIN	UTILS>
COMMENT % EXPONENTIATION CODE

	FPOW COMPUTES
	REAL←FPOW(REAL!BASE,INTEGER!EXPONENT)

	POW COMPUTES
	REAL←POW(INTEGER!BASE,INTEGER!EXPONENT)

%

DSCR POW, FPOW, LOGS, FLOGS(EXPONENT,ARGUMENT).  BOTH RETURN REALS.
SID  CLOBBERS LPSA,TEMP,USER
CAL SAIL
DES CALLS GENERATED BY COMPILER FOR ↑ OPERATOR
⊗

COMMENT !
	USER HAS THE BASE
	LPSA HAS THE EXPONENT
	TEMP HAS THE RESULT

	!

HERE(FPOW)
	MOVE 	USER,-1(P)		;BASE
	SKIPGE 	LPSA,-2(P)	;EXPONENT -- IS IT NEGATIVE
	   MOVN	LPSA,LPSA	;NEGATE IT
	JUMPE	LPSA,EXZERO	;0 EXPONENT
	MOVSI	TEMP,(1.0)	;SET FOR FLOATING	
	JRST	2,.+1		;CLEAR AR FLAGS

FEXLUP:
	TRNE 	LPSA,1		;COLLECT PRODUCT?
	FMPR	TEMP,USER	;YES
	  JOV	FPOWOV		;OVERFLOW?
	ASH	LPSA,-1		;PREPARE TO LOOK AT NEXT BIT
	JUMPE	LPSA,FEXDUN	;ALL DONE IF ZERO
	FMPR	USER,USER	;SQUARE BASE
	  JOV	FPOWOV		;OVERFLOW?
	JRST	FEXLUP

FEXDUN:
	SKIPGE	-2(P)		;POSITIVE EXPONENT?
	   JRST	FEXDU1
EXDUN:	MOVE	A,TEMP
POWRET: SUB	P,X33
	JRST 	@3(P)

EXZERO:
	SKIPN	USER		;0↑0
	  ERR	<0↑0 NOT DEFINED>,1
	MOVSI	A,(1.0)		;RETURN FLOATING 1
	JRST 	POWRET


FEXDU1:
;MUST TAKE RECIPROCAL OF TEMP
	MOVSI	A,(1.0)
	FDVR	A,TEMP		;TAKE RECIPROCAL	
	JRST 	POWRET		;RETURN		

FPOWOV:
;ON AN OVERFLOW, WE FLOAT THE ARGUMENTS AND ATTEMPT
;TO USE THE FLOATING ROUTINES
	PUSH	P, B		;SAVE B
	MOVE	A,-2(P)		;BASE (ALREADY REAL)
	FLOAT	B,-3(P)		;EXPONENT
	PUSH	P,C		;SAVE C AND D
	PUSH	P,D
	JRST	 TRYFL		;TRY THE FLOATING ARITHMETIC


HERE(POW)
	MOVE	USER,-1(P)	;BASE
	SKIPGE	LPSA,-2(P)	;EXPONENT -- IS IT NEGATIVE	
	   MOVN	LPSA,LPSA	;NEGATE IT
	JUMPE	LPSA,EXZERO	;ZERO EXPONENT
	MOVEI	TEMP,1		
	JRST	2,.+1		;CLEAR AR FLAGS
EXPLUP:
	TRNE	LPSA,1
	IMUL	TEMP,USER
	  JOV	POWOV  		;OVER (UNDER) FLOW
	ASH	LPSA,-1	
	JUMPE	LPSA,FLORET		;ARE WE DONE?
	IMUL	USER,USER
	  JOV	POWOV		;OVER (UNDER) FLOW
	JRST	EXPLUP


FLORET:
	IDIVI	TEMP,1B18
	SKIPE	TEMP
	TLC	TEMP,254000
	TLC	USER,233000
	FAD	TEMP,USER		;FLOATED RESULT IN TEMP
	SKIPGE	-2(P)			;POSITIVE EXPONENT?
	  JRST	FEXDU1			;NO
	JRST	EXDUN			;YES -- RETURN

POWOV:	
	PUSH	P,B			;SAVE B
	FLOAT	A,-2(P)			;BASE
	FLOAT	B,-3(P)			;EXPONENT	
	PUSH	P,C			;SAVE C AND D
	PUSH	P,D
	JRST	TRYFL


;REAL←LOGS(INTEGER_BASE,REAL_EXPONENT)
HERE(LOGS)
	PUSH 	P, B			;SAVE B
	MOVE	A,-2(P)			;BASE
;DO FLOAT INLINE
	IDIVI	A,1B18
	SKIPE	A
	TLC	A,254000
	TLC	B,233000
	FAD	A,B

	MOVE	B,-3(P)			;EXPONENT
	JRST	FLOGS1			;DO IT

;REAL←FLOGS(REAL_BASE,REAL_EXPONENT)

HERE(FLOGS)
	PUSH	P, B
	MOVE	A,-2(P)		;BASE
	MOVE	B,-3(P)		;EXPONENT
	JUMPE	B, FLZERO	;EXIT IF EXPONENT IS ZERO
FLOGS1:	PUSH	P, C		;SAVE MORE ACS
	PUSH	P, D

	
;;;    	JUMPE	A, FLZERO	;EXIT IMMEDIATELY IF BASE IS ZERO

	SKIPGE	D,B		;IS EXPONENT NEG. ?
	MOVNS	D		;YES,MAKE IT POSITIVE
	MOVEI	C,0		;CLEAR AC C TO ZERO
	LSHC	C,11		;SHIFT 9 PLACES LEFT
	SUBI	C,200		;TO OBTAIN SHIFTING FACTOR
	JUMPLE	C,EXP3GO	;IS C > 0

	PUSH	P,E		;SAVE E
	HRR	E,C		;SET UP E AS AN INDEX REG.
	MOVEI	C,0		;CLEAR OUT AC C
	LSHC	C,(E)		;SHIFT LFT BY CONTENTS OF E
	POP	P,E		;RESTORE E

	JUMPN	D,EXP3GO	;IS EXPONENT AN INTEGER ?
	SKIPGE	B		;YES, WAS  IT NEG. ?
	MOVNS	C		;YES, NEGATE IT
	PUSH	P, B		;SAVE IT IN CASE WE NEED IT LATER
	MOVE	B,C		;MOVE INTEGER INTO B
	PUSHJ	P,EXP2.0	;OBTAIN RESULT USING EXP2.0
	SUB	P, X11		;REMOVE B FROM STACK
	JRST	EXP3A 		;
EXP3GO:	
;ARGUMENT IS IN A
TRYFL:	PUSHJ	P,ALOG		;CALCULATE LOG OF A
	FMPR	A, B		;CALCULATE B*LOG(A)
;ARGUMENT IS IN A
	PUSHJ	P,EXP		;CALCULATE EXP(B*LOG(A))

;RESULT IS IN A
EXP3A:	POP	P, D
	POP	P, C
	POP	P, B
	SUB	P, X33
	JRST	@3(P)

FLZERO:
	SKIPN	A		;0↑0?
	  ERR <0↑0 NOT DEFINED>,1
	POP	P,B		;RESTORE B
	MOVSI	A,(1.0)		;
	JRST	POWRET		;RETURN


COMMENT !
	EXP2.0 TAKES AS ARGUMENTS:
	A	REAL
	B	INTEGER

	A↑B IS RETURNED IN A AS A REAL
	!
OPDEF JRSTF [JRST 2,]		;IS THIS REALLY UNDEFINED IN FAIL?

EXP2.0:	JUMPE	A, BASEZ	;TREAT CASE OF A ZERO BASE
	PUSH	P, C		;SAVE AC C
	MOVSI	C, 201400	;GET 1.0 IN ACCUMULATOR C

	JRSTF	@[XWD 0,.+1]	;CLEAR AR FLAGS
	JUMPGE	B, GFEXP2	;IS EXPONENT POSITIVE?
	MOVMS	B		;NO, MAKE IT POSITIVE
	PUSHJ	P, FEXP2	;CALL MAIN PART OF PROGRAM
	MOVSI	B, 201400	;GET 1.0 IN B
	FDVM	B, A		;FORM 1/(A**B) FOR NEG. EXPONENT
RETEX2:
	POP	P, C		;RESTORE C
	POPJ	P,		;EXIT

GFEXP2: PUSHJ	P,FEXP2		;CALL FEXP2
	JRST	RETEX2		;RETURN

FEXP1:	FMP	A, A		;FORM A**N, FLOATING POINT
	LSH	B, -1		;SHIFT EXPONENT FOR NEXT BIT
FEXP2:	TRZE	B, 1		;IS THE BIT ON?
	FMP	C, A		;YES, MULTIPLY ANSWER BY A**N
	JOV	OVERF		;TRANSFER ON OVER (UNDER) FLOW
	JUMPN	B, FEXP1	;UPDATE A**N UNLESS ALL THROUGH
FEXP3:	MOVE	A, C		;PICK UP RESULT FROM C
FEXP4:	POPJ	P,		;EXIT

BASEZ:	SKIPN	B		;IS THE EXPONENT ALSO ZERO?
	  ERR <0↑0 NOT DEFINED>	
	MOVSI	A,(1.0)		;1.0
	POPJ	P,

COMMENT ! ROUTINE FOR OVERFLOW.
	This overflow trap occurs when we have tried to
use EXP2.0.  Instead, we will try to compute using logarithms.


	!

OVERF:
	SUB	P, X11		;REMOVE RETURN ADDRESS
	POP	P, C		;RESTORE C
	SUB	P, X11		;REMOVE RETURN FROM EXP2.0
	POP	P, B		;GET BACK REAL EXPONENT
	JRST	TRYFL		;GO TRY FLOATING




;FLOATING POINT SINGLE PRECISION EXPONENTIAL FUNCTION
;THE ARGUMENT IS RESTRICTED TO THE FOLLOWING RANGE
;	-88.028<X<88.028
;IF X<-88.028, THE PROGRAM RETURNS ZERO AS THE ANSWER
;IF X<88.028, THE PROGRAM RETURNS X AS THE ANSWER
;THE RANGE OF THE ARGUMENT IS REDUCED AS FOLLOWS:
;EXP(X) = 2**(X*LOG(E)BASE2) = 2**(M+F)
;WHERE M IS AN INTEGER AND F IS A FRACTION
;2**M IS CALCULATED BY ALGEBRAICALLY ADDING M TO THE EXPONENT
;OF THE RESULT OF 2**F. 2**F IS CALCULATED AS

;2**F = 2(0.5+F(A+B*F↑2 - F-C(F↑2 + D)**-1)**-1

;THE ROUTINE HAS THE FOLLOWING CALLING SEQUENCE:
;	ARG IS IN ACCUMULATOR A
;	PUSHJ	P,EXP
;THE ANSWER IS RETURNED IN ACCUMULATOR A

EXP:
	PUSH	P, B		;SAVE B
	MOVE	B, A 		;PICK UP THE ARGUMENT IN B
	MOVM	A, B		;GET ABSF(X)
	CAMG	A, E7		;IS ARGUMENT IN PROPER RANGE?
	JRST	EXP1		;YES, GO TO ALGORITHM
;NON-FATAL MESSAGE
	ERR <EXPONENTIATION UNDER OR OVERFLOW>,1
	HRLOI	A, 377777	;GET LARGEST FLOATING NUMBER
	SKIPG	B		;WAS THE ARGUMENT POSITIVE?
	MOVEI	A, 0		;NO, RETURN 0
	POP	P, B		;RESTORE B
	POPJ	P,		;RETURN



EXP1:	PUSH	P, C		;SAVE ACCUMULATOR C
	PUSH	P, D		;SAVE ACCUMULATOR D
	PUSH	P, E		;SAVE E
	PUSH	P, LPSA 	;SAVE LPSA
	SETZB	E, LPSA 	;INITIALIZE E, TBITS
	MULI	B, 400		;SEPARATE FRACTION AND EXPONENT
	TSC	B, B		;GET A POSITIVE EXPONENT
	MUL	C, E5		;FIXED POINT MULTIPLY BY LOG2(E)
	ASHC	C, -242(B)	;SEPARATE FRACTION AND INTEGER
	AOSG	C		;ALGORITHM CALLS FOR MULT. BY 2
	AOS	C		;ADJUST IF FRACTION WAS NEGATIVE
	HRRM	C, LPSA 	;SAVE FOR FUTURE SCALING
	ASH	D, -10		;MAKE ROOM FOR EXPONENT
	TLC	D, 200000	;PUT 200 IN EXPONENT BITS
	FADB	D, E  		;NORMALIZE, RESULTS TO D AND E
	FMP	D, D		;FORM X↑2
	MOVE	A, E2		;GET FIRST CONSTANT
	FMP	A, D		;E2*X↑2 IN A
	FAD	D, E4		;ADD E4 TO RESULTS IN D
	MOVE	B, E3		;PICK UP E3
	FDV	B, D		;CALCULATE E3/(F↑2 + E4)
	FSB	A, B		;E2*F↑2-E3(F↑2 + E4)**-1
	MOVE	C, E  		;GET F AGAIN
	FSB	A, C		;SUBTRACT FROM PARTIAL SUM
	FAD	A, E1		;ADD IN E1
	FDVM	C, A		;DIVIDE BY F
	FAD	A, E6		;ADD 0.5
EX1:	FSC	A, (LPSA)	;SCALE THE RESULTS
	POP	P, LPSA 	;RESTORE ACS
	POP	P, E
	POP	P, D
	POP	P, C
	POP	P, B		;SAVED EARLIER
	POPJ	P,


E1:	204476430062		;9.95459578
E2:	174433723400		;0.03465735903
E3:	212464770715		;617.97226953
E4:	207535527022		;87.417497202
E5:	270524354513		;LOG(E), BASE 2
E6:	0.5
E7:	207540071260		;88.028


;ALOG
;FLOATING POINT SINGLE PRECISION LOGARITHM FUNCTION
;LOG(ABSF(X)) IS CALCULATED BY THE SUBROUTINE, AND AN
;ARGUMENT OF ZERO IS RETURNED AS MINUS INFINITY. THE ALGORITHM IS

;LOGE(X) = (I + LOG2(F))*LOGE(2)
;WHERE X = (F/2)*2↑(I+1), AND LOG2(F) IS GIVEN BY
;LOG2(F) = C1*Z + C3*Z↑3 + C5*Z↑5 - 1/2
;AND Z = (F-SQRT(2))/(F+SQRT(2))

;THE CALLING SEQUENCE FOR THE ROUTINE IS AS FOLLOWS:
;THE ARGUMENT IS IN ACCUMULATOR A
;	PUSHJ	P, ALOG
;THE ANSWER IS RETURNED IN ACCUMULATOR A


ALOG:
	MOVM	A, A   		;GET ABSF(A)
	JUMPE	A, LZERO	;CHECK FOR ZERO ARGUMENT
	CAMN	A, ONE		;CHECK FOR 1.0 ARGUMENT
	JRST	ZERANS		;IT IS 1.0 RETURN ZERO ANS.
	PUSH	P, B		;SAVE AC B
	PUSH	P, C		;SAVE AC C
	PUSH	P, D		;SAVE AC D
	ASHC	A, -33		;SEPARATE FRACTION FROM EXPONENT
	ADDI	A, 211000	;FLOAT THE EXPONENT AND MULT. BY 2
	MOVSM	A, C		;NUMBER NOW IN CORRECT FL. FORMAT
	MOVSI	A, 567377	;SET UP -401.0 IN A
	FADM	A, C 		;SUBTRACT 401 FROM EXP.*2
	ASH	B, -10		;SHIFT FRACTION FOR FLOATING
	TLC	B, 200000	;FLOAT THE FRACTION PART
	FAD	B, L1		;B = B-SQRT(2.0)/2.0
	MOVE	A, B		;PUT RESULTS IN A
	FAD	A, L2		;A = A+SQRT(2.0)
	FDV	B, A		;B = B/A
	MOVEM	B, D		;STORE NEW VARIABLE IN D
	FMP	B, B		;CALCULATE Z↑2
	MOVE	A, L3		;PICK UP FIRST CONSTANT
	FMP	A, B		;MULTIPLY BY Z↑2
	FAD	A, L4		;ADD IN NEXT CONSTANT
	FMP	A, B		;MULTIPLY BY Z↑2
	FAD	A, L5		;ADD IN NEXT CONSTANT
	FMP	A, D		;MULTIPLY BY Z
	FAD	A, C		;ADD IN EXPONENT TO FORM LOG2(X)
	FMP	A, L7		;MULTIPLY TO FORM LOGE(X)
	POP	P, D		;RESTORE
	POP	P, C
	POP	P, B
	POPJ	P,		;EXIT

LZERO:	MOVE	A, MIFI		;PICK UP MINUS INFINITY
L:	POPJ 	P, 		;EXIT

ZERANS:	MOVEI	A, 0		;MAKE ARG. ZERO
	POPJ	P,		;EXIT

;CONSTANTS

ONE:	201400000000
L1:	577225754146		;-0.707106781187
L2:	201552023632		;1.414213562374
L3:	200462532521		;0.5989786496
L4:	200754213604		;0.9614706323
L5:	202561251002		;2.8853912903
L7:	200542710300		;0.69314718056
MIFI:	400000000001		;LARGEST NEGATIVE FLOATING NUMBER

ENDCOM (POW)


COMPIL(COD,<CODE,CALL>,<.SKIP.,CVSIX,X22,GOGTAB,X33>,<CODE, CALL>)

DSCR VAL←CODE(OCTAL COMMAND, REFERENCE ARG);
⊗
Comment ⊗CODE
   Reference arg is added to octal command.  CODAC(USER)
   is placed in AC 1.  The constructed word is executed, and AC 1 resaved.
   Isn't that clever?  (AC1 is also returned as the value of the call)
⊗

HERE (CODE)	MOVE	USER,GOGTAB
	SETOM	.SKIP.		;ASSUME IT SKIPS
	PUSH	P,0
	MOVE	1,CODAC(USER)		;GET USER'S AC
	MOVE	0,-3(P)
	ADDI	0,@-2(P)		;CALCULATE THE INSTR DO BE EXECUTED
	XCT	0			;DO IT
	SETZM	.SKIP.			;DIDN'T SKIP
	MOVEM	1,CODAC(USER)
	POP	P,0
	SUB	P,X33
	JRST	@3(P)


DSCR VALUE←CALL(VAL,"FUNCTION");
CAL SAIL
⊗

↑↑.CALL:
HERE (CALL)
	SETOM	.SKIP.		;ASSUME A SKIP
	PUSHJ	P,CVSIX		;PARSE SIXBIT
	MOVE	TEMP,A		;SIXBIT FOR WHAT'S WANTED
	MOVE	A,-1(P)		;INPUT VALUE
	CALL	A,TEMP
	SETZM	.SKIP.		;NO SKIP, RECORD IT
	SUB	P,X22		;RETURN VALUE IN 1, WANT IT OR NOT
	JRST	@2(P)

ENDCOM (COD)

IFN ALWAYS,<BEND UTILS>
SUBTTL	STRING HANDLING ROUTINES