perm filename GOGOL[S,AIL]34 blob sn#143199 filedate 1975-02-01 generic text, type T, neo UTF8
COMMENT ⊗   VALID 00062 PAGES VERSION 18-1(12)
RECORD PAGE   DESCRIPTION
 00001 00001
 00007 00002	HISTORY
 00020 00003	Command File Descriptions
 00022 00004	Conditional Assembly Switches, Macros
 00026 00005	Titles, Versions
 00027 00006	AC Definitions
 00028 00007	CDB, SIMIO Indices For IOSER, OTHER INDICES
 00033 00008	Base (Low Segment) Data Descriptions -- Macros, Compil spec
 00035 00009	Base (Low Segment) Data Descriptions - Params, Links, Size specs
 00047 00010	Initialization Routines, Data
 00049 00011	Sailor, Reent --  Allocation, Main Program Control
 00052 00012	.SEG2. -- Get a second segment
 00055 00013	
 00058 00014	
 00063 00015	
 00064 00016	 Segment-Fetching Data
 00070 00017	
 00071 00018	 %ALLOC -- Main Allocation Routine
 00077 00019	
 00085 00020	
 00090 00021	 
 00097 00022	  Utility Subroutines for allocation
 00099 00023	%UUOLNK -- UUO Handler (Dispatch Vector Just Below)
 00102 00024	 RUUO -- RECORD HANDLER UUO ROUTINE 
 00105 00025	DSCR OCTPNT, DECPNT UUO'S
 00108 00026	DSCR PRINIT -- INTERFACE TO SYSTEM PRINTING FACILITIES
 00113 00027	DSCR ERROR UUOS
 00120 00028	DSCR CALLEDFROM -- PRINTS 'CALLED FROM' XXX 'LAST SAIL CALL AT'
 00129 00029	  Special Printing Routines For Error Handler
 00134 00030	DSCR USERERR(VALUE,CODE,"MSG","RESPONSE")
 00138 00031	  Code to Handle Linkage to Editors
 00141 00032	 EXPORT VERSION OF EDITOR-INTERFACE
 00146 00033	SAVE, RESTR, INSET -- General Utility Routines
 00150 00034	Core Service Routines -- General Description
 00155 00035	 Special AC Declarations
 00156 00036	  Utility Routines
 00162 00037	
 00167 00038	 CORGET
 00173 00039	
 00177 00040	 CORINC, CANINC
 00183 00041	 CORREL
 00190 00042	 CORPRT, CORBIG
 00201 00043	DSCR STRGC (REQUEST)
 00207 00044	STRGC, Definitions
 00211 00045	STRNGC -- Init, CALSGL, SGSWEP -- main loop through space sorting
 00216 00046	STRNGC -- SWPLUP -- main sweep (string moving) loop
 00218 00047	STRNGC -- SWPDUN -- expansion/contraction, parameter update
 00223 00048	STRNGC -- STSTAT -- Finish Up, collect statistics
 00226 00049	STRNGC Service routines -- SGSORT
 00229 00050	STRNGC Service routines -- SPGC,STRMRK, etc. -- Descriptor providing routines
 00234 00051	STRNGC Service routines -- SRTSPC -- space sorter
 00238 00052	STRNGC Service routines -- SOURCE and DEST
 00242 00053	
 00249 00054	STRNGC Service routines -- SGINS and SGREM
 00251 00055	STRNGC Service routines -- STCLER and RESCLR
 00253 00056	Some Runtime Routines Which Could Go Nowhere Else
 00254 00057	 Kounter Routines
 00256 00058	
 00265 00059	DSCR POW, FPOW, LOGS, FLOGS.  BOTH RETURN REALS.
 00270 00060	DSCR EXP,ALOG -- FOR USE BY EXPONENTIATION ROUTINES & WORLD
 00278 00061	Usercon 
 00280 00062	DSCR VAL←CODE(OCTAL COMMAND, REFERENCE ARG)
 00282 ENDMK
⊗;
COMMENT ⊗HISTORY
AUTHOR,FAIL,REASON
031  102200000014  ⊗;
DEFINE .VERSION <102200000014>

COMMENT ⊗
VERSION 18-1(12) 2-1-75 BY RLS ADD TENEX PSI SYSTEM
VERSION 18-1(11) 11-24-74 BY JFR X33 AN EXTERNAL TO SAILUP P.16
VERSION 18-1(10) 11-24-74 BY JFR BAIL/USERERR PATCH, P.30
VERSION 18-1(9) 11-24-74 BY JFR BAIL ERROR HANDLER
VERSION 18-1(8) 11-19-74 BY JFR MORE BAIL ERROR HANDLING
VERSION 18-1(7) 11-17-74 BY JFR MORE OF SAME
VERSION 18-1(6) 11-17-74 BY JFR BYE
VERSION 18-1(5) 11-17-74 BY JFR P.28 COMMUNICATION BETWEEN ERROR HANDLER AND BAIL
VERSION 18-1(4) 10-18-74 BY RLS FEAT BV CALLI -22 FOR CMU
VERSION 18-1(3) 10-18-74 BY RLS ADD .LEPIN FOR LDE
VERSION 18-1(2) 10-18-74 BY RHT VERSION 18
VERSION 17-1(74) 10-10-74 BY RLS RANDOR TENX MODS
VERSION 17-1(73) 10-10-74 BY RHT FEAT %BR% REMOVE HACKS, HEREFK TO HERE
VERSION 17-1(72) 9-20-74 BY JFR INSTALL BAIL
VERSION 17-1(71) 8-31-74 BY RHT BUG #tc# sgsort did not like funny null strings
VERSION 17-1(70) 7-31-74 BY JRL BUG #SX# HEREFK INSET
VERSION 17-1(69) 7-7-74 BY RHT ADD EDITS FOR RGC & UUO HACK
VERSION 17-1(68) 7-7-74 
VERSION 17-1(67) 7-7-74 
VERSION 17-1(66) 6-16-74 BY JRL %AO% SETPR2 LOSSAGE(STANFORD ONLY)
VERSION 17-1(65) 5-30-74 BY RLS BUG #SM# TEST FOR OVERFLOW OF DISPATCH TABLE
VERSION 17-1(64) 5-25-74 BY RLS EDIT
VERSION 17-1(63) 5-25-74 BY RLS EDIT
VERSION 17-1(62) 5-25-74 BY RLS PARAMETERIZE JRST TABLE LENGTH
VERSION 17-1(61) 5-25-74 BY RLS P.FIN FOR TENEX
VERSION 17-1(60) 5-25-74 BY RLS EDIT
VERSION 17-1(59) 5-24-74 BY RHT MOVE USERCON OVER FROM IOSER
VERSION 17-1(58) 5-24-74 
VERSION 17-1(57) 5-20-74 BY RHT ZERO ALLOCATED QUANTS. ALSO, ADD PD LINKEND
VERSION 17-1(56) 5-19-74 BY rht %bj% -- had to add a call to p.fin
VERSION 17-1(55) 4-8-74 BY RHT FEAT %BI% ADDED RECORD UUOS
VERSION 17-1(54) 4-8-74 
VERSION 17-1(53) 4-6-74 BY RLS TENEX FIX TO UDDT INTERFACE CODE
VERSION 17-1(52) 3-19-74 BY RHT GO OVER FILE WITH RLS
VERSION 17-1(51) 3-19-74 
VERSION 17-1(50) 3-19-74 
VERSION 17-1(49) 3-19-74 
VERSION 17-1(47) 3-5-74 BY RHT BUG #RL# STRINGC WAS ACCESSING .NEXT OF A SPACE AFTER CORREL
VERSION 17-1(46) 2-20-74 BY RHT BUG #RI# NEEDED AN INSET IN .SONTP
VERSION 17-1(45) 2-16-74 BY RHT FEAT %BF% WAY TO EXPAND ERROR BUFFER
VERSION 17-1(44) 1-26-74 BY RHT  BUG #QQ# INSTRUCTION LEFT OUT OF .SONTP
VERSION 17-1(43) 1-26-74 BY RHT BUG #QP# .SONTP STRING DESCR CANON USED WRONG
VERSION 17-1(42) 1-12-74 BY RHT FIX COMPIL FOR SGC
VERSION 17-1(41) 1-11-74 
VERSION 17-1(40) 1-11-74 BY RHT ADD .SONTP ROUTINE
VERSION 17-1(39) 1-11-74 
VERSION 17-1(38) 1-11-74 
VERSION 17-1(37) 1-11-74 BY RHT MERGE IN CMU CHANGES
VERSION 17-1(36) 1-11-74 
VERSION 17-1(35) 1-11-74 
VERSION 17-1(34) 1-11-74 
VERSION 17-1(33) 1-11-74 
VERSION 17-1(32) 12-14-73 BY RHT BUG #QA# PARAM COUNT TO GC TRAP WRONG
VERSION 17-1(31) 12-14-73 
VERSION 17-1(30) 12-12-73 BY RHT  MOVE LPLK OUT OF MIDDLE OF XX AREA
VERSION 17-1(29) 12-11-73 BY rht make rfs happy
VERSION 17-1(28) 12-10-73 BY RFS BUG PU, PAGE 26
VERSION 17-1(27) 12-10-73 
VERSION 17-1(26) 12-10-73 
VERSION 17-1(25) 12-8-73 BY JRL REMOVE SPECIAL STANFORD CHARACTERS(WHERE POSSIBLE)
VERSION 17-1(24) 12-3-73 
VERSION 17-1(23) 12-3-73 
VERSION 17-1(22) 12-3-73 
VERSION 17-1(21) 12-3-73 
VERSION 17-1(20) 12-3-73 BY RFS ELIMINATE ALL III DISPLAY STUFF
VERSION 17-1(19) 12-2-73 BY KVL MAKE ERR DISPATCH TO ETV INSTEAD OF TV
VERSION 17-1(18) 12-2-73 BY RHT ALLOW MORE ROOM FOR HERES
VERSION 17-1(17) 12-1-73 BY RLS ADD CDB INDICES FOR SETPL FUNCTION
VERSION 17-1(16) 11-30-73 BY RHT FLUSH ERRSPC DECL IN SAILOR
VERSION 17-1(15) 11-30-73 BY RHT ADD A FEW MORE XX SPARES
VERSION 17-1(14) 11-28-73 BY RHT FIX USERERR RIGHT
VERSION 17-1(13) 11-26-73 BY RHT TRIVIAL IMPROVEMENT TO AC PUSH LOOP IN ERR HANDLER
VERSION 17-1(12) 11-25-73 BY RHT FEAT %AO% DO SETPR2 IF REMAP LOSES.
VERSION 17-1(11) 11-25-73 BY KVL ADD "A" AND "C" OPTIONS TO WATNOW LOOP OF ERR
VERSION 17-1(10) 11-24-73 BY RHT FEAT %AL% SET UP RF FOR OUTER BLOCK
VERSION 17-1(9) 11-24-73 BY RHT MOVE PHASE COUNTS TO HEAD
VERSION 17-1(8) 11-24-73 
VERSION 17-1(7) 11-21-73 BY RHT MINOR FIXUP TO (NEW) USERERR
VERSION 17-1(6) 11-20-73 BY RFS CHANGE CHNL TO REG 10 TO FREE RF.
VERSION 17-1(4) 11-20-73 BY RFS ADD NEW EXPONENTIATION CODE; REENTRANT ERROR HANDLER
10/29/73 %AH% -- REE W/O STARTING
10/23/73 %AG% -- LEAPIS SWITCH IN $GITNO, NOT $ITNO
10/6/73  %AD% -- ALLOW LOWER CASE ANSWER TO "ALLOC"
9/18/73  MAKE END OF SAIL EXECUTION MESSAGE DO A CRLF FIRST
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=HEAD+ORDER+GOGOL+TRIGS+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=HEAD+LOW+FILSPC+GOGOL/NOLO
TAILOR.REL,UPPER=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

;;%BB% DCS (1-many) 12-3-73 Move REENT setup to within SAILOW, for library.
JOBVER←←137
	LOC	JOBVER
;;#HE# DCS 5-11-72 (1-2) MODIFY VERSION STUFF
	.VERSION&777777000000	;CURRENT VERSION NUMBER (LH ONLY)
	RELOC
;;#HE# (1-2)
>;NOUP
>;ALWAYS NEQ 0
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		?CHNL←10	;CHNL # FOR IOSER
		?T←11		?CDB←11		;CHANNEL DATA BLOCK PTR
		?T1←12				;TRY TO KEEP 12(RF) VALID.
?LPSA←13					;TEMP, PARAM AC
?TEMP←14					;TEMP ONLY
?USER←15					;PTR 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
	?IOSTATUS ←← 0		;RETURN STATUS
	?IOIN     ←← 1		;BUFFERED INPUT
	?IODIN    ←← 2		;DUMP INPUT
     	?IOOUT    ←← 3		;BUFMODE OUT.
	?IODOUT   ←← 4		;DUMP OUTPUT
	?IOCLOSE  ←← 5		;CLOSE FILE
	?IORELEASE←← 6		;RELEASE FILE
	?IOINBUF  ←← 7		;INBUF
	?IOOUTBUF ←←10		;OUTBUF
	?IOSETI   ←←11		;USETI
	?IOSETO   ←←12		;USETO
;;%##% RHT ! ADD A PRIMITIVE
	?SETIOSTS ←←13		;SET IO STATUS
	?IOOPEN ←←14		;OPEN CHANNEL
	?IOLOOKUP ←←15		;LOOKUP FILE
	?IOENTER  ←←16		;ENTER FILE
	?IORENAME ←←17		;RENAME FILE

;  FORMAT OF CDBs

	DMODE	←← 0		;DATA MODE	
	DNAME	←← 1		;DEVICE	
	BFHED	←← 2		;HEADER POINTERS	
	OBPNT	←← 3		;OUTPUT BUF. PTR	
	OBP	←← 4		;OUTPUT BYTE PTR	
	OCOWNT	←← 5		;OUTPUT BYTE CNT
	ONAME	←← 6		;OUTPUT FILE NAM
	OBUF	←← 7	 	;OUTPUT BUFFER LOC.
	IBPNT	←←10		;SAME FOR INPUT
	IBP	←←11	
	ICOWNT	←←12
	INAME	←←13	
	IBUF	←←14	
	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
	LINNUM  ←←21		;ADDR OF LINE NUMBER WORD (SETPL FUNCTION)
	PAGNUM  ←←22		;ADDR OF PAGE NUMBER WORD (SETPL FUNCTION)
	SOSNUM  ←←23		;ADDR OF SOS NUMBER WORD  (SETPL FUNCTION)
↑IOTLEN	←←SOSNUM+1	;LENGTH OF TABLE ENTRY

?LUPDL←30			;LENGTH OF UUO PDL
?MINPDS←←=64			;SMALLEST ALLOWABLE SYSTEM PDL SIZE
?DEFPDS←←=192			;DEFAULT PDL SIZE

?.ERSWC ←← 20			;SIZE OF BUILT IN .ERSTR BUFFER

GLOB < 
;;ALSO SET IN LEPRUN
?GBRK ←← 6000			;MIN GLOBAL ITEM NUMBER
>;GLOB

;;%BA% DCS (1-many) new STRNGC
; String space header indices -- one header per String Space
?.HDRSIZ←←4			;Header allocated in each string space
?.NEXT←←-1			;Next string space
?.LIST←←-2			;Used to link descriptors during GC
?.SIZE←←-3			;Size of this space
?.STTOP←←-4;<			;=> 1 past last word this space (redundant)
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,$PDLOV,P.FIN>
	    ,<BASE DATA, INITIALIZATION CONTROL>
	    ,<X11,X22,X33,X44>,INHIBIT)
SUBTTL	Base (Low Segment) Data Descriptions - Params, Links, Size specs

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

XX	(GOGTAB,0,INTERNAL)	;PTR TO USER TABLE
XX	(DATM,0,INTERNAL)	;XWD 3,ADDR OF DATUM TABLE
XX	(LKSTAT,0,INTERNAL)	;STATUS OF GLOBAL LEAP MODEL INTERLOCK (SHOULD BE IN GOGTAB
XX	(INFTB,0,INTERNAL)	;POINT  9,ADDRESS INFOTAB TABLE(3)
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	(.ERRP.,0,INTERNAL)	;PLACE FOR USER TO PUT AN ERROR PROCEDURE
XX	(.ERRJ.,0,INTERNAL)	;TRANSFER ADDRESS RETURNED BY USER PROC.
XX	(%ERRC,0,INTERNAL)	;COMMUNICATION BETWEEN USERRR AND ERROR UUO.
XX	(%RECOV,0,INTERNAL)	;HIGH ORDER BIT ON IF ERROR RECOVERABLE
XX	(%ERGO,0,INTERNAL)	;SET IF IN CONTINUATION MODE.
XX	(.ERSTP,0,INTERNAL)	;POINTER INTO ERROR STRING.
;;?.ERSWC ←← 20	; ERROR STRING BUILT IN BUFFER'S WD CNT (ACTUALLY DEFINED EARLIER)
XX	(.ERSTR,<BLOCK 20>,INTERNAL,20) ;ERROR MESSAGE STRING.
XX	(.DTRT.,0,INTERNAL)	;DDT RETURN ADDRESS
;;%BB% DCS 12-3-73 (1-many) cmu style pre/post traps
XX	(.EXPINT,0,INTERNAL)	;CORE UUO TRAP ROUTINE ADDRESS (CMU-STYLE)
XX	(.SGCINT,0,INTERNAL)	;STRING GC TRAP ROUTINE ADDRESS (")
XX	(.TRACS,<BLOCK 12>,INTERNAL,12)	;CORE, STRNGC TRAP ROUTINE SAVE ACS
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)	;NEQ 0 MEANS 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	(OVPCWD,0,INTERNAL)	;SET BY APR INTERRUPT HANDLER (IF ANY)
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.
>;IFE APRISW
IFN APRISW <
XX	(S15ARE,0)
XX	(S16ARE,0)
XX	(S17ARE,0)
>;IFN APRISW
>;NOEXPO
XX	(XJBENB,0,INTERNAL)	;USED BY APR ENABLER FOR EXPORT SYSTEM
				;SPARE LOWER LOCATIONS
XX	(.ERSTC,0,INTERNAL)		; COUNT OF CHARS LEFT IN .ERSTR
;;%BF%	-- ERR BUFFER LENGTH KLUGE (1 OF MANY)
XX	(.ERBWD,0,INTERNAL)	; BYRE(13)CHAR COUNT(23)BUFFER
XX	(RECCHN,0,INTERNAL)	;EVERY RECORD IN THE WORLD GOES ON THIS
XX	(RGCLST,0,INTERNAL)	;LIST OF RECORD MARK ROUTINES
;;%BL% -- UUO KLUGE
XX	(.UUOCN,0,INTERNAL)	;LOCATION OF ALTERNATE UUO DISPATCH
;;%BT% !
XX	(.CORIN,0,INTERNAL)	;SOME SORT OF CORGET TRAP
;;%BU% !
XX	(.LEPIN,0,INTERNAL)	;LEAP TRAP FOR TIMING TESTS
;;%BR% ADD SOME MORE SPARES
XX	(S1PARE,0)
XX	(S2PARE,0)
XX	(S3PARE,0)
XX	(S4PARE,0)
XX	(S5PARE,0)
XX	(S6PARE,0)
XX	(S7PARE,0)
XX	(S8PARE,0)
XX	(S9PARE,0)
;;%BR% ↑
XX	(S10ARE,0)
XX	(S11ARE,0)
XX	(S12ARE,0)
XX	(S13ARE,0)
XX	(S14ARE,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)	;7 INITIALIZATION ROUTINES (LPINI ONLY NOW)
;;%BR% MOVED THESE DOWN FROM SPARES
XX	(PDLNK,0,INTERNAL)	;LINKED LIST OF ALL PDS
;;%BM% -- RECORD GARBAGE COLLECTION
XX	(RBLIST,0,INTERNAL)	;LIST OF RECORD BLOCKS
XX	(BALNK,0,INTERNAL)	;LOADER LINK FOR DEBUGGER INFO
;;%BR% ↑

; 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
	LINKEND %PDLNK,PDLNK
	LINKEND	%RBLNK,RBLIST
BAIL<
	LINKEND %BALNK,BALNK
>;BAIL
>;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)

; MADE ALLPDL BIGGER (FROM 20) BECAUSE OF NEW UUO HANDLER
XX	(ALLPDP,<IOWD 40,ALLPDL>,INTERNAL);USED FOR A WHILE DURING ALLOC
XX	(ALLPDL,<BLOCK 40>,INTERNAL,40)	  ;AND IN PROCESS TERMINATION
XX	(%ALLCHR,0,INTERNAL)
XX	(%OCTRET,0,INTERNAL)

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

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

XX	(APRACS,<BLOCK 20>,INTERNAL,20)	;APR INTERRUPT AC STORAGE
;;%##% EXPORT OUTSTR BUFFER (USED TO USE SGACS, BUT ...)
NOTENX<
EXPO <
XX	(OTSTRBF,<BLOCK 20>,INTERNAL,20)	;OUTSTR BUFFER
>;EXPO
>;NOTENX
CMU <	;THIS STUFF USED FOR GAS
XX	(GASCMD,0,INTERNAL)		;IF 0 THEN VIRGIN, SO
					;SET NEG & SET LH(JOBHRL) TO -1 & EXIT
XX	(THIS.MOD,0,INTERNAL)		;
>;CMU

;TENEX XX VARIABLES - MOSTLY FOR INTERRUPTS
TENX <
XX	(CHNTAB,<BLOCK =36>,INTERNAL,=36);SHOULD BE REFERENCED
XX	(LEVTAB,LPC1,INTERNAL)	;ONLY FROM CODE AT STRT IN SAILOR, Q.V.
XX	(,LPC2,)
XX	(,LPC3,)
XX	(LPC1,0,INTERNAL)
XX	(LPC2,0,INTERNAL)
XX	(LPC3,0,INTERNAL)


XX	(JMPCHN,<BLOCK =36>,INTERNAL,=36)
LOW <
EXTERNAL	PSIL1,PSIL2,PSIL3
>;LOW
XX	(PS1ACS,<BLOCK 20>,INTERNAL,20)
XX	(,<JRST PSIL1>,)
XX	(PS2ACS,<BLOCK 20>,INTERNAL,20)
XX	(,<JRST PSIL2>,)
XX	(PS3ACS,<BLOCK 20>,INTERNAL,20)
XX	(,<JRST PSIL3>,)



;XX VARIABLES FOR IO
XX	(JFNTBL,<BLOCK JFNSIZE>,INTERNAL,JFNSIZE)	;JFNs for each channel
XX	(CDBTBL,<BLOCK JFNSIZE>,INTERNAL,JFNSIZE)	;Addr. of chnl data buffer for each chnl
XX	(PRTMP,0,INTERNAL)
XX	(CTLOSW,0,INTERNAL)				;CTRL-O SWITCH
XX	(TTCSVB,0,INTERNAL)				;TENEX emulation of TTCALL
>;TENX

;PUT NO XX VARIABLES IN AFTER THIS POINT

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

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

;;%AZ% DCS 12-3-73 (1-many) Improved ALLOC, Reenter sqncs, here and following
; Set Re-entry address
	LOC	124		;SET UP REENTER ADDRESS
	REENT
	RELOC
↑REENT:	SETOM	%RENSW		;RE-ENTER -- ASK FOR NEW ALLOC
;;%  %2.! DCS 12-3-73 SIMPLE REENTER SEQUENCE
	HRRZ	TEMP,JOBSA	;SAME AS START, OTHERWISE
	JRST	(TEMP)

;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:
TENX <
	JSYS	RESET
>;TENX

	JSP	P,.SEG2.	;GET SECOND SEGMENT
;; %AO%				;WILL SKIP RETURN IF DOES A SETPR2
				;INSTEAD OF SEGMENT FETCHING
STRT:
NOTENX <
	CALL6(RESET)
>;NOTENX
TENX <
EXTERNAL .RESET
EXTERNAL P.FIN
	JSP	P,.RESET	;JSYS RESET, PSI SYSTEM, TTY MODES, FILE BUFFERS
>;TENX
CMU <
GGAS <
	MOVEI	TEMP,0		;
	CALL6	(TEMP,SETUWP)	;
	JRST	[PUUO	3,[ASCIZ /CANNOT CLEAR WRITE PROTECTION/]
		CALL6(EXIT) ];
>;GGAS
>;CMU
	SETZM	GOGTAB		;FORCE CORSER RE-INITIALIZATION
	SETNIT			;GET TEMP STACK, IF NECESSARY
;;%AZ% DCS 12-3-73 K.ZERO, INILST calls moved to ALLOC
	JSP	16,%ALLOC	;ALLOCATE AREAS

	MOVEI	A,RESTRT	;CHANGE JOBSA AND JOBREN
	HRRM	A,JOBSA		;"S" USES OLD ALLOCATION
;;%AL% .! THE OUTER BLOCK IS JUST A PROCEDURE
	HRLOI	RF,1		;THE VERY OUTER BLOCK
	PUSHJ	P,@SAILOR	;CALL USER PROGRAM
	PUSHJ	P,K.OUT		;WRITE OUT THE COUNTERS
;;%BF%	!
	PUSHJ	P,P.FIN		;CLOSE OUTPUT $PRINT FILE, IF ANY
	TERPRI	<
End of SAIL execution>
NOTENX <
	CALL6	(0,RESET)	;CLEAR THE I/O WORLD
	CALL6	(1,EXIT)	;QUIT QUIETLY
>;NOTENX
TENX <
	JSYS	HALTF
	JRST	.-1	;NO CONTINUATION
>;TENX
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
⊗

NOTENX <
INTERNAL .SEG2.
.SEG2.:
NOCMU <
LOW <
	SKIPE	JOBHRL		;IS THERE A SEGMENT?
>;LOW
>;NOCMU
CMU <
IFN LOWER!GASSW ,<
GGAS <
	SKIPL	GASCMD		;VIRGIN??
	JRST	GASSET		;YES, DO SOMETHING ABOUT THAT
>;GGAS
	SKIPN	A,JOBHRL	;ALSO CHECK FOR -1,,0
	JRST	.+3
	CAME	A,[XWD -1,0]	;
>;IFN LOWER!GASSW
>;CMU
	 JRST	 (P)		; YES, GO AHEAD (OR ALWAYS, IF NOLOW)
>;NOTENX
>;NOUP

NOTENX <
NOCMU <
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 IN (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:	SPRINT	<SEGMENT LOGICAL NAME?>
	JSR	GGNAM		;GET A SEGMENT NAME.
GOTEM:	MOVEM	A,NMSAV
>;GLOB
NOGLOB <
	MOVE	A,[FILXXX]	;TRY TO FIND IT.
>;NOGLOB
	CALL6(A,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
	CALL6(A,ATTSEG)		;
	JSP	A,ERSEG
	JRST	(P)		;OK, GOT IT
>;NOEXPO
EXPO <
ASKEM:				;MISPLACED LABEL
>;EXPO
GETSE:	CALL6(RESET)
GLOB <
	SKIPE	A,SEGFIL	;WAS ONE "REQUIRE"D?
	 JRST	 THSFL		; YES, USE IT
	SPRINT	<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
	SPRINT	<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
	SPRINT	<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.
	CALL6	(A,CORE)	;CORE UUO ----
	JSP	A,ERSEG
LOP22:	INPUT	1,[LIOD: 0
		    0]
GLOB <
	TLZ	D,-1		;NO, MAKE IT WRITEABLE IF GLOBAL MODEL.
>;GLOB
IFN NOPROT,<
	TLZ	D,-1		;MAKE WRITEABLE IF REQUESTED TO
>;NOPROT NEQ 0
	CALL6	(D,REMAP)	;
;;%AO% DO SETPR2 TO AVOID LOSSAGE WHEN NO JOB SLOTS LEFT
NOGLOB <
	JRST	[		;
		CALL6(RESET)	;SINCE A RESET LATER MEANS DISASTER
		PUUO	3,[ ASCIZ/
COULD NOT DO REMAP TO GET A SAIL SEGMENT!
SETPR2 DONE INSTEAD.  YOUR JOB SHOULD BE HAPPY SO LONG AS 
IT DOES NOT DO A RESET OR OTHER BADNESS. GOOD LUCK.
ALSO, IF YOU WANT TO RUN THIS WAY, BEWARE OF RESTARTING.
/]		;BETTER WARN THE POOR PEOPLE
		ADDI	D,2	;MAKE EVEN K & MAKE IT REL MODE
		MOVS	A,SEGNAM+3;
		MOVN	A,A	;SIZE
		ORI	A,1777	;PUTS TO K BNDRY & WRITE PROT
		HRLI	D,(A)	;
		SETPR2	D,	;FAKE THE SEGMENT
		JRST	[ PUUO 3,[ASCIZ/
SETPR2 LOST, TOO!
/]
			JRST	4,1(P)]
		MOVE	A,JOBREL; SINCE SAIL COMPILER IS DUMB
		HRRM	A,JOBFF	; SAFE NOW???
		HRLM	A,JOBSA ; BOTH PLACES (BUFSAV REFERS TO JOBSA)
		JRST	1(P)	;HURRAH -- RETURN
				;DO 1(P) TO AVOID THE RESET
		]
>;NOGLOB
GLOB <
	JSP	A,ERSEG		;GLOBAL CANNOT GET AWAY WITH SETPR2
>;GLOB
;;%AO%
NOGLOB <
	MOVE	A,[FILXXX]
>;NOGLOB
GLOB <
	MOVE	A,NMSAV
>;GLOB
	CALL6	(A,SETNM2)	
	JRST	[MOVEI	A,0
		CALL6	(A,CORE2)	;CORE2
	 	 JSP	A,ERSEG
GLOB <
		 SETOM	%RENSW	;FORCE TTY RITUAL
>;GLOB
		 JRST	SEGTR]		;TRY AGAIN.
	CALL6(RESET)
>;NOEXPO

EXPO <
	SETZM	SEGNAM+4		;CLEAR LAST TWO WORDS OF GETSEG BLOCK
	SETZM	SEGNAM+5
	MOVEI	A,DEVSEG		;GET READY
	MOVEM	P,SAVPP
	CALL6	(A,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
					;NOTE: ALSO HAVE A JRST (P) IN
					; THE CODE FOR FEAT %AL%
>;LOW
>;NOCMU
;;*************************
CMU <
IFN LOWER!GASSW,<
INTERNAL DEVSEG
SEGTR:					;TRY AGAIN
ASKEM:					;RANDOM LABEL
GETSE:	CALL6(RESET)			;
	SETZM	SEGNAM+2
	MOVE	TEMP,[SGPPNN]
	MOVEM	TEMP,SEGNAM+3	;SET UP PPN
	HLLZS	SEGNAM+1

	SETZM	SEGNAM+4		;CLEAR LAST TWO WORDS OF GETSEG BLOCK
	SETZM	SEGNAM+5
	MOVEI	A,DEVSEG		;GET READY
	MOVEM	P,SAVPP
	CALL6	(A,GETSEG)		;GET THE SEGMENT
	 JSP	 A,ERSEG		; COULDN'T
	MOVE	P,SAVPP
; NO WAY TO RENAME 2D SEGMENT, SO DON'T WORRY ABOUT IT
	HRROS	JOBHRL

	JRST	(P)			;RETURN
					;NOTE: ALSO HAVE A JRST (P) IN
					; THE CODE FOR FEAT %AL%
>;LOW
>;IFN LOWER!GASSW
>;CMU
>;NOTENX

EXPO <
NOUP <
INTERNAL TYPER.,ERRMSG
;THESE ARE BECUSE OF LIB40 CHANGES
; MADE CAPRICIOUSLY BY DEC
TYPER.:
ERRMSG:
	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

NOTENX <

NOCMU < ;THESE GUYS HAVE TO BE EXTRA SPECIAL
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:	SPRINT	<SAIL SEGMENT LOADING ERROR
>
GLOB<
	SETOM	%RENSW		;FORCE TTY RITUAL
>;GLOB

	CALL6 (EXIT)

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		; CNVRT TO  SIXBIT
	IDPB	C,B		;SAVE IT.
	JRST	GGGO
>;GLOB
>;LOW
>;NOCMU
;;****************************
CMU <
IFN LOWER!GASSW,<
NMSAV:	0			;SAVE LOGICAL SEGMENT NAME HERE
SEGDEV: 0			;SAVE UPPER SEGMENT DEVICE NAME HERE
SEGFIL:	0			;SAVE UPPER SEGMENT FILE NAME HERE
	SIXBIT	/SHR/		;DIFFERENT STROKES FOR ....
	0
SEGPPN: 0			;SAVE UPPER SEGMENT PPN HERE

DEVSEG:	SGDEVC			;USED ONLY BY EXPO'S GETSEG
SEGNAM:	FILXXX
	SIXBIT /SHR/
	0
	SGPPNN			;SPECIFIED PPN DEFAULT
	0 
	0			;SIX WORD BLOCK FOR GETSEG
SAVPP:	0			;P SAVED HERE OVER GETSEG
ERSEG:	SPRINT	<SAIL SEGMENT LOADING ERROR
>
	CALL6 (EXIT)
GGAS <	;COME HERE WHEN STARTING VIRGINALLY
	EXTERNAL %FIRLOC,TOP2
GASSET:	SKIPE	GASCMD		;NORMAL?
	JRST	GASPEC		;NO
	HRROS	JOBHRL		;SO THE HISEG WON'T BE SAVED
	SETOM	GASCMD		;SO WE WON'T DO THIS SILLINESS AGAIN
	TERPRI	<SAVE me>
	CALL6	(0,EXIT)
GASPEC:	SKIPE	TOP2		;HAVE WE BEEN HERE BEFORE?
	JRST	(P)		;YES
	MOVEI	A,0
	CALLI	A,36		;CLEAR WRITE PROTECT
	JRST	[TERPRI <CAN'T WRITE ENABLE 2D SEG>
		CALLI 1,12]
	SETZM	%FIRLOC+11	;NO 2D SEGMENT SYMBOL TABLE
	HLRZ	A,JOBHRL
	MOVEI	A,-%FIRLOC-1(A)
	TRO	A,400000	;TURN IT OFF.
	HRRZM	A,TOP2
	JRST	(P)
>;GGAS
>;IFN LOWER!GASSW
>;CMU
>;NOTENX
TENX <
NOUP <
INTERNAL .SEG2.
.SEG2.:	MOVE	1,[XWD 400000,SEGPAG]	;THIS FORK←←400000
	JSYS	RPACS
	TLNE	2,10000			;DOES THE PAGE FOR THE SEGMENT EXIST?	
	 JRST	(P)			;YES
	MOVEI	1,400000		;THIS FORK
	JSYS	GEVEC			;GET ENTRY VECTOR
	MOVEM	2,3			;SAVE IT
	HRLZI	1,100001
	HRROI	2,[FILXXX]
	JSYS	GTJFN
	  JRST	[HRROI	1,[ASCIZ/SAIL segment loading error on segment:
/]
		 JSYS	PSOUT
		 HRROI	1,[FILXXX]
		 JSYS 	PSOUT
		 HRROI	1,[ASCIZ/
/]
		 JSYS	PSOUT
	HLTAGN:	 JSYS HALTF
		 JRST HLTAGN		;NO CONTINUATION
		]
	HRLI	1,400000
	JSYS	GET
	MOVEI	1,400000		;THIS FORK
	MOVEM	3,2
	JSYS	SEVEC
	JRST	(P)
>;NOUP
>;TENX
ENDCOM(LOR)
LOW <
	END
>;LOW
COMPIL(LUP,<%UUOLNK,%ALLOC,SAVE,RESTR,STACSV,STACRS,INSET,USERERR,$PDLOV,.UINIT,ERMSBF> 
	   ,<CORGET,STCLER,GOGTAB,CONFIG,%ALLCHR,CAT,STRNGC,K.ZERO>
	   ,<INITIALIZATION ROUTINES, UUO HANDLER, UTILITY ROUTINES>
	   ,DT.RET)
IFE ALWAYS,<
INTERNAL %ALLOC,DT.RET
; MORE EXTERNALS
;;%BL%
EXTERNAL	ALLPDP,SETLET,INILNK,XJBENB,.UUOCN
EXTERNAL	SPLNEK,%OCTRET,%RECOV,%ERRC,%RENSW,%ERGO
;;%##% .ERSTC ADDED
;;%BF% ALSO .ERBWD,CORREL
EXTERNAL	.DTRT.,.ERSTR,.ERSTP,.ERRP.,.ERRJ.,.ERSTC,.ERBWD,CORREL
;; X33 11-24-74 JFR
EXTERNAL	X11,X22,X33,X44,CORINC,%STDLS,%SPL,KTLNK,PDLNK
EXPO <
EXTERNAL	PPMAX
>;EXPO
RGC <
EXTERNAL	RECCHN,RGCLST
>;RGC
>;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.

;;#SM# 5-30-74 RLS CHECK FOR OVERFLOW OF DISPATCH TABLE
	USE	DSPCH		;A PC FOR VECTOR JRSTS
	USE
?DSPBAS:	BLOCK DSPLEN		;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)
IMSSS<;HACK FOR MISERABLE IMSSS LOADER -- REMOVE WITH NEW LOADER
	SETO	1,			;SET TO REMOVE PAGE
	HRRZ	2,JOBREL		;THAT THE LOADER LEAVES
	LSH	2,-11			;WRITE PROTECTED
	ADDI	2,1
	HRLI	2,400000		;THIS FORK
	JSYS	PMAP			;REMOVE
>;IMSSS
;;%BF% be sure the ERR below will work
	SETZM	.ERBWD			;INITIALIZE ERROR MESSAGES

	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 ptr to next allocation block.
;  T1 is ptr to next entry specification
;  Q1 is modified T1 -- accounts for STDSPC specifications
;  Q2 is incoming OP-size word
;  A  is ptr to 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
;;%BR% ALLOW VERSIONS NOW
;;%AL1:	MOVEI	T1,$SPREQ(T)		;PTR TO FIRST REQUEST
;;%##% OUGHT TO INCLUDE THIS IN NEXT STANFORD COMPILER
	JRST	VEROK			;FORGET THE BUILTIN BLOCK
%AL1:
	HLRZ	TEMP,$CMVER(T)		;RUNTIME VERSION NUMBER
	CAIE	TEMP,(.VERSION & 777777000000)
	SKIPE	CONFIG		;DON'T DO FOR COMPILER
	JRST	VEROK
	ERR	<POSSIBLE COMPILED CODE-RUNTIME INCOMPATIBILITY.
CONTINUE IF YOU DARE>,1
VEROK:
	MOVEI	T1,$SPREQ(T)
;;%BR% ↑
%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 pnts to 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 NEQ  0, OSIZ etc. -- then
 NMIN and not OSIZ		then  OSIZ←NSIZ, OMIN←TRUE
 NMIN and  OSIZ			then  no change

 not NMIN and NSIZ and OMIN	then  OSIZ←NSIZ, OMIN←FALSE
 not NMIN and not NSIZ and OMIN	then  no change
 not NMIN and not OMIN		then  OSIZ←NSIZ+OSIZ, OMIN←FALSE

In the sequel,
 A pnts to 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		;not NMIN and not OMIN, ADD
	JUMPN	Q2,%AL6		;not NMIN and OMIN, NSIZ?
	TLOA	Q3,MINSZ	;not NMIN and OMIN and not NSIZ,
				; NMIN←TRUE, NSIZ+OSIZ=OSIZ
%AL6:	HLLZS	TEMP	;not NMIN and OMIN and NSIZ,
			; OSIZ←FALSE,NSIZ+OSIZ=NSIZ,NMIN←FALSE
	JRST	ADDIT		;not NMIN and OMIN, EITHER NSIZ OR OSIZ

; NMIN
INMIN:	TRNE	TEMP,-1		;OSIZ?
	TLZA	Q3,MINSZ	;NMIN and OSIZ, OSIZ unchg, NMIN←FALSE
	TLZA	LPSA,MINSZ	;NMIN and not OSIZ, OSIZ←NSIZ, NMIN←TRUE
	MOVEI	Q2,0		;NMIN and 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 <
;; %AG% .! LEAPIS USED TO BE STORED IN $ITNO
	SKIPL	$GITNO(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? >
	PUUO	0,B		;ASK LEADING QUESTION AND GET ANSWER
	TERPRI
;; %AD% RHT ALLOW LOWER CASE 10/4/73
	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

	PUUO	3,(A)		;PRINT IT
;;%AZ% DCS 12-1-73 (2-many) Enhance behavior of ALLOC sequence.
	PRINT	< (>
	HLRZ	C,A		;DEFAULT (+"REQUIRE"d) VALUE
	DECPNT	C		;  "SYSTEM PDL (64) = "
	PRINT	<) = >
;;%AZ% (2-many)
	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:
;;%AZ%.! DCS 12-1-73 (2-3) Enhance behavior of ALLOC Sequence.
;; Removed size printing code from here, moved it to (1-3) above
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		;PNT TO RETURN ADDRESS (DUMMY AND SYSPDL ENTRIES)

 
; FINAL BOOKKEEPING

	SETZM	%RENSW		;DON'T ASK EACH TIME
	MOVE	SP,SPDL(USER)	;STRING STACK POINTER
;;%BA% DCS 12-1-73 (1-1) New String Garbage Collector -- New initialization
	MOVEI	A,4		;Update ST(USER) to include a .HDRSIZ-word
	ADDB	A,ST(USER)	; header, preceding ST(USER). Call new addr. "SPC".
	HRLI	A,(<POINT 7,0>)	;USER TABLE ENTRIES:
	MOVEM	A,TOPBYTE(USER)	; TOPBYTE ← POINT 7,SPC
	HRRZM	A,STLIST(USER)	; STLIST ← SPC
	MOVE	B,STTOP(USER)	; STINCR ← size(SPC)*5,,size(SPC)+.HDRSIZ
	MOVEM	B,.STTOP(A)	; STREQD ← size(SPC)/8*5,,size(SPC)/8
	SUBI	B,(A)		; REMCHR ← -(size(SPC)*5)+=15
	MOVEM	B,.SIZE(A)	;SPC's header entries:
	SETZM	.LIST(A)	; .LIST ← .NEXT ← 0
	SETZM	.NEXT(A)	; .SIZE ← size(SPC)  (STTOP-new ST)
	MOVEI	TEMP,.HDRSIZ(B)	; .STTOP ← STTOP(USER)
	HRRM	TEMP,STINCR(USER)
	LSH	TEMP,-3
	HRRM	TEMP,STREQD(USER)
	IMULI	TEMP,5
	HRLM	TEMP,STREQD(USER)
	IMULI	B,5
	HRLM	B,STINCR(USER)
	SUBI	B,=15
	MOVNM	B,REMCHR(USER)
;;%BA% (1-1)
	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
	SETZM	XJBENB		; WHERE APR INTERRUPT ENABLINGS ARE REMEMBERED
	SETZM	%ERGO		;REINITIALIZE ERROR PRINTER
;;#HE# DCS 5-11-72 (2-2) MODIFY VERSION CHECKING, STORAGE METHODS

;;%BF% RHT ASK FOR BIGGER ERROR BUFFER
	PUSH	P,[=256]
	PUSHJ 	P,ERMSBF
;;%  % rht be sure small space guy is initialized if segment
REC <
UP <
	SKIPN	$FSLIS(USER)	;IF NOTHING ON $FSLIS THEN GET SOMETHING
	PUSHJ	P,$FSINI	;THERE
>;UP
RGC <	
	SETZM	RECCHN		;CHAIN OF ALL RECORDS IN THE WORLD
	SETZM	RGCLST		;CHAIN OF USER-ADDED GC ROUTINES
>;RGC
>;REC

IFNDEF JOBVER,<EXTERNAL JOBVER>
	MOVEI	LPSA,SPLNEK	;For each element of the space
;;%AZ% DCS see just below
CHKVRS:	SKIPN	LPSA,(LPSA)	; list, if there is a non-zero 
	 JRST	 ENDINT		; 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)

;;%AZ% DCS  moved this from SAILOR sequence

ENDINT: PUSHJ	P,K.ZERO	;NZERO OUT THE COUNTERS

;;%  % RHT ZERO OUT INCORE ALLOCATED VARIABLES & AVOID RESTART HASSLES
INIPDS:	HRRZ	A,PDLNK		;PD LINK
INI1PD:	JUMPE	A,INILST	;IF ANY PROCEDURES
	HRRZ	TEMP,PD.LLW+1(A);POINT AT LVI
	HRRZ	A,(A)		;NEXT ONE
	JUMPE	TEMP,INI1PD
PDLLL:	MOVE	LPSA,(TEMP)	;GET AN ENTRY
	TLNN	LPSA,740000	;A 0 MEANS DONE
	JRST	INI1PD
	TLNE	LPSA,37		;INDEX MEANS DO NOTHING
	AOJA	TEMP,PDLLL
	LSH	LPSA,-=32	;ALL HAVE LEFT IS TYPE CODE
	CAIE	LPSA,10		;A CLEANUP IS EXEMPT
	CAIN	LPSA,17		;AS IS A BLOCK END
	AOJA	TEMP,PDLLL
	SETZM	@(TEMP)		;MAKE IT VIRGIN
	AOJA	TEMP,PDLLL	;
;;%  %

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

HERE(.UINIT)
	MOVE	A,[XWD -USRPHS,400000] ;DO USER PHASES
;; #KV# MAKE SURE LINK NON-NULL
	SKIPN  INILNK
	POPJ	P,
;; #KV#
	JRST	DOPHS

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
;;%AZ% DCS 12-1-73 (3-3) Enhance behavior of ALLOC sequence
;; Use line mode input, remove inferior line-editing code.
OCTIN1:	PUUO	4,B		;	;; INCHWL, was 0,B (INCHRW)
;; Removed rubout, ctrlo check
;;!HOOK! May need to put some back in for TENEX
	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,

;; Removed rubout, ctrlo code from here
;;%AZ% (3-3)

SUBTTL	%UUOLNK -- UUO Handler (Dispatch Vector Just Below)


NOLOW <			;INCLUDE IN UPPER SEGMENT.....
HERE(%UUOLNK)
UUOCON: PUSH	P,FF		;SAVE REGISTER 0
	PUSH	P,A		;AND REGISTER 1
	MOVE	FF,@JOBUUO	;ARGUMENT BEFORE CLOBBERING AC'S
	LDB	A,[POINT 9,JOBUUO,8] ;GET OP CODE.
;	TRNE	A,777760	;SEE IF IN RANGE
;	JRST	ILLUUO		;ILLEGAL
	JRST	@UUOTBL(A)	;DISPATCH TO CORRECT ROUTINE.
RETM:	POP	P,D		;RESTORE SAVED AC'S
	POP	P,C
	POP	P,B
USRXIT:	POP	P,A
	POP	P,FF		;RESTORED AC'S
	POPJ	P,		;AND RETURN!


SAVM:	PUSH	P,B		;SAVE AC'S -- CALLED WITH JSP 0
	PUSH	P,C
	PUSH	P,D		;ENUF
	PUSH	P,[RETM]
	JRST	@FF		;RETURN

;;%BI% THESE TWO GENERALLY USEFUL ROUTINES ADDED WHEN RUUO ADDED

SAVALL:	PUSH	P,2		;SAVES ACS 2-15 (ASSUMES 0,1 TOP 2 ELTS)
	HRLZI	2,-13		;NUMBER LEFT TO SAVE
	PUSH	P,3(2)		;SAVE AN AC
	AOBJN	2,.-1		;COUNT DOWN
	PUSH	P,[RSTALL]	;POPJ WILL FALL INTO RSTALL
	JRST	@FF		;RETURN

RSTALL:	HRLZI	15,-15(P)	;ASSUMES STACK HAS (RETADR, ACS 0-15)
	BLT	15,15		;RESTORE THE ACS
	SUB	P,[XWD 16,16]	;GIVE BACK THE SPACE
	POPJ	P,		;RETURN
;;%BI%



; UUO TABLE

UUOTBL:	JRST	ILLUUO		;0
	JRST	ILLUUO		;1
	JRST	FLOAQ		;2 -- FLOAT A NUMBER
	JRST	FIXQ	   	;3 -- FIX A NUMBER
	JRST	IOERRR		;4 -- I/O ERROR
	JRST	ERRR		;5 -- STANDARD ERROR UUO
	JRST	PSIXQ		;6 -- SIXBIT PRINT
	JRST	ARERRR		;7 -- ARRAY ERROR
;;%BI% ! ADDED A UUO
	JRST	RUUO		;10 -- RECUUO
	JRST	DECPNQ		;11 -- PRINT DECIMAL NUMBER
	JRST	OCTPNQ		;12 -- PRINT OCTAL NUMBER
	JRST	ILLUUO		;13
	JRST	ILLUUO		;14
	JRST	PRINIT		;15 -- HANDLE TERMINAL

HERE($PDLOV)			;PLACE TO COME WHEN A STACK
	MOVEI	TEMP,TEMP	;IS EXHAUSTED.
	POP	TEMP,TEMP	;THIS WILL CAUSE PDLOV
	JRST	(USER)		;RETURN IF USER CAN.

;; RUUO -- RECORD HANDLER UUO ROUTINE 
;;%BI% 

↑RUUO:	LDB	A,[POINT 4,JOBUUO,=12]	;AC FIELD IS THE MINOR OPCODE
NORGC <
	CAILE	A,RDLAST		;
	JRST	USRUUO			;DEFAULT CASE IS USRUUO
	JUMPN	A,@RDISP(A)		;DISPATCH
RDREF:	SKIPE	A,FF			; DE-REFERENCE -- DO WE HAVE A RECD?
	SOSLE	-1(A)			; DROP COUNT BY ONE
	JRST	USRXIT			; GO EXIT FROM UUO LEVEL
UINCUU:	AOS	-1(A)			; SINCE WILL DO DEREFERENCING SOS AGAIN
	; OTHERWISE, FALL INTO USRUUO
	; (ACTUAL DELETION WILL BE SLOWED UP A BIT, SINCE WILL DO
	; YET ANOTHER SOSLE & WILL WASTE SOME EFFORT WITH EXTRANEOUS PUSHES
	; BUT THIS DOES MAKE THE CODE A BIT MORE MODULAR)
>;NORGC
RGC  <
	CAIG	A,RDLAST		;ONE WE CAN DISPATCH ON ??
	JRST	@RDISP(A)		;YES
					;NO, CALL THE HANDLER
>;RGC


USRUUO:	MOVE	A,FF			;A GETS THE RECORD ADDRESS
	JSP	FF,SAVALL		;SAVE ALL THOSE ACS
USRUUX:	LDB	FF,[POINT 4,JOBUUO,=12]	;GET MINOR OP AGAIN
UCALL0:	PUSH	P,FF			; OP CODE
	PUSH	P,A			; RECORD ID
	PUSH	P,[0]			; A PLACE HOLDER
	PUSHJ	P,@(A)			; CALL THE USER ROUTINE (POSSIBLY $REC$)
	POPJ	P,

USRUU1:	MOVE	A,FF			;LIKE USRUUO BUT RETURNS AC1
	JSP	FF,SAVALL		;SAVE SOME ACS
	PUSHJ	P,USRUUX		;DO THE REST
	MOVEM	A,-15(P)		;WHERE AC1 IS STORED ON THE STACK
	POPJ	P,			;RETURN WILL FALL INTO RSTALL

;;DISPATCH TABLE FOR RECUUO OP,ADR
;;


RDISP:
NORGC <
	JRST	RDREF	;0 -- DEREFERENCE E.G RECUUO 0,RECVAR
	JRST	USRUU1	;1 -- ALLOCATE: E.G RECUUO 1,[CLASSID]
	JRST	UINCUU	;2
>;NORGC
RGC <
	JRST	USRUUO	;0 -- DEREFERENCE (ACTUALLY AN ERROR)
	JRST	USRUU1	;1 -- ALLOCATE: E.G RECUUO 1,[CLASSID]
>;RGC
RDLAST ←← (.-RDISP)-1	

;;%BI%

DSCR OCTPNT, DECPNT UUO'S
PAR MOVE FF,ARG; JRST OCTPNQ -- RET VIA USRXIT
	OR MOVE A,ARG; PUSHJ P,OCTO
RES DECPNT -- WORD TYPED IN DECIMAL
 OCTPNT -- OCTAL
⊗

OCTPNQ: MOVE	A,FF		;GET ARGUMENT
	JSP	FF,SAVM		;SAVE MORE AC'S
OCTO:	SKIPA	C,[PUUO 1,B]
;;%##% CHECK NUMBER OF CHARS IF GOING TO .ERSTR
OCTOB:	MOVE	C,[PUSHJ P,.PUTBE]
	MOVEI	FF,10		;KEEP RADIX IN FF.
	JUMPGE	A,PNT
;;%##% OLD OCTPNT WASN'T HAPPY WITH NEG OCTS
	MOVEI	FF,=12		;JUST PRINT THE BYTES
PNTO.1:	MOVEI	B,0		;
	ROTC	A,3		;
	IORI	B,"0"		;
	XCT	C		;PUT IT OUT
	CAIN	FF,7		;FOR THE SPACE
	JRST	PNTO.2		;IN THE MIDDLE
	SOJG	FF,PNTO.1	;COUNT DOWN
	POPJ	P,		;DONE 
PNTO.2:	MOVEI	B,","		;PUT OUT ,,
	XCT 	C
	XCT	C
	SOJA	FF,PNTO.1	;GO ON

DECPNQ:	MOVE	A,FF		;GET ARGUMENT
	JSP	FF,SAVM
DECO:	SKIPA	C,[PUUO 1,B]
DECOB:	MOVE	C,[PUSHJ P,.PUTBE]
	MOVEI	FF,=10
	JUMPGE	A,PNT		; GREATER 0.
	MOVEI	B,"-"
	XCT	C
	MOVMS	A		; FOO1 ← ABS(FOO1)	;
PNT:	IDIV	A,FF		;FAMOUS DEC RECURSIVE NUMBER PRINTER.
	IORI	B,"0"
	HRLM	B,(P)
	SKIPE	A
	PUSHJ	P,PNT
	HLRZ	B,(P)
	XCT	C		;EITHER PRINT IT OR STORE IT
	POPJ	P,		;RETURN TO RETM
;;%##% WATCH COUNT WHEN STUFF A NUMBER
.PUTBE:	SOSG	.ERSTC		;ROOM LEFT????
	JRST	PRA.NO		;NO ROOM
	IDPB	B,.ERSTP	;YES
	POPJ	P,

DSCR FIX, FLOAT UUO'S (FIXQ,FLOAQ)
PAR MOVE FF,ARG	; JRST FIX/FLOA Q; RET VIA USRXIT
RES FIXED POINT EQUIVALENT IN AC SPECIFIED IN AC FIELD OF UUO
⊗

FIXQ:	MULI	FF,400		;THIS ALGORITHM STOLEN FROM F4.
	TSC	FF,FF
	EXCH	FF,A
	ASH	FF,-243(A)
	JRST	FXFLT		;STORE IN RIGHT PLACE.

FLOAQ:	IDIVI	FF,400000
	SKIPE	FF
	TLC	FF,254000
	TLC	A,233000
	FAD	FF,A
FXFLT:	LDB	A,[POINT 4,JOBUUO,12] ;RESULT REGISTER
	CAIG	A,1		;NUMBER OF AC'S SAVED
	 ADDI	 A,-1(P)	;ADJUST TO FIND STACK SPOT
	MOVEM	FF,(A)		;AND RETURN RESULT
	JRST	USRXIT		;AND RETURN TO USER

DSCR PRINIT -- INTERFACE TO SYSTEM PRINTING FACILITIES
INCLUDED HERE TO MAKE INTERCEPTION EASY FOR WHATEVER
PURPOSE AND TO MAKE CONVERSION TO TENEX EASY
⊗
PRINIT:				;IF NOT ASSEMBLED, FALL INTO ILLUUO

TENX <
	LDB	A,[POINT 4,JOBUUO,12]
	HRRZ	FF,JOBUUO
	TRNN	FF,777776	;IF ADDR. IS FF OR A GET ARG AND/OR
	ADDI	FF,-1(P)	;PUT ANSWER ON STACK WORD FOR FF OR A
	JRST	@.+1(A)
;TTCALL DISPATCH TABLE
	TTC0
	TTC1
	TTC2
	TTC3
	TTC4
	TTC5
	ILLUUO
	ILLUUO
	ILLUUO
	TTC11
	TTC12
	TTC13
	TTC14
	ILLUUO
	ILLUUO
	ILLUUO


TTC4:	;EFFECTIVELY SAME AS TTC0 GIVEN 10X WAKEUP BEHAVIOR
TTC0:	MOVEM	B,TTCSVB	;SAVE B.
TTC01:	HRRZI	1,100	;B34 of RFMOD word returned in 2 says
	JSYS	RFMOD	;that BKJFN has been done since last char was
	JSYS	PBIN	;read, i.e. this PBIN will get a re-run. This is
	CAIN	1,37	;best EOL-to-CRLF conversion hack I can devise.
	 JRST	TTCEOL	;It's impossible to stick a linefeed back in
TTC0RT:	MOVE	B,TTCSVB	;tty input buffer IN FRONT OF extant type-ahead.
	MOVEM	A,@FF
	JRST	USRXIT	;Returning just CR causes SAIL to look for non-
TTCEOL:	TRNE	2,2	;existent LF following. And setting a flag loses
	 JRST	TTC0BK	;when some random other code does a PBIN. This
	HRRZI	1,100	;way, random other code gets a 37 too (Oh well).
	JSYS	BKJFN	;but at least the pending LF is cleared (since
	 JFCL		;the BKJFN bit is cleared). This code returns a
	HRRZI	A,15	;CR on first reading of EOL and a LF on second.
	JRST	TTC0RT
TTC0BK:	HRRZI	A,12	;Second reading of eol here.
	JRST	TTC0RT	;"flag" is effectively cleared by PBIN.


TTC1:	HRRZ	1,@FF
	JSYS	PBOUT
	JRST	USRXIT

TTC2: ;Effectively same as TTC 5.

TTC5:	HRRZI	A,100
	MOVEM	B,TTCSVB ;SAVE B - NEW SIBE: B←CNT OF CHRS WAITING IF ANY
	JSYS	SIBE
	 AOSA	-2(P)	;Get char and skip return
	JRST	USRXIT	;NOSKIP, NO CHAR, B UNCHANGED
	JRST	TTC01

TTC3:	HRRO	1,FF
	JSYS	PSOUT
	JRST	USRXIT

TTC11:	HRRZI	1,100
	JSYS	CFIBF
	JRST	USRXIT


TTC12:	HRRZI	1,101
	JSYS	CFOBF
	JRST	USRXIT

TTC13:
TTC14:	HRRZI	A,100
	JSYS	SIBE
	 AOS	-2(P)		;CHAR HAS BEEN TYPED, SKIP RET (BUT
				;DON'T READ ANYTHING IN)
	JRST	USRXIT		;NOTHING, NOSKIP.
;This emulates DECUS's SKPINC & SKPINL. Stanford's TTCALL 14,
;is different. I have found one instance of its use (at PARSE&LINSTOP)
;which as far as I could tell wouldn't work on EXPORT systems,
;so I put that under a STANFO switch.

>;TENX

NOTENX <
IFN 0,<
	MOVE	A,FF		;SAVE ARGUMENT
	JSP	FF,SAVM		;GET MORE AC'S
	LDB	C,[POINT 4,JOBUUO,12]
	JRST	@PTBL(C)

PTBL:	GCH			;0 -- GET A CHAR
	PCH			;1 -- PRINT A CHAR
	0
	PST			;3 -- PRINT A STRING

PST:	TTCALL	3,@JOBUUO	;CALL SYSTEM
	POPJ	P,

PCH:	TTCALL	1,A		;PRINT CHAR
	POPJ	P,

GCH:	HRRZ	B,JOBUUO	;GET EFF ADDRESS
	CAIG	B,D
	 ADDI	 B,-5(P)	;RELOCATE INTO STACK.
	TTCALL	0,(B)		;AND READ A CHAR
	POPJ 	P,
>;0
>;NOTENX

DSCR ERROR UUOS
PAR AC FIELD IS INDEX INTO ERROR ROUTINE
SID SAVES THE WORLD
DES THE ASCIZ STRING INDICATED BY THE EFFECTIVE ADDRESS IS TYPED. THEN
 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.
⊗

ILLUUO:	
;;%BL%
	SKIPN	.UUOCN		;DID THE USER GIVE US SOMETHING ELSE TO TRY
	JRST	.ILL.		;NOPE, MUST BE AN ERROR
	POP	P,A		;GET BACK TO A MORE VIRGINAL STATE
	POP	P,FF		;NOW ALL ACS ARE BACK (P IS ONE TOO DEEP, BUT...)
	XCT	.UUOCN		;
	POPJ	P,
	
.ILL.:	MOVE	A,[ERR <Illegal UUO>]
	MOVEM	A,JOBUUO
ERRR:	JSP	FF,SAVM		;SAVE MORE AC'S
	LDB	B,[POINT 4,JOBUUO,12] ;CODE IN AC FIELD
	JRST	ERRW

ARERRR:	JSP	FF,SAVM		;SAVE MORE AC'S
	MOVSI	D,4		;PRINTING INSTRUCTIONS
	MOVEI	B,20		;ERROR CODE -- FATAL
	JRST	ERRX

IOERRR:	JSP	FF,SAVM		;SAVE MORE AC'S
	MOVEI	B,16		;ERROR CODE -- FATAL
ERRW:	MOVEI	D,0
ERRX:	ROT	B,-1		;CONTINUE BIT TO SIGN BIT
	MOVEM	B,%RECOV	;AND SAVE FOR TESTING LATER
	MOVE	C,-6(P)		;RETURN ADDRESS
	MOVEM	C,.DTRT.	;SAVE AS DDT RETURN ADDRESS
;;%##%  ADD A COUNT TO BE SURE DO NOT OVERFLOW
;;%BF% allow larger buuffers.  do things in this way to make
;;	old programs still able to work (sort of)
	SKIPN	C,.ERBWD	;INITIALIZED ??
	MOVE	C,[XWD .ERSWC*5*40,.ERSTR] ;.ERSWC*5 CHARS IN .ERSTR
	MOVEM	C,.ERBWD	;BE SURE PUT AWAY OK
	LSH	C,-5		;THE COUNT FIELD
	HLRZM	C,.ERSTC	;REMEMBER THE COUNT
;;%##%
	MOVEI	C,@.ERBWD
	HRLI	C,(<POINT 7,0>)	;MAKE UP THE BYTE PTR
	MOVEM	C,.ERSTP
;;%BF%
	MOVEI	A,[BYTE(7) 15,12,0]
	PUSHJ	P,PRA		;BEGIN EACH ERROR MESSAGE WITH CRLF.
	MOVE	A,JOBUUO	;GET UUO BACK
	TLZN	D,4		;DO NOT PRINT EFF ADDR OF ARRAY UUO
	 PUSHJ	 P,PRA		;PRINT ACSIZ STRING INTO ERSTR
	MOVE	A,JOBUUO
	PUSHJ	P,@URTBL(B)	;AND DO SPECIAL-CASE STUFF
	MOVEI	A,[BYTE(7) 15,12,0]
	PUSHJ	P,PRA		;TERMINATE WITH CRLF
	IDPB	FF,.ERSTP	;AND A ZERO.

;#PU# ACCUMULATOR D WAS NOT ZERO FOR ORDINARY ERRORS.
	SKIPE	D,%ERRC		;IF USERRR LEFT A POINTER
	 JRST	[MOVE D,1(D)	;GET BYTE POINTER
		 ILDB D,D	;GET FIRST RESPONSE CHARACTER
		 JRST .+1]
	SKIPN	.ERRP.		;DOES USER HAVE A ROUTINE?
	 JRST	 NOUSRR		;NO
	MOVE	C,[XWD D-15,D+1] ;AOBJN POINTER TO DO PUSHES
	PUSH	P,(C)		;PUSHES WILL CAUSE PDLOV
	AOBJN	C,.-1		;COUNT DOWN
				;CAN BLT OFF
	MOVE	USER,GOGTAB
	MOVE	C,[XWD -13,RACS] ;ALSO SAVE RUNTIME AC'S
	ADDI	C,(USER)	;RELOCATE
	PUSH	P,(C)
	 AOBJN	 C,.-1
	PUSH	P,UUO1(USER)	;SAVE RUNTIME RETURN ADDRESS
	SETZM	.ERRJ.		;ASSUME NO USER TRANSFER ADDRESS
	MOVE	A,-33(P)	;UUO RETURN ADDRESS
	SUBI	A,1
	PUSH	P,SP		;SAVE STRING STACK POINTER (OR,
				;IF COMPILER, MAYBE PARSER STACK)
	SKIPL	CONFIG		;IF IN COMPILER, GENERATE
	 JRST	 .+4
	MOVEI	SP,(P)		;A FAKE STACK BECAUSE OF CONFLICT
	HRLI	SP,-5		;WITH PARSE STACK
	ADD	P,X44
	PUSH	P,A		;ADDR OF UUO = ARG TO PROC.
	HRRZ	A,.ERSTP	;NOW COMPUTE LENGTH OF STRING
;;%BF%
	SUBI	A,@.ERBWD	;SAVED AWAY
	IMULI	A,5
	LDB	B,[POINT 6,.ERSTP,5]
	IDIVI	B,7
	MOVN	B,B
	ADDI	A,4(B)		;TOTAL NUMBER OF CHARACTERS (NOT INCL NULL)
	PUSH	SP,A		;TO STRING STACK.
;;%BF% -- also not too sure strngc likes indirects, so ...
	MOVEI	A,@.ERBWD
	HRLI	A,(<POINT 7,0>)	;MAKE UP THE BYTE PTR
	PUSH	SP,A
;;%BF%
	SKIPN	A,%ERRC		;TRACKS LEFT BY USERRR??
	 MOVEI	 A,[0
		    0]		;NO
	PUSH	SP,(A)
	PUSH	SP,1(A)
	PUSHJ	P,@.ERRP.
	SKIPGE	CONFIG		;IF IN COMPILER, THEN
	 SUB	 P,X44		;BACK UP THE STACK.
	POP	P,SP		;RESTORE STRING STACK.
	MOVE	USER,GOGTAB
	POP	P,UUO1(USER)	;RESTORE THINGS
	MOVEI	B,12
	MOVEI	C,RACS+12(USER)
	POP	P,(C)
	SUBI	C,1
	 SOJGE	 B,.-2		;TILL DONE
	HRLZI	FF,D+1-15(P)	;FROM HERE ON STACK
	HRRI	FF,D+1		;FIRST AC TO RESTORE
	BLT	FF,15		;GET THEM BACK
	SUB	P,[XWD 15-D,15-D] ;ADJUST

	MOVEM	A,D		;SAVE PRINTING INSTRUCTIONS
	SKIPE	B,.ERRJ.	;IF USER SPECIFIED RETURN ADDRESS
	 MOVEM	 B,-6(P)	;REPLACE CURRENT ONE.
NOUSRR:	
	TLZN	D,1		;IF INHIBITED,
;;%BF%
	 PUUO	 3,@.ERBWD	;PRINT ERROR STRING.
	MOVE	A,-6(P)		;RETURN ADDRESS
	TLZN	D,2		;IF NOT INHIBITED,
	 PUSHJ	 P,CALLEDFROM	;PRINT SAIL MESSAGE
	SETZM	%ERRC		;NO MORE USERRR SPEC.

	PUSHJ	P,WATNOW	;GO GET A RESPONSE.
	 MOVEM	 A,-6(P)	;REPLACE RETURN ADDRESS
	POPJ	P,



HERE(DT.RET)			;JRST HERE TO GET BACK FROM DDT
	JRST	@.DTRT.		;GONE.


DSCR CALLEDFROM -- PRINTS 'CALLED FROM' XXX 'LAST SAIL CALL AT'
PAR WHERE XXX+1 IS PRESENTED IN AC A.
RES -- ONLY TYPING
SID DESTROYS A,B,C
⊗

CALLEDFROM:
	PRINT	<Called from >
	MOVEI	A,-1(A)
	PUSHJ	P,OCTO		;PRINT IT IN OCTAL
	SKIPGE	CONFIG		;RUNTIMES
	 JRST	NOLSCL
	PRINT	 <  Last SAIL call at >
	MOVE	A,GOGTAB
	HRRZ	A,UUO1(A)
	SOS	A
	PUSHJ	P,OCTO
NOLSCL:	TERPRI
	POPJ	P,		;END OF CALLEDFROM ROUTINE.





DSCR WATNOW -- ROUTINE TO GET AND PROCESS USER RESPONSES.
PAR RECOV IS >0 IF RECOVERY IMPOSSIBLE, <0 IF RECOVERY POSSIBLE
	D,IF NON ZERO, HAS A RESPONSE CHARACTER IN IT.
RES RETURNS TO CALLER+1 IF TO GO TO DDT OR EXIT.  IN THIS
	CASE, AC 'A' HAS A NEW RETURN ADDRESS
    RETURNS TO CALLER+2 IF USER SAID 'CONTINUE'
SID CLOBBERS FF,A
⊗


WATNOW:	
IMSSS<;IMSSS KLUDGE FOR STUDENT SYSTEM
	PUSHJ	P,KIDCHK	
>;IMSSS
	MOVE	A,GOGTAB	;ADDRESS OF USER TABLE
	HRRZ	FF,TOPBYTE(A)	;CURRENT STRING POINTER
	CAMLE	FF,STTOP(A)	;IN RANGE?
	 JRST	 [TERPRI <String space exhausted unexpectedly.
Any attempt to continue will cause a restart.>
		  MOVEI FF,[JRST @JOBREN]
		  MOVEM FF,-7(P) ;NEW RETURN ADDRESS.
;;%##% RHT MAKE IT SO THE GUY HAS TO AGREE TO RESTARTING
		SETZB	D,%ERGO
		  JRST .+1]
	SKIPE	%ERGO		;CONTINUOUS CONTINUE?
	JRST	GOTRY		;AUTOMATIC CONTINUE SET
	SKIPE	A,D		;IF A RESPONSE CHARACTER IS SPECIFIED,
	 JRST	 RESGOT		;GO USE IT.
QUES:	PUUO	2,A		;INCHRS
	 JRST	 PRMPT		;NO CHARACTER -- PROMPT
	PUUO	11,0		;CLEAR INPUT BUFFER
	CAIN	A,12		;IF FEED, USE IT
	 JRST	 RESGOT		;CAN ONLY TYPE AHEAD LF.
PRMPT:	MOVEI	A,"?"		;PRINT ? FOR IRRECOVERABLE ERRORS,
	SKIPGE	%RECOV		; ↑ FOR RECOVERABLE ONES.
	MOVEI	A,"↑"		;SOMETHING PRINTABLE.
	PUUO	1,A		;PRINT IT
	PUUO	0,A		;GET RESPONSE CHAR
	CAIN	A,15		;IF RESPONSE CR, THEN
	 PUUO	 2,FF		; INCHRS
	 JFCL			; DON'T DO INCHRW HERE BECAUSE OF PTY'S
RESGOT:
	CAIL	A,"a"		;lower case?
	SUBI	A,40		;YES, CONVERT TO UPPER
	CAIN	A,"E"		;RE-EDIT?
	 JRST	 EDIT		; YES
	CAIN	A,"T"		;TVEDIT?
	 JRST	 TVEDIT
	CAIN	A,"S"		;START?
	 JRST	 STRTIT		;YES
	CAIN	A,"X"		;EXIT
	 JRST	 XIT
	CAIN	A,"D"		;DDT
	 JRST	 DDIT		;.
;;%##% BY JFR 11-17-74
BAIL<
	CAIN	A,"B"		;BAIL?
	 JRST	 BAILIT
>;BAIL
;;%##% ↑
	CAIE	A,"A"
	CAIN	A,12		;CONTINUE AUTOMATISCH?
	 SETOM	 %ERGO		;YES

	CAIN	A,"C"		;CONTINUE AT ALL COSTS?
	 JRST	EPOPJ		;YES -- SKIP RETURN.
	CAILE	A,15		;TRY TO CONTINUE?
	 JRST	 BADRSP		;INCORRECT RESPONSE

GOTRY:	SKIPGE	%RECOV		;CAN WE CONTINUE?
	 JRST	 EPOPJ		;YES -- SKIP RETURN
	TERPRI	<Can't continue>
	JRST	QUES

STRTIT:	HRRZ	A,JOBSA
	JRST	(A)		;AWAY WE GO!

IMSSS<;KLUDGE FOR STUDENT SYSTEM
KIDCHK:	PUSH	P,A
	PUSH	P,B
	MOVEI	A,101		;PRIMARY INPUT
	JSYS	RFMOD
	TRNE	B,1B33 		;A STUDENT JOB?
	  JRST	ISKIDY		;YES
	POP	P,B
	POP	P,A
	POPJ	P,

ISKIDY:	HRROI	A,[ASCIZ/
Sorry, system error.
/]
	JSYS	PSOUT
	SETO	A,
	JSYS	KLGOT		;LOG HIM OUT
>;IMSSS

;;%##% BY JFR 11-17-74
BAIL<
BAILIT:	SKIPN	BAILOC(USER)
	 JRST	 [TERPRI <No BAIL>
		  JRST QUES]
	MOVEI	A,[PUSH P,.DTRT.	;ADDR+1 OF UUO
		   JRST @BAILOC(USER)]	;HEAVE-HO!
	POPJ	P,		;NON-SKIP RETURN.
>;BAIL
;;%##% ↑

NOTENX <
DDIT:	SKIPN	JOBDDT
	 JRST	 [TERPRI <No DDT>
		  JRST QUES]	;NO SUCH ANIMAL
;;%##%
EXPO <
	TERPRI	<
TYPE DT.RET$G TO CONTINUE
>
>;EXPO
	SKIPA	A,[[JRST @JOBDDT]] ;PREPARE TO CALL DDT
XIT:
	MOVEI	A,[CALL6 (EXIT)]	;PREPARE TO EXIT
	POPJ	P,		;NON SKIP RETURN.


EPOPJ:	AOS	(P)		;SKIP RETURN
	POPJ	P,
>;NOTENX

TENX <	;TENEX CODE TO GET UDDT (DEFINED IN THE FILSPC SECTION OF HEAD) 
	;IF NO DDT ALREADY HERE
DDTORG←←770000
DDTPAG←←770
UDTSYM←←DDTORG+1			;UDDT KEEPS A SYMBOL TABLE POINTER HERE
DDIT:	SKIPE	JOBDDT
	  JRST [HRROI	1,[ASCIZ/
Type DT.RET$G to continue.
/]
		JSYS	PSOUT
		MOVEI 	A,[JRST @JOBDDT]
		POPJ	P,]
	PUSH	P,1
	PUSH	P,2
	MOVE	1,[XWD 400000,DDTPAG]	;XWD THIS FORK, PAGE 770	
	JSYS	RPACS			;TEST FOR PAGE 770
	TLNN	2,10000			;DOES PAGE 770 EXIST?
	   JRST	GTUDDT			;NOPE
	MOVE	1,DDTORG
	CAME	1,[JRST DDTORG+2]	;DOES IT LOOK LIKE UDDT?		
	   JRST	GTUDDT			;NOPE
GOTUDT:	HRROI	1,[ASCIZ/
Type DT.RET$G to continue.
/]
	JSYS	PSOUT
	POP	P,2
	POP	P,1	
	MOVEI	1,[JRST DDTORG]		;SET UP FOR CALL
	POPJ	P,

GTUDDT:	MOVSI	1,1
	HRROI	2,[UDTFIL]
	JSYS	GTJFN
	   JRST	[HRROI	1,[ASCIZ/
Cannot GTJFN file:
/]
		 JSYS PSOUT
		 HRROI	1,[UDTFIL]
		 JSYS PSOUT		
		 JSYS HALTF
		]
	PUSH	P,1			;SAVE JFN
	MOVEI	1,400000		;THIS FORK
	JSYS	GEVEC			;GET ENTRY VECTOR INTO 2
	POP	P,1			;JFN FOR UDDT FILE	
	HRLI	1,400000		;THIS FORK
	JSYS	GET
	MOVEI	1,400000		;THIS FORK
	JSYS	SEVEC			;PUT BACK THE ENTRY VECTOR
	MOVE	1,JOBSYM		;SET UP SYMBOL TABLE POINTER
	MOVEM	1,@UDTSYM		;SAVE FOR USER
	JRST	GOTUDT			;AND RETURN

XIT:	MOVEI	A,[JRST DOHLTF]		;TENEX VERSION OF EXIT CODE
	POPJ	P,

EPOPJ:	AOS	(P)			;SKIP RETURN
	POPJ	P,
	
DOHLTF:	HRROI	A,-1
	JSYS	CLOSF				;CLOSING ALL FILES
	  JFCL				;IS PROBABLY DONE 
	JSYS	HALTF			;AUTOMATICALLY ON
	JRST 	.-1			;THE DEC SYSTEM

>;TENX

;;%##% BY JFR 11-17-74
NOBAIL<
BADRSP:	TERPRI	<Reply [CR] to continue,
[LF] to continue automatically,
"D" for DDT, "E" to edit,
"X" to exit, "S" to restart>
	JRST	QUES		;GET ANOTHER RESPONSE.
>;NOBAIL
BAIL<
BADRSP:	TERPRI	<Reply [CR] to continue,
[LF] to continue automatically,
"D" for DDT, "E" to edit, "B" for BAIL,
"X" to exit, "S" to restart>
	JRST	QUES		;GET ANOTHER RESPONSE.
>;BAIL
;;%##% ↑


SUBTTL	  Special Printing Routines For Error Handler

DSCR UUO ERROR MESSAGE ROUTINES AND THEIR INDICES (AC FIELD OF UUO)
SID CLOBBERS A,B,C,D
⊗

↑↑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
	IOER2		;16-17 --SECOND HALF OF IOERR
	ARER2		;20-21 --SECOND HALF OF ARRERR

UUOPRT: PUSH	P,A		;SAVE UUO
	HLRZ	A,A
	PUSHJ	P,OCTOB		;TYPE IT
	POP	P,A		;RESTORE
	HRRZS	A
	JRST	OCTOB		;TYPE 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
.PRSM:	HRRI	A,$PNAME(LPSA)	;PTR TO STRING DESCRIPTOR
PRASC:	HRRZ	B,(A)		;#CHARACTERS
	MOVE	A,1(A)		;STRING BP
	MOVEI	C,0		;NO ADJUSTMENT
;;%##% WATCH COUNT
	MOVE	D,[PUSHJ P,.PUTFE]
	JRST	PRSL1

IOER2:	TLNN	A,740		;AC FIELD SPECIFIED?
	 POPJ	 P,		;NO -- DONE
				;ELSE PRINT WHAT IS IN LPSA
;;%##% MUST WATCCH COUNT
SIXPRT:	MOVE	D,[PUSHJ P,.PUTFE]
	SKIPA	A,[POINT 6,LPSA];GET FROM HERE
PSIX:	HRLI	A,(<POINT 6,0>) ;UUO ADDR IS ADDR OF SIXBIT
	MOVEI	C,40		;ADJUSTMENT
	MOVEI	B,6		;PRINT 6 CHARS
	JRST	PRSL1

PRSL:	ILDB	FF,A		;CHARACTER
	ADDI	FF,(C)		;ADJUSTMENT
CMU <
	CAIN	FF,30		;UNDERBAR?
	MOVEI	FF,41		;INTO EXCL
	CAIN	FF,33		;NOT EQUAL
	MOVEI	FF,43		;INTO HASH
>;CMU
	XCT	D		;PUSH TO ERROR STRING OR TYPE IT.
PRSL1:	SOJGE	B,PRSL
UPOPJ:	POPJ	P,

AC1PRT:	MOVE	A,GOGTAB	;GET USER TABLE PTR
	SKIPA	A,UUO1(A)	;SOMEONE STORED RIGHT THING HERE
ACPRT:	HRRZ	A,-7(P)		;RETURN ADDRESS
	LDB	A,[POINT 4,-2(A),12] ;AC # FROM PREV INSTR
	CAIG	A,D		;IF BIN SAVED AC'S
	 ADDI	 A,-6(P)	;RELOCATE
	MOVE	A,(A)		;PICK UP VALUE.
	JRST	DECOB		;PRINT IT IN DECIMAL

ARER2:	PUSH	P,A		;SAVE UUO
	MOVEI	A,[ASCIZ /Invalid index for array /]
	PUSHJ	P,PRA		;TO ERROR STRING.
	MOVE	A,(P)		;GET POINTER TO ARRAY NAME
	PUSHJ	P,PRASC		;PRINT ARRAY NAME
	MOVEI	A,[ASCIZ /. Index no. /]
	PUSHJ	P,PRA
	POP	P,A		;RESTORE UUO
	LDB	A,[POINT 4,A,12]
	PUSHJ	P,DECOB		;PRINT INDEX NUMBER
	MOVEI	A,[ASCIZ /. Value is /]
	PUSHJ	P,PRA
	JRST	ACPRT		;PRINT VALUE IN PRECEDING AC.

PSIXQ:	MOVE	A,JOBUUO	;UUO
	JSP	FF,SAVM		;GET STACK AND AC'S
	MOVE	D,[PUUO 1,FF]	;PRINT DIRECTLY
	JRST	PSIX		;TYPE IT.


PRA:	HRLI	A,(<POINT 7,0>)	;PUSH STRING TO ERROR BUFFER
PRA.CK:	SOSG	.ERSTC		;ENOUGH ROOM ??
	JRST	PRA.NO		;NOPE
	ILDB	FF,A
	JUMPE	FF,UPOPJ	;DONE AT ZZERO BYTE
	IDPB	FF,.ERSTP
	JRST	PRA.CK		;LOOP

PRA.NO:	SKIPL	.ERSTC		;ALREADY COMPLAINED??
	TERPRI	<.... ERROR MESSAGE TOO LONG .... 
>
	POPJ	P,

;;%##% ANOTHER COUNT WATCHER
.PUTFE:	SOSG	.ERSTC			;ROOM???
	JRST	PRA.NO		;NOPE
	IDPB	FF,.ERSTP	;YEP
	POPJ	P,
DSCR USERERR(VALUE,CODE,"MSG","RESPONSE");
CAL SAIL
⊗

HERE (USERERR)
;; WE REALLY OUGHT TO HAVE ANOTHER UUO THAT CAN TAKE SOMETHING 
;; OTHER THAN ASCIZ.

	MOVE	USER,GOGTAB
	MOVEI	A,1		;BE SURE THAT DONT GC AT BAD TIME
	AOSL	REMCHR(USER)	;
	PUSHJ	P,STRNGC	;
	IBP	TOPBYTE(USER)	;BE SURE THAT HAVE NEITHER STRING AT TOP
	PUSHJ	P,INSET		;GET TO FW BNDRY
	PUSH	SP,[1]		;CONCATENATE A NULL TO END OF RSP STRING
	PUSH	SP,[POINT 7,[0]]
	PUSHJ	P,CAT
	MOVE	TEMP,-3(SP)	;EXCHANGE RESPONSE AND MSG STRINGS ON STACK
	EXCH	TEMP,-1(SP)
	MOVEM	TEMP,-3(SP)
	MOVE	TEMP,-2(SP)
	EXCH	TEMP,(SP)
	MOVEM	TEMP,-2(SP)
	PUSHJ	P,INSET		;
	PUSH	SP,[1]		;CONCATENATE A NULL FOR TTCALL
	PUSH	SP,[POINT 7,[0]]
	PUSHJ	P,CAT
	MOVEI	TEMP,-3(SP)	;ADDRESS OF RESPONSE STRING.
	MOVEM	TEMP,%ERRC	;SAVE FOR ERROR UUO.
;;%##% BY JFR 11-19-74
NOBAIL<
	POP	P,UUO1(USER)
	SKIPG	TEMP,(P)	;IS CODE 0?
>;NOBAIL
BAIL<
	POP	P,UUO1(USER)	;ADDR+1 OF CALL
	PUSH	P,UUO1(USER)	;MUST NO FIDDLE WITH STACK, OR BAIL WON'T WORK
	SKIPG	TEMP,-1(P)	;IS CODE 0?
>;BAIL
;;%##% ↑
	ERR.	@(SP)		;YES, NO CONTINUATION POSSIBLE
	CAIN	TEMP,1		;IS CODE 1?
	ERR.	1,@(SP)		;YES, JUST PRINT ERROR, ALLOW CONT
	CAIGE	TEMP,2		;IS IT SOMETHING ELSE
	JRST	USERBAK		;NO
;;%##% BY JFR 11-19-74
NOBAIL<
	MOVE	TEMP,-1(P)	;YES, SET UP SO ERR. GUY WILL PRINT VALUE
>;NOBAIL
BAIL<
	MOVE	TEMP,-2(P)	;YES, SET UP SO ERR. GUY WILL PRINT VALUE
>;BAIL
;;%##% ↑
	ERR.	7,@(SP)		; AND DO IT
USERBAK:
	SUB	SP,X44
;;%##%
NOBAIL<
	SUB	P,X22
>;NOBAIL
BAIL<
	SUB	P,X33
>;BAIL
;;%##% ↑
NOBAIL<
	JRST	@UUO1(USER)	;RETURN FROM ROUTINE.
>;NOBAIL
BAIL<
	JRST	@3(P)		;RETURN--UUO1 MAY HAVE BEEN CLOBBERED BY BAIL
>;BAIL

DSCR ERMSBF
CAL	SAIL -- ERMSBF(#CHARS)
DES	WILL CALL CORGET, IF NEED BE TO ENSURE THAT YOU CAN HAVE AT LEAST
	THE SPECIFIED NUMBER OF CHARS-1 IN YOUR ERROR MESSAGES.
	SETS UP .ERBWD TO BYTE (13)CHARCNT(23)BUFADR
⊗

;;%BR% WAS A HEREFK
HERE(ERMSBF)
	PUSHJ	P,SAVE
	MOVE	A,-1(P)		;GET NEW BUFFER, IF NEED IT
	MOVEI	B,0		;
	CAIGE	A,.ERSWC*5	;WILL .ERSTR WORK ??
	JRST	FROLD		;YES THE 0 WILL FORCE ITS USE BY NEXT ERR UUO
	MOVE	C,A		;HOW MANY WORDS??
	IDIVI	C,5		;
	ADDI	C,1		;FOR SAFETY'S SAKE
	PUSHJ	P,CORGET	;TRY & GET A BLOCK
	ERR	<CORGET OUT OF ROOM>
	DPB	A,[POINT =13,B,12] ; COUNT INTO B
FROLD:	EXCH	B,.ERBWD	;
	JUMPE	B,ERSXT		;WAS NULL BEFORE ??
	MOVEI	B,@B		;GET ADDRESS
	CAIE	B,.ERSTR	;WAS .ERSTR BEFORE ??
	PUSHJ	P,CORREL	;NO, MUST BE A CORGET BLOCK
ERSXT:	MOVE	LPSA,X22
	JRST	RESTR		;GO QUIT

SUBTTL	  Code to Handle Linkage to Editors

NOTENX <
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 #
	PUUO	0,B		;SEE IF FILE NAME SPECIFIED
	CAIE	B,15		;CR?
	 JRST	 GTNAM		; NO, NAME SPECIFIED
	PUUO	0,B		;SNARF UP LINE FEED AFTER CR
	SKIPL	CONFIG		;IF IN THE COMPILER,
	 JRST	 GTIT
	PUSH	P,[0]		;USE SPECIAL CALL TO SET UP AC'S
	PUSHJ	P,@.ERRP.	;...
	JRST	GTIT		;GO PROCESS.

GTNAM:	CAIE	B," "		;DELETE LEADING BLANKS
	 JRST	 MKNAMM
	PUUO	0,B
	JRST	GTNAM

MKNAMM:	CAIN	B,15		;GO BACK ON CR
	 JRST	 AUTO
	MOVE	C,[POINT 6,13] ;COLLECT FILE NAME HERE
MKNLP:	CAIE	B," "		;DONE?
	CAIN	B,15
	 JRST	 GTIT1		; YES
	TRZN	B,100		;MAKE SIXBIT
	TRZA	B,40
	TRO	B,40		
	CAIN	B,'.'
	SKIPA	C,[POINT 6,14] ;ADJUST TO GET EXTENSION
	IDPB	B,C		;CHAR OF FILENAME
	PUUO	0,B
	JRST	MKNLP


GTIT1:	CAIN	B,15
	PUUO	0,B

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,<E>)	 	;NO, TV (ACTUALY E.DMP)
	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
###### ??????? THIS PAGE CONTAINS CALLIs STILL ???????? ########
⊗
NOCMU <
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,OCTQ	;OUTPUT OCTAL
	MOVEI	1,","
	PUSHJ	P,OUT1
	HRRZ	1,11
	PUSHJ	P,OCTQ
	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,
OCTQ:	IDIVI	1,10
	HRLM	2,(P)
	SKIPE	1
	PUSHJ	P,OCTQ
	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
>;NOCMU

;;*****************
CMU < ;;
EDITG: 	MOVEI	P,[SIXBIT /SYS/
		   SIXBIT /LINED/
		  0 ↔ 0 ↔ 0 ↔ 0 ]
;;	SKIPE	14	;DID HE TYPE "E FILE"?
	HRLI	P,1	;YES
;%BV% CHANGE RUN CALL TO CALLI -22 FOR CMU
RNNIT:	CALLI	P,-22	;RUN IT
	JRST	4,0	;HALT
>;CMU

>;NOTENX

TENX <
NOIMSSS<
EDIT:
TVEDIT:	TERPRI <
Automatic switching to editors not implemented >
	JRST	WATNOW
>;NOIMSSS

IMSSS<
EDIT:	TDOA	A,[-1]	;INDICATE STOPGAP
TVEDIT:	SETZ	A,	;INDICATE TERMINAL-DEPENDENT EDITOR
	SKIPE	.ERRP.	;ANYTHING THERE?
	  JRST	TVEDI1	;YES
	TERPRI <You cannot edit from here.>
	JRST	WATNOW
TVEDI1:
	PUSH	P,A	;INFORMATION ABOUT WHICH EDITOR TO THE STACK
	MOVEI	A,1		;INDICATE THAT WE WANT AN EDIT
	PUSHJ	P,@.ERRP. ;FOR COMPILER, TO MYERR
	JRST	WATNOW	;WHAT -- IT CONTINUED?
>;IMSSS
>;TENX

SUBTTL	SAVE, RESTR, INSET -- General Utility Routines

DSCR SAVE
CAL PUSHJ
DES This routine saves registers 0-RF (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	; LOAD PTR TO USER RE-ENTRANT TABLE
	HRRZI	TEMP,RACS(USER)	;XWD FF,SAVEADDR
	BLT	TEMP,RACS+RF(USER) ;SAVE FF THRU RF  
	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
	CAME	RF,RACS+RF(USER) ;TEMPORARY CHECK TO MAKE SURE NOT CLOBBERED.
	 ERR	 <DRYROT: RF CLOBBERED AT RESTR>,1
	BLT	TEMP,RF		;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 PNTS TO GOGTAB
DES REMCHR is first adjusted, and STRNGC called if necessary.
 Then TOPBYTE is adjusted.
⊗


;; #SX# INSET SHOULD REALLY BE HERE'D
HERE(INSET)
;; #SX#
	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>
	   ,<.EXPIN,.TRACS,X11,GOGTAB>
	   ,<CORGET, CORREL, ... -- CORE ALLOCATION ROUTINES>)
SUBTTL	Core Service Routines -- General Description

DSCR BEGIN CORSER
⊗
IFN ALWAYS,<BEGIN CORSER>
CMU <
GGAS <
IFE ALWAYS,<EXTERNAL TOP2,GLBPNT,GAS>
>;GGAS
>;CMU
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:	ptr to PREV,, ptr to 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,, ptr to HEAD	;x=1 if in use, 0 if free

ptr to PREV is zero if this block is first on free storage list.
 ptr to 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) pnts at 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) NEQ  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) NEQ 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.
CMU <
DEBGAS ←← 0	;FOR GAS CORE STUFF
>;CMU
;  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
CMU <
GGAS <
TM	←←  7			;MODULE NUMBER
GASAD	←←  4			;ADDRESS OF GAS
>;GGAS

>;CMU
SUBTTL	  Utility Routines

DSCR UNLINK
CAL PUSHJ
PAR  ptr to 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)		;PTR TO NEXT BLOCK
	HLRZ	PREV,(THIS)		;PTR TO 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 ptr to  core block to be placed on free storage list
 AC LAST ptr to 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 then 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
⊗

CMU < GGGON
>;CMU
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>
		 CALL6	(EXIT)]
	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
NOCMU <
	MOVE	USER,[XWD GLUSER+LEABOT+20,GLUSER+LEABOT+21]
	SETZM	GLUSER+LEABOT+20
>;NOCMU
CMU <
NOGGAS <
	MOVE	USER,[XWD GLUSER+LEABOT+20,GLUSER+LEABOT+21]
	SETZM	GLUSER+LEABOT+20
>;NOGGAS
GGAS <
	MOVE	USER,[XWD GLUSER+ZAPBEG,GLUSER+ZAPBEG+1]
	SETZM	GLUSER+ZAPBEG
>;GGAS
>;CMU
	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
CMU <
GGAS <	;LET'S GET SOME CORE TO USE
	HRRZ	USER,GLUSXX		; ****** KLUGE TO GET AROUND LOADER FUCKUP
	MOVEI	TEMP,(THIS)
	ADDI 	TEMP,2000
	HRLZS	TEMP
	CALLI	TEMP,11	;CORE UUO
	ERR	<CORE2I: CAN'T GET CORE FOR GAS>
	HRROS	JOBHRL		;SO MONITOR WON'T SAVE HISEG
	SETZM	GAS	;WE HAVE NO GGAS YET
>;GGAS
>;CMU
	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

CMU <
GLUSXX:	GLUSER			;KLUGE TO GET AROUND FAIL OR LOADER LOSSAGE AT CMU
>;CMU
>;GLOB

CMU <	GGGOFF
>;CMU

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:	
CMU < GGGON
>;CMU
GLOB <
	SKIPN	GLBPNT		;HAS GLOBAL MODEL BEEN INITIALIZED?
	 PUSHJ	P,CORE2I		;NO --INITIALIZE IT.
>;GLOB
CMU < GGGOFF
>;CMU
	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

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

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:	CALL6	(LAST,SEGSIZ)		;FIND OUT HOW BIG.
	TRO	LAST,400000		;SINCE ANDY DOES NOT GIVE ME THIS.
	JRST	NEWB1
>;GLOB
CMU <
GGAS <
NEWB2:	HRRZ	LAST,JOBHRL		;FIND HOW BIG
	JRST	NEWB1
>;GGAS
>;CMU
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


NOCMU <
COR21:	ADDI	SIZ,3			;3 WORDS FOR CONTROL INFO
>;NOCMU
CMU <
GGAS <
	SKIPN	USCOR2(USER)		;ARE WE INSTRUCTED TO USE CORE2?
	JRST	COR21			;NOPE -- GO AHEAD.
↑↑CORE2: 
IFN DEBGAS,<
	SKIPE	PRTCOR
	TERPRI	<CORE2:>		;FOR GAS
>;DEBGAS
	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.
		MOVEI	TEMP,0
		CALLI	TEMP,31		;SLEEP 0 SECONDS
		 JRST .-1]
	MOVEI	USER,GLUSER		;USE THIS VERSION OF USER.
	PUSHJ	P,JUSTSAVE		;JUST SAVE THE ACCUMULATORS.
>;GGAS


COR21:	ADDI	SIZ,3			;3 WORDS FOR CONTROL INFO
IFN DEBGAS,<
	CAIN	USER,GLUSER
	SKIPN	PRTGAS
	JRST	GETPRT
	PRINT	<   MODULE=>
	OCTPNT	TM
	PRINT	<   SIZE=>
	OCTPNT	SIZ
GETPRT:
>;IFN DEBGAS
>;CMU
	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)		;PTR TO 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  MEANS IN USE
CMU <
IFN GASSW,<TRNN	THIS,400000
	JRST	COR2GT
	MOVEM	TM,(THIS)		;STORE MODULE #
IFN DEBGAS,<
	SKIPN	PRTGAS
	JRST	COR2GT
	PRINT	<   LOC=>
	MOVE	TEMP,THIS
	OCTPNT	TEMP
	TERPRI
>;IFN DEBGAS
COR2GT:
>;IFN GASSW
>;CMU
	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 PNTS TO 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
;;%BB% dcs cmu-style pre/post trap calls
CMU <	GGGON		;SO TRPCAL WORKS ?
>;CMU
	TRPCAL	(SIZ,TEMP,X11,X11,.EXPINT) ;TRAP TO USER IF DESIRED
CMU <	GGGOFF		;
>;CMU
GLOB <
	CAIN	USER,GLUSER		;THIS IS HOW WE TELL
	JRST	[CALL6 (TEMP,CORE2)	;GET SOME CORE
;;%##% GO AHEAD & TRAP A LOSSAGE 
		 JRST  BLEWIT		;HE SPAT UPON OUR HUMBLE REQUEST.
		 PUSHJ	P,NEWB2		;LINK IT UP
		 JRST  GETM.1]
>;GLOB
CMU <
GGAS <
	CAIN	USER,GLUSER
	JRST	[ HRLZ	TEMP,TEMP	;
		  TLO	TEMP,400000	;
		  CALL6 (TEMP,CORE)	; DO THE CORE UUO
		  JRST	BLEWIT		; NO JOY
		  MOVNS  TEMP
		  GGGON
		  TRPCAL(SIZ,TEMP,X11,X11,.EXPINT) ;TRAP TO LOSER
		   GGGOFF
		  HRROS	JOBHRL		;SO DONT SAVE HISEG
		  PUSHJ P,NEWB2		;LINK IT UP
	  	  JRST GETM.1 ]		;
>;GGAS
>;CMU
;;%##% TWO SEGS OVER 400000 IS A LOSER
UP <
TENX <
;;ON TENEX, SEGLOC MAY BE ALMOST ANYWHERE
IFNDEF SEGLOC, <SEGLOC←←400000>
	CAIL	TEMP,SEGLOC		;WELL??
	JRST	BLEWIT			;GREAT EROR
>;TENX
NOTENX <
	CAIL	TEMP,400000		;
	JRST	BLEWIT			;
>;NOTENX
>;UP
NOTENX <
	CALL6	(TEMP,CORE)		;ASK FOR MORE
;;%##% USED TO BE GETRST
	 JRST	BLEWIT			;CAN'T GET IT
>;NOTENX
TENX <
	HRRZM	TEMP,JOBREL		;SEE COMMENT @ NODDT ABOVE
>;TENX
;;%BB% dcs ! for 2
	MOVNS	TEMP
	TRPCAL	(SIZ,TEMP,X11,X11,.EXPINT) ;TRAP TO USER NOW THAT HAVE CORE
	PUSHJ	P,NEWBLK		;MAKE TOP LOOK LIKE FREE BLOCK
GETM.1:	CAMLE	SIZ,1(THIS)		;NOW SHOULD FIT
	 CORERR	 <DRYROT -- EXPAND CODE GLUBBED UP>
	JRST	GETCOR			;GO GET BLOCK
;;%##% HERE IF BLOWN IT
BLEWIT: MOVNS SIZ
	MOVNS TEMP
;;%BB% !
	TRPCAL(SIZ,TEMP,X11,X11,.EXPINT)

GETRST:	
CMU < GGGON
>;CMU
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
CMU <	GGGOFF
>;CMU
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
CMU <	GGGON
>;GGGOFF
GLOB <
	TRNE	THIS,400000		;CHECK TO SEE IF CORE2
	CORERR	<NO CANINC SECOND SEGMENT SPACE>
>;GLOB
CMU <	GGGOFF
>;CMU
	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
CMU <
GGAS <
	TRNN	THIS,400000		;IS IT SECOND SEGMENT ADDRESS?
	JRST	NOSGR			;NO
↑↑CORE2R:
IFN DEBGAS,<SKIPE	PRTGAS
	TERPRI	<CORREL: >
>
	MOVEI	USER,GLUSER		;USE THIS ONE.
	AOSE	CORLOK			;SEE IF WE CAN GET IN.
	JRST	[SOS CORLOK
		MOVEI	TEMP,0
			CALLI	TEMP,31
		 JRST .-1]
NOSGR:
>;GGAS
>;CMU
	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
CMU <
IFN DEBGAS,<
	TRNE	THIS,400000
	SKIPN	PRTGAS
	JRST	RELPRT
	PRINT	<   LOC=>
	MOVE	TEMP,THIS
	OCTPNT	TEMP
	PRINT	<   SIZ=>
	OCTPNT	SIZ
	PRINT	<   MODULE=>
	OCTPNT	(TEMP)
RELPRT:
>;IFN DEBGAS
>;CMU
	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)		;PTR TO 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  PTR TO  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
CMU <
GGAS <
	CAIN	USER,GLUSER	;HI GUY?
	JRST	[HRRZ	TEMP,JOBHRL	;YES
		CAIG	LAST,(TEMP)	;HIEST BLOCK?
		JRST	LNKRT		;NOPE
		HRLZI	TEMP,=1023(THIS)	;STICK IN HI SEG HALF
		TRPCAL	(SIZ,TEMP,X11,X11,.EXPINT)
		CALL6	(TEMP,CORE)
		ERR	<DRYROT --CORSER&LNKRET>
		MOVNS	TEMP
		TRPCAL	(SIZ,TEMP,X11,X11,.EXPINT)
		HRROS	JOBHRL		;HACK SO SAVE WON'T A HI SEG
		HRRZ	LAST,JOBHRL
		JRST	CORCUT]
>;GGAS
>;CMU
	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
;;%BB%
	TRPCAL	(SIZ,TEMP,X11,X11,.EXPINT)
;;#IC# (1-1)
NOTENX <
	CALL6	(TEMP,CORE)
	 ERR	 <DRYROT --CORSER&LNKRET>
>;NOTENX
TENX <
	HRRZM	TEMP,JOBREL	;SEE COMMENT @ NODDT ABOVE
>;TENX
;;%BB%
	MOVNS	TEMP
	TRPCAL	(SIZ,TEMP,X11,X11,.EXPINT)
	MOVE	LAST,JOBREL	; AND  2) ADJUST BLOCK TO INDICATE
CMU <
GGAS <
CORCUT:
>;GGAS
>;CMU
	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
CMU <
GGAS <
	MOVEI	USER,GLUSER
>;GGAS
>;CMU
	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
CMU <
GGAS <
	JRST	GG.DBP	;HACK TO MAKE COND ASSY EASIER (UGH)
>;GGAS
>;CMU
	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

CMU <
GGAS <
GG.DBP:
	TERPRI
	PRINT	<LASTAL = >
	OCTPNT	LASTAL
	PRINT	<   HI BND = >
	MOVE	TEMP,GAS
	JUMPE	TEMP,.+3
	OCTPNT	-1(TEMP)
	TERPRI
>;GGAS
>;CMU
DUNMOR:	TERPRI
	POP	P,LPSA
	TTCALL	11,
	TTCALL	TEMP
	TERPRI
	POPJ	P,

>
CMU <
IFN GASSW,<

INTERNAL  GASINI,MAKEGA,GASTAT

TEMP2←←13
GASLOK:-1	;CRITICAL SECTION LOCK, ONE CUSTOMER AT A TIME
LASTAL: 0	;INDEX OF FIRST WORD OF HIEST ALLOCATED BLOK
IFN DEBGAS,<PRTGAS:	0	;SWITCH TO ENABLE DEBUGGING
	INTERNAL PRTGAS
>;IFN DEBGAS

HERE(GASINI)
	SETZM	GAS
	SETZM	GLBPNT
	SETOM	CORLOK
	SETOM	GASLOK
IFN DEBGAS,<
	SKIPE	PRTGAS
	TERPRI	<GASINIT:>
>;IFN DEBGAS
	POPJ	P,


HERE(MAKEGA)
	SKIPG	TM,-3(P)
	ERR	<MAKEGAS: NEGATIVE MODULE #>,1
	AOSE	GASLOK		;ONE AT A TIME.
	JRST	[
		MOVEI A,0
		CALLI A,31
		JRST .-1]	;COME BACK LATER.
IFN DEBGAS,<	SKIPE	PRTGAS
	TERPRI	<MAKEGAS:>
>
	;MOVE	USER,GOGTAB	;GET USER TABLE ADDRESS.
	;SETOM	USCOR2(USER)	;TERN ON FLAG ABOUT HIGH SEG.
	SKIPN	GASAD,GAS	;GET ADDRESS OF ARRAY IS IT ZERO.
	JRST	INITGS		;ZERO. GO INITIALIZE IT.
TKGS01:	SKIPG	SIZ,-2(P)	;GET SIZE REQUEST.
	JRST	GASRTN		;NOT POSITIVE, &O RETURNING.
	PUSHJ	P,CORE2	;GO ALLOCATE CORE.
	ERR	<MAKEGAS: NO CORE>
	SUBI	THIS,(GASAD)	;COMPUTE INDEX.
	MOVEM	THIS,@-1(P)	;SET IT TO RETURN TO CALLER.
	CAML	THIS,LASTAL	;HAVE WE EXTENDED THE ARRAY
	JRST	[MOVEM	THIS,LASTAL	;YUP--REMEMBER IT
		ADDI	THIS,-1(SIZ)	;NEW UPPER BOUND
		MOVEM	THIS,-3(GASAD)	;SAVE UPR BND IN HEADER
		HRRM	THIS,-1(GASAD)	; "   TOTL SIZ   "   "
		JRST	.+1	]
TKGS03:
IFN DEBGAS,<SKIPE	PRTGAS
	PUSHJ	P,CORPRT
>;IFN DEBGAS
	;SETZM	USCOR2(USER)	;TURN OFF FLAG.
	SETOM	GASLOK		;RESET LOCK.
	SUB	P,[XWD 4,4]		;STEP BACK IN STACK.
			;NOTE THAT HERE WE USED A LITERAL INSTEAD
			; OF "X44" SO THAT THIS CAN BE CALLED FROM
			; A NON-SAIL LOW SEGMENT.
	JRST	@4(P)		;AND LEAVE.

;CODE THAT FOLLOWS SETS UP ORIGINAL ARRAY DESCRIPTOR.
INITGS:	MOVEI	SIZ,5		;NEED 5 WORDS FOR DESCRIPTOR.
	PUSHJ	P,CORE2	;GET THEM.
	ERR	<MAKEGAS: NO CORE>
	SETZM	1(THIS)		;LOWER BOUNDS = 0.
	SETZM	2(THIS)		;UPPER BOUNDS = 0.
	MOVEI	TEMP,1
	MOVEM	TEMP,3(THIS)	;MULT = 1.
	HRLI	TEMP,1
	MOVEM	TEMP,4(THIS)	;#DIMS,,SIZE
	MOVEI	GASAD,5(THIS)	;ADDRESS OF START OF ARRAY.
	MOVEM	GASAD,(THIS)	;SET AS BASE WORD.
	MOVEM	GASAD,GAS	;SET AS GAS.
	SETZM	LASTAL		;ZERO LAST-ALLOC. WORD.
	JRST	TKGS01		;CONTINUE.

;THIS IS THE PART THAT FREES UP SPACE.
GASRTN:	MOVE	THIS,@-1(P)	;GET INDEX.
	CAMN	THIS,LASTAL	;END OF ARRAY?
	JRST	[MOVEI	TEMP,-3(THIS)	;YES
		ADDI	TEMP,(GASAD)	;ADDR OF LAST WORD OF PREV
	TGAS8:	MOVEI	TEMP2,-1(TEMP)	;SAVE
		SKIPL	TEMP,(TEMP)
		JRST	[MOVEI	TEMP,-1(TEMP)
			JRST	TGAS8]	;THIS IS FREE, TOO.
		SUBI	TEMP2,(GASAD)	;CALC HIEST INDEX
		MOVEM	TEMP2,-3(GASAD)	;SAVE UPR BND
		HRRM	TEMP2,-1(GASAD)	;SAVE TOTAL SIZE
		HRRZS	TEMP	;CLEAR OUT SIGN BIT
		SUBI	TEMP,-2(GASAD)	;INDEX OF 1ST WRD OF BLOK
		MOVEM	TEMP,LASTAL	;REMEMBER IT
		JRST	.+1]
TKGS06:	ADDI	THIS,(GASAD)	;MAKE IT AN INDEX
	PUSHJ	P,CORE2R	;RELEASE CORE.
	JRST	TKGS03		;GO LEAVE.


HERE(GASTAT)
	TERPRI	<GAS PROFILE:>
	MOVEI	USER,GLUSER		;HI SEG
	AOSE	GASLOK			;CRITICAL SECTION
	JRST	[MOVEI	TEMP,0
		CALLI	TEMP,31		;DISMISS
		JRST	.-1]
	SKIPN	TM,GAS		;WHERE IT IS
	JRST	NOGAS
	PRINT	<GAS[0] IS AT '>
	OCTPNT	TM
	PRINT	<   JOBHRL='>
	OCTPNT	JOBHRL
	PRINT	<    LASTAL=>
	DECPNT	LASTAL
	PRINT	<   HIEST=>
	DECPNT	-3(TM)
	TERPRI	<

START	LENGTH	MODULE	PREV	NEXT>
	MOVEI	PREV,0		;TO ACCUMULATE AMOUNT FREE
	MOVEI	NEXT,0		;"     "         "    IN USE
	HRRZ	LAST,JOBHRL	;THE STOPPING ADDRESS
	AOS	TM		;ADDRESS OF FIRST BLOCK IN GAS
STLP:	MOVE	TEMP,TM
	SUB	TEMP,GAS
	DECPNT	TEMP		;STARTING INDEX
	PRINT	<	>
	MOVM	SIZ,1(TM)	;ABSOLUTE LENGTH
	DECPNT	SIZ
	PRINT	<	>
	SKIPL	1(TM)		;FREE?
	JRST	STFREE		; YES
	DECPNT	(TM)		;MODULE NUMBER
	ADD	NEXT,SIZ	;ACCUMULATE AMOUNT IN USE
	JRST	STNEXT		;GO GET ANOTHER

STFREE:	ADD 	PREV,SIZ		;ACCUMULATE AMOUNT FREE
	PRINT	<	>
	HLRZ	TEMP,(TM)		;PREV
	SKIPE	TEMP
	SUB	TEMP,GAS		;COMPUTE THE INDEX
	DECPNT	TEMP
	PRINT	<	>
	HRRZ	TEMP,(TM)		;NEXT
	SKIPE	TEMP
	SUB	TEMP,GAS		;ITS INDEX
	DECPNT	TEMP
STNEXT:	TERPRI
	ADD	TM,SIZ		;ADDR OF NEXT BLOCK
	CAMG	TM,LAST		;DONE?
	JRST	STLP			; NO
	PRINT	<
AMOUNT IN USE=>
	MOVE	TEMP,NEXT
	DECPNT	TEMP
	PRINT	<    FREE=>
	DECPNT	PREV
STATOU:	TERPRI
	SETOM	GASLOK			;LEAVE CRIT SECTION
	POPJ	P,

NOGAS:	TERPRI	<THE TANK IS DRY!>
	JRST	STATOU

>;IFN GASSW
>;CMU
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
>

;;%BA% DCS New high class expanding string garbage collector.  Entire compil
COMPIL(SGC,<STRNGC,STRGC,STCLER,SGINS,SGREM,%SPGC1,%ARSR1,.SONTP>
	   ,<.SGCIN,GOGTAB,X11,CORGET,CORREL,CORINC,X22,CORBIG,SPRPDA,INSET>
	   ,<STRING GARBAGE COLLECTOR ROUTINES>
	   ,<%SPGC,%STRMRK,%ARRSRT>)

DSCR STRGC (REQUEST)
CAL SAIL
PAR REQUEST -- length of string which must fit after STRNGC
RES Calls STRNGC, using REQUEST as A-argument
    REMCHR not updated by REQUEST size after return
⊗

DSCR STRNGC
CAL PUSHJ
PAR A -- number of new characters needed
 REMCHR(USER) -- has been updated by that number of chars
 STREQD(USER) -- Additional characters required (see below).
 STINCR(USER) -- Size (in words) of string space increments (see below).
 Statistics:
   SGCTIME -- Time of last garbage collect, in ms.
	      User must activate timing, by setting this cell to -1.
   SGCTOTAL-- Total gc time, in ms., if timing active.
   SGCNUM -- Number of strings collected, last gc.
   SGCWASTE -- Number of unused but unavailable wds detected, last gc.
RES REMCHR (updated by request) and TOPBYTE are correct, there is room
 to insert a string of the requested size, + STREQD additional chars.
SID none
DES STRNGC is two-pass. In the first, all string descriptors are found
  and sorted into ascending sequence with respect to the locations of their
  respective texts.  Descriptors are found via the generating routines,
  described in CALSG description below.
 In the second pass, all string texts are moved down to fill any
  unused space. All descriptors are adjusted to reflect the new locations.
 If there is still not room to satisfy the request+REQD, a new block
  (space), STINCR long, is allocated for strings, and TOPBYTE set to 
  point to it. Alternatively, if the compaction yielded some empty spaces,
  they may be deleted, depending on the value of REQD, and the request.
  String space thus dynamically expands and contracts to satisfy demand.
⊗

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 linking routine, SGSORT.
SID SGSORT uses B,C, and TEMP, accepts input in A. Generating
 routines may use A-T (11) and TEMP for their own devices.
 D through T will not be changed by calls on SGSORT.
DES 
Active strings are identified by the two-word descriptors which
 are scattered throughout memory, some in variables, some in arrays,
 some in stacks, some in LEAP storage, etc.  STRNGC must look at
 each descriptor during collection.  It does it by calling, in sequence,
 each of the routines on SGROUT, providing each with the address of a
 routine which will add the descriptor to those STRNGC knows about.  The
 user (clever) can add or remove routines on the SGROUT list (see SGINS,
 SGREM).
Each generating routine should do the following:
 1) Place a string descriptor address 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
 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 compiler.
These routines should provide sufficient examples.
⊗
;STRGC, Definitions

NOLOW <

MLT←←=16  BKSZ←←5*MLT+1		;BKSZ must always be so related to MLT

↑.CORERR:
	CORERR	<NO CORE FOR ALLOCATON>



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 .SONTP(STRING S;INTEGER CNT)
DES 	This routine returns (on sp) a string EQU to S (may be S)
	which is aligned with TOPBYT & ensures that there are at least
	an additional CNT chars left in the current string space.
SID 	updates REMCHR.  Sets USER to GOGTAB, mangles TEMP
	may call STRNGC
⊗


HERE(.SONTP)

	BEGIN 	SONTP

;; THE CANON STUFF IS COPIED FROM CAT

DEFINE CANON (ADR,AC)<
	LDB	TEMP,[POINT 3,ADR,5]	;4,5,6,7,0,1 FROM POSITION
	IMULI	AC,5			;ADDR IN CHARS
	ADD	AC,BPTBL(TEMP)		;0,1,2,3,4,5 EXTRA CHARS
>

	MOVE	USER,GOGTAB
	PUSH	P,A
	PUSH	P,B
	PUSH	P,C
	PUSH	P,D
	MOVE	A,-5(P)	;CNT
	ADDM	A,REMCHR(USER)	;TEST GCING LATER
;;#QQ# RHT ! BOY, WAS I ASLEEP WHEN I WROTE THIS CODE
	HRRZ	D,-1(SP)	;LOAD LENGTH
;;#QP# RHT ! (1 OF 4)
	HRRZ	B,(SP)
	CANON	<(SP)>,B	;STANDARD FORM 
	ADD	B,D		;ADD LENGTH
;;#QP# RHT ! (2 OF 4)
	HRRZ	C,TOPBYT(USER)
	CANON	<TOPBYT(USER)>,C
	CAMN	B,C		;SAME??
ISONTP:	SKIPLE	REMCHR(USER)	;GC NEEDED??
	JRST	NOTONT		;MAY WIND UP COPYING
XIT:	POP	P,D		;FINISH
	POP	P,C
	POP	P,B
	POP	P,A		
	SUB	P,X22
	JRST	@2(P)
NOTONT:				;ALWAYS GET ENOUGH TO COPY STRING
				;IF ARE GOING TO GC
	HRRZ	D,-1(SP)	;GET LENGTH OF STRING
	ADD	A,D
	ADDM	D,REMCHR(USER)
	SKIPG	REMCHR(USER)	;REALLY GC ??
	JRST	CPYSTR		;NO REAL NEED
	PUSHJ	P,STRNGC	;GARBAGE IS COLLECTED
;;#QP#	! RHT (3 OF 4)
	HRRZ	B,(SP)
	CANON	<(SP)>,B	;ON TOP NOW ??
	ADD	B,D
;;#QP# ! RHT (HAD MISREAD CANON) 4 OF 4
	HRRZ	C,TOPBYT(USER)	
	CANON	<TOPBYT(USER)>,C
	CAME	B,C		;WELL
	JRST	CPYSTR		;NO, MUST COPY
	MOVN	D,D		;GIVE BACK CHARS GET FROM NOT COPYING
	ADDM	D,REMCHR(USER)	;
	JRST	XIT		;DONE
CPYSTR:	
;;#RI# RHT SOMETIMES NEED A FW BNDRY
	SKIPE	SGLIGN(USER)	;NEED FW BNDRY??
	PUSHJ	P,INSET		;YES
;;#RI#
	MOVE	B,TOPBYT(USER)	;NEW STRING BP
	EXCH	B,(SP)
	JUMPE	D,XIT		;DONE ??
	ILDB	C,B		;COPY CHARS
	IDPB	C,TOPBYT(USER)
	SOJG	D,.-2		;
	JRST	XIT		;DONE

;CAT'S MAP TABLE

BPTBL:	4
	5
	0
	0
	0
	1
	2
        3				;MAP
BEND SONTP

;STRNGC -- Init, CALSGL, SGSWEP -- main loop through space sorting

HERE(STRNGC)
	MOVE	USER,GOGTAB
;!BUG TRAP! remove after reverence for F is established
	CAME	RF,RACS+RF(USER)	;ALL RUNTIMES SHOULD BOTH
	 ERR	 <DRYROT -- RF (R12) not saved in RACS at STRNGC>
;!END BUG TRAP! -- LATER THE NECESSITY TO SAVE WILL BE PHASED OUT.
	MOVEM	RF,RACS+RF(USER)	;WILL RESTORE AFTER SORTING ROUTINES
	SKIPN	SGCTIME(USER)	;User can
	 JRST	 SGC1
	MOVEI	TEMP,0		;TIME SG STARTS
;!HOOK! Conditional assembly for CMU, TENEX system timing goes here.
NOTENX <
	CALL6	(TEMP,MSTIME)
	MOVNM	TEMP,SGCTIME(USER)
>;NOTENX
TENX <
	MOVEM	1,SGCTIME(USER)		;SAVE 1 & 2
	MOVE	TEMP,2			;"TIME" GIVES TIME IN 1, DIVISOR
	JSYS	TIME			;TO GET SECONDS IN 2 (ALWAYS
	MOVNS	1			;1000 SO FAR)
	EXCH	1,SGCTIME(USER)		;BUT SHOULD THIS REALLY BE TIME
	MOVE	2,TEMP			;OF DAY, NOT BILLABLE RUNTIME?
>;TENX
SGC1:	MOVEM	11,SGACS+11(USER)
	MOVEI	11,SGACS(USER)
	BLT	11,SGACS+10(USER)
	AOS	TEMP,SGCCNT(USER)	;COUNT TIMES THROUGH GC
	MOVNM	TEMP,SGCCNT(USER)	;INDICATE THAT GC IS IN PROGRESS
;;%BB% CMU-TYPE TRAP CALL
	SKIPN	.SGCINT
	 JRST	 NOTRP
;;#QA# RHT & DCS THE ARGS TO THIS WERE WRONG
	PUSH	P,A			;SIZE OF REQUEST
	PUSH	P,0			;CONVENTION IS 4 PARAMS
	PUSH	P,SGCCNT(USER)
	PUSH	P,0			;SO PUSH SOME [CENSORED] UP
	PUSHJ	P,@.SGCINT
NOTRP:
;;%BB%
	HRRZ	TEMP,TOPBYTE(USER) ;MAKE SURE DIDN'T OVERFLOW
	CAMG	TEMP,STTOP(USER)
	CAMGE	TEMP,ST(USER)
	 ERR	 <TOPBYTE out of range at STRNGC -- will continue>,1

; List the String Descriptors
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
	MOVE	RF,RACS+RF(USER)	;GET GOOD F BACK, ASSUMING GOOD USER
	JRST	CALSGL			;DO MORE THAN ONCE
ALLCOL:	SUB	P,X22			;Remove temp, SGSORT address

; Sort all spaces
; Allocate a BKSZ-word bucket.  Then, for each space, look at each
;  descriptor, partition it (by starting location within the space)
;  into one of the buckets, then sort it into the list of strings
;  so partitioned, in an order specified in the SRTSPC comments.
;  Finally, for each space, create a single linked list of sorted
;  descriptors.

SGSWEP:	MOVEI	C,BKSZ
	PUSHJ	P,CORGET
STCORERR: ERR  <String garbage collector can't get core>
	MOVEM	B,STBUCK(USER)

; Space Sorting Loop
	MOVE	B,STLIST(USER)		;Loop through all string spaces, 
	SETZM	SGCNUM(USER)		;Strings handled count (not incl. const.)
;<** B => current space throughout
SPCLUP:	PUSHJ	P,SRTSPC		; sorting.  When through, .LIST
	SKIPE	B,.NEXT(B)		; in the header of each space
	 JRST	 SPCLUP			; will be the sorted dscrptr lst.
;STRNGC -- SWPLUP -- main sweep (string moving) loop
; Move the strings, and update the descriptors.  Two routines,
; SOURCE and DEST, maintain information about old and new string
; locations, respectively, and other state info needed to move the
; strings.  Each is responsible for switching from space to space
; when necessary.
	MOVE	B,STBUCK(USER)	;Release the buckets (STBUCK=OFFSET, see blow).
	PUSHJ	P,CORREL
;Initialize source, destination space pointers.
	MOVE	B,STLIST(USER)
	MOVE	C,B
	PUSHJ	P,DSTSET

;**B is Source Space Pointer throughout
;**C is Destination Space pointer throughout

SWPLUP:	PUSHJ	P,SOURCE	;Identify a source "nest", return params
	 JRST	 SWPDUN		; and adjust descriptors, no-skip when done
	PUSHJ	P,DEST		;Identify a destination location, move the
	JRST	SWPLUP		; source nest there, and re-create all 
				; descriptors, adjusted for destination.
;STRNGC -- SWPDUN -- expansion/contraction, parameter update
SWPDUN:
;<** C => last dest. space
;** TOPBYTE, REMCHR correct for C's dest. space

; 1. Get room for request + desired free space (see ALLOC), either
;    from a new space block, or from empty spaces between C's and
;    A's, if there are any
; 2. Release from "C+1" to and including the last space (shrink string space)
; 3. Clean up, zero remaining free space, quit.

;!HOOK! Here, if you made a decision to move the last destination
;  space, you should  do it -- see below for more about this.
	HLRZ	D,STREQD(USER)		;Requested char count +
	ADD	D,SGACS+A(USER)		; STREQD (see p. 2) char count.
	MOVE	E,D
;**E is total required empty space -- valid until GRANTED, below.
GRANT:	ADD	D,REMCHR(USER)		;Granted, if total required
	JUMPL	D,GRANTED		; space exists in last DEST
	PUSHJ	P,WASTE			;Add up wasted space in DEST being left.
	MOVE	A,C			;Save space being abondoned
	SKIPN	C,.NEXT(C)		; space.  Otherwise, move
	 JRST	 EXPSTR			; to next space, if any, and
GRTSET:	PUSHJ	P,DSTSET		; continue to try to grant 
	MOVE	D,E			; request
	JRST	GRANT
;<** A => previous DEST Space, get another
EXPSTR:	HLRZ	C,STINCR(USER)		;STINCR (see p. 2) char count.
	CAML	E,C			;Is there going to be room?
	 ERR	 <String space expansion: request too big>
	HRRZ	C,STINCR(USER)		;STINCR  word count, + .HDRSIZ
	PUSHJ	P,CORGET
	 JRST	 [PUSHJ P,CORBIG	;If for some reason we can't get
		  MOVEI B,.HDRSIZ+1(C)	; STINCR words, make sure that
		  IMULI B,5		; a new block can at least satisfy
		  CAMGE B,E		; the request + STREQD.
		   ERR <String GC: no core to expand string space>
		  PUSHJ P,CORGET	;Will do, get it
		   ERR <DRYROT -- unexpected STRNGC core problem>
		  JRST .+1]
	MOVEI	B,.HDRSIZ(B)		;Adjust pointer to leave header,
	SUBI	C,.HDRSIZ		; set up header area parameters,
	MOVEM	C,.STTOP(B)		; link to previous area
	MOVEM	C,.SIZE(B)
	ADDM	B,.STTOP(B)
	SETZM	.NEXT(B)
	SETZM	.LIST(B)
	MOVEM	B,.NEXT(A)
	MOVE	C,B			;This becomes last destination
	JRST	GRTSET			;Go satisfy request, now guaranteed.
GRANTED:HRRZM	C,ST(USER)		;Update ST, STTOP, release any
	MOVE	TEMP,.STTOP(C)		; spaces made unnecessary by diminished
	MOVEM	TEMP,STTOP(USER)	; active strings
	SKIPN	A,.NEXT(C)		;Get next space past last DEST, if any,
	 JRST	 STSTAT			; then clear any next space pointers.
	SETZM	.NEXT(C)
RELLUP:	MOVEI	B,-.HDRSIZ(A)		;Release any spaces which are
;;#RL# (CMU =B2=) USED TO ACCESS .NEXT AFTER THE CORREL
	MOVE	A,.NEXT(A)
	PUSHJ	P,CORREL		; apparently no longer necessary.
	JUMPN	A,RELLUP
;;#RL#

;STRNGC -- STSTAT -- Finish Up, collect statistics
STSTAT:				;Check that Full-word alignment produced
	SKIPE	SGLIGN(USER)	;Alignment also implies clearing
	 PUSHJ	 P,RESCLR	;Free space
	MOVEI	B,=15		;Update REMCHR by initial request, plus a
	ADD	B,SGACS+A(USER)	; bit of slop (NOT by STREQD, which specifies
	ADDB	B,REMCHR(USER)	; free space -- slop is unfree, for safety.)
	JUMPGE	B,[ERR <DRYROT -- String GC Surprised at Untoward Occurrence>]
	MOVMS	SGCCNT(USER)	;Now indicate done with GC
	SKIPN	SGCTIME(USER)	;Timing active?
	 JRST	 NOTIME		;No
	MOVEI	TEMP,
;!HOOK! Insert, conditionally, other system timing calls
NOTENX <
	CALL6	(TEMP,MSTIME)	;Collect GC times
>;NOTENX
TENX <
	EXCH	1,TEMP
	PUSH	P,2
	JSYS	TIME
	POP	P,2
	EXCH	1,TEMP
>;TENX
	ADDB	TEMP,SGCTIME(USER)
	ADDM	TEMP,SGCTOTAL(USER)
NOTIME:
;;%BB% CMU-STYLE TRAP -- I DON'T SUPPLY ALL THE SAME INFO AS LDE DID AT CMU
	SKIPN	.SGCINT
	 JRST	 QUITGC
	MOVN	TEMP,REMCHR(USER);SIZE OF GRANT, LESS ORIGINAL REQUEST
	PUSH	P,TEMP
	PUSH	P,SGACS+1(USER)	;ORIGINAL REQUEST
	PUSH	P,SGCCNT(USER)	;AS FAR AS I CAN TELL, JUST USING UP CELLS
	PUSH	P,SGCNUM(USER)	; IN THE CALL STACK
	PUSHJ	P,@.SGCINT
;;%BB%
QUITGC:	MOVE	USER,GOGTAB	;PARANOID
	HRLZI	11,SGACS(USER)	;Restore and return
	BLT	11,11
	POPJ	P,
;STRNGC Service routines -- SGSORT
;Sgsort
;<A is => descriptor
;1. Ignore constants
;2. Check legality, go easy on null strings
;	issues: Recover gracefully from bad strings
;		Report complete info about bad strings
;		Try to supply name of descriptor source for
;		   bad strings (stack, vbl, array, other)
;3. In // with above, find proper string space for each str.
;4. Link in string # field (lh word 1) -- separate list for each space

SGSORT:	HLLZ	B,(A)		;don't collect constants
	JUMPE	B,SGRST

; Loop on string spaces, find the one containing this string
	HRRZ	TEMP,1(A)
	MOVEI	B,STLIST-.NEXT(USER)
SGLUP1:	SKIPN	B,.NEXT(B)
	 JRST	 NORANGE	;Range exhausted, bad string
	CAML	TEMP,B		;Address check of string bp
	CAML	TEMP,.STTOP(B)	; against both ends of each 
	 JRST	 SGLUP1		; space determines if string in range
INRANGE:SUB	TEMP,B		;Convert bp to space-relative
	IMULI	TEMP,5		; character count
	HLLZ	C,1(A)
	TLNN	C,777770	;Make sure there are still byte ptr. bits
				;Max possible start count is 4,,777777
	 JRST	 [MOVE A,A	;ERR type 7 gets AC # from here
		  ERR <SGSORT-- string encountered twice, descriptor addr = >,7
		  JRST SGRST]	;Don't handle again.
	HRRI	C,[BYTE(7) 0,1,2,3,4,5]
	ILDB	C,C		;Space-relative count fits in
	ADD	C,TEMP		; rh, lh 0 signals
	MOVEM	C,1(A)		; re-encounter (above)
	MOVE	C,.LIST(B)	;Insert descriptor, linked by
	HRLM	C,(A)		; string number field, into
	HRRZM	A,.LIST(B)	; list for this space
	JRST	SGRST
NORANGE:
;;#tc# rht (cmu =a7=) dont barf at null strings
	HRRZ	B,(A)		;test for null
	JUMPE	B,.+3		;& do the right thing
;;#tc#
	MOVE	A,A		;String not in range, complain, NULL it,
	ERR	<String GC: Descriptor byte ptr. out of bounds, Addr. is >,7
	SETZM	(A)		; and go on.
SGRST:	ADDI	A,2		;Auto-increment descriptor index
	POPJ	P,
;STRNGC Service routines -- SPGC,STRMRK, etc. -- Descriptor providing routines
; 	     ------ 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:	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  (ASSUME SET UP 12-3-73)
↑%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	E,ARYLS(USER)	;LEAPING LISTS
	POPJ	P,		;NONE
LAR1:	
	HLRZ	Q2,(E)		;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	<DRYROT -- LEAPing error at ARRSRT>
	PUSHJ	P,ARPUTX	;GO SORT IT

LAR2:	HRRZ	E,(E)		;MERRILY WE LINK ALONG
	JUMPN	E,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.

;STRNGC Service routines -- SRTSPC -- space sorter
;Space Sorter

;<** B => A string space, descriptor list is .list(b)
SRTSPC:	MOVE	A,STBUCK(USER)	;Clear bucket list
	SETZM	(A)
	ADDI	A,1
	HRLI	A,-1(A)
	MOVEI	C,BKSZ-2(A)
	BLT	A,(C)
	SKIPN	A,.LIST(B)
	 JRST	 SORTED
;<** A => word 1 of NEW descriptor
DSCLUP:	AOS	SGCNUM(USER)	;Count strings handled.
	HLRZ	FF,(A)
	MOVE	C,1(A)
	MOVE	E,C		;For later (below)
	IMULI	C,MLT
	IDIV	C,.SIZE(B)	;Compute bucket entry
	ADD	C,STBUCK(USER)	; (partition space among bckts)
	MOVE	Q1,C
	HRRZ	T,(A)
SGSLUP:	MOVE	D,C
	HLRZ	C,(C)
;<** Q1 => bucket entry, for end-pointer maintenance (just below)
;<** D  => PREV descriptor, which has been seen
;<** C  => NEXT descriptor, to be examined
;** E  is starting count of NEW rel. to this space
;** T  is length(NEW)
;Sort NEW into this bucket list such that its starting count is >=
; all which precede it, <= all which follow it.  Where starting
; counts are equal, sort by descending length.  This creates nests
; of strings to  be handled by the sweep phase.
	JUMPE	C,[HRRM A,(Q1)	;** NEW will be end string,
		   JRST INSERT]	;    keep track of it for linkage
	CAMGE	E,1(C)
	 JRST	 INSERT		;NEW begins before NEXT, insert
	CAME	E,1(C)
	 JRST	 SGSLUP		;NEW begins after NEXT, keep looking
	HRRZ	TEMP,(C)
	CAMG	T,TEMP		;Insert by descending length
	 JRST	 SGSLUP
;	(JRST	INSERT)
;<** A => NEW, 1st word
;<** C => NEXT, 1st word, or is 0
;<** D => PREV, 1st word, or bucket
;** E is start count from descriptor
;Standard one-way linked list insertion
INSERT:	HRLM	A,(D)
	HRLM	C,(A)		;Link is in lh of word 2 of descriptor
;Sort next descriptor from this space
	MOVE	A,FF
	JUMPN	A,DSCLUP

;Now use list pointers in buckets
;  (each is <first,,last>)
; to create one sorted list -- store in .LIST(this space)
SORTED:	MOVE	C,STBUCK(USER)	;Starting at the end of the bucket
	HRLI	C,D		; array, look only at non-zero
	MOVEI	D,BKSZ-1	; entries.  Each iteration, retain
	MOVEI	A,0		; the newest <first> pointer, having
LNKLUP:	SKIPN	E,@C		; placed the previous <first> pointer
	 JRST	 AOCHK		; into the list identified by the
	HRLM	A,(E)		; newest <last> pointer.  The first
	HLRZ	A,E		; <first> pointer is 0
AOCHK:	SOJGE	D,LNKLUP
	MOVEM	A,.LIST(B)
	POPJ	P,
;STRNGC Service routines -- SOURCE and DEST
;SOURCE:
;<** B => source space
;<** .LIST(B) => first descriptor of next nest to move, or 0 (space done)
;
; 1. Move to next space, if necessary -- this one done. No-skip if no more.
; 2. Create BP to start of nest, save.  Save first space-relative count.
; 3. Move down list, identify end of nest -- convert all descriptor
;    counts to nest-relative counts
; 4. Update .LIST
; 5. Skip (found a nest) Return:
;    A -- BP to source string (nest)
;    D -- total # chars in nest
;<   E -- =>first in nest -- last link in nest zeroed
; 6. Non-skip (no more nests) Return.
; 7. Don't change C!!!

SOURCE:	MOVE	E,.LIST(B)
	JUMPE	E,[SKIPN B,.NEXT(B)
		   POPJ P,		;no-skip, return
		   JRST SOURCE]
	MOVE	Q1,1(E)
	IDIVI	Q1,5
	ADD	Q1,B
	HLL	Q1,[PTBL1: POINT 7,0	;!HOOK! IF PTBL OF SUBSTR AVAIL, 
		    POINT 7,0,6		; declare it external and use it
		    POINT 7,0,13	; here -- tables are the same
		    POINT 7,0,20
		    POINT 7,0,27
		    POINT 7,0,35](Q2)
	PUSH	P,Q1
	HRLS	E
	MOVN	A,1(E)
	HRRZ	D,(E)
	SUB	D,A
	ADDM	A,1(E)		;Adjust 1st descr. location count to nest-rel.
;** A is -(nest start char)
;** D is Nest end char +1
;<<** E is => first elt of nest,, => current elt.
;** First nest descriptor already count-relative adjusted
;Loop until a descriptor is not in the nest
SRCLUP:	HLRZ	Q1,(E)		;Next elt.
	JUMPE	Q1,NONEST	;If end-loc in D does not reach the next
	CAMG	D,1(Q1)		; descriptor's location, nest is done
	 JRST	 NONEST		;(Adjoining, non-overlapping nests must be
	HRRZ	TEMP,(Q1)
	ADD	TEMP,1(Q1)	; moved separately because of full-word reqmt.
	CAMGE	D,TEMP		;Adjust nest-end location, if new string
	 MOVE	 D,TEMP		; extends beyond old nest
	ADDM	A,1(Q1)		;Adjust location count to nest-relative.
	HRR	E,Q1		;Will be last descriptor in nest at NONEST
	JRST	SRCLUP

NONEST:	HRRZM	Q1,.LIST(B)	;Update list, retrieve BP, compute length,
	HRRZS	(E)		;Clear last elt in nest
	HLRZS	E		;Return ptr. to 1st, as advertised
	ADD	D,A		; skip-return as advertised
	POP	P,A
	AOS	(P)
	POPJ	P,

;DEST:
;** B inviolate
;<** C => dest space
;** TOPBYTE(USER) is free in current dest space
;** REMCHR(USER) is -(number remaining) in current dest space
;<** E is  =>first in nest -- last elt. is zeroed
;** D is nest size in chars
;** A is nest source byte pointer

; 1. Adjust to FW bdry if SGLIGN
; 2. Find room, this dest space or next -- error if out of spaces.
; 3. Adjust REMCHR
; 4. Move nest, adjust TOPBYTE
; 5. Recreate BP for each descriptor

DEST:	MOVE	Q1,D		;SAVE LENGTH
;** Q1 is original nest length, will remain so until FIXLP 1st pass
DEST1:	SKIPN	SGLIGN(USER)
	 JRST	 NOLIGN
	PUSHJ	P,INSET			;Inset aligns TOPBYTE to full word,
	PUSH	P,D+1			; but it should already be there really.
	ADDI	D,4			;Move smallest multiple of 5 characters
	IDIVI	D,5			; which hold nest.
	IMULI	D,5
	POP	P,D+1
;** D is nest length, possibly adjusted for sglign
NOLIGN:	ADDM	D,REMCHR(USER)		;Standard room test
	SKIPGE	REMCHR(USER)
	 JRST	 ISROOM
;!HOOK! If you decided to move the DEST being left (in DSTSET, see below),
; Do it now.  Move it to (C)+OFFSET(USER).
NOROOM:	PUSHJ	P,WASTE			;Count waste in space being left
	HRRZ	C,.NEXT(C)		;Since we are moving strings "down",
	JUMPE	C,[ERR <DRYROT -- No more room for strings -- very strange>]
					; running out of already existent
	PUSHJ	P,DSTSET		; space is a fatal error.
	JRST	DEST1			;Try again, C, REMCHR, TOPBYTE are adjusted.
ISROOM:	MOVE	FF,TOPBYTE(USER)
	CAME	A,FF			;Avoid moving the nest to its previous
	 JRST	 MVTST			; location (expensive NO-OP).
	 JRST	 MVDON
MVLP:	ILDB	TEMP,A
	IDPB	TEMP,FF
MVTST:	SOJGE	D,MVLP
	MOVE	FF,TOPBYTE(USER)	;FF←BP of first char

MVDON:	MOVSI	A,40			; in destination nest
	MOVE	D,E			;First, adjust TOPBYTE, then
	MOVEI	E,TOPBYTE-1(USER)	; the strings of the nest
	LDB	TEMP,[POINT 3,FF,5]
;<**E => current descriptor in nest or topbyte, starting with latter
;**A's LH is non-zero "string number" value -- strings aren't constants
;**FF is BP to 1st nest destination character.
;For each descriptor, Store string number, create a new byte pointer
; (algorithm stolen from SUBSTR routine)

	TRC	TEMP,4
	JRST	FIXTOP		;Start in middle to get topbyte
FIXLP:	HLRZ	D,(E)
;<**D => next descriptor
;**TEMP is character offset of FF-pointer in its word (for computing BP's)
	HLLM	A,(E)		;Update string number
	MOVE	Q1,1(E)		;Compute new BP -- see SUBSTR in STRSER
FIXTOP:	MOVE	T,FF
	ADD	Q1,TEMP
	CAILE	Q1,4
	 JRST	 [CAILE Q1,9
		  JRST	    [IDIVI Q1,5
			     ADD   T,Q1
			     HLL   T,PTBL1(Q2)
			     JRST  PTWY]
		  SUBI  Q1,5
		  AOJA  T,.+1]
	HLL	T,PTBL1(Q1)
PTWY:
;!HOOK!	ADD	T,OFFSET(USER)	;activate when space-moving becomes reality.
;; !! But topbyte fix is messed up some by this, watch it.
	MOVEM	T,1(E)		;Store new BP, to descriptor or topbyte
	MOVE	E,D		;loop
	 JUMPN	 E,FIXLP
	POPJ	P,



;DSTSET:
;<** C => destination space
;Result: TOPBYTE(USER) is destination byte pointer -- to beginning of space
;	 REMCHR(USER) is -(size of space in characters)
DSTSET:	HRLI	C,(<POINT 7,0>)
	MOVEM	C,TOPBYTE(USER)
	MOVN	TEMP,.SIZE(C)
	IMULI	TEMP,5
	MOVEM	TEMP,REMCHR(USER)
;!HOOK! This is probably the best place to decide, perhaps to minimize
; checkerboarding or memory use, that the DEST just prepared should be
; moved to a new location.  This move will not happen until the space
; has been filled, and all descriptors for it adjusted.  Decide where
; to move the block, then put the difference between its future location
; and its current one into OFFSET(USER).  The DEST routine will use this
; to adjust all descriptor byte pointers.
	POPJ	P,

;When leaving a DEST for a new one, keep track of the unfilled space
; within that space.
WASTE:	PUSH	P,TEMP+1
	MOVN	TEMP,REMCHR(USER)	;Unused characters this space
	IDIVI	TEMP,5			;Just rough estimate.
	POP	P,TEMP+1
	ADDM	TEMP,SGCWASTE(USER)
	POPJ	P,
;STRNGC Service routines -- SGINS and SGREM
;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
⊗

HERE(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
⊗

HERE(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)
;STRNGC Service routines -- STCLER and RESCLR
DSCR STCLER
CAL PUSHJ
RES Clears all string variables on STRLNK(USER) to null strings
DES compiler only
⊗

HERE(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:	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)
NOTENX<
	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
>;NOTENX

TENX<;TENEX VERSION OF K.OUT

	MOVE	USER,GOGTAB
	SKIPN	KNTLNK(USER)		;ANY KOUNTERS?
	  POPJ	P,

COMMENT ⊗ SAVE ACS 0-14
⊗;
	MOVEM	14,15(P)
	MOVEI	14,1(P)
	BLT	14,14(P)
	ADD	P,[XWD 15,15]
	TLNN	P,400000		;OVERFLOW?
	  ERR	<PDL overflow in K.OUT routine>

COMMENT ⊗	Chain the counters together as above.
⊗;
	MOVE	2,KNTLNK(USER)
	SKIPN	1,(2)
	JRST	.+5
	MOVEI	0,1(2)
	MOVEM	0,3(1)
	MOVE	2,1
	JRST	.-5
	
COMMENT ⊗  
	At this point, 1(2) contains the start of a DEC-style
dump mode command chain that will be used to write out the
counters.  -1(2)  contains the sixbit for the file name.
⊗;

	MOVE	5,2			;SAVE POINTER TO THE CHAIN
	PUSH	P,-1(5)			;SIXBIT/FILENAME/	
	PUSHJ	P,CVXSTR		;GET ASCII
	PUSH	P,[0]
	PUSHJ	P,CATCHR		;PUT A NULL BYTE ON THE END
	POP	SP,2			;BP TO 2 FOR GTJFN
	SUB	SP,X11			;CLEAR SP STACK
	MOVEI	1,EKNT			;LONG FORM	
	JSYS	GTJFN
	  JRST	KNTERR			;GTJFN ERROR
	MOVE	2,[XWD 440000,100000]	;36 BIT WRITE	
	JSYS	OPENF			;JFN REMAINS IN 1
	  JRST	KNTERR			;OPENF ERROR
;5 HAS THE START OF A DUMP-MODE COMMAND CHAIN, WHICH WE MUST	
;INTERPRET INTO SOUT'S
	MOVEI	4,1(5)			;START OF COMMAND LIST		

KNTLUP:	MOVE	3,(4)
	JUMPE	3,KNTDUN		;0 COMMAND MEANS TO STOP
	TLNE	3,-1			;0 LEFT HALF MEANS GOTO 
	  JRST	KNTOUT			;REAL IO WORD
	MOVE	4,3			;OK DO THE GOTO
	JRST	KNTLUP
	
KNTOUT:	HRRI	2,1(3)			;FIRST LOCATION
	HRLI	2,444400		;MAKE A BP
	HLRO	3,3			;WORD COUNT
	JSYS	SOUT
	AOJA	4,KNTLUP

KNTDUN:	JSYS	CLOSF			;CLOSE OUT THE FILE
	  JFCL				;ERROR RETURN
	
KNTRET:	MOVSI	14,-14(P)		;RESTORE ACS
	BLT	14,14
	SUB	P,[XWD 15,15]
	POPJ	P,			;AND RETURN

KNTERR:	ERR	<K.OUT:  Cannot GTJFN or OPENF file>,1
	JRST	KNTRET

EKNT:	XWD 400000,0			;NEW VERSION
	XWD 377777,377777		;NO EXTRA JFNS
	BLOCK 3
	XWD -1,[ASCIZ/KNT/]		;DEFAULT VERSION IS .KNT
	BLOCK 3


>;TENX

ENDCOM (KNT)
COMPIL(POW,<FPOW,POW,LOGS,FLOGS,EXP$,LOG$>
	,<X11,X22,X33,OVPCWD>,<POW, FPOW, LOGS, FLOGS -- EXPON. ROUTINES>)


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

FPOW:	REAL←FPOW(INTEGER!EXPONENT,REAL!BASE)
POW:	REAL← POW(INTEGER!EXPONENT,INTEGER!BASE)

LOGS:	REAL← LOGS(REAL!EXPONENT,INTEGER!BASE)
FLOGS:	REAL←FLOGS(REAL!EXPONENT,REAL!BASE)

SPECIAL CASES:
	A↑0 = 1
	0↑B = 0 IF B GEQ 0.
	0↑B = INF. IF B<0  ; MESSAGE PRINTED
	A↑B = (-1)↑B*|A|↑B  IF A<0, B INTEGRAL
	A↑B = REALPART(A↑B) IF A<0, B NOT INTEGRAL ; MESSAGE

MESSAGE IS PRINTED IF OVERFLOW OR UNDERFLOW HAPPENS.
IN THIS CASE, FIXUP IS MADE SO THAT ANSWER IS EITHER 0, +INF, OR
-INF.

⊗
IFN ALWAYS,<	BEGIN	UTILS>


HERE(FPOW)
	SKIPA 	USER,-1(P)	;BASE
HERE(POW)
	FLOAT	USER,-1(P)
FPX:	MOVM	LPSA,-2(P)	;GET ABS(EXPONENT)
	JUMPE	LPSA,EXZERO	;0 EXPONENT
	MOVSI	A,(1.0)		;SET FOR FLOATING	
	JRST	2,@[FEXS]	;CLEAR AR FLAGS

FEXL:	ASH	LPSA,-1		;PREPARE TO LOOK AT NEXT BIT.
	FMPR	USER,USER	;SQUARE BASE
	 JFOV	 FPOWOV		;OVERFLOW/UNDERFLOW
FEXS:	TRZE 	LPSA,1		;COLLECT PRODUCT?
	FMPR	A,USER		;YES
	 JFOV	 FPOWOV		;OVERFLOW?
	JUMPN	LPSA,FEXL	;LOOP UNTIL EXPONENT ZERO.
	SKIPGE	-2(P)		;POSITIVE EXPONENT?
	   JRST	FEXDU1
POWRET: SUB	P,X33
	JRST 	@3(P)

FEXDU1:	MOVM	LPSA,A		;CHECK FOR OVERFLOW POSS.
	CAMGE	LPSA,[XWD 2400,1] ;SMALL NUMBER 
	 JRST	 FPDOV		;CALL UNDERFLOW
	MOVSI	LPSA,(1.0)	;TAKE RECIPROCAL OF ANS.
	FDVRM	LPSA,A
	JRST	POWRET		;AND RETURN IT.

EXZERO:	SKIPN	USER		;0↑0
ZRET:	 TDZA	 A,A		;RETURN 0
	MOVSI	A,(1.0)		;RETURN FLOATING 1
	JRST 	POWRET


FPOWOV:	SKIPN	TEMP,OVPCWD	;IF TRAPS ENABLED, USE EM
	 JSP	 TEMP,.+1	;ELSE GET FLAGS THIS WAY
	TLNE	TEMP,100	;SKIP IF NOT UNDERFLOW
FPDOV:	 MOVNS	 -2(P)		;UNDERFLOW -- CHANGE EXPONENT SIGN.
	MOVE	A,[XWD 400000,1] ;LARGE NEGATIVE NUMBER
	SKIPG	TEMP,-2(P)	;CHECK SIGN OF EXPONENT.
	 MOVEI	 A,0		;NEGATIVE ==> RESULT 0.
	SKIPGE	-1(P)		;CHECK SIGN OF BASE.
	 TRNN	 TEMP,1		;XOR SIGN OF EXPONENT.
	 MOVNS	 A		;MAKE +- LARGE NUMBER
	ERR	<Exponentiation under or overflow>,1
	JRST	POWRET		;RETURN.

HERE(FLOGS)
.FLOGS:	SKIPA	USER,-1(P)	;FLOATING BASE
HERE(LOGS)
.LOGS:	FLOAT	USER,-1(P)	;FLOAT THE BASE
	SKIPN	-2(P)		;IF ZERO EXPONENT,
	 JRST	 EXZERO		;GO TO COMMON CODE.
	MOVM	TEMP,-2(P)	;CHECK TO SEE IF 'FIX' WILL 
	CAMLE	TEMP,C1		;OVERFLOW
	 JRST	 USLGEP		;YES -- GO TO LOG-EXP
	FIX	TEMP,-2(P)	;CHECK TO SEE IF EXPONENT
	FLOAT	LPSA,TEMP	;HAPPENS TO BE AN INTEGER
	CAMN	LPSA,-2(P)	;IF SO, USE LOOPS TO
	 JRST	 [MOVEM TEMP,-2(P) ;BE SURE OF CORRECT SIGN
		  JRST FPX]
USLGEP:	JUMPE	USER,[SKIPGE -2(P) ;IF BASE ZERO, AND EXPT NEG.
			JRST FPDOV ;RETURN LARGE NUMBER
			JRST ZRET] ;ELSE RETURN ZERO.
	PUSH	P,USER		;ARGUMENT TO 'ALOG'
	PUSHJ	P,.LOG		;CALL IT.
	FMPR	A,-2(P)		;MULTIPLY BY EXPONENT
	PUSH	P,A		;ARGUMENT TO 'EXP'
	PUSHJ	P,.EXP		;CALCULATE
	JRST	POWRET		;AND RETURN.

C1:	243777777777		;2↑35 - EPSILON


DSCR EXP,ALOG -- FOR USE BY EXPONENTIATION ROUTINES & WORLD
SID	CLOBBERS LPSA,TEMP,USER
CAL	SAIL
⊗


;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:
;	PUSH P,ARG
;	PUSHJ	P,EXP
;THE ANSWER IS RETURNED IN ACCUMULATOR A

HERE(EXP$)
.EXP:	PUSH	P,[0]		;ONE WORKING CELL
	PUSH	P,B		;AND ONE SAVED AC
	MOVE	LPSA,-3(P)	;GET ARGUMENT
	MOVM	A,LPSA		;GET ABSF(X)
	CAMG	A, E7		;IS ARGUMENT IN PROPER RANGE?
	JRST	EXP1		;YES, GO TO ALGORITHM
	ERR <EXP: under or overflow>,1
	HRLOI	A, 377777	;GET LARGEST FLOATING NUMBER
	SKIPG	LPSA		;WAS THE ARGUMENT POSITIVE?
	MOVEI	A, 0		;NO, RETURN 0
	JRST	EXPXIT		;AND RETURN

EXP1:	MULI	LPSA,400	;SEPARATE FRACTION AND EXPONENT
	TSC	LPSA,LPSA	;GET A POSITIVE EXPONENT
	MUL	TEMP,E5		;FIXED POINT MULTIPLY BY LOG2(E)
	ASHC	TEMP,-242(LPSA)	;SEPARATE FRACTION AND INTEGER
	AOSG	TEMP		;ALGORITHM CALLS FOR MULT. BY 2
	AOS	TEMP		;ADJUST IF FRACTION WAS NEGATIVE
	HRRM	TEMP,B 		;SAVE FOR FUTURE SCALING
	JUMPG	USER,ASHH	;GO AHEAD IF ARG GREATER THAN 0
	TRNN	USER,377	;ALL THESE BITS 0?
	 JRST	 ASHH		;YES -- GO AHEAD
	ADDI	USER,200	;NO -- FIX UP
ASHH:	ASH	USER, -10	;MAKE ROOM FOR EXPONENT
	TLC	USER, 200000	;PUT 200 IN EXPONENT BITS
	FADB	USER, -1(P) 	;NORMALIZE, RESULTS TO USER AND E
	FMP	USER,USER	;FORM X↑2
	MOVE	A, E2		;GET FIRST CONSTANT
	FMP	A, USER		;E2*X↑2 IN A
	FAD	USER, E4	;ADD E4 TO RESULTS IN USER
	MOVE	LPSA, E3	;PICK UP E3
	FDV	LPSA,USER	;CALCULATE E3/(F↑2 + E4)
	FSB	A,LPSA		;E2*F↑2-E3(F↑2 + E4)**-1
	MOVE	TEMP,-1(P)  	;GET F AGAIN
	FSB	A, TEMP		;SUBTRACT FROM PARTIAL SUM
	FAD	A, E1		;ADD IN E1
	FDVM	TEMP, A		;DIVIDE BY F
	FAD	A, E6		;ADD 0.5
	FSC	A, (B)		;SCALE THE RESULTS
EXPXIT:	POP	P,B		;RESTORE AC
	SUB	P,X33		;ADJUST STACK
	JRST	@2(P)		;RETURN.

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


;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:
;	PUSH P,ARG
;	PUSHJ	P, LOG
;THE ANSWER IS RETURNED IN ACCUMULATOR A


HERE(LOG$)
.LOG:
	SKIPGE	-1(P)		;CHECK SIGN OF ARGUMENT.
	ERR <LOG: Negative argument -- real part returned>,1
	MOVM	LPSA,-1(P)   	;GET ABSF(A)
	JUMPE	LPSA, LZERO	;CHECK FOR ZERO ARGUMENT
	CAMN	LPSA, ONE	;CHECK FOR 1.0 ARGUMENT
	JRST	ZERANS		;IT IS 1.0 RETURN ZERO ANS.
	ASHC	LPSA, -33	;SEPARATE FRACTION FROM EXPONENT
	ADDI	LPSA, 211000	;FLOAT THE EXPONENT AND MULT. BY 2
	MOVSM	LPSA,USER	;NUMBER NOW IN CORRECT FL. FORMAT
	MOVSI	LPSA, 567377	;SET UP -401.0 IN LPSA
	FADM	LPSA,USER 	;SUBTRACT 401 FROM EXP.*2
	ASH	TEMP, -10	;SHIFT FRACTION FOR FLOATING
	TLC	TEMP, 200000	;FLOAT THE FRACTION PART
	FAD	TEMP, L1	;TEMP = TEMP-SQRT(2.0)/2.0
	MOVE	LPSA,TEMP	;PUT RESULTS IN LPSA
	FAD	LPSA, L2	;LPSA = LPSA+SQRT(2.0)
	FDV	TEMP,LPSA	;TEMP = TEMP/LPSA
	MOVEM	TEMP,A		;STORE NEW VARIABLE IN A
	FMP	TEMP,TEMP	;CALCULATE Z↑2
	MOVE	LPSA, L3	;PICK UP FIRST CONSTANT
	FMP	LPSA,TEMP	;MULTIPLY BY Z↑2
	FAD	LPSA, L4	;ADD IN NEXT CONSTANT
	FMP	LPSA,TEMP	;MULTIPLY BY Z↑2
	FAD	LPSA, L5	;ADD IN NEXT CONSTANT
	FMP	A,LPSA		;MULTIPLY BY Z
	FAD	A,USER		;ADD IN EXPONENT TO FORM LOG2(X)
	FMP	A, L7		;MULTIPLY TO FORM LOGE(X)
LOGXIT:	SUB	P,X22
	JRST	@2(P)

LZERO:	ERR	<LOG: Argument 0; minus infinity returned>,1
	SKIPA	A, MIFI		;PICK UP MINUS INFINITY
ZERANS:	MOVEI	A,0		;MARG ANS ZERO
	JRST	LOGXIT		;AND RETURN

;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(USC,<USERCON>,<SAVE,RESTR,GOGTAB>,<USERCON ROUTINE>)
COMMENT ⊗Usercon ⊗

DSCR USERCON(@INDEX,@SETGET,FLAG);
CAL SAIL
PAR INDEX is USER-table displacement (usually obtained from HEAD.REL)
 SETGET is used to communicate USER table values
 FLAG is "OPCODE" input to USERCON
RES The INDEXth USER table entry is accessed (GLUSER table if FLAG negative).
 On exit, SETGET contains old value of this entry.
 If FLAG is odd, the original SETGET value replaces this entry.
⊗

CMU <
GGAS <
IFE ALWAYS, <EXTERNAL GLUSER>
>;GGAS
>;CMU


;;%BR% ! USED TO HEREFK TO HERE
HERE(USERCON)
	PUSHJ	P,SAVE
	MOVE	LPSA,[XWD 4,4]
	MOVE	A,-1(P)		;THE FLAG
CMU < GGGON
>;CMU
GLOB <
	MOVEI	B,ENDREN
	JUMPL	A,[MOVEI USER,GLUSER
		   MOVEI B,ZAPEND ;USE GLOBAL TABLE
		   JRST .+1]
	SKIPL	C,-3(P)		;THE INDEX
	CAML	C,B
>;GLOB
NOGLOB <
	SKIPL	C,-3(P)		;THE INDEX
	CAIL	C,ENDREN	;CHECK BOUNDS
>;NOGLOB
	ERR	<USERCON: index out of bounds >,7,RESTR
	ADD	C,USER		;POINT AT CORRECT ENTRY
	MOVE	B,(C)		;GET OLD VALUE
	MOVE	D,@-2(P)	;(PERHAPS) NEW VALUE
	TRNE	A,1		;STORE NEW VALUE?
	MOVEM	D,(C)		;YES
	MOVEM	B,@-2(P)	;RETURN OLD VALUE
GLOB <
	MOVE	USER,GOGTAB	;RESET
>;GLOB
	JRST	RESTR
CMU < GGGOFF
>;CMU
ENDCOM(USC)



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)


NOTENX <;CALL FUNCTION EMULATED IN FILE CALL.TNX
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
>;NOTENX