perm filename GEN[S,AIL]5 blob sn#019038 filedate 1973-01-09 generic text, type T, neo UTF8
COMMENT ⊗   VALID 00053 PAGES VERSION 16-2(96)
RECORD PAGE   DESCRIPTION
 00001 00001
 00006 00002	HISTORY
 00015 00003		LSTON	(GEN)
 00023 00004	TABLEDATA (EXEC ROUTINES -- GLOBAL VARIABLES)
 00028 00005	TABCONDATA (EXEC ROUTINES -- GLOBAL VARIABLES)
 00031 00006	DSCR GENINI
 00035 00007	DSCR GETOP, GETADL, GETAD
 00037 00008	DSCR -- SAIL DECLARATION EXECS
 00042 00009	DSCR TYPSET, VALSET, XOWSET,  etc.
 00045 00010	DSCR TCON, BTRU, BFAL, BNUL, BINF
 00048 00011	DSCR TWID10, ECHK, ESET
 00051 00012	DSCR DWN, BLOCK, BLNAME, ENTID, UP, NAMCHK, etc.
 00060 00013	↑ENTID:	
 00066 00014	
 00074 00015	 Check for match on block names.
 00077 00016	DSCR RQ00, RQSET, SRCSWT
 00080 00017	
 00081 00018	
 00084 00019	↑SRCSWT:
 00085 00020	DSCR DFPREP, DCPREP, DWPREP, DFPINS, DFSET, DFENT, MACOFF
 00097 00021	DSCR STCAT
 00109 00022	DSCR LETSET, LETENT
 00111 00023	DSCR TWCOND,SWICHP,SWPOFF,PSWICH,OKEOF
 00119 00024	
 00132 00025		SUBTTL	EXECS for Entry Declaration
 00134 00026	DSCR ALOT
 00139 00027	↑ALOT:				ROUTINE TO HANDLE ALLOCATION
 00143 00028	
 00147 00029	Comment 
 00154 00030	NOSY:	PUSHJ	P,URGSTR	IF ON STRING RING....
 00163 00031	LOADER BLOCK FOR POLISH FIXUP
 00165 00032	DSCR PDOUT
 00171 00033	DOLVIN:	PUSH	P,PNT2
 00173 00034	ROUTINE TO PUT OUT LOCAL VAR INFO -- USED BY DIS
 00178 00035	Allo -- Allocate One Type of Symbol
 00184 00036	ROUTINE TO ALLOCATE SPACE FOR TEMP CELLS AND TO OUTPUT
 00189 00037	REQINI -- USER REQUIRED INITIALIZTIONS
 00192 00038	DSCR DONES
 00194 00039	
 00199 00040	NOGAG <	BLOCK BITS USED BY "GOGOL", SO NO NEED
 00202 00041	
 00206 00042	
 00211 00043	MEMORY  and LOCATION EXECS, ALSO UINCLL
 00214 00044	DSCR MAKBUK, FREBUK
 00216 00045	BEGIN	ERRORS
 00221 00046	DSCR SCNBAK,POPBAK,KILPOP,QREM2,QTYPCK
 00226 00047	DSCR  UNDEC -- Undeclared identifiers
 00233 00048	DSCR  QDEC0,1,2   QARSUB  QARDEC QPARM QPRDEC
 00240 00049	BEGIN SCOMM
 00243 00050	BEGIN  INLINE
 00245 00051	DSCR CODNIT, WRDNIT, ONEWRD, SETSIX, SETOP, CODIND, CODREG, etc.
 00251 00052	
 00256 00053	BEGIN COUNT
 00259 ENDMK
⊗;
COMMENT ⊗HISTORY
AUTHOR,REASON
021  202000000140  ⊗;


COMMENT ⊗
VERSION 16-2(96) 1-9-73 BY RHT BUG #KT# TYPO IN UP
VERSION 16-2(95) 1-9-73 BY RHT BUG #KY# ALLOW GLOBAL INTERNAL SYMBOLS TO GO OUT ALWAYS
VERSION 16-2(94) 1-9-73 BY RHT BUG #KX# NEED ALLSTO BEFORE BEXIT
VERSION 16-2(93) 1-8-73 BY JRL BUG KW DON'T ALLOW INTERNAL OR EXTERNAL ITEM DECLARATIONS
VERSION 16-2(92) 1-8-73 
VERSION 16-2(91) 1-8-73 
VERSION 16-2(90) 12-13-72 BY HJS FIX RACE CONDITION WHERE MACROS AND CONDITIONAL COMPILATION END SIMULTANEOUSLY
VERSION 16-2(89) 12-11-72 BY HJS ENDC PARSER SWITCH TRIGGER IN WHILEC, CASEC, FORC, AND FORLC BODIES
VERSION 16-2(88) 12-2-72 BY HJS SAVE VALUE OF BITS DURING CONDITIONAL COMPILATION AND MACRO DEFINITION
VERSION 16-2(87) 11-30-72 BY RHT ADD LIBTAB ENTRIES FOR POLLING
VERSION 16-2(86) 11-28-72 BY RHT ADD CODE FOR CLEANUPS
VERSION 16-2(85) 11-24-72 BY RHT BUG #KM# TYPO MESSED UP POLISH FIXUP FOR EXT PD
VERSION 16-2(84) 11-21-72 BY JRL BAD JRST IN INMAIN
VERSION 16-2(83) 11-20-72 BY KVL REMOVE ER51 - MEANINGLESS MSG.  IF YOU WANT IT, SEE ME.
VERSION 16-2(82) 11-19-72 BY HJS DLMPSH AND DLMPOP FOR PROPER HANDLING OF DEFINES WITHIN DEFINES
VERSION 16-2(81) 11-17-72 BY RHT ADD CALL TO USER INITIALIZATION
VERSION 16-2(80) 11-15-72 BY HJS INSERT DEFDLM QSTACK ROUTINES FOR DEFLUK BIT OF FF FOR COMPILE-TIME MACROS WITHIN MACROS
VERSION 16-2(79) 11-15-72 BY KVL SURPRESS CODE GENERATION AFTER SERIOUS ERRORS.
VERSION 16-2(78) 11-10-72 BY HJS ADD DLMSTG STACK SO MACROS DEFINED WITHIN MACROS WITH CONCATENATION WILL WORK
VERSION 16-2(77) 11-10-72 BY JRL ADD ERR MSG FOR PROPS AND LIBTAB ENTRIES
VERSION 16-2(76) 11-8-72 BY HJS IMPLEMENTATION OF CHECK_TYPE
VERSION 16-2(75) 11-7-72 BY JRL GIVE ERROR MESSAGE BAD USE OF BIND
VERSION 16-2(74) 11-2-72 BY RHT BUG #JY# TYPE CHECKING ON MEMORY INDEX
VERSION 16-2(73) 11-2-72 BY JRL ADD MAINPR TO LIBTAB
VERSION 16-2(72) 10-24-72 BY JRL ADD INMAIN EXEC TO INIT MAINPR
VERSION 16-2(71) 10-22-72 BY RHT BUG #JU# FIX UP ACKTAB ENCLOBERMENT BY QUICK_CODE
VERSION 16-2(70) 10-20-72 BY RHT BUG #JV# MEMORY TRIED TO USE AC 0 AS INDEX
VERSION 16-2(69) 10-20-72 BY RHT PROVIDE EXTRA ENTRY POINTS IN REQINI
VERSION 16-2(68) 10-17-72 BY AM HJS IMPLEMENTATION OF DECLARATION FEATURE FOR TYPE CHECKING AT COMPILE TIME
VERSION 16-2(67) 10-12-72 BY HJS BUG #JP# AND CVMS IMPLEMENTATION
VERSION 16-2(66) 10-10-72 BY KVL FIX ; ELSE RECOVERY
VERSION 16-2(65) 10-5-72 BY JRL  PREPARE FOR EXPO
VERSION 16-2(64) 10-5-72 BY KVL MAKE UNDECLARED IDENTIFIERS AN ERR.
VERSION 16-2(63) 9-29-72 BY RHT BUG #JH# FIX TYPO IN REQINI
VERSION 16-2(62) 9-27-72 BY HJS FORCE EXECUTION OF BLOCK WHEN A DEFINE IS THE ONLY DECLARATION IN THE BEGINNING OF A BLOCK.
VERSION 16-2(61) 9-27-72 BY RHT BUG #JF# MESSAGE PROC LINK GETTING WRONG ADDRESS
VERSION 16-2(60) 9-27-72 BY JRL ADD ARYSET,SAFSET EXECS FOR DATUMS
VERSION 16-2(59) 9-25-72 BY RHT BUG #IZ# GLOBAL STUFF SHOULD STAY OUT OF PD
VERSION 16-2(58) 9-22-72 BY RHT BUG #IV# UNDEC FWRD MESSAGE PROC PD BUG
VERSION 16-2(57) 9-21-72 BY RHT MAKE THE LOCN PUT THING INCOR
VERSION 16-2(56) 8-24-72 BY RHT ADD CAUSE & INTERROGATE TO XCALL TABLE
VERSION 16-2(55) 8-23-72 BY JRL ADD BEXIT CODE FOR CONTEXT
VERSION 16-2(54) 8-22-72 BY RHT PREVENT DOUBLE ALLOCATION OF KILL SET
VERSION 16-2(53) 8-18-72 BY JRL CHANGE TYPPRO TO HANDLE MATCHING PROCEDURES
VERSION 16-2(52) 8-14-72 BY RHT EXEC FOR LOCATION(X)
VERSION 16-2(51) 8-14-72 BY RHT EVAL →→ APPLY
VERSION 16-2(50) 8-14-72 BY RHT ADD EXECS FOR MEMORY
VERSION 16-2(49) 8-11-72 BY RHT MAKE POLISH FIXUP TO GET AT EXTERNAL PD'S
VERSION 16-2(48) 8-11-72 BY JRL ADD REMEMBER ETC TO LIBTAB
VERSION 16-2(47) 8-4-72 BY RHT BUG #IT# EXTERNALS IN THE PD
VERSION 16-2(46) 8-1-72 BY RHT MAKE KILL SETS REAL SETS
VERSION 16-2(45) 7-28-72 BY RHT CHANGE FORKER TO SPROUT
VERSION 16-2(44) 7-26-72 BY HJS TURN OFF MACRO EXPANSION WHEN SCANNING FORMAL PARAMETERS.
VERSION 16-2(43) 7-25-72 BY RHT FIX THE PD SYMBOL
VERSION 16-2(42) 7-24-72 BY RHT PUT FORKER IN LIST OF XCALLED FNS
VERSION 16-2(41) 7-24-72 BY RHT PUT OUT SYMBOL FOR PD
VERSION 16-2(40) 7-22-72 BY RHT ADD KILL LISTS 
VERSION 16-2(39) 7-9-72 BY RHT NO PD IF NO DADDY
VERSION 16-2(38) 7-5-72 BY DCS BUG #II# DON'T LET DEFINES OUT AS SYMBOLS
VERSION 16-2(37) 7-2-72 BY JRL SET LEAPIS IF ANY LEAP FUNCTIONS USED
VERSION 16-2(36) 6-25-72 BY DCS BUG #HX# PARAMETERIZE OPCODE FILE NAMES (AND OTHERS)
VERSION 16-2(35) 6-21-72 BY RHT CHANGE WAY PDA,,0 SEMBLK IS  LINKED
VERSION 16-2(34) 6-14-72 BY JRL BUG ##H#S# STRING ITEMVAR PROCS ARE NOT STRING PROCS.
VERSION 16-2(32) 6-8-72 BY RHT MAKE ENTRY IN LIBTAB FOR EVAL
VERSION 16-2(31) 5-16-72 BY RHT GIVE ERR IF SIMPLE PROC ALLOCATES
VERSION 16-2(30) 5-16-72 BY RHT TO HANDLE OWN VARS IN BLOCKS--ENTID
VERSION 16-2(29) 5-14-72 BY DCS BUG #HH# BETTER INITIAL CODE IF /H
VERSION 15-6(7-28) 4-20-72 LOTS OF THINGS
VERSION 15-2(6) 2-21-72 BY HJS THE BRAVE NEW PARSER WORLD
VERSION 15-2(5) 2-6-72 BY DCS BUG #GN# UUOS TO START_CODE TABLE, FIX BOUNDARY COND.
VERSION 15-2(4) 2-5-72 BY DCS BUG #GJ# ADD LSTON LISTING CONTROL STUFF
VERSION 15-2(3) 2-5-72 BY DCS BUG #GI# ADD CAT ROUTS TO LIBFSN (CHRCAT, ETC.)
VERSION 15-2(2) 2-1-72 BY DCS ISSUE NEW STYLE %ALLOC SPACE REQUESTS
VERSION 15-2(1) 12-2-71 BY DCS INSTALL VERSION NUMBER

⊗;
	LSTON	(GEN)
BITD2DATA (EMITTER)

; EMITTER BITS -- PUT DESCRIPTORS IN POSITION TO BE EXAMINED BY $L OPERATIONS

↑GENBTS:
BIT (NOUSAC,400000)	;DON'T USE D(RH) AS AC #
BIT (USCOND,200000)	;USE C(RH) AS 3 BITS OF CONDITION
BIT (USADDR,100000)	;USE C(LH) AS DISPLACEMENT PART
BIT (USX   , 40000)	;USE D(LH) AS INDEX REG
BIT (NORLC , 20000)	;RELOCATE NOT!
BIT (IMMOVE, 10000)	;IF OPERAND CONSTANT, LOAD IT ANY WAY POSSIBLE
BIT (INDRCT,  4000)	;INDIRECT ADDRESSING REQUIRED
BIT (JSFIX ,  2000)	;JUST DO A FIXUP (DON'T GET SEMANTICS).
BIT (NOADDR,  1000)	;NO EFFECTIVE ADDRESS PART
BIT (EMADDR,400)	;WE WANT THE ADDRESS OF THIS ENTITY
BIT (PNTROP,   200)	;INTERNAL OPERATION INDICATING POINTER INDEXING
BIT (FXTWO,   100)	;USE SECOND FIXUP WORD
BLOCK	6		;LEFT OVER BITS


BITD2DATA (GENMOV)

;CONTROL BITS PASSED TO GENMOV IN THE RIGHT HALF OF "FF".
;FOR COMMENTS, SEE THE FILE "TOTAL".


BIT (INSIST,400000)	;INSIST ON DOING TYPE CONVERSION.
			;THE RIGHT HALF OF "B" CONTAINS TYPE BITS.
BIT (ARITH,200000)	;INSIST ARGUMENT IS AN ARITHMETIC TYPE.
BIT (EXCHIN,100000)	;DO AN EXCHOP ON THE WAY INTO THE ROUTINE.
BIT (EXCHOUT,40000)	;DO AN EXCHOP ON THE WAY OUT OF A ROUTINE.
BIT (GETD,20000)	;DO A GETAD BEFORE DOING THIS ROUTINE.
BIT (SPARE,10000)	;NEGAT←← 10000	;GET THE OPERAND IN NEGATIVE FORM.
BIT (POSIT,4000)	;INSIST ON THE OPERAND IN POSITIVE FORM.
BIT (BITS2,2000)	;UPDATE SBITS2 FROM $SBITS2(PNT2) ON WAY OUT.
BIT (MRK,1000)		;MARK THE ACCUMULATOR MENTIONED IN D WITH THE ARGUMENT.
			;(DONE AT END OF MAIN OPERATION)
			;THIS MEANS "GENERATE A TEMP CELL IF NECESSARY."
BIT (ADDR,400)		;SAME BIT AS GENERATOR USES.  USE THE ADDRESS OF ARG.
BIT (REM,200)		;REMOP ON THE WAY OUT.
BIT (NONSTD,100)	;NON-STANDARD OPERATION.
BIT (SPAC,40)		;WE HAVE A SPECIFIC AC NUMBER IN MIND.
BIT (PROTECT,20)	;PROTECT THIS ACCUMULATOR.
BIT (UNPROTECT,10)	;UNPROTECT THIS ACCUMULATOR.
BIT (DBL,2)		;NEED A DOUBLE ACCUMULATOR.
BIT (INDX,1)		;NEED AN INDEXABLE ACCUMULATOR.


BITDATA (STROP)

; BITS TO BE PASSED TO STROP IN A
; SEE STROP FOR MEANINGS OF THESE BITS.

↓BPWORD ←← 400000
↓LNWORD ←← 200000
↓BPFIRST ←← 100000
↓ADOP ←← 40000
↓SBOP ←← 20000
↓UNDO ←← 10000
↓STAK ←←  4000
↓BPINC ←← 2000

ZERODATA (EXEC ROUTINES -- GLOBAL VARIABLES)

COMMENT ⊗
ADEPTH -- Whenever code is generated to push something onto the
    System stack (P, usually 17), currently only when an actual
    parameter is put on, this is incremented.  It is added to
    the displacement for a formal parameter whenever it is ref-
    erenced.  This allows the access code to get to the right
    stack element for a parameter, no matter what's on the stack.
    ADEPTH is decremented when things come off.  It is restarted
    whenever a procedure declaration is encountered (first checked,
    since it should always be 0 at that point).
⊗
↓ADEPTH: 0

;APARNO -- a count of the number of non-string parameters in
;    the current procedure -- used to set up the $NPRMS word
;    in the 2d Semblk for the procedure
↓APARNO:  0

;DEFRN1 -- Semantics of first formal macro param in VARB-Ring
;    while scanning macro params.  Used to release all the
;    Semblks for these params when done with them.
↓DEFRN1:  0

COMMENT ⊗
FALLOC -- Semantics of a [0] integer constant, created the
    first time the word FALSE appears in source -- FALSE
    thenceforth equated to this [0] constant, since the two
    are internally equivalent -- see BFAL routine
⊗
↓FALLOC:  0

;GLOBCNT -- used in ENTID to count # global items declared
↓GLOBCNT: 0

;LENCNT -- AOS'ed whenever substring operation is begun, SOS'ed
;    when it is complete.  BINF (∞≡length(str) EXEC) checks
;    this to make sure there's a string to take the length of.
↓LENCNT:  0

;LENSTR -- QSTACK descriptor -- each entry is Semantics of a 
;    string being SUBSTRd.  Kept here for convenience of BINF,
;    so that it doesn't have to search up the stack for it.
↓LENSTR:  0

;NULLOC -- Semantics of "", for BNUL (NULL ≡ "" EXEC)
↓NULLOC: 0	;SEE FALLOC, TRULOC

;OPCODE -- for binary operations, proper opcode (and control bits),
;   fetched from one of the OP tables (PMTAB, TDTAB, MXMNTB) via the
;   class code in the production which called the EXEC. Used as tem-
;   plate for output instruction.  Stored in OPCODE for convenience
↓OPCODE:  0

;SDEPTH -- ADEPTH-type count for String stack -- bumped not only for
;    actual params, but also for String Procedure results, other
;    String operations which use the stack.
↓SDEPTH: 0

;SPARNO -- APARNO-type count of String formals -- it's possible that
;    this is doubled before use, since there are two words for each
;    String descriptor.  See PROCED, ENTID for uses.
↓SPARNO: 0

;THISE -- Set by ECHK EXEC, remembers type of expression, since two
;    class codes are passed in from PARSER 
; (e.g., EXEC @E ECHK @class randomexec)
↓THISE:  0

;TRULOC -- Semantics of [-1], used by BTRU (TRUE≡≠0 EXEC)
↓TRULOC: 0


TABLEDATA (EXEC ROUTINES -- GLOBAL VARIABLES)
NOGAG <
COMMENT ⊗
LIBTAB -- table of fixups (current ends of chains) for routines
    called by SAIL programs to accomplish complicated operators
    (CAT, SUBSTR, ARRMAK, etc.) -- the LIBFSN macro, with the 
    appropriate definition of the FN macro, puts out a symbolic
    index into this table for each name mentioned (R&ROUTNAME),
    and a word of table to hold the fixup.  It is used again below
    (LIBNAM) to create a table of corresponding External RADIX50
    request words which will be used in DONES to put out the chain
    requests. The XCALL and LPCALL macros are used to put out
    (fixup chained) calls to these routines.
⊗
DEFINE LIBFSN	<
	FN	<CAT>		;STRING CONCATENATIONS.
	FN	<CHRCAT>	;INTEGER&STRING
	FN	<CATCHR>	;STRING&INTEGR
	FN	<CHRCHR>	;INTEGR&INTEGR
	FN	<CAT.RV>	;STRING&STRING, 2D ARG FIRST
	FN	<SUBSR>		;SUBSTRING (FOR)
	FN	<SUBST>		;SUBSTRING (TO)
;	FN	<SUBSI>		;EXTINCT (USED TO BE SUBSTRING INF)
	FN	<GETCH>		;CONVERT FIRST CHAR OF STRING TO INTEGER
	FN	<PUTCH>		;CONVERT LOW ORDER 7 BITS TO STRING
	FN	<POW>		;EXPONENTIATION
	FN	<FPOW>		;FLOATING ARG, INTEGER EXPONENT.
	FN	<LOGS>		;INTEGER ARG,FLOATING EXPONENT.
	FN	<FLOGS>		;FLOATING ARG, FLOATING EXPONENT.
	FN	<ARMRK>		;MARK THE ARRAY PUSHDOWN STACK.
	FN	<ARMAK>		;MAKE AN ARRAY (PARAMS IN STACK)
	FN	<ARREL>		;RELEASE ARRAYS BACK TO LAST MARK ON STACK.
LEP <	
	FN 	<LEAP>		;CALL LEAP!
	FN	<DATM>		;THIS IS REFERENCE TO A WORD WHICH IS XWD 3,→
				;    BASE OF DATUM TABLE.
	FN	<LPRYER>	;DATUM(X) WAS NULL, WHEN AN ARRAY WAS EXPECTED.
	FN	<PROPS>		;THE PROPS BYTE POINTER POINT 9,INFOTAB(3),35
GLOC <
	FN	<GPROPS>	;GLOBAL PROPS
	FN	<GDATM>		;GLOBAL DATUM
	FN	<.MES1>
	FN	<.MES2>
	FN	<DATERR>
>;GLOC
	FN	<PITBND>	;BIND PD TO ITEM
	FN	<PITCOP>	;COPY PROC ITEM
	FN	<PITDTM>	;-1(P)←DATUM(-1(P))
	FN	<APPLY>		;INTERP CALLER
	FN	<SPROUT>	;SPROUTER
	FN	<CAUSE>		;CAUSES EVENTS
	FN	<INTERROGATE>	;INTERROGATE FUNCTION
	FN	<MAINPR>	;INITIALIZE PROCESSES
>;LEP
DIS <
	FN	<BEXIT>		;BLOCK EXITER
	FN	<STKUWD>	;STACK UNWINDER
>;DIS
	FN	<CSERR>		;CASE STATEMENT INDEX OUT OF BOUNDS
	FN	<ALLRM>		;REMEMBER ALL
	FN	<ALLFOR>	;FORGET ALL
	FN	<ALLRS>		;RESTORE ALL
	FN	<REMEMB>	;REMEMBER
	FN	<FORGET>	;FORGET
	FN	<RESTOR>	;RESTORE
	FN	<.SUCCE>	;SUCCEED (FOR MATCH. PROCS)
	FN	<.FAIL>		;FAIL
	FN	<.UINIT>	;USER INITIALIZATIONS
	FN	<DDFINT>	;DO DEFERED INTERRUPT
	FN	<INTRPT>	;SET ≠0 WHEN HAVE AN INTERRUPT
>

DEFINE	FN '(X)	<
	↓R'X ←← LIBNUM
	↓LIBNUM ←← LIBNUM+1
	0		;FIXUP WORD.
	>

↓LIBNUM←←0

↓LIBTAB:	LIBFSN		;FIXUPS FOR LIBRARY FUNCTIONS.
>;NOGAG
;    the current procedure -- used to set up the $NPRMS word

TABCONDATA (EXEC ROUTINES -- GLOBAL VARIABLES)

NOGAG <
COMMENT ⊗
LIBNAM -- these are the external request symbols for the
    above-mentioned runtime routines -- see LIBTAB, above
⊗

DEFINE	FN (X) < RADIX50 60,X >

LIBNAM:	LIBFSN
>

COMMENT ⊗
TYPTAB, VALTAB, XOTAB
    These tables are used by the TYPSET, VALSET, XOWSET routines
    to convert the class codes from the PARSER, specifying which
    data type, REFERENCE or VALUE type, or modifier (SAFE, etc.)
    is being requested, to the appropriate TBITS bit.  These three
    routines are, as might be guessed, EXEC routines.
⊗

↑TYPTAB:
HELITM:	ITEM				;ITEM
HELITV:	ITMVAR				;ITEMVAR
	0+SET				;SET
	LABEL+FORWRD			;LABEL
	FLOTNG				;REAL
	INTEGR				;INTEGER
	STRING				;STRING
	INTEGR				;BOOLEAN
	0+SET+LSTBIT			;LIST
	XWD SAFE,SET!INTEGR		;KILL_SET
	0+SET!FLOTNG			;CONTEXT
XOTAB:	XWD INTRNL,0			;INTERNAL
	XWD SAFE,0			;SAFE
	XWD EXTRNL,0			;EXTERNAL
	XWD OWN,0			;OWN
	XWD RECURS,0			;RECURSIVE
	XWD EXTRNL,FORTRAN		;FORTRAN
	FORWRD				;FORWARD
	SHORT				;SHORT
	XWD SIMPLE,0			;SIMPLE
	XWD MPBIND,INTEGR		;MATCHING
GLOC <
	GLOBL				;GLOBAL LEAP TYPE.
	XWD MESSAGE,0			;MESSAGE
>;GLOC

VALTAB:	XWD REFRNC,0			;REFERENCE
	XWD VALUE,0			;VALUE
	XWD VALUE!MPBIND,ITMVAR		;? PARAMETER

CHKTAB:	XWD RES,0			; RESERVED
	XWD BILTIN,0			; BUILTIN FUNCTION
LEP<
	LPARRAY				; LEAP ARRAY
>;LEP

	XWD SBSCRP,0			; NORMAL ARRAY
	XWD DEFINE,0			; DEFINE
	PROCED				; PROCEDURE

ENDDATA
SUBTTL	EXEC (GENERATOR) INITIALIZATION


DSCR GENINI
CAL PUSHJ from SAIL Exec
RES Initializes variables for whom the EXECS (generators)
 have main responsibility. Calls RELINI and LEPINI to set
 up Relfile and Leap variables
SEE SAIL Exec, RELINI, LEPINI
⊗
↑GENINI:
NOGAG <
IFN PATSW,<II←←4;>II←←3
DIS <II←←10>			;LONGER STARTUP
;* * * * * * 
REN <
	SETOM	INHIGH		;WILL BE IN HIGH FIRST IF HISW
	MOVEI	TEMP,1
	MOVEM	TEMP,HCNT	;DATA STARTS AT 1 IF HISW
>;REN
	MOVEI TEMP,II		;START HERE
REN <
	SKIPE	HISW		;TWO-SEGMENT COMPILATION?
	MOVEI	TEMP,400000+II	;YES, CODE STARTS HERE
>;REN
	MOVEM	TEMP,PCNT
;;#HH# 5-14-72 DCS (2-2) ACCOUNT FOR UPPER SEGMENT CODE
REN <
	MOVEI	TEMP,5-II(TEMP)	;NOW ADJUST INITIAL PD PUSH DATA
	HRRM	TEMP,IPDFIX	;SEE SAIL FOR THIS ARCHBLOCK
>;REN
;;#HH# (2-2)
>;NOGAG
NODIS <
Comment ⊗ The first four words of code (for main programs anyway)
are:

0	SKIPA			;NON RPG-MODE START
1	SETOM	RPGSW		;RPG-MODE START
2	JSR	SAILOR		;CALL INITIALIZER
3	AOS	"PAT"		;OUTER BLOCK AOS

Non main programs have these four words present (in some partially completed
	state), so that PCNT still starts at 4.

⊗
>;NODIS

DIS <
Comment ⊗ The first words of code are (for main programs)

0	SKIPA			;NON-RPGMODE START
1	SETOM	RPGSW		;RPG MODE
2	JSR	SAILOR		;INITIALIZE
3	HRLOI	RF,1		;FOR FAKE F LINK
4	PUSH	P,RF
5	PUSH	P,[PDA,,0]	;PDA OF OUTER BLOCK & USELESS STATIC LINK
6	PUSH	P,SP		;REST OF MSCP
7	HRRZI	RF,-2(P)	;POINT THERE

⊗;
>;DIS

; MARK TOP AC'S UNUSABLE FOR GENERAL ALLOCATION

	FOR II⊂(RSP,RP,USER,TEMP,LPSA,RF)  <
		SETOM ACKTAB+II>

; ***** THIS CODE MOVED TO RELOUTPUT AREA IN TOTAL
	PUSHJ	P,RELINI	;INITIALIZE LOADER FILE VAIRIABLES
; *****


IFN FTDEBUG <
	MOVE TEMP,BITABLE
	EXTERNAL $M
	MOVEM	TEMP,$M+3	;RAID LOC
>

; ***** THIS CODE MOVED TO LEAP
LEP <
	PUSHJ	P,LEPINI	;INITIALIZE LEAP VARIABLES
>;LEP
; ******
	POPJ	P,

REN <
DSCR HISET, LOSET, SWIT -- Call to Get Correct PCs into PCNT and HCNT
DES Calling HISET makes sure code will go to upper segment.
 Calling LOSET makes sure it will go to lower segment
 Calling SWIT does HISET if LOSET was last, LOSET if HISET was last.
⊗
↑HISET:	SKIPE	INHIGH		;ALREADY IN HIGH SEGMENT?
	 POPJ	 P,		;YES, DONE
	JRST	SWIT		;NO, GO IN
↑LOSET:	SKIPE	INHIGH		;ALREADY IN LOW SEGMENT OR
↑SWIT:	SKIPN	HISW		; IS THIS RELEVANT?
	POPJ	P,		;YES OR NO
	SETCMM	INHIGH		;IF IN, NOW OUT AND VICE VERSA
	PUSHJ	P,FRBT		;FORCE OUT BINARY IN OTHER SEGMENT
	MOVE	TEMP,PCNT	;EXCHANGE PCS
	EXCH	TEMP,HCNT
	MOVEM	TEMP,PCNT
	POPJ	P,		;DONE
>;REN

DSCR GETOP, GETADL, GETAD
DES Routines to pick things up from symbol table blocks.
 GETOP is the entry which also picks up the
 generator stack entry specified by accumulator A.
⊗


↑GETAD2: SKIPN	PNT2
	ERR	<DRYROT -- GETAD>
	MOVE	SBITS2,$SBITS(PNT2)
	MOVE	TBITS2,$TBITS(PNT2)
	POPJ	P,



↑GETAD:	JUMPN	PNT,GETSTF		;TEST FOR NULL SEMANTICS.
	ERR	<DRYROT -- GETAD>
↑GETADL: SKIPN	PNT,LPSA		;MAKE SURE WE HAVE A GOOD ENTRY
	ERR	<DRYROT -- GETAD>
GETSTF:	MOVE	SBITS,$SBITS(PNT)
	MOVE	TBITS,$TBITS(PNT)	;BOTH BITS WORDS
	POPJ	P,










BEGIN	GENDEC
SUBTTL EXECS for typing variables, equating TRUE with -1, etc.


DSCR -- SAIL DECLARATION EXECS
DES These are the declarations routines.  
 They take care of simple identifier declarations
 as well as procedures, arrays, etc.  If a "BEGIN"
 is seen, the varb structure recurrs out of the current
 block, a new one is created, the VARB list is updated to the
 new block, and a new symbol table bucket is made.
 The reverse is effected when an "END" is seen which
 matches a BEGIN which involved declarations.

 For procedures, a similar thing happens.
⊗

DSCR TYPDEC, TYPAR, TYPPRO, etc.
PRO TYPDEC TYPAR TYPPRO TYPR1 PRST
DES The routines to "type" an entity and return an appropriate
 parser token.  Thus, the parser can be aware of the types of
 user identifiers.  This speeds up operations somewhat, and means
 that the parser can do much of the "semantic" type-checking.
⊗

↑TYPDEC: HRLI	A,CLSIDX		;ALL VARIABLES ARE CLASS MEMBERS
	TLNE	TBITS,CNST		;a constant ?
	JRST	MYCON
	TLNE	TBITS,SBSCRP		;ARRAY?
	JRST	ARLO			;YES
	TRNE	TBITS,ITEM+ITMVAR+PROCED
	JRST	TYPDES			;DESCRIMINATE
	HRRI	A,TICTXT
	TRNE	TBITS,FLOTNG
	TRNN	TBITS,SET
	CAIA	
	POPJ	P,
	HRRI	A,TIST			;SET
	TRNE	TBITS,SET
	POPJ	P,
	HRRI	A,TIVB
	TRNE	TBITS,INTEGR+FLOTNG+DBLPRC
	POPJ	P,
	HRRI	A,TISV			;STRING VARIABLE
	TRNE	TBITS,STRING
	POPJ	P,
	HRRI	A,TILB			;LABEL
	TRNE	TBITS,LABEL
	POPJ	P,
TROUBL:	HRRI	A,TI			;UNDECLARED IDENTIFIER
	POPJ	P,

TYPDES:	HRRI	A,TIPR			;PROCEDURE
	TRNE	TBITS,PROCED
	POPJ	P,
	HRRI	A,TIIT			;ITEM
	TRNE	TBITS,ITEM
	POPJ	P,
	HRRI	A,TITV			;ITEMVAR
	TRNE	TBITS,ITMVAR
	POPJ	P,
	JRST	TROUBL

ARLO:	HRRI	A,TIAR			;ARITHMETIC OR ITEM ARRAY.
	POPJ	P,			;ARITHMETIC OR ITEM ARRAY

MYCON:	HRRI	A,TICN			;ARITHMETIC CONTSTANT
	TRNE	TBITS,STRING		;MIGHT BE STRING
	 HRRI	 A,TSTC			;STRING CONSTANT.
	POPJ	P,

↑TYPAR:	;TYPE AN ARRAY
↑TYPPRO: TDZA	B,B		;INDEX INTO GENRIG,PARIG
↑TYPR1:	MOVEI	B,1
	SKIPN	LPSA,GENRIG(B)		;SEMANTICS
	ERR	<UNTYPED PROCEDURE AS EXPRESSION>,1,<[TRO TBITS,INTEGR
						JRST TYPESS]>
TYA1:	PUSHJ	P,GETADL		;GET GOOD BITS
	TLNE	TBITS,MPBIND		;MATCHING PROCEDURE
	TLNN	FF,LPPROG		;AND FOREACH IN PROGRESS
	CAIA
	POPJ	P,
	TRZ	TBITS,PROCED		;TURN OFF PROCEDURE
	TLZ	TBITS,-1
	TRNN	TBITS,ALTYPS		;ANYTHING THERE?
TYPER:	JRST	[HRLI	A,CLSIDX	;WE FAKE AN INTEGER
		 HRRI	A,TIVB
		 JRST	TYPESS]
       	PUSHJ	P,TYPDEC		;TYPE BIT
TYPESS:	MOVEM	A,PARRIG(B)		;PUT DOWN THE ANSWER
	POPJ	P,


↑PRST:	SKIPN	PNT,GENRIG
	POPJ	P,		;PROCEDURE WAS UNTYPED....
	MOVE 	TBITS,$TBITS(PNT)	; TYPE.
;;#HS# JRL 6-14-72 A STRING ITEMVAR IS NOT A STRING
	TRNE	TBITS,ITMVAR!ITEM
	JRST	REMOP
;;#HS# 
	TRNE	TBITS,STRING	;IF OF TYPE STRING, COMPLAIN.
	JRST	SUBIT		;DOWN IN TOTAL -- SUBTRACTS FROM STACK.
	JRST	REMOP

DSCR TYPSET, VALSET, XOWSET,  etc.
PRO TYPSET XOWSET VALSET HELAR2 HELAR1 HELARY CLRSET PRSET
DES EXECS to collect type bits as they are specified
 The standard mechanisms for entering variables.
 Little routines are called to turn on the right bits
 in the "BITS" word for ENTERS to eventually use
⊗



;RECORD ANY MODIFIERS ON THE DECLARATIONS.
;CALLED WITH CLASS INDEX TYPE IN REGISTER B.
↑XOWSET: SKIPA	A,XOTAB(B)		;PICK UP TABLE ENTRY
↑VALSET: MOVE	A,VALTAB(B)		;INDEXED BY "B" PASSED FROM PARSER
	IORM	A,BITS
	POPJ	P,			;RETURN

LEP<
↑ARYSET: SKIPA  A,[LPARRAY]
↑SAFSET: MOVEI	A,SAFE			;SAFE BIT
	 IORM	A,BITS			;SAVE IT
	 POPJ   P,
>;LEP
↑HELAR2: MOVE	B,BITS
	PUSHJ	P,HELSPC		;SPECIAL FOR ARRAY ITEMS.
	TDZA	B,B			;ITEM .......
↑HELAR1: MOVEI	B,1
↑HELARY: MOVEI	A,LPARRAY		;SAY A LEAP TYPE ARRAY.
	IORM	A,BITS			;AND FALL THROUGH TO TYPE IT.
↑HELSET:
↑TYPSET: MOVE	A,TYPTAB(B)		;ORDINARY TYPES.
	IORB	A,BITS
	MOVEM	A,ARYBIT		;AND RECORD SHOULD AN ARRAY BE DECLARED.
	POPJ	P,

↑CLRSET: SETZM	BITS			;ZERO FOR A NEW TYPE
	POPJ	P,

↑PRSET:	MOVEI	A,PROCED
	IORM	A,BITS
	POPJ	P,

; ******
;  STARY, ENTARY, Array declaration routines, were moved to ARRAY code
; ****** 11/24/70
	MOVEM	A,PARRIG(B)		;PUT DOWN THE ANSWER

DSCR TCON, BTRU, BFAL, BNUL, BINF
PRO TCON
DES kludges to make TRUE, FALSE, NULL, and ∞ work right
 TRUE≡-1, so a constant is created (once), and Semantics rtnd
 FALSE≡0
 NULL≡""
 ∞≡LENGTH(innermost String being SUBSCRd -- else error)
⊗

↑TCON:	JRST	.+1(B)		;CALL CORRECT ROUTINE.
	JRST	BINF		;∞ OPERATOR.
	JRST	BNUL		;NULL

↑BTRU:	SKIPA	C,[XWD -1,TRULOC]
↑BFAL:	MOVEI	C,FALLOC
	PUSHJ	P,GETITC	;GET THE CONSTANT.
RETRT:	MOVEM	PNT,GENRIG
	POPJ	P,

↑BTRU1:	HRROI	C,TRULOC	;FOR TRUE
GETITC:	SKIPE	PNT,(C)		;IS THERE A VALUE ALREADY??
	 POPJ    P,		;YES -- RETURN IT.
	PUSH	P,BITS
	HLRE	A,C			;THIS IS 0 OR -1
	PUSHJ	P,CREINT
	MOVEM	PNT,(C)
	POP	P,BITS			;RESTORE
	POPJ	P,



↑BNUL:	SKIPE	PNT,NULLOC
	JRST	RETRT
	PUSH	P,BITS
	PUSH	P,PNAME
	PUSH	P,PNAME+1
	SETZM	PNAME+1
	SETZM	PNAME
	PUSHJ	P,STRINS
	MOVEM	PNT,NULLOC
	POP	P,PNAME+1
	POP	P,PNAME
	POP	P,BITS
	JRST	RETRT

↑BINF:	SKIPN	LENCNT		;ARE WE INSIDEA SUBSTRING OPERATION??
	ERR	(<∞ (INF) INVALID, 0 ASSUMED>,1,BFAL)
	HLRZ	A,LENSTR	;LEFT HALF POINTS TO TOP OF QPUSH STACK.
LEP <  
	SKIPGE  A,(A)		;NEG IF INF. WITHIN SUBLIST SELECTOR
	JRST	LINF		;LIST INFIN. LOCATED IN LEAP
    >;LEP
NOLEP <
	MOVE	A,(A)
    >;NOLEP

	MOVEM	A,GENLEF+1	;SET UP FOR LENGTH
	JRST	LLEN1		;MODIFIED FORM OF LENGTH.

DSCR TWID10, ECHK, ESET
PRO TWID10, ECHK, ESET
DES The "TWIDDLERS" which craftily manipulate the semantics
 stack entries.  They are used to move things around when
 no other generators need be called, or when convenience warrents.
⊗

↑TWID10: MOVE	A,GENLEF+1	;THIS MOVES FROM ENTRY 1
	MOVEM	A,GENRIG	;TO ENTRY 0.
	POPJ	P,		;EXAMPLE -- PRODUCTION "XID"



;NOW FOR THE GENERALIZED EXPRESSION CHECKER.  PASSED IS AN INDEX....

↑ECHK:	JRST	@.+1(B)		;GO DO RIGHT THINGS.
	JRST	CPOPJ		;REGULAR ARITH EXPRESSION.
	JRST	LEVBOL		;BOOLEAN EXPRESSION .. CONVERT TO INTEGER.
	JRST	LEAVE		;ASSOCIATIVE EXPR. -- CONVERT TO ITEM ..


; SAVE CLASS INDEX FOR PRODUCTIONS WHICH REFER TO TWO (FIRST)

↑ESET:	MOVEM	B,THISE		;SAVE INDEX IF THIS CLASS
	POPJ	P,		;HARDLY WORTH THE CALL
				; (SHOULD HAVE WRITTEN?)

DSCR FDO1, FDO2
PRO FDO1 FDO2
DES LEAP function calling routines -- dipatch on class
 to proper LEAP routine.
⊗

↑FDO1:	JRST	@.+1(B)
	JRST	ISTRIP		;ISTRIPLE
	JRST	SLOP		;STRING LOP
	JRST	ECVN		;CVN
	JRST	[SKIPN	PNT,GENLEF+1
		 JRST	STCNT
		 MOVE	TBITS,$TBITS(PNT)
		 TRNN	TBITS,STRING!INTEGR
		 JRST	STCNT	;LENGTH OF SET.
		 JRST	LLEN	;STRING LENGTH
		]
	REPEAT 2 ,<JRST BYPE>	;BYTE POINTER THINGS.
	JRST	ECVN		;? ITEMVAR BOUND

↑FDO2:	JRST	@.+1(B)
	SELET
	SELET
	SELET			;FIRST,SECOND,THIRD
	STUNT			;COP
	ECVI			;CVI
SUBTTL	EXECS for Handling Block Levels, Entering Variables

DSCR DWN, BLOCK, BLNAME, ENTID, UP, NAMCHK, etc.
PRO DWNA DWN BLOCK BLNAME ENTID ENDDEC UP1 UP2 NAMCHK UPWOM
DES These EXECS handle the declarations of a Block, from
 recursion of lexical state at BEGIN and END, to the actual
 entry of locals, to the checking of Block names.
SEE comments following this DSCR for more information.
⊗


Comment ⊗

These are the routines to process the entering and leaving of lexical levels.

DWN is called when a BEGIN is seen.  It merely clears the boards in case
	some declarations come along.

BLOCK is called if it develops that this block is going to have declarations.
	The lexical level is incremented, and a new hash bucket is made.
	The block entry in the semantic stack is flagged as "declarations
	done in this block".

BLNAME is called if the block is going to have a name.  This is independent
	of whether it has declarations or not.  If there are no declarations,
	this is merely the name of a compound block.

ENTID is called to enter identifiers in the block. It basically calls
	ENTERS.  But there is a lot of bookkeeping to do -- allocate
	item numbers, flag the block if arrays are declared, etc.
	
ENDDEC is called when all declarations are done.  This puts out an
	ARMRK if arrays were declared, etc.

UP1 or UP2 is called when the block is exited.  
	The block header is placed in a "block list" which is scanned
	at allocation time (end of procedure).  Symbols, etc. are
	put out at that time. 

NAMCHK is called to check to see if the respective BEGIN END pairs have
	corresponding names.

PACDO is called to protect acs for the duration of the block

⊗


;COME HERE WHEN YOU SEE A BEGIN

↑DWN:	SETOM	NODFSW			; SET FLAG TO DEFER PROCESSING OF DEFINES 
					;  UNTIL A BLOCK HAS BEEN EXECUTED.

↑DWN1:	SETZM	BITS			;IN CASE A CONSTANT WAS ENTERED
	SETZM	GENRIG+1
WOM <
	JUMPE	B,DWNWOM
>;WOM
					;WHILE WE WERE AWAY!!!
	POPJ	P,			;ALL DONE








↑OFFDEF: SETZM	NODFSW			; TURN OFF FLAG WHICH DEFERS THE PROCESSING
	POPJ	P,			;  OF DEFINES UNTIL A BLOCK HAS BEEN 
					;  EXECUTED.

↑BLOCK:	SETZM	NODFSW			; TURN OFF FLAG WHICH CAUSES THE DEFERMENT 
					;  OF DEFINE PROCESSING.
	AOS	LEVEL
	MOVE	A,VARB			;SAVE OLD CONTENTS.
	SETZM	VARB			;RESTART VARB.
	SKIPN	LPSA,GENLEF+1		;"BLOCK" BLOCK THERE?
	GETBLK				; NO -- GET ONE.
	SKIPN	QQFLAG			;IS THIS THE FIRST BLOCK WITH DECL'S?
	HRRZM	LPSA,QQBLK		;YES, STORE IT FOR UNDEC
	SETOM	QQFLAG

;**** QQFLAG WILL HAVE TO BE INCLUDED IN THE INITIALZATION CODE EVENTUALLY****
YESBB:	
	HRROM	LPSA,GENRIG+1		;FLAG THAT DELCARATIONS HAVE BEEN DONE.
	PUSHJ	P,RNGVRB		;PUT ON THE VARB RING
	HRL	A,TTOP			;GET OLD TTOP
	MOVEM	A,$ADR(LPSA)		;SAVE TTOP,,VARB.
	MOVEW	(<$SBITS(LPSA)>,LEVEL)	;SAVE CURRENT LEVEL
	HRRM	LPSA,TTOP		;NEW ONE
	HRRZ	TEMP,NMLVL		;PICK IT UP HERE IN CASE BLNAME DOESN'T
	HRRM	TEMP,$VAL2(LPSA)	;AND STORE IT IN DDT LEVEL LOCATION

	PUSHJ	P,MAKBUK		;MAKE A NEW SYMBOL BCKET
	MOVE	LPSA,SYMTAB		; GET NEW BUCKET
	MOVE	TEMP,GENRIG+1		; GET THE BLOCK
	HRRM	LPSA,%TBUCK(TEMP)	; STORE BUCKET FOR LATER HASH OF IDENTS
	JRST	SHASH			;HASH AGAIN GIVEN THE NEW BUCKET







↑CSNAME: TLO	FF,FFTEMP	;NAMED CASE STATEMENT
	SETZM	BITS		;DUPLICATE INITIAL CODE
	MOVE	PNT,GENLEF	; BECAUSE
	MOVE	LPSA,GENLEF+1	; WE ALREADY HAVE A CASE BLOCK
	JRST	FOXX		;  LINK IT TO STRING RING AND CONTINUE
	
↑BLNAME: TLZ	FF,FFTEMP	;NAMED BLOCK,CPD STMT
	SETZM	BITS
	MOVE	PNT,GENLEF		;POINTER TO NAME CONSTANT.
WOM <
	SKIPE	LPSA,GENRIG		;IF THIS WAS AN "EX" THING
	JRST	FOXX			;THEN DO NOT GET BLOCK
>;WOM
	GETBLK	<GENRIG>		;GET A BLOCK.
FOXX:	PUSHJ	P,RNGSTR		;PUT ON THE STRING RING
	TLNE	FF,FFTEMP		;CASE STMT?
	 JRST 	CSVER			;YES, NO LABEL ISSUED
	AOS	TEMP,NMLVL		;DDT (BLOCK NAME) LEVEL
	HRL	TEMP,PCNT		;LOCATION OF FIRST WORD
	MOVEM	TEMP,$VAL2(LPSA)	;STORE IN BLOCK BLOCK
CSVER:	MOVEI	A,$PNAME-1(LPSA)
	PUSH	A,$PNAME(PNT)	;RECORD NAME.
	PUSH	A,$PNAME+1(PNT)
SLS <		;ENTER BLOCK NAME
	QPUSH	(PRGBSTK,PRGBLK)	;SAVE OLD PRGBLK VALUE
	TLNE	FF,TOPLEV		;DIFFERENT PROCEDURE FOR TOP LEVEL
	 JRST	 NOCRW
	SALCAL	(SLBLK,<NMLVL>,<-PNT,$PNAME>) ;INSERT THIS BLOCK
	MOVEM	A,PRGBLK		;UPDATE PRGBLK
>;SLS

NOGAG <
	TLNN	FF,CREFSW		;CREFFING?
	JRST 	NOCRW			;NO
	MOVEI	A,15
	PUSHJ	P,CREFOUT		;BLOCK NAME COMING.
	PUSHJ	P,CREFASC		;AND CREF THE ASCII NAME OF BLOCK.
>;NOGAG
NOCRW:
	TLNN	FF,FFTEMP		;CASE?
	TLNN	FF,TOPLEV		;AT TOP LEVEL?
	POPJ	P,			;NO
	MOVEI	LPSA,IPROC+$PNAME-1	;PUT IN PROGRAM NMAE.
	PUSH	LPSA,$PNAME(PNT)
	PUSH	LPSA,$PNAME+1(PNT)
SLS <		;ENTER TITLE, OUTER BLOCK NAME
	SALCAL	(SLPRG,<>,<-PNT,$PNAME>)
	MOVEM	A,PRGBLK		;SET PRGBLK ID (SLS)
>;SLS
	JRST	MAKT			;MAKE A NEW PROGRAM HEADER.

↑PACDO:	MOVE	LPSA,GENLEF+1		;PICK UP AC NO TO SAVE
	MOVE	D,$VAL(LPSA)		;
	CAIL	D,0
	CAILE	D,17
	ERR	<ATTEMPT TO PROTECT A NUMBER NOT AN AC>,7
	ANDI	D,17			;IN CASE THE FOOL CONTINUES
	SKIPL	B,ACKTAB(A)
	JRST 	.+3
	MOVE 	D,D			;FOR ERR UUO
	ERR	<ATTEMPT TO PROTECT SOMETHING ALREADY PROTECTED>,7
	PUSHJ	P,STORZ			;CLEAR THE AC
	HRROS	ACKTAB(D)		;PROTECT IT
	HRLZI	A,1
	LSH	A,-1(D)			;ORING MASK
	MOVE	LPSA,TTOP
	ORM	A,$TBITS(LPSA)		;MARK BLOCK SEMBLK
	MOVEI	A,12
	MOVEI	B,4
CNT1FA:	SKIPL	ACKTAB(A)
	SOJLE	B,ENGHAC
	SOJGE	A,CNT1FA
	ERR	<NOT ENOUGH ACS LEFT UNPROTECTED>,1
ENGHAC:	POPJ	P,

↑ENTID:	
ORDENT:	
	SKIPN	PNT,NEWSYM
	 JRST	 ENWAY		;NOT DEFINED BEFORE
	MOVE	TBITS,$TBITS(PNT) ;GET CURRENT SEMANTICS
	TLNE	TBITS,CNST	;DON'T LET CONSTANTS THROUGH
	 ERR	 <DECLARING A CONSTANT -- CHECK MACROS>,1
NOGAG <
	TLNN	FF,CREFSW	;ARE WE CREFFING?
	 JRST	 ENWAY		; NO
	MOVEI	A,7		;DELETE PREVIOUS ENTRY.
	PUSHJ	P,CREFOUT
>;NOGAG
ENWAY:
	PUSHJ	P,ENTERS		;DO THIS FIRST!!
	MOVE	LPSA,NEWSYM
	PUSHJ	P,GETADL		;GET GOOD BITS
	TLNE	FF,PRODEF		;ARE WE SCANNING ID LIST
	 JRST	 IDLIS			; YES
	MOVE	A,[XWD SAFE,SET+INTEGR]	;CHECK ON KILL SET GUY
	TDC	A,TBITS
	TDNE	A,[XWD SAFE,SET+INTEGR]	;IS IT ??
	JRST	EN.W1			;NO
	TDNE	TBITS,[XWD SBSCRP,ITEM!ITMVAR!PROCED]
	ERR	<ILLEGAL DATA TYPE COMBINATION FOR KILL SET>
EN.W1:	TLNE	TBITS,SBSCRP		;IF STRING ARRAYS, TURN
	TRZ	TBITS,STRING		;OFF THE STRING PART.
	TRNE	TBITS,ITEM!ITMVAR	;IGNORE DATUM TYPE OF ITEMS
	TRZ	TBITS,STRING!BOOLEAN!INTEGR!SET!LSTBIT!FLOTNG
	MOVE	PNT2,TTOP		;CURRENT BLOCK.
	TLNE	TBITS,OWN		;IF OWN, THEN DONTSAVE BIT
	JRST	IORDON			;
	SKIPN	SIMPSW			;BETTER NOT LET SIMPLE DO ALLOC
	JRST	.+3			;HE ISNT SIMPLE
	TDNE	TBITS,[XWD SBSCRP,SET]	;CHECK FOR BAD GUYS
	ERR	<SIMPLE PROCEDURES MAY NOT ALLOCATE!>,1,IORDON
	IORM	TBITS,$VAL(PNT2)	;THE "OR" OF ALL SYMBOLS DEFINED.
IORDON:
GLOC <
	TRNN	TBITS,ITEM		;IF ITEM OR
	TRNN	TBITS,GLOBL		;NOT GLOBAL, THEN GO ON
	JRST	NOGLB
	TLNE	FF,TOPLEV		;IF NOT AT TOP LEVEL
	TRNE	TBITS,STRING!LABEL	;OR IF THESE RIDICULUOUS TYPES.
	ERR	<INVALID GLOBAL TYPE>,1
	AOS	A,GLOBCNT		;COUNT OF GLOBALS.
	CAILE	A,GLBAR		;WITHIN BOUNDS OF GLOBAL AREA?
	ERR	<TOO MUCH GLOBAL DATA>,1
	HRLM	A,$VAL2(PNT)		;AND SAVE.
GAG <
	ADDI	A,400013		;GLOBAL DATA BASE.
	HRRZM	A,$ADR(PNT)
>;GAG
NOGLB:
>;GLOC
LEP <
; FOLLOWING REMOVED TO ALLOW INTRODUCTION OF STRING ITEMS.
;	TRNN	TBITS,LPARRAY
;	JRST	[TRNN	TBITS,STRING
;		 JRST	.+1
;		 TRNE	TBITS,ITEM!ITMVAR
;		 ERR	<STRING ITEMS NOT IN, ALTHOUGH STRING ARRAY ITEMS ARE>,1
;		 JRST	.+1]
NOGRUMP:
	TRNE	TBITS,ITEM!ITMVAR!SET	;A LEAP DATA TYPE?
	SETOM	LEAPIS			;TELL WORLD SOMEONE USED LEAP.
	TRNN	TBITS,ITEM		;WAS IT AN ITEM?
NOGAG < ;NOT DONE IF "GOGOL"
	POPJ	P,
>;NOGAG
GAG <
	JRST	ASSIGN		;ASSIGN A LOCATION TO IT
>;GAG
	PUSH	P,PNT			;SAVE ITEM SYMBOL POINTER
	PUSH	P,BITS
GLOC <
	TRNE	TBITS,GLOBL		;IF A GLOBAL ITEM, THEN MAKE LEFT HALF
	SOSA	A,GITEMNO
>;GLOC
	AOS	A,ITEMNO		;MAKE A NEW NUMBER FOR IT
	AOS 	ITMCNT			;TOTAL NUMBER OF DECLARED ITEMS
GAG <
GLOC <
	TRNE	TBITS,GLOBL
	SOSA	GITEMNO-SPCDAT+WOMSPC	;IN WOM SPACE BLOCK.
>;GLOC
	AOS	ITEMNO-SPCDAT+WOMSPC
>;GAG
	PUSHJ	P,CREINT		;MAKE AN INEGER OF ITEM NUMBER.
	MOVE	PNT2,PNT
	PUSH	P,A			;SAVE ITEM NUMBER
	SKIPN	PNMSW			;PNAMES GOING NOW ?
	JRST	NOPNM			;NO
	AOS	PNMSW			;INDEX COUNT.
NOGAG <
	PUSHJ	P,STRINS		;MAKE ANOTHER COPY OF NAME
	HRL	PNT,A		;ITEM NUMBER.
	QPUSH	(PNLST,PNT)		;SAVE FOR LATER.
NOPNM:
	MOVE	A,-1(P)		;TYPE BITS
	PUSHJ	P,ITMTYP	;GET TYPE INDEX
	HRL	A,(P)		;ALSO ITEM NUMBER
	QPUSH   (ITMSTK)
	POP	P,A		;RESTORE A
>;NOGAG
GAG <
	MOVE	SP,STPSAV
	PUSH	SP,PNAME
	PUSH	SP,PNAME+1
	PUSHJ	P,[PUSHJ P,SAVE
		   PUSH	P,A	;ITEM NUMBER.
		   PUSHJ P,NEW.PNAME
		   MOVE LPSA,X11
		   JRST RESTR]
>;GAG

	POP	P,BITS
	POP	P,LPSA
;; #KW# DON'T ALLOW INTERNAL OR EXTERNAL ITEMS
	MOVE	TBITS,$TBITS(LPSA)
	TLZE	TBITS,EXTRNL!INTRNL	;ITEMS CAN'T BE INTERNAL OR EXTERNAL
	ERR	<ITEMS CAN'T BE INTERNAL OR EXTERNAL>,1
	MOVEM	TBITS,$TBITS(LPSA)
;; #KW#
	MOVEM	PNT2,$VAL2(LPSA)		;SAVE THE POINTER TO INTEGER!!!!
	POPJ	P,		;EVEN IF "GOGOL", ITEMS DON'T NEED LOCATIONS
>;LEP


GAG <
↑ASSIGN:
	TRNN	TBITS,GLOBL		;NEVER ASSIGN CORE FOR GLOBS.
	TRNE	TBITS,ITEM!LABEL!PROCED ;DON'T ASSIGN LOCS TO THESE
	POPJ	P,
	TLNE	TBITS,EXTRNL	;ALREADY ASSIGNED IF EXTERNAL!
	 POPJ	 P,

	MOVEI	B,0		;BITS FOR VARSTK HEADER
	TRNE	TBITS,STRING	;AS USUAL, THIS IS DIFFERENT
	 JRST	 STRASS		; STRING ASSIGNMENT
	TRNE	TBITS,SET	;DENOTE TYPE BY SOME SPECIAL BITS
	 TRO	 B,1
	TLNE	TBITS,SBSCRP	;ALSO MARK ARRAYS SO THEY CAN BE FOUND
	 JRST	 [MOVE TBITS,$TBITS(PNT)
		  TRNE TBITS,STRING
		  TRO	B,2	;STRING ARRAY
		  TRO	B,4	;SOME SORT OF ARRAY
		  JRST	.+1]
	PUSHJ	P,VAROUT	;MAKE ROOM
ASSBAK:	HRRM	TEMP,$ADR(PNT)	;STORE ADDR (OF 1ST IF STRING)
SLS <
	SALCAL	(SLSENT,<PRGBLK,PNT>,<-PNT,$PNAME>)
>;SLS
; ABOVE PUTS OUT THE SYMBOL, RAT NOW.
	POPJ	P,

STRASS:	PUSHJ	P,STVOUT	;ALMOST THE SAME
	HRLM	TEMP,$ADR(PNT)	;ADDRESS OF SECOND WORD
	SOJA	TEMP,ASSBAK	;GO MARK 1ST WORD ADDR

>;GAG

IDLIS:	TRNN	TBITS,PROCED
	TLNE	TBITS,SBSCRP
	JRST	[TLZE	TBITS,VALUE
		 ERR	<VALUE PROCEDURE OR ARRAY CALLS NOT IMPLEMENTED>,1
		 TLO	TBITS,REFRNC
		 TRZ	TBITS,INPROG	;ONLY RELEVANT TO PROCED
		 JRST	IDFXN]
	TLNN	TBITS,REFRNC
	TLO	TBITS,VALUE		;IMPLIED VALUE
IDFXN:	TRNE	TBITS,PROCED
	TLO	TBITS,ANYTYP
	MOVEM	TBITS,$TBITS(PNT)
;;#HR# 6-14-72 JRL HANDLE STRING ITEMVAR FORMAL PARAMETERS
	TRNE	TBITS,ITEM!ITMVAR	;IGNORE STRING BIT IF ITEM
	TRZ	TBITS,STRING
;;#HR#
	TRNE	TBITS,STRING		;UPDATE THE STACK
	TLNE	TBITS,REFRNC		;COUNTERS ACCORDING
	AOSA	APARNO			;TO THE TYPE OF PARAMETER
	AOS	SPARNO
SLS <	;PUT OUT SYMBOL
	SALCAL	(SLSENT,<PRGBLK,PNT>,<-PNT,$PNAME>)
	MOVEM	A,LINKS
>;SLS

	POPJ	P,





↑ENDDEC:PUSHJ	P,ENDJMP		;FIX UP JUMP AROUND PROCS, IF ANY
	JFCL				;IGNORE SKIPPEDNESS
	SKIPN	LPSA,GENLEF+1		;DID WE DEFINE ANYTHING?
	POPJ	P,			;NO -- RETURN
	HRRZ	TEMP,PCNT		;UPDATE LOC OF FIRST WORD OF BLOCK
	HRLM	TEMP,$VAL2(LPSA)
NODIS <
	MOVE	TBITS,$VAL(LPSA)	;ALL TYPES OF SYMBOLS DECLARED.
	TLNN	TBITS,SBSCRP		;ARRAYS DELCARED HERE?
	JRST	ENDDE			;NO
	XCALL	<ARMRK>
>;NODIS
ENDDE:	TLZ	FF,TOPLEV
	POPJ	P,			;ALL DONE

↑↑ENDJMP:
	MOVE	TEMP,TPROC		;SURROUNDING PROCEDURE SEMANTICS
	HLRZ	TEMP,%TLINK(TEMP)	;2D PROC BLOCK
	SKIPN	B,$SBITS(TEMP)		;DID ANYBODY JUMP? (SEE PRDEC)
	 JRST	 CPOPJ1			; NOBODY DID
	SETZM	$SBITS(TEMP)		;CLEAR FOR NEXT TIME
	HRL	B,PCNT
	JRST	FBOSWP			;NOW FIX UP JUMP AND QUIT
↑CPOPJ1:AOS	(P)			;THE CANONICAL SKIP-RETURN
	POPJ	P,			;DONE

;HERE WHEN YOU SEE THE MATCHING "END"

↑UP1:	SKIPA	PNT,GENLEF+1		;FOR CODE_BEGIN SEQUENCES
↑UP2:	MOVE	PNT,GENLEF+2		;BEGIN SEMANTICS.
UPPP:	MOVEM	PNT,GENRIG		;SAVE FOR NAME CHECKING.
	JUMPE	PNT,NMSUB		;NO BLOCK ASSOCIATED WITH THIS BEGIN
	JUMPL	PNT,UPCHK		;THIS BLOCK HAS DECLARATIONS ...
	SKIPN	$PNAME(PNT)		;NAMED COMPOUND STATEMENT?
	 JRST	 NONM			; NO, FORGET IT
	HRRZS	PNT			;LH 0 TO INDICATE PRESENCE OF NAME
	QPUSH	(BLKIDX,PNT)		;PUT CPD STMT SEMBLK IN STACK
	SETZM	%RVARB(PNT)		;MAKE SURE THERE'S NO LIST
	SOS	NMLVL			;LOWER DDT LEVEL BY ONE
SLS <
	QPOP	(PRGBSTK)		;OLD PRGBLK ID
	MOVEM	A,PRGBLK		;RESTORE
>;SLS
CREFWQ:
NOGAG <
	TLNN	FF,CREFSW		;CREFFING ?
>;NOGAG
	POPJ	P,			;DON'T DELETE THE BLOCK
NOGAG <
	MOVEI	LPSA,(PNT)	; POINTER TO BLOCK.
	JRST	CREFBLOCK		;AND CREF BLOCK EXIT.
>;NOGAG

NONM:	MOVE	LPSA,PNT
	PUSHJ	P,URGSTR		;IN CASE IT WAS A NAMED BLOCK..!!
	FREBLK	<PNT>
NMSUB:	POPJ	P,


UPCHK:	PUSHJ	P,GOSTO			;STORE EVERYONE
	MOVE	TBITS,$VAL(PNT)
NODIS <
	TLNN	TBITS,SBSCRP		;WERE ARRAYS DELCARED IN THIS BLOCK?
	JRST	EMJR			;NO
	XCALL	<ARREL>			;RELEASE THEM.
>;NODIS

DIS <
;;#KT# ↓ TYPO AS TO WHERE KILL SET IS
	HRRZ	C,$ACNO(PNT)		;IF WE HAVE A KILL LIST
	JUMPN	C,DBEX			;MUST BEXIT
	LDB	C,[POINT LLFLDL,$SBITS(PNT),35]	;PICK UP LEXIC LEVEL
	CAIE	C,1			; IF NOT GLOBAL AND
	TDNN	TBITS,[ XWD SBSCRP,SET]	;IF ONE OF THE BAD GUYS
	JRST	EMJR			;THINGS ARENT SO EASY
;;#KX# 1-9-73 DO ALLSTO BEFORE YOU BEXIT -- RHT
DBEX:	PUSHJ 	P,ALLSTO		;
	HRR	C,PCNT
	HLL	C,$SBITS(PNT)
	HRLM	C,$SBITS(PNT)		;FIXUP BK LVI REF
	EMIT	<MOVEI	LPSA,NOUSAC!USADDR>
	XCALL	<BEXIT>
>;DIS



EMJR:	HRROS	PNT			;ASSUME NO NAME
	SKIPE	$PNAME(PNT)
	JRST	[HRRZS PNT		;WRONG AGAIN
		 SOS	NMLVL		;NAME LEVEL
		 PUSHJ	P,CREFWQ	;POSSIBLY CREF BLOCK EXIT.
SLS <
		 QPOP 	(PRGBSTK)	;RESTORE PRGBLK ID
		 MOVEM	A,PRGBLK
>;SLS
		 JRST 	.+1]
	HLRZ	A,$TBITS(PNT)		;BITS OF PROTECTED ACS
COMMENT ⊗ HORRIBLE LOOP TO UNDO PROTECTION OF ACS IN THIS BLOCK ⊗
	PUSH	P,B
	PUSH	P,D
	MOVEI	D,11
	MOVEI	B,1000			;BIT FOR AC 11 
UPACHK:	TDZE	A,B			;DID WE PROTECT IT
	HRRZS	ACKTAB(D)		;UNPROTECT IT
	LSH	B,-1
	SOJGE	D,UPACHK			;
	POP	P,D
	POP	P,B
;**************************************
	QPUSH(BLKIDX,PNT)
	MOVE	A,$ADR(PNT)
	HLRM	A,TTOP			;RESTORE IT.
	HRRM	A,VARB			;RESTORE THE VARB POINTER.
	SOS	LEVEL
	JRST	FREBUK		;come up a level in symbol buckets.

; Check for match on block names.

↑NAMCHK: SKIPN	PNT,GENLEF+1		;BLOCK SEMANTICS.
	JRST	NMCHKK
	MOVE	PNT2,GENLEF		;END NAMED.
	MOVE	A,$PNAME+1(PNT)		;BYTE POINTER.
	JUMPE	A,NMCHKK		;BLOCK UNNAMED
	CAMN	A,$PNAME+1(PNT2)	;AND THE OTHER
	POPJ	P,
	JRST	MTCERR			;NO GOOD
NMCHKK:	MOVE	TEMP,TPROC		;TRY FOR MATCH WITH 
	MOVE	PNT2,GENLEF		;END NAMED
	MOVE	A,@$PNAME+1(TEMP)	;CURRENT PROC NAME
	CAMN	A,@$PNAME+1(PNT2)	; (FIRST WORD MATCH ONLY)
	POPJ	P,
	SKIPN	PNT
	ERR	<NAME AFTER UNNAMED BLOCK!>,1,CPOPJ
MTCERR:	ERR	<NAMES OF BEGIN AND END DO NOT MATCH>,1
	POPJ	P,




WOM <
;ROUTINES FOR EXECUTE AND THROW OUT PARTS OF CODE....

DWNWOM:	PUSH	P,PCNT
	PUSH	P,CODSTK
	PUSH	P,CODSTK+1
	PUSH	P,CODSTK+2		;SAVE LOTS.
	GETBLK	<GENRIG>		;GOT A BLOCK.
	GETBLK				;AND ANOTHER
	MOVEM	LPSA,@GENRIG		;  BLOCK BLOCK POINTS TO EX BLOCK.
	HRLI	LPSA,-3(P)		;
	HRRI	B,3(LPSA)		;
	BLT	LPSA,(B)		;STORE IN NEW BLOCK.
	SUB	P,X44
	POPJ	P,

↑UPWOM:	PUSHJ	P,ALLSTO
	MOVE	SP,GENLEF+2		;BEGIN BLOCK.
	MOVE	SP,(SP)			; → TO EX BLOCK INFO.
	HRLI	C,RETTN			;RETURN ADDRESS.
	EMIT	(JRST NOUSAC!NORLC!USADDR)
	
	PUSH	P,SP
	PUSH	P,FF
	
	MOVE	SP,STPSAV	;STRING STACK....
	MOVE	A,@-1(P)	; ADDRESS OF STATEMENT.
	JRST	(A)		;GO OF AND HOPE TO RETURN.
	
RETTN:	POP	P,FF
	POP	P,SP

COMUP:	MOVE	B,1(SP)			;CODSTK.
	CAMN	B,CODSTK		;SAME BLOCK?
	JRST	OKK			;YES -- JUST ADJUST CNTS.
	HRRZ	C,-2(B)			;→ PREV.
	PUSHJ	P,CORREL
	MOVE	B,C
	JRST	COMUP
OKK:	HRROI	A,3(SP)
	POP	A,CODSTK+2
	POP	A,CODSTK+1
	POP	A,CODSTK
	POP	A,PCNT
	FREBLK	(SP)
	JRST	UP2		;AND ACT AS IF COMING UP FROM BLOCK.

>;WOM

SUBTTL	EXECS for REQUIRE Verb

DSCR RQ00, RQSET, SRCSWT
PRO RQ00 RQSET SRCSWT REQERR
DES These routines handle the REQUIRE Syntax of the forms:

	|			| PNAMES
	|			| SYSTEM_PDL
	|			| STRING_PDL
	|	n		| STRING_SPACE
	|			| ARRAY_PDL
	|			| NEW_ITEMS
	|			| VERSION
REQUIRE |-----------------------|
	|			| LIBRARY
	|			| LOAD_MODULE
	| "file description"	| SEGMENT_FILE
	|			| SEGMENT_NAME
	|			| SOURCE_FILE
	|-----------------------|
	| "2 or 4 characters"	| DELIMITERS
	|-----------------------|
 PNAMES and SOURCE_FILE are handled specially
⊗


↑RQ00:	SETZM	SCNVAL		;IN CASE NO NUMBER IS GIVEN.
ZPOPJ:	POPJ	P,
↑RQSET:
	SETZM	BITS			;IN CASE UNARY WAS CALLED
LEP <
	JUMPE	B,PNAM			;PNAMES......
>;LEP
	MOVE	A,SCNVAL		;THE CONSTANT
	XCT	RQTAB-1(B)		;DO SOMETHING
	POPJ	P,

RECORD:	HRRZ	TEMP,SPCTBL		;THE SPACE RESERVATIN TABLE
	ADDI	TEMP,1			;ONE MORE WORD
	HRRM	TEMP,SPCTBL		;HOPEFULLY
	CAIN	TEMP,=18		;OVERFLOW?
	 ERR	 <TOO MANY SPACE REQUIRES>,1
	CAILE	TEMP,=17		;PREVIOUS OVERFLOW?
	 POPJ	 P,			;YES
	HRL	A,B			;THE INDEX INDICATES WHICH
	TLO	A,STDSPC		; SPACE IS REQUESTED
	MOVEM	A,SPCTBL+1(TEMP)	;INTO LOADER BLOCK FOR LATER OUTPUT
	 POPJ	 P,

RQTAB:	JRST	RECORD	;SYSTEM PDL
	JRST	RECORD	;STRING PDL
	JRST	RECORD	;STRING SPACE
	JFCL		;ARRAY PDL NO LONGER EXISTS
	MOVEM	A,NWITM	;NEW ITEMS.
	MOVEM A,VERNO	;VERSION NUMBER
	JRST	LBSET			;LIBRARY REQUEST
	JRST	PRGSET			;LOAD MODULE REQUEST.
	JRST	REQERR		;SOMETHING WRONG WITH SOURCE_FILE RQST
	JRST	DELSTG		; PROCESS REQUIRE DELIMITERS COMMAND
	JRST	REPDEL		; PROCESS REPPLACE DELIMITERS COMMAND
	JRST	POPDEL		; PROCESS POP_DELIMITERS COMMAND
	JRST	NULDEL		; PROCESS NULL_DELIMITERS COMMAND
GLOC <		;REQUESTS FOR SEGMENT NAMES, ETC.
	JRST	SEGSET			;LOGICAL SEGMENT NAME REQUEST
	JRST	SEGFL			;SEGMENT FILE NAME REQUEST
>;GLOC
	JRST	INMAIN		;GO INITIALIZE MAINPR
	JRST	REQPLL		; POLLING INTERVAL


NOGAG <
LBSET:	SKIPA	B,[LBTAB]		;LIBRARY OUTPUT BLOCK ADDR
PRGSET:	MOVEI	B,PRGTAB		;PROGRAM OUTPUT BLOCK ADDR
	GETSEM	(1)			;SEMANTICS OF STRING CONST
	HRROI	TEMP,$PNAME+1(PNT)
	POP	TEMP,PNAME+1
	POP	TEMP,PNAME		;SET UP FOR CALL
	JRST	PRGOUT			;OUTPUT REQUEST, RETURN

>;NOGAG

GLOC <
SEGSET:	PUSHJ	P,GETSOM		;GET NAME, SET UP TABLE POINTER
	MOVEM	C,SEGNAM		;NAME ONLY, PUT IN SPACE BLOCK
	POPJ	P,

SEGFL:	PUSHJ	P,GETSOM
	JUMPN	A,.+2			;DEVICE
	MOVSI	A,(<SIXBIT /DSK/>)	;DEFAULT
	MOVEM	A,SEGDEV		;DEVICE NAME
	MOVEM	C,SEGFIL		;FILE NAME
	MOVEM	D,SEGPPN		;WHEEE (TRANSLATION -- PPN)
	POPJ	P,


GETSOM:	GETSEM	(1)			;→STRING REPRESENTING REQUEST
	HRROI	TEMP,$PNAME+1(PNT)	;PNAME
	POP	TEMP,PNAME+1
	POP	TEMP,PNAME
	JRST	FILSCN			;CONVERT TO SIXBIT IN A,C,D
>;GLOC

DELSTG:	GETSEM	(1)			; GET POINTER TO STRING SEMBLK
	TLNE	TBITS,CNST		; CONSTANT?
	TRNN	TBITS,STRING		; STRING?
	ERR	<NOT A STRING CONSTANT - STATEMENT IGNORED>,1,CPOPJ ;


↑GETDEL: HRRZ	LPSA,$PNAME(PNT)	; GET STRING CHARACTER COUNT
	JUMPE	LPSA,NULDEL		; NULL DELIMITER STRING?
	MOVE	PNT,$PNAME+1(PNT)
	QPUSH	(DELSTK,<(PNT)>)	; SAVE THE DELIMITERS
GETDL1:	SETOM	REQDLM
	MOVE	TEMP,[XWD -DELNUM,0]	; FOR AOBJN
↑GETDL2:SOJGE	LPSA,.+2		; DELIMITER SCANNER LOOP
	ERR	<NOT ENOUGH DELIMITERS IN INPUT - GARBAGE IN REST> ;
	ILDB	B,PNT          		; GET NEXT DELIMITER
	SKIPG	SCNTBL(B)		; SPECIAL OR IGNORABLE?
	JRST 	GETDL2			; YES, GET NEXT
	SKIPN 	SWBODY			; SPECIAL DELIMITER DEFINITION?
	MOVEM	B,LOCMBD(TEMP)		; NO, STORE FOR PERMANENT REFERENCE
	MOVEM	B,CURMBG(TEMP)		; STORE FOR TEMPORARY REFERENCE
	AOBJN	TEMP,GETDL2		; CHECK IF DONE
	POPJ	P,			; YES

REPDEL:	QPOP	(DELSTK)
	JRST	DELSTG

POPDEL:	QPOP	(DELSTK)
	QLOOK(DELSTK)		; GET A POINTER TO TOP ELEMENT OF DELSTK
	SETZM	REQDLM
	SKIPN	(A)
	POPJ	P,
	HRLI	A,(<POINT 7,0>)
	MOVE	PNT,A
	MOVEI	LPSA,DELNUM
	JRST	GETDL1

NULDEL:	SETZM	REQDLM
	QPUSH	(DELSTK,REQDLM)
	POPJ	P,

↑MKNSTB: MOVEI	C,1			; INITIALIZE COUNT FOR NESTABLE CHARS.
	MOVEI	A,NUMCHA		; NUMBER OF CHARACTERS
CONCNV:	SOJL	A,CPOPJ			; DONE?
	MOVE	B,SCNTBL(A)		; LOAD AND TEST IF NESTABLE CHARACTER
	TLNN	B,NEST			; 
	JRST 	CONCNV			; NO, GET NEXT CHAR
	MOVEM	C,NSTABL(A)		; YES, NSTABL CONTAINS INDEX AMOUNT
					; TO BE ADDED TO LOCNST
	TLNE 	B,LNEST			; DONE WITH A NESTED PAIR?
	ADDI	C,1			; YES, INCREMENT COUNTER
	JRST 	CONCNV			; GET NEXT

↑SRCSWT:
; FIRST CHECK VALIDITY OF SOURCE_FILE SWITCHING RQST, SET SPECIAL SWITCHER
	MOVE	TBITS2,SCNWRD
	TLNE	TBITS2,MACIN		;IF IN MACRO, ILLEGAL
	 ERR	 <DON'T SWITCH SOURCE FILES INSIDE MACRO>,1,SCANNER
	SETOM	SRCDLY			;FLAG SCANNER
	POPJ	P,

; NOW TRY THE SWITCH-OVER

; CHECK IF THE FILE WAS ACTUALLY SWITCHED
↑SRCCHK: SKIPE	SRCDLY			;WILL BE ZERO IF SWITCHED
	ERR	 <SOURCE FILE REQUEST MUST END LINE>
	POPJ	P,

↑REQERR: ERR	<INVALID SYNTAX -- SOURCE FILE REQUEST>,1
	POPJ	P,

SUBTTL	EXECS for MACRO (DEFINE) Declarations

DSCR DFPREP, DCPREP, DWPREP, DFPINS, DFSET, DFENT, MACOFF
PRO DFPREP DCPREP, DWPREP, DFPINS DFSET DFENT MACOFF
DES Execs for syntax
 DEFINE macnam(a1,a2..)="macro body", macnam2=....,...;
 Relies heavily on mechanisms built into the SCANNER to
 parse the macro body, insert parameters.
SEE SCANNER
⊗
Comment * 
  DFR:	@I  (  →  DPL  EXEC DFPR1  SCAN 2  GO TO DPA
	@I  SG →  DPL  SG  EXEC DFPREP  GO TO LEQ OR GO TO Q0

 DFPREP -- prepare to define a macro body.
	Enter DEFINE symbol. Use current def if
	it's at the same level (done in ENTER). Get
	a new symbol table bucket.

 DCPREP -- prepare to define a conditional compilation CASEC body.
	Check if first casec and if not then enter the computed
	casec value in the $VAL2 entry of the semblk obtained for
	the casec body.

 DWPREP -- prepare to define a conditional compilation WHILEC, FORC,
	or FORLC body. *

↑MACOFF: TLO	FF,NOMACR	;NO MACRO EXPANSIONS WHEN REDEFINING!
	POPJ	P,

↑DCPREP: GETBLK	NEWSYM		; SEMBLK FOR CASEC BODY
	GETSEM (1)		; SEMANTICS OF CASEC NUMBER
	MOVE	TEMP,$VAL(PNT)	; GET CASEC NUMBER
	JUMPN	TEMP,NOFRST	; TWIDDLE IF NOT FIRST CASEC
	PUSHJ	P,CPSHEN	; SET ENDC DOESN'T TRIGGER A PARSER SWITCH FLAG
	SETOM	SWCPRS		; PARSER SWITCHING IS OK (I.E. IFC IN BODY OF CASEC
				;  TO BE EXECUTED)
	JRST	CMPRP2		; DON'T TWIDDLE SINCE FIRST CASEC
NOFRST:	MOVEM	TEMP,$VAL2(LPSA) ; STORE CASEC NUMBER IN $VAL2 OF THE SEMBLK
	MOVEM	LPSA,GENRIG+1	; SAVE SEMANTICS OF PSEUDO MACRO BODY SEMBLK
	MOVE	TEMP,%CFLS1	; TWIDDLE
	MOVEM	TEMP,PARRIG	; NOT THE FIRST CASEC
	JRST	DWPRP1		; REST OF MACRO BODY PRELIMINARIES

↑DWPREP: GETBLK	 NEWSYM		; SEMBLK FOR WHILEC, FORC, OR FORLC BODY
DWPRP1:	HRLZI	TEMP,DEFINE	; GET GOOD BITS
	MOVEM	TEMP,$TBITS(LPSA) ; SET SEMBLK DESCRIPTOR
	HRRZS	%TLINK(LPSA)	; ZERO THE MACRO BODY DEFINITION LINK
	JRST	CMPRP2		; REST OF MACRO BODY PRELIMINARIES

↑DFPREP: HRLZI	TEMP,DEFINE	; GET GOOD BITS
	MOVEM	TEMP,BITS	; PREPARE TO DO AN ENTERS
	PUSHJ	P,ENTERS	; ENTER MACRO NAME IF NOT ALREADY DEFINED
	MOVE	LPSA,VARB	; CHECK IF DEFINE IS HAPPENING BEFORE THE 
	SKIPN	LEVEL		;  OUTER LEVEL BLOCK HAS BEEN STARTED.  IF 
	MOVEI	LPSA,RESYM	;  YES, THEN SET VARB TO RESYM SO DONES WILL
	MOVEM	LPSA,VARB	;  WORK PROPERLY.
CMPRP2:	PUSHJ	P,MAKBUK	;DOWN ONE LEVEL FOR PARAMETERS
	AOS	LEVEL
	MOVE	LPSA,NEWSYM	;SYMANTICS OF ENTRY
	MOVEM	LPSA,GENRIG	;MAY BE GARBAGING "="'S SEMANTICS
	MOVE	TEMP,VARB	;SAVE VARB LIST -- WILL LINK FORMALS
	MOVEM	TEMP,$ADR(LPSA) ; OLD VARB POINTER IS SAVED IN $ADR SO THAT
				;     THE MACRO BODY IS STILL KNOWN
	SETZM	VARB
	HLLZS	$VAL(LPSA)	;CLEAR #PARAMS COUNT (SAVE COUNT FOR PREV DEF).
	SETZM	$ACNO(LPSA)	;WILL POINT AT FIRST PARAM
	TLZ	FF,NOMACR	;MACROS EXPANDED AGAIN
	POPJ	P,


Comment ⊗
  DPA:	SG @I ,  →  SG  EXEC DFPINS  SCAN 2  ¬DPA
	SG @I )  →  SG  EXEC DFPINS  SCAN    ¬LEQ #Q0
  Insert macro parameter:
	1. Enter the symbol
	2. Insert in list off %TLINK in macro name semantics  ⊗

↑MDFPNS: TLZ	FF,NOMACR	; MACROS EXPANDED AGAIN WHEN THROUGH SCANNING 
				;   FORMALS
↑DFPINS: HRLZI	TEMP,FORMAL!DEFINE	;ENTER PARAM (LINK ON SPECIAL VARB RING)
	MOVEM	TEMP,BITS	
	PUSHJ	P,ENTERS
	MOVE	TEMP,GENLEF+2	;SEMANTICS FOR MACRO NAME
	AOS	A,$VAL(TEMP)	;COUNT MACRO PARAMS
	MOVE	LPSA,NEWSYM	;SEMANTICS OF THIS PARAM
	SKIPN	$ACNO(TEMP)	;IS THIS THE FIRST ONE?
	 MOVEM	 LPSA,$ACNO(TEMP) ; YES, STORE POINTER TO FIRST
	HRRZM	A,$VAL(LPSA)	;STORE PARAM NUMBER
	POPJ	P,



Comment ⊗
  LEQ:  STC  →  EXEC SPDMBD  SCAN  ¬LEQ1
	Check if a special macro body delimiter declaration has occurred  ⊗

↑SPDMBD: SETOM	SWBODY		; SET SWITCH DELIMITER DECLARATION FLAG
	MOVE	TEMP,[XWD -2,0]	; SET UP A COUNT
	MOVE	PNT,GENLEF	; GET SEMBLK ADDRESS OF STRING
	HRRZ	LPSA,$PNAME(PNT) ; GET READY FOR A SPECIAL DELIMITER MODE
	MOVE	PNT,$PNAME+1(PNT) ;    SCAN
	JRST	GETDL2		; GET SPECIAL DELIMITERS


Comment ⊗
  LEQ1:	=  →  EXEC DFSET  SCAN 2  ¬DEQ #Q0
	Get ready for macro body  ⊗

↑DFSET:	JRST	FFPUSH		; SAVE DEFLUK BIT OF FF AND TURN IT ON IN FF


Comment ⊗
   DEQ:	DPL ICN ,       →  EXEC DFINE  SCAN 2   ¬DFR
	DDEF DPL ICN ;  →  EXEC DFINE  SCAN     ¬DS0
	SDEF DPL ICN ;  →  EXEC DFINE  SCAN     ¬S1  #Q0

	Eradicate formal parameter ring, turn off special
string mode bit after macro scan -- install the macro body. ⊗

↑DFENT1: MOVE	A,GENLEF+3	; SEMBLK OF CASEC ENTRY
	JRST	NOREDF		; NO PARAMETER LIST TO DELETE
↑DFENT:	MOVE	A,GENLEF+2	; GET SEMBLK ADDRESS
	MOVE	LPSA,$ACNO(A) 	; FORMAL LIST
	PUSHJ	P,KILLST	;DELETE FORMAL PARAM LIST
	SETZM	$ACNO(A)	; NO MORE LIST
	HRRZ	TEMP,$VAL(A)	; #PARAMS FOR THIS (NEW) DEFINITION
	HRLZM	TEMP,$VAL(A)	; #PARAMS FOR CURRENTLY ACTIVE DEF.
	HLRZ	LPSA,%TLINK(A)	; CHECK IF THE MACRO HAS BEEN PREVIOUSLY
	JUMPE	LPSA,NOREDF	;   DEFINED, AND IF YES
	PUSHJ	P,KILLST	;   DELETE THE PREVIOUS DEFINITION
NOREDF:	MOVE	TEMP,$ADR(A) 	; RESTORE SAVED VARB POINTER
	MOVEM	TEMP,VARB	; (IT WAS USED TO KEEP FORMALS LOCATED)
	MOVE	LPSA,GENLEF+1	;MACRO BODY (STRING CONST) SEMANTICS
	HRLM	LPSA,%TLINK(A) 	; STORE IN %TLINK FIELD
	MOVE	TBITS,$TBITS(LPSA) ; GET GOOD BITS
	TRNE	TBITS,STRING	; TEST IF A STRING AND SET IT TO STRING
	JRST	NOCNST		; YES, NO NEED TO CONVERT CONSTANT TO STRING
	PUSH	P,$VAL(LPSA)	; PUSH VALUE
	PUSHJ	P,REMOPL	; DELETE SEMBLK OF NUMERIC CONSTANT IF POSSIBLE
	EXCH	SP,STPSAV	; GET STRING POINTER
	MOVSS	POVTAB+6	;*ENABLE CORRECT MESSAGE -- DCS 4-9-72
	PUSHJ	P,CVS		; CONVERT TO STRING
	POP	SP,PNAME+1	;*FIRST WORD OF STRING DESCRIPTOR
	POP	SP,PNAME	;*SECOND WORD OF STRING DESCRIPTOR
	EXCH	SP,STPSAV	; RETURN STRING POINTER
	MOVSS	POVTAB+6	;*KEEP ERROR MESSAGES IN SYNCH -- DCS 4-9-72
	PUSHJ	P,STRINS	;*MAKE STRING CONSTANT -- DCS 4-16-72
	MOVEM	PNT,GENLEF+1	;*RECORD RESULTS WHERE WILL BE SEEN
	MOVE	LPSA,GENLEF+2	;*MACRO NAME SEMBLK AGAIN -- DCS 4-16
	HRLM	PNT,%TLINK(LPSA);*FILL IN THE REAL GUY -- DCS 4-16
NOCNST:	SOS	LEVEL
	PUSHJ	P,FREBUK	;RETURN UP
	JRST	CLRSET		;CLEAR BITS

↑SWDLM: SKIPN	SWBODY		; NEED TO SWAP MACRO BODY DELIMITERS?
	POPJ	P,		; NO, RETURN
	HRROI	TEMP,LOCMBD+1	; GET RESTORING ADDRESS
	POP	TEMP,CURMED	; RESTORE START DELIMITER
	POP	TEMP,CURMBG	; RESTORE END DELIMITER
	SETZM	SWBODY		; RESET SWITCH DELIMITERS FLAG
	POPJ	P,		; RETURN

↑SETDLM: QPUSH(LOKDLM,DLMSTG)	; SAVE CURRENT DLMSTG VALUE
	SKIPE	REQDLM		; SPECIAL DELIMITER MODE?
	SETOM	DLMSTG		; YES, POSSIBLY LOOKING FOR DELIMITED STRING
	POPJ	P,		; RETURN

↑OFFDLM: QPOP(LOKDLM,DLMSTG)	; CEASE LOOKING FOR DELIMITED STRING
	POPJ	P,		; RETURN

↑ENDMAC: MOVE	TEMP,GENLEF+1	; GET MACRO BODY SEMBLK
	EXCH	SP,STPSAV	; GET STRING POINTER
	PUSH	SP,$PNAME(TEMP) ; FIRST WORD OF STRING DESCRIPTOR
	PUSH	SP,$PNAME+1(TEMP) ; SECOND WORD OF STRING DESCRIPTOR
	PUSH	SP,[XWD 0,2]	; LENGTH OF FOLLOWING STRING
	PUSH	SP,[POINT 7,[BYTE (7) 177 0]] ; END OF MACRO STRING
	PUSHJ	P,CAT		; CONCATENATE
	MOVE	TEMP,GENLEF+1	; GET MACRO BODY SEMBLK
	POP	SP,$PNAME+1(TEMP) ; SECOND WORD OF STRING DESCRIPTOR
	POP	SP,$PNAME(TEMP) ; FIRST WORD OF STRING DESCRIPTOR
	EXCH	SP,STPSAV	; RETURN STRING POINTER
	POPJ	P,		; RETURN

↑SWPON:	SETOM	SWCPRS		; SWITCHING PARSERS IS ALLOWED
	POPJ	P,		; RETURN

DSCR STCAT
PRO STCAT
DES Converts a macro body to a string.
 CVMS(macname).  If called with a macro name and a parameter list, then 
 the parameters are ignored and a suitable error message is emitted.
⊗

↑STCAT: MOVE	LPSA,GENLEF		; PREPARE TO LOOK UP THE STRING 
	HLRZ	LPSA,%TLINK(LPSA)	;  AND ENTER IT IN THE SYMBOL 
	MOVE	TEMP,$PNAME(LPSA)	;  TABLE IF NOT ALREADY THERE.
	SUBI	TEMP,2			; THE ONLY DIFFERENCE BETWEEN THE 
	MOVEM	TEMP,PNAME		;  STRING AND THE MACRO BODY IS 
	MOVE	TEMP,$PNAME+1(LPSA)	;  THAT THE STRING DOES NOT HAVE 
	MOVEM	TEMP,PNAME+1		;  177-0 AT ITS END.
	MOVE	LPSA,STRCON		;
	MOVEW	HSPNT,HPNT		;
	PUSHJ	P,SHASH			;
	SKIPE	LPSA,NEWSYM		;
	JRST	NOENTR			;
	PUSH	P,BITS			;
	MOVE	TEMP,[XWD CNST,STRING]	;
	MOVEM	TEMP,BITS		;
	PUSHJ	P,ENTERS		;
	POP	P,BITS			;
	MOVE	LPSA,NEWSYM		; SET THE SEMANTIC STACK ENTRY TO 
NOENTR:	MOVEM	LPSA,GENRIG		;  THE SEMBLK ADDRESS OF THE STRING.
	TLZ	FF,NOMACR		; TURN MACRO EXPANSION BACK ON
	POPJ	P,			;


DSCR DCLINT
PRO DCLINT
DES This routine is used to process a DECLARATION(varname) command which looks 
  up the varname in the symbol table and returns an integer having the value of 
  the $TBITS entry in the symbol table.  If the variable has not been declared, 
  then a zero is returned.  Note that macro names are not expanded here.  Also,
  turn off the OWN bit if LPARRAY or SBSCRP are on and TOPLEV ∧¬[XWD EXTRNL,GLOBL].
⊗

↑DCLINT: SKIPE	A,GENLEF		; GET $TBITS VALUE IF DECLARED - ZERO 
	MOVE	A,$TBITS(A)		;  OTHERWISE.
	TLNN	A,SBSCRP		; TURN OFF OWN BIT IF LPARRAY OR SBSCRP AND 
	TRNE	A,LPARRAY		;  TOPLEV ∧¬[XWD EXTRNL,GLOBL].
	TLNN	FF,TOPLEV		;
	JRST	MKINT1			;
	TDNN	A,[XWD EXTRNL,GLOBL]	;
	TLZ	A,OWN			;
MKINT1:	TLZ	FF,NOMACR		; TURN MACRO EXPANSION BACK ON
MKINT2:	PUSHJ	P,CREINT		; CREATE INTEGER CONSTANT SEMBLK
	MOVEM	PNT,GENRIG		; SET THE SEMANTIC STACK ENTRY TO 
					;  THE SEMBLK ADDRESS OF THE NUMBER.
	POPJ	P,			;


DSCR SPRZER, XOWST1, VALST1, HELAR3, HELST1, TYPST1, RSTST1, MKINT
PRO SPRZER, XOWST1, VALST1, HELAR3, HELST1, TYPST1, RSTST1, MKINT
DES These routines are used to process the CHECK_TYPE command which takes as an 
  argument a declaration and forms a word containing the apporopriate bits in 
  SPRBTS.  
SPRZER	Zeroes SPRBTS.
XOWST1	Gets bits corresponding to @XO.
VALST1	Gets bits corresponding to @VAL.
HELAR3	Gets the LPARRAY bit.
HELST1	Gets the ITEM or ITEMVAR bits.
TYPST1	Gets the @ALGLP bit.
RSTST1	Gets the remaining bits (i.e. PROCED, RES, BILTIN, DEFINE, SBSCRP, and 
	LPARRAY for a LPARRAY declaration.
MKINT	Creates an integer out of the SPRBTS value and places it on the stack.
⊗

↑SPRZER: SETZM	SPRBTS			;
	SETOM	NODFSW			; NO DEFINE TRIGGERING WHILE IN CHECK_TYPE.
	POPJ	P,			;

↑XOWST1: SKIPA	A,XOTAB(B)		;
↑VALST1: MOVE	A,VALTAB(B)		;
	JRST	ENDFRM			;

↑HELAR3: MOVEI	A,LPARRAY		;
	IORM	A,SPRBTS		;
↑HELST1:
↑TYPST1: SKIPA	A,TYPTAB(B)		;
↑RSTST1: MOVE	A,CHKTAB(B)		;
ENDFRM:	IORM	A,SPRBTS		;
	POPJ	P,			;

↑MKINT:	SETZM	NODFSW			; ALLOW DEFINE TRIGGERING TO HAPPEN AGAIN.
	MOVE	A,SPRBTS		;
	JRST	MKINT2			; MAKE AN INTEGER AND PLACE IT ON THE STACK.


DSCR FFPUSH, FFPOP
PRO FFPUSH, FFPOP
DES These rotines are used to save and restore the DEFLUK bit of FF on a QSTACK 
  pointed to by DEFDLM.  This is necessary due to compile-time variables whose
  definition may cause other  macros to be called.  DEFLUK is used to indicate
  that a macro body is about to be scanned or a set of actual parameters to a 
  macro are about to be scanned.
FFPUSH	Saves the DEFLUK bit of FF on a QSTACK pointed to by DEFDLM (actually save
	the entire value of FF).
FFPOP	Restores the DEFLUK bit of FF from the QSTACK pointed to by DEFDLM.
⊗

↑FFPUSH: MOVEI	LPSA,DEFDLM		; GET QSTACK POINTER
	MOVE	A,FF			; A CONTAINS ITEM TO BE PUSHED IN QSTACK
	TLO	FF,DEFLUK		; TURN ON DEFLUK BIT IN FF
	JRST	BPUSH			; PUSH IN QSTACK

↑FFPOP:	MOVEI	LPSA,DEFDLM		; GET STACK POINTER
	PUSHJ	P,BPOP			; POP TOP OF QSTACK INTO A
	TLZ	FF,DEFLUK		; RESTORE DEFLUK BIT OF FF TO PREVIOUS VALUE
	TLNE	A,DEFLUK		;
	TLO	FF,DEFLUK		;
	POPJ	P,			;


DSCR DLMPSH, DLMPOP
PRO DLMPSH, DLMPOP
DES These routines are used to save and restore the DEFLUK bit of FF and the value
  of the  DLMSTG flag after encountering the DEFINE reserved word and after
  encountering  the = sign in a macro definition.  This is necessary so that macro
  names will  be properly entered in the symbol table.
DLMPSH	Saves the current value of DLMSTG and sets it to zero.  Also saves the
	current value of the DEFLUK bit of FF and sets it to zero.
DLMPOP	Restores the value of DLMSTG from the stack.  Also restores the DEFLUK bit 
	of FF.
⊗

↑DLMPSH: QPUSH(LOKDLM,DLMSTG)		; SAVE DLMSTG
	SETZM	DLMSTG			; DON'T LOOK FOR DELIMITED STRINGS
	MOVEI	LPSA,DEFDLM		; GET STACK POINTER
	MOVE	A,FF			;
	TLZ	FF,DEFLUK		; STRINGS SCANNED IN NON-MACRO MODE
	JRST	BPUSH			; PUSH IN QSTACK

↑DLMPOP: QPOP(LOKDLM,DLMSTG)		; RESTORE DLMSTG
	JRST	FFPOP			; RESTORE DEFLUK


DSCR CPSHBT, CPOPBT, DPSHBT, DPOPBT
PRO CPSHBT, CPOPBT, DPSHBT, DPOPBT
DES These routines are used to save and restore bits before and after conditional 
  compilation and macro definitions.  This enables declarations to be interrupted 
  without having the partially accumulated BITS value destroyed when expressions 
  are looked up or string constants created.  
CPSHBT	Saves current BITS value during conditional compilation.
CPOPBT	Restores the value of BITS after conditional compilation.
DPSHBT	Saves current BITS value during a macro definition.
DPOPBT	Restores the value of BITS after a macro definition.  
⊗

↑CPSHBT: QPUSH(CBTSTK,BITS)		;
	SETZM	BITS			;
	POPJ	P,			;

↑CPOPBT: QPOP(CBTSTK,BITS)		;
	POPJ	P,			;

↑DPSHBT: QPUSH(DBTSTK,BITS)		;
	SETZM	BITS			;
	POPJ	P,			;

↑DPOPBT: QPOP(DBTSTK,BITS)		;
	POPJ	P,			;	


DSCR CPSHEN, CPSHEY, CPOPET
PRO CPSHEN, CPSHEY, CPOPET
DES These routines are used to allow parser switching in the bodies of WHILEC, 
  CASEC, FORC, and FORLC statements.  This enables one to conditionally compile 
  these bodies.  The routines serve to set and reset a flag which is kept in a 
  QSTACK pointed at by ENDCTR.  This flag indicates whether parser switching 
  should occur when an ENDC is seen (i.e. if it is terminating a WHILEC, CASEC, 
  FORC, or FORLC body, then no triggering should occur).
CPSHEN	Pushes a -1 on the QSTACK indicating that an ENDC seen with this value 
	on top of the QSTACK is not to serve as a parser switching trigger.  
CPSHEY	Pushes a zero on the QSTACK indicating that an ENDC seen with this value on 
	the top of the QSTACK is to serve as a parser switching trigger.
CPOPET	Pops the QSTACK pointed to by ENDCTR when one is done with a particular 
	ENDC parser switching trigger mode.
⊗

↑CPSHEY: TDZA	A,A			;
↑CPSHEN: SETOM	A			;
	QPUSH(ENDCTR)			;
	POPJ	P,			;

↑CPOPET: QPOP(ENDCTR)			;
	POPJ	P,			;
DSCR LETSET, LETENT
PRO LETSET LENENT
DES EXECS for syntax
 LET ident=<reserved word>, .... , ... ;
 The semantics of the reserved word is copied into the identifier.
 This mechanism could be expanded to allow synonymating idents with
  characters, so that characters could be returned to the letter set,
  and to allow run-time expressions (LET FOO=1, FOO=FOO+1).

LTR:	@IDD		EXEC LETSET SCCAN 2 ¬LT1 #QCON
LT1:	SG = @RESERVED →→ EXEC LETENT SCAN ....

⊗
↑LETSET: SETZM	BITS		;NO BITS NOW
	PUSHJ	P,ENTERS		;ENTER IT RANDOMLY
	SKIPN	LPSA,NEWSYM		;BE CAREFUL
	 ERR	 <DRYROT>
	MOVEM	LPSA,GENRIG		;RESULT, SO TO SPEAK
	TLZ	FF,NOMACR		;TURN OFF SPECIAL
	POPJ	P,			;DONE


↑LETENT: SKIPE GENLEF
	 ERR	 <SYNONYMS FOR RESERVED WORDS ONLY>
	MOVE	TEMP,PARLEF		;BITS
	TLO	TEMP,RES		;RESET RESERVED BIT
	MOVE	PNT,GENLEF+2		;NEW NAME FOR SAME THING
	MOVEM	TEMP,$TBITS(PNT)	;MAKE THEM EQUIVALENT
	POPJ	P,			;RETURN

DSCR TWCOND,SWICHP,SWPOFF,PSWICH,OKEOF
PRO TWCOND SWICHP SWPOFF PSWICH OKEOF
DES EXECS for conditional assembly
TWCOND is responsible for indicating on the parse stack whether or not a
	condition is true.  In the productions one assumes the condition 
	is true, and thus if it is false then TWCOND will change the parse
	stack token to false.
SWICHP switches parsers from the conditional parser back to the main sail 
	parser.  This entails saving the processor descriptor of the 
	conditional parser (semantic stack pointer, parse stack pointer,
	production stack pointer, and number of calls to scanner that 
	have still not yet been processed), as well as restoring the 
	processor descriptor of the main sail parser.
PSWICH does the reverse of SWICHP when one wants to switch from the main 
	sail parser to the conditional parser.  The actual code for this
	can be found in SYM at the end of the identifier scan routine.
	Note that this is not a procedure but it is described  here for
	the sake of completeness.
SWPOFF turns the switchparser switch (SWCPRS) off when one would want to 
	switch to a parser that is already executing.  This would typically 
	happen when one has evaluated a condition to be false; since the 
	conditional parser would now be in control and is in the process 
	of swallowing characters until IFC ... ELSEC ... ENDC and nested 
	occurrences are eliminated and an ENDC or ELSEC appears unnested.
	Thus what one has is a flag that says don't interrupt the con-
	ditional parser.
OKEOF	Is not strictly a part of conditional assembly.  It was added to
	allow parser to see EOF as a token on some occasions.  This allows
	code after DONES to scan to EOF, listing rest of file (final END
	bug).  Will also lead the way to more parsers, like the conditional
	parser.  OKEOF simply turns on SCNWRD's EOFOK bit...SCANNER
	then returns EOF token when appropriate.
⊗
↑TWCOND: GETSEM (1)		; GET SEMANTICS OF ARITHMETIC EXPRESSION
	MOVE	TEMP,%CFLS1	; ASSUME COMPARE FALSE (0 OR NOT CONSTANT)
	TLNE	TBITS,CNST	; CONSTANT?
	SKIPN	$VAL(PNT)	; ZERO?
	MOVEM	TEMP,PARRIG	; YES, CHANGE FROM CTRU1 TO CFLS1
	POPJ	P,		; RETURN


↑SWPOFF: SETZM	SWCPRS		; TURN OFF SWITCH PARSEERS FLAG
	POPJ	P,		; RETURN

↑OKEOF:	MOVE	TEMP,SCNWRD	;TURN ON EOFOK FOR SCANNER (SCANNER ALWAYS
	TLO	TEMP,EOFOK	; TURNS IT OFF, SO PRODUCTIONS MUST TURN
	MOVEM	TEMP,SCNWRD	; IT ON EACH TIME (PROBABLY NOT NECESSARY,
	POPJ	P,		; BUT SCANNER SOMETIMES HAS TO TURN IT OFF
				; UNDER CURRENT IMPL, SO...)

↑SETFL:	MOVE	LPSA,GENLEF+2	; MACRO PSEUDONYM SEMBLK
	MOVE	LPSA,$VAL2(LPSA) ; ADDRES OF ACTUAL PARAMETER RING SEMBLK
	MOVEM	LPSA,DEFRN2	; STORE IT IN DEFRN2
	JRST	SETFL1		; GO CONTINUE PREPARING FOR A MACRO CALL

↑SETFR:	MOVE	LPSA,GENLEF+2	; GET MACRO PSEUDONYM SEMBLK
	PUSHJ	P,MKFRLP	; MAKE A FORC LOOP PARAMETER (I.E. LOOP VAR)
	POP	SP,PNAME+1	; SECOND WORD OF STRING DESCRIPTOR
	POP	SP,PNAME	; FIRST WORD OF STRING DESCRIPTOR
	EXCH	SP,STPSAV	; RETURN STRING POINTER (EXCH IN MKFRLP)
	PUSH	P,VARB		; SAVE VARB AND SET IT TO ZERO SO ENTERS
	SETZM	VARB		;   WILL LINK AS IF ACTUAL MACRO PARAMETER
	TLO	FF,PRMSCN 	; SET GOOD BITS
	PUSHJ	P,FFPUSH	; SAVE DEFLUK BIT OF FF AND TURN IT ON IN FF
	PUSH	P,BITS		; SAVE THESE
	MOVE	B,[XWD CNST,STRING] ; STRING CONSTANT
	MOVEM	B,BITS		; PREPARE FOR ENTERS
	MOVE	LPSA,STRCON	; BUCKET SEMBLK FOR SHASH
	PUSHJ	P,SHASH		; GET HASH BUCKET
	PUSHJ	P,ENTERS
	MOVE	TEMP,NEWSYM	; GET PARAMETER SEMBLK
	MOVEM	TEMP,DEFRN2	; SET UP ACTUAL PARAMETER RING
	POP	P,BITS		; RESTORE BITS
	POP	P,VARB		; RESTORE VARB
	TLZ	FF,PRMSCN 	; RESET GOOD BITS
	PUSHJ	P,FFPOP		; RESTORE DEFLUK BIT IN FF
SETFL1: EXCH	SP,STPSAV	; GET STRING POINTER
	MOVE	TEMP,GENLEF+1	; GET FORC OR FORLC BODY STRING SEMBLK
	PUSH	SP,$PNAME(TEMP)	; FIRST WORD OF STRING DESCRIPTOR
	PUSH	SP,$PNAME+1(TEMP) ; SECOND WORD OF STRING DESCRIPTOR
	PUSHJ	P,CTENDC	; APPEND COND COMP ENDING (" ENCD 177 0")
	MOVE	LPSA,GENLEF+2	; LPSA MUST CONTAIN MACRO PSEUDONYM SEMBLK
	JRST	PRCAL1		; GO CONTINUE PREPARING FOR A MACRO CALL

↑SETCSE: EXCH	SP,STPSAV	; GET STRING POINTER
	MOVE	TEMP,GENLEF+1	; GET THE CASEC BODY STRING SEMBLK
	PUSH	SP,$PNAME(TEMP)	; FIRST WORD OF STRING DESCRIPTOR
	PUSH	SP,$PNAME+1(TEMP) ; SECOND WORD OF STRING DESCRIPTOR
	PUSHJ	P,CTENDC	; APPEND COND COMP ENDING (" ENDC 177 0")
	MOVE	LPSA,GENLEF+3	; LPSA MUST CONTAIN MACRO PSEUDONYM SEMBLK
	JRST	PRECAL		; GO CONTINUE PREPARING FOR A MACRO CALL


↑SETWHL: EXCH	SP,STPSAV	; GET STRING POINTER
	PUSH	SP,[XWD 0,4]	; LENGTH OF FOLLOWING STRING
	PUSH	SP,[POINT 7,[ASCII "IFC "]] ; FIRST WORD OF PSEUDO MACRO
	MOVE 	TEMP,GENLEF+3	; GET THE CONDITION STRING SEMBLK
	PUSH	SP,$PNAME(TEMP) ; FIRST WORD OF STRING DESCRIPTOR
	PUSH	SP,$PNAME+1(TEMP) ; SECOND WORD OF STRING DESCRIPTOR
	PUSHJ	P,CAT		; CONCATENATE
	PUSH	SP,[XWD 0,7]	; LENGTH OF FOLLOWING STRING
	PUSH	SP,[POINT 7,[ASCII " THENC "]] ; END OF CONDITION
	PUSHJ	P,CAT		; CONCATENATE
	FREBLK	GENLEF+3	; FREE THE CONDITIONS SEMBLK
	MOVE	TEMP,GENLEF+1	; GET THE PSEUDO MACRO BODY STRING SEMBLK
	PUSH	SP,$PNAME(TEMP)	; FIRST WORD OF STRING DESCRIPTOR
	PUSH	SP,$PNAME+1(TEMP) ; SECOND WORD OF STRING DESCRIPTOR
	PUSHJ	P,CAT		; CONCATENATE
	PUSHJ	P,CTENDC	; APPEND COND COMP ENDING (" ENDC 177 0")
	MOVE	LPSA,GENLEF+2	; LPSA MUST CONTAIN MACRO PSEUDONYM SEMBLK
PRECAL:	SETZM	DEFRN2		; WHILEC AND CASEC HAVE NO PARAMETER RINGS
PRCAL1: HLRZ	TEMP,%TLINK(LPSA) ; SEMBLK OF PSEUDO MACRO BODY
	POP	SP,$PNAME+1(TEMP) ; FIRST WORD OF STRING DESCRIPTOR
	POP	SP,$PNAME(TEMP) ; SECOND WORD OF STRING DESCRIPTOR
	EXCH	SP,STPSAV	; RETURN STRING POINTER
	MOVE	TBITS2,SCNWRD	; SYNCH SCAN COMTROL WORD
	JRST	ACPMED		; GO PREPARE FOR A MACRO CALL (IN SCANNER)

↑CTENDC: PUSH	SP,[XWD 0,8]	; LENGTH OF FOLLOWING STRING
	PUSH	SP,[POINT 7,[BYTE (7) " ","E","N","D","C"," ",177,0]] ; END 
				;   OF PSEUDO MACRO BODY
	JRST	CAT		; CONCATENATE

↑SWICHM: MOVE	LPSA,GENLEF+2	; PSEUDO MACRO NAME SEMBLK
	JRST	CONTXT		; PREPARE FOR WHILEC BODY SCAN

↑SWCHFR: MOVE	LPSA,GENLEF	; PSEUDO MACRO NAME SEMBLK
	PUSHJ	P,MKFRLP	; GET NEW FORC LOOP PARAMETER
	MOVE	LPSA,DEFRNG	; SEMBLK OF PSEUDO MACRO PARAMETER
	POP	SP,$PNAME+1(LPSA) ; SECOND WORD OF STRING DESCRIPTOR
	POP	SP,$PNAME(LPSA) ; FIRST WORD OF STRING DESCRIPTOR
	EXCH	SP,STPSAV	; RETURN STRING POINTER (EXCH IN MKFRLP)
↑SWCHFL: MOVE	LPSA,GENLEF	; PSEUDO MACRO NAME SEMBLK
	JRST	CONTXT		; PREPARE FOR FORC OR FORLC BODY SCAN

↑MKFRLP: EXCH	SP,STPSAV	; GET STRING POINTER
	PUSH	P,$VAL2(LPSA)	; CURRENT VALUE OF FORC LOOP PARAMETER
	PUSHJ	P,CVS		; CONVERT TO STRING
	PUSH	SP,[XWD 0,2]	; LENGTH OF FOLLOWING STRING
	PUSH	SP,[POINT 7,[BYTE (7) 177,0]] ; MACRO PARAMETER ENDING
	JRST	CAT		; CONCATENATE

↑GTSTRT: PUSHJ	P,GETCVI	; CONVERT FORC STARTING VALUE TO INTEGER
	MOVEM	PNT,$VAL2(LPSA)	; STORE IN $VAL2 OF MACRO PSEUDONYM SEMBLK
	POPJ	P,		; RETURN

↑GTSTEP: PUSHJ	P,GETCVI	; CONVERT FORC STEP TO INTEGER
	MOVEM	PNT,$DATA(LPSA)	; STORE IN $DATA OF MACRO PSEUDONYM SEMBLK
	POPJ	P,		; RETURN

↑GETERM: PUSHJ	P,GETCVI	; CONVERT FORC END VALUE TO INTEGER
	MOVE	LPSA,GENLEF+2	; SEMANTICS OF MACRO PSEUDONYM
	MOVEM	PNT,$DATA2(LPSA) ; STORE IN $DATA2 OF MACRO PSEUDONYM SEMBLK
	MOVE	PNT,$VAL2(LPSA) ; GET FORC STARTING VALUE
	PUSHJ	P,TWNUM1	; GO CHECK IF STARTING VALUE IS OUT OF RANGE
	CAMN	PNT,%CFLS1	; STARTING VALUE OUT OF RANGE?
	PUSHJ	P,FFPUSH	; NO
	POPJ	P,		; RETURN

↑GETCVI: MOVE	PNT,GENLEF+1	; STRING SEMBLK TO BE CONVERTED TO INTEGER
	GENMOV(CONV,INSIST!GETD,INTEGR) ; CONVERT
	MOVE	PNT,$VAL(PNT)	; GET INTEGER VALUE
	MOVE	LPSA,GENLEF+2	; ADDRESS OF MACRO PSEUDONYM SEMBLK
	POPJ	P,		; RETURN

↑TWNUM:	MOVE	LPSA,GENLEF+1	; ADDRESS OF FORC MACRO PSEUDONYM SEMBLK
	MOVE	PNT,$DATA(LPSA)	; FORC LOOP STEP VALUE
	ADDB	PNT,$VAL2(LPSA)	; INCREMENT CURRENT FORC LOOP VALUE
↑TWNUM1: SUB	PNT,$DATA2(LPSA) ; SUBTRACT FORC LOOP END VALUE
	SKIPL	$DATA(LPSA)	; STEP NEGATIVE?
	MOVN	PNT,PNT		; NO, NEGATE STEP
	JUMPGE	PNT,GPOPJ	; DONE WITH LOOP IF POSITIVE
	MOVE	PNT,%CFLS1	; TWIDDLE TO INDICATE END OF FORC LOOP
	MOVEM	PNT,PARRIG+1	; SET PARSE STACK TO TWIDDLED VALUE
GPOPJ:	POPJ	P,		; RETURN

↑GETACT: MOVE	LPSA,GENLEF+2	; ADDRESS OF FORLC MACRO PSEUDONYM SEMBLK
	HRLZI	TEMP,1		; SET PARAMETER COUNT TO ZERO
	MOVEM	TEMP,$VAL(LPSA)	; STORE IT (incredibly imaginative comment)
	MOVE	TBITS2,SCNWRD	; SYNCH SCAN CONTROL WORD
	PUSHJ	P,SCNACT	; SCAN A LIST OF ACTUAL PARAMETERS WHICH
				;   CAN HAVE A SPECIAL DELIMITER DECLARATION
				;   (IN SCANNER)
	MOVE	TEMP,DEFRN2	; DEFRN2 POINTS TO RING OF ACTUAL PARAMETERS
	MOVEM	TEMP,$VAL2(LPSA) ; STORE IT IN $VAL2 OF FORLC MACRO PSEUDO-
				;   NYM SEMBLK SO THAT THE MACRO BODY CAN BE
				;   PROPERLY SCANNED FOR PARAMETER SUBSTITU-
				;   TIONS
	POPJ	P,		; RETURN

↑TWACT:	MOVE	LPSA,DEFRNG	; GET FORLC ACTUAL PARAMETER RING
	HRRZ	LPSA,%RVARB(LPSA) ; GET NEXT PARAMETER IF NOT DONE
	JUMPN	LPSA,.+4	; FORLC ACTUAL PARAMETER LIST EXHAUSTED
	MOVE	LPSA,%CFLS1	; TOKEN TO BE TWIDDLED
	MOVEM	LPSA,PARRIG+1	; SET PARSE STACK STRAIGHT
	POPJ	P,		; RETURN
	FREBLK	DEFRNG		; FREE PREVIOUS PARAMETER SEMBLK
	MOVEM	LPSA,DEFRNG	; SET DEFRNG TO CURRENT ACTUAL PARAMETER
	POPJ	P,		; RETURN

↑TWCSCN: MOVE	TEMP,GENLEF+3	; ADDRESS OF CASEC MACRO PSEUDONYM SEMBLK
	SOSE	$VAL2(TEMP)	; RIGHT CASEC?
	POPJ	P,		; NO, RETURN
	PUSHJ	P,CPSHEN	; SET ENDC DOESN'T TRIGGER A PARSER SWITCH FLAG
	SETOM	SWCPRS		; PARSER SWITCHING IS OK (I.E. IFC IN BODY OF CASEC
				;  TO BE EXECUTED)
	MOVE	TEMP,%CTRU1	; TWIDDLE SO NEXT CASEC WILL BE SCANNED
	MOVEM	TEMP,PARRIG	; SET PARSE STACK STRAIGHT
	POPJ	P,		; RETURN

↑FREMBN: MOVE	A,GENLEF+2	; GET RID OF FORMAL PARAMETER LIST TO FORC 
	MOVE	LPSA,$ACNO(A)	;   AND FORLC WHICH ARE NEVER EXECUTED AS 
	PUSHJ	P,KILLST	;   WELL AS RESTORE THE PROPER LEVEL AND 
	MOVE	LPSA,GENLEF+2	;   VARB
	PUSHJ	P,CLENUP	;
	JRST	FRMBFF		;
↑FREMBF:SKIPA	LPSA,GENLEF	; FORC, AND FORLC MACRO PSEUDONYM
↑FREMBW: MOVE	LPSA,GENLEF+2	; WHILEC MACRO PSEUDONYM
				;   SEMBLK ADDRESS
FRMBFF:	HLRZ	TEMP,%TLINK(LPSA) ; PSEUDO MACRO BODY SEMBLK ADDRESS
	FREBLK	TEMP		; FREE THE PSEUDO MACRO BODY SEMBLK
	FREBLK			; FREE THE MACRO PSEUDONYM SEMBLK
	POPJ	P,		; RETURN

↑FRMBCE: PUSHJ	P,FRMBCF	; DELETE SEMBLK OF BODY OF LAST FALSE CASEC
	MOVE	LPSA,GENLEF+3	; CASEC SEMBLK ADDRESS
	SKIPLE	$VAL2(LPSA)	; CHECK IF NONE OF THE CASEC CASES WERE
	PUSHJ	P,CLENUP	;   EXECUTED; IF SO RESTORE VARB AND LEVEL
	FREBLK	GENLEF+3	; DELETE CASEC PSEUDONYM SEMBLK
	POPJ	P,		; RETURN

↑FRMBCF: GETSEM(1)		; GET SEMANTICS OF LAST FALSE CASEC
	TRNN	TBITS,STRING	; DON'T DELETE IF NOT A STRING SINCE A CVS
				;   IS ONLY DONE FOR TRUE CASEC (IN DFENT)
				;   OTHERWISE A GOOD CONSTANT MAY BE DELETED
	POPJ	P,		; NOT A STRING, RETURN
	FREBLK	GENLEF+1	; DELETE SEMBLK OF BODY OF LAST FALSE CASEC
	POPJ	P,		; RETURN

↑FRMBCT: MOVE	LPSA,GENLEF+2	; LAST TRUE CASEC BODY SEMBLK
	HLRZ	TEMP,%TLINK(LPSA) ; LAST TRUE CASEC BODY SEMBLK
	FREBLK	TEMP		; DELETE SEMBLK OF BODY OF LAST TRUE CASEC
	HRRZS	%TLINK(LPSA)	; MACRO PSEUDONYM NO LONGER HAS A BODY LINK
	POPJ	P,		; RETURN

CLENUP:	MOVE	TEMP,$ADR(LPSA)	; RESTORE VARB AND LEVEL WHEN CASEC, FORC, 
	MOVEM	TEMP,VARB	;   AND FORLC ARE NOT EXECUTED.  EXPECTS 
	SOS	LEVEL		;   LPSA TO CONTAIN THE ADDRESS OF THE 
	JRST	FREBUK		;   RELEVANT SEMBLK

↑TMACIN: SKIPE	PRSCON		; DETERMINE WHICH PARSER IS CURRENTLY SUSPENDED AND
	SKIPA	A,SSCWSV	;  GET A POINTER TO ITS SCNWRD STACK.  THIS IS USED
	MOVE	A,CSCWSV	;  TO SET THE MACIN BIT IN SYNCH WITH MACROS THAT 
	POPJ	P,		;  MIGHT HAVE ENDED WHILE THE SUSPENDED OR MOST 
				;  RECENTLY ACTIVATED PARSER WERE INACTIVE.  

↑TOMACN: PUSHJ	P,TMACIN	; CHANGE MACIN BIT OF PARSER TO BE RESUMED TO 
	LDB	TBITS2,[POINT 1,SCNWRD,6] ;  THE VALUE OF THE MACIN BIT OF THE
	DPB	TBITS2,[POINT 1,(A),6] ;  CURRENT PARSER.
	POPJ	P,		;

↑FRMACN: PUSHJ	P,TMACIN	; CHANGE THE MACIN BIT OF THE CURRENT PARSER TO 
	LDB	TBITS2,[POINT 1,(A),6] ;  THE VALUE OF THE MACIN BIT OF THE SUSPENDED 
	DPB	TBITS2,[POINT 1,SCNWRD,6] ;  PARSER.
	POPJ	P,		;
	SUBTTL	EXECS for Entry Declaration
DSCR ENTMAK, ENTOUT
PRO ENTMAK ENTOUT
DES EXECS for syntax
 ENTRY id1, id2, ...., ... ;
 Must appear before initial BEGIN
SEE comment below DSCR for details
⊗

Comment ⊗ ENTRY code -- has two functions:
	1.  Denote that this compilation is not the main program
but a collection of separately compiled procedures.
	2. 	Create an entry block so that these programs
can be loaded from a library.

The syntax:

BB0:	ENTRY →				SCAN 2  ¬ ENT
	BEGIN → BLAT BEGIN		EXEC ENTOUT DWN SCAN ¬DS

...

ENT:	@I ,	→			EXEC ENTMAK SCAN 2 ¬ ENT
	@I ;	→			EXEC ENTMAK SCAN    ¬ BB0

⊗

NOGAG <
↑ENTMAK: TLZE	FF,MAINPG		;NO STARTING ADDRESS FOR THIS PROGRAM
	 HLLZS	 ENTTAB			;RESET FIRST TIME IN
	HRL	LPSA,PNAME	;COUNT
	HRR	LPSA,PNAME+1		;BYTE POINTER FOR ENTRY SYMBOL
	PUSHJ	P,RAD52			;MAKE RADIX50 FOR ENTRY
	AOS	B,ENTTAB		; → NEXT ENTRY
	HRRZS	B			;CLEAR LEFT HALF
	MOVEM	A,ENTTAB+1(B)		;TO ENTRY TABLE
	CAIGE	B,22		;FULL?
	 POPJ	 P,			;NO

↑ENTOUT: 
	MOVEI	B,ENTTAB		;PUT OUT BLOCK IF THERE IS
	TLNN	FF,MAINPG		; ONE
	 JRST	 GBOUT
	POPJ	P,			;THERE IS NONE FOR SURE

>;NOGAG
GAG<
↑ENTMAK:
↑ENTOUT:
	POPJ	P,			;NO WAY IN "GOGOL"
>;GAG

SUBTTL	EXECS for Storage Allocation at end of Procedure

DSCR ALOT
DES Allocation routine -- called by PRUP and DONES EXECS, allocates
 storage, issues fixups and symbols for all locals in Procedure
 (outer Block)
PAR VARB-rings on BLKLIS Qstack
RES ALIMS, ALOCALS, SLIMS, SLOCALS, LLIMS, LLOCALS as described
 in subsequent comments
SEE comment below DSCR for details
⊗

COMMENT ⊗
	This is the code invoked to allocate space for variables on the
VARB ring.  Symbols are also output to the loader, for use by DDT and
the world.  As each block is closed, the portion of the VARB ring developed
for that block is saved by a pointer in the table BLKLIS, and the count
BLKIDX is incremented.  It is the job of this code to run through all
the VARB information stored on this list, and allocate.

There is a bit in FF, called ALLOCT which determines whether
this code actually allocates storage, or merely counts things.
The counts are necessary for deciding how exit and entry code for
recursive procedures should be generated.  These counts are:
ALOCAL (arithmetic stack locals) and SLOCAL (string stack
locals).  FIRSYM and LSTSYM point to the first and last symbols allocated.

⊗
ZERODATA (VARIABLE-ALLOCATION VARIABLES)

COMMENT ⊗
ALIMS -- [Semantics of last,Semantics of first] -- set up by ALLOT
    to indicate the range of non-string variables allocated. This
    is used by PROCED after the first (non-allocating) call on ALLOT
    and before the second (allocating) call, to set up saving 
    and restoring instructions (BLT) for these variables for 
    recursive Procedures.  The non-allocating run allows these extra
    instructions to be inserted before fixed locations are assigned
    to the variables (see ALLOT's DSCRs).
⊗
↑↑ALIMS: 0

;ALOCALS -- a count of the number of non-string locals -- set up
;   for the same reasons given above for ALIMS
↑↑ALOCALS: 0

;BLKCNT -- temp used when outputing symbol names -- see DOSYM's
;    DSCR for details
↓BLKCNT: 0

;FIRSYM -- Semantics of first variable allocated by ALOT -- used to
;    set up ALIMS, SLIMS, LLIMS
↓FIRSYM: 0

;LLIMS -- ALIMS-like thing for sets -- ALIMS includes LLIMS in its
;    range -- used to put together Set Link Blocks -- see ALLOT
↓LLIMS:	0

;LLOCAL -- ALOCAL-type count of number of Sets this Procedure
↓LLOCAL: 0

;LSTSYM -- Semantics of last variable allocated by ALOT -- used to
;    set up ALIMS, SLIMS, LLIMS
↓LSTSYM: 0

;SLIMS -- ALIMS-like thing for strings.  Used for above-
;    mentioned purposes; also to put together String Link Blocks
;    See ALLOT, LNKOUT
↑↑SLIMS: 0

;SLOCALS -- ALOCALS-type count for # Strings this Procedure
↑↑SLOCALS: 0

ENDDATA

↑ALOT:				;ROUTINE TO HANDLE ALLOCATION
				;OF CORE AND THINGS FOR VARIABLES.
	SETZM	FIRSYM
	TLNN	FF,ALLOCT	;ALLOCATING REALLY?
	 JRST	 ALSYMS		; NO, IGNORE ADCONS THIS TIME AROUND

;ALLOCATE ADDRESS CONSTANTS. INFORMATION ABOUT THEM IS
;SAVED ON THE VARB RING HOMED AT ADRTAB.  SEE PROCED
;FOR DETAILS OF HOW THE ADDRESS CONSTANTS ARE USED.

ADCGO:	HRRZ	LPSA,TPROC	;GET LEVEL OF PROCEDURE WHOSE LOCALS
	LDB	TEMP,PLEVEL	; ARE BEING DEFINED
	MOVEM	TEMP,THSLVL#
	HRRZ	LPSA,ADRTAB	;ADDRESS CONSTANTS.
	JUMPE	LPSA,ALSYMS	;NONE

RADA:	MOVE	SBITS,$SBITS(LPSA)	;IF A TEMP, IT IS IDENTIFIED BY
	TLNN	SBITS,ARTEMP		;ITS SEQUENCE NO, ELSE BY SEMANTIC ADR
	 JRST	 RADAA			;NOT A TEMP

	MOVE	A,$PNAME(LPSA)		;THE ID NO FOR THIS TEMP
	MOVE	PNT,TTEMP		;SEARCH THE TEMP LIST FOR IT
RADLP:	JUMPE	PNT,NOUNLK		;NOT THERE, TRY LATER
	CAMN	A,$PNAME(PNT)		;IS THIS THE RIGHT INFO?
	JRST	RADAB			; YES, PUT OUT ADCON
	HLRZ	PNT,%RVARB(PNT)		;NO, KEEP LOOKING
	JRST	RADLP

RADAA:	HLRZ	PNT,%TLINK(LPSA)	;GET POINTER TO
RADAB:	PUSHJ	P,GETAD		;SEMANTICS OF SYMBOL WHOSE AD IS CONED.
	TLNE	SBITS,CORTMP	;IS THIS A CORE TEMP?
	 JRST	 OKRADA		; YES, PUT OUT THE ADCON
	TLNE	SBITS,ARTEMP
				; ***** BUG TRAP
	 ERR	 <DRYROT -- RADA>,1
	TLNE	TBITS,CNST
	JRST	OKRADA		;EACH WILL APPEAR BUT ONCE
	TDZ	SBITS,[¬LLFLDM] ;GET LEVEL ONLY
	CAMGE	SBITS,THSLVL	;IF ADCON CORRESPONDS TO
	JRST	 NOUNLK		;SOMETHING IN THIS PROC, PUT IT OUT

OKRADA:
NOGAG <
	HRLZ	B,$ADR(LPSA)	;ADCON FIXUP
	JUMPE	B,RADC		;WAS NOT USED.
	HRR	B,PCNT
	PUSHJ	P,FBOUT		;FIXUP FOR THE ADCON.
	HLL	A,$ADR(LPSA)	;TYPE BITS TO INSERT.
	HRRI	A,FXTWO!NOUSAC
	TLNN	TBITS,SBSCRP	;IF ¬SBSCRP ∧ STRING,
	TRNN	TBITS,STRING	; USE 2D WORD FIXUP
	 TRZ	 A,FXTWO	;ELSE REGULAR OLD FIXUP
	PUSHJ	P,EMITER	;USE HIM TO OUTPUT THE WORD.
>;NOGAG
RADC:	PUSHJ	P,URGADR	;REMOVE FROM ADRTAB
	FREBLK	(LPSA)
NOUNLK:	LEFT	,%RVARB,ALSYMS	;LOOP UNTIL DONE.
	JRST	RADA



Comment ⊗
NOW ALLOCATE STORAGE FOR VARIABLES.

When a block has been compiled, the pointer to its block entry (and thus to
its  VARB  ring  of  locals)  is placed in the next free location in BLKLIS
(using BLKIDX QPDP). BLKIDX is cleared at the beginning of  each  procedure
compilation, and the old value is stored. In all that follows, all and only
those blocks whose pointers lie in the current BLKLIS will be processed.

In order to keep things together for BLT'ing on and off the stacks, strings
are allocated first. Then arrays. Then all  else.  The  routine  "ALLO"  is
called  to actually look for things to allocate. It uses the mask set up in
TBITS2.

⊗

ALSYMS:	MOVEI	TBITS2,STRING	;FIRST ALLOCATE STRINGS.
REN <
	PUSHJ	P,LOSET		;SWITCH TO DATA SEGMENT
>;REN
DIS <
	SETZM	CSPOS		;SET STACK	 DISPL=0
>;DIS
	PUSHJ	P,ALLO		;GO DO IT.
	LSH	PNT2,1
	MOVEM	PNT2,SLOCAL	;SAVE COUNT OF STRINGS ALLOCATED.
	MOVEM	A,SLIMS		;LIMITS OF SYMBOLS.FOR STRINGS
DIS <
	MOVE	PNT2,CSPOS	;
	MOVEM	PNT2,SSDIS	;STRING STACK DISPL DUE TO LOCALS
	MOVEI	PNT2,2		;FOR MCSP SIZE
	SKIPE	SIMPSW		;IF SIMPLE
	HRRZI	PNT2,0		;THEN NO MSCP
	MOVEM	PNT2,CSPOS	;SET CNTR
>;DIS
AL1:	SETZM	FIRSYM
	SETZM	LSTSYM		
	MOVEI	TBITS2,SET!LSTBIT	;ALLOCATE SETS FIRST AMONG "ARITHMETICS"
	PUSHJ	P,ALLO
	HRLZM	PNT2,LLOCAL	;FOR SETS ONLY.
	MOVEM	A,LLIMS
	MOVEM	PNT2,ALOCAL	;START LOCAL COUNT FOR ARITHS.
	MOVSI	TBITS2,SBSCRP	;ALLOCATE ARRAYS.
	PUSHJ	P,ALLO
	ADDM	PNT2,ALOCAL	;COUNT OF ARITH. LOCALS.
	MOVEI	TBITS2,-1 ≠ (STRING!LSTBIT!SET)	;ALL OTHERS.
	PUSHJ	P,ALLO
	ADDM	PNT2,ALOCAL	;AND UPDATE LOCAL COUNT
	PUSHJ	P,TMPALO	;ALLOCATE TEMPS.
	ADDM	PNT2,ALOCAL	;AND UPDATE LOCAL COUNT
	MOVE	A,FIRSYM
	HRL	A,LSTSYM
	MOVEM	A,ALIMS		;LIMITS OF ARITH. LOCALS.
DIS <
	MOVE 	PNT2,CSPOS	;PICK UP STACK LOC
	MOVEM	PNT2,ASDIS	;SAVE IT AS ARITH STACK DISPL FOR LOCALS
>;DIS
REN <
	PUSHJ	P,HISET		;BACK TO CODE SEGMENT
>;REN
	TLNN	FF,ALLOCT	;ACTUALLY ALLOCATING ?
	POPJ	P,		;NO -- DONE COMPLETELY.

DIS <
	HRRZ	PNT2,TPROC	;THIS PROCEDURE
	SKIPN	SIMPSW		;IF SIMPLE, NO PD
	PUSHJ	P,PDOUT		;PUT OUT PROC DESC
>;DIS

AL2:	SETZM	TTEMP		;RESTART TEMP LIST.
	SETZM	BLKCNT		;NO BLOCKS LOOKED AT OR ALLOCATED
	QBEGIN	(BLKIDX)	;FIND BOTTOM ELEMENT IN BLKLIM QSTACK
	 JUMPE	 B,CRECHK	; NO SYMBOLS TO ALLOCATE

Comment ⊗

; NOW ISSUE SYMBOLS FOR THIS PROCEDURE

At  procedure  declaration,  and  at  the  beginning of each NAMED block or
compound statement, a count called NMLVL (name level) is  incremented.  Its
current  value  is  stored  in  $VAL2  of  every  block  and NAMED compound
statement. It is also stored in procedure  blocks.  It  is  decremented  at
appropriate times.

When  a  block pointer is placed in BLKLIS (via BLKIDX QPDP), its left half
is 0 if the block has a name, -1 otherwise (depends on higher-LEVELed block
for  name).   A  non-named  block's NMLVL should be the same as that of the
next named block in the list.

Inner blocks appear in BLKLIS preceding outer ones.  DDT  (as  it  happens)
requires  that  symbols for inner blocks appear first. So the algorithm for
symbol allocation is:

      1) Search from BLKLIS bottom to 1st named Block (index→SBITS2)
      2) Put out Block name and level to .REL file
      3) NMLVL of this block to TBITS2
      4) For each BLKLIS entry from current backwards to bottom, 
       or until an entry is found whose NMLVL is lower (outer block)
       that TBITS2, if the Block hasn't been  handled (list entry 0),
       include its symbols in this DDT block on the .REL file.
      5) Search forwards for the next named block (index → SBITS2).
        If one is found, go to step 2.
      6) If some blocks were not handled, it is because the outer block of
      this procedure was not named. Put out procedure name as  block  name,
      and repeat step 3 once more to get the rest of the symbols.
      7) Reset BLKIDX QPDP
⊗

;STEP 1,5 -- FORWARDS SEARCH LOOP
DOSYM:	MOVEM	B,SBITS2	;B GETS CHANGED BY DOSYL1
DOSYML:	MOVE	B,SBITS2	;GET QSTACK PDP FOR FORWARD SEARCH
	QTAKE	(BLKIDX)	;LOOK AT NEXT BLOCK
	 JRST	 DIDSYM		; HAVE LOOKED AT ALL, CHECK FOR REMAINING
	AOS	BLKCNT		;ADD ONE FOR EACH ONE GLIMPSED
	MOVEM	B,SBITS2	;PROTECT THIS QPDP
	JUMPLE	A,DOSYML	;IF NOT NAMED, CONTINUE FORWARD SEARCH
	MOVE	LPSA,A
;STEP 2
	PUSHJ	P,BLBOUT	;ISSUE BLOCK NAME TO .REL FILE
;STEP 3
	HRRZ	TBITS2,$VAL2(LPSA) ;NMLVL (DDT LEVEL) OF THIS BLOCK
	MOVE	B,SBITS2	;BLBOUT CHANGES, MAYBE

;STEP4 -- BACKWARDS SEARCH LOOP
DOSYL1:	QBACK			;NONDESTRUCTIVE POP
	 JRST	 DOSYML		; HAVE ALL BLOCKS, RETURN TO FORWARD SEARCH
	JUMPE	A,DOSYL1	;ALREADY DID THIS ONE
	MOVE	LPSA,A		;BELONGS HERE FOR NOSY ETC.
	HRRZ	TEMP,$VAL2(LPSA);NMLVL OF THIS BLOCK
	CAMLE	TBITS2,TEMP	;IF NEW LEVEL LOWER, DON'T INCLUDE IT,
	 JRST	 DOSYML		; RETURN TO FORWARD SEARCH
	HLRZ	TEMP,B		;GET CURRENT "QSTACK" POINTER
	SETZM	1(TEMP)		;ZERO "POPPED" ENTRY
	SOS	BLKCNT		;SUBTRACT ONE FOR EACH ONE ALLOCATED
	PUSH	P,%TLINK(LPSA)	;
	PUSH	P,B
	PUSHJ	P,NOSY		;ALLOCATE SYMBOLS FOR THIS BLOCK
	POP	P,B
	POP	P,LPSA		;SEE IF HAD A SECOND SEMBLK
	TLNN	LPSA,-1		;IF NOT
	JRST	DOSYL1		;CONTINUE BACKWARDS SEARCH
	HLRZ	LPSA,LPSA	;WE DID
	FREBLK			;DONE WITH IT NOW
	JRST	DOSYL1		;CONTINUE BACKWARDS

;STEP 6 -- PUT OUT PROCNAME BLOCK IF NOT ALL GONE
DIDSYM:	SKIPG	BLKCNT		;DID WE SEE SOME WE DIDN'T ALLOCATE?
	 JRST	 DIDALL		; NO, ALL DONE
	SETOM	BLKCNT		;WON'T FAIL AGAIN
	MOVE	LPSA,TPROC	;USE PROCEDURE NAME AS OUTER BLOCK NAME
	PUSHJ	P,BLBOUT
	MOVNI	TBITS2,1	;VERRRY LOW LEVEL
	MOVE	B,BLKIDX	;LOOK AT ALL POSSIBLE ENTRIES
	JRST	DOSYL1		;GO ROUND ONCE MORE, GET THE REST

;STEP 7 -- CLEAN UP
DIDALL:	QFLUSH	(BLKIDX)	;RELEASE STORAGE, CLEAR QPDP
	SKIPE	SIMPSW		;NO PD FOR SIMPLE
	JRST	CRECHK		;
CRECHK:	
NOGAG <
	TLNN	FF,CREFSW	;IF ¬CREFFING, DONE.
	POPJ	P,		;DONE
	MOVE	LPSA,TPROC	;PROCEDURE NAME
	CAIE	LPSA,RESYM	;NOT THIS ONE;
	JRST	CREFBLOCK	;FOR BLOCK EXIT.
>;NOGAG
APOPJ:	POPJ	P,

NOSY:	PUSHJ	P,URGSTR	;IF ON STRING RING....
	FREBLK			;DELETE THE BLOCK.
	RIGHT	,%RVARB,APOPJ	;GO TO NEXT BLOCK.(OR POPJ)
SY2A:	MOVE	TBITS,$TBITS(LPSA)
	TLNE	FF,CREFSW	;IF CREFFING.
	PUSHJ	P,CREFDEF	;DEFINE THE SYMBOL.
	TLNE	TBITS,RES	;IF RESERVED WORD (NEW DEF),
	 JRST	 NOSY		; (VIA LET) , FORGET IT
	TLNE	TBITS,SBSCRP	;TURN OFF STRING IF ARRAY
	TRZ	TBITS,STRING
	PUSHJ	P,RAD50	;MAKE SURE A SYMBOL NAME GETS MADE
	TRNE	TBITS,ITEM
	TLNE	TBITS,FORMAL!SBSCRP!EXTRNL	;PUT OUT ITEM NUMBER IF
	JRST	NOITMS			;IT IS THERE.
	HRRZ	TEMP,$VAL2(LPSA)	;POINTER TO INTEGER.
	MOVE	B,$VAL(TEMP)		;ITEM NUMBER.
	PUSHJ	P,SCOUT0		;NO RELOCATION.
	JRST	NOSY
NOITMS:	HRRZ	B,$ADR(LPSA)	;FIXUP
;;#KY# ALLOW GLOBAL INTERNAL SYMBOLS OUT (FIX 1 OF 2)
	TRNE	TBITS,GLOBL	;
	TLNN	TBITS,INTRNL	;
;;#KY# 1 OF 2
	JUMPE	B,NOSY1		;NO SYMBOL
GLOC <
	TRNE	TBITS,GLOBL	;IF NOT GLOBAL
	TRNE	TBITS,ITEM	;OR IT ITEM, THEN 
	JRST	REGSYM		;NOT POSSIBLY A GLOBAL TYPE.
	HRLZ	B,$ADR(LPSA)	;FIXUP CHAIN
	HLR	B,$VAL2(LPSA)	; AND THE GLOBAL NUMBER.
	ADDI	B,400013	; GLOBAL DATA BASE.
	HRRM	B,$ADR(LPSA)	;FOR THE SYMBOL....
;;#KY# ↓ 2 OF 2
	TLNE	B,-1		;ANY TO FIX UP?
	PUSHJ	P,FIXOUT	;FIXUP WITH NO RELOCATION.
	PUSHJ	P,SCOUT0	;PUT OUT SYMBOL WITH NO RELOC.
	JRST	NOSY
REGSYM:
>;GLOC
;;#II#↓ 7-4-72 DCS DON'T LET DEFINES OUT!
	TLNN	TBITS,DEFINE
	PUSHJ	P,SOUT		;OUTPUT THE SYMBOL.
	TRC	TBITS,FORWRD!LABEL
	TRCN	TBITS,FORWRD!LABEL	;HAS A LABEL BEEN USED BUT NOT DEFINED?
	 ERR	 <UNUSED LABEL: >,3
NOSY1:	TRNE	TBITS,PROCED
	JRST	PPR		;PROCEDURE AND FRIENDS.
	TLNN	TBITS,DEFINE	;DELETE THE MACRO BODY ....
	JRST	CHARYZ		;CHECK ARRAYS.
	PUSH	P,LPSA
	LEFT	,%TLINK,LPSERR
	PUSHJ	P,URGSTR	;UNLINK MACRO BODY.
	POP	P,LPSA
	JRST	NOSY		;ALL DONE

CHARYZ:	TLNN	TBITS,SBSCRP		;ARRAY?
	 JRST	 CHKTWO			; NO

	PUSH	P,LPSA
	HRRZ	B,$VAL(LPSA)		;ARRAY ADDRESS IF OWN ARRAY
	MOVE	A,RAD5.			;DOTTED SYMBOL NAME
	TLZ	A,740000		;MAKE AN INTERNAL SYMBOL!
	TLO	A,100000		;LIKE THIS
	TLNE	TBITS,OWN		;BUILT IN?
	 PUSHJ	 P,SCOUT		; YES, PUT OUT A SYMBOL
	LEFT	,%TLINK,NOBBLK		;DELETE BNDBLK (SEE ARRAY)
	FREBLK
NOBBLK:	POP	P,LPSA			; IF THERE IS ONE

CHKTWO:	TLNE	TBITS,INTRNL!EXTRNL	;IS THERE 
	TRNN	TBITS,STRING	;A SECOND SYMBOL?
	JRST	NOSY		;NO -- DONE
	MOVE	A,RAD5.		;GET KLUDGED UP VERSION OF SYMBOL
	HLRZ	B,$ADR(LPSA)	;GET ADDRESS FOR 2D WORD
	JUMPE	B,NOSY		;AN EXTERNAL STRING COULD CAUSE THIS
	PUSHJ	P,SCOUT		;OUTPUT SYMBOL
	JRST	NOSY

PPR:	TLNE	TBITS,EXTRNL!MESSAGE	;DON'T MAKE THIS CHECK FOR EXTERNALS
	 JRST	 PPR1
	TRNE	TBITS,FORWRD	;CHECK FOR FORWARD NEVER DEFINED
	ERR	<FORWARD PROCEDURE NEVER DEFINED: >,3
PPR1:	PUSH	P,LPSA
	LEFT	,%TLINK,LPSERR	;LPSA → 2D PROC BLOCK
	MOVE	A,LPSA		;SAVE POINTER
	LEFT	(,%TLINK)	;→FIRST PARAM OR NIL
	PUSHJ	P,KILLST	;DELETE ALL FORMALS
	FREBLK	(A)		;DELETE 2D PROC BLOCK
;THE FOLLOWING CODE HANDLES THE PROCEDURE DESCRIPTOR
	MOVE LPSA,(P)		;PICK UP PROCEDURE
	HRRZ	A,$VAL(LPSA)	;PICK UP THE PD SEMBLK
	JUMPE	A,NOPD		
	TLNN	TBITS,EXTRNL	;EXTERNAL?
	JRST	NOEXPD		;NO
	SKIPGE	C,$ADR(A)	;OUT ALREADY??
	ERR	<DRYROT AT NOSY --EXTERNAL PD >,1
	TRNN	C,-1		;FIXUPS??
	JRST	PDFDON		;NO
	PUSH	P,B
	PUSH	P,A
	HRLM	C,PDFFHD	;REMEMBER FIXUP HEAD
	PUSHJ	P,RAD50		;GET PROCEDURE RADIX50
	TLC	A,640000	;CHANGE TYPE BITS
	HLRM	A,R5PD1		;SAVE RADIX50 IN BLOCK
;;#KM# RHT ↓ 11-24-72 "B"→→ "A"
	HRLM	A,R5PD2		
	MOVE	B,PDPFBD	;POLISH FIXUP BLOCK DESC
	PUSHJ	P,FRBT		;FLUSH BN OUTPUT
	PUSHJ	P,GBOUT		;PUT OUT THE BLOCK
	POP	P,A
	POP	P,B
	JRST	PDFDON
NOEXPD:
;;#IV# RHT (9-22-72) IGNORE FORWARD PROCEDURES HERE
	TRNE	TBITS,FORWRD
	JRST	PDFDON
;;#IV#
	PUSH	P,A
	PUSHJ	P,RAD50		;GET RADIX 50 SYMBOL
	MOVE	A,RAD5$		;THE $ SYMBOL
	TLZ	A,740000
	TLO	A,100000	;LOCAL PROCEDURE
	HRRZ	B,$VAL(LPSA)
	SKIPL	B,$ADR(B)	;THE ADDRESS
	ERR	<DRYROT AT NOSY -- NON EXTERNAL PROC>
	PUSHJ	P,SCOUT		;PUT PD SYMBOL OUT
	POP	P,A		;
PDFDON:	HLRZ	C,%TLINK(A)	;POINT AT PDA,,0 SEMBLK
	FREBLK	(A)		;FREE PD BLOCK 
	JUMPE	C,NOPD		;FREE PDA,,0 BLOCK IF HAVE ONE
	FREBLK	(C)
NOPD:
	POP	P,LPSA
GLOC <
;;#JF# RHT (9-27-72) ↓ BE SURE MESSAGE BLOCK GETS RIGHT ADDR
	HRRZ	B,$ADR(LPSA)	;
	CAIE	B,0		;IF FORWARD MESSAGE DESCRIP. NEVER DEFINED
	TLNN	TBITS,MESSAGE	;AND IS DEFINITELY A MESSAGE
	JRST	NOSY		; --
	TLO	FF,RELOC	;FIRST GOES THE WORD WHICH CHAINS LINKS.
	HRRO	A,PCNT
NOGAG <
	EXCH	A,MESLNK	;MESSAGE LINK
>;NOGAG
GAG <
	EXCH	A,MESLNK-SPCDAT+WOMSPC
>;GAG
	PUSHJ	P,CODOUT	;PUT IT OUT
	HRL	A,$PNAME(LPSA)	;STRING COUNT
	HRR	A,B		;ADDRESS OF PROCEDURE
	TLO	FF,RELOC	;AGAIN SINCE IF MESLNK WAS ZERO, OUR FRIEND
				;CODOUT RESET RELOC.......
	PUSHJ	P,CODOUT	;XWD  #CHARS,,PROD ADDRESS.
	TLZ	FF,RELOC
	HRRZ	C,$PNAME(LPSA)	;#CHARS AGAIN.
	ADDI	C,4		;..
	IDIVI	C,=5
MES21:	AOS	B,$PNAME+1(LPSA);WE CAN HAPPILY DESTROY THE BYTE POINTER.
	MOVE	A,-1(B)		;FIRST WORD OF PNAMES.
	PUSHJ	P,CODOUT	;OUT IT GOES.
	MOVE	A,(B)		;NEXT WORD
	CAIGE	C,2		;...
	MOVEI 	A,0		;NOT TWO WORDS LONG.
	PUSHJ	P,CODOUT
>;GLOC
	JRST	NOSY		;AND LOOP.


;LOADER BLOCK FOR POLISH FIXUP
LODBLK(,11,PDPFB,PDPFBD,5,,<XWD 001000,0>)
RELOC  .-5
	XWD	3,1		;ADD , LITC
	-1
R5PD1:	XWD	2,0		;OPDC ,, LH OF RAD50
R5PD2:	XWD	0,-1		;RH OF RAD50,,SHR
PDFFHD:	XWD	0,0		;DEST ,,0
DSCR BLBOUT
CAL PUSHJ
PAR LPSA is Semantics of Block with a name
DES outputs a Block name LOADER block via GBOUT.  Saves RADIX50 for
 name, and SHOUT makes sure that no two consecutive blocks output
 with the same names.  This can happen:  PRODEDURE FINIS (..);
  BEGIN "FINIS"  ... two identical block names
 cause havoc with DDT.
SID Uses most ACs except SBITS, PNT2 group
⊗

BLBOUT:	
	MOVE	TBITS,$TBITS(LPSA)	;SEE IF IT IS A PROCEDURE OR NOT
	HRRZ	B,$VAL2(LPSA)		;LEVEL (DDT) OF THIS BLOCK
	TRNN	TBITS,PROCED		;IF PROCEDURE,
					; GET LEVEL FROM DIFFERENT PLACE
	JRST	NOPRCC
	HLRZ	TEMP,%TLINK(LPSA)
	HRRZ	B,$VAL2(TEMP)
NOPRCC:	PUSHJ	P,RAD50		;GET BLOCK NAME IN RADIX50
	TLZ	A,740000	;CLEAR SYMBOL TYPE BITS
	TLO	A,140000	;PUT IN THE RIGHT ONES
	PUSHJ	P,SCOUT		;PUT OUT BLOCK NAME
	MOVEM	A,LSTRAD	;SAVE RADIX50 FOR THE BLOCK NAME.
	TRNE	TBITS,PROCED
	 POPJ	P,
	MOVE	A,RAD5.
	TLZ	A,740000	;SHOULD BE BLOCK TYPE 10
	TLO	A,100000
	HLRZ	B,$VAL2(LPSA)
PPFF:	JRST	SCOUT		;MAKE LABEL FOR BLK OR CMPD STMT.


DSCR PDOUT
DES ROUTINE TO OUTPUT THE PROCEDURE DESCRIPTOR -- USED ONLY FOR DISPLAY SYSTEMS
PARM PROC SEMBLK ADDRESS IN PNT2
SID  ALL ACCUMULATORS SAVED EXCEPT TEMP & LPSA
⊗
DIS <

BITDATA( PROC DESC STUFF)
BLKCOD←←17				;BLOCK BOUNDARY CODE
EOPCOD←←0				;END OF PROC LVI CODE
AACOD←←1					;ARITH ARRAY
SACOD←←2					;STRING ARRAY
SETCOD←←3				;SET
LACOD←←4					;LIST OR SET ARRAY
FRCCOD←←5				;FOREACH STATEMENT
KLCOD←←6				;KILL LIST
CTXCOD ←← 7				;CONTEXT
CLNCOD ←← 10				;CLEANUP PROC
ENDDATA

PDOUT:	PUSH	P,FF	;SAVE FF
	PUSH	P,A
	PUSH	P,B
	PUSH	P,C
	PUSH	P,SBITS2
	PUSH	P,TBITS
	PUSH	P,PNT
	HRRZ	PNT,$VAL(PNT2)		;PICK UP PD SEMBLK
	JUMPE	PNT,XPDOUT		;IF OUTER BLOCK, NOTHING GOES OUT
	MOVEI	A,0
	TLZ	FF,RELOC
	PUSHJ	P,CODOUT
COMMENT ⊗  ****** ON THE MAGIC DAY *****
	MOVEI	B,PDLINK		;LINK  THE PROC DESC
	PUSHJ	P,LNKOUT
⊗;**************************************
	HRRZ	B,PCNT			;THE CURRENT ADDRESS
	HRL	B,$ADR(PNT)		;FIXUP REFERENCES TO PDA
	HRROM	B,$ADR(PNT)		;REMEMBER THE FACT THAT PDA IS RIGHT
	TLNE	B,-1			;IF THERE WERE ANY
	PUSHJ	P,FBOUT			;DO IT
	HRRZ	A,$ADR(PNT2)		;ADDRESS OF PROC ENTRY
	TLO	FF,RELOC
	PUSHJ	P,CODOUT
	HRRZ	A,$PNAME(PNT2)		;LENGTH OF THE NAME
	TLZ	FF,RELOC
	PUSHJ	P,CODOUT		;PUT IT OUT
	HRRZ	B,PCNT
	HRRM	B,$PNAME+1(PNT)		;REMEMBER THIS SPOT
	MOVE	A,[POINT 7,0]		;BYTE PTR WORD FOR PNAME
	PUSHJ	P,CODOUT
	MOVE	A,$TBITS(PNT2)
	PUSHJ	P,CODOUT		;PUT OUT PROCEDURE TBITS
	HLRZ	B,%TLINK(PNT2)		;POINT AT 2ND PROC SEMBLK
	MOVS	A,$NPRMS(B)		;#SPARMS*2,,#APRMS +1 →→ A
	PUSHJ	P,CODOUT		;PUT IT OUT
	HRL	A,SSDIS			;+SS DISP
	HRR	A,ASDIS			;+AS DISP
	PUSHJ	P,CODOUT		;
LLPUT:	HRLZ	A,$SBITS(PNT2)
	AND	A,[XWD LLFLDM,0]	;LEX LEV
	HRR	A,$VAL2(PNT)		;LVI FIXUP
	HRL	B,PCNT		
	HLRM	B,$VAL2(PNT)
	TLO	FF,RELOC	
	PUSHJ	P,CODOUT
DLPUT:	HRLZ	A,CDLEV			;CURRENT DISPLAY LEVEL
	HRR	A,$VAL(PNT)		;PARAM INFO FIXUP
	HRL	B,PCNT			;
	HLRM	B,$VAL(PNT)
	TLO	FF,RELOC
	PUSHJ	P,CODOUT
	HLRZ	B,%TLINK(PNT)		;POINT AT [PDA,,0] SEMBLK
	CAIN	B,0			;DO WE HAVE ONE
	JRST	PDAX0			;NO
	HRL	B,$ADR(B)
	HRR	B,PCNT			;HERE IT IS
	TLNE	B,-1
	PUSHJ	P,FBOUT
PDAX0:	HRLZ	A,$ADR(PNT)		;PICK UP PDA INTO LH
	PUSHJ	P,CODLRL		;GO RELOCATE LH
	HLRZ	C,%TLINK(PNT2)		;LOOK AT 2ND PROC SEMBLK
	HRRZ	C,%SAVET(C)		;TO FIND PARENT PROC
	MOVEI	A,0			;
 	JUMPE	C,[ TLZ FF,RELOC	;IF THE TOP LEVEL (I.E. NO DADDY)
		  PUSHJ	P,CODOUT	;PUT OUT THE 0
		  JRST PCPRD]		;GO ON TO NEXT THING
	HRRZ	C,$VAL(C)		;PD SEMBLK
	HRRZ	A,$ADR(C)		;EASIEST TO CHAIN BY SELF
	HRR	B,PCNT			;NEW CHAIN
	HRRM	B,$ADR(C)
	HLL	A,$ACNO(PNT)		;PCNT AT END OF MKSEMT
PPDA0:	TLO	FF,RELOC
	PUSHJ	P,CODLRL		;GO PUT IT OUT
PCPRD:	MOVE	A,$ACNO(PNT2)		;PCNT AT PRDEC,,EXIT(FIXED UP)
	HRR	A,$ACNO(PNT)		;PICK UP EXIT FROM PD SEMBLK
	TLO	FF,RELOC
	PUSHJ	P,CODLRL		;RELOC BOTH HALVES
	HLRZ	C,%TLINK(PNT2)		;SECOND PROC SEMBLK
	HLRZ	C,%SAVET(C)		;OLD TTOP
	HRLZ	A,PCNT			;
	HLR	A,$SBITS(C)		;FIXUP LVI REF TO PARENT BLOCK
	HLLM	A,$SBITS(C)		;FIXUP CONTINUED
	HRRZS	A			;SCRATCH THE OLD CRUFT
	PUSHJ	P,CODOUT		;PUT IT OUT
	TLZ	FF,RELOC
	HLRZ	LPSA,%TLINK(PNT2)	;LPSA← →→ 2ND PROC SEMBLK
	HLRZ	LPSA,%TLINK(LPSA)	;LPSA NOW →→ FIRST PARA
	JUMPE	LPSA,DOLVIN		;THERE MAY NOT BE ANY
	HRR	B,PCNT
	HRL	B,$VAL(PNT)		;LOC OF START OF PROC PARAM INFO
	PUSHJ	P,FBOUT

NPTB:	MOVE	A,$TBITS(LPSA)		;PICK IT UP
	PUSHJ	P,CODOUT		;PUT IT OUT
	RIGHT	,%RVARB,DOLVIN
	JRST	NPTB			;GO DO NEXT ONE

DOLVIN:	PUSH	P,PNT2
	HRR	B,PCNT
	HRL	B,$VAL2(PNT)
	PUSHJ	P,FBOUT
	MOVE	PNT,$SBITS(PNT2)
	ANDI	PNT,LLFLDM		;LEX LEVEL
	SKIPE	SBITS2,BLKIDX		;PICK UP
	PUSHJ	P,LVIOUT
	POP	P,PNT2
	TLZ	FF,RELOC
	MOVEI	A,0
	PUSHJ	P,CODOUT		;PUT OUT END OF LVI FLAG
	MOVE	PNT,$VAL(PNT2)		;PD SEMBLK AGAIN
	HRL	B,$PNAME+1(PNT)		;FIX UP THE STRING REFERENCE
	HRR	B,PCNT
	PUSHJ	P,FBOUT
	HRRZ	SBITS2,$PNAME(PNT2)	;LEN OF PNAME
	TLZ	FF,RELOC		;DO NOT RELOCATE
	MOVE	LPSA,$PNAME+1(PNT2)	;BYTE PTR FOR PNAME
TRDY:	MOVE	TEMP,[POINT 7,A]
	MOVEI	A,0
	MOVEI	B,5
TPNC:	SOJL	SBITS2,PNMDN
	ILDB	C,LPSA			;PICK UP CHAR
	IDPB	C,TEMP			;PUT IT DOWN
	SOJG	B,TPNC
	PUSHJ	P,CODOUT
	JRST	TRDY
PNMDN:  CAIE	B,5
	PUSHJ	P,CODOUT
XPDOUT:	POP	P,PNT			;RETURN
	POP	P,TBITS
	POP	P,SBITS2
	POP	P,C
	POP	P,B
	POP	P,A
	POP	P,FF
	POPJ	P,


;ROUTINE TO PUT OUT LOCAL VAR INFO -- USED BY DIS
;PARAMS -- BLOCK QPDP IN SBITS2,, LEX LEV IN PNT


LVIOUT:	PUSH	P,[-1]		;CLEVER FLAG TO CATCH BIG PARENT
LVIO.1:	MOVE	B,SBITS2
	QBACK
	JRST	LVIEXT		;ALL DONE
	MOVEM	B,SBITS2
	MOVE	PNT2,A		;GET HIS NAME
	LDB	PNT,[POINT LLFLDL,$SBITS(PNT2),=35]

	HRRZ	B,PCNT
	HLL	B,$SBITS(PNT2)
	TLNE	B,-1
	PUSHJ	P,FBOUT		;FIXUP REFS FOR THIS BLOCK'S INFO, IF ANY
	HRLM    B,$SBITS(PNT2)	;REMEMBER MY SPOT
	HLRZ	LPSA,%TLINK(PNT2)	;SECOND PROC SEMBLK
	JUMPE	LPSA,LIT.1		;NONE
	SKIPN	$ACNO(LPSA)	;THE QPDP FOR CLEANUPS
	JRST	LIT.1		;NONE
	QBEGIN	(<$ACNO(LPSA)>)	;GET INITIAL QPDP
LIT.0:	QTAKE			;TAKE ONE
	JRST	LIT.X		;DONE
	MOVE	TBITS,$TBITS(A)	;GET TYPE
	MOVE	C,A		;
	HRRZ	A,$ADR(C)	;ADDRESS
	TDNN	TBITS,[XWD EXTRNL,FORWRD+INPROG] ;NEED FIXUP?
	JRST	LIT.01		;NO
	HRL	C,PCNT 		;YES
	HLRM	C,$ADR(C)	;
LIT.01:	HRLI	A,CLNCOD⊗=14	;TYPE IS CLEANUP
	DPB	PNT,[ POINT =9,A,=12] ;LEX LEV
	TLO	FF,RELOC	;RELOC
	PUSHJ	P,CODOUT	;
	JRST	LIT.0		;GET NEXT
LIT.X:	QFLUSH
LIT.1:	MOVE	LPSA,PNT2
LITER:	RIGHT	,%RVARB,EBK	;GO DOWN VARB RING
	MOVE	TBITS,$TBITS(LPSA)	;PICK UP TYPE BITS

;;#IT# RHT 8-4-72 ↓ KEEP OUT EXTERNALS
;;#IZ# RHT 9-25-72 ↓ ALSO KEEP OUT GLOBALS
	TDNE	TBITS,[XWD EXTRNL!OWN,GLOBL!PROCED];OWN STUFF NEVER GOES,
					     ;	ALSO NO PROCS OR EXTERNALS
	JRST	LITER
	TLNE	TBITS,SBSCRP
	JRST	ARYINF
;;#  # DCS 5-3-72  SETS, BUT NOT SET ITEMS!!
	TRNE	TBITS,ITMVAR!ITEM	;CHECK IT OUT -- DCS
	 JRST	 LITER			;LOOP
;;#  # 5-3
	TRNE	TBITS,SET		;SET??
	JRST	SETINF
	TRNE	TBITS,INTEGR	;TEST FOR THE FOREACH KLUGE (FLOATING INTEGER)
	TRNN	TBITS,FLOTNG
	JRST 	LITER		;LOOP
FRCINF:	MOVEI	B,FRCCOD	;FOREACH CODE
	JRST	PUTCI

ARYINF:	TLNE	TBITS,BILTIN	;BUILT IN
	JRST	LITER		;YES,DONT BOTHER
	MOVEI	B,AACOD		;ARITH CODE
	TRNE	TBITS,STRING	;MAYBE IT WAS A STRING ARRAY
	MOVEI	B,SACOD
	TRNE	TBITS,SET	;OR A LEAPISH THING
	MOVEI	B,LACOD
	JRST 	PUTCI
;;#  # RHT 8-1-72 KILL SET
SETINF:	TLNN	TBITS,SAFE	;CHECK IF KILL SET
	JRST SETI.1		;NO
	TRNN	TBITS,INTEGR	;BE SURE
	ERR	<DRYROT AT LVIOUT>
	MOVEI	B,KLCOD
	JRST	PUTCI
;;#  # RHT 8-1-72
SETI.1:	SKIPN	RECSW		
	JRST	LITER	
	MOVEI	B,CTXCOD	;CONTEXT?
	TLNE	TBITS,FLOTNG	;CHECK
	JRST	PUTCI
	MOVEI	B,SETCOD
PUTCI:	MOVEI	A,0
	SKIPE	RECSW		;IS THIS FORB RECURSIVE??
	HRLZI	A,RF
	DPB	B,[POINT 4,A,3]
	DPB	PNT,[POINT =9,A,=12]
	TLO	FF,RELOC
	SKIPE	RECSW
	TLZ	FF,RELOC
	HRR	A,$ADR(LPSA)
	TRNE	A,-1		;DID IT GET USED?? - IF SO MUST BE NON ZERO FOR 
				;EITHER CORE OR STACK (SINCE (F) IS DYN LINK)
	PUSHJ	P,CODOUT
	JRST	LITER

EBK:	HRLZ	A,PNT
	LSH	A,5			;PUT LEX LEV IN RIGHT SPOT
	MOVEI	B,BLKCOD		;SAY IT IS A BLOCK
	DPB	B,[POINT 4,A,3]
	AOSN	(P)			;IS THIS THE OUTER BLK FOR THIS PD
	JRST	.+4			;YES LINK UP IS ZERO
	HLRZ	B,$ADR(PNT2)		;
	HLR	A,$SBITS(B)		;RH  OF A  ←← PARENT'S LVI AREA
	TLOA	FF,RELOC		;
	TLZ	FF,RELOC		;NEVER RELOC 0
	PUSHJ	P,CODOUT		;PUT OUT FLAG WORD
	JRST	LVIO.1			;GO GET NEXT BLOCK
LVIEXT:	SUB	P,[XWD 2,2]		;FLUSH	THE FLAG
	JRST	@1(P)			;RETURN


>;DIS
 

COMMENT ⊗Allo -- Allocate One Type of Symbol
 ALLO looks at each symbol and outputs its core locations, etc.
  It also outputs fixups, and saves the final core address in
  $ADR so that the symbol-outputter can find it.
⊗
ALLO:	MOVEI	PNT2,0		;COUNT OF LOCALS ALLOCATED.
	SKIPN	SBITS2,BLKIDX	;GET QPDP FOR BLOCK QSTACK
	 JRST	 CPOPJ		; NOTHING TO ALLOCATE

ITE:	MOVE	B,SBITS2	;GET QPDP TO PARAM POSITION
	QBACK			;NON-DESTRUCTIVE QPOP
	 JRST	[HRR A,FIRSYM	;SET UP ALIMS-TYPE WORD
		 HRL A,LSTSYM
		 POPJ P,]	;DONE
	MOVEM	B,SBITS2	;SAVE UPDATED QPDP
	MOVE	LPSA,A
ITER:	RIGHT	,%RVARB,ITE		;GO DOWN LIST
	MOVE	TBITS,$TBITS(LPSA)	;TYPE BITS.
	TRNE	TBITS,SET	;IF A SET DO NOT ALLOCATE AS ARITH TOO
	TRZ	TBITS,FLOTNG!INTEGR
	TLNE	TBITS,SBSCRP	;DO NOT ALLOCATE AS BOTH ARRAY AND INTEGER!!!
	TRZ	TBITS,STRING!INTEGR!FLOTNG!ITMVAR!ITEM!SET!LSTBIT!LPARRAY!SHORT
	TRNE	TBITS,ITEM!ITMVAR
	TRZ	TBITS,STRING!INTEGR!FLOTNG!SET!LSTBIT
	TRNN	TBITS,PROCED!LABEL	;NEVER SPACE FOR THESE.
	TDNN	TBITS,TBITS2	;USE THE MASK.
	JRST	ITER		;NO MATCH -- GO FARTHER
	
ALOWDS:	
	TDNE	TBITS,[XWD EXTRNL!DEFINE,GLOBL] ;PUT OUT NO CODE
						; OR FIXUPS FOR EXTERNALS
	 JRST	 ITER
	TLNE	TBITS,SBSCRP	;ALWAYS ALLOCATE ARRAYS
	 JRST	 ANYWAY
	SKIPN	B,$ADR(LPSA)	;IF $ADR IS 0 AND SYMBOL IS NOT
	TLNN	TBITS,INTRNL	; INTERNAL, DON'T PUT OUT CODE OR FIXUPS
	JUMPE	B,ITER
ANYWAY:
DIS <
	SKIPE	RECSW		;IF NOT RECURSIVE 
	TDNE	TBITS,[XWD OWN,ITEM] ;OR VAR IS OWN, ITEM OR THE LIKE
	JRST	ALCV		;IT GETS INTO CORE
	AOS	B,CSPOS		;USE A STACK LOCN
	TLNN	FF,ALLOCT	;ALLOCATING?
	JRST	[TRNE	TBITS,STRING	;NO-- IS IT A STRING?
		AOS	CSPOS		;YES
		JRST	ITER]
	HRL	B,$ADR(LPSA)	;FIRST FIXUP
	HRRM	B,$ADR(LPSA)	;SAVE ITS SACK INC
	TLNE	B,-1		;MIGHT BE UNUSED
	PUSHJ	P,FIXOUT	;NO RELOC FOR FIXED UP VALUE
	TRNN	TBITS,STRING	;STRING????
	JRST	ITER		;NO -- DONE WITH THIS
	AOS	B,CSPOS		;BUMP	STACK DISPL
	HLL	B,$ADR(LPSA)	;SECOND WORD FIXUP CHAIN
	HRLM	B,$ADR(LPSA)	;SAVE IT
	TLNE	B,-1		;USED?
	PUSHJ	P,FIXOUT	;YES
	JRST	ITER		;AT LAST
ALCV:
>;DIS
	MOVEM	LPSA,LSTSYM	;LAST SYMBOL
	AOS	PNT2		;INCREMENT COUNT.
	SKIPN	FIRSYM
	 MOVEM	LPSA,FIRSYM	;RECORD FIRST SYMBOL ONCE!!
	TLNN	FF,ALLOCT	;ACTUALLY ALLOCATE?
	JRST ITER		;NO -- LOOP
NOGAG <	;DON'T NEED FIXUPS IN "GOGOL"
	HRLZ	B,$ADR(LPSA)	;FIRST FIXUP
	HRR	B,PCNT
	HRRM	B,$ADR(LPSA)	;SAVE THE PCNT FOR SOUT TO FIND.
	TLNE	B,-1		;IN CASE A STRING WHICH ONLY USES SECOND WD.
	PUSHJ	P,FBOUT		;OUTPUT THE FIXUP
>;NOGAG

; BUG TRAP -- $VAL SHOULD GENERALLY BE 0 THRU HERE

	SKIPE	A,$VAL(LPSA)		;VALUE WORD
	TRNE	TBITS,ITEM		;EXCEPT ITEMS.........
	 JRST	 NVL			; IT IS ZERO
	TLNN	TBITS,SBSCRP		;CAN BE NON-ZERO IF ARRAY
	 ERR	<DRYROT -- ALLO>,1
NVL:
NOGAG <
	TLZ	FF,RELOC
	TLNE	TBITS,SBSCRP		;WANT RELOCATABLE IF ARRAY
	TLO	FF,RELOC		; UNLESS IT IS ZERO

	PUSHJ	P,CODOUT	;OUTPUT A WORD FOR IT!
	TLZ	FF,RELOC	;MAKE SURE IT'S OFF
	TRNN	TBITS,STRING	;DO WE WANT STILL ANOTHER WORD?
	JRST	ITER		;NO -- LOOP
	HLLZ	B,$ADR(LPSA)	;SECOND FIXUP
	HRR	B,PCNT
	HRLM	B,$ADR(LPSA)	;SAVE THIS FOR 2D SYMBOL IF ANY
	TLNE	B,-1		;IN CASE NOT USED.
	PUSHJ	P,FBOUT		;OUTPUT FIXUP
	MOVEI	A,0
	PUSHJ	P,CODOUT	;AND A WORD OF STORAGE.
>;NOGAG
	JRST	ITER		;LOOP



;ROUTINE TO ALLOCATE SPACE FOR TEMP CELLS AND TO OUTPUT
;FIXUPS.

TMPALO:	SETZM	PNT2		;COUNT
	HRRZ	LPSA,TTEMP
	JUMPE	LPSA,CPOPJ
TMPAL:	MOVE	SBITS,$SBITS(LPSA) ;S BITS.
	TLNN	SBITS,CORTMP	;A CORE TEMP?
	JRST	TMNXT		;NO
	MOVEM	LPSA,LSTSYM	;SAVE
	SKIPN	FIRSYM		;NO ARITH VARIABLES?
	 MOVEM	 LPSA,FIRSYM	; THAT'S RIGHT, THIS TEMP IS FIRST
	MOVEI	TEMP,INTEGR	;MIGHT BE INDXED STRING TEMP LEFT OVER,
	MOVEM	TEMP,$TBITS(LPSA) ;THIS IS EASIEST WAY TO AVOID CONFUSION
				;(PRUP CHECKS STRING, DOES FXTWO, WE DON'T
				;   WANT THAT HERE)
	TLZ	SBITS,INDXED!FIXARR ;DO SOME THINGS TO SBITS TOO
	TLZE	SBITS,INAC!PTRAC!STTEMP ;ONLY REMAINING USE IS
	ERR	<DRYROT -- TMPALL>,1	; FOR REC. PROC BLT CODE
	MOVEM	SBITS,$SBITS(LPSA)		;(MORE HONESTY)
	AOS	PNT2
	SKIPN	RECSW		;IF NOT RECURSIVE
	JRST	ALCTMP		;THEY GO TO CORE
	AOS	B,CSPOS		;BUMP THE STACK OFFSET
	TLNN	FF,ALLOCT	;ACTUALLY ALLOCATE?
	JRST	TMNXT		;NO
	HRL	B,$ADR(LPSA)	;PICK UP FIXUP CHAIN
	PUSHJ	P,FIXOUT	;FIXUP
	JRST	TMNXT
ALCTMP:
	TLNN	FF,ALLOCT	;ACTUALLY ALLOCATE?
	JRST	TMNXT		;NO

NOGAG <
	HRR	B,PCNT
	HRL	B,$ADR(LPSA)
	PUSHJ	P,FBOUT		;FIXUP
>;NOGAG

; PUT OUT A "TEMPXX" SYMBOL

	MOVE	A,$PNAME(LPSA)	;ID NO FOR THIS TEMP
	IDIVI	A,=10		;TENS IN A, ONES IN B
	ADDI	A,1
	IMULI	A,50		;RADIX50 FOR TENS
	ADDI	B,1		;RADIX50 FOR ONES
	ADD	A,[<XWD 100000,0>+(<RADIX50 0,TEMP>*50*50)]
	ADD	A,B		;A HAS RADIX50 FOR "TEMPXX"
NOGAG <
	HRRZ	B,PCNT
>;NOGAG
GAG <
	HRRZ B,$ADR(LPSA);HAVE ADDR ALREADY
>;GAG
	PUSHJ	P,SCOUT		;WRITE A SYMBOL

NOGAG <
	MOVEI	A,0
	PUSHJ	P,CODOUT
>;NOGAG
TMNXT:	HLRZ	PNT,%RVARB(LPSA) ;GET NEXT ONE
	TLNN	FF,ALLOCT
	JRST	TMNN
	FREBLK			;RELEASE THE SYMBOL TABLE BLOCK
TMNN:	MOVE	LPSA,PNT	;COPY IT BACK.
	JUMPN	LPSA,TMPAL	;LOOP
	POPJ	P,


↑LNKMAK:		; PUT OUT STRING LINK BLOCK, IF NECESSARY
NOGAG <;DON'T NEED IN "GOGOL"
	SKIPN	TEMP,SLOCALS
	JRST	SETLNQ
	LSH	TEMP,-1	;NUMBER OF STRINGS
	HRLZ	A,TEMP		;WORD WILL BE #STRINGS,,ADDR OF FIRST
	HRRZ	LPSA,SLIMS	;SEMANTICS OF FIRST
	HRL	C,$ADR(LPSA)	;ADDR OF FIRST
	TRO	A,NOUSAC+USADDR
	PUSHJ	P,EMITER	;PUT OUT DESCRIPTOR WORD
	EMIT	(<NOADDR+NOUSAC>)	;LINKAGE WORD -- PUT OUT ZERO
	MOVEI	B,1		;STRING LINK.
	PUSHJ	P,LNKOUT	;THEN A LINKAGE CALL TO LOADER REFERENCING IT
SETLNQ:	SKIPN	A,LLOCAL
	POPJ	P,		;NO SETS TO LINK UP EITHER.
	MOVNS	A		;A WILL BE - # OF SETS,,ADR OF FIRST.
	HRRZ	LPSA,LLIMS	;SEMANTICS OF FIRST ONE.
	HRL	C,$ADR(LPSA)	;ADDRESS OF FIRST ONE.
	HRRI	A,NOUSAC!USADDR
	PUSHJ	P,EMITER	;PUT IT OUT.
	EMIT	(NOADDR!NOUSAC)	;FOR THE LINK.
	MOVEI	B,3		;SET LINK NUMBER
	JRST	LNKOUT
>;NOGAG

SNTP:	POPJ	P,

COMMENT ⊗REQINI -- USER REQUIRED INITIALIZTIONS⊗
ZERODATA()
INIPDP: 0	;QSTACK POINTER FOR INITIALIZATIONS
INIMAN: 0	;FLAG IF INMAIN HAS BEEN CALLED
ENDDATA

DSCR REQINI,REQIN1,REQIN2
CAL PUSHJ
PARM REQINI -- TAKES PROC SEMBLK FROM GENLEF+1
     REQIN1 -- PROC SEMBLK IN PNT
     REQIN2 -- INITIALIZATION WORD IN A
		-- PHASE #,,LOC TO BE PUSHJ'ED TO
DES  PUSHES AN INITIALIZATION REQUEST ONTO QSTACK INIPDP. DONES
	WILL PUT OUT THE CONTENTS OF THIS QSTACK AS THE INITIALIZATION
	REQUEST BLOCK.
⊗

↑REQINI:MOVE PNT,GENLEF+1	;GET PROCEDURE
↑REQIN1:HLRZ	PNT2,%TLINK(PNT);2ND BLOCK
;;#JH# ↓ RHT 9-29-72 TYPO ERROR
	HRLZI	A,1		;
	CAME	A,$NPRMS(PNT2)	;ANY PAPAMS
	ERR	<THIS PROCEDURE HAS PARAMETERS>,1
	PUSHJ	P,GETAD
	TLNN	TBITS,FORWRD!EXTRNL	;IF ONE OF THESE, HARDER
	JRST	ESYCS
	HRRZ	C,PCNT
	HRLI	C,2(C)
	EMIT	<JRST NOUSAC!USADDR>	;JRST .+2
	HRRZ	A,PCNT
	HRLI	A,400000
	QPUSH	(INIPDP)		;REMEMBER THIS SPOT
	EMIT	<JRST NOUSAC>		;CALL THE PROCEDURE
	POPJ	P,
ESYCS:	HRRZ	A,$ADR(PNT)
	HRLI	A,400000
REQIN2:	QPUSH	(INIPDP)		;REMEMBER THE ROUTINE ADDRESS
	POPJ	P,


COMMENT ⊗ INMAIN - REQUEST INITIALIZATION FOR MAINPR IF NOT ALREADY DONE ⊗

↑INMAIN: SKIPE	INIMAN			;ALREADY REQUESTED?
	POPJ	P,			;YES
	SETOM	INIMAN			;REQUESTED NOW
	HRRZ	C,PCNT
	HRLI	C,2(C)			;FOR JRST .+2
	EMIT	<JRST NOUSAC!USADDR>
	HRL	C,PCNT
	EXCH	C,LIBTAB+RMAINPR	;LIBRARY ENTRY FOR MAINPR
	EMIT	<JRST NOUSAC!USADDR>
	HRR	A,PCNT
	SUBI	A,1
	HRLI	A,1			;PHASE 1
	JRST	REQIN2
SUBTTL	DONES  -- Storage Allocation Routines -- end of program

DSCR DONES
PRO DONES
DES This is the DONE code.  It takes care of any allocation that
must be left until the end, allocates constants,etc.
The order of operations is:

1.	Allocate space for any remaining variables, temps, etc.
1aa.	Put out block of counters if /K switch is specified.
1aaa.	Put out initialization link.
1a.	Put out LEAP printnames if any.
2.	Allocate space for constants,string constants, and address constants.
3.	Output external requests for built-in procedures.
4.	Output external requests for run-time (XCALL) routines.
5.	Put out rqsts for other programs to be loaded, libraries 
	to be searched
6.	Finish all binary output, and write an end block.
7.	Put out the space allocation information block. This is examined
	at run time to know how much space need be allocated for various
	purposes (strings, leap, array push-down, etc.).

SEE ALOT for variable-allocation code
⊗

;1

↑DONES:	PUSHJ	P,ALLSTO		;STORE EVERYONE
DIS <
	MOVE	A,[XWD 3,3]
	PUSHJ	P,CREINT
	EMIT	<SUB P,NOUSAC>
>;DIS 
	EMIT	(<POPJ RP,NOUSAC+NOADDR>)	;RETURN
	TLO	FF,ALLOCT		;THIS TIME WE DO THINGS RIGHT OFF
	PUSHJ	P,ALOT
	SKIPE	ADRTAB		;MUST BE EXHAUSTED AT THIS POINT
	ERR	<DRYROT -- DONES>,1
REN <
	PUSHJ	P,LOSET			;DATA TO DATA SEGMENT
>;REN


COMMENT ⊗
  If the /K switch was specified, we are now ready to alocate
  space for the counters and put out the small data block used
  by the runtime routines K.ZERO and K.OUT.  The block is linked to
  other such blocks via the loader LINK feature, using link
  number 5.  There will be multiple counter blocks only in the
  case of multiple compilations.  If there are no counters
  inserted, then nothing is put out.  The symbolic name
  .KOUNT is given to the location of the first counter.  The
  routine K.OUT needs a file name to write the counters out to
  after execution.  The filename is set to the name of the listing
  file.  (they will have different extensions.)  The generated
  code will look as follows:

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

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

⊗
	SKIPE	KOUNT			;ARE WE INSERTING COUNTERS
	SKIPN	KCOUNT			;AND ARE THERE ANY
	JRST	NOK3			;NO ON ONE OF THE ABOVE
	MOVEI	TBITS2,LSTCDB		;GET FILE NAME
	MOVE	A,CFIL(TBITS2)
	TLZ	FF,RELOC		;DON'T RELOCATE IT
	PUSHJ	P,CODOUT		;WRITE IT
	MOVEI	A,0
	PUSHJ	P,CODOUT		;PUT OUT A ZERO WORD
	MOVEI	B,5			;LINK IT INTO CHAIN 5
	PUSHJ	P,LNKOUT
	MOVE	C,PCNT
	MOVSI	C,-3(C)
	EMIT	(<XWD -4,NOUSAC!USADDR>)  ;IOWD 4,.-2
	MOVN	A,KCOUNT
	HRLZ	A,A			;-COUNT
	HRR	A,PCNT			;.KOUNT-2
	ADDI	A,1			; IOWD N,.KOUNT
	TLO	FF,RELOC		;RELOC PLEASE
	PUSHJ	P,CODOUT
	MOVEI	A,0			;ANOTHER 0
	PUSHJ	P,CODOUT
	PUSHJ	P,FRBT			;FORCE OUT CODE BLOCK
	HRRZ	B,PCNT
	MOVE	A,[RADIX50 10,.KOUNT]	;DEFINE SYMBOLIC NAME
	PUSHJ	P,SCOUT			;FOR THE COUNTERS
	MOVE	A,KCOUNT
	ADDM	A,PCNT			;LEAVE SPACE FOR THEM

COMMENT ⊗	Now we fix up all counters addresses in 
	the AOS instructions that have already been output.
⊗

	MOVE	B,PCNT			;POINT JUST PAST THE COUNTERS
ISK1:	MOVEI	B,-1(B)			;MOVE POINTER BACK ONE
	QPOP	(KPDP)			;GET ADDR OF AN AOS
	JUMPL	A,NOK3			;THAT'S ALL
	HRL	B,A			;PREPARE B FOR FBOUT
	PUSHJ	P,FBOUT			;FIXUP
	JRST	ISK1			;ONE MORE TIME
NOK3:
; here put the initialization requests.
	SKIPN	INIPDP			;ANY ON THE QSTACK?
	JRST	INI.DN			;NO
	MOVEI	A,0			;FOR THE LINK
	TLZ	FF,RELOC
	PUSHJ	P,CODOUT
	MOVEI	B,%INLNK
	PUSHJ	P,LNKOUT		;PUT OUT THE LINK
	TLO	FF,RELOC
	QBEGIN	(INIPDP)		;GET READY TO TAKE SOME OUT
NX.INI:	QTAKE	(INIPDP)		;TAKE NEXT ENTRY
	JRST	INI.D1			;DONE
	PUSHJ	P,CODOUT		;PUT OUT THE REQUEST
	JRST	NX.INI
INI.D1:	MOVEI	A,0
	TLZ	FF,RELOC
	PUSHJ	P,CODOUT
INI.DN:
NOGAG <	;BLOCK BITS USED BY "GOGOL", SO NO NEED
IFN PATSW,<
	HRLI	B,3			;ADDRESS OF 1ST AOS IF IN LOW SEG
REN <
	SKIPE	HISW
	HRLI	B,400003		;IT'S IN HIGH SEGMENT
>;REN
	HRR	B,PCNT
	PUSHJ	P,FBOUT			;INITIAL AOS "PAT" FIXUP
	HRLI	C,-1			;BLOCK ALWAYS ACTIVE
	EMIT	(<USADDR+NORLC+NOUSAC>) ;SO PUT OUT LARGE COUNT
>;PATSW
REN <
	PUSHJ	P,HISET			;BACK TO UPPER SEGMENT TO
>;REN
	PUSHJ	P,LNKMAK		;MAKE LINKAGE BLOCK
>;NOGAG

;1A
NOGAG <
LEP <
	SKIPE	LEAPIS			;ANY LEAP ASKED FOR
	HRROS	ITEMNO			;TELL RUNTIMS YES
	SKIPN	ITMSTK			;ANY DECLARED ITEMS?
	JRST	CONQN			;NONE
	MOVE	A,PCNT			;GET PROG. CNTR
	MOVEM	A,TINIT			;SAVE IT
	MOVE	A,ITMCNT		;NUMBER OF DECLARED ITEMS(INCLUDES GLOBALS)
	TLZ	FF,RELOC
	PUSHJ	P,CODOUT		;PUT IT OUT
	MOVE	B,ITMBEG		;START OF ITEM QSTACK
LPITMT:	QTAKE	(ITMSTK)		;GET ITEM,TYPE
	JRST	PNMOUT			;THROUGH, NO MORE ITEMS
	PUSHJ	P,CODOUT
	JRST	LPITMT			;LOOP

PNMOUT:
	MOVE	A,PCNT
	MOVEM	A,PINIT
	TLZ	FF,RELOC
	SOS	A,PNMSW			;NUMBER OF NAMES.
	PUSHJ	P,CODOUT		;PUT OUT SOME STUFF.
	SKIPN	PNMSW			
	JRST	CONQN			;NO PNAMES -- SE ABOUT CONSTANTS.
	MOVE	B,PNBEG			;THE QTAKE POINTER
ITM1:	QTAKE	(PNLST)
	JRST	ITM2			;ALL DONE.
	MOVE	PNT,A			;FOR EMITTER
	HRRI	A,NOUSAC
	PUSHJ	P,EMITER		; #CHARS,,POINTER TO BYTE POINTER.
	JRST	ITM1
ITM2:
>;LEP
>;NOGAG
CONQN:



;2
	TLZ	FF,RELOC
	HRRZ	LPSA,CONINT		;VARB-LIKE RING OF CONSTANTS.
	JUMPE	LPSA,STRGO
REN <
	MOVSI	D,RECURS		;GET REAL LIVE CONSTANTS FIRST
	PUSHJ	P,INTLOP
	PUSHJ	P,LOSET			;SWITCH TO LOWER SEGMENT IF HISW
	HRRZ	LPSA,CONINT		;NOW GET CONSTANTS WHICH WERE
	JUMPE	LPSA,STRG1		; (IF ANY LEFT)
	MOVEI	D,0			;UNIQUELY CREATED AS REFERENCE
	PUSH	P,INTRET		; PARAMS
;	PUSHJ	P,INTLOP
>;REN
INTLOP:
REN <
	TDNE	D,$TBITS(LPSA)		;THIS TIME?
	JRST	 GOLEFT			; NO, WAIT FOR LOWER SEGMENT
>;REN
	HRLZ	B,$ADR(LPSA)		;FIXUP
	JUMPE	B,NOINT			;NOT USED
	HRR	B,PCNT
	PUSHJ	P,FBOUT
	MOVE	A,$VAL(LPSA)		;VALUE
	PUSHJ	P,CODOUT		;A WORD FOR IT.
NOINT:	
REN <
	PUSHJ	P,URGCNM		;REMOVE FROM RING
GOLEFT:
>;REN
	LEFT	,%RVARB,INTRET
	JRST	INTLOP			;LOOP UNTIL DONE.
INTRET:
REN <
	POPJ	P,.+1
STRG1:	PUSHJ	P,HISET			;BACK TO UPPER
>;REN

STRGO:	HRRZ	LPSA,CONSTR		;STRING CONSTANT RING.
	JUMPE	LPSA,BILGO
STRLOP:
NOGAG <;PRELOADS WILL NEED SPECIAL ATTENTION HERE IN "GOGOL"
	MOVS	B,$ADR(LPSA)		;FIXUPS
	JUMPE	B,[SKIPN B,$VAL(LPSA)	;SEE IF STORED IN PRE-LOADED ARRAY
		   JRST NOSTR		;NOT USED AT ALL.
		   HRR B,PCNT		;NOW XWD FIXUP,,PCNT
		   PUSHJ P,FBOUT	;EMIT IT.
		   JRST PUTIT]
	HRLZ	B,$ADR(LPSA)		;FIXUP FOR FIRST WORD.
	JUMPE	B,.+3
	HRR	B,PCNT
	PUSHJ	P,FBOUT
	HRRZ	A,$PNAME(LPSA)		;COUNT OF CHARACTERS.
	PUSHJ	P,CODOUT
	HLLZ	B,$ADR(LPSA)		;FIXUP FOR SECOND WORD.
	JUMPE	B,.+3
	HRR	B,PCNT
	PUSHJ	P,FBOUT			;OUTPUT THE FIXUP.
	JUMPE	A,NOSTR			;IN CASE NULL FLIES BY.
	HRLI	A,(<POINT 7,0>)		;BYTE POINTER
	HRR	A,PCNT
	ADDI	A,1			;POINT TO .+1
	SKIPN	B,$VAL(LPSA)		;FIXUP FROM PRE-LOADED ARRAY IF ANY.
	JRST	.+3
	HRR	B,A			;THE PCNT FOR ASCII
	PUSHJ	P,FBOUT			;GO GUYS.
	TLO	FF,RELOC
	PUSHJ	P,CODOUT
	TLZ	FF,RELOC
PUTIT:	HRRZ	B,$PNAME(LPSA)		;COUNT AGAIN.
	ADDI	B,4
	IDIVI	B,5			;B HAS NUMBER OF WORDS.
	HRRZ	C,$PNAME+1(LPSA)	;POINTER TO FIRST WORD.
STLL:	MOVE	A,(C)
	PUSHJ	P,CODOUT
	AOS	C
	SOJG	B,STLL
>;NOGAG
NOSTR:
	LEFT	,%RVARB,BILGO
	JRST	STRLOP			;LOOP FOR ALL STRINGS.



;3

BILGO:	
NOGAG < ;WILL GET ADDRESSES DIRECTLY FROM SYMBOL TABLE IN "GOGOL"
	MOVE	LPSA,VARB
	CAIE	LPSA,RESYM		;IT SHOULD BE HERE
	ERR	<DRYROT -- DONES>
BILOP:	HRRZ	B,$ADR(LPSA)		;FIXUP
	JUMPE	B,BILR
	TLNE	FF,CREFSW		;CREFFING??
	PUSHJ	P,CREFDEF		;DEFINE THIS SYMBOL.
	PUSHJ	P,SOUT			;GENERATE EXTERNAL REQUEST
BILR:	LEFT	,%RVARB,LIBGO
	JRST	BILOP			;LOOP UNTIL DONE

;4
; IF GAG, WILL GET ADDRESSES DIRECTLY (MOVEI)

LIBGO:	MOVEI	C,0
LIBLOP:	SKIPN	B,LIBTAB(C)		;FIXUP FOR THIS FCN.
	JRST	NONT
YESLIB:	MOVSS	B
	MOVE	A,LIBNAM(C)		;RADIX50 FOR THIS FCN.
	PUSHJ	P,SCOUT			;GENERATE THE REQUEST.
NONT:	AOS	C
	CAIE	C,LIBNUM
	JRST	LIBLOP			;LOOP UNTIL DONE.

;5

	HRROI	TEMP,SALIB+1		;FAKE STRING DESCRIPTOR FOR SAIL LIBRARY
REN <
	SKIPE	HISW			;WANT RE-ENTRANT LIBRARY?
	HRROI	TEMP,SALIBH+1		;YES
>;REN
	POP	TEMP,PNAME+1
	POP	TEMP,PNAME
	MOVEI	B,LBTAB		;PUT OUT LIBRARY SEARCH 
	PUSHJ	P,PRGOUT		; REQUEST

;6

	PUSHJ	P,FRBT			;FORCE BINARY.
	
	MOVEI	B,FXTAB
	PUSHJ	P,GBOUT			;AND FIXUPS.

	MOVEI	B,SMTAB
	PUSHJ	P,GBOUT			;AND SYMBOLS.

	MOVEI	B,PRGTAB
	PUSHJ	P,GBOUT			;AND PROGRAM/LIBRARY REQUESTS

	MOVEI	B,LBTAB
	PUSHJ	P,GBOUT

;7
;NOW OUTPUT THE SPACE ALLOCATION BLOCK.

	MOVE	A,PCNT
	MOVEM	A,SPCPC		;PCNT FOR SPACE BLOCK.
	MOVEM	A,SLNKWD	;AND FOR LINK WORD.
	HRRZ	TEMP,SPCTBL	;NUMBER OF WORDS OF DATA
	ADDI	A,(TEMP)	;NUMBER OF WORDS IN OBJECT MODULE
	MOVEM	A,PCNT
	MOVEI	B,SPCTBL	;SPACE TABLE
	AOS	TEMP,SPCTBL	;ONE MORE (A ZERO)
	MOVEI	A,=18
	CAIG	A,(TEMP)
	HRRM	A,SPCTBL	;MAKE SURE NO OVERFLOW HAPPENS
	PUSHJ	P,GBOUT

	MOVEI	TEMP,2		;SPACE BLOCK IS TYPE 2
	MOVEM	TEMP,LNKNM
	MOVE	B,SDSCRP	;LINK BLOCK
	PUSHJ	P,GBOUT		;AND LINK (LINK NUMBER 2)


	MOVE	B,EBDSC		;ASSUME SHOULD WRITE START ADDR, ETC.
	TLNN	FF,MAINPG		;A STARTING ADDRESS?
	 MOVE	 B,EBDSC1	;NO, NO START ADDR, NO INIT CODE FIXUPS
REN <
	PUSHJ	P,HISET			;BE SURE PCNT IS IN UPPER SEGMENT
	MOVE	A,[XWD 5,2]		;ASSUME TWOSEG END BLOCK
	MOVE	TEMP,[IORM A,STRDDR]	;PUT CONSTANT SYMS INTO HI SEG
	SKIPE	HISW			;RIGHT?
	 JRST	 TSEND			;RIGHT
	MOVE	TEMP,[ANDCAM A,STRDDR]	;PUT CONSTANT SYMS INTO LOW SEG
	MOVE	A,[XWD 5,1]		;ONESEG END BLOCK
	SUB	B,[XWD 1,0]		;ONE FEWER WORDS TO WRITE
TSEND:	MOVEM	A,PRGBRK-2		;TO CODE WORD OF LOADER BLOCK
	MOVEI	A,400000		;SEGMENT CONTROL BIT
	XCT	TEMP			;STARTING ADDRESS INTO RIGHT SGMNT
	HRRI	TEMP,CONSYM+1		;NOW
	XCT	TEMP			; PUT S., RPGSW, SAILOR REQUESTS
	ADDI	TEMP,2			; INTO PROPER SEGMENT (SEE TOTAL,
	XCT	TEMP			; UNDER LOADER OUTPUT BLOCKS
	ADDI	TEMP,4			; -- END BLOCKS SECTION
	XCT	TEMP
	MOVE	A,HCNT			;YES, GET CODE COUNT
	MOVEM	A,PRGBRK+1		;LOW SEG BREAK IF TWO SEGMENTS
>;REN
	MOVE	A,PCNT			;ONLY OR HIGH SEG BREAK
	MOVEM	A,PRGBRK
	PUSHJ	P,GBOUT			;WRITE THE END BLOCKS.

>;NOGAG
;TEMP ****** FOR TESTING SLS
SLS <
	GEN
	SALCAL	(SLSTST,<LINKS>,<PNAME>)
>;SLS
	POPJ	P,			;ALL DONES
COMMENT ⊗MEMORY  and LOCATION EXECS, ALSO UINCLL⊗
↑↑ZBITS:  SETZM	BITS
	POPJ	P,
↑↑MEMI:	SKIPA	TBITS,[INTEGR]
↑↑MEMS:	MOVE	TBITS,BITS
	TDNE	TBITS,[XWD PROCED!SBSCRP,STRING];ILLEGAL TYPES
	ERR	<ILLEGAL DATA TYPE FOR MEMORY>,1
	PUSHJ	P,TYPDEC		;GET PARSE   TOKEN
	MOVEM	A,PARRIG		;PUT IT AWAY
	MOVE	PNT,GENLEF+1		;THE EXPRESSION GUY
	MOVE	SBITS,$SBITS(PNT)	;SEMANTICS OF THE EXPRN
	HRRZ	TEMP,$TBITS(PNT)	;IT BETTER BE INTEGER
;;#JY# RHT (11-2-72) ↓ TURN OFF SHORT
	TRZ	TEMP,SHORT		;TTURN OFF SHORT
	TLNN	SBITS,NEGAT		;AND NOT NEGATIVE
	CAIE	TEMP,INTEGR
	JRST	COERCI
	TLNE	SBITS,INAC		;LOADED?
	JRST	ITSINA			;YES
	TLNE	SBITS,ARTEMP		;IF NOT A TEMP
	TLNE	SBITS,INDXED		;OR INDEXED TEMP
	JRST 	LODIT			;THEN LOAD IT
	TLO	SBITS,INDXED		;MAKE INDEXED TEMP
	MOVEM	SBITS,$SBITS(PNT)	;
	MOVEM	TBITS,$TBITS(PNT)	;
	SETZM	$VAL(PNT)		;
	POPJ	P,
LODIT:	PUSHJ	P,GETAN0		;GET AN AC
	EMIT	<HRRZ>			;LOAD IT
MAKTMP:	HRLZI	SBITS,PTRAC!INDXED
	PUSHJ	P,GETTEM
	HRRZM	LPSA,ACKTAB(D)		;REMEMBER IT
	HRRM	D,$ACNO(LPSA)
	MOVEM	LPSA,GENRIG
	POPJ	P,
ITSINA:	HRRZ	D,$ACNO(PNT)		;GET AC #
	PUSHJ	P,REMOPA		;IF TEMP, REMOP IT
;;#JV# ↓ (10-20-72) RHT CANNOT USE AC0
	JUMPE 	D,LODIT			;
	TLZ	SBITS,INAC		;
	MOVEM	SBITS,$SBITS(PNT)	;THIS WONT BE INAC ANY MORE
	JRST	MAKTMP			;NICE, NEW TEMP
COERCI:	PUSH	P,TBITS			;
	MOVEI	B,INTEGR
	GENMOV	(GET,POSIT!INSIST!GETD)
	PUSHJ	P,REMOP			;DONE OLD THING
	POP	P,TBITS
	JRST	MAKTMP			;NEW TEMP


↑↑LOCN:	MOVE	PNT,GENLEF+1		;
	PUSHJ	P,GETAD
	TLNN	SBITS,PTRAC		;IF PTRAC THEN LEAVE ALONE
	PUSHJ	P,INCOR			;GET THE THING TO CORE
	GENMOV	(GET,ADDR)		;ADDRESS OF THIS
	PUSHJ	P,REMOP
	MOVEI	TBITS,INTEGR
	HRLZI	SBITS,INAC
	GENMOV	(MARK,0)
	MOVEM	PNT,GENRIG
	PUSHJ	P,TYPDEC
	MOVEM	A,PARRIG
	POPJ	P,

↑UINCLL: PUSHJ P,ALLSTO			;FLUSH ACS
	XCALL	(.UINITS)		;EMIT CALL TO USER INITIALIZATIONS
	POPJ	P,

DSCR MAKBUK, FREBUK
CAL PUSHJ
PAR current value of SYMTAB
DES MAKBUK allocates a new Semblk, copies current Symtab
  bucket list into it; saves a pointer to the old one --
  see main SAIL data descriptions for details.  This is
  how scope is handled, because...
 FREBUK deletes this Semblk, restores old pointer.  It is
  up to somebody else (ALOT) to delete all the local Semblks
   which are no longer available via SYMTAB
 This junk is unnecessary for STRCON and CONST buckets, since
  all such entities are global (one bucket list)
SEE main SAIL data definitions in SAIL
SEE BLOCK, UP1, UP2, etc.
⊗
↑MAKBUK:
	GETBLK				;MAKE A NEW BLOCK
	EXCH	LPSA,SYMTAB		;SYMTAB IS NOW UPDATED
	HRLI	PNT,(LPSA)
	HRR	PNT,SYMTAB		;PREPARE TO BLT
	HRRZM	LPSA,BLKLEN-1(PNT)	;TIE TO OLD ONE
	MOVE	TEMP,PNT
	BLT	PNT,BLKLEN-2(TEMP)	;COPY BUCKET
	POPJ	P,


↑FREBUK:
	MOVE	LPSA,SYMTAB
	HRRZ	A,BLKLEN-1(LPSA)	;TIE
	MOVEM	A,SYMTAB
	FREBLK				;RELEASE THE BLOCK
	POPJ	P,


BEND GENDEC
SUBTTL	ERROR MESSAGE EXECS

BEGIN	ERRORS

;THE FIRST ROUTINE ALWAYS PRINTS OUT A NEAT MESSAGE....

DEFINE	XX (NAME,MESSG,CODE) <     
↑ NAME : ERR.	1,[ASCIZ/MESSG/]
	 TLNN	FF,ERSEEN
	 POPJ	P,
	 SKIPE	CODE
	 POPJ	P,		;IF CODE=0, THEN WE RECOVERED SAFELY
	 TLO	FF,ERSEEN
	 TLZ	FF,BINARY
	TERPRI	<IRRECOVERABLE ERROR.NO REL FILE WILL BE PRODUCED.>
	;******STUFF TO CLOSE THE FILE????
	>

XX (ER1,<START YOUR PROGRAM WITH BEGIN OR ENTRY - WILL SCAN FOR BEGIN.>,1)
XX (ER2,<BAD ENTRY STATEMENT - WILL SCAN FOR BEGIN.>,1)
XX (ER3,<YOU SEEM TO HAVE USED A , INSTEAD OF A ; BETWEEN DECLARATIONS.>,0)
XX (ER4,<BOGUS IDENTIFIER IN IDENTIFIER LIST.>,1)
XX (ER5,<INSERTING FORGOTTEN SEMI-COLON.>,0)
XX (ER6,<DELETED EXTRA SEMI-COLON.>,0)
XX (ER7,<SYNTAX ERROR. CURRENT STATEMENT OR DECLARATION WILL BE FLUSHED.>,2)
XX (ER8,<SYNTAX ERROR AT END OF EXPRESSION - WILL CHECK FOR PARENTHESES MISMATCH.>,0)
XX (ER15,<ARRAYS SUBSCRIPTING USES BRACKETS!  PARENTHESIS REPLACED.>,0)
XX (ER24,<YOU CAN NOT BEGIN A DECLARATION OR STATEMENT LIKE THIS.>,1)
XX (ER33,<NEED AN "UNTIL" AFTER THE STATEMENT OF A "DO ...UNTIL ...">,1)
XX (ER34,<BAD BLOCKING - TOO FEW ENDS.>,1)
XX (ER35,<UNDECLARED ARRAY>,0)
XX (ER36,<MISSING ( INSERTED.>,0)
XX (ER37,<EXTRA ) DELETED.>,0)
XX (ER38,<REQUIRE A BOOLEAN OR AN ALGEBRAIC EXPRESSION HERE.>,1)
XX (ER39,<REQUIRE A CONSTANT ALGEBRAIC EXPRESSION HERE.>,1)
XX (ER40,<INSERTED MISSING ).>,0)
XX (ER41,<YOU CANNOT BEGIN AN EXPRESSION LIKE THIS.>,1)
XX (ER48,<MISSING RIGHT CURLY BRACKET INSERTED.>,0)
XX (ER59,<NEED AN ASSOCIATIVE EXPRESSION HERE.>,1)
XX (ER66,<USE A BEGIN OR A ( AFTER A CASE.>,1)
XX (ER68,<YOU FORGOT TO INCLUDE THE CONTEXT.>,1)
XX (ERTRAP,<QTRAP: ACCORDING TO THE PRODUCTIONS, ITS IMPOSSIBLE FOR TO HIT THIS. SEE A SAIL HACKER>,1);


DEFINE YY (NAME,MESSG) <
↑NAME:		TERPRI	<MESSG>
		POPJ 	P,
  	>
YY (ERR101,<STATEMENT FLUSHED.>)               
YY (ERR102,<BLOCK FOUND WHILE FLUSHING STATEMENT - WILL TRY TO PARSE IT.>)
YY (ERR103,<EXTRA ) DELETED.>)             
YY (ERR104,<MISSING ) INSERTED.>)             
YY (ERR105,<BLOCK END OKAY - FLUSH OF STATEMENT CONTINUES.>)
YY (ERR106,<MISSING ; INSERTED.>)      
YY (ERR107,<SORRY - CAN'T CONTINUE.>)
YY (ERR108,<DISREGARD THE ABOVE AND REMEMBER TO USE BRACKETS ON ARRAYS.>)
YY (ERR109,<CVMS TAKES AS AN ARGUMENT A MACRO NAME - PARAMETERS ARE IGNORED>)
YY (ERR110,<DECLARATION TAKES AN IDENTIFIER AS AN ARGUMENT - FLUSH REST OF STATEMENT>)
YY (ERR111,<CHECK_TYPE ONLY TAKES VALID DECLARATIONS OR PARTS OF DECALRATIONS AS ARGUMENTS - FLUSH REST OF STATEMENT>)


XX (ERR112,<BIND USED INCORRECTLY, WILL BE IGNORED>)
XX (ERR113,<PROPS REQUIRES SINGLE ITEM EXPR AS ARGUMENT>)
XX (ERR114,<PROPS MAY BE ASSIGNED ONLY ARITHMETIC VALUES>)
XX (ERR115,<MISSING ARRAY BOUND-PAIR LIST>)


DSCR SCNBAK,POPBAK,KILPOP,QREM2,QTYPCK;
PRO SCNBAK,POPBAK,KILPOP,QREM1,QREM2,QTYPCK;
DES Error recovery execs:
SCNBAK: backs scanner up by one token.
POPBAK: returns you to the previous production.
KILPOP: returns the production control stack (stack for the ↑EX and ↓↓ stuff)
to its pristine state.
QREM1,QREM2: Called at the end of a block to delete untyped identifiers still left
on the VARB ring.
QTYPCK: Called from PRE in TOTAL. Every time one GENMOVs with CONVRT on, QTYPCK     
checks to see if the type bits of either the source or destination are zero in the
rh, and gives the untyped one the type of the other. If the source is undeclared,
then QTYPCK corrects the source, and if the source is a temp, it corrects the 
procedure or array that generated the temp.
⊗


;BACKS THE SCANNER UP BY ONE TOKEN
↑SCNBAK: MOVE	A,PARLEF
	MOVEM	A,SAVPAR
	MOVE	A,GENLEF
	MOVEM	A,SAVSEM
	TLO	FF,BAKSCN		;SCANNER IS AHEAD.
	POPJ	P,

;RETURNS YOU TO THE PREVIOUS PRODUCTION 
↑POPBAK: MOVE	A,SAVPOP
	MOVEM	A,-2(P)			;PRODUCTION POINTER.
	POPJ	P,

;FLUSHS THE PRODUCTION CONTROL STOCK (used for the ↑EX, ↓↓ stuff)
↑KILPOP:
	MOVE 	TEMP,PCSAV	; GET PRODUCTION CONTROL STACK POINTER
KPJ:	SKIPGE	-1(TEMP)	; IS THIS THE JUMP TO PARSE
	JRST	KILDUN		; YES, LEAVE IT AND GO HOME
	POP	TEMP,-1(TEMP)	; NO, GO DOWN ONE
	JRST	KPJ
KILDUN:	MOVEM	TEMP,PCSAV
	POPJ	P,


;CALLED AT THE END OF A BLOCK TO DELETE THE UNTYPED IDENTIFIERS(EXCEPT PROCEDURES)
↑QREM1:	SKIPA	LPSA,GENLEF+1		; GET THE BLOCK
↑QREM2:	MOVE	LPSA,GENLEF+2	
	JUMPE	LPSA,QFIN		; THIS BEGIN HASN'T A BLOCK SEMBLK
QL:	HRRZ	LPSA,%RVARB(LPSA)	; GO RIGHT ON VARB RING...
QL1:	JUMPE	LPSA,QFIN		; UNTIL YOU GET TO THE END.
	HRRZ	TBITS,$TBITS(LPSA)	; THE TYPE...
	JUMPN	TBITS,QL		; IS OKAY...
	TRNE	TBITS,PROCED		; DON'T KILL IT IF IT'S A PRODEDURE
	JRST	QL			
	HRRZ	TBITS,%RVARB(LPSA)	;SAVE THE NEXT GUY..........
	PUSHJ	P,DESTRO		; KILL THE BASTARD!
	MOVE	LPSA,TBITS
	JRST	QL1
QFIN:	POPJ	P,

;DESTROYS AN IDENTIFIER - REMOVES FROM VARB RING - NULLIFIES HASH AND STR RING
↑QDESID:
	MOVE	LPSA,GENLEF+1	; GET THE FATED IDENTIFIER
DESTRO:	PUSHJ	P, URGVRB	; UNRING IT
	SETZM	 ,$PNAME(LPSA)	; CHANGE ITS NAME TO SOMETHING ABSURD
	SETZM	$PNAME+1(LPSA)
	POPJ	P,		; AND RETURN


;CALLED FROM PRE OF GENMOV - CHANGES UNTYPED TO A REASONABLE TYPE
↑QTYPCK:
	TRNN	TBITS,-1	; IS THE SOURCE OF UNDECLARED TYPE
	JRST	QMATCH		; YES, GO GIVE IT THE DESTINATIONS TYPE
	TRNE	B,-1		; IS THE DESTINATION UNTYPED
	POPJ	P,		; NO, GO HOME
	HRR	B,TBITS		; YES, GIVE IT THE SOURCE TYPE
	POPJ	P,

QMATCH:
 	HLR 	TBITS,$SBITS(PNT)	; GET SOURCE SEMANTICES
	HRRM	B,$TBITS(PNT)		; GIVE THE SOURCE THE DESTINATION TYPE
	TLNN	TBITS,INAC!ARTEMP!INUSE	; IS IT A TEMP	
	JRST	.+3			; NO, GO BACK
	HLR	TBITS,%TLINK(PNT)	; GET THE ARRAY OR PROCEDURE
	HRRM 	B,$TBITS(TBITS)		; GIVE IT THE GOOD TYPE
	HRR	TBITS,B			; GIVE TBITS THE GOOD TYPE
 	POPJ	P,


DSCR  UNDEC -- Undeclared identifiers;
PRO   UNDEC;
DES  Declares an identifier globally or locally and modifies symbol table nicely.
When the token I is scanned at the identifier switch areas S1 and EX1 in
HEL, we call UNDEC. Since TYPDEC (called by the scanner) returns I if there are
no type bits on, we may have merely an untyped identifier, so we don't need to 
declare it again. Otherwise, we create an empty semblk, then link it on the
appropriate varb ring, hash bucket and string ring for global or local declaration.
We make the assumption that the user has declared something in the global block,
and thus use the block semblk referenced by QQBLK which is loaded at the first
call of the exec BLOCK.
⊗

;ENTERS IDENTIFIER ON LOCAL OR GLOBAL LEVEL
↑UNDEC:	SKIPE	A,GENLEF		; IF THE THING IS DECLARED...
	POPJ	P,			; THEN GO BACK ELSE...
	PRINT	<UNDECLARED IDENTIFIER: >
	HRRI	A,PNAME			; STUFF TO PRINT THE PNAME OF THE ID
	HRRZ	B,(A)
	MOVE	A,1(A)
	JRST	QPRSL1
QPRSL:	ILDB	C,A
	TTCALL	1,C
QPRSL1:	SOJGE	B,QPRSL
	ERR 	< >,1			; PRINT REST OF ERROR MESS

	TERPRI	<DO YOU WANT THIS DECLARED IN THE OUTER-MOST BLOCK?>
	PRINT	<(TYPE Y OR N)→ >
	TTCALL	0,B			; GET HIS RESPONSE
	TERPRI				; CRLF
	CAIL	B,"a"			; LOWER CASE?
	SUBI	B,40			; CONVERT TO UPPER
	CAIN	B,"N"			; NO?
	JRST	LOCA			; WHAT A CHICKEN!
	CAIE	B,"Y"			
	JRST	.-8			; PLEASE TYPE Y OR N...
	JRST	GLOBA			; DECLARE IT GLOBALY
LOCA:	SKIPN	QQBLK			; IF HE HASN'T DECLARED ANYTHING
	TERPRI	<YOUR PROGRAM WILL END FUNNY -- NEXT TIME DECLARE YOUR IDENTIFIERS>
     	HRRZI	A,INTEGR		; SOMETHING SIMPLE TO DECLARE
	MOVEM	A,BITS
	PUSHJ	P,ENTERS		; GO MAKE IT
	MOVE	A,NEWSYM		; GET IT BACK
	MOVEM	A,GENRIG		; PUT IT OUT
	POPJ	P,			; RETURN

GLOBA:	SKIPN	PNT,QQBLK		; GET THE HIGHEST BLOCK WITH DECLARATION
	JRST    LOCA			; WE  ARE THE HIGHEST BLOCK
	GETBLK	NEWSYM			; GET A NEW SEMBLK
	MOVE	LPSA,NEWSYM		
	HRROI	PNT2,PNAME+1		; PDP FOR NAME
	POP	PNT2,$PNAME+1(LPSA)
	POP	PNT2,$PNAME(LPSA)
	PUSHJ	P,RNGSTR		; PUT IT ON THE STRING RING
	HRRZ	PNT,%RVARB(PNT)		; THE FIRST MEMBER OF BLOCK'S VARB RING
	HRRZ	PNT2,$SBITS(PNT)	; GET THE LEVELS,ZERO THE SBITS
	MOVEM	PNT2,$SBITS(LPSA)
	HRLM	LPSA,%RVARB(PNT)	; LPSA ← 1ST
	HRRM	PNT,%RVARB(LPSA)	; LPSA → 1ST
	MOVE	PNT,QQBLK		; GET THE HIGHEST BLOCK
	HRRM	LPSA,%RVARB(PNT)	; BLK → LPSA
	HRLM	PNT,%RVARB(LPSA)	; BLK ← LPSA
	
      	MOVE	PNT,HPNT		; GET HASH(BUCK(QQBLK)) INTO B
	SUB 	PNT,SYMTAB		; CORRECT ADDRESS TO...
	MOVE	C,PNT			; GENERALIZED HPNT FOR LATTER
	MOVE	PNT2,QQBLK	
	HRRZ 	PNT2,%TBUCK(PNT2)
	ADD 	PNT,PNT2 		; ... TO THE OUTER LEVEL
	XCT	PNT			
	HRRZ 	B,LPSA			; B = HASH(BUCK(QQBLK))
	HRRZ	A,SYMTAB		; INITIALIZE 

;GO UP THE BLOCKS, FIXING THE HASH BUCKETS OR HASH CHAINGS THAT USED TO PT TO B
HASHL:	MOVE	PNT,C			; GET GENERAL HPNT
      	ADD 	PNT,A			; CORRECT HPNT TO THIS LEVEL
	XCT	PNT			; LPSA → HEAD OF HASH CHAIN THIS BUCKET
	HRRZ    PNT2,LPSA
	CAMN	B,PNT2			; DOES B = HASH(BUCK(A)) ?
	JRST	BUCIT			; YES,GO FIX THIS BUCKET
	SKIPN	QQFLAG			; NO, FIX THE CHAIN. 
	JRST	UPBUCK			; WE ALREADY FIXED THE CHAIN,GO UP A BLOCK

	SETZM	QQFLAG			; MAKE SURE WE ONLY DO THIS ONCE
UPCHAI:	MOVE	PNT,PNT2	; FIND THE TOP GUY OF THE CHAIN BEFORE QQBLK LEVEL
	HRRZ	PNT2,%TBUCK(PNT2)	;  GO UP
	CAME	B,PNT2		; ARE WE AT QQBLK LEVEL YET?
	JRST	UPCHAI			; NO, GO UP THE CHAIN
       	HRRZ	PNT2,NEWSYM		; GET THE GUY
	HRRM	PNT2,%TBUCK(PNT)	; TOP-NOT-ON-QQBLK-GUY → UNDECLARED-GUY
	HRRM	B,%TBUCK(PNT2)	; UNDECLARED-GUY → 1ST-OF-QQBLK-LEVEL-GUY
	JRST	UPBUCK			; FINE, GO UP A BUCKET


BUCIT:	MOVE	PNT2,NEWSYM		; WE ARE GOING TO FIX THE BUCKET BY
	HRRM	LPSA,%TBUCK(PNT2)	; DOING A REGULAR HASH
	HRR	LPSA,PNT2
	TLO	PNT,2000
	XCT	PNT
	JRST	UPBUCK			; GO UP A BUCKET

UPBUCK:	MOVE 	PNT,QQBLK		; GET THE TOP BUCKET
	HRRZ	PNT,%TBUCK(PNT)		
	CAMN	A,PNT			; ARE WE AT THE TOP
	JRST	.+3			; YES, GO HOME
	HRRZ	A,BLKLEN-1(A)		; NO, GO UP A BUCKET
	JRST	HASHL			; NO TRY AGAIN
	MOVE	PNT,NEWSYM		; PUT OUT, RESTORE, AND QUIT
	MOVEM	PNT,GENRIG
	SETOM	QQFLAG
	POPJ	P,
 
 
↑↑QQFLAG:0
↑↑QQBLK: 0 

DSCR  QDEC0,1,2   QARSUB  QARDEC QPARM QPRDEC;
PRO QDEC0,QDEC1,QDEC2,QSUBSC,QARDEC,QPARM,QPRDEC.
DES These execs finish the declaration of an undeclared identifier by giving
it a type and appropriate goodies. The QDEC execs determine the type from the token
put in PARRIG by the productions. If we need an array, we count the dimensions with
QSUBSC, install them and put out a temp in QARDEC. If we need a procedure, we get a
second semblk in QDEC, ring on formals in QPARM, install parmeter counts in QPRDEC,
and jrst to QARDEC to generate a temp (we assume all procedures are integer 
functions).
⊗


;EXECS TO SET THE TBITS FROM THE PARSE TOKEN
↑QDEC2:	MOVEI	A,0			; RIGHT - TOP
	JRST	.+4
↑QDEC0:	SKIPA	A,[0]			; RIGHT - ONE DOWN
↑QDEC1: SKIPA	A,[1]			; RIGHT - ONE DOWN
	SKIPA	B,[0]			; LEFT - TOP
	MOVEI	B,1			; LEFT - ONE DOWN
	HRRZ 	PNT, PARRIG(A)		; GET IT
	MOVEI	TBITS,0
	CAMN	PNT, %ILB		; LABEL
	JRST   [TRO TBITS,LABEL+FORWRD
		TERPRI <UNDECLARED IDENTIFIER DECLARED A LABEL>
		JRST .+15]
	CAMN	PNT,  %ISV		; SET
	JRST   [TRO TBITS,SET
		TERPRI <UNDECLARED IDENTIFIER DECLARED A SET>
		JRST .+13]
	CAMN	PNT,%ARID		; AN ARRAY
	JRST   [TLO TBITS, SBSCRP!SAFE
		TERPRI <UNDECLARED IDENTIFIER DECLARED AN ARRAY>
		JRST .+11]
	CAMN	PNT,%PCALL		; A PROCEDURE
	JRST	.+4
	CAMN	PNT,%S			; ANOTHER PROCEDURE
	JRST	.+2
	CAMN	PNT,%FCALL		; YET ANOTHER PROCEDURE
	JRST    [MOVE  TBITS, [XWD EXTRNL,PROCED!INTEGR]
		TERPRI <UNDECLARED IDENTIFIER DECLARED A INTEGER PROCEDURE>
		JRST .+3]
	CAMN	PNT,%ITV		; ITEMVAR
	JRST   [TRO  TBITS, ITMVAR!INTEGR
		TERPRI	<UNDECLARED IDENTIFIER DECLARED AN INTEGER ITEMVAR>
		JRST .+1]
					; IVB GETS NO BITS
	CAME	PNT,%S			; DONT TURN ON THE CLASIDX IF S
	HRLI	PNT,CLSIDX		; ALL VARIABLES ARE CLASS MEMBERS
	MOVEM	PNT,PARRIG(A)	; PUT IT OUT
	MOVE	PNT,GENLEF(B)		; GET THE UNDECLARED GUY (from UNDEC)
	TLNE	TBITS, SBSCRP	; IS IT AN ARRAY
	SETZM	,DIMNO		; YES, ZERO THE NUMBER OF DIMENSIONS
	TRNE	TBITS,PROCED	; IF ITS A PROCEDURE...
	JRST   [GETBLK			; GET A 2D BLOCK
		HRLM	LPSA,%TLINK(PNT)   ; PUT A PNTR TO IT IN TLINK OF PROC
		MOVEW	%%VARB,VARB	; SAVE THE CURRENT VARB
		SETZM	    VARB	; INITIALIZE A NEW VARB
		JRST	.+1]
	MOVEM	TBITS,$TBITS(PNT)	; GIVE IT ITS TYPE
	MOVEM	PNT,GENRIG(A)
	POPJ	P,

%%VARB:0

↑QSUBSC:
	AOS	,DIMNO		; COUNT DIMENSIONS
	MOVE	PNT, GENLEF +1	; THE EXPRESSION TEMP ..
	PUSHJ	P,REMOP		; GETS REMOVED
	POPJ	P,
DIMNO:	0

↑QARDEC:
	MOVE 	PNT2,GENLEF+2	;GET THE ARRAY (OR PROCEDURE)
	MOVE	PNT,DIMNO	; GET #OF DIMENSIONS
	HRLM	PNT,$ACNO(PNT2)	;  RECORD IT
	MOVEI	TBITS,0		; TYPE IT
	MOVEI	D,1		; DUMMY AC NUMBER FOR ...
	PUSHJ	P,MARKME	;   CREATING A TEMP.
	HRL	PNT,PNT2	; →ARR (OR →PROC) IN %TLINK( the temp)
	MOVEM	PNT,GENRIG	; PUT IT OUT
	POPJ	P,





↑QPARM:	MOVE 	PNT,GENLEF+2		; GET THE PROCEDURE
	HLRZ	PNT2,%TLINK(PNT)	; THE SECOND BLOCK
	PUSH	P,PNT2			; SAVE IT
	MOVE	LPSA,GENLEF+1		; GET THE EXPRESSION
	HRRZ	TBITS,$TBITS(LPSA)	; GET ITS TYPE
	TLO	TBITS,VALUE		; MAKE ALL PARAMETERS VALUE...
	TRNE	TBITS,PROCED		; EXCEPT PROCEDURE EXPRESSIONS
	TLC	TBITS,VALUE!REFRNC	
	MOVEM	TBITS,BITS
	TRNE	TBITS,STRING		; IF IT IS A STRING
	AOS	,$NPRMS(PNT2)		; INCREMENT STRING PARM COUNT
	HLRZ	TEMP,$NPRMS(PNT2)	; ALWAYS INCREMENT ARITH PARM COUNT
	AOJ	TEMP,			
	HRLM	TEMP,$NPRMS(PNT2)
	GETBLK				; MAKE A FORMAL
	MOVEM	TBITS,$TBITS(LPSA)	; GIVE IT A TYPE
	PUSHJ	P,RNGVRB		; PUT IT ON THE VARB RING
	POP	P,PNT2			; GET 2ND BLOCK BACK
	SKIPN	%TLINK(PNT2)		; IS THIS THE FIRST FORMAL
	HRLM	LPSA,%TLINK(PNT2)	; YES, PUT A POINTER TO IT IN 
					; 2D BLOCK OF THE PROCEDURE
	MOVE	PNT,GENLEF +1		; GET THE EXPRESSION AND....
	JRST	REMOP			; KILL IT!!!!! , THEN RETURN QUIETLY


↑QPRDEC:
	MOVE	PNT,GENLEF+2	;GET THE PROCEDURE
	HLRZ	PNT2,%TLINK(PNT)	; GET THE 2D BLOCK
	HLRZ	TEMP,$NPRMS(PNT2)	; INCREMENT ARITH PARM COUNT
	AOJ	TEMP,
	HRLM	TEMP,$NPRMS(PNT2)	
	HRRZ	TEMP,$NPRMS(PNT2)	; STRING PARM COUNT * 2
	LSH	TEMP,1
	HRRM	TEMP,$NPRMS(PNT2)	
	MOVEW	VARB,%%VARB		; RESTORE CURRENT VARB
	JRST	QARDEC		; ASSUME FUNCTION (i.e. make a temp)





BEND
SUBTTL EXECS to handle string constants as comments

BEGIN SCOMM

DSCR SCOMM
PRO SCOMM
DES Remove the damage done by using a string constant
 as a comment preceding a statement  
⊗

COMMENT ⊗
last prod at S1:
STC → 		EXEC SCOMM SCAN ¬S1 #Q6
⊗

↑SCOMM:	GETSEM	(0)		;SEMANTICS OF CONSTANT
	TRNN	TBITS,STRING	;MUST BE A STRING CONSTANT
	 JRST	 [ERR	<I THOUGHT IT WAS A STRING COMMENT>,1
		  POPJ	P,]

;;#FL# 11-14-71 DCS (1-1)
	SKIPN	$VAL(PNT)	;HAS ANYONE USED THIS IN A PRELOAD?
	SKIPE	$ADR(PNT)	;OR HAS ANYONE USED THIS AS A STRING CONSTANT?
;;#FL#
	 JRST	 REMOP		; YES, NO MORE ACTION NECESSARY
	MOVE	LPSA,PNT
	PUSHJ	P,URGSTR	;REMOVE FROM BOTH RINGS
	PUSHJ	P,URGCST
	MOVE	B,HSPNT		;GET POINTER DOWN BUCKET LIST
	XCT	B		; (SEE HASH, ENTER)
	HRRZS	PNT
	MOVEI	PNT2,LPSA	;MUST PRESERVE LPSA CORRECTLY IN CASE
				; FIRST BLOCK IS DELETED.
SCOMLP:	HRRZ	TEMP,(PNT2)	;TEMP← LPSA FIRST TIME, →OTHER BLOCKS LATER
	JUMPE	TEMP,ERRSTC	;ERROR -- SHOULD FIND IT SOMEWHERE!
	CAMN	TEMP,PNT	;IS THIS THE ONE WE WANT TO REMOVE?
	 JRST	 SFNDIT		; YES
	MOVE	PNT2,TEMP	;NO, CONTINUE
	JRST	SCOMLP

SFNDIT:	HRRZ	TEMP,(TEMP)	;GET POINTER FROM BLOCK TO GO
	HRRM	TEMP,(PNT2)	;AND RELINK
	TLO	B,2000		;PUT BUCKET POINTER BACK IN CASE
	XCT	B		;IT CHANGED
	FREBLK	(PNT)		;REMOVE THE BLOCK
	POPJ	P,

ERRSTC:	ERR	<DRYROT AT SCOMM>,1

BEND	SCOMM
SUBTTL	START_CODE (inline) EXECS

BEGIN  INLINE

ZERODATA (START_CODE VARIABLES)

↓CODSEM: 0		;SEMANTICS OF ADDRESS FIELD (IF VBL)

↓CODVAL: 0		;VALUE OF ADDRESS, AC, INDEX FIELDS (CONST STUFF)

↓INSTBL: 0		;→SIXBIT TABLE OF OPCODES, IF HAS BEEN READ IN

↓OPCOD:  0		;OPCODE OF INSTRUCTION BEING ASSEMBLED

;OPDUN -- on if opcode field has been scanned.  Also used as flag
;   to EMITER that the instruction going out is a START_CODE 
;   produced intruction -- avoids optimizations of various forms
↑OPDUN:	0

DATA (START_CODE VARIABLES)

; THIS IS THE ENTER BLOCK FOR THE SIXBIT OPCODE TABLE USED TO
; ALLOW SYMBOLIC OPCODES IN START_CODE INSTRUCTIONS

TNAME:	OPNAME
	'OPS   '
TWORD3: 0
TPPN:	OPPPN
ENDDATA

DSCR CODNIT, WRDNIT, ONEWRD, SETSIX, SETOP, CODIND, CODREG, etc.
PRO CODNIT WRDNIT ONEWRD SETSIX SETOP CODIND CODREG CODLIT ERRCOL ERRCOM
DES These routines handle the START_CODE/QUICK_CODE syntax.
 The only surprise is a table of SIXBIT opcodes which are read in
  when needed.  No variable with the same name as one of these opcodes
  may be used within a CODE block.
⊗

↑CODNIT:
	JRST	.+1(B)			;START_CODE CLEARS, QUICK_CODE DOESN'T
	PUSHJ	P,ALLSTO		;CLEAR THE WORLD
;	JRST	WRDNIT			;FALL THROUGH

↑WRDNIT:
	SETZM	OPCOD			;OP, AC, INDEX, INDR COLLECTED HERE
	SETZM	OPDUN
	SETZM	CODVAL			;OPDUN IS A FLAG, CODVAL IF CONST
	SETZM	CODSEM			;SEMANTICS OF ADDR IF NON-CONST
;;#JU# RHT (DEL 1 LINE) -- DONT HURT ACKTAB 10-23-72
	MOVSI	TEMP,INLIN		;SET SPECIAL SCANNER BIT SO THAT
	ORM	TEMP,SCNWRD		; @ IS TREATED AS A DELIM,
					; (DCS -- 8/13/70)  PNAME+1 ZEROED
NOCODE:	POPJ	P,

↑ONEWRD:
	SKIPE	A,OPCOD
	HRRZS	CODVAL
	OR	A,CODVAL
	HRL	C,A
	HLLZS	A			;PUT OP CODE,UNRELOC ADDR IN PLACE
	SKIPN	OPDUN			;WAS ANYTHING SEEN?
	 JRST	 NOCODE			; NO, NULL STATEMENT
	SETOM	OPDUN			;TELL EMITER DOING INLINE CODE
	TRO	A,NOUSAC!USADDR!NORLC	;ASSUME CONSTANT ADDR FIELD
	SKIPN	PNT,CODSEM		;WELL, WHICH IS IT?
	 JRST	 EMITER			;EMIT IT
	MOVE	TBITS,$TBITS(PNT)	;GET BITS FOR FXTWO SET
	TRC	A,USADDR!NORLC!FXTWO	;ASSUME A STRING
;; #JRL# 9-19-72 A STRING ITEMVAR IS NOT A STRING
	TDNN	TBITS,[XWD SBSCRP,ITEM!ITMVAR]	;IF SBSCRP ∨ ¬STRING,
;; #JRL#
	TRNN	TBITS,STRING		; REVERSE ASSUMPTION
	TRZ	A,FXTWO
	JRST	EMITER			;GO EMIT CODE

↑SETSIX:
	MOVEI	A,0			;COLLECT SIXBIT
	HRRZ	TEMP,PNAME		;LENGTH
	JUMPE	TEMP,.+2		;IGNORE NULL STRINGS
	CAILE	TEMP,6			;MUST BE OPCODE-SIZED
	 POPJ	 P,			; NO PRINT NAME, NO SIXBIT
	MOVE	C,[POINT 6,A]
	MOVE	LPSA,PNAME+1		;BYTE POINTER TO STRING
LOOP:	SOJL	TEMP,LOKSIX		;GOT IT CONVERTED, LOOK IT UP
	ILDB	D,LPSA			;GET CHAR
	SUBI	D,40
	IDPB	D,C			;COLLECT SIXBIT
	JRST	LOOP

LOKSIX:
Comment ⊗ might be an OPCOD -- will assume it is if it is in
	the opcode table. To find out, we may have to read said
	table in. Then we will do a linear search to discover
	the correct instruction code ⊗

	SKIPE	B,INSTBL		;TABLE IN CORE?
	 JRST	 TABLIN			;YES, ADDRESS IN B
;;#GN# DCS 2-6-72 (1-1) INCLUDE UUO'S, STANFORD UUO'S
EXPO <
	SIZZZZ←←700-40
>;EXPO
NOEXPO <
	SIZZZZ←←724-40
>;NOEXPO
	MOVEI	C,SIZZZZ+4		;SIZE OF TABLE, PLUS BREATHING ROOM
;; #GN#
	PUSHJ	P,CORGET		;GET SOME SPACE FOR IT
	 ERR	 <DRYROT -- INLINE CODE>
	SUBI	B,1
	HRLI	B,-SIZZZZ		;IOWD -SIZE,ADDR-1 FOR OP TABLE
	MOVEM	B,INSTBL		;STORE ITS ADDRESS
	MOVEI	B+1,0		;END COMMAND LIST
	SETZM	TWORD3
	MOVE	TEMP,[OPPPN]
	MOVEM	TEMP,TPPN		;RESTORE OPCODE FILE PPN
	OPEN	17,[17
		    OPDEV
		     0]
	 ERR	 <DRYROT -- INLINE CODE>
	LOOKUP	17,TNAME
	 ERR	 <DRYROT -- INLINE CODE>
	INPUT	17,B			;READ THE OP TABLE
	RELEASE	17,

TABLIN:	

Comment ⊗ 
	B → current table entry (LH IS -COUNT)
	A will soon be sixbit for OPcode being sought
⊗


	MOVE	D,[CAME A,(B)]		;SET UP QUICK SEARCH LOOP
	MOVE	D+1,[AOBJN B,D]		;ITERATION CONTROL
	MOVE	D+2,[JRST TSTFND]	;OUT OF ACS
	AOJA	B,D			;INITIAL ADD

TSTFND:	JUMPGE	B,UNFNDOP		;SEARCH EXHAUSTED

FNDOPC:	SUB	B,INSTBL		;GET OP CODE IN OCTAL
;; #GN#
	ADDI	B,37			;ADJUST -- FIRST 40 NOT LOADED
;;#GN# (1-1)
	MOVEM	B,GENRIG		;STORE FOR A WHILE
	MOVE	TEMP,%OPC		;MARK OPCODE FOUND
	MOVEM	TEMP,PARRIG		;SAVE FOR PARSER
UNFNDOP: POPJ	P,


↑CODID:	SKIPN	PNT,GENLEF+1		;MUST BE DEFINED
	 ERR	 <UNDEFINED INSTRUCTION ELEMENT>,1,FRGET
	MOVNI	TBITS2,1		;ASSUME NO OPCODE SEEN YET
	HLLOS	TEMP,OPDUN		;MARK SOMETHING SEEN
	JUMPG	TEMP,MAYBOP		;NO OPCODE SEEN, MIGHT BE CNST OPCODE
NONOPC:	SKIPN	CODSEM			;CHECK TWO ADDRESS FIELDS
	SKIPE	CODVAL
	 ERR	 <TWO ADDRESS FIELDS>,1
	MOVEI	TBITS2,0		;OPCODE SEEN PREVIOUSLY
MAYBOP:	SETOM	OPDUN			;NO MORE OPCODES ALLOWED
	PUSHJ	P,GETAD
	TLNN	TBITS,CNST		;CONSTANT?
	 JRST	 CODVBL			; NO, MUST BE VARIABLE ADDR FIELD
	GENMOV	(CONV,INSIST,INTEGR)	;GET INTEGER CONSTANT
	MOVE	A,$VAL(PNT)
	JUMPL	TBITS2,STROPC		;OPCODE CONSTANT (ASSUME SO, ANYWAY)
	MOVEM	A,CODVAL		;NOT OPCODE, SAVE HERE
	JRST	REMOP			;DON'T NEED CONST ANY MORE
STROPC:	ORM	A,OPCOD		;NON-DESTRUCTIVE STORE
	JRST	REMOP			;DON'T NEED SEMANTICS

CODVBL:	TLNN	SBITS,FIXARR		;ACCEPT CNST-CNST-CNST ARRAY
	TLNN	SBITS,ARTEMP!STTEMP	; AND VARIABLES
	 JRST	 VBLOK
	ERR	<EXPRESSION NOT LEGAL AS INSTRUCTION ADDRESS>,1
VBLOK:	MOVEM	PNT,CODSEM		;SAVE SEMANTICS
	POPJ	P,


↑SETOP:	HLLOS	TEMP,OPDUN		;SET SOMETHING SEEN
	JUMPL	TEMP,TWOOP		;TWO OPCODES
	SETOM	OPDUN			;MARK OPCODE DONE
	MOVE	A,GENLEF
	DPB	A,[POINT 9,OPCOD,8]	;OPCOD POSITION
	POPJ	P,
TWOOP:	ERR	<TWO OPCODES>,1,FRGET

↑CODIND:
	HLLOS	OPDUN			;MARK SOMETHING SEEN
	MOVSI	TEMP,20			;INDIRECT BIT
	ORM	TEMP,OPCOD		;PUT IN OPCOD WORD
FRGET:	POPJ	P,

↑CODREG:
	HLLOS	OPDUN
	SKIPN	PNT,GENLEF+1		;MUST BE A CONSTANT
	 ERR	 <NON-CONSTANT AC FIELD>,1,REMOP
	GENMOV	(CONV,GETD!INSIST,INTEGR)
	TLNN	TBITS,CNST		;MUST BE A CONSTANT
	 ERR	 <NON-CONSTANT AC FIELD>,1,REMOP
	MOVE	TEMP,$VAL(PNT)		;GET ITS VALUE
	DPB	TEMP,[POINT 4,OPCOD,12]  ;DEPOSIT IN AC FIELD
	JRST	REMOP

↑CODX:	HLLOS	OPDUN
	SKIPN	PNT,GENLEF+1		;MUST BE A CONSTANT
	 ERR	 <NON-CONSTANT INDEX FIELD>,1,REMOP
	GENMOV	(CONV,GETD!INSIST,INTEGR)
	TLNN	TBITS,CNST
	 ERR	 <NON-CONSTANT INDEX FIELD>,1,REMOP
	MOVE	TEMP,$VAL(PNT)
	DPB	TEMP,[POINT 4,OPCOD,17]	;INDEX FIELD
	JRST	REMOP

↑CODLIT:
	HLLOS	OPDUN
	SKIPN	PNT,GENLEF+1
	 ERR	 <NON-CONSTANT LITERAL>,1,REMOP
	MOVE	TBITS,$TBITS(PNT)
	TLNN	TBITS,CNST
	 ERR	 <NON-CONSTANT LITERAL>,1,REMOP
	SKIPN	CODVAL		;CHECK FOR TWO ADDRESS FIELDS
	SKIPE	CODSEM
	 ERR	 <TWO ADDRESS FIELDS>,1,REMOP
CODBK:	MOVEM	PNT,CODSEM
	MOVSI	TEMP,INLIN		;TURN SPECIAL SCANNING BIT
	ORM	TEMP,SCNWRD		;BACK ON
	POPJ	P,

↑LITOFF: ;TURN OFF SPECIAL @ SCANNING BIT IN SCNWRD
;  (CALLED WHEN SCANNING LITERALS, AND WHEN LEAVING A
;   START_CODE BLOCK)
	MOVSI	TEMP,INLIN
	ANDCAM	TEMP,SCNWRD
	POPJ	P,


↑ERRCOL:
	ERR	<UNDEFINED LABEL OR BAD SYNTAX>,1
	POPJ	P,

↑ERRCOM:
	ERR	<COMMA USED IN WRONG MANNER>,1
	POPJ	P,

BEND INLINE
SUBTTL  COUNTER SYSTEM EXECS

BEGIN COUNT

DSCR KOUNT1,KOUNT2,KOUNT3,KOUNT4,KOUNT5  --  INSERT A COUNTER
PRO KOUNT1 KOUNT2 KOUNT3 KOUNT4 KOUNT5
DES These exec routines insert a counter into the code and a 
 marker into the output listing.  They are NO-OP's unless the
 /K switch is specified.  As a listing file is necessary for /K, 
 it is not necessary to check SCANWD for listing.  KOUNT2 will
 someday do the right thing for multiple labels.  KOUNT3 , KOUNT4,
 and KOUNT5 insert a different marker for counters in expressions.
 The multiplicity of routines for expression counters comes from
 the necessity of having the counter immediately after the reserved
 word in order for the analysis routine to work right.
⊗
↑KOUNT6: SKIPA  C,[","]			;SHOULD FOLLOW ","
↑KOUNT5: MOVEI	C,"("			;SHOULD FOLLOW "("
	JRST	KOUNT4+1
↑KOUNT3: SKIPA	C,["N"]			;SHOULD FOLLOW "THEN"
↑KOUNT4: MOVEI	C,"E"			;SHOULD FOLLOW "ELSE"
	MOVEI	B,3			;MARKER IS BETA (β)
	MOVEI	D,LSTOU1		;USE THIS LIST ROUTINE
	JRST	KOUNT1+2
↑KOUNT2:		;EVENTUALLY, CHECK FOR MULTIPLE LABELS
↑KOUNT1: MOVEI	B,2			;MARKER IS ALPHA (α)
	MOVEI	D,LSTOUT		;USE THIS ROUTINE
	SKIPN	KOUNT			;ARE WE INSERTING COUNTERS
	POPJ	P,			;NO
	MOVE	A,[AOS 0]		
	PUSHJ	P,CODOUT		;PUT THE ADD INSTR INTO THE CODE
	AOS	KCOUNT			;COUNT THE COUNTERS
	MOVE	A,PCNT
	SUBI	A,1
	QPUSH	(KPDP,)			;SAVE ADDRESS OF AOS
	MOVEI	A,177			;PUT A MARKER INTO
	PUSHJ	P,(D)			; THE LIST FILE
	MOVEI	C,177			;NEEDED IN CASE WE'RE CALLING LSTOU1
	MOVE	A,B			;GET THE CHARACTER FOR THE MARK
	PUSHJ	P,(D)
	POPJ	P,

BEND COUNT

SUBTTL	ARRAY DECLARATION AND INDEXING EXECS