perm filename TOTAL[S,AIL]44 blob sn#241606 filedate 1976-10-16 generic text, type C, neo UTF8
COMMENT ⊗   VALID 00052 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00005 00002	HISTORY
C00013 00003	DATA for Total (Low-level Code Production) Routines
C00016 00004	Description of Total Routines
C00026 00005	CONV, PRE, POST -- Type-Conversion routines
C00031 00006
C00035 00007	  
C00040 00008
C00041 00009	PUT
C00045 00010	ACCESS,GETSDR,GETDR,DISBLK,ZOTDIS--last four  only for dis
C00054 00011	GET
C00060 00012
C00063 00013
C00067 00014
C00072 00015	STACK -- Issue Instrs. to Stack Anything on Approp. Stack
C00076 00016	MARK, MARKINT, MARKME -- Mark Semblk with Correct Temp Semantics
C00080 00017	INCOR -- Issue Code to Clear this Entity from ACs
C00081 00018	REMOPs, CLEARs -- Remove Temps, ACs, from Use
C00093 00019	DSCR CLEAR,CLEARL,CLEARA
C00095 00020	STROP -- Bit-Driven String Operation Code Generator
C00102 00021	GETTEM, etc. -- Temp Semblk Allocators
C00105 00022	GETAC, GETAN0 -- AC Allocators
C00111 00023	AC Store routines -- BOLSTO, FORSTO, STORIX, GOSTO, STORZ
C00116 00024	 STORA -- main AC-storing subr. -- called by above
C00123 00025	EMITER -- Descriptions of Routine and Control Bits
C00126 00026	 EMITER Routine
C00130 00027
C00135 00028		SUBI	TEMP,1		FIX IT
C00141 00029
C00144 00030	Qstack Routines -- BPUSH, etc.
C00148 00031
C00151 00032
C00154 00033	PWR2
C00155 00034	GBOUT Description, Loader Block Format Description
C00158 00035	 Control Variables for Loader Block Output
C00161 00036	 Loader Output Blocks-- Entry, Program Name, Initial Stuff
C00165 00037	                        Code, Boolean Code, Fixups, Links
C00169 00038	                        Space Allocation Block
C00173 00039	                        Request Blocks -- RELfile, Libraries
C00175 00040	                        Ending Code, Symbols -- END Block
C00179 00041	 RELINI -- Loader Block Initialization
C00180 00042	 GBOUT Routine
C00183 00043	 CODOUT Routine -- Output Code or Data
C00187 00044
C00188 00045	 FBOUT, etc. -- Output Fixups
C00191 00046	 SCOUT, etc. -- Output Symbols
C00195 00047	 LNKOUT -- Output Linkage Block
C00197 00048	 PRGOUT, FILSCN -- Output Request Blocks, Scan for Source!file Rqst
C00204 00049
C00207 00050	>NOTENX
C00209 00051	  RAD50, RAD52 -- Radix-50 Functions for Scout Routines
C00213 00052
C00214 ENDMK
C⊗;
COMMENT ⊗HISTORY
AUTHOR,REASON
021  102100000044  ⊗;


COMMENT ⊗
VERSION 17-1(36) 3-7-75 BY RHT BUG #UE# STRING ARRAY ISNT A STRING
VERSION 17-1(35) 2-16-75 BY JFR BAIL P.35 DEFINE RESIDENCE OF RUNTIME PROCEDURE DESCRIPTORS
VERSION 17-1(34) 12-7-74 BY JFR DEFINE RESIDENCE OF  BAIL  LOADMODULE
VERSION 17-1(33) 11-3-74 BY RHT BUG TR MAKE GBOUT HONEST ABOUT WORD COUNT
VERSION 17-1(32) 10-10-74 BY RHT FEAT %BR% (REMOVE HACKS)
VERSION 17-1(31) 7-24-74 BY RHT BUG #SV# GET SPAC OF RECORD WAS LOSING
VERSION 17-1(30) 7-22-74 BY RHT BUG #SU# CONV(ARITH) FOR PNTVAR
VERSION 17-1(29) 7-7-74 BY RHT  MANY EDITS FOR RECGC
VERSION 17-1(28) 7-7-74 
VERSION 17-1(27) 7-7-74 
VERSION 17-1(26) 7-7-74 
VERSION 17-1(25) 5-30-74 BY RLS TENEX BUG #SK# DONT MESS UP DEVICE NAME FOR LOAD!MODULE
VERSION 17-1(24) 5-20-74 BY RHT BUG #SA# SHOULD NOT BUMP REF CNT ON GET ADDR
VERSION 17-1(23) 5-14-74 BY RHT BUG #RY# RECUUO (AC) S/B RECUUO 0,AC
VERSION 17-1(22) 4-18-74 
VERSION 17-1(21) 4-12-74 BY RHT %BI% MAKE EMITTER KNOW ABOUT RECORD CLASSES
VERSION 17-1(20) 4-12-74 BY RHT %BI% ADD SOME LOW LEVEL RECORD STUFF
VERSION 17-1(19) 4-12-74 
VERSION 17-1(18) 4-12-74 
VERSION 17-1(17) 4-12-74 
VERSION 17-1(16) 4-12-74 
VERSION 17-1(15) 4-12-74 
VERSION 17-1(14) 4-6-74 BY RLS TENEX
VERSION 17-1(13) 3-17-74 BY RLS TENEX ADDITIONS
VERSION 17-1(13) 2-13-74 BY JRL BUG #RE# STRING ITEMVAR ARRAY NOT STRING ARRAY
VERSION 17-1(12) 1-11-74 BY JRL CMU CHANGE COMVER (UNDER NOHACK)
VERSION 17-1(11) 12-8-73 BY JRL REMOVE SPECIAL STANFORD CHARACTERS(WHERE POSSIBLE)
VERSION 17-1(10) 11-24-73 BY RHT %AL% TAKE HRLOI 12, OUT OF S. SEQUENCE
VERSION 17-1(9) 11-24-73 BY RFS RADIX50 TYPE BITS NOT INSTALLED IN RAD5$, RAD5%
VERSION 17-1(8) 11-13-73 BY JRL FORCE PUT TO ALWAYS DO AN ACCESS
VERSION 17-1(7) 11-13-73 BY JRL BUG #PA# GET ADDR OF MPPARM WAS DESTROYING AC C
VERSION 17-1(6) 11-13-73 BY JRL BUG #OZ# FIX GET FOR INSISTED ITEMVARS
VERSION 17-1(5) 11-4-73 BY JRL BUG #OX# LET PUT KNOW ABOUT ? ITEMVARS
VERSION 17-1(4) 10-26-73 BY  JRL BUG #OR# A STRING ITEM IS NOT A STRING
VERSION 17-1(3) 10-23-73 BY JRL FEATURE %AG& ITEM OVERLAP STUFF
VERSION 17-1(2) 8-16-73 BY JRL REMOVE REFERENCES TO LEAPSW
VERSION 17-1(1) 8-2-73 BY JRL BUG #NK# TEMPS SHOULD NOT HAVE DISPLAY LEVELS
VERSION 17-1(0) 7-26-73 BY RHT **** VERSION IS 17 ****
VERSION 16-2(31) 7-13-73 BY RHT MODIFY SOUT FOR FNYNAM
VERSION 16-2(30) 7-13-73 BY RHT BUG #MN# A DREADFUL KLUGE TO FIX ACCESS BUG
VERSION 16-2(29) 7-13-73 
VERSION 16-2(28) 6-28-73 BY JRL BUG #KA#B IMMEDIATE INSTRUCTIONS NOT USED FOR OR,AND
VERSION 16-2(27) 3-19-73 BY RHT CHANGE SOUT SO STACK SYMBOLS WORK RIGHT
VERSION 16-2(26) 3-13-73 BY JRL REMOVE REFERENCES TO WOM,SLS,GAG,NODIS
VERSION 16-2(25) 2-26-73 BY JRL DO A SKIPE NOEMIT IN XCALLQ
VERSION 16-2(24) 2-6-73 BY JRL MAKE GET HONEST FOR QPARS
VERSION 16-2(23) 1-31-73 BY HJS DISABLE CODOUT, EMITER, AND FBOUT FOR EXPR!TYPE
VERSION 16-2(22) 12-13-72 BY JRL BUG #KS# ADD LOADVR SWITCH
VERSION 16-2(21) 12-13-72 
VERSION 16-2(20) 11-30-72 BY JRL MAKE GET HONEST FOR ? ITEMVARS
VERSION 16-2(19) 11-30-72 BY JRL BUG #KQ# IGNORE FIXARRS IN STORA
VERSION 16-2(18) 11-21-72 BY RHT BUG #KH# DEL FORMFX STUFF FROM SIMPROC FORMALS
VERSION 16-2(17) 10-17-72 BY JRL BUG #JR# STRING ITEMVARS NOT STRING
VERSION 16-2(16) 8-29-72 BY KVL ADD CKECK FOR UNTYPED IN PRE
VERSION 16-2(15) 7-17-72 BY RHT BUG #IO# EVAR MESSED UP BY INDEXED STRING TEMP
VERSION 16-2(14) 7-8-72 BY RHT BUG ##I#L# GET ACCESS TO A VARIABLE IN PRE BEFORE INSISTING
VERSION 16-2(13) 6-30-72 BY DCS BUG #IA# PROTECT PTRAC AC OVER FIX, FLOAT, STRING to INTEGER
VERSION 16-2(12) 6-25-72 BY DCS BUG #HX# PARAMETERIZE LIBRARY NAMES (OTHER THINGS)
VERSION 16-2(11) 6-20-72 BY DCS BUG #HU# BETTER TTY PRINTOUT
VERSION 16-2(10) 6-14-72 BY JRL BUG #HS# AN ITEMVAR IS NOT ITS DATUM(MARK).
VERSION 16-2(9) 5-13-72 BY DCS BUG #HF# MAKE GETAC MUCH MORE HONEST
VERSION 15-2(8) 3-25-72 BY DCS BAD ARRAY ADDRESS PROBLEM
VERSION 15-2(7) 3-10-72 BY DCS REPLACE RING, ULINK MACROS WITH ROUTINES
VERSION 15-2(6) 2-9-72 BY DCS BUG #GQ# MAKE ! = UNDERLINE IN RADIX50
VERSION 15-2(5) 2-5-72 BY DCS BUG #GJ# ADD LSTON LISTING CONTROL STUFF
VERSION 15-2(4) 2-1-72 BY DCS ISSUE %ALLOC SPACE REQUESTS IN NEW WAY (SEE GOGOL FOR FORMAT)
VERSION 15-2(3) 1-10-72 BY DCS BUG #FP# FIX A NEGAT BUG
VERSION 15-2(2) 1-7-72 BY DCS BUG #FY# Fix Strvar←INAC-Intvar bookkeeping problem
VERSION 15-2(1) 12-2-71 BY DCS INSTALL VERSION NUMBER

⊗;

COMMENT ⊗DATA for Total (Low-level Code Production) Routines⊗
	LSTON	(TOTAL)

SUBTTL	WIZARD'S DEN -- Generator Called Routines.
BEGIN	TOTAL

ZERODATA (TOTAL ROUTINE VARIABLES)

;ACKPNT -- next AC # GETAC should try -- used to distribute
;    AC usages among the ACs -- used by GETAC only
?ACKPNT: 0

COMMENT ⊗
FORMFX -- QSTACK descriptor for formal fixups.  Until a recursive
    Procedure has been completely compiled, it is not known how
    many local strings and non-strings will be saved in the runtime
    stacks between the stack tops and the formal parameters.  Therefore
    as instructions accessing parameters are issued, the address
    field displacements (assuming 0 locals) are saved, along with
    the addresses where they are issued, in the FORMFX stack.
    The left half of each entry is the address of the instruction--
    the right half is the desired relative displacement (high-order
    bit specifies String stack or System stack).  After the procedure
    is compiled, these entries are QPOPed off and used, along with
    the ALOCALS, SLOCALS counts (see PROCED variables) to issue
    fixups for these instructions.  This Qstack is not used
    for non-recursive Procedures
⊗
↑↑FORMFX: 0

?POSSIB: 0	;TEMP USED BY GETAC WHEN GETTING 2 

;TEMPNO -- each temp Semblk allocated is assigned a unique
;    number, by incrementing TEMPNO -- a temp Semblk may
;    be used several times in the same procedure.  See GETTEM
;    for description of the mysteries of temps.
?TEMPNO: 0

ENDDATA

COMMENT ⊗Description of Total Routines⊗

DSCR CONV,ACCESS,GET,PUT,STACK,MARK
DES This is the generalized move code. (i.e. called by macro GENMOV).
 It consists of several routines which are called in a uniform
 fashion.  This fashion stipulates that "directive" bits be passed
 in the right half of FF which specify modifiers on the operation
 of the routine called.  Each routine is preceded by a standard
 preamble (PRE) and followed by a standard epilog (POST).

 Some of the directive bits control PRE and POST.  They are:

PAR 
PRE:
1.	If the GETD bit is on, we do a GETAD first (i.e. use PNT
	as the pointer to a symbol table entry, and fill TBITS
	and SBITS. This is useful since many of the GENMOV routines
	require that TBITS and SBITS be set up.
2.	If the PROTECT bit is set, then register D is assumed to have
	an accumulator number in it.  That accumulator table entry
	is "protected". I.e. calls on GETAC and STORA will not affect
	the status of anything marked in that accumulator.
3.	If the EXCHIN bit is set, we do an EXCHOP.
4.	If the INSIST bit is on, type conversions are performed.
	These conversions convert from the type specified in the
	TBITS word to the type specified in register B (bits
	passed to the INSISTer). 
5.	If the ARITH bit is on, we make sure that the type is
	an arithmetic type, performing conversions if necessary.


POST:
1.	Put the current contents of the ac's TBITS and SBITS
	down in the symbol table entry pointed to by PNT
2.	If the REM bit is set, do a REMOP on the thing in PNT
3.	If the BITS2 bit is set, we execute MOVE SBITS2,$SBITS(PNT2)
	This is useful when an operation on one argument of a binary
	op. may change the semantics of another.
4.	If the UNPROTECT bit is set, then register D is assumed to
	contain an ac number.  The ac table entry is unprotected.
5.	If the EXCHOUT bit is set, we do an EXCHOP.

 NOW FOR A DESCRIPTION OF THE ROUTINES WHICH ACTUALLY USE PRE AND POST:

CONV:
	This is really a no-op.  It is here for the purposes of calling
	the type-conversion routines in PRE, and for the purpose of
	making sure that an argument is positive if in an accumulator
	(e.g. if we had  CVF(-(A+B)), then the result would be in an
	accumulator in negated fashion.  We now want to push it onto the
	stack for the call on CVF.  We want to make sure it is REAL and
	positive.  We use the POSIT bit:  GENMOV (CONV,INSIST!POSIT,REAL)


PUT
	This issues a store of accumulator mentioned in register D
	into the thing described in TBITS, SBITS, PNT.  The accumulator
	table is updated to reflect this store (i.e. the thing talked about
	by PNT is marked as "inac").

	If the PNT entry is a string, then D is assumed to be an ac.
	into which a HRROI was done, or the SP stack.  At any rate, two
	POP's are emitted.

ACCESS:
	This routine makes sure that we can have access to the entry
	mentioned in PNT.  That is, if the thing is indexed (result of
	an array calculation) and if it requires that some index accumulator
	be loaded with a good number, then the load will happen, so
	that an effective address can be generated which points at
	the thing talked about by PNT.

GET:
	This is the generalized "get this entity in an ac" routine.
	It makes many checks (i.e. is it already in an ac?) and
	finally returns in register D the number of the ac which
	has been loaded, and returns in SBITS the updated semantics
	information that now reflects the loaded state.
	(By the way, to "get" a string means to do HRROI ac,second word
	of string.. This is so that POP's can be done later). There
	are many modifier bits to this routine:

	DBL	-- make sure that the ac following the one loaded
			 is free (for a double ac operation such as IDIV)
	INDX	-- make sure entity is loaded in an AC which can be
			 used for indexing (i.e. not 0 or 1.  The reason
			 for including 1 in this is a bit vague -- since
			 runtime routines often return results in 1, we
			 try to avoid its use for things thay may have
			 to be stored as temps).
	SPAC	-- load this into a special accumulator.  That accumulator
			number is passed in D.
	ADDR	-- load the address of this entity, not the value.
	POSIT	-- make sure the entity is in the ac in positive form.
	NEGAT	-- make sure in negative form.
	NONSTD	-- if indxed temp, do not remop it as someone wants
			to use it again. (see SWPR for instance).  The
			problem is not so much remopping, but that GET
			likes to make the semantic entries as "inac" on
			exit.  This fouls up any index calculations that
			may have been stored in the PNT entity.
	MRK	-- when done with the GET, call MARK (see below).

STACK:
	The entity mentioned in PNT is stacked on an appropriate
	stack.  Strings (except arrays) are stacked on the SP
	stack, all others on the P stack.  ADEPTH or SDEPTH is 
	updated.

MARK:
	This uses the bits in TBITS and SBITS, and the ac number
	in D as prototypes for making up a temp descriptor, and
	marking the ac full with that temp.  Return is a valid
	temp descriptor in PNT. If STRING is on in TBITS,
	a stacked-string descriptor will be generated
	(and of course, no accumulator will be marked).
	WARNING ***** MARK masks off some bits in SBITS and
	TBITS.  PTRAC,CORTMP,INDXED,FIXARR are turned off in SBITS
	and the only bits honored by TBITS are:
	LPARRAY,SET,ITEM,ITMVAR,INTEGR,FLOTNG,STRING

SID 
ACCUMULATORS:
FF		-- RIGHT HALF SAVED.
A		--THIS MAY BE CHANGED
B		--SAVED, I BELIEVE.
C		--SAVED, I BELIEVE.
D		--OCCASIONALLY FILLED UP (E.G. GET,ACCESS)
TBITS		-- THESE ARE THE SEMANTIC BITS -- THEY MAY BE CHANGED.
SBITS		--  "
PNT		-- "  (IN CASE OF MARK OR CONVERSIONS)
LPSA		CLOBBERED
USER		CLOBBERED
TEMP		CLOBBERED
SP		--SAVED
SBITS2		--SAVED (modulo what is done in PRE).
TBITS2		--SAVED
PNT2		--SAVED

SEE GENMOV MACRO
⊗;

COMMENT ⊗CONV, PRE, POST -- Type-Conversion routines⊗

MASK←←	0+LPARRAY+SET+LSTBIT+ITEM+ITMVAR+INTEGR+FLOTNG+STRING		
				;GENMOVE KNOWS ABOUT THESE TYPES
REC <
MASK ←← MASK+PNTVAR
>;REC

;THIS IS THE PREAMBLE FOR ALL OF THE ROUTINES WHICH
;USE DIRECTIVE BITS TO SPECIFY COERCIONS, EXCHOPS, ETC.

PREMASK ←← GETD!EXCHIN!INSIST!ARITH!PROTECT


↑↑CONV: TRNE	FF,PREMASK
	PUSHJ	P,PRE			;DO EVERYTHING HERE.
	TLNE	SBITS,NEGAT		;IF NOT NEGAT OR
	TRNN	FF,POSIT		;NOT NEED THINGS POSITIVE?
	 JRST	 POST			;ALL DONE.
	JRST	GETOPE			;DO THE GET.



PRE:	TRNE	FF,GETD			;DO A GETAD?
	 PUSHJ	 P,GETAD		;YES
	TRNE	FF,EXCHIN!PROTECT	;EXCHOP ON WAY IN?
	 JRST	 [TRNE  FF,PROTECT
		   HRROS ACKTAB(D)
		  TRNN  FF,EXCHIN
		   JRST .+1
		   EXCHOP
		 JRST .+1]
	TRNN	FF,INSIST!ARITH		;ANY COERCIONS TO DO?
	 POPJ	 P,			;NO -- ALL DONE.
	PUSHJ	P,QTYPCK
				;CHECK FOR UNTYPED AND TYPE IF NEC. (SEE ERRORS)
;#IL# 7-8-72 RHT ! GET ACCESS BEFORE YOU CONVERT
	PUSHJ	P,ACCOP			;GET ACCESS -- YOU MAY NEED IT
	TRNE	FF,ARITH		;WANT TO BE SURE OF ARITH ARG?
	JRST	AGET			;YES
LEPPRE:	TRNN	TBITS,ITEM!ITMVAR	;IF EITHER HAS ITEM BITS ON.
	TRNE	B,ITEM!ITMVAR		;ALL THESE ARE GOOD GUYS.
	JRST	[ ;....			;KEEP GOING.
		TRNE	B,ITEM!ITMVAR
		TRNN	TBITS,ITEM!ITMVAR
		ERR	<ITEM TYPE MISMATCH >,1
		POPJ	P,]		;THIS IS ALL THE CHECKING!
        TRNE	B,SET			;A SET OR LIST DESIRED?
	JRST	[TRNN	TBITS,SET	;IF NOT LIST OR A SET CAN'T BE DONE
		 ERR	<TYPE CAN'T BE CONVERTED TO SET OR LIST>,1
		 TRNE	B,LSTBIT	;IF WANTED LIST CAN RETURN
		 JRST   MAKLST		;MAY HAVE TO COPY LIST.
		 TRNN	TBITS,LSTBIT	;IF WANTED SET AND HAVE SET CAN RETURN
		 POPJ	P,
		 JRST   MAKEST]		;WILL HAVE TO CALL CVSET
	MOVE	USER,B			;COPY OFF.
	MOVE	TEMP,TBITS
	AND	TEMP,[XWD SBSCRP,MASK≠(ITEM!ITMVAR)]
	ORCB	USER,[XWD SBSCRP,MASK≠(ITEM!ITMVAR)]
	TDNN	TEMP,USER		;ARE ALL BITS IN B ON IN TBITS?
	POPJ	P,			;THEY MATCH !!
REC <	
	TRNE	TBITS,PNTVAR		;IF RECORDS & INSISTING
	TRNE	TBITS,SHORT!ITEM!ITMVAR	;THEN BETTER BE SURE CLASSES MATCH
	JRST	AGOTH			;NOT THAT CASE, ANYHOW
	PUSH	P,PNT2			;NOTE DON'T CHECK ITEMS
	PUSH	P,LPSA
	HLRZ	PNT2,$ACNO(PNT)		; THE CLASSID
	SKIPN	LPSA,RCLASS		;
	ERR	<RCLASS = 0 ON INSISTING GET>,1
	PUSHJ	P,SUBFOK		;CHECK CLASS ID
	ERR	<CLASS DISAGREEMENT FOR RECORD COERCION>,1
	TRNN	FF,MRK			;ASKED FOR A MARK
	SETZM	RCLASS			;NO, ALWAYS CLEAR THIS OUT
	POP	P,LPSA
	POP	P,PNT2
>;REC
AGOTH:	
	PUSH	P,FF
	TRZ	FF,-1≠NONSTD		;IN CASE ANY OTHER ROUTINES CALLED.
	PUSH	P,D
	TRNE	B,INTEGR+FLOTNG
	JRST	RESAR			;INSISTS ON ARITHMETIC TYPE
	TRNE	B,STRING
	JRST	RESSTR			;INSISTS ON STRING
	ERR	<GENMOV MAY BE GENERAL, BUT ...>,1
	JRST	GEMGO			;GO ON ANYWAY



RESSTR:	TRNN	TBITS,INTEGR		;INSIST ON INTEGER ARGUMENT.
	ERR	<STRINGS OF NON-INTEGERS?>
	TLNN	TBITS,CNST		;CONSTANT?
	JRST	STR1			;NO
	EXCH	SP,STPSAV		;GET A GOOD STACK POINTER.
	MOVSS	POVTAB+6		;ENABLE FOR STRING PDLOV
	PUSH	P,$VAL(PNT)
	PUSHJ	P,PUTCH			;MAKE A STRING (SLOWLY)
	POP	SP,PNAME+1
	POP	SP,PNAME
	EXCH	SP,STPSAV		;AND RESTORE EVERYONE.
	MOVSS	POVTAB+6		;RE-ENABLE FOR PARSE PDLOV
	PUSHJ	P,STRINS		;INSERT A STRING CONSTANT
					;THIS DOES A GETAD.
	JRST	GEMGO			;ALL DONE

STR1:					;PREPARE TO STACK THE INTEGER
	PUSHJ	P,STACK1		;DO THE STACK.
	SOS	ADEPTH			;SINCE THE RUNTIM ROUTINES ADJUST.
	MOVEI	TEMP,2
	ADDM	TEMP,SDEPTH		;INCREASE DUE TO CALL.
	XCALL	<PUTCH>			;FUNCTION CALL
	MOVEI	SBITS,0			;START WITH CLEAN DYNAMIC SLATE
	JRST	TGO			;GO MAKE A TEMP.



;;#SU# ! ADD PNTVAR TO THIS LIST
AGET:	TRNE	TBITS,INTEGR+FLOTNG+PNTVAR	;IS IT ALREADY ARITHMETIC TYPE?
	 POPJ	 P,			;YES
	PUSH	P,FF
	TRZ	FF,-1≠NONSTD		; SAVE ALL THIS FOR OTHER
	PUSH	P,D			; EMBEDDED OPERATIONS
	MOVEI	B,INTEGR		;THIS FOR THE BENEFIT OF ARSTR.
RESAR:	TRNE	TBITS,STRING		;HERE TO GET ARITHMETIC RESULTS
	JRST	ARSTR			;CONVERT FROM STRING
	TRNE	TBITS,INTEGR+FLOTNG
	JRST	FIXFL
	ERR	<THE CONVERSION YOU HAVE REQUESTED ...>,1
	JRST	TGO			;MAKE A TEMP FOR IT ANYWAY...

ARSTR:	TLNE	TBITS,CNST		;CONSTANT?
	JRST	STRCNS
;;#IA# 6-30-72 DCS (3-6) PROTECT PTRAC AC OVER GETAC
	HRLI	PNT,-1			;FLAG, ASSUME PROTECTION
	HRRZ	TEMP,$ACNO(PNT)		;PTRAC AC #, IF ANY
	TLNN	SBITS,PTRAC		;NEED PROTECTION?
	TLZA	PNT,-1			;NO, UNMARK
	HRROS	ACKTAB(TEMP)		;YES, PROTECT
;;#IA# (3-6)
	PUSH	P,B			;SAVE TYPE WORD
	PUSHJ	P,GETAN0		;NON-0 AC NUMBER
	JUMPGE	PNT,.+3			;NEED TO UNPROTECT?
;;#IA# 6-30-72 (4-6)
	HRRZ	TEMP,$ACNO(PNT)		;YES, DO
	HRRZS	ACKTAB(TEMP)		; IT
;;#IA# (4-6)
	MOVE	A,[HRRZ LNWORD] 	;CALCULATE LENGTH TO THIS AC
	PUSHJ	P,STROP			;VIA STROP
	HRL	B,PCNT			;SAVE PC FOR FIXUP
	HRLI	C,0
	EMIT	(<JUMPE USADDR!NORLC>)	;0 IF STRING EMPTY
	TLNE	SBITS,STTEMP		;NO NEED TO COPY BP IF TEMP STRING
	 JRST	 [MOVE A,[ILDB BPWORD]
		  PUSHJ P,STROP		;SO DO ILDB DIRECTLY
		  JRST NOCOP]		;AND GET OUT
	MOVE	A,[MOVE BPWORD] 	;GET COPY OF BP
	PUSHJ	P,STROP			;IN SAME AC
	HRL	C,D
	EMIT	(<ILDB USADDR!NORLC>) 	;ILDB AC,AC
NOCOP:	HRR	B,PCNT			;FIXUP WORD
	PUSHJ	P,FBOUT
	MOVEI	A,UNDO!REM
	PUSHJ	P,STROP			;NOW ISSUE SUB IF NECESSARY
	PUSHJ	P,MARKINT		;MARK INT. RETS RIGHT THING IN PNT
	POP	P,B
	TRNE	B,INTEGR		;CONVERT ONLY TO INTEGER?
	JRST	GEMGO			;YES, OK.
	JRST	FIXFL			;GO ON FARTHER

  
STRCNS:	HRRZ	TEMP,$PNAME(PNT)	;THIS IS THE SAME CODE AS
	JUMPE	TEMP,.+3		; SAIL GENERATES TO DO
	MOVE	TEMP,$PNAME+1(PNT)	; STRING to INTEGER AT 
	ILDB	TEMP,TEMP		; RUNTIME
	TRNN	B,INTEGR		;DOES HE WANT AN INTEGER CONST
	FLOAT	TEMP,TEMP		;NO -- ASSUME FLOATING
	JRST	CONGO			;GO INSERT A CONSTANT.

FIXFL:
;;%DN% JFR 7-1-76
	MOVE	TEMP,ASWITCH		;OPTION BITS
	MOVSI	A,(<FIX>)		;ASSUME STANDARD
	TRNE	TEMP,AFIXR
	 MOVSI	A,(<FIXR>)
	TRNE	TEMP,AKIFIX
	 MOVSI	A,(<KIFIX>)
	MOVE	USER,A			;COPY THE DECISION
	OR	USER,[TEMP,TEMP]	;INSERT AC AND ADDR FIELDS
;;%DN% ↑
	MOVE	TEMP,TBITS		;GET OR OF `SHORT' BITS
	OR	TEMP,B
	TRNE	B,INTEGR		;RESULT FIXED?
	JRST	FIX			;YES
;;%DN%
	MOVE	TEMP,ASWITCH
	MOVSI	A,(<FLOAT>)
	TRNE	TEMP,AFLTR
	 MOVSI	A,(<FLTR>)
	MOVE	USER,A
	OR	USER,[TEMP,TEMP]
	MOVE	TEMP,TBITS		;GET OR OF `SHORT' BITS
	OR	TEMP,B
;;%DN% ↑
	TLNE	TBITS,CNST		;CONSTANT?
	JRST	FLC
	TRNN	TEMP,SHORT		;SHORT INTEGER BEGIN FLOATED?
	 JRST	 UUOGO			;NO, USE UUO
	PUSH	P,[FSC USADDR!NORLC] 	;INSTR TO FLOAT
	HRLI	C,233			;ARGUMENT OF FLOAT INSTR
SHRTCV:	MOVE	TEMP,-2(P)		;FF BITS COMING INTO TOTAL
	TRNE	TEMP,SPAC		;WAS SPECIFIC AC REQUIRED
	TRO	FF,SPAC			;YES, RETAIN IT
	PUSHJ	P,GET			;GET THE THING
	POP	P,A			;INSTR
	JRST	JSTEST			;ALREADY KNOW WHAT AC


FIX:	TLNE	TBITS,CNST		;CONSTANT?
	JRST	FLC
NOEXPO<
	TRNN	TEMP,SHORT		;CONVERT TO SHORT INTEGER?
	 JRST	 UUOGO			;NO
	PUSH	P,[PDPFIX USADDR!NORLC]	;YES, USE PDP-10 INSTR
	HRLI	C,233000		;MAGIC ADDR FIELD FOR PDPFIX INSTR
	JRST	SHRTCV			;DO SHORT CONVERSION
>;NOEXPO

UUOGO:	MOVE	TEMP,-1(P)		;DIRECTIVE BITS WORD FROM STACK.
	TRNE	TEMP,SPAC		;IS HE GOING TO WANT A SPECIAL ONE?
	JRST	JSTEST			;YES
	HRR	D,$ACNO(PNT)
;;#IA# 6-30-72 DCS (5-6) PROTECT PTRAC AC OVER GETAC
	HRLI	PNT,-1			;FLAG, ETC., SEE PART (3-6)
	TLNN	SBITS,PTRAC
	TLZA	PNT,-1
	HRROS	ACKTAB(D)
;;#IA# (5-6)
	TLNN	SBITS,INAC		;IF NOT IN AN AC, THEN GET ONE.
	PUSHJ	P,GETAC
;;#IA# 6-30-72 (6-6)
	JUMPGE	PNT,.+3
	HRRZ	TEMP,$ACNO(PNT)
	HRRZS	ACKTAB(TEMP)
;;#IA# (6-6)
GOTACB:
JSTEST:
	DPB	D,[POINT 4,A,12] 	; STORE AC NUMBER IN INSTRUCTION.
	PUSHJ	P,EMITER
	HRRZ	TEMP,FF			;ORIGINAL FF
	TRNE	TEMP,NONSTD		;IF NON-STANDARD (SEE SWAP OPER),
	 JRST	 [POP P,(P)		; DON'T REMOP OR MARK
		  JRST GEMGO1]		;BUT RETAIN THE AC USED
	PUSHJ	P,REMOP			;REMOP THE OPERAND.
TGO:	HRRZ	TBITS,B			;MAKE TBITS CONFORM TO THE DESIRED TYPE
	ANDI	TBITS,MASK		;MAKE RESULT LOOK LIKE THE REQUESTS
	TLZ	SBITS,-1≠NEGAT		;CLEAR AWAY THE CHAFF
	PUSHJ	P,MARK1			;GO DO A MARK.
	JRST	GEMGO

FLC:	MOVE	TEMP,$VAL(PNT)		;HERE FOR A CONSTANT.
	XCT	USER			;DO THE CONVERSION
CONGO:	MOVEM	TEMP,SCNVAL		;SET UP FOR SYMBOL TABLE INSERTION
	HRRZ	TBITS,B			;COME HERE TO INSERT A CONSTANT.
	ANDI	TBITS,MASK
	TLO	TBITS,CNST
	MOVEM	TBITS,BITS		;FOR CONINS
	PUSHJ	P,REMOP			;ALWAYS REMOVE THE OLD GUY
	PUSHJ	P,CONINS
GEMGO:	POP	P,D
GEMGO1:	POP	P,FF			;AT LAST DO THE POP AND
	POPJ	P,			;ALL DONE -- FULL SPEED AHEAD.


; NOW FOR THE POSTAMBLE (WE WILL AMBLE THROUGH THE COMPILATION).


POST:	MOVEM	SBITS,$SBITS(PNT) 	;PUT DOWN SEMANTICS WORDS.
	MOVEM	TBITS,$TBITS(PNT)
	TRNN	FF,EXCHOUT!BITS2!REM!UNPROTECT ;THESE ARE THINGS TO DO.
	POPJ	P,			;ALL DONE.
	TRNE	FF,REM			;REMOP THE THING?
	 JRST	[PUSHJ   P,REMOP	;YES
		 MOVE	SBITS,$SBITS(PNT)
		 JRST	.+1]
	TRNE	FF,BITS2		;UPDATE SBITS2?
	 MOVE	 SBITS2,$SBITS2(PNT2) 	;DONE.
	TRNE	FF,UNPROTECT
	 HRRZS	 ACKTAB(D)
	TRNN	FF,EXCHOUT		;EXCHANGE ON WAY OUT?
	POPJ	P,			;NO --DONE.
	EXCHOP
	POPJ	P,

COMMENT ⊗PUT⊗

↑↑PUT:	TRNE	FF,PREMASK	;ANY PREAMBLE TO BE DONE
	 PUSHJ	 P,PRE		;YES -- DO IT.
	PUSH	P,FF		;HERE TO STORE AN ACCUMULATOR INTO
; HAVE PUT ALWAYS DO AN ACCESS
;	TLNE	SBITS,INDXED	;A DESCRIPTOR
	PUSHJ	P,ACCOP		;GET ACCESS TO THE TARGET.
	TRNE	TBITS,STRING	;IF NOT A STRING
	TDNE	TBITS,[XWD SBSCRP,ITEM!ITMVAR] ;OR NOT REALLY A STRING,THEN
	 JRST	 APUT		;USE A MOVEM OR THE LIKE.

	MOVE	A,[POP	BPWORD!LNWORD!SBOP!BPFIRST]
	PUSHJ	P,STROP		;USE THE STRING OPERATION TO PUT OUT POPS.
	CAIE	D,RSP		;IF IT WAS NOT THE STACK, THEN
	 PUSHJ	 P,CLEARA	;CLEAR OUT THIS ACCUMULATOR ENTRY.
				;IT WAS CHANGED WHEN THE POPS WERE DONE ANYWAY.
	JRST	PUTFIN		;ALL DONE.  MY THAT WAS SIMPLE.

APUT:	PUSHJ	P,CLEARA	;CLEAR OUT THE DESTINATION ACCUMULATOR.
	TLNE	SBITS,INAC	;IF THE DESTINATION OF THE STORE IS ALREADY
	PUSHJ	P,CLEAR		;IN AN AC, THEN CLEAR IT OUT.
REC <
NORGC <
	TRNE	TBITS,PNTVAR		;A RECORD ?
	TRNE	TBITS,777777-(PNTVAR!GLOBL)
	JRST	APUT2			;NOPE, JUST DO THE PUT
	PUSH	P,C			;IT MAY BE USED, NOT SURE
	MOVNI	C,1			;DEREFERENCE THE THING IN PNT
	PUSHJ	P,RFCADJ		;LIKE SO
	POP	P,C
	
APUT2:
>;NORGC
>;REC
	HRLZI	A,(<MOVEM>)	;THE ORDINARY STORE INSTRUCTION.
	TLNE	SBITS,NEGAT	; BUT IF NEGATED, USE THE OTHER
	HRLI	A,(<MOVNM>)
;; #OX# TREAT ? ITEMVARS SPECIALLY
	TLNE	TBITS,MPBIND
	JRST	[HRR	C,D	;SAVE AC NUMBER
		 GENMOVE (GET,ADDR!INDX)
		 MOVSS	D	
		 HRR	D,C	;XWD INDX,,AC
		 MOVE	A,[MOVEM USX+NORLC+NOADDR]
		 JRST	.+1
		 ]	;GO AWAY
;; #OX#
	PUSHJ	P,EMITER	;AND PUT OUT THE INSTRUCTION.
	
	TLNE	SBITS,INDXED	;WE DO NOT WANT TO MARK *********
	 JRST	 PUTFN1		;GO AWAY.

	HRRM	D,$ACNO(PNT)	;AND THE AC IT IS IN
	HRRM	PNT,ACKTAB(D)	;IN TWO PLACES.
				;THIS UNPROTECTS THIS ACCUMULATOR.
	TLOA	SBITS,INAC	;AND NOW MARK THE DESCRIPTOR BITS

PUTFN1:	TLZ	SBITS,NEGAT	;SUBSCRIPTED, NEGAT GETS IN WAY (BELIEVE!)
PUTFIN:	POP	P,FF		;ALL DONE
	JRST	POST		;AND FINISH OUT.

COMMENT ⊗ACCESS,GETSDR,GETDR,DISBLK,ZOTDIS--last four  only for dis

Call ACCOP when you need to reference a thing and don't know whether you
 can get at it in a single instruction (i.e. an indexed thing). 
GENMOV(ACCESS)  will cause ACCOP to be called for you.
 People like GET and STACKOP do it automatically.
⊗

↑↑ACCESS: TRNE	FF,PREMASK
	PUSHJ	P,PRE
	PUSHJ	P,ACCOP
	JRST	POST

ACCOP:	TDNN	SBITS,[XWD INDXED,DLFLDM]; ONLY CARE IF INDEXED OR NEED A DISPLY
	POPJ	P,
	TLNE	SBITS,INAC!PTRAC	;IF IN AN AC WE CAN ACCESS IT
	POPJ	P,
	TRNN	SBITS,DLFLDM		;IF DISPLAY LEV=0 ONLY CARE ABOUT INDEXED 
	JRST	INXSTF			;NO WORRY ABOUT THE DIAPLAY
	LDB	TEMP,[LEVPOINT<SBITS>]	;PICK UP DISPLY LEV
	TRNE	TBITS,STRING		;IS ITT A STRING
	JRST	[
;; #JR# BY JRL 10-17-72 ITEMVARS,ARRAYS DON'T USE STRING STACK
		 TDNN TBITS,[REFRNC!SBSCRP,,ITEM!ITMVAR];THESE THINGS DON'T USE 
		 TLNE SBITS,INDXED	;INDEXED?       ;STRING STACK
		 JRST .+1
;; #JR#
		 JRST	GETSDR	;GET STRING DR
		]
	PUSHJ	P,GETDR			;GET A DISPLAY REG LOADED
	TRNN	SBITS,INDXED		;INDEXED TOO?
	POPJ	P,			;NO
INXSTF:
;;#JR#
	TRNN	TBITS,ITEM!ITMVAR
	TRNN	TBITS,STRING	;ALWAYS NEED STRING GUYS
	JRST 	.+2
;;#JR#
	JRST    ACMOP
	HRRZ	TEMP,$VAL(PNT)	; ONLY NEED IT IF NON-ZERO
	JUMPE	TEMP,CPOPJ	;  DISPLACEMENT

ACMOP:	TLNE	SBITS,PTRAC	;IS IT ALREADY ACCEPTABLE (IN AC)?
	 POPJ	 P,		; YES, WHY HAVE WE WORRIED?

	PUSH	P,D		;HAVE TO SAVE CURRENT AC
	PUSH	P,A
	PUSH	P,FF
	HRRI	FF,INDX		;SO THAT NOTHING NONSTD WILL HAPPEN.
	MOVE	A,[XWD 40!2!1,ADDR] ;SET NECESSARY BITS
				;(SPECIAL BIT, MOVE, GET AC, USE INDXBLE AC, GET ADDR)
	PUSHJ	P,GETWD
	POP	P,FF
	POP	P,A
	POP	P,D
	POPJ	P,


COMMENT⊗
DSCR	GETSDR,GETDR
DES	ROUTINES TO LOAD UP STRING (ARITHMETIC) DISPLAYS
	LOADS UP LPSA WITH THE AC NO TO USE & FIXES UP ACTAB,DISTAB,&DISLST
PARM	TEMP=LEVEL DESIRED
SID	MANGLE	TEMP,LPSA
	STORES LEVEL IN LSDRLV, STORES DR # IN LSDRNM (LH FOR SDR & RH FOR DR)
⊗

;;#MN# 7-13-73 FIX ACCESS PROBLEM
ZERODATA(EMITTER DATA)
LSDRLV: 0 ;SEE ABOVE
LSDRNM: 0
ENDDATA

↑↑GETSDR: 
	HRLM	TEMP,LSDRLV		;REMEMBER LEVEL OF STRING REQUEST
	HLRZ	LPSA,DISTAB(TEMP)	;DO WE HAVE IT ALREADY
	HRLM	LPSA,LSDRNM		;IF SO REMEMBER
;;#MN#
	JUMPN   LPSA,CPOPJ		;YES
	PUSHJ	P,GETDR			;GET THE P-DISPLY
	PUSH	P,FF			;WHAT A PITY WE MIGHT HAVE JUST POPPED
	PUSH	P,A			;BUT THIS IS QUICKER IN THE LONG
	PUSH	P,B			;RUN THAN MESSING WITH FLAGS
	PUSH	P,C			;
	PUSH	P,D
	TRZ	FF,DBL			;ONLY ONE AC
	HRL	D,LPSA			;USE P-DR AS INDEX
	MOVE	B,TEMP			;WE WILL NEED THIS
	HRLI	C,2			;DISPL OF 2
	PUSHJ	P,GETAN0		;GET AN AC FOR DISPLY
	EMIT	(<MOVE ,USX!USADDR!NORLC>) ;LOAD THE DR
	HRLM	D,DISTAB(B)		;ENTER INTO DISPLAY TABLE
	PUSHJ	P,DISBLK		;SET	UP MOST OF BLOCK
	MOVEI	TEMP,STRING		;
	HRRZM	TEMP,$TBITS(LPSA)	;MAKE TYPE RIGHT
	MOVSS	$VAL(LPSA)		;FIX UP AND MASK
;;#MN#  !
	HRLM	LPSA,LSDRNM

	JRST	RETSEQ			;GO POP STUFF & RETURN
↑↑GETDR:
;;#MN#	!
	HRRM	TEMP,LSDRLV
	HRRZ	LPSA,DISTAB(TEMP)	;PICK UP THE PUTATIVE REGISTER
;;#MN#  !
	HRRM	LPSA,LSDRNM
	JUMPN	LPSA,CPOPJ		;IF THERE,RETURN
	PUSH	P,FF
	PUSH	P,A
	PUSH	P,B
	PUSH	P,C
	PUSH	P,D
	PUSH	P,TEMP			;GETDR MUST SAVE IT
	TRZ	FF,DBL			;ONLY ONE AC
	HRRZI	B,1(TEMP)		;NEXT LEVEL DEEPER

GDR1:	HRLZ	D,DISTAB(B)		;PICK IT UP
	CAIN	D,0			;IS IT LOADED
	AOJA	B,GDR1			;NO
	HRLI	C,1			;SET TO SELECT STATIC LINK
	MOVE	A,[<MOVE 0,USX!NORLC!USADDR>]	
GDR2:	PUSHJ	P,GETAN0		;THIS BETTER LEAVE LH(D) ALONE -- IT DOES
	PUSHJ	P,EMITER		;UP ONE STATIC LINK
	SOS	B			;BACK A LEVEL
	HRRM	D,DISTAB(B)		;SAY WE HAVE IT
	PUSHJ	P,DISBLK		;TO DO STUFF FOR DISPLAY BLOCK&ACKTAB
	CAMN	B,(P)			;IS THIS THE ONE WE WANT
	JRST	GDR4			;YES
GDR3:	HRL	D,D			;USE AS INDEX PERHAPS
	HRR	D,DISTAB-1(B)		;NEXT AC BACK
	TRNE	D,-1			;IS IT THERE
	SOJA	B,GDR3			;YES
	JRST	GDR2			;NO--FETCH IT
GDR4:	HRRZ	LPSA,D			;AC NO OD DISPLY
;;#MN# !
	HRRM	LPSA,LSDRNM		;REMEMBER NUMBER
	POP	P,TEMP
;;#UW# ! JFR 8-17-75 CALL TO EMITER AT GDR2+1 WIPED OUT LSDRLV
	HRRM	TEMP,LSDRLV
RETSEQ:	POP	P,D
	POP	P,C
	POP	P,B
	POP	P,A
	POP	P,FF
	POPJ	P,			;RETURN

COMMENT ⊗
DSCR DISBLK
DES THIS PROCEDURE SETS UP DISPLAY SEMBLK STUFF & UPDATES ACKTAB
	IT SETS LPSA TO POINT ATE THE NEW SEMBLK
	THE BLOCK IS SET UP FOR A LPSA TYPE SEMBLK
PARM	B = DISPLAY LEBEL
	D= ACNO OF DISPLAY REG
⊗
↑↑DISBLK:
	GETBLK				;GET A BLOCK
	HRRM	D,$ACNO(LPSA)		;SAVE AC NO
	HRRM	B,$ADR(LPSA)		;LEVEL GOES HERE
	SETOM	TEMP
	HRLZM	TEMP,$VAL(LPSA)		;SETS UP ANDING MASK
	MOVE	TEMP,[XWD PTRAC!INAC!DISTMP,INTEGR]
	HRRZM	TEMP,$TBITS(LPSA)	;$TBITS WORD
	HLLZM	TEMP,$SBITS(LPSA)	;$SBITS WORD
	PUSHJ	P,RNGDIS		;PUT IT ON DISLST LIST
	HRRZM	LPSA,ACKTAB(D)		;MARK AC FULL OF IT
	POPJ	P,			;RETURN

COMMENT ⊗
DSCR ZOTDIS
DES this procedure will wipe out your current display
PARM None
SID LPSA,TEMP used
⊗
↑↑ZOTDIS:
	PUSH	P,D			;SAVE
	PUSH	P,A
	MOVE	A,CDLEV			;CURRENT DISPLAY LEVEL
ZDIS.1: SOJL	A,ZDIS.2
	HRRZ	D,DISTAB+1(A)
	CAIE	D,RF			;DONT ZONK RF
	CAIN	D,			;DONT DO ANYTHING IF NOT THERE
	SKIPA
	PUSHJ	P,STORZ
	HLRZ	D,DISTAB+1(A)
	CAILE   D,
	PUSHJ	P,STORZ
	SETZM	DISTAB+1(A)
	JRST	ZDIS.1
ZDIS.2: POP	P,A
	POP	P,D
	POPJ	P,



COMMENT ⊗GET

	GENMOV(GET) generally invokes this routine.
	It has many purposes, depending on the entity to be "getted".
	Briefly, however, it loads an AC with the thing one
	wants in order to store or compute using the entity in
	question.  For strings, it loads a string address
	with the left half negative (for popping). For 
	INDXED guys (with ADDR turned on), it loads
	the result of the index calc to an ac if it was not 
	there. For regular variables, it simply picks them
	up if they are not in an AC.  The bits 
	ADDR, INDX,  DBL, POSIT, NEGAT, and MARK
	may be used to modify the action of GETOPE.

⊗

↑↑GET:	TRNE	FF,PREMASK	;ANYTHING TO DO??
	 PUSHJ	 P,PRE
	TRC	FF,INSIST!NONSTD 	;IF NO MARKING TO BE DONE, AND
	TRCE	FF,INSIST!NONSTD	; A TYPE CONVERSION WAS DONE,
	 JRST	 GETOPE
;; #OZ# (1 OF 1) PRE DOESN'T DO A GET OF ITEMS OR ITEMVARS
	TRNE	B,ITMVAR!ITEM		; PRE DID NOT DO A GET
					; IF ITEMVARS OR ITEMS
	JRST	GETOPE
;; #OZ#
	HRRZ	TEMP,B			; (COMPARE INSISTED TYPE WITH
	CAIE	TEMP,(TBITS)		;  ACTUAL TYPE), THEN DON'T GET
	 JRST	 POST			;  AGAIN
↑GETOPE:
	PUSHJ	P,ACCOP		; ESTABLISH ACCESS TO THE EFFECTIVE ADDRESS.

COMMENT ⊗ IF STTEMP, NO MORE WORK NECESSARY
	(ASSUME STRING IS ON) ⊗

	TLNN	SBITS,STTEMP
	JRST	GETOPC
	TRNN	FF,ADDR		;MUST GO THRU WITH IT IF ADDR
	 JRST	 TMPRET

COMMENT ⊗ USE LEFT HALF OF A TO HOLD SOME EXTRA BITS:

	1 -- NEED AN AC (GETAC)
	2 -- DO A MOVE OF SOME SORT
	4 -- DO A MOVN
	10 - MAKE IT A HRRO
	20 - MAKE IT A HRROI, FOR STRING INDXED GUYS (SEE BELOW)
	40 - SPECIAL ACCOP BIT, SEE GETRET BELOW
	100 - SEEMS TO MEAN MOVEI -- WASN'T DOCUMENTED, DAMMIT
	200 - SPECIAL KLUGERY FOR RECORDS
	400 - KLUGE TO PREVENT GET ADDR OF REGULAR THING
		FROM MARKING INAC.  

NEED EXTRA CHECKS IF ENTITY IS ALREADY IN AN AC
⊗

GETOPC:	HRLZI	A,3		;ASSUME NEED A MOVE
	TRNE	FF,SPAC		;UNLESS AC # PROVIDED,
	 TLZ	 A,1		; ASSUME AC NEEDED
	TLNN	SBITS,INDXED	;IF ¬INDEXED, THEN TURN OFF NONSTD.
	 TRZ	 FF,NONSTD	;SO AS NOT TO FOUL UP.
REC <
	TRNE	TBITS,PNTVAR		;MAKE SURE ONLY DO KLUGE IF A RECORD
	TRNE	TBITS,777777-(PNTVAR!GLOBL) ;ONLY THAT BIT IS ALLOWED TO BE ON
	JRST	NOSPAC			; NOT A RECORD

;;#SA# ! GET ADDR IS JUST NORMAL
	TRNE	FF,ADDR			;WELL??
	JRST	NOSPAC

	HLRZ	TEMP,$ACNO(PNT)		;IN CASE WE WANT A MARK (USUALLY WILL)
	TRNE	FF,MRK			;TEST IT OUT
	HRRZM	TEMP,RCLASS		;NOW THE MARK WON'T DRYROT
	TLNE	TBITS,CNST		;CONSTANTS ARE GETTABLE DIRECTLY
	JRST	[ CAME	PNT,NLRCBK	;THIS SHOULD BE THE ONLY ONE POSSIBLE
		ERR	<RECORD CLASS TEMP OTHER THAN NULL RECORD?>,1
		JRST	NOSPAC
		]

	TLNN	SBITS,ARTEMP		;IF NOT A TEMP
	JRST	RECKL1			;THEN DO THE FIRST PART OF RECORD KLUGE
	TLNN	SBITS,INDXED		;IF NOT INDEXED TEMP BUT A TEMP
	JRST	NOSPAC			;DON'T DO ANYTHING ABOUT THIS
					;WE WILL PERFORM THE INCREMENT OF
					;THE REF CNT FOR ANY VARIABLE OR
					;INDXED TEMP, WHETHER A SUBFIELD OR NOT
RECKL1:	
NORGC <	
	TLO	A,200			;BIT THAT SAYS TO DO RECORD ACCESS
>;NORGC
	TRNN	FF,SPAC			;KLUGE TO GET AC # GOOD
	TRO	FF,INDX			;IF WE GET ONE, IT BETTER BE INDEXABLE

IFN 0,<
	TLNE	SBITS,INAC		;IF INAC, WE WILL FORGET IT FOR THIS PURPOSE
	PUSHJ	P,[ TLNE SBITS,INDXED	;BIG SURPRIZE IF THIS IS ON
		ERR <DRYROT: INDXED INAC?>,1
;;#SV# RHT MUST PRESERVE D
		PUSH	P,D
		HRR	D,$ACNO(PNT)	;GET OUT OF THE AC & THEN WILL WIN
		PUSHJ	P,CLEARA	;FORGET INACITUDE
		POP	P,D
		JRST	GETAD		;REFURBISH THE BITS & RETURN FROM LITERAL
		]
>;FALSE

;; FALL INTO NOSPAC
>;REC
NOSPAC:	TLNN	SBITS,INAC!PTRAC;IF IN AC, HAVE TO BE SURE IT'S RIGHT
	 JRST	 STCHK			; IF NOT, MUST CHECK
					; FOR STRINGS (HAVE TO LOAD)


Comment ⊗ INAC -- if DBL or INDX or SPAC,
	find out if thing can stay in this AC -- otherwise
	must get another.  ⊗

; FIRST CHECK SPAC GUYS

	TLZ	A,1!2		;ASSUME NOTHING YET
	TRNN	FF,SPAC		;PROVIDED WITH SPECIFIC AC?
	 JRST	 DBCHK		; NO, CHECK DBL WANTED
	HRRZ	TEMP,$ACNO(PNT) ;GET CURRENT AC #
	CAIN	TEMP,(D)	;DID WE LUCK OUT (SAME ONE)?
	 JRST	 SBSCHK		;YES, GO CHECK SPECIAL INDXED THING

				;DCS 8/16/70 IF SPAC AC BEING REPLACED,
				; STORE AND CLEAR WHAT'S IN IT
	SKIPLE	ACKTAB(D)	;PROTECTED OR NOTHING THERE?
	 PUSHJ	 P,STORZ	; NO, GET RID OF IT
				;DCS 8/16/70

	TLO	A,2		;WILL HAVE TO DO A MOVE
	JRST	WPCHK1		;AND MAKE SEMANTICS CHANGES

; IF DBL IS ON, SEE IF NEXT AC IS FREE, SET UP TO MOVE IF NOT

DBCHK:	
	HRR	D,$ACNO(PNT)	;GET CURRENT AC NUMBER
	TRNN	FF,DBL		;WELL
	 JRST	 IDXCHK		;NO DBL REQUESTED

	SKIPGE	ACKTAB+1(D)	;NEXT ONE NOT USABLE?
	 JRST	 WIPCHK		; CANNOT  BE USED, MAKE SEMANTIC CHANGES

	HRRI	D,1(D)		;STORE THE NEXT
	PUSHJ	P,STORZ
	HRRI	D,-1(D)		;RESTORE AC #


IDXCHK:	TRNE	FF,INDX		;NEED INDX?
	TRNE	D,-2		; AND NOT IN ONE ALREADY?
	 JRST	 SBSCHK		;OK, 'TWOULD SEEM


Comment ⊗ If AC # is being changed (INAC and NEEDAC or SPAC and MOVE)
	clear right half of ACKTAB(AC), but first be sure nothing will be
	wiped out  ⊗

WIPCHK:	TLO	A,1!2		;HAVE TO MOVE IT
WPCHK1:	HRRZ	TEMP,$ACNO(PNT)	;IT IS HERE CURRENTLY
	SKIPGE	ACKTAB(TEMP)	;WAS THIS AC PROTECTED?
	 ERR	<DRYROT --AC CLOBBER>,1
	SETZM	ACKTAB(TEMP)	;"STORR" (STORL DONE BEFORE)


Comment ⊗ for STRING INDXED quantities (or non-STRING with ADDR)
	(guaranteed INAC by now) requiring a displacement,
	a "HRROI" FXTWO (or MOVEI)must be done --
	"HRRO" ("MOVE") with ADDR would yield a no-op
⊗

SBSCHK:	TLNN	SBITS,INDXED	;TEST THE CONDITONS
	 JRST	 POSN		; NOT INDEXED
	HRRZ	TEMP,$VAL(PNT)	;≠0 DISPLACEMENT?
	 JUMPE 	 TEMP,POSN	; NO DISPLACEMENT, NO PROBLEM
;; #OR# ! A STRING ITEMVAR IS NOT A STRING
;; #UE# ! NOR IS A STRING ARRAY
	TDNN	TBITS,[XWD SBSCRP,ITMVAR!ITEM]; A STRING ITEM IS NOT A STRING
	TRNN	TBITS,STRING	;INDXED STRING?
	 JRST	 CHKNUM		; NO, CHECK GET!ADDR FOR NUMERIC ARRAY
	TRZ	FF,ADDR		;JUST IN CASE
	TLO	A,2!20		;MOVE, HRROI, NO ADDR
	JRST	POSN

CHKNUM:	TRZE	FF,ADDR		;WANT THE ADDRESS ALL TOGETHER?
	 TLO	 A,100!2	; YES, MOVE, MOVEI
	JRST	POSN


Comment ⊗ for strings, we must do a HRRO with ADDR
	turned ON (except for SBSCRP strings) ⊗

STCHK:	TRNE	FF,SPAC		;STORE AC IF SPAC
	 PUSHJ	 P,STORZ
	TRNE	TBITS,STRING	;STRING, NOT SBSCRP?
;;#VJ# ! JFR 10-17-75 A STRING PROCEDURE IS NOT A STRING, EITHER
	TDNE	TBITS,[XWD SBSCRP,ITEM!ITMVAR!PROCED] ;NOT REALLY A STRING?
	 JRST	 POSN
	TDO	A,[XWD 2!10,ADDR] ;DO A "HRRO" ADDR

; IF (POSIT(A) and NEGAT(SBITS)) or (NEGAT(A) and ¬ NEGAT(SBITS)) MUST 
;    DO SOMETHING ABOUT IT

POSN:	TRNE	FF,POSIT	;FIRST CONDITION
	TLNN	SBITS,NEGAT
	 JRST	 CHNGAT		; UNSATISFIED
	TLZ	SBITS,NEGAT	;NO LONGER NEGAT
	TLO	A,2!4		;DO "MOVN"
	JRST	CHKDX		;GO CHECK INDEXED

CHNGAT:	TRNE	FF,NEGAT	;SECOND CONDITION
	TLNE	SBITS,NEGAT
	 JRST	 CHKDX		; UNSATISFIED
	TLO	SBITS,NEGAT	;NOW NEGAT
	TLO	A,2!4		;DO A "MOVN"

CHKDX:	TLNN	SBITS,INDXED	;IF INDXED, NOT STRING,  NOT ADDR,  BE
	JRST	ADRCK
;; #RE# (1 OF 1) A STRING ITEMVAR ARRAY NOT A STRING ARRAY
;; #UE# ! (2 OF 3) STRING ARRAY INDXED TEMPS EXIST TOO
	TDNE	TBITS,[XWD SBSCRP,ITMVAR!ITEM]
	JRST	CHKDX2
	TRNE	TBITS,STRING
	JRST	ADRCK		;DOES NOT NEED A HRRO, HRROI
CHKDX2:
;; # RE#
;;#TE# DAMNED CODE WAS PUTTING RESULT OF GET ADDR INAC
	TRNN	FF,ADDR
	 TLOA	 A,2		; SURE SOME SORT OF MOVE GETS DONE
	TRO	A,ADDR		;IN CASE OF INDXED THING, OK TO SAY "INAC"
	JRST	GETWD		;(IF WAS STRING, MARKING INAC DOESN'T HURT)
ADRCK:	TRNE	FF,ADDR		;NOW COPY THIS INTO A
;;#TE# ! USED TO BE A TRO A,ADDR
	 TDO	 A,[400,,ADDR]	;LIKE ALL CPA'S.




GETWD:	TRNN	FF,NONSTD	;THE NON-STANDARD TYPE WILL 
				;**ALWAYS** GET AN AC.
	TLNE	A,1		;NEED AC?
	PUSHJ	P,GETAC		; YES, GOT IT
	TLNN	A,2		;NEED TO MOVE?
	JRST	[TLNN SBITS,INAC!PTRAC ;STRIVE TO PUT BITS BACK RIGHT
		  JRST	 TMPRET
		 TLNE SBITS,INDXED
		  JRST	 IDXRET
		 JRST	GETRET]	;BEST AS POSSIBLE THE SAME AS ON ENTRY
	MOVE	TEMP,A		;SAVE BITS SO YOU CAN TEST THEM
	PUSH	P,A		;SAVE LH BITS
	HRLI	A,(<MOVE>)	;ASSUME "MOVE"
	TLNE	TEMP,4		;MOVN?
	HRLI	A,(<MOVN>)	; YES
	TLNN	TEMP,20!10	;HRRO OR HRROI?
	JRST	NOHRRO		;NO
	TRO	A,FXTWO
	HRLI	A,(<HRRO>)
	TLNE	TEMP,20	;ETC.
	HRLI	A,(<HRROI>)
NOHRRO:
	PUSH	P,PNT
	TRNE	TBITS,ITMVAR
	TLNN	TBITS,MPBIND	;IF NOT ?ITEMVAR
	JRST	NOTMPP		;CONTINUE
	TRZ	A,ADDR
;; JRL FOLLOWING WAS MISTAKENLY A HRRI
	HRLI	A,(<MOVEI @>)
	TRNE	TEMP,ADDR	;ADDR REQUESTED
;; JRL FOLLOWING WAS MISTAKENLY A HRRI
	HRLI	A,(<MOVE>)
	JRST	EMTMOV		;EMIT THE MOVE
NOTMPP:	TLNE    TEMP,100	;FOR GET ADDR 
	 HRLI	 A,(<MOVEI>)
	TRO	A,IMMOVE	;IF POSSIBLE

	TRNE	TBITS,ITEM	;OH MY GOSH AROODIES.
	JRST	[TLNN	TBITS,FORMAL!SBSCRP
		MOVE	PNT,$VAL2(PNT)	; IT WILL BE AN INTEGER....
		JRST EMTMOV]
REC <
NORGC <
	TLNN	 TEMP,100		;SPECIFIED IMMEDIATENESS
	TLNN	 TEMP,200		;NO, THEN RECORD KLUGE IS A LIVE OPTION
	JRST	 EMTMOV			;NOT A RECORD KLUGERY INSTANCE
RECKL2:	HRLI	A,(<SKIPE>)		;NEED TO BUMP REF CNT IF NOT NULL
;;BUG TRAP
	TRZE	A,USCOND
	ERR	<DRYROT: USCOND ON AT RECKL2>,1
	PUSHJ	P,EMITER
	HRLOI	A,(<AOS>)		;
	TLO	A,(D)			;PUT AC NUMBER IN PLACE
	TLZ	FF,RELOC		; NOT A RELOCATABLE -1 !
	PUSHJ	P,CODOUT		; AOS -1(AC)

	SKIPA				;SKIP OVER EMITER CALL AT EMTMOV

>;NORGC
>;REC
EMTMOV:	PUSHJ	P,EMITER
	POP	P,PNT		;IN CASE OF ITEM.

	POP	P,A
	TLNE	TBITS,MPBIND
	JRST	[TLO	SBITS,INAC
		 TRNN	A,ADDR	;ADDR?
		 JRST	ALLRET	;NO.
;; #PA#!(1OF 2) SAVE C ON CALL TO GET
		 PUSH	P,C
		 HRLZI	C,20	;INDIRECT BIT
		 EMIT	<TLZN ,USADDR!NORLC>
;; #PA#!(2 OF 2) RESTORE C
		 POP	P,C
		 EMIT	<MOVEI	,0>
		 TLZ	SBITS,INAC
	 	 JRST	TMPRET] ;DON'T REMEMBER ADDR IS IN AC


;;#TE# DONT WANT TO ALWAYS REMEMBER THIS AC IN $ACNO
GETRET:	TLNN	A,400		;WAS IT REGULAR VBL, GET (ADDR)
	TRNE	FF,NONSTD	;SPECIAL CASE OF PRESERVING INDXD TEMPS
	JRST	[MOVE SBITS,$SBITS(PNT) ;RESTORE OLD MARKING.
		 JRST TMPRT1]	;AND FINISH OUT.
	TLZ	SBITS,PTRAC!INDXED!INAC ;START FROM SCRATCH
	TLNN	A,20!40!100	;INAC  MARKING?
	 JRST 	 STDRET		; YES, DO IT

IDXRET:	TLO	SBITS,PTRAC!INDXED;KEEP INDXED BITS
	TLNN	A,20!100	;HRROI (MOVEI) THING?
	 JRST	 ALLRET		; NO
	TLZ	TBITS,OWN
	HLLZS	$VAL(PNT)	; NO DISPL ANYMORE
	JRST	ALLRET

STDRET:	TDNN	TBITS,[XWD SBSCRP,ITEM!ITMVAR] ;NOT REALLY A STRING?
	TRNN	TBITS,STRING	;KEEP BITS OFF IF STRING
	TLO	SBITS,INAC
ALLRET:	HRRM	PNT,ACKTAB(D)	;UPDATE SEMANTICS AND
	HRRM	D,$ACNO(PNT)	; ACKTAB

TMPRET:	MOVEM	SBITS,$SBITS(PNT) ;IF ACCOP, THIS WILL BE NECESSARY
TMPRT1:	TRNN	FF,MRK		;DOES HE WANT A MARK?
	 JRST	 POST		;ALL DONE.
	PUSHJ	P,REMOP		;AFTER ALL THAT?
	JRST	MARK1		;AH, WELL

COMMENT ⊗STACK -- Issue Instrs. to Stack Anything on Approp. Stack⊗

↑↑STACK: TRNE	FF,PREMASK	;ANY TO DO?
	 PUSHJ	 P,PRE
	PUSHJ	P,STACK1
	TRNN	FF,MRK		;HAS HE ASKED FOR A MARK?
	 JRST	 POST		;FINISH OUT.
	JRST	MARK1		;AND DO A MARK.


STACK1: PUSH	P,FF		;SAVE
	TRNN	SBITS,DLFLDM	;DOES HE LIVE IN THE STACK?
	TLNE	SBITS,INDXED
	PUSHJ	P,ACCOP		;GET ACCESS.
	TDNE	TBITS,[XWD SBSCRP,ITEM!ITMVAR]	;ALWAYS STACK ARRAYS ON P-STACK
	 JRST	 ASTACK		; NO MATTER WHAT
	TRNN	FF,ADDR		;MUST BE A CALL BY REF.
	TRNN	TBITS,STRING	;STRING STACK?
	JRST	ASTACK		;NO -- ARITHMETIC
	TLNE	SBITS,STTEMP	;IF STTEMP and INUSE,
				; ALREADY STACKED, DON'T DO AGAIN
	 JRST	 MARTK		;JUST MARK AND QUIT


	MOVEI	D,RSP			;TO AVOID CLOBBERING CORE.
	MOVE	A,[PUSH RSP,STAK!BPWORD!LNWORD!ADOP!REM]
	TRNE	FF,REM		; IF REM BIT IS ON IN FF THEN DON'T REMOP IN 
	TRZ	A,REM		;  STROP1 SINCE POST WILL DO IT
	PUSHJ	P,STROP1		;THIS IS REALLY EASY.  DO TWO PUSHES.
;; FOLLOWING WAS ERRONEOUSLY TO MARTK THUS REMOPING BLOCK TWICE
;; #ML ACTUALLY NEED TO LOAD SBITS AGAIN SHOULD BE MARTJ
	JRST	MARTJ			;AND NOW MARK THINGS.



ASTACK:	TLZN	SBITS,NEGAT	;ARE THINGS CURRENTLY NEGATIVE?
	JRST	OKPO		;NO
	TLNN	SBITS,INAC!PTRAC
	ERR	<DRYROT -- STACK NEGAT IN CORE?>,1
	HRL	C,$ACNO(PNT)
	EMIT	(MOVNS USADDR!NORLC!NOUSAC)
	MOVEM	SBITS,$SBITS(PNT);FOR THE EMITER.
OKPO:	
REC <
NORGC <
	TRNE	TBITS,PNTVAR	;IS IT A PNTVAR (IE RECORD)
	TRNE	TBITS,777777-(PNTVAR!GLOBL) ;
	JRST	OKPO.1		;NO
	TRNE	FF,ADDR		;WANT ADDRESS?
	JRST	OKPO.1		;WON'T WORK ANYHOW
	PUSH	P,FF		;
	GENMOV	(GET,MRK)	;GET IT & MARK IT 
	POP	P,FF
OKPO.1:				;
>;NORGC
>;REC
	
	TLNE	TBITS,MPBIND	;A ?ITEMVAR
	JRST	[TRNE FF,ADDR	;ADDRESS REQUIRED?
		 ERR <DRYROT -STACK ADDR ? ITEMVAR>
		 TLNE SBITS,PTRAC!INAC
		 JRST .+1
		 PUSH P,D
		 PUSHJ	P,GETAC
		 EMIT	<MOVEI @,>
		 PUSHJ	P,MARKINT
		 POP	P,D
		 JRST	.+1]
	HRLZI	A,(<PUSH RP,>)
	TRNE	FF,ADDR		;COPY THIS BIT.
	 TRO	 A,ADDR
	TRO	A,NOUSAC	;WE HAVE SPECIFIED IT.
	PUSHJ	P,EMITER	;PUT OUT THE PUSH.
	AOS	ADEPTH		;SINCE WE USED THE PSTACK
MARTK:	TRNN	FF,REM		;IF REM BIT IS ON THEN DON'T DO REMOP SINCE POST 
				; WILL DO IT
	PUSHJ	P,REMOP		;REMOVE THE THING YOU'RE STACKING
MARTJ:	MOVE	SBITS,$SBITS(PNT);GET ITS BITS BACK FOR THE REST OF THIS
MARTH:	POP	P,FF		;RESTORE
	POPJ	P,

COMMENT ⊗MARK, MARKINT, MARKME -- Mark Semblk with Correct Temp Semantics
 This marks the AC (D) with a temp descriptor of type in SBITS, TBITS⊗

↑↑MARK:	TRNE	FF,PREMASK	;
	PUSHJ	P,[TRNE FF,657777
		   ERR <MARK>,1
		   JRST PRE]
	PUSHJ	P,MARK1
	JRST	POST		;ALL DONE.

MARK1:	ANDI	TBITS,MASK	;WANT ONLY THE TYPE BITS (NOT FORMAL,ETC.)
;;#NK# ! (1 OF 2) TEMPS SHOULD NOT HAVE DISPLAY LEVELS
	TDZ	SBITS,[CORTMP!PTRAC!INDXED!FIXARR,,DLFLDM]
;;#HS# JRL AN ITEMVAR IS NOT ITS DATUM
	TRNE	TBITS,ITMVAR!ITEM
	JRST	.+3
;;#HS#
	TRNE	TBITS,STRING		;IF STRING TYPE, THEN
	 JRST	 STMARK
	TLO	SBITS,INAC!ARTEMP!INUSE	;SINCE HE MAY NOT HAVE SET THEM.
	TLZ	SBITS,STTEMP
	HRRE	LPSA,ACKTAB(D)		;PICK UP TEMP DESCIRIPTOR
	JUMPLE	LPSA,NOTEM		;IF NO TEMP OR REMOPPED TEMP
	MOVE	USER,$SBITS(LPSA)	;GET SEMANTIC BITS
	TLNN	USER,INUSE		;A TEMP?
	 JRST	 REMM			;NO
	TLNN	USER,CORTMP		;A CORE TEMP?
	 JRST	 USOLD			;NO -- USE THE TEMP THAT IS THERE.
	TLNE	USER,INAC		;IS IT STILL IN THE ACCUMULATOR?
	 PUSHJ	 P,STORA		;YES --STORE IT.
	
	SKIPA
REMM:	PUSHJ	P,CLEARL		;DO THE REMOP
NOTEM:	PUSHJ	P,GETTEM		;GET A NEW TEMPORARY
USOLD:	HRRM	LPSA,ACKTAB(D)		;INSERT IN AC TABLE RIGHT HALF
	HRRM	D,$ACNO(LPSA)		;AND THE LOGICAL INVERSE.
REC <
	TRNE	TBITS,PNTVAR		;A RECORD TEMP
	TRNE	TBITS,777777-(PNTVAR!GLOBL) ;
	JRST	MARKT			;NOPE
	SKIPN	TEMP,RCLASS		;BUG TRAP
	ERR	<DRYROT: RCLASS=0 WHEN TRYING TO MARK RECORD TEMP>,1
	HRLM	TEMP,$ACNO(LPSA)	;MARK IT
	SETZM	RCLASS			;
	;FALL INTO MARKT
>;REC
MARKT:	HRRZM	LPSA,PNT		;
	SETZM	$VAL(PNT)
MARTS:	POPJ	P,
STMARK:	TLO	SBITS,STTEMP		;IN CASE IT SKIPS AND NOONE ELSE DID
	TLZ	SBITS,ARTEMP
	HRRZ	LPSA,PNT		;IN CASE STRTMP NOT CALLED
	TLNN	SBITS,INUSE		;ALREADY HAS A TEMP?
	PUSHJ	P,STRTMP		;GET A STRING TEMP.
	JRST	MARKT

DSCR MARKINT, MARKME
DES THESE ARE ROUTINES TO HELP YOU CALL "MARK"
 MARKINT -- ALWAYS MARKS A VANILLA INTEGER, RETURNS DESCR. IN PNT,SBITS,TBITS.
 MARKME	-- YOU SPECIFY TBITS, SBITS=0 IS ASSUMED
⊗;
↑↑MARKINT: MOVEI TBITS,INTEGR		;MARK AN INTEGR,
↑↑MARKME: HRRI	FF,0
	SETZ	SBITS,
	JRST	MARK1

COMMENT ⊗INCOR -- Issue Code to Clear this Entity from ACs⊗

DSCR INCOR
DES makes sure that the entity mentioned in PNT,TBITS,SBITS is really
 in core.  If not, the AC entry for that entity is cleared.
 The updated Semantics bits are returned in SBITS.
⊗;

↑↑INCOR:	
	TLZN	SBITS,INAC!PTRAC	;GONE?
	POPJ	P,		;ALL DONE!
	PUSH	P,D		;SAVE THIS.
	HRRZ	D,$ACNO(PNT)	;PICK UP RELEVANT AC.
	PUSHJ	P,STORZ
	POP	P,D
	JRST	GETAD		;ALAS, SINCE STORZ WILL CHANGE THINGS.

COMMENT ⊗REMOPs, CLEARs -- Remove Temps, ACs, from Use⊗

DSCR REMOP,REMOPA,REMOPL,REMOP2
DES These are the REMOP routines.  They say, in effect, "I am 
 finished with this argument.  If it was a temp descriptor, then I
 am really finished, and the temp may be returned to the pool of
 such temps.  If it was a simple variable or constant, etc. then no
 action is taken.  

PAR The differences among the routines are only in the call form:
 REMOP	-- PNT  has pointer to entity.
 REMOPL	-- LPSA has pointer to entity
 REMOPA	-- D has AC number of entity.
 REMOP2	-- PNT2	has pointer to entity.

SID AC'S USED: LPSA,TEMP,USER
⊗;


↑REMOP2: MOVE	LPSA,PNT2
	JRST	REMOPL
↑REMOPA: SKIPA	LPSA,ACKTAB(D)	;REMOP BY ACCUMULATOR NUMBER
↑REMOP:	MOVE	LPSA,PNT	;OH WELL.
↑REMOPL: TRNN	LPSA,-1
	POPJ	P,		;NONE THERE.
	MOVE	TEMP,$SBITS(LPSA);THE STANDARD REMOP
	TLNN	TEMP,STTEMP!ARTEMP!INUSE ;A REAL TEMP?
	JRST	STCNST		;NO, CHECK IF A STRING CONSTANT
DELAL:	
REC <
NORGC <
	TLNN	TEMP,INDXED
	JRST	DRFDON		;DONT HAVE TO DEREFERENCE IT
	HRRZ	USER,$VAL2(LPSA);WAS THIS GUY A RECORD SUBFIELD
	JUMPE	USER,DRFDON	;IF NOT, THEN NOTHING TO WORRY ABOUT

	SKIPN	USER,%RVARB(LPSA);UNLINK SELF FROM SUBFIELD CHAIN
	ERR	<DRYROT: REMOP OF SUBFIELD NOT ON SUBFIELD CHAIN>,1,SFULKD
	TRNE	USER,-1		;ASS END OF CHAIN ?
	HLLM	USER,%RVARB(USER) ;NO, MAKE THE RIGHT GUY POINT AT MY LEFT
	MOVS	USER,USER	;NOW LINK THE OTHER WAY
	HLRM	USER,%RVARB(USER) ;MY LEFT POINTER NOW POINTS AT MY RIGHT
	SETZM	%RVARB(LPSA)	;TIDY UP
SFULKD:				;UNLINKING DONE NOW

	HLLZS	$VAL2(LPSA)	;MAKE SUBFIELD FLAG ZERO AGAIN
	HLRZ	USER,%TLINK(LPSA); WAS THIS THING HANGING RECD REF
	CAIN	USER,-1		;IF SO,THIS IS -1
	JRST	DREFIT		;IT WAS, MUST DE-REFERENCE THIS ONE

	PUSH	P,USER		;I AM A SUBFIELD OF A FIELD
	PUSHJ	P,DRFDON	;KILL MYSELF OFF
	POP	P,LPSA		;THEN REMOP THE FIELD I HUNG OFF OF
	JRST	REMOPL		;
	
DREFIT:
	SETZM	$VAL(LPSA)	;SO THAT THE DEREF WORKS

	PUSH	P,A		;SAVE SOME ACS
	PUSH	P,C		;
	PUSH	P,PNT		
	PUSH	P,TEMP
	PUSH	P,LPSA
;;#RY# MUST DO RECUUO ON AC, NOT (AC)
	MOVE	TEMP,$SBITS(LPSA)
	MOVEI	C,ARTEMP+INAC+INUSE
	TLNE	TEMP,CORTMP
	TRC	C,INAC+CORTMP
	HRLM	C,$SBITS(LPSA)
;;#RY#
	MOVNI	C,1		;TO DO DEREFERENCING BY 1, SET C TO -1
	MOVE	PNT,LPSA	;THE THING TO DEREFERENCE
	PUSHJ	P,RFCADJ	;ADJUST REFERENCE COUNT
				;**** NOTE: MAY BE SAFER TO PUT THESE
				;     ONTO SOME "HANG LIST" UNTIL STATEMENT LEVEL
				;     THIS IS BETTER, THOUGH, IF NOTHING BAD HAPPENS

	POP	P,LPSA		;RECOVER THESE FROM EARLIER
	POP	P,TEMP
	POP	P,PNT		;
	POP	P,C
	POP	P,A

DRFDON:

;; HERE CAN FALL INTO THE REST OF THE DELALL CODE.  THIS WILL BE OK
;; SO LONG AS (1) DON'T SUFFER THE LOSSAGE I FEAR ABOUT ROUTINES ASSUMING
;; REMOP LEAVES PCNT THE SAME (ONE KLUGE WOULD BE TO SET A FLAG TO ALLOW
;; THE NEXT CALL TO ACCESS TO DO THE "RIGHT" THING, BUT UGH!
;; (2) THE CODE ABOVE ONLY GOBBLES THE SORT OF INDEXED TEMPS I EXPECT IT TO
;; IF NOT, MORE TESTING & MARKING IS REQUIRED
>;NORGC
RGC <
;;#WD# RHT 1-25-76 MAKE SURE THAT DEPENDENT TEMP TO STRING GOES, TOO.
	MOVE	USER,$TBITS(LPSA)	;
	TLNE	TEMP,INDXED		;INDEXED 
	TRNN	USER,STRING		;STRING, TOO
	JRST	RMP.00			;NOPE
	TDNE	USER,[XWD SBSCRP,PROCED!ITEM!ITMVAR] ;EXCEPT FOR THESE
	JRST	RMP.00
	HRRZ	USER,$VAL2(LPSA)	;IS IT SUBFIELD
	JUMPE	USER,RMP.00		;NO
	PUSH	P,LPSA			;SAVE STATE
	PUSH	P,TEMP			;
	HLRZ	LPSA,$ACNO(LPSA)	;HAVE WE A DEPENDENT?
	SKIPE	LPSA
	PUSHJ	P,REMOPL		;YUP, FLUSH HIM, TOO
	POP	P,TEMP
	POP	P,LPSA
	JRST	RMP.1			;STRING SUBFIELD INDXED TEMPS
					;DO NOT HAVE RECORDS AT ALL
RMP.00:
;;#WD# ↑
	TLNN	TEMP,CORTMP		;ONLY CORTMPS ARE SPECIAL
	JRST	RMP.1			;
	TLNN	TEMP,INDXED		;INDXED CORTMP??
	JRST	RMP.0			;NOPE
	HRRZ	USER,$VAL2(LPSA)	;RECORD SUBFIELD??
	JUMPE	USER,RMP.1		;NOPE
	MOVSI	USER,CORTMP!INUSE!ARTEMP;MAKE INTO A RECORD CORTMP
	MOVEM	USER,$SBITS(LPSA)
	MOVEI	USER,PNTVAR
	MOVEM	USER,$TBITS(LPSA)	;LIKE SO
	JRST	RMP.RC			;PUT IT ONTO THE RIGHT RING
	
RMP.0:
	MOVE	USER,$TBITS(LPSA)	;
	TRNE	USER,PNTVAR		;WAS IT A RECORD CORTMP
;;#VQ# ! RECORD ARRAYS ARE ALSO OK
	TDNE	USER,[XWD SBSCRP,ITEM!ITMVAR]	;THESE ARE OK
	JRST	RMP.1			;NOPE
RMP.RC:	
;;%##% BUG TRAP
	HRRZ	USER,RCTEMP		;WAS THIS GUY ALREADY ON THE CHAIN
	JUMPE	USER,RMP.0R		;NO CHAIN
	CAIN	USER,(LPSA)		;WELL?
	ERR	<DRYROT: RECORD CORTMP REMOP>,1
	HRRZ	USER,(USER)		;CHAIN
	JUMPN	USER,.-3
RMP.0R:			;;%??% INSERTED HERE BY JFR 11-16-75
;;%##% ↑
	HRRZ	USER,LPSA		;
	EXCH	USER,RCTEMP		;
	HRRZM	USER,%TLINK(LPSA)	;REMEMBER IT AS AN AVAILABLE 
	JRST	IACCHK			;RECORD TEMP
					;(NOTICE THAT INUSE WAS LEFT ON)
RMP.1:
>;RGC
>;REC
	MOVSI	USER,INUSE!STTEMP!INAC!PTRAC!NEGAT!FIXARR ;TURN THESE OFF
	ANDCAM	USER,$SBITS(LPSA) ;IN MEMORY.
IACCHK:	HRRZ	USER,$ACNO(LPSA) ;GET THE AC IT WAS IN
	TLNN	TEMP,INAC!PTRAC	;WAS IT IN AN AC?
	 JRST	 CTCHK		;NO -- ALL DONE.
	SKIPGE	ACKTAB(USER)	;YES --TURN IT OFF.
	ERR	<DRYROT -- REMOP>,1
	SETZM	ACKTAB(USER)
CTCHK:	TLNE	TEMP,INUSE	;If this was still an alive temp, and
	TLNE	TEMP,CORTMP	; was not a CORTMP, thus contains no fixups
	POPJ	P,		; or anything, we can release it to free
	PUSH	P,LPSA		; storage.  Otherwise, leave it on the TTEMP
	PUSHJ	P,BLKFRE	; list (where it MUST be), and forget it.
	POPJ	P,


STCNST:	MOVE	TEMP,$TBITS(LPSA) ;
	TLNE	TEMP,CNST	;
	TRNN	TEMP,STRING	;
	POPJ	P,		; RETURN IF NOT A STRING CONSTANT 
	MOVE	TEMP,$PNAME(LPSA) ; CHECK IF TRYING TO REMOP NULL STRING WHICH IS 
	TRNN	TEMP,-1		;  ONLY STRINS'ED ONCE 
	POPJ	P,		; YES, DON'T REMOP
	SOSLE	TEMP,$VAL2(LPSA) ; DECREMENT REFERENCE COUNT AND GET OUT IF NOT 
	POPJ	P,		;  ZERO
	JUMPE	TEMP,.+2	; ZERO COUNT? 
	ERR	<DRYROT REMOP:STCNST> ; 
	SKIPN	$VAL(LPSA)	; USED IN PRELOAD? 
	SKIPE	$ADR(LPSA)	; USED IN FIXUP? 
	POPJ	P,		; YES, RETURN 
	PUSHJ	P,URGCST	; REMOVE FROM STRING CONSTANT RING 
	PUSHJ	P,URGSTR	; REMOVE FROM STRING RING 
	PUSH	P,PNAME		; SAVE PNAME AND PNAME+1 (OK ON P STACK SINCE NO 
	PUSH	P,PNAME+1	;  GARBAGE COLLECTION CAN HAPPEN) 
	HRROI	TEMP,$PNAME+1(LPSA) ; GET STRING DESCRIPTOR FOR HASH LOOKUP SO THE 
	POP	TEMP,PNAME+1	;  STRING CAN BE REMOVED FROM THE HASHED SYMBOL 
	POP	TEMP,PNAME	;  TABLE 
	PUSH	P,TBITS		; SAVE AC'S WHICH SHASH WILL DESTROY 
	PUSH	P,A		; 
	PUSH	P,B		;
	PUSH	P,C		;
	PUSH	P,D		;
	PUSH	P,PNT		;
	PUSH	P,LPSA		; 
	MOVE	LPSA,STRCON	; USE STRING HASH TABLE 
	PUSHJ	P,SHASH		; 
	MOVE	B,HPNT		; INSTRUCTION TO LOAD FIRST IN CONFLICT LIST 
	XCT	B		; FIRST IN CONFLICT LIST INTO LPSA 
	HRRZ	PNT,(P)		; THE ONE WE ARE LOOKING FOR 
	MOVEI	A,LPSA		;
SCOMLP:	HRRZ	TEMP,(A)	; CANDIDATE? 
	JUMPE	TEMP,ERRSTC	; NOT THERE - ERROR 
	CAMN	TEMP,PNT	;
	JRST	SFNDIT		; 
	MOVE	A,TEMP		; CHAIN DOWN CONFLICT LIST 
	JRST	SCOMLP		; 
SFNDIT:	HRRZ	TEMP,(TEMP)	; NEXT IN LIST 
	HRRM	TEMP,(A)	; CHAIN AROUND DELETED ELEMENT 
	TLO	B,2000		; CHANGE FROM LOAD TO STORE 
	XCT	B		; 
	FREBLK	(PNT)		; 
	POP	P,LPSA		; RESTORE AC'S 
	POP	P,PNT		; 
	POP	P,D		; 
	POP	P,C		; 
	POP	P,B		; 
	POP	P,A		; 
	POP	P,TBITS		; 
	POP	P,PNAME+1	; 
	POP	P,PNAME		; 
	POPJ	P,		;
ERRSTC:	ERR	<DRYROT AT REMOP>,1 ;

DSCR CLEAR,CLEARL,CLEARA
DES These are routines to clear an entry in the AC table (ACKTAB)
 That is, all memory of what is in the AC is lost.  The difference
 among the routines is the call form:

PAR CLEAR -- PNT has pointer to entity to be "cleared"
 If it turns out not to be in an AC, no action is taken.
 CLEARL -- LPSA has pointer; same deal.
 CLEARA  -- D has AC number to be cleared.

SID AC'S USED: LPSA,TEMP
⊗;

↑CLEAR:	MOVEI	LPSA,(PNT)	;CLEAR OUT AN AC TABLE ENTRY.
↑CLEARL: MOVE	TEMP,$SBITS(LPSA) ;SEE IF IT IS IN AN AC.
	TLNN	TEMP,INAC!PTRAC  ;IF NOT -- ALL DONE.
	 POPJ	 P,		;DONE.
	MOVE	TEMP,$ACNO(LPSA) ;AC IT IS IN.
	SETZM	ACKTAB(TEMP)	;AND ZERO THE ENTRY.
	JRST	CLR1		;FINISH OUT.
↑CLEARA: MOVEI	LPSA,0		;
	EXCH	LPSA,ACKTAB(D)	;ZERO AC TABLE ENTRY.
CLR1:	MOVSI	TEMP,INAC!PTRAC!NEGAT
	TRNE	LPSA,-1	;ANYTHING THERE? (DCS -- 8/16/70)
	ANDCAM	TEMP,$SBITS(LPSA) ;TURN THESE OFF IN MEMORY.
	POPJ	P,

COMMENT ⊗STROP -- Bit-Driven String Operation Code Generator⊗

DSCR STROP
DES This routine is willing to do lots of twiddling on strings.
 It knows about reference strings, etc. 
PAR A is an instruction for the EMITTER, with some bits in
 it to say what things should be done with this instruction.  
Bits in A: 	bpword		-- issue the instruction for
				 the byte pointer word.
		lnword		-- or for the length word.
		bpfirst		-- issue the byte pointer inst. first.
		adop		-- this is an instruction which adds to stack.
		sbop		-- this is an instruction which subs from stack.
		undo		-- so a SUB SP,X22 at end.
		rem		-- do a remop when done.

		stak		-- used internally.
		bpinc		-- byte pointer instruction is in c(rh)

 PNT,TBITS,SBITS -- semantics of string.

 D -- accumulator to use for ac field of op.
  Thus, it must be RSP if that stack is to be used.
⊗;


↑STROP:	CAIN	D,RSP		;IF THE STACK,
	TRO	A,STAK		;THEN MARK AS SUCH.
	DPB	D,[POINT 4,A,12] ;SAVE IN AC FIELD OF INSTRUCTION.
	PUSHJ	P,ACCOP		;AND GET ACCESS TO THE ROUTINE.
				;THIS UPDATES SBITS IN CORE.
STROP1:	PUSH	P,ACKTAB(D)	;PROTECT.
	SETOM	ACKTAB(D)
	PUSH	P,D		;SAVE AC.
	TLNN	TBITS,REFRNC	;THE HARD CASE.
	JRST	OPPP1		;
	PUSH	P,A		;SINCE GETOPE DOES NOT PRESEVE.
	HRRI	FF,ADDR!INDX
	PUSHJ	P,GETOPE	;GET THE ADDRESS OF THE BP WORD IN AN AC.
				;THIS UPDATES SBITS IN CORE.
	SETZM	ACKTAB(D)	;WE DO NOT WANT TO SEE THIS AGAIN.
	HRLZS	D		;READY FOR INDEXING.
	POP	P,A
OPPP1:	TLNE	SBITS,STTEMP	;IF STACKED, THEN NEED
	 HRLI	 D,RSP		;THE STACK
	HRRI	FF,(A)		;SAVE BITS.
	TRNE	FF,BPFIRST	;IF BYTE POINTER WORD FIRST, DO IT
	 PUSHJ	 P,BP
	PUSHJ	P,LN		;NOW THE LENGTH
	TRNN	FF,BPFIRST
	 PUSHJ	 P,BP
	
	TRNE	FF,UNDO
	TLNN	SBITS,STTEMP	;IF UNDO AND A STACKED STRING.
	JRST	OP2		;
	PUSHJ	P,SUBIT
OP2:	POP	P,D		;RESTORE.
	POP	P,ACKTAB(D)
	TRNE	FF,REM		;IF REMOP ASKED FOR.
	 JRST	 REMOP
	POPJ	P,		;ALL DONE.


DSCR SUBIT
DES Emits a SUB SP,[XWD 2,2], and subtracts two from SDEPTH.
⊗;
↑SUBIT:
;;%DN% JFR 7-2-76
;;	PUSH	P,A
	MOVNI	A,2
	ADDM	A,SDEPTH
	HRLI	C,-2
	JRST	ESPADJ
;;	MOVE	A,X22		;SUBTRACT TWO FROM THE STACK.
;;	PUSH	P,PNT
;;	PUSHJ	P,CREINT
;;	EMIT	(<SUB RSP,NOUSAC>) ;THEN ISSUE THE SUBS.
;;	PUSHJ	P,REMOP		;JUST IN CASE
;;	POP	P,PNT
;;	MOVNI	A,2
;;	ADDM	A,SDEPTH	;UPDATE COUNT.
;;	POP	P,A
;;	JRST	GETAD		;RESTORE TBITS,SBITS.
;;%DN% ↑

BP:	TRNN	FF,BPWORD	;ONLY IF ASKED FOR.
	 POPJ	 P,
	PUSH	P,A		;SAVE
	TRNE	FF,BPINC	;IF ANOTHER INSTRUCTION AROUND.
	 DPB	 C,[POINT 9,A,8] ;IN INSTRUCTION PARTS.
	HRRI	A,NOUSAC!FXTWO	;TENTATIVE BITS TO EMITER.
	TLNN	SBITS,STTEMP	;IF ON STACK OR
	TLNE	TBITS,REFRNC	;BUT IF THIS CASE, THEN
	TRC	A,FXTWO!NORLC!USX!USADDR
	HRLI	C,0		;WITH NO DISCPLACEMENT.
	PUSHJ	P,EMITER
	POP	P,A
	JRST	FINBP

LN:	TRNN	FF,LNWORD	;ONLY IF ASKED
	 POPJ	 P,
	HRRI	A,NOUSAC
	TLNN	SBITS,STTEMP	;IF TEMP OR
	TLNE	TBITS,REFRNC	;REFERENCE, THEN MUST USE
	TRO	A,NORLC!USX!USADDR ;INDEXING ETC.
	HRLI	C,-1		;ANO THIS TIME A DISPLACEMENT.
	PUSHJ	P,EMITER

FINBP:	TRNE	FF,ADOP!SBOP	;PREPARE TO ADJUST STACK.
	TRNN	FF,STAK		;ONLY IF ON STACK.
	 POPJ	 P,		;NONE.
	TRNE	FF,ADOP
	AOSA	SDEPTH
	SOS	SDEPTH		;OUR BOOKKEEPING DONE,
	POPJ	P,		;WE DEPART.


;;%DN% JFR 7-4-76
DSCR	EADJSP, EPADJ, ESPADJ
DES	Emits instruction to alter stack depth
PAR	LH(C)	proper constant for ADJSP
	RH(D)	stack ac for EADJSP.
RES	ADJSP emitted if allowed, else proper ADD or SUB
SID	A, TEMP clobbered. PNT,TBITS,SBITS saved
⊗;

↑EADJSP:MOVEI	TEMP,(D)	;AC
	CAIE	TEMP,RP		;FIGURE OUT WHICH STACK
↑ESPADJ:SKIPA	A,[ADJSP RSP,NOUSAC!USADDR!NORLC]
↑EPADJ:	MOVE	A,[ADJSP RP,NOUSAC!USADDR!NORLC]
	MOVE	TEMP,ASWITCH
	TRNE	TEMP,AADJSP
	 JRST	EMITER		;EASY WAY
	PUSH	P,PNT		;SAVE THIS GUY
	PUSH	P,TBITS
	PUSH	P,SBITS
	JUMPL	C,.+2		;FIGURE OUT ADD OR SUB
	TLCA	A,(<ADJSP>≠<ADD>)
	TLC	A,(<ADJSP>≠<SUB>)
	TRZ	A,USADDR!NORLC
	PUSH	P,A		;SAVE INSTR FOR LATER
	HLRE	A,C		;COMPUTE CONSTANT
	MOVM	A,A
	HRLI	A,(A)
	PUSHJ	P,CREINT	;MAKE AN XWD
	POP	P,A		;GET INSTR BACK
	PUSHJ	P,EMITER	;PUT OUT INSTR, PNT POINTS TO XWD
	POP	P,SBITS
	POP	P,TBITS
	POP	P,PNT		;GET IT BACK
	POPJ	P,
;;%DN% ↑
COMMENT ⊗GETTEM, etc. -- Temp Semblk Allocators⊗

DSCR GETTEM,GETCRTMP,STRTMP
DES Routines for getting temp descriptor Semblks. The list of
 free temps is searched for an appropriately free one.  If found,
 a masked form of TBITS, and a masked form of SBITS are stored
 in the Semblk for this temp. A pointer to it is returned in LPSA
INCL more descriptions about temps, their numbers, how they're
 moved, kept track of, deleted, depend on procedures, etc.

 GETTEM -- get a non-core temp
 STRTMP -- get a String temp (i.e. turn on the STTEMP bit in SBITS)
 GETCRTMP -- get a core temp.

SID AC'S USED: USER,LPSA,TEMP
⊗;

STRTMP:	TLOA	SBITS,INUSE!STTEMP
↑GETTEM: TLO	SBITS,INUSE!ARTEMP	;TURN ON TEMP BITS.
;;#NK# ! (2 OF 2) TEMPS SHOULD NOT HAVE DISPLAYS LEVELS
	TDZ	SBITS,[CORTMP,,DLFLDM]
	GETBLK				;GET A NEW BLOCK
GTT1:	MOVEM	SBITS,$SBITS(LPSA)
	ANDI	TBITS,MASK
	MOVEM	TBITS,$TBITS(LPSA)	;GOOD BITS IN MEMORY
	POPJ	P,			;NOTHING ELSE TO DO

↑GETCRTMP:				;GET A CORE TEMP
	SKIPA	LPSA,TTEMP
STRG:	LEFT	,%RVARB,NOFF
	MOVE	TEMP,$SBITS(LPSA)
	TLNE	SBITS,CORTMP
	TLOE	TEMP,INUSE
	JRST	STRG
DDRET:	MOVSI	SBITS,INUSE!CORTMP!ARTEMP
	JRST	GTT1			;FINISH OUT AS ABOVE.

NOFF:	PUSHJ	P,GETTEM
	AOS	TEMP,TEMPNO		;INCREMENT TEMP ID NO
	MOVEM	TEMP,$PNAME(LPSA)	;STORE IN $PNAME FOR ADCON AND SCOUT
	SETZM	$ADR(LPSA)	;AND ZERO THE FIXUP.......
	PUSHJ	P,RNGTMP
	JRST	DDRET

RGC <
↑GETRCT:SKIPE	SIMPSW		;SIMPLE PROCEDURE??
	ERR	<ATTEMPT TO CREATE A RECORD TEMP INSIDE A SIMPLE PROCEDURE>,1
	HRRZ	LPSA,RCTEMP	;GET NEXT OFF RECORD TEMP CHAIN
	JUMPE	LPSA,GRCT.1	;NONE THERE
	HRRZ	TEMP,%TLINK(LPSA);
	MOVEM	TEMP,RCTEMP
	POPJ	P,
GRCT.1:	GETBLK
	PUSHJ	P,RNGTMP
	AOS	TEMP,TEMPNO
	MOVEM	TEMP,$PNAME(LPSA)
	MOVSI	TEMP,ARTEMP!INUSE!CORTMP
	MOVEM	TEMP,$SBITS(LPSA)
	MOVEI	TEMP,PNTVAR
	MOVEM	TEMP,$TBITS(LPSA)
	POPJ	P,
>;RGC


COMMENT ⊗GETAC, GETAN0 -- AC Allocators⊗

DSCR GETAC,GETAN0
DES These are the "get a free AC routines".
PAR FF(rh) -- two modifier bits:
 DBL	-- get a double AC (i.e. next one free too)
 INDX	-- get an indexable AC (not 0 or 1 -- 1 is avoided since
   Procedures tend to return values in 1).
RES in D is returned the free (first free) AC number
 Note that no ACKTAB marking has been done yet, so the AC
 need not be used.

 GETAN0: same as GETAC, but INDX is autimatically turned on.

AC'S USED: TEMP,LPSA
⊗;

↑GETAN0: TRO	FF,INDX			;HERE IF YOU DON'T WANT TO SET THE BIT
↑GETAC:	
	HRR	D,ACKPNT		;LAST AC USED
	SETOM	ACKPNT			;CLEAR IT
	SETZM	POSSIB			;MASK OF POSSIBILITIES
	MOVNI	TEMP,20			;NUMBER OF AC'S TO SEARCH

;;#HF# 5-13-72 DCS RETURN OLDEST AVAILABLE AC IF NONE FREE, FIX DBL
GET1:	AOJG	TEMP,GET7		;For each AC, starting with the one
	ADDI	D,1			; after the last allocated, and wrapping
	TRZ	D,777760		; around to 0 (2 if GETAN0), if the AC
	TRNE	FF,INDX			; is not protected (ACKTAB(AC)<0),
	TRNE	D,-2			; record the (oldest) first one seen in
	SKIPGE	LPSA,ACKTAB(D)		; ACKPNT -- if the entry is free (0),
	JRST	GET1			; try to terminate. Otherwise, continue
	SKIPGE	ACKPNT			; looking for a free one.
	HRRZM	D,ACKPNT
	TRNN	LPSA,-1
	JRST	GET4
	JRST	GET1

; ONE FREE ONE EXISTS -- JUST RECORD IF DBL (NEED TWO)

GET4:	TRNN	FF,DBL			;If only one AC is needed, it's number
	JRST	DSTORZ			; is in D.

GET3:	MOVEI	LPSA,1			;Otherwise, record its number in the
	LSH	LPSA,(D)		; bit array POSSIB.  This is not the
	IORM	LPSA,POSSIB		; most efficient method, but it allows
	JRST	GET1			; the fun below.

; LIST EXHAUSTED -- TAKE WHAT WE COULD GET

GET7:	TRNE	FF,DBL			;If two were needed, we must work
	JRST	GET9			; harder.

; TAKE A DISPLAY TEMP FIRST

	SKIPE	DISLST			;ONLY ANY GOOD IF HAVE SOME
	SKIPG	LPSA,CDLEV		;CURRENT DISPLAY LEV
	JRST	GET7.1
	HRRI	D,1			; COULD NEVER BE ZERO OR 1
GET7.2:	SKIPE	DISTAB(D)
	JRST	GET7.3			;THIS THING HAS AN AC
	AOS     D			;TRY THE NEXT ONE UP
	SOJG	LPSA,GET7.2
	ERR	<DRYROT AT GETAC>	;YOU REALLY BLEW IT, SAM
GET7.3: MOVE	LPSA,DISTAB(D)		;PICK IT UP
	TLNE	LPSA,-1			;USE STRING DISPLY IF WE CAN
	MOVSS	LPSA			;US STRING -HURRAH
	CAIN	LPSA,RF			;
	JRST	GET7.1			;IF RF, THEN NO GO
	HRR	D,LPSA			;WE CAN GRAB THIS ONE
	SKIPG   ACKTAB(D)
	ERR	<GETAC GRABBED SAFE AC -- DRYROT AND WORMS>
	JRST	DSTORZ			;RECORD IT, CLEAR IT OUT
GET7.1:

; NO DISPLAY TEMP, CLEAR SOMETHING ELSE OUT AND USE IT.

	HRR	D,ACKPNT		;Use the first one recorded, which
	JRST	STORZ			; is also the oldest found

; WE NEED TWO -- TRY FOR TWO UNUSED IN A ROW

GET9:	MOVE	LPSA,POSSIB		;If any two in a row were free,
	LSH	LPSA,1			; the AND of the bits and 2*bits
	AND	LPSA,POSSIB		; will yield a bit for each pair.
	JUMPE	LPSA,G10		;No bits implies no pairs.
	FSC	LPSA,231		;The FSC shifts the first match
	LDB	LPSA,[POINT 4,LPSA,8]	; to a normalized position, and 
	MOVEM	LPSA,ACKPNT		; records its index in the exponent
	HRR	D,LPSA			; field.
	POPJ	P,


G10:	HRRI	D,21			;As a last resort, take the first
G11:	SUBI	D,2			; two unprotected ACs available.
	TRNE	D,777000		;If none are found, complain bitterly.
	 ERR <DRYROT AT DBL GETAC>	;This could be improved by
	SKIPL	LPSA,ACKTAB(D)		; looking for the oldest pair, and/or
	SKIPGE	ACKTAB-1(D)		; a pair with one free AC, but at
	 JRST	 G11			; this point, we're sort of beyond
	JUMPE	LPSA,.+2		; caring.
	PUSHJ	P,STORZ			;Store the second, if it needs it.
	SUBI	D,1			;This is the result.

DSTORZ:	HRRZM	D,ACKPNT		;Allocating this one.  Now go make
	JRST	STORZ			; sure it's ready for new action.
;;#HF#

COMMENT ⊗AC Store routines -- BOLSTO, FORSTO, STORIX, GOSTO, STORZ⊗

DSCR BOLSTO
DES Special Boolean store. It does not remove from ACs any
 of the arguments to the Boolean compare.
PAR PNT and PNT2 must point to Semantics of the two arguments.
RES All other ACs are stored.  The Semantics of the parameters
 are not necessarily guaranteed over the call, since either
 may have been marked for storing.  
SEE STORZ, which it calls for each AC cleared
⊗;


↑BOLSTO: PUSH	P,[PUSHJ	P,[
		HRRZ	TEMP,LPSA
		CAIE	TEMP,(PNT2)
		CAIN	TEMP,(PNT)
		POPJ	P,
		JRST	STORZ]]	 ;DO TURN OFF ACSAME FOR THESE GUYS.
; THIS STORZ IS NEEDED BECAUSE A PARTICULAR BOOLEAN MAY LOOK LIKE:
;	MOVE 4,I
;	SKIPN	J
;	JRST	FOO1
;	MOVE	4,J+K
;	SKIPE	GH
;	JRST	SHIT
;FOO1:	.....  HERE THE COMPILER THINKS J+K IS IN 4, WHERE I MIGHT BE!!!
;

	JRST	GG0

DSCR FORSTO
DES Special AC dumper for FOR Loops. This protects the index
 AC from being cleared. Other variables are not cleared, just
 stored if temps.
PAR PNT and PNT2 should point to anything to be preserved
 over this operation (e.g. FOR I← <EXP> STEP .... want to preserve
 I and the Semantics of <EXP> from storing before the test.
SEE STORA, which it calls for each AC stored.
⊗;

↑FORSTO: PUSH	P,[PUSHJ P,[HRRZ TEMP,ACKTAB(D)	;FOR FOR LOOPS.
		   CAIE	TEMP,(PNT)
		   CAIN	TEMP,(PNT2)
		   POPJ	P,
				;DCS -- 8/16/70
		   PUSHJ P,STORA	;STORE IT FOR SURE
		   JUMPE LPSA,NSBSC	;NOTHING TO CLEAR
;;#MU# RHT 6-25-73 I THINK THE FOLLOWING DISTINCTION IS POINTLESS
;		   MOVE  TEMP,$TBITS(LPSA) ;IF AN INAC ARRAY,
;		   TLNE  TEMP,SBSCRP	;CLEAR IT, BECAUSE WILL
;;#MU#
		    JRST  CLEARL	;STILL BE ASSUMED INAC AT
	   NSBSC:   POPJ	 P,	; LOOP TOP OTHERWISE
		  ]]			;DCS -- 8/16/70

	JRST	GG0


DSCR STORIX
DES "Store" all INTERNALs and EXTERNALs, i.e. forget that
 they are in ACs.
⊗;
↑STORIX: PUSH	P, [PUSHJ P,[
		HRRZ	LPSA,ACKTAB(D)
		JUMPE	LPSA,CPOPJ		;NOTHING THERE.
		MOVE	LPSA,$TBITS(LPSA)
		TLNE	LPSA,INTRNL!EXTRNL
		JRST	CLEARA
		POPJ	P,]]
	JRST	GG0


DSCR ALLSTO
DES Dump all ACs in the most permanent of ways. Do not
 retain any marking of the AC's at all.

SEE STORZ, which it calls for each AC gronked.
⊗;

↑ALLSTO:OPTSYM	%ALSTO
	PUSH	P,[PUSHJ P,STORZ]	;TO CLEAR  INAC" BITS.
	SKIPA

DSCR GOSTO
DES Store any AC's marked with temps (as opposed to variables).
 Leave the AC markings as they are.
⊗;

↑GOSTO:	PUSH	P,[PUSHJ P,STORA]
GG0:	PUSH	P,D
	MOVEI	D,20			;D, WHO WILL HAVE A COUNT
G1:	SOJL	D,ALLD			;COUNT DOWN
	SKIPG	LPSA,ACKTAB(D)		;DO WE HAVE A STORE TO DO?
	JRST	G1			;NO -- GO AHEAD
	XCT	-1(P)			;EXECUTE STORING ROUTINE.
	JRST	G1

ALLD:	POP	P,D
	POP	P,(P)			;THROW AWAY
	POPJ	P,			;AND RETURN


DSCR STORZ
DES "Store" this AC and wipe out the ACKTAB entry -- clear
 INAC-type SBITS in the Semantics which were there.
PAR AC # in D
SEE STORA,CLEARA routines, which it calls
⊗;

↑STORZ:	PUSHJ	P,STORA
	JRST	CLEARA

COMMENT ⊗ STORA -- main AC-storing subr. -- called by above⊗

DSCR STORA
DES Stores temp results that are in a specified AC into
  a core temp. If a temp exists in that AC, an appropriate core
  temp is found, and the Stoe is EMITted.
 Then the SBITS word in the Semantics is updated to
  reflect the "In Core" status (e.g. CORTMP bit, fixup
  chain addr, etc.) The fixup chain may have originated
  in another temp entry, but was moved here to avoid searching
  up the Semantic stack for all who refer to this temp and
  changing the addresses of the entry they point to. WHAT????

PAR D contains AC # affected.
SID LPSA, TEMP used
⊗;

↑STORA:	SKIPG	LPSA,ACKTAB(D)
	POPJ	P,		;NOTHING THERE.
	PUSH	P,SBITS
	PUSH	P,TBITS		;SAVE YET ANOTHER AC
	MOVE	SBITS,$SBITS(LPSA);GET SEMANTIC BITS.
	TLNN	SBITS,INAC!PTRAC ;IF NOT IN AC, THEN TROUBLE
	ERR	<STORA A THING NOT IN AC>,1
;; #KQ BY JRL (11-30-72) IGNORE FIXARS
	TLNN	SBITS,FIXARR		;A FIXARR SHOULDN'T GET STORED
	TLNN	SBITS,ARTEMP!DISTMP	;OTHERWISE A NOOP
	 JRST	 ZER
	PUSH	P,PNT
	PUSH	P,A
	MOVEI	PNT,(LPSA)

;BUG TRAP
	HRRZ	TEMP,$ACNO(PNT)		;THIS IS THE AC IT THINKS ITS IN.
	CAIE	TEMP,(D)		;THE SAME
	ERR	<STORA>,1

	TLNE	SBITS,DISTMP		;DISPLAY????
	JRST	ZERDR			;YES

	TLNE	SBITS,CORTMP		;CAN WE PUT IT WHERE WE PUT IT BEFORE?
	 JRST	 DEP			; YES (USUALLY ONLY HAPPENS WHEN SOME
					; BUG PROVOKES IT --LIKE MISSING REMOP)
RGC <
	TLNN	SBITS,INDXED		;IF NOT INDXED TEMP
	JRST	RCTCHK			;GO CHECK IF RECORD TEMP
	HRRZ	TEMP,$VAL2(PNT)		;A SUBFIELD INDXED TEMP??
	JUMPE	TEMP,NRML		;NO, JUST TREAT NORMALLY
;;#WX# ! JFR 6-5-76 FORGOT TO FETCH TBITS
	MOVE	TBITS,$TBITS(PNT)
;;#WD# STRING SUBFIELD INDXED TEMPS ARE SPECIAL 
	TDNN	TBITS,[XWD SBSCRP,PROCED!ITEM!ITMVAR]
;;#WW# ! JFR 6-1-76 used to be TRNE (typo)
	TRNN	TBITS,STRING
	JRST	RCTMAK			;YES, DO THE OTHER SORT OF MOVEM
	JRST	NRML			;HERE IF STR SUBF INDX TEMP
;;#WD# ↑
RCTCHK:	MOVE	TBITS,$TBITS(PNT)
	TRNN	TBITS,ITEM!ITMVAR	;THESE ARE ALWAYS NORMAL
	TRNN	TBITS,PNTVAR		;A RECORD TEMP
	JRST	NRML			;NOPE NORMAL
RCTMAK:	PUSHJ	P,GETRCT		;GET A PNTVAR CORTMP
	JRST	TMPCPY			;GO COPY FIXUPS,ETC
NRML:
>;RGC

	SKIPA	LPSA,TTEMP		;PREPARE TO SEARCH TEMP LIST
TEML:	LEFT	,%RVARB,NOFND		;GO DOWN TEMP LIST
		MOVE	TEMP,$SBITS(LPSA)
		TLZE	TEMP,INUSE	;NEED ONE NOT IN USE
		JRST	TEML
		TLZN	TEMP,CORTMP	;AND IN CORE
		JRST	TEML		;REALLY AN ERROR
TMPCPY: MOVE    TEMP,$ADR(LPSA)
        MOVEM   TEMP,$ADR(PNT)          ; HO HO.
        MOVE    TEMP,$PNAME(LPSA)       ;ID NUMBER OF THIS CORTMP
        MOVEM   TEMP,$PNAME(PNT)        ;SO ADRINS AND SCOUT DON'T GET CONFUSED
        PUSHJ   P,URGTMP                ;REMOVE FROM RING
        FREBLK  ()                      ;THE OLD ONE
	JRST	DEP1

NOFND:	SETZM	$ADR(PNT)		;WITH ZERO FIXUP
;; #JRL ALWAYS GIVE CORTMPS ID NO.
	AOS	TEMP,TEMPNO		;CORTMP ID
	MOVEM	TEMP,$PNAME(PNT)
;; #JRL
DEP1:	MOVE	LPSA,PNT
	PUSHJ	P,RNGTMP		;PUT ON RING
DEP:	MOVSI	SBITS,CORTMP!INUSE!ARTEMP
	IORB	SBITS,$SBITS(PNT)	;INDICATE THE NEW STATUS
TURNOF:	MOVSI	LPSA,INAC!PTRAC!NEGAT	;TEMP NO LONGER IN AC
	ANDCAM	LPSA,$SBITS(PNT)
	HRRM	D,$ACNO(PNT)		;RECORD THE AC NUMBER
	HRLZI	A,(<MOVEM>)
	TLNE	SBITS,INDXED		;A CALCULATED SUBSCRIPT?
	TRO	A,ADDR			;YES -- DO NOT STORE INDIRECT.
	TLNE	SBITS,NEGAT		;IS THE AC AROUND NEGATIVELY?
	HRLI	A,(<MOVNM>)		;YES
;; #MD# ONLY STORE RIGHT HALF OF PTRAC
	TLNE	SBITS,PTRAC
	HRLI	A,(<HRRZM>)		;ONLY RIGHT HALF, IN CASE LATER AN
					;INDIRECT MOVE IS DONE
	PUSHJ	P,EMITER
					;NOTE THOUGH THAT NEGAT MAY STILL
					;BE ON.  THIS MAY BE DANGEROUS.
	MOVEM	SBITS,$SBITS(PNT)
ZRET:	POP	P,A
	POP	P,PNT

ZER:	
	POP	P,TBITS
	POP	P,SBITS
	POPJ	P,			;RETURN
ZERDR:	MOVE	A,$VAL(PNT)		;ZEROING MASK
	HRR	LPSA,$ADR(PNT)		;PICK UP DISPLAY LEVEL
	ANDM	A,DISTAB(LPSA)		;ZERO APPROPRIATE SIDE OF DISTAB WORD
	HLLZS	ACKTAB(D)		;ZONK THE ACKTAB ENTRY
	MOVE	LPSA,PNT
	PUSHJ	P,URGDIS		;UNLINK FROM DISPLAY VARB RING
	FREBLK  (PNT)
	JRST	ZRET
SUBTTL	CODE EMITTER

COMMENT ⊗EMITER -- Descriptions of Routine and Control Bits⊗

DSCR EMITER -- code emitting routine.

DES From input parameters and symbol table information,
  generate a word of real live code.

PAR 
A --	OPCODE in LH, bits in RH:  
	NOUSAC←←400000	;DON'T USE D(RH) AS AC #
	USCOND←←200000	;USE C(RH) AS 3 BITS OF CONDITION
	USADDR←←100000	;USE C(LH) AS DISPLACEMENT PART
	USX   ←← 40000	;USE D(LH) AS INDEX REG
	NORLC ←← 20000	;RELOCATE NOT!
	IMMOVE←← 10000	;IF OPERAND CONSTANT, LOAD IT ANY WAY POSSIBLE
	INDRCT←←  4000	;INDIRECT ADDRESSING REQUIRED
	JSFIX ←←  2000	;JUST DO A FIXUP (DON'T GET SEMANTICS).
	NOADDR←←  1000	;NO EFFECTIVE ADDRESS PART
	ADDR ←←    400	;WE WANT THE ADDRESS OF THIS ENTITY
	FXTWO←←   100	;USE SECOND FIXUP WORD

C --   DISPLACEMENT (if provided) in LH, condition bits in RH
D --   Index number in LH, AC number in RH (both optional)
PNT --	symbol table pointer, if required

RES Code is written, RELOC bit is set to final value;
  Formal fixup list (FORMFX) has been updated, if necessary.

SID All Ac's are saved except TEMP and LPSA.
⊗;

BIT2DATA (EMITTER)
INDIR	←← 20	;THE INDIRECT BIT!!
;PNTROP	←← 200	;THIS OPERATION WILL DO POINTER INDEXING
		; (PURELY LOCAL BIT, BUT DON'T SEND IT IN)
IMMED	←← 1000	;THE IMMEDIATE BIT (FOR SOME THINGS).


↑XCALLQ:
	SKIPE	NOEMIT
	POPJ	P,
	PUSH	P,C		;LITTLE ROUTINE
	HRL	C,PCNT		;FOR CALLING LIBRARY ROUTINES.
	EXCH	C,(A)		;FIXUP INTO LIBRARY TABLE.
	EMIT	(<PUSHJ RP,NOUSAC!USADDR>)
	POP	P,C
	POPJ	P,


COMMENT ⊗ EMITER Routine⊗

↑EMITER:
	SKIPE	NOEMIT		; GET OUT IF NO CODE IS TO BE EMITTED (I.E. 
	POPJ	P,		;  EXPR!TYPE)
	PUSH	P,A		;SAVE THOSE THINGS WHICH MIGHT CHANGE
	PUSH	P,C
	PUSH	P,D
	PUSH	P,TBITS
	PUSH	P,SBITS
	TRZ	A,PNTROP	;ASSUME NO POINTER OP
;;#  # DCS 3-25-72 Eliminate bad array address problem
;;#  #   When [0,0,0]-word of array (location known, no fixup) falls
;;#  #   on reladr 0 of .REL file, CODOUT will mistake the 0 addr field
;;#  #   for end of fixup chain, will inhibit RELOC -- want RELOC in this
;;#  #   case.  A bad fix, should be more generally solved.
	TLO	FF,RELOC!FFTMP1	;AND RELOC (FFTMP1 FOR CODOUT 0-TEST)
;;#  #
	TRNE	A,USADDR	;ADDR IN C(LH)?
	 JRST	 EAC		;YES, BYPASS SEMANTICS TESTING
	TLZ	FF,RELOC	;NOW ASSUME NO RELOCATION
	HRRZS	C		;CLEAR DISPLACEMENT FLD -- C(LH)
	TRNE	A,NOADDR	;IS THERE AN ADDRESS FLD AT ALL?
	 JRST	 EAC		;NO, FINISH UP
	TRNE	A,JSFIX
	JRST	EVAR		;GO DO A FIXUP

; NOW GET SEMANTICS AND DISPATCH TO CORRECT ROUTINE TO OUTPUT INSTR

	MOVE	SBITS,$SBITS(PNT)
	MOVE	TBITS,$TBITS(PNT)
;; #JR# BY JRL 10-17-72 A STRING ITEM IS NOT A STRING
	TRNE	TBITS,ITEM!ITMVAR
	TRZ	TBITS,STRING	;FORGET ABOUT STRING TYPE FOR ITEMS
;; #JR# 
NOSBS:	
NOREC <
	TRNN	TBITS,PNTVAR	;IF PNTVAR OR INDXED OR
>;NOREC
	TLNE	SBITS,INDXED	; REFERENCE FORMAL,
	TRO	A,PNTROP	;INDICATE A POINTER OPERATION
	TLNE	TBITS,REFRNC
	TRO	A,PNTROP
	TRNE	A,ADDR		;IF ADDR and PNTROP, TURN OFF BOTH
	TRZE	A,PNTROP	;(THE IMMEDIATENESS
	TRZ	A,ADDR		; OF ADDR CANCELS THE INDIRECTNESS OF PNTROP
	TLNE	TBITS,SBSCRP	;ELIMINATE FXTWO IF
	TRZ	A,FXTWO		; ARRAY NAME

;;#FP#  1-10-72 DCS (1-2)
	TLNE	SBITS,INAC	;IN ACCUMULATOR?
	 JRST	 EINAC
;;#FP#
	TLNE	TBITS,FORMAL	;FORMAL PARAMETER (ACTUAL)?
	 JRST	 EFORM		; 
	TRNE	A,PNTROP	;INDIRECTNESS DESIRED?
	 JRST	 EPNT
;;#FP#  1-10-72 DCS (2-2)
	TLNE	SBITS,PTRAC	;IN ACCUMULATOR? (WAS INAC TOO)
	 JRST	 EINAC
;;#FP#
	TRNE	A,ADDR		;SHOULD WE CONSIDER CONSTANT IMMED?
	 JRST	 EVAR		;NO
	TLNE	TBITS,CNST	;NUMERIC CONSTANT?
	TRNE	TBITS,STRING	;
	 JRST	 EVAR		; NO


ECONST:
	SKIPE	OPDUN		;NEVER OPTIMIZE USER INLINE CODE
	 JRST	 EVAR		; BUT REFER TO MEMORY
	MOVE	TEMP,$VAL(PNT)	;GET VALUE
	TRNN	A,IMMOVE	;IMMEDIATE MOVE REQUESTED?
	 JRST	 OPCON1		; NO, TEST LH0
	HRLI	A,(<MOVE >)	;ASSUME MOVEI

	TLC	TEMP,-1		;TEST LEFT HALF -1
	TLCN	TEMP,-1		;IS IT?
	 JRST	 [HRL C,TEMP	;YES, SET UP
		  HRLI A,(<HRROI>) ; INSTR
		  JRST EAC]	;AND EMIT IT
	TRNE	TEMP,-1		;RIGHT HALF ZERO?
	 JRST	 OPCON1		; NO
	MOVSS	TEMP		;YES, SWAP HALVES
	TLO	A,4000		; AND TURN ON MOVSI BIT
OPCON1:	TLNE	TEMP,-1		;LEFT HALF ZERO?
	 JRST	 EVAR		;NO
	HRL	C,TEMP
	LDB	TEMP,[POINT 9,A,8] ;GET OP-CODE
	SUBI	TEMP,200	;ONLY OPCODES IN RANGE <MOVE> (200)
	JUMPL	TEMP,EVAR	; TO <OR> (434) WILL
	CAILE	TEMP,234	; BE CONSIDERED
	 JRST	 EVAR
	PUSH	P,USER
	IDIVI	TEMP,=36	;WORD # TO TEMP, BIT # TO USER
	MOVE	TEMP,OPBTS(TEMP);SOME BITS

TABCONDATA (OPCODE BITS TABLE FOR EMITER OPTIMIZER)
OPBTS:	421042004000	;BIT ON IF
	000000104000	;CORRESPONDING OPCODE
	776000000000	;CAN BE IMMEDIATE
; OLD WORD OBPTS+3	;REPLACED (6-27-73)
;	001040000000
;; #KAB INCORRECT AND MISSING OBPTS ENTRIES
	000000004200
	401040000000
;; #KAB#
ENDDATA

	LSH	TEMP,(USER)	;THE RIGHT ONE
	POP	P,USER
	JUMPGE	TEMP,EVAR	;CAN'T OPTIMIZE, CODE WRONG
	CAML	A,[CAM]		;THE COMPARES ARE MADE 
	CAML	A,[JUMP]	; IMMEDIATE BY TURNING OFF
	 TLOA	 A,IMMED	; THE 10000 BIT, ALL OTHERS
	TLZ	A,10000		; BY TURNING ON THE 1000 BIT
	JRST	EAC		;PUT OUT OPTIMIZED INSTR



EPNT:	HRRE	TEMP,$VAL(PNT)	;GET DISPLACEMENT IF ANY
	SUBI	TEMP,1		;ASSUME STRING AND ¬FXTWO
;;#UE#	(3 OF 3) INDEXED STRING ARRAY TEMPS ARE LOSERS
	TLNE	TBITS,SBSCRP	;IF AN ARRAY 
	AOJA	TEMP,EPNT.1	;JUST REVERSE ASSUMPTION QUAM CELERIME
;;#UE# ↑
	TRZN	A,FXTWO		;IF FXTWO OR
	TRNN	TBITS,STRING	; ¬STRING,
	 ADDI	 TEMP,1		;REVERSE ASSUMPTION
EPNT.1:	HRL	C,TEMP		;GET TO DISPLACEMENT PLACE
	TLNE	SBITS,PTRAC	;POINTER IN AC?
	 JRST	 EACX		; YES
	TLNE	C,-1		;MAKE INDIRECT
	 ERR	 <DRYROT AT EPNT>,1 ;UNLESS WE WANTED A DISPLACEMENT
	TRO	A,INDRCT	;MAKE IT INDIRECT
	JRST	 EVAR		;GO DO FIXUPS

EACX:	HRL	D,$ACNO(PNT)	;USE AC AS INDEX
	TLNE	TBITS,OWN	;IF ARRAY NAME COMES INTO IT,
;;#  # DCS 3-25-72 Bad array address problem.
	 TLC	 FF,RELOC!FFTMP1;RELOCATABLE, SHOUDN'T 0-TEST IN CODOUT
;;#  #
	TROA	A,USX		;DENOTE THAT IT SHLD BE DONE
EINAC:	HRL	C,$ACNO(PNT)	;INAC, GET ACNO AS DISPL.
	JRST	CHKIMM		;SEE IF ADDR IS ON

EFORM:	TRO	A,USX		;WILL NEED TO USE A STACK AS INDEX
	HRRZ	TEMP,$ADR(PNT)	;GET DISPL FROM STACK TOP
	TLNE	TBITS,REFRNC	;REFERENCE PARAM?
	 JRST	 REFPRM		; YES
VALPRM:	TRNN	TBITS,STRING	;STRING
	JRST	REFPRM		;NO
	SKIPN	SIMPSW
	TRNN	SBITS,DLFLDM	;IF SIMPLE OR DL 0 THEN DO IT THE OOLD WAY
	JRST	USERSP
	LDB	LPSA,[LEVPOINT(SBITS)]; PICK UP LEVEL
	HLL	D,DISTAB(LPSA)	;PICK UP REGISTER
	TLNN	D,17
;;#MN# 7-13-73 THE FRIDAY 13 ACCESS KLUGE
	JRST	[
		PUSH P,TEMP
		HLRZ	TEMP,LSDRLV		;MAYBE THE THING IS STILL AROUND
		CAIE	TEMP,(LPSA)
		ERR	<DRYROT AT EFORM FOR STRING>	;BETTER NOT BE 0
		HLL	D,LSDRNM		;GET THE OLD THING
		POP	P,TEMP
		JRST	.+1]
;;#  #
	TRZE	A,FXTWO		;IF SECONG WORD

	SUBI	TEMP,1		;FIX IT
	MOVN	TEMP,TEMP
	HRL	C,TEMP		;USE THIS DISPL
	JRST	CHKIMM		;GO CHECK
 
REFPRM:	TLNN	TBITS,SBSCRP	;IF SUBSCRIPTED AND
	 JRST	 .+3		; REFERENCE, 
	TLNE	TBITS,REFRNC		;
	TRZ	A,PNTROP	;DO NOT GO INDIRECT.
	TRZE	A,PNTROP	;WANT TO GET VALUE?
	 TRO	 A,INDRCT	; YES, GO INDIRECT, FIND ON RP STACK
	LDB	LPSA,[LEVPOINT(SBITS)];PICK UP DISPLY LEVEL
	CAIE	LPSA,0		;IF HAVE A DISPLAY
	JRST	USEDRF		;USE IT
	MOVE 	LPSA,TPROC	;PICK UP PROC ID
	HRRZ	LPSA,$SBITS(LPSA);PICK UP RH OF SBITS FOR PROC
	ADDI	LPSA,1		;WANT LEVEL OF FORMLS
	XOR	LPSA,SBITS	;ALL THIS IS A FANCY TEST TO SEE IF THIS PROC'S
	TRNE	LPSA,LLFLDM			;IS IT THE SAME
	ERR	<INACCESSABLE FORMAL>		;NO
	SKIPN	SIMPSW		;BETTER BE SIMPLE PROC
	ERR	<DRYROT AT EPNT -- SIMPLE?>	;YOU FUCKED UP


USERP:	HRLI	D,RP		;MARK THIS STACK
	ADD	TEMP,ADEPTH	;TOTAL ARITH STACK DEPTH
	JRST	MAKFRM		;GO CREATE FORMAL REF INSTR

USERSP:	HRLI	D,RSP
	ADD	TEMP,SDEPTH
	TRZE	A,FXTWO		;SECOND WORD?
	 SUBI	 TEMP,1		;YES, DON'T GO SO FAR

MAKFRM:	MOVNS	TEMP		;NEGATIVE STACK DISPLACEMENT
	HRL	C,TEMP		;USE THIS DISPLACEMENT
;;#KH# RHT (11-21-72) DELETED LARGE HUNKOF LEFT OVER STUFF FROM FORMFX
	JRST	CHKIMM		;FINISH OUT
USEDRF:	HRL	D,DISTAB(LPSA)	;PICK UP DISPLAY REGISTER
	TLNN	D,-1		;WAS IT LOADED
;;#MN# FRIDAY 13 JULY 
	PUSHJ	P,[DRKLUG:
		PUSH	P,TEMP
		HRRZ	TEMP,LSDRLV
		CAIE	TEMP,(LPSA) ;OLD LEVEL THERE???
		ERR	<DRYROT AT EFORM>,1;NO
		POP	P,TEMP
		HRL	D,LSDRNM
		POPJ	P, ]
;;#  #
	MOVN	TEMP,TEMP	;NEGATE DISPL
	SUBI	TEMP,1		;SINCE RF IS ONE MORE AWAY
	HRL	C,TEMP		;USE IT
	JRST	CHKIMM		;GO FINISH UP

EVAR:
 	TLO	FF,RELOC	;NOW ASSUME RELOC AGAIN
;;#VM# ! JFR 10-30-75 PARANOIA THAT PROCEDURES COULD SLIP THROUGH
	TRNN	TBITS,PROCED
	TRNE	A,JSFIX		;IF JUST WANT A FIXUP
	JRST	USECR		;THEN THATS ALL YOU GET
	TLNE	SBITS,CORTMP	;IS IT A CORE TEMP
	JRST	[		;YES
		SKIPN	RECSW		;IF NOT RECURSIVE PROC THEN
		JRST	USECR		;USE A CORE LOCN -- NO DR NEEDED
		MOVE	LPSA,CDLEV	;USE THIS LEVEL
		JRST	USED.1		;NO LDB ALLOWED
		]
	TRNE 	SBITS,DLFLDM	;STACK VAR?
	JRST	USEDR		;YES
USECR:
	HRL	C,$ADR(PNT)	;ADDR OR LAST FIXUP
DCDFX:	TRNN	A,JSFIX
	TRNE	TBITS,FORWRD!INPROG ;MUST FIXUP IF EITHER IS ON
	 JRST	 DOFIX
	TLNN	SBITS,FIXARR	;DON'T FIXUP IF FIXARR ON
	TRNE	TBITS,PROCED!LABEL  ;ELSE ONLY IF NEITHER OF THESE
	 JRST	 DONTFX
REC <
	TRNE	TBITS,PNTVAR	;CHECK FOR CLASS ID
	TRNN	TBITS,SHORT	; IE SHORT PNTVAR
	JRST	DOFIX
	JRST	DONTFX		;CLASS ID NOT FIXED UP 
>;REC
NOREC <
	JRST	DOFIX		;HERE DO IT
>;NOREC

USEDR:	LDB	LPSA,[LEVPOINT<SBITS>]	;GET DISPLAY LEVEL
USED.1: HRL	D,DISTAB(LPSA)		;USE DISPLY REG
	TRNE	TBITS,STRING		;UNLESS STRING
	JRST	[
;#IO# RHT 7-17-72 ATTEMPT TO USE STR DR FOR A INDEXED TEMP
		TLNE SBITS,INDXED	;DONT IF RESULT OF ARRAY CALC
		JRST	.+1		;
;#  #
		TLNN TBITS,SBSCRP	;DONT FOR ARRAYS
		HLL	D,DISTAB(LPSA)	;CODED THIS WAY TO HANDLE USUAL CASE
		JRST	.+1]
	TRNE	A,USX			;BETTER NOT PLAN TO INDEX THIS
	ERR	<DRYROT AT EVAR>,1	;NO
	TLNN	D,-1			;WAS IT LOADER
;;#UV# JFR 8-16-75 WHAT A HACK.
	 PUSHJ	P,DRKLUG		;FIX RACE CONDITION.  GET (ACCESS)
			;FOUND THE DISPLAY REG, BUT ACCOP USED THE REG SINCE
			;ALL OTHERS WERE BUSY.  HACK, HACK.
	HRL	C,$ADR(PNT)		;PICK UP DISPL
	TRO	A,USX			;USE THE MOTHER
	JRST	DCDFX			;GO THINK ABOUT FIXING UP



DOFIX:	HRRZ	TEMP,PCNT	;READY TO DO FIXUP CHAINING
	TRZE	A,FXTWO		;USE SECOND FIXUP ADDR
	 JRST	 [HLL C,$ADR(PNT)
		  HRLM	TEMP,$ADR(PNT)  ;YES, MATTER OF FACT
		  JRST	CHKIMM]
	HRRM	TEMP,$ADR(PNT)	;FINISH FIXUP CHAINING

DONTFX:
	TLNN	SBITS,FIXARR
	 JRST	 CHKIMM
	SUB	C,[XWD 1,0]	;ASSUME STRING, NOT FXTWO
	TRNE	TBITS,STRING	;IF NOT STRING OR IF FXTWO,
	TRZE	A,FXTWO
	 ADD	 C,[XWD 1,0]	; NULLIFY ASSUMPTION
CHKIMM:

	TRNN	A,ADDR		;DO WE WANT THIS POINTER RAW?
	 JRST	 EAC		; NO, FINISH UP
	TLO	A,IMMED		;THE ONLY WAY TO DO IT HERE IS TO
	TRNE	A,USCOND	; MAKE THE INSTR IMMEDIATE
	 HRLI	 A,(<CAI>)	; (CONDITIONAL MUST BE A CAM)

EAC:	TRNE	A,INDRCT	;INDIRECT BIT WANTED?
	 TLO	 A,INDIR
	TRNN	A,NOUSAC	;AC FLD PROHIBITED?
	 DPB	 D,[POINT 4,A,12] ;NO, PUT IT IN
	TRNE	A,NORLC		;RELOCATION PROHIBITED?
	 TLZ	 FF,RELOC	; YES, TAKE IT OUT
	TRNE	A,USCOND	;CONDITION BITS NEEDED TO FINISH OPCODE
	 DPB	 C,[POINT 3,A,8] ;YES, DO IT
	TRNE	A,USX		;D(LH) TO BE USED AS INDEX FLD?
	 TDO	 A,D		;YES (WIPES OUT A(RH))
	HLR	A,C		;GET DISPL (SO DOES THIS)
;;#  # DCS 3-25-72 bad array address problem
	MOVEI	TEMP,CODOUT	;STANDARD CASE
	TLNN	FF,FFTMP1	;IF THIS BIT GOT TURNED OFF, CODREL SHOULD
	 MOVEI	 TEMP,CODREL	; BE CALLED TO AVOID THE 0-TEST WHICH
	PUSHJ	P,(TEMP)	; WOULD INHIBIT RELOC -- PUT OUT THE CODE
;;#  #
	POP	P,SBITS
	POP	P,TBITS
	POP	P,D
	POP	P,C
	POP	P,A
;;#MN# 7-13-73
	SETZM	LSDRLV		;REALLY ONLY NEED TO ZERO THIS
	SETZM	LSDRNM		;REALLY WILL DO THIS ANYHOW
;;#  #
	POPJ	P,		;RESTORE AND RETURN
SUBTTL	Generalized push and pop.

COMMENT ⊗Qstack Routines -- BPUSH, etc.⊗

DSCR QSTACK ROUTINES
DES These are routines to provide generalized, expandable push-
 down stacks (buffers? queues?) for use by algorithms which need
 widely varying storage, accessed in simple ways.  Such structures
 are called QSTACKS, and are built out of Semblks as follows --

WORD1 --    ptr to PREV,,ptr to NEXT
WORDS 2-11 --	up to 10 words of "stack" data

A stack is identified by its QPDP, or Qstack Descriptor, which is --
 ptr TOP,,ptr Semblk containing TOP

Most Qstack operations reference the address where this QPDP (there 
 should be one QPDP which always refers to the TOP) is stored.  Others
 may also be used in conjunction with Qstack operations

Qstack operations are provided to PUSH data on, POP data off (these
 allocate and release Semblks, if necessary, and change the TOP QPDP),
 access data non-destructively in forward and reverse directions, and
 to clear a given Qstack.
⊗

DSCR BPUSH
CAL PUSHJ via QPUSH macro
PAR LPSA ptr to  QPDP for Qstack
 A is data to be pushed
RES QPDP is updated, A is stored in Qstack, new Semblk if necessary
DES if QPDP is 0, an initial Semblk is created, QPDP constructed.
SID only TEMP is changed
SEE QPUSH
⊗

↑BPUSH:	PUSH	P,A			;SAVE IT.
	SKIPN	TEMP,(LPSA)		;THE CURRENT POINTER
	JRST	NEWONE			;NONE YET, GUYS.
	HLRZ	A,TEMP
	CAIL	A,BLKLEN-1(TEMP)	;GONE OVER BLOCK BOUNDARY?
	JRST	NOTHER			;YES
PUSH1:	PUSH	A,(P)			;SEE !!!
	HRLM	A,(LPSA)		;CURRENT POINTER UPDATED.
	POP	P,A			;RESTORE
	POPJ	P,			;DONE

NEWONE:	PUSH	P,LPSA
	GETBLK				;GET A NEW BLOCK.
	SETZM	(LPSA)
	MOVE	TEMP,LPSA		;POINTER TO NEW BLOCK.
	POP	P,LPSA
MORBLK:	HRRM	TEMP,(LPSA)		;UPDATE PDP POINTER.
	HRRZ	A,TEMP
	JRST	PUSH1			;FINISH OUT.

NOTHER:	PUSH	P,LPSA			;SAVE IT
	GETBLK
	MOVE	TEMP,LPSA		;POINTER TO NEW ONE.
	POP	P,LPSA
	HRRZ	A,(LPSA)		;PDP POINTER.
	HRLZM	A,(TEMP)		;SAVE LINKS IN NEW BLOCK.
	HRRM	TEMP,(A)		;AND IN PDP
	JRST	MORBLK


DSCR BPOP
CAL PUSHJ via QPOP macro
PAR LPSA ptr to  QPDP
RES A ← data from TOP, QPDP is updated
DES Semblks are released as they are emptied
SID only TEMP, A are changed
ERR if there is no QPDP, or if no more data, error
SEE QPOP
⊗

↑BPOP:	SKIPN	TEMP,(LPSA)		;PDP POINTER
	ERR	<DRYROT -- BPOP>
	HLRZ	A,TEMP
POPMOR:	SUBI	A,1			;THIS IS A POP
	CAIGE	A,(TEMP)		;GONE BELOW THIS BLOCK?
	JRST	POPBAK			;YES ALAS
	HRLM	A,(LPSA)		;UPDATE PDP
	MOVE	A,1(A)			;THIS IS THE RESULT.
	POPJ	P,

POPBAK:	PUSH	P,TEMP
	HLRZ	TEMP,(TEMP)		;BACKWARD POINTER.
	PUSH	P,TEMP
	FREBLK	<-1(P)>			;DELETE THE BLOCK.
	POP	P,TEMP
	POP	P,(P)			;INGNORE THIS.
	SKIPN	TEMP			;IS IT THERE?
	ERR	<DRYROT -- BPOP>
	HLLZS	(TEMP)			;ZERO FORWARD POINTER
	MOVEM	TEMP,(LPSA)		;UPDATE PDP
	MOVEI	A,BLKLEN-1(TEMP)	;NEW MAX.
	JRST	POPMOR			;FINISH OUT.


DSCR QTAK
CAL PUSHJ, via QTAKE macro
PAR B is QPDP for data word preceding one desired
 LPSA ptr  QPDP for this QSTACK
RES if there is more data (check via LPSA ptr):
 B is updated as if it were a BPUSH QPDP
 A receives value of TOP
 BTAK skips

 if there is no more data:
 nothing is changed
 BTAK does not skip
SID only A,B, TEMP changed
SEE QTAKE macro
⊗
↑QTAK:	CAMN	B,(LPSA)		;OVERFLOW?
	POPJ	P,			;YUP
	HLRZ	TEMP,B
	CAIL	TEMP,BLKLEN-1(B)	;OVERFLOW OF OTHER TYPE?
	JRST	NEXTBL			;YES
TAKMOR:	MOVE	A,1(TEMP)
	HRLI	B,1(TEMP)
	AOS	(P)
	POPJ	P,

NEXTBL:	HRRZ	B,(B)			;GO FORWARD
	HRRZ	TEMP,B			;NOTE THAT THE BLOCKS ARE
	JRST	TAKMOR			;NOT DELETED !!!!!!


DSCR BBACK
CAL PUSHJ via QBACK macro
PAR B contains QPDP
RES B is "popped"
 A receives data from TOP word
 if there was data left, skip-returns -- else no-skip
SID only A, TEMP, B changed
SEE QBACK
⊗
↑↑BBACK: HLRZ	A,B		;ptr to TOP, ACCORDING TO B'S QPDP
BTMOR:	SUBI	A,1		;TRY THE "POP"
	CAIGE	A,(B)		;WAS THERE DATA LEFT HERE?
	 JRST	 BTBAK		;NO, BACK UP
	HRLM	A,B		;UPDATE B'S QPDP
	MOVE	A,1(A)		;FETCH "TOP" ELEMENT
	AOS	(P)		;SUCCESS UNLESS SOSED BY BTBAK
QPOPJ:	POPJ	P,		;DONE

BTBAK:	HLRZ	B,(B)		;BACK UP
	JUMPE	B,QPOPJ		; NO MORE DATA
	MOVEI	A,BLKLEN-1(B)	;RESET LH PTR
	JRST	BTMOR		;FINISH UP

DSCR BFLUSH
CAL PUSHJ, via QFLUSH macro
PAR LPSA ptr to QPDP
RES all Semblks cleared, QPDP zeroed
SID A, B, TEMP changed
SEE QFLUSH
⊗
↑↑BFLUSH: SKIPN	A,(LPSA)
	 POPJ	P,		;NO STACK
FLSHLP:	HLRZ	B,(A)		;GET NEXT PTR
	FREBLK	(A)		;RELEASE TOP SEMBLK
	MOVE	A,B
	JUMPN	A,FLSHLP	;MAKE NEXT ONE BACK TOP ONE
	SETZM	(LPSA)		;ALL DONE
	POPJ	P,

DSCR BBEG
CAL PUSHJ, via QBEGIN macro
PAR B is QPDP
RES B is QPDP which, when BTAKEd, returns first element in Qstack
 B is 0 if no Qstack exists
SID only B, TEMP changed
SEE QBEGIN
⊗
↑↑BBEG:	SKIPN	B,(LPSA)	;IS THERE A STACK?
	 POPJ	 P,		; NO
LOPPP:	HRLS	B		;MAKE INIT QPDP FOR THIS SEMBLK
	HLRZ	TEMP,(B)	;GET BACK PTR
	JUMPE	TEMP,CPOPJ	;WHEN HAVE REACHED FIRST SEMBLK, QUIT
	MOVE	B,TEMP		;TRY AGAIN
	JRST	LOPPP

COMMENT ⊗PWR2⊗

DSCR PWR2
DES Tests number in register B for being a power of 2.
 if so, it skip-returns (********) and C
 has a small integer representing the power.

SID AC'S: uses TEMP
⊗;
↑PWR2:	JUMPLE	B,CPOPJ		;ROUTINE TO TEST B FOR A POWER OF TWO.
	MOVN	TEMP,B		;TWO'S COMPLEMENT.
	AND	TEMP,B		;AND THE AND
	TLNN	B,777000	;TOO BIG ?
	CAME	TEMP,B		;THE MAGIC TEST FOR POWER OF TWO.
	POPJ	P,		;NO DICE.
	FSC	B,233		;NOW THE NORMALIZE.
	ASHC	B,-=44		;NOW CORRECTLY IN C. (LEFT HALF)
	SUB	C,[XWD 201,400000]
	AOS	(P)
	POPJ	P,


SUBTTL	Generator Output Routines.

COMMENT ⊗GBOUT Description, Loader Block Format Description⊗

DSCR GBOUT -- write a block of binary output
DES 
One of the specialized output routines has produced
	a loader block, ready for output.  These 
	routines are:

	CODOUT -- prepares a code block. Each call
	  puts a word of code into a buffer and sets relocation
	  appropriately.

	FBOUT -- prepares a fixup block. Each call puts a fixup word into
	  a buffer.

	SOUT -- for outputting symbols. Each call puts a symbol
	  name (in RADIX50) and an address into a buffer.

Other parts of the generators also call GBOUT for special functions
	(entry block, prog name block, etc). The routines
	call GBOUT when their buffers are full or when they 
	wish to force out all of a given block.

Each block outputted by GBOUT has the same general format:
	WD1:  BLOCK TYPE,,COUNT
		0 LEQ COUNT (WDn-WD3+1) LEQ 18
	WD2:  relocation bits
		18 2-bit bytes (left-justified) corresponding
		  to the 18 (maximum) data words in the block.
		  The first bit of each is on if the left
		  half is to be relocated. The second bit
		  of each corresponds to the right half
		  of its data word.
	WD3:  first data word
	.
	.
	.
	WDn:  last data word		2 LEQ n LEQ 20

The Binary file is opened and initialized in the command
	scanner (outer block of SAIL). The FF bit BINARY
	is on if a binary output is desired (if the file is open).

PAR B -- SIZE,,address of loader block
 SIZE is size of ENTIRE block (2 + WD1's count)
  It is zero if WD1's COUNT is to be believed.

RES The block is written if SIZE is GEQ 3

SID All ACS are preserved 
⊗;

COMMENT ⊗ Control Variables for Loader Block Output⊗

ZERODATA (REL-FILE OUTPUT VARIABLES)

;CODPNT -- bp for relocation bits in BINTAB CODE block
;    see GBOUT for details about relocation bits -- initted to --
?CODPNT: POINT 2,BINTAB+1

;FRSTSW -- off until first word of code goes out -- used to
;    trigger output of program name block, initial code, etc.
;    in CODOUT -- set on in CODOUt
?FRSTSW: 0

;FXPNT -- reloc bits bp for FXTAB FIXUP block -- see FBOUT, GBOUT
?FXPNT: POINT 2,FXTAB+1

;LSTRAD, LSTRLC, LSTWRD -- last radix50 word output, last code
;    word output, last relocation bits output -- used by Boolean
;    and ALLOT code, for repeating some of it
↑↑LSTRAD: 0
↑↑LSTRLC: 0
↑↑LSTWRD: 0

;OUTADR -- bp set up by GBOUT for fetching words from LODBLKs
;    for transfer to output buffer
?OUTADR:  0

;RAD5. -- RADIX50 creates a value corresponding to a symbol comprising
; the first 5 characters of the identifier, followed by ".", in 
; addition to each value it creates.  It is saved here, used sometimes.
↑↑RAD5.: 0
↑↑RAD5$: 0	;SIMILAR, BUT WITH A $
↑↑RAD5%: 0	;GUESS WHAT
;SMPNT -- reloc bits pb for SMTAB SYMBOLS block -- see SCOUT, GBOUT
?SMPNT:  0

DATA (REL-FILE OUTPUT VARIABLES)

;SALIB -- used to place main SAIL library request in LBTAB output
;   loader block -- see DONES, PRGOUT
;SALIH -- re-entrant version of library

↑SALIB:	LIBLEN		;STRING CONSTANT, LIBLEN LONG
;;#HX# 6-24-72 DCS PARAMETERIZE LIBRARY NAMES
	POINT	7,[LIBLOW]
REN <
↑SALIBH:LIBLEN
	POINT	7,[LIBHI]
;;#HX#
>;REN

BAIL<
↑BAIREL: BALENG		;STRING CONSTANT, BALENG LONG
	POINT	7,[BAILOD]
↑BAIPD:	BPDALN		;STRING CONSTANT
	POINT	7,[BAIPDS]
>;BAIL

COMMENT ⊗ Loader Output Blocks-- Entry, Program Name, Initial Stuff⊗
 
DATA (LOADER OUTPUT BLOCKS)
COMMENT ⊗
Here are the loader output blocks.  They are formatted as described
   in SAILON ;;.; by Bill Weiher.  The general routine GBOUT handles
   the actual output of these (filled) blocks to the .REL file.  For
   several of the block types, special routines exist below (CODOUT,
   FBOUT, etc.) to place individual words (and their relocation) into
   the blocks, and to call GBOUT when a block is full
⊗


COMMENT ⊗
ENTTAB -- ENTRY block -- names included in SAIL ENTRY statements.
   This must be the first block out (due both to syntax and
   necessity.  It allows the .REL file to be used as part
   of a library.
⊗
LODBLK	(ENTRY,4,ENTTAB,,=18)


COMMENT ⊗
PROGNAM -- PROGRAM NAME BLOCK -- output of this block is delayed until
   first word of code goes out, to give user longest possible time
   to come up with a program name.  Must go out before code to name 
   outer block symbols and labels and stuff.
⊗
;;%CL% JFR 7-22-75 IDENTIFY OURSELVES TO LINK-10
LODBLK	(PROGNAM,6,BEGNAM,BEGCNT,2)
RELOC .-2
↑↑PRGTTL: RADIX50 0,M		;DEFAULT NAME, IF NO OTHER COMES
XWD	KI10SW*20000+7,0	;7 means SAIL, bits 0-5 tell hardware assumptions
;;%CL% ↑

COMMENT ⊗
HBLK -- High Segment Block -- Denotes Re-entrant Output
⊗
REN <
LODBLK	(HIGH,3,HBLK,HBLK2,1,,<XWD 200000,0>)
RELOC .-1
	XWD	400000,400000	;TWOSEG
>;REN



COMMENT ⊗
BEGOUT -- STANDARD INITIAL CODE SEQUENCE
   This code is always put out, but is only executed (and fixups
   are only correct) for Main Programs.  Sample fixed-up code is
   included in the comments
⊗


LODBLK (CODE,1,BEGOUT,BEGCT2,10,,<XWD 200000,0>)
RELOC .-10

↑↑BEGPC:0		;PC ALWAYS 0 OR 400000
	SKIPA		;NOT STARTED IN RPG
	SETOM		;RPGSW
	JSR		;SAILOR
;;%AL% THE HRLOI IS NOW DONE BY SAILOR
;;	HRLOI	RF,1	;FOR FIRST LINK
	PUSH	P,RF
	PUSH	P,	;[PDA,,0]
	PUSH	P,SP
	HRRI	RF,-2(P); SET F



COMMENT ⊗                        Code, Boolean Code, Fixups, Links⊗

COMMENT ⊗
BINTAB -- MAIN CODE BLOCK
   All generated instructions are output via CODOUT-GBOUT
   to this block.  See CODOUT for details
⊗
LODBLK	(CODE,1,BINTAB,,=18)


COMMENT ⊗
BOLOUT -- SPECIAL BOOLEAN CODE BLOCK
   Conditionals are output once when a condition is seen, and
   again (with fixups and compare op codes correct) when the
   entire Boolean expression has been parsed and analyzed.
   See BOOLEAN for details.
⊗
LODBLK	(CODE,1,BOLOUT,,0,,<XWD 200000,0>)
↑↑BRELC←.-1	;TO ACCESS RELOCATION BITS
↑↑BPCNT: 0	;PROGRAM COUNTER -- SAME AS WHEN INSTRS FIRST OUT
↑↑BWRD1: 0	;COMPARE, SKIP, OR CONDITIONAL JUMP
↑↑BWRD2: 0	;UNCONDITIONAL JUMP IF BWRD1 WAS A COMPARE OR SKIP


COMMENT ⊗
FXTAB -- FIXUPS
    Each word contains in its right half the address or stack
    displacement (reloc bits adj. accordingly) of a variable
    or instruction.  The left half contains the address 
    (relative to 0, of course) of the last instruction or data
    which requires this address field.  This location, in turn,
    was compiled to refer to the next previous use of the variable
    or whatever... in other words, a fixup chain (terminates in 0).
    The LOADER uses these fixups to handle forward references to 
    things.  See FBOUT for details
⊗
LODBLK	(FIXUPS,10,FXTAB,,=18,-1)


COMMENT ⊗
SMTAB -- SYMBOLS
    All local and internal symbols, and global requests, are output
    through this block.  See SCOUT and friends for details.
⊗
LODBLK	(SYMBOLS,2,SMTAB,,=18,<XWD 42104,210421>)
;(RELOCATE EVERY OTHER WORD -- GENERALLY)


COMMENT ⊗
SLNKBK -- LINK BLOCKS
    The string link, space link, and other links are output
    through this block.  These links provide inter-RELfile
    communication (best example is link that chains all string
    variables together, so that STRNGC can get at them. See
    LNKOUT for details.
⊗
LODBLK	(LINK,12,SLNKBK,SDSCRP,2,,<XWD 40000,0>)
 RELOC	.-2
↑↑LNKNM: 1		;USUALLY STRING LINK, BY CONVENTION #1
			;SPACE LINK IS #2
			;SET LINK IS #3
			;STRNGC ROUTINE NAMES LINK IS #4
			; THESE ARE SAIL CONVENTIONS ONLY
↑↑SLNKWD: 0		;ADDRESS OF ELEMENT OF CHAIN

COMMENT ⊗                        Space Allocation Block

SBCTBL -- SPACE ALLOCATION BLOCK
    In this block is collected all REQUIRE specifications
    (except LOAD!MODULES, LIBRARIES, SOURCE!FILES) and 
    space limits (string space, system pdl, new items, etc.)
    It is output as a code block.  Also output is a link
    block tying this space block to all the others loaded
    together.  The SAILOR (initialization) routine uses this
    information to provide an environment pleasing to the user.
    See DONES and the REQUIRE code for more details. Also GOGOL
    (%ALLOC) for block format explanations
⊗
;;%BR% RHT ALLOW COMVER THING FOR EVERYONE (BUT KEEP EXPO FOR NOW)
↑↑SPCSIZ←←=17    ;$SPREQ+1	;IF EVER MAKE 18 OR MORE, MUST CHANGE SOME THINGS
;;↑↑SPCSIZ←←=14			;BAD OLD VALUE *****
;;%BR% ↑

↑↑SPCTBL:XWD	1,SPCSIZ	;CODE BLOCK, AT LEAST SPCSIZ LONG
	BYTE (2) 1,0,0,0,0,1,0,0,0,0,0,0,1,1,0,1
		;PC WORD,MESLNK,TINIT,PINIT,OBPDA(RELOC)
↑SPCPC: 0	;PC LOCATION
	0	;LINK BLOCK PROVIDES CHAIN THROUGH THIS LOC
;; %AG% HAVE ITEMNO KEEP BOTH MIN AND MAX
↑ITEMNO:0	;MIN,,MAX ITEM NUMBER DECLARED THIS COMPILATION
↑NWITM:  0	;REQUIRE n NEW!ITEMS PUTS n HERE
;; %AG% ! HAVE GITEMNO CONTAIN LEAPIS FLAG
↑GITEMNO:0	;XWD LEAPIS,MAX (MIN?) GLOBAL ITEM NUMBER DECLARED
↑MESLNK:0	;POINTER TO MESSAGE PROCEDURE LIST PUT HERE
↑PNAMNO:0	;REQUIRE n PNAMES PUTS n HERE
↑VERNO:	0	;REQUIRE n VERSION PUTS n HERE
↑SEGNAM:0	;REQUIRE "name" SEGMENT!NAME PUTS "name" HERE IN SIXBIT
↑SEGDEV:0	;REQUIRE "dev:file[p,pn]" SEGMENT!FILE PUTS
↑SEGFIL:0	; dev, file, ppn IN THESE LOCS IN SIXBIT
↑SEGPPN:0	;(LOW BIT OF DEV IS SEGMENT PROTECT BIT, NOT USED NOW)
↑TINIT: 0	;INITIALIZATION BLOCK ADDRESS FOR DECLARED ITEM TYPES
↑PINIT: 0	;INIT. BLOCK FOR PNAMES(DECLARED ITEMS)
;;%BR% 
↑↑COMVER:	0	;NICE THING, BUT SUAI 
;;%BV% !
↑↑OBPDA:0		;OUTER BLOCK PDA
	0		;SPARE
;;%BR% ↑
	BLOCK	50		;ROOM FOR MORE REQUESTS
↑SPCEND←←.-1



COMMENT ⊗                        Request Blocks -- RELfile, Libraries⊗

COMMENT ⊗
PRGTAB -- RELFILE REQUEST BLOCK
   REQUIRE "...." LOAD!MODULE generates one of these.  The LOADER
   loads all requested .REL files after loading all the explicit
   stuff. See REQUIRE code for details
⊗
;; #KS# ADD LOADVR SWITCH
IFN (LOADVR-=54), <
LODBLK	(RELREQ,15,PRGTAB,,=18)
>
IFE (LOADVR-=54), <
LODBLK  (RELREQ,16,PRGTAB,,=18)
>
;; #KS#

COMMENT ⊗
LBTAB -- LIBRARY REQUEST BLOCK
   REQUIRE "...." LIBRARY generates one of these (SAIL main programs
   automatically request SYS:LIBSAI.REL).  The LOADER searches these
   libraries, if necessary, after searching all the others except the
   automatic F4 search.
⊗

;; #KS# LOADVR SWITCH
IFN (LOADVR-=54), <
LODBLK  (LIBREQ,16,LBTAB,,=18)
>
IFE (LOADVR-=54), <
LODBLK  (LIBREQ,17,LBTAB,,=18)
>
;; #KS#


COMMENT ⊗                        Ending Code, Symbols -- END Block

STAROT ETC. -- ENDING STUFF.
   These include some constant ending code, some extra standard
   symbols, the starting address block, if there is one, and so on.
   It's too messy to use the LODBLK macro on, so here it is in
   all its glory--
⊗
EBLEN←←.		;COLLECT LENGTH.

;If this is a Main Program, a starting address block is issued
; (via the GBOUT descriptor EBDSC); else EBDSC1 is used to issue
; all but the starting address block.  Starting address is always
; relative 0 (addr of the BEGOUT code--see above)
?STAROT: XWD	7,1	;STARTING ADDR BLOCK -- 1 DATA WORD
	XWD 200000,0 	;RELOCATE ADDRESS (RH)
↑STRDDR:0		;STARTING ADDRESS ALWAYS REL 0

; If Main Program, global requests must be issued to fill in
; the RPGSW and SAILOR blanks in the BEGOUT block (above)
	XWD	2,4	;SYMBOL BLOCK
	XWD	42104,210421 ;EVERY OTHER WORD.
↑CONSYM:RADIX50	60,SAILOR;JSR REQUEST.
	2		;JSR IS IN LOC 2
	RADIX50 60,RPGSW;FOR SETOM RPGSW BUSINESS
	1		;SETOM IS IN 1

; This part is always issued -- standard symbol names, end block
NOSTAR: XWD	2,STRCT-NOSTAR-2;SYMBOLS
	XWD	40000,0;RELOCATE ONLY S.
	RADIX50	10,S.  ;FIRST EXECUTABLE LOC IN PROG
	0		;ALWAYS 0
	RADIX50	10,P	;SYSTEM PDP ADDR
	RP		;USUALLY 17
	RADIX50	10,SP	;STRING PDP ADDR
	RSP		;USUALLY 16
	RADIX50 10,ARERR;UUO FOR ARRAY INDEX OV/UNDERFLOW
	ARERR		;THE UUO OPCODE
	RADIX50	10,FLOAT;UUO FOR INTEGER to REAL
	FLOAT
	RADIX50	10,FIX  ;UUO FOR REAL to INTEGER
	FIX
STRCT:			;END OF EXTRA SYMBOLS

; END BLOCK
NOREN <
	XWD	5,1	;END BLOCK.
	XWD 200000,0	;RELOCATE PROGRAM BREAK WORD
↑↑PRGBRK: 0		;PROGRAM BREAK-- FIRST NON-USED ADDR
>;NOREN
REN <
	XWD	5,2	;TWO PROGRAM BREAKS
	XWD 240000,0	;RELOCATE PROGRAM BREAK WORD
↑↑PRGBRK: 0		;HIGH-SEG PROGRAM BREAK
	  0		;LOW-SEG PROGRAM BREAK
>;REN

EBLEN←← .-EBLEN		;LENGTH OF ENTIRE OUTPUT RITUAL

↑EBDSC:	XWD	EBLEN,STAROT	;IF MAIN PROGRAM
↑EBDSC1:XWD	EBLEN+STAROT-NOSTAR,NOSTAR ;IF NOT
ENDDATA

COMMENT ⊗ RELINI -- Loader Block Initialization⊗

DSCR RELINI
CAL PUSHJ FROM GENINI
DES SETS UP ALL REL-FILE OUTPUT STUFF BEFORE EACH COMPILATION
⊗

↑↑RELINI:
	HLLZS	BINTAB
	HLLZS	FXTAB
	SETOM	FXTAB+1			;ALL RELOCATABLE
	HLLZS	SMTAB			;CLEARS OUTPUT BUFFER COUNTS
	HLLZS	PRGTAB			;PROGRAM AND LIBRARY REQUEST BLOCKS
	HLLZS	LBTAB
	MOVE	A,[XWD SPCPC,SPCPC+1] ;CLEAR SPACE ALLOCATION BLOCK
	SETZM	SPCPC
	BLT	A,SPCEND		;SIZE ALLOCATION BLOCK.
	HRRI	TEMP,SPCSIZ
	HRRM	TEMP,SPCTBL
	POPJ	P,			;RETURN TO GENINI

COMMENT ⊗ GBOUT Routine⊗

↑GBOUT:	
	PUSH	P,A		;SAVE A
	PUSH	P,B		;SAVE ADDRESS OF BUFFER
	HLRZ	A,B		;GET COUNT IF NONSTANDARD

	TLO	FF,IREGCT	;SET NON-STANDARD COUNT BIT
	HRLI	B,(<POINT 36,0>)	;FOR PICKING UP WORDS
	MOVEM	B,OUTADR	;SAVE TABLE ADDRESS
	JUMPN	A,GBOUTA	;NOT STANDARD (FROM TABLE) COUNT
	HRRZ	A,(B)		;GET COUNT FROM BLOCK
;;#TR# BE MORE HONEST ON COMPUTING THIS
;	ADDI	A,2		; +2 FOR BLOCK TYPE & RELOC
	ADDI	A,=35		; CNT ← CNT+1+FLOOR((A+17)/18)
	IDIVI	A,=18
	HRRZ	B,@OUTADR	;WORD CNT AGAIN
	ADD	A,B		; CORRECT VALUE (I HOPE)

	TLZ	FF,IREGCT	;RESET NON-STANDARD COUNT BIT

;  OUTPUT ROUTINE

GBOUTA:	TLNN	FF,BINARY	;IS THERE A BINARY FILE?
	JRST	OUTDUN		;NO, DON'T WRITE
	CAIGE	A,3		;IS THERE ANYTHING TO WRITE?
	JRST	OUTDUN		;NO, DON'T DO IT

NOTENX <
BQN:	SOSLE	BINCNT		;FULL?
	JRST	OKOUT		;NO
	OUTPUT	BIN,0		;EMPTY BUFFER, ON TO NEXT
	TSTERR	BIN		;ERRORS?
	ERR	<OUTPUT ERROR ON BINARY FILE>

OKOUT:	ILDB	B,OUTADR	;BLOCK WORD
	IDPB	B,BINPNT
	SOJG	A,BQN		;WRITE THEM ALL
>;NOTENX
TENX <
	PUSH	P,C
	MOVNI	C,(A)
	MOVE	B,OUTADR
	SKIPL	A,BINJFN	;JUST IN CASE IT'S -1 (DUMMY)
	 JSYS	SOUT
	MOVEM	B,OUTADR	;UPDATE OUTADR
	POP	P,C
>;TENX

OUTDUN:	POP	P,B		;GET BUFFER ADDR BACK
	TLZN	FF,IREGCT	;DON-'T CLEAR IF NON-STANDARD COUNT
	HLLZS	(B)		;CLEAR COUNT
	POP	P,A		;RESTORE A
	POPJ	P,

COMMENT ⊗ CODOUT Routine -- Output Code or Data⊗

DSCR   CODOUT -- WRITE DATA    (ALSO CODREL)

PAR WORD IN "A"
  relocatable if RELOC in in "FF"
  (if rh of A is zero, then never RELOC. If you want to
		 TO BYPASS THIS TEST, CALL "CODREL").

RES Writes word, increments program counter (PCNT)

SID Uses A,B,C -- Saves all
⊗;

↑CODOUT:	
	SKIPE	NOEMIT		; GET OUT IF NO CODE IS TO BE EMITTED (I.E. 
	POPJ	P,		;  EXPR!TYPE)
	PUSH	P,A
	PUSH	P,B

	SKIPE	FRSTSW	;HAVE WE DONE THIS BEFORE
	 JRST	 COD1		; YES, DON'T DO AGAIN
	SETOM	FRSTSW
	PUSH	P,LPSA		;AND SOME OTHERS
	MOVEI	LPSA,IPROC	;GET PROGRAM NAME.
	PUSHJ	P,RAD50		;IN RADIX50
	TLZ	A,740000	;RADIX50 0,NAME
	MOVEM	A,PRGTTL
	MOVE	B,BEGCNT
	PUSHJ	P,GBOUT		;WRITE NAME BLOCK
REN <
	MOVEI	A,0
	SKIPN	HISW		;TWO-SEGMENT PROGRAM?
	 JRST	 JUST1		;NO
	MOVE	B,HBLK2		;YES, WRITE HISEG (TYPE 3) BLOCK
	PUSHJ	P,GBOUT
	MOVEI	A,400000	;BEGINNING PC
JUST1:
	MOVEM	A,BEGPC		;IN WHICH SEGMENT
>;REN
	MOVE	B,BEGCT2	;CALL TO INIT & LINKAGE
	PUSHJ	P,GBOUT
COD2:	POP	P,LPSA
	MOVE	A,-1(P)		;RESTORE A.

COD1:	TRNN	A,-1		;ZERO ADDRESS?
	TLZ	FF,RELOC	;YES, NO RELOC
	JRST	CDRL1
↑CODREL:
	PUSH	P,A		;ENTER HERE TO BYPASS ZERO TEST
	PUSH	P,B
CDRL1:
	HRRZ	B,BINTAB	;GET COUNT
	JUMPN	B,BAQ		;FIRST WORD OF BLOCK?

	AOS	BINTAB		;YES, SET UP BLOCK
	MOVE	B,PCNT		;SET LOCATION WORD
	MOVEM	B,BINTAB+2	;INTO 3D WORD OF BLOCK
	SETZM	BINTAB+1	;CLEAR RELOCATION BITS
	MOVE	B,[POINT 2,BINTAB+1] ;BYTE POINTER FOR RELOC BITS
	MOVEM	B,CODPNT	;TO RIGHT PLACE
	MOVEI	B,1		;RELOCATE THE LOC COUNTER WORD
	IDPB	B,CODPNT

BAQ:	AOS	B,BINTAB	;INCREMENT COUNT
	HRRZS	B		;AND MOVE TO B
	MOVEM	A,BINTAB+1(B)	;DEPOSIT WORD
	MOVEM	A,LSTWRD	;SAVE LAST WORD OUTPUT
	LDB	A,[POINT 1,FF,RLCPOS] ;RELOC?
	SKIPE	LHRELC		;RELOC LEFT HALF?
	ADDI	A,2		;SAY SO
	MOVEM	A,LSTRLC	;AND LAST RELOCATION BIT.
	IDPB	A,CODPNT	;SET RELOC BITS

	AOS	PCNT		;INCREMENT COUNT

	CAIGE	B,22		;FULL?
	JRST	CDRET		;NO, RETURN

	MOVEI	B,BINTAB	;INDICATE STANDARD COUNT AND WHICH TABLE
	PUSHJ	P,GBOUT		;WRITE BLOCK
;	JRST	CDRET

CDRET:	POP	P,B
	POP	P,A
	POPJ	P,

↑CODLRL:			;RELOCATE LEFT HALF -- FF SAYS ABOUT RIGHT HALF
	TLNE	A,-1		;NEVER RELOCATE 0
	SETOM	LHRELC 		;SET FLAG
	PUSHJ	P,CODOUT
	SETZM	LHRELC
	POPJ	P,

ZERODATA( DISPLAY STUFF)
LHRELC:	0
ENDDATA




DSCR FRBT
DES Force out current binary (BINTAB) code block,
  even if it's not full yet.  This is done whenever
  symbols or fixups which might refer to this code
  are put out, so that there is something to fixup
  or refer to symbolically.  It is also called from DONES.
SID Saves all ACS
⊗

↑FRBT:	PUSH	P,B
	MOVEI	B,BINTAB
	PUSHJ	P,GBOUT		;CLEAR BINARY BUFFER
	POP	P,B
	POPJ	P,


COMMENT ⊗ FBOUT, etc. -- Output Fixups⊗

DSCR  FBOUT,FIXOUT,FBOSWP
DES Put word of fixup information into output file.
PAR B contains fixup specification:
   lh -- PCNT of actual location of entity
   rh -- PCNT of last word in fixup chain.
 FBOSWP takes the above B value, swapped.
RES This word is written into the FXTAB fixup Loader
  block via GBOUT (when there are enough).
 FBOUT always assumes both halves reloatable
 FIXOUT always assumes the actual (lh) address is not
  relocatable
 FBOSWP is included for convenience
SID Saves all ACs
⊗;

↑FXOSW2: MOVSS 	B
	PUSHJ	P,FIXOUT
	MOVSS	B
	POPJ	P,
↑FBOSW2: MOVSS  B
	PUSHJ	P,FBOUT
	MOVSS	B
	POPJ	P,

↑FBOSWP: MOVSS	B
↑FBOUT:	SKIPE	NOEMIT		; GET OUT IF NO CODE IS TO BE EMITTED (I.E. 
	POPJ	P,		;  EXPR!TYPE)
	TLNN	B,-1		;IS LEFT HALF ZERO?
	ERR	<DRYROT -- FBOUT>,1
	TLOA	FF,FFTEMP	;USE RELOCATION IN FIXUP SIDE
↑FIXOUT:
	TLZ	FF,FFTEMP	;DO NOT RELOCATE FIXUP PART
	PUSH	P,B
	PUSH	P,A		;SAVE A
	HRRZ	A,FXTAB
	JUMPN	A,FAQ		;FIRST WORD OF BLOCK?
	MOVE	A,[POINT 2,FXTAB+1] ;YES, RESET RELOCATION BIT POINTER
	MOVEM	A,FXPNT		; (SEE CODOUT FOR SIMILARITIES)
FAQ:
	AOS	A,FXTAB		;INCREMENT AND FETCH COUNT
	HRRZS	A
	MOVEM	B,FXTAB+1(A)	;DEPOSIT WORD
	MOVEI	B,3		;ASSUME BOTH HALVES RELOC
	TLNN	FF,FFTEMP	;TEST ASSUMPTION
	 MOVEI	 B,2		; WRONG
	IDPB	B,FXPNT		;INSERT RELOCATION BITS

	CAIGE	A,22		;FULL?
	JRST	FXRET		;NO, RETURN

	PUSHJ	P,FRBT		;FORCE OUT ANY BINARY
				;(BECAUSE FIXUPS HAVE TO COME AFTER)

	MOVEI	B,FXTAB	
	PUSHJ	P,GBOUT		;WRITE BLOCK

FXRET:	POP	P,A
	POP	P,B
	POPJ	P,



COMMENT ⊗ SCOUT, etc. -- Output Symbols⊗

DSCR SOUT,SCOUT,SHOUT,SCOUT0
DES Output symbols in RADIX50 -- many ways exist for
  obtaining symbols for output, thus the proliferation.

PAR
SOUT:	LPSA -- Semantics ptr. $PNAME and $ADR  are used to
	obtain the symbol and address.
SHOUT:	LPSA -- descriptor of the form:
	 bits 0-5  DDT symbol type
	      6-17  #characters
	     18-35  address of string in ASCII (assumed justified)
	B -- address for symbol
SCOUT:	A -- RADIX50 for symbol
	B -- address for symbol
SCOUT0:  SAME AS SCOUT, BUT MAKES SYMBOL NON-RELOCATABLE.

SID A, TEMP, may be different on exit
⊗;

↑SHOUT:	PUSHJ	P,RAD52
	JRST	SCOUT		;MAKE RADIX50 FROM DESCRIPTOR

↑SCOUT0: PUSH	P,B		;NON-RELOCATED SYMBOL
	MOVEI	TEMP,0
	JRST	SASS


↑SOUT:	PUSHJ	P,RAD50		;GET RADIX50 FOR SYMBOL
	PUSH	P,B		;SAVE IT
;;# # RHT 3-19-73 MAKE RECSV SYMBOLS GO OUT UNRELOC
	HRRZ	B,$ADR(LPSA)	;GET ADDRESS
	MOVE	TEMP,$SBITS(LPSA);DOES THIS SYMBOL USE THE STACK?
	TRNN	TEMP,DLFLDM	;
	JRST	SOUT.0		;NO
	CAIGE	B,20		;HALF KILL??
	TLO	A,400000	;YES
	MOVEI	TEMP,0		;
	JRST	SASS
;;# # RHT

;;# # RHT -- 7-13-73 EXTRA KLUGE TO USE THE RAD5$ SYMBOL FOR
;;			SPECIAL BILTIN RUNTIMES
SOUT.0:	SETCM	TEMP,$TBITS(LPSA)
	TLNE	TEMP,FNYNAM+OWN+EXTRNL
	JRST	SOUT.1		;REGULAR
	SKIPA	A,RAD5$		;PREMIUM
;;# #
↑SCOUT:	PUSH	P,B		;SAVE
SOUT.1:	MOVEI	TEMP,1		;RELOCATION BIT.
SASS:	PUSH	P,C
	HRRZ	C,SMTAB
	JUMPN	C,SAQ
	MOVE	C,[POINT 4,SMTAB+1]
	MOVEM	C,SMPNT
SAQ:
	CAMN	A,LSTRAD	;RADIX50 FOR LAST BLOCK NAME.
	JRST	SYMRET		;DO NOT PUT IT OUT.
	AOS	C,SMTAB		;BINARY DOES NOT HAVE TO BE
	HRRZS	B		;FORCED OUT
	MOVEM	A,SMTAB+1(C)
	MOVEM	B,SMTAB+2(C)
	AOS	C,SMTAB
	HRRZS	C
	LDB	B,[POINT 4,A,3]	;DON'T RELOCATE BLOCK LEVELS
	CAIN	B,3		;BLOCK TYPE 14
	MOVEI	TEMP,0
	IDPB	TEMP,SMPNT
	CAIGE	C,22
	JRST	SYMRET

	PUSHJ	P,FRBT		;MAKE BINARY GO FIRST
	MOVEI	B,SMTAB
	PUSHJ	P,GBOUT

SYMRET:	POP	P,C
	POP	P,B
	POPJ	P,

COMMENT ⊗ LNKOUT -- Output Linkage Block⊗

DSCR LNKOUT -- 
DES Put out a (type 12) Link block via GBOUT. These blocks
  allow chains of addresses to be created through separate
  .REL files. STRINGC uses LINK 1 to find all its strings.
 Other uses are for SETS, STRINGC routine names, and the
  space allocation block.
PAR B -- link number
 PCNT -- decremented by one; that is address for LINK rqst.
⊗

↑LNKOUT: MOVEM	B,LNKNM		;SAVE LINK NUMBER
	PUSHJ 	P,FRBT		;NOTE DOES NOT SAVE ACS
	HRRZ	TEMP,PCNT
	SUBI	TEMP,1		;LAST WORD OUTPUT WILL HOLD LINK
	HRRZM	TEMP,SLNKWD	;PLACE IN ADDR WORD OF LINK BLOCK TEMPLATE
	MOVE	B,SDSCRP	;DESCRIPTOR OF LINK BLOCK [COUNT,ADDR OF TEMPLATE]
	PUSHJ	P,GBOUT
	POPJ	P,		;RETURN AFTER WRITING BLOCK

COMMENT ⊗ PRGOUT, FILSCN -- Output Request Blocks, Scan for Source!file Rqst⊗

DSCR FILSCN -- CONVERT ASCII FILE-STRING TO SIXBIT
PAR PNAME, PNAME+1 describe a String representing the file
  name.
RES A, C, D return DEVICE, FILENAME, and PPN in SIXBIT
DES Converts String to SIXBIT via FILNAM routine (approp-
  riately informed) in Command Scanner (SAIL). Extension
  not returned, because there's currenlty no need.
SID Nothing much saved
SEE FILNAM, PRGOUT, RQSET, SRCSWT
⊗
NOTENX <
↑↑FILSCN: SETOM	TYICORE		;TYI IN COMND WILL GET CHARS FRM STRNG
	PUSH	P,DEVICE	;SAVE FILE DATA
	PUSH	P,EXTEN	
	PUSH	P,SAVTYI
	PUSH	P,EOL
	SETZM	SAVTYI		;NO SCAN-AHEAD
	MOVSI	TEMP,(<SIXBIT /DSK/>) ;DEFAULT DEVICE
	MOVEM	TEMP,DEVICE
	PUSHJ	P,FILNAM	;GET SIXBITS IN NAME, EXTEN, ETC.
	MOVE	A,DEVICE	;LOAD RESULTS
	MOVE	C,NAME
	MOVE	D,PPN
	POP	P,EOL
	POP	P,SAVTYI
	POP	P,EXTEN
	POP	P,DEVICE	;RESTORE OLD VALUES
	POPJ	P,
>;NOTENX

TENX <
TFLSCN:
	BEGIN TFLSCN

CTRLV←←"V"-100			;TENEX QUOTING CHARACTER
FIND←←D

	SETZM	FIND
	PUSH	SP,PNAME	;ORIGINAL NAME -- COPY ONTO STACK
	PUSH	SP,PNAME+1
	PUSH	SP,[0]		;DEVICE TEMPORARY
	PUSH	SP,[0]
	PUSH	SP,[0]		;DIR TEMPORARY
	PUSH	SP,[0]
	PUSH	SP,[0]		;NAM TEMPORARY
	PUSH	SP,[0]	

DEFINE ORIG <-7(SP)>
DEFINE ORIG1 <-6(SP)>
DEFINE DEV <-5(SP)>
DEFINE DEV1 <-4(SP)>
DEFINE DIR <-3(SP)>
DEFINE DIR1 <-2(SP)>
DEFINE NAM <-1(SP)>
DEFINE NAM1 <0(SP)>

;SIMPLE SINCE NAME IS AT THE TOP OF SP
DEFINE CATNAM (X) <
	PUSH	P,X
	PUSHJ	P,CATCHR
>
DEFINE CATDIR (X) <
	PUSH	P,X
	PUSH	SP,DIR
	PUSH	SP,DIR
	PUSHJ	P,CATCHR
	POP	SP,-4(SP)
	POP	SP,-4(SP)
>

DEFINE GCH <
	HRRZ	A,ORIG
	JUMPE	A,TENDUN
	ILDB	C,ORIG1
	SOS	ORIG
>

TENX1:	GCH
	CAIE	C,CTRLV
	  JRST	NOQUOTE
	SKIPE	FIND
	  JRST	QUODIR
	PUSHJ	P,CATNA3
	GCH	
	PUSHJ	P,CATNA3 		;AND THE CHAR FOLLOWING THE CTRLV	
	JRST	TENX1
QUODIR:	PUSHJ	P,CATDI3
	GCH
	PUSHJ	P,CATDI3
	JRST	TENX1			;AND CONTINUE

NOQUOTE:
	CAIN	C,":"			;COLON -- DEVICE
	   JRST	ISDEV			;ITS BEEN A DEVICE ALL ALONG!!
	CAIN	C,","
	   JRST	TENX1			;IGNORE COMMA
	CAIE	C,40			;SPACE
	CAIN	C,11			;OR TAB
	   JRST	TENX1
	CAIE	C,"<"			;THESE START THE DIRECTORY NAME
	CAIN	C,"["
	   JRST	 STTDIR
	CAIE	C,">"			;THESE FINISH THE DIR. NAME
	CAIN	C,"]"
	   JRST	ENDDIR
	SKIPE	FIND			;DOING DIRECTORY?
	   JRST	.+3			;YES
	PUSHJ	P,CATNA3
	JRST	TENX1
	PUSHJ	P,CATDI3
	JRST	TENX1

STTDIR:	SETOM	FIND
	JRST	TENX1

ENDDIR:	SETZM	FIND
	JRST	TENX1

;;#SK# 5-30-74 RLS DONT MESS UP DEVICE NAME IF PRESENT
ISDEV:
	MOVE	C,NAM			;THE "NAME" HAS REALLY BEEN A DEV
	MOVEM	C,DEV
	MOVE	C,NAM1
	MOVEM	C,DEV1			
	
	SETZM	NAM			;SO CLEAR THE NAME -- START OVER
	SETZM	NAM1
	JRST	TENX1

TENDUN:	
;NOW STACK HAS ORIG,DEV,DIR,NAM
GOTDIR: 
;NOW FIND ONLY THE NAME -- IGNORE EXTENSION, VERSION, ETC.
	PUSH	SP,[0]			;NEW TEMPORARY
	PUSH	SP,[0]
NAMLUP:	HRRZ	A,-3(SP)
	SOS	-3(SP)			;DECREMENT
	JUMPE	A,GOTDI1
	ILDB	C,-2(SP)
	CAIE	C,"."			;QUIT ON PERIOD
	CAIN	C,";"			;OR SEMICOLON
	JRST	GOTDI1
	PUSH	P,C
	PUSHJ	P,CATCHR
	JRST	NAMLUP
GOTDI1:	POP	SP,-2(SP)		;REMOVE TEMPORARY
	POP	SP,-2(SP)	
	HRRZ	A,-1(SP)		;CHECK LENGTH OF NAME
	CAILE	A,6	
	   ERR <Name too long for loader.>,1
	PUSHJ	P,CVSIX			;GET SIXBIT FOR NAME
	MOVEM	A,C			;INTO C
IFN SIXSW,<
	HRRZ	A,-1(SP)
	CAILE	A,6
	   ERR <Directory too long for loader.>,1
	PUSHJ	P,CVSIX			;SIXBIT FOR DIR
	MOVEM	A,D			;INTO D
>;SIXSW
IFE SIXSW,<;DAMN -- PHONEY BBN PPNS INSTEAD OF NICE HONEST SIXBIT
	HRRZ	A,-1(SP)		;LENGTH
	JUMPE	A,[SETZ	D,		;ASSUME CONNECTED DIR
		   SUB	SP,X22
		   JRST	DIRDUN]
	PUSH	P,B			;SAVE B
	PUSH	P,[0]
	PUSHJ	P,CATCHR		;NULL BYTE TO END OF STRING
	POP	SP,B			;FOR STDIR	
	SUB	SP,X11			;ADJUST
	MOVEI	A,1			;POSITIVE -- NO RECOGNIZE
	JSYS	STDIR
	  JFCL
	  JRST [ERR <This directory does not exist on this system.>,1
		SETZ	D,
		JRST .+2		;AND CLEANUP
	       ]
	HRRZM	A,D			;XWD 0,DIRNO INTO D
	POP	P,B
DIRDUN:
>;IFE SIXSW
	HRRZ	A,-1(SP)
	CAILE	A,6
	  ERR <Device name too long for loader.>,1
	PUSHJ	P,CVSIX			;SIXBIT FOR DEVICE INTO A
	SKIPN	A			;ANYTHING THERE?
	  MOVE	A,[SIXBIT/DSK/]		;ASSUME DEVICE DSK
	SUB	SP,X22			;CLEAR OFF COPY OF PNAME
	POPJ	P,
	
;CALL CAT MACROS WITH AC C AS THE ARG
CATNA3:	CATNAM C
	POPJ	P,

CATDI3:	CATDIR C
	POPJ	P,


	BEND TFLSCN
>;TENX



DSCR PRGOUT -- OUTPUT PROGRAM AND LIBRARY REQUEST BLOCKS
DES Output (via GBOUT) Program and Libraray REQUEST BLOCKS.
PAR B ptr to  PRGTAB or LBTAB (program or library request)
 PNAME, PNAME+1 as in FILSCN
 Defaults as in FILSCN; DEVICE, FILE and PPN will be passed
  to the loader.
RES FILSCN is called to make SIXBIT representations of DEVICE,
  FILE, and PPN; these are placed in the output block.
SID Saves the world
⊗;

↑↑PRGOUT: 
NOTENX<
	MOVE	USER,GOGTAB		;SAVE ACS IN USER TABLE AREA
	HRRZI	TEMP,RACS(USER)
	BLT	TEMP,SBITS2+RACS(USER)		;FILNAME USES MANY ACS
	PUSHJ	P,FILSCN		;GET SIXBITS IN A,C,D
	MOVE	B,RACS+2(USER)		;GET TABLE ADDRESS BACK
	MOVEI	TEMP,3			;PREPARE TO COUNT UP BLOCK COUNT
	ADDB	TEMP,(B)
	ADDI	TEMP,(B)		;ptr to AREAS TO BE FILLED
	MOVEM	C,-1(TEMP)		;STORE NAME
;;=I10=	SFD PATCH - BE SURE WE HAVE A REAL PPN
SFDS<
	JUMPE	D,.+3			;ZERO PPN IS OK
	TLNN	D,777777		;SO IS A REAL PPN
;;JOHN - POSSIBLE YOU WANT TO ISSUE AN ERROR MESSAGE HERE INSTEAD
	MOVE	D,2(D)			;IF PATH PTR, USE PPN FROM PATH
> ;SFDS
	MOVEM	D,00(TEMP)		;STORE PPN
	MOVEM	A,01(TEMP)		;STORE DEVICE
TYMSHR<
	JUMPE D,PRGOU2		;IF NO PPN
	TLNN D,-1		;OR IF REAL PPN
	CAME A,[SIXBIT /DSK/]	;OR NOT DISK
	JRST PRGOU2
	MOVE C,AVLSRC
	JFFO C,.+2
	JRST PRGOU2
	CAILE D,17
	JRST PRGOU2		;FIND CHANNEL
	PUSH P,B
	MOVSI A,(<RELEASE>)
	DPB D,[POINT 4,A,12]
	PUSH P,A
	MOVE A,[LOOKUP A]
	DPB D,[POINT 4,A,12]
	PUSH P,A
	MOVE A,[OPEN B]
	DPB D,[POINT 4,A,12]
	MOVEI B,16
	MOVSI C,'DSK'
	MOVEI D,0
	XCT A
	JRST PRGOU3
	MOVEI A,3	;NOW LOOKUP
	MOVE B,(TEMP)
	MOVE C,-1(TEMP)
	MOVEI D,0
	XCT (P)
	JFCL
	MOVEM B,(TEMP)	;SAVE PPN
PRGOU3:	POP P,A
	POP P,A		;THE RELEASE
	XCT A
	POP P,B
PRGOU2:>
     
>;NOTENX
TENX<
	PUSH	P,A			;MUST PUSH SINCE TFLSCN CALLS RUNTIMES
	PUSH	P,C
	PUSH	P,D
	EXCH	SP,STPSAV		;GET A STRING STACK
	PUSHJ	P,TFLSCN		;DOES NOT MODIFY B
	EXCH	SP,STPSAV		;RESTORE IT
	MOVEI	TEMP,3			
	ADDB	TEMP,(B)
	ADDI	TEMP,(B)		;ptr to AREAS to be filled
	MOVEM	C,-1(TEMP)		;STORE NAME
	MOVEM	D,00(TEMP)		;STORE PPN
	MOVEM	A,01(TEMP)		;STORE DEVICE
	POP	P,D
	POP	P,C
	POP	P,A			;RESTORE
	PUSH	P,TEMP
	MOVE	USER,GOGTAB		;SAVE FOR KROCK BELOW
	HRRZI	TEMP,RACS(USER)	
	BLT	TEMP,SBITS2+RACS(USER)	
	POP	P,TEMP
>;TENX
	HRRZS	TEMP
	CAIL	TEMP,22(B)		;BLOCK FULL?
	PUSHJ	P,GBOUT			;YES, PUT IT OUT
	HRLZI	TEMP,RACS(USER)
	BLT	TEMP,SBITS2
	POPJ	P,			;TRA 0,4?

SUBTTL	Generator Miscellaneous.

COMMENT ⊗  RAD50, RAD52 -- Radix-50 Functions for Scout Routines⊗

DSCR RAD50,RAD52 -- create a RADIX50 symbol
PAR RAD50 -- LPSA pntr to  block head -- string is in $PNAME, etc.
 RAD52 -- LPSA(lh) is count, LPSA (rh) is address of string,
 assumed aligned.
RES RADIX50 for symbol in A
SID Results in A, all other ACS saved (except TEMP)
⊗;

↑RAD50:	
	EXCH	SP,STPSAV
	MOVSS	POVTAB+6	;ENABLE FOR STRING PDL OV
	PUSH	SP,$PNAME(LPSA)	;COLLECT POINTERS IN COMMON SPOT
	PUSH	SP,$PNAME+1(LPSA)
	HRRZS	-1(SP)		;CLEAR STRNO, SAVE COUNT
	MOVE	A,$TBITS(LPSA)	;CONTROLS MODE BITS IN RAD50 SYMBOL
	MOVEI	TEMP,10/4		;ASSUME LOCAL
	TLNE	A,INTRNL	;INTERNAL IS TYPE 4
	MOVEI	TEMP,4/4
	TLNE	A,EXTRNL
	MOVEI	TEMP,60/4		;EXTERNAL IS TYPE 60
	MOVEI	A,0		;INITIALIZE A
	JRST	RAD5


↑RAD52:
	LDB	TEMP,[POINT 12,LPSA,17] ;COUNT
	EXCH	SP,STPSAV
	MOVSS	POVTAB+6	;ENABLE FOR STRING PDLOV
	PUSH	SP,TEMP
	PUSH	SP,LPSA		;MAKE IT LOOK LIKE STRING 
	HRRI	TEMP,(<POINT 7,0>) ; DESCRIPTOR
	HRLM	TEMP,(SP)
	MOVEI	A,0
	LDB	TEMP,[POINT 4,LPSA,3]

RAD5:	PUSH	P,TEMP
	PUSH	P,B		;SAVE IT
	MOVEI	TEMP,6

R50LUP: SOSGE	-1(SP)		;QUIT IF NO MORE STRING
	 JRST	 R5OUT
	ILDB	B,(SP)		;CHARACTER
	CAIN	B," "		;IGNORE BLANKS ABSOLUTELY!
	 JRST	 R50LUP		; THIS RUNS ALL THE CHARACTERS TOGETHER
	CAIL	B,"a"
	CAILE	B,"z"
	JRST	.+2
	SUBI	B,40		;CONVERT TO UPPER CASE
	CAIE	B,30		;UNDERLINE:THESE CHARS HAVE TO BE CREATED INDIVIDUALLY
	CAIN	B,"."
	MOVEI	B,66+45		;RAD50 CHAR FOR "." + 66 TO BE SUBTRACTED
;;#GQ# DCS 2-8-72 (1-1) ! SAME AS  UNDERLINE
	CAIN	B,"!"		;! SAME AS UNDERLINE
	MOVEI	B,66+45		;"."
;;#GQ# (1)
	CAIN	B,"$"
	MOVEI	B,66+46
	CAIN	B,"%"
	MOVEI	B,66+47
	SUBI	B,66		;OK IF A LETTER
	CAIG	B,12		;<12 IF A NUMBER
	ADDI	B,7		; THIS MAKES IT RIGHT
	IMULI	A,50		;THAT'S THE NUMBER ALL RIGHT
	ADD	A,B		;COLLECT RADIX50
	SOJN	TEMP,R50LUP	;QUIT AT 6

R5OUT:	MOVEM	A,RAD5.		;NOW CREATE SAME SYMBOL WITH
	JUMPLE	TEMP,MORFIV	;MORE THAN FIVE CHARS?
	IMULI	A,50		;MAKE IT "SYMB".
	SKIPA
MORFIV:	SUB	A,B		;"." IN PLACE OF THE LAST
	POP	P,B		;RESTORE B
	POP	P,TEMP		;TYPE BITS.
	DPB	TEMP,[POINT 4,A,3] ;TYPE BITS TO RADIX 50
	ADDI	A,46		;$
	MOVEM	A,RAD5$
	ADDI	A,1		;%
	MOVEM	A,RAD5%		;
	SUBI	A,2		;"."
	EXCH	A,RAD5.		; AND STORE IT IN RAD5. FOR STRINGS
	DPB	TEMP,[POINT 4,A,3] ;TYPE BITS TO RADIX 50
	SUB	SP,X22
	EXCH	SP,STPSAV	;RESTORE REGS
	MOVSS	POVTAB+6	;RE-ENABLE FOR PARSE PDLOV
	POPJ	P,

BEND	TOTAL
IFN FTDEBUG, <↑INNA←INNA>