perm filename SYM[S,AIL]4 blob sn#015208 filedate 1972-12-03 generic text, type T, neo UTF8
COMMENT ⊗   VALID 00038 PAGES VERSION 16-2(37)
RECORD PAGE   DESCRIPTION
 00001 00001
 00005 00002	HISTORY
 00008 00003	SCAN
 00011 00004	BITDATA (SCNWRD -- LISTING CONTROL, ETC.)
 00017 00005	DATA (SCANNER PARSE TOKENS)
 00022 00006	DSCR main SCANNER Dispatch loop
 00027 00007	 ID -- RESET FOR SCAN
 00035 00008	Comment   COMMENT -- throw out everything to next semicolon
 00036 00009	DSCR -- USID
 00044 00010	
 00051 00011		PUSH	PNT,PNEXTC-1	STRING NUMBER
 00055 00012	DSCR STRNG, etc.
 00059 00013	 
 00064 00014	DEFCHK:
 00074 00015	DSCR SCNUMB -- number scanner
 00081 00016	Comment 
 00083 00017	Comment  Print the last character, then stack the result
 00086 00018	DSCR CSPEC, SEOL, SEOM, SEOB -- Special handling routines
 00090 00019	Cspec, Seol
 00091 00020	 CALL SPECIAL ROUTINE, BUT FIRST MAKE SURE CHARACTER COUNT IS
 00096 00021	
 00102 00022	 END OF BUFFER CODE.
 00104 00023	Comment  Parameter delimiter or end of message 
 00110 00024	DSCR ADVBUF -- new input buffer routine
 00114 00025	UPDCNT:	HRRM	C,PNAME			UPDATE PNAME
 00116 00026	NOGAG <
 00122 00027	DSCR HDR, HDROV 
 00127 00028	DSCR ENTERS -- make new symbol entry
 00131 00029	↑ENTERS:	
 00136 00030	 
 00142 00031	
 00144 00032		JSP	A,LNK		LINK TO BUCKET LIST
 00145 00033	DSCR ADCINS, CREINT, CONINS
 00149 00034	DSCR SHASH, NHASH -- look up symbol entries in hashed buckets.
 00155 00035	SEMBLK Allocation Routines
 00162 00036	RNGVRB, RNGSTR, etc. -- `Ring' Linkage Routines
 00165 00037	
 00168 00038	 Mark insertion routine for counter routines
 00171 ENDMK
⊗;
COMMENT ⊗HISTORY
AUTHOR,REASON
021  202000000045  ⊗;


COMMENT ⊗
VERSION 16-2(37) 12-2-72 BY HJS SAVE BITS DURING CONDITIONAL COMPILATION AND MACRO DEFINITIONS (CBTSTK AND DBTSTK)
VERSION 16-2(36) 11-20-72 BY JRL FIX SUGG BY R. SMITH AT CHKPRC
VERSION 16-2(35) 11-19-72 BY HJS BUG #JZ# CORRECTION - MACRO REDEFINITION AND RESERVED WORD REDEFINITION IN ENTERS
VERSION 16-2(34) 11-15-72 BY HJS INSERT DEFDLM QSTACK FOR DEFLUK BIT OF FF FOR COMPILE-TIME MACROS WITHIN MACROS
VERSION 16-2(33) 11-5-72 BY DCS BUG #JZ# CHANGE MACRO SCOPE RULES
VERSION 16-2(32) 11-3-72 BY DCS SIMILARLY, ALLOW ALL EXTERNALS TO OVERRIDE
VERSION 16-2(31) 11-2-72 BY DCS BUG #JX# ALLOW INTRNL PROC TO OVERRIDE EXTRNL ONE.
VERSION 16-2(30) 10-24-72 BY HJS EMIT ERR MSG FOR UNINIT MACRO VAR USE
VERSION 16-2(29) 7-5-72 BY DCS BUG #IF# FIX SOME GOERGE BUGS
VERSION 15-6(18-28) 7-5-72 
VERSION 15-6(17) 3-10-72 BY DCS REPLACE RING,ULINK MACRO WITH VARIOUS ROUTINES
VERSION 15-6(8-16) 3-9-72 
VERSION 15-6(7) 2-21-72 BY HJS THE BRAVE NEW PARSER WORLD
VERSION 15-2(6) 2-18-72 BY DCS BUG #GP# CHECK OLD FORMALS AGAINST NEW FORMALS
VERSION 15-2(5) 2-5-72 BY DCS BUG #GJ# ADD LSTON LIST-CONTROL STUFF
VERSION 15-2(4) 2-5-72 BY DCS BUG #GI# REMOVE TOPSTR
VERSION 15-2(3) 2-1-72 BY DCS BUG #GE# LPSBOT FROM USER TABLE TO COMPILER DATA
VERSION 15-2(2) 12-22-71 BY DCS BUG #FT# PROVIDE LINE NUMBER IF NOT SOS FILE
VERSION 15-2(1) 12-2-71 BY DCS INSTALL VERSION NUMBER

⊗;
SUBTTL	SCAN
	LSTON	(SYM)
BEGIN SYM

DSCR SCANNER -- get next "ATOM" from source file
CAL PUSHJ from PARSE (or recursively)
PAR PNEXTC is bp to next input char (from file or macro)
 SAVCHR, if non-zero, is a scan-ahead char which should
  be considered first.
 File variables, Listing variables used by I/O part.
 Define stack, variables, macro semantics used when
  recurring into macros

RES The ATOM will be either:

1. An operator or other character atom, in which case
	the Parse token representing it will be placed in the
	parse stack, a 0 in the generator stack (null entry).

2. A reserved word, in which case the Parse token will be 
	placed on the parse stack from the word's symbol 
	entry, and again a null semantic entry will be stacked.

3. An IDENTIFIER, in which case the Parse token for the appro-
	iate class of IDs will appear on the parse stack, the
	Semantics for the symbol on the generator stack. If the
	symbol is undefined, a 0 is represents null Semantics.

4. A STRING or numeric constant. These entities are ENTERed 
	in their respective symbol tables if previously 
	undefined, and the stacks are set up as above.


 In all cases, the semantic entry will be repeated in the cell
	NEWSYM. In those cases where a hash was made, the
	MOVE or MOVS instr to fetch the list on which the symbol
	appears (or will appear after ENTERy) is located in
	the cell HPNT. For string constants or identifiers, the
	string	identifier is left in PNAME, PNAME+1. For numeric
	arguments, the value is left in SCNVAL. DBLVAL is zeroed
	in these cases.

SID SCANNER uses temporary ACs indiscriminately, so look out for it.
 Many variables are changed as a result of calling SCANNER.
⊗
BITDATA (SCNWRD -- LISTING CONTROL, ETC.)

Comment ⊗ SCAN table -- good bits that make the whole thing work ⊗

↑↑LSTEXP←←400000		;ON IF "⊂"-"⊃" PAIRS TO BE PRINTED
↑↑MACEXP←←200000		;EXPAND MACRO TEXTS
↑↑MACLST←←100000		;LIST MACRO NAMES BEFORE EXPANSION
↑↑LINESO←← 40000		;ON IF LINE NUMBERS SHOULD BE PRINTED
↑↑PCOUT ←← 20000		;ON IF PCNT SHOULD BE PRINTED
↑↑CREFIT←← 10000		;ON IF A CREF S HAPPENING
↑↑MACIN ←←  4000		;ON IF IN A MACRO EXPANSION
↑↑EOFOK ←←  2000		;ON IF CAN GET EOF WITHOUT FATALITY
↑↑BACKON←←  1000		;ON IF LISTING BACK ON AFTER PARAM RESCAN
↑↑LOKPRM←←  400			;ON IF LOOKING FOR POSSIBLE MACRO PARAM
↑↑RDYPRM←←  200			;GETTING READY FOR MACRO PARAM (RANSCN)
↑↑INLIN ←←  100			;TREAT @ AS DELIMITER IN IN-LINE CODE
↑↑INSWT ←←   40			;WE'RE SCANNING A SWITCHED-TO SOURCE FILE
  ↑NOLIST←←     1		;ON IN RH IF NO LISTING HAPPENING NOW

BITDATA (SCANNER TABLE)

SPCL  ←←400000		;NOT A LETTER OR DIGIT
ATSIGN←← 20000		;@ -- REAL EXPONENT COMING
AOSSOS←← 20000		;BIT DIFFERENTIATING BETWEEN AOS AND SOS FOR NESTING
			;   DELIMITERS COUNT
DOT   ←← 10000		;. -- DECIMAL POINT
NUMB  ←←  4000		;NUMBER OR NUMBER PART (ONE OF ABOVE TWO)
DIG   ←←  2000		;0 THRU 9
LETDG ←←  1000		;REQUIRES SPECIAL TREATMENT
QUOTE ←←   400		;" -- STRING CONSTANT DELIMITER
↑NEST  ←←   200		; NESTABLE CHARACTER
↑LNEST ←←   100		; LEFT NESTED CHARACTER
QUOCTE←←    40		;' -- OCTAL NUMBER COMING

; BITS FOR NUMBER SCANNER

INTOV ←←200000		;INTEGER OVERFLOW
REALOV←←100000		;REAL OVERFLOW
EXPNEG←← 40000		;NEGATIVE EXPONENT
NUMNST ←←3		; NUMBER OF NESTABLE CHARACTERS
RPAROF ←←2		; RIGHT PAREN OFFSET FOR LOCNST ENSTRY
↑NUMCHA ←←200		; NUMBER OF CHARACTERS
↑DELNUM ←←4		; NUMBER OF DELIMITERS AS INPUT TO REQ. DEL.


TABCONDATA (SCANNER CHARACTER TABLE)

DEFINE IGL <XWD SPCL,IGLCHR>
DEFINE OPER <.-SCNTBL>
DEFINE LTR <XWD LETDG,.-SCNTBL>
DEFINE NESTED <<XWD NEST,0>>
DEFINE LNESTD <<XWD NEST+LNEST,0>>

↑SCNTBL:
	XWD	SPCL,SEOB		;0 -- END OF BUFFER
	LTR 				;↓ α  BETA
	LTR 
	LTR 
	RAND ↔ RNOT ↔ RIN		;∧ ¬ ε
	REPEAT 2,<LTR >			;π λ
	0				;TAB
	XWD SPCL,SEOL		;LF -- END OF LINE
	0				;VTAB
	XWD SPCL,SEOP			;FF -- END OF PAGE
	0				;CARRIAGE RETURN
	RINF				; ∞ -- INFINITY.
	LTR 				; ∂ ⊂ ⊃
	REPEAT 2,<LTR >
	RINTER ↔ RUNION			; ∩ ∪
	LTR  ↔ LTR 			; ∀ ∃
	RXOR↔RSWAP			; ⊗  ↔
	LTR 				;UNDERLINE ?
	LTR  ↔ RAND			; → ∧
	RNEQ ↔ RLEQ ↔ RGEQ ↔ REQV ↔ ROR	;≠ ≤ ≥ ≡ ∨
	0				;SPACE
 	XWD LETDG,30			;! -- SAME AS UNDERLINE.
	XWD	QUOTE,.-SCNTBL		;   "
	LTR ↔ LTR			;# $ 
	TPRC				; %
	TANDD				;&
	XWD	LETDG+NUMB+QUOCTE,.-SCNTBL	;   '
	LNESTD+TLPRN			; (
	NESTED+TRPRN			; )
	TTIMS ↔ TPLUS ↔ TCOMA ↔ TMINUS  ; *+,-
	XWD	LETDG+NUMB+DOT,.-SCNTBL		; .
	TSLSH					;  /
	REPEAT 12,<XWD LETDG+NUMB+DIG,.-SCNTBL>	;DIGITS
	TCOL ↔ TSEMI 			;  : ;
	TLES				; <
	TEQU       			; =
	TGRE				; >
	TQUES				;?
	XWD	LETDG+NUMB+ATSIGN,.-SCNTBL	;  @
	REPEAT =26,<LTR>			;UPPER CASE LETTERS
	LNESTD+TLBR			; [
	LTR  				; TILDE
	NESTED+TRBR			; ]
	TUPRW ↔ TLARW ↔ RASSOC		; ↑ ← `
	REPEAT =26,<LTR-40>			;LOWER CASE LETTERS
	LNESTD+RSETO			; {
	TVERT				; |
	RSETC			; }
	NESTED+RSETC			; }
; 175 AND 176 WILL BOTH BE CURLY BRACKETS FOR A WHILE.
	XWD	SPCL,EOM			;177 -- END MACRO OR PARAM
ENDSCN←.
DATA (SCANNER PARSE TOKENS)

COMMENT ⊗
  These variables provide symbolic access to the PARSE token
 numbers for several delimiter characters -- they are used in
 those cases where the SCANNER or some EXEC needs to examine
 a value directly
⊗
%ATS:	TINDR		;BITS FOR @ DELIMITER IN INLINE(SEE SCNUMB)
%COMMENT: RCOMME+1B0
↑↑%ID:	TI
%NUMCON: TICN		;ARITHMETIC CONSTANT.
%SEMICOL: TSEMI
↑↑%STCON:TSTC		;STRING CONSTANT.

ZERODATA (SCANNER VARIABLES)

↑↑DEFRN2: 0	;TEMP RING-VARIABLE WHILE SCANNING MACRO ACTUAL PARAMS

;FLTVAL -- collect floating point equiv while scanning number
↓FLTVAL: 0

COMMENT ⊗
HPNT, HSPNT -- When the hashing routines (SHASH, NHASH) locate the
  right bucket pointer in the appropriate bucket Semblk, they create
  a [HRR LPSA,addr] or [HLR LPSA,addr] instruction which will fetch
  this pointer, and put it into HPNT -- also leaving it in LPSA. They
  then execute the instruction to begin their lookup phases.  ENTERS
  again uses this pointer when adding a new Semblk to a bucket -- first
  as is, to fetch the old pointer, then modified to HRRM or HRLM, to 
  update the bucket.
  HSPNT is the saved HPNT value for the last string constant scanned.
  The "string constant as comment" EXEC uses it to remove the constant
  from the bucket (provided, of course, that it hasn't also been used
  as a string constant).
⊗
↑HPNT: 0

↑HSPNT: 0

↑↑LOCMBD:  BLOCK 2		; MACRO BODY DELIMITERS BLOCK
↑↑LOCMPR:  BLOCK 2		; MACRO PARAMETER DELIMITERS BLOCK
BAKDLM:	   0			; A FLAG WHICH IS SET TO -1 IF DLMSTG IS ON
				;  (I.E. ONE WANTS A DELIMITED MACRO BODY)
				;  AND QUOTES ARE USED INSTEAD BECAUSE A 
				;  REQUIRE NULL DELIMITERS STATEMENT WAS NOT
				;  USED.
↑↑CURMBG:  0			; CURRENT MACRO BODY BEGIN DELIMITER
↑↑CURMED:  0			; CURRENT MACRO BODY END DELIMITER 
↑↑CURPBG:  0			; CURRENT PARAMETER BEGIN DELIMITER
↑↑CURPED:  0			; CURRENT PARAMETER END DELIMITER
↑↑DELSTK:  0			; DELIMITER "BLOCK-STRUCTURE" STACK
↑↑LOKDLM:  0			; DLMSTG (LOOKING FOR DELIMITERS FLAG) QSTACK
↑↑DEFDLM:  0			; DEFLUK (SCANNING A MACRO BODY OR LOOKING FOR
				;  ACTUAL PARAMETERS) QSTACK
↑↑CBTSTK:  0			; POINTER TO QSTACK FOR SAVING BITS WHILE SCANNING 
				;  CONDITIONAL COMPILATION EXPRESSIONS
↑↑DBTSTK:  0			; POINTER TO QSTACK FOR SAVING BITS WHILE SCANNING 
				;  MACRO DEFINITIONS
↑↑REQDLM:  0			; REQUIRE DELIMITER STATEMENT SEEN FLAG
↑↑SWBODY:  0			; SPECIAL DELIMITER DEFINITION SEEN
↑↑BNSTCN:  0			; NESTED DELIMITER COUNT
↑↑LOCNST:  BLOCK NUMNST  	; NESTABLE CHARACTERS BLOCK
↑↑NSTABL:  BLOCK NUMCHA		; NESTABLE CHARACTERS ADDRESS INDEX BLOCK

ENDDATA

DSCR  LSTDPB
⊗

DEFINE LSTDPB	<		;OUTPUT CHAR TO LISTING FILE IF REQD
	TRNN	TBITS2,NOLIST	;IS LISTING HAPPENING, BABY?
	IDPB	B,LPNT		;YES, DO THE REQUIRED THING
>
DSCR main SCANNER Dispatch loop
RES gets first char from SAVCHR or PNEXTC, dispatches to
 routine to handle what it found (IDENT, STRING, DELIM, etc.)
⊗
↑SCANNER:	
	MOVE	TBITS2,SCNWRD	; SET UP SCANNER PARAMS
	TLZE	FF,BAKSCN	;IS SCANNER BACK ONE CHARACTER ??
	 JRST	 GOAGAIN	; DO IT.
	MOVE	USER,GOGTAB	;USER DATA TABLE ADDR FOR STRING STUFF
	TLNE	TBITS2,INLIN	;SPECIAL START_CODE FEATURE?
	SETZM	PNAME		;YES, ASSURE NO PNAME USED
	MOVEI	C,0		;WILL COUNT CHARS FOR IDENTS
	SKIPE	B,SAVCHR	;IS ANYTHING LEFT OVER?
	 JRST	 SPCHAR		;YES, DISPATCH AS FIRST CHAR

	TLNN	FF,PRMSCN	;SCANNING MACRO PARAMETERS?
	 JRST	 DISPT		; NO
	 TRNA			;SKIP IDPB

	IDPB	B,LPNT		;TO LISTING FILE
DSPRM:	ILDB	B,PNEXTC	;SKIP IGNORABLE CHARACTERS
	SKIPGE	A,SCNTBL(B)	;ANYTHING SPECIAL REQUIRED?
	PUSHJ	P,(A)		;YES, DO IT
	JUMPE	A,DSPRM-1(TBITS2) ;MAYBE LIST, GET NEXT IGNORABLE

DSPR1:	TLO	FF,PRMXXX	;SET SPECIAL PARAM SCANNING BIT
	TLNE	A,QUOTE		;DOES HE WANT COMPLETE FREEDOM?
	 JRST	 STRLST		; YES, GIVE IT TO HIM (FIRST LIST `"')
	PUSHJ	P,INSET		;NO, SPECIAL MODE -- "," OR ")" WILL BREAK
	JRST	BAKSTR		;AROUND QUOTE DELETION

	IDPB	B,LPNT		;TO LIST FILE
DISPT:	ILDB	B,PNEXTC	;GET FIRST CHAR
	SKIPGE	A,SCNTBL(B)	;GET GOOD BITS, CHECK SPECIAL
	PUSHJ	P,(A)		;SPECIAL, HANDLE IT
	 JUMPE	 A,DISPT-1(TBITS2) ;BLANKS AND OTHER IGNORABLES
	MOVE	SBITS2,LPNT	;SAVE IN CASE BACKUP MUST HAPPEN
STRLST:	LSTDPB			;TO LISTING FILE IF REQD

SPCHAR:	SETZM	SAVCHR		;NOTHING LEFT OVER YET
	SETZM	LSTCHR
	JUMPL	B,[TLZN	TBITS2,EOFOK	;OK FOR EOF HERE?
		   ERR  <FATAL END OF SOURCE FILE>	;NO
		   MOVE	A,%EOFILE	;YES, RETURN `EOF'
		   JRST	CHAROUT]	;NULL SEMANTICS
	SKIPN	A,SCNTBL(B)	;GET GOOD BITS (DON'T DISPATCH AGAIN!)
	JRST	DISPT		; IGNORABLE, FIND ONE THAT ISN'T
	SKIPE	DLMSTG		; LOOKING FOR SPECIALLY DELIMITED STRING?
	CAME	B,CURMBG	; POSSIBLY, MACRO BODY BEGIN DELIMITER?
	JRST CONCHK		; GO DO A NORMAL SCAN
	SETZM	BNSTCN		; SET DELIMITER NEST COUNT TO ZERO
	JRST	STRNG		; GET MACRO BODY
CONCHK:	TLNE	A,LETDG		; LETTER OR NUMBER?
	JRST	CHKNUM		; YES, GO SEE WHICH
       	TLNN	A,QUOTE		;STRING CONSTANT?
	 JRST	 CHAROUT	; NO, OPERATOR, OUTPUT ID, NULL SEMANTICS
	SKIPN	DLMSTG		; HAS A QUOTE BEEN USED TO DELIMIT A MACRO
				;  BODY WHILE IN REQUIRE DELIMITERS MODE?
	JRST	STRNG		; NO, SCAN A STRING CONSTANT IN NORMAL MODE.
	SETZM	DLMSTG		; YES, TURN OFF DLMSTG FLAG AND TURN ON 
	SETOM	BAKDLM		;  BAKDLM FLAG SO THAT WHEN SCANNING THE 
	JRST	STRNG		;  MACRO BODY A QUOTE WILL BREAK THE SCAN.

CHKNUM:	TLNE	A,NUMB		;NUMBER PART?
	 JRST	 SCNUMB		; YES, SCAN NUMBER

; ID -- RESET FOR SCAN

DSCAN:	PUSHJ	P,INSET		;CLEAR PNAMES, COUNT, ALIGN TO FW
	MOVE	TBITS2,SCNWRD	;MAKE SURE THE BITS ARE RIGHT
	TLO	TBITS2,EOFOK	;EOF CAN END THE WORLD WITHOUT KILLING IT
	MOVEI	C,1		;ACCOUNT FOR FIRST CHARACTER
	TRNA
	IDPB	B,LPNT		;TO LISTING FILE
IDSCAN:	IDPB	A,TOPBYTE(USER)	;STORE CONVERTED CHAR
	ILDB	B,PNEXTC	; GET NEXT CHARACTER
	SKIPGE	A,SCNTBL(B)	;GET GOOD BITS, CHECK SPECIAL
	PUSHJ	P,CSPEC		;SPECIAL, DO SOMETHING
	TLNE	A,LETDG		;DONE WITH ID?
	 AOJA	 C,IDSCAN-1(TBITS2) ;NO, GO GET MORE.

Comment ⊗ Now the symbol is in string space, pointed to
	by the string descriptor in PNAME, etc. Store the
	count, make the lookup, set up the results ⊗

	CAIE	B,12		;IF LF, ALREADY HANDLED, LEAVE SAVCHR 0
	MOVEM	B,SAVCHR	;SAVE THE BREAK BITS (0 IF BLANK OR CR BROKE)
	MOVEM	B,LSTCHR	;ALSO HERE ANY TIME
	TLZ	TBITS2,EOFOK	;DONE WITH THIS MODE

	PUSHJ	P,UPDCNT	;UPDATE PNAME CNT, REMCHR CNT, COLLECT IF NECC.
	MOVE	LPSA,SYMTAB	;TRY TO FIND IT
	PUSH	P,B		;SAVE FOR LATER
	PUSHJ	P,SHASH		;LIKE SO
	POP	P,B		;GET IT BACK
	MOVEM	TBITS2,SCNWRD	;SAVE ANY CHANGES
	TLNE	TBITS2,LOKPRM	;STACK IT?
	 POPJ	 P,		; NO, IN STRING CONSTANT MODE

;  GET RELEVANT DATA TO STACKS

	MOVE	A,%ID		;IT IS AN IDENTIFIER
	SKIPG	LPSA,NEWSYM	;IF IT IS UNDEFINED,
	 JRST	 LSTACK		;   PUSH TO STACKS

	MOVE	TBITS,$TBITS(LPSA)
NOGAG <
;IF CREFFING, DO IT NOW...
	TLNE	FF,CREFSW	;
	PUSHJ	P,LCREFIT
>;NOGAG

	 JUMPGE	 TBITS,USID	; NO, USER ID
	LSTDPB
	MOVE	A,TBITS		;RESULTANT PL-ID
	MOVEI	LPSA,0		;MAKE NULL SEMANTICS
	CAMN	A,%COMMENT	; COMMENT?
	 JRST	 CHKSAV		; YES, GO PROCESS IT
	TLNE	TBITS,CONRES	; PARSER SWITCHING RESERVED WORD?
	SKIPN	SWCPRS		; YES, NEED TO SWITCH PARSERS?
	JRST	STACK		; NO, RETURN RESERVED WORD
	TLNE	TBITS,DEFINT	; PARSER INTERRUPT (I.E. NO SWITCHING)?
	JRST[SKIPE NODFSW	; DEFER DEFINE HANDLING FOR BLOCK EXECUTION?
	JRST	STACK		; YES, RETURN RESERVED WORD
	MOVE 	TEMP,SCNNO	; YES, SAVE NUMBER OF SCANS REMAINING IN LEFT HALF 
	MOVE	B,PCSAV		;  OF TOP OF PRODUCTION STACK, UNPACK $TBITS ENTRY 
	HRLM	TEMP,(B)	;  OF THE RESERVED WORD TO GET AN INDEX OF ADDRESS 
	JRST	CONDAD]		;  TO PUSHJ TO, AND SET SCNNO TO ONE.
	SKIPE	PRSCON		; DETERMINE WHICH PARSER ONE IS CURRENTLY IN AND 
	SKIPA	TEMP,[CGPSAV-1]	;  GET THE ADDRESS TO SAVE ITS PARSER DESCRIPTOR.
	MOVEI	TEMP,SGPSAV-1	;  SAVE SEMANTIC STACK POINTER, PARSE STACK POINTER,
	PUSH	TEMP,GPSAV	;  NUMBER OF SCANS REMAINING IN LEFT HALF OF TOP OF 
	PUSH	TEMP,PPSAV	;  PRODUCTION STACK, PRODUCTION STACK POINTER, 
	MOVE	SP,SCNNO	;  CURRENT SCNWRD, AND A POINTER TO THE SCNWRD 
	MOVE	B,PCSAV		;
	HRLM	SP,(B)		;  STACK.
	PUSH	TEMP,PCSAV	;
	MOVE	B,SCWSV		;
	MOVEM	TBITS2,(B)	; SAVE SCNWRD
	PUSH	TEMP,SCWSV	;
	SKIPE	PRSCON		; DETERMINE WHICH PARSER IS TO BE RESUMED AND GET 
	SKIPA	TEMP,[XWD -1,SSCWSV] ;  THE ADDRESS OF ITS PARSER DESCRIPTOR.
	HRROI	TEMP,CSCWSV	;
	POP	TEMP,B		; RESTORE SCNWRD STACK POINTER
	TLNE	TBITS,CONDIN	; IF ONE IS SWITCHING PARSERS VIA A PUSHJ INSTEAD OF
	JRST[TLZ TBITS2,INLIN	;  PROPER SCANNING OF INLINE STARTCODE.  COMPENSATE
	TRO	TBITS2,NOLIST	;  FOR NOT POPPING TEMP.
	PUSH	B,TBITS2	;
	JRST	.+2]		;
	MOVE	TBITS2,(B)	; RESTORE SCNWRD AND TBITS2
	MOVEM	B,SCWSV		;
	MOVEM	TBITS2,SCNWRD	;
	MOVEM	SBITS2,LPNT	; DON'T LIST PARSER SWITCH TRIGGERING RESERVED WORDS
	POP	TEMP,B		; RESTORE CONTROL STACK POINTER
	POP	TEMP,SP		; RESTORE PARSE STACK POINTER.  MUST BE IN AC AS 
	MOVEM	SP,PPSAV	;  WELL AS IN MEMORY.
	POP	TEMP,GPSAV	; RESTORE SEMANTIC STACK POINTER
	SETCMM	PRSCON		; COMPLEMENT PARSER IN CONTROL FLAG
	MOVEI	C,1001		; ASSUME A RESUME TYPE SWITCH
	TLNN	TBITS,CONDIN	; RESUME TYPE SWITCH?
	JRST	SWTPRE		; YES
CONDAD:	HLRZ	C,TBITS		; CONDAD IS CALLED WITH THE $TBITS ENTRY 
	TRZ	C,RES+CONBTS	;  OF A PARSER INTERRUPT RESERVED WORD IN 
	LSH	C,-IF0SHF	;  TBITS.  IT INSERTS THE ADDRESS OF THE 
	MOVEI	C,PRODGO(C)	;  PRODUCTION WHICH ONE IS TO EXECUTE NEXT
	PUSH	B,C		;  IN THE PRODUCTION CONTROL STACK.  TBITS
	MOVEI	C,4001		;  IS UNPACKED TO GET AN INDEX TO A TABLE
				;  STARTING AT PRODG0 (BITS 6-8).  SET 
				;  REMAINING NUMBER OF CALLS TO SCANNER TO 
				;  ONE SO THAT THE PARSER WILL NOT SCAN 
				;  AGAIN AND SET A BIT TO DO A PUSHJ.
SWTPRE:	MOVEM	B,PCSAV		; RESTORE CONTROL STACK POINTER IN CORE
	MOVEM	C,SCNNO		; SET REMAINING NUMBER OF CALLS TO SCANNER
	JRST	STACK		; GO STACK

Comment ⊗  COMMENT -- throw out everything to next semicolon
⊗

CHKSAV:	MOVE	B,SAVCHR	;BE SURE SAVCHR IS NOT ";"
	SETZM	SAVCHR
	SETZM	LSTCHR
	SKIPGE	A,SCNTBL(B)	;GET BITS, CHECK SPECIAL
	PUSHJ	P,(A)		;SPECIAL, GET PAST PROBLEM
	JRST	COMLUP		;GET THEM ALL

	IDPB	B,LPNT		;TO LISTING FILE
COMLUP:	CAIN	B,";"		;DONE?
	 JRST	 SCANNER		; YES
COMILD:	ILDB	B,PNEXTC	;GET NEXT CHAR
	SKIPGE	A,SCNTBL(B)	;USUAL
	PUSHJ	P,(A)
	 JRST	 COMLUP-1(TBITS2) ;GO PUT AWAY, GET ANOTHER
DSCR -- USID
DES An identifier has been found.  If it is a macro name, go
  expand it.  Otherwise call TYPDEC routine to provide the
  proper parse token for this identifier (differentiates 
  ARRAYS from PROCEDURES from STRINGS from ....
SEE TYPDEC in GEN, for providing correct parse token.
⊗

USID:	TLNE	TBITS,DEFINE	;NEED TO EXPAND MACRO?
	JRST	DEFRG		;YES
GOHEQ:	LSTDPB
	PUSHJ	P,TYPDEC
NODIS <	        ;DISABLE GLOBAL FORMAL STUFF
	TLNN	FF,PRODEF	;IGNORE IF REDEFINING THE SAME FORMALS.
	TLNN	TBITS,FORMAL	;SEE IF HE HAS MISUSED A FORMAL.
	JRST	STACK		;NOT A FORMAL.
	LDB	B,PLEVEL	;THE LEVEL OF THIS SYMBOL.
	MOVE	C,TPROC		;THE CURRENT PROCEDURE.
	MOVE	C,$SBITS(C)	;THE LEVEL OF THE PROCEDURE.
	CAIG	B,(C)		;ARE THINGS OK?
	ERR	<USING A GLOBAL FORMAL:  >,3
>;NODIS
	JRST	STACK

DSCR DEFRG -- prepare to expand a macro
DES The Ident is a DEFINE Ident.  The steps are
1.	Save current Parse and Semantic Stack state,
	 other state which will be destroyed.
2.	If no parameters to get, go to step 5.
3.	Get a parameter (special form string constant,
	 see manual), via SCANNER (recursive call, also
	 ENTERS); place on special VARB-RING whose ring
	 variable is VARB, and whose starting element is
	 in DEFRN2.
4.	If comma, go to step 3 for more, else check for 
	 right paren.
5.	Save previous SCANNER information on DEFPDP stack,
	 set up DEFRNG for actuals, put macro body descrip-
	 tor in PNEXTC, restore stacks and VARB, etc.
6.	Handle macro expansions in listing.
7.	JRST to SCANNER for another try with the new PNEXTC
⊗

DEFRG:	HLRZ	A,%TLINK(LPSA)	; CHECK IF MACRO HAS BEEN INITIALIZED.
	JUMPN	A,DEFRG1	;
	ERR <MACRO WAS NOT INITIALIZED - INITIALIZE TO ZERO AND CONTINUE> ;
	SETZM	A		; SOLVES PROBLEMS SUCH AS:
	PUSHJ	P,CREINT	;  DEFINE NAME=NAME+1 WITHOUT A DEFINE NAME=0 
	MOVE	LPSA,PNT	;  OR ANOTHER INITIAL VALUE.
	MOVE	A,%NUMCON	;
	JRST	STACK		;
DEFRG1:				;CREATE A NEW DEFINE ELEMENT
	TLNE	FF,NOMACR	;EXPAND MACROS??
	JRST	[LSTDPB↔MOVE A,%ID ↔ JRST STACK];NO -- USER ID.

; IF WE DON'T WANT TO SEE MACRO NAMES IN OUTPUT LISTING, BACK UP OUTPUT PTR.
; ALSO TURN OFF LISTING FOR PARAMS

	TLNN	TBITS2,MACLST	;LIST MACRO NAMES?
	 JRST	 [MOVEM SBITS2,LPNT ;NO, NULLIFY ALL TO DATE
		  TRO	TBITS2,NOLIST ;LIST NO MORE FOR A WHILE
		  JRST	.+1]

	PUSHJ	P,SCNACT	; GET ACTUAL PARAMETER LIST
	PUSHJ	P,ACPMED	; FINISH OFF THE MACRO CALL PREPARATION
	JRST	SCANNER		; TRY AGAIN (SCAN THE MACRO BODY!)

; SPECIAL DELIMITER MODE ACTUAL PARAMETER SCANNING ROUTINE

SCNPMR:	PUSHJ	P,INSET		; SET UP STRING SPACE ENTRY
	TRNA			; SKIP
	IDPB	B,LPNT		; LIST MAYBE
DSPRMS:	ILDB	B,PNEXTC	; GET NEXT CHAR.
	SKIPGE	A,SCNTBL(B)	; SPECIAL?
	PUSHJ	P,(A)		; DO IT
	JUMPE	A,DSPRMS-1(TBITS2) ; AGAIN IF IGNORABLE
	CAME	B,CURPBG	; PARAMETER BEGIN DELIMITER?
	JRST	BALCHK		; NO, NESTED-BALANCED COMMA OR RPAR WILL BREAK
	LSTDPB			; LIST IT?
	SETZM 	BNSTCN		; SET NEST COUNT TO ZERO
	JRST	PSCAN+3		; CONTINUE SCAN
PSCAN:	LSTDPB			; LIST IT?
	IDPB	B,TOPBYTE(USER)	; DEPOSIT
	ILDB	B,PNEXTC	; GET NEXT CHAR.
	SKIPGE	A,SCNTBL(B)	; SPECIAL?
	PUSHJ	P,(A)		; DO IT
	CAMN	B,CURPED	; PARAMETER END DELIMITER?
	JRST    SPMEND		; YES, CHECK IF DONE
	CAMN	B,CURPBG	; PARAMETER BEGIN DELIMITER?
	AOS	BNSTCN		; INCREMENT NEST COUNT
	AOJA	C,PSCAN		; SCAN AGAIN
SPMEND: SOSL	BNSTCN		; DECREMENT NEST COUNT AND CHECK IF DONE
	AOJA	C,PSCAN		; NO, SCAN AGAIN
	ILDB	B,PNEXTC	; ADVANCE CHAR. TO KEEP IN SYNCH.
	SKIPGE	A,SCNTBL(B)	; SPECAIL?
	PUSHJ	P,(A)		; DO IT
	JRST 	ENDSTR		; GO TO END
DEPOSB:	CAIN	B,")"		; RIGHT PAREN WITH NONZERO NEST COUNT?
	SOS	LOCNST+RPAROF	; DECREMENT NEST COUNT
DEPOSA:	LSTDPB			; LIST IT?
	IDPB	B,TOPBYTE(USER)	; DEPOSIT
	AOJ	C,		; INCREMENT CHARACTER COUNT
	ILDB	B,PNEXTC	; GET NEXT CHAR.
	SKIPGE	A,SCNTBL(B)	; SPECIAL?
	PUSHJ	P,(A)		; DO IT
BALCHK:	CAIE	B,","		; END OF PARAMETER?
	CAIN	B,")"		; 
	JRST	ENDCHK		; POSSIBLY, GO CHECK
	TLNN 	A,NEST		; NESTED CHARACTER?
	JRST 	DEPOSA		; NO, GO DEPOSIT
	MOVE 	TEMP,[AOS LOCNST-1(LPSA)] ; SET UP INSTRUCTION TO UPDATE APPROP. NEST COUNT
	TLNN	A,LNEST		; LEFT NESTED?
	TLO	TEMP,AOSSOS	; NO, CHANGE INSTRUCTION TO SUBTRACT
	HRRZ	LPSA,NSTABL(B)	; LOAD CHAR'S NESTED COUNT INDEX
	XCT	TEMP		; MODIFY COUNT
	JRST 	DEPOSA		; GO DEPOSIT
ENDCHK:	MOVEI	TEMP,NUMNST-1	; SET UP COUNT
EDLOOP:	SKIPN	LOCNST(TEMP)	; NEST COUNTEQUAL ZERO?
	SOJGE	TEMP, EDLOOP	; YES, AND TRY NEXT IF NOT DONE
	JUMPGE	TEMP,DEPOSB	; GO DEPOSIT IF NOT ALL NEST COUNTS EQUAL ZERO
	JRST 	ENDSTR		; GO TO END



DSCR -- SCNACT
DES This procedure is used to scan a list of actual parmeters for a macro
  or a conditional compilation FORLC statement.  When the latter happens
  SCNACT is called from the EXEC routine GETACT which appears in GEN. 
  FORLC statements have a body which is scanned as many times as one has
  parameters in the actual list; in each case a different actual is used
  as the parameter.
PAR LPSA contains the semantics of the macro name or macro pseudonym in
  case a FORLC list is being scanned (address of semblk of name).
RES DEFRN2 contains the address of the first actual parameter in the list.
⊗

↑SCNACT: PUSH	P,LPSA		;SAVE SEMANTICS OF DEFINE SYMBOL
	PUSH	P,VARB		;WILL MAKE NEW ONE FOR MACRO ARGUMENTS
	PUSH	P,PPSAV	;SAVE THE STACKS
	PUSH	P,GPSAV
	SETZM	DEFRN2		;INITIALIZE FOR NEW MACRO
	SETZM	VARB
	HLRZ	TEMP,$VAL(LPSA)	;ANY PARAMETERS NEEDED?
	JUMPE	TEMP,NOPRMS	 	; NO
	MOVEM	TBITS2,SCNWRD	;NOTE CHANGES
SCNAGN:	PUSHJ	P,SCANNER	;LOOKING FOR "("
	MOVE	TEMP,(SP)	;SYNTAX OF SCANNED ELEMENT
	POP	P,GPSAV		;KEEP STACKS IN SYNCH
	POP	P,PPSAV
	ADD	P,X22
	SKIPE	REQDLM		; IN SPECIAL DELIMITER MODE?
	SKIPE 	SWBODY		; YES, COULD WE POSSIBLY HAVE SEEN A SPEC DEL DECL.
	JRST	TSLPRN		; YES, GET LEFT PAREN.
	CAME	TEMP,%STCON	; A SPECIAL DELIMITER DECLARATION?
	JRST 	TSLPRN		; NO, GET A LEFT PAREN.
	SETOM 	SWBODY		; SET SWITCH DECLARATION FLAG
	MOVE	TEMP,[XWD -2,2]	; SET UP A COUNT
	MOVE	PNT,$PNAME+1(LPSA) ; PNT HAS BYTE POINTER TO DELIM. STRING
	HRRZ	LPSA,$PNAME(LPSA) ; LPSA HAS DELIMITER STRING LENGTH
	PUSHJ	P,GETDL2	; GET SPECIAL DELIMITER DECLARATION
	JRST 	SCNAGN		; GO BACK AND GET LEFT PAREN.
TSLPRN:	CAME	TEMP,[TLPRN&17777777]	;PARAMS? 
	 ERR	 <MISSING "(" IN MACRO CALL> ; NO
	MOVEI	B,"("
	LSTDPB
	TLO	FF,PRMSCN 	; PRIME THE SCANNER FOR PARAMETER
	PUSHJ	P,FFPUSH	; SAVE OLD DEFLUK BIT OF FF AND TURN IT ON IN FF
PRMLUP:	SKIPN 	REQDLM		; IN SPECIAL DELIMITER MODE?
	JRST	PRMOLD		; NO	
	PUSHJ	P,SCNPMR	; YES, GET THE PARAMETERS
	TRNA
PRMOLD:	PUSHJ	P,SCANNER	;GET A PARAMETER
	POP	P,GPSAV		;SYNCH STACK
	POP	P,PPSAV
	ADD	P,X22

; WE KNOW RESULT IS STRING CONSTANT, SCANNER WILL RETURN NO OTHER

	SKIPN	TEMP,DEFRN2	;PUT → FIRST ARG IN DEFRN2
	 MOVE	 TEMP,NEWSYM
	MOVEM	TEMP,DEFRN2

	PUSHJ 	P,SCANNER	;GET NEXT PUNCTUATION
	MOVE	TEMP,(SP)
	POP	P,GPSAV
	POP	P,PPSAV
	ADD	P,X22		;SYNCH STACKS
	CAMN	TEMP,[TCOMA&17777777]	;LOOPING?	
	 JRST	 PRMLUP		;YES
	CAME	TEMP,[TRPRN&17777777]	;DONE?  
	 ERR	 <MISSING "," OR ")" IN MACRO CALL>
	TLZ	FF,PRMSCN 	; DONE WITH THESE
	PUSHJ	P,FFPOP		; RESTORE DEFLUK BIT OF FF
	SKIPE 	REQDLM		; IN SPECIAL DELIMITER MODE?
	SKIPN	SWBODY		; YES, HAVE TO REVERT TO OLD DELS?
	JRST	NOPRMS		; NO
	HRROI	TEMP,LOCMPR+1	; GET RESTORING ADDRESS
	POP	TEMP,CURPED	; RESTORE START DEL.
	POP	TEMP,CURPBG	; RESTORE END DEL.
	SETZM 	SWBODY		; RESET SWITCH DEL. FLAG
NOPRMS: POP	P,GPSAV		; GET SEMANTIC STACK BACK
	POP	P,PPSAV		; GET PARSE STACK BACK
	POP	P,VARB		; GET OLD VARB BACK
	POP	P,LPSA		; SEMANTICS FOR DEFINE
	MOVE	SP,PPSAV	; RESTORE SP IN CASE IT GOT FOULED UP IN
				;   SCANNER CALLS
	POPJ	P,		; RETURN



DSCR -- ACPMED
DES ACPMED prepares for a macro call once the actual parameters have been
  scanned.  It is also used to prepare for the first instantiation of the
  body of a conditional compilation WHILEC, CASEC, FORC, or FORLC statement.
PAR LPSA contains the semantics of the macro name or macro pseudonym in
  case a conditional compilation WHILEC, CASEC, FORC, or FORLC body is
  being scanned for the first time.  DEFRN2 contains the address of the
  actual parameter list in case of a FORLC statement, the address of the
  loop variable semblk in case of a FORC statement, and zero in the case
  of a WHILEC or CASEC statement.
RES At the end of this procedure one has effectively switched PNEXTC and
  PNEXTC-1 to scan the macro body or the conditional compilation body.
  Relevant information is saved on the DEFPDP stack.
⊗



↑ACPMED: MOVE	PNT,DEFPDP	;RESTORE NOW
	PUSH	PNT,DEFRNG	;SAVE OLD RING OF PARAMETERS
	PUSH	PNT,PNEXTC-1	;STRING NUMBER
	PUSH	PNT,PNEXTC	;INSTEAD SAVE THOSE WHICH
	PUSH	PNT,SAVCHR	; PARAMETERS
	MOVEM	PNT,DEFPDP
	MOVE	PNT,PLINE	;WILL SAVE IN IPLINE IF LEAVING INPUT LEVEL

	MOVEW	DEFRNG,DEFRN2	;PERMANENT LODGING FOR DEFINE RING
	PUSHJ	P,CONTXT	; SET UP THE SCAN POINTERS

; DECIDE WHETHER MACRO EXPANSION SHOULD BE LISTED.

	MOVEI	B,"⊂"		;MARK EXPANSION IF MACRO NAME
	TLNE	TBITS2,LSTEXP	; IS ALSO BEING LISTED
	IDPB	B,LPNT	; (NEVER ON IF ¬LISTNG)
	TLON	TBITS2,MACIN	;IN A MACRO NOW
	MOVEM	PNT,IPLINE	;CAN GET CURRENT LINE LOC FROM HERE
	SKIPE	SWCPRS		; NO LISTING WHEN IN COND. PARSER
	TRZ	TBITS2,NOLIST	;ASSUME LISTING
	TLNN	TBITS2,MACEXP	;IF MACRO EXPANSION SHOULD NOT BE LISTED,
	TRO	TBITS2,NOLIST	; INDICATE IT
	MOVEM	TBITS2,SCNWRD	;UPDATE IN CORE
	POPJ	P,		; RETURN



DSCR -- CONTXT
DES CONTXT is used to switch the input pointers before a macro call or
  prior to each invocation of the body of conditional compilation WHILEC,
  CASEC, FORC, or FORLC statement.  If conditional compilation is the case
  then this is virtually all that need be done for the reinvocation of the
  body and thus it is clearly cheaper than calling the macro in the old
  sense several times with different variables (this statement is only true
  for the WHILEC, FORC, and  FORLC statement since the body of a CASEC
  statement is only scanned once).
PAR LPSA contains the semantics of the macro name or macro pseudonym in the
  case of a conditional compilation WHILEC, CASEC, FORC, or FORLC statement.
RES PNEXTC, PNEXTC-1, PLINE, and PLINE-1 are set.
⊗



↑CONTXT: HLRZ	LPSA,%TLINK(LPSA)	;SEMANTICS FOR MACRO BODY
	PUSHJ	P,SGCOL1	  ;MAKE SURE THERE'S ENOUGH ROOM
	HLLZ	TEMP,$PNAME(LPSA) ;STRING NUMBER -- NULL STRING
	MOVEM	TEMP,PNEXTC-1
	MOVEM	TEMP,PLINE-1
	MOVEW	PNEXTC,$PNAME+1(LPSA) ;SET UP NEW INPUT POINTER
	MOVEM	TEMP,PLINE
	SETZM	SAVCHR		; NOTHING SCANNED AHEAD AT THIS LEVEL
	SETZM	LSTCHR		; NOTHING SCANNED AHEAD AT THIS LEVEL
	POPJ	P,		; RETURN
DSCR STRNG, etc.
DES Input a string constant. Check all identifiers to see if
  they are formal parameters to a DEFINE (macro). If so,
  replace them by their internal identifiers (delete <177>
  followed by unique code). Store string constant in string
  space, place entry in table, results to HPNT and NEWSYM. 
SEE Comments on following page for details of actual param thing.
⊗

STRNG:
	PUSHJ	P,INSET		;CLEAR AND RESET AS ABOVE
	TLZ	FF,PRMXXX	;IF " WAS FIRST CHAR, NOT IN SPECIAL MODE
STSCAN:
	ILDB	B,PNEXTC	;PRESERVE NEXT CHARACTER
BAKSTR:	SKIPGE	A,SCNTBL(B)	;DO SPECIAL THINGS
	PUSHJ	P,CSPEC		;IF REQUIRED
BAKST1:	TLNN	A,LETDG		;THINK HARD ONLY ON QUOTE, LETTDIG
	JRST 	MORSTR		; NOT LETTER OR DIGIT
	TLNE	FF,DEFLUK	; SCANNING A MACRO BODY?
	TLNE	FF,PRMSCN	; YES, SCANNING MACRO PARAMETERS
	JRST 	MORSTR		; YES, CHECK DELIMITERS
	SKIPN 	REQDLM		; SPECIAL DELIMITER MODE?
	JRST	DEFCHK 		; NO, THINK HARD
	CAMN 	B,CURMED	; MACRO BODY END DELIMITER?
	JRST	LTDEND		; YES, CHECK IF DONE
	CAMN	B,CURMBG	; MACRO BODY BEGIN DELIMITER?
	AOS	BNSTCN		; YES, INCREMENT NEST COUNT
	JRST	DEFCHK		; THINK HARD
LTDEND:	SOSL	BNSTCN		; DECREMENT NEST COUNT AND CHECK IF DONE
	JRST	DEFCHK		; THINK HARD
	JRST 	LTDCON		; TERMINATE MACRO BODY SCAN

MORSTR:	TLNN	FF,PRMXXX	;IN SPECIAL PARAMETER-SCANNING MODE?
	 JRST	 MORST1		; NO, CONTINUE

	CAIE	B,","		;END OF PARAMETER?
	CAIN	B,")"
	 JRST	 ENDSTR		; YES
	JRST	DEPOSIT		;LET SINGLE QUOTES THRU IN THIS MODE
MORST1:	SKIPN	DLMSTG		; A SPECIALLY DELIMITED STRING?
	JRST 	MORST2		; NO, GO CHECK FOR QUOTES
	CAMN	B,CURMED	; MACRO BODY END DELIMITER?
	JRST	MBDEND		; YES
	CAMN	B,CURMBG	; MACRO BEGIN DELIMITER?
	AOS	BNSTCN		; YES, INCREMENT NEST COUNT
	JRST 	DEPOSIT		; DEPOSIT
MBDEND:	SOSL	BNSTCN		; DECREMENT NEST COUNT AND CHECK IF DONE
	JRST 	DEPOSIT		; DEPOSIT
LTDCON:	LSTDPB			; PUT IT AWAY
	ILDB	B,PNEXTC 	; GET NEXT CHAR. TO KEEP IN SYNCH.
	SKIPGE	A,SCNTBL(B)	; SPECIAL?
	PUSHJ	P,(A)		;DO IT
	JRST	ENDSTR		; GO TO END
MORST2:	TLNN	A,QUOTE		;END OR DOUBLE-QUOTE ?
	 JRST	 DEPOSIT	; NO, PUT IT AWAY

	LSTDPB			;PUT IT AWAY
	ILDB	B,PNEXTC	;TRY NEXT
	SKIPGE	A,SCNTBL(B)	; DO THE USUAL IF SPCL
	PUSHJ	P,CSPEC
	TLNN	A,QUOTE		;IS IT ONE?
	JRST[SKIPE BAKDLM	; YES, CHECK IF NEED TO RESTORE DLMSTG
	SETOM	DLMSTG		; YES
	SETZM	BAKDLM		; TURN OFF BAKDLM
	 JRST	 ENDSTR]	; DONE

DEPOSIT:
	LSTDPB			;TO LISTING FILE IF REQD
DEPO1:	IDPB	B,TOPBYTE(USER)	;STORE CHARACTER AS IS
	AOJA	C,STSCAN	;LOOP ON RANDOM CHARACTERS

COMMENT ⊗ 
We come here if a letter or number has been seen.  If we are not
 scanning a macro body, we simply scan the rest of the characters
 which could be an identifier into the string constant, and return
 to the main string constant scanning loop.

If we are scanning a macro body, this may be a parameter name.
 The following algorithm is used:
   1. If not a letter, continue as if were not scanning macro body.
   2. Save a pointer to the start of this ident in the string const.
   3. Scan this (possible) param into the constant, no case conversion.
   4. Reset the TOPBYTE pointer, save status, then return PNEXTC to
      point to this ident again.  Call DSCAN (ident scanner) to con-
      vert and lookup this identifier (some special bits set to avoid
      stacking results, etc.)
   5. If not a DEFINE parameter, reset TOPBYTE and PNAME pointers to
      their state at the end of step 3, clear space used during DSCAN,
      and return to main string constant loop.
   6. Back TOPBYTE pointer up to beginning of ident again, insert '177
      (param marker), followed by param number into string, clear space
      used during steps 3 and 4, update PNAME count properly, and return
      to main loop.

During the course of this operation, several things get stored
 (as strings) on the SP stack, to prevent damage over possible
 garbage collects: the string constant so far, pointers to the
 beginning and one past the end of the possible parameter, and
 the input (PNEXTC) pointers (in case they represent a macro
 body, which of course must be collected properly.  There exists
 a problem.  If STRINGC happens, all these  pointers  must  be
 moved together, so that they still point inside the same string.
 STRINGC,  remember, when  working  for SAIL, adjusts each new 
 string to the start of a new word--catastrophic in this case.
 To solve this, we convince each pointer  saved  that it  is a
 (non-null)  string  which is a substring of a string which is
 guaranteed to contain all the others.  Since in some cases we
 save a pointer one past the last real char scanned, there are
 places in the code below where the string count of PNAME (and
 saved  representations)  is incremented to include this char.
 This is also the reason for the one character  long  invented
 strings ([XWD 40,1] constructs). In one mystical case, below,
 a  PNAME, PNAME+1 pair is saved solely for the reason that it
 is the only string containing all others -- it is thrown away
 after the last possible STRINGC,  and the  count  re-computed
 from other data.

Be warned that the current setup is the result of several killed
 bugs  --  each  thought to  be the  last.  No guarantees  are
 proferred that no more exist, but chances are better than ever.
⊗
DEFCHK:
	HRRM	C,PNAME		;MAKE COUNT HONEST BEFORE SAVING
	TLNE	A,NUMB		;MUST BE A LETTER
	 JRST	 DEPOSIT	; DIGIT OR OTHER NUMBER PART, GO ON

	EXCH	SP,STPSAV	;SAVE PNAME
	MOVSS	POVTAB+6	;SET PDLOV FOR STRING STACK
	AOS	PNAME		;INCREMENT TO INCLUDE 1ST IDENT CHAR(SEE ABOVE)
	ADDI	C,1		;TO CARRY XTRA CHAR THROUGH FURTHER STEPS
	PUSH	SP,PNAME	; BECAUSE DSCAN IS GOING TO CHANGE
	PUSH	SP,PNAME+1	; IT
	PUSH	SP,[XWD 40,1]   ;PROTECT 1ST CHAR PTR OVER GC (SEE ABOVE)
	PUSH	SP,TOPBYTE(USER);SAVE LOC OF BEGINNING OF IDENT
	EXCH	SP,STPSAV	;PUT BACK FOR NONCE
	MOVSS	POVTAB+6	;RE-ENABLE TRAP FOR PARSE STACKS

RANSCN:	ADDI	C,1		;COUNT FIRST CHAR
	LSTDPB			;LIST IF NECESSARY
RANSC1:	IDPB	B,TOPBYTE(USER)	;KNOW FIRST ONE IS OK
	ILDB	B,PNEXTC
	SKIPGE	A,SCNTBL(B)	;USUAL TEST
	 PUSHJ	 P,CSPEC
	TLNN	A,LETDG
	JRST	SEEPRM		; NOT A LETTER OR DIGIT
	SKIPN	REQDLM		; SPECIAL DELIMITER MODE?
	JRST 	CHKCON		; NO
	CAMN	B,CURMED	; MACRO BODY END DELIMITER?
	JRST	MBEDCK		; YES
	CAMN	B,CURMBG	; MACRO BODY BEGIN DELIMITER?
	AOS	BNSTCN		; YES, INCREMENT NEST COUNT
	JRST	CHKCON		; CONTINUE ID SCAN
MBEDCK:	SOSL 	BNSTCN		; DONE WITH MACRO BODY?
CHKCON:	 AOJA	 C,RANSC1-1(TBITS2) ; COUNT AND LOOP

; NOW CONVERT IDENT TO UPPER CASE, ALIGN, CALL SCANNER TO LOOK IT UP

SEEPRM:	HRRM	C,PNAME		;UPDATE CHAR COUNT IN STRING DSCRPTR
	SUBI	C,1		; MAINTAIN XTRA CHAR IN PNAME
	PUSH	P,A		;SAVE BITS AND
	PUSH	P,B		; CHAR AND
	PUSH	P,C		; COUNT
	EXCH	SP,STPSAV	;GET STRING STACK BACK
	MOVSS	POVTAB+6	;ENABLE FOR STRING STACK OV
	PUSH	SP,[XWD 40,1]	;PROTECT PTR OVER STRINGC(SEE ABOVE)
	PUSH	SP,TOPBYTE(USER) ;END OF ID
	PUSH	SP,PNEXTC-1	;CURRENT INPUT POSITION
	PUSH	SP,PNEXTC
	HRRZ	TBITS,-7(SP)	;ORIGINAL COUNT
	PUSH	SP,PNAME	;THIS IS ONLY STRING GUARANTEED
	PUSH	SP,PNAME+1	; TO CONTAIN ALL OTHERS
	EXCH	SP,STPSAV
	MOVSS	POVTAB+6	;ENABLE FOR PARSE STACK OV
	SUBM	C,TBITS		;LENGTH OF ID (`C' NOW CORRECT, SEE ABOVE)
	ADDI	TBITS,5		;WILL MOVE OUT TO AVOID A PROBLEM
COLNEC:	PUSHJ	P,SGCOL2	;COLLECT IF NECESSARY
	AOS	TOPBYTE(USER)	;IDPB-ILDB GETS INTO LOOP IN DSCAN IF NOT
	MOVE	TEMP,STPSAV	;NOW GET →BEGINNING OF ID (PERHAPS LOWER CASE)
	MOVE	TEMP,-6(TEMP)	;ILDB GETS ID'S FIRST CHAR
	ILDB	B,TEMP		;SET UP FOR SCANNER
	MOVEM	TEMP,PNEXTC	;SCAN FROM HERE FOR A WHILE
	MOVE	A,SCNTBL(B)	;GET THE BITS BACK
	TLO	TBITS2,LOKPRM
	TRON	TBITS2,NOLIST	;TURN OFF LISTING FOR RESCAN
	TLO	TBITS2,BACKON	;SAY YOU'VE DONE IT IF STATE CHANGED
	MOVEM	TBITS2,SCNWRD	;UPDATE
SCNPRM:	PUSHJ	P,DSCAN		;ID SCANNER -- SCAN AND LOOK IT UP
				;THIS MAY CALL STRINGC -- BUT ALL-ENCOMPASSING
				;PNAME ENTRY IS IN THE SP STACK, SO OK

	POP	P,C		;GET COUNT BACK (IT'S CORRECT)
	POP	P,B		;GET ID BREAK CHAR BACK
	POP	P,A		;GET ID BREAK CHAR BITS BACK
	EXCH	SP,STPSAV	;PUT THE SCANNER LOCATION BACK
	SUB	SP,X22		;REMOVE ENCOMPASSING PNAME ENTRY (SEE DESCR)
	POP	SP,PNEXTC
	POP	SP,PNEXTC-1
TSTPRM:	SKIPG	LPSA,NEWSYM	;THESE TESTS DETERMINE IF 
	 JRST	 NOPAR		; (1) THERE IS A SYMBOL OF THIS NAME
	SKIPGE	TBITS,$TBITS(LPSA)
	 JRST	 NOPAR		; (2) IT IS NOT A RESERVED WORD
	TLNE	TBITS,FORMAL
	TLNN	TBITS,DEFINE
	 JRST	 NOPAR		; (3) IT IS A MACRO PARAMETER NAME

	MOVE	TEMP,-2(SP)	;IN OTHER WORDS, WE FOUND A PARAM
	MOVEI	C,0		; BP OF START OF ID IN TEMP
LINLUP:	TLNN	TEMP,760000	;ZERO REST OF FIRST WORD TO BE AFFECTED
	 JRST	 OKL
	IDPB	C,TEMP
	JRST	LINLUP
OKL:	HRLI	TEMP,1(TEMP)	;ZERO REST OF ORIGINAL SCAN, ALL OF DSCAN
	HRRI	TEMP,2(TEMP)	; SCAN
	SETZM	-1(TEMP)	
	BLT	TEMP,@TOPBYTE(USER)
	SUB	SP,X44		;REMOVE →FIRST, →LAST OF ORIG ID SCAN
	MOVE	C,2(SP)		;→FIRST, WILL BECOME TOPBYTE
	MOVEI	TEMP,177	;MARK PARAM OCCURRENCE
	IDPB	TEMP,C
SETPRM:	HRRZ	TEMP,$VAL(LPSA) ;PARAM NUMBER
	IDPB	TEMP,C
	MOVEM	C,TOPBYTE(USER) ;WHAT DID I TELL YOU?
	HRRZ	C,-1(SP)	;ORIGINAL LENGTH (+1)
	AOJA	C,DN		; +2 FOR MARKER, -1 TO REMOVE XTRA CHR


NOPAR:	AOS	TEMP,PNAME+1	;CLEAR FROM END OF ORIGINAL SCAN
	HRLI	TEMP,-1(TEMP)	;TO END OF DSCAN SCAN
	SETZM	-1(TEMP)
	BLT	TEMP,@TOPBYTE(USER)
	POP	SP,TOPBYTE(USER);SAVE ORIGINAL SCAN
	SUB	SP,X33		;FORGET OTHER POINTER
; C IS THE VALUE PRIOR TO THE DSCAN IF NOPAR
DN:	TLZE	TBITS2,BACKON	;TURN LISTING BACK ON?
	TRZ	TBITS2,NOLIST	;YES
	POP	SP,PNAME+1	;NOW RESTORE THESE
	POP	SP,PNAME
	EXCH	SP,STPSAV	;ONE MORE TIME
	HRRM	C,PNAME		;MAKE SURE COUNT IS REALLY HONEST
;A AND B ARE THE APPROPRIATE VALUES FOR THE ORIGINAL BREAK CHAR
	TLZ	TBITS2,LOKPRM	;LOOK NO MORE
	JRST	MORSTR		;CONTINUE THE SCAN



Comment ⊗
End of string constant -- set up results for stacking,
	go do it   ⊗

ENDSTR:
	MOVEM	TBITS2,SCNWRD	;PUT ALL THE BITS AWAY
	LSTDPB			;PUT "," OR ")" AWAY
	TLZ	FF,PRMXXX
	CAIE	B,12		;LF IS SPECIAL PROBLEM!
	MOVEM	B,SAVCHR	;SAVE BITS FOR NEXT TIME
	MOVEM	B,LSTCHR	;ALSO HERE ANY TIME
	TLNN	FF,PRMSCN	; SCANNING ACTUAL PARAMETERS?
	 JRST	 NOMACW		; NO, MACRO BODY ENDING SUPPLIED BY ENDMAC
	ADDI	C,2
	MOVEI	TEMP,177	;177-0 AT END
	IDPB	TEMP,TOPBYTE(USER)
	MOVEI	TEMP,0
	IDPB	TEMP,TOPBYTE(USER)
NOMACW:
	PUSHJ	P,UPDCNT	;UPDATE PNAME CNT, REMCHR, COLLECT IF NECC.
MKSTRG:	MOVE	LPSA,STRCON	;LOOK IT
	PUSHJ	P,SHASH		; UP
	MOVEW	HSPNT,HPNT	;SAVE FOR REMOVAL IF PRE-STATEMENT COMMENT
	TLNN	FF,DEFLUK	;FORCE AN ENTERS IF SCANNING FORMAL DEFINE
	SKIPE	DLMSTG		; FORCE ENTERS FOR ALL SPECIALLY DELIMITED
				;   STRINGS SO THAT THEY CAN BE DELETED IF
				;   NOT NEEDED (I.E. FALSE CASEC)
	 JRST	 ENTSTG		; PARAMETERS OR MACRO BODY 
	SKIPE	LPSA,NEWSYM	;ALSO ENTER IF IT WASN'T THERE BEFORE
	 JRST	 STKSTG
ENTSTG:	PUSH	P,BITS		;SAVE THESE
	MOVE	B,[XWD CNST,STRING] ;STRING CONSTANT
	MOVEM	B,BITS
	PUSHJ	P,ENTERS		;ENTERS IT
	POP	P,BITS		;NO EFFECT ON OUTSIDE WORLD
STKSTG:	MOVE	LPSA,NEWSYM	;FOR STACKER
	MOVE	A,%STCON	;ALSO FOR STACKER
	JRST	STACK		;GO STACK RESULTS
DSCR SCNUMB -- number scanner
DES Scan a number -- keep both REAL (floaging) and fixed
  representations around, use the appropriate one at the end.
 A number is composed of integers and various special characters.
 See the syntax for a better definition, but here is a summary:

		<int><.<int>><@<+|->int>

 Common sense should indicate that some of these things must
  be present to constitute a legal number. The results
  are returned as described on the opening page of SCAN.
⊗

SCNUMB:

; @ CHARACTER TO BE TREATED AS DELIMITER IF INSIDE START_CODE
;  BLOCK

	TLNE	A,ATSIGN	;SHOULD WE WORRY?
	TLNN	TBITS2,INLIN	;IS IT SPECIAL?
	 JRST	 SCNM1		; NO

	MOVE	A,%ATS		;GET BITS FOR AT SIGN DELIMITER
	JRST	CHAROUT		;HANDLE AS DELIMITER

SCNM1:
	SETZM	SCNVAL		;NUMERIC VALUE
	SETZM	DBLVAL		;FUTURE USE BY DBLPRC, COMPLEX
	SETZB	SBITS2,FLTVAL	;SBITS2 HOLDS FLAGS, FLTVAL COLLECTS REAL
				;  REPRESENTATION
				;C HOLDS COUNT OF DECIMAL PLACES

	TLNN	A,QUOCTE	;OCTAL QUOTE MARK (') ?
	 JRST	 DECIM		;NO, DECIMAL NUMBER

OCTL:	ILDB	B,PNEXTC	;GET BACK IN SYNCH
	SKIPGE	A,SCNTBL(B)
	PUSHJ	P,(A)		;USUAL SPECIAL TREATMENT
	LSTDPB
	SKIPA	D,[LSH TEMP,3]	;OCTAL NUMBER GATHERER
DECIM:	MOVE	D,[IMULI TEMP,=10]	;DECIMAL NUMBER GATHERER

	PUSHJ	P,GETINT	;CLEAR COUNT, GET AN INTEGER
	TLNN	A,LETDG 	;IF NOT PART OF A NUMBER,
	 JRST	 ENDNUM		; DONE
	TLNN	A,DOT		;"."?
	 JRST	 NODOT		; NO DECIMAL PART, CHECK EXP PART
	TRO	SBITS2,FLOTNG	;MARK REAL NUMBER
	PUSHJ	P,LGETINT	;TRY FOR SOME MORE INTEGER
	TLNN	A,LETDG 	;IF NOT NUMBER, NONE, JUST WANTED TO IND
	 JRST	 ENDNUM		; ICATE REAL (OR DONE)

NODOT:	TLNN	A,ATSIGN	;IF NOT ".", MUST BE "@"
	 ERR	 <ILLEGAL REAL CONSTANT>,1
	TRON	SBITS2,FLOTNG	;NO DEC PLACES UNLESS
	 MOVEI	 C,0		; ALREADY REAL
	PUSH	P,FLTVAL	;SAVE FLOATING REPRESENTATION
	PUSH	P,C		;AND DECIMAL COUNT
	SETZM	SCNVAL		;CLEAR VALUES AGAIN
	SETZM	FLTVAL
	ILDB	B,PNEXTC	;CHECK SIGNED EXPONENT
	SKIPGE	A,SCNTBL(B)	;USUAL
	PUSHJ	P,(A)
	LSTDPB			;PUT IT TO LISTING FILE
	PUSH	P,[FIXAT]
	CAIN	B,"-"		;MINUS?
	 TLOA	 SBITS2,EXPNEG	; YES, EXPONENT NEGATIVE
	CAIN	B,"+"		;NO, PLUS?
	 JRST	 LGETINT	; PLUS OR MINUS, GET DIGIT
	 JRST	 GETINT		; HAVE DIGIT, GO GET NUMBER
FIXAT:	TLNE	SBITS2,EXPNEG	;NEGATIVE EXPONENT?
	 MOVNS	 SCNVAL		; YES
	POP	P,C		;GET DECIMALS BACK
	POP	P,FLTVAL	;AND OLD FLOATING VALUE
	ADD	C,SCNVAL	;TOTAL EXPONENT

ENDNUM:	CAIE	B,12		;EXCEPT FOR LINE FEED,
	MOVEM	B,SAVCHR	;SAVE FOR NEXT SCAN
	MOVEM	B,LSTCHR	;ALSO HERE ANY TIME
	TLNE	A,LETDG 	;MUST NOT BE LEETTER OR DIG OR
	 ERR	 <ILLEGAL CONSTANT>,1
	TRNN	SBITS2,FLOTNG	;REAL OR INTEGER?
	 JRST	 INTEG
	TLNE	SBITS2,REALOV	;FLOATING POINT OVERFLOW?
	 ERR	 <REAL CONSTANT TOO LARGE>,1
	MOVE	A,[FDVR TEMP,[10.0]] ;ADJUST NUMBER
	SKIPL	C
	 MOVE	 A,[FMPR TEMP,[10.0]] ; BY MULTIPLYING OR
	MOVMS	C		;DIVIDING UNTIL C GOES NEGATIVE
	MOVE	TEMP,FLTVAL	;UNADJUSTED NUMBER
	JFCL	17,MLP		;CLEAR FLAGS
	JRST	MLP
MULUP:	
	XCT	A		;ADJUST
	JFOV	[ERR <REAL CONSTANT TOO LARGE OR TOO SMALL>,1
		 JRST	MLP]
MLP:	SOJGE	C,MULUP		;KEEP GOING MAYBE

DUN:	MOVEM	TEMP,SCNVAL	;THIS IS THE (REAL) ANSWER
	JRST	NUMRET		;GO STACK
	
INTEG:	SKIPN	C		;MAKE SURE THERE WAS SOMETHING
	 ERR	 <ILLEGAL INTEGER CONSTANT>,1
	TLNE	SBITS2,INTOV	;INTEGER OVERFLOW?
	 ERR	 <INTEGER CONSTANT TOO LARGE>,1
	TRO	SBITS2,INTEGR	;MARK TYPE
NUMRET:	HRLI	SBITS2,CNST		;MAKE INTO TBITS WORD
	PUSH	P,BITS		;DON'T EFFECT OUTSIDE WORLD
	MOVEM	SBITS2,BITS		;SET UP FOR ENTER
	PUSHJ	P,NHASH		;LOOK UP THE NUMBER
	SKIPE	DLMSTG		; SPECIAL DELIMITER MODE?
	JRST	ENTNUM		; ENTER ALL NUMBERS APPEARING IN SPECIALLY
				;   DELIMITED STRINGS SO THAT THEY CAN BE
				;  DELETED WHEN DONE SANNING THE STRING
	TLNN	FF,DEFLUK	; COMPILE TIME ASSIGNMENT? (I.E. MACRO BODY)
	SKIPG	NEWSYM		;WAS IT THERE ALREADY?
ENTNUM:	 PUSHJ	 P,ENTERS	; NO, BUT IT IS NOW
	POP	P,BITS		;GET OLD BITS BACK
	MOVE	LPSA,NEWSYM	;SET UP FOR STACKING
	MOVE	A,%NUMCON
	JRST	STACK		;GO DO IT
Comment ⊗
Get an integer (base 10 only for the present).
⊗
LGETINT:		;GET A CHARACTER FIRST
	ILDB	B,PNEXTC
MGETINT:		;GET BITS FIRST
	SKIPGE	A,SCNTBL(B)
	PUSHJ	P,(A)	;SIGH!
	LSTDPB

GETINT:			;GET AN INTEGER
	TDZA	C,C		;SET # DECIMAL PLACES TO 0

	IDPB	B,LPNT		;PUT AWAY
GETLUP:	TLNN	A,DIG		;IS IT A DIG?
	 POPJ	  P,		; NO, RETURN
	MOVEI	TEMP,-"0"(A)	;MAKE AN INTEGER
	EXCH	TEMP,SCNVAL	;PREVIOUS VALUE SO FAR
	JFCL	17,.+1		;CLEAR APR FLAGS
	XCT	D		;COLLECT NUMBER
	ADDM	TEMP,SCNVAL	;NEW NUMBER
	JOV	[TLO	SBITS2,INTOV
		 JRST	.+1]	;CHECK AND RECORD OVERFLOW
	MOVEI	TEMP,-"0"(A)	;MAKE A FLOATING ONE
	FSC	TEMP,233	;FLOAT THIS DIG
	EXCH	TEMP,FLTVAL
	FMPR	TEMP,[10.0]
	FADRM	TEMP,FLTVAL	;NEW NUMBER
	JFOV	[TLO	SBITS2,REALOV
		 JRST	.+1]	;CHECK REAL OVERFLOW
	SUBI	C,1		;COUNT DECIMAL PLACES
	ILDB	B,PNEXTC	; GET ANOTHER
	SKIPGE	A,SCNTBL(B)	;COULD IT STILL BE A DIGIT?
	PUSHJ	P,(A)
	JRST	GETLUP-1(TBITS2);LOOP
Comment ⊗ Print the last character, then stack the result
⊗

LSTACK:	LSTDPB
	JRST	STACK

Comment ⊗ We have been backed up by the wonderful error routines
in the parser.  So now we return things to their normal states:
⊗

GOAGAIN: MOVE	LPSA,SAVSEM
	SKIPA	A,SAVPAR

DSCR CHAROUT -- returns value for single char operator.
DES No Semantic stack entry is necessary (a null pointer
  is stacked). The indirect, address, and index fields
  of the character comprise its PL-ID. 
⊗

CHAROUT:
	MOVEI	LPSA,0		;SEMANTICS RETURNED ARE NULL

DSCR STACK  
DES All SCANNER sub-sections return here to place Parse
  token on parse stack (PPDL) and Semantics on EXEC stack
  (GPDL). STACK is bypassed only by the string constant
  scanner when calling SCANNER recursively to modify for-
  mal parameters.
⊗
STACK:	HRRZS	LPSA		;MAKE SURE ONLY RH
	TLZ	A,777740	;CLEAR SCANNER BITS
	PUSH	SP,A		;PL ENTRY
	EXCH	SP,GPSAV	;GET GP POINTER
	PUSH	SP,LPSA		;SEMANTIC ENTRY
	EXCH	SP,GPSAV	;PUT AWAY SEMANTIC POINTER
	MOVEM	SP,PPSAV	;PUT AWAY PARSE POINTER
	POPJ	P,

DSCR INSET
DES prepare for ID or STRING constant scan
RES sets up TOPBYTE, REMCHR, PNAME, TOPSTR, C (char count)
SID Uses TEMP
⊗
INSET:	MOVEI	C,0		;CLEAR CHARACTER COUNT
;;#GI# DCS 2-5-72 REMOVE TOPSTR
	MOVSI	TEMP,40		; MOST HARMLESS ¬CONST BIT
;;#GI
	MOVEM	TEMP,PNAME	;FIRST PNAME DESCRIPTOR WORD
	HLL	TEMP,TOPBYTE(USER)	;ADJUST REMCHR FOR
	HRRI	TEMP,[BYTE (7) 0,4,3,2,1,0] ;CHARACTERS SKIPPED
	ILDB	TEMP,TEMP
	ADDM	TEMP,REMCHR(USER)	;UPDATE REMCHR

	SKIPL	TEMP,TOPBYTE(USER)	;ADJUST TOPBYTE TO
	ADDI	TEMP,1		; WORD BDRY (440700 OK ALREADY)
	HRLI	TEMP,440700	;[POINT 7,WORD]
	MOVEM	TEMP,PNAME+1	;BP FOR THIS STRING
	MOVEM	TEMP,TOPBYTE(USER)	;ADJUSTED TOPBYTE
		;NOW GC CAN GO AHEAD AND HAPPEN
	POPJ	P,		;ALL SET
SUBTTL	SCANNER I/O, MACRO EXPANSION
DSCR CSPEC, SEOL, SEOM, SEOB -- Special handling routines
PAR A contains address of appropriate routine.  Many SCANNER
  state variables are perused and changed.
RES PNEXTC, SAVCHR, and friends are set to proper values after
  more file has been read, macro has been returned from, etc.
DES Called by SCANNER routines when an input char is detected
  whose SCNTBL entry indicates special conditions.  The routine
  address is in the right half of this SCNTBL word.
 CSPEC is sometimes called to save the char count (C) before dis-
  patching to the special routine (for STRINGC integrity)
 SEOL is called when the SCANNER is reading from the input file
   or a macro and an end of of line condition is detected.  A
   new line is found and the PNEXTC pointer is reinitialized.
 EOM is called when the SCANNER is reading a DEFINE body, and end
   of text (177 char) is seen. If the character following the EOT
   is non-zero, it indicates the right actual parameter to expand
   here.  If it is 0, it signals end of macro. Old input values are
   restored, things like PNEXTC and SAVCHR.
 SEOB is called when a 0 is detected while scanning. This can mean
  two things -- a TECO-type file is being read, and a buffer has
  ended in the middle of a line, or the string scanner has called
  SCANNER recursively to pick up a possible formal param.  In either
  case the right thing happens.
SEE ADVBUF routine, which these call for for file input
⊗
ZERODATA (SCANNER INPUT/OUTPUT VARIABLES)
;LINNUM -- physical line number of this output line.  Used
;    to force page ejects and new sub-numbering when too
;    many have gone out since last logical page encountered
↓LINNUM: 0

↓LNCREF: 0	;IF ON, CREF INFO HAS GONE OUT FOR THIS LINE

COMMENT ⊗
LPNT -- byte pointer used to deposit characters in output
    buffer (LSTBUF) -- SEOL code transfers this data, along
    with CREF data, to the output file buffers.  IDPB B,LPNT
    instructions are scattered throughout the SCANNER to build
    this output file
⊗
↑↑LPNT: 0

↑↑LSTBUF: 0	;ADDRESS OF LISTING BUFFER

;LSTCHR -- saved scan-ahead character -- sometimes slightly different
;   from SAVCHR -- used for error message (the arrow) output
↑↑LSTCHR: 0
ENDDATA
SUBTTL	Cspec, Seol

; CALL SPECIAL ROUTINE, BUT FIRST MAKE SURE CHARACTER COUNT IS
;  CORRECT IN "PNAME" (THE DESCRIPTOR FOR THE CURRENTLY DEVELOPING
;  IDENTIFIER OR STRING)

CSPEC:	HRRM	C,PNAME		;UPDATE CHAR COUNT
	JRST	(A)		;DISPATCH TO SPECIFIED ROUTINE

SEOL:	
	PUSH	P,C		;SAVE CHARACTER COUNT (CLOBBERED BY HDROV)
	TRNE	TBITS2,NOLIST	;ARE WE LISTING NOW?
	 JRST	 NOLST		; NO

; TIME TO DO A LISTING

	MOVE	TBITS,LPNT	;PUT THE LINE FEED IN LIST BUFFER
LLL2:	IDPB	B,TBITS
	MOVEI	B,0		;ZERO REMAINING CHARS OF CURRENT WORD
	TLNE	TBITS,760000	;ALL DONE?
	JRST	LLL2		;NO, PUT OUT ZERO
	MOVEM	TBITS,LPNT	;SAVE AGAIN FOR A WHILE

NOGAG <
;IF CREFING WAS DONE ON THIS LINE, TERMINATE THE CREF STUFF
	SKIPN	LNCREF		;CREF GONE OUT?
	 JRST	 NOLNX		;NOPE
	SETZM	LNCREF		;RESET.
	MOVEI	TBITS,177	;DELETE
	PUSHJ	P,CHROUT
	MOVEI	TBITS,"A"	;AND AN A
	PUSHJ	P,CHROUT
NOLNX:
>;NOGAG

; IF PCNT OUTPUT DESIRED, DO THAT FIRST

	TLNN	TBITS2,PCOUT	;WANT TO PRINT PC?
	 JRST	 NOPC		; NO

	MOVE	TBITS,PCNT	;YET ANOTHER FRNP
	ADD	TBITS,LSTSTRT	;OFFSET BY USER-PROVIDED LOC
	MOVEI	B,CHROUT	;ROUTINE TO USE
	MOVEI	PNT2,6		;ALWAYS DO 6 CHARS
	PUSHJ	P,[
↑FRNP1:	SKIPA	TEMP,[10]
↑FRNPD:	MOVEI	TEMP,=10
FRNP3:	IDIV	TBITS,TEMP
	IORI	SBITS,"0"
	HRLM	SBITS,(P)
	SOJE	PNT2,FRNP2
	PUSHJ	P,FRNP3
FRNP2:	HLRZ	TBITS,(P)
	JRST	(B)		;CHARACTER TO OUTPUT
]
	MOVE	SBITS,[POINT 7,[ASCII /   /]]
	PUSHJ	P,LL1+1		;SEE BELOW

; IF LINE NUMBER OUTPUT DESIRED, DO IT NEXT.

NOPC:	MOVE	SBITS,[POINT 7,ASCLIN] ;ASSUME WANT LINE NUMBER
	TLNE	TBITS2,LINESO	;IS IT THE CASE
	PUSHJ	P,[LL1: PUSHJ P,CHROUT ;CHARACTER TO OUTPUT
		      ILDB  TBITS,SBITS ;NEXT CHAR
		      JUMPN TBITS,LL1
		      POPJ   P,]+1	;KLUDGE........

; NEXT LINE UP THE BP FOR SOME RAPID-FIRE STUFF

NLNO:	MOVE	TBITS,LSTPNT	;LST OUTPUT  BYTE POINTER
	MOVE	SBITS,LSTCNT	;IF ALREADY LINED UP....
HARRY:	TLNN	TBITS,760000	;LINED UP WHEN PTR PART IS 01
	JRST	LNDUP
	SOS	SBITS,LSTCNT	;DENOTE CHANGE
	IBP	TBITS		;MAINLY WANT TO ADJUST COUNT
	JRST	HARRY		;COULD PROBABLY DO CALCULATION

LNDUP:	MOVEM	TBITS,LSTPNT	;UPDATE
	IDIVI	SBITS,5		;#WORDS LEFT, NO REMAINDER GUARANTEED
	AOS	PNT2,LPNT	;WE GOT THIS FAR
	HRRZS	PNT2
	SUB	PNT2,LSTBUF	;HOW MANY WORDS?
	CAMGE	SBITS,PNT2	;IS THERE ROOM?
	 PUSHJ	 P,LSTDO	; NOW THERE IS
	MOVNI	SBITS,5		;UPDATE CHAR COUNT
	IMUL	SBITS,PNT2
	ADDM	SBITS,LSTCNT
	EXCH	PNT2,LSTPNT	;AND LSTPNT
	ADDM	PNT2,LSTPNT	;PREV VERSION IN PNT2
	ADDI	PNT2,1
	HRL	PNT2,LSTBUF	;BLT WORD (LSTBUF,,OUTBUF)
	BLT	PNT2,@LSTPNT	;WRITE THE LINE!
	HRRO	TEMP,LSTBUF	;ADDR OF FIRST WORD OF BUFFER
	SUB	TEMP,[XWD 677077,1] ;POINT 5,@LSTBUF,29
	MOVEM	TEMP,LPNT	;NEW LIST POINTER
	MOVE	TEMP,[ASCID /     /] ;BLANKS IN CASE
	MOVEM	TEMP,ASCLIN	;IN MACRO AND MORE LINES TO COME
	AOS	TBITS,LINNUM	;CHECK LINE OVERFLOW
	IDIVI	TBITS,PGSIZ
	SKIPN	SBITS
	PUSHJ	P,HDROV		;PRINT FF

; ENOUGH OUTPUT, NOW FOR SOME INPUT

NOLST:
	SKIPE	SRCDLY			;SWITCHING SOURCE INPUT?
	 JRST	 NXTSRC			; YES

	MOVE	PNT,PNEXTC
	IBP	PNT
	MOVEM	PNT,PLINE	;UPDATE IF MACRO
	TLNE	TBITS2,MACIN	;DONE IF MACRO
	 JRST	 LDO1		;DONE

; MAKE A LINE NUMBER IN CASE FILE HAS NONE
	AOS	TBITS,BINLIN	;SEQUENTIAL WITHIN PAGE
	MOVEI	B,[IDPB TBITS,A ;ROUTINE TO DISPENSE CHARS
		   POPJ P,]
	MOVEI	PNT2,5		;5 CHARS ALWAYS
	MOVE	A,[POINT 7,ASCLIN] ;PUT IT HERE
	PUSHJ	P,FRNPD		;GET ASCII VERSION
	MOVEI	TEMP,1
	ORM	TEMP,ASCLIN	;MAKE ASCID
; ACTUAL LINE NUMBER WILL OVERRIDE THIS IF THERE

	LDB TEMP,PNT		;NEXT CHAR.
	JUMPE TEMP,NULCHR	;GO FIND NON-NULL
LINCHA:	MOVE TEMP,(PNT)
LINCHK:	TRNN TEMP,1		;ARE WE IN LINE NUMBER?
	JRST LDUNA		;NO THIS IS THE NEXT CHAR.
	CAME TEMP,[ASCID/     /];IS IT A PAGE MARK PERHAPS
	AOJA PNT,LDUN		;NO JUST SKIP LINE NUM AND TAB
	MOVEM PNT,PNEXTC	;HDR CLOBBERS THIS
	PUSHJ P,HDR		;WRITE PAGE MARK, NEW TITLE LINE
	MOVE PNT,PNEXTC		;GET HIM BACK
	SKIPN 1(PNT)		;END OF BUFFER?
	PUSHJ P,ADVBUF		;YES, GET NEXT.
	ADDI PNT,1		;POINT BEHIND NEXT LINE NUMBER
	SKIPN TEMP,1(PNT)	;IS IT IN THIS BUFFER?
	PUSHJ P,ADVBUF		;NO.
	HRLI PNT,350700		;POINT TO FIRST CHAR. OF LINE NUMBER
	AOJA PNT,LINCHA		;AND DO IT AGAIN (IN CASE 2 PAGE MARKS).

NULCHR:	ILDB B,PNT		;MOVE ON UP
	MOVE	TEMP,(PNT)	;GET COMPLETE WORD
	JUMPN B,LINCHK		;FINALLY WE GOT SOMETHING
	IBP	PNEXTC		;KEEP IN STEP
	JUMPN	TEMP,NULCHR	;END OF BUFFER?
	PUSHJ P,ADVBUF		;YES.
	JRST NULCHR		;HERE WE GO LOOP-D-LOOP

LDUN:	SKIPE (PNT)		;IS TAB IN THIS BUFFER
	JRST LDUN1		;YES
	PUSHJ P,ADVBUF		;NO
	IBP PNT			;MAKE IT CURRENT
LDUN1:	MOVEM TEMP,ASCLIN	;CURRENT LINE#
	MOVEM PNT,PNEXTC	;THIS GUY POINTS TO TAB
LDUNA:	MOVE TEMP,PNEXTC	;MAY NOT USE PNT
	MOVEM TEMP,PLINE	;BEGINNING OF LINE
IFN FTDEBUG,<
	AOS	LINCNT		;COUNT NUMBER OF LINES SEEN
	SKIPL STPAGE		;ARE WE LOOKING FOR A PAGE/LINE?
	PUSHJ P,STPLIN		;LINE BREAK IF NECESSARY.
>
LDO1:	MOVEI B,12		;GET LINE FEED BACK.
	MOVEI A,0		;HARMLESS LF
	MOVE USER,GOGTAB
	POP	P,C		;RESTORE CHARACTER COUNT.
	POPJ P,			;WASN'T THAT WONDERFUL


; HERE WE SAVE INFO ABOUT SOURCE FILE, AND PREPARE TO GET INFO
; ABOUT NEW ONE.

NXTSRC:	MOVE	A,AVLSRC		;BITS TELLING FREE CHANNELS
	JFFO	A,GOTNEW		;FOUND A FREE ONE
	 ERR	 <NO MORE AVAILABLE SOURCE CHANNELS>
GOTNEW:
	PUSH	P,B			;SAVE NEW CHANNEL #
	MOVEI	C,ENDSRC-SRCCDB+1	;SIZE OF SAVE AREA
	PUSHJ	P,CORGET		;GET ONE
	 ERR	 <NO CORE AVAILABLE FOR FILE SWITCH>
	HRR	TEMP,B			;BLT WORD
	HRLI	TEMP,SRCCDB
	BLT	TEMP,ENDSRC-SRCCDB(B)
	HRRZM	B,SWTLNK		;SAVE PTR TO SAVE AREA
	TLO	TBITS2,INSWT		;WE'RE SCANNING SWITCHED-TO FILE
	MOVEM	TBITS2,SCNWRD
FOR II ⊂ (LSTCHR,SAVCHR,SAVTYI,EOF,EOL) <
	SETZM	II
>
	POP	P,A			;CHANNEL NUMBER
FOR II←0,1 <
	DPB	A,[POINT 4,SRCOP+II,12]
>
FOR II←0,3 <
	DPB	A,[POINT 4,INSRC+II,12]
>
NOEXPO <
	DPB	A,[POINT 4,SRCOP+2,12]	;PUSHJ IF EXPO
>;NOEXPO
	MOVN	TEMP,A			;-CHANNEL NUMBER
	MOVSI	LPSA,400000		;BIT
	LSH	LPSA,(TEMP)
	ANDCAM	LPSA,AVLSRC		;THIS CHANNEL UNAVAILABLE
	AOS	TEMP,LININD		;HOW FAR IN TO SPACE ON TTY
	CAILE	TEMP,MAXIND		;TOO FAR?
	SOS	LININD			;NOT REALLY
	SETOM	TYICORE			;WILL SCAN FROM STRING
	MOVE	TEMP,GENLEF+2
	HRROI	TEMP,$PNAME+1(TEMP)	;GET STRING TO BE SCANNED
	POP	TEMP,PNAME+1
	POP	TEMP,PNAME		;PUT ER THERE
	PUSHJ	P,ENDSWT		;USE EOF CODE TO GET NEW FILE
					;SRCDLY WILL BE TURNED OFF HERE
	JRST	NOLST			;AND GO BACK TO END OF LINE CODE
; END OF BUFFER CODE.

SEOB:	TLNE	TBITS2,LOKPRM	;END OF POSSIBLE MACRO PARAM SCAN?
	POPJ	P,		;YES, IGNORE THE WHOLE THING
	MOVE	PNT,PNEXTC	;CURRENT BP
	JUMPE	PNT,ADVIT	;INITIALIZATION TIME
	SKIPE	TEMP,(PNT)	;REAL END OF BUFFER?
	 JRST	 SEOBAK		; NO, WILL COME BACK UNTIL NOT NULL
ADVIT:	PUSHJ	P,ADVBUF
	TRNN	TEMP,1		;LINE NUMBER? (INIT SCAN FOR SOS FILES)
	 JRST	 SEOBAK		;NO, FIND NEXT CHAR
	MOVEM	TEMP,ASCLIN	;SAVE LINE NUMBER
	IBP	PNT		;OVER TAB
	ADDI	PNT,1		;BACK IN BUSINESS
SEOBAK:	MOVEM	PNT,PLINE	;BEGINNING OF LINE
	ILDB	B,PNT		;GET CHAR
	MOVEM	PNT,PNEXTC	;UPDATE
	SKIPGE	A,SCNTBL(B)	;SPECIAL?
	JRST	(A)		;YES, HANDLE
	POPJ	P,		;NO, DONE

; END OF PAGE (TECO FILES ONLY)

SEOP:	PUSHJ	P,HDR		;PRINT FF, TITLE LINE
	MOVEI	B,15		;PRETEND A CR
	MOVEI	A,0		;BITS FOR CR
	POPJ	P,
Comment ⊗ Parameter delimiter or end of message ⊗

EOM:	ILDB	B,PNEXTC	;CHECK WHICH
	JUMPE	B,RESTOR	;ZERO, END OF MACRO (OR PARAM) TEXT
	
; PARAMETER NEEDED

	SETZM	SAVCHR
	SETZM	LSTCHR
	MOVE	LPSA,DEFRNG
GETIT:	SOJE	B,GOTIT		;LOOK FOR THE PARAMETER OF PROPER NUMBER
	RIGHT	,%RVARB,<[ERR <NOT ENOUGH ARGUMENTS SUPPLIED TO MACRO>]>
	JRST	GETIT		;KEEP LOOKING

GOTIT:
DFNEST:	MOVE	PNT,DEFPDP	;NOW SAVE STATE OF SCANNER AND RECUR
	PUSH	PNT,[-1]		;INDICATE NO DEFRNG CHANGE
	PUSH	PNT,PNEXTC-1
	PUSH	PNT,PNEXTC	;INPUT POINTER
	PUSH	PNT,SAVCHR	;SCANNED AHEAD
	MOVEM	PNT,DEFPDP	;SAVE POINTER
	PUSHJ	P,SGCOL1		;MAKE SURE ENOUGH ROOM
	HLLZ	TEMP,$PNAME(LPSA) ;STRING NUMBER
	MOVEM	TEMP,PNEXTC-1
	MOVEM	TEMP,PLINE-1
	MOVEW	PNEXTC,$PNAME+1(LPSA) ;NEW INPUT POINTER
	MOVEM	TEMP,PLINE
	MOVEI	B,"⊂"		;MARKER FOR MACRO EXP
	TLNE	TBITS2,LSTEXP	;WANT IT?
	IDPB	B,LPNT		;YES
	TLO	TBITS2,MACIN	;MARK IN MACRO
	TLNN	FF,PRMSCN	; IF SCANNING ACTUALS, THEN LEAVE LISTING ALONE
	TRZ	TBITS2,NOLIST	;ASSUME LISTING
	TLNN	TBITS2,MACEXP	;EXPANDING?
	TRO	TBITS2,NOLIST	;NO
	MOVEM	TBITS2,SCNWRD	;UPDATE
	TLNE	FF,PRMSCN	; SCANNING PARAMETERS?
	SKIPN	REQDLM		; YES, IN SPECAIL DELIMITER MODE?
	JRST	NEWCHR		;GO GET FIRST NEW CHAR, RET
	CAIN	P,DSPRMS+3	; IS 177-# FIRST ITEM IN ACTUAL PARAMETER
	HRRI	P,BALCHK	; YES, CHANGE RETURN ADDRESS TO REFLECT 
				; THAT UNTESTED COMMAS AND RIGHT PARS. WILL
				; BREAK SCAN
DLMPRM:	ILDB	B,PNEXTC	; SCAN REST OF CHARS. INTO STRING CONSTANT
	SKIPGE	A,SCNTBL(B)	; SPECIAL?
	PUSHJ	P,(A)		; DO IT
	LSTDPB			; PUT IT AWAY
	IDPB	B,TOPBYTE(USER)	; DEPOSIT IT
	AOJA	C,DLMPRM	; INCREMENT COUNT AND CONTINUE SCAN

RESTOR:	MOVE	PNT,DEFPDP
	POP	PNT,SAVCHR	;CHAR SCANNED AHEAD
	POP	PNT,PNEXTC	;OLD INPUT POINTER
	POP	PNT,PNEXTC-1	;STRING NUMBER
	ADD	PNT,X22			;START PLINE HERE
	POP	PNT,PLINE
	POP	PNT,PLINE-1
	POP	PNT,LPSA	;PERHAPS OLD DEFRNG
	MOVEM	PNT,DEFPDP
	JUMPL	LPSA,DDUN	;NONE OR NOT TO BE CHANGED
	EXCH	LPSA,DEFRNG
	PUSHJ	P,KILLST	;KILL DEFRNG (OLD)

DDUN:	MOVEI	B,"⊃"		;END OF EXPANSION MARKER
	TLNE	TBITS2,LSTEXP
	IDPB	B,LPNT		;PUT OUT IF DESIRED
	SKIPN	PNEXTC-1	;OUT OF MACROS?
	TLZA	TBITS2,MACIN	;YES
	JRST	DUNRST		;NO
	TLNE	FF,LISTNG	;WANT LISTING, IN GENERAL?
	TRZ	TBITS2,NOLIST	;YES, START UP AGAIN
	MOVE	TEMP,IPLINE	;PLINE TO OUTER LEVEL VALUE
	MOVEM	TEMP,PLINE
	SETZM	PLINE-1

DUNRST:	MOVEM	TBITS2,SCNWRD	;SAFETY FIRST

; NOW GET A CHARACTER FOR THE SCANNER

	TLNE	FF,PRMSCN	; SCANNING PARAMETERS?
	SKIPN	REQDLM		; YES, IN SPECIAL DELIMITER MODE?
	TRNA			; SKIP
	SUB	P,X11		; POP RETURN ADDRESS, AND NOW WILL RETURN 
				; TO CHECK NESTING INSTEAD OF CONTINUING 
				; FORMAL PARAMETER SCAN
	SKIPN	B,SAVCHR	;HAVE IT ALREADY?
	JRST	NEWCHR		;NO
	SETZM	SAVCHR		;NO LONGER AHEAD (DCS 5-27-71)******
	MOVE	A,SCNTBL(B)	;YES, DON'T DISPATCH AGAIN
	POPJ	P,

NEWCHR:	ILDB	B,PNEXTC	;GET FROM INPUT
	SKIPGE	A,SCNTBL(B)	;SPECIAL?
	JRST	(A)		;YES, DISPATCH
	POPJ	P,		;NO, DONE

DSCR KILLST
CAL PUSHJ
PAR LPSA → first Semblk to be released
RES Unlinks Semblk from %RSTR, releases it to free
  storage, then continues right down %RVARB until
  all Semblks on this VARB-Ring are released.
DES THIS ROUTINE IS IN THE WRONG PLACE!
SEE FREBLK, ULINK
⊗

↑KILLST:  
	PUSH	P,LPSA
	JUMPE	LPSA,KLPDUN

KLLUP:	

	PUSHJ	P,URGSTR	;UNLINK FROM STRING RING
	FREBLK
	RIGHT	,%RVARB,<[KLPDUN: POP P,LPSA
				  POPJ P,]>
	JRST	KLLUP
SUBTTL	SCANNER INPUT AND LISTING ROUTINES
DSCR ADVBUF -- new input buffer routine
DES Reads a new input buffer, gets a new source file
  if this one is exhausted or if file switching is
  happening (prints loser message if no files remain),
  and assures that the buffer ends in zero for EOB
  detection by SEOL. The buffers were made long enough
  to allow the inclusion of an extra word of zero.
SID Saves USER, C -- reinits A,B -- all others vulnerable
SEE SEOL, SEOB, routines which detect EOB and call ADVBUF.
⊗

ADVBUF:	
WOM <
	MOVSI	TEMP,(<'TTY   '>)
	CAMN	TEMP,SRCDEV	;IF SOURCE IS TTY, TELL USER TO GO
	 TERPRI	 <SAILX:	>
>;WOM
	XCT	INSRC		;ADVANCE BUFFER
	XCT	TSTSRC		;ANY ERRORS?
	 ERR	 <I-O ERROR ON SOURCE DEVICE>,1
	XCT	EOFSRC		;TO ENDFL ON EOF
	JRST	ENDFL
	PUSHJ	P,SGCHK		;STRING GC, IF NECESSARY, TBITS←SRCCNT
	ADDI	TBITS,4		;(CHAR CT+4)/5 IS WORD COUNT
	IDIVI	TBITS,5
	ADD	TBITS,SRCPNT	;ADD BASE ADDRESS
	IBP	TBITS		;→LAST WORD+1, MAKE 0 TO
	SETZM	(TBITS)		; DENOTE EOB
	MOVE	PNT,SRCPNT	;RESET PNT TO CURRENT BP,
	MOVEM	PNT,PNEXTC	;FIX THIS GUY TOO.
	MOVE	TEMP,1(PNT)	; TEMP TO WORD NEXT REFERENCED
	POPJ	P,

; CHECK FOR STRING SPACE FULL, GC IF SO

SGCHK:
	HRRZ	TBITS,SRCCNT	;GET # OF CHARACTERS
	MOVE	TEMP,REMCHR(USER) ;TEST ENOUGH ROOM
	ADD	TEMP,TBITS
	SKIPL	TEMP		;IS THERE ENOUGH?
	 JRST	 SGCOL		;NO, COLLECT SPACE
	POPJ	P,		;NOT NECESSARY

ENDFL:	XCT	RELSRC		;RELEASE OLD FILE,
ENDSWT:	MOVEM	TBITS2,SCNWRD	;UPDATE IN CORE VERSION
	PUSHJ	P,FILEIN	;FIND AND INIT NEW ONE
	JRST	[TLNN	TBITS2,EOFOK
		 ERR	<FATAL END OF SOURCE FILE>
		 MOVNI	B,1	;MARK END OF FILE NEXT TIME
		 MOVEI	A,1	;HARMLESS, BUT BREAKS IGNORABLE
		 SUB	P,X11	;RETURN EARLY
		 POP	P,C	;CHAR COUNT BACK
		 POPJ	P,]
	PUSHJ	P,MAKT		;PREPARE NEW TITLE LINE
	SKIPE	SRCDLY		;COMING BACK FROM SWTCHED-TO FILE?
	 JRST	 SWTBKP		; YES, DO MORE BOOKKEEPING
	SETZM	FPAGNO		;FIRST PAGE IN NEW FILE
	PUSHJ	P,HDR		; , DENOTE IT
	JRST	ADVBUF		; OR PRINT LOSING MESSAGE, TRY AGAIN
; WE HAVE OLD SOURCE FILE BACK, FAKE ADVBUF
SWTBKP:
	PUSHJ	P,HDROV		;CONTINUE PAGE NUMBERING FOR FILE
	SETZM	SRCDLY
	PUSHJ	P,SGCHK		;CHECK (LIBERALLY) FOR STRING SPACE FULL
	MOVE	TEMP,PNEXTC	;NOW SET UP PNT, PNEXTC, AND TEMP AS
SWTLUP:	SKIPN	(TEMP)		; THEY WOULD BE COMING OUT OF ADVBUF
	 JRST	 ADVBUF		;WE WERE AT END OF BUFFER ANYWAY
	MOVE	PNT,TEMP	;WE'RE GOING TO GET AHEAD OF SELVES
	ILDB	TBITS,TEMP	;CHECK NULLS
	JUMPE	TBITS,SWTLUP	;ALL THIS UNECESSARY IF SOS FILES, BUT...
	MOVEM	PNT,PNEXTC	;FAKE ADVBUF
	MOVE	TEMP,(TEMP)	;WORD WITH NON-NULL CHAR
	POPJ	P,
UPDCNT:	HRRM	C,PNAME			;UPDATE PNAME
	ADDB	C,REMCHR(USER)		;AND REMCHR
	CAMGE	C,[-=50]		;ARE WE NEARING CATASTROPHE?
	 POPJ	 P,			; NO
;EVEN THIS CANNOT PREVENT OCCASIONAL DEATH
	MOVEI	TBITS,=50		;REQUIRE AT LEAST THIS MANY
	JRST	SGCOL			;GO COLLECT

SGCOL1:	HRRZ	TBITS,$PNAME(LPSA)	;CHAR COUNT
SGCOL2:	MOVE	USER,GOGTAB
	MOVE	TEMP,REMCHR(USER)		;REMAINING CHARS
	ADD	TEMP,TBITS
	SKIPGE	TEMP				;NOT ENOUGH?
	 POPJ	 P,				;NO, OK

SGCOL:	EXCH	SP,STPSAV	;GET STRING STACK
	PUSH	P,TBITS		;PASS TO STRGC THIS WAY
	PUSHJ	P,STRGC	;COLLECT STRING SPACE
	EXCH	SP,STPSAV	;GET IT BACK
	POPJ	P,		; NO, GO AHEAD

↓CHROUT: SOSG	LSTCNT		;ONE CHAR OUTPUT ROUTINE
	PUSHJ	P,LSTDO		;DO AN OUTPUT
	IDPB	TBITS,LSTPNT	;DO THE OUTPUT
	POPJ	P,

↓LSTDO:	OUT	LST,
	POPJ	P,		;OK
	ERR	<I-O ERROR ON LISTING DEVICE>,1
	POPJ	P,
NOGAG <
DSCR --HERE IS THE CREFFINF STUFF (STRANGE PLACE N'EST CE PAS?)
DES We'll leave it at these comments for the nonce:
 For those of you who are interested in what cref output looks like, allow
 me to discourse for a while on it.  Basically, the output line is
 preceeded by a whole mess of garbage. (In the following discussion,
 let ≡ stand for delete -- octal 177).

1. The first thing in a line with cref information in it must be
	≡B    .  This is handled in crefout.

2. There are two types of symbols:
	a. NUMSYM's, which are represented by a six-digit number(decimal)
		which is unique to that occurrance of the symbol.
		The number is represented by an octal 6 (length of symbol)
		followed by the number in ASCII.
	b. SYMSYM's, which are the real symbolic symbols.  These consist
		of one byte of length, followed by the symbol in ASCII

3. When an identifier is seen in the source text, you do one of
	several things:
	1  followed by the NUMSYM -- a regular identifer seen.
	3  followed by the SYMSYM -- a reserved word.
	5  followed by the NUMSYM -- a macro use.
  -- it is occasionally to flush the last type 1 instance.  This is done
 	by following it immediately with a 7.

4. When defining things, we put out:
	1 followed by the NUMSYM followed by 2 -- ordinary identifier
	6 followed by NUMSYM -- macro.

5. When beginning a block, we put out a 15 followed by the SYMSYM.
6. When ending a block, we put out a 16 followed by the SYMSYM.
	Then come the equivalences of numbers and symbolic names.
7. To equivalence an ordinary symbol, we put out 11 followed by
	the NUMSYM followed by the SYMSYM.

8. When all done with the cref information for a line, we put out
	≡A    .
⊗

BEGIN CREF

↑LCREFIT: 
	TDZA	C,C
↑ECREFIT: MOVNI C,1		;CREF FOR ENTER.
	TLNN	TBITS,CNST	;IF A CONSTANT, FORGET IT.
	TLNE	FF,NOCRFW	;AN EXTERNAL PROCEDURE -- DO NOT CREF;
	POPJ	P,
	MOVE	A,X11		;ORDINARY IDENTIFIER.
	TLNE	TBITS,DEFINE	;IF THIS IS A MACRO.
	MOVE	A,[XWD 6,5]
	TLNE	TBITS,400000	;RESERVED WORD?
	MOVE	A,X33
	TLNE	C,-1		;ENTER OR LOOKUP?
	MOVSS	A
	PUSHJ	P,CREFOUT	;AND PUT OUT THE CHARACTER.
	PUSHJ	P,CREFSYM	;CREF THE SYMBOL IN LPSA,TBITS.
	TLNN	A,-2		;IF REGULAR SYMBOL,
	SKIPL	C		;BEING DEFINED,
	POPJ	P,
	MOVEI	A,2		;THEN PUT OUT EXTRA THING.
	JRST	CREFOUT		;....


CREFSYM: PUSH	P,TBITS
	JUMPL	TBITS,ASC1	;A RESERVED WORD ----
	MOVEI	TBITS,6
	PUSHJ	P,CHROUT	;NUMBER OF CHARACTERS.
	MOVEI	TBITS,(LPSA)
	MOVEI	PNT2,6		;FOR THE RECURSIVE NUMBER PRINTER IN SEOL.
	MOVEI	B,CHROUT	;OUTPUT ROUTINE FOR SAME --
	PUSHJ	P,FRNP1		;  FRNP1 IS IN SEOL ABOVE.
	POP	P,TBITS
	POPJ	P,		;GO AWAY.
ASC1:	PUSH	P,A
	PUSHJ	P,CREFASC	;ASCII CREF.....
	POP	P,A
	POP	P,TBITS
	POPJ	P,


CREFCHR: CAIN	A,"_"
	MOVEI	A,"."		;CHANGE UNDERLINE TO .
↑↑CREFOUT: SKIPE  LNCREF	;CREF GONE FOR THIS LINE?
	JRST	GONEF		;YES
	SETOM	LNCREF
	PUSH	P,A
	MOVEI	A,177
	PUSHJ	P,CREFOUT
	MOVEI	A,"B"
	PUSHJ	P,CREFOUT
	POP	P,A
GONEF:	SOSG	LSTCNT
	PUSHJ	P,LSTDO
	IDPB	A,LSTPNT
	POPJ	P,

↑↑CREFASC:			;CREF THE ASCII FOR A SYMBOL.
	HRRZ	A,$PNAME(LPSA)	;COUNT.
	PUSHJ	P,CREFOUT	;AND CREF...
	MOVE	TEMP,A
	MOVE	C,$PNAME+1(LPSA)	;BYTE POINTER.
	ILDB	A,C
	PUSHJ	P,CREFCHR
	SOJG	TEMP,.-2
GPOPJ:	POPJ	P,

↑↑CREFDEF:			;PUT OUT SYMBOL DEFINTION.
	MOVEI	A,11		;ORDINARY SYMBOL
	MOVE	TEMP,$TBITS(LPSA)
	TLNE	TEMP,DEFINE
	MOVEI	A,13		;FOR MACRO
	PUSHJ	P,CREFOUT
	PUSHJ	P,CREFSYM
	JRST	CREFASC		;CODE,SYMBOL,PRINT-NAME.

↑↑CREFBLOCK:			;END OF A BLOCK.
	MOVEI	A,16
	PUSHJ	P,CREFOUT
	JRST	CREFASC		;AND THE NAME.


BEND
>;NOGAG
DSCR HDR, HDROV 
DES List routines for top of (physical page). Reset page,
  line counters.  Print a page header if listing.
 HDR is called when new page (logical) is sensed.
 HDROV is called when PGSIZ lines have been printed
  since last time a header was printed.
SID Uses D, TEMP,USER -- saves USER, C, others vulnerable.
⊗

↑HDR:	
	AOS	PAGENO		;NEXT PAGE, PLEASE
	AOS	FPAGNO		;NEXT IN THIS FILE
	SETZM	PAGINC		;FIRST PHYSICAL PAGE NO
	SETZM	BINLIN		;SEQUENTIAL LINE #
	AOS	BINLIN		;ALWAYS STARTS AT 1
;;#HU# 6-20-72 DCS BETTER TTY LISTING
	SKIPN	CRIND		;NEED CRLF/INDENT?
	 JRST	 NCRIND		;NO
	SETZM	CRIND
	TERPRI
	MOVE	TEMP,LININD
	OUTSTR	INDTAB(TEMP)	;CRLF -- INDENT
NCRIND:	PRINT	< >
	DECPNT	FPAGNO		;JUST KEEP TRACK

↑HDROV:	
	SETZM	LINNUM
	AOS	PAGINC		;HERE WHEN LINES OVERFLOW PAGE
	TLNN	FF,LISTNG	;ARE WE LISTING?
	 POPJ	 P,		; NO

	PUSH	P,D		;SAVE

	MOVEI	TEMP,"$"
	MOVEM	TEMP,BKR	;$ BREAKS ASCFIL
	MOVE	A,[POINT 7,TITLIN]
	MOVEI	TEMP,=5*28	;MAKE SURE ENOUGH ROOM REMAINS
NOWOM <
	CAMLE	TEMP,LSTCNT	;IS THERE
>;NOWOM
WOM <
	SOSG	LSTCNT		;IS THERE ROOM FOR ONE?
>;WOM
	PUSHJ	P,LSTDO		;NOW THERE IS
	MOVEI	D,14
	IDPB	D,LSTPNT
NOWOM <
	MOVE	TEMP,LSTPNT
	PUSHJ	P,ASCFIL	;INTERSPERSE CONSTANTS
	MOVE	D,FPAGNO
	PUSHJ	P,DECFIL
	MOVN	D,PAGINC	; TO FORM HEADER LINE
	PUSHJ	P,DECFIL
	PUSHJ	P,ASCFIL
	MOVE	LPSA,TTOP
	PUSHJ	P,PSTRNG
	PUSHJ	P,ASCFIL
	TLZ	TEMP,770000		;ADJUST BYTE POINTER
	EXCH	TEMP,LSTPNT		;TO NEW LOC
	SUB	TEMP,LSTPNT		;GET SIZE
	IMULI	TEMP,5			;NUMBER OF CHARS USED
	HRREI	TEMP,-5(TEMP)
	ADDM	TEMP,LSTCNT
>;NOWOM
	POP	P,D
	POPJ	P,

TITLIN:	BLOCK	=28		;SHOULD BE BIG ENOUGH FOR TITLE LINE

;  MAKT -- PREPARE A TITLE LINE

↑MAKT:	
	MOVEI	TEMP,"%"
	MOVEM	TEMP,BKR	;% BREAKS ASCFIL
	MOVE	A,[<POINT 7,[ASCII /		SAIL	%/]>]
	MOVE	TEMP,[POINT 7,TITLIN]
	MOVEI	LPSA,IPROC	;GET PROGRAM NAME
	PUSHJ	P,[
PSTRNG:	HRRZ	B,$PNAME(LPSA)
	MOVE	C,$PNAME+1(LPSA)
	
MKT1:	ILDB	D,C
	IDPB	D,TEMP
	SOJG	B,MKT1	;PUT OUT PROG NAME
	POPJ	P, ]


	PUSHJ	P,ASCFIL	;MOVE IN THIS MUCH
	MOVE	A,[<POINT 7,[ASCII /   %:% %  $
$

$%/]>]


; A AND TEMP SHOULD NOT BE USED HERE UNLESS SAVED

	PUSH	P,A
	CALL6	C,DATE
	IDIVI	C,=31		;DAY IN D
	ADDI	D,1		;DAY - 1 THAT IS
	PUSHJ	P,DECFIL
	IDIVI	C,=12		;MONTH - 1 IN D
	MOVE	D,[ASCII /-JAN--FEB--MAR--APR--MAY--JUN--JUL-/
		   ASCII /-AUG--SEP--OCT--NOV--DEC-/](D)
	MOVE	A,[POINT 7,D]
	MOVE	D+1,[ASCII /%/]
	PUSHJ	P,ASCFIL
	MOVEI	D,=64(C)	;YEAR
	PUSHJ	P,DECFIL
	POP	P,A
	PUSHJ	P,ASCFIL	;SPACES, I THINK
	CALL6	C,MSTIME	;TIME IN MS
	IDIVI	C,=60000
	IDIVI	C,=60		;MINUTES IN D
	EXCH	C,D
	PUSHJ	P,DECFIL	;PRINT IT
	PUSHJ	P,ASCFIL	;COLON
	MOVE	D,C		;MINUTES
	PUSHJ	P,DECFIL	;PRINT THEM
	PUSHJ	P,ASCFIL	;MORE SPACES
	MOVE	B,SRCFIL	;GET SOURCE FILE NAME
	MOVEI	D,6		;COUNT
LLUP:	ROTC	B,6
	TRZ	C,100		;DITCH BIT
	ADDI	C,40		;CONVERT TO ASCII
	IDPB	C,TEMP
	SOJN	D,LLUP
	PUSHJ	P,ASCFIL	;MORE SPACES AND THINGS
	POPJ	P,

SUBTTL	ENTERS -- ENTER A SYMBOL
DSCR ENTERS -- make new symbol entry
DES Will use existing comments, not use standard form
 ENTERS creates a block of proper type for this "ATOM", and
  installs the proper links to assure this thing can be found
  again. ENTERS can handle the following kinds of things:
		1. Variables -- numeric, STRING, ITEM, etc.
		2. Labels
		3. Procedure identifiers
		4. Numeric constants
		5. String constants
 STEPS:
 1-3: Create a block for ID. Check that level is greater
  for new symbol if old one was present (FORWARD Procedures
  are a special case). Install level, $TBITS, $PNAME; link
  to SYMTAB hash table (→instr to fetch right bucket in HPNT).
  Link to current VARB structure via %RVARB, to STRRNG via
  %RSTR for STRINGC collector. Return →Semantics in  NEWSYM
  (replaces → found block if redefinition).
 4: Insert numeric value entry in CONST bucket. No checking
  (level, etc.) is necessary because ENTERS is called for
  constants only when the lookup fails. Bucket fetching instr
  found in HPNT, new Semantics to NEWSYM.
 5: Insert new string constant entry in STRCON bucket. #4 
  arguments also apply here.

PAR "BITS" -- the TBITS flags for the ATOM. These will be
  installed in the entry. They also guide the entry process.

"PNAME" -- String descriptor for $PNAME or String constant.

"SCNVAL" -- value of (1st word of) numeric constant. Second
  word, if any, is the adjacent word DBLVAL.

"HPNT"  -- The instr which when executed will load LPSA with
  the correct bucket in the right half. SHASH, NHASH set up.

"NEWSYM" -- if ≠0, →block matching PNAME or SCNVAL. This ptr
  is set by SCAN, STRINS, etc., using SHASH, NHASH. If -0,
  this is the first occurrence of the symbol.

DIS < 
Also, the prodef bit in ff is used to tell if the symbol is a formal param
>;DIS

RES "NEWSYM"←pointer to new block.

SID Uses A,C, TBITS, LPSA, TEMP; alters symbol table structure
⊗
↑ENTERS:	
	MOVE	TBITS,BITS	;TYPE BITS
	TLNE	TBITS,CNST	;CONSTANT?
	 JRST	 ENCNST		; YES

; ENTER AN IDENTIFIER -- CHECK FOR RESERVED (ERROR), FORWARD
;  PROCEDURE BEING DEFINED. CHECK LEVEL VALIDITY FOR REDEFINED
;  SYMBOLS

ENIDNT:
	MOVE	C,LEVEL		;CURRENT LEVEL OF DEFINITION
	SKIPG	LPSA,NEWSYM	;IS THIS THE FIRST OCCURRENCE?
	 JRST	 BRANEW		; YES

;;#JZ# 11-4-72 HJS (1-2) CHANGE MACRO SCOPE
;;#JZ# THIS GROUP AND THE NEXT WERE INTERCHANGED
	SETCM	TEMP,$TBITS(LPSA);PREVIOUS TYPE BITS, COMPLEMENTED
	SKIPL	$TBITS(LPSA)	; CHECK FOR REDEFINITION OF A RESERVED WORD AS
				;  AS A MACRO (HJS 11-19-72)
	TLNN	TBITS,DEFINE	;SPECIAL TREATMENT FOR REDEFINITION
	 JRST	 NODEFN		; IT ISN'T ONE (HJS 11-19-72)
	TLNN	TEMP,DEFINE	
	 JRST	DFEN1		; IT IS ONE
;;#JZ# (1-2)

;;#JZ# 11-4-72 HJS (2-2) WAS INTERCHANGED WITH ABOVE
NODEFN:	LDB	A,PLEVEL	;OLD LEVEL OF DEFINITION (HJS 11-19-72)
	SKIPL	$TBITS(LPSA)	;IF OLD WAS RESERVED WORD, THEN OK.
	CAMLE	C,A		;C=CURRENT -- MUST BE GREATER
	 JRST	 OKOLD		; AND IS
	CAME	C,A		;IF =, MAY BE FORWARD COMING
	 ERR	 <SAIL IN LEVEL TROUBLE>,1
;;#JZ# 2-2

CHKPRC:	SETCM	A,TBITS		;NEW BITS
;; SUGG BY R. SMITH LOAD A BEFORE TRNN
	TRNN	TEMP,PROCED!FORWRD; MUST BE FORWARD PROCEDURE
	 JRST	 ISPRC
	TLO	A,OWN		;THIS IS SORT OF IRRELEVANT
	TLO	TEMP,OWN
	TLOE	TEMP,EXTRNL
	 ERR	 <DUPLICATE IDENTIFIER DECLARATION>,1,BRANEW ; ISN'T ANY GOOD!
	TLC	A,INTRNL	;SHOULD BE ON (=0), TURN OFF (=1) OR ON (ERROR)
	CAME	A,TEMP
	 ERR	 <DUPLICATE IDENTIFIER DECLARATION>,1,BRANEW ; ISN'T ANY GOOD!
	MOVEM	TBITS,$TBITS(LPSA)
	PUSHJ	P,URGVRB
	PUSHJ	P,RNGVRB
	POPJ	P,

ISPRC:	TRNN	TBITS,PROCED	 ;THIS SHOULD ALSO BE A PROCEDURE
	 ERR	 <DUPLICATE IDENTIFIER DECLARATION FOR >,3,BRANEW

; FORWARD PROCEDURE BEING DEFINED NOW, CHECK VALIDITY, CHANGE BITS

	TRZE	A,FORWRD 	;TO MATCH OLD(COMPLEMENTED)
	TLNN	A,EXTRNL	;MAKE SURE NOT DUPLICATE EXTERNAL
	 ERR	 <DUPLICATE FORWARD/EXTERNAL DECLARATION FOR >,3,NOPROG
;;#JX#2↓ 11-2-72 DCS ALLOW INTERNAL PROC TO OVERRIDE EXTERNAL PROC.
	TLON	TEMP,EXTRNL	;Turn off EXTRNL in old, but if it was on, flip
	 TLC	 A,INTRNL	; INTRNL in new (will turn it off was on -- correct)
;;#JX#
	CAME	A,TEMP		;CHECK MATCHING TYPES
	 ERR	 <FORWARD TYPE DISAGREES>,1
	TRO	TBITS,INPROG	;MARK PROCEDURE UNDER DEFINITION
	MOVEM	TBITS,$TBITS(LPSA) ;STORE NEW
NOPROG:	PUSHJ	P,URGVRB	;REMOVE FROM VARB RING
	PUSHJ	P,RNGVRB	;PUT BACK ON THE END
	LEFT	,%TLINK,LPSERR	;→SECOND BLOCK
	LEFT	(,%TLINK)
;;#GP# DCS 2-6-72 (2-4) CHECK OLD FORMALS AGAINST ACTUAL ONES
	HRRZM	LPSA,OLDPRM	;SAVE OLD FORMALS -- USED TO KILLST HERE
	POPJ	P,		;FOR A BIT LATER
;;#GP# (2)

; REDEFINITION IF NOT A PARAMETER TO A MACRO

DFEN1:	TLNN	TEMP,FORMAL	;BITS ARE COMPLEMENTED HERE, CAN'T BE FORMAL
	ERR	<DUPLICATE IDENTIFIER DECLARATION>,1
	POPJ	P,		; GET OUT IF MACRO REDEFINITION AT THE SAME
				;   LEVEL.  BODY IS DELETED IN DFENT IF
				;   %TLINK IS NON-ZERO
 
; NOW CREATE A NEW BLOCK, PUT STUFF IN IT

BRANEW:	;NO CHECKING WAS DONE
OKOLD:	;IT'S ALL OK

	GETBLK	NEWSYM		;GET A NEW BLOCK

; INSERT PNAME, BITS -- LINK TO BUCKET, STRING RING,(VARB IF ID)

	MOVE	LPSA,NEWSYM	;POINTER TO NEW BLOCK
	HRROI	TEMP,PNAME+1	;GET PDP FOR POPPING DATA

	POP	TEMP,$PNAME+1(LPSA) ;STORE STUFF
	POP	TEMP,$PNAME(LPSA)

NOGAG <
;CREFFING FOR THE WORLD.
	TLNE	FF,CREFSW
	PUSHJ	P,ECREFIT
>;NOGAG

	TRNN	TBITS,PROCED	;PROCEDURE?
	JRST	NOPROC		;NO
	MOVE	PNT,LPSA
	GETBLK			;SECOND PROCEDURE BLOCK
	HRLM	LPSA,%TLINK(PNT) ;%TLINK → 2D BLOCK
	MOVE	LPSA,PNT
	TRNN	TBITS,FORTRAN	;A FORTRAN CALL?
	TLNE	TBITS,EXTRNL	;OR EXTERNAL
	TRO	TBITS,FORWRD	;TURN ON FORWARD.
	TRNN	TBITS,FORWRD	;A FORWARD PROCEDURE?
	TRO	TBITS,INPROG	;NO -- TURN ON IN PROGRESS.
NOPROC:	MOVEM	TBITS,$TBITS(LPSA) ;TYPE BITS
GAG <
	TLNN	TBITS,EXTRNL	  ;IF ANY KIND OF EXTERNAL TYPE, THEN
	 JRST	 NOXTR
	MOVEI	TEMP,FORWRD	;TURN IT OFF
	ANDCAM	TEMP,$TBITS(LPSA) ;SINCE WE WILL LOOK FOR IT.
	PUSHJ	P,RAD50		;THIS WILL MAKE RADIX50 IN A.
	TLC	A,640000	;CHANGE FROM EXTERNAL TO INTERNAL
	PUSH	P,[0]		;FOR LUKSYM -- MEANS SEARCH ALL.
	PUSH	P,[0]
	PUSH	P,A		;AND FOR THIS NAME.
	PUSHJ	P,LUKSYM	;GO FIND IT.
	 ERR	 <EXTERNAL CODE MUST BE LOADED WITH SAILX>,1
	HLRM	C,$ADR(LPSA)	;AND PUT DOWN RESULT.
NOXTR:
>;GAG
NODIS <
	MOVE	C,LEVEL		;CLOBBERED BY CREFFING.
>;NODIS
DIS <
	SKIPE	C,SIMPSW	;IF SIMPLE
	AOJA	C,FILLEV	;CLEVER TRICK TO LOAD C 0 & GO PUT IN LL
	TRNN	TBITS,LABEL	;OR NOT A LABEL, DONT CARE
	JRST	DOLL		;GO DO LEVELS
	MOVE	C,TPROC		;PICK UP CURRENT PROCEDURE
	HRRZ	C,$VAL(C)	;PICK UP PD SEMBLK
	HRLM	C,$ACNO(LPSA)	;PUT AWAY FOR LABEL SEMBLK
;#HY# RHT 6-26-72 OWN WAS BEING TESTED AS A RIGHT HALF BIT
DOLL:	SKIPE	C,CDLEV		;PICK UP DISPLY LEVEL
;;#IU# 8-12-72 ↓ RHT PREVENT EXTERNALS FROM BEING REFD (RF)
	TLNE	TBITS,OWN!EXTRNL;IF NON-ZERO DISPLY LEV, BUT OWN, OK
	JRST	FILLEV		;NO WORRY, ID IS AT LEVEL 0
	SKIPE	RECSW		;IF  CURRENT PROC IS RECURSVE
;#HY# RHT  HERE IS WHERE OWN WAS BEING TESTED
	TRNE	TBITS,ITEM!LABEL!PROCED; YES, IF NOT ITEM,LABEL, OR PROC THEN USE
				;STACK
	TLNE	FF,PRODEF	;IF FORMAL USE STACK -- PRODEF SAYS WAS AN ARG LST
	LSH	C,LLFLDL	;SHIFT LEVEL  T RIGHT SPOT
	TRZ	C,LLFLDM
	;MASK OUT LEX LEV FLD AREA
FILLEV:	TDO	C,LEVEL		;PUT IN THE LEX LEVEL
>;DIS
	HRRZM	C,$SBITS(LPSA)	;LEVEL OF DEFINITION

; LINK TO BUCKET, STRING RING

	TLNN	FF,DEFLUK	; DON'T PUT PARAMETERS TO MACROS OR 
	SKIPE	DLMSTG		;   MACRO BODIES OR SPECIALLY DELIMITED
	 JRST	 STRPUT		;   STRINGS ON BUCKET
	MOVEI	A,LNKRET+1	;IN-LINE "CALL"
LNK:	MOVE	B,HPNT		;WORD SET UP BY HASH
	XCT	B		;THIS PICKS UP THE TIE INTO LPSA
	MOVE	TEMP,NEWSYM	;POINTER TO NEW ONE
	HRRM	LPSA,%TBUCK(TEMP)	;LINK DOWN NEW BLOCK
	HRR	LPSA,TEMP	;GET LPSA READY TO PUT BACK
	TLO	B,2000		;TURN ON "MOVE TO MEMORY" BIT
	XCT	B
LNKRET:	JRST	(A)		;ALL DONE

STRPUT:	MOVE	LPSA,NEWSYM
	PUSHJ	P,RNGSTR	;PUT ON STRING RING


; IF NOT A CONSTANT, LINK TO VARB LIST -- RETURN

VRBLNK:	TLNE	FF,PRMSCN	;PUT ON VARB RING IF ACTUAL PARAM
	 JRST	 VRBMAK		; TO DEFINE
	TLNE	TBITS,CNST	;NOT ON VARB IF CONST
	 POPJ	 P,		; DONE

VRBMAK:	MOVE	LPSA,NEWSYM
	JRST	RNGVRB		;PUT ON VARB RING

Comment ⊗ Constants, String or Numeric ⊗

ENCNST:	TRNN	TBITS,STRING	;STRING CONSTANT?
	 JRST	 ENNUMB		; NO, NUMERIC

ENSTRNG:
	MOVEI	C,0		;STRCONS ARE AT LEVEL 0
	PUSHJ	P,BRANEW	;USE VARIABLE STUFF TO PERFORM THE ENTER.
	MOVE	LPSA,NEWSYM	;SEMANTICS OF RESULT
	HLLZS	$SBITS(LPSA)	;NO LEVELS FOR STRING CONSTANTS
	TLNN	FF,DEFLUK	; ALREADY LINKED ON %RVARB IF
	SKIPE	DLMSTG		;    AN ACTUAL DEFINE PARAM, MACRO BODY, OR
	 POPJ	 P,		;    A SPECIALLY DELIMITED STRING
	PUSHJ	P,RNGCST	;PUT ON CONSTANT RING.

GAG <
	PUSH	P,PNT		;SAVE
	MOVE	PNT,LPSA	;→NEW SYMBOL
	MOVEI	LPSA,STRSTK	;PUT OUT STRINGS
	MOVEI	B,0		;NO BITS
	MOVE	A,PNAME		;FIRST WORD OF DESCRIPTOR
	PUSHJ	P,CPUSH		;FIND IT A HOME
	MOVE	A,PNAME+1	;SECOND WORD
	PUSHJ	P,CPUSH		;WON'T YOU JOIN US?
	HRLM	TEMP,$ADR(PNT)	;ADVERTISE ITS LOCATION
	SOJA	TEMP,WD1S	;GO MARK 1ST WORD, EXIT
>;GAG
	POPJ	P,


; NUMERIC CONSTANT

ENNUMB:
	GETBLK	NEWSYM
	HRROI	TEMP,DBLVAL	;STORE STUFF
	POP	TEMP,$VAL+1(LPSA)
	POP	TEMP,$VAL(LPSA)
	POP	TEMP,$TBITS(LPSA)
	SKIPN	DLMSTG		; SPECIAL DELIMITER MODE?
	TLNE	FF,DEFLUK	; AOMPILE TIME ASSIGNMENT (I.E. MACRO BODY)
	POPJ	P,		; DON'T LINK, RETURN
	JSP	A,LNK		;LINK TO BUCKET LIST
	PUSHJ	P,RNGCNM	;PUT ON CONSTANT RING

GAG <
	PUSH	P,PNT
	MOVE	PNT,LPSA	;→NEW SYMBOL ENTRY
	MOVEI	LPSA,VARSTK	;MIX WITH THE VARIABLES
	MOVEI	B,0		;NO BITS
	MOVE	A,SCNVAL	;THE CONSTANT
	PUSHJ	P,CPUSH		;PUT IT OUT
WD1S:	HRRM	TEMP,$ADR(PNT)	;MARK ITS LOCATION
	MOVE	LPSA,PNT	;RESTORE
	POP	P,PNT		;AND RESTORE
>;GAG
	POPJ	P,
DSCR ADCINS, CREINT, CONINS
CAL PUSHJ from EXECS which create constants for runtime.
PAR A contains value for CREINT, ADCINS
 SCNVAL contains value for CONINS (numeric)
 BITS contains type bits for CONINS
 PNAME string is value for CONINS (String)
RES Semantics for constant (new or used) in rh of PNT
DES These routines are used to create constants, for
  adjusting the stack, doing compile-time computation
  of constant expressions, providing address constants, etc.
 CONINS uses SCNVAL and BITS to make a constant of the
  proper flavor (PNAME string for String constants).
 CREINT makes an Integer constant.
 ADCINS is CONINS, except it forces a new constant to be
  made (code in SCANNER does it).  It is used to provide
  unique addresses for REFERENCE calls, which might wipe
  the values out.
SID All AC's except PNT preserved; lh PNT preserved.
⊗

↑ADCINS:
	MOVEM	A,SCNVAL	;SPECIAL UNIQUE CONSTANT FOR
	MOVE	TBITS,[XWD CNST+RECURS,0] ;ADCON MAKER
	ORM	TBITS,BITS		;(CONSTANT BY REFERENCE)
	JRST	CONINS		;CONTINUE

↑CREINT: MOVEM	A,SCNVAL	;CREATE AN INTEGER
	SKIPA	TBITS,[XWD CNST,INTEGR]

↑CONINS: MOVE	TBITS,BITS
;;#  # DCS 3-1-72
	TRNE	TBITS,STRING	;INSERT A STRING IF REQUESTED
	 JRST	 STRINS
;;#  #
	PUSH	P,NUM1		;FLAGS
	PUSH	P,NUM2
CINS:	MOVE	TEMP,[XWD A,CONACS]
	BLT	TEMP,CONACS+SBITS2-A
	MOVE	LPSA,STRCON	;STRING CONSTANT BUCKET.
	MOVEM	TBITS,BITS
	XCT	-1(P)		;HASH AND LOOKUP
	MOVE	TBITS,TBITS+CONACS-A
	MOVEM	TBITS,BITS
	SKIPN	NEWSYM		;WAS IT FOUND?
	XCT	(P)		;NO -- ENTERS
	MOVE	TEMP,[XWD CONACS,A]
	BLT	TEMP,SBITS2
	SUB	P,X22
	HRR	PNT,NEWSYM	;DO NOT CLOBBER LEFT HALF INCASE
				; ADCONS ARE BEING MADE.
	JRST	GETAD

↑STRINS: PUSH	P,STR1		;FOR STRINGS
	PUSH	P,STR2
	MOVE	TBITS,[XWD CNST,STRING]
	JRST	CINS		;GO DO IT.

NUM1:	PUSHJ	P,NHASH
NUM2:	PUSHJ	P,ENNUMB
STR1:	PUSHJ	P,SHASH
STR2:	PUSHJ	P,ENSTRNG

ZERODATA (AC SAVE AREA FOR CONSTANT-MAKERS)
CONACS:	BLOCK SBITS2-A+1
ENDDATA

SUBTTL	HASH ROUTINES
DSCR SHASH, NHASH -- look up symbol entries in hashed buckets.

PAR LPSA -- →bucket Semblk for SHASH (since there are two).
  NHASH supplies its own.
 PNAME -- String search argument for SHASH
 SCNVAL -- Numeric search argument for NHASH

RES HPNT -- [HRRZ LPSA, bucketaddr] or [HLRZ LPSA, bucketaddr]
  as explained in HPNT declaration.
 NEWSYM -- 0 if not found, else Semantics of found entity.

SID Uses TEMP, TBITS, A, B, C, D, PNT -- Results in LPSA
SEE HPNT, NEWSYM, Bucket descriptions in main SAIL DATA area
⊗

↑SHASH:
	MOVE	A,PNAME+1	;BYTE POINTER
	MOVE	A,(A)		;1ST STRING WORD
	HRRZ	TEMP,PNAME	;#CHARACTERS
	XOR	A,TEMP		;MIX IT UP A BIT
	PUSHJ	P,HASH		;COMPUTE HASH, GET POINTER, STORE IN HPNT

Comment ⊗ Search for symbol identical to string in pname.
	Put pointer to it in NEWSYM if found.
	Computed hash pointer is in HPNT on entry ⊗

SFIND:	SETZM	NEWSYM		;ASSUME NOT FOUND
	HRRZ	A,PNAME		;LENGTH
	JUMPE	A,BUKS		;ZERO LENGTH PNAME TEST
	MOVEI	B,4(A)
	IDIVI	B,5		;# WORDS IN B
	HRLI	PNT,D		;SET UP INDICES
	HRR	PNT,PNAME+1	;BYTE POINTER TO NEW NAME
	HRLI	C,D
	MOVE	TBITS,(PNT)	;FIRST WORD OF NEW NAME

	JRST	BUKS		;START AT THIS ONE
BUKLS:	RIGHT	,%TBUCK,,	;GO DOWN BUCKET
BUKS:		JUMPE	LPSA,NOFND		;IN CASE BUCKET WAS EMPTY
		JUMPE	A,LCOMP			;ZERO LENGTH PNAME TEST
		CAME	TBITS,@$PNAME+1(LPSA)	;SAME FIRST WORD?
		 JRST	BUKLS		;NO , FAIL
	LCOMP:	HRR	TEMP,$PNAME(LPSA)	;LENGTH OF OBJECT STRING
		CAIE	A,(TEMP)	;SAME LENGTH?
		 JRST	BUKLS		;NO -- FAILURE
		JUMPE	A,FND		;IF BOTH LENGTH(0), ASSUME IDENTICAL
		HRREI	D,-1(B)		;# WORDS-1
		JUMPLE	D,FND		;SAME SYMBOL, ONE WORD LONG
		HRR	C,$PNAME+1(LPSA);BYTE POINTER ADDR -- INDEX

	SFNLUP:	MOVE	TEMP,@PNT
		CAME	TEMP,@C		;SAME WORD?
		 JRST	BUKLS		;FAILURE
		SOJG	D,SFNLUP	;KEEP AT IT!


FND:	MOVEM	LPSA,NEWSYM
NOFND:	POPJ	P,



; USES A,B  only -- results in LPSA

↑NHASH:	SETZM	NEWSYM		;ASSUME FAILURE
	MOVE	A,SCNVAL	;HASH ON 1ST WORD OF VALUE
	MOVE	LPSA,CONST	; HASH TO CONST BUCKET
	PUSHJ	P,HASH
	MOVE	A,SCNVAL	;GET VALUES FOR COMPARISON
	MOVE	B,DBLVAL

	MOVE	TEMP,BITS
	TLNE	TEMP,RECURS	;WANT UNIQUE CONSTANT?
	 JRST	 NOFND		; YES, SAME AS FAILURE

	JRST	BUK		;START HERE
BUKL:	RIGHT	,%TBUCK		;DOWN BUCKET LIST
BUK:		JUMPE	LPSA,NOFND	;BE SURE TO CHECK THE FIRST ONE
		CAME	A,$VAL(LPSA)	;FIRST VALUE EQUAL?
		 JRST	BUKL		;NO -- FAILURE
		CAME	B,$VAL2(LPSA)	;SECOND VALUE EQUAL?
		 JRST	BUKL		;NO -- FAILURE
		MOVE	TEMP,BITS	;MAKE SURE TYPE IS SAME
		CAME	TEMP,$TBITS(LPSA)
		 JRST	 BUKL		;STILL CAN'T USE IT
		JRST	FND		;OK, USE IT

	JRST	FND		;FINISH OUT

Comment ⊗ HASH routine itself --

IN:  A -- number to be hashed
     LPSA -- bucket pointer

OUT: HPNT contains an instruction which, when executed
	will load LPSA with the bucket word in the RH.
	See LNK above for the cute way of entering
	the new symbol.

ACS: uses A, B -- results in LPSA

⊗

HASH:	IDIVI	A,BUKLEN	;GET  (A mod BUKLEN)
	MOVMS	B		;USE MAGNITUDE
	ROT	B,-1		;DIVIDE BY TWO
	ADD	LPSA,B		;ADD TO THE BUCKET POINTER
	HRLI	LPSA,(<MOVE LPSA,0>)
	SKIPL	B
	HRLI	LPSA,(<MOVS LPSA,0>)
	MOVEM	LPSA,HPNT	;AND STORE AWAY
	XCT	LPSA
	HRRZS	LPSA		;SO THE JUMPE WILL WORK.
	POPJ	P,
SUBTTL	SEMBLK Allocation Routines
DSCR BLKGET, BLKFRE -- Semblk Allocators
CAL PUSHJ via GETBLK, FREBLK macros.

DES Routines to perform the following:
 BLKGET allocates a new 11-word Semblk.
 BLKFRE restores such a Semblk to the BLFREE storage list
 SETBLK Initializes BLFREE with blocks as determined by
  determined by the area allocated in lpsbot, lpstop.
 NEEBLK	Gets more blocks when you need them
 BLKZER	Zeroes the block pointed to by LPSA

PAR LPSA is Semblk address for BLKFRE

RES LPSA contains Semblk address from BLKGET

SID USER used for GOGTAB by SET-&NEE- blk
 TEMP  destroyed by same
 LPSA changed by SETBLK and BLKZER, set to good thing by NEEBLK
⊗

ZERODATA (BLOCK-GETTER VARIABLES)
COMMENT ⊗
BLFREE -- Semblk Free Storage List pointer.  Points to first Semblk
   on list, whose first word points to next, etc. -- 0 terminates.
   Semblks are put on the list by BLKZER when allocating more, and
   by the BLKFRE (via FREBLK macro) routine.  They are removed by
   the BLKGET (via GETBLK macro) routine.
⊗
↑↑BLFREE: 0

;FRECNT -- # free blocks when enabled by FTCOUNT switch
IFN FTDEBUG, <
↑↑FRECNT: 0
>

TSTALO←←0		;SPECIAL TEST MODE FOR BLOCK ALLOCATOR
IFNDEF TSTALO, <TSTALO←←0>
IFE TSTALO,<BLLEN←←BLKLEN; ELSE>BLLEN←←BLKLEN+2 ;SET TOTAL BLOCK SIZE
IFN TSTALO, <BLKUSE: 0>
ENDDATA

↑SETBLK:
IFN TSTALO ,<
	MOVEI	TEMP,BLKUSE-BLKLEN-1 ;initialize pointer to
	HRLS	TEMP		     ;doubly-linked list of IN USE
	MOVEM	TEMP,BLKUSE	     ; blocks for finding lacking FREBLKs
>;TSTALO

	MOVE	TEMP,LPSBOT
SETBL1:	MOVEM	TEMP,BLFREE		;STARTING ADDRESS
GOK:	MOVEI	LPSA,BLLEN(TEMP)	;NEXT AREA
	CAML	LPSA,LPSTOP		;TOO FAR?
	JRST	SETD
	MOVEM	LPSA,(TEMP)		;STORE THE POINTER
	MOVE	TEMP,LPSA
	JRST	GOK

SETD:	SUBI	TEMP,BLLEN		;GO BACK AND
	SETZM	(TEMP)			;TERMINATE LIST
	POPJ	P,

↑NEEBLK:
	PUSH	P,B			;NEEDED FOR CORE GETTERS
	PUSH	P,C
	MOVE	B,LPSBOT		;TRY TO INCREMENT THIS BLOCK
	MOVEI	C,=100*BLLEN		;TRY TO INCREMENT THIS BLOCK
	PUSHJ	P,CANINC		;IS IT POSSIBLE?
	 JRST	 NOINC			;NO

	JRST	INCR3			;YES, GO DO IT

NOINC:	
	CAIGE	C,=20*BLLEN		;WILL SETTLE FOR THIS
	 JRST	 GETTOP			;NO, GET NEW BLOCK

INCR3:	PUSHJ	P,CORINC		;EXPAND BY ALLOWABLE AMOUNT
	 ERR	 <DRYROT>		;CAN'T HAPPEN
	EXCH	C,LPSTOP		;OLD TOP IS NEW FREE AREA
	ADDM	C,LPSTOP		;NEW UPPER LIMIT
	MOVE	TEMP,C			;SO LEAVE IT WHERE IT WILL BE NOTICED
	JRST	NEERT1			;NOW GO AND RELINK


GETTOP:	MOVEI	C,=100*BLLEN		;GET NEW BLOCK THIS SIZE
	PUSHJ	P,CORGET
	 JRST	 CORERR			;CAN'T GET ENOUGH
	MOVEM	B,LPSBOT		;SET LIMITS ANEW
	MOVEM	B,LPSTOP
	ADDM	C,LPSTOP

NEERET:	
	MOVE	TEMP,B			;→BOTTOM OF NEW
NEERT1:	POP	P,C
	POP	P,B
	PUSHJ	P,SETBL1		;LINK THEM UP
	MOVE	LPSA,BLFREE		;SO THAT WE CAN CONTINUE
	POPJ	P,

↑BLKGET: 
IFN FTDEBUG,<AOS FRECNT>
	SKIPN	LPSA,BLFREE
	PUSHJ	P,NEEBLK	;GET A WHOLE NOTHER SET.
	MOVE	TEMP,(LPSA)
	MOVEM	TEMP,BLFREE	;UPDATE FREE STORAGE.
↑BLKZER: SETZM	(LPSA)		;FIRST WORD
	MOVSI	TEMP,(LPSA)		;ZERO THE BLOCK
	HRRI	TEMP,1(LPSA)
	BLT	TEMP,BLLEN-1(LPSA)
IFN TSTALO,<
; ADD BLOCK TO DOUBLY-LINKED RING OF IN USE BLOCKS
	POP	P,BLKLEN(LPSA) ;SAVE RET ADDR FOR HISTORY OF CALL TO BLKGET
	HLRZ	TEMP,BLKUSE	;GET POINTER TO LAST BLOCK IN RING
	HRLM	LPSA,BLKUSE	;UPDATE SAID POINTER
	HRRM	LPSA,BLKLEN+1(TEMP) ;UPDATE FOR'RD PNTR IN OLD LAST BLOCK
	HRLM	TEMP,BLKLEN+1(LPSA) ;UPDATE BCK'RD PNTR IN NEW (LAST) BLOCK
	MOVEI	TEMP,BLKUSE-BLKLEN-1 ;UPDATE FOR'RD PNTR IN NEW BLOCK
	HRRM	TEMP,BLKLEN+1(LPSA)
	JRST	@BLKLEN(LPSA)	    ;RETURN DEVIOUSLY
; ELSE >POPJ	P,

↑BLKFRE:
IFN FTDEBUG,<SOS FRECNT>
	EXCH	LPSA,-1(P)		;GET ARG, SAVE LPSA
	MOVE	TEMP,BLFREE
	HRRZM	TEMP,(LPSA)		;STRINGOUT FREE STORAGE
	HRRM	LPSA,BLFREE
IFN TSTALO, <
; REMOVE FROM IN USE RING
	MOVE	TEMP,BLKLEN+1(LPSA)	;BCK'RD,,FOR'RD
	HLLM	TEMP,BLKLEN+1(TEMP)	;UPDATE BCK'RD IN NEXT TO → PREV
	MOVSS	TEMP
	HLRM	TEMP,BLKLEN+1(TEMP)	;UPDATE FOR'RD IN LAST TO → NEXT
>
	MOVE	LPSA,-1(P)		;GET OLD VALUE BACK
	SUB	P,X22
	JRST	@2(P)
SUBTTL	RNGVRB, RNGSTR, etc. -- `Ring' Linkage Routines


DSCR RNGSTR, RNGGEN, RNGTMP, RNGCST, RNGVRB, RNGADR, RNGCNM
PAR (Sometimes) LPSA is Semblk address
RES The Semblk is linked onto a `ring' based on a variable
 implied by the routine name.  RNGSTR uses %RSTR -- all others
 use %RVARB.  The ring header variables are STRRNG, VARB, TTEMP,
 CONINT, CONSTR, ADRTAB.
DES These routines replace the RING macro -- for space efficiency.
⊗

↑RNGDIS:MOVEI	TEMP,DISLST	;DISPLAY TEMPS
	JRST	RNGGEN
↑RNGADR:SKIPA	TEMP,[ADRTAB]	;ADDRESS CONSTANTS
↑RNGTMP:MOVEI	TEMP,TTEMP	;CORE TEMPS
	JRST	RNGGEN
↑RNGCNM:SKIPA	TEMP,[CONINT]	;NUMERICAL CONSTANTS -- ASSUMES NEWSYM
↑RNGCST:MOVEI	TEMP,CONSTR	;STRING CONSTANTS    -- ASSUMES NEWSYM
	SKIPA	LPSA,NEWSYM	;GET SEMBLK FROM HERE
↑RNGVRB:MOVEI	TEMP,VARB	;VARB RING
RNGGEN:	PUSH	P,A
	SKIPN	A,(TEMP)	;The left half of %RVARB(Semblk) is
	 JRST	 .+3		; made to point to the previous `newest'
	HRRM	LPSA,%RVARB(A)	; Semblk, if one exists -- the right
	HRLZM	A,%RVARB(LPSA)	; half of %RVARB(Previous) points to
	MOVEM	LPSA,(TEMP)	; this one -- the vase vbl (TEMP) always
	POP	P,A		; indicates the new (right-hand) end
	POPJ	P,		; of the list -- the oldest lh is always 0


↑RNGSTR:SKIPN	TEMP,STRRNG	;String ring linkage -- same business
	 JRST	 .+3
	HRRM	LPSA,%RSTR(TEMP)
	HRLZM	TEMP,%RSTR(LPSA)
	MOVEM	LPSA,STRRNG
	POPJ	P,

DSCR URGVRB, URGADR, URGTMP, URGCST, URGSTR
PAR LPSA is a Semblk Address
 The Header vbl is set up by calling the right routine
DES Undoes the damage done by RING
⊗

↑URGDIS:SKIPA	TEMP,[DISLST]
↑URGCNM:MOVEI	TEMP,CONINT
	JRST	URGGEN
↑URGVRB:SKIPA	TEMP,[VARB]
↑URGTMP:MOVEI	TEMP,TTEMP
	JRST	URGGEN
↑URGADR:SKIPA	TEMP,[ADRTAB]
↑URGCST:MOVEI	TEMP,CONSTR
URGGEN:	PUSH	P,A		;If there are no pointers in %RVARB, then
	SKIPN	A,%RVARB(LPSA)	;1) The Semblk is not on the ring, or:
	CAMN	LPSA,(TEMP)	;2) It is the only member, in which case its
	 JRST	 DOU		;   address is that of the header vbl (TEMP)
ENDU:	POP	P,A		;So you get here immediately in CASE 1 above,
	POPJ	P,		;   and after you've unlinked in other cases.
DOU:	TRNE	A,-1		;If there is a younger neighbor, tell him
	 HLLM	 A,%RVARB(A)	;   you're gone.
	TRNN	A,-1		;If there is not a younger neighbor, update
	 HLRZM	 A,(TEMP)	;   the header, because you were youngest.
	MOVSS	A
	TRNE	A,-1		;If there is an older neigbor, tell him
	 HLRM	 A,%RVARB(A)	;   you're gone.
	JRST	ENDU

↑URGSTR:SKIPN	TEMP,%RSTR(LPSA);Same stuff for string ring.
	CAMN	LPSA,STRRNG
	 JRST	 DOST
	 POPJ	 P,
DOST:	TRNE	TEMP,-1
	 HLLM	 TEMP,%RSTR(TEMP)
	TRNN	TEMP,-1
	 HLRZM	 TEMP,STRRNG
	MOVSS	TEMP
	TRNE	TEMP,-1
	 HLRM	 TEMP,%RSTR(TEMP)
	POPJ	P,
SUBTTL  Mark insertion routine for counter routines
DSCR LSTOUT -- write to list file
CAL PUSHJ P,LSTOUT
PAR Reg A contains character to be listed
RES The character right justified in A is placed in the output
 line of the list file.  If the last character was a CR, the character 
 is inserted before the CR.  This routine is called by the exec
 routines KOUNT1, KOUNT2, etc. to put markers in the list file
 indicating where counters were placed into the object code.
SID the contents of A may be changed.
⊗

↑LSTOUT: PUSH	P,B		;SAVE B
	LDB	B,LPNT		;GET PREV LAST CHAR
	CAIE	B,15		;IS IT A CR
	JRST	.+3		;NO
	DPB	A,LPNT		;YES, WIPE IT OUT
	MOVEI	A,15		;AND PUT CR AFTER IT
	IDPB	A,LPNT		;STORE CHAR
	POP	P,B		;RESTORE B
	POPJ	P,		;RETURN



DSCR LSTOU1 -- Write to list file
CAL PUSHJ P,LSTOU1
PAR Reg A contains character to be listed
 Reg C contains character that the char in A should follow
RES If the last character in the line matches the one in
 C, the character in A is put at the end of the line.  If
 not, the char in A is placed before the last character.
 The necessity for doing this comes from the fact that some
 single character tokens are placed in the listing file before
 they are parsed.
SID Register A may be changed
⊗
↑LSTOU1:  PUSH	P,B		;SAVE B
	LDB	B,LPNT		;GET THE LAST CHAR
	CAMN	B,C		;IS IT THE ONE WE WANT...
	JRST	.+8		;YES, GO STORE CHARACTER
	CAIGE	C,"A"		;IS THE COMPARE CHAR A LETTER
	JRST	.+4		;NO
	ADDI	C,"a"-"A"	;CONVERT TO LOWERCASE
	CAMN	B,C		;IS IT THE RIGHT THING?
	JRST	.+3		;YES, GO STORE CHARACTER AND RETURN
	DPB	A,LPNT		;NO, STORE NEW CHAR
	MOVE	A,B		;THEN OLD CHARACTER
	IDPB	A,LPNT
	POP	P,B		;RESTORE B
	POPJ	P,		;RETURN

BEND SYM
↑KILLST←KILLST

SUBTTL	Generator Data