Trailing-Edge
-
PDP-10 Archives
-
-
There are no other files named in the archive.
00100 COMMENT VALID 00037 PAGES
00200 C REC PAGE DESCRIPTION
00300 C00001 00001
00400 C00004 00002 HISTORY
00500 C00012 00003 SCAN
00600 C00015 00004 BITDATA (SCNWRD -- LISTING CONTROL, ETC.)
00700 C00021 00005 DATA (SCANNER PARSE TOKENS)
00800 C00033 00006 DSCR main SCANNER Dispatch loop
00900 C00046 00007 ID -- RESET FOR SCAN
01000 C00054 00008 COMMENT -- throw out everything to next semicolon
01100 C00056 00009 DSCR -- USID
01200 C00063 00010 DSCR -- SCNACT
01300 C00073 00011 PUSH PNT,PNEXTC-1 STRING NUMBER
01400 C00077 00012 DSCR STRNG, etc.
01500 C00081 00013
01600 C00084 00014 DEFCHK:
01700 C00096 00015 DSCR SCNUMB -- number scanner
01800 C00109 00016
01900 C00114 00017 Print the last character, then stack the result
02000 C00118 00018 DSCR CSPEC, SEOL, SEOM, SEOB -- Special handling routines
02100 C00122 00019 Cspec, Seol
02200 C00123 00020 CALL SPECIAL ROUTINE, BUT FIRST MAKE SURE CHARACTER COUNT IS
02300 C00130 00021
02400 C00138 00022 END OF BUFFER CODE.
02500 C00140 00023 Parameter delimiter or end of message
02600 C00148 00024 DSCR ADVBUF -- new input buffer routine
02700 C00160 00025 BAIL <
02800 C00163 00026 DSCR --HERE IS THE CREFFINF STUFF (STRANGE PLACE N'EST CE PAS?)
02900 C00170 00027 DSCR HDR, HDROV
03000 C00181 00028 DSCR ENTERS -- make new symbol entry
03100 C00185 00029 ^ENTERS:
03200 C00191 00030
03300 C00196 00031
03400 C00197 00032 DSCR ADCINS, CREINT, CONINS
03500 C00201 00033 DSCR SHASH, NHASH -- look up symbol entries in hashed buckets.
03600 C00207 00034 SEMBLK Allocation Routines
03700 C00214 00035 RNGVRB, RNGSTR, etc. -- `Ring' Linkage Routines
03800 C00217 00036
03900 C00220 00037 Mark insertion routine for counter routines
04000 C00223 ENDMK
04100 C;
00100 COMMENT HISTORY
00200 AUTHOR,REASON
00300 021 102100000046 ;
00400
00500
00600 COMMENT
00700 VERSION 17-1(38) 4-14-75 BY JFR ANOTHER PASS AT BAIL COORDINATE FIXES P.6
00800 VERSION 17-1(37) 3-1-75 BY RLS CHECK FOR END OF BUFFER IN TENEX ADVBUF (PROB. SHOULD BE ADDED TO DEC ALSO)
00900 VERSION 17-1(36) 2-8-75 BY JFR BAIL SOURCE POINTERS P.6
01000 VERSION 17-1(35) 11-17-74 BY JFR BAIL SOURCE FILE POINTER BUGS P. 6,21
01100 VERSION 17-1(34) 10-16-74 BY JFR FIX BAIL SOURCE FILE COUNTING
01200 VERSION 17-1(33) 10-10-74 BY JFR REVISE WAY BAIL PUTS OUT TEXT FILE POINTERS
01300 VERSION 17-1(32) 9-26-74 BY JFR BAIL INSTALLED 9-19-74. FIX VERSION, AUTHOR, REASON STUFF
01400 VERSION 17-1(31) 9-15-74 BY HJS BUG #TG# PREVENT PARSE STACK OVERFLOW WHEN SCANNING ACTUAL PARAMETERS TO MACROS
01500 VERSION 17-1(30) 5-30-74 BY RLS TENEX FIX #SI# BETTER LISTING FORMAT
01600 VERSION 17-1(29) 5-30-74
01700 VERSION 17-1(28) 5-28-74 BY RHT BUG #SD# NEEDED A FLAG TO DETECT EXTERNAL-INTERNAL CHANGES
01800 VERSION 17-1(27) 4-12-74 BY RHT %BI% ASS RECORD STUFF TO ENTID
01900 VERSION 17-1(26) 3-17-74 BY RLS INSTALL TENEX
02000 VERSION 17-1(25) 3-17-74
02100 VERSION 17-1(24) 2-5-74 BY HJS BUG #RA# ALLOW TEXT PAST FINAL END OF PROGRAM
02200 VERSION 17-1(23) 1-29-74 BY HJS BUG #QV# ASSIGNC PROBLEMS
02300 VERSION 17-1(22) 1-25-74 BY RHT BUG #QO# PNAME MAY BE SPLIT BY STRING SPACE EXPANSION
02400 VERSION 17-1(21) 1-11-74 BY JRL CHANGE MACRO EXPANSION LIST CHARACTER
02500 VERSION 17-1(20) 12-14-73 BY RHT BUG #PZ# A KLUGE THAT NO LONGER WORKED FIXED BY NEW DCS KLUGE
02600 VERSION 17-1(19) 12-14-73
02700 VERSION 17-1(18) 12-7-73 BY JRL REMOVE SPECIAL STANFORD CHARACTERS
02800 VERSION 17-1(17) 11-27-73 BY RLS BUG #PF# AVOID DYING IF SOURCE FILE ENDS IN FF
02900 VERSION 17-1(16) 11-27-73
03000 VERSION 17-1(15) 11-25-73 BY JRL FEAT %AN% HAVE SOURCE!FILE SWITCHING CHECK ARG AS STRING CONSTANT
03100 VERSION 17-1(14) 11-16-73 BY HJS BUG #PC# OVERWRITNG FIRST LINE IN CREF
03200 VERSION 17-1(13) 11-10-73 BY KVL MERGE:CORERR
03300 VERSION 17-1(12) 9-24-73 BY HJS BUG #OH# NO CREFFING OF MACRO FORMALS ALLOWED
03400 VERSION 17-1(11) 9-24-73
03500 VERSION 17-1(10) 9-21-73 BY HJS INHIBIT LISTING IN FALSE PART OF CONDITIONAL COMPILATION
03600 VERSION 17-1(9) 9-21-73 BY RHT PATCH UP VERSION STUFF
03700 VERSION 17-1(7) 9-21-73 BY HJS MAKE BUG OG FIX RIGHT
03800 VERSION 17-1(6) 9-19-73 BY HJS BUG #OG# SAVE PNAME COUNT BEFORE SGCOL
03900 VERSION 17-1(5) 9-19-73
04000 VERSION 17-1(4) 9-17-73 BY HJS BUG #OF# MAKE SURE PARSE TOKEN IN AC A WHEN GOING TO STACK
04100 VERSION 17-1(3) 9-17-73
04200 VERSION 17-1(2) 9-17-73
04300 VERSION 17-1(1) 8-14-73 BY RHT TURN JRST .CORERR AT GETTOP BACK TO JRST CORERR
04400 VERSION 16-2(48) 7-12-73 BY HJS SAVE CHARACTER COUNT IN CASE GARBAGE COLLECTION HAPPENS DURING MACRO ACTUAL SCANNING
04500 VERSION 16-2(47) 6-20-73 BY HJS IFCR, REDEFINE, EVALDEFINE, AND ASSIGNC IMPLEMENTATION
04600 VERSION 16-2(46) 6-10-73 BY JRL BUG #MQ# LPNT NOT PROPERLY SAVED FOR BACKUP WHEN SAVCHR=0
04700 VERSION 16-2(45) 6-1-73 BY DCS BUG #MP# KEEP REMCHR HONEST (STRNGC BUG)
04800 VERSION 16-2(44) 3-19-73 BY HJS ALLOW TEMPORARY OVERRIDING OF NULL DELIMITERS MODE
04900 VERSION 16-2(43) 3-13-73 BY JRL REMOVE REFERENCES TO WOM,SLS,GAG,NODIS
05000 VERSION 16-2(42) 3-12-73 BY RHT BUG #LS# OWN THINGS GETTING THE WRONG LEVEL INFO
05100 VERSION 16-2(41) 1-31-73 BY HJS ADD NOEMIT, ACKSAV, AND SBSAV FOR EXPR!TYPE
05200 VERSION 16-2(40) 1-17-73 BY HJS BUG #LC# MACRO FORMALS ARE NOT MACRO REDEFINTION
05300 VERSION 16-2(39) 1-17-73
05400 VERSION 16-2(38) 12-11-72 BY HJS DISABLE ENDC PARSER SWITCH TRIGGER IN WHILEC, CASEC, FORC, AND FORLC BODIES
05500 VERSION 16-2(37) 12-2-72 BY HJS SAVE BITS DURING CONDITIONAL COMPILATION AND MACRO DEFINITIONS (CBTSTK AND DBTSTK)
05600 VERSION 16-2(36) 11-20-72 BY JRL FIX SUGG BY R. SMITH AT CHKPRC
05700 VERSION 16-2(35) 11-19-72 BY HJS BUG #JZ# CORRECTION - MACRO REDEFINITION AND RESERVED WORD REDEFINITION IN ENTERS
05800 VERSION 16-2(34) 11-15-72 BY HJS INSERT DEFDLM QSTACK FOR DEFLUK BIT OF FF FOR COMPILE-TIME MACROS WITHIN MACROS
05900 VERSION 16-2(33) 11-5-72 BY DCS BUG #JZ# CHANGE MACRO SCOPE RULES
06000 VERSION 16-2(32) 11-3-72 BY DCS SIMILARLY, ALLOW ALL EXTERNALS TO OVERRIDE
06100 VERSION 16-2(31) 11-2-72 BY DCS BUG #JX# ALLOW INTRNL PROC TO OVERRIDE EXTRNL ONE.
06200 VERSION 16-2(30) 10-24-72 BY HJS EMIT ERR MSG FOR UNINIT MACRO VAR USE
06300 VERSION 16-2(29) 7-5-72 BY DCS BUG #IF# FIX SOME GOERGE BUGS
06400 VERSION 15-6(18-28) 7-5-72
06500 VERSION 15-6(17) 3-10-72 BY DCS REPLACE RING,ULINK MACRO WITH VARIOUS ROUTINES
06600 VERSION 15-6(8-16) 3-9-72
06700 VERSION 15-6(7) 2-21-72 BY HJS THE BRAVE NEW PARSER WORLD
06800 VERSION 15-2(6) 2-18-72 BY DCS BUG #GP# CHECK OLD FORMALS AGAINST NEW FORMALS
06900 VERSION 15-2(5) 2-5-72 BY DCS BUG #GJ# ADD LSTON LIST-CONTROL STUFF
07000 VERSION 15-2(4) 2-5-72 BY DCS BUG #GI# REMOVE TOPSTR
07100 VERSION 15-2(3) 2-1-72 BY DCS BUG #GE# LPSBOT FROM USER TABLE TO COMPILER DATA
07200 VERSION 15-2(2) 12-22-71 BY DCS BUG #FT# PROVIDE LINE NUMBER IF NOT SOS FILE
07300 VERSION 15-2(1) 12-2-71 BY DCS INSTALL VERSION NUMBER
07400
07500 ;
07600
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
04600
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_.
12400
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 BAIL<
01900 ^^BCORDN: 0 ;DEBUGGER COORDINATE NUMBER. RIGHT HALF CONTAINS CURRENT
02000 ;COORDINATE, LEFT HALF IS ZERO IF WE ARE NOT NOW PUTTING OUT
02100 ;COORDINATES TO THE .SM1 FILE, AND NON-ZERO IF WE ARE.
02200 BCRDW1: 0 ;SPACE TO SAVE COORD INFO TO BE WRITTEN TO .SM1 FILE, SINCE
02300 BCRDW2: 0 ; LOCATION MUST BE MARKED AT BEGINNING OF STATEMENT, BUT
02400 ; WE DONT KNOW IF WE WANT A COORD UNTIL THE END OF STATEMENT
02500 >;BAIL
02600
02700 ^^DEFRN2: 0 ;TEMP RING-VARIABLE WHILE SCANNING MACRO ACTUAL PARAMS
02800
02900 ;FLTVAL -- collect floating point equiv while scanning number
03000 ?FLTVAL: 0
03100
03200 COMMENT
03300 HPNT, HSPNT -- When the hashing routines (SHASH, NHASH) locate the
03400 right bucket pointer in the appropriate bucket Semblk, they create
03500 a [HRR LPSA,addr] or [HLR LPSA,addr] instruction which will fetch
03600 this pointer, and put it into HPNT -- also leaving it in LPSA. They
03700 then execute the instruction to begin their lookup phases. ENTERS
03800 again uses this pointer when adding a new Semblk to a bucket -- first
03900 as is, to fetch the old pointer, then modified to HRRM or HRLM, to
04000 update the bucket.
04100 HSPNT is the saved HPNT value for the last string constant scanned.
04200 The "string constant as comment" EXEC uses it to remove the constant
04300 from the bucket (provided, of course, that it hasn't also been used
04400 as a string constant).
04500
04600 ^HPNT: 0
04700
04800 ^HSPNT: 0
04900
05000 ^^LOCMBD: BLOCK 2 ; MACRO BODY DELIMITERS BLOCK
05100 ^^LOCMPR: BLOCK 2 ; MACRO PARAMETER DELIMITERS BLOCK
05200 BAKDLM: 0 ; A FLAG WHICH IS SET TO -1 IF DLMSTG IS ON
05300 ; (I.E. ONE WANTS A DELIMITED MACRO BODY)
05400 ; AND QUOTES ARE USED INSTEAD BECAUSE A
05500 ; REQUIRE NULL DELIMITERS STATEMENT WAS NOT
05600 ; USED.
05700 ^^CURMBG: 0 ; CURRENT MACRO BODY BEGIN DELIMITER
05800 ^^CURMED: 0 ; CURRENT MACRO BODY END DELIMITER
05900 ^^CURPBG: 0 ; CURRENT PARAMETER BEGIN DELIMITER
06000 ^^CURPED: 0 ; CURRENT PARAMETER END DELIMITER
06100 ^^DELSTK: 0 ; DELIMITER "BLOCK-STRUCTURE" STACK
06200 ^^LOKDLM: 0 ; DLMSTG (LOOKING FOR DELIMITERS FLAG) QSTACK
06300 ^^DEFDLM: 0 ; DEFLUK (SCANNING A MACRO BODY OR LOOKING FOR
06400 ; ACTUAL PARAMETERS) QSTACK
06500 ^^CBTSTK: 0 ; POINTER TO QSTACK FOR SAVING BITS WHILE SCANNING
06600 ; CONDITIONAL COMPILATION EXPRESSIONS
06700 ^^DBTSTK: 0 ; POINTER TO QSTACK FOR SAVING BITS WHILE SCANNING
06800 ; MACRO DEFINITIONS
06900 ^^ENDCTR: 0 ; POINTER TO QSTACK INDICATING WHETHER OR NOT ENDC
07000 ; SHOULD TRIGGER A PARSER SWITCH (NO IF ONE IS
07100 ; SCANNING A WHILEC, CASEC, FORC, OR FORLC BODY)
07200 ^^REQDLM: 0 ; REQUIRE DELIMITER STATEMENT SEEN FLAG
07300 ^^SWBODY: 0 ; SPECIAL DELIMITER DEFINITION SEEN
07400 ^^BNSTCN: 0 ; NESTED DELIMITER COUNT
07500 ^^LOCNST: BLOCK NUMNST ; NESTABLE CHARACTERS BLOCK
07600 ^^NSTABL: BLOCK NUMCHA ; NESTABLE CHARACTERS ADDRESS INDEX BLOCK
07700
07800 ^^NOEMIT: 0 ; DON'T EMIT CODE FLAG FOR THE EMITTER
07900 ^^ACKSAV: BLOCK 13 ; SAVE ACKTAB HERE WHILE EVALUATING EXPR!TYPE
08000 ^^SBSAV: BLOCK 13 ; SAVE $SBITS CORRESPONDING TO ACKSAV VALUES WHILE
08100 ; EVALUATING EXPR!TYPE (AVOIDS HARMFUL SIDE
08200 ; EFFECTS OF CODE GENERATORS)
08300 ^^ADPTSV: 0 ; ADEPTH VALUE BEFORE EXPR!TYPE PROCESSING
08400 ^^PCNTSV: 0 ; PCNT VALUE BEFORE EXPR!TYPE PROCESSING
08500 ^^SDPTSV: 0 ; SDEPTH VALUE BEFORE EXPR!TYPE PROCESSING
08600 ^^RSTDLM: 0 ; TEMPORARY OVERRIDING OF NULL DELIMITERS MODE FLAG
08700 ^^RECSTK: 0 ; POINTER TO QSTACK INDICATING WHETHER MACROS SHOULD
08800 ; BE EXPANDED IN THE FALSE PART OF CONDITIONAL
08900 ; COMPILATION
09000 ^^IFCREC: 0 ; FLAG INDICATING WHETHER MACROS SHOULD BE EXPANDED IN
09100 ; THE FALSE PART OF CONDITIONAL COMPILATION
09200 NULCNT: 0 ; COUNTER INDICATING THE NUMBER OF ACTUAL PARAMETERS
09300 ; THAT HAVE NOT BEEN SPECIFIED AT THE END OF THE LIST OF
09400 ; ACTUALS IN A MACRO CALL. THEY ARE TREATED AS IF THEY
09500 ; HAD BEEN THE NULL STRING (AS DONE AT CMU)
09600 LPTRSV: 0 ; SAVE WORD FOR LISTING BUFFER POINTER SO THAT
09700 ; FALSE PART OF CONDITIONAL COMPILATION DOES NOT
09800 ; GET LISTED
09900 ^^LSTSTK: 0 ; POINTER TO QSTACK INDICATING WHETHER OR NOT ONE
10000 ; IS IN THE FALSE PART OF CONDITIONAL COMPILATION
10100 ^^CNDLST: 0 ; FLAG INDICATING IF ONE IS IN THE FALSE PART OF
10200 ; CONDITIONAL COMPILATION
10300 ;;%CI% (1/5) JFR 7-18-75
10400 TRKMCR: 0 ;ADDR OF $PNAME+1 OF CURRENT MACRO NAME
10500 TRKMCS: 0 ;SAME FOR LAST MACRO IN SOURCE FILE
10600 TRKM.P: 0 ;PAGE # OF LAST MACRO IN SOURCE FILE
10700 TRKM.L: 0 ;ASCLIN # OF LAST MACRO IN SOURCE FILE
10800 ^^TRKBEG: 0 ;PTR TO SECOND BLOCK SEMBLK OF CURRENT BLOCK
10900 ;FOR INFORMATIVE ERROR MESSAGES, "FATAL EOF"
11000 ;;%CI% ^
11100 ;; #RA# (1 OF 2) !
11200 ^^EOFCEL: 0 ; FLAG INDICATING FINAL END OF PROGRAM SEEN
11300
11400 BAIL <
11500 ^^BSRCFC: 0 ; BUFFER ADDR,,BLOCK COUNT FOR SOURCE FILE
11600 ^^BNSRC: 0 ; NUMBER OF SOURCE FILES SEEN
11700 ^^BSRCFN: 0 ; CURRENT SOURCE FILE NUMBER
11800 ^^BSRCFQ: 0 ; QSTACK FOR REQUIRE SAVING
11900 ^^BLSTFC: 0 ; WORD COUNT FOR LISTING FILE
12000 ^^BPPCNT: 0 ; PREVIOUS PROGRAM COUNTER
12100 >;BAIL
12200
12300 IFN FTL$DBG,<
12400 ^^L$CNT: 0 ;#CHARS LEFT IN LSTBUF
12500 >;IFN FTL$DBG
12600
12700 ENDDATA
12800
12900 DSCR LSTDPB
13000
13100
13200 DEFINE LSTDPB < ;OUTPUT CHAR TO LISTING FILE IF REQD
13300 TRNN TBITS2,NOLIST ;IS LISTING HAPPENING, BABY?
13400 ML$CHR ;YES, DO THE REQUIRED THING
13500 >
13600
13700 IFE FTL$DBG,<
13800 DEFINE ML$CHR <IDPB B,LPNT>
13900 DEFINE ML$BAK <MOVEM SBITS2,LPNT>
14000 >;IFE FTL$DBG
14100 IFN FTL$DBG,<
14200 DEFINE ML$CHR <PUSHJ P,L$CHR>
14300 DEFINE ML$BAK <PUSHJ P,L$BAK>
14400
14500 L$CHR: SOSGE L$CNT ;ADD CHAR IN B TO LSTBUF, CHECKING OVERFLOW
14600 ERR <LSTBUF OVERFLOW>,1
14700 IDPB B,LPNT
14800 POPJ P,
14900
15000 5*<POINT 7,0,-1>-5 0 0 0 0
15100 L$TAB: 5*<POINT 7,0,34>-4
15200 5*<POINT 7,0,27>-3
15300 5*<POINT 7,0,20>-2
15400 5*<POINT 7,0,13>-1
15500 5*<POINT 7,0,06>-0
15600
15700 L$BAK: ;BACK UP LPNT TO SBITS2, CHECKING AND COUNTING
15800 CAMN SBITS2,LPNT
15900 POPJ P, ;FREQUENT SPECIAL CASE
16000 PUSH P,LPSA
16100 PUSH P,LPSA+1
16200 MOVE LPSA,SBITS2 ;SUPPOSED BACK BP
16300 MULI LPSA,5 ;HAKMEM STRIKES AGAIN (PROG. HAX,ITEM 165-FREIBERG)
16400 SUB LPSA+1,L$TAB(LPSA) ;LPSA+1 IS NOW CHAR ADDR
16500 PUSH P,LPSA+1
16600 MOVE LPSA,LPNT ;CURRENT BP
16700 MULI LPSA,5
16800 SUB LPSA+1,L$TAB(LPSA)
16900 CAML LPSA+1,(P) ;CURRENT CHR ADDR MUST BE BACKUP
17000 JRST L$BAK1
17100 ERR <LPNT FORWARD "BACKUP">,1
17200 JRST L$BAK2
17300 L$BAK1: MOVEM SBITS2,LPNT ;BACKUP BP
17400 SUB LPSA+1,(P)
17500 ADDM LPSA+1,L$CNT ;AND CNT
17600 L$BAK2: SUB P,X11
17700 POP P,LPSA+1
17800 POP P,LPSA
17900 POPJ P,
18000 >;IFN FTL$DBG
18100
18200 ;;#YV# JFR 2-4-77 SET 'NOLIST' FROM ABSOLUTE BEARINGS
18300 ^^L$SET:TLNE FF,LISTNG ;.LST FILE EXIST?
18400 SKIPE CNDLST ;CHECK FOR EXPLICIT NO LIST OF COND. COMP.
18500 JRST L$NO
18600 MOVE TEMP,FMTWRD
18700 TLNE FF,PRMSCN
18800 TLNE TBITS2,MACLST ;SCANNING PRMS, NOT LISTING MACRO NAMES, DONT LIST ARGS EITHER
18900 TRNE TEMP,40 ;USER MIGHT HAVE EXPLICITLY TURNED IT OFF
19000 JRST L$NO
19100 TLNE TBITS2,MACIN
19200 TLNE TBITS2,MACEXP ;IN A MACRO, NOT LISTING EXPANDED TEXTS
19300 TLNE TBITS2,LOKPRM
19400 L$NO: TROA TBITS2,NOLIST ;HUNTING PRM, OR IN MACRO AND NOT LISTING EXPANSIONS
19500 TRZ TBITS2,NOLIST ;YES LIST
19600 POPJ P,
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 ;; #RA# (2 OF 2)
00800 SKIPE EOFCEL ; FINAL END OF PROGRAM SEEN?
00900 JRST [TLO TBITS2,EOFOK ;
01000 MOVEM TBITS2,SCNWRD ;
01100 JRST .+1];
01200 ;; #RA#
01300 TLZE FF,BAKSCN ;IS SCANNER BACK ONE CHARACTER ??
01400 JRST GOAGAIN ; DO IT.
01500 MOVE USER,GOGTAB ;USER DATA TABLE ADDR FOR STRING STUFF
01600 TLNE TBITS2,INLIN ;SPECIAL START!CODE FEATURE?
01700 SETZM PNAME ;YES, ASSURE NO PNAME USED
01800 ;;#MQ# SET UP SBITS2 FOR BACKING UP LPNT EVEN IF HAVE SAVCHR0
01900 MOVE SBITS2,LPNT
02000 MOVEM SBITS2,LPTRSV ; SAVE IN CASE IN FALSE PART OF COND. COMP.
02100
02200 MOVEI C,0 ;WILL COUNT CHARS FOR IDENTS
02300 SKIPE B,SAVCHR ;IS ANYTHING LEFT OVER?
02400 JRST SPCHAR ;YES, DISPATCH AS FIRST CHAR
02500
02600 TLNN FF,PRMSCN ;SCANNING MACRO PARAMETERS?
02700 JRST DISPT ; NO
02800 TRNA ;SKIP IDPB
02900
03000 ML$CHR ;TO LISTING FILE
03100 DSPRM: ILDB B,PNEXTC ;SKIP IGNORABLE CHARACTERS
03200 SKIPGE A,SCNTBL(B) ;ANYTHING SPECIAL REQUIRED?
03300 PUSHJ P,(A) ;YES, DO IT
03400 JUMPE A,DSPRM-1(TBITS2) ;MAYBE LIST, GET NEXT IGNORABLE
03500
03600 DSPR1: TLO FF,PRMXXX ;SET SPECIAL PARAM SCANNING BIT
03700 TLNE A,QUOTE ;DOES HE WANT COMPLETE FREEDOM?
03800 JRST STRLST ; YES, GIVE IT TO HIM (FIRST LIST `"')
03900 PUSHJ P,INSET ;NO, SPECIAL MODE -- "," OR ")" WILL BREAK
04000 JRST BAKSTR ;AROUND QUOTE DELETION
04100
04200 ML$CHR ;TO LIST FILE
04300 DISPT: ILDB B,PNEXTC ;GET FIRST CHAR
04400 SKIPGE A,SCNTBL(B) ;GET GOOD BITS, CHECK SPECIAL
04500 PUSHJ P,(A) ;SPECIAL, HANDLE IT
04600 JUMPE A,DISPT-1(TBITS2) ;BLANKS AND OTHER IGNORABLES
04700 MOVE SBITS2,LPNT ;SAVE IN CASE BACKUP MUST HAPPEN
04800 MOVEM SBITS2,LPTRSV ; SAVE IN CASE IN FALSE PART OF COND. COMP.
04900 STRLST: LSTDPB ;TO LISTING FILE IF REQD
05000
05100 SPCHAR: SETZM SAVCHR ;NOTHING LEFT OVER YET
05200 SETZM LSTCHR
05300 JUMPL B,[TLZN TBITS2,EOFOK ;OK FOR EOF HERE?
05400 ERR <Fatal end of source file> ;NO
05500 MOVE A,%EOFILE ;YES, RETURN `EOF'
05600 JRST CHAROUT] ;NULL SEMANTICS
05700 SKIPN A,SCNTBL(B) ;GET GOOD BITS (DON'T DISPATCH AGAIN!)
05800 JRST DISPT ; IGNORABLE, FIND ONE THAT ISN'T
05900 SKIPE DLMSTG ; LOOKING FOR SPECIALLY DELIMITED STRING?
06000 CAME B,CURMBG ; POSSIBLY, MACRO BODY BEGIN DELIMITER?
06100 JRST CONCHK ; GO DO A NORMAL SCAN
06200 SETZM BNSTCN ; SET DELIMITER NEST COUNT TO ZERO
06300 JRST STRNG ; GET MACRO BODY
06400
06500 BAIL<
06600 ^^BMKSRC:
06700 MOVE TEMP,BAILON
06800 TRNN TEMP,BBCRD ;SKIP IF WE WANT COORDS
06900 POPJ P,
07000 PUSH P,A
07100 PUSH P,B
07200 PUSH P,C ;WE ARE IN THE HEART OF THE SCANNER, SO BEWARE
07300 ;;%##% 1! JFR 4-18-76
07400 PUSH P,D
07500
07600 MOVE TBITS2,SCNWRD ;PICK UP SCANNER FLAGS
07700 TRNN TBITS2,NOLIST ;LISTING IN PROGRESS?
07800 JRST BCRDLS ;YES
07900 ;;#%%# JFR 2-8-75 FIX THIS CRUFFT FOR MACROS AND CONDITIONAL COMPILATION
08000 TLNE TBITS2,MACIN ;IN A MACRO?
08100 JRST BCRDN2 ;YES, UPDATE COUNTERS ONLY, NOT POINTERS
08200 HRRZ TEMP,PNEXTC
08300 HRRZ SBITS,SRCPNT
08400 SUBI TEMP,(SBITS)
08500 CAIL TEMP,1
08600 CAILE TEMP,200 ;SRCPNT IS A WORD EARLY
08700 JRST BCRDN2 ;PNEXTC IS OUT IN THE BOONIES
08800 ;;#%%# ^
08900 MOVE TEMP,PNEXTC
09000 MOVEM TEMP,BPNXTC ;SAVE BYTE POINTER
09100
09200 HRR SBITS,BSRCFC ;BLOCK COUNT FOR SOURCE FILE
09300 HRRZ A,BPNXTC ;ADDR OF CURRENT WORD IN BUFFER
09400 ;;#%%# BY JFR 11-17-74 CORRECT COMPUTATION OF WORD OFFSETS
09500 HRRZ B,SRCPNT ;WORD EARLY POINTER
09600 ADDI B,1 ;CORRECT
09700 ;;#%%# ^
09800 LDB C,[POINT 5,BSRCFN,35-0] ;FILE NUMBER
09900 LDB D,[POINT 6,BPNXTC,35-30] ;"P" PORTION OF BYTE POINTER
10000 JRST BCRDN1
10100 BCRDLS:
10200 NOTENX<
10300 LDB SBITS,[POINT 18,BLSTFC,35-7] ;BLOCK COUNT FOR LIST FILE
10400 ADDI SBITS,1 ;FIRST BLOCK IS 1, NOT 0
10500 HRRZ A,LPNT ;ADDR OF CURRENT WORD IN BUFFER
10600 HRRZ B,LSTBUF ;ADDR OF FIRST WORD
10700 LDB D,[POINT 6,LPNT,35-30] ;"P" PORTION OF BYTE POINTER
10800 >;NOTENX
10900 TENX<
11000 MOVE A,BLSTFC ; CHAR COUNT FOR LIST FILE
11100 IDIVI A,5 ;WORD COUNT IN A, REMAINDER IN B
11200 SUBI B,5 ;BEGIN CONSTRUCTION OF "P" OF BYTE POINTER
11300 MOVM D,B
11400 IMULI D,7
11500 ADDI D,1 ;FINISHED
11600 LDB SBITS,[POINT 18,A,35-7] ;BLOCK COUNT FOR FILE
11700 ADDI SBITS,1
11800 ANDI A,177 ;WORD OFFSET IN A
11900 SETZ B, ; FAKE IT FOR BCRND1
12000 >;TENX
12100 SETZ C, ;LIST FILE IS NUMBER 0
12200 BCRDN1: SUBI A,(B) ;WORD OFFSET IN BUFFER
12300 ;;
12400 TLCE TBITS2,PCOUT!LINESO
12500 ADDI A,2 ;PC OR SOS LINE NUMBER GIVES 2 EXTRA WDS
12600 TLCN TBITS2,PCOUT!LINESO
12700 ADDI A,1 ;BOTH GIVE 3
12800 ;;
12900 DPB A,[POINT 7,SBITS,35-18] ;INSERT WORD OFFSET
13000 DPB C,[POINT 5,SBITS,35-25] ;INSERT FILE NU DP
13100 DPB D,[POINT 6,SBITS,35-30] ;INSERT "P" POINTER
13200 MOVEM SBITS,BCRDW1 ;SAVE
13300 BCRDN2: HRL SBITS,BCORDN ;COORD NUMBER
13400 ;SEE IF ANYTHING IS IN THE ACS
13500 MOVSI TEMP,-20 ;LENGTH OF ACKTAB
13600 MOVE A,ACKTAB(TEMP)
13700 JUMPE A,.+3 ;JUMP IF VACANT
13800 ADDI A,1
13900 JUMPN A,.+3 ;JUMP IF NOT PROTECTED, I.E. BUSY
14000 AOBJN TEMP,.-4 ;LOOP
14100 TLO SBITS,400000 ;MARK AS ALLSTO
14200
14300 HRR SBITS,PCNT
14400 MOVEM SBITS,BCRDW2 ;SAVE
14500
14600 BXCRD:
14700 ;;%##% 1! JFR 4-18-76
14800 POP P,D
14900 POP P,C
15000 POP P,B
15100 POP P,A
15200 POPJ P,
15300
15400 ^^BCROUT: ;PUT COORD OUT TO .SM1 FILE IF NECESSARY
15500 ;;%##% 1! JFR 4-18-76
15600 SKIPE TEMP,BPNXTC ;DONT PUT ONE OUT IF TEXT NOT MARKED YET
15700 SKIPLE TEMP,BAILON ;SKIP IF BAIL OFF
15800 TRNN TEMP,BBCRD ;SKIP IF WE WANT COORDS
15900 POPJ P,
16000 MOVE TEMP,PCNT
16100 SKIPN NOEMIT ;NO COORDS FOR EXPR TYPE
16200 CAMN TEMP,BPPCNT ;NO SKIP IF PCNT SAME AS BEFORE
16300 BCRPJ: POPJ P,
16400 SETZM BPNXTC ;REMEMBER TO MARK SOURCE AT NEXT TOKEN
16500 EXCH TEMP,BPPCNT ;UPDATE, KEEP OLD VALUE
16600 JUMPE TEMP,BCRPJ ;FIRST TIME THROUGH IS JUST SETUP
16700 PUSH P,A
16800 PUSH P,B
16900 PUSH P,C ;TAKE CARE IN SCANNER
17000 ;;%##% 1! JFR 4-18-76
17100 PUSH P,D
17200 AOS A,BCORDN ;INCREMENT COORD COUNT
17300 TLOE A,1 ;IS CURRENT TABLE OF .SM1 FILE A COORD TABLE?
17400 JRST BCROU1 ;YES
17500 MOVEM A,BCORDN ;UPDATE
17600 SETZ SBITS,
17700 PUSHJ P,VALOUT ;END PREVIOUS TABLE OF .SM1 FILE
17800 MOVEI SBITS,BAICRD
17900 PUSHJ P,VALOUT ;START COORD TABLE
18000 BCROU1: MOVE SBITS,BCRDW1
18100 PUSHJ P,VALOUT ;FIRST WORD
18200 MOVE SBITS,BCRDW2
18300 PUSHJ P,VALOUT ;SECOND WORD
18400 JRST BXCRD
18500 >;BAIL
18600
18700 CONCHK:
18800 ;;%DI% 3! JFR 12-2-75 CLEAN UP BEGINNING OF COORDINATE, ESP. FOR "CASE"
18900 BAIL< SKIPN BPNXTC ;IF SOURCE NOT MARKED
19000 PUSHJ P,BMKSRC ; THEN DO SO
19100 >;BAIL
19200 TLNE A,LETDG ; LETTER OR NUMBER?
19300 JRST CHKNUM ; YES, GO SEE WHICH
19400 BAIL<
19500 CAIN B,";" ;TEST FOR END OF STATEMENT
19600 PUSHJ P,BCROUT ;YES. PUT OUT COORDINATE
19700 >;BAIL
19800 ;;\UR#4\ ALLOW := FOR _, >= FOR GEQ, <= FOR LEQ , ** FOR ^
19900 CAIN B,":"
20000 JRST [PUSHJ P,[SNEAKC:
20100 ILDB B,PNEXTC ; PICK UP NEXT CHARACTER
20200 SKIPGE A,SCNTBL(B); MAKE SURE NOT END OF BUFFER ETC.
20300 PUSHJ P,(A) ; IF IS. HANDLE IT.
20400 TRNN TBITS2,-1 ; LISTING?
20500 ML$CHR ; YEP.
20600 POP P,TEMP ;RETRIEVE PTR TO ARGS
20700 MOVE A,@(TEMP) ;ASSUME THIS
20800 CAMN B,1(TEMP) ;DOES 2ND CHAR MATCH?
20900 JRST CHAROUT ;YES, ASSUMPTION CORRECT
21000 MOVEM B,SAVCHR ;ASSUMPTION WRONG. SAVE 2ND CHAR
21100 MOVEM B,LSTCHR
21200 MOVE A,@2(TEMP) ;GET ORIGINAL SEMANTICS
21300 JRST CHAROUT] ;AND LEAVE
21400 SCNTBL+"_" ;ASSUME SEMANTICS OF _
21500 0,,"=" ;2ND CHAR OF := IS "="
21600 SCNTBL+":" ;SEMANTICS IN CASE ASSUMPTION OF _ FAILS
21700 ]
21800 CAIN B,76 ;a GREATER THAN CHAR
21900 JRST [PUSHJ P,SNEAKC
22000 SCNTBL+" " ;ASSUME WE REALLY HAVE GEQ
22100 0,,"=" ;2ND CHAR IS "="
22200 SCNTBL+76] ;ASSUMPTION FAILS, WE HAVE GTR
22300 CAIN B,74
22400 JRST [PUSHJ P,SNEAKC
22500 SCNTBL+" "
22600 0,,"="
22700 SCNTBL+74]
22800 CAIN B,"*"
22900 JRST [PUSHJ P,SNEAKC
23000 SCNTBL+"^"
23100 0,,"*"
23200 SCNTBL+"*"]
23300 ;;\UR#4\
23400 TLNN A,QUOTE ;STRING CONSTANT?
23500 JRST CHAROUT ; NO, OPERATOR, OUTPUT ID, NULL SEMANTICS
23600 ;;#XO# ! JFR 10-14-76
23700 TLZ TBITS2,EOFOK ;saw a " char, must see another
23800 ; (particularly after final END "FOO )
23900 SKIPN DLMSTG ; HAS A QUOTE BEEN USED TO DELIMIT A MACRO
24000 ; BODY WHILE IN REQUIRE DELIMITERS MODE?
24100 JRST STRNG ; NO, SCAN A STRING CONSTANT IN NORMAL MODE.
24200 SETZM DLMSTG ; YES, TURN OFF DLMSTG FLAG AND TURN ON
24300 SETOM BAKDLM ; BAKDLM FLAG SO THAT WHEN SCANNING THE
24400 JRST STRNG ; MACRO BODY A QUOTE WILL BREAK THE SCAN.
24500
24600 CHKNUM: TLNE A,NUMB ;NUMBER PART?
24700 JRST SCNUMB ; YES, SCAN NUMBER
24800
24900
00100 ; ID -- RESET FOR SCAN
00200
00300 DSCAN: PUSHJ P,INSET ;CLEAR PNAMES, COUNT, ALIGN TO FW
00400 BAIL<
00500 SKIPN BPNXTC ;DOES DEBUGGER KNOW WHERE WE ARE?
00600 PUSHJ P,BMKSRC ;NO -- GO MARK PLACE
00700 >;BAIL
00800 MOVE TBITS2,SCNWRD ;MAKE SURE THE BITS ARE RIGHT
00900 TLO TBITS2,EOFOK ;EOF CAN END THE WORLD WITHOUT KILLING IT
01000 MOVEI C,1 ;ACCOUNT FOR FIRST CHARACTER
01100 TRNA
01200 ML$CHR ;TO LISTING FILE
01300 IDSCAN: IDPB A,TOPBYTE(USER) ;STORE CONVERTED CHAR
01400 ILDB B,PNEXTC ; GET NEXT CHARACTER
01500 SKIPGE A,SCNTBL(B) ;GET GOOD BITS, CHECK SPECIAL
01600 PUSHJ P,CSPEC ;SPECIAL, DO SOMETHING
01700 TLNE A,LETDG ;DONE WITH ID?
01800 AOJA C,IDSCAN-1(TBITS2) ;NO, GO GET MORE.
01900
02000 Comment Now the symbol is in string space, pointed to
02100 by the string descriptor in PNAME, etc. Store the
02200 count, make the lookup, set up the results
02300
02400 CAIE B,12 ;IF LF, ALREADY HANDLED, LEAVE SAVCHR 0
02500 MOVEM B,SAVCHR ;SAVE THE BREAK BITS (0 IF BLANK OR CR BROKE)
02600 MOVEM B,LSTCHR ;ALSO HERE ANY TIME
02700 TLZ TBITS2,EOFOK ;DONE WITH THIS MODE
02800
02900 PUSHJ P,UPDCNT ;UPDATE PNAME CNT, REMCHR CNT, COLLECT IF NECC.
03000 MOVE LPSA,SYMTAB ;TRY TO FIND IT
03100 PUSH P,B ;SAVE FOR LATER
03200 PUSHJ P,SHASH ;LIKE SO
03300 POP P,B ;GET IT BACK
03400 MOVEM TBITS2,SCNWRD ;SAVE ANY CHANGES
03500 TLNE TBITS2,LOKPRM ;STACK IT?
03600 POPJ P, ; NO, IN STRING CONSTANT MODE
03700
03800 ; GET RELEVANT DATA TO STACKS
03900
04000 MOVE A,%ID ;IT IS AN IDENTIFIER
04100 SKIPG LPSA,NEWSYM ;IF IT IS UNDEFINED,
04200 JRST LSTACK ; PUSH TO STACKS
04300
04400 MOVE TBITS,$TBITS(LPSA)
04500 ;IF CREFFING, DO IT NOW...
04600 TLNE FF,CREFSW ;
04700 PUSHJ P,LCREFIT
04800
04900 JUMPGE TBITS,USID ; NO, USER ID
05000 LSTDPB
05100 MOVE A,TBITS ;RESULTANT PL-ID
05200 ;;%CI% ! JFR 7-26-75
05300 MOVEI TEMP,$PNAME+1(LPSA) ;ADDR OF B.P. TO RES WORD
05400 MOVEI LPSA,0 ;MAKE NULL SEMANTICS
05500 CAMN A,%COMMENT ; COMMENT?
05600 JRST CHKSAV ; YES, GO PROCESS IT
05700 TLNN TBITS,CONRES ; PARSER SWITCHING RESERVED WORD?
05800 JRST STACK ; NO, RETURN RESERVED WORD
05900 ;;%CI%
06000 MOVEM TEMP,TRKMCR ;CURRENT "MACRO"
06100 SKIPN SWCPRS ; YES, NEED TO SWITCH PARSERS?
06200 JRST STACK ; NO, RETURN RESERVED WORD
06300 TLNE TBITS2,MACIN ;IN A MACRO??
06400 JRST .+5 ;YES, DON'T RECORD
06500 MOVEM TEMP,TRKMCS ; SOURCE-FILE TOKEN
06600 MOVEI TEMP,TRKM.P-1
06700 PUSH TEMP,FPAGNO ; PAGE #
06800 PUSH TEMP,ASCLIN ; LINE #
06900 ;;%CI% ^
07000 TLNE TBITS,DEFINT ; PARSER INTERRUPT (I.E. NO SWITCHING)?
07100 JRST[SKIPE NODFSW ; DEFER DEFINE HANDLING FOR BLOCK EXECUTION?
07200 JRST STACK ; YES, RETURN RESERVED WORD
07300 MOVE TEMP,SCNNO ; YES, SAVE NUMBER OF SCANS REMAINING IN LEFT HALF
07400 MOVE B,PCSAV ; OF TOP OF PRODUCTION STACK, UNPACK $TBITS ENTRY
07500 HRLM TEMP,(B) ; OF THE RESERVED WORD TO GET AN INDEX OF ADDRESS
07600 JRST CONDAD] ; TO PUSHJ TO, AND SET SCNNO TO ONE.
07700 TLNE TBITS,CONDIN ; CHECK IF ENDC HAS OCCURRED AS THE END OF A WHILEC,
07800 JRST ENDCOK ; CASEC, FORC, OR FORLC BODY AND IF SO, THEN DO NOT
07900 HLRZ TEMP,ENDCTR ; SWITCH PARSERS. ENDCTR IS A POINTER TO A QSTACK
08000 SKIPE (TEMP) ; INDICATING SUCH INFORMATION.
08100 JRST STACK ;
08200 ENDCOK: MOVEI TEMP,CGPSAV-1 ; DETERMINE WHICH PARSER ONE IS CURRENTLY IN AND
08300 SKIPN PRSCON ; GET THE ADDRESS TO SAVE ITS PARSER DESCRIPTOR.
08400 MOVEI TEMP,SGPSAV-1 ; SAVE SEMANTIC STACK POINTER, PARSE STACK POINTER,
08500 PUSH TEMP,GPSAV ; NUMBER OF SCANS REMAINING IN LEFT HALF OF TOP OF
08600 PUSH TEMP,PPSAV ; PRODUCTION STACK, PRODUCTION STACK POINTER,
08700 MOVE SP,SCNNO ; CURRENT SCNWRD, AND A POINTER TO THE SCNWRD
08800 MOVE B,PCSAV ;
08900 HRLM SP,(B) ; STACK.
09000 PUSH TEMP,PCSAV ;
09100 MOVE B,SCWSV ;
09200 MOVEM TBITS2,(B) ; SAVE SCNWRD
09300 PUSH TEMP,SCWSV ;
09400 HRROI TEMP,SSCWSV ; DETERMINE WHICH PARSER IS TO BE RESUMED AND GET
09500 SKIPN PRSCON ; THE ADDRESS OF ITS PARSER DESCRIPTOR.
09600 HRROI TEMP,CSCWSV ;
09700 POP TEMP,B ; RESTORE SCNWRD STACK POINTER
09800 TLNE TBITS,CONDIN ; IF ONE IS SWITCHING PARSERS VIA A PUSHJ INSTEAD OF
09900 JRST[TLZ TBITS2,INLIN ; PROPER SCANNING OF INLINE STARTCODE. COMPENSATE
10000 TRO TBITS2,NOLIST ; FOR NOT POPPING TEMP.
10100 PUSH B,TBITS2 ;
10200 JRST .+2] ;
10300 MOVE TBITS2,(B) ; RESTORE SCNWRD AND TBITS2
10400 MOVEM B,SCWSV ;
10500 MOVEM TBITS2,SCNWRD ;
10600 ML$BAK ; DON'T LIST PARSER SWITCH TRIGGERING RESERVED WORDS
10700 POP TEMP,B ; RESTORE CONTROL STACK POINTER
10800 POP TEMP,SP ; RESTORE PARSE STACK POINTER. MUST BE IN AC AS
10900 MOVEM SP,PPSAV ; WELL AS IN MEMORY.
11000 POP TEMP,GPSAV ; RESTORE SEMANTIC STACK POINTER
11100 SETCMM PRSCON ; COMPLEMENT PARSER IN CONTROL FLAG
11200 MOVEI C,1001 ; ASSUME A RESUME TYPE SWITCH
11300 TLNN TBITS,CONDIN ; RESUME TYPE SWITCH?
11400 JRST SWTPRE ; YES
11500 CONDAD: HLRZ C,TBITS ; CONDAD IS CALLED WITH THE $TBITS ENTRY
11600 TRZ C,RES+CONBTS ; OF A PARSER INTERRUPT RESERVED WORD IN
11700 LSH C,-IF0SHF ; TBITS. IT INSERTS THE ADDRESS OF THE
11800 MOVEI C,PRODGO(C) ; PRODUCTION WHICH ONE IS TO EXECUTE NEXT
11900 PUSH B,C ; IN THE PRODUCTION CONTROL STACK. TBITS
12000 MOVEI C,4001 ; IS UNPACKED TO GET AN INDEX TO A TABLE
12100 ; STARTING AT PRODG0 (BITS 6-8). SET
12200 ; REMAINING NUMBER OF CALLS TO SCANNER TO
12300 ; ONE SO THAT THE PARSER WILL NOT SCAN
12400 ; AGAIN AND SET A BIT TO DO A PUSHJ.
12500 SWTPRE: MOVEM B,PCSAV ; RESTORE CONTROL STACK POINTER IN CORE
12600 MOVEM C,SCNNO ; SET REMAINING NUMBER OF CALLS TO SCANNER
12700 JRST STACK ; GO STACK
12800
12900
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 ML$CHR ;TO LISTING FILE
01400 NOBAIL<
01500 COMLUP: CAIN B,";" ;DONE?
01600 JRST SCANNER ; YES
01700 >;NOBAIL
01800 BAIL<
01900 COMLUP: CAIE B,";" ;DONE?
02000 JRST COMILD ; NO
02100 SETZM BPNXTC ;YES. MARK SOURCE AT NEXT TOKEN
02200 JRST SCANNER
02300 >;BAIL
02400 COMILD: ILDB B,PNEXTC ;GET NEXT CHAR
02500 SKIPGE A,SCNTBL(B) ;USUAL
02600 PUSHJ P,(A)
02700 JRST COMLUP-1(TBITS2) ;GO PUT AWAY, GET ANOTHER
02800
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 [ML$BAK ;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 ML$CHR ; 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
12100
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 ;;%CI% (2,3/5) JFR 7-25-75
02000 MOVEI TEMP,$PNAME+1(LPSA) ;ADDR OF B.P. TO MACRO NAME
02100 MOVEM TEMP,TRKMCR ;CURRENT MACRO
02200 TLNE TBITS2,MACIN ;IN A MACRO??
02300 JRST .+5 ;YES, DON'T RECORD SOURCE-FILE INFO
02400 MOVEM TEMP,TRKMCS
02500 MOVEI TEMP,TRKM.P-1
02600 PUSH TEMP,FPAGNO
02700 PUSH TEMP,ASCLIN
02800 ;;%CI% ^
02900 HLRZ TEMP,$VAL(LPSA) ;ANY PARAMETERS NEEDED?
03000 JUMPE TEMP,NOPRMS ; NO
03100 MOVEM TBITS2,SCNWRD ;NOTE CHANGES
03200 SCNAGN: PUSHJ P,SCANNER ;LOOKING FOR "("
03300 MOVE TEMP,(SP) ;SYNTAX OF SCANNED ELEMENT
03400 POP P,GPSAV ;KEEP STACKS IN SYNCH
03500 POP P,PPSAV
03600 ADD P,X22
03700 CAMN TEMP,%STCON ; A SPECIAL DELIMITER DECLARATION?
03800 SKIPE SWBODY ; YES, COULD WE POSSIBLY HAVE SEEN A SPEC DEL DECL.
03900 ; I.E. DID WE SEE ONE ALREADY?
04000 JRST TSLPRN ; NO, GET LEFT PAREN.
04100 SKIPN REQDLM ; TRYING TO OVERRIDE NULL DELIMITERS MODE?
04200 SETOM RSTDLM ; YES, SET APPROPRIATE FLAGS
04300 SETOM REQDLM ;
04400 SETOM SWBODY ; SET SWITCH DELIMITER DECLARATION FLAG
04500 MOVE TEMP,[XWD -2,2] ; SET UP A COUNT
04600 MOVE PNT,$PNAME+1(LPSA) ; PNT HAS BYTE POINTER TO DELIM. STRING
04700 HRRZ LPSA,$PNAME(LPSA) ; LPSA HAS DELIMITER STRING LENGTH
04800 PUSHJ P,GETDL2 ; GET SPECIAL DELIMITER DECLARATION
04900 JRST SCNAGN ; GO BACK AND GET LEFT PAREN.
05000 TSLPRN: CAME TEMP,[TLPRN&17777777] ;PARAMS?
05100 ;;%CU% (1/2) JFR 8-16-75 make this error continuable
05200 JRST [ERR <MISSING "(" IN MACRO CALL>,1
05300 MOVEI TEMP,SCANNER
05400 MOVEM TEMP,-4(P)
05500 JRST CONACT+2] ; NO
05600 ;;%CU% ^
05700 MOVEI B,"("
05800 LSTDPB
05900 TLO FF,PRMSCN ; PRIME THE SCANNER FOR PARAMETER
06000 PUSHJ P,FFPUSH ; SAVE OLD DEFLUK BIT OF FF AND TURN IT ON IN FF
06100 ;;#TG# 9-15-74 HJS RESTORE PARSE STACK POINTER
06200 PRMLUP: MOVE SP,PPSAV ; RESTORE SP SINCE IT POINTS TO THE PARSE STACK
06300 ; SINCE OTHERWISE MAY GET OVERFLOW SINCE STACK
06400 ; IS CALLED AT THE END OF EACH PARAMETER SCAN
06500 ;;#TG#
06600 SKIPN REQDLM ; IN SPECIAL DELIMITER MODE?
06700 JRST PRMOLD ; NO
06800 PUSHJ P,SCNPMR ; YES, GET THE PARAMETERS
06900 TRNA
07000 PRMOLD: PUSHJ P,SCANNER ;GET A PARAMETER
07100 POP P,GPSAV ;SYNCH STACK
07200 POP P,PPSAV
07300 ADD P,X22
07400
07500 ; WE KNOW RESULT IS STRING CONSTANT, SCANNER WILL RETURN NO OTHER
07600
07700 SKIPN TEMP,DEFRN2 ;PUT PTR TO FIRST ARG IN DEFRN2
07800 MOVE TEMP,NEWSYM
07900 MOVEM TEMP,DEFRN2
08000
08100 PUSHJ P,SCANNER ;GET NEXT PUNCTUATION
08200 MOVE TEMP,(SP)
08300 POP P,GPSAV
08400 POP P,PPSAV
08500 ADD P,X22 ;SYNCH STACKS
08600 CAMN TEMP,[TCOMA&17777777] ;LOOPING?
08700 JRST PRMLUP ;YES
08800 CAME TEMP,[TRPRN&17777777] ;DONE?
08900 ;;%CU% (2/2) JFR 8-16-75 make this error continuable; even recoverable
09000 ;; JRST [ERR <MISSING "," OR ")" IN MACRO CALL>,1
09100 ;; MOVEI TEMP,SCANNER
09200 ;; MOVEM TEMP,-4(P)
09300 ;; JRST CONACT]
09400 PUSHJ P,[PUSHJ P,ER40 ;inserted missing )
09500 JRST SCNBAK] ;scanner is ahead
09600 ;;%CU% ^
09700 MOVE LPSA,DEFRN2 ; DETERMINE IF ALL PARAMETERS HAVE BEEN
09800 MOVEI TEMP,0 ; SPECIFIED AND IF NOT FORM NULL'S FOR
09900 DEFLNK: HRRZ LPSA,%RVARB(LPSA); ALL THOSE LEFT OUT SO THAT ASSIGNC
10000 ADDI TEMP,1 ; WILL WORK PROPERLY
10100 JUMPN LPSA,DEFLNK ;
10200 MOVE LPSA,-3(P) ;
10300 HLRZ LPSA,$VAL(LPSA)
10400 SUB TEMP,LPSA ; NUMBER OF UNSPECIFIED PARAMETERS
10500 MOVEM TEMP,NULCNT ;
10600 TSTDON: AOSLE NULCNT ; ALL PARAMETERS SPECIFIED?
10700 JRST CONACT ; YES,
10800 PUSHJ P,INSET ; SET UP STRING SPACE ENTRY
10900 ADDI C,2 ; APPEND 1770 TO NULL STRING AND LINK
11000 MOVEI TEMP,177 ; ON VARB AND STRING RINGS
11100 IDPB TEMP,TOPBYTE(USER) ;
11200 MOVEI TEMP,0 ;
11300 IDPB TEMP,TOPBYTE(USER) ;
11400 PUSHJ P,UPDCNT ;
11500 GETBLK NEWSYM ;
11600 HRROI TEMP,PNAME+1 ;
11700 POP TEMP,$PNAME+1(LPSA) ;
11800 POP TEMP,$PNAME(LPSA) ;
11900 MOVE TEMP,[XWD CNST,STRING] ;
12000 MOVEM TEMP,$TBITS(LPSA) ;
12100 PUSHJ P,RNGSTR ;
12200 PUSHJ P,RNGVRB ;
12300 JRST TSTDON ;
12400 CONACT: TLZ FF,PRMSCN ; DONE WITH THESE
12500 PUSHJ P,FFPOP ; RESTORE DEFLUK BIT OF FF
12600 SKIPE REQDLM ; IN SPECIAL DELIMITER MODE?
12700 SKIPN SWBODY ; YES, HAVE TO REVERT TO OLD DELS?
12800 JRST NOPRMS ; NO
12900 SETZM SWBODY ; RESET SWITCH DELIMITER DECLARATION FLAG
13000 SKIPN RSTDLM ; RESTORING NULL DELIMITERS MODE?
13100 JRST .+4 ; NO
13200 SETZM RSTDLM ; YES, RESTORE APPROPRIATE FLAGS
13300 SETZM REQDLM ;
13400 JRST NOPRMS ;
13500 HRROI TEMP,LOCMPR+1 ; GET RESTORING ADDRESS
13600 POP TEMP,CURPED ; RESTORE START DEL.
13700 POP TEMP,CURPBG ; RESTORE END DEL.
13800 NOPRMS: POP P,GPSAV ; GET SEMANTIC STACK BACK
13900 POP P,PPSAV ; GET PARSE STACK BACK
14000 POP P,VARB ; GET OLD VARB BACK
14100 POP P,LPSA ; SEMANTICS FOR DEFINE
14200 MOVE SP,PPSAV ; RESTORE SP IN CASE IT GOT FOULED UP IN
14300 ; SCANNER CALLS
14400 POPJ P, ; RETURN
14500
14600
14700
14800 DSCR -- ACPMED
14900 DES ACPMED prepares for a macro call once the actual parameters have been
15000 scanned. It is also used to prepare for the first instantiation of the
15100 body of a conditional compilation WHILEC, CASEC, FORC, or FORLC statement.
15200 PAR LPSA contains the semantics of the macro name or macro pseudonym in
15300 case a conditional compilation WHILEC, CASEC, FORC, or FORLC body is
15400 being scanned for the first time. DEFRN2 contains the address of the
15500 actual parameter list in case of a FORLC statement, the address of the
15600 loop variable semblk in case of a FORC statement, and zero in the case
15700 of a WHILEC or CASEC statement.
15800 RES At the end of this procedure one has effectively switched PNEXTC and
15900 PNEXTC-1 to scan the macro body or the conditional compilation body.
16000 Relevant information is saved on the DEFPDP stack.
16100
16200
16300
16400
16500 ^ACPMED: MOVE PNT,DEFPDP ;RESTORE NOW
16600 PUSH PNT,DEFRNG ;SAVE OLD RING OF PARAMETERS
16700
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 ;;#YV# JFR 2-4-77
01700 TLNN TBITS2,LSTEXP ; IS ALSO BEING LISTED
01800 JRST ACPM.1
01900 LSTDPB ;LISTING MIGHT BE OFF FOR OTHER REASONS
02000 ACPM.1:
02100 TLON TBITS2,MACIN ;IN A MACRO NOW
02200 MOVEM PNT,IPLINE ;CAN GET CURRENT LINE LOC FROM HERE
02300 ;;#ZH# JFR 9-17-77
02400 ;; TLNN TBITS2,MACEXP ;IF MACRO EXPANSION SHOULD NOT BE LISTED,
02500 ;; TRO TBITS2,NOLIST ; INDICATE IT
02600 PUSHJ P,L$SET ;SET COURSE FROM ABSOLUTE BEARINGS
02700 ;;#ZH# ^
02800 ;;#YV# ^
02900 MOVEM TBITS2,SCNWRD ;UPDATE IN CORE
03000 POPJ P, ; RETURN
03100
03200
03300
03400 DSCR -- CONTXT
03500 DES CONTXT is used to switch the input pointers before a macro call or
03600 prior to each invocation of the body of conditional compilation WHILEC,
03700 CASEC, FORC, or FORLC statement. If conditional compilation is the case
03800 then this is virtually all that need be done for the reinvocation of the
03900 body and thus it is clearly cheaper than calling the macro in the old
04000 sense several times with different variables (this statement is only true
04100 for the WHILEC, FORC, and FORLC statement since the body of a CASEC
04200 statement is only scanned once).
04300 PAR LPSA contains the semantics of the macro name or macro pseudonym in the
04400 case of a conditional compilation WHILEC, CASEC, FORC, or FORLC statement.
04500 RES PNEXTC, PNEXTC-1, PLINE, and PLINE-1 are set.
04600
04700
04800
04900
05000 ^CONTXT: HLRZ LPSA,%TLINK(LPSA) ;SEMANTICS FOR MACRO BODY
05100 CONTX2: PUSHJ P,SGCOL1 ;MAKE SURE THERE'S ENOUGH ROOM
05200 HLLZ TEMP,$PNAME(LPSA) ;STRING NUMBER -- NULL STRING
05300 MOVEM TEMP,PNEXTC-1
05400 MOVEM TEMP,PLINE-1
05500 MOVEW PNEXTC,$PNAME+1(LPSA) ;SET UP NEW INPUT POINTER
05600 MOVEM TEMP,PLINE
05700 SETZM SAVCHR ; NOTHING SCANNED AHEAD AT THIS LEVEL
05800 SETZM LSTCHR ; NOTHING SCANNED AHEAD AT THIS LEVEL
05900 POPJ P, ; RETURN
06000
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:
01010 PUSHJ P,INSET ;CLEAR AND RESET AS ABOVE
01050
01110 ;[05] Ensure that there is room in string space for a large string,
01115 ;[05] thereby making it less likely that a large string constant or
01117 ;[05] macro will cause TOPBYTE out of range at STRNGC error
01120 EXTERNAL STRGC ;[05] Need this for patch
01150 MOVEI A,^D5000 ;[05] We want at least 5000 chars
01155 MOVE B,REMCHR(USER) ;[05] Neg. Number chars left
01160 ADD B,A ;[05]
01165 SKIPG B ;[05] More than 5000 chars left?
01167 JRST STRNG1 ;[05] Yes, we are safe
01168 PUSH P,A ;[05] No, so get some space
01170 PUSHJ P,STRGC ;[05]
01175 PUSHJ P,INSET ;[05] Need to do this again
01185
01190 STRNG1:
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
07200
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 the length of the string up to the start of the ident.
01100 3. Scan this (possible) param into the constant, no case conversion.
01200 4. Save the length of the string up to the end of the ident.
01300 5. Save state of scanner (char, bits), then return PNEXTC to the
01400 ident within the string const. Call DSCAN (ident scanner) to con-
01500 vert and lookup this identifier (some special bits set to avoid
01600 stacking results, etc.)
01700 6. If not a DEFINE parameter, reset TOPBYTE and PNAME pointers to
01800 their state at the end of step 3, clear space used during DSCAN,
01900 and return to main string constant loop.
02000 7. Back TOPBYTE pointer up to the length of step 2, insert '177
02100 (param marker), followed by param number into string, clear space
02200 used during steps 3 and 4, update PNAME count properly, and return
02300 to main loop.
02400
02500 Substring operations are used to retrieve the relevant byte
02600 pointers from the saved lengths, and only when they are really
02700 needed, to avoid the garbage collect problems with multiple
02800 saved pointers which plagued past implementations, and made
02900 the multiple string space implementation impossible.
03000
03100 Be warned (again) that the current setup is the result of several
03200 (+1) killed bugs -- each thought to be the last. No
03300 guarantees are proferred that no more exist, but chances are
03400 (even) better than ever.
03500
03600
00100 DEFCHK:
00200 TLNE A,NUMB ;MUST BE A LETTER
00300 JRST DEPOSIT ; DIGIT OR OTHER NUMBER PART, GO ON
00400 PUSH P,C ;save length just before scanning ident
00500 RANSCN: ADDI C,1 ;COUNT FIRST CHAR
00600 LSTDPB ;LIST IF NECESSARY
00700 RANSC1: IDPB B,TOPBYTE(USER) ;KNOW FIRST ONE IS OK
00800 ILDB B,PNEXTC
00900 SKIPGE A,SCNTBL(B) ;USUAL TEST
01000 PUSHJ P,CSPEC
01100 TLNN A,LETDG
01200 JRST SEEPRM ; NOT A LETTER OR DIGIT
01300 SKIPN REQDLM ; SPECIAL DELIMITER MODE
01400 JRST CHKCON ; NO
01500 CAMN B,CURMED ; MACRO BODY END DELIMITER
01600 JRST MBEDCK ; YES
01700 CAMN B,CURMBG ; MACRO BODY BEGIN DELIMITER
01800 AOS BNSTCN ; YES, INCREMENT NEST COUNT
01900 JRST CHKCON ; CONTINUE ID SCAN
02000 MBEDCK: SOSL BNSTCN ; DONE WITH MACRO BODY
02100 CHKCON: AOJA C,RANSC1-1(TBITS2) ; COUNT AND LOOP
02200
02300 ; NOW CONVERT IDENT TO UPPER CASE, ALIGN, CALL SCANNER TO LOOK IT UP
02400
02500 SEEPRM:
02600 PUSH P,A ;SAVE BITS,
02700 PUSH P,B ; CHARACTER, AND CURRENT TOTAL
02800 PUSH P,C ; MACRO BODY STRING COUNT
02900 HRRM C,PNAME ; END POINTER OVER GC
03000 ; P stack is:
03100 ; -3 -- length before ident scanned into string const
03200 ; -2 -- bits for char after ident.
03300 ; -1 -- char after ident.
03400 ; 0 -- length after ident scanned into string const
03500 HRRZ TBITS,-3(P);use length(id)+5 for string space need
03600 SUBM C,TBITS
03700 PUSH P,TBITS ;save id length for remchr update
03800 ADDI TBITS,5 ;WILL MOVE OUT TO AVOID A PROBLEM
03900 COLNEC: PUSHJ P,SGCOL2 ;COLLECT IF NECESSARY
04000 ; Developing string constant is now at the end of the current
04100 ; string space, with room beyond for the identifier scan.
04200 ; P Stack as before, with ident length added to top
04300 AOS TOPBYTE(USER) ;IDPB-ILDB GETS INTO LOOP IN DSCAN IF NOT
04400 ;;#WN# JFR 3-24-76 THERE ONCE WAS A BIG HAIRY MACRO THAT NEEDED THIS PATCH.
04500 ; SEEMS GENERALLY RIGHT, TOO, IN LIGHT OF ABOVE AOS. ONLY POSSIBLE
04600 ; SIDE EFFECT IS STRING GARBAGE COLLECTION MORE OFTEN, BUT WATCHING
04700 ; CONSOLE LIGHTS INDICATED THAT THIS DID NOT HAPPEN.
04800 MOVEI TEMP,5
04900 ADDM TEMP,REMCHR(USER) ;KEEP COUNT MORE HONEST
05000 ;;#WN# ^
05100 EXCH SP,STPSAV ;save string constant state in preparation for
05200 MOVSS POVTAB+6 ; identifier rescan (as identifier)
05300 PUSH SP,PNEXTC-1 ;Save Scanner input state, and PNAME
05400 PUSH SP,PNEXTC ; (string constant) state.
05500 PUSH SP,PNAME
05600 PUSH SP,PNAME+1
05700 PUSH SP,PNAME ;Now retrieve (possibly moved) bp to beginning
05800 PUSH SP,PNAME+1 ; of potential formal name in constant
05900 PUSH P,[1] ;PNAME[<before id length> for 1]
06000 PUSH P,-5(P)
06100 JSP B,SBSTR
06200 POP SP,TEMP ;resultant bp
06300 SUB SP,X11
06400 MOVSS POVTAB+6
06500 EXCH SP,STPSAV
06600 ILDB B,TEMP ;SET UP FOR SCANNER
06700 MOVEM TEMP,PNEXTC ;SCAN FROM HERE FOR A WHILE
06800 MOVE A,SCNTBL(B) ;GET THE BITS BACK
06900 TLO TBITS2,LOKPRM
07000 TRON TBITS2,NOLIST ;TURN OFF LISTING FOR RESCAN
07100 TLO TBITS2,BACKON ;SAY YOU'VE DONE IT IF STATE CHANGED
07200 MOVEM TBITS2,SCNWRD ;UPDATE
07300 SCNPRM: PUSHJ P,DSCAN ;ID SCANNER -- SCAN AND LOOK IT UP
07400 POP P,TEMP ;fix up REMCHR using saved ident length
07500 MOVNS TEMP
07600 ADDM TEMP,REMCHR(USER)
07700 EXCH SP,STPSAV ;PUT THE SCANNER LOCATION BACK
07800 POP SP,PNAME+1 ;Restore string constant descriptor
07900 POP SP,PNAME
08000 ADD SP,X22 ;Then use to get one or other pointer back (below)
08100 PUSH P,[1] ;Whichever SUBSR is called, it will be [x for 1]
08200 TSTPRM: SKIPG LPSA,NEWSYM ;THESE TESTS DETERMINE IF
08300 JRST NOPAR ; (1) THERE IS A SYMBOL OF THIS NAME
08400 SKIPGE TBITS,$TBITS(LPSA)
08500 JRST NOPAR ; (2) IT IS NOT A RESERVED WORD
08600 TLNE TBITS,FORMAL
08700 TLNN TBITS,DEFINE
08800 JRST NOPAR ; (3) IT IS A MACRO PARAMETER NAME
08900
09000 PUSH P,-4(P) ;We found a param -- retrieve bp to beginning of
09100 JSP B,SBSTR ; original param name, clear string space to end
09200 MOVE TEMP,(SP) ; of space which DSCAN used
09300 PUSHJ P,CLREST
09400 POP SP,C ;Now replace param name with 177, param #
09500 MOVEI TEMP,177 ;(other word of SUBSR result removed at DN below)
09600 IDPB TEMP,C
09700 HRRZ TEMP,$VAL(LPSA) ;PARAM NUMBER
09800 IDPB TEMP,C
09900 MOVEM C,TOPBYTE(USER) ;update end of space
10000 AOS C,-3(P) ;length before id scan, +2 for param spec,
10100 AOJA C,DN ; yields proper current string const. length
10200
10300 NOPAR:
10400 PUSH P,-1(P) ;Was not param, retain (apparent) ident in string,
10500 JSP B,SBSTR ; by retrieving bp to end of original scan,
10600 MOVE TEMP,(SP) ; clearing space to end of DSCAN scan,
10700 PUSHJ P,CLREST ; then restoring TOPBYTE to continue macro body
10800 POP SP,TOPBYTE(USER) ; scan
10900 HRRZ C,(P) ;Restore length after ident scan
11000 DN:
11100 TLZE TBITS2,BACKON ;TURN LISTING BACK ON
11200 TRZ TBITS2,NOLIST ;YES
11300 SUB P,X11 ;Toss end of ident length
11400 POP P,B ;ident terminator
11500 POP P,A ;bits for that terminator
11600 SUB P,X11 ;Beginning of ident length
11700 SUB SP,X11 ;count word from whichever subsr was done
11800 POP SP,PNEXTC ;Finally, restore Scanner input
11900 POP SP,PNEXTC-1
12000 EXCH SP,STPSAV ;ONE MORE TIME
12100 HRRM C,PNAME ;MAKE SURE COUNT IS REALLY HONEST
12200 ;A AND B ARE THE APPROPRIATE VALUES FOR THE ORIGINAL BREAK CHAR
12300 TLZ TBITS2,LOKPRM ;LOOK NO MORE
12400 JRST MORSTR ;CONTINUE THE SCAN
12500
12600 CLREST:
12700 ;;#WM# JFR 3-22-76 440700 BYTE POINTERS (STRNGC) CAUSE PROBLEMS
12800 SKIPLE C,TOPBYTE(USER) ;BAD GUY?
12900 JRST CLRES1 ;NO
13000 MOVEI C,-1(C) ;MAKE HIM A GOOD GUY
13100 HRLI C,010700
13200 MOVEM C,TOPBYTE(USER)
13300 CLRES1:
13400 ;;#WM# ^
13500 MOVEI C,0 ; BP OF START OF ID IN TEMP
13600 LINLUP: CAMN TEMP,TOPBYTE(USER) ;clear space from temp's bp to
13700 POPJ P, ;current top
13800 IDPB C,TEMP
13900 JRST LINLUP
14000
14100
14200 SBSTR: AOS (P) ;ADAPT TO SAIL CONVENTIONS
14300 MOVE C,LPSA ;SAVE
14400 EXTERN SUBSR
14500 PUSHJ P,SUBSR
14600 MOVE LPSA,C ;RESTORE
14700 MOVE USER,GOGTAB
14800 JRST (B)
14900
15000 Comment
15100 End of string constant -- set up results for stacking,
15200 go do it
15300
15400 ENDSTR:
15500 MOVEM TBITS2,SCNWRD ;PUT ALL THE BITS AWAY
15600 LSTDPB ;PUT "," OR ")" AWAY
15700 TLZ FF,PRMXXX
15800 CAIE B,12 ;LF IS SPECIAL PROBLEM!
15900 MOVEM B,SAVCHR ;SAVE BITS FOR NEXT TIME
16000 MOVEM B,LSTCHR ;ALSO HERE ANY TIME
16100 SKIPN SWCPRS ; SWITCHING PARSERS OK?
16200 JRST NOSWCH ; NO,
16300 ;; #QV (1 OF 2) WILL NOW USE ENDMAC TO ADD 177-0 TO ASSIGNC BODIES
16400 TLNE FF,PRMSCN ; SCANNING ACTUALS?
16500 JRST ENDACT ; YES, APPEND 1770 TO MACRO ACTUALS
16600 JRST NOMACW ; NO,
16700 ;; #QV#
16800 NOSWCH: SKIPN IFCREC ; EXPAND MACROS IN FALSE PART OF COND COMP?
16900 TLNN FF,PRMSCN ; YES, SCANNING MACRO ACTUALS?
17000 JRST [PUSHJ P,UPDCNT ; KEEP REMCHR HONEST
17100 JRST STCTYP] ; DON'T ENTER STRING
17200 ENDACT: ADDI C,2 ; FOR ACTUAL PARAMETERS APPEND 177-0 TO END OF
17300 MOVEI TEMP,177 ; STRING, GET A SEMBLK AND PLACE IT ONLY ON
17400 IDPB TEMP,TOPBYTE(USER) ; THE STRING RING. ALL ACTUAL PARAMETERS TO
17500 MOVEI TEMP,0 ; A MACRO ARE LINKED ON THE VARB RING. THUS WHEN
17600 IDPB TEMP,TOPBYTE(USER) ; A MACRO CALL IS FINISHED ALL THAT REMAINS TO
17700 PUSHJ P,UPDCNT ; DO IS TO KILLST ALONG THE VARB RING WHOSE HEAD
17800 GETBLK NEWSYM ; IS POINTED TO BY DEFRNG.
17900 HRROI TEMP,PNAME+1 ;
18000 POP TEMP,$PNAME+1(LPSA) ;
18100 POP TEMP,$PNAME(LPSA) ;
18200 MOVE TEMP,[XWD CNST,STRING] ; MAKE SEMBLK OF ACTUAL PARAMETER LOOK LIKE
18300 MOVEM TEMP,$TBITS(LPSA) ; A STRING CONSTANT SEMBLK EXCEPT FOR THE FACT
18400 PUSHJ P,RNGSTR ; THAT IT IS NOT LINKED ON THE STRING CONSTANT RING
18500 ;; #QV (2 OF 2) ! REMOVED TEST ON ASGFLG HERE
18600 PUSHJ P,RNGVRB ;
18700 MOVE LPSA,NEWSYM ;
18800 MOVE A,%STCON ;
18900 JRST STACK ;
19000 NOMACW: PUSHJ P,UPDCNT ; UPDATE PNAME CNT, REMCHR, COLLECT IF NECESSARY
19100 PUSH P,BITS ;
19200 PUSHJ P,STRINS ; CHECK IF STRING HAS ALREADY BEEN ENTERED IN THE
19300 POP P,BITS ; SYMBOL TABLE AND IF NOT THEN ENTER IT
19400 MOVE LPSA,PNT ;
19500 MOVEM LPSA,NEWSYM ;
19600 STCTYP: MOVE A,%STCON ;
19700 JRST STACK ;
19800
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 ;;#YA# ! (1/2) JFR 1-3-77 CLEAR FLAGS FOR SAFETY
02100 JRST 2,@[SCNM1] ; NO, GET REST OF NUMBER
02200 SKIPN SWCPRS ; YES, IN FALSE PART OF CONDITIONAL COMPILATION?
02300 JRST ATOUT ; YES, TREAT AT SIGN AS A PARSE TOKEN
02400 TLNN TBITS2,INLIN ; NO, IN-LINE CODE?
02500 ;;#YA# ! (2/2)
02600 JRST 2,@[SCNM1] ; NO, GET REST OF NUMBER
02700
02800 ATOUT: MOVE A,%ATS ;GET BITS FOR AT SIGN DELIMITER
02900 JRST CHAROUT ;HANDLE AS DELIMITER
03000
03100 SCNM1:
03200 SETZB C,SCNVAL ;DIGITS CTR, VALUE
03300 SETZB SBITS2,DBLVAL ;FLAGS, LOW HALF OF LONG VALUE
03400 TLNN A,QUOCTE ;OCTAL QUOTE MARK (') ?
03500 JRST DECIM ;NO, DECIMAL NUMBER
03600
03700 SETZB LPSA,LPSA+1 ;ACCUMULATE HERE
03800 OCTL: ILDB B,PNEXTC ;GET BACK IN SYNCH
03900 SKIPGE A,SCNTBL(B)
04000 PUSHJ P,(A) ;USUAL SPECIAL TREATMENT
04100 LSTDPB
04200 MOVE LPSA,SCNVAL
04300 MOVE LPSA+1,DBLVAL
04400 TLNE A,DIG
04500 JRST OCTL1
04600 JUMPE LPSA,ENDNUM ;SINGLE PRECISION INTEGER
04700 IORI SBITS2,DBLPRC ;LONG INTEGER
04800 JRST ENDNUM
04900 OCTL1: LSHC LPSA,3
05000 ADDI LPSA+1,-"0"(A)
05100 JOV [ADDI LPSA,1 ;IN CASE SOME JOKER SAYS '777777777778
05200 JOV .+1 ;TOP PART COULD OVERFLOW, TOO
05300 JRST .+1]
05400 MOVEM LPSA,SCNVAL
05500 MOVEM LPSA+1,DBLVAL
05600 AOJA C,OCTL ;COUNT DIGITS TO DETECT LONE '
05700
05800 DECIM:
05900 PUSHJ P,GETINT ;CLEAR COUNT, GET INTEGER
06000 TLNN A,LETDG ;PART OF NUMBER?
06100 JRST ENDNMZ ;NO
06200 ;;#XZ# JFR 1-3-77 GET EXPONENT/TERMINATION CONDITIONS STRAIGHT
06300 IORI SBITS2,FLOTNG ;MUST BE REAL
06400 ;;#ZD# MWK 4-13-77 FIX TO PREVENT C CLOBBERAGE
06500 ; TLNN A,DOT ;DECIMAL POINT?
06600 ; SETZ C, ;NO. NO DIGITS AFTER DECIMAL PT.
06700 ;;#ZD#
06800 PUSH P,C ;SAVE DIGIT COUNTS
06900 TLNE A,DOT
07000 PUSHJ P,TZ ;TRY FOR MORE INTEGER
07100 HLRZ D,C ;# TRAILING ZEROES
07200 SUBI D,(C) ;-(# DIGITS WHICH ARE NOT TRAILING ZEROES)
07300 ADDM D,(P) ;RH (P) = AMOUNT TO ADD TO EXPONENT
07400 PUSH P,SCNVAL ;SAVE FRACTION VALUE
07500 PUSH P,DBLVAL
07600 SETZM SCNVAL ;INITIAL EXPONENT VALUE
07700 SETZB C,DBLVAL
07800 TLNN A,LETDG
07900 JRST FIXAT1 ;END OF REAL NUMBER
08000 TLNN A,DOT ;MUST BE "." OR "@"
08100 TLNE A,ATSIGN
08200 JRST .+2
08300 ERR <ILLEGAL REAL CONSTANT>,1
08400 ;;#XZ# ^
08500 NODOT1: ILDB B,PNEXTC
08600 SKIPGE A,SCNTBL(B)
08700 PUSHJ P,(A)
08800 LSTDPB
08900 TLNN A,ATSIGN ;SECOND "@"
09000 JRST NODOT2 ;NO
09100 IORI SBITS2,DBLPRC ;YES, LONG PRECISION
09200 JRST NODOT1
09300 NODOT2: PUSH P,[FIXAT]
09400 CAIN B,"-" ;MINUS?
09500 TLOA SBITS2,EXPNEG ; YES, EXPONENT NEGATIVE
09600 CAIN B,"+" ;NO, PLUS?
09700 JRST LGETINT ; PLUS OR MINUS, GET DIGIT
09800 JRST GETINT ; HAVE DIGIT, GO GET NUMBER
09900 FIXAT: PUSHJ P,TZMUL
10000 FIXAT1: SKIPN (P) ;IS RESULT ZERO?
10100 SKIPE -1(P)
10200 JRST .+3 ;NO
10300 SUB P,X33 ;YES, REMOVE 2 VALUE WORDS AND DIGIT CTR WORD
10400 JRST RETZER ;AND MAKE LIFE SIMPLE
10500 SKIPE SCNVAL ;IF THIS IS NOT ZERO
10600 JRST EXPER3 ;THEN WE HAVE A WHOPPING BIG EXPONENT
10700 TLZN SBITS2,EXPNEG ;NEGATIVE EXPONENT?
10800 SKIPA D,DBLVAL ;NO
10900 MOVN D,DBLVAL ;YES
11000 POP P,DBLVAL ;RETRIEVE MANTISSA
11100 POP P,SCNVAL
11200 ADD D,(P)
11300 HRREI D,(D) ;EXPONENT OF 10
11400 SUB P,X11 ;DONE WITH FORMER DIGIT CTR WORD
11500 MOVE LPSA,SCNVAL ;BEGIN CONVERTING MANTISSA TO PURE FRACTION
11600 JFFO LPSA,DFSC
11700 MOVE LPSA,DBLVAL ;HIGH ORDER WORD WAS ALL ZERO
11800 JFFO LPSA,.+1
11900 ADDI LPSA+1,=35 ;HIGH WORD WAS ALL ZERO
12000 DFSC: MOVEI C,-1(LPSA+1) ;# OF PLACES TO SHIFT (REMEMBER SIGN BIT)
12100 MOVE LPSA,SCNVAL ;GET MANTISSA
12200 MOVE LPSA+1,DBLVAL
12300 ASHC LPSA,(C) ;MAKE MANTISSA INTO PURE FRACTION
12400 SUBI C,=70
12500 MOVN C,C ;C=EXPONENT OF 2 OF MANTISSA
12600 JUMPE D,DFSC2 ;EXPONENT OF 10 WAS ZERO
12700 PUSH P,A ;SAVE BITS
12800 MOVE A,[EXP.P1,,FR.P1] ;ASSUME EXPONENT OF 10 IS POSITIVE
12900 JUMPG D,DFSCA
13000 TLO SBITS2,EXPNEG ;EXPONENT WAS NEG
13100 MOVN D,D
13200 MOVE A,[EXP.M1,,FR.M1] ;MULT BY NEG PWRS OF 10
13300 DFSCA: MOVEM LPSA,SCNVAL
13400 MOVEM LPSA+1,DBLVAL
13500 TRNE D,777700 ;CHECK MAGNITUDE OF EXP OF 10
13600 JRST EXPERR ;EXPONENT IS TOO BIG
13700 TRNE D,40 ;E+-32 INVOLVED?
13800 TLNE SBITS2,EXPNEG ;EXPONENT NEGATIVE?
13900 JRST MULOOP ;NO
14000 TRNE D,20 ;OUT OF RANGE IF E-48
14100 JRST EXPERR ;BAD
14200 MULOOP: TRZE D,1 ;SHOULD WE MULTIPLY?
14300 PUSHJ P,DMUL.. ;YES
14400 JUMPE D,DFSC1 ;QUIT IF EXPONENT NOW ZERO
14500 ASH D,-1 ;NEXT BIT INTO POSITION
14600 AOBJN A,.+1 ;ADD 1 TO LH
14700 AOJA A,MULOOP ;AND 2 TO RH
14800
14900 ;MULTIPLY TWO DOUBLE-LENGTH PURE FRACTIONS. ONE IS (A), OTHER IS SCNVAL, DBLVAL PAIR
15000 ;RETURN DOUBLE-LENGTH RESULT IN SCNVAL, DBLVAL
15100 ;SCALE FACTOR KEPT IN C
15200 DMUL..:
15300 NOKL10< PUSH P,SCNVAL ;SAVE HIGH
15400 SETZM SCNVAL ;1ST WORD, FINAL PRODUCT
15500 MOVE LPSA,(A) ;HIGH
15600 MULM LPSA,DBLVAL ;* LOW
15700 ;IGNORING 3RD WORDS: 8 EXPONENT BITS TO BURN
15800 MOVE LPSA,1(A) ;LOW
15900 MUL LPSA,(P) ;* HIGH
16000 TLO LPSA,400000 ;PREVENT OVERFLOWS
16100 ADD LPSA,DBLVAL ;ADD 2ND WORDS
16200 TLZN LPSA,400000 ;WOULD THERE HAVE BEEN AN OVERFLOW?
16300 AOS SCNVAL ;YES, DO CARRY (SETS SCNVAL TO 1)
16400 MOVEM LPSA,DBLVAL ;STORE LOW RESULT
16500 POP P,LPSA ;HIGH
16600 MUL LPSA,(A) ;* HIGH
16700 TLO LPSA+1,400000 ;PREVENT OVERFLOW
16800 ADD LPSA+1,DBLVAL ;COLLECT 2ND WORD
16900 TLZN LPSA+1,400000 ;WOULD THERE HAVE BEEN AN OVERFLOW?
17000 ADDI LPSA,1 ;YES
17100 ADD LPSA,SCNVAL ;COLLECT 1ST WORD (THIS CAN'T OVERFLOW)
17200 >;NOKL10
17300 KL10<
17400 DMOVE LPSA,SCNVAL
17500 DMOVEM LPSA+2,SCNVAL
17600 DMUL LPSA,(A)
17700 JOV [TLO SBITS2,INTOV
17800 JRST .+1]
17900 DMOVE LPSA+2,SCNVAL
18000 >;KL10
18100 TLNE LPSA,(1B1) ;NORMALIZED FRACTION?
18200 JRST .+3 ;YES
18300 ASHC LPSA,1 ;NO, SHIFT OVER
18400 SUBI C,1 ;AND ADJUST EXPONENT
18500 MOVS A,A ;COLLECT EXPONENT CHANGES
18600 ADD C,(A)
18700 MOVS A,A
18800 MOVEM LPSA,SCNVAL ;STORE RESULT SO FAR
18900 MOVEM LPSA+1,DBLVAL
19000 POPJ P,
19100
19200 DFSC1: POP P,A ;GET BITS BACK
19300 MOVE LPSA,SCNVAL ;GET VALUE
19400 MOVE LPSA+1,DBLVAL
19500 TRNN LPSA+1,400 ;ROUND?
19600 JRST DFSC2 ;NO
19700 TLO LPSA,400000 ;PREVENT
19800 TLO LPSA+1,400000 ; OVERFLOWS
19900 ADDI LPSA+1,400 ;YES
20000 TLZN LPSA+1,400000 ;WOULD THERE HAVE BEEN AN OVERFLOW?
20100 ADDI LPSA,1 ;YES
20200 TLZE LPSA,400000
20300 JRST DFSC2 ;NO OVERFLOW
20400 MOVSI LPSA,200000 ;HIGH WD EXACTLY .1 (BASE 2)
20500 ADDI C,1 ;EXPONENT HAS INCREASED
20600 LSH LPSA+1,-1 ;KEEP LOW WD ALIGNED PROPERLY
20700 DFSC2: ASHC LPSA,-8 ;MAKE ROOM FOR EXPONENT
20800 FSC LPSA,200(C) ;AND INSERT IT
20900 JFOV EXPERR
21000 JRST ENDNUM ;FINALLY DONE (EXCEPT TEST OVERFLOW FLAGS)
21100
21200 EXPER3: SUB P,X33
21300 EXPERR: ERR <EXPONENT RANGE EXCEEDED>,1
21400 HRLOI LPSA,377777 ;SET UP AN INFINITY
21500 MOVE LPSA+1,LPSA
21600 TLNE SBITS2,EXPNEG
21700 RETZER: SETZB LPSA,LPSA+1 ;BUT USE ZERO IF EXPONENT WAS NEG
21800 JRST ENDNUM
21900
22000 ENDNMZ: PUSHJ P,TZMUL ;TRAILING ZEROES NOW SIGNIF.
22100 MOVE LPSA,SCNVAL
22200 MOVE LPSA+1,DBLVAL
22300 ENDNUM: CAIE B,12 ;EXCEPT FOR LINE FEED,
22400 MOVEM B,SAVCHR ;SAVE FOR NEXT SCAN
22500 MOVEM B,LSTCHR ;ALSO HERE ANY TIME
22600 TLNE A,LETDG ;MUST NOT BE LEETTER OR DIG OR
22700 ERR <ILLEGAL CONSTANT>,1
22800 TRNN SBITS2,FLOTNG ;REAL OR INTEGER?
22900 JRST INTEG
23000 TRNN SBITS2,DBLPRC
23100 SNGL LPSA,LPSA ;ONLY SINGLE ASKED FOR
23200 JRST NUMRET
23300
23400 INTEG: SKIPN C ;MAKE SURE THERE WAS SOMETHING
23500 ERR <ILLEGAL INTEGER CONSTANT>,1
23600 TLNE SBITS2,INTOV ;INTEGER OVERFLOW?
23700 ERR <INTEGER CONSTANT TOO LARGE>,1
23800 TRO SBITS2,INTEGR ;MARK TYPE
23900 NUMRET: SKIPN SWCPRS ; INSIDE FALSE PART OF CONDITIONAL COMPILATION?
24000 JRST NUMTYP ; YES, DON'T ENTER THE NUMBER
24100 HRLI SBITS2,CNST ; MAKE INTO TBITS WORD
24200 PUSH P,BITS ;DON'T EFFECT OUTSIDE WORLD
24300 MOVEM SBITS2,BITS ;SET UP FOR ENTER
24400 JUMPN LPSA,.+2
24500 EXCH LPSA,LPSA+1 ;SINGLE PRECISION INTEGER ONLY
24600 MOVEM LPSA,SCNVAL
24700 MOVEM LPSA+1,DBLVAL
24800 PUSHJ P,NHASH ;LOOK UP THE NUMBER
24900 SKIPG NEWSYM ;WAS IT THERE ALREADY?
25000 PUSHJ P,ENTERS ; NO, BUT IT IS NOW
25100 POP P,BITS ;GET OLD BITS BACK
25200 MOVE LPSA,NEWSYM ;SET UP FOR STACKING
25300 NUMTYP: MOVE A,%NUMCON
25400 JRST STACK ;GO DO IT
25500
00100 Comment
00200 Get an integer (base 10 only for the present).
00300 C has # trailing zeroes ,, # digits
00400
00500 LGETINT: ;GET A CHARACTER FIRST
00600 ILDB B,PNEXTC
00700 MGETINT: ;GET BITS FIRST
00800 SKIPGE A,SCNTBL(B)
00900 PUSHJ P,(A) ;SIGH!
01000 LSTDPB
01100
01200 GETINT: JOV .+1 ;GET AN INTEGER
01300 TDZA C,C ;SET # DECIMAL PLACES TO 0
01400
01500 ML$CHR ;PUT AWAY
01600 GETLUP: TLNN A,DIG ;IS IT A DIG?
01700 POPJ P, ; NO, RETURN
01800 CAIN B,"0"
01900 AOBJP C,TZ ;A TRAILING ZERO
02000 TLNN C,-1 ;HAVE DIGIT. WERE THERE TRAILING ZEROES BEFORE IT?
02100 AOJA C,NOTZ ;NO. COUNT DIGIT AND LEAVE
02200 ADDI C,1 ;YES. COUNT DIGIT ANYWAY
02300 PUSHJ P,TZMUL ;TRAILING ZEROES NOW SIGNIF.
02400 NOTZ: PUSHJ P,M10ADA ;MULTIPLY BY 10 AND ADD A
02500 TZ: ILDB B,PNEXTC ; GET ANOTHER
02600 SKIPGE A,SCNTBL(B) ;COULD IT STILL BE A DIGIT?
02700 PUSHJ P,(A)
02800 JRST GETLUP-1(TBITS2);LOOP
02900
03000 TZMUL: HLRZ D,C ;# TRAILING ZEROES
03100 JUMPE D,TZMUL1 ;QUIT IF NONE
03200 CAIN D,(C)
03300 JRST TZMUL1 ;TRAILERS WERE ALSO LEADERS!
03400 PUSH P,A
03500 MOVEI A,"0"
03600 PUSHJ P,M10ADA ;ADJUST VALUE TO ACCOUNT FOR TRAILING ZEROES
03700 SOJG D,.-1
03800 POP P,A
03900 TZMUL1: TLZ C,-1 ;NO TRAILING ZEROES NOW
04000 POPJ P,
04100
04200 M10ADA:
04300 NOKL10< SKIPN LPSA,SCNVAL ;ANY HIGH ORDER PART?
04400 JRST M10A.1 ;NO
04500 IMULI LPSA,=10 ;YES
04600 JOV [TLO SBITS2,INTOV
04700 JRST .+1]
04800 MOVEM LPSA,SCNVAL
04900 M10A.1: MOVE LPSA,DBLVAL ;LOW HALF
05000 MULI LPSA,=10
05100 TLO LPSA+1,400000 ;PREVENT OVERFLOW
05200 ADDI LPSA+1,-"0"(A) ;ADD THE NEW DIGIT
05300 TLZN LPSA+1,400000 ;WOULD THERE HAVE BEEN AN OVERFLOW?
05400 ADDI LPSA,1 ;YES. (THIS CAN'T OVERFLOW; LPSA WAS AT MOST =9)
05500 MOVEM LPSA+1,DBLVAL ;SAVE LOW HALF
05600 TLO LPSA,400000
05700 ADD LPSA,SCNVAL ;TAKE CARE OF HIGH HALF
05800 TLZN LPSA,400000
05900 TLO SBITS2,INTOV
06000 MOVEM LPSA,SCNVAL ;SAVE HIGH HALF
06100 >;NOKL10
06200 KL10<
06300 DMOVE LPSA,SCNVAL ;FETCH ONE VALUE
06400 DMOVEM LPSA+2,SCNVAL ;SAVE 2 REGS CLOBBERED BY DMUL
06500 DMUL LPSA,[0 =10] ;RESULT SHOULD BE IN LPSA+3,+4
06600 JOV [TLO SBITS2,INTOV
06700 JRST .+1]
06800 JUMPN LPSA,.+2
06900 JUMPE LPSA+1,.+2
07000 TLO SBITS2,INTOV ;BUT IT MIGHT HAVE OVERFLOWED
07100 MOVEI LPSA+1,-"0"(A) ;CONSTRUCT VALUE TO ADD. LPSA HAS 0 ALREADY
07200 DADD LPSA,LPSA+2 ;ADD
07300 JOV [TLO SBITS2,INTOV
07400 JRST .+1]
07500 DMOVE LPSA+2,SCNVAL ;RESTORE 2 REGS
07600 DMOVEM LPSA,SCNVAL
07700 >;KL10
07800 POPJ P,
07900
08000 FR.P1: 240000,,0 ;10^1 PURE FRACTION PART
08100 0
08200 310000,,0 ;10^2
08300 0
08400 234200,,0 ;10^4
08500 0
08600 276570,,200000 ;10^8
08700 0
08800 216067,,446770 ;10^16
08900 040000,,0
09000 235613,,266501 ;10^32
09100 133413,,263574
09200 EXP.P1: 4 ;POWER OF 2 EXPONENT PART
09300 7
09400 16
09500 33
09600 66
09700 153
09800
09900 FR.M1: 314631,,463146 ;10^-1
10000 146314,,631463
10100 243656,,050753 ;10^-2
10200 205075,,314217
10300 321556,,135307 ;10^-4
10400 020626,,245364
10500 253630,,734214 ;10^-8
10600 043034,,737425
10700 346453,,122766 ;10^-16
10800 042336,,053314
10900 317542,,172552 ;10^-32
11000 051631,,227215
11100 EXP.M1: -3
11200 -6
11300 -15
11400 -32
11500 -65
11600 -152
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 ML$BAK
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
06600
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
04900
00100 SUBTTL Cspec, Seol
00200
00300
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 ifn 0,<;;JFR 12-11-76 causes Address check for device DSK on PASS1.SAI[PUB,SYS]
01400 ;; \UR#5\ BETTER LISTING FOR CONDITIONAL COMPILATION
01500 SKIPE CNDLST ;SUPPRESSING LISTING?
01600 JRST [ MOVE SBITS2,LPTRSV
01700 ML$BAK
01800 JRST NOLST ]
01900 ;; \UR#5\
02000 >;ifn 0,
02100
02200 ; TIME TO DO A LISTING
02300
02400 MOVE TBITS,LPNT ;PUT THE LINE FEED IN LIST BUFFER
02500 LLL2: IDPB B,TBITS
02600 MOVEI B,0 ;ZERO REMAINING CHARS OF CURRENT WORD
02700 TLNE TBITS,760000 ;ALL DONE?
02800 JRST LLL2 ;NO, PUT OUT ZERO
02900 MOVEM TBITS,LPNT ;SAVE AGAIN FOR A WHILE
03000
03100 ;IF CREFING WAS DONE ON THIS LINE, TERMINATE THE CREF STUFF
03200 SKIPN LNCREF ;CREF GONE OUT?
03300 JRST NOLNX ;NOPE
03400 SETZM LNCREF ;RESET.
03500 MOVEI TBITS,177 ;DELETE
03600 PUSHJ P,CHROUT
03700 MOVEI TBITS,"A" ;AND AN A
03800 PUSHJ P,CHROUT
03900 NOLNX:
04000
04100 ; IF PCNT OUTPUT DESIRED, DO THAT FIRST
04200
04300 TLNN TBITS2,PCOUT ;WANT TO PRINT PC?
04400 JRST NOPC ; NO
04500
04600 MOVE TBITS,PCNT ;YET ANOTHER FRNP
04700 ADD TBITS,LSTSTRT ;OFFSET BY USER-PROVIDED LOC
04800 MOVEI B,CHROUT ;ROUTINE TO USE
04900 MOVEI PNT2,6 ;ALWAYS DO 6 CHARS
05000 BAIL<
05100 SKIPN BAILON
05200 JRST .+4 ;NO BAIL
05300 HRRZ TBITS,BCORDN ;IF DEBUGGER IN USE, PRINT COORDINATE INSTEAD
05400 PUSHJ P,FRNPD ;IN DECIMAL
05500 JRST .+2 ;AND SKIP OVER PC PRINTER
05600 >;BAIL
05700 PUSHJ P,[
05800 ^FRNP1: SKIPA TEMP,[10]
05900 ^FRNPD: MOVEI TEMP,=10
06000 FRNP3: IDIV TBITS,TEMP
06100 IORI SBITS,"0"
06200 HRLM SBITS,(P)
06300 SOJE PNT2,FRNP2
06400 PUSHJ P,FRNP3
06500 FRNP2: HLRZ TBITS,(P)
06600 JRST (B) ;CHARACTER TO OUTPUT
06700 ]
06800 MOVE SBITS,[POINT 7,[ASCII / /]]
06900 PUSHJ P,LL1+1 ;SEE BELOW
07000
07100 ; IF LINE NUMBER OUTPUT DESIRED, DO IT NEXT.
07200
07300 NOPC: MOVE SBITS,[POINT 7,ASCLIN] ;ASSUME WANT LINE NUMBER
07400 TLNE TBITS2,LINESO ;IS IT THE CASE
07500 PUSHJ P,[LL1: PUSHJ P,CHROUT ;CHARACTER TO OUTPUT
07600 ILDB TBITS,SBITS ;NEXT CHAR
07700 JUMPN TBITS,LL1
07800 POPJ P,]+1 ;KLUDGE........
07900
08000 ; NEXT LINE UP THE BP FOR SOME RAPID-FIRE STUFF
08100
08200 NOTENX <
08300 NLNO: MOVE TBITS,LSTPNT ;LST OUTPUT BYTE POINTER
08400 MOVE SBITS,LSTCNT ;IF ALREADY LINED UP....
08500 HARRY: TLNN TBITS,760000 ;LINED UP WHEN PTR PART IS 01
08600 JRST LNDUP
08700 SOS SBITS,LSTCNT ;DENOTE CHANGE
08800 IBP TBITS ;MAINLY WANT TO ADJUST COUNT
08900 JRST HARRY ;COULD PROBABLY DO CALCULATION
09000
09100 LNDUP: MOVEM TBITS,LSTPNT ;UPDATE
09200 IDIVI SBITS,5 ;#WORDS LEFT, NO REMAINDER GUARANTEED
09300 AOS PNT2,LPNT ;WE GOT THIS FAR
09400 HRRZS PNT2
09500 SUB PNT2,LSTBUF ;HOW MANY WORDS?
09600 CAMGE SBITS,PNT2 ;IS THERE ROOM?
09700 PUSHJ P,LSTDO ; NOW THERE IS
09800 BAIL<
09900 ADDM PNT2,BLSTFC ;WORD COUNT FOR LIST FILE
10000 >;BAIL
10100 MOVNI SBITS,5 ;UPDATE CHAR COUNT
10200 IMUL SBITS,PNT2
10300 ADDM SBITS,LSTCNT
10400 EXCH PNT2,LSTPNT ;AND LSTPNT
10500 ADDM PNT2,LSTPNT ;PREV VERSION IN PNT2
10600 ADDI PNT2,1
10700 HRL PNT2,LSTBUF ;BLT WORD (LSTBUF,,OUTBUF)
10800 BLT PNT2,@LSTPNT ;WRITE THE LINE!
10900 >;NOTENX
11000 TENX<
11100 PUSH P,C
11200 PUSH P,B
11300 HRRZ 2,LPNT
11400 HRRZ 3,LSTBUF
11500 SUBI 3,1(2) ;-#WRDS, INCLUDING CURRENT WORD
11600 IMULI 3,5 ;-#CHRS, INCL. EXTRAS IN CURRENT WRD
11700 SKIPA 2,LPNT
11800 IBP 2
11900 TLNE 2,760000 ;LAST CHAR IN WORD COUNTED?
12000 AOJA 3,.-2 ;UN-COUNT AN EXTRA CHAR
12100 BAIL<
12200 ADDM 3,BLSTFC ; UPDATE COUNT
12300 >;BAIL
12400 EXCH 1,LISJFN
12500 HRRO 2,LSTBUF
12600 JSYS SOUT
12700 EXCH 1,LISJFN
12800 HRRZ 3,LSTBUF ;NOW ZERO LSTBUF, JUST IN CASE.
12900 SETZM (3)
13000 HRLI 3,(3)
13100 ADDI 3,1
13200 BLT 3,(2)
13300 POP P,B
13400 POP P,C
13500 >;TENX
13600 HRRO TEMP,LSTBUF ;ADDR OF FIRST WORD OF BUFFER
13700 SUB TEMP,[XWD 677077,1] ;POINT 5,@LSTBUF,29
13800 MOVEM TEMP,LPNT ;NEW LIST POINTER
13900 IFN FTL$DBG,<
14000 MOVEI TEMP,5*=50
14100 MOVEM TEMP,L$CNT
14200 >;IFN FTL$DBG
14300 MOVE TEMP,[ASCID / /] ;BLANKS IN CASE
14400 MOVEM TEMP,ASCLIN ;IN MACRO AND MORE LINES TO COME
14500 AOS TBITS,LINNUM ;CHECK LINE OVERFLOW
14600 IDIVI TBITS,PGSIZ
14700 SKIPN SBITS
14800 PUSHJ P,HDROV ;PRINT FF
14900
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 ;;%DM% CMU =F4= LDE 14-JUN-76 GENERATE MORE LIKELY SOS LINE NUMBERS.
01700 EXPO <
01800 CAIG TBITS,=999 ;HIGHEST LEGAL LINE NUMBER
01900 IMULI TBITS,=100
02000 >;EXPO =F4=
02100 ;;%DM% ^
02200 MOVEI B,[IDPB TBITS,A ;ROUTINE TO DISPENSE CHARS
02300 POPJ P,]
02400 MOVEI PNT2,5 ;5 CHARS ALWAYS
02500 MOVE A,[POINT 7,ASCLIN] ;PUT IT HERE
02600 PUSHJ P,FRNPD ;GET ASCII VERSION
02700 MOVEI TEMP,1
02800 ORM TEMP,ASCLIN ;MAKE ASCID
02900 ; ACTUAL LINE NUMBER WILL OVERRIDE THIS IF THERE
03000
03100 LDB TEMP,PNT ;NEXT CHAR.
03200 JUMPE TEMP,NULCHR ;GO FIND NON-NULL
03300 LINCHA: MOVE TEMP,(PNT)
03400 LINCHK: TRNN TEMP,1 ;ARE WE IN LINE NUMBER?
03500 JRST LDUNA ;NO THIS IS THE NEXT CHAR.
03600 BAIL< ;JFR 4-18-76 AT COMPLAINT OF REM
03700 PUSH P,TEMP
03800 SKIPN BPNXTC ;IF SOURCE NOT MARKED
03900 PUSHJ P,BMKSRC ;THEN MARK IT BEGINNING AT LINE NUMBER
04000 POP P,TEMP
04100 >;BAIL
04200 CAME TEMP,[ASCID/ /];IS IT A PAGE MARK PERHAPS
04300 AOJA PNT,LDUN ;NO JUST SKIP LINE NUM AND TAB
04400 MOVEM PNT,PNEXTC ;HDR CLOBBERS THIS
04500 PUSHJ P,HDR ;WRITE PAGE MARK, NEW TITLE LINE
04600 MOVE PNT,PNEXTC ;GET HIM BACK
04700 SKIPN 1(PNT) ;END OF BUFFER?
04800 PUSHJ P,ADVBUF ;YES, GET NEXT.
04900 ADDI PNT,1 ;POINT BEHIND NEXT LINE NUMBER
05000 SKIPN TEMP,1(PNT) ;IS IT IN THIS BUFFER?
05100 PUSHJ P,LINADV ;[clh] NO.
05200 HRLI PNT,350700 ;POINT TO FIRST CHAR. OF LINE NUMBER
05300 AOJA PNT,LINCHA ;AND DO IT AGAIN (IN CASE 2 PAGE MARKS).
05400
05500 LINADV: MOVEM PNT,PNEXTC ;[clh] advbuf needs this
05600 JRST ADVBUF ;[clh] get to new buffer
05700
05800 NULCHR: ILDB B,PNT ;MOVE ON UP
05900 MOVE TEMP,(PNT) ;GET COMPLETE WORD
06000 JUMPN B,LINCHK ;FINALLY WE GOT SOMETHING
06100 IBP PNEXTC ;KEEP IN STEP
06200 JUMPN TEMP,NULCHR ;END OF BUFFER?
06300 PUSHJ P,ADVBUF ;YES.
06400 JRST NULCHR ;HERE WE GO LOOP-D-LOOP
06500
06600 LDUN: SKIPE (PNT) ;IS TAB IN THIS BUFFER
06700 JRST LDUN1 ;YES
06800 PUSHJ P,LINADV ;[CLH] NO
06900 IBP PNT ;MAKE IT CURRENT
07000 LDUN1: MOVEM TEMP,ASCLIN ;CURRENT LINE#
07100 MOVEM PNT,PNEXTC ;THIS GUY POINTS TO TAB
07200 LDUNA: MOVE TEMP,PNEXTC ;MAY NOT USE PNT
07300 MOVEM TEMP,PLINE ;BEGINNING OF LINE
07400 IFN FTDEBUG,<
07500 AOS LINCNT ;COUNT NUMBER OF LINES SEEN
07600 SKIPL STPAGE ;ARE WE LOOKING FOR A PAGE/LINE?
07700 PUSHJ P,STPLIN ;LINE BREAK IF NECESSARY.
07800 >
07900 LDO1: MOVEI B,12 ;GET LINE FEED BACK.
08000 MOVEI A,0 ;HARMLESS LF
08100 MOVE USER,GOGTAB
08200 POP P,C ;RESTORE CHARACTER COUNT.
08300 POPJ P, ;WASN'T THAT WONDERFUL
08400
08500
08600 ; HERE WE SAVE INFO ABOUT SOURCE FILE, AND PREPARE TO GET INFO
08700 ; ABOUT NEW ONE.
08800
08900 NXTSRC:
09000 NOTENX <
09100 MOVE A,AVLSRC ;BITS TELLING FREE CHANNELS
09200 JFFO A,GOTNEW ;FOUND A FREE ONE
09300 ERR <NO MORE AVAILABLE SOURCE CHANNELS>
09400 GOTNEW:
09500 PUSH P,B ;SAVE NEW CHANNEL #
09600 MOVEI C,ENDSRC-SRCCDB+1 ;SIZE OF SAVE AREA
09700 >;NOTENX
09800 TENX <
09900 MOVEI C,ENDSRC-BGNSWA+1 ;SIZE OF SAVE AREA
10000 >;TENX
10100 PUSHJ P,CORGET ;GET ONE
10200 ERR <NO CORE AVAILABLE FOR FILE SWITCH>
10300 HRR TEMP,B ;BLT WORD
10400 NOTENX <
10500 HRLI TEMP,SRCCDB
10600 BLT TEMP,ENDSRC-SRCCDB(B)
10700 >;NOTENX
10800 TENX <
10900 HRLI TEMP,BGNSWA
11000 BLT TEMP,ENDSRC-BGNSWA(B)
11100 >;TENX
11200 HRRZM B,SWTLNK ;SAVE PTR TO SAVE AREA
11300 TLO TBITS2,INSWT ;WE'RE SCANNING SWITCHED-TO FILE
11400 MOVEM TBITS2,SCNWRD
11500 SETZM LSTCHR ;ALWAYS DO IT
11600 SETZM SAVCHR
11700 NOTENX <
11800 SETZM SAVTYI
11900 SETZM EOF
12000 SETZM EOL
12100 POP P,A ;CHANNEL NUMBER
12200 FOR II_0,1 <
12300 DPB A,[POINT 4,SRCOP+II,12]
12400 >
12500 FOR II_0,3 <
12600 DPB A,[POINT 4,INSRC+II,12]
12700 >
12800 NOEXPO <
12900 DPB A,[POINT 4,SRCOP+2,12] ;PUSHJ IF EXPO
13000 >;NOEXPO
13100 MOVN TEMP,A ;-CHANNEL NUMBER
13200 MOVSI LPSA,400000 ;BIT
13300 LSH LPSA,(TEMP)
13400 ANDCAM LPSA,AVLSRC ;THIS CHANNEL UNAVAILABLE
13500 >;NOTENX
13600 ;;%CF% JFR 7-8-75
13700 IFN 0,<
13800 AOS TEMP,LININD ;HOW FAR IN TO SPACE ON TTY
13900 CAILE TEMP,MAXIND ;TOO FAR?
14000 SOS LININD ;NOT REALLY
14100 >;IFN 0
14200 MOVEI TEMP,2 ;INDENT ON TTY
14300 ADDM TEMP,LININD
14400 ;;%CF% ^
14500 NOTENX <
14600 SETOM TYICORE ;WILL SCAN FROM STRING
14700 >;NOTENX
14800 MOVE TEMP,GENLEF+2
14900 ;; %AN% CHECK TO BE SURE STRING CONSTANT, SINCE PRODUCTIONS NO LONGER CHECK
15000 MOVE TEMP,$TBITS(TEMP)
15100 TRNN TEMP,STRING
15200 ERR <SOURCE!FILE NAME MUST BE STRING>
15300 MOVE TEMP,GENLEF+2
15400 ;; %AN%
15500 HRROI TEMP,$PNAME+1(TEMP) ;GET STRING TO BE SCANNED
15600 POP TEMP,PNAME+1
15700 POP TEMP,PNAME ;PUT ER THERE
15800 BAIL<
15900 SKIPN SRCDLY ;SWITCHING SOURCE INPUT?
16000 JRST BNSRCD ;NO
16100 QPUSH BSRCFQ,BSRCFC ;YES. SAVE BUFF. ADDR,,BLOCK COUNT
16200 QPUSH BSRCFQ,BSRCFN ;SAVE FILE NUMBER
16300 ;;#%%# ! BY JFR 11-17-74 ZERO THE BLOCK COUNT FOR THE NEW FILE
16400 SETZM BSRCFC
16500 BNSRCD:
16600 >;BAIL
16700 PUSHJ P,ENDSWT ;USE EOF CODE TO GET NEW FILE
16800 ;SRCDLY WILL BE TURNED OFF HERE
16900 JRST NOLST ;AND GO BACK TO END OF LINE CODE
17000
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,
03400
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 ;;#YV# JFR 2-4-77
03900 TLNN TBITS2,LSTEXP ;WANT IT?
04000 JRST DFNE.1 ;SURELY NOT
04100 LSTDPB ;MAYBE
04200 DFNE.1: TLO TBITS2,MACIN ;MARK IN MACRO
04300 TLNN TBITS2,MACEXP ;EXPANDING?
04400 TRO TBITS2,NOLIST ;NO
04500 ;;#YV# ^
04600 MOVEM TBITS2,SCNWRD ;UPDATE
04700 TLNE FF,PRMSCN ; SCANNING PARAMETERS?
04800 SKIPN REQDLM ; YES, IN SPECAIL DELIMITER MODE?
04900 JRST NEWCHR ;GO GET FIRST NEW CHAR, RET
05000 CAIN P,DSPRMS+3 ; IS 177-# FIRST ITEM IN ACTUAL PARAMETER
05100 HRRI P,BALCHK ; YES, CHANGE RETURN ADDRESS TO REFLECT
05200 ; THAT UNTESTED COMMAS AND RIGHT PARS. WILL
05300 ; BREAK SCAN
05400 DLMPRM: ILDB B,PNEXTC ; SCAN REST OF CHARS. INTO STRING CONSTANT
05500 SKIPGE A,SCNTBL(B) ; SPECIAL?
05600 ;; #OG# ! MAKE SURE PNAME COUNT VALID IN CASE OF REAL GARBAGE COLLECT
05700 PUSHJ P,CSPEC ; DO IT
05800 LSTDPB ; PUT IT AWAY
05900 IDPB B,TOPBYTE(USER) ; DEPOSIT IT
06000 AOJA C,DLMPRM ; INCREMENT COUNT AND CONTINUE SCAN
06100
06200 RESTOR: MOVE PNT,DEFPDP
06300 POP PNT,SAVCHR ;CHAR SCANNED AHEAD
06400 POP PNT,PNEXTC ;OLD INPUT POINTER
06500 POP PNT,PNEXTC-1 ;STRING NUMBER
06600 ADD PNT,X22 ;START PLINE HERE
06700 POP PNT,PLINE
06800 POP PNT,PLINE-1
06900 POP PNT,LPSA ;PERHAPS OLD DEFRNG
07000 MOVEM PNT,DEFPDP
07100 HLRZ TBITS,LPSA ; GET LENGTH OF MACRO TO WHICH ONE IS RETURNING AND
07200 PUSHJ P,SGCOL2 ; INSURE ENOUGH ROOM IN STRING SPACE FOR IT
07300 EXCH LPSA,DEFRNG ; GET OLD DEFRNG VALUE AND IF DIFFERENT FROM CURRENT
07400 CAMN LPSA,DEFRNG ; VALUE THEN ONE IS DONE WITH THE MACRO AND THUS
07500 JRST DDUN ; RING OF ACTUAL PARAMETERS (POINTED TO BY DEFRNG)
07600 HRRZS LPSA ; IS REMOVED FROM THE STRING RING. NOTE THAT
07700 PUSHJ P,KILLST ; KILLST EXPECTS LPSA WITH ZERO IN THE LEFT HALF.
07800
07900 DDUN: MOVEI B,">" ;END OF EXPANSION MARKER
08000 ;;#YV# JFR 2-4-77
08100 TLNN TBITS2,LSTEXP
08200 JRST DDUN.1
08300 LSTDPB
08400 DDUN.1:
08500 SKIPN PNEXTC-1 ;OUT OF MACROS?
08600 TLZA TBITS2,MACIN ;YES
08700 JRST DUNRST ;NO
08800 PUSHJ P,L$SET ;GET 'NOLIST' FROM ABSOLUTE BEARINGS
08900 ;;#YV# ^
09000 MOVE TEMP,IPLINE ;PLINE TO OUTER LEVEL VALUE
09100 MOVEM TEMP,PLINE
09200 SETZM PLINE-1
09300
09400 DUNRST: MOVEM TBITS2,SCNWRD ;SAFETY FIRST
09500
09600 ; NOW GET A CHARACTER FOR THE SCANNER
09700
09800 TLNE FF,PRMSCN ; SCANNING PARAMETERS?
09900 SKIPN REQDLM ; YES, IN SPECIAL DELIMITER MODE?
10000 TRNA ; SKIP
10100 SUB P,X11 ; POP RETURN ADDRESS, AND NOW WILL RETURN
10200 ; TO CHECK NESTING INSTEAD OF CONTINUING
10300 ; FORMAL PARAMETER SCAN
10400 SKIPN B,SAVCHR ;HAVE IT ALREADY?
10500 JRST NEWCHR ;NO
10600 SETZM SAVCHR ;NO LONGER AHEAD (DCS 5-27-71)******
10700 MOVE A,SCNTBL(B) ;YES, DON'T DISPATCH AGAIN
10800 POPJ P,
10900
11000 NEWCHR: ILDB B,PNEXTC ;GET FROM INPUT
11100 SKIPGE A,SCNTBL(B) ;SPECIAL?
11200 JRST (A) ;YES, DISPATCH
11300 POPJ P, ;NO, DONE
11400
11500 DSCR KILLST
11600 CAL PUSHJ
11700 PAR LPSA ptr to first Semblk to be released
11800 RES Unlinks Semblk from %RSTR, releases it to free
11900 storage, then continues right down %RVARB until
12000 all Semblks on this VARB-Ring are released.
12100 DES THIS ROUTINE IS IN THE WRONG PLACE!
12200 SEE FREBLK, ULINK
12300
12400
12500 ^KILLST:
12600 PUSH P,LPSA
12700 JUMPE LPSA,KLPDUN
12800
12900 KLLUP:
13000
13100 PUSHJ P,URGSTR ;UNLINK FROM STRING RING
13200 FREBLK
13300 RIGHT ,%RVARB,<[KLPDUN: POP P,LPSA
13400 POPJ P,]>
13500 JRST KLLUP
13600 SUBTTL SCANNER INPUT AND LISTING ROUTINES
13700
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 NOTENX <
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 BAIL <
01900 AOS BSRCFC ; ADD ONE TO SOURCE FILE BLOCK COUNT
02000 >;BAIL
02100 PUSHJ P,SGCHK ;STRING GC, IF NECESSARY, TBITS_SRCCNT
02200 ADDI TBITS,4 ;(CHAR CT+4)/5 IS WORD COUNT
02300 IDIVI TBITS,5
02400 ADD TBITS,SRCPNT ;ADD BASE ADDRESS
02500 IBP TBITS ;PTR TO LAST WORD+1, MAKE 0 TO
02600 SETZM (TBITS) ; DENOTE EOB
02700 MOVE PNT,SRCPNT ;RESET PNT TO CURRENT BP,
02800 MOVEM PNT,PNEXTC ;FIX THIS GUY TOO.
02900 MOVE TEMP,1(PNT) ; TEMP TO WORD NEXT REFERENCED
03000 POPJ P,
03100
03200 ; CHECK FOR STRING SPACE FULL, GC IF SO
03300
03400 SGCHK:
03500 HRRZ TBITS,SRCCNT ;GET # OF CHARACTERS
03600 MOVE TEMP,REMCHR(USER) ;TEST ENOUGH ROOM
03700 ADD TEMP,TBITS
03800 SKIPL TEMP ;IS THERE ENOUGH?
03900 JRST SGCOL ;NO, COLLECT SPACE
04000 POPJ P, ;NOT NECESSARY
04100
04200 ENDFL: XCT RELSRC ;RELEASE OLD FILE,
04300 >;NOTENX
04400 TENX <
04500 ADVBUF: PUSH P,1
04600 PUSH P,2
04700 PUSH P,3
04800 SKIPE TTYSRC ;CONTROLLING TERMINAL SOURCE DEVICE?
04900 JRST ADVTTY ;YES
05000 SKIPN TNXBND ;ANYTHING IN THE BUFFER?
05100 JRST ADVBF1 ;NO DONT CHECK
05200 HRRZ 1,PNEXTC ;LOOK AT ADDR
05300 ADVBF2: CAML 1,TNXBND ;BEYOND BUFFER?
05400 JRST ADVBF1 ;YES, CHECK EOF, GET MORE IF THERE
05500 SKIPN 1(1) ;0 WORD?
05600 AOJA 1,ADVBF2 ;YES KEEP LOOKING FOR INFO IN THE BUFFER
05700 HRLI 1,010700
05800 PUSH P,1 ;SAVE NEW BP
05900 PUSHJ P,SGCHK ;CHECK GARBAGE COLLECTION
06000 POP P,PNT ;BP TO PNT
06100 POP P,3 ;RESTORE
06200 POP P,2
06300 POP P,1
06400 MOVEM PNT,PNEXTC
06500 MOVE TEMP,1(PNT) ;WHICH IS NON-ZERO BECAUSE WE JUST CHECKED
06600 POPJ P,
06700
06800 ADVBF1: HRRZ 1,SRCJFN
06900 JSYS GTSTS
07000 TLNE 2,1000 ;EOF?
07100 JRST ENDFL ;YES
07200 BAIL <
07300 AOS BSRCFC ;ADD ONE TO SOURCE FILE BLOCK COUNT
07400 >;BAIL
07500 HRR 2,SRCPNT
07600 ADDI 2,1 ;SRCPNT IS A 7-BIT POINTER THAT IS A WORD EARLY
07700 HRLI 2,444400 ;36-BIT POINTER.
07800 MOVNI 3,SRCBSZ ;SIZE OF SRC BUF IN WRDS, MINUS EOB NULL
07900 JSYS SIN ;SRCJFN OPEN FOR 36BIT INPUT
08000 HRRZM 2,TNXBND ;SAVE END OF BUFFER ADDRESS FOR CHECKS ABOVE
08100 SETZM 1(2) ;EOB NULL.
08200 ADVDUN: PUSHJ P,SGCHK
08300 POP P,3
08400 POP P,2
08500 POP P,1
08600 MOVE PNT,SRCPNT ;RESET PNT TO CURRENT BP,
08700 MOVEM PNT,PNEXTC ;FIX THIS GUY TOO.
08800 MOVE TEMP,1(PNT) ;GET THE FIRST WORD IN TEMP
08900 POPJ P,
09000
09100 ; CHECK FOR STRING SPACE FULL, GC IF SO
09200
09300 SGCHK:
09400 MOVEI TBITS,SRCBSZ*5 ;TENEX BUFFER SIZE
09500 MOVE TEMP,REMCHR(USER) ;REMAINING CHARS
09600 ADD TEMP,TBITS
09700 SKIPL TEMP ;ENOUGH?
09800 JRST SGCOL ;NOT ENUF STRNG SPACE FOR A FULL BUFFER
09900 POPJ P, ;NOW THERE IS
10000
10100 DSCR ADVTTY
10200 Since the boys at BBN have seen fit to not provide a standard
10300 line editor into their system, we must resort to using some runtimes
10400 to handle input in the case that the source is a TTY. We confine the
10500 problem to the case that the source is the controlling teletype, as
10600 indicated by the SRCTTY (set in CC), and use INTTY. INTTY at IMSSS
10700 uses the IMSSS PSTIN jsys, otherwise a simulation of same.
10800 ;
10900
11000 ADVTTY:
11100 EXTERNAL .SKIP.
11200 EXTERNAL INTTY
11300 EXCH SP,STPSAV
11400 PUSHJ P,INTTY ;GET A STRING USING THE PSTIN JSYS
11500 POP SP,A ;BYTE POINTER
11600 POP SP,C ;XWD -1, LENGTH -- STACKS ARE NOW OK
11700 EXCH SP,STPSAV
11800 MOVE B,.SKIP.
11900 CAIN B,32 ;CONTROL-Z TO INDIATE EOF
12000 JRST ENDFL ;YES END OF FILE
12100 MOVE B,SRCPNT
12200 HRRZ C,C
12300 MOVNS C ;NUMBER OF CHARS TO TRANSFER
12400 JSYS SIN ;USE SIN TO TRANSFER STRING
12500 MOVEI C,15
12600 IDPB C,B
12700 MOVEI C,12
12800 IDPB C,B
12900 SETZ C,
13000 REPEAT 5, <IDPB C,B> ;PUT NULLS THERE
13100 SETZM (B) ;BE SURE TO INDICATE EOF
13200 SETZM 1(B)
13300 JRST ADVDUN ;AND FINISH UP, ABOVE
13400
13500 ENDFL:
13600 HRRZ A,SRCJFN
13700 JSYS CLOSF
13800 JFCL
13900 HRRZ A,SRCJFN
14000 JSYS RLJFN
14100 JFCL
14200 POP P,3
14300 POP P,2
14400 POP P,1
14500
14600 >;TENX
14700 ENDSWT: MOVEM TBITS2,SCNWRD ;UPDATE IN CORE VERSION
14800 PUSHJ P,FILEIN ;FIND AND INIT NEW ONE
14900 JRST [TLNN TBITS2,EOFOK
15000 ;;%CI% ! (4/5)
15100 JRST ENDSW1
15200 MOVNI B,1 ;MARK END OF FILE NEXT TIME
15300 MOVEI A,1 ;HARMLESS, BUT BREAKS IGNORABLE
15400 SUB P,X11 ;RETURN EARLY
15500 POP P,C ;CHAR COUNT BACK
15600 POPJ P,]
15700 ENDSW3:
15800 ;;%DE% ! JFR 10-25-75 PUSHJ P,MAKT ;PREPARE NEW TITLE LINE
15900 SKIPE SRCDLY ;COMING BACK FROM SWTCHED-TO FILE?
16000 JRST SWTBKP ; YES, DO MORE BOOKKEEPING
16100 SETZM FPAGNO ;FIRST PAGE IN NEW FILE
16200 PUSHJ P,HDR ; , DENOTE IT
16300 JRST ADVBUF ; OR PRINT LOSING MESSAGE, TRY AGAIN
16400
16500 ^^XTCONT:MOVSI 16,INIACS ;RESTORE
16600 BLT 16,16
16700 JRST ENDSW3
16800
16900 ;;%CI% (5/5) JFR 7-18-75
17000 ENDSW1:
17100 MOVEI TEMP,LININD+1 ;MAKE SURE TRKMCS AND TRKMCR POINT A LEGIT STRING
17200 SKIPN TRKMCS
17300 MOVEM TEMP,TRKMCS
17400 SKIPN TRKMCR
17500 MOVEM TEMP,TRKMCR
17600 MOVEI TEMP,0 ;ASSUME FILE JUST RAN OUT
17700 TLNE FF,PRMSCN ;SCANNING MACRO ACTUALS?
17800 MOVEI TEMP,[ASCIZ/macro parameters/]
17900 SKIPE CNDLST
18000 MOVEI TEMP,[ASCIZ/false conditional compilation/]
18100 JUMPN TEMP,.+4 ;IF ALREADY SOME BAD REASON
18200 SKIPE XTFLAG ;ELSE TEST FOR EXTENDED COMPILATION
18300 JRST XTCOMP
18400 MOVEI TEMP,[ASCIZ/file/]
18500 HRLI TEMP,(<POINT 7,0>) ;MAKE BYTE POINTER
18600 ;;%DH%
18700 MOVE SBITS,TRKBEG ;SECOND SEMBLK OF CURRENT BEGIN
18800 HLRZ TBITS,(SBITS) ;FIRST SEMBLK OF BEGIN
18900 ERRSPL [[ASCIZ\
19000 Fatal end of source file, scanning @A.
19100 BEGIN @I @E/@D
19200 Last source-file macro: @I @E/@D
19300 Current macro: @I
19400 \]
19500 PWORD TEMP ;MORE EXPLICIT REASON
19600 PWORD $PNAME+1(TBITS) ;BLOCK NAME
19700 PWORD $PNAME+1(SBITS) ;LINE #
19800 PWORD $PNAME(SBITS) ;PAGE #
19900 PWORD @TRKMCS ;MACRO NAME
20000 PWORD TRKM.L ;LINE #
20100 PWORD TRKM.P ;PAGE #
20200 PWORD @TRKMCR] ;MACRO NAME
20300 JRST ENDSW3
20400
20500 XTCOMP:
20600 NOTENX<
20700 ;;%DL% JFR 4-30-76 prevent enclobberment if /X and /B
20800 IFN 0,< ;some problems remain
20900 SKIPE BAILON
21000 SKIPN XTFLAG
21100 JRST XTC.NR ;MISSING ONE OR BOTH OF /X, /B
21200 MOVE TEMP,SM1FIL
21300 MOVEM TEMP,NAME
21400 MOVSI TEMP,'SM0' ;NEW EXTENSION
21500 MOVEM TEMP,EXTEN
21600 MOVEM TEMP,SM1EXT
21700 SETZM WORD3
21800 MOVE TEMP,SM1PPN
21900 MOVEM TEMP,PPN
22000 RENAME SM1,NAME
22100 ERR <RENAME error .SM1>,1
22200 XTC.NR:
22300 >;IFN 0,
22400 ;;%DL% ^
22500 PUSH P,SM1DEV ;SAVE NAME OF .SM1 FILE
22600 PUSH P,SM1FIL
22700 PUSH P,SM1EXT
22800 PUSH P,SM1PPN
22900 PUSH P,BINDEV ;AND .REL FILE
23000 PUSH P,BINFIL
23100 PUSH P,BINEXT
23200 PUSH P,BINPPN
23300 >;NOTENX
23400 MOVEI TEMP,INIACS ;SAVE OUR ACS HERE
23500 BLT TEMP,INIACS+17
23600 TENX<
23700 HRROI 1,XTSFIL
23800 SETZ 3,
23900 SKIPN 2,SM1JFN
24000 JRST .+2
24100 JSYS JFNS
24200 HRROI 1,XTBFIL
24300 SETZ 3,
24400 SKIPN 2,BINJFN
24500 JRST .+2
24600 JSYS JFNS
24700 SETZM TMPCNT ;[clh]
24800 MOVE TEMP,[ASCII /XSAIL/] ;[clh]
24900 MOVEM TEMP,CMPMT ;[clh] <
25000 MOVE TEMP,[ASCIZ />/] ;[clh]
25100 MOVEM TEMP,CMPMT+1
25200 >;TENX
25300 HRLZS XTFLAG ;WHEN WE START AGAIN, WE ARE XTENDED!!!!!
25400 HRROS JOBHRL ;GET RID OF SECOND SEGMENT??
25500 HRRZ TEMP,JOBREL ;HIGHEST LEGAL ADDR IN LOW SEG
25600 MOVSI TEMP,1(TEMP) ;FIRST FREE LOC,,0
25700 HRRI TEMP,XSTART ;NEW START ADDR
25800 MOVEM TEMP,JOBSA ;NOW .SAVE HAD BETTER DO THE RIGHT THING
25900 PUUO 3,[ASCIZ/
26000 SAVE ME FOR USE AS XSAIL./]
26100 JRST RELSE
26200
26300 ; WE HAVE OLD SOURCE FILE BACK, FAKE ADVBUF
26400 SWTBKP:
26500 BAIL <
26600 QPOP BSRCFQ,BSRCFN ;RETRIEVE PREVIOUS FILE NUMBER
26700 QPOP BSRCFQ,BSRCFC ;RETRIEVE BUFF.ADDR,,BLOCK COUNT
26800 >;BAIL
26900 PUSHJ P,HDROV ;CONTINUE PAGE NUMBERING FOR FILE
27000 SETZM SRCDLY
27100 PUSHJ P,SGCHK ;CHECK (LIBERALLY) FOR STRING SPACE FULL
27200 MOVE TEMP,PNEXTC ;NOW SET UP PNT, PNEXTC, AND TEMP AS
27300 SWTLUP: SKIPN (TEMP) ; THEY WOULD BE COMING OUT OF ADVBUF
27400 JRST ADVBUF ;WE WERE AT END OF BUFFER ANYWAY
27500 MOVE PNT,TEMP ;WE'RE GOING TO GET AHEAD OF SELVES
27600 ILDB TBITS,TEMP ;CHECK NULLS
27700 JUMPE TBITS,SWTLUP ;ALL THIS UNECESSARY IF SOS FILES, BUT...
27800 MOVEM PNT,PNEXTC ;FAKE ADVBUF
27900 MOVE TEMP,(TEMP) ;WORD WITH NON-NULL CHAR
28000 POPJ P,
28100 ;;%CI% ^
28200
00100 BAIL <
00200 ^^UPDCNT: HRRM C,PNAME ;UPDATE PNAME
00300 >;BAIL
00400 NOBAIL<
00500 UPDCNT: HRRM C,PNAME ;UPDATE PNAME
00600 >;NOBAIL
00700 ADDB C,REMCHR(USER) ;AND REMCHR
00800 CAMGE C,[-=50] ;ARE WE NEARING CATASTROPHE?
00900 POPJ P, ; NO
01000 ;EVEN THIS CANNOT PREVENT OCCASIONAL DEATH
01100 MOVEI TBITS,=50 ;REQUIRE AT LEAST THIS MANY
01200 JRST SGCOL ;GO COLLECT
01300
01400 SGCOL1: HRRZ TBITS,$PNAME(LPSA) ;CHAR COUNT
01500 SGCOL2: MOVE USER,GOGTAB
01600 MOVE TEMP,REMCHR(USER) ;REMAINING CHARS
01700 ADD TEMP,TBITS
01800 SKIPGE TEMP ;NOT ENOUGH?
01900 POPJ P, ;NO, OK
02000
02100 SGCOL: EXCH SP,STPSAV ;GET STRING STACK
02200 MOVSS POVTAB+6 ;calling seq. to .SONTP may oflow
02300 PUSH P,TBITS ;PASS TO STRGC THIS WAY
02400 PUSHJ P,STRGC ;COLLECT STRING SPACE
02500 ;;#QO# -- BE SURE PNAME STAYS TOGETHER 1-25-74 RHT
02600 EXTERN .SONTP
02700 PUSH SP,PNAME
02800 PUSH SP,PNAME+1
02900 PUSH P,[0]
03000 PUSHJ P,.SONTP
03100 POP SP,PNAME+1
03200 POP SP,PNAME
03300 ;;#QO#
03400 EXCH SP,STPSAV ;GET IT BACK
03500 MOVSS POVTAB+6
03600 POPJ P, ; NO, GO AHEAD
03700 NOTENX <
03800
03900 ?CHROUT: SOSG LSTCNT ;ONE CHAR OUTPUT ROUTINE
04000 PUSHJ P,LSTDO ;DO AN OUTPUT
04100 IDPB TBITS,LSTPNT ;DO THE OUTPUT
04200 POPJ P,
04300
04400 ?LSTDO: OUT LST,
04500 POPJ P,
04600 ERR <I-O ERROR ON LISTING DEVICE>,1
04700 POPJ P,
04800 >;NOTENX
04900 TENX <
05000 ?CHROUT: EXCH TBITS,2
05100 EXCH 1,LISJFN
05200 JSYS BOUT
05300 EXCH 1,LISJFN
05400 EXCH TBITS,2
05500 POPJ P,
05600 >;TENX
05700
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 NOTENX <
10000 GONEF: SOSG LSTCNT
10100 PUSHJ P,LSTDO
10200 IDPB A,LSTPNT
10300 POPJ P,
10400 >;NOTENX
10500 TENX <
10600 GONEF: EXCH 1,2
10700 EXCH 1,LISJFN
10800 JSYS BOUT
10900 EXCH 1,LISJFN
11000 EXCH 1,2
11100 POPJ P,
11200 >;TENX
11300
11400 ^^CREFASC: ;CREF THE ASCII FOR A SYMBOL.
11500 HRRZ A,$PNAME(LPSA) ;COUNT.
11600 PUSHJ P,CREFOUT ;AND CREF...
11700 MOVE TEMP,A
11800 MOVE C,$PNAME+1(LPSA) ;BYTE POINTER.
11900 ILDB A,C
12000 PUSHJ P,CREFCHR
12100 SOJG TEMP,.-2
12200 GPOPJ: POPJ P,
12300
12400 ^^CREFDEF: ;PUT OUT SYMBOL DEFINTION.
12500 MOVEI A,11 ;ORDINARY SYMBOL
12600 MOVE TEMP,$TBITS(LPSA)
12700 TLNE TEMP,DEFINE
12800 MOVEI A,13 ;FOR MACRO
12900 PUSHJ P,CREFOUT
13000 PUSHJ P,CREFSYM
13100 JRST CREFASC ;CODE,SYMBOL,PRINT-NAME.
13200
13300 ^^CREFBLOCK: ;END OF A BLOCK.
13400 MOVEI A,16
13500 PUSHJ P,CREFOUT
13600 JRST CREFASC ;AND THE NAME.
13700
13800
13900 BEND
14000
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 MOVE TEMP,[ASCII /00001/]
01700 MOVEM TEMP,ASCLIN ;SO DOES THE SUFF WHICH APPEARS ON LISTING
01800 ;;#HU# 6-20-72 DCS BETTER TTY LISTING
01900 SKIPN CRIND ;NEED CRLF/INDENT?
02000 JRST NCRIND ;NO
02100 SETZM CRIND
02200 TERPRI
02300 ;;%CF% JFR 7-8-75
02400 SKIPA TEMP,LININD ;HOW MANY
02500 PUUO 1,[" "]
02600 SOJGE TEMP,.-1
02700 ;;%CF% ^
02800 NCRIND: PRINT < >
02900 DECPNT FPAGNO ;JUST KEEP TRACK
03000 ;;%CT% warnings if in macro or false conditional scan
03100 MOVEI TEMP,LININD+1 ;TRKMCR AND TRKMCS MUST POINT TO A STRING
03200 SKIPN TRKMCR
03300 MOVEM TEMP,TRKMCR
03400 SKIPN TRKMCS
03500 MOVEM TEMP,TRKMCS
03600 MOVEI TEMP,0
03700 TLNE FF,PRMSCN ;SCANNING MACRO PARAMS?
03800 MOVEI TEMP,[ASCIZ/macro parameters/]
03900 SKIPE CNDLST ;OR FALSE CONDIITIONAL?
04000 MOVEI TEMP,[ASCIZ/false conditional compilation/]
04100 JUMPE TEMP,SEOP1 ;IF OK
04200 HRLI TEMP,440700 ;COMPLETE BYTE POINTER
04300 MOVEI A,[ASCIZ\
04400 WARNING: Form-feed while scanning @A.
04500 Last source-file macro: @I @E/@D
04600 Current macro: @I
04700 \]
04800 MOVEI B,-1+[ PWORD TEMP
04900 PWORD @TRKMCS
05000 PWORD TRKM.L
05100 PWORD TRKM.P
05200 PWORD @TRKMCR]
05300 PUSH P,C ;SAVE THIS
05400 PUSHJ P,SPLPRT
05500 POP P,C
05600 SEOP1:
05700 ;;%CT% ^
05800
05900
06000 NOTENX<
06100 ;;%DE% JFR 10-25-75
06200 ^HDROV: SETZM LINNUM
06300 AOS PAGINC ;HERE WHEN LINES OVERFLOW PAGE
06400 MOVE TEMP,TTOP ;CUR BLOCK SEMBLK
06500 MOVEI A,TITPAT
06600 MOVEI B,-1+[
06700 PWORD IPROC+$PNAME+1 ;OUTER BLOCK NAME B.P.
06800 PWORD SRCDEV
06900 PWORD SRCFIL
07000 PLEFT SRCEXT
07100 PWORD SRCPPN
07200 PWORD FPAGNO
07300 PWORD PAGINC
07400 PWORD $PNAME+1(TEMP) ;CURRENT BLOCK NAME B.P.
07500 PWORD ASWITCH ;/A
07600 PWORD BAILON ;/B
07700 POINT 1,SCNWRD,5;/C
07800 PRIGHT DFMAX ;/D
07900 PWORD FMTWRD ;/F
08000 PWORD HISW ;/H
08100 PWORD KOUNT ;/K
08200 PWORD LSTSTRT ;/L
08300 PRIGHT PDLMAX ;/P
08400 PRIGHT SPMAX ;/Q
08500 PRIGHT PPMAX ;/R
08600 PRIGHT STMAXX ;/S
08700 PWORD OVRSAI ;/V
08800 PWORD WHERSW ;/W
08900 PWORD XTFLAG ;/X
09000 ]
09100 PUSH P,C
09200 PUSH P,D
09300 MOVSI C,-5*=28
09400 MOVE D,[IPCHAR TITLIN]
09500 EXTERNAL SPLICE
09600 PUSHJ P,SPLICE
09700 HRRZM C,BANMAC+$PNAME ;CHAR COUNT
09800 POP P,D
09900 POP P,C
10000 ;;%DF% RHT 10-25-75
10100 MOVE TEMP,FMTWRD ;CHECK FORMAT BITS
10200 TRNN TEMP,140 ; USER REQUESTED LIST OFF (40) OR NO HEADING (100)
10300 ;;%DF% ^
10400 TLNN FF,LISTNG ;LISTING FILE OPEN?
10500 POPJ P, ; NO
10600 MOVE TEMP,SCNWRD
10700 TRNE TEMP,NOLIST ;DID SCANNER TURN LISTING OFF?
10800 POPJ P, ; YES
10900 ;;%XM% ! JFR 8-22-76 WAS =5*28+4 28 IS A FUNNY OCTAL CONSTANT!
11000 MOVEI TEMP,5*=28+4 ;MAKE SURE ENOUGH ROOM REMAINS
11100 CAMLE TEMP,LSTCNT ;IS THERE
11200 PUSHJ P,LSTDO ;NOW THERE IS
11300 MOVE TEMP,BANMAC+$PNAME+1 ;B.P.
11400 IBP TEMP ;SKIP OPENING QUOTE
11500 MOVEI D,14
11600 PUSHJ P,HDROV1
11700 MOVEI D,15 ;CR
11800 MOVE TEMP,[POINT 7,[BYTE (7) 12,15,12,42],-1] ;LF CR LF "
11900 HDROV1: IDPB D,LSTPNT
12000 SOS LSTCNT
12100 ILDB D,TEMP ;CHAR FROM BANNER
12200 CAIE D,042
12300 JRST .-4 ;CONTINUE UNTIL 042 CLOSE QUOTE
12400 POPJ P,
12500 ;;%DE% ^
12600 >;NOTENX
12700
12800 TENX<
12900 ^HDROV:
13000 SETZM LINNUM
13100 AOS PAGINC ;HERE WHEN LINES OVERFLOW PAGE
13200 PUSH P,A
13300 PUSH P,B
13400 PUSH P,C
13500 PUSH P,D
13600 HRROI 2,TITLIN ;DESTINATION
13700 HRROI 1,TITTIM ;SAIL time date
13800 SETZ 3,
13900 JSYS SIN ;COPY INTO MACRO BODY STRING
14000 MOVE 1,2 ;UPDATED DESTINATION
14100 HRRZ 2,SRCJFN
14200 SETZ 3,
14300 JSYS JFNS ;FILE NAME
14400 MOVE D,1 ;UPDATED DESTINATION BYTE POINTER
14500 MOVE TEMP,TTOP ;CUR BLOCK SEMBLK
14600 MOVEI A,TITPAT ;PATTERN FOR REST OF STUFF
14700 MOVEI B,-1+[
14800 PWORD FPAGNO
14900 PWORD PAGINC
15000 PWORD IPROC+$PNAME+1 ;OUTER BLOCK NAME B.P.
15100 PWORD $PNAME+1(TEMP) ;CURRENT BLOCK NAME B.P.
15200 PWORD ASWITCH ;/A
15300 PWORD BAILON ;/B
15400 POINT 1,SCNWRD,5;/C
15500 PRIGHT DFMAX ;/D
15600 PWORD FMTWRD ;/F
15700 PWORD LODMOD ;/G
15800 PWORD HISW ;/H
15900 PWORD KOUNT ;/K
16000 PWORD LSTSTRT ;/L
16100 PRIGHT PDLMAX ;/P
16200 PRIGHT SPMAX ;/Q
16300 PRIGHT PPMAX ;/R
16400 PRIGHT STMAXX ;/S
16500 PWORD LODDDT ;/T
16600 PWORD LODSDT ;/U
16700 PWORD OVRSAI ;/V
16800 PWORD WHERSW ;/W
16900 PWORD XTFLAG ;/X
17000 ]
17100 MOVSI C,-5*=28
17200 EXTERNAL SPLICE
17300 PUSHJ P,SPLICE
17400 MOVE C,D ;UPDATED B.P.
17500 SUBI C,TITLIN ;rh(C) has # words
17600 MULI C,5 ;C_4,3,2,1 or 0, rh(D)_5*#words
17700 SUBI D,-4(C) ;rh(D)_# chars
17800 HRRZM D,BANMAC+$PNAME
17900 ;;%DF% RHT 10-25-75
18000 MOVE TEMP,FMTWRD ;CHECK FORMAT BITS
18100 TRNN TEMP,140 ; USER REQUESTED LIST OFF (40) OR NO HEADING (100)
18200 ;;%DF% ^
18300 SKIPG A,LISJFN ;LISTING FILE OPEN?
18400 JRST NOHDR ; NO
18500 MOVE TEMP,SCNWRD
18600 TRNE TEMP,NOLIST ;SCANNER TURNED LISTING OFF?
18700 JRST NOHDR ;YES
18800 HRRZI B,14
18900 JSYS BOUT
19000 MOVE B,BANMAC+$PNAME+1 ;B.P.
19100 IBP B ;SKIP OPENNING QUOTE
19200 HRRZ C,BANMAC+$PNAME ;COUNT
19300 SUBI C,4 ;OMIT QUOTES AND 177&0
19400 JSYS SOUT ;DISPOSE OF IT
19500 MOVE B,[POINT 7,[BYTE (7) 15,12,15,12],-1] ;CRLF CRLF
19600 MOVEI C,4
19700 JSYS SOUT
19800 NOHDR: POP P,D
19900 POP P,C
20000 POP P,B
20100 POP P,A
20200 POPJ P,
20300
20400 ;;%DE% JFR 10-25-75
20500 DATA(TITLE LINE)
20600 ^BANMAC:0 ;FAKE SEMBLK FOR BODY OF MACRO
20700 0
20800 POINT 7,TITLIN
20900 CNST,,STRING
21000 0
21100 TITLIN: BLOCK =60
21200 TITTIM: BLOCK =10 ;SAIL day time
21300 TITPAT: ASCII / @D-@D @I
21400 @I @BA @BB @DC @DD @BF @DG @DH @DK @BL @DP @DQ @DR @DS @DT @DU @DV @DW @DX"/
21500 BYTE (7) 177,"@",0 ; 177&0=END OF MACRO
21600 >;TENX
21700
21800
21900 NOTENX<
22000 ;;%DE% JFR 10-25-75
22100 DATA(TITLE LINE)
22200 ^BANMAC:0 ;FAKE SEMBLK FOR BODY OF MACRO
22300 0
22400 POINT 7,TITLIN
22500 CNST,,STRING
22600 0
22700 TITLIN: BLOCK =28
22800
22900 TITPAT: ASCII /"@I /
23000 NOTYMSHR <ASCII /SAIL />
23100 TYMSHR <ASCII /SAIL-TYMSHARE />
23200 ASCII / dd/
23300 ASCII /-mon-/
23400 ASCII /yr /
23500 ASCII /hr:mn/
23600 ASCII / @F:@F.@F@G @D-@D /
23700 ASCII /
23800 @I @BA @BB @DC @DD @BF @DH @DK @BL @DP @DQ @DR @DS @DV @DW @DX/
23900 BYTE (7) 042,177,"@",0 ;" 177&0=END OF MACRO
24000 0
24100 ENDDATA
24200
24300 ; MAKT -- PREPARE A TITLE LINE
24400
24500 ^MAKT: NOTYMSHR <MOVE TEMP,[POINT 7,TITPAT+2,20] ;IDPB POINTER TO DAY OF MONTH>
24600 TYMSHR <MOVE TEMP,[POINT 7,TITPAT+4,20]>
24700 CALL6 C,DATE
24800 IDIVI C,=31 ;DAY IN D
24900 ADDI D,1 ;DAY - 1 THAT IS
25000 PUSHJ P,MAKT.1
25100 IDIVI C,=12 ;MONTH - 1 IN D
25200 MOVE D,[ASCII /-JAN--FEB--MAR--APR--MAY--JUN--JUL-/
25300 ASCII /-AUG--SEP--OCT--NOV--DEC-/](D)
25400 AOJ TEMP,
25500 MOVEM D,(TEMP) ;-mon-
25600 MOVEI D,=64(C) ;YEAR
25700 PUSHJ P,MAKT.1
25800 NOTYMSHR <MOVE TEMP,[POINT 7,TITPAT+5]>
25900 TYMSHR <MOVE TEMP,[POINT 7,TITPAT+7]>
26000 CALL6 C,MSTIME ;TIME IN MS
26100 IDIVI C,=60000
26200 IDIVI C,=60 ;MINUTES IN D
26300 EXCH D,C ;HOURS IN D
26400 PUSHJ P,MAKT.1
26500 IBP TEMP ;COLON
26600 MOVE D,C ;MINUTES
26700 MAKT.1: IDIVI D,=10
26800 ADDI D,"0"
26900 IDPB D,TEMP
27000 ADDI D+1,"0"
27100 IDPB D+1,TEMP
27200 POPJ P,
27300 ;;%DE% ^
27400 >;NOTENX
27500
27600
27700 TENX <
27800 ^MAKT:
27900 HRROI 2,TITTIM ;DEST. DESIGN. FOR ALL THAT FOLLOWS
28000 HRROI 1,[ASCIZ /"SAIL /]
28100 SETZ 3,
28200 JSYS SIN ;MERELY COPY
28300 MOVE 1,2 ;UPDATED DEST
28400 SETO 2, ;CURRENT TIME
28500 SETZ 3, ;KEEP IT SIMPLE
28600 JSYS ODTIM ;APPEND DATE AND TIME
28700 SETZ 2,
28800 IDPB 2,1 ;MAKE SURE ITS ASCIZ
28900 POPJ P,
29000 >;TENX
29100
29200 SUBTTL ENTERS -- ENTER A SYMBOL
29300
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 "QRCTYP" -- Record class id. ... if not zero, put into lhs of $acno
04200
04300 Also, the prodef bit in ff is used to tell if the symbol is a formal param
04400
04500 RES "NEWSYM"_pointer to new block.
04600
04700 SID Uses A,C, TBITS, LPSA, TEMP; alters symbol table structure
04800
04900
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 REC <
05400 SKIPE C,QRCTYP ;RECORD CLASS ID SPECIFIED
05500 HRLM C,$ACNO(LPSA)
05600 >;REC
05700 PUSHJ P,URGVRB
05800 PUSHJ P,RNGVRB
05900 POPJ P,
06000
06100 ISPRC: TRNN TBITS,PROCED ;THIS SHOULD ALSO BE A PROCEDURE
06200 ERR <DUPLICATE IDENTIFIER DECLARATION FOR >,3,BRANEW
06300
06400 ; FORWARD PROCEDURE BEING DEFINED NOW, CHECK VALIDITY, CHANGE BITS
06500
06600 TRZE A,FORWRD ;TO MATCH OLD(COMPLEMENTED)
06700 TLNN A,EXTRNL ;MAKE SURE NOT DUPLICATE EXTERNAL
06800 ERR <DUPLICATE FORWARD/EXTERNAL DECLARATION FOR >,3,NOPROG
06900 ;;#JX#2! 11-2-72 DCS ALLOW INTERNAL PROC TO OVERRIDE EXTERNAL PROC.
07000 TLON TEMP,EXTRNL ;Turn off EXTRNL in old, but if it was on, flip
07100 TLC A,INTRNL ; INTRNL in new (will turn it off was on -- correct)
07200 ;;#JX#
07300 CAME A,TEMP ;CHECK MATCHING TYPES
07400 ERR <FORWARD TYPE DISAGREES>,1
07500 TRO TBITS,INPROG ;MARK PROCEDURE UNDER DEFINITION
07600 ;;#SD# ADD A FLAG IF OLD IS EXTERNAL & NEW IS INTERNAL
07700 MOVE C,$TBITS(LPSA) ; COULD HAVE USED THE HAIR ABOVE, BUT ...
07800 SETOM IEFLAG ;SET THE FLAG
07900 TLNE C,EXTRNL ;RESET IT IF OLD NOT EXTERNAL
08000 TLNN TBITS,INTRNL ;OR NEW NOT INTERNAL
08100 SETZM IEFLAG ;
08200 ;;#SD#
08300
08400 MOVEM TBITS,$TBITS(LPSA) ;STORE NEW
08500 REC <
08600 SKIPE C,QRCTYP ;RECORD CLASS ID SPECIFIED
08700 HRLM C,$ACNO(LPSA)
08800 >;REC
08900 NOPROG: PUSHJ P,URGVRB ;REMOVE FROM VARB RING
09000 PUSHJ P,RNGVRB ;PUT BACK ON THE END
09100 LEFT ,%TLINK,LPSERR ;PTR TO SECOND BLOCK
09200 LEFT (,%TLINK)
09300 ;;#GP# DCS 2-6-72 (2-4) CHECK OLD FORMALS AGAINST ACTUAL ONES
09400 HRRZM LPSA,OLDPRM ;SAVE OLD FORMALS -- USED TO KILLST HERE
09500 POPJ P, ;FOR A BIT LATER
09600 ;;#GP# (2)
09700
09800 ; REDEFINITION IF NOT A PARAMETER TO A MACRO
09900
10000 DFEN1: TLNN TEMP,FORMAL ;BITS ARE COMPLEMENTED HERE, CAN'T BE FORMAL
10100 ERR <DUPLICATE IDENTIFIER DECLARATION>,1
10200 POPJ P, ; GET OUT IF MACRO REDEFINITION AT THE SAME
10300 ; LEVEL. BODY IS DELETED IN DFENT IF
10400 ; %TLINK IS NON-ZERO
10500
10600
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 REC <
03900 SKIPE C,QRCTYP ;RECORD CLASS ID SPECIFIED
04000 HRLM C,$ACNO(LPSA)
04100 >;REC
04200 SKIPE C,SIMPSW ;IF SIMPLE
04300 AOJA C,FILLEV ;CLEVER TRICK TO LOAD C 0 & GO PUT IN LL
04400 TRNN TBITS,LABEL ;OR NOT A LABEL, DONT CARE
04500 JRST DOLL ;GO DO LEVELS
04600 MOVE C,TPROC ;PICK UP CURRENT PROCEDURE
04700 HRRZ C,$VAL(C) ;PICK UP PD SEMBLK
04800 HRLM C,$ACNO(LPSA) ;PUT AWAY FOR LABEL SEMBLK
04900 ;#HY# RHT 6-26-72 OWN WAS BEING TESTED AS A RIGHT HALF BIT
05000 DOLL: SKIPE C,CDLEV ;PICK UP DISPLY LEVEL
05100 ;;#IU# 8-12-72 ! RHT PREVENT EXTERNALS FROM BEING REFD (RF)
05200 TLNE TBITS,OWN!EXTRNL;IF NON-ZERO DISPLY LEV, BUT OWN, OK
05300 ;;#LS# RHT 2! 3-12-73 WAS GETTING TO FILLEV WITH NOD ZERO C FOR OWN&EXTERNAL
05400 JRST [SETZM C ;NO WORRY, ID IS AT LEVEL 0
05500 JRST FILLEV]
05600 SKIPE RECSW ;IF CURRENT PROC IS RECURSVE
05700 ;#HY# RHT HERE IS WHERE OWN WAS BEING TESTED
05800 TRNE TBITS,ITEM!LABEL!PROCED; YES, IF NOT ITEM,LABEL, OR PROC THEN USE
05900 ;STACK
06000 TLNE FF,PRODEF ;IF FORMAL USE STACK -- PRODEF SAYS WAS AN ARG LST
06100 LSH C,LLFLDL ;SHIFT LEVEL T RIGHT SPOT
06200 TRZ C,LLFLDM
06300 ;MASK OUT LEX LEV FLD AREA
06400 FILLEV: TDO C,LEVEL ;PUT IN THE LEX LEVEL
06500 HRRZM C,$SBITS(LPSA) ;LEVEL OF DEFINITION
06600
06700 ; LINK TO BUCKET, STRING RING
06800
06900 MOVEI A,LNKRET+1 ;IN-LINE "CALL"
07000 LNK: MOVE B,HPNT ;WORD SET UP BY HASH
07100 XCT B ;THIS PICKS UP THE TIE INTO LPSA
07200 MOVE TEMP,NEWSYM ;POINTER TO NEW ONE
07300 HRRM LPSA,%TBUCK(TEMP) ;LINK DOWN NEW BLOCK
07400 HRR LPSA,TEMP ;GET LPSA READY TO PUT BACK
07500 TLO B,2000 ;TURN ON "MOVE TO MEMORY" BIT
07600 XCT B
07700 LNKRET: JRST (A) ;ALL DONE
07800
07900 MOVE LPSA,NEWSYM
08000 PUSHJ P,RNGSTR ;PUT ON STRING RING
08100
08200
08300 ; IF NOT A CONSTANT, LINK TO VARB LIST -- RETURN
08400
08500 TLNE TBITS,CNST ;NOT ON VARB IF CONST
08600 POPJ P, ; DONE
08700
08800 MOVE LPSA,NEWSYM
08900 JRST RNGVRB ;PUT ON VARB RING
09000
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,
02600
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
07200
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,
11400
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)
13800
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,
03800
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,
04300
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 MOVEI B,(A)
02000 ML$CHR
02100 POP P,B ;RESTORE B
02200 POPJ P, ;RETURN
02300
02400
02500
02600 DSCR LSTOU1 -- Write to list file
02700 CAL PUSHJ P,LSTOU1
02800 PAR Reg A contains character to be listed
02900 Reg C contains character that the char in A should follow
03000 RES If the last character in the line matches the one in
03100 C, the character in A is put at the end of the line. If
03200 not, the char in A is placed before the last character.
03300 The necessity for doing this comes from the fact that some
03400 single character tokens are placed in the listing file before
03500 they are parsed.
03600 SID Register A may be changed
03700
03800 ^LSTOU1: PUSH P,B ;SAVE B
03900 LDB B,LPNT ;GET THE LAST CHAR
04000 CAMN B,C ;IS IT THE ONE WE WANT...
04100 JRST .+8 ;YES, GO STORE CHARACTER
04200 CAIGE C,"A" ;IS THE COMPARE CHAR A LETTER
04300 JRST .+4 ;NO
04400 ADDI C,"a"-"A" ;CONVERT TO LOWERCASE
04500 CAMN B,C ;IS IT THE RIGHT THING?
04600 JRST .+3 ;YES, GO STORE CHARACTER AND RETURN
04700 DPB A,LPNT ;NO, STORE NEW CHAR
04800 MOVEI A,(B) ;THEN OLD CHARACTER
04900 MOVEI B,(A)
05000 ML$CHR
05100 POP P,B ;RESTORE B
05200 POPJ P, ;RETURN
05300
05400 BEND SYM
05500 ^KILLST_KILLST
05600
05700 SUBTTL Generator Data
05800
05900
06000