perm filename TOTAL[S,AIL]53 blob sn#350250 filedate 1978-04-27 generic text, type T, neo UTF8
00100	COMMENT ⊗   VALID 00052 PAGES
00200	C REC  PAGE   DESCRIPTION
00300	C00001 00001
00400	C00005 00002	HISTORY
00500	C00013 00003	DATA for Total (Low-level Code Production) Routines
00600	C00016 00004	Description of Total Routines
00700	C00026 00005	CONV, PRE, POST -- Type-Conversion routines
00800	C00032 00006
00900	C00036 00007	  
01000	C00043 00008
01100	C00045 00009	PUT
01200	C00049 00010	ACCESS,GETSDR,GETDR,DISBLK,ZOTDIS--last four  only for dis
01300	C00059 00011	GET
01400	C00066 00012
01500	C00069 00013
01600	C00073 00014
01700	C00079 00015	STACK -- Issue Instrs. to Stack Anything on Approp. Stack
01800	C00084 00016	MARK, MARKINT, MARKME -- Mark Semblk with Correct Temp Semantics
01900	C00088 00017	INCOR -- Issue Code to Clear this Entity from ACs
02000	C00089 00018	REMOPs, CLEARs -- Remove Temps, ACs, from Use
02100	C00101 00019	DSCR CLEAR,CLEARL,CLEARA
02200	C00104 00020	STROP -- Bit-Driven String Operation Code Generator
02300	C00111 00021	GETTEM, etc. -- Temp Semblk Allocators
02400	C00115 00022	GETAC, GETAN0 -- AC Allocators
02500	C00121 00023	AC Store routines -- BOLSTO, FORSTO, STORIX, GOSTO, STORZ
02600	C00126 00024	 STORA -- main AC-storing subr. -- called by above
02700	C00133 00025	EMITER -- Descriptions of Routine and Control Bits
02800	C00136 00026	 EMITER Routine
02900	C00140 00027
03000	C00146 00028		SUBI	TEMP,1		FIX IT
03100	C00152 00029
03200	C00155 00030	Qstack Routines -- BPUSH, etc.
03300	C00159 00031
03400	C00162 00032
03500	C00165 00033	PWR2
03600	C00166 00034	GBOUT Description, Loader Block Format Description
03700	C00169 00035	 Control Variables for Loader Block Output
03800	C00172 00036	 Loader Output Blocks-- Entry, Program Name, Initial Stuff
03900	C00176 00037	                        Code, Boolean Code, Fixups, Links
04000	C00180 00038	                        Space Allocation Block
04100	C00184 00039	                        Request Blocks -- RELfile, Libraries
04200	C00186 00040	                        Ending Code, Symbols -- END Block
04300	C00190 00041	 RELINI -- Loader Block Initialization
04400	C00191 00042	 GBOUT Routine
04500	C00194 00043	 CODOUT Routine -- Output Code or Data
04600	C00198 00044
04700	C00199 00045	 FBOUT, etc. -- Output Fixups
04800	C00202 00046	 SCOUT, etc. -- Output Symbols
04900	C00206 00047	 LNKOUT -- Output Linkage Block
05000	C00208 00048	 PRGOUT, FILSCN -- Output Request Blocks, Scan for Source!file Rqst
05100	C00218 00049
05200	C00221 00050	>NOTENX
05300	C00223 00051	  RAD50, RAD52 -- Radix-50 Functions for Scout Routines
05400	C00227 00052
05500	C00228 ENDMK
05600	C⊗;
     

00100	COMMENT ⊗HISTORY
00200	AUTHOR,REASON
00300	021  102100000044  ⊗;
00400	
00500	
00600	COMMENT ⊗
00700	VERSION 17-1(36) 3-7-75 BY RHT BUG #UE# STRING ARRAY ISNT A STRING
00800	VERSION 17-1(35) 2-16-75 BY JFR BAIL P.35 DEFINE RESIDENCE OF RUNTIME PROCEDURE DESCRIPTORS
00900	VERSION 17-1(34) 12-7-74 BY JFR DEFINE RESIDENCE OF  BAIL  LOADMODULE
01000	VERSION 17-1(33) 11-3-74 BY RHT BUG TR MAKE GBOUT HONEST ABOUT WORD COUNT
01100	VERSION 17-1(32) 10-10-74 BY RHT FEAT %BR% (REMOVE HACKS)
01200	VERSION 17-1(31) 7-24-74 BY RHT BUG #SV# GET SPAC OF RECORD WAS LOSING
01300	VERSION 17-1(30) 7-22-74 BY RHT BUG #SU# CONV(ARITH) FOR PNTVAR
01400	VERSION 17-1(29) 7-7-74 BY RHT  MANY EDITS FOR RECGC
01500	VERSION 17-1(28) 7-7-74 
01600	VERSION 17-1(27) 7-7-74 
01700	VERSION 17-1(26) 7-7-74 
01800	VERSION 17-1(25) 5-30-74 BY RLS TENEX BUG #SK# DONT MESS UP DEVICE NAME FOR LOAD!MODULE
01900	VERSION 17-1(24) 5-20-74 BY RHT BUG #SA# SHOULD NOT BUMP REF CNT ON GET ADDR
02000	VERSION 17-1(23) 5-14-74 BY RHT BUG #RY# RECUUO (AC) S/B RECUUO 0,AC
02100	VERSION 17-1(22) 4-18-74 
02200	VERSION 17-1(21) 4-12-74 BY RHT %BI% MAKE EMITTER KNOW ABOUT RECORD CLASSES
02300	VERSION 17-1(20) 4-12-74 BY RHT %BI% ADD SOME LOW LEVEL RECORD STUFF
02400	VERSION 17-1(19) 4-12-74 
02500	VERSION 17-1(18) 4-12-74 
02600	VERSION 17-1(17) 4-12-74 
02700	VERSION 17-1(16) 4-12-74 
02800	VERSION 17-1(15) 4-12-74 
02900	VERSION 17-1(14) 4-6-74 BY RLS TENEX
03000	VERSION 17-1(13) 3-17-74 BY RLS TENEX ADDITIONS
03100	VERSION 17-1(13) 2-13-74 BY JRL BUG #RE# STRING ITEMVAR ARRAY NOT STRING ARRAY
03200	VERSION 17-1(12) 1-11-74 BY JRL CMU CHANGE COMVER (UNDER NOHACK)
03300	VERSION 17-1(11) 12-8-73 BY JRL REMOVE SPECIAL STANFORD CHARACTERS(WHERE POSSIBLE)
03400	VERSION 17-1(10) 11-24-73 BY RHT %AL% TAKE HRLOI 12, OUT OF S. SEQUENCE
03500	VERSION 17-1(9) 11-24-73 BY RFS RADIX50 TYPE BITS NOT INSTALLED IN RAD5$, RAD5%
03600	VERSION 17-1(8) 11-13-73 BY JRL FORCE PUT TO ALWAYS DO AN ACCESS
03700	VERSION 17-1(7) 11-13-73 BY JRL BUG #PA# GET ADDR OF MPPARM WAS DESTROYING AC C
03800	VERSION 17-1(6) 11-13-73 BY JRL BUG #OZ# FIX GET FOR INSISTED ITEMVARS
03900	VERSION 17-1(5) 11-4-73 BY JRL BUG #OX# LET PUT KNOW ABOUT ? ITEMVARS
04000	VERSION 17-1(4) 10-26-73 BY  JRL BUG #OR# A STRING ITEM IS NOT A STRING
04100	VERSION 17-1(3) 10-23-73 BY JRL FEATURE %AG& ITEM OVERLAP STUFF
04200	VERSION 17-1(2) 8-16-73 BY JRL REMOVE REFERENCES TO LEAPSW
04300	VERSION 17-1(1) 8-2-73 BY JRL BUG #NK# TEMPS SHOULD NOT HAVE DISPLAY LEVELS
04400	VERSION 17-1(0) 7-26-73 BY RHT **** VERSION IS 17 ****
04500	VERSION 16-2(31) 7-13-73 BY RHT MODIFY SOUT FOR FNYNAM
04600	VERSION 16-2(30) 7-13-73 BY RHT BUG #MN# A DREADFUL KLUGE TO FIX ACCESS BUG
04700	VERSION 16-2(29) 7-13-73 
04800	VERSION 16-2(28) 6-28-73 BY JRL BUG #KA#B IMMEDIATE INSTRUCTIONS NOT USED FOR OR,AND
04900	VERSION 16-2(27) 3-19-73 BY RHT CHANGE SOUT SO STACK SYMBOLS WORK RIGHT
05000	VERSION 16-2(26) 3-13-73 BY JRL REMOVE REFERENCES TO WOM,SLS,GAG,NODIS
05100	VERSION 16-2(25) 2-26-73 BY JRL DO A SKIPE NOEMIT IN XCALLQ
05200	VERSION 16-2(24) 2-6-73 BY JRL MAKE GET HONEST FOR QPARS
05300	VERSION 16-2(23) 1-31-73 BY HJS DISABLE CODOUT, EMITER, AND FBOUT FOR EXPR!TYPE
05400	VERSION 16-2(22) 12-13-72 BY JRL BUG #KS# ADD LOADVR SWITCH
05500	VERSION 16-2(21) 12-13-72 
05600	VERSION 16-2(20) 11-30-72 BY JRL MAKE GET HONEST FOR ? ITEMVARS
05700	VERSION 16-2(19) 11-30-72 BY JRL BUG #KQ# IGNORE FIXARRS IN STORA
05800	VERSION 16-2(18) 11-21-72 BY RHT BUG #KH# DEL FORMFX STUFF FROM SIMPROC FORMALS
05900	VERSION 16-2(17) 10-17-72 BY JRL BUG #JR# STRING ITEMVARS NOT STRING
06000	VERSION 16-2(16) 8-29-72 BY KVL ADD CKECK FOR UNTYPED IN PRE
06100	VERSION 16-2(15) 7-17-72 BY RHT BUG #IO# EVAR MESSED UP BY INDEXED STRING TEMP
06200	VERSION 16-2(14) 7-8-72 BY RHT BUG ##I#L# GET ACCESS TO A VARIABLE IN PRE BEFORE INSISTING
06300	VERSION 16-2(13) 6-30-72 BY DCS BUG #IA# PROTECT PTRAC AC OVER FIX, FLOAT, STRING to INTEGER
06400	VERSION 16-2(12) 6-25-72 BY DCS BUG #HX# PARAMETERIZE LIBRARY NAMES (OTHER THINGS)
06500	VERSION 16-2(11) 6-20-72 BY DCS BUG #HU# BETTER TTY PRINTOUT
06600	VERSION 16-2(10) 6-14-72 BY JRL BUG #HS# AN ITEMVAR IS NOT ITS DATUM(MARK).
06700	VERSION 16-2(9) 5-13-72 BY DCS BUG #HF# MAKE GETAC MUCH MORE HONEST
06800	VERSION 15-2(8) 3-25-72 BY DCS BAD ARRAY ADDRESS PROBLEM
06900	VERSION 15-2(7) 3-10-72 BY DCS REPLACE RING, ULINK MACROS WITH ROUTINES
07000	VERSION 15-2(6) 2-9-72 BY DCS BUG #GQ# MAKE ! = UNDERLINE IN RADIX50
07100	VERSION 15-2(5) 2-5-72 BY DCS BUG #GJ# ADD LSTON LISTING CONTROL STUFF
07200	VERSION 15-2(4) 2-1-72 BY DCS ISSUE %ALLOC SPACE REQUESTS IN NEW WAY (SEE GOGOL FOR FORMAT)
07300	VERSION 15-2(3) 1-10-72 BY DCS BUG #FP# FIX A NEGAT BUG
07400	VERSION 15-2(2) 1-7-72 BY DCS BUG #FY# Fix Strvar←INAC-Intvar bookkeeping problem
07500	VERSION 15-2(1) 12-2-71 BY DCS INSTALL VERSION NUMBER
07600	
07700	⊗;
07800	
     

00100	COMMENT ⊗DATA for Total (Low-level Code Production) Routines⊗
00200		LSTON	(TOTAL)
00300	
00400	SUBTTL	WIZARD'S DEN -- Generator Called Routines.
00500	BEGIN	TOTAL
00600	
00700	ZERODATA (TOTAL ROUTINE VARIABLES)
00800	
00900	;ACKPNT -- next AC # GETAC should try -- used to distribute
01000	;    AC usages among the ACs -- used by GETAC only
01100	?ACKPNT: 0
01200	
01300	COMMENT ⊗
01400	FORMFX -- QSTACK descriptor for formal fixups.  Until a recursive
01500	    Procedure has been completely compiled, it is not known how
01600	    many local strings and non-strings will be saved in the runtime
01700	    stacks between the stack tops and the formal parameters.  Therefore
01800	    as instructions accessing parameters are issued, the address
01900	    field displacements (assuming 0 locals) are saved, along with
02000	    the addresses where they are issued, in the FORMFX stack.
02100	    The left half of each entry is the address of the instruction--
02200	    the right half is the desired relative displacement (high-order
02300	    bit specifies String stack or System stack).  After the procedure
02400	    is compiled, these entries are QPOPed off and used, along with
02500	    the ALOCALS, SLOCALS counts (see PROCED variables) to issue
02600	    fixups for these instructions.  This Qstack is not used
02700	    for non-recursive Procedures
02800	⊗
02900	↑↑FORMFX: 0
03000	
03100	?POSSIB: 0	;TEMP USED BY GETAC WHEN GETTING 2 
03200	
03300	;TEMPNO -- each temp Semblk allocated is assigned a unique
03400	;    number, by incrementing TEMPNO -- a temp Semblk may
03500	;    be used several times in the same procedure.  See GETTEM
03600	;    for description of the mysteries of temps.
03700	?TEMPNO: 0
03800	
03900	ENDDATA
04000	
     

00100	COMMENT ⊗Description of Total Routines⊗
00200	
00300	DSCR CONV,ACCESS,GET,PUT,STACK,MARK
00400	DES This is the generalized move code. (i.e. called by macro GENMOV).
00500	 It consists of several routines which are called in a uniform
00600	 fashion.  This fashion stipulates that "directive" bits be passed
00700	 in the right half of FF which specify modifiers on the operation
00800	 of the routine called.  Each routine is preceded by a standard
00900	 preamble (PRE) and followed by a standard epilog (POST).
01000	
01100	 Some of the directive bits control PRE and POST.  They are:
01200	
01300	PAR 
01400	PRE:
01500	1.	If the GETD bit is on, we do a GETAD first (i.e. use PNT
01600		as the pointer to a symbol table entry, and fill TBITS
01700		and SBITS. This is useful since many of the GENMOV routines
01800		require that TBITS and SBITS be set up.
01900	2.	If the PROTECT bit is set, then register D is assumed to have
02000		an accumulator number in it.  That accumulator table entry
02100		is "protected". I.e. calls on GETAC and STORA will not affect
02200		the status of anything marked in that accumulator.
02300	3.	If the EXCHIN bit is set, we do an EXCHOP.
02400	4.	If the INSIST bit is on, type conversions are performed.
02500		These conversions convert from the type specified in the
02600		TBITS word to the type specified in register B (bits
02700		passed to the INSISTer). 
02800	5.	If the ARITH bit is on, we make sure that the type is
02900		an arithmetic type, performing conversions if necessary.
03000	
03100	
03200	POST:
03300	1.	Put the current contents of the ac's TBITS and SBITS
03400		down in the symbol table entry pointed to by PNT
03500	2.	If the REM bit is set, do a REMOP on the thing in PNT
03600	3.	If the BITS2 bit is set, we execute MOVE SBITS2,$SBITS(PNT2)
03700		This is useful when an operation on one argument of a binary
03800		op. may change the semantics of another.
03900	4.	If the UNPROTECT bit is set, then register D is assumed to
04000		contain an ac number.  The ac table entry is unprotected.
04100	5.	If the EXCHOUT bit is set, we do an EXCHOP.
04200	
04300	 NOW FOR A DESCRIPTION OF THE ROUTINES WHICH ACTUALLY USE PRE AND POST:
04400	
04500	CONV:
04600		This is really a no-op.  It is here for the purposes of calling
04700		the type-conversion routines in PRE, and for the purpose of
04800		making sure that an argument is positive if in an accumulator
04900		(e.g. if we had  CVF(-(A+B)), then the result would be in an
05000		accumulator in negated fashion.  We now want to push it onto the
05100		stack for the call on CVF.  We want to make sure it is REAL and
05200		positive.  We use the POSIT bit:  GENMOV (CONV,INSIST!POSIT,REAL)
05300	
05400	
05500	PUT
05600		This issues a store of accumulator mentioned in register D
05700		into the thing described in TBITS, SBITS, PNT.  The accumulator
05800		table is updated to reflect this store (i.e. the thing talked about
05900		by PNT is marked as "inac").
06000	
06100		If the PNT entry is a string, then D is assumed to be an ac.
06200		into which a HRROI was done, or the SP stack.  At any rate, two
06300		POP's are emitted.
06400	
06500	ACCESS:
06600		This routine makes sure that we can have access to the entry
06700		mentioned in PNT.  That is, if the thing is indexed (result of
06800		an array calculation) and if it requires that some index accumulator
06900		be loaded with a good number, then the load will happen, so
07000		that an effective address can be generated which points at
07100		the thing talked about by PNT.
07200	
07300	GET:
07400		This is the generalized "get this entity in an ac" routine.
07500		It makes many checks (i.e. is it already in an ac?) and
07600		finally returns in register D the number of the ac which
07700		has been loaded, and returns in SBITS the updated semantics
07800		information that now reflects the loaded state.
07900		(By the way, to "get" a string means to do HRROI ac,second word
08000		of string.. This is so that POP's can be done later). There
08100		are many modifier bits to this routine:
08200	
08300		DBL	-- make sure that the ac following the one loaded
08400				 is free (for a double ac operation such as IDIV)
08500		INDX	-- make sure entity is loaded in an AC which can be
08600				 used for indexing (i.e. not 0 or 1.  The reason
08700				 for including 1 in this is a bit vague -- since
08800				 runtime routines often return results in 1, we
08900				 try to avoid its use for things thay may have
09000				 to be stored as temps).
09100		SPAC	-- load this into a special accumulator.  That accumulator
09200				number is passed in D.
09300		ADDR	-- load the address of this entity, not the value.
09400		POSIT	-- make sure the entity is in the ac in positive form.
09500		NEGAT	-- make sure in negative form.
09600		NONSTD	-- if indxed temp, do not remop it as someone wants
09700				to use it again. (see SWPR for instance).  The
09800				problem is not so much remopping, but that GET
09900				likes to make the semantic entries as "inac" on
10000				exit.  This fouls up any index calculations that
10100				may have been stored in the PNT entity.
10200		MRK	-- when done with the GET, call MARK (see below).
10300	
10400	STACK:
10500		The entity mentioned in PNT is stacked on an appropriate
10600		stack.  Strings (except arrays) are stacked on the SP
10700		stack, all others on the P stack.  ADEPTH or SDEPTH is 
10800		updated.
10900	
11000	MARK:
11100		This uses the bits in TBITS and SBITS, and the ac number
11200		in D as prototypes for making up a temp descriptor, and
11300		marking the ac full with that temp.  Return is a valid
11400		temp descriptor in PNT. If STRING is on in TBITS,
11500		a stacked-string descriptor will be generated
11600		(and of course, no accumulator will be marked).
11700		WARNING ***** MARK masks off some bits in SBITS and
11800		TBITS.  PTRAC,CORTMP,INDXED,FIXARR are turned off in SBITS
11900		and the only bits honored by TBITS are:
12000		LPARRAY,SET,ITEM,ITMVAR,INTEGR,FLOTNG,STRING
12100	
12200	SID 
12300	ACCUMULATORS:
12400	FF		-- RIGHT HALF SAVED.
12500	A		--THIS MAY BE CHANGED
12600	B		--SAVED, I BELIEVE.
12700	C		--SAVED, I BELIEVE.
12800	D		--OCCASIONALLY FILLED UP (E.G. GET,ACCESS)
12900	TBITS		-- THESE ARE THE SEMANTIC BITS -- THEY MAY BE CHANGED.
13000	SBITS		--  "
13100	PNT		-- "  (IN CASE OF MARK OR CONVERSIONS)
13200	LPSA		CLOBBERED
13300	USER		CLOBBERED
13400	TEMP		CLOBBERED
13500	SP		--SAVED
13600	SBITS2		--SAVED (modulo what is done in PRE).
13700	TBITS2		--SAVED
13800	PNT2		--SAVED
13900	
14000	SEE GENMOV MACRO
14100	⊗;
14200	
     

00100	COMMENT ⊗CONV, PRE, POST -- Type-Conversion routines⊗
00200	
00300	MASK←←	0+LPARRAY+SET+LSTBIT+ITEM+ITMVAR+INTEGR+FLOTNG+STRING!DBLPRC
00400					;GENMOVE KNOWS ABOUT THESE TYPES
00500	REC <
00600	MASK ←← MASK+PNTVAR
00700	>;REC
00800	
00900	;THIS IS THE PREAMBLE FOR ALL OF THE ROUTINES WHICH
01000	;USE DIRECTIVE BITS TO SPECIFY COERCIONS, EXCHOPS, ETC.
01100	
01200	PREMASK ←← GETD!EXCHIN!INSIST!ARITH!PROTECT
01300	
01400	
01500	↑↑CONV: TRNE	FF,PREMASK
01600		PUSHJ	P,PRE			;DO EVERYTHING HERE.
01700		TLNE	SBITS,NEGAT		;IF NOT NEGAT OR
01800		TRNN	FF,POSIT		;NOT NEED THINGS POSITIVE?
01900		 JRST	 POST			;ALL DONE.
02000		JRST	GETOPE			;DO THE GET.
02100	
02200	
02300	
02400	PRE:	TRNE	FF,GETD			;DO A GETAD?
02500		 PUSHJ	 P,GETAD		;YES
02600		TRNE	FF,EXCHIN		;EXCHOP ON WAY IN?
02700		 JRST	[EXCHOP			;YES
02800			JRST .+1]
02900		TRNE	FF,PROTECT
03000		 JRST	[HRROS ACKTAB(D)	;PROTECT THIS AC
03100			TDNN TBITS,[SBSCRP,,PROCED!ITEM!ITMVAR]
03200			TRNN TBITS,DBLPRC
03300			 JRST .+1		;THESE ARE NOT DOUBLE
03400			MOVEI	TEMP,(D)
03500			CAIN	TEMP,RF-1
03600			 ERR	<DRYROT PRE>,1
03700			CAIE	TEMP,RF-1
03800			 HRROS ACKTAB+1(D)	;2ND AC OF LONG
03900			JRST .+1]
04000		TRNN	FF,INSIST!ARITH		;ANY COERCIONS TO DO?
04100		 POPJ	 P,			;NO -- ALL DONE.
04200		PUSHJ	P,QTYPCK
04300					;CHECK FOR UNTYPED AND TYPE IF NEC. (SEE ERRORS)
04400	;#IL# 7-8-72 RHT ! GET ACCESS BEFORE YOU CONVERT
04500		PUSHJ	P,ACCOP			;GET ACCESS -- YOU MAY NEED IT
04600		TRNE	FF,ARITH		;WANT TO BE SURE OF ARITH ARG?
04700		JRST	AGET			;YES
04800	LEPPRE:	TRNN	TBITS,ITEM!ITMVAR	;IF EITHER HAS ITEM BITS ON.
04900		TRNE	B,ITEM!ITMVAR		;ALL THESE ARE GOOD GUYS.
05000		JRST	[ ;....			;KEEP GOING.
05100			TRNE	B,ITEM!ITMVAR
05200			TRNN	TBITS,ITEM!ITMVAR
05300			ERR	<ITEM TYPE MISMATCH >,1
05400			POPJ	P,]		;THIS IS ALL THE CHECKING!
05500	        TRNE	B,SET			;A SET OR LIST DESIRED?
05600		JRST	[TRNN	TBITS,SET	;IF NOT LIST OR A SET CAN'T BE DONE
05700			 ERR	<TYPE CAN'T BE CONVERTED TO SET OR LIST>,1
05800			 TRNE	B,LSTBIT	;IF WANTED LIST CAN RETURN
05900			 JRST   MAKLST		;MAY HAVE TO COPY LIST.
06000			 TRNN	TBITS,LSTBIT	;IF WANTED SET AND HAVE SET CAN RETURN
06100			 POPJ	P,
06200			 JRST   MAKEST]		;WILL HAVE TO CALL CVSET
06300	;;#YQ# JFR 2-2-77 DO RCLASS CHECKING FOR ASSIGNMENT NOW
06400	REC <	
06500		TRNE	TBITS,PNTVAR		;IF RECORDS & INSISTING
06600		TRNE	TBITS,SHORT!ITEM!ITMVAR	;THEN BETTER BE SURE CLASSES MATCH
06700		JRST	LEPP.1			;NOT THAT CASE, ANYHOW
06800		PUSH	P,PNT2			;NOTE DON'T CHECK ITEMS
06900		PUSH	P,LPSA
07000		HLRZ	PNT2,$ACNO(PNT)		; THE CLASSID
07100		SKIPN	LPSA,RCLASS		;
07200	;;     MWK This message used to be "RCLASS=0 ON INSISTING GET"
07300		ERR	<ATTEMPT TO COERCE RECORD POINTER>,1
07400		PUSHJ	P,SUBFOK		;CHECK CLASS ID
07500		ERR	<CLASS DISAGREEMENT FOR RECORD COERCION>,1
07600		TRNN	FF,MRK			;ASKED FOR A MARK
07700		SETZM	RCLASS			;NO, ALWAYS CLEAR THIS OUT
07800		POP	P,LPSA
07900		POP	P,PNT2
08000	LEPP.1:
08100	>;REC
08200	;;#YQ# ↑
08300		MOVEI	TEMP,(TBITS)		;ALWAYS INSIST ON CORRECT PRECISION
08400		XORI	TEMP,(B)
08500		TRNN	TBITS,DBLPRC
08600		TRNE	B,DBLPRC
08700		TRNN	TEMP,DBLPRC		;ONE IS DBL. ARE BOTH?
08800		 SKIPA	TEMP,TBITS		;BOTH ARE SAME PRECISON
08900		JRST	AGOTH			;DIFFERENT PRECISION. MUST CONVERT
09000		MOVE	USER,B			;COPY OFF.
09100		AND	TEMP,[XWD SBSCRP,MASK≠(ITEM!ITMVAR)]
09200		ORCB	USER,[XWD SBSCRP,MASK≠(ITEM!ITMVAR)]
09300		TDNN	TEMP,USER		;ARE ALL BITS IN B ON IN TBITS?
09400		POPJ	P,			;THEY MATCH !!
09500	AGOTH:	
09600		PUSH	P,FF
09700		TRZ	FF,-1≠NONSTD		;IN CASE ANY OTHER ROUTINES CALLED.
09800		PUSH	P,D
09900		TRNE	B,INTEGR+FLOTNG
10000		JRST	RESAR			;INSISTS ON ARITHMETIC TYPE
10100		TRNE	B,STRING
10200		JRST	RESSTR			;INSISTS ON STRING
10300		ERR	<IMPOSSIBLE TYPE COERCION>,1
10400		JRST	GEMGO			;GO ON ANYWAY
10500	
     

00100	
00200	
00300	RESSTR:	TRNN	TBITS,INTEGR		;INSIST ON INTEGER ARGUMENT.
00400		ERR	<STRINGS OF NON-INTEGERS?>
00500		TLNN	TBITS,CNST		;CONSTANT?
00600		JRST	STR1			;NO
00700		EXCH	SP,STPSAV		;GET A GOOD STACK POINTER.
00800		MOVSS	POVTAB+6		;ENABLE FOR STRING PDLOV
00900		PUSH	P,$VAL(PNT)
01000		PUSHJ	P,PUTCH			;MAKE A STRING (SLOWLY)
01100		POP	SP,PNAME+1
01200		POP	SP,PNAME
01300		EXCH	SP,STPSAV		;AND RESTORE EVERYONE.
01400		MOVSS	POVTAB+6		;RE-ENABLE FOR PARSE PDLOV
01500		PUSHJ	P,STRINS		;INSERT A STRING CONSTANT
01600						;THIS DOES A GETAD.
01700		JRST	GEMGO			;ALL DONE
01800	
01900	STR1:					;PREPARE TO STACK THE INTEGER
02000		PUSHJ	P,STACK1		;DO THE STACK.
02100		SOS	ADEPTH			;SINCE THE RUNTIM ROUTINES ADJUST.
02200		MOVEI	TEMP,2
02300		ADDM	TEMP,SDEPTH		;INCREASE DUE TO CALL.
02400		XCALL	<PUTCH>			;FUNCTION CALL
02500		MOVEI	SBITS,0			;START WITH CLEAN DYNAMIC SLATE
02600		JRST	TGO			;GO MAKE A TEMP.
02700	
02800	
02900	
03000	;;#SU# ! ADD PNTVAR TO THIS LIST
03100	AGET:	TRNE	TBITS,INTEGR+FLOTNG+PNTVAR	;IS IT ALREADY ARITHMETIC TYPE?
03200		 POPJ	 P,			;YES
03300		PUSH	P,FF
03400		TRZ	FF,-1≠NONSTD		; SAVE ALL THIS FOR OTHER
03500		PUSH	P,D			; EMBEDDED OPERATIONS
03600		MOVEI	B,INTEGR		;THIS FOR THE BENEFIT OF ARSTR.
03700	RESAR:	TRNE	TBITS,STRING		;HERE TO GET ARITHMETIC RESULTS
03800		JRST	ARSTR			;CONVERT FROM STRING
03900		TRNE	TBITS,INTEGR+FLOTNG
04000		JRST	FIXFL
04100		ERR	<IMPOSSIBLE TYPE COERCION>,1
04200		JRST	TGO			;MAKE A TEMP FOR IT ANYWAY...
04300	
04400	ARSTR:	TLNE	TBITS,CNST		;CONSTANT?
04500		JRST	STRCNS
04600	;;#IA# 6-30-72 DCS (3-6) PROTECT PTRAC AC OVER GETAC
04700		HRLI	PNT,-1			;FLAG, ASSUME PROTECTION
04800		HRRZ	TEMP,$ACNO(PNT)		;PTRAC AC #, IF ANY
04900		TLNN	SBITS,PTRAC		;NEED PROTECTION?
05000		TLZA	PNT,-1			;NO, UNMARK
05100		HRROS	ACKTAB(TEMP)		;YES, PROTECT
05200	;;#IA# (3-6)
05300		PUSH	P,B			;SAVE TYPE WORD
05400		PUSHJ	P,GETAN0		;NON-0 AC NUMBER
05500		JUMPGE	PNT,.+3			;NEED TO UNPROTECT?
05600	;;#IA# 6-30-72 (4-6)
05700		HRRZ	TEMP,$ACNO(PNT)		;YES, DO
05800		HRRZS	ACKTAB(TEMP)		; IT
05900	;;#IA# (4-6)
06000		MOVE	A,[HRRZ LNWORD] 	;CALCULATE LENGTH TO THIS AC
06100		PUSHJ	P,STROP			;VIA STROP
06200		HRL	B,PCNT			;SAVE PC FOR FIXUP
06300		HRLI	C,0
06400		EMIT	(<JUMPE USADDR!NORLC>)	;0 IF STRING EMPTY
06500		TLNE	SBITS,STTEMP		;NO NEED TO COPY BP IF TEMP STRING
06600		 JRST	 [MOVE A,[ILDB BPWORD]
06700			  PUSHJ P,STROP		;SO DO ILDB DIRECTLY
06800			  JRST NOCOP]		;AND GET OUT
06900		MOVE	A,[MOVE BPWORD] 	;GET COPY OF BP
07000		PUSHJ	P,STROP			;IN SAME AC
07100		HRL	C,D
07200		EMIT	(<ILDB USADDR!NORLC>) 	;ILDB AC,AC
07300	NOCOP:	HRR	B,PCNT			;FIXUP WORD
07400		PUSHJ	P,FBOUT
07500		MOVEI	A,UNDO!REM
07600		PUSHJ	P,STROP			;NOW ISSUE SUB IF NECESSARY
07700		PUSHJ	P,MARKINT		;MARK INT. RETS RIGHT THING IN PNT
07800		POP	P,B
07900		TRNE	B,INTEGR		;CONVERT ONLY TO INTEGER?
08000		JRST	GEMGO			;YES, OK.
08100		JRST	FIXFL			;GO ON FARTHER
08200	
     

00100	  
00200	STRCNS:	HRRZ	TEMP,$PNAME(PNT)	;THIS IS THE SAME CODE AS
00300		JUMPE	TEMP,.+3		; SAIL GENERATES TO DO
00400		MOVE	TEMP,$PNAME+1(PNT)	; STRING to INTEGER AT 
00500		ILDB	TEMP,TEMP		; RUNTIME
00600		TRNN	B,INTEGR		;DOES HE WANT AN INTEGER CONST
00700		FLOAT	TEMP,TEMP		;NO -- ASSUME FLOATING
00800		JRST	CONGO			;GO INSERT A CONSTANT.
00900	
01000	FIXFL:
01100		TRNN	TBITS,DBLPRC		;INPUT LONG?
01200		 JRST	FXFLS1			;NO
01300		EXCH	B,-1(P)			;ULTIMATE DESIRES
01400		MOVEI	TEMP,FXFLL1		;RETURN ADDR
01500		EXCH	TEMP,(P)
01600		PUSH	P,B			;ORIGINAL DIRECTIVE BITS
01700		PUSH	P,TEMP			;OLD AC D
01800		MOVSI	A,(<SNGL>)		;WHAT TO EMIT, IF WE HAVE TO
01900		MOVEI	B,FLOTNG		;WHAT WE WANT, TEMPORARILY
02000		TLNN	TBITS,CNST
02100		 JRST	UUOGO			;CONVERT TO SINGLE REAL, COME BACK TO FXFLL1
02200		SNGL	TEMP,$VAL(PNT)		;DO THE OP ON A CONSTANT
02300		JRST	CONGO			;RECORD RESULTS
02400	FXFLL1:	POP	P,B			;ULTIMATE DESIRES ARE BACK
02500		JRST	LEPPRE			;PROBLEM HAS BEEN REDUCED ONE NOTCH
02600	
02700	FXFLS1:
02800		TRNN	B,DBLPRC		;OUTPUT LONG?
02900		 JRST	FXFLS2			;NO
03000		TLNE	TBITS,CNST		;CONSTANT?
03100		 JRST	[MOVE	TEMP,$VAL(PNT)	;YES, GET VALUE
03200	;;#YB# ! JFR 1-3-77 COMPLETE TYPO
03300			TRNN	TBITS,FLOTNG	;ALREADY REAL?
03400			 FLOAT	TEMP,TEMP	;NO
03500			SETZM	DBLVAL		;SECOND WORD IS ZERO
03600			JRST	CONGO]		;THE EASY WAY
03700		GENMOV	(GET,DBL!INSIST,FLOTNG)	;LOAD IT FLOTNG
03800		PUSHJ	P,CLEARA		;THEN FORGET YOU DID IT
03900		MOVE	FF,-1(P)		;ORIGINAL DIRECTIVE BITS
04000		IORI	B,DBLPRC
04100		ADDI	D,1			;AND ZERO THE NEXT
04200	FXFLL2:	EMIT	(<SETZ NOADDR>)
04300		SOJA	D,TGO1			;MARK RESULT
04400	FXFLS2:
04500	;;%DN% JFR 7-1-76
04600		MOVE	TEMP,ASWITCH		;OPTION BITS
04700		MOVSI	A,(<FIX>)		;ASSUME STANDARD
04800		TRNE	TEMP,AFIXR
04900		 MOVSI	A,(<FIXR>)
05000		TRNE	TEMP,AKIFIX
05100		 MOVSI	A,(<KIFIX>)
05200		MOVE	USER,A			;COPY THE DECISION
05300		OR	USER,[TEMP,TEMP]	;INSERT AC AND ADDR FIELDS
05400	;;%DN% ↑
05500		MOVE	TEMP,TBITS		;GET OR OF `SHORT' BITS
05600		OR	TEMP,B
05700		TRNE	B,INTEGR		;RESULT FIXED?
05800		JRST	FIX			;YES
05900	;;%DN%
06000		MOVE	TEMP,ASWITCH
06100		MOVSI	A,(<FLOAT>)
06200		TRNE	TEMP,AFLTR
06300		 MOVSI	A,(<FLTR>)
06400		MOVE	USER,A
06500		OR	USER,[TEMP,TEMP]
06600		MOVE	TEMP,TBITS		;GET OR OF `SHORT' BITS
06700		OR	TEMP,B
06800	;;%DN% ↑
06900		TLNE	TBITS,CNST		;CONSTANT?
07000		JRST	FLC
07100		TRNN	TEMP,SHORT		;SHORT INTEGER BEGIN FLOATED?
07200		 JRST	 UUOGO			;NO, USE UUO
07300		PUSH	P,[FSC USADDR!NORLC] 	;INSTR TO FLOAT
07400		HRLI	C,233			;ARGUMENT OF FLOAT INSTR
07500	SHRTCV:	MOVE	TEMP,-2(P)		;FF BITS COMING INTO TOTAL
07600		TRNE	TEMP,SPAC		;WAS SPECIFIC AC REQUIRED
07700		TRO	FF,SPAC			;YES, RETAIN IT
07800		PUSHJ	P,GET			;GET THE THING
07900		POP	P,A			;INSTR
08000		JRST	JSTEST			;ALREADY KNOW WHAT AC
08100	
08200	
08300	FIX:	TLNE	TBITS,CNST		;CONSTANT?
08400		JRST	FLC
08500	NOEXPO<
08600		TRNN	TEMP,SHORT		;CONVERT TO SHORT INTEGER?
08700		 JRST	 UUOGO			;NO
08800		PUSH	P,[PDPFIX USADDR!NORLC]	;YES, USE PDP-10 INSTR
08900		HRLI	C,233000		;MAGIC ADDR FIELD FOR PDPFIX INSTR
09000		JRST	SHRTCV			;DO SHORT CONVERSION
09100	>;NOEXPO
09200	
09300	UUOGO:	MOVE	TEMP,-1(P)		;DIRECTIVE BITS WORD FROM STACK.
09400		TRNE	TEMP,SPAC		;IS HE GOING TO WANT A SPECIAL ONE?
09500		JRST	JSTEST			;YES
09600		HRR	D,$ACNO(PNT)
09700	;;#IA# 6-30-72 DCS (5-6) PROTECT PTRAC AC OVER GETAC
09800		HRLI	PNT,-1			;FLAG, ETC., SEE PART (3-6)
09900		TLNN	SBITS,PTRAC
10000		TLZA	PNT,-1
10100		HRROS	ACKTAB(D)
10200	;;#IA# (5-6)
10300		TLNN	SBITS,INAC		;IF NOT IN AN AC, THEN GET ONE.
10400		PUSHJ	P,GETAC
10500	;;#IA# 6-30-72 (6-6)
10600		JUMPGE	PNT,.+3
10700		HRRZ	TEMP,$ACNO(PNT)
10800		HRRZS	ACKTAB(TEMP)
10900	;;#IA# (6-6)
11000	GOTACB:
11100	JSTEST:
11200		DPB	D,[POINT 4,A,12] 	; STORE AC NUMBER IN INSTRUCTION.
11300		PUSHJ	P,EMITER
11400	TGO1:	HRRZ	TEMP,FF			;ORIGINAL FF
11500		TRNE	TEMP,NONSTD		;IF NON-STANDARD (SEE SWAP OPER),
11600		 JRST	 [POP P,(P)		; DON'T REMOP OR MARK
11700			  JRST GEMGO1]		;BUT RETAIN THE AC USED
11800		PUSHJ	P,REMOP			;REMOP THE OPERAND.
11900	TGO:	HRRZ	TBITS,B			;MAKE TBITS CONFORM TO THE DESIRED TYPE
12000		ANDI	TBITS,MASK		;MAKE RESULT LOOK LIKE THE REQUESTS
12100		TLZ	SBITS,-1≠NEGAT		;CLEAR AWAY THE CHAFF
12200		PUSHJ	P,MARK1			;GO DO A MARK.
12300		JRST	GEMGO
12400	
12500	FLC:	MOVE	TEMP,$VAL(PNT)		;HERE FOR A CONSTANT.
12600		XCT	USER			;DO THE CONVERSION
12700	CONGO:	MOVEM	TEMP,SCNVAL		;SET UP FOR SYMBOL TABLE INSERTION
12800		HRRZ	TBITS,B			;COME HERE TO INSERT A CONSTANT.
12900		ANDI	TBITS,MASK
13000		TLO	TBITS,CNST
13100		MOVEM	TBITS,BITS		;FOR CONINS
13200		PUSHJ	P,REMOP			;ALWAYS REMOVE THE OLD GUY
13300		PUSHJ	P,CONINS
13400	GEMGO:	POP	P,D
13500	GEMGO1:	POP	P,FF			;AT LAST DO THE POP AND
13600		POPJ	P,			;ALL DONE -- FULL SPEED AHEAD.
13700	
     

00100	
00200	; NOW FOR THE POSTAMBLE (WE WILL AMBLE THROUGH THE COMPILATION).
00300	
00400	
00500	↑↑POST:	MOVEM	SBITS,$SBITS(PNT) 	;PUT DOWN SEMANTICS WORDS.
00600		MOVEM	TBITS,$TBITS(PNT)
00700		TRNN	FF,EXCHOUT!BITS2!REM!UNPROTECT ;THESE ARE THINGS TO DO.
00800		POPJ	P,			;ALL DONE.
00900		TRNE	FF,REM			;REMOP THE THING?
01000		 JRST	[PUSHJ   P,REMOP	;YES
01100			 MOVE	SBITS,$SBITS(PNT)
01200			 JRST	.+1]
01300		TRNE	FF,BITS2		;UPDATE SBITS2?
01400		 MOVE	 SBITS2,$SBITS2(PNT2) 	;DONE.
01500	
01600		TRNE	FF,UNPROTECT
01700		 JRST	[HRRZS	 ACKTAB(D)
01800			TDNN	TBITS,[SBSCRP,,PROCED!ITEM!ITMVAR]
01900			TRNN	TBITS,DBLPRC
02000			 JRST	.+1
02100			MOVEI	TEMP,(D)
02200			CAIN	TEMP,RF-1
02300			 ERR	<DRYROT POST>,1
02400			CAIE	TEMP,RF-1
02500			 HRRZS	ACKTAB+1(D)
02600			JRST	.+1]
02700	
02800		TRNN	FF,EXCHOUT		;EXCHANGE ON WAY OUT?
02900		POPJ	P,			;NO --DONE.
03000		EXCHOP
03100		POPJ	P,
03200	
     

00100	COMMENT ⊗PUT⊗
00200	
00300	↑↑PUT:	TRNE	FF,PREMASK	;ANY PREAMBLE TO BE DONE
00400		 PUSHJ	 P,PRE		;YES -- DO IT.
00500		PUSH	P,FF		;HERE TO STORE AN ACCUMULATOR INTO
00600	; HAVE PUT ALWAYS DO AN ACCESS
00700	;	TLNE	SBITS,INDXED	;A DESCRIPTOR
00800		PUSHJ	P,ACCOP		;GET ACCESS TO THE TARGET.
00900		TRNE	TBITS,STRING	;IF NOT A STRING
01000		TDNE	TBITS,[XWD SBSCRP,ITEM!ITMVAR] ;OR NOT REALLY A STRING,THEN
01100		 JRST	 APUT		;USE A MOVEM OR THE LIKE.
01200	
01300		MOVE	A,[POP	BPWORD!LNWORD!SBOP!BPFIRST]
01400		PUSHJ	P,STROP		;USE THE STRING OPERATION TO PUT OUT POPS.
01500		CAIE	D,RSP		;IF IT WAS NOT THE STACK, THEN
01600		 PUSHJ	 P,CLEARA	;CLEAR OUT THIS ACCUMULATOR ENTRY.
01700					;IT WAS CHANGED WHEN THE POPS WERE DONE ANYWAY.
01800		JRST	PUTFIN		;ALL DONE.  MY THAT WAS SIMPLE.
01900	
02000	APUT:	PUSHJ	P,CLEARA	;CLEAR OUT THE DESTINATION ACCUMULATOR.
02100		TLNE	SBITS,INAC	;IF THE DESTINATION OF THE STORE IS ALREADY
02200		PUSHJ	P,CLEAR		;IN AN AC, THEN CLEAR IT OUT.
02300	REC <
02400	NORGC <
02500		TRNE	TBITS,PNTVAR		;A RECORD ?
02600		TRNE	TBITS,777777-(PNTVAR!GLOBL)
02700		JRST	APUT2			;NOPE, JUST DO THE PUT
02800		PUSH	P,C			;IT MAY BE USED, NOT SURE
02900		MOVNI	C,1			;DEREFERENCE THE THING IN PNT
03000		PUSHJ	P,RFCADJ		;LIKE SO
03100		POP	P,C
03200		
03300	APUT2:
03400	>;NORGC
03500	>;REC
03600		HRLZI	A,(<MOVEM>)	;THE ORDINARY STORE INSTRUCTION.
03700		TDNE	TBITS,[SBSCRP,,PROCED!ITEM!ITMVAR]
03800		 JRST	.+3		;SUFFICES IN ANY CASE FOR AN ARRAY, ITEM, ITEMVAR
03900		TRNE	TBITS,DBLPRC
04000		 HRLZI	A,(<DMOVEM>)
04100		TLNN	SBITS,NEGAT	; BUT IF NEGATED, USE THE OTHER
04200		 JRST	.+4		;NOT NEGATED
04300		TRNN	TBITS,DBLPRC	;DOUBLE?
04400		TLCA	A,(<MOVNM>≠<MOVEM>)	;NO. MAKE INTO MOVNM
04500		TLC	A,(<DMOVNM>≠<DMOVEM>)	;YES. MAKE INTO DMOVNM
04600	;; #OX# TREAT ? ITEMVARS SPECIALLY
04700		TLNE	TBITS,MPBIND
04800		JRST	[HRR	C,D	;SAVE AC NUMBER
04900			 GENMOVE (GET,ADDR!INDX)
05000			 MOVSS	D	
05100			 HRR	D,C	;XWD INDX,,AC
05200			 MOVE	A,[MOVEM USX+NORLC+NOADDR]
05300			 JRST	.+1
05400			 ]	;GO AWAY
05500	;; #OX#
05600		PUSHJ	P,EMITER	;AND PUT OUT THE INSTRUCTION.
05700		
05800		TLNE	SBITS,INDXED	;WE DO NOT WANT TO MARK *********
05900		 JRST	 PUTFN1		;GO AWAY.
06000	
06100		HRRM	D,$ACNO(PNT)	;AND THE AC IT IS IN
06200		HRRM	PNT,ACKTAB(D)	;IN TWO PLACES.
06300					;THIS UNPROTECTS THIS ACCUMULATOR.
06400		TLNN	SBITS,PTRAC
06500		TDNE	TBITS,[SBSCRP,,PROCED!ITEM!ITMVAR]
06600		 JRST	.+3
06700		TRNE	TBITS,DBLPRC
06800		 JRST	[SKIPE	ACKTAB+1(D)
06900			  ERR	<DRYROT PUT DOUBLE>,1
07000			MOVEI	TEMP,(D)
07100			CAIE	TEMP,RF-1	;DO NOT CLOBBER RF!
07200			 HRRM	PNT,ACKTAB+1(D)
07300			JRST	.+1]
07400		TLOA	SBITS,INAC	;AND NOW MARK THE DESCRIPTOR BITS
07500	
07600	PUTFN1:	TLZ	SBITS,NEGAT	;SUBSCRIPTED, NEGAT GETS IN WAY (BELIEVE!)
07700	PUTFIN:	POP	P,FF		;ALL DONE
07800		JRST	POST		;AND FINISH OUT.
07900	
     

00100	COMMENT ⊗ACCESS,GETSDR,GETDR,DISBLK,ZOTDIS--last four  only for dis
00200	
00300	Call ACCOP when you need to reference a thing and don't know whether you
00400	 can get at it in a single instruction (i.e. an indexed thing). 
00500	GENMOV(ACCESS)  will cause ACCOP to be called for you.
00600	 People like GET and STACKOP do it automatically.
00700	⊗
00800	
00900	↑↑ACCESS: TRNE	FF,PREMASK
01000		PUSHJ	P,PRE
01100		PUSHJ	P,ACCOP
01200		JRST	POST
01300	
01400	ACCOP:	TDNN	SBITS,[XWD INDXED,DLFLDM]; ONLY CARE IF INDEXED OR NEED A DISPLY
01500		POPJ	P,
01600		TLNE	SBITS,INAC!PTRAC	;IF IN AN AC WE CAN ACCESS IT
01700		POPJ	P,
01800		TRNN	SBITS,DLFLDM		;IF DISPLAY LEV=0 ONLY CARE ABOUT INDEXED 
01900		JRST	INXSTF			;NO WORRY ABOUT THE DIAPLAY
02000		LDB	TEMP,[LEVPOINT<SBITS>]	;PICK UP DISPLY LEV
02100		TRNE	TBITS,STRING		;IS ITT A STRING
02200		JRST	[
02300	;; #JR# BY JRL 10-17-72 ITEMVARS,ARRAYS DON'T USE STRING STACK
02400			 TDNN TBITS,[REFRNC!SBSCRP,,ITEM!ITMVAR];THESE THINGS DON'T USE 
02500			 TLNE SBITS,INDXED	;INDEXED?       ;STRING STACK
02600			 JRST .+1
02700	;; #JR#
02800			 JRST	GETSDR	;GET STRING DR
02900			]
03000		PUSHJ	P,GETDR			;GET A DISPLAY REG LOADED
03100	;;%DU% JFR 1-4-77
03200		TRNE	FF,ACESS2		;DIRECT TO 2ND WD
03300		TRNN	TBITS,DBLPRC		; OF LONG?
03400		 JRST	ACCOP1			;NO
03500		TLNE	TBITS,REFRNC
03600		 JRST	ACMOP		;APPARENTLY ONLY REF. FORMALS NEED THIS
03700	ACCOP1:
03800	;;%DU% ↑
03900		TRNN	SBITS,INDXED		;INDEXED TOO?
04000		POPJ	P,			;NO
04100	INXSTF:
04200	;;#JR#
04300		TRNN	TBITS,ITEM!ITMVAR
04400		TRNN	TBITS,STRING	;ALWAYS NEED STRING GUYS
04500		JRST 	.+2
04600	;;#JR#
04700		JRST    ACMOP
04800		HRRZ	TEMP,$VAL(PNT)	; ONLY NEED IT IF NON-ZERO
04900		JUMPE	TEMP,CPOPJ	;  DISPLACEMENT
05000	
05100	ACMOP:	TLNE	SBITS,PTRAC	;IS IT ALREADY ACCEPTABLE (IN AC)?
05200		 POPJ	 P,		; YES, WHY HAVE WE WORRIED?
05300	
05400		PUSH	P,D		;HAVE TO SAVE CURRENT AC
05500		PUSH	P,A
05600		PUSH	P,FF
05700		MOVE	TEMP,FF
05800		HRRI	FF,INDX		;SO THAT NOTHING NONSTD WILL HAPPEN.
05900		MOVE	A,[XWD 40!2!1,ADDR] ;SET NECESSARY BITS
06000					;(SPECIAL BIT, MOVE, GET AC, USE INDXBLE AC, GET ADDR)
06100	;;%DU%
06200		TRNE	TEMP,ACESS2
06300		TRNN	TBITS,DBLPRC
06400		 CAIA
06500		TLO	A,400		;DO NOT CHANGE SBITS(PNT)
06600	;;%DU% ↑
06700		PUSHJ	P,GETWD
06800		POP	P,FF
06900	;;%DU% JFR 1-4-77
07000		TRNE	FF,ACESS2
07100		TRNN	TBITS,DBLPRC
07200		 JRST	ACMOP1		;NOT SPECIAL 2ND WD ACCESS
07300		PUSH	P,TBITS
07400		SETZB	TBITS,SBITS
07500		PUSHJ	P,GETTEM	;WE HAVE GOTTEN THE ADDR INTO A TEMP
07600		MOVEM	D,$ACNO(LPSA)	;REMEMBER INTO WHICH AC
07700		HRRM	LPSA,ACKTAB(D)
07800		POP	P,$TBITS(LPSA)
07900		HRRZS	TBITS,$TBITS(LPSA)	;SANITIZE THE TYPE
08000		MOVSI	SBITS,ARTEMP!PTRAC!INDXED
08100		MOVEM	SBITS,$SBITS(LPSA)
08200		SETZM	$VAL(LPSA)	;DISPLACEMENT IS ZERO
08300		MOVEI	PNT,(LPSA)	;OUR NEW OPERAND
08400	ACMOP1:
08500	;;%DU% ↑
08600		POP	P,A
08700		POP	P,D
08800		POPJ	P,
08900	
09000	
09100	COMMENT⊗
09200	DSCR	GETSDR,GETDR
09300	DES	ROUTINES TO LOAD UP STRING (ARITHMETIC) DISPLAYS
09400		LOADS UP LPSA WITH THE AC NO TO USE & FIXES UP ACTAB,DISTAB,&DISLST
09500	PARM	TEMP=LEVEL DESIRED
09600	SID	MANGLE	TEMP,LPSA
09700		STORES LEVEL IN LSDRLV, STORES DR # IN LSDRNM (LH FOR SDR & RH FOR DR)
09800	⊗
09900	
10000	;;#MN# 7-13-73 FIX ACCESS PROBLEM
10100	ZERODATA(EMITTER DATA)
10200	LSDRLV: 0 ;SEE ABOVE
10300	LSDRNM: 0
10400	ENDDATA
10500	
10600	↑↑GETSDR: 
10700		HRLM	TEMP,LSDRLV		;REMEMBER LEVEL OF STRING REQUEST
10800		HLRZ	LPSA,DISTAB(TEMP)	;DO WE HAVE IT ALREADY
10900		HRLM	LPSA,LSDRNM		;IF SO REMEMBER
11000	;;#MN#
11100		JUMPN   LPSA,CPOPJ		;YES
11200		PUSHJ	P,GETDR			;GET THE P-DISPLY
11300		PUSH	P,FF			;WHAT A PITY WE MIGHT HAVE JUST POPPED
11400		PUSH	P,A			;BUT THIS IS QUICKER IN THE LONG
11500		PUSH	P,B			;RUN THAN MESSING WITH FLAGS
11600		PUSH	P,C			;
11700		PUSH	P,D
11800		TRZ	FF,DBL			;ONLY ONE AC
11900		HRL	D,LPSA			;USE P-DR AS INDEX
12000		MOVE	B,TEMP			;WE WILL NEED THIS
12100		HRLI	C,2			;DISPL OF 2
12200		PUSHJ	P,GETAN0		;GET AN AC FOR DISPLY
12300		EMIT	(<MOVE ,USX!USADDR!NORLC>) ;LOAD THE DR
12400		HRLM	D,DISTAB(B)		;ENTER INTO DISPLAY TABLE
12500		PUSHJ	P,DISBLK		;SET	UP MOST OF BLOCK
12600		MOVEI	TEMP,STRING		;
12700		HRRZM	TEMP,$TBITS(LPSA)	;MAKE TYPE RIGHT
12800		MOVSS	$VAL(LPSA)		;FIX UP AND MASK
12900	;;#MN#  !
13000		HRLM	LPSA,LSDRNM
13100	
13200		JRST	RETSEQ			;GO POP STUFF & RETURN
13300	↑↑GETDR:
13400	;;#MN#	!
13500		HRRM	TEMP,LSDRLV
13600		HRRZ	LPSA,DISTAB(TEMP)	;PICK UP THE PUTATIVE REGISTER
13700	;;#MN#  !
13800		HRRM	LPSA,LSDRNM
13900		JUMPN	LPSA,CPOPJ		;IF THERE,RETURN
14000		PUSH	P,FF
14100		PUSH	P,A
14200		PUSH	P,B
14300		PUSH	P,C
14400		PUSH	P,D
14500		PUSH	P,TEMP			;GETDR MUST SAVE IT
14600		TRZ	FF,DBL			;ONLY ONE AC
14700		HRRZI	B,1(TEMP)		;NEXT LEVEL DEEPER
14800	
14900	GDR1:	HRLZ	D,DISTAB(B)		;PICK IT UP
15000		CAIN	D,0			;IS IT LOADED
15100		AOJA	B,GDR1			;NO
15200		HRLI	C,1			;SET TO SELECT STATIC LINK
15300		MOVE	A,[<MOVE 0,USX!NORLC!USADDR>]	
15400	GDR2:	PUSHJ	P,GETAN0		;THIS BETTER LEAVE LH(D) ALONE -- IT DOES
15500		PUSHJ	P,EMITER		;UP ONE STATIC LINK
15600		SOS	B			;BACK A LEVEL
15700		HRRM	D,DISTAB(B)		;SAY WE HAVE IT
15800		PUSHJ	P,DISBLK		;TO DO STUFF FOR DISPLAY BLOCK&ACKTAB
15900		CAMN	B,(P)			;IS THIS THE ONE WE WANT
16000		JRST	GDR4			;YES
16100	GDR3:	HRL	D,D			;USE AS INDEX PERHAPS
16200		HRR	D,DISTAB-1(B)		;NEXT AC BACK
16300		TRNE	D,-1			;IS IT THERE
16400		SOJA	B,GDR3			;YES
16500		JRST	GDR2			;NO--FETCH IT
16600	GDR4:	HRRZ	LPSA,D			;AC NO OD DISPLY
16700	;;#MN# !
16800		HRRM	LPSA,LSDRNM		;REMEMBER NUMBER
16900		POP	P,TEMP
17000	;;#UW# ! JFR 8-17-75 CALL TO EMITER AT GDR2+1 WIPED OUT LSDRLV
17100		HRRM	TEMP,LSDRLV
17200	RETSEQ:	POP	P,D
17300		POP	P,C
17400		POP	P,B
17500		POP	P,A
17600		POP	P,FF
17700		POPJ	P,			;RETURN
17800	
17900	COMMENT ⊗
18000	DSCR DISBLK
18100	DES THIS PROCEDURE SETS UP DISPLAY SEMBLK STUFF & UPDATES ACKTAB
18200		IT SETS LPSA TO POINT ATE THE NEW SEMBLK
18300		THE BLOCK IS SET UP FOR A LPSA TYPE SEMBLK
18400	PARM	B = DISPLAY LEBEL
18500		D= ACNO OF DISPLAY REG
18600	⊗
18700	↑↑DISBLK:
18800		GETBLK				;GET A BLOCK
18900		HRRM	D,$ACNO(LPSA)		;SAVE AC NO
19000		HRRM	B,$ADR(LPSA)		;LEVEL GOES HERE
19100		SETOM	TEMP
19200		HRLZM	TEMP,$VAL(LPSA)		;SETS UP ANDING MASK
19300		MOVE	TEMP,[XWD PTRAC!INAC!DISTMP,INTEGR]
19400		HRRZM	TEMP,$TBITS(LPSA)	;$TBITS WORD
19500		HLLZM	TEMP,$SBITS(LPSA)	;$SBITS WORD
19600		PUSHJ	P,RNGDIS		;PUT IT ON DISLST LIST
19700		HRRZM	LPSA,ACKTAB(D)		;MARK AC FULL OF IT
19800		POPJ	P,			;RETURN
19900	
20000	COMMENT ⊗
20100	DSCR ZOTDIS
20200	DES this procedure will wipe out your current display
20300	PARM None
20400	SID LPSA,TEMP used
20500	⊗
20600	↑↑ZOTDIS:
20700		PUSH	P,D			;SAVE
20800		PUSH	P,A
20900		MOVE	A,CDLEV			;CURRENT DISPLAY LEVEL
21000	ZDIS.1: SOJL	A,ZDIS.2
21100		HRRZ	D,DISTAB+1(A)
21200		CAIE	D,RF			;DONT ZONK RF
21300		CAIN	D,			;DONT DO ANYTHING IF NOT THERE
21400		SKIPA
21500		PUSHJ	P,STORZ
21600		HLRZ	D,DISTAB+1(A)
21700		CAILE   D,
21800		PUSHJ	P,STORZ
21900		SETZM	DISTAB+1(A)
22000		JRST	ZDIS.1
22100	ZDIS.2: POP	P,A
22200		POP	P,D
22300		POPJ	P,
22400	
22500	
22600	
     

00100	COMMENT ⊗GET
00200	
00300		GENMOV(GET) generally invokes this routine.
00400		It has many purposes, depending on the entity to be "getted".
00500		Briefly, however, it loads an AC with the thing one
00600		wants in order to store or compute using the entity in
00700		question.  For strings, it loads a string address
00800		with the left half negative (for popping). For 
00900		INDXED guys (with ADDR turned on), it loads
01000		the result of the index calc to an ac if it was not 
01100		there. For regular variables, it simply picks them
01200		up if they are not in an AC.  The bits 
01300		ADDR, INDX,  DBL, POSIT, NEGAT, and MARK
01400		may be used to modify the action of GETOPE.
01500	
01600	⊗
01700	
01800	↑↑GET:	TRNE	FF,PREMASK	;ANYTHING TO DO??
01900		 PUSHJ	 P,PRE
02000		TRC	FF,INSIST!NONSTD 	;IF NO MARKING TO BE DONE, AND
02100		TRCE	FF,INSIST!NONSTD	; A TYPE CONVERSION WAS DONE,
02200		 JRST	 GETOPE
02300	;; #OZ# (1 OF 1) PRE DOESN'T DO A GET OF ITEMS OR ITEMVARS
02400		TRNE	B,ITMVAR!ITEM		; PRE DID NOT DO A GET
02500						; IF ITEMVARS OR ITEMS
02600		JRST	GETOPE
02700	;; #OZ#
02800		HRRZ	TEMP,B			; (COMPARE INSISTED TYPE WITH
02900		CAIE	TEMP,(TBITS)		;  ACTUAL TYPE), THEN DON'T GET
03000		 JRST	 POST			;  AGAIN
03100	↑GETOPE:
03200		PUSHJ	P,ACCOP		; ESTABLISH ACCESS TO THE EFFECTIVE ADDRESS.
03300	
03400	COMMENT ⊗ IF STTEMP, NO MORE WORK NECESSARY
03500		(ASSUME STRING IS ON) ⊗
03600	
03700		TLNN	SBITS,STTEMP
03800		JRST	GETOPC
03900		TRNN	FF,ADDR		;MUST GO THRU WITH IT IF ADDR
04000		 JRST	 TMPRET
04100	
04200	COMMENT ⊗ USE LEFT HALF OF A TO HOLD SOME EXTRA BITS:
04300	
04400		1 -- NEED AN AC (GETAC)
04500		2 -- DO A MOVE OF SOME SORT
04600		4 -- DO A MOVN
04700		10 - MAKE IT A HRRO
04800		20 - MAKE IT A HRROI, FOR STRING INDXED GUYS (SEE BELOW)
04900		40 - SPECIAL ACCOP BIT, SEE GETRET BELOW
05000		100 - SEEMS TO MEAN MOVEI -- WASN'T DOCUMENTED, DAMMIT
05100		200 - SPECIAL KLUGERY FOR RECORDS
05200		400 - KLUGE TO PREVENT GET ADDR OF REGULAR THING
05300			FROM MARKING INAC.  
05400		1000 - USE DOUBLE WORD INSTRUCTIONS (DMOVE, ...) INSTEAD OF SINGLE (MOVE,...)
05500	
05600	NEED EXTRA CHECKS IF ENTITY IS ALREADY IN AN AC
05700	⊗
05800	
05900	GETOPC:	HRLZI	A,3		;ASSUME NEED A MOVE
06000		TRNE	FF,SPAC		;UNLESS AC # PROVIDED,
06100		 TLZ	 A,1		; ASSUME AC NEEDED
06200		TLNN	SBITS,INDXED	;IF ¬INDEXED, THEN TURN OFF NONSTD.
06300		 TRZ	 FF,NONSTD	;SO AS NOT TO FOUL UP.
06400	REC <
06500		TRNE	TBITS,PNTVAR		;MAKE SURE ONLY DO KLUGE IF A RECORD
06600		TRNE	TBITS,777777-(PNTVAR!GLOBL) ;ONLY THAT BIT IS ALLOWED TO BE ON
06700		JRST	NOSPAC			; NOT A RECORD
06800	
06900	;;#SA# ! GET ADDR IS JUST NORMAL
07000		TRNE	FF,ADDR			;WELL??
07100		JRST	NOSPAC
07200	
07300		HLRZ	TEMP,$ACNO(PNT)		;IN CASE WE WANT A MARK (USUALLY WILL)
07400		TRNE	FF,MRK			;TEST IT OUT
07500		HRRZM	TEMP,RCLASS		;NOW THE MARK WON'T DRYROT
07600		TLNE	TBITS,CNST		;CONSTANTS ARE GETTABLE DIRECTLY
07700		JRST	[ CAME	PNT,NLRCBK	;THIS SHOULD BE THE ONLY ONE POSSIBLE
07800			ERR	<RECORD CLASS TEMP OTHER THAN NULL RECORD?>,1
07900			JRST	NOSPAC
08000			]
08100	
08200		TLNN	SBITS,ARTEMP		;IF NOT A TEMP
08300		JRST	RECKL1			;THEN DO THE FIRST PART OF RECORD KLUGE
08400		TLNN	SBITS,INDXED		;IF NOT INDEXED TEMP BUT A TEMP
08500		JRST	NOSPAC			;DON'T DO ANYTHING ABOUT THIS
08600						;WE WILL PERFORM THE INCREMENT OF
08700						;THE REF CNT FOR ANY VARIABLE OR
08800						;INDXED TEMP, WHETHER A SUBFIELD OR NOT
08900	RECKL1:	
09000	NORGC <	
09100		TLO	A,200			;BIT THAT SAYS TO DO RECORD ACCESS
09200	>;NORGC
09300		TRNN	FF,SPAC			;KLUGE TO GET AC # GOOD
09400		TRO	FF,INDX			;IF WE GET ONE, IT BETTER BE INDEXABLE
09500	
09600	IFN 0,<
09700		TLNE	SBITS,INAC		;IF INAC, WE WILL FORGET IT FOR THIS PURPOSE
09800		PUSHJ	P,[ TLNE SBITS,INDXED	;BIG SURPRIZE IF THIS IS ON
09900			ERR <DRYROT: INDXED INAC?>,1
10000	;;#SV# RHT MUST PRESERVE D
10100			PUSH	P,D
10200			HRR	D,$ACNO(PNT)	;GET OUT OF THE AC & THEN WILL WIN
10300			PUSHJ	P,CLEARA	;FORGET INACITUDE
10400			POP	P,D
10500			JRST	GETAD		;REFURBISH THE BITS & RETURN FROM LITERAL
10600			]
10700	>;FALSE
10800	
10900	;; FALL INTO NOSPAC
11000	>;REC
11100	NOSPAC:	TLNN	SBITS,INAC!PTRAC;IF IN AC, HAVE TO BE SURE IT'S RIGHT
11200		 JRST	 STCHK			; IF NOT, MUST CHECK
11300						; FOR STRINGS (HAVE TO LOAD)
11400	
11500	;DBLPRC PTRAC MUST TURN ON DBL UNLESS ADDR
11600		TRNN	FF,ADDR
11700		TLNN	SBITS,PTRAC
11800		 JRST	NOSPA1
11900		TDNN	TBITS,[SBSCRP,,PROCED!ITEM!ITMVAR]
12000		TRNN	TBITS,DBLPRC
12100		 JRST	NOSPA1
12200		IORI	FF,DBL
12300	NOSPA1:
     

00100	
00200	Comment ⊗ INAC -- if DBL or INDX or SPAC,
00300		find out if thing can stay in this AC -- otherwise
00400		must get another.  ⊗
00500	
00600	; FIRST CHECK SPAC GUYS
00700	
00800		TLZ	A,1!2		;ASSUME NOTHING YET
00900		TRNN	FF,SPAC		;PROVIDED WITH SPECIFIC AC?
01000		 JRST	 DBCHK		; NO, CHECK DBL WANTED
01100		HRRZ	TEMP,$ACNO(PNT) ;GET CURRENT AC #
01200		CAIN	TEMP,(D)	;DID WE LUCK OUT (SAME ONE)?
01300		 JRST	 SBSCHK		;YES, GO CHECK SPECIAL INDXED THING
01400	
01500					;DCS 8/16/70 IF SPAC AC BEING REPLACED,
01600					; STORE AND CLEAR WHAT'S IN IT
01700		SKIPLE	ACKTAB(D)	;PROTECTED OR NOTHING THERE?
01800		 PUSHJ	 P,STORZ	; NO, GET RID OF IT
01900					;DCS 8/16/70
02000	
02100		TLO	A,2		;WILL HAVE TO DO A MOVE
02200		JRST	WPCHK1		;AND MAKE SEMANTICS CHANGES
02300	
02400	; IF DBL IS ON, SEE IF NEXT AC IS FREE, SET UP TO MOVE IF NOT
02500	
02600	DBCHK:	
02700		HRR	D,$ACNO(PNT)	;GET CURRENT AC NUMBER
02800		TRNN	FF,DBL		;WELL
02900		 JRST	 IDXCHK		;NO DBL REQUESTED
03000	
03100		SKIPGE	ACKTAB+1(D)	;NEXT ONE NOT USABLE?
03200		 JRST	 WIPCHK		; CANNOT  BE USED, MAKE SEMANTIC CHANGES
03300	
03400		HRRI	D,1(D)		;STORE THE NEXT
03500		PUSHJ	P,STORZ
03600		HRRI	D,-1(D)		;RESTORE AC #
03700	
03800	
03900	IDXCHK:	TRNE	FF,INDX		;NEED INDX?
04000		TRNE	D,-2		; AND NOT IN ONE ALREADY?
04100		 JRST	 SBSCHK		;OK, 'TWOULD SEEM
04200	
04300	
04400	Comment ⊗ If AC # is being changed (INAC and NEEDAC or SPAC and MOVE)
04500		clear right half of ACKTAB(AC), but first be sure nothing will be
04600		wiped out  ⊗
04700	
04800	WIPCHK:	TLO	A,1!2		;HAVE TO MOVE IT
04900	WPCHK1:	HRRZ	TEMP,$ACNO(PNT)	;IT IS HERE CURRENTLY
05000		SKIPGE	ACKTAB(TEMP)	;WAS THIS AC PROTECTED?
05100		 ERR	<DRYROT --AC CLOBBER>,1
05200		SETZM	ACKTAB(TEMP)	;"STORR" (STORL DONE BEFORE)
05300		TDNN	TBITS,[SBSCRP,,ITEM!ITMVAR!PROCED]
05400		TRNN	TBITS,DBLPRC
05500		 JRST	WPCHK2		;NOT VALUE LONG
05600		TLNE	SBITS,PTRAC
05700		 JRST	WPCHK2		;NEITHER IS THIS
05800		CAIN	TEMP,RF-1
05900		 ERR	<DRYROT WIPCHK>,1
06000		CAIE	TEMP,RF-1
06100		 SETZM	ACKTAB+1(TEMP)	;CLEAR 2ND AC OF LONG
06200	WPCHK2:
     

00100	
00200	Comment ⊗ for STRING INDXED quantities (or non-STRING with ADDR)
00300		(guaranteed INAC by now) requiring a displacement,
00400		a "HRROI" FXTWO (or MOVEI)must be done --
00500		"HRRO" ("MOVE") with ADDR would yield a no-op
00600	⊗
00700	
00800	SBSCHK:	TLNN	SBITS,INDXED	;TEST THE CONDITONS
00900		 JRST	 POSN		; NOT INDEXED
01000		HRRZ	TEMP,$VAL(PNT)	;≠0 DISPLACEMENT?
01100		 JUMPE 	 TEMP,POSN	; NO DISPLACEMENT, NO PROBLEM
01200	;; #OR# ! A STRING ITEMVAR IS NOT A STRING
01300	;; #UE# ! NOR IS A STRING ARRAY
01400		TDNN	TBITS,[XWD SBSCRP,ITMVAR!ITEM]; A STRING ITEM IS NOT A STRING
01500		TRNN	TBITS,STRING	;INDXED STRING?
01600		 JRST	 CHKNUM		; NO, CHECK GET!ADDR FOR NUMERIC ARRAY
01700		TRZ	FF,ADDR		;JUST IN CASE
01800		TLO	A,2!20		;MOVE, HRROI, NO ADDR
01900		JRST	POSN
02000	
02100	CHKNUM:	TRZE	FF,ADDR		;WANT THE ADDRESS ALL TOGETHER?
02200		 TLO	 A,100!2	; YES, MOVE, MOVEI
02300		JRST	POSN
02400	
02500	
02600	Comment ⊗ for strings, we must do a HRRO with ADDR
02700		turned ON (except for SBSCRP strings) ⊗
02800	
02900	STCHK:	TRNE	FF,SPAC		;STORE AC IF SPAC
03000		 PUSHJ	 P,STORZ
03100		TRNE	TBITS,STRING	;STRING, NOT SBSCRP?
03200	;;#VJ# ! JFR 10-17-75 A STRING PROCEDURE IS NOT A STRING, EITHER
03300		TDNE	TBITS,[XWD SBSCRP,ITEM!ITMVAR!PROCED] ;NOT REALLY A STRING?
03400		 JRST	 POSN
03500		TDO	A,[XWD 2!10,ADDR] ;DO A "HRRO" ADDR
03600	
03700	; IF (POSIT(A) and NEGAT(SBITS)) or (NEGAT(A) and ¬ NEGAT(SBITS)) MUST 
03800	;    DO SOMETHING ABOUT IT
03900	
04000	POSN:	TRNE	FF,POSIT	;FIRST CONDITION
04100		TLNN	SBITS,NEGAT
04200		 JRST	 CHNGAT		; UNSATISFIED
04300		TLZ	SBITS,NEGAT	;NO LONGER NEGAT
04400		TLO	A,2!4		;DO "MOVN"
04500		JRST	CHKDX		;GO CHECK INDEXED
04600	
04700	CHNGAT:	TRNE	FF,NEGAT	;SECOND CONDITION
04800		TLNE	SBITS,NEGAT
04900		 JRST	 CHKDX		; UNSATISFIED
05000		TLO	SBITS,NEGAT	;NOW NEGAT
05100		TLO	A,2!4		;DO A "MOVN"
05200	
05300	CHKDX:	TLNN	SBITS,INDXED	;IF INDXED, NOT STRING,  NOT ADDR,  BE
05400		JRST	ADRCK
05500	;; #RE# (1 OF 1) A STRING ITEMVAR ARRAY NOT A STRING ARRAY
05600	;; #UE# ! (2 OF 3) STRING ARRAY INDXED TEMPS EXIST TOO
05700		TDNE	TBITS,[XWD SBSCRP,ITMVAR!ITEM]
05800		JRST	CHKDX2
05900		TRNE	TBITS,STRING
06000		JRST	ADRCK		;DOES NOT NEED A HRRO, HRROI
06100	CHKDX2:
06200	;; # RE#
06300	;;#TE# DAMNED CODE WAS PUTTING RESULT OF GET ADDR INAC
06400		TRNN	FF,ADDR
06500		 TLOA	 A,2		; SURE SOME SORT OF MOVE GETS DONE
06600		TRO	A,ADDR		;IN CASE OF INDXED THING, OK TO SAY "INAC"
06700		JRST	ADRCKD		;(IF WAS STRING, MARKING INAC DOESN'T HURT)
06800	ADRCK:	TRNE	FF,ADDR		;NOW COPY THIS INTO A
06900	;;#TE# ! USED TO BE A TRO A,ADDR
07000		 TDO	 A,[400,,ADDR]	;LIKE ALL CPA'S.
07100		TRNE	A,ADDR
07200		 JRST	GETWD		;WANT THE ADDRESS
07300	ADRCKD:
07400		TDNN	TBITS,[SBSCRP,,PROCED!ITEM!ITMVAR]	;THESE ARE BOGUS
07500		TRNN	TBITS,DBLPRC
07600		 JRST	GETWD		;NOT DOUBLE
07700		TLO	A,1000		;USE DBL MOVES
07800		IORI	FF,DBL		;AND DBL ACS
07900	
     

00100	
00200	GETWD:	TRNN	FF,NONSTD	;THE NON-STANDARD TYPE WILL 
00300					;**ALWAYS** GET AN AC.
00400		TLNE	A,1		;NEED AC?
00500		PUSHJ	P,GETAC		; YES, GOT IT
00600		TLNN	A,2		;NEED TO MOVE?
00700		JRST	[TLNN SBITS,INAC!PTRAC ;STRIVE TO PUT BITS BACK RIGHT
00800			  JRST	 TMPRET
00900			 TLNE SBITS,INDXED
01000			  JRST	 IDXRET
01100			 JRST	GETRET]	;BEST AS POSSIBLE THE SAME AS ON ENTRY
01200		MOVE	TEMP,A		;SAVE BITS SO YOU CAN TEST THEM
01300		PUSH	P,A		;SAVE LH BITS
01400		HRLI	A,(<MOVE>)	;ASSUME "MOVE"
01500		TLNE	TEMP,1000	;DOUBLE?
01600		 HRLI	A,(<DMOVE>)
01700		TLNE	TEMP,4		;MOVN?
01800		 JRST	[HRLI	A,(<MOVN>)	; YES
01900			TLNE	TEMP,1000
02000			 HRLI	A,(<DMOVN>)	;DOUBLE MOVN
02100			 JRST	.+1]
02200		TLNN	TEMP,20!10	;HRRO OR HRROI?
02300		JRST	NOHRRO		;NO
02400		TRO	A,FXTWO
02500		HRLI	A,(<HRRO>)
02600		TLNE	TEMP,20	;ETC.
02700		HRLI	A,(<HRROI>)
02800	NOHRRO:
02900		PUSH	P,PNT
03000		TRNE	TBITS,ITMVAR
03100		TLNN	TBITS,MPBIND	;IF NOT ?ITEMVAR
03200		JRST	NOTMPP		;CONTINUE
03300		TRZ	A,ADDR
03400	;; JRL FOLLOWING WAS MISTAKENLY A HRRI
03500		HRLI	A,(<MOVEI @>)
03600		TRNE	TEMP,ADDR	;ADDR REQUESTED
03700	;; JRL FOLLOWING WAS MISTAKENLY A HRRI
03800		HRLI	A,(<MOVE>)
03900		JRST	EMTMOV		;EMIT THE MOVE
04000	NOTMPP:	TLNE    TEMP,100	;FOR GET ADDR 
04100		 HRLI	 A,(<MOVEI>)
04200		TRO	A,IMMOVE	;IF POSSIBLE
04300	
04400		TRNE	TBITS,ITEM	;OH MY GOSH AROODIES.
04500		JRST	[TLNN	TBITS,FORMAL!SBSCRP
04600			MOVE	PNT,$VAL2(PNT)	; IT WILL BE AN INTEGER....
04700			JRST EMTMOV]
04800	REC <
04900	NORGC <
05000		TLNN	 TEMP,100		;SPECIFIED IMMEDIATENESS
05100		TLNN	 TEMP,200		;NO, THEN RECORD KLUGE IS A LIVE OPTION
05200		JRST	 EMTMOV			;NOT A RECORD KLUGERY INSTANCE
05300	RECKL2:	HRLI	A,(<SKIPE>)		;NEED TO BUMP REF CNT IF NOT NULL
05400	;;BUG TRAP
05500		TRZE	A,USCOND
05600		ERR	<DRYROT: USCOND ON AT RECKL2>,1
05700		PUSHJ	P,EMITER
05800		HRLOI	A,(<AOS>)		;
05900		TLO	A,(D)			;PUT AC NUMBER IN PLACE
06000		TLZ	FF,RELOC		; NOT A RELOCATABLE -1 !
06100		PUSHJ	P,CODOUT		; AOS -1(AC)
06200	
06300		SKIPA				;SKIP OVER EMITER CALL AT EMTMOV
06400	
06500	>;NORGC
06600	>;REC
06700	EMTMOV:	PUSHJ	P,EMITER
06800		POP	P,PNT		;IN CASE OF ITEM.
06900	
07000		POP	P,A
07100		TLNE	TBITS,MPBIND
07200		JRST	[TLO	SBITS,INAC
07300			 TRNN	A,ADDR	;ADDR?
07400			 JRST	ALLRET	;NO.
07500	;; #PA#!(1OF 2) SAVE C ON CALL TO GET
07600			 PUSH	P,C
07700			 HRLZI	C,20	;INDIRECT BIT
07800			 EMIT	<TLZN ,USADDR!NORLC>
07900	;; #PA#!(2 OF 2) RESTORE C
08000			 POP	P,C
08100			 EMIT	<MOVEI	,0>
08200			 TLZ	SBITS,INAC
08300		 	 JRST	TMPRET] ;DON'T REMEMBER ADDR IS IN AC
08400	
08500	
08600	;;#TE# DONT WANT TO ALWAYS REMEMBER THIS AC IN $ACNO
08700	GETRET:	TLNN	A,400		;WAS IT REGULAR VBL, GET (ADDR)
08800		TRNE	FF,NONSTD	;SPECIAL CASE OF PRESERVING INDXD TEMPS
08900		JRST	[MOVE SBITS,$SBITS(PNT) ;RESTORE OLD MARKING.
09000			 JRST TMPRT1]	;AND FINISH OUT.
09100		TLZ	SBITS,PTRAC!INDXED!INAC ;START FROM SCRATCH
09200		TLNN	A,20!40!100	;INAC  MARKING?
09300		 JRST 	 STDRET		; YES, DO IT
09400	
09500	IDXRET:	TLO	SBITS,PTRAC!INDXED;KEEP INDXED BITS
09600		TLNN	A,20!100	;HRROI (MOVEI) THING?
09700		 JRST	 ALLRET		; NO
09800		TLZ	TBITS,OWN
09900		HLLZS	$VAL(PNT)	; NO DISPL ANYMORE
10000		JRST	ALLRET
10100	
10200	STDRET:	TDNN	TBITS,[XWD SBSCRP,ITEM!ITMVAR] ;NOT REALLY A STRING?
10300		TRNN	TBITS,STRING	;KEEP BITS OFF IF STRING
10400		TLO	SBITS,INAC
10500	ALLRET:	HRRM	PNT,ACKTAB(D)	;UPDATE SEMANTICS AND
10600		HRRM	D,$ACNO(PNT)	; ACKTAB
10700		TLNN	SBITS,PTRAC
10800		TDNE	TBITS,[SBSCRP,,PROCED!ITEM!ITMVAR]	;THESE ARE BOGUS
10900		 JRST	.+3
11000		TRNE	TBITS,DBLPRC
11100		 JRST	[MOVEI	TEMP,(D)
11200			CAIN	TEMP,RF-1
11300			 ERR	<DRYROT ALLRET>,1
11400			CAIE	TEMP,RF-1
11500			 HRRM	PNT,ACKTAB+1(D)	;SECOND AC OF DOUBLE
11600			JRST	.+1]
11700		
11800	TMPRET:	MOVEM	SBITS,$SBITS(PNT) ;IF ACCOP, THIS WILL BE NECESSARY
11900	TMPRT1:	TRNN	FF,MRK		;DOES HE WANT A MARK?
12000		 JRST	 POST		;ALL DONE.
12100		PUSHJ	P,REMOP		;AFTER ALL THAT?
12200		JRST	MARK1		;AH, WELL
12300	
     

00100	COMMENT ⊗STACK -- Issue Instrs. to Stack Anything on Approp. Stack⊗
00200	
00300	↑↑STACK: TRNE	FF,PREMASK	;ANY TO DO?
00400		 PUSHJ	 P,PRE
00500		PUSHJ	P,STACK1
00600		TRNN	FF,MRK		;HAS HE ASKED FOR A MARK?
00700		 JRST	 POST		;FINISH OUT.
00800		JRST	MARK1		;AND DO A MARK.
00900	
01000	
01100	STACK1: PUSH	P,FF		;SAVE
01200		TRNN	SBITS,DLFLDM	;DOES HE LIVE IN THE STACK?
01300		TLNE	SBITS,INDXED
01400		PUSHJ	P,ACCOP		;GET ACCESS.
01500		TDNE	TBITS,[XWD SBSCRP,ITEM!ITMVAR]	;ALWAYS STACK ARRAYS ON P-STACK
01600		 JRST	 ASTACK		; NO MATTER WHAT
01700		TRNN	FF,ADDR		;MUST BE A CALL BY REF.
01800		TRNN	TBITS,STRING	;STRING STACK?
01900		JRST	ASTACK		;NO -- ARITHMETIC
02000		TLNE	SBITS,STTEMP	;IF STTEMP and INUSE,
02100					; ALREADY STACKED, DON'T DO AGAIN
02200		 JRST	 MARTK		;JUST MARK AND QUIT
02300	
02400	
02500		MOVEI	D,RSP			;TO AVOID CLOBBERING CORE.
02600		MOVE	A,[PUSH RSP,STAK!BPWORD!LNWORD!ADOP!REM]
02700		TRNE	FF,REM		; IF REM BIT IS ON IN FF THEN DON'T REMOP IN 
02800		TRZ	A,REM		;  STROP1 SINCE POST WILL DO IT
02900		PUSHJ	P,STROP1		;THIS IS REALLY EASY.  DO TWO PUSHES.
03000	;; FOLLOWING WAS ERRONEOUSLY TO MARTK THUS REMOPING BLOCK TWICE
03100	;; #ML ACTUALLY NEED TO LOAD SBITS AGAIN SHOULD BE MARTJ
03200		JRST	MARTJ			;AND NOW MARK THINGS.
03300	
03400	
03500	
03600	ASTACK:	TLZN	SBITS,NEGAT	;ARE THINGS CURRENTLY NEGATIVE?
03700		JRST	OKPO		;NO
03800		TLNN	SBITS,INAC!PTRAC
03900		ERR	<DRYROT -- STACK NEGAT IN CORE?>,1
04000		HRL	C,$ACNO(PNT)
04100		TRNE	TBITS,DBLPRC
04200		 JRST	[HLR	D,C	;SAME AC AS ADDR
04300			EMIT	(DMOVN USADDR!NORLC)	;DMOVN AC,AC
04400			JRST	ASTA.1]
04500		EMIT	(MOVNS USADDR!NORLC!NOUSAC)
04600	ASTA.1:	MOVEM	SBITS,$SBITS(PNT);FOR THE EMITER.
04700	OKPO:	
04800	REC <
04900	NORGC <
05000		TRNE	TBITS,PNTVAR	;IS IT A PNTVAR (IE RECORD)
05100		TRNE	TBITS,777777-(PNTVAR!GLOBL) ;
05200		JRST	OKPO.1		;NO
05300		TRNE	FF,ADDR		;WANT ADDRESS?
05400		JRST	OKPO.1		;WON'T WORK ANYHOW
05500		PUSH	P,FF		;
05600		GENMOV	(GET,MRK)	;GET IT & MARK IT 
05700		POP	P,FF
05800	OKPO.1:				;
05900	>;NORGC
06000	>;REC
06100		
06200		TLNE	TBITS,MPBIND	;A ?ITEMVAR
06300		JRST	[TRNE FF,ADDR	;ADDRESS REQUIRED?
06400			 ERR <DRYROT -STACK ADDR ? ITEMVAR>
06500			 TLNE SBITS,PTRAC!INAC
06600			 JRST .+1
06700			 PUSH P,D
06800			 PUSHJ	P,GETAC
06900			 EMIT	<MOVEI @,>
07000			 PUSHJ	P,MARKINT
07100			 POP	P,D
07200			 JRST	.+1]
07300		HRLZI	A,(<PUSH RP,>)
07400		TRNE	FF,ADDR		;COPY THIS BIT.
07500		 TRO	 A,ADDR
07600		TRO	A,NOUSAC	;WE HAVE SPECIFIED IT.
07700		PUSHJ	P,EMITER	;PUT OUT THE PUSH.
07800		AOS	ADEPTH		;SINCE WE USED THE PSTACK
07900		TDNE	TBITS,[SBSCRP,,PROCED!ITEM!ITMVAR]	;THESE ARE NOT DOUBLE
08000		 JRST	MARTK
08100		TRNE	TBITS,DBLPRC
08200		TRNE	FF,ADDR
08300		 JRST	MARTK		;ADDR OR NOT DOUBLE
08400		EMIT	(<PUSH RP,NOUSAC!FXTWO>)	;SECOND WORD
08500		AOS	ADEPTH
08600	MARTK:	TRNN	FF,REM		;IF REM BIT IS ON THEN DON'T DO REMOP SINCE POST 
08700					; WILL DO IT
08800		PUSHJ	P,REMOP		;REMOVE THE THING YOU'RE STACKING
08900	MARTJ:	MOVE	SBITS,$SBITS(PNT);GET ITS BITS BACK FOR THE REST OF THIS
09000	MARTH:	POP	P,FF		;RESTORE
09100		POPJ	P,
09200	
     

00100	COMMENT ⊗MARK, MARKINT, MARKME -- Mark Semblk with Correct Temp Semantics
00200	 This marks the AC (D) with a temp descriptor of type in SBITS, TBITS⊗
00300	
00400	↑↑MARK:	TRNE	FF,PREMASK	;
00500		PUSHJ	P,[TRNE FF,657777
00600			   ERR <MARK>,1
00700			   JRST PRE]
00800		PUSHJ	P,MARK1
00900		JRST	POST		;ALL DONE.
01000	
01100	MARK1:	ANDI	TBITS,MASK	;WANT ONLY THE TYPE BITS (NOT FORMAL,ETC.)
01200	;;#NK# ! (1 OF 2) TEMPS SHOULD NOT HAVE DISPLAY LEVELS
01300		TDZ	SBITS,[CORTMP!PTRAC!INDXED!FIXARR,,DLFLDM]
01400	;;#HS# JRL AN ITEMVAR IS NOT ITS DATUM
01500		TRNE	TBITS,ITMVAR!ITEM
01600		JRST	.+3
01700	;;#HS#
01800		TRNE	TBITS,STRING		;IF STRING TYPE, THEN
01900		 JRST	 STMARK
02000		TLO	SBITS,INAC!ARTEMP!INUSE	;SINCE HE MAY NOT HAVE SET THEM.
02100		TLZ	SBITS,STTEMP
02200		HRRE	LPSA,ACKTAB(D)		;PICK UP TEMP DESCIRIPTOR
02300		JUMPLE	LPSA,NOTEM		;IF NO TEMP OR REMOPPED TEMP
02400		MOVE	USER,$SBITS(LPSA)	;GET SEMANTIC BITS
02500		TLNN	USER,INUSE		;A TEMP?
02600		 JRST	 REMM			;NO
02700		TLNN	USER,CORTMP		;A CORE TEMP?
02800		 JRST	 USOLD			;NO -- USE THE TEMP THAT IS THERE.
02900		TLNE	USER,INAC		;IS IT STILL IN THE ACCUMULATOR?
03000		 PUSHJ	 P,STORA		;YES --STORE IT.
03100		
03200		SKIPA
03300	REMM:	PUSHJ	P,CLEARL		;DO THE REMOP
03400	NOTEM:	PUSHJ	P,GETTEM		;GET A NEW TEMPORARY
03500	USOLD:	HRRM	LPSA,ACKTAB(D)		;INSERT IN AC TABLE RIGHT HALF
03600		TLNN	SBITS,PTRAC
03700		TDNE	TBITS,[SBSCRP,,PROCED!ITEM!ITMVAR]
03800		 JRST	.+3
03900		TRNE	TBITS,DBLPRC
04000		 JRST	[
04100	;;#YX# 3! JFR 2-10-77 SPURIOUS MESSAGE FOR X←-((Y+Z)+Z);
04200			MOVE	TEMP,ACKTAB(D)
04300			CAMN	TEMP,ACKTAB+1(D)
04400			 JRST	.+1		;ALREADY SAME, ASSUME RE-USE
04500			SKIPE	ACKTAB+1(D)
04600			  ERR	<DRYROT MARK DOUBLE>,1
04700			MOVEI	TEMP,(D)
04800			CAIE	TEMP,RF-1	;DO NOT CLOBBER RF!
04900			 HRRM	LPSA,ACKTAB+1(D);SECOND AC OF DOUBLE
05000			JRST	.+1]
05100		HRRM	D,$ACNO(LPSA)		;AND THE LOGICAL INVERSE.
05200	REC <
05300		TRNE	TBITS,PNTVAR		;A RECORD TEMP
05400		TRNE	TBITS,777777-(PNTVAR!GLOBL) ;
05500		JRST	MARKT			;NOPE
05600		SKIPN	TEMP,RCLASS		;BUG TRAP
05700		ERR	<DRYROT: RCLASS=0 WHEN TRYING TO MARK RECORD TEMP>,1
05800		HRLM	TEMP,$ACNO(LPSA)	;MARK IT
05900		SETZM	RCLASS			;
06000		;FALL INTO MARKT
06100	>;REC
06200	MARKT:	HRRZM	LPSA,PNT		;
06300		SETZM	$VAL(PNT)
06400	MARTS:	POPJ	P,
06500	STMARK:	TLO	SBITS,STTEMP		;IN CASE IT SKIPS AND NOONE ELSE DID
06600		TLZ	SBITS,ARTEMP
06700		HRRZ	LPSA,PNT		;IN CASE STRTMP NOT CALLED
06800		TLNN	SBITS,INUSE		;ALREADY HAS A TEMP?
06900		PUSHJ	P,STRTMP		;GET A STRING TEMP.
07000		JRST	MARKT
07100	
07200	DSCR MARKINT, MARKME
07300	DES THESE ARE ROUTINES TO HELP YOU CALL "MARK"
07400	 MARKINT -- ALWAYS MARKS A VANILLA INTEGER, RETURNS DESCR. IN PNT,SBITS,TBITS.
07500	 MARKME	-- YOU SPECIFY TBITS, SBITS=0 IS ASSUMED
07600	⊗;
07700	↑↑MARKINT: MOVEI TBITS,INTEGR		;MARK AN INTEGR,
07800	↑↑MARKME: HRRI	FF,0
07900		SETZ	SBITS,
08000		JRST	MARK1
08100	
     

00100	COMMENT ⊗INCOR -- Issue Code to Clear this Entity from ACs⊗
00200	
00300	DSCR INCOR
00400	DES makes sure that the entity mentioned in PNT,TBITS,SBITS is really
00500	 in core.  If not, the AC entry for that entity is cleared.
00600	 The updated Semantics bits are returned in SBITS.
00700	⊗;
00800	
00900	↑↑INCOR:	
01000		TLZN	SBITS,INAC!PTRAC	;GONE?
01100		POPJ	P,		;ALL DONE!
01200		PUSH	P,D		;SAVE THIS.
01300		HRRZ	D,$ACNO(PNT)	;PICK UP RELEVANT AC.
01400		PUSHJ	P,STORZ
01500		POP	P,D
01600		JRST	GETAD		;ALAS, SINCE STORZ WILL CHANGE THINGS.
01700	
     

00100	COMMENT ⊗REMOPs, CLEARs -- Remove Temps, ACs, from Use⊗
00200	
00300	DSCR REMOP,REMOPA,REMOPL,REMOP2
00400	DES These are the REMOP routines.  They say, in effect, "I am 
00500	 finished with this argument.  If it was a temp descriptor, then I
00600	 am really finished, and the temp may be returned to the pool of
00700	 such temps.  If it was a simple variable or constant, etc. then no
00800	 action is taken.  
00900	
01000	PAR The differences among the routines are only in the call form:
01100	 REMOP	-- PNT  has pointer to entity.
01200	 REMOPL	-- LPSA has pointer to entity
01300	 REMOPA	-- D has AC number of entity.
01400	 REMOP2	-- PNT2	has pointer to entity.
01500	
01600	SID AC'S USED: LPSA,TEMP,USER
01700	⊗;
01800	
01900	
02000	↑REMOP2: MOVE	LPSA,PNT2
02100		JRST	REMOPL
02200	↑REMOPA: SKIPA	LPSA,ACKTAB(D)	;REMOP BY ACCUMULATOR NUMBER
02300	↑REMOP:	MOVE	LPSA,PNT	;OH WELL.
02400	↑REMOPL: TRNN	LPSA,-1
02500		POPJ	P,		;NONE THERE.
02600		MOVE	TEMP,$SBITS(LPSA);THE STANDARD REMOP
02700		TLNN	TEMP,STTEMP!ARTEMP!INUSE ;A REAL TEMP?
02800		JRST	STCNST		;NO, CHECK IF A STRING CONSTANT
02900	DELAL:	
03000	REC <
03100	NORGC <
03200		TLNN	TEMP,INDXED
03300		JRST	DRFDON		;DONT HAVE TO DEREFERENCE IT
03400		HRRZ	USER,$VAL2(LPSA);WAS THIS GUY A RECORD SUBFIELD
03500		JUMPE	USER,DRFDON	;IF NOT, THEN NOTHING TO WORRY ABOUT
03600	
03700		SKIPN	USER,%RVARB(LPSA);UNLINK SELF FROM SUBFIELD CHAIN
03800		ERR	<DRYROT: REMOP OF SUBFIELD NOT ON SUBFIELD CHAIN>,1,SFULKD
03900		TRNE	USER,-1		;ASS END OF CHAIN ?
04000		HLLM	USER,%RVARB(USER) ;NO, MAKE THE RIGHT GUY POINT AT MY LEFT
04100		MOVS	USER,USER	;NOW LINK THE OTHER WAY
04200		HLRM	USER,%RVARB(USER) ;MY LEFT POINTER NOW POINTS AT MY RIGHT
04300		SETZM	%RVARB(LPSA)	;TIDY UP
04400	SFULKD:				;UNLINKING DONE NOW
04500	
04600		HLLZS	$VAL2(LPSA)	;MAKE SUBFIELD FLAG ZERO AGAIN
04700		HLRZ	USER,%TLINK(LPSA); WAS THIS THING HANGING RECD REF
04800		CAIN	USER,-1		;IF SO,THIS IS -1
04900		JRST	DREFIT		;IT WAS, MUST DE-REFERENCE THIS ONE
05000	
05100		PUSH	P,USER		;I AM A SUBFIELD OF A FIELD
05200		PUSHJ	P,DRFDON	;KILL MYSELF OFF
05300		POP	P,LPSA		;THEN REMOP THE FIELD I HUNG OFF OF
05400		JRST	REMOPL		;
05500		
05600	DREFIT:
05700		SETZM	$VAL(LPSA)	;SO THAT THE DEREF WORKS
05800	
05900		PUSH	P,A		;SAVE SOME ACS
06000		PUSH	P,C		;
06100		PUSH	P,PNT		
06200		PUSH	P,TEMP
06300		PUSH	P,LPSA
06400	;;#RY# MUST DO RECUUO ON AC, NOT (AC)
06500		MOVE	TEMP,$SBITS(LPSA)
06600		MOVEI	C,ARTEMP+INAC+INUSE
06700		TLNE	TEMP,CORTMP
06800		TRC	C,INAC+CORTMP
06900		HRLM	C,$SBITS(LPSA)
07000	;;#RY#
07100		MOVNI	C,1		;TO DO DEREFERENCING BY 1, SET C TO -1
07200		MOVE	PNT,LPSA	;THE THING TO DEREFERENCE
07300		PUSHJ	P,RFCADJ	;ADJUST REFERENCE COUNT
07400					;**** NOTE: MAY BE SAFER TO PUT THESE
07500					;     ONTO SOME "HANG LIST" UNTIL STATEMENT LEVEL
07600					;     THIS IS BETTER, THOUGH, IF NOTHING BAD HAPPENS
07700	
07800		POP	P,LPSA		;RECOVER THESE FROM EARLIER
07900		POP	P,TEMP
08000		POP	P,PNT		;
08100		POP	P,C
08200		POP	P,A
08300	
08400	DRFDON:
08500	
08600	;; HERE CAN FALL INTO THE REST OF THE DELALL CODE.  THIS WILL BE OK
08700	;; SO LONG AS (1) DON'T SUFFER THE LOSSAGE I FEAR ABOUT ROUTINES ASSUMING
08800	;; REMOP LEAVES PCNT THE SAME (ONE KLUGE WOULD BE TO SET A FLAG TO ALLOW
08900	;; THE NEXT CALL TO ACCESS TO DO THE "RIGHT" THING, BUT UGH!
09000	;; (2) THE CODE ABOVE ONLY GOBBLES THE SORT OF INDEXED TEMPS I EXPECT IT TO
09100	;; IF NOT, MORE TESTING & MARKING IS REQUIRED
09200	>;NORGC
09300	RGC <
09400	;;#WD# RHT 1-25-76 MAKE SURE THAT DEPENDENT TEMP TO STRING GOES, TOO.
09500		MOVE	USER,$TBITS(LPSA)	;
09600		TLNE	TEMP,INDXED		;INDEXED 
09700		TRNN	USER,STRING!DBLPRC	;STRING, TOO
09800		JRST	RMP.00			;NOPE
09900		TDNE	USER,[XWD SBSCRP,PROCED!ITEM!ITMVAR] ;EXCEPT FOR THESE
10000		JRST	RMP.00
10100		HRRZ	USER,$VAL2(LPSA)	;IS IT SUBFIELD
10200		JUMPE	USER,RMP.00		;NO
10300		PUSH	P,LPSA			;SAVE STATE
10400		PUSH	P,TEMP			;
10500		HLRZ	LPSA,$ACNO(LPSA)	;HAVE WE A DEPENDENT?
10600		SKIPE	LPSA
10700		PUSHJ	P,REMOPL		;YUP, FLUSH HIM, TOO
10800		POP	P,TEMP
10900		POP	P,LPSA
11000		JRST	RMP.1			;STRING SUBFIELD INDXED TEMPS
11100						;DO NOT HAVE RECORDS AT ALL
11200	RMP.00:
11300	;;#WD# ↑
11400		TLNN	TEMP,CORTMP		;ONLY CORTMPS ARE SPECIAL
11500		JRST	RMP.1			;
11600		TLNN	TEMP,INDXED		;INDXED CORTMP??
11700		JRST	RMP.0			;NOPE
11800		HRRZ	USER,$VAL2(LPSA)	;RECORD SUBFIELD??
11900		JUMPE	USER,RMP.1		;NOPE
12000		MOVSI	USER,CORTMP!INUSE!ARTEMP;MAKE INTO A RECORD CORTMP
12100		MOVEM	USER,$SBITS(LPSA)
12200		MOVEI	USER,PNTVAR
12300		MOVEM	USER,$TBITS(LPSA)	;LIKE SO
12400		JRST	RMP.RC			;PUT IT ONTO THE RIGHT RING
12500		
12600	RMP.0:
12700		MOVE	USER,$TBITS(LPSA)	;
12800		TRNE	USER,PNTVAR		;WAS IT A RECORD CORTMP
12900	;;#VQ# ! RECORD ARRAYS ARE ALSO OK
13000		TDNE	USER,[XWD SBSCRP,ITEM!ITMVAR]	;THESE ARE OK
13100		JRST	RMP.1			;NOPE
13200	RMP.RC:	
13300	;;%##% BUG TRAP
13400		HRRZ	USER,RCTEMP		;WAS THIS GUY ALREADY ON THE CHAIN
13500		JUMPE	USER,RMP.0R		;NO CHAIN
13600		CAIN	USER,(LPSA)		;WELL?
13700		ERR	<DRYROT: RECORD CORTMP REMOP>,1
13800		HRRZ	USER,(USER)		;CHAIN
13900		JUMPN	USER,.-3
14000	RMP.0R:			;;%??% INSERTED HERE BY JFR 11-16-75
14100	;;%##% ↑
14200		HRRZ	USER,LPSA		;
14300		EXCH	USER,RCTEMP		;
14400		HRRZM	USER,%TLINK(LPSA)	;REMEMBER IT AS AN AVAILABLE 
14500		JRST	IACCHK			;RECORD TEMP
14600						;(NOTICE THAT INUSE WAS LEFT ON)
14700	RMP.1:
14800	>;RGC
14900	>;REC
15000		MOVSI	USER,INUSE!STTEMP!INAC!PTRAC!NEGAT!FIXARR ;TURN THESE OFF
15100		ANDCAM	USER,$SBITS(LPSA) ;IN MEMORY.
15200	IACCHK:	HRRZ	USER,$ACNO(LPSA) ;GET THE AC IT WAS IN
15300		TLNN	TEMP,INAC!PTRAC	;WAS IT IN AN AC?
15400		 JRST	 CTCHK		;NO -- ALL DONE.
15500		SKIPGE	ACKTAB(USER)	;YES --TURN IT OFF.
15600		ERR	<DRYROT -- REMOP>,1
15700		SETZM	ACKTAB(USER)
15800		TLNN	TEMP,PTRAC
15900		TDNE	TBITS,[SBSCRP,,PROCED!ITEM!ITMVAR]
16000		 JRST	.+3
16100		TRNE	TBITS,DBLPRC
16200		 JRST	[CAIN	USER,RF-1
16300			  ERR	<DRYROT IACCHK>,1
16400			CAIE	USER,RF-1
16500			 SETZM	ACKTAB+1(USER)
16600			JRST	.+1]
16700	CTCHK:	TLNE	TEMP,INUSE	;If this was still an alive temp, and
16800		TLNE	TEMP,CORTMP	; was not a CORTMP, thus contains no fixups
16900		POPJ	P,		; or anything, we can release it to free
17000		PUSH	P,LPSA		; storage.  Otherwise, leave it on the TTEMP
17100		PUSHJ	P,BLKFRE	; list (where it MUST be), and forget it.
17200		POPJ	P,
17300	
17400	
17500	STCNST:	MOVE	TEMP,$TBITS(LPSA) ;
17600		TLNE	TEMP,CNST	;
17700		TRNN	TEMP,STRING	;
17800		POPJ	P,		; RETURN IF NOT A STRING CONSTANT 
17900		MOVE	TEMP,$PNAME(LPSA) ; CHECK IF TRYING TO REMOP NULL STRING WHICH IS 
18000		TRNN	TEMP,-1		;  ONLY STRINS'ED ONCE 
18100		POPJ	P,		; YES, DON'T REMOP
18200		SOSLE	TEMP,$VAL2(LPSA) ; DECREMENT REFERENCE COUNT AND GET OUT IF NOT 
18300		POPJ	P,		;  ZERO
18400		JUMPE	TEMP,.+2	; ZERO COUNT? 
18500		ERR	<DRYROT REMOP:STCNST> ; 
18600		SKIPN	$VAL(LPSA)	; USED IN PRELOAD? 
18700		SKIPE	$ADR(LPSA)	; USED IN FIXUP? 
18800		POPJ	P,		; YES, RETURN 
18900		PUSHJ	P,URGCST	; REMOVE FROM STRING CONSTANT RING 
19000		PUSHJ	P,URGSTR	; REMOVE FROM STRING RING 
19100		PUSH	P,PNAME		; SAVE PNAME AND PNAME+1 (OK ON P STACK SINCE NO 
19200		PUSH	P,PNAME+1	;  GARBAGE COLLECTION CAN HAPPEN) 
19300		HRROI	TEMP,$PNAME+1(LPSA) ; GET STRING DESCRIPTOR FOR HASH LOOKUP SO THE 
19400		POP	TEMP,PNAME+1	;  STRING CAN BE REMOVED FROM THE HASHED SYMBOL 
19500		POP	TEMP,PNAME	;  TABLE 
19600		PUSH	P,TBITS		; SAVE AC'S WHICH SHASH WILL DESTROY 
19700		PUSH	P,A		; 
19800		PUSH	P,B		;
19900		PUSH	P,C		;
20000		PUSH	P,D		;
20100		PUSH	P,PNT		;
20200		PUSH	P,LPSA		; 
20300		MOVE	LPSA,STRCON	; USE STRING HASH TABLE 
20400		PUSHJ	P,SHASH		; 
20500		MOVE	B,HPNT		; INSTRUCTION TO LOAD FIRST IN CONFLICT LIST 
20600		XCT	B		; FIRST IN CONFLICT LIST INTO LPSA 
20700		HRRZ	PNT,(P)		; THE ONE WE ARE LOOKING FOR 
20800		MOVEI	A,LPSA		;
20900	SCOMLP:	HRRZ	TEMP,(A)	; CANDIDATE? 
21000		JUMPE	TEMP,ERRSTC	; NOT THERE - ERROR 
21100		CAMN	TEMP,PNT	;
21200		JRST	SFNDIT		; 
21300		MOVE	A,TEMP		; CHAIN DOWN CONFLICT LIST 
21400		JRST	SCOMLP		; 
21500	SFNDIT:	HRRZ	TEMP,(TEMP)	; NEXT IN LIST 
21600		HRRM	TEMP,(A)	; CHAIN AROUND DELETED ELEMENT 
21700		TLO	B,2000		; CHANGE FROM LOAD TO STORE 
21800		XCT	B		; 
21900		FREBLK	(PNT)		; 
22000		POP	P,LPSA		; RESTORE AC'S 
22100		POP	P,PNT		; 
22200		POP	P,D		; 
22300		POP	P,C		; 
22400		POP	P,B		; 
22500		POP	P,A		; 
22600		POP	P,TBITS		; 
22700		POP	P,PNAME+1	; 
22800		POP	P,PNAME		; 
22900		POPJ	P,		;
23000	ERRSTC:	ERR	<DRYROT AT REMOP>,1 ;
23100	
     

00100	DSCR CLEAR,CLEARL,CLEARA
00200	DES These are routines to clear an entry in the AC table (ACKTAB)
00300	 That is, all memory of what is in the AC is lost.  The difference
00400	 among the routines is the call form:
00500	
00600	PAR CLEAR -- PNT has pointer to entity to be "cleared"
00700	 If it turns out not to be in an AC, no action is taken.
00800	 CLEARL -- LPSA has pointer; same deal.
00900	 CLEARA  -- D has AC number to be cleared.
01000	
01100	SID AC'S USED: LPSA,TEMP
01200	⊗;
01300	
01400	↑CLEAR:	MOVEI	LPSA,(PNT)	;CLEAR OUT AN AC TABLE ENTRY.
01500	↑CLEARL: MOVE	TEMP,$SBITS(LPSA) ;SEE IF IT IS IN AN AC.
01600		TLNN	TEMP,INAC!PTRAC  ;IF NOT -- ALL DONE.
01700		 POPJ	 P,		;DONE.
01800		MOVE	TEMP,$ACNO(LPSA) ;AC IT IS IN.
01900	;;#YJ# 2! JFR 1-13-77 QUIT IF NOTHING THERE
02000		SKIPN	ACKTAB(TEMP)
02100		 JRST	CLR1
02200		SETZM	ACKTAB(TEMP)	;AND ZERO THE ENTRY.
02300		MOVE	TEMP,$SBITS(LPSA)
02400		TLNE	TEMP,PTRAC
02500		 JRST	CLR1		;POINTERS ARE NOT LONG
02600		MOVE	TEMP,$TBITS(LPSA)
02700		TDNN	TEMP,[SBSCRP,,PROCED!ITEM!ITMVAR]	;LEAP IS NOT LONG
02800		TRNN	TEMP,DBLPRC	;LONG?
02900		 JRST	CLR1		;NO
03000		HRRZ	TEMP,$ACNO(LPSA);YES, REFETCH AC
03100		JRST	CLR2
03200	
03300	↑CLEARA:
03400		SKIPN	LPSA,ACKTAB(D)
03500		 POPJ	P,		;NOTHING THERE
03600		CAMN	LPSA,ACKTAB-1(D)	;POSSIBLE DBLPRC SCREWUP?
03700		 SOJA	D,[PUSHJ P,CLEARA	;YES, CLEAR FIRST AC INSTEAD
03800			   AOJA D,CPOPJ]	;RESTORE D
03900		SETZM	ACKTAB(D)	;ZERO AC TABLE ENTRY
04000		MOVE	TEMP,$SBITS(LPSA)
04100		TLNE	TEMP,PTRAC
04200		 JRST	CLR1		;POINTERS ARE NOT LONG
04300		MOVE	TEMP,$TBITS(LPSA)
04400		TDNE	TEMP,[SBSCRP,,PROCED!ITEM!ITMVAR]
04500		 JRST	CLR1
04600		TRNE	TEMP,DBLPRC	;DOUBLE?
04700		 JRST	[MOVEI	TEMP,(D)
04800	      CLR2:	HLL	LPSA,ACKTAB+1(TEMP)	;MAKE COMPARISON ON RIGHT HALF ONLY
04900			CAIE	TEMP,RF-1	;MAKE THIS IRON-CLAD
05000			CAME	LPSA,ACKTAB+1(TEMP);NEXT AC SHOULD BE SAME
05100			  ERR	<DRYROT CLEAR DOUBLE>,1
05200			CAIE	TEMP,RF-1
05300			 SETZM	ACKTAB+1(TEMP)	;CLEAR SECOND AC
05400			JRST	.+1]
05500	CLR1:	MOVSI	TEMP,INAC!PTRAC!NEGAT
05600		TRNE	LPSA,-1	;ANYTHING THERE? (DCS -- 8/16/70)
05700		ANDCAM	TEMP,$SBITS(LPSA) ;TURN THESE OFF IN MEMORY.
05800		POPJ	P,
05900	
     

00100	COMMENT ⊗STROP -- Bit-Driven String Operation Code Generator⊗
00200	
00300	DSCR STROP
00400	DES This routine is willing to do lots of twiddling on strings.
00500	 It knows about reference strings, etc. 
00600	PAR A is an instruction for the EMITTER, with some bits in
00700	 it to say what things should be done with this instruction.  
00800	Bits in A: 	bpword		-- issue the instruction for
00900					 the byte pointer word.
01000			lnword		-- or for the length word.
01100			bpfirst		-- issue the byte pointer inst. first.
01200			adop		-- this is an instruction which adds to stack.
01300			sbop		-- this is an instruction which subs from stack.
01400			undo		-- so a SUB SP,X22 at end.
01500			rem		-- do a remop when done.
01600	
01700			stak		-- used internally.
01800			bpinc		-- byte pointer instruction is in c(rh)
01900	
02000	 PNT,TBITS,SBITS -- semantics of string.
02100	
02200	 D -- accumulator to use for ac field of op.
02300	  Thus, it must be RSP if that stack is to be used.
02400	⊗;
02500	
02600	
02700	↑STROP:	CAIN	D,RSP		;IF THE STACK,
02800		TRO	A,STAK		;THEN MARK AS SUCH.
02900		DPB	D,[POINT 4,A,12] ;SAVE IN AC FIELD OF INSTRUCTION.
03000		PUSHJ	P,ACCOP		;AND GET ACCESS TO THE ROUTINE.
03100					;THIS UPDATES SBITS IN CORE.
03200	STROP1:	PUSH	P,ACKTAB(D)	;PROTECT.
03300		SETOM	ACKTAB(D)
03400		PUSH	P,D		;SAVE AC.
03500		TLNN	TBITS,REFRNC	;THE HARD CASE.
03600		JRST	OPPP1		;
03700		PUSH	P,A		;SINCE GETOPE DOES NOT PRESEVE.
03800		HRRI	FF,ADDR!INDX
03900		PUSHJ	P,GETOPE	;GET THE ADDRESS OF THE BP WORD IN AN AC.
04000					;THIS UPDATES SBITS IN CORE.
04100		SETZM	ACKTAB(D)	;WE DO NOT WANT TO SEE THIS AGAIN.
04200		HRLZS	D		;READY FOR INDEXING.
04300		POP	P,A
04400	OPPP1:	TLNE	SBITS,STTEMP	;IF STACKED, THEN NEED
04500		 HRLI	 D,RSP		;THE STACK
04600		HRRI	FF,(A)		;SAVE BITS.
04700		TRNE	FF,BPFIRST	;IF BYTE POINTER WORD FIRST, DO IT
04800		 PUSHJ	 P,BP
04900		PUSHJ	P,LN		;NOW THE LENGTH
05000		TRNN	FF,BPFIRST
05100		 PUSHJ	 P,BP
05200		
05300		TRNE	FF,UNDO
05400		TLNN	SBITS,STTEMP	;IF UNDO AND A STACKED STRING.
05500		JRST	OP2		;
05600		PUSHJ	P,SUBIT
05700	OP2:	POP	P,D		;RESTORE.
05800		POP	P,ACKTAB(D)
05900		TRNE	FF,REM		;IF REMOP ASKED FOR.
06000		 JRST	 REMOP
06100		POPJ	P,		;ALL DONE.
06200	
06300	
06400	DSCR SUBIT
06500	DES Emits a SUB SP,[XWD 2,2], and subtracts two from SDEPTH.
06600	⊗;
06700	↑SUBIT:
06800	;;%DN% JFR 7-2-76
06900	;;	PUSH	P,A
07000		MOVNI	A,2
07100		ADDM	A,SDEPTH
07200		HRLI	C,-2
07300		JRST	ESPADJ
07400	;;	MOVE	A,X22		;SUBTRACT TWO FROM THE STACK.
07500	;;	PUSH	P,PNT
07600	;;	PUSHJ	P,CREINT
07700	;;	EMIT	(<SUB RSP,NOUSAC>) ;THEN ISSUE THE SUBS.
07800	;;	PUSHJ	P,REMOP		;JUST IN CASE
07900	;;	POP	P,PNT
08000	;;	MOVNI	A,2
08100	;;	ADDM	A,SDEPTH	;UPDATE COUNT.
08200	;;	POP	P,A
08300	;;	JRST	GETAD		;RESTORE TBITS,SBITS.
08400	;;%DN% ↑
08500	
08600	BP:	TRNN	FF,BPWORD	;ONLY IF ASKED FOR.
08700		 POPJ	 P,
08800		PUSH	P,A		;SAVE
08900		TRNE	FF,BPINC	;IF ANOTHER INSTRUCTION AROUND.
09000		 DPB	 C,[POINT 9,A,8] ;IN INSTRUCTION PARTS.
09100		HRRI	A,NOUSAC!FXTWO	;TENTATIVE BITS TO EMITER.
09200		TLNN	SBITS,STTEMP	;IF ON STACK OR
09300		TLNE	TBITS,REFRNC	;BUT IF THIS CASE, THEN
09400		TRC	A,FXTWO!NORLC!USX!USADDR
09500		HRLI	C,0		;WITH NO DISCPLACEMENT.
09600		PUSHJ	P,EMITER
09700		POP	P,A
09800		JRST	FINBP
09900	
10000	LN:	TRNN	FF,LNWORD	;ONLY IF ASKED
10100		 POPJ	 P,
10200		HRRI	A,NOUSAC
10300		TLNN	SBITS,STTEMP	;IF TEMP OR
10400		TLNE	TBITS,REFRNC	;REFERENCE, THEN MUST USE
10500		TRO	A,NORLC!USX!USADDR ;INDEXING ETC.
10600		HRLI	C,-1		;ANO THIS TIME A DISPLACEMENT.
10700		PUSHJ	P,EMITER
10800	
10900	FINBP:	TRNE	FF,ADOP!SBOP	;PREPARE TO ADJUST STACK.
11000		TRNN	FF,STAK		;ONLY IF ON STACK.
11100		 POPJ	 P,		;NONE.
11200		TRNE	FF,ADOP
11300		AOSA	SDEPTH
11400		SOS	SDEPTH		;OUR BOOKKEEPING DONE,
11500		POPJ	P,		;WE DEPART.
11600	
11700	
11800	;;%DN% JFR 7-4-76
11900	DSCR	EADJSP, EPADJ, ESPADJ
12000	DES	Emits instruction to alter stack depth
12100	PAR	LH(C)	proper constant for ADJSP
12200		RH(D)	stack ac for EADJSP.
12300	RES	ADJSP emitted if allowed, else proper ADD or SUB
12400	SID	A, TEMP clobbered. PNT,TBITS,SBITS saved
12500	⊗;
12600	
12700	↑EADJSP:MOVEI	TEMP,(D)	;AC
12800		CAIE	TEMP,RP		;FIGURE OUT WHICH STACK
12900	↑ESPADJ:SKIPA	A,[ADJSP RSP,NOUSAC!USADDR!NORLC]
13000	↑EPADJ:	MOVE	A,[ADJSP RP,NOUSAC!USADDR!NORLC]
13100		MOVE	TEMP,ASWITCH
13200		TRNE	TEMP,AADJSP
13300		 JRST	EMITER		;EASY WAY
13400		PUSH	P,PNT		;SAVE THIS GUY
13500		PUSH	P,TBITS
13600		PUSH	P,SBITS
13700		JUMPL	C,.+2		;FIGURE OUT ADD OR SUB
13800		TLCA	A,(<ADJSP>≠<ADD>)
13900		TLC	A,(<ADJSP>≠<SUB>)
14000		TRZ	A,USADDR!NORLC
14100		PUSH	P,A		;SAVE INSTR FOR LATER
14200		HLRE	A,C		;COMPUTE CONSTANT
14300		MOVM	A,A
14400		HRLI	A,(A)
14500		PUSHJ	P,CREINT	;MAKE AN XWD
14600		POP	P,A		;GET INSTR BACK
14700		PUSHJ	P,EMITER	;PUT OUT INSTR, PNT POINTS TO XWD
14800		POP	P,SBITS
14900		POP	P,TBITS
15000		POP	P,PNT		;GET IT BACK
15100		POPJ	P,
15200	;;%DN% ↑
     

00100	COMMENT ⊗GETTEM, etc. -- Temp Semblk Allocators⊗
00200	
00300	DSCR GETTEM,GETCRTMP,STRTMP
00400	DES Routines for getting temp descriptor Semblks. The list of
00500	 free temps is searched for an appropriately free one.  If found,
00600	 a masked form of TBITS, and a masked form of SBITS are stored
00700	 in the Semblk for this temp. A pointer to it is returned in LPSA
00800	INCL more descriptions about temps, their numbers, how they're
00900	 moved, kept track of, deleted, depend on procedures, etc.
01000	
01100	 GETTEM -- get a non-core temp
01200	 STRTMP -- get a String temp (i.e. turn on the STTEMP bit in SBITS)
01300	 GETCRTMP -- get a core temp.
01400	
01500	SID AC'S USED: USER,LPSA,TEMP
01600	⊗;
01700	
01800	STRTMP:	TLOA	SBITS,INUSE!STTEMP
01900	↑GETTEM: TLO	SBITS,INUSE!ARTEMP	;TURN ON TEMP BITS.
02000	;;#NK# ! (2 OF 2) TEMPS SHOULD NOT HAVE DISPLAYS LEVELS
02100		TDZ	SBITS,[CORTMP,,DLFLDM]
02200		GETBLK				;GET A NEW BLOCK
02300	GTT1:	MOVEM	SBITS,$SBITS(LPSA)
02400		ANDI	TBITS,MASK
02500		MOVEM	TBITS,$TBITS(LPSA)	;GOOD BITS IN MEMORY
02600		POPJ	P,			;NOTHING ELSE TO DO
02700	
02800	↑GETCRTMP:				;GET A CORE TEMP
02900		SKIPA	LPSA,TTEMP
03000	STRG:	LEFT	,%RVARB,NOFF
03100		MOVE	TEMP,$SBITS(LPSA)
03200		TLNE	SBITS,CORTMP
03300		TLOE	TEMP,INUSE
03400		 JRST	STRG
03500		TLNE	SBITS,PTRAC
03600		 JRST	DDRET		;POINTERS ARE NOT LONG
03700		TDNN	TBITS,[SBSCRP,,PROCED!ITEM!ITMVAR]
03800		TRNN	TBITS,DBLPRC
03900		 JRST	DDRET			;NOT DBL
04000		MOVE	TEMP,$TBITS(LPSA)
04100		TDNN	TEMP,[SBSCRP,,PROCED!ITEM!ITMVAR]
04200		TRNN	TEMP,DBLPRC
04300		 JRST	STRG			;NEED DBL TEMP FOR DBL QTY
04400	DDRET:	MOVSI	SBITS,INUSE!CORTMP!ARTEMP
04500		JRST	GTT1			;FINISH OUT AS ABOVE.
04600	
04700	NOFF:	PUSHJ	P,GETTEM
04800		AOS	TEMP,TEMPNO		;INCREMENT TEMP ID NO
04900		MOVEM	TEMP,$PNAME(LPSA)	;STORE IN $PNAME FOR ADCON AND SCOUT
05000		SETZM	$ADR(LPSA)	;AND ZERO THE FIXUP.......
05100		PUSHJ	P,RNGTMP
05200		JRST	DDRET
05300	
05400	RGC <
05500	↑GETRCT:SKIPE	SIMPSW		;SIMPLE PROCEDURE??
05600		ERR	<ATTEMPT TO CREATE A RECORD TEMP INSIDE A SIMPLE PROCEDURE>,1
05700		HRRZ	LPSA,RCTEMP	;GET NEXT OFF RECORD TEMP CHAIN
05800		JUMPE	LPSA,GRCT.1	;NONE THERE
05900		HRRZ	TEMP,%TLINK(LPSA);
06000		MOVEM	TEMP,RCTEMP
06100		POPJ	P,
06200	GRCT.1:	GETBLK
06300		PUSHJ	P,RNGTMP
06400		AOS	TEMP,TEMPNO
06500		MOVEM	TEMP,$PNAME(LPSA)
06600		MOVSI	TEMP,ARTEMP!INUSE!CORTMP
06700		MOVEM	TEMP,$SBITS(LPSA)
06800		MOVEI	TEMP,PNTVAR
06900		MOVEM	TEMP,$TBITS(LPSA)
07000		POPJ	P,
07100	>;RGC
07200	
07300	
     

00100	COMMENT ⊗GETAC, GETAN0 -- AC Allocators⊗
00200	
00300	DSCR GETAC,GETAN0
00400	DES These are the "get a free AC routines".
00500	PAR FF(rh) -- two modifier bits:
00600	 DBL	-- get a double AC (i.e. next one free too)
00700	 INDX	-- get an indexable AC (not 0 or 1 -- 1 is avoided since
00800	   Procedures tend to return values in 1).
00900	RES in D is returned the free (first free) AC number
01000	 Note that no ACKTAB marking has been done yet, so the AC
01100	 need not be used.
01200	
01300	 GETAN0: same as GETAC, but INDX is autimatically turned on.
01400	
01500	AC'S USED: TEMP,LPSA
01600	⊗;
01700	
01800	↑GETAN0: TRO	FF,INDX			;HERE IF YOU DON'T WANT TO SET THE BIT
01900	↑GETAC:	
02000		HRR	D,ACKPNT		;LAST AC USED
02100		SETOM	ACKPNT			;CLEAR IT
02200		SETZM	POSSIB			;MASK OF POSSIBILITIES
02300		MOVNI	TEMP,20			;NUMBER OF AC'S TO SEARCH
02400	
02500	;;#HF# 5-13-72 DCS RETURN OLDEST AVAILABLE AC IF NONE FREE, FIX DBL
02600	GET1:	AOJG	TEMP,GET7		;For each AC, starting with the one
02700		ADDI	D,1			; after the last allocated, and wrapping
02800		TRZ	D,777760		; around to 0 (2 if GETAN0), if the AC
02900		TRNE	FF,INDX			; is not protected (ACKTAB(AC)<0),
03000		TRNE	D,-2			; record the (oldest) first one seen in
03100		SKIPGE	LPSA,ACKTAB(D)		; ACKPNT -- if the entry is free (0),
03200		JRST	GET1			; try to terminate. Otherwise, continue
03300		SKIPGE	ACKPNT			; looking for a free one.
03400		HRRZM	D,ACKPNT
03500		TRNN	LPSA,-1
03600		JRST	GET4
03700		JRST	GET1
03800	
03900	; ONE FREE ONE EXISTS -- JUST RECORD IF DBL (NEED TWO)
04000	
04100	GET4:	TRNN	FF,DBL			;If only one AC is needed, it's number
04200		JRST	DSTORZ			; is in D.
04300	
04400	GET3:	MOVEI	LPSA,1			;Otherwise, record its number in the
04500		LSH	LPSA,(D)		; bit array POSSIB.  This is not the
04600		IORM	LPSA,POSSIB		; most efficient method, but it allows
04700		JRST	GET1			; the fun below.
04800	
04900	; LIST EXHAUSTED -- TAKE WHAT WE COULD GET
05000	
05100	GET7:	TRNE	FF,DBL			;If two were needed, we must work
05200		JRST	GET9			; harder.
05300	
05400	; TAKE A DISPLAY TEMP FIRST
05500	
05600		SKIPE	DISLST			;ONLY ANY GOOD IF HAVE SOME
05700		SKIPG	LPSA,CDLEV		;CURRENT DISPLAY LEV
05800		JRST	GET7.1
05900		HRRI	D,1			; COULD NEVER BE ZERO OR 1
06000	GET7.2:	SKIPE	DISTAB(D)
06100		JRST	GET7.3			;THIS THING HAS AN AC
06200		AOS     D			;TRY THE NEXT ONE UP
06300		SOJG	LPSA,GET7.2
06400		ERR	<DRYROT AT GETAC>	;YOU REALLY BLEW IT, SAM
06500	GET7.3: MOVE	LPSA,DISTAB(D)		;PICK IT UP
06600		TLNE	LPSA,-1			;USE STRING DISPLY IF WE CAN
06700		MOVSS	LPSA			;US STRING -HURRAH
06800		CAIN	LPSA,RF			;
06900		JRST	GET7.1			;IF RF, THEN NO GO
07000		HRR	D,LPSA			;WE CAN GRAB THIS ONE
07100		SKIPG   ACKTAB(D)
07200		ERR	<GETAC GRABBED SAFE AC -- DRYROT AND WORMS>
07300		JRST	DSTORZ			;RECORD IT, CLEAR IT OUT
07400	GET7.1:
07500	
07600	; NO DISPLAY TEMP, CLEAR SOMETHING ELSE OUT AND USE IT.
07700	
07800		HRR	D,ACKPNT		;Use the first one recorded, which
07900		JRST	STORZ			; is also the oldest found
08000	
08100	; WE NEED TWO -- TRY FOR TWO UNUSED IN A ROW
08200	
08300	GET9:	MOVE	LPSA,POSSIB		;If any two in a row were free,
08400		LSH	LPSA,1			; the AND of the bits and 2*bits
08500		AND	LPSA,POSSIB		; will yield a bit for each pair.
08600		JUMPE	LPSA,G10		;No bits implies no pairs.
08700		FSC	LPSA,231		;The FSC shifts the first match
08800		LDB	LPSA,[POINT 4,LPSA,8]	; to a normalized position, and 
08900		MOVEM	LPSA,ACKPNT		; records its index in the exponent
09000		HRR	D,LPSA			; field.
09100		POPJ	P,
09200	
09300	
09400	G10:	HRRI	D,21			;As a last resort, take the first
09500	G11:	SUBI	D,2			; two unprotected ACs available.
09600		TRNE	D,777000		;If none are found, complain bitterly.
09700		 ERR <DRYROT AT DBL GETAC>	;This could be improved by
09800		SKIPL	LPSA,ACKTAB(D)		; looking for the oldest pair, and/or
09900		SKIPGE	ACKTAB-1(D)		; a pair with one free AC, but at
10000		 JRST	 G11			; this point, we're sort of beyond
10100		JUMPE	LPSA,.+2		; caring.
10200		PUSHJ	P,STORZ			;Store the second, if it needs it.
10300		SUBI	D,1			;This is the result.
10400	
10500	DSTORZ:	HRRZM	D,ACKPNT		;Allocating this one.  Now go make
10600		JRST	STORZ			; sure it's ready for new action.
10700	;;#HF#
10800	
     

00100	COMMENT ⊗AC Store routines -- BOLSTO, FORSTO, STORIX, GOSTO, STORZ⊗
00200	
00300	DSCR BOLSTO
00400	DES Special Boolean store. It does not remove from ACs any
00500	 of the arguments to the Boolean compare.
00600	PAR PNT and PNT2 must point to Semantics of the two arguments.
00700	RES All other ACs are stored.  The Semantics of the parameters
00800	 are not necessarily guaranteed over the call, since either
00900	 may have been marked for storing.  
01000	SEE STORZ, which it calls for each AC cleared
01100	⊗;
01200	
01300	
01400	↑BOLSTO: PUSH	P,[PUSHJ	P,[
01500			HRRZ	TEMP,LPSA
01600			CAIE	TEMP,(PNT2)
01700			CAIN	TEMP,(PNT)
01800			POPJ	P,
01900			JRST	STORZ]]	 ;DO TURN OFF ACSAME FOR THESE GUYS.
02000	; THIS STORZ IS NEEDED BECAUSE A PARTICULAR BOOLEAN MAY LOOK LIKE:
02100	;	MOVE 4,I
02200	;	SKIPN	J
02300	;	JRST	FOO1
02400	;	MOVE	4,J+K
02500	;	SKIPE	GH
02600	;	JRST	SHIT
02700	;FOO1:	.....  HERE THE COMPILER THINKS J+K IS IN 4, WHERE I MIGHT BE!!!
02800	;
02900	
03000		JRST	GG0
03100	
03200	DSCR FORSTO
03300	DES Special AC dumper for FOR Loops. This protects the index
03400	 AC from being cleared. Other variables are not cleared, just
03500	 stored if temps.
03600	PAR PNT and PNT2 should point to anything to be preserved
03700	 over this operation (e.g. FOR I← <EXP> STEP .... want to preserve
03800	 I and the Semantics of <EXP> from storing before the test.
03900	SEE STORA, which it calls for each AC stored.
04000	⊗;
04100	
04200	↑FORSTO: PUSH	P,[PUSHJ P,[HRRZ TEMP,ACKTAB(D)	;FOR FOR LOOPS.
04300			   CAIE	TEMP,(PNT)
04400			   CAIN	TEMP,(PNT2)
04500			   POPJ	P,
04600					;DCS -- 8/16/70
04700			   PUSHJ P,STORA	;STORE IT FOR SURE
04800			   JUMPE LPSA,NSBSC	;NOTHING TO CLEAR
04900	;;#MU# RHT 6-25-73 I THINK THE FOLLOWING DISTINCTION IS POINTLESS
05000	;		   MOVE  TEMP,$TBITS(LPSA) ;IF AN INAC ARRAY,
05100	;		   TLNE  TEMP,SBSCRP	;CLEAR IT, BECAUSE WILL
05200	;;#MU#
05300			    JRST  CLEARL	;STILL BE ASSUMED INAC AT
05400		   NSBSC:   POPJ	 P,	; LOOP TOP OTHERWISE
05500			  ]]			;DCS -- 8/16/70
05600	
05700		JRST	GG0
05800	
05900	
06000	DSCR STORIX
06100	DES "Store" all INTERNALs and EXTERNALs, i.e. forget that
06200	 they are in ACs.
06300	⊗;
06400	↑STORIX: PUSH	P, [PUSHJ P,[
06500			HRRZ	LPSA,ACKTAB(D)
06600			JUMPE	LPSA,CPOPJ		;NOTHING THERE.
06700			MOVE	LPSA,$TBITS(LPSA)
06800			TLNE	LPSA,INTRNL!EXTRNL
06900			JRST	CLEARA
07000			POPJ	P,]]
07100		JRST	GG0
07200	
07300	
07400	DSCR ALLSTO
07500	DES Dump all ACs in the most permanent of ways. Do not
07600	 retain any marking of the AC's at all.
07700	
07800	SEE STORZ, which it calls for each AC gronked.
07900	⊗;
08000	
08100	↑ALLSTO:OPTSYM	%ALSTO
08200		PUSH	P,[PUSHJ P,STORZ]	;TO CLEAR  INAC" BITS.
08300		SKIPA
08400	
08500	DSCR GOSTO
08600	DES Store any AC's marked with temps (as opposed to variables).
08700	 Leave the AC markings as they are.
08800	 Storing in forward direction makes life easier for LONG (double) things.
08900	⊗;
09000	
09100	↑GOSTO:	PUSH	P,[PUSHJ P,STORA]
09200	GG0:	PUSH	P,D
09300		MOVSI	D,-20			;D, WHO WILL HAVE A COUNT
09400		SKIPLE	LPSA,ACKTAB(D)		;DO WE HAVE A STORE TO DO?
09500		XCT	-1(P)			;EXECUTE STORING ROUTINE.
09600		AOBJN	D,.-2
09700	
09800	ALLD:	POP	P,D
09900		POP	P,(P)			;THROW AWAY
10000		POPJ	P,			;AND RETURN
10100	
10200	
10300	DSCR STORZ
10400	DES "Store" this AC and wipe out the ACKTAB entry -- clear
10500	 INAC-type SBITS in the Semantics which were there.
10600	PAR AC # in D
10700	SEE STORA,CLEARA routines, which it calls
10800	⊗;
10900	
11000	↑STORZ:	PUSHJ	P,STORA
11100		JRST	CLEARA
11200	
     

00100	COMMENT ⊗ STORA -- main AC-storing subr. -- called by above⊗
00200	
00300	DSCR STORA
00400	DES Stores temp results that are in a specified AC into
00500	  a core temp. If a temp exists in that AC, an appropriate core
00600	  temp is found, and the Stoe is EMITted.
00700	 Then the SBITS word in the Semantics is updated to
00800	  reflect the "In Core" status (e.g. CORTMP bit, fixup
00900	  chain addr, etc.) The fixup chain may have originated
01000	  in another temp entry, but was moved here to avoid searching
01100	  up the Semantic stack for all who refer to this temp and
01200	  changing the addresses of the entry they point to. WHAT????
01300	
01400	PAR D contains AC # affected.
01500	SID LPSA, TEMP used
01600	⊗;
01700	
01800	↑STORA:	SKIPG	LPSA,ACKTAB(D)
01900		POPJ	P,		;NOTHING THERE.
02000		CAMN	LPSA,ACKTAB-1(D)	;POSSIBLE DBLPRC SCREWUP?
02100		 SOJA	D,[PUSHJ P,STORA		;YES, STORE PRECEDING AC INSTEAD
02200			   AOJA D,CPOPJ]	;AND RESTORE D
02300		PUSH	P,SBITS
02400		PUSH	P,TBITS		;SAVE YET ANOTHER AC
02500		MOVE	SBITS,$SBITS(LPSA);GET SEMANTIC BITS.
02600		TLNN	SBITS,INAC!PTRAC ;IF NOT IN AC, THEN TROUBLE
02700		ERR	<STORA A THING NOT IN AC>,1
02800	;; #KQ BY JRL (11-30-72) IGNORE FIXARS
02900		TLNN	SBITS,FIXARR		;A FIXARR SHOULDN'T GET STORED
03000		TLNN	SBITS,ARTEMP!DISTMP	;OTHERWISE A NOOP
03100		 JRST	 ZER
03200		PUSH	P,PNT
03300		PUSH	P,A
03400		MOVEI	PNT,(LPSA)
03500	
03600	;BUG TRAP
03700		HRRZ	TEMP,$ACNO(PNT)		;THIS IS THE AC IT THINKS ITS IN.
03800		CAIE	TEMP,(D)		;THE SAME
03900		ERR	<STORA>,1
04000	
04100		TLNE	SBITS,DISTMP		;DISPLAY????
04200		JRST	ZERDR			;YES
04300	
04400		TLNE	SBITS,CORTMP		;CAN WE PUT IT WHERE WE PUT IT BEFORE?
04500		 JRST	 DEP			; YES (USUALLY ONLY HAPPENS WHEN SOME
04600						; BUG PROVOKES IT --LIKE MISSING REMOP)
04700	RGC <
04800		TLNN	SBITS,INDXED		;IF NOT INDXED TEMP
04900		JRST	RCTCHK			;GO CHECK IF RECORD TEMP
05000		HRRZ	TEMP,$VAL2(PNT)		;A SUBFIELD INDXED TEMP??
05100		JUMPE	TEMP,NRML		;NO, JUST TREAT NORMALLY
05200	;;#WX# ! JFR 6-5-76 FORGOT TO FETCH TBITS
05300		MOVE	TBITS,$TBITS(PNT)
05400	;;#WD# STRING SUBFIELD INDXED TEMPS ARE SPECIAL 
05500		TDNN	TBITS,[XWD SBSCRP,PROCED!ITEM!ITMVAR]
05600	;;#WW# ! JFR 6-1-76 used to be TRNE (typo)
05700		TRNN	TBITS,STRING
05800		JRST	RCTMAK			;YES, DO THE OTHER SORT OF MOVEM
05900		JRST	NRML			;HERE IF STR SUBF INDX TEMP
06000	;;#WD# ↑
06100	RCTCHK:	MOVE	TBITS,$TBITS(PNT)
06200		TRNN	TBITS,ITEM!ITMVAR	;THESE ARE ALWAYS NORMAL
06300		TRNN	TBITS,PNTVAR		;A RECORD TEMP
06400		JRST	NRML			;NOPE NORMAL
06500	RCTMAK:	PUSHJ	P,GETRCT		;GET A PNTVAR CORTMP
06600		JRST	TMPCPY			;GO COPY FIXUPS,ETC
06700	NRML:
06800	>;RGC
06900	
07000		SKIPA	LPSA,TTEMP		;PREPARE TO SEARCH TEMP LIST
07100	TEML:	LEFT	,%RVARB,NOFND		;GO DOWN TEMP LIST
07200			MOVE	TEMP,$SBITS(LPSA)
07300			TLZE	TEMP,INUSE	;NEED ONE NOT IN USE
07400			JRST	TEML
07500			TLZN	TEMP,CORTMP	;AND IN CORE
07600			JRST	TEML		;REALLY AN ERROR
07700	TMPCPY: MOVE    TEMP,$ADR(LPSA)
07800	        MOVEM   TEMP,$ADR(PNT)          ; HO HO.
07900	        MOVE    TEMP,$PNAME(LPSA)       ;ID NUMBER OF THIS CORTMP
08000	        MOVEM   TEMP,$PNAME(PNT)        ;SO ADRINS AND SCOUT DON'T GET CONFUSED
08100	        PUSHJ   P,URGTMP                ;REMOVE FROM RING
08200	        FREBLK  ()                      ;THE OLD ONE
08300		JRST	DEP1
08400	
08500	NOFND:	SETZM	$ADR(PNT)		;WITH ZERO FIXUP
08600	;; #JRL ALWAYS GIVE CORTMPS ID NO.
08700		AOS	TEMP,TEMPNO		;CORTMP ID
08800		MOVEM	TEMP,$PNAME(PNT)
08900	;; #JRL
09000	DEP1:	MOVE	LPSA,PNT
09100		PUSHJ	P,RNGTMP		;PUT ON RING
09200	DEP:	MOVSI	SBITS,CORTMP!INUSE!ARTEMP
09300		IORB	SBITS,$SBITS(PNT)	;INDICATE THE NEW STATUS
09400	TURNOF:	MOVSI	LPSA,INAC!PTRAC!NEGAT	;TEMP NO LONGER IN AC
09500		ANDCAM	LPSA,$SBITS(PNT)
09600		HRRM	D,$ACNO(PNT)		;RECORD THE AC NUMBER
09700		HRLZI	A,(<MOVEM>)
09800		TDNE	TBITS,[SBSCRP,,PROCED!ITEM!ITMVAR]
09900		 JRST	.+3
10000		TRNE	TBITS,DBLPRC
10100		 MOVSI	A,(<DMOVEM>)
10200		TLNE	SBITS,INDXED		;A CALCULATED SUBSCRIPT?
10300		TRO	A,ADDR			;YES -- DO NOT STORE INDIRECT.
10400		TLNE	SBITS,NEGAT		;IS THE AC AROUND NEGATIVELY?
10500		 JRST	[HRLI	A,(<MOVNM>)		;YES
10600			TRNE	TBITS,DBLPRC
10700			 HRLI	A,(<DMOVNM>)
10800			 JRST	.+1]
10900	;; #MD# ONLY STORE RIGHT HALF OF PTRAC
11000		TLNE	SBITS,PTRAC
11100		HRLI	A,(<HRRZM>)		;ONLY RIGHT HALF, IN CASE LATER AN
11200						;INDIRECT MOVE IS DONE
11300		PUSHJ	P,EMITER
11400						;NOTE THOUGH THAT NEGAT MAY STILL
11500						;BE ON.  THIS MAY BE DANGEROUS.
11600		MOVEM	SBITS,$SBITS(PNT)
11700	ZRET:	POP	P,A
11800		POP	P,PNT
11900	
12000	ZER:	
12100		POP	P,TBITS
12200		POP	P,SBITS
12300		POPJ	P,			;RETURN
12400	ZERDR:	MOVE	A,$VAL(PNT)		;ZEROING MASK
12500		HRR	LPSA,$ADR(PNT)		;PICK UP DISPLAY LEVEL
12600		ANDM	A,DISTAB(LPSA)		;ZERO APPROPRIATE SIDE OF DISTAB WORD
12700		HLLZS	ACKTAB(D)		;ZONK THE ACKTAB ENTRY
12800		MOVE	LPSA,PNT
12900		PUSHJ	P,URGDIS		;UNLINK FROM DISPLAY VARB RING
13000		FREBLK  (PNT)
13100		JRST	ZRET
13200	SUBTTL	CODE EMITTER
13300	
     

00100	COMMENT ⊗EMITER -- Descriptions of Routine and Control Bits⊗
00200	
00300	DSCR EMITER -- code emitting routine.
00400	
00500	DES From input parameters and symbol table information,
00600	  generate a word of real live code.
00700	
00800	PAR 
00900	A --	OPCODE in LH, bits in RH:  
01000		NOUSAC←←400000	;DON'T USE D(RH) AS AC #
01100		USCOND←←200000	;USE C(RH) AS 3 BITS OF CONDITION
01200		USADDR←←100000	;USE C(LH) AS DISPLACEMENT PART
01300		USX   ←← 40000	;USE D(LH) AS INDEX REG
01400		NORLC ←← 20000	;RELOCATE NOT!
01500		IMMOVE←← 10000	;IF OPERAND CONSTANT, LOAD IT ANY WAY POSSIBLE
01600		INDRCT←←  4000	;INDIRECT ADDRESSING REQUIRED
01700		JSFIX ←←  2000	;JUST DO A FIXUP (DON'T GET SEMANTICS).
01800		NOADDR←←  1000	;NO EFFECTIVE ADDRESS PART
01900		ADDR ←←    400	;WE WANT THE ADDRESS OF THIS ENTITY
02000		FXTWO←←   100	;USE SECOND FIXUP WORD
02100	
02200	C --   DISPLACEMENT (if provided) in LH, condition bits in RH
02300	D --   Index number in LH, AC number in RH (both optional)
02400	PNT --	symbol table pointer, if required
02500	
02600	RES Code is written, RELOC bit is set to final value;
02700	  Formal fixup list (FORMFX) has been updated, if necessary.
02800	
02900	SID All Ac's are saved except TEMP and LPSA.
03000	⊗;
03100	
03200	BIT2DATA (EMITTER)
03300	INDIR	←← 20	;THE INDIRECT BIT!!
03400	;PNTROP	←← 200	;THIS OPERATION WILL DO POINTER INDEXING
03500			; (PURELY LOCAL BIT, BUT DON'T SEND IT IN)
03600	IMMED	←← 1000	;THE IMMEDIATE BIT (FOR SOME THINGS).
03700	
03800	
03900	↑XCALLQ:
04000		SKIPE	NOEMIT
04100		POPJ	P,
04200		PUSH	P,C		;LITTLE ROUTINE
04300		HRL	C,PCNT		;FOR CALLING LIBRARY ROUTINES.
04400		EXCH	C,(A)		;FIXUP INTO LIBRARY TABLE.
04500		EMIT	(<PUSHJ RP,NOUSAC!USADDR>)
04600		POP	P,C
04700		POPJ	P,
04800	
04900	
     

00100	COMMENT ⊗ EMITER Routine⊗
00200	
00300	↑EMITER:
00400		SKIPE	NOEMIT		; GET OUT IF NO CODE IS TO BE EMITTED (I.E. 
00500		POPJ	P,		;  EXPR!TYPE)
00600		PUSH	P,A		;SAVE THOSE THINGS WHICH MIGHT CHANGE
00700		PUSH	P,C
00800		PUSH	P,D
00900		PUSH	P,TBITS
01000		PUSH	P,SBITS
01100		TRZ	A,PNTROP	;ASSUME NO POINTER OP
01200	;;#  # DCS 3-25-72 Eliminate bad array address problem
01300	;;#  #   When [0,0,0]-word of array (location known, no fixup) falls
01400	;;#  #   on reladr 0 of .REL file, CODOUT will mistake the 0 addr field
01500	;;#  #   for end of fixup chain, will inhibit RELOC -- want RELOC in this
01600	;;#  #   case.  A bad fix, should be more generally solved.
01700		TLO	FF,RELOC!FFTMP1	;AND RELOC (FFTMP1 FOR CODOUT 0-TEST)
01800	;;#  #
01900		TRNE	A,USADDR	;ADDR IN C(LH)?
02000		 JRST	 EAC		;YES, BYPASS SEMANTICS TESTING
02100		TLZ	FF,RELOC	;NOW ASSUME NO RELOCATION
02200		HRRZS	C		;CLEAR DISPLACEMENT FLD -- C(LH)
02300		TRNE	A,NOADDR	;IS THERE AN ADDRESS FLD AT ALL?
02400		 JRST	 EAC		;NO, FINISH UP
02500		TRNE	A,JSFIX
02600		JRST	EVAR		;GO DO A FIXUP
02700	
02800	; NOW GET SEMANTICS AND DISPATCH TO CORRECT ROUTINE TO OUTPUT INSTR
02900	
03000		MOVE	SBITS,$SBITS(PNT)
03100		MOVE	TBITS,$TBITS(PNT)
03200	;; #JR# BY JRL 10-17-72 A STRING ITEM IS NOT A STRING
03300		TRNE	TBITS,ITEM!ITMVAR
03400		TRZ	TBITS,STRING!DBLPRC	;FORGET ABOUT STRING TYPE FOR ITEMS
03500	;; #JR# 
03600	NOSBS:	
03700	NOREC <
03800		TRNN	TBITS,PNTVAR	;IF PNTVAR OR INDXED OR
03900	>;NOREC
04000		TLNE	SBITS,INDXED	; REFERENCE FORMAL,
04100		TRO	A,PNTROP	;INDICATE A POINTER OPERATION
04200		TLNE	TBITS,REFRNC
04300		TRO	A,PNTROP
04400		TRNE	A,ADDR		;IF ADDR and PNTROP, TURN OFF BOTH
04500		TRZE	A,PNTROP	;(THE IMMEDIATENESS
04600		TRZ	A,ADDR		; OF ADDR CANCELS THE INDIRECTNESS OF PNTROP
04700		TLNE	TBITS,SBSCRP	;ELIMINATE FXTWO IF
04800		TRZ	A,FXTWO		; ARRAY NAME
04900	
05000	;;#FP#  1-10-72 DCS (1-2)
05100		TLNE	SBITS,INAC	;IN ACCUMULATOR?
05200		 JRST	 EINAC
05300	;;#FP#
05400		TLNE	TBITS,FORMAL	;FORMAL PARAMETER (ACTUAL)?
05500		 JRST	 EFORM		; 
05600		TRNE	A,PNTROP	;INDIRECTNESS DESIRED?
05700		 JRST	 EPNT
05800	;;#FP#  1-10-72 DCS (2-2)
05900		TLNE	SBITS,PTRAC	;IN ACCUMULATOR? (WAS INAC TOO)
06000		 JRST	 EINAC
06100	;;#FP#
06200		TRNE	A,ADDR		;SHOULD WE CONSIDER CONSTANT IMMED?
06300		 JRST	 EVAR		;NO
06400		TLNE	TBITS,CNST	;NUMERIC CONSTANT?
06500		TRNE	TBITS,STRING	;
06600		 JRST	 EVAR		; NO
06700	
     

00100	
00200	ECONST:	TRNN	TBITS,DBLPRC	;CANT OPTIMIZE LONG PRECISION
00300		SKIPE	OPDUN		;NEVER OPTIMIZE USER INLINE CODE
00400		 JRST	 EVAR		; BUT REFER TO MEMORY
00500		MOVE	TEMP,$VAL(PNT)	;GET VALUE
00600		TRNN	A,IMMOVE	;IMMEDIATE MOVE REQUESTED?
00700		 JRST	 OPCON1		; NO, TEST LH0
00800		HRLI	A,(<MOVE >)	;ASSUME MOVEI
00900	
01000		TLC	TEMP,-1		;TEST LEFT HALF -1
01100		TLCN	TEMP,-1		;IS IT?
01200		 JRST	 [HRL C,TEMP	;YES, SET UP
01300			  HRLI A,(<HRROI>) ; INSTR
01400			  JRST EAC]	;AND EMIT IT
01500		TRNE	TEMP,-1		;RIGHT HALF ZERO?
01600		 JRST	 OPCON1		; NO
01700		MOVSS	TEMP		;YES, SWAP HALVES
01800		TLO	A,4000		; AND TURN ON MOVSI BIT
01900	OPCON1:	TLNE	TEMP,-1		;LEFT HALF ZERO?
02000		 JRST	 EVAR		;NO
02100		HRL	C,TEMP
02200		LDB	TEMP,[POINT 9,A,8] ;GET OP-CODE
02300		SUBI	TEMP,200	;ONLY OPCODES IN RANGE <MOVE> (200)
02400		JUMPL	TEMP,EVAR	; TO <OR> (434) WILL
02500		CAILE	TEMP,234	; BE CONSIDERED
02600		 JRST	 EVAR
02700		PUSH	P,USER
02800		IDIVI	TEMP,=36	;WORD # TO TEMP, BIT # TO USER
02900		MOVE	TEMP,OPBTS(TEMP);SOME BITS
03000	
03100	TABCONDATA (OPCODE BITS TABLE FOR EMITER OPTIMIZER)
03200	OPBTS:	421042004000	;BIT ON IF
03300		000000104000	;CORRESPONDING OPCODE
03400		776000000000	;CAN BE IMMEDIATE
03500	; OLD WORD OBPTS+3	;REPLACED (6-27-73)
03600	;	001040000000
03700	;; #KAB INCORRECT AND MISSING OBPTS ENTRIES
03800		000000004200
03900		401040000000
04000	;; #KAB#
04100	ENDDATA
04200	
04300		LSH	TEMP,(USER)	;THE RIGHT ONE
04400		POP	P,USER
04500		JUMPGE	TEMP,EVAR	;CAN'T OPTIMIZE, CODE WRONG
04600		CAML	A,[CAM]		;THE COMPARES ARE MADE 
04700		CAML	A,[JUMP]	; IMMEDIATE BY TURNING OFF
04800		 TLOA	 A,IMMED	; THE 10000 BIT, ALL OTHERS
04900		TLZ	A,10000		; BY TURNING ON THE 1000 BIT
05000		JRST	EAC		;PUT OUT OPTIMIZED INSTR
05100	
05200	
05300	
05400	EPNT:	HRRE	TEMP,$VAL(PNT)	;GET DISPLACEMENT IF ANY
05500		SUBI	TEMP,1		;ASSUME STRING AND ¬FXTWO
05600	;;#UE#	(3 OF 3) INDEXED STRING ARRAY TEMPS ARE LOSERS
05700		TLNE	TBITS,SBSCRP	;IF AN ARRAY 
05800		AOJA	TEMP,EPNT.1	;JUST REVERSE ASSUMPTION QUAM CELERIME
05900	;;#UE# ↑
06000		TRNN	TBITS,STRING
06100		 ADDI	TEMP,1		;WAS NOT STRING
06200		TRZE	A,FXTWO
06300		 ADDI	TEMP,1		;WAS FXTWO
06400	EPNT.1:	HRL	C,TEMP		;GET TO DISPLACEMENT PLACE
06500		TLNE	SBITS,PTRAC	;POINTER IN AC?
06600		 JRST	 EACX		; YES
06700		TLNE	C,-1		;MAKE INDIRECT
06800		 ERR	 <DRYROT AT EPNT>,1 ;UNLESS WE WANTED A DISPLACEMENT
06900		TRO	A,INDRCT	;MAKE IT INDIRECT
07000		JRST	 EVAR		;GO DO FIXUPS
07100	
07200	EACX:	HRL	D,$ACNO(PNT)	;USE AC AS INDEX
07300		TLNE	TBITS,OWN	;IF ARRAY NAME COMES INTO IT,
07400	;;#  # DCS 3-25-72 Bad array address problem.
07500		 TLC	 FF,RELOC!FFTMP1;RELOCATABLE, SHOUDN'T 0-TEST IN CODOUT
07600	;;#  #
07700		TRO	A,USX		;DENOTE THAT IT SHLD BE DONE
07800		JRST	CHKIMM
07900	
08000	EINAC:	HRL	C,$ACNO(PNT)	;INAC, GET ACNO AS DISPL.
08100		TRNE	TBITS,DBLPRC	;LONG
08200		TRNN	A,FXTWO		;AND FXTWO
08300		 JRST	CHKIMM		; SEE IF ADDR IS ON
08400		ADD	C,[1,,0]	;MEANS AC+1
08500		JRST	CHKIMM
08600	
08700	EFORM:	TRO	A,USX		;WILL NEED TO USE A STACK AS INDEX
08800		HRRZ	TEMP,$ADR(PNT)	;GET DISPL FROM STACK TOP
08900		TDNN	TBITS,[SBSCRP!REFRNC,,PROCED!ITEM!ITMVAR]	;THESE ARE NOT VALUE LONGS
09000		TRNN	TBITS,DBLPRC	;LONG?
09100		 JRST	.+3		;NO
09200		TRZE	A,FXTWO
09300		 SUBI	TEMP,1		;FXTWO ON LONG FORMAL MOVES CLOSER TO STACK TOP
09400		TLNE	TBITS,REFRNC	;REFERENCE PARAM?
09500		 JRST	 REFPRM		; YES
09600	VALPRM:	TRNN	TBITS,STRING	;STRING
09700		JRST	REFPRM		;NO
09800		SKIPN	SIMPSW
09900		TRNN	SBITS,DLFLDM	;IF SIMPLE OR DL 0 THEN DO IT THE OOLD WAY
10000		JRST	USERSP
10100		LDB	LPSA,[LEVPOINT(SBITS)]; PICK UP LEVEL
10200		HLL	D,DISTAB(LPSA)	;PICK UP REGISTER
10300		TLNN	D,17
10400	;;#MN# 7-13-73 THE FRIDAY 13 ACCESS KLUGE
10500		JRST	[
10600			PUSH P,TEMP
10700			HLRZ	TEMP,LSDRLV		;MAYBE THE THING IS STILL AROUND
10800			CAIE	TEMP,(LPSA)
10900			ERR	<DRYROT AT EFORM FOR STRING>	;BETTER NOT BE 0
11000			HLL	D,LSDRNM		;GET THE OLD THING
11100			POP	P,TEMP
11200			JRST	.+1]
11300	;;#  #
11400		TRZE	A,FXTWO		;IF SECONG WORD
11500	
     

00100		SUBI	TEMP,1		;FIX IT
00200		MOVN	TEMP,TEMP
00300		HRL	C,TEMP		;USE THIS DISPL
00400		JRST	CHKIMM		;GO CHECK
00500	 
00600	REFPRM:	TLNN	TBITS,SBSCRP	;IF SUBSCRIPTED AND
00700		 JRST	 .+3		; REFERENCE, 
00800		TLNE	TBITS,REFRNC		;
00900		TRZ	A,PNTROP	;DO NOT GO INDIRECT.
01000		TRZE	A,PNTROP	;WANT TO GET VALUE?
01100		 TRO	 A,INDRCT	; YES, GO INDIRECT, FIND ON RP STACK
01200		LDB	LPSA,[LEVPOINT(SBITS)];PICK UP DISPLY LEVEL
01300		CAIE	LPSA,0		;IF HAVE A DISPLAY
01400		JRST	USEDRF		;USE IT
01500		MOVE 	LPSA,TPROC	;PICK UP PROC ID
01600		HRRZ	LPSA,$SBITS(LPSA);PICK UP RH OF SBITS FOR PROC
01700		ADDI	LPSA,1		;WANT LEVEL OF FORMLS
01800		XOR	LPSA,SBITS	;ALL THIS IS A FANCY TEST TO SEE IF THIS PROC'S
01900		TRNE	LPSA,LLFLDM			;IS IT THE SAME
02000		ERR	<INACCESSABLE FORMAL>		;NO
02100		SKIPN	SIMPSW		;BETTER BE SIMPLE PROC
02200		ERR	<DRYROT AT EPNT -- SIMPLE?>	;YOU FUCKED UP
02300	
02400	
02500	USERP:	HRLI	D,RP		;MARK THIS STACK
02600		ADD	TEMP,ADEPTH	;TOTAL ARITH STACK DEPTH
02700		JRST	MAKFRM		;GO CREATE FORMAL REF INSTR
02800	
02900	USERSP:	HRLI	D,RSP
03000		ADD	TEMP,SDEPTH
03100		TRZE	A,FXTWO		;SECOND WORD?
03200		 SUBI	 TEMP,1		;YES, DON'T GO SO FAR
03300	
03400	MAKFRM:	MOVNS	TEMP		;NEGATIVE STACK DISPLACEMENT
03500		HRL	C,TEMP		;USE THIS DISPLACEMENT
03600	;;#KH# RHT (11-21-72) DELETED LARGE HUNKOF LEFT OVER STUFF FROM FORMFX
03700		JRST	CHKIMM		;FINISH OUT
03800	USEDRF:	HRL	D,DISTAB(LPSA)	;PICK UP DISPLAY REGISTER
03900		TLNN	D,-1		;WAS IT LOADED
04000	;;#MN# FRIDAY 13 JULY 
04100		PUSHJ	P,[DRKLUG:
04200			PUSH	P,TEMP
04300			HRRZ	TEMP,LSDRLV
04400			CAIE	TEMP,(LPSA) ;OLD LEVEL THERE???
04500			ERR	<DRYROT AT EFORM>,1;NO
04600			POP	P,TEMP
04700			HRL	D,LSDRNM
04800			POPJ	P, ]
04900	;;#  #
05000		MOVN	TEMP,TEMP	;NEGATE DISPL
05100		SUBI	TEMP,1		;SINCE RF IS ONE MORE AWAY
05200		HRL	C,TEMP		;USE IT
05300		JRST	CHKIMM		;GO FINISH UP
05400	
05500	EVAR:
05600	 	TLO	FF,RELOC	;NOW ASSUME RELOC AGAIN
05700	;;#VM# ! JFR 10-30-75 PARANOIA THAT PROCEDURES COULD SLIP THROUGH
05800		TRNN	TBITS,PROCED
05900		TRNE	A,JSFIX		;IF JUST WANT A FIXUP
06000		JRST	USECR		;THEN THATS ALL YOU GET
06100		TLNE	SBITS,CORTMP	;IS IT A CORE TEMP
06200		JRST	[		;YES
06300			SKIPN	RECSW		;IF NOT RECURSIVE PROC THEN
06400			JRST	USECR		;USE A CORE LOCN -- NO DR NEEDED
06500			MOVE	LPSA,CDLEV	;USE THIS LEVEL
06600			JRST	USED.1		;NO LDB ALLOWED
06700			]
06800		TRNE 	SBITS,DLFLDM	;STACK VAR?
06900		JRST	USEDR		;YES
07000	USECR:
07100		HRL	C,$ADR(PNT)	;ADDR OR LAST FIXUP
07200	DCDFX:	TRNN	A,JSFIX
07300		TRNE	TBITS,FORWRD!INPROG ;MUST FIXUP IF EITHER IS ON
07400		 JRST	 DOFIX
07500		TLNN	SBITS,FIXARR	;DON'T FIXUP IF FIXARR ON
07600		TRNE	TBITS,PROCED!LABEL  ;ELSE ONLY IF NEITHER OF THESE
07700		 JRST	 DONTFX
07800	REC <
07900		TRNE	TBITS,PNTVAR	;CHECK FOR CLASS ID
08000		TRNN	TBITS,SHORT	; IE SHORT PNTVAR
08100		JRST	DOFIX
08200		JRST	DONTFX		;CLASS ID NOT FIXED UP 
08300	>;REC
08400	NOREC <
08500		JRST	DOFIX		;HERE DO IT
08600	>;NOREC
08700	
08800	USEDR:	LDB	LPSA,[LEVPOINT<SBITS>]	;GET DISPLAY LEVEL
08900	USED.1: HRL	D,DISTAB(LPSA)		;USE DISPLY REG
09000		TRNE	TBITS,STRING		;UNLESS STRING
09100		JRST	[
09200	;#IO# RHT 7-17-72 ATTEMPT TO USE STR DR FOR A INDEXED TEMP
09300			TLNE SBITS,INDXED	;DONT IF RESULT OF ARRAY CALC
09400			JRST	.+1		;
09500	;#  #
09600			TLNN TBITS,SBSCRP	;DONT FOR ARRAYS
09700			HLL	D,DISTAB(LPSA)	;CODED THIS WAY TO HANDLE USUAL CASE
09800			JRST	.+1]
09900		TRNE	A,USX			;BETTER NOT PLAN TO INDEX THIS
10000		ERR	<DRYROT AT EVAR>,1	;NO
10100		TLNN	D,-1			;WAS IT LOADER
10200	;;#UV# JFR 8-16-75 WHAT A HACK.
10300		 PUSHJ	P,DRKLUG		;FIX RACE CONDITION.  GET (ACCESS)
10400				;FOUND THE DISPLAY REG, BUT ACCOP USED THE REG SINCE
10500				;ALL OTHERS WERE BUSY.  HACK, HACK.
10600		HRL	C,$ADR(PNT)		;PICK UP DISPL
10700		TRO	A,USX			;USE THE MOTHER
10800		JRST	DCDFX			;GO THINK ABOUT FIXING UP
10900	
11000	
     

00100	
00200	DOFIX:	HRRZ	TEMP,PCNT	;READY TO DO FIXUP CHAINING
00300		TRZE	A,FXTWO		;USE SECOND FIXUP ADDR
00400		 JRST	 [HLL C,$ADR(PNT)
00500			  HRLM	TEMP,$ADR(PNT)  ;YES, MATTER OF FACT
00600			  JRST	CHKIMM]
00700		HRRM	TEMP,$ADR(PNT)	;FINISH FIXUP CHAINING
00800	
00900	DONTFX:
01000		TLNN	SBITS,FIXARR
01100		 JRST	 CHKIMM
01200	;;#YY# JFR 2-12-77 MAKE LOGIC CLEARER AND FXTWO OF LONG DO THE RIGHT THING
01300	;;	SUB	C,[XWD 1,0]	;ASSUME STRING, NOT FXTWO
01400	;;	TRNE	TBITS,STRING	;IF NOT STRING OR IF FXTWO,
01500	;;	TRZE	A,FXTWO
01600	;;	 ADD	 C,[XWD 1,0]	; NULLIFY ASSUMPTION
01700		TRZE	A,FXTWO
01800		 ADD	C,[XWD 1,0]	;FXTWO, SO 2ND WD
01900		TRNE	TBITS,STRING
02000		 SUB	C,[XWD 1,0]	;EXCEPT STRINGS HAVE ORIGIN AT -1
02100	;;#YY# ↑
02200	CHKIMM:
02300	
02400		TRNN	A,ADDR		;DO WE WANT THIS POINTER RAW?
02500		 JRST	 EAC		; NO, FINISH UP
02600		TLO	A,IMMED		;THE ONLY WAY TO DO IT HERE IS TO
02700		TRNE	A,USCOND	; MAKE THE INSTR IMMEDIATE
02800		 HRLI	 A,(<CAI>)	; (CONDITIONAL MUST BE A CAM)
02900	
03000	EAC:	TRNE	A,INDRCT	;INDIRECT BIT WANTED?
03100		 TLO	 A,INDIR
03200		TRNN	A,NOUSAC	;AC FLD PROHIBITED?
03300		 DPB	 D,[POINT 4,A,12] ;NO, PUT IT IN
03400		TRNE	A,NORLC		;RELOCATION PROHIBITED?
03500		 TLZ	 FF,RELOC	; YES, TAKE IT OUT
03600		TRNE	A,USCOND	;CONDITION BITS NEEDED TO FINISH OPCODE
03700		 DPB	 C,[POINT 3,A,8] ;YES, DO IT
03800		TRNE	A,USX		;D(LH) TO BE USED AS INDEX FLD?
03900		 TDO	 A,D		;YES (WIPES OUT A(RH))
04000		HLR	A,C		;GET DISPL (SO DOES THIS)
04100	;;#  # DCS 3-25-72 bad array address problem
04200		MOVEI	TEMP,CODOUT	;STANDARD CASE
04300		TLNN	FF,FFTMP1	;IF THIS BIT GOT TURNED OFF, CODREL SHOULD
04400		 MOVEI	 TEMP,CODREL	; BE CALLED TO AVOID THE 0-TEST WHICH
04500		PUSHJ	P,(TEMP)	; WOULD INHIBIT RELOC -- PUT OUT THE CODE
04600	;;#  #
04700		POP	P,SBITS
04800		POP	P,TBITS
04900		POP	P,D
05000		POP	P,C
05100		POP	P,A
05200	;;#MN# 7-13-73
05300		SETZM	LSDRLV		;REALLY ONLY NEED TO ZERO THIS
05400		SETZM	LSDRNM		;REALLY WILL DO THIS ANYHOW
05500	;;#  #
05600		POPJ	P,		;RESTORE AND RETURN
05700	SUBTTL	Generalized push and pop.
05800	
     

00100	COMMENT ⊗Qstack Routines -- BPUSH, etc.⊗
00200	
00300	DSCR QSTACK ROUTINES
00400	DES These are routines to provide generalized, expandable push-
00500	 down stacks (buffers? queues?) for use by algorithms which need
00600	 widely varying storage, accessed in simple ways.  Such structures
00700	 are called QSTACKS, and are built out of Semblks as follows --
00800	
00900	WORD1 --    ptr to PREV,,ptr to NEXT
01000	WORDS 2-11 --	up to 10 words of "stack" data
01100	
01200	A stack is identified by its QPDP, or Qstack Descriptor, which is --
01300	 ptr TOP,,ptr Semblk containing TOP
01400	
01500	Most Qstack operations reference the address where this QPDP (there 
01600	 should be one QPDP which always refers to the TOP) is stored.  Others
01700	 may also be used in conjunction with Qstack operations
01800	
01900	Qstack operations are provided to PUSH data on, POP data off (these
02000	 allocate and release Semblks, if necessary, and change the TOP QPDP),
02100	 access data non-destructively in forward and reverse directions, and
02200	 to clear a given Qstack.
02300	⊗
02400	
02500	DSCR BPUSH
02600	CAL PUSHJ via QPUSH macro
02700	PAR LPSA ptr to  QPDP for Qstack
02800	 A is data to be pushed
02900	RES QPDP is updated, A is stored in Qstack, new Semblk if necessary
03000	DES if QPDP is 0, an initial Semblk is created, QPDP constructed.
03100	SID only TEMP is changed
03200	SEE QPUSH
03300	⊗
03400	
03500	↑BPUSH:	PUSH	P,A			;SAVE IT.
03600		SKIPN	TEMP,(LPSA)		;THE CURRENT POINTER
03700		JRST	NEWONE			;NONE YET, GUYS.
03800		HLRZ	A,TEMP
03900		CAIL	A,BLKLEN-1(TEMP)	;GONE OVER BLOCK BOUNDARY?
04000		JRST	NOTHER			;YES
04100	PUSH1:	PUSH	A,(P)			;SEE !!!
04200		HRLM	A,(LPSA)		;CURRENT POINTER UPDATED.
04300		POP	P,A			;RESTORE
04400		POPJ	P,			;DONE
04500	
04600	NEWONE:	PUSH	P,LPSA
04700		GETBLK				;GET A NEW BLOCK.
04800		SETZM	(LPSA)
04900		MOVE	TEMP,LPSA		;POINTER TO NEW BLOCK.
05000		POP	P,LPSA
05100	MORBLK:	HRRM	TEMP,(LPSA)		;UPDATE PDP POINTER.
05200		HRRZ	A,TEMP
05300		JRST	PUSH1			;FINISH OUT.
05400	
05500	NOTHER:	PUSH	P,LPSA			;SAVE IT
05600		GETBLK
05700		MOVE	TEMP,LPSA		;POINTER TO NEW ONE.
05800		POP	P,LPSA
05900		HRRZ	A,(LPSA)		;PDP POINTER.
06000		HRLZM	A,(TEMP)		;SAVE LINKS IN NEW BLOCK.
06100		HRRM	TEMP,(A)		;AND IN PDP
06200		JRST	MORBLK
06300	
     

00100	
00200	DSCR BPOP
00300	CAL PUSHJ via QPOP macro
00400	PAR LPSA ptr to  QPDP
00500	RES A ← data from TOP, QPDP is updated
00600	DES Semblks are released as they are emptied
00700	SID only TEMP, A are changed
00800	ERR if there is no QPDP, or if no more data, error
00900	SEE QPOP
01000	⊗
01100	
01200	↑BPOP:	SKIPN	TEMP,(LPSA)		;PDP POINTER
01300		ERR	<DRYROT -- BPOP>
01400		HLRZ	A,TEMP
01500	POPMOR:	SUBI	A,1			;THIS IS A POP
01600		CAIGE	A,(TEMP)		;GONE BELOW THIS BLOCK?
01700		JRST	POPBAK			;YES ALAS
01800		HRLM	A,(LPSA)		;UPDATE PDP
01900		MOVE	A,1(A)			;THIS IS THE RESULT.
02000		POPJ	P,
02100	
02200	POPBAK:	PUSH	P,TEMP
02300		HLRZ	TEMP,(TEMP)		;BACKWARD POINTER.
02400		PUSH	P,TEMP
02500		FREBLK	<-1(P)>			;DELETE THE BLOCK.
02600		POP	P,TEMP
02700		POP	P,(P)			;INGNORE THIS.
02800		SKIPN	TEMP			;IS IT THERE?
02900		ERR	<DRYROT -- BPOP>
03000		HLLZS	(TEMP)			;ZERO FORWARD POINTER
03100		MOVEM	TEMP,(LPSA)		;UPDATE PDP
03200		MOVEI	A,BLKLEN-1(TEMP)	;NEW MAX.
03300		JRST	POPMOR			;FINISH OUT.
03400	
03500	
03600	DSCR QTAK
03700	CAL PUSHJ, via QTAKE macro
03800	PAR B is QPDP for data word preceding one desired
03900	 LPSA ptr  QPDP for this QSTACK
04000	RES if there is more data (check via LPSA ptr):
04100	 B is updated as if it were a BPUSH QPDP
04200	 A receives value of TOP
04300	 BTAK skips
04400	
04500	 if there is no more data:
04600	 nothing is changed
04700	 BTAK does not skip
04800	SID only A,B, TEMP changed
04900	SEE QTAKE macro
05000	⊗
05100	↑QTAK:	CAMN	B,(LPSA)		;OVERFLOW?
05200		POPJ	P,			;YUP
05300		HLRZ	TEMP,B
05400		CAIL	TEMP,BLKLEN-1(B)	;OVERFLOW OF OTHER TYPE?
05500		JRST	NEXTBL			;YES
05600	TAKMOR:	MOVE	A,1(TEMP)
05700		HRLI	B,1(TEMP)
05800		AOS	(P)
05900		POPJ	P,
06000	
06100	NEXTBL:	HRRZ	B,(B)			;GO FORWARD
06200		HRRZ	TEMP,B			;NOTE THAT THE BLOCKS ARE
06300		JRST	TAKMOR			;NOT DELETED !!!!!!
06400	
     

00100	
00200	DSCR BBACK
00300	CAL PUSHJ via QBACK macro
00400	PAR B contains QPDP
00500	RES B is "popped"
00600	 A receives data from TOP word
00700	 if there was data left, skip-returns -- else no-skip
00800	SID only A, TEMP, B changed
00900	SEE QBACK
01000	⊗
01100	↑↑BBACK: HLRZ	A,B		;ptr to TOP, ACCORDING TO B'S QPDP
01200	BTMOR:	SUBI	A,1		;TRY THE "POP"
01300		CAIGE	A,(B)		;WAS THERE DATA LEFT HERE?
01400		 JRST	 BTBAK		;NO, BACK UP
01500		HRLM	A,B		;UPDATE B'S QPDP
01600		MOVE	A,1(A)		;FETCH "TOP" ELEMENT
01700		AOS	(P)		;SUCCESS UNLESS SOSED BY BTBAK
01800	QPOPJ:	POPJ	P,		;DONE
01900	
02000	BTBAK:	HLRZ	B,(B)		;BACK UP
02100		JUMPE	B,QPOPJ		; NO MORE DATA
02200		MOVEI	A,BLKLEN-1(B)	;RESET LH PTR
02300		JRST	BTMOR		;FINISH UP
02400	
02500	DSCR BFLUSH
02600	CAL PUSHJ, via QFLUSH macro
02700	PAR LPSA ptr to QPDP
02800	RES all Semblks cleared, QPDP zeroed
02900	SID A, B, TEMP changed
03000	SEE QFLUSH
03100	⊗
03200	↑↑BFLUSH: SKIPN	A,(LPSA)
03300		 POPJ	P,		;NO STACK
03400	FLSHLP:	HLRZ	B,(A)		;GET NEXT PTR
03500		FREBLK	(A)		;RELEASE TOP SEMBLK
03600		MOVE	A,B
03700		JUMPN	A,FLSHLP	;MAKE NEXT ONE BACK TOP ONE
03800		SETZM	(LPSA)		;ALL DONE
03900		POPJ	P,
04000	
04100	DSCR BBEG
04200	CAL PUSHJ, via QBEGIN macro
04300	PAR B is QPDP
04400	RES B is QPDP which, when BTAKEd, returns first element in Qstack
04500	 B is 0 if no Qstack exists
04600	SID only B, TEMP changed
04700	SEE QBEGIN
04800	⊗
04900	↑↑BBEG:	SKIPN	B,(LPSA)	;IS THERE A STACK?
05000		 POPJ	 P,		; NO
05100	LOPPP:	HRLS	B		;MAKE INIT QPDP FOR THIS SEMBLK
05200		HLRZ	TEMP,(B)	;GET BACK PTR
05300		JUMPE	TEMP,CPOPJ	;WHEN HAVE REACHED FIRST SEMBLK, QUIT
05400		MOVE	B,TEMP		;TRY AGAIN
05500		JRST	LOPPP
05600	
     

00100	COMMENT ⊗PWR2⊗
00200	
00300	DSCR PWR2
00400	DES Tests number in register B for being a power of 2.
00500	 if so, it skip-returns (********) and C
00600	 has a small integer representing the power.
00700	
00800	SID AC'S: uses TEMP
00900	⊗;
01000	↑PWR2:	JUMPLE	B,CPOPJ		;ROUTINE TO TEST B FOR A POWER OF TWO.
01100		MOVN	TEMP,B		;TWO'S COMPLEMENT.
01200		AND	TEMP,B		;AND THE AND
01300		TLNN	B,777000	;TOO BIG ?
01400		CAME	TEMP,B		;THE MAGIC TEST FOR POWER OF TWO.
01500		POPJ	P,		;NO DICE.
01600		FSC	B,233		;NOW THE NORMALIZE.
01700		ASHC	B,-=44		;NOW CORRECTLY IN C. (LEFT HALF)
01800		SUB	C,[XWD 201,400000]
01900		AOS	(P)
02000		POPJ	P,
02100	
02200	
02300	SUBTTL	Generator Output Routines.
02400	
     

00100	COMMENT ⊗GBOUT Description, Loader Block Format Description⊗
00200	
00300	DSCR GBOUT -- write a block of binary output
00400	DES 
00500	One of the specialized output routines has produced
00600		a loader block, ready for output.  These 
00700		routines are:
00800	
00900		CODOUT -- prepares a code block. Each call
01000		  puts a word of code into a buffer and sets relocation
01100		  appropriately.
01200	
01300		FBOUT -- prepares a fixup block. Each call puts a fixup word into
01400		  a buffer.
01500	
01600		SOUT -- for outputting symbols. Each call puts a symbol
01700		  name (in RADIX50) and an address into a buffer.
01800	
01900	Other parts of the generators also call GBOUT for special functions
02000		(entry block, prog name block, etc). The routines
02100		call GBOUT when their buffers are full or when they 
02200		wish to force out all of a given block.
02300	
02400	Each block outputted by GBOUT has the same general format:
02500		WD1:  BLOCK TYPE,,COUNT
02600			0 LEQ COUNT (WDn-WD3+1) LEQ 18
02700		WD2:  relocation bits
02800			18 2-bit bytes (left-justified) corresponding
02900			  to the 18 (maximum) data words in the block.
03000			  The first bit of each is on if the left
03100			  half is to be relocated. The second bit
03200			  of each corresponds to the right half
03300			  of its data word.
03400		WD3:  first data word
03500		.
03600		.
03700		.
03800		WDn:  last data word		2 LEQ n LEQ 20
03900	
04000	The Binary file is opened and initialized in the command
04100		scanner (outer block of SAIL). The FF bit BINARY
04200		is on if a binary output is desired (if the file is open).
04300	
04400	PAR B -- SIZE,,address of loader block
04500	 SIZE is size of ENTIRE block (2 + WD1's count)
04600	  It is zero if WD1's COUNT is to be believed.
04700	
04800	RES The block is written if SIZE is GEQ 3
04900	
05000	SID All ACS are preserved 
05100	⊗;
05200	
     

00100	COMMENT ⊗ Control Variables for Loader Block Output⊗
00200	
00300	ZERODATA (REL-FILE OUTPUT VARIABLES)
00400	
00500	;CODPNT -- bp for relocation bits in BINTAB CODE block
00600	;    see GBOUT for details about relocation bits -- initted to --
00700	?CODPNT: POINT 2,BINTAB+1
00800	
00900	;FRSTSW -- off until first word of code goes out -- used to
01000	;    trigger output of program name block, initial code, etc.
01100	;    in CODOUT -- set on in CODOUt
01200	?FRSTSW: 0
01300	
01400	;FXPNT -- reloc bits bp for FXTAB FIXUP block -- see FBOUT, GBOUT
01500	?FXPNT: POINT 2,FXTAB+1
01600	
01700	;LSTRAD, LSTRLC, LSTWRD -- last radix50 word output, last code
01800	;    word output, last relocation bits output -- used by Boolean
01900	;    and ALLOT code, for repeating some of it
02000	↑↑LSTRAD: 0
02100	↑↑LSTRLC: 0
02200	↑↑LSTWRD: 0
02300	
02400	;OUTADR -- bp set up by GBOUT for fetching words from LODBLKs
02500	;    for transfer to output buffer
02600	?OUTADR:  0
02700	
02800	;RAD5. -- RADIX50 creates a value corresponding to a symbol comprising
02900	; the first 5 characters of the identifier, followed by ".", in 
03000	; addition to each value it creates.  It is saved here, used sometimes.
03100	↑↑RAD5.: 0
03200	↑↑RAD5$: 0	;SIMILAR, BUT WITH A $
03300	↑↑RAD5%: 0	;GUESS WHAT
03400	;SMPNT -- reloc bits pb for SMTAB SYMBOLS block -- see SCOUT, GBOUT
03500	?SMPNT:  0
03600	
03700	DATA (REL-FILE OUTPUT VARIABLES)
03800	
03900	;SALIB -- used to place main SAIL library request in LBTAB output
04000	;   loader block -- see DONES, PRGOUT
04100	;SALIH -- re-entrant version of library
04200	
04300	↑SALIB:	LIBLEN		;STRING CONSTANT, LIBLEN LONG
04400	;;#HX# 6-24-72 DCS PARAMETERIZE LIBRARY NAMES
04500		POINT	7,[LIBLOW]
04600	REN <
04700	↑SALIBH:LIBLEN
04800		POINT	7,[LIBHI]
04900	;;#HX#
05000	>;REN
05100	
05200	BAIL<
05300	↑BAIREL: BALENG		;STRING CONSTANT, BALENG LONG
05400		POINT	7,[BAILOD]
05500	↑BAIPD:	BPDALN		;STRING CONSTANT
05600		POINT	7,[BAIPDS]
05700	>;BAIL
05800	
     

00100	COMMENT ⊗ Loader Output Blocks-- Entry, Program Name, Initial Stuff⊗
00200	 
00300	DATA (LOADER OUTPUT BLOCKS)
00400	COMMENT ⊗
00500	Here are the loader output blocks.  They are formatted as described
00600	   in SAILON ;;.; by Bill Weiher.  The general routine GBOUT handles
00700	   the actual output of these (filled) blocks to the .REL file.  For
00800	   several of the block types, special routines exist below (CODOUT,
00900	   FBOUT, etc.) to place individual words (and their relocation) into
01000	   the blocks, and to call GBOUT when a block is full
01100	⊗
01200	
01300	
01400	COMMENT ⊗
01500	ENTTAB -- ENTRY block -- names included in SAIL ENTRY statements.
01600	   This must be the first block out (due both to syntax and
01700	   necessity.  It allows the .REL file to be used as part
01800	   of a library.
01900	⊗
02000	LODBLK	(ENTRY,4,ENTTAB,,=18)
02100	
02200	
02300	COMMENT ⊗
02400	PROGNAM -- PROGRAM NAME BLOCK -- output of this block is delayed until
02500	   first word of code goes out, to give user longest possible time
02600	   to come up with a program name.  Must go out before code to name 
02700	   outer block symbols and labels and stuff.
02800	⊗
02900	;;%CL% JFR 7-22-75 IDENTIFY OURSELVES TO LINK-10
03000	LODBLK	(PROGNAM,6,BEGNAM,BEGCNT,2)
03100	RELOC .-2
03200	↑↑PRGTTL: RADIX50 0,M		;DEFAULT NAME, IF NO OTHER COMES
03300	XWD	7,0	;7 means SAIL, bits 0-5 tell hardware assumptions
03400	;;%CL% ↑
03500	
03600	COMMENT ⊗
03700	HBLK -- High Segment Block -- Denotes Re-entrant Output
03800	⊗
03900	REN <
04000	LODBLK	(HIGH,3,HBLK,HBLK2,1,,<XWD 200000,0>)
04100	RELOC .-1
04200		XWD	400000,400000	;TWOSEG
04300	>;REN
04400	
04500	
04600	
04700	COMMENT ⊗
04800	BEGOUT -- STANDARD INITIAL CODE SEQUENCE
04900	   This code is always put out, but is only executed (and fixups
05000	   are only correct) for Main Programs.  Sample fixed-up code is
05100	   included in the comments
05200	⊗
05300	
05400	
05500	LODBLK (CODE,1,BEGOUT,BEGCT2,10,,<XWD 200000,0>)
05600	RELOC .-10
05700	
05800	↑↑BEGPC:0		;PC ALWAYS 0 OR 400000
05900		SKIPA		;NOT STARTED IN RPG
06000		SETOM		;RPGSW
06100		JSR		;SAILOR
06200	;;%AL% THE HRLOI IS NOW DONE BY SAILOR
06300	;;	HRLOI	RF,1	;FOR FIRST LINK
06400		PUSH	P,RF
06500		PUSH	P,	;[PDA,,0]
06600		PUSH	P,SP
06700		HRRI	RF,-2(P); SET F
06800	
06900	
07000	
     

00100	COMMENT ⊗                        Code, Boolean Code, Fixups, Links⊗
00200	
00300	COMMENT ⊗
00400	BINTAB -- MAIN CODE BLOCK
00500	   All generated instructions are output via CODOUT-GBOUT
00600	   to this block.  See CODOUT for details
00700	⊗
00800	LODBLK	(CODE,1,BINTAB,,=18)
00900	
01000	
01100	COMMENT ⊗
01200	BOLOUT -- SPECIAL BOOLEAN CODE BLOCK
01300	   Conditionals are output once when a condition is seen, and
01400	   again (with fixups and compare op codes correct) when the
01500	   entire Boolean expression has been parsed and analyzed.
01600	   See BOOLEAN for details.
01700	⊗
01800	LODBLK	(CODE,1,BOLOUT,,0,,<XWD 200000,0>)
01900	↑↑BRELC←.-1	;TO ACCESS RELOCATION BITS
02000	↑↑BPCNT: 0	;PROGRAM COUNTER -- SAME AS WHEN INSTRS FIRST OUT
02100	↑↑BWRD1: 0	;COMPARE, SKIP, OR CONDITIONAL JUMP
02200	↑↑BWRD2: 0	;UNCONDITIONAL JUMP IF BWRD1 WAS A COMPARE OR SKIP
02300	↑↑BWRD3: 0
02400	
02500	
02600	COMMENT ⊗
02700	FXTAB -- FIXUPS
02800	    Each word contains in its right half the address or stack
02900	    displacement (reloc bits adj. accordingly) of a variable
03000	    or instruction.  The left half contains the address 
03100	    (relative to 0, of course) of the last instruction or data
03200	    which requires this address field.  This location, in turn,
03300	    was compiled to refer to the next previous use of the variable
03400	    or whatever... in other words, a fixup chain (terminates in 0).
03500	    The LOADER uses these fixups to handle forward references to 
03600	    things.  See FBOUT for details
03700	⊗
03800	LODBLK	(FIXUPS,10,FXTAB,,=18,-1)
03900	
04000	
04100	COMMENT ⊗
04200	SMTAB -- SYMBOLS
04300	    All local and internal symbols, and global requests, are output
04400	    through this block.  See SCOUT and friends for details.
04500	⊗
04600	LODBLK	(SYMBOLS,2,SMTAB,,=18,<XWD 42104,210421>)
04700	;(RELOCATE EVERY OTHER WORD -- GENERALLY)
04800	
04900	
05000	COMMENT ⊗
05100	SLNKBK -- LINK BLOCKS
05200	    The string link, space link, and other links are output
05300	    through this block.  These links provide inter-RELfile
05400	    communication (best example is link that chains all string
05500	    variables together, so that STRNGC can get at them. See
05600	    LNKOUT for details.
05700	⊗
05800	LODBLK	(LINK,12,SLNKBK,SDSCRP,2,,<XWD 40000,0>)
05900	 RELOC	.-2
06000	↑↑LNKNM: 1		;USUALLY STRING LINK, BY CONVENTION #1
06100				;SPACE LINK IS #2
06200				;SET LINK IS #3
06300				;STRNGC ROUTINE NAMES LINK IS #4
06400				; THESE ARE SAIL CONVENTIONS ONLY
06500	↑↑SLNKWD: 0		;ADDRESS OF ELEMENT OF CHAIN
06600	
     

00100	COMMENT ⊗                        Space Allocation Block
00200	
00300	SBCTBL -- SPACE ALLOCATION BLOCK
00400	    In this block is collected all REQUIRE specifications
00500	    (except LOAD!MODULES, LIBRARIES, SOURCE!FILES) and 
00600	    space limits (string space, system pdl, new items, etc.)
00700	    It is output as a code block.  Also output is a link
00800	    block tying this space block to all the others loaded
00900	    together.  The SAILOR (initialization) routine uses this
01000	    information to provide an environment pleasing to the user.
01100	    See DONES and the REQUIRE code for more details. Also GOGOL
01200	    (%ALLOC) for block format explanations
01300	⊗
01400	;;%BR% RHT ALLOW COMVER THING FOR EVERYONE (BUT KEEP EXPO FOR NOW)
01500	↑↑SPCSIZ←←=17    ;$SPREQ+1	;IF EVER MAKE 18 OR MORE, MUST CHANGE SOME THINGS
01600	;;↑↑SPCSIZ←←=14			;BAD OLD VALUE *****
01700	;;%BR% ↑
01800	
01900	↑↑SPCTBL:XWD	1,SPCSIZ	;CODE BLOCK, AT LEAST SPCSIZ LONG
02000		BYTE (2) 1,0,0,0,0,1,0,0,0,0,0,0,1,1,0,1
02100			;PC WORD,MESLNK,TINIT,PINIT,OBPDA(RELOC)
02200	↑SPCPC: 0	;PC LOCATION
02300		0	;LINK BLOCK PROVIDES CHAIN THROUGH THIS LOC
02400	;; %AG% HAVE ITEMNO KEEP BOTH MIN AND MAX
02500	↑ITEMNO:0	;MIN,,MAX ITEM NUMBER DECLARED THIS COMPILATION
02600	↑NWITM:  0	;REQUIRE n NEW!ITEMS PUTS n HERE
02700	;; %AG% ! HAVE GITEMNO CONTAIN LEAPIS FLAG
02800	↑GITEMNO:0	;XWD LEAPIS,MAX (MIN?) GLOBAL ITEM NUMBER DECLARED
02900	↑MESLNK:0	;POINTER TO MESSAGE PROCEDURE LIST PUT HERE
03000	↑PNAMNO:0	;REQUIRE n PNAMES PUTS n HERE
03100	↑VERNO:	0	;REQUIRE n VERSION PUTS n HERE
03200	↑SEGNAM:0	;REQUIRE "name" SEGMENT!NAME PUTS "name" HERE IN SIXBIT
03300	↑SEGDEV:0	;REQUIRE "dev:file[p,pn]" SEGMENT!FILE PUTS
03400	↑SEGFIL:0	; dev, file, ppn IN THESE LOCS IN SIXBIT
03500	↑SEGPPN:0	;(LOW BIT OF DEV IS SEGMENT PROTECT BIT, NOT USED NOW)
03600	↑TINIT: 0	;INITIALIZATION BLOCK ADDRESS FOR DECLARED ITEM TYPES
03700	↑PINIT: 0	;INIT. BLOCK FOR PNAMES(DECLARED ITEMS)
03800	;;%BR% 
03900	↑↑COMVER:	0	;NICE THING, BUT SUAI 
04000	;;%BV% !
04100	↑↑OBPDA:0		;OUTER BLOCK PDA
04200		0		;SPARE
04300	;;%BR% ↑
04400		BLOCK	50		;ROOM FOR MORE REQUESTS
04500	↑SPCEND←←.-1
04600	
04700	
04800	
     

00100	COMMENT ⊗                        Request Blocks -- RELfile, Libraries⊗
00200	
00300	COMMENT ⊗
00400	PRGTAB -- RELFILE REQUEST BLOCK
00500	   REQUIRE "...." LOAD!MODULE generates one of these.  The LOADER
00600	   loads all requested .REL files after loading all the explicit
00700	   stuff. See REQUIRE code for details
00800	⊗
00900	;; #KS# ADD LOADVR SWITCH
01000	IFN (LOADVR-=54), <
01100	LODBLK	(RELREQ,15,PRGTAB,,=18)
01200	>
01300	IFE (LOADVR-=54), <
01400	LODBLK  (RELREQ,16,PRGTAB,,=18)
01500	>
01600	;; #KS#
01700	
01800	COMMENT ⊗
01900	LBTAB -- LIBRARY REQUEST BLOCK
02000	   REQUIRE "...." LIBRARY generates one of these (SAIL main programs
02100	   automatically request SYS:LIBSAI.REL).  The LOADER searches these
02200	   libraries, if necessary, after searching all the others except the
02300	   automatic F4 search.
02400	⊗
02500	
02600	;; #KS# LOADVR SWITCH
02700	IFN (LOADVR-=54), <
02800	LODBLK  (LIBREQ,16,LBTAB,,=18)
02900	>
03000	IFE (LOADVR-=54), <
03100	LODBLK  (LIBREQ,17,LBTAB,,=18)
03200	>
03300	;; #KS#
03400	
03500	
     

00100	COMMENT ⊗                        Ending Code, Symbols -- END Block
00200	
00300	STAROT ETC. -- ENDING STUFF.
00400	   These include some constant ending code, some extra standard
00500	   symbols, the starting address block, if there is one, and so on.
00600	   It's too messy to use the LODBLK macro on, so here it is in
00700	   all its glory--
00800	⊗
00900	EBLEN←←.		;COLLECT LENGTH.
01000	
01100	;If this is a Main Program, a starting address block is issued
01200	; (via the GBOUT descriptor EBDSC); else EBDSC1 is used to issue
01300	; all but the starting address block.  Starting address is always
01400	; relative 0 (addr of the BEGOUT code--see above)
01500	?STAROT: XWD	7,1	;STARTING ADDR BLOCK -- 1 DATA WORD
01600		XWD 200000,0 	;RELOCATE ADDRESS (RH)
01700	↑STRDDR:0		;STARTING ADDRESS ALWAYS REL 0
01800	
01900	; If Main Program, global requests must be issued to fill in
02000	; the RPGSW and SAILOR blanks in the BEGOUT block (above)
02100		XWD	2,4	;SYMBOL BLOCK
02200		XWD	42104,210421 ;EVERY OTHER WORD.
02300	↑CONSYM:RADIX50	60,SAILOR;JSR REQUEST.
02400		2		;JSR IS IN LOC 2
02500		RADIX50 60,RPGSW;FOR SETOM RPGSW BUSINESS
02600		1		;SETOM IS IN 1
02700	
02800	; This part is always issued -- standard symbol names, end block
02900	NOSTAR: XWD	2,STRCT-NOSTAR-2;SYMBOLS
03000		XWD	40000,0;RELOCATE ONLY S.
03100		RADIX50	10,S.  ;FIRST EXECUTABLE LOC IN PROG
03200		0		;ALWAYS 0
03300		RADIX50	10,P	;SYSTEM PDP ADDR
03400		RP		;USUALLY 17
03500		RADIX50	10,SP	;STRING PDP ADDR
03600		RSP		;USUALLY 16
03700		RADIX50 10,ARERR;UUO FOR ARRAY INDEX OV/UNDERFLOW
03800		ARERR		;THE UUO OPCODE
03900		RADIX50	10,FLOAT;UUO FOR INTEGER to REAL
04000		FLOAT
04100		RADIX50	10,FIX  ;UUO FOR REAL to INTEGER
04200		FIX
04300		RADIX50 10,SNGL	;UUO FOR LONG REAL to REAL
04400		SNGL
04500	STRCT:			;END OF EXTRA SYMBOLS
04600	
04700	; END BLOCK
04800	NOREN <
04900		XWD	5,1	;END BLOCK.
05000		XWD 200000,0	;RELOCATE PROGRAM BREAK WORD
05100	↑↑PRGBRK: 0		;PROGRAM BREAK-- FIRST NON-USED ADDR
05200	>;NOREN
05300	REN <
05400		XWD	5,2	;TWO PROGRAM BREAKS
05500		XWD 240000,0	;RELOCATE PROGRAM BREAK WORD
05600	↑↑PRGBRK: 0		;HIGH-SEG PROGRAM BREAK
05700		  0		;LOW-SEG PROGRAM BREAK
05800	>;REN
05900	
06000	EBLEN←← .-EBLEN		;LENGTH OF ENTIRE OUTPUT RITUAL
06100	
06200	↑EBDSC:	XWD	EBLEN,STAROT	;IF MAIN PROGRAM
06300	↑EBDSC1:XWD	EBLEN+STAROT-NOSTAR,NOSTAR ;IF NOT
06400	ENDDATA
06500	
     

00100	COMMENT ⊗ RELINI -- Loader Block Initialization⊗
00200	
00300	DSCR RELINI
00400	CAL PUSHJ FROM GENINI
00500	DES SETS UP ALL REL-FILE OUTPUT STUFF BEFORE EACH COMPILATION
00600	⊗
00700	
00800	↑↑RELINI:
00900		HLLZS	BINTAB
01000		HLLZS	FXTAB
01100		SETOM	FXTAB+1			;ALL RELOCATABLE
01200		HLLZS	SMTAB			;CLEARS OUTPUT BUFFER COUNTS
01300		HLLZS	PRGTAB			;PROGRAM AND LIBRARY REQUEST BLOCKS
01400		HLLZS	LBTAB
01500		MOVE	A,[XWD SPCPC,SPCPC+1] ;CLEAR SPACE ALLOCATION BLOCK
01600		SETZM	SPCPC
01700		BLT	A,SPCEND		;SIZE ALLOCATION BLOCK.
01800		HRRI	TEMP,SPCSIZ
01900		HRRM	TEMP,SPCTBL
02000		POPJ	P,			;RETURN TO GENINI
02100	
     

00100	COMMENT ⊗ GBOUT Routine⊗
00200	
00300	↑GBOUT:	
00400		PUSH	P,A		;SAVE A
00500		PUSH	P,B		;SAVE ADDRESS OF BUFFER
00600		HLRZ	A,B		;GET COUNT IF NONSTANDARD
00700	
00800		TLO	FF,IREGCT	;SET NON-STANDARD COUNT BIT
00900		HRLI	B,(<POINT 36,0>)	;FOR PICKING UP WORDS
01000		MOVEM	B,OUTADR	;SAVE TABLE ADDRESS
01100		JUMPN	A,GBOUTA	;NOT STANDARD (FROM TABLE) COUNT
01200		HRRZ	A,(B)		;GET COUNT FROM BLOCK
01300	;;#TR# BE MORE HONEST ON COMPUTING THIS
01400	;	ADDI	A,2		; +2 FOR BLOCK TYPE & RELOC
01500		ADDI	A,=35		; CNT ← CNT+1+FLOOR((A+17)/18)
01600		IDIVI	A,=18
01700		HRRZ	B,@OUTADR	;WORD CNT AGAIN
01800		ADD	A,B		; CORRECT VALUE (I HOPE)
01900	
02000		TLZ	FF,IREGCT	;RESET NON-STANDARD COUNT BIT
02100	
02200	;  OUTPUT ROUTINE
02300	
02400	GBOUTA:	TLNN	FF,BINARY	;IS THERE A BINARY FILE?
02500		JRST	OUTDUN		;NO, DON'T WRITE
02600		CAIGE	A,3		;IS THERE ANYTHING TO WRITE?
02700		JRST	OUTDUN		;NO, DON'T DO IT
02800	
02900	NOTENX <
03000	BQN:	SOSLE	BINCNT		;FULL?
03100		JRST	OKOUT		;NO
03200		OUTPUT	BIN,0		;EMPTY BUFFER, ON TO NEXT
03300		TSTERR	BIN		;ERRORS?
03400		ERR	<OUTPUT ERROR ON BINARY FILE>
03500	
03600	OKOUT:	ILDB	B,OUTADR	;BLOCK WORD
03700		IDPB	B,BINPNT
03800		SOJG	A,BQN		;WRITE THEM ALL
03900	>;NOTENX
04000	TENX <
04100		PUSH	P,C
04200		MOVNI	C,(A)
04300		MOVE	B,OUTADR
04400		SKIPL	A,BINJFN	;JUST IN CASE IT'S -1 (DUMMY)
04500		 JSYS	SOUT
04600		MOVEM	B,OUTADR	;UPDATE OUTADR
04700		POP	P,C
04800	>;TENX
04900	
05000	OUTDUN:	POP	P,B		;GET BUFFER ADDR BACK
05100		TLZN	FF,IREGCT	;DON-'T CLEAR IF NON-STANDARD COUNT
05200		HLLZS	(B)		;CLEAR COUNT
05300		POP	P,A		;RESTORE A
05400		POPJ	P,
05500	
     

00100	COMMENT ⊗ CODOUT Routine -- Output Code or Data⊗
00200	
00300	DSCR   CODOUT -- WRITE DATA    (ALSO CODREL)
00400	
00500	PAR WORD IN "A"
00600	  relocatable if RELOC in in "FF"
00700	  (if rh of A is zero, then never RELOC. If you want to
00800			 TO BYPASS THIS TEST, CALL "CODREL").
00900	
01000	RES Writes word, increments program counter (PCNT)
01100	
01200	SID Uses A,B,C -- Saves all
01300	⊗;
01400	
01500	↑CODOUT:	
01600		SKIPE	NOEMIT		; GET OUT IF NO CODE IS TO BE EMITTED (I.E. 
01700		POPJ	P,		;  EXPR!TYPE)
01800		PUSH	P,A
01900		PUSH	P,B
02000	
02100		SKIPE	FRSTSW	;HAVE WE DONE THIS BEFORE
02200		 JRST	 COD1		; YES, DON'T DO AGAIN
02300		SETOM	FRSTSW
02400		PUSH	P,LPSA		;AND SOME OTHERS
02500		MOVEI	LPSA,IPROC	;GET PROGRAM NAME.
02600		PUSHJ	P,RAD50		;IN RADIX50
02700		TLZ	A,740000	;RADIX50 0,NAME
02800		MOVEM	A,PRGTTL
02900		MOVE	B,BEGCNT
03000		PUSHJ	P,GBOUT		;WRITE NAME BLOCK
03100	REN <
03200		MOVEI	A,0
03300		SKIPN	HISW		;TWO-SEGMENT PROGRAM?
03400		 JRST	 JUST1		;NO
03500		MOVE	B,HBLK2		;YES, WRITE HISEG (TYPE 3) BLOCK
03600		PUSHJ	P,GBOUT
03700		MOVEI	A,400000	;BEGINNING PC
03800	JUST1:
03900		MOVEM	A,BEGPC		;IN WHICH SEGMENT
04000	>;REN
04100		MOVE	B,BEGCT2	;CALL TO INIT & LINKAGE
04200		PUSHJ	P,GBOUT
04300	COD2:	POP	P,LPSA
04400		MOVE	A,-1(P)		;RESTORE A.
04500	
04600	COD1:	TRNN	A,-1		;ZERO ADDRESS?
04700		TLZ	FF,RELOC	;YES, NO RELOC
04800		JRST	CDRL1
04900	↑CODREL:
05000		PUSH	P,A		;ENTER HERE TO BYPASS ZERO TEST
05100		PUSH	P,B
05200	CDRL1:
05300		HRRZ	B,BINTAB	;GET COUNT
05400		JUMPN	B,BAQ		;FIRST WORD OF BLOCK?
05500	
05600		AOS	BINTAB		;YES, SET UP BLOCK
05700		MOVE	B,PCNT		;SET LOCATION WORD
05800		MOVEM	B,BINTAB+2	;INTO 3D WORD OF BLOCK
05900		SETZM	BINTAB+1	;CLEAR RELOCATION BITS
06000		MOVE	B,[POINT 2,BINTAB+1] ;BYTE POINTER FOR RELOC BITS
06100		MOVEM	B,CODPNT	;TO RIGHT PLACE
06200		MOVEI	B,1		;RELOCATE THE LOC COUNTER WORD
06300		IDPB	B,CODPNT
06400	
06500	BAQ:	AOS	B,BINTAB	;INCREMENT COUNT
06600		HRRZS	B		;AND MOVE TO B
06700		MOVEM	A,BINTAB+1(B)	;DEPOSIT WORD
06800		MOVEM	A,LSTWRD	;SAVE LAST WORD OUTPUT
06900		LDB	A,[POINT 1,FF,RLCPOS] ;RELOC?
07000		SKIPE	LHRELC		;RELOC LEFT HALF?
07100		ADDI	A,2		;SAY SO
07200		MOVEM	A,LSTRLC	;AND LAST RELOCATION BIT.
07300		IDPB	A,CODPNT	;SET RELOC BITS
07400	
07500		AOS	PCNT		;INCREMENT COUNT
07600	
07700		CAIGE	B,22		;FULL?
07800		JRST	CDRET		;NO, RETURN
07900	
08000		MOVEI	B,BINTAB	;INDICATE STANDARD COUNT AND WHICH TABLE
08100		PUSHJ	P,GBOUT		;WRITE BLOCK
08200	;	JRST	CDRET
08300	
08400	CDRET:	POP	P,B
08500		POP	P,A
08600		POPJ	P,
08700	
08800	↑CODLRL:			;RELOCATE LEFT HALF -- FF SAYS ABOUT RIGHT HALF
08900		TLNE	A,-1		;NEVER RELOCATE 0
09000		SETOM	LHRELC 		;SET FLAG
09100		PUSHJ	P,CODOUT
09200		SETZM	LHRELC
09300		POPJ	P,
09400	
09500	ZERODATA( DISPLAY STUFF)
09600	LHRELC:	0
09700	ENDDATA
09800	
09900	
10000	
     

00100	
00200	DSCR FRBT
00300	DES Force out current binary (BINTAB) code block,
00400	  even if it's not full yet.  This is done whenever
00500	  symbols or fixups which might refer to this code
00600	  are put out, so that there is something to fixup
00700	  or refer to symbolically.  It is also called from DONES.
00800	SID Saves all ACS
00900	⊗
01000	
01100	↑FRBT:	PUSH	P,B
01200		MOVEI	B,BINTAB
01300		PUSHJ	P,GBOUT		;CLEAR BINARY BUFFER
01400		POP	P,B
01500		POPJ	P,
01600	
01700	
     

00100	COMMENT ⊗ FBOUT, etc. -- Output Fixups⊗
00200	
00300	DSCR  FBOUT,FIXOUT,FBOSWP
00400	DES Put word of fixup information into output file.
00500	PAR B contains fixup specification:
00600	   lh -- PCNT of actual location of entity
00700	   rh -- PCNT of last word in fixup chain.
00800	 FBOSWP takes the above B value, swapped.
00900	RES This word is written into the FXTAB fixup Loader
01000	  block via GBOUT (when there are enough).
01100	 FBOUT always assumes both halves reloatable
01200	 FIXOUT always assumes the actual (lh) address is not
01300	  relocatable
01400	 FBOSWP is included for convenience
01500	SID Saves all ACs
01600	⊗;
01700	
01800	↑FXOSW2: MOVSS 	B
01900		PUSHJ	P,FIXOUT
02000		MOVSS	B
02100		POPJ	P,
02200	↑FBOSW2: MOVSS  B
02300		PUSHJ	P,FBOUT
02400		MOVSS	B
02500		POPJ	P,
02600	
02700	↑FBOSWP: MOVSS	B
02800	↑FBOUT:	SKIPE	NOEMIT		; GET OUT IF NO CODE IS TO BE EMITTED (I.E. 
02900		POPJ	P,		;  EXPR!TYPE)
03000		TLNN	B,-1		;IS LEFT HALF ZERO?
03100		ERR	<DRYROT -- FBOUT>,1
03200		TLOA	FF,FFTEMP	;USE RELOCATION IN FIXUP SIDE
03300	↑FIXOUT:
03400		TLZ	FF,FFTEMP	;DO NOT RELOCATE FIXUP PART
03500		PUSH	P,B
03600		PUSH	P,A		;SAVE A
03700		HRRZ	A,FXTAB
03800		JUMPN	A,FAQ		;FIRST WORD OF BLOCK?
03900		MOVE	A,[POINT 2,FXTAB+1] ;YES, RESET RELOCATION BIT POINTER
04000		MOVEM	A,FXPNT		; (SEE CODOUT FOR SIMILARITIES)
04100	FAQ:
04200		AOS	A,FXTAB		;INCREMENT AND FETCH COUNT
04300		HRRZS	A
04400		MOVEM	B,FXTAB+1(A)	;DEPOSIT WORD
04500		MOVEI	B,3		;ASSUME BOTH HALVES RELOC
04600		TLNN	FF,FFTEMP	;TEST ASSUMPTION
04700		 MOVEI	 B,2		; WRONG
04800		IDPB	B,FXPNT		;INSERT RELOCATION BITS
04900	
05000		CAIGE	A,22		;FULL?
05100		JRST	FXRET		;NO, RETURN
05200	
05300		PUSHJ	P,FRBT		;FORCE OUT ANY BINARY
05400					;(BECAUSE FIXUPS HAVE TO COME AFTER)
05500	
05600		MOVEI	B,FXTAB	
05700		PUSHJ	P,GBOUT		;WRITE BLOCK
05800	
05900	FXRET:	POP	P,A
06000		POP	P,B
06100		POPJ	P,
06200	
06300	
06400	
     

00100	COMMENT ⊗ SCOUT, etc. -- Output Symbols⊗
00200	
00300	DSCR SOUT,SCOUT,SHOUT,SCOUT0
00400	DES Output symbols in RADIX50 -- many ways exist for
00500	  obtaining symbols for output, thus the proliferation.
00600	
00700	PAR
00800	SOUT:	LPSA -- Semantics ptr. $PNAME and $ADR  are used to
00900		obtain the symbol and address.
01000	SHOUT:	LPSA -- descriptor of the form:
01100		 bits 0-5  DDT symbol type
01200		      6-17  #characters
01300		     18-35  address of string in ASCII (assumed justified)
01400		B -- address for symbol
01500	SCOUT:	A -- RADIX50 for symbol
01600		B -- address for symbol
01700	SCOUT0:  SAME AS SCOUT, BUT MAKES SYMBOL NON-RELOCATABLE.
01800	
01900	SID A, TEMP, may be different on exit
02000	⊗;
02100	
02200	↑SHOUT:	PUSHJ	P,RAD52
02300		JRST	SCOUT		;MAKE RADIX50 FROM DESCRIPTOR
02400	
02500	↑SCOUT0: PUSH	P,B		;NON-RELOCATED SYMBOL
02600		MOVEI	TEMP,0
02700		JRST	SASS
02800	
02900	
03000	↑SOUT:	PUSHJ	P,RAD50		;GET RADIX50 FOR SYMBOL
03100		PUSH	P,B		;SAVE IT
03200	;;# # RHT 3-19-73 MAKE RECSV SYMBOLS GO OUT UNRELOC
03300		HRRZ	B,$ADR(LPSA)	;GET ADDRESS
03400		MOVE	TEMP,$SBITS(LPSA);DOES THIS SYMBOL USE THE STACK?
03500		TRNN	TEMP,DLFLDM	;
03600		JRST	SOUT.0		;NO
03700		CAIGE	B,20		;HALF KILL??
03800		TLO	A,400000	;YES
03900		MOVEI	TEMP,0		;
04000		JRST	SASS
04100	;;# # RHT
04200	
04300	;;# # RHT -- 7-13-73 EXTRA KLUGE TO USE THE RAD5$ SYMBOL FOR
04400	;;			SPECIAL BILTIN RUNTIMES
04500	SOUT.0:	SETCM	TEMP,$TBITS(LPSA)
04600		TLNE	TEMP,FNYNAM+OWN+EXTRNL
04700		JRST	SOUT.1		;REGULAR
04800		SKIPA	A,RAD5$		;PREMIUM
04900	;;# #
05000	↑SCOUT:	PUSH	P,B		;SAVE
05100	SOUT.1:	MOVEI	TEMP,1		;RELOCATION BIT.
05200	SASS:	PUSH	P,C
05300		HRRZ	C,SMTAB
05400		JUMPN	C,SAQ
05500		MOVE	C,[POINT 4,SMTAB+1]
05600		MOVEM	C,SMPNT
05700	SAQ:
05800		CAMN	A,LSTRAD	;RADIX50 FOR LAST BLOCK NAME.
05900		JRST	SYMRET		;DO NOT PUT IT OUT.
06000		AOS	C,SMTAB		;BINARY DOES NOT HAVE TO BE
06100		HRRZS	B		;FORCED OUT
06200		MOVEM	A,SMTAB+1(C)
06300		MOVEM	B,SMTAB+2(C)
06400		AOS	C,SMTAB
06500		HRRZS	C
06600		LDB	B,[POINT 4,A,3]	;DON'T RELOCATE BLOCK LEVELS
06700		CAIN	B,3		;BLOCK TYPE 14
06800		MOVEI	TEMP,0
06900		IDPB	TEMP,SMPNT
07000		CAIGE	C,22
07100		JRST	SYMRET
07200	
07300		PUSHJ	P,FRBT		;MAKE BINARY GO FIRST
07400		MOVEI	B,SMTAB
07500		PUSHJ	P,GBOUT
07600	
07700	SYMRET:	POP	P,C
07800		POP	P,B
07900		POPJ	P,
08000	
     

00100	COMMENT ⊗ LNKOUT -- Output Linkage Block⊗
00200	
00300	DSCR LNKOUT -- 
00400	DES Put out a (type 12) Link block via GBOUT. These blocks
00500	  allow chains of addresses to be created through separate
00600	  .REL files. STRINGC uses LINK 1 to find all its strings.
00700	 Other uses are for SETS, STRINGC routine names, and the
00800	  space allocation block.
00900	PAR B -- link number
01000	 PCNT -- decremented by one; that is address for LINK rqst.
01100	⊗
01200	
01300	↑LNKOUT: MOVEM	B,LNKNM		;SAVE LINK NUMBER
01400		PUSHJ 	P,FRBT		;NOTE DOES NOT SAVE ACS
01500		HRRZ	TEMP,PCNT
01600		SUBI	TEMP,1		;LAST WORD OUTPUT WILL HOLD LINK
01700		HRRZM	TEMP,SLNKWD	;PLACE IN ADDR WORD OF LINK BLOCK TEMPLATE
01800		MOVE	B,SDSCRP	;DESCRIPTOR OF LINK BLOCK [COUNT,ADDR OF TEMPLATE]
01900		PUSHJ	P,GBOUT
02000		POPJ	P,		;RETURN AFTER WRITING BLOCK
02100	
     

00100	COMMENT ⊗ PRGOUT, FILSCN -- Output Request Blocks, Scan for Source!file Rqst⊗
00200	
00300	DSCR FILSCN -- CONVERT ASCII FILE-STRING TO SIXBIT
00400	PAR PNAME, PNAME+1 describe a String representing the file
00500	  name.
00600	RES A, C, D return DEVICE, FILENAME, and PPN in SIXBIT
00700	DES Converts String to SIXBIT via FILNAM routine (approp-
00800	  riately informed) in Command Scanner (SAIL). Extension
00900	  not returned, because there's currenlty no need.
01000	SID Nothing much saved
01100	SEE FILNAM, PRGOUT, RQSET, SRCSWT
01200	⊗
01300	NOTENX <
01400	↑↑FILSCN: SETOM	TYICORE		;TYI IN COMND WILL GET CHARS FRM STRNG
01500		PUSH	P,DEVICE	;SAVE FILE DATA
01600		PUSH	P,EXTEN	
01700		PUSH	P,SAVTYI
01800		PUSH	P,EOL
01900		SETZM	SAVTYI		;NO SCAN-AHEAD
02000		MOVSI	TEMP,(<SIXBIT /DSK/>) ;DEFAULT DEVICE
02100		MOVEM	TEMP,DEVICE
02200		PUSHJ	P,FILNAM	;GET SIXBITS IN NAME, EXTEN, ETC.
02300		MOVE	A,DEVICE	;LOAD RESULTS
02400		MOVE	C,NAME
02500		MOVE	D,PPN
02600		POP	P,EOL
02700		POP	P,SAVTYI
02800		POP	P,EXTEN
02900		POP	P,DEVICE	;RESTORE OLD VALUES
03000		POPJ	P,
03100	>;NOTENX
03200	
03300	TENX <
03400	TFLSCN:
03500		BEGIN TFLSCN
03600	
03700	CTRLV←←"V"-100			;TENEX QUOTING CHARACTER
03800	FIND←←D
03900	
04000		SETZM	FIND
04100		PUSH	SP,PNAME	;ORIGINAL NAME -- COPY ONTO STACK
04200		PUSH	SP,PNAME+1
04300		PUSH	SP,[0]		;DEVICE TEMPORARY
04400		PUSH	SP,[0]
04500		PUSH	SP,[0]		;DIR TEMPORARY
04600		PUSH	SP,[0]
04700		PUSH	SP,[0]		;NAM TEMPORARY
04800		PUSH	SP,[0]	
04900	
05000	DEFINE ORIG <-7(SP)>
05100	DEFINE ORIG1 <-6(SP)>
05200	DEFINE DEV <-5(SP)>
05300	DEFINE DEV1 <-4(SP)>
05400	DEFINE DIR <-3(SP)>
05500	DEFINE DIR1 <-2(SP)>
05600	DEFINE NAM <-1(SP)>
05700	DEFINE NAM1 <0(SP)>
05800	
05900	;SIMPLE SINCE NAME IS AT THE TOP OF SP
06000	DEFINE CATNAM (X) <
06100		PUSH	P,X
06200		PUSHJ	P,CATCHR
06300	>
06400	DEFINE CATDIR (X) <
06500		PUSH	P,X
06600		PUSH	SP,DIR
06700		PUSH	SP,DIR
06800		PUSHJ	P,CATCHR
06900		POP	SP,-4(SP)
07000		POP	SP,-4(SP)
07100	>
07200	
07300	DEFINE GCH <
07400		HRRZ	A,ORIG
07500		JUMPE	A,TENDUN
07600		ILDB	C,ORIG1
07700		SOS	ORIG
07800	>
07900	
08000	TENX1:	GCH
08100		CAIE	C,CTRLV
08200		  JRST	NOQUOTE
08300		SKIPE	FIND
08400		  JRST	QUODIR
08500		PUSHJ	P,CATNA3
08600		GCH	
08700		PUSHJ	P,CATNA3 		;AND THE CHAR FOLLOWING THE CTRLV	
08800		JRST	TENX1
08900	QUODIR:	PUSHJ	P,CATDI3
09000		GCH
09100		PUSHJ	P,CATDI3
09200		JRST	TENX1			;AND CONTINUE
09300	
09400	NOQUOTE:
09500		CAIN	C,":"			;COLON -- DEVICE
09600		   JRST	ISDEV			;ITS BEEN A DEVICE ALL ALONG!!
09700		CAIN	C,","
09800		   JRST	TENX1			;IGNORE COMMA
09900		CAIE	C,40			;SPACE
10000		CAIN	C,11			;OR TAB
10100		   JRST	TENX1
10200		CAIE	C,"<"			;THESE START THE DIRECTORY NAME
10300		CAIN	C,"["
10400		   JRST	 STTDIR
10500		CAIE	C,">"			;THESE FINISH THE DIR. NAME
10600		CAIN	C,"]"
10700		   JRST	ENDDIR
10800		SKIPE	FIND			;DOING DIRECTORY?
10900		   JRST	.+3			;YES
11000		PUSHJ	P,CATNA3
11100		JRST	TENX1
11200		PUSHJ	P,CATDI3
11300		JRST	TENX1
11400	
11500	STTDIR:	SETOM	FIND
11600		JRST	TENX1
11700	
11800	ENDDIR:	SETZM	FIND
11900		JRST	TENX1
12000	
12100	;;#SK# 5-30-74 RLS DONT MESS UP DEVICE NAME IF PRESENT
12200	ISDEV:
12300		MOVE	C,NAM			;THE "NAME" HAS REALLY BEEN A DEV
12400		MOVEM	C,DEV
12500		MOVE	C,NAM1
12600		MOVEM	C,DEV1			
12700		
12800		SETZM	NAM			;SO CLEAR THE NAME -- START OVER
12900		SETZM	NAM1
13000		JRST	TENX1
13100	
13200	TENDUN:	
13300	;NOW STACK HAS ORIG,DEV,DIR,NAM
13400	GOTDIR: 
13500	;NOW FIND ONLY THE NAME -- IGNORE EXTENSION, VERSION, ETC.
13600		PUSH	SP,[0]			;NEW TEMPORARY
13700		PUSH	SP,[0]
13800	NAMLUP:	HRRZ	A,-3(SP)
13900		SOS	-3(SP)			;DECREMENT
14000		JUMPE	A,GOTDI1
14100		ILDB	C,-2(SP)
14200		CAIE	C,"."			;QUIT ON PERIOD
14300		CAIN	C,";"			;OR SEMICOLON
14400		JRST	GOTDI1
14500		PUSH	P,C
14600		PUSHJ	P,CATCHR
14700		JRST	NAMLUP
14800	GOTDI1:	POP	SP,-2(SP)		;REMOVE TEMPORARY
14900		POP	SP,-2(SP)	
15000		HRRZ	A,-1(SP)		;CHECK LENGTH OF NAME
15100		CAILE	A,6	
15200		   ERR <Name too long for loader.>,1
15300		PUSHJ	P,CVSIX			;GET SIXBIT FOR NAME
15400		MOVEM	A,C			;INTO C
15500	
15600		PUSHJ	P,DIRPPN		;TRANSLATE DIRECTORY STRING TO PPN
15700		MOVEM	A,D			;PLACE PPN IN D
15800	
15900		HRRZ	A,-1(SP)		;NOW DO THE DEVICE
16000		CAILE	A,6
16100		  ERR <Device name too long for loader.>,1
16200		PUSHJ	P,CVSIX			;SIXBIT FOR DEVICE INTO A
16300		SKIPN	A			;ANYTHING THERE?
16400		  MOVE	A,[SIXBIT/DSK/]		;ASSUME DEVICE DSK
16500		SUB	SP,X22			;CLEAR OFF COPY OF PNAME
16600		POPJ	P,
16700		
16800	;CALL CAT MACROS WITH AC C AS THE ARG
16900	CATNA3:	CATNAM C
17000		POPJ	P,
17100	
17200	CATDI3:	CATDIR C
17300		POPJ	P,
17400	
17500	
17600	DIRPPN:
17700	; DIRPPN -- CONVERT ASCII DIRECTORY NAME TO PPN (NEEDED FOR THE LOADER)
17800	; PAR STRING DEVICE-NAME, DIRECTORY-NAME (ON SP STACK) 
17900	;			  (DEVICE-NAME IS NOT REMOVED)
18000	; RES A: PPN
18100	; SID SAME AS SIXBIT (EVERYTHING BUT A)
18200		HRRZ	A,-1(SP)		;IF DIRECTORY NAME LENGTH = 0
18300		JUMPE	A,DIRP.X		; RETURN(0)-ASSUME CONNECTED DIR
18400	IFN SIXSW,<				;USE SIXBIT(DIRNAME) AS PPN
18500		CAILE	A,6			;VERIFY THAT NAME FITS IN SIXBIT
18600		   ERR <DIRECTORY TOO LONG FOR LOADER.>,1
18700		JRST	  CVSIX			; RETURN( CVSIX(ARG) )
18800	>;IFN SIXSW
18900	IFE SIXSW,<			;NOT SIXBIT, MORE FINAGGLING NECESSARY
19000	;	Modifications made to support TOPS20 v. 3
19100	;		Robert Smith
19200	;		Rutgers University
19300	;		March 12, 1978
19400	;	DEC has blown it!  They removed the STDIR jsys, and 
19500	;changed the conventions in the emulator about directory-to-ppn
19600	;conversion.  However, there is a new JSYS, STPPN, that will
19700	;now suffice.
19800	;	Algorithm for the following code:
19900	;IF STDEV("NIL") fails, THEN 
20000	;	BEGIN "assume TOPS20"
20100	;		AC[D] ← STPPN("<" & directory " ">" & 0);
20200	;	END ELSE
20300	;	BEGIN "assume TENEX"
20400	;		rh of AC[D] ← STDIR(directory & 0);
20500	;	END;
20600		BEGIN	DIRNAME
20650	EXTERN CHRCAT
20700		PUSH	P,B			;SAVE B
20705		HRROI 	1,2			;PREPARE FOR DEVST
20710		HRLOI 	2,600015		;ON NULL DEVICE
20715		JSYS	DEVST
20720		    ERR <DRYOT ON DEVST JSYS>,1
20725		TRZ	2,377			;MASK OUT REST OF WORD
20730		CAME	2,[ASCIZ/NIL/]		;"NIL" ON TENEX?
21000		  JRST	TOPS20			;NO--MUST BE TOPS20
21005	
21100		PUSH	P,[0]			;MAKE STRING ASCIZ BY APPENDING
21200		PUSHJ	P,CATCHR		;NULL BYTE TO END OF STRING
21300		MOVE	B,(SP)			;BP TO ASCIZ
21400		MOVEI	A,1			;POSITIVE -- NO RECOGNIZE
21500		JSYS	STDIR			;TWO ERROR RETURNS (+1 AND +2)
21600		  JFCL				;HANDLE IDENTICALLY
21700		  JRST [ERR <This directory does not exist on this system.>,1
21800			SETZ	A,		;RESULT 0(CONNECTED DIRECTORY)
21900			JRST	CLNUP		;AND CLEANUP
22000		       ]
22100		HRLI	A,4			;4,,DIRNO
22200		JRST	CLNUP			;CLEANUP STACK AND RETURN
22300	
22400	;HERE WITH TOPS20
22500	;FIRST BUILD A STRUCTURE NAME
22600	;SP STACK:
22700	;	DEVICE-NAME
22800	;	DIRECTORY-NAME
22900	TOPS20:					;
23000	;FIRST SURROUND DIRECTORY-NAME WITH "<>" PAIR
23100		PUSH	P,[74]		;LEFT BROKET
23200		PUSHJ	P,CHRCAT
23300		PUSH	P,[76]		;RIGHT BROKET
23400		PUSHJ	P,CATCHR
23500	;NOW SEE IF THERE IS A DEVICE NAME 
23600		HRRZ	B,-3(SP)		;IF NOT LENGTH(DEVICE-NAME)
23700		JUMPE	B,NODEVN		;THEN GOTO NODEVN
23800	
23900		PUSH	SP,-3(SP)		;DEVICE-NAME
24000		PUSH	SP,-3(SP)
24100		PUSH	P,[":"]			;WITH A COLON
24200		PUSHJ	P,CATCHR
24300		PUSH	SP,-3(SP)		;DIRECTORY-NAME
24400		PUSH	SP,-3(SP)		
24500		PUSHJ	P,CAT			;
24600		POP	SP,-2(SP)		;CLOBBERS DIRECTORY-NAME ON 
24700		POP	SP,-2(SP)		;STACK
24800	
24900	NODEVN:	
25000		PUSH	P,[0]			;PREPARE FOR STPPN
25100		PUSHJ	P,CATCHR		;AND PUT A NULL ON THE END	;
25200		MOVE	A,0(SP)			;STRING POINTER
25300	OPDEF	STPPN	[104000000556]
25400		STPPN				;PPN IN REG A
25450		MOVEM 	B,A			;FOR RETURN
25500	CLNUP:	POP	P,B			;RESTORE B
25600		BEND 	DIRNAME
25700	>;IFE SIXSW
25800	DIRP.X:	SUB	SP,X22			;REMOVE ARGUMENT FROM SP
25900		POPJ	P,			;AND LEAVE
26000	
26100		BEND TFLSCN
26200	>;TENX
     

00100	
00200	
00300	DSCR PRGOUT -- OUTPUT PROGRAM AND LIBRARY REQUEST BLOCKS
00400	DES Output (via GBOUT) Program and Libraray REQUEST BLOCKS.
00500	PAR B ptr to  PRGTAB or LBTAB (program or library request)
00600	 PNAME, PNAME+1 as in FILSCN
00700	 Defaults as in FILSCN; DEVICE, FILE and PPN will be passed
00800	  to the loader.
00900	RES FILSCN is called to make SIXBIT representations of DEVICE,
01000	  FILE, and PPN; these are placed in the output block.
01100	SID Saves the world
01200	⊗;
01300	
01400	↑↑PRGOUT: 
01500	NOTENX<
01600		MOVE	USER,GOGTAB		;SAVE ACS IN USER TABLE AREA
01700		HRRZI	TEMP,RACS(USER)
01800		BLT	TEMP,SBITS2+RACS(USER)		;FILNAME USES MANY ACS
01900		PUSHJ	P,FILSCN		;GET SIXBITS IN A,C,D
02000		MOVE	B,RACS+2(USER)		;GET TABLE ADDRESS BACK
02100		MOVEI	TEMP,3			;PREPARE TO COUNT UP BLOCK COUNT
02200		ADDB	TEMP,(B)
02300		ADDI	TEMP,(B)		;ptr to AREAS TO BE FILLED
02400		MOVEM	C,-1(TEMP)		;STORE NAME
02500	;;=I10=	SFD PATCH - BE SURE WE HAVE A REAL PPN
02600	SFDS<
02700		JUMPE	D,.+3			;ZERO PPN IS OK
02800		TLNN	D,777777		;SO IS A REAL PPN
02900	;;JOHN - POSSIBLE YOU WANT TO ISSUE AN ERROR MESSAGE HERE INSTEAD
03000		MOVE	D,2(D)			;IF PATH PTR, USE PPN FROM PATH
03100	> ;SFDS
03200		MOVEM	D,00(TEMP)		;STORE PPN
03300		MOVEM	A,01(TEMP)		;STORE DEVICE
03400	TYMSHR<
03500		JUMPE D,PRGOU2		;IF NO PPN
03600		TLNN D,-1		;OR IF REAL PPN
03700		CAME A,[SIXBIT /DSK/]	;OR NOT DISK
03800		JRST PRGOU2
03900		MOVE C,AVLSRC
04000		JFFO C,.+2
04100		JRST PRGOU2
04200		CAILE D,17
04300		JRST PRGOU2		;FIND CHANNEL
04400		PUSH P,B
04500		MOVSI A,(<RELEASE>)
04600		DPB D,[POINT 4,A,12]
04700		PUSH P,A
04800		MOVE A,[LOOKUP A]
04900		DPB D,[POINT 4,A,12]
05000		PUSH P,A
05100		MOVE A,[OPEN B]
05200		DPB D,[POINT 4,A,12]
05300		MOVEI B,16
05400		MOVSI C,'DSK'
05500		MOVEI D,0
05600		XCT A
05700		JRST PRGOU3
05800		MOVEI A,3	;NOW LOOKUP
05900		MOVE B,(TEMP)
06000		MOVE C,-1(TEMP)
06100		MOVEI D,0
06200		XCT (P)
06300		JFCL
06400		MOVEM B,(TEMP)	;SAVE PPN
06500	PRGOU3:	POP P,A
06600		POP P,A		;THE RELEASE
06700		XCT A
06800		POP P,B
06900	PRGOU2:>
07000	     
     

00100	>;NOTENX
00200	TENX<
00300		PUSH	P,A			;MUST PUSH SINCE TFLSCN CALLS RUNTIMES
00400		PUSH	P,C
00500		PUSH	P,D
00600		EXCH	SP,STPSAV		;GET A STRING STACK
00700		PUSHJ	P,TFLSCN		;DOES NOT MODIFY B
00800		EXCH	SP,STPSAV		;RESTORE IT
00900		MOVEI	TEMP,3			
01000		ADDB	TEMP,(B)
01100		ADDI	TEMP,(B)		;ptr to AREAS to be filled
01200		MOVEM	C,-1(TEMP)		;STORE NAME
01300		MOVEM	D,00(TEMP)		;STORE PPN
01400		MOVEM	A,01(TEMP)		;STORE DEVICE
01500		POP	P,D
01600		POP	P,C
01700		POP	P,A			;RESTORE
01800		PUSH	P,TEMP
01900		MOVE	USER,GOGTAB		;SAVE FOR KROCK BELOW
02000		HRRZI	TEMP,RACS(USER)	
02100		BLT	TEMP,SBITS2+RACS(USER)	
02200		POP	P,TEMP
02300	>;TENX
02400		HRRZS	TEMP
02500		CAIL	TEMP,22(B)		;BLOCK FULL?
02600		PUSHJ	P,GBOUT			;YES, PUT IT OUT
02700		HRLZI	TEMP,RACS(USER)
02800		BLT	TEMP,SBITS2
02900		POPJ	P,			;TRA 0,4?
03000	
03100	SUBTTL	Generator Miscellaneous.
03200	
     

00100	COMMENT ⊗  RAD50, RAD52 -- Radix-50 Functions for Scout Routines⊗
00200	
00300	DSCR RAD50,RAD52 -- create a RADIX50 symbol
00400	PAR RAD50 -- LPSA pntr to  block head -- string is in $PNAME, etc.
00500	 RAD52 -- LPSA(lh) is count, LPSA (rh) is address of string,
00600	 assumed aligned.
00700	RES RADIX50 for symbol in A
00800	SID Results in A, all other ACS saved (except TEMP)
00900	⊗;
01000	
01100	↑RAD50:	
01200		EXCH	SP,STPSAV
01300		MOVSS	POVTAB+6	;ENABLE FOR STRING PDL OV
01400		PUSH	SP,$PNAME(LPSA)	;COLLECT POINTERS IN COMMON SPOT
01500		PUSH	SP,$PNAME+1(LPSA)
01600		HRRZS	-1(SP)		;CLEAR STRNO, SAVE COUNT
01700		MOVE	A,$TBITS(LPSA)	;CONTROLS MODE BITS IN RAD50 SYMBOL
01800		MOVEI	TEMP,10/4		;ASSUME LOCAL
01900		TLNE	A,INTRNL	;INTERNAL IS TYPE 4
02000		MOVEI	TEMP,4/4
02100		TLNE	A,EXTRNL
02200		MOVEI	TEMP,60/4		;EXTERNAL IS TYPE 60
02300		MOVEI	A,0		;INITIALIZE A
02400		JRST	RAD5
02500	
02600	
02700	↑RAD52:
02800		LDB	TEMP,[POINT 12,LPSA,17] ;COUNT
02900		EXCH	SP,STPSAV
03000		MOVSS	POVTAB+6	;ENABLE FOR STRING PDLOV
03100		PUSH	SP,TEMP
03200		PUSH	SP,LPSA		;MAKE IT LOOK LIKE STRING 
03300		HRRI	TEMP,(<POINT 7,0>) ; DESCRIPTOR
03400		HRLM	TEMP,(SP)
03500		MOVEI	A,0
03600		LDB	TEMP,[POINT 4,LPSA,3]
03700	
03800	RAD5:	PUSH	P,TEMP
03900		PUSH	P,B		;SAVE IT
04000		MOVEI	TEMP,6
04100	
04200	R50LUP: SOSGE	-1(SP)		;QUIT IF NO MORE STRING
04300		 JRST	 R5OUT
04400		ILDB	B,(SP)		;CHARACTER
04500		CAIN	B," "		;IGNORE BLANKS ABSOLUTELY!
04600		 JRST	 R50LUP		; THIS RUNS ALL THE CHARACTERS TOGETHER
04700		CAIL	B,"a"
04800		CAILE	B,"z"
04900		JRST	.+2
05000		SUBI	B,40		;CONVERT TO UPPER CASE
05100		CAIE	B,30		;UNDERLINE:THESE CHARS HAVE TO BE CREATED INDIVIDUALLY
05200		CAIN	B,"."
05300		MOVEI	B,66+45		;RAD50 CHAR FOR "." + 66 TO BE SUBTRACTED
05400	;;#GQ# DCS 2-8-72 (1-1) ! SAME AS  UNDERLINE
05500		CAIN	B,"!"		;! SAME AS UNDERLINE
05600		MOVEI	B,66+45		;"."
05700	;;#GQ# (1)
05800		CAIN	B,"$"
05900		MOVEI	B,66+46
06000		CAIN	B,"%"
06100		MOVEI	B,66+47
06200		SUBI	B,66		;OK IF A LETTER
06300		CAIG	B,12		;<12 IF A NUMBER
06400		ADDI	B,7		; THIS MAKES IT RIGHT
06500		IMULI	A,50		;THAT'S THE NUMBER ALL RIGHT
06600		ADD	A,B		;COLLECT RADIX50
06700		SOJN	TEMP,R50LUP	;QUIT AT 6
06800	
06900	R5OUT:	MOVEM	A,RAD5.		;NOW CREATE SAME SYMBOL WITH
07000		JUMPLE	TEMP,MORFIV	;MORE THAN FIVE CHARS?
07100		IMULI	A,50		;MAKE IT "SYMB".
07200		SKIPA
07300	MORFIV:	SUB	A,B		;"." IN PLACE OF THE LAST
07400		POP	P,B		;RESTORE B
07500		POP	P,TEMP		;TYPE BITS.
07600		DPB	TEMP,[POINT 4,A,3] ;TYPE BITS TO RADIX 50
07700		ADDI	A,46		;$
07800		MOVEM	A,RAD5$
07900		ADDI	A,1		;%
08000		MOVEM	A,RAD5%		;
08100		SUBI	A,2		;"."
08200		EXCH	A,RAD5.		; AND STORE IT IN RAD5. FOR STRINGS
08300		DPB	TEMP,[POINT 4,A,3] ;TYPE BITS TO RADIX 50
08400		SUB	SP,X22
08500		EXCH	SP,STPSAV	;RESTORE REGS
08600		MOVSS	POVTAB+6	;RE-ENABLE FOR PARSE PDLOV
08700		POPJ	P,
08800	
08900	BEND	TOTAL
09000	IFN FTDEBUG, <↑INNA←INNA>
09100	
09200	
09300	
     

00100	
00200