perm filename GEN[S,AIL]33 blob sn#114973 filedate 1974-08-08 generic text, type T, neo UTF8
COMMENT ⊗   VALID 00064 PAGES VERSION 17-1(201)
RECORD PAGE   DESCRIPTION
 00001 00001
 00011 00002	HISTORY
 00030 00003		LSTON	(GEN)
 00038 00004	TABLEDATA (EXEC ROUTINES -- GLOBAL VARIABLES)
 00043 00005	TABCONDATA (EXEC ROUTINES -- GLOBAL VARIABLES)
 00046 00006	DSCR GENINI
 00050 00007	DSCR GETOP, GETADL, GETAD
 00052 00008	DSCR -- SAIL DECLARATION EXECS
 00057 00009	DSCR TYPSET, VALSET, XOWSET,  etc.
 00060 00010	DSCR TCON, BTRU, BFAL, BNUL, BINF
 00063 00011	DSCR TWID10, ECHK, ESET
 00066 00012	DSCR DWN, BLOCK, BLNAME, ENTID, UP, NAMCHK, etc.
 00075 00013	↑ENTID:	
 00081 00014	
 00088 00015	 Check for match on block names.
 00089 00016	DSCR RQ00, RQSET, SRCSWT
 00094 00017	
 00096 00018	
 00101 00019	
 00104 00020	↑SRCSWT:
 00105 00021	DSCR DFPREP, DCPREP, DWPREP, DFPINS, DFSET, DFENT, MACOFF, MACON 
 00118 00022	DSCR STCAT
 00130 00023	DSCR DCLNT1,DCLNT2
 00137 00024	DSCR CNDRCY, CNDRCN, CNDRCP 
 00144 00025	DSCR LETSET, LETENT
 00147 00026	DSCR TWCOND,SWICHP,SWPOFF,PSWICH,OKEOF
 00155 00027	↑SETWHL: EXCH	SP,STPSAV	 GET STRING POINTER
 00169 00028		SUBTTL	EXECS for Entry Declaration
 00171 00029	DSCR ALOT
 00176 00030	↑ALOT:				ROUTINE TO HANDLE ALLOCATION
 00180 00031	
 00184 00032	BAIL <
 00190 00033	
 00195 00034	Comment 
 00201 00035	NOSY:	PUSHJ	P,URGSTR	IF ON STRING RING....
 00211 00036	LOADER BLOCK FOR POLISH FIXUP
 00213 00037	DSCR PDOUT
 00220 00038	DOLVIN:	PUSH	P,PNT2
 00224 00039	ROUTINE TO PUT OUT LOCAL VAR INFO -- USED BY DIS
 00230 00040	 %AA% -- SDFLTS
 00231 00041	Allo -- Allocate One Type of Symbol
 00238 00042	ROUTINE TO ALLOCATE SPACE FOR TEMP CELLS AND TO OUTPUT
 00244 00043	REQINI -- USER REQUIRED INITIALIZTIONS
 00249 00044	DSCR DONES
 00252 00045	
 00258 00046	REN <
 00260 00047	
 00264 00048	
 00270 00049	MEMORY  and LOCATION EXECS, ALSO UINCLL
 00273 00050	 MINOR RECORD EXECS
 00279 00051	 RCFPIK -- ROUTINE TO DECODE RECORD INDEX
 00281 00052	 RCFREF -- EXEC ROUTINE FOR HANDLING RECORD FIELD REFERENCES
 00287 00053	 RECORD TYPE JUSTIFICATION ROUTINE
 00289 00054	 ROUTINE TO HANLDE REFERENCE COUNT ADJUSTMENT
 00293 00055	DSCR MAKBUK, FREBUK
 00295 00056	BEGIN	ERRORS
 00301 00057	DSCR SCNBAK,POPBAK,KILPOP,QREM2,QTYPCK
 00306 00058	DSCR  UNDEC -- Undeclared identifiers
 00312 00059	DSCR  QDEC0,1,2   QARSUB  QARDEC QPARM QPRDEC
 00319 00060	BEGIN SCOMM
 00320 00061	BEGIN  INLINE
 00322 00062	DSCR CODNIT, WRDNIT, ONEWRD, SETSIX, SETOP, CODIND, CODREG, etc.
 00330 00063	↑CESSGO:MOVE	TEMP,OPDUN		SAVING OPDUN
 00336 00064	BEGIN COUNT
 00339 ENDMK
⊗;
COMMENT ⊗HISTORY
AUTHOR,REASON
021  102100000311  ⊗;


COMMENT ⊗
VERSION 17-1(201) 8-8-74 BY JRL BUG #TA# ASSIGNC SCREWED UP WHEN GIVEN CONSTANT EXPRESSION
VERSION 17-1(200) 8-5-74 BY JRL BUG #SZ# (CMU =C7=) LPSA WASN'T BEING SAVED IN CLENUP
VERSION 17-1(199) 7-7-74 BY RHT MANY EDITS FOR RECGC
VERSION 17-1(198) 7-7-74 
VERSION 17-1(197) 7-7-74 
VERSION 17-1(196) 7-7-74 
VERSION 17-1(195) 7-7-74 
VERSION 17-1(194) 7-7-74 
VERSION 17-1(193) 7-7-74 
VERSION 17-1(192) 7-7-74 
VERSION 17-1(191) 7-7-74 
VERSION 17-1(190) 7-5-74 BY RHT BUG #SS# RECORD INDXED TEMPS AC NOT IN ACKTAB
VERSION 17-1(189) 6-2-74 BY RHT MODIFY RCBIT0
VERSION 17-1(188) 5-30-74 BY RLS BUG #SN# ALLOW RECURSIVE EXPR!TYPE CALLS
VERSION 17-1(187) 5-29-74 BY RHT BUG #SG# EMITER WAS MODIFYING ADCONS
VERSION 17-1(186) 5-27-74 BY RHT MARK RECORD ARRAYS AS SUCH IN THE PD LVI
VERSION 17-1(185) 5-27-74 
VERSION 17-1(184) 5-27-74 BY RHT ADD DEREFERENCE AT PRST FOR RECORD PROCEDURES
VERSION 17-1(183) 5-5-74 BY RHT  BUG RW FIX TO BUG FIX #RNR
VERSION 17-1(182) 4-12-74 
VERSION 17-1(181) 4-12-74 
VERSION 17-1(180) 4-12-74 
VERSION 17-1(179) 4-12-74 
VERSION 17-1(178) 4-12-74 
VERSION 17-1(177) 4-12-74 
VERSION 17-1(176) 4-12-74 
VERSION 17-1(175) 4-12-74 
VERSION 17-1(174) 4-8-74 BY RHT %BI% -- ADDED MINOR CHANGES IN LVIOUT
VERSION 17-1(173) 3-26-74 BY JFR ADD WRITEON RUNTIME TO LIBFN LIST
VERSION 17-1(172) 3-19-74 BY RHT LOOK OVER WITH RLS
VERSION 17-1(171) 3-17-74 BY RLS INSTALL TENEX
VERSION 17-1(170) 3-16-74 BY RHT BUG #RN# PROTECT_ACS LOSSAGE
VERSION 17-1(169) 2-22-74 BY RHT  BUG #RJ# ALWAYS PUT OUT LVI FOR SETS
VERSION 17-1(168) 2-5-74 BY HJS BUG #RA# ALLOW TEXT PAST END OF PROGRAM 
VERSION 17-1(167) 1-29-74 BY HJS BUG #QV# ADD ASGOFF TO TURN OFF SPECIAL ASSIGNC SCANNING
VERSION 17-1(166) 1-28-74 BY RHT SHORTEN LONG ERROR MESSAGE (ER24)
VERSION 17-1(165) 1-27-74 BY JRL BUG #QT# GIVE BETTER RECOVERY FOR EXTRA ELSE'S
VERSION 17-1(164) 1-25-74 BY RHT FIX TYPO IN BUG QK
VERSION 17-1(163) 1-16-74 BY RHT BUG #QK# REQUIRE RUNTIMEROUTINE INITIALIZATION
VERSION 17-1(162) 1-16-74 BY RHT BUG #QJ# PD WRONG FOR SG ITEMVAR ARRAY
VERSION 17-1(161) 1-16-74 
VERSION 17-1(160) 1-11-74 BY JRL CMU CHANGE SPACE ALLOCATION BLOCK SIZE
VERSION 17-1(159) 1-11-74 
VERSION 17-1(158) 1-11-74 
VERSION 17-1(157) 1-11-74 
VERSION 17-1(156) 1-6-74 BY KVL ADD %BC% ALL THE STUFF ON PGS 32 AND 33 -- BAIL SYM OUTPUTING
VERSION 17-1(155) 12-7-73 BY JRL REMOVE STANFORD SPECIAL CHARACTERS(WHERE POSSIBLE)
VERSION 17-1(154) 12-2-73 BY RHT BUG #PK# MAKE START CODE DO REMOPS
VERSION 17-1(153) 11-29-73 BY RHT EXPAND EXPLANATION OF AN ERROR MESSAGE
VERSION 17-1(152) 11-25-73 
VERSION 17-1(151) 11-25-73 BY JRL FEAT %AN% ALLOW REQUIRE TO USE CONSTANT EXPRESSIONS
VERSION 17-1(150) 11-25-73 BY RHT FEAT %AL% OUTER BLOCK LOOKS LIKE A PROCEDURE
VERSION 17-1(149) 11-25-73 BY KVL IMPROVE CODING STYLE IN REQUIRE ERROR!MODES LINK TO DSPATC 
VERSION 17-1(148) 11-24-73 BY RHT FEAT %AM% ALLOW USER TO SPECIFY INIT PHASE
VERSION 17-1(147) 11-24-73 BY RHT GET VERSION BACK
VERSION 17-1(146) 11-24-73 
VERSION 17-1(145) 11-10-73 BY KVL INSERT LOG ERR UUO STUFF
VERSION 17-1(144) 11-10-73 
VERSION 17-1(143) 10-31-73 BY HJS BUG #OS# DETECT UNDECLARED ARGUMENT TO CVMS 
VERSION 17-1(142) 10-30-73 BY RHT BUG #OB# SDFLTS NEEDED TO DO CLRSET
VERSION 17-1(141) 10-23-73 BY JRL FEATURE %AG% ITEM!START STUFF
VERSION 17-1(140) 9-27-73 BY KVL %AC% REMOVE GLOBAL DECL OPTION IN ERROR RECOVERY
VERSION 17-1(139) 9-27-73 
VERSION 17-1(138) 9-21-73 BY HJS INHIBIT LST FALSE PART OF CONDITIONAL COMPILATION 
VERSION 17-1(137) 9-19-73 BY HJS ADD CVPS AND EVALREDEFINE
VERSION 17-1(136) 9-1-73 BY RHT FEATURE %AA% -- SPROUT DEFAULTS
VERSION 17-1(135) 8-16-73 BY jrl REMOVE REFERENCES TO LEP SWITCH
VERSION 17-1(134) 8-12-73 BY JRL BUG #NQ# STRING ITEMVAR IS NOT A STRING
VERSION 17-1(133) 8-12-73 
VERSION 17-1(132) 7-26-73 BY RHT **** VERSION 17 ****
VERSION 16-2(131) 7-22-73 BY JRL BUG #KU# BAD FIX, ARRAY ITEMS SHOULD NOT BE OWN
VERSION 16-2(130) 7-14-73 BY RHT ADD AN APPL$Y,SETIP,SETCP TO LIBTAB
VERSION 16-2(129) 7-12-73 BY JRL ADD REQUIRE BUCKETS
VERSION 16-2(128) 7-12-73 
VERSION 16-2(127) 7-12-73 
VERSION 16-2(126) 7-12-73 
VERSION 16-2(125) 7-12-73 
VERSION 16-2(124) 6-20-73 BY JRL BUG #MS# LET NOT WORKING WHEN RIGHT SIDE A TRIGGERER
VERSION 16-2(123) 6-20-73 
VERSION 16-2(122) 6-20-73 BY HJS IFCR, REDEFINE, EVALDEFINE, AND ASSIGNC IMPLEMENTATION 
VERSION 16-2(121) 5-9-73 BY HJS REMOP STRING CONSTANTS
VERSION 16-2(120) 5-7-73 BY JRL ADD ERRMSG FOR BAD CONTEXT ELEMENT SYNTAX
VERSION 16-2(119) 5-4-73 
VERSION 16-2(118) 5-4-73 
VERSION 16-2(117) 5-4-73 
VERSION 16-2(116) 4-23-73 
VERSION 16-2(115) 4-23-73 BY RHT CHANGE PROC DESC FOR PROC ARGS
VERSION 16-2(114) 4-23-73 
VERSION 16-2(113) 4-22-73 BY RHT FIX UNDISCOVERED LVI BUG
VERSION 16-2(112) 4-21-73 BY RHT BUG #MC#
VERSION 16-2(111) 3-22-73 BY RHT ADD DEFAULT VALUES FOR PARAMS
VERSION 16-2(110) 3-20-73 BY RHT CHANGE FORMAL SEMBLK DELETION
VERSION 16-2(109) 3-19-73 BY HJS ALLOW TEMPORARY OVERRIDING OF NULL DELIMITERS MODE
VERSION 16-2(108) 3-13-73 BY JRL REMOVE SLS,WOM,NODIS,GAG CONDITIONAL
VERSION 16-2(107) 3-7-73 BY KVL ADD ACCESS CONSTRUCT FEATURE
VERSION 16-2(107) 3-6-73 BY JRL ADD ALLGLOBAL REQUIRE
VERSION 16-2(106) 3-5-73 BY JRL ADD OKSTAC TO DCLBEG
VERSION 16-2(105) 2-27-73 BY JRL REMOVE ..RVAL FROM LIBTAB
VERSION 16-2(104) 2-21-73 BY RHT ADD EXEC TYPMSG (P19) FOR REQUIRE STC MESSAGE
VERSION 16-2(103) 2-12-73 BY JRL ADD ..RVAL TO LIBTAB
VERSION 16-2(102) 1-28-73 BY JRL REMOVE BOUND FROM SYNTAX
VERSION 16-2(101) 1-26-73 BY JRL ADD INCONT TO LIBTAB
VERSION 16-2(100) 1-26-73 BY JRL ADD ERRMSG FOR SAMEIV AND IN!CONTEXT
VERSION 16-2(99) 1-25-73 BY JRL HALF-KILL ITEMS WITH NOS. < 20
VERSION 16-2(98) 1-25-73 BY JRL MOD ERRMSG ERR112 TO INCLUDE ?
VERSION 16-2(97) 1-24-73 BY KVL INSTALL ENTENT EXEC, MAKING DUMMY SYMBOLS TO ENTRY UNNECESSARY
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 NOW NAMED 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 (INF  same as 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 equivalent to "" 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 equivalent to ≠0 EXEC)
?TRULOC: 0


TABLEDATA (EXEC ROUTINES -- GLOBAL VARIABLES)
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	($PDLOV)	;THIS IS HOW TO CAUSE PDLOV UNDER SKIPL
	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.
	FN 	<LEAP>		;CALL LEAP!
	FN	<DATM>		;THIS IS REF TO A WORD WHICH IS XWD 3, ptr to
				;    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
	FN	<BEXIT>		;BLOCK EXITER
	FN	<STKUWD>	;STACK UNWINDER
	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	<.INCON>	;IN!CONTEXT
	FN	<CONELM>	;C:VAR
	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
	FN	<APPL$Y>	;USED WITH SPROUT APPLY
	FN	<SETIP>		;
	FN	<SETCP>		;
	FN	<WR_TON>	;WRITEON RUNTIME
REC <	FN	<$RERR>		;RECORD ACCESS ERROR
	FN	<$REC$>		;SYSTEM RECORD HANDLER
>;REC
>

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

?LIBNUM←←0

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


TABCONDATA (EXEC ROUTINES -- GLOBAL VARIABLES)

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
NOGLOC <
	0				;TURN ON NO BITS IF NOT GLOBAL
	0				;COMPILER....
>;NOGLOC

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

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

	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:
;;%AL% ! STARTUP SEQUENCE IS ONE SHORTER
	II←←7			;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)

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

⊗;

; MARK TOP AC'S UNUSABLE FOR GENERAL ALLOCATION

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

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


;No RAID on TENEX and $M causes UNDEF GLOBAL loading errors
NOTENX <
IFN FTDEBUG <
	MOVE TEMP,BITABLE
	EXTERNAL $M
	MOVEM	TEMP,$M+3	;RAID LOC
>;IFN FTDEBUG
>;NOTENX


; ***** THIS CODE MOVED TO LEAP
	PUSHJ	P,LEPINI	;INITIALIZE LEAP VARIABLES
; ******
	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,
REC <
	TRNE	TBITS,PNTVAR		;CHECK FOR RECORD CLASS ID
	TRNN	TBITS,SHORT		;CLASS IS SHORT PNTVAR
	JRST	.+3			;NOPE
	HRRI	A,TIRC			;IT IS A RECORD CLASSID
	POPJ	P,
>;REC

	HRRI	A,TIVB
NOREC <
	TRNE	TBITS,INTEGR+FLOTNG+DBLPRC
>;NOREC
REC <
	TRNE	TBITS,INTEGR+FLOTNG+DBLPRC+PNTVAR
>;REC
	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# 
REC <
NORGC <
	TRNE	TBITS,PNTVAR	;A RECORD PROCEDURE??
	JRST	[ EMIT <RECUUO 0,NOUSAC>
		JRST	REMOP ]	;DEREFERENCE IT
>;NORGC
>;REC
	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

↑ARYSET: SKIPA  A,[LPARRAY]
↑SAFSET: MOVEI	A,SAFE			;SAFE BIT
	 IORM	A,BITS			;SAVE IT
	 POPJ   P,
↑HELAR2: MOVE	B,BITS
;; #KU# DON'T MAKE ARRAY ITEMS OWN
	 TRO	B,ITEM			;SO HELSPC WILL KNOW NOT TO MAKE OWN
	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
REC <	
	SETZM	QRCTYP
	SETZM	URCIPR
	SETZM	RCLASS
>;REC
	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 INF work right
 TRUE canonically -1, so a constant is created (once), and Semantics rtnd
 FALSE equivalent to 0
 NULL equivalent to ""
 INF same as LENGTH(innermost String being SUBSCRd -- else error)
⊗

↑TCON:	JRST	.+1(B)		;CALL CORRECT ROUTINE.
	JRST	BINF		;INF 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 (infinity) INVALID, 0 ASSUMED>,1,BFAL)
	HLRZ	A,LENSTR	;LEFT HALF POINTS TO TOP OF QPUSH STACK.
	SKIPGE  A,(A)		;NEG IF INF. WITHIN SUBLIST SELECTOR
	JRST	LINF		;LIST INFIN. LOCATED IN LEAP

	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.

↑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
					;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
REC <
	QPUSH	(RCLPDL,[-1])		;MARK THE REC CLASS LIST PDL
>;REC
	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.
	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)

	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.
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)
	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(D)
	JRST 	.+3
	MOVE 	D,D			;FOR ERR UUO
	ERR	<ATTEMPT TO PROTECT SOMETHING ALREADY PROTECTED: 0>,7
	PUSHJ	P,STORZ			;CLEAR THE AC
	HRROS	ACKTAB(D)		;PROTECT IT
	HRLZI	A,1
;;#RN# ! USED TO BE -1(D)
	LSH	A,(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
	TLNN	FF,CREFSW	;ARE WE CREFFING?
	 JRST	 ENWAY		; NO
	MOVEI	A,7		;DELETE PREVIOUS ENTRY.
	PUSHJ	P,CREFOUT
ENWAY:
GLOC <
	SKIPN	ALLGLO			;GLOBAL LEAP ONLY?
	JRST	ENWAY2			;NO
	MOVE	A,BITS
	TRNE	A,ITEM			;ONLY ITEMS ARE AFFECTED
	TRO	A,GLOBL
	MOVEM	A,BITS
ENWAY2:
>;GLOC
	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
;;%BI% ALSO NO WORRY ABOUT PNTVAR
REC <
	TRZ	TBITS,STRING!BOOLEAN!INTEGR!SET!LSTBIT!FLOTNG!PNTVAR
>;REC
NOREC <
	TRZ	TBITS,STRING!BOOLEAN!INTEGR!SET!LSTBIT!FLOTNG
>;NOREC
	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
NOREC <
	TDNE	TBITS,[XWD SBSCRP,SET]	;CHECK FOR BAD GUYS
>;NOREC
REC <
	TDNE	TBITS,[XWD SBSCRP,SET!PNTVAR]	;CHECK FOR BAD GUYS
>;REC
	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.
NOGLB:
>;GLOC
; 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?
	POPJ	P,
	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
;; %AG% LH(ITEMNO) NOW CONTAINS ITEM!START
	AOS	A,ITEMNO		;MAKE A NEW NUMBER FOR IT
	HRRZS	A
;; %AG%
	AOS 	ITMCNT			;TOTAL NUMBER OF DECLARED ITEMS
	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.
	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

	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


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

	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)
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
CREFWQ:
	TLNN	FF,CREFSW		;CREFFING ?
	POPJ	P,			;DON'T DELETE THE BLOCK
	MOVEI	LPSA,(PNT)	; POINTER TO BLOCK.
	JRST	CREFBLOCK		;AND CREF BLOCK EXIT.

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)

;;#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
NOREC <
	TDNN	TBITS,[ XWD SBSCRP,SET]	;IF ONE OF THE BAD GUYS
>;NOREC
REC <
	TDNN	TBITS,[ XWD SBSCRP,SET!PNTVAR]	;IF ONE OF THE BAD GUYS
>;REC
	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>



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.
		 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
;;#RN# USED TO BE 1000
;;	MOVEI	B,2000			;BIT FOR AC 11 
;;#RW# SHOULD BE 1000, AFTER ALL (IE 1 LSH 9 = '1000)
	MOVEI	B,1000
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
;**************************************
REC <
RCLPOP:	QPOP(RCLPDL)			;GET A RECORD CLASS BLOCK
	JUMPE	A,[
		    ERR <DRYROT AT RCLPOP>,1
		    JRST RPPPD
		   ]
	CAMN	A,[-1]			;THIS WAS THE SIGN
	JRST	RPPPD			;ALL DONE
	HRRZ	LPSA,A			;A SEMBLK
	FREBLK				;RETURN IT
	JRST	RCLPOP			;& ASK FOR ANOTHER ONE
RPPPD:	
>;REC
	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,





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
	|-----------------------|
	| "some characters"	| ERROR!MODES
 PNAMES and SOURCE!FILE are handled specially
⊗

;; %AN% - ALL REQUIRE STUFF MODIFIED TO ALLOW CONSTANT EXPRESSIONS,
;; THIS CODE USED TO LOAD AC A FROM SCNVAL, AND THE INDIVIDUAL ROUTINES
;; DID WHAT THEY WISHED WITH IT.

↑DEFZRO:				;DEFAULT OF ZERO IF NO CONSTANT EXPRESSION
	MOVEI	A,0
	PUSHJ	P,CREINT
	MOVEM	PNT,GENLEF+1
	POPJ	P,

↑RQSET:
	SETZM	BITS			;IN CASE UNARY WAS CALLED
	GETSEM	(1)			;SEMANTICS OF CONSTANT
	XCT	RQTAB(B)		;DO SOMETHING
ZPOPJ:	POPJ	P,

RECORD:
	TRNN	TBITS,INTEGR		;BETTER BE INTEGER CONSTANT
	ERR	<THIS REQUIRE NEEDS INTEGER EXPRESSION>,1
	MOVE	A,$VAL(PNT)		;THE INTEGER VALUE 
	HRRZ	TEMP,SPCTBL		;THE SPACE RESERVATIN TABLE
	ADDI	TEMP,1			;ONE MORE WORD
	HRRM	TEMP,SPCTBL		;HOPEFULLY
HACK <
	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,
>;HACK
NOHACK <
	CAILE	TEMP,=18
	ADDI	TEMP,1	;FOR RELOC WORD
	CAIL	TEMP,=35	;TOO MANY??
	ERR	<TOO MANY SPACE REQUIRES>,1,CPOPJ
	HRL	A,B		;THE INDEX TO SAY WHICH
	TLO	A,STDSPC	;THE OP CODE
	MOVEM	A,SPCTBL+1(TEMP)
ZNXSRE:	SETZM	SPCTBL+2(TEMP)
	CAIE	TEMP,=18
	POPJ	P,
	AOS	SPCTBL
	AOJA	TEMP,ZNXSRE	;GO MAKE A ZERO
>;NOHACK
RQTAB:
	JRST	PNAM	;PNAMES
	JRST	RECORD	;SYSTEM PDL
	JRST	RECORD	;STRING PDL
	JRST	RECORD	;STRING SPACE
	JFCL		;ARRAY PDL NO LONGER EXISTS
	JRST	RNWITM	;NEW ITEMS
	JRST	RVERNUM	;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
	SETOM	ALLGLO		; COMPILE FOR GLOBAL LEAP ONLY
	JRST	SEGSET			;LOGICAL SEGMENT NAME REQUEST
	JRST	SEGFL			;SEGMENT FILE NAME REQUEST
	JRST	INMAIN		;GO INITIALIZE MAINPR
	JRST	REQPLL		; POLLING INTERVAL
	JRST	LPBUCK		; REQUIRE n BUCKETS
	JRST	ITMSTRT		;ITEM START
	JRST	MODSET		;ERROR MODES


RNWITM:
	TRNN	TBITS,INTEGR		;INTEGER REQUIRED
	ERR	<THIS REQUIRE NEEDS INTEGER CONSTANT>,1
	MOVE	A,$VAL(PNT)
	HRRM	A,NWITM			;INTO SPACE ALLOCATION BLOCK
	POPJ	P,
RVERNUM:
	TRNN	TBITS,INTEGR!FLOTNG
	ERR	<THIS REQUIRE NEEDS ARITHMETIC CONSTANT>,1
	MOVE	A,$VAL(PNT)
	MOVEM	A,VERNO
	POPJ	P,


LBSET:	SKIPA	B,[LBTAB]		;LIBRARY OUTPUT BLOCK ADDR
PRGSET:	MOVEI	B,PRGTAB		;PROGRAM OUTPUT BLOCK ADDR
	TRNN	TBITS,STRING		;HAD BETTER BE STRING CONSTANT
	ERR	<THIS REQUIRE NEEDS STRING CONSTANT>,1,ZPOPJ
	HRROI	TEMP,$PNAME+1(PNT)
	POP	TEMP,PNAME+1
	POP	TEMP,PNAME		;SET UP FOR CALL
	JRST	PRGOUT			;OUTPUT REQUEST, RETURN


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

SEGFL:
GLOC <
	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)
>;GLOC
	POPJ	P,


GLOC <
GETSOM:					;PNT pnts to STRING REPRESENTING REQUEST
	TRNN	TBITS,STRING		;HAD BETTER BE STRING CONSTANT
	ERR	<THIS REQUIRE NEEDS STRING CONSTANT>,1,ZPOPJ
	HRROI	TEMP,$PNAME+1(PNT)	;PNAME
	POP	TEMP,PNAME+1
	POP	TEMP,PNAME
	JRST	FILSCN			;CONVERT TO SIXBIT IN A,C,D
>;GLOC

DELSTG:					; SEMANTICS OF STRCON ALREADY SET UP
	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
COMMENT ⊗REQPLL -- SETS POLINT⊗

↑REQPLL:

	TLNE	TBITS,CNST	;BETTER BE CONSTANT INTEGER
	TRNN	TBITS,INTEGR	;
	ERR	<INVALID SPEC TO REQUIRE>,1,CPOPJ
	MOVE	A,$VAL(PNT)	;GET VALUE
	MOVEM	A,POLINT	;
	JUMPG	A,INMAIN
	POPJ	P,
LPBUCK:					; FOR REQUIRE n BUCKETS
	TRNN	TBITS,INTEGR		; BETTER BE INTEGER
	ERR	<THIS REQUIRE NEEDS INTEGER CONSTANT>,1,CPOPJ
	JUMPGE	A,.+2
	MOVEI	A,0			; MAKE SURE IS POSITIVE
	JFFO	A,.+2			; FIND FIRST ONE
	JRST	MINBKT			; MINIMUM NUMBER OF BUCKETS IS 2
	HRLZI	C,400000		; A BIT FOR TESTING
	MOVN	B,B
	LSH	C,(B)			; C NOW IS THE LARGEST POWER OF TWO
					; SUCH THAT C LEQ n
	CAME	A,C			; SEE IF n WAS A POWER OF TWO
	LSH	C,1			; NO, GO TO NEXT HIGHER POWER.
HAVSIZ: HRLM	C,NWITM
	POPJ	P,
MINBKT: MOVEI	C,2
	JRST	HAVSIZ


;; %AG%	ITEM!START
↑↑ITMSTRT:
	MOVE	TEMP,[XWD 11,10]	;SEE IF LEGAL
	CAME	TEMP,ITEMNO
	ERR	<ITEM!START REQUIRED TWICE OR AFTER ITEM DECLARATION>,1
	TRNN	TBITS,INTEGR		;INTEGER REQUIRED
	ERR	<THIS REQUIRE NEEDS INTEGER CONSTANT>,1
	CAILE	A,10
	CAIL	A,7777
	ERR	<INVALID ARGUMENT TO REQUIRE ITEM!START>,1
	HRLI	A,(A)
	SUBI	A,1			;SO FIRST WILL ALLOCATE
	MOVEM	A,ITEMNO
	POPJ	P,
;; %AG%


MODSET:
	AOS	%QUIET			;MAKE EVERY THING QUIET
	MOVEI	B,[0]
	MOVEM	B,..STR			;NULL MESSAGE
	SETZM	..LOCA
	AOS	..LOCA			;LOCATION IS 0
	TRNN	TBITS,STRING
	ERR	<THIS REQUIRE NEEDS STRING CONSTANT>,1
	SKIPN	B,$PNAME(PNT)		;STRING LENGTH
	 POPJ	P,
	HRRZ 	B,B
	PUSH	P,B			;SAVE SO DSPATC DOESN'T KILL
	MOVE	PNT,$PNAME+1(PNT)	;THE STRING
	PUSH	P,PNT			;SAVE! SAVE! SAVE! REGISTER PARANOIA
REP..:	SOSL	-1(P)			;DECREMENT CHARACTER COUNT
	 JRST	UNNCDE			;DECODE CHAR
	SOSGE	%QUIET			;RAN OUT OF STRING SO GO AWAY
	 SETZM	%QUIET			; IN CASE  ANY SETZM %QUIETS IN DSPATCH
	SUB	P,X22			;FIX STACK
	POPJ	P,

UNNCDE:	ILDB	B,(P)			;FIRST LETTER
	PUSHJ	P,DSPATC		;GO PRETEND THIS IS A REALLY ERROR
	CAIE 	B,"A"			;RETURNS HERE IF LETTER IS ACTIVATION LETTER
	JRST	REP..			;RETURNS HERE IF LETTER IS MODE OR UNKNOWN
	SETOM	%ERGO
	JRST	REP..
	EXTERNAL OUTSTR
↑TYPMSG:
	MOVE	USER,GOGTAB;
	MOVE	SP,SPDL(USER)
	GETSEM	(1)
	TRNN	TBITS,STRING
	ERR	<THIS REQUIRE NEEDS STRING CONSTANT>,1,CPOPJ
	PUSH	SP,$PNAME(PNT)
	PUSH	SP,$PNAME+1(PNT)
	PUSHJ	P,OUTSTR	;WRITE IT OUT
	JRST	SCOMM1		;ZAP STC BLOCK

↑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, MACON 
PRO DFPREP DCPREP, DWPREP, DFPINS DFSET DFENT MACOFF, MACON 
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  (  drarrow  DPL  EXEC DFPR1  SCAN 2  GO TO DPA
	@I  SG drarrow  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. *

↑MACON:	TLZ	FF,NOMACR	; TURN MACRO EXPANSION ON 
	POPJ	P,		; RETURN 

↑EVMCOF: SKIPN	EVLDEF		; TURN OFF MACRO EXPANSION ONLY IF 
				;  EVALDEFINE IS NOT IN PROGRESS 
↑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 ,  drarrow  SG  EXEC DFPINS  SCAN 2  ¬DPA
	SG @I )  drarrow  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  drarrow  EXEC SPDMBD  SCAN  ¬LEQ1
	Check if a special macro body delimiter declaration has occurred  ⊗

↑SPDMBD: SKIPN	REQDLM		; TRYING TO OVERRIDE NULL DELIMITER MODE?
	SETOM	RSTDLM		; YES, SET FLAGS SO CAN RESET PROPERLY WHEN DONE
	SETOM	REQDLM		;
	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:	=  drarrow  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 ,  drarrow EXEC DFINE  SCAN 2   ¬DFR
	DDEF DPL ICN ;  drarrow  EXEC DFINE  SCAN     ¬DS0
	SDEF DPL ICN ;  drarrow  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 DELETE THE PREVIOUS 
	PUSHJ	P,REMOPL	;   DEFINITION IF IT IS THE ONLY REFERENCE TO IT
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
	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 PDL OVERFLOW MESSAGE 
	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 
	PUSHJ	P,STRINS	; MAKE STRING CONSTANT 
	MOVEM	PNT,GENLEF+1	; RECORD RESULTS WHERE WILL BE SEEN
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
	SETZM	SWBODY		; RESET SWITCH DELIMITER DECLARATION FLAG
	SKIPN	RSTDLM		; RESTORING NULL DELIMITERS MODE?
	JRST	.+4		; NO
	SETZM	RSTDLM		; RESTORE THE APPROPRIATE FLAGS
	SETZM	REQDLM		;
	POPJ	P,		;
	HRROI	TEMP,LOCMBD+1	; GET RESTORING ADDRESS
	POP	TEMP,CURMED	; RESTORE START DELIMITER
	POP	TEMP,CURMBG	; RESTORE END DELIMITER
	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	LPSA,GENLEF+1	; GET MACRO BODY SEMBLK
	EXCH	SP,STPSAV	; GET STRING STACK POINTER
	MOVSS	POVTAB+6	; ENABLE CORRECT PDL OVERFLOW MESSAGE
	PUSH	SP,$PNAME(LPSA) ; FIRST WORD OF STRING DESCRIPTOR
	PUSH	SP,$PNAME+1(LPSA) ; SECOND WORD OF STRING DESCRIPTOR
	PUSHJ	P,REMOPL	; CHECK IF THROUGH WITH STRING AND IF YES FREE ITS 
				;  SEMBLK SO THE STRING WILL BE GARBAGE COLLECTED
	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
	POP	SP,PNAME+1	; SECOND WORD OF STRING DESCRIPTOR
	POP	SP,PNAME	; FIRST WORD OF STRING DESCRIPTOR
	PUSHJ	P,STRINS	; ENTER MACRO BODY STRING IN SYMBOL TABLE
	MOVE	LPSA,GENLEF+2	; LINK MACRO NAME TO MACRO BODY
	HRLM	PNT,%TLINK(LPSA) ;
	EXCH	SP,STPSAV	; RETURN STRING POINTER
	MOVSS	POVTAB+6	; KEEP ERROR MESSAGES IN SYNCH
	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: TLZ	FF,NOMACR		; TURN MACRO EXPANSION BACK ON 
;;#OS# 10-31-73 HJS CHECK FOR UNDECLARED MACRO NAME 
	SKIPE	LPSA,GENLEF		; IS THIS A DECLARED MACRO? 
	JRST	CVMSOK			; YES, 
	ERR	<NOT A MACRO NAME SUPPLIED TO CVMS> ; NO, RETURN A NULL STRING 
	SETZM	PNAME			; 
	SETZM	PNAME+1			; 
	JRST	UNDCVM			; 
CVMSOK:	HLRZ	LPSA,%TLINK(LPSA)	; CONVERT TO STRING AND ENTER IT IN THE 
					;  SYMBOL TABLE IF NOT ALREADY THERE.  
RM1770:
;; #TA# (1 OF 2) DETECT WHEN LENGTH GOES NEGATIVE
	HRRZ	TEMP,$PNAME(LPSA)	;
	SUBI	TEMP,2			; THE ONLY DIFFERENCE BETWEEN THE 
	JUMPGE	TEMP,.+2
	ERR	<DRYROT- RM1770>,1
	HRRM	TEMP,PNAME		;  STRING AND THE MACRO BODY IS 
;; #TA#
	MOVE	TEMP,$PNAME+1(LPSA)	;  THAT THE STRING DOES NOT HAVE 
	MOVEM	TEMP,PNAME+1		;  177-0 AT ITS END.
UNDCVM:	PUSH	P,BITS			;
	PUSHJ	P,STRINS		;
	POP	P,BITS			;
	MOVEM	PNT,GENRIG		; SET THE SEMANTIC STACK ENTRY TO 
					;  THE SEMBLK ADDRESS OF THE STRING.
	POPJ	P,			;


DSCR CVPFRM, ASGOFF 
PRO CVPFRM, ASGOFF 
DES These routines are used to implement the CVPS construct which converts a macro 
 actual parameter to a string.  
 CVPS(formal parameter name).  
CVPFRM	This routine fetches the appropriate parameter from the VARB ring associated 
	with the cureent invocation of the macro and strips off the 177-0 at its end 
	and converts it to a string.  
ASGOFF	This routine turns off the flag which inhibits the expansion of macro actual 
	parameters in case an error has occurred.  
⊗ 

↑CVPFRM: SETZM	ASGFLG			; TURN OFF ACTUAL MACRO PARAMETER EXPANSION 
	MOVE	B,GENLEF		;  INHIBITION FLAG AND GET SEMBLK OF ACTUAL 
	MOVE	LPSA,DEFRNG		;  PARAMETER TO BE CONVERTED TO A STRING 
GETITP:	SOJE	B,RM1770		; 
	RIGHT	,%RVARB,		; 
	JRST	GETITP			; 

↑ASGOFF: SETZM	ASGFLG			; TURN OFF ACTUAL MACRO PARAMETER EXPANSION 
	POPJ	P,			;  INHIBITION FLAG 


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 DCLNT1,DCLNT2
PRO DCLNT1,DCLNT2
DES These routines are used for the DECLARATION and EXPR!TYPE commands.
DCLNT1	Same as DCLNT2 for EXPR!TYPE.  
DCLNT2	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].
⊗

↑DCLNT1: SKIPA	A,GENLEF+1		; GET SEMBLK FOR EXPR!TYPE
↑DCLNT2: 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 IF OFF
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 DCLBEG,DCLEND
PRO DCLBEG,DCLEND
DES These routines are used to process EXPR!TYPE command which takes an arbitrary 
  expression as an argument and returns an integer having the value of the $TBITS 
  entry in the symbol table for the appropriate type.  The difference between it 
  and the DECLARATION command is that the latter does not expand macro names thus 
  enabling the user to determine if variables have been used as macro names.  
  Also, identifiers must have been previously declared if used here.
DCLBEG	Saves contents of accumulators and $SBITS values of their contents to 
	enable recovery from damage done by code generators.  Also turn off code 
	generation, and save ADEPTH, PCNT, and SDEPTH.  
DCLEND	Restore contents of accumulators and $SBITS values of their contents.  
	Also restore PCNT and SDEPTH, and make sure ADEPTH has not changed.  
⊗

;;#SN# (1 OF 3) 5-30-74 RLS ALLOW RECURSIVE EXPR!TYPE
ZERODATA
EXPCNT:	0
ENDDATA
;;#SN#


↑DCLBEG:
;;#SN# (2 OF 3)5-30-74 RLS ALLOW RECURSIVE EXPR!TYPE
	SKIPE	EXPCNT			;EXPR!TYPE ENTERED?
	  JRST	[AOS	EXPCNT		;YET ANOTHER LEVEL
		 POPJ	P,]		;SO DONT SAVE
	AOS	EXPCNT			;BUMP COUNT TO 1
;;#SN#
	TLNN	FF,LPPROG
	PUSHJ	P,OKSTAC
	MOVE	A,[XWD ACKTAB,ACKSAV]	; SAVE ACKTAB IN ACKSAV
	BLT	A,ACKSAV+12		;
	MOVEI	D,12			;
LPAT:	MOVE	PNT,ACKTAB(D)		; SAVE $SBITS IN SBSAV
	MOVE	SBITS,$SBITS(PNT)	;
	MOVEM	SBITS,SBSAV(D)		;
	SOJGE	D,LPAT			;
	SETOM	NOEMIT			; TURN OFF EMITTER
	MOVE	TEMP,ADEPTH		;
	MOVEM	TEMP,ADPTSV		;
	MOVE	TEMP,PCNT		;
	MOVEM	TEMP,PCNTSV		;
	MOVE	TEMP,SDEPTH		;
	MOVEM	TEMP,SDPTSV		;
	POPJ	P,			;


↑DCLEND:
;;#SN# (3 OF 3) 5-30-74 RLS ALLOW RECURSIVE CALLS TO EXPR!TYPE
	SOSLE	EXPCNT			;BACK TO 0 YET?
	  JRST	[SETZ D,		;NO -- WHY MUST WE ZERO D??
		 POPJ	P,]		;DONT RESTORE YET
;;#SN# 
	MOVEI	D,12			;
BEGLP:	MOVE	PNT,ACKTAB(D)		;
	CAMN	PNT,ACKSAV(D)		; IF ACKTAB IS SAME AS ACKSAV, THEN JUST 
	JRST	AFTRM2			;  RESTORE $SBITS
	HRRZ	C,$ACNO(PNT)		; CHECK IF AC HAS ALREADY BEEN REMOPED AND 
	CAIE	C,(D)			;  IS THUS VALID
	JRST	AFTREM			; YES
	PUSHJ	P,CLEAR			;
	PUSHJ	P,REMOP			;
AFTREM:	MOVE	PNT,ACKSAV(D)		; RESTORE ACKTAB, $SBITS, AND $ACNO
	MOVEM	PNT,ACKTAB(D)		;
AFTRM2:	MOVE	SBITS,SBSAV(D)		;
	MOVEM	SBITS,$SBITS(PNT)	;
	HRRM	D,$ACNO(PNT)		;
ENDLP:	SOJGE	D,BEGLP			;
	SETZM	NOEMIT			; TURN EMITTER BACK ON
	MOVE	TEMP,ADPTSV		; IF ADEPTH CHANGED WHILE PROCESSING 
	CAME	TEMP,ADEPTH		;  EXPR!TYPE THEN ERROR SINCE PARAMETER 
	ERR	<DRYROT - DCLEND FOR EXPR!TYPE> ;  STACK WILL BE OUT OF SYNCH
	MOVE	TEMP,PCNTSV		;
	MOVEM	TEMP,PCNT		;
	MOVE	TEMP,SDPTSV		;
	MOVEM	TEMP,SDEPTH		;
	POPJ	P,			;

DSCR CNDRCY, CNDRCN, CNDRCP 
PRO CNDRCY, CNDRCN, CNDRCP 
DES These routines are used to keep track of whether macros should be 
  expanded in the false part of conditional compilation.  IFCREC is 
  used to denote the current mode and RECSTK points to the top of 
  the qstack used to store the currently overridden values of IFCREC 
CNDRCY	This routine is used to save the current IFC mode and set it 
	to no expansion of macros in the false part of conditional 
	compilation,  
CNDRCN	This routine is used to save the current IFC mode and set it 
	to expand macros in the false part of conditional compilation.  
CNDRCP	This routine is used to restore the previous IFC mode.  
⊗

↑CNDRCY: QPUSH(RECSTK,IFCREC)		; 
	SETOM	IFCREC			;
	POPJ	P,			; 

↑CNDRCN: QPUSH(RECSTK,IFCREC)		; 
	SETZM	IFCREC			; 
	POPJ	P,			; 

↑CNDRCP: QPOP(RECSTK,IFCREC)		; 
	POPJ	P,			; 


DSCR PSHLST, POPLST 
DES PSHLST, POPLST 
DES These routines are used to indicate whether one is in the false part of 
	conditional compilation or in the conditional compilation parser.  This 
	information is used by the SCANNER so that listing files can hopefully 
	reflect the true program that is being compiled.  The basic action of 
	the SCANNER is to test the CNDLST flag when it is about to stack a result 
	on the parse stack and if one is in  the conditional compilation parser, 
	then the listing buffer pointer is reset to the value it had prior to 
	scanning the parse token in question.  
PSHLST	This routine is used to indicate that listing should not be happening now.  
POPLST	This routine is used to indicate that one is to revert to the previous mode 
	of listing output.  
⊗ 

↑PSHLST: QPUSH(LSTSTK,CNDLST)		; SAVE PREVIOUS COND. COMP. LISTING STATE 
	SETOM	CNDLST			; CEASE LISTING 
	POPJ	P,			; 

↑POPLST: QPOP(LSTSTK,CNDLST)		; RESTORE PREVIOUS COND. COMP. LISTING STATE 
	POPJ	P,			; 


DSCR SETRDF, SETEDF, DEFOFF 
PRO SETRDF, SETEDF, DEFOFF 
DES These routines are used indicate when a REDEFINE or an EVALDEFINE are
	in progress.  
SETRDF	This routine turns on the REDEFN flag which indicates that a 
	REDEFINE of a macro is in progress.  
SETEDF	This routine turns on the EVLDEF flag which indicates that an 
	EVALDEFINE is in progress and thus the following macro name is 
	expanded.  
DEFOFF	This routine turns off the REDEFN and EVLDEF flags.  
⊗

↑SETRDF: SETOM	REDEFN			; 
	POPJ	P,			; 

↑SETEDF: SETOM	EVLDEF			; 
	POPJ	P,			; 

↑DEFOFF: SETZM	REDEFN			; 
	SETZM	EVLDEF			; 
	POPJ	P,			; 


DSCR INTSCN, ASGENT
PRO INTSCN, ASGENT
DES These routines are used to implement the ASSIGNC construct which 
	allows assignment to macro formals.  
INTSCN	This routine turns on the ASGFLG flag which indicates that 
	the next internal representation of a macro is not to be 
	expanded.  Instead the integer value of the macro formal 
	parameter number is returned.  
ASGENT	This routine is used to assign the macro body to the macro 
	formal parameter.  
⊗

↑INTSCN: SETOM	ASGFLG			; 
	POPJ	P,			; 

↑ASGENT: MOVE	LPSA,GENLEF+1		; ASSIGNC NEW BODY
	EXCH	SP,STPSAV		; SET UP TO USE STRING STACK
	MOVSS	POVTAB+6		; 
	MOVE	TBITS,$TBITS(LPSA)	;  SEE IF STRING AND IF NOT CONVERT 
	TRNE	TBITS,STRING		;  TO A STRING 
	JRST	ASGCON			; IT IS A STRING 
	PUSH	P,$VAL(LPSA)		; NO, CONVERT TO A STRING, 
	PUSHJ	P,REMOPL		;  REMOVE NUMERIC SEMBLK
	PUSHJ	P,CVS			;  WILL LEAVE RESULT STRING ON SP-STACK
;; #TA# (CMU = D1=) (2 OF 2) NEED 177 0 AT END OF ACTUAL
	PUSH	SP,[XWD 0,2]
	PUSH	SP,[POINT 7,[BYTE (7) 177,0]]
	PUSHJ 	P,CAT
;; #TA#
	JRST	POPSTR
ASGCON:
	PUSH	SP,$PNAME(LPSA)		; STACK THE STRING
	PUSH    SP,$PNAME+1(LPSA) 	;
;; #QV# (1 OF ) 
	PUSH	SP,[XWD 0,2]
	PUSH	SP,[POINT 7,[BYTE (7) 177,0]]
	PUSHJ	P,CAT
	EXCH	SP,STPSAV		; 
	PUSHJ	P,REMOPL		; REMOVE BODY SEMBLK IF NO ONE ELSE USES IT
;; #QV#
	EXCH	SP,STPSAV		; 
POPSTR:
	MOVE	LPSA,DEFRNG		; GET SEMBLK OF ACTUAL 
	MOVE	B,GENLEF+2		;  PARAMETER TO BE ASSIGNED TO, 
GETIT:	SOJE	B,GOTIT			;  REPLACE ITS $PNAME WITH NEW VALUE
	RIGHT	,%RVARB,		;  WHICH IS ON TOP OF SP STACK
	JRST	GETIT			;  
GOTIT:
	POP	SP,$PNAME+1(LPSA)	; 
	POP	SP,$PNAME(LPSA)		; 
	EXCH	SP,STPSAV		;
	MOVSS	POVTAB+6		; 
;; #QV ! TURN OFF ASGFLG AT APROPRIATE TIME (NOT HERE)
	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 drarrow EXEC LETENT SCAN ....

⊗
↑LETSET: SETZM	BITS		;NO BITS NOW
	PUSHJ	P,ENTERS		;ENTER IT RANDOMLY
	SKIPN	LPSA,NEWSYM		;BE CAREFUL
	 ERR	 <DRYROT AT LETSET>	;IN CASE ENTERS MAKES A MISTAKE 
	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>
;; #MS# LET NOT COPYING TRIGGER BIT
	MOVE	LPSA,SYMTAB		;PREPARE TO LOOK IT UP
	PUSHJ	P,SHASH			;LOOK UP SYMBOL AGAIN, PNAME SHOULD
					;STILL BE VALID
	MOVE	TEMP,NEWSYM		;SEMBLK FOR RESERVED WORD
	MOVE	TEMP,$TBITS(TEMP)	;THE TBITS
;; #MS#
	MOVE	PNT,GENLEF+2		;NEW NAME FOR SAME THING
	MOVEM	TEMP,$TBITS(PNT)	;MAKE THEM EQUIVALENT
	POPJ	P,			;RETURN

↑TRIGOF: SETZM	SWCPRS			; TURN OFF TRIGGERING ON IFC ... 
	SETOM	NODFSW			; TURN OFF TRIGGERING ON DEFINE, 
	POPJ	P,			;  REDEFINE, EVALDEFINE, IFC ... SO
					;  THAT ONE CAN HAVE CONSTRUCTS 
					;  SUCH AS   LET DEFINE=REDEFINE
					;  LET IFC=IFCR 

↑TRIGON: SETOM SWCPRS			; TURN ON TRIGGERING ON IFC ...
	SETZM	NODFSW			; TURN ON TRIGGERING ON DEFINE, 
	POPJ	P,			;  REDFINE, AND EVALDEFINE 


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,
;; #RA# (1 OF 1)
	SETOM	EOFCEL		;
	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)
	MOVSS	POVTAB+6	; ENABLE CORRECT PDL OVERFLOW MESSAGE 
	GETBLK	NEWSYM		; GET A SEMBLK FOR THE FORC LOOP PARAMETER WHICH 
	HRROI	TEMP,PNAME+1	;  IS TREATED AS IF IT IS AN ACTUAL PARAMETER TO 
	POP	TEMP,$PNAME+1(LPSA) ;  A MACRO AND IS THUS ALWAYS PUT ON THE STRING
	POP	TEMP,$PNAME(LPSA) ;  RING.  NOTE THAT IT IS NOT HASHED AND IS 
	MOVE	TEMP,[XWD CNST,STRING] ;  NOT PLACED ON THE STRING CONSTANT RING.  
	MOVEM	TEMP,$TBITS(LPSA) ;  THUS WHEN ONE IS THROUGH WITH THE FORC BODY 
	PUSHJ	P,RNGSTR	;  ITS LOOP PARAMETER'S SEMBLK IS FREED.  
	MOVEM	LPSA,DEFRN2	;
SETFL1: EXCH	SP,STPSAV	; GET STRING POINTER
	MOVSS	POVTAB+6	; ENABLE CORRECT PDL OVERFLOW MESSAGE 
	MOVE	LPSA,GENLEF+1	; GET FORC OR FORLC BODY STRING SEMBLK
	PUSH	SP,$PNAME(LPSA)	; FIRST WORD OF STRING DESCRIPTOR
	PUSH	SP,$PNAME+1(LPSA) ; SECOND WORD OF STRING DESCRIPTOR
	PUSHJ	P,REMOPL	; CHECK IF THROUGH WITH STRING AND IF YES FREE ITS 
				;  SEMBLK SO THE STRING WILL BE GARBAGE COLLECTED
	PUSHJ	P,CTENDC	; APPEND COND COMP ENDING (" ENDC 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
	MOVSS	POVTAB+6	; ENABLE CORRECT PDL OVERFLOW MESSAGE 
	MOVE	LPSA,GENLEF+1	; GET THE CASEC BODY STRING SEMBLK
	PUSH	SP,$PNAME(LPSA)	; FIRST WORD OF STRING DESCRIPTOR
	PUSH	SP,$PNAME+1(LPSA) ; SECOND WORD OF STRING DESCRIPTOR
	PUSHJ	P,REMOPL	; CHECK IF THROUGH WITH STRING AND IF YES FREE ITS 
				;  SEMBLK SO THE STRING WILL BE GARBAGE COLLECTED
	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
	MOVSS	POVTAB+6	; ENABLE CORRECT PDL OVERFLOW MESSAGE 
	PUSH	SP,[XWD 0,4]	; LENGTH OF FOLLOWING STRING
	PUSH	SP,[POINT 7,[ASCII "IFC "]] ; FIRST WORD OF PSEUDO MACRO
	MOVE 	LPSA,GENLEF+3	; GET THE CONDITION STRING SEMBLK
	PUSH	SP,$PNAME(LPSA) ; FIRST WORD OF STRING DESCRIPTOR
	PUSH	SP,$PNAME+1(LPSA) ; SECOND WORD OF STRING DESCRIPTOR
	PUSHJ	P,REMOPL	; CHECK IF THROUGH WITH STRING AND IF YES FREE ITS 
				;  SEMBLK SO THE STRING WILL BE GARBAGE COLLECTED
	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
	MOVE	LPSA,GENLEF+1	; GET THE PSEUDO MACRO BODY STRING SEMBLK
	PUSH	SP,$PNAME(LPSA)	; FIRST WORD OF STRING DESCRIPTOR
	PUSH	SP,$PNAME+1(LPSA) ; SECOND WORD OF STRING DESCRIPTOR
	PUSHJ	P,REMOPL	; CHECK IF THROUGH WITH STRING AND IF YES FREE ITS 
				;  SEMBLK SO THE STRING WILL BE GARBAGE COLLECTED
	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: POP	SP,PNAME+1	; FIRST WORD OF STRING DESCRIPTOR
	POP	SP,PNAME	; SECOND WORD OF STRING DESCRIPTOR
	PUSH	P,LPSA		; ENTER CONDITIONAL COMPILATION BODY STRING AND 
	PUSHJ	P,STRINS	;  LINK TO MACRO PSEUDONYM SEMBLK
	POP	P,LPSA		; 
	HRLM	PNT,%TLINK(LPSA) ; 
	EXCH	SP,STPSAV	; RETURN STRING POINTER
	MOVSS	POVTAB+6	; ENABLE CORRECT PDL OVERFLOW MESSAGE 
	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)
	MOVSS	POVTAB+6	; ENABLE CORRECT PDL OVERFLOW MESSAGE 
↑SWCHFL: MOVE	LPSA,GENLEF	; PSEUDO MACRO NAME SEMBLK
	JRST	CONTXT		; PREPARE FOR FORC OR FORLC BODY SCAN

↑MKFRLP: EXCH	SP,STPSAV	; GET STRING POINTER
	MOVSS	POVTAB+6	; ENABLE CORRECT PDL OVERFLOW MESSAGE 
	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,.+3	; FORLC ACTUAL PARAMETER LIST EXHAUSTED
	MOVE	TEMP,%CFLS1	; TOKEN TO BE TWIDDLED
	MOVEM	TEMP,PARRIG+1	; SET PARSE STACK STRAIGHT
	PUSH	P,LPSA		; REMOVE CURRENT FORLC PARAMETER FROM THE STRING 
	MOVE	LPSA,DEFRNG	;  RING AND FREE ITS STRING SEMBLK
	PUSHJ	P,URGSTR
	POP	P,LPSA;
	FREBLK	DEFRNG		; 
	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 WHICH IS 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 SEMBLK
↑FREMBW: MOVE	LPSA,GENLEF+2	; WHILEC MACRO PSEUDONYM SEMBLK ADDRESS 
FRMBFF: PUSH	P,LPSA		; CHECK IF THROUGH WITH PSEUDO MACRO STRING AND IF 
	HLRZ	LPSA,%TLINK(LPSA) ; YES FREE ITS SEMBLK SO THE STRING WILL BE 
	PUSHJ	P,REMOPL	;  GARBAGE COLLECTED
	PUSHJ	P,BLKFRE	; FREE MACRO PSEUDONYM SEMBLK
	MOVEI	TEMP,2		; AT THIS POINT ONE STILL HAS 177,0 TO SCAN SO SET 
	HRRM	TEMP,PNEXTC-1	;  PNEXTC-1 TO POINT TO THE 177,0 AS A STRING SO IT
	POPJ	P,		;  WON'T BE LOST IN CASE OF A GARBAGE COLLECTION

↑FRMBCE: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

↑FRMBCT: MOVE	LPSA,GENLEF+2	; LAST TRUE CASEC BODY SEMBLK
	HLRZ	LPSA,%TLINK(LPSA) ; LAST TRUE CASEC BODY SEMBLK
	PUSHJ	P,REMOPL	; CHECK IF THROUGH WITH STRING AND IF YES FREE ITS 
				;  SEMBLK SO THE STRING WILL BE GARBAGE COLLECTED
	MOVE	LPSA,GENLEF+2
	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 
				;   RELEVANT SEMBLK
;; #SZ# CMU =C7= SAVE LPSA OVER CALL TO FREBUK
	PUSH	P,LPSA		;   SAVE OVER CALL TO FREBUK
	PUSHJ	P,FREBUK	
	POP	P,LPSA
	POPJ	P,
;; #SZ#

↑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 drarrow			EXEC ENTENT SCAN 2  ¬ ENT
	BEGIN drarrow BLAT BEGIN		EXEC ENTOUT DWN SCAN ¬DS

...

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

⊗

↑ENTENT: TLZE	FF,MAINPG		;NO STARTING ADDRESS FOR THIS PROGRAM
	 HLLZS	 ENTTAB			;RESET FIRST TIME IN
	 POPJ	P,

↑ENTMAK: HRL	LPSA,PNAME		;COUNT
	HRR	LPSA,PNAME+1		;BYTE POINTER FOR ENTRY SYMBOL
	PUSHJ	P,RAD52			;MAKE RADIX50 FOR ENTRY
	AOS	B,ENTTAB		; PTR TO 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


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

THSLVL:	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:
	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
;; #NQ#  ! A STRING ITEMVAR IS NOT A STRING
	TDNN	TBITS,[SBSCRP,,ITMVAR]	;IF ¬(SBSCRP OR ITEMVAR)AND STRING
	TRNN	TBITS,STRING	; USE 2D WORD FIXUP
	 TRZ	 A,FXTWO	;ELSE REGULAR OLD FIXUP
;;#SG# THE TYPE BITS MAY BE AN "IMMEDIATE-ABLE" OP CODE
	PUSH	P,OPDUN		;PARANOIA STRIKES DEEP
	SETOM	OPDUN
	PUSHJ	P,EMITER	;USE HIM TO OUTPUT THE WORD.
	POP	P,OPDUN
;;#SG#
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
	SETZM	CSPOS		;SET STACK	 DISPL=0
	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
	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
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.
	MOVE 	PNT2,CSPOS	;PICK UP STACK LOC
	MOVEM	PNT2,ASDIS	;SAVE IT AS ARITH STACK DISPL FOR LOCALS
REN <
	PUSHJ	P,HISET		;BACK TO CODE SEGMENT
>;REN
	TLNN	FF,ALLOCT	;ACTUALLY ALLOCATING ?
	POPJ	P,		;NO -- DONE COMPLETELY.

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

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

BAIL <
COMMENT ⊗
Here lies the Bail symbol outputing stuff. Currently, it puts out 3 files:

	.SM1	Ascii for variable, procedure, and block names, followed
		by CRLF.
	.SM2	block number,type coded, absolute adr (or stack increment)

⊗

BAISYM:
	TLNN	FF,BINARY		;ARE WE PUTING OUT SYMBOLS?
	 JRST	DOSYM			;NOPE
	PUSH	P,PNT2
	PUSH	P,TBITS2
	MOVE	LPSA, TPROC	;CURRENT PROCEDURE
	MOVE	TBITS,$TBITS(LPSA)	;TYPE
	TLNE	TBITS,EXTRNL		;DON'T BOTHER WITH EXTERNAL PROCS
	JRST	[CAIE	LPSA,RESYM		;IF THE OUTER BLOCK PROC,DO IT
		 JRST 	BLCDUN
		JRST .+1]
	PUSHJ	P,NAMOUT		;PUT OUT THE PROCEDURE'S NAME
	HRRZ	LPSA,$VAL(LPSA)		;THE PD SEMBLK
	SKIPL	SBITS,$ADR(LPSA)	;THE PD'S ADRESS
	 ERR.	1,[ASCIZ /UNALLOCATED PD AT BAISYM/]
	SETZM	PRCNO			;FOR GENERATING BLOCK NAMES
	AOS	TBITS,BLKNO		;A PROCEDURE IS AN INVISIBLE BLOCK??
	LSH	TBITS,=9
	HRRZM	TBITS,BLKNUM
	HRL	SBITS,TBITS		;PUT LEX IN FAR LEFT HALF
	TLO	SBITS,BPROCED		;INDICATE TYPE IS PROCEDURE
	PUSHJ	P,VALOUT		;PUT OUT TO SM2
	MOVE	LPSA,TPROC
	HLRZ	LPSA,%TLINK(LPSA)	;2ND PROC BLOCK
	HLRZ	LPSA,%TLINK(LPSA)	;1ST FORMAL PARM
FORMS:	JUMPE	LPSA,BLCKDN		;ANY MORE?
	PUSHJ	P,NAMOUT		;PUT THE NAME OUT
	HRLZ	SBITS,BLKNUM
	HRR	SBITS,$ADR(LPSA)	;PUT ADR IN RH, BLKNO & BITS IN LH
	MOVE	TBITS,$TBITS(LPSA)
	TLNE	TBITS,PROCED		;PROCEDURES GET SPECIAL TREATMENT
	 JRST	[TLO	SBITS,BPROCED!BREF
		JRST	.+2]
	PUSHJ	P,TYPMNG		;*******  TYPE MUNGING GOES HERE
	PUSHJ	P,VALOUT
	HRRZ	LPSA,%RVARB(LPSA)	;GET NEXT FORMAL
	JRST 	FORMS

BLCKDN:	
	QTAKE	(BLKIDX)		;GET NEXT BLOCK
	 JRST	BLCDUN			;NO MORE BLOCK!
	HRRZ	LPSA,A			;GET THE BLOCK SEMBLK
	SKIPE	$PNAME(LPSA)		;HAS IT GOT A NAME?
	 JRST	[PUSHJ	P,NAMOUT	;YEP
		JRST	BCKVAL]
	AOS	BLKNO
	AOS	TBITS,PRCNO
	MOVEI	PNT2,5			;ALWAYS PUT OUT 5 CHARACTERS
	PUSH	P,B
	MOVEI	B,NAMOU.		;WHAT TO DO WITH THE CHARS
	PUSHJ	P,FRNPD			;A SOUPED UP DEC RECURSIVE NUM PRI
	POP	P,B
	MOVEI	TBITS,15		;CR...
	PUSHJ	P,NAMOU.
	MOVEI	TBITS,12		;...LF
	PUSHJ	P,NAMOU.
BCKVAL:	HRLZ	SBITS,BLKNO		;BLKNO AND TYPE IN LH, 0 IN LH
	LSH	SBITS,=9
	HLRZM	SBITS,BLKNUM		;SAVE FOR LOCALS OF THE BLOCK
	TLO	SBITS,BBLOCK	
	PUSHJ	P,VALOUT
LOCAS:	HRRZ	LPSA,%RVARB(LPSA)	;GET NEXT VARIABLE
	JUMPE	LPSA,BLCKDN		;END OF LOCALS
	MOVE	TBITS,$TBITS(LPSA)
	TRNE	TBITS,SET		;DON'T LET KILL SETS OUT
	TRNN	TBITS,INTEGR
	TDNE	TBITS,[XWD EXTRNL,PROCED]	;DON'T PUT OUT EXTERNALS OR PROCEDURES
	 JRST   LOCAS
	PUSHJ	P,NAMOUT		
	HRLZ	SBITS,BLKNUM		;BLKNO & TYPE IN LH, ADRESS IN RH
	HRR	SBITS,$ADR(LPSA)
	MOVE	TBITS,$TBITS(LPSA)	;
	TRNE	TBITS,ITEM		;ITEMS GET SPECIAL TREAMENT
	 JRST	[TLO	SBITS,BITEM!BBILTN
		HRRZ	TBITS,$VAL2(LPSA)	;GET INTEGER CONST SEMBLK
		HRR	SBITS,$VAL(TBITS)	;GET THE ITEM NUMBER
		JRST	.+2]
	PUSHJ	P,TYPMNG		;***ALL THE TYPE MUNGING GOES HERE
	PUSHJ	P,VALOUT
	JRST	LOCAS

BLCDUN: QBEGIN	(BLKIDX)		;RESET BLKLIS
	POP	P,TBITS2
	POP	P,PNT2
	JRST	DOSYM			;GO GIVE RAID IT'S SYMBOLS

NAMOUT:	HRRZ	PNT2,$PNAME(LPSA)	;COUNT
	MOVE	SBITS,$PNAME+1(LPSA)	;POINTER
NN:	ILDB	TBITS,SBITS
	PUSHJ	P,NAMOU.
	SOJG	PNT2,NN			;NOT DONE YET
	MOVEI	TBITS,15		;CR...
	PUSHJ	P,NAMOU.
	MOVEI	TBITS,12		;...LF
NAMOU.:	SOSG	SM1CNT
	OUTPUT	SM1,
	IDPB	TBITS,SM1PNT
      	POPJ	P,

VALOUT:	SOSG	SM2CNT
	OUTPUT	SM2,
	IDPB	SBITS,SM2PNT
	POPJ	P,


ZERODATA

↑BLKNO:	0			;CONTAINS UNIQUE BLOCK NUMBER
BLKNUM:	0			;BLKNO LSH =9
PRCNO:	0			;BLOCK NUMBER - BLOCK NUMBER AT PROC HEAD


ENDDATA

COMMENT ⊗
TYPMNG is the routine that translates Compiler types into Bail types.
Procedures and items have been filterd out ahead of time. There are
3 trees:
(right branch indicates that SAIL bit was off)
COMPLEX TYPE:

		_______________	SBSCRP___________________
		|					|
	_____ITMVAR___________		  ___________ITMVAR______
	|		     ↓		  |			↓
____LPARRY_______	  BARRY	   _____LPARRY__________	BSIMPL
↓		↓		   ↓		 	↓
BARITA	     BITMAR		BARITM		      BITMV


SIMPLE TYPE:

	________________________SET______________
	|					|
_____LSTBIT________		______________STRING________
↓		  |		↓			   |
BLIST	_______FLOTNG____    BSTRNG	 _______________INTEGR______
	↓		↓		 ↓			    |
     BCNTXT           BSET	      BINTGR		  ________FLOTNG____
							  ↓		    |
							BREAL        ______LABEL___
								     ↓             ↓
								  BLABEL	BLAMDA


ACCESS TYPE:

				REFRNC___________________
				  |			↓
				  |		       BREF
				VALUE____________________
				  |			↓
				  |		       BSTAK
				 OWN_____________________
				  |			↓
				  |		       BBILTN
				<RECSW>__________________
			 	  |			↓
				  |		       BSTAK
			     SBSCRP!SET__________________
				  |			↓
				  ↓		       BALLOC
				BBILTN
⊗
BITDATA (BAIL TYPES)
;COMPLEX

BSIMPLE	←←0
BARRY	←←1
BITMV	←←2
BARITM	←←3
BITMAR	←←4
BARITA	←←5
BPROCED	←←6
BITEM	←←7

BBLOCK	←←BPROCED+10;

;SIMPLE

BLAMDA	←←00
BINTGR	←←10
BREAL	←←20
BSTRNG	←←30
BLIST	←←40
BSET	←←50
BCNTXT	←←60
BLABEL	←←70

;ACCESS

BBILTN	←←000
BREF	←←100
BALLOC	←←200
BSTAK	←←300

ENDDATA

TYPMNG:			;INPUT TYPE IN TBITS, OUTPUT IN SBITS
	TLNE	TBITS,SBSCRP
	 JRST	B1.
	TRNE	TBITS,ITMVAR
	 JRST	B2.
	TLO	SBITS,BSIMPL	
	JRST	SIMTYP

  B1.:	TRNE	TBITS,ITMVAR	
	 JRST	B3.
	TLO	SBITS,BARRY
	JRST	SIMTYP

  B2.:	TRNE	TBITS,LPARRAY
	 TLOA SBITS,BARITM
	TLO	SBITS,BITMV
	JRST	SIMTYP
  
  B3.:	TRNE	TBITS,LPARRAY
	 TLOA	SBITS,BARITA
	TLO	SBITS,BITMAR

SIMTYP:	TRNE	TBITS,SET
	 JRST	B4.
	TRNE	TBITS,INTEGR
	 JRST	[TLO SBITS,BINTGR
		JRST ACCTYP]
	TRNE	TBITS,STRING
	 JRST	[TLO  SBITS,BSTRNG
		JRST  ACCTYP]
	TRNE	TBITS,FLOTNG
	 JRST	[TLO  SBITS,BREAL
		JRST  ACCTYP]
	TRNE	TBITS,LABEL
	 TLOA	SBITS,BLABEL		;WE ASSUME $ADR HAS ADDRESS OF LABEL...
	TLO	SBITS,BLAMDA
	JRST	ACCTYP

  B4.:	TRNE	TBITS,LSTBIT
	 JRST	[TLO  SBITS,BLIST
		JRST  ACCTYP]
	TRNE	TBITS,FLOTNG
	 TLOA	SBITS,BCNTXT
	TLO	SBITS,BSET
	
ACCTYP: TLNE	TBITS,REFRNC
	 JRST	[TLO  SBITS,BREF
		POPJ	P,]
	TLNE	TBITS,VALUE
	 JRST	[TLO  SBITS,BSTAK
		POPJ  P,   ]
	TLNE	TBITS,OWN
	 JRST	[TLO  SBITS,BBILTN
		POPJ  P,   ]
	SKIPE	RECSW			;RECSW IS ON IF DURING REC PROC COMPS
	 JRST	[TLO  SBITS,BSTAK
		 TRO  SBITS,400000	;SIGNALS THAT THE STAC INC IS NEGATIVE
		POPJ  P,   ]
	TDNE	TBITS,[XWD SBSCRP,SET]
	 TLOA	SBITS,BALLOC
	TLO	SBITS,BBILTN
	POPJ	P,
>;BAIL
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 into 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 into 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:	
	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.
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
IMSSS<
	TRNE	TBITS,ITEM			;IS IT AN ITEM AT IMSSS?
	  TLO	A,400000			;YES, TURN OFF PRINTOUT DDT
>;IMSSS
	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.
;; #  #  BY JRL (1-25-73)
	CAMGE	B,[20]
	TLO	A,400000	;HALF KILL ITEM NO. < 20
;; #  #
	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.
REC <
	TRNE	TBITS,PNTVAR	;
	TRNN	TBITS,SHORT	;A RECORD CLASS ID
	JRST	.+2		;NO
	TDC	TBITS,[XWD SIMPLE,PROCED!PNTVAR!SHORT] ;NOW WILL DEALLOCATE
				;SEMBLKS IN PROPER MANNER
>;REC
	TLNN	TBITS,DEFINE	;DELETE THE MACRO BODY ....
	JRST	CHARYZ		;CHECK ARRAYS.
	PUSH	P,LPSA
	LEFT	,%TLINK,LPSERR
	PUSHJ	P,REMOPL	;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 PNTS TO 2D PROC BLOCK
	MOVE	A,LPSA		;SAVE POINTER
	LEFT	(,%TLINK,PPR4)	;PTR TO FIRST PARAM OR NIL
PPR2:
COMMENT ⊗THIS COMMENT FLUSHES A POTENTIAL BUG
	BUT STILL LEAVES EVIL AROUND, IN THE FORM OF WASTED SPACE
	HRRZ	B,$VAL2(LPSA)	;DOET THIS HAVE A DEFAULT VALUE
	JUMPE	B,PPRX		;NO
	HRRZ	C,$ADR(B)	;ZERO FIXUP ?
	JUMPN	C,PPRX		;NO?
	EXCH	B,LPSA		;
	FREBLK			;GET RID OF IT
	SKIPA	LPSA,B		;LPSA ← FORMAL SEMBLK
⊗
PPRX:	MOVE	B,LPSA		;SAVE IT
;;#MC# ! NEED TO GET IT OFF STRING RING TOO RHT 4-20-73
	PUSHJ	P,URGSTR	;GET OFF THE STRING RING
	FREBLK			;KILL IT
	RIGHT	(B,%RVARB,PPR4)	;GET NEXT
	JRST	PPR2
PPR4:
	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 USE "A" INSTEAD OF "B"
	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
	EXCH	A,MESLNK	;MESSAGE LINK
	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
⊗

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
	MOVEI	B,%PDLNK		;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
	MOVEI	B,PROCB
	MOVE	A,$TBITS(PNT2)
	TRNE	A,ITEM!ITMVAR
	TRO	B,ITEMB
	TLNE	A,MPBIND		;MATCHING PROC?
	TRO	B,BINDB			;YEP
	PUSHJ	P,ITMTYP		;SIX BIT TYPE
	LSH	A,5			;INTO ITS SPOT
	TLO	A,(B)			;OTHER BITS
;;%AA% A NEW FEATURE RHT -- SPROUT DEFAULTS 9-1-73
	HLR	A,$VAL(PNT2)		;ADD IN SPROUT DEFAULTS
	PUSHJ	P,CODOUT		;PUT OUT PROCEDURE TYPE
	HLRZ	B,%TLINK(PNT2)		;POINT AT 2ND PROC SEMBLK
	MOVS	A,$NPRMS(B)		;#SPARMS*2,,#APRMS +1 INTO AC 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
;;%BI% ! (rht) used to be in $acno
PCPRD:	MOVE	A,$VAL2(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← PTR TO 2ND PROC SEMBLK
	HLRZ	LPSA,%TLINK(LPSA)	;LPSA NOW PNTS TO 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
	PUSHJ	P,TBCOUT		;GO PUT OUT INFO ON PARAMS

DOLVIN:	PUSH	P,PNT2
	HRR	B,PCNT
	HRL	B,$VAL2(PNT)
	PUSHJ	P,FBOUT
	MOVE	PNT,$SBITS(PNT2)
	ANDI	PNT,LLFLDM		;LEX LEVEL
RGC <
	HRLZI	A,RPCOD⊗=9(PNT)		;
	LSH	A,5			;
	SKIPE	RECSW
	TLOA	A,RF
	TLOA	FF,RELOC		;NOT RECURSIVE MEANS RELOC
	TLZ	FF,RELOC		;RECSW MEANS DONT RELOC
	SKIPN	LPSA,RCTEMP		;THE RECORD TEMPS WE BUFFERED UP
	JRST	RCLV.2
RCLVLP:	HRR	A,$ADR(LPSA)		;THE CUPLRIT
	PUSHJ	P,CODOUT		;PUT IT OUT
	HRRZ	B,%TLINK(LPSA)		;REMEMBER THE NEXT 
	FREBLK				;KILL OFF THE BLOCK
	SKIPE	LPSA,B			;ITERATE
	JRST	RCLVLP
RCLV.1:	HRLZI	A,BLKCOD⊗=14
	TLZ	FF,RELOC
	PUSHJ	P,CODOUT
	SETZM	RCTEMP
RCLV.2:
>;RGC
	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,


↑TBCOUT:	;ROUTINE TO PUT OUT TYPE CODES FOR A RING OF THINGS
		;TAKES LPSA= PTR TO FIRST SEMBLK
		; USES LPSA,A,B

NPTB:	MOVE	A,$TBITS(LPSA)		;PICK IT UP
	MOVEI	B,
	TRNN	A,ITEM!ITMVAR   ;ITEMISH ?
	JRST	NTITFP		;NO
	TRO	B,ITEMB		;YES
	TLCE	A,SBSCRP	;TEST THE ARY2 THING
	TROA	B,ARY2B		;
	TLC	A,SBSCRP	;
	TLNE	A,MPBIND	;BINDING ITEMVAR
	TRO	B,QUESB		;SAY SO
	
NTITFP:	TLNE	A,REFRNC	;REFERENCE??
	TRO	B,REFB		;THE REF BIT
	TRNE	A,PROCED	;PROCEDURE
	TRO	B,PROCB		;GET TYPE
	PUSHJ	P,ITMTYP	;
	LSH	A,5		;LEFT 5 TO GET OUT OF FULL ADDR
	TRO	A,(B)		;THE OTHER BITS
	HRLZ	A,A		;THE OTHER HALF!
	PUSHJ	P,CODOUT		;PUT IT OUT
	RIGHT	,%RVARB,CPOPJ
	JRST	NPTB			;GO DO NEXT ONE


;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
;;%BI%
REC <
	TRNE	TBITS,PNTVAR		;PERHAPS A RECORDISH THING
	JRST	RECINF			;WE SHALL SEE
>;REC
;;%BI%
	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
REC <
;;%BI%
RECINF:	TRNE	TBITS,SHORT	;A CLASSID?
	JRST	LITER		;YES
	MOVEI	B,RPCOD		;A REC PTR
	JRST	PUTCI		;
;;%BI%
>;REC

ARYINF:	TLNE	TBITS,BILTIN	;BUILT IN
	JRST	LITER		;YES,DONT BOTHER
	MOVEI	B,AACOD		;ARITH CODE
;;#QJ# !2 RHT IF AN ITEMVAR ARRAY, BETTER DEALOCATE AS ARITHMETIC
	TRNE	TBITS,ITEM!ITMVAR
	JRST	PUTCI		;SO DONT DEALOCATE BASED ON DATUM TYPE
	TRNE	TBITS,STRING	;MAYBE IT WAS A STRING ARRAY
	MOVEI	B,SACOD
	TRNE	TBITS,SET	;OR A LEAPISH THING
	MOVEI	B,LACOD
REC <
	TRNE	TBITS,PNTVAR	;OR PERHAPS A RECORD ARRAY
	MOVEI	B,RPACOD	;
>;REC
	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
;;#RJ# USED ONLY TO PUT OUT IF RECURSIVE ! RHT 2-21-74
SETI.1:		; USED TO SKIPN RECSW HERE
	MOVEI	B,CTXCOD	;CONTEXT?
	TRNE	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


 
;; %AA% -- SDFLTS

↑SDFLTS:
	MOVE PNT,GENLEF+1;
	PUSHJ P,GETAD;	BETTER HAVE AN INTEGER CONSTANT
	TRNN TBITS,INTEGR
	ERR <YOU NEED AN INTEGER CONSTANT HERE>,1,CPOPJ
	MOVE A,$VAL(PNT)
	LSH 	A,-4	;THE VALUE SHIFTED TO GET RID OF CONTROL OPTS
	SKIPE	SIMPSW	;MAY NOT BE SIMPLE
	ERR 	<YOU CANNOT DO THIS INSIDE A SIMPLE PROCEDURE>,1,CPOPJ
	MOVE	PNT2,TPROC	;THE CURRENT PROCEDURE
	HRLM	A,$VAL(PNT2)	;SAVE IT AWAY
;;#OB# RHT ! 10-31-73 NEED TO SETZM BITS
	JRST 	CLRSET		;DONE

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.
REC <
	TRNE	TBITS,PNTVAR
	TRNN	TBITS,SHORT	;SHORT PNTVAR IS CLASS ID, NEVER GOES
	JRST	.+2
	TRZ	TBITS,PNTVAR!SHORT
>;REC
	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!!!
NOREC <
	TRZ	TBITS,STRING!INTEGR!FLOTNG!ITMVAR!ITEM!SET!LSTBIT!LPARRAY!SHORT
>;NOREC
REC <
	TRZ	TBITS,STRING!INTEGR!FLOTNG!ITMVAR!ITEM!SET!LSTBIT!LPARRAY!SHORT!PNTVAR
>;REC
	TRNE	TBITS,ITEM!ITMVAR
NOREC <
	TRZ	TBITS,STRING!INTEGR!FLOTNG!SET!LSTBIT
>;NOREC
REC <
	TRZ	TBITS,STRING!INTEGR!FLOTNG!SET!LSTBIT!PNTVAR
>;REC
	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:
	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:
	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
	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

; 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:
	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!
RGC <
	TLNN	TBITS,SBSCRP		;OWN RPTR ARRAYS HANDLED ELSEWHERE
	TLNN	TBITS,OWN!BILTIN	;OWN??
	JRST	NVL.1			;NOPE
	TRNE	TBITS,PNTVAR		;RECORD PNTR??
	TRNE	TBITS,ITEM!ITMVAR	;WELL
	JRST	NVL.1			;NOPE
	HRLO	A,$ADR(LPSA)		;-1,,ADDRESS
	PUSH	P,LPSA			;SAVE IT FROM HARM
	QPUSH	(RBSTK)			;REMEMBER IT FOR LATER
	POP	P,LPSA
NVL.1:
>;RGC
	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.
	JRST	ITER		;LOOP



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

TMPALO:	SETZM	PNT2		;COUNT
	HRRZ	LPSA,TTEMP
	JUMPE	LPSA,CPOPJ
RGC <
	TLNN	FF,ALLOCT	;ONLY WORK HARD IF ACTUALLY ALLOCATING
	JRST	TMPAL
	MOVEI	PNT,0		;USE THIS TO HOLD THE CHAIN
RCTMLP:	MOVE	SBITS,$SBITS(LPSA)
	SETZM	%TLINK(LPSA)	;SINCE NON-ZERO IS A MARK
	TLNN	SBITS,CORTMP
	JRST	NXRCTM
	TLNN	SBITS,INDXED	;CHECK ALSO SUBFIELD INDXED CORTMP
	JRST	RCTM.1		;NOT ONE OF THOSE
	HRRZ	B,$VAL2(LPSA)	;WELL ??
	JUMPE	B,NXRCTM	;NOT ONE OF THOSE
	JRST	RCTM.2		;YES IT IS

RCTM.1:	MOVE	B,$TBITS(LPSA)
	TRNE	B,PNTVAR	;A RECORD VBL
	TRNE	B,ITEM!ITMVAR 	;BUT NOT AN ITEMISH THING
	JRST	NXRCTM		;NOPE
RCTM.2:	HRROM	PNT,%TLINK(LPSA);MARK IT
	MOVE	PNT,LPSA	;& REMEMBER CHAIN
NXRCTM:	HRRZ	LPSA,%RVARB(LPSA)
	JUMPN	LPSA,RCTMLP
	HRRZM	PNT,RCTEMP	;REMEMBER WHICH TEMPS WERE RECORD VALUES
	HRRZ	LPSA,TTEMP	;BACK IN BUSINESS
>;RGC
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
RGC <
	HRRZM	B,$ADR(LPSA)	;REMEMBER THE SURE ENOUGH VALUE
>;RGC
	PUSHJ	P,FIXOUT	;FIXUP
	JRST	TMNXT
ALCTMP:
	TLNN	FF,ALLOCT	;ACTUALLY ALLOCATE?
	JRST	TMNXT		;NO

	HRR	B,PCNT
	HRL	B,$ADR(LPSA)
RGC <
	HRRZM	B,$ADR(LPSA)	;REMEMBER THE SURE ENOUGH VALUE
>;RGC
	PUSHJ	P,FBOUT		;FIXUP

; 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"
	HRRZ	B,PCNT
	PUSHJ	P,SCOUT		;WRITE A SYMBOL

	MOVEI	A,0
	PUSHJ	P,CODOUT
TMNXT:	HLRZ	PNT,%RVARB(LPSA) ;GET NEXT ONE
RGC <
	SKIPN	%TLINK(LPSA)	;ALSO DON'T KILL IF IT WAS A RECORD TEMP
				;PDOUT WILL HACK THINGS
>;RGC
	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
	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

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
     RQINIX -- TAKES PROC SEMBLK IN GENLEF+3, PHASE IN GENLEF+1
     REQIXX -- PROC SEMBLK IN PNT, PHASE IN SBITS2
DES  PUSHES AN INITIALIZATION REQUEST ONTO QSTACK INIPDP. DONES
	WILL PUT OUT THE CONTENTS OF THIS QSTACK AS THE INITIALIZATION
	REQUEST BLOCK.
⊗

;;%AM% (1 OF 2) ALLOW USER TO SPECIFY PHASES
↑RQINIX: MOVE	PNT2,GENLEF+1	;PHASE NUMBER
	MOVE	PNT,GENLEF+3	;PROCEDURE
	MOVE	TBITS2,$TBITS(PNT2);
	TDNN	TBITS2,[XWD CNST,INTEGR]; MUST BE AN INTEGER
	JRST	[ERR <PHASE NUMBER MUST BE INTEGER CONST>,1
		JRST	REQIN1
		]
	SKIPGE	SBITS2,$VAL(PNT2);GET THE VALUE
	JRST	[ ERR	<PHASE NUMBER MUST BE GEQ 0>,1
		MOVEI	SBITS2,0
		JRST 	REQIXX 
		]
	CAIL	SBITS2,USRPHS	;MUST BE LESS 
	JRST	[
		ERR	<PHASE NUMBER TOO BIG>,1
		MOVEI	SBITS2,USRPHS-1
		JRST	REQIXX
		]
	JRST	REQIXX

↑REQINI:MOVE PNT,GENLEF+1	;GET PROCEDURE
↑REQIN1:MOVEI	SBITS2,1	;THE LOWEST PHASE NUMBER+1
↑REQIXX:HLRZ	PNT2,%TLINK(PNT);2ND BLOCK
;;%AM%
;;#QK# RHT OWN PROCS ARE SPECIAL
	PUSHJ	P,GETAD
	TLNE	TBITS,OWN	;RUNTIME ROUTINE??
	JRST	[ MOVE	A,$ACNO(PNT)	;BYTE WORD
		TLNE	A,770000	;ZERO BYTE HERE MEANS NO PARAMS
		ERR	<THIS PROCEDURE HAS PARAMETERS>,1
		JRST	EXTCSE		;TREAT AS AN EXTERNAL
		]
;;#QK#

;;#JH# ! RHT 9-29-72 TYPO ERROR
	HRLZI	A,1		;
	CAME	A,$NPRMS(PNT2)	;ANY PAPAMS
	ERR	<THIS PROCEDURE HAS PARAMETERS>,1
	TLNN	TBITS,FORWRD!EXTRNL	;IF ONE OF THESE, HARDER
	JRST	ESYCS
;;#QK# !
EXTCSE: 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)
;;%AM% (2 OF 2) !
	HRLI	A,400000(SBITS2)	;PHASE NO
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
;;%AL% RHT ! TREAT 12 RIGHT
	EMIT	<MOVE RF,NOUSAC+NOADDR(RF)>
	MOVE	A,[XWD 3,3]
	PUSHJ	P,CREINT
	EMIT	<SUB P,NOUSAC>
	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
NOTENX <
	MOVEI	TBITS2,LSTCDB		;GET FILE NAME
	MOVE	A,CFIL(TBITS2)
>;NOTENX
TENX <;WE WANT THE SIXBIT NAME OF THE LST FILE IN AC A
ZERODATA
LISFLN:	BLOCK 11
ENDDATA
	PUSH	P,B
	PUSH	P,C
	PUSH	P,D
	HRROI	A,LISFLN	
	HRRZ	B,LISJFN		;SET UP IN CC
	MOVSI	C,002000		;PRINT NAME ONLY
	JSYS	JFNS			;GET THE NAME
	MOVEI	C,6
	SETZ	A,			;ACCUMULATE SIXBIT HERE
	MOVE	B,[POINT 7,LISFLN,-1]

SIXLUP:	ILDB	D,B			;GET A BYTE
	SKIPE	D
	  SUBI	D,40			;CONVERT TO SIXBIT
	LSH	A,=6			;MOVE OVER
	ADD	A,D			;ADD IN
	SOJG	C,SIXLUP

	POP	P,D			
	POP	P,C
	POP	P,B
>;TENX
	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.
IFN 0,< ;ALL THIS IS PROCEDURIZED NOW
	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:
>;IFN 0
	PUSH	P,INIPDP		;INITIALIZATIONS
	MOVEI	B,%INLNK	;
	PUSHJ	P,QSTKOU
	QFLUSH	(INIPDP)	;FLUSH THE QSTACK
RGC <
	PUSH	P,RBSTK		;RECORD BLOCKS
	MOVEI	B,%RBLNK
	PUSHJ	P,QSTKOU
	QFLUSH	(RBSTK)
>;RGC

REN <
	PUSHJ	P,HISET			;BACK TO UPPER SEGMENT TO
>;REN
	PUSHJ	P,LNKMAK		;MAKE LINKAGE BLOCK

;1A
	SKIPE	LEAPIS			;ANY LEAP ASKED FOR
;; %AG% GITEMNO NOW CONTAINS THE LEAPIS FLAG
	HRROS	GITEMNO			;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:
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:
	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
NOSTR:
	LEFT	,%RVARB,BILGO
	JRST	STRLOP			;LOOP FOR ALL STRINGS.



;3

BILGO:	
	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

NOHACK <
;NOW SAVE THE COMPILER VERSION NUMBER, SO WE CAN CHECK AT STARTUP
	MOVE	A,[.VERSION]
	MOVEM	A,COMVER

>;NOHACK
;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.

	POPJ	P,			;ALL DONES

;ROUTINE TO PUT OUT A QSTACK FULL OF WORDS (ALL RELOC), FOLLOWED BY A ZERO
; AND PRECEDED BY A LINK WORD FOR SOME LOADER LINK
; PARAMS: QPDP IN (P), LINK NUMBER IN B
; SID: CLOBBERS B,A,LPSA,TEMP,FF(RELOC)

QSTKOU:	SKIPN	-1(P)		;QPDP EMPTY
	JRST	QS.XIT		;
	MOVEI	A,0		;NO, PUT OUT A WORD FOR THE LINK
	TLZ	FF,RELOC	;LIKE SO
	PUSHJ	P,CODOUT	;
	PUSHJ	P,LNKOUT	;LINK GOES OUT
	TLO	FF,RELOC	;FOR ALL THE ADDRESSES
	QBEGIN	(<-1(P)>)	;SETS UP ACB
QS.OU1:	QTAKE	(<-1(P)>)	;
	JRST	QS.OU2		;ALL DONE
	PUSHJ	P,CODOUT	;PUT OUT WORD
	JRST	QS.OU1		;ITERATE
QS.OU2:	MOVEI	A,0		;
	TLZ	FF,RELOC
	PUSHJ	P,CODOUT
QS.XIT:	SUB	P,X22
	JRST	@2(P)


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,
;; MINOR RECORD EXECS

REC <

ZERODATA (RECORD VARIABLES)

↑QRCTYP:	0	;HOLDS THE RECORD CLASS FOR THE RECORD_POINTER

↑URCIPR:	0	;NAME OF HANDLER PROCEDURE FOR A RECORD

↑RCLASS:	0	;RECORD CLASS HOLDER FOR MARK.  MARK ALWAYS COPIES THIS
			;INTO THE LEFT HALF OF $ACNO OF ANY TEMP IT MARKS
↑CURRCC:	0	;NAME OF CURRENT RECORD CLASS BEING DEFINED

↑RCLPDL:	0	;RECORD CLASS PDL

↑NLRCBK:	0	;HOLDS SEMBLK FOR NULL RECORD

↑RCTEMP: 	0	; LIST OF CURRENTLY AVAILABLE RECORD TEMPS

↑RBSTK:		0	; QPDP FOR -CNT,,ADR WORDS

ENDDATA


;NEW EXEC ROUTINES:
↑NLLREC: 		;CREATES A NULL RECORD
	SKIPE	PNT,NLRCBK	;HAVE ONE?
	JRST	GOTNRC		;YEP, USE IT
	SETZM	SCNVAL		;NO MUST MAKE ONE
	MOVE	TBITS,[XWD CNST,PNTVAR]
	MOVEM	TBITS,BITS
	HRROS	RCLASS	;
	PUSHJ	P,CONINS;
	HRROS	$ACNO(PNT)	;THE UNIVERSAL CLASS
	MOVEM	PNT,NLRCBK
GOTNRC:	MOVEM	PNT,GENRIG
	POPJ	P,

↑RCCREM: MOVE PNT,GENRIG ;CALLED AFTER PRDEC
	MOVEM PNT,CURRCC
	POPJ	P,

↑SETIRP:		;REMEMBER THAT THIS IS A RECORD POINTER
	MOVEI	A,PNTVAR
	ORM	A,BITS
	POPJ	P,

↑TWDIRC:		;REMEMBER RECORD CLASS
	CAIE	B,1	;ANY_CLASS?
	SKIPA	PNT2,GENLEF
	HRRZI	PNT2,-1
	CAIN	B,2	;AN IPR?
	CAMN	PNT2,CURRCC	;YES, IS IT ONLY TEMPORARILY THAT
	SKIPA	
	ERR	<BAD TYPE SPECIFICATION FOR RECORD POINTER>,1
	SKIPE	PNT,QRCTYP	;
	JRST	MULRCC		;A MULTIPLE RECORD CLASS
	MOVEM	PNT2,QRCTYP
	POPJ	P,

MULRCC:	CAIN	PNT,-1		;THE SPECIAL "ANYTHING" FLAG
	SKIPA	TBITS,[PNTVAR!SHORT]; SO THAT WILL GET SOME MORE
	PUSHJ	P,GETAD		;IS THE THING THERE ALREADY A CLASS?
	TRNN	TBITS,LSTBIT	;THIS IS THE GIVEAWAY
	JRST	[ GETBLK	;GET A BLOCK FOR THE PURPOSE
		TRO	TBITS,LSTBIT		;FLAG IT
		MOVEM	TBITS,$TBITS(LPSA)
		MOVEI	TEMP,1			
		MOVEM	TEMP,$PNAME(LPSA)
		MOVE	PNT,LPSA 		; SAVE IT
		EXCH	LPSA,QRCTYP		; NOW LPSA IS THE THING USED TO HAVE
		HRLI	TEMP,(<POINT =18,0>)	;
		HRRI	TEMP,$ADR(PNT)		;A SURE ENOUGH BYTE POINTER
		MOVEM	TEMP,$PNAME+1(PNT)	;
		IDPB	LPSA,TEMP		;REMEMBER OLD QRCTYP
		MOVEM	TEMP,$SBITS(PNT)	;AND NEW VERSION OF BYTE POINTER
		QPUSH	(RCLPDL,PNT)		;SAVE THIS SO WE CAN KILL IT OFF
		JRST	.+1 ]
	AOS	TEMP,$PNAME(PNT)		;ONE MORE
	CAILE	TEMP,=12			;
	ERR	<WE ONLY ALLOW UP TO TWELVE CLASSES AT A TIME FOR NOW>,1,CPOPJ
	IDPB	PNT2,$SBITS(PNT)
	POPJ	P,

↑RCBIT0:
	MOVE	A,[XWD SIMPLE,PROCED]	;PRETEND TO BE A SIMPLE PROCEDURE
	ORM	A,BITS
;;#  # NEEDED TO FIX BITS BACK IF RECORD CLASS WAS ALREADY FORWARD
	SKIPN	PNT,GENLEF		;IF ANY
	POPJ	P,
	PUSHJ	P,GETAD			;FIND OUT WHAT THIS ID USED TO BE
	TDNN	TBITS,[XWD EXTRNL,FORWRD]
	POPJ	P,			;NOT ELIGIBLE
	TRZE	TBITS,PNTVAR		;IF NOT A RECORD CLASS
	TRZN	TBITS,SHORT
	POPJ	P,			;THEN LEAVE IT ALONE
	ANDI	SBITS,LLFLDM		;
	CAME	SBITS,LEVEL		;SAME LEVEL??
	POPJ	P,			;NOPE
EXTERN EQU
	EXCH	SP,STPSAV		;SAME PNAME??
	PUSH	SP,$PNAME(PNT)
	PUSH	SP,$PNAME+1(PNT)
	PUSH	SP,PNAME
	PUSH	SP,PNAME+1
	PUSHJ	P,EQU
	EXCH	SP,STPSAV
	JUMPE	1,CPOPJ			;IF NOT, DO NOTHING

	TDO	TBITS,[XWD SIMPLE,PROCED]
	MOVEM	TBITS,$TBITS(PNT)	;IF SO, THEN MODIFY SO PRDEC
	POPJ	P,			;WINS


↑URCHLR:		;USER RECORD HANDLER PROCEDURE SPECIFICATION
	MOVE	PNT,GENLEF+1
	MOVEM	PNT,URCIPR
	POPJ	P,


↑NRCDO:			;MAKES A NEW RECORD
	MOVEI	D,1	;RESULT WILL COME BACK IN 1
	PUSHJ	P,STORZ
	MOVE	PNT,GENLEF+1	;DO A RECUUO 1
	PUSHJ	P,ADRINS	;WILL NEED AN ADCON
	EMIT	<RECUUO 1,NOUSAC>
	MOVEI	D,1		;RESULT COMES BACK IN AC1
	MOVEI	TBITS,PNTVAR	;
	MOVE	PNT,GENLEF+1
	MOVEM	PNT,RCLASS
	PUSHJ	P,MARKME
	MOVEM	PNT,GENRIG	;THE TEMP
	POPJ	P,

↑RCCERR: ERR	<SYNTAX ERROR IN RECORD CLASS DECLARATION>,1
	POPJ	P,
↑RCPERR: ERR 	<SYNTAX ERROR IN RECORD POINTER DECLARATION>,1
	POPJ	P,

>;REC
;; RCFPIK -- ROUTINE TO DECODE RECORD INDEX

REC <
EXTERN EQU

↑RCFPIK:
	MOVE	PNT,GENLEF+3		;GET THE CLASS
	HLRZ	PNT2,%TLINK(PNT)	;INTERESTING THINGS ARE IN SECOND BLOCK
	HLRZ	PNT2,%TLINK(PNT2)
	JUMPE	PNT2,RCFP.3		;NO FIELDS, MUST LOSE
	MOVSS	POVTAB+6		;INCASE OF OVERFLOW
	EXCH	SP,STPSAV		;GET THE STRING STACK
RCFP.1: 
	PUSH	SP,$PNAME(PNT2)		;CHECK TO SEE IF THE SAME
	PUSH	SP,$PNAME+1(PNT2)
	PUSH	SP,PNAME		;THE ONE WE SCANNED
	PUSH	SP,PNAME+1		;
	PUSHJ	P,EQU			;CHECK FOR EQUAL
	JUMPN	1,RCFP.2		;YES
	HRRZ	PNT2,%RVARB(PNT2)	;GO ON TO NEXT
	JUMPN	PNT2,RCFP.1		;IF THERE IS A NEXT
RCFP.2:	EXCH	SP,STPSAV		;SAVE PDL AGAIN
	MOVSS	POVTAB+6		;PUT PDLOV BACK
	CAIN	PNT2,0			;DID WE GET ONE
RCFP.3:	ERR	<COULD NOT FIND THE SPECIFIED SUBFIELD>,1
	MOVEM	PNT2,GENRIG		;UGH! IF LOSES, WILL DO SOMETHING ELSE
	POPJ	P,
>;REC

;; RCFREF -- EXEC ROUTINE FOR HANDLING RECORD FIELD REFERENCES

REC <

↑RCFREF:	
	HRRZ	PNT,GENLEF+1		;GET THE RECORD ID
	PUSHJ	P,GETAD			;GET THE SEMANTICS
	TRNE	TBITS,PNTVAR		;BETTER BE SURE A POINTER VARIABLE
	TRNE	TBITS,777777-(PNTVAR!GLOBL) ;BETTER LOOK LIKE THIS
	ERR	<RCIREF OF SOMETHING NOT A RECORD PTR>,1
NORGC <
	TLNE	SBITS,ARTEMP		;A TEMP??
	TLNE	SBITS,FIXARR		;EVEN IF SO, FIXARR IS JUST NORMAL
	JRST	RCR1			;DO THE STANDARD CASE
;;%  % treat all indxed temps in good way (unless later get in trouble)
;	TLNN	SBITS,INDXED		;INDEXED TEMP?
;	JRST	RUINDX			;NOPE, ASSUME CAME FROM SOME BAD THING
;	HRRZ	LPSA,$VAL2(PNT)		;THE SUBFIELD FLAG
;	JUMPN	LPSA,RCR1		;A SUBFIELD INDEXED TEMP IS JUST NORMAL
;	GENMOV	(GET,MRK!INDX)		;GET THE INDEXED TEMP INTO AN AC
	TLNE	SBITS,INDXED		
	JRST	RCR1
;;%  %
>;NORGC

RUINDX:	PUSH	P,PNT			;SINCE WILL REMOP RIGHT AWAY
	PUSHJ	P,RCR1			;GET A NEW INDEXED TEMP
	HRROS	%TLINK(PNT)		;& MARK IT SO REMOP UNDOES REF COUNT
	POP	P,LPSA			;FOR THE REMOP OF OUR ORIGINAL TEMP
	JRST	REMOPL			;GO REMOP THE BEASTIE
	
RCR1:	GENMOV	(ACCESS,0)		;GET ACCESS TO THE THING
	PUSHJ	P,GETAN0		;GET AN INDEX AC
	EMIT	<SKIPN >		;BE SURE OK
	XCALL	<$RERR>			;MAY WANT SOMETHING BETTER LATER
					;TOO BAD CANNOT ELIMINATE THE 
					;REDUNDENT CHECKING, AS IN
					; X←FOOC:1[R]+FOOC:2[R]
	HLRZ	LPSA,$ACNO(PNT)		;GET THE CLASS ID
	HRRZ	PNT2,GENLEF+3		;AS HE SPECIFIED IT
	PUSHJ	P,SUBFOK		;TEST FOR CLASS AGREEMENT
	ERR	<CLASS DISAGREEMENT ON RECORD FIELD>,1
	HLRZ	PNT2,%TLINK(PNT2)	;THE INTERESTING THINGS ARE IN THE SECOND


GOTFS:  MOVE	PNT,GENLEF+2		;GOT FIELD SEMANTICS

	SETZB	TBITS,SBITS
	PUSHJ	P,GETTEM		;GET A TEMP
					;& FILL IN THESE BITS
	MOVE	TBITS,$TBITS(PNT)
	HRLZI	SBITS,ARTEMP!PTRAC!INDXED; PROMISE TO BE ARITHMETIC
	TLZ	TBITS,OWN!FORMAL!MPBIND ;RANDOM BAD GUYS THAT MAY BE ON
	MOVEM	SBITS,$SBITS(LPSA)
	MOVEM	TBITS,$TBITS(LPSA)
	TLNE	TBITS,SBSCRP		;ARRAYS ARE FUNNY
	HRLM	PNT,$VAL2(LPSA)		;SAVES THE FIELD NAME SO THAT ARRSB WILL WIN

	TRNE	TBITS,PNTVAR		;A POINTER ITSELF??
	TRNE	TBITS,ITMVAR!ITEM!SHORT
	TLZA	D,-1			;NO, JUST DO THE MARKING -- CLASSID 0
	HLL	D,$ACNO(PNT)		;THE CLASS ID OF THIS FIELD

	MOVEM	D,$ACNO(LPSA)		;REMEMBER RCLASS,,ACNO
;;#SS# ! RHT ALSO REMEMBER IN ACKTAB
	HRRM	LPSA,ACKTAB(D)		;REMEMBER I DID IT
	MOVE	PNT,LPSA		;FOR TYPDEC
	MOVEM	PNT,GENRIG		;THIS IS WHAT WE HAVE
	PUSHJ	P,TYPDEC		;GET CORRECT TYPE
	MOVEM	A,PARRIG		;

	HRRZ	LPSA,GENLEF+2		;GET THE SEMANTICS OF THE FIELD ID
	HRRE	B,$ADR(LPSA)		;ADR FIELD IS THE INDEX
	MOVEM	B,$VAL(PNT)		;REMEMBER IT AS SUCH
	HLLOS	$VAL2(PNT)		;JUST USE -1 AS A FLAG FOR NOW

NORGC <
	MOVE	PNT2,TPROC		;PUT ON SUBFIELD TEMP RING
	HLRZ	PNT2,%TLINK(PNT2)	;IT IS HOMED IN THE SECOND PROC SEMBLK

	HRLZ	LPSA,PNT2		;BACK POINTER IS INTO PROC SEMBLK
	HRR	LPSA,%RVARB(PNT2)	;THE FIRST THERE NOW
	MOVEM	LPSA,%RVARB(PNT)	;LINKS FOR NEW SUBFIELD
	TRNE	LPSA,-1			;AM I THE VERY FIRST SUCH?
	HRLM	PNT,%RVARB(LPSA)	;NOPE, HE LINKS BACK TO ME NOW
	HRRM	PNT,%RVARB(PNT2)	;NEW LIST HEADER

	MOVE	PNT2,GENLEF+1		;THE RECORD POINTER AGAIN
	HRLM	PNT2,%TLINK(PNT)	;BOY IS ALL THIS HAIRY
					;POINTS BACK SO THAT DEREF KLUGE WORKS
>;NORGC

	POPJ	P,

;NOTE THAT I DON'T EVEN DO A REMOP YET ON THE RECORD POINTER
;	THE REMOP WILL HAPPEN AUTOMATICALLY WHEN I REMOP THE NEW INDEXED TEMP

>;REC
;; RECORD TYPE JUSTIFICATION ROUTINE

REC <

↑SUBFOK: CAMN	LPSA,PNT2	;TAKES A CLASS OR CLASS LIST IN PNT2 & LPSA
	JRST	SBFSKP		;SKIP RETURNS IF HAVE NON ZERO INTERSECTION
				;CHANGES NO ACS
	CAIE	LPSA,-1		;IF EITHER IS THE UNIVERSAL CLASS
	CAIN	PNT2,-1		;WE WILL KNOW WE ARE WINNING
	JRST	SBFSKP

	PUSHJ	P,SBFTRY	;TRY SUBFIELDING
	JRST	[		;LOST, TRY OTHER CASE
		EXCH	PNT2,LPSA	;
		PUSHJ	P,SBFTRY	;SKIP RET MEANS WINNER
		SOS	(P)		;UNDO WINNAGE
		EXCH	PNT2,LPSA	;
		JRST	SBFSKP
		]

SBFSKP:	AOS	(P)		;A GREAT WIN
SBFRET:	POPJ	P,



SBFTRY:	
	PUSH	P,C		;VERIFY CLASS OK
	PUSH	P,TEMP
	PUSH	P,LPSA
	MOVE	C,$TBITS(LPSA)
	TRNN	C,LSTBIT	;THIS BIT IS THE GIVEAWAY
	JRST	POPOFF		;LOSER
	HRRZ	C,$PNAME(LPSA)	;
	MOVE	TEMP,$PNAME+1(LPSA)
LPLP.1:	JUMPE	C,POPOFF
	ILDB	LPSA,TEMP	;
	PUSHJ	P,SUBFOK	;TEST IT OUT
	SOJA	C,LPLP.1	;LOOP BACK
	AOS	-3(P)		;WILL SKIP RET ONLY IF LOSE
POPOFF:	POP	P,LPSA
	POP	P,TEMP
	POP	P,C
	POPJ	P,

>;REC

;; ROUTINE TO HANLDE REFERENCE COUNT ADJUSTMENT

REC <
NORGC <

;;ROUTINE TO EMIT A DEREFERENCEING INSTRUCTION FOR THE THING IN PNT
;;WILL EVENTUALLY EMIT A <RECUUO 0,>, USUALLY.  IF HOWEVER THE THING
;;HAS DANGLING REFERENCES IN THE FORM OF INDEXED TEMPS, WILL INSTEAD
;;EMIT CODE TO ADJUST THE REFERENCE COUNT BY N+C, WHERE N IS THE
;;NUMBER OF SUCH TEMPS, AND C IS USUALLY -1. (IF C=0, THEN THE EFFECT
;;OF THIS ROUTINE WILL BE TO "CORRECT" THE REFERENCE COUNT -- USEFUL
;;WHEN YOU MUST PASS A RECORD BY REFERENCE). IF N+C<0, THEN THE CODE
;;<RECUUO,0> WILL BE PUT OUT ABS(N+C) TIMES.  OTHERWISE THE COUNT IS BUMPED
;;BY ABS(N+C).  IN ANY EVENT, ANY SUCH TEMPS THAT POINT TO THE PNT THING ARE
;;MARKED (BY SETTING THEIR BACK REFERENCE POINTER (LH OF %TLINK) TO -1) 
;;SO THAT THEY WILL EMIT A <RECUUO 0,-1(AC)> WHENEVER THEY GET REMOPPED
;;AND THE THING IN PNT WILL GET ITS REFCOUNT BUMPED BY THAT MUCH.
;;
;;PARAMETERS: PNT = THING
;;	      C = INITIAL OFFSET COUNT = "TRUE" ADJUSTMENT
;;		  	SET TO -1 FOR SIMPLE DEREFERENCING
;;			SET TO 0 FOR REF PARAM "CORRECTION"
;;ENTRY POINTS:
;;	      ↑RFCADJ:  <DOES THE WHOLE THING, INCLUDING INDEXED TEMPS>
;;
;;MODIFIES LPSA,C,A,TEMP

↑RFCADJ:	
	PUSH	P,FF
	PUSH	P,PNT2
	PUSH	P,D			;BECAUSE ACCESS MAY MUNGE
	PUSH	P,TBITS
	PUSH	P,SBITS
	PUSH	P,B
	HRRZ	B,TPROC			;WILL CRAWL DOWN DEPENDENTS LIST
	HLRZ	B,%TLINK(B)		;POINTER IS IN SECOND BLOCK
	JRST	CKL.1			;COUNT UP 
CKL:	HLRZ	LPSA,%TLINK(B)		;BACK POINTER
	CAIN	LPSA,(PNT)		;IS THIS ONE?
	JRST	[ HRROS	%TLINK(B)	;THIS WAS ONE, MARK IT
		  AOJA	C,.+1		;AND BUMP THE COUNT
		]
CKL.1:	HRRZ	B,%RVARB(B)		;GO ON TO NEXT
	JUMPN	B,CKL

LCKD:	JUMPE	C,RFCXIT		;HAVE TO ADJUST COUNT?
	PUSH	P,C			;WHAT A PARANOID
	GENMOV	(ACCESS,GETD)		;GET ACCESS
	POP	P,C
	JUMPG	C,BMCNT			;MUST INCREMENT
	MOVE	A,[RECUUO 0,NOUSAC]	;DROP COUNT BY ONE
	PUSHJ	P,EMITER		;EMIT IT
	AOJL	C,.-1			;HANG IN THERE UNTIL DONE
RFCXIT:	POP	P,B
	POP	P,SBITS
	POP	P,TBITS
	POP	P,D			
	POP	P,PNT2
	POP	P,FF
	POPJ	P,
BMCNT:	
	EMIT	<SKIPN TEMP,NOUSAC>	;FETCH THE RECORD ADDRESS
	XCALL	<$RERR>			;BETTER NOT BUMP REF COUNT OF NULL
	HRLOI	A,(<AOS	(TEMP)>)	;SHOULD PUT <AOS -1(<INDEX AC>)> INTO A
	TLZ	FF,RELOC		;AN ABSOLUTE VALUE
	PUSHJ	P,CODOUT		;EMIT ONE OF THESE
	SOJG	C,.-1			;PUT OUT A MESS OF THEM
	JRST	RFCXIT			;DONE

>;NORGC
>;REC

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....

JOBERR←←42

DEFINE	XX (NAME,MESSG,CODE) <     
↑NAME : ERR.	1,[ASCIZ/MESSG/]

;;##LN##KVL - MAKES EXECUTION OF BAD CODE HARDER
IFN CODE,<
	 HLLOS	JOBERR		;CAUSES LOADER TO DELETE EXECUTION (HOPEFULLY)
	>;CODE

	 POPJ	P,
	>;XX

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,<CANNOT BEGIN A DECL OR STMNT LIKE THIS.
(MOST LIKELY A DECL AFTER A STMNT)>,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: SEE A SAIL HACKER>,1);


DEFINE YY (NAME,MESSG) <
↑NAME:		;SHOULD REALLY BE AN ERRPRI
		PUSH	P,A
		MOVEI	A,[ASCIZ /MESSG
/]
		PUSHJ	P,PRINT.
		POP	P,A
		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 DECLARATIONS AS ARGUMENTS - FLUSH REST OF STATEMENT>)


XX (ERR112,<BIND OR ? USED INCORRECTLY, WILL BE IGNORED>,1)
XX (ERR113,<PROPS REQUIRES SINGLE ITEM EXPR AS ARGUMENT>,1)
XX (ERR114,<PROPS MAY BE ASSIGNED ONLY ARITHMETIC VALUES>,1)
XX (ERR115,<MISSING ARRAY BOUND-PAIR LIST>,1)
XX (ERR116,<INVALID SAMEIV SYNTAX>,1)
XX (ERR117,<INVALID IN!CONTEXT SYNTAX>,1)
XX (ERR118,<MISUSE OF EXPR!TYPE>,1)
XX (ERR119,<INVALID CONTEXT ELEMENT SYNTAX>,1)
XX (ERR120,<ILLEGAL ASSIGNC PARAMETER NAME>,1)
XX (ERR121,<CONDITIONAL COMPILATION PROBLEM  PROBABLY EXTRA ENDC OR ELSEC>,1)
XX (ERR122,<NOMAC REQUIRES A MACRO NAME WITH NO ARGUMENTS>,1)
XX (ERR123,<CVPS REQUIRES A LEFT PARENTHESIS HERE>,0)
XX (ERR124,<ILLEGAL CVPS PARAMETER NAME>,1)
;; #QT# BETTER DIAGNOSTIC FOR ELSE
XX (ERR125,<EXTRANEOUS "ELSE", WILL BE IGNORED>,1)

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 productions pushj,popj 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 production pushj popj 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.
	MOVE	TBITS,$TBITS(LPSA)	; THE TYPE...
	JUMPN	TBITS,QL		; IS OKAY...
	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:
	TLNE	FF,CREFSW
	PUSHJ	P,CREFDEF	; DEFINE WHAT WE'RE KILLING TO CREF
	PUSHJ	P,URGSTR
	PUSHJ	P, URGVRB	; UNRING IT
	FREBLK  (LPSA)
	POPJ	P,


;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...
	HRRZI	LPSA,PNAME-1		;SET UP LPSA WITH IDD'S NAME
	ERR	<UNDECLARED IDENTIFIER: >,3
     	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

;;%AC% REMOVE  GLOBAL DECLARATION OPTION
IFN 0 <
;The following is how to declare an identifier in the outermost block.
;Social pressures forced its removal from the error recovery, but I
;thought I'd leave it around for a while in case the algorithm is needed
;for another purpose. -kvl
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 PNTS TO 1ST
	MOVE	PNT,QQBLK		; GET THE HIGHEST BLOCK
	HRRM	LPSA,%RVARB(PNT)	; BLK IN 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 PNTS TO 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 PNTS TO UNDECLARED-GUY
	HRRM	B,%TBUCK(PNT2)	; UNDECLARED-GUY PNTS TO 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,
>;  IFN 0
 
ZERODATA 
↑↑QQFLAG:0
↑↑QQBLK: 0 

ENDDATA
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
		ERRPRI <UNDECLARED IDENTIFIER DECLARED A LABEL>
		JRST .+15]
	CAMN	PNT,  %ISV		; SET
	JRST   [TRO TBITS,SET
		ERRPRI <UNDECLARED IDENTIFIER DECLARED A SET>
		JRST .+13]
	CAMN	PNT,%ARID		; AN ARRAY
	JRST   [TLO TBITS, SBSCRP!SAFE
		ERRPRI <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]
		ERRPRI <UNDECLARED IDENTIFIER DECLARED A INTEGER PROCEDURE>
		JRST .+3]
	CAMN	PNT,%ITV		; ITEMVAR
	JRST   [TRO  TBITS, ITMVAR!INTEGR
		ERRPRI	<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	; PTR TO ARR (OR TO 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 drarrow	EXEC SCOMM SCAN ¬S1 #Q6
⊗

↑SCOMM1: SKIPA	PNT,GENLEF+1	;SEMANTICS FROM GENLEF+1

↑SCOMM:	MOVE    PNT,GENLEF	;SEMANTICS OF CONSTANT
	PUSHJ	P,GETAD		;
	TRNN	TBITS,STRING	;MUST BE A STRING CONSTANT
	 JRST	 [ERR	<I THOUGHT IT WAS A STRING COMMENT>,1
		  POPJ	P,]
	JRST	REMOP
BEND	SCOMM
SUBTTL	START!CODE (inline) EXECS

BEGIN  INLINE

ZERODATA (START!CODE VARIABLES)

?ACSWCH: 0		;ACCESS HAS BEEN SEEN (-1) OR NOT (0)

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

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

?INSTBL: 0		;PTR TO 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

NOTENX <
TNAME:	OPNAME
	'OPS   '
TWORD3: 0
TPPN:	OPPPN
>;NOTENX
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	ACSWCH			;RESET ACCESS SWITCH
	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 OR ¬STRING,
;; #JRL#
	TRNN	TBITS,STRING		; REVERSE ASSUMPTION
	TRZ	A,FXTWO
;; #PK# 12-2-73 DO A REMOP HERE
	PUSHJ	P,EMITER		;GO EMIT CODE
	JRST	REMOP			;REMOP IT
;; #PK#

↑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 ⊗

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

TENX<
	SKIPE	INSTBL			;TABLE READ IN?
	  JRST	TABLIN			;YES
	PUSH	P,A
	HRROI	B,[OPFILE]
	HRLZI	A,100001		;OLD FILE, SHORT FORM
	JSYS	GTJFN
	  ERR	<CAN'T FIND OPFILE>
	
	HRLI	A,400000		;XWD FORK, JFN
	JSYS	GET			;OPFILE IS SSHARED
	SETOM	INSTBL			;MARK THAT THE TABLE IS HERE
	POP	P,A
>;TENX

TABLIN:	

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

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

TENX<
COMMENT !
	In TENEX, the opcode table is created by MAKTAB.TNX to
be a SSAVEd file.  It consists of the operations names (in sixbit),
their opcodes, in bucket-driven link lists.
	!
OPBUKT←←=307				;NUMBER OF BUCKETS
BUKPAG←←600				;STARTING PAGE FOR OPTABLE
BUKTST←←BUKPAG*1000			;STARTING ADDR FOR BUCKETS

	MOVM	B,A			;ABS(OPCODE)
	IDIVI	B,OPBUKT		;COMPUTE BUCKET NUMBER IN C
	MOVE	B,BUKTST(C)		;GET BUCKET POINTER
			
TABLI1:	CAMN	A,(B)			;IS THIS THE RIGHT OPCODE?
	  JRST	FNDOPC			;YES	  
	SKIPN	B,2(B)			;CDR DOWN LIST, ARE WE TO NIL
	  JRST	UNFNDOP			;YES, NO MORE	
	JRST	TABLI1			;NO, KEEP GOING

FNDOPC:	MOVE	B,1(B)			;PICK UP THE OPCODE
	MOVEM	B,GENRIG		;STORE FOR A WHILE
	MOVE	TEMP,%OPC		;MARK OPCODE FOUND
	MOVEM	TEMP,PARRIG		;SAVE FOR PARSER
UNFNDOP: POPJ	P,			;RETURN, ANSWER IN B

>;TENX
↑CESSGO:MOVE	TEMP,OPDUN		;SAVING OPDUN
	MOVEM	TEMP,T.OPDUN
	SETZM	OPDUN
	POPJ	P,

↑CESSOK:				;THIS EXEC TO DO THE ACCESS CONSTRUCT
	MOVE	PNT, GENLEF+1		;GET THE @E
	GENMOV	ACCESS, GETD		;MAKE SURE THE EXPR IS AVAILABLE
	SETOM	ACSWCH			;TELL THE CODVBL GUY NOT TO COMPLAIN
;	PUSHJ	P,REMOP			;DESTROY TEMPORARIES WITH ABANDON
	MOVE	TEMP,T.OPDUN		;RESTORE OPDUN
	MOVEM	TEMP,OPDUN
	POPJ	P,

T.OPDUN:0				;PLACE TO PUT OPDUN
	
↑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
	SKIPN	ACSWCH			;DON'T COMPLAIN IF ACCESS HAPPENED
	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
NOTENX<
	DPB	A,[POINT 9,OPCOD,8]	;OPCOD POSITION
>;NOTENX
TENX<
	MOVEM	A,OPCOD			;36-BIT OPCODE
>;
	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 ('03)
	MOVEI	D,LSTOU1		;USE THIS LIST ROUTINE
	JRST	KOUNT1+2
↑KOUNT2:		;EVENTUALLY, CHECK FOR MULTIPLE LABELS
↑KOUNT1: MOVEI	B,2			;MARKER IS ALPHA ('02)
	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