perm filename SYM[CMU,AIL] blob
sn#083808 filedate 1974-01-27 generic text, type T, neo UTF8
00100 COMMENT ⊗ VALID 00037 PAGES VERSION 17-1(22)
00200 RECORD PAGE DESCRIPTION
00300 00001 00001
00400 00005 00002 HISTORY
00500 00011 00003 SCAN
00600 00014 00004 BITDATA (SCNWRD -- LISTING CONTROL, ETC.)
00700 00020 00005 DATA (SCANNER PARSE TOKENS)
00800 00027 00006 DSCR main SCANNER Dispatch loop
00900 00032 00007 ID -- RESET FOR SCAN
01000 00040 00008 Comment COMMENT -- throw out everything to next semicolon
01100 00041 00009 DSCR -- USID
01200 00048 00010 DSCR -- SCNACT
01300 00057 00011 PUSH PNT,PNEXTC-1 STRING NUMBER
01400 00061 00012 DSCR STRNG, etc.
01500 00065 00013
01600 00070 00014 DEFCHK:
01700 00081 00015 DSCR SCNUMB -- number scanner
01800 00088 00016 Comment
01900 00090 00017 Comment Print the last character, then stack the result
02000 00094 00018 DSCR CSPEC, SEOL, SEOM, SEOB -- Special handling routines
02100 00098 00019 Cspec, Seol
02200 00099 00020 CALL SPECIAL ROUTINE, BUT FIRST MAKE SURE CHARACTER COUNT IS
02300 00104 00021
02400 00110 00022 END OF BUFFER CODE.
02500 00112 00023 Comment Parameter delimiter or end of message
02600 00119 00024 DSCR ADVBUF -- new input buffer routine
02700 00123 00025 UPDCNT: HRRM C,PNAME UPDATE PNAME
02800 00125 00026 DSCR --HERE IS THE CREFFINF STUFF (STRANGE PLACE N'EST CE PAS?)
02900 00131 00027 DSCR HDR, HDROV
03000 00136 00028 DSCR ENTERS -- make new symbol entry
03100 00140 00029 ↑ENTERS:
03200 00146 00030
03300 00151 00031
03400 00152 00032 DSCR ADCINS, CREINT, CONINS
03500 00156 00033 DSCR SHASH, NHASH -- look up symbol entries in hashed buckets.
03600 00162 00034 SEMBLK Allocation Routines
03700 00169 00035 RNGVRB, RNGSTR, etc. -- `Ring' Linkage Routines
03800 00172 00036
03900 00175 00037 Mark insertion routine for counter routines
04000 00178 ENDMK
04100 ⊗;
00100 COMMENT ⊗HISTORY
00200 AUTHOR,REASON
00300 021 102100000026 ⊗;
00400
00500
00600 COMMENT ⊗
00700 VERSION 17-1(22) 1-25-74 BY RHT BUG #QO# PNAME MAY BE SPLIT BY STRING SPACE EXPANSION
00800 VERSION 17-1(21) 1-11-74 BY JRL CHANGE MACRO EXPANSION LIST CHARACTER
00900 VERSION 17-1(20) 12-14-73 BY RHT BUG #PZ# A KLUGE THAT NO LONGER WORKED FIXED BY NEW DCS KLUGE
01000 VERSION 17-1(19) 12-14-73
01100 VERSION 17-1(18) 12-7-73 BY JRL REMOVE SPECIAL STANFORD CHARACTERS
01200 VERSION 17-1(17) 11-27-73 BY RLS BUG #PF# AVOID DYING IF SOURCE FILE ENDS IN FF
01300 VERSION 17-1(16) 11-27-73
01400 VERSION 17-1(15) 11-25-73 BY JRL FEAT %AN% HAVE SOURCE!FILE SWITCHING CHECK ARG AS STRING CONSTANT
01500 VERSION 17-1(14) 11-16-73 BY HJS BUG #PC# OVERWRITNG FIRST LINE IN CREF
01600 VERSION 17-1(13) 11-10-73 BY KVL MERGE:CORERR
01700 VERSION 17-1(12) 9-24-73 BY HJS BUG #OH# NO CREFFING OF MACRO FORMALS ALLOWED
01800 VERSION 17-1(11) 9-24-73
01900 VERSION 17-1(10) 9-21-73 BY HJS INHIBIT LISTING IN FALSE PART OF CONDITIONAL COMPILATION
02000 VERSION 17-1(9) 9-21-73 BY RHT PATCH UP VERSION STUFF
02100 VERSION 17-1(7) 9-21-73 BY HJS MAKE BUG OG FIX RIGHT
02200 VERSION 17-1(6) 9-19-73 BY HJS BUG #OG# SAVE PNAME COUNT BEFORE SGCOL
02300 VERSION 17-1(5) 9-19-73
02400 VERSION 17-1(4) 9-17-73 BY HJS BUG #OF# MAKE SURE PARSE TOKEN IN AC A WHEN GOING TO STACK
02500 VERSION 17-1(3) 9-17-73
02600 VERSION 17-1(2) 9-17-73
02700 VERSION 17-1(1) 8-14-73 BY RHT TURN JRST .CORERR AT GETTOP BACK TO JRST CORERR
02800 VERSION 16-2(48) 7-12-73 BY HJS SAVE CHARACTER COUNT IN CASE GARBAGE COLLECTION HAPPENS DURING MACRO ACTUAL SCANNING
02900 VERSION 16-2(47) 6-20-73 BY HJS IFCR, REDEFINE, EVALDEFINE, AND ASSIGNC IMPLEMENTATION
03000 VERSION 16-2(46) 6-10-73 BY JRL BUG #MQ# LPNT NOT PROPERLY SAVED FOR BACKUP WHEN SAVCHR=0
03100 VERSION 16-2(45) 6-1-73 BY DCS BUG #MP# KEEP REMCHR HONEST (STRNGC BUG)
03200 VERSION 16-2(44) 3-19-73 BY HJS ALLOW TEMPORARY OVERRIDING OF NULL DELIMITERS MODE
03300 VERSION 16-2(43) 3-13-73 BY JRL REMOVE REFERENCES TO WOM,SLS,GAG,NODIS
03400 VERSION 16-2(42) 3-12-73 BY RHT BUG #LS# OWN THINGS GETTING THE WRONG LEVEL INFO
03500 VERSION 16-2(41) 1-31-73 BY HJS ADD NOEMIT, ACKSAV, AND SBSAV FOR EXPR!TYPE
03600 VERSION 16-2(40) 1-17-73 BY HJS BUG #LC# MACRO FORMALS ARE NOT MACRO REDEFINTION
03700 VERSION 16-2(39) 1-17-73
03800 VERSION 16-2(38) 12-11-72 BY HJS DISABLE ENDC PARSER SWITCH TRIGGER IN WHILEC, CASEC, FORC, AND FORLC BODIES
03900 VERSION 16-2(37) 12-2-72 BY HJS SAVE BITS DURING CONDITIONAL COMPILATION AND MACRO DEFINITIONS (CBTSTK AND DBTSTK)
04000 VERSION 16-2(36) 11-20-72 BY JRL FIX SUGG BY R. SMITH AT CHKPRC
04100 VERSION 16-2(35) 11-19-72 BY HJS BUG #JZ# CORRECTION - MACRO REDEFINITION AND RESERVED WORD REDEFINITION IN ENTERS
04200 VERSION 16-2(34) 11-15-72 BY HJS INSERT DEFDLM QSTACK FOR DEFLUK BIT OF FF FOR COMPILE-TIME MACROS WITHIN MACROS
04300 VERSION 16-2(33) 11-5-72 BY DCS BUG #JZ# CHANGE MACRO SCOPE RULES
04400 VERSION 16-2(32) 11-3-72 BY DCS SIMILARLY, ALLOW ALL EXTERNALS TO OVERRIDE
04500 VERSION 16-2(31) 11-2-72 BY DCS BUG #JX# ALLOW INTRNL PROC TO OVERRIDE EXTRNL ONE.
04600 VERSION 16-2(30) 10-24-72 BY HJS EMIT ERR MSG FOR UNINIT MACRO VAR USE
04700 VERSION 16-2(29) 7-5-72 BY DCS BUG #IF# FIX SOME GOERGE BUGS
04800 VERSION 15-6(18-28) 7-5-72
04900 VERSION 15-6(17) 3-10-72 BY DCS REPLACE RING,ULINK MACRO WITH VARIOUS ROUTINES
05000 VERSION 15-6(8-16) 3-9-72
05100 VERSION 15-6(7) 2-21-72 BY HJS THE BRAVE NEW PARSER WORLD
05200 VERSION 15-2(6) 2-18-72 BY DCS BUG #GP# CHECK OLD FORMALS AGAINST NEW FORMALS
05300 VERSION 15-2(5) 2-5-72 BY DCS BUG #GJ# ADD LSTON LIST-CONTROL STUFF
05400 VERSION 15-2(4) 2-5-72 BY DCS BUG #GI# REMOVE TOPSTR
05500 VERSION 15-2(3) 2-1-72 BY DCS BUG #GE# LPSBOT FROM USER TABLE TO COMPILER DATA
05600 VERSION 15-2(2) 12-22-71 BY DCS BUG #FT# PROVIDE LINE NUMBER IF NOT SOS FILE
05700 VERSION 15-2(1) 12-2-71 BY DCS INSTALL VERSION NUMBER
05800
05900 ⊗;
00100 SUBTTL SCAN
00200 LSTON (SYM)
00300 BEGIN SYM
00400
00500 DSCR SCANNER -- get next "ATOM" from source file
00600 CAL PUSHJ from PARSE (or recursively)
00700 PAR PNEXTC is bp to next input char (from file or macro)
00800 SAVCHR, if non-zero, is a scan-ahead char which should
00900 be considered first.
01000 File variables, Listing variables used by I/O part.
01100 Define stack, variables, macro semantics used when
01200 recurring into macros
01300
01400 RES The ATOM will be either:
01500
01600 1. An operator or other character atom, in which case
01700 the Parse token representing it will be placed in the
01800 parse stack, a 0 in the generator stack (null entry).
01900
02000 2. A reserved word, in which case the Parse token will be
02100 placed on the parse stack from the word's symbol
02200 entry, and again a null semantic entry will be stacked.
02300
02400 3. An IDENTIFIER, in which case the Parse token for the appro-
02500 iate class of IDs will appear on the parse stack, the
02600 Semantics for the symbol on the generator stack. If the
02700 symbol is undefined, a 0 is represents null Semantics.
02800
02900 4. A STRING or numeric constant. These entities are ENTERed
03000 in their respective symbol tables if previously
03100 undefined, and the stacks are set up as above.
03200
03300
03400 In all cases, the semantic entry will be repeated in the cell
03500 NEWSYM. In those cases where a hash was made, the
03600 MOVE or MOVS instr to fetch the list on which the symbol
03700 appears (or will appear after ENTERy) is located in
03800 the cell HPNT. For string constants or identifiers, the
03900 string identifier is left in PNAME, PNAME+1. For numeric
04000 arguments, the value is left in SCNVAL. DBLVAL is zeroed
04100 in these cases.
04200
04300 SID SCANNER uses temporary ACs indiscriminately, so look out for it.
04400 Many variables are changed as a result of calling SCANNER.
04500 ⊗
00100 BITDATA (SCNWRD -- LISTING CONTROL, ETC.)
00200
00300 Comment ⊗ SCAN table -- good bits that make the whole thing work ⊗
00400
00500 ↑↑LSTEXP←←400000 ;ON IF "<"-">" PAIRS TO BE PRINTED
00600 ↑↑MACEXP←←200000 ;EXPAND MACRO TEXTS
00700 ↑↑MACLST←←100000 ;LIST MACRO NAMES BEFORE EXPANSION
00800 ↑↑LINESO←← 40000 ;ON IF LINE NUMBERS SHOULD BE PRINTED
00900 ↑↑PCOUT ←← 20000 ;ON IF PCNT SHOULD BE PRINTED
01000 ↑↑CREFIT←← 10000 ;ON IF A CREF S HAPPENING
01100 ↑↑MACIN ←← 4000 ;ON IF IN A MACRO EXPANSION
01200 ↑↑EOFOK ←← 2000 ;ON IF CAN GET EOF WITHOUT FATALITY
01300 ↑↑BACKON←← 1000 ;ON IF LISTING BACK ON AFTER PARAM RESCAN
01400 ↑↑LOKPRM←← 400 ;ON IF LOOKING FOR POSSIBLE MACRO PARAM
01500 ↑↑RDYPRM←← 200 ;GETTING READY FOR MACRO PARAM (RANSCN)
01600 ↑↑INLIN ←← 100 ;TREAT @ AS DELIMITER IN IN-LINE CODE
01700 ↑↑INSWT ←← 40 ;WE'RE SCANNING A SWITCHED-TO SOURCE FILE
01800 ↑NOLIST←← 1 ;ON IN RH IF NO LISTING HAPPENING NOW
01900
02000 BITDATA (SCANNER TABLE)
02100
02200 SPCL ←←400000 ;NOT A LETTER OR DIGIT
02300 ATSIGN←← 20000 ;@ -- REAL EXPONENT COMING
02400 AOSSOS←← 20000 ;BIT DIFFERENTIATING BETWEEN AOS AND SOS FOR NESTING
02500 ; DELIMITERS COUNT
02600 DOT ←← 10000 ;. -- DECIMAL POINT
02700 NUMB ←← 4000 ;NUMBER OR NUMBER PART (ONE OF ABOVE TWO)
02800 DIG ←← 2000 ;0 THRU 9
02900 LETDG ←← 1000 ;REQUIRES SPECIAL TREATMENT
03000 QUOTE ←← 400 ;" -- STRING CONSTANT DELIMITER
03100 ↑NEST ←← 200 ; NESTABLE CHARACTER
03200 ↑LNEST ←← 100 ; LEFT NESTED CHARACTER
03300 QUOCTE←← 40 ;' -- OCTAL NUMBER COMING
03400
03500 ; BITS FOR NUMBER SCANNER
03600
03700 INTOV ←←200000 ;INTEGER OVERFLOW
03800 REALOV←←100000 ;REAL OVERFLOW
03900 EXPNEG←← 40000 ;NEGATIVE EXPONENT
04000 NUMNST ←←3 ; NUMBER OF NESTABLE CHARACTERS
04100 RPAROF ←←2 ; RIGHT PAREN OFFSET FOR LOCNST ENSTRY
04200 ↑NUMCHA ←←200 ; NUMBER OF CHARACTERS
04300 ↑DELNUM ←←4 ; NUMBER OF DELIMITERS AS INPUT TO REQ. DEL.
04400
04500
04600 TABCONDATA (SCANNER CHARACTER TABLE)
04700
04800 DEFINE IGL <XWD SPCL,IGLCHR>
04900 DEFINE OPER <.-SCNTBL>
05000 DEFINE LTR <XWD LETDG,.-SCNTBL>
05100 DEFINE NESTED <<XWD NEST,0>>
05200 DEFINE LNESTD <<XWD NEST+LNEST,0>>
05300
05400 ↑SCNTBL:
05500 XWD SPCL,SEOB ;0 -- END OF BUFFER
05600 LTR ;DWNARROW
05700 LTR ;ALPHA
05800 LTR ;BETA
05900 RAND ;AND
06000 RNOT ;NOT
06100 RIN ;ELEMENTOF
06200 REPEAT 2,<LTR > ;PI, LAMBDA
06300 0 ;TAB
06400 XWD SPCL,SEOL ;LF -- END OF LINE
06500 0 ;VTAB
06600 XWD SPCL,SEOP ;FF -- END OF PAGE
06700 0 ;CARRIAGE RETURN
06800 RINF ;INFINITY.
06900 LTR ;PARTIAL, LEFTHORSESHOE,RGHTHORSESHOE
07000 REPEAT 2,<LTR >
07100 RINTER ;INTERSECT
07200 RUNION ;UNION
07300 LTR ;FOREACH
07400 LTR ;EXISTS
07500 RXOR
07600 RSWAP ;BOTHWAYSARROW
07700 LTR ;UNDERLINE ?
07800 LTR ;RGT ARRW
07900 RAND ;STANFORD TILDE (AND)
08000 RNEQ ;NTEQUAL
08100 RLEQ ;LTEQUAL
08200 RGEQ ;GTEQUAL
08300 REQV ;EQUIVALENCE
08400 ROR ;OR
08500 0 ;SPACE
08600 XWD LETDG,30 ;! -- SAME AS UNDERLINE.
08700 XWD QUOTE,.-SCNTBL ; "
08800 LTR ;#
08900 LTR ;$
09000 TPRC ; %
09100 TANDD ;&
09200 XWD LETDG+NUMB+QUOCTE,.-SCNTBL ; '
09300 LNESTD+TLPRN ; (
09400 NESTED+TRPRN ; )
09500 TTIMS ;*
09600 TPLUS ;+
09700 TCOMA ;,
09800 TMINUS ;-
09900 XWD LETDG+NUMB+DOT,.-SCNTBL ; .
10000 TSLSH ; /
10100 REPEAT 12,<XWD LETDG+NUMB+DIG,.-SCNTBL> ;DIGITS
10200 TCOL ; :
10300 TSEMI ; ;
10400 TLES ; <
10500 TEQU ; =
10600 TGRE ; >
10700 TQUES ;?
10800 XWD LETDG+NUMB+ATSIGN,.-SCNTBL ; @
10900 REPEAT =26,<LTR> ;UPPER CASE LETTERS
11000 LNESTD+TLBR ; [
11100 LTR ; TILDE
11200 NESTED+TRBR ; ]
11300 TUPRW ;↑
11400 TLARW ;←
11500 RASSOC ;`
11600 REPEAT =26,<LTR-40> ;LOWER CASE LETTERS
11700 LNESTD+RSETO ; {
11800 TVERT ; |
11900 NESTED+RSETC ; RIGHT CURLY BRACKET
12000 NESTED+RSETC ; RIGHT CURLY BRACKET
12100 ; 175 AND 176 WILL BOTH BE CURLY BRACKETS FOR A WHILE.
12200 XWD SPCL,EOM ;177 -- END MACRO OR PARAM
12300 ENDSCN←.
00100 DATA (SCANNER PARSE TOKENS)
00200
00300 COMMENT ⊗
00400 These variables provide symbolic access to the PARSE token
00500 numbers for several delimiter characters -- they are used in
00600 those cases where the SCANNER or some EXEC needs to examine
00700 a value directly
00800 ⊗
00900 %ATS: TINDR ;BITS FOR @ DELIMITER IN INLINE(SEE SCNUMB)
01000 %COMMENT: RCOMME+1B0
01100 ↑↑%ID: TI
01200 %NUMCON: TICN ;ARITHMETIC CONSTANT.
01300 %SEMICOL: TSEMI
01400 ↑↑%STCON:TSTC ;STRING CONSTANT.
01500
01600 ZERODATA (SCANNER VARIABLES)
01700
01800 ↑↑DEFRN2: 0 ;TEMP RING-VARIABLE WHILE SCANNING MACRO ACTUAL PARAMS
01900
02000 ;FLTVAL -- collect floating point equiv while scanning number
02100 ?FLTVAL: 0
02200
02300 COMMENT ⊗
02400 HPNT, HSPNT -- When the hashing routines (SHASH, NHASH) locate the
02500 right bucket pointer in the appropriate bucket Semblk, they create
02600 a [HRR LPSA,addr] or [HLR LPSA,addr] instruction which will fetch
02700 this pointer, and put it into HPNT -- also leaving it in LPSA. They
02800 then execute the instruction to begin their lookup phases. ENTERS
02900 again uses this pointer when adding a new Semblk to a bucket -- first
03000 as is, to fetch the old pointer, then modified to HRRM or HRLM, to
03100 update the bucket.
03200 HSPNT is the saved HPNT value for the last string constant scanned.
03300 The "string constant as comment" EXEC uses it to remove the constant
03400 from the bucket (provided, of course, that it hasn't also been used
03500 as a string constant).
03600 ⊗
03700 ↑HPNT: 0
03800
03900 ↑HSPNT: 0
04000
04100 ↑↑LOCMBD: BLOCK 2 ; MACRO BODY DELIMITERS BLOCK
04200 ↑↑LOCMPR: BLOCK 2 ; MACRO PARAMETER DELIMITERS BLOCK
04300 BAKDLM: 0 ; A FLAG WHICH IS SET TO -1 IF DLMSTG IS ON
04400 ; (I.E. ONE WANTS A DELIMITED MACRO BODY)
04500 ; AND QUOTES ARE USED INSTEAD BECAUSE A
04600 ; REQUIRE NULL DELIMITERS STATEMENT WAS NOT
04700 ; USED.
04800 ↑↑CURMBG: 0 ; CURRENT MACRO BODY BEGIN DELIMITER
04900 ↑↑CURMED: 0 ; CURRENT MACRO BODY END DELIMITER
05000 ↑↑CURPBG: 0 ; CURRENT PARAMETER BEGIN DELIMITER
05100 ↑↑CURPED: 0 ; CURRENT PARAMETER END DELIMITER
05200 ↑↑DELSTK: 0 ; DELIMITER "BLOCK-STRUCTURE" STACK
05300 ↑↑LOKDLM: 0 ; DLMSTG (LOOKING FOR DELIMITERS FLAG) QSTACK
05400 ↑↑DEFDLM: 0 ; DEFLUK (SCANNING A MACRO BODY OR LOOKING FOR
05500 ; ACTUAL PARAMETERS) QSTACK
05600 ↑↑CBTSTK: 0 ; POINTER TO QSTACK FOR SAVING BITS WHILE SCANNING
05700 ; CONDITIONAL COMPILATION EXPRESSIONS
05800 ↑↑DBTSTK: 0 ; POINTER TO QSTACK FOR SAVING BITS WHILE SCANNING
05900 ; MACRO DEFINITIONS
06000 ↑↑ENDCTR: 0 ; POINTER TO QSTACK INDICATING WHETHER OR NOT ENDC
06100 ; SHOULD TRIGGER A PARSER SWITCH (NO IF ONE IS
06200 ; SCANNING A WHILEC, CASEC, FORC, OR FORLC BODY)
06300 ↑↑REQDLM: 0 ; REQUIRE DELIMITER STATEMENT SEEN FLAG
06400 ↑↑SWBODY: 0 ; SPECIAL DELIMITER DEFINITION SEEN
06500 ↑↑BNSTCN: 0 ; NESTED DELIMITER COUNT
06600 ↑↑LOCNST: BLOCK NUMNST ; NESTABLE CHARACTERS BLOCK
06700 ↑↑NSTABL: BLOCK NUMCHA ; NESTABLE CHARACTERS ADDRESS INDEX BLOCK
06800
06900 ↑↑NOEMIT: 0 ; DON'T EMIT CODE FLAG FOR THE EMITTER
07000 ↑↑ACKSAV: BLOCK 13 ; SAVE ACKTAB HERE WHILE EVALUATING EXPR!TYPE
07100 ↑↑SBSAV: BLOCK 13 ; SAVE $SBITS CORRESPONDING TO ACKSAV VALUES WHILE
07200 ; EVALUATING EXPR!TYPE (AVOIDS HARMFUL SIDE
07300 ; EFFECTS OF CODE GENERATORS)
07400 ↑↑ADPTSV: 0 ; ADEPTH VALUE BEFORE EXPR!TYPE PROCESSING
07500 ↑↑PCNTSV: 0 ; PCNT VALUE BEFORE EXPR!TYPE PROCESSING
07600 ↑↑SDPTSV: 0 ; SDEPTH VALUE BEFORE EXPR!TYPE PROCESSING
07700 ↑↑RSTDLM: 0 ; TEMPORARY OVERRIDING OF NULL DELIMITERS MODE FLAG
07800 ↑↑RECSTK: 0 ; POINTER TO QSTACK INDICATING WHETHER MACROS SHOULD
07900 ; BE EXPANDED IN THE FALSE PART OF CONDITIONAL
08000 ; COMPILATION
08100 ↑↑IFCREC: 0 ; FLAG INDICATING WHETHER MACROS SHOULD BE EXPANDED IN
08200 ; THE FALSE PART OF CONDITIONAL COMPILATION
08300 NULCNT: 0 ; COUNTER INDICATING THE NUMBER OF ACTUAL PARAMETERS
08400 ; THAT HAVE NOT BEEN SPECIFIED AT THE END OF THE LIST OF
08500 ; ACTUALS IN A MACRO CALL. THEY ARE TREATED AS IF THEY
08600 ; HAD BEEN THE NULL STRING (AS DONE AT CMU)
08700 LPTRSV: 0 ; SAVE WORD FOR LISTING BUFFER POINTER SO THAT
08800 ; FALSE PART OF CONDITIONAL COMPILATION DOES NOT
08900 ; GET LISTED
09000 ↑↑LSTSTK: 0 ; POINTER TO QSTACK INDICATING WHETHER OR NOT ONE
09100 ; IS IN THE FALSE PART OF CONDITIONAL COMPILATION
09200 ↑↑CNDLST: 0 ; FLAG INDICATING IF ONE IS IN THE FALSE PART OF
09300 ; CONDITIONAL COMPILATION
09400
09500 ENDDATA
09600
09700 DSCR LSTDPB
09800 ⊗
09900
10000 DEFINE LSTDPB < ;OUTPUT CHAR TO LISTING FILE IF REQD
10100 TRNN TBITS2,NOLIST ;IS LISTING HAPPENING, BABY?
10200 IDPB B,LPNT ;YES, DO THE REQUIRED THING
10300 >
00100 DSCR main SCANNER Dispatch loop
00200 RES gets first char from SAVCHR or PNEXTC, dispatches to
00300 routine to handle what it found (IDENT, STRING, DELIM, etc.)
00400 ⊗
00500 ↑SCANNER:
00600 MOVE TBITS2,SCNWRD ; SET UP SCANNER PARAMS
00700 TLZE FF,BAKSCN ;IS SCANNER BACK ONE CHARACTER ??
00800 JRST GOAGAIN ; DO IT.
00900 MOVE USER,GOGTAB ;USER DATA TABLE ADDR FOR STRING STUFF
01000 TLNE TBITS2,INLIN ;SPECIAL START!CODE FEATURE?
01100 SETZM PNAME ;YES, ASSURE NO PNAME USED
01200 ;;#MQ# SET UP SBITS2 FOR BACKING UP LPNT EVEN IF HAVE SAVCHR≠0
01300 MOVE SBITS2,LPNT
01400 MOVEM SBITS2,LPTRSV ; SAVE IN CASE IN FALSE PART OF COND. COMP.
01500
01600 MOVEI C,0 ;WILL COUNT CHARS FOR IDENTS
01700 SKIPE B,SAVCHR ;IS ANYTHING LEFT OVER?
01800 JRST SPCHAR ;YES, DISPATCH AS FIRST CHAR
01900
02000 TLNN FF,PRMSCN ;SCANNING MACRO PARAMETERS?
02100 JRST DISPT ; NO
02200 TRNA ;SKIP IDPB
02300
02400 IDPB B,LPNT ;TO LISTING FILE
02500 DSPRM: ILDB B,PNEXTC ;SKIP IGNORABLE CHARACTERS
02600 SKIPGE A,SCNTBL(B) ;ANYTHING SPECIAL REQUIRED?
02700 PUSHJ P,(A) ;YES, DO IT
02800 JUMPE A,DSPRM-1(TBITS2) ;MAYBE LIST, GET NEXT IGNORABLE
02900
03000 DSPR1: TLO FF,PRMXXX ;SET SPECIAL PARAM SCANNING BIT
03100 TLNE A,QUOTE ;DOES HE WANT COMPLETE FREEDOM?
03200 JRST STRLST ; YES, GIVE IT TO HIM (FIRST LIST `"')
03300 PUSHJ P,INSET ;NO, SPECIAL MODE -- "," OR ")" WILL BREAK
03400 JRST BAKSTR ;AROUND QUOTE DELETION
03500
03600 IDPB B,LPNT ;TO LIST FILE
03700 DISPT: ILDB B,PNEXTC ;GET FIRST CHAR
03800 SKIPGE A,SCNTBL(B) ;GET GOOD BITS, CHECK SPECIAL
03900 PUSHJ P,(A) ;SPECIAL, HANDLE IT
04000 JUMPE A,DISPT-1(TBITS2) ;BLANKS AND OTHER IGNORABLES
04100 MOVE SBITS2,LPNT ;SAVE IN CASE BACKUP MUST HAPPEN
04200 MOVEM SBITS2,LPTRSV ; SAVE IN CASE IN FALSE PART OF COND. COMP.
04300 STRLST: LSTDPB ;TO LISTING FILE IF REQD
04400
04500 SPCHAR: SETZM SAVCHR ;NOTHING LEFT OVER YET
04600 SETZM LSTCHR
04700 JUMPL B,[TLZN TBITS2,EOFOK ;OK FOR EOF HERE?
04800 ERR <FATAL END OF SOURCE FILE> ;NO
04900 MOVE A,%EOFILE ;YES, RETURN `EOF'
05000 JRST CHAROUT] ;NULL SEMANTICS
05100 SKIPN A,SCNTBL(B) ;GET GOOD BITS (DON'T DISPATCH AGAIN!)
05200 JRST DISPT ; IGNORABLE, FIND ONE THAT ISN'T
05300 SKIPE DLMSTG ; LOOKING FOR SPECIALLY DELIMITED STRING?
05400 CAME B,CURMBG ; POSSIBLY, MACRO BODY BEGIN DELIMITER?
05500 JRST CONCHK ; GO DO A NORMAL SCAN
05600 SETZM BNSTCN ; SET DELIMITER NEST COUNT TO ZERO
05700 JRST STRNG ; GET MACRO BODY
05800 CONCHK: TLNE A,LETDG ; LETTER OR NUMBER?
05900 JRST CHKNUM ; YES, GO SEE WHICH
06000 TLNN A,QUOTE ;STRING CONSTANT?
06100 JRST CHAROUT ; NO, OPERATOR, OUTPUT ID, NULL SEMANTICS
06200 SKIPN DLMSTG ; HAS A QUOTE BEEN USED TO DELIMIT A MACRO
06300 ; BODY WHILE IN REQUIRE DELIMITERS MODE?
06400 JRST STRNG ; NO, SCAN A STRING CONSTANT IN NORMAL MODE.
06500 SETZM DLMSTG ; YES, TURN OFF DLMSTG FLAG AND TURN ON
06600 SETOM BAKDLM ; BAKDLM FLAG SO THAT WHEN SCANNING THE
06700 JRST STRNG ; MACRO BODY A QUOTE WILL BREAK THE SCAN.
06800
06900 CHKNUM: TLNE A,NUMB ;NUMBER PART?
07000 JRST SCNUMB ; YES, SCAN NUMBER
07100
00100 ; ID -- RESET FOR SCAN
00200
00300 DSCAN: PUSHJ P,INSET ;CLEAR PNAMES, COUNT, ALIGN TO FW
00400 MOVE TBITS2,SCNWRD ;MAKE SURE THE BITS ARE RIGHT
00500 TLO TBITS2,EOFOK ;EOF CAN END THE WORLD WITHOUT KILLING IT
00600 MOVEI C,1 ;ACCOUNT FOR FIRST CHARACTER
00700 TRNA
00800 IDPB B,LPNT ;TO LISTING FILE
00900 IDSCAN: IDPB A,TOPBYTE(USER) ;STORE CONVERTED CHAR
01000 ILDB B,PNEXTC ; GET NEXT CHARACTER
01100 SKIPGE A,SCNTBL(B) ;GET GOOD BITS, CHECK SPECIAL
01200 PUSHJ P,CSPEC ;SPECIAL, DO SOMETHING
01300 TLNE A,LETDG ;DONE WITH ID?
01400 AOJA C,IDSCAN-1(TBITS2) ;NO, GO GET MORE.
01500
01600 Comment ⊗ Now the symbol is in string space, pointed to
01700 by the string descriptor in PNAME, etc. Store the
01800 count, make the lookup, set up the results ⊗
01900
02000 CAIE B,12 ;IF LF, ALREADY HANDLED, LEAVE SAVCHR 0
02100 MOVEM B,SAVCHR ;SAVE THE BREAK BITS (0 IF BLANK OR CR BROKE)
02200 MOVEM B,LSTCHR ;ALSO HERE ANY TIME
02300 TLZ TBITS2,EOFOK ;DONE WITH THIS MODE
02400
02500 PUSHJ P,UPDCNT ;UPDATE PNAME CNT, REMCHR CNT, COLLECT IF NECC.
02600 MOVE LPSA,SYMTAB ;TRY TO FIND IT
02700 PUSH P,B ;SAVE FOR LATER
02800 PUSHJ P,SHASH ;LIKE SO
02900 POP P,B ;GET IT BACK
03000 MOVEM TBITS2,SCNWRD ;SAVE ANY CHANGES
03100 TLNE TBITS2,LOKPRM ;STACK IT?
03200 POPJ P, ; NO, IN STRING CONSTANT MODE
03300
03400 ; GET RELEVANT DATA TO STACKS
03500
03600 MOVE A,%ID ;IT IS AN IDENTIFIER
03700 SKIPG LPSA,NEWSYM ;IF IT IS UNDEFINED,
03800 JRST LSTACK ; PUSH TO STACKS
03900
04000 MOVE TBITS,$TBITS(LPSA)
04100 ;IF CREFFING, DO IT NOW...
04200 TLNE FF,CREFSW ;
04300 PUSHJ P,LCREFIT
04400
04500 JUMPGE TBITS,USID ; NO, USER ID
04600 LSTDPB
04700 MOVE A,TBITS ;RESULTANT PL-ID
04800 MOVEI LPSA,0 ;MAKE NULL SEMANTICS
04900 CAMN A,%COMMENT ; COMMENT?
05000 JRST CHKSAV ; YES, GO PROCESS IT
05100 TLNE TBITS,CONRES ; PARSER SWITCHING RESERVED WORD?
05200 SKIPN SWCPRS ; YES, NEED TO SWITCH PARSERS?
05300 JRST STACK ; NO, RETURN RESERVED WORD
05400 TLNE TBITS,DEFINT ; PARSER INTERRUPT (I.E. NO SWITCHING)?
05500 JRST[SKIPE NODFSW ; DEFER DEFINE HANDLING FOR BLOCK EXECUTION?
05600 JRST STACK ; YES, RETURN RESERVED WORD
05700 MOVE TEMP,SCNNO ; YES, SAVE NUMBER OF SCANS REMAINING IN LEFT HALF
05800 MOVE B,PCSAV ; OF TOP OF PRODUCTION STACK, UNPACK $TBITS ENTRY
05900 HRLM TEMP,(B) ; OF THE RESERVED WORD TO GET AN INDEX OF ADDRESS
06000 JRST CONDAD] ; TO PUSHJ TO, AND SET SCNNO TO ONE.
06100 TLNE TBITS,CONDIN ; CHECK IF ENDC HAS OCCURRED AS THE END OF A WHILEC,
06200 JRST ENDCOK ; CASEC, FORC, OR FORLC BODY AND IF SO, THEN DO NOT
06300 HLRZ TEMP,ENDCTR ; SWITCH PARSERS. ENDCTR IS A POINTER TO A QSTACK
06400 SKIPE (TEMP) ; INDICATING SUCH INFORMATION.
06500 JRST STACK ;
06600 ENDCOK: SKIPE PRSCON ; DETERMINE WHICH PARSER ONE IS CURRENTLY IN AND
06700 SKIPA TEMP,[CGPSAV-1] ; GET THE ADDRESS TO SAVE ITS PARSER DESCRIPTOR.
06800 MOVEI TEMP,SGPSAV-1 ; SAVE SEMANTIC STACK POINTER, PARSE STACK POINTER,
06900 PUSH TEMP,GPSAV ; NUMBER OF SCANS REMAINING IN LEFT HALF OF TOP OF
07000 PUSH TEMP,PPSAV ; PRODUCTION STACK, PRODUCTION STACK POINTER,
07100 MOVE SP,SCNNO ; CURRENT SCNWRD, AND A POINTER TO THE SCNWRD
07200 MOVE B,PCSAV ;
07300 HRLM SP,(B) ; STACK.
07400 PUSH TEMP,PCSAV ;
07500 MOVE B,SCWSV ;
07600 MOVEM TBITS2,(B) ; SAVE SCNWRD
07700 PUSH TEMP,SCWSV ;
07800 SKIPE PRSCON ; DETERMINE WHICH PARSER IS TO BE RESUMED AND GET
07900 SKIPA TEMP,[XWD -1,SSCWSV] ; THE ADDRESS OF ITS PARSER DESCRIPTOR.
08000 HRROI TEMP,CSCWSV ;
08100 POP TEMP,B ; RESTORE SCNWRD STACK POINTER
08200 TLNE TBITS,CONDIN ; IF ONE IS SWITCHING PARSERS VIA A PUSHJ INSTEAD OF
08300 JRST[TLZ TBITS2,INLIN ; PROPER SCANNING OF INLINE STARTCODE. COMPENSATE
08400 TRO TBITS2,NOLIST ; FOR NOT POPPING TEMP.
08500 PUSH B,TBITS2 ;
08600 JRST .+2] ;
08700 MOVE TBITS2,(B) ; RESTORE SCNWRD AND TBITS2
08800 MOVEM B,SCWSV ;
08900 MOVEM TBITS2,SCNWRD ;
09000 MOVEM SBITS2,LPNT ; DON'T LIST PARSER SWITCH TRIGGERING RESERVED WORDS
09100 POP TEMP,B ; RESTORE CONTROL STACK POINTER
09200 POP TEMP,SP ; RESTORE PARSE STACK POINTER. MUST BE IN AC AS
09300 MOVEM SP,PPSAV ; WELL AS IN MEMORY.
09400 POP TEMP,GPSAV ; RESTORE SEMANTIC STACK POINTER
09500 SETCMM PRSCON ; COMPLEMENT PARSER IN CONTROL FLAG
09600 MOVEI C,1001 ; ASSUME A RESUME TYPE SWITCH
09700 TLNN TBITS,CONDIN ; RESUME TYPE SWITCH?
09800 JRST SWTPRE ; YES
09900 CONDAD: HLRZ C,TBITS ; CONDAD IS CALLED WITH THE $TBITS ENTRY
10000 TRZ C,RES+CONBTS ; OF A PARSER INTERRUPT RESERVED WORD IN
10100 LSH C,-IF0SHF ; TBITS. IT INSERTS THE ADDRESS OF THE
10200 MOVEI C,PRODGO(C) ; PRODUCTION WHICH ONE IS TO EXECUTE NEXT
10300 PUSH B,C ; IN THE PRODUCTION CONTROL STACK. TBITS
10400 MOVEI C,4001 ; IS UNPACKED TO GET AN INDEX TO A TABLE
10500 ; STARTING AT PRODG0 (BITS 6-8). SET
10600 ; REMAINING NUMBER OF CALLS TO SCANNER TO
10700 ; ONE SO THAT THE PARSER WILL NOT SCAN
10800 ; AGAIN AND SET A BIT TO DO A PUSHJ.
10900 SWTPRE: MOVEM B,PCSAV ; RESTORE CONTROL STACK POINTER IN CORE
11000 MOVEM C,SCNNO ; SET REMAINING NUMBER OF CALLS TO SCANNER
11100 JRST STACK ; GO STACK
11200
00100 Comment ⊗ COMMENT -- throw out everything to next semicolon
00200 ⊗
00300
00400 CHKSAV: MOVE B,SAVCHR ;BE SURE SAVCHR IS NOT ";"
00500 SETZM SAVCHR
00600 SETZM LSTCHR
00700 ;; #PC#! OVERWRITING FIRST LINE IN CREF
00800 JUMPE B,COMLUP ; NULL HAS ALREADY BEEN HANDLED
00900 SKIPGE A,SCNTBL(B) ;GET BITS, CHECK SPECIAL
01000 PUSHJ P,(A) ;SPECIAL, GET PAST PROBLEM
01100 JRST COMLUP ;GET THEM ALL
01200
01300 IDPB B,LPNT ;TO LISTING FILE
01400 COMLUP: CAIN B,";" ;DONE?
01500 JRST SCANNER ; YES
01600 COMILD: ILDB B,PNEXTC ;GET NEXT CHAR
01700 SKIPGE A,SCNTBL(B) ;USUAL
01800 PUSHJ P,(A)
01900 JRST COMLUP-1(TBITS2) ;GO PUT AWAY, GET ANOTHER
00100 DSCR -- USID
00200 DES An identifier has been found. If it is a macro name, go
00300 expand it. Otherwise call TYPDEC routine to provide the
00400 proper parse token for this identifier (differentiates
00500 ARRAYS from PROCEDURES from STRINGS from ....
00600 SEE TYPDEC in GEN, for providing correct parse token.
00700 ⊗
00800
00900 USID: SKIPN SWCPRS ; IN FALSE PART OF CONDITIONAL COMPILATION?
01000 SKIPN IFCREC ; YES, SHOULD MACROS BE EXPANDED?
01100 JRST TSTDEF ; YES, GO EXPAND MACROS
01200 ;; #OF# ! MAKE SURE A IS VALID BEFORE GOING OFF TO STACK
01300 MOVE A,%ID
01400 JRST STACK ; NO, DON'T EXPAND MACROS OR CHECK TYPES AND RETURN
01500 TSTDEF: TLNE TBITS,DEFINE ;NEED TO EXPAND MACRTO?
01600 JRST DEFRG ;YES
01700 GOHEQ: LSTDPB
01800 PUSHJ P,TYPDEC
01900 JRST STACK
02000
02100 DSCR DEFRG -- prepare to expand a macro
02200 DES The Ident is a DEFINE Ident. The steps are
02300 1. Save current Parse and Semantic Stack state,
02400 other state which will be destroyed.
02500 2. If no parameters to get, go to step 5.
02600 3. Get a parameter (special form string constant,
02700 see manual), via SCANNER (recursive call, also
02800 ENTERS); place on special VARB-RING whose ring
02900 variable is VARB, and whose starting element is
03000 in DEFRN2.
03100 4. If comma, go to step 3 for more, else check for
03200 right paren.
03300 5. Save previous SCANNER information on DEFPDP stack,
03400 set up DEFRNG for actuals, put macro body descrip-
03500 tor in PNEXTC, restore stacks and VARB, etc.
03600 6. Handle macro expansions in listing.
03700 7. JRST to SCANNER for another try with the new PNEXTC
03800 ⊗
03900
04000 DEFRG: HLRZ A,%TLINK(LPSA) ; CHECK IF MACRO HAS BEEN INITIALIZED.
04100 JUMPN A,DEFRG1 ;
04200 ERR <MACRO WAS NOT INITIALIZED - INITIALIZE TO ZERO AND CONTINUE>,1;
04300 SETZM A ; SOLVES PROBLEMS SUCH AS:
04400 PUSHJ P,CREINT ; DEFINE NAME=NAME+1 WITHOUT A DEFINE NAME=0
04500 MOVE LPSA,PNT ; OR ANOTHER INITIAL VALUE.
04600 MOVE A,%NUMCON ;
04700 JRST STACK ;
04800 DEFRG1: ;CREATE A NEW DEFINE ELEMENT
04900 TLNE FF,NOMACR ;EXPAND MACROS??
05000 JRST [LSTDPB
05100 MOVE A,%ID
05200 JRST STACK];NO -- USER ID.
05300
05400 ; IF WE DON'T WANT TO SEE MACRO NAMES IN OUTPUT LISTING, BACK UP OUTPUT PTR.
05500 ; ALSO TURN OFF LISTING FOR PARAMS
05600
05700 TLNN TBITS2,MACLST ;LIST MACRO NAMES?
05800 JRST [MOVEM SBITS2,LPNT ;NO, NULLIFY ALL TO DATE
05900 TRO TBITS2,NOLIST ;LIST NO MORE FOR A WHILE
06000 JRST .+1]
06100
06200 PUSHJ P,SCNACT ; GET ACTUAL PARAMETER LIST
06300 PUSHJ P,ACPMED ; FINISH OFF THE MACRO CALL PREPARATION
06400 JRST SCANNER ; TRY AGAIN (SCAN THE MACRO BODY!)
06500
06600 ; SPECIAL DELIMITER MODE ACTUAL PARAMETER SCANNING ROUTINE
06700
06800 SCNPMR: PUSHJ P,INSET ; SET UP STRING SPACE ENTRY
06900 TRNA ; SKIP
07000 IDPB B,LPNT ; LIST MAYBE
07100 DSPRMS: ILDB B,PNEXTC ; GET NEXT CHAR.
07200 SKIPGE A,SCNTBL(B) ; SPECIAL?
07300 PUSHJ P,CSPEC ; DO IT
07400 JUMPE A,DSPRMS-1(TBITS2) ; AGAIN IF IGNORABLE
07500 CAME B,CURPBG ; PARAMETER BEGIN DELIMITER?
07600 JRST BALCHK ; NO, NESTED-BALANCED COMMA OR RPAR WILL BREAK
07700 LSTDPB ; LIST IT?
07800 SETZM BNSTCN ; SET NEST COUNT TO ZERO
07900 JRST PSCAN+3 ; CONTINUE SCAN
08000 PSCAN: LSTDPB ; LIST IT?
08100 IDPB B,TOPBYTE(USER) ; DEPOSIT
08200 ILDB B,PNEXTC ; GET NEXT CHAR.
08300 SKIPGE A,SCNTBL(B) ; SPECIAL?
08400 PUSHJ P,CSPEC ; DO IT
08500 CAMN B,CURPED ; PARAMETER END DELIMITER?
08600 JRST SPMEND ; YES, CHECK IF DONE
08700 CAMN B,CURPBG ; PARAMETER BEGIN DELIMITER?
08800 AOS BNSTCN ; INCREMENT NEST COUNT
08900 AOJA C,PSCAN ; SCAN AGAIN
09000 SPMEND: SOSL BNSTCN ; DECREMENT NEST COUNT AND CHECK IF DONE
09100 AOJA C,PSCAN ; NO, SCAN AGAIN
09200 ILDB B,PNEXTC ; ADVANCE CHAR. TO KEEP IN SYNCH.
09300 SKIPGE A,SCNTBL(B) ; SPECIAL?
09400 PUSHJ P,CSPEC ; DO IT
09500 JRST ENDSTR ; GO TO END
09600 DEPOSB: CAIN B,")" ; RIGHT PAREN WITH NONZERO NEST COUNT?
09700 SOS LOCNST+RPAROF ; DECREMENT NEST COUNT
09800 DEPOSA: LSTDPB ; LIST IT?
09900 IDPB B,TOPBYTE(USER) ; DEPOSIT
10000 AOJ C, ; INCREMENT CHARACTER COUNT
10100 ILDB B,PNEXTC ; GET NEXT CHAR.
10200 SKIPGE A,SCNTBL(B) ; SPECIAL?
10300 PUSHJ P,CSPEC ; DO IT
10400 BALCHK: CAIE B,"," ; END OF PARAMETER?
10500 CAIN B,")" ;
10600 JRST ENDCHK ; POSSIBLY, GO CHECK
10700 TLNN A,NEST ; NESTED CHARACTER?
10800 JRST DEPOSA ; NO, GO DEPOSIT
10900 MOVE TEMP,[AOS LOCNST-1(LPSA)] ; SET UP INSTRUCTION TO UPDATE APPROP. NEST COUNT
11000 TLNN A,LNEST ; LEFT NESTED?
11100 TLO TEMP,AOSSOS ; NO, CHANGE INSTRUCTION TO SUBTRACT
11200 HRRZ LPSA,NSTABL(B) ; LOAD CHAR'S NESTED COUNT INDEX
11300 XCT TEMP ; MODIFY COUNT
11400 JRST DEPOSA ; GO DEPOSIT
11500 ENDCHK: MOVEI TEMP,NUMNST-1 ; SET UP COUNT
11600 EDLOOP: SKIPN LOCNST(TEMP) ; NEST COUNTEQUAL ZERO?
11700 SOJGE TEMP, EDLOOP ; YES, AND TRY NEXT IF NOT DONE
11800 JUMPGE TEMP,DEPOSB ; GO DEPOSIT IF NOT ALL NEST COUNTS EQUAL ZERO
11900 JRST ENDSTR ; GO TO END
12000
00100 DSCR -- SCNACT
00200 DES This procedure is used to scan a list of actual parmeters for a macro
00300 or a conditional compilation FORLC statement. When the latter happens
00400 SCNACT is called from the EXEC routine GETACT which appears in GEN.
00500 FORLC statements have a body which is scanned as many times as one has
00600 parameters in the actual list; in each case a different actual is used
00700 as the parameter.
00800 PAR LPSA contains the semantics of the macro name or macro pseudonym in
00900 case a FORLC list is being scanned (address of semblk of name).
01000 RES DEFRN2 contains the address of the first actual parameter in the list.
01100 ⊗
01200
01300 ↑SCNACT: PUSH P,LPSA ;SAVE SEMANTICS OF DEFINE SYMBOL
01400 PUSH P,VARB ;WILL MAKE NEW ONE FOR MACRO ARGUMENTS
01500 PUSH P,PPSAV ;SAVE THE STACKS
01600 PUSH P,GPSAV
01700 SETZM DEFRN2 ;INITIALIZE FOR NEW MACRO
01800 SETZM VARB
01900 HLRZ TEMP,$VAL(LPSA) ;ANY PARAMETERS NEEDED?
02000 JUMPE TEMP,NOPRMS ; NO
02100 MOVEM TBITS2,SCNWRD ;NOTE CHANGES
02200 SCNAGN: PUSHJ P,SCANNER ;LOOKING FOR "("
02300 MOVE TEMP,(SP) ;SYNTAX OF SCANNED ELEMENT
02400 POP P,GPSAV ;KEEP STACKS IN SYNCH
02500 POP P,PPSAV
02600 ADD P,X22
02700 CAMN TEMP,%STCON ; A SPECIAL DELIMITER DECLARATION?
02800 SKIPE SWBODY ; YES, COULD WE POSSIBLY HAVE SEEN A SPEC DEL DECL.
02900 ; I.E. DID WE SEE ONE ALREADY?
03000 JRST TSLPRN ; NO, GET LEFT PAREN.
03100 SKIPN REQDLM ; TRYING TO OVERRIDE NULL DELIMITERS MODE?
03200 SETOM RSTDLM ; YES, SET APPROPRIATE FLAGS
03300 SETOM REQDLM ;
03400 SETOM SWBODY ; SET SWITCH DELIMITER DECLARATION FLAG
03500 MOVE TEMP,[XWD -2,2] ; SET UP A COUNT
03600 MOVE PNT,$PNAME+1(LPSA) ; PNT HAS BYTE POINTER TO DELIM. STRING
03700 HRRZ LPSA,$PNAME(LPSA) ; LPSA HAS DELIMITER STRING LENGTH
03800 PUSHJ P,GETDL2 ; GET SPECIAL DELIMITER DECLARATION
03900 JRST SCNAGN ; GO BACK AND GET LEFT PAREN.
04000 TSLPRN: CAME TEMP,[TLPRN&17777777] ;PARAMS?
04100 ERR <MISSING "(" IN MACRO CALL> ; NO
04200 MOVEI B,"("
04300 LSTDPB
04400 TLO FF,PRMSCN ; PRIME THE SCANNER FOR PARAMETER
04500 PUSHJ P,FFPUSH ; SAVE OLD DEFLUK BIT OF FF AND TURN IT ON IN FF
04600 PRMLUP: SKIPN REQDLM ; IN SPECIAL DELIMITER MODE?
04700 JRST PRMOLD ; NO
04800 PUSHJ P,SCNPMR ; YES, GET THE PARAMETERS
04900 TRNA
05000 PRMOLD: PUSHJ P,SCANNER ;GET A PARAMETER
05100 POP P,GPSAV ;SYNCH STACK
05200 POP P,PPSAV
05300 ADD P,X22
05400
05500 ; WE KNOW RESULT IS STRING CONSTANT, SCANNER WILL RETURN NO OTHER
05600
05700 SKIPN TEMP,DEFRN2 ;PUT PTR TO FIRST ARG IN DEFRN2
05800 MOVE TEMP,NEWSYM
05900 MOVEM TEMP,DEFRN2
06000
06100 PUSHJ P,SCANNER ;GET NEXT PUNCTUATION
06200 MOVE TEMP,(SP)
06300 POP P,GPSAV
06400 POP P,PPSAV
06500 ADD P,X22 ;SYNCH STACKS
06600 CAMN TEMP,[TCOMA&17777777] ;LOOPING?
06700 JRST PRMLUP ;YES
06800 CAME TEMP,[TRPRN&17777777] ;DONE?
06900 ERR <MISSING "," OR ")" IN MACRO CALL>
07000 MOVE LPSA,DEFRN2 ; DETERMINE IF ALL PARAMETERS HAVE BEEN
07100 MOVEI TEMP,0 ; SPECIFIED AND IF NOT FORM NULL'S FOR
07200 DEFLNK: HRRZ LPSA,%RVARB(LPSA); ALL THOSE LEFT OUT SO THAT ASSIGNC
07300 ADDI TEMP,1 ; WILL WORK PROPERLY
07400 JUMPN LPSA,DEFLNK ;
07500 MOVE LPSA,-3(P) ;
07600 HLRZ LPSA,$VAL(LPSA)
07700 SUB TEMP,LPSA ; NUMBER OF UNSPECIFIED PARAMETERS
07800 MOVEM TEMP,NULCNT ;
07900 TSTDON: AOSLE NULCNT ; ALL PARAMETERS SPECIFIED?
08000 JRST CONACT ; YES,
08100 PUSHJ P,INSET ; SET UP STRING SPACE ENTRY
08200 ADDI C,2 ; APPEND 177¬0 TO NULL STRING AND LINK
08300 MOVEI TEMP,177 ; ON VARB AND STRING RINGS
08400 IDPB TEMP,TOPBYTE(USER) ;
08500 MOVEI TEMP,0 ;
08600 IDPB TEMP,TOPBYTE(USER) ;
08700 PUSHJ P,UPDCNT ;
08800 GETBLK NEWSYM ;
08900 HRROI TEMP,PNAME+1 ;
09000 POP TEMP,$PNAME+1(LPSA) ;
09100 POP TEMP,$PNAME(LPSA) ;
09200 MOVE TEMP,[XWD CNST,STRING] ;
09300 MOVEM TEMP,$TBITS(LPSA) ;
09400 PUSHJ P,RNGSTR ;
09500 PUSHJ P,RNGVRB ;
09600 JRST TSTDON ;
09700 CONACT: TLZ FF,PRMSCN ; DONE WITH THESE
09800 PUSHJ P,FFPOP ; RESTORE DEFLUK BIT OF FF
09900 SKIPE REQDLM ; IN SPECIAL DELIMITER MODE?
10000 SKIPN SWBODY ; YES, HAVE TO REVERT TO OLD DELS?
10100 JRST NOPRMS ; NO
10200 SETZM SWBODY ; RESET SWITCH DELIMITER DECLARATION FLAG
10300 SKIPN RSTDLM ; RESTORING NULL DELIMITERS MODE?
10400 JRST .+4 ; NO
10500 SETZM RSTDLM ; YES, RESTORE APPROPRIATE FLAGS
10600 SETZM REQDLM ;
10700 JRST NOPRMS ;
10800 HRROI TEMP,LOCMPR+1 ; GET RESTORING ADDRESS
10900 POP TEMP,CURPED ; RESTORE START DEL.
11000 POP TEMP,CURPBG ; RESTORE END DEL.
11100 NOPRMS: POP P,GPSAV ; GET SEMANTIC STACK BACK
11200 POP P,PPSAV ; GET PARSE STACK BACK
11300 POP P,VARB ; GET OLD VARB BACK
11400 POP P,LPSA ; SEMANTICS FOR DEFINE
11500 MOVE SP,PPSAV ; RESTORE SP IN CASE IT GOT FOULED UP IN
11600 ; SCANNER CALLS
11700 POPJ P, ; RETURN
11800
11900
12000
12100 DSCR -- ACPMED
12200 DES ACPMED prepares for a macro call once the actual parameters have been
12300 scanned. It is also used to prepare for the first instantiation of the
12400 body of a conditional compilation WHILEC, CASEC, FORC, or FORLC statement.
12500 PAR LPSA contains the semantics of the macro name or macro pseudonym in
12600 case a conditional compilation WHILEC, CASEC, FORC, or FORLC body is
12700 being scanned for the first time. DEFRN2 contains the address of the
12800 actual parameter list in case of a FORLC statement, the address of the
12900 loop variable semblk in case of a FORC statement, and zero in the case
13000 of a WHILEC or CASEC statement.
13100 RES At the end of this procedure one has effectively switched PNEXTC and
13200 PNEXTC-1 to scan the macro body or the conditional compilation body.
13300 Relevant information is saved on the DEFPDP stack.
13400 ⊗
13500
13600
13700
13800 ↑ACPMED: MOVE PNT,DEFPDP ;RESTORE NOW
13900 PUSH PNT,DEFRNG ;SAVE OLD RING OF PARAMETERS
00100 PUSH PNT,PNEXTC-1 ;STRING NUMBER
00200 PUSH PNT,PNEXTC ;INSTEAD SAVE THOSE WHICH
00300 PUSH PNT,SAVCHR ; PARAMETERS
00400 MOVEM PNT,DEFPDP
00500 MOVE PNT,PLINE ;WILL SAVE IN IPLINE IF LEAVING INPUT LEVEL
00600
00700 HLRZ LPSA,%TLINK(LPSA) ; STORE THE LENGTH OF THE MACRO BODY IN THE LEFT
00800 HRLZ TEMP,$PNAME(LPSA) ; HALF OF DEFRNG SO THAT WHEN FINISH SCANNING AN
00900 HRR TEMP,DEFRN2 ; ACTUAL PARAMETER THERE WILL BE SOME INDICATION OF
01000 MOVEM TEMP,DEFRNG ; THE MINIMUM AMOUNT OF STRING SPACE NECESSARY FOR
01100 PUSHJ P,CONTX2 ; THE SCANNING OF THE REMAINDER OF THE MACRO
01200
01300 ; DECIDE WHETHER MACRO EXPANSION SHOULD BE LISTED.
01400
01500 MOVEI B,"<" ;MARK EXPANSION IF MACRO NAME
01600 TLNE TBITS2,LSTEXP ; IS ALSO BEING LISTED
01700 IDPB B,LPNT ; (NEVER ON IF ¬LISTNG)
01800 TLON TBITS2,MACIN ;IN A MACRO NOW
01900 MOVEM PNT,IPLINE ;CAN GET CURRENT LINE LOC FROM HERE
02000 SKIPE SWCPRS ; NO LISTING WHEN IN COND. PARSER
02100 TRZ TBITS2,NOLIST ;ASSUME LISTING
02200 TLNN TBITS2,MACEXP ;IF MACRO EXPANSION SHOULD NOT BE LISTED,
02300 TRO TBITS2,NOLIST ; INDICATE IT
02400 MOVEM TBITS2,SCNWRD ;UPDATE IN CORE
02500 POPJ P, ; RETURN
02600
02700
02800
02900 DSCR -- CONTXT
03000 DES CONTXT is used to switch the input pointers before a macro call or
03100 prior to each invocation of the body of conditional compilation WHILEC,
03200 CASEC, FORC, or FORLC statement. If conditional compilation is the case
03300 then this is virtually all that need be done for the reinvocation of the
03400 body and thus it is clearly cheaper than calling the macro in the old
03500 sense several times with different variables (this statement is only true
03600 for the WHILEC, FORC, and FORLC statement since the body of a CASEC
03700 statement is only scanned once).
03800 PAR LPSA contains the semantics of the macro name or macro pseudonym in the
03900 case of a conditional compilation WHILEC, CASEC, FORC, or FORLC statement.
04000 RES PNEXTC, PNEXTC-1, PLINE, and PLINE-1 are set.
04100 ⊗
04200
04300
04400
04500 ↑CONTXT: HLRZ LPSA,%TLINK(LPSA) ;SEMANTICS FOR MACRO BODY
04600 CONTX2: PUSHJ P,SGCOL1 ;MAKE SURE THERE'S ENOUGH ROOM
04700 HLLZ TEMP,$PNAME(LPSA) ;STRING NUMBER -- NULL STRING
04800 MOVEM TEMP,PNEXTC-1
04900 MOVEM TEMP,PLINE-1
05000 MOVEW PNEXTC,$PNAME+1(LPSA) ;SET UP NEW INPUT POINTER
05100 MOVEM TEMP,PLINE
05200 SETZM SAVCHR ; NOTHING SCANNED AHEAD AT THIS LEVEL
05300 SETZM LSTCHR ; NOTHING SCANNED AHEAD AT THIS LEVEL
05400 POPJ P, ; RETURN
00100 DSCR STRNG, etc.
00200 DES Input a string constant. Check all identifiers to see if
00300 they are formal parameters to a DEFINE (macro). If so,
00400 replace them by their internal identifiers (delete <177>
00500 followed by unique code). Store string constant in string
00600 space, place entry in table, results to HPNT and NEWSYM.
00700 SEE Comments on following page for details of actual param thing.
00800 ⊗
00900
01000 STRNG:
01100 PUSHJ P,INSET ;CLEAR AND RESET AS ABOVE
01200 TLZ FF,PRMXXX ;IF " WAS FIRST CHAR, NOT IN SPECIAL MODE
01300 STSCAN:
01400 ILDB B,PNEXTC ;PRESERVE NEXT CHARACTER
01500 BAKSTR: SKIPGE A,SCNTBL(B) ;DO SPECIAL THINGS
01600 PUSHJ P,CSPEC ;IF REQUIRED
01700 BAKST1: TLNN A,LETDG ;THINK HARD ONLY ON QUOTE, LETTDIG
01800 JRST MORSTR ; NOT LETTER OR DIGIT
01900 TLNE FF,DEFLUK ; SCANNING A MACRO BODY?
02000 TLNE FF,PRMSCN ; YES, SCANNING MACRO PARAMETERS
02100 JRST MORSTR ; YES, CHECK DELIMITERS
02200 SKIPN REQDLM ; SPECIAL DELIMITER MODE?
02300 JRST DEFCHK ; NO, THINK HARD
02400 CAMN B,CURMED ; MACRO BODY END DELIMITER?
02500 JRST LTDEND ; YES, CHECK IF DONE
02600 CAMN B,CURMBG ; MACRO BODY BEGIN DELIMITER?
02700 AOS BNSTCN ; YES, INCREMENT NEST COUNT
02800 JRST DEFCHK ; THINK HARD
02900 LTDEND: SOSL BNSTCN ; DECREMENT NEST COUNT AND CHECK IF DONE
03000 JRST DEFCHK ; THINK HARD
03100 JRST LTDCON ; TERMINATE MACRO BODY SCAN
03200
03300 MORSTR: TLNN FF,PRMXXX ;IN SPECIAL PARAMETER-SCANNING MODE?
03400 JRST MORST1 ; NO, CONTINUE
03500
03600 CAIE B,"," ;END OF PARAMETER?
03700 CAIN B,")"
03800 JRST ENDSTR ; YES
03900 JRST DEPOSIT ;LET SINGLE QUOTES THRU IN THIS MODE
04000 MORST1: SKIPN DLMSTG ; A SPECIALLY DELIMITED STRING?
04100 JRST MORST2 ; NO, GO CHECK FOR QUOTES
04200 CAMN B,CURMED ; MACRO BODY END DELIMITER?
04300 JRST MBDEND ; YES
04400 CAMN B,CURMBG ; MACRO BEGIN DELIMITER?
04500 AOS BNSTCN ; YES, INCREMENT NEST COUNT
04600 JRST DEPOSIT ; DEPOSIT
04700 MBDEND: SOSL BNSTCN ; DECREMENT NEST COUNT AND CHECK IF DONE
04800 JRST DEPOSIT ; DEPOSIT
04900 LTDCON: LSTDPB ; PUT IT AWAY
05000 ILDB B,PNEXTC ; GET NEXT CHAR. TO KEEP IN SYNCH.
05100 SKIPGE A,SCNTBL(B) ; SPECIAL?
05200 PUSHJ P,CSPEC ;DO IT
05300 JRST ENDSTR ; GO TO END
05400 MORST2: TLNN A,QUOTE ;END OR DOUBLE-QUOTE ?
05500 JRST DEPOSIT ; NO, PUT IT AWAY
05600
05700 LSTDPB ;PUT IT AWAY
05800 ILDB B,PNEXTC ;TRY NEXT
05900 SKIPGE A,SCNTBL(B) ; DO THE USUAL IF SPCL
06000 PUSHJ P,CSPEC
06100 TLNN A,QUOTE ;IS IT ONE?
06200 JRST[SKIPE BAKDLM ; YES, CHECK IF NEED TO RESTORE DLMSTG
06300 SETOM DLMSTG ; YES
06400 SETZM BAKDLM ; TURN OFF BAKDLM
06500 JRST ENDSTR] ; DONE
06600
06700 DEPOSIT:
06800 LSTDPB ;TO LISTING FILE IF REQD
06900 DEPO1: IDPB B,TOPBYTE(USER) ;STORE CHARACTER AS IS
07000 AOJA C,STSCAN ;LOOP ON RANDOM CHARACTERS
07100
00100 COMMENT ⊗
00200 We come here if a letter or number has been seen. If we are not
00300 scanning a macro body, we simply scan the rest of the characters
00400 which could be an identifier into the string constant, and return
00500 to the main string constant scanning loop.
00600
00700 If we are scanning a macro body, this may be a parameter name.
00800 The following algorithm is used:
00900 1. If not a letter, continue as if were not scanning macro body.
01000 2. Save a pointer to the start of this ident in the string const.
01100 3. Scan this (possible) param into the constant, no case conversion.
01200 4. Reset the TOPBYTE pointer, save status, then return PNEXTC to
01300 point to this ident again. Call DSCAN (ident scanner) to con-
01400 vert and lookup this identifier (some special bits set to avoid
01500 stacking results, etc.)
01600 5. If not a DEFINE parameter, reset TOPBYTE and PNAME pointers to
01700 their state at the end of step 3, clear space used during DSCAN,
01800 and return to main string constant loop.
01900 6. Back TOPBYTE pointer up to beginning of ident again, insert '177
02000 (param marker), followed by param number into string, clear space
02100 used during steps 3 and 4, update PNAME count properly, and return
02200 to main loop.
02300
02400 During the course of this operation, several things get stored
02500 (as strings) on the SP stack, to prevent damage over possible
02600 garbage collects: the string constant so far, pointers to the
02700 beginning and one past the end of the possible parameter, and
02800 the input (PNEXTC) pointers (in case they represent a macro
02900 body, which of course must be collected properly. There exists
03000 a problem. If STRINGC happens, all these pointers must be
03100 moved together, so that they still point inside the same string.
03200 STRINGC, remember, when working for SAIL, adjusts each new
03300 string to the start of a new word--catastrophic in this case.
03400 To solve this, we convince each pointer saved that it is a
03500 (non-null) string which is a substring of a string which is
03600 guaranteed to contain all the others. Since in some cases we
03700 save a pointer one past the last real char scanned, there are
03800 places in the code below where the string count of PNAME (and
03900 saved representations) is incremented to include this char.
04000 This is also the reason for the one character long invented
04100 strings ([XWD 40,1] constructs). In one mystical case, below,
04200 a PNAME, PNAME+1 pair is saved solely for the reason that it
04300 is the only string containing all others -- it is thrown away
04400 after the last possible STRINGC, and the count re-computed
04500 from other data.
04600
04700 Be warned that the current setup is the result of several killed
04800 bugs -- each thought to be the last. No guarantees are
04900 proferred that no more exist, but chances are better than ever.
05000 ⊗
00100 DEFCHK:
00200 HRRM C,PNAME ;MAKE COUNT HONEST BEFORE SAVING
00300 TLNE A,NUMB ;MUST BE A LETTER
00400 JRST DEPOSIT ; DIGIT OR OTHER NUMBER PART, GO ON
00500
00600 EXCH SP,STPSAV ;SAVE PNAME
00700 MOVSS POVTAB+6 ;SET PDLOV FOR STRING STACK
00800 AOS PNAME ;INCREMENT TO INCLUDE 1ST IDENT CHAR(SEE ABOVE)
00900 ;;#PZ#(1 OF 3) DCS SAID DELETE THE NEXT INSTR.
01000 ;; ADDI C,1 ;TO CARRY XTRA CHAR THROUGH FURTHER STEPS
01100 PUSH SP,PNAME ; BECAUSE DSCAN IS GOING TO CHANGE
01200 PUSH SP,PNAME+1 ; IT
01300 PUSH SP,[XWD 40,1] ;PROTECT 1ST CHAR PTR OVER GC (SEE ABOVE)
01400 PUSH SP,TOPBYTE(USER);SAVE LOC OF BEGINNING OF IDENT
01500 EXCH SP,STPSAV ;PUT BACK FOR NONCE
01600 MOVSS POVTAB+6 ;RE-ENABLE TRAP FOR PARSE STACKS
01700
01800 RANSCN: ADDI C,1 ;COUNT FIRST CHAR
01900 LSTDPB ;LIST IF NECESSARY
02000 RANSC1: IDPB B,TOPBYTE(USER) ;KNOW FIRST ONE IS OK
02100 ILDB B,PNEXTC
02200 SKIPGE A,SCNTBL(B) ;USUAL TEST
02300 PUSHJ P,CSPEC
02400 TLNN A,LETDG
02500 JRST SEEPRM ; NOT A LETTER OR DIGIT
02600 SKIPN REQDLM ; SPECIAL DELIMITER MODE?
02700 JRST CHKCON ; NO
02800 CAMN B,CURMED ; MACRO BODY END DELIMITER?
02900 JRST MBEDCK ; YES
03000 CAMN B,CURMBG ; MACRO BODY BEGIN DELIMITER?
03100 AOS BNSTCN ; YES, INCREMENT NEST COUNT
03200 JRST CHKCON ; CONTINUE ID SCAN
03300 MBEDCK: SOSL BNSTCN ; DONE WITH MACRO BODY?
03400 CHKCON: AOJA C,RANSC1-1(TBITS2) ; COUNT AND LOOP
03500
03600 ; NOW CONVERT IDENT TO UPPER CASE, ALIGN, CALL SCANNER TO LOOK IT UP
03700
03800 SEEPRM:
03900 ;;#PZ# RHT -- (2 OF 3) DCS SAID TO REPLACE THE COMMENTED OUT CODE
04000 ;; HRRM C,PNAME ;UPDATE CHAR COUNT IN STRING DSCRPTR
04100 ;; SUBI C,1 ; MAINTAIN XTRA CHAR IN PNAME
04200 ;; PUSH P,A ;SAVE BITS AND
04300 ;; PUSH P,B ; CHAR AND
04400 ;; PUSH P,C ; COUNT
04500 PUSH P,A ;SAVE BITS,
04600 PUSH P,B ; CHARACTER, AND CURRENT TOTAL
04700 PUSH P,C ; MACRO BODY STRING COUNT
04800 ADDI C,1 ;MAKE PNAME LOOK ONE LONGET TO PROTECT
04900 HRRM C,PNAME ; END POINTER OVER GC
05000 ;;#PZ#
05100 EXCH SP,STPSAV ;GET STRING STACK BACK
05200 MOVSS POVTAB+6 ;ENABLE FOR STRING STACK OV
05300 PUSH SP,[XWD 40,1] ;PROTECT PTR OVER STRINGC(SEE ABOVE)
05400 PUSH SP,TOPBYTE(USER) ;END OF ID
05500 PUSH SP,PNEXTC-1 ;CURRENT INPUT POSITION
05600 PUSH SP,PNEXTC
05700 HRRZ TBITS,-7(SP) ;ORIGINAL COUNT
05800 PUSH SP,PNAME ;THIS IS ONLY STRING GUARANTEED
05900 PUSH SP,PNAME+1 ; TO CONTAIN ALL OTHERS
06000 EXCH SP,STPSAV
06100 MOVSS POVTAB+6 ;ENABLE FOR PARSE STACK OV
06200 SUBM C,TBITS ;LENGTH OF ID (`C' NOW CORRECT, SEE ABOVE)
06300 ;;#PZ# (3 OF 3) ! USED TO BE A 5
06400 ADDI TBITS,4 ;WILL MOVE OUT TO AVOID A PROBLEM
06500 COLNEC: PUSHJ P,SGCOL2 ;COLLECT IF NECESSARY
06600 AOS TOPBYTE(USER) ;IDPB-ILDB GETS INTO LOOP IN DSCAN IF NOT
06700 MOVE TEMP,STPSAV ;NOW GET PTR TO BEGIN OF ID (PERHAPS LOWER CASE)
06800 MOVE TEMP,-6(TEMP) ;ILDB GETS ID'S FIRST CHAR
06900 ILDB B,TEMP ;SET UP FOR SCANNER
07000 MOVEM TEMP,PNEXTC ;SCAN FROM HERE FOR A WHILE
07100 MOVE A,SCNTBL(B) ;GET THE BITS BACK
07200 TLO TBITS2,LOKPRM
07300 TRON TBITS2,NOLIST ;TURN OFF LISTING FOR RESCAN
07400 TLO TBITS2,BACKON ;SAY YOU'VE DONE IT IF STATE CHANGED
07500 MOVEM TBITS2,SCNWRD ;UPDATE
07600 SCNPRM: PUSHJ P,DSCAN ;ID SCANNER -- SCAN AND LOOK IT UP
07700 ;THIS MAY CALL STRINGC -- BUT ALL-ENCOMPASSING
07800 ;PNAME ENTRY IS IN THE SP STACK, SO OK
07900
08000 POP P,C ;GET COUNT BACK (IT'S CORRECT)
08100 POP P,B ;GET ID BREAK CHAR BACK
08200 POP P,A ;GET ID BREAK CHAR BITS BACK
08300 EXCH SP,STPSAV ;PUT THE SCANNER LOCATION BACK
08400 SUB SP,X22 ;REMOVE ENCOMPASSING PNAME ENTRY (SEE DESCR)
08500 POP SP,PNEXTC
08600 POP SP,PNEXTC-1
08700 TSTPRM: SKIPG LPSA,NEWSYM ;THESE TESTS DETERMINE IF
08800 JRST NOPAR ; (1) THERE IS A SYMBOL OF THIS NAME
08900 SKIPGE TBITS,$TBITS(LPSA)
09000 JRST NOPAR ; (2) IT IS NOT A RESERVED WORD
09100 TLNE TBITS,FORMAL
09200 TLNN TBITS,DEFINE
09300 JRST NOPAR ; (3) IT IS A MACRO PARAMETER NAME
09400
09500 MOVE TEMP,-2(SP) ;IN OTHER WORDS, WE FOUND A PARAM
09600 MOVEI C,0 ; BP OF START OF ID IN TEMP
09700 LINLUP: TLNN TEMP,760000 ;ZERO REST OF FIRST WORD TO BE AFFECTED
09800 JRST OKL
09900 IDPB C,TEMP
10000 JRST LINLUP
10100 OKL: HRLI TEMP,1(TEMP) ;ZERO REST OF ORIGINAL SCAN, ALL OF DSCAN
10200 HRRI TEMP,2(TEMP) ; SCAN
10300 SETZM -1(TEMP)
10400 BLT TEMP,@TOPBYTE(USER)
10500 SUB SP,X44 ;REMOVE PTR TO FIRST, PTR TO LAST OF ORIG ID SCAN
10600 MOVE C,2(SP) ;PTR TO FIRST, WILL BECOME TOPBYTE
10700 MOVEI TEMP,177 ;MARK PARAM OCCURRENCE
10800 IDPB TEMP,C
10900 HRRZ TEMP,$VAL(LPSA) ;PARAM NUMBER
11000 IDPB TEMP,C
11100 MOVEM C,TOPBYTE(USER) ;WHAT DID I TELL YOU?
11200 HRRZ C,-1(SP) ;ORIGINAL LENGTH (+1)
11300 AOJA C,DN ; +2 FOR MARKER, -1 TO REMOVE XTRA CHR
11400
11500
11600 NOPAR: AOS TEMP,PNAME+1 ;CLEAR FROM END OF ORIGINAL SCAN
11700 HRLI TEMP,-1(TEMP) ;TO END OF DSCAN SCAN
11800 SETZM -1(TEMP)
11900 BLT TEMP,@TOPBYTE(USER)
12000 POP SP,TOPBYTE(USER);SAVE ORIGINAL SCAN
12100 SUB SP,X33 ;FORGET OTHER POINTER
12200 ; C IS THE VALUE PRIOR TO THE DSCAN IF NOPAR
12300 DN: TLZE TBITS2,BACKON ;TURN LISTING BACK ON?
12400 TRZ TBITS2,NOLIST ;YES
12500 POP SP,PNAME+1 ;NOW RESTORE THESE
12600 POP SP,PNAME
12700 EXCH SP,STPSAV ;ONE MORE TIME
12800 HRRM C,PNAME ;MAKE SURE COUNT IS REALLY HONEST
12900 ;A AND B ARE THE APPROPRIATE VALUES FOR THE ORIGINAL BREAK CHAR
13000 TLZ TBITS2,LOKPRM ;LOOK NO MORE
13100 JRST MORSTR ;CONTINUE THE SCAN
13200
13300
13400
13500 Comment ⊗
13600 End of string constant -- set up results for stacking,
13700 go do it ⊗
13800
13900 ENDSTR:
14000 MOVEM TBITS2,SCNWRD ;PUT ALL THE BITS AWAY
14100 LSTDPB ;PUT "," OR ")" AWAY
14200 TLZ FF,PRMXXX
14300 CAIE B,12 ;LF IS SPECIAL PROBLEM!
14400 MOVEM B,SAVCHR ;SAVE BITS FOR NEXT TIME
14500 MOVEM B,LSTCHR ;ALSO HERE ANY TIME
14600 SKIPN SWCPRS ; SWITCHING PARSERS OK?
14700 JRST NOSWCH ; NO,
14800 TLNN FF,PRMSCN ; SCANNING ACTUALS?
14900 SKIPE ASGFLG ; NO, ASSIGNC BODY?
15000 JRST ENDACT ; YES, APPEND 177¬0 TO MACRO ACTUALS
15100 JRST NOMACW ; NO,
15200 NOSWCH: SKIPN IFCREC ; EXPAND MACROS IN FALSE PART OF COND COMP?
15300 TLNN FF,PRMSCN ; YES, SCANNING MACRO ACTUALS?
15400 JRST [PUSHJ P,UPDCNT ; KEEP REMCHR HONEST
15500 JRST STCTYP] ; DON'T ENTER STRING
15600 ENDACT: ADDI C,2 ; FOR ACTUAL PARAMETERS APPEND 177-0 TO END OF
15700 MOVEI TEMP,177 ; STRING, GET A SEMBLK AND PLACE IT ONLY ON
15800 IDPB TEMP,TOPBYTE(USER) ; THE STRING RING. ALL ACTUAL PARAMETERS TO
15900 MOVEI TEMP,0 ; A MACRO ARE LINKED ON THE VARB RING. THUS WHEN
16000 IDPB TEMP,TOPBYTE(USER) ; A MACRO CALL IS FINISHED ALL THAT REMAINS TO
16100 PUSHJ P,UPDCNT ; DO IS TO KILLST ALONG THE VARB RING WHOSE HEAD
16200 GETBLK NEWSYM ; IS POINTED TO BY DEFRNG.
16300 HRROI TEMP,PNAME+1 ;
16400 POP TEMP,$PNAME+1(LPSA) ;
16500 POP TEMP,$PNAME(LPSA) ;
16600 MOVE TEMP,[XWD CNST,STRING] ; MAKE SEMBLK OF ACTUAL PARAMETER LOOK LIKE
16700 MOVEM TEMP,$TBITS(LPSA) ; A STRING CONSTANT SEMBLK EXCEPT FOR THE FACT
16800 PUSHJ P,RNGSTR ; THAT IT IS NOT LINKED ON THE STRING CONSTANT RING
16900 SKIPN ASGFLG ; ASSIGNC BODY IS NOT PLACED DIRECTLY ON VARRB RING
17000 PUSHJ P,RNGVRB ;
17100 MOVE LPSA,NEWSYM ;
17200 MOVE A,%STCON ;
17300 JRST STACK ;
17400 NOMACW: PUSHJ P,UPDCNT ; UPDATE PNAME CNT, REMCHR, COLLECT IF NECESSARY
17500 PUSH P,BITS ;
17600 PUSHJ P,STRINS ; CHECK IF STRING HAS ALREADY BEEN ENTERED IN THE
17700 POP P,BITS ; SYMBOL TABLE AND IF NOT THEN ENTER IT
17800 MOVE LPSA,PNT ;
17900 MOVEM LPSA,NEWSYM ;
18000 STCTYP: MOVE A,%STCON ;
18100 JRST STACK ;
00100 DSCR SCNUMB -- number scanner
00200 DES Scan a number -- keep both REAL (floating) and fixed
00300 representations around, use the appropriate one at the end.
00400 A number is composed of integers and various special characters.
00500 See the syntax for a better definition, but here is a summary:
00600
00700 <int><.<int>><@<+|->int>
00800
00900 Common sense should indicate that some of these things must
01000 be present to constitute a legal number. The results
01100 are returned as described on the opening page of SCAN.
01200 ⊗
01300
01400 SCNUMB:
01500
01600 ; @ CHARACTER TO BE TREATED AS DELIMITER IF INSIDE START!CODE
01700 ; BLOCK
01800
01900 TLNN A,ATSIGN ; AT SIGN?
02000 JRST SCNM1 ; NO, GET REST OF NUMBER
02100 SKIPN SWCPRS ; YES, IN FALSE PART OF CONDITIONAL COMPILATION?
02200 JRST ATOUT ; YES, TREAT AT SIGN AS A PARSE TOKEN
02300 TLNN TBITS2,INLIN ; NO, IN-LINE CODE?
02400 JRST SCNM1 ; NO, GET REST OF NUMBER
02500
02600 ATOUT: MOVE A,%ATS ;GET BITS FOR AT SIGN DELIMITER
02700 JRST CHAROUT ;HANDLE AS DELIMITER
02800
02900 SCNM1:
03000 SETZM SCNVAL ;NUMERIC VALUE
03100 SETZM DBLVAL ;FUTURE USE BY DBLPRC, COMPLEX
03200 SETZB SBITS2,FLTVAL ;SBITS2 HOLDS FLAGS, FLTVAL COLLECTS REAL
03300 ; REPRESENTATION
03400 ;C HOLDS COUNT OF DECIMAL PLACES
03500
03600 TLNN A,QUOCTE ;OCTAL QUOTE MARK (') ?
03700 JRST DECIM ;NO, DECIMAL NUMBER
03800
03900 OCTL: ILDB B,PNEXTC ;GET BACK IN SYNCH
04000 SKIPGE A,SCNTBL(B)
04100 PUSHJ P,(A) ;USUAL SPECIAL TREATMENT
04200 LSTDPB
04300 SKIPA D,[LSH TEMP,3] ;OCTAL NUMBER GATHERER
04400 DECIM: MOVE D,[IMULI TEMP,=10] ;DECIMAL NUMBER GATHERER
04500
04600 PUSHJ P,GETINT ;CLEAR COUNT, GET AN INTEGER
04700 TLNN A,LETDG ;IF NOT PART OF A NUMBER,
04800 JRST ENDNUM ; DONE
04900 TLNN A,DOT ;"."?
05000 JRST NODOT ; NO DECIMAL PART, CHECK EXP PART
05100 TRO SBITS2,FLOTNG ;MARK REAL NUMBER
05200 PUSHJ P,LGETINT ;TRY FOR SOME MORE INTEGER
05300 TLNN A,LETDG ;IF NOT NUMBER, NONE, JUST WANTED TO IND
05400 JRST ENDNUM ; ICATE REAL (OR DONE)
05500
05600 NODOT: TLNN A,ATSIGN ;IF NOT ".", MUST BE "@"
05700 ERR <ILLEGAL REAL CONSTANT>,1
05800 TRON SBITS2,FLOTNG ;NO DEC PLACES UNLESS
05900 MOVEI C,0 ; ALREADY REAL
06000 PUSH P,FLTVAL ;SAVE FLOATING REPRESENTATION
06100 PUSH P,C ;AND DECIMAL COUNT
06200 SETZM SCNVAL ;CLEAR VALUES AGAIN
06300 SETZM FLTVAL
06400 ILDB B,PNEXTC ;CHECK SIGNED EXPONENT
06500 SKIPGE A,SCNTBL(B) ;USUAL
06600 PUSHJ P,(A)
06700 LSTDPB ;PUT IT TO LISTING FILE
06800 PUSH P,[FIXAT]
06900 CAIN B,"-" ;MINUS?
07000 TLOA SBITS2,EXPNEG ; YES, EXPONENT NEGATIVE
07100 CAIN B,"+" ;NO, PLUS?
07200 JRST LGETINT ; PLUS OR MINUS, GET DIGIT
07300 JRST GETINT ; HAVE DIGIT, GO GET NUMBER
07400 FIXAT: TLNE SBITS2,EXPNEG ;NEGATIVE EXPONENT?
07500 MOVNS SCNVAL ; YES
07600 POP P,C ;GET DECIMALS BACK
07700 POP P,FLTVAL ;AND OLD FLOATING VALUE
07800 ADD C,SCNVAL ;TOTAL EXPONENT
07900
08000 ENDNUM: CAIE B,12 ;EXCEPT FOR LINE FEED,
08100 MOVEM B,SAVCHR ;SAVE FOR NEXT SCAN
08200 MOVEM B,LSTCHR ;ALSO HERE ANY TIME
08300 TLNE A,LETDG ;MUST NOT BE LEETTER OR DIG OR
08400 ERR <ILLEGAL CONSTANT>,1
08500 TRNN SBITS2,FLOTNG ;REAL OR INTEGER?
08600 JRST INTEG
08700 TLNE SBITS2,REALOV ;FLOATING POINT OVERFLOW?
08800 ERR <REAL CONSTANT TOO LARGE>,1
08900 MOVE A,[FDVR TEMP,[10.0]] ;ADJUST NUMBER
09000 SKIPL C
09100 MOVE A,[FMPR TEMP,[10.0]] ; BY MULTIPLYING OR
09200 MOVMS C ;DIVIDING UNTIL C GOES NEGATIVE
09300 MOVE TEMP,FLTVAL ;UNADJUSTED NUMBER
09400 JFCL 17,MLP ;CLEAR FLAGS
09500 JRST MLP
09600 MULUP:
09700 XCT A ;ADJUST
09800 JFOV [ERR <REAL CONSTANT TOO LARGE OR TOO SMALL>,1
09900 JRST MLP]
10000 MLP: SOJGE C,MULUP ;KEEP GOING MAYBE
10100
10200 DUN: MOVEM TEMP,SCNVAL ;THIS IS THE (REAL) ANSWER
10300 JRST NUMRET ;GO STACK
10400
10500 INTEG: SKIPN C ;MAKE SURE THERE WAS SOMETHING
10600 ERR <ILLEGAL INTEGER CONSTANT>,1
10700 TLNE SBITS2,INTOV ;INTEGER OVERFLOW?
10800 ERR <INTEGER CONSTANT TOO LARGE>,1
10900 TRO SBITS2,INTEGR ;MARK TYPE
11000 NUMRET: SKIPN SWCPRS ; INSIDE FALSE PART OF CONDITIONAL COMPILATION?
11100 JRST NUMTYP ; YES, DON'T ENTER THE NUMBER
11200 HRLI SBITS2,CNST ; MAKE INTO TBITS WORD
11300 PUSH P,BITS ;DON'T EFFECT OUTSIDE WORLD
11400 MOVEM SBITS2,BITS ;SET UP FOR ENTER
11500 PUSHJ P,NHASH ;LOOK UP THE NUMBER
11600 SKIPG NEWSYM ;WAS IT THERE ALREADY?
11700 PUSHJ P,ENTERS ; NO, BUT IT IS NOW
11800 POP P,BITS ;GET OLD BITS BACK
11900 MOVE LPSA,NEWSYM ;SET UP FOR STACKING
12000 NUMTYP: MOVE A,%NUMCON
12100 JRST STACK ;GO DO IT
00100 Comment ⊗
00200 Get an integer (base 10 only for the present).
00300 ⊗
00400 LGETINT: ;GET A CHARACTER FIRST
00500 ILDB B,PNEXTC
00600 MGETINT: ;GET BITS FIRST
00700 SKIPGE A,SCNTBL(B)
00800 PUSHJ P,(A) ;SIGH!
00900 LSTDPB
01000
01100 GETINT: ;GET AN INTEGER
01200 TDZA C,C ;SET # DECIMAL PLACES TO 0
01300
01400 IDPB B,LPNT ;PUT AWAY
01500 GETLUP: TLNN A,DIG ;IS IT A DIG?
01600 POPJ P, ; NO, RETURN
01700 MOVEI TEMP,-"0"(A) ;MAKE AN INTEGER
01800 EXCH TEMP,SCNVAL ;PREVIOUS VALUE SO FAR
01900 JFCL 17,.+1 ;CLEAR APR FLAGS
02000 XCT D ;COLLECT NUMBER
02100 ADDM TEMP,SCNVAL ;NEW NUMBER
02200 JOV [TLO SBITS2,INTOV
02300 JRST .+1] ;CHECK AND RECORD OVERFLOW
02400 MOVEI TEMP,-"0"(A) ;MAKE A FLOATING ONE
02500 FSC TEMP,233 ;FLOAT THIS DIG
02600 EXCH TEMP,FLTVAL
02700 FMPR TEMP,[10.0]
02800 FADRM TEMP,FLTVAL ;NEW NUMBER
02900 JFOV [TLO SBITS2,REALOV
03000 JRST .+1] ;CHECK REAL OVERFLOW
03100 SUBI C,1 ;COUNT DECIMAL PLACES
03200 ILDB B,PNEXTC ; GET ANOTHER
03300 SKIPGE A,SCNTBL(B) ;COULD IT STILL BE A DIGIT?
03400 PUSHJ P,(A)
03500 JRST GETLUP-1(TBITS2);LOOP
00100 Comment ⊗ Print the last character, then stack the result
00200 ⊗
00300
00400 LSTACK: LSTDPB
00500 JRST STACK
00600
00700 Comment ⊗ We have been backed up by the wonderful error routines
00800 in the parser. So now we return things to their normal states:
00900 ⊗
01000
01100 GOAGAIN: MOVE LPSA,SAVSEM
01200 SKIPA A,SAVPAR
01300
01400 DSCR CHAROUT -- returns value for single char operator.
01500 DES No Semantic stack entry is necessary (a null pointer
01600 is stacked). The indirect, address, and index fields
01700 of the character comprise its PL-ID.
01800 ⊗
01900
02000 CHAROUT:
02100 MOVEI LPSA,0 ;SEMANTICS RETURNED ARE NULL
02200
02300 DSCR STACK
02400 DES All SCANNER sub-sections return here to place Parse
02500 token on parse stack (PPDL) and Semantics on EXEC stack
02600 (GPDL). STACK is bypassed only by the string constant
02700 scanner when calling SCANNER recursively to modify for-
02800 mal parameters.
02900 ⊗
03000 STACK: HRRZS LPSA ;MAKE SURE ONLY RH
03100 TLZ A,777740 ;CLEAR SCANNER BITS
03200 PUSH SP,A ;PL ENTRY
03300 EXCH SP,GPSAV ;GET GP POINTER
03400 PUSH SP,LPSA ;SEMANTIC ENTRY
03500 EXCH SP,GPSAV ;PUT AWAY SEMANTIC POINTER
03600 MOVEM SP,PPSAV ;PUT AWAY PARSE POINTER
03700 SKIPN CNDLST ; IN FALSE PART OF COND. COMP.?
03800 POPJ P, ; NO, RETURN
03900 MOVE SBITS2,LPTRSV ; YES, DO NOT LIST - I.E. RESTORE LPNT
04000 MOVEM SBITS2,LPNT ;
04100 POPJ P,
04200
04300 DSCR INSET
04400 DES prepare for ID or STRING constant scan
04500 RES sets up TOPBYTE, REMCHR, PNAME, TOPSTR, C (char count)
04600 SID Uses TEMP
04700 ⊗
04800 ↑↑INSET: MOVEI C,0 ;CLEAR CHARACTER COUNT
04900 ;;#GI# DCS 2-5-72 REMOVE TOPSTR
05000 MOVSI TEMP,40 ; MOST HARMLESS ¬CONST BIT
05100 ;;#GI
05200 MOVEM TEMP,PNAME ;FIRST PNAME DESCRIPTOR WORD
05300 HLL TEMP,TOPBYTE(USER) ;ADJUST REMCHR FOR
05400 HRRI TEMP,[BYTE (7) 0,4,3,2,1,0] ;CHARACTERS SKIPPED
05500 ILDB TEMP,TEMP
05600 ADDM TEMP,REMCHR(USER) ;UPDATE REMCHR
05700
05800 SKIPL TEMP,TOPBYTE(USER) ;ADJUST TOPBYTE TO
05900 ADDI TEMP,1 ; WORD BDRY (440700 OK ALREADY)
06000 HRLI TEMP,440700 ;[POINT 7,WORD]
06100 MOVEM TEMP,PNAME+1 ;BP FOR THIS STRING
06200 MOVEM TEMP,TOPBYTE(USER) ;ADJUSTED TOPBYTE
06300 ;NOW GC CAN GO AHEAD AND HAPPEN
06400 POPJ P, ;ALL SET
06500 SUBTTL SCANNER I/O, MACRO EXPANSION
00100 DSCR CSPEC, SEOL, SEOM, SEOB -- Special handling routines
00200 PAR A contains address of appropriate routine. Many SCANNER
00300 state variables are perused and changed.
00400 RES PNEXTC, SAVCHR, and friends are set to proper values after
00500 more file has been read, macro has been returned from, etc.
00600 DES Called by SCANNER routines when an input char is detected
00700 whose SCNTBL entry indicates special conditions. The routine
00800 address is in the right half of this SCNTBL word.
00900 CSPEC is sometimes called to save the char count (C) before dis-
01000 patching to the special routine (for STRINGC integrity)
01100 SEOL is called when the SCANNER is reading from the input file
01200 or a macro and an end of of line condition is detected. A
01300 new line is found and the PNEXTC pointer is reinitialized.
01400 EOM is called when the SCANNER is reading a DEFINE body, and end
01500 of text (177 char) is seen. If the character following the EOT
01600 is non-zero, it indicates the right actual parameter to expand
01700 here. If it is 0, it signals end of macro. Old input values are
01800 restored, things like PNEXTC and SAVCHR.
01900 SEOB is called when a 0 is detected while scanning. This can mean
02000 two things -- a TECO-type file is being read, and a buffer has
02100 ended in the middle of a line, or the string scanner has called
02200 SCANNER recursively to pick up a possible formal param. In either
02300 case the right thing happens.
02400 SEE ADVBUF routine, which these call for for file input
02500 ⊗
02600 ZERODATA (SCANNER INPUT/OUTPUT VARIABLES)
02700 ;LINNUM -- physical line number of this output line. Used
02800 ; to force page ejects and new sub-numbering when too
02900 ; many have gone out since last logical page encountered
03000 ?LINNUM: 0
03100
03200 ?LNCREF: 0 ;IF ON, CREF INFO HAS GONE OUT FOR THIS LINE
03300
03400 COMMENT ⊗
03500 LPNT -- byte pointer used to deposit characters in output
03600 buffer (LSTBUF) -- SEOL code transfers this data, along
03700 with CREF data, to the output file buffers. IDPB B,LPNT
03800 instructions are scattered throughout the SCANNER to build
03900 this output file
04000 ⊗
04100 ↑↑LPNT: 0
04200
04300 ↑↑LSTBUF: 0 ;ADDRESS OF LISTING BUFFER
04400
04500 ;LSTCHR -- saved scan-ahead character -- sometimes slightly different
04600 ; from SAVCHR -- used for error message (the arrow) output
04700 ↑↑LSTCHR: 0
04800 ENDDATA
00100 SUBTTL Cspec, Seol
00200
00100 ; CALL SPECIAL ROUTINE, BUT FIRST MAKE SURE CHARACTER COUNT IS
00200 ; CORRECT IN "PNAME" (THE DESCRIPTOR FOR THE CURRENTLY DEVELOPING
00300 ; IDENTIFIER OR STRING)
00400
00500 CSPEC: HRRM C,PNAME ;UPDATE CHAR COUNT
00600 JRST (A) ;DISPATCH TO SPECIFIED ROUTINE
00700
00800 SEOL:
00900 PUSH P,C ;SAVE CHARACTER COUNT (CLOBBERED BY HDROV)
01000 TRNE TBITS2,NOLIST ;ARE WE LISTING NOW?
01100 JRST NOLST ; NO
01200
01300 ; TIME TO DO A LISTING
01400
01500 MOVE TBITS,LPNT ;PUT THE LINE FEED IN LIST BUFFER
01600 LLL2: IDPB B,TBITS
01700 MOVEI B,0 ;ZERO REMAINING CHARS OF CURRENT WORD
01800 TLNE TBITS,760000 ;ALL DONE?
01900 JRST LLL2 ;NO, PUT OUT ZERO
02000 MOVEM TBITS,LPNT ;SAVE AGAIN FOR A WHILE
02100
02200 ;IF CREFING WAS DONE ON THIS LINE, TERMINATE THE CREF STUFF
02300 SKIPN LNCREF ;CREF GONE OUT?
02400 JRST NOLNX ;NOPE
02500 SETZM LNCREF ;RESET.
02600 MOVEI TBITS,177 ;DELETE
02700 PUSHJ P,CHROUT
02800 MOVEI TBITS,"A" ;AND AN A
02900 PUSHJ P,CHROUT
03000 NOLNX:
03100
03200 ; IF PCNT OUTPUT DESIRED, DO THAT FIRST
03300
03400 TLNN TBITS2,PCOUT ;WANT TO PRINT PC?
03500 JRST NOPC ; NO
03600
03700 MOVE TBITS,PCNT ;YET ANOTHER FRNP
03800 ADD TBITS,LSTSTRT ;OFFSET BY USER-PROVIDED LOC
03900 MOVEI B,CHROUT ;ROUTINE TO USE
04000 MOVEI PNT2,6 ;ALWAYS DO 6 CHARS
04100 PUSHJ P,[
04200 ↑FRNP1: SKIPA TEMP,[10]
04300 ↑FRNPD: MOVEI TEMP,=10
04400 FRNP3: IDIV TBITS,TEMP
04500 IORI SBITS,"0"
04600 HRLM SBITS,(P)
04700 SOJE PNT2,FRNP2
04800 PUSHJ P,FRNP3
04900 FRNP2: HLRZ TBITS,(P)
05000 JRST (B) ;CHARACTER TO OUTPUT
05100 ]
05200 MOVE SBITS,[POINT 7,[ASCII / /]]
05300 PUSHJ P,LL1+1 ;SEE BELOW
05400
05500 ; IF LINE NUMBER OUTPUT DESIRED, DO IT NEXT.
05600
05700 NOPC: MOVE SBITS,[POINT 7,ASCLIN] ;ASSUME WANT LINE NUMBER
05800 TLNE TBITS2,LINESO ;IS IT THE CASE
05900 PUSHJ P,[LL1: PUSHJ P,CHROUT ;CHARACTER TO OUTPUT
06000 ILDB TBITS,SBITS ;NEXT CHAR
06100 JUMPN TBITS,LL1
06200 POPJ P,]+1 ;KLUDGE........
06300
06400 ; NEXT LINE UP THE BP FOR SOME RAPID-FIRE STUFF
06500
06600 NLNO: MOVE TBITS,LSTPNT ;LST OUTPUT BYTE POINTER
06700 MOVE SBITS,LSTCNT ;IF ALREADY LINED UP....
06800 HARRY: TLNN TBITS,760000 ;LINED UP WHEN PTR PART IS 01
06900 JRST LNDUP
07000 SOS SBITS,LSTCNT ;DENOTE CHANGE
07100 IBP TBITS ;MAINLY WANT TO ADJUST COUNT
07200 JRST HARRY ;COULD PROBABLY DO CALCULATION
07300
07400 LNDUP: MOVEM TBITS,LSTPNT ;UPDATE
07500 IDIVI SBITS,5 ;#WORDS LEFT, NO REMAINDER GUARANTEED
07600 AOS PNT2,LPNT ;WE GOT THIS FAR
07700 HRRZS PNT2
07800 SUB PNT2,LSTBUF ;HOW MANY WORDS?
07900 CAMGE SBITS,PNT2 ;IS THERE ROOM?
08000 PUSHJ P,LSTDO ; NOW THERE IS
08100 MOVNI SBITS,5 ;UPDATE CHAR COUNT
08200 IMUL SBITS,PNT2
08300 ADDM SBITS,LSTCNT
08400 EXCH PNT2,LSTPNT ;AND LSTPNT
08500 ADDM PNT2,LSTPNT ;PREV VERSION IN PNT2
08600 ADDI PNT2,1
08700 HRL PNT2,LSTBUF ;BLT WORD (LSTBUF,,OUTBUF)
08800 BLT PNT2,@LSTPNT ;WRITE THE LINE!
08900 HRRO TEMP,LSTBUF ;ADDR OF FIRST WORD OF BUFFER
09000 SUB TEMP,[XWD 677077,1] ;POINT 5,@LSTBUF,29
09100 MOVEM TEMP,LPNT ;NEW LIST POINTER
09200 MOVE TEMP,[ASCID / /] ;BLANKS IN CASE
09300 MOVEM TEMP,ASCLIN ;IN MACRO AND MORE LINES TO COME
09400 AOS TBITS,LINNUM ;CHECK LINE OVERFLOW
09500 IDIVI TBITS,PGSIZ
09600 SKIPN SBITS
09700 PUSHJ P,HDROV ;PRINT FF
00100
00200 ; ENOUGH OUTPUT, NOW FOR SOME INPUT
00300
00400 NOLST:
00500 SKIPE SRCDLY ;SWITCHING SOURCE INPUT?
00600 JRST NXTSRC ; YES
00700
00800 MOVE PNT,PNEXTC
00900 IBP PNT
01000 MOVEM PNT,PLINE ;UPDATE IF MACRO
01100 TLNE TBITS2,MACIN ;DONE IF MACRO
01200 JRST LDO1 ;DONE
01300
01400 ; MAKE A LINE NUMBER IN CASE FILE HAS NONE
01500 AOS TBITS,BINLIN ;SEQUENTIAL WITHIN PAGE
01600 MOVEI B,[IDPB TBITS,A ;ROUTINE TO DISPENSE CHARS
01700 POPJ P,]
01800 MOVEI PNT2,5 ;5 CHARS ALWAYS
01900 MOVE A,[POINT 7,ASCLIN] ;PUT IT HERE
02000 PUSHJ P,FRNPD ;GET ASCII VERSION
02100 MOVEI TEMP,1
02200 ORM TEMP,ASCLIN ;MAKE ASCID
02300 ; ACTUAL LINE NUMBER WILL OVERRIDE THIS IF THERE
02400
02500 LDB TEMP,PNT ;NEXT CHAR.
02600 JUMPE TEMP,NULCHR ;GO FIND NON-NULL
02700 LINCHA: MOVE TEMP,(PNT)
02800 LINCHK: TRNN TEMP,1 ;ARE WE IN LINE NUMBER?
02900 JRST LDUNA ;NO THIS IS THE NEXT CHAR.
03000 CAME TEMP,[ASCID/ /];IS IT A PAGE MARK PERHAPS
03100 AOJA PNT,LDUN ;NO JUST SKIP LINE NUM AND TAB
03200 MOVEM PNT,PNEXTC ;HDR CLOBBERS THIS
03300 PUSHJ P,HDR ;WRITE PAGE MARK, NEW TITLE LINE
03400 MOVE PNT,PNEXTC ;GET HIM BACK
03500 SKIPN 1(PNT) ;END OF BUFFER?
03600 PUSHJ P,ADVBUF ;YES, GET NEXT.
03700 ADDI PNT,1 ;POINT BEHIND NEXT LINE NUMBER
03800 SKIPN TEMP,1(PNT) ;IS IT IN THIS BUFFER?
03900 PUSHJ P,ADVBUF ;NO.
04000 HRLI PNT,350700 ;POINT TO FIRST CHAR. OF LINE NUMBER
04100 AOJA PNT,LINCHA ;AND DO IT AGAIN (IN CASE 2 PAGE MARKS).
04200
04300 NULCHR: ILDB B,PNT ;MOVE ON UP
04400 MOVE TEMP,(PNT) ;GET COMPLETE WORD
04500 JUMPN B,LINCHK ;FINALLY WE GOT SOMETHING
04600 IBP PNEXTC ;KEEP IN STEP
04700 JUMPN TEMP,NULCHR ;END OF BUFFER?
04800 PUSHJ P,ADVBUF ;YES.
04900 JRST NULCHR ;HERE WE GO LOOP-D-LOOP
05000
05100 LDUN: SKIPE (PNT) ;IS TAB IN THIS BUFFER
05200 JRST LDUN1 ;YES
05300 PUSHJ P,ADVBUF ;NO
05400 IBP PNT ;MAKE IT CURRENT
05500 LDUN1: MOVEM TEMP,ASCLIN ;CURRENT LINE#
05600 MOVEM PNT,PNEXTC ;THIS GUY POINTS TO TAB
05700 LDUNA: MOVE TEMP,PNEXTC ;MAY NOT USE PNT
05800 MOVEM TEMP,PLINE ;BEGINNING OF LINE
05900 IFN FTDEBUG,<
06000 AOS LINCNT ;COUNT NUMBER OF LINES SEEN
06100 SKIPL STPAGE ;ARE WE LOOKING FOR A PAGE/LINE?
06200 PUSHJ P,STPLIN ;LINE BREAK IF NECESSARY.
06300 >
06400 LDO1: MOVEI B,12 ;GET LINE FEED BACK.
06500 MOVEI A,0 ;HARMLESS LF
06600 MOVE USER,GOGTAB
06700 POP P,C ;RESTORE CHARACTER COUNT.
06800 POPJ P, ;WASN'T THAT WONDERFUL
06900
07000
07100 ; HERE WE SAVE INFO ABOUT SOURCE FILE, AND PREPARE TO GET INFO
07200 ; ABOUT NEW ONE.
07300
07400 NXTSRC: MOVE A,AVLSRC ;BITS TELLING FREE CHANNELS
07500 JFFO A,GOTNEW ;FOUND A FREE ONE
07600 ERR <NO MORE AVAILABLE SOURCE CHANNELS>
07700 GOTNEW:
07800 PUSH P,B ;SAVE NEW CHANNEL #
07900 MOVEI C,ENDSRC-SRCCDB+1 ;SIZE OF SAVE AREA
08000 PUSHJ P,CORGET ;GET ONE
08100 ERR <NO CORE AVAILABLE FOR FILE SWITCH>
08200 HRR TEMP,B ;BLT WORD
08300 HRLI TEMP,SRCCDB
08400 BLT TEMP,ENDSRC-SRCCDB(B)
08500 HRRZM B,SWTLNK ;SAVE PTR TO SAVE AREA
08600 TLO TBITS2,INSWT ;WE'RE SCANNING SWITCHED-TO FILE
08700 MOVEM TBITS2,SCNWRD
08800 FOR II IN (LSTCHR,SAVCHR,SAVTYI,EOF,EOL) <
08900 SETZM II
09000 >
09100 POP P,A ;CHANNEL NUMBER
09200 FOR II←0,1 <
09300 DPB A,[POINT 4,SRCOP+II,12]
09400 >
09500 FOR II←0,3 <
09600 DPB A,[POINT 4,INSRC+II,12]
09700 >
09800 NOEXPO <
09900 DPB A,[POINT 4,SRCOP+2,12] ;PUSHJ IF EXPO
10000 >;NOEXPO
10100 MOVN TEMP,A ;-CHANNEL NUMBER
10200 MOVSI LPSA,400000 ;BIT
10300 LSH LPSA,(TEMP)
10400 ANDCAM LPSA,AVLSRC ;THIS CHANNEL UNAVAILABLE
10500 AOS TEMP,LININD ;HOW FAR IN TO SPACE ON TTY
10600 CAILE TEMP,MAXIND ;TOO FAR?
10700 SOS LININD ;NOT REALLY
10800 SETOM TYICORE ;WILL SCAN FROM STRING
10900 MOVE TEMP,GENLEF+2
11000 ;; %AN% CHECK TO BE SURE STRING CONSTANT, SINCE PRODUCTIONS NO LONGER CHECK
11100 MOVE TEMP,$TBITS(TEMP)
11200 TRNN TEMP,STRING
11300 ERR <SOURCE!FILE NAME MUST BE STRING>
11400 MOVE TEMP,GENLEF+2
11500 ;; %AN%
11600 HRROI TEMP,$PNAME+1(TEMP) ;GET STRING TO BE SCANNED
11700 POP TEMP,PNAME+1
11800 POP TEMP,PNAME ;PUT ER THERE
11900 PUSHJ P,ENDSWT ;USE EOF CODE TO GET NEW FILE
12000 ;SRCDLY WILL BE TURNED OFF HERE
12100 JRST NOLST ;AND GO BACK TO END OF LINE CODE
00100 ; END OF BUFFER CODE.
00200
00300 SEOB: TLNE TBITS2,LOKPRM ;END OF POSSIBLE MACRO PARAM SCAN?
00400 POPJ P, ;YES, IGNORE THE WHOLE THING
00500 MOVE PNT,PNEXTC ;CURRENT BP
00600 JUMPE PNT,ADVIT ;INITIALIZATION TIME
00700 SKIPE TEMP,(PNT) ;REAL END OF BUFFER?
00800 JRST SEOBAK ; NO, WILL COME BACK UNTIL NOT NULL
00900 ADVIT:
01000 ;; #PF# SUPPLY CORRECT NUMBER OF THINGS ON STACK IN CASE ADVBUG DOESN'T RETURN
01100 PUSH P,C
01200 PUSHJ P,ADVBUF
01300 POP P,C
01400 ;; #PF#
01500 TRNN TEMP,1 ;LINE NUMBER? (INIT SCAN FOR SOS FILES)
01600 JRST SEOBAK ;NO, FIND NEXT CHAR
01700 MOVEM TEMP,ASCLIN ;SAVE LINE NUMBER
01800 IBP PNT ;OVER TAB
01900 ADDI PNT,1 ;BACK IN BUSINESS
02000 SEOBAK: MOVEM PNT,PLINE ;BEGINNING OF LINE
02100 ILDB B,PNT ;GET CHAR
02200 MOVEM PNT,PNEXTC ;UPDATE
02300 SKIPGE A,SCNTBL(B) ;SPECIAL?
02400 JRST (A) ;YES, HANDLE
02500 POPJ P, ;NO, DONE
02600
02700 ; END OF PAGE (TECO FILES ONLY)
02800
02900 SEOP: PUSHJ P,HDR ;PRINT FF, TITLE LINE
03000 ;; #PC#! OVERWRITING FIRST LINE OF CREF
03100 MOVEI B,0 ;PRETEND A NULL CHARACTER
03200 MOVEI A,0 ;BITS FOR CR
03300 POPJ P,
00100 Comment ⊗ Parameter delimiter or end of message ⊗
00200
00300 EOM: ILDB B,PNEXTC ;CHECK WHICH
00400 SKIPN ASGFLG ;ASSIGNC PARAMETER NUMBER?
00500 JRST CONEOM ;NO,
00600 MOVE LPSA,B ;RETURN THE PARAMETER NUMBER IN THE
00700 MOVE A,%NUMCON ; SEMANTIC STACK
00800 SUB P,X11 ; TO OVERRIDE THE PUSHJ HERE
00900 JRST STACK ;
01000 CONEOM: JUMPE B,RESTOR ;ZERO, END OF MACRO (OR PARAM) TEXT
01100
01200 ; PARAMETER NEEDED
01300
01400 SETZM SAVCHR
01500 SETZM LSTCHR
01600 MOVE LPSA,DEFRNG
01700 GETIT: SOJE B,GOTIT ;LOOK FOR THE PARAMETER OF PROPER NUMBER
01800 RIGHT ,%RVARB,<[ERR <NOT ENOUGH ARGUMENTS SUPPLIED TO MACRO>]>
01900 JRST GETIT ;KEEP LOOKING
02000
02100 GOTIT:
02200 DFNEST: MOVE PNT,DEFPDP ;NOW SAVE STATE OF SCANNER AND RECUR
02300 PUSH PNT,DEFRNG ; SAVE DEFRNG WHICH CONTAINS THE LENGTH OF THE
02400 PUSH PNT,PNEXTC-1 ; ACTUAL PARAMETER TO BE EXPANDED. THIS WILL
02500 ; ENSURE THAT WHEN A RETURN IS MADE FROM
02600 ; EXPANDING THE ACTUAL THERE WILL BE ENOUGH
02700 ; STRING SPACE FOR THE REST OF THE MACRO.
02800 PUSH PNT,PNEXTC ;INPUT POINTER
02900 PUSH PNT,SAVCHR ;SCANNED AHEAD
03000 MOVEM PNT,DEFPDP ;SAVE POINTER
03100 PUSHJ P,SGCOL1 ;MAKE SURE ENOUGH ROOM
03200 HLLZ TEMP,$PNAME(LPSA) ;STRING NUMBER
03300 MOVEM TEMP,PNEXTC-1
03400 MOVEM TEMP,PLINE-1
03500 MOVEW PNEXTC,$PNAME+1(LPSA) ;NEW INPUT POINTER
03600 MOVEM TEMP,PLINE
03700 MOVEI B,"<" ;MARKER FOR MACRO EXP
03800 TLNE TBITS2,LSTEXP ;WANT IT?
03900 IDPB B,LPNT ;YES
04000 TLO TBITS2,MACIN ;MARK IN MACRO
04100 TLNN FF,PRMSCN ; IF SCANNING ACTUALS, THEN LEAVE LISTING ALONE
04200 TRZ TBITS2,NOLIST ;ASSUME LISTING
04300 TLNN TBITS2,MACEXP ;EXPANDING?
04400 TRO TBITS2,NOLIST ;NO
04500 MOVEM TBITS2,SCNWRD ;UPDATE
04600 TLNE FF,PRMSCN ; SCANNING PARAMETERS?
04700 SKIPN REQDLM ; YES, IN SPECAIL DELIMITER MODE?
04800 JRST NEWCHR ;GO GET FIRST NEW CHAR, RET
04900 CAIN P,DSPRMS+3 ; IS 177-# FIRST ITEM IN ACTUAL PARAMETER
05000 HRRI P,BALCHK ; YES, CHANGE RETURN ADDRESS TO REFLECT
05100 ; THAT UNTESTED COMMAS AND RIGHT PARS. WILL
05200 ; BREAK SCAN
05300 DLMPRM: ILDB B,PNEXTC ; SCAN REST OF CHARS. INTO STRING CONSTANT
05400 SKIPGE A,SCNTBL(B) ; SPECIAL?
05500 ;; #OG# ! MAKE SURE PNAME COUNT VALID IN CASE OF REAL GARBAGE COLLECT
05600 PUSHJ P,CSPEC ; DO IT
05700 LSTDPB ; PUT IT AWAY
05800 IDPB B,TOPBYTE(USER) ; DEPOSIT IT
05900 AOJA C,DLMPRM ; INCREMENT COUNT AND CONTINUE SCAN
06000
06100 RESTOR: MOVE PNT,DEFPDP
06200 POP PNT,SAVCHR ;CHAR SCANNED AHEAD
06300 POP PNT,PNEXTC ;OLD INPUT POINTER
06400 POP PNT,PNEXTC-1 ;STRING NUMBER
06500 ADD PNT,X22 ;START PLINE HERE
06600 POP PNT,PLINE
06700 POP PNT,PLINE-1
06800 POP PNT,LPSA ;PERHAPS OLD DEFRNG
06900 MOVEM PNT,DEFPDP
07000 HLRZ TBITS,LPSA ; GET LENGTH OF MACRO TO WHICH ONE IS RETURNING AND
07100 PUSHJ P,SGCOL2 ; INSURE ENOUGH ROOM IN STRING SPACE FOR IT
07200 EXCH LPSA,DEFRNG ; GET OLD DEFRNG VALUE AND IF DIFFERENT FROM CURRENT
07300 CAMN LPSA,DEFRNG ; VALUE THEN ONE IS DONE WITH THE MACRO AND THUS
07400 JRST DDUN ; RING OF ACTUAL PARAMETERS (POINTED TO BY DEFRNG)
07500 HRRZS LPSA ; IS REMOVED FROM THE STRING RING. NOTE THAT
07600 PUSHJ P,KILLST ; KILLST EXPECTS LPSA WITH ZERO IN THE LEFT HALF.
07700
07800 DDUN: MOVEI B,">" ;END OF EXPANSION MARKER
07900 TLNE TBITS2,LSTEXP
08000 IDPB B,LPNT ;PUT OUT IF DESIRED
08100 SKIPN PNEXTC-1 ;OUT OF MACROS?
08200 TLZA TBITS2,MACIN ;YES
08300 JRST DUNRST ;NO
08400 TLNE FF,LISTNG ;WANT LISTING, IN GENERAL?
08500 TRZ TBITS2,NOLIST ;YES, START UP AGAIN
08600 MOVE TEMP,IPLINE ;PLINE TO OUTER LEVEL VALUE
08700 MOVEM TEMP,PLINE
08800 SETZM PLINE-1
08900
09000 DUNRST: MOVEM TBITS2,SCNWRD ;SAFETY FIRST
09100
09200 ; NOW GET A CHARACTER FOR THE SCANNER
09300
09400 TLNE FF,PRMSCN ; SCANNING PARAMETERS?
09500 SKIPN REQDLM ; YES, IN SPECIAL DELIMITER MODE?
09600 TRNA ; SKIP
09700 SUB P,X11 ; POP RETURN ADDRESS, AND NOW WILL RETURN
09800 ; TO CHECK NESTING INSTEAD OF CONTINUING
09900 ; FORMAL PARAMETER SCAN
10000 SKIPN B,SAVCHR ;HAVE IT ALREADY?
10100 JRST NEWCHR ;NO
10200 SETZM SAVCHR ;NO LONGER AHEAD (DCS 5-27-71)******
10300 MOVE A,SCNTBL(B) ;YES, DON'T DISPATCH AGAIN
10400 POPJ P,
10500
10600 NEWCHR: ILDB B,PNEXTC ;GET FROM INPUT
10700 SKIPGE A,SCNTBL(B) ;SPECIAL?
10800 JRST (A) ;YES, DISPATCH
10900 POPJ P, ;NO, DONE
11000
11100 DSCR KILLST
11200 CAL PUSHJ
11300 PAR LPSA ptr to first Semblk to be released
11400 RES Unlinks Semblk from %RSTR, releases it to free
11500 storage, then continues right down %RVARB until
11600 all Semblks on this VARB-Ring are released.
11700 DES THIS ROUTINE IS IN THE WRONG PLACE!
11800 SEE FREBLK, ULINK
11900 ⊗
12000
12100 ↑KILLST:
12200 PUSH P,LPSA
12300 JUMPE LPSA,KLPDUN
12400
12500 KLLUP:
12600
12700 PUSHJ P,URGSTR ;UNLINK FROM STRING RING
12800 FREBLK
12900 RIGHT ,%RVARB,<[KLPDUN: POP P,LPSA
13000 POPJ P,]>
13100 JRST KLLUP
13200 SUBTTL SCANNER INPUT AND LISTING ROUTINES
00100 DSCR ADVBUF -- new input buffer routine
00200 DES Reads a new input buffer, gets a new source file
00300 if this one is exhausted or if file switching is
00400 happening (prints loser message if no files remain),
00500 and assures that the buffer ends in zero for EOB
00600 detection by SEOL. The buffers were made long enough
00700 to allow the inclusion of an extra word of zero.
00800 SID Saves USER, C -- reinits A,B -- all others vulnerable
00900 SEE SEOL, SEOB, routines which detect EOB and call ADVBUF.
01000 ⊗
01100
01200 ADVBUF:
01300 XCT INSRC ;ADVANCE BUFFER
01400 XCT TSTSRC ;ANY ERRORS?
01500 ERR <I-O ERROR ON SOURCE DEVICE>,1
01600 XCT EOFSRC ;TO ENDFL ON EOF
01700 JRST ENDFL
01800 PUSHJ P,SGCHK ;STRING GC, IF NECESSARY, TBITS←SRCCNT
01900 ADDI TBITS,4 ;(CHAR CT+4)/5 IS WORD COUNT
02000 IDIVI TBITS,5
02100 ADD TBITS,SRCPNT ;ADD BASE ADDRESS
02200 IBP TBITS ;PTR TO LAST WORD+1, MAKE 0 TO
02300 SETZM (TBITS) ; DENOTE EOB
02400 MOVE PNT,SRCPNT ;RESET PNT TO CURRENT BP,
02500 MOVEM PNT,PNEXTC ;FIX THIS GUY TOO.
02600 MOVE TEMP,1(PNT) ; TEMP TO WORD NEXT REFERENCED
02700 POPJ P,
02800
02900 ; CHECK FOR STRING SPACE FULL, GC IF SO
03000
03100 SGCHK:
03200 HRRZ TBITS,SRCCNT ;GET # OF CHARACTERS
03300 MOVE TEMP,REMCHR(USER) ;TEST ENOUGH ROOM
03400 ADD TEMP,TBITS
03500 SKIPL TEMP ;IS THERE ENOUGH?
03600 JRST SGCOL ;NO, COLLECT SPACE
03700 POPJ P, ;NOT NECESSARY
03800
03900 ENDFL: XCT RELSRC ;RELEASE OLD FILE,
04000 ENDSWT: MOVEM TBITS2,SCNWRD ;UPDATE IN CORE VERSION
04100 PUSHJ P,FILEIN ;FIND AND INIT NEW ONE
04200 JRST [TLNN TBITS2,EOFOK
04300 ERR <FATAL END OF SOURCE FILE>
04400 MOVNI B,1 ;MARK END OF FILE NEXT TIME
04500 MOVEI A,1 ;HARMLESS, BUT BREAKS IGNORABLE
04600 SUB P,X11 ;RETURN EARLY
04700 POP P,C ;CHAR COUNT BACK
04800 POPJ P,]
04900 PUSHJ P,MAKT ;PREPARE NEW TITLE LINE
05000 SKIPE SRCDLY ;COMING BACK FROM SWTCHED-TO FILE?
05100 JRST SWTBKP ; YES, DO MORE BOOKKEEPING
05200 SETZM FPAGNO ;FIRST PAGE IN NEW FILE
05300 PUSHJ P,HDR ; , DENOTE IT
05400 JRST ADVBUF ; OR PRINT LOSING MESSAGE, TRY AGAIN
05500 ; WE HAVE OLD SOURCE FILE BACK, FAKE ADVBUF
05600 SWTBKP:
05700 PUSHJ P,HDROV ;CONTINUE PAGE NUMBERING FOR FILE
05800 SETZM SRCDLY
05900 PUSHJ P,SGCHK ;CHECK (LIBERALLY) FOR STRING SPACE FULL
06000 MOVE TEMP,PNEXTC ;NOW SET UP PNT, PNEXTC, AND TEMP AS
06100 SWTLUP: SKIPN (TEMP) ; THEY WOULD BE COMING OUT OF ADVBUF
06200 JRST ADVBUF ;WE WERE AT END OF BUFFER ANYWAY
06300 MOVE PNT,TEMP ;WE'RE GOING TO GET AHEAD OF SELVES
06400 ILDB TBITS,TEMP ;CHECK NULLS
06500 JUMPE TBITS,SWTLUP ;ALL THIS UNECESSARY IF SOS FILES, BUT...
06600 MOVEM PNT,PNEXTC ;FAKE ADVBUF
06700 MOVE TEMP,(TEMP) ;WORD WITH NON-NULL CHAR
06800 POPJ P,
00100 UPDCNT: HRRM C,PNAME ;UPDATE PNAME
00200 ADDB C,REMCHR(USER) ;AND REMCHR
00300 CAMGE C,[-=50] ;ARE WE NEARING CATASTROPHE?
00400 POPJ P, ; NO
00500 ;EVEN THIS CANNOT PREVENT OCCASIONAL DEATH
00600 MOVEI TBITS,=50 ;REQUIRE AT LEAST THIS MANY
00700 JRST SGCOL ;GO COLLECT
00800
00900 SGCOL1: HRRZ TBITS,$PNAME(LPSA) ;CHAR COUNT
01000 SGCOL2: MOVE USER,GOGTAB
01100 MOVE TEMP,REMCHR(USER) ;REMAINING CHARS
01200 ADD TEMP,TBITS
01300 SKIPGE TEMP ;NOT ENOUGH?
01400 POPJ P, ;NO, OK
01500
01600 SGCOL: EXCH SP,STPSAV ;GET STRING STACK
01700 PUSH P,TBITS ;PASS TO STRGC THIS WAY
01800 PUSHJ P,STRGC ;COLLECT STRING SPACE
01900 ;;#QO# -- BE SURE PNAME STAYS TOGETHER 1-25-74 RHT
02000 EXTERN .SONTP
02100 PUSH SP,PNAME
02200 PUSH SP,PNAME+1
02300 PUSH P,[0]
02400 PUSHJ P,.SONTP
02500 POP SP,PNAME+1
02600 POP SP,PNAME
02700 ;;#QO#
02800 EXCH SP,STPSAV ;GET IT BACK
02900 POPJ P, ; NO, GO AHEAD
03000
03100 ?CHROUT: SOSG LSTCNT ;ONE CHAR OUTPUT ROUTINE
03200 PUSHJ P,LSTDO ;DO AN OUTPUT
03300 IDPB TBITS,LSTPNT ;DO THE OUTPUT
03400 POPJ P,
03500
03600 ?LSTDO: OUT LST,
03700 POPJ P, ;OK
03800 ERR <I-O ERROR ON LISTING DEVICE>,1
03900 POPJ P,
00100 DSCR --HERE IS THE CREFFINF STUFF (STRANGE PLACE N'EST CE PAS?)
00200 DES We'll leave it at these comments for the nonce:
00300 For those of you who are interested in what cref output looks like, allow
00400 me to discourse for a while on it. Basically, the output line is
00500 preceeded by a whole mess of garbage. (In the following discussion,
00600 let # stand for delete -- octal 177).
00700
00800 1. The first thing in a line with cref information in it must be
00900 #B . This is handled in crefout.
01000
01100 2. There are two types of symbols:
01200 a. NUMSYM's, which are represented by a six-digit number(decimal)
01300 which is unique to that occurrance of the symbol.
01400 The number is represented by an octal 6 (length of symbol)
01500 followed by the number in ASCII.
01600 b. SYMSYM's, which are the real symbolic symbols. These consist
01700 of one byte of length, followed by the symbol in ASCII
01800
01900 3. When an identifier is seen in the source text, you do one of
02000 several things:
02100 1 followed by the NUMSYM -- a regular identifer seen.
02200 3 followed by the SYMSYM -- a reserved word.
02300 5 followed by the NUMSYM -- a macro use.
02400 -- it is occasionally to flush the last type 1 instance. This is done
02500 by following it immediately with a 7.
02600
02700 4. When defining things, we put out:
02800 1 followed by the NUMSYM followed by 2 -- ordinary identifier
02900 6 followed by NUMSYM -- macro.
03000
03100 5. When beginning a block, we put out a 15 followed by the SYMSYM.
03200 6. When ending a block, we put out a 16 followed by the SYMSYM.
03300 Then come the equivalences of numbers and symbolic names.
03400 7. To equivalence an ordinary symbol, we put out 11 followed by
03500 the NUMSYM followed by the SYMSYM.
03600
03700 8. When all done with the cref information for a line, we put out
03800 #A .
03900 ⊗
04000
04100 BEGIN CREF
04200
04300 ↑LCREFIT:
04400 TDZA C,C
04500 ↑ECREFIT: MOVNI C,1 ;CREF FOR ENTER.
04600 SKIPE CNDLST ; IN FALSE PART OF CONDITIONAL COMPILATION?
04700 POPJ P, ; YES, DO NOT CREF
04800 TLNN TBITS,CNST ;IF A CONSTANT, FORGET IT.
04900 TLNE FF,NOCRFW ;AN EXTERNAL PROCEDURE -- DO NOT CREF;
05000 POPJ P,
05100 MOVE A,X11 ;ORDINARY IDENTIFIER.
05200 TLNE TBITS,DEFINE ;IF THIS IS A MACRO.
05300 MOVE A,[XWD 6,5]
05400 TLNE TBITS,400000 ;RESERVED WORD?
05500 MOVE A,X33
05600 TLNE C,-1 ;ENTER OR LOOKUP?
05700 MOVSS A
05800 PUSHJ P,CREFOUT ;AND PUT OUT THE CHARACTER.
05900 PUSHJ P,CREFSYM ;CREF THE SYMBOL IN LPSA,TBITS.
06000 TLNN A,-2 ;IF REGULAR SYMBOL,
06100 SKIPL C ;BEING DEFINED,
06200 POPJ P,
06300 MOVEI A,2 ;THEN PUT OUT EXTRA THING.
06400 JRST CREFOUT ;....
06500
06600
06700 CREFSYM: PUSH P,TBITS
06800 JUMPL TBITS,ASC1 ;A RESERVED WORD ----
06900 MOVEI TBITS,6
07000 PUSHJ P,CHROUT ;NUMBER OF CHARACTERS.
07100 MOVEI TBITS,(LPSA)
07200 MOVEI PNT2,6 ;FOR THE RECURSIVE NUMBER PRINTER IN SEOL.
07300 ;;#MF#! 5-1-73 DCS (1 OF 2) AC B NEEDED IN CALLER OF LCREFIT
07400 PUSH P,B
07500 MOVEI B,CHROUT ;OUTPUT ROUTINE FOR SAME --
07600 PUSHJ P,FRNP1 ; FRNP1 IS IN SEOL ABOVE.
07700 ;;#MF#! (2 OF 2) SAVE, RESTORE B
07800 POP P,B
07900 POP P,TBITS
08000 POPJ P, ;GO AWAY.
08100 ASC1: PUSH P,A
08200 PUSHJ P,CREFASC ;ASCII CREF.....
08300 POP P,A
08400 POP P,TBITS
08500 POPJ P,
08600
08700
08800 CREFCHR: CAIN A,30 ;UNDERLINE
08900 MOVEI A,"." ;CHANGE UNDERLINE TO .
09000 ↑↑CREFOUT: SKIPE LNCREF ;CREF GONE FOR THIS LINE?
09100 JRST GONEF ;YES
09200 SETOM LNCREF
09300 PUSH P,A
09400 MOVEI A,177
09500 PUSHJ P,CREFOUT
09600 MOVEI A,"B"
09700 PUSHJ P,CREFOUT
09800 POP P,A
09900 GONEF: SOSG LSTCNT
10000 PUSHJ P,LSTDO
10100 IDPB A,LSTPNT
10200 POPJ P,
10300
10400 ↑↑CREFASC: ;CREF THE ASCII FOR A SYMBOL.
10500 HRRZ A,$PNAME(LPSA) ;COUNT.
10600 PUSHJ P,CREFOUT ;AND CREF...
10700 MOVE TEMP,A
10800 MOVE C,$PNAME+1(LPSA) ;BYTE POINTER.
10900 ILDB A,C
11000 PUSHJ P,CREFCHR
11100 SOJG TEMP,.-2
11200 GPOPJ: POPJ P,
11300
11400 ↑↑CREFDEF: ;PUT OUT SYMBOL DEFINTION.
11500 MOVEI A,11 ;ORDINARY SYMBOL
11600 MOVE TEMP,$TBITS(LPSA)
11700 TLNE TEMP,DEFINE
11800 MOVEI A,13 ;FOR MACRO
11900 PUSHJ P,CREFOUT
12000 PUSHJ P,CREFSYM
12100 JRST CREFASC ;CODE,SYMBOL,PRINT-NAME.
12200
12300 ↑↑CREFBLOCK: ;END OF A BLOCK.
12400 MOVEI A,16
12500 PUSHJ P,CREFOUT
12600 JRST CREFASC ;AND THE NAME.
12700
12800
12900 BEND
00100 DSCR HDR, HDROV
00200 DES List routines for top of (physical page). Reset page,
00300 line counters. Print a page header if listing.
00400 HDR is called when new page (logical) is sensed.
00500 HDROV is called when PGSIZ lines have been printed
00600 since last time a header was printed.
00700 SID Uses D, TEMP,USER -- saves USER, C, others vulnerable.
00800 ⊗
00900
01000 ↑HDR:
01100 AOS PAGENO ;NEXT PAGE, PLEASE
01200 AOS FPAGNO ;NEXT IN THIS FILE
01300 SETZM PAGINC ;FIRST PHYSICAL PAGE NO
01400 SETZM BINLIN ;SEQUENTIAL LINE #
01500 AOS BINLIN ;ALWAYS STARTS AT 1
01600 ;;#HU# 6-20-72 DCS BETTER TTY LISTING
01700 SKIPN CRIND ;NEED CRLF/INDENT?
01800 JRST NCRIND ;NO
01900 SETZM CRIND
02000 TERPRI
02100 MOVE TEMP,LININD
02200 OUTSTR INDTAB(TEMP) ;CRLF -- INDENT
02300 NCRIND: PRINT < >
02400 DECPNT FPAGNO ;JUST KEEP TRACK
02500
02600 ↑HDROV:
02700 SETZM LINNUM
02800 AOS PAGINC ;HERE WHEN LINES OVERFLOW PAGE
02900 TLNN FF,LISTNG ;ARE WE LISTING?
03000 POPJ P, ; NO
03100
03200 PUSH P,D ;SAVE
03300
03400 MOVEI TEMP,"$"
03500 MOVEM TEMP,BKR ;$ BREAKS ASCFIL
03600 MOVE A,[POINT 7,TITLIN]
03700 MOVEI TEMP,=5*28 ;MAKE SURE ENOUGH ROOM REMAINS
03800 CAMLE TEMP,LSTCNT ;IS THERE
03900 PUSHJ P,LSTDO ;NOW THERE IS
04000 MOVEI D,14
04100 IDPB D,LSTPNT
04200 MOVE TEMP,LSTPNT
04300 PUSHJ P,ASCFIL ;INTERSPERSE CONSTANTS
04400 MOVE D,FPAGNO
04500 PUSHJ P,DECFIL
04600 MOVN D,PAGINC ; TO FORM HEADER LINE
04700 PUSHJ P,DECFIL
04800 PUSHJ P,ASCFIL
04900 MOVE LPSA,TTOP
05000 PUSHJ P,PSTRNG
05100 PUSHJ P,ASCFIL
05200 TLZ TEMP,770000 ;ADJUST BYTE POINTER
05300 EXCH TEMP,LSTPNT ;TO NEW LOC
05400 SUB TEMP,LSTPNT ;GET SIZE
05500 IMULI TEMP,5 ;NUMBER OF CHARS USED
05600 HRREI TEMP,-5(TEMP)
05700 ADDM TEMP,LSTCNT
05800 POP P,D
05900 POPJ P,
06000
06100 TITLIN: BLOCK =28 ;SHOULD BE BIG ENOUGH FOR TITLE LINE
06200
06300 ; MAKT -- PREPARE A TITLE LINE
06400
06500 ↑MAKT:
06600 MOVEI TEMP,"%"
06700 MOVEM TEMP,BKR ;% BREAKS ASCFIL
06800 MOVE A,[<POINT 7,[ASCII / SAIL %/]>]
06900 MOVE TEMP,[POINT 7,TITLIN]
07000 MOVEI LPSA,IPROC ;GET PROGRAM NAME
07100 PUSHJ P,[
07200 PSTRNG: HRRZ B,$PNAME(LPSA)
07300 MOVE C,$PNAME+1(LPSA)
07400
07500 MKT1: ILDB D,C
07600 IDPB D,TEMP
07700 SOJG B,MKT1 ;PUT OUT PROG NAME
07800 POPJ P, ]
07900
08000
08100 PUSHJ P,ASCFIL ;MOVE IN THIS MUCH
08200 MOVE A,[<POINT 7,[ASCII / %:% % $
08300 $
08400
08500 $%/]>]
08600
08700
08800 ; A AND TEMP SHOULD NOT BE USED HERE UNLESS SAVED
08900
09000 PUSH P,A
09100 CALL6 C,DATE
09200 IDIVI C,=31 ;DAY IN D
09300 ADDI D,1 ;DAY - 1 THAT IS
09400 PUSHJ P,DECFIL
09500 IDIVI C,=12 ;MONTH - 1 IN D
09600 MOVE D,[ASCII /-JAN--FEB--MAR--APR--MAY--JUN--JUL-/
09700 ASCII /-AUG--SEP--OCT--NOV--DEC-/](D)
09800 MOVE A,[POINT 7,D]
09900 MOVE D+1,[ASCII /%/]
10000 PUSHJ P,ASCFIL
10100 MOVEI D,=64(C) ;YEAR
10200 PUSHJ P,DECFIL
10300 POP P,A
10400 PUSHJ P,ASCFIL ;SPACES, I THINK
10500 CALL6 C,MSTIME ;TIME IN MS
10600 IDIVI C,=60000
10700 IDIVI C,=60 ;MINUTES IN D
10800 EXCH C,D
10900 PUSHJ P,DECFIL ;PRINT IT
11000 PUSHJ P,ASCFIL ;COLON
11100 MOVE D,C ;MINUTES
11200 PUSHJ P,DECFIL ;PRINT THEM
11300 PUSHJ P,ASCFIL ;MORE SPACES
11400 MOVE B,SRCFIL ;GET SOURCE FILE NAME
11500 MOVEI D,6 ;COUNT
11600 LLUP: ROTC B,6
11700 TRZ C,100 ;DITCH BIT
11800 ADDI C,40 ;CONVERT TO ASCII
11900 IDPB C,TEMP
12000 SOJN D,LLUP
12100 PUSHJ P,ASCFIL ;MORE SPACES AND THINGS
12200 POPJ P,
12300
12400 SUBTTL ENTERS -- ENTER A SYMBOL
00100 DSCR ENTERS -- make new symbol entry
00200 DES Will use existing comments, not use standard form
00300 ENTERS creates a block of proper type for this "ATOM", and
00400 installs the proper links to assure this thing can be found
00500 again. ENTERS can handle the following kinds of things:
00600 1. Variables -- numeric, STRING, ITEM, etc.
00700 2. Labels
00800 3. Procedure identifiers
00900 4. Numeric constants
01000 5. String constants
01100 STEPS:
01200 1-3: Create a block for ID. Check that level is greater
01300 for new symbol if old one was present (FORWARD Procedures
01400 are a special case). Install level, $TBITS, $PNAME; link
01500 to SYMTAB hash table (ptr to instr to fetch right bucket in HPNT).
01600 Link to current VARB structure via %RVARB, to STRRNG via
01700 %RSTR for STRINGC collector. Return ptr to Semantics in NEWSYM
01800 (replaces ptr to found block if redefinition).
01900 4: Insert numeric value entry in CONST bucket. No checking
02000 (level, etc.) is necessary because ENTERS is called for
02100 constants only when the lookup fails. Bucket fetching instr
02200 found in HPNT, new Semantics to NEWSYM.
02300 5: Insert new string constant entry in STRCON bucket. #4
02400 arguments also apply here.
02500
02600 PAR "BITS" -- the TBITS flags for the ATOM. These will be
02700 installed in the entry. They also guide the entry process.
02800
02900 "PNAME" -- String descriptor for $PNAME or String constant.
03000
03100 "SCNVAL" -- value of (1st word of) numeric constant. Second
03200 word, if any, is the adjacent word DBLVAL.
03300
03400 "HPNT" -- The instr which when executed will load LPSA with
03500 the correct bucket in the right half. SHASH, NHASH set up.
03600
03700 "NEWSYM" -- if ≠0, ptr to block matching PNAME or SCNVAL. This ptr
03800 is set by SCAN, STRINS, etc., using SHASH, NHASH. If -0,
03900 this is the first occurrence of the symbol.
04000
04100 Also, the prodef bit in ff is used to tell if the symbol is a formal param
04200
04300 RES "NEWSYM"←pointer to new block.
04400
04500 SID Uses A,C, TBITS, LPSA, TEMP; alters symbol table structure
04600 ⊗
00100 ↑ENTERS:
00200 MOVE TBITS,BITS ;TYPE BITS
00300 TLNE TBITS,CNST ;CONSTANT?
00400 JRST ENCNST ; YES
00500
00600 ; ENTER AN IDENTIFIER -- CHECK FOR RESERVED (ERROR), FORWARD
00700 ; PROCEDURE BEING DEFINED. CHECK LEVEL VALIDITY FOR REDEFINED
00800 ; SYMBOLS
00900
01000 ENIDNT:
01100 MOVE C,LEVEL ;CURRENT LEVEL OF DEFINITION
01200 SKIPG LPSA,NEWSYM ;IS THIS THE FIRST OCCURRENCE?
01300 JRST BRANEW ; YES
01400
01500 ;;#JZ# 11-4-72 HJS (1-2) CHANGE MACRO SCOPE
01600 ;;#JZ# THIS GROUP AND THE NEXT WERE INTERCHANGED
01700 SETCM TEMP,$TBITS(LPSA);PREVIOUS TYPE BITS, COMPLEMENTED
01800 SKIPL $TBITS(LPSA) ; CHECK FOR REDEFINITION OF A RESERVED WORD AS
01900 ; AS A MACRO (HJS 11-19-72)
02000 TLNN TBITS,DEFINE ;SPECIAL TREATMENT FOR REDEFINITION
02100 JRST NODEFN ; IT ISN'T ONE (HJS 11-19-72)
02200 ;; #LC# (1-17-73) HJS MACRO FORMAL,NOT MACRO REDEFINITION
02300 TLNE TBITS,FORMAL ;
02400 JRST NODEFN ;MACRO FORMAL, NOT MACRO REDEFINTION
02500 ;; #LC#
02600 TLNN TEMP,DEFINE ; WAS PREVIOUS DEFINITION ALSO A MACRO?
02700 SKIPN REDEFN ; YES, MACRO REDEFINITION?
02800 JRST NODEFN ; NO, GO CHECK LEVELS
02900 JRST DFEN1 ; IT IS ONE
03000 ;;#JZ# (1-2)
03100
03200 ;;#JZ# 11-4-72 HJS (2-2) WAS INTERCHANGED WITH ABOVE
03300 NODEFN: LDB A,PLEVEL ;OLD LEVEL OF DEFINITION (HJS 11-19-72)
03400 SKIPL $TBITS(LPSA) ;IF OLD WAS RESERVED WORD, THEN OK.
03500 CAMLE C,A ;C=CURRENT -- MUST BE GREATER
03600 JRST OKOLD ; AND IS
03700 CAME C,A ;IF =, MAY BE FORWARD COMING
03800 ERR <SAIL IN LEVEL TROUBLE>,1
03900 ;;#JZ# 2-2
04000
04100 CHKPRC: SETCM A,TBITS ;NEW BITS
04200 ;; SUGG BY R. SMITH LOAD A BEFORE TRNN
04300 TRNN TEMP,PROCED!FORWRD; MUST BE FORWARD PROCEDURE
04400 JRST ISPRC
04500 TLO A,OWN ;THIS IS SORT OF IRRELEVANT
04600 TLO TEMP,OWN
04700 TLOE TEMP,EXTRNL
04800 ERR <DUPLICATE IDENTIFIER DECLARATION>,1,BRANEW ; ISN'T ANY GOOD!
04900 TLC A,INTRNL ;SHOULD BE ON (=0), TURN OFF (=1) OR ON (ERROR)
05000 CAME A,TEMP
05100 ERR <DUPLICATE IDENTIFIER DECLARATION>,1,BRANEW ; ISN'T ANY GOOD!
05200 MOVEM TBITS,$TBITS(LPSA)
05300 PUSHJ P,URGVRB
05400 PUSHJ P,RNGVRB
05500 POPJ P,
05600
05700 ISPRC: TRNN TBITS,PROCED ;THIS SHOULD ALSO BE A PROCEDURE
05800 ERR <DUPLICATE IDENTIFIER DECLARATION FOR >,3,BRANEW
05900
06000 ; FORWARD PROCEDURE BEING DEFINED NOW, CHECK VALIDITY, CHANGE BITS
06100
06200 TRZE A,FORWRD ;TO MATCH OLD(COMPLEMENTED)
06300 TLNN A,EXTRNL ;MAKE SURE NOT DUPLICATE EXTERNAL
06400 ERR <DUPLICATE FORWARD/EXTERNAL DECLARATION FOR >,3,NOPROG
06500 ;;#JX#2! 11-2-72 DCS ALLOW INTERNAL PROC TO OVERRIDE EXTERNAL PROC.
06600 TLON TEMP,EXTRNL ;Turn off EXTRNL in old, but if it was on, flip
06700 TLC A,INTRNL ; INTRNL in new (will turn it off was on -- correct)
06800 ;;#JX#
06900 CAME A,TEMP ;CHECK MATCHING TYPES
07000 ERR <FORWARD TYPE DISAGREES>,1
07100 TRO TBITS,INPROG ;MARK PROCEDURE UNDER DEFINITION
07200 MOVEM TBITS,$TBITS(LPSA) ;STORE NEW
07300 NOPROG: PUSHJ P,URGVRB ;REMOVE FROM VARB RING
07400 PUSHJ P,RNGVRB ;PUT BACK ON THE END
07500 LEFT ,%TLINK,LPSERR ;PTR TO SECOND BLOCK
07600 LEFT (,%TLINK)
07700 ;;#GP# DCS 2-6-72 (2-4) CHECK OLD FORMALS AGAINST ACTUAL ONES
07800 HRRZM LPSA,OLDPRM ;SAVE OLD FORMALS -- USED TO KILLST HERE
07900 POPJ P, ;FOR A BIT LATER
08000 ;;#GP# (2)
08100
08200 ; REDEFINITION IF NOT A PARAMETER TO A MACRO
08300
08400 DFEN1: TLNN TEMP,FORMAL ;BITS ARE COMPLEMENTED HERE, CAN'T BE FORMAL
08500 ERR <DUPLICATE IDENTIFIER DECLARATION>,1
08600 POPJ P, ; GET OUT IF MACRO REDEFINITION AT THE SAME
08700 ; LEVEL. BODY IS DELETED IN DFENT IF
08800 ; %TLINK IS NON-ZERO
00100
00200 ; NOW CREATE A NEW BLOCK, PUT STUFF IN IT
00300
00400 BRANEW: ;NO CHECKING WAS DONE
00500 OKOLD: ;IT'S ALL OK
00600
00700 GETBLK NEWSYM ;GET A NEW BLOCK
00800
00900 ; INSERT PNAME, BITS -- LINK TO BUCKET, STRING RING,(VARB IF ID)
01000
01100 MOVE LPSA,NEWSYM ;POINTER TO NEW BLOCK
01200 HRROI TEMP,PNAME+1 ;GET PDP FOR POPPING DATA
01300
01400 POP TEMP,$PNAME+1(LPSA) ;STORE STUFF
01500 POP TEMP,$PNAME(LPSA)
01600
01700 ;CREFFING FOR THE WORLD.
01800 TLNE FF,CREFSW
01900 ;;#OH# -- HJS 9-24-73 DO NOT CREF MACRO FORMALS
02000 PUSHJ P,[ TLNE TBITS,DEFINE ; DO NOT CREF MACRO FORMALS
02100 TLNN TBITS,FORMAL
02200 JRST ECREFIT
02300 POPJ P,]
02400 ;;#OH#
02500
02600 TRNN TBITS,PROCED ;PROCEDURE?
02700 JRST NOPROC ;NO
02800 MOVE PNT,LPSA
02900 GETBLK ;SECOND PROCEDURE BLOCK
03000 HRLM LPSA,%TLINK(PNT) ;%TLINK PNTS TO 2D BLOCK
03100 MOVE LPSA,PNT
03200 TRNN TBITS,FORTRAN ;A FORTRAN CALL?
03300 TLNE TBITS,EXTRNL ;OR EXTERNAL
03400 TRO TBITS,FORWRD ;TURN ON FORWARD.
03500 TRNN TBITS,FORWRD ;A FORWARD PROCEDURE?
03600 TRO TBITS,INPROG ;NO -- TURN ON IN PROGRESS.
03700 NOPROC: MOVEM TBITS,$TBITS(LPSA) ;TYPE BITS
03800 SKIPE C,SIMPSW ;IF SIMPLE
03900 AOJA C,FILLEV ;CLEVER TRICK TO LOAD C 0 & GO PUT IN LL
04000 TRNN TBITS,LABEL ;OR NOT A LABEL, DONT CARE
04100 JRST DOLL ;GO DO LEVELS
04200 MOVE C,TPROC ;PICK UP CURRENT PROCEDURE
04300 HRRZ C,$VAL(C) ;PICK UP PD SEMBLK
04400 HRLM C,$ACNO(LPSA) ;PUT AWAY FOR LABEL SEMBLK
04500 ;#HY# RHT 6-26-72 OWN WAS BEING TESTED AS A RIGHT HALF BIT
04600 DOLL: SKIPE C,CDLEV ;PICK UP DISPLY LEVEL
04700 ;;#IU# 8-12-72 ! RHT PREVENT EXTERNALS FROM BEING REFD (RF)
04800 TLNE TBITS,OWN!EXTRNL;IF NON-ZERO DISPLY LEV, BUT OWN, OK
04900 ;;#LS# RHT 2! 3-12-73 WAS GETTING TO FILLEV WITH NOD ZERO C FOR OWN&EXTERNAL
05000 JRST [SETZM C ;NO WORRY, ID IS AT LEVEL 0
05100 JRST FILLEV]
05200 SKIPE RECSW ;IF CURRENT PROC IS RECURSVE
05300 ;#HY# RHT HERE IS WHERE OWN WAS BEING TESTED
05400 TRNE TBITS,ITEM!LABEL!PROCED; YES, IF NOT ITEM,LABEL, OR PROC THEN USE
05500 ;STACK
05600 TLNE FF,PRODEF ;IF FORMAL USE STACK -- PRODEF SAYS WAS AN ARG LST
05700 LSH C,LLFLDL ;SHIFT LEVEL T RIGHT SPOT
05800 TRZ C,LLFLDM
05900 ;MASK OUT LEX LEV FLD AREA
06000 FILLEV: TDO C,LEVEL ;PUT IN THE LEX LEVEL
06100 HRRZM C,$SBITS(LPSA) ;LEVEL OF DEFINITION
06200
06300 ; LINK TO BUCKET, STRING RING
06400
06500 MOVEI A,LNKRET+1 ;IN-LINE "CALL"
06600 LNK: MOVE B,HPNT ;WORD SET UP BY HASH
06700 XCT B ;THIS PICKS UP THE TIE INTO LPSA
06800 MOVE TEMP,NEWSYM ;POINTER TO NEW ONE
06900 HRRM LPSA,%TBUCK(TEMP) ;LINK DOWN NEW BLOCK
07000 HRR LPSA,TEMP ;GET LPSA READY TO PUT BACK
07100 TLO B,2000 ;TURN ON "MOVE TO MEMORY" BIT
07200 XCT B
07300 LNKRET: JRST (A) ;ALL DONE
07400
07500 MOVE LPSA,NEWSYM
07600 PUSHJ P,RNGSTR ;PUT ON STRING RING
07700
07800
07900 ; IF NOT A CONSTANT, LINK TO VARB LIST -- RETURN
08000
08100 TLNE TBITS,CNST ;NOT ON VARB IF CONST
08200 POPJ P, ; DONE
08300
08400 MOVE LPSA,NEWSYM
08500 JRST RNGVRB ;PUT ON VARB RING
00100
00200 Comment ⊗ Constants, String or Numeric ⊗
00300
00400 ENCNST: TRNN TBITS,STRING ;STRING CONSTANT?
00500 JRST ENNUMB ; NO, NUMERIC
00600
00700 ENSTRNG:
00800 MOVEI C,0 ;STRCONS ARE AT LEVEL 0
00900 PUSHJ P,BRANEW ;USE VARIABLE STUFF TO PERFORM THE ENTER.
01000 MOVE LPSA,NEWSYM ;SEMANTICS OF RESULT
01100 HLLZS $SBITS(LPSA) ;NO LEVELS FOR STRING CONSTANTS
01200 JRST RNGCST ;PUT ON CONSTANT RING.
01300
01400
01500 ; NUMERIC CONSTANT
01600
01700 ENNUMB:
01800 GETBLK NEWSYM
01900 HRROI TEMP,DBLVAL ;STORE STUFF
02000 POP TEMP,$VAL+1(LPSA)
02100 POP TEMP,$VAL(LPSA)
02200 POP TEMP,$TBITS(LPSA)
02300 JSP A,LNK ;LINK TO BUCKET LIST
02400 PUSHJ P,RNGCNM ;PUT ON CONSTANT RING
02500 POPJ P,
00100 DSCR ADCINS, CREINT, CONINS
00200 CAL PUSHJ from EXECS which create constants for runtime.
00300 PAR A contains value for CREINT, ADCINS
00400 SCNVAL contains value for CONINS (numeric)
00500 BITS contains type bits for CONINS
00600 PNAME string is value for CONINS (String)
00700 RES Semantics for constant (new or used) in rh of PNT
00800 DES These routines are used to create constants, for
00900 adjusting the stack, doing compile-time computation
01000 of constant expressions, providing address constants, etc.
01100 CONINS uses SCNVAL and BITS to make a constant of the
01200 proper flavor (PNAME string for String constants).
01300 CREINT makes an Integer constant.
01400 ADCINS is CONINS, except it forces a new constant to be
01500 made (code in SCANNER does it). It is used to provide
01600 unique addresses for REFERENCE calls, which might wipe
01700 the values out.
01800 SID All AC's except PNT preserved; lh PNT preserved.
01900 ⊗
02000
02100 ↑ADCINS:
02200 MOVEM A,SCNVAL ;SPECIAL UNIQUE CONSTANT FOR
02300 MOVE TBITS,[XWD CNST+RECURS,0] ;ADCON MAKER
02400 ORM TBITS,BITS ;(CONSTANT BY REFERENCE)
02500 JRST CONINS ;CONTINUE
02600
02700 ↑CREINT: MOVEM A,SCNVAL ;CREATE AN INTEGER
02800 SKIPA TBITS,[XWD CNST,INTEGR]
02900
03000 ↑CONINS: MOVE TBITS,BITS
03100 ;;# # DCS 3-1-72
03200 TRNE TBITS,STRING ;INSERT A STRING IF REQUESTED
03300 JRST STRINS
03400 ;;# #
03500 PUSH P,NUM1 ;FLAGS
03600 PUSH P,NUM2
03700 CINS: MOVE TEMP,[XWD A,CONACS] ; SAVE REGISTERS 1-12
03800 BLT TEMP,CONACS+SBITS2-A
03900 MOVE LPSA,STRCON ;STRING CONSTANT BUCKET.
04000 MOVEM TBITS,BITS
04100 XCT -1(P) ;HASH AND LOOKUP
04200 MOVE TBITS,TBITS+CONACS-A
04300 MOVEM TBITS,BITS
04400 SKIPN NEWSYM ;WAS IT FOUND?
04500 XCT (P) ;NO -- ENTERS
04600 MOVE TEMP,[XWD CONACS,A] ; RESTORE REGISTERS 1-12
04700 BLT TEMP,SBITS2
04800 SUB P,X22 ; ADJUST STACK POINTER TO GET RID OF ROUTINE NAMES
04900 HRR PNT,NEWSYM ;DO NOT CLOBBER LEFT HALF INCASE
05000 ; ADCONS ARE BEING MADE.
05100 JRST GETAD ; LOAD SBITS AND TBITS
05200
05300 ↑STRINS: PUSHJ P,STRNS1 ;
05400 AOS $VAL2(PNT) ; INCREMENT REFERENCE COUNT
05500 POPJ P, ;
05600
05700 STRNS1: PUSH P,STR1 ;FOR STRINGS
05800 PUSH P,STR2
05900 MOVE TBITS,[XWD CNST,STRING]
06000 JRST CINS ;GO DO IT.
06100
06200 NUM1: PUSHJ P,NHASH
06300 NUM2: PUSHJ P,ENNUMB
06400 STR1: PUSHJ P,SHASH
06500 STR2: PUSHJ P,ENSTRNG
06600
06700 ZERODATA (AC SAVE AREA FOR CONSTANT-MAKERS)
06800 CONACS: BLOCK SBITS2-A+1
06900 ENDDATA
07000
07100 SUBTTL HASH ROUTINES
00100 DSCR SHASH, NHASH -- look up symbol entries in hashed buckets.
00200
00300 PAR LPSA -- ptr to bucket Semblk for SHASH (since there are two).
00400 NHASH supplies its own.
00500 PNAME -- String search argument for SHASH
00600 SCNVAL -- Numeric search argument for NHASH
00700
00800 RES HPNT -- [HRRZ LPSA, bucketaddr] or [HLRZ LPSA, bucketaddr]
00900 as explained in HPNT declaration.
01000 NEWSYM -- 0 if not found, else Semantics of found entity.
01100
01200 SID Uses TEMP, TBITS, A, B, C, D, PNT -- Results in LPSA
01300 SEE HPNT, NEWSYM, Bucket descriptions in main SAIL DATA area
01400 ⊗
01500
01600 ↑SHASH:
01700 MOVE A,PNAME+1 ;BYTE POINTER
01800 MOVE A,(A) ;1ST STRING WORD
01900 HRRZ TEMP,PNAME ;#CHARACTERS
02000 XOR A,TEMP ;MIX IT UP A BIT
02100 PUSHJ P,HASH ;COMPUTE HASH, GET POINTER, STORE IN HPNT
02200
02300 Comment ⊗ Search for symbol identical to string in pname.
02400 Put pointer to it in NEWSYM if found.
02500 Computed hash pointer is in HPNT on entry ⊗
02600
02700 SFIND: SETZM NEWSYM ;ASSUME NOT FOUND
02800 HRRZ A,PNAME ;LENGTH
02900 JUMPE A,BUKS ;ZERO LENGTH PNAME TEST
03000 MOVEI B,4(A)
03100 IDIVI B,5 ;# WORDS IN B
03200 HRLI PNT,D ;SET UP INDICES
03300 HRR PNT,PNAME+1 ;BYTE POINTER TO NEW NAME
03400 HRLI C,D
03500 MOVE TBITS,(PNT) ;FIRST WORD OF NEW NAME
03600
03700 JRST BUKS ;START AT THIS ONE
03800 BUKLS: RIGHT ,%TBUCK,, ;GO DOWN BUCKET
03900 BUKS: JUMPE LPSA,NOFND ;IN CASE BUCKET WAS EMPTY
04000 JUMPE A,LCOMP ;ZERO LENGTH PNAME TEST
04100 CAME TBITS,@$PNAME+1(LPSA) ;SAME FIRST WORD?
04200 JRST BUKLS ;NO , FAIL
04300 LCOMP: HRR TEMP,$PNAME(LPSA) ;LENGTH OF OBJECT STRING
04400 CAIE A,(TEMP) ;SAME LENGTH?
04500 JRST BUKLS ;NO -- FAILURE
04600 JUMPE A,FND ;IF BOTH LENGTH(0), ASSUME IDENTICAL
04700 HRREI D,-1(B) ;# WORDS-1
04800 JUMPLE D,FND ;SAME SYMBOL, ONE WORD LONG
04900 HRR C,$PNAME+1(LPSA);BYTE POINTER ADDR -- INDEX
05000
05100 SFNLUP: MOVE TEMP,@PNT
05200 CAME TEMP,@C ;SAME WORD?
05300 JRST BUKLS ;FAILURE
05400 SOJG D,SFNLUP ;KEEP AT IT!
05500
05600
05700 FND: MOVEM LPSA,NEWSYM
05800 NOFND: POPJ P,
05900
06000
06100
06200 ; USES A,B only -- results in LPSA
06300
06400 ↑NHASH: SETZM NEWSYM ;ASSUME FAILURE
06500 MOVE A,SCNVAL ;HASH ON 1ST WORD OF VALUE
06600 MOVE LPSA,CONST ; HASH TO CONST BUCKET
06700 PUSHJ P,HASH
06800 MOVE A,SCNVAL ;GET VALUES FOR COMPARISON
06900 MOVE B,DBLVAL
07000
07100 MOVE TEMP,BITS
07200 TLNE TEMP,RECURS ;WANT UNIQUE CONSTANT?
07300 JRST NOFND ; YES, SAME AS FAILURE
07400
07500 JRST BUK ;START HERE
07600 BUKL: RIGHT ,%TBUCK ;DOWN BUCKET LIST
07700 BUK: JUMPE LPSA,NOFND ;BE SURE TO CHECK THE FIRST ONE
07800 CAME A,$VAL(LPSA) ;FIRST VALUE EQUAL?
07900 JRST BUKL ;NO -- FAILURE
08000 CAME B,$VAL2(LPSA) ;SECOND VALUE EQUAL?
08100 JRST BUKL ;NO -- FAILURE
08200 MOVE TEMP,BITS ;MAKE SURE TYPE IS SAME
08300 CAME TEMP,$TBITS(LPSA)
08400 JRST BUKL ;STILL CAN'T USE IT
08500 JRST FND ;OK, USE IT
08600
08700 JRST FND ;FINISH OUT
08800
08900 Comment ⊗ HASH routine itself --
09000
09100 IN: A -- number to be hashed
09200 LPSA -- bucket pointer
09300
09400 OUT: HPNT contains an instruction which, when executed
09500 will load LPSA with the bucket word in the RH.
09600 See LNK above for the cute way of entering
09700 the new symbol.
09800
09900 ACS: uses A, B -- results in LPSA
10000
10100 ⊗
10200
10300 HASH: IDIVI A,BUKLEN ;GET (A mod BUKLEN)
10400 MOVMS B ;USE MAGNITUDE
10500 ROT B,-1 ;DIVIDE BY TWO
10600 ADD LPSA,B ;ADD TO THE BUCKET POINTER
10700 HRLI LPSA,(<MOVE LPSA,0>)
10800 SKIPL B
10900 HRLI LPSA,(<MOVS LPSA,0>)
11000 MOVEM LPSA,HPNT ;AND STORE AWAY
11100 XCT LPSA
11200 HRRZS LPSA ;SO THE JUMPE WILL WORK.
11300 POPJ P,
00100 SUBTTL SEMBLK Allocation Routines
00200 DSCR BLKGET, BLKFRE -- Semblk Allocators
00300 CAL PUSHJ via GETBLK, FREBLK macros.
00400
00500 DES Routines to perform the following:
00600 BLKGET allocates a new 11-word Semblk.
00700 BLKFRE restores such a Semblk to the BLFREE storage list
00800 SETBLK Initializes BLFREE with blocks as determined by
00900 determined by the area allocated in lpsbot, lpstop.
01000 NEEBLK Gets more blocks when you need them
01100 BLKZER Zeroes the block pointed to by LPSA
01200
01300 PAR LPSA is Semblk address for BLKFRE
01400
01500 RES LPSA contains Semblk address from BLKGET
01600
01700 SID USER used for GOGTAB by SET-&NEE- blk
01800 TEMP destroyed by same
01900 LPSA changed by SETBLK and BLKZER, set to good thing by NEEBLK
02000 ⊗
02100
02200 ZERODATA (BLOCK-GETTER VARIABLES)
02300 COMMENT ⊗
02400 BLFREE -- Semblk Free Storage List pointer. Points to first Semblk
02500 on list, whose first word points to next, etc. -- 0 terminates.
02600 Semblks are put on the list by BLKZER when allocating more, and
02700 by the BLKFRE (via FREBLK macro) routine. They are removed by
02800 the BLKGET (via GETBLK macro) routine.
02900 ⊗
03000 ↑↑BLFREE: 0
03100
03200 ;FRECNT -- # free blocks when enabled by FTCOUNT switch
03300 IFN FTDEBUG, <
03400 ↑↑FRECNT: 0
03500 >
03600
03700 TSTALO←←0 ;SPECIAL TEST MODE FOR BLOCK ALLOCATOR
03800 IFNDEF TSTALO, <TSTALO←←0>
03900 IFE TSTALO,<BLLEN←←BLKLEN; ELSE>BLLEN←←BLKLEN+2 ;SET TOTAL BLOCK SIZE
04000 IFN TSTALO, <BLKUSE: 0>
04100 ENDDATA
04200
04300 ↑SETBLK:
04400 IFN TSTALO ,<
04500 MOVEI TEMP,BLKUSE-BLKLEN-1 ;initialize pointer to
04600 HRLS TEMP ;doubly-linked list of IN USE
04700 MOVEM TEMP,BLKUSE ; blocks for finding lacking FREBLKs
04800 >;TSTALO
04900
05000 MOVE TEMP,LPSBOT
05100 SETBL1: MOVEM TEMP,BLFREE ;STARTING ADDRESS
05200 GOK: MOVEI LPSA,BLLEN(TEMP) ;NEXT AREA
05300 CAML LPSA,LPSTOP ;TOO FAR?
05400 JRST SETD
05500 MOVEM LPSA,(TEMP) ;STORE THE POINTER
05600 MOVE TEMP,LPSA
05700 JRST GOK
05800
05900 SETD: SUBI TEMP,BLLEN ;GO BACK AND
06000 SETZM (TEMP) ;TERMINATE LIST
06100 POPJ P,
06200
06300 ↑NEEBLK:
06400 PUSH P,B ;NEEDED FOR CORE GETTERS
06500 PUSH P,C
06600 MOVE B,LPSBOT ;TRY TO INCREMENT THIS BLOCK
06700 MOVEI C,=100*BLLEN ;TRY TO INCREMENT THIS BLOCK
06800 PUSHJ P,CANINC ;IS IT POSSIBLE?
06900 JRST NOINC ;NO
07000
07100 JRST INCR3 ;YES, GO DO IT
07200
07300 NOINC:
07400 CAIGE C,=20*BLLEN ;WILL SETTLE FOR THIS
07500 JRST GETTOP ;NO, GET NEW BLOCK
07600
07700 INCR3: PUSHJ P,CORINC ;EXPAND BY ALLOWABLE AMOUNT
07800 ERR <DRYROT> ;CAN'T HAPPEN
07900 EXCH C,LPSTOP ;OLD TOP IS NEW FREE AREA
08000 ADDM C,LPSTOP ;NEW UPPER LIMIT
08100 MOVE TEMP,C ;SO LEAVE IT WHERE IT WILL BE NOTICED
08200 JRST NEERT1 ;NOW GO AND RELINK
08300
08400
08500 GETTOP: MOVEI C,=100*BLLEN ;GET NEW BLOCK THIS SIZE
08600 PUSHJ P,CORGET
08700 CORERR <RAN OUT OF CORE AT GETTOP>
08800 MOVEM B,LPSBOT ;SET LIMITS ANEW
08900 MOVEM B,LPSTOP
09000 ADDM C,LPSTOP
09100
09200 NEERET:
09300 MOVE TEMP,B ;PTR TO BOTTOM OF NEW
09400 NEERT1: POP P,C
09500 POP P,B
09600 PUSHJ P,SETBL1 ;LINK THEM UP
09700 MOVE LPSA,BLFREE ;SO THAT WE CAN CONTINUE
09800 POPJ P,
09900
10000 ↑BLKGET:
10100 IFN FTDEBUG,<AOS FRECNT>
10200 SKIPN LPSA,BLFREE
10300 PUSHJ P,NEEBLK ;GET A WHOLE NOTHER SET.
10400 MOVE TEMP,(LPSA)
10500 MOVEM TEMP,BLFREE ;UPDATE FREE STORAGE.
10600 ↑BLKZER: SETZM (LPSA) ;FIRST WORD
10700 MOVSI TEMP,(LPSA) ;ZERO THE BLOCK
10800 HRRI TEMP,1(LPSA)
10900 BLT TEMP,BLLEN-1(LPSA)
11000 IFN TSTALO,<
11100 ; ADD BLOCK TO DOUBLY-LINKED RING OF IN USE BLOCKS
11200 POP P,BLKLEN(LPSA) ;SAVE RET ADDR FOR HISTORY OF CALL TO BLKGET
11300 HLRZ TEMP,BLKUSE ;GET POINTER TO LAST BLOCK IN RING
11400 HRLM LPSA,BLKUSE ;UPDATE SAID POINTER
11500 HRRM LPSA,BLKLEN+1(TEMP) ;UPDATE FOR'RD PNTR IN OLD LAST BLOCK
11600 HRLM TEMP,BLKLEN+1(LPSA) ;UPDATE BCK'RD PNTR IN NEW (LAST) BLOCK
11700 MOVEI TEMP,BLKUSE-BLKLEN-1 ;UPDATE FOR'RD PNTR IN NEW BLOCK
11800 HRRM TEMP,BLKLEN+1(LPSA)
11900 JRST @BLKLEN(LPSA) ;RETURN DEVIOUSLY
12000 ; ELSE >POPJ P,
12100
12200 ↑BLKFRE:
12300 IFN FTDEBUG,<SOS FRECNT>
12400 EXCH LPSA,-1(P) ;GET ARG, SAVE LPSA
12500 MOVE TEMP,BLFREE
12600 HRRZM TEMP,(LPSA) ;STRINGOUT FREE STORAGE
12700 HRRM LPSA,BLFREE
12800 IFN TSTALO, <
12900 ; REMOVE FROM IN USE RING
13000 MOVE TEMP,BLKLEN+1(LPSA) ;BCK'RD,,FOR'RD
13100 HLLM TEMP,BLKLEN+1(TEMP) ;UPDATE BCK'RD IN NEXT TO PNT TO PREV
13200 MOVSS TEMP
13300 HLRM TEMP,BLKLEN+1(TEMP) ;UPDATE FOR'RD IN LAST TO PNT TO NEXT
13400 >
13500 MOVE LPSA,-1(P) ;GET OLD VALUE BACK
13600 SUB P,X22
13700 JRST @2(P)
00100 SUBTTL RNGVRB, RNGSTR, etc. -- `Ring' Linkage Routines
00200
00300
00400 DSCR RNGSTR, RNGGEN, RNGTMP, RNGCST, RNGVRB, RNGADR, RNGCNM
00500 PAR (Sometimes) LPSA is Semblk address
00600 RES The Semblk is linked onto a `ring' based on a variable
00700 implied by the routine name. RNGSTR uses %RSTR -- all others
00800 use %RVARB. The ring header variables are STRRNG, VARB, TTEMP,
00900 CONINT, CONSTR, ADRTAB.
01000 DES These routines replace the RING macro -- for space efficiency.
01100 ⊗
01200
01300 ↑RNGDIS:MOVEI TEMP,DISLST ;DISPLAY TEMPS
01400 JRST RNGGEN
01500 ↑RNGADR:SKIPA TEMP,[ADRTAB] ;ADDRESS CONSTANTS
01600 ↑RNGTMP:MOVEI TEMP,TTEMP ;CORE TEMPS
01700 JRST RNGGEN
01800 ↑RNGCNM:SKIPA TEMP,[CONINT] ;NUMERICAL CONSTANTS -- ASSUMES NEWSYM
01900 ↑RNGCST:MOVEI TEMP,CONSTR ;STRING CONSTANTS -- ASSUMES NEWSYM
02000 SKIPA LPSA,NEWSYM ;GET SEMBLK FROM HERE
02100 ↑RNGVRB:MOVEI TEMP,VARB ;VARB RING
02200 RNGGEN: PUSH P,A
02300 SKIPN A,(TEMP) ;The left half of %RVARB(Semblk) is
02400 JRST .+3 ; made to point to the previous `newest'
02500 HRRM LPSA,%RVARB(A) ; Semblk, if one exists -- the right
02600 HRLZM A,%RVARB(LPSA) ; half of %RVARB(Previous) points to
02700 MOVEM LPSA,(TEMP) ; this one -- the vase vbl (TEMP) always
02800 POP P,A ; indicates the new (right-hand) end
02900 POPJ P, ; of the list -- the oldest lh is always 0
03000
03100
03200 ↑RNGSTR:SKIPN TEMP,STRRNG ;String ring linkage -- same business
03300 JRST .+3
03400 HRRM LPSA,%RSTR(TEMP)
03500 HRLZM TEMP,%RSTR(LPSA)
03600 MOVEM LPSA,STRRNG
03700 POPJ P,
00100
00200 DSCR URGVRB, URGADR, URGTMP, URGCST, URGSTR
00300 PAR LPSA is a Semblk Address
00400 The Header vbl is set up by calling the right routine
00500 DES Undoes the damage done by RING
00600 ⊗
00700
00800 ↑URGDIS:SKIPA TEMP,[DISLST]
00900 ↑URGCNM:MOVEI TEMP,CONINT
01000 JRST URGGEN
01100 ↑URGVRB:SKIPA TEMP,[VARB]
01200 ↑URGTMP:MOVEI TEMP,TTEMP
01300 JRST URGGEN
01400 ↑URGADR:SKIPA TEMP,[ADRTAB]
01500 ↑URGCST:MOVEI TEMP,CONSTR
01600 URGGEN: PUSH P,A ;If there are no pointers in %RVARB, then
01700 SKIPN A,%RVARB(LPSA) ;1) The Semblk is not on the ring, or:
01800 CAMN LPSA,(TEMP) ;2) It is the only member, in which case its
01900 JRST DOU ; address is that of the header vbl (TEMP)
02000 ENDU: POP P,A ;So you get here immediately in CASE 1 above,
02100 POPJ P, ; and after you've unlinked in other cases.
02200 DOU: TRNE A,-1 ;If there is a younger neighbor, tell him
02300 HLLM A,%RVARB(A) ; you're gone.
02400 TRNN A,-1 ;If there is not a younger neighbor, update
02500 HLRZM A,(TEMP) ; the header, because you were youngest.
02600 MOVSS A
02700 TRNE A,-1 ;If there is an older neigbor, tell him
02800 HLRM A,%RVARB(A) ; you're gone.
02900 JRST ENDU
03000
03100 ↑URGSTR:SKIPN TEMP,%RSTR(LPSA);Same stuff for string ring.
03200 CAMN LPSA,STRRNG
03300 JRST DOST
03400 POPJ P,
03500 DOST: TRNE TEMP,-1
03600 HLLM TEMP,%RSTR(TEMP)
03700 TRNN TEMP,-1
03800 HLRZM TEMP,STRRNG
03900 MOVSS TEMP
04000 TRNE TEMP,-1
04100 HLRM TEMP,%RSTR(TEMP)
04200 POPJ P,
00100 SUBTTL Mark insertion routine for counter routines
00200 DSCR LSTOUT -- write to list file
00300 CAL PUSHJ P,LSTOUT
00400 PAR Reg A contains character to be listed
00500 RES The character right justified in A is placed in the output
00600 line of the list file. If the last character was a CR, the character
00700 is inserted before the CR. This routine is called by the exec
00800 routines KOUNT1, KOUNT2, etc. to put markers in the list file
00900 indicating where counters were placed into the object code.
01000 SID the contents of A may be changed.
01100 ⊗
01200
01300 ↑LSTOUT: PUSH P,B ;SAVE B
01400 LDB B,LPNT ;GET PREV LAST CHAR
01500 CAIE B,15 ;IS IT A CR
01600 JRST .+3 ;NO
01700 DPB A,LPNT ;YES, WIPE IT OUT
01800 MOVEI A,15 ;AND PUT CR AFTER IT
01900 IDPB A,LPNT ;STORE CHAR
02000 POP P,B ;RESTORE B
02100 POPJ P, ;RETURN
02200
02300
02400
02500 DSCR LSTOU1 -- Write to list file
02600 CAL PUSHJ P,LSTOU1
02700 PAR Reg A contains character to be listed
02800 Reg C contains character that the char in A should follow
02900 RES If the last character in the line matches the one in
03000 C, the character in A is put at the end of the line. If
03100 not, the char in A is placed before the last character.
03200 The necessity for doing this comes from the fact that some
03300 single character tokens are placed in the listing file before
03400 they are parsed.
03500 SID Register A may be changed
03600 ⊗
03700 ↑LSTOU1: PUSH P,B ;SAVE B
03800 LDB B,LPNT ;GET THE LAST CHAR
03900 CAMN B,C ;IS IT THE ONE WE WANT...
04000 JRST .+8 ;YES, GO STORE CHARACTER
04100 CAIGE C,"A" ;IS THE COMPARE CHAR A LETTER
04200 JRST .+4 ;NO
04300 ADDI C,"a"-"A" ;CONVERT TO LOWERCASE
04400 CAMN B,C ;IS IT THE RIGHT THING?
04500 JRST .+3 ;YES, GO STORE CHARACTER AND RETURN
04600 DPB A,LPNT ;NO, STORE NEW CHAR
04700 MOVE A,B ;THEN OLD CHARACTER
04800 IDPB A,LPNT
04900 POP P,B ;RESTORE B
05000 POPJ P, ;RETURN
05100
05200 BEND SYM
05300 ↑KILLST←KILLST
05400
05500 SUBTTL Generator Data