perm filename SYM[S,AIL]34 blob sn#148081 filedate 1975-03-01 generic text, type T, neo UTF8
COMMENT ⊗   VALID 00037 PAGES VERSION 17-1(37)
RECORD PAGE   DESCRIPTION
 00001 00001
 00005 00002	HISTORY
 00013 00003	SCAN
 00016 00004	BITDATA (SCNWRD -- LISTING CONTROL, ETC.)
 00022 00005	DATA (SCANNER PARSE TOKENS)
 00031 00006	DSCR main SCANNER Dispatch loop
 00042 00007	 ID -- RESET FOR SCAN
 00050 00008	Comment   COMMENT -- throw out everything to next semicolon
 00052 00009	DSCR -- USID
 00059 00010	DSCR -- SCNACT
 00068 00011		PUSH	PNT,PNEXTC-1	STRING NUMBER
 00072 00012	DSCR STRNG, etc.
 00076 00013	 
 00079 00014	DEFCHK:
 00090 00015	DSCR SCNUMB -- number scanner
 00097 00016	Comment 
 00099 00017	Comment  Print the last character, then stack the result
 00103 00018	DSCR CSPEC, SEOL, SEOM, SEOB -- Special handling routines
 00107 00019	Cspec, Seol
 00108 00020	 CALL SPECIAL ROUTINE, BUT FIRST MAKE SURE CHARACTER COUNT IS
 00114 00021	
 00121 00022	 END OF BUFFER CODE.
 00123 00023	Comment  Parameter delimiter or end of message 
 00130 00024	DSCR ADVBUF -- new input buffer routine
 00139 00025	BAIL <
 00142 00026	DSCR --HERE IS THE CREFFINF STUFF (STRANGE PLACE N'EST CE PAS?)
 00149 00027	DSCR HDR, HDROV 
 00157 00028	DSCR ENTERS -- make new symbol entry
 00161 00029	↑ENTERS:	
 00167 00030	 
 00172 00031	
 00173 00032	DSCR ADCINS, CREINT, CONINS
 00177 00033	DSCR SHASH, NHASH -- look up symbol entries in hashed buckets.
 00183 00034	SEMBLK Allocation Routines
 00190 00035	RNGVRB, RNGSTR, etc. -- `Ring' Linkage Routines
 00193 00036	
 00196 00037	 Mark insertion routine for counter routines
 00199 ENDMK
⊗;
COMMENT ⊗HISTORY
AUTHOR,REASON
021  102100000045  ⊗;


COMMENT ⊗
VERSION 17-1(37) 3-1-75 BY RLS CHECK FOR END OF BUFFER IN TENEX ADVBUF (PROB. SHOULD BE ADDED TO DEC ALSO)
VERSION 17-1(36) 2-8-75 BY JFR BAIL SOURCE POINTERS P.6
VERSION 17-1(35) 11-17-74 BY JFR BAIL SOURCE FILE POINTER BUGS P. 6,21
VERSION 17-1(34) 10-16-74 BY JFR FIX BAIL SOURCE FILE COUNTING
VERSION 17-1(33) 10-10-74 BY JFR REVISE WAY BAIL PUTS OUT TEXT FILE POINTERS
VERSION 17-1(32) 9-26-74 BY JFR BAIL INSTALLED 9-19-74.  FIX VERSION, AUTHOR, REASON STUFF
VERSION 17-1(31) 9-15-74 BY HJS BUG #TG# PREVENT PARSE STACK OVERFLOW WHEN SCANNING ACTUAL PARAMETERS TO MACROS 
VERSION 17-1(30) 5-30-74 BY RLS TENEX FIX #SI# BETTER LISTING FORMAT
VERSION 17-1(29) 5-30-74 
VERSION 17-1(28) 5-28-74 BY RHT BUG #SD# NEEDED A FLAG TO DETECT EXTERNAL-INTERNAL CHANGES
VERSION 17-1(27) 4-12-74 BY RHT %BI% ASS RECORD STUFF TO ENTID
VERSION 17-1(26) 3-17-74 BY RLS INSTALL TENEX
VERSION 17-1(25) 3-17-74 
VERSION 17-1(24) 2-5-74 BY HJS BUG #RA# ALLOW TEXT PAST FINAL END OF PROGRAM 
VERSION 17-1(23) 1-29-74 BY HJS BUG #QV# ASSIGNC PROBLEMS
VERSION 17-1(22) 1-25-74 BY RHT BUG #QO# PNAME MAY BE SPLIT BY STRING SPACE EXPANSION
VERSION 17-1(21) 1-11-74 BY JRL CHANGE MACRO EXPANSION LIST CHARACTER
VERSION 17-1(20) 12-14-73 BY RHT BUG #PZ# A KLUGE THAT NO LONGER WORKED FIXED BY NEW DCS KLUGE
VERSION 17-1(19) 12-14-73 
VERSION 17-1(18) 12-7-73 BY JRL REMOVE SPECIAL STANFORD CHARACTERS
VERSION 17-1(17) 11-27-73 BY RLS BUG #PF# AVOID DYING IF SOURCE FILE ENDS IN FF
VERSION 17-1(16) 11-27-73 
VERSION 17-1(15) 11-25-73 BY JRL FEAT %AN% HAVE SOURCE!FILE SWITCHING CHECK ARG AS STRING CONSTANT
VERSION 17-1(14) 11-16-73 BY HJS BUG #PC# OVERWRITNG FIRST LINE IN CREF 
VERSION 17-1(13) 11-10-73 BY KVL MERGE:CORERR
VERSION 17-1(12) 9-24-73 BY HJS BUG #OH# NO CREFFING OF MACRO FORMALS ALLOWED
VERSION 17-1(11) 9-24-73 
VERSION 17-1(10) 9-21-73 BY HJS INHIBIT LISTING IN FALSE PART OF CONDITIONAL COMPILATION 
VERSION 17-1(9) 9-21-73 BY RHT PATCH UP VERSION STUFF
VERSION 17-1(7) 9-21-73 BY HJS MAKE BUG OG FIX RIGHT
VERSION 17-1(6) 9-19-73 BY HJS BUG #OG# SAVE PNAME COUNT BEFORE SGCOL
VERSION 17-1(5) 9-19-73 
VERSION 17-1(4) 9-17-73 BY HJS BUG #OF# MAKE SURE PARSE TOKEN IN AC A WHEN GOING TO STACK
VERSION 17-1(3) 9-17-73 
VERSION 17-1(2) 9-17-73 
VERSION 17-1(1) 8-14-73 BY RHT TURN JRST .CORERR AT GETTOP BACK TO JRST CORERR
VERSION 16-2(48) 7-12-73 BY HJS SAVE CHARACTER COUNT IN CASE GARBAGE COLLECTION HAPPENS DURING MACRO ACTUAL SCANNING
VERSION 16-2(47) 6-20-73 BY HJS IFCR, REDEFINE, EVALDEFINE, AND ASSIGNC IMPLEMENTATION 
VERSION 16-2(46) 6-10-73 BY JRL BUG #MQ# LPNT NOT PROPERLY SAVED FOR BACKUP WHEN SAVCHR=0
VERSION 16-2(45) 6-1-73 BY DCS BUG #MP# KEEP REMCHR HONEST (STRNGC BUG)
VERSION 16-2(44) 3-19-73 BY HJS ALLOW TEMPORARY OVERRIDING OF NULL DELIMITERS MODE
VERSION 16-2(43) 3-13-73 BY JRL REMOVE REFERENCES TO WOM,SLS,GAG,NODIS
VERSION 16-2(42) 3-12-73 BY RHT BUG #LS# OWN THINGS GETTING THE WRONG LEVEL INFO
VERSION 16-2(41) 1-31-73 BY HJS ADD NOEMIT, ACKSAV, AND SBSAV FOR EXPR!TYPE
VERSION 16-2(40) 1-17-73 BY HJS BUG #LC# MACRO FORMALS ARE NOT MACRO REDEFINTION
VERSION 16-2(39) 1-17-73 
VERSION 16-2(38) 12-11-72 BY HJS DISABLE ENDC PARSER SWITCH TRIGGER IN WHILEC, CASEC, FORC, AND FORLC BODIES
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 				;DWNARROW
	LTR 				;ALPHA
	LTR 				;BETA
	RAND				;AND
	RNOT				;NOT
	RIN				;ELEMENTOF
	REPEAT 2,<LTR >			;PI, LAMBDA
	0				;TAB
	XWD SPCL,SEOL		;LF -- END OF LINE
	0				;VTAB
	XWD SPCL,SEOP			;FF -- END OF PAGE
	0				;CARRIAGE RETURN
	RINF				;INFINITY.
	LTR 				;PARTIAL, LEFTHORSESHOE,RGHTHORSESHOE
	REPEAT 2,<LTR >
	RINTER				;INTERSECT
	RUNION				;UNION
	LTR 				;FOREACH
	LTR 				;EXISTS
	RXOR
	RSWAP				;BOTHWAYSARROW
	LTR 				;UNDERLINE ?
	LTR				;RGT ARRW
	RAND				;STANFORD TILDE (AND)
	RNEQ 				;NTEQUAL
	RLEQ				;LTEQUAL
	RGEQ				;GTEQUAL
	REQV				;EQUIVALENCE
	ROR				;OR
	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				; |
	NESTED+RSETC			; RIGHT CURLY BRACKET
	NESTED+RSETC			; RIGHT CURLY BRACKET
; 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)

BAIL<
↑↑BCORDN: 0	;DEBUGGER COORDINATE NUMBER.  RIGHT HALF CONTAINS CURRENT
		;COORDINATE, LEFT HALF IS ZERO IF WE ARE NOT NOW PUTTING OUT
		;COORDINATES TO THE .SM1 FILE, AND NON-ZERO IF WE ARE.
BCRDW1:	0	;SPACE TO SAVE COORD INFO TO BE WRITTEN TO .SM1 FILE, SINCE
BCRDW2:	0	;  LOCATION MUST BE MARKED AT BEGINNING OF STATEMENT, BUT
		;  WE DONT KNOW IF WE WANT A COORD UNTIL THE END OF STATEMENT
>;BAIL

↑↑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
↑↑ENDCTR:  0			; POINTER TO QSTACK INDICATING WHETHER OR NOT ENDC 
				;  SHOULD TRIGGER A PARSER SWITCH (NO IF ONE IS 
				;  SCANNING A WHILEC, CASEC, FORC, OR FORLC BODY)
↑↑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

↑↑NOEMIT:  0			; DON'T EMIT CODE FLAG FOR THE EMITTER
↑↑ACKSAV:  BLOCK 13		; SAVE ACKTAB HERE WHILE EVALUATING EXPR!TYPE
↑↑SBSAV:   BLOCK 13		; SAVE $SBITS CORRESPONDING TO ACKSAV VALUES WHILE 
				;  EVALUATING EXPR!TYPE (AVOIDS HARMFUL SIDE 
				;  EFFECTS OF CODE GENERATORS)
↑↑ADPTSV:  0			; ADEPTH VALUE BEFORE EXPR!TYPE PROCESSING
↑↑PCNTSV:  0			; PCNT VALUE BEFORE EXPR!TYPE PROCESSING
↑↑SDPTSV:  0			; SDEPTH VALUE BEFORE EXPR!TYPE PROCESSING
↑↑RSTDLM:  0			; TEMPORARY OVERRIDING OF NULL DELIMITERS MODE FLAG
↑↑RECSTK:  0			; POINTER TO QSTACK INDICATING WHETHER MACROS SHOULD 
				;  BE EXPANDED IN THE FALSE PART OF CONDITIONAL 
				;  COMPILATION 
↑↑IFCREC:  0			; FLAG INDICATING WHETHER MACROS SHOULD BE EXPANDED IN 
				;  THE FALSE PART OF CONDITIONAL COMPILATION 
NULCNT:	   0			; COUNTER INDICATING THE NUMBER OF ACTUAL PARAMETERS 
				;  THAT HAVE NOT BEEN SPECIFIED AT THE END OF THE LIST OF 
				;  ACTUALS IN A MACRO CALL.  THEY ARE TREATED AS IF THEY 
				;  HAD BEEN THE NULL STRING (AS DONE AT CMU) 
LPTRSV:	   0			; SAVE WORD FOR LISTING BUFFER POINTER SO THAT 
				;  FALSE PART OF CONDITIONAL COMPILATION DOES NOT 
				;  GET LISTED 
↑↑LSTSTK:  0			; POINTER TO QSTACK INDICATING WHETHER OR NOT ONE 
				;  IS IN THE FALSE PART OF CONDITIONAL COMPILATION 
↑↑CNDLST:  0			; FLAG INDICATING IF ONE IS IN THE FALSE PART OF 
				;  CONDITIONAL COMPILATION 
;; #RA#	(1 OF 2) ! 
↑↑EOFCEL:  0			; FLAG INDICATING FINAL END OF PROGRAM SEEN 

BAIL <
↑↑BSRCFC: 0			; BUFFER ADDR,,BLOCK COUNT  FOR SOURCE FILE
↑↑BNSRC:  0			; NUMBER OF SOURCE FILES SEEN
↑↑BSRCFN: 0			; CURRENT SOURCE FILE NUMBER
↑↑BSRCFQ: 0			; QSTACK FOR  REQUIRE  SAVING
↑↑BLSTFC: 0			; WORD COUNT FOR LISTING FILE
↑↑BPPCNT: 0			; PREVIOUS PROGRAM COUNTER
>;BAIL
 
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
;; #RA# (2 OF 2) 
	SKIPE	EOFCEL		; FINAL END OF PROGRAM SEEN? 
	JRST	[TLO TBITS2,EOFOK ; 
		 MOVEM TBITS2,SCNWRD ; 
		 JRST .+1]; 
;; #RA# 
	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
;;#MQ# SET UP SBITS2 FOR BACKING UP LPNT EVEN IF HAVE SAVCHR≠0
	MOVE	SBITS2,LPNT
	MOVEM	SBITS2,LPTRSV	; SAVE IN CASE IN FALSE PART OF COND. COMP. 

	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
	MOVEM	SBITS2,LPTRSV	; SAVE IN CASE IN FALSE PART OF COND. COMP. 
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

BAIL<
↑↑BMKSRC:
	MOVE	TEMP,BAILON
	TRNN	TEMP,BBCRD	;SKIP IF WE WANT COORDS
	 POPJ	P,
	PUSH	P,A
	PUSH	P,B
	PUSH	P,C		;WE ARE IN THE HEART OF THE SCANNER, SO BEWARE

	MOVE	TBITS2,SCNWRD		;PICK UP SCANNER FLAGS
	TRNN	TBITS2,NOLIST		;LISTING IN PROGRESS?
	 JRST	BCRDLS			;YES
;;#%%# JFR 2-8-75 FIX THIS CRUFFT FOR MACROS AND CONDITIONAL COMPILATION
	TLNE	TBITS2,MACIN		;IN A MACRO?
	 JRST	BCRDN2			;YES, UPDATE COUNTERS ONLY, NOT POINTERS
	HRRZ	TEMP,PNEXTC
	HRRZ	SBITS,SRCPNT
	SUBI	TEMP,(SBITS)
	CAIL	TEMP,1
	CAILE	TEMP,200		;SRCPNT IS A WORD EARLY
	 JRST	BCRDN2			;PNEXTC IS OUT IN THE BOONIES
;;#%%# ↑
	MOVE	TEMP,PNEXTC
	MOVEM	TEMP,BPNXTC		;SAVE BYTE POINTER

	HRR	SBITS,BSRCFC		;BLOCK COUNT FOR SOURCE FILE
	HRRZ	A,BPNXTC		;ADDR OF CURRENT WORD IN BUFFER
;;#%%# BY JFR 11-17-74  CORRECT COMPUTATION OF WORD OFFSETS
	HRRZ	B,SRCPNT		;WORD EARLY POINTER
	ADDI	B,1			;CORRECT
;;#%%# ↑
	LDB	C,[POINT 5,BSRCFN,35-0]	;FILE NUMBER
	LDB	D,[POINT 6,BPNXTC,35-30]	;"P" PORTION OF BYTE POINTER
	JRST	BCRDN1
BCRDLS:
NOTENX<
	LDB	SBITS,[POINT 18,BLSTFC,35-7]	;BLOCK COUNT FOR LIST FILE
	HRRZ	A,LPNT			;ADDR OF CURRENT WORD IN BUFFER
	HRRZ	B,LSTBUF		;ADDR OF FIRST WORD
	LDB	D,[POINT 6,LPNT,35-30]	;"P" PORTION OF BYTE POINTER
>;NOTENX
TENX<
	MOVE	A,BLSTFC		; CHAR COUNT FOR LIST FILE
	IDIVI	A,5			;WORD COUNT IN A, REMAINDER IN B
	SUBI	B,5			;BEGIN CONSTRUCTION OF "P" OF BYTE POINTER
	MOVM	D,B
	IMULI	D,7
	ADDI	D,1			;FINISHED
	LDB	SBITS,[POINT 18,A,35-7]	;BLOCK COUNT FOR FILE
	ANDI	A,177			;WORD OFFSET IN A
	SETZ	B,			; FAKE IT FOR BCRND1
>;TENX	
	SETZ	C,			;LIST FILE IS NUMBER 0
	JRST	BCRDN1
BCRDN1:	SUB	A,B			;WORD OFFSET IN BUFFER
	DPB	A,[POINT 7,SBITS,35-18]	;INSERT WORD OFFSET
	DPB	C,[POINT 5,SBITS,35-25]	;INSERT FILE NUMBER
	DPB	D,[POINT 6,SBITS,35-30]	;INSERT "P" POINTER
	MOVEM	SBITS,BCRDW1		;SAVE
BCRDN2:	HRL	SBITS,BCORDN		;COORD NUMBER
				;SEE IF ANYTHING IS IN THE ACS
	MOVSI	TEMP,-20		;LENGTH OF ACKTAB
	MOVE	A,ACKTAB(TEMP)
	JUMPE	A,.+3			;JUMP IF VACANT
	ADDI	A,1
	JUMPN	A,.+3			;JUMP IF NOT PROTECTED, I.E. BUSY
	AOBJN	TEMP,.-4		;LOOP
	TLO	SBITS,400000		;MARK AS ALLSTO

	HRR	SBITS,PCNT
	MOVEM	SBITS,BCRDW2		;SAVE

BXCRD:	POP	P,C
	POP	P,B
	POP	P,A
	POPJ	P,

↑↑BCROUT:			;PUT COORD OUT TO .SM1 FILE IF NECESSARY
	SKIPLE	TEMP,BAILON	;SKIP IF BAIL OFF
	TRNN	TEMP,BBCRD	;SKIP IF WE WANT COORDS
	 POPJ	P,
	SETZM	BPNXTC		;REMEMBER TO MARK SOURCE AT NEXT TOKEN
	MOVE	TEMP,PCNT
	SKIPN	NOEMIT		;NO COORDS FOR EXPR TYPE
	CAMN	TEMP,BPPCNT	;NO SKIP IF PCNT SAME AS BEFORE
	 POPJ	P,
	MOVEM	TEMP,BPPCNT	;UPDATE
	PUSH	P,A
	PUSH	P,B
	PUSH	P,C		;TAKE CARE IN SCANNER
	AOS	A,BCORDN	;INCREMENT COORD COUNT
	TLOE	A,1		;IS CURRENT TABLE OF .SM1 FILE A COORD TABLE?
	 JRST	BCROU1		;YES
	MOVEM	A,BCORDN	;UPDATE
	SETZ	SBITS,
	PUSHJ	P,VALOUT	;END PREVIOUS TABLE OF .SM1 FILE
	MOVEI	SBITS,BAICRD
	PUSHJ	P,VALOUT	;START COORD TABLE
BCROU1:	MOVE	SBITS,BCRDW1
	PUSHJ	P,VALOUT	;FIRST WORD
	MOVE	SBITS,BCRDW2
	PUSHJ	P,VALOUT	;SECOND WORD
	JRST	BXCRD		;THAT'S ALL
>;BAIL
	
CONCHK:
BAIL<	SKIPN	BPNXTC		;MARK SOURCE ONCE PER STATEMENT
	 PUSHJ	P,BMKSRC
>;BAIL
	TLNE	A,LETDG		; LETTER OR NUMBER?
	JRST	CHKNUM		; YES, GO SEE WHICH
BAIL<
	CAIN	B,";"		;TEST FOR END OF STATEMENT
	 PUSHJ	P,BCROUT	;PUT OUT COORD IF STATEMENT GENERATED CODE
>;BAIL
	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
BAIL<
	SKIPN	BPNXTC		;DOES DEBUGGER KNOW WHERE WE ARE?
	 PUSHJ	P,BMKSRC	;NO -- GO MARK PLACE
>;BAIL
	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)
;IF CREFFING, DO IT NOW...
	TLNE	FF,CREFSW	;
	PUSHJ	P,LCREFIT

	 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.
	TLNE	TBITS,CONDIN	; CHECK IF ENDC HAS OCCURRED AS THE END OF A WHILEC,
	JRST	ENDCOK		;  CASEC, FORC, OR FORLC BODY AND IF SO, THEN DO NOT
	HLRZ	TEMP,ENDCTR	;  SWITCH PARSERS.  ENDCTR IS A POINTER TO A QSTACK 
	SKIPE	(TEMP)		;  INDICATING SUCH INFORMATION.  
	JRST	STACK		;
ENDCOK:	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
;; #PC#! OVERWRITING FIRST LINE IN CREF 
	JUMPE	B,COMLUP	; NULL HAS ALREADY BEEN HANDLED 
	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
NOBAIL<
COMLUP:	CAIN	B,";"		;DONE?
	 JRST	 SCANNER		; YES
>;NOBAIL
BAIL<
COMLUP:	CAIE	B,";"		;DONE?
	 JRST	COMILD		; NO
	SETZM	BPNXTC		;YES. MARK SOURCE AT NEXT TOKEN
	JRST	SCANNER
>;BAIL
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:	SKIPN	SWCPRS		; IN FALSE PART OF CONDITIONAL COMPILATION? 
	SKIPN	IFCREC		; YES, SHOULD MACROS BE EXPANDED? 
	JRST	TSTDEF		; YES, GO EXPAND MACROS 
;; #OF# ! MAKE SURE A IS VALID BEFORE GOING OFF TO STACK
	MOVE	A,%ID		
	JRST	STACK		; NO, DON'T EXPAND MACROS OR CHECK TYPES AND RETURN
TSTDEF:	TLNE	TBITS,DEFINE	;NEED TO EXPAND MACRTO?
	JRST	DEFRG		;YES
GOHEQ:	LSTDPB
	PUSHJ	P,TYPDEC
	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>,1; 
	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,CSPEC		; 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,CSPEC		; 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)	; SPECIAL?
	PUSHJ	P,CSPEC		; 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,CSPEC		; 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
	CAMN	TEMP,%STCON	; A SPECIAL DELIMITER DECLARATION?
	SKIPE 	SWBODY		; YES, COULD WE POSSIBLY HAVE SEEN A SPEC DEL DECL.
				;  I.E. DID WE SEE ONE ALREADY?
	JRST	TSLPRN		; NO, GET LEFT PAREN.
	SKIPN	REQDLM		; TRYING TO OVERRIDE NULL DELIMITERS MODE?
	SETOM	RSTDLM		; YES, SET APPROPRIATE FLAGS
	SETOM	REQDLM		;
	SETOM 	SWBODY		; SET SWITCH DELIMITER 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
;;#TG#	9-15-74 HJS RESTORE PARSE STACK POINTER 
PRMLUP:	MOVE	SP,PPSAV	; RESTORE SP SINCE IT POINTS TO THE PARSE STACK 
				;  SINCE OTHERWISE MAY GET OVERFLOW SINCE STACK 
				;  IS CALLED AT THE END OF EACH PARAMETER SCAN 
;;#TG# 
	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 PTR TO 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>
	MOVE	LPSA,DEFRN2	; DETERMINE IF ALL PARAMETERS HAVE BEEN 
	MOVEI	TEMP,0		;  SPECIFIED AND IF NOT FORM NULL'S FOR 
DEFLNK:	HRRZ	LPSA,%RVARB(LPSA);  ALL THOSE LEFT OUT SO THAT ASSIGNC 
	ADDI	TEMP,1		;  WILL WORK PROPERLY 
	JUMPN	LPSA,DEFLNK	;
	MOVE	LPSA,-3(P)	; 
	HLRZ	LPSA,$VAL(LPSA)
	SUB	TEMP,LPSA	; NUMBER OF UNSPECIFIED PARAMETERS
	MOVEM	TEMP,NULCNT	; 
TSTDON:	AOSLE	NULCNT		; ALL PARAMETERS SPECIFIED? 
	JRST	CONACT		; YES, 
	PUSHJ	P,INSET		; SET UP STRING SPACE ENTRY 
	ADDI	C,2		; APPEND 177¬0 TO NULL STRING AND LINK 
	MOVEI	TEMP,177	;  ON VARB AND STRING RINGS 
	IDPB	TEMP,TOPBYTE(USER) ; 
	MOVEI	TEMP,0		; 
	IDPB	TEMP,TOPBYTE(USER) ; 
	PUSHJ	P,UPDCNT	; 
	GETBLK	NEWSYM		; 
	HRROI	TEMP,PNAME+1	; 
	POP	TEMP,$PNAME+1(LPSA) ; 
	POP	TEMP,$PNAME(LPSA) ; 
	MOVE	TEMP,[XWD CNST,STRING] ; 
	MOVEM	TEMP,$TBITS(LPSA) ; 
	PUSHJ	P,RNGSTR	; 
	PUSHJ	P,RNGVRB	; 
	JRST	TSTDON		; 
CONACT:	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
	SETZM	SWBODY		; RESET SWITCH DELIMITER DECLARATION FLAG
	SKIPN	RSTDLM		; RESTORING NULL DELIMITERS MODE?
	JRST	.+4		; NO
	SETZM	RSTDLM		; YES, RESTORE APPROPRIATE FLAGS
	SETZM	REQDLM		;
	JRST	NOPRMS		;
	HRROI	TEMP,LOCMPR+1	; GET RESTORING ADDRESS
	POP	TEMP,CURPED	; RESTORE START DEL.
	POP	TEMP,CURPBG	; RESTORE END DEL.
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

	HLRZ	LPSA,%TLINK(LPSA) ; STORE THE LENGTH OF THE MACRO BODY IN THE LEFT 
	HRLZ	TEMP,$PNAME(LPSA) ;  HALF OF DEFRNG SO THAT WHEN FINISH SCANNING AN
	HRR	TEMP,DEFRN2	;  ACTUAL PARAMETER THERE WILL BE SOME INDICATION OF 
	MOVEM	TEMP,DEFRNG	;  THE MINIMUM AMOUNT OF STRING SPACE NECESSARY FOR
	PUSHJ	P,CONTX2	;  THE SCANNING OF THE REMAINDER OF THE MACRO

; 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
CONTX2:	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,CSPEC		;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 the length of the string up to the start of the ident.
   3. Scan this (possible) param into the constant, no case conversion.
   4. Save the length of the string up to the end of the ident.
   5. Save state of scanner (char, bits), then return PNEXTC to the
      ident within the string const.  Call DSCAN (ident scanner) to con-
      vert and lookup this identifier (some special bits set to avoid
      stacking results, etc.)
   6. 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.
   7. Back TOPBYTE pointer up to the length of step 2, 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.

 Substring operations are used to retrieve the relevant byte
 pointers from the saved lengths, and only when they are really
 needed, to avoid the garbage collect problems with multiple
 saved pointers which plagued past implementations, and made
 the multiple string space implementation impossible.

Be warned (again) that the current setup is the result of several
 (+1) killed bugs  --  each  thought to  be the  last.  No
 guarantees are proferred that no more exist, but chances are
 (even) better than ever.
⊗
DEFCHK:
	TLNE	A,NUMB		;MUST BE A LETTER
	 JRST	 DEPOSIT	; DIGIT OR OTHER NUMBER PART, GO ON
	PUSH	P,C	;save length just before scanning ident
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:	
	PUSH	P,A		;SAVE BITS,
	PUSH	P,B		; CHARACTER, AND CURRENT TOTAL
	PUSH	P,C		; MACRO BODY STRING COUNT
	HRRM	C,PNAME		; END POINTER OVER GC
; P stack is:
;  -3 -- length before ident scanned into string const
;  -2 -- bits for char after ident.
;  -1 -- char after ident.
;   0 -- length after ident scanned into string const
	HRRZ	TBITS,-3(P);use length(id)+5 for string space need
	SUBM	C,TBITS	
	PUSH	P,TBITS	;save id length for remchr update
	ADDI	TBITS,5		;WILL MOVE OUT TO AVOID A PROBLEM
COLNEC:	PUSHJ	P,SGCOL2	;COLLECT IF NECESSARY
; Developing string constant is now at the end of the current
;  string space, with room beyond for the identifier scan.
; P Stack as before, with ident length added to top
	AOS	TOPBYTE(USER)	;IDPB-ILDB GETS INTO LOOP IN DSCAN IF NOT
	EXCH	SP,STPSAV	;save string constant state in preparation for
	MOVSS	POVTAB+6	; identifier rescan (as identifier)
	PUSH	SP,PNEXTC-1	;Save Scanner input state, and PNAME
	PUSH	SP,PNEXTC	; (string constant) state.
	PUSH	SP,PNAME
	PUSH	SP,PNAME+1
	PUSH	SP,PNAME	;Now retrieve (possibly moved) bp to beginning
	PUSH	SP,PNAME+1	; of potential formal name in constant
	PUSH	P,[1]	;PNAME[<before id length> for 1]
	PUSH	P,-5(P)
	JSP	B,SBSTR
	POP	SP,TEMP	;resultant bp
	SUB	SP,X11
	MOVSS	POVTAB+6
	EXCH	SP,STPSAV
	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
	POP	P,TEMP	;fix up REMCHR using saved ident length
	MOVNS	TEMP
	ADDM	TEMP,REMCHR(USER)
	EXCH	SP,STPSAV	;PUT THE SCANNER LOCATION BACK
	POP	SP,PNAME+1	;Restore string constant descriptor
	POP	SP,PNAME
	ADD	SP,X22	;Then use to get one or other pointer back (below)
	PUSH	P,[1]	;Whichever SUBSR is called, it will be [x for 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

	PUSH	P,-4(P)	;We found a param -- retrieve bp to beginning of
	JSP	B,SBSTR	; original param name, clear string space to end
	MOVE	TEMP,(SP)	; of space which DSCAN used
	PUSHJ	P,CLREST
	POP	SP,C		;Now replace param name with 177, param #
	MOVEI	TEMP,177	;(other word of SUBSR result removed at DN below)
	IDPB	TEMP,C
	HRRZ	TEMP,$VAL(LPSA) ;PARAM NUMBER 
	IDPB	TEMP,C
	MOVEM	C,TOPBYTE(USER)	;update end of space
	AOS	C,-3(P)	;length before id scan, +2 for param spec,
	AOJA	C,DN		; yields proper current string const. length

NOPAR:
	PUSH	P,-1(P)	;Was not param, retain (apparent) ident in string,
	JSP	B,SBSTR	; by retrieving bp to end of original scan,
	MOVE	TEMP,(SP)	; clearing space to end of DSCAN scan,
	PUSHJ	P,CLREST	; then restoring TOPBYTE to continue macro body
	POP	SP,TOPBYTE(USER)	; scan
	HRRZ	C,(P)	;Restore length after ident scan
DN:	TLZE	TBITS2,BACKON	;TURN LISTING BACK ON
	TRZ	TBITS2,NOLIST	;YES
	SUB	P,X11	;Toss end of ident length
	POP	P,B	;ident terminator
	POP	P,A	;bits for that terminator
	SUB	P,X11	;Beginning of ident length
	SUB	SP,X11	;count word from whichever subsr was done
	POP	SP,PNEXTC	;Finally, restore Scanner input
	POP	SP,PNEXTC-1
	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

CLREST:	MOVEI	C,0		; BP OF START OF ID IN TEMP
LINLUP:	CAMN	TEMP,TOPBYTE(USER) ;clear space from temp's bp to
	POPJ	P,		;current top
	IDPB	C,TEMP
	JRST	LINLUP


SBSTR:	AOS	(P)		;ADAPT TO SAIL CONVENTIONS
	MOVE	C,LPSA		;SAVE
EXTERN	SUBSR
	PUSHJ	P,SUBSR
	MOVE	LPSA,C		;RESTORE
	MOVE	USER,GOGTAB
	JRST	(B)

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
	SKIPN	SWCPRS		; SWITCHING PARSERS OK?  
	JRST	NOSWCH		; NO, 
;; #QV (1 OF 2) WILL NOW USE ENDMAC TO ADD 177-0 TO ASSIGNC BODIES
	TLNE	FF,PRMSCN	; SCANNING ACTUALS? 
	JRST	ENDACT		; YES, APPEND 177¬0 TO MACRO ACTUALS 
	JRST	NOMACW		; NO, 
;; #QV#
NOSWCH:	SKIPN	IFCREC		; EXPAND MACROS IN FALSE PART OF COND COMP? 
	TLNN	FF,PRMSCN	; YES, SCANNING MACRO ACTUALS? 
	JRST	[PUSHJ P,UPDCNT	; KEEP REMCHR HONEST 
		 JRST	STCTYP]	; DON'T ENTER STRING 
ENDACT: ADDI	C,2		; FOR ACTUAL PARAMETERS APPEND 177-0 TO END OF 
	MOVEI	TEMP,177	;  STRING, GET A SEMBLK AND PLACE IT ONLY ON 
	IDPB	TEMP,TOPBYTE(USER) ;  THE STRING RING.  ALL ACTUAL PARAMETERS TO 
	MOVEI	TEMP,0		;  A MACRO ARE LINKED ON THE VARB RING.  THUS WHEN 
	IDPB	TEMP,TOPBYTE(USER) ;  A MACRO CALL IS FINISHED ALL THAT REMAINS TO 
	PUSHJ	P,UPDCNT	;  DO IS TO KILLST ALONG THE VARB RING WHOSE HEAD 
	GETBLK	NEWSYM		;  IS POINTED TO BY DEFRNG.  
	HRROI	TEMP,PNAME+1	;
	POP	TEMP,$PNAME+1(LPSA) ;
	POP	TEMP,$PNAME(LPSA) ;
	MOVE	TEMP,[XWD CNST,STRING] ; MAKE SEMBLK OF ACTUAL PARAMETER LOOK LIKE 
	MOVEM	TEMP,$TBITS(LPSA) ;  A STRING CONSTANT SEMBLK EXCEPT FOR THE FACT 
	PUSHJ	P,RNGSTR	;  THAT IT IS NOT LINKED ON THE STRING CONSTANT RING
;; #QV (2 OF 2) ! REMOVED TEST ON ASGFLG HERE
	PUSHJ	P,RNGVRB	;
	MOVE	LPSA,NEWSYM	;
	MOVE	A,%STCON	;
	JRST	STACK		;
NOMACW:	PUSHJ	P,UPDCNT	; UPDATE PNAME CNT, REMCHR, COLLECT IF NECESSARY
	PUSH	P,BITS		;
	PUSHJ	P,STRINS	; CHECK IF STRING HAS ALREADY BEEN ENTERED IN THE 
	POP	P,BITS		;  SYMBOL TABLE AND IF NOT THEN ENTER IT
	MOVE	LPSA,PNT	;
	MOVEM	LPSA,NEWSYM	;
STCTYP:	MOVE	A,%STCON	;
	JRST	STACK		;
DSCR SCNUMB -- number scanner
DES Scan a number -- keep both REAL (floating) 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

	TLNN	A,ATSIGN	; AT SIGN? 
	JRST	SCNM1		; NO, GET REST OF NUMBER 
	SKIPN	SWCPRS		; YES, IN FALSE PART OF CONDITIONAL COMPILATION? 
	JRST	ATOUT		; YES, TREAT AT SIGN AS A PARSE TOKEN 
	TLNN	TBITS2,INLIN	; NO, IN-LINE CODE? 
	JRST	SCNM1		; NO, GET REST OF NUMBER 

ATOUT:	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:	SKIPN	SWCPRS		; INSIDE FALSE PART OF CONDITIONAL COMPILATION? 
	JRST	NUMTYP		; YES, DON'T ENTER THE NUMBER 
	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
	SKIPG	NEWSYM		;WAS IT THERE ALREADY?
	PUSHJ	 P,ENTERS	; NO, BUT IT IS NOW
	POP	P,BITS		;GET OLD BITS BACK
	MOVE	LPSA,NEWSYM	;SET UP FOR STACKING
NUMTYP:	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
	SKIPN	CNDLST		; IN FALSE PART OF COND. COMP.? 
	POPJ	P,		; NO, RETURN 
	MOVE	SBITS2,LPTRSV	; YES, DO NOT LIST - I.E. RESTORE LPNT 
	MOVEM	SBITS2,LPNT	; 
	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

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

; 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
BAIL<
	SKIPL	BAILON
	MOVE	TBITS,BCORDN	;IF DEBUGGER IN USE, PRINT COORDINATE INSTEAD
>;BAIL
	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

NOTENX <
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
BAIL<
	ADDM	PNT2,BLSTFC	;WORD COUNT FOR LIST FILE
>;BAIL
	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!
>;NOTENX
TENX<
	PUSH	P,C
	PUSH	P,B
	HRRZ	2,LPNT
	HRRZ	3,LSTBUF
	SUBI	3,1(2)		;-#WRDS, INCLUDING CURRENT WORD
	IMULI	3,5		;-#CHRS, INCL. EXTRAS IN CURRENT WRD
	SKIPA	2,LPNT
	IBP	2
	TLNE	2,760000	;LAST CHAR IN WORD COUNTED?
	 AOJA	3,.-2		;UN-COUNT AN EXTRA CHAR
BAIL<
	ADDM	3,BLSTFC	; UPDATE COUNT
>;BAIL
	EXCH	1,LISJFN
	HRRO	2,LSTBUF
	JSYS	SOUT
	EXCH	1,LISJFN
	HRRZ	3,LSTBUF	;NOW ZERO LSTBUF, JUST IN CASE.
	SETZM	(3)
	HRLI	3,(3)
	ADDI	3,1
	BLT	3,(2)
	POP	P,B
	POP	P,C
>;TENX
	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:
NOTENX <
	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
>;NOTENX
TENX <
	MOVEI 	C,ENDSRC-BGNSWA+1	;SIZE OF SAVE AREA
>;TENX
	PUSHJ	P,CORGET		;GET ONE
	 ERR	 <NO CORE AVAILABLE FOR FILE SWITCH>
	HRR	TEMP,B			;BLT WORD
NOTENX <
	HRLI	TEMP,SRCCDB
	BLT	TEMP,ENDSRC-SRCCDB(B)
>;NOTENX
TENX <
	HRLI	TEMP,BGNSWA
	BLT	TEMP,ENDSRC-BGNSWA(B)
>;TENX
	HRRZM	B,SWTLNK		;SAVE PTR TO SAVE AREA
	TLO	TBITS2,INSWT		;WE'RE SCANNING SWITCHED-TO FILE
	MOVEM	TBITS2,SCNWRD
	SETZM	LSTCHR			;ALWAYS DO IT
	SETZM	SAVCHR
NOTENX <
	SETZM	SAVTYI
	SETZM	EOF
	SETZM	EOL
	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
>;NOTENX
	AOS	TEMP,LININD		;HOW FAR IN TO SPACE ON TTY
	CAILE	TEMP,MAXIND		;TOO FAR?
	SOS	LININD			;NOT REALLY
NOTENX <
	SETOM	TYICORE			;WILL SCAN FROM STRING
>;NOTENX
	MOVE	TEMP,GENLEF+2
;; %AN% CHECK TO BE SURE STRING CONSTANT, SINCE PRODUCTIONS NO LONGER CHECK
	MOVE	TEMP,$TBITS(TEMP)
	TRNN	TEMP,STRING	
	ERR	<SOURCE!FILE NAME MUST BE STRING>
	MOVE	TEMP,GENLEF+2
;; %AN%
	HRROI	TEMP,$PNAME+1(TEMP)	;GET STRING TO BE SCANNED
	POP	TEMP,PNAME+1
	POP	TEMP,PNAME		;PUT ER THERE
BAIL<
	SKIPN	SRCDLY			;SWITCHING SOURCE INPUT?
	JRST	BNSRCD			;NO
	QPUSH	BSRCFQ,BSRCFC		;YES. SAVE BUFF. ADDR,,BLOCK COUNT
	QPUSH	BSRCFQ,BSRCFN		;SAVE FILE NUMBER
;;#%%# ! BY JFR 11-17-74  ZERO THE BLOCK COUNT FOR THE NEW FILE
	SETZM	BSRCFC
BNSRCD:
>;BAIL
	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:	
;; #PF# SUPPLY CORRECT NUMBER OF THINGS ON STACK IN CASE ADVBUG DOESN'T RETURN
	PUSH	P,C
	PUSHJ	P,ADVBUF
	POP	P,C
;; #PF#
	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
;; #PC#! OVERWRITING FIRST LINE OF CREF 
	MOVEI	B,0		;PRETEND A NULL CHARACTER 
	MOVEI	A,0		;BITS FOR CR
	POPJ	P,
Comment ⊗ Parameter delimiter or end of message ⊗

EOM:	ILDB	B,PNEXTC	;CHECK WHICH
	SKIPN	ASGFLG		;ASSIGNC PARAMETER NUMBER? 
	JRST	CONEOM		;NO, 
	MOVE	LPSA,B		;RETURN THE PARAMETER NUMBER IN THE 
	MOVE	A,%NUMCON	; SEMANTIC STACK 
	SUB	P,X11		; TO OVERRIDE THE PUSHJ HERE 
	JRST	STACK		;
CONEOM:	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,DEFRNG	; SAVE DEFRNG WHICH CONTAINS THE LENGTH OF THE 
	PUSH	PNT,PNEXTC-1	;  ACTUAL PARAMETER TO BE  EXPANDED.  THIS WILL
				;  ENSURE THAT WHEN A RETURN IS MADE FROM
				;  EXPANDING THE ACTUAL THERE WILL BE ENOUGH
				;  STRING SPACE FOR THE REST OF THE MACRO.  
	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?
;; #OG# ! MAKE SURE PNAME COUNT VALID IN CASE OF REAL GARBAGE COLLECT
	PUSHJ	P,CSPEC		; 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
	HLRZ	TBITS,LPSA	; GET LENGTH OF MACRO TO WHICH ONE IS RETURNING AND
	PUSHJ	P,SGCOL2	;  INSURE ENOUGH ROOM IN STRING SPACE FOR IT 
	EXCH	LPSA,DEFRNG	; GET OLD DEFRNG VALUE AND IF DIFFERENT FROM CURRENT
	CAMN	LPSA,DEFRNG	;  VALUE THEN ONE IS DONE WITH THE MACRO AND THUS 
	JRST	DDUN		;  RING OF ACTUAL PARAMETERS (POINTED TO BY DEFRNG) 
	HRRZS	LPSA		;  IS REMOVED FROM THE STRING RING.  NOTE THAT 
	PUSHJ	P,KILLST	;  KILLST EXPECTS LPSA WITH ZERO IN THE LEFT HALF.  	

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 ptr to 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.
⊗
NOTENX <
ADVBUF:	
	XCT	INSRC		;ADVANCE BUFFER
	XCT	TSTSRC		;ANY ERRORS?
	 ERR	 <I-O ERROR ON SOURCE DEVICE>,1
	XCT	EOFSRC		;TO ENDFL ON EOF
	JRST	ENDFL
BAIL <
	AOS	BSRCFC		; ADD ONE TO SOURCE FILE BLOCK COUNT
>;BAIL
	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		;PTR TO 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,
>;NOTENX
TENX <
ADVBUF:	PUSH	P,1
	PUSH	P,2
	PUSH	P,3
	SKIPE	TTYSRC		;CONTROLLING TERMINAL SOURCE DEVICE?
	  JRST	ADVTTY		;YES
	SKIPN	TNXBND		;ANYTHING IN THE BUFFER?
	  JRST	ADVBF1		;NO DONT CHECK
	HRRZ	1,PNEXTC 	;LOOK AT ADDR
ADVBF2:	CAML	1,TNXBND	;BEYOND BUFFER?
	  JRST	ADVBF1		;YES, CHECK EOF, GET MORE IF THERE
	SKIPN	1(1)		;0 WORD?
	  AOJA	1,ADVBF2	;YES KEEP LOOKING FOR INFO IN THE BUFFER
	HRLI	1,010700
	PUSH	P,1		;SAVE NEW BP
	PUSHJ	P,SGCHK		;CHECK GARBAGE COLLECTION
	POP	P,PNT		;BP TO PNT
	POP	P,3		;RESTORE
	POP	P,2
	POP	P,1
	MOVEM	PNT,PNEXTC
	MOVE	TEMP,1(PNT)	;WHICH IS NON-ZERO BECAUSE WE JUST CHECKED
	POPJ	P,

ADVBF1:	HRRZ	1,SRCJFN
	JSYS	GTSTS
	TLNE	2,1000		;EOF?
	 JRST	ENDFL		;YES
BAIL <
	AOS	BSRCFC		;ADD ONE TO SOURCE FILE BLOCK COUNT
>;BAIL
	HRR	2,SRCPNT
	ADDI	2,1		;SRCPNT IS A 7-BIT POINTER THAT IS A WORD EARLY
	HRLI	2,444400	;36-BIT POINTER.
	MOVNI	3,SRCBSZ	;SIZE OF SRC BUF IN WRDS, MINUS EOB NULL
	JSYS	SIN		;SRCJFN OPEN FOR 36BIT INPUT
	HRRZM	2,TNXBND	;SAVE END OF BUFFER ADDRESS FOR CHECKS ABOVE
	SETZM	1(2)		;EOB NULL.
ADVDUN:	PUSHJ	P,SGCHK
	POP	P,3
	POP	P,2
	POP	P,1
	MOVE	PNT,SRCPNT	;RESET PNT TO CURRENT BP,
	MOVEM	PNT,PNEXTC	;FIX THIS GUY TOO.
	MOVE	TEMP,1(PNT)	;GET THE FIRST WORD IN TEMP
	POPJ	P,

; CHECK FOR STRING SPACE FULL, GC IF SO

SGCHK:
	MOVEI	TBITS,SRCBSZ*5	;TENEX BUFFER SIZE
	MOVE	TEMP,REMCHR(USER)	;REMAINING CHARS
	ADD 	TEMP,TBITS
	SKIPL	TEMP			;ENOUGH?
	   JRST	SGCOL		;NOT ENUF STRNG SPACE FOR A FULL BUFFER
	POPJ	P,		;NOW THERE IS

DSCR ADVTTY
	Since the boys at BBN have seen fit to not provide a standard
line editor into their system, we must resort to using some runtimes
to handle input in the case that the source is a TTY.  We confine the
problem to the case that the source is the controlling teletype, as
indicated by the SRCTTY (set in CC), and use INTTY.  INTTY at IMSSS
uses the IMSSS PSTIN jsys, otherwise a simulation of same.
⊗;

ADVTTY:
EXTERNAL .SKIP.
EXTERNAL INTTY
	EXCH	SP,STPSAV
	PUSHJ	P,INTTY		;GET A STRING USING THE PSTIN JSYS
	POP	SP,A		;BYTE POINTER
	POP	SP,C		;XWD -1, LENGTH -- STACKS ARE NOW OK
	EXCH	SP,STPSAV
	MOVE	B,.SKIP.
	CAIN	B,32		;CONTROL-Z TO INDIATE EOF
	  JRST	ENDFL		;YES END OF FILE
	MOVE	B,SRCPNT
	HRRZ	C,C	
	MOVNS	C		;NUMBER OF CHARS TO TRANSFER
	JSYS	SIN		;USE SIN TO TRANSFER STRING
	MOVEI	C,15
	IDPB	C,B
	MOVEI	C,12
	IDPB	C,B
	SETZ	C,
	REPEAT 5, <IDPB	C,B>	;PUT NULLS THERE
	SETZM	(B)		;BE SURE TO INDICATE EOF
	SETZM	1(B)		
	JRST	ADVDUN		;AND FINISH UP, ABOVE

ENDFL:
	HRRZ	A,SRCJFN
	JSYS	CLOSF
	  JFCL
	HRRZ	A,SRCJFN
	JSYS	RLJFN
	  JFCL
	POP	P,3
	POP	P,2
	POP	P,1

>;TENX
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:
BAIL <
	QPOP	BSRCFQ,BSRCFN	;RETRIEVE PREVIOUS FILE NUMBER
	QPOP	BSRCFQ,BSRCFC	;RETRIEVE BUFF.ADDR,,BLOCK COUNT
>;BAIL
	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,
BAIL <
↑↑UPDCNT:	HRRM	C,PNAME			;UPDATE PNAME
>;BAIL
NOBAIL<
UPDCNT:	HRRM	C,PNAME			;UPDATE PNAME
>;NOBAIL
	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
	MOVSS	POVTAB+6	;calling seq. to .SONTP may oflow
	PUSH	P,TBITS		;PASS TO STRGC THIS WAY
	PUSHJ	P,STRGC	;COLLECT STRING SPACE
;;#QO# -- BE SURE PNAME STAYS TOGETHER 1-25-74 RHT
	EXTERN 	.SONTP
	PUSH	SP,PNAME
	PUSH	SP,PNAME+1
	PUSH	P,[0]
	PUSHJ	P,.SONTP
	POP	SP,PNAME+1
	POP	SP,PNAME
;;#QO#
	EXCH	SP,STPSAV	;GET IT BACK
	MOVSS	POVTAB+6
	POPJ	P,		; NO, GO AHEAD
NOTENX <

?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,
>;NOTENX
TENX <
?CHROUT: EXCH	TBITS,2
	EXCH	1,LISJFN
	JSYS	BOUT
	EXCH	1,LISJFN
	EXCH	TBITS,2
	POPJ	P,
>;TENX
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.
	SKIPE	CNDLST		; IN FALSE PART OF CONDITIONAL COMPILATION? 
	POPJ	P,		; YES, DO NOT CREF 
	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.
;;#MF#! 5-1-73 DCS (1 OF 2) AC B NEEDED IN CALLER OF LCREFIT
	PUSH	P,B
	MOVEI	B,CHROUT	;OUTPUT ROUTINE FOR SAME --
	PUSHJ	P,FRNP1		;  FRNP1 IS IN SEOL ABOVE.
;;#MF#! (2 OF 2) SAVE, RESTORE B
	POP	P,B
	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,30		;UNDERLINE
	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
NOTENX <
GONEF:	SOSG	LSTCNT
	PUSHJ	P,LSTDO
	IDPB	A,LSTPNT
	POPJ	P,
>;NOTENX
TENX <
GONEF:	EXCH	1,2
	EXCH	1,LISJFN
	JSYS	BOUT
	EXCH	1,LISJFN
	EXCH	1,2
	POPJ	P,
>;TENX

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

NOTENX<
↑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
	MOVE	TEMP,[ASCII /00001/]
	MOVEM	TEMP,ASCLIN	;SO DOES THE SUFF WHICH APPEARS ON LISTING
;;#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
	CAMLE	TEMP,LSTCNT	;IS THERE
	PUSHJ	P,LSTDO		;NOW THERE IS
	MOVEI	D,14
	IDPB	D,LSTPNT
	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
	POP	P,D
	POPJ	P,
>;NOTENX

TENX<
↑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
	PUUO	3,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

	SETZM	BKR		;LET NULL BREAK ON TENEX
	SKIPG	LISJFN		;SHOULD SKIP IF LISTING
	  JRST	NOHDR
	PUSH	P,A
	PUSH	P,B
	MOVE	A,LISJFN
	HRRZI	B,14
	JSYS	BOUT
	MOVE	TEMP,A		;10X ASCFIL TAKES JFN'S IN TEMP
	POP	P,B
	POP	P,A
	MOVE	A,[POINT 7,TITLIN]
	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
;;#SI# 5-30-74 RLS BETTER LISTING FORMAT
	MOVE	A,[POINT 7,[ASCIZ/

/],-1]
;;#SI#
	PUSHJ	P,ASCFIL

NOHDR:	POP	P,D
	POPJ	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,

>;TENX

ZERODATA(TITLE LINE)
TITLIN:	BLOCK	=28		;SHOULD BE BIG ENOUGH FOR TITLE LINE
ENDDATA

;  MAKT -- PREPARE A TITLE LINE

NOTENX <
↑MAKT:	
;; RHT & RS ! 2 DONT BOTHER MAKING HEADER IF NOT LISTING
	TLNN	FF,LISTNG	;DOING LISTING HERE
	POPJ	P,		;NOPE
	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,
>;NOTENX
TENX <
↑MAKT:	TLNN	FF,LISTNG	;WANT A LISTING?
	  POPJ	P,		;NO
	HRROI	2,TITLIN	;DEST. DESIGN. FOR ALL THAT FOLLOWS
	HRROI	1,[ASCIZ /SAIL  /]
	SETZ	3,
	JSYS	SIN
	HRRZI	3,IPROC
	MOVE	1,$PNAME+1(3)	;BP FOR PROGRAM NAME
	HRRZ	3,$PNAME(3)	;CHAR COUNT
	MOVNS	3
	JSYS	SIN
	MOVEI	1," "
	IDPB	1,2
	IDPB	1,2
	MOVE	1,2		;DEST. DESIG (UPDATED) INTO 1.
	HRRZ	2,SRCJFN
	SETZ	3,		
	JSYS	JFNS		
	MOVEI	2," "
	IDPB	2,1		
	IDPB	2,1
	SETO	2,
	HRLZI	3,336321	
	JSYS	ODTIM		
	MOVEI	2," "
	IDPB	2,1
	IDPB	2,1
	SETZ	2,		
	IDPB	2,1
	POPJ	P,
>;TENX

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 (ptr to instr to fetch right bucket in HPNT).
  Link to current VARB structure via %RVARB, to STRRNG via
  %RSTR for STRINGC collector. Return ptr to Semantics in  NEWSYM
  (replaces ptr to 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, ptr to 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.

"QRCTYP" -- Record class id. ... if  not zero, put into lhs of $acno

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

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)
;; #LC# (1-17-73) HJS MACRO FORMAL,NOT MACRO REDEFINITION
	TLNE	TBITS,FORMAL	;
	JRST	NODEFN		;MACRO FORMAL, NOT MACRO REDEFINTION
;; #LC#
	TLNN	TEMP,DEFINE	; WAS PREVIOUS DEFINITION ALSO A MACRO? 
	SKIPN	REDEFN		; YES, MACRO REDEFINITION? 
	JRST	NODEFN		; NO, GO CHECK LEVELS 
	 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)
REC <
	SKIPE	C,QRCTYP	;RECORD CLASS ID SPECIFIED
	HRLM	C,$ACNO(LPSA)
>;REC
	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
;;#SD#	ADD A FLAG IF OLD IS EXTERNAL & NEW IS INTERNAL
	MOVE	C,$TBITS(LPSA)	; COULD HAVE USED THE HAIR ABOVE, BUT ...
	SETOM	IEFLAG		;SET THE FLAG
	TLNE	C,EXTRNL	;RESET IT IF OLD NOT EXTERNAL
	TLNN	TBITS,INTRNL	;OR NEW NOT INTERNAL
	SETZM	IEFLAG		;
;;#SD#

	MOVEM	TBITS,$TBITS(LPSA) ;STORE NEW
REC <
	SKIPE	C,QRCTYP	;RECORD CLASS ID SPECIFIED
	HRLM	C,$ACNO(LPSA)
>;REC
NOPROG:	PUSHJ	P,URGVRB	;REMOVE FROM VARB RING
	PUSHJ	P,RNGVRB	;PUT BACK ON THE END
	LEFT	,%TLINK,LPSERR	;PTR TO 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)

;CREFFING FOR THE WORLD.
	TLNE	FF,CREFSW
;;#OH# -- HJS 9-24-73 DO NOT CREF MACRO FORMALS 
	PUSHJ	P,[ TLNE TBITS,DEFINE ; DO NOT CREF MACRO FORMALS
		    TLNN TBITS,FORMAL
		    JRST ECREFIT
		    POPJ P,] 
;;#OH#

	TRNN	TBITS,PROCED	;PROCEDURE?
	JRST	NOPROC		;NO
	MOVE	PNT,LPSA
	GETBLK			;SECOND PROCEDURE BLOCK
	HRLM	LPSA,%TLINK(PNT) ;%TLINK PNTS TO 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
REC <
	SKIPE	C,QRCTYP	;RECORD CLASS ID SPECIFIED
	HRLM	C,$ACNO(LPSA)
>;REC
	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
;;#LS# RHT 2! 3-12-73 WAS GETTING TO FILLEV WITH NOD ZERO C FOR OWN&EXTERNAL
	JRST	[SETZM C	;NO WORRY, ID IS AT LEVEL 0
		JRST FILLEV]
	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
	HRRZM	C,$SBITS(LPSA)	;LEVEL OF DEFINITION

; LINK TO BUCKET, STRING RING

	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

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


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

	TLNE	TBITS,CNST	;NOT ON VARB IF CONST
	 POPJ	 P,		; DONE

	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
	JRST	RNGCST		;PUT ON CONSTANT RING.


; NUMERIC CONSTANT

ENNUMB:
	GETBLK	NEWSYM
	HRROI	TEMP,DBLVAL	;STORE STUFF
	POP	TEMP,$VAL+1(LPSA)
	POP	TEMP,$VAL(LPSA)
	POP	TEMP,$TBITS(LPSA)
	JSP	A,LNK		;LINK TO BUCKET LIST
	PUSHJ	P,RNGCNM	;PUT ON CONSTANT RING
	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] ; SAVE REGISTERS 1-12
	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] ; RESTORE REGISTERS 1-12
	BLT	TEMP,SBITS2
	SUB	P,X22		; ADJUST STACK POINTER TO GET RID OF ROUTINE NAMES 
	HRR	PNT,NEWSYM	;DO NOT CLOBBER LEFT HALF INCASE
				; ADCONS ARE BEING MADE.
	JRST	GETAD		; LOAD SBITS AND TBITS

↑STRINS: PUSHJ	P,STRNS1	; 
	AOS	$VAL2(PNT)	; INCREMENT REFERENCE COUNT 
	POPJ	P,		; 

STRNS1:	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 -- ptr to 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
	 CORERR <RAN OUT OF CORE AT GETTOP>
	MOVEM	B,LPSBOT		;SET LIMITS ANEW
	MOVEM	B,LPSTOP
	ADDM	C,LPSTOP

NEERET:	
	MOVE	TEMP,B			;PTR TO 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 PNT TO  PREV
	MOVSS	TEMP
	HLRM	TEMP,BLKLEN+1(TEMP)	;UPDATE FOR'RD IN LAST TO PNT 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