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 04900 DEFINE OPER <.-SCNTBL> 05000 DEFINE LTR 05100 DEFINE NESTED <> 05200 DEFINE LNESTD <> 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, ;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, 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, ;DIGITS 10200 TCOL ; : 10300 TSEMI ; ; 10400 TLES ; < 10500 TEQU ; = 10600 TGRE ; > 10700 TQUES ;? 10800 XWD LETDG+NUMB+ATSIGN,.-SCNTBL ; @ 10900 REPEAT =26, ;UPPER CASE LETTERS 11000 LNESTD+TLBR ; [ 11100 LTR ; TILDE 11200 NESTED+TRBR ; ] 11300 TUPRW ;^ 11400 TLARW ;_ 11500 RASSOC ;` 11600 REPEAT =26, ;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 13900 DEFINE ML$BAK 14000 >;IFE FTL$DBG 14100 IFN FTL$DBG,< 14200 DEFINE ML$CHR 14300 DEFINE ML$BAK 14400 14500 L$CHR: SOSGE L$CNT ;ADD CHAR IN B TO LSTBUF, CHECKING OVERFLOW 14600 ERR ,1 14700 IDPB B,LPNT 14800 POPJ P, 14900 15000 5*-5  0  0  0  0 15100 L$TAB: 5*-4 15200 5*-3 15300 5*-2 15400 5*-1 15500 5*-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 ,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 ;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 ,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 ,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 ,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[ 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> 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 ,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 ,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 ,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 ,1 23600 TLNE SBITS2,INTOV ;INTEGER OVERFLOW? 23700 ERR ,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 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 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 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 ]> 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 ,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, ;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,() ;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 ,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 ,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 23100 TYMSHR 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 24600 TYMSHR 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 25900 TYMSHR 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 ,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 ,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 ,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 ,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 ,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 ,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 ,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,() 10800 SKIPL B 10900 HRLI LPSA,() 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, 03900 IFE TSTALO,BLLEN__BLKLEN+2 ;SET TOTAL BLOCK SIZE 04000 IFN TSTALO, 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 ;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 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, 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, 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