V10/cmd/spitbol/4.3/spitv43.min
* CHANGES [SGD]
* -------------
* 1. COMMENTED OUT DEFAULT .DEF, .UNDEF AS THESE MACHINE-
* DEPENDENT. I SUGGEST AGAIN THAT THESE DO NOT BELONG
* IN MINIMAL SOURCE, UNLESS SOMETHING OF THE FORM .*DEF
* IS TO BE INCORPORTATED INTO MINIMAL LANGUAGE DEFN.
*
* 2. NOTED THAT DESCRIPTION OF BEV, BOD MISSING FROM
* SBL42.CMT MINIMAL DESCRIPTION, AND DISCUSSION OF
* "ODD"/"EVEN" AND REQUIREMENTS PERTAINING THERETO
* SEEMS INSUFFICIENT.
*
* 3. PERMIT CODE KEYWORD TO CONTAIN ANY INTEGER VALUE.
* THIS CONSISTS OF REMOVING THE ENFORCED RESTRICTION
* IN ASIGN (SEE ASG24), SINCE CODE CONTAINS NO RELOC.
* USE OF KEYWORD VALUE (AS IT SHOULDNT). SBL DOC.
* MUST BE UPDATED. ADDRESS OF CODE VALUE NOW PASSED TO
* OSINT (KVCOD), INSTEAD OF VALUE ITSELF. HENCE OSINT
* DOCUMENTATION MUST LIKEWISE BE REVISED. CHANGES
* MADE IN KEYWORD DEFINITION TABLES, PROCEDURES ACESS
* AND ASIGN SINCE CODE NOW SPECIAL KEYWORD.
*
* EROSI RETURNS NOW CONTAIN NEW CODE KEYWORD VALUE IN
* IA. OSINT DOCUMENTATION MUST BE REVISED.
*
* INTERESTINGLY, THIS SHOULD PERMIT THE SPITBOL PROGRAM
* TO INTERROGATE THE CODE KEYWORD AT THE START OF
* EXECUTION TO DETERMINE IF COMPILATION ERRORS
* OCCURRED.
*
* 4. ADD -COPY "FILETAG" CONTROL CARD. -COPY PERMITTED IN
* CODE STRINGS. NESTING IS PERMITTED TO ANY LEVEL,
* THOUGH OSINT IS FREE TO RESTRICT THE MAXIMUM LEVEL.
* NOTE REQUIREMENT FOR FILETAG SPECIFIED AS
* STRING CONSTANT SINCE FILETAGS MAY CONTAIN SEMICOLONS.
* I HAVE TRIED TO MAKE THIS ENHANCEMENT WITH MINIMUM
* (MINIMAL?) AMOUNT OF NEW CODE, SO THE FEATURE IS
* NOT CONDITIONALIZED. THE SOLUTION
* REQUIRED THE ADDITION OF A NEW BLOCK TYPE (COBLK) TO
* BUILD THE INPUT CONTEXT SAVE STACK AS A CHAIN OF
* COBLKS. A RECUSIVE SOLUTION ON CMPIL/READR/NEXTS
* WOULD HAVE REQUIRED EXTENSIVE MODIFICATIONS AND
* SUBSTANTIAL NEW CODE. NOTE THAT FORMS SUCH AS
* CODE('-COPY "FILE.SBL"') ARE ACCEPTABLE, WHICH IS
* VIEWED AS SIGNIFICANT ENHANCEMENT IN ADDITION TO
* COMPILE-TIME INCLUDE.
*
* TO SUPPORT THIS FEATURE, TWO NEW OSINT ROUTINES ARE
* DEFINED, SYSSC (START COPY) AND SYSEC (END COPY) WITH
* LOGICS DESCRIBED IN THE .CMT FILE.
*
* BECAUSE OF ANNOYANCE FACTOR, SOURCE LISTING OF
* CODE() INFO VIA -LIST, INCLUDING -COPY INPUT, IS
* NO LONGER POSSIBLE. IF THIS IS PERMITTED, THEN
* ONE FINDS -COPY INPUT BEING PRINTED ON STD.
* OUTPUT CHANNEL (DEPENDING ON STATE OF -LIST),
* UNLESS EXPLICIT -NOLIST IS GIVEN.
*
* 5. THE DOCUMENTATION FOR SYSIO IS INCONSISTENT. IT
* SHOWS 0,1,2,3 BEING POSSIBLE INPUTS DEPENDING ON
* INPUT/OUTPUT, STD/NONSTD. HOWEVER, IT ALSO APPEARS
* (AND IS STATED) THAT SYSIO IS NOT CALLED FOR STD
* INPUT/OUTPUT.
*
* 6. SINCE -PRINT,-NOPRINT REMOVED IN V4, I HAVE
* REINSTATED THE CIRCUIT IN NEXTS TO AVOID LISTING
* CONTROL CARDS (-COPY FORCES LIST IN CNCRD THOUGH).
*
* 7. WA NOW CONTAINS THE INITIAL VALUE OF &CODE ON ENTRY
* TO SPITBOL.
*
* 8. ADDED DDC (DEFINE DISPLAY CONSTANT). IS IDENTICAL
* TO DTC EXCEPT THAT ON SYSTEMS SUPPORTING LOWER CASE,
* THE DISPLAY TEXT CAN BE TRANSLATED WITH A
* CASE MIX. FOR EXAMPLE, CAPITALIZE ONLY THE FIRST
* LETTER, OR THE FIRST LETTER OF EVERY WORD, OR NO
* UPPER CASE (FOR EUNICHS), ETC.
*
* 9. FIX MINOR OVERSIGHT IN FAILING TO CLEAR R$PMB AT
* END OF PATTERN MATCH, THUS LEAVING PTR TO BCBLK
* THAT CANNOT BE COLLECTED.
*
* 10. AFTER CONSULTATION WITH DAVE SHIELDS, IT WAS AGREED
* TO REINSTATE ARG,FIELD,ITEM AND LOCAL FUNCTIONS.
* COMMENTS WERE RECEIVED THAT REMOVING THEM BREAKS
* EXISTING CODE IN DIFFICULT-TO-FIX WAYS, INCLUDING
* A NUMBER OF THE UTILITY ROUTINES IN GIMPELS BOOK.
* IN ANY EVENT, THESE ARE SNOBOL4 COMPATIBILITY
* FUNCTIONS THAT TAKE LITTLE CODE SPACE. AS A
* RESULT OF THIS, AND -COPY, ERROR NUMBERS HAVE
* BEEN PUSHED BACK OVER THE 255 THRESHOLD, WHICH
* SEEMS UNAVOIDABLE UNLESS MAJOR SURGERY IS DONE.
*
* 11. VERSION ID CHANGED TO V4.3 DUE TO SUBSTANTIAL
* CHANGES.
*
* 12. PERMIT DOLLAR SIGN IN VARIABLE NAMES. MINOR
* CHANGE TO OPERATOR TABLE AND SCANE.
*
* 13. PERMIT BUFFER TYPE FOR LOAD SPECIFICATION. AS
* A SIDE-EFFECT, THE CODE FOR BUFFER CONVERSION HAS
* BEEN CENTRALIZED IN GTBUF. ALSO FIXED PADDING
* BUG IN INSBF RELATED TO ZERO PADDING.
*
* 14. DOCUMENT THAT SYSIL MUST NEVER REQUEST ZERO BYTES.
* DOING SO CAUSES ACESS TO POTENTIALLY CREATE
* INVALID MEMORY CAUSING LATER GARBAGE COLLECTOR
* PROBLEMS OR MISADJUSTMENTS OF DNAMP, ETC.
*
* 15. VDIFFER FUNCTION ADDED. VDIFFER(X,Y) RETURNS X
* IF DIFFERENT FROM Y. IN MOST CASES IT IS EXPECTED
* THAT Y WOULD BE NULL.
*
SEC FORMAL START OF PROCEDURES SECTION
EJC
*
* SPITBOL CONDITIONAL ASSEMBLY SYMBOLS
* ------------------------------------
*
* IN THE SPITBOL TRANSLATOR, THE FOLLOWING CONDITIONAL
* ASSEMBLY SYMBOLS ARE REFERRED TO.
* A PARTICULAR SET OF DEFAULT SETTINGS IS GIVEN IN THIS
* SOURCE BY USE OF .DEF AND .UNDEF PSEUDO OPS.
* A DIFFERENT SELECTION MAY BE MADE BY VARYING THE
* DEFINITIONS. AS AN ALTERNATIVE, THIS SECTION MAY BE
* COMMENTED OUT AND THE MINIMAL TRANSLATOR PRELOADED WITH
* THE SELECTED DEFINITIONS, THUS ALLOWING A MORE DYNAMIC
* CHOICE TO BE MADE.
* SOME OF THE CONDITIONAL FEATURES CHOOSE AMONGST A VARIETY
* OF OPTIONS. OTHERS ARE DEFINED PRINCIPALLY TO ALLOW
* OMISSION OF A FEATURE WHICH IS NOT WANTED IN ORDER TO
* SAVE MEMORY OR BECAUSE IT CANNOT BE SUPPORTED.
* NOTE THAT IF .CPLC OPTION IS CHOSEN, TRANSLATION OF DTC,
* ERR, ERB ARGUMENTS SHOULD BE TO LOWER CASE.
*
*.DEF .CAHT DEFINE TO INCLUDE HORIZONTAL TAB
*.DEF .CASL DEFINE TO INCLUDE 26 SHIFTED LETTRS
*.DEF .CAVT DEFINE TO INCLUDE VERTICAL TAB
*.UNDEF .CEPP DEFINE FOR ODD PARITY ENTRY POINTS
*.UNDEF .CNBF DEFINE TO OMIT BUFFER EXTENSION
*.UNDEF .CNBT DEFINE TO OMIT BATCH INITIALISATION
*.UNDEF .CNEX DEFINE TO OMIT EXIT() CODE
*.UNDEF .CNFN DEFINE TO OMIT FENCE() CODE
*.UNDEF .CNLD DEFINE TO OMIT LOAD() CODE
*.UNDEF .CNPF DEFINE TO OMIT PROFILE CODE
*.UNDEF .CNRA DEFINE TO OMIT ALL REAL ARITHMETIC
*.UNDEF .CNSR DEFINE TO OMIT SORT, RSORT CODE
*.DEF .CPLC DEFINE IF HOST PREFERS LOWER CASE
*.UNDEF .CRPP DEFINE FOR ODD PARITY RETURN POINTS
*.UNDEF .CS16 DEFINE TO INITIALIZE STLIM TO 32767
*.UNDEF .CSAX DEFINE IF SYSAX IS TO BE CALLED
*.UNDEF .CSCI DEFINE TO ENABLE SYSCI ROUTINE
*.UNDEF .CSCV DEFINE FOR CLU, CUL CASE CONVERSION
*.DEF .CSIG DEFINE TO IGNORE CASE OF LETTERS
*.UNDEF .CSN6 DEFINE TO PAD STMT NOS TO 6 CHARS
*.DEF .CSN8 DEFINE TO PAD STMT NOS TO 8 CHARS
*.UNDEF .CTMD DEFINE IF SYSTM UNIT IS DECISECOND
.IF .CASL
.ELSE
.UNDEF .CSIG .CSIG USELESS WITHOUT LC LETTERS
.UNDEF .CPLC .CPLC ERRONEOUS WITHOUT LC LETTERS
.FI
EJC
*
* ACTUAL PROCESSABLE EXP PROCEDURE DEFINITIONS
*
.IF .CSAX
SYSAX EXP E,0
.ELSE
.FI
SYSBX EXP E,0
.IF .CSCI
SYSCI EXP E,0
.FI
SYSDT EXP E,0
SYSEC EXP E,2
SYSEF EXP E,2
SYSEJ EXP E,0
SYSEM EXP E,0
SYSEN EXP E,2
SYSEP EXP E,2
.IF .CNLD
.ELSE
SYSEX EXP E,1
.FI
SYSHS EXP E,2
SYSID EXP E,0
SYSIL EXP E,0
SYSIN EXP E,2
SYSIO EXP E,2
.IF .CNLD
.ELSE
SYSLD EXP E,2
.FI
SYSMM EXP E,0
SYSMX EXP E,0
SYSOU EXP E,2
SYSPI EXP E,2
SYSPP EXP E,0
SYSPR EXP E,2
SYSRD EXP E,2
SYSRI EXP E,2
SYSSC EXP E,2
.IF .CUST
SYSST EXP E,2
.FI
SYSTM EXP E,0
SYSTT EXP E,0
.IF .CNLD
.ELSE
SYSUL EXP E,0
.FI
.IF .CNEX
.ELSE
SYSXI EXP E,2
.FI
EJC
* NAME GLOBAL LABELS, INTERNAL PROCEDURES AND ROUTINES.
*
CMPCE GLB
CMPEL GLB
CMPLE GLB
CMPSE GLB
EVLXF GLB
EVLXN GLB
EVLXV GLB
LCNXE GLB
TRXQR GLB
ACESS INP R,1
ACOMP INP N,5
ALLOC INP E,0
.IF .CNBF
.ELSE
ALOBF INP E,0
.FI
ALOCS INP E,0
ALOST INP E,0
.IF .CNRA
ARITH INP N,2
.ELSE
ARITH INP N,3
.FI
ASIGN INP R,1
ASINP INP R,1
BLKLN INP E,0
CBLCK INP N,1
CDGCG INP E,0
CDGEX INP R,0
CDGNM INP R,0
CDGVL INP R,0
CDWRD INP E,0
CMGEN INP R,0
CMPIL INP E,0
CNCRD INP E,0
COPND INP E,0
DFFNC INP E,0
DTYPE INP E,0
DUMPR INP E,0
ERMSG INP E,0
ERTEX INP E,0
EVALI INP R,3
EVALP INP R,1
EVALS INP R,2
EVALX INP R,1
EXBLD INP E,0
EXPAN INP E,0
EXPAP INP E,1
EXPDM INP N,0
EXPOP INP N,0
GBCOL INP E,0
GBCPF INP E,0
GTARR INP E,1
.IF .CNBF
.ELSE
GTBUF INP E,1
.FI
EJC
GTCOD INP E,1
GTEXP INP E,1
GTINT INP E,1
GTNUM INP E,1
GTNVR INP E,1
GTPAT INP E,1
.IF .CNRA
.ELSE
GTREA INP E,1
.FI
GTSMI INP N,2
GTSTG INP N,1
GTVAR INP E,1
HASHS INP E,0
ICBLD INP E,0
IDENT INP E,1
INOUT INP E,0
.IF .CNBF
.ELSE
INSBF INP E,2
.FI
IOFTG INP N,1
IOPUT INP N,4
KTREX INP R,0
KWNAM INP N,0
LCOMP INP N,5
LISTR INP E,0
LISTT INP E,0
NEXTS INP E,0
PATIN INP N,2
PATST INP N,1
PBILD INP E,0
PCONC INP E,0
PCOPY INP N,0
.IF .CNPF
.ELSE
PRFLR INP E,0
PRFLU INP E,0
.FI
PRPAR INP E,0
PRTCF INP E,0
PRTCH INP E,0
PRTFB INP E,0
PRTFH INP R,0
PRTIN INP E,0
PRTMI INP E,0
PRTNM INP R,0
PRTNV INP E,0
PRTPG INP E,0
PRTPS INP E,0
PRTSF INP E,0
PRTSN INP E,0
PRTST INP R,0
EJC
PRTVF INP E,0
PRTVL INP R,0
PRTVN INP E,0
PTTFH INP E,0
PTTST INP E,0
.IF .CNRA
.ELSE
RCBLD INP E,0
.FI
READR INP E,0
.IF .CASL
SBSCC INP E,0
SBSTG INP E,0
.FI
SBSTR INP E,0
SCANE INP E,0
SCNGF INP E,0
SETVR INP E,0
.IF .CNSR
.ELSE
SORTA INP N,1
SORTC INP E,1
SORTF INP E,0
SORTH INP N,0
.FI
TFIND INP E,1
TRACE INP N,3
TRBLD INP E,0
TRCHN INP E,1
TRIMR INP E,0
TRXEQ INP R,0
XSCAN INP E,0
XSCNI INP N,2
ARREF INR
CFUNC INR
EROSI INR
ERROR INR
EXFAL INR
EXINT INR
EXITS INR
EXIXR INR
EXNAM INR
EXNUL INR
.IF .CNRA
.ELSE
EXREA INR
.FI
EXSID INR
EXVNM INR
FAILP INR
FLPOP INR
INDIR INR
INITL INR
MATCH INR
RETRN INR
STAKV INR
STCOV INR
STMGO INR
STOPR INR
SUCCP INR
TTL S P I T B O L -- DEFINITIONS AND DATA STRUCTURES
* THIS SECTION CONTAINS ALL SYMBOL DEFINITIONS AND ALSO
* PICTURES OF ALL DATA STRUCTURES USED IN THE SYSTEM.
*
SEC START OF DEFINITIONS SECTION
*
* DEFINITIONS OF MACHINE PARAMETERS
*
* THE MINIMAL TRANSLATOR SHOULD SUPPLY APPROPRIATE VALUES
* FOR THE PARTICULAR TARGET MACHINE FOR ALL THE
* EQU *
* DEFINITIONS GIVEN AT THE START OF THIS SECTION.
* NOTE THAT EVEN IF CONDITIONAL ASSEMBLY IS USED TO OMIT
* SOME FEATURE (E.G. REAL ARITHMETIC) A FULL SET OF CFP$-
* VALUES MUST BE SUPPLIED. USE DUMMY VALUES IF GENUINE
* ONES ARE NOT NEEDED.
*
CFP$A EQU * NUMBER OF CHARACTERS IN ALPHABET
*
CFP$B EQU * BAUS/WORD ADDRESSING FACTOR
*
CFP$C EQU * NUMBER OF CHARACTERS PER WORD
*
CFP$F EQU * OFFSET IN BAUS TO CHARS IN
* SCBLK. SEE SCBLK FORMAT.
*
CFP$I EQU * NUMBER OF WORDS IN INTEGER CONSTANT
*
CFP$M EQU * MAX POSITIVE INTEGER IN ONE WORD
*
CFP$N EQU * NUMBER OF BITS IN ONE WORD
*
CFP$R EQU * NUMBER OF WORDS IN REAL CONSTANT
*
CFP$S EQU * NUMBER OF SIG DIGS FOR REAL OUTPUT
*
* THE FOLLOWING DEFINITION FOR CFP$U SUPPLIES A REALISTIC
* UPPER BOUND ON THE SIZE OF THE ALPHABET. CFP$U IS USED
* TO SAVE SPACE IN THE SCANE BSW-IFF-ESW TABLE AND TO EASE
* TRANSLATION STORAGE REQUIREMENTS.
*
CFP$U EQU * REALISTIC UPPER BOUND ON ALPHABET
*
CFP$X EQU * MAX DIGITS IN REAL EXPONENT
*
MXDGS EQU CFP$S+CFP$X MAX DIGITS IN REAL NUMBER
*
NSTMX EQU MXDGS+5 MAX SPACE FOR REAL (FOR +0.E+)
EJC
*
* ENVIRONMENT PARAMETERS
*
* THE SPITBOL PROGRAM IS ESSENTIALLY INDEPENDENT OF
* THE DEFINITIONS OF THESE PARAMETERS. HOWEVER, THE
* EFFICIENCY OF THE SYSTEM MAY BE AFFECTED. CONSEQUENTLY,
* THESE PARAMETERS MAY REQUIRE TUNING FOR A GIVEN VERSION
* THE VALUES GIVEN IN COMMENTS HAVE BEEN SUCCESSFULLY USED.
*
* E$SRS IS THE NUMBER OF WORDS TO RESERVE AT THE END OF
* STORAGE FOR END OF RUN PROCESSING. IT SHOULD BE
* SET AS SMALL AS POSSIBLE WITHOUT CAUSING MEMORY OVERFLOW
* IN CRITICAL SITUATIONS (E.G. MEMORY OVERFLOW TERMINATION)
* AND SHOULD THUS RESERVE SUFFICIENT SPACE AT LEAST FOR
* AN SCBLK CONTAINING SAY 30 CHARACTERS.
*
E$SRS EQU * 30 WORDS
*
* E$STS IS THE NUMBER OF WORDS GRABBED IN A CHUNK WHEN
* STORAGE IS ALLOCATED IN THE STATIC REGION. THE MINIMUM
* PERMITTED VALUE IS 256/CFP$B. LARGER VALUES WILL LEAD
* TO INCREASED EFFICIENCY AT THE COST OF WASTING MEMORY.
*
E$STS EQU * 500 WORDS
*
* E$CBS IS THE SIZE OF CODE BLOCK ALLOCATED INITIALLY AND
* THE EXPANSION INCREMENT IF OVERFLOW OCCURS. IF THIS VALUE
* IS TOO SMALL OR TOO LARGE, EXCESSIVE GARBAGE COLLECTIONS
* WILL OCCUR DURING COMPILATION AND MEMORY MAY BE LOST
* IN THE CASE OF A TOO LARGE VALUE.
*
E$CBS EQU * 500 WORDS
*
* E$HNB IS THE NUMBER OF BUCKET HEADERS IN THE VARIABLE
* HASH TABLE. IT SHOULD ALWAYS BE ODD. LARGER VALUES WILL
* SPEED UP COMPILATION AND INDIRECT REFERENCES AT THE
* EXPENSE OF ADDITIONAL STORAGE FOR THE HASH TABLE ITSELF.
*
E$HNB EQU * 127 BUCKET HEADERS
*
* E$HNW IS THE MAXIMUM NUMBER OF WORDS OF A STRING
* NAME WHICH PARTICIPATE IN THE STRING HASH ALGORITHM.
* LARGER VALUES GIVE A BETTER HASH AT THE EXPENSE OF TAKING
* LONGER TO COMPUTE THE HASH. THERE IS SOME OPTIMAL VALUE.
*
E$HNW EQU * 6 WORDS
*
* E$FSP . IF THE AMOUNT OF FREE SPACE LEFT AFTER A GARBAGE
* COLLECTION IS SMALL COMPARED TO THE TOTAL AMOUNT OF SPACE
* IN USE GARBAGE COLLECTOR THRASHING IS LIKELY TO OCCUR AS
* THIS SPACE IS USED UP. E$FSP IS A MEASURE OF THE
* MINIMUM PERCENTAGE OF DYNAMIC MEMORY LEFT AS FREE SPACE
* BEFORE THE SYSTEM ROUTINE SYSMM IS CALLED TO TRY TO
* OBTAIN MORE MEMORY.
*
E$FSP EQU * 15 PERCENT
EJC
*
* DEFINITIONS OF CODES FOR LETTERS
*
CH$LA EQU * LETTER A
CH$LB EQU * LETTER B
CH$LC EQU * LETTER C
CH$LD EQU * LETTER D
CH$LE EQU * LETTER E
CH$LF EQU * LETTER F
CH$LG EQU * LETTER G
CH$LH EQU * LETTER H
CH$LI EQU * LETTER I
CH$LJ EQU * LETTER J
CH$LK EQU * LETTER K
CH$LL EQU * LETTER L
CH$LM EQU * LETTER M
CH$LN EQU * LETTER N
CH$LO EQU * LETTER O
CH$LP EQU * LETTER P
CH$LQ EQU * LETTER Q
CH$LR EQU * LETTER R
CH$LS EQU * LETTER S
CH$LT EQU * LETTER T
CH$LU EQU * LETTER U
CH$LV EQU * LETTER V
CH$LW EQU * LETTER W
CH$LX EQU * LETTER X
CH$LY EQU * LETTER Y
CH$L$ EQU * LETTER Z
*
* DEFINITIONS OF CODES FOR DIGITS
*
CH$D0 EQU * DIGIT 0
CH$D1 EQU * DIGIT 1
CH$D2 EQU * DIGIT 2
CH$D3 EQU * DIGIT 3
CH$D4 EQU * DIGIT 4
CH$D5 EQU * DIGIT 5
CH$D6 EQU * DIGIT 6
CH$D7 EQU * DIGIT 7
CH$D8 EQU * DIGIT 8
CH$D9 EQU * DIGIT 9
EJC
*
* DEFINITIONS OF CODES FOR SPECIAL CHARACTERS
*
* THE NAMES OF THESE CHARACTERS ARE RELATED TO THEIR
* ORIGINAL REPRESENTATION IN THE EBCDIC SET CORRESPONDING
* TO THE DESCRIPTION IN STANDARD SNOBOL4 MANUALS AND TEXTS.
*
CH$AM EQU * KEYWORD OPERATOR (AMPERSAND)
CH$AS EQU * MULTIPLICATION SYMBOL (ASTERISK)
CH$AT EQU * CURSOR POSITION OPERATOR (AT)
CH$BB EQU * LEFT ARRAY BRACKET (LESS THAN)
CH$BL EQU * BLANK
CH$BR EQU * ALTERNATION OPERATOR (VERTICAL BAR)
CH$CL EQU * GOTO SYMBOL (COLON)
CH$CM EQU * COMMA
CH$DL EQU * INDIRECTION OPERATOR (DOLLAR)
CH$DT EQU * NAME OPERATOR (DOT)
CH$DQ EQU * DOUBLE QUOTE
CH$EQ EQU * EQUAL SIGN
CH$EX EQU * EXPONENTIATION OPERATOR (EXCLM)
CH$MN EQU * MINUS SIGN
CH$NM EQU * NUMBER SIGN
CH$NT EQU * NEGATION OPERATOR (NOT)
CH$PC EQU * PERCENT
CH$PL EQU * PLUS SIGN
CH$PP EQU * LEFT PARENTHESIS
CH$RB EQU * RIGHT ARRAY BRACKET (GRTR THAN)
CH$RP EQU * RIGHT PARENTHESIS
CH$QU EQU * INTERROGATION OPERATOR (QUESTION)
CH$SL EQU * SLASH
CH$SM EQU * SEMICOLON
CH$SQ EQU * SINGLE QUOTE
CH$UN EQU * SPECIAL IDENTIFIER CHAR (UNDERLINE)
CH$OB EQU * OPENING BRACKET
CH$CB EQU * CLOSING BRACKET
EJC
*
* REMAINING CHARS ARE OPTIONAL ADDITIONS TO THE STANDARDS.
* THEY ARE ALL UNDER CONDITIONAL ASSEMBLY.
.IF .CAHT
*
* TAB CHARACTERS - SYNTACTICALLY EQUIVALENT TO BLANK
*
CH$HT EQU * HORIZONTAL TAB
.FI
.IF .CAVT
CH$VT EQU * VERTICAL TAB
.FI
.IF .CASL
*
* LOWER CASE OR SHIFTED CASE ALPHABETIC CHARS
*
CH$$A EQU * SHIFTED A
CH$$B EQU * SHIFTED B
CH$$C EQU * SHIFTED C
CH$$D EQU * SHIFTED D
CH$$E EQU * SHIFTED E
CH$$F EQU * SHIFTED F
CH$$G EQU * SHIFTED G
CH$$H EQU * SHIFTED H
CH$$I EQU * SHIFTED I
CH$$J EQU * SHIFTED J
CH$$K EQU * SHIFTED K
CH$$L EQU * SHIFTED L
CH$$M EQU * SHIFTED M
CH$$N EQU * SHIFTED N
CH$$O EQU * SHIFTED O
CH$$P EQU * SHIFTED P
CH$$Q EQU * SHIFTED Q
CH$$R EQU * SHIFTED R
CH$$S EQU * SHIFTED S
CH$$T EQU * SHIFTED T
CH$$U EQU * SHIFTED U
CH$$V EQU * SHIFTED V
CH$$W EQU * SHIFTED W
CH$$X EQU * SHIFTED X
CH$$Y EQU * SHIFTED Y
CH$$$ EQU * SHIFTED Z
.IF .CASL
DFA$A EQU CH$$A-CH$LA DIFF BETWEEN LC AND UC LETTERS
.FI
.FI
EJC
*
* DATA BLOCK FORMATS AND DEFINITIONS
*
* THE FOLLOWING SECTIONS DESCRIBE THE DETAILED FORMAT OF
* ALL POSSIBLE DATA BLOCKS IN STATIC AND DYNAMIC MEMORY.
*
* EVERY BLOCK HAS A NAME OF THE FORM XXBLK WHERE XX IS A
* UNIQUE TWO CHARACTER IDENTIFIER. THE FIRST WORD OF EVERY
* BLOCK MUST CONTAIN A POINTER TO A PROGRAM LOCATION IN THE
* INTERPRETOR WHICH IS IMMEDIATELY PRECEDED BY AN ADDRESS
* CONSTANT CONTAINING THE VALUE BL$XX WHERE XX IS THE BLOCK
* IDENTIFIER. THIS PROVIDES A UNIFORM MECHANISM FOR
* DISTINGUISHING BETWEEN THE VARIOUS BLOCK TYPES.
*
* IN SOME CASES, THE CONTENTS OF THE FIRST WORD IS CONSTANT
* FOR A GIVEN BLOCK TYPE AND MERELY SERVES AS A POINTER
* TO THE IDENTIFYING ADDRESS CONSTANT. HOWEVER, IN OTHER
* CASES THERE ARE SEVERAL POSSIBILITIES FOR THE FIRST
* WORD IN WHICH CASE EACH OF THE SEVERAL PROGRAM ENTRY
* POINTS MUST BE PRECEDED BY THE APPROPRIATE CONSTANT.
*
* IN EACH BLOCK, SOME OF THE FIELDS ARE RELOCATABLE. THIS
* MEANS THAT THEY MAY CONTAIN A POINTER TO ANOTHER BLOCK
* IN THE DYNAMIC AREA. (TO BE MORE PRECISE, IF THEY CONTAIN
* A POINTER WITHIN THE DYNAMIC AREA, THEN IT IS A POINTER
* TO A BLOCK). SUCH FIELDS MUST BE MODIFIED BY THE GARBAGE
* COLLECTOR (PROCEDURE GBCOL) WHENEVER BLOCKS ARE COMPACTED
* IN THE DYNAMIC REGION. THE GARBAGE COLLECTOR (ACTUALLY
* PROCEDURE GBCPF) REQUIRES THAT ALL SUCH RELOCATABLE
* FIELDS IN A BLOCK MUST BE CONTIGUOUS.
EJC
*
* THE DESCRIPTION FORMAT USES THE FOLLOWING SCHEME.
*
* 1) BLOCK TITLE AND TWO CHARACTER IDENTIFIER
*
* 2) DESCRIPTION OF BASIC USE OF BLOCK AND INDICATION
* OF CIRCUMSTANCES UNDER WHICH IT IS CONSTRUCTED.
*
* 3) PICTURE OF THE BLOCK FORMAT. IN THESE PICTURES LOW
* MEMORY ADDRESSES ARE AT THE TOP OF THE PAGE. FIXED
* LENGTH FIELDS ARE SURROUNDED BY I (LETTER I). FIELDS
* WHICH ARE FIXED LENGTH BUT WHOSE LENGTH IS DEPENDENT
* ON A CONFIGURATION PARAMETER ARE SURROUNDED BY *
* (ASTERISK). VARIABLE LENGTH FIELDS ARE SURROUNDED
* BY / (SLASH).
*
* 4) DEFINITION OF SYMBOLIC OFFSETS TO FIELDS IN
* BLOCK AND OF THE SIZE OF THE BLOCK IF FIXED LENGTH
* OR OF THE SIZE OF THE FIXED LENGTH FIELDS IF THE
* BLOCK IS VARIABLE LENGTH.
* NOTE THAT SOME ROUTINES SUCH AS GBCPF ASSUME
* CERTAIN OFFSETS ARE EQUAL. THE DEFINITIONS
* GIVEN HERE ENFORCE THIS. MAKE CHANGES TO
* THEM ONLY WITH DUE CARE.
*
* DEFINITIONS OF COMMON OFFSETS
*
OFFS1 EQU 1
OFFS2 EQU 2
OFFS3 EQU 3
*
* 5) DETAILED COMMENTS ON THE SIGNIFICANCE AND FORMATS
* OF THE VARIOUS FIELDS.
*
* THE ORDER IS ALPHABETICAL BY IDENTIFICATION CODE.
EJC
*
* DEFINITIONS OF BLOCK CODES
*
* THIS TABLE PROVIDES A UNIQUE IDENTIFICATION CODE FOR
* EACH SEPARATE BLOCK TYPE. THE FIRST WORD OF A BLOCK IN
* THE DYNAMIC AREA ALWAYS CONTAINS THE ADDRESS OF A PROGRAM
* ENTRY POINT. THE BLOCK CODE IS USED AS THE ENTRY POINT ID
* THE ORDER OF THESE CODES DICTATES THE ORDER OF THE TABLE
* USED BY THE DATATYPE FUNCTION (SCNMT IN THE CONSTANT SEC)
*
* BLOCK CODES FOR ACCESSIBLE DATATYPES
*
BL$AR EQU 0 ARBLK ARRAY
.IF .CNBF
BL$CD EQU BL$AR+1 CDBLK CODE
.ELSE
BL$BC EQU BL$AR+1 BCBLK BUFFER
BL$CD EQU BL$BC+1 CDBLK CODE
.FI
BL$EX EQU BL$CD+1 EXBLK EXPRESSION
BL$IC EQU BL$EX+1 ICBLK INTEGER
BL$NM EQU BL$IC+1 NMBLK NAME
BL$P0 EQU BL$NM+1 P0BLK PATTERN
BL$P1 EQU BL$P0+1 P1BLK PATTERN
BL$P2 EQU BL$P1+1 P2BLK PATTERN
.IF .CNRA
BL$SC EQU BL$P2+1 SCBLK STRING
.ELSE
BL$RC EQU BL$P2+1 RCBLK REAL
BL$SC EQU BL$RC+1 SCBLK STRING
.FI
BL$SE EQU BL$SC+1 SEBLK EXPRESSION
BL$TB EQU BL$SE+1 TBBLK TABLE
BL$VC EQU BL$TB+1 VCBLK ARRAY
BL$XN EQU BL$VC+1 XNBLK EXTERNAL
BL$XR EQU BL$XN+1 XRBLK EXTERNAL
BL$PD EQU BL$XR+1 PDBLK PROGRAM DEFINED DATATYPE
*
BL$$D EQU BL$PD+1 NUMBER OF BLOCK CODES FOR DATA
*
* OTHER BLOCK CODES
*
BL$TR EQU BL$PD+1 TRBLK
.IF .CNBF
BL$CC EQU BL$TR+1 CCBLK
.ELSE
BL$BF EQU BL$TR+1 BFBLK
BL$CC EQU BL$BF+1 CCBLK
.FI
BL$CM EQU BL$CC+1 CMBLK
BL$CO EQU BL$CM+1 COBLK
BL$CT EQU BL$CO+1 CTBLK
BL$DF EQU BL$CT+1 DFBLK
BL$EF EQU BL$DF+1 EFBLK
BL$EV EQU BL$EF+1 EVBLK
BL$FF EQU BL$EV+1 FFBLK
BL$KV EQU BL$FF+1 KVBLK
BL$PF EQU BL$KV+1 PFBLK
BL$TE EQU BL$PF+1 TEBLK
*
BL$$I EQU 0 DEFAULT IDENTIFICATION CODE
BL$$T EQU BL$TR+1 CODE FOR DATA OR TRACE BLOCK
BL$$$ EQU BL$TE+1 NUMBER OF BLOCK CODES
EJC
*
* FIELD REFERENCES
*
* REFERENCES TO THE FIELDS OF DATA BLOCKS ARE SYMBOLIC
* (I.E. USE THE SYMBOLIC OFFSETS) WITH THE FOLLOWING
* EXCEPTIONS.
*
* 1) REFERENCES TO THE FIRST WORD ARE USUALLY NOT
* SYMBOLIC SINCE THEY USE THE (X) OPERAND FORMAT.
*
* 2) THE CODE WHICH CONSTRUCTS A BLOCK IS OFTEN NOT
* SYMBOLIC AND SHOULD BE CHANGED IF THE CORRESPONDING
* BLOCK FORMAT IS MODIFIED.
*
* 3) THE PLC AND PSC INSTRUCTIONS IMPLY AN OFFSET
* CORRESPONDING TO THE DEFINITION OF CFP$F.
*
* 4) THERE ARE NON-SYMBOLIC REFERENCES (EASILY CHANGED)
* IN THE GARBAGE COLLECTOR (PROCEDURES GBCPF, BLKLN).
*
* 5) THE FIELDS IDVAL, FARGS APPEAR IN SEVERAL BLOCKS
* AND ANY CHANGES MUST BE MADE IN PARALLEL TO ALL
* BLOCKS CONTAINING THE FIELDS. THE ACTUAL REFERENCES
* TO THESE FIELDS ARE SYMBOLIC WITH THE ABOVE
* LISTED EXCEPTIONS.
*
* 6) SEVERAL SPOTS IN THE CODE ASSUME THAT THE
* DEFINITIONS OF THE FIELDS VRVAL, TEVAL, TRNXT ARE
* THE SAME (THESE ARE SECTIONS OF CODE WHICH SEARCH
* OUT ALONG A TRBLK CHAIN FROM A VARIABLE).
*
* 7) REFERENCES TO THE FIELDS OF AN ARRAY BLOCK IN THE
* ARRAY REFERENCE ROUTINE ARREF ARE NON-SYMBOLIC.
*
* APART FROM THE EXCEPTIONS LISTED, REFERENCES ARE SYMBOLIC
* AS FAR AS POSSIBLE AND MODIFYING THE ORDER OR NUMBER
* OF FIELDS WILL NOT REQUIRE CHANGES.
EJC
*
* COMMON FIELDS FOR FUNCTION BLOCKS
*
* BLOCKS WHICH REPRESENT CALLABLE FUNCTIONS HAVE TWO
* COMMON FIELDS AT THE START OF THE BLOCK AS FOLLOWS.
*
* +------------------------------------+
* I FCODE I
* +------------------------------------+
* I FARGS I
* +------------------------------------+
* / /
* / REST OF FUNCTION BLOCK /
* / /
* +------------------------------------+
*
FCODE EQU 0 POINTER TO CODE FOR FUNCTION
FARGS EQU 1 NUMBER OF ARGUMENTS
*
* FCODE IS A POINTER TO THE LOCATION IN THE INTERPRETOR
* PROGRAM WHICH PROCESSES THIS TYPE OF FUNCTION CALL.
*
* FARGS IS THE EXPECTED NUMBER OF ARGUMENTS. THE ACTUAL
* NUMBER OF ARGUMENTS IS ADJUSTED TO THIS AMOUNT BY
* DELETING EXTRA ARGUMENTS OR SUPPLYING TRAILING NULLS
* FOR MISSING ONES BEFORE TRANSFERRING THOUGH FCODE.
* A VALUE OF 999 MAY BE USED IN THIS FIELD TO INDICATE A
* VARIABLE NUMBER OF ARGUMENTS (SEE SVBLK FIELD SVNAR).
*
* THE BLOCK TYPES WHICH FOLLOW THIS SCHEME ARE.
*
* FFBLK FIELD FUNCTION
* DFBLK DATATYPE FUNCTION
* PFBLK PROGRAM DEFINED FUNCTION
* EFBLK EXTERNAL LOADED FUNCTION
EJC
*
* IDENTIFICATION FIELD
*
*
* ID FIELD
*
* CERTAIN PROGRAM ACCESSIBLE OBJECTS (THOSE WHICH CONTAIN
* OTHER DATA VALUES AND CAN BE COPIED) ARE GIVEN A UNIQUE
* IDENTIFICATION NUMBER (SEE EXSID). THIS ID VALUE IS AN
* ADDRESS INTEGER VALUE WHICH IS ALWAYS STORED IN WORD TWO.
*
IDVAL EQU 1 ID VALUE FIELD
*
* THE BLOCKS CONTAINING AN IDVAL FIELD ARE.
*
* ARBLK ARRAY
* PDBLK PROGRAM DEFINED DATATYPE
* TBBLK TABLE
* VCBLK VECTOR BLOCK (ARRAY)
*
* NOTE THAT A ZERO IDVAL MEANS THAT THE BLOCK IS ONLY
* HALF BUILT AND SHOULD NOT BE DUMPED (SEE DUMPR).
EJC
*
* ARRAY BLOCK (ARBLK)
*
* AN ARRAY BLOCK REPRESENTS AN ARRAY VALUE OTHER THAN ONE
* WITH ONE DIMENSION WHOSE LOWER BOUND IS ONE (SEE VCBLK).
* AN ARBLK IS BUILT WITH A CALL TO THE FUNCTIONS CONVERT
* (S$CNV) OR ARRAY (S$ARR).
*
* +------------------------------------+
* I ARTYP I
* +------------------------------------+
* I IDVAL I
* +------------------------------------+
* I ARLEN I
* +------------------------------------+
* I AROFS I
* +------------------------------------+
* I ARNDM I
* +------------------------------------+
* * ARLBD *
* +------------------------------------+
* * ARDIM *
* +------------------------------------+
* * *
* * ABOVE 2 FLDS REPEATED FOR EACH DIM *
* * *
* +------------------------------------+
* I ARPRO I
* +------------------------------------+
* / /
* / ARVLS /
* / /
* +------------------------------------+
EJC
*
* ARRAY BLOCK (CONTINUED)
*
ARTYP EQU 0 POINTER TO DUMMY ROUTINE B$ART
ARLEN EQU IDVAL+1 LENGTH OF ARBLK IN BAUS
AROFS EQU ARLEN+1 OFFSET IN ARBLK TO ARPRO FIELD
ARNDM EQU AROFS+1 NUMBER OF DIMENSIONS
ARLBD EQU ARNDM+1 LOW BOUND (FIRST SUBSCRIPT)
ARDIM EQU ARLBD+CFP$I DIMENSION (FIRST SUBSCRIPT)
ARLB2 EQU ARDIM+CFP$I LOW BOUND (SECOND SUBSCRIPT)
ARDM2 EQU ARLB2+CFP$I DIMENSION (SECOND SUBSCRIPT)
ARPRO EQU ARDIM+CFP$I ARRAY PROTOTYPE (ONE DIMENSION)
ARVLS EQU ARPRO+1 START OF VALUES (ONE DIMENSION)
ARPR2 EQU ARDM2+CFP$I ARRAY PROTOTYPE (TWO DIMENSIONS)
ARVL2 EQU ARPR2+1 START OF VALUES (TWO DIMENSIONS)
ARSI$ EQU ARLBD NUMBER OF STANDARD FIELDS IN BLOCK
ARDMS EQU ARLB2-ARLBD SIZE OF INFO FOR ONE SET OF BOUNDS
*
* THE BOUNDS AND DIMENSION FIELDS ARE SIGNED INTEGER
* VALUES AND EACH OCCUPY CFP$I WORDS IN THE ARBLK.
*
* THE LENGTH OF AN ARBLK IN BAUS MAY NOT EXCEED MXLEN.
* THIS IS REQUIRED TO KEEP NAME OFFSETS GARBAGE COLLECTABLE
*
* THE ACTUAL VALUES ARE ARRANGED IN ROW-WISE ORDER AND
* CAN CONTAIN A DATA POINTER OR A POINTER TO A TRBLK.
.IF .CNBF
.ELSE
EJC
* BUFFER CONTROL BLOCK (BCBLK)
*
* A BCBLK IS BUILT FOR EVERY BFBLK.
*
* +------------------------------------+
* I BCTYP I
* +------------------------------------+
* I IDVAL I
* +------------------------------------+
* I BCLEN I
* +------------------------------------+
* I BCBUF I
* +------------------------------------+
*
BCTYP EQU 0 PTR TO DUMMY ROUTINE B$BCT
BCLEN EQU IDVAL+1 DEFINED BUFFER LENGTH
BCBUF EQU BCLEN+1 PTR TO BFBLK
BCSI$ EQU BCBUF+1 SIZE OF BCBLK
*
* A BCBLK IS AN INDIRECT CONTROL HEADER FOR BFBLK.
* THE REASON FOR NOT STORING THIS DATA DIRECTLY
* IN THE RELATED BFBLK IS SO THAT THE BFBLK CAN
* MAINTAIN THE SAME SKELETAL STRUCTURE AS AN SCBLK
* THUS FACILITATING TRANSPARENT STRING OPERATIONS
* (FOR THE MOST PART). SPECIFICALLY, CFP$F IS THE
* SAME FOR A BFBLK AS FOR AN SCBLK. BY CONVENTION,
* WHEREEVER A BUFFER VALUE IS EMPLOYED, THE BCBLK
* IS POINTED TO.
*
* THE CORRESPONDING BFBLK IS POINTED TO BY THE
* BCBUF POINTER IN THE BCBLK.
*
* BCLEN IS THE CURRENT DEFINED SIZE OF THE CHARACTER
* ARRAY IN THE BFBLK. CHARACTERS FOLLOWING THE OFFSET
* OF BCLEN ARE UNDEFINED.
*
EJC
*
* STRING BUFFER BLOCK (BFBLK)
*
* A BFBLK IS BUILT BY A CALL TO BUFFER(...)
*
* +------------------------------------+
* I BFTYP I
* +------------------------------------+
* I BFALC I
* +------------------------------------+
* / /
* / BFCHR /
* / /
* +------------------------------------+
*
BFTYP EQU 0 PTR TO DUMMY ROUTINE B$BFT
BFALC EQU BFTYP+1 ALLOCATED SIZE OF BUFFER
BFCHR EQU BFALC+1 CHARACTERS OF STRING
BFSI$ EQU BFCHR SIZE OF STANDARD FIELDS IN BFBLK
*
* THE CHARACTERS IN THE BUFFER ARE STORED LEFT JUSTIFIED.
* THE FINAL WORD OF DEFINED CHARACTERS IS ALWAYS ZERO
* (CHARACTER) PADDED. ANY TRAILING ALLOCATION PAST THE
* WORD CONTAINING THE LAST CHARACTER CONTAINS
* UNPREDICTABLE CONTENTS AND IS NEVER REFERENCED.
*
* NOTE THAT THE OFFSET TO THE CHARACTERS OF THE STRING
* IS GIVEN BY CFP$F, AS WITH AN SCBLK. HOWEVER, THE
* OFFSET WHICH IS OCCUPIED BY THE LENGTH FOR AN SCBLK
* IS THE TOTAL CHAR SPACE FOR BFBLKS, AND ROUTINES WHICH
* DEAL WITH BOTH MUST ACCOUNT FOR THIS DIFFERENCE.
*
* THE VALUE OF BFALC MAY NOT EXCEED MXLEN. THE VALUE OF
* BCLEN IS ALWAYS LESS THAN OR EQUAL TO BFALC.
*
.FI
EJC
*
* CODE CONSTRUCTION BLOCK (CCBLK)
*
* AT ANY ONE MOMENT THERE IS AT MOST ONE CCBLK INTO
* WHICH THE COMPILER IS CURRENTLY STORING CODE (CDWRD).
*
* +------------------------------------+
* I CCTYP I
* +------------------------------------+
* I CCLEN I
* +------------------------------------+
* I CCUSE I
* +------------------------------------+
* / /
* / CCCOD /
* / /
* +------------------------------------+
*
CCTYP EQU 0 POINTER TO DUMMY ROUTINE B$CCT
CCLEN EQU CCTYP+1 LENGTH OF CCBLK IN BAUS
CCUSE EQU CCLEN+1 OFFSET PAST LAST USED WORD (BAUS)
CCCOD EQU CCUSE+1 START OF GENERATED CODE IN BLOCK
*
* THE REASON THAT THE CCBLK IS A SEPARATE BLOCK TYPE FROM
* THE USUAL CDBLK IS THAT THE GARBAGE COLLECTOR MUST
* ONLY PROCESS THOSE FIELDS WHICH HAVE BEEN SET (SEE GBCPF)
EJC
*
* CODE BLOCK (CDBLK)
*
* A CODE BLOCK IS BUILT FOR EACH STATEMENT COMPILED DURING
* THE INITIAL COMPILATION OR BY SUBSEQUENT CALLS TO CODE.
*
* +------------------------------------+
* I CDJMP I
* +------------------------------------+
* I CDSTM I
* +------------------------------------+
* I CDLEN I
* +------------------------------------+
* I CDFAL I
* +------------------------------------+
* / /
* / CDCOD /
* / /
* +------------------------------------+
*
CDJMP EQU 0 PTR TO ROUTINE TO EXECUTE STATEMENT
CDSTM EQU CDJMP+1 STATEMENT NUMBER
CDLEN EQU OFFS2 LENGTH OF CDBLK IN BAUS
CDFAL EQU OFFS3 FAILURE EXIT (SEE BELOW)
CDCOD EQU CDFAL+1 EXECUTABLE PSEUDO-CODE
CDSI$ EQU CDCOD NUMBER OF STANDARD FIELDS IN CDBLK
*
* CDSTM IS THE STATEMENT NUMBER OF THE CURRENT STATEMENT.
*
* CDJMP, CDFAL ARE SET AS FOLLOWS.
*
* 1) IF THE FAILURE EXIT IS THE NEXT STATEMENT
*
* CDJMP = B$CDS
* CDFAL = PTR TO CDBLK FOR NEXT STATEMENT
*
* 2) IF THE FAILURE EXIT IS A SIMPLE LABEL NAME
*
* CDJMP = B$CDS
* CDFAL IS A PTR TO THE VRTRA FIELD OF THE VRBLK
*
* 3) IF THERE IS NO FAILURE EXIT (-NOFAIL MODE)
*
* CDJMP = B$CDS
* CDFAL = O$UNF
*
* 4) IF THE FAILURE EXIT IS COMPLEX OR DIRECT
*
* CDJMP = B$CDC
* CDFAL IS THE OFFSET TO THE O$GOF WORD
EJC
*
* CODE BLOCK (CONTINUED)
*
* CDCOD IS THE START OF THE ACTUAL CODE. FIRST WE DESCRIBE
* THE CODE GENERATED FOR AN EXPRESSION. IN AN EXPRESSION,
* ELEMENTS ARE FETCHED BY NAME OR BY VALUE. FOR EXAMPLE,
* THE BINARY EQUAL OPERATOR FETCHES ITS LEFT ARGUMENT
* BY NAME AND ITS RIGHT ARGUMENT BY VALUE. THESE TWO
* CASES GENERATE QUITE DIFFERENT CODE AND ARE DESCRIBED
* SEPARATELY. FIRST WE CONSIDER THE CODE BY VALUE CASE.
*
* GENERATION OF CODE BY VALUE FOR EXPRESSIONS ELEMENTS.
*
* EXPRESSION POINTER TO EXBLK OR SEBLK
*
* INTEGER CONSTANT POINTER TO ICBLK
*
* NULL CONSTANT POINTER TO NULLS
*
* PATTERN (RESULTING FROM PREEVALUATION)
* =O$LPT
* POINTER TO P0BLK,P1BLK OR P2BLK
*
* REAL CONSTANT POINTER TO RCBLK
*
* STRING CONSTANT POINTER TO SCBLK
*
* VARIABLE POINTER TO VRGET FIELD OF VRBLK
*
* ADDITION VALUE CODE FOR LEFT OPERAND
* VALUE CODE FOR RIGHT OPERAND
* =O$ADD
*
* AFFIRMATION VALUE CODE FOR OPERAND
* =O$AFF
*
* ALTERNATION VALUE CODE FOR LEFT OPERAND
* VALUE CODE FOR RIGHT OPERAND
* =O$ALT
*
* ARRAY REFERENCE (CASE OF ONE SUBSCRIPT)
* VALUE CODE FOR ARRAY OPERAND
* VALUE CODE FOR SUBSCRIPT OPERAND
* =O$AOV
*
* (CASE OF MORE THAN ONE SUBSCRIPT)
* VALUE CODE FOR ARRAY OPERAND
* VALUE CODE FOR FIRST SUBSCRIPT
* VALUE CODE FOR SECOND SUBSCRIPT
* ...
* VALUE CODE FOR LAST SUBSCRIPT
* =O$AMV
* NUMBER OF SUBSCRIPTS
EJC
*
* CODE BLOCK (CONTINUED)
*
* ASSIGNMENT (TO NATURAL VARIABLE)
* VALUE CODE FOR RIGHT OPERAND
* POINTER TO VRSTO FIELD OF VRBLK
*
* (TO ANY OTHER VARIABLE)
* NAME CODE FOR LEFT OPERAND
* VALUE CODE FOR RIGHT OPERAND
* =O$ASS
*
* COMPILE ERROR =O$CER
*
*
* COMPLEMENTATION VALUE CODE FOR OPERAND
* =O$COM
*
* CONCATENATION (CASE OF PRED FUNC LEFT OPERAND)
* VALUE CODE FOR LEFT OPERAND
* =O$POP
* VALUE CODE FOR RIGHT OPERAND
*
* (ALL OTHER CASES)
* VALUE CODE FOR LEFT OPERAND
* VALUE CODE FOR RIGHT OPERAND
* =O$CNC
*
* CURSOR ASSIGNMENT NAME CODE FOR OPERAND
* =O$CAS
*
* DIVISION VALUE CODE FOR LEFT OPERAND
* VALUE CODE FOR RIGHT OPERAND
* =O$DVD
*
* EXPONENTIATION VALUE CODE FOR LEFT OPERAND
* VALUE CODE FOR RIGHT OPERAND
* =O$EXP
*
* FUNCTION CALL (CASE OF CALL TO SYSTEM FUNCTION)
* VALUE CODE FOR FIRST ARGUMENT
* VALUE CODE FOR SECOND ARGUMENT
* ...
* VALUE CODE FOR LAST ARGUMENT
* POINTER TO SVFNC FIELD OF SVBLK
*
EJC
*
* CODE BLOCK (CONTINUED)
*
* FUNCTION CALL (CASE OF NON-SYSTEM FUNCTION 1 ARG)
* VALUE CODE FOR ARGUMENT
* =O$FNS
* POINTER TO VRBLK FOR FUNCTION
*
* (NON-SYSTEM FUNCTION, GT 1 ARG)
* VALUE CODE FOR FIRST ARGUMENT
* VALUE CODE FOR SECOND ARGUMENT
* ...
* VALUE CODE FOR LAST ARGUMENT
* =O$FNC
* NUMBER OF ARGUMENTS
* POINTER TO VRBLK FOR FUNCTION
*
* IMMEDIATE ASSIGNMENT VALUE CODE FOR LEFT OPERAND
* NAME CODE FOR RIGHT OPERAND
* =O$IMA
*
* INDIRECTION VALUE CODE FOR OPERAND
* =O$INV
*
* INTERROGATION VALUE CODE FOR OPERAND
* =O$INT
*
* KEYWORD REFERENCE NAME CODE FOR OPERAND
* =O$KWV
*
* MULTIPLICATION VALUE CODE FOR LEFT OPERAND
* VALUE CODE FOR RIGHT OPERAND
* =O$MLT
*
* NAME REFERENCE (NATURAL VARIABLE CASE)
* POINTER TO NMBLK FOR NAME
*
* (ALL OTHER CASES)
* NAME CODE FOR OPERAND
* =O$NAM
*
* NEGATION =O$NTA
* CDBLK OFFSET OF O$NTC WORD
* VALUE CODE FOR OPERAND
* =O$NTB
* =O$NTC
EJC
*
* CODE BLOCK (CONTINUED)
*
* PATTERN ASSIGNMENT VALUE CODE FOR LEFT OPERAND
* NAME CODE FOR RIGHT OPERAND
* =O$PAS
*
* PATTERN MATCH VALUE CODE FOR LEFT OPERAND
* VALUE CODE FOR RIGHT OPERAND
* =O$PMV
*
* PATTERN REPLACEMENT NAME CODE FOR SUBJECT
* VALUE CODE FOR PATTERN
* =O$PMN
* VALUE CODE FOR REPLACEMENT
* =O$RPL
*
* SELECTION (FOR FIRST ALTERNATIVE)
* =O$SLA
* CDBLK OFFSET TO NEXT O$SLC WORD
* VALUE CODE FOR FIRST ALTERNATIVE
* =O$SLB
* CDBLK OFFSET PAST ALTERNATIVES
*
* (FOR SUBSEQUENT ALTERNATIVES)
* =O$SLC
* CDBLK OFFSET TO NEXT O$SLC,O$SLD
* VALUE CODE FOR ALTERNATIVE
* =O$SLB
* OFFSET IN CDBLK PAST ALTERNATIVES
*
* (FOR LAST ALTERNATIVE)
* =O$SLD
* VALUE CODE FOR LAST ALTERNATIVE
*
* SUBTRACTION VALUE CODE FOR LEFT OPERAND
* VALUE CODE FOR RIGHT OPERAND
* =O$SUB
EJC
*
* CODE BLOCK (CONTINUED)
*
* GENERATION OF CODE BY NAME FOR EXPRESSION ELEMENTS.
*
* VARIABLE =O$LVN
* POINTER TO VRBLK
*
* EXPRESSION (CASE OF *NATURAL VARIABLE)
* =O$LVN
* POINTER TO VRBLK
*
* (ALL OTHER CASES)
* =O$LEX
* POINTER TO EXBLK
*
*
* ARRAY REFERENCE (CASE OF ONE SUBSCRIPT)
* VALUE CODE FOR ARRAY OPERAND
* VALUE CODE FOR SUBSCRIPT OPERAND
* =O$AON
*
* (CASE OF MORE THAN ONE SUBSCRIPT)
* VALUE CODE FOR ARRAY OPERAND
* VALUE CODE FOR FIRST SUBSCRIPT
* VALUE CODE FOR SECOND SUBSCRIPT
* ...
* VALUE CODE FOR LAST SUBSCRIPT
* =O$AMN
* NUMBER OF SUBSCRIPTS
*
* COMPILE ERROR =O$CER
*
* FUNCTION CALL (SAME CODE AS FOR VALUE CALL)
* =O$FNE
*
* INDIRECTION VALUE CODE FOR OPERAND
* =O$INN
*
* KEYWORD REFERENCE NAME CODE FOR OPERAND
* =O$KWN
*
* ANY OTHER OPERAND IS AN ERROR IN A NAME POSITION
*
* NOTE THAT IN THIS DESCRIPTION, =O$XXX REFERS TO THE
* GENERATION OF A WORD CONTAINING THE ADDRESS OF ANOTHER
* WORD WHICH CONTAINS THE ENTRY POINT ADDRESS O$XXX.
EJC
*
* CODE BLOCK (CONTINUED)
*
* NOW WE CONSIDER THE OVERALL STRUCTURE OF THE CODE BLOCK
* FOR A STATEMENT WITH POSSIBLE GOTO FIELDS.
*
* FIRST COMES THE CODE FOR THE STATEMENT BODY.
* THE STATEMENT BODY IS AN EXPRESSION TO BE EVALUATED
* BY VALUE ALTHOUGH THE VALUE IS NOT ACTUALLY REQUIRED.
* NORMAL VALUE CODE IS GENERATED FOR THE BODY OF THE
* STATEMENT EXCEPT IN THE CASE OF A PATTERN MATCH BY
* VALUE, IN WHICH CASE THE FOLLOWING IS GENERATED.
*
* VALUE CODE FOR LEFT OPERAND
* VALUE CODE FOR RIGHT OPERAND
* =O$PMS
*
* NEXT WE HAVE THE CODE FOR THE SUCCESS GOTO. THERE ARE
* SEVERAL CASES AS FOLLOWS.
*
* 1) NO SUCCESS GOTO PTR TO CDBLK FOR NEXT STATEMENT
*
* 2) SIMPLE LABEL PTR TO VRTRA FIELD OF VRBLK
*
* 3) COMPLEX GOTO (CODE BY NAME FOR GOTO OPERAND)
* =O$GOC
*
* 4) DIRECT GOTO (CODE BY VALUE FOR GOTO OPERAND)
* =O$GOD
*
* FOLLOWING THIS WE GENERATE CODE FOR THE FAILURE GOTO IF
* IT IS DIRECT OR IF IT IS COMPLEX, SIMPLE FAILURE GOTOS
* HAVING BEEN HANDLED BY AN APPROPRIATE SETTING OF THE
* CDFAL FIELD OF THE CDBLK. THE GENERATED CODE IS ONE
* OF THE FOLLOWING.
*
* 1) COMPLEX FGOTO =O$FIF
* =O$GOF
* NAME CODE FOR GOTO OPERAND
* =O$GOC
*
* 2) DIRECT FGOTO =O$FIF
* =O$GOF
* VALUE CODE FOR GOTO OPERAND
* =O$GOD
*
* AN OPTIMIZATION OCCURS IF THE SUCCESS AND FAILURE GOTOS
* ARE IDENTICAL AND EITHER COMPLEX OR DIRECT. IN THIS CASE,
* NO CODE IS GENERATED FOR THE SUCCESS GOTO AND CONTROL
* IS ALLOWED TO FALL INTO THE FAILURE GOTO ON SUCCESS.
EJC
*
* COMPILER BLOCK (CMBLK)
*
* A COMPILER BLOCK (CMBLK) IS BUILT BY EXPAN TO REPRESENT
* ONE NODE OF A TREE STRUCTURED EXPRESSION REPRESENTATION.
*
* +------------------------------------+
* I CMIDN I
* +------------------------------------+
* I CMLEN I
* +------------------------------------+
* I CMTYP I
* +------------------------------------+
* I CMOPN I
* +------------------------------------+
* / CMVLS OR CMROP /
* / /
* / CMLOP /
* / /
* +------------------------------------+
*
CMIDN EQU 0 POINTER TO DUMMY ROUTINE B$CMT
CMLEN EQU CMIDN+1 LENGTH OF CMBLK IN BAUS
CMTYP EQU CMLEN+1 TYPE (C$XXX, SEE LIST BELOW)
CMOPN EQU CMTYP+1 OPERAND POINTER (SEE BELOW)
CMVLS EQU CMOPN+1 OPERAND VALUE POINTERS (SEE BELOW)
CMROP EQU CMVLS RIGHT (ONLY) OPERATOR OPERAND
CMLOP EQU CMVLS+1 LEFT OPERATOR OPERAND
CMSI$ EQU CMVLS NUMBER OF STANDARD FIELDS IN CMBLK
CMUS$ EQU CMSI$+1 SIZE OF UNARY OPERATOR CMBLK
CMBS$ EQU CMSI$+2 SIZE OF BINARY OPERATOR CMBLK
CMAR1 EQU CMVLS+1 ARRAY SUBSCRIPT POINTERS
*
* THE CMOPN AND CMVLS FIELDS ARE SET AS FOLLOWS
*
* ARRAY REFERENCE CMOPN = PTR TO ARRAY OPERAND
* CMVLS = PTRS TO SUBSCRIPT OPERANDS
*
* FUNCTION CALL CMOPN = PTR TO VRBLK FOR FUNCTION
* CMVLS = PTRS TO ARGUMENT OPERANDS
*
* SELECTION CMOPN = ZERO
* CMVLS = PTRS TO ALTERNATE OPERANDS
*
* UNARY OPERATOR CMOPN = PTR TO OPERATOR DVBLK
* CMROP = PTR TO OPERAND
*
* BINARY OPERATOR CMOPN = PTR TO OPERATOR DVBLK
* CMROP = PTR TO RIGHT OPERAND
* CMLOP = PTR TO LEFT OPERAND
EJC
*
* CMTYP IS SET TO INDICATE THE TYPE OF EXPRESSION ELEMENT
* AS SHOWN BY THE FOLLOWING TABLE OF DEFINITIONS.
*
C$ARR EQU 0 ARRAY REFERENCE
C$FNC EQU C$ARR+1 FUNCTION CALL
C$DEF EQU C$FNC+1 DEFERRED EXPRESSION (UNARY *)
C$IND EQU C$DEF+1 INDIRECTION (UNARY $)
C$KEY EQU C$IND+1 KEYWORD REFERENCE (UNARY AMPERSAND)
C$UBO EQU C$KEY+1 UNDEFINED BINARY OPERATOR
C$UUO EQU C$UBO+1 UNDEFINED UNARY OPERATOR
C$UO$ EQU C$UUO+1 TEST VALUE (=C$UUO+1=C$UBO+2)
C$$NM EQU C$UUO+1 NUMBER OF CODES FOR NAME OPERANDS
*
* THE REMAINING TYPES INDICATE EXPRESSION ELEMENTS WHICH
* CAN ONLY BE EVALUATED BY VALUE (NOT BY NAME).
*
C$BVL EQU C$UUO+1 BINARY OP WITH VALUE OPERANDS
C$UVL EQU C$BVL+1 UNARY OPERATOR WITH VALUE OPERAND
C$ALT EQU C$UVL+1 ALTERNATION (BINARY BAR)
C$CNC EQU C$ALT+1 CONCATENATION
C$CNP EQU C$CNC+1 CONCATENATION, NOT PATTERN MATCH
C$UNM EQU C$CNP+1 UNARY OP WITH NAME OPERAND
C$BVN EQU C$UNM+1 BINARY OP (OPERANDS BY VALUE, NAME)
C$ASS EQU C$BVN+1 ASSIGNMENT
C$INT EQU C$ASS+1 INTERROGATION
C$NEG EQU C$INT+1 NEGATION (UNARY NOT)
C$SEL EQU C$NEG+1 SELECTION
C$PMT EQU C$SEL+1 PATTERN MATCH
*
C$PR$ EQU C$BVN LAST PREEVALUABLE CODE
C$$NV EQU C$PMT+1 NUMBER OF DIFFERENT CMBLK TYPES
EJC
*
* COPY FILE BLOCK (COBLK)
*
* A CHAIN STACK OF COPY BLOCKS IS BUILT FOR EVERY NESTED
* -COPY CONTROL CARD. THE CONTROL BLOCK IS USED TO PRESERVE
* THE INPUT CONTEXT OF THE FILE CONTAINING THE -COPY.
* AS -COPYS ARE ENDED, THESE BLOCKS ARE POPPED OFF THE CHAIN
* AND THE STATE RESTORED. SEE ROUTINES CNCRD, COPND.
*
* +------------------------------------+
* I COTYP I
* +------------------------------------+
* I CONXT I
* +------------------------------------+
* I COIOT I
* +------------------------------------+
* I COTTI I
* +------------------------------------+
* I COCIM I
* +------------------------------------+
* I COSPT I
* +------------------------------------+
* I COSLS I
* +------------------------------------+
* I COSIN I
* +------------------------------------+
* I COSTL I
* +------------------------------------+
*
COTYP EQU 0 POINTER TO DUMMY ROUTINE B$COP
CONXT EQU COTYP+1 POINT TO NEXT (OUTER -COPY) COBLK
COIOT EQU CONXT+1 RECORD IOTAG FOR OSINT
COTTI EQU COIOT+1 RECORD TTINS FLAG
COCIM EQU COTTI+1 RECORD R$CIM COMPILER IMAGE
COSPT EQU COCIM+1 RECORD SCNPT SCAN POINTER
COSLS EQU COSPT+1 RECORD CSWLS LISTING FLAG
COSIN EQU COSLS+1 RECORD CSWIN -INXXX VALUE
COSTL EQU COSIN+1 RECORD R$STL -STITL STRING PTR
COSI$ EQU COSTL+1 SIZE OF COBLK
EJC
*
* CHARACTER TABLE BLOCK (CTBLK)
*
* A CHARACTER TABLE BLOCK IS USED TO HOLD LOGICAL CHARACTER
* TABLES FOR USE WITH ANY,NOTANY,SPAN,BREAK,BREAKX
* PATTERNS. EACH CHARACTER TABLE CAN BE USED TO STORE
* CFP$N DISTINCT TABLES AS BIT COLUMNS. A BIT COLUMN
* ALLOCATED FOR EACH ARGUMENT OF MORE THAN ONE CHARACTER
* IN LENGTH TO ONE OF THE ABOVE LISTED PATTERN PRIMITIVES.
*
* +------------------------------------+
* I CTTYP I
* +------------------------------------+
* * *
* * *
* * CTCHS *
* * *
* * *
* +------------------------------------+
*
CTTYP EQU 0 POINTER TO DUMMY ROUTINE B$CTT
CTCHS EQU CTTYP+1 START OF CHARACTER TABLE WORDS
CTSI$ EQU CTCHS+CFP$A NUMBER OF WORDS IN CTBLK
*
* CTCHS IS CFP$A WORDS LONG AND CONSISTS OF A ONE WORD
* BIT STRING VALUE FOR EACH POSSIBLE CHARACTER IN THE
* INTERNAL ALPHABET. EACH OF THE CFP$N POSSIBLE BITS IN
* A BITSTRING IS USED TO FORM A COLUMN OF BIT INDICATORS.
* A BIT IS SET ON IF THE CHARACTER IS IN THE TABLE AND OFF
* IF THE CHARACTER IS NOT PRESENT.
EJC
*
* DATATYPE FUNCTION BLOCK (DFBLK)
*
* A DATATYPE FUNCTION IS USED TO CONTROL THE CONSTRUCTION
* OF A PROGRAM DEFINED DATATYPE OBJECT. A CALL TO THE
* SYSTEM FUNCTION DATA BUILDS A DFBLK FOR THE DATATYPE NAME
*
* NOTE THAT THESE BLOCKS ARE BUILT IN STATIC BECAUSE PDBLK
* LENGTH IS GOT FROM DFLEN FIELD. IF DFBLK WAS IN DYNAMIC
* STORE THIS WOULD CAUSE TROUBLE DURING PASS TWO OF GARBAGE
* COLLECTION. SCBLK REFERRED TO BY DFNAM FIELD IS ALSO PUT
* IN STATIC SO THAT THERE ARE NO RELOC. FIELDS. THIS CUTS
* GARBAGE COLLECTION TASK APPRECIABLY FOR PDBLKS WHICH ARE
* LIKELY TO BE PRESENT IN LARGE NUMBERS.
*
* +------------------------------------+
* I FCODE I
* +------------------------------------+
* I FARGS I
* +------------------------------------+
* I DFLEN I
* +------------------------------------+
* I DFPDL I
* +------------------------------------+
* I DFNAM I
* +------------------------------------+
* / /
* / DFFLD /
* / /
* +------------------------------------+
*
DFLEN EQU FARGS+1 LENGTH OF DFBLK IN BAUS
DFPDL EQU DFLEN+1 LENGTH OF CORRESPONDING PDBLK
DFNAM EQU DFPDL+1 POINTER TO SCBLK FOR DATATYPE NAME
DFFLD EQU DFNAM+1 START OF VRBLK PTRS FOR FIELD NAMES
DFFLB EQU DFFLD-1 OFFSET BEHIND DFFLD FOR FIELD FUNC
DFSI$ EQU DFFLD NUMBER OF STANDARD FIELDS IN DFBLK
*
* THE FCODE FIELD POINTS TO THE ROUTINE B$DFC
*
* FARGS (THE NUMBER OF ARGUMENTS) IS THE NUMBER OF FIELDS.
EJC
*
* DOPE VECTOR BLOCK (DVBLK)
*
* A DOPE VECTOR IS ASSEMBLED FOR EACH POSSIBLE OPERATOR IN
* THE SNOBOL4 LANGUAGE AS PART OF THE CONSTANT SECTION.
*
* +------------------------------------+
* I DVOPN I
* +------------------------------------+
* I DVTYP I
* +------------------------------------+
* I DVLPR I
* +------------------------------------+
* I DVRPR I
* +------------------------------------+
*
DVOPN EQU 0 ENTRY ADDRESS (PTR TO O$XXX)
DVTYP EQU DVOPN+1 TYPE CODE (C$XXX, SEE CMBLK)
DVLPR EQU DVTYP+1 LEFT PRECEDENCE (LLXXX, SEE BELOW)
DVRPR EQU DVLPR+1 RIGHT PRECEDENCE (RRXXX, SEE BELOW)
DVUS$ EQU DVLPR+1 SIZE OF UNARY OPERATOR DV
DVBS$ EQU DVRPR+1 SIZE OF BINARY OPERATOR DV
DVUBS EQU DVUS$+DVBS$ SIZE OF UNOP + BINOP (SEE SCANE)
*
* THE CONTENTS OF THE DVTYP FIELD IS COPIED INTO THE CMTYP
* FIELD OF THE CMBLK FOR THE OPERATOR IF IT IS USED.
*
* THE CMOPN FIELD OF AN OPERATOR CMBLK POINTS TO THE DVBLK
* ITSELF, PROVIDING THE REQUIRED ENTRY ADDRESS POINTER PTR.
*
* FOR NORMALLY UNDEFINED OPERATORS, THE DVOPN (AND CMOPN)
* FIELDS CONTAIN A WORD OFFSET FROM R$UBA OF THE FUNCTION
* BLOCK POINTER FOR THE OPERATOR (INSTEAD OF O$XXX PTR).
* FOR CERTAIN SPECIAL OPERATORS, THE DVOPN FIELD IS NOT
* REQUIRED AT ALL AND IS ASSEMBLED AS ZERO.
*
* THE LEFT PRECEDENCE IS USED IN COMPARING AN OPERATOR TO
* THE LEFT OF SOME OTHER OPERATOR. IT THEREFORE GOVERNS THE
* PRECEDENCE OF THE OPERATOR TOWARDS ITS RIGHT OPERAND.
*
* THE RIGHT PRECEDENCE IS USED IN COMPARING AN OPERATOR TO
* THE RIGHT OF SOME OTHER OPERATOR. IT THEREFORE GOVERNS
* THE PRECEDENCE OF THE OPERATOR TOWARDS ITS LEFT OPERAND.
*
* HIGHER PRECEDENCE VALUES CORRESPOND TO A TIGHTER BINDING
* CAPABILITY. THUS WE HAVE THE LEFT PRECEDENCE LOWER
* (HIGHER) THAN THE RIGHT PRECEDENCE FOR RIGHT (LEFT)
* ASSOCIATIVE BINARY OPERATORS.
*
* THE LEFT PRECEDENCE OF UNARY OPERATORS IS SET TO AN
* ARBITRARY HIGH VALUE. THE RIGHT VALUE IS NOT REQUIRED AND
* CONSEQUENTLY THE DVRPR FIELD IS OMITTED FOR UNARY OPS.
EJC
*
* TABLE OF OPERATOR PRECEDENCE VALUES
*
RRASS EQU 10 RIGHT EQUAL
LLASS EQU 00 LEFT EQUAL
RRPMT EQU 20 RIGHT QUESTION MARK
LLPMT EQU 30 LEFT QUESTION MARK
RRAMP EQU 40 RIGHT AMPERSAND
LLAMP EQU 50 LEFT AMPERSAND
RRALT EQU 70 RIGHT VERTICAL BAR
LLALT EQU 60 LEFT VERTICAL BAR
RRCNC EQU 90 RIGHT BLANK
LLCNC EQU 80 LEFT BLANK
RRATS EQU 110 RIGHT AT
LLATS EQU 100 LEFT AT
RRPLM EQU 120 RIGHT PLUS, MINUS
LLPLM EQU 130 LEFT PLUS, MINUS
RRNUM EQU 140 RIGHT NUMBER
LLNUM EQU 150 LEFT NUMBER
RRDVD EQU 160 RIGHT SLASH
LLDVD EQU 170 LEFT SLASH
RRMLT EQU 180 RIGHT ASTERISK
LLMLT EQU 190 LEFT ASTERISK
RRPCT EQU 200 RIGHT PERCENT
LLPCT EQU 210 LEFT PERCENT
RREXP EQU 230 RIGHT EXCLAMATION
LLEXP EQU 220 LEFT EXCLAMATION
RRDLD EQU 240 RIGHT DOLLAR, DOT
LLDLD EQU 250 LEFT DOLLAR, DOT
RRNOT EQU 270 RIGHT NOT
LLNOT EQU 260 LEFT NOT
LLUNO EQU 999 LEFT ALL UNARY OPERATORS
*
* PRECEDENCES ARE THE SAME AS IN BTL SNOBOL4 WITH THE
* FOLLOWING EXCEPTIONS.
*
* 1) BINARY QUESTION MARK IS LOWERED AND MADE LEFT ASSOC-
* IATIVE TO REFLECT ITS NEW USE FOR PATTERN MATCHING.
*
* 2) ALTERNATION AND CONCATENATION ARE MADE RIGHT
* ASSOCIATIVE FOR GREATER EFFICIENCY IN PATTERN
* CONSTRUCTION AND MATCHING RESPECTIVELY. THIS CHANGE
* IS TRANSPARENT TO THE SNOBOL4 PROGRAMMER.
*
* 3) THE EQUAL SIGN HAS BEEN ADDED AS A LOW PRECEDENCE
* OPERATOR WHICH IS RIGHT ASSOCIATIVE TO REFLECT ITS
* MORE GENERAL USAGE IN THIS VERSION OF SNOBOL4.
.IF .CNLD
.ELSE
EJC
*
* EXTERNAL FUNCTION BLOCK (EFBLK)
*
* AN EXTERNAL FUNCTION BLOCK IS USED TO CONTROL THE CALLING
* OF AN EXTERNAL FUNCTION. IT IS BUILT BY A CALL TO LOAD.
*
* +------------------------------------+
* I FCODE I
* +------------------------------------+
* I FARGS I
* +------------------------------------+
* I EFLEN I
* +------------------------------------+
* I EFUSE I
* +------------------------------------+
* I EFCOD I
* +------------------------------------+
* I EFVAR I
* +------------------------------------+
* I EFRSL I
* +------------------------------------+
* / /
* / EFTAR /
* / /
* +------------------------------------+
*
EFLEN EQU FARGS+1 LENGTH OF EFBLK IN BAUS
EFUSE EQU EFLEN+1 USE COUNT (FOR OPSYN)
EFCOD EQU EFUSE+1 PTR TO CODE (FROM SYSLD)
EFVAR EQU EFCOD+1 PTR TO ASSOCIATED VRBLK
EFRSL EQU EFVAR+1 RESULT TYPE (SEE BELOW)
EFTAR EQU EFRSL+1 ARGUMENT TYPES (SEE BELOW)
EFSI$ EQU EFTAR NUMBER OF STANDARD FIELDS IN EFBLK
*
* THE FCODE FIELD POINTS TO THE ROUTINE B$EFC.
*
* EFUSE IS USED TO KEEP TRACK OF MULTIPLE USE WHEN OPSYN
* IS EMPLOYED. THE FUNCTION IS AUTOMATICALLY UNLOADED
* WHEN THERE ARE NO MORE REFERENCES TO THE FUNCTION.
*
* EFRSL AND EFTAR ARE TYPE CODES AS FOLLOWS.
*
* 0 TYPE IS UNCONVERTED
* 1 TYPE IS STRING
* 2 TYPE IS INTEGER
* 3 TYPE IS REAL
* 4 TYPE IS BUFFER
.FI
EJC
*
* EXPRESSION VARIABLE BLOCK (EVBLK)
*
* IN THIS VERSION OF SPITBOL, AN EXPRESSION CAN BE USED IN
* ANY POSITION WHICH WOULD NORMALLY EXPECT A NAME (FOR
* EXAMPLE ON THE LEFT SIDE OF EQUALS OR AS THE RIGHT
* ARGUMENT OF BINARY DOT). THIS CORRESPONDS TO THE CREATION
* OF A PSEUDO-VARIABLE WHICH IS REPRESENTED BY A POINTER TO
* AN EXPRESSION VARIABLE BLOCK AS FOLLOWS.
*
* +------------------------------------+
* I EVTYP I
* +------------------------------------+
* I EVEXP I
* +------------------------------------+
* I EVVAR I
* +------------------------------------+
*
EVTYP EQU 0 POINTER TO DUMMY ROUTINE B$EVT
EVEXP EQU EVTYP+1 POINTER TO EXBLK FOR EXPRESSION
EVVAR EQU EVEXP+1 POINTER TO TRBEV DUMMY TRBLK
EVSI$ EQU EVVAR+1 SIZE OF EVBLK
*
* THE NAME OF AN EXPRESSION VARIABLE IS REPRESENTED BY A
* BASE POINTER TO THE EVBLK AND AN OFFSET OF EVVAR. THIS
* VALUE APPEARS TO BE TRAPPED BY THE DUMMY TRBEV BLOCK.
*
* NOTE THAT THERE IS NO NEED TO ALLOW FOR THE CASE OF AN
* EXPRESSION VARIABLE WHICH REFERENCES AN SEBLK SINCE A
* VARIABLE WHICH IS OF THE FORM *VAR IS EQUIVALENT TO VAR.
EJC
*
* EXPRESSION BLOCK (EXBLK)
*
* AN EXPRESSION BLOCK IS BUILT FOR EACH EXPRESSION
* REFERENCED IN A PROGRAM OR CREATED BY EVAL OR CONVERT
* DURING EXECUTION OF A PROGRAM.
*
* +------------------------------------+
* I EXTYP I
* +------------------------------------+
* I EXSTM I
* +------------------------------------+
* I EXLEN I
* +------------------------------------+
* I EXFLC I
* +------------------------------------+
* / /
* / EXCOD /
* / /
* +------------------------------------+
*
EXTYP EQU 0 PTR TO ROUTINE B$EXL TO LOAD EXPR
EXSTM EQU CDSTM STORES STMNT NO. DURING EVALUATION
EXLEN EQU EXSTM+1 LENGTH OF EXBLK IN BAUS
EXFLC EQU EXLEN+1 FAILURE CODE (=O$FEX)
EXCOD EQU EXFLC+1 PSEUDO-CODE FOR EXPRESSION
EXSI$ EQU EXCOD NUMBER OF STANDARD FIELDS IN EXBLK
*
* THERE ARE TWO CASES FOR EXCOD DEPENDING ON WHETHER THE
* EXPRESSION CAN BE EVALUATED BY NAME (SEE DESCRIPTION
* OF CDBLK FOR DETAILS OF CODE FOR EXPRESSIONS).
*
* IF THE EXPRESSION CAN BE EVALUATED BY NAME WE HAVE.
*
* (CODE FOR EXPR BY NAME)
* =O$RNM
*
* IF THE EXPRESSION CAN ONLY BE EVALUATED BY VALUE.
*
* (CODE FOR EXPR BY VALUE)
* =O$RVL
EJC
*
* FIELD FUNCTION BLOCK (FFBLK)
*
* A FIELD FUNCTION BLOCK IS USED TO CONTROL THE SELECTION
* OF A FIELD FROM A PROGRAM DEFINED DATATYPE BLOCK.
* A CALL TO DATA CREATES AN FFBLK FOR EACH FIELD.
*
* +------------------------------------+
* I FCODE I
* +------------------------------------+
* I FARGS I
* +------------------------------------+
* I FFDFP I
* +------------------------------------+
* I FFNXT I
* +------------------------------------+
* I FFOFS I
* +------------------------------------+
*
FFDFP EQU FARGS+1 POINTER TO ASSOCIATED DFBLK
FFNXT EQU FFDFP+1 PTR TO NEXT FFBLK ON CHAIN OR ZERO
FFOFS EQU FFNXT+1 OFFSET (BAUS) TO FIELD IN PDBLK
FFSI$ EQU FFOFS+1 SIZE OF FFBLK IN WORDS
*
* THE FCODE FIELD POINTS TO THE ROUTINE B$FFC.
*
* FARGS ALWAYS CONTAINS ONE.
*
* FFDFP IS USED TO VERIFY THAT THE CORRECT PROGRAM DEFINED
* DATATYPE IS BEING ACCESSED BY THIS CALL.
* FFDFP IS NON-RELOC. BECAUSE DFBLK IS IN STATIC
*
* FFOFS IS USED TO SELECT THE APPROPRIATE FIELD. NOTE THAT
* IT IS AN ACTUAL OFFSET (NOT A FIELD NUMBER)
*
* FFNXT IS USED TO POINT TO THE NEXT FFBLK OF THE SAME NAME
* IN THE CASE WHERE THERE ARE SEVERAL FIELDS OF THE SAME
* NAME FOR DIFFERENT DATATYPES. ZERO MARKS THE END OF CHAIN
EJC
*
* INTEGER CONSTANT BLOCK (ICBLK)
*
* AN ICBLK IS CREATED FOR EVERY INTEGER REFERENCED OR
* CREATED BY A PROGRAM. NOTE HOWEVER THAT CERTAIN INTERNAL
* INTEGER VALUES ARE STORED AS ADDRESSES (E.G. THE LENGTH
* FIELD IN A STRING CONSTANT BLOCK)
*
* +------------------------------------+
* I ICGET I
* +------------------------------------+
* * ICVAL *
* +------------------------------------+
*
ICGET EQU 0 PTR TO ROUTINE B$ICL TO LOAD INT
ICVAL EQU ICGET+1 INTEGER VALUE
ICSI$ EQU ICVAL+CFP$I SIZE OF ICBLK
*
* THE LENGTH OF THE ICVAL FIELD IS CFP$I.
EJC
*
* KEYWORD VARIABLE BLOCK (KVBLK)
*
* A KVBLK IS USED TO REPRESENT A KEYWORD PSEUDO-VARIABLE.
* A KVBLK IS BUILT FOR EACH KEYWORD REFERENCE (KWNAM).
*
* +------------------------------------+
* I KVTYP I
* +------------------------------------+
* I KVVAR I
* +------------------------------------+
* I KVNUM I
* +------------------------------------+
*
KVTYP EQU 0 POINTER TO DUMMY ROUTINE B$KVT
KVVAR EQU KVTYP+1 POINTER TO DUMMY BLOCK TRBKV
KVNUM EQU KVVAR+1 KEYWORD NUMBER
KVSI$ EQU KVNUM+1 SIZE OF KVBLK
*
* THE NAME OF A KEYWORD VARIABLE IS REPRESENTED BY A
* BASE POINTER TO THE KVBLK AND AN OFFSET OF KVVAR. THE
* VALUE APPEARS TO BE TRAPPED BY THE POINTER TO TRBKV.
EJC
*
* NAME BLOCK (NMBLK)
*
* A NAME BLOCK IS USED WHEREVER A NAME MUST BE STORED AS
* A VALUE FOLLOWING USE OF THE UNARY DOT OPERATOR.
*
* +------------------------------------+
* I NMTYP I
* +------------------------------------+
* I NMBAS I
* +------------------------------------+
* I NMOFS I
* +------------------------------------+
*
NMTYP EQU 0 PTR TO ROUTINE B$NML TO LOAD NAME
NMBAS EQU NMTYP+1 BASE POINTER FOR VARIABLE
NMOFS EQU NMBAS+1 OFFSET FOR VARIABLE
NMSI$ EQU NMOFS+1 SIZE OF NMBLK
*
* THE ACTUAL FIELD REPRESENTING THE CONTENTS OF THE NAME
* IS FOUND NMOFS BAUS PAST THE ADDRESS IN NMBAS.
*
* THE NAME IS SPLIT INTO BASE AND OFFSET FORM TO AVOID
* CREATION OF A POINTER INTO THE MIDDLE OF A BLOCK WHICH
* COULD NOT BE HANDLED PROPERLY BY THE GARBAGE COLLECTOR.
*
* A NAME MAY BE BUILT FOR ANY VARIABLE (SEE SECTION ON
* REPRESENTATIONS OF VARIABLES) THIS INCLUDES THE
* CASES OF PSEUDO-VARIABLES.
EJC
*
* PATTERN BLOCK, NO PARAMETERS (P0BLK)
*
* A P0BLK IS USED TO REPRESENT PATTERN NODES WHICH DO
* NOT REQUIRE THE USE OF ANY PARAMETER VALUES.
*
* +------------------------------------+
* I PCODE I
* +------------------------------------+
* I PTHEN I
* +------------------------------------+
*
PCODE EQU 0 PTR TO MATCH ROUTINE (P$XXX)
PTHEN EQU PCODE+1 POINTER TO SUBSEQUENT NODE
PASI$ EQU PTHEN+1 SIZE OF P0BLK
*
* PTHEN POINTS TO THE PATTERN BLOCK FOR THE SUBSEQUENT
* NODE TO BE MATCHED. THIS IS A POINTER TO THE PATTERN
* BLOCK NDNTH IF THERE IS NO SUBSEQUENT (END OF PATTERN)
*
* PCODE IS A POINTER TO THE MATCH ROUTINE FOR THE NODE.
EJC
*
* PATTERN BLOCK (ONE PARAMETER)
*
* A P1BLK IS USED TO REPRESENT PATTERN NODES WHICH
* REQUIRE ONE PARAMETER VALUE.
*
* +------------------------------------+
* I PCODE I
* +------------------------------------+
* I PTHEN I
* +------------------------------------+
* I PARM1 I
* +------------------------------------+
*
PARM1 EQU PTHEN+1 FIRST PARAMETER VALUE
PBSI$ EQU PARM1+1 SIZE OF P1BLK IN WORDS
*
* SEE P0BLK FOR DEFINITIONS OF PCODE, PTHEN
*
* PARM1 CONTAINS A PARAMETER VALUE USED IN MATCHING THE
* NODE. FOR EXAMPLE, IN A LEN PATTERN, IT IS THE INTEGER
* ARGUMENT TO LEN. THE DETAILS OF THE USE OF THE PARAMETER
* FIELD ARE INCLUDED IN THE DESCRIPTION OF THE INDIVIDUAL
* MATCH ROUTINES. PARM1 IS ALWAYS AN ADDRESS POINTER WHICH
* IS PROCESSED BY THE GARBAGE COLLECTOR.
EJC
*
* PATTERN BLOCK (TWO PARAMETERS)
*
* A P2BLK IS USED TO REPRESENT PATTERN NODES WHICH
* REQUIRE TWO PARAMETER VALUES.
*
* +------------------------------------+
* I PCODE I
* +------------------------------------+
* I PTHEN I
* +------------------------------------+
* I PARM1 I
* +------------------------------------+
* I PARM2 I
* +------------------------------------+
*
PARM2 EQU PARM1+1 SECOND PARAMETER VALUE
PCSI$ EQU PARM2+1 SIZE OF P2BLK IN WORDS
*
* SEE P1BLK FOR DEFINITIONS OF PCODE, PTHEN, PARM1
*
* PARM2 IS A PARAMETER WHICH PERFORMS THE SAME SORT OF
* FUNCTION AS PARM1 (SEE DESCRIPTION OF P1BLK).
*
* PARM2 IS A NON-RELOCATABLE FIELD AND IS NOT
* PROCESSED BY THE GARBAGE COLLECTOR. ACCORDINGLY, IT MAY
* NOT CONTAIN A POINTER TO A BLOCK IN DYNAMIC MEMORY.
EJC
*
* PROGRAM-DEFINED DATATYPE BLOCK
*
* A PDBLK REPRESENTS THE DATA ITEM FORMED BY A CALL TO A
* DATATYPE FUNCTION AS DEFINED BY THE SYSTEM FUNCTION DATA.
*
* +------------------------------------+
* I PDTYP I
* +------------------------------------+
* I IDVAL I
* +------------------------------------+
* I PDDFP I
* +------------------------------------+
* / /
* / PDFLD /
* / /
* +------------------------------------+
*
PDTYP EQU 0 PTR TO DUMMY ROUTINE B$PDT
PDDFP EQU IDVAL+1 PTR TO ASSOCIATED DFBLK
PDFLD EQU PDDFP+1 START OF FIELD VALUE POINTERS
PDFOF EQU DFFLD-PDFLD DIFFERENCE IN OFFSET TO FIELD PTRS
PDSI$ EQU PDFLD SIZE OF STANDARD FIELDS IN PDBLK
PDDFS EQU DFSI$-PDSI$ DIFFERENCE IN DFBLK, PDBLK SIZES
*
* THE PDDFP POINTER MAY BE USED TO DETERMINE THE DATATYPE
* AND THE NAMES OF THE FIELDS IF REQUIRED. THE DFBLK ALSO
* CONTAINS THE LENGTH OF THE PDBLK IN BAUS (FIELD DFPDL).
* PDDFP IS NON-RELOC. BECAUSE DFBLK IS IN STATIC
*
* PDFLD VALUES ARE STORED IN ORDER FROM LEFT TO RIGHT.
* THEY CONTAIN VALUES OR POINTERS TO TRBLK CHAINS.
EJC
*
* PROGRAM DEFINED FUNCTION BLOCK (PFBLK)
*
* A PFBLK IS CREATED FOR EACH CALL TO THE DEFINE FUNCTION
* AND A POINTER TO THE PFBLK PLACED IN THE PROPER VRBLK.
*
* +------------------------------------+
* I FCODE I
* +------------------------------------+
* I FARGS I
* +------------------------------------+
* I PFLEN I
* +------------------------------------+
* I PFVBL I
* +------------------------------------+
* I PFNLO I
* +------------------------------------+
* I PFCOD I
* +------------------------------------+
* I PFCTR I
* +------------------------------------+
* I PFRTR I
* +------------------------------------+
* / /
* / PFARG /
* / /
* +------------------------------------+
*
PFLEN EQU FARGS+1 LENGTH OF PFBLK IN BAUS
PFVBL EQU PFLEN+1 POINTER TO VRBLK FOR FUNCTION NAME
PFNLO EQU PFVBL+1 NUMBER OF LOCALS
PFCOD EQU PFNLO+1 PTR TO CDBLK FOR FIRST STATEMENT
PFCTR EQU PFCOD+1 TRBLK PTR IF CALL TRACED ELSE 0
PFRTR EQU PFCTR+1 TRBLK PTR IF RETURN TRACED ELSE 0
PFARG EQU PFRTR+1 VRBLK PTRS FOR ARGUMENTS AND LOCALS
PFAGB EQU PFARG-1 OFFSET BEHIND PFARG FOR ARG,LOCAL
PFSI$ EQU PFARG NUMBER OF STANDARD FIELDS IN PFBLK
*
* THE FCODE FIELD POINTS TO THE ROUTINE B$PFC.
*
* PFARG IS STORED IN THE FOLLOWING ORDER.
*
* ARGUMENTS (LEFT TO RIGHT)
* LOCALS (LEFT TO RIGHT)
.IF .CNRA
.ELSE
EJC
*
* REAL CONSTANT BLOCK (RCBLK)
*
* AN RCBLK IS CREATED FOR EVERY REAL REFERENCED OR
* CREATED BY A PROGRAM.
*
* +------------------------------------+
* I RCGET I
* +------------------------------------+
* * RCVAL *
* +------------------------------------+
*
RCGET EQU 0 PTR TO ROUTINE B$RCL TO LOAD REAL
RCVAL EQU RCGET+1 REAL VALUE
RCSI$ EQU RCVAL+CFP$R SIZE OF RCBLK
*
* THE LENGTH OF THE RCVAL FIELD IS CFP$R.
.FI
EJC
*
* STRING CONSTANT BLOCK (SCBLK)
*
* AN SCBLK IS BUILT FOR EVERY STRING REFERENCED OR CREATED
* BY A PROGRAM.
*
* +------------------------------------+
* I SCGET I
* +------------------------------------+
* I SCLEN I
* +------------------------------------+
* / /
* / SCHAR /
* / /
* +------------------------------------+
*
SCGET EQU 0 PTR TO ROUTINE B$SCL TO LOAD STRING
SCLEN EQU SCGET+1 LENGTH OF STRING IN CHARACTERS
SCHAR EQU SCLEN+1 CHARACTERS OF STRING
SCSI$ EQU SCHAR SIZE OF STANDARD FIELDS IN SCBLK
*
* THE CHARACTERS OF THE STRING ARE STORED LEFT JUSTIFIED.
* THE FINAL WORD IS PADDED ON THE RIGHT WITH ZEROS.
* (I.E. THE CHARACTER WHOSE INTERNAL CODE IS ZERO).
*
* THE VALUE OF SCLEN MAY NOT EXCEED MXLEN. THIS ENSURES
* THAT CHARACTER OFFSETS (E.G. THE PATTERN MATCH CURSOR)
* CAN BE CORRECTLY PROCESSED BY THE GARBAGE COLLECTOR.
*
* NOTE THAT THE OFFSET TO THE CHARACTERS OF THE STRING
* IS GIVEN IN BAUS BY CFP$F AND THAT THIS VALUE IS
* AUTOMATICALLY ALLOWED FOR IN PLC, PSC.
* NOTE THAT FOR A SPITBOL SCBLK, THE VALUE OF CFP$F
* IS GIVEN BY CFP$B*SCHAR.
EJC
*
* SIMPLE EXPRESSION BLOCK (SEBLK)
*
* AN SEBLK IS USED TO REPRESENT AN EXPRESSION OF THE FORM
* *(NATURAL VARIABLE). ALL OTHER EXPRESSIONS ARE EXBLKS.
*
* +------------------------------------+
* I SETYP I
* +------------------------------------+
* I SEVAR I
* +------------------------------------+
*
SETYP EQU 0 PTR TO ROUTINE B$SEL TO LOAD EXPR
SEVAR EQU SETYP+1 PTR TO VRBLK FOR VARIABLE
SESI$ EQU SEVAR+1 LENGTH OF SEBLK IN WORDS
EJC
*
* STANDARD VARIABLE BLOCK (SVBLK)
*
* AN SVBLK IS ASSEMBLED IN THE CONSTANT SECTION FOR EACH
* VARIABLE WHICH SATISFIES ONE OF THE FOLLOWING CONDITIONS.
*
* 1) IT IS THE NAME OF A SYSTEM FUNCTION
* 2) IT HAS AN INITIAL VALUE
* 3) IT HAS A KEYWORD ASSOCIATION
* 4) IT HAS A STANDARD I/O ASSOCIATION
* 6) IT HAS A STANDARD LABEL ASSOCIATION
*
* IF VRBLKS ARE CONSTRUCTED FOR ANY OF THESE VARIABLES,
* THEN THE VRSVP FIELD POINTS TO THE SVBLK (SEE VRBLK)
*
* +------------------------------------+
* I SVBIT I
* +------------------------------------+
* I SVLEN I
* +------------------------------------+
* / SVCHS /
* +------------------------------------+
* I SVKNM I
* +------------------------------------+
* I SVFNC I
* +------------------------------------+
* I SVNAR I
* +------------------------------------+
* I SVLBL I
* +------------------------------------+
* I SVVAL I
* +------------------------------------+
EJC
*
* STANDARD VARIABLE BLOCK (CONTINUED)
*
SVBIT EQU 0 BIT STRING INDICATING ATTRIBUTES
SVLEN EQU 1 (=SCLEN) LENGTH OF NAME IN CHARS
SVCHS EQU 2 (=SCHAR) CHARACTERS OF NAME
SVSI$ EQU 2 NUMBER OF STANDARD FIELDS IN SVBLK
SVPRE EQU 1 SET IF PREEVALUATION PERMITTED
SVFFC EQU SVPRE+SVPRE SET ON IF FAST CALL PERMITTED
SVCKW EQU SVFFC+SVFFC SET ON IF KEYWORD VALUE CONSTANT
SVPRD EQU SVCKW+SVCKW SET ON IF PREDICATE FUNCTION
SVNBT EQU 4 NUMBER OF BITS TO RIGHT OF SVKNM
SVKNM EQU SVPRD+SVPRD SET ON IF KEYWORD ASSOCIATION
SVFNC EQU SVKNM+SVKNM SET ON IF SYSTEM FUNCTION
SVNAR EQU SVFNC+SVFNC SET ON IF SYSTEM FUNCTION
SVLBL EQU SVNAR+SVNAR SET ON IF SYSTEM LABEL
SVVAL EQU SVLBL+SVLBL SET ON IF PREDEFINED VALUE
*
* NOTE THAT THE LAST FIVE BITS CORRESPOND IN ORDER
* TO THE FIELDS WHICH ARE PRESENT (SEE PROCEDURE GTNVR).
*
* THE FOLLOWING DEFINITIONS ARE USED IN THE SVBLK TABLE
*
SVFNF EQU SVFNC+SVNAR FUNCTION WITH NO FAST CALL
SVFNN EQU SVFNF+SVFFC FUNCTION WITH FAST CALL, NO PREEVAL
SVFNP EQU SVFNN+SVPRE FUNCTION ALLOWING PREEVALUATION
SVFPR EQU SVFNN+SVPRD PREDICATE FUNCTION
SVFNK EQU SVFNN+SVKNM NO PREEVAL FUNC + KEYWORD
SVKWV EQU SVKNM+SVVAL KEYWORD + VALUE
SVKWC EQU SVCKW+SVKNM KEYWORD WITH CONSTANT VALUE
SVKVC EQU SVKWV+SVCKW CONSTANT KEYWORD + VALUE
SVKVL EQU SVKVC+SVLBL CONSTANT KEYWORD + VALUE + LABEL
.IF .CNFN
.ELSE
SVFPK EQU SVFNP+SVKVC PREEVAL FUNC + CONST KEYWD+VAL
.FI
*
* THE SVPRE BIT ALLOWS THE COMPILER TO PREEVALUATE A CALL
* TO THE ASSOCIATED SYSTEM FUNCTION IF ALL THE ARGUMENTS
* ARE THEMSELVES CONSTANTS. FUNCTIONS IN THIS CATEGORY
* MUST HAVE NO SIDE EFFECTS AND MUST NEVER CAUSE FAILURE.
* THE CALL MAY GENERATE AN ERROR CONDITION.
*
* THE SVFFC BIT ALLOWS THE COMPILER TO GENERATE THE SPECIAL
* FAST CALL AFTER ADJUSTING THE NUMBER OF ARGUMENTS. ONLY
* THE APPLY FUNCTION FALLS OUTSIDE THIS CATEGORY.
*
* THE SVCKW BIT IS SET IF THE ASSOCIATED KEYWORD VALUE IS
* A CONSTANT, THUS ALLOWING PREEVALUATION FOR A VALUE CALL.
*
* THE SVPRD BIT IS SET ON FOR ALL PREDICATE FUNCTIONS TO
* ENABLE THE SPECIAL CONCATENATION CODE OPTIMIZATION.
EJC
*
* SVBLK (CONTINUED)
*
* SVKNM KEYWORD NUMBER
*
* SVKNM IS PRESENT ONLY FOR A STANDARD KEYWORD ASSOC.
* IT CONTAINS A KEYWORD NUMBER AS DEFINED BY THE
* KEYWORD NUMBER TABLE GIVEN LATER ON.
*
* SVFNC SYSTEM FUNCTION POINTER
*
* SVFNC IS PRESENT ONLY FOR A SYSTEM FUNCTION ASSOC.
* IT IS A POINTER TO THE ACTUAL CODE FOR THE SYSTEM
* FUNCTION. THE GENERATED CODE FOR A FAST CALL IS A
* POINTER TO THE SVFNC FIELD OF THE SVBLK FOR THE
* FUNCTION. THE VRFNC FIELD OF THE VRBLK POINTS TO
* THIS SAME FIELD, IN WHICH CASE, IT SERVES AS THE
* FCODE FIELD FOR THE FUNCTION CALL.
*
* SVNAR NUMBER OF FUNCTION ARGUMENTS
*
* SVNAR IS PRESENT ONLY FOR A SYSTEM FUNCTION ASSOC.
* IT IS THE NUMBER OF ARGUMENTS REQUIRED FOR A CALL
* TO THE SYSTEM FUNCTION. THE COMPILER USES THIS
* VALUE TO ADJUST THE NUMBER OF ARGUMENTS IN A FAST
* CALL AND IN THE CASE OF A FUNCTION CALLED THROUGH
* THE VRFNC FIELD OF THE VRBLK, THE SVNAR FIELD
* SERVES AS THE FARGS FIELD FOR O$FNC. A SPECIAL
* CASE OCCURS IF THIS VALUE IS SET TO 999. THIS IS
* USED TO INDICATE THAT THE FUNCTION HAS A VARIABLE
* NUMBER OF ARGUMENTS AND CAUSES O$FNC TO PASS CONTROL
* WITHOUT ADJUSTING THE ARGUMENT COUNT. THE ONLY
* PREDEFINED FUNCTION USING THIS IS APPLY.
*
* SVLBL SYSTEM LABEL POINTER
*
* SVLBL IS PRESENT ONLY FOR A STANDARD LABEL ASSOC.
* IT IS A POINTER TO A SYSTEM LABEL ROUTINE (L$XXX).
* THE VRLBL FIELD OF THE CORRESPONDING VRBLK POINTS TO
* THE SVLBL FIELD OF THE SVBLK.
*
* SVVAL SYSTEM VALUE POINTER
*
* SVVAL IS PRESENT ONLY FOR A STANDARD VALUE.
* IT IS A POINTER TO THE PATTERN NODE (NDXXX) WHICH
* IS THE STANDARD INITIAL VALUE OF THE VARIABLE.
* THIS VALUE IS COPIED TO THE VRVAL FIELD OF THE VRBLK
EJC
*
* SVBLK (CONTINUED)
*
* KEYWORD NUMBER TABLE
*
* THE FOLLOWING TABLE GIVES SYMBOLIC NAMES FOR KEYWORD
* NUMBERS. THESE VALUES ARE STORED IN THE SVKNM FIELD OF
* SVBLKS AND IN THE KVNUM FIELD OF KVBLKS. SEE ALSO
* PROCEDURES ASIGN, ACESS AND KWNAM.
*
* UNPROTECTED KEYWORDS WITH ONE WORD INTEGER VALUES
*
K$ANC EQU 0 ANCHOR
K$DMP EQU K$ANC+CFP$B DUMP
K$ERL EQU K$DMP+CFP$B ERRLIMIT
K$ERT EQU K$ERL+CFP$B ERRTYPE
K$FTR EQU K$ERT+CFP$B FTRACE
K$INP EQU K$FTR+CFP$B INPUT
K$MXL EQU K$INP+CFP$B MAXLENGTH
K$OUP EQU K$MXL+CFP$B OUTPUT
.IF .CNPF
K$TRA EQU K$OUP+CFP$B TRACE
.ELSE
K$PFL EQU K$OUP+CFP$B PROFILE
K$TRA EQU K$PFL+CFP$B TRACE
.FI
K$TRM EQU K$TRA+CFP$B TRIM
*
* PROTECTED KEYWORDS WITH ONE WORD INTEGER VALUES
*
K$FNC EQU K$TRM+CFP$B FNCLEVEL
K$LST EQU K$FNC+CFP$B LASTNO
K$STN EQU K$LST+CFP$B STNO
*
* KEYWORDS WITH CONSTANT PATTERN VALUES
*
K$ABO EQU K$STN+CFP$B ABORT
K$ARB EQU K$ABO+PASI$ ARB
K$BAL EQU K$ARB+PASI$ BAL
K$FAL EQU K$BAL+PASI$ FAIL
K$FEN EQU K$FAL+PASI$ FENCE
K$REM EQU K$FEN+PASI$ REM
K$SUC EQU K$REM+PASI$ SUCCEED
EJC
*
* KEYWORD NUMBER TABLE (CONTINUED)
*
* SPECIAL KEYWORDS
*
K$ALP EQU K$SUC+1 ALPHABET
K$RTN EQU K$ALP+1 RTNTYPE
K$COD EQU K$RTN+1 CODE
K$STC EQU K$COD+1 STCOUNT
K$ETX EQU K$STC+1 ERRTEXT
K$STL EQU K$ETX+1 STLIMIT
*
* RELATIVE OFFSETS OF SPECIAL KEYWORDS
*
K$$AL EQU K$ALP-K$ALP ALPHABET
K$$RT EQU K$RTN-K$ALP RTNTYPE
K$$CD EQU K$COD-K$ALP CODE
K$$SC EQU K$STC-K$ALP STCOUNT
K$$ET EQU K$ETX-K$ALP ERRTEXT
K$$SL EQU K$STL-K$ALP STLIMIT
*
* SYMBOLS USED IN ASIGN AND ACESS PROCEDURES
*
K$P$$ EQU K$FNC FIRST PROTECTED KEYWORD
K$V$$ EQU K$ABO FIRST KEYWORD WITH CONSTANT VALUE
K$S$$ EQU K$ALP FIRST KEYWORD WITH SPECIAL ACESS
EJC
*
* FORMAT OF A TABLE BLOCK (TBBLK)
*
* A TABLE BLOCK IS USED TO REPRESENT A TABLE VALUE.
* IT IS BUILT BY A CALL TO THE TABLE OR CONVERT FUNCTIONS.
*
* +------------------------------------+
* I TBTYP I
* +------------------------------------+
* I IDVAL I
* +------------------------------------+
* I TBLEN I
* +------------------------------------+
* I TBINV I
* +------------------------------------+
* / /
* / TBBUK /
* / /
* +------------------------------------+
*
TBTYP EQU 0 POINTER TO DUMMY ROUTINE B$TBT
TBLEN EQU OFFS2 LENGTH OF TBBLK IN BAUS
TBINV EQU OFFS3 DEFAULT INITIAL LOOKUP VALUE
TBBUK EQU TBINV+1 START OF HASH BUCKET POINTERS
TBSI$ EQU TBBUK SIZE OF STANDARD FIELDS IN TBBLK
TBNBK EQU 11 DEFAULT NO. OF BUCKETS
*
* THE TABLE BLOCK IS A HASH TABLE WHICH POINTS TO CHAINS
* OF TABLE ELEMENT BLOCKS REPRESENTING THE ELEMENTS
* IN THE TABLE WHICH HASH INTO THE SAME BUCKET.
*
* TBBUK ENTRIES EITHER POINT TO THE FIRST TEBLK ON THE
* CHAIN OR THEY POINT TO THE TBBLK ITSELF TO INDICATE THE
* END OF THE CHAIN.
EJC
*
* TABLE ELEMENT BLOCK (TEBLK)
*
* A TABLE ELEMENT IS USED TO REPRESENT A SINGLE ENTRY IN
* A TABLE (SEE DESCRIPTION OF TBBLK FORMAT FOR HASH TABLE)
*
* +------------------------------------+
* I TETYP I
* +------------------------------------+
* I TESUB I
* +------------------------------------+
* I TEVAL I
* +------------------------------------+
* I TENXT I
* +------------------------------------+
*
TETYP EQU 0 POINTER TO DUMMY ROUTINE B$TET
TESUB EQU TETYP+1 SUBSCRIPT VALUE
TEVAL EQU TESUB+1 (=VRVAL) TABLE ELEMENT VALUE
TENXT EQU TEVAL+1 LINK TO NEXT TEBLK
* SEE S$CNV WHERE RELATION IS ASSUMED WITH TENXT AND TBBUK
TESI$ EQU TENXT+1 SIZE OF TEBLK IN WORDS
*
* TENXT POINTS TO THE NEXT TEBLK ON THE HASH CHAIN FROM THE
* TBBUK CHAIN FOR THIS HASH INDEX. AT THE END OF THE CHAIN,
* TENXT POINTS BACK TO THE START OF THE TBBLK.
*
* TEVAL CONTAINS A DATA POINTER OR A TRBLK POINTER.
*
* TESUB CONTAINS A DATA POINTER.
EJC
*
* TRAP BLOCK (TRBLK)
*
* A TRAP BLOCK IS USED TO REPRESENT A TRACE OR INPUT OR
* OUTPUT ASSOCIATION IN RESPONSE TO A CALL TO THE TRACE
* INPUT OR OUTPUT SYSTEM FUNCTIONS. SEE BELOW FOR DETAILS
*
* +------------------------------------+
* I TRIDN I
* +------------------------------------+
* I TRTYP I
* +------------------------------------+
* I TRVAL OR TRLBL OR TRNXT OR TRKVR I
* +------------------------------------+
* I TRTAG OR TRTER I
* +------------------------------------+
* I TRFNC OR TRTRI I
* +------------------------------------+
*
TRIDN EQU 0 POINTER TO DUMMY ROUTINE B$TRT
TRTYP EQU TRIDN+1 TRAP TYPE CODE
TRVAL EQU TRTYP+1 VALUE OF TRAPPED VARIABLE (=VRVAL)
TRNXT EQU TRVAL PTR TO NEXT TRBLK ON TRBLK CHAIN
TRLBL EQU TRVAL PTR TO ACTUAL LABEL (TRACED LABEL)
TRKVR EQU TRVAL VRBLK POINTER FOR KEYWORD TRACE
TRTAG EQU TRVAL+1 TRACE TAG OR IOTAG
TRTER EQU TRTAG PTR TO TERMINAL VRBLK OR NULL
TRFNC EQU TRTAG+1 TRACE FUNCTION VRBLK (ZERO IF NONE)
TRTRI EQU TRFNC PTR TO TRACE BLOCK HOLDING IOTAG
TRSI$ EQU TRFNC+1 NUMBER OF WORDS IN TRBLK
*
TRTIN EQU 0 TRACE TYPE FOR INPUT ASSOCIATION
TRTAC EQU TRTIN+1 TRACE TYPE FOR ACCESS TRACE
TRTVL EQU TRTAC+1 TRACE TYPE FOR VALUE TRACE
TRTIO EQU TRTVL+1 TRACE TYPE FOR IOTAG TRACE BLOCK
TRTOU EQU TRTIO+1 TRACE TYPE FOR OUTPUT ASSOCIATION
EJC
*
* TRAP BLOCK (CONTINUED)
*
* VARIABLE INPUT ASSOCIATION
*
* THE VALUE FIELD OF THE VARIABLE POINTS TO A TRBLK
* INSTEAD OF CONTAINING THE DATA VALUE. IN THE CASE
* OF A NATURAL VARIABLE, THE VRGET AND VRSTO FIELDS
* CONTAIN =B$VRA AND =B$VRV TO ACTIVATE THE CHECK.
*
* TRTYP IS SET TO TRTIN
* TRNXT POINTS TO NEXT TRBLK OR TRVAL HAS VARIABLE VAL
* TRTER IS A POINTER TO SVBLK IF ASSOCIATION IS
* FOR INPUT, TERMINAL, ELSE IT IS NULL.
* TRTRI IS A PTR TO IOTAG TRBLK FROM SYSIO OR ZERO.
*
* VARIABLE ACCESS TRACE ASSOCIATION
*
* THE VALUE FIELD OF THE VARIABLE POINTS TO A TRBLK
* INSTEAD OF CONTAINING THE DATA VALUE. IN THE CASE
* OF A NATURAL VARIABLE, THE VRGET AND VRSTO FIELDS
* CONTAIN =B$VRA AND =B$VRV TO ACTIVATE THE CHECK.
*
* TRTYP IS SET TO TRTAC
* TRNXT POINTS TO NEXT TRBLK OR TRVAL HAS VARIABLE VAL
* TRTAG IS THE TRACE TAG (0 IF NONE)
* TRFNC IS THE TRACE FUNCTION VRBLK PTR (0 IF NONE)
*
* VARIABLE VALUE TRACE ASSOCIATION
*
* THE VALUE FIELD OF THE VARIABLE POINTS TO A TRBLK
* INSTEAD OF CONTAINING THE DATA VALUE. IN THE CASE
* OF A NATURAL VARIABLE, THE VRGET AND VRSTO FIELDS
* CONTAIN =B$VRA AND =B$VRV TO ACTIVATE THE CHECK.
*
* TRTYP IS SET TO TRTVL
* TRNXT POINTS TO NEXT TRBLK OR TRVAL HAS VARIABLE VAL
* TRTAG IS THE TRACE TAG (0 IF NONE)
* TRFNC IS THE TRACE FUNCTION VRBLK PTR (0 IF NONE)
EJC
* TRAP BLOCK (CONTINUED)
*
* VARIABLE OUTPUT ASSOCIATION
*
* THE VALUE FIELD OF THE VARIABLE POINTS TO A TRBLK
* INSTEAD OF CONTAINING THE DATA VALUE. IN THE CASE
* OF A NATURAL VARIABLE, THE VRGET AND VRSTO FIELDS
* CONTAIN =B$VRA AND =B$VRV TO ACTIVATE THE CHECK.
*
* TRTYP IS SET TO TRTOU
* TRNXT POINTS TO NEXT TRBLK OR TRVAL HAS VARIABLE VAL
* TRTER IS A POINTER TO SVBLK IF ASSOCIATION IS
* FOR OUTPUT, TERMINAL, ELSE IT IS NULL.
* TRTRI IS A PTR TO IOTAG TRBLK FROM SYSIO OR ZERO.
*
* FUNCTION CALL TRACE
*
* THE PFCTR FIELD OF THE CORRESPONDING PFBLK IS SET
* TO POINT TO A TRBLK.
*
* TRTYP IS SET TO TRTIN
* TRNXT IS ZERO
* TRTAG IS THE TRACE TAG (0 IF NONE)
* TRFNC IS THE TRACE FUNCTION VRBLK PTR (0 IF NONE)
*
* FUNCTION RETURN TRACE
*
* THE PFRTR FIELD OF THE CORRESPONDING PFBLK IS SET
* TO POINT TO A TRBLK
*
* TRTYP IS SET TO TRTIN
* TRNXT IS ZERO
* TRTAG IS THE TRACE TAG (0 IF NONE)
* TRFNC IS THE TRACE FUNCTION VRBLK PTR (0 IF NONE)
*
* LABEL TRACE
*
* THE VRLBL OF THE VRBLK FOR THE LABEL IS
* CHANGED TO POINT TO A TRBLK AND THE VRTRA FIELD IS
* SET TO B$VRT TO ACTIVATE THE CHECK.
*
* TRTYP IS SET TO TRTIN
* TRLBL POINTS TO THE ACTUAL LABEL (CDBLK) VALUE
* TRTAG IS THE TRACE TAG (0 IF NONE)
* TRFNC IS THE TRACE FUNCTION VRBLK PTR (0 IF NONE)
EJC
*
* TRAP BLOCK (CONTINUED)
*
* KEYWORD TRACE
*
* KEYWORDS WHICH CAN BE TRACED POSSESS A UNIQUE
* LOCATION WHICH IS ZERO IF THERE IS NO TRACE AND
* POINTS TO A TRBLK IF THERE IS A TRACE. THE LOCATIONS
* ARE AS FOLLOWS.
*
* R$ERT ERRTYPE
* R$FNC FNCLEVEL
* R$STC STCOUNT
*
* THE FORMAT OF THE TRBLK IS AS FOLLOWS.
*
* TRTYP IS SET TO TRTIN
* TRKVR IS A POINTER TO THE VRBLK FOR THE KEYWORD
* TRTAG IS THE TRACE TAG (0 IF NONE)
* TRFNC IS THE TRACE FUNCTION VRBLK PTR (0 IF NONE)
*
* INPUT/OUTPUT FILETAG TRAP BLOCK (TRTIO)
*
* THE VALUE FIELD OF THE FILETAG VBL POINTS TO A TRBLK
* INSTEAD OF CONTAINING THE DATA VALUE. IN THE CASE OF
* A NATURAL VARIABLE, THE VRGET AND VRSTO FIELDS
* CONTAIN =B$VRA AND =B$VRV. THIS TRAP BLOCK IS USED
* TO HOLD THE IOTAG RETURNED BY A SYSIO CALL
*
* TRTYP IS SET TO TRTIO
* TRNXT POINTS TO NEXT TRBLK OR TRVAL IS VARIABLE VAL
* TRTAG HOLDS THE IOTAG.
*
* NOTE THAT WHEN MULTIPLE TRAPS ARE SET ON A VARIABLE
* THE ORDER IS IN ASCENDING VALUE OF TRTYP FIELD.
*
* INPUT ASSOCIATION (IF PRESENT)
* ACCESS TRACE (IF PRESENT)
* VALUE TRACE (IF PRESENT)
* FILETAG ASSOCIATION (IF PRESENT)
* OUTPUT ASSOCIATION (IF PRESENT)
*
* THE ACTUAL VALUE OF THE VARIABLE IS STORED IN THE TRVAL
* FIELD OF THE LAST TRBLK ON THE CHAIN.
*
* THIS IMPLEMENTATION DOES NOT PERMIT TRACE OR I/O
* ASSOCIATIONS TO ANY OF THE PSEUDO-VARIABLES.
EJC
*
* VECTOR BLOCK (VCBLK)
*
* A VCBLK IS USED TO REPRESENT AN ARRAY VALUE WHICH HAS
* ONE DIMENSION WHOSE LOWER BOUND IS ONE. ALL OTHER ARRAYS
* ARE REPRESENTED BY ARBLKS. A VCBLK IS CREATED BY THE
* SYSTEM FUNCTION ARRAY (S$ARR) WHEN PASSED AN INTEGER ARG.
*
* +------------------------------------+
* I VCTYP I
* +------------------------------------+
* I IDVAL I
* +------------------------------------+
* I VCLEN I
* +------------------------------------+
* I VCVLS I
* +------------------------------------+
*
VCTYP EQU 0 POINTER TO DUMMY ROUTINE B$VCT
VCLEN EQU OFFS2 LENGTH OF VCBLK IN BAUS
VCVLS EQU OFFS3 START OF VECTOR VALUES
VCSI$ EQU VCVLS SIZE OF STANDARD FIELDS IN VCBLK
VCVLB EQU VCVLS-1 OFFSET ONE WORD BEHIND VCVLS
VCTBD EQU TBSI$-VCSI$ DIFFERENCE IN SIZES - SEE PRTVL
*
* VCVLS ARE EITHER DATA POINTERS OR TRBLK POINTERS
*
* THE DIMENSION CAN BE DEDUCED FROM VCLEN.
EJC
*
* VARIABLE BLOCK (VRBLK)
*
* A VARIABLE BLOCK IS BUILT IN THE STATIC MEMORY AREA
* FOR EVERY VARIABLE REFERENCED OR CREATED BY A PROGRAM.
*
* NOTE THAT SINCE THESE BLOCKS ONLY OCCUR IN THE STATIC
* REGION, IT IS PERMISSIBLE TO POINT TO ANY WORD IN
* THE BLOCK AND THIS IS USED TO PROVIDE THREE DISTINCT
* ACCESS POINTS FROM THE GENERATED CODE AS FOLLOWS.
*
* 1) POINT TO VRGET (FIRST WORD OF VRBLK) TO LOAD THE
* VALUE OF THE VARIABLE ONTO THE MAIN STACK.
*
* 2) POINT TO VRSTO (SECOND WORD OF VRBLK) TO STORE THE
* TOP STACK ELEMENT AS THE VALUE OF THE VARIABLE.
*
* 3) POINT TO VRTRA (FOURTH WORD OF VRBLK) TO JUMP TO
* THE LABEL ASSOCIATED WITH THE VARIABLE NAME.
*
* +------------------------------------+
* I VRGET I
* +------------------------------------+
* I VRSTO I
* +------------------------------------+
* I VRVAL I
* +------------------------------------+
* I VRTRA I
* +------------------------------------+
* I VRLBL I
* +------------------------------------+
* I VRFNC I
* +------------------------------------+
* I VRNXT I
* +------------------------------------+
* I VRLEN I
* +------------------------------------+
* / /
* / VRCHS = VRSVP /
* / /
* +------------------------------------+
EJC
*
* VARIABLE BLOCK (CONTINUED)
*
VRGET EQU 0 POINTER TO ROUTINE TO LOAD VALUE
VRSTO EQU VRGET+1 POINTER TO ROUTINE TO STORE VALUE
VRVAL EQU VRSTO+1 VARIABLE VALUE
VRVLO EQU VRVAL-VRSTO OFFSET TO VALUE FROM STORE FIELD
VRTRA EQU VRVAL+1 POINTER TO ROUTINE TO JUMP TO LABEL
VRLBL EQU VRTRA+1 POINTER TO CODE FOR LABEL
VRLBO EQU VRLBL-VRTRA OFFSET TO LABEL FROM TRANSFER FIELD
VRFNC EQU VRLBL+1 POINTER TO FUNCTION BLOCK
VRNXT EQU VRFNC+1 POINTER TO NEXT VRBLK ON HASH CHAIN
VRLEN EQU VRNXT+1 LENGTH OF NAME (OR ZERO)
VRCHS EQU VRLEN+1 CHARACTERS OF NAME (VRLEN GT 0)
VRSVP EQU VRLEN+1 PTR TO SVBLK (VRLEN EQ 0)
VRSI$ EQU VRCHS+1 NUMBER OF STANDARD FIELDS IN VRBLK
VRSOF EQU VRLEN-SCLEN OFFSET TO DUMMY SCBLK FOR NAME
VRSVO EQU VRSVP-VRSOF PSEUDO-OFFSET TO VRSVP FIELD
*
* VRGET = B$VRL IF NOT INPUT ASSOCIATED OR ACCESS TRACED
* VRGET = B$VRA IF INPUT ASSOCIATED OR ACCESS TRACED
*
* VRSTO = B$VRS IF NOT OUTPUT ASSOCIATED OR VALUE TRACED
* VRSTO = B$VRV IF OUTPUT ASSOCIATED OR VALUE TRACED
* VRSTO = B$VRE IF VALUE IS PROTECTED PATTERN VALUE
*
* VRVAL POINTS TO THE APPROPRIATE VALUE UNLESS THE
* VARIABLE IS I/O/TRACE ASSOCIATED IN WHICH CASE, VRVAL
* POINTS TO AN APPROPRIATE TRBLK (TRAP BLOCK) CHAIN.
*
* VRTRA = B$VRG IF THE LABEL IS NOT TRACED
* VRTRA = B$VRT IF THE LABEL IS TRACED
*
* VRLBL POINTS TO A CDBLK IF THERE IS A LABEL
* VRLBL POINTS TO THE SVBLK SVLBL FIELD FOR A SYSTEM LABEL
* VRLBL POINTS TO STNDL FOR AN UNDEFINED LABEL
* VRLBL POINTS TO A TRBLK IF THE LABEL IS TRACED
*
* VRFNC POINTS TO A FFBLK FOR A FIELD FUNCTION
* VRFNC POINTS TO A DFBLK FOR A DATATYPE FUNCTION
* VRFNC POINTS TO A PFBLK FOR A PROGRAM DEFINED FUNCTION
* VRFNC POINTS TO A EFBLK FOR AN EXTERNAL LOADED FUNCTION
* VRFNC POINTS TO SVFNC (SVBLK) FOR A SYSTEM FUNCTION
* VRFNC POINTS TO STNDF IF THE FUNCTION IS UNDEFINED
*
* VRNXT POINTS TO THE NEXT VRBLK ON THIS CHAIN UNLESS
* THIS IS THE END OF THE CHAIN IN WHICH CASE IT IS ZERO.
*
* VRLEN IS THE NAME LENGTH FOR A NON-SYSTEM VARIABLE.
* VRLEN IS ZERO FOR A SYSTEM VARIABLE.
*
* VRCHS IS THE NAME IF VRLEN IS NON-ZERO.
* VRSVP IS A PTR TO THE SVBLK IF VRLEN IS ZERO.
EJC
*
* FORMAT OF A NON-RELOCATABLE EXTERNAL BLOCK (XNBLK)
*
* AN XNBLK IS A BLOCK REPRESENTING AN UNKNOWN (EXTERNAL)
* DATA VALUE. THE BLOCK CONTAINS NO POINTERS TO OTHER
* RELOCATABLE BLOCKS. AN XNBLK IS USED BY EXTERNAL FUNCTION
* PROCESSING OR POSSIBLY FOR SYSTEM I/O ROUTINES ETC.
* THE MACRO-SYSTEM ITSELF DOES NOT USE XNBLKS.
*
* +------------------------------------+
* I XNTYP I
* +------------------------------------+
* I XNLEN I
* +------------------------------------+
* / /
* / XNDTA /
* / /
* +------------------------------------+
*
XNTYP EQU 0 POINTER TO DUMMY ROUTINE B$XNT
XNLEN EQU XNTYP+1 LENGTH OF XNBLK IN BAUS
XNDTA EQU XNLEN+1 DATA WORDS
XNSI$ EQU XNDTA SIZE OF STANDARD FIELDS IN XNBLK
*
* NOTE THAT THE TERM NON-RELOCATABLE REFERS TO THE CONTENTS
* AND NOT THE BLOCK ITSELF. AN XNBLK CAN BE MOVED AROUND IF
* IT IS BUILT IN THE DYNAMIC MEMORY AREA.
EJC
*
* RELOCATABLE EXTERNAL BLOCK (XRBLK)
*
* AN XRBLK IS A BLOCK REPRESENTING AN UNKNOWN (EXTERNAL)
* DATA VALUE. THE DATA AREA IN THIS BLOCK CONSISTS ONLY
* OF ADDRESS VALUES AND ANY ADDRESSES POINTING INTO THE
* DYNAMIC MEMORY AREA MUST POINT TO THE START OF OTHER
* DATA BLOCKS. SEE ALSO DESCRIPTION OF XNBLK.
*
* +------------------------------------+
* I XRTYP I
* +------------------------------------+
* I XRLEN I
* +------------------------------------+
* / /
* / XRPTR /
* / /
* +------------------------------------+
*
XRTYP EQU 0 POINTER TO DUMMY ROUTINE B$XRT
XRLEN EQU XRTYP+1 LENGTH OF XRBLK IN BAUS
XRPTR EQU XRLEN+1 START OF ADDRESS POINTERS
XRSI$ EQU XRPTR SIZE OF STANDARD FIELDS IN XRBLK
EJC
*
* S$CNV (CONVERT) FUNCTION SWITCH CONSTANTS. THE VALUES
* ARE TIED TO THE ORDER OF THE ENTRIES IN THE SVCTB TABLE
* AND HENCE TO THE BRANCH TABLE IN S$CNV.
*
CNVST EQU 8 MAX STANDARD TYPE CODE FOR CONVERT
.IF .CNRA
CNVRT EQU CNVST NO REALS - SAME AS STANDARD TYPES
.ELSE
CNVRT EQU CNVST+1 CONVERT CODE FOR REALS
.FI
.IF .CNBF
CNVBT EQU CNVRT NO BUFFERS - SAME AS REAL CODE
.ELSE
CNVBT EQU CNVRT+1 CONVERT CODE FOR BUFFER
.FI
CNVTT EQU CNVBT+1 BSW CODE FOR CONVERT
*
* INPUT IMAGE LENGTH
*
INILN EQU 160 DEFAULT IMAGE LENGTH FOR COMPILER
*
* IN GENERAL, MEANINGFUL MNEMONICS SHOULD BE USED FOR
* OFFSETS. HOWEVER FOR SMALL INTEGERS USED OFTEN IN
* LITERALS THE FOLLOWING GENERAL DEFINITIONS ARE PROVIDED.
*
NUM01 EQU 1
NUM02 EQU 2
NUM03 EQU 3
NUM04 EQU 4
NUM05 EQU 5
NUM06 EQU 6
NUM07 EQU 7
NUM08 EQU 8
NUM09 EQU 9
NUM10 EQU 10
NINI9 EQU 999
THSND EQU 1000
*
* NUMBERS OF UNDEFINED SPITBOL OPERATORS
*
OPBUN EQU 5 NO. OF BINARY UNDEFINED OPS
OPUUN EQU 6 NO OF UNARY UNDEFINED OPS
*
* OFFSETS USED IN PRTSN, PRTMI AND ACESS
*
PRSNF EQU 13 OFFSET USED IN PRTSN
PRTMF EQU 15 OFFSET TO COL 15 (PRTMI)
RILEN EQU 160 BUFFER LENGTH FOR SYSRI
*
* CODES FOR STAGES OF PROCESSING
*
STGIC EQU 0 INITIAL COMPILE
STGXC EQU STGIC+1 EXECUTION COMPILE (CODE)
STGEV EQU STGXC+1 EXPRESSION EVAL DURING EXECUTION
STGXT EQU STGEV+1 EXECUTION TIME
STGCE EQU STGXT+1 INITIAL COMPILE AFTER END LINE
STGXE EQU STGCE+1 EXEC. COMPILE AFTER END LINE
STGND EQU STGCE-STGIC DIFFERENCE IN STAGE AFTER END
STGEE EQU STGXE+1 EVAL EVALUATING EXPRESSION
STGNO EQU STGEE+1 NUMBER OF CODES
EJC
*
*
* STATEMENT NUMBER PAD COUNT FOR LISTR
*
.DEF .CSN5
.IF .CSN6
STNPD EQU 6 STATEMENT NO. PAD COUNT
.UNDEF .CSN5
.FI
.IF .CSN8
STNPD EQU 8 STATEMENT NO. PAD COUNT
.UNDEF .CSN5
.FI
.IF .CSN5
STNPD EQU 5 STATEMENT NO. PAD COUNT
.FI
*
* SYNTAX TYPE CODES
*
* THESE CODES ARE RETURNED FROM THE SCANE PROCEDURE.
*
* THEY ARE SPACED 3 APART FOR THE BENEFIT OF EXPAN.
*
T$UOP EQU 0 UNARY OPERATOR
T$LPR EQU T$UOP+3 LEFT PAREN
T$LBR EQU T$LPR+3 LEFT BRACKET
T$CMA EQU T$LBR+3 COMMA
T$FNC EQU T$CMA+3 FUNCTION CALL
T$VAR EQU T$FNC+3 VARIABLE
T$CON EQU T$VAR+3 CONSTANT
T$BOP EQU T$CON+3 BINARY OPERATOR
T$RPR EQU T$BOP+3 RIGHT PAREN
T$RBR EQU T$RPR+3 RIGHT BRACKET
T$COL EQU T$RBR+3 COLON
T$SMC EQU T$COL+3 SEMI-COLON
*
* THE FOLLOWING DEFINITIONS ARE USED ONLY IN THE GOTO FIELD
*
T$FGO EQU T$SMC+1 FAILURE GOTO
T$SGO EQU T$FGO+1 SUCCESS GOTO
*
* THE ABOVE CODES ARE GROUPED SO THAT CODES FOR ELEMENTS
* WHICH CAN LEGITIMATELY IMMEDIATELY PRECEDE A UNARY
* OPERATOR COME FIRST TO FACILITATE OPERATOR SYNTAX CHECK.
*
T$UOK EQU T$FNC LAST CODE OK BEFORE UNARY OPERATOR
EJC
*
* DEFINITIONS OF VALUES FOR EXPAN JUMP TABLE
*
T$UO0 EQU T$UOP+0 UNARY OPERATOR, STATE ZERO
T$UO1 EQU T$UOP+1 UNARY OPERATOR, STATE ONE
T$UO2 EQU T$UOP+2 UNARY OPERATOR, STATE TWO
T$LP0 EQU T$LPR+0 LEFT PAREN, STATE ZERO
T$LP1 EQU T$LPR+1 LEFT PAREN, STATE ONE
T$LP2 EQU T$LPR+2 LEFT PAREN, STATE TWO
T$LB0 EQU T$LBR+0 LEFT BRACKET, STATE ZERO
T$LB1 EQU T$LBR+1 LEFT BRACKET, STATE ONE
T$LB2 EQU T$LBR+2 LEFT BRACKET, STATE TWO
T$CM0 EQU T$CMA+0 COMMA, STATE ZERO
T$CM1 EQU T$CMA+1 COMMA, STATE ONE
T$CM2 EQU T$CMA+2 COMMA, STATE TWO
T$FN0 EQU T$FNC+0 FUNCTION CALL, STATE ZERO
T$FN1 EQU T$FNC+1 FUNCTION CALL, STATE ONE
T$FN2 EQU T$FNC+2 FUNCTION CALL, STATE TWO
T$VA0 EQU T$VAR+0 VARIABLE, STATE ZERO
T$VA1 EQU T$VAR+1 VARIABLE, STATE ONE
T$VA2 EQU T$VAR+2 VARIABLE, STATE TWO
T$CO0 EQU T$CON+0 CONSTANT, STATE ZERO
T$CO1 EQU T$CON+1 CONSTANT, STATE ONE
T$CO2 EQU T$CON+2 CONSTANT, STATE TWO
T$BO0 EQU T$BOP+0 BINARY OPERATOR, STATE ZERO
T$BO1 EQU T$BOP+1 BINARY OPERATOR, STATE ONE
T$BO2 EQU T$BOP+2 BINARY OPERATOR, STATE TWO
T$RP0 EQU T$RPR+0 RIGHT PAREN, STATE ZERO
T$RP1 EQU T$RPR+1 RIGHT PAREN, STATE ONE
T$RP2 EQU T$RPR+2 RIGHT PAREN, STATE TWO
T$RB0 EQU T$RBR+0 RIGHT BRACKET, STATE ZERO
T$RB1 EQU T$RBR+1 RIGHT BRACKET, STATE ONE
T$RB2 EQU T$RBR+2 RIGHT BRACKET, STATE TWO
T$CL0 EQU T$COL+0 COLON, STATE ZERO
T$CL1 EQU T$COL+1 COLON, STATE ONE
T$CL2 EQU T$COL+2 COLON, STATE TWO
T$SM0 EQU T$SMC+0 SEMICOLON, STATE ZERO
T$SM1 EQU T$SMC+1 SEMICOLON, STATE ONE
T$SM2 EQU T$SMC+2 SEMICOLON, STATE TWO
*
T$NES EQU T$SM2+1 NUMBER OF ENTRIES IN BRANCH TABLE
EJC
*
* DEFINITION OF OFFSETS USED IN CONTROL CARD PROCESSING
*
.IF .CASL
CC$CI EQU 0 -CASEIG
CC$CO EQU CC$CI+1 -COPY
.ELSE
CC$CO EQU 0 -COPY
.FI
CC$EJ EQU CC$CO+1 -EJECT
CC$FA EQU CC$EJ+1 -FAIL
CC$LI EQU CC$FA+1 -LIST
.IF .CASL
CC$NC EQU CC$LI+1 -NOCASEIG
CC$NF EQU CC$NC+1 -NOFAIL
.ELSE
CC$NF EQU CC$LI+1 -NOFAIL
.FI
CC$NL EQU CC$NF+1 -NOLIST
CC$ST EQU CC$NL+1 -STITL
CC$TI EQU CC$ST+1 -TITLE
CC$TR EQU CC$TI+1 -TRACE
CC$CT EQU CC$TR+1 NUMBER OF CONTROL CARDS
CCNOC EQU 4 NO. OF CHARS INCLUDED IN MATCH
CCOFS EQU 7 OFFSET TO START OF TITLE/SUBTITLE
*
* DEFINITIONS OF STACK OFFSETS USED IN CMPIL PROCEDURE
*
* SEE DESCRIPTION AT START OF CMPIL PROCEDURE FOR DETAILS
* OF USE OF THESE LOCATIONS ON THE STACK.
*
CMSTM EQU 0 TREE FOR STATEMENT BODY
CMSGO EQU CMSTM+1 TREE FOR SUCCESS GOTO
CMFGO EQU CMSGO+1 TREE FOR FAIL GOTO
CMCGO EQU CMFGO+1 CONDITIONAL GOTO FLAG
CMPCD EQU CMCGO+1 PREVIOUS CDBLK POINTER
CMFFP EQU CMPCD+1 FAILURE FILL IN FLAG FOR PREVIOUS
CMFFC EQU CMFFP+1 FAILURE FILL IN FLAG FOR CURRENT
CMSOP EQU CMFFC+1 SUCCESS FILL IN OFFSET FOR PREVIOUS
CMSOC EQU CMSOP+1 SUCCESS FILL IN OFFSET FOR CURRENT
CMLBL EQU CMSOC+1 PTR TO VRBLK FOR CURRENT LABEL
CMTRA EQU CMLBL+1 PTR TO ENTRY CDBLK
*
CMNEN EQU CMTRA+1 COUNT OF STACK ENTRIES FOR CMPIL
.IF .CNPF
.ELSE
*
* A FEW CONSTANTS USED BY THE PROFILER
PFPD1 EQU 8 PAD POSITIONS ...
PFPD2 EQU 20 ... FOR PROFILE ...
PFPD3 EQU 32 ... PRINTOUT
PF$I2 EQU CFP$I+CFP$I SIZE OF TABLE ENTRY (2 INTS)
.FI
TTL S P I T B O L -- CONSTANT SECTION
*
* THIS SECTION CONSISTS ENTIRELY OF ASSEMBLED CONSTANTS.
*
* ALL LABEL NAMES ARE FIVE LETTERS. THE ORDER IS
* APPROXIMATELY ALPHABETICAL, BUT IN SOME CASES (ALWAYS
* DOCUMENTED), CONSTANTS MUST BE PLACED IN SOME SPECIAL
* ORDER WHICH MUST NOT BE DISTURBED.
*
* IT MUST ALSO BE REMEMBERED THAT THERE IS A REQUIREMENT
* FOR NO FORWARD REFERENCES WHICH ALSO DISTURBS THE
* ALPHABETICAL ORDER IN SOME CASES.
*
SEC START OF CONSTANT SECTION
*
* FREE STORE PERCENTAGE (USED BY ALLOC)
*
ALFSP DAC E$FSP FREE STORE PERCENTAGE
*
* BIT CONSTANTS FOR GENERAL USE
*
BITS0 DBC 0 ALL ZERO BITS
BITS1 DBC 1 ONE BIT IN LOW ORDER POSITION
BITS2 DBC 2 BIT IN POSITION 2
BITS3 DBC 4 BIT IN POSITION 3
BITS4 DBC 8 BIT IN POSITION 4
BITS5 DBC 16 BIT IN POSITION 5
BITS6 DBC 32 BIT IN POSITION 6
BITS7 DBC 64 BIT IN POSITION 7
BITS8 DBC 128 BIT IN POSITION 8
BITS9 DBC 256 BIT IN POSITION 9
BIT10 DBC 512 BIT IN POSITION 10
BITSM DBC CFP$M MASK FOR MAX INTEGER
*
* BIT CONSTANTS FOR SVBLK (SVBIT FIELD) TESTS
*
BTFNC DBC SVFNC BIT TO TEST FOR FUNCTION
BTKNM DBC SVKNM BIT TO TEST FOR KEYWORD NUMBER
BTLBL DBC SVLBL BIT TO TEST FOR LABEL
BTFFC DBC SVFFC BIT TO TEST FOR FAST CALL
BTCKW DBC SVCKW BIT TO TEST FOR CONSTANT KEYWORD
BTPRD DBC SVPRD BIT TO TEST FOR PREDICATE FUNCTION
BTPRE DBC SVPRE BIT TO TEST FOR PREEVALUATION
BTVAL DBC SVVAL BIT TO TEST FOR VALUE
EJC
*
* LIST OF NAMES USED FOR CONTROL CARD PROCESSING
*
.IF .CASL
CCNMS DTC /CASE/
DTC /COPY/
.ELSE
CCNMS DTC /COPY/
.FI
DTC /EJEC/
DTC /FAIL/
DTC /LIST/
.IF .CASL
DTC /NOCA/
.FI
DTC /NOFA/
DTC /NOLI/
DTC /STIT/
DTC /TITL/
DTC /TRAC/
*
* HEADER MESSAGES FOR DUMPR PROCEDURE (SCBLK FORMAT)
*
DMHDK DAC B$SCL
DAC 22
DDC /DUMP OF KEYWORD VALUES/
*
DMHDV DAC B$SCL
DAC 25
DDC /DUMP OF NATURAL VARIABLES/
*
* MESSAGE TEXT FOR COMPILATION STATISTICS
*
ENCM1 DAC B$SCL
DAC 10
DDC /STORE USED/
*
ENCM2 DAC B$SCL
DAC 10
DDC /STORE LEFT/
*
ENCM3 DAC B$SCL
DAC 11
DDC /COMP ERRORS/
*
ENCM4 DAC B$SCL
DAC 14
.IF .CTMD
DDC /COMP TIME-DSEC/
.ELSE
DDC /COMP TIME-MSEC/
.FI
*
ENCM5 DAC B$SCL
DAC 20
DDC /EXECUTION SUPPRESSED/
EJC
*
* FOR TERMINATION IN COMPILATION
*
ENDIC DAC B$SCL
DAC 14
DDC /IN COMPILATION/
*
* MEMORY OVERFLOW DURING INITIALISATION
*
ENDMO DAC B$SCL
ENDML DAC 15
DDC /MEMORY OVERFLOW/
*
* STRING CONSTANT FOR MESSAGE ISSUED BY L$END
*
ENDMS DAC B$SCL
DAC 10
DDC /NORMAL END/
*
* FAIL MESSAGE FOR STACK FAIL SECTION
*
ENDSO DAC B$SCL
DAC 36
DDC /STACK OVERFLOW IN GARBAGE COLLECTION/
EJC
*
* STRING CONSTANT FOR ERROR MESSAGE (ERROR SECTION)
*
ERMMS DAC B$SCL
DAC 5
DDC /ERROR/
*
ERMNS DAC B$SCL
DAC 4
DTC / -- /
*
*
ERRTF DAC 251 FATAL ERROR CODE - SEE LABEL ERRAF
*
* STRING CONSTANT FOR PAGE NUMBERING
*
LSTMS DAC B$SCL
DAC 5
DDC /PAGE /
*
* LISTING HEADER MESSAGE
*
HEADR DAC B$SCL
DAC 25
DDC /MACRO SPITBOL VERSION 4.3/
*
HEADV DAC B$SCL FOR EXIT() VERSION NO. CHECK
DAC 3
DTC /4.3/
*
* INTEGER CONSTANTS FOR GENERAL USE
* ICBLD OPTIMISATION USES THE FIRST THREE.
*
INT$R DAC B$ICL
INTV0 DIC +0 0
INTON DAC B$ICL
INTV1 DIC +1 1
INTTW DAC B$ICL
INTV2 DIC +2 2
INTVT DIC +10 10
INTVH DIC +100 100
INTTH DIC +1000 1000
*
* TABLE USED IN ICBLD OPTIMISATION
*
INTAB DAC INT$R POINTER TO 0
DAC INTON POINTER TO 1
DAC INTTW POINTER TO 2
EJC
*
* SPECIAL PATTERN NODES. THE FOLLOWING PATTERN NODES
* CONSIST SIMPLY OF A PCODE POINTER, SEE MATCH ROUTINES
* (P$XXX) FOR FULL DETAILS OF THEIR USE AND FORMAT).
*
NDABB DAC P$ABB ARBNO
NDABD DAC P$ABD ARBNO
NDARC DAC P$ARC ARB
NDEXB DAC P$EXB EXPRESSION
NDEXC DAC P$EXC EXPRESSION
.IF .CNFN
.ELSE
NDFNB DAC P$FNB FENCE()
NDFND DAC P$FND FENCE()
.FI
NDIMB DAC P$IMB IMMEDIATE ASSIGNMENT
NDIMD DAC P$IMD IMMEDIATE ASSIGNMENT
NDNTH DAC P$NTH PATTERN END (NULL PATTERN)
NDPAB DAC P$PAB PATTERN ASSIGNMENT
NDPAD DAC P$PAD PATTERN ASSIGNMENT
NDUNA DAC P$UNA ANCHOR POINT MOVEMENT
*
* KEYWORD CONSTANT PATTERN NODES. THE FOLLOWING NODES ARE
* USED AS THE VALUES OF PATTERN KEYWORDS AND THE INITIAL
* VALUES OF THE CORRESPONDING NATURAL VARIABLES. ALL
* NODES ARE IN P0BLK FORMAT AND THE ORDER IS TIED TO THE
* DEFINITIONS OF CORRESPONDING K$XXX SYMBOLS.
*
NDABO DAC P$ABO ABORT
DAC NDNTH
NDARB DAC P$ARB ARB
DAC NDNTH
NDBAL DAC P$BAL BAL
DAC NDNTH
NDFAL DAC P$FAL FAIL
DAC NDNTH
NDFEN DAC P$FEN FENCE
DAC NDNTH
NDREM DAC P$REM REM
DAC NDNTH
NDSUC DAC P$SUC SUCCEED
DAC NDNTH
*
* NULL STRING. ALL NULL VALUES POINT TO THIS STRING. THE
* SVCHS FIELD CONTAINS A BLANK TO PROVIDE FOR EASY DEFAULT
* PROCESSING IN TRACE, STOPTR, LPAD AND RPAD.
* NULLW CONTAINS 10 BLANKS WHICH ENSURES AN ALL BLANK WORD
* BUT FOR VERY EXCEPTIONAL MACHINES.
*
NULLS DAC B$SCL NULL STRING VALUE
DAC 0 SCLEN = 0
NULLW DTC / /
EJC
*
* OPERATOR DOPE VECTORS (SEE DVBLK FORMAT)
*
OPDVC DAC O$CNC CONCATENATION
DAC C$CNC
DAC LLCNC
DAC RRCNC
*
* OPDVP IS USED WHEN SCANNING BELOW TOP LEVEL TO ENSURE
* THE CONCATENATION WILL NOT LATER BE MISTAKEN FOR
* PATTERN MATCHING
*
OPDVP DAC O$CNC PROVEN CONCATENATION
DAC C$CNP
DAC LLCNC
DAC RRCNC
*
* NOTE THAT THE ORDER OF THE REMAINING ENTRIES IS TIED TO
* THE ORDER OF THE CODING IN THE SCANE PROCEDURE.
*
OPDVS DAC O$ASS ASSIGNMENT
DAC C$ASS
DAC LLASS
DAC RRASS
*
DAC 6 UNARY EQUAL
DAC C$UUO
DAC LLUNO
*
DAC O$PMV PATTERN MATCH
DAC C$PMT
DAC LLPMT
DAC RRPMT
*
DAC O$INT INTERROGATION
DAC C$UVL
DAC LLUNO
*
DAC 1 BINARY AMPERSAND
DAC C$UBO
DAC LLAMP
DAC RRAMP
*
DAC O$KWV KEYWORD REFERENCE
DAC C$KEY
DAC LLUNO
*
DAC O$ALT ALTERNATION
DAC C$ALT
DAC LLALT
DAC RRALT
EJC
*
* OPERATOR DOPE VECTORS (CONTINUED)
*
DAC 5 UNARY VERTICAL BAR
DAC C$UUO
DAC LLUNO
*
DAC 0 BINARY AT
DAC C$UBO
DAC LLATS
DAC RRATS
*
DAC O$CAS CURSOR ASSIGNMENT
DAC C$UNM
DAC LLUNO
*
DAC 2 BINARY NUMBER SIGN
DAC C$UBO
DAC LLNUM
DAC RRNUM
*
DAC 7 UNARY NUMBER SIGN
DAC C$UUO
DAC LLUNO
*
DAC O$DVD DIVISION
DAC C$BVL
DAC LLDVD
DAC RRDVD
*
DAC 9 UNARY SLASH
DAC C$UUO
DAC LLUNO
*
DAC O$MLT MULTIPLICATION
DAC C$BVL
DAC LLMLT
DAC RRMLT
EJC
*
* OPERATOR DOPE VECTORS (CONTINUED)
*
DAC 0 DEFERRED EXPRESSION
DAC C$DEF
DAC LLUNO
*
DAC 3 BINARY PERCENT
DAC C$UBO
DAC LLPCT
DAC RRPCT
*
DAC 8 UNARY PERCENT
DAC C$UUO
DAC LLUNO
*
DAC O$EXP EXPONENTIATION
DAC C$BVL
DAC LLEXP
DAC RREXP
*
DAC 10 UNARY EXCLAMATION
DAC C$UUO
DAC LLUNO
*
DAC 4 BINARY NOT
DAC C$UBO
DAC LLNOT
DAC RRNOT
*
DAC 0 NEGATION
DAC C$NEG
DAC LLUNO
EJC
*
* OPERATOR DOPE VECTORS (CONTINUED)
*
DAC O$SUB SUBTRACTION
DAC C$BVL
DAC LLPLM
DAC RRPLM
*
DAC O$COM COMPLEMENTATION
DAC C$UVL
DAC LLUNO
*
DAC O$ADD ADDITION
DAC C$BVL
DAC LLPLM
DAC RRPLM
*
DAC O$AFF AFFIRMATION
DAC C$UVL
DAC LLUNO
*
DAC O$IMA IMMEDIATE ASSIGNMENT
DAC C$BVN
DAC LLDLD
DAC RRDLD
*
DAC O$INV INDIRECTION
DAC C$IND
DAC LLUNO
*
DAC O$PAS PATTERN ASSIGNMENT
DAC C$BVN
DAC LLDLD
DAC RRDLD
*
DAC O$NAM NAME REFERENCE
DAC C$UNM
DAC LLUNO
*
* SPECIAL DVS FOR GOTO OPERATORS (SEE PROCEDURE SCNGF)
*
OPDVD DAC O$GOD DIRECT GOTO
DAC C$UVL
DAC LLUNO
*
OPDVN DAC O$GOC COMPLEX NORMAL GOTO
DAC C$UNM
DAC LLUNO
EJC
*
* OPERATOR ENTRY ADDRESS POINTERS, USED IN CODE
*
OAMN$ DAC O$AMN ARRAY REF (MULTI-SUBS BY VALUE)
OAMV$ DAC O$AMV ARRAY REF (MULTI-SUBS BY VALUE)
OAON$ DAC O$AON ARRAY REF (ONE SUB BY NAME)
OAOV$ DAC O$AOV ARRAY REF (ONE SUB BY VALUE)
OCER$ DAC O$CER COMPILATION ERROR
OFEX$ DAC O$FEX FAILURE IN EXPRESSION EVALUATION
OFIF$ DAC O$FIF FAILURE DURING GOTO EVALUATION
OFNC$ DAC O$FNC FUNCTION CALL (MORE THAN ONE ARG)
OFNE$ DAC O$FNE FUNCTION NAME ERROR
OFNS$ DAC O$FNS FUNCTION CALL (SINGLE ARGUMENT)
OGOF$ DAC O$GOF SET GOTO FAILURE TRAP
OINN$ DAC O$INN INDIRECTION BY NAME
OKWN$ DAC O$KWN KEYWORD REFERENCE BY NAME
OLEX$ DAC O$LEX LOAD EXPRESSION BY NAME
OLPT$ DAC O$LPT LOAD PATTERN
OLVN$ DAC O$LVN LOAD VARIABLE NAME
ONTA$ DAC O$NTA NEGATION, FIRST ENTRY
ONTB$ DAC O$NTB NEGATION, SECOND ENTRY
ONTC$ DAC O$NTC NEGATION, THIRD ENTRY
OPMN$ DAC O$PMN PATTERN MATCH BY NAME
OPMS$ DAC O$PMS PATTERN MATCH (STATEMENT)
OPOP$ DAC O$POP POP TOP STACK ITEM
ORNM$ DAC O$RNM RETURN NAME FROM EXPRESSION
ORPL$ DAC O$RPL PATTERN REPLACEMENT
ORVL$ DAC O$RVL RETURN VALUE FROM EXPRESSION
OSLA$ DAC O$SLA SELECTION, FIRST ENTRY
OSLB$ DAC O$SLB SELECTION, SECOND ENTRY
OSLC$ DAC O$SLC SELECTION, THIRD ENTRY
OSLD$ DAC O$SLD SELECTION, FOURTH ENTRY
OSTP$ DAC O$STP STOP EXECUTION
OUNF$ DAC O$UNF UNEXPECTED FAILURE
EJC
*
* TABLE OF NAMES OF UNDEFINED BINARY OPERATORS FOR OPSYN
*
OPSNB DAC CH$AT AT
DAC CH$AM AMPERSAND
DAC CH$NM NUMBER
DAC CH$PC PERCENT
DAC CH$NT NOT
*
* TABLE OF NAMES OF UNDEFINED UNARY OPERATORS FOR OPSYN
*
OPNSU DAC CH$BR VERTICAL BAR
DAC CH$EQ EQUAL
DAC CH$NM NUMBER
DAC CH$PC PERCENT
DAC CH$SL SLASH
DAC CH$EX EXCLAMATION
.IF .CNPF
.ELSE
*
* ADDRESS CONST CONTAINING PROFILE TABLE ENTRY SIZE
*
PFI2A DAC PF$I2
*
* PROFILER MESSAGE STRINGS
*
PFMS1 DAC B$SCL
DAC 15
DDC /PROGRAM PROFILE/
PFMS2 DAC B$SCL
DAC 42
DDC /STMT NUMBER OF -- EXECUTION TIME --/
PFMS3 DAC B$SCL
DAC 47
DDC /NUMBER EXECUTIONS TOTAL(MSEC) PER EXCN(MCSEC)/
.FI
.IF .CNRA
.ELSE
*
* REAL CONSTANTS FOR GENERAL USE. NOTE THAT THE CONSTANTS
* STARTING AT REAV1 FORM A POWERS OF TEN TABLE (GTSTG)
*
REAV0 DRC +0.0 0.0
REAP1 DRC +0.1 0.1
REAP5 DRC +0.5 0.5
REAV1 DRC +1.0 10**0
REAVT DRC +1.0E+1 10**1
DRC +1.0E+2 10**2
DRC +1.0E+3 10**3
DRC +1.0E+4 10**4
DRC +1.0E+5 10**5
DRC +1.0E+6 10**6
DRC +1.0E+7 10**7
DRC +1.0E+8 10**8
DRC +1.0E+9 10**9
REATT DRC +1.0E+10 10**10
.FI
EJC
*
* STRING CONSTANTS (SCBLK FORMAT) FOR DTYPE PROCEDURE
*
SCARR DAC B$SCL ARRAY
DAC 5
DTC /ARRAY/
.IF .CNBF
.ELSE
*
SCBUF DAC B$SCL
DAC 6
DTC /BUFFER/
.FI
*
SCCOD DAC B$SCL CODE
DAC 4
DTC /CODE/
*
SCEXP DAC B$SCL EXPRESSION
DAC 10
DTC /EXPRESSION/
*
SCEXT DAC B$SCL EXTERNAL
DAC 8
DTC /EXTERNAL/
*
SCINT DAC B$SCL INTEGER
DAC 7
DTC /INTEGER/
*
SCNAM DAC B$SCL NAME
DAC 4
DTC /NAME/
*
SCNUM DAC B$SCL NUMERIC
DAC 7
DTC /NUMERIC/
*
SCPAT DAC B$SCL PATTERN
DAC 7
DTC /PATTERN/
.IF .CNRA
.ELSE
*
SCREA DAC B$SCL REAL
DAC 4
DTC /REAL/
.FI
*
SCSTR DAC B$SCL STRING
DAC 6
DTC /STRING/
*
SCTAB DAC B$SCL TABLE
DAC 5
DTC /TABLE/
EJC
*
* STRING CONSTANTS (SCBLK FORMAT) FOR KVRTN (SEE RETRN)
*
SCFRT DAC B$SCL FRETURN
DAC 7
DTC /FRETURN/
*
SCNRT DAC B$SCL NRETURN
DAC 7
DTC /NRETURN/
*
SCRTN DAC B$SCL RETURN
DAC 6
DTC /RETURN/
*
* DATATYPE NAME TABLE FOR DTYPE PROCEDURE. THE ORDER OF
* THESE ENTRIES IS TIED TO THE B$XXX DEFINITIONS FOR BLOCKS
*
SCNMT DAC SCARR ARBLK ARRAY
.IF .CNBF
.ELSE
DAC SCBUF BFBLK BUFFER
.FI
DAC SCCOD CDBLK CODE
DAC SCEXP EXBLK EXPRESSION
DAC SCINT ICBLK INTEGER
DAC SCNAM NMBLK NAME
DAC SCPAT P0BLK PATTERN
DAC SCPAT P1BLK PATTERN
DAC SCPAT P2BLK PATTERN
.IF .CNRA
.ELSE
DAC SCREA RCBLK REAL
.FI
DAC SCSTR SCBLK STRING
DAC SCEXP SEBLK EXPRESSION
DAC SCTAB TBBLK TABLE
DAC SCARR VCBLK ARRAY
DAC SCEXT XNBLK EXTERNAL
DAC SCEXT XRBLK EXTERNAL
*
.IF .CNRA
.ELSE
* STRING CONSTANT FOR REAL ZERO
*
SCRE0 DAC B$SCL
DAC 2
DTC /0./
.FI
EJC
*
* USED TO RE-INITIALISE KVSTL
*
.IF .CS16
STLIM DIC +32767 DEFAULT STATEMENT LIMIT
.ELSE
STLIM DIC +50000 DEFAULT STATEMENT LIMIT
.FI
*
* DUMMY FUNCTION BLOCK USED FOR UNDEFINED FUNCTIONS
*
STNDF DAC O$FUN PTR TO UNDEFINED FUNCTION ERR CALL
DAC 0 DUMMY FARGS COUNT FOR CALL CIRCUIT
*
* DUMMY CODE BLOCK USED FOR UNDEFINED LABELS
*
STNDL DAC L$UND CODE PTR POINTS TO UNDEFINED LBL
*
* DUMMY OPERATOR BLOCK USED FOR UNDEFINED OPERATORS
*
STNDO DAC O$OUN PTR TO UNDEFINED OPERATOR ERR CALL
DAC 0 DUMMY FARGS COUNT FOR CALL CIRCUIT
*
* STANDARD VARIABLE BLOCK. THIS BLOCK IS USED TO INITIALIZE
* THE FIRST SEVEN FIELDS OF A NEWLY CONSTRUCTED VRBLK.
* ITS FORMAT IS TIED TO THE VRBLK DEFINITIONS (SEE GTNVR).
*
STNVR DAC B$VRL VRGET
DAC B$VRS VRSTO
DAC NULLS VRVAL
DAC B$VRG VRTRA
DAC STNDL VRLBL
DAC STNDF VRFNC
DAC 0 VRNXT
EJC
*
* MESSAGES USED IN END OF RUN PROCESSING (STOPR)
*
STPM1 DAC B$SCL
DAC 12
DDC /IN STATEMENT/
*
STPM2 DAC B$SCL
DAC 14
DDC /STMTS EXECUTED/
*
STPM3 DAC B$SCL
DAC 13
.IF .CTMD
DDC /RUN TIME-DSEC/
.ELSE
DDC /RUN TIME-MSEC/
.FI
*
STPM4 DAC B$SCL
DAC 12
DDC $MCSEC / STMT$
*
STPM5 DAC B$SCL
DAC 13
DDC /REGENERATIONS/
*
* TABLE USED BY CONVERT FUNCTION TO CHECK DATATYPE NAME
* THE ENTRIES ARE ORDERED TO CORRESPOND TO BRANCH TABLE
* IN S$CNV
*
SVCTB DAC SCSTR STRING
DAC SCINT INTEGER
DAC SCNAM NAME
DAC SCPAT PATTERN
DAC SCARR ARRAY
DAC SCTAB TABLE
DAC SCEXP EXPRESSION
DAC SCCOD CODE
DAC SCNUM NUMERIC
.IF .CNRA
.ELSE
DAC SCREA REAL
.FI
.IF .CNBF
.ELSE
DAC SCBUF BUFFER
.FI
DAC 0 ZERO MARKS END OF LIST
EJC
*
* MESSAGES (SCBLK FORMAT) USED BY TRACE PROCEDURES
*
*
TMASB DAC B$SCL
DAC 13
DTC /************ /
*
TMBEB DAC B$SCL
DAC 3
DTC / = /
*
* DUMMY TRBLK FOR EXPRESSION VARIABLE
*
TRBEV DAC B$TRT DUMMY TRBLK
*
* DUMMY TRBLK FOR KEYWORD VARIABLE
*
TRBKV DAC B$TRT DUMMY TRBLK
*
* DUMMY CODE BLOCK TO RETURN CONTROL TO TRXEQ PROCEDURE
*
TRXDR DAC O$TXR BLOCK POINTS TO RETURN ROUTINE
TRXDC DAC TRXDR POINTER TO BLOCK
EJC
*
* STANDARD VARIABLE BLOCKS
*
* SEE SVBLK FORMAT FOR FULL DETAILS OF THE FORMAT. THE
* VRBLKS ARE ORDERED BY LENGTH AND WITHIN EACH LENGTH THE
* ORDER IS ALPHABETICAL BY NAME OF THE VARIABLE.
*
V$EQF DBC SVFPR EQ
DAC 2
DTC /EQ/
DAC S$EQF
DAC 2
*
V$GEF DBC SVFPR GE
DAC 2
DTC /GE/
DAC S$GEF
DAC 2
*
V$GTF DBC SVFPR GT
DAC 2
DTC /GT/
DAC S$GTF
DAC 2
*
V$LEF DBC SVFPR LE
DAC 2
DTC /LE/
DAC S$LEF
DAC 2
*
V$LTF DBC SVFPR LT
DAC 2
DTC /LT/
DAC S$LTF
DAC 2
*
V$NEF DBC SVFPR NE
DAC 2
DTC /NE/
DAC S$NEF
DAC 2
*
V$ANY DBC SVFNP ANY
DAC 3
DTC /ANY/
DAC S$ANY
DAC 1
*
V$ARB DBC SVKVC ARB
DAC 3
DTC /ARB/
DAC K$ARB
DAC NDARB
EJC
*
* STANDARD VARIABLE BLOCKS (CONTINUED)
*
V$ARG DBC SVFNN ARG
DAC 3
DTC /ARG/
DAC S$ARG
DAC 2
*
V$BAL DBC SVKVC BAL
DAC 3
DTC /BAL/
DAC K$BAL
DAC NDBAL
*
V$CTI DBC SVFNP CTI
DAC 3
DTC /CTI/
DAC S$CTI
DAC 1
*
V$END DBC SVLBL END
DAC 3
DTC /END/
DAC L$END
*
V$ITC DBC SVFNN ITC
DAC 3
DTC /ITC/
DAC S$ITC
DAC 1
*
V$LEN DBC SVFNP LEN
DAC 3
DTC /LEN/
DAC S$LEN
DAC 1
*
V$LEQ DBC SVFPR LEQ
DAC 3
DTC /LEQ/
DAC S$LEQ
DAC 2
*
V$LGE DBC SVFPR LGE
DAC 3
DTC /LGE/
DAC S$LGE
DAC 2
*
V$LGT DBC SVFPR LGT
DAC 3
DTC /LGT/
DAC S$LGT
DAC 2
*
V$LLE DBC SVFPR LLE
DAC 3
DTC /LLE/
DAC S$LLE
DAC 2
EJC
*
* STANDARD VARIABLE BLOCKS (CONTINUED)
*
V$LLT DBC SVFPR LLT
DAC 3
DTC /LLT/
DAC S$LLT
DAC 2
*
V$LNE DBC SVFPR LNE
DAC 3
DTC /LNE/
DAC S$LNE
DAC 2
*
V$POS DBC SVFNP POS
DAC 3
DTC /POS/
DAC S$POS
DAC 1
*
V$REM DBC SVKVC REM
DAC 3
DTC /REM/
DAC K$REM
DAC NDREM
.IF .CUST
*
V$SET DBC SVFNN SET
DAC 3
DTC /SET/
DAC S$SET
DAC 3
.FI
*
V$TAB DBC SVFNP TAB
DAC 3
DTC /TAB/
DAC S$TAB
DAC 1
*
V$COD DBC SVFNK CODE
DAC 4
DTC /CODE/
DAC K$COD
DAC S$COD
DAC 1
*
V$COP DBC SVFNN COPY
DAC 4
DTC /COPY/
DAC S$COP
DAC 1
EJC
*
* STANDARD VARIABLE BLOCKS (CONTINUED)
*
V$DAT DBC SVFNN DATA
DAC 4
DTC /DATA/
DAC S$DAT
DAC 1
*
V$DTE DBC SVFNN DATE
DAC 4
DTC /DATE/
DAC S$DTE
DAC 0
*
V$DMP DBC SVFNK DUMP
DAC 4
DTC /DUMP/
DAC K$DMP
DAC S$DMP
DAC 1
*
V$DUP DBC SVFNN DUPL
DAC 4
DTC /DUPL/
DAC S$DUP
DAC 2
*
V$EVL DBC SVFNN EVAL
DAC 4
DTC /EVAL/
DAC S$EVL
DAC 1
.IF .CNEX
.ELSE
*
V$EXT DBC SVFNN EXIT
DAC 4
DTC /EXIT/
DAC S$EXT
DAC 1
.FI
*
V$FAL DBC SVKVC FAIL
DAC 4
DTC /FAIL/
DAC K$FAL
DAC NDFAL
*
V$HST DBC SVFNN HOST
DAC 4
DTC /HOST/
DAC S$HST
DAC 3
EJC
*
* STANDARD VARIABLE BLOCKS (CONTINUED)
*
V$ITM DBC SVFNF ITEM
DAC 4
DTC /ITEM/
DAC S$ITM
DAC 999
.IF .CNLD
.ELSE
*
V$LOD DBC SVFNN LOAD
DAC 4
DTC /LOAD/
DAC S$LOD
DAC 2
.FI
*
V$LPD DBC SVFNP LPAD
DAC 4
DTC /LPAD/
DAC S$LPD
DAC 3
*
V$RPD DBC SVFNP RPAD
DAC 4
DTC /RPAD/
DAC S$RPD
DAC 3
EJC
*
* STANDARD VARIABLE BLOCKS (CONTINUED)
*
*
V$RPS DBC SVFNP RPOS
DAC 4
DTC /RPOS/
DAC S$RPS
DAC 1
*
V$RTB DBC SVFNP RTAB
DAC 4
DTC /RTAB/
DAC S$RTB
DAC 1
*
V$SI$ DBC SVFNP SIZE
DAC 4
DTC /SIZE/
DAC S$SI$
DAC 1
*
.IF .CNSR
.ELSE
*
V$SRT DBC SVFNN SORT
DAC 4
DTC /SORT/
DAC S$SRT
DAC 2
.FI
V$SPN DBC SVFNP SPAN
DAC 4
DTC /SPAN/
DAC S$SPN
DAC 1
EJC
*
* STANDARD VARIABLE BLOCKS (CONTINUED)
*
V$STN DBC SVKNM STNO
DAC 4
DTC /STNO/
DAC K$STN
*
V$TIM DBC SVFNN TIME
DAC 4
DTC /TIME/
DAC S$TIM
DAC 0
*
V$TRM DBC SVFNK TRIM
DAC 4
DTC /TRIM/
DAC K$TRM
DAC S$TRM
DAC 1
*
V$ABO DBC SVKVL ABORT
DAC 5
DTC /ABORT/
DAC K$ABO
DAC L$ABO
DAC NDABO
*
V$APP DBC SVFNF APPLY
DAC 5
DTC /APPLY/
DAC S$APP
DAC 999
*
V$ABN DBC SVFNP ARBNO
DAC 5
DTC /ARBNO/
DAC S$ABN
DAC 1
*
V$ARR DBC SVFNN ARRAY
DAC 5
DTC /ARRAY/
DAC S$ARR
DAC 2
EJC
*
* STANDARD VARIABLE BLOCKS (CONTINUED)
*
V$BRK DBC SVFNP BREAK
DAC 5
DTC /BREAK/
DAC S$BRK
DAC 1
*
V$CLR DBC SVFNN CLEAR
DAC 5
DTC /CLEAR/
DAC S$CLR
DAC 1
*
V$EJC DBC SVFNN EJECT
DAC 5
DTC /EJECT/
DAC S$EJC
DAC 1
*
.IF .CNFN
V$FEN DBC SVKVC FENCE
.ELSE
V$FEN DBC SVFPK FENCE
.FI
DAC 5
DTC /FENCE/
DAC K$FEN
.IF .CNFN
.ELSE
DAC S$FNC
DAC 1
.FI
DAC NDFEN
*
V$FLD DBC SVFNN FIELD
DAC 5
DTC /FIELD/
DAC S$FLD
DAC 2
*
V$IDN DBC SVFPR IDENT
DAC 5
DTC /IDENT/
DAC S$IDN
DAC 2
*
V$INP DBC SVFNK INPUT
DAC 5
DTC /INPUT/
DAC K$INP
DAC S$INP
DAC 3
*
V$LOC DBC SVFNN LOCAL
DAC 5
DTC /LOCAL/
DAC S$LOC
DAC 2
EJC
* STANDARD VARIABLE BLOCKS (CONTINUED)
*
V$OPS DBC SVFNN OPSYN
DAC 5
DTC /OPSYN/
DAC S$OPS
DAC 3
*
V$RMD DBC SVFNP REMDR
DAC 5
DTC /REMDR/
DAC S$RMD
DAC 2
.IF .CNSR
.ELSE
*
V$RSR DBC SVFNN RSORT
DAC 5
DTC /RSORT/
DAC S$RSR
DAC 2
.FI
*
V$TBL DBC SVFNN TABLE
DAC 5
DTC /TABLE/
DAC S$TBL
DAC 3
*
V$TRA DBC SVFNK TRACE
DAC 5
DTC /TRACE/
DAC K$TRA
DAC S$TRA
DAC 4
*
V$ANC DBC SVKNM ANCHOR
DAC 6
DTC /ANCHOR/
DAC K$ANC
EJC
*
* STANDARD VARIABLE BLOCKS (CONTINUED)
*
.IF .CNBF
.ELSE
V$APN DBC SVFNN APPEND
DAC 6
DTC /APPEND/
DAC S$APN
DAC 2
.FI
*
V$BKX DBC SVFNP BREAKX
DAC 6
DTC /BREAKX/
DAC S$BKX
DAC 1
.IF .CNBF
.ELSE
V$BUF DBC SVFNN BUFFER
DAC 6
DTC /BUFFER/
DAC S$BUF
DAC 2
.FI
*
V$DEF DBC SVFNN DEFINE
DAC 6
DTC /DEFINE/
DAC S$DFN
DAC 2
*
V$DET DBC SVFNN DETACH
DAC 6
DTC /DETACH/
DAC S$DET
DAC 1
*
V$DIF DBC SVFPR DIFFER
DAC 6
DTC /DIFFER/
DAC S$DIF
DAC 2
*
V$FTR DBC SVKNM FTRACE
DAC 6
DTC /FTRACE/
DAC K$FTR
EJC
.IF .CNBF
.ELSE
*
V$INS DBC SVFNN INSERT
DAC 6
DTC /INSERT/
DAC S$INS
DAC 4
.FI
*
V$LST DBC SVKNM LASTNO
DAC 6
DTC /LASTNO/
DAC K$LST
*
V$NAY DBC SVFNP NOTANY
DAC 6
DTC /NOTANY/
DAC S$NAY
DAC 1
*
V$OUP DBC SVFNK OUTPUT
DAC 6
DTC /OUTPUT/
DAC K$OUP
DAC S$OUP
DAC 3
*
V$RET DBC SVLBL RETURN
DAC 6
DTC /RETURN/
DAC L$RTN
*
V$STT DBC SVFNN STOPTR
DAC 6
DTC /STOPTR/
DAC S$STT
DAC 2
EJC
*
* STANDARD VARIABLE BLOCKS (CONTINUED)
*
V$SUB DBC SVFNN SUBSTR
DAC 6
DTC /SUBSTR/
DAC S$SUB
DAC 3
*
V$UNL DBC SVFNN UNLOAD
DAC 6
DTC /UNLOAD/
DAC S$UNL
DAC 1
*
V$COL DBC SVFNN COLLECT
DAC 7
DTC /COLLECT/
DAC S$COL
DAC 1
*
V$CNV DBC SVFNN CONVERT
DAC 7
DTC /CONVERT/
DAC S$CVT
DAC 2
*
V$ENF DBC SVFNN ENDFILE
DAC 7
DTC /ENDFILE/
DAC S$ENF
DAC 2
*
V$ETX DBC SVKNM ERRTEXT
DAC 7
DTC /ERRTEXT/
DAC K$ETX
*
V$ERT DBC SVKNM ERRTYPE
DAC 7
DTC /ERRTYPE/
DAC K$ERT
*
V$FRT DBC SVLBL FRETURN
DAC 7
DTC /FRETURN/
DAC L$FRT
*
V$INT DBC SVFPR INTEGER
DAC 7
DTC /INTEGER/
DAC S$INT
DAC 1
*
V$NRT DBC SVLBL NRETURN
DAC 7
DTC /NRETURN/
DAC L$NRT
EJC
*
* STANDARD VARIABLE BLOCKS (CONTINUED)
.IF .CNPF
.ELSE
*
V$PFL DBC SVKNM PROFILE
DAC 7
DTC /PROFILE/
DAC K$PFL
.FI
*
*
V$RPL DBC SVFNP REPLACE
DAC 7
DTC /REPLACE/
DAC S$RPL
DAC 3
*
V$RVS DBC SVFNP REVERSE
DAC 7
DTC /REVERSE/
DAC S$RVS
DAC 1
*
V$RTN DBC SVKNM RTNTYPE
DAC 7
DTC /RTNTYPE/
DAC K$RTN
*
V$STX DBC SVFNN SETEXIT
DAC 7
DTC /SETEXIT/
DAC S$STX
DAC 1
*
V$STC DBC SVKNM STCOUNT
DAC 7
DTC /STCOUNT/
DAC K$STC
*
V$STL DBC SVKNM STLIMIT
DAC 7
DTC /STLIMIT/
DAC K$STL
*
V$SUC DBC SVKVC SUCCEED
DAC 7
DTC /SUCCEED/
DAC K$SUC
DAC NDSUC
*
V$VDF DBC SVFPR VDIFFER
DAC 7
DTC /VDIFFER/
DAC S$VDF
DAC 2
*
V$ALP DBC SVKWC ALPHABET
DAC 8
DTC /ALPHABET/
DAC K$ALP
EJC
*
* STANDARD VARIABLE BLOCKS (CONTINUED)
*
V$CNT DBC SVLBL CONTINUE
DAC 8
DTC /CONTINUE/
DAC L$CNT
*
V$DTP DBC SVFNP DATATYPE
DAC 8
DTC /DATATYPE/
DAC S$DTP
DAC 1
*
V$ERL DBC SVKNM ERRLIMIT
DAC 8
DTC /ERRLIMIT/
DAC K$ERL
*
V$FNC DBC SVKNM FNCLEVEL
DAC 8
DTC /FNCLEVEL/
DAC K$FNC
*
V$MXL DBC SVKNM MAXLNGTH
DAC 8
DTC /MAXLNGTH/
DAC K$MXL
*
V$TER DBC 0 TERMINAL
DAC 8
DTC /TERMINAL/
DAC 0
*
V$PRO DBC SVFNN PROTOTYPE
DAC 9
DTC /PROTOTYPE/
DAC S$PRO
DAC 1
*
DBC 0 DUMMY ENTRY TO END LIST
DAC 10 LENGTH GT 9 (PROTOTYPE)
EJC
*
* LIST OF SVBLK POINTERS FOR KEYWORDS TO BE DUMPED. THE
* LIST IS IN THE ORDER WHICH APPEARS ON THE DUMP OUTPUT.
*
VDMKW DAC V$ANC ANCHOR
DAC V$COD CODE
DAC V$DMP DUMP
DAC V$ERL ERRLIMIT
DAC V$ETX ERRTEXT
DAC V$ERT ERRTYPE
DAC V$FNC FNCLEVEL
DAC V$FTR FTRACE
DAC V$INP INPUT
DAC V$LST LASTNO
DAC V$MXL MAXLENGTH
DAC V$OUP OUTPUT
.IF .CNPF
.ELSE
DAC V$PFL PROFILE
.FI
DAC V$RTN RTNTYPE
DAC V$STC STCOUNT
DAC V$STL STLIMIT
DAC V$STN STNO
DAC V$TRA TRACE
DAC V$TRM TRIM
DAC 0 END OF LIST
*
* TABLE USED BY GTNVR TO SEARCH SVBLK LISTS
*
VSRCH DAC 0 DUMMY ENTRY TO GET PROPER INDEXING
DAC V$EQF START OF 1 CHAR VARIABLES (NONE)
DAC V$EQF START OF 2 CHAR VARIABLES
DAC V$ANY START OF 3 CHAR VARIABLES
DAC V$COD START OF 4 CHAR VARIABLES
DAC V$ABO START OF 5 CHAR VARIABLES
DAC V$ANC START OF 6 CHAR VARIABLES
DAC V$COL START OF 7 CHAR VARIABLES
DAC V$ALP START OF 8 CHAR VARIABLES
DAC V$PRO START OF 9 CHAR VARIABLES
TTL S P I T B O L -- WORKING STORAGE SECTION
*
* THE WORKING STORAGE SECTION CONTAINS AREAS WHICH ARE
* CHANGED DURING EXECUTION OF THE PROGRAM. THE VALUE
* ASSEMBLED IS THE INITIAL VALUE BEFORE EXECUTION STARTS.
*
* ALL THESE AREAS ARE FIXED LENGTH AREAS. VARIABLE LENGTH
* DATA IS STORED IN THE STATIC OR DYNAMIC REGIONS OF THE
* ALLOCATED DATA AREAS.
*
* THE VALUES IN THIS AREA ARE DESCRIBED EITHER AS WORK
* AREAS OR AS GLOBAL VALUES. A WORK AREA IS USED IN AN
* EPHEMERAL MANNER AND THE VALUE IS NOT SAVED FROM ONE
* ENTRY INTO A ROUTINE TO ANOTHER. A GLOBAL VALUE IS A
* LESS TEMPORARY LOCATION WHOSE VALUE IS SAVED FROM ONE
* CALL TO ANOTHER.
*
* A GENERAL PART OF THE APPROACH IN THIS PROGRAM IS NOT
* TO OVERLAP WORK AREAS BETWEEN PROCEDURES EVEN THOUGH A
* SMALL AMOUNT OF SPACE COULD BE SAVED. SUCH OVERLAP IS
* CONSIDERED A SOURCE OF PROGRAM ERRORS AND DECREASES THE
* INFORMATION LEFT BEHIND AFTER A SYSTEM CRASH OF ANY KIND.
*
* THE NAMES OF THESE LOCATIONS ARE LABELS WITH FIVE LETTER
* (A-Y,$) NAMES. AS FAR AS POSSIBLE THE ORDER IS KEPT
* ALPHABETICAL BY THESE NAMES BUT IN SOME CASES THERE
* ARE SLIGHT DEPARTURES CAUSED BY OTHER ORDER REQUIREMENTS.
*
* UNLESS OTHERWISE DOCUMENTED, THE ORDER OF WORK AREAS
* DOES NOT AFFECT THE EXECUTION OF THE SPITBOL PROGRAM.
*
SEC START OF WORKING STORAGE SECTION
EJC
*
* THIS AREA IS NOT CLEARED BY INITIAL CODE
*
CMLAB DAC B$SCL STRING USED TO CHECK LABEL LEGALITY
DAC 2
DTC / /
*
* LABEL TO MARK START OF WORK AREA WHICH IS CLEARED
*
AAAAA DAC 0
*
* WORK AREAS FOR ALLOC PROCEDURE
*
ALDYN DAC 0 AMOUNT OF DYNAMIC STORE
ALFSF DIC +0 FACTOR IN FREE STORE PCNTAGE CHECK
ALLIA DIC +0 DUMP IA
ALLSV DAC 0 SAVE WB IN ALLOC
*
* WORK AREAS FOR ALOST PROCEDURE
*
ALSTA DAC 0 SAVE WA IN ALOST
*
* SAVE AREAS FOR ARRAY FUNCTION (S$ARR)
*
ARCDM DAC 0 COUNT DIMENSIONS
ARNEL DIC +0 COUNT ELEMENTS
ARPTR DAC 0 OFFSET PTR INTO ARBLK
ARSVL DIC +0 SAVE INTEGER LOW BOUND
EJC
* WORK AREAS FOR ARREF ROUTINE
*
ARFSI DIC +0 SAVE CURRENT EVOLVING SUBSCRIPT
ARFXS DAC 0 SAVE BASE STACK POINTER
*
* WORK AREAS FOR B$EFC BLOCK ROUTINE
*
BEFOF DAC 0 SAVE OFFSET PTR INTO EFBLK
*
* WORK AREAS FOR B$PFC BLOCK ROUTINE
*
BPFPF DAC 0 SAVE PFBLK POINTER
BPFSV DAC 0 SAVE OLD FUNCTION VALUE
BPFXT DAC 0 POINTER TO STACKED ARGUMENTS
*
* SAVE AREAS FOR COLLECT FUNCTION (S$COL)
*
CLSVI DIC +0 SAVE INTEGER ARGUMENT
*
* GLOBAL VALUES FOR CMPIL PROCEDURE
*
CMERC DAC 0 COUNT OF INITIAL COMPILE ERRORS
CMPXS DAC 0 SAVE STACK PTR IN CASE OF ERRORS
CMPSN DAC 1 NUMBER OF NEXT STATEMENT TO COMPILE
CMPSS DAC 0 SAVE SUBROUTINE STACK PTR
*
* WORK AREA FOR CNCRD
*
CNSCC DAC 0 POINTER TO CONTROL CARD STRING
CNSWC DAC 0 WORD COUNT
CNR$T DAC 0 POINTER TO R$TTL OR R$STL
CNTTL DAC 0 FLAG FOR -TITLE, -STITL
*
* WORK AREAS FOR CONVERT FUNCTION (S$CNV)
*
CNVTP DAC 0 SAVE PTR INTO SCVTB
*
* FLAG FOR SUPPRESSION OF COMPILATION STATISTICS.
*
CPSTS DAC 0 SUPPRESS COMP. STATS IF NON ZERO
*
* GLOBAL VALUES FOR CONTROL CARD SWITCHES
*
.IF .CASL
CSWCI DAC 0 0/1 FOR -NOCASEIG/CASEIG
.FI
CSWFL DAC 1 0/1 FOR -NOFAIL/-FAIL
CSWIN DAC INILN XXX FOR -INXXX
CSWLS DAC 1 0/1 FOR -NOLIST/-LIST
EJC
*
* GLOBAL LOCATION USED BY PATST PROCEDURE
*
CTMSK DBC 0 LAST BIT POSITION USED IN R$CTP
CURID DAC 0 CURRENT ID VALUE
*
* GLOBAL VALUE FOR CDWRD PROCEDURE
*
CWCOF DAC 0 NEXT WORD OFFSET IN CURRENT CCBLK
*
* WORK AREAS FOR DATA FUNCTION (S$DAT)
*
DATDV DAC 0 SAVE VRBLK PTR FOR DATATYPE NAME
DATXS DAC 0 SAVE INITIAL STACK POINTER
*
* WORK AREAS FOR DEFINE FUNCTION (S$DEF)
*
DEFLB DAC 0 SAVE VRBLK PTR FOR LABEL
DEFNA DAC 0 COUNT FUNCTION ARGUMENTS
DEFVR DAC 0 SAVE VRBLK PTR FOR FUNCTION NAME
DEFXS DAC 0 SAVE INITIAL STACK POINTER
*
* WORK AREAS FOR DUMPR PROCEDURE
*
DMARG DAC 0 DUMP ARGUMENT
DMPKB DAC B$KVT DUMMY KVBLK FOR USE IN DUMPR
DMPKT DAC TRBKV KVVAR TRBLK POINTER
DMPKN DAC 0 KEYWORD NUMBER (MUST FOLLOW DMPKB)
DMPSA DAC 0 PRESERVE WA OVER PRTVL CALL
DMPSV DAC 0 GENERAL SCRATCH SAVE
DMVCH DAC 0 CHAIN POINTER FOR VARIABLE BLOCKS
DMPCH DAC 0 SAVE SORTED VRBLK CHAIN POINTER
*
* GLOBAL LOCATIONS FOR DYNAMIC STORAGE POINTERS
*
DNAMB DAC 0 START OF DYNAMIC AREA
DNAMP DAC 0 NEXT AVAILABLE LOC IN DYNAMIC AREA
DNAME DAC 0 END OF AVAILABLE DYNAMIC AREA
*
* WORK AREAS FOR DUPL FUNCTION (S$DUP)
*
DUPSI DIC +0 STORE INTEGER STRING LENGTH
*
* WORK AREA FOR ENDFILE (S$ENF)
*
ENFCH DAC 0 FOR IOCHN CHAIN HEAD
*
* WORK AREA FOR ERROR PROCESSING.
*
EROSN DAC 0 FLAG FOR SPECIAL EROSI RETURN
ERRFT DAC 0 FATAL ERROR FLAG
ERRSP DAC 0 ERROR SUPPRESSION FLAG
EJC
*
* DUMP AREA FOR ERTEX
*
ERTWA DAC 0 SAVE WA
ERTWB DAC 0 SAVE WB
*
* GLOBAL VALUES FOR EVALI
*
EVLIN DAC P$LEN DUMMY PATTERN BLOCK PCODE
EVLIS DAC 0 POINTER TO SUBSEQUENT NODE
EVLIV DAC 0 VALUE OF PARAMETER
*
* WORK AREA FOR EXPAN
*
EXPSV DAC 0 SAVE OP DOPE VECTOR POINTER
*
* FLAG FOR SUPPRESSION OF EXECUTION STATS
*
EXSTS DAC 0 SUPPRESS EXEC STATS IF SET
*
* GLOBAL VALUES FOR EXFAL AND RETURN
*
FLPRT DAC 0 LOCATION OF FAIL OFFSET FOR RETURN
FLPTR DAC 0 LOCATION OF FAILURE OFFSET ON STACK
*
* WORK AREAS FOR GBCOL PROCEDURE
*
GBCFL DAC 0 GARBAGE COLLECTOR ACTIVE FLAG
GBCLM DAC 0 POINTER TO LAST MOVE BLOCK (PASS 3)
GBCNM DAC 0 DUMMY FIRST MOVE BLOCK
GBCNS DAC 0 REST OF DUMMY BLOCK (FOLLOWS GBCNM)
GBSVA DAC 0 SAVE WA
GBSVB DAC 0 SAVE WB
GBSVC DAC 0 SAVE WC
*
* GLOBAL LOCATION TO COUNT GARBAGE COLLECTIONS (GBCOL)
*
GBCNT DAC 0 COUNT OF GARBAGE COLLECTIONS
*
* WORK AREAS FOR GTNVR PROCEDURE
*
GNVHE DAC 0 PTR TO END OF HASH CHAIN
GNVNW DAC 0 NUMBER OF WORDS IN STRING NAME
GNVSA DAC 0 SAVE WA
GNVSB DAC 0 SAVE WB
GNVSP DAC 0 POINTER INTO VSRCH TABLE
GNVST DAC 0 POINTER TO CHARS OF STRING
*
* GLOBAL VALUE FOR GTCOD AND GTEXP
*
GTCEF DAC 0 SAVE FAIL PTR IN CASE OF ERROR
*
* WORK AREAS FOR GTINT
*
GTINA DAC 0 SAVE WA
GTINB DAC 0 SAVE WB
EJC
*
* WORK AREAS FOR GTNUM PROCEDURE
*
GTNNF DAC 0 ZERO/NONZERO FOR RESULT +/-
GTNSI DIC +0 GENERAL INTEGER SAVE
.IF .CNRA
.ELSE
GTNDF DAC 0 0/1 FOR DEC POINT SO FAR NO/YES
GTNES DAC 0 ZERO/NONZERO EXPONENT +/-
GTNEX DIC +0 REAL EXPONENT
GTNSC DAC 0 SCALE (PLACES AFTER POINT)
GTNSR DRC +0.0 GENERAL REAL SAVE
GTNSV DIC +0 SAVE IA
GTNRD DAC 0 FLAG FOR OK REAL NUMBER
.FI
*
* WORK AREAS FOR GTPAT PROCEDURE
*
GTPSB DAC 0 SAVE WB
*
* WORK AREAS FOR GTSTG PROCEDURE
*
GTSSF DAC 0 0/1 FOR RESULT +/-
GTSVC DAC 0 SAVE WC
GTSVB DAC 0 SAVE WB
GTSWK DAC 0 PTR TO WORK AREA FOR GTSTG
.IF .CNRA
.ELSE
GTSES DAC 0 CHAR + OR - FOR EXPONENT +/-
GTSRS DRC +0.0 GENERAL REAL SAVE
*
* GLOBAL LOCATIONS (CONSTANTS) FOR GTSTG PROCEDURE
*
GTSRN DRC +0.0 ROUNDING FACTOR 0.5*10**-CFP$S
GTSSC DRC +0.0 SCALING VALUE 10**CFP$S
.FI
EJC
*
* WORK AREAS FOR GTVAR PROCEDURE
*
GTVRC DAC 0 SAVE WC
*
* FLAGS FOR HEADER PRINTING
*
HEADN DAC 0 NON-ZERO IF HDRS NOT TO BE PRINTED
HEADP DAC 0 HEADER PRINTED FLAG
*
* GLOBAL VALUES FOR VARIABLE HASH TABLE
*
HSHNB DIC +0 NUMBER OF HASH BUCKETS
HSHTB DAC 0 POINTER TO START OF VRBLK HASH TABL
HSHTE DAC 0 POINTER PAST END OF VRBLK HASH TABL
*
* WORK AREA FOR INIT
*
INICD DIC +0 CODE KWD VAL (NEEDED FOR BATCH)
INISS DAC 0 SAVE SUBROUTINE STACK PTR
INITR DAC 0 SAVE TERMINAL FLAG
.IF .CNBF
.ELSE
*
* SAVE AREA FOR INSBF
*
INSAB DAC 0 ENTRY WA PLUS ENTRY WB
INSBB DAC 0 BFBLK POINTER
INSBC DAC 0 BCBLK POINTER
INSSA DAC 0 SAVE ENTRY WA
INSSB DAC 0 SAVE ENTRY WB
.FI
*
* WORK AREAS FOR IOPUT
*
IOPNF DAC 0 NAME OFFSET
IOPVR DAC 0 FILETAG VRBLK
IOPWA DAC 0 KEEP WA
IOPWB DAC 0 KEEP WB
IOPWC DAC 0 KEEP WC
EJC
*
* GLOBAL VALUES FOR KEYWORD VALUES WHICH ARE STORED AS ONE
* WORD INTEGERS. THESE VALUES MUST BE ASSEMBLED IN THE
* FOLLOWING ORDER (AS DICTATED BY K$XXX DEFINITION VALUES).
*
KVANC DAC 0 ANCHOR
KVDMP DAC 0 DUMP
KVERL DAC 0 ERRLIMIT
KVERT DAC 0 ERRTYPE
KVFTR DAC 0 FTRACE
KVINP DAC 1 INPUT
KVMXL DAC 5000 MAXLENGTH
KVOUP DAC 1 OUTPUT
.IF .CNPF
.ELSE
KVPFL DAC 0 PROFILE
.FI
KVTRA DAC 0 TRACE
KVTRM DAC 0 TRIM
KVFNC DAC 0 FNCLEVEL
KVLST DAC 0 LASTNO
KVSTN DAC 0 STNO
*
* GLOBAL VALUES FOR OTHER KEYWORDS
*
KVALP DAC 0 ALPHABET
KVRTN DAC NULLS RTNTYPE (SCBLK POINTER)
KVCOD DIC 0 CODE
.IF .CS16
KVSTL DIC +32767 STLIMIT
KVSTC DIC +32767 STCOUNT (COUNTS DOWN FROM STLIMIT)
.ELSE
KVSTL DIC +50000 STLIMIT
KVSTC DIC +50000 STCOUNT (COUNTS DOWN FROM STLIMIT)
.FI
.IF .CNLD
.ELSE
*
* WORK AREAS FOR LOAD FUNCTION
*
LODFN DAC 0 POINTER TO VRBLK FOR FUNC NAME
LODNA DAC 0 COUNT NUMBER OF ARGUMENTS
.FI
EJC
*
* GLOBAL VALUES FOR LISTR PROCEDURE
*
LSTLC DAC 0 COUNT LINES ON SOURCE LIST PAGE
LSTNP DAC 0 MAX NUMBER OF LINES ON PAGE
LSTPF DAC 1 SET NONZERO IF CURRENT IMAGE LISTED
LSTPG DAC 0 CURRENT SOURCE LIST PAGE NUMBER
LSTPO DAC 0 OFFSET TO PAGE NNN MESSAGE
LSTSN DAC 0 REMEMBER LAST STMNUM LISTED
*
* MAXIMUM SIZE OF SPITBOL OBJECTS
*
MXLEN DAC 0 INITIALISED BY SYSMX CALL
*
* EXECUTION CONTROL VARIABLE
*
NOXEQ DAC 0 SET NON-ZERO TO INHIBIT EXECUTION
.IF .CNPF
.ELSE
*
* PROFILER GLOBAL VALUES AND WORK LOCATIONS
*
PFDMP DAC 0 SET NON-0 IF PROFILE SET NON-0
PFFNC DAC 0 SET NON-0 IF FUNCT JUST ENTERED
PFSTM DIC +0 TO STORE STARTING TIME OF STMT
PFETM DIC +0 TO STORE ENDING TIME OF STMT
PFSVW DAC 0 TO SAVE A W-REG
PFTBL DAC 0 GETS ADRS OF (IMAG) TABLE BASE
PFNTE DAC 0 NR OF TABLE ENTRIES
PFSTE DIC +0 TABLE ENTRY SIZE IN BAUS
.FI
EJC
*
* GLOBAL VALUES USED IN PATTERN MATCH ROUTINES
*
PMDFL DAC 0 PATTERN ASSIGNMENT FLAG
PMHBS DAC 0 HISTORY STACK BASE POINTER
PMSSL DAC 0 LENGTH OF SUBJECT STRING IN CHARS
*
* GLOBAL VALUE FOR PRTNM PROCEDURE
*
PRNMV DAC 0 VRBLK PTR FROM LAST NAME SEARCH
*
* WORK AREAS FOR PRTNM PROCEDURE
*
PRNSI DIC +0 SCRATCH INTEGER LOC
*
* WORK AREAS FOR PRTSN PROCEDURE
*
PRSNA DAC 0 SAVE WA
*
* GLOBAL VALUES FOR PRINT PROCEDURES
*
PRAVL DAC 0 SET IF PRINT FILE AVAILABLE
PRBLK DAC 0 ADDRESS OF BUFFER BLANKING STRING
PRBUF DAC 0 PTR TO PRINT BFR IN STATIC
PRCHS DAC 0 ADDRESS OF CHARS IN PRINT BUFFER
PRCMV DAC 0 NO. OF BAUS TO MOVE IN BFR CLEARING
PRECL DAC 0 EXTENDED/COMPACT LISTING FLAG
PRLEN DAC 0 LENGTH OF PRINT BUFFER IN CHARS
PROFS DAC 0 OFFSET TO NEXT LOCATION IN PRBUF
PRPUT DAC 0 SET IF CHARS TO BE PUT IN BFR
PRSTD DAC 0 TESTED BY PRTPG
PRSTO DAC 0 STANDARD LISTING OPTION FLAG
PRTEF DAC 0 ENDFILE FLAG
*
* WORK AREAS FOR PRTST, PTTST PROCEDURES
*
PRSVA DAC 0 SAVE WA
PRSVB DAC 0 SAVE WB
PRTVA DAC 0 SAVE WA
PRTVB DAC 0 SAVE WB
*
* WORK AREA FOR PRTVL
*
PRVSI DAC 0 SAVE IDVAL
*
* WORK AREAS FOR PATTERN MATCH ROUTINES
*
PSAVE DAC 0 TEMPORARY SAVE FOR CURRENT NODE PTR
PSAVC DAC 0 SAVE CURSOR IN P$SPN, P$STR
EJC
*
* FLAG TO TELL ERROR THAT WE ARE READING SOURCE LINE
*
RDRER DAC 0 READ-SOURCE-LINE IN PROGRESS FLAG
*
* AMOUNT OF MEMORY RESERVED FOR END OF EXECUTION
*
RSMEM DAC 0 RESERVE MEMORY
*
* WORK AREAS FOR RETRN ROUTINE
*
RTNBP DAC 0 TO SAVE A BLOCK POINTER
RTNFV DAC 0 NEW FUNCTION VALUE (RESULT)
RTNSV DAC 0 OLD FUNCTION VALUE (SAVED VALUE)
*
* RELOCATABLE GLOBAL VALUES
*
* ALL THE POINTERS IN THIS SECTION CAN POINT TO BLOCKS IN
* THE DYNAMIC STORAGE AREA AND MUST BE RELOCATED BY THE
* GARBAGE COLLECTOR. THEY ARE IDENTIFIED BY R$XXX NAMES.
*
R$AAA DAC 0 START OF RELOCATABLE VALUES
R$ARF DAC 0 ARRAY BLOCK POINTER FOR ARREF
R$CCB DAC 0 PTR TO CCBLK BEING BUILT (CDWRD)
R$CIM DAC 0 PTR TO CURRENT COMPILER INPUT STR
R$CMP DAC 0 COPY OF R$CIM USED IN CMPIL
R$CNI DAC 0 PTR TO NEXT COMPILER INPUT STRING
R$CNT DAC 0 CDBLK POINTER FOR SETEXIT CONTINUE
R$COD DAC 0 POINTER TO CURRENT CDBLK OR EXBLK
R$COP DAC 0 PTR TO -COPY CHAIN STACK
R$CTP DAC 0 PTR TO CURRENT CTBLK FOR PATST
R$ERT DAC 0 TRBLK POINTER FOR ERRTYPE TRACE
R$ETX DAC NULLS POINTER TO ERRTEXT STRING
R$EXS DAC 0 = SAVE XL IN EXPDM
R$FNC DAC 0 TRBLK POINTER FOR FNCLEVEL TRACE
R$GTC DAC 0 KEEP CODE PTR FOR GTCOD,GTEXP
R$IO1 DAC 0 FIRST ARGUMENT
R$IOL DAC 0 SECOND ARGUMENT (FILETAG) SCBLK PTR
R$IOR DAC 0 FILEPROPS SCBLK PTR
R$IOT DAC 0 TRTIO TRACE BLK PTR
.IF .CNBF
.ELSE
R$PMB DAC 0 BUFFER PTR IN PATTERN MATCH
.FI
R$PMS DAC 0 SUBJECT STRING PTR IN PATTERN MATCH
R$RA2 DAC 0 REPLACE SECOND ARGUMENT LAST TIME
R$RA3 DAC 0 REPLACE THIRD ARGUMENT LAST TIME
R$RPT DAC 0 PTR TO CTBLK REPLACE TABLE LAST USD
R$SCP DAC 0 SAVE POINTER FROM LAST SCANE CALL
R$SXL DAC 0 PRESERVE XL IN SORTC
R$SXR DAC 0 PRESERVE XR IN SORTA/SORTC
R$STC DAC 0 TRBLK POINTER FOR STCOUNT TRACE
R$STL DAC 0 SOURCE LISTING SUB-TITLE
R$SXC DAC 0 CODE (CDBLK) PTR FOR SETEXIT TRAP
R$TTL DAC NULLS SOURCE LISTING TITLE
R$XSC DAC 0 STRING POINTER FOR XSCAN
EJC
*
* THE REMAINING POINTERS IN THIS LIST ARE USED TO POINT
* TO FUNCTION BLOCKS FOR NORMALLY UNDEFINED OPERATORS.
*
R$UBA DAC STNDO BINARY AT
R$UBM DAC STNDO BINARY AMPERSAND
R$UBN DAC STNDO BINARY NUMBER SIGN
R$UBP DAC STNDO BINARY PERCENT
R$UBT DAC STNDO BINARY NOT
R$UUB DAC STNDO UNARY VERTICAL BAR
R$UUE DAC STNDO UNARY EQUAL
R$UUN DAC STNDO UNARY NUMBER SIGN
R$UUP DAC STNDO UNARY PERCENT
R$UUS DAC STNDO UNARY SLASH
R$UUX DAC STNDO UNARY EXCLAMATION
R$YYY DAC 0 LAST RELOCATABLE LOCATION
*
* WORK AREAS FOR SUBSTR FUNCTION (S$SUB)
*
SBSSV DAC 0 SAVE THIRD ARGUMENT
*
* GLOBAL LOCATIONS USED IN SCAN PROCEDURE
*
SCNBL DAC 0 SET NON-ZERO IF SCANNED PAST BLANKS
SCNCC DAC 0 NON-ZERO TO SCAN CONTROL CARD NAME
SCNGO DAC 0 SET NON-ZERO TO SCAN GOTO FIELD
SCNIL DAC 0 LENGTH OF CURRENT INPUT IMAGE
SCNPT DAC 0 POINTER TO NEXT LOCATION IN R$CIM
SCNRS DAC 0 SET NON-ZERO TO SIGNAL RESCAN
SCNTP DAC 0 SAVE SYNTAX TYPE FROM LAST CALL
*
* WORK AREAS FOR SCAN PROCEDURE
*
SCNSA DAC 0 SAVE WA
SCNSB DAC 0 SAVE WB
SCNSC DAC 0 SAVE WC
SCNSE DAC 0 START OF CURRENT ELEMENT
SCNOF DAC 0 SAVE OFFSET
*
* WORK AREA FOR DETACH PROCEDURE
*
SDETF DAC 0 TRACE BLOCK FLAG
*
* WORK AREA FOR ENDFILE PROCEDURE
*
SENFR DAC 0 SAVE XR
.IF .CNSR
.ELSE
EJC
*
* WORK AREA USED BY SORTA, SORTC, SORTF, SORTH
*
SRTDF DAC 0 DATATYPE FIELD NAME
SRTFD DAC 0 FOUND DFBLK ADDRESS
SRTFF DAC 0 FOUND FIELD NAME
SRTFO DAC 0 OFFSET TO FIELD NAME
SRTNR DAC 0 NUMBER OF ROWS
SRTOF DAC 0 OFFSET WITHIN ROW TO SORT KEY
SRTRT DAC 0 ROOT OFFSET
SRTS1 DAC 0 SAVE OFFSET 1
SRTS2 DAC 0 SAVE OFFSET 2
SRTSC DAC 0 SAVE WC
SRTSF DAC 0 SORT ARRAY FIRST ROW OFFSET
SRTSN DAC 0 SAVE N
SRTSO DAC 0 OFFSET TO A(0)
SRTSR DAC 0 0 , NON-ZERO FOR SORT, RSORT
SRTST DAC 0 STRIDE FROM ONE ROW TO NEXT
SRTWC DAC 0 DUMP WC
.FI
*
* VALUES FOR INDICATING COMPILATION/EXECUTION STAGE
*
STAGE DAC 0 INITIAL VALUE = INITIAL COMPILE
STAGX DAC 0 NON-ZERO IF EXECUTING
*
* GLOBAL VALUES DEFINING EXTENT OF STATIC AREA (ALOST)
*
STATB DAC 0 START OF STATIC AREA
STATE DAC 0 END OF STATIC AREA
EJC
*
* GLOBAL STACK POINTER
*
STBAS DAC 0 POINTER PAST STACK BASE
*
* WORK AREAS FOR STOPR ROUTINE
*
STPSI DIC +0 SAVE VALUE OF STCOUNT
STPTI DIC +0 SAVE TIME ELAPSED
STPXR DAC 0 SAVE XR
*
* GLOBAL VALUES FOR SETEXIT FUNCTION (S$STX)
*
STXOF DAC 0 FAILURE OFFSET
STXVR DAC NULLS VRBLK POINTER OR NULL
*
* WORK AREAS FOR TFIND PROCEDURE
*
TFNSI DIC +0 NUMBER OF HEADERS
*
* GLOBAL VALUE FOR TIME KEEPING
*
TIMSX DIC +0 TIME AT START OF EXECUTION
*
* TERMINAL BUFFER ADDRESSES, FLAGS ETC
*
TTBLK DAC 0 BLANKING STRING ADRS
TTBUF DAC 0 BUFFER ADRS
TTCHS DAC 0 START OF BUFFER CHARACTERS
TTCMV DAC 0 COUNT OF BLANKING CHARS TO MOVE
TTERL DAC 0 ERROR FLAG
TTINS DAC 0 NON-ZERO IF STD INPUT FROM TERML
TTLEN DAC 0 LENGTH OF TERMINAL BUFFER
TTLST DAC 0 COPY STD O/P TO TERML IF SET
TTOFS DAC 0 OFFSET TO POSITION IN TERML BFR
TTOUS DAC 0 SET IF STD OUTPUT TO TERMINAL
*
* WORK AREAS FOR XSCAN PROCEDURE
*
XSCBL DAC 0 COUNT OF TRAILING BLANKS
XSCNB DAC 0 NON-ZERO IF NON-BLANKS SEEN
XSCRT DAC 0 SAVE RETURN CODE
XSCWB DAC 0 SAVE REGISTER WB
*
* GLOBAL VALUES FOR XSCAN AND XSCNI PROCEDURES
*
XSOFS DAC 0 OFFSET TO CURRENT LOCATION IN R$XSC
*
* LABEL TO MARK END OF WORK AREA
*
YYYYY DAC 0
TTL S P I T B O L -- INITIALIZATION
*
* INITIALISATION
* THE FOLLOWING SECTION RECEIVES CONTROL FROM THE SYSTEM
* AT THE START OF A RUN WITH THE REGISTERS SET AS FOLLOWS.
*
* (XS) POINTS PAST STACK BASE
* (XR) POINTS TO FIRST WORD OF DATA AREA
* (XL) POINTS TO LAST WORD OF DATA AREA
* (WA) INITIAL &CODE VALUE
*
SEC START OF PROGRAM SECTION
*
INITL RTN INITIALISATION CODE
MOV WA,INICD SAVE INITIAL CODE KYWD VALUE
.IF .CNBT
MOV XR,STATB START ADDRESS OF STATIC
.ELSE
*
* INITIALISE WORK AREA (ESSENTIAL FOR BATCHED RUNS)
*
MOV XR,WB PRESERVE XR
MOV =YYYYY,WA POINT TO END OF WORK AREA
SUB =AAAAA,WA GET LENGTH OF WORK AREA
BTW WA CONVERT TO WORDS
LCT WA,WA COUNT FOR LOOP
MOV =AAAAA,XR SET UP INDEX REGISTER
*
* CLEAR WORK SPACE
*
INI01 ZER (XR)+ CLEAR A WORD
BCT WA,INI01 LOOP TILL DONE
MOV =STNDO,WA UNDEFINED OPERATORS POINTER
MOV =R$YYY,WC POINT TO TABLE END
SUB =R$UBA,WC LENGTH OF UNDEF. OPERATORS TABLE
BTW WC CONVERT TO WORDS
LCT WC,WC LOOP COUNTER
MOV =R$UBA,XR SET UP XR
*
* SET CORRECT VALUE INTO UNDEFINED OPERATORS TABLE
*
INI02 MOV WA,(XR)+ STORE VALUE
BCT WC,INI02 LOOP TILL ALL DONE
MOV =NUM01,WA GET A 1
MOV WA,CMPSN STATEMENT NO
MOV WA,CSWFL NOFAIL
MOV WA,CSWLS LIST
MOV WA,KVINP INPUT
MOV WA,KVOUP OUTPUT
MOV WA,LSTPF NOTHING FOR LISTR YET
MOV =INILN,WA INPUT IMAGE LENGTH
MOV WA,CSWIN STORE FOR LATER USE
MOV =B$KVT,DMPKB DUMP
MOV =TRBKV,DMPKT DUMP
MOV =P$LEN,EVLIN EVAL
EJC
MOV =NULLS,WA GET NULLSTRING POINTER
MOV WA,KVRTN RETURN
MOV WA,R$ETX ERRTEXT
MOV WA,R$TTL TITLE FOR LISTING
MOV WA,STXVR SETEXIT
LDI STLIM GET DEFAULT STLIMIT
STI KVSTL STATEMENT LIMIT
STI KVSTC STATEMENT COUNT
MOV WB,STATB STORE START ADRS OF STATIC
.FI
.IF .CSIG
MNZ CSWCI -CASEIG
.FI
JSR SYSTM INITIALISE TIMER
STI TIMSX STORE TIME
LDI INICD LOAD INITIAL CODE KWD VALUE
STI KVCOD STORE
MOV *E$SRS,RSMEM RESERVE MEMORY
MOV XS,STBAS STORE STACK BASE
SSS INISS SAVE S-R STACK PTR
*
* NOW CONVERT FREE STORE PERCENTAGE TO A SUITABLE FACTOR
* FOR EASY TESTING IN ALLOC ROUTINE.
*
LDI INTVH GET 100
DVI ALFSP FORM 100 / ALFSP
STI ALFSF STORE THE FACTOR
.IF .CNRA
.ELSE
*
* INITIALIZE VALUES FOR REAL CONVERSION ROUTINE
*
LCT WB,=CFP$S LOAD COUNTER FOR SIGNIFICANT DIGITS
LDR REAV1 LOAD 1.0
*
* LOOP TO COMPUTE 10**(MAX NUMBER SIGNIFICANT DIGITS)
*
INI03 MLR REAVT * 10.0
BCT WB,INI03 LOOP TILL DONE
STR GTSSC STORE 10**(MAX SIG DIGITS)
LDR REAP5 LOAD 0.5
DVR GTSSC COMPUTE 0.5*10**(MAX SIG DIGITS)
STR GTSRN STORE AS ROUNDING BIAS
.FI
ZER WC SET TO READ PARAMETERS
JSR PRPAR READ THEM
EJC
*
* NOW COMPUTE STARTING ADDRESS FOR DYNAMIC STORE AND IF
* NECESSARY REQUEST MORE MEMORY.
*
SUB *E$SRS,XL ALLOW FOR RESERVE MEMORY
MOV PRLEN,WA GET PRINT BUFFER LENGTH
ADD TTLEN,WA ADD TERMINAL BUFFER LENGTH
ADD WA,WA ALLOW FOR EQUALLY BIG BLANK STRINGS
ADD =CFP$A,WA ADD NO. OF CHARS IN ALPHABET
ADD =NSTMX,WA ADD CHARS FOR GTSTG BFR
CTB WA,8 CONVERT TO BAUS, ALLOWING A MARGIN
MOV STATB,XR POINT TO STATIC BASE
ADD WA,XR INCREMENT FOR ABOVE BUFFERS
ADD *E$HNB,XR INCREMENT FOR HASH TABLE
ADD *E$STS,XR BUMP FOR INITIAL STATIC BLOCK
JSR SYSMX GET MXLEN
MOV WA,KVMXL PROVISIONALLY STORE AS MAXLNGTH
MOV WA,MXLEN AND AS MXLEN
BGT XR,WA,INI05 SKIP IF STATIC HI EXCEEDS MXLEN
MOV WA,XR USE MXLEN INSTEAD
ICA XR MAKE BIGGER THAN MXLEN
*
* HERE TO STORE VALUES WHICH MARK INITIAL DIVISION
* OF DATA AREA INTO STATIC AND DYNAMIC
*
INI05 MOV XR,DNAMB DYNAMIC BASE ADRS
MOV XR,DNAMP DYNAMIC PTR
BNZ WA,INI06 SKIP IF NON-ZERO MXLEN
DCA XR POINT A WORD IN FRONT
MOV XR,KVMXL USE AS MAXLNGTH
MOV XR,MXLEN AND AS MXLEN
*
* LOOP HERE IF NECESSARY TILL ENOUGH MEMORY OBTAINED
* SO THAT DNAME IS ABOVE DNAMB
*
INI06 MOV XL,DNAME STORE DYNAMIC END ADDRESS
BLT DNAMB,XL,INI08 SKIP IF HIGH ENOUGH
JSR SYSMM REQUEST MORE MEMORY
WTB XR CONVERT TO BAUS
ADD XR,XL BUMP BY AMOUNT OBTAINED
BNZ XR,INI06 TRY AGAIN
MOV =ENDMO,XR POINT TO FAILURE MESSAGE
MOV ENDML,WC MESSAGE LENGTH
JSR SYSPR PRINT IT (PRTST NOT YET USABLE)
PPM INI07
PPM INI07
*
* EMERGENCY SHUTDOWN
*
INI07 MOV =KVCOD,WA CODE KEYWORD
JSR SYSEJ PACK UP (STOPR NOT YET USABLE)
EJC
*
* INITIALISE PRINT BUFFER WITH BLANK WORDS
*
INI08 MOV PRLEN,WA NO. OF CHARS IN PRINT BFR
MOV STATB,XR POINT TO STATIC AGAIN
MOV XR,PRBUF PRINT BFR IS PUT AT STATIC START
MOV =B$SCL,(XR)+ STORE STRING TYPE CODE
MOV WA,(XR)+ AND STRING LENGTH
MOV XR,PRCHS KEEP ADRS OF BUFFER PROPER
MOV XR,XL COPY IT
CTB WA,0 WORDS NEEDED EXPRESSED IN BAUS
MOV WA,PRCMV KEEP FOR CLEARING BUFFER
MOV XR,PRBLK CONSTRUCT ADRS OF BLANKING STRING
ADD WA,PRBLK ADD OFFSET TO BLANKING STRING
ADD WA,WA CLEAR BOTH BFR AND BLANKING STRING
MOV NULLW,(XR)+ CLEAR FIRST WORD
BZE WA,INI09 SKIP IF NO PRINT BUFFER
DCA WA ADJUST FOR FIRST WORD
MVW PERFORM BLANKING
*
* SET UP TERMINAL BUFFER
*
INI09 MOV TTLEN,WA LENGTH OF TERMINAL BUFFER
MOV XR,TTBUF ADRS OF TERMINAL STRING BUFFER
MOV =B$SCL,(XR)+ STRING TYPE CODE
MOV WA,(XR)+ STRING LENGTH
MOV XR,TTCHS KEEP ADRS OF BUFFER PROPER
MOV XR,XL COPY IT
CTB WA,0 WORDS NEEDED EXPRESSED IN BAUS
MOV WA,TTCMV KEEP FOR CLEARING BUFFER
MOV XR,TTBLK CONSTRUCT ADRS OF BLANKING STRING
ADD WA,TTBLK ADD OFFSET TO BLANKING STRING
ADD WA,WA CLEAR BOTH BFR AND BLANKING STRING
MOV NULLW,(XR)+ CLEAR FIRST WORD
BZE WA,INI10 SKIP IF NO PRINT BUFFER
DCA WA ADJUST FOR FIRST WORD
MVW PERFORM BLANKING
*
* INITIALIZE NUMBER OF HASH HEADERS
*
INI10 MOV =E$HNB,WA GET NUMBER OF HASH HEADERS
MTI WA CONVERT TO INTEGER
STI HSHNB STORE FOR USE BY GTNVR PROCEDURE
LCT WA,WA COUNTER FOR CLEARING HASH TABLE
MOV XR,HSHTB POINTER TO HASH TABLE
*
* LOOP TO CLEAR HASH TABLE
*
INI11 ZER (XR)+ BLANK A WORD
BCT WA,INI11 LOOP
MOV XR,HSHTE END OF HASH TABLE ADRS IS KEPT
*
* ALLOCATE WORK AREA FOR GTSTG CONVERSION PROCEDURE
*
MOV =NSTMX,WA GET MAX NUM CHARS IN OUTPUT NUMBER
CTB WA,SCSI$ NO OF BAUS NEEDED
MOV XR,GTSWK STORE BFR ADRS
ADD WA,XR BUMP FOR WORK BFR
EJC
*
* BUILD ALPHABET STRING FOR ALPHABET KEYWORD AND REPLACE
*
MOV XR,KVALP SAVE ALPHABET POINTER
MOV =B$SCL,(XR) STRING BLK TYPE
MOV =CFP$A,WC NO OF CHARS IN ALPHABET
MOV WC,SCLEN(XR) STORE AS STRING LENGTH
MOV WC,WB COPY CHAR COUNT
CTB WB,SCSI$ NO. OF BAUS NEEDED
ADD XR,WB CURRENT END ADDRESS FOR STATIC
MOV WB,STATE STORE STATIC END ADRS
LCT WC,WC LOOP COUNTER
PSC XR POINT TO CHARS OF STRING
ZER WB SET INITIAL CHARACTER VALUE
*
* LOOP TO ENTER CHARACTER CODES IN ORDER
*
INI12 SCH WB,(XR)+ STORE NEXT CODE
ICV WB BUMP CODE VALUE
BCT WC,INI12 LOOP TILL ALL STORED
CSC XR COMPLETE STORE CHARACTERS
*
* INITIALIZE VARIABLE BLOCKS FOR INPUT OUTPUT TERMINAL
*
MOV =V$INP,XL POINT TO STRING /INPUT/
MOV =TRTIN,WB TRBLK TYPE FOR INPUT
JSR INOUT PERFORM INPUT ASSOCIATION
MOV =V$OUP,XL POINT TO STRING /OUTPUT/
MOV =TRTOU,WB TRBLK TYPE FOR OUTPUT
JSR INOUT PERFORM OUTPUT ASSOCIATION
BZE TTLEN,INI13 SKIP IF NO TERMINAL I/O
MOV =V$TER,XL POINT TO STRING /TERMINAL/
MOV =TRTOU,WB TRTYP FOR OUTPUT
JSR INOUT PERFORM ASSOCIATION
MOV =V$TER,XL
MOV =TRTIN,WB TRTYP FOR INPUT
JSR INOUT PERFORM ASSOCIATION
EJC
*
*
* PREPARE FOR COMPILATION
*
INI13 MOV XS,FLPTR IN CASE STACK OVERFLOWS IN COMPILER
*
* NOW COMPILE SOURCE INPUT CODE
*
JSR CMPIL CALL COMPILER
MOV XR,R$COD SET PTR TO FIRST CODE BLOCK
MOV =NULLS,R$TTL FORGET TITLE
MOV =NULLS,R$STL FORGET SUB-TITLE
ZER R$CIM FORGET COMPILER INPUT IMAGE
ZER XL CLEAR DUD VALUE
ZER WB DONT SHIFT DYNAMIC STORE UP
JSR GBCOL CLEAR GARBAGE LEFT FROM COMPILE
BNZ CPSTS,INIX1 SKIP IF NO LISTING OF COMP STATS
JSR PRTPG EJECT PAGE
*
* PRINT COMPILE STATISTICS
*
MOV DNAMP,WA NEXT AVAILABLE LOC
SUB STATB,WA MINUS START
BTW WA CONVERT TO WORDS
MTI WA CONVERT TO INTEGER
MOV =ENCM1,XR POINT TO /MEMORY USED (WORDS)/
JSR PRTMI PRINT MESSAGE
MOV DNAME,WA END OF MEMORY
SUB DNAMP,WA MINUS NEXT AVAILABLE LOC
BTW WA CONVERT TO WORDS
MTI WA CONVERT TO INTEGER
MOV =ENCM2,XR POINT TO /MEMORY AVAILABLE (WORDS)/
JSR PRTMI PRINT LINE
MTI CMERC GET COUNT OF ERRORS AS INTEGER
MOV =ENCM3,XR POINT TO /COMPILE ERRORS/
JSR PRTMI PRINT IT
MTI GBCNT GARBAGE COLLECTION COUNT
SBI INTV1 ADJUST FOR UNAVOIDABLE COLLECT
MOV =STPM5,XR POINT TO /STORAGE REGENERATIONS/
JSR PRTMI PRINT GBCOL COUNT
JSR SYSTM GET TIME
SBI TIMSX GET COMPILATION TIME
MOV =ENCM4,XR POINT TO COMPILATION TIME (MSEC)/
JSR PRTMI PRINT MESSAGE
ADD =NUM05,LSTLC BUMP LINE COUNT
EJC
*
* PREPARE NOW TO START EXECUTION
*
*
* CHECK FOR NOEXECUTE
*
INIX1 BNZ NOXEQ,INIX3 JUMP IF EXECUTION SUPPRESSED
ZER GBCNT INITIALISE COLLECT COUNT
BZE HEADP,INIX2 SKIP IF NO PRTPG CALLS IN COMPILN
JSR PRTPG EJECT STANDARD PRINTER FILE
*
* INFORM OSINT OF STAGE
*
INIX2 JSR SYSBX CALL BEFORE STARTING EXECUTION
ZER -(XS) SET FAILURE LOCATION ON STACK
MOV XS,FLPTR SAVE PTR TO FAILURE OFFSET WORD
MOV R$COD,XR LOAD PTR TO ENTRY CODE BLOCK
MOV =STGXT,STAGE SET STAGE FOR EXECUTE TIME
JSR SYSTM GET TIME
STI TIMSX STORE FOR END RUN PROCESSING
.IF .CNPF
.ELSE
STI PFSTM STORE TIME FOR PROFILER
MOV CMPSN,PFNTE COPY STATEMENTS COMPILED COUNT
.FI
BRI (XR) START XEQ WITH FIRST STATEMENT
*
* HERE IF EXECUTION IS SUPPRESSED
*
INIX3 JSR PRTFH PRINT A BLANK LINE
MOV =ENCM5,XR POINT TO /EXECUTION SUPPRESSED/
MOV TTERL,TTLST TO FORCE MSG TO TERMINAL
JSR PRTSF PRINT NOEXECUTE MESSAGE
MOV =KVCOD,WA ENDING CODE
JSR SYSEJ END OF JOB, EXIT TO SYSTEM
TTL S P I T B O L -- SNOBOL4 OPERATOR ROUTINES
*
* THIS SECTION INCLUDES ALL ROUTINES WHICH CAN BE ACCESSED
* DIRECTLY FROM THE GENERATED CODE EXCEPT SYSTEM FUNCTIONS.
*
* ALL ROUTINES IN THIS SECTION START WITH A LABEL OF THE
* FORM O$XXX WHERE XXX IS THREE LETTERS. THE GENERATED CODE
* CONTAINS A POINTER TO THE APPROPRIATE ENTRY LABEL.
*
* SINCE THE GENERAL FORM OF THE GENERATED CODE CONSISTS OF
* POINTERS TO BLOCKS WHOSE FIRST WORD IS THE ADDRESS OF THE
* ACTUAL ENTRY POINT LABEL (O$XXX).
*
* THESE ROUTINES ARE IN ALPHABETICAL ORDER BY THEIR
* ENTRY LABEL NAMES (I.E. BY THE XXX OF THE O$XXX NAME)
*
* THESE ROUTINES RECEIVE CONTROL AS FOLLOWS
*
* (CP) POINTER TO NEXT CODE WORD
* (XS) CURRENT STACK POINTER
EJC
*
* BINARY PLUS (ADDITION)
*
O$ADD ENT ENTRY POINT
JSR ARITH FETCH ARITHMETIC OPERANDS
ERR 001,ADDITION LEFT OPERAND IS NOT NUMERIC
ERR 002,ADDITION RIGHT OPERAND IS NOT NUMERIC
.IF .CNRA
.ELSE
PPM OADD1 JUMP IF REAL OPERANDS
.FI
*
* HERE TO ADD TWO INTEGERS
*
ADI ICVAL(XL) ADD RIGHT OPERAND TO LEFT
INO EXINT RETURN INTEGER IF NO OVERFLOW
ERB 003,ADDITION CAUSED INTEGER OVERFLOW
.IF .CNRA
.ELSE
*
* HERE TO ADD TWO REALS
*
OADD1 ADR RCVAL(XL) ADD RIGHT OPERAND TO LEFT
RNO EXREA RETURN REAL IF NO OVERFLOW
ERB 004,ADDITION CAUSED REAL OVERFLOW
.FI
EJC
*
* UNARY PLUS (AFFIRMATION)
*
O$AFF ENT ENTRY POINT
MOV (XS)+,XR LOAD OPERAND
JSR GTNUM CONVERT TO NUMERIC
ERR 005,AFFIRMATION OPERAND IS NOT NUMERIC
BRN EXIXR RETURN IF CONVERTED TO NUMERIC
EJC
*
* BINARY BAR (ALTERNATION)
*
O$ALT ENT ENTRY POINT
MOV (XS)+,XR LOAD RIGHT OPERAND
JSR GTPAT CONVERT TO PATTERN
ERR 006,ALTERNATION RIGHT OPERAND IS NOT PATTERN
*
* MERGE HERE FROM SPECIAL (LEFT ALTERNATION) CASE
*
OALT1 MOV =P$ALT,WB SET PCODE FOR ALTERNATIVE NODE
JSR PBILD BUILD ALTERNATIVE NODE
MOV XR,XL SAVE ADDRESS OF ALTERNATIVE NODE
MOV (XS)+,XR LOAD LEFT OPERAND
JSR GTPAT CONVERT TO PATTERN
ERR 007,ALTERNATION LEFT OPERAND IS NOT PATTERN
BEQ XR,=P$ALT,OALT2 JUMP IF LEFT ARG IS ALTERNATION
MOV XR,PTHEN(XL) SET LEFT OPERAND AS SUCCESSOR
MOV XL,XR MOVE RESULT TO PROPER REGISTER
BRN EXIXR JUMP FOR NEXT CODE WORD
*
* COME HERE IF LEFT ARGUMENT IS ITSELF AN ALTERNATION
*
* THE RESULT IS MORE EFFICIENT IF WE MAKE THE REPLACEMENT
*
* (A / B) / C = A / (B / C)
*
OALT2 MOV PARM1(XR),PTHEN(XL) BUILD THE (B / C) NODE
MOV PTHEN(XR),-(XS) SET A AS NEW LEFT ARG
MOV XL,XR SET (B / C) AS NEW RIGHT ARG
BRN OALT1 MERGE BACK TO BUILD A / (B / C)
EJC
*
* ARRAY REFERENCE (MULTIPLE SUBSCRIPTS, BY NAME)
*
O$AMN ENT ENTRY POINT
LCW XR LOAD NUMBER OF SUBSCRIPTS
MOV XR,WB SET FLAG FOR BY NAME
BRN ARREF JUMP TO ARRAY REFERENCE ROUTINE
*
* ARRAY REFERENCE (MULTIPLE SUBSCRIPTS, BY VALUE)
*
O$AMV ENT ENTRY POINT
LCW XR LOAD NUMBER OF SUBSCRIPTS
ZER WB SET FLAG FOR BY VALUE
BRN ARREF JUMP TO ARRAY REFERENCE ROUTINE
*
* ARRAY REFERENCE (ONE SUBSCRIPT, BY NAME)
*
O$AON ENT ENTRY POINT
MOV (XS),XR LOAD SUBSCRIPT VALUE
MOV 1(XS),XL LOAD ARRAY VALUE
MOV (XL),WA LOAD FIRST WORD OF ARRAY OPERAND
BEQ WA,=B$VCT,OAON2 JUMP IF VECTOR REFERENCE
BEQ WA,=B$TBT,OAON3 JUMP IF TABLE REFERENCE
*
* HERE TO USE CENTRAL ARRAY REFERENCE ROUTINE
*
OAON1 MOV =NUM01,XR SET NUMBER OF SUBSCRIPTS TO ONE
MOV XR,WB SET FLAG FOR BY NAME
BRN ARREF JUMP TO ARRAY REFERENCE ROUTINE
*
* HERE IF WE HAVE A VECTOR REFERENCE
*
OAON2 BNE (XR),=B$ICL,OAON1 USE LONG ROUTINE IF NOT INTEGER
LDI ICVAL(XR) LOAD INTEGER SUBSCRIPT VALUE
MFI WA,EXFAL COPY AS ADDRESS INT, FAIL IF OVFLO
BZE WA,EXFAL FAIL IF ZERO
ADD =VCVLB,WA COMPUTE OFFSET IN WORDS
WTB WA CONVERT TO BAUS
MOV WA,(XS) COMPLETE NAME ON STACK
BLT WA,VCLEN(XL),EXITS EXIT IF SUBSCRIPT NOT TOO LARGE
BRN EXFAL ELSE FAIL
*
* HERE FOR TABLE REFERENCE
*
OAON3 MNZ WB SET FLAG FOR NAME REFERENCE
JSR TFIND LOCATE/CREATE TABLE ELEMENT
PPM EXFAL FAIL IF ACCESS FAILS
MOV XL,1(XS) STORE NAME BASE ON STACK
MOV WA,(XS) STORE NAME OFFSET ON STACK
BRN EXITS EXIT WITH RESULT ON STACK
EJC
*
* ARRAY REFERENCE (ONE SUBSCRIPT, BY VALUE)
*
O$AOV ENT ENTRY POINT
MOV (XS)+,XR LOAD SUBSCRIPT VALUE
MOV (XS)+,XL LOAD ARRAY VALUE
MOV (XL),WA LOAD FIRST WORD OF ARRAY OPERAND
BEQ WA,=B$VCT,OAOV2 JUMP IF VECTOR REFERENCE
BEQ WA,=B$TBT,OAOV3 JUMP IF TABLE REFERENCE
*
* HERE TO USE CENTRAL ARRAY REFERENCE ROUTINE
*
OAOV1 MOV XL,-(XS) RESTACK ARRAY VALUE
MOV XR,-(XS) RESTACK SUBSCRIPT
MOV =NUM01,XR SET NUMBER OF SUBSCRIPTS TO ONE
ZER WB SET FLAG FOR VALUE CALL
BRN ARREF JUMP TO ARRAY REFERENCE ROUTINE
*
* HERE IF WE HAVE A VECTOR REFERENCE
*
OAOV2 BNE (XR),=B$ICL,OAOV1 USE LONG ROUTINE IF NOT INTEGER
LDI ICVAL(XR) LOAD INTEGER SUBSCRIPT VALUE
MFI WA,EXFAL MOVE AS ONE WORD INT, FAIL IF OVFLO
BZE WA,EXFAL FAIL IF ZERO
ADD =VCVLB,WA COMPUTE OFFSET IN WORDS
WTB WA CONVERT TO BAUS
BGE WA,VCLEN(XL),EXFAL FAIL IF SUBSCRIPT TOO LARGE
JSR ACESS ACCESS VALUE
PPM EXFAL FAIL IF ACCESS FAILS
BRN EXIXR ELSE RETURN VALUE TO CALLER
*
* HERE FOR TABLE REFERENCE BY VALUE
*
OAOV3 ZER WB SET FLAG FOR VALUE REFERENCE
JSR TFIND CALL TABLE SEARCH ROUTINE
PPM EXFAL FAIL IF ACCESS FAILS
BRN EXIXR EXIT WITH RESULT IN XR
EJC
*
* ASSIGNMENT (O$RPL MERGES)
*
O$ASS ENT ENTRY POINT
MOV (XS)+,WB LOAD VALUE TO BE ASSIGNED
MOV (XS)+,WA LOAD NAME OFFSET
MOV (XS),XL LOAD NAME BASE
MOV WB,(XS) STORE ASSIGNED VALUE AS RESULT
JSR ASIGN PERFORM ASSIGNMENT
PPM EXFAL FAIL IF ASSIGNMENT FAILS
BRN EXITS EXIT WITH RESULT ON STACK
*
* COMPILATION ERROR
*
O$CER ENT ENTRY POINT
ERB 008,COMPILATION ERROR ENCOUNTERED DURING EXECUTION
*
* UNARY AT (CURSOR ASSIGNMENT)
*
O$CAS ENT ENTRY POINT
MOV (XS)+,WC LOAD NAME OFFSET (PARM2)
MOV (XS)+,XR LOAD NAME BASE (PARM1)
MOV =P$CAS,WB SET PCODE FOR CURSOR ASSIGNMENT
JSR PBILD BUILD NODE
BRN EXIXR JUMP FOR NEXT CODE WORD
EJC
*
* CONCATENATION
*
O$CNC ENT ENTRY POINT
MOV (XS),XR LOAD RIGHT ARGUMENT
BEQ XR,=NULLS,OCNC3 JUMP IF RIGHT ARG IS NULL
MOV 1(XS),XL LOAD LEFT ARGUMENT
BEQ XL,=NULLS,OCNC4 JUMP IF LEFT ARGUMENT IS NULL
MOV =B$SCL,WA GET CONSTANT TO TEST FOR STRING
BNE WA,(XL),OCNC2 JUMP IF LEFT ARG NOT A STRING
BNE WA,(XR),OCNC2 JUMP IF RIGHT ARG NOT A STRING
*
* MERGE HERE TO CONCATENATE TWO STRINGS
*
OCNC1 MOV SCLEN(XL),WA LOAD LEFT ARGUMENT LENGTH
ADD SCLEN(XR),WA COMPUTE RESULT LENGTH
JSR ALOCS ALLOCATE SCBLK FOR RESULT
MOV XR,1(XS) STORE RESULT PTR OVER LEFT ARGUMENT
PSC XR PREPARE TO STORE CHARS OF RESULT
MOV SCLEN(XL),WA GET NUMBER OF CHARS IN LEFT ARG
PLC XL PREPARE TO LOAD LEFT ARG CHARS
MVC MOVE CHARACTERS OF LEFT ARGUMENT
MOV (XS)+,XL LOAD RIGHT ARG POINTER, POP STACK
MOV SCLEN(XL),WA LOAD NUMBER OF CHARS IN RIGHT ARG
PLC XL PREPARE TO LOAD RIGHT ARG CHARS
MVC MOVE CHARACTERS OF RIGHT ARGUMENT
BRN EXITS EXIT WITH RESULT ON STACK
*
* COME HERE IF ARGUMENTS ARE NOT BOTH STRINGS
*
OCNC2 JSR GTSTG CONVERT RIGHT ARG TO STRING
PPM OCNC5 JUMP IF RIGHT ARG IS NOT STRING
MOV XR,XL SAVE RIGHT ARG PTR
JSR GTSTG CONVERT LEFT ARG TO STRING
PPM OCNC6 JUMP IF LEFT ARG IS NOT A STRING
MOV XR,-(XS) STACK LEFT ARGUMENT
MOV XL,-(XS) STACK RIGHT ARGUMENT
MOV XR,XL MOVE LEFT ARG TO PROPER REG
MOV (XS),XR MOVE RIGHT ARG TO PROPER REG
BRN OCNC1 MERGE BACK TO CONCATENATE STRINGS
EJC
*
* CONCATENATION (CONTINUED)
*
* COME HERE FOR NULL RIGHT ARGUMENT
*
OCNC3 ICA XS REMOVE RIGHT ARG FROM STACK
BRN EXITS RETURN WITH LEFT ARGUMENT ON STACK
*
* HERE FOR NULL LEFT ARGUMENT
*
OCNC4 ICA XS UNSTACK ONE ARGUMENT
MOV XR,(XS) STORE RIGHT ARGUMENT
BRN EXITS EXIT WITH RESULT ON STACK
*
* HERE IF RIGHT ARGUMENT IS NOT A STRING
*
OCNC5 MOV XR,XL MOVE RIGHT ARGUMENT PTR
MOV (XS)+,XR LOAD LEFT ARG POINTER
*
* MERGE HERE WHEN LEFT ARGUMENT IS NOT A STRING
*
OCNC6 JSR GTPAT CONVERT LEFT ARG TO PATTERN
ERR 009,CONCATENATION LEFT OPND IS NOT STRING OR PATTERN
MOV XR,-(XS) SAVE RESULT ON STACK
MOV XL,XR POINT TO RIGHT OPERAND
JSR GTPAT CONVERT TO PATTERN
ERR 010,CONCATENATION RIGHT OPD IS NOT STRING OR PATTERN
MOV XR,XL MOVE FOR PCONC
MOV (XS)+,XR RELOAD LEFT OPERAND PTR
JSR PCONC CONCATENATE PATTERNS
BRN EXIXR EXIT WITH RESULT IN XR
EJC
*
* COMPLEMENTATION
*
O$COM ENT ENTRY POINT
MOV (XS)+,XR LOAD OPERAND
MOV (XR),WA LOAD TYPE WORD
*
* MERGE BACK HERE AFTER CONVERSION
*
OCOM1 BEQ WA,=B$ICL,OCOM2 JUMP IF INTEGER
.IF .CNRA
.ELSE
BEQ WA,=B$RCL,OCOM3 JUMP IF REAL
.FI
JSR GTNUM ELSE CONVERT TO NUMERIC
ERR 011,COMPLEMENTATION OPERAND IS NOT NUMERIC
BRN OCOM1 BACK TO CHECK CASES
*
* HERE TO COMPLEMENT INTEGER
*
OCOM2 LDI ICVAL(XR) LOAD INTEGER VALUE
NGI NEGATE
INO EXINT RETURN INTEGER IF NO OVERFLOW
ERB 012,COMPLEMENTATION CAUSED INTEGER OVERFLOW
.IF .CNRA
.ELSE
*
* HERE TO COMPLEMENT REAL
*
OCOM3 LDR RCVAL(XR) LOAD REAL VALUE
NGR NEGATE
BRN EXREA RETURN REAL RESULT
.FI
EJC
*
* BINARY SLASH (DIVISION)
*
O$DVD ENT ENTRY POINT
JSR ARITH FETCH ARITHMETIC OPERANDS
ERR 013,DIVISION LEFT OPERAND IS NOT NUMERIC
ERR 014,DIVISION RIGHT OPERAND IS NOT NUMERIC
.IF .CNRA
.ELSE
PPM ODVD2 JUMP IF REAL OPERANDS
.FI
*
* HERE TO DIVIDE TWO INTEGERS
*
DVI ICVAL(XL) DIVIDE LEFT OPERAND BY RIGHT
INO EXINT RESULT OK IF NO OVERFLOW
ERB 015,DIVISION CAUSED INTEGER OVERFLOW
.IF .CNRA
.ELSE
*
* HERE TO DIVIDE TWO REALS
*
ODVD2 DVR RCVAL(XL) DIVIDE LEFT OPERAND BY RIGHT
RNO EXREA RETURN REAL IF NO OVERFLOW
ERB 016,DIVISION CAUSED REAL OVERFLOW
.FI
EJC
*
* EXPONENTIATION
*
O$EXP ENT ENTRY POINT
MOV (XS)+,XR LOAD EXPONENT
JSR GTNUM CONVERT TO NUMBER
ERR 017,EXPONENTIATION RIGHT OPERAND IS NOT NUMERIC
.IF .CNRA
.ELSE
BNE WA,=B$ICL,OEXP7 JUMP IF REAL
.FI
MOV XR,XL MOVE EXPONENT
MOV (XS)+,XR LOAD BASE
JSR GTNUM CONVERT TO NUMERIC
ERR 018,EXPONENTIATION LEFT OPERAND IS NOT NUMERIC
LDI ICVAL(XL) LOAD EXPONENT
ILT OEXP8 ERROR IF NEGATIVE EXPONENT
.IF .CNRA
.ELSE
BEQ WA,=B$RCL,OEXP3 JUMP IF BASE IS REAL
.FI
*
* HERE TO EXPONENTIATE AN INTEGER
*
MFI WA,OEXP2 CONVERT EXPONENT TO 1 WORD INTEGER
LCT WA,WA SET LOOP COUNTER
LDI INTV1 LOAD INITIAL VALUE OF 1
BNZ WA,OEXP1 JUMP IF NON-ZERO EXPONENT
INE EXINT GIVE ZERO AS RESULT FOR NONZERO**0
BRN OEXP4 ELSE ERROR OF 0**0
*
* LOOP TO PERFORM EXPONENTIATION
*
OEXP1 MLI ICVAL(XR) MULTIPLY BY BASE
IOV OEXP2 JUMP IF OVERFLOW
BCT WA,OEXP1 LOOP BACK TILL COMPUTATION COMPLETE
BRN EXINT THEN RETURN INTEGER RESULT
*
* HERE IF INTEGER OVERFLOW
*
OEXP2 ERB 019,EXPONENTIATION CAUSED INTEGER OVERFLOW
EJC
*
* EXPONENTIATION (CONTINUED)
.IF .CNRA
.ELSE
*
* HERE TO EXPONENTIATE A REAL
*
OEXP3 MFI WA,OEXP6 CONVERT EXPONENT TO ONE WORD
LCT WA,WA SET LOOP COUNTER
LDR REAV1 LOAD 1.0 AS INITIAL VALUE
BNZ WA,OEXP5 JUMP IF NON-ZERO EXPONENT
RNE EXREA RETURN 1.0 IF NONZERO**ZERO
.FI
*
* HERE FOR ERROR OF 0**0 OR 0.0**0
*
OEXP4 ERB 020,EXPONENTIATION RESULT IS UNDEFINED
.IF .CNRA
.ELSE
*
* LOOP TO PERFORM EXPONENTIATION
*
OEXP5 MLR RCVAL(XR) MULTIPLY BY BASE
ROV OEXP6 JUMP IF OVERFLOW
BCT WA,OEXP5 LOOP TILL COMPUTATION COMPLETE
BRN EXREA THEN RETURN REAL RESULT
*
* HERE IF REAL OVERFLOW
*
OEXP6 ERB 021,EXPONENTIATION CAUSED REAL OVERFLOW
*
* HERE IF REAL EXPONENT
*
OEXP7 ERB 022,EXPONENTIATION RIGHT OPERAND IS REAL NOT INTEGER
.FI
*
* HERE FOR NEGATIVE EXPONENT
*
OEXP8 ERB 023,EXPONENTIATION RIGHT OPERAND IS NEGATIVE
EJC
*
* FAILURE IN EXPRESSION EVALUATION
*
* THIS ENTRY POINT IS USED IF THE EVALUATION OF AN
* EXPRESSION, INITIATED BY THE EVALX PROCEDURE, FAILS.
* CONTROL IS RETURNED TO AN APPROPRIATE POINT IN EVALX.
*
O$FEX ENT ENTRY POINT
JMG EVLXF JUMP TO FAILURE LOC IN EVALX
*
* FAILURE DURING EVALUATION OF A COMPLEX OR DIRECT GOTO
*
O$FIF ENT ENTRY POINT
ERB 024,GOTO EVALUATION FAILURE
*
* FUNCTION CALL (MORE THAN ONE ARGUMENT)
*
O$FNC ENT ENTRY POINT
LCW WA LOAD NUMBER OF ARGUMENTS
LCW XR LOAD FUNCTION VRBLK POINTER
MOV VRFNC(XR),XL LOAD FUNCTION POINTER
BNE WA,FARGS(XL),CFUNC USE CENTRAL ROUTINE IF WRONG NUM
BRI (XL) JUMP TO FUNCTION IF ARG COUNT OK
*
* FUNCTION NAME ERROR
*
O$FNE ENT ENTRY POINT
LCW WA GET NEXT CODE WORD
BNE WA,=ORNM$,OFNE1 FAIL IF NOT EVALUATING EXPRESSION
BNZ 2(XS),OFNE1 FAIL UNLESS EXPRN WANTED BY VALUE
JMG EVLXV JOIN EXPRESSION BY VALUE CODE
*
* HERE FOR ERROR
*
OFNE1 ERB 025,FUNCTION CALLED BY NAME RETURNED A VALUE
*
* FUNCTION CALL (SINGLE ARGUMENT)
*
O$FNS ENT ENTRY POINT
LCW XR LOAD FUNCTION VRBLK POINTER
MOV =NUM01,WA SET NUMBER OF ARGUMENTS TO ONE
MOV VRFNC(XR),XL LOAD FUNCTION POINTER
BNE WA,FARGS(XL),CFUNC USE CENTRAL ROUTINE IF WRONG NUM
BRI (XL) JUMP TO FUNCTION IF ARG COUNT OK
EJC
* CALL TO UNDEFINED FUNCTION
*
O$FUN ENT ENTRY POINT
ERB 026,UNDEFINED FUNCTION CALLED
*
* EXECUTE COMPLEX GOTO
*
O$GOC ENT ENTRY POINT
MOV 1(XS),XR LOAD NAME BASE POINTER
BHI XR,STATE,OGOC1 JUMP IF NOT NATURAL VARIABLE
ADD *VRTRA,XR ELSE POINT TO VRTRA FIELD
BRI (XR) AND JUMP THROUGH IT
*
* HERE IF GOTO OPERAND IS NOT NATURAL VARIABLE
*
OGOC1 ERB 027,GOTO OPERAND IS NOT A NATURAL VARIABLE
*
* EXECUTE DIRECT GOTO
*
O$GOD ENT ENTRY POINT
MOV (XS),XR LOAD OPERAND
MOV (XR),WA LOAD FIRST WORD
BEQ WA,=B$CDC,OGOD1 JUMP IF CODE BLOCK
BEQ WA,=B$CDS,OGOD2 JUMP IF CODE BLOCK
ERB 028,GOTO OPERAND IN DIRECT GOTO IS NOT CODE
*
* CASE OF COMPLEX FAILURE CODE
*
OGOD1 MOV FLPTR,XS POP GARBAGE OFF STACK
MOV CDFAL(XR),(XS) SET NEW FAILURE OFFSET
BRN STMGO JUMP TO EXECUTE CODE
*
* CASE OF SIMPLE FAILURE CODE
*
OGOD2 MOV FLPTR,XS POP GARBAGE OFF STACK
MOV *CDFAL,(XS) SET NEW FAILURE OFFSET
BRN STMGO JUMP TO EXECUTE CODE
*
* SET GOTO FAILURE TRAP
*
* THIS ROUTINE IS EXECUTED AT THE START OF A COMPLEX OR
* DIRECT FAILURE GOTO TO TRAP A SUBSEQUENT FAIL (SEE EXFAL)
*
O$GOF ENT ENTRY POINT
MOV FLPTR,XR POINT TO FAIL OFFSET ON STACK
ICA (XR) POINT FAILURE TO O$FIF WORD
ICP POINT TO NEXT CODE WORD
BRN EXITS EXIT TO CONTINUE
EJC
*
* BINARY DOLLAR (IMMEDIATE ASSIGNMENT)
*
* THE PATTERN BUILT BY BINARY DOLLAR IS A COMPOUND PATTERN.
* SEE DESCRIPTION AT START OF PATTERN MATCH SECTION FOR
* DETAILS OF THE STRUCTURE WHICH IS CONSTRUCTED.
*
O$IMA ENT ENTRY POINT
MOV =P$IMC,WB SET PCODE FOR LAST NODE
MOV (XS)+,WC POP NAME OFFSET (PARM2)
MOV (XS)+,XR POP NAME BASE (PARM1)
JSR PBILD BUILD P$IMC NODE
MOV XR,XL SAVE PTR TO NODE
MOV (XS),XR LOAD LEFT ARGUMENT
JSR GTPAT CONVERT TO PATTERN
ERR 029,IMMEDIATE ASSIGNMENT LEFT OPERAND IS NOT PATTERN
MOV XR,(XS) SAVE PTR TO LEFT OPERAND PATTERN
MOV =P$IMA,WB SET PCODE FOR FIRST NODE
JSR PBILD BUILD P$IMA NODE
MOV (XS)+,PTHEN(XR) SET LEFT OPERAND AS P$IMA SUCCESSOR
JSR PCONC CONCATENATE TO FORM FINAL PATTERN
BRN EXIXR ALL DONE
*
* INDIRECTION (BY NAME)
*
O$INN ENT ENTRY POINT
MNZ WB SET FLAG FOR RESULT BY NAME
BRN INDIR JUMP TO COMMON ROUTINE
*
* INTERROGATION
*
O$INT ENT ENTRY POINT
MOV =NULLS,(XS) REPLACE OPERAND WITH NULL
BRN EXITS EXIT FOR NEXT CODE WORD
*
* INDIRECTION (BY VALUE)
*
O$INV ENT ENTRY POINT
ZER WB SET FLAG FOR BY VALUE
BRN INDIR JUMP TO COMMON ROUTINE
EJC
*
* KEYWORD REFERENCE (BY NAME)
*
O$KWN ENT ENTRY POINT
JSR KWNAM GET KEYWORD NAME
BRN EXNAM EXIT WITH RESULT NAME
*
* KEYWORD REFERENCE (BY VALUE)
*
O$KWV ENT ENTRY POINT
JSR KWNAM GET KEYWORD NAME
MOV XR,DNAMP DELETE KVBLK
JSR ACESS ACCESS VALUE
PPM EXNUL DUMMY (UNUSED) FAILURE RETURN
BRN EXIXR JUMP WITH VALUE IN XR
*
* LOAD EXPRESSION BY NAME
*
O$LEX ENT ENTRY POINT
MOV *EVSI$,WA SET SIZE OF EVBLK
JSR ALLOC ALLOCATE SPACE FOR EVBLK
MOV =B$EVT,(XR) SET TYPE WORD
MOV =TRBEV,EVVAR(XR) SET DUMMY TRBLK POINTER
LCW WA LOAD EXBLK POINTER
MOV WA,EVEXP(XR) SET EXBLK POINTER
MOV XR,XL MOVE NAME BASE TO PROPER REG
MOV *EVVAR,WA SET NAME OFFSET = ZERO
BRN EXNAM EXIT WITH NAME IN (XL,WA)
*
* LOAD PATTERN VALUE
*
O$LPT ENT ENTRY POINT
LCW XR LOAD PATTERN POINTER
BRN EXIXR STACK PTR AND OBEY NEXT CODE WORD
EJC
*
* LOAD VARIABLE NAME
*
O$LVN ENT ENTRY POINT
LCW WA LOAD VRBLK POINTER
MOV WA,-(XS) STACK VRBLK PTR (NAME BASE)
MOV *VRVAL,-(XS) STACK NAME OFFSET
BRN EXITS EXIT WITH RESULT ON STACK
*
* BINARY ASTERISK (MULTIPLICATION)
*
O$MLT ENT ENTRY POINT
JSR ARITH FETCH ARITHMETIC OPERANDS
ERR 030,MULTIPLICATION LEFT OPERAND IS NOT NUMERIC
ERR 031,MULTIPLICATION RIGHT OPERAND IS NOT NUMERIC
.IF .CNRA
.ELSE
PPM OMLT1 JUMP IF REAL OPERANDS
.FI
*
* HERE TO MULTIPLY TWO INTEGERS
*
MLI ICVAL(XL) MULTIPLY LEFT OPERAND BY RIGHT
INO EXINT RETURN INTEGER IF NO OVERFLOW
ERB 032,MULTIPLICATION CAUSED INTEGER OVERFLOW
.IF .CNRA
.ELSE
*
* HERE TO MULTIPLY TWO REALS
*
OMLT1 MLR RCVAL(XL) MULTIPLY LEFT OPERAND BY RIGHT
RNO EXREA RETURN REAL IF NO OVERFLOW
ERB 033,MULTIPLICATION CAUSED REAL OVERFLOW
.FI
*
* NAME REFERENCE
*
O$NAM ENT ENTRY POINT
MOV *NMSI$,WA SET LENGTH OF NMBLK
JSR ALLOC ALLOCATE NMBLK
MOV =B$NML,(XR) SET NAME BLOCK CODE
MOV (XS)+,NMOFS(XR) SET NAME OFFSET FROM OPERAND
MOV (XS)+,NMBAS(XR) SET NAME BASE FROM OPERAND
BRN EXIXR EXIT WITH RESULT IN XR
EJC
*
* NEGATION
*
* INITIAL ENTRY
*
O$NTA ENT ENTRY POINT
LCW WA LOAD NEW FAILURE OFFSET
MOV FLPTR,-(XS) STACK OLD FAILURE POINTER
MOV WA,-(XS) STACK NEW FAILURE OFFSET
MOV XS,FLPTR SET NEW FAILURE POINTER
BRN EXITS JUMP TO CONTINUE EXECUTION
*
* ENTRY AFTER SUCCESSFUL EVALUATION OF OPERAND
*
O$NTB ENT ENTRY POINT
MOV 2(XS),FLPTR RESTORE OLD FAILURE POINTER
BRN EXFAL AND FAIL
*
* ENTRY FOR FAILURE DURING OPERAND EVALUATION
*
O$NTC ENT ENTRY POINT
ICA XS POP FAILURE OFFSET
MOV (XS)+,FLPTR RESTORE OLD FAILURE POINTER
BRN EXNUL EXIT GIVING NULL RESULT
*
* USE OF UNDEFINED OPERATOR
*
O$OUN ENT ENTRY POINT
ERB 034,UNDEFINED OPERATOR REFERENCED
*
* BINARY DOT (PATTERN ASSIGNMENT)
*
* THE PATTERN BUILT BY BINARY DOT IS A COMPOUND PATTERN.
* SEE DESCRIPTION AT START OF PATTERN MATCH SECTION FOR
* DETAILS OF THE STRUCTURE WHICH IS CONSTRUCTED.
*
O$PAS ENT ENTRY POINT
MOV =P$PAC,WB LOAD PCODE FOR P$PAC NODE
MOV (XS)+,WC LOAD NAME OFFSET (PARM2)
MOV (XS)+,XR LOAD NAME BASE (PARM1)
JSR PBILD BUILD P$PAC NODE
MOV XR,XL SAVE PTR TO NODE
MOV (XS),XR LOAD LEFT OPERAND
JSR GTPAT CONVERT TO PATTERN
ERR 035,PATTERN ASSIGNMENT LEFT OPERAND IS NOT PATTERN
MOV XR,(XS) SAVE PTR TO LEFT OPERAND PATTERN
MOV =P$PAA,WB SET PCODE FOR P$PAA NODE
JSR PBILD BUILD P$PAA NODE
MOV (XS)+,PTHEN(XR) SET LEFT OPERAND AS P$PAA SUCCESSOR
JSR PCONC CONCATENATE TO FORM FINAL PATTERN
BRN EXIXR JUMP FOR NEXT CODE WORD
EJC
*
* PATTERN MATCH (BY NAME, FOR REPLACEMENT)
*
O$PMN ENT ENTRY POINT
ZER WB SET TYPE CODE FOR MATCH BY NAME
BRN MATCH JUMP TO ROUTINE TO START MATCH
*
* PATTERN MATCH (STATEMENT)
*
* O$PMS IS USED IN PLACE OF O$PMV WHEN THE PATTERN MATCH
* OCCURS AT THE OUTER (STATEMENT) LEVEL SINCE IN THIS
* CASE THE SUBSTRING VALUE NEED NOT BE CONSTRUCTED.
*
O$PMS ENT ENTRY POINT
MOV =NUM02,WB SET FLAG FOR STATEMENT TO MATCH
BRN MATCH JUMP TO ROUTINE TO START MATCH
*
* PATTERN MATCH (BY VALUE)
*
O$PMV ENT ENTRY POINT
MOV =NUM01,WB SET TYPE CODE FOR VALUE MATCH
BRN MATCH JUMP TO ROUTINE TO START MATCH
*
* POP TOP ITEM ON STACK
*
O$POP ENT ENTRY POINT
ICA XS POP TOP STACK ENTRY
BRN EXITS OBEY NEXT CODE WORD
*
* TERMINATE EXECUTION (CODE COMPILED FOR END STATEMENT)
*
O$STP ENT ENTRY POINT
MOV =ENDMS,XR ENDING MESSAGE
ZER WA NO ERROR CODE
BRN STOPR STOP THE RUN
*
* RETURN NAME FROM EXPRESSION
* THIS ENTRY POINTS IS USED IF THE EVALUATION OF AN
* EXPRESSION, INITIATED BY THE EVALX PROCEDURE, RETURNS
* A NAME. CONTROL IS RETURNED TO THE PROPER POINT IN EVALX.
*
O$RNM ENT ENTRY POINT
JMG EVLXN RETURN TO EVALX PROCEDURE
EJC
*
* PATTERN REPLACEMENT
*
* WHEN THIS ROUTINE GETS CONTROL, THE FOLLOWING STACK
* ENTRIES HAVE BEEN MADE (SEE END OF MATCH ROUTINE P$NTH)
*
* SUBJECT NAME BASE
* SUBJECT NAME OFFSET
* INITIAL CURSOR VALUE
* FINAL CURSOR VALUE
* SUBJECT STRING POINTER
* (XS) ---------------- REPLACEMENT VALUE
*
O$RPL ENT ENTRY POINT
JSR GTSTG CONVERT REPLACEMENT VAL TO STRING
ERR 036,PATTERN REPLACEMENT RIGHT OPERAND IS NOT STRING
*
* GET RESULT LENGTH AND ALLOCATE RESULT SCBLK
*
MOV (XS),XL LOAD SUBJECT STRING POINTER
.IF .CNBF
.ELSE
BEQ (XL),=B$BCT,ORPL5 BRANCH IF BUFFER ASSIGNMENT
.FI
ADD SCLEN(XL),WA ADD SUBJECT STRING LENGTH
ADD 2(XS),WA ADD STARTING CURSOR
SUB 1(XS),WA MINUS FINAL CURSOR = TOTAL LENGTH
BZE WA,ORPL3 JUMP IF RESULT IS NULL
MOV XR,-(XS) RESTACK REPLACEMENT STRING
JSR ALOCS ALLOCATE SCBLK FOR RESULT
MOV 3(XS),WA GET INITIAL CURSOR (PART 1 LEN)
MOV XR,3(XS) STACK RESULT POINTER
PSC XR POINT TO CHARACTERS OF RESULT
*
* MOVE PART 1 (START OF SUBJECT) TO RESULT
*
BZE WA,ORPL1 JUMP IF FIRST PART IS NULL
MOV 1(XS),XL ELSE POINT TO SUBJECT STRING
PLC XL POINT TO SUBJECT STRING CHARS
MVC MOVE FIRST PART TO RESULT
EJC
* PATTERN REPLACEMENT (CONTINUED)
*
* NOW MOVE IN REPLACEMENT VALUE
*
ORPL1 MOV (XS)+,XL LOAD REPLACEMENT STRING, POP
MOV SCLEN(XL),WA LOAD LENGTH
BZE WA,ORPL2 JUMP IF NULL REPLACEMENT
PLC XL ELSE POINT TO CHARS OF REPLACEMENT
MVC MOVE IN CHARS (PART 2)
*
* NOW MOVE IN REMAINDER OF STRING (PART 3)
*
ORPL2 MOV (XS)+,XL LOAD SUBJECT STRING POINTER, POP
MOV (XS)+,WC LOAD FINAL CURSOR, POP
MOV SCLEN(XL),WA LOAD SUBJECT STRING LENGTH
SUB WC,WA MINUS FINAL CURSOR = PART 3 LENGTH
BZE WA,ORPL4 JUMP TO ASSIGN IF PART 3 IS NULL
PLC XL,WC ELSE POINT TO LAST PART OF STRING
MVC MOVE PART 3 TO RESULT
BRN ORPL4 JUMP TO PERFORM ASSIGNMENT
*
* HERE IF RESULT IS NULL
*
ORPL3 ADD *NUM02,XS POP SUBJECT STR PTR, FINAL CURSOR
MOV =NULLS,(XS) SET NULL RESULT
*
* MERGE WITH ASSIGNMENT ROUTINE
*
ORPL4 MOV =O$ASS,XL CONTINUATION ROUTINE
BRI XL ENTER ROUTINE
.IF .CNBF
.ELSE
*
* HERE FOR BUFFER SUBSTRING ASSIGNMENT
*
ORPL5 MOV XR,XL COPY SCBLK REPLACEMENT PTR
MOV (XS)+,XR UNSTACK BCBLK PTR
MOV (XS)+,WB GET FINAL CURSOR VALUE
MOV (XS)+,WA GET INITIAL CURSOR
SUB WA,WB GET LENGTH IN WB
ADD *NUM02,XS GET RID OF NAME BASE/OFFSET
JSR INSBF INSERT SUBSTRING
PPM CONVERT FAIL IMPOSSIBLE
PPM EXFAL FAIL IF INSERT FAILS
BRN EXNUL ELSE NULL RESULT
.FI
EJC
*
* RETURN VALUE FROM EXPRESSION
*
* THIS ENTRY POINTS IS USED IF THE EVALUATION OF AN
* EXPRESSION, INITIATED BY THE EVALX PROCEDURE, RETURNS
* A VALUE. CONTROL IS RETURNED TO THE PROPER POINT IN EVALX
*
O$RVL ENT ENTRY POINT
BRN EVLXV RETURN TO EVALX PROCEDURE
EJC
*
* SELECTION
*
* INITIAL ENTRY
*
O$SLA ENT ENTRY POINT
LCW WA LOAD NEW FAILURE OFFSET
MOV FLPTR,-(XS) STACK OLD FAILURE POINTER
MOV WA,-(XS) STACK NEW FAILURE OFFSET
MOV XS,FLPTR SET NEW FAILURE POINTER
BRN EXITS JUMP TO EXECUTE FIRST ALTERNATIVE
*
* ENTRY AFTER SUCCESSFUL EVALUATION OF ALTERNATIVE
*
O$SLB ENT ENTRY POINT
MOV (XS)+,XR LOAD RESULT
ICA XS POP FAIL OFFSET
MOV (XS),FLPTR RESTORE OLD FAILURE POINTER
MOV XR,(XS) RESTACK RESULT
LCW WA LOAD NEW CODE OFFSET
ADD R$COD,WA POINT TO ABSOLUTE CODE LOCATION
LCP WA SET NEW CODE POINTER
BRN EXITS JUMP TO CONTINUE PAST SELECTION
*
* ENTRY AT START OF SUBSEQUENT ALTERNATIVES
*
O$SLC ENT ENTRY POINT
LCW WA LOAD NEW FAIL OFFSET
MOV WA,(XS) STORE NEW FAIL OFFSET
BRN EXITS JUMP TO EXECUTE NEXT ALTERNATIVE
*
* ENTRY AT START OF LAST ALTERNATIVE
*
O$SLD ENT ENTRY POINT
ICA XS POP FAILURE OFFSET
MOV (XS)+,FLPTR RESTORE OLD FAILURE POINTER
BRN EXITS JUMP TO EXECUTE LAST ALTERNATIVE
EJC
*
* BINARY MINUS (SUBTRACTION)
*
O$SUB ENT ENTRY POINT
JSR ARITH FETCH ARITHMETIC OPERANDS
ERR 037,SUBTRACTION LEFT OPERAND IS NOT NUMERIC
ERR 038,SUBTRACTION RIGHT OPERAND IS NOT NUMERIC
.IF .CNRA
.ELSE
PPM OSUB1 JUMP IF REAL OPERANDS
.FI
*
* HERE TO SUBTRACT TWO INTEGERS
*
SBI ICVAL(XL) SUBTRACT RIGHT OPERAND FROM LEFT
INO EXINT RETURN INTEGER IF NO OVERFLOW
ERB 039,SUBTRACTION CAUSED INTEGER OVERFLOW
.IF .CNRA
.ELSE
*
* HERE TO SUBTRACT TWO REALS
*
OSUB1 SBR RCVAL(XL) SUBTRACT RIGHT OPERAND FROM LEFT
RNO EXREA RETURN REAL IF NO OVERFLOW
ERB 040,SUBTRACTION CAUSED REAL OVERFLOW
.FI
*
* DUMMY OPERATOR TO RETURN CONTROL TO TRXEQ PROCEDURE
*
O$TXR ENT ENTRY POINT
JMG TRXQR JUMP INTO TRXEQ PROCEDURE
*
* UNEXPECTED FAILURE
*
* NOTE THAT IF A SETEXIT TRAP IS OPERATING THEN
* TRANSFER TO SYSTEM LABEL CONTINUE
* WILL RESULT IN LOOPING HERE. DIFFICULT TO AVOID EXCEPT
* WITH A CONSIDERABLE OVERHEAD WHICH IS NOT WORTHWHILE OR
* ELSE BY A TECHNIQUE SUCH AS SETTING KVERL TO ZERO.
*
O$UNF ENT ENTRY POINT
ERB 041,UNEXPECTED FAILURE IN -NOFAIL MODE
TTL S P I T B O L -- SNOBOL4 BUILTIN LABEL ROUTINES
*
* THE FOLLOWING SECTION CONTAINS THE ROUTINES FOR LABELS
* WHICH HAVE A PREDEFINED MEANING IN SNOBOL4.
*
* CONTROL IS PASSED DIRECTLY TO THE LABEL NAME ENTRY POINT.
*
* ENTRY NAMES ARE OF THE FORM L$XXX WHERE XXX IS THE THREE
* LETTER VARIABLE NAME IDENTIFIER.
*
* ENTRIES ARE IN ALPHABETICAL ORDER
*
* ABORT
*
L$ABO ENT ENTRY POINT
MOV KVERT,WA LOAD ERROR CODE
ZER XR INDICATE NO ENDING MESSAGE
BNZ WA,STOPR STOP RUN
*
*
* FAIL IF NO ERROR HAD OCCURED
*
ERB 042,GOTO ABORT WITH NO PRECEDING ERROR
*
* CONTINUE
*
L$CNT ENT ENTRY POINT
*
* MERGE HERE AFTER EXECUTION ERROR
*
LCNXE MOV R$CNT,XR LOAD CONTINUATION CODE BLOCK PTR
BZE XR,LCNT1 JUMP IF NO PREVIOUS ERROR
ZER R$CNT CLEAR FLAG
MOV XR,R$COD ELSE STORE AS NEW CODE BLOCK PTR
ADD STXOF,XR ADD FAILURE OFFSET
LCP XR LOAD CODE POINTER
MOV FLPTR,XS RESET STACK POINTER
BRN EXITS JUMP TO TAKE INDICATED FAILURE
*
* HERE IF NO PREVIOUS ERROR
*
LCNT1 ERB 043,GOTO CONTINUE WITH NO PRECEDING ERROR
EJC
*
* END
*
L$END ENT ENTRY POINT
MOV =ENDMS,XR POINT TO MESSAGE /NORMAL TERM../
ZER WA NO ERROR CODE
BRN STOPR JUMP TO ROUTINE TO STOP RUN
*
* FRETURN
*
L$FRT ENT ENTRY POINT
MOV =SCFRT,WA POINT TO STRING /FRETURN/
BRN RETRN JUMP TO COMMON RETURN ROUTINE
*
* NRETURN
*
L$NRT ENT ENTRY POINT
MOV =SCNRT,WA POINT TO STRING /NRETURN/
BRN RETRN JUMP TO COMMON RETURN ROUTINE
*
* RETURN
*
L$RTN ENT ENTRY POINT
MOV =SCRTN,WA POINT TO STRING /RETURN/
BRN RETRN JUMP TO COMMON RETURN ROUTINE
*
* UNDEFINED LABEL
*
L$UND ENT ENTRY POINT
ERB 044,GOTO UNDEFINED LABEL
TTL S P I T B O L -- BLOCK ACTION ROUTINES
*
* THE FIRST WORD OF EVERY BLOCK IN DYNAMIC STORAGE AND THE
* VRGET, VRSTO AND VRTRA FIELDS OF A VRBLK CONTAIN A
* POINTER TO AN ENTRY POINT IN THE PROGRAM. ALL SUCH ENTRY
* POINTS ARE IN THE FOLLOWING SECTION EXCEPT THOSE FOR
* PATTERN BLOCKS WHICH ARE IN THE PATTERN MATCHING SEGMENT
* LATER ON (LABELS OF THE FORM P$XXX), AND DOPE VECTORS
* (D$XXX) WHICH ARE IN THE DOPE VECTOR SECTION FOLLOWING
* THE PATTERN ROUTINES (DOPE VECTORS ARE USED FOR CMBLKS).
*
* THE ENTRY POINTS IN THIS SECTION HAVE LABELS OF THE
* FORM B$XXY WHERE XX IS THE TWO CHARACTER BLOCK TYPE FOR
* THE CORRESPONDING BLOCK AND Y IS ANY LETTER.
*
* IN SOME CASES, THE POINTERS SERVE NO OTHER PURPOSE THAN
* TO IDENTIFY THE BLOCK TYPE. IN THIS CASE THE ROUTINE
* IS NEVER EXECUTED AND THUS NO CODE IS ASSEMBLED.
*
* FOR EACH OF THESE ENTRY POINTS CORRESPONDING TO A BLOCK
* AN ENTRY POINT IDENTIFICATION IS ASSEMBLED (BL$XX).
*
* THE EXACT ENTRY CONDITIONS DEPEND ON THE MANNER IN
* WHICH THE ROUTINE IS ACCESSED AND ARE DOCUMENTED WITH
* THE INDIVIDUAL ROUTINES AS REQUIRED.
*
* THE ORDER OF THESE ROUTINES IS ALPHABETICAL WITH THE
* FOLLOWING EXCEPTIONS.
*
* THE ROUTINES FOR SEBLK AND EXBLK ENTRIES OCCUR FIRST SO
* THAT EXPRESSIONS CAN BE QUICKLY IDENTIFIED FROM THE FACT
* THAT THEIR ROUTINES LIE BEFORE THE SYMBOL B$E$$.
*
* THESE ARE IMMEDIATELY FOLLOWED BY THE ROUTINE FOR A TRBLK
* SO THAT THE TEST AGAINST THE SYMBOL B$T$$ CHECKS FOR
* TRAPPED VALUES OR EXPRESSION VALUES (SEE PROCEDURE EVALP)
*
* THE PATTERN ROUTINES LIE AFTER THIS SECTION SO THAT
* PATTERNS ARE IDENTIFIED WITH ROUTINES STARTING AT OR
* AFTER THE INITIAL INSTRUCTION IN THESE ROUTINES (P$AAA).
*
* THE SYMBOL B$AAA DEFINES THE FIRST LOCATION FOR BLOCK
* ROUTINES AND THE SYMBOL P$YYY (AT THE END OF THE PATTERN
* MATCH ROUTINES SECTION) DEFINES THE LAST SUCH ENTRY POINT
*
B$AAA ENT BL$$I ENTRY POINT OF FIRST BLOCK ROUTINE
EJC
*
* EXBLK
*
* THE ROUTINE FOR AN EXBLK LOADS THE EXPRESSION ONTO
* THE STACK AS A VALUE.
*
* (XR) POINTER TO EXBLK
*
B$EXL ENT BL$EX ENTRY POINT (EXBLK)
BRN EXIXR STACK XR AND OBEY NEXT CODE WORD
*
* SEBLK
*
* THE ROUTINE FOR SEBLK IS ACCESSED FROM THE GENERATED
* CODE TO LOAD THE EXPRESSION VALUE ONTO THE STACK.
*
B$SEL ENT BL$SE ENTRY POINT (SEBLK)
BRN EXIXR STACK XR AND OBEY NEXT CODE WORD
*
* DEFINE SYMBOL WHICH MARKS END OF ENTRIES FOR EXPRESSIONS
*
B$E$$ ENT BL$$I ENTRY POINT
*
* TRBLK
*
* THE ROUTINE FOR A TRBLK IS NEVER EXECUTED
*
B$TRT ENT BL$TR ENTRY POINT (TRBLK)
*
* DEFINE SYMBOL MARKING END OF TRAP AND EXPRESSION BLOCKS
*
B$T$$ ENT BL$$I END OF TRBLK,SEBLK,EXBLK ENTRIES
*
* ARBLK
*
* THE ROUTINE FOR ARBLK IS NEVER EXECUTED
*
B$ART ENT BL$AR ENTRY POINT (ARBLK)
EJC
.IF .CNBF
.ELSE
*
* BCBLK
*
* THE ROUTINE FOR A BCBLK IS NEVER EXECUTED
*
* (XR) POINTER TO BCBLK
*
B$BCT ENT BL$BC ENTRY POINT (BCBLK)
*
* BFBLK
*
* THE ROUTINE FOR A BFBLK IS NEVER EXECUTED
*
* (XR) POINTER TO BFBLK
*
B$BFT ENT BL$BF ENTRY POINT (BFBLK)
EJC
.FI
*
* CCBLK
*
* THE ROUTINE FOR CCBLK IS NEVER ENTERED
*
B$CCT ENT BL$CC ENTRY POINT (CCBLK)
*
* CDBLK
*
* THE CDBLK ROUTINES ARE EXECUTED FROM THE GENERATED CODE.
* THERE ARE TWO CASES DEPENDING ON THE FORM OF CDFAL.
*
* ENTRY FOR COMPLEX FAILURE CODE AT CDFAL
*
* (XR) POINTER TO CDBLK
*
B$CDC ENT BL$CD ENTRY POINT (CDBLK)
MOV FLPTR,XS POP GARBAGE OFF STACK
MOV CDFAL(XR),(XS) SET FAILURE OFFSET
BRN STMGO ENTER STMT
*
* ENTRY FOR SIMPLE FAILURE CODE AT CDFAL
*
* (XR) POINTER TO CDBLK
*
B$CDS ENT BL$CD ENTRY POINT (CDBLK)
MOV FLPTR,XS POP GARBAGE OFF STACK
MOV *CDFAL,(XS) SET FAILURE OFFSET
BRN STMGO ENTER STMT
*
* CMBLK
*
* THE ROUTINE FOR A CMBLK IS NEVER EXECUTED
*
B$CMT ENT BL$CM ENTRY POINT (CMBLK)
*
* COBLK
*
* THE ROUTINE FOR A COBLK IS NEVER EXECUTED
*
B$COP ENT BL$CO ENTRY POINT (COBLK)
*
* CTBLK
*
* THE ROUTINE FOR A CTBLK IS NEVER EXECUTED
*
B$CTT ENT BL$CT ENTRY POINT (CTBLK)
EJC
*
* DFBLK
*
* THE ROUTINE FOR A DFBLK IS ACCESSED FROM THE O$FNC ENTRY
* TO CALL A DATATYPE FUNCTION AND BUILD A PDBLK.
*
* (XL) POINTER TO DFBLK
*
B$DFC ENT BL$DF ENTRY POINT
MOV DFPDL(XL),WA LOAD LENGTH OF PDBLK
JSR ALLOC ALLOCATE PDBLK
MOV =B$PDT,(XR) STORE TYPE WORD
MOV XL,PDDFP(XR) STORE DFBLK POINTER
MOV XR,WC SAVE POINTER TO PDBLK
ADD WA,XR POINT PAST PDBLK
LCT WA,FARGS(XL) SET TO COUNT FIELDS
*
* LOOP TO ACQUIRE FIELD VALUES FROM STACK
*
BDFC1 MOV (XS)+,-(XR) MOVE A FIELD VALUE
BCT WA,BDFC1 LOOP TILL ALL MOVED
MOV WC,XR RECALL POINTER TO PDBLK
BRN EXSID EXIT SETTING ID FIELD
.IF .CNLD
.ELSE
EJC
*
* EFBLK
*
* THE ROUTINE FOR AN EFBLK IS PASSED CONTROL FORM THE O$FNC
* ENTRY TO CALL AN EXTERNAL FUNCTION.
*
* (XL) POINTER TO EFBLK
*
B$EFC ENT BL$EF ENTRY POINT (EFBLK)
MOV FARGS(XL),WC LOAD NUMBER OF ARGUMENTS
WTB WC CONVERT TO OFFSET
MOV XL,-(XS) SAVE POINTER TO EFBLK
MOV XS,XT COPY POINTER TO ARGUMENTS
*
* LOOP TO CONVERT ARGUMENTS
*
BEFC1 ICA XT POINT TO NEXT ENTRY
MOV (XS),XR LOAD POINTER TO EFBLK
DCA WC DECREMENT EFTAR OFFSET
ADD WC,XR POINT TO NEXT EFTAR ENTRY
MOV EFTAR(XR),XR LOAD EFTAR ENTRY
BSW XR,5,BEFC7 SWITCH ON EFTAR TYPE
IFF 1,BEFC2 STRING
IFF 2,BEFC3 INTEGER
.IF .CNRA
.ELSE
IFF 3,BEFC4 REAL
.FI
.IF .CNBF
.ELSE
IFF 4,BEFCA BUFFER
.FI
ESW END OF SWITCH ON TYPE
*
* HERE TO CONVERT TO STRING
*
BEFC2 MOV (XT),-(XS) STACK ARG PTR
JSR GTSTG CONVERT ARGUMENT TO STRING
ERR 045,EXTERNAL FUNCTION ARGUMENT IS NOT STRING
BRN BEFC6 JUMP TO MERGE
EJC
*
* EFBLK (CONTINUED)
*
* HERE TO CONVERT AN INTEGER
*
BEFC3 MOV (XT),XR LOAD NEXT ARGUMENT
MOV WC,BEFOF SAVE OFFSET
JSR GTINT CONVERT TO INTEGER
ERR 046,EXTERNAL FUNCTION ARGUMENT IS NOT INTEGER
.IF .CNRA
.ELSE
BRN BEFC5 MERGE WITH REAL CASE
*
* HERE TO CONVERT A REAL
*
BEFC4 MOV (XT),XR LOAD NEXT ARGUMENT
MOV WC,BEFOF SAVE OFFSET
JSR GTREA CONVERT TO REAL
ERR 047,EXTERNAL FUNCTION ARGUMENT IS NOT REAL
*
* INTEGER CASE MERGES HERE
*
.FI
.IF .CNBF
.ELSE
BRN BEFC5 MERGE
*
* HERE TO CONVERT BUFFER
*
BEFCA MOV (XT),XR LOAD ARGUMENT
MOV WC,BEFOF SAVE OFFSET
MOV XL,-(XS) SAVE EFBLK PTR
JSR GTBUF GET A BUFFER
ERR 259,EXTERNAL FUNCTION ARGUMENT IS NOT BUFFER
MOV (XS)+,XL RESTORE EFBLK PTR
*
* INTEGER AND REAL CASE MERGES HERE
*
.FI
BEFC5 MOV BEFOF,WC RESTORE OFFSET
*
* STRING MERGES HERE
*
BEFC6 MOV XR,(XT) STORE CONVERTED RESULT
*
* NO CONVERSION MERGES HERE
*
BEFC7 BNZ WC,BEFC1 LOOP BACK IF MORE TO GO
*
* HERE AFTER CONVERTING ALL THE ARGUMENTS
*
MOV (XS)+,XL RESTORE EFBLK POINTER
MOV FARGS(XL),WA GET NUMBER OF ARGS
JSR SYSEX CALL ROUTINE TO CALL EXTERNAL FNC
PPM EXFAL FAIL IF FAILURE
EJC
*
* EFBLK (CONTINUED)
*
* RETURN HERE WITH RESULT IN XR
*
* FIRST DEFEND AGAINST NON-STANDARD NULL STRING RETURNED
*
MOV EFRSL(XL),WB GET RESULT TYPE
BNZ WB,BEFA8 BRANCH IF NOT UNCONVERTED
BNE (XR),=B$SCL,BEFC8 JUMP IF NOT A STRING
BZE SCLEN(XR),EXNUL RETURN NULL IF NULL
*
* HERE IF CONVERTED RESULT TO CHECK FOR NULL STRING
*
BEFA8 BNE WB,=NUM01,BEFC8 JUMP IF NOT A STRING
BZE SCLEN(XR),EXNUL RETURN NULL IF NULL
*
* RETURN IF RESULT IS IN DYNAMIC STORAGE
*
BEFC8 BLT XR,DNAMB,BEFC9 JUMP IF NOT IN DYNAMIC STORAGE
BLE XR,DNAMP,EXIXR RETURN RESULT IF ALREADY DYNAMIC
*
* HERE WE COPY A RESULT INTO THE DYNAMIC REGION
*
BEFC9 MOV (XR),WA GET POSSIBLE TYPE WORD
BZE WB,BEF11 JUMP IF UNCONVERTED RESULT
MOV =B$SCL,WA STRING
BEQ WB,=NUM01,BEF10 YES JUMP
MOV =B$ICL,WA INTEGER
BEQ WB,=NUM02,BEF10 YES JUMP
.IF .CNRA
.ELSE
MOV =B$RCL,WA REAL
BEQ WB,=NUM03,BEF10 YES JUMP
.FI
.IF .CNBF
.ELSE
MOV =B$BCT,WA BUFFER
BEQ WB,=NUM04,BEF10 YES JUMP
.FI
*
* STORE TYPE WORD IN RESULT
*
BEF10 MOV WA,(XR) STORED BEFORE COPYING TO DYNAMIC
*
* MERGE FOR UNCONVERTED RESULT
*
BEF11 JSR BLKLN GET LENGTH OF BLOCK
MOV XR,XL COPY ADDRESS OF OLD BLOCK
JSR ALLOC ALLOCATE DYNAMIC BLOCK SAME SIZE
MOV XR,-(XS) SET POINTER TO NEW BLOCK AS RESULT
MVW COPY OLD BLOCK TO DYNAMIC BLOCK
BRN EXITS EXIT WITH RESULT ON STACK
.FI
*
* EVBLK
*
* THE ROUTINE FOR AN EVBLK IS NEVER EXECUTED
*
B$EVT ENT BL$EV ENTRY POINT (EVBLK)
EJC
*
* FFBLK
*
* THE ROUTINE FOR AN FFBLK IS EXECUTED FROM THE O$FNC ENTRY
* TO CALL A FIELD FUNCTION AND EXTRACT A FIELD VALUE/NAME.
*
* (XL) POINTER TO FFBLK
*
B$FFC ENT BL$FF ENTRY POINT (FFBLK)
MOV XL,XR COPY FFBLK POINTER
LCW WC LOAD NEXT CODE WORD
MOV (XS),XL LOAD PDBLK POINTER
BNE (XL),=B$PDT,BFFC2 JUMP IF NOT PDBLK AT ALL
MOV PDDFP(XL),WA LOAD DFBLK POINTER FROM PDBLK
*
* LOOP TO FIND CORRECT FFBLK FOR THIS PDBLK
*
BFFC1 BEQ WA,FFDFP(XR),BFFC3 JUMP IF THIS IS THE CORRECT FFBLK
MOV FFNXT(XR),XR ELSE LINK TO NEXT FFBLK ON CHAIN
BNZ XR,BFFC1 LOOP BACK IF ANOTHER ENTRY TO CHECK
*
* HERE FOR BAD ARGUMENT
*
BFFC2 ERB 048,FIELD FUNCTION ARGUMENT IS WRONG DATATYPE
*
* HERE AFTER LOCATING CORRECT FFBLK
*
BFFC3 MOV FFOFS(XR),WA LOAD FIELD OFFSET
BEQ WC,=OFNE$,BFFC5 JUMP IF CALLED BY NAME
ADD WA,XL ELSE POINT TO VALUE FIELD
MOV (XL),XR LOAD VALUE
BNE (XR),=B$TRT,BFFC4 JUMP IF NOT TRAPPED
SUB WA,XL ELSE RESTORE NAME BASE,OFFSET
MOV WC,(XS) SAVE NEXT CODE WORD OVER PDBLK PTR
JSR ACESS ACCESS VALUE
PPM EXFAL FAIL IF ACCESS FAILS
MOV (XS),WC RESTORE NEXT CODE WORD
*
* HERE AFTER GETTING VALUE IN (XR)
*
BFFC4 MOV XR,(XS) STORE VALUE ON STACK (OVER PDBLK)
MOV WC,XR COPY NEXT CODE WORD
MOV (XR),XL LOAD ENTRY ADDRESS
BRI XL JUMP TO ROUTINE FOR NEXT CODE WORD
*
* HERE IF CALLED BY NAME
*
BFFC5 MOV WA,-(XS) STORE NAME OFFSET (BASE IS SET)
BRN EXITS EXIT WITH NAME ON STACK
EJC
*
* ICBLK
*
* THE ROUTINE FOR ICBLK IS EXECUTED FROM THE GENERATED
* CODE TO LOAD AN INTEGER VALUE ONTO THE STACK.
*
* (XR) POINTER TO ICBLK
*
B$ICL ENT BL$IC ENTRY POINT (ICBLK)
BRN EXIXR STACK XR AND OBEY NEXT CODE WORD
*
* KVBLK
*
* THE ROUTINE FOR A KVBLK IS NEVER EXECUTED.
*
B$KVT ENT BL$KV ENTRY POINT (KVBLK)
*
* NMBLK
*
* THE ROUTINE FOR A NMBLK IS EXECUTED FROM THE GENERATED
* CODE FOR THE CASE OF LOADING A NAME ONTO THE STACK
* WHERE THE NAME IS THAT OF A NATURAL VARIABLE WHICH CAN
* BE PREEVALUATED AT COMPILE TIME.
*
* (XR) POINTER TO NMBLK
*
B$NML ENT BL$NM ENTRY POINT (NMBLK)
BRN EXIXR STACK XR AND OBEY NEXT CODE WORD
*
* PDBLK
*
* THE ROUTINE FOR A PDBLK IS NEVER EXECUTED
*
B$PDT ENT BL$PD ENTRY POINT (PDBLK)
EJC
*
* PFBLK
*
* THE ROUTINE FOR A PFBLK IS EXECUTED FROM THE ENTRY O$FNC
* TO CALL A PROGRAM DEFINED FUNCTION.
*
* (XL) POINTER TO PFBLK
*
* THE FOLLOWING STACK ENTRIES ARE MADE BEFORE PASSING
* CONTROL TO THE PROGRAM DEFINED FUNCTION.
*
* SAVED VALUE OF FIRST ARGUMENT
* .
* SAVED VALUE OF LAST ARGUMENT
* SAVED VALUE OF FIRST LOCAL
* .
* SAVED VALUE OF LAST LOCAL
* SAVED VALUE OF FUNCTION NAME
* SAVED CODE BLOCK PTR (R$COD)
* SAVED CODE POINTER (-R$COD)
* SAVED VALUE OF FLPRT
* SAVED VALUE OF FLPTR
* POINTER TO PFBLK
* FLPTR --------------- ZERO (TO BE OVERWRITTEN WITH OFFS)
*
B$PFC ENT BL$PF ENTRY POINT (PFBLK)
MOV XL,BPFPF SAVE PFBLK PTR (NEED NOT BE RELOC)
MOV XL,XR COPY FOR THE MOMENT
MOV PFVBL(XR),XL POINT TO VRBLK FOR FUNCTION
*
* LOOP TO FIND OLD VALUE OF FUNCTION
*
BPF01 MOV XL,WB SAVE POINTER
MOV VRVAL(XL),XL LOAD VALUE
BEQ (XL),=B$TRT,BPF01 LOOP IF TRBLK
*
* SET VALUE TO NULL AND SAVE OLD FUNCTION VALUE
*
MOV XL,BPFSV SAVE OLD VALUE
MOV WB,XL POINT BACK TO BLOCK WITH VALUE
MOV =NULLS,VRVAL(XL) SET VALUE TO NULL
MOV FARGS(XR),WA LOAD NUMBER OF ARGUMENTS
ADD *PFARG,XR POINT TO PFARG ENTRIES
BZE WA,BPF04 JUMP IF NO ARGUMENTS
MOV XS,XT PTR TO LAST ARG
WTB WA CONVERT NO. OF ARGS TO BAUS OFFSET
ADD WA,XT POINT BEFORE FIRST ARG
MOV XT,BPFXT REMEMBER ARG POINTER
EJC
*
* PFBLK (CONTINUED)
*
* LOOP TO SAVE OLD ARGUMENT VALUES AND SET NEW ONES
*
BPF02 MOV (XR)+,XL LOAD VRBLK PTR FOR NEXT ARGUMENT
*
* LOOP THROUGH POSSIBLE TRBLK CHAIN TO FIND VALUE
*
BPF03 MOV XL,WC SAVE POINTER
MOV VRVAL(XL),XL LOAD NEXT VALUE
BEQ (XL),=B$TRT,BPF03 LOOP BACK IF TRBLK
*
* SAVE OLD VALUE AND GET NEW VALUE
*
MOV XL,WA KEEP OLD VALUE
MOV BPFXT,XT POINT BEFORE NEXT STACKED ARG
MOV -(XT),WB LOAD ARGUMENT (NEW VALUE)
MOV WA,(XT) SAVE OLD VALUE
MOV XT,BPFXT KEEP ARG PTR FOR NEXT TIME
MOV WC,XL POINT BACK TO BLOCK WITH VALUE
MOV WB,VRVAL(XL) SET NEW VALUE
BNE XS,BPFXT,BPF02 LOOP IF NOT ALL DONE
*
* NOW PROCESS LOCALS
*
BPF04 MOV BPFPF,XL RESTORE PFBLK POINTER
MOV PFNLO(XL),WA LOAD NUMBER OF LOCALS
BZE WA,BPF07 JUMP IF NO LOCALS
MOV =NULLS,WB GET NULL CONSTANT
LCT WA,WA SET LOCAL COUNTER
*
* LOOP TO PROCESS LOCALS
*
BPF05 MOV (XR)+,XL LOAD VRBLK PTR FOR NEXT LOCAL
*
* LOOP THROUGH POSSIBLE TRBLK CHAIN TO FIND VALUE
*
BPF06 MOV XL,WC SAVE POINTER
MOV VRVAL(XL),XL LOAD NEXT VALUE
BEQ (XL),=B$TRT,BPF06 LOOP BACK IF TRBLK
*
* SAVE OLD VALUE AND SET NULL AS NEW VALUE
*
MOV XL,-(XS) STACK OLD VALUE
MOV WC,XL POINT BACK TO BLOCK WITH VALUE
MOV WB,VRVAL(XL) SET NULL AS NEW VALUE
BCT WA,BPF05 LOOP TILL ALL LOCALS PROCESSED
EJC
*
* PFBLK (CONTINUED)
*
* HERE AFTER PROCESSING ARGUMENTS AND LOCALS
*
.IF .CNPF
BPF07 MOV R$COD,WA LOAD OLD CODE BLOCK POINTER
.ELSE
BPF07 ZER XR ZERO REG XR IN CASE
BZE KVPFL,BPF7C SKIP IF PROFILING IS OFF
BEQ KVPFL,=NUM02,BPF7A BRANCH ON TYPE OF PROFILE
*
* HERE IF PROFILE = 1
*
JSR SYSTM GET CURRENT TIME
STI PFETM SAVE FOR A SEC
SBI PFSTM FIND TIME USED BY CALLER
JSR ICBLD BUILD INTO AN ICBLK
LDI PFETM RELOAD CURRENT TIME
BRN BPF7B MERGE
*
* HERE IF PROFILE = 2
*
BPF7A LDI PFSTM GET START TIME OF CALLING STMT
JSR ICBLD ASSEMBLE AN ICBLK ROUND IT
JSR SYSTM GET NOW TIME
*
* BOTH TYPES OF PROFILE MERGE HERE
*
BPF7B STI PFSTM SET START TIME OF 1ST FUNC STMT
MNZ PFFNC FLAG FUNCTION ENTRY
EJC
*
* PFBLK (CONTINUED)
*
* NO PROFILING MERGES HERE
*
BPF7C MOV XR,-(XS) STACK ICBLK PTR (OR ZERO)
MOV R$COD,WA LOAD OLD CODE BLOCK POINTER
.FI
SCP WB GET CODE POINTER
SUB WA,WB MAKE CODE POINTER INTO OFFSET
MOV BPFPF,XL RECALL PFBLK POINTER
MOV BPFSV,-(XS) STACK OLD VALUE OF FUNCTION NAME
MOV WA,-(XS) STACK CODE BLOCK POINTER
MOV WB,-(XS) STACK CODE OFFSET
MOV FLPRT,-(XS) STACK OLD FLPRT
MOV FLPTR,-(XS) STACK OLD FAILURE POINTER
MOV XL,-(XS) STACK POINTER TO PFBLK
ZER -(XS) DUMMY ZERO ENTRY FOR FAIL RETURN
CHK CHECK FOR STACK OVERFLOW
MOV XS,FLPTR SET NEW FAIL RETURN VALUE
MOV XS,FLPRT SET NEW FLPRT
MOV KVTRA,WA LOAD TRACE VALUE
ADD KVFTR,WA ADD FTRACE VALUE
BNZ WA,BPF09 JUMP IF TRACING POSSIBLE
ICV KVFNC ELSE BUMP FNCLEVEL
*
* HERE TO ACTUALLY JUMP TO FUNCTION
*
BPF08 MOV PFCOD(XL),XR POINT TO CODE
BRI (XR) OFF TO EXECUTE FUNCTION
*
* HERE IF TRACING IS POSSIBLE
*
BPF09 MOV PFCTR(XL),XR LOAD POSSIBLE CALL TRACE TRBLK
MOV PFVBL(XL),XL LOAD VRBLK POINTER FOR FUNCTION
MOV *VRVAL,WA SET NAME OFFSET FOR VARIABLE
BZE KVTRA,BPF10 JUMP IF TRACE MODE IS OFF
BZE XR,BPF10 OR IF THERE IS NO CALL TRACE
*
* HERE IF CALL TRACED
*
DCV KVTRA DECREMENT TRACE COUNT
BZE TRFNC(XR),BPF11 JUMP IF PRINT TRACE
JSR TRXEQ EXECUTE FUNCTION TYPE TRACE
EJC
*
* PFBLK (CONTINUED)
*
* HERE TO TEST FOR FTRACE TRACE
*
BPF10 BZE KVFTR,BPF16 JUMP IF FTRACE IS OFF
DCV KVFTR ELSE DECREMENT FTRACE
*
* HERE FOR PRINT TRACE
*
BPF11 JSR PRTSN PRINT STATEMENT NUMBER
JSR PRTNM PRINT FUNCTION NAME
MOV =CH$PP,WA LOAD LEFT PAREN
JSR PRTCH PRINT LEFT PAREN
MOV 1(XS),XL RECOVER PFBLK POINTER
BZE FARGS(XL),BPF15 SKIP IF NO ARGUMENTS
ZER WB ELSE SET ARGUMENT COUNTER
BRN BPF13 JUMP INTO LOOP
*
* LOOP TO PRINT ARGUMENT VALUES
*
BPF12 MOV =CH$CM,WA LOAD COMMA
JSR PRTCH PRINT TO SEPARATE FROM LAST ARG
*
* MERGE HERE FIRST TIME (NO COMMA REQUIRED)
*
BPF13 MOV WB,(XS) SAVE ARG CTR (OVER FAILOFFS IS OK)
WTB WB CONVERT TO BAU OFFSET
ADD WB,XL POINT TO NEXT ARGUMENT POINTER
MOV PFARG(XL),XR LOAD NEXT ARGUMENT VRBLK PTR
SUB WB,XL RESTORE PFBLK POINTER
MOV VRVAL(XR),XR LOAD NEXT VALUE
JSR PRTVL PRINT ARGUMENT VALUE
EJC
*
* HERE AFTER DEALING WITH ONE ARGUMENT
*
MOV (XS),WB RESTORE ARGUMENT COUNTER
ICV WB INCREMENT ARGUMENT COUNTER
BLT WB,FARGS(XL),BPF12 LOOP IF MORE TO PRINT
*
* MERGE HERE IN NO ARGS CASE TO PRINT PAREN
*
BPF15 MOV =CH$RP,WA LOAD RIGHT PAREN
JSR PRTCF PRINT TO TERMINATE OUTPUT
*
* MERGE HERE TO EXIT WITH TEST FOR FNCLEVEL TRACE
*
BPF16 ICV KVFNC INCREMENT FNCLEVEL
MOV R$FNC,XL LOAD PTR TO POSSIBLE TRBLK
JSR KTREX CALL KEYWORD TRACE ROUTINE
*
* CALL FUNCTION AFTER TRACE TESTS COMPLETE
*
MOV 1(XS),XL RESTORE PFBLK POINTER
BRN BPF08 JUMP BACK TO EXECUTE FUNCTION
.IF .CNRA
.ELSE
EJC
*
* RCBLK
*
* THE ROUTINE FOR AN RCBLK IS EXECUTED FROM THE GENERATED
* CODE TO LOAD A REAL VALUE ONTO THE STACK.
*
* (XR) POINTER TO RCBLK
*
B$RCL ENT BL$RC ENTRY POINT (RCBLK)
BRN EXIXR STACK XR AND OBEY NEXT CODE WORD
.FI
*
* SCBLK
*
* THE ROUTINE FOR AN SCBLK IS EXECUTED FROM THE GENERATED
* CODE TO LOAD A STRING VALUE ONTO THE STACK.
*
* (XR) POINTER TO SCBLK
*
B$SCL ENT BL$SC ENTRY POINT (SCBLK)
BRN EXIXR STACK XR AND OBEY NEXT CODE WORD
*
* TBBLK
*
* THE ROUTINE FOR A TBBLK IS NEVER EXECUTED
*
B$TBT ENT BL$TB ENTRY POINT (TBBLK)
*
* TEBLK
*
* THE ROUTINE FOR A TEBLK IS NEVER EXECUTED
*
B$TET ENT BL$TE ENTRY POINT (TEBLK)
*
* VCBLK
*
* THE ROUTINE FOR A VCBLK IS NEVER EXECUTED
*
B$VCT ENT BL$VC ENTRY POINT (VCBLK)
EJC
*
* VRBLK
*
* THE VRBLK ROUTINES ARE EXECUTED FROM THE GENERATED CODE.
* THERE ARE SIX ENTRIES FOR VRBLK COVERING VARIOUS CASES
*
B$VR$ ENT BL$$I MARK START OF VRBLK ENTRY POINTS
*
* ENTRY FOR VRGET (TRAPPED CASE). THIS ROUTINE IS CALLED
* FROM THE GENERATED CODE TO LOAD THE VALUE OF A VARIABLE.
* THIS ENTRY POINT IS USED IF AN ACCESS TRACE OR INPUT
* ASSOCIATION IS CURRENTLY ACTIVE.
*
* (XR) POINTER TO VRGET FIELD OF VRBLK
*
B$VRA ENT BL$$I ENTRY POINT
MOV XR,XL COPY NAME BASE (VRGET = 0)
MOV *VRVAL,WA SET NAME OFFSET
JSR ACESS ACCESS VALUE
PPM EXFAL FAIL IF ACCESS FAILS
BRN EXIXR ELSE EXIT WITH RESULT IN XR
*
* ENTRY FOR VRSTO (ERROR CASE. THIS ROUTINE IS CALLED FROM
* THE EXECUTED CODE FOR AN ATTEMPT TO MODIFY THE VALUE
* OF A PROTECTED (PATTERN VALUED) NATURAL VARIABLE.
*
B$VRE ENT ENTRY POINT
ERB 049,ATTEMPT TO CHANGE VALUE OF PROTECTED VARIABLE
*
* ENTRY FOR VRTRA (UNTRAPPED CASE). THIS ROUTINE IS CALLED
* FROM THE EXECUTED CODE TO TRANSFER TO A LABEL.
*
* (XR) POINTER TO VRTRA FIELD OF VRBLK
*
B$VRG ENT ENTRY POINT
MOV VRLBO(XR),XR LOAD CODE POINTER
MOV (XR),XL LOAD ENTRY ADDRESS
BRI XL JUMP TO ROUTINE FOR NEXT CODE WORD
*
* ENTRY FOR VRGET (UNTRAPPED CASE). THIS ROUTINE IS CALLED
* FROM THE GENERATED CODE TO LOAD THE VALUE OF A VARIABLE.
*
* (XR) POINTS TO VRGET FIELD OF VRBLK
*
B$VRL ENT ENTRY POINT
MOV VRVAL(XR),-(XS) LOAD VALUE ONTO STACK (VRGET = 0)
BRN EXITS OBEY NEXT CODE WORD
EJC
*
* VRBLK (CONTINUED)
*
* ENTRY FOR VRSTO (UNTRAPPED CASE). THIS ROUTINE IS CALLED
* FROM THE GENERATED CODE TO STORE THE VALUE OF A VARIABLE.
*
* (XR) POINTER TO VRSTO FIELD OF VRBLK
*
B$VRS ENT ENTRY POINT
MOV (XS),VRVLO(XR) STORE VALUE, LEAVE ON STACK
BRN EXITS OBEY NEXT CODE WORD
*
* VRTRA (TRAPPED CASE). THIS ROUTINE IS CALLED FROM THE
* GENERATED CODE TO TRANSFER TO A LABEL WHEN A LABEL
* TRACE IS CURRENTLY ACTIVE.
*
B$VRT ENT ENTRY POINT
SUB *VRTRA,XR POINT BACK TO START OF VRBLK
MOV XR,XL COPY VRBLK POINTER
MOV *VRVAL,WA SET NAME OFFSET
MOV VRLBL(XL),XR LOAD POINTER TO TRBLK
BZE KVTRA,BVRT2 JUMP IF TRACE IS OFF
DCV KVTRA ELSE DECREMENT TRACE COUNT
BZE TRFNC(XR),BVRT1 JUMP IF PRINT TRACE CASE
JSR TRXEQ ELSE EXECUTE FULL TRACE
BRN BVRT2 MERGE TO JUMP TO LABEL
*
* HERE FOR PRINT TRACE -- PRINT COLON ( LABEL NAME )
*
BVRT1 JSR PRTSN PRINT STATEMENT NUMBER
MOV XL,XR COPY VRBLK POINTER
MOV =CH$CL,WA COLON
JSR PRTCH PRINT IT
MOV =CH$PP,WA LEFT PAREN
JSR PRTCH PRINT IT
JSR PRTVN PRINT LABEL NAME
MOV =CH$RP,WA RIGHT PAREN
JSR PRTCF PRINT IT
MOV VRLBL(XL),XR POINT BACK TO TRBLK
*
* MERGE HERE TO JUMP TO LABEL
*
BVRT2 MOV TRLBL(XR),XR LOAD POINTER TO ACTUAL CODE
BRI (XR) EXECUTE STATEMENT AT LABEL
EJC
*
* VRBLK (CONTINUED)
*
* ENTRY FOR VRSTO (TRAPPED CASE). THIS ROUTINE IS CALLED
* FROM THE GENERATED CODE TO STORE THE VALUE OF A VARIABLE.
* THIS ENTRY IS USED WHEN A VALUE TRACE OR OUTPUT
* ASSOCIATION IS CURRENTLY ACTIVE.
*
* (XR) POINTER TO VRSTO FIELD OF VRBLK
*
B$VRV ENT ENTRY POINT
MOV (XS),WB LOAD VALUE (LEAVE COPY ON STACK)
SUB *VRSTO,XR POINT TO VRBLK
MOV XR,XL COPY VRBLK POINTER
MOV *VRVAL,WA SET OFFSET
JSR ASIGN CALL ASSIGNMENT ROUTINE
PPM EXFAL FAIL IF ASSIGNMENT FAILS
BRN EXITS ELSE RETURN WITH RESULT ON STACK
EJC
*
* XNBLK
*
* THE ROUTINE FOR AN XNBLK IS NEVER EXECUTED
*
B$XNT ENT BL$XN ENTRY POINT (XNBLK)
*
* XRBLK
*
* THE ROUTINE FOR AN XRBLK IS NEVER EXECUTED
*
B$XRT ENT BL$XR ENTRY POINT (XRBLK)
*
* MARK ENTRY ADDRESS PAST LAST BLOCK ACTION ROUTINE
*
B$YYY ENT BL$$I LAST BLOCK ROUTINE ENTRY POINT
TTL S P I T B O L -- PATTERN MATCHING ROUTINES
*
* THE FOLLOWING SECTION CONSISTS OF THE PATTERN MATCHING
* ROUTINES. ALL PATTERN NODES CONTAIN A POINTER (PCODE)
* TO ONE OF THE ROUTINES IN THIS SECTION (P$XXX).
*
* NOTE THAT THIS SECTION FOLLOWS THE B$XXX ROUTINES TO
* ENABLE A FAST TEST FOR THE PATTERN DATATYPE.
*
P$AAA ENT BL$$I ENTRY TO MARK FIRST PATTERN
*
*
* THE ENTRY CONDITIONS TO THE MATCH ROUTINE ARE AS FOLLOWS
* (SEE O$PMN, O$PMV, O$PMS AND PROCEDURE MATCH).
*
* STACK CONTENTS.
*
* NAME BASE (O$PMN ONLY)
* NAME OFFSET (O$PMN ONLY)
* TYPE (0-O$PMN, 1-O$PMV, 2-O$PMS)
* PMHBS --------------- INITIAL CURSOR (ZERO)
* INITIAL NODE POINTER
* XS ------------------ =NDABO (ANCHORED), =NDUNA (UNANCH)
*
* REGISTER VALUES.
*
* (XS) SET AS SHOWN IN STACK DIAGRAM
* (XR) POINTER TO INITIAL PATTERN NODE
* (WB) INITIAL CURSOR (ZERO)
*
* GLOBAL PATTERN VALUES
*
* R$PMS POINTER TO SUBJECT STRING SCBLK
* PMSSL LENGTH OF SUBJECT STRING IN CHARS
* PMDFL DOT FLAG, INITIALLY ZERO
* PMHBS SET AS SHOWN IN STACK DIAGRAM
*
* CONTROL IS PASSED BY BRANCHING THROUGH THE PCODE
* FIELD OF THE INITIAL PATTERN NODE (BRI (XR)).
EJC
*
* DESCRIPTION OF ALGORITHM
*
* A PATTERN STRUCTURE IS REPRESENTED AS A LINKED GRAPH
* OF NODES WITH THE FOLLOWING STRUCTURE.
*
* +------------------------------------+
* I PCODE I
* +------------------------------------+
* I PTHEN I
* +------------------------------------+
* I PARM1 I
* +------------------------------------+
* I PARM2 I
* +------------------------------------+
*
* PCODE IS A POINTER TO THE ROUTINE WHICH WILL PERFORM
* THE MATCH OF THIS PARTICULAR NODE TYPE.
*
* PTHEN IS A POINTER TO THE SUCCESSOR NODE. I.E. THE NODE
* TO BE MATCHED IF THE ATTEMPT TO MATCH THIS NODE SUCCEEDS.
* IF THIS IS THE LAST NODE OF THE PATTERN PTHEN POINTS
* TO THE DUMMY NODE NDNTH WHICH INITIATES PATTERN EXIT.
*
* PARM1, PARM2 ARE PARAMETERS WHOSE USE VARIES WITH THE
* PARTICULAR NODE. THEY ARE ONLY PRESENT IF REQUIRED.
*
* ALTERNATIVES ARE HANDLED WITH THE SPECIAL ALTERNATIVE
* NODE WHOSE PARAMETER POINTS TO THE NODE TO BE MATCHED
* IF THERE IS A FAILURE ON THE SUCCESSOR PATH.
*
* THE FOLLOWING EXAMPLE ILLUSTRATES THE MANNER IN WHICH
* THE STRUCTURE IS BUILT UP. THE PATTERN IS
*
* (A / B / C) (D / E) WHERE / IS ALTERNATION
*
* IN THE DIAGRAM, THE NODE MARKED + REPRESENTS AN
* ALTERNATIVE NODE AND THE DOTTED LINE FROM A + NODE
* REPRESENTS THE PARAMETER POINTER TO THE ALTERNATIVE.
*
* +---+ +---+ +---+ +---+
* I + I-----I A I-----I + I-----I D I-----
* +---+ +---+ I +---+ +---+
* . I .
* . I .
* +---+ +---+ I +---+
* I + I-----I B I--I I E I-----
* +---+ +---+ I +---+
* . I
* . I
* +---+ I
* I C I------------I
* +---+
EJC
*
* DURING THE MATCH, THE REGISTERS ARE USED AS FOLLOWS.
*
* (XR) POINTS TO THE CURRENT NODE
* (XL) SCRATCH
* (XS) MAIN STACK POINTER
* (WB) CURSOR (NUMBER OF CHARS MATCHED)
* (WA,WC) SCRATCH
*
* TO KEEP TRACK OF ALTERNATIVES, THE MAIN STACK IS USED AS
* A HISTORY STACK AND CONTAINS TWO WORD ENTRIES.
*
* WORD 1 SAVED CURSOR VALUE
* WORD 2 NODE TO MATCH ON FAILURE
*
* WHEN A FAILURE OCCURS, THE MOST RECENT ENTRY ON THIS
* STACK IS POPPED OFF TO RESTORE THE CURSOR AND POINT
* TO THE NODE TO BE MATCHED AS AN ALTERNATIVE. THE ENTRY
* AT THE BOTTOM OF THE STACK POINTS TO THE FOLLOWING
* SPECIAL NODES DEPENDING ON THE SCAN MODE.
*
* ANCHORED MODE THE BOTTOM ENTRY POINTS TO THE
* SPECIAL NODE NDABO WHICH CAUSES AN
* ABORT. THE CURSOR VALUE STORED
* WITH THIS ENTRY IS ALWAYS ZERO.
*
* UNANCHORED MODE THE BOTTOM ENTRY POINTS TO THE
* SPECIAL NODE NDUNA WHICH MOVES THE
* ANCHOR POINT AND RESTARTS THE MATCH
* THE CURSOR SAVED WITH THIS ENTRY
* IS THE NUMBER OF CHARACTERS WHICH
* LIE BEFORE THE INITIAL ANCHOR POINT
* (I.E. THE NUMBER OF ANCHOR MOVES).
* THIS ENTRY IS THREE WORDS LONG AND
* ALSO CONTAINS THE INITIAL PATTERN.
*
* ENTRIES ARE MADE ON THIS HISTORY STACK BY ALTERNATIVE
* NODES AND BY SOME SPECIAL COMPOUD PATTERNS AS DESCRIBED
* LATER ON. THE FOLLOWING GLOBAL LOCATIONS ARE USED DURING
* PATTERN MATCHING.
*
* R$PMS POINTER TO SUBJECT STRING
* PMSSL LENGTH OF SUBJECT STRING
* PMDFL FLAG SET NON-ZERO FOR DOT PATTERNS
* PMHBS BASE PTR FOR CURRENT HISTORY STACK
*
* THE FOLLOWING EXIT POINTS ARE AVAILABLE TO MATCH ROUTINES
*
* SUCCP SUCCESS IN MATCHING CURRENT NODE
* FAILP FAILURE IN MATCHING CURRENT NODE
EJC
*
* COMPOUND PATTERNS
*
* SOME PATTERNS HAVE IMPLICIT ALTERNATIVES AND THEIR
* REPRESENTATION IN THE PATTERN STRUCTURE CONSISTS OF A
* LINKED SET OF NODES AS INDICATED BY THESE DIAGRAMS.
*
* AS BEFORE, THE + REPRESENTS AN ALTERNATIVE NODE AND
* THE DOTTED LINE FROM A + NODE IS THE PARAMETER POINTER
* TO THE ALTERNATIVE PATTERN.
*
* ARB
* ---
*
* +---+ THIS NODE (P$ARB) MATCHES NULL
* I B I----- AND STACKS CURSOR, SUCCESSOR PTR,
* +---+ CURSOR (COPY) AND A PTR TO NDARC.
*
*
*
*
* BAL
* ---
*
* +---+ THE P$BAL NODE SCANS A BALANCED
* I B I----- STRING AND THEN STACKS A POINTER
* +---+ TO ITSELF ON THE HISTORY STACK.
EJC
*
* COMPOUND PATTERN STRUCTURES (CONTINUED)
*
*
* ARBNO
* -----
*
* +---+ THIS ALTERNATIVE NODE MATCHES NULL
* +----I + I----- THE FIRST TIME AND STACKS A POINTER
* I +---+ TO THE ARGUMENT PATTERN X.
* I .
* I .
* I +---+ NODE (P$ABA) TO STACK CURSOR
* I I A I AND HISTORY STACK BASE PTR.
* I +---+
* I I
* I I
* I +---+ THIS IS THE ARGUMENT PATTERN. AS
* I I X I INDICATED, THE SUCCESSOR OF THE
* I +---+ PATTERN IS THE P$ABC NODE
* I I
* I I
* I +---+ THIS NODE (P$ABC) POPS PMHBS,
* +----I C I STACKS OLD PMHBS AND PTR TO NDABD
* +---+ (UNLESS OPTIMISATION HAS OCCURRED)
*
* STRUCTURE AND EXECUTION OF THIS PATTERN RESEMBLE THOSE OF
* RECURSIVE PATTERN MATCHING AND IMMEDIATE ASSIGNMENT.
* THE ALTERNATIVE NODE AT THE HEAD OF THE STRUCTURE MATCHES
* NULL INITIALLY BUT ON SUBSEQUENT FAILURE ENSURES ATTEMPT
* TO MATCH THE ARGUMENT. BEFORE THE ARGUMENT IS MATCHED
* P$ABA STACKS THE CURSOR,PMHBS AND A PTR TO P$ABB. IF
* THE ARGUMENT CANT BE MATCHED , P$ABB REMOVES THIS SPECIAL
* STACK ENTRY AND FAILS.
* IF ARGUMENT IS MATCHED , P$ABC RESTORES THE OUTER PMHBS
* VALUE (SAVED BY P$ABA) . THEN IF THE ARGUMENT HAS LEFT
* ALTERNATIVES ON STACK IT STACKS THE INNER VALUE OF PMHBS
* AND A PTR TO NDABD. IF ARGUMENT LEFT NOTHING ON THE STACK
* IT OPTIMISES BY REMOVING ITEMS STACKED BY P$ABA. FINALLY
* A CHECK IS MADE THAT ARGUMENT MATCHED MORE THAN THE NULL
* STRING (CHECK IS INTENDED TO PREVENT USELESS LOOPING).
* IF SO THE SUCCESSOR IS AGAIN THE ALTERNATIVE NODE AT THE
* HEAD OF THE STRUCTURE , ENSURING A POSSIBLE EXTRA ATTEMPT
* TO MATCH THE ARG IF NECESSARY. IF NOT , THE SUCCESSOR TO
* ALTERNATIVE IS TAKEN SO AS TO TERMINATE THE LOOP. P$ABD
* RESTORES INNER PMHBS PTR AND FAILS , THUS TRYING TO MATCH
* ALTERNATIVES LEFT BY THE ARBNO ARGUMENT.
EJC
*
* COMPOUND PATTERN STRUCTURES (CONTINUED)
*
* BREAKX
* ------
*
* +---+ THIS NODE IS A BREAK NODE FOR
* +----I B I THE ARGUMENT TO BREAKX, IDENTICAL
* I +---+ TO AN ORDINARY BREAK NODE.
* I I
* I I
* I +---+ THIS ALTERNATIVE NODE STACKS A
* I I + I----- POINTER TO THE BREAKX NODE TO
* I +---+ ALLOW FOR SUBSEQUENT FAILURE
* I .
* I .
* I +---+ THIS IS THE BREAKX NODE ITSELF. IT
* +----I X I MATCHES ONE CHARACTER AND THEN
* +---+ PROCEEDS BACK TO THE BREAK NODE.
*
*
*
*
* FENCE
* -----
*
* +---+ THE FENCE NODE MATCHES NULL AND
* I F I----- STACKS A POINTER TO NODE NDABO TO
* +---+ ABORT ON A SUBSEQUENT REMATCH
*
*
*
*
* SUCCEED
* -------
*
* +---+ THE NODE FOR SUCCEED MATCHES NULL
* I S I----- AND STACKS A POINTER TO ITSELF
* +---+ TO REPEAT THE MATCH ON A FAILURE.
EJC
*
* COMPOUND PATTERNS (CONTINUED)
*
* BINARY DOT (PATTERN ASSIGNMENT)
* -------------------------------
*
* +---+ THIS NODE (P$PAA) SAVES THE CURRENT
* I A I CURSOR AND A POINTER TO THE
* +---+ SPECIAL NODE NDPAB ON THE STACK.
* I
* I
* +---+ THIS IS THE STRUCTURE FOR THE
* I X I PATTERN LEFT ARGUMENT OF THE
* +---+ PATTERN ASSIGNMENT CALL.
* I
* I
* +---+ THIS NODE (P$PAC) SAVES THE CURSOR,
* I C I----- A PTR TO ITSELF, THE CURSOR (COPY)
* +---+ AND A PTR TO NDPAD ON THE STACK.
*
*
* THE FUNCTION OF THE MATCH ROUTINE FOR NDPAB (P$PAB)
* IS SIMPLY TO UNSTACK ITSELF AND FAIL BACK ONTO THE STACK.
*
* THE MATCH ROUTINE FOR P$PAC ALSO SETS THE GLOBAL PATTERN
* FLAG PMDFL NON-ZERO TO INDICATE THAT PATTERN ASSIGNMENTS
* MAY HAVE OCCURED IN THE PATTERN MATCH
*
* IF PMDFL IS SET AT THE END OF THE MATCH (SEE P$NTH), THE
* HISTORY STACK IS SCANNED FOR MATCHING NDPAB-NDPAD PAIRS
* AND THE CORRESPONDING PATTERN ASSIGNMENTS ARE EXECUTED.
*
* THE FUNCTION OF THE MATCH ROUTINE FOR NDPAD (P$PAD)
* IS SIMPLY TO REMOVE ITS ENTRY FROM THE STACK AND FAIL.
* THIS INCLUDES REMOVING THE SPECIAL NODE POINTER STORED
* IN ADDITION TO THE STANDARD TWO ENTRIES ON THE STACK.
.IF .CNFN
.ELSE
EJC
*
* FENCE (FUNCTION)
* ----------------
*
* +---+ THIS NODE (P$FNA) SAVES THE
* I A I CURRENT HISTORY STACK AND A
* +---+ POINTER TO NDFNB ON THE STACK.
* I
* I
* +---+ THIS IS THE PATTERN STRUCTURE
* I X I GIVEN AS THE ARGUMENT TO THE
* +---+ FENCE FUNCTION.
* I
* I
* +---+ THIS NODE P$FNC RESTORES THE OUTER
* I C I HISTORY STACK PTR SAVED IN P$FNA,
* +---+ AND STACKS THE INNER STACK BASE
* PTR AND A POINTER TO NDFND ON THE
* STACK.
*
* NDFNB (F$FNB) SIMPLY IS THE FAILURE EXIT FOR PATTERN
* ARGUMENT FAILURE, AND IT POPS ITSELF AND FAILS ONTO THE
* STACK.
*
* THE MATCH ROUTINE P$FNC ALLOWS FOR AN OPTIMIZATION WHEN
* THE FENCE PATTERN LEAVES NO ALTERNATIVES. IN THIS CASE,
* THE NDFNB ENTRY IS POPPED, AND THE MATCH CONTINUES.
*
* NDFND (P$FND) IS ENTERED WHEN THE PATTERN FAILS AFTER
* GOING THROUGH A NON-OPTIMIZED P$FNC, AND IT POPS THE
* STACK BACK PAST THE INNER STACK BASE CREATED BY P$FNA
.FI
EJC
*
* COMPOUND PATTERNS (CONTINUED)
*
* EXPRESSION PATTERNS (RECURSIVE PATTERN MATCHES)
* -----------------------------------------------
*
* INITIAL ENTRY FOR A PATTERN NODE IS TO THE ROUTINE P$EXA.
* IF THE EVALUATED RESULT OF THE EXPRESSION IS ITSELF A
* PATTERN, THEN THE FOLLOWING STEPS ARE TAKEN TO ARRANGE
* FOR PROPER RECURSIVE PROCESSING.
*
* 1) A POINTER TO THE CURRENT NODE (THE P$EXA NODE) IS
* STORED ON THE HISTORY STACK WITH A DUMMY CURSOR.
*
* 2) A SPECIAL HISTORY STACK ENTRY IS MADE IN WHICH THE
* NODE POINTER POINTS TO NDEXB, AND THE CURSOR VALUE
* IS THE SAVED VALUE OF PMHBS ON ENTRY TO THIS NODE.
* THE MATCH ROUTINE FOR NDEXB (P$EXB) RESTORES PMHBS
* FROM THIS CURSOR ENTRY, POPS OFF THE P$EXA NODE
* POINTER AND FAILS.
*
* 3) THE RESULTING HISTORY STACK POINTER IS SAVED IN
* PMHBS TO ESTABLISH A NEW LEVEL OF HISTORY STACK.
*
* AFTER MATCHING A PATTERN, THE END OF MATCH ROUTINE GETS
* CONTROL (P$NTH). THIS ROUTINE PROCEEDS AS FOLLOWS.
*
* 1) LOAD THE CURRENT VALUE OF PMHBS AND RECOGNIZE THE
* OUTER LEVEL CASE BY THE FACT THAT THE ASSOCIATED
* CURSOR IN THIS CASE IS THE PATTERN MATCH TYPE CODE
* WHICH IS LESS THAN 3. TERMINATE THE MATCH IN THIS
* CASE AND CONTINUE EXECUTION OF THE PROGRAM.
*
* 2) OTHERWISE MAKE A SPECIAL HISTORY STACK ENTRY IN
* WHICH THE NODE POINTER POINTS TO THE SPECIAL NODE
* NDEXC AND THE CURSOR IS THE CURRENT VALUE OF PMHBS.
* THE MATCH ROUTINE FOR NDEXC (P$EXC) RESETS PMHBS TO
* THIS (INNER) VALUE AND AND THEN FAILS.
*
* 3) USING THE HISTORY STACK ENTRY MADE ON STARTING THE
* EXPRESSION (ACCESSIBLE WITH THE CURRENT VALUE OF
* PMHBS), RESTORE THE P$EXA NODE POINTER AND THE OLD
* PMHBS SETTING. TAKE THE SUCCESSOR AND CONTINUE.
*
* AN OPTIMIZATION IS POSSIBLE IF THE EXPRESSION PATTERN
* MAKES NO ENTRIES ON THE HISTORY STACK. IN THIS CASE,
* INSTEAD OF BUILDING THE P$EXC NODE IN STEP 2, IT IS MORE
* EFFICIENT TO SIMPLY POP OFF THE P$EXB ENTRY AND ITS
* ASSOCIATED NODE POINTER. THE EFFECT IS THE SAME.
EJC
*
* COMPOUND PATTERNS (CONTINUED)
*
* BINARY DOLLAR (IMMEDIATE ASSIGNMENT)
* ------------------------------------
*
* +---+ THIS NODE (P$IMA) STACKS THE CURSOR
* I A I PMHBS AND A PTR TO NDIMB AND RESETS
* +---+ THE STACK PTR PMHBS.
* I
* I
* +---+ THIS IS THE LEFT STRUCTURE FOR THE
* I X I PATTERN LEFT ARGUMENT OF THE
* +---+ IMMEDIATE ASSIGNMENT CALL.
* I
* I
* +---+ THIS NODE (P$IMC) PERFORMS THE
* I C I----- ASSIGNMENT, POPS PMHBS AND STACKS
* +---+ THE OLD PMHBS AND A PTR TO NDIMD.
*
*
* THE STRUCTURE AND EXECUTION OF THIS PATTERN ARE SIMILAR
* TO THOSE OF THE RECURSIVE EXPRESSION PATTERN MATCHING.
*
* THE MATCH ROUTINE FOR NDIMB (P$IMB) RESTORES THE OUTER
* LEVEL VALUE OF PMHBS, UNSTACKS THE SAVED CURSOR AND FAILS
*
* THE MATCH ROUTINE P$IMC USES THE CURRENT VALUE OF PMHBS
* TO LOCATE THE P$IMB ENTRY. THIS ENTRY IS USED TO MAKE
* THE ASSIGNMENT AND RESTORE THE OUTER LEVEL VALUE OF
* PMHBS. FINALLY, THE INNER LEVEL VALUE OF PMHBS AND A
* POINTER TO THE SPECIAL NODE NDIMD ARE STACKED.
*
* THE MATCH ROUTINE FOR NDIMD (P$IMD) RESTORES THE INNER
* LEVEL VALUE OF PMHBS AND FAILS BACK INTO THE STACK.
*
* AN OPTIMIZATION OCCURS IF THE INNER PATTERN MAKES NO
* ENTRIES ON THE HISTORY STACK. IN THIS CASE, P$IMC POPS
* THE P$IMB ENTRY INSTEAD OF MAKING A P$IMD ENTRY.
EJC
*
* ARBNO
*
* SEE COMPOUND PATTERNS SECTION FOR STUCTURE AND
* ALGORITHM FOR MATCHING THIS NODE TYPE.
*
* NO PARAMETERS
*
P$ABA ENT BL$P0 P0BLK
MOV WB,-(XS) STACK CURSOR
MOV XR,-(XS) STACK DUMMY NODE PTR
MOV PMHBS,-(XS) STACK OLD STACK BASE PTR
MOV =NDABB,-(XS) STACK PTR TO NODE NDABB
MOV XS,PMHBS STORE NEW STACK BASE PTR
BRN SUCCP SUCCEED
*
* ARBNO (REMOVE P$ABA SPECIAL STACK ENTRY)
*
* NO PARAMETERS (DUMMY PATTERN)
*
P$ABB ENT ENTRY POINT
MOV WB,PMHBS RESTORE HISTORY STACK BASE PTR
BRN FLPOP FAIL AND POP DUMMY NODE PTR
*
* ARBNO (CHECK IF ARG MATCHED NULL STRING)
*
* NO PARAMETERS (DUMMY PATTERN)
*
P$ABC ENT BL$P0 P0BLK
MOV PMHBS,XT KEEP P$ABB STACK BASE
MOV 3(XT),WA LOAD INITIAL CURSOR
MOV 1(XT),PMHBS RESTORE OUTER STACK BASE PTR
BEQ XT,XS,PABC1 JUMP IF NO HISTORY STACK ENTRIES
MOV XT,-(XS) ELSE SAVE INNER PMHBS ENTRY
MOV =NDABD,-(XS) STACK PTR TO SPECIAL NODE NDABD
BRN PABC2 MERGE
*
* OPTIMISE CASE OF NO EXTRA ENTRIES ON STACK FROM ARBNO ARG
*
PABC1 ADD *NUM04,XS REMOVE NDABB ENTRY AND CURSOR
*
* MERGE TO CHECK FOR MATCHING OF NULL STRING
*
PABC2 BNE WA,WB,SUCCP ALLOW FURTHER ATTEMPT IF NON-NULL
MOV PTHEN(XR),XR BYPASS ALTERNATIVE NODE SO AS TO ..
BRN SUCCP ... REFUSE FURTHER MATCH ATTEMPTS
*
* ARBNO (TRY FOR ALTERNATIVES IN ARBNO ARGUMENT)
*
* NO PARAMETERS (DUMMY PATTERN)
*
P$ABD ENT ENTRY POINT
MOV WB,PMHBS RESTORE INNER STACK BASE PTR
BRN FAILP AND FAIL
EJC
*
* ABORT
*
* NO PARAMETERS
*
P$ABO ENT BL$P0 P0BLK
BRN EXFAL SIGNAL STATEMENT FAILURE
*
* ALTERNATION
*
* PARM1 ALTERNATIVE NODE
*
P$ALT ENT BL$P1 P1BLK
MOV WB,-(XS) STACK CURSOR
MOV PARM1(XR),-(XS) STACK POINTER TO ALTERNATIVE
CHK CHECK FOR STACK OVERFLOW
BRN SUCCP IF ALL OK, THEN SUCCEED
EJC
*
* ANY (ONE CHARACTER ARGUMENT) (1-CHAR STRING ALSO)
*
* PARM1 CHARACTER ARGUMENT
*
P$ANS ENT BL$P1 P1BLK
BEQ WB,PMSSL,FAILP FAIL IF NO CHARS LEFT
MOV R$PMS,XL ELSE POINT TO SUBJECT STRING
PLC XL,WB POINT TO CURRENT CHARACTER
LCH WA,(XL) LOAD CURRENT CHARACTER
BNE WA,PARM1(XR),FAILP FAIL IF NO MATCH
ICV WB ELSE BUMP CURSOR
BRN SUCCP AND SUCCEED
*
* ANY (MULTI-CHARACTER ARGUMENT CASE)
* EXPRESSION ARGUMENT CASE MERGES
*
* PARM1 POINTER TO CTBLK
* PARM2 BIT MASK TO SELECT BIT IN CTBLK
*
P$ANY ENT BL$P2 P2BLK
BEQ WB,PMSSL,FAILP FAIL IF NO CHARACTERS LEFT
MOV R$PMS,XL ELSE POINT TO SUBJECT STRING
PLC XL,WB GET CHAR PTR TO CURRENT CHARACTER
LCH WA,(XL) LOAD CURRENT CHARACTER
MOV PARM1(XR),XL POINT TO CTBLK
WTB WA CHANGE TO BAU OFFSET
ADD WA,XL POINT TO ENTRY IN CTBLK
MOV CTCHS(XL),WA LOAD WORD FROM CTBLK
ANB PARM2(XR),WA AND WITH SELECTED BIT
ZRB WA,FAILP FAIL IF NO MATCH
ICV WB ELSE BUMP CURSOR
BRN SUCCP AND SUCCEED
*
* ANY (EXPRESSION ARGUMENT)
*
* PARM1 EXPRESSION POINTER
*
P$AYD ENT BL$P1 P1BLK
MOV =P$ANY,WA PCODE FOR NEW NODE
JSR EVALS EVALUATE STRING ARGUMENT
ERR 050,ANY EVALUATED ARGUMENT IS NOT STRING
PPM FAILP FAIL IF EVALUATION FAILURE
BRI XL MERGE MULTI-CHAR CASE IF OK
EJC
*
* P$ARB INITIAL ARB MATCH
*
* NO PARAMETERS
*
* THE P$ARB NODE IS PART OF A COMPOUND PATTERN STRUCTURE
* FOR AN ARB PATTERN (SEE DESCRIPTION OF COMPOUND PATTERNS)
*
P$ARB ENT BL$P0 P0BLK
MOV PTHEN(XR),XR LOAD SUCCESSOR POINTER
MOV WB,-(XS) STACK DUMMY CURSOR
MOV XR,-(XS) STACK SUCCESSOR POINTER
MOV WB,-(XS) STACK CURSOR
MOV =NDARC,-(XS) STACK PTR TO SPECIAL NODE NDARC
BRI (XR) EXECUTE NEXT NODE MATCHING NULL
*
* P$ARC EXTEND ARB MATCH
*
* NO PARAMETERS (DUMMY PATTERN)
*
P$ARC ENT ENTRY POINT
BEQ WB,PMSSL,FLPOP FAIL AND POP STACK TO SUCCESSOR
ICV WB ELSE BUMP CURSOR
MOV WB,-(XS) STACK UPDATED CURSOR
MOV XR,-(XS) RESTACK POINTER TO NDARC NODE
MOV 2(XS),XR LOAD SUCCESSOR POINTER
BRI (XR) OFF TO REEXECUTE SUCCESSOR NODE
EJC
*
* BAL
*
* NO PARAMETERS
*
* THE P$BAL NODE IS PART OF THE COMPOUND STRUCTURE BUILT
* FOR BAL (SEE SECTION ON COMPOUND PATTERNS).
*
P$BAL ENT BL$P0 P0BLK
ZER WC ZERO PARENTHESES LEVEL COUNTER
MOV R$PMS,XL POINT TO SUBJECT STRING
PLC XL,WB POINT TO CURRENT CHARACTER
BRN PBAL2 JUMP INTO SCAN LOOP
*
* LOOP TO SCAN OUT CHARACTERS
*
PBAL1 LCH WA,(XL)+ LOAD NEXT CHARACTER, BUMP POINTER
ICV WB PUSH CURSOR FOR CHARACTER
BEQ WA,=CH$PP,PBAL3 JUMP IF LEFT PAREN
BEQ WA,=CH$RP,PBAL4 JUMP IF RIGHT PAREN
BZE WC,PBAL5 ELSE SUCCEED IF AT OUTER LEVEL
*
* HERE AFTER PROCESSING ONE CHARACTER
*
PBAL2 BNE WB,PMSSL,PBAL1 LOOP BACK UNLESS END OF STRING
BRN FAILP IN WHICH CASE, FAIL
*
* HERE ON LEFT PAREN
*
PBAL3 ICV WC BUMP PAREN LEVEL
BRN PBAL2 LOOP BACK TO CHECK END OF STRING
*
* HERE FOR RIGHT PAREN
*
PBAL4 BZE WC,FAILP FAIL IF NO MATCHING LEFT PAREN
DCV WC ELSE DECREMENT LEVEL COUNTER
BNZ WC,PBAL2 LOOP BACK IF NOT AT OUTER LEVEL
*
* HERE AFTER SUCCESSFULLY SCANNING A BALANCED STRING
*
PBAL5 MOV WB,-(XS) STACK CURSOR
MOV XR,-(XS) STACK PTR TO BAL NODE FOR EXTEND
BRN SUCCP AND SUCCEED
EJC
*
* BREAK (EXPRESSION ARGUMENT)
*
* PARM1 EXPRESSION POINTER
*
P$BKD ENT BL$P1 P1BLK
MOV =P$BRK,WA PCODE FOR NEW NODE
JSR EVALS EVALUATE STRING EXPRESSION
ERR 051,BREAK EVALUATED ARGUMENT IS NOT STRING
PPM FAILP FAIL IF EVALUATION FAILS
BRI XL MERGE WITH MULTI-CHAR CASE IF OK
*
* BREAK (ONE CHARACTER ARGUMENT)
*
* PARM1 CHARACTER ARGUMENT
*
P$BKS ENT BL$P1 P1BLK
MOV PMSSL,WC GET SUBJECT STRING LENGTH
SUB WB,WC GET NUMBER OF CHARACTERS LEFT
BZE WC,FAILP FAIL IF NO CHARACTERS LEFT
LCT WC,WC SET COUNTER FOR CHARS LEFT
MOV R$PMS,XL POINT TO SUBJECT STRING
PLC XL,WB POINT TO CURRENT CHARACTER
*
* LOOP TO SCAN TILL BREAK CHARACTER FOUND
*
PBKS1 LCH WA,(XL)+ LOAD NEXT CHAR, BUMP POINTER
BEQ WA,PARM1(XR),SUCCP SUCCEED IF BREAK CHARACTER FOUND
ICV WB ELSE PUSH CURSOR
BCT WC,PBKS1 LOOP BACK IF MORE TO GO
BRN FAILP FAIL IF END OF STRING, NO BREAK CHR
EJC
*
* BREAK (MULTI-CHARACTER ARGUMENT)
* EXPRESSION ARGUMENT CASE MERGES
*
* PARM1 POINTER TO CTBLK
* PARM2 BIT MASK TO SELECT BIT COLUMN
*
P$BRK ENT BL$P2 P2BLK
MOV PMSSL,WC LOAD SUBJECT STRING LENGTH
SUB WB,WC GET NUMBER OF CHARACTERS LEFT
BZE WC,FAILP FAIL IF NO CHARACTERS LEFT
LCT WC,WC SET COUNTER FOR CHARACTERS LEFT
MOV R$PMS,XL ELSE POINT TO SUBJECT STRING
PLC XL,WB POINT TO CURRENT CHARACTER
MOV XR,PSAVE SAVE NODE POINTER
*
* LOOP TO SEARCH FOR BREAK CHARACTER
*
PBRK2 LCH WA,(XL)+ LOAD NEXT CHAR, BUMP POINTER
MOV PARM1(XR),XR LOAD POINTER TO CTBLK
WTB WA CONVERT TO BAU OFFSET
ADD WA,XR POINT TO CTBLK ENTRY
MOV CTCHS(XR),WA LOAD CTBLK WORD
MOV PSAVE,XR RESTORE NODE POINTER
ANB PARM2(XR),WA AND WITH SELECTED BIT
NZB WA,SUCCP SUCCEED IF BREAK CHARACTER FOUND
ICV WB ELSE PUSH CURSOR
BCT WC,PBRK2 LOOP BACK UNLESS END OF STRING
BRN FAILP FAIL IF END OF STRING, NO BREAK CHR
EJC
*
* BREAKX (EXTENSION)
*
* THIS IS THE ENTRY WHICH CAUSES AN EXTENSION OF A BREAKX
* MATCH WHEN FAILURE OCCURS. SEE SECTION ON COMPOUND
* PATTERNS FOR FULL DETAILS OF BREAKX MATCHING.
*
* NO PARAMETERS
*
P$BKX ENT BL$P0 P0BLK
ICV WB STEP CURSOR PAST PREVIOUS BREAK CHR
BRN SUCCP SUCCEED TO REMATCH BREAK
*
* BREAKX (EXPRESSION ARGUMENT)
*
* SEE SECTION ON COMPOUND PATTERNS FOR FULL STRUCTURE OF
* BREAKX PATTERN. THE ACTUAL CHARACTER MATCHING USES A
* BREAK NODE. HOWEVER, THE ENTRY FOR THE EXPRESSION
* ARGUMENT CASE IS SEPARATED TO GET PROPER ERROR MESSAGES.
*
* PARM1 EXPRESSION POINTER
*
P$BXD ENT BL$P1 P1BLK
MOV =P$BRK,WA PCODE FOR NEW NODE
JSR EVALS EVALUATE STRING ARGUMENT
ERR 052,BREAKX EVALUATED ARGUMENT IS NOT STRING
PPM FAILP FAIL IF EVALUATION FAILS
BRI XL MERGE WITH BREAK IF ALL OK
*
* CURSOR ASSIGNMENT
*
* PARM1 NAME BASE
* PARM2 NAME OFFSET
*
P$CAS ENT BL$P2 P2BLK
MOV XR,-(XS) SAVE NODE POINTER
MOV WB,-(XS) SAVE CURSOR
MOV PARM1(XR),XL LOAD NAME BASE
MTI WB LOAD CURSOR AS INTEGER
MOV PARM2(XR),WB LOAD NAME OFFSET
JSR ICBLD GET ICBLK FOR CURSOR VALUE
MOV WB,WA MOVE NAME OFFSET
MOV XR,WB MOVE VALUE TO ASSIGN
JSR ASINP PERFORM ASSIGNMENT
PPM FLPOP FAIL ON ASSIGNMENT FAILURE
MOV (XS)+,WB ELSE RESTORE CURSOR
MOV (XS)+,XR RESTORE NODE POINTER
BRN SUCCP AND SUCCEED MATCHING NULL
EJC
*
* EXPRESSION NODE (P$EXA, INITIAL ENTRY)
*
* SEE COMPOUND PATTERNS DESCRIPTION FOR THE STRUCTURE AND
* ALGORITHMS FOR HANDLING EXPRESSION NODES.
*
* PARM1 EXPRESSION POINTER
*
P$EXA ENT BL$P1 P1BLK
JSR EVALP EVALUATE EXPRESSION
PPM FAILP FAIL IF EVALUATION FAILS
BLO WA,=P$AAA,PEXA1 JUMP IF RESULT IS NOT A PATTERN
*
* HERE IF RESULT OF EXPRESSION IS A PATTERN
*
MOV WB,-(XS) STACK DUMMY CURSOR
MOV XR,-(XS) STACK PTR TO P$EXA NODE
MOV PMHBS,-(XS) STACK HISTORY STACK BASE PTR
MOV =NDEXB,-(XS) STACK PTR TO SPECIAL NODE NDEXB
MOV XS,PMHBS STORE NEW STACK BASE POINTER
MOV XL,XR COPY NODE POINTER
BRI (XR) MATCH FIRST NODE IN EXPRESSION PAT
*
* HERE IF RESULT OF EXPRESSION IS NOT A PATTERN
*
PEXA1 BEQ WA,=B$SCL,PEXA2 JUMP IF IT IS ALREADY A STRING
MOV XL,-(XS) ELSE STACK RESULT
MOV XR,XL SAVE NODE POINTER
JSR GTSTG CONVERT RESULT TO STRING
ERR 053,EXPRESSION DOES NOT EVALUATE TO PATTERN
MOV XR,WC COPY STRING POINTER
MOV XL,XR RESTORE NODE POINTER
MOV WC,XL COPY STRING POINTER AGAIN
*
* MERGE HERE WITH STRING POINTER IN XL
*
PEXA2 BZE SCLEN(XL),SUCCP JUST SUCCEED IF NULL STRING
MOV XR,PSAVE SAVE NODE PTR
MOV R$PMS,XR LOAD SUBJECT STRING PTR
PLC XR,WB POINT TO CURRENT CHAR
ADD SCLEN(XL),WB COMPUTE NEW CURSOR POSITION
BGT WB,PMSSL,FAILP FAIL IF PAST END OF STRING
MOV WB,PSAVC SAVE UPDATED CURSOR
MOV SCLEN(XL),WA NUMBER OF CHARS TO COMPARE
PLC XL POINT TO TEST STRING CHARS
CMC FAILP,FAILP COMPARE, FAIL IF UNEQUAL
MOV PSAVE,XR IF ALL MATCHED, RESTORE NODE PTR
MOV PSAVC,WB RESTORE UPDATED CURSOR
BRN SUCCP AND SUCCEED
EJC
*
* EXPRESSION NODE (P$EXB, REMOVE NDEXB ENTRY)
*
* SEE COMPOUND PATTERNS DESCRIPTION FOR THE STRUCTURE AND
* ALGORITHMS FOR HANDLING EXPRESSION NODES.
*
* NO PARAMETERS (DUMMY PATTERN)
*
P$EXB ENT ENTRY POINT
MOV WB,PMHBS RESTORE OUTER LEVEL STACK POINTER
BRN FLPOP FAIL AND POP P$EXA NODE PTR
EJC
*
* EXPRESSION NODE (P$EXC, REMOVE NDEXC ENTRY)
*
* SEE COMPOUND PATTERNS DESCRIPTION FOR THE STRUCTURE AND
* ALGORITHMS FOR HANDLING EXPRESSION NODES.
*
* NO PARAMETERS (DUMMY PATTERN)
*
P$EXC ENT ENTRY POINT
MOV WB,PMHBS RESTORE INNER STACK BASE POINTER
BRN FAILP AND FAIL INTO EXPR PATTERN ALTERNVS
*
* FAIL
*
* NO PARAMETERS
*
P$FAL ENT BL$P0 P0BLK
BRN FAILP JUST SIGNAL FAILURE
EJC
* FENCE
*
* SEE COMPOUND PATTERNS SECTION FOR THE STRUCTURE AND
* ALGORITHM FOR MATCHING THIS NODE TYPE.
*
* NO PARAMETERS
*
P$FEN ENT BL$P0 P0BLK
MOV WB,-(XS) STACK DUMMY CURSOR
MOV =NDABO,-(XS) STACK PTR TO ABORT NODE
BRN SUCCP AND SUCCEED MATCHING NULL
.IF .CNFN
.ELSE
*
* FENCE (FUNCTION)
*
* SEE COMPOUND PATTERNS COMMENTS AT START OF THIS SECTION
* FOR DETAILS OF SCHEME
*
* NO PARAMETERS
*
P$FNA ENT BL$P0 P0BLK
MOV PMHBS,-(XS) STACK CURRENT HISTORY STACK BASE
MOV =NDFNB,-(XS) STACK INDIR PTR TO P$FNB (FAILURE)
MOV XS,PMHBS BEGIN NEW HISTORY STACK
BRN SUCCP SUCCEED
*
* FENCE (FUNCTION) (RESET HISTORY STACK AND FAIL)
*
* NO PARAMETERS (DUMMY PATTERN)
*
P$FNB ENT BL$P0 P0BLK
MOV WB,PMHBS RESTORE OUTER PMHBS STACK BASE
BRN FAILP ...AND FAIL
*
* FENCE (FUNCTION) (MAKE FENCE TRAP ENTRY ON STACK)
*
* NO PARAMETERS (DUMMY PATTERN)
*
P$FNC ENT BL$P0 P0BLK
MOV PMHBS,XT GET INNER STACK BASE PTR
MOV NUM01(XT),PMHBS RESTORE OUTER STACK BASE
BEQ XT,XS,PFNC1 OPTIMIZE IF NO ALTERNATIVES
MOV XT,-(XS) ELSE STACK INNER STACK BASE
MOV =NDFND,-(XS) STACK PTR TO NDFND
BRN SUCCP SUCCEED
*
* HERE WHEN FENCE FUNCTION LEFT NOTHING ON THE STACK
*
PFNC1 ADD *NUM02,XS POP OFF P$FNB ENTRY
BRN SUCCP SUCCEED
*
* FENCE (FUNCTION) (SKIP PAST ALTERNATIVES ON FAILURE)
*
* NO PARAMETERS (DUMMY PATTERN)
*
P$FND ENT BL$P0 P0BLK
MOV WB,XS POP STACK TO FENCE() HISTORY BASE
BRN FLPOP POP BASE ENTRY AND FAIL
.FI
EJC
*
* IMMEDIATE ASSIGNMENT (INITIAL ENTRY, SAVE CURRENT CURSOR)
*
* SEE COMPOUND PATTERNS DESCRIPTION FOR DETAILS OF THE
* STRUCTURE AND ALGORITHM FOR MATCHING THIS NODE TYPE.
*
* NO PARAMETERS
*
P$IMA ENT BL$P0 P0BLK
MOV WB,-(XS) STACK CURSOR
MOV XR,-(XS) STACK DUMMY NODE POINTER
MOV PMHBS,-(XS) STACK OLD STACK BASE POINTER
MOV =NDIMB,-(XS) STACK PTR TO SPECIAL NODE NDIMB
MOV XS,PMHBS STORE NEW STACK BASE POINTER
BRN SUCCP AND SUCCEED
*
* IMMEDIATE ASSIGNMENT (REMOVE CURSOR MARK ENTRY)
*
* SEE COMPOUND PATTERNS DESCRIPTION FOR DETAILS OF THE
* STRUCTURE AND ALGORITHMS FOR MATCHING THIS NODE TYPE.
*
* NO PARAMETERS (DUMMY PATTERN)
*
P$IMB ENT ENTRY POINT
MOV WB,PMHBS RESTORE HISTORY STACK BASE PTR
BRN FLPOP FAIL AND POP DUMMY NODE PTR
EJC
*
* IMMEDIATE ASSIGNMENT (PERFORM ACTUAL ASSIGNMENT)
*
* SEE COMPOUND PATTERNS DESCRIPTION FOR DETAILS OF THE
* STRUCTURE AND ALGORITHMS FOR MATCHING THIS NODE TYPE.
*
* PARM1 NAME BASE OF VARIABLE
* PARM2 NAME OFFSET OF VARIABLE
*
P$IMC ENT BL$P2 P2BLK
MOV PMHBS,XT LOAD POINTER TO P$IMB ENTRY
MOV WB,WA COPY FINAL CURSOR
MOV 3(XT),WB LOAD INITIAL CURSOR
MOV 1(XT),PMHBS RESTORE OUTER STACK BASE POINTER
BEQ XT,XS,PIMC1 JUMP IF NO HISTORY STACK ENTRIES
MOV XT,-(XS) ELSE SAVE INNER PMHBS POINTER
MOV =NDIMD,-(XS) AND A PTR TO SPECIAL NODE NDIMD
BRN PIMC2 MERGE
*
* HERE IF NO ENTRIES MADE ON HISTORY STACK
*
PIMC1 ADD *NUM04,XS REMOVE NDIMB ENTRY AND CURSOR
*
* MERGE HERE TO PERFORM ASSIGNMENT
*
PIMC2 MOV WA,-(XS) SAVE CURRENT (FINAL) CURSOR
MOV XR,-(XS) SAVE CURRENT NODE POINTER
MOV R$PMS,XL POINT TO SUBJECT STRING
SUB WB,WA COMPUTE SUBSTRING LENGTH
JSR SBSTR BUILD SUBSTRING
MOV XR,WB MOVE RESULT
MOV (XS),XR RELOAD NODE POINTER
MOV PARM1(XR),XL LOAD NAME BASE
MOV PARM2(XR),WA LOAD NAME OFFSET
JSR ASINP PERFORM ASSIGNMENT
PPM FLPOP FAIL IF ASSIGNMENT FAILS
MOV (XS)+,XR ELSE RESTORE NODE POINTER
MOV (XS)+,WB RESTORE CURSOR
BRN SUCCP AND SUCCEED
*
* IMMEDIATE ASSIGNMENT (REMOVE NDIMD ENTRY ON FAILURE)
*
* SEE COMPOUND PATTERNS DESCRIPTION FOR DETAILS OF THE
* STRUCTURE AND ALGORITHMS FOR MATCHING THIS NODE TYPE.
*
* NO PARAMETERS (DUMMY PATTERN)
*
P$IMD ENT ENTRY POINT
MOV WB,PMHBS RESTORE INNER STACK BASE POINTER
BRN FAILP AND FAIL
EJC
*
* LEN (INTEGER ARGUMENT)
*
* PARM1 INTEGER ARGUMENT
*
P$LEN ENT BL$P1 P1BLK
ADD PARM1(XR),WB PUSH CURSOR INDICATED AMOUNT
BLE WB,PMSSL,SUCCP SUCCEED IF NOT OFF END
BRN FAILP ELSE FAIL
*
* LEN (EXPRESSION ARGUMENT)
*
* PARM1 EXPRESSION POINTER
*
P$LND ENT BL$P1 P1BLK
JSR EVALI EVALUATE INTEGER ARGUMENT
ERR 054,LEN EVALUATED ARGUMENT IS NOT INTEGER
ERR 055,LEN EVALUATED ARGUMENT IS NEGATIVE OR TOO LARGE
PPM FAILP FAIL IF EVALUATION FAILS
ADD PARM1(XR),WB PUSH CURSOR INDICATED AMOUNT
BLE WB,PMSSL,SUCCP SUCCEED IF NOT OFF END
BRN FAILP ELSE FAIL
EJC
*
* NOTANY (EXPRESSION ARGUMENT)
*
* PARM1 EXPRESSION POINTER
*
P$NAD ENT BL$P1 P1BLK
MOV =P$NAY,WA PCODE FOR NEW NODE
JSR EVALS EVALUATE STRING ARGUMENT
ERR 056,NOTANY EVALUATED ARGUMENT IS NOT STRING
PPM FAILP FAIL IF EVALUATION FAILS
BRI XL MERGE WITH MULTI-CHAR CASE IF OK
EJC
*
* NOTANY (ONE CHARACTER ARGUMENT)
*
* PARM1 CHARACTER ARGUMENT
*
P$NAS ENT BL$P1 ENTRY POINT
BEQ WB,PMSSL,FAILP FAIL IF NO CHARS LEFT
MOV R$PMS,XL ELSE POINT TO SUBJECT STRING
PLC XL,WB POINT TO CURRENT CHARACTER IN STRIN
LCH WA,(XL) LOAD CURRENT CHARACTER
BEQ WA,PARM1(XR),FAILP FAIL IF MATCH
ICV WB ELSE BUMP CURSOR
BRN SUCCP AND SUCCEED
EJC
*
* NOTANY (MULTI-CHARACTER STRING ARGUMENT)
* EXPRESSION ARGUMENT CASE MERGES
*
* PARM1 POINTER TO CTBLK
* PARM2 BIT MASK TO SELECT BIT COLUMN
*
P$NAY ENT BL$P2 P2BLK
BEQ WB,PMSSL,FAILP FAIL IF NO CHARACTERS LEFT
MOV R$PMS,XL ELSE POINT TO SUBJECT STRING
PLC XL,WB POINT TO CURRENT CHARACTER
LCH WA,(XL) LOAD CURRENT CHARACTER
WTB WA CONVERT TO BAU OFFSET
MOV PARM1(XR),XL LOAD POINTER TO CTBLK
ADD WA,XL POINT TO ENTRY IN CTBLK
MOV CTCHS(XL),WA LOAD ENTRY FROM CTBLK
ANB PARM2(XR),WA AND WITH SELECTED BIT
NZB WA,FAILP FAIL IF CHARACTER IS MATCHED
ICV WB ELSE BUMP CURSOR
BRN SUCCP AND SUCCEED
EJC
*
* END OF PATTERN MATCH
*
* THIS ROUTINE IS ENTERED ON SUCCESSFUL COMPLETION.
* SEE DESCRIPTION OF EXPRESSION PATTERNS IN COMPOUND
* PATTERN SECTION FOR HANDLING OF RECURSION IN MATCHING.
*
* NO PARAMETERS (DUMMY PATTERN)
*
P$NTH ENT ENTRY POINT
MOV PMHBS,XT LOAD POINTER TO BASE OF STACK
MOV 1(XT),WA LOAD SAVED PMHBS (OR PATTERN TYPE)
BLE WA,=NUM02,PNTH2 JUMP IF OUTER LEVEL (PATTERN TYPE)
*
* HERE WE ARE AT THE END OF MATCHING AN EXPRESSION PATTERN
*
MOV WA,PMHBS RESTORE OUTER STACK BASE POINTER
MOV 2(XT),XR RESTORE POINTER TO P$EXA NODE
BEQ XT,XS,PNTH1 JUMP IF NO HISTORY STACK ENTRIES
MOV XT,-(XS) ELSE STACK INNER STACK BASE PTR
MOV =NDEXC,-(XS) STACK PTR TO SPECIAL NODE NDEXC
BRN SUCCP AND SUCCEED
*
* HERE IF NO HISTORY STACK ENTRIES DURING PATTERN
*
PNTH1 ADD *NUM04,XS REMOVE P$EXB ENTRY AND NODE PTR
BRN SUCCP AND SUCCEED
*
* HERE IF END OF MATCH AT OUTER LEVEL
*
PNTH2 MOV WB,PMSSL SAVE FINAL CURSOR IN SAFE PLACE
BZE PMDFL,PNTH6 JUMP IF NO PATTERN ASSIGNMENTS
EJC
*
* END OF PATTERN MATCH (CONTINUED)
*
* NOW WE MUST PERFORM PATTERN ASSIGNMENTS. THIS IS DONE BY
* SCANNING THE HISTORY STACK FOR MATCHING NDPAB-NDPAD PAIRS
*
PNTH3 DCA XT POINT PAST CURSOR ENTRY
MOV -(XT),WA LOAD NODE POINTER
BEQ WA,=NDPAD,PNTH4 JUMP IF NDPAD ENTRY
BNE WA,=NDPAB,PNTH5 JUMP IF NOT NDPAB ENTRY
*
* HERE FOR NDPAB ENTRY, STACK INITIAL CURSOR
* NOTE THAT THERE MUST BE MORE ENTRIES ON THE STACK.
*
MOV 1(XT),-(XS) STACK INITIAL CURSOR
CHK CHECK FOR STACK OVERFLOW
BRN PNTH3 LOOP BACK IF OK
*
* HERE FOR NDPAD ENTRY. THE STARTING CURSOR FROM THE
* MATCHING NDPAD ENTRY IS NOW THE TOP STACK ENTRY.
*
PNTH4 MOV 1(XT),WA LOAD FINAL CURSOR
MOV (XS),WB LOAD INITIAL CURSOR FROM STACK
MOV XT,(XS) SAVE HISTORY STACK SCAN PTR
SUB WB,WA COMPUTE LENGTH OF STRING
*
* BUILD SUBSTRING AND PERFORM ASSIGNMENT
*
MOV R$PMS,XL POINT TO SUBJECT STRING
JSR SBSTR CONSTRUCT SUBSTRING
MOV XR,WB COPY SUBSTRING POINTER
MOV (XS),XT RELOAD HISTORY STACK SCAN PTR
MOV 2(XT),XL LOAD POINTER TO P$PAC NODE WITH NAM
MOV PARM2(XL),WA LOAD NAME OFFSET
MOV PARM1(XL),XL LOAD NAME BASE
JSR ASINP PERFORM ASSIGNMENT
PPM EXFAL MATCH FAILS IF NAME EVAL FAILS
MOV (XS)+,XT ELSE RESTORE HISTORY STACK PTR
EJC
*
* END OF PATTERN MATCH (CONTINUED)
*
* HERE CHECK FOR END OF ENTRIES
*
PNTH5 BNE XT,XS,PNTH3 LOOP IF MORE ENTRIES TO SCAN
*
* HERE AFTER DEALING WITH PATTERN ASSIGNMENTS
*
PNTH6 MOV PMHBS,XS WIPE OUT HISTORY STACK
MOV (XS)+,WB LOAD INITIAL CURSOR
MOV (XS)+,WC LOAD MATCH TYPE CODE
MOV PMSSL,WA LOAD FINAL CURSOR VALUE
MOV R$PMS,XL POINT TO SUBJECT STRING
ZER R$PMS CLEAR SUBJECT STRING PTR FOR GBCOL
BZE WC,PNTH7 JUMP IF CALL BY NAME
ZER R$PMB CLEAR POSSIBLE BCBLK PTR FOR GBCOL
BEQ WC,=NUM02,EXITS EXIT IF STATEMENT LEVEL CALL
*
* HERE WE HAVE A CALL BY VALUE, BUILD SUBSTRING
*
SUB WB,WA COMPUTE LENGTH OF STRING
JSR SBSTR BUILD SUBSTRING
BRN EXIXR AND EXIT WITH SUBSTRING VALUE
*
* HERE FOR CALL BY NAME, MAKE STACK ENTRIES FOR O$RPL
*
PNTH7 MOV WB,-(XS) STACK INITIAL CURSOR
MOV WA,-(XS) STACK FINAL CURSOR
.IF .CNBF
MOV XL,-(XS) STACK SUBJECT STRING POINTER
.ELSE
BZE R$PMB,PNTH8 SKIP IF SUBJECT NOT BUFFER
MOV R$PMB,XL ELSE GET PTR TO BCBLK INSTEAD
ZER R$PMB CLEAR BCBLK PTR FOR GBCOL
*
* HERE WITH XL POINTING TO SCBLK OR BCBLK
*
PNTH8 MOV XL,-(XS) STACK SUBJECT POINTER
.FI
BRN EXITS EXIT WITH SPECIAL ENTRY ON STACK
EJC
*
* POS (INTEGER ARGUMENT)
*
* PARM1 INTEGER ARGUMENT
*
P$POS ENT BL$P1 P1BLK
BEQ WB,PARM1(XR),SUCCP SUCCEED IF AT RIGHT LOCATION
BRN FAILP ELSE FAIL
*
* POS (EXPRESSION ARGUMENT)
*
* PARM1 EXPRESSION POINTER
*
P$PSD ENT BL$P1 P1BLK
JSR EVALI EVALUATE INTEGER ARGUMENT
ERR 057,POS EVALUATED ARGUMENT IS NOT INTEGER
ERR 058,POS EVALUATED ARGUMENT IS NEGATIVE OR TOO LARGE
PPM FAILP FAIL IF EVALUATION FAILS
BEQ WB,PARM1(XR),SUCCP SUCCEED IF AT RIGHT LOCATION
BRN FAILP ELSE FAIL
EJC
*
* PATTERN ASSIGNMENT (INITIAL ENTRY, SAVE CURSOR)
*
* SEE COMPOUND PATTERNS DESCRIPTION FOR THE STRUCTURE AND
* ALGORITHMS FOR MATCHING THIS NODE TYPE.
*
* NO PARAMETERS
*
P$PAA ENT BL$P0 P0BLK
MOV WB,-(XS) STACK INITIAL CURSOR
MOV =NDPAB,-(XS) STACK PTR TO NDPAB SPECIAL NODE
BRN SUCCP AND SUCCEED MATCHING NULL
*
* PATTERN ASSIGNMENT (REMOVE SAVED CURSOR)
*
* SEE COMPOUND PATTERNS DESCRIPTION FOR THE STRUCTURE AND
* ALGORITHMS FOR MATCHING THIS NODE TYPE.
*
* NO PARAMETERS (DUMMY PATTERN)
*
P$PAB ENT ENTRY POINT
BRN FAILP JUST FAIL (ENTRY IS ALREADY POPPED)
*
* PATTERN ASSIGNMENT (END OF MATCH, MAKE ASSIGN ENTRY)
*
* SEE COMPOUND PATTERNS DESCRIPTION FOR THE STRUCTURE AND
* ALGORITHMS FOR MATCHING THIS NODE TYPE.
*
* PARM1 NAME BASE OF VARIABLE
* PARM2 NAME OFFSET OF VARIABLE
*
P$PAC ENT BL$P2 P2BLK
MOV WB,-(XS) STACK DUMMY CURSOR VALUE
MOV XR,-(XS) STACK POINTER TO P$PAC NODE
MOV WB,-(XS) STACK FINAL CURSOR
MOV =NDPAD,-(XS) STACK PTR TO SPECIAL NDPAD NODE
MNZ PMDFL SET DOT FLAG NON-ZERO
BRN SUCCP AND SUCCEED
*
* PATTERN ASSIGNMENT (REMOVE ASSIGN ENTRY)
*
* SEE COMPOUND PATTERNS DESCRIPTION FOR THE STRUCTURE AND
* ALGORITHMS FOR MATCHING THIS NODE TYPE.
*
* NO PARAMETERS (DUMMY NODE)
*
P$PAD ENT ENTRY POINT
BRN FLPOP FAIL AND REMOVE P$PAC NODE
EJC
*
* REM
*
* NO PARAMETERS
*
P$REM ENT BL$P0 P0BLK
MOV PMSSL,WB POINT CURSOR TO END OF STRING
BRN SUCCP AND SUCCEED
*
* RPOS (EXPRESSION ARGUMENT)
*
* PARM1 EXPRESSION POINTER
*
P$RPD ENT BL$P1 P1BLK
JSR EVALI EVALUATE INTEGER ARGUMENT
ERR 059,RPOS EVALUATED ARGUMENT IS NOT INTEGER
ERR 060,RPOS EVALUATED ARGUMENT IS NEGATIVE OR TOO LARGE
PPM FAILP FAIL IF EVALUATION FAILS
MOV =P$RPS,XL CONTINUATION ROUTINE
BRI XL ENTER ROUTINE
*
* RPOS (INTEGER ARGUMENT)
* EXPRESSION ARGUMENT CASE MERGES
*
* PARM1 INTEGER ARGUMENT
*
P$RPS ENT BL$P1 P1BLK
MOV PMSSL,WC GET LENGTH OF STRING
SUB WB,WC GET NUMBER OF CHARACTERS REMAINING
BEQ WC,PARM1(XR),SUCCP SUCCEED IF AT RIGHT LOCATION
BRN FAILP ELSE FAIL
EJC
*
* RTAB (INTEGER ARGUMENT)
* EXPRESSION ARGUMENT CASE MERGES
*
* PARM1 INTEGER ARGUMENT
*
P$RTB ENT BL$P1 P1BLK
MOV WB,WC SAVE INITIAL CURSOR
MOV PMSSL,WB POINT TO END OF STRING
BLT WB,PARM1(XR),FAILP FAIL IF STRING NOT LONG ENOUGH
SUB PARM1(XR),WB ELSE SET NEW CURSOR
BGE WB,WC,SUCCP AND SUCCEED IF NOT TOO FAR ALREADY
BRN FAILP IN WHICH CASE, FAIL
*
* RTAB (EXPRESSION ARGUMENT)
*
* PARM1 EXPRESSION POINTER
*
P$RTD ENT BL$P1 P1BLK
JSR EVALI EVALUATE INTEGER ARGUMENT
ERR 061,RTAB EVALUATED ARGUMENT IS NOT INTEGER
ERR 062,RTAB EVALUATED ARGUMENT IS NEGATIVE OR TOO LARGE
PPM FAILP FAIL IF EVALUATION FAILS
MOV =P$RTB,XL CONTINUATION ROUTINE
BRI XL ENTER ROUTINE
EJC
*
* SPAN (EXPRESSION ARGUMENT)
*
* PARM1 EXPRESSION POINTER
*
P$SPD ENT BL$P1 P1BLK
MOV =P$SPN,WA PCODE FOR NEW NODE
JSR EVALS EVALUATE STRING ARGUMENT
ERR 063,SPAN EVALUATED ARGUMENT IS NOT STRING
PPM FAILP FAIL IF EVALUATION FAILS
BRI XL MERGE WITH MULTI-CHAR CASE IF OK
*
* SPAN (MULTI-CHARACTER ARGUMENT CASE)
* EXPRESSION ARGUMENT CASE MERGES
*
* PARM1 POINTER TO CTBLK
* PARM2 BIT MASK TO SELECT BIT COLUMN
*
P$SPN ENT BL$P2 P2BLK
MOV PMSSL,WC COPY SUBJECT STRING LENGTH
SUB WB,WC CALCULATE NUMBER OF CHARACTERS LEFT
BZE WC,FAILP FAIL IF NO CHARACTERS LEFT
MOV R$PMS,XL POINT TO SUBJECT STRING
PLC XL,WB POINT TO CURRENT CHARACTER
MOV WB,PSAVC SAVE INITIAL CURSOR
MOV XR,PSAVE SAVE NODE POINTER
LCT WC,WC SET COUNTER FOR CHARS LEFT
*
* LOOP TO SCAN MATCHING CHARACTERS
*
PSPN2 LCH WA,(XL)+ LOAD NEXT CHARACTER, BUMP POINTER
WTB WA CONVERT TO BAU OFFSET
MOV PARM1(XR),XR POINT TO CTBLK
ADD WA,XR POINT TO CTBLK ENTRY
MOV CTCHS(XR),WA LOAD CTBLK ENTRY
MOV PSAVE,XR RESTORE NODE POINTER
ANB PARM2(XR),WA AND WITH SELECTED BIT
ZRB WA,PSPN3 JUMP IF NO MATCH
ICV WB ELSE PUSH CURSOR
BCT WC,PSPN2 LOOP BACK UNLESS END OF STRING
*
* HERE AFTER SCANNING MATCHING CHARACTERS
*
PSPN3 BNE WB,PSAVC,SUCCP SUCCEED IF CHARS MATCHED
BRN FAILP ELSE FAIL IF NULL STRING MATCHED
EJC
*
* SPAN (ONE CHARACTER ARGUMENT)
*
* PARM1 CHARACTER ARGUMENT
*
P$SPS ENT BL$P1 P1BLK
MOV PMSSL,WC GET SUBJECT STRING LENGTH
SUB WB,WC CALCULATE NUMBER OF CHARACTERS LEFT
BZE WC,FAILP FAIL IF NO CHARACTERS LEFT
MOV R$PMS,XL ELSE POINT TO SUBJECT STRING
PLC XL,WB POINT TO CURRENT CHARACTER
MOV WB,PSAVC SAVE INITIAL CURSOR
LCT WC,WC SET COUNTER FOR CHARACTERS LEFT
*
* LOOP TO SCAN MATCHING CHARACTERS
*
PSPS1 LCH WA,(XL)+ LOAD NEXT CHARACTER, BUMP POINTER
BNE WA,PARM1(XR),PSPS2 JUMP IF NO MATCH
ICV WB ELSE PUSH CURSOR
BCT WC,PSPS1 AND LOOP UNLESS END OF STRING
*
* HERE AFTER SCANNING MATCHING CHARACTERS
*
PSPS2 BNE WB,PSAVC,SUCCP SUCCEED IF CHARS MATCHED
BRN FAILP FAIL IF NULL STRING MATCHED
*
* MULTI-CHARACTER STRING (MERGE FROM P$EXA)
*
* NOTE THAT ONE CHARACTER STRINGS USE THE CIRCUIT FOR
* ONE CHARACTER ANY ARGUMENTS (P$AN1).
*
* PARM1 POINTER TO SCBLK FOR STRING ARG
*
P$STR ENT BL$P1 P1BLK
MOV PARM1(XR),XL GET POINTER TO STRING
MOV XR,PSAVE SAVE NODE POINTER
MOV R$PMS,XR LOAD SUBJECT STRING POINTER
PLC XR,WB POINT TO CURRENT CHARACTER
ADD SCLEN(XL),WB COMPUTE NEW CURSOR POSITION
BGT WB,PMSSL,FAILP FAIL IF PAST END OF STRING
MOV WB,PSAVC SAVE UPDATED CURSOR
MOV SCLEN(XL),WA GET NUMBER OF CHARS TO COMPARE
PLC XL POINT TO CHARS OF TEST STRING
CMC FAILP,FAILP COMPARE, FAIL IF NOT EQUAL
MOV PSAVE,XR IF ALL MATCHED, RESTORE NODE PTR
MOV PSAVC,WB RESTORE UPDATED CURSOR
BRN SUCCP AND SUCCEED
EJC
*
* SUCCEED
*
* SEE SECTION ON COMPOUND PATTERNS FOR DETAILS OF THE
* STRUCTURE AND ALGORITHMS FOR MATCHING THIS NODE TYPE
*
* NO PARAMETERS
*
P$SUC ENT BL$P0 P0BLK
MOV WB,-(XS) STACK CURSOR
MOV XR,-(XS) STACK POINTER TO THIS NODE
BRN SUCCP SUCCEED MATCHING NULL
EJC
*
* TAB (INTEGER ARGUMENT)
* EXPRESSION CASE MERGES
*
* PARM1 INTEGER ARGUMENT
*
P$TAB ENT BL$P1 P1BLK
BGT WB,PARM1(XR),FAILP FAIL IF TOO FAR ALREADY
MOV PARM1(XR),WB ELSE SET NEW CURSOR POSITION
BLE WB,PMSSL,SUCCP SUCCEED IF NOT OFF END
BRN FAILP ELSE FAIL
*
* TAB (EXPRESSION ARGUMENT)
*
* PARM1 EXPRESSION POINTER
*
P$TBD ENT BL$P1 P1BLK
JSR EVALI EVALUATE INTEGER ARGUMENT
ERR 064,TAB EVALUATED ARGUMENT IS NOT INTEGER
ERR 065,TAB EVALUATED ARGUMENT IS NEGATIVE OR TOO LARGE
PPM FAILP FAIL IF EVALUATION FAILS
MOV =P$TAB,XL CONTINUATION ROUTINE
BRI XL ENTER ROUTINE
*
* ANCHOR MOVEMENT
*
* NO PARAMETERS (DUMMY NODE)
*
P$UNA ENT ENTRY POINT
MOV WB,XR COPY INITIAL PATTERN NODE POINTER
MOV (XS),WB GET INITIAL CURSOR
BEQ WB,PMSSL,EXFAL MATCH FAILS IF AT END OF STRING
ICV WB ELSE INCREMENT CURSOR
MOV WB,(XS) STORE INCREMENTED CURSOR
MOV XR,-(XS) RESTACK INITIAL NODE PTR
MOV =NDUNA,-(XS) RESTACK UNANCHORED NODE
BRI (XR) REMATCH FIRST NODE
*
* END OF PATTERN MATCH ROUTINES
*
* THE FOLLOWING ENTRY POINT MARKS THE END OF THE PATTERN
* MATCHING ROUTINES AND ALSO THE END OF THE ENTRY POINTS
* REFERENCED FROM THE FIRST WORD OF BLOCKS IN DYNAMIC STORE
*
P$YYY ENT BL$$I MARK LAST ENTRY IN PATTERN SECTION
TTL S P I T B O L -- PREDEFINED SNOBOL4 FUNCTIONS
*
* THE FOLLOWING SECTION CONTAINS CODING FOR FUNCTIONS
* WHICH ARE PREDEFINED AND AVAILABLE AT THE SNOBOL LEVEL.
*
* THESE ROUTINES RECEIVE CONTROL DIRECTLY FROM THE CODE OR
* INDIRECTLY THROUGH THE O$FNC, O$FNS OR CFUNC ROUTINES.
* IN BOTH CASES THE CONDITIONS ON ENTRY ARE AS FOLLOWS
*
* THE ARGUMENTS ARE ON THE STACK. THE NUMBER OF ARGUMENTS
* HAS BEEN ADJUSTED TO CORRESPOND TO THE SVBLK SVNAR FIELD.
*
* IN CERTAIN FUNCTIONS THE DIRECT CALL IS NOT PERMITTED
* AND IN THESE INSTANCES WE ALSO HAVE.
*
* (WA) ACTUAL NUMBER OF ARGUMENTS IN CALL
*
* CONTROL RETURNS BY PLACING THE FUNCTION RESULT VALUE ON
* ON THE STACK AND CONTINUING EXECUTION WITH THE NEXT
* WORD FROM THE GENERATED CODE.
*
* THE NAMES OF THE ENTRY POINTS OF THESE FUNCTIONS ARE OF
* THE FORM S$XXX WHERE XXX IS THE THREE LETTER CODE FOR
* THE SYSTEM VARIABLE NAME. THE FUNCTIONS ARE IN ORDER
* ALPHABETICALLY BY THEIR ENTRY NAMES.
EJC
*
* ANY
*
S$ANY ENT ENTRY POINT
MOV =P$ANS,WB SET PCODE FOR SINGLE CHAR CASE
MOV =P$ANY,XL PCODE FOR MULTI-CHAR CASE
MOV =P$AYD,WC PCODE FOR EXPRESSION CASE
JSR PATST CALL COMMON ROUTINE TO BUILD NODE
ERR 066,ANY ARGUMENT IS NOT STRING OR EXPRESSION
BRN EXIXR JUMP FOR NEXT CODE WORD
.IF .CNBF
.ELSE
EJC
*
* APPEND
*
S$APN ENT ENTRY POINT
MOV (XS)+,XL GET APPEND ARGUMENT
MOV (XS)+,XR GET BCBLK
BEQ (XR),=B$BCT,SAPN1 OK IF FIRST ARG IS BCBLK
ERB 067,APPEND FIRST ARGUMENT IS NOT BUFFER
*
* HERE TO DO THE APPEND
*
SAPN1 MOV BCLEN(XR),WA OFFSET TO BUFFER END
ZER WB NO CHARS TO BE REPLACED
JSR INSBF DO THE APPEND
ERR 068,APPEND SECOND ARGUMENT IS NOT STRING
PPM EXFAL NO ROOM - FAIL
BRN EXNUL EXIT WITH NULL RESULT
.FI
EJC
*
* APPLY
*
* APPLY DOES NOT PERMIT THE DIRECT (FAST) CALL SO THAT
* WA CONTAINS THE ACTUAL NUMBER OF ARGUMENTS PASSED.
*
S$APP ENT ENTRY POINT
BZE WA,SAPP3 JUMP IF NO ARGUMENTS
DCV WA ELSE GET APPLIED FUNC ARG COUNT
MOV WA,WB COPY
WTB WB CONVERT TO BAUS
MOV XS,XT COPY STACK POINTER
ADD WB,XT POINT TO FUNCTION ARGUMENT ON STACK
MOV (XT),XR LOAD FUNCTION PTR (APPLY 1ST ARG)
BZE WA,SAPP2 JUMP IF NO ARGS FOR APPLIED FUNC
LCT WB,WA ELSE SET COUNTER FOR LOOP
*
* LOOP TO MOVE ARGUMENTS UP ON STACK
*
SAPP1 DCA XT POINT TO NEXT ARGUMENT
MOV (XT),1(XT) MOVE ARGUMENT UP
BCT WB,SAPP1 LOOP TILL ALL MOVED
*
* MERGE HERE TO CALL FUNCTION (WA = NUMBER OF ARGUMENTS)
*
SAPP2 ICA XS ADJUST STACK PTR FOR APPLY 1ST ARG
JSR GTNVR GET VARIABLE BLOCK ADDR FOR FUNC
PPM SAPP3 JUMP IF NOT NATURAL VARIABLE
MOV VRFNC(XR),XL ELSE POINT TO FUNCTION BLOCK
BRN CFUNC GO CALL APPLIED FUNCTION
*
* HERE FOR INVALID FIRST ARGUMENT
*
SAPP3 ERB 069,APPLY FIRST ARG IS NOT NATURAL VARIABLE NAME
EJC
*
* ARBNO
*
* ARBNO BUILDS A COMPOUND PATTERN. SEE DESCRIPTION AT
* START OF PATTERN MATCHING SECTION FOR STRUCTURE FORMED.
*
S$ABN ENT ENTRY POINT
ZER XR SET PARM1 = 0 FOR THE MOMENT
MOV =P$ALT,WB SET PCODE FOR ALTERNATIVE NODE
JSR PBILD BUILD ALTERNATIVE NODE
MOV XR,XL SAVE PTR TO ALTERNATIVE PATTERN
MOV =P$ABC,WB PCODE FOR P$ABC
ZER XR P0BLK
JSR PBILD BUILD P$ABC NODE
MOV XL,PTHEN(XR) PUT ALTERNATIVE NODE AS SUCCESSOR
MOV XL,WA REMEMBER ALTERNATIVE NODE POINTER
MOV XR,XL COPY P$ABC NODE PTR
MOV (XS),XR LOAD ARBNO ARGUMENT
MOV WA,(XS) STACK ALTERNATIVE NODE POINTER
JSR GTPAT GET ARBNO ARGUMENT AS PATTERN
ERR 070,ARBNO ARGUMENT IS NOT PATTERN
JSR PCONC CONCAT ARG WITH P$ABC NODE
MOV XR,XL REMEMBER PTR TO CONCD PATTERNS
MOV =P$ABA,WB PCODE FOR P$ABA
ZER XR P0BLK
JSR PBILD BUILD P$ABA NODE
MOV XL,PTHEN(XR) CONCATENATE NODES
MOV (XS),XL RECALL PTR TO ALTERNATIVE NODE
MOV XR,PARM1(XL) POINT ALTERNATIVE BACK TO ARGUMENT
BRN EXITS JUMP FOR NEXT CODE WORD
EJC
*
* ARG
*
S$ARG ENT ENTRY POINT
JSR GTSMI GET SECOND ARG AS SMALL INTEGER
ERR 253,ARG SECOND ARGUMENT IS NOT INTEGER
PPM EXFAL FAIL IF OUT OF RANGE OR NEGATIVE
MOV XR,WA SAVE ARGUMENT NUMBER
MOV (XS)+,XR LOAD FIRST ARGUMENT
JSR GTNVR LOCATE VRBLK
PPM SARG1 JUMP IF NOT NATURAL VARIABLE
MOV VRFNC(XR),XR ELSE LOAD FUNCTION BLOCK POINTER
BNE (XR),=B$PFC,SARG1 JUMP IF NOT PROGRAM DEFINED
BZE WA,EXFAL FAIL IF ARG NUMBER IS ZERO
BGT WA,FARGS(XR),EXFAL FAIL IF ARG NUMBER IS TOO LARGE
WTB WA ELSE CONVERT TO BYTE OFFSET
ADD WA,XR POINT TO ARGUMENT SELECTED
MOV PFAGB(XR),XR LOAD ARGUMENT VRBLK POINTER
BRN EXVNM EXIT TO BUILD NMBLK
*
* HERE IF 1ST ARGUMENT IS BAD
*
SARG1 ERB 252,ARG FIRST ARGUMENT IS NOT PROGRAM FUNCTION NAME
EJC
*
* ARRAY
*
S$ARR ENT ENTRY POINT
MOV (XS)+,XL LOAD INITIAL ELEMENT VALUE
MOV (XS)+,XR LOAD FIRST ARGUMENT
JSR GTINT CONVERT FIRST ARG TO INTEGER
PPM SAR02 JUMP IF NOT INTEGER
*
* HERE FOR INTEGER FIRST ARGUMENT, BUILD VCBLK
*
LDI ICVAL(XR) LOAD INTEGER VALUE
ILE SAR10 JUMP IF ZERO OR NEG (BAD DIMENSION)
MFI WA,SAR11 ELSE CONVERT TO ONE WORD, TEST OVFL
LCT WB,WA COPY ELEMENTS FOR LOOP LATER ON
ADD =VCSI$,WA ADD SPACE FOR STANDARD FIELDS
WTB WA CONVERT LENGTH TO BAUS
BGE WA,MXLEN,SAR11 FAIL IF TOO LARGE
JSR ALLOC ALLOCATE SPACE FOR VCBLK
MOV =B$VCT,(XR) STORE TYPE WORD
MOV WA,VCLEN(XR) SET LENGTH
MOV XL,WC COPY DEFAULT VALUE
MOV XR,XL COPY VCBLK POINTER
ADD *VCVLS,XL POINT TO FIRST ELEMENT VALUE
*
* LOOP TO SET VECTOR ELEMENTS TO DEFAULT VALUE
*
SAR01 MOV WC,(XL)+ STORE ONE VALUE
BCT WB,SAR01 LOOP TILL ALL STORED
BRN EXSID EXIT SETTING IDVAL
EJC
*
* ARRAY (CONTINUED)
*
* HERE IF FIRST ARGUMENT IS NOT AN INTEGER
*
SAR02 MOV XR,-(XS) REPLACE ARGUMENT ON STACK
JSR XSCNI INITIALIZE SCAN OF FIRST ARGUMENT
ERR 071,ARRAY FIRST ARGUMENT IS NOT INTEGER OR STRING
PPM EXNUL DUMMY (UNUSED) NULL STRING EXIT
MOV R$XSC,-(XS) SAVE PROTOTYPE POINTER
MOV XL,-(XS) SAVE DEFAULT VALUE
ZER ARCDM ZERO COUNT OF DIMENSIONS
ZER ARPTR ZERO OFFSET TO INDICATE PASS ONE
LDI INTV1 LOAD INTEGER ONE
STI ARNEL INITIALIZE ELEMENT COUNT
*
* THE FOLLOWING CODE IS EXECUTED TWICE. THE FIRST TIME
* (ARPTR EQ 0), IT IS USED TO COUNT THE NUMBER OF ELEMENTS
* AND NUMBER OF DIMENSIONS. THE SECOND TIME (ARPTR GT 0) IS
* USED TO ACTUALLY FILL IN THE DIM,LBD FIELDS OF THE ARBLK.
*
SAR03 LDI INTV1 LOAD ONE AS DEFAULT LOW BOUND
STI ARSVL SAVE AS LOW BOUND
MOV =CH$CL,WC SET DELIMITER ONE = COLON
MOV =CH$CM,XL SET DELIMITER TWO = COMMA
JSR XSCAN SCAN NEXT BOUND
BNE WA,=NUM01,SAR04 JUMP IF NOT COLON
*
* HERE WE HAVE A COLON ENDING A LOW BOUND
*
JSR GTINT CONVERT LOW BOUND
ERR 072,ARRAY FIRST ARGUMENT LOWER BOUND IS NOT INTEGER
LDI ICVAL(XR) LOAD VALUE OF LOW BOUND
STI ARSVL STORE LOW BOUND VALUE
MOV =CH$CM,WC SET DELIMITER ONE = COMMA
MOV WC,XL AND DELIMITER TWO = COMMA
JSR XSCAN SCAN HIGH BOUND
EJC
*
* ARRAY (CONTINUED)
*
* MERGE HERE TO PROCESS UPPER BOUND
*
SAR04 BNZ WA,SAR4A SKIP IF DELIMITER 1 OR 2
BNZ XSCNB,SAR10 JUMP IF ILLEGALLY PLACED BLANK
*
* CHECK FOR INTEGER BOUND
*
SAR4A JSR GTINT CONVERT HIGH BOUND TO INTEGER
ERR 073,ARRAY FIRST ARGUMENT UPPER BOUND IS NOT INTEGER
LDI ICVAL(XR) GET HIGH BOUND
SBI ARSVL SUBTRACT LOWER BOUND
IOV SAR10 BAD DIMENSION IF OVERFLOW
ILT SAR10 BAD DIMENSION IF NEGATIVE
ADI INTV1 ADD 1 TO GET DIMENSION
IOV SAR10 BAD DIMENSION IF OVERFLOW
MOV ARPTR,XL LOAD OFFSET (ALSO PASS INDICATOR)
BZE XL,SAR05 JUMP IF FIRST PASS
*
* HERE IN SECOND PASS TO STORE LBD AND DIM IN ARBLK
*
ADD (XS),XL POINT TO CURRENT LOCATION IN ARBLK
STI CFP$I(XL) STORE DIMENSION
LDI ARSVL LOAD LOW BOUND
STI (XL) STORE LOW BOUND
ADD *ARDMS,ARPTR BUMP OFFSET TO NEXT BOUNDS
BRN SAR06 JUMP TO CHECK FOR END OF BOUNDS
*
* HERE IN PASS 1
*
SAR05 ICV ARCDM BUMP DIMENSION COUNT
MLI ARNEL MULTIPLY DIMENSION BY COUNT SO FAR
IOV SAR11 TOO LARGE IF OVERFLOW
STI ARNEL ELSE STORE UPDATED ELEMENT COUNT
*
* MERGE HERE AFTER PROCESSING ONE SET OF BOUNDS
*
SAR06 BNZ WA,SAR03 LOOP BACK UNLESS END OF BOUNDS
BNZ ARPTR,SAR09 JUMP IF END OF PASS 2
EJC
*
* ARRAY (CONTINUED)
*
* HERE AT END OF PASS ONE, BUILD ARBLK
*
LDI ARNEL GET NUMBER OF ELEMENTS
MFI WB,SAR11 GET AS ADDR INTEGER, TEST OVFLO
WTB WB ELSE CONVERT TO LENGTH IN BAUS
MOV *ARSI$,WA SET SIZE OF STANDARD FIELDS
LCT WC,ARCDM SET DIMENSION COUNT TO CONTROL LOOP
*
* LOOP TO ALLOW SPACE FOR DIMENSIONS
*
SAR07 ADD *ARDMS,WA ALLOW SPACE FOR ONE SET OF BOUNDS
BCT WC,SAR07 LOOP BACK TILL ALL ACCOUNTED FOR
MOV WA,XL SAVE SIZE (=AROFS)
*
* NOW ALLOCATE SPACE FOR ARBLK
*
ADD WB,WA ADD SPACE FOR ELEMENTS
ICA WA ALLOW FOR ARPRO PROTOTYPE FIELD
BGE WA,MXLEN,SAR11 FAIL IF TOO LARGE
JSR ALLOC ELSE ALLOCATE ARBLK
MOV (XS),WB LOAD DEFAULT VALUE
MOV XR,(XS) SAVE ARBLK POINTER
MOV WA,WC SAVE LENGTH IN BAUS
BTW WA CONVERT LENGTH BACK TO WORDS
LCT WA,WA SET COUNTER TO CONTROL LOOP
*
* LOOP TO CLEAR ENTIRE ARBLK TO DEFAULT VALUE
*
SAR08 MOV WB,(XR)+ SET ONE WORD
BCT WA,SAR08 LOOP TILL ALL SET
EJC
*
* ARRAY (CONTINUED)
*
* NOW SET INITIAL FIELDS OF ARBLK
*
MOV (XS)+,XR RELOAD ARBLK POINTER
MOV (XS),WB LOAD PROTOTYPE
MOV =B$ART,(XR) SET TYPE WORD
MOV WC,ARLEN(XR) STORE LENGTH IN BAUS
ZER IDVAL(XR) ZERO ID TILL WE GET IT BUILT
MOV XL,AROFS(XR) SET PROTOTYPE FIELD PTR
MOV ARCDM,ARNDM(XR) SET NUMBER OF DIMENSIONS
MOV XR,WC SAVE ARBLK POINTER
ADD XL,XR POINT TO PROTOTYPE FIELD
MOV WB,(XR) STORE PROTOTYPE PTR IN ARBLK
MOV *ARLBD,ARPTR SET OFFSET FOR PASS 2 BOUNDS SCAN
MOV WB,R$XSC RESET STRING POINTER FOR XSCAN
MOV WC,(XS) STORE ARBLK POINTER ON STACK
ZER XSOFS RESET OFFSET PTR TO START OF STRING
BRN SAR03 JUMP BACK TO RESCAN BOUNDS
*
* HERE AFTER FILLING IN BOUNDS INFORMATION (END PASS TWO)
*
SAR09 MOV (XS)+,XR RELOAD POINTER TO ARBLK
BRN EXSID EXIT SETTING IDVAL
*
* HERE FOR BAD DIMENSION
*
SAR10 ERB 074,BAD DIMENSION, ZERO, NEGATIVE OR OUT OF RANGE
*
* HERE IF ARRAY IS TOO LARGE
*
SAR11 ERB 075,ARRAY SIZE EXCEEDS MAXIMUM PERMITTED
EJC
*
* BREAK
*
S$BRK ENT ENTRY POINT
MOV =P$BKS,WB SET PCODE FOR SINGLE CHAR CASE
MOV =P$BRK,XL PCODE FOR MULTI-CHAR CASE
MOV =P$BKD,WC PCODE FOR EXPRESSION CASE
JSR PATST CALL COMMON ROUTINE TO BUILD NODE
ERR 076,BREAK ARGUMENT IS NOT STRING OR EXPRESSION
BRN EXIXR JUMP FOR NEXT CODE WORD
EJC
*
* BREAKX
*
* BREAKX IS A COMPOUND PATTERN. SEE DESCRIPTION AT START
* OF PATTERN MATCHING SECTION FOR STRUCTURE FORMED.
*
S$BKX ENT ENTRY POINT
MOV =P$BKS,WB PCODE FOR SINGLE CHAR ARGUMENT
MOV =P$BRK,XL PCODE FOR MULTI-CHAR ARGUMENT
MOV =P$BXD,WC PCODE FOR EXPRESSION CASE
JSR PATST CALL COMMON ROUTINE TO BUILD NODE
ERR 077,BREAKX ARGUMENT IS NOT STRING OR EXPRESSION
*
* NOW HOOK BREAKX NODE ON AT FRONT END
*
MOV XR,-(XS) SAVE PTR TO BREAK NODE
MOV =P$BKX,WB SET PCODE FOR BREAKX NODE
JSR PBILD BUILD IT
MOV (XS),PTHEN(XR) SET BREAK NODE AS SUCCESSOR
MOV =P$ALT,WB SET PCODE FOR ALTERNATION NODE
JSR PBILD BUILD (PARM1=ALT=BREAKX NODE)
MOV XR,WA SAVE PTR TO ALTERNATION NODE
MOV (XS),XR POINT TO BREAK NODE
MOV WA,PTHEN(XR) SET ALTERNATE NODE AS SUCCESSOR
BRN EXITS EXIT WITH RESULT ON STACK
.IF .CNBF
.ELSE
EJC
*
* BUFFER
*
S$BUF ENT ENTRY POINT
MOV (XS)+,XL GET INITIAL STRING
JSR GTSMI CONVERT MEMORY REQUEST TO INTEGER
ERR 078,BUFFER FIRST ARGUMENT IS NOT INTEGER
PPM SBF01 FAIL IF OUT OF RANGE
MOV WC,WA MOVE LENGTH TO CORRECT REGISTER
JSR ALOBF ALLOCATE THE BUFFER
JSR INSBF COPY INITIAL ARG IN
ERR 079,BUFFER SECOND ARGUMENT IS NOT STRING OR BUFFER
ERR 080,BUFFER INITIAL VALUE TOO BIG FOR ALLOCATION
BRN EXSID EXIT SETTING IDVAL
*
* HERE FOR INVALID ALLOCATION SIZE
*
SBF01 ERB 081,BUFFER FIRST ARGUMENT IS OUT OF RANGE
.FI
EJC
*
* CLEAR
*
S$CLR ENT ENTRY POINT
JSR XSCNI INITIALIZE TO SCAN ARGUMENT
ERR 082,CLEAR ARGUMENT IS NOT STRING
PPM SCLR2 JUMP IF NULL
*
* LOOP TO SCAN OUT NAMES IN FIRST ARGUMENT. VARIABLES IN
* THE LIST ARE FLAGGED BY SETTING VRGET OF VRBLK TO ZERO.
*
SCLR1 MOV =CH$CM,WC SET DELIMITER ONE = COMMA
MOV WC,XL DELIMITER TWO = COMMA
JSR XSCAN SCAN NEXT VARIABLE NAME
JSR GTNVR LOCATE VRBLK
PPM SCLR7 ERRONEOUS NAME
ZER VRGET(XR) ELSE FLAG BY ZEROING VRGET FIELD
BNZ WA,SCLR1 LOOP BACK IF STOPPED BY COMMA
BNZ XSCNB,SCLR7 BADLY PLACED BLANK
*
* HERE AFTER FLAGGING VARIABLES IN ARGUMENT LIST
*
SCLR2 MOV HSHTB,WB POINT TO START OF HASH TABLE
*
* LOOP THROUGH SLOTS IN HASH TABLE
*
SCLR3 BEQ WB,HSHTE,EXNUL EXIT RETURNING NULL IF NONE LEFT
MOV WB,XR ELSE COPY SLOT POINTER
ICA WB BUMP SLOT POINTER
SUB *VRNXT,XR SET OFFSET TO MERGE INTO LOOP
*
* LOOP THROUGH VRBLKS ON ONE HASH CHAIN
*
SCLR4 MOV VRNXT(XR),XR POINT TO NEXT VRBLK ON CHAIN
BZE XR,SCLR3 JUMP FOR NEXT BUCKET IF CHAIN END
BNZ VRGET(XR),SCLR5 JUMP IF NOT FLAGGED
EJC
*
* CLEAR (CONTINUED)
*
* HERE FOR FLAGGED VARIABLE, DO NOT SET VALUE TO NULL
*
JSR SETVR FOR FLAGGED VAR, RESTORE VRGET
BRN SCLR4 AND LOOP BACK FOR NEXT VRBLK
*
* HERE TO SET VALUE OF A VARIABLE TO NULL
* PROTECTED VARIABLES (ARB ETC) ARE EXEMPT
*
SCLR5 BEQ VRSTO(XR),=B$VRE,SCLR4 CHECK FOR PROTECTED VARIABLE
MOV XR,XL COPY VRBLK POINTER
*
* LOOP TO LOCATE VALUE AT END OF POSSIBLE TRBLK CHAIN
*
SCLR6 MOV XL,WA SAVE BLOCK POINTER
MOV VRVAL(XL),XL LOAD NEXT VALUE FIELD
BEQ (XL),=B$TRT,SCLR6 LOOP BACK IF TRAPPED
*
* NOW STORE THE NULL VALUE
*
MOV WA,XL RESTORE BLOCK POINTER
MOV =NULLS,VRVAL(XL) STORE NULL CONSTANT VALUE
BRN SCLR4 LOOP BACK FOR NEXT VRBLK
*
* ERROR POINT
*
SCLR7 ERB 083,NULL VARIABLE NAME OR ILLEGAL BLANK IN CLEAR ARG
EJC
*
* CODE
*
S$COD ENT ENTRY POINT
MOV (XS)+,XR LOAD ARGUMENT
JSR GTCOD CONVERT TO CODE
PPM EXFAL FAIL IF CONVERSION IS IMPOSSIBLE
BRN EXIXR ELSE RETURN CODE AS RESULT
EJC
*
* COLLECT
*
S$COL ENT ENTRY POINT
MOV (XS)+,XR LOAD ARGUMENT
JSR GTINT CONVERT TO INTEGER
ERR 084,COLLECT ARGUMENT IS NOT INTEGER
LDI ICVAL(XR) LOAD COLLECT ARGUMENT
STI CLSVI SAVE COLLECT ARGUMENT
ZER WB SET NO MOVE UP
JSR GBCOL PERFORM GARBAGE COLLECTION
MOV DNAME,WA POINT TO END OF MEMORY
SUB DNAMP,WA SUBTRACT NEXT LOCATION
BTW WA CONVERT BAUS TO WORDS
MTI WA CONVERT WORDS AVAILABLE AS INTEGER
SBI CLSVI SUBTRACT ARGUMENT
IOV EXFAL FAIL IF OVERFLOW
ILT EXFAL FAIL IF NOT ENOUGH
ADI CLSVI ELSE RECOMPUTE AVAILABLE
BRN EXINT AND EXIT WITH INTEGER RESULT
EJC
*
* CONVERT
*
S$CVT ENT ENTRY POINT
JSR GTSTG CONVERT SECOND ARGUMENT TO STRING
ERR 085,CONVERT SECOND ARGUMENT IS NOT STRING
.IF .CASL
MOV XR,XL COPY STRING PTR TO XL
ZER WB ZERO OFFSET
JSR SBSTG CONVERT CASE OF ARG IF NECESSARY
.FI
MOV (XS),XL LOAD FIRST ARGUMENT
BNE (XL),=B$PDT,SCV01 JUMP IF NOT PROGRAM DEFINED
*
* HERE FOR PROGRAM DEFINED DATATYPE
*
MOV PDDFP(XL),XL POINT TO DFBLK
MOV DFNAM(XL),XL LOAD DATATYPE NAME
JSR IDENT COMPARE WITH SECOND ARG
PPM EXITS EXIT IF IDENT WITH ARG AS RESULT
BRN EXFAL ELSE FAIL
*
* HERE IF NOT PROGRAM DEFINED DATATYPE
*
SCV01 MOV XR,-(XS) SAVE STRING ARGUMENT
MOV =SVCTB,XL POINT TO TABLE OF NAMES TO COMPARE
ZER WB INITIALIZE COUNTER
MOV SCLEN(XR),WC SAVE LENGTH OF ARGUMENT STRING
*
* LOOP THROUGH TABLE ENTRIES
*
SCV02 MOV (XL)+,XR LOAD NEXT TABLE ENTRY, BUMP POINTER
BZE XR,EXFAL FAIL IF ZERO MARKING END OF LIST
BNE WC,SCLEN(XR),SCV05 JUMP IF WRONG LENGTH
MOV XL,CNVTP ELSE STORE TABLE POINTER
PLC XR POINT TO CHARS OF TABLE ENTRY
MOV (XS),XL LOAD POINTER TO STRING ARGUMENT
PLC XL POINT TO CHARS OF STRING ARG
MOV WC,WA SET NUMBER OF CHARS TO COMPARE
CMC SCV04,SCV04 COMPARE, JUMP IF NO MATCH
EJC
*
* CONVERT (CONTINUED)
*
* HERE WE HAVE A MATCH
*
SCV03 MOV WB,XL COPY ENTRY NUMBER
ICA XS POP STRING ARG OFF STACK
MOV (XS)+,XR LOAD FIRST ARGUMENT
BSW XL,CNVTT JUMP TO APPROPRIATE ROUTINE
IFF 0,SCV06 STRING
IFF 1,SCV07 INTEGER
IFF 2,SCV09 NAME
IFF 3,SCV10 PATTERN
IFF 4,SCV11 ARRAY
IFF 5,SCV19 TABLE
IFF 6,SCV25 EXPRESSION
IFF 7,SCV26 CODE
IFF 8,SCV27 NUMERIC
.IF .CNRA
.ELSE
IFF 9,SCV08 REAL
.FI
.IF .CNBF
.ELSE
IFF CNVBT,SCV28 BUFFER
.FI
ESW END OF SWITCH TABLE
*
* HERE IF NO MATCH WITH TABLE ENTRY
*
SCV04 MOV CNVTP,XL RESTORE TABLE POINTER, MERGE
*
* MERGE HERE IF LENGTHS DID NOT MATCH
*
SCV05 ICV WB BUMP ENTRY NUMBER
BRN SCV02 LOOP BACK TO CHECK NEXT ENTRY
*
* HERE TO CONVERT TO STRING
*
SCV06 MOV XR,-(XS) REPLACE STRING ARGUMENT ON STACK
JSR GTSTG CONVERT TO STRING
PPM EXFAL FAIL IF CONVERSION NOT POSSIBLE
BRN EXIXR ELSE RETURN STRING
EJC
*
* CONVERT (CONTINUED)
*
* HERE TO CONVERT TO INTEGER
*
SCV07 JSR GTINT CONVERT TO INTEGER
PPM EXFAL FAIL IF CONVERSION NOT POSSIBLE
BRN EXIXR ELSE RETURN INTEGER
.IF .CNRA
.ELSE
*
* HERE TO CONVERT TO REAL
*
SCV08 JSR GTREA CONVERT TO REAL
PPM EXFAL FAIL IF CONVERSION NOT POSSIBLE
BRN EXIXR ELSE RETURN REAL
.FI
*
* HERE TO CONVERT TO NAME
*
SCV09 BEQ (XR),=B$NML,EXIXR RETURN IF ALREADY A NAME
JSR GTNVR ELSE TRY STRING TO NAME CONVERT
PPM EXFAL FAIL IF CONVERSION NOT POSSIBLE
BRN EXVNM ELSE EXIT BUILDING NMBLK FOR VRBLK
*
* HERE TO CONVERT TO PATTERN
*
SCV10 JSR GTPAT CONVERT TO PATTERN
PPM EXFAL FAIL IF CONVERSION NOT POSSIBLE
BRN EXIXR ELSE RETURN PATTERN
*
* CONVERT TO ARRAY
*
SCV11 JSR GTARR GET AN ARRAY
PPM EXFAL FAIL IF NOT CONVERTIBLE
BRN EXSID EXIT SETTING ID FIELD
*
* CONVERT TO TABLE
*
SCV19 MOV (XR),WA LOAD FIRST WORD OF BLOCK
MOV XR,-(XS) REPLACE ARBLK POINTER ON STACK
BEQ WA,=B$TBT,EXITS RETURN ARG IF ALREADY A TABLE
BNE WA,=B$ART,EXFAL ELSE FAIL IF NOT AN ARRAY
EJC
*
* CONVERT (CONTINUED)
*
* HERE TO CONVERT AN ARRAY TO TABLE
*
BNE ARNDM(XR),=NUM02,EXFAL FAIL IF NOT 2-DIM ARRAY
LDI ARDM2(XR) LOAD DIM 2
SBI INTV2 SUBTRACT 2 TO COMPARE
INE EXFAL FAIL IF DIM2 NOT 2
*
* HERE WE HAVE AN ARBLK OF THE RIGHT SHAPE
*
LDI ARDIM(XR) LOAD DIM 1 (NUMBER OF ELEMENTS)
MFI WA GET AS ONE WORD INTEGER
LCT WB,WA COPY TO CONTROL LOOP
ADD =TBSI$,WA ADD SPACE FOR STANDARD FIELDS
WTB WA CONVERT LENGTH TO BAUS
JSR ALLOC ALLOCATE SPACE FOR TBBLK
MOV XR,WC COPY TBBLK POINTER
MOV XR,-(XS) SAVE TBBLK POINTER
MOV =B$TBT,(XR)+ STORE TYPE WORD
ZER (XR)+ STORE ZERO FOR IDVAL FOR NOW
MOV WA,(XR)+ STORE LENGTH
MOV =NULLS,(XR)+ NULL INITIAL LOOKUP VALUE
*
* LOOP TO INITIALIZE BUCKET PTRS TO POINT TO TABLE
*
SCV20 MOV WC,(XR)+ SET BUCKET PTR TO POINT TO TBBLK
BCT WB,SCV20 LOOP TILL ALL INITIALIZED
MOV *ARVL2,WB SET OFFSET TO FIRST ARBLK ELEMENT
*
* LOOP TO COPY ELEMENTS FROM ARRAY TO TABLE
*
SCV21 MOV 1(XS),XL POINT TO ARBLK
BEQ WB,ARLEN(XL),SCV24 JUMP IF ALL MOVED
ADD WB,XL ELSE POINT TO CURRENT LOCATION
ADD *NUM02,WB BUMP OFFSET
MOV (XL),XR LOAD SUBSCRIPT NAME
DCA XL ADJUST PTR TO MERGE (TRVAL=1+1)
EJC
*
* CONVERT (CONTINUED)
*
* LOOP TO CHASE DOWN TRBLK CHAIN FOR VALUE
*
SCV22 MOV TRVAL(XL),XL POINT TO NEXT VALUE
BEQ (XL),=B$TRT,SCV22 LOOP BACK IF TRAPPED
*
* HERE WITH NAME IN XR, VALUE IN XL
*
SCV23 MOV XL,-(XS) STACK VALUE
MOV 1(XS),XL LOAD TBBLK POINTER
JSR TFIND BUILD TEBLK (NOTE WB GT 0 BY NAME)
PPM EXFAL FAIL IF ACESS FAILS
MOV (XS)+,TEVAL(XL) STORE VALUE IN TEBLK
BRN SCV21 LOOP BACK FOR NEXT ELEMENT
*
* HERE AFTER MOVING ALL ELEMENTS TO TBBLK
*
SCV24 MOV (XS)+,XR LOAD TBBLK POINTER
ICA XS POP ARBLK POINTER
BRN EXSID EXIT SETTING IDVAL
*
* CONVERT TO EXPRESSION
*
SCV25 JSR GTEXP CONVERT TO EXPRESSION
PPM EXFAL FAIL IF CONVERSION NOT POSSIBLE
BRN EXIXR ELSE RETURN EXPRESSION
*
* CONVERT TO CODE
*
SCV26 JSR GTCOD CONVERT TO CODE
PPM EXFAL FAIL IF CONVERSION IS NOT POSSIBLE
BRN EXIXR ELSE RETURN CODE
*
* CONVERT TO NUMERIC
*
SCV27 JSR GTNUM CONVERT TO NUMERIC
PPM EXFAL FAIL IF UNCONVERTIBLE
BRN EXIXR RETURN NUMBER
EJC
.IF .CNBF
.ELSE
*
* CONVERT TO BUFFER
*
SCV28 JSR GTBUF CONVERT TO BUFFER
PPM EXFAL FAIL IF CONVERSION NOT POSSIBLE
BRN EXSID EXIT SETTING IDVAL FIELD
.FI
EJC
*
* COPY
*
S$COP ENT ENTRY POINT
JSR CBLCK COPY THE BLOCK
PPM EXITS RETURN IF NO IDVAL FIELD
BRN EXSID EXIT SETTING ID VALUE
*
* CTI
*
S$CTI ENT
LDI INTV0 ZERO IN CASE NULL STRING
JSR GTSTG GET ARG AS A STRING
ERR 086,CTI ARGUMENT IS NOT A STRING
BZE WA,SCT01 SKIP IF NULL
PLC XR PREPARE TO READ THE CHARACTER
LCH WB,(XR) GET THE CHARACTER
MTI WB CONVERT TO INTEGER
ZER XR CLEAR GARBAGE
*
* MAKE ICBLK AND RETURN
*
SCT01 JSR ICBLD BUILD ICBLK
BRN EXIXR RETURN INTEGER RESULT
EJC
*
* DATA
*
S$DAT ENT ENTRY POINT
JSR XSCNI PREPARE TO SCAN ARGUMENT
ERR 087,DATA ARGUMENT IS NOT STRING
ERR 088,DATA ARGUMENT IS NULL
*
* SCAN OUT DATATYPE NAME
*
MOV =CH$PP,WC DELIMITER ONE = LEFT PAREN
MOV WC,XL DELIMITER TWO = LEFT PAREN
JSR XSCAN SCAN DATATYPE NAME
BNZ WA,SDAT1 SKIP IF LEFT PAREN FOUND
ERB 089,DATA ARGUMENT IS MISSING A LEFT PAREN
*
* HERE AFTER SCANNING DATATYPE NAME
*
SDAT1 MOV XR,XL SAVE NAME PTR
MOV SCLEN(XR),WA GET LENGTH
CTB WA,SCSI$ COMPUTE SPACE NEEDED
JSR ALOST REQUEST STATIC STORE FOR NAME
MOV XR,-(XS) SAVE DATATYPE NAME
MVW COPY NAME TO STATIC
MOV (XS),XR GET NAME PTR
ZER XL SCRUB DUD REGISTER
JSR GTNVR LOCATE VRBLK FOR DATATYPE NAME
ERR 090,DATA ARGUMENT HAS NULL DATATYPE NAME
MOV XR,DATDV SAVE VRBLK POINTER FOR DATATYPE
MOV XS,DATXS STORE STARTING STACK VALUE
ZER WB ZERO COUNT OF FIELD NAMES
*
* LOOP TO SCAN FIELD NAMES AND STACK VRBLK POINTERS
*
SDAT2 MOV =CH$RP,WC DELIMITER ONE = RIGHT PAREN
MOV =CH$CM,XL DELIMITER TWO = COMMA
JSR XSCAN SCAN NEXT FIELD NAME
BNZ WA,SDAT3 JUMP IF DELIMITER FOUND
ERB 091,BAD BLANK OR MISSING RIGHT PAREN IN DATA ARG
*
* HERE AFTER SCANNING OUT ONE FIELD NAME
*
SDAT3 JSR GTNVR LOCATE VRBLK FOR FIELD NAME
ERR 092,DATA ARGUMENT HAS NULL FIELD NAME
MOV XR,-(XS) STACK VRBLK POINTER
ICV WB INCREMENT COUNTER
BEQ WA,=NUM02,SDAT2 LOOP BACK IF STOPPED BY COMMA
EJC
*
* DATA (CONTINUED)
*
* NOW BUILD THE DFBLK
*
MOV =DFSI$,WA SET SIZE OF DFBLK STANDARD FIELDS
ADD WB,WA ADD NUMBER OF FIELDS
WTB WA CONVERT LENGTH TO BAUS
MOV WB,WC PRESERVE NO. OF FIELDS
JSR ALOST ALLOCATE SPACE FOR DFBLK
MOV WC,WB GET NO OF FIELDS
MOV DATXS,XT POINT TO START OF STACK
MOV (XT),WC LOAD DATATYPE NAME
MOV XR,(XT) SAVE DFBLK POINTER ON STACK
MOV =B$DFC,(XR)+ STORE TYPE WORD
MOV WB,(XR)+ STORE NUMBER OF FIELDS (FARGS)
MOV WA,(XR)+ STORE LENGTH (DFLEN)
SUB *PDDFS,WA COMPUTE PDBLK LENGTH (FOR DFPDL)
MOV WA,(XR)+ STORE PDBLK LENGTH (DFPDL)
MOV WC,(XR)+ STORE DATATYPE NAME (DFNAM)
LCT WC,WB COPY NUMBER OF FIELDS
*
* LOOP TO MOVE FIELD NAME VRBLK POINTERS TO DFBLK
*
SDAT4 MOV -(XT),(XR)+ MOVE ONE FIELD NAME VRBLK POINTER
BCT WC,SDAT4 LOOP TILL ALL MOVED
*
* NOW DEFINE THE DATATYPE FUNCTION
*
MOV WA,WC COPY LENGTH OF PDBLK FOR LATER LOOP
MOV DATDV,XR POINT TO VRBLK
MOV DATXS,XT POINT BACK ON STACK
MOV (XT),XL LOAD DFBLK POINTER
JSR DFFNC DEFINE FUNCTION
EJC
*
* DATA (CONTINUED)
*
* LOOP TO BUILD FFBLKS
*
*
* NOTICE THAT THE FFBLKS ARE CONSTRUCTED IN REVERSE ORDER
* SO THAT THE REQUIRED OFFSETS CAN BE OBTAINED FROM
* SUCCESSIVE DECREMENTATION OF THE PDBLK LENGTH (IN WC).
*
SDAT5 MOV *FFSI$,WA SET LENGTH OF FFBLK
JSR ALLOC ALLOCATE SPACE FOR FFBLK
MOV =B$FFC,(XR) SET TYPE WORD
MOV =NUM01,FARGS(XR) STORE FARGS (ALWAYS ONE)
MOV DATXS,XT POINT BACK ON STACK
MOV (XT),FFDFP(XR) COPY DFBLK PTR TO FFBLK
DCA WC DECREMENT OLD DFPDL TO GET NEXT OFS
MOV WC,FFOFS(XR) SET OFFSET TO THIS FIELD
ZER FFNXT(XR) TENTATIVELY SET ZERO FORWARD PTR
MOV XR,XL COPY FFBLK POINTER FOR DFFNC
MOV (XS),XR LOAD VRBLK POINTER FOR FIELD
MOV VRFNC(XR),XR LOAD CURRENT FUNCTION POINTER
BNE (XR),=B$FFC,SDAT6 SKIP IF NOT CURRENTLY A FIELD FUNC
*
* HERE WE MUST CHAIN AN OLD FFBLK PTR TO PRESERVE IT IN THE
* CASE OF MULTIPLE FIELD FUNCTIONS WITH THE SAME NAME
*
MOV XR,FFNXT(XL) LINK NEW FFBLK TO PREVIOUS CHAIN
*
* MERGE HERE TO DEFINE FIELD FUNCTION
*
SDAT6 MOV (XS)+,XR LOAD VRBLK POINTER
JSR DFFNC DEFINE FIELD FUNCTION
BNE XS,DATXS,SDAT5 LOOP BACK TILL ALL DONE
ICA XS POP DFBLK POINTER
BRN EXNUL RETURN WITH NULL RESULT
EJC
*
* DATATYPE
*
S$DTP ENT ENTRY POINT
MOV (XS)+,XR LOAD ARGUMENT
JSR DTYPE GET DATATYPE
BRN EXIXR AND RETURN IT AS RESULT
EJC
*
* DATE
*
S$DTE ENT ENTRY POINT
JSR SYSDT CALL SYSTEM DATE ROUTINE
MOV 1(XL),WA LOAD LENGTH FOR SBSTR
BZE WA,EXNUL RETURN NULL IF LENGTH IS ZERO
ZER WB SET ZERO OFFSET
JSR SBSTR USE SBSTR TO BUILD SCBLK
BRN EXIXR RETURN DATE STRING
EJC
*
* DEFINE
*
S$DFN ENT ENTRY POINT
MOV (XS)+,XR LOAD SECOND ARGUMENT
ZER DEFLB ZERO LABEL POINTER IN CASE NULL
BEQ XR,=NULLS,SDF01 JUMP IF NULL SECOND ARGUMENT
JSR GTNVR ELSE FIND VRBLK FOR LABEL
PPM SDF13 JUMP IF NOT A VARIABLE NAME
MOV XR,DEFLB ELSE SET SPECIFIED ENTRY
*
* SCAN FUNCTION NAME
*
SDF01 JSR XSCNI PREPARE TO SCAN FIRST ARGUMENT
ERR 093,DEFINE FIRST ARGUMENT IS NOT STRING
ERR 094,DEFINE FIRST ARGUMENT IS NULL
MOV =CH$PP,WC DELIMITER ONE = LEFT PAREN
MOV WC,XL DELIMITER TWO = LEFT PAREN
JSR XSCAN SCAN OUT FUNCTION NAME
BNZ WA,SDF02 JUMP IF LEFT PAREN FOUND
ERB 095,DEFINE FIRST ARGUMENT IS MISSING A LEFT PAREN
*
* HERE AFTER SCANNING OUT FUNCTION NAME
*
SDF02 JSR GTNVR GET VARIABLE NAME
ERR 096,DEFINE FIRST ARGUMENT HAS NULL FUNCTION NAME
MOV XR,DEFVR SAVE VRBLK POINTER FOR FUNCTION NAM
ZER WB ZERO COUNT OF ARGUMENTS
MOV XS,DEFXS SAVE INITIAL STACK POINTER
BNZ DEFLB,SDF03 JUMP IF SECOND ARGUMENT GIVEN
MOV XR,DEFLB ELSE DEFAULT IS FUNCTION NAME
*
* LOOP TO SCAN ARGUMENT NAMES AND STACK VRBLK POINTERS
*
SDF03 MOV =CH$RP,WC DELIMITER ONE = RIGHT PAREN
MOV =CH$CM,XL DELIMITER TWO = COMMA
JSR XSCAN SCAN OUT NEXT ARGUMENT NAME
BZE WA,SDF14 FAIL IF RUNOUT
JSR GTNVR GET VRBLK POINTER
PPM SDF04 IGNORE NULL NAME
MOV XR,-(XS) STACK ARGUMENT VRBLK POINTER
ICV WB INCREMENT COUNTER
BEQ WA,=NUM02,SDF03 LOOP BACK IF STOPPED BY A COMMA
BRN SDF05 JUMP FOR RIGHT PAREN
EJC
*
* DEFINE (CONTINUED)
*
* NULL ARG FOUND. CONTINUE IF STOPPED BY COMMA
*
SDF04 BEQ WA,=NUM02,SDF03 LOOP IF COMMA
*
* HERE AFTER SCANNING OUT FUNCTION ARGUMENT NAMES
*
SDF05 MOV WB,DEFNA SAVE NUMBER OF ARGUMENTS
ZER WB ZERO COUNT OF LOCALS
*
* LOOP TO SCAN LOCAL NAMES AND STACK VRBLK POINTERS
*
SDF06 MOV =CH$CM,WC SET DELIMITER ONE = COMMA
MOV WC,XL SET DELIMITER TWO = COMMA
JSR XSCAN SCAN OUT NEXT LOCAL NAME
BNZ WA,SDF07 SKIP IF COMMA FOUND
BNZ XSCNB,SDF14 FAIL IF BAD BLANK, OK IF LAST LOC
*
* HERE AFTER SCANNING OUT A LOCAL NAME
*
SDF07 JSR GTNVR GET VRBLK POINTER
PPM SDF08 IGNORE NULL NAME
ICV WB IF OK, INCREMENT COUNT
MOV XR,-(XS) STACK VRBLK POINTER
BNZ WA,SDF06 LOOP BACK IF STOPPED BY A COMMA
BRN SDF09 JUMP FOR END OF STRING
*
* NULL LOCAL
*
SDF08 BNZ WA,SDF06 LOOP IF COMMA AFTER NULL LOCAL
EJC
*
* DEFINE (CONTINUED)
*
* HERE AFTER SCANNING LOCALS, BUILD PFBLK
*
SDF09 MOV WB,WA COPY COUNT OF LOCALS
ADD DEFNA,WA ADD NUMBER OF ARGUMENTS
MOV WA,WC SET SUM ARGS+LOCALS AS LOOP COUNT
ADD =PFSI$,WA ADD SPACE FOR STANDARD FIELDS
WTB WA CONVERT LENGTH TO BAUS
JSR ALLOC ALLOCATE SPACE FOR PFBLK
MOV XR,XL SAVE POINTER TO PFBLK
MOV =B$PFC,(XR)+ STORE FIRST WORD
MOV DEFNA,(XR)+ STORE NUMBER OF ARGUMENTS
MOV WA,(XR)+ STORE LENGTH (PFLEN)
MOV DEFVR,(XR)+ STORE VRBLK PTR FOR FUNCTION NAME
MOV WB,(XR)+ STORE NUMBER OF LOCALS
ZER (XR)+ DEAL WITH LABEL LATER
ZER (XR)+ ZERO PFCTR
ZER (XR)+ ZERO PFRTR
BZE WC,SDF11 SKIP IF NO ARGS OR LOCALS
MOV XL,WA KEEP PFBLK POINTER
MOV DEFXS,XT POINT BEFORE ARGUMENTS
LCT WC,WC GET COUNT OF ARGS+LOCALS FOR LOOP
*
* LOOP TO MOVE LOCALS AND ARGS TO PFBLK
*
SDF10 MOV -(XT),(XR)+ STORE ONE ENTRY AND BUMP POINTERS
BCT WC,SDF10 LOOP TILL ALL STORED
MOV WA,XL RECOVER PFBLK POINTER
EJC
*
* DEFINE (CONTINUED)
*
* NOW DEAL WITH LABEL
*
SDF11 MOV DEFXS,XS POP STACK
MOV DEFLB,XR POINT TO VRBLK FOR LABEL
MOV VRLBL(XR),XR LOAD LABEL POINTER
BNE (XR),=B$TRT,SDF12 SKIP IF NOT TRAPPED
MOV TRLBL(XR),XR ELSE POINT TO REAL LABEL
*
* HERE AFTER LOCATING REAL LABEL POINTER
*
SDF12 BEQ XR,=STNDL,SDF13 JUMP IF LABEL IS NOT DEFINED
MOV XR,PFCOD(XL) ELSE STORE LABEL POINTER
MOV DEFVR,XR POINT BACK TO VRBLK FOR FUNCTION
JSR DFFNC DEFINE FUNCTION
BRN EXNUL AND EXIT RETURNING NULL
*
* HERE FOR ERRONEOUS LABEL
*
SDF13 ERB 097,DEFINE FUNCTION ENTRY POINT IS NOT DEFINED LABEL
*
* ERRONEOUS ARG OR LOCAL
*
SDF14 ERB 098,BAD BLANK OR MISSING RIGHT PAREN IN DEFINE ARG
EJC
*
* DETACH
*
S$DET ENT ENTRY POINT
MOV (XS)+,XR LOAD ARGUMENT
JSR GTVAR LOCATE VARIABLE
ERR 099,DETACH ARGUMENT IS NOT APPROPRIATE NAME
MOV WA,-(XS) KEEP OFFSET
ZER SDETF CLEAR FAIL FLAG
MOV =TRTIN,WB TRACE TYPE
ZER XR REMOVE TRBLK
JSR TRCHN REMOVE ANY INPUT ASSOCIATION
PPM SDET1 SKIP IF NO INPUT TRBLK
MNZ SDETF NOTE TRBLK REMOVED
*
* REPEAT FOR OUTPUT TRBLK
*
SDET1 MOV (XS)+,WA RECOVER OFFSET
MOV =TRTOU,WB TRTYP
JSR TRCHN REMOVE ANY OUTPUT ASSOCIATION
PPM SDET2 SKIP IF NO TRBLK
BRN EXNUL SUCCEED
*
* CHECK AT LEAST ONE TRBLK REMOVED
*
SDET2 BNZ SDETF,EXNUL SUCCEED IF SO
BRN EXFAL ELSE FAIL
EJC
*
* DIFFER
*
S$DIF ENT ENTRY POINT
MOV (XS)+,XR LOAD SECOND ARGUMENT
MOV (XS)+,XL LOAD FIRST ARGUMENT
JSR IDENT CALL IDENT COMPARISON ROUTINE
PPM EXFAL FAIL IF IDENT
BRN EXNUL RETURN NULL IF DIFFER
EJC
*
* DUMP
*
S$DMP ENT ENTRY POINT
JSR GTSMI LOAD DUMP ARG AS SMALL INTEGER
ERR 100,DUMP ARGUMENT IS NOT INTEGER
ERR 101,DUMP ARGUMENT IS NEGATIVE OR TOO LARGE
JSR DUMPR ELSE CALL DUMP ROUTINE
BRN EXNUL AND RETURN NULL AS RESULT
EJC
*
* DUPL
*
S$DUP ENT ENTRY POINT
JSR GTSMI GET SECOND ARGUMENT AS SMALL INTEGE
ERR 102,DUPL SECOND ARGUMENT IS NOT INTEGER
PPM SDUP7 JUMP IF NEGATIVE OT TOO BIG
MOV XR,WB SAVE DUPLICATION FACTOR
JSR GTSTG GET FIRST ARG AS STRING
PPM SDUP4 JUMP IF NOT A STRING
*
* HERE FOR CASE OF DUPLICATION OF A STRING
*
MTI WA ACQUIRE LENGTH AS INTEGER
STI DUPSI SAVE FOR THE MOMENT
MTI WB GET DUPLICATION FACTOR AS INTEGER
MLI DUPSI FORM PRODUCT
IOV SDUP3 JUMP IF OVERFLOW
IEQ EXNUL RETURN NULL IF RESULT LENGTH = 0
MFI WA,SDUP3 GET AS ADDR INTEGER, CHECK OVFLO
*
* MERGE HERE WITH RESULT LENGTH IN WA
*
SDUP1 MOV XR,XL SAVE STRING POINTER
JSR ALOCS ALLOCATE SPACE FOR STRING
MOV XR,-(XS) SAVE AS RESULT POINTER
MOV XL,WC SAVE POINTER TO ARGUMENT STRING
PSC XR PREPARE TO STORE CHARS OF RESULT
LCT WB,WB SET COUNTER TO CONTROL LOOP
*
* LOOP THROUGH DUPLICATIONS
*
SDUP2 MOV WC,XL POINT BACK TO ARGUMENT STRING
MOV SCLEN(XL),WA GET NUMBER OF CHARACTERS
PLC XL POINT TO CHARS IN ARGUMENT STRING
MVC MOVE CHARACTERS TO RESULT STRING
BCT WB,SDUP2 LOOP TILL ALL DUPLICATIONS DONE
BRN EXITS THEN EXIT FOR NEXT CODE WORD
EJC
*
* DUPL (CONTINUED)
*
* HERE IF TOO LARGE, SET MAX LENGTH AND LET ALOCS CATCH IT
*
SDUP3 MOV DNAME,WA SET IMPOSSIBLE LENGTH FOR ALOCS
BRN SDUP1 MERGE BACK
*
* HERE IF NOT A STRING
*
SDUP4 JSR GTPAT CONVERT ARGUMENT TO PATTERN
ERR 103,DUPL FIRST ARGUMENT IS NOT STRING OR PATTERN
*
* HERE TO DUPLICATE A PATTERN ARGUMENT
*
MOV XR,-(XS) STORE PATTERN ON STACK
MOV =NDNTH,XR START OFF WITH NULL PATTERN
BZE WB,SDUP6 NULL PATTERN IS RESULT IF DUPFAC=0
MOV WB,-(XS) PRESERVE LOOP COUNT
*
* LOOP TO DUPLICATE BY SUCCESSIVE CONCATENATION
*
SDUP5 MOV XR,XL COPY CURRENT VALUE AS RIGHT ARGUMNT
MOV 1(XS),XR GET A NEW COPY OF LEFT
JSR PCONC CONCATENATE
DCV (XS) COUNT DOWN
BNZ (XS),SDUP5 LOOP
ICA XS POP LOOP COUNT
*
* HERE TO EXIT AFTER CONSTRUCTING PATTERN
*
SDUP6 MOV XR,(XS) STORE RESULT ON STACK
BRN EXITS EXIT WITH RESULT ON STACK
*
* FAIL IF SECOND ARG IS OUT OF RANGE
*
SDUP7 ICA XS POP FIRST ARGUMENT
BRN EXFAL FAIL
EJC
*
* EJECT
*
S$EJC ENT ENTRY POINT
MOV (XS)+,WB GET ARGUMENT
MOV WB,-(XS) RESTACK IT
JSR GTSTG CONVERT TO STRING
PPM SEJC2 FAIL IF CANT
BZE WA,SEJC1 SKIP IF NULL STRING
MOV WB,-(XS) RESTACK ORIGINAL ARG
JSR IOFTG CALL FILETAG ROUTINE
PPM SEJC2 FAIL
BZE WA,EXFAL FAIL IF NOT ASSOCIATED
JSR SYSEF CALL EJECT FILE FUNCTION
PPM EXFAL FAIL RETURN
PPM EROSI ERROR RETURN
BRN EXNUL RETURN NULL AS RESULT
*
* HERE TO EJECT STANDARD OUTPUT FILE
*
SEJC1 JSR SYSEP CALL ROUTINE TO EJECT PRINTER
PPM EXFAL FAIL RETURN
PPM EROSI ERROR RETURN
BRN EXNUL EXIT WITH NULL RESULT
*
* ERROR POINT
*
SEJC2 ERB 104,EJECT ARGUMENT IS NOT A SUITABLE FILETAG
EJC
*
* ENDFILE
*
S$ENF ENT ENTRY POINT
JSR GTSTG CONVERT SECOND ARG TO STRING
ERR 105,ENDFILE SECOND ARGUMENT IS NOT A STRING
BNZ WA,SENF1 SKIP IF NON NULL SECOND ARG
ZER XR 0 IF NULL
*
* NOW PROCESS FILETAG
*
SENF1 MOV XR,SENFR KEEP SECOND ARG
JSR IOFTG CALL FILETAG PROC (WB = VRBLK PTR)
ERR 106,ENDFILE FIRST ARGUMENT IS NOT A SUITABLE FILETAG
BZE WA,EXFAL FAIL IF NO IOTAG
MOV SENFR,XR RECOVER SECOND ARG
JSR SYSEN CALL ENDFILE ROUTINE
PPM EXFAL FAIL RETURN
PPM EROSI ERROR RETURN
BNZ WA,EXNUL RETURN NULL IF NO FILE CLOSURE
MOV WB,XL POINT TO FILETAG VRBLK
MOV *VRVAL,WA OFFSET TO VALUE FIELD
ZER XR FOR TRBLK REMOVAL
MOV =TRTIO,WB TRTYP
JSR TRCHN REMOVE TRBLK
PPM EXFAL (CANT FAIL HERE)
BRN EXNUL RETURN NULL
EJC
*
* EQ
*
S$EQF ENT ENTRY POINT
JSR ACOMP CALL ARITHMETIC COMPARISON ROUTINE
ERR 107,EQ FIRST ARGUMENT IS NOT NUMERIC
ERR 108,EQ SECOND ARGUMENT IS NOT NUMERIC
PPM EXFAL FAIL IF LT
PPM EXNUL RETURN NULL IF EQ
PPM EXFAL FAIL IF GT
EJC
*
* EVAL
*
S$EVL ENT ENTRY POINT
MOV (XS)+,XR LOAD ARGUMENT
JSR GTEXP CONVERT TO EXPRESSION
ERR 109,EVAL ARGUMENT IS NOT EXPRESSION
LCW WC LOAD NEXT CODE WORD
BNE WC,=OFNE$,SEVL1 JUMP IF CALLED BY VALUE
SCP XL COPY CODE POINTER
MOV (XL),WA GET NEXT CODE WORD
BNE WA,=ORNM$,SEVL2 BY NAME UNLESS EXPRESSION
BNZ 1(XS),SEVL2 JUMP IF BY NAME
*
* HERE IF CALLED BY VALUE
*
SEVL1 ZER WB SET FLAG FOR BY VALUE
MOV WC,-(XS) SAVE CODE WORD
JSR EVALX EVALUATE EXPRESSION BY VALUE
PPM EXFAL FAIL IF EVALUATION FAILS
MOV XR,XL COPY RESULT
MOV (XS),XR RELOAD NEXT CODE WORD
MOV XL,(XS) STACK RESULT
BRI (XR) JUMP TO EXECUTE NEXT CODE WORD
*
* HERE IF CALLED BY NAME
*
SEVL2 MOV =NUM01,WB SET FLAG FOR BY NAME
JSR EVALX EVALUATE EXPRESSION BY NAME
PPM EXFAL FAIL IF EVALUATION FAILS
BRN EXNAM EXIT WITH NAME
.IF .CNEX
.ELSE
EJC
*
* EXIT
*
S$EXT ENT ENTRY POINT
ZER WB CLEAR AMOUNT OF STATIC SHIFT
JSR GBCOL COMPACT MEMORY BY COLLECTING
JSR GTSTG CONVERT ARG TO STRING
ERR 110,EXIT ARGUMENT IS NOT SUITABLE INTEGER OR STRING
MOV XR,XL COPY STRING PTR
JSR GTINT CHECK IT IS INTEGER
PPM SEXT1 SKIP IF UNCONVERTIBLE
ZER XL NOTE IT IS INTEGER
LDI ICVAL(XR) GET INTEGER ARG
*
* MERGE TO CALL OSINT EXIT ROUTINE
*
SEXT1 MOV =HEADV,XR POINT TO V.V STRING
MOV =KVCOD,WA VALUE OF CODE KEYWORD
JSR SYSXI CALL EXTERNAL ROUTINE
PPM EXFAL FAIL RETURN
PPM EROSI ERROR RETURN
IEQ EXNUL RETURN IF ARGUMENT 0
ZER GBCNT RESUMING EXECUTION SO.
IGT SEXT2 SKIP IF POSITIVE
NGI MAKE POSITIVE
*
* CHECK FOR OPTION RESPECIFICATION
*
SEXT2 MFI WC GET VALUE IN WORK REGISTER
BEQ WC,=NUM03,SEXT3 SKIP IF WAS 3
MOV WC,-(XS) SAVE VALUE
ZER WC SET TO READ OPTIONS
JSR PRPAR READ SYSPP OPTIONS
MOV (XS)+,WA RESTORE VALUE
*
* DEAL WITH HEADER OPTIONS (FIDDLED BY PRPAR)
*
SEXT3 MNZ HEADP ASSUME NO HEADERS
BNE WC,=NUM01,SEXT4 SKIP IF NOT 1
ZER HEADP REQUEST HEADER PRINTING
*
* ALMOST READY TO RESUME RUNNING
*
SEXT4 JSR SYSTM GET RECOMMENCEMENT TIME
STI TIMSX SAVE AS INITIAL TIME
LDI KVSTC RESET TO ENSURE ...
STI KVSTL ... CORRECT EXECUTION STATS
BRN EXNUL RESUME EXECUTION
.FI
.IF .CNFN
.ELSE
EJC
*
* FENCE
*
S$FNC ENT ENTRY POINT
MOV =P$FNC,WB SET PCODE FOR P$FNC
ZER XR P0BLK
JSR PBILD BUILD P$FNC NODE
MOV XR,XL SAVE POINTER TO IT
MOV (XS)+,XR GET ARGUMENT
JSR GTPAT CONVERT TO PATTERN
ERR 180,FENCE ARGUMENT IS NOT PATTERN
JSR PCONC CONCATENATE TO P$FNC NODE
MOV XR,XL SAVE PTR TO CONCATENATED PATTERN
MOV =P$FNA,WB SET FOR P$FNA PCODE
ZER XR P0BLK
JSR PBILD CONSTRUCT P$FNA NODE
MOV XL,PTHEN(XR) SET PATTERN AS PTHEN
MOV XR,-(XS) SET AS RESULT
BRN EXITS DO NEXT CODE WORD
EJC
.FI
*
* FIELD
*
S$FLD ENT ENTRY POINT
JSR GTSMI GET SECOND ARGUMENT (FIELD NUMBER)
ERR 255,FIELD SECOND ARGUMENT IS NOT INTEGER
PPM EXFAL FAIL IF OUT OF RANGE
MOV XR,WB ELSE SAVE INTEGER VALUE
MOV (XS)+,XR LOAD FIRST ARGUMENT
JSR GTNVR POINT TO VRBLK
PPM SFLD1 JUMP (ERROR) IF NOT VARIABLE NAME
MOV VRFNC(XR),XR ELSE POINT TO FUNCTION BLOCK
BNE (XR),=B$DFC,SFLD1 ERROR IF NOT DATATYPE FUNCTION
*
* HERE IF FIRST ARGUMENT IS A DATATYPE FUNCTION NAME
*
BZE WB,EXFAL FAIL IF ARGUMENT NUMBER IS ZERO
BGT WB,FARGS(XR),EXFAL FAIL IF TOO LARGE
WTB WB ELSE CONVERT TO BYTE OFFSET
ADD WB,XR POINT TO FIELD NAME
MOV DFFLB(XR),XR LOAD VRBLK POINTER
BRN EXVNM EXIT TO BUILD NMBLK
*
* HERE FOR BAD FIRST ARGUMENT
*
SFLD1 ERB 254,FIELD FIRST ARGUMENT IS NOT DATATYPE NAME
EJC
*
* GE
*
S$GEF ENT ENTRY POINT
JSR ACOMP CALL ARITHMETIC COMPARISON ROUTINE
ERR 111,GE FIRST ARGUMENT IS NOT NUMERIC
ERR 112,GE SECOND ARGUMENT IS NOT NUMERIC
PPM EXFAL FAIL IF LT
PPM EXNUL RETURN NULL IF EQ
PPM EXNUL RETURN NULL IF GT
*
* GT
*
S$GTF ENT ENTRY POINT
JSR ACOMP CALL ARITHMETIC COMPARISON ROUTINE
ERR 113,GT FIRST ARGUMENT IS NOT NUMERIC
ERR 114,GT SECOND ARGUMENT IS NOT NUMERIC
PPM EXFAL FAIL IF LT
PPM EXFAL FAIL IF EQ
PPM EXNUL RETURN NULL IF GT
EJC
*
* HOST
*
S$HST ENT ENTRY POINT
JSR GTSTG CONVERT ARG TO STRING
ERR 115,ERRONEOUS THIRD ARGUMENT FOR HOST
MOV WA,WB KEEP LENGTH
MOV XR,WC KEEP THIRD ARG
JSR GTSTG CONVERT ARG TO STRING
ERR 116,ERRONEOUS SECOND ARGUMENT FOR HOST
ORB WA,WB NON ZERO UNLESS TWO ARGS NULL
MOV XR,XL KEEP SECOND ARG
JSR GTSTG CONVERT ARG TO STRING
ERR 117,ERRONEOUS FIRST ARGUMENT FOR HOST
ORB WA,WB NON ZERO UNLESS ALL ARGS NULL
MOV XR,WA KEEP FIRST ARG
MOV WC,XR GET THIRD ARG
JSR SYSHS CALL SYSHS ROUTINE
PPM EXFAL FAIL RETURN
PPM EROSI ERROR RETURN
MOV SCLEN(XL),WA LENGTH OF RETURNED STRING
ZER WB ZERO OFFSET
JSR SBSTR BUILD COPY OF STRING
MOV XR,-(XS) STACK THE RESULT
BRN EXITS RETURN RESULT ON STACK
EJC
*
* IDENT
*
S$IDN ENT ENTRY POINT
MOV (XS)+,XR LOAD SECOND ARGUMENT
MOV (XS)+,XL LOAD FIRST ARGUMENT
JSR IDENT CALL IDENT COMPARISON ROUTINE
PPM EXNUL RETURN NULL IF IDENT
BRN EXFAL FAIL IF DIFFER
EJC
*
* INPUT
*
S$INP ENT ENTRY POINT
ZER WB INPUT FLAG
JSR IOPUT CALL INPUT/OUTPUT ASSOC. ROUTINE
ERR 118,INPUT THIRD ARGUMENT (FILEPROPS) IS NOT A STRING
ERR 119,INAPPROPRIATE SECOND ARGUMENT (FILETAG) FOR INPUT
ERR 120,INAPPROPRIATE FIRST ARGUMENT FOR INPUT
PPM EXFAL FAIL RETURN
BRN EXNUL RETURN NULL STRING
.IF .CNBF
.ELSE
EJC
*
* INSERT
*
S$INS ENT ENTRY POINT
MOV (XS)+,XL GET STRING ARG
JSR GTSMI GET REPLACE LENGTH
ERR 121,INSERT THIRD ARGUMENT NOT INTEGER
PPM EXFAL FAIL IF OUT OF RANGE
MOV WC,WB COPY TO PROPER REG
JSR GTSMI GET REPLACE POSITION
ERR 122,INSERT SECOND ARGUMENT NOT INTEGER
PPM EXFAL FAIL IF OUT OF RANGE
BZE WC,EXFAL FAIL IF ZERO
DCV WC DECREMENT TO GET OFFSET
MOV WC,WA PUT IN PROPER REGISTER
MOV (XS)+,XR GET BUFFER
BEQ (XR),=B$BCT,SINS1 PRESS ON IF TYPE OK
ERB 123,INSERT FIRST ARGUMENT NOT BUFFER
*
* HERE WHEN EVERYTHING LOADED UP
*
SINS1 JSR INSBF CALL TO INSERT
ERR 124,INSERT FOURTH ARGUMENT NOT A STRING
PPM EXFAL FAIL IF OUT OF RANGE
BRN EXNUL ELSE OK - EXIT WITH NULL
.FI
EJC
*
* INTEGER
*
S$INT ENT ENTRY POINT
MOV (XS)+,XR LOAD ARGUMENT
JSR GTNUM CONVERT TO NUMERIC
PPM EXFAL FAIL IF NON-NUMERIC
BEQ WA,=B$ICL,EXNUL RETURN NULL IF INTEGER
BRN EXFAL FAIL IF REAL
EJC
*
* ITC
*
S$ITC ENT
JSR GTSMI OBTAIN ARG AS AN INTEGER
ERR 125,ITC ARGUMENT IS NOT A SMALL INTEGER
PPM EXFAL FAIL IF OUT OF RANGE
BGE WC,=CFP$A,EXFAL FURTHER RANGE CHECK
MOV WC,WB PRESERVE WC
MOV =NUM01,WA FOR SCBLK REQUEST
JSR ALOCS BUILD STRING BLOCK
MOV XR,XL COPY STRING PTR
PSC XL READY TO STORE CHAR
SCH WB,(XL) STORE IT
ZER XL CLEAR GARBAGE
BRN EXIXR RETURN STRING RESULT
EJC
*
* ITEM
*
* ITEM DOES NOT PERMIT THE DIRECT (FAST) CALL SO THAT
* WA CONTAINS THE ACTUAL NUMBER OF ARGUMENTS PASSED.
*
S$ITM ENT ENTRY POINT
*
* DEAL WITH CASE OF NO ARGS
*
BNZ WA,SITM1 JUMP IF AT LEAST ONE ARG
MOV =NULLS,-(XS) ELSE SUPPLY GARBAGE NULL ARG
MOV =NUM01,WA AND FIX ARGUMENT COUNT
*
* CHECK FOR NAME/VALUE CASES
*
SITM1 SCP XR GET CURRENT CODE POINTER
MOV (XR),XL LOAD NEXT CODE WORD
DCV WA GET NUMBER OF SUBSCRIPTS
MOV WA,XR COPY FOR ARREF
BEQ XL,=OFNE$,SITM2 JUMP IF CALLED BY NAME
*
* HERE IF CALLED BY VALUE
*
ZER WB SET CODE FOR CALL BY VALUE
BRN ARREF OFF TO ARRAY REFERENCE ROUTINE
*
* HERE FOR CALL BY NAME
*
SITM2 MNZ WB SET CODE FOR CALL BY NAME
LCW WA LOAD AND IGNORE OFNE$ CALL
BRN ARREF OFF TO ARRAY REFERENCE ROUTINE
EJC
*
* LE
*
S$LEF ENT ENTRY POINT
JSR ACOMP CALL ARITHMETIC COMPARISON ROUTINE
ERR 126,LE FIRST ARGUMENT IS NOT NUMERIC
ERR 127,LE SECOND ARGUMENT IS NOT NUMERIC
PPM EXNUL RETURN NULL IF LT
PPM EXNUL RETURN NULL IF EQ
PPM EXFAL FAIL IF GT
EJC
*
* LEN
*
S$LEN ENT ENTRY POINT
MOV =P$LEN,WB SET PCODE FOR INTEGER ARG CASE
MOV =P$LND,WA SET PCODE FOR EXPR ARG CASE
JSR PATIN CALL COMMON ROUTINE TO BUILD NODE
ERR 128,LEN ARGUMENT IS NOT INTEGER OR EXPRESSION
ERR 129,LEN ARGUMENT IS NEGATIVE OR TOO LARGE
BRN EXIXR RETURN PATTERN NODE
EJC
*
* LEQ
*
S$LEQ ENT ENTRY POINT
JSR LCOMP CALL STRING COMPARISON ROUTINE
ERR 130,LEQ FIRST ARGUMENT IS NOT STRING
ERR 131,LEQ SECOND ARGUMENT IS NOT STRING
PPM EXFAL FAIL IF LLT
PPM EXNUL RETURN NULL IF LEQ
PPM EXFAL FAIL IF LGT
EJC
*
* LGE
*
S$LGE ENT ENTRY POINT
JSR LCOMP CALL STRING COMPARISON ROUTINE
ERR 132,LGE FIRST ARGUMENT IS NOT STRING
ERR 133,LGE SECOND ARGUMENT IS NOT STRING
PPM EXFAL FAIL IF LLT
PPM EXNUL RETURN NULL IF LEQ
PPM EXNUL RETURN NULL IF LGT
EJC
*
* LGT
*
S$LGT ENT ENTRY POINT
JSR LCOMP CALL STRING COMPARISON ROUTINE
ERR 134,LGT FIRST ARGUMENT IS NOT STRING
ERR 135,LGT SECOND ARGUMENT IS NOT STRING
PPM EXFAL FAIL IF LLT
PPM EXFAL FAIL IF LEQ
PPM EXNUL RETURN NULL IF LGT
EJC
*
* LLE
*
S$LLE ENT ENTRY POINT
JSR LCOMP CALL STRING COMPARISON ROUTINE
ERR 136,LLE FIRST ARGUMENT IS NOT STRING
ERR 137,LLE SECOND ARGUMENT IS NOT STRING
PPM EXNUL RETURN NULL IF LLT
PPM EXNUL RETURN NULL IF LEQ
PPM EXFAL FAIL IF LGT
EJC
*
* LLT
*
S$LLT ENT ENTRY POINT
JSR LCOMP CALL STRING COMPARISON ROUTINE
ERR 138,LLT FIRST ARGUMENT IS NOT STRING
ERR 139,LLT SECOND ARGUMENT IS NOT STRING
PPM EXNUL RETURN NULL IF LLT
PPM EXFAL FAIL IF LEQ
PPM EXFAL FAIL IF LGT
EJC
*
* LNE
*
S$LNE ENT ENTRY POINT
JSR LCOMP CALL STRING COMPARISON ROUTINE
ERR 140,LNE FIRST ARGUMENT IS NOT STRING
ERR 141,LNE SECOND ARGUMENT IS NOT STRING
PPM EXNUL RETURN NULL IF LLT
PPM EXFAL FAIL IF LEQ
PPM EXNUL RETURN NULL IF LGT
.IF .CNLD
.ELSE
EJC
*
* LOAD
*
S$LOD ENT ENTRY POINT
JSR GTSTG LOAD LIBRARY NAME
ERR 142,LOAD SECOND ARGUMENT IS NOT STRING
MOV XR,XL SAVE LIBRARY NAME
JSR XSCNI PREPARE TO SCAN FIRST ARGUMENT
ERR 143,LOAD FIRST ARGUMENT IS NOT STRING
ERR 144,LOAD FIRST ARGUMENT IS NULL
MOV XL,-(XS) STACK LIBRARY NAME
MOV =CH$PP,WC SET DELIMITER ONE = LEFT PAREN
MOV WC,XL SET DELIMITER TWO = LEFT PAREN
JSR XSCAN SCAN FUNCTION NAME
MOV XR,-(XS) SAVE PTR TO FUNCTION NAME
BNZ WA,SLOD1 JUMP IF LEFT PAREN FOUND
ERB 145,LOAD FIRST ARGUMENT IS MISSING A LEFT PAREN
*
* HERE AFTER SUCCESSFULLY SCANNING FUNCTION NAME
*
SLOD1 JSR GTNVR LOCATE VRBLK
ERR 146,LOAD FIRST ARGUMENT HAS NULL FUNCTION NAME
MOV XR,LODFN SAVE VRBLK POINTER
ZER LODNA ZERO COUNT OF ARGUMENTS
*
* LOOP TO SCAN ARGUMENT DATATYPE NAMES
*
SLOD2 MOV =CH$RP,WC DELIMITER ONE IS RIGHT PAREN
MOV =CH$CM,XL DELIMITER TWO IS COMMA
JSR XSCAN SCAN NEXT ARGUMENT NAME
ICV LODNA BUMP ARGUMENT COUNT
BNZ WA,SLOD3 JUMP IF OK DELIMITER WAS FOUND
ERB 147,BAD BLANK OR MISSING RIGHT PAREN IN LOAD ARG
EJC
*
* LOAD (CONTINUED)
*
* COME HERE TO ANALYZE THE DATATYPE POINTER IN (XR). THIS
* CODE IS USED BOTH FOR ARGUMENTS (WA=1,2) AND FOR THE
* RESULT DATATYPE (WITH WA SET TO ZERO).
*
SLOD3 MOV XR,-(XS) STACK DATATYPE NAME POINTER
MOV =NUM01,WB SET STRING CODE IN CASE (1)
MOV =SCSTR,XL POINT TO /STRING/
JSR IDENT CHECK FOR MATCH
PPM SLOD4 JUMP IF MATCH
MOV (XS),XR ELSE RELOAD NAME
ADD WB,WB SET CODE FOR INTEGER (2)
MOV =SCINT,XL POINT TO /INTEGER/
JSR IDENT CHECK FOR MATCH
PPM SLOD4 JUMP IF MATCH
ICV WB ELSE SET CODE FOR REAL (3)
.IF .CNRA
.ELSE
MOV (XS),XR RELOAD STRING POINTER
MOV =SCREA,XL POINT TO /REAL/
JSR IDENT CHECK FOR MATCH
PPM SLOD4 JUMP IF MATCH
.FI
ICV WB SET CODE FOR BUFFER (4)
.IF .CNBF
.ELSE
MOV (XS),XR RELOAD STRING POINTER
MOV =SCBUF,XL POINT TO /BUFFER/
JSR IDENT CHECK FOR MATCH
PPM SLOD4 JUMP IF MATCH
.FI
ZER WB ELSE GET CODE FOR NO CONVERT
*
* MERGE HERE WITH PROPER DATATYPE CODE IN WB
*
SLOD4 MOV WB,(XS) STORE CODE ON STACK
BEQ WA,=NUM02,SLOD2 LOOP BACK IF ARG STOPPED BY COMMA
BZE WA,SLOD5 JUMP IF THAT WAS THE RESULT TYPE
*
* HERE WE SCAN OUT THE RESULT TYPE (ARG STOPPED BY ) )
*
MOV MXLEN,WC SET DUMMY (IMPOSSIBLE) DELIMITER 1
MOV WC,XL AND DELIMITER TWO
JSR XSCAN SCAN RESULT NAME
ZER WA SET CODE FOR PROCESSING RESULT
BRN SLOD3 JUMP BACK TO PROCESS RESULT NAME
EJC
*
* LOAD (CONTINUED)
*
* HERE AFTER PROCESSING ALL ARGS AND RESULT
*
SLOD5 MOV LODNA,WA GET NUMBER OF ARGUMENTS
MOV WA,WC COPY FOR LATER
WTB WA CONVERT LENGTH TO BAUS
ADD *EFSI$,WA ADD SPACE FOR STANDARD FIELDS
JSR ALLOC ALLOCATE EFBLK
MOV =B$EFC,(XR) SET TYPE WORD
MOV WC,FARGS(XR) SET NUMBER OF ARGUMENTS
ZER EFUSE(XR) SET USE COUNT (DFFNC WILL SET TO 1)
ZER EFCOD(XR) ZERO CODE POINTER FOR NOW
MOV (XS)+,EFRSL(XR) STORE RESULT TYPE CODE
MOV LODFN,EFVAR(XR) STORE FUNCTION VRBLK POINTER
MOV WA,EFLEN(XR) STORE EFBLK LENGTH
MOV XR,WB SAVE EFBLK POINTER
ADD WA,XR POINT PAST END OF EFBLK
LCT WC,WC SET NUMBER OF ARGUMENTS FOR LOOP
*
* LOOP TO SET ARGUMENT TYPE CODES FROM STACK
*
SLOD6 MOV (XS)+,-(XR) STORE ONE TYPE CODE FROM STACK
BCT WC,SLOD6 LOOP TILL ALL STORED
*
* NOW LOAD THE EXTERNAL FUNCTION AND PERFORM DEFINITION
*
MOV (XS)+,XR LOAD FUNCTION STRING NAME
MOV (XS),XL LOAD LIBRARY NAME
MOV WB,(XS) STORE EFBLK POINTER
JSR SYSLD CALL FUNCTION TO LOAD EXTERNAL FUNC
PPM EXFAL FAIL RETURN
PPM EROSI ERROR RETURN
MOV (XS)+,XL RECALL EFBLK POINTER
MOV XR,EFCOD(XL) STORE CODE POINTER
MOV LODFN,XR POINT TO VRBLK FOR FUNCTION
JSR DFFNC PERFORM FUNCTION DEFINITION
BRN EXNUL RETURN NULL RESULT
.FI
EJC
*
* LOCAL
*
S$LOC ENT ENTRY POINT
JSR GTSMI GET SECOND ARGUMENT (LOCAL NUMBER)
ERR 256,LOCAL SECOND ARGUMENT IS NOT INTEGER
PPM EXFAL FAIL IF OUT OF RANGE
MOV XR,WB SAVE LOCAL NUMBER
MOV (XS)+,XR LOAD FIRST ARGUMENT
JSR GTNVR POINT TO VRBLK
PPM SLOC1 JUMP IF NOT VARIABLE NAME
MOV VRFNC(XR),XR ELSE LOAD FUNCTION POINTER
BNE (XR),=B$PFC,SLOC1 JUMP IF NOT PROGRAM DEFINED
*
* HERE IF WE HAVE A PROGRAM DEFINED FUNCTION NAME
*
BZE WB,EXFAL FAIL IF SECOND ARG IS ZERO
BGT WB,PFNLO(XR),EXFAL OR TOO LARGE
ADD FARGS(XR),WB ELSE ADJUST OFFSET TO INCLUDE ARGS
WTB WB CONVERT TO BYTES
ADD WB,XR POINT TO LOCAL POINTER
MOV PFAGB(XR),XR LOAD VRBLK POINTER
BRN EXVNM EXIT BUILDING NMBLK
*
* HERE IF FIRST ARGUMENT IS NO GOOD
*
SLOC1 ERB 257,LOCAL FIRST ARG IS NOT A PROGRAM FUNCTION NAME
EJC
*
* LPAD
*
S$LPD ENT ENTRY POINT
JSR GTSTG GET PAD CHARACTER
ERR 148,LPAD THIRD ARGUMENT NOT A STRING
PLC XR POINT TO CHARACTER (NULL IS BLANK)
LCH WB,(XR) LOAD PAD CHARACTER
JSR GTSMI GET PAD LENGTH
ERR 149,LPAD SECOND ARGUMENT IS NOT INTEGER
PPM SLPD3 SKIP IF NEGATIVE OR LARGE
*
* MERGE TO CHECK FIRST ARG
*
SLPD1 JSR GTSTG GET FIRST ARGUMENT (STRING TO PAD)
ERR 150,LPAD FIRST ARGUMENT IS NOT STRING
BGE WA,WC,EXIXR RETURN 1ST ARG IF TOO LONG TO PAD
MOV XR,XL ELSE MOVE PTR TO STRING TO PAD
*
* NOW WE ARE READY FOR THE PAD
*
* (XL) POINTER TO STRING TO PAD
* (WB) PAD CHARACTER
* (WC) LENGTH TO PAD STRING TO
*
MOV WC,WA COPY LENGTH
JSR ALOCS ALLOCATE SCBLK FOR NEW STRING
MOV XR,-(XS) SAVE AS RESULT
MOV SCLEN(XL),WA LOAD LENGTH OF ARGUMENT
SUB WA,WC CALCULATE NUMBER OF PAD CHARACTERS
PSC XR POINT TO CHARS IN RESULT STRING
LCT WC,WC SET COUNTER FOR PAD LOOP
*
* LOOP TO PERFORM PAD
*
SLPD2 SCH WB,(XR)+ STORE PAD CHARACTER, BUMP PTR
BCT WC,SLPD2 LOOP TILL ALL PAD CHARS STORED
CSC XR COMPLETE STORE CHARACTERS
*
* NOW COPY STRING
*
BZE WA,EXITS EXIT IF NULL STRING
PLC XL ELSE POINT TO CHARS IN ARGUMENT
MVC MOVE CHARACTERS TO RESULT STRING
BRN EXITS JUMP FOR NEXT CODE WORD
*
* HERE IF 2ND ARG IS NEGATIVE OR LARGE
*
SLPD3 ZER WC ZERO PAD COUNT
BRN SLPD1 MERGE
EJC
*
* LT
*
S$LTF ENT ENTRY POINT
JSR ACOMP CALL ARITHMETIC COMPARISON ROUTINE
ERR 151,LT FIRST ARGUMENT IS NOT NUMERIC
ERR 152,LT SECOND ARGUMENT IS NOT NUMERIC
PPM EXNUL RETURN NULL IF LT
PPM EXFAL FAIL IF EQ
PPM EXFAL FAIL IF GT
EJC
*
* NE
*
S$NEF ENT ENTRY POINT
JSR ACOMP CALL ARITHMETIC COMPARISON ROUTINE
ERR 153,NE FIRST ARGUMENT IS NOT NUMERIC
ERR 154,NE SECOND ARGUMENT IS NOT NUMERIC
PPM EXNUL RETURN NULL IF LT
PPM EXFAL FAIL IF EQ
PPM EXNUL RETURN NULL IF GT
EJC
*
* NOTANY
*
S$NAY ENT ENTRY POINT
MOV =P$NAS,WB SET PCODE FOR SINGLE CHAR ARG
MOV =P$NAY,XL PCODE FOR MULTI-CHAR ARG
MOV =P$NAD,WC SET PCODE FOR EXPR ARG
JSR PATST CALL COMMON ROUTINE TO BUILD NODE
ERR 155,NOTANY ARGUMENT IS NOT STRING OR EXPRESSION
BRN EXIXR JUMP FOR NEXT CODE WORD
EJC
*
* OPSYN
*
S$OPS ENT ENTRY POINT
JSR GTSMI LOAD THIRD ARGUMENT
ERR 156,OPSYN THIRD ARGUMENT IS NOT INTEGER
ERR 157,OPSYN THIRD ARGUMENT IS NEGATIVE OR TOO LARGE
MOV WC,WB IF OK, SAVE THIRD ARGUMNET
MOV (XS)+,XR LOAD SECOND ARGUMENT
JSR GTNVR LOCATE VARIABLE BLOCK
ERR 158,OPSYN SECOND ARG IS NOT NATURAL VARIABLE NAME
MOV VRFNC(XR),XL IF OK, LOAD FUNCTION BLOCK POINTER
BNZ WB,SOPS2 JUMP IF OPERATOR OPSYN CASE
*
* HERE FOR FUNCTION OPSYN (THIRD ARG ZERO)
*
MOV (XS)+,XR LOAD FIRST ARGUMENT
JSR GTNVR GET VRBLK POINTER
ERR 159,OPSYN FIRST ARG IS NOT NATURAL VARIABLE NAME
*
* MERGE HERE TO PERFORM FUNCTION DEFINITION
*
SOPS1 JSR DFFNC CALL FUNCTION DEFINER
BRN EXNUL EXIT WITH NULL RESULT
*
* HERE FOR OPERATOR OPSYN (THIRD ARG NON-ZERO)
*
SOPS2 JSR GTSTG GET OPERATOR NAME
PPM SOPS5 JUMP IF NOT STRING
BNE WA,=NUM01,SOPS5 ERROR IF NOT ONE CHAR LONG
PLC XR ELSE POINT TO CHARACTER
LCH WC,(XR) LOAD CHARACTER NAME
EJC
*
* OPSYN (CONTINUED)
*
* NOW SET TO SEARCH FOR MATCHING UNARY OR BINARY OPERATOR
* NAME AS APPROPRIATE. NOTE THAT THERE ARE =OPBUN UNDEFINED
* BINARY OPERATORS AND =OPUUN UNDEFINED UNARY OPERATORS.
*
MOV =R$UUB,WA POINT TO UNOP POINTERS IN CASE
MOV =OPNSU,XR POINT TO NAMES OF UNARY OPERATORS
ADD =OPBUN,WB ADD NO. OF UNDEFINED BINARY OPS
BEQ WB,=OPUUN,SOPS3 JUMP IF UNOP (THIRD ARG WAS 1)
MOV =R$UBA,WA ELSE POINT TO BINARY OPERATOR PTRS
MOV =OPSNB,XR POINT TO NAMES OF BINARY OPERATORS
MOV =OPBUN,WB SET NUMBER OF UNDEFINED BINOPS
*
* MERGE HERE TO CHECK LIST (WB = NUMBER TO CHECK)
*
SOPS3 LCT WB,WB SET COUNTER TO CONTROL LOOP
*
* LOOP TO SEARCH FOR NAME MATCH
*
SOPS4 BEQ WC,(XR),SOPS6 JUMP IF NAMES MATCH
ICA WA ELSE PUSH POINTER TO FUNCTION PTR
ICA XR BUMP POINTER
BCT WB,SOPS4 LOOP BACK TILL ALL CHECKED
*
* HERE IF BAD OPERATOR NAME
*
SOPS5 ERB 160,OPSYN FIRST ARG IS NOT CORRECT OPERATOR NAME
*
* COME HERE ON FINDING A MATCH IN THE OPERATOR NAME TABLE
*
SOPS6 MOV WA,XR COPY POINTER TO FUNCTION BLOCK PTR
SUB *VRFNC,XR MAKE IT LOOK LIKE DUMMY VRBLK
BRN SOPS1 MERGE BACK TO DEFINE OPERATOR
EJC
*
* OUTPUT
*
S$OUP ENT ENTRY POINT
MOV =NUM02,WB OUTPUT FLAG
JSR IOPUT CALL INPUT/OUTPUT ASSOC. ROUTINE
ERR 161,OUTPUT THIRD ARGUMENT (FILEPROPS) IS NOT A STRING
ERR 162,INAPPROPRIATE SECOND ARGUMENT (FILETAG) FOR OUTPUT
ERR 163,INAPPROPRIATE FIRST ARGUMENT FOR OUTPUT
PPM EXFAL FAIL RETURN
BRN EXNUL RETURN NULL STRING
EJC
*
* POS
*
S$POS ENT ENTRY POINT
MOV =P$POS,WB SET PCODE FOR INTEGER ARG CASE
MOV =P$PSD,WA SET PCODE FOR EXPRESSION ARG CASE
JSR PATIN CALL COMMON ROUTINE TO BUILD NODE
ERR 164,POS ARGUMENT IS NOT INTEGER OR EXPRESSION
ERR 165,POS ARGUMENT IS NEGATIVE OR TOO LARGE
BRN EXIXR RETURN PATTERN NODE
EJC
*
* PROTOTYPE
*
S$PRO ENT ENTRY POINT
MOV (XS)+,XR LOAD ARGUMENT
MOV TBLEN(XR),WB LENGTH IF TABLE, VECTOR (=VCLEN)
BTW WB CONVERT TO WORDS
MOV (XR),WA LOAD TYPE WORD OF ARGUMENT BLOCK
BEQ WA,=B$ART,SPRO4 JUMP IF ARRAY
BEQ WA,=B$TBT,SPRO1 JUMP IF TABLE
BEQ WA,=B$VCT,SPRO3 JUMP IF VECTOR
.IF .CNBF
.ELSE
BEQ WA,=B$BCT,SPR05 JUMP IF BUFFER
.FI
ERB 166,PROTOTYPE ARGUMENT IS NOT TABLE OR ARRAY
*
* HERE FOR TABLE
*
SPRO1 SUB =TBSI$,WB SUBTRACT STANDARD FIELDS
*
* MERGE FOR VECTOR
*
SPRO2 MTI WB CONVERT TO INTEGER
BRN EXINT EXIT WITH INTEGER RESULT
*
* HERE FOR VECTOR
*
SPRO3 SUB =VCSI$,WB SUBTRACT STANDARD FIELDS
BRN SPRO2 MERGE
*
* HERE FOR ARRAY
*
SPRO4 ADD AROFS(XR),XR POINT TO PROTOTYPE FIELD
MOV (XR),XR LOAD PROTOTYPE
BRN EXIXR RETURN PROTOTYPE AS RESULT
.IF .CNBF
.ELSE
*
* HERE FOR BUFFER
*
SPR05 MOV BCBUF(XR),XR POINT TO BFBLK
MTI BFALC(XR) LOAD ALLOCATED LENGTH
BRN EXINT EXIT WITH INTEGER ALLOCATION
.FI
EJC
*
* REMDR
*
S$RMD ENT ENTRY POINT
ZER WB SET POSITIVE FLAG
MOV (XS),XR LOAD SECOND ARGUMENT
JSR GTINT CONVERT TO INTEGER
ERR 167,REMDR SECOND ARGUMENT IS NOT INTEGER
JSR ARITH CONVERT ARGS
PPM SRM01 FIRST ARG NOT INTEGER
PPM SECOND ARG CHECKED ABOVE
.IF .CNRA
.ELSE
PPM SRM01 FIRST ARG REAL
.FI
LDI ICVAL(XR) LOAD LEFT ARGUMENT VALUE
RMI ICVAL(XL) GET REMAINDER
INO EXINT JUMP IF NO OVERFLOW
ERB 168,REMDR CAUSED INTEGER OVERFLOW
*
* FAIL FIRST ARGUMENT
*
SRM01 ERB 169,REMDR FIRST ARGUMENT IS NOT INTEGER
EJC
*
* REPLACE
*
* THE ACTUAL REPLACE OPERATION USES AN SCBLK WHOSE CFP$A
* CHARS CONTAIN THE TRANSLATED VERSIONS OF ALL THE CHARS.
* THE TABLE POINTER IS REMEMBERED FROM CALL TO CALL AND
* THE TABLE IS ONLY BUILT WHEN THE ARGUMENTS CHANGE.
*
S$RPL ENT ENTRY POINT
JSR GTSTG LOAD THIRD ARGUMENT AS STRING
ERR 170,REPLACE THIRD ARGUMENT IS NOT STRING
MOV XR,XL SAVE THIRD ARG PTR
JSR GTSTG GET SECOND ARGUMENT
ERR 171,REPLACE SECOND ARGUMENT IS NOT STRING
*
* CHECK TO SEE IF THIS IS THE SAME TABLE AS LAST TIME
*
BNE XR,R$RA2,SRPL1 JUMP IF 2ND ARGUMENT DIFFERENT
BEQ XL,R$RA3,SRPL4 JUMP IF ARGS SAME AS LAST TIME
*
* HERE WE BUILD A NEW REPLACE TABLE (NOTE WA = 2ND ARG LEN)
*
SRPL1 MOV SCLEN(XL),WB LOAD 3RD ARGUMENT LENGTH
BNE WA,WB,SRPL5 JUMP IF ARGUMENTS NOT SAME LENGTH
BZE WB,SRPL5 JUMP IF NULL 2ND ARGUMENT
MOV XL,R$RA3 SAVE THIRD ARG FOR NEXT TIME IN
MOV XR,R$RA2 SAVE SECOND ARG FOR NEXT TIME IN
MOV KVALP,XL POINT TO ALPHABET STRING
MOV SCLEN(XL),WA LOAD ALPHABET SCBLK LENGTH
MOV R$RPT,XR POINT TO CURRENT TABLE (IF ANY)
BNZ XR,SRPL2 JUMP IF WE ALREADY HAVE A TABLE
*
* HERE WE ALLOCATE A NEW TABLE
*
JSR ALOCS ALLOCATE NEW TABLE
MOV WC,WA KEEP SCBLK LENGTH
MOV XR,R$RPT SAVE TABLE POINTER FOR NEXT TIME
*
* MERGE HERE WITH POINTER TO NEW TABLE BLOCK IN (XR)
*
SRPL2 CTB WA,SCSI$ COMPUTE LENGTH OF SCBLK
MVW COPY TO GET INITIAL TABLE VALUES
EJC
*
* REPLACE (CONTINUED)
*
* NOW WE MUST PLUG SELECTED ENTRIES AS REQUIRED. NOTE THAT
* WE ARE SHORT OF INDEX REGISTERS FOR THE FOLLOWING LOOP.
* HENCE THE NEED TO REPEATEDLY RE-INITIALISE CHAR PTR XL
*
MOV R$RA2,XL POINT TO SECOND ARGUMENT
LCT WB,WB NUMBER OF CHARS TO PLUG
ZER WC ZERO CHAR OFFSET
MOV R$RA3,XR POINT TO 3RD ARG
PLC XR GET CHAR PTR FOR 3RD ARG
*
* LOOP TO PLUG CHARS
*
SRPL3 MOV R$RA2,XL POINT TO 2ND ARG
PLC XL,WC POINT TO NEXT CHAR
ICV WC INCREMENT OFFSET
LCH WA,(XL) GET NEXT CHAR
MOV R$RPT,XL POINT TO TRANSLATE TABLE
PSC XL,WA CONVERT CHAR TO OFFSET INTO TABLE
LCH WA,(XR)+ GET TRANSLATED CHAR
SCH WA,(XL) STORE IN TABLE
CSC XL COMPLETE STORE CHARACTERS
BCT WB,SRPL3 LOOP TILL DONE
EJC
*
* REPLACE (CONTINUED)
*
* HERE TO PERFORM TRANSLATE
*
SRPL4 JSR GTSTG GET FIRST ARGUMENT
ERR 172,REPLACE FIRST ARGUMENT IS NOT STRING
BZE WA,EXNUL RETURN NULL IF NULL ARGUMENT
MOV XR,XL COPY POINTER
MOV WA,WC SAVE LENGTH
CTB WA,SCHAR GET SCBLK LENGTH
JSR ALLOC ALLOCATE SPACE FOR COPY
MOV XR,WB SAVE ADDRESS OF COPY
MVW MOVE SCBLK CONTENTS TO COPY
MOV R$RPT,XR POINT TO REPLACE TABLE
PLC XR POINT TO CHARS OF TABLE
MOV WB,XL POINT TO STRING TO TRANSLATE
PLC XL POINT TO CHARS OF STRING
MOV WC,WA SET NUMBER OF CHARS TO TRANSLATE
TRC PERFORM TRANSLATION
MOV WB,-(XS) STACK NEW STRING AS RESULT
BRN EXITS RETURN WITH RESULT ON STACK
*
* ERROR POINT
*
SRPL5 ERB 173,NULL OR UNEQUALLY LONG 2ND, 3RD ARGS TO REPLACE
EJC
*
* REVERSE
*
S$RVS ENT ENTRY POINT
JSR GTSTG LOAD STRING ARGUMENT
ERR 174,REVERSE ARGUMENT IS NOT STRING
BZE WA,EXIXR RETURN ARGUMENT IF NULL
MOV XR,XL ELSE SAVE POINTER TO STRING ARG
JSR ALOCS ALLOCATE SPACE FOR NEW SCBLK
MOV XR,-(XS) STORE SCBLK PTR ON STACK AS RESULT
PSC XR PREPARE TO STORE IN NEW SCBLK
PLC XL,WC POINT PAST LAST CHAR IN ARGUMENT
LCT WC,WC SET LOOP COUNTER
*
* LOOP TO MOVE CHARS IN REVERSE ORDER
*
SRVS1 LCH WB,-(XL) LOAD NEXT CHAR FROM ARGUMENT
SCH WB,(XR)+ STORE IN RESULT
BCT WC,SRVS1 LOOP TILL ALL MOVED
CSC XR COMPLETE STORE CHARACTERS
BRN EXITS AND THEN JUMP FOR NEXT CODE WORD
EJC
*
* RPAD
*
S$RPD ENT ENTRY POINT
JSR GTSTG GET PAD CHARACTER
ERR 175,RPAD THIRD ARGUMENT IS NOT STRING
PLC XR POINT TO CHARACTER (NULL IS BLANK)
LCH WB,(XR) LOAD PAD CHARACTER
JSR GTSMI GET PAD LENGTH
ERR 176,RPAD SECOND ARGUMENT IS NOT INTEGER
PPM SRPD3 SKIP IF NEGATIVE OR LARGE
*
* MERGE TO CHECK FIRST ARG.
*
SRPD1 JSR GTSTG GET FIRST ARGUMENT (STRING TO PAD)
ERR 177,RPAD FIRST ARGUMENT IS NOT STRING
BGE WA,WC,EXIXR RETURN 1ST ARG IF TOO LONG TO PAD
MOV XR,XL ELSE MOVE PTR TO STRING TO PAD
*
* NOW WE ARE READY FOR THE PAD
*
* (XL) POINTER TO STRING TO PAD
* (WB) PAD CHARACTER
* (WC) LENGTH TO PAD STRING TO
*
MOV WC,WA COPY LENGTH
JSR ALOCS ALLOCATE SCBLK FOR NEW STRING
MOV XR,-(XS) SAVE AS RESULT
MOV SCLEN(XL),WA LOAD LENGTH OF ARGUMENT
SUB WA,WC CALCULATE NUMBER OF PAD CHARACTERS
PSC XR POINT TO CHARS IN RESULT STRING
LCT WC,WC SET COUNTER FOR PAD LOOP
*
* COPY ARGUMENT STRING
*
BZE WA,SRPD2 JUMP IF ARGUMENT IS NULL
PLC XL ELSE POINT TO ARGUMENT CHARS
MVC MOVE CHARACTERS TO RESULT STRING
*
* LOOP TO SUPPLY PAD CHARACTERS
*
SRPD2 SCH WB,(XR)+ STORE PAD CHARACTER, BUMP PTR
BCT WC,SRPD2 LOOP TILL ALL PAD CHARS STORED
CSC XR COMPLETE CHARACTER STORING
BRN EXITS AND EXIT FOR NEXT WORD
*
* HERE IF 2ND ARG IS NEGATIVE OR LARGE
*
SRPD3 ZER WC ZERO PAD COUNT
BRN SRPD1 MERGE
EJC
*
* RTAB
*
S$RTB ENT ENTRY POINT
MOV =P$RTB,WB SET PCODE FOR INTEGER ARG CASE
MOV =P$RTD,WA SET PCODE FOR EXPRESSION ARG CASE
JSR PATIN CALL COMMON ROUTINE TO BUILD NODE
ERR 178,RTAB ARGUMENT IS NOT INTEGER OR EXPRESSION
ERR 179,RTAB ARGUMENT IS NEGATIVE OR TOO LARGE
BRN EXIXR RETURN PATTERN NODE
EJC
.IF .CUST
*
* SET
*
S$SET ENT ENTRY POINT
MOV (XS)+,R$IOL SAVE THIRD ARG
MOV (XS)+,R$IO1 SAVE SECOND ARG
JSR IOFTG CALL IOTAG ROUTINE
ERR 180,SET FIRST ARGUMENT IS NOT A SUITABLE NAME
BZE WA,EXFAL FAIL IF NO IOTAG
MOV R$IO1,WB LOAD SECOND ARG
MOV R$IOL,WC LOAD THIRD ARG
JSR SYSST CALL SYSTEM SET ROUTINE
PPM EXFAL FAILURE RETURN
PPM EROSI ERROR RETURN
BRN EXNUL OTHERWISE RETURN NULL
EJC
.FI
*
* RPOS
*
S$RPS ENT ENTRY POINT
MOV =P$RPS,WB SET PCODE FOR INTEGER ARG CASE
MOV =P$RPD,WA SET PCODE FOR EXPRESSION ARG CASE
JSR PATIN CALL COMMON ROUTINE TO BUILD NODE
ERR 181,RPOS ARGUMENT IS NOT INTEGER OR EXPRESSION
ERR 182,RPOS ARGUMENT IS NEGATIVE OR TOO LARGE
BRN EXIXR RETURN PATTERN NODE
.IF .CNSR
.ELSE
EJC
*
* RSORT
*
S$RSR ENT ENTRY POINT
MNZ WA MARK AS RSORT
JSR SORTA CALL SORT ROUTINE
PPM EXFAL FAIL EMPTY TABLE
BRN EXSID RETURN, SETTING IDVAL
.FI
EJC
*
* SETEXIT
*
S$STX ENT ENTRY POINT
MOV (XS)+,XR LOAD ARGUMENT
MOV STXVR,WA LOAD OLD VRBLK POINTER
ZER XL LOAD ZERO IN CASE NULL ARG
BEQ XR,=NULLS,SSTX1 JUMP IF NULL ARGUMENT (RESET CALL)
JSR GTNVR ELSE GET SPECIFIED VRBLK
PPM SSTX2 JUMP IF NOT NATURAL VARIABLE
MOV VRLBL(XR),XL ELSE LOAD LABEL
BEQ XL,=STNDL,SSTX2 JUMP IF LABEL IS NOT DEFINED
BNE (XL),=B$TRT,SSTX1 JUMP IF NOT TRAPPED
MOV TRLBL(XL),XL ELSE LOAD PTR TO REAL LABEL CODE
*
* HERE TO SET/RESET SETEXIT TRAP
*
SSTX1 MOV XR,STXVR STORE NEW VRBLK POINTER (OR NULL)
MOV XL,R$SXC STORE NEW CODE PTR (OR ZERO)
BEQ WA,=NULLS,EXNUL RETURN NULL IF NULL RESULT
MOV WA,XR ELSE COPY VRBLK POINTER
BRN EXVNM AND RETURN BUILDING NMBLK
*
* HERE IF BAD ARGUMENT
*
SSTX2 ERB 183,SETEXIT ARGUMENT IS NOT LABEL NAME OR NULL
.IF .CNSR
.ELSE
EJC
*
* SORT
*
S$SRT ENT ENTRY POINT
ZER WA MARK AS SORT
JSR SORTA CALL SORT ROUTINE
PPM EXFAL FAIL EMPTY TABLE
BRN EXSID RETURN, SETTING IDVAL
.FI
EJC
*
* SPAN
*
S$SPN ENT ENTRY POINT
MOV =P$SPS,WB SET PCODE FOR SINGLE CHAR ARG
MOV =P$SPN,XL SET PCODE FOR MULTI-CHAR ARG
MOV =P$SPD,WC SET PCODE FOR EXPRESSION ARG
JSR PATST CALL COMMON ROUTINE TO BUILD NODE
ERR 184,SPAN ARGUMENT IS NOT STRING OR EXPRESSION
BRN EXIXR JUMP FOR NEXT CODE WORD
EJC
*
* SIZE
*
S$SI$ ENT ENTRY POINT
.IF .CNBF
JSR GTSTG LOAD STRING ARGUMENT
.ELSE
MOV (XS),XR LOAD ARGUMENT
BNE (XR),=B$BCT,SSI$1 BRANCH IF NOT BUFFER
ICA XS ELSE POP ARGUMENT
MTI BCLEN(XR) LOAD DEFINED LENGTH
BRN EXINT EXIT WITH INTEGER
*
* HERE IF NOT BUFFER
*
SSI$1 JSR GTSTG LOAD STRING ARGUMENT
.FI
ERR 185,SIZE ARGUMENT IS NOT STRING
MTI WA LOAD LENGTH AS INTEGER
BRN EXINT EXIT WITH INTEGER RESULT
EJC
*
* STOPTR
*
S$STT ENT ENTRY POINT
ZER XL INDICATE STOPTR CASE
JSR TRACE CALL TRACE PROCEDURE
ERR 186,STOPTR FIRST ARGUMENT IS NOT APPROPRIATE NAME
ERR 187,STOPTR SECOND ARGUMENT IS NOT TRACE TYPE
PPM EXFAL FAIL RETURN
BRN EXNUL RETURN NULL
EJC
*
* SUBSTR
*
S$SUB ENT ENTRY POINT
JSR GTSMI LOAD THIRD ARGUMENT
ERR 188,SUBSTR THIRD ARGUMENT IS NOT INTEGER
PPM EXFAL JUMP IF NEGATIVE OR TOO LARGE
MOV XR,SBSSV SAVE THIRD ARGUMENT
JSR GTSMI LOAD SECOND ARGUMENT
ERR 189,SUBSTR SECOND ARGUMENT IS NOT INTEGER
PPM EXFAL JUMP IF OUT OF RANGE
MOV XR,WB SAVE SECOND ARGUMENT
BZE WB,EXFAL JUMP IF SECOND ARGUMENT ZERO
DCV WB ELSE DECREMENT FOR ONES ORIGIN
.IF .CNBF
JSR GTSTG LOAD FIRST ARGUMENT
.ELSE
MOV (XS),XL GET FIRST ARG PTR
BNE (XL),=B$BCT,SSUBA BRANCH IF NOT BUFFER
MOV BCBUF(XL),XR GET BFBLK PTR
MOV BCLEN(XL),WA GET LENGTH
BRN SSUBB MERGE
*
* HERE IF NOT BUFFER TO GET STRING
*
SSUBA JSR GTSTG LOAD FIRST ARGUMENT
.FI
ERR 190,SUBSTR FIRST ARGUMENT IS NOT STRING
MOV XR,XL COPY POINTER TO FIRST ARG
.IF .CNBF
MOV SBSSV,WC RELOAD THIRD ARGUMENT
.ELSE
*
* MERGE WITH BFBLK OR SCBLK IN XR, LENGTH IN WA
*
SSUBB MOV SBSSV,WC RELOAD THIRD ARGUMENT
.FI
BNZ WC,SSUB1 SKIP IF THIRD ARG GIVEN
MOV SCLEN(XL),WC ELSE GET STRING LENGTH
BGT WB,WC,EXFAL FAIL IF IMPROPER
SUB WB,WC REDUCE BY OFFSET TO START
*
* MERGE
*
SSUB1 MOV WC,WA SET LENGTH OF SUBSTRING
ADD WB,WC ADD 2ND ARG TO 3RD ARG
BGT WC,SCLEN(XL),EXFAL JUMP IF IMPROPER SUBSTRING
JSR SBSTR BUILD SUBSTRING
BRN EXIXR AND JUMP FOR NEXT CODE WORD
EJC
*
* TAB
*
S$TAB ENT ENTRY POINT
MOV =P$TAB,WB SET PCODE FOR INTEGER ARG CASE
MOV =P$TBD,WA SET PCODE FOR EXPRESSION ARG CASE
JSR PATIN CALL COMMON ROUTINE TO BUILD NODE
ERR 191,TAB ARGUMENT IS NOT INTEGER OR EXPRESSION
ERR 192,TAB ARGUMENT IS NEGATIVE OR TOO LARGE
BRN EXIXR RETURN PATTERN NODE
EJC
*
* TABLE
*
S$TBL ENT ENTRY POINT
MOV (XS)+,XL GET INITIAL LOOKUP VALUE
ICA XS POP SECOND ARGUMENT
JSR GTSMI LOAD ARGUMENT
ERR 193,TABLE ARGUMENT IS NOT INTEGER
ERR 194,TABLE ARGUMENT IS OUT OF RANGE
BNZ WC,STBL1 JUMP IF NON-ZERO
MOV =TBNBK,WC ELSE SUPPLY DEFAULT VALUE
*
* MERGE HERE WITH NUMBER OF HEADERS IN WA
*
STBL1 MOV WC,WA COPY NUMBER OF HEADERS
ADD =TBSI$,WA ADJUST FOR STANDARD FIELDS
WTB WA CONVERT LENGTH TO BAUS
JSR ALLOC ALLOCATE SPACE FOR TBBLK
MOV XR,WB COPY POINTER TO TBBLK
MOV =B$TBT,(XR)+ STORE TYPE WORD
ZER (XR)+ ZERO ID FOR THE MOMENT
MOV WA,(XR)+ STORE LENGTH (TBLEN)
MOV XL,(XR)+ STORE INITIAL LOOKUP VALUE
LCT WC,WC SET LOOP COUNTER (NUM HEADERS)
*
* LOOP TO INITIALIZE ALL BUCKET POINTERS
*
STBL2 MOV WB,(XR)+ STORE TBBLK PTR IN BUCKET HEADER
BCT WC,STBL2 LOOP TILL ALL STORED
MOV WB,XR RECALL POINTER TO TBBLK
BRN EXSID EXIT SETTING IDVAL
EJC
*
* TIME
*
S$TIM ENT ENTRY POINT
JSR SYSTM GET TIMER VALUE
SBI TIMSX SUBTRACT STARTING TIME
BRN EXINT EXIT WITH INTEGER VALUE
EJC
*
* TRACE
*
S$TRA ENT ENTRY POINT
BEQ 3(XS),=NULLS,STR03 JUMP IF FIRST ARGUMENT IS NULL
MOV (XS)+,XR LOAD FOURTH ARGUMENT
ZER XL TENTATIVELY SET ZERO POINTER
BEQ XR,=NULLS,STR02 JUMP IF 4TH ARGUMENT IS NULL
JSR GTNVR ELSE POINT TO VRBLK
PPM STR01 JUMP IF NOT VARIABLE NAME
MOV VRFNC(XR),XL ELSE LOAD FUNCTION POINTER
BNE XL,=STNDF,STR02 JUMP IF FUNCTION IS DEFINED
*
* HERE FOR BAD FOURTH ARGUMENT
*
STR01 ERB 195,TRACE FOURTH ARG IS NOT FUNCTION NAME OR NULL
*
* HERE WITH FUNCTION POINTER IN XL
*
STR02 MOV (XS)+,XR LOAD THIRD ARGUMENT (TAG)
ZER WB SET ZERO AS TRTYP VALUE FOR NOW
JSR TRBLD BUILD TRBLK FOR TRACE CALL
MOV XR,XL MOVE TRBLK POINTER FOR TRACE
JSR TRACE CALL TRACE PROCEDURE
ERR 196,TRACE FIRST ARGUMENT IS NOT APPROPRIATE NAME
ERR 197,TRACE SECOND ARGUMENT IS NOT TRACE TYPE
PPM UNUSED RETURN
BRN EXNUL RETURN NULL
*
* HERE TO CALL SYSTEM TRACE TOGGLE ROUTINE
*
STR03 JSR SYSTT CALL IT
ADD *NUM04,XS POP TRACE ARGUMENTS
BRN EXNUL RETURN
EJC
*
* TRIM
*
S$TRM ENT ENTRY POINT
JSR GTSTG LOAD ARGUMENT AS STRING
ERR 198,TRIM ARGUMENT IS NOT STRING
BZE WA,EXNUL RETURN NULL IF ARGUMENT IS NULL
MOV XR,XL COPY STRING POINTER
CTB WA,SCHAR GET BLOCK LENGTH
JSR ALLOC ALLOCATE COPY SAME SIZE
MOV XR,WB SAVE POINTER TO COPY
MVW COPY OLD STRING BLOCK TO NEW
MOV WB,XR RESTORE PTR TO NEW BLOCK
JSR TRIMR TRIM BLANKS (WB IS NON-ZERO)
BRN EXIXR EXIT WITH RESULT IN XR
EJC
*
* UNLOAD
*
S$UNL ENT ENTRY POINT
MOV (XS)+,XR LOAD ARGUMENT
JSR GTNVR POINT TO VRBLK
ERR 199,UNLOAD ARGUMENT IS NOT NATURAL VARIABLE NAME
MOV =STNDF,XL GET PTR TO UNDEFINED FUNCTION
JSR DFFNC UNDEFINE NAMED FUNCTION
BRN EXNUL RETURN NULL AS RESULT
EJC
*
* VDIFFER
*
S$VDF ENT ENTRY POINT
MOV (XS)+,XR LOAD SECOND ARGUMENT
MOV (XS),XL LOAD FIRST ARGUMENT
JSR IDENT CALL IDENT COMPARISON ROUTINE
PPM EXFAL FAIL IF IDENT
BRN EXITS RETURN FIRST ARG IF DIFFER
TTL S P I T B O L -- UTILITY PROCEDURES
*
* THE FOLLOWING SECTION CONTAINS PROCEDURES WHICH ARE
* USED FOR VARIOUS PURPOSES THROUGHOUT THE SYSTEM.
*
* EACH PROCEDURE IS PRECEDED BY A DESCRIPTION OF THE
* CALLING SEQUENCE. USUALLY THE ARGUMENTS ARE IN REGISTERS
* BUT ARGUMENTS CAN ALSO OCCUR ON THE STACK AND AS
* PARAMETERS ASSEMBLED AFTER THE JSR INSTRUCTION.
*
* THE FOLLOWING CONSIDERATIONS APPLY TO THESE DESCRIPTIONS.
*
* 1) THE STACK POINTER (XS) IS NOT CHANGED UNLESS THE
* CHANGE IS EXPLICITLY DOCUMENTED IN THE CALL.
*
* 2) REGISTERS WHOSE ENTRY VALUES ARE NOT MENTIONED
* MAY CONTAIN ANY VALUE EXCEPT THAT XL,XR MAY ONLY
* CONTAIN PROPER (COLLECTABLE) POINTER VALUES.
* THIS CONDITION ON XR MEANS THAT THE CALLED ROUTINE
* MAY IF IT CHOOSES PRESERVE XR BY STACKING.
*
* 3) REGISTERS NOT MENTIONED ON EXIT CONTAIN THE SAME
* VALUES AS THEY DID ON ENTRY EXCEPT THAT VALUES IN
* XR,XL MAY HAVE BEEN RELOCATED BY THE COLLECTOR.
*
* 4) REGISTERS WHICH ARE DESTROYED ON EXIT MAY CONTAIN
* ANY VALUE EXCEPT THAT VALUES IN XL,XR ARE PROPER
* (COLLECTABLE) POINTERS.
*
* 5) THE CODE POINTER REGISTER POINTS TO THE CURRENT
* CODE LOCATION ON ENTRY AND IS UNCHANGED ON EXIT.
*
* IN THE ABOVE DESCRIPTION, A COLLECTABLE POINTER IS ONE
* WHICH EITHER POINTS OUTSIDE THE DYNAMIC REGION OR
* POINTS TO THE START OF A BLOCK IN THE DYNAMIC REGION.
*
* IN THOSE CASES WHERE THE CALLING SEQUENCE CONTAINS
* PARAMETERS WHICH ARE USED AS ALTERNATE RETURN POINTS,
* THESE PARAMETERS MAY BE REPLACED BY ERROR CODES
* ASSEMBLED WITH THE ERR INSTRUCTION. THIS WILL RESULT
* IN THE POSTING OF THE ERROR IF THE RETURN IS TAKEN.
*
* THE PROCEDURES ALL HAVE NAMES CONSISTING OF FIVE LETTERS
* AND ARE IN ALPHABETICAL ORDER BY THEIR NAMES.
EJC
*
* ACESS - ACCESS VARIABLE VALUE WITH TRACE/INPUT CHECKS
*
* ACESS LOADS THE VALUE OF A VARIABLE. TRACE AND INPUT
* ASSOCIATIONS ARE TESTED FOR AND EXECUTED AS REQUIRED.
* ACESS ALSO HANDLES THE SPECIAL CASES OF PSEUDO-VARIABLES.
*
* (XL) VARIABLE NAME BASE
* (WA) VARIABLE NAME OFFSET
* JSR ACESS CALL TO ACCESS VALUE
* PPM LOC TRANSFER LOC IF ACCESS FAILURE
* (XR) VARIABLE VALUE
* (WA,WB,WC) DESTROYED
* (XL,RA) DESTROYED
*
* FAILURE CAN OCCUR IF AN INPUT ASSOCIATION CAUSES AN END
* OF FILE CONDITION OR IF THE EVALUATION OF AN EXPRESSION
* ASSOCIATED WITH AN EXPRESSION VARIABLE FAILS.
*
ACESS PRC R,1 ENTRY POINT (RECURSIVE)
MOV XL,XR COPY NAME BASE
ADD WA,XR POINT TO VARIABLE LOCATION
MOV (XR),XR LOAD VARIABLE VALUE
*
* LOOP HERE TO CHECK FOR SUCCESSIVE TRBLKS
*
ACS02 BNE (XR),=B$TRT,ACS18 JUMP IF NOT TRAPPED
*
* HERE IF TRAPPED
*
BEQ XR,=TRBKV,ACS12 JUMP IF KEYWORD VARIABLE
BNE XR,=TRBEV,ACS05 JUMP IF NOT EXPRESSION VARIABLE
*
* HERE FOR EXPRESSION VARIABLE, EVALUATE VARIABLE
*
MOV EVEXP(XL),XR LOAD EXPRESSION POINTER
ZER WB EVALUATE BY VALUE
JSR EVALX EVALUATE EXPRESSION
PPM ACS04 JUMP IF EVALUATION FAILURE
BRN ACS02 CHECK VALUE FOR MORE TRBLKS
EJC
*
* ACESS (CONTINUED)
*
* HERE ON READING END OF FILE
*
ACS03 ADD *NUM03,XS POP TRBLK PTR, NAME BASE AND OFFSET
MOV XR,DNAMP POP UNUSED SCBLK
*
* MERGE HERE WHEN EVALUATION OF EXPRESSION FAILS
*
ACS04 EXI 1 TAKE ALTERNATE (FAILURE) RETURN
*
* HERE IF NOT KEYWORD OR EXPRESSION VARIABLE
*
ACS05 MOV TRTYP(XR),WB LOAD TRAP TYPE CODE
BNZ WB,ACS10 JUMP IF NOT INPUT ASSOCIATION
BZE KVINP,ACS09 IGNORE INPUT ASSOC IF INPUT IS OFF
*
* HERE FOR INPUT ASSOCIATION
*
MOV XL,-(XS) STACK NAME BASE
MOV WA,-(XS) STACK NAME OFFSET
MOV XR,-(XS) STACK TRBLK POINTER
MOV TRTRI(XR),XL GET TRTIO BLOCK PTR OR 0
BNZ XL,ACS06 JUMP IF NOT STANDARD INPUT FILE
BEQ TRTER(XR),=V$TER,ACS21 JUMP IF TERMINAL
*
* HERE TO READ FROM STANDARD INPUT FILE
*
MOV CSWIN,WA LENGTH FOR READ BUFFER
JSR ALOCS BUILD STRING OF APPROPRIATE LENGTH
BZE TTINS,ACSA5 SKIP IF NOT TERML STD INPUT
JSR SYSRI READ FROM TERMINAL
PPM ACS03 END FILE
PPM EROSI ERROR
BRN ACS07 MERGE
*
* GENUINE STD INPUT FILE
*
ACSA5 JSR SYSRD READ NEXT STANDARD INPUT IMAGE
PPM ACS03 JUMP TO FAIL EXIT IF END OF FILE
PPM EROSI ERROR RETURN
BRN ACS07 ELSE MERGE WITH OTHER FILE CASE
*
* HERE FOR INPUT FROM OTHER THAN STANDARD INPUT FILE
*
ACS06 MOV TRTAG(XL),WA OBTAIN IOTAG
BZE WA,ACS03 FAIL IF ENDFILE DONE
JSR SYSIL GET INPUT RECORD MAX LENGTH (TO WA)
JSR ALOCS ALLOCATE STRING OF CORRECT SIZE
MOV TRTAG(XL),WA GET IOTAG
JSR SYSIN CALL SYSTEM INPUT ROUTINE
PPM ACS03 JUMP TO FAIL EXIT IF END OF FILE
PPM ACS22 ERROR RETURN
EJC
*
* ACESS (CONTINUED)
*
* MERGE HERE AFTER OBTAINING INPUT RECORD
*
ACS07 MOV KVTRM,WB LOAD TRIM INDICATOR
JSR TRIMR TRIM RECORD AS REQUIRED
MOV XR,WB COPY RESULT POINTER
MOV (XS),XR RELOAD POINTER TO TRBLK
*
* LOOP TO CHASE TO END OF TRBLK CHAIN AND STORE VALUE
*
ACS08 MOV XR,XL SAVE POINTER TO THIS TRBLK
MOV TRNXT(XR),XR LOAD FORWARD POINTER
BEQ (XR),=B$TRT,ACS08 LOOP IF THIS IS ANOTHER TRBLK
MOV WB,TRNXT(XL) ELSE STORE RESULT AT END OF CHAIN
MOV (XS)+,XR RESTORE INITIAL TRBLK POINTER
MOV (XS)+,WA RESTORE NAME OFFSET
MOV (XS)+,XL RESTORE NAME BASE POINTER
*
* COME HERE TO MOVE TO NEXT TRBLK
*
ACS09 MOV TRNXT(XR),XR LOAD FORWARD PTR TO NEXT VALUE
BRN ACS02 BACK TO CHECK IF TRAPPED
*
* HERE TO CHECK FOR ACCESS TRACE TRBLK
*
ACS10 BNE WB,=TRTAC,ACS09 LOOP BACK IF NOT ACCESS TRACE
BZE KVTRA,ACS09 IGNORE ACCESS TRACE IF TRACE OFF
DCV KVTRA ELSE DECREMENT TRACE COUNT
BZE TRFNC(XR),ACS11 JUMP IF PRINT TRACE
EJC
*
* ACESS (CONTINUED)
*
* HERE FOR FULL FUNCTION TRACE
*
JSR TRXEQ CALL ROUTINE TO EXECUTE TRACE
BRN ACS09 JUMP FOR NEXT TRBLK
*
* HERE FOR CASE OF PRINT TRACE
*
ACS11 JSR PRTSN PRINT STATEMENT NUMBER
JSR PRTNV PRINT NAME = VALUE
BRN ACS09 JUMP BACK FOR NEXT TRBLK
*
* HERE FOR KEYWORD VARIABLE
*
ACS12 MOV KVNUM(XL),XR LOAD KEYWORD NUMBER
BGE XR,=K$V$$,ACS14 JUMP IF NOT ONE WORD VALUE
MTI KVANC(XR) ELSE LOAD VALUE AS INTEGER
*
* COMMON EXIT WITH KEYWORD VALUE AS INTEGER IN (IA)
*
ACS13 JSR ICBLD BUILD ICBLK
BRN ACS18 JUMP TO EXIT
*
* HERE IF NOT ONE WORD KEYWORD VALUE
*
ACS14 BGE XR,=K$S$$,ACS15 JUMP IF SPECIAL CASE
SUB =K$V$$,XR ELSE GET OFFSET
WTB XR CONVERT TO OFFSET IN BAUS
ADD =NDABO,XR POINT TO PATTERN VALUE
BRN ACS18 JUMP TO EXIT
*
* HERE IF SPECIAL KEYWORD CASE
*
ACS15 MOV KVRTN,XL LOAD RTNTYPE IN CASE
LDI KVSTL LOAD STLIMIT IN CASE
SUB =K$S$$,XR GET CASE NUMBER
BSW XR,6 SWITCH ON KEYWORD NUMBER
IFF K$$AL,ACS16 JUMP IF ALPHABET
IFF K$$RT,ACS17 RTNTYPE
IFF K$$CD,ACS23 CODE
IFF K$$SC,ACS19 STCOUNT
IFF K$$SL,ACS13 STLIMIT
IFF K$$ET,ACS20 ERRTEXT
ESW END SWITCH ON KEYWORD NUMBER
EJC
*
* ACESS (CONTINUED)
*
* ALPHABET
*
ACS16 MOV KVALP,XL LOAD POINTER TO ALPHABET STRING
*
* RTNTYPE MERGES HERE
*
ACS17 MOV XL,XR COPY STRING PTR TO PROPER REG
*
* COMMON RETURN POINT
*
ACS18 EXI RETURN TO ACESS CALLER
*
* HERE FOR STCOUNT (IA HAS STLIMIT)
*
ACS19 SBI KVSTC STCOUNT = LIMIT - LEFT
BRN ACS13 MERGE BACK WITH INTEGER RESULT
*
* ERRTEXT
*
ACS20 MOV R$ETX,XR GET ERRTEXT STRING
BRN ACS18 MERGE WITH RESULT
*
* HERE TO READ A RECORD FROM TERMINAL
*
ACS21 MOV =RILEN,WA BUFFER LENGTH
JSR ALOCS ALLOCATE BUFFER
JSR SYSRI READ RECORD
PPM ACS03 ENDFILE
PPM EROSI ERROR RETURN
BRN ACS07 MERGE WITH RECORD READ
*
* ERROR RETURN
*
ACS22 MOV XR,DNAMP POP UNUSED SCBLK
BRN EROSI GENERATE ERROR MESSAGE
*
* ACCESS CODE KEYWORD
*
ACS23 LDI KVCOD GET CODE VALUE
BRN ACS13 EXIT
ENP END PROCEDURE ACESS
EJC
*
* ACOMP -- COMPARE TWO ARITHMETIC VALUES
*
* 1(XS) FIRST ARGUMENT
* 0(XS) SECOND ARGUMENT
* JSR ACOMP CALL TO COMPARE VALUES
* PPM LOC TRANSFER LOC IF ARG1 IS NON-NUMERIC
* PPM LOC TRANSFER LOC IF ARG2 IS NON-NUMERIC
* PPM LOC TRANSFER LOC FOR ARG1 LT ARG2
* PPM LOC TRANSFER LOC FOR ARG1 EQ ARG2
* PPM LOC TRANSFER LOC FOR ARG1 GT ARG2
* (NORMAL RETURN IS NEVER GIVEN)
* (WA,WB,WC,IA,RA) DESTROYED
* (XL,XR) DESTROYED
*
ACOMP PRC N,5 ENTRY POINT
JSR ARITH LOAD ARITHMETIC OPERANDS
PPM ACMP7 JUMP IF FIRST ARG NON-NUMERIC
PPM ACMP8 JUMP IF SECOND ARG NON-NUMERIC
.IF .CNRA
.ELSE
PPM ACMP4 JUMP IF REAL ARGUMENTS
.FI
*
* HERE FOR INTEGER ARGUMENTS
*
SBI ICVAL(XL) SUBTRACT TO COMPARE
IOV ACMP3 JUMP IF OVERFLOW
ILT ACMP5 ELSE JUMP IF ARG1 LT ARG2
IEQ ACMP2 JUMP IF ARG1 EQ ARG2
*
* HERE IF ARG1 GT ARG2
*
ACMP1 EXI 5 TAKE GT EXIT
*
* HERE IF ARG1 EQ ARG2
*
ACMP2 EXI 4 TAKE EQ EXIT
EJC
*
* ACOMP (CONTINUED)
*
* HERE FOR INTEGER OVERFLOW ON SUBTRACT
*
ACMP3 LDI ICVAL(XL) LOAD SECOND ARGUMENT
ILT ACMP1 GT IF NEGATIVE
BRN ACMP5 ELSE LT
.IF .CNRA
.ELSE
*
* HERE FOR REAL OPERANDS
*
ACMP4 SBR RCVAL(XL) SUBTRACT TO COMPARE
ROV ACMP6 JUMP IF OVERFLOW
RGT ACMP1 ELSE JUMP IF ARG1 GT
REQ ACMP2 JUMP IF ARG1 EQ ARG2
.FI
*
* HERE IF ARG1 LT ARG2
*
ACMP5 EXI 3 TAKE LT EXIT
.IF .CNRA
.ELSE
*
* HERE IF OVERFLOW ON REAL SUBTRACTION
*
ACMP6 LDR RCVAL(XL) RELOAD ARG2
RLT ACMP1 GT IF NEGATIVE
BRN ACMP5 ELSE LT
.FI
*
* HERE IF ARG1 NON-NUMERIC
*
ACMP7 EXI 1 TAKE ERROR EXIT
*
* HERE IF ARG2 NON-NUMERIC
*
ACMP8 EXI 2 TAKE ERROR EXIT
ENP END PROCEDURE ACOMP
EJC
*
* ALLOC ALLOCATE BLOCK OF DYNAMIC STORAGE
*
* (WA) LENGTH REQUIRED IN BAUS
* JSR ALLOC CALL TO ALLOCATE BLOCK
* (XR) POINTER TO ALLOCATED BLOCK
*
* A POSSIBLE ALTERNATIVE TO AOV .. AND FOLLOWING STMT IS -
* MOV DNAME,XR . SUB WA,XR . BLO XR,DNAMP,ALOC2 .
* MOV DNAMP,XR . ADD WA,XR
*
ALLOC PRC E,0 ENTRY POINT
*
* COMMON EXIT POINT
*
ALOC1 MOV DNAMP,XR POINT TO NEXT AVAILABLE LOC
AOV WA,XR,ALOC2 POINT PAST ALLOCATED BLOCK
BGT XR,DNAME,ALOC2 JUMP IF NOT ENOUGH ROOM
MOV XR,DNAMP STORE NEW POINTER
SUB WA,XR POINT BACK TO START OF ALLOCATED BK
EXI RETURN TO CALLER
*
* HERE IF INSUFFICIENT ROOM, TRY A GARBAGE COLLECTION
*
ALOC2 MOV WB,ALLSV SAVE WB
ZER WB SET NO UPWARD MOVE FOR GBCOL
JSR GBCOL GARBAGE COLLECT
*
* SEE IF ROOM AFTER GBCOL OR SYSMM CALL
*
ALOC3 MOV DNAMP,XR POINT TO FIRST AVAILABLE LOC
AOV WA,XR,ALC3A POINT PAST NEW BLOCK
BLO XR,DNAME,ALOC4 JUMP IF THERE IS ROOM NOW
*
* FAILED AGAIN, SEE IF WE CAN GET MORE CORE
*
ALC3A JSR SYSMM TRY TO GET MORE MEMORY
WTB XR CONVERT TO BAUS
ADD XR,DNAME BUMP PTR BY AMOUNT OBTAINED
BNZ XR,ALOC3 JUMP IF GOT MORE CORE
ADD RSMEM,DNAME GET THE RESERVE MEMORY
ZER RSMEM ONLY PERMISSIBLE ONCE
ICV ERRFT FATAL ERROR
ERB 200,MEMORY OVERFLOW
EJC
*
* HERE AFTER SUCCESSFUL GARBAGE COLLECTION
*
ALOC4 STI ALLIA SAVE IA
MOV DNAME,WB GET DYNAMIC END ADRS
SUB DNAMP,WB COMPUTE FREE STORE
BTW WB CONVERT BAUS TO WORDS
MTI WB PUT FREE STORE IN IA
MLI ALFSF MULTIPLY BY FREE STORE FACTOR
IOV ALOC5 JUMP IF OVERFLOWED
MOV DNAME,WB DYNAMIC END ADRS
SUB DNAMB,WB COMPUTE TOTAL AMOUNT OF DYNAMIC
BTW WB CONVERT TO WORDS
MOV WB,ALDYN STORE IT
SBI ALDYN SUBTRACT FROM SCALED UP FREE STORE
IGT ALOC5 JUMP IF SUFFICIENT FREE STORE
JSR SYSMM TRY TO GET MORE STORE
WTB XR CONVERT TO BAUS
ADD XR,DNAME ADJUST DYNAMIC END ADRS
*
* MERGE TO RESTORE IA AND WB
*
ALOC5 LDI ALLIA RECOVER IA
MOV ALLSV,WB RESTORE WB
BRN ALOC1 JUMP BACK TO EXIT
ENP END PROCEDURE ALLOC
EJC
.IF .CNBF
.ELSE
*
* ALOBF -- ALLOCATE BUFFER
*
* THIS ROUTINES ALLOCATES A NEW BUFFER. AS THE BFBLK
* AND BCBLK COME IN PAIRS, BOTH ARE ALLOCATED HERE,
* AND XR POINTS TO THE BCBLK ON RETURN. THE BFBLK
* AND BCBLK ARE SET TO THE NULL BUFFER, AND THE IDVAL
* IS ZERO ON RETURN.
*
* (WA) BUFFER SIZE IN CHARACTERS
* JSR ALOBF CALL TO CREATE BUFFER
* (WA) 0 (INITIAL OFFSET TO BFBLK CHARS)
* (WB) 0 (INITIAL BCLEN)
* (XR) BCBLK PTR
*
ALOBF PRC E,0 ENTRY POINT
MOV WA,WB HANG ONTO ALLOCATION SIZE
CTB WA,BFSI$ GET TOTAL BLOCK SIZE
BGE WA,MXLEN,ALB01 CHECK FOR MAXLEN EXCEEDED
ADD *BCSI$,WA ADD IN ALLOCATION FOR BCBLK
JSR ALLOC ALLOCATE FRAME
MOV =B$BCT,(XR) SET TYPE
ZER IDVAL(XR) NO ID YET
ZER BCLEN(XR) NO DEFINED LENGTH
MOV XL,WA SAVE XL
MOV XR,XL COPY BCBLK PTR
ADD *BCSI$,XL BIAS PAST PARTIALLY BUILT BCBLK
MOV =B$BFT,(XL) SET BFBLK TYPE WORD
MOV WB,BFALC(XL) SET ALLOCATED SIZE
MOV XL,BCBUF(XR) SET POINTER IN BCBLK
ZER WB CLEAR FOR RETURN
MOV WB,BFCHR(XL) CLEAR FIRST WORD (NULL PAD)
MOV WA,XL RESTORE ENTRY XL
ZER WA CLEAR FOR RETURN
EXI RETURN TO CALLER
*
* HERE FOR MXLEN EXCEEDED
*
ALB01 ERB 201,REQUESTED BUFFER ALLOCATION EXCEEDS MAXLNGTH
ENP END PROCEDURE ALOBF
EJC
.FI
*
* ALOCS -- ALLOCATE STRING BLOCK
*
* ALOCS IS USED TO BUILD A FRAME FOR A STRING BLOCK INTO
* WHICH THE ACTUAL CHARACTERS ARE PLACED BY THE CALLER.
* ALL STRINGS ARE CREATED WITH A CALL TO ALOCS (THE
* EXCEPTIONS OCCUR IN TRIMR AND S$RPL PROCEDURES).
*
* (WA) LENGTH OF STRING TO BE ALLOCATED
* JSR ALOCS CALL TO ALLOCATE SCBLK
* (XR) POINTER TO RESULTING SCBLK
* (WA) DESTROYED
* (WC) CHARACTER COUNT (ENTRY VALUE OF WA)
*
* THE RESULTING SCBLK HAS THE TYPE WORD AND THE LENGTH
* FILLED IN AND THE LAST WORD IS CLEARED TO ZERO CHARACTERS
* TO ENSURE CORRECT RIGHT PADDING OF THE FINAL WORD.
*
ALOCS PRC E,0 ENTRY POINT
BGT WA,KVMXL,ALCS2 JUMP IF LENGTH EXCEEEDS MAXLENGTH
MOV WA,WC ELSE COPY LENGTH
CTB WA,SCSI$ COMPUTE LENGTH OF SCBLK IN BAUS
MOV DNAMP,XR POINT TO NEXT AVAILABLE LOCATION
AOV WA,XR,ALCS0 POINT PAST BLOCK
BLO XR,DNAME,ALCS1 JUMP IF THERE IS ROOM
*
* INSUFFICIENT MEMORY
*
ALCS0 ZER XR ELSE CLEAR GARBAGE XR VALUE
JSR ALLOC AND USE STANDARD ALLOCATOR
ADD WA,XR POINT PAST END OF BLOCK TO MERGE
*
* MERGE HERE WITH XR POINTING BEYOND NEW BLOCK
*
ALCS1 MOV XR,DNAMP SET UPDATED STORAGE POINTER
ZER -(XR) STORE ZERO CHARS IN LAST WORD
DCA WA DECREMENT LENGTH
SUB WA,XR POINT BACK TO START OF BLOCK
MOV =B$SCL,(XR) SET TYPE WORD
MOV WC,SCLEN(XR) STORE LENGTH IN CHARS
EXI RETURN TO ALOCS CALLER
*
* COME HERE IF STRING IS TOO LONG
*
ALCS2 ERB 202,STRING LENGTH EXCEEDS VALUE OF MAXLNGTH KEYWORD
ENP END PROCEDURE ALOCS
EJC
*
* ALOST -- ALLOCATE SPACE IN STATIC REGION
*
* (WA) LENGTH REQUIRED IN BAUS
* JSR ALOST CALL TO ALLOCATE SPACE
* (XR) POINTER TO ALLOCATED BLOCK
* (WB) DESTROYED
*
* NOTE THAT THE CODING ENSURES THAT THE RESULTING VALUE
* OF STATE IS ALWAYS LESS THAN DNAMB. THIS FACT IS USED
* IN TESTING A VARIABLE NAME FOR BEING IN THE STATIC REGION
*
ALOST PRC E,0 ENTRY POINT
*
* MERGE BACK HERE AFTER ALLOCATING NEW CHUNK
*
ALST1 MOV STATE,XR POINT TO CURRENT END OF AREA
AOV WA,XR,ALST2 POINT BEYOND PROPOSED BLOCK
BGE XR,DNAMB,ALST2 JUMP IF OVERLAP WITH DYNAMIC AREA
MOV XR,STATE ELSE STORE NEW POINTER
SUB WA,XR POINT BACK TO START OF BLOCK
EXI RETURN TO ALOST CALLER
*
* HERE IF NO ROOM, PREPARE TO MOVE DYNAMIC STORAGE UP
*
ALST2 MOV WA,ALSTA SAVE WA
BGE WA,*E$STS,ALST3 SKIP IF REQUESTED CHUNK IS LARGE
MOV *E$STS,WA ELSE SET TO GET LARGE ENOUGH CHUNK
*
* HERE WITH AMOUNT TO MOVE UP IN WA
*
ALST3 JSR ALLOC ALLOCATE BLOCK TO ENSURE ROOM
MOV XR,DNAMP AND DELETE IT
MOV WA,WB COPY MOVE UP AMOUNT
JSR GBCOL CALL GBCOL TO MOVE DYNAMIC AREA UP
MOV ALSTA,WA RESTORE WA
BRN ALST1 LOOP BACK TO TRY AGAIN
ENP END PROCEDURE ALOST
EJC
*
* ARITH -- FETCH ARITHMETIC OPERANDS
*
* ARITH IS USED BY FUNCTIONS AND OPERATORS WHICH EXPECT
* TWO NUMERIC ARGUMENTS (OPERANDS) WHICH MUST BOTH BE
* INTEGER OR BOTH BE REAL. ARITH FETCHES TWO ARGUMENTS FROM
* THE STACK AND PERFORMS ANY NECESSARY CONVERSIONS.
*
* 1(XS) FIRST ARGUMENT (LEFT OPERAND)
* 0(XS) SECOND ARGUMENT (RIGHT OPERAND)
* JSR ARITH CALL TO FETCH NUMERIC ARGUMENTS
* PPM LOC TRANSFER LOC FOR OPND 1 NON-NUMERIC
* PPM LOC TRANSFER LOC FOR OPND 2 NON-NUMERIC
.IF .CNRA
.ELSE
* PPM LOC TRANSFER LOC FOR REAL OPERANDS
.FI
*
* FOR INTEGER ARGS, CONTROL RETURNS PAST THE PARAMETERS
*
* (IA) LEFT OPERAND VALUE
* (XR) PTR TO ICBLK FOR LEFT OPERAND
* (XL) PTR TO ICBLK FOR RIGHT OPERAND
* (XS) POPPED TWICE
* (WA,WB,RA) DESTROYED
.IF .CNRA
.ELSE
*
* FOR REAL ARGUMENTS, CONTROL RETURNS TO THE LOCATION
* SPECIFIED BY THE THIRD PARAMETER.
*
* (RA) LEFT OPERAND VALUE
* (XR) PTR TO RCBLK FOR LEFT OPERAND
* (XL) PTR TO RCBLK FOR RIGHT OPERAND
* (WA,WB,WC) DESTROYED
* (XS) POPPED TWICE
.FI
EJC
*
* ARITH (CONTINUED)
*
* ENTRY POINT
*
.IF .CNRA
ARITH PRC N,2 ENTRY POINT
.ELSE
ARITH PRC N,3 ENTRY POINT
.FI
MOV (XS)+,XL LOAD RIGHT OPERAND
MOV (XS)+,XR LOAD LEFT OPERAND
MOV (XL),WA GET RIGHT OPERAND TYPE WORD
BEQ WA,=B$ICL,ARTH1 JUMP IF INTEGER
.IF .CNRA
.ELSE
BEQ WA,=B$RCL,ARTH4 JUMP IF REAL
.FI
MOV XR,-(XS) ELSE REPLACE LEFT ARG ON STACK
MOV XL,XR COPY LEFT ARG POINTER
JSR GTNUM CONVERT TO NUMERIC
PPM ARTH6 JUMP IF UNCONVERTIBLE
MOV XR,XL ELSE COPY CONVERTED RESULT
MOV (XL),WA GET RIGHT OPERAND TYPE WORD
MOV (XS)+,XR RELOAD LEFT ARGUMENT
.IF .CNRA
.ELSE
BEQ WA,=B$RCL,ARTH4 JUMP IF RIGHT ARG IS REAL
.FI
*
* HERE IF RIGHT ARG IS AN INTEGER
*
ARTH1 BNE (XR),=B$ICL,ARTH3 JUMP IF LEFT ARG NOT INTEGER
*
* EXIT FOR INTEGER CASE
*
ARTH2 LDI ICVAL(XR) LOAD LEFT OPERAND VALUE
EXI RETURN TO ARITH CALLER
*
* HERE FOR RIGHT OPERAND INTEGER, LEFT OPERAND NOT
*
ARTH3 JSR GTNUM CONVERT LEFT ARG TO NUMERIC
PPM ARTH7 JUMP IF NOT CONVERTIBLE
BEQ WA,=B$ICL,ARTH2 JUMP BACK IF INTEGER-INTEGER
.IF .CNRA
.ELSE
*
* HERE WE MUST CONVERT REAL-INTEGER TO REAL-REAL
*
MOV XR,-(XS) PUT LEFT ARG BACK ON STACK
LDI ICVAL(XL) LOAD RIGHT ARGUMENT VALUE
ITR CONVERT TO REAL
JSR RCBLD GET REAL BLOCK FOR RIGHT ARG, MERGE
MOV XR,XL COPY RIGHT ARG PTR
MOV (XS)+,XR LOAD LEFT ARGUMENT
BRN ARTH5 MERGE FOR REAL-REAL CASE
EJC
*
* ARITH (CONTINUED)
*
* HERE IF RIGHT ARGUMENT IS REAL
*
ARTH4 BEQ (XR),=B$RCL,ARTH5 JUMP IF LEFT ARG REAL
JSR GTREA ELSE CONVERT TO REAL
PPM ARTH7 ERROR IF UNCONVERTIBLE
*
* HERE FOR REAL-REAL
*
ARTH5 LDR RCVAL(XR) LOAD LEFT OPERAND VALUE
EXI 3 TAKE REAL-REAL EXIT
.FI
*
* HERE FOR ERROR CONVERTING RIGHT ARGUMENT
*
ARTH6 ICA XS POP UNWANTED LEFT ARG
EXI 2 TAKE APPROPRIATE ERROR EXIT
*
* HERE FOR ERROR CONVERTING LEFT OPERAND
*
ARTH7 EXI 1 TAKE APPROPRIATE ERROR RETURN
ENP END PROCEDURE ARITH
EJC
*
* ASIGN -- PERFORM ASSIGNMENT
*
* ASIGN PERFORMS THE ASSIGNMENT OF A VALUE TO A VARIABLE
* WITH APPROPRIATE CHECKS FOR OUTPUT ASSOCIATIONS AND
* VALUE TRACE ASSOCIATIONS WHICH ARE EXECUTED AS REQUIRED.
* ASIGN ALSO HANDLES THE SPECIAL CASES OF ASSIGNMENT TO
* PATTERN AND EXPRESSION VARIABLES.
*
* (WB) VALUE TO BE ASSIGNED
* (XL) BASE POINTER FOR VARIABLE
* (WA) OFFSET FOR VARIABLE
* JSR ASIGN CALL TO ASSIGN VALUE TO VARIABLE
* PPM LOC TRANSFER LOC FOR FAILURE
* (XR,XL,WA,WB,WC) DESTROYED
* (RA) DESTROYED
*
* FAILURE OCCURS IF THE EVALUATION OF AN EXPRESSION
* ASSOCIATED WITH AN EXPRESSION VARIABLE FAILS.
*
ASIGN PRC R,1 ENTRY POINT (RECURSIVE)
*
* MERGE BACK HERE TO ASSIGN RESULT TO EXPRESSION VARIABLE.
*
ASG01 ADD WA,XL POINT TO VARIABLE VALUE
MOV (XL),XR LOAD VARIABLE VALUE
BEQ (XR),=B$TRT,ASG02 JUMP IF TRAPPED
MOV WB,(XL) ELSE PERFORM ASSIGNMENT
ZER XL CLEAR GARBAGE VALUE IN XL
EXI AND RETURN TO ASIGN CALLER
*
* HERE IF VALUE IS TRAPPED
*
ASG02 SUB WA,XL RESTORE NAME BASE
BEQ XR,=TRBKV,ASG14 JUMP IF KEYWORD VARIABLE
BNE XR,=TRBEV,ASG04 JUMP IF NOT EXPRESSION VARIABLE
*
* HERE FOR ASSIGNMENT TO EXPRESSION VARIABLE
*
MOV EVEXP(XL),XR POINT TO EXPRESSION
MOV WB,-(XS) STORE VALUE TO ASSIGN ON STACK
MOV =NUM01,WB SET FOR EVALUATION BY NAME
JSR EVALX EVALUATE EXPRESSION BY NAME
PPM ASG03 JUMP IF EVALUATION FAILS
MOV (XS)+,WB ELSE RELOAD VALUE TO ASSIGN
BRN ASG01 LOOP BACK TO PERFORM ASSIGNMENT
EJC
*
* ASIGN (CONTINUED)
*
* HERE FOR FAILURE RETURNS
*
ASG03 ICA XS REMOVE STACKED VALUE ENTRY
*
ASG3A EXI 1 TAKE FAILURE EXIT
*
* HERE IF NOT KEYWORD OR EXPRESSION VARIABLE
*
ASG04 MOV XR,-(XS) SAVE PTR TO FIRST TRBLK
*
* LOOP TO CHASE DOWN TRBLK CHAIN AND ASSIGN VALUE AT END
*
ASG05 MOV XR,WC SAVE PTR TO THIS TRBLK
MOV TRNXT(XR),XR POINT TO NEXT TRBLK
BEQ (XR),=B$TRT,ASG05 LOOP BACK IF ANOTHER TRBLK
MOV WC,XR ELSE POINT BACK TO LAST TRBLK
MOV WB,TRVAL(XR) STORE VALUE AT END OF CHAIN
MOV (XS)+,XR RESTORE PTR TO FIRST TRBLK
*
* LOOP TO PROCESS TRBLK ENTRIES ON CHAIN
*
ASG06 MOV TRTYP(XR),WB LOAD TYPE CODE OF TRBLK
BEQ WB,=TRTVL,ASG08 JUMP IF VALUE TRACE
BEQ WB,=TRTOU,ASG10 JUMP IF OUTPUT ASSOCIATION
*
* HERE TO MOVE TO NEXT TRBLK ON CHAIN
*
ASG07 MOV TRNXT(XR),XR POINT TO NEXT TRBLK ON CHAIN
BEQ (XR),=B$TRT,ASG06 LOOP BACK IF ANOTHER TRBLK
EXI ELSE END OF CHAIN, RETURN TO CALLER
*
* HERE TO PROCESS VALUE TRACE
*
ASG08 BZE KVTRA,ASG07 IGNORE VALUE TRACE IF TRACE OFF
DCV KVTRA ELSE DECREMENT TRACE COUNT
BZE TRFNC(XR),ASG09 JUMP IF PRINT TRACE
JSR TRXEQ ELSE EXECUTE FUNCTION TRACE
BRN ASG07 AND LOOP BACK
EJC
*
* ASIGN (CONTINUED)
*
* HERE FOR PRINT TRACE
*
ASG09 JSR PRTSN PRINT STATEMENT NUMBER
JSR PRTNV PRINT NAME = VALUE
BRN ASG07 LOOP BACK FOR NEXT TRBLK
*
* HERE FOR OUTPUT ASSOCIATION
*
ASG10 BZE KVOUP,ASG07 IGNORE OUTPUT ASSOC IF OUTPUT OFF
MOV XR,XL ELSE COPY TRBLK POINTER
MOV TRVAL(XR),-(XS) STACK VALUE TO OUTPUT
JSR GTSTG CONVERT TO STRING
PPM ASG12 GET DATATYPE NAME IF UNCONVERTIBLE
*
* MERGE WITH STRING FOR OUTPUT
*
ASG11 MOV TRTRI(XL),WA TRTIO BLK PTR
BZE WA,ASG13 JUMP IF STANDARD OUTPUT FILE
*
* HERE FOR OUTPUT TO NON-STANDARD OUTPUT FILE
*
MOV WA,XL COPY TRTIO BLOCK PTR TO XL
MOV TRTAG(XL),WA GET IOTAG
BZE WA,ASG3A FAIL IF ENDFILE DONE
MOV SCLEN(XR),WC STRING LENGTH
JSR SYSOU CALL SYSTEM OUTPUT ROUTINE
PPM ASG3A FAIL RETURN
PPM EROSI ERROR RETURN
EXI ELSE ALL DONE, RETURN TO CALLER
*
* IF NOT PRINTABLE, GET DATATYPE NAME INSTEAD
*
ASG12 JSR DTYPE CALL DATATYPE ROUTINE
BRN ASG11 MERGE
*
* HERE TO PRINT A STRING
*
ASG13 BEQ TRTER(XL),=V$TER,ASG20 JUMP IF TERMINAL OUTPUT
JSR PRTSF PRINT STRING AND FLUSH BUFFER
EXI RETURN TO CALLER
EJC
*
* ASIGN (CONTINUED)
*
* HERE FOR KEYWORD ASSIGNMENT
*
ASG14 MOV KVNUM(XL),XL LOAD KEYWORD NUMBER
BEQ XL,=K$ETX,ASG19 JUMP IF ERRTEXT
MOV WB,XR COPY VALUE TO BE ASSIGNED
JSR GTINT CONVERT TO INTEGER
ERR 203,KEYWORD VALUE ASSIGNED IS NOT INTEGER
LDI ICVAL(XR) ELSE LOAD VALUE
BEQ XL,=K$STL,ASG16 JUMP IF SPECIAL CASE OF STLIMIT
BEQ XL,=K$COD,ASG24 JUMP IF SPECIAL CASE OF CODE
MFI WA,ASG18 ELSE GET ADDR INTEGER, TEST OVFLOW
BGE WA,MXLEN,ASG18 FAIL IF TOO LARGE
BEQ XL,=K$ERT,ASG17 JUMP IF SPECIAL CASE OF ERRTYPE
.IF .CNPF
.ELSE
BEQ XL,=K$PFL,ASG21 JUMP IF SPECIAL CASE OF PROFILE
.FI
BLT XL,=K$P$$,ASG15 JUMP UNLESS PROTECTED
ERB 204,KEYWORD IN ASSIGNMENT IS PROTECTED
*
* HERE TO DO ASSIGNMENT IF NOT PROTECTED
*
ASG15 MOV WA,KVANC(XL) STORE NEW VALUE
EXI RETURN TO ASIGN CALLER
*
* HERE FOR SPECIAL CASE OF STLIMIT
*
* SINCE STCOUNT IS MAINTAINED AS (STLIMIT-STCOUNT)
* IT IS ALSO NECESSARY TO MODIFY STCOUNT APPROPRIATELY.
*
ASG16 SBI KVSTL SUBTRACT OLD LIMIT
ADI KVSTC ADD OLD COUNTER
STI KVSTC STORE NEW COUNTER VALUE
LDI ICVAL(XR) RELOAD NEW LIMIT VALUE
STI KVSTL STORE NEW LIMIT VALUE
EXI RETURN TO ASIGN CALLER
EJC
*
* ASIGN (CONTINUED)
*
* HERE FOR SPECIAL CASE OF ERRTYPE
*
ASG17 BLE WA,=NINI9,ERROR OK TO SIGNAL IF IN RANGE
*
* HERE IF VALUE ASSIGNED IS OUT OF RANGE
*
ASG18 ERB 205,KEYWORD VALUE ASSIGNED IS NEGATIVE OR TOO LARGE
*
* HERE FOR SPECIAL CASE OF ERRTEXT
*
ASG19 MOV WB,-(XS) STACK VALUE
JSR GTSTG CONVERT TO STRING
ERR 206,VALUE ASSIGNED TO KEYWORD ERRTEXT NOT A STRING
MOV XR,R$ETX MAKE ASSIGNMENT
EXI RETURN TO CALLER
*
* PRINT STRING TO TERMINAL
*
ASG20 JSR PTTST PRINT STRING TO TERMINAL
JSR PTTFH FLUSH TERMINAL BUFFER
EXI RETURN
.IF .CNPF
.ELSE
* HERE FOR KEYWORD PROFILE
*
ASG21 BGT WA,=NUM02,ASG18 MOAN IF NOT 0,1, OR 2
BZE WA,ASG15 JUST ASSIGN IF ZERO
BZE PFDMP,ASG22 BRANCH IF FIRST ASSIGNMENT
BEQ WA,PFDMP,ASG23 ALSO IF SAME VALUE AS BEFORE
ERB 207,INCONSISTENT VALUE ASSIGNED TO KEYWORD PROFILE
*
ASG22 MOV WA,PFDMP NOTE VALUE ON FIRST ASSIGNMENT
ASG23 JSR SYSTM GET THE TIME
STI PFSTM FUDGE SOME KIND OF START TIME
BRN ASG15 AND GO ASSIGN
.FI
*
* HERE FOR KEYWORD ASSIGNMENT TO CODE
*
ASG24 STI KVCOD STORE VALUE
EXI RETURN TO CALLER
ENP END PROCEDURE ASIGN
EJC
*
* ASINP -- ASSIGN DURING PATTERN MATCH
*
* ASINP IS LIKE ASIGN AND HAS A SIMILAR CALLING SEQUENCE
* AND EFFECT. THE DIFFERENCE IS THAT THE GLOBAL PATTERN
* VARIABLES ARE SAVED AND RESTORED IF REQUIRED.
*
* (XL) BASE POINTER FOR VARIABLE
* (WA) OFFSET FOR VARIABLE
* (WB) VALUE TO BE ASSIGNED
* JSR ASINP CALL TO ASSIGN VALUE TO VARIABLE
* PPM LOC TRANSFER LOC IF FAILURE
* (XR,XL) DESTROYED
* (WA,WB,WC,RA) DESTROYED
*
ASINP PRC R,1 ENTRY POINT, RECURSIVE
ADD WA,XL POINT TO VARIABLE
MOV (XL),XR LOAD CURRENT CONTENTS
BEQ (XR),=B$TRT,ASNP1 JUMP IF TRAPPED
MOV WB,(XL) ELSE PERFORM ASSIGNMENT
ZER XL CLEAR GARBAGE VALUE IN XL
EXI RETURN TO ASINP CALLER
*
* HERE IF VARIABLE IS TRAPPED
*
ASNP1 SUB WA,XL RESTORE BASE POINTER
MOV PMSSL,-(XS) STACK SUBJECT STRING LENGTH
MOV PMHBS,-(XS) STACK HISTORY STACK BASE PTR
MOV R$PMS,-(XS) STACK SUBJECT STRING POINTER
MOV PMDFL,-(XS) STACK DOT FLAG
JSR ASIGN CALL FULL-BLOWN ASSIGNMENT ROUTINE
PPM ASNP2 JUMP IF FAILURE
MOV (XS)+,PMDFL RESTORE DOT FLAG
MOV (XS)+,R$PMS RESTORE SUBJECT STRING POINTER
MOV (XS)+,PMHBS RESTORE HISTORY STACK BASE POINTER
MOV (XS)+,PMSSL RESTORE SUBJECT STRING LENGTH
EXI RETURN TO ASINP CALLER
*
* HERE IF FAILURE IN ASIGN CALL
*
ASNP2 MOV (XS)+,PMDFL RESTORE DOT FLAG
MOV (XS)+,R$PMS RESTORE SUBJECT STRING POINTER
MOV (XS)+,PMHBS RESTORE HISTORY STACK BASE POINTER
MOV (XS)+,PMSSL RESTORE SUBJECT STRING LENGTH
EXI 1 TAKE FAILURE EXIT
ENP END PROCEDURE ASINP
EJC
*
* BLKLN -- DETERMINE LENGTH OF BLOCK
*
* BLKLN DETERMINES THE LENGTH OF A BLOCK IN DYNAMIC STORE.
*
* (WA) FIRST WORD OF BLOCK
* (XR) POINTER TO BLOCK
* JSR BLKLN CALL TO GET BLOCK LENGTH
* (WA) LENGTH OF BLOCK IN BAUS
* (XL) DESTROYED
*
* BLKLN IS USED BY THE GARBAGE COLLECTOR AND IS NOT
* PERMITTED TO CALL GBCOL DIRECTLY OR INDIRECTLY.
*
* THE FIRST WORD STORED IN THE BLOCK (I.E. AT XR) MAY
* BE ANYTHING, BUT THE CONTENTS OF WA MUST BE CORRECT.
*
BLKLN PRC E,0 ENTRY POINT
MOV WA,XL COPY FIRST WORD
LEI XL GET ENTRY ID (BL$XX)
BSW XL,BL$$$,BLN00 SWITCH ON BLOCK TYPE
IFF BL$AR,BLN01 ARBLK
IFF BL$CD,BLN01 CDBLK
IFF BL$CO,BLN12 COBLK
IFF BL$DF,BLN01 DFBLK
IFF BL$EF,BLN01 EFBLK
IFF BL$EX,BLN01 EXBLK
IFF BL$PF,BLN01 PFBLK
IFF BL$TB,BLN01 TBBLK
IFF BL$VC,BLN01 VCBLK
IFF BL$EV,BLN03 EVBLK
IFF BL$KV,BLN03 KVBLK
IFF BL$P0,BLN02 P0BLK
IFF BL$SE,BLN02 SEBLK
IFF BL$NM,BLN03 NMBLK
IFF BL$P1,BLN03 P1BLK
IFF BL$P2,BLN04 P2BLK
IFF BL$TE,BLN04 TEBLK
IFF BL$FF,BLN05 FFBLK
IFF BL$TR,BLN05 TRBLK
IFF BL$CT,BLN06 CTBLK
IFF BL$IC,BLN07 ICBLK
IFF BL$PD,BLN08 PDBLK
.IF .CNBF
.ELSE
IFF BL$BC,BLN04 BCBLK
IFF BL$BF,BLN11 BFBLK
.FI
.IF .CNRA
.ELSE
IFF BL$RC,BLN09 RCBLK
.FI
IFF BL$SC,BLN10 SCBLK
ESW END OF JUMP TABLE ON BLOCK TYPE
EJC
*
* BLKLN (CONTINUED)
*
* HERE FOR BLOCKS WITH LENGTH IN SECOND WORD
*
BLN00 MOV 1(XR),WA LOAD LENGTH
EXI RETURN TO BLKLN CALLER
*
* HERE FOR LENGTH IN THIRD WORD (AR,CD,DF,EF,EX,PF,TB,VC)
*
BLN01 MOV 2(XR),WA LOAD LENGTH FROM THIRD WORD
EXI RETURN TO BLKLN CALLER
*
* HERE FOR TWO WORD BLOCKS (P0,SE)
*
BLN02 MOV *NUM02,WA LOAD LENGTH (TWO WORDS)
EXI RETURN TO BLKLN CALLER
*
* HERE FOR THREE WORD BLOCKS (NM,P1,EV,KV)
*
BLN03 MOV *NUM03,WA LOAD LENGTH (THREE WORDS)
EXI RETURN TO BLKLN CALLER
*
* HERE FOR FOUR WORD BLOCKS (P2,TE)
*
BLN04 MOV *NUM04,WA LOAD LENGTH (FOUR WORDS)
EXI RETURN TO BLKLN CALLER
*
* HERE FOR FIVE WORD BLOCKS (FF,TR)
*
BLN05 MOV *NUM05,WA LOAD LENGTH
EXI RETURN TO BLKLN CALLER
EJC
*
* BLKLN (CONTINUED)
*
* HERE FOR CTBLK
*
BLN06 MOV *CTSI$,WA SET SIZE OF CTBLK
EXI RETURN TO BLKLN CALLER
*
* HERE FOR ICBLK
*
BLN07 MOV *ICSI$,WA SET SIZE OF ICBLK
EXI RETURN TO BLKLN CALLER
*
* HERE FOR PDBLK
*
BLN08 MOV PDDFP(XR),XL POINT TO DFBLK
MOV DFPDL(XL),WA LOAD PDBLK LENGTH FROM DFBLK
EXI RETURN TO BLKLN CALLER
.IF .CNRA
.ELSE
*
* HERE FOR RCBLK
*
BLN09 MOV *RCSI$,WA SET SIZE OF RCBLK
EXI RETURN TO BLKLN CALLER
.FI
*
* HERE FOR SCBLK
*
BLN10 MOV SCLEN(XR),WA LOAD LENGTH IN CHARACTERS
CTB WA,SCSI$ CALCULATE LENGTH IN BAUS
EXI RETURN TO BLKLN CALLER
.IF .CNBF
.ELSE
*
* HERE FOR BFBLK
*
BLN11 MOV BFALC(XR),WA GET ALLOCATION IN BAUS
CTB WA,BFSI$ CALCULATE LENGTH IN BAUS
EXI RETURN TO BLKLN CALLER
.FI
*
* HERE FOR COBLK
*
BLN12 MOV *COSI$,WA GET SIZE IN BAUS
EXI RETURN TO BLKLN CALLER
ENP END PROCEDURE BLKLN
EJC
*
* CBLCK -- COPY A BLOCK
*
* (XS) BLOCK TO BE COPIED
* JSR CBLCK CALL TO COPY BLOCK
* PPM LOC RETURN IF BLOCK HAS NO IDVAL FIELD
* NORMAL RETURN IF IDVAL FIELD
* (XR) COPY OF BLOCK
* (XS) POPPED
* (XL,WA,WB,WC) DESTROYED
*
CBLCK PRC N,1 ENTRY POINT
MOV (XS),XR LOAD ARGUMENT
BEQ XR,=NULLS,CBL10 RETURN ARGUMENT IF IT IS NULL
MOV (XR),WA ELSE LOAD TYPE WORD
MOV WA,WB COPY TYPE WORD
JSR BLKLN GET LENGTH OF ARGUMENT BLOCK
MOV XR,XL COPY POINTER
JSR ALLOC ALLOCATE BLOCK OF SAME SIZE
MOV XR,(XS) STORE POINTER TO COPY
MVW COPY CONTENTS OF OLD BLOCK TO NEW
MOV (XS),XR RELOAD POINTER TO START OF COPY
BEQ WB,=B$TBT,CBL05 JUMP IF TABLE
BEQ WB,=B$VCT,CBL01 JUMP IF VECTOR
BEQ WB,=B$PDT,CBL01 JUMP IF PROGRAM DEFINED
.IF .CNBF
.ELSE
BEQ WB,=B$BCT,CBL11 JUMP IF BUFFER
.FI
BNE WB,=B$ART,CBL10 RETURN COPY IF NOT ARRAY
*
* HERE FOR ARRAY (ARBLK)
*
ADD AROFS(XR),XR POINT TO PROTOTYPE FIELD
BRN CBL02 JUMP TO MERGE
*
* HERE FOR VECTOR, PROGRAM DEFINED
*
CBL01 ADD *PDFLD,XR POINT TO PDFLD = VCVLS
*
* MERGE HERE FOR ARBLK, VCBLK, PDBLK TO DELETE TRAP
* BLOCKS FROM ALL VALUE FIELDS (THE COPY IS UNTRAPPED)
*
CBL02 MOV (XR),XL LOAD NEXT POINTER
*
* LOOP TO GET VALUE AT END OF TRBLK CHAIN
*
CBL03 BNE (XL),=B$TRT,CBL04 JUMP IF NOT TRAPPED
MOV TRVAL(XL),XL ELSE POINT TO NEXT VALUE
BRN CBL03 AND LOOP BACK
EJC
*
* CBLCK (CONTINUED)
*
* HERE WITH UNTRAPPED VALUE IN XL
*
CBL04 MOV XL,(XR)+ STORE REAL VALUE, BUMP POINTER
BNE XR,DNAMP,CBL02 LOOP BACK IF MORE TO GO
BRN CBL09 ELSE JUMP TO EXIT
*
* HERE TO COPY A TABLE
*
CBL05 ZER IDVAL(XR) ZERO ID TO STOP DUMP BLOWING UP
MOV *TESI$,WA SET SIZE OF TEBLK
MOV *TBBUK,WC SET INITIAL OFFSET
*
* LOOP THROUGH BUCKETS IN TABLE
*
CBL06 MOV (XS),XR LOAD TABLE POINTER
BEQ WC,TBLEN(XR),CBL09 JUMP TO EXIT IF ALL DONE
ADD WC,XR ELSE POINT TO NEXT BUCKET HEADER
ICA WC BUMP OFFSET
SUB *TENXT,XR SUBTRACT LINK OFFSET TO MERGE
*
* LOOP THROUGH TEBLKS ON ONE CHAIN
*
CBL07 MOV TENXT(XR),XL LOAD POINTER TO NEXT TEBLK
MOV (XS),TENXT(XR) SET END OF CHAIN POINTER IN CASE
BEQ (XL),=B$TBT,CBL06 BACK FOR NEXT BUCKET IF CHAIN END
MOV XR,-(XS) ELSE STACK PTR TO PREVIOUS BLOCK
MOV *TESI$,WA SET SIZE OF TEBLK
JSR ALLOC ALLOCATE NEW TEBLK
MOV XR,WB SAVE PTR TO NEW TEBLK
MVW COPY OLD TEBLK TO NEW TEBLK
MOV WB,XR RESTORE POINTER TO NEW TEBLK
MOV (XS)+,XL RESTORE POINTER TO PREVIOUS BLOCK
MOV XR,TENXT(XL) LINK NEW BLOCK TO PREVIOUS
MOV XR,XL COPY POINTER TO NEW BLOCK
*
* LOOP TO SET REAL VALUE AFTER REMOVING TRAP CHAIN
*
CBL08 MOV TEVAL(XL),XL LOAD VALUE
BEQ (XL),=B$TRT,CBL08 LOOP BACK IF TRAPPED
MOV XL,TEVAL(XR) STORE UNTRAPPED VALUE IN TEBLK
BRN CBL07 BACK FOR NEXT TEBLK
*
* COMMON EXIT POINT
*
CBL09 MOV (XS)+,XR LOAD POINTER TO BLOCK
EXI RETURN
*
* ALTERNATIVE RETURN
*
CBL10 EXI 1 RETURN
.IF .CNBF
.ELSE
EJC
*
* HERE TO COPY BUFFER
*
CBL11 MOV BCBUF(XR),XL GET BFBLK PTR
MOV BFALC(XL),WA GET ALLOCATION
CTB WA,BFSI$ SET TOTAL SIZE
MOV XR,XL SAVE BCBLK PTR
JSR ALLOC ALLOCATE BFBLK
MOV BCBUF(XL),WB GET OLD BFBLK
MOV XR,BCBUF(XL) SET POINTER TO NEW BFBLK
MOV WB,XL POINT TO OLD BFBLK
MVW COPY BFBLK TOO
ZER XL CLEAR RUBBISH PTR
BRN CBL09 BRANCH TO EXIT
.FI
ENP END PROCEDURE CBLCK
EJC
*
* CDGCG -- GENERATE CODE FOR COMPLEX GOTO
*
* USED BY CMPIL TO PROCESS COMPLEX GOTO TREE
*
* (WB) MUST BE COLLECTABLE
* (XR) EXPRESSION POINTER
* JSR CDGCG CALL TO GENERATE COMPLEX GOTO
* (XL,XR,WA) DESTROYED
*
CDGCG PRC E,0 ENTRY POINT
MOV CMOPN(XR),XL GET UNARY GOTO OPERATOR
MOV CMROP(XR),XR POINT TO GOTO OPERAND
BEQ XL,=OPDVD,CDGC2 JUMP IF DIRECT GOTO
JSR CDGNM GENERATE OPND BY NAME IF NOT DIRECT
*
* RETURN POINT
*
CDGC1 MOV XL,WA GOTO OPERATOR
JSR CDWRD GENERATE IT
EXI RETURN TO CALLER
*
* DIRECT GOTO
*
CDGC2 JSR CDGVL GENERATE OPERAND BY VALUE
BRN CDGC1 MERGE TO RETURN
ENP END PROCEDURE CDGCG
EJC
*
* CDGEX -- BUILD EXPRESSION BLOCK
*
* CDGEX IS PASSED A POINTER TO AN EXPRESSION TREE (SEE
* EXPAN) AND RETURNS AN EXPRESSION (SEBLK OR EXBLK).
*
* (WC) SOME COLLECTABLE VALUE
* (WB) INTEGER IN RANGE 0 LE X LE MXLEN
* (XL) PTR TO EXPRESSION TREE
* JSR CDGEX CALL TO BUILD EXPRESSION
* (XR) PTR TO SEBLK OR EXBLK
* (XL,WA,WB) DESTROYED
*
CDGEX PRC R,0 ENTRY POINT, RECURSIVE
BLO (XL),=B$VR$,CDGX1 JUMP IF NOT VARIABLE
*
* HERE FOR NATURAL VARIABLE, BUILD SEBLK
*
MOV *SESI$,WA SET SIZE OF SEBLK
JSR ALLOC ALLOCATE SPACE FOR SEBLK
MOV =B$SEL,(XR) SET TYPE WORD
MOV XL,SEVAR(XR) STORE VRBLK POINTER
EXI RETURN TO CDGEX CALLER
*
* HERE IF NOT VARIABLE, BUILD EXBLK
*
CDGX1 MOV XL,XR COPY TREE POINTER
MOV WC,-(XS) SAVE WC
MOV CWCOF,XL SAVE CURRENT OFFSET
MOV (XR),WA GET TYPE WORD
BNE WA,=B$CMT,CDGX2 CALL BY VALUE IF NOT CMBLK
BGE CMTYP(XR),=C$$NM,CDGX2 JUMP IF CMBLK ONLY BY VALUE
EJC
*
* CDGEX (CONTINUED)
*
* HERE IF EXPRESSION CAN BE EVALUATED BY NAME
*
JSR CDGNM GENERATE CODE BY NAME
MOV =ORNM$,WA LOAD RETURN BY NAME WORD
BRN CDGX3 MERGE WITH VALUE CASE
*
* HERE IF EXPRESSION CAN ONLY BE EVALUATED BY VALUE
*
CDGX2 JSR CDGVL GENERATE CODE BY VALUE
MOV =ORVL$,WA LOAD RETURN BY VALUE WORD
*
* MERGE HERE TO CONSTRUCT EXBLK
*
CDGX3 JSR CDWRD GENERATE RETURN WORD
JSR EXBLD BUILD EXBLK
MOV (XS)+,WC RESTORE WC
EXI RETURN TO CDGEX CALLER
ENP END PROCEDURE CDGEX
EJC
*
* CDGNM -- GENERATE CODE BY NAME
*
* CDGNM IS CALLED DURING THE COMPILATION PROCESS TO
* GENERATE CODE BY NAME FOR AN EXPRESSION. SEE CDBLK
* DESCRIPTION FOR DETAILS OF CODE GENERATED. THE INPUT
* TO CDGNM IS AN EXPRESSION TREE AS GENERATED BY EXPAN.
*
* CDGNM IS A RECURSIVE PROCEDURE WHICH PROCEEDS BY MAKING
* RECURSIVE CALLS TO GENERATE CODE FOR OPERANDS.
*
* (WB) INTEGER IN RANGE 0 LE N LE DNAMB
* (XR) PTR TO TREE GENERATED BY EXPAN
* (WC) CONSTANT FLAG (SEE BELOW)
* JSR CDGNM CALL TO GENERATE CODE BY NAME
* (XR,WA) DESTROYED
* (WC) SET NON-ZERO IF NON-CONSTANT
*
* WC IS SET TO A NON-ZERO (COLLECTABLE) VALUE IF THE
* EXPRESSION FOR WHICH CODE IS GENERATED CANNOT BE
* EVALUATED AT COMPILE TIME, OTHERWISE WC IS UNCHANGED.
*
* THE CODE IS GENERATED IN THE CURRENT CCBLK (SEE CDWRD).
*
CDGNM PRC R,0 ENTRY POINT, RECURSIVE
MOV XL,-(XS) SAVE ENTRY XL
MOV WB,-(XS) SAVE ENTRY WB
CHK CHECK FOR STACK OVERFLOW
MOV (XR),WA LOAD TYPE WORD
BEQ WA,=B$CMT,CGN04 JUMP IF CMBLK
BHI WA,=B$VR$,CGN02 JUMP IF SIMPLE VARIABLE
*
* MERGE HERE FOR OPERAND YIELDING VALUE (E.G. CONSTANT)
*
CGN01 ERB 208,SYNTAX ERROR. VALUE USED WHERE NAME IS REQUIRED
*
* HERE FOR NATURAL VARIABLE REFERENCE
*
CGN02 MOV =OLVN$,WA LOAD VARIABLE LOAD CALL
JSR CDWRD GENERATE IT
MOV XR,WA COPY VRBLK POINTER
JSR CDWRD GENERATE VRBLK POINTER
EJC
*
* CDGNM (CONTINUED)
*
* HERE TO EXIT WITH WC SET CORRECTLY
*
CGN03 MOV (XS)+,WB RESTORE ENTRY WB
MOV (XS)+,XL RESTORE ENTRY XL
EXI RETURN TO CDGNM CALLER
*
* HERE FOR CMBLK
*
CGN04 MOV XR,XL COPY CMBLK POINTER
MOV CMTYP(XR),XR LOAD CMBLK TYPE
BGE XR,=C$$NM,CGN01 ERROR IF NOT NAME OPERAND
BSW XR,C$$NM ELSE SWITCH ON TYPE
IFF C$ARR,CGN05 ARRAY REFERENCE
IFF C$FNC,CGN08 FUNCTION CALL
IFF C$DEF,CGN09 DEFERRED EXPRESSION
IFF C$IND,CGN10 INDIRECT REFERENCE
IFF C$KEY,CGN11 KEYWORD REFERENCE
IFF C$UBO,CGN08 UNDEFINED BINARY OP
IFF C$UUO,CGN08 UNDEFINED UNARY OP
ESW END SWITCH ON CMBLK TYPE
*
* HERE TO GENERATE CODE FOR ARRAY REFERENCE
*
CGN05 MOV *CMOPN,WB POINT TO ARRAY OPERAND
*
* LOOP TO GENERATE CODE FOR ARRAY OPERAND AND SUBSCRIPTS
*
CGN06 JSR CMGEN GENERATE CODE FOR NEXT OPERAND
MOV CMLEN(XL),WC LOAD LENGTH OF CMBLK
BLT WB,WC,CGN06 LOOP TILL ALL GENERATED
*
* GENERATE APPROPRIATE ARRAY CALL
*
MOV =OAON$,WA LOAD ONE-SUBSCRIPT CASE CALL
BEQ WC,*CMAR1,CGN07 JUMP TO EXIT IF ONE SUBSCRIPT CASE
MOV =OAMN$,WA ELSE LOAD MULTI-SUBSCRIPT CASE CALL
JSR CDWRD GENERATE CALL
MOV WC,WA COPY CMBLK LENGTH
BTW WA CONVERT TO WORDS
SUB =CMVLS,WA CALCULATE NUMBER OF SUBSCRIPTS
EJC
*
* CDGNM (CONTINUED)
*
* HERE TO EXIT GENERATING WORD (NON-CONSTANT)
*
CGN07 MNZ WC SET RESULT NON-CONSTANT
JSR CDWRD GENERATE WORD
BRN CGN03 BACK TO EXIT
*
* HERE TO GENERATE CODE FOR FUNCTIONS AND UNDEFINED OPRS
*
CGN08 MOV XL,XR COPY CMBLK POINTER
JSR CDGVL GEN CODE BY VALUE FOR CALL
MOV =OFNE$,WA GET EXTRA CALL FOR BY NAME
BRN CGN07 BACK TO GENERATE AND EXIT
*
* HERE TO GENERATE CODE FOR DEFERED EXPRESSION
*
CGN09 MOV CMROP(XL),XR CHECK IF VARIABLE
BHI (XR),=B$VR$,CGN02 TREAT *VARIABLE AS SIMPLE VAR
MOV XR,XL COPY PTR TO EXPRESSION TREE
JSR CDGEX ELSE BUILD EXBLK
MOV =OLEX$,WA SET CALL TO LOAD EXPR BY NAME
JSR CDWRD GENERATE IT
MOV XR,WA COPY EXBLK POINTER
JSR CDWRD GENERATE EXBLK POINTER
BRN CGN03 BACK TO EXIT
*
* HERE TO GENERATE CODE FOR INDIRECT REFERENCE
*
CGN10 MOV CMROP(XL),XR GET OPERAND
JSR CDGVL GENERATE CODE BY VALUE FOR IT
MOV =OINN$,WA LOAD CALL FOR INDIRECT BY NAME
BRN CGN12 MERGE
*
* HERE TO GENERATE CODE FOR KEYWORD REFERENCE
*
CGN11 MOV CMROP(XL),XR GET OPERAND
JSR CDGNM GENERATE CODE BY NAME FOR IT
MOV =OKWN$,WA LOAD CALL FOR KEYWORD BY NAME
*
* KEYWORD, INDIRECT MERGE HERE
*
CGN12 JSR CDWRD GENERATE CODE FOR OPERATOR
BRN CGN03 EXIT
ENP END PROCEDURE CDGNM
EJC
*
* CDGVL -- GENERATE CODE BY VALUE
*
* CDGVL IS CALLED DURING THE COMPILATION PROCESS TO
* GENERATE CODE BY VALUE FOR AN EXPRESSION. SEE CDBLK
* DESCRIPTION FOR DETAILS OF THE CODE GENERATED. THE INPUT
* TO CDGVL IS AN EXPRESSION TREE AS GENERATED BY EXPAN.
*
* CDGVL IS A RECURSIVE PROCEDURE WHICH PROCEEDS BY MAKING
* RECURSIVE CALLS TO GENERATE CODE FOR OPERANDS.
*
* (WB) INTEGER IN RANGE 0 LE N LE DNAMB
* (XR) PTR TO TREE GENERATED BY EXPAN
* (WC) CONSTANT FLAG (SEE BELOW)
* JSR CDGVL CALL TO GENERATE CODE BY VALUE
* (XR,WA) DESTROYED
* (WC) SET NON-ZERO IF NON-CONSTANT
*
* WC IS SET TO A NON-ZERO (COLLECTABLE) VALUE IF THE
* EXPRESSION FOR WHICH CODE IS GENERATED CANNOT BE
* EVALUATED AT COMPILE TIME, OTHERWISE WC IS UNCHANGED.
*
* IF WC IS NON-ZERO ON ENTRY, THEN PREEVALUATION IS NOT
* ALLOWED REGARDLESS OF THE NATURE OF THE OPERAND.
*
* THE CODE IS GENERATED IN THE CURRENT CCBLK (SEE CDWRD).
*
CDGVL PRC R,0 ENTRY POINT, RECURSIVE
MOV (XR),WA LOAD TYPE WORD
BEQ WA,=B$CMT,CGV01 JUMP IF CMBLK
BLT WA,=B$VRA,CGV00 JUMP IF ICBLK, RCBLK, SCBLK
*
* HERE FOR VARIABLE VALUE REFERENCE
*
CGVL0 MNZ WC INDICATE NON-CONSTANT VALUE
*
* MERGE HERE FOR SIMPLE CONSTANT (ICBLK,RCBLK,SCBLK)
* AND FOR VARIABLES CORRESPONDING TO CONSTANT KEYWORDS.
*
CGV00 MOV XR,WA COPY PTR TO VAR OR CONSTANT
JSR CDWRD GENERATE AS CODE WORD
EXI RETURN TO CALLER
EJC
*
* CDGVL (CONTINUED)
*
* HERE FOR TREE NODE (CMBLK)
*
CGV01 MOV WB,-(XS) SAVE ENTRY WB
MOV XL,-(XS) SAVE ENTRY XL
MOV WC,-(XS) SAVE ENTRY CONSTANT FLAG
MOV CWCOF,-(XS) SAVE INITIAL CODE OFFSET
CHK CHECK FOR STACK OVERFLOW
*
* PREPARE TO GENERATE CODE FOR CMBLK. WC IS CLEARED TO
* START WITH AND IS RESET NON-ZERO FOR ANY NON-CONSTANT
* CODE GENERATED. IF IT IS STILL ZERO AFTER GENERATING ALL
* THE CMBLK CODE, THEN ITS VALUE IS COMPUTED AS THE RESULT.
*
MOV XR,XL COPY CMBLK POINTER
MOV CMTYP(XR),XR LOAD CMBLK TYPE
ZER WC CLEAR OPTIMISE FLAG
BLE XR,=C$PR$,CGV02 JUMP IF NOT PREDICATE VALUE
MNZ WC ELSE FORCE NON-CONSTANT CASE
*
* HERE WITH WC SET APPROPRIATELY
*
CGV02 BSW XR,C$$NV SWITCH TO APPROPRIATE GENERATOR
IFF C$ARR,CGV03 ARRAY REFERENCE
IFF C$FNC,CGV05 FUNCTION CALL
IFF C$DEF,CGV14 DEFERRED EXPRESSION
IFF C$SEL,CGV15 SELECTION
IFF C$IND,CGV31 INDIRECT REFERENCE
IFF C$KEY,CGV27 KEYWORD REFERENCE
IFF C$UBO,CGV29 UNDEFINED BINOP
IFF C$UUO,CGV30 UNDEFINED UNOP
IFF C$BVL,CGV18 BINOPS WITH VAL OPDS
IFF C$ALT,CGV18 ALTERNATION
IFF C$UVL,CGV19 UNOPS WITH VALU OPND
IFF C$ASS,CGV21 ASSIGNMENT
IFF C$CNC,CGV24 CONCATENATION
IFF C$UNM,CGV27 UNOPS WITH NAME OPND
IFF C$CNP,CGV24 CONCAT. NOT PATTERN
IFF C$BVN,CGV26 BINARY $ AND .
IFF C$INT,CGV31 INTERROGATION
IFF C$NEG,CGV28 NEGATION
IFF C$PMT,CGV18 PATTERN MATCH
ESW END SWITCH ON CMBLK TYPE
EJC
*
* CDGVL (CONTINUED)
*
* HERE TO GENERATE CODE FOR ARRAY REFERENCE
*
CGV03 MOV *CMOPN,WB SET OFFSET TO ARRAY OPERAND
*
* LOOP TO GENERATE CODE FOR ARRAY OPERAND AND SUBSCRIPTS
*
CGV04 JSR CMGEN GEN VALUE CODE FOR NEXT OPERAND
MOV CMLEN(XL),WC LOAD CMBLK LENGTH
BLT WB,WC,CGV04 LOOP BACK IF MORE TO GO
*
* GENERATE CALL TO APPROPRIATE ARRAY REFERENCE ROUTINE
*
MOV =OAOV$,WA SET ONE SUBSCRIPT CALL IN CASE
BEQ WC,*CMAR1,CGV32 JUMP TO EXIT IF 1-SUB CASE
MOV =OAMV$,WA ELSE SET CALL FOR MULTI-SUBSCRIPTS
JSR CDWRD GENERATE CALL
MOV WC,WA COPY LENGTH OF CMBLK
SUB *CMVLS,WA SUBTRACT STANDARD LENGTH
BTW WA GET NUMBER OF WORDS
BRN CGV32 JUMP TO GENERATE SUBSCRIPT COUNT
*
* HERE TO GENERATE CODE FOR FUNCTION CALL
*
CGV05 MOV *CMVLS,WB SET OFFSET TO FIRST ARGUMENT
*
* LOOP TO GENERATE CODE FOR ARGUMENTS
*
CGV06 BEQ WB,CMLEN(XL),CGV07 JUMP IF ALL GENERATED
JSR CMGEN ELSE GEN VALUE CODE FOR NEXT ARG
BRN CGV06 BACK TO GENERATE NEXT ARGUMENT
*
* HERE TO GENERATE ACTUAL FUNCTION CALL
*
CGV07 SUB *CMVLS,WB GET NUMBER OF ARG PTRS (BAUS)
BTW WB CONVERT BAUS TO WORDS
MOV CMOPN(XL),XR LOAD FUNCTION VRBLK POINTER
BNZ VRLEN(XR),CGV12 JUMP IF NOT SYSTEM FUNCTION
MOV VRSVP(XR),XL LOAD SVBLK PTR IF SYSTEM VAR
MOV SVBIT(XL),WA LOAD BIT MASK
ANB BTFFC,WA TEST FOR FAST FUNCTION CALL ALLOWED
ZRB WA,CGV12 JUMP IF NOT
EJC
*
* CDGVL (CONTINUED)
*
* HERE IF FAST FUNCTION CALL IS ALLOWED
*
MOV SVBIT(XL),WA RELOAD BIT INDICATORS
ANB BTPRE,WA TEST FOR PREEVALUATION OK
NZB WA,CGV08 JUMP IF PREEVALUATION PERMITTED
MNZ WC ELSE SET RESULT NON-CONSTANT
*
* TEST FOR CORRECT NUMBER OF ARGS FOR FAST CALL
*
CGV08 MOV VRFNC(XR),XL LOAD PTR TO SVFNC FIELD
MOV FARGS(XL),WA LOAD SVNAR FIELD VALUE
BEQ WA,WB,CGV11 JUMP IF ARGUMENT COUNT IS CORRECT
BHI WA,WB,CGV09 JUMP IF TOO FEW ARGUMENTS GIVEN
*
* HERE IF TOO MANY ARGUMENTS, PREPARE TO GENERATE O$POPS
*
SUB WA,WB GET NUMBER OF EXTRA ARGS
LCT WB,WB SET AS COUNT TO CONTROL LOOP
MOV =OPOP$,WA SET POP CALL
BRN CGV10 JUMP TO COMMON LOOP
*
* HERE IF TOO FEW ARGUMENTS, PREPARE TO GENERATE NULLS
*
CGV09 SUB WB,WA GET NUMBER OF MISSING ARGUMENTS
LCT WB,WA LOAD AS COUNT TO CONTROL LOOP
MOV =NULLS,WA LOAD PTR TO NULL CONSTANT
*
* LOOP TO GENERATE CALLS TO FIX ARGUMENT COUNT
*
CGV10 JSR CDWRD GENERATE ONE CALL
BCT WB,CGV10 LOOP TILL ALL GENERATED
*
* HERE AFTER ADJUSTING ARG COUNT AS REQUIRED
*
CGV11 MOV XL,WA COPY POINTER TO SVFNC FIELD
BRN CGV36 JUMP TO GENERATE CALL
EJC
*
* CDGVL (CONTINUED)
*
* COME HERE IF FAST CALL IS NOT PERMITTED
*
CGV12 MOV =OFNS$,WA SET ONE ARG CALL IN CASE
BEQ WB,=NUM01,CGV13 JUMP IF ONE ARG CASE
MOV =OFNC$,WA ELSE LOAD CALL FOR MORE THAN 1 ARG
JSR CDWRD GENERATE IT
MOV WB,WA COPY ARGUMENT COUNT
*
* ONE ARG CASE MERGES HERE
*
CGV13 JSR CDWRD GENERATE =O$FNS OR ARG COUNT
MOV XR,WA COPY VRBLK POINTER
BRN CGV32 JUMP TO GENERATE VRBLK PTR
*
* HERE FOR DEFERRED EXPRESSION
*
CGV14 MOV CMROP(XL),XL POINT TO EXPRESSION TREE
JSR CDGEX BUILD EXBLK OR SEBLK
MOV XR,WA COPY BLOCK PTR
JSR CDWRD GENERATE PTR TO EXBLK OR SEBLK
BRN CGV34 JUMP TO EXIT, CONSTANT TEST
*
* HERE TO GENERATE CODE FOR SELECTION
*
CGV15 ZER -(XS) ZERO PTR TO CHAIN OF FORWARD JUMPS
ZER -(XS) ZERO PTR TO PREV O$SLC FORWARD PTR
MOV *CMVLS,WB POINT TO FIRST ALTERNATIVE
MOV =OSLA$,WA SET INITIAL CODE WORD
*
* 0(XS) IS THE OFFSET TO THE PREVIOUS WORD
* WHICH REQUIRES FILLING IN WITH AN
* OFFSET TO THE FOLLOWING O$SLC,O$SLD
*
* 1(XS) IS THE HEAD OF A CHAIN OF OFFSET
* POINTERS INDICATING THOSE LOCATIONS
* TO BE FILLED WITH OFFSETS PAST
* THE END OF ALL THE ALTERNATIVES
*
CGV16 JSR CDWRD GENERATE O$SLC (O$SLA FIRST TIME)
MOV CWCOF,(XS) SET CURRENT LOC AS PTR TO FILL IN
JSR CDWRD GENERATE GARBAGE WORD THERE FOR NOW
JSR CMGEN GEN VALUE CODE FOR ALTERNATIVE
MOV =OSLB$,WA LOAD O$SLB POINTER
JSR CDWRD GENERATE O$SLB CALL
MOV 1(XS),WA LOAD OLD CHAIN PTR
MOV CWCOF,1(XS) SET CURRENT LOC AS NEW CHAIN HEAD
JSR CDWRD GENERATE FORWARD CHAIN LINK
EJC
*
* CDGVL (CONTINUED)
*
* NOW TO FILL IN THE SKIP OFFSET TO O$SLC,O$SLD
*
MOV (XS),XR LOAD OFFSET TO WORD TO PLUG
ADD R$CCB,XR POINT TO ACTUAL LOCATION TO PLUG
MOV CWCOF,(XR) PLUG PROPER OFFSET IN
MOV =OSLC$,WA LOAD O$SLC PTR FOR NEXT ALTERNATIVE
MOV WB,XR COPY OFFSET (DESTROY GARBAGE XR)
ICA XR BUMP EXTRA TIME FOR TEST
BLT XR,CMLEN(XL),CGV16 LOOP BACK IF NOT LAST ALTERNATIVE
*
* HERE TO GENERATE CODE FOR LAST ALTERNATIVE
*
MOV =OSLD$,WA GET HEADER CALL
JSR CDWRD GENERATE O$SLD CALL
JSR CMGEN GENERATE CODE FOR LAST ALTERNATIVE
ICA XS POP OFFSET PTR
MOV (XS)+,XR LOAD CHAIN PTR
*
* LOOP TO PLUG OFFSETS PAST STRUCTURE
*
CGV17 ADD R$CCB,XR MAKE NEXT PTR ABSOLUTE
MOV (XR),WA LOAD FORWARD PTR
MOV CWCOF,(XR) PLUG REQUIRED OFFSET
MOV WA,XR COPY FORWARD PTR
BNZ WA,CGV17 LOOP BACK IF MORE TO GO
BRN CGV33 ELSE JUMP TO EXIT (NOT CONSTANT)
*
* HERE FOR BINARY OPS WITH VALUE OPERANDS
*
CGV18 MOV CMLOP(XL),XR LOAD LEFT OPERAND POINTER
JSR CDGVL GEN VALUE CODE FOR LEFT OPERAND
*
* HERE FOR UNARY OPS WITH VALUE OPERAND (BINOPS MERGE)
*
CGV19 MOV CMROP(XL),XR LOAD RIGHT (ONLY) OPERAND PTR
JSR CDGVL GEN CODE BY VALUE
EJC
*
* CDGVL (CONTINUED)
*
* MERGE HERE TO GENERATE OPERATOR CALL FROM CMOPN FIELD
*
CGV20 MOV CMOPN(XL),WA LOAD OPERATOR CALL POINTER
BRN CGV36 JUMP TO GENERATE IT WITH CONS TEST
*
* HERE FOR ASSIGNMENT
*
CGV21 MOV CMLOP(XL),XR LOAD LEFT OPERAND POINTER
BLO (XR),=B$VR$,CGV22 JUMP IF NOT VARIABLE
*
* HERE FOR ASSIGNMENT TO SIMPLE VARIABLE
*
MOV CMROP(XL),XR LOAD RIGHT OPERAND PTR
JSR CDGVL GENERATE CODE BY VALUE
MOV CMLOP(XL),WA RELOAD LEFT OPERAND VRBLK PTR
ADD *VRSTO,WA POINT TO VRSTO FIELD
BRN CGV32 JUMP TO GENERATE STORE PTR
*
* HERE IF NOT SIMPLE VARIABLE ASSIGNMENT
*
CGV22 JSR EXPAP TEST FOR PATTERN MATCH ON LEFT SIDE
PPM CGV23 JUMP IF NOT PATTERN MATCH
*
* HERE FOR PATTERN REPLACEMENT
*
MOV CMROP(XR),CMLOP(XL) SAVE PATTERN PTR IN SAFE PLACE
MOV CMLOP(XR),XR LOAD SUBJECT PTR
JSR CDGNM GEN CODE BY NAME FOR SUBJECT
MOV CMLOP(XL),XR LOAD PATTERN PTR
JSR CDGVL GEN CODE BY VALUE FOR PATTERN
MOV =OPMN$,WA LOAD MATCH BY NAME CALL
JSR CDWRD GENERATE IT
MOV CMROP(XL),XR LOAD REPLACEMENT VALUE PTR
JSR CDGVL GEN CODE BY VALUE
MOV =ORPL$,WA LOAD REPLACE CALL
BRN CGV32 JUMP TO GEN AND EXIT (NOT CONSTANT)
*
* HERE FOR ASSIGNMENT TO COMPLEX VARIABLE
*
CGV23 MNZ WC INHIBIT PRE-EVALUATION
JSR CDGNM GEN CODE BY NAME FOR LEFT SIDE
BRN CGV31 MERGE WITH UNOP CIRCUIT
EJC
*
* CDGVL (CONTINUED)
*
* HERE FOR CONCATENATION
*
CGV24 MOV CMLOP(XL),XR LOAD LEFT OPERAND PTR
BNE (XR),=B$CMT,CGV18 ORDINARY BINOP IF NOT CMBLK
MOV CMTYP(XR),WB LOAD CMBLK TYPE CODE
BEQ WB,=C$INT,CGV25 SPECIAL CASE IF INTERROGATION
BEQ WB,=C$NEG,CGV25 OR NEGATION
BNE WB,=C$FNC,CGV18 ELSE ORDINARY BINOP IF NOT FUNCTION
MOV CMOPN(XR),XR ELSE LOAD FUNCTION VRBLK PTR
BNZ VRLEN(XR),CGV18 ORDINARY BINOP IF NOT SYSTEM VAR
MOV VRSVP(XR),XR ELSE POINT TO SVBLK
MOV SVBIT(XR),WA LOAD BIT INDICATORS
ANB BTPRD,WA TEST FOR PREDICATE FUNCTION
ZRB WA,CGV18 ORDINARY BINOP IF NOT
*
* HERE IF LEFT ARG OF CONCATENATION IS PREDICATE FUNCTION
*
CGV25 MOV CMLOP(XL),XR RELOAD LEFT ARG
JSR CDGVL GEN CODE BY VALUE
MOV =OPOP$,WA LOAD POP CALL
JSR CDWRD GENERATE IT
MOV CMROP(XL),XR LOAD RIGHT OPERAND
JSR CDGVL GEN CODE BY VALUE AS RESULT CODE
BRN CGV33 EXIT (NOT CONSTANT)
*
* HERE TO GENERATE CODE FOR PATTERN, IMMEDIATE ASSIGNMENT
*
CGV26 MOV CMLOP(XL),XR LOAD LEFT OPERAND
JSR CDGVL GEN CODE BY VALUE, MERGE
*
* HERE FOR UNOPS WITH ARG BY NAME (BINARY $ . MERGE)
*
CGV27 MOV CMROP(XL),XR LOAD RIGHT OPERAND PTR
JSR CDGNM GEN CODE BY NAME FOR RIGHT ARG
MOV CMOPN(XL),XR GET OPERATOR CODE WORD
BNE (XR),=O$KWV,CGV20 GEN CALL UNLESS KEYWORD VALUE
EJC
*
* CDGVL (CONTINUED)
*
* HERE FOR KEYWORD BY VALUE. THIS IS CONSTANT ONLY IF
* THE OPERAND IS ONE OF THE SPECIAL SYSTEM VARIABLES WITH
* THE SVCKW BIT SET TO INDICATE A CONSTANT KEYWORD VALUE.
* NOTE THAT THE ONLY CONSTANT OPERAND BY NAME IS A VARIABLE
*
BNZ WC,CGV20 GEN CALL IF NON-CONSTANT (NOT VAR)
MNZ WC ELSE SET NON-CONSTANT IN CASE
MOV CMROP(XL),XR LOAD PTR TO OPERAND VRBLK
BNZ VRLEN(XR),CGV20 GEN (NON-CONSTANT) IF NOT SYS VAR
MOV VRSVP(XR),XR ELSE LOAD PTR TO SVBLK
MOV SVBIT(XR),WA LOAD BIT MASK
ANB BTCKW,WA TEST FOR CONSTANT KEYWORD
ZRB WA,CGV20 GO GEN IF NOT CONSTANT
ZER WC ELSE SET RESULT CONSTANT
BRN CGV20 AND JUMP BACK TO GENERATE CALL
*
* HERE TO GENERATE CODE FOR NEGATION
*
CGV28 MOV =ONTA$,WA GET INITIAL WORD
JSR CDWRD GENERATE IT
MOV CWCOF,WB SAVE NEXT OFFSET
JSR CDWRD GENERATE GUNK WORD FOR NOW
MOV CMROP(XL),XR LOAD RIGHT OPERAND PTR
JSR CDGVL GEN CODE BY VALUE
MOV =ONTB$,WA LOAD END OF EVALUATION CALL
JSR CDWRD GENERATE IT
MOV WB,XR COPY OFFSET TO WORD TO PLUG
ADD R$CCB,XR POINT TO ACTUAL WORD TO PLUG
MOV CWCOF,(XR) PLUG WORD WITH CURRENT OFFSET
MOV =ONTC$,WA LOAD FINAL CALL
BRN CGV32 JUMP TO GENERATE IT (NOT CONSTANT)
*
* HERE TO GENERATE CODE FOR UNDEFINED BINARY OPERATOR
*
CGV29 MOV CMLOP(XL),XR LOAD LEFT OPERAND PTR
JSR CDGVL GENERATE CODE BY VALUE
EJC
*
* CDGVL (CONTINUED)
*
* HERE TO GENERATE CODE FOR UNDEFINED UNARY OPERATOR
*
CGV30 MOV =C$UO$,WB SET UNOP CODE + 1
SUB CMTYP(XL),WB SET NUMBER OF ARGS (1 OR 2)
*
* MERGE HERE FOR UNDEFINED OPERATORS
*
MOV CMROP(XL),XR LOAD RIGHT (ONLY) OPERAND POINTER
JSR CDGVL GEN VALUE CODE FOR RIGHT OPERAND
MOV CMOPN(XL),XR LOAD POINTER TO OPERATOR DV
MOV DVOPN(XR),XR LOAD POINTER OFFSET
WTB XR CONVERT WORD OFFSET TO BAUS
ADD =R$UBA,XR POINT TO PROPER FUNCTION PTR
SUB *VRFNC,XR SET STANDARD FUNCTION OFFSET
BRN CGV12 MERGE WITH FUNCTION CALL CIRCUIT
*
* HERE TO GENERATE CODE FOR INTERROGATION, INDIRECTION
*
CGV31 MNZ WC SET NON CONSTANT
BRN CGV19 MERGE
*
* HERE TO EXIT GENERATING A WORD, RESULT NOT CONSTANT
*
CGV32 JSR CDWRD GENERATE WORD, MERGE
*
* HERE TO EXIT WITH NO WORD GENERATED, NOT CONSTANT
*
CGV33 MNZ WC INDICATE RESULT IS NOT CONSTANT
*
* COMMON EXIT POINT
*
CGV34 ICA XS POP INITIAL CODE OFFSET
MOV (XS)+,WA RESTORE OLD CONSTANT FLAG
MOV (XS)+,XL RESTORE ENTRY XL
MOV (XS)+,WB RESTORE ENTRY WB
BNZ WC,CGV35 JUMP IF NOT CONSTANT
MOV WA,WC ELSE RESTORE ENTRY CONSTANT FLAG
*
* HERE TO RETURN AFTER DEALING WITH WC SETTING
*
CGV35 EXI RETURN TO CDGVL CALLER
*
* EXIT HERE TO GENERATE WORD AND TEST FOR CONSTANT
*
CGV36 JSR CDWRD GENERATE WORD
BNZ WC,CGV34 JUMP TO EXIT IF NOT CONSTANT
EJC
*
* CDGVL (CONTINUED)
*
* HERE TO PREEVALUATE CONSTANT SUB-EXPRESSION
*
MOV =ORVL$,WA LOAD CALL TO RETURN VALUE
JSR CDWRD GENERATE IT
MOV (XS),XL LOAD INITIAL CODE OFFSET
JSR EXBLD BUILD EXBLK FOR EXPRESSION
ZER WB SET TO EVALUATE BY VALUE
JSR EVALX EVALUATE EXPRESSION
PPM SHOULD NOT FAIL
MOV (XR),WA LOAD TYPE WORD OF RESULT
BLO WA,=P$AAA,CGV37 JUMP IF NOT PATTERN
MOV =OLPT$,WA ELSE LOAD SPECIAL PATTERN LOAD CALL
JSR CDWRD GENERATE IT
*
* MERGE HERE TO GENERATE POINTER TO RESULTING CONSTANT
*
CGV37 MOV XR,WA COPY CONSTANT POINTER
JSR CDWRD GENERATE PTR
ZER WC SET RESULT CONSTANT
BRN CGV34 JUMP BACK TO EXIT
ENP END PROCEDURE CDGVL
EJC
*
* CDWRD -- GENERATE ONE WORD OF CODE
*
* CDWRD WRITES ONE WORD INTO THE CURRENT CODE BLOCK UNDER
* CONSTRUCTION. A NEW, LARGER, BLOCK IS ALLOCATED IF THERE
* IS INSUFFICIENT ROOM IN THE CURRENT BLOCK. CDWRD ENSURES
* THAT THERE ARE AT LEAST THREE WORDS LEFT IN THE BLOCK
* AFTER ENTERING THE NEW WORD. THIS GUARANTEES THAT ANY
* EXTRA SPACE AT THE END CAN BE SPLIT OFF AS A CCBLK.
*
* (WA) WORD TO BE GENERATED
* JSR CDWRD CALL TO GENERATE WORD
*
CDWRD PRC E,0 ENTRY POINT
MOV XR,-(XS) SAVE ENTRY XR
MOV WA,-(XS) SAVE CODE WORD TO BE GENERATED
*
* MERGE BACK HERE AFTER ALLOCATING LARGER BLOCK
*
CDWD1 MOV R$CCB,XR LOAD PTR TO CCBLK BEING BUILT
BNZ XR,CDWD2 JUMP IF BLOCK ALLOCATED
*
* HERE WE ALLOCATE AN ENTIRELY FRESH BLOCK
*
MOV *E$CBS,WA LOAD INITIAL LENGTH
JSR ALLOC ALLOCATE CCBLK
MOV =B$CCT,(XR) STORE TYPE WORD
MOV *CCCOD,CWCOF SET INITIAL OFFSET
MOV WA,CCLEN(XR) STORE BLOCK LENGTH
MOV XR,R$CCB STORE PTR TO NEW BLOCK
*
* HERE WE HAVE A BLOCK WE CAN USE
*
CDWD2 MOV CWCOF,WA LOAD CURRENT OFFSET
ADD *NUM04,WA ADJUST FOR TEST (FOUR WORDS)
BLO WA,CCLEN(XR),CDWD4 JUMP IF ROOM IN THIS BLOCK
*
* HERE IF NO ROOM IN CURRENT BLOCK
*
BGE WA,MXLEN,CDWD5 JUMP IF ALREADY AT MAX SIZE
ADD *E$CBS,WA ELSE GET NEW SIZE
MOV XL,-(XS) SAVE ENTRY XL
MOV XR,XL COPY POINTER
BLT WA,MXLEN,CDWD3 JUMP IF NOT TOO LARGE
MOV MXLEN,WA ELSE RESET TO MAX ALLOWED SIZE
EJC
*
* CDWRD (CONTINUED)
*
* HERE WITH NEW BLOCK SIZE IN WA
*
CDWD3 JSR ALLOC ALLOCATE NEW BLOCK
MOV XR,R$CCB STORE POINTER TO NEW BLOCK
MOV =B$CCT,(XR)+ STORE TYPE WORD IN NEW BLOCK
MOV WA,(XR)+ STORE BLOCK LENGTH
ADD *CCUSE,XL POINT TO CCUSE,CCCOD FIELDS IN OLD
MOV (XL),WA LOAD CCUSE VALUE
MVW COPY USEFUL WORDS FROM OLD BLOCK
MOV (XS)+,XL RESTORE XL
BRN CDWD1 MERGE BACK TO TRY AGAIN
*
* HERE WITH ROOM IN CURRENT BLOCK
*
CDWD4 MOV CWCOF,WA LOAD CURRENT OFFSET
ICA WA GET NEW OFFSET
MOV WA,CWCOF STORE NEW OFFSET
MOV WA,CCUSE(XR) STORE IN CCBLK FOR GBCOL
DCA WA RESTORE PTR TO THIS WORD
ADD WA,XR POINT TO CURRENT ENTRY
MOV (XS)+,WA RELOAD WORD TO GENERATE
MOV WA,(XR) STORE WORD IN BLOCK
MOV (XS)+,XR RESTORE ENTRY XR
EXI RETURN TO CALLER
*
* HERE IF COMPILED CODE IS TOO LONG FOR CDBLK
*
CDWD5 ERB 209,SYNTAX ERROR. STATEMENT IS TOO COMPLICATED.
ENP END PROCEDURE CDWRD
EJC
*
* CMGEN -- GENERATE CODE FOR CMBLK PTR
*
* CMGEN IS A SUBSIDIARY PROCEDURE USED TO GENERATE VALUE
* CODE FOR A CMBLK PTR FROM THE MAIN CODE GENERATORS.
*
* (XL) CMBLK POINTER
* (WB) OFFSET TO POINTER IN CMBLK
* JSR CMGEN CALL TO GENERATE CODE
* (XR,WA) DESTROYED
* (WB) BUMPED BY ONE WORD
*
CMGEN PRC R,0 ENTRY POINT, RECURSIVE
MOV XL,XR COPY CMBLK POINTER
ADD WB,XR POINT TO CMBLK POINTER
MOV (XR),XR LOAD CMBLK POINTER
JSR CDGVL GENERATE CODE BY VALUE
ICA WB BUMP OFFSET
EXI RETURN TO CALLER
ENP END PROCEDURE CMGEN
EJC
*
* CMPIL (COMPILE SOURCE CODE)
*
* CMPIL IS USED TO CONVERT SNOBOL4 SOURCE CODE TO INTERNAL
* FORM (SEE CDBLK FORMAT). IT IS USED BOTH FOR THE INITIAL
* COMPILE AND AT RUN TIME BY THE CODE AND CONVERT FUNCTIONS
* THIS PROCEDURE HAS CONTROL FOR THE ENTIRE DURATION OF
* INITIAL COMPILATION. AN ERROR IN ANY PROCEDURE CALLED
* DURING COMPILATION WILL LEAD FIRST TO THE ERROR SECTION
* AND ULTIMATELY BACK HERE FOR RESUMED COMPILATION. THE
* RE-ENTRY POINTS AFTER AN ERROR ARE SPECIALLY LABELLED -
*
* CMPCE RESUME AFTER CONTROL CARD ERROR
* CMPLE RESUME AFTER LABEL ERROR
* CMPSE RESUME AFTER STATEMENT ERROR
*
* JSR CMPIL CALL TO COMPILE CODE
* (XR) PTR TO CDBLK FOR ENTRY STATEMENT
* (XL,WA,WB,WC,RA) DESTROYED
*
* THE FOLLOWING GLOBAL VARIABLES ARE REFERENCED
*
* CMPSN NUMBER OF NEXT STATEMENT
* TO BE COMPILED.
*
* CSWXX CONTROL CARD SWITCH VALUES ARE
* CHANGED WHEN RELEVANT CONTROL
* CARDS ARE MET.
*
* CWCOF OFFSET TO NEXT WORD IN CODE BLOCK
* BEING BUILT (SEE CDWRD).
*
* LSTSN NUMBER OF STATEMENT MOST RECENTLY
* COMPILED (INITIALLY SET TO ZERO).
*
* R$CIM CURRENT (INITIAL) COMPILER IMAGE
* (ZERO FOR INITIAL COMPILE CALL)
*
* R$CNI USED TO POINT TO FOLLOWING IMAGE.
* (SEE READR PROCEDURE).
*
* SCNGO GOTO SWITCH FOR SCANE PROCEDURE
*
* SCNIL LENGTH OF CURRENT IMAGE EXCLUDING
* CHARACTERS REMOVED BY -INPUT.
*
* SCNPT CURRENT SCAN OFFSET, SEE SCANE.
*
* SCNRS RESCAN SWITCH FOR SCANE PROCEDURE.
*
* SCNSE OFFSET (IN R$CIM) OF MOST RECENTLY
* SCANNED ELEMENT. SET ZERO IF NOT
* CURRENTLY SCANNING ITEMS
EJC
*
* CMPIL (CONTINUED)
*
* STAGE STGIC INITIAL COMPILE IN PROGRESS
* STGXC CODE/CONVERT COMPILE
* STGEV BUILDING EXBLK FOR EVAL
* STGXT EXECUTE TIME (OUTSIDE COMPILE)
* STGCE INITIAL COMPILE AFTER END LINE
* STGXE EXECUTE COMPILE AFTER END LINE
*
* CMPIL ALSO USES A FIXED NUMBER OF LOCATIONS ON THE
* MAIN STACK AS FOLLOWS. (THE DEFINITIONS OF THE ACTUAL
* OFFSETS ARE IN THE DEFINITIONS SECTION).
*
* CMSTM(XS) POINTER TO EXPAN TREE FOR BODY OF
* STATEMENT (SEE EXPAN PROCEDURE).
*
* CMSGO(XS) POINTER TO TREE REPRESENTATION OF
* SUCCESS GOTO (SEE PROCEDURE SCNGO)9
* ZERO IF NO SUCCESS GOTO IS GIVEN
*
* CMFGO(XS) LIKE CMSGO FOR FAILURE GOTO.
*
* CMCGO(XS) SET NON-ZERO ONLY IF THERE IS A
* CONDITIONAL GOTO. USED FOR -FAIL,
* -NOFAIL CODE GENERATION.
*
* CMPCD(XS) POINTER TO CDBLK FOR PREVIOUS
* STATEMENT. ZERO FOR 1ST STATEMENT.
*
* CMFFP(XS) SET NON-ZERO IF CDFAL IN PREVIOUS
* CDBLK NEEDS FILLING WITH FORWARD
* POINTER, ELSE SET TO ZERO.
*
* CMFFC(XS) SAME AS CMFFP FOR CURRENT CDBLK
*
* CMSOP(XS) OFFSET TO WORD IN PREVIOUS CDBLK
* TO BE FILLED IN WITH FORWARD PTR
* TO NEXT CDBLK FOR SUCCESS GOTO.
* ZERO IF NO FILL IN IS REQUIRED.
*
* CMSOC(XS) SAME AS CMSOP FOR CURRENT CDBLK.
*
* CMLBL(XS) POINTER TO VRBLK FOR LABEL OF
* CURRENT STATEMENT. ZERO IF NO LABEL
*
* CMTRA(XS) POINTER TO CDBLK FOR ENTRY STMNT.
EJC
*
* CMPIL (CONTINUED)
*
* ENTRY POINT
*
CMPIL PRC E,0 ENTRY POINT
LCT WB,=CMNEN SET NUMBER OF STACK WORK LOCATIONS
*
* LOOP TO INITIALIZE STACK WORKING LOCATIONS
*
CMP00 ZER -(XS) STORE A ZERO, MAKE ONE ENTRY
BCT WB,CMP00 LOOP BACK UNTIL ALL SET
MOV XS,CMPXS SAVE STACK POINTER FOR ERROR SEC
SSS CMPSS SAVE S-R STACK POINTER IF ANY
*
* LOOP THROUGH STATEMENTS
*
CMP01 MOV SCNPT,WB SET SCAN POINTER OFFSET
MOV WB,SCNSE SET START OF ELEMENT LOCATION
MOV =OCER$,WA POINT TO COMPILE ERROR CALL
JSR CDWRD GENERATE AS TEMPORARY CDFAL
BLT WB,SCNIL,CMP04 JUMP IF CHARS LEFT ON THIS IMAGE
*
* LOOP HERE AFTER COMMENT OR CONTROL CARD
* ALSO SPECIAL ENTRY AFTER CONTROL CARD ERROR
*
CMPCE ZER XR CLEAR POSSIBLE GARBAGE XR VALUE
BEQ STAGE,=STGIC,CMPC1 READ IF INITIAL COMPILE
BZE R$COP,CMP02 ELSE SKIP IF NO -COPY IN FORCE
*
* HERE TO ATTEMPT READ (STGIC OR -COPY)
*
CMPC1 JSR READR READ NEXT INPUT IMAGE
BZE XR,CMPC2 JUMP IF NO INPUT AVAILABLE
JSR NEXTS ACQUIRE NEXT SOURCE IMAGE
MOV CMPSN,LSTSN STORE STMT NO FOR USE BY LISTR
ZER SCNPT RESET SCAN POINTER
BRN CMP04 GO PROCESS IMAGE
*
* HERE IF READR HAD NOTHING TO RETURN. IF NOT DURING
* INITIAL COMPILE, THEN MUST BE AT OUTER LEVEL OF -COPY
* IN CODE(). R$CIM HAS BEEN RESTORED TO CODE STRING
* BY COPND SO WE CONTINUE FROM THE -COPY STMT.
*
CMPC2 BEQ STAGE,=STGIC,CMP09 JUMP IF INITIAL COMPILE
*
* FOR EXECUTE TIME COMPILE, PERMIT EMBEDDED CONTROL CARDS
* AND COMMENTS (BY SKIPPING TO NEXT SEMI-COLON)
*
CMP02 MOV R$CIM,XR GET CURRENT IMAGE
MOV SCNPT,WB GET CURRENT OFFSET
PLC XR,WB PREPARE TO GET CHARS
*
* SKIP TO SEMI-COLON
*
CMP03 LCH WC,(XR)+ GET CHAR
ICV SCNPT ADVANCE OFFSET
BEQ WC,=CH$SM,CMP04 SKIP IF SEMI-COLON FOUND
BLT SCNPT,SCNIL,CMP03 LOOP IF MORE CHARS
ZER XR CLEAR GARBAGE XR VALUE
BRN CMP09 END OF IMAGE
EJC
*
* CMPIL (CONTINUED)
*
* HERE WITH IMAGE AVAILABLE TO SCAN. NOTE THAT IF THE INPUT
* STRING IS NULL, THEN EVERYTHING IS OK SINCE NULL IS
* ACTUALLY ASSEMBLED AS A WORD OF BLANKS.
*
CMP04 MOV R$CIM,XR POINT TO CURRENT IMAGE
MOV SCNPT,WB LOAD CURRENT OFFSET
MOV WB,WA COPY FOR LABEL SCAN
PLC XR,WB POINT TO FIRST CHARACTER
LCH WC,(XR)+ LOAD FIRST CHARACTER
BEQ WC,=CH$SM,CMP12 NO LABEL IF SEMICOLON
BEQ WC,=CH$AS,CMPCE LOOP BACK IF COMMENT CARD
BEQ WC,=CH$MN,CMP33 JUMP IF CONTROL CARD
MOV R$CIM,R$CMP ABOUT TO DESTROY R$CIM
MOV =CMLAB,XL POINT TO LABEL WORK STRING
MOV XL,R$CIM SCANE IS TO SCAN WORK STRING
PSC XL POINT TO FIRST CHARACTER POSITION
SCH WC,(XL)+ STORE CHAR JUST LOADED
MOV =CH$SM,WC GET A SEMICOLON
SCH WC,(XL) STORE AFTER FIRST CHAR
CSC XL FINISHED CHARACTER STORING
ZER XL CLEAR POINTER
ZER SCNPT START AT FIRST CHARACTER
MOV SCNIL,-(XS) PRESERVE IMAGE LENGTH
MOV =NUM02,SCNIL READ 2 CHARS AT MOST
JSR SCANE SCAN FIRST CHAR FOR TYPE
MOV (XS)+,SCNIL RESTORE IMAGE LENGTH
MOV XL,WC NOTE RETURN CODE
MOV R$CMP,XL GET OLD R$CIM
MOV XL,R$CIM PUT IT BACK
MOV WB,SCNPT REINSTATE OFFSET
BNZ SCNBL,CMP12 BLANK SEEN - CANT BE LABEL
MOV XL,XR POINT TO CURRENT IMAGE
PLC XR,WB POINT TO FIRST CHAR AGAIN
BEQ WC,=T$VAR,CMP06 OK IF LETTER
BEQ WC,=T$CON,CMP06 OK IF DIGIT
*
* DROP IN OR JUMP FROM ERROR SECTION IF SCANE FAILED
*
CMPLE MOV R$CMP,R$CIM POINT TO BAD LINE
ERB 210,BAD LABEL OR MISPLACED CONTINUATION LINE
*
* LOOP TO SCAN LABEL
*
CMP05 BEQ WC,=CH$SM,CMP07 SKIP IF SEMICOLON
ICV WA BUMP OFFSET
BEQ WA,SCNIL,CMP07 JUMP IF END OF IMAGE (LABEL END)
EJC
*
* CMPIL (CONTINUED)
*
* ENTER LOOP AT THIS POINT
*
CMP06 LCH WC,(XR)+ ELSE LOAD NEXT CHARACTER
.IF .CAHT
BEQ WC,=CH$HT,CMP07 JUMP IF HORIZONTAL TAB
.FI
.IF .CAVT
BEQ WC,=CH$VT,CMP07 JUMP IF VERTICAL TAB
.FI
BNE WC,=CH$BL,CMP05 LOOP BACK IF NON-BLANK
*
* HERE AFTER SCANNING OUT LABEL
*
CMP07 MOV WA,SCNPT SAVE UPDATED SCAN OFFSET
SUB WB,WA GET LENGTH OF LABEL
BZE WA,CMP12 SKIP IF LABEL LENGTH ZERO
ZER XR CLEAR GARBAGE XR VALUE
JSR SBSTR BUILD SCBLK FOR LABEL NAME
JSR GTNVR LOCATE/CONTRUCT VRBLK
PPM DUMMY (IMPOSSIBLE) ERROR RETURN
MOV XR,CMLBL(XS) STORE LABEL POINTER
BNZ VRLEN(XR),CMP11 JUMP IF NOT SYSTEM LABEL
BNE VRSVP(XR),=V$END,CMP11 JUMP IF NOT END LABEL
*
* HERE FOR END LABEL SCANNED OUT
*
ADD =STGND,STAGE ADJUST STAGE APPROPRIATELY
JSR SCANE SCAN OUT NEXT ELEMENT
BEQ XL,=T$SMC,CMPEE JUMP IF END OF IMAGE
BNE XL,=T$VAR,CMP08 ELSE ERROR IF NOT VARIABLE
*
* HERE CHECK FOR VALID INITIAL TRANSFER
*
BEQ VRLBL(XR),=STNDL,CMP08 JUMP IF NOT DEFINED (ERROR)
MOV VRLBL(XR),CMTRA(XS) ELSE SET INITIAL ENTRY POINTER
JSR SCANE SCAN NEXT ELEMENT
BEQ XL,=T$SMC,CMPEE JUMP IF OK (END OF IMAGE)
*
* HERE FOR BAD TRANSFER LABEL
*
CMP08 ERB 211,SYNTAX ERROR. UNDEFINED OR ERRONEOUS ENTRY LABEL
*
* HERE FOR END OF INPUT (NO END LABEL DETECTED)
*
CMP09 ADD =STGND,STAGE ADJUST STAGE APPROPRIATELY
BEQ STAGE,=STGXE,CMPEE JUMP IF CODE CALL (OK)
ERB 212,SYNTAX ERROR. MISSING END LINE
*
* HERE AFTER PROCESSING END LINE (MERGE HERE ON END ERROR)
*
CMPEE MOV =OSTP$,WA SET STOP CALL POINTER
JSR CDWRD GENERATE AS STATEMENT CALL
BRN CMPSE JUMP TO GENERATE AS FAILURE
EJC
*
* CMPIL (CONTINUED)
*
* HERE AFTER PROCESSING LABEL OTHER THAN END
*
CMP11 BNE STAGE,=STGIC,CMP12 JUMP IF CODE CALL - REDEF. OK
BEQ VRLBL(XR),=STNDL,CMP12 ELSE CHECK FOR REDEFINITION
ZER CMLBL(XS) LEAVE FIRST LABEL DECLN UNDISTURBED
ERB 213,SYNTAX ERROR. DUPLICATE LABEL
*
* HERE AFTER DEALING WITH LABEL
*
CMP12 ZER WB SET FLAG FOR STATEMENT BODY
JSR EXPAN GET TREE FOR STATEMENT BODY
MOV XR,CMSTM(XS) STORE FOR LATER USE
ZER CMSGO(XS) CLEAR SUCCESS GOTO POINTER
ZER CMFGO(XS) CLEAR FAILURE GOTO POINTER
ZER CMCGO(XS) CLEAR CONDITIONAL GOTO FLAG
JSR SCANE SCAN NEXT ELEMENT
BNE XL,=T$COL,CMP18 JUMP IT NOT COLON (NO GOTO)
*
* LOOP TO PROCESS GOTO FIELDS
*
CMP13 MNZ SCNGO SET GOTO FLAG
JSR SCANE SCAN NEXT ELEMENT
BEQ XL,=T$SMC,CMP32 JUMP IF NO FIELDS LEFT
BEQ XL,=T$SGO,CMP14 JUMP IF S FOR SUCCESS GOTO
BEQ XL,=T$FGO,CMP16 JUMP IF F FOR FAILURE GOTO
*
* HERE FOR UNCONDITIONAL GOTO (I.E. NOT F OR S)
*
MNZ SCNRS SET TO RESCAN ELEMENT NOT F,S
JSR SCNGF SCAN OUT GOTO FIELD
BNZ CMFGO(XS),CMP17 ERROR IF FGOTO ALREADY
MOV XR,CMFGO(XS) ELSE SET AS FGOTO
BRN CMP15 MERGE WITH SGOTO CIRCUIT
*
* HERE FOR SUCCESS GOTO
*
CMP14 JSR SCNGF SCAN SUCCESS GOTO FIELD
MOV =NUM01,CMCGO(XS) SET CONDITIONAL GOTO FLAG
*
* UNCONTIONAL GOTO MERGES HERE
*
CMP15 BNZ CMSGO(XS),CMP17 ERROR IF SGOTO ALREADY GIVEN
MOV XR,CMSGO(XS) ELSE SET SGOTO
BRN CMP13 LOOP BACK FOR NEXT GOTO FIELD
*
* HERE FOR FAILURE GOTO
*
CMP16 JSR SCNGF SCAN GOTO FIELD
MOV =NUM01,CMCGO(XS) SET CONDITONAL GOTO FLAG
BNZ CMFGO(XS),CMP17 ERROR IF FGOTO ALREADY GIVEN
MOV XR,CMFGO(XS) ELSE STORE FGOTO POINTER
BRN CMP13 LOOP BACK FOR NEXT FIELD
EJC
*
* CMPIL (CONTINUED)
*
* HERE FOR DUPLICATED GOTO FIELD
*
CMP17 ERB 214,SYNTAX ERROR. DUPLICATED GOTO FIELD
*
* HERE TO GENERATE CODE
*
CMP18 ZER SCNSE STOP POSITIONAL ERROR FLAGS
MOV CMSTM(XS),XR LOAD TREE PTR FOR STATEMENT BODY
ZER WB COLLECTABLE VALUE FOR WB FOR CDGVL
ZER WC RESET CONSTANT FLAG FOR CDGVL
JSR EXPAP TEST FOR PATTERN MATCH
PPM CMP19 JUMP IF NOT PATTERN MATCH
MOV =OPMS$,CMOPN(XR) ELSE SET PATTERN MATCH POINTER
MOV =C$PMT,CMTYP(XR)
*
* HERE AFTER DEALING WITH SPECIAL PATTERN MATCH CASE
*
CMP19 JSR CDGVL GENERATE CODE FOR BODY OF STATEMENT
MOV CMSGO(XS),XR LOAD SGOTO POINTER
MOV XR,WA COPY IT
BZE XR,CMP21 JUMP IF NO SUCCESS GOTO
ZER CMSOC(XS) CLEAR SUCCESS OFFSET FILLIN PTR
BHI XR,STATE,CMP20 JUMP IF COMPLEX GOTO
*
* HERE FOR SIMPLE SUCCESS GOTO (LABEL)
*
ADD *VRTRA,WA POINT TO VRTRA FIELD AS REQUIRED
JSR CDWRD GENERATE SUCCESS GOTO
BRN CMP22 JUMP TO DEAL WITH FGOTO
*
* HERE FOR COMPLEX SUCCESS GOTO
*
CMP20 BEQ XR,CMFGO(XS),CMP22 NO CODE IF SAME AS FGOTO
ZER WB ELSE SET OK VALUE FOR CDGVL IN WB
JSR CDGCG GENERATE CODE FOR SUCCESS GOTO
BRN CMP22 JUMP TO DEAL WITH FGOTO
*
* HERE FOR NO SUCCESS GOTO
*
CMP21 MOV CWCOF,CMSOC(XS) SET SUCCESS FILL IN OFFSET
MOV =OCER$,WA POINT TO COMPILE ERROR CALL
JSR CDWRD GENERATE AS TEMPORARY VALUE
EJC
*
* CMPIL (CONTINUED)
*
* HERE TO DEAL WITH FAILURE GOTO
*
CMP22 MOV CMFGO(XS),XR LOAD FAILURE GOTO POINTER
MOV XR,WA COPY IT
ZER CMFFC(XS) SET NO FILL IN REQUIRED YET
BZE XR,CMP23 JUMP IF NO FAILURE GOTO GIVEN
ADD *VRTRA,WA POINT TO VRTRA FIELD IN CASE
BLO XR,STATE,CMPSE JUMP TO GEN IF SIMPLE FGOTO
*
* HERE FOR COMPLEX FAILURE GOTO
*
MOV CWCOF,WB SAVE OFFSET TO O$GOF CALL
MOV =OGOF$,WA POINT TO FAILURE GOTO CALL
JSR CDWRD GENERATE
MOV =OFIF$,WA POINT TO FAIL IN FAIL WORD
JSR CDWRD GENERATE
JSR CDGCG GENERATE CODE FOR FAILURE GOTO
MOV WB,WA COPY OFFSET TO O$GOF FOR CDFAL
MOV =B$CDC,WB SET COMPLEX CASE CDTYP
BRN CMP25 JUMP TO BUILD CDBLK
*
* HERE IF NO FAILURE GOTO GIVEN
*
CMP23 MOV =OUNF$,WA LOAD UNEXPECTED FAILURE CALL IN CAS
MOV CSWFL,WC GET -NOFAIL FLAG
ORB CMCGO(XS),WC CHECK IF CONDITIONAL GOTO
ZRB WC,CMPSE JUMP IF -NOFAIL AND NO COND. GOTO
MNZ CMFFC(XS) ELSE SET FILL IN FLAG
MOV =OCER$,WA AND SET COMPILE ERROR FOR TEMPORARY
*
* MERGE HERE WITH CDFAL VALUE IN WA, SIMPLE CDBLK
* ALSO SPECIAL ENTRY AFTER STATEMENT ERROR
*
CMPSE MOV =B$CDS,WB SET CDTYP FOR SIMPLE CASE
EJC
*
* CMPIL (CONTINUED)
*
* MERGE HERE TO BUILD CDBLK
*
* (WA) CDFAL VALUE TO BE GENERATED
* (WB) CDTYP VALUE TO BE GENERATED
*
* AT THIS STAGE, WE CHOP OFF AN APPROPRIATE CHUNK OF THE
* CURRENT CCBLK AND CONVERT IT INTO A CDBLK. THE REMAINDER
* OF THE CCBLK IS REFORMATTED TO BE THE NEW CCBLK.
*
CMP25 MOV R$CCB,XR POINT TO CCBLK
MOV CMLBL(XS),XL GET POSSIBLE LABEL POINTER
BZE XL,CMP26 SKIP IF NO LABEL
ZER CMLBL(XS) CLEAR FLAG FOR NEXT STATEMENT
MOV XR,VRLBL(XL) PUT CDBLK PTR IN VRBLK LABEL FIELD
*
* MERGE AFTER DOING LABEL
*
CMP26 MOV WB,(XR) SET TYPE WORD FOR NEW CDBLK
MOV WA,CDFAL(XR) SET FAILURE WORD
MOV XR,XL COPY POINTER TO CCBLK
MOV CCUSE(XR),WB LOAD LENGTH GEN (= NEW CDLEN)
MOV CCLEN(XR),WC LOAD TOTAL CCBLK LENGTH
ADD WB,XL POINT PAST CDBLK
SUB WB,WC GET LENGTH LEFT FOR CHOP OFF
MOV =B$CCT,(XL) SET TYPE CODE FOR NEW CCBLK AT END
MOV *CCCOD,CCUSE(XL) SET INITIAL CODE OFFSET
MOV *CCCOD,CWCOF REINITIALISE CWCOF
MOV WC,CCLEN(XL) SET NEW LENGTH
MOV XL,R$CCB SET NEW CCBLK POINTER
MOV CMPSN,CDSTM(XR) SET STATEMENT NUMBER
ICV CMPSN BUMP STATEMENT NUMBER
*
* SET POINTERS IN PREVIOUS CODE BLOCK AS REQUIRED
*
MOV CMPCD(XS),XL LOAD PTR TO PREVIOUS CDBLK
BZE CMFFP(XS),CMP27 JUMP IF NO FAILURE FILL IN REQUIRED
MOV XR,CDFAL(XL) ELSE SET FAILURE PTR IN PREVIOUS
*
* HERE TO DEAL WITH SUCCESS FORWARD POINTER
*
CMP27 MOV CMSOP(XS),WA LOAD SUCCESS OFFSET
BZE WA,CMP28 JUMP IF NO FILL IN REQUIRED
ADD WA,XL ELSE POINT TO FILL IN LOCATION
MOV XR,(XL) STORE FORWARD POINTER
ZER XL CLEAR GARBAGE XL VALUE
EJC
*
* CMPIL (CONTINUED)
*
* NOW SET FILL IN POINTERS FOR THIS STATEMENT
*
CMP28 MOV CMFFC(XS),CMFFP(XS) COPY FAILURE FILL IN FLAG
MOV CMSOC(XS),CMSOP(XS) COPY SUCCESS FILL IN OFFSET
MOV XR,CMPCD(XS) SAVE PTR TO THIS CDBLK
BNZ CMTRA(XS),CMP29 JUMP IF INITIAL ENTRY ALREADY SET
MOV XR,CMTRA(XS) ELSE SET PTR HERE AS DEFAULT
*
* HERE AFTER COMPILING ONE STATEMENT
*
CMP29 BLT STAGE,=STGCE,CMP01 JUMP IF NOT END LINE JUST DONE
BZE CSWLS,CMP30 SKIP IF -NOLIST
JSR LISTR LIST LAST LINE
*
* RETURN
*
CMP30 MOV CMTRA(XS),XR LOAD INITIAL ENTRY CDBLK POINTER
ADD *CMNEN,XS POP WORK LOCATIONS OFF STACK
*
* LOOP TO UNNEST ANY OUTSTANDING -COPY LEVELS
*
CMP31 JSR COPND CALL TO UNNEST -COPY
BNZ R$COP,CMP31 LOOP IF NOT ALL -COPYS CLOSED
EXI RETURN TO CMPIL CALLER
*
* HERE AT END OF GOTO FIELD
*
CMP32 MOV CMFGO(XS),WB GET FAIL GOTO
ORB CMSGO(XS),WB OR IN SUCCESS GOTO
BNZ WB,CMP18 OK IF NON-NULL FIELD
ERB 215,SYNTAX ERROR. EMPTY GOTO FIELD
*
* CONTROL CARD FOUND
*
CMP33 ICV WB POINT PAST CH$MN
JSR CNCRD PROCESS CONTROL CARD
ZER SCNSE CLEAR START OF ELEMENT LOC.
BRN CMPCE LOOP FOR NEXT STATEMENT
ENP END PROCEDURE CMPIL
EJC
*
* CNCRD -- CONTROL CARD PROCESSOR
*
* CALLED TO DEAL WITH CONTROL CARDS
*
* R$CIM POINTS TO CURRENT IMAGE
* (WB) OFFSET TO 1ST CHAR OF CONTROL CARD
* JSR CNCRD CALL TO PROCESS CONTROL CARDS
* (XL,XR,WA,WB,WC,IA) DESTROYED
*
CNCRD PRC E,0 ENTRY POINT
MOV WB,SCNPT OFFSET FOR CONTROL CARD SCAN
MOV =CCNOC,WA NUMBER OF CHARS FOR COMPARISON
CTW WA,0 CONVERT TO WORD COUNT
MOV WA,CNSWC SAVE WORD COUNT
*
* LOOP HERE IF MORE THAN ONE CONTROL CARD
*
CNC01 BGE SCNPT,SCNIL,CNC10 RETURN IF END OF IMAGE
MOV R$CIM,XR POINT TO IMAGE
PLC XR,SCNPT CHAR PTR FOR FIRST CHAR
LCH WA,(XR)+ GET FIRST CHAR
BEQ WA,=CH$LI,CNC07 SPECIAL CASE OF -INXXX
.IF .CASL
BEQ WA,=CH$$I,CNC07 DITTO (LC)
.FI
MNZ SCNCC SET FLAG FOR SCANE
JSR SCANE SCAN CARD NAME
ZER SCNCC CLEAR SCANE FLAG
BNZ XL,CNC06 FAIL UNLESS CONTROL CARD NAME
MOV =CCNOC,WA NO. OF CHARS TO BE COMPARED
BLT SCLEN(XR),WA,CNC06 FAIL IF TOO FEW CHARS
MOV XR,XL POINT TO CONTROL CARD NAME
ZER WB ZERO OFFSET FOR SUBSTRING
.IF .CASL
JSR SBSCC CONVERT CASE BEFORE COMPARISON
.ELSE
JSR SBSTR EXTRACT SUBSTRING FOR COMPARISON
.FI
MOV XR,CNSCC KEEP CONTROL CARD SUBSTRING PTR
MOV =CCNMS,XR POINT TO LIST OF STANDARD NAMES
ZER WB INITIALISE NAME OFFSET
LCT WC,=CC$CT NUMBER OF STANDARD NAMES
*
* TRY TO MATCH NAME
*
CNC02 MOV CNSCC,XL POINT TO NAME
LCT WA,CNSWC COUNTER FOR INNER LOOP
BRN CNC04 JUMP INTO LOOP
*
* INNER LOOP TO MATCH CARD NAME CHARS
*
CNC03 ICA XR BUMP STANDARD NAMES PTR
ICA XL BUMP NAME POINTER
*
* HERE TO INITIATE THE LOOP
*
CNC04 CNE SCHAR(XL),(XR),CNC05 COMP. UP TO CFP$C CHARS AT ONCE
BCT WA,CNC03 LOOP IF MORE WORDS TO COMPARE
EJC
*
* CNCRD (CONTINUED)
*
* MATCHED - BRANCH ON CARD OFFSET
*
MOV WB,XL GET NAME OFFSET
BSW XL,CC$CT SWITCH
.IF .CASL
IFF CC$CI,CNC11 -CASEIG
.FI
IFF CC$CO,CNC23 -COPY
IFF CC$EJ,CNC12 -EJECT
IFF CC$FA,CNC13 -FAIL
IFF CC$LI,CNC14 -LIST
.IF .CASL
IFF CC$NC,CNC15 -NOCASEIG
.FI
IFF CC$NF,CNC16 -NOFAIL
IFF CC$NL,CNC17 -NOLIST
IFF CC$ST,CNC18 -STITLE
IFF CC$TI,CNC19 -TITLE
IFF CC$TR,CNC22 -TRACE
ESW END SWITCH
*
* NOT MATCHED YET. ALIGN STD NAMES PTR AND TRY AGAIN
*
CNC05 ICA XR BUMP STANDARD NAMES PTR
BCT WA,CNC05 LOOP
ICV WB BUMP NAMES OFFSET
BCT WC,CNC02 CONTINUE IF MORE NAMES
*
* INVALID CONTROL CARD NAME
*
CNC06 ERB 216,INVALID CONTROL CARD
*
* SPECIAL PROCESSING FOR -INXXX
*
CNC07 LCH WA,(XR) GET NEXT CHAR
.IF .CASL
BEQ WA,=CH$$N,CNC08 SKIP IF LC N
.FI
BNE WA,=CH$LN,CNC06 FAIL IF NOT LETTER N
.IF .CASL
CNC08 ADD =NUM02,SCNPT BUMP OFFSET PAST -IN
.ELSE
ADD =NUM02,SCNPT BUMP OFFSET PAST -IN
.FI
JSR SCANE SCAN INTEGER AFTER -IN
MOV XR,-(XS) STACK SCANNED ITEM
JSR GTSMI CHECK IF INTEGER
PPM CNC06 FAIL IF NOT INTEGER
PPM CNC06 FAIL IF NEGATIVE OR LARGE
MOV XR,CSWIN KEEP INTEGER
EJC
*
* CNCRD (CONTINUED)
*
* CHECK FOR MORE CONTROL CARDS BEFORE RETURNING
*
CNC09 MOV SCNPT,WA PRESERVE IN CASE XEQ TIME COMPILE
JSR SCANE LOOK FOR COMMA
BEQ XL,=T$CMA,CNC01 LOOP IF COMMA FOUND
MOV WA,SCNPT RESTORE SCNPT IN CASE XEQ TIME
*
* RETURN POINT
*
CNC10 EXI RETURN
.IF .CASL
*
* -CASEIG
*
CNC11 MNZ CSWCI SET SWITCH
BRN CNC09 MERGE
.FI
*
* -EJECT
*
CNC12 BZE CSWLS,CNC10 RETURN IF -NOLIST
JSR PRTPS EJECT
JSR LISTT LIST TITLE
BRN CNC10 FINISHED
*
* -FAIL
*
CNC13 MNZ CSWFL SET SWITCH
BRN CNC09 MERGE
*
* -LIST
*
CNC14 MNZ CSWLS SET SWITCH
BRN CNC09 MERGE
.IF .CASL
*
* -NOCASEIG
*
CNC15 ZER CSWCI CLEAR SWITCH
BRN CNC09 MERGE
.FI
*
* -NOFAIL
*
CNC16 ZER CSWFL CLEAR SWITCH
BRN CNC09 MERGE
EJC
*
* CNCRD (CONTINUED)
*
* -NOLIST
*
CNC17 ZER CSWLS CLEAR SWITCH
BRN CNC09 MERGE
*
* -STITL
*
CNC18 MOV =R$STL,CNR$T PTR TO R$STL
BRN CNC20 MERGE
*
* -TITLE
*
CNC19 MOV =NULLS,R$STL CLEAR SUBTITLE
MOV =R$TTL,CNR$T PTR TO R$TTL
*
* COMMON PROCESSING FOR -TITLE, -STITL
*
CNC20 MOV =NULLS,XR NULL IN CASE NEEDED
MNZ CNTTL SET FLAG FOR NEXT LISTR CALL
MOV =CCOFS,WB OFFSET TO TITLE/SUBTITLE
MOV SCNIL,WA INPUT IMAGE LENGTH
BLO WA,WB,CNC21 JUMP IF NO CHARS LEFT
SUB WB,WA NO OF CHARS TO EXTRACT
MOV R$CIM,XL POINT TO IMAGE
JSR SBSTR GET TITLE/SUBTITLE
*
* STORE TITLE/SUBTITLE
*
CNC21 MOV CNR$T,XL POINT TO STORAGE LOCATION
MOV XR,(XL) STORE TITLE/SUBTITLE
BRN CNC10 RETURN
*
* -TRACE
*
* PROVIDED FOR SYSTEM DEBUGGING. TOGGLES THE SYSTEM LABEL
* TRACE SWITCH AT COMPILE TIME
*
CNC22 JSR SYSTT TOGGLE SWITCH
BRN CNC09 MERGE
*
* -COPY
*
* GET FILETAG AND NOTIFY OSINT THAT WE ARE NESTING
*
CNC23 JSR SCANE GET FILETAG
BNE =T$CON,XL,CNC06 ERR IF NOT CONSTANT
BNE =B$SCL,(XR),CNC06 ERR IF NOT SCBLK
JSR SYSSC CALL TO START COPY
ERR 258,COPY FILE DOES NOT EXIST
PPM EROSI ERROR RETURN (ALWAYS)
MOV WA,WB SAVE IOTAG FROM OSINT
MOV *COSI$,WA GET SIZE OF COPY BLOCK
JSR ALLOC ALLOCATE
MOV =B$COP,COTYP(XR) SET TYPE
MOV R$COP,CONXT(XR) PLACE AT FRONT OF STACK CHN
MOV XR,R$COP SPLICE IT IN
MOV WB,COIOT(XR) SAVE OSINT IOTAG
MOV TTINS,COTTI(XR) SAVE TTINS
ZER TTINS INPUT NOT FROM TERMINAL NOW
MOV R$CIM,COCIM(XR) SAVE R$CIM IN CASE EXEC TIME
MOV SCNPT,COSPT(XR) SAVE SCNPT IN CASE EXEC TIME
MOV CSWLS,COSLS(XR) SAVE LIST FLAG
MOV CSWIN,COSIN(XR) SAVE -INXXX VALUE
MOV R$STL,COSTL(XR) SAVE SUBTITLE
BZE CSWLS,CNC10 NO LIST -COPY IF -NOLIST
JSR LISTR LIST -COPY CARD
BRN CNC10 EXIT
ENP END PROCEDURE CNCRD
EJC
*
* COPND -- END -COPY NESTING
*
* COPND IS CALLED FROM CMPIL AND READR IN ORDER TO
* UNNEST ONE LEVEL OF -COPY AND RESTORE THE PREVIOUS
* INPUT COMPILE STRING. THE COPY BLOCK IS REMOVED
* FROM THE CHAIN AND THE STATE RESTORED FROM IT.
*
* JSR COPND CALL TO END -COPY AT CUR. LEVEL
* (XL,WA,WB,WC) DESTROYED
*
COPND PRC E,0 ENTRY POINT
MOV R$COP,XL GET POINTER TO CURRENT COBLK
BZE XL,COP02 EXIT IF NONE
MOV CONXT(XL),R$COP TAKE OFF CHAIN
MOV COIOT(XL),WA GET IOTAG FOR OSINT
JSR SYSEC CALL TO END COPY
PPM DO NOT USE
PPM EROSI ERROR EXIT
BZE CSWLS,COP01 SKIP LISTING IF -NOLIST
JSR LISTR LIST CURRENT IMAGE
*
* MERGE AFTER POSSIBLE LISTING OF CURRENT IMAGE
*
COP01 MOV COTTI(XL),TTINS RESTORE TERMINAL INPUT FLAG
MOV COSLS(XL),CSWLS RESTORE LISTING STATE
MOV COSPT(XL),SCNPT GET OLD SCAN POINTER
MOV COSIN(XL),CSWIN OLD INPUT IMAGE LENGTH
MOV COSTL(XL),R$STL RESTORE SUBTITLE STRING
MNZ LSTPF THIS IMAGE LISTED IN CNCRD
MOV COCIM(XL),XL GET OLD COMPILER IMAGE SCBLK
MOV XL,R$CIM RESTORE IT
MOV SCLEN(XL),SCNIL SET INPUT IMAGE LENGTH TOO
*
* MERGE TO EXIT
*
COP02 EXI RETURN TO CALLER
ENP END PROCEDURE COPND
EJC
*
* DFFNC -- DEFINE FUNCTION
*
* DFFNC IS CALLED WHENEVER A NEW FUNCTION IS ASSIGNED TO
* A VARIABLE. IT DEALS WITH EXTERNAL FUNCTION USE COUNTS.
*
* (XR) POINTER TO VRBLK
* (XL) POINTER TO NEW FUNCTION BLOCK
* JSR DFFNC CALL TO DEFINE FUNCTION
* (WA,WB) DESTROYED
*
DFFNC PRC E,0 ENTRY POINT
.IF .CNLD
.ELSE
BNE (XL),=B$EFC,DFFN1 SKIP IF NEW FUNCTION NOT EXTERNAL
ICV EFUSE(XL) ELSE INCREMENT ITS USE COUNT
*
* HERE AFTER DEALING WITH NEW FUNCTION USE COUNT
*
DFFN1 MOV XR,WA SAVE VRBLK POINTER
MOV VRFNC(XR),XR LOAD OLD FUNCTION POINTER
BNE (XR),=B$EFC,DFFN2 JUMP IF OLD FUNCTION NOT EXTERNAL
MOV EFUSE(XR),WB ELSE GET USE COUNT
DCV WB DECREMENT
MOV WB,EFUSE(XR) STORE DECREMENTED VALUE
BNZ WB,DFFN2 JUMP IF USE COUNT STILL NON-ZERO
JSR SYSUL ELSE CALL SYSTEM UNLOAD FUNCTION
*
* HERE AFTER DEALING WITH OLD FUNCTION USE COUNT
*
DFFN2 MOV WA,XR RESTORE VRBLK POINTER
.FI
MOV XL,WA COPY FUNCTION BLOCK PTR
BLT XR,=R$YYY,DFFN3 SKIP CHECKS IF OPSYN OP DEFINITION
BNZ VRLEN(XR),DFFN3 JUMP IF NOT SYSTEM VARIABLE
*
* FOR SYSTEM VARIABLE, CHECK FOR ILLEGAL REDEFINITION
*
MOV VRSVP(XR),XL POINT TO SVBLK
MOV SVBIT(XL),WB LOAD BIT INDICATORS
ANB BTFNC,WB IS IT A SYSTEM FUNCTION
ZRB WB,DFFN3 REDEF OK IF NOT
ERB 217,ATTEMPTED REDEFINITION OF SYSTEM FUNCTION
*
* HERE IF REDEFINITION IS PERMITTED
*
DFFN3 MOV WA,VRFNC(XR) STORE NEW FUNCTION POINTER
MOV WA,XL RESTORE FUNCTION BLOCK POINTER
EXI RETURN TO DFFNC CALLER
ENP END PROCEDURE DFFNC
EJC
*
* DTYPE -- GET DATATYPE NAME
*
* (XR) OBJECT WHOSE DATATYPE IS REQUIRED
* JSR DTYPE CALL TO GET DATATYPE
* (XR) RESULT DATATYPE
*
DTYPE PRC E,0 ENTRY POINT
BEQ (XR),=B$PDT,DTYP1 JUMP IF PROG.DEFINED
MOV (XR),XR LOAD TYPE WORD
LEI XR GET ENTRY POINT ID (BLOCK CODE)
WTB XR CONVERT TO BAU OFFSET
MOV SCNMT(XR),XR LOAD TABLE ENTRY
EXI EXIT TO DTYPE CALLER
*
* HERE IF PROGRAM DEFINED
*
DTYP1 MOV PDDFP(XR),XR POINT TO DFBLK
MOV DFNAM(XR),XR GET DATATYPE NAME FROM DFBLK
EXI RETURN TO DTYPE CALLER
ENP END PROCEDURE DTYPE
EJC
*
* DUMPR -- PRINT DUMP OF STORAGE
*
* (XR) DUMP ARGUMENT (SEE BELOW)
* JSR DUMPR CALL TO PRINT DUMP
* (XR,XL) DESTROYED
* (WA,WB,WC,RA) DESTROYED
*
* THE DUMP ARGUMENT HAS THE FOLLOWING SIGNIFICANCE
*
* DMARG = 0 NO DUMP PRINTED
* DMARG = 1 PARTIAL DUMP (NAT VARS, KEYWORDS)
* DMARG GE 2 FULL DUMP (INCL ARRAYS ETC.)
*
* SINCE DUMPR SCRAMBLES STORE, IT IS NOT PERMISSIBLE TO
* COLLECT IN MID-DUMP. HENCE A COLLECT IS DONE INITIALLY
* AND THEN IF STORE RUNS OUT AN ERROR MESSAGE IS PRODUCED.
*
DUMPR PRC E,0 ENTRY POINT
BZE XR,DMP28 SKIP DUMP IF ARGUMENT IS ZERO
ZER XL CLEAR XL
ZER WB ZERO MOVE OFFSET
MOV XR,DMARG SAVE DUMP ARGUMENT
JSR GBCOL COLLECT GARBAGE
JSR PRTPG EJECT PRINTER
MOV =DMHDV,XR POINT TO HEADING FOR VARIABLES
JSR PRTFB PRINT IT
*
* FIRST ALL NATURAL VARIABLE BLOCKS (VRBLK) WHOSE VALUES
* ARE NON-NULL ARE LINKED IN LEXICAL ORDER USING DMVCH AS
* THE CHAIN HEAD AND CHAINING THROUGH THE VRGET FIELDS.
* NOTE THAT THIS SCRAMBLES STORE IF THE PROCESS IS
* INTERRUPTED BEFORE COMPLETION E.G. BY EXCEEDING TIME OR
* PRINT LIMITS. SINCE THE SUBSEQUENT CORE DUMPS AND
* FAILURES IF EXECUTION IS RESUMED ARE VERY CONFUSING, THE
* EXECUTION TIME ERROR ROUTINE CHECKS FOR THIS EVENT AND
* ATTEMPTS AN UNSCRAMBLE. SIMILAR PRECAUTIONS SHOULD BE
* OBSERVED IF TRANSLATE TIME DUMPING IS IMPLEMENTED.
*
ZER DMVCH SET NULL CHAIN TO START
MOV HSHTB,WA POINT TO HASH TABLE
*
* LOOP THROUGH HEADERS IN HASH TABLE
*
DMP00 MOV WA,XR COPY HASH BUCKET POINTER
ICA WA BUMP POINTER
SUB *VRNXT,XR SET OFFSET TO MERGE
*
* LOOP THROUGH VRBLKS ON ONE CHAIN
*
DMP01 MOV VRNXT(XR),XR POINT TO NEXT VRBLK ON CHAIN
BZE XR,DMP09 JUMP IF END OF THIS HASH CHAIN
MOV XR,XL ELSE COPY VRBLK POINTER
EJC
*
* DUMPR (CONTINUED)
*
* LOOP TO FIND VALUE AND SKIP IF NULL
*
DMP02 MOV VRVAL(XL),XL LOAD VALUE
BEQ XL,=NULLS,DMP01 LOOP FOR NEXT VRBLK IF NULL VALUE
BEQ (XL),=B$TRT,DMP02 LOOP BACK IF VALUE IS TRAPPED
*
* NON-NULL VALUE, PREPARE TO SEARCH CHAIN
*
MOV XR,WC SAVE VRBLK POINTER
ADD *VRSOF,XR ADJUST PTR TO BE LIKE SCBLK PTR
BNZ SCLEN(XR),DMP03 JUMP IF NON-SYSTEM VARIABLE
MOV VRSVO(XR),XR ELSE LOAD PTR TO NAME IN SVBLK
*
* HERE WITH NAME POINTER FOR NEW BLOCK IN XR
*
DMP03 MOV XR,WB SAVE POINTER TO CHARS
MOV WA,DMPSV SAVE HASH BUCKET POINTER
MOV =DMVCH,WA POINT TO CHAIN HEAD
*
* LOOP TO SEARCH CHAIN FOR CORRECT INSERTION POINT
*
DMP04 MOV WA,DMPCH SAVE CHAIN POINTER
MOV WA,XL COPY IT
MOV (XL),XR LOAD POINTER TO NEXT ENTRY
BZE XR,DMP08 JUMP IF END OF CHAIN TO INSERT
ADD *VRSOF,XR ELSE GET NAME PTR FOR CHAINED VRBLK
BNZ SCLEN(XR),DMP05 JUMP IF NOT SYSTEM VARIABLE
MOV VRSVO(XR),XR ELSE POINT TO NAME IN SVBLK
*
* HERE PREPARE TO COMPARE THE NAMES
*
* (WA) SCRATCH
* (WB) POINTER TO STRING OF ENTERING VRBLK
* (WC) POINTER TO ENTERING VRBLK
* (XR) POINTER TO STRING OF CURRENT BLOCK
* (XL) SCRATCH
*
DMP05 MOV WB,XL POINT TO ENTERING VRBLK STRING
MOV SCLEN(XL),WA LOAD ITS LENGTH
PLC XL POINT TO CHARS OF ENTERING STRING
BHI WA,SCLEN(XR),DMP06 JUMP IF ENTERING LENGTH HIGH
PLC XR ELSE POINT TO CHARS OF OLD STRING
CMC DMP08,DMP07 COMPARE, INSERT IF NEW IS LLT OLD
BRN DMP08 OR IF LEQ (WE HAD SHORTER LENGTH)
*
* HERE WHEN NEW LENGTH IS LONGER THAN OLD LENGTH
*
DMP06 MOV SCLEN(XR),WA LOAD SHORTER LENGTH
PLC XR POINT TO CHARS OF OLD STRING
CMC DMP08,DMP07 COMPARE, INSERT IF NEW ONE LOW
EJC
*
* DUMPR (CONTINUED)
*
* HERE WE MOVE OUT ON THE CHAIN
*
DMP07 MOV DMPCH,XL COPY CHAIN POINTER
MOV (XL),WA MOVE TO NEXT ENTRY ON CHAIN
BRN DMP04 LOOP BACK
*
* HERE AFTER LOCATING THE PROPER INSERTION POINT
*
DMP08 MOV DMPCH,XL COPY CHAIN POINTER
MOV DMPSV,WA RESTORE HASH BUCKET POINTER
MOV WC,XR RESTORE VRBLK POINTER
MOV (XL),VRGET(XR) LINK VRBLK TO REST OF CHAIN
MOV XR,(XL) LINK VRBLK INTO CURRENT CHAIN LOC
BRN DMP01 LOOP BACK FOR NEXT VRBLK
*
* HERE AFTER PROCESSING ALL VRBLKS ON ONE CHAIN
*
DMP09 BNE WA,HSHTE,DMP00 LOOP BACK IF MORE BUCKETS TO GO
*
* LOOP TO GENERATE DUMP OF NATURAL VARIABLE VALUES
*
DMP10 MOV DMVCH,XR LOAD POINTER TO NEXT ENTRY ON CHAIN
BZE XR,DMP11 JUMP IF END OF CHAIN
MOV (XR),DMVCH ELSE UPDATE CHAIN PTR TO NEXT ENTRY
JSR SETVR RESTORE VRGET FIELD
MOV XR,XL COPY VRBLK POINTER (NAME BASE)
MOV *VRVAL,WA SET OFFSET FOR VRBLK NAME
JSR PRTNV PRINT NAME = VALUE
BRN DMP10 LOOP BACK TILL ALL PRINTED
*
* PREPARE TO PRINT KEYWORDS
*
DMP11 JSR PRTFH PRINT BLANK LINE
JSR PRTFH AND ANOTHER
MOV =DMHDK,XR POINT TO KEYWORD HEADING
JSR PRTFB PRINT HEADING
MOV =VDMKW,XL POINT TO LIST OF KEYWORD SVBLK PTRS
EJC
*
* DUMPR (CONTINUED)
*
* LOOP TO DUMP KEYWORD VALUES
*
DMP12 MOV (XL)+,XR LOAD NEXT SVBLK PTR FROM TABLE
BZE XR,DMP13 JUMP IF END OF LIST
MOV =CH$AM,WA LOAD AMPERSAND
JSR PRTCH PRINT AMPERSAND
JSR PRTST PRINT KEYWORD NAME
MOV SVLEN(XR),WA LOAD NAME LENGTH FROM SVBLK
CTB WA,SVCHS GET LENGTH OF NAME
ADD WA,XR POINT TO SVKNM FIELD
MOV (XR),DMPKN STORE IN DUMMY KVBLK
MOV =TMBEB,XR POINT TO BLANK-EQUAL-BLANK
JSR PRTST PRINT IT
MOV XL,DMPSV SAVE TABLE POINTER
MOV =DMPKB,XL POINT TO DUMMY KVBLK
MOV *KVVAR,WA SET ZERO OFFSET
JSR ACESS GET KEYWORD VALUE
PPM FAILURE IS IMPOSSIBLE
JSR PRTVF PRINT KEYWORD VALUE
MOV DMPSV,XL RESTORE TABLE POINTER
BRN DMP12 LOOP BACK TILL ALL PRINTED
*
* HERE AFTER COMPLETING PARTIAL DUMP
*
DMP13 BEQ DMARG,=NUM01,DMP27 EXIT IF PARTIAL DUMP COMPLETE
MOV DNAMB,XR ELSE POINT TO FIRST DYNAMIC BLOCK
*
* LOOP THROUGH BLOCKS IN DYNAMIC STORAGE
*
DMP14 BEQ XR,DNAMP,DMP27 JUMP IF END OF USED REGION
MOV (XR),WA ELSE LOAD FIRST WORD OF BLOCK
BEQ WA,=B$VCT,DMP16 JUMP IF VECTOR
BEQ WA,=B$ART,DMP17 JUMP IF ARRAY
BEQ WA,=B$PDT,DMP18 JUMP IF PROGRAM DEFINED
BEQ WA,=B$TBT,DMP19 JUMP IF TABLE
.IF .CNBF
.ELSE
BEQ WA,=B$BCT,DMP29 JUMP IF BUFFER
.FI
*
* MERGE HERE TO MOVE TO NEXT BLOCK
*
DMP15 JSR BLKLN GET LENGTH OF BLOCK
ADD WA,XR POINT PAST THIS BLOCK
BRN DMP14 LOOP BACK FOR NEXT BLOCK
EJC
*
* DUMPR (CONTINUED)
*
* HERE FOR VECTOR
*
DMP16 MOV *VCVLS,WB SET OFFSET TO FIRST VALUE
BRN DMP19 JUMP TO MERGE
*
* HERE FOR ARRAY
*
DMP17 MOV AROFS(XR),WB SET OFFSET TO ARPRO FIELD
ICA WB BUMP TO GET OFFSET TO VALUES
BRN DMP19 JUMP TO MERGE
*
* HERE FOR PROGRAM DEFINED
*
DMP18 MOV *PDFLD,WB POINT TO VALUES, MERGE
*
* HERE FOR TABLE (OTHERS MERGE)
*
DMP19 BZE IDVAL(XR),DMP15 IGNORE BLOCK IF ZERO ID VALUE
JSR BLKLN ELSE GET BLOCK LENGTH
MOV XR,XL COPY BLOCK POINTER
MOV WA,DMPSV SAVE LENGTH
MOV WB,WA COPY OFFSET TO FIRST VALUE
JSR PRTFH PRINT BLANK LINE
MOV WA,DMPSA PRESERVE OFFSET
JSR PRTVF PRINT BLOCK VALUE (FOR TITLE)
MOV DMPSA,WA RECOVER OFFSET
BEQ (XR),=B$TBT,DMP22 JUMP IF TABLE
DCA WA POINT BEFORE FIRST WORD
*
* LOOP TO PRINT CONTENTS OF ARRAY, VECTOR, OR PROGRAM DEF
*
DMP20 MOV XL,XR COPY BLOCK POINTER
ICA WA BUMP OFFSET
ADD WA,XR POINT TO NEXT VALUE
BEQ WA,DMPSV,DMP14 EXIT IF END (XR PAST BLOCK)
SUB *VRVAL,XR SUBTRACT OFFSET TO MERGE INTO LOOP
*
* LOOP TO FIND VALUE AND IGNORE NULLS
*
DMP21 MOV VRVAL(XR),XR LOAD NEXT VALUE
BEQ XR,=NULLS,DMP20 LOOP BACK IF NULL VALUE
BEQ (XR),=B$TRT,DMP21 LOOP BACK IF TRAPPED
JSR PRTNV ELSE PRINT NAME = VALUE
BRN DMP20 LOOP BACK FOR NEXT FIELD
EJC
*
* DUMPR (CONTINUED)
*
* HERE TO DUMP A TABLE
*
DMP22 MOV *TBBUK,WC SET OFFSET TO FIRST BUCKET
MOV *TEVAL,WA SET NAME OFFSET FOR ALL TEBLKS
*
* LOOP THROUGH TABLE BUCKETS
*
DMP23 MOV XL,-(XS) SAVE TBBLK POINTER
ADD WC,XL POINT TO NEXT BUCKET HEADER
ICA WC BUMP BUCKET OFFSET
SUB *TENXT,XL SUBTRACT OFFSET TO MERGE INTO LOOP
*
* LOOP TO PROCESS TEBLKS ON ONE CHAIN
*
DMP24 MOV TENXT(XL),XL POINT TO NEXT TEBLK
BEQ XL,(XS),DMP26 JUMP IF END OF CHAIN
MOV XL,XR ELSE COPY TEBLK POINTER
*
* LOOP TO FIND VALUE AND IGNORE IF NULL
*
DMP25 MOV TEVAL(XR),XR LOAD NEXT VALUE
BEQ XR,=NULLS,DMP24 IGNORE IF NULL VALUE
BEQ (XR),=B$TRT,DMP25 LOOP BACK IF TRAPPED
MOV WC,DMPSV ELSE SAVE OFFSET POINTER
JSR PRTNV PRINT NAME = VALUE
MOV DMPSV,WC RELOAD OFFSET
BRN DMP24 LOOP BACK FOR NEXT TEBLK
*
* HERE TO MOVE TO NEXT HASH CHAIN
*
DMP26 MOV (XS)+,XL RESTORE TBBLK POINTER
BNE WC,TBLEN(XL),DMP23 LOOP BACK IF MORE BUCKETS TO GO
MOV XL,XR ELSE COPY TABLE POINTER
ADD WC,XR POINT TO FOLLOWING BLOCK
BRN DMP14 LOOP BACK TO PROCESS NEXT BLOCK
*
* HERE AFTER COMPLETING DUMP
*
DMP27 JSR PRTPG EJECT PRINTER
*
* MERGE HERE IF NO DUMP GIVEN (DMARG=0)
*
DMP28 EXI RETURN TO DUMP CALLER
.IF .CNBF
.ELSE
EJC
*
* DUMPR (CONTINUED)
*
* HERE TO DUMP BUFFER BLOCK
*
DMP29 JSR PRTFH PRINT BLANK LINE
JSR PRTVF PRINT VALUE ID FOR TITLE
MOV =CH$DQ,WA LOAD DOUBLE QUOTE
JSR PRTCH PRINT IT
MOV BCLEN(XR),WC LOAD DEFINED LENGTH
BZE WC,DMP32 SKIP CHARACTERS IF NONE
LCT WC,WC LOAD COUNT FOR LOOP
MOV XR,WB SAVE BCBLK PTR
MOV BCBUF(XR),XR POINT TO BFBLK
PLC XR GET SET TO LOAD CHARACTERS
*
* LOOP HERE STUFFING CHARACTERS IN OUTPUT STREAM
*
DMP31 LCH WA,(XR)+ GET NEXT CHARACTER
JSR PRTCH STUFF IT
BCT WC,DMP31 BRANCH FOR NEXT ONE
MOV WB,XR RESTORE BCBLK POINTER
*
* MERGE TO STUFF CLOSING QUOTE MARK
*
DMP32 MOV =CH$DQ,WA STUFF QUOTE
JSR PRTCF PRINT IT
MOV (XR),WA GET FIRST WD FOR BLKLN
BRN DMP15 MERGE TO GET NEXT BLOCK
.FI
ENP END PROCEDURE DUMPR
EJC
*
* ERMSG -- PRINT ERROR CODE AND ERROR MESSAGE
*
* KVERT ERROR CODE
* JSR ERMSG CALL TO PRINT MESSAGE
* (XR,XL,WA,WB,WC,IA) DESTROYED
*
ERMSG PRC E,0 ENTRY POINT
JSR PRTFH PRINT ERROR PTR OR BLANK LINE
MOV KVERT,WA LOAD ERROR CODE
MOV =ERMMS,XR POINT TO ERROR MESSAGE /ERROR/
JSR PRTST PRINT IT
JSR ERTEX GET ERROR MESSAGE TEXT
ADD =THSND,WA BUMP ERROR CODE FOR PRINT
MTI WA FAIL CODE IN INT ACC
JSR PRTIN PRINT CODE (NOW HAVE ERROR1XXX)
MOV PRBUF,XL POINT TO PRINT BUFFER
PSC XL,=NUM05 POINT TO THE 1
MOV =CH$BL,WA LOAD A BLANK
SCH WA,(XL) STORE BLANK OVER 1 (ERROR XXX)
CSC XL COMPLETE STORE CHARACTERS
ZER XL CLEAR GARBAGE POINTER IN XL
MOV XR,WA KEEP ERROR TEXT
MOV =ERMNS,XR POINT TO / -- /
JSR PRTST PRINT IT
MOV WA,XR GET ERROR TEXT AGAIN
JSR PRTFB PRINT ERROR MESSAGE TEXT
EXI RETURN TO ERMSG CALLER
ENP END PROCEDURE ERMSG
EJC
*
* ERTEX -- GET ERROR MESSAGE TEXT
*
* (WA) ERROR CODE
* JSR ERTEX CALL TO GET ERROR TEXT
* (XR) PTR TO ERROR TEXT IN DYNAMIC
* (R$ETX) COPY OF PTR TO ERROR TEXT
* (XL,WC,IA) DESTROYED
*
ERTEX PRC E,0 ENTRY POINT
MOV WA,ERTWA SAVE WA
MOV WB,ERTWB SAVE WB
BNZ EROSN,ERT03 SKIP IF SPECIAL EROSI RETURN
JSR SYSEM GET FAILURE MESSAGE TEXT
MOV XR,XL COPY POINTER TO IT
MOV SCLEN(XR),WA GET LENGTH OF STRING
BZE WA,ERT02 JUMP IF NULL
ZER WB OFFSET OF ZERO
JSR SBSTR COPY INTO DYNAMIC STORE
MOV XR,R$ETX STORE FOR RELOCATION
*
* RETURN
*
ERT01 MOV ERTWB,WB RESTORE WB
MOV ERTWA,WA RESTORE WA
EXI RETURN TO CALLER
*
* RETURN ERRTEXT CONTENTS INSTEAD OF NULL
*
ERT02 MOV R$ETX,XR GET ERRTEXT
BRN ERT01 RETURN
*
* SPECIAL CASE SET UP BY EROSI RETURN TO AVOID SYSEM CALL
*
ERT03 ZER EROSN CLEAR FLAG
MOV R$ETX,XR GET ERROR MESSAGE TEXT
BRN ERT01 RETURN WITHOUT MAKING SYSEM CALL
ENP
EJC
*
* EVALI -- EVALUATE INTEGER ARGUMENT
*
* EVALI IS USED BY PATTERN PRIMITIVES LEN,TAB,RTAB,POS,RPOS
* WHEN THEIR ARGUMENT IS AN EXPRESSION VALUE.
*
* (XR) NODE POINTER
* (WB) CURSOR
* JSR EVALI CALL TO EVALUATE INTEGER
* PPM LOC TRANSFER LOC FOR NON-INTEGER ARG
* PPM LOC TRANSFER LOC FOR OUT OF RANGE ARG
* PPM LOC TRANSFER LOC FOR EVALUATION FAILURE
* (XR) PTR TO NODE WITH INTEGER ARGUMENT
* (WC,XL,RA) DESTROYED
*
* ON RETURN, THE NODE POINTED TO HAS THE INTEGER ARGUMENT
* IN PARM1 AND THE PROPER SUCCESSOR POINTER IN PTHEN.
* THIS ALLOWS MERGING WITH THE NORMAL (INTEGER ARG) CASE.
*
EVALI PRC R,3 ENTRY POINT (RECURSIVE)
JSR EVALP EVALUATE EXPRESSION
PPM EVLI1 JUMP ON FAILURE
MOV XL,-(XS) STACK RESULT FOR GTSMI
MOV PTHEN(XR),XL LOAD SUCCESSOR POINTER
JSR GTSMI CONVERT ARG TO SMALL INTEGER
PPM EVLI2 JUMP IF NOT INTEGER
PPM EVLI3 JUMP IF OUT OF RANGE
MOV XR,EVLIV STORE RESULT IN SPECIAL DUMMY NODE
MOV XL,EVLIS STORE SUCCESSOR POINTER
MOV =EVLIN,XR POINT TO DUMMY NODE WITH RESULT
EXI SUCCESSFUL RETURN
*
* HERE IF EVALUATION FAILS
*
EVLI1 EXI 3 TAKE FAILURE RETURN
*
* HERE IF ARGUMENT IS NOT INTEGER
*
EVLI2 EXI 1 TAKE NON-INTEGER ERROR EXIT
*
* HERE IF ARGUMENT IS OUT OF RANGE
*
EVLI3 EXI 2 TAKE OUT-OF-RANGE ERROR EXIT
ENP END PROCEDURE EVALI
EJC
*
* EVALP -- EVALUATE EXPRESSION DURING PATTERN MATCH
*
* EVALP IS USED TO EVALUATE AN EXPRESSION (BY VALUE) DURING
* A PATTERN MATCH. THE EFFECT IS LIKE EVALX, BUT PATTERN
* VARIABLES ARE STACKED AND RESTORED IF NECESSARY.
*
* EVALP ALSO DIFFERS FROM EVALX IN THAT IF THE RESULT IS
* AN EXPRESSION IT IS REEVALUATED. THIS OCCURS REPEATEDLY.
*
* (XR) NODE POINTER
* (WB) PATTERN MATCH CURSOR
* JSR EVALP CALL TO EVALUATE EXPRESSION
* PPM LOC TRANSFER LOC IF EVALUATION FAILS
* (XL) RESULT
* (WA) FIRST WORD OF RESULT BLOCK
* (XR,WB) DESTROYED (FAILURE CASE ONLY)
* (WC,RA) DESTROYED
*
* THE EXPRESSION POINTER IS STORED IN PARM1 OF THE NODE
*
* CONTROL RETURNS TO FAILP ON FAILURE OF EVALUATION
*
EVALP PRC R,1 ENTRY POINT (RECURSIVE)
MOV PARM1(XR),XL LOAD EXPRESSION POINTER
BEQ (XL),=B$EXL,EVLP1 JUMP IF EXBLK CASE
*
* HERE FOR CASE OF SEBLK
*
* WE CAN GIVE A FAST RETURN IF THE VALUE OF THE VRBLK IS
* NOT AN EXPRESSION AND IS NOT TRAPPED.
*
MOV SEVAR(XL),XL LOAD VRBLK POINTER
MOV VRVAL(XL),XL LOAD VALUE OF VRBLK
MOV (XL),WA LOAD FIRST WORD OF VALUE
BHI WA,=B$T$$,EVLP3 JUMP IF NOT SEBLK, TRBLK OR EXBLK
*
* HERE FOR EXBLK OR SEBLK WITH EXPR VALUE OR TRAPPED VALUE
*
EVLP1 MOV XR,-(XS) STACK NODE POINTER
MOV WB,-(XS) STACK CURSOR
MOV R$PMS,-(XS) STACK SUBJECT STRING POINTER
MOV PMSSL,-(XS) STACK SUBJECT STRING LENGTH
MOV PMDFL,-(XS) STACK DOT FLAG
MOV PMHBS,-(XS) STACK HISTORY STACK BASE POINTER
MOV PARM1(XR),XR LOAD EXPRESSION POINTER
EJC
*
* EVALP (CONTINUED)
*
* LOOP BACK HERE TO REEVALUATE EXPRESSION RESULT
*
EVLP2 ZER WB SET FLAG FOR BY VALUE
JSR EVALX EVALUATE EXPRESSION
PPM EVLP4 JUMP ON FAILURE
MOV (XR),WA ELSE LOAD FIRST WORD OF VALUE
BLO WA,=B$E$$,EVLP2 LOOP BACK TO REEVALUATE EXPRESSION
*
* HERE TO RESTORE PATTERN VALUES AFTER SUCCESSFUL EVAL
*
MOV XR,XL COPY RESULT POINTER
MOV (XS)+,PMHBS RESTORE HISTORY STACK BASE POINTER
MOV (XS)+,PMDFL RESTORE DOT FLAG
MOV (XS)+,PMSSL RESTORE SUBJECT STRING LENGTH
MOV (XS)+,R$PMS RESTORE SUBJECT STRING POINTER
MOV (XS)+,WB RESTORE CURSOR
MOV (XS)+,XR RESTORE NODE POINTER
*
* COMMON EXIT POINT
*
EVLP3 EXI RETURN TO EVALP CALLER
*
* HERE FOR FAILURE DURING EVALUATION
*
EVLP4 MOV (XS)+,PMHBS RESTORE HISTORY STACK BASE POINTER
MOV (XS)+,PMDFL RESTORE DOT FLAG
MOV (XS)+,PMSSL RESTORE SUBJECT STRING LENGTH
MOV (XS)+,R$PMS RESTORE SUBJECT STRING POINTER
ADD *NUM02,XS REMOVE NODE PTR, CURSOR
EXI 1 TAKE FAILURE EXIT
ENP END PROCEDURE EVALP
EJC
*
* EVALS -- EVALUATE STRING ARGUMENT
*
* EVALS IS USED BY SPAN, ANY, NOTANY, BREAK, BREAKX WHEN
* THEY ARE PASSED AN EXPRESSION ARGUMENT.
*
* (XR) NODE POINTER
* (WA) APPROPRIATE MULTI CHARACTER PCODE
* (WB) CURSOR
* JSR EVALS CALL TO EVALUATE STRING
* PPM LOC TRANSFER LOC FOR NON-STRING ARG
* PPM LOC TRANSFER LOC FOR EVALUATION FAILURE
* (XL) PCODE OF NEW NODE (ENTRY WA)
* (XR) PTR TO NODE WITH PARMS SET
* (WA,WC,RA) DESTROYED
*
* ON RETURN, THE NODE POINTED TO HAS A CHARACTER TABLE
* POINTER IN PARM1 AND A BIT MASK IN PARM2. THE PROPER
* SUCCESSOR IS STORED IN PTHEN OF THIS NODE. THUS IT IS
* OK FOR MERGING WITH THE NORMAL (MULTI-CHAR STRING) CASE.
* THIS IS DONE BY THE USUAL INDIRECT BRANCH THROUGH THE
* PCODE PASSED IN WA.
*
EVALS PRC R,2 ENTRY POINT (RECURSIVE)
MOV WA,-(XS) KEEP PCODE
JSR EVALP EVALUATE EXPRESSION
PPM EVLS1 JUMP IF EVALUATION FAILS
MOV (XS)+,WA RECOVER PCODE
MOV PTHEN(XR),-(XS) SAVE SUCCESSOR POINTER
MOV WB,-(XS) SAVE CURSOR
MOV XL,-(XS) STACK RESULT PTR FOR PATST
ZER WB DUMMY PCODE FOR ONE CHAR STRING
ZER WC DUMMY PCODE FOR EXPRESSION ARG
MOV WA,XL APPROPRIATE PCODE FOR OUR USE
JSR PATST CALL ROUTINE TO BUILD NODE
PPM EVLS2 JUMP IF NOT STRING
MOV (XS)+,WB RESTORE CURSOR
MOV (XS)+,PTHEN(XR) STORE SUCCESSOR POINTER
MOV (XR),XL GET PCODE
EXI TAKE SUCCESS RETURN
*
* HERE IF EVALUATION FAILS
*
EVLS1 MOV (XS)+,WA POP STACK
EXI 2 TAKE FAILURE RETURN
*
* HERE IF ARGUMENT IS NOT STRING
*
EVLS2 ADD *NUM02,XS POP SUCCESSOR AND CURSOR
EXI 1 TAKE NON-STRING ERROR EXIT
ENP END PROCEDURE EVALS
EJC
*
* EVALX -- EVALUATE EXPRESSION
*
* EVALX IS CALLED TO EVALUATE AN EXPRESSION
*
* (XR) POINTER TO EXBLK OR SEBLK
* (WB) 0 IF BY VALUE, 1 IF BY NAME
* JSR EVALX CALL TO EVALUATE EXPRESSION
* PPM LOC TRANSFER LOC IF EVALUATION FAILS
* (XR) RESULT IF CALLED BY VALUE
* (XL,WA) RESULT NAME BASE,OFFSET IF BY NAME
* (XR) DESTROYED (NAME CASE ONLY)
* (XL,WA) DESTROYED (VALUE CASE ONLY)
* (WB,WC,RA) DESTROYED
*
EVALX PRC R,1 ENTRY POINT, RECURSIVE
BEQ (XR),=B$EXL,EVLX2 JUMP IF EXBLK CASE
*
* HERE FOR SEBLK
*
MOV SEVAR(XR),XL LOAD VRBLK POINTER (NAME BASE)
MOV *VRVAL,WA SET NAME OFFSET
BNZ WB,EVLX1 JUMP IF CALLED BY NAME
JSR ACESS CALL ROUTINE TO ACCESS VALUE
PPM EVLX9 JUMP IF FAILURE ON ACCESS
*
* MERGE HERE TO EXIT FOR SEBLK CASE
*
EVLX1 EXI RETURN TO EVALX CALLER
EJC
*
* EVALX (CONTINUED)
*
* HERE FOR FULL EXPRESSION (EXBLK) CASE
*
* IF AN ERROR OCCURS IN THE EXPRESSION CODE AT EXECUTION
* TIME, CONTROL IS PASSED VIA ERROR SECTION TO EXFAL
* WITHOUT RETURNING TO THIS ROUTINE.
* THE FOLLOWING ENTRIES ARE MADE ON THE STACK BEFORE
* GIVING CONTROL TO THE EXPRESSION CODE
*
* EVALX RETURN POINT
* SAVED VALUE OF R$COD
* CODE POINTER (-R$COD)
* SAVED VALUE OF FLPTR
* 0 IF BY VALUE, 1 IF BY NAME
* FLPTR --------------- *EXFLC, FAIL OFFSET IN EXBLK
*
EVLX2 SCP WC GET CODE POINTER
MOV R$COD,WA LOAD CODE BLOCK POINTER
SUB WA,WC GET CODE POINTER AS OFFSET
MOV WA,-(XS) STACK OLD CODE BLOCK POINTER
MOV WC,-(XS) STACK RELATIVE CODE OFFSET
MOV FLPTR,-(XS) STACK OLD FAILURE POINTER
MOV WB,-(XS) STACK NAME/VALUE INDICATOR
MOV *EXFLC,-(XS) STACK NEW FAIL OFFSET
MOV FLPTR,GTCEF KEEP IN CASE OF ERROR
MOV R$COD,R$GTC KEEP CODE BLOCK POINTER SIMILARLY
MOV XS,FLPTR SET NEW FAILURE POINTER
MOV XR,R$COD SET NEW CODE BLOCK POINTER
MOV KVSTN,EXSTM(XR) REMEMBER STMNT NUMBER
ADD *EXCOD,XR POINT TO FIRST CODE WORD
LCP XR SET CODE POINTER
BNE STAGE,=STGXT,EXITS JUMP IF NOT EXECUTION TIME
MOV =STGEE,STAGE EVALUATING EXPRESSION
BRN EXITS JUMP TO EXECUTE FIRST CODE WORD
EJC
*
* EVALX (CONTINUED)
*
* COME HERE IF SUCCESSFUL RETURN BY VALUE (SEE O$RVL)
*
EVLXV MOV (XS)+,XR LOAD VALUE
BZE 1(XS),EVLX5 JUMP IF CALLED BY VALUE
ERB 218,EXPRESSION EVALUATED BY NAME RETURNED VALUE
*
* HERE FOR EXPRESSION RETURNING BY NAME (SEE O$RNM)
*
EVLXN MOV (XS)+,WA LOAD NAME OFFSET
MOV (XS)+,XL LOAD NAME BASE
BNZ 1(XS),EVLX5 JUMP IF CALLED BY NAME
JSR ACESS ELSE ACCESS VALUE FIRST
PPM EVLXF JUMP IF FAILURE DURING ACCESS
*
* HERE AFTER LOADING CORRECT RESULT INTO XR OR XL,WA
*
EVLX5 ZER WB NOTE SUCCESSFUL
BRN EVLX7 MERGE
*
* HERE FOR FAILURE IN EXPRESSION EVALUATION (SEE O$FEX)
*
EVLXF MNZ WB NOTE UNSUCCESSFUL
*
* RESTORE ENVIRONMENT
*
EVLX7 BNE STAGE,=STGEE,EVLX8 SKIP IF WAS NOT PREVIOUSLY XT
MOV =STGXT,STAGE EXECUTE TIME
*
* MERGE WITH STAGE SET UP
*
EVLX8 ADD *NUM02,XS POP NAME/VALUE INDICATOR, *EXFAL
MOV (XS)+,FLPTR RESTORE OLD FAILURE POINTER
MOV (XS)+,WC LOAD CODE OFFSET
ADD (XS),WC MAKE CODE POINTER ABSOLUTE
MOV (XS)+,R$COD RESTORE OLD CODE BLOCK POINTER
LCP WC RESTORE OLD CODE POINTER
BZE WB,EVLX1 JUMP FOR SUCCESSFUL RETURN
*
* MERGE HERE FOR FAILURE IN SEBLK CASE
*
EVLX9 EXI 1 TAKE FAILURE EXIT
ENP END OF PROCEDURE EVALX
EJC
*
* EXBLD -- BUILD EXBLK
*
* EXBLD IS USED TO BUILD AN EXPRESSION BLOCK FROM THE
* CODE COMPILED MOST RECENTLY IN THE CURRENT CCBLK.
*
* (XL) OFFSET IN CCBLK TO START OF CODE
* (WB) INTEGER IN RANGE 0 LE N LE MXLEN
* JSR EXBLD CALL TO BUILD EXBLK
* (XR) PTR TO CONSTRUCTED EXBLK
* (WA,WB,XL) DESTROYED
*
EXBLD PRC E,0 ENTRY POINT
MOV XL,WA COPY OFFSET TO START OF CODE
SUB *EXCOD,WA CALC REDUCTION IN OFFSET IN EXBLK
MOV WA,-(XS) STACK FOR LATER
MOV CWCOF,WA LOAD FINAL OFFSET
SUB XL,WA COMPUTE LENGTH OF CODE
ADD *EXSI$,WA ADD SPACE FOR STANDARD FIELDS
JSR ALLOC ALLOCATE SPACE FOR EXBLK
MOV XR,-(XS) SAVE POINTER TO EXBLK
MOV =B$EXL,EXTYP(XR) STORE TYPE WORD
ZER EXSTM(XR) ZEROISE STMNT NUMBER FIELD
MOV WA,EXLEN(XR) STORE LENGTH
MOV =OFEX$,EXFLC(XR) STORE FAILURE WORD
ADD *EXSI$,XR SET XR FOR SYSMW
MOV XL,CWCOF RESET OFFSET TO START OF CODE
ADD R$CCB,XL POINT TO START OF CODE
SUB *EXSI$,WA LENGTH OF CODE TO MOVE
MOV WA,-(XS) STACK LENGTH OF CODE
MVW MOVE CODE TO EXBLK
MOV (XS)+,WA GET LENGTH OF CODE
BTW WA CONVERT BAU COUNT TO WORD COUNT
LCT WA,WA PREPARE COUNTER FOR LOOP
MOV (XS),XL COPY EXBLK PTR, DONT UNSTACK
ADD *EXCOD,XL POINT TO CODE ITSELF
MOV 1(XS),WB GET REDUCTION IN OFFSET
*
* THIS LOOP SEARCHES FOR NEGATION AND SELECTION CODE SO
* THAT THE OFFSETS COMPUTED WHILST CODE WAS IN CODE BLOCK
* CAN BE TRANSFORMED TO REDUCED VALUES APPLICABLE IN AN
* EXBLK.
*
EXBL1 MOV (XL)+,XR GET NEXT CODE WORD
BEQ XR,=OSLA$,EXBL3 JUMP IF SELECTION FOUND
BEQ XR,=ONTA$,EXBL3 JUMP IF NEGATION FOUND
BCT WA,EXBL1 LOOP TO END OF CODE
*
* NO SELECTION FOUND OR MERGE TO EXIT ON TERMINATION
*
EXBL2 MOV (XS)+,XR POP EXBLK PTR INTO XR
MOV (XS)+,XL POP REDUCTION CONSTANT
EXI RETURN TO CALLER
EJC
*
* EXBLD (CONTINUED)
*
* SELECTION OR NEGATION FOUND
* REDUCE THE OFFSETS AS NEEDED. OFFSETS OCCUR IN WORDS
* FOLLOWING CODE WORDS -
* =ONTA$, =OSLA$, =OSLB$, =OSLC$
*
EXBL3 SUB WB,(XL)+ ADJUST OFFSET
BCT WA,EXBL4 DECREMENT COUNT
*
EXBL4 BCT WA,EXBL5 DECREMENT COUNT
*
* CONTINUE SEARCH FOR MORE OFFSETS
*
EXBL5 MOV (XL)+,XR GET NEXT CODE WORD
BEQ XR,=OSLA$,EXBL3 JUMP IF OFFSET FOUND
BEQ XR,=OSLB$,EXBL3 JUMP IF OFFSET FOUND
BEQ XR,=OSLC$,EXBL3 JUMP IF OFFSET FOUND
BEQ XR,=ONTA$,EXBL3 JUMP IF OFFSET FOUND
BCT WA,EXBL5 LOOP
BRN EXBL2 MERGE TO RETURN
ENP END PROCEDURE EXBLD
EJC
*
* EXPAN -- ANALYZE EXPRESSION
*
* THE EXPRESSION ANALYZER (EXPAN) PROCEDURE IS USED TO SCAN
* AN EXPRESSION AND CONVERT IT INTO A TREE REPRESENTATION.
* SEE DESCRIPTIONS OF CMBLK, CUBLK, CBBLK IN THE STRUCTURES
* SECTION FOR DETAILED FORMAT OF TREE BLOCKS.
*
* THE ANALYZER USES A SIMPLE PRECEDENCE SCHEME IN WHICH
* OPERANDS AND OPERATORS ARE PLACED ON A SINGLE STACK
* AND CONDENSATIONS ARE MADE WHEN LOW PRECEDENCE OPERATORS
* ARE STACKED AFTER A HIGHER PRECEDENCE OPERATOR. A GLOBAL
* VARIABLE (IN WB) KEEPS TRACK OF THE LEVEL AS FOLLOWS.
*
* 0 SCANNING OUTER LEVEL OF STATEMENT OR EXPRESSION
* 1 SCANNING OUTER LEVEL OF NORMAL GOTO
* 2 SCANNING OUTER LEVEL OF DIRECT GOTO
* 3 SCANNING INSIDE ARRAY BRACKETS
* 4 SCANNING INSIDE GROUPING PARENTHESES
* 5 SCANNING INSIDE FUNCTION PARENTHESES
*
* THIS VARIABLE IS SAVED ON THE STACK ON ENCOUNTERING A
* GROUPING AND RESTORED AT THE END OF THE GROUPING.
*
* ANOTHER GLOBAL VARIABLE (IN WC) COUNTS THE NUMBER OF
* ITEMS AT ONE GROUPING LEVEL AND IS INCREMENTED FOR EACH
* COMMA ENCOUNTERED. IT IS STACKED WITH THE LEVEL INDICATOR
*
* THE SCAN IS CONTROLLED BY A THREE STATE FINITE MACHINE.
* A GLOBAL VARIABLE STORED IN WA IS THE CURRENT STATE.
*
* WA=0 NOTHING SCANNED AT THIS LEVEL
* WA=1 OPERAND EXPECTED
* WA=2 OPERATOR EXPECTED
*
* (WB) CALL TYPE (SEE BELOW)
* JSR EXPAN CALL TO ANALYZE EXPRESSION
* (XR) POINTER TO RESULTING TREE
* (XL,WA,WB,WC,RA) DESTROYED
*
* THE ENTRY VALUE OF WB INDICATES THE CALL TYPE AS FOLLOWS.
*
* 0 SCANNING EITHER THE MAIN BODY OF A STATEMENT OR THE
* TEXT OF AN EXPRESSION (FROM EVAL CALL). VALID
* TERMINATORS ARE COLON, SEMICOLON. THE RESCAN FLAG IS
* SET TO RETURN THE TERMINATOR ON THE NEXT SCANE CALL.
*
* 1 SCANNING A NORMAL GOTO. THE ONLY VALID
* TERMINATOR IS A RIGHT PAREN.
*
* 2 SCANNING A DIRECT GOTO. THE ONLY VALID
* TERMINATOR IS A RIGHT BRACKET.
EJC
*
* EXPAN (CONTINUED)
*
* ENTRY POINT
*
EXPAN PRC E,0 ENTRY POINT
ZER -(XS) SET TOP OF STACK INDICATOR
ZER WA SET INITIAL STATE TO ZERO
ZER WC ZERO COUNTER VALUE
*
* LOOP HERE FOR SUCCESSIVE ENTRIES
*
EXP01 JSR SCANE SCAN NEXT ELEMENT
ADD WA,XL ADD STATE TO SYNTAX CODE
BSW XL,T$NES SWITCH ON ELEMENT TYPE/STATE
IFF T$VA0,EXP03 VARIABLE, S=0
IFF T$VA1,EXP03 VARIABLE, STATE ONE
IFF T$VA2,EXP04 VARIABLE, S=2
IFF T$CO0,EXP03 CONSTANT, S=0
IFF T$CO1,EXP03 CONSTANT, S=1
IFF T$CO2,EXP04 CONSTANT, S=2
IFF T$LP0,EXP06 LEFT PAREN, S=0
IFF T$LP1,EXP06 LEFT PAREN, S=1
IFF T$LP2,EXP04 LEFT PAREN, S=2
IFF T$FN0,EXP10 FUNCTION, S=0
IFF T$FN1,EXP10 FUNCTION, S=1
IFF T$FN2,EXP04 FUNCTION, S=2
IFF T$RP0,EXP02 RIGHT PAREN, S=0
IFF T$RP1,EXP05 RIGHT PAREN, S=1
IFF T$RP2,EXP12 RIGHT PAREN, S=2
IFF T$LB0,EXP08 LEFT BRKT, S=0
IFF T$LB1,EXP08 LEFT BRKT, S=1
IFF T$LB2,EXP09 LEFT BRKT, S=2
IFF T$RB0,EXP02 RIGHT BRKT, S=0
IFF T$RB1,EXP05 RIGHT BRKT, S=1
IFF T$RB2,EXP18 RIGHT BRKT, S=2
IFF T$UO0,EXP27 UNOP, S=0
IFF T$UO1,EXP27 UNOP, S=1
IFF T$UO2,EXP04 UNOP, S=2
IFF T$BO0,EXP05 BINOP, S=0
IFF T$BO1,EXP05 BINOP, S=1
IFF T$BO2,EXP26 BINOP, S=2
IFF T$CM0,EXP02 COMMA, S=0
IFF T$CM1,EXP05 COMMA, S=1
IFF T$CM2,EXP11 COMMA, S=2
IFF T$CL0,EXP02 COLON, S=0
IFF T$CL1,EXP05 COLON, S=1
IFF T$CL2,EXP19 COLON, S=2
IFF T$SM0,EXP02 SEMICOLON, S=0
IFF T$SM1,EXP05 SEMICOLON, S=1
IFF T$SM2,EXP19 SEMICOLON, S=2
ESW END SWITCH ON ELEMENT TYPE/STATE
EJC
*
* EXPAN (CONTINUED)
*
* HERE FOR RBR,RPR,COL,SMC,CMA IN STATE 0
*
* SET TO RESCAN THE TERMINATOR ENCOUNTERED AND CREATE
* A NULL CONSTANT (CASE OF OMITTED NULL)
*
EXP02 MNZ SCNRS SET TO RESCAN ELEMENT
MOV =NULLS,XR POINT TO NULL, MERGE
*
* HERE FOR VAR OR CON IN STATES 0,1
*
* STACK THE VARIABLE/CONSTANT AND SET STATE=2
*
EXP03 MOV XR,-(XS) STACK POINTER TO OPERAND
MOV =NUM02,WA SET STATE 2
BRN EXP01 JUMP FOR NEXT ELEMENT
*
* HERE FOR VAR,CON,LPR,FNC,UOP IN STATE 2
*
* WE RESCAN THE ELEMENT AND CREATE A CONCATENATION OPERATOR
* THIS IS THE CASE OF THE BLANK CONCATENATION OPERATOR.
*
EXP04 MNZ SCNRS SET TO RESCAN ELEMENT
MOV =OPDVC,XR POINT TO CONCAT OPERATOR DV
BZE WB,EXP4A OK IF AT TOP LEVEL
MOV =OPDVP,XR ELSE POINT TO UNMISTAKEABLE CONCAT
*
* MERGE WITH CORRECT CONCATENATION DVBLK IN XR
*
EXP4A BNZ SCNBL,EXP26 MERGE BOP IF BLANKS, ELSE ERROR
DCV SCNSE ADJUST START OF ELEMENT LOCATION
ERB 219,SYNTAX ERROR. MISSING OPERATOR
*
* HERE FOR CMA,RPR,RBR,COL,SMC,BOP(S=1) BOP(S=0)
*
* THIS IS AN ERRONOUS CONTRUCTION
*
EXP05 DCV SCNSE ADJUST START OF ELEMENT LOCATION
ERB 220,SYNTAX ERROR. MISSING OPERAND
*
* HERE FOR LPR (S=0,1)
*
EXP06 MOV =NUM04,XL SET NEW LEVEL INDICATOR
ZER XR SET ZERO VALUE FOR CMOPN
EJC
*
* EXPAN (CONTINUED)
*
* MERGE HERE TO STORE OLD LEVEL ON STACK AND START NEW ONE
*
EXP07 MOV XR,-(XS) STACK CMOPN VALUE
MOV WC,-(XS) STACK OLD COUNTER
MOV WB,-(XS) STACK OLD LEVEL INDICATOR
CHK CHECK FOR STACK OVERFLOW
ZER WA SET NEW STATE TO ZERO
MOV XL,WB SET NEW LEVEL INDICATOR
MOV =NUM01,WC INITIALIZE NEW COUNTER
BRN EXP01 JUMP TO SCAN NEXT ELEMENT
*
* HERE FOR LBR (S=0,1)
*
* THIS IS AN ILLEGAL USE OF LEFT BRACKET
*
EXP08 ERB 221,SYNTAX ERROR. INVALID USE OF LEFT BRACKET
*
* HERE FOR LBR (S=2)
*
* SET NEW LEVEL AND START TO SCAN SUBSCRIPTS
*
EXP09 MOV (XS)+,XR LOAD ARRAY PTR FOR CMOPN
MOV =NUM03,XL SET NEW LEVEL INDICATOR
BRN EXP07 JUMP TO STACK OLD AND START NEW
*
* HERE FOR FNC (S=0,1)
*
* STACK OLD LEVEL AND START TO SCAN ARGUMENTS
*
EXP10 MOV =NUM05,XL SET NEW LEV INDIC (XR=VRBLK=CMOPN)
BRN EXP07 JUMP TO STACK OLD AND START NEW
*
* HERE FOR CMA (S=2)
*
* INCREMENT ARGUMENT COUNT AND CONTINUE
*
EXP11 ICV WC INCREMENT COUNTER
JSR EXPDM DUMP OPERATORS AT THIS LEVEL
ZER -(XS) SET NEW LEVEL FOR PARAMETER
ZER WA SET NEW STATE
BGT WB,=NUM02,EXP01 LOOP BACK UNLESS OUTER LEVEL
ERB 222,SYNTAX ERROR. INVALID USE OF COMMA
EJC
*
* EXPAN (CONTINUED)
*
* HERE FOR RPR (S=2)
*
* AT OUTER LEVEL IN A NORMAL GOTO THIS IS A TERMINATOR
* OTHERWISE IT MUST TERMINATE A FUNCTION OR GROUPING
*
EXP12 BEQ WB,=NUM01,EXP20 END OF NORMAL GOTO
BEQ WB,=NUM05,EXP13 END OF FUNCTION ARGUMENTS
BEQ WB,=NUM04,EXP14 END OF GROUPING / SELECTION
ERB 223,SYNTAX ERROR. UNBALANCED RIGHT PARENTHESIS
*
* HERE AT END OF FUNCTION ARGUMENTS
*
EXP13 MOV =C$FNC,XL SET CMTYP VALUE FOR FUNCTION
BRN EXP15 JUMP TO BUILD CMBLK
*
* HERE FOR END OF GROUPING
*
EXP14 BEQ WC,=NUM01,EXP17 JUMP IF END OF GROUPING
MOV =C$SEL,XL ELSE SET CMTYP FOR SELECTION
*
* MERGE HERE TO BUILD CMBLK FOR LEVEL JUST SCANNED AND
* TO POP UP TO THE PREVIOUS SCAN LEVEL BEFORE CONTINUING.
*
EXP15 JSR EXPDM DUMP OPERATORS AT THIS LEVEL
MOV WC,WA COPY COUNT
ADD =CMVLS,WA ADD FOR STANDARD FIELDS AT START
WTB WA CONVERT LENGTH TO BAUS
JSR ALLOC ALLOCATE SPACE FOR CMBLK
MOV =B$CMT,(XR) STORE TYPE CODE FOR CMBLK
MOV XL,CMTYP(XR) STORE CMBLK NODE TYPE INDICATOR
MOV WA,CMLEN(XR) STORE LENGTH
ADD WA,XR POINT PAST END OF BLOCK
LCT WC,WC SET LOOP COUNTER
*
* LOOP TO MOVE REMAINING WORDS TO CMBLK
*
EXP16 MOV (XS)+,-(XR) MOVE ONE OPERAND PTR FROM STACK
MOV (XS)+,WB POP TO OLD LEVEL INDICATOR
BCT WC,EXP16 LOOP TILL ALL MOVED
EJC
*
* EXPAN (CONTINUED)
*
* COMPLETE CMBLK AND STACK POINTER TO IT ON STACK
*
SUB *CMVLS,XR POINT BACK TO START OF BLOCK
MOV (XS)+,WC RESTORE OLD COUNTER
MOV (XS),CMOPN(XR) STORE OPERAND PTR IN CMBLK
MOV XR,(XS) STACK CMBLK POINTER
MOV =NUM02,WA SET NEW STATE
BRN EXP01 BACK FOR NEXT ELEMENT
*
* HERE AT END OF A PARENTHESIZED EXPRESSION
*
EXP17 JSR EXPDM DUMP OPERATORS AT THIS LEVEL
MOV (XS)+,XR RESTORE XR
MOV (XS)+,WB RESTORE OUTER LEVEL
MOV (XS)+,WC RESTORE OUTER COUNT
MOV XR,(XS) STORE OPND OVER UNUSED CMOPN VAL
MOV =NUM02,WA SET NEW STATE
BRN EXP01 BACK FOR NEXT ELE8ENT
*
* HERE FOR RBR (S=2)
*
* AT OUTER LEVEL IN A DIRECT GOTO, THIS IS A TERMINATOR.
* OTHERWISE IT MUST TERMINATE A SUBSCRIPT LIST.
*
EXP18 MOV =C$ARR,XL SET CMTYP FOR ARRAY REFERENCE
BEQ WB,=NUM03,EXP15 JUMP TO BUILD CMBLK IF END ARRAYREF
BEQ WB,=NUM02,EXP20 JUMP IF END OF DIRECT GOTO
ERB 224,SYNTAX ERROR. UNBALANCED RIGHT BRACKET
EJC
*
* EXPAN (CONTINUED)
*
* HERE FOR COL,SMC (S=2)
*
* ERROR UNLESS TERMINATING STATEMENT BODY AT OUTER LEVEL
*
EXP19 MNZ SCNRS RESCAN TERMINATOR
MOV WB,XL COPY LEVEL INDICATOR
BSW XL,6 SWITCH ON LEVEL INDICATOR
IFF 0,EXP20 NORMAL OUTER LEVEL
IFF 1,EXP22 FAIL IF NORMAL GOTO
IFF 2,EXP23 FAIL IF DIRECT GOTO
IFF 3,EXP24 FAIL ARRAY BRACKETS
IFF 4,EXP21 FAIL IF IN GROUPING
IFF 5,EXP21 FAIL FUNCTION ARGS
ESW END SWITCH ON LEVEL
*
* HERE AT NORMAL END OF EXPRESSION
*
EXP20 JSR EXPDM DUMP REMAINING OPERATORS
MOV (XS)+,XR LOAD TREE POINTER
ICA XS POP OFF BOTTOM OF STACK MARKER
EXI RETURN TO EXPAN CALLER
*
* MISSING RIGHT PAREN
*
EXP21 ERB 225,SYNTAX ERROR. MISSING RIGHT PAREN
*
* MISSING RIGHT PAREN IN GOTO FIELD
*
EXP22 ERB 226,SYNTAX ERROR. RIGHT PAREN MISSING FROM GOTO
*
* MISSING BRACKET IN GOTO
*
EXP23 ERB 227,SYNTAX ERROR. RIGHT BRACKET MISSING FROM GOTO
*
* MISSING ARRAY BRACKET
*
EXP24 ERB 228,SYNTAX ERROR. MISSING RIGHT ARRAY BRACKET
EJC
*
* EXPAN (CONTINUED)
*
* LOOP HERE WHEN AN OPERATOR CAUSES AN OPERATOR DUMP
*
EXP25 MOV XR,EXPSV
JSR EXPOP POP ONE OPERATOR
MOV EXPSV,XR RESTORE OP DV POINTER AND MERGE
*
* HERE FOR BOP (S=2)
*
* REMOVE OPERATORS (CONDENSE) FROM STACK UNTIL NO MORE
* LEFT AT THIS LEVEL OR TOP ONE HAS LOWER PRECEDENCE.
* LOOP HERE TILL THIS CONDITION IS MET.
*
EXP26 MOV 1(XS),XL LOAD OPERATOR DVPTR FROM STACK
BLE XL,=NUM05,EXP27 JUMP IF BOTTOM OF STACK LEVEL
BLT DVRPR(XR),DVLPR(XL),EXP25 ELSE POP IF NEW PREC IS LO
*
* HERE FOR UOP (S=0,1)
*
* BINARY OPERATOR MERGES AFTER PRECEDENCE CHECK
*
* THE OPERATOR DV IS STORED ON THE STACK AND THE SCAN
* CONTINUES AFTER SETTING THE SCAN STATE TO ONE.
*
EXP27 MOV XR,-(XS) STACK OPERATOR DVPTR ON STACK
CHK CHECK FOR STACK OVERFLOW
MOV =NUM01,WA SET NEW STATE
BNE XR,=OPDVS,EXP01 BACK FOR NEXT ELEMENT UNLESS =
*
* HERE FOR SPECIAL CASE OF BINARY =. THE SYNTAX ALLOWS A
* NULL RIGHT ARGUMENT FOR THIS OPERATOR TO BE LEFT
* OUT. ACCORDINGLY WE RESET TO STATE ZERO TO GET PROPER
* ACTION ON A TERMINATOR (SUPPLY A NULL CONSTANT).
*
ZER WA SET STATE ZERO
BRN EXP01 JUMP FOR NEXT ELEMENT
ENP END PROCEDURE EXPAN
EJC
*
* EXPAP -- TEST FOR PATTERN MATCH TREE
*
* EXPAP IS PASSED AN EXPRESSION TREE TO DETERMINE IF IT
* IS A PATTERN MATCH. THE FOLLOWING ARE RECOGIZED AS
* MATCHES IN THE CONTEXT OF THIS CALL.
*
* 1) AN EXPLICIT USE OF BINARY QUESTION MARK
* 2) A CONCATENATION
* 3) AN ALTERNATION WHOSE LEFT OPERAND IS A CONCATENATION
*
* (XR) PTR TO EXPAN TREE
* JSR EXPAP CALL TO TEST FOR PATTERN MATCH
* PPM LOC TRANSFER LOC IF NOT A PATTERN MATCH
* (WA) DESTROYED
* (XR) UNCHANGED (IF NOT MATCH)
* (XR) PTR TO BINARY OPERATOR BLK IF MATCH
*
EXPAP PRC E,1 ENTRY POINT
MOV XL,-(XS) SAVE XL
BNE (XR),=B$CMT,EXPP2 NO MATCH IF NOT COMPLEX
MOV CMTYP(XR),WA ELSE LOAD TYPE CODE
BEQ WA,=C$CNC,EXPP1 CONCATENATION IS A MATCH
BEQ WA,=C$PMT,EXPP1 BINARY QUESTION MARK IS A MATCH
BNE WA,=C$ALT,EXPP2 ELSE NOT MATCH UNLESS ALTERNATION
*
* HERE FOR ALTERNATION. CHANGE (A B) / C TO A QM (B / C)
*
MOV CMLOP(XR),XL LOAD LEFT OPERAND POINTER
BNE (XL),=B$CMT,EXPP2 NOT MATCH IF LEFT OPND NOT COMPLEX
BNE CMTYP(XL),=C$CNC,EXPP2 NOT MATCH IF LEFT OP NOT CONC
MOV CMROP(XL),CMLOP(XR) XR POINTS TO (B / C)
MOV XR,CMROP(XL) SET XL OPNDS TO A, (B / C)
MOV XL,XR POINT TO THIS ALTERED NODE
*
* EXIT HERE FOR PATTERN MATCH
*
EXPP1 MOV (XS)+,XL RESTORE ENTRY XL
EXI GIVE PATTERN MATCH RETURN
*
* EXIT HERE IF NOT PATTERN MATCH
*
EXPP2 MOV (XS)+,XL RESTORE ENTRY XL
EXI 1 GIVE NON-MATCH RETURN
ENP END PROCEDURE EXPAP
EJC
*
* EXPDM -- DUMP OPERATORS AT CURRENT LEVEL (FOR EXPAN)
*
* EXPDM USES EXPOP TO CONDENSE ALL OPERATORS AT THIS SYNTAX
* LEVEL. THE STACK BOTTOM IS RECOGNIZED FROM THE LEVEL
* VALUE WHICH IS SAVED ON THE TOP OF THE STACK.
*
* JSR EXPDM CALL TO DUMP OPERATORS
* (XS) POPPED AS REQUIRED
* (XR,WA) DESTROYED
*
EXPDM PRC N,0 ENTRY POINT
MOV XL,R$EXS SAVE XL VALUE
*
* LOOP TO DUMP OPERATORS
*
EXDM1 BLE 1(XS),=NUM05,EXDM2 JUMP IF STACK BOTTOM (SAVED LEVEL)
JSR EXPOP ELSE POP ONE OPERATOR
BRN EXDM1 AND LOOP BACK
*
* HERE AFTER POPPING ALL OPERATORS
*
EXDM2 MOV R$EXS,XL RESTORE XL
ZER R$EXS RELEASE SAVE LOCATION
EXI RETURN TO EXPDM CALLER
ENP END PROCEDURE EXPDM
EJC
*
* EXPOP-- POP OPERATOR (FOR EXPAN)
*
* EXPOP IS USED BY THE EXPAN ROUTINE TO CONDENSE ONE
* OPERATOR FROM THE TOP OF THE SYNTAX STACK. AN APPROPRIATE
* CMBLK IS BUILT FOR THE OPERATOR (UNARY OR BINARY) AND A
* POINTER TO THIS CMBLK IS STACKED.
*
* EXPOP IS ALSO USED BY SCNGF (GOTO FIELD SCAN) PROCEDURE
*
* JSR EXPOP CALL TO POP OPERATOR
* (XS) POPPED APPROPRIATELY
* (XR,XL,WA) DESTROYED
*
EXPOP PRC N,0 ENTRY POINT
MOV 1(XS),XR LOAD OPERATOR DV POINTER
BEQ DVLPR(XR),=LLUNO,EXPO2 JUMP IF UNARY
*
* HERE FOR BINARY OPERATOR
*
MOV *CMBS$,WA SET SIZE OF BINARY OPERATOR CMBLK
JSR ALLOC ALLOCATE SPACE FOR CMBLK
MOV (XS)+,CMROP(XR) POP AND STORE RIGHT OPERAND PTR
MOV (XS)+,XL POP AND LOAD OPERATOR DV PTR
MOV (XS),CMLOP(XR) STORE LEFT OPERAND POINTER
*
* COMMON EXIT POINT
*
EXPO1 MOV =B$CMT,(XR) STORE TYPE CODE FOR CMBLK
MOV DVTYP(XL),CMTYP(XR) STORE CMBLK NODE TYPE CODE
MOV XL,CMOPN(XR) STORE DVPTR (=PTR TO DAC O$XXX)
MOV WA,CMLEN(XR) STORE CMBLK LENGTH
MOV XR,(XS) STORE RESULTING NODE PTR ON STACK
EXI RETURN TO EXPOP CALLER
*
* HERE FOR UNARY OPERATOR
*
EXPO2 MOV *CMUS$,WA SET SIZE OF UNARY OPERATOR CMBLK
JSR ALLOC ALLOCATE SPACE FOR CMBLK
MOV (XS)+,CMROP(XR) POP AND STORE OPERAND POINTER
MOV (XS),XL LOAD OPERATOR DV POINTER
BRN EXPO1 MERGE BACK TO EXIT
ENP END PROCEDURE EXPOP
EJC
*
* GBCOL -- PERFORM GARBAGE COLLECTION
*
* GBCOL PERFORMS A GARBAGE COLLECTION ON THE DYNAMIC REGION
* ALL BLOCKS WHICH ARE NO LONGER IN USE ARE ELIMINATED
* BY MOVING BLOCKS WHICH ARE IN USE DOWN AND RESETTING
* DNAMP, THE POINTER TO THE NEXT AVAILABLE LOCATION.
*
* (WB) MOVE OFFSET (SEE BELOW)
* JSR GBCOL CALL TO COLLECT GARBAGE
* (XR) DESTROYED
*
* THE FOLLOWING CONDITIONS MUST BE MET AT THE TIME WHEN
* GBCOL IS CALLED.
*
* 1) ALL POINTERS TO BLOCKS IN THE DYNAMIC AREA MUST BE
* ACCESSIBLE TO THE GARBAGE COLLECTOR. THIS MEANS
* THAT THEY MUST OCCUR IN ONE OF THE FOLLOWING.
*
* A) MAIN STACK, WITH CURRENT TOP
* ELEMENT BEING INDICATED BY XS
*
* B) IN RELOCATABLE FIELDS OF VRBLKS.
*
* C) IN REGISTER XL AT THE TIME OF CALL
*
* E) IN THE SPECIAL REGION OF WORKING
* STORAGE WHERE NAMES BEGIN WITH R$.
*
* 2) ALL POINTERS MUST POINT TO THE START OF BLOCKS WITH
* THE SOLE EXCEPTION OF THE CONTENTS OF THE CODE
* POINTER REGISTER WHICH POINTS INTO THE R$COD BLOCK.
*
* 3) NO LOCATION WHICH APPEARS TO CONTAIN A POINTER
* INTO THE DYNAMIC REGION MAY OCCUR UNLESS IT IS IN
* FACT A POINTER TO THE START OF THE BLOCK. HOWEVER
* POINTERS OUTSIDE THIS AREA MAY OCCUR AND WILL
* NOT BE CHANGED BY THE GARBAGE COLLECTOR.
* IT IS ESPECIALLY IMPORTANT TO MAKE SURE THAT XL
* DOES NOT CONTAIN A GARBAGE VALUE FROM SOME PROCESS
* CARRIED OUT BEFORE THE CALL TO THE COLLECTOR.
*
* GBCOL HAS THE CAPABILITY OF MOVING THE FINAL COMPACTED
* RESULT UP IN MEMORY (WITH ADDRESSES ADJUSTED ACCORDINGLY)
* THIS IS USED TO ADD SPACE TO THE STATIC REGION. THE
* ENTRY VALUE OF WB IS THE NUMBER OF BAUS TO MOVE UP.
* THE CALLER MUST GUARANTEE THAT THERE IS ENOUGH ROOM.
* FURTHERMORE THE VALUE IN WB IF IT IS NON-ZERO, MUST BE AT
* LEAST 256 SO THAT THE MWB INSTRUCTION CONDITIONS ARE MET.
EJC
*
* GBCOL (CONTINUED)
*
* THE ALGORITHM, WHICH IS A MODIFICATION OF THE LISP-2
* GARBAGE COLLECTOR DEVISED BY R.DEWAR AND K.BELCHER
* TAKES THREE PASSES AS FOLLOWS.
*
* 1) ALL POINTERS IN MEMORY ARE SCANNED AND BLOCKS IN USE
* DETERMINED FROM THIS SCAN. NOTE THAT THIS PROCEDURE
* IS RECURSIVE AND USES THE MAIN STACK FOR LINKAGE.
* THE MARKING PROCESS IS THUS SIMILAR TO THAT USED IN
* A STANDARD LISP COLLECTOR. HOWEVER THE METHOD OF
* ACTUALLY MARKING THE BLOCKS IS DIFFERENT.
*
* THE FIRST FIELD OF A BLOCK NORMALLY CONTAINS A
* CODE ENTRY POINT POINTER. SUCH AN ENTRY POINTER
* CAN BE DISTINGUISHED FROM THE ADDRESS OF ANY POINTER
* TO BE PROCESSED BY THE COLLECTOR. DURING GARBAGE
* COLLECTION, THIS WORD IS USED TO BUILD A BACK CHAIN
* OF POINTERS THROUGH FIELDS WHICH POINT TO THE BLOCK.
* THE END OF THE CHAIN IS MARKED BY THE OCCURENCE
* OF THE WORD WHICH USED TO BE IN THE FIRST WORD OF
* THE BLOCK. THIS BACKCHAIN SERVES BOTH AS A MARK
* INDICATING THAT THE BLOCK IS IN USE AND AS A LIST OF
* REFERENCES FOR THE RELOCATION PHASE.
*
* 2) STORAGE IS SCANNED SEQUENTIALLY TO DISCOVER WHICH
* BLOCKS ARE CURRENTLY IN USE AS INDICATED BY THE
* PRESENCE OF A BACKCHAIN. TWO POINTERS ARE MAINTAINED
* ONE SCANS THROUGH LOOKING AT EACH BLOCK. THE OTHER
* IS INCREMENTED ONLY FOR BLOCKS FOUND TO BE IN USE.
* IN THIS WAY, THE EVENTUAL LOCATION OF EACH BLOCK CAN
* BE DETERMINED WITHOUT ACTUALLY MOVING ANY BLOCKS.
* AS EACH BLOCK WHICH IS IN USE IS PROCESSED, THE BACK
* CHAIN IS USED TO RESET ALL POINTERS WHICH POINT TO
* THIS BLOCK TO CONTAIN ITS NEW ADDRESS, I.E. THE
* ADDRESS IT WILL OCCUPY AFTER THE BLOCKS ARE MOVED.
* THE FIRST WORD OF THE BLOCK, TAKEN FROM THE END OF
* THE CHAIN IS RESTORED AT THIS POINT.
*
* DURING PASS 2, THE COLLECTOR BUILDS BLOCKS WHICH
* DESCRIBE THE REGIONS OF STORAGE WHICH ARE TO BE
* MOVED IN THE THIRD PASS. THERE IS ONE DESCRIPTOR FOR
* EACH CONTIGUOUS SET OF GOOD BLOCKS. THE DESCRIPTOR
* IS BUILT JUST BEHIND THE BLOCK TO BE MOVED AND
* CONTAINS A POINTER TO THE NEXT BLOCK AND THE NUMBER
* OF WORDS TO BE MOVED.
*
* 3) IN THE THIRD AND FINAL PASS, THE MOVE DESCRIPTOR
* BLOCKS BUILT IN PASS TWO ARE USED TO ACTUALLY MOVE
* THE BLOCKS DOWN TO THE BOTTOM OF THE DYNAMIC REGION.
* THE COLLECTION IS THEN COMPLETE AND THE NEXT
* AVAILABLE LOCATION POINTER IS RESET.
EJC
*
* GBCOL (CONTINUED)
*
GBCOL PRC E,0 ENTRY POINT
BNZ DMVCH,GBC14 FAIL IF IN MID-DUMP
MNZ GBCFL NOTE GBCOL ENTERED
MOV WA,GBSVA SAVE ENTRY WA
MOV WB,GBSVB SAVE ENTRY WB
MOV WC,GBSVC SAVE ENTRY WC
MOV XL,-(XS) SAVE ENTRY XL
SCP WA GET CODE POINTER VALUE
SUB R$COD,WA MAKE RELATIVE
LCP WA AND RESTORE
*
* PROCESS STACK ENTRIES
*
MOV XS,XR POINT TO STACK FRONT
MOV STBAS,XL POINT PAST END OF STACK
BGE XL,XR,GBC00 OK IF D-STACK
MOV XL,XR REVERSE IF ...
MOV XS,XL ... U-STACK
*
* PROCESS THE STACK
*
GBC00 JSR GBCPF PROCESS POINTERS ON STACK
*
* PROCESS SPECIAL WORK LOCATIONS
*
MOV =R$AAA,XR POINT TO START OF RELOCATABLE LOCS
MOV =R$YYY,XL POINT PAST END OF RELOCATABLE LOCS
JSR GBCPF PROCESS WORK FIELDS
*
* PREPARE TO PROCESS VARIABLE BLOCKS
*
MOV HSHTB,WA POINT TO FIRST HASH SLOT POINTER
*
* LOOP THROUGH HASH SLOTS
*
GBC01 MOV WA,XL POINT TO NEXT SLOT
ICA WA BUMP BUCKET POINTER
MOV WA,GBCNM SAVE BUCKET POINTER
EJC
*
* GBCOL (CONTINUED)
*
* LOOP THROUGH VARIABLES ON ONE HASH CHAIN
*
GBC02 MOV (XL),XR LOAD PTR TO NEXT VRBLK
BZE XR,GBC03 JUMP IF END OF CHAIN
MOV XR,XL ELSE COPY VRBLK POINTER
ADD *VRVAL,XR POINT TO FIRST RELOC FLD
ADD *VRNXT,XL POINT PAST LAST (AND TO LINK PTR)
JSR GBCPF PROCESS RELOC FIELDS IN VRBLK
BRN GBC02 LOOP BACK FOR NEXT BLOCK
*
* HERE AT END OF ONE HASH CHAIN
*
GBC03 MOV GBCNM,WA RESTORE BUCKET POINTER
BNE WA,HSHTE,GBC01 LOOP BACK IF MORE BUCKETS TO GO
EJC
*
* GBCOL (CONTINUED)
*
* NOW WE ARE READY TO START PASS TWO. REGISTERS ARE USED
* AS FOLLOWS IN PASS TWO.
*
* (XR) SCANS THROUGH ALL BLOCKS
* (WC) POINTER TO EVENTUAL LOCATION
*
* THE MOVE DESCRIPTION BLOCKS BUILT IN THIS PASS HAVE
* THE FOLLOWING FORMAT.
*
* WORD 1 POINTER TO NEXT MOVE BLOCK,
* ZERO IF END OF CHAIN OF BLOCKS
*
* WORD 2 LENGTH OF BLOCKS TO BE MOVED IN
* BAUS. SET TO THE ADDRESS OF THE
* FIRST BAU WHILE ACTUALLY SCANNING
* THE BLOCKS.
*
* THE FIRST ENTRY ON THIS CHAIN IS A SPECIAL ENTRY
* CONSISTING OF THE TWO WORDS GBCNM AND GBCNS. AFTER
* BUILDING THE CHAIN OF MOVE DESCRIPTORS, GBCNM POINTS TO
* THE FIRST REAL MOVE BLOCK, AND GBCNS IS THE LENGTH OF
* BLOCKS IN USE AT THE START OF STORAGE WHICH NEED NOT
* BE MOVED SINCE THEY ARE IN THE CORRECT POSITION.
*
GBC04 MOV DNAMB,XR POINT TO FIRST BLOCK
MOV XR,WC SET AS FIRST EVENTUAL LOCATION
ADD GBSVB,WC ADD OFFSET FOR EVENTUAL MOVE UP
ZER GBCNM CLEAR INITIAL FORWARD POINTER
MOV =GBCNM,GBCLM INITIALIZE PTR TO LAST MOVE BLOCK
MOV XR,GBCNS INITIALIZE FIRST ADDRESS
*
* LOOP THROUGH A SERIES OF BLOCKS IN USE
*
GBC05 BEQ XR,DNAMP,GBC07 JUMP IF END OF USED REGION
MOV (XR),WA ELSE GET FIRST WORD
.IF .CEPP
BOD WA,GBC07 JUMP IF ENTRY POINTER (UNUSED)
.ELSE
BHI WA,=P$YYY,GBC06 SKIP IF NOT ENTRY PTR (IN USE)
BHI WA,=B$AAA,GBC07 JUMP IF ENTRY POINTER (UNUSED)
.FI
*
* HERE FOR BLOCK IN USE, LOOP TO RELOCATE REFERENCES
*
GBC06 MOV WA,XL COPY POINTER
MOV (XL),WA LOAD FORWARD POINTER
MOV WC,(XL) RELOCATE REFERENCE
.IF .CEPP
BEV WA,GBC06 LOOP BACK IF NOT END OF CHAIN
.ELSE
BHI WA,=P$YYY,GBC06 LOOP BACK IF NOT END OF CHAIN
BLO WA,=B$AAA,GBC06 LOOP BACK IF NOT END OF CHAIN
.FI
EJC
*
* GBCOL (CONTINUED)
*
* AT END OF CHAIN, RESTORE FIRST WORD AND BUMP PAST
*
MOV WA,(XR) RESTORE FIRST WORD
JSR BLKLN GET LENGTH OF THIS BLOCK
ADD WA,XR BUMP ACTUAL POINTER
ADD WA,WC BUMP EVENTUAL POINTER
BRN GBC05 LOOP BACK FOR NEXT BLOCK
*
* HERE AT END OF A SERIES OF BLOCKS IN USE
*
GBC07 MOV XR,WA COPY POINTER PAST LAST BLOCK
MOV GBCLM,XL POINT TO PREVIOUS MOVE BLOCK
SUB 1(XL),WA SUBTRACT STARTING ADDRESS
MOV WA,1(XL) STORE LENGTH OF BLOCK TO BE MOVED
*
* LOOP THROUGH A SERIES OF BLOCKS NOT IN USE
*
GBC08 BEQ XR,DNAMP,GBC10 JUMP IF END OF USED REGION
MOV (XR),WA ELSE LOAD FIRST WORD OF NEXT BLOCK
.IF .CEPP
BEV WA,GBC09 JUMP IF IN USE
.ELSE
BHI WA,=P$YYY,GBC09 JUMP IF IN USE
BLO WA,=B$AAA,GBC09 JUMP IF IN USE
.FI
JSR BLKLN ELSE GET LENGTH OF NEXT BLOCK
ADD WA,XR PUSH POINTER
BRN GBC08 AND LOOP BACK
*
* HERE FOR A BLOCK IN USE AFTER PROCESSING A SERIES OF
* BLOCKS WHICH WERE NOT IN USE, BUILD NEW MOVE BLOCK.
*
GBC09 SUB *NUM02,XR POINT 2 WORDS BEHIND FOR MOVE BLOCK
MOV GBCLM,XL POINT TO PREVIOUS MOVE BLOCK
MOV XR,(XL) SET FORWARD PTR IN PREVIOUS BLOCK
ZER (XR) ZERO FORWARD PTR OF NEW BLOCK
MOV XR,GBCLM REMEMBER ADDRESS OF THIS BLOCK
MOV XR,XL COPY PTR TO MOVE BLOCK
ADD *NUM02,XR POINT BACK TO BLOCK IN USE
MOV XR,1(XL) STORE STARTING ADDRESS
BRN GBC06 JUMP TO PROCESS BLOCK IN USE
EJC
*
* GBCOL (CONTINUED)
*
* HERE FOR PASS THREE -- ACTUALLY MOVE THE BLOCKS DOWN
*
* (XL) POINTER TO OLD LOCATION
* (XR) POINTER TO NEW LOCATION
*
GBC10 MOV DNAMB,XR POINT TO START OF STORAGE
ADD GBCNS,XR BUMP PAST UNMOVED BLOCKS AT START
*
* LOOP THROUGH MOVE DESCRIPTORS
*
GBC11 MOV GBCNM,XL POINT TO NEXT MOVE BLOCK
BZE XL,GBC12 JUMP IF END OF CHAIN
MOV (XL)+,GBCNM MOVE POINTER DOWN CHAIN
MOV (XL)+,WA GET LENGTH TO MOVE
MVW PERFORM MOVE
BRN GBC11 LOOP BACK
*
* NOW TEST FOR MOVE UP
*
GBC12 MOV XR,DNAMP SET NEXT AVAILABLE LOC PTR
MOV GBSVB,WB RELOAD MOVE OFFSET
BZE WB,GBC13 JUMP IF NO MOVE REQUIRED
MOV XR,XL ELSE COPY OLD TOP OF CORE
ADD WB,XR POINT TO NEW TOP OF CORE
MOV XR,DNAMP SAVE NEW TOP OF CORE POINTER
MOV XL,WA COPY OLD TOP
SUB DNAMB,WA MINUS OLD BOTTOM = LENGTH
ADD WB,DNAMB BUMP BOTTOM TO GET NEW VALUE
MWB PERFORM MOVE (BACKWARDS)
*
* MERGE HERE TO EXIT
*
GBC13 MOV GBSVA,WA RESTORE WA
SCP WC GET CODE POINTER
ADD R$COD,WC MAKE ABSOLUTE AGAIN
LCP WC AND REPLACE ABSOLUTE VALUE
MOV GBSVC,WC RESTORE WC
MOV (XS)+,XL RESTORE ENTRY XL
ICV GBCNT INCREMENT COUNT OF COLLECTIONS
ZER XR CLEAR GARBAGE VALUE IN XR
ZER GBCFL NOTE EXIT FROM GBCOL
EXI EXIT TO GBCOL CALLER
*
* GARBAGE COLLECTION NOT ALLOWED WHILST DUMPING
*
GBC14 ICV ERRFT FATAL ERROR
ERB 229,INSUFFICIENT MEMORY TO COMPLETE DUMP
ENP END PROCEDURE GBCOL
EJC
*
* GBCPF -- PROCESS FIELDS FOR GARBAGE COLLECTOR
*
* THIS PROCEDURE IS USED BY THE GARBAGE COLLECTOR TO
* PROCESS FIELDS IN PASS ONE. SEE GBCOL FOR FULL DETAILS.
*
* (XR) PTR TO FIRST LOCATION TO PROCESS
* (XL) PTR PAST LAST LOCATION TO PROCESS
* JSR GBCPF CALL TO PROCESS FIELDS
* (XR,WA,WB,WC,IA) DESTROYED
*
* NOTE THAT ALTHOUGH THIS PROCEDURE USES A RECURSIVE
* APPROACH, IT CONTROLS ITS OWN STACK AND IS NOT RECURSIVE.
*
GBCPF PRC E,0 ENTRY POINT
ZER -(XS) SET ZERO TO MARK BOTTOM OF STACK
MOV XL,-(XS) SAVE END POINTER
*
* MERGE HERE TO GO DOWN A LEVEL AND START A NEW LOOP
*
* 1(XS) NEXT LVL FIELD PTR (0 AT OUTER LVL)
* 0(XS) PTR PAST LAST FIELD TO PROCESS
* (XR) PTR TO FIRST FIELD TO PROCESS
*
* LOOP TO PROCESS SUCCESSIVE FIELDS
*
GPF01 MOV (XR),XL LOAD FIELD CONTENTS
MOV XR,WC SAVE FIELD POINTER
.IF .CRPP
BOD XL,GPF02 JUMP IF NOT PTR INTO DYNAMIC AREA
.ELSE
.FI
BLT XL,DNAMB,GPF02 JUMP IF NOT PTR INTO DYNAMIC AREA
BGE XL,DNAMP,GPF02 JUMP IF NOT PTR INTO DYNAMIC AREA
*
* HERE WE HAVE A PTR TO A BLOCK IN THE DYNAMIC AREA.
* LINK THIS FIELD ONTO THE REFERENCE BACKCHAIN.
*
MOV (XL),WA LOAD PTR TO CHAIN (OR ENTRY PTR)
MOV XR,(XL) SET THIS FIELD AS NEW HEAD OF CHAIN
MOV WA,(XR) SET FORWARD POINTER
*
* NOW SEE IF THIS BLOCK HAS BEEN PROCESSED BEFORE
*
.IF .CEPP
BOD WA,GPF03 JUMP IF NOT ALREADY PROCESSED
.ELSE
BHI WA,=P$YYY,GPF02 JUMP IF ALREADY PROCESSED
BHI WA,=B$AAA,GPF03 JUMP IF NOT ALREADY PROCESSED
.FI
*
* HERE TO MOVE TO NEXT FIELD
*
GPF02 MOV WC,XR RESTORE FIELD POINTER
ICA XR BUMP TO NEXT FIELD
BNE XR,(XS),GPF01 LOOP BACK IF MORE TO GO
EJC
*
* GBCPF (CONTINUED)
*
* HERE WE POP UP A LEVEL AFTER FINISHING A BLOCK
*
MOV (XS)+,XL RESTORE POINTER PAST END
MOV (XS)+,WC RESTORE BLOCK POINTER
BNZ WC,GPF02 CONTINUE LOOP UNLESS OUTER LEVL
EXI RETURN TO CALLER IF OUTER LEVEL
*
* HERE TO PROCESS AN ACTIVE BLOCK WHICH HAS NOT BEEN DONE
*
GPF03 MOV XL,XR COPY BLOCK POINTER
MOV WA,XL COPY FIRST WORD OF BLOCK
LEI XL LOAD ENTRY POINT ID (BL$XX)
*
* BLOCK TYPE SWITCH. NOTE THAT BLOCKS WITH NO RELOCATABLE
* FIELDS JUST RETURN TO GPF02 HERE TO CONTINE TO NEXT FLD.
*
BSW XL,BL$$$ SWITCH ON BLOCK TYPE
IFF BL$AR,GPF06 ARBLK
.IF .CNBF
.ELSE
IFF BL$BC,GPF18 BCBLK
IFF BL$BF,GPF02 BFBLK
.FI
IFF BL$CC,GPF07 CCBLK
IFF BL$CD,GPF08 CDBLK
IFF BL$CM,GPF04 CMBLK
IFF BL$CO,GPF19 COBLK
IFF BL$DF,GPF02 DFBLK
IFF BL$EV,GPF10 EVBLK
IFF BL$EX,GPF17 EXBLK
IFF BL$FF,GPF11 FFBLK
IFF BL$NM,GPF10 NMBLK
IFF BL$P0,GPF10 P0BLK
IFF BL$P1,GPF12 P1BLK
IFF BL$P2,GPF12 P2BLK
IFF BL$PD,GPF13 PDBLK
IFF BL$PF,GPF14 PFBLK
IFF BL$TB,GPF08 TBBLK
IFF BL$TE,GPF15 TEBLK
IFF BL$TR,GPF16 TRBLK
IFF BL$VC,GPF08 VCBLK
IFF BL$XR,GPF09 XRBLK
IFF BL$CT,GPF02 CTBLK
IFF BL$EF,GPF02 EFBLK
IFF BL$IC,GPF02 ICBLK
IFF BL$KV,GPF02 KVBLK
.IF .CNRA
.ELSE
IFF BL$RC,GPF02 RCBLK
.FI
IFF BL$SC,GPF02 SCBLK
IFF BL$SE,GPF02 SEBLK
IFF BL$XN,GPF02 XNBLK
ESW END OF JUMP TABLE
EJC
*
* GBCPF (CONTINUED)
*
* CMBLK
*
GPF04 MOV CMLEN(XR),WA LOAD LENGTH
MOV *CMTYP,WB SET OFFSET
*
* HERE TO PUSH DOWN TO NEW LEVEL
*
* (WC) FIELD PTR AT PREVIOUS LEVEL
* (XR) PTR TO NEW BLOCK
* (WA) LENGTH (RELOC FLDS + FLDS AT START)
* (WB) OFFSET TO FIRST RELOC FIELD
*
GPF05 ADD XR,WA POINT PAST LAST RELOC FIELD
ADD WB,XR POINT TO FIRST RELOC FIELD
MOV WC,-(XS) STACK OLD FIELD POINTER
MOV WA,-(XS) STACK NEW LIMIT POINTER
CHK CHECK FOR STACK OVERFLOW
BRN GPF01 IF OK, BACK TO PROCESS
*
* ARBLK
*
GPF06 MOV ARLEN(XR),WA LOAD LENGTH
MOV AROFS(XR),WB SET OFFSET TO 1ST RELOC FLD (ARPRO)
BRN GPF05 ALL SET
*
* CCBLK
*
GPF07 MOV CCUSE(XR),WA SET LENGTH IN USE
MOV *CCUSE,WB 1ST WORD (MAKE SURE AT LEAST ONE)
BRN GPF05 ALL SET
EJC
*
* GBCPF (CONTINUED)
*
* CDBLK, TBBLK, VCBLK
*
GPF08 MOV OFFS2(XR),WA LOAD LENGTH
MOV *OFFS3,WB SET OFFSET
BRN GPF05 JUMP BACK
*
* XRBLK
*
GPF09 MOV XRLEN(XR),WA LOAD LENGTH
MOV *XRPTR,WB SET OFFSET
BRN GPF05 JUMP BACK
*
* EVBLK, NMBLK, P0BLK
*
GPF10 MOV *OFFS2,WA POINT PAST SECOND FIELD
MOV *OFFS1,WB OFFSET IS ONE (ONLY RELOC FLD IS 2)
BRN GPF05 ALL SET
*
* FFBLK
*
GPF11 MOV *FFOFS,WA SET LENGTH
MOV *FFNXT,WB SET OFFSET
BRN GPF05 ALL SET
*
* P1BLK, P2BLK
*
GPF12 MOV *PARM2,WA LENGTH (PARM2 IS NON-RELOCATABLE)
MOV *PTHEN,WB SET OFFSET
BRN GPF05 ALL SET
EJC
*
* GBCPF (CONTINUED)
*
* PDBLK
*
GPF13 MOV PDDFP(XR),XL LOAD PTR TO DFBLK
MOV DFPDL(XL),WA GET PDBLK LENGTH
MOV *PDFLD,WB SET OFFSET
BRN GPF05 ALL SET
*
* PFBLK
*
GPF14 MOV *PFARG,WA LENGTH PAST LAST RELOC
MOV *PFCOD,WB OFFSET TO FIRST RELOC
BRN GPF05 ALL SET
*
* TEBLK
*
GPF15 MOV *TESI$,WA SET LENGTH
MOV *TESUB,WB AND OFFSET
BRN GPF05 ALL SET
*
* TRBLK
*
GPF16 MOV *TRSI$,WA SET LENGTH
MOV *TRVAL,WB AND OFFSET
BRN GPF05 ALL SET
*
* EXBLK
*
GPF17 MOV EXLEN(XR),WA LOAD LENGTH
MOV *EXFLC,WB SET OFFSET
BRN GPF05 JUMP BACK
.IF .CNBF
.ELSE
*
* BCBLK
*
GPF18 MOV *BCSI$,WA SET LENGTH
MOV *BCBUF,WB AND OFFSET
BRN GPF05 ALL SET
.FI
*
* COBLK
*
GPF19 MOV *COSI$,WA SET LENGTH
MOV *CONXT,WB AND OFFSET
BRN GPF05 ALL SET
ENP END PROCEDURE GBCPF
.IF .CNBF
.ELSE
EJC
*
* GTBUF -- GET BUFFER
*
* GTBUF IS PASSED AN OBJECT AND RETURNS A BUFFER IF
* POSSIBLE. UNLESS THE OBJECT IS ALREADY A BUFFER,
* THIS INVOLVES A CONVERSION TO STRING AND THEN
* STRING TO BUFFER.
*
* (XR) OBJECT TO BE CONVERTED
* JSR GTBUF CALL TO GET BUFFER
* PPM LOC TRANSFER LOC FOR CONVERT IMPOSSIBLE
* (XR) RESULTING BUFFER
* (XL,WA,WB,WC) DESTROYED
*
GTBUF PRC E,1 ENTRY POINT
BEQ (XR),=B$BCT,GTB01 EXIT IF ALREADY BUFFER
MOV XR,-(XS) STACK TO CONVERT TO STRING
JSR GTSTG CONVERT TO STRING
PPM GTB02 CONVERSION ERROR
MOV XR,XL SAVE STRING POINTER
JSR ALOBF ALLOCATE BUFFER OF SAME SIZE
JSR INSBF COPY IN THE STRING
PPM ALREADY STRING - CANT FAIL TO CNV
PPM MUST BE ENOUGH ROOM
*
* MERGE TO EXIT WITH BUFFER CONTROL BLK IN (XR)
*
GTB01 EXI RETURN TO CALLER
*
* HERE ON CONVERSION FAILURE
*
GTB02 EXI 1 TAKE FAILURE EXIT
ENP
.FI
EJC
*
* GTARR -- GET ARRAY
*
* GTARR IS PASSED AN OBJECT AND RETURNS AN ARRAY IF POSSIBLE
*
* (XR) VALUE TO BE CONVERTED
* JSR GTARR CALL TO GET ARRAY
* PPM LOC TRANSFER LOC FOR CONVERT IMPOSSIBLE
* (XR) RESULTING ARRAY
* (XL,WA,WB,WC) DESTROYED
*
GTARR PRC E,1 ENTRY POINT
MOV (XR),WA LOAD TYPE WORD
BEQ WA,=B$ART,GTAR8 EXIT IF ALREADY AN ARRAY
BEQ WA,=B$VCT,GTAR8 EXIT IF ALREADY AN ARRAY
MOV XR,-(XS) PLACE POSSIBLE TBBLK PTR ON STACK
BNE WA,=B$TBT,GTAR9 ELSE FAIL IF NOT A TABLE
*
* HERE WE CONVERT A TABLE TO AN ARRAY
*
ZER XR SIGNAL FIRST PASS
ZER WB ZERO NON-NULL ELEMENT COUNT
*
* THE FOLLOWING CODE IS EXECUTED TWICE. ON THE FIRST PASS,
* SIGNALLED BY XR=0, THE NUMBER OF NON-NULL ELEMENTS IN
* THE TABLE IS COUNTED IN WB. IN THE SECOND PASS, WHERE
* XR IS A POINTER INTO THE ARBLK, THE NAME AND VALUE ARE
* ENTERED INTO THE CURRENT ARBLK LOCATION.
*
GTAR1 MOV (XS),XL POINT TO TABLE
ADD TBLEN(XL),XL POINT PAST LAST BUCKET
SUB *TBBUK,XL SET FIRST BUCKET OFFSET
MOV XL,WA COPY ADJUSTED POINTER
*
* LOOP THROUGH BUCKETS IN TABLE BLOCK
* NEXT THREE LINES OF CODE RELY ON TENXT HAVING A VALUE
* 1 LESS THAN TBBUK.
*
GTAR2 MOV WA,XL COPY BUCKET POINTER
DCA WA DECREMENT BUCKET POINTER
*
* LOOP THROUGH TEBLKS ON ONE BUCKET CHAIN
*
GTAR3 MOV TENXT(XL),XL POINT TO NEXT TEBLK
BEQ XL,(XS),GTAR6 JUMP IF CHAIN END (TBBLK PTR)
MOV XL,CNVTP ELSE SAVE TEBLK POINTER
*
* LOOP TO FIND VALUE DOWN TRBLK CHAIN
*
GTAR4 MOV TEVAL(XL),XL LOAD VALUE
BEQ (XL),=B$TRT,GTAR4 LOOP TILL VALUE FOUND
MOV XL,WC COPY VALUE
MOV CNVTP,XL RESTORE TEBLK POINTER
EJC
*
* GTARR (CONTINUED)
*
* NOW CHECK FOR NULL AND TEST CASES
*
BEQ WC,=NULLS,GTAR3 LOOP BACK TO IGNORE NULL VALUE
BNZ XR,GTAR5 JUMP IF SECOND PASS
ICV WB FOR THE FIRST PASS, BUMP COUNT
BRN GTAR3 AND LOOP BACK FOR NEXT TEBLK
*
* HERE IN SECOND PASS
*
GTAR5 MOV TESUB(XL),(XR)+ STORE SUBSCRIPT NAME
MOV WC,(XR)+ STORE VALUE IN ARBLK
BRN GTAR3 LOOP BACK FOR NEXT TEBLK
*
* HERE AFTER SCANNING TEBLKS ON ONE CHAIN
*
GTAR6 BNE WA,(XS),GTAR2 LOOP BACK IF MORE BUCKETS TO GO
BNZ XR,GTAR7 ELSE JUMP IF SECOND PASS
*
* HERE AFTER COUNTING NON-NULL ELEMENTS
*
BZE WB,GTAR9 FAIL IF NO NON-NULL ELEMENTS
MOV WB,WA ELSE COPY COUNT
ADD WB,WA DOUBLE (TWO WORDS/ELEMENT)
ADD =ARVL2,WA ADD SPACE FOR STANDARD FIELDS
WTB WA CONVERT LENGTH TO BAUS
BGE WA,MXLEN,GTAR9 FAIL IF TOO LONG FOR ARRAY
JSR ALLOC ELSE ALLOCATE SPACE FOR ARBLK
MOV =B$ART,(XR) STORE TYPE WORD
ZER IDVAL(XR) ZERO ID FOR THE MOMENT
MOV WA,ARLEN(XR) STORE LENGTH
MOV =NUM02,ARNDM(XR) SET DIMENSIONS = 2
LDI INTV1 GET INTEGER ONE
STI ARLBD(XR) STORE AS LBD 1
STI ARLB2(XR) STORE AS LBD 2
LDI INTV2 LOAD INTEGER TWO
STI ARDM2(XR) STORE AS DIM 2
MTI WB GET ELEMENT COUNT AS INTEGER
STI ARDIM(XR) STORE AS DIM 1
ZER ARPR2(XR) ZERO PROTOTYPE FIELD FOR NOW
MOV *ARPR2,AROFS(XR) SET OFFSET FIELD (SIGNAL PASS 2)
MOV XR,WB SAVE ARBLK POINTER
ADD *ARVL2,XR POINT TO FIRST ELEMENT LOCATION
BRN GTAR1 JUMP BACK TO FILL IN ELEMENTS
EJC
*
* GTARR (CONTINUED)
*
* HERE AFTER FILLING IN ELEMENT VALUES
*
GTAR7 MOV WB,XR RESTORE ARBLK POINTER
MOV WB,(XS) STORE AS RESULT
*
* NOW WE NEED THE ARRAY PROTOTYPE WHICH IS OF THE FORM NN,2
* THIS IS OBTAINED BY BUILDING THE STRING FOR NN02 AND
* CHANGING THE ZERO TO A COMMA BEFORE STORING IT.
*
LDI ARDIM(XR) GET NUMBER OF ELEMENTS (NN)
MLI INTVH MULTIPLY BY 100
ADI INTV2 ADD 2 (NN02)
JSR ICBLD BUILD INTEGER
MOV XR,-(XS) STORE PTR FOR GTSTG
JSR GTSTG CONVERT TO STRING
PPM CONVERT FAIL IS IMPOSSIBLE
MOV XR,XL COPY STRING POINTER
MOV (XS)+,XR RELOAD ARBLK POINTER
MOV XL,ARPR2(XR) STORE PROTOTYPE PTR (NN02)
SUB =NUM02,WA ADJUST LENGTH TO POINT TO ZERO
PSC XL,WA POINT TO ZERO
MOV =CH$CM,WB LOAD A COMMA
SCH WB,(XL) STORE A COMMA OVER THE ZERO
CSC XL COMPLETE STORE CHARACTERS
*
* NORMAL RETURN
*
GTAR8 EXI RETURN TO CALLER
*
* NON-CONVERSION RETURN
*
GTAR9 MOV (XS)+,XR CLEAR UP STACK
EXI 1 RETURN
ENP PROCEDURE GTARR
EJC
*
* GTCOD -- CONVERT TO CODE
*
* (XR) OBJECT TO BE CONVERTED
* JSR GTCOD CALL TO CONVERT TO CODE
* PPM LOC TRANSFER LOC IF CONVERT IMPOSSIBLE
* (XR) POINTER TO RESULTING CDBLK
* (XL,WA,WB,WC,RA) DESTROYED
*
* IF A SPITBOL ERROR OCCURS DURING COMPILATION OR PRE-
* EVALUATION, CONTROL IS PASSED VIA ERROR SECTION TO EXFAL
* WITHOUT RETURNING TO THIS ROUTINE.
*
GTCOD PRC E,1 ENTRY POINT
BEQ (XR),=B$CDS,GTCD1 JUMP IF ALREADY CODE
BEQ (XR),=B$CDC,GTCD1 JUMP IF ALREADY CODE
*
* HERE WE MUST GENERATE A CDBLK BY COMPILATION
*
MOV XR,-(XS) STACK ARGUMENT FOR GTSTG
JSR GTSTG CONVERT ARGUMENT TO STRING
PPM GTCD2 JUMP IF NON-CONVERTIBLE
MOV FLPTR,GTCEF SAVE FAIL PTR IN CASE OF ERROR
MOV R$COD,R$GTC ALSO SAVE CODE PTR
MOV XR,R$CIM ELSE SET IMAGE POINTER
MOV WA,SCNIL SET IMAGE LENGTH
ZER SCNPT SET SCAN POINTER
MOV =STGXC,STAGE SET STAGE FOR EXECUTE COMPILE
MOV CMPSN,LSTSN IN CASE LISTR CALLED
JSR CMPIL COMPILE STRING
MOV =STGXT,STAGE RESET STAGE FOR EXECUTE TIME
ZER R$CIM CLEAR IMAGE
*
* MERGE HERE IF NO CONVERT REQUIRED
*
GTCD1 EXI GIVE NORMAL GTCOD RETURN
*
* HERE IF UNCONVERTIBLE
*
GTCD2 EXI 1 GIVE ERROR RETURN
ENP END PROCEDURE GTCOD
EJC
*
* GTEXP -- CONVERT TO EXPRESSION
*
* (XR) INPUT VALUE TO BE CONVERTED
* JSR GTEXP CALL TO CONVERT TO EXPRESSION
* PPM LOC TRANSFER LOC IF CONVERT IMPOSSIBLE
* (XR) POINTER TO RESULT EXBLK OR SEBLK
* (XL,WA,WB,WC,RA) DESTROYED
*
* IF A SPITBOL ERROR OCCURS DURING COMPILATION OR PRE-
* EVALUATION, CONTROL IS PASSED VIA ERROR SECTION TO EXFAL
* WITHOUT RETURNING TO THIS ROUTINE.
*
GTEXP PRC E,1 ENTRY POINT
BLO (XR),=B$E$$,GTEX1 JUMP IF ALREADY AN EXPRESSION
MOV XR,-(XS) STORE ARGUMENT FOR GTSTG
JSR GTSTG CONVERT ARGUMENT TO STRING
PPM GTEX2 JUMP IF UNCONVERTIBLE
*
* CHECK THE LAST CHAR OF STRING FOR COLON OR
* SEMICOLON. THEY CAN LEGITIMATELY END AN EXPRESSION
* IN OPEN CODE, SO EXPAN WILL NOT FAIL THEM BUT THEY ARE
* INVALID AS TERMINATORS FOR A STRING WHICH IS TO BE
* CONVERTED TO EXPRESSION FORM.
*
MOV XR,XL COPY ARGUMENT STRING
PLC XL,WA POINT PAST STRING END
LCH XL,-(XL) GET LAST CHAR
BEQ XL,=CH$CL,GTEX2 FAIL IF COLON
BEQ XL,=CH$SM,GTEX2 FAIL IF SEMICOLON
*
* HERE WE CONVERT A STRING BY COMPILATION
*
MOV XR,R$CIM SET INPUT IMAGE POINTER
ZER SCNPT SET SCAN POINTER
MOV WA,SCNIL SET INPUT IMAGE LENGTH
ZER WB SET CODE FOR NORMAL SCAN
MOV FLPTR,GTCEF SAVE FAIL PTR IN CASE OF ERROR
MOV R$COD,R$GTC ALSO SAVE CODE PTR
MOV =STGEV,STAGE ADJUST STAGE FOR COMPILE
MOV =T$UOK,SCNTP INDICATE UNARY OPERATOR ACCEPTABLE
JSR EXPAN BUILD TREE FOR EXPRESSION
ZER SCNRS RESET RESCAN FLAG
BNE SCNPT,SCNIL,GTEX2 ERROR IF NOT END OF IMAGE
ZER WB SET OK VALUE FOR CDGEX CALL
MOV XR,XL COPY TREE POINTER
JSR CDGEX BUILD EXPRESSION BLOCK
ZER R$CIM CLEAR POINTER
MOV =STGXT,STAGE RESTORE STAGE FOR EXECUTE TIME
*
* MERGE HERE IF NO CONVERSION REQUIRED
*
GTEX1 EXI RETURN TO GTEXP CALLER
*
* HERE IF UNCONVERTIBLE
*
GTEX2 EXI 1 TAKE ERROR EXIT
ENP END PROCEDURE GTEXP
EJC
*
* GTINT -- GET INTEGER VALUE
*
* GTINT IS PASSED AN OBJECT AND RETURNS AN INTEGER AFTER
* PERFORMING ANY NECESSARY CONVERSIONS.
*
* (XR) VALUE TO BE CONVERTED
* JSR GTINT CALL TO CONVERT TO INTEGER
* PPM LOC TRANSFER LOC FOR CONVERT IMPOSSIBLE
* (XR) RESULTING INTEGER
* (WC,RA) DESTROYED
* (WA,WB) DESTROYED (ONLY ON CONVERSION ERR)
* (XR) UNCHANGED (ON CONVERT ERROR)
*
GTINT PRC E,1 ENTRY POINT
BEQ (XR),=B$ICL,GTIN2 JUMP IF ALREADY AN INTEGER
MOV WA,GTINA ELSE SAVE WA
MOV WB,GTINB SAVE WB
JSR GTNUM CONVERT TO NUMERIC
PPM GTIN3 JUMP IF UNCONVERTIBLE
.IF .CNRA
.ELSE
BEQ WA,=B$ICL,GTIN1 JUMP IF INTEGER
*
* HERE WE CONVERT A REAL TO INTEGER
*
LDR RCVAL(XR) LOAD REAL VALUE
RTI GTIN3 CONVERT TO INTEGER (ERR IF OVFLOW)
JSR ICBLD IF OK BUILD ICBLK
.FI
*
* HERE AFTER SUCCESSFUL CONVERSION TO INTEGER
*
GTIN1 MOV GTINA,WA RESTORE WA
MOV GTINB,WB RESTORE WB
*
* COMMON EXIT POINT
*
GTIN2 EXI RETURN TO GTINT CALLER
*
* HERE ON CONVERSION ERROR
*
GTIN3 EXI 1 TAKE CONVERT ERROR EXIT
ENP END PROCEDURE GTINT
EJC
*
* GTNUM -- GET NUMERIC VALUE
*
* GTNUM IS GIVEN AN OBJECT AND RETURNS EITHER AN INTEGER
* OR A REAL, PERFORMING ANY NECESSARY CONVERSIONS.
*
* (XR) OBJECT TO BE CONVERTED
* JSR GTNUM CALL TO CONVERT TO NUMERIC
* PPM LOC TRANSFER LOC IF CONVERT IMPOSSIBLE
* (XR) POINTER TO RESULT (INT OR REAL)
* (WA) FIRST WORD OF RESULT BLOCK
* (WB,WC,RA) DESTROYED
* (XR) UNCHANGED (ON CONVERT ERROR)
*
GTNUM PRC E,1 ENTRY POINT
MOV (XR),WA LOAD FIRST WORD OF BLOCK
BEQ WA,=B$ICL,GTN3A JUMP IF INTEGER (NO CONVERSION)
.IF .CNRA
.ELSE
BEQ WA,=B$RCL,GTN3A JUMP IF REAL (NO CONVERSION)
.FI
*
* AT THIS POINT THE ONLY POSSIBILITY IS TO CONVERT A STRING
* TO AN INTEGER OR REAL AS APPROPRIATE.
*
STI GTNSV SAVE IA
MOV XR,-(XS) STACK ARGUMENT IN CASE CONVERT ERR
MOV XR,-(XS) STACK ARGUMENT FOR GTSTG
JSR GTSTG CONVERT ARGUMENT TO STRING
PPM GTN36 JUMP IF UNCONVERTIBLE
*
* INITIALIZE NUMERIC CONVERSION
*
LDI INTV0 INITIALIZE INTEGER RESULT TO ZERO
BZE WA,GTN32 JUMP TO EXIT WITH ZERO IF NULL
LCT WA,WA SET BCT COUNTER FOR FOLLOWING LOOPS
ZER GTNNF TENTATIVELY INDICATE RESULT +
.IF .CNRA
.ELSE
STI GTNEX INITIALISE EXPONENT TO ZERO
ZER GTNSC ZERO SCALE IN CASE REAL
ZER GTNDF RESET FLAG FOR DEC POINT FOUND
ZER GTNRD RESET FLAG FOR DIGITS FOUND
LDR REAV0 ZERO REAL ACCUM IN CASE REAL
.FI
PLC XR POINT TO ARGUMENT CHARACTERS
*
* MERGE BACK HERE AFTER IGNORING LEADING BLANK
*
GTN01 LCH WB,(XR)+ LOAD FIRST CHARACTER
BLT WB,=CH$D0,GTN02 JUMP IF NOT DIGIT
BLE WB,=CH$D9,GTN06 JUMP IF FIRST CHAR IS A DIGIT
EJC
*
* GTNUM (CONTINUED)
*
* HERE IF FIRST DIGIT IS NON-DIGIT
*
GTN02 BNE WB,=CH$BL,GTN03 JUMP IF NON-BLANK
GTNA2 BCT WA,GTN01 ELSE DECR COUNT AND LOOP BACK
BRN GTN07 JUMP TO RETURN ZERO IF ALL BLANKS
*
* HERE FOR FIRST CHARACTER NON-BLANK, NON-DIGIT
*
GTN03 BEQ WB,=CH$PL,GTN04 JUMP IF PLUS SIGN
.IF .CAHT
BEQ WB,=CH$HT,GTNA2 HORIZONTAL TAB EQUIV TO BLANK
.FI
.IF .CAVT
BEQ WB,=CH$VT,GTNA2 VERTICAL TAB EQUIV TO BLANK
.FI
.IF .CNRA
BNE WB,=CH$MN,GTN36 ELSE FAIL
.ELSE
BNE WB,=CH$MN,GTN12 JUMP IF NOT MINUS (MAY BE REAL)
.FI
MNZ GTNNF IF MINUS SIGN, SET NEGATIVE FLAG
*
* MERGE HERE AFTER PROCESSING SIGN
*
GTN04 BCT WA,GTN05 JUMP IF CHARS LEFT
BRN GTN36 ELSE ERROR
*
* LOOP TO FETCH CHARACTERS OF AN INTEGER
*
GTN05 LCH WB,(XR)+ LOAD NEXT CHARACTER
BLT WB,=CH$D0,GTN08 JUMP IF NOT A DIGIT
BGT WB,=CH$D9,GTN08 JUMP IF NOT A DIGIT
*
* MERGE HERE FOR FIRST DIGIT
*
GTN06 STI GTNSI SAVE CURRENT VALUE
.IF .CNRA
CVM GTN36 CURRENT*10-(NEW DIG) JUMP IF OVFLOW
.ELSE
CVM GTN35 CURRENT*10-(NEW DIG) JUMP IF OVFLOW
MNZ GTNRD SET DIGIT READ FLAG
.FI
BCT WA,GTN05 ELSE LOOP BACK IF MORE CHARS
*
* HERE TO EXIT WITH CONVERTED INTEGER VALUE
*
GTN07 BNZ GTNNF,GTN32 JUMP IF NEGATIVE (ALL SET)
NGI ELSE NEGATE
INO GTN32 JUMP IF NO OVERFLOW
BRN GTN36 ELSE SIGNAL ERROR
EJC
*
* GTNUM (CONTINUED)
*
* HERE FOR A NON-DIGIT CHARACTER WHILE ATTEMPTING TO
* CONVERT AN INTEGER, CHECK FOR TRAILING BLANKS OR REAL.
*
GTN08 BEQ WB,=CH$BL,GTNA9 JUMP IF A BLANK
.IF .CAHT
BEQ WB,=CH$HT,GTNA9 JUMP IF HORIZONTAL TAB
.FI
.IF .CAVT
BEQ WB,=CH$VT,GTNA9 JUMP IF VERTICAL TAB
.FI
.IF .CNRA
BRN GTN36 ERROR
.ELSE
ITR ELSE CONVERT INTEGER TO REAL
NGR NEGATE TO GET POSITIVE VALUE
BRN GTN12 JUMP TO TRY FOR REAL
.FI
*
* HERE WE SCAN OUT BLANKS TO END OF STRING
*
GTN09 LCH WB,(XR)+ GET NEXT CHAR
.IF .CAHT
BEQ WB,=CH$HT,GTNA9 JUMP IF HORIZONTAL TAB
.FI
.IF .CAVT
BEQ WB,=CH$VT,GTNA9 JUMP IF VERTICAL TAB
.FI
BNE WB,=CH$BL,GTN36 ERROR IF NON-BLANK
GTNA9 BCT WA,GTN09 LOOP BACK IF MORE CHARS TO CHECK
BRN GTN07 RETURN INTEGER IF ALL BLANKS
.IF .CNRA
.ELSE
*
* LOOP TO COLLECT MANTISSA OF REAL
*
GTN10 LCH WB,(XR)+ LOAD NEXT CHARACTER
BLT WB,=CH$D0,GTN12 JUMP IF NON-NUMERIC
BGT WB,=CH$D9,GTN12 JUMP IF NON-NUMERIC
*
* MERGE HERE TO COLLECT FIRST REAL DIGIT
*
GTN11 SUB =CH$D0,WB CONVERT DIGIT TO NUMBER
MLR REAVT MULTIPLY REAL BY 10.0
ROV GTN36 CONVERT ERROR IF OVERFLOW
STR GTNSR SAVE RESULT
MTI WB GET NEW DIGIT AS INTEGER
ITR CONVERT NEW DIGIT TO REAL
ADR GTNSR ADD TO GET NEW TOTAL
ADD GTNDF,GTNSC INCREMENT SCALE IF AFTER DEC POINT
MNZ GTNRD SET DIGIT FOUND FLAG
BCT WA,GTN10 LOOP BACK IF MORE CHARS
BRN GTN22 ELSE JUMP TO SCALE
EJC
*
* GTNUM (CONTINUED)
*
* HERE IF NON-DIGIT FOUND WHILE COLLECTING A REAL
*
GTN12 BNE WB,=CH$DT,GTN13 JUMP IF NOT DEC POINT
BNZ GTNDF,GTN36 IF DEC POINT, ERROR IF ONE ALREADY
MOV =NUM01,GTNDF ELSE SET FLAG FOR DEC POINT
BCT WA,GTN10 LOOP BACK IF MORE CHARS
BRN GTN22 ELSE JUMP TO SCALE
*
* HERE IF NOT DECIMAL POINT
*
GTN13 BEQ WB,=CH$LE,GTN15 JUMP IF E FOR EXPONENT
BEQ WB,=CH$LD,GTN15 JUMP IF D FOR EXPONENT
.IF .CASL
BEQ WB,=CH$$E,GTN15 JUMP FOR EXPT
BEQ WB,=CH$$D,GTN15 JUMP FOR EXPT
.FI
*
* HERE CHECK FOR TRAILING BLANKS
*
GTN14 BEQ WB,=CH$BL,GTNB4 JUMP IF BLANK
.IF .CAHT
BEQ WB,=CH$HT,GTNB4 JUMP IF HORIZONTAL TAB
.FI
.IF .CAVT
BEQ WB,=CH$VT,GTNB4 JUMP IF VERTICAL TAB
.FI
BRN GTN36 ERROR IF NON-BLANK
*
GTNB4 LCH WB,(XR)+ GET NEXT CHARACTER
BCT WA,GTN14 LOOP BACK TO CHECK IF MORE
BRN GTN22 ELSE JUMP TO SCALE
*
* HERE TO READ AND PROCESS AN EXPONENT
*
GTN15 ZER GTNES SET EXPONENT SIGN POSITIVE
LDI INTV0 INITIALIZE EXPONENT TO ZERO
MNZ GTNDF RESET NO DEC POINT INDICATION
BCT WA,GTN16 JUMP SKIPPING PAST E OR D
BRN GTN36 ERROR IF NULL EXPONENT
*
* CHECK FOR EXPONENT SIGN
*
GTN16 LCH WB,(XR)+ LOAD FIRST EXPONENT CHARACTER
BEQ WB,=CH$PL,GTN17 JUMP IF PLUS SIGN
BNE WB,=CH$MN,GTN19 ELSE JUMP IF NOT MINUS SIGN
MNZ GTNES SET SIGN NEGATIVE IF MINUS SIGN
*
* MERGE HERE AFTER PROCESSING EXPONENT SIGN
*
GTN17 BCT WA,GTN18 JUMP IF CHARS LEFT
BRN GTN36 ELSE ERROR
*
* LOOP TO CONVERT EXPONENT DIGITS
*
GTN18 LCH WB,(XR)+ LOAD NEXT CHARACTER
EJC
*
* GTNUM (CONTINUED)
*
* MERGE HERE FOR FIRST EXPONENT DIGIT
*
GTN19 BLT WB,=CH$D0,GTN20 JUMP IF NOT DIGIT
BGT WB,=CH$D9,GTN20 JUMP IF NOT DIGIT
CVM GTN36 ELSE CURRENT*10, SUBTRACT NEW DIGIT
BCT WA,GTN18 LOOP BACK IF MORE CHARS
BRN GTN21 JUMP IF EXPONENT FIELD IS EXHAUSTED
*
* HERE TO CHECK FOR TRAILING BLANKS AFTER EXPONENT
*
GTN20 BEQ WB,=CH$BL,GTNC0 JUMP IF BLANK
.IF .CAHT
BEQ WB,=CH$HT,GTNC0 JUMP IF HORIZONTAL TAB
.FI
.IF .CAVT
BEQ WC,=CH$VT,GTNC0 JUMP IF VERTICAL TAB
.FI
BRN GTN36 ERROR IF NON-BLANK
*
GTNC0 LCH WB,(XR)+ GET NEXT CHARACTER
BCT WA,GTN20 LOOP BACK TILL ALL BLANKS SCANNED
*
* MERGE HERE AFTER COLLECTING EXPONENT
*
GTN21 STI GTNEX SAVE COLLECTED EXPONENT
BNZ GTNES,GTN22 JUMP IF IT WAS NEGATIVE
NGI ELSE COMPLEMENT
IOV GTN36 ERROR IF OVERFLOW
STI GTNEX AND STORE POSITIVE EXPONENT
*
* MERGE HERE WITH EXPONENT (0 IF NONE GIVEN)
*
GTN22 BZE GTNRD,GTN36 ERROR IF NOT DIGITS COLLECTED
BZE GTNDF,GTN36 ERROR IF NO EXPONENT OR DEC POINT
MTI GTNSC ELSE LOAD SCALE AS INTEGER
SBI GTNEX SUBTRACT EXPONENT
IOV GTN36 ERROR IF OVERFLOW
ILT GTN26 JUMP IF WE MUST SCALE UP
*
* HERE WE HAVE A NEGATIVE EXPONENT, SO SCALE DOWN
*
MFI WA,GTN36 LOAD SCALE FACTOR, ERR IF OVFLOW
*
* LOOP TO SCALE DOWN IN STEPS OF 10**10
*
GTN23 BLE WA,=NUM10,GTN24 JUMP IF 10 OR LESS TO GO
DVR REATT ELSE DIVIDE BY 10**10
SUB =NUM10,WA DECREMENT SCALE
BRN GTN23 AND LOOP BACK
EJC
*
* GTNUM (CONTINUED)
*
* HERE SCALE REST OF WAY FROM POWERS OF TEN TABLE
*
GTN24 BZE WA,GTN30 JUMP IF SCALED
LCT WB,=CFP$R ELSE GET INDEXING FACTOR
MOV =REAV1,XR POINT TO POWERS OF TEN TABLE
WTB WA CONVERT REMAINING SCALE TO BAU OFS
*
* LOOP TO POINT TO POWERS OF TEN TABLE ENTRY
*
GTN25 ADD WA,XR BUMP POINTER
BCT WB,GTN25 ONCE FOR EACH VALUE WORD
DVR (XR) SCALE DOWN AS REQUIRED
BRN GTN30 AND JUMP
*
* COME HERE TO SCALE RESULT UP (POSITIVE EXPONENT)
*
GTN26 NGI GET ABSOLUTE VALUE OF EXPONENT
IOV GTN36 ERROR IF OVERFLOW
MFI WA,GTN36 ACQUIRE SCALE, ERROR IF OVFLOW
*
* LOOP TO SCALE UP IN STEPS OF 10**10
*
GTN27 BLE WA,=NUM10,GTN28 JUMP IF 10 OR LESS TO GO
MLR REATT ELSE MULTIPLY BY 10**10
ROV GTN36 ERROR IF OVERFLOW
SUB =NUM10,WA ELSE DECREMENT SCALE
BRN GTN27 AND LOOP BACK
*
* HERE TO SCALE UP REST OF WAY WITH TABLE
*
GTN28 BZE WA,GTN30 JUMP IF SCALED
LCT WB,=CFP$R ELSE GET INDEXING FACTOR
MOV =REAV1,XR POINT TO POWERS OF TEN TABLE
WTB WA CONVERT REMAINING SCALE TO BAU OFS
*
* LOOP TO POINT TO PROPER ENTRY IN POWERS OF TEN TABLE
*
GTN29 ADD WA,XR BUMP POINTER
BCT WB,GTN29 ONCE FOR EACH WORD IN VALUE
MLR (XR) SCALE UP
ROV GTN36 ERROR IF OVERFLOW
EJC
*
* GTNUM (CONTINUED)
*
* HERE WITH REAL VALUE SCALED AND READY EXCEPT FOR SIGN
*
GTN30 BZE GTNNF,GTN31 JUMP IF POSITIVE
NGR ELSE NEGATE
*
* HERE WITH PROPERLY SIGNED REAL VALUE IN (RA)
*
GTN31 JSR RCBLD BUILD REAL BLOCK
BRN GTN33 MERGE TO EXIT
.FI
*
* HERE WITH PROPERLY SIGNED INTEGER VALUE IN (IA)
*
GTN32 JSR ICBLD BUILD ICBLK
*
* REAL MERGES HERE
*
GTN33 MOV (XR),WA LOAD FIRST WORD OF RESULT BLOCK
ICA XS POP ARGUMENT OFF STACK
*
* COMMON EXIT POINT
*
GTN34 LDI GTNSV RECOVER IA
GTN3A EXI RETURN TO GTNUM CALLER
.IF .CNRA
.ELSE
*
* COME HERE IF OVERFLOW OCCURS DURING COLLECTION OF INTEGER
*
GTN35 LDI GTNSI RELOAD INTEGER SO FAR
ITR CONVERT TO REAL
NGR MAKE VALUE POSITIVE
BRN GTN11 MERGE WITH REAL CIRCUIT
.FI
*
* HERE FOR UNCONVERTIBLE TO STRING OR CONVERSION ERROR
*
GTN36 MOV (XS)+,XR RELOAD ORIGINAL ARGUMENT
LDI GTNSV RECOVER IA
EXI 1 TAKE CONVERT-ERROR EXIT
ENP END PROCEDURE GTNUM
EJC
*
* GTNVR -- CONVERT TO NATURAL VARIABLE
*
* GTNVR LOCATES A VARIABLE BLOCK (VRBLK) GIVEN EITHER AN
* APPROPRIATE NAME (NMBLK) OR A NON-NULL STRING (SCBLK).
*
* (XR) ARGUMENT
* JSR GTNVR CALL TO CONVERT TO NATURAL VARIABLE
* PPM LOC TRANSFER LOC IF CONVERT IMPOSSIBLE
* (XR) POINTER TO VRBLK
* (WC) DESTROYED
*
GTNVR PRC E,1 ENTRY POINT
BNE (XR),=B$NML,GNV02 JUMP IF NOT NAME
MOV NMBAS(XR),XR ELSE LOAD NAME BASE IF NAME
BLO XR,STATE,GNV07 SKIP IF VRBLK (IN STATIC REGION)
BRN GNV01 FAIL
*
* RESTORE REGS AND FAIL
*
GNV00 MOV GNVSA,WA RESTORE REGS
MOV GNVSB,WB
*
* COMMON ERROR EXIT
*
GNV01 EXI 1 TAKE CONVERT-ERROR EXIT
*
* HERE IF NOT NAME
*
GNV02 MOV WA,GNVSA SAVE WA
MOV WB,GNVSB SAVE WB
MOV XR,-(XS) STACK ARGUMENT FOR GTSTG
JSR GTSTG CONVERT ARGUMENT TO STRING
PPM GNV00 JUMP IF CONVERSION ERROR
BZE WA,GNV00 NULL STRING IS AN ERROR
MOV XL,-(XS) SAVE XL
.IF .CASL
MOV XR,XL COPY STRING POINTER
ZER WB ZERO OFFSET
JSR SBSTG CONVERT TO PREFERRED CASE
MOV SCLEN(XR),WA RECOVER STRING LENGTH
.FI
MOV XR,-(XS) STACK STRING PTR FOR LATER
MOV XR,WB COPY STRING POINTER
ADD *SCHAR,WB POINT TO CHARACTERS OF STRING
MOV WB,GNVST SAVE POINTER TO CHARACTERS
MOV WA,WB COPY LENGTH
CTW WB,0 GET NUMBER OF WORDS IN NAME
MOV WB,GNVNW SAVE FOR LATER
JSR HASHS COMPUTE HASH INDEX FOR STRING
RMI HSHNB COMPUTE HASH OFFSET BY TAKING MOD
MFI WC GET AS OFFSET
WTB WC CONVERT OFFSET TO BAUS
ADD HSHTB,WC POINT TO PROPER HASH CHAIN
SUB *VRNXT,WC SUBTRACT OFFSET TO MERGE INTO LOOP
EJC
*
* GTNVR (CONTINUED)
*
* LOOP TO SEARCH HASH CHAIN
*
GNV03 MOV WC,XL COPY HASH CHAIN POINTER
MOV VRNXT(XL),XL POINT TO NEXT VRBLK ON CHAIN
BZE XL,GNV08 JUMP IF END OF CHAIN
MOV XL,WC SAVE POINTER TO THIS VRBLK
BNZ VRLEN(XL),GNV04 JUMP IF NOT SYSTEM VARIABLE
MOV VRSVP(XL),XL ELSE POINT TO SVBLK
SUB *VRSOF,XL ADJUST OFFSET FOR MERGE
*
* MERGE HERE WITH STRING PTR (LIKE VRBLK) IN XL
*
GNV04 BNE WA,VRLEN(XL),GNV03 BACK FOR NEXT VRBLK IF LENGTHS NE
ADD *VRCHS,XL ELSE POINT TO CHARS OF CHAIN ENTRY
LCT WB,GNVNW GET WORD COUNTER TO CONTROL LOOP
MOV GNVST,XR POINT TO CHARS OF NEW NAME
*
* LOOP TO COMPARE CHARACTERS OF THE TWO NAMES
*
GNV05 CNE (XR),(XL),GNV03 JUMP IF NO MATCH FOR NEXT VRBLK
ICA XR BUMP NEW NAME POINTER
ICA XL BUMP VRBLK IN CHAIN NAME POINTER
BCT WB,GNV05 ELSE LOOP TILL ALL COMPARED
MOV WC,XR WE HAVE FOUND A MATCH, GET VRBLK
*
* EXIT POINT AFTER FINDING VRBLK OR BUILDING NEW ONE
*
GNV06 MOV GNVSA,WA RESTORE WA
MOV GNVSB,WB RESTORE WB
ICA XS POP STRING POINTER
MOV (XS)+,XL RESTORE XL
*
* COMMON EXIT POINT
*
GNV07 EXI RETURN TO GTNVR CALLER
*
* NOT FOUND, PREPARE TO SEARCH SYSTEM VARIABLE TABLE
*
GNV08 ZER XR CLEAR GARBAGE XR POINTER
MOV WC,GNVHE SAVE PTR TO END OF HASH CHAIN
BGT WA,=NUM09,GNV14 CANNOT BE SYSTEM VAR IF LENGTH GT 9
MOV WA,XL ELSE COPY LENGTH
WTB XL CONVERT TO BAU OFFSET
MOV VSRCH(XL),XL POINT TO FIRST SVBLK OF THIS LENGTH
EJC
*
* GTNVR (CONTINUED)
*
* LOOP TO SEARCH ENTRIES IN STANDARD VARIABLE TABLE
*
GNV09 MOV XL,GNVSP SAVE TABLE POINTER
MOV (XL)+,WC LOAD SVBIT BIT STRING
MOV (XL)+,WB LOAD LENGTH FROM TABLE ENTRY
BNE WA,WB,GNV14 JUMP IF END OF RIGHT LENGTH ENTIRES
LCT WB,GNVNW GET WORD COUNTER TO CONTROL LOOP
MOV GNVST,XR POINT TO CHARS OF NEW NAME
*
* LOOP TO CHECK FOR MATCHING NAMES
*
GNV10 CNE (XR),(XL),GNV11 JUMP IF NAME MISMATCH
ICA XR ELSE BUMP NEW NAME POINTER
ICA XL BUMP SVBLK POINTER
BCT WB,GNV10 ELSE LOOP UNTIL ALL CHECKED
*
* HERE WE HAVE A MATCH IN THE STANDARD VARIABLE TABLE
*
ZER WC SET VRLEN VALUE ZERO
MOV *VRSI$,WA SET STANDARD SIZE
BRN GNV15 JUMP TO BUILD VRBLK
*
* HERE IF NO MATCH WITH TABLE ENTRY IN SVBLKS TABLE
*
GNV11 ICA XL BUMP PAST WORD OF CHARS
BCT WB,GNV11 LOOP BACK IF MORE TO GO
RSH WC,SVNBT REMOVE UNINTERESTING BITS
*
* LOOP TO BUMP TABLE PTR FOR EACH FLAGGED WORD
*
GNV12 MOV BITS1,WB LOAD BIT TO TEST
ANB WC,WB TEST FOR WORD PRESENT
ZRB WB,GNV13 JUMP IF NOT PRESENT
ICA XL ELSE BUMP TABLE POINTER
*
* HERE AFTER DEALING WITH ONE WORD (ONE BIT)
*
GNV13 RSH WC,1 REMOVE BIT ALREADY PROCESSED
NZB WC,GNV12 LOOP BACK IF MORE BITS TO TEST
BRN GNV09 ELSE LOOP BACK FOR NEXT SVBLK
*
* HERE IF NOT SYSTEM VARIABLE
*
GNV14 MOV WA,WC COPY VRLEN VALUE
MOV =VRCHS,WA LOAD STANDARD SIZE -CHARS
ADD GNVNW,WA ADJUST FOR CHARS OF NAME
WTB WA CONVERT LENGTH TO BAUS
EJC
*
* GTNVR (CONTINUED)
*
* MERGE HERE TO BUILD VRBLK
*
GNV15 JSR ALOST ALLOCATE SPACE FOR VRBLK (STATIC)
MOV XR,WB SAVE VRBLK POINTER
MOV =STNVR,XL POINT TO MODEL VARIABLE BLOCK
MOV *VRLEN,WA SET LENGTH OF STANDARD FIELDS
MVW SET INITIAL FIELDS OF NEW BLOCK
MOV GNVHE,XL LOAD POINTER TO END OF HASH CHAIN
MOV WB,VRNXT(XL) ADD NEW BLOCK TO END OF CHAIN
MOV WC,(XR)+ SET VRLEN FIELD, BUMP PTR
MOV GNVNW,WA GET LENGTH IN WORDS
WTB WA CONVERT TO LENGTH IN BAUS
BZE WC,GNV16 JUMP IF SYSTEM VARIABLE
*
* HERE FOR NON-SYSTEM VARIABLE -- SET CHARS OF NAME
*
MOV (XS),XL POINT BACK TO STRING NAME
ADD *SCHAR,XL POINT TO CHARS OF NAME
MVW MOVE CHARACTERS INTO PLACE
MOV WB,XR RESTORE VRBLK POINTER
BRN GNV06 JUMP BACK TO EXIT
*
* HERE FOR SYSTEM VARIABLE CASE TO FILL IN FIELDS WHERE
* NECESSARY FROM THE FIELDS PRESENT IN THE SVBLK.
*
GNV16 MOV GNVSP,XL LOAD POINTER TO SVBLK
MOV XL,(XR) SET SVBLK PTR IN VRBLK
MOV WB,XR RESTORE VRBLK POINTER
MOV SVBIT(XL),WB LOAD BIT INDICATORS
ADD *SVCHS,XL POINT TO CHARACTERS OF NAME
ADD WA,XL POINT PAST CHARACTERS
*
* SKIP PAST KEYWORD NUMBER (SVKNM) IF PRESENT
*
MOV BTKNM,WC LOAD TEST BIT
ANB WB,WC AND TO TEST
ZRB WC,GNV17 JUMP IF NO KEYWORD NUMBER
ICA XL ELSE BUMP POINTER
EJC
*
* GTNVR (CONTINUED)
*
* HERE TEST FOR FUNCTION (SVFNC AND SVNAR)
*
GNV17 MOV BTFNC,WC GET TEST BIT
ANB WB,WC AND TO TEST
ZRB WC,GNV18 SKIP IF NO SYSTEM FUNCTION
MOV XL,VRFNC(XR) ELSE POINT VRFNC TO SVFNC FIELD
ADD *NUM02,XL AND BUMP PAST SVFNC, SVNAR FIELDS
*
* NOW TEST FOR LABEL (SVLBL)
*
GNV18 MOV BTLBL,WC GET TEST BIT
ANB WB,WC AND TO TEST
ZRB WC,GNV19 JUMP IF BIT IS OFF (NO SYSTEM LABL)
MOV XL,VRLBL(XR) ELSE POINT VRLBL TO SVLBL FIELD
ICA XL BUMP PAST SVLBL FIELD
*
* NOW TEST FOR VALUE (SVVAL)
*
GNV19 MOV BTVAL,WC LOAD TEST BIT
ANB WB,WC AND TO TEST
ZRB WC,GNV06 ALL DONE IF NO VALUE
MOV (XL),VRVAL(XR) ELSE SET INITIAL VALUE
MOV =B$VRE,VRSTO(XR) SET ERROR STORE ACCESS
BRN GNV06 MERGE BACK TO EXIT TO CALLER
ENP END PROCEDURE GTNVR
EJC
*
* GTPAT -- GET PATTERN
*
* GTPAT IS PASSED AN OBJECT IN (XR) AND RETURNS A
* PATTERN AFTER PERFORMING ANY NECESSARY CONVERSIONS
*
* (XR) INPUT ARGUMENT
* JSR GTPAT CALL TO CONVERT TO PATTERN
* PPM LOC TRANSFER LOC IF CONVERT IMPOSSIBLE
* (XR) RESULTING PATTERN
* (WA) DESTROYED
* (WB) DESTROYED (ONLY ON CONVERT ERROR)
* (XR) UNCHANGED (ONLY ON CONVERT ERROR)
*
GTPAT PRC E,1 ENTRY POINT
BHI (XR),=P$AAA,GTPT5 JUMP IF PATTERN ALREADY
*
* HERE IF NOT PATTERN, TRY FOR STRING
*
MOV WB,GTPSB SAVE WB
MOV XR,-(XS) STACK ARGUMENT FOR GTSTG
JSR GTSTG CONVERT ARGUMENT TO STRING
PPM GTPT2 JUMP IF IMPOSSIBLE
*
* HERE WE HAVE A STRING
*
BNZ WA,GTPT1 JUMP IF NON-NULL
*
* HERE FOR NULL STRING. GENERATE POINTER TO NULL PATTERN.
*
MOV =NDNTH,XR POINT TO NOTHEN NODE
BRN GTPT4 JUMP TO EXIT
EJC
*
* GTPAT (CONTINUED)
*
* HERE FOR NON-NULL STRING
*
GTPT1 MOV =P$STR,WB LOAD PCODE FOR MULTI-CHAR STRING
BNE WA,=NUM01,GTPT3 JUMP IF MULTI-CHAR STRING
*
* HERE FOR ONE CHARACTER STRING, SHARE ONE CHARACTER ANY
*
PLC XR POINT TO CHARACTER
LCH WA,(XR) LOAD CHARACTER
MOV WA,XR SET AS PARM1
MOV =P$ANS,WB POINT TO PCODE FOR 1-CHAR ANY
BRN GTPT3 JUMP TO BUILD NODE
*
* HERE IF ARGUMENT IS NOT CONVERTIBLE TO STRING
*
GTPT2 MOV =P$EXA,WB SET PCODE FOR EXPRESSION IN CASE
BLO (XR),=B$E$$,GTPT3 JUMP TO BUILD NODE IF EXPRESSION
*
* HERE WE HAVE AN ERROR (CONVERSION IMPOSSIBLE)
*
EXI 1 TAKE CONVERT ERROR EXIT
*
* MERGE HERE TO BUILD NODE FOR STRING OR EXPRESSION
*
GTPT3 JSR PBILD CALL ROUTINE TO BUILD PATTERN NODE
*
* COMMON EXIT AFTER SUCCESSFUL CONVERSION
*
GTPT4 MOV GTPSB,WB RESTORE WB
*
* MERGE HERE TO EXIT IF NO CONVERSION REQUIRED
*
GTPT5 EXI RETURN TO GTPAT CALLER
ENP END PROCEDURE GTPAT
.IF .CNRA
.ELSE
EJC
*
* GTREA -- GET REAL VALUE
*
* GTREA IS PASSED AN OBJECT AND RETURNS A REAL VALUE
* PERFORMING ANY NECESSARY CONVERSIONS.
*
* (XR) OBJECT TO BE CONVERTED
* JSR GTREA CALL TO CONVERT OBJECT TO REAL
* PPM LOC TRANSFER LOC IF CONVERT IMPOSSIBLE
* (XR) POINTER TO RESULTING REAL
* (WA,WB,WC,RA) DESTROYED
* (XR) UNCHANGED (CONVERT ERROR ONLY)
*
GTREA PRC E,1 ENTRY POINT
MOV (XR),WA GET FIRST WORD OF BLOCK
BEQ WA,=B$RCL,GTRE2 JUMP IF REAL
JSR GTNUM ELSE CONVERT ARGUMENT TO NUMERIC
PPM GTRE3 JUMP IF UNCONVERTIBLE
BEQ WA,=B$RCL,GTRE2 JUMP IF REAL WAS RETURNED
*
* HERE FOR CASE OF AN INTEGER TO CONVERT TO REAL
*
GTRE1 LDI ICVAL(XR) LOAD INTEGER
ITR CONVERT TO REAL
JSR RCBLD BUILD RCBLK
*
* EXIT WITH REAL
*
GTRE2 EXI RETURN TO GTREA CALLER
*
* HERE ON CONVERSION ERROR
*
GTRE3 EXI 1 TAKE CONVERT ERROR EXIT
ENP END PROCEDURE GTREA
.FI
EJC
*
* GTSMI -- GET SMALL INTEGER
*
* GTSMI IS PASSED A SNOBOL OBJECT AND RETURNS AN ADDRESS
* INTEGER IN THE RANGE (0 LE N LE DNAMB). SUCH A VALUE CAN
* ONLY BE DERIVED FROM AN INTEGER IN THE APPROPRIATE RANGE.
* SMALL INTEGERS NEVER APPEAR AS SNOBOL VALUES. HOWEVER,
* THEY ARE USED INTERNALLY FOR A VARIETY OF PURPOSES.
*
* -(XS) ARGUMENT TO CONVERT (ON STACK)
* JSR GTSMI CALL TO CONVERT TO SMALL INTEGER
* PPM LOC TRANSFER LOC FOR NOT INTEGER
* PPM LOC TRANSFER LOC FOR LT 0, GT DNAMB
* (XR,WC) RESULTING SMALL INT (TWO COPIES)
* (XS) POPPED
* (RA) DESTROYED
* (WA,WB) DESTROYED (ON CONVERT ERROR ONLY)
* (XR) INPUT ARG (CONVERT ERROR ONLY)
*
GTSMI PRC N,2 ENTRY POINT
MOV (XS)+,XR LOAD ARGUMENT
BEQ (XR),=B$ICL,GTSM1 SKIP IF ALREADY AN INTEGER
*
* HERE IF NOT AN INTEGER
*
JSR GTINT CONVERT ARGUMENT TO INTEGER
PPM GTSM2 JUMP IF CONVERT IS IMPOSSIBLE
*
* MERGE HERE WITH INTEGER
*
GTSM1 LDI ICVAL(XR) LOAD INTEGER VALUE
MFI WC,GTSM3 MOVE AS ONE WORD, JUMP IF OVFLOW
BGT WC,MXLEN,GTSM3 OR IF TOO LARGE
MOV WC,XR COPY RESULT TO XR
EXI RETURN TO GTSMI CALLER
*
* HERE IF UNCONVERTIBLE TO INTEGER
*
GTSM2 EXI 1 TAKE NON-INTEGER ERROR EXIT
*
* HERE IF OUT OF RANGE
*
GTSM3 EXI 2 TAKE OUT-OF-RANGE ERROR EXIT
ENP END PROCEDURE GTSMI
EJC
*
* GTSTG -- GET STRING
*
* GTSTG IS PASSED AN OBJECT AND RETURNS A STRING WITH
* ANY NECESSARY CONVERSIONS PERFORMED.
*
* -(XS) INPUT ARGUMENT (ON STACK)
* JSR GTSTG CALL TO CONVERT TO STRING
* PPM LOC TRANSFER LOC IF CONVERT IMPOSSIBLE
* (XR) POINTER TO RESULTING STRING
* (WA) LENGTH OF STRING IN CHARACTERS
* (XS) POPPED
* (RA) DESTROYED
* (XR) INPUT ARG (CONVERT ERROR ONLY)
*
GTSTG PRC N,1 ENTRY POINT
MOV (XS)+,XR LOAD ARGUMENT, POP STACK
BEQ (XR),=B$SCL,GTS30 JUMP IF ALREADY A STRING
*
* HERE IF NOT A STRING ALREADY
*
GTS01 MOV XR,-(XS) RESTACK ARGUMENT IN CASE ERROR
MOV XL,-(XS) SAVE XL
MOV WB,GTSVB SAVE WB
MOV WC,GTSVC SAVE WC
MOV (XR),WA LOAD FIRST WORD OF BLOCK
BEQ WA,=B$ICL,GTS05 JUMP TO CONVERT INTEGER
.IF .CNRA
.ELSE
BEQ WA,=B$RCL,GTS10 JUMP TO CONVERT REAL
.FI
BEQ WA,=B$NML,GTS03 JUMP TO CONVERT NAME
.IF .CNBF
.ELSE
BEQ WA,=B$BCT,GTS32 JUMP TO CONVERT BUFFER
.FI
*
* HERE ON CONVERSION ERROR
*
GTS02 MOV (XS)+,XL RESTORE XL
MOV (XS)+,XR RELOAD INPUT ARGUMENT
EXI 1 TAKE CONVERT ERROR EXIT
EJC
*
* GTSTG (CONTINUED)
*
* HERE TO CONVERT A NAME (ONLY POSSIBLE IF NATURAL VAR)
*
GTS03 MOV NMBAS(XR),XL LOAD NAME BASE
BHI XL,STATE,GTS02 ERROR IF NOT NATURAL VAR (STATIC)
ADD *VRSOF,XL ELSE POINT TO POSSIBLE STRING NAME
MOV SCLEN(XL),WA LOAD LENGTH
BNZ WA,GTS04 JUMP IF NOT SYSTEM VARIABLE
MOV VRSVO(XL),XL ELSE POINT TO SVBLK
MOV SVLEN(XL),WA AND LOAD NAME LENGTH
*
* MERGE HERE WITH STRING IN XR, LENGTH IN WA
*
GTS04 ZER WB SET OFFSET TO ZERO
JSR SBSTR USE SBSTR TO COPY STRING
BRN GTS29 JUMP TO EXIT
*
* COME HERE TO CONVERT AN INTEGER
*
GTS05 LDI ICVAL(XR) LOAD INTEGER VALUE
.IF .CSCI
JSR SYSCI CONVERT INTEGER
MOV SCLEN(XL),WA GET LENGTH
ZER WB ZERO OFFSET FOR SBSTR
JSR SBSTR COPY IN RESULT FROM SYSCI
BRN GTS29 EXIT
.ELSE
MOV =NUM01,GTSSF SET SIGN FLAG NEGATIVE
ILT GTS06 SKIP IF INTEGER IS NEGATIVE
NGI ELSE NEGATE INTEGER
ZER GTSSF AND RESET NEGATIVE FLAG
EJC
*
* GTSTG (CONTINUED)
*
* HERE WITH SIGN FLAG SET AND SIGN FORCED NEGATIVE AS
* REQUIRED BY THE CVD INSTRUCTION.
*
GTS06 MOV GTSWK,XR POINT TO RESULT WORK AREA
MOV =NSTMX,WB INITIALIZE COUNTER TO MAX LENGTH
PSC XR,WB PREPARE TO STORE (RIGHT-LEFT)
*
* LOOP TO CONVERT DIGITS INTO WORK AREA
*
GTS07 CVD CONVERT ONE DIGIT INTO WA
SCH WA,-(XR) STORE IN WORK AREA
DCV WB DECREMENT COUNTER
INE GTS07 LOOP IF MORE DIGITS TO GO
CSC XR COMPLETE STORE CHARACTERS
*
* MERGE HERE AFTER CONVERTING INTEGER OR REAL INTO WORK
* AREA. WB IS SET TO NSTMX - (NUMBER OF CHARS IN RESULT).
*
GTS08 MOV =NSTMX,WA GET MAX NUMBER OF CHARACTERS
SUB WB,WA COMPUTE LENGTH OF RESULT
MOV WA,XL REMEMBER LENGTH FOR MOVE LATER ON
ADD GTSSF,WA ADD ONE FOR NEGATIVE SIGN IF NEEDED
JSR ALOCS ALLOCATE STRING FOR RESULT
MOV XR,WC SAVE RESULT POINTER FOR THE MOMENT
PSC XR POINT TO CHARS OF RESULT BLOCK
BZE GTSSF,GTS09 SKIP IF POSITIVE
MOV =CH$MN,WA ELSE LOAD NEGATIVE SIGN
SCH WA,(XR)+ AND STORE IT
CSC XR COMPLETE STORE CHARACTERS
.FI
*
* HERE AFTER DEALING WITH SIGN
*
GTS09 MOV XL,WA RECALL LENGTH TO MOVE
MOV GTSWK,XL POINT TO RESULT WORK AREA
PLC XL,WB POINT TO FIRST RESULT CHARACTER
MVC MOVE CHARS TO RESULT STRING
MOV WC,XR RESTORE RESULT POINTER
.IF .CNRA
.ELSE
BRN GTS29 JUMP TO EXIT
EJC
*
* GTSTG (CONTINUED)
*
* HERE TO CONVERT A REAL
*
GTS10 LDR RCVAL(XR) LOAD REAL
ZER GTSSF RESET NEGATIVE FLAG
REQ GTS31 SKIP IF ZERO
RGE GTS11 JUMP IF REAL IS POSITIVE
MOV =NUM01,GTSSF ELSE SET NEGATIVE FLAG
NGR AND GET ABSOLUTE VALUE OF REAL
*
* NOW SCALE THE REAL TO THE RANGE (0.1 LE X LT 1.0)
*
GTS11 LDI INTV0 INITIALIZE EXPONENT TO ZERO
*
* LOOP TO SCALE UP IN STEPS OF 10**10
*
GTS12 STR GTSRS SAVE REAL VALUE
SBR REAP1 SUBTRACT 0.1 TO COMPARE
RGE GTS13 JUMP IF SCALE UP NOT REQUIRED
LDR GTSRS ELSE RELOAD VALUE
MLR REATT MULTIPLY BY 10**10
SBI INTVT DECREMENT EXPONENT BY 10
BRN GTS12 LOOP BACK TO TEST AGAIN
*
* TEST FOR SCALE DOWN REQUIRED
*
GTS13 LDR GTSRS RELOAD VALUE
SBR REAV1 SUBTRACT 1.0
RLT GTS17 JUMP IF NO SCALE DOWN REQUIRED
LDR GTSRS ELSE RELOAD VALUE
*
* LOOP TO SCALE DOWN IN STEPS OF 10**10
*
GTS14 SBR REATT SUBTRACT 10**10 TO COMPARE
RLT GTS15 JUMP IF LARGE STEP NOT REQUIRED
LDR GTSRS ELSE RESTORE VALUE
DVR REATT DIVIDE BY 10**10
STR GTSRS STORE NEW VALUE
ADI INTVT INCREMENT EXPONENT BY 10
BRN GTS14 LOOP BACK
EJC
*
* GTSTG (CONTINUED)
*
* AT THIS POINT WE HAVE (1.0 LE X LT 10**10)
* COMPLETE SCALING WITH POWERS OF TEN TABLE
*
GTS15 MOV =REAV1,XR POINT TO POWERS OF TEN TABLE
*
* LOOP TO LOCATE CORRECT ENTRY IN TABLE
*
GTS16 LDR GTSRS RELOAD VALUE
ADI INTV1 INCREMENT EXPONENT
ADD *CFP$R,XR POINT TO NEXT ENTRY IN TABLE
SBR (XR) SUBTRACT IT TO COMPARE
RGE GTS16 LOOP TILL WE FIND A LARGER ENTRY
LDR GTSRS THEN RELOAD THE VALUE
DVR (XR) AND COMPLETE SCALING
STR GTSRS STORE VALUE
*
* WE ARE NOW SCALED, SO ROUND BY ADDING 0.5 * 10**(-CFP$S)
*
GTS17 LDR GTSRS GET VALUE AGAIN
ADR GTSRN ADD ROUNDING FACTOR
STR GTSRS STORE RESULT
*
* THE ROUNDING OPERATION MAY HAVE PUSHED US UP PAST
* 1.0 AGAIN, SO CHECK ONE MORE TIME.
*
SBR REAV1 SUBTRACT 1.0 TO COMPARE
RLT GTS18 SKIP IF OK
ADI INTV1 ELSE INCREMENT EXPONENT
LDR GTSRS RELOAD VALUE
DVR REAVT DIVIDE BY 10.0 TO RESCALE
BRN GTS19 JUMP TO MERGE
*
* HERE IF ROUNDING DID NOT MUCK UP SCALING
*
GTS18 LDR GTSRS RELOAD ROUNDED VALUE
EJC
*
* GTSTG (CONTINUED)
*
* NOW WE HAVE COMPLETED THE SCALING AS FOLLOWS
*
* (IA) SIGNED EXPONENT
* (RA) SCALED REAL (ABSOLUTE VALUE)
*
* IF THE EXPONENT IS NEGATIVE OR GREATER THAN CFP$S, THEN
* WE CONVERT THE NUMBER IN THE FORM.
*
* (NEG SIGN) 0 . (CPF$S DIGITS) E (EXP SIGN) (EXP DIGITS)
*
* IF THE EXPONENT IS POSITIVE AND LESS THAN OR EQUAL TO
* CFP$S, THE NUMBER IS CONVERTED IN THE FORM.
*
* (NEG SIGN) (EXPONENT DIGITS) . (CFP$S-EXPONENT DIGITS)
*
* IN BOTH CASES, THE FORMATS OBTAINED FROM THE ABOVE
* RULES ARE MODIFIED BY DELETING TRAILING ZEROS AFTER THE
* DECIMAL POINT. THERE ARE NO LEADING ZEROS IN THE EXPONENT
* AND THE EXPONENT SIGN IS ALWAYS PRESENT.
*
GTS19 MOV =CFP$S,XL SET NUM DEC DIGITS = CFP$S
MOV =CH$MN,GTSES SET EXPONENT SIGN NEGATIVE
ILT GTS21 ALL SET IF EXPONENT IS NEGATIVE
MFI WA ELSE FETCH EXPONENT
BLE WA,=CFP$S,GTS20 SKIP IF WE CAN USE SPECIAL FORMAT
MTI WA ELSE RESTORE EXPONENT
NGI SET NEGATIVE FOR CVD
MOV =CH$PL,GTSES SET PLUS SIGN FOR EXPONENT SIGN
BRN GTS21 JUMP TO GENERATE EXPONENT
*
* HERE IF WE CAN USE THE FORMAT WITHOUT AN EXPONENT
*
GTS20 SUB WA,XL COMPUTE DIGITS AFTER DECIMAL POINT
LDI INTV0 RESET EXPONENT TO ZERO
EJC
*
* GTSTG (CONTINUED)
*
* MERGE HERE AS FOLLOWS
*
* (IA) EXPONENT ABSOLUTE VALUE
* GTSES CHARACTER FOR EXPONENT SIGN
* (RA) POSITIVE FRACTION
* (XL) NUMBER OF DIGITS AFTER DEC POINT
*
GTS21 MOV GTSWK,XR POINT TO WORK AREA
MOV =NSTMX,WB SET CHARACTER CTR TO MAX LENGTH
PSC XR,WB PREPARE TO STORE (RIGHT TO LEFT)
IEQ GTS23 SKIP EXPONENT IF IT IS ZERO
*
* LOOP TO GENERATE DIGITS OF EXPONENT
*
GTS22 CVD CONVERT A DIGIT INTO WA
SCH WA,-(XR) STORE IN WORK AREA
DCV WB DECREMENT COUNTER
INE GTS22 LOOP BACK IF MORE DIGITS TO GO
*
* HERE GENERATE EXPONENT SIGN AND E
*
MOV GTSES,WA LOAD EXPONENT SIGN
SCH WA,-(XR) STORE IN WORK AREA
.IF .CPLC
MOV =CH$$E,WA GET CHAR LETTER E
.ELSE
MOV =CH$LE,WA GET CHARACTER LETTER E
.FI
SCH WA,-(XR) STORE IN WORK AREA
SUB =NUM02,WB DECREMENT COUNTER FOR SIGN AND E
*
* HERE TO GENERATE THE FRACTION
*
GTS23 MLR GTSSC CONVERT REAL TO INTEGER (10**CFP$S)
RTI GET INTEGER (OVERFLOW IMPOSSIBLE)
NGI NEGATE AS REQUIRED BY CVD
*
* LOOP TO SUPPRESS TRAILING ZEROS
*
GTS24 BZE XL,GTS27 JUMP IF NO DIGITS LEFT TO DO
CVD ELSE CONVERT ONE DIGIT
BNE WA,=CH$D0,GTS26 JUMP IF NOT A ZERO
DCV XL DECREMENT COUNTER
BRN GTS24 LOOP BACK FOR NEXT DIGIT
EJC
*
* GTSTG (CONTINUED)
*
* LOOP TO GENERATE DIGITS AFTER DECIMAL POINT
*
GTS25 CVD CONVERT A DIGIT INTO WA
*
* MERGE HERE FIRST TIME
*
GTS26 SCH WA,-(XR) STORE DIGIT
DCV WB DECREMENT COUNTER
DCV XL DECREMENT COUNTER
BNZ XL,GTS25 LOOP BACK IF MORE TO GO
*
* HERE GENERATE THE DECIMAL POINT
*
GTS27 MOV =CH$DT,WA LOAD DECIMAL POINT
SCH WA,-(XR) STORE IN WORK AREA
DCV WB DECREMENT COUNTER
*
* HERE GENERATE THE DIGITS BEFORE THE DECIMAL POINT
*
GTS28 CVD CONVERT A DIGIT INTO WA
SCH WA,-(XR) STORE IN WORK AREA
DCV WB DECREMENT COUNTER
INE GTS28 LOOP BACK IF MORE TO GO
CSC XR COMPLETE STORE CHARACTERS
BRN GTS08 ELSE JUMP BACK TO EXIT
.FI
*
* EXIT POINT AFTER SUCCESSFUL CONVERSION
*
GTS29 MOV (XS)+,XL RESTORE XL
ICA XS POP ARGUMENT
MOV GTSVB,WB RESTORE WB
MOV GTSVC,WC RESTORE WC
*
* MERGE HERE IF NO CONVERSION REQUIRED
*
GTS30 MOV SCLEN(XR),WA LOAD STRING LENGTH
EXI RETURN TO CALLER
.IF .CNRA
.ELSE
*
* HERE TO RETURN STRING FOR REAL ZERO
*
GTS31 MOV =SCRE0,XL POINT TO STRING
MOV =NUM02,WA 2 CHARS
ZER WB ZERO OFFSET
JSR SBSTR COPY STRING
BRN GTS29 RETURN
.FI
.IF .CNBF
.ELSE
EJC
*
* HERE TO CONVERT A BUFFER BLOCK
*
GTS32 MOV XR,XL COPY ARG PTR
MOV BCLEN(XL),WA GET SIZE TO ALLOCATE
BZE WA,GTS33 IF NULL THEN RETURN NULL
JSR ALOCS ALLOCATE STRING FRAME
MOV XR,WB SAVE STRING PTR
MOV SCLEN(XR),WA GET LENGTH TO MOVE
CTB WA,0 GET AS MULTIPLE OF WORD SIZE
MOV BCBUF(XL),XL POINT TOBFBLK
ADD *SCSI$,XR POINT TO START OF CHARACTER AREA
ADD *BFSI$,XL POINT TO START OF BUFFER CHARS
MVW COPY WORDS
MOV WB,XR RESTORE SCBLK PTR
BRN GTS29 EXIT WITH SCBLK
*
* HERE WHEN NULL BUFFER IS BEING CONVERTED
*
GTS33 MOV =NULLS,XR POINT TO NULL
BRN GTS29 EXIT WITH NULL
.FI
ENP END PROCEDURE GTSTG
EJC
*
* GTVAR -- GET VARIABLE FOR I/O/TRACE ASSOCIATION
*
* GTVAR IS USED TO POINT TO AN ACTUAL VARIABLE LOCATION
* FOR THE DETACH,INPUT,OUTPUT,TRACE,STOPTR SYSTEM FUNCTIONS
*
* (XR) ARGUMENT TO FUNCTION
* JSR GTVAR CALL TO LOCATE VARIABLE POINTER
* PPM LOC TRANSFER LOC IF NOT OK VARIABLE
* (XL,WA) NAME BASE,OFFSET OF VARIABLE
* (XR,RA) DESTROYED
* (WB,WC) DESTROYED (CONVERT ERROR ONLY)
* (XR) INPUT ARG (CONVERT ERROR ONLY)
*
GTVAR PRC E,1 ENTRY POINT
BNE (XR),=B$NML,GTVR2 JUMP IF NOT A NAME
MOV NMOFS(XR),WA ELSE LOAD NAME OFFSET
MOV NMBAS(XR),XL LOAD NAME BASE
BEQ (XL),=B$EVT,GTVR1 ERROR IF EXPRESSION VARIABLE
BNE (XL),=B$KVT,GTVR3 ALL OK IF NOT KEYWORD VARIABLE
*
* HERE ON CONVERSION ERROR
*
GTVR1 EXI 1 TAKE CONVERT ERROR EXIT
*
* HERE IF NOT A NAME, TRY CONVERT TO NATURAL VARIABLE
*
GTVR2 MOV WC,GTVRC SAVE WC
JSR GTNVR LOCATE VRBLK IF POSSIBLE
PPM GTVR1 JUMP IF CONVERT ERROR
MOV XR,XL ELSE COPY VRBLK NAME BASE
MOV *VRVAL,WA AND SET OFFSET
MOV GTVRC,WC RESTORE WC
*
* HERE FOR NAME OBTAINED
*
GTVR3 BHI XL,STATE,GTVR4 ALL OK IF NOT NATURAL VARIABLE
BEQ VRSTO(XL),=B$VRE,GTVR1 ERROR IF PROTECTED VARIABLE
*
* COMMON EXIT POINT
*
GTVR4 EXI RETURN TO CALLER
ENP END PROCEDURE GTVAR
EJC
*
* HASHS -- COMPUTE HASH INDEX FOR STRING
*
* HASHS REPRODUCIBLY MAPS A STRING TO AN INTEGER
* VALUE. THE RESULTING HASH VALUE IS A POSITIVE INTEGER
* IN THE RANGE 0 TO CFP$M
*
* (XR) STRING TO BE HASHED
* JSR HASHS CALL TO HASH STRING
* (IA) HASH VALUE
* (XR,WB,WC) DESTROYED
*
* THE HASH FUNCTION USED IS AS FOLLOWS.
*
* START WITH THE LENGTH OF THE STRING
*
* TAKE THE FIRST E$HNW WORDS OF THE CHARACTERS FROM
* THE STRING OR ALL THE WORDS IF FEWER THAN E$HNW.
*
* COMPUTE THE EXCLUSIVE OR OF ALL THESE WORDS TREATING
* THEM AS ONE WORD BIT STRING VALUES.
*
* MOVE THE RESULT AS AN INTEGER WITH THE MTI INSTRUCTION.
*
HASHS PRC E,0 ENTRY POINT
MOV SCLEN(XR),WC LOAD STRING LENGTH IN CHARACTERS
MOV WC,WB INITIALIZE WITH LENGTH
BZE WC,HSHS3 JUMP IF NULL STRING
CTW WC,0 ELSE GET NUMBER OF WORDS OF CHARS
ADD *SCHAR,XR POINT TO CHARACTERS OF STRING
BLO WC,=E$HNW,HSHS1 USE WHOLE STRING IF SHORT
MOV =E$HNW,WC ELSE SET TO INVOLVE FIRST E$HNW WDS
*
* HERE WITH COUNT OF WORDS TO CHECK IN WC
*
HSHS1 LCT WC,WC SET COUNTER TO CONTROL LOOP
*
* LOOP TO COMPUTE EXCLUSIVE OR
*
HSHS2 XOB (XR)+,WB EXCLUSIVE OR NEXT WORD OF CHARS
BCT WC,HSHS2 LOOP TILL ALL PROCESSED
*
* MERGE HERE WITH EXCLUSIVE OR IN WB
*
HSHS3 ZGB WB ZEROISE UNDEFINED BITS
ANB BITSM,WB ENSURE IN RANGE 0 TO CFP$M
MTI WB MOVE RESULT AS INTEGER
ZER XR CLEAR GARBAGE VALUE IN XR
EXI RETURN TO HASHS CALLER
ENP END PROCEDURE HASHS
EJC
*
* ICBLD -- BUILD INTEGER BLOCK
*
* (IA) INTEGER VALUE FOR ICBLK
* JSR ICBLD CALL TO BUILD INTEGER BLOCK
* (XR) POINTER TO RESULT ICBLK
* (WA) DESTROYED
*
ICBLD PRC E,0 ENTRY POINT
ILT ICBL1 SKIP IF NEGATIVE
SBI INTV2 REDUCE BY TWO
ILE ICBL3 JUMP IF 0 , 1 OR 2
ADI INTV2 RESTORE VALUE
*
* CONSTRUCT ICBLK
*
ICBL1 MOV DNAMP,XR LOAD POINTER TO NEXT AVAILABLE LOC
ADD *ICSI$,XR POINT PAST NEW ICBLK
BLO XR,DNAME,ICBL2 JUMP IF THERE IS ROOM
MOV *ICSI$,WA ELSE LOAD LENGTH OF ICBLK
JSR ALLOC USE STANDARD ALLOCATOR TO GET BLOCK
ADD WA,XR POINT PAST BLOCK TO MERGE
*
* MERGE HERE WITH XR POINTING PAST THE BLOCK OBTAINED
*
ICBL2 MOV XR,DNAMP SET NEW POINTER
SUB *ICSI$,XR POINT BACK TO START OF BLOCK
MOV =B$ICL,(XR) STORE TYPE WORD
STI ICVAL(XR) STORE INTEGER VALUE IN ICBLK
EXI RETURN TO ICBLD CALLER
*
* OPTIMISE BY NOT BUILDING ICBLKS FOR SMALL INTEGERS
*
ICBL3 ADI INTV2 RESTORE VALUE
MFI XR CONVERT TO SHORT INTEGER
WTB XR CONVERT INTEGER TO OFFSET
MOV INTAB(XR),XR POINT TO PRE-BUILT ICBLK
EXI RETURN
ENP END PROCEDURE ICBLD
EJC
*
* IDENT -- COMPARE TWO VALUES
*
* IDENT COMPARES TWO VALUES IN THE SENSE OF THE IDENT
* DIFFER FUNCTIONS AVAILABLE AT THE SNOBOL LEVEL.
*
* (XR) FIRST ARGUMENT
* (XL) SECOND ARGUMENT
* JSR IDENT CALL TO COMPARE ARGUMENTS
* PPM LOC TRANSFER LOC IF IDENT
* (NORMAL RETURN IF DIFFER)
* (XR,XL,WC,RA) DESTROYED
*
IDENT PRC E,1 ENTRY POINT
BEQ XR,XL,IDEN7 JUMP IF SAME POINTER (IDENT)
MOV (XR),WC ELSE LOAD ARG 1 TYPE WORD
BNE WC,(XL),IDEN1 DIFFER IF ARG 2 TYPE WORD DIFFER
BEQ WC,=B$SCL,IDEN2 JUMP IF STRINGS
BEQ WC,=B$ICL,IDEN4 JUMP IF INTEGERS
.IF .CNRA
.ELSE
BEQ WC,=B$RCL,IDEN5 JUMP IF REALS
.FI
BEQ WC,=B$NML,IDEN6 JUMP IF NAMES
*
* FOR ALL OTHER DATATYPES, MUST BE DIFFER IF XR NE XL
*
* MERGE HERE FOR DIFFER
*
IDEN1 EXI TAKE DIFFER EXIT
*
* HERE FOR STRINGS, IDENT ONLY IF LENGTHS AND CHARS SAME
*
IDEN2 MOV SCLEN(XR),WC LOAD ARG 1 LENGTH
BNE WC,SCLEN(XL),IDEN1 DIFFER IF LENGTHS DIFFER
CTW WC,0 GET NUMBER OF WORDS IN STRINGS
ADD *SCHAR,XR POINT TO CHARS OF ARG 1
ADD *SCHAR,XL POINT TO CHARS OF ARG 2
LCT WC,WC SET LOOP COUNTER
*
* LOOP TO COMPARE CHARACTERS. NOTE THAT WA CANNOT BE ZERO
* SINCE ALL NULL STRINGS POINT TO NULLS AND GIVE XL=XR.
*
IDEN3 CNE (XR),(XL),IDEN8 DIFFER IF CHARS DO NOT MATCH
ICA XR ELSE BUMP ARG ONE POINTER
ICA XL BUMP ARG TWO POINTER
BCT WC,IDEN3 LOOP BACK TILL ALL CHECKED
EJC
*
* IDENT (CONTINUED)
*
* HERE TO EXIT FOR CASE OF TWO IDENT STRINGS
*
ZER XL CLEAR GARBAGE VALUE IN XL
ZER XR CLEAR GARBAGE VALUE IN XR
EXI 1 TAKE IDENT EXIT
*
* HERE FOR INTEGERS, IDENT IF SAME VALUES
*
IDEN4 LDI ICVAL(XR) LOAD ARG 1
SBI ICVAL(XL) SUBTRACT ARG 2 TO COMPARE
IOV IDEN1 DIFFER IF OVERFLOW
INE IDEN1 DIFFER IF RESULT IS NOT ZERO
EXI 1 TAKE IDENT EXIT
.IF .CNRA
.ELSE
*
* HERE FOR REALS, IDENT IF SAME VALUES
*
IDEN5 LDR RCVAL(XR) LOAD ARG 1
SBR RCVAL(XL) SUBTRACT ARG 2 TO COMPARE
ROV IDEN1 DIFFER IF OVERFLOW
RNE IDEN1 DIFFER IF RESULT IS NOT ZERO
EXI 1 TAKE IDENT EXIT
.FI
*
* HERE FOR NAMES, IDENT IF BASES AND OFFSETS SAME
*
IDEN6 BNE NMOFS(XR),NMOFS(XL),IDEN1 DIFFER IF DIFFERENT OFFSET
BNE NMBAS(XR),NMBAS(XL),IDEN1 DIFFER IF DIFFERENT BASE
*
* MERGE HERE TO SIGNAL IDENT FOR IDENTICAL POINTERS
*
IDEN7 EXI 1 TAKE IDENT EXIT
*
* HERE FOR DIFFER STRINGS
*
IDEN8 ZER XR CLEAR GARBAGE PTR IN XR
ZER XL CLEAR GARBAGE PTR IN XL
EXI RETURN TO CALLER (DIFFER)
ENP END PROCEDURE IDENT
EJC
*
* INOUT - USED TO INITIALISE .INPUT .OUTPUT .TERMINAL
*
* (XL) POINTER TO VBL NAME STRING
* (WB) TRBLK TYPE (TRTYP FIELD)
* JSR INOUT CALL TO PERFORM INITIALISATION
* (WA,WC) DESTROYED
*
* NOTE THAT TRTER (= TRTRF) FIELD OF STANDARD I/O VARIABLES
* POINTS TO CORRESPONDING SVBLK NOT TO A TRBLK AS IS THE
* CASE FOR ORDINARY VARIABLES.
*
INOUT PRC E,0 ENTRY POINT
MOV WB,-(XS) STACK TRBLK TYPE
MOV SCLEN(XL),WA GET NAME LENGTH
ZER WB POINT TO START OF NAME
JSR SBSTR BUILD A PROPER SCBLK
JSR GTNVR FIND OR BUILD VRBLK
PPM NO ERROR RETURN
MOV XR,WC SAVE VRBLK POINTER
MOV (XS)+,WB GET TRTYP FIELD
ZER XL ZERO TRTRI
MOV VRSVP(XR),XR GET SVBLK POINTER
JSR TRBLD BUILD TRBLK
MOV WC,XL RECALL VRBLK POINTER
MOV *VRVAL,WA OFFSET TO VALUE FIELD
JSR TRCHN PUT TRBLK IN TRACE CHAIN
PPM CANT FAIL
EXI RETURN TO CALLER
ENP END PROCEDURE INOUT
EJC
.IF .CNBF
.ELSE
*
* INSBF -- INSERT STRING IN BUFFER
*
* THIS ROUTINE WILL REPLACE A SECTION OF A BUFFER WITH THE
* CONTENTS OF A GIVEN STRING. IF THE LENGTH OF THE
* SECTION TO BE REPLACED DIFFERS FROM THAT OF THE
* GIVEN STRING, AND THE REPLACEMENT IS NOT AN APPEND,
* THEN THE UPPER SECTION OF THE BUFFER IS SHIFTED UP OR
* DOWN TO CREATE THE PROPER SPACE FOR THE INSERT.
*
* (XR) POINTER TO BCBLK
* (XL) OBJECT WHICH IS STRING CONVERTIBLE
* (WA) OFFSET OF START OF INSERT IN (XR)
* (WB) LENGTH OF SECTION IN (XR) REPLACED
* JSR INSBF CALL TO INSERT CHARACTERS IN BUFFER
* PPM LOC ERROR IF (XR) NOT CONVERTIBLE
* PPM LOC FAIL IF INSERT NOT POSSIBLE
* (XL,WA,WB,WC) DESTROYED
*
* THE SECOND ALTERNATE EXIT IS TAKEN IF THE INSERT WOULD
* OVERFLOW THE BUFFER, OR IF THE INSERT IS OUT PAST THE
* DEFINED END OF THE BUFFER AS GIVEN.
*
INSBF PRC E,2 ENTRY POINT
MOV WA,INSSA SAVE ENTRY WA
MOV WB,INSSB SAVE ENTRY WB
ADD WB,WA ADD TO GET OFFSET PAST REPLACE PART
MOV WA,INSAB SAVE WA+WB
MOV BCLEN(XR),WC GET CURRENT DEFINED LENGTH
BGT INSSA,WC,INS07 FAIL IF START OFFSET TOO BIG
BGT WA,WC,INS07 FAIL IF FINAL OFFSET TOO BIG
MOV XR,-(XS) SAVE BCBLK PTR
MOV XL,-(XS) STACK STRING POINTER FOR GTSTG
JSR GTSTG CALL TO CONVERT TO STRING
PPM INS06 TAKE STRING CONVERT ERR EXIT
MOV XR,XL SAVE STRING PTR
MOV (XS)+,XR RESTORE BCBLK PTR
MOV XR,INSBC BCBLK PTR - NO DANGER OF GARB COLLN
MOV BCBUF(XR),XR POINT TO BFBLK
MOV XR,INSBB BFBLK PTR - NO DANGER OF GARB COLLN
ADD WC,WA ADD BUFFER LEN TO STRING LEN
SUB INSSB,WA BIAS OUT COMPONENT BEING REPLACED
BGT WA,BFALC(XR),INS07 FAIL IF RESULT EXCEEDS ALLOCATION
MOV INSBC,XR RESTORE BCBLK PTR
MOV WC,WA GET BUFFER LENGTH
SUB INSAB,WA SUBTRACT TO GET SHIFT LENGTH
ADD SCLEN(XL),WC ADD LENGTH OF NEW
SUB INSSB,WC SUBTRACT OLD TO GET TOTAL NEW LEN
MOV BCLEN(XR),WB GET OLD BCLEN
MOV WC,BCLEN(XR) STUFF NEW LENGTH
MOV INSBB,XR POINT TO BFBLK
MOV XL,-(XS) SAVE SCBLK PTR
BZE WA,INS02 SKIP SHIFT IF NOTHING TO DO
BEQ INSSB,SCLEN(XL),INS02 SKIP SHIFT IF LENGTHS MATCH
BLO INSSB,SCLEN(XL),INS01 BRN IF SHIFT IS FOR MORE ROOM
EJC
*
* INSBF (CONTINUED)
*
* WE ARE SHIFTING THE UPPER SEGMENT DOWN TO COMPACT
* THE BUFFER. (THE STRING LENGTH IS SMALLER THAN THE
* SEGMENT BEING REPLACED). REGISTERS ARE SET AS -
*
* (WA) MOVE (SHIFT DOWN) LENGTH
* (WB) OLD BCLEN
* (WC) NEW BCLEN
* (XR) BFBLK PTR
* (XL),(XS) SCBLK PTR
*
MOV INSSA,WB GET OFFSET TO INSERT
ADD SCLEN(XL),WB ADD INSERT LENGTH TO GET DEST OFF
MOV XR,XL MAKE COPY
PLC XL,INSAB PREPARE SOURCE FOR MOVE
PSC XR,WB PREPARE DESTINATION REG FOR MOVE
MVC MOVE EM OUT
BRN INS02 BRANCH TO PAD
*
* WE ARE SHIFTING THE UPPER SEGMENT UP TO EXPAND
* THE BUFFER. (THE STRING LENGTH IS LARGER THAN THE
* SEGMENT BEING REPLACED.)
*
INS01 MOV XR,XL COPY BFBLK PTR
PLC XL,WB SET SOURCE REG FOR MOVE BACKWARDS
PSC XR,WC SET DESTINATION PTR FOR MOVE
MCB MOVE BACKWARDS (POSSIBLE OVERLAP)
*
* MERGE HERE AFTER POSSIBLE MOVE TO ADJUST ZERO FILL AT END
*
INS02 MOV (XS)+,XL RESTORE SCBLK PTR
MOV WC,WA COPY NEW BUFFER END
CTB WA,0 ROUND OUT
BTC WA CONVERT TO CHAR COUNT
SUB WC,WA SUBTRACT TO GET REMAINDER
BZE WA,INS04 NO PAD IF ALREADY EVEN BOUNDARY
MOV INSBB,XR POINT TO BFBLK
PSC XR,WC PREPARE TO PAD
ZER WB CLEAR WB
LCT WA,WA LOAD LOOP COUNT
EJC
*
* INSBF (CONTINUED)
*
* LOOP HERE TO STUFF PAD CHARACTERS
*
INS03 SCH WB,(XR)+ STUFF ZERO PAD
BCT WA,INS03 BRANCH FOR MORE
*
* MERGE HERE WHEN PADDING OK. NOW COPY IN THE INSERT
* STRING TO THE HOLE.
*
INS04 MOV INSBB,XR POINT TO BFBLK
MOV SCLEN(XL),WA GET MOVE LENGTH
BZE WA,INS05 SKIP IF NO CHARS TO INSERT
PLC XL PREPARE TO COPY FROM FIRST CHAR
PSC XR,INSSA PREPARE TO STORE IN HOLE
MVC COPY THE CHARACTERS
*
* SUCCESSFUL RETURN
*
INS05 MOV INSBC,XR RESTORE ENTRY XR
ZER XL CLEAR GARBAGE CHAR POINTER
EXI RETURN TO CALLER
*
* HERE TO TAKE STRING CONVERT ERROR EXIT
*
INS06 ICA XS DISCARD UNWANTED STACK TOP
EXI 1 ALTERNATE EXIT
*
* HERE FOR INVALID OFFSET OR LENGTH
*
INS07 EXI 2 ALTERNATE EXIT
ENP END PROCEDURE INSBF
EJC
.FI
* IOFTG -- GET IOTAG
*
* USED TO FIND THE IOTAG (IF ANY) CORRESPONDING TO THE
* FILETAG ARGUMENT.
*
* -(XS) FILETAG ARGUMENT
* JSR IOFTG CALL TO FIND IOTAG
* PPM LOC ARG IS AN UNSUITABLE FILETAG
* (XS) POPPED
* (XL) PTR TO FILETAG SCBLK
* (XR) PTR TO TRTIO TRACE BLK OR ZERO
* (WA) IOTAG OR ZERO
* (WB) PTR TO FILETAG VRBLK
* (WC) VALUE/0 FOR INTEGER/STRING FILETAG
*
IOFTG PRC N,1 ENTRY POINT
JSR GTSTG GET ARG AS STRING
PPM IOFT4 FAIL
MOV XR,XL COPY STRING PTR
MOV XR,-(XS) STACK STRING
JSR GTSMI TRY CONVERSION TO INTEGER
PPM IOFT5 SKIP IF CANT
PPM IOFT5 SKIP IF CANT
*
* MERGE WITH WC SET UP
*
IOFT1 MOV WC,WB KEEP INTEGER OR ZERO
MOV XL,XR FILETAG STRING TO XR FOR GTNVR CALL
JSR GTNVR FIND VRBLK
PPM IOFT4 SKIP IF NULL STRING
MOV XL,-(XS) KEEP SCBLK PTR
ZER XL IN CASE NO TRTIO BLK FOUND
MOV WB,WC KEEP INTEGER OR ZERO
MOV XR,WB COPY VRBLK PTR FOR RETURN
ZER WA IN CASE NO TRBLK FOUND
*
* LOOP TO FIND FILE ARG1 TRBLK
*
IOFT2 MOV VRVAL(XR),XR GET POSSIBLE TRBLK PTR
BNE (XR),=B$TRT,IOFT3 SKIP IF END OF CHAIN
BNE TRTYP(XR),=TRTIO,IOFT2 LOOP IF NOT FILETAG TRBLK
MOV TRTAG(XR),WA GET IOTAG OR 0
MOV XR,XL TRTIO BLK PTR
*
* RETURN POINT
*
IOFT3 MOV XL,XR TRTIO BLK PTR OR 0
MOV (XS)+,XL RECOVER SCBLK PTR
EXI SUCCESSFUL RETURN
*
* FAIL RETURN
*
IOFT4 EXI 1 FAIL
EJC
*
* NON NUMERIC FILETAG
*
IOFT5 ZER WC NOTE NON NUMERIC
BRN IOFT1 MERGE
ENP END PROCEDURE IOFTG
EJC
*
* IOPUT -- PROCESS INPUT AND OUTPUT ARGUMENTS
*
* IOPUT CHECKS THE ARGUMENTS OF INPUT AND OUTPUT CALLS,
* SETS UP THE REQUIRED ASSOCIATIONS AND CALLS SYSIO TO
* OPEN THE REQUESTED FILES.
*
* -(XS) 1ST ARG (VBL TO BE ASSOCIATED)
* -(XS) 2ND ARG (FILETAG)
* -(XS) 3RD ARG (FILEPROPS)
* (WB) 0 FOR INPUT, 2 FOR OUTPUT ASSOC.
* JSR IOPUT CALL FOR INPUT/OUTPUT ASSOCIATION
* PPM LOC 3RD ARG NOT A STRING
* PPM LOC 2ND ARG NOT A SUITABLE FILETAG
* PPM LOC 1ST ARG NOT A SUITABLE NAME
* PPM LOC FAIL RETURN
* (XS) POPPED
* (XL,XR,WA,WB,WC) DESTROYED
*
EJC
* FIRST ARG NAME
* I I
* +------+
* I I-----+
* +------+ V
* I I +----------------+
* I =B$TRT I
* +----------------+
* I =TRTIN/=TRTOU I
* +----------------+
* I VALUE OR TRCHN +
* +----------------+
* TRTER I I-----+
* +----------------+ V
* TRTRI I 0 I +------+
* +----------------+ I I SVBLK
* I/O TRACE BLOCK +------+
*
* 1. ASSOCIATION TO STANDARD FILES.
*
* FIRST ARG NAME FILETAG VRBLK
* I I I I
* +------+ LK1 +------+ LK2
* I I---+ +---+ I I---+
* +------+ V I V +------+ V
* I I +----------------+ I +----------------+
* I =B$TRT I I I =B$TRT I
* +----------------+ I +----------------+
* I =TRTIN/=TRTOU I I I =TRTIO I
* +----------------+ I +----------------+
* I VALUE OR TRCHN I I I VALUE OR TRCHN I
* +----------------+ I +----------------+
* TRTER I 0 I I I 0 OR IOTAG I TRTAG
* +----------------+ I +----------------+
* TRTRI I I--+ I 0 I TRTRI
* +----------------+ +----------------+
* I/O TRACE BLOCK TRTIO BLOCK
*
* 2. REGULAR CASE.
*
* THE STRUCTURES BUILT FOR I/O ASSOCIATIONS ARE AS SHOWN
* ABOVE. A TRACE BLOCK CHAIN (TRCHN) MAY HOLD ANY OR ALL
* OF THE TYPES, =TRTIN, =TRTOU, =TRTIO, BUT NOT MORE THAN
* ONE BLOCK OF ANY GIVEN TYPE. CASES ARE -
* 1. NO FILETAG OR IOTAG IS USED FOR ASSOCIATING STANDARD
* FILES (SYSRD, SYSPR, TERMINAL). THE I/O TRACE BLOCK
* IS DISTINGUISHED BY A NON-NULL TRTER FIELD POINTING
* TO THE RELEVANT SVBLK (V$INP, V$OUP, V$TER) AND A
* ZERO TRTRI FIELD. FOR TERMINAL, TRBLKS OF BOTH
* INPUT AND OUTPUT TYPE ARE CHAINED FROM THE FIRST ARG
* VIA THE TRCHN FIELD.
* 2. THE I/O TRACE BLOCK FOR THE REGULAR CASE HAS A ZERO
* TRTER FIELD AND A POINTER TO A TRTIO BLOCK IS IN
* THE TRTRI FIELD. THE FILETAG MUST BE A NATURAL
* VARIABLE AND THE TRTIO TRACE BLOCK ATTACHED TO IT
* HOLDS THE IOTAG.
* THE EFFECT OF ENDFILE() IS TO CLEAR IOTAG AND BREAK LK2.
* THE EFFECT OF DETACH() IS TO BREAK LK1.
EJC
IOPUT PRC N,4 ENTRY POINT
MOV WB,IOPWB KEEP ASSOCIATION TYPE FLAG
JSR GTSTG CONVERT THIRD ARG TO STRING
PPM IOP12 FAIL THIRD ARG
BNZ WA,IOP01 SKIP IF NON NULL
ZER XR NOTE NULL ARG
*
* PROCESS SECOND ARG
*
IOP01 MOV XR,R$IOR KEEP FILEPROPS STRING PTR
JSR IOFTG CHECK SECOND ARG
PPM IOP07 FAIL SECOND ARG
MOV XL,R$IOL KEEP SCBLK FOR FILETAG
MOV XR,R$IOT KEEP TRTIO BLK PTR
MOV WA,IOPWA KEEP IOTAG
MOV WB,IOPVR KEEP FILETAG VRBLK PTR
MOV WC,IOPWC KEEP FILETAG VALUE
MOV (XS)+,XR GET FIRST ARG OFF STACK
JSR GTVAR CONVERT TO NAME
PPM IOP13 FAIL FIRST ARG
MOV XL,R$IO1 SAVE FIRST ARG NAME BASE ADRS
MOV WA,IOPNF SAVE FIRST ARG NAME OFFSET
MOV WB,XR FILETAG VRBLK PTR
BNZ VRLEN(XR),IOP02 NOT SPECIAL CASE IF NOT SYS NAME
MOV VRSVP(XR),WC GET SVBLK PTR
MOV =TRTIN,WB IN CASE .INPUT
BEQ WC,=V$INP,IOP06 JUMP IF .INPUT
MOV =TRTOU,WB IN CASE .OUTPUT OR .TERMINAL
BEQ WC,=V$OUP,IOP08 JUMP IF .OUTPUT
BEQ WC,=V$TER,IOP09 JUMP IF .TERMINAL
EJC
*
* NORMAL CASE
*
IOP02 BNZ R$IOT,IOP03 SKIP IF TRTIO BLK EXISTS ALREADY
MOV =TRTIO,WB TRACE BLOCK TYPE WORD
ZER XR ZERO IOTAG WORD
ZER XL ZERO TRTRI FIELD
JSR TRBLD BUILD TRTIO TRBLK
MOV XR,R$IOT SAVE TRTIO BLK PTR
MOV IOPVR,XL GET FILETAG VRBLK
MOV *VRVAL,WA OFFSET TO VALUE FIELD
JSR TRCHN PLACE IN TRBLK CHAIN FOR FILETAG
PPM UNUSED RETURN
*
* MERGE TO BUILD TRBLK FOR FIRST ARG
*
IOP03 MOV =TRTIN,WB IN CASE INPUT
BZE IOPWB,IOP04 SKIP IF SO
MOV =TRTOU,WB IN CASE OUTPUT
*
* BUILD TRACE BLOCK
*
IOP04 ICV IOPWB NOTE NOT STANDARD I/O FILE
MOV R$IOT,XL TRTIO BLK PTR TO TRTRI FIELD
ZER XR ZERO TRTER FIELD
JSR TRBLD BUILD I/O TRACE BLOCK
MOV R$IO1,XL ASSOCIATED VBL NAME BASE
MOV IOPNF,WA NAME OFFSET
JSR TRCHN UPDATE TRACE CHAIN FOR FIRST ARG
PPM UNUSED RETURN
*
* PREPARE FOR AND MAKE SYSIO CALL
*
IOP05 MOV R$IOL,XL FILETAG SCBLK PTR
MOV R$IOR,XR FILEPROPS SCBLK PTR
MOV IOPWA,WA IOTAG OR ZERO
MOV IOPWB,WB ASSOCIATION TYPE NUMBER
MOV IOPWC,WC POSSIBLE FILETAG VALUE
JSR SYSIO CALL SYSTEM ROUTINE TO OPEN FILE
PPM IOP14 FAIL RETURN
PPM EROSI ERROR RETURN
MOV R$IOT,XL TRTIO POINTER
BZE XL,IOP11 DONE IF ZERO
MOV WA,TRTAG(XL) STORE RETURNED IOTAG
BRN IOP11 SUCCEED
EJC
*
* SPECIAL CASE OF .INPUT
*
IOP06 BZE IOPWB,IOP09 FAIL OUTPUT(.X,.INPUT)
*
* BAD FILETAG
*
IOP07 EXI 2 ERRONEOUS SECOND ARG
*
* SPECIAL CASE OF .OUTPUT
*
IOP08 BZE IOPWB,IOP07 FAIL INPUT(.X,.OUTPUT)
*
* SPECIAL CASE OF .TERMINAL AND MERGE FOR OTHERS
*
IOP09 ZER R$IOT NOTE NO TRTIO BLOCK
MOV WC,XR SVBLK PTR FOR TRTER FIELD
ZER XL ZERO TRTRI FIELD
JSR TRBLD BUILD TRBLK
MOV R$IO1,XL ASSOCIATED VBL NAME BASE
MOV IOPNF,WA NAME OFFSET
JSR TRCHN UPDATE TRACE CHAIN FOR ARG 1
PPM UNUSED RETURN
BNE TRTER(XR),=V$TER,IOP10 DONE UNLESS TERMINAL
BNE TRTYP(XR),=TRTOU,IOP10 DONE IF TERM. 2ND TIME ROUND
MOV =V$TER,WC TRTER FIELD
MOV =TRTIN,WB TRTYP FIELD
BRN IOP09 REPEAT LOOP FOR TERMINAL
*
* CHECK SPECIAL CASES FOR NON-NULL THIRD ARGS
*
IOP10 ZER IOPWA NO IOTAG
BNZ R$IOR,IOP05 MERGE ONLY IF FILEPROPS NON-NULL
*
* SUCCESS RETURN
*
IOP11 ZER R$IO1 CLEAR GARBAGE
ZER R$IOL
ZER R$IOR
ZER R$IOT
EXI RETURN TO CALLER
*
* ERROR RETURNS
*
IOP12 EXI 1 ERRONEOUS THIRD ARG
*
IOP13 EXI 3 ERRONEOUS FIRST ARG
*
IOP14 EXI 4 FAIL RETURN FROM SYSIO
ENP END PROCEDURE IOPUT
EJC
*
* KTREX -- EXECUTE KEYWORD TRACE
*
* KTREX IS USED TO EXECUTE A POSSIBLE KEYWORD TRACE. IT
* INCLUDES THE TEST ON TRACE AND TESTS FOR TRACE ACTIVE.
*
* (XL) PTR TO TRBLK (OR 0 IF UNTRACED)
* JSR KTREX CALL TO EXECUTE KEYWORD TRACE
* (XL,WA,WB,WC) DESTROYED
* (RA) DESTROYED
*
KTREX PRC R,0 ENTRY POINT (RECURSIVE)
BZE XL,KTRX3 IMMEDIATE EXIT IF KEYWORD UNTRACED
BZE KVTRA,KTRX3 IMMEDIATE EXIT IF TRACE = 0
DCV KVTRA ELSE DECREMENT TRACE
MOV XR,-(XS) SAVE XR
MOV XL,XR COPY TRBLK POINTER
MOV TRKVR(XR),XL LOAD VRBLK POINTER (NMBAS)
MOV *VRVAL,WA SET NAME OFFSET
BZE TRFNC(XR),KTRX1 JUMP IF PRINT TRACE
JSR TRXEQ ELSE EXECUTE FULL TRACE
BRN KTRX2 AND JUMP TO EXIT
*
* HERE FOR PRINT TRACE
*
KTRX1 MOV XL,-(XS) STACK VRBLK PTR FOR KWNAM
MOV WA,-(XS) STACK OFFSET FOR KWNAM
JSR PRTSN PRINT STATEMENT NUMBER
MOV =CH$AM,WA LOAD AMPERSAND
JSR PRTCH PRINT AMPERSAND
JSR PRTNM PRINT KEYWORD NAME
MOV =TMBEB,XR POINT TO BLANK-EQUAL-BLANK
JSR PRTST PRINT BLANK-EQUAL-BLANK
JSR KWNAM GET KEYWORD PSEUDO-VARIABLE NAME
MOV XR,DNAMP RESET PTR TO DELETE KVBLK
JSR ACESS GET KEYWORD VALUE
PPM FAILURE IS IMPOSSIBLE
JSR PRTVF PRINT KEYWORD VALUE
*
* HERE TO EXIT AFTER COMPLETING TRACE
*
KTRX2 MOV (XS)+,XR RESTORE ENTRY XR
*
* MERGE HERE TO EXIT IF NO TRACE REQUIRED
*
KTRX3 EXI RETURN TO KTREX CALLER
ENP END PROCEDURE KTREX
EJC
*
* KWNAM -- GET PSEUDO-VARIABLE NAME FOR KEYWORD
*
* 1(XS) NAME BASE FOR VRBLK
* 0(XS) OFFSET (SHOULD BE *VRVAL)
* JSR KWNAM CALL TO GET PSEUDO-VARIABLE NAME
* (XS) POPPED TWICE
* (XL,WA) RESULTING PSEUDO-VARIABLE NAME
* (XR,WA,WB) DESTROYED
*
KWNAM PRC N,0 ENTRY POINT
ICA XS IGNORE NAME OFFSET
MOV (XS)+,XR LOAD NAME BASE
BGE XR,STATE,KWNM1 JUMP IF NOT NATURAL VARIABLE NAME
BNZ VRLEN(XR),KWNM1 ERROR IF NOT SYSTEM VARIABLE
MOV VRSVP(XR),XR ELSE POINT TO SVBLK
MOV SVBIT(XR),WA LOAD BIT MASK
ANB BTKNM,WA AND WITH KEYWORD BIT
ZRB WA,KWNM1 ERROR IF NO KEYWORD ASSOCIATION
MOV SVLEN(XR),WA ELSE LOAD NAME LENGTH IN CHARACTERS
CTB WA,SVCHS COMPUTE OFFSET TO FIELD WE WANT
ADD WA,XR POINT TO SVKNM FIELD
MOV (XR),WB LOAD SVKNM VALUE
MOV *KVSI$,WA SET SIZE OF KVBLK
JSR ALLOC ALLOCATE KVBLK
MOV =B$KVT,(XR) STORE TYPE WORD
MOV WB,KVNUM(XR) STORE KEYWORD NUMBER
MOV =TRBKV,KVVAR(XR) SET DUMMY TRBLK POINTER
MOV XR,XL COPY KVBLK POINTER
MOV *KVVAR,WA SET PROPER OFFSET
EXI RETURN TO KVNAM CALLER
*
* HERE IF NOT KEYWORD NAME
*
KWNM1 ERB 230,KEYWORD OPERAND IS NOT NAME OF DEFINED KEYWORD
ENP END PROCEDURE KWNAM
EJC
*
* LCOMP-- COMPARE TWO STRINGS LEXICALLY
*
* 1(XS) FIRST ARGUMENT
* 0(XS) SECOND ARGUMENT
* JSR LCOMP CALL TO COMPARE ARUMENTS
* PPM LOC TRANSFER LOC FOR ARG1 NOT STRING
* PPM LOC TRANSFER LOC FOR ARG2 NOT STRING
* PPM LOC TRANSFER LOC IF ARG1 LLT ARG2
* PPM LOC TRANSFER LOC IF ARG1 LEQ ARG2
* PPM LOC TRANSFER LOC IF ARG1 LGT ARG2
* (THE NORMAL RETURN IS NEVER TAKEN)
* (XS) POPPED TWICE
* (XR,XL) DESTROYED
* (WA,WB,WC,RA) DESTROYED
*
LCOMP PRC N,5 ENTRY POINT
JSR GTSTG CONVERT SECOND ARG TO STRING
PPM LCMP6 JUMP IF SECOND ARG NOT STRING
MOV XR,XL ELSE SAVE POINTER
MOV WA,WB AND LENGTH
JSR GTSTG CONVERT FIRST ARGUMENT TO STRING
PPM LCMP5 JUMP IF NOT STRING
MOV WA,WC SAVE ARG 1 LENGTH
PLC XR POINT TO CHARS OF ARG 1
PLC XL POINT TO CHARS OF ARG 2
BLO WA,WB,LCMP0 JUMP IF ARG 1 LENGTH IS SMALLER
MOV WB,WA ELSE SET ARG 2 LENGTH AS SMALLER
*
* HERE WITH SMALLER LENGTH IN (WA)
*
LCMP0 BZE WA,LCMP1 SKIP IF A NULL ARG
CMC LCMP4,LCMP3 COMPARE STRINGS, JUMP IF UNEQUAL
*
* EQUAL STRINGS OR AT LEAST ONE NULL ARG
*
LCMP1 BNE WB,WC,LCMP2 IF EQUAL, JUMP IF LENGTHS UNEQUAL
EXI 4 ELSE IDENTICAL STRINGS, LEQ EXIT
EJC
*
* LCOMP (CONTINUED)
*
* HERE IF INITIAL STRINGS IDENTICAL, BUT LENGTHS UNEQUAL
*
LCMP2 BHI WC,WB,LCMP4 JUMP IF ARG 1 LENGTH GT ARG 2 LENG
*
* HERE IF FIRST ARG LLT SECOND ARG
*
LCMP3 EXI 3 TAKE LLT EXIT
*
* HERE IF FIRST ARG LGT SECOND ARG
*
LCMP4 EXI 5 TAKE LGT EXIT
*
* HERE IF FIRST ARG IS NOT A STRING
*
LCMP5 EXI 1 TAKE BAD FIRST ARG EXIT
*
* HERE FOR SECOND ARG NOT A STRING
*
LCMP6 EXI 2 TAKE BAD SECOND ARG ERROR EXIT
ENP END PROCEDURE LCOMP
EJC
*
* LISTR -- LIST SOURCE LINE
*
* LISTR IS USED TO LIST A SOURCE LINE DURING THE INITIAL
* COMPILATION. IT IS CALLED FROM SCANE AND SCANL.
*
* JSR LISTR CALL TO LIST LINE
* (XR,XL,WA,WB,WC) DESTROYED
*
* GLOBAL LOCATIONS USED BY LISTR
*
* ERLST IF LISTING ON ACCOUNT OF AN ERROR
*
* LSTLC COUNT LINES ON CURRENT PAGE
*
* LSTNP MAX NUMBER OF LINES/PAGE
*
* LSTPF SET NON-ZERO IF THE CURRENT SOURCE
* LINE HAS BEEN LISTED, ELSE ZERO.
*
* LSTPG COMPILER LISTING PAGE NUMBER
*
* LSTSN SET IF STMNT NUM TO BE LISTED
*
* R$CIM POINTER TO CURRENT INPUT LINE.
*
* R$TTL TITLE FOR SOURCE LISTING
*
* R$STL PTR TO SUB-TITLE STRING
*
* ENTRY POINT
*
LISTR PRC E,0 ENTRY POINT
MOV STAGE,WA GET COMPILER STAGE
BEQ WA,=STGIC,LIST0 LIST OK IF INITIAL COMPILE
BEQ WA,=STGCE,LIST0 LIST OK IF END LINE
BRN LIST4 ELSE NO LISTING OF SOURCE
*
* HERE WHEN STAGE IS OK TO LIST
*
LIST0 BNZ CNTTL,LIST5 JUMP IF -TITLE OR -STITL
BNZ LSTPF,LIST4 IMMEDIATE EXIT IF ALREADY LISTED
BGE LSTLC,LSTNP,LIST6 JUMP IF NO ROOM
*
* HERE AFTER PRINTING TITLE (IF NEEDED)
*
LIST1 MOV R$CIM,XR LOAD POINTER TO CURRENT IMAGE
PLC XR POINT TO CHARACTERS
LCH WA,(XR) LOAD FIRST CHARACTER
MOV LSTSN,XR LOAD STATEMENT NUMBER
BZE XR,LIST2 JUMP IF NO STATEMENT NUMBER
MTI XR ELSE GET STMNT NUMBER AS INTEGER
BEQ WA,=CH$AS,LIST2 NO STMNT NUMBER LIST IF COMMENT
BEQ WA,=CH$MN,LIST2 NO STMNT NO. IF CONTROL CARD
JSR PRTIN ELSE PRINT STATEMENT NUMBER
ZER LSTSN AND CLEAR FOR NEXT TIME IN
EJC
*
* LISTR (CONTINUED)
*
* MERGE HERE AFTER PRINTING STATEMENT NUMBER (IF REQUIRED)
*
LIST2 MOV =STNPD,PROFS POINT PAST STATEMENT NUMBER
MOV R$CIM,XR LOAD POINTER TO CURRENT IMAGE
JSR PRTSF PRINT IT
ICV LSTLC BUMP LINE COUNTER
MNZ LSTPF SET FLAG FOR LINE PRINTED
*
* MERGE HERE TO EXIT
*
LIST4 EXI RETURN TO LISTR CALLER
*
* PRINT TITLE AFTER -TITLE OR -STITL CARD
*
LIST5 ZER CNTTL CLEAR FLAG
*
* EJECT TO NEW PAGE AND LIST TITLE
*
LIST6 JSR PRTPS EJECT
BNZ PRLEN,LIST7 SKIP IF LISTING TO REGULAR PRINTER
BEQ R$TTL,=NULLS,LIST1 TERMINAL LISTING OMITS NULL TITLE
*
* LIST TITLE
*
LIST7 JSR LISTT LIST TITLE
BRN LIST1 MERGE
ENP END PROCEDURE LISTR
EJC
*
* LISTT -- LIST TITLE AND SUBTITLE
*
* USED DURING COMPILATION TO PRINT PAGE HEADING
*
* JSR LISTT CALL TO LIST TITLE
* (XR,WA) DESTROYED
*
LISTT PRC E,0 ENTRY POINT
MOV R$TTL,XR POINT TO SOURCE LISTING TITLE
JSR PRTST PRINT TITLE
MOV LSTPO,PROFS SET OFFSET
MOV =LSTMS,XR SET PAGE MESSAGE
JSR PRTST PRINT PAGE MESSAGE
ICV LSTPG BUMP PAGE NUMBER
MTI LSTPG LOAD PAGE NUMBER AS INTEGER
JSR PRTIN PRINT PAGE NUMBER
JSR PRTFH TERMINATE TITLE LINE
ADD =NUM02,LSTLC COUNT TITLE LINE AND BLANK LINE
*
* PRINT SUB-TITLE (IF ANY)
*
MOV R$STL,XR LOAD POINTER TO SUB-TITLE
BZE XR,LSTT1 JUMP IF NO SUB-TITLE
JSR PRTSF ELSE PRINT SUB-TITLE
ICV LSTLC BUMP LINE COUNT
*
* RETURN POINT
*
LSTT1 JSR PRTFH PRINT A BLANK LINE
EXI RETURN TO CALLER
ENP END PROCEDURE LISTT
EJC
*
* NEXTS -- ACQUIRE NEXT SOURCE IMAGE
*
* NEXTS IS USED TO ACQUIRE THE NEXT SOURCE IMAGE AT COMPILE
* TIME. IT ASSUMES THAT A PRIOR CALL TO READR HAS INPUT
* A LINE IMAGE (SEE PROCEDURE READR). BEFORE THE CURRENT
* IMAGE IS FINALLY LOST IT MAY BE LISTED HERE.
*
* JSR NEXTS CALL TO ACQUIRE NEXT INPUT LINE
* (XR,XL,WA,WB,WC) DESTROYED
*
* GLOBAL VALUES AFFECTED
*
* R$CNI ON INPUT, NEXT IMAGE. ON
* EXIT RESET TO ZERO
*
* R$CIM ON EXIT, SET TO POINT TO IMAGE
*
* SCNIL INPUT IMAGE LENGTH ON EXIT
*
* SCNSE RESET TO ZERO ON EXIT
*
* LSTPF SET ON EXIT IF LINE IS LISTED
*
NEXTS PRC E,0 ENTRY POINT
BZE CSWLS,NXTS1 JUMP IF -NOLIST
MOV R$CIM,XR POINT TO IMAGE
BZE XR,NXTS1 JUMP IF NO IMAGE
PLC XR GET CHAR PTR
LCH WA,(XR) GET FIRST CHAR
BEQ WA,=CH$MN,NXTS1 SKIP LISTING IF CONTROL CARD
JSR LISTR LIST LINE
*
* HERE AFTER POSSIBLE LISTING
*
NXTS1 MOV R$CNI,XR POINT TO NEXT IMAGE
MOV XR,R$CIM SET AS NEXT IMAGE
ZER R$CNI CLEAR NEXT IMAGE POINTER
MOV SCLEN(XR),WA GET INPUT IMAGE LENGTH
MOV CSWIN,WB GET MAX ALLOWABLE LENGTH
BLO WA,WB,NXTS2 SKIP IF NOT TOO LONG
MOV WB,WA ELSE TRUNCATE
*
* HERE WITH LENGTH IN (WA)
*
NXTS2 MOV WA,SCNIL USE AS RECORD LENGTH
ZER SCNSE RESET SCNSE
ZER LSTPF SET LINE NOT LISTED YET
EXI RETURN TO NEXTS CALLER
ENP END PROCEDURE NEXTS
EJC
*
* PATIN -- PATTERN CONSTRUCTION FOR LEN,POS,RPOS,TAB,RTAB
*
* THESE PATTERN TYPES ALL GENERATE A SIMILAR NODE TYPE. SO
* THE CONSTRUCTION CODE IS SHARED. SEE FUNCTIONS SECTION
* FOR ACTUAL ENTRY POINTS FOR THESE FIVE FUNCTIONS.
*
* (WA) PCODE FOR EXPRESSION ARG CASE
* (WB) PCODE FOR INTEGER ARG CASE
* JSR PATIN CALL TO BUILD PATTERN NODE
* PPM LOC TRANSFER LOC FOR NOT INTEGER OR EXP
* PPM LOC TRANSFER LOC FOR INT OUT OF RANGE
* (XR) POINTER TO CONSTRUCTED NODE
* (XL,WA,WB,WC,IA) DESTROYED
*
PATIN PRC N,2 ENTRY POINT
MOV WA,XL PRESERVE EXPRESSION ARG PCODE
JSR GTSMI TRY TO CONVERT ARG AS SMALL INTEGER
PPM PTIN2 JUMP IF NOT INTEGER
PPM PTIN3 JUMP IF OUT OF RANGE
*
* COMMON SUCCESSFUL EXIT POINT
*
PTIN1 JSR PBILD BUILD PATTERN NODE
EXI RETURN TO CALLER
*
* HERE IF ARGUMENT IS NOT AN INTEGER
*
PTIN2 MOV XL,WB COPY EXPR ARG CASE PCODE
BLO (XR),=B$E$$,PTIN1 ALL OK IF EXPRESSION ARG
EXI 1 ELSE TAKE ERROR EXIT FOR WRONG TYPE
*
* HERE FOR ERROR OF OUT OF RANGE INTEGER ARGUMENT
*
PTIN3 EXI 2 TAKE OUT-OF-RANGE ERROR EXIT
ENP END PROCEDURE PATIN
EJC
*
* PATST -- PATTERN CONSTRUCTION FOR ANY,NOTANY,
* BREAK,SPAN AND BREAKX PATTERN FUNCTIONS.
*
* THESE PATTERN FUNCTIONS BUILD SIMILAR TYPES OF NODES AND
* THE CONSTRUCTION CODE IS SHARED. SEE FUNCTIONS SECTION
* FOR ACTUAL ENTRY POINTS FOR THESE FIVE PATTERN FUNCTIONS.
*
* 0(XS) STRING ARGUMENT
* (WB) PCODE FOR ONE CHAR ARGUMENT
* (XL) PCODE FOR MULTI-CHAR ARGUMENT
* (WC) PCODE FOR EXPRESSION ARGUMENT
* JSR PATST CALL TO BUILD NODE
* PPM LOC TRANSFER LOC IF NOT STRING OR EXPR
* (XS) POPPED PAST STRING ARGUMENT
* (XR) POINTER TO CONSTRUCTED NODE
* (XL) DESTROYED
* (WA,WB,WC,RA) DESTROYED
*
* NOTE THAT THERE IS A SPECIAL CALL TO PATST IN THE EVALS
* PROCEDURE WITH A SLIGHTLY DIFFERENT FORM. SEE EVALS
* FOR DETAILS OF THE FORM OF THIS CALL.
*
PATST PRC N,1 ENTRY POINT
JSR GTSTG CONVERT ARGUMENT AS STRING
PPM PATS7 JUMP IF NOT STRING
BNE WA,=NUM01,PATS2 JUMP IF NOT ONE CHAR STRING
*
* HERE FOR ONE CHAR STRING CASE
*
BZE WB,PATS2 TREAT AS MULTI-CHAR IF EVALS CALL
PLC XR POINT TO CHARACTER
LCH XR,(XR) LOAD CHARACTER
*
* COMMON EXIT POINT AFTER SUCCESSFUL CONSTRUCTION
*
PATS1 JSR PBILD CALL ROUTINE TO BUILD NODE
EXI RETURN TO PATST CALLER
EJC
*
* PATST (CONTINUED)
*
* HERE FOR MULTI-CHARACTER STRING CASE
*
PATS2 MOV XL,-(XS) SAVE MULTI-CHAR PCODE
MOV XR,-(XS) SAVE STRING POINTER
MOV CTMSK,WC LOAD CURRENT MASK BIT
LSH WC,1 SHIFT TO NEXT POSITION
NZB WC,PATS4 SKIP IF POSITION LEFT IN THIS TBL
*
* HERE WE MUST ALLOCATE A NEW CHARACTER TABLE
*
MOV *CTSI$,WA SET SIZE OF CTBLK
JSR ALLOC ALLOCATE CTBLK
MOV XR,R$CTP STORE PTR TO NEW CTBLK
MOV =B$CTT,(XR)+ STORE TYPE CODE, BUMP PTR
LCT WB,=CFP$A SET NUMBER OF WORDS TO CLEAR
MOV BITS0,WC LOAD ALL ZERO BITS
*
* LOOP TO CLEAR ALL BITS IN TABLE TO ZEROS
*
PATS3 MOV WC,(XR)+ MOVE WORD OF ZERO BITS
BCT WB,PATS3 LOOP TILL ALL CLEARED
MOV BITS1,WC SET INITIAL BIT POSITION
*
* MERGE HERE WITH BIT POSITION AVAILABLE
*
PATS4 MOV WC,CTMSK SAVE PARM2 (NEW BIT POSITION)
MOV (XS)+,XL RESTORE POINTER TO ARGUMENT STRING
MOV SCLEN(XL),WB LOAD STRING LENGTH
BZE WB,PATS6 JUMP IF NULL STRING CASE
LCT WB,WB ELSE SET LOOP COUNTER
PLC XL POINT TO CHARACTERS IN ARGUMENT
EJC
*
* PATST (CONTINUED)
*
* LOOP TO SET BITS IN COLUMN OF TABLE
*
PATS5 LCH WA,(XL)+ LOAD NEXT CHARACTER
WTB WA CONVERT TO BAU OFFSET
MOV R$CTP,XR POINT TO CTBLK
ADD WA,XR POINT TO CTBLK ENTRY
MOV WC,WA COPY BIT MASK
ORB CTCHS(XR),WA OR IN BITS ALREADY SET
MOV WA,CTCHS(XR) STORE RESULTING BIT STRING
BCT WB,PATS5 LOOP TILL ALL BITS SET
*
* COMPLETE PROCESSING FOR MUTI-CHAR STRING CASE
*
PATS6 MOV R$CTP,XR LOAD CTBLK PTR AS PARM1 FOR PBILD
ZER XL CLEAR GARBAGE PTR IN XL
MOV (XS)+,WB LOAD PCODE FOR MULTI-CHAR STR CASE
BRN PATS1 BACK TO EXIT (WC=BITSTRING=PARM2)
*
* HERE IF ARGUMENT IS NOT A STRING
*
* NOTE THAT THE CALL FROM EVALS CANNOT PASS AN EXPRESSION
* SINCE EVALP ALWAYS REEVALUATES EXPRESSIONS.
*
PATS7 MOV WC,WB SET PCODE FOR EXPRESSION ARGUMENT
BLO (XR),=B$E$$,PATS1 JUMP TO EXIT IF EXPRESSION ARG
EXI 1 ELSE TAKE WRONG TYPE ERROR EXIT
ENP END PROCEDURE PATST
EJC
*
* PBILD -- BUILD PATTERN NODE
*
* (XR) PARM1 (ONLY IF REQUIRED)
* (WB) PCODE FOR NODE
* (WC) PARM2 (ONLY IF REQUIRED)
* JSR PBILD CALL TO BUILD NODE
* (XR) POINTER TO CONSTRUCTED NODE
* (WA) DESTROYED
*
PBILD PRC E,0 ENTRY POINT
MOV XR,-(XS) STACK POSSIBLE PARM1
MOV WB,XR COPY PCODE
LEI XR LOAD ENTRY POINT ID (BL$PX)
BEQ XR,=BL$P1,PBLD1 JUMP IF ONE PARAMETER
BEQ XR,=BL$P0,PBLD3 JUMP IF NO PARAMETERS
*
* HERE FOR TWO PARAMETER CASE
*
MOV *PCSI$,WA SET SIZE OF P2BLK
JSR ALLOC ALLOCATE BLOCK
MOV WC,PARM2(XR) STORE SECOND PARAMETER
BRN PBLD2 MERGE WITH ONE PARM CASE
*
* HERE FOR ONE PARAMETER CASE
*
PBLD1 MOV *PBSI$,WA SET SIZE OF P1BLK
JSR ALLOC ALLOCATE NODE
*
* MERGE HERE FROM TWO PARM CASE
*
PBLD2 MOV (XS),PARM1(XR) STORE FIRST PARAMETER
BRN PBLD4 MERGE WITH NO PARAMETER CASE
*
* HERE FOR CASE OF NO PARAMETERS
*
PBLD3 MOV *PASI$,WA SET SIZE OF P0BLK
JSR ALLOC ALLOCATE NODE
*
* MERGE HERE FROM OTHER CASES
*
PBLD4 MOV WB,(XR) STORE PCODE
ICA XS POP FIRST PARAMETER
MOV =NDNTH,PTHEN(XR) SET NOTHEN SUCCESSOR POINTER
EXI RETURN TO PBILD CALLER
ENP END PROCEDURE PBILD
EJC
*
* PCONC -- CONCATENATE TWO PATTERNS
*
* (XL) PTR TO RIGHT PATTERN
* (XR) PTR TO LEFT PATTERN
* JSR PCONC CALL TO CONCATENATE PATTERNS
* (XR) PTR TO CONCATENATED PATTERN
* (XL,WA,WB,WC) DESTROYED
*
*
* TO CONCATENATE TWO PATTERNS, ALL SUCCESSORS IN THE LEFT
* PATTERN WHICH POINT TO THE NOTHEN NODE MUST BE CHANGED TO
* POINT TO THE RIGHT PATTERN. HOWEVER, THIS MODIFICATION
* MUST BE PERFORMED ON A COPY OF THE LEFT ARGUMENT RATHER
* THAN THE LEFT ARGUMENT ITSELF, SINCE THE LEFT ARGUMENT
* MAY BE POINTED TO BY SOME OTHER VARIABLE VALUE.
*
* ACCORDINGLY, IT IS NECESSARY TO COPY THE LEFT ARGUMENT.
* THIS IS NOT A TRIVIAL PROCESS SINCE WE MUST AVOID COPYING
* NODES MORE THAN ONCE AND THE PATTERN IS A GRAPH STRUCTURE
* THE FOLLOWING ALGORITHM IS EMPLOYED.
*
* THE STACK IS USED TO STORE A LIST OF NODES WHICH
* HAVE ALREADY BEEN COPIED. THE FORMAT OF THE ENTRIES ON
* THIS LIST CONSISTS OF A TWO WORD BLOCK. THE FIRST WORD
* IS THE OLD ADDRESS AND THE SECOND WORD IS THE ADDRESS
* OF THE COPY. THIS LIST IS SEARCHED BY THE PCOPY
* ROUTINE TO AVOID MAKING DUPLICATE COPIES. A TRICK IS
* USED TO ACCOMPLISH THE CONCATENATION AT THE SAME TIME.
* A SPECIAL ENTRY IS MADE TO START WITH ON THE STACK. THIS
* ENTRY RECORDS THAT THE NOTHEN NODE HAS BEEN COPIED
* ALREADY AND THE ADDRESS OF ITS COPY IS THE RIGHT PATTERN.
* THIS AUTOMATICALLY PERFORMS THE CORRECT REPLACEMENTS.
*
PCONC PRC E,0 ENTRY POINT
ZER -(XS) MAKE ROOM FOR ONE ENTRY AT BOTTOM
MOV XS,WC STORE POINTER TO START OF LIST
MOV =NDNTH,-(XS) STACK NOTHEN NODE AS OLD NODE
MOV XL,-(XS) STORE RIGHT ARG AS COPY OF NOTHEN
MOV XS,XT INITIALIZE POINTER TO STACK ENTRIES
JSR PCOPY COPY FIRST NODE OF LEFT ARG
MOV WA,2(XT) STORE AS RESULT UNDER LIST
EJC
*
* PCONC (CONTINUED)
*
* THE FOLLOWING LOOP SCANS ENTRIES IN THE LIST AND MAKES
* SURE THAT THEIR SUCCESSORS HAVE BEEN COPIED.
*
PCNC1 BEQ XT,XS,PCNC2 JUMP IF ALL ENTRIES PROCESSED
MOV -(XT),XR ELSE LOAD NEXT OLD ADDRESS
MOV PTHEN(XR),XR LOAD POINTER TO SUCCESSOR
JSR PCOPY COPY SUCCESSOR NODE
MOV -(XT),XR LOAD POINTER TO NEW NODE (COPY)
MOV WA,PTHEN(XR) STORE PTR TO NEW SUCCESSOR
*
* NOW CHECK FOR SPECIAL CASE OF ALTERNATION NODE WHERE
* PARM1 POINTS TO A NODE AND MUST BE COPIED LIKE PTHEN.
*
BNE (XR),=P$ALT,PCNC1 LOOP BACK IF NOT
MOV PARM1(XR),XR ELSE LOAD POINTER TO ALTERNATIVE
JSR PCOPY COPY IT
MOV (XT),XR RESTORE PTR TO NEW NODE
MOV WA,PARM1(XR) STORE PTR TO COPIED ALTERNATIVE
BRN PCNC1 LOOP BACK FOR NEXT ENTRY
*
* HERE AT END OF COPY PROCESS
*
PCNC2 MOV WC,XS RESTORE STACK POINTER
MOV (XS)+,XR LOAD POINTER TO COPY
EXI RETURN TO PCONC CALLER
ENP END PROCEDURE PCONC
EJC
*
* PCOPY -- COPY A PATTERN NODE
*
* PCOPY IS CALLED FROM THE PCONC PROCEDURE TO COPY A SINGLE
* PATTERN NODE. THE COPY IS ONLY CARRIED OUT IF THE NODE
* HAS NOT BEEN COPIED ALREADY.
*
* (XR) POINTER TO NODE TO BE COPIED
* (XT) PTR TO CURRENT LOC IN COPY LIST
* (WC) POINTER TO LIST OF COPIED NODES
* JSR PCOPY CALL TO COPY A NODE
* (WA) POINTER TO COPY
* (WB,XR) DESTROYED
*
PCOPY PRC N,0 ENTRY POINT
MOV XT,WB SAVE XT
MOV WC,XT POINT TO START OF LIST
*
* LOOP TO SEARCH LIST OF NODES COPIED ALREADY
*
PCOP1 DCA XT POINT TO NEXT ENTRY ON LIST
BEQ XR,(XT),PCOP2 JUMP IF MATCH
DCA XT ELSE SKIP OVER COPIED ADDRESS
BNE XT,XS,PCOP1 LOOP BACK IF MORE TO TEST
*
* HERE IF NOT IN LIST, PERFORM COPY
*
MOV (XR),WA LOAD FIRST WORD OF BLOCK
JSR BLKLN GET LENGTH OF BLOCK
MOV XR,XL SAVE POINTER TO OLD NODE
JSR ALLOC ALLOCATE SPACE FOR COPY
MOV XL,-(XS) STORE OLD ADDRESS ON LIST
MOV XR,-(XS) STORE NEW ADDRESS ON LIST
CHK CHECK FOR STACK OVERFLOW
MVW MOVE WORDS FROM OLD BLOCK TO COPY
MOV (XS),WA LOAD POINTER TO COPY
BRN PCOP3 JUMP TO EXIT
*
* HERE IF WE FIND ENTRY IN LIST
*
PCOP2 MOV -(XT),WA LOAD ADDRESS OF COPY FROM LIST
*
* COMMON EXIT POINT
*
PCOP3 MOV WB,XT RESTORE XT
EXI RETURN TO PCOPY CALLER
ENP END PROCEDURE PCOPY
.IF .CNPF
.ELSE
EJC
*
* PRFLR -- PRINT PROFILE
* PRFLR IS CALLED TO PRINT THE CONTENTS OF THE PROFILE
* TABLE IN A FAIRLY READABLE TABULAR FORMAT.
*
* JSR PRFLR CALL TO PRINT PROFILE
* (WA,IA) DESTROYED
*
PRFLR PRC E,0
BZE PFDMP,PRFL4 NO PRINTING IF NO PROFILING DONE
MOV XR,-(XS) PRESERVE ENTRY XR
MOV WB,PFSVW AND ALSO WB
JSR PRTPG EJECT
MOV =PFMS1,XR LOAD MSG /PROGRAM PROFILE/
JSR PRTFB AND PRINT IT
MOV =PFMS2,XR POINT TO FIRST HDR
JSR PRTSF PRINT IT
MOV =PFMS3,XR SECOND HDR
JSR PRTFB
ZER WB INITIAL STMT COUNT
MOV PFTBL,XR POINT TO TABLE ORIGIN
ADD *NUM02,XR BIASS PAST XNBLK HEADER
EJC
*
* PRFLR (CONTINUED)
*
* LOOP FOR PRINTING TABLE ENTRIES
*
PRFL1 ICV WB BUMP STMT NR
LDI (XR) LOAD NR OF EXECUTIONS
IEQ PRFL3 NO PRINTING IF ZERO
MOV =PFPD1,PROFS POINT WHERE TO PRINT
JSR PRTIN AND PRINT IT
ZER PROFS BACK TO START OF LINE
MTI WB LOAD STMT NR
JSR PRTIN PRINT IT THERE
MOV =PFPD2,PROFS AND PAD PAST COUNT
LDI CFP$I(XR) LOAD TOTAL EXEC TIME
JSR PRTIN PRINT THAT TOO
LDI CFP$I(XR) RELOAD TIME
MLI INTTH CONVERT TO MICROSEC
IOV PRFL2 OMIT NEXT BIT IF OVERFLOW
DVI (XR) DIVIDE BY EXECUTIONS
MOV =PFPD3,PROFS PAD LAST PRINT
JSR PRTIN AND PRINT MCSEC/EXECN
*
* PRINT A BLANK
*
PRFL2 JSR PRTFH THATS ANOTHER LINE
*
* TEST TO SEE IF LOOP FINISHED
*
PRFL3 ADD *PF$I2,XR BUMP INDEX POINTER
BLT WB,PFNTE,PRFL1 LOOP IF MORE STMTS
MOV (XS)+,XR RESTORE CALLERS XR
MOV PFSVW,WB AND WB TOO
*
* RETURN POINT
*
PRFL4 EXI RETURN
ENP END OF PRFLR
EJC
*
* PRFLU -- UPDATE AN ENTRY IN THE PROFILE TABLE
*
* ON ENTRY, KVSTN CONTAINS NR OF STMT TO PROFILE
*
* JSR PRFLU CALL TO UPDATE ENTRY
* (IA) DESTROYED
*
PRFLU PRC E,0
BNZ PFFNC,PFLU4 SKIP IF JUST ENTERED FUNCTION
MOV XR,-(XS) PRESERVE ENTRY XR
MOV WA,PFSVW SAVE WA
BNZ PFTBL,PFLU2 BRANCH IF TABLE ALLOCATED
*
* HERE IF SPACE FOR PROFILE TABLE NOT YET ALLOCATED.
* CALCULATE SIZE NEEDED, ALLOCATE A STATIC XNBLK, AND
* INITIALIZE IT ALL TO ZERO.
* THE TIME TAKEN FOR THIS WILL BE ATTRIBUTED TO THE CURRENT
* STATEMENT (ASSIGNMENT TO KEYWD PROFILE), BUT SINCE THE
* TIMING FOR THIS STATEMENT IS UP THE POLE ANYWAY, THIS
* DOESNT REALLY MATTER...
*
SUB =NUM01,PFNTE ADJUST FOR EXTRA COUNT
MTI PFI2A CONVRT ENTRY SIZE TO INT
STI PFSTE AND STORE SAFELY FOR LATER
MTI PFNTE LOAD TABLE LENGTH AS INTEGER
MLI PFSTE MULTIPLY BY ENTRY SIZE
MFI WA GET BACK ADDRESS-STYLE
ADD =NUM02,WA ADD ON 2 WORD OVERHEAD
WTB WA CONVERT THE WHOLE LOT TO BYTES
JSR ALOST GIMME THE SPACE
MOV XR,PFTBL SAVE BLOCK POINTER
MOV =B$XNT,(XR)+ PUT BLOCK TYPE AND ...
MOV WA,(XR)+ ... LENGTH INTO HEADER
MFI WA GET BACK NR OF WDS IN DATA AREA
LCT WA,WA LOAD THE COUNTER
*
* LOOP HERE TO ZERO THE BLOCK DATA
*
PFLU1 ZER (XR)+ BLANK A WORD
BCT WA,PFLU1 AND ALL THE REST
EJC
*
* PRFLU (CONTINUED)
*
* END OF ALLOCATION. MERGE BACK INTO ROUTINE
*
PFLU2 MTI KVSTN LOAD NR OF STMT JUST ENDED
SBI INTV1 MAKE INTO INDEX OFFSET
MLI PFSTE MAKE OFFSET OF TABLE ENTRY
MFI WA CONVERT TO ADDRESS
WTB WA GET AS BAUS
ADD *NUM02,WA OFFSET INCLUDES TABLE HEADER
MOV PFTBL,XR GET TABLE START
BGE WA,NUM01(XR),PFLU3 IF OUT OF TABLE, SKIP IT
ADD WA,XR ELSE POINT TO ENTRY
LDI (XR) GET NR OF EXECUTIONS SO FAR
ADI INTV1 NUDGE UP ONE
STI (XR) AND PUT BACK
JSR SYSTM GET TIME NOW
STI PFETM STASH ENDING TIME
SBI PFSTM SUBTRACT START TIME
ADI CFP$I(XR) ADD CUMULATIVE TIME SO FAR
STI CFP$I(XR) AND PUT BACK NEW TOTAL
LDI PFETM LOAD END TIME OF THIS STMT ...
STI PFSTM ... WHICH IS START TIME OF NEXT
*
* RETURN POINT
*
PFLU3 MOV (XS)+,XR RESTORE CALLERS XR
MOV PFSVW,WA RESTORE WA
EXI AND RETURN
*
* HERE IF PROFILE IS SUPPRESSED BECAUSE A PROGRAM DEFINED
* FUNCTION IS ABOUT TO BE ENTERED, AND SO THE CURRENT STMT
* HAS NOT YET FINISHED
*
PFLU4 ZER PFFNC RESET THE CONDITION FLAG
EXI AND IMMEDIATE RETURN
ENP END OF PROCEDURE PRFLU
.FI
EJC
*
* PRPAR -- PROCESS PRINT PARAMETERS
*
* JSR PRPAR CALL TO PROCESS PRINT PARAMETERS
* (XR,WA,WB,WC) DESTROYED
*
PRPAR PRC E,0 ENTRY POINT
MOV XL,-(XS) SAVE XL
JSR SYSPP GET PRINT PARAMETERS
BNZ WB,PRPA1 JUMP IF LINES/PAGE SPECIFIED
MOV =CFP$M,WB ELSE USE A LARGE VALUE
RSH WB,1 BUT NOT TOO LARGE
*
* STORE LINE COUNT/PAGE
*
PRPA1 MOV WB,LSTNP STORE NUMBER OF LINES/PAGE
MOV WB,LSTLC PRETEND PAGE IS FULL INITIALLY
ZER LSTPG CLEAR PAGE NUMBER
BZE PRLEN,PRPA2 SKIP IF NOT SYSXI RESUMPTION
BHI WA,PRLEN,PRPA3 SKIP IF BIGGER THAN PRIOR BFRS
*
* STORE PRINT BUFFER LENGTH
*
PRPA2 MOV WA,PRLEN STORE VALUE
*
* CHECK TERMINAL BUFFER SIZE
*
PRPA3 BZE TTLEN,PRPA4 SKIP IF NOT SYSXI RESUMPTION
BHI XL,TTLEN,PRPA5 SKIP IF TOO BIG
*
* STORE TERMINAL BUFFER LENGTH
*
PRPA4 MOV XL,TTLEN BFR LENGTH
*
* PROCESS BITS OPTIONS
*
PRPA5 MOV BITS1,WB BIT 1 MASK
ANB WC,WB GET BIT
MOV WB,TTINS INPUT FROM TERMINAL FLAG
MOV BITS2,WB BIT 2 MASK
ANB WC,WB GET BIT
MOV WB,TTOUS STD OUTPUT TO TERMINAL FLAG
MOV TTLEN,TTERL ERRORS TO TERML IF AVAILABLE
MOV PRLEN,PRAVL NOTE IF A PRINT FILE IS AVAILABLE
ZRB WB,PRPA6 IF FLAG SET, CLEAR TTERL SINCE ...
ZER TTERL ... TERML GETS ALL OUTPUT ALREADY
MOV TTLEN,TTOUS REGULAR O/P TO TERML IF AVAILABLE
MOV TTLEN,PRLEN REVISED PRINT BUFFER LENGTH
ZER TTLEN DONT NEED SEPARATE TERML BUFFER
EJC
*
* PRPAR (CONTINUED)
*
* GET OFFSET TO /PAGE NN/ PART OF HEADER
*
PRPA6 MOV PRLEN,WA STD BFR LENGTH
BNZ WA,PRPA7 USE IF NON-ZERO
MOV TTLEN,WA ELSE TRY TERMINAL
BZE WA,PRPA8 GIVE UP IF ZERO ALSO
*
* GET OFFSET
*
PRPA7 MOV WA,PRLEN STORE AS BUFFER LENGTH
SUB =NUM08,WA JUST BEFORE END OF LINE
MOV WA,LSTPO KEEP IT
MOV TTOUS,WB CONSTRUCT VALUE FOR ...
ORB PRAVL,WB ... USE IN DECIDING WHETHER TO ...
MOV WB,PRPUT ... PUT STRINGS IN OUTPUT BUFFER
*
* MORE BITS
*
PRPA8 MOV BITS3,WB BIT 3 MASK
ANB WC,WB GET -NOLIST BIT
ZRB WB,PRPA9 SKIP IF CLEAR
ZER CSWLS SET -NOLIST
*
* MORE BITS
*
PRPA9 MOV BITS4,WB BIT 4 MASK
ANB WC,WB GET BIT
MOV WB,CPSTS FLAG FOR COMPILE STATS SUPPRESSN.
MOV BITS5,WB BIT 5 MASK
ANB WC,WB GET BIT
MOV WB,EXSTS FLAG FOR EXEC STATS SUPPRESSION
MOV BITS6,WB BIT 6 MASK
ANB WC,WB GET BIT
MOV WB,NOXEQ SET NOEXECUTE IF NON-ZERO
MOV BITS7,WB BIT 7 MASK
ANB WC,WB GET BIT
ZRB WB,PRP10 SKIP IF NOT SET
ZER TTERL CLEAR ERRORS TO TERML IF SET
*
* MORE BITS
*
PRP10 MOV BITS8,WB BIT 8 MASK
ANB WC,WB GET BIT
MOV WB,HEADN SYSID HEADERS INCLUDE/OMIT FLAG
MOV BITS9,WB BIT 9 MASK
ANB WC,WB GET BIT
MOV WB,PRSTO STANDARD LISTING FLAG
MOV BIT10,WB BIT 10 MASK
ANB WC,WB GET BIT
MOV WB,PRECL EXTENDED LISTING OPTION
MOV (XS)+,XL RESTORE XL
EXI RETURN
ENP END PROCEDURE PRPAR
EJC
*
* PRTCF -- PRINT CHAR TO STD PRINTER AND FLUSH BFR
*
* (WA) CHAR TO PRINT
* JSR PRTCF CALL TO PRINT AND FLUSH
*
PRTCF PRC E,0 ENTRY POINT
JSR PRTCH PRINT CHARACTER
JSR PRTFH FLUSH BUFFER
EXI RETURN TO CALLER
ENP END PROCEDURE PRTCF
*
* PRTCH -- PRINT A CHARACTER ON STANDARD PRINTER
*
* PRTCH IS USED TO PRINT A SINGLE CHARACTER
*
* (WA) CHARACTER TO BE PRINTED
* JSR PRTCH CALL TO PRINT CHARACTER
*
PRTCH PRC E,0 ENTRY POINT
BZE PRLEN,PTCH2 SKIP IF NO PRINT FILE
MOV XR,-(XS) SAVE XR
BNE PROFS,PRLEN,PTCH1 JUMP IF ROOM IN BUFFER
JSR PRTFH ELSE PRINT THIS LINE
*
* HERE AFTER MAKING SURE WE HAVE ROOM
*
PTCH1 MOV PRBUF,XR POINT TO PRINT BUFFER
PSC XR,PROFS POINT TO NEXT CHARACTER LOCATION
SCH WA,(XR) STORE NEW CHARACTER
CSC XR COMPLETE STORE CHARACTERS
ICV PROFS BUMP POINTER
MOV (XS)+,XR RESTORE ENTRY XR
*
* RETURN POINT
*
PTCH2 EXI RETURN TO PRTCH CALLER
ENP END PROCEDURE PRTCH
*
* PRTFB -- PRINT STRING, FLUSH BFR AND PRINT BLANK LINE
*
* (XR) STRING TO PRINT
* JSR PRTFB CALL FOR PRINT FLUSH AND BLANK
*
PRTFB PRC E,0 ENTRY POINT
JSR PRTSF PRINT AND FLUSH
JSR PRTFH PRINT BLANK
EXI RETURN TO CALLER
ENP END PROCEDURE PRTFB
EJC
*
* PRTFH -- FLUSH STANDARD PRINT BUFFER
*
* PRTFH PRINTS THE CONTENTS OF THE PRINT BUFFER, RESETS
* THE BUFFER TO ALL BLANKS AND RESETS THE PRINT POINTER.
* ON ITS FIRST CALL IT MAY PRINT LISTING HEADERS.
* IF TTLST IS NON-ZERO, IT COPIES PRINT BUFFER TO
* TERMINAL AND FLUSHES THIS ALSO.
*
* JSR PRTFH CALL TO FLUSH BUFFER
*
PRTFH PRC R,0 ENTRY POINT
BNZ HEADP,PTFH1 WERE HEADERS PRINTED
JSR PRTPS NO - PRINT THEM
*
* HEADERS DONE
*
PTFH1 BZE PRLEN,PTFH4 SKIP IF NO OUTPUT POSSIBLE
MOV XL,-(XS) SAVE XL
MOV XR,-(XS) SAVE XR
MOV WA,-(XS) SAVE WA
MOV WC,-(XS) SAVE WC
MOV PRBUF,XR LOAD POINTER TO BUFFER
MOV PROFS,WC LOAD NUMBER OF CHARS IN BUFFER
BNZ PRAVL,PTFH5 SKIP IF PRINT FILE AVAILABLE
BNZ TTOUS,PTFH2 SKIP IF STD OUTPUT TO TERML
BZE TTLST,PTFH3 LAST POSSIBILITY IS ERROR TO TERML
*
* SEND TO TERMINAL
*
PTFH2 JSR SYSPI PRINT TO TERMINAL
PPM PTFH6 FAIL
PPM EROSI ERROR
EJC
* PRTFH (CONTINUED)
*
* BLANK BUFFER
*
PTFH3 MOV PRBLK,XL POINT TO BLANKING STRING
MOV PRCHS,XR POINT TO BUFFER
MOV PRCMV,WA COUNT OF BAUS TO MOVE
MVW MOVE BLANKS INTO BUFFER
ZER PROFS RESET OFFSET
MOV (XS)+,WC RESTORE WC
MOV (XS)+,WA RECOVER WA
MOV (XS)+,XR RESTORE XR
MOV (XS)+,XL RESTORE XL
*
* RETURN POINT
*
PTFH4 EXI RETURN TO CALLER
*
* HERE FOR REGULAR PRINT FILE
*
PTFH5 JSR SYSPR CALL SYSTEM PRINT ROUTINE
PPM PTFH6 JUMP IF FAILED
PPM EROSI STOP IF ERROR
BZE TTLST,PTFH3 SKIP IF NO COPY TO TERMINAL
MOV PROFS,SCLEN(XR) SET STRING LENGTH FOR PTTST
JSR PTTST COPY STD BUFFER TO TERML BFR
JSR PTTFH FLUSH IT
MOV PRLEN,SCLEN(XR) RESTORE BUFFER LENGTH
BRN PTFH3 MERGE
*
* A FAILURE SUCH AS FILE OVERFILLED OCCURRED
*
PTFH6 BZE STAGX,PTFH3 IGNORE IF COMPILE TIME
BRN EXFAL ELSE CAUSE STMT FAILURE
ENP END PROCEDURE PRTFH
EJC
*
* PRTIN -- PRINT AN INTEGER
*
* PRTIN PRINTS THE INTEGER VALUE WHICH IS IN THE INTEGER
* ACCUMULATOR. BLOCKS BUILT IN DYNAMIC STORAGE
* DURING THIS PROCESS ARE IMMEDIATELY DELETED.
*
* (IA) INTEGER VALUE TO BE PRINTED
* JSR PRTIN CALL TO PRINT INTEGER
* (IA,RA) DESTROYED
*
PRTIN PRC E,0 ENTRY POINT
MOV XR,-(XS) SAVE XR
JSR ICBLD BUILD INTEGER BLOCK
BLO XR,DNAMB,PRTI1 JUMP IF ICBLK BELOW DYNAMIC
BHI XR,DNAMP,PRTI1 JUMP IF ABOVE DYNAMIC
MOV XR,DNAMP IMMEDIATELY DELETE IT
*
* DELETE ICBLK FROM DYNAMIC STORE
*
PRTI1 MOV XR,-(XS) STACK PTR FOR GTSTG
JSR GTSTG CONVERT TO STRING
PPM CONVERT ERROR IS IMPOSSIBLE
MOV XR,DNAMP RESET POINTER TO DELETE SCBLK
JSR PRTST PRINT INTEGER STRING
MOV (XS)+,XR RESTORE ENTRY XR
EXI RETURN TO PRTIN CALLER
ENP END PROCEDURE PRTIN
*
* PRTMI -- PRINT MESSAGE AND INTEGER
*
* PRTMI IS USED TO PRINT MESSAGES TOGETHER WITH AN INTEGER
* VALUE STARTING IN COLUMN 15 (USED BY THE ROUTINES AT
* THE END OF COMPILATION).
*
* JSR PRTMI CALL TO PRINT MESSAGE AND INTEGER
*
PRTMI PRC E,0 ENTRY POINT
JSR PRTST PRINT STRING MESSAGE
MOV =PRTMF,PROFS SET OFFSET TO COL 15
JSR PRTIN PRINT INTEGER
JSR PRTFH PRINT LINE
EXI RETURN TO PRTMI CALLER
ENP END PROCEDURE PRTMI
EJC
*
* PRTNM -- PRINT VARIABLE NAME
*
* PRTNM IS USED TO PRINT A CHARACTER REPRESENTATION OF THE
* NAME OF A VARIABLE (NOT A VALUE OF DATATYPE NAME)
* NAMES OF PSEUDO-VARIABLES MAY NOT BE PASSED TO PRTNM.
*
* (XL) NAME BASE
* (WA) NAME OFFSET
* JSR PRTNM CALL TO PRINT NAME
* (WB,WC,RA) DESTROYED
*
PRTNM PRC R,0 ENTRY POINT (RECURSIVE, SEE PRTVL)
MOV WA,-(XS) SAVE WA (OFFSET IS COLLECTABLE)
MOV XR,-(XS) SAVE ENTRY XR
MOV XL,-(XS) SAVE NAME BASE
BHI XL,STATE,PRN02 JUMP IF NOT NATURAL VARIABLE
*
* HERE FOR NATURAL VARIABLE NAME, RECOGNIZED BY THE FACT
* THAT THE NAME BASE POINTS INTO THE STATIC AREA.
*
MOV XL,XR POINT TO VRBLK
JSR PRTVN PRINT NAME OF VARIABLE
*
* COMMON EXIT POINT
*
PRN01 MOV (XS)+,XL RESTORE NAME BASE
MOV (XS)+,XR RESTORE ENTRY VALUE OF XR
MOV (XS)+,WA RESTORE WA
EXI RETURN TO PRTNM CALLER
*
* HERE FOR CASE OF NON-NATURAL VARIABLE
*
PRN02 MOV WA,WB COPY NAME OFFSET
BNE (XL),=B$PDT,PRN03 JUMP IF ARRAY OR TABLE
*
* FOR PROGRAM DEFINED DATATYPE, PRT FLD NAME, LEFT PAREN
*
MOV PDDFP(XL),XR LOAD POINTER TO DFBLK
ADD WA,XR ADD NAME OFFSET
MOV PDFOF(XR),XR LOAD VRBLK POINTER FOR FIELD
JSR PRTVN PRINT FIELD NAME
MOV =CH$PP,WA LOAD LEFT PAREN
JSR PRTCH PRINT CHARACTER
EJC
*
* PRTNM (CONTINUED)
*
* NOW WE PRINT AN IDENTIFYING NAME FOR THE OBJECT IF ONE
* CAN BE FOUND. THE FOLLOWING CODE SEARCHES FOR A NATURAL
* VARIABLE WHICH CONTAINS THIS OBJECT AS VALUE. IF SUCH A
* VARIABLE IS FOUND, ITS NAME IS PRINTED, ELSE THE VALUE
* OF THE OBJECT (AS PRINTED BY PRTVL) IS USED INSTEAD.
*
* FIRST WE POINT TO THE PARENT TBBLK IF THIS IS THE CASE OF
* A TABLE ELEMENT. TO DO THIS, CHASE DOWN THE TRNXT CHAIN.
*
PRN03 BNE (XL),=B$TET,PRN04 JUMP IF WE GOT THERE (OR NOT TE)
MOV TENXT(XL),XL ELSE MOVE OUT ON CHAIN
BRN PRN03 AND LOOP BACK
*
* NOW WE ARE READY FOR THE SEARCH. TO SPEED THINGS UP IN
* THE CASE OF CALLS FROM DUMP WHERE THE SAME NAME BASE
* WILL OCCUR REPEATEDLY WHILE DUMPING AN ARRAY OR TABLE,
* WE REMEMBER THE LAST VRBLK POINTER FOUND IN PRNMV. SO
* FIRST CHECK TO SEE IF WE HAVE THIS ONE AGAIN.
*
PRN04 MOV PRNMV,XR POINT TO VRBLK WE FOUND LAST TIME
MOV HSHTB,WA POINT TO HASH TABLE IN CASE NOT
BRN PRN07 JUMP INTO SEARCH FOR SPECIAL CHECK
*
* LOOP THROUGH HASH SLOTS
*
PRN05 MOV WA,XR COPY SLOT POINTER
ICA WA BUMP SLOT POINTER
SUB *VRNXT,XR INTRODUCE STANDARD VRBLK OFFSET
*
* LOOP THROUGH VRBLKS ON ONE HASH CHAIN
*
PRN06 MOV VRNXT(XR),XR POINT TO NEXT VRBLK ON HASH CHAIN
*
* MERGE HERE FIRST TIME TO CHECK BLOCK WE FOUND LAST TIME
*
PRN07 MOV XR,WC COPY VRBLK POINTER
BZE WC,PRN09 JUMP IF CHAIN END (OR PRNMV ZERO)
EJC
*
* PRTNM (CONTINUED)
*
* LOOP TO FIND VALUE (CHASE DOWN POSSIBLE TRBLK CHAIN)
*
PRN08 MOV VRVAL(XR),XR LOAD VALUE
BEQ (XR),=B$TRT,PRN08 LOOP IF THAT WAS A TRBLK
*
* NOW WE HAVE THE VALUE, IS THIS THE BLOCK WE WANT
*
BEQ XR,XL,PRN10 JUMP IF THIS MATCHES THE NAME BASE
MOV WC,XR ELSE POINT BACK TO THAT VRBLK
BRN PRN06 AND LOOP BACK
*
* HERE TO MOVE TO NEXT HASH SLOT
*
PRN09 BLT WA,HSHTE,PRN05 LOOP BACK IF MORE TO GO
MOV XL,XR ELSE NOT FOUND, COPY VALUE POINTER
JSR PRTVL PRINT VALUE
BRN PRN11 AND MERGE AHEAD
*
* HERE WHEN WE FIND A MATCHING ENTRY
*
PRN10 MOV WC,XR COPY VRBLK POINTER
MOV XR,PRNMV SAVE FOR NEXT TIME IN
JSR PRTVN PRINT VARIABLE NAME
*
* MERGE HERE IF NO ENTRY FOUND
*
PRN11 MOV (XL),WC LOAD FIRST WORD OF NAME BASE
BNE WC,=B$PDT,PRN13 JUMP IF NOT PROGRAM DEFINED
*
* FOR PROGRAM DEFINED DATATYPE, ADD RIGHT PAREN AND EXIT
*
MOV =CH$RP,WA LOAD RIGHT PAREN, MERGE
*
* MERGE HERE TO PRINT FINAL RIGHT PAREN OR BRACKET
*
PRN12 JSR PRTCH PRINT FINAL CHARACTER
MOV WB,WA RESTORE NAME OFFSET
BRN PRN01 MERGE BACK TO EXIT
EJC
*
* PRTNM (CONTINUED)
*
* HERE FOR ARRAY OR TABLE
*
PRN13 MOV =CH$BB,WA LOAD LEFT BRACKET
JSR PRTCH AND PRINT IT
MOV (XS),XL RESTORE BLOCK POINTER
MOV (XL),WC LOAD TYPE WORD AGAIN
BNE WC,=B$TET,PRN15 JUMP IF NOT TABLE
*
* HERE FOR TABLE, PRINT SUBSCRIPT VALUE
*
MOV TESUB(XL),XR LOAD SUBSCRIPT VALUE
MOV WB,XL SAVE NAME OFFSET
JSR PRTVL PRINT SUBSCRIPT VALUE
MOV XL,WB RESTORE NAME OFFSET
*
* MERGE HERE FROM ARRAY CASE TO PRINT RIGHT BRACKET
*
PRN14 MOV =CH$RB,WA LOAD RIGHT BRACKET
BRN PRN12 MERGE BACK TO PRINT IT
*
* HERE FOR ARRAY OR VECTOR, TO PRINT SUBSCRIPT(S)
*
PRN15 MOV WB,WA COPY NAME OFFSET
BTW WA CONVERT TO WORDS
BEQ WC,=B$ART,PRN16 JUMP IF ARBLK
*
* HERE FOR VECTOR
*
SUB =VCVLB,WA ADJUST FOR STANDARD FIELDS
MTI WA MOVE TO INTEGER ACCUM
JSR PRTIN PRINT LINEAR SUBSCRIPT
BRN PRN14 MERGE BACK FOR RIGHT BRACKET
EJC
*
* PRTNM (CONTINUED)
*
* HERE FOR ARRAY. FIRST CALCULATE ABSOLUTE SUBSCRIPT
* OFFSETS BY SUCCESSIVE DIVISIONS BY THE DIMENSION VALUES.
* THIS MUST BE DONE RIGHT TO LEFT SINCE THE ELEMENTS ARE
* STORED ROW-WISE. THE SUBSCRIPTS ARE STACKED AS INTEGERS.
*
PRN16 MOV AROFS(XL),WC LOAD LENGTH OF BOUNDS INFO
ICA WC ADJUST FOR ARPRO FIELD
BTW WC CONVERT TO WORDS
SUB WC,WA GET LINEAR ZERO-ORIGIN SUBSCRIPT
MTI WA GET INTEGER VALUE
LCT WA,ARNDM(XL) SET NUM OF DIMENSIONS AS LOOP COUNT
ADD AROFS(XL),XL POINT PAST BOUNDS INFORMATION
SUB *ARLBD,XL SET OK OFFSET FOR PROPER PTR LATER
*
* LOOP TO STACK SUBSCRIPT OFFSETS
*
PRN17 SUB *ARDMS,XL POINT TO NEXT SET OF BOUNDS
STI PRNSI SAVE CURRENT OFFSET
RMI ARDIM(XL) GET REMAINDER ON DIVIDING BY DIMENS
MFI -(XS) STORE ON STACK (ONE WORD)
LDI PRNSI RELOAD ARGUMENT
DVI ARDIM(XL) DIVIDE TO GET QUOTIENT
BCT WA,PRN17 LOOP TILL ALL STACKED
ZER XR SET OFFSET TO FIRST SET OF BOUNDS
LCT WB,ARNDM(XL) LOAD COUNT OF DIMS TO CONTROL LOOP
BRN PRN19 JUMP INTO PRINT LOOP
*
* LOOP TO PRINT SUBSCRIPTS FROM STACK ADJUSTING BY ADDING
* THE APPROPRIATE LOW BOUND VALUE FROM THE ARBLK
*
PRN18 MOV =CH$CM,WA LOAD A COMMA
JSR PRTCH PRINT IT
*
* MERGE HERE FIRST TIME IN (NO COMMA REQUIRED)
*
PRN19 MTI (XS)+ LOAD SUBSCRIPT OFFSET AS INTEGER
ADD XR,XL POINT TO CURRENT LBD
ADI ARLBD(XL) ADD LBD TO GET SIGNED SUBSCRIPT
SUB XR,XL POINT BACK TO START OF ARBLK
JSR PRTIN PRINT SUBSCRIPT
ADD *ARDMS,XR BUMP OFFSET TO NEXT BOUNDS
BCT WB,PRN18 LOOP BACK TILL ALL PRINTED
BRN PRN14 MERGE BACK TO PRINT RIGHT BRACKET
ENP END PROCEDURE PRTNM
EJC
*
* PRTNV -- PRINT NAME VALUE
*
* PRTNV IS USED BY THE TRACE AND DUMP ROUTINES TO PRINT
* A LINE OF THE FORM
*
* NAME = VALUE
*
* NOTE THAT THE NAME INVOLVED CAN NEVER BE A PSEUDO-VAR
*
* (XL) NAME BASE
* (WA) NAME OFFSET
* JSR PRTNV CALL TO PRINT NAME = VALUE
* (WB,WC,RA) DESTROYED
*
PRTNV PRC E,0 ENTRY POINT
JSR PRTNM PRINT ARGUMENT NAME
MOV XR,-(XS) SAVE ENTRY XR
MOV WA,-(XS) SAVE NAME OFFSET (COLLECTABLE)
MOV =TMBEB,XR POINT TO BLANK EQUAL BLANK
JSR PRTST PRINT IT
MOV XL,XR COPY NAME BASE
ADD WA,XR POINT TO VALUE
MOV (XR),XR LOAD VALUE POINTER
JSR PRTVF PRINT VALUE
MOV (XS)+,WA RESTORE NAME OFFSET
MOV (XS)+,XR RESTORE ENTRY XR
EXI RETURN TO CALLER
ENP END PROCEDURE PRTNV
EJC
*
* PRTPG -- PRINT A PAGE THROW
*
* PRINTS A PAGE THROW OR A FEW BLANK LINES ON THE STANDARD
* LISTING FILE DEPENDING ON THE LISTING OPTIONS CHOSEN.
*
* JSR PRTPG CALL FOR PAGE EJECT
*
PRTPG PRC E,0 ENTRY POINT
BNZ STAGX,PTPG1 SKIP IF EXECUTION TIME
BZE LSTLC,PTPG6 RETURN IF TOP OF PAGE ALREADY
ZER LSTLC CLEAR LINE COUNT
*
* CHECK TYPE OF LISTING
*
PTPG1 MOV XR,-(XS) PRESERVE XR
BNZ PRECL,PTPG2 EJECT IF EXTENDED LISTING
BZE PRSTD,PTPG3 SKIP IF COMPACT LISTING
BNZ TTOUS,PTPG3 SKIP IF LISTING TO TERMINAL
*
* PERFORM AN EJECT
*
PTPG2 JSR SYSEP EJECT
PPM PTPG4 IGNORE FAILURE
PPM EROSI ERROR
BRN PTPG4 MERGE
*
* COMPACT LISTING.
*
PTPG3 BNZ HEADN,PTPG4 SKIP IF HEADERS OMITTED
MOV HEADP,XR REMEMBER HEADP
MNZ HEADP SET TO AVOID RECURSIVE PRTPG CALLS
JSR PRTFH PRINT BLANK LINE
JSR PRTFH PRINT BLANK LINE
JSR PRTFH PRINT BLANK LINE
MOV =NUM03,LSTLC COUNT BLANK LINES
MOV XR,HEADP RESTORE HEADER FLAG
EJC
*
* PRPTG (CONTINUED)
*
* PRINT THE HEADING
*
PTPG4 BNZ HEADP,PTPG5 JUMP IF HEADER LISTED
MNZ HEADP MARK HEADERS PRINTED
BNZ HEADN,PTPG5 SKIP IF HEADERS OMITTED
MOV XL,-(XS) KEEP XL
MOV =HEADR,XR POINT TO LISTING HEADER
JSR PRTST PLACE IT
JSR SYSID GET SYSTEM IDENTIFICATION
JSR PRTSF APPEND EXTRA CHARS AND PRINT
MOV XL,XR EXTRA HEADER LINE
JSR PRTFB PLACE IT AND A BLANK
JSR PRTFH AND ANOTHER
ADD =NUM04,LSTLC FOUR HEADER LINES PRINTED
MOV (XS)+,XL RESTORE XL
*
* MERGE IF HEADER NOT PRINTED
*
PTPG5 MOV (XS)+,XR RESTORE XR
*
* RETURN
*
PTPG6 EXI RETURN
ENP END PROCEDURE PRTPG
EJC
*
* PRTPS -- PRINT PAGE WITH TEST FOR STANDARD LISTING OPTION
*
* IF THE STANDARD LISTING OPTION IS SELECTED, INSIST THAT
* AN EJECT BE DONE
*
* JSR PRTPS CALL FOR EJECT
*
PRTPS PRC E,0 ENTRY POINT
MOV PRSTO,PRSTD COPY OPTION FLAG
JSR PRTPG PRINT PAGE
ZER PRSTD CLEAR FLAG
EXI RETURN
ENP END PROCEDURE PRTPS
*
* PRTSF -- PRINT STRING TO STD PRINTER AND FLUSH BFR
*
* (XR) STRING TO PRINT
* JSR PRTSF CALL TO PRINT AND FLUSH
*
PRTSF PRC E,0 ENTRY POINT
JSR PRTST PRINT STRING
JSR PRTFH FLUSH BUFFER
EXI RETURN TO CALLER
ENP END PROCEDURE PRTSF
EJC
*
* PRTSN -- PRINT STATEMENT NUMBER
*
* PRTSN IS USED TO INITIATE A PRINT TRACE LINE BY PRINTING
* ASTERISKS AND THE CURRENT STATEMENT NUMBER. THE ACTUAL
* FORMAT OF THE OUTPUT GENERATED IS.
*
* ***NNNNN**** III.....IIII
*
* NNNNN IS THE STATEMENT NUMBER WITH LEADING ZEROS REPLACED
* BY ASTERISKS (E.G. *******9****)
*
* III...III REPRESENTS A VARIABLE LENGTH OUTPUT CONSISTING
* OF A NUMBER OF LETTER I CHARACTERS EQUAL TO FNCLEVEL.
*
* JSR PRTSN CALL TO PRINT STATEMENT NUMBER
* (WC) DESTROYED
*
PRTSN PRC E,0 ENTRY POINT
MOV XR,-(XS) SAVE ENTRY XR
MOV WA,PRSNA SAVE ENTRY WA
MOV =TMASB,XR POINT TO ASTERISKS
JSR PRTST PRINT ASTERISKS
MOV =NUM04,PROFS POINT INTO MIDDLE OF ASTERISKS
MTI KVSTN LOAD STATEMENT NUMBER AS INTEGER
JSR PRTIN PRINT INTEGER STATEMENT NUMBER
MOV =PRSNF,PROFS POINT PAST ASTERISKS PLUS BLANK
MOV KVFNC,XR GET FNCLEVEL
MOV =CH$LI,WA SET LETTER I
*
* LOOP TO GENERATE LETTER I FNCLEVEL TIMES
*
PRSN1 BZE XR,PRSN2 JUMP IF ALL SET
JSR PRTCH ELSE PRINT AN I
DCV XR DECREMENT COUNTER
BRN PRSN1 LOOP BACK
*
* MERRE WITH ALL LETTER I CHARACTERS GENERATED
*
PRSN2 MOV =CH$BL,WA GET BLANK
JSR PRTCH PRINT BLANK
MOV PRSNA,WA RESTORE ENTRY WA
MOV (XS)+,XR RESTORE ENTRY XR
EXI RETURN TO PRTSN CALLER
ENP END PROCEDURE PRTSN
EJC
*
* PRTST -- PRINT STRING TO STANDARD FILE
*
* PLACE A STRING OF CHARACTERS IN THE STANDARD PRINT BUFFER
*
* NOTE THAT THE FIRST WORD OF THE BLOCK (NORMALLY B$SCL)
* IS NOT USED AND NEED NOT BE SET CORRECTLY (SEE PRTVN)
* IF GLOBAL TTOUS IS NON-ZERO, STRING IS SENT TO TERMINAL
* INSTEAD OF STANDARD OUTPUT FILE.
* IF GLOBAL TTLST IS NON-ZERO, STRING IS SENT TO
* TERMINAL AS WELL AS STANDARD OUTPUT FILE
*
* (XR) STRING TO BE PRINTED
* JSR PRTST CALL TO PRINT STRING
* (PROFS) UPDATED PAST CHARS PLACED
*
PRTST PRC R,0 ENTRY POINT
BNZ HEADP,PTST1 WERE HEADERS PRINTED
JSR PRTPS NO - PRINT THEM
*
* HEADERS DEALT WITH
*
PTST1 BZE PRLEN,PTST7 SKIP IF NO O/P POSSIBLE
BNZ PRPUT,PTST2 SKIP IF PUTTING IS OK
BZE TTLST,PTST7 SKIP OUT IF NOT ERROR TO TERML
*
* KEEP REGISTERS
*
PTST2 MOV WA,PRSVA SAVE WA
MOV WB,PRSVB SAVE WB
ZER WB SET CHARS PRINTED COUNT TO ZERO
*
* LOOP TO PRINT SUCCESSIVE LINES FOR LONG STRING
*
PTST3 MOV SCLEN(XR),WA LOAD STRING LENGTH
SUB WB,WA SUBTRACT COUNT OF CHARS ALREADY OUT
BZE WA,PTST6 JUMP TO EXIT IF NONE LEFT
MOV XL,-(XS) ELSE STACK ENTRY XL
MOV XR,-(XS) SAVE ARGUMENT
MOV XR,XL COPY FOR EVENTUAL MOVE
MOV PRLEN,XR LOAD PRINT BUFFER LENGTH
SUB PROFS,XR GET CHARS LEFT IN PRINT BUFFER
BNZ XR,PTST4 SKIP IF ROOM LEFT ON THIS LINE
JSR PRTFH PRINT THIS LINE
MOV PRLEN,XR AND SET FULL WIDTH AVAILABLE
EJC
*
* PRTST (CONTINUED)
*
* HERE WITH CHARS TO PRINT AND SOME ROOM IN BUFFER
*
PTST4 BLO WA,XR,PTST5 JUMP IF ROOM FOR REST OF STRING
MOV XR,WA ELSE SET TO FILL LINE
*
* MERGE HERE WITH CHARACTER COUNT IN WA
*
PTST5 MOV PRBUF,XR POINT TO PRINT BUFFER
PLC XL,WB POINT TO LOCATION IN STRING
PSC XR,PROFS POINT TO LOCATION IN BUFFER
ADD WA,WB BUMP STRING CHARS COUNT
ADD WA,PROFS BUMP BUFFER POINTER
MVC MOVE CHARACTERS TO BUFFER
MOV (XS)+,XR RESTORE ARGUMENT POINTER
MOV (XS)+,XL RESTORE ENTRY XL
BRN PTST3 LOOP BACK TO TEST FOR MORE
*
* HERE TO EXIT AFTER PRINTING STRING
*
PTST6 MOV PRSVB,WB RESTORE ENTRY WB
MOV PRSVA,WA RESTORE ENTRY WA
*
* RETURN POINT
*
PTST7 EXI RETURN TO PRTST CALLER
ENP END PROCEDURE PRTST
*
* PRTVF -- PLACE A VALUE AND FLUSH STANDARD BUFFER
*
* (XR) VALUE TO PRINT
* JSR PRTVF CALL TO PRINT AND FLUSH
*
PRTVF PRC E,0 ENTRY POINT
JSR PRTVL PLACE VALUE
JSR PRTFH FLUSH BUFFER
EXI RETURN TO CALLER
ENP END PROCEDURE PRTVF
EJC
*
* PRTVL -- PRINT A VALUE
*
* PRTVL PLACES AN APPROPRIATE CHARACTER REPRESENTATION OF
* A DATA VALUE IN THE PRINT BUFFER FOR DUMP/TRACE USE.
*
* (XR) VALUE TO BE PRINTED
* JSR PRTVL CALL TO PRINT VALUE
* (WA,WB,WC,RA) DESTROYED
*
PRTVL PRC R,0 ENTRY POINT, RECURSIVE
MOV XL,-(XS) SAVE ENTRY XL
MOV XR,-(XS) SAVE ARGUMENT
CHK CHECK FOR STACK OVERFLOW
*
* LOOP BACK HERE AFTER FINDING A TRAP BLOCK (TRBLK)
*
PRV01 MOV IDVAL(XR),PRVSI COPY IDVAL (IF ANY)
MOV (XR),XL LOAD FIRST WORD OF BLOCK
LEI XL LOAD ENTRY POINT ID
BSW XL,BL$$T,PRV02 SWITCH ON BLOCK TYPE
IFF BL$TR,PRV04 TRBLK
IFF BL$AR,PRV05 ARBLK
IFF BL$IC,PRV08 ICBLK
IFF BL$NM,PRV09 NMBLK
IFF BL$PD,PRV10 PDBLK
.IF .CNRA
.ELSE
IFF BL$RC,PRV08 RCBLK
.FI
IFF BL$SC,PRV11 SCBLK
IFF BL$SE,PRV12 SEBLK
IFF BL$TB,PRV13 TBBLK
IFF BL$VC,PRV13 VCBLK
.IF .CNBF
.ELSE
IFF BL$BC,PRV15 BCBLK
.FI
ESW END OF SWITCH ON BLOCK TYPE
*
* HERE FOR BLOCKS FOR WHICH WE JUST PRINT DATATYPE NAME
*
PRV02 JSR DTYPE GET DATATYPE NAME
JSR PRTST PRINT DATATYPE NAME
*
* COMMON EXIT POINT
*
PRV03 MOV (XS)+,XR RELOAD ARGUMENT
MOV (XS)+,XL RESTORE XL
EXI RETURN TO PRTVL CALLER
*
* HERE FOR TRBLK
*
PRV04 MOV TRVAL(XR),XR LOAD REAL VALUE
BRN PRV01 AND LOOP BACK
EJC
*
* PRTVL (CONTINUED)
*
* HERE FOR ARRAY (ARBLK)
*
* PRINT ARRAY ( PROTOTYPE ) BLANK NUMBER IDVAL
*
PRV05 MOV XR,XL PRESERVE ARGUMENT
MOV =SCARR,XR POINT TO DATATYPE NAME (ARRAY)
JSR PRTST PRINT IT
MOV =CH$PP,WA LOAD LEFT PAREN
JSR PRTCH PRINT LEFT PAREN
ADD AROFS(XL),XL POINT TO PROTOTYPE
MOV (XL),XR LOAD PROTOTYPE
JSR PRTST PRINT PROTOTYPE
*
* VCBLK, TBBLK MERGE HERE FOR ) BLANK NUMBER IDVAL
*
PRV06 MOV =CH$RP,WA LOAD RIGHT PAREN
JSR PRTCH PRINT RIGHT PAREN
*
* PDBLK MERGES HERE TO PRINT BLANK NUMBER IDVAL
*
PRV07 MOV =CH$BL,WA LOAD BLANK
JSR PRTCH PRINT IT
MOV =CH$NM,WA LOAD NUMBER SIGN
JSR PRTCH PRINT IT
MTI PRVSI GET IDVAL
JSR PRTIN PRINT ID NUMBER
BRN PRV03 BACK TO EXIT
*
* HERE FOR INTEGER (ICBLK), REAL (RCBLK)
*
* PRINT CHARACTER REPRESENTATION OF VALUE
*
PRV08 MOV XR,-(XS) STACK ARGUMENT FOR GTSTG
JSR GTSTG CONVERT TO STRING
PPM ERROR RETURN IS IMPOSSIBLE
JSR PRTST PRINT THE STRING
MOV XR,DNAMP DELETE GARBAGE STRING FROM STORAGE
BRN PRV03 BACK TO EXIT
EJC
*
* PRTVL (CONTINUED)
*
* NAME (NMBLK)
*
* FOR PSEUDO-VARIABLE, JUST PRINT DATATYPE NAME (NAME)
* FOR ALL OTHER NAMES, PRINT DOT FOLLOWED BY NAME REP
*
PRV09 MOV NMBAS(XR),XL LOAD NAME BASE
MOV (XL),WA LOAD FIRST WORD OF BLOCK
BEQ WA,=B$KVT,PRV02 JUST PRINT NAME IF KEYWORD
BEQ WA,=B$EVT,PRV02 JUST PRINT NAME IF EXPRESSION VAR
MOV =CH$DT,WA ELSE GET DOT
JSR PRTCH AND PRINT IT
MOV NMOFS(XR),WA LOAD NAME OFFSET
JSR PRTNM PRINT NAME
BRN PRV03 BACK TO EXIT
*
* PROGRAM DATATYPE (PDBLK)
*
* PRINT DATATYPE NAME CH$BL CH$NM IDVAL
*
PRV10 JSR DTYPE GET DATATYPE NAME
JSR PRTST PRINT DATATYPE NAME
BRN PRV07 MERGE BACK TO PRINT ID
*
* HERE FOR STRING (SCBLK)
*
* PRINT QUOTE STRING-CHARACTERS QUOTE
*
PRV11 MOV =CH$SQ,WA LOAD SINGLE QUOTE
JSR PRTCH PRINT QUOTE
JSR PRTST PRINT STRING VALUE
JSR PRTCH PRINT ANOTHER QUOTE
BRN PRV03 BACK TO EXIT
EJC
*
* PRTVL (CONTINUED)
*
* HERE FOR SIMPLE EXPRESSION (SEBLK)
*
* PRINT ASTERISK VARIABLE-NAME
*
PRV12 MOV =CH$AS,WA LOAD ASTERISK
JSR PRTCH PRINT ASTERISK
MOV SEVAR(XR),XR LOAD VARIABLE POINTER
JSR PRTVN PRINT VARIABLE NAME
BRN PRV03 JUMP BACK TO EXIT
*
* HERE FOR TABLE (TBBLK) AND ARRAY (VCBLK)
*
* PRINT DATATYPE ( PROTOTYPE ) BLANK NUMBER IDVAL
*
PRV13 MOV XR,XL PRESERVE ARGUMENT
JSR DTYPE GET DATATYPE NAME
JSR PRTST PRINT DATATYPE NAME
MOV =CH$PP,WA LOAD LEFT PAREN
JSR PRTCH PRINT LEFT PAREN
MOV TBLEN(XL),WA LOAD LENGTH OF BLOCK (=VCLEN)
BTW WA CONVERT TO WORD COUNT
SUB =TBSI$,WA ALLOW FOR STANDARD FIELDS
BEQ (XL),=B$TBT,PRV14 JUMP IF TABLE
ADD =VCTBD,WA FOR VCBLK, ADJUST SIZE
*
* PRINT PROTOTYPE
*
PRV14 MTI WA MOVE AS INTEGER
JSR PRTIN PRINT INTEGER PROTOTYPE
BRN PRV06 MERGE BACK FOR REST
.IF .CNBF
.ELSE
EJC
*
* PRTVL (CONTINUED)
*
* HERE FOR BUFFER (BCBLK)
*
PRV15 MOV XR,XL PRESERVE ARGUMENT
MOV =SCBUF,XR POINT TO DATATYPE NAME (BUFFER)
JSR PRTST PRINT IT
MOV =CH$PP,WA LOAD LEFT PAREN
JSR PRTCH PRINT LEFT PAREN
MOV BCBUF(XL),XR POINT TO BFBLK
MTI BFALC(XR) LOAD ALLOCATION SIZE
JSR PRTIN PRINT IT
MOV =CH$CM,WA LOAD COMMA
JSR PRTCH PRINT IT
MTI BCLEN(XL) LOAD DEFINED LENGTH
JSR PRTIN PRINT IT
BRN PRV06 MERGE TO FINISH UP
.FI
ENP END PROCEDURE PRTVL
EJC
*
* PRTVN -- PRINT NATURAL VARIABLE NAME
*
* PRTVN PRINTS THE NAME OF A NATURAL VARIABLE
*
* (XR) POINTER TO VRBLK
* JSR PRTVN CALL TO PRINT VARIABLE NAME
*
PRTVN PRC E,0 ENTRY POINT
MOV XR,-(XS) STACK VRBLK POINTER
ADD *VRSOF,XR POINT TO POSSIBLE STRING NAME
BNZ SCLEN(XR),PRVN1 JUMP IF NOT SYSTEM VARIABLE
MOV VRSVO(XR),XR POINT TO SVBLK WITH NAME
*
* MERGE HERE WITH DUMMY SCBLK POINTER IN XR
*
PRVN1 JSR PRTST PRINT STRING NAME OF VARIABLE
MOV (XS)+,XR RESTORE VRBLK POINTER
EXI RETURN TO PRTVN CALLER
ENP END PROCEDURE PRTVN
EJC
*
* PTTFH -- FLUSH TERMINAL BUFFER
*
* PRINTS THE CONTENTS OF THE TTY BUFFER, RESETS
* THE BUFFER TO ALL BLANKS AND RESETS THE POINTER.
*
* JSR PTTFH CALL TO FLUSH BUFFER
*
PTTFH PRC E,0 ENTRY POINT
BZE TTLEN,PTTF2 SKIP IF NO TERMINAL
MOV XL,-(XS) SAVE XL
MOV XR,-(XS) SAVE XR
MOV WA,-(XS) SAVE WA
MOV WC,-(XS) SAVE WC
MOV TTBUF,XR LOAD POINTER TO BUFFER
MOV TTOFS,WC LOAD NUMBER OF CHARS IN BUFFER
JSR SYSPI CALL SYSTEM PRINT ROUTINE
PPM PTTF3 JUMP IF FAILED
PPM EROSI STOP IF ERROR
*
* BLANK BUFFER
*
PTTF1 MOV TTBLK,XL POINT TO BLANKING STRING
MOV TTCHS,XR POINT TO BUFFER
MOV TTCMV,WA COUNT OF BAUS TO MOVE
MVW MOVE BLANKS INTO BUFFER
ZER TTOFS RESET OFFSET
MOV (XS)+,WC RESTORE WC
MOV (XS)+,WA RECOVER WA
MOV (XS)+,XR RESTORE XR
MOV (XS)+,XL RESTORE XL
*
* RETURN POINT
*
PTTF2 EXI RETURN TO CALLER
*
* A FAILURE SUCH AS FILE OVERFILLED OCCURRED
*
PTTF3 BZE STAGX,PTTF1 IGNORE IF COMPILE TIME
BRN EXFAL ELSE CAUSE STMT FAILURE
ENP END PROCEDURE
EJC
*
* PTTST -- PRINT STRING TO TERMINAL
*
* PLACE A STRING OF CHARACTERS IN THE TERMINAL BUFFER
*
* NOTE THAT THE FIRST WORD OF THE BLOCK (NORMALLY B$SCL)
* IS NOT USED AND NEED NOT BE SET CORRECTLY (SEE PRTVN)
*
* (XR) STRING TO BE PRINTED
* JSR PTTST CALL TO PRINT STRING
* (TTOFS) UPDATED PAST CHARS PLACED
*
PTTST PRC E,0 ENTRY POINT
BZE TTLEN,PTTS5 SKIP IF NO TERMINAL
MOV WA,PRTVA SAVE WA
MOV WB,PRTVB SAVE WB
ZER WB SET CHARS PRINTED COUNT TO ZERO
*
* LOOP TO PRINT SUCCESSIVE LINES FOR LONG STRING
*
PTTS1 MOV SCLEN(XR),WA LOAD STRING LENGTH
SUB WB,WA SUBTRACT COUNT OF CHARS ALREADY OUT
BZE WA,PTTS4 JUMP TO EXIT IF NONE LEFT
MOV XL,-(XS) ELSE STACK ENTRY XL
MOV XR,-(XS) SAVE ARGUMENT
MOV XR,XL COPY FOR EVENTUAL MOVE
MOV TTLEN,XR LOAD BUFFER LENGTH
SUB TTOFS,XR GET CHARS LEFT IN BUFFER
BNZ XR,PTTS2 SKIP IF ROOM LEFT ON THIS LINE
JSR PTTFH ELSE PRINT THIS LINE
MOV TTLEN,XR AND SET FULL WIDTH AVAILABLE
*
* HERE WITH CHARS TO PRINT AND SOME ROOM IN BUFFER
*
PTTS2 BLO WA,XR,PTTS3 JUMP IF ROOM FOR REST OF STRING
MOV XR,WA ELSE SET TO FILL LINE
*
* MERGE HERE WITH CHARACTER COUNT IN WA
*
PTTS3 MOV TTBUF,XR POINT TO PRINT BUFFER
PLC XL,WB POINT TO LOCATION IN STRING
PSC XR,TTOFS POINT TO LOCATION IN BUFFER
ADD WA,WB BUMP STRING CHARS COUNT
ADD WA,TTOFS BUMP BUFFER POINTER
MVC MOVE CHARACTERS TO BUFFER
MOV (XS)+,XR RESTORE ARGUMENT POINTER
MOV (XS)+,XL RESTORE ENTRY XL
BRN PTTS1 LOOP BACK TO TEST FOR MORE
EJC
*
* HERE TO EXIT AFTER PRINTING STRING
*
PTTS4 MOV PRTVB,WB RESTORE ENTRY WB
MOV PRTVA,WA RESTORE ENTRY WA
*
* RETURN POINT
*
PTTS5 EXI RETURN TO PTTST CALLER
ENP END PROCEDURE PTTST
.IF .CNRA
.ELSE
EJC
*
* RCBLD -- BUILD A REAL BLOCK
*
* (RA) REAL VALUE FOR RCBLK
* JSR RCBLD CALL TO BUILD REAL BLOCK
* (XR) POINTER TO RESULT RCBLK
* (WA) DESTROYED
*
RCBLD PRC E,0 ENTRY POINT
MOV DNAMP,XR LOAD POINTER TO NEXT AVAILABLE LOC
ADD *RCSI$,XR POINT PAST NEW RCBLK
BLO XR,DNAME,RCBL1 JUMP IF THERE IS ROOM
MOV *RCSI$,WA ELSE LOAD RCBLK LENGTH
JSR ALLOC USE STANDARD ALLOCATOR TO GET BLOCK
ADD WA,XR POINT PAST BLOCK TO MERGE
*
* MERGE HERE WITH XR POINTING PAST THE BLOCK OBTAINED
*
RCBL1 MOV XR,DNAMP SET NEW POINTER
SUB *RCSI$,XR POINT BACK TO START OF BLOCK
MOV =B$RCL,(XR) STORE TYPE WORD
STR RCVAL(XR) STORE REAL VALUE IN RCBLK
EXI RETURN TO RCBLD CALLER
ENP END PROCEDURE RCBLD
.FI
EJC
*
* READR -- READ NEXT SOURCE IMAGE AT COMPILE TIME
*
* READR IS USED TO READ THE NEXT SOURCE IMAGE. TO PROCESS
* CONTINUATION CARDS PROPERLY, THE COMPILER MUST READ ONE
* LINE AHEAD. THUS READR DOES NOT DESTROY THE CURRENT IMAGE
* SEE ALSO THE NEXTS ROUTINE WHICH ACTUALLY GETS THE IMAGE.
*
* THE GLOBAL FLAG RDRER IS SET JUST BEFORE THE READ, AND
* CLEARED AFTER IT. THIS IS SO THAT IN THE EVENT SYSRD
* OR SYSRI TAKE AN EROSI EXIT, THE ERROR APPENDAGE CAN
* RECOGNIZE THE SITUATION AND TAKE APPROPRIATE ACTION.
*
* JSR READR CALL TO READ NEXT IMAGE
* (XR) PTR TO NEXT IMAGE (0 IF NONE)
* (R$CNI) COPY OF POINTER
* (WA,WB,WC,XL) DESTROYED
*
READR PRC E,0 ENTRY POINT
MOV R$CNI,XR GET PTR TO NEXT IMAGE
BNZ XR,READ5 EXIT IF ALREADY READ
*
* MERGE FROM -COPY EOF TO TRY READ
*
READ0 BEQ STAGE,=STGIC,READ1 READ IF INITIAL COMPILE
BZE R$COP,READ6 ELSE EXIT IF NO -COPY IN FORCE
*
* ATTEMPT READ
*
READ1 MOV CSWIN,WA MAX READ LENGTH
MNZ RDRER NOTE IN-READR IN CASE EROSI
JSR ALOCS ALLOCATE BUFFER
BZE TTINS,READ2 SKIP IF STANDARD INPUT FILE
JSR SYSRI READ FROM TERMINAL
PPM READ7 FAIL
PPM EROSI ERROR
BRN READ3 MERGE
*
* READ FROM STANDARD FILE
*
READ2 JSR SYSRD READ INPUT IMAGE
PPM READ7 JUMP IF END OF FILE
PPM EROSI ERROR RETURN
*
* MERGE
*
READ3 ZER RDRER NOTE NOT-IN-READR FOR ERROR RTN
MNZ WB SET TRIMR TO PERFORM TRIM
BLE SCLEN(XR),CSWIN,READ4 USE SMALLER OF STRING LNTH..
MOV CSWIN,SCLEN(XR) ... AND XXX OF -INXXX
*
* PERFORM THE TRIM
*
READ4 JSR TRIMR TRIM TRAILING BLANKS
*
* MERGE HERE AFTER READ
*
READ5 MOV XR,R$CNI STORE COPY OF POINTER
*
* MERGE HERE IF NO READ ATTEMPTED
*
READ6 EXI RETURN TO READR CALLER
*
* HERE ON END OF FILE
*
READ7 ZER RDRER NOTE NOT-IN-READR FOR ERR
MOV XR,DNAMP POP UNUSED SCBLK
ZER XR ZERO PTR AS RESULT
BZE R$COP,READ5 SKIP IF NO -COPY IN FORCE
JSR COPND CALL TO END THIS -COPY (EOF)
BRN READ0 TRY AGAIN
ENP END PROCEDURE READR
.IF .CASL
EJC
*
* SBSCC -- BUILD SUBSTRING WITH CASE CONVERSION
*
* (XL) PTR TO SCBLK CONTAINING CHARS
* (WA) CHAR COUNT
* (WB) OFFSET TO FIRST CHAR IN SCBLK
* JSR SBSCC CALL TO BUILD SUBSTRING
* (XR) PTR TO NEW SCBLK WITH SUBSTRING
* (WA,WB,WC,XL,IA) DESTROYED
*
* IF OPTION .CPLC IS SELECTED (PREFER LOWER CASE), TARGET
* CASE IS LOWER CASE, OTHERWISE IT IS UPPER CASE.
*
SBSCC PRC E,0 ENTRY POINT
BZE WA,SBSC4 JUMP IF NULL SUBSTRING
JSR ALOCS ELSE ALLOCATE SCBLK
MOV WC,WA MOVE NUMBER OF CHARACTERS
MOV XR,WC SAVE PTR TO NEW SCBLK
PLC XL,WB PREPARE TO LOAD CHARS FROM OLD BLK
PSC XR PREPARE TO STORE CHARS IN NEW BLK
LCT WA,WA TO COUNT ROUND LOOP
*
* LOOP TO COPY AND TRANSLATE CHARS
*
SBSC1 LCH WB,(XL)+ GET CHAR
.IF .CPLC
BGT WB,=CH$L$,SBSC2 SKIP IF NOT UC LETTER
BLT WB,=CH$LA,SBSC2 SKIP IF NOT UC LETTER
.IF .CSCV
CUL WB CONVERT FROM UC TO LC
.ELSE
ADD =DFA$A,WB CONVERT FROM UC TO LC
.FI
.ELSE
BGT WB,=CH$$$,SBSC2 SKIP IF NOT A LC LETTER
BLT WB,=CH$$A,SBSC2 SKIP IF NOT A LC LETTER
.IF .CSCV
CLU WB CONVERT FROM LC TO UC
.ELSE
SUB =DFA$A,WB CONVERT FROM LC TO UC
.FI
.FI
*
* STORE CHAR IN NEW SUBSTRING
*
SBSC2 SCH WB,(XR)+ STORE CHAR
BCT WA,SBSC1 LOOP
MOV WC,XR RESTORE SCBLK POINTER
*
* RETURN POINT
*
SBSC3 ZER XL CLEAR GARBAGE POINTER IN XL
EXI RETURN TO SBSCC CALLER
*
* HERE FOR NULL SUBSTRING
*
SBSC4 MOV =NULLS,XR SET NULL STRING AS RESULT
BRN SBSC3 RETURN
ENP END PROCEDURE SBSCC
EJC
*
* SBSTG -- BUILD SUBSTRING POSSIBLY CONVERTING CASE
*
* (XL) PTR TO SCBLK CONTAINING CHARS
* (WA) CHAR COUNT
* (WB) OFFSET TO FIRST CHAR IN SCBLK
* JSR SBSTG CALL TO BUILD SUBSTRING
* (XR) PTR TO NEW SCBLK WITH SUBSTRING
* (WA,WB,WC,XL,IA) DESTROYED
*
* IF CASE IS TO BE IGNORED (-CASEIG OR .CSIG), SUBSTRING
* IS CONVERTED TO PREFERRED CASE (DEFAULT UPPER),
* OTHERWISE CASE IS LEFT ALONE.
*
SBSTG PRC E,0 ENTRY POINT
BZE CSWCI,SBSG1 SKIP IF CASE NOT IGNORED
JSR SBSCC CONVERT TO IGNORE CASE
EXI RETURN TO CALLER
*
SBSG1 JSR SBSTR READ SUBSTRING IN MIXED CASE
EXI RETURN TO CALLER
ENP END PROCEDURE SBSTG
.FI
EJC
*
* SBSTR -- BUILD A SUBSTRING
*
* (XL) PTR TO SCBLK CONTAINING CHARS
* (WA) NUMBER OF CHARS IN SUBSTRING
* (WB) OFFSET TO FIRST CHAR IN SCBLK
* JSR SBSTR CALL TO BUILD SUBSTRING
* (XR) PTR TO NEW SCBLK WITH SUBSTRING
* (WA,WB,WC,XL,IA) DESTROYED
*
* NOTE THAT SBSTR IS CALLED WITH A DUMMY STRING POINTER
* (POINTING INTO A VRBLK OR SVBLK) TO COPY THE NAME OF A
* VARIABLE AS A STANDARD STRING VALUE.
*
SBSTR PRC E,0 ENTRY POINT
BZE WA,SBST2 JUMP IF NULL SUBSTRING
JSR ALOCS ELSE ALLOCATE SCBLK
MOV WC,WA MOVE NUMBER OF CHARACTERS
MOV XR,WC SAVE PTR TO NEW SCBLK
PLC XL,WB PREPARE TO LOAD CHARS FROM OLD BLK
PSC XR PREPARE TO STORE CHARS IN NEW BLK
MVC MOVE CHARACTERS TO NEW STRING
MOV WC,XR THEN RESTORE SCBLK POINTER
*
* RETURN POINT
*
SBST1 ZER XL CLEAR GARBAGE POINTER IN XL
EXI RETURN TO SBSTR CALLER
*
* HERE FOR NULL SUBSTRING
*
SBST2 MOV =NULLS,XR SET NULL STRING AS RESULT
BRN SBST1 RETURN
ENP END PROCEDURE SBSTR
EJC
*
* SCANE -- SCAN AN ELEMENT
*
* SCANE IS CALLED AT COMPILE TIME (BY EXPAN ,CMPIL,CNCRD)
* TO SCAN ONE ELEMENT FROM THE INPUT IMAGE.
*
* (SCNCC) NON-ZERO IF CALLED FROM CNCRD
* JSR SCANE CALL TO SCAN ELEMENT
* (XR) RESULT POINTER (SEE BELOW)
* (XL) SYNTAX TYPE CODE (T$XXX)
*
* THE FOLLOWING GLOBAL LOCATIONS ARE USED.
*
* R$CIM POINTER TO STRING BLOCK (SCBLK)
* FOR CURRENT INPUT IMAGE.
*
* R$CNI POINTER TO NEXT INPUT IMAGE STRING
* POINTER (ZERO IF NONE).
*
* R$SCP SAVE POINTER (EXIT XR) FROM LAST
* CALL IN CASE RESCAN IS SET.
*
* SCNBL THIS LOCATION IS SET NON-ZERO ON
* EXIT IF SCANE SCANNED PAST BLANKS
* BEFORE LOCATING THE CURRENT ELEMENT
* THE END OF A LINE COUNTS AS BLANKS.
*
* SCNCC CNCRD SETS THIS NON-ZERO TO SCAN
* CONTROL CARD NAMES AND CLEARS IT
* ON RETURN
*
* SCNIL LENGTH OF CURRENT INPUT IMAGE
*
* SCNGO IF SET NON-ZERO ON ENTRY, F AND S
* ARE RETURNED AS SEPARATE SYNTAX
* TYPES (NOT LETTERS) (GOTO PRO-
* CESSING). SCNGO IS RESET ON EXIT.
*
* SCNPT OFFSET TO CURRENT LOC IN R$CIM
*
* SCNRS IF SET NON-ZERO ON ENTRY, SCANE
* RETURNS THE SAME RESULT AS ON THE
* LAST CALL (RESCAN). SCNRS IS RESET
* ON EXIT FROM ANY CALL TO SCANE.
*
* SCNTP SAVE SYNTAX TYPE FROM LAST
* CALL (IN CASE RESCAN IS SET).
EJC
*
* SCANE (CONTINUED)
*
*
*
* ELEMENT SCANNED XL XR
* --------------- -- --
*
* CONTROL CARD NAME 0 POINTER TO SCBLK FOR NAME
*
* UNARY OPERATOR T$UOP PTR TO OPERATOR DVBLK
*
* LEFT PAREN T$LPR T$LPR
*
* LEFT BRACKET T$LBR T$LBR
*
* COMMA T$CMA T$CMA
*
* FUNCTION CALL T$FNC PTR TO FUNCTION VRBLK
*
* VARIABLE T$VAR PTR TO VRBLK
*
* STRING CONSTANT T$CON PTR TO SCBLK
*
* INTEGER CONSTANT T$CON PTR TO ICBLK
*
.IF .CNRA
.ELSE
* REAL CONSTANT T$CON PTR TO RCBLK
*
.FI
* BINARY OPERATOR T$BOP PTR TO OPERATOR DVBLK
*
* RIGHT PAREN T$RPR T$RPR
*
* RIGHT BRACKET T$RBR T$RBR
*
* COLON T$COL T$COL
*
* SEMI-COLON T$SMC T$SMC
*
* F (SCNGO NE 0) T$FGO T$FGO
*
* S (SCNGO NE 0) T$SGO T$SGO
EJC
*
* SCANE (CONTINUED)
*
* ENTRY POINT
*
SCANE PRC E,0 ENTRY POINT
ZER SCNBL RESET BLANKS FLAG
MOV WA,SCNSA SAVE WA
MOV WB,SCNSB SAVE WB
MOV WC,SCNSC SAVE WC
BZE SCNRS,SCN03 JUMP IF NO RESCAN
*
* HERE FOR RESCAN REQUEST
*
MOV SCNTP,XL SET PREVIOUS RETURNED SCAN TYPE
MOV R$SCP,XR SET PREVIOUS RETURNED POINTER
ZER SCNRS RESET RESCAN SWITCH
BRN SCN13 JUMP TO EXIT
*
* COME HERE TO READ NEW IMAGE TO TEST FOR CONTINUATION
*
SCN01 JSR READR READ NEXT IMAGE
MOV *DVUBS,WB SET WB FOR NOT READING NAME
BZE XR,SCN30 TREAT AS SEMI-COLON IF NONE
PLC XR ELSE POINT TO FIRST CHARACTER
LCH WC,(XR) LOAD FIRST CHARACTER
BEQ WC,=CH$DT,SCN02 JUMP IF DOT FOR CONTINUATION
BNE WC,=CH$PL,SCN30 ELSE TREAT AS SEMICOLON UNLESS PLUS
*
* HERE FOR CONTINUATION LINE
*
SCN02 JSR NEXTS ACQUIRE NEXT SOURCE IMAGE
MOV =NUM01,SCNPT SET SCAN POINTER PAST CONTINUATION
MNZ SCNBL SET BLANKS FLAG
EJC
*
* SCANE (CONTINUED)
*
* MERGE HERE TO SCAN NEXT ELEMENT ON CURRENT LINE
*
SCN03 MOV SCNPT,WA LOAD CURRENT OFFSET
BEQ WA,SCNIL,SCN01 CHECK CONTINUATION IF END
MOV R$CIM,XL POINT TO CURRENT LINE
PLC XL,WA POINT TO CURRENT CHARACTER
MOV WA,SCNSE SET START OF ELEMENT LOCATION
MOV =OPDVS,WC POINT TO OPERATOR DV LIST
MOV *DVUBS,WB SET CONSTANT FOR OPERATOR CIRCUIT
BRN SCN06 START SCANNING
*
* LOOP HERE TO IGNORE LEADING BLANKS AND TABS
*
SCN05 BZE WB,SCN10 JUMP IF TRAILING
ICV SCNSE INCREMENT START OF ELEMENT
BEQ WA,SCNIL,SCN01 JUMP IF END OF IMAGE
MNZ SCNBL NOTE BLANKS SEEN
*
* THE FOLLOWING JUMP IS USED REPEATEDLY FOR SCANNING OUT
* THE CHARACTERS OF A NUMERIC CONSTANT OR VARIABLE NAME.
* THE REGISTERS ARE USED AS FOLLOWS.
*
* (XR) SCRATCH
* (XL) PTR TO NEXT CHARACTER
* (WA) CURRENT SCAN OFFSET
* (WB) *DVUBS (0 IF SCANNING NAME,CONST)
* (WC) =OPDVS (0 IF SCANNING CONSTANT)
*
SCN06 LCH XR,(XL)+ GET NEXT CHARACTER
ICV WA BUMP SCAN OFFSET
MOV WA,SCNPT STORE OFFSET PAST CHAR SCANNED
BGE XR,=CFP$U,SCN07 QUICK CHECK FOR OTHER CHAR
BSW XR,CFP$U,SCN07 SWITCH ON SCANNED CHARACTER
*
* SWITCH TABLE FOR SWITCH ON CHARACTER
*
IFF CH$BL,SCN05 BLANK
.IF .CAHT
IFF CH$HT,SCN05 HORIZONTAL TAB
.FI
.IF .CAVT
IFF CH$VT,SCN05 VERTICAL TAB
.FI
IFF CH$D0,SCN08 DIGIT 0
IFF CH$D1,SCN08 DIGIT 1
IFF CH$D2,SCN08 DIGIT 2
IFF CH$D3,SCN08 DIGIT 3
IFF CH$D4,SCN08 DIGIT 4
IFF CH$D5,SCN08 DIGIT 5
IFF CH$D6,SCN08 DIGIT 6
IFF CH$D7,SCN08 DIGIT 7
IFF CH$D8,SCN08 DIGIT 8
IFF CH$D9,SCN08 DIGIT 9
EJC
*
* SCANE (CONTINUED)
*
IFF CH$LA,SCN09 LETTER A
IFF CH$LB,SCN09 LETTER B
IFF CH$LC,SCN09 LETTER C
IFF CH$LD,SCN09 LETTER D
IFF CH$LE,SCN09 LETTER E
IFF CH$LG,SCN09 LETTER G
IFF CH$LH,SCN09 LETTER H
IFF CH$LI,SCN09 LETTER I
IFF CH$LJ,SCN09 LETTER J
IFF CH$LK,SCN09 LETTER K
IFF CH$LL,SCN09 LETTER L
IFF CH$LM,SCN09 LETTER M
IFF CH$LN,SCN09 LETTER N
IFF CH$LO,SCN09 LETTER O
IFF CH$LP,SCN09 LETTER P
IFF CH$LQ,SCN09 LETTER Q
IFF CH$LR,SCN09 LETTER R
IFF CH$LT,SCN09 LETTER T
IFF CH$LU,SCN09 LETTER U
IFF CH$LV,SCN09 LETTER V
IFF CH$LW,SCN09 LETTER W
IFF CH$LX,SCN09 LETTER X
IFF CH$LY,SCN09 LETTER Y
IFF CH$L$,SCN09 LETTER Z
.IF .CASL
IFF CH$$A,SCN09 SHIFTED A
IFF CH$$B,SCN09 SHIFTED B
IFF CH$$C,SCN09 SHIFTED C
IFF CH$$D,SCN09 SHIFTED D
IFF CH$$E,SCN09 SHIFTED E
IFF CH$$F,SCN20 SHIFTED F
IFF CH$$G,SCN09 SHIFTED G
IFF CH$$H,SCN09 SHIFTED H
IFF CH$$I,SCN09 SHIFTED I
IFF CH$$J,SCN09 SHIFTED J
IFF CH$$K,SCN09 SHIFTED K
IFF CH$$L,SCN09 SHIFTED L
IFF CH$$M,SCN09 SHIFTED M
IFF CH$$N,SCN09 SHIFTED N
IFF CH$$O,SCN09 SHIFTED O
IFF CH$$P,SCN09 SHIFTED P
IFF CH$$Q,SCN09 SHIFTED Q
IFF CH$$R,SCN09 SHIFTED R
IFF CH$$S,SCN21 SHIFTED S
IFF CH$$T,SCN09 SHIFTED T
IFF CH$$U,SCN09 SHIFTED U
IFF CH$$V,SCN09 SHIFTED V
IFF CH$$W,SCN09 SHIFTED W
IFF CH$$X,SCN09 SHIFTED X
IFF CH$$Y,SCN09 SHIFTED Y
IFF CH$$$,SCN09 SHIFTED Z
.FI
EJC
*
* SCANE (CONTINUED)
*
IFF CH$SQ,SCN16 SINGLE QUOTE
IFF CH$DQ,SCN17 DOUBLE QUOTE
IFF CH$LF,SCN20 LETTER F
IFF CH$LS,SCN21 LETTER S
IFF CH$UN,SCN24 UNDERLINE
IFF CH$PP,SCN25 LEFT PAREN
IFF CH$RP,SCN26 RIGHT PAREN
IFF CH$RB,SCN27 RIGHT BRACKET
IFF CH$BB,SCN28 LEFT BRACKET
IFF CH$CB,SCN27 RIGHT BRACKET
IFF CH$OB,SCN28 LEFT BRACKET
IFF CH$CL,SCN29 COLON
IFF CH$SM,SCN30 SEMI-COLON
IFF CH$CM,SCN31 COMMA
IFF CH$DT,SCN32 DOT
IFF CH$PL,SCN34 PLUS
IFF CH$MN,SCN35 MINUS
IFF CH$NT,SCN36 NOT
IFF CH$DL,SCN33 DOLLAR
IFF CH$EX,SCN37 EXCLAMATION MARK
IFF CH$PC,SCN38 PERCENT
IFF CH$SL,SCN40 SLASH
IFF CH$NM,SCN41 NUMBER SIGN
IFF CH$AT,SCN42 AT
IFF CH$BR,SCN43 VERTICAL BAR
IFF CH$AM,SCN44 AMPERSAND
IFF CH$QU,SCN45 QUESTION MARK
IFF CH$EQ,SCN46 EQUAL
IFF CH$AS,SCN49 ASTERISK
ESW END SWITCH ON CHARACTER
*
* HERE FOR ILLEGAL CHARACTER (UNDERLINE MERGES)
*
SCN07 BZE WB,SCN10 JUMP IF SCANNING NAME OR CONSTANT
ERB 232,SYNTAX ERROR. ILLEGAL CHARACTER
EJC
*
* SCANE (CONTINUED)
*
* HERE FOR DIGITS 0-9
*
SCN08 BZE WB,SCN09 KEEP SCANNING IF NAME/CONSTANT
ZER WC ELSE SET FLAG FOR SCANNING CONSTANT
*
* HERE FOR LETTER. LOOP HERE WHEN SCANNING NAME/CONSTANT
*
SCN09 BEQ WA,SCNIL,SCN11 JUMP IF END OF IMAGE
ZER WB SET FLAG FOR SCANNING NAME/CONST
BRN SCN06 MERGE BACK TO CONTINUE SCAN
*
* COME HERE FOR DELIMITER ENDING NAME OR CONSTANT
*
SCN10 DCV WA RESET OFFSET TO POINT TO DELIMITER
*
* COME HERE AFTER FINISHING SCAN OF NAME OR CONSTANT
*
SCN11 MOV WA,SCNPT STORE UPDATED SCAN OFFSET
MOV SCNSE,WB POINT TO START OF ELEMENT
SUB WB,WA GET NUMBER OF CHARACTERS
MOV R$CIM,XL POINT TO LINE IMAGE
BNZ WC,SCN15 JUMP IF NAME
*
* HERE AFTER SCANNING OUT NUMERIC CONSTANT
*
JSR SBSTR GET STRING FOR CONSTANT
MOV XR,DNAMP DELETE FROM STORAGE (NOT NEEDED)
JSR GTNUM CONVERT TO NUMERIC
PPM SCN14 JUMP IF CONVERSION FAILURE
*
* MERGE HERE TO EXIT WITH CONSTANT
*
SCN12 MOV =T$CON,XL SET RESULT TYPE OF CONSTANT
EJC
*
* SCANE (CONTINUED)
*
* COMMON EXIT POINT (XR,XL) SET
*
SCN13 MOV SCNSA,WA RESTORE WA
MOV SCNSB,WB RESTORE WB
MOV SCNSC,WC RESTORE WC
MOV XR,R$SCP SAVE XR IN CASE RESCAN
MOV XL,SCNTP SAVE XL IN CASE RESCAN
ZER SCNGO RESET POSSIBLE GOTO FLAG
EXI RETURN TO SCANE CALLER
*
* HERE IF CONVERSION ERROR ON NUMERIC ITEM
*
SCN14 ERB 233,SYNTAX ERROR. INVALID NUMERIC ITEM
*
* HERE AFTER SCANNING OUT VARIABLE NAME
*
.IF .CASL
SCN15 JSR SBSTG BUILD STRING NAME OF VARIABLE
.ELSE
SCN15 JSR SBSTR BUILD STRING NAME OF VARIABLE
.FI
BNZ SCNCC,SCN13 RETURN IF CNCRD CALL
JSR GTNVR LOCATE/BUILD VRBLK
PPM DUMMY (UNUSED) ERROR RETURN
MOV =T$VAR,XL SET TYPE AS VARIABLE
BRN SCN13 BACK TO EXIT
*
* HERE FOR SINGLE QUOTE (START OF STRING CONSTANT)
*
SCN16 BZE WB,SCN10 TERMINATOR IF SCANNING NAME OR CNST
MOV =CH$SQ,WB SET TERMINATOR AS SINGLE QUOTE
BRN SCN18 MERGE
*
* HERE FOR DOUBLE QUOTE (START OF STRING CONSTANT)
*
SCN17 BZE WB,SCN10 TERMINATOR IF SCANNING NAME OR CNST
MOV =CH$DQ,WB SET DOUBLE QUOTE TERMINATOR, MERGE
*
* LOOP TO SCAN OUT STRING CONSTANT
*
SCN18 BEQ WA,SCNIL,SCN19 ERROR IF END OF IMAGE
LCH WC,(XL)+ ELSE LOAD NEXT CHARACTER
ICV WA BUMP OFFSET
BNE WC,WB,SCN18 LOOP BACK IF NOT TERMINATOR
EJC
*
* SCANE (CONTINUED)
*
* HERE AFTER SCANNING OUT STRING CONSTANT
*
MOV SCNPT,WB POINT TO FIRST CHARACTER
MOV WA,SCNPT SAVE OFFSET PAST FINAL QUOTE
DCV WA POINT BACK PAST LAST CHARACTER
SUB WB,WA GET NUMBER OF CHARACTERS
MOV R$CIM,XL POINT TO INPUT IMAGE
JSR SBSTR BUILD SUBSTRING VALUE
BRN SCN12 BACK TO EXIT WITH CONSTANT RESULT
*
* HERE IF NO MATCHING QUOTE FOUND
*
SCN19 MOV WA,SCNPT SET UPDATED SCAN POINTER
ERB 234,SYNTAX ERROR. UNMATCHED STRING QUOTE
*
* HERE FOR F (POSSIBLE FAILURE GOTO)
*
SCN20 MOV =T$FGO,XR SET RETURN CODE FOR FAIL GOTO
BRN SCN22 JUMP TO MERGE
*
* HERE FOR S (POSSIBLE SUCCESS GOTO)
*
SCN21 MOV =T$SGO,XR SET SUCCESS GOTO AS RETURN CODE
*
* SPECIAL GOTO CASES MERGE HERE
*
SCN22 BZE SCNGO,SCN09 TREAT AS NORMAL LETTER IF NOT GOTO
*
* MERGE HERE FOR SPECIAL CHARACTER EXIT
*
SCN23 BZE WB,SCN10 JUMP IF END OF NAME/CONSTANT
MOV XR,XL ELSE COPY CODE
BRN SCN13 AND JUMP TO EXIT
*
* HERE FOR UNDERLINE
*
SCN24 BZE WB,SCN09 PART OF NAME IF SCANNING NAME
BRN SCN07 ELSE ILLEGAL
EJC
*
* SCANE (CONTINUED)
*
* HERE FOR LEFT PAREN
*
SCN25 MOV =T$LPR,XR SET LEFT PAREN RETURN CODE
BNZ WB,SCN23 RETURN LEFT PAREN UNLESS NAME
BZE WC,SCN10 DELIMITER IF SCANNING CONSTANT
*
* HERE FOR LEFT PAREN AFTER NAME (FUNCTION CALL)
*
MOV SCNSE,WB POINT TO START OF NAME
MOV WA,SCNPT SET POINTER PAST LEFT PAREN
DCV WA POINT BACK PAST LAST CHAR OF NAME
SUB WB,WA GET NAME LENGTH
MOV R$CIM,XL POINT TO INPUT IMAGE
JSR SBSTR GET STRING NAME FOR FUNCTION
JSR GTNVR LOCATE/BUILD VRBLK
PPM DUMMY (UNUSED) ERROR RETURN
MOV =T$FNC,XL SET CODE FOR FUNCTION CALL
BRN SCN13 BACK TO EXIT
*
* PROCESSING FOR SPECIAL CHARACTERS
*
SCN26 MOV =T$RPR,XR RIGHT PAREN, SET CODE
BRN SCN23 TAKE SPECIAL CHARACTER EXIT
*
SCN27 MOV =T$RBR,XR RIGHT BRACKET, SET CODE
BRN SCN23 TAKE SPECIAL CHARACTER EXIT
*
SCN28 MOV =T$LBR,XR LEFT BRACKET, SET CODE
BRN SCN23 TAKE SPECIAL CHARACTER EXIT
*
SCN29 MOV =T$COL,XR COLON, SET CODE
BRN SCN23 TAKE SPECIAL CHARACTER EXIT
*
SCN30 MOV =T$SMC,XR SEMI-COLON, SET CODE
BRN SCN23 TAKE SPECIAL CHARACTER EXIT
*
SCN31 MOV =T$CMA,XR COMMA, SET CODE
BRN SCN23 TAKE SPECIAL CHARACTER EXIT
EJC
*
* SCANE (CONTINUED)
*
* HERE FOR OPERATORS. ON ENTRY, WC POINTS TO THE TABLE OF
* OPERATOR DOPE VECTORS AND WB IS THE INCREMENT TO STEP
* TO THE NEXT PAIR (BINARY/UNARY) OF DOPE VECTORS IN THE
* LIST. ON REACHING SCN46, THE POINTER HAS BEEN ADJUSTED TO
* POINT TO THE APPROPRIATE PAIR OF DOPE VECTORS.
* THE FIRST FOUR ENTRIES ARE SPECIAL SINCE THEY CAN OCCUR
* AS PART OF A VARIABLE NAME (.$) OR CONSTANT (.+-).
*
SCN32 BZE WB,SCN09 DOT CAN BE PART OF NAME OR CONSTANT
ADD WB,WC ELSE BUMP POINTER
*
SCN33 BZE WB,SCN09 DOLLAR CAN BE PART OF NAME
ADD WB,WC ELSE BUMP POINTER
*
SCN34 BZE WC,SCN09 PLUS CAN BE PART OF CONSTANT
BZE WB,SCN48 PLUS CANNOT BE PART OF NAME
ADD WB,WC ELSE BUMP POINTER
*
SCN35 BZE WC,SCN09 MINUS CAN BE PART OF CONSTANT
BZE WB,SCN48 MINUS CANNOT BE PART OF NAME
ADD WB,WC ELSE BUMP POINTER
LCH XR,(XL) GET NEXT CHARACTER
BLT XR,=CH$D0,SCN36 SKIP IF NOT DIGIT
BLE XR,=CH$D9,SCN08 JUMP IF DIGIT
*
SCN36 ADD WB,WC NOT
SCN37 ADD WB,WC EXCLAMATION
SCN38 ADD WB,WC PERCENT
SCN39 ADD WB,WC ASTERISK
SCN40 ADD WB,WC SLASH
SCN41 ADD WB,WC NUMBER SIGN
SCN42 ADD WB,WC AT SIGN
SCN43 ADD WB,WC VERTICAL BAR
SCN44 ADD WB,WC AMPERSAND
SCN45 ADD WB,WC QUESTION MARK
EJC
*
* SCANE (CONTINUED)
*
* ALL OPERATORS COME HERE (EQUAL MERGES DIRECTLY)
* (WC) POINTS TO THE BINARY/UNARY PAIR OF OPERATOR DVBLKS.
*
SCN46 BZE WB,SCN10 OPERATOR TERMINATES NAME/CONSTANT
MOV WC,XR ELSE COPY DV POINTER
LCH WC,(XL) LOAD NEXT CHARACTER
MOV =T$BOP,XL SET BINARY OP IN CASE
BEQ WA,SCNIL,SCN47 SHOULD BE BINARY IF IMAGE END
BEQ WC,=CH$BL,SCN47 SHOULD BE BINARY IF FOLLOWED BY BLK
.IF .CAHT
BEQ WC,=CH$HT,SCN47 JUMP IF HORIZONTAL TAB
.FI
.IF .CAVT
BEQ WC,=CH$VT,SCN47 JUMP IF VERTICAL TAB
.FI
BEQ WC,=CH$SM,SCN47 SEMICOLON CAN IMMEDIATELY FOLLOW =
*
* HERE FOR UNARY OPERATOR
*
ADD *DVBS$,XR POINT TO DV FOR UNARY OP
MOV =T$UOP,XL SET TYPE FOR UNARY OPERATOR
BLE SCNTP,=T$UOK,SCN13 OK UNARY IF OK PRECEDING ELEMENT
EJC
*
* SCANE (CONTINUED)
*
* MERGE HERE TO REQUIRE PRECEDING BLANKS
*
SCN47 BNZ SCNBL,SCN13 ALL OK IF PRECEDING BLANKS, EXIT
*
* FAIL OPERATOR IN THIS POSITION
*
SCN48 ERB 235,SYNTAX ERROR. INVALID USE OF OPERATOR
*
* HERE FOR ASTERISK, COULD BE ** SUBSTITUTE FOR EXCLAMATION
*
SCN49 BZE WB,SCN10 END OF NAME IF SCANNING NAME
BEQ WA,SCNIL,SCN39 NOT ** IF * AT IMAGE END
MOV WA,XR ELSE SAVE OFFSET PAST FIRST *
MOV WA,SCNOF SAVE ANOTHER COPY
LCH WA,(XL)+ LOAD NEXT CHARACTER
BNE WA,=CH$AS,SCN50 NOT ** IF NEXT CHAR NOT *
ICV XR ELSE STEP OFFSET PAST SECOND *
BEQ XR,SCNIL,SCN51 OK EXCLAM IF END OF IMAGE
LCH WA,(XL) ELSE LOAD NEXT CHARACTER
BEQ WA,=CH$BL,SCN51 EXCLAMATION IF BLANK
.IF .CAHT
BEQ WA,=CH$HT,SCN51 EXCLAMATION IF HORIZONTAL TAB
.FI
.IF .CAVT
BEQ WA,=CH$VT,SCN51 EXCLAMATION IF VERTICAL TAB
.FI
*
* UNARY *
*
SCN50 MOV SCNOF,WA RECOVER STORED OFFSET
MOV R$CIM,XL POINT TO LINE AGAIN
PLC XL,WA POINT TO CURRENT CHAR
BRN SCN39 MERGE WITH UNARY *
*
* HERE FOR ** AS SUBSTITUTE FOR EXCLAMATION
*
SCN51 MOV XR,SCNPT SAVE SCAN POINTER PAST 2ND *
MOV XR,WA COPY SCAN POINTER
BRN SCN37 MERGE WITH EXCLAMATION
ENP END PROCEDURE SCANE
EJC
*
* SCNGF -- SCAN GOTO FIELD
*
* SCNGF IS CALLED FROM CMPIL TO SCAN AND ANALYZE A GOTO
* FIELD INCLUDING THE SURROUNDING BRACKETS OR PARENTHESES.
* FOR A NORMAL GOTO, THE RESULT RETURNED IS EITHER A VRBLK
* POINTER FOR A SIMPLE LABEL OPERAND, OR A POINTER TO AN
* EXPRESSION TREE WITH A SPECIAL OUTER UNARY OPERATOR
* (O$GOC). FOR A DIRECT GOTO, THE RESULT RETURNED IS A
* POINTER TO AN EXPRESSION TREE WITH THE SPECIAL OUTER
* UNARY OPERATOR O$GOD.
*
* JSR SCNGF CALL TO SCAN GOTO FIELD
* (XR) RESULT (SEE ABOVE)
* (XL,WA,WB,WC) DESTROYED
*
SCNGF PRC E,0 ENTRY POINT
JSR SCANE SCAN INITIAL ELEMENT
BEQ XL,=T$LPR,SCNG1 SKIP IF LEFT PAREN (NORMAL GOTO)
BEQ XL,=T$LBR,SCNG2 SKIP IF LEFT BRACKET (DIRECT GOTO)
ERB 236,SYNTAX ERROR. GOTO FIELD INCORRECT
*
* HERE FOR LEFT PAREN (NORMAL GOTO)
*
SCNG1 MOV =NUM01,WB SET EXPAN FLAG FOR NORMAL GOTO
JSR EXPAN ANALYZE GOTO FIELD
MOV =OPDVN,WA ELSE POINT TO OPDV FOR COMPLEX GOTO
BLE XR,STATB,SCNG3 JUMP IF NOT IN STATIC
BLO XR,STATE,SCNG4 JUMP TO EXIT IF SIMPLE LABEL NAME
BRN SCNG3 AND MERGE
*
* HERE FOR LEFT BRACKET (DIRECT GOTO)
*
SCNG2 MOV =NUM02,WB SET EXPAN FLAG FOR DIRECT GOTO
JSR EXPAN SCAN GOTO FIELD
MOV =OPDVD,WA SET OPDV POINTER FOR DIRECT GOTO
EJC
*
* SCNGF (CONTINUED)
*
* MERGE HERE TO BUILD OUTER UNARY OPERATOR BLOCK
*
SCNG3 MOV WA,-(XS) STACK OPERATOR DV POINTER
MOV XR,-(XS) STACK POINTER TO EXPRESSION TREE
JSR EXPOP POP OPERATOR OFF
MOV (XS)+,XR RELOAD NEW EXPRESSION TREE POINTER
*
* COMMON EXIT POINT
*
SCNG4 EXI RETURN TO CALLER
ENP END PROCEDURE SCNGF
EJC
*
* SETVR -- SET VRGET,VRSTO FIELDS OF VRBLK
*
* SETVR SETS THE PROPER VALUES IN THE VRGET AND VRSTO
* FIELDS OF A VRBLK. IT IS CALLED WHENEVER TRBLKS ARE
* ADDED OR SUBTRACTED (TRACE,STOPTR,INPUT,OUTPUT,DETACH)
*
* (XR) POINTER TO VRBLK
* JSR SETVR CALL TO SET FIELDS
* (XL,WA) DESTROYED
*
* NOTE THAT SETVR IGNORES THE CALL IF XR DOES NOT POINT
* INTO THE STATIC REGION (I.E. IS SOME OTHER NAME BASE)
*
SETVR PRC E,0 ENTRY POINT
BHI XR,STATE,SETV1 EXIT IF NOT NATURAL VARIABLE
*
* HERE IF WE HAVE A VRBLK
*
MOV XR,XL COPY VRBLK POINTER
MOV =B$VRL,VRGET(XR) STORE NORMAL GET VALUE
BEQ VRSTO(XR),=B$VRE,SETV1 SKIP IF PROTECTED VARIABLE
MOV =B$VRS,VRSTO(XR) STORE NORMAL STORE VALUE
MOV VRVAL(XL),XL POINT TO NEXT ENTRY ON CHAIN
BNE (XL),=B$TRT,SETV1 JUMP IF END OF TRBLK CHAIN
MOV =B$VRA,VRGET(XR) STORE TRAPPED ROUTINE ADDRESS
MOV =B$VRV,VRSTO(XR) SET TRAPPED ROUTINE ADDRESS
*
* MERGE HERE TO EXIT TO CALLER
*
SETV1 EXI RETURN TO SETVR CALLER
ENP END PROCEDURE SETVR
.IF .CNSR
.ELSE
EJC
*
* SORTA -- SORT ARRAY
*
* ROUTINE TO SORT AN ARRAY OR TABLE ON SAME BASIS AS IN
* SITBOL. A TABLE IS CONVERTED TO AN ARRAY, LEAVING TWO
* DIMENSIONAL ARRAYS AND VECTORS AS CASES TO BE CONSIDERED.
* WHOLE ROWS OF ARRAYS ARE PERMUTED ACCORDING TO THE
* ORDERING OF THE KEYS THEY CONTAIN, AND THE STRIDE
* REFERRED TO, IS THE THE LENGTH OF A ROW. IT IS ONE
* FOR A VECTOR.
* THE SORT USED IS HEAPSORT, FUNDAMENTALS OF DATA STRUCTURES,
* HOROWITZ AND SAHNI, PITMAN 1977, PAGE 347.
* IT IS AN ORDER N*LOG(N) ALGORITHM. IN ORDER
* TO MAKE IT STABLE, COMPARANDS MAY NOT COMPARE EQUAL. THIS
* IS ACHIEVED BY SORTING A COPY ARRAY (REFERRED TO AS THE
* SORT ARRAY) CONTAINING AT ITS HIGH ADDRESS END, BAU
* OFFSETS TO THE ROWS TO BE SORTED HELD IN THE ORIGINAL
* ARRAY (REFERRED TO AS THE KEY ARRAY). SORTC, THE
* COMPARISON ROUTINE, ACCESSES THE KEYS THROUGH THESE
* OFFSETS AND IN THE CASE OF EQUALITY, RESOLVES IT BY
* COMPARING THE OFFSETS THEMSELVES. THE SORT PERMUTES THE
* OFFSETS WHICH ARE THEN USED IN A FINAL OPERATION TO COPY
* THE ACTUAL ITEMS INTO THE NEW ARRAY IN SORTED ORDER.
* REFERENCES TO ZEROTH ITEM ARE TO NOTIONAL ITEM
* PRECEDING FIRST ACTUAL ITEM.
* REVERSE SORTING FOR RSORT IS DONE BY HAVING THE LESS THAN
* TEST FOR KEYS EFFECTIVELY BE REPLACED BY A
* GREATER THAN TEST.
* GIVES ERROR MESSAGES FOR INCORRECT ARGS, RETURNS EXI 1
* FOR EMPTY TABLE.
*
* 1(XS) FIRST ARG - ARRAY OR TABLE
* 0(XS) 2ND ARG - INDEX OR PDTYPE NAME
* (WA) 0 , NON-ZERO FOR SORT , RSORT
* JSR SORTA CALL TO SORT ARRAY
* PPM LOC FAIL RETURN FOR EMPTY TABLE
* (XR) SORTED ARRAY
* (XL,WA,WB,WC) DESTROYED
EJC
*
* SORTA (CONTINUED)
*
SORTA PRC N,1 ENTRY POINT
MOV WA,SRTSR SORT/RSORT INDICATOR
MOV *NUM01,SRTST DEFAULT STRIDE OF 1
ZER SRTOF DEFAULT ZERO OFFSET TO SORT KEY
MOV =NULLS,SRTDF CLEAR DATATYPE FIELD NAME
MOV (XS)+,R$SXR UNSTACK ARGUMENT 2
MOV (XS)+,XR GET FIRST ARGUMENT
MOV (XR),WA GET ARG TYPE
BEQ WA,=B$ART,SRT00 SKIP IF ARRAY
BNE WA,=B$TBT,SRT16 ERROR IF NOT TABLE
JSR GTARR CONVERT TO ARRAY
PPM SRT18 FAIL
*
* MAKE COPY OF ARRAY
*
SRT00 MOV XR,-(XS) STACK PTR TO RESULTING KEY ARRAY
MOV XR,-(XS) ANOTHER COPY FOR CBLCK
JSR CBLCK GET COPY ARRAY FOR SORTING INTO
PPM CANT FAIL
MOV XR,-(XS) STACK POINTER TO SORT ARRAY
MOV R$SXR,XR GET SECOND ARG
MOV 1(XS),XL GET PTR TO KEY ARRAY
BNE (XL),=B$VCT,SRT02 JUMP IF ARBLK
BEQ XR,=NULLS,SRT01 JUMP IF NULL SECOND ARG
JSR GTNVR GET VRBLK PTR FOR IT
ERR 237,ERRONEOUS 2ND ARG IN SORT/RSORT OF VECTOR
MOV XR,SRTDF STORE DATATYPE FIELD NAME VRBLK
*
* COMPUTE N AND OFFSET TO ITEM A(0) IN VECTOR CASE
*
SRT01 MOV *VCLEN,WC OFFSET TO A(0)
MOV *VCVLS,WB OFFSET TO FIRST ITEM
MOV VCLEN(XL),WA GET BLOCK LENGTH
SUB *VCSI$,WA GET NO. OF ENTRIES, N (IN BAUS)
BRN SRT04 MERGE
*
* HERE FOR ARRAY
*
SRT02 LDI ARDIM(XL) GET POSSIBLE DIMENSION
MFI WA CONVERT TO SHORT INTEGER
WTB WA FURTHER CONVERT TO BAUS
MOV *ARVLS,WB OFFSET TO FIRST VALUE IF ONE DIM.
MOV *ARPRO,WC OFFSET BEFORE VALUES IF ONE DIM.
BEQ ARNDM(XL),=NUM01,SRT04 JUMP IF IN FACT ONE DIMENSION
BNE ARNDM(XL),=NUM02,SRT16 FAIL UNLESS TWO DIMENSIONAL
LDI ARLB2(XL) GET LOWER BOUND 2 AS DEFAULT COLUMN
BEQ XR,=NULLS,SRT03 JUMP IF DEFAULT SECOND ARG
JSR GTINT CONVERT TO INTEGER
PPM SRT17 FAIL
LDI ICVAL(XR) GET ACTUAL INTEGER VALUE
EJC
*
* SORTA (CONTINUED)
*
* HERE WITH SORT COLUMN INDEX IN IA IN ARRAY CASE
*
SRT03 SBI ARLB2(XL) SUBTRACT LOW BOUND
IOV SRT17 FAIL IF OVERFLOW
ILT SRT17 FAIL IF BELOW LOW BOUND
SBI ARDM2(XL) CHECK AGAINST DIMENSION
IGE SRT17 FAIL IF TOO LARGE
ADI ARDM2(XL) RESTORE VALUE
MFI WA GET AS SMALL INTEGER
WTB WA OFFSET WITHIN ROW TO KEY
MOV WA,SRTOF KEEP OFFSET
LDI ARDM2(XL) SECOND DIMENSION IS ROW LENGTH
MFI WA CONVERT TO SHORT INTEGER
MOV WA,XR COPY ROW LENGTH
WTB WA CONVERT TO BAUS
MOV WA,SRTST STORE AS STRIDE
LDI ARDIM(XL) GET NUMBER OF ROWS
MFI WA AS A SHORT INTEGER
WTB WA CONVERT N TO BAUS
MOV ARLEN(XL),WC OFFSET PAST ARRAY END
SUB WA,WC ADJUST, GIVING SPACE FOR N OFFSETS
DCA WC POINT TO A(0)
MOV AROFS(XL),WB OFFSET TO WORD BEFORE FIRST ITEM
ICA WB OFFSET TO FIRST ITEM
*
* SEPARATE PRE-PROCESSING FOR ARRAYS AND VECTORS DONE.
* TO SIMPLIFY LATER KEY COMPARISONS, REMOVAL OF ANY TRBLK
* TRAP BLOCKS FROM ENTRIES IN KEY ARRAY IS EFFECTED.
*
* (XL) = 1(XS) = POINTER TO KEY ARRAY
* (XS) = POINTER TO SORT ARRAY
* WA = NUMBER OF ITEMS, N (CONVERTED TO BAUS).
* WB = OFFSET TO FIRST ITEM OF ARRAYS.
* WC = OFFSET TO A(0)
*
SRT04 BLE WA,*NUM01,SRT15 RETURN IF ONLY A SINGLE ITEM
MOV WA,SRTSN STORE NUMBER OF ITEMS (IN BAUS)
MOV WC,SRTSO STORE OFFSET TO A(0)
MOV ARLEN(XL),WC LENGTH OF ARRAY OR VEC (=VCLEN)
ADD XL,WC POINT PAST END OF ARRAY OR VECTOR
MOV WB,SRTSF STORE OFFSET TO FIRST ROW
ADD WB,XL POINT TO FIRST ITEM IN KEY ARRAY
*
* LOOP THROUGH ARRAY
*
SRT05 MOV (XL),XR GET AN ENTRY
*
* HUNT ALONG TRBLK CHAIN
*
SRT06 BNE (XR),=B$TRT,SRT07 JUMP OUT IF NOT TRBLK
MOV TRVAL(XR),XR GET VALUE FIELD
BRN SRT06 LOOP
EJC
*
* SORTA (CONTINUED)
*
* XR IS VALUE FROM END OF CHAIN
*
SRT07 MOV XR,(XL)+ STORE AS ARRAY ENTRY
BLT XL,WC,SRT05 LOOP IF NOT DONE
MOV (XS),XL GET ADRS OF SORT ARRAY
MOV SRTSF,XR INITIAL OFFSET TO FIRST KEY
MOV SRTST,WB GET STRIDE
ADD SRTSO,XL OFFSET TO A(0)
ICA XL POINT TO A(1)
MOV SRTSN,WC GET N
BTW WC CONVERT FROM BAUS
MOV WC,SRTNR STORE AS ROW COUNT
LCT WC,WC LOOP COUNTER
*
* STORE KEY OFFSETS AT TOP OF SORT ARRAY
*
SRT08 MOV XR,(XL)+ STORE AN OFFSET
ADD WB,XR BUMP OFFSET BY STRIDE
BCT WC,SRT08 LOOP THROUGH ROWS
*
* PERFORM THE SORT ON OFFSETS IN SORT ARRAY.
*
* (SRTSN) NUMBER OF ITEMS TO SORT, N (BAUS)
* (SRTSO) OFFSET TO A(0)
*
SRT09 MOV SRTSN,WA GET N
MOV SRTNR,WC GET NUMBER OF ROWS
RSH WC,1 I = N / 2 (WC=I, INDEX INTO ARRAY)
WTB WC CONVERT BACK TO BAUS
*
* LOOP TO FORM INITIAL HEAP
*
SRT10 JSR SORTH SORTH(I,N)
DCA WC I = I - 1
BNZ WC,SRT10 LOOP IF I GT 0
MOV WA,WC I = N
*
* SORTING LOOP. AT THIS POINT, A(1) IS THE LARGEST
* ITEM, SINCE ALGORITHM INITIALISES IT AS, AND THEN MAINTAINS
* IT AS, ROOT OF TREE.
*
SRT11 DCA WC I = I - 1 (N - 1 INITIALLY)
BZE WC,SRT12 JUMP IF DONE
MOV (XS),XR GET SORT ARRAY ADDRESS
ADD SRTSO,XR POINT TO A(0)
MOV XR,XL A(0) ADDRESS
ADD WC,XL A(I) ADDRESS
MOV 1(XL),WB COPY A(I+1)
MOV 1(XR),1(XL) MOVE A(1) TO A(I+1)
MOV WB,1(XR) COMPLETE EXCHANGE OF A(1), A(I+1)
MOV WC,WA N = I FOR SORTH
MOV *NUM01,WC I = 1 FOR SORTH
JSR SORTH SORTH(1,N)
MOV WA,WC RESTORE WC
BRN SRT11 LOOP
EJC
*
* SORTA (CONTINUED)
*
* OFFSETS HAVE BEEN PERMUTED INTO REQUIRED ORDER BY SORT.
* COPY ARRAY ELEMENTS OVER THEM.
*
SRT12 MOV (XS),XL BASE ADRS OF KEY ARRAY
MOV XL,WC COPY IT
ADD SRTSO,WC OFFSET OF A(0)
ADD SRTSF,XL ADRS OF FIRST ROW OF SORT ARRAY
MOV SRTST,WB GET STRIDE
BTW WB CONVERT TO WORDS
*
* COPYING LOOP FOR SUCCESSIVE ITEMS. SORTED OFFSETS ARE
* HELD AT END OF SORT ARRAY.
*
SRT13 ICA WC ADRS OF NEXT OF SORTED OFFSETS
MOV WC,XR COPY IT FOR ACCESS
MOV (XR),XR GET OFFSET
ADD 1(XS),XR ADD KEY ARRAY BASE ADRS
LCT WA,WB GET COUNT OF WORDS IN ROW
*
* COPY A COMPLETE ROW
*
SRT14 MOV (XR)+,(XL)+ MOVE A WORD
BCT WA,SRT14 LOOP
DCV SRTNR DECREMENT ROW COUNT
BNZ SRTNR,SRT13 REPEAT TILL ALL ROWS DONE
*
* RETURN POINT
*
SRT15 MOV (XS)+,XR POP RESULT ARRAY PTR
ICA XS POP KEY ARRAY PTR
ZER R$SXL CLEAR JUNK
ZER R$SXR CLEAR JUNK
EXI RETURN
*
* ERROR POINT
*
SRT16 ERB 238,SORT/RSORT 1ST ARG NOT SUITABLE ARRAY OR TABLE
SRT17 ERB 239,SORT/RSORT 2ND ARG OUT OF RANGE OR NON-INTEGER
*
* SOFT FAIL RETURN
*
SRT18 EXI 1 RETURN
ENP END PROCUDURE SORTA
EJC
*
* SORTC -- COMPARE SORT KEYS
*
* COMPARE TWO SORT KEYS GIVEN THEIR OFFSETS. IF
* EQUAL, COMPARE KEY OFFSETS TO GIVE STABLE SORT.
* NOTE THAT IF SRTSR IS NON-ZERO (REQUEST FOR REVERSE
* SORT), THE QUOTED RETURNS ARE INVERTED.
* FOR OBJECTS OF DIFFERING DATATYPES, THE ENTRY POINT
* IDENTIFICATIONS ARE COMPARED.
*
* (XL) BASE ADRS FOR KEYS
* (WA) OFFSET TO KEY 1 ITEM
* (WB) OFFSET TO KEY 2 ITEM
* (SRTSR) ZERO/NON-ZERO FOR SORT/RSORT
* (SRTOF) OFFSET WITHIN ROW TO COMPARANDS
* JSR SORTC CALL TO COMPARE KEYS
* PPM LOC KEY1 LESS THAN KEY2
* NORMAL RETURN, KEY1 GT THAN KEY2
* (XL,XR,WA,WB) DESTROYED
*
SORTC PRC E,1 ENTRY POINT
MOV WA,SRTS1 SAVE OFFSET 1
MOV WB,SRTS2 SAVE OFFSET 2
MOV WC,SRTSC SAVE WC
ADD SRTOF,XL ADD OFFSET TO COMPARAND FIELD
MOV XL,XR COPY BASE + OFFSET
ADD WA,XL ADD KEY1 OFFSET
ADD WB,XR ADD KEY2 OFFSET
MOV (XL),XL GET KEY1
MOV (XR),XR GET KEY2
BNE SRTDF,=NULLS,SRC11 JUMP IF DATATYPE FIELD NAME USED
EJC
*
* SORTC (CONTINUED)
*
* MERGE AFTER DEALING WITH FIELD NAME. TRY FOR STRINGS.
*
SRC01 MOV (XL),WC GET TYPE CODE
BNE WC,(XR),SRC02 SKIP IF NOT SAME DATATYPE
BEQ WC,=B$SCL,SRC09 JUMP IF BOTH STRINGS
*
* NOW TRY FOR NUMERIC
*
SRC02 MOV XL,R$SXL KEEP ARG1
MOV XR,R$SXR KEEP ARG2
MOV XL,-(XS) STACK
MOV XR,-(XS) ARGS
JSR ACOMP COMPARE OBJECTS
PPM SRC10 NOT NUMERIC
PPM SRC10 NOT NUMERIC
PPM SRC03 KEY1 LESS
PPM SRC08 KEYS EQUAL
PPM SRC05 KEY1 GREATER
*
* RETURN IF KEY1 SMALLER (SORT), GREATER (RSORT)
*
SRC03 BNZ SRTSR,SRC06 JUMP IF RSORT
*
SRC04 MOV SRTSC,WC RESTORE WC
EXI 1 RETURN
*
* RETURN IF KEY1 GREATER (SORT), SMALLER (RSORT)
*
SRC05 BNZ SRTSR,SRC04 JUMP IF RSORT
*
SRC06 MOV SRTSC,WC RESTORE WC
EXI RETURN
*
* KEYS ARE OF SAME DATATYPE
*
SRC07 BLT XL,XR,SRC03 ITEM FIRST CREATED IS LESS
BGT XL,XR,SRC05 ADDRESSES RISE IN ORDER OF CREATION
*
* DROP THROUGH OR MERGE FOR IDENTICAL OR EQUAL OBJECTS
*
SRC08 BLT SRTS1,SRTS2,SRC04 TEST OFFSETS OR KEY ADDRSS INSTEAD
BRN SRC06 OFFSET 1 GREATER
EJC
*
* SORTC (CONTINUED)
*
* STRINGS
*
SRC09 MOV XL,-(XS) STACK
MOV XR,-(XS) ARGS
JSR LCOMP COMPARE OBJECTS
PPM CANT
PPM FAIL
PPM SRC03 KEY1 LESS
PPM SRC08 KEYS EQUAL
PPM SRC05 KEY1 GREATER
*
* ARITHMETIC COMPARISON FAILED - RECOVER ARGS
*
SRC10 MOV R$SXL,XL GET ARG1
MOV R$SXR,XR GET ARG2
MOV (XL),WC GET TYPE OF KEY1
BEQ WC,(XR),SRC07 JUMP IF KEYS OF SAME TYPE
MOV WC,XL GET BLOCK TYPE WORD
MOV (XR),XR GET BLOCK TYPE WORD
LEI XL ENTRY POINT ID FOR KEY1
LEI XR ENTRY POINT ID FOR KEY2
BGT XL,XR,SRC05 JUMP IF KEY1 GT KEY2
BRN SRC03 KEY1 LT KEY2
*
* DATATYPE FIELD NAME USED
*
SRC11 JSR SORTF CALL ROUTINE TO FIND FIELD 1
MOV XL,-(XS) STACK ITEM POINTER
MOV XR,XL GET KEY2
JSR SORTF FIND FIELD 2
MOV XL,XR PLACE AS KEY2
MOV (XS)+,XL RECOVER KEY1
BRN SRC01 MERGE
ENP PROCEDURE SORTC
EJC
*
* SORTF -- FIND FIELD FOR SORTC
*
* ROUTINE USED BY SORTC TO OBTAIN ITEM CORRESPONDING
* TO A GIVEN FIELD NAME, IF THIS EXISTS, IN A PROGRAMMER
* DEFINED OBJECT PASSED AS ARGUMENT.
* IF SUCH A MATCH OCCURS, RECORD IS KEPT OF DATATYPE
* NAME, FIELD NAME AND OFFSET TO FIELD IN ORDER TO
* SHORT-CIRCUIT LATER SEARCHES ON SAME TYPE. NOTE THAT
* DFBLKS ARE STORED IN STATIC AND HENCE CANNOT BE MOVED.
*
* (SRTDF) VRBLK POINTER OF FIELD NAME
* (XL) POSSIBLE PDBLK POINTER
* JSR SORTF CALL TO SEARCH FOR FIELD NAME
* (XL) ITEM FOUND OR ORIGINAL PDBLK PTR
* (WC) DESTROYED
*
SORTF PRC E,0 ENTRY POINT
BNE (XL),=B$PDT,SRTF3 RETURN IF NOT PDBLK
MOV XR,-(XS) KEEP XR
MOV SRTFD,XR GET POSSIBLE FORMER DFBLK PTR
BZE XR,SRTF4 JUMP IF NOT
BNE XR,PDDFP(XL),SRTF4 JUMP IF NOT RIGHT DATATYPE
BNE SRTDF,SRTFF,SRTF4 JUMP IF NOT RIGHT FIELD NAME
ADD SRTFO,XL ADD OFFSET TO REQUIRED FIELD
*
* HERE WITH XL POINTING TO FOUND FIELD
*
SRTF1 MOV (XL),XL GET ITEM FROM FIELD
*
* RETURN POINT
*
SRTF2 MOV (XS)+,XR RESTORE XR
*
SRTF3 EXI RETURN
EJC
*
* SORTF (CONTINUED)
*
* CONDUCT A SEARCH
*
SRTF4 MOV XL,XR COPY ORIGINAL POINTER
MOV PDDFP(XR),XR POINT TO DFBLK
MOV XR,SRTFD KEEP A COPY
MOV FARGS(XR),WC GET NUMBER OF FIELDS
WTB WC CONVERT TO BAUS
ADD DFLEN(XR),XR POINT PAST LAST FIELD
*
* LOOP TO FIND NAME IN PDFBLK
*
SRTF5 DCA WC COUNT DOWN
DCA XR POINT IN FRONT
BEQ (XR),SRTDF,SRTF6 SKIP OUT IF FOUND
BNZ WC,SRTF5 LOOP
BRN SRTF2 RETURN - NOT FOUND
*
* FOUND
*
SRTF6 MOV (XR),SRTFF KEEP FIELD NAME PTR
ADD *PDFLD,WC ADD OFFSET TO FIRST FIELD
MOV WC,SRTFO STORE AS FIELD OFFSET
ADD WC,XL POINT TO FIELD
BRN SRTF1 RETURN
ENP PROCEDURE SORTF
EJC
*
* SORTH -- HEAP ROUTINE FOR SORTA
*
* THIS ROUTINE CONSTRUCTS A HEAP FROM ELEMENTS OF ARRAY, A.
* IN THIS APPLICATION, THE ELEMENTS ARE OFFSETS TO KEYS IN
* A KEY ARRAY.
*
* (XS) POINTER TO SORT ARRAY BASE
* 1(XS) POINTER TO KEY ARRAY BASE
* (WA) MAX ARRAY INDEX, N (IN BAUS)
* (WC) OFFSET J IN A TO ROOT (IN *1 TO *N)
* JSR SORTH CALL SORTH(J,N) TO MAKE HEAP
* (XL,XR,WB) DESTROYED
*
SORTH PRC N,0 ENTRY POINT
MOV WA,SRTSN SAVE N
MOV WC,SRTWC KEEP WC
MOV (XS),XL SORT ARRAY BASE ADRS
ADD SRTSO,XL ADD OFFSET TO A(0)
ADD WC,XL POINT TO A(J)
MOV (XL),SRTRT GET OFFSET TO ROOT
ADD WC,WC DOUBLE J - CANT EXCEED N
*
* LOOP TO MOVE DOWN TREE USING DOUBLED INDEX J
*
SRH01 BGT WC,SRTSN,SRH03 DONE IF J GT N
BEQ WC,SRTSN,SRH02 SKIP IF J EQUALS N
MOV (XS),XR SORT ARRAY BASE ADRS
MOV 1(XS),XL KEY ARRAY BASE ADRS
ADD SRTSO,XR POINT TO A(0)
ADD WC,XR ADRS OF A(J)
MOV 1(XR),WA GET A(J+1)
MOV (XR),WB GET A(J)
*
* COMPARE SONS. (WA) RIGHT SON, (WB) LEFT SON
*
JSR SORTC COMPARE KEYS - LT(A(J+1),A(J))
PPM SRH02 A(J+1) LT A(J)
ICA WC POINT TO GREATER SON, A(J+1)
EJC
*
* SORTH (CONTINUED)
*
* COMPARE ROOT WITH GREATER SON
*
SRH02 MOV 1(XS),XL KEY ARRAY BASE ADRS
MOV (XS),XR GET SORT ARRAY ADDRESS
ADD SRTSO,XR ADRS OF A(0)
MOV XR,WB COPY THIS ADRS
ADD WC,XR ADRS OF GREATER SON, A(J)
MOV (XR),WA GET A(J)
MOV WB,XR POINT BACK TO A(0)
MOV SRTRT,WB GET ROOT
JSR SORTC COMPARE THEM - LT(A(J),ROOT)
PPM SRH03 FATHER EXCEEDS SONS - DONE
MOV (XS),XR GET SORT ARRAY ADRS
ADD SRTSO,XR POINT TO A(0)
MOV XR,XL COPY IT
MOV WC,WA COPY J
BTW WC CONVERT TO WORDS
RSH WC,1 GET J/2
WTB WC CONVERT BACK TO BAUS
ADD WA,XL POINT TO A(J)
ADD WC,XR ADRS OF A(J/2)
MOV (XL),(XR) A(J/2) = A(J)
MOV WA,WC RECOVER J
AOV WC,WC,SRH03 J = J*2. DONE IF TOO BIG
BRN SRH01 LOOP
*
* FINISH BY COPYING ROOT OFFSET BACK INTO ARRAY
*
SRH03 BTW WC CONVERT TO WORDS
RSH WC,1 J = J/2
WTB WC CONVERT BACK TO BAUS
MOV (XS),XR SORT ARRAY ADRS
ADD SRTSO,XR ADRS OF A(0)
ADD WC,XR ADRS OF A(J/2)
MOV SRTRT,(XR) A(J/2) = ROOT
MOV SRTSN,WA RESTORE WA
MOV SRTWC,WC RESTORE WC
EXI RETURN
ENP END PROCEDURE SORTH
EJC
.FI
EJC
*
* TFIND -- LOCATE TABLE ELEMENT
*
* (XR) SUBSCRIPT VALUE FOR ELEMENT
* (XL) POINTER TO TABLE
* (WB) ZERO BY VALUE, NON-ZERO BY NAME
* JSR TFIND CALL TO LOCATE ELEMENT
* PPM LOC TRANSFER LOCATION IF ACCESS FAILS
* (XR) ELEMENT VALUE (IF BY VALUE)
* (XR) DESTROYED (IF BY NAME)
* (XL,WA) TEBLK NAME (IF BY NAME)
* (XL,WA) DESTROYED (IF BY VALUE)
* (WC,RA) DESTROYED
*
* NOTE THAT IF A CALL BY VALUE SPECIFIES A NON-EXISTENT
* SUBSCRIPT, NULL IS RETURNED WITHOUT BUILDING A NEW TEBLK.
*
TFIND PRC E,1 ENTRY POINT
MOV WB,-(XS) SAVE NAME/VALUE INDICATOR
MOV XR,-(XS) SAVE SUBSCRIPT VALUE
MOV XL,-(XS) SAVE TABLE POINTER
MOV TBLEN(XL),WA LOAD LENGTH OF TBBLK
BTW WA CONVERT TO WORD COUNT
SUB =TBBUK,WA GET NUMBER OF BUCKETS
MTI WA CONVERT TO INTEGER VALUE
STI TFNSI SAVE FOR LATER
MOV (XR),XL LOAD FIRST WORD OF SUBSCRIPT
LEI XL LOAD BLOCK ENTRY ID (BL$XX)
BSW XL,BL$$D,TFN00 SWITCH ON BLOCK TYPE
IFF BL$IC,TFN02 JUMP IF INTEGER
.IF .CNRA
.ELSE
IFF BL$RC,TFN02 REAL
.FI
IFF BL$P0,TFN03 JUMP IF PATTERN
IFF BL$P1,TFN03 JUMP IF PATTERN
IFF BL$P2,TFN03 JUMP IF PATTERN
IFF BL$NM,TFN04 JUMP IF NAME
IFF BL$SC,TFN05 JUMP IF STRING
ESW END SWITCH ON BLOCK TYPE
*
* HERE FOR BLOCKS FOR WHICH WE USE THE SECOND WORD OF THE
* BLOCK AS THE HASH SOURCE (SEE BLOCK FORMATS FOR DETAILS).
*
TFN00 MOV 1(XR),WA LOAD SECOND WORD
*
* MERGE HERE WITH ONE WORD HASH SOURCE IN WA
*
TFN01 MTI WA CONVERT TO INTEGER
BRN TFN06 JUMP TO MERGE
EJC
*
* TFIND (CONTINUED)
*
* HERE FOR INTEGER OR REAL
* POSSIBILITY OF OVERFLOW EXIST ON TWOS COMPLEMENT
* MACHINE IF HASH SOURCE IS MOST NEGATIVE INTEGER OR IS
* A REAL HAVING THE SAME BIT PATTERN.
*
TFN02 LDI 1(XR) LOAD VALUE AS HASH SOURCE
IGE TFN06 OK IF POSITIVE OR ZERO
NGI MAKE POSITIVE
IOV TFN06 CLEAR POSSIBLE OVERFLOW
BRN TFN06 MERGE
*
* FOR PATTERN, USE FIRST WORD (PCODE) AS SOURCE
*
TFN03 MOV (XR),WA LOAD FIRST WORD AS HASH SOURCE
BRN TFN01 MERGE BACK
*
* FOR NAME, USE OFFSET AS HASH SOURCE
*
TFN04 MOV NMOFS(XR),WA LOAD OFFSET AS HASH SOURCE
BRN TFN01 MERGE BACK
*
* HERE FOR STRING
*
TFN05 JSR HASHS CALL ROUTINE TO COMPUTE HASH
*
* MERGE HERE WITH HASH SOURCE IN (IA)
*
TFN06 RMI TFNSI COMPUTE HASH INDEX BY REMAINDERING
MFI WC GET AS ONE WORD INTEGER
WTB WC CONVERT TO BAU OFFSET
MOV (XS),XL GET TABLE PTR AGAIN
ADD WC,XL POINT TO PROPER BUCKET
MOV TBBUK(XL),XR LOAD FIRST TEBLK POINTER
BEQ XR,(XS),TFN10 JUMP IF NO TEBLKS ON CHAIN
*
* LOOP THROUGH TEBLKS ON HASH CHAIN
*
TFN07 MOV XR,WB SAVE TEBLK POINTER
MOV TESUB(XR),XR LOAD SUBSCRIPT VALUE
MOV 1(XS),XL LOAD INPUT ARGUMENT SUBSCRIPT VAL
JSR IDENT COMPARE THEM
PPM TFN08 JUMP IF EQUAL (IDENT)
*
* HERE IF NO MATCH WITH THAT TEBLK
*
MOV WB,XL RESTORE TEBLK POINTER
MOV TENXT(XL),XR POINT TO NEXT TEBLK ON CHAIN
BNE XR,(XS),TFN07 JUMP IF THERE IS ONE
*
* HERE IF NO MATCH WITH ANY TEBLK ON CHAIN
*
MOV *TENXT,WC SET OFFSET TO LINK FIELD (XL BASE)
BRN TFN11 JUMP TO MERGE
EJC
*
* TFIND (CONTINUED)
*
* HERE WE HAVE FOUND A MATCHING ELEMENT
*
TFN08 MOV WB,XL RESTORE TEBLK POINTER
MOV *TEVAL,WA SET TEBLK NAME OFFSET
MOV 2(XS),WB RESTORE NAME/VALUE INDICATOR
BNZ WB,TFN09 JUMP IF CALLED BY NAME
JSR ACESS ELSE GET VALUE
PPM TFN12 JUMP IF REFERENCE FAILS
ZER WB RESTORE NAME/VALUE INDICATOR
*
* COMMON EXIT FOR ENTRY FOUND
*
TFN09 ADD *NUM03,XS POP STACK ENTRIES
EXI RETURN TO TFIND CALLER
*
* HERE IF NO TEBLKS ON THE HASH CHAIN
*
TFN10 ADD *TBBUK,WC GET OFFSET TO BUCKET PTR
MOV (XS),XL SET TBBLK PTR AS BASE
*
* MERGE HERE WITH (XL,WC) BASE,OFFSET OF FINAL LINK
*
TFN11 MOV (XS),XR TBBLK POINTER
MOV TBINV(XR),XR LOAD DEFAULT VALUE IN CASE
MOV 2(XS),WB LOAD NAME/VALUE INDICATOR
BZE WB,TFN09 EXIT WITH DEFAULT IF VALUE CALL
MOV XR,WB COPY DEFAULT VALUE
*
* HERE WE MUST BUILD A NEW TEBLK
*
MOV *TESI$,WA SET SIZE OF TEBLK
JSR ALLOC ALLOCATE TEBLK
ADD WC,XL POINT TO HASH LINK
MOV XR,(XL) LINK NEW TEBLK AT END OF CHAIN
MOV =B$TET,(XR) STORE TYPE WORD
MOV WB,TEVAL(XR) SET DEFAULT AS INITIAL VALUE
MOV (XS)+,TENXT(XR) SET TBBLK PTR TO MARK END OF CHAIN
MOV (XS)+,TESUB(XR) STORE SUBSCRIPT VALUE
MOV (XS)+,WB RESTORE NAME/VALUE INDICATOR
MOV XR,XL COPY TEBLK POINTER (NAME BASE)
MOV *TEVAL,WA SET OFFSET
EXI RETURN TO CALLER WITH NEW TEBLK
*
* ACESS FAIL RETURN
*
TFN12 EXI 1 ALTERNATIVE RETURN
ENP END PROCEDURE TFIND
EJC
*
* TRACE -- SET/RESET A TRACE ASSOCIATION
*
* THIS PROCEDURE IS SHARED BY TRACE AND STOPTR TO
* EITHER INITIATE OR STOP A TRACE RESPECTIVELY.
*
* (XL) TRBLK PTR (TRACE) OR ZERO (STOPTR)
* 1(XS) FIRST ARGUMENT (NAME)
* 0(XS) SECOND ARGUMENT (TRACE TYPE)
* JSR TRACE CALL TO SET/RESET TRACE
* PPM LOC TRANSFER LOC IF 1ST ARG IS BAD NAME
* PPM LOC TRANSFER LOC IF 2ND ARG IS BAD TYPE
* PPM LOC FAIL STOPTR IF NON-EXISTENT TRACE
* (XS) POPPED
* (XL,XR,WA,WB,WC,IA) DESTROYED
*
TRACE PRC N,3 ENTRY POINT
JSR GTSTG GET TRACE TYPE STRING
PPM TRC15 JUMP IF NOT STRING
PLC XR ELSE POINT TO STRING
LCH WA,(XR) LOAD FIRST CHARACTER
.IF .CASL
BLT WA,=CH$$A,TRC00 SKIP IF NOT LOWER CASE
SUB =DFA$A,WA CONVERT LOWER TO UPPER CASE
*
* HERE WITH UPPER CASE TRACE TYPE CODE
*
TRC00 MOV (XS),XR LOAD NAME ARGUMENT
.ELSE
MOV (XS),XR LOAD NAME ARGUMENT
.FI
MOV XL,(XS) STACK TRBLK PTR OR ZERO
MOV =TRTAC,WC SET TRTYP FOR ACCESS TRACE
BEQ WA,=CH$LA,TRC10 JUMP IF A (ACCESS)
MOV =TRTVL,WC SET TRTYP FOR VALUE TRACE
BEQ WA,=CH$LV,TRC10 JUMP IF V (VALUE)
BEQ WA,=CH$BL,TRC10 JUMP IF BLANK (VALUE)
*
* HERE FOR L,K,F,C,R
*
BEQ WA,=CH$LF,TRC01 JUMP IF F (FUNCTION)
BEQ WA,=CH$LR,TRC01 JUMP IF R (RETURN)
BEQ WA,=CH$LL,TRC03 JUMP IF L (LABEL)
BEQ WA,=CH$LK,TRC06 JUMP IF K (KEYWORD)
BNE WA,=CH$LC,TRC15 ELSE ERROR IF NOT C (CALL)
*
* HERE FOR F,C,R
*
TRC01 JSR GTNVR POINT TO VRBLK FOR NAME
PPM TRC16 JUMP IF BAD NAME
ICA XS POP STACK
MOV VRFNC(XR),XR POINT TO FUNCTION BLOCK
BNE (XR),=B$PFC,TRC17 ERROR IF NOT PROGRAM FUNCTION
MOV XL,WB COPY TRBLK PTR OR 0
BEQ WA,=CH$LR,TRC02 JUMP IF R (RETURN)
EJC
*
* TRACE (CONTINUED)
*
* HERE FOR F,C TO SET/RESET CALL TRACE
*
ORB PFCTR(XR),WB STOPTR FAIL CHECK
MOV XL,PFCTR(XR) SET/RESET CALL TRACE
BEQ WA,=CH$LC,TRC11 RETURN IF LETTER C
*
* HERE FOR F,R TO SET/RESET RETURN TRACE
*
TRC02 ORB PFRTR(XR),WB STOPTR FAIL CHECK
MOV XL,PFRTR(XR) SET/RESET RETURN TRACE
BRN TRC11 RETURN
*
* HERE FOR L TO SET/RESET LABEL TRACE
*
TRC03 JSR GTNVR POINT TO VRBLK
PPM TRC16 JUMP IF BAD NAME
MOV (XS)+,WB GET TRBLK OR ZERO
MOV VRLBL(XR),XL LOAD LABEL POINTER
BNE (XL),=B$TRT,TRC04 JUMP IF NO OLD TRACE
MOV TRLBL(XL),XL ELSE DELETE OLD TRACE ASSOCIATION
BRN TRCA4 MERGE
*
* HERE WITH OLD LABEL TRACE ASSOCIATION DELETED
*
TRC04 BZE WB,TRC12 FAIL IF STOPTR OF UNTRACED LABEL
*
* TEST FOR UNDEFINED LABEL
*
TRCA4 BEQ XL,=STNDL,TRC17 ERROR IF UNDEFINED LABEL
BZE WB,TRC05 JUMP IF STOPTR CASE
MOV WB,VRLBL(XR) ELSE SET NEW TRBLK POINTER
MOV =B$VRT,VRTRA(XR) SET LABEL TRACE ROUTINE ADDRESS
MOV WB,XR COPY TRBLK POINTER
MOV XL,TRLBL(XR) STORE REAL LABEL IN TRBLK
EXI RETURN
*
* HERE FOR STOPTR CASE FOR LABEL
*
TRC05 MOV XL,VRLBL(XR) STORE LABEL PTR BACK IN VRBLK
MOV =B$VRG,VRTRA(XR) STORE NORMAL TRANSFER ADDRESS
EXI RETURN
EJC
*
* TRACE (CONTINUED)
*
* HERE FOR K (KEYWORD)
*
TRC06 JSR GTNVR POINT TO VRBLK
PPM TRC16 ERROR IF NOT NATURAL VAR
BNZ VRLEN(XR),TRC16 ERROR IF NOT SYSTEM VAR
ICA XS POP STACK
BZE XL,TRC07 JUMP IF STOPTR CASE
MOV XR,TRKVR(XL) STORE VRBLK PTR IN TRBLK FOR KTREX
*
* MERGE HERE WITH TRBLK SET UP IN XL (OR ZERO)
*
TRC07 MOV VRSVP(XR),XR POINT TO SVBLK
MOV XL,WB COPY TRBLK PR OR 0
BEQ XR,=V$ERT,TRC08 JUMP IF ERRTYPE
BEQ XR,=V$STC,TRC09 JUMP IF STCOUNT
BNE XR,=V$FNC,TRC17 ELSE ERROR IF NOT FNCLEVEL
*
* FNCLEVEL
*
ORB R$FNC,WB STOPTR FAIL CHECK
MOV XL,R$FNC SET/RESET FNCLEVEL TRACE
BRN TRC11 RETURN
*
* ERRTYPE
*
TRC08 ORB R$ERT,WB STOPTR FAIL CHECK
MOV XL,R$ERT SET/RESET ERRTYPE TRACE
BRN TRC11 RETURN
*
* STCOUNT
*
TRC09 ORB R$STC,WB STOPTR FAIL CHECK
MOV XL,R$STC SET/RESET STCOUNT TRACE
BRN TRC11 RETURN
EJC
*
* TRACE (CONTINUED)
*
* A,V MERGE HERE WITH TRTYP VALUE IN WC
*
TRC10 JSR GTVAR LOCATE VARIABLE
PPM TRC16 ERROR IF NOT APPROPRIATE NAME
MOV (XS)+,XR GET NEW TRBLK PTR AGAIN
MOV WC,WB COPY TRACE TYPE
JSR TRCHN UPDATE TRACE CHAIN
PPM TRC12 FAIL
EXI RETURN
*
* RETURN AFTER CHECKING STOPTR FAIL CONDITION (WB = 0)
*
TRC11 ZRB WB,TRC12 FAIL IF NECESSARY
EXI ELSE RETURN
*
* FAIL STOPTR
*
TRC12 EXI 3 FAIL RETURN
*
* HERE FOR BAD TRACE TYPE
*
TRC15 EXI 2 TAKE BAD TRACE TYPE ERROR EXIT
*
* POP STACK BEFORE FAILING
*
TRC16 ICA XS POP STACK
*
* HERE FOR BAD NAME ARGUMENT
*
TRC17 EXI 1 TAKE BAD NAME ERROR EXIT
ENP END PROCEDURE TRACE
EJC
*
* TRBLD -- BUILD TRBLK
*
* TRBLK IS USED BY THE INPUT, OUTPUT AND TRACE FUNCTIONS
* TO CONSTRUCT A TRBLK (TRAP BLOCK)
*
* (XR) TRTAG OR TRTER
* (XL) TRFNC OR TRTRI
* (WB) TRTYP
* JSR TRBLD CALL TO BUILD TRBLK
* (XR) POINTER TO TRBLK
* (WA) DESTROYED
*
TRBLD PRC E,0 ENTRY POINT
MOV XR,-(XS) STACK TRTAG (OR TRFNM)
MOV *TRSI$,WA SET SIZE OF TRBLK
JSR ALLOC ALLOCATE TRBLK
MOV =B$TRT,(XR) STORE FIRST WORD
MOV XL,TRFNC(XR) STORE TRFNC (OR TRTRI)
MOV (XS)+,TRTAG(XR) STORE TRTAG (OR TRTER)
MOV WB,TRTYP(XR) STORE TYPE
MOV =NULLS,TRVAL(XR) FOR NOW, A NULL VALUE
EXI RETURN TO CALLER
ENP END PROCEDURE TRBLD
EJC
*
* TRCHN -- UPDATE TRACE BLOCK CHAIN
*
* CALLED WHEN A TRACE BLOCK CHAIN IS TO BE UPDATED BY
* ADDITION OR REMOVAL OF A TRBLK.
* IF A TRBLK OF THE SAME TYPE AS AN ADDITION IS ALREADY
* PRESENT IT IS DELETED. THE TRTAG FIELD OF ANY DELETED
* TRBLK IS CLEARED AS REQUIRED BY S$ENF.
*
* (XL,WA) POINTER, OFFSET TO TRACED VARIABLE
* (XR) PTR TO NEW TRBLK OR 0 FOR REMOVAL
* (WB) TRACE TYPE (TRTYP)
* JSR TRCHN CALL TO UPDATE TRACE CHAIN
* PPM LOC NO TRACE BLK OF REQD DELETION TYPE
* (WA,WC) DESTROYED
*
TRCHN PRC E,1 ENTRY POINT
ADD XL,WA KEEP POINTER TO TRACED LOCATION
MOV WA,XL COPY POINTER
SUB *TRNXT,XL ADJUST OFFSET BEFORE ENTERING LOOP
MOV XR,WC COPY TRBLK PTR
*
* LOOP TO FIND TRACE BLOCK
*
TRCH1 MOV XL,XR COPY SO XR POINTS TO PREDECESSOR
MOV TRNXT(XL),XL POINT TO POSSIBLE TRACE BLOCK
BNE (XL),=B$TRT,TRCH2 SKIP OUT AT CHAIN END
BLT WB,TRTYP(XL),TRCH2 SKIP IF TOO FAR OUT ON CHAIN
BNE WB,TRTYP(XL),TRCH1 LOOP UNLESS TYPE MATCHES
MOV TRNXT(XL),TRNXT(XR) REMOVE LINK TO OLD TRBLK
ZER TRTAG(XL) CLEAR IOTAG FIELD OF DELETED BLOCK
BZE WC,TRCH3 DONE IF NO NEW TRBLK
*
* OLD TRBLK REMOVED AND/OR END OF CHAIN REACHED
*
TRCH2 BZE WC,TRCH4 FAIL IF REQD BLOCK TYPE NOT FOUND
MOV WC,XL POINT TO NEW TRBLK
MOV TRNXT(XR),TRNXT(XL) ATTACH TAIL OF CHAIN TO IT
MOV WC,TRNXT(XR) LINK NEW BLOCK IN
MOV WB,TRTYP(XL) ENSURE TRTYP FIELD SET UP
*
* UPDATE ACCESS FIELDS OF NAME IF IT IS A VRBLK
*
TRCH3 MOV WA,XR POINT TO VBL
SUB *VRVAL,XR ADJUST TO POSSIBLE VRBLK NAME BASE
JSR SETVR UPDATE ACCESS FIELDS
MOV WA,XL RECOVER XL
MOV WC,XR RECOVER XR
EXI RETURN TO CALLER
*
* FAIL RETURN
*
TRCH4 MOV WA,XL RECOVER XL
MOV WC,XR RECOVER XR
EXI 1 FAIL
ENP END PROCEDURE TRCHN
EJC
*
* TRIMR -- TRIM TRAILING BLANKS
*
* TRIMR IS PASSED A POINTER TO AN SCBLK WHICH MUST BE THE
* LAST BLOCK IN DYNAMIC STORAGE. TRAILING BLANKS ARE
* TRIMMED OFF AND THE DYNAMIC STORAGE POINTER RESET TO
* THE END OF THE (POSSIBLY) SHORTENED BLOCK.
*
* (WB) NON-ZERO TO TRIM TRAILING BLANKS
* (XR) POINTER TO STRING TO TRIM
* JSR TRIMR CALL TO TRIM STRING
* (XR) POINTER TO TRIMMED STRING
* (XL,WA,WB,WC) DESTROYED
*
* THE CALL WITH WB ZERO STILL PERFORMS THE END ZERO PAD
* AND DNAMP READJUSTMENT. IT IS USED FROM ACESS IF KVTRM=0.
*
TRIMR PRC E,0 ENTRY POINT
MOV XR,XL COPY STRING POINTER
MOV SCLEN(XR),WA LOAD STRING LENGTH
BZE WA,TRIM2 JUMP IF NULL INPUT
PLC XL,WA ELSE POINT PAST LAST CHARACTER
BZE WB,TRIM3 JUMP IF NO TRIM
MOV =CH$BL,WC LOAD BLANK CHARACTER
*
* LOOP THROUGH CHARACTERS FROM RIGHT TO LEFT
*
TRIM0 LCH WB,-(XL) LOAD NEXT CHARACTER
.IF .CAHT
BEQ WB,=CH$HT,TRIM1 JUMP IF HORIZONTAL TAB
.FI
BNE WB,WC,TRIM3 JUMP IF NON-BLANK FOUND
TRIM1 DCV WA ELSE DECREMENT CHARACTER COUNT
BNZ WA,TRIM0 LOOP BACK IF MORE TO CHECK
*
* HERE IF RESULT IS NULL (NULL OR ALL-BLANK INPUT)
*
TRIM2 MOV XR,DNAMP WIPE OUT INPUT STRING BLOCK
MOV =NULLS,XR LOAD NULL RESULT
BRN TRIM5 MERGE TO EXIT
EJC
*
* TRIMR (CONTINUED)
*
* HERE WITH NON-BLANK FOUND (MERGE FOR NO TRIM)
*
TRIM3 MOV WA,SCLEN(XR) SET NEW LENGTH
MOV XR,XL COPY STRING POINTER
PSC XL,WA READY FOR STORING ZEROES
CTB WA,SCHAR GET LENGTH OF BLOCK IN BAUS
ADD XR,WA POINT PAST NEW BLOCK
MOV WA,DNAMP SET NEW TOP OF STORAGE POINTER
LCT WA,=CFP$C GET COUNT OF CHARS IN WORD
ZER WC SET ZERO CHAR
*
* LOOP TO ZERO PAD LAST WORD OF CHARACTERS
*
TRIM4 SCH WC,(XL)+ STORE ZERO CHARACTER
BCT WA,TRIM4 LOOP BACK TILL ALL STORED
CSC XL COMPLETE STORE CHARACTERS
*
* COMMON EXIT POINT
*
TRIM5 ZER XL CLEAR GARBAGE XL POINTER
EXI RETURN TO CALLER
ENP END PROCEDURE TRIMR
EJC
*
* TRXEQ -- EXECUTE FUNCTION TYPE TRACE
*
* TRXEQ IS USED TO EXECUTE A TRACE WHEN A FOURTH ARGUMENT
* HAS BEEN SUPPLIED. TRACE HAS ALREADY BEEN DECREMENTED.
*
* (XR) POINTER TO TRBLK
* (XL,WA) NAME BASE,OFFSET FOR VARIABLE
* JSR TRXEQ CALL TO EXECUTE TRACE
* (WB,WC,RA) DESTROYED
*
* THE FOLLOWING STACK ENTRIES ARE MADE BEFORE PASSING
* CONTROL TO THE TRACE FUNCTION USING THE CFUNC ROUTINE.
*
* TRXEQ RETURN POINT WORD(S)
* SAVED VALUE OF TRACE KEYWORD
* TRBLK POINTER
* NAME BASE
* NAME OFFSET
* SAVED VALUE OF R$COD
* SAVED CODE PTR (-R$COD)
* SAVED VALUE OF FLPTR
* FLPTR --------------- ZERO (DUMMY FAIL OFFSET)
* NMBLK FOR VARIABLE NAME
* XS ------------------ TRACE TAG
*
* R$COD AND THE CODE PTR ARE SET TO DUMMY VALUES WHICH
* CAUSE CONTROL TO RETURN TO THE TRXEQ PROCEDURE ON SUCCESS
* OR FAILURE (TRXEQ IGNORES A FAILURE CONDITION).
*
TRXEQ PRC R,0 ENTRY POINT (RECURSIVE)
MOV R$COD,WC LOAD CODE BLOCK POINTER
SCP WB GET CURRENT CODE POINTER
SUB WC,WB MAKE CODE POINTER INTO OFFSET
MOV KVTRA,-(XS) STACK TRACE KEYWORD VALUE
MOV XR,-(XS) STACK TRBLK POINTER
MOV XL,-(XS) STACK NAME BASE
MOV WA,-(XS) STACK NAME OFFSET
MOV WC,-(XS) STACK CODE BLOCK POINTER
MOV WB,-(XS) STACK CODE POINTER OFFSET
MOV FLPTR,-(XS) STACK OLD FAILURE POINTER
ZER -(XS) SET DUMMY FAIL OFFSET
MOV XS,FLPTR SET NEW FAILURE POINTER
ZER KVTRA RESET TRACE KEYWORD TO ZERO
MOV =TRXDC,WC LOAD NEW (DUMMY) CODE BLK POINTER
MOV WC,R$COD SET AS CODE BLOCK POINTER
LCP WC AND NEW CODE POINTER
EJC
*
* TRXEQ (CONTINUED)
*
* NOW PREPARE ARGUMENTS FOR FUNCTION
*
MOV WA,WB SAVE NAME OFFSET
MOV *NMSI$,WA LOAD NMBLK SIZE
JSR ALLOC ALLOCATE SPACE FOR NMBLK
MOV =B$NML,(XR) SET TYPE WORD
MOV XL,NMBAS(XR) STORE NAME BASE
MOV WB,NMOFS(XR) STORE NAME OFFSET
MOV 6(XS),XL RELOAD POINTER TO TRBLK
MOV XR,-(XS) STACK NMBLK POINTER (1ST ARGUMENT)
MOV TRTAG(XL),-(XS) STACK TRACE TAG (2ND ARGUMENT)
MOV TRFNC(XL),XL LOAD TRACE FUNCTION POINTER
MOV =NUM02,WA SET NUMBER OF ARGUMENTS TO TWO
BRN CFUNC JUMP TO CALL FUNCTION
*
* SEE O$TXR FOR DETAILS OF RETURN TO THIS POINT
*
TRXQR MOV FLPTR,XS POINT BACK TO OUR STACK ENTRIES
ICA XS POP OFF GARBAGE FAIL OFFSET
MOV (XS)+,FLPTR RESTORE OLD FAILURE POINTER
MOV (XS)+,WB RELOAD CODE OFFSET
MOV (XS)+,WC LOAD OLD CODE BASE POINTER
MOV WC,XR COPY CDBLK POINTER
MOV CDSTM(XR),KVSTN RESTORE STMNT NO
MOV (XS)+,WA RELOAD NAME OFFSET
MOV (XS)+,XL RELOAD NAME BASE
MOV (XS)+,XR RELOAD TRBLK POINTER
MOV (XS)+,KVTRA RESTORE TRACE KEYWORD VALUE
ADD WC,WB RECOMPUTE ABSOLUTE CODE POINTER
LCP WB RESTORE CODE POINTER
MOV WC,R$COD AND CODE BLOCK POINTER
EXI RETURN TO TRXEQ CALLER
ENP END PROCEDURE TRXEQ
EJC
*
* XSCAN -- EXECUTION FUNCTION ARGUMENT SCAN
*
* XSCAN SCANS OUT ONE TOKEN IN A PROTOTYPE ARGUMENT IN
* ARRAY,CLEAR,DATA,DEFINE,LOAD FUNCTION CALLS. XSCAN
* CALLS MUST BE PRECEDED BY A CALL TO THE INITIALIZATION
* PROCEDURE XSCNI. THE FOLLOWING VARIABLES ARE USED.
*
* R$XSC POINTER TO SCBLK FOR FUNCTION ARG
* XSOFS OFFSET (NUM CHARS SCANNED SO FAR)
*
* (WC) DELIMITER ONE (CH$XX)
* (XL) DELIMITER TWO (CH$XX)
* JSR XSCAN CALL TO SCAN NEXT ITEM
* (XR) POINTER TO SCBLK FOR TOKEN SCANNED
* (WA) COMPLETION CODE (SEE BELOW)
* (WC,XL) DESTROYED
* (XSCNB) ERROR INDICATOR - SEE 4) BELOW
*
* LEADING BLANKS AND TRAILING BLANKS POSITIONED BEFORE A
* DELIMITER OR AT THE END OF THE ARGUMENT STRING ARE
* IGNORED. OTHER BLANKS ARE ILLEGAL.
* THE SCAN STARTS FROM THE CURRENT POSITION AND CONTINUES
* UNTIL ONE OF THE FOLLOWING CONDITIONS OCCURS.
*
* 1) DELIMITER ONE IS ENCOUNTERED (WA SET TO 1)
*
* 2) DELIMITER TWO ENCOUNTERED (WA SET TO 2)
*
* 3) END OF STRING ENCOUNTERED (WA AND XSCNB SET TO 0)
*
* 4) ILLEGAL BLANK (WA 0, XSCNB NON-ZERO)
*
* THE RESULT IS A STRING CONTAINING ALL CHARACTERS SCANNED
* UP TO BUT NOT INCLUDING ANY DELIMITER CHARACTER.
* THE POINTER IS LEFT POINTING PAST THE DELIMITER.
*
* IF ONLY ONE DELIMITER IS TO BE DETECTED, DELIMITER ONE
* AND DELIMITER TWO SHOULD BE SET TO THE SAME VALUE.
*
* IN THE CASE WHERE THE END OF STRING IS ENCOUNTERED, THE
* STRING INCLUDES ALL THE CHARACTERS TO THE END OF THE
* STRING. NO FURTHER CALLS CAN BE MADE TO XSCAN UNTIL
* XSCNI IS CALLED TO INITIALIZE A NEW ARGUMENT SCAN
EJC
*
* XSCAN (CONTINUED)
*
XSCAN PRC E,0 ENTRY POINT
MOV WB,XSCWB PRESERVE WB
ZER XSCBL CLEAR COUNT OF TRAILING BLANKS
ZER XSCNB CLEAR NON-BLANK SEEN FLAG
MOV R$XSC,XR POINT TO ARGUMENT STRING
MOV SCLEN(XR),WA LOAD STRING LENGTH
MOV XSOFS,WB LOAD CURRENT OFFSET
SUB WB,WA GET NUMBER OF REMAINING CHARACTERS
BZE WA,XSCN2 JUMP IF NO CHARACTERS LEFT
PLC XR,WB POINT TO CURRENT CHARACTER
*
* LOOP TO SEARCH FOR DELIMITER
*
XSCN0 LCH WB,(XR)+ LOAD NEXT CHARACTER
BEQ WB,WC,XSCN3 JUMP IF DELIMITER ONE FOUND
BEQ WB,XL,XSCN4 JUMP IF DELIMITER TWO FOUND
BEQ WB,=CH$BL,XSCN7 SKIP IF IT IS A BLANK
.IF .CAHT
BEQ WB,=CH$HT,XSCN7 SKIP IF IT IS A TAB
.FI
BNZ XSCBL,XSCN2 FAIL CHAR AFTER TRAILING BLANK
MNZ XSCNB NOTE A NON-BLANK SEEN
*
* COUNT CHARS DONE
*
XSCN1 DCV WA DECREMENT COUNT OF CHARS LEFT
BNZ WA,XSCN0 LOOP BACK IF MORE CHARS TO GO
ZER XSCNB CLEAR ERRONEOUS BLANKS FLAG
*
* HERE FOR RUNOUT
*
XSCN2 MOV R$XSC,XL POINT TO STRING BLOCK
MOV SCLEN(XL),WA GET STRING LENGTH
MOV XSOFS,WB LOAD OFFSET
SUB WB,WA GET SUBSTRING LENGTH
SUB XSCBL,WA ADJUST FOR TRAILING BLANKS
ZER R$XSC CLEAR STRING PTR FOR COLLECTOR
ZER XSCRT SET ZERO (RUNOUT) RETURN CODE
BRN XSCN6 JUMP TO EXIT
EJC
*
* XSCAN (CONTINUED)
*
* HERE IF DELIMITER ONE FOUND
*
XSCN3 MOV =NUM01,XSCRT SET RETURN CODE
BRN XSCN5 JUMP TO MERGE
*
* HERE IF DELIMITER TWO FOUND
*
XSCN4 MOV =NUM02,XSCRT SET RETURN CODE
*
* MERGE HERE AFTER DETECTING A DELIMITER
*
XSCN5 MOV R$XSC,XL RELOAD POINTER TO STRING
MOV SCLEN(XL),WC GET ORIGINAL LENGTH OF STRING
SUB WA,WC MINUS CHARS LEFT = CHARS SCANNED
MOV WC,WA MOVE TO REG FOR SBSTR
SUB XSCBL,WA ADJUST FOR TRAILING BLANKS
MOV XSOFS,WB SET OFFSET
SUB WB,WA COMPUTE LENGTH FOR SBSTR
ICV WC ADJUST NEW CURSOR PAST DELIMITER
MOV WC,XSOFS STORE NEW OFFSET
*
* COMMON EXIT POINT
*
XSCN6 ZER XR CLEAR GARBAGE CHARACTER PTR IN XR
.IF .CASL
JSR SBSTG BUILD SUBSTRING
.ELSE
JSR SBSTR BUILD SUB-STRING
.FI
MOV XSCRT,WA LOAD RETURN CODE
MOV XSCWB,WB RESTORE WB
EXI RETURN TO XSCAN CALLER
*
* DEAL WITH BLANK
*
XSCN7 BZE XSCNB,XSCN8 SKIP IF LEADING BLANK
ICV XSCBL ELSE COUNT TRAILING BLANK
BRN XSCN1 LOOP
*
* LEADING BLANK
*
XSCN8 ICV XSOFS PUSH OFFSET PAST BLANK
BRN XSCN1 LOOP
ENP END PROCEDURE XSCAN
EJC
*
* XSCNI -- EXECUTION FUNCTION ARGUMENT SCAN
*
* XSCNI INITIALIZES THE SCAN USED FOR PROTOTYPE ARGUMENTS
* IN THE CLEAR, DEFINE, LOAD, DATA, ARRAY FUNCTIONS. SEE
* XSCAN FOR THE PROCEDURE WHICH IS USED AFTER THIS CALL.
*
* -(XS) ARGUMENT TO BE SCANNED (ON STACK)
* JSR XSCNI CALL TO SCAN ARGUMENT
* PPM LOC TRANSFER LOC IF ARG IS NOT STRING
* PPM LOC TRANSFER LOC IF ARGUMENT IS NULL
* (XS) POPPED
* (XR,R$XSC) ARGUMENT (SCBLK PTR)
* (WA) ARGUMENT LENGTH
* (IA,RA) DESTROYED
*
XSCNI PRC N,2 ENTRY POINT
JSR GTSTG FETCH ARGUMENT AS STRING
PPM XSCI1 JUMP IF NOT CONVERTIBLE
MOV XR,R$XSC ELSE STORE SCBLK PTR FOR XSCAN
ZER XSOFS SET OFFSET TO ZERO
BZE WA,XSCI2 JUMP IF NULL STRING
EXI RETURN TO XSCNI CALLER
*
* HERE IF ARGUMENT IS NOT A STRING
*
XSCI1 EXI 1 TAKE NOT-STRING ERROR EXIT
*
* HERE FOR NULL STRING
*
XSCI2 EXI 2 TAKE NULL-STRING ERROR EXIT
ENP END PROCEDURE XSCNI
TTL S P I T B O L -- UTILITY ROUTINES
*
* THE FOLLOWING SECTION CONTAINS UTILITY ROUTINES USED FOR
* VARIOUS PURPOSES THROUGHOUT THE SYSTEM. THESE DIFFER
* FROM THE PROCEDURES IN THE UTILITY PROCEDURES SECTION IN
* THEY ARE NOT IN PROCEDURE FORM AND THEY DO NOT RETURN
* TO THEIR CALLERS. THEY ARE ACCESSED WITH A BRANCH TYPE
* INSTRUCTION AFTER SETTING THE REGISTERS TO APPROPRIATE
* PARAMETER VALUES.
*
* THE REGISTER VALUES REQUIRED FOR EACH ROUTINE ARE
* DOCUMENTED AT THE START OF EACH ROUTINE. REGISTERS NOT
* MENTIONED MAY CONTAIN ANY VALUES EXCEPT THAT XR,XL
* CAN ONLY CONTAIN PROPER COLLECTABLE POINTERS.
*
* SOME OF THESE ROUTINES WILL TOLERATE GARBAGE POINTERS
* IN XL,XR ON ENTRY. THIS IS ALWAYS DOCUMENTED AND IN
* EACH CASE, THE ROUTINE CLEARS THESE GARBAGE VALUES BEFORE
* EXITING AFTER COMPLETING ITS TASK.
*
* THE ROUTINES HAVE NAMES CONSISTING OF FIVE LETTERS
* AND ARE ASSEMBLED IN ALPHABETICAL ORDER.
EJC
* ARREF -- ARRAY REFERENCE
*
* (XL) MAY BE NON-COLLECTABLE
* (XR) NUMBER OF SUBSCRIPTS
* (WB) SET ZERO/NONZERO FOR VALUE/NAME
* THE VALUE IN WB MUST BE COLLECTABLE
* STACK SUBSCRIPTS AND ARRAY OPERAND
* BRN ARREF JUMP TO CALL FUNCTION
*
* ARREF CONTINUES BY EXECUTING THE NEXT CODE WORD WITH
* THE RESULT NAME OR VALUE PLACED ON TOP OF THE STACK.
* TO DEAL WITH THE PROBLEM OF ACCESSING SUBSCRIPTS IN THE
* ORDER OF STACKING, XL IS USED AS A SUBSCRIPT POINTER
* WORKING BELOW THE STACK POINTER.
*
ARREF RTN
MOV XR,WA COPY NUMBER OF SUBSCRIPTS
MOV XS,XT POINT TO STACK FRONT
WTB XR CONVERT TO BAU OFFSET
ADD XR,XT POINT TO ARRAY OPERAND ON STACK
ICA XT FINAL VALUE FOR STACK POPPING
MOV XT,ARFXS KEEP FOR LATER
MOV -(XT),XR LOAD ARRAY OPERAND POINTER
MOV XR,R$ARF KEEP ARRAY POINTER
MOV XT,XR SAVE POINTER TO SUBSCRIPTS
MOV R$ARF,XL POINT XL TO POSSIBLE VCBLK OR TBBLK
MOV (XL),WC LOAD FIRST WORD
BEQ WC,=B$ART,ARF01 JUMP IF ARBLK
BEQ WC,=B$VCT,ARF07 JUMP IF VCBLK
BEQ WC,=B$TBT,ARF10 JUMP IF TBBLK
ERB 240,SUBSCRIPTED OPERAND IS NOT TABLE OR ARRAY
*
* HERE FOR ARRAY (ARBLK)
*
ARF01 BNE WA,ARNDM(XL),ARF09 JUMP IF WRONG NUMBER OF DIMS
LDI INTV0 GET INITIAL SUBSCRIPT OF ZERO
MOV XR,XT POINT BEFORE SUBSCRIPTS
ZER WA INITIAL OFFSET TO BOUNDS
BRN ARF03 JUMP INTO LOOP
*
* LOOP TO COMPUTE SUBSCRIPTS BY MULTIPLICATIONS
*
ARF02 MLI ARDM2(XR) MULTIPLY TOTAL BY NEXT DIMENSION
*
* MERGE HERE FIRST TIME
*
ARF03 MOV -(XT),XR LOAD NEXT SUBSCRIPT
STI ARFSI SAVE CURRENT SUBSCRIPT
LDI ICVAL(XR) LOAD INTEGER VALUE IN CASE
BEQ (XR),=B$ICL,ARF04 JUMP IF IT WAS AN INTEGER
EJC
*
* ARREF (CONTINUED)
*
*
JSR GTINT CONVERT TO INTEGER
PPM ARF12 JUMP IF NOT INTEGER
LDI ICVAL(XR) IF OK, LOAD INTEGER VALUE
*
* HERE WITH INTEGER SUBSCRIPT IN (IA)
*
ARF04 MOV R$ARF,XR POINT TO ARRAY
ADD WA,XR OFFSET TO NEXT BOUNDS
SBI ARLBD(XR) SUBTRACT LOW BOUND TO COMPARE
IOV ARF13 OUT OF RANGE FAIL IF OVERFLOW
ILT ARF13 OUT OF RANGE FAIL IF TOO SMALL
SBI ARDIM(XR) SUBTRACT DIMENSION
IGE ARF13 OUT OF RANGE FAIL IF TOO LARGE
ADI ARDIM(XR) ELSE RESTORE SUBSCRIPT OFFSET
ADI ARFSI ADD TO CURRENT TOTAL
ADD *ARDMS,WA POINT TO NEXT BOUNDS
BNE XT,XS,ARF02 LOOP BACK IF MORE TO GO
*
* HERE WITH INTEGER SUBSCRIPT COMPUTED
*
MFI WA GET AS ONE WORD INTEGER
WTB WA CONVERT TO OFFSET
MOV R$ARF,XL POINT TO ARBLK
ADD AROFS(XL),WA ADD OFFSET PAST BOUNDS
ICA WA ADJUST FOR ARPRO FIELD
BNZ WB,ARF08 EXIT WITH NAME IF NAME CALL
*
* MERGE HERE TO GET VALUE FOR VALUE CALL
*
ARF05 JSR ACESS GET VALUE
PPM ARF13 FAIL IF ACESS FAILS
*
* RETURN VALUE
*
ARF06 MOV ARFXS,XS POP STACK ENTRIES
ZER R$ARF FINISHED WITH ARRAY POINTER
BRN EXIXR EXIT WITH VALUE IN XR
EJC
*
* ARREF (CONTINUED)
*
* HERE FOR VECTOR
*
ARF07 BNE WA,=NUM01,ARF09 ERROR IF MORE THAN 1 SUBSCRIPT
MOV (XS),XR ELSE LOAD SUBSCRIPT
JSR GTINT CONVERT TO INTEGER
PPM ARF12 ERROR IF NOT INTEGER
LDI ICVAL(XR) ELSE LOAD INTEGER VALUE
SBI INTV1 SUBTRACT FOR ONES OFFSET
MFI WA,ARF13 GET SUBSCRIPT AS ONE WORD
ADD =VCVLS,WA ADD OFFSET FOR STANDARD FIELDS
WTB WA CONVERT OFFSET TO BAUS
BGE WA,VCLEN(XL),ARF13 FAIL IF OUT OF RANGE SUBSCRIPT
BZE WB,ARF05 BACK TO GET VALUE IF VALUE CALL
*
* RETURN NAME
*
ARF08 MOV ARFXS,XS POP STACK ENTRIES
ZER R$ARF FINISHED WITH ARRAY POINTER
BRN EXNAM ELSE EXIT WITH NAME
*
* HERE IF SUBSCRIPT COUNT IS WRONG
*
ARF09 ERB 241,ARRAY REFERENCED WITH WRONG NUMBER OF SUBSCRIPTS
*
* TABLE
*
ARF10 BNE WA,=NUM01,ARF11 ERROR IF MORE THAN 1 SUBSCRIPT
MOV (XS),XR ELSE LOAD SUBSCRIPT
JSR TFIND CALL TABLE SEARCH ROUTINE
PPM ARF13 FAIL IF FAILED
BNZ WB,ARF08 EXIT WITH NAME IF NAME CALL
BRN ARF06 ELSE EXIT WITH VALUE
*
* HERE FOR BAD TABLE REFERENCE
*
ARF11 ERB 242,TABLE REFERENCED WITH MORE THAN ONE SUBSCRIPT
*
* HERE FOR BAD SUBSCRIPT
*
ARF12 ERB 243,ARRAY SUBSCRIPT IS NOT INTEGER
*
* HERE TO SIGNAL FAILURE
*
ARF13 ZER R$ARF FINISHED WITH ARRAY POINTER
BRN EXFAL FAIL
EJC
*
* CFUNC -- CALL A FUNCTION
*
* CFUNC IS USED TO CALL A SNOBOL LEVEL FUNCTION. IT IS
* USED BY THE APPLY FUNCTION (S$APP), THE FUNCTION
* TRACE ROUTINE (TRXEQ) AND THE MAIN FUNCTION CALL ENTRY
* (O$FNC, O$FNS). IN THE LATTER CASES, CFUNC IS USED ONLY
* IF THE NUMBER OF ARGUMENTS IS INCORRECT.
*
* (XL) POINTER TO FUNCTION BLOCK
* (WA) ACTUAL NUMBER OF ARGUMENTS
* (XS) POINTS TO STACKED ARGUMENTS
* BRN CFUNC JUMP TO CALL FUNCTION
*
* CFUNC CONTINUES BY EXECUTING THE FUNCTION
*
CFUNC RTN
BLT WA,FARGS(XL),CFNC1 JUMP IF TOO FEW ARGUMENTS
BEQ WA,FARGS(XL),CFNC3 JUMP IF CORRECT NUMBER OF ARGS
*
* HERE IF TOO MANY ARGUMENTS SUPPLIED, POP THEM OFF
*
MOV WA,WB COPY ACTUAL NUMBER
SUB FARGS(XL),WB GET NUMBER OF EXTRA ARGS
WTB WB CONVERT TO BAUS
ADD WB,XS POP OFF UNWANTED ARGUMENTS
BRN CFNC3 JUMP TO GO OFF TO FUNCTION
*
* HERE IF TOO FEW ARGUMENTS
*
CFNC1 MOV FARGS(XL),WB LOAD REQUIRED NUMBER OF ARGUMENTS
BEQ WB,=NINI9,CFNC3 JUMP IF CASE OF VAR NUM OF ARGS
SUB WA,WB CALCULATE NUMBER MISSING
LCT WB,WB SET COUNTER TO CONTROL LOOP
*
* LOOP TO SUPPLY EXTRA NULL ARGUMENTS
*
CFNC2 MOV =NULLS,-(XS) STACK A NULL ARGUMENT
BCT WB,CFNC2 LOOP TILL PROPER NUMBER STACKED
*
* MERGE HERE TO JUMP TO FUNCTION
*
CFNC3 BRI (XL) JUMP THROUGH FCODE FIELD
EJC
*
* EROSI -- PROCESS ERROR RETURN FROM OSINT
*
* (WA) 0 OR ERROR CODE IN 256 TO 998
* (XL) 0 OR PSEUDO SCBLK FOR ERROR MESSAGE
* (IA) NEW VALUE FOR CODE KEYWORD
* BRN EROSI JUMP TO PROCESS ERROR
*
EROSI RTN
STI KVCOD STORE NEW CODE KEYWORD VALUE
MOV WA,KVERT STORE ERROR CODE
BZE XL,ERROR FAIL AT ONCE IF NO ERROR MSG TEXT
MOV SCLEN(XL),WA STRING LENGTH
ZER WB ZERO OFFSET
JSR SBSTR COPY ERROR MESSAGE STRING
MOV XR,R$ETX AND STORE IT
MNZ EROSN NOTE NO CALL OF SYSEM
MOV KVERT,WA RECALL ERROR CODE
BRN ERROR ENTER ERROR SECTION
*
* EXFAL -- EXIT SIGNALLING SNOBOL FAILURE
*
* (XL,XR) MAY BE NON-COLLECTABLE
* BRN EXFAL JUMP TO FAIL
*
* EXFAL CONTINUES BY EXECUTING THE APPROPRIATE FAIL GOTO
*
EXFAL RTN
MOV FLPTR,XS POP STACK
MOV (XS),XR LOAD FAILURE OFFSET
ADD R$COD,XR POINT TO FAILURE CODE LOCATION
LCP XR SET CODE POINTER
BRN EXITS DO NEXT CODE WORD
*
* EXINT -- EXIT WITH INTEGER RESULT
*
* (XL,XR) MAY BE NONCOLLECTABLE
* (IA) INTEGER VALUE
* BRN EXINT JUMP TO EXIT WITH INTEGER
*
* EXINT CONTINUES BY EXECUTING THE NEXT CODE WORD
* WHICH IT DOES BY FALLING THROUGH TO EXIXR
*
EXINT RTN
JSR ICBLD BUILD ICBLK
EJC
* EXIXR -- EXIT WITH RESULT IN (XR)
*
* (XR) RESULT
* (XL) MAY BE NON-COLLECTABLE
* BRN EXIXR JUMP TO EXIT WITH RESULT IN (XR)
*
* EXIXR CONTINUES BY EXECUTING THE NEXT CODE WORD
* WHICH IT DOES BY FALLING THROUGH TO EXITS.
EXIXR RTN
*
MOV XR,-(XS) STACK RESULT
*
*
* EXITS -- EXIT WITH RESULT IF ANY STACKED
*
* (XR,XL) MAY BE NON-COLLECTABLE
*
* BRN EXITS ENTER EXITS ROUTINE
*
EXITS RTN
LCW XR LOAD NEXT CODE WORD
MOV (XR),XL LOAD ENTRY ADDRESS
BRI XL JUMP TO EXECUTE NEXT CODE WORD
*
* EXNAM -- EXIT WITH NAME IN (XL,WA)
*
* (XL) NAME BASE
* (WA) NAME OFFSET
* (XR) MAY BE NON-COLLECTABLE
* BRN EXNAM JUMP TO EXIT WITH NAME IN (XL,WA)
*
* EXNAM CONTINUES BY EXECUTING THE NEXT CODE WORD
*
EXNAM RTN
MOV XL,-(XS) STACK NAME BASE
MOV WA,-(XS) STACK NAME OFFSET
BRN EXITS DO NEXT CODE WORD
EJC
*
* EXNUL -- EXIT WITH NULL RESULT
*
* (XL,XR) MAY BE NON-COLLECTABLE
* BRN EXNUL JUMP TO EXIT WITH NULL VALUE
*
* EXNUL CONTINUES BY EXECUTING THE NEXT CODE WORD
*
EXNUL RTN
MOV =NULLS,-(XS) STACK NULL VALUE
BRN EXITS DO NEXT CODE WORD
.IF .CNRA
.ELSE
*
* EXREA -- EXIT WITH REAL RESULT
*
* (XL,XR) MAY BE NON-COLLECTABLE
* (RA) REAL VALUE
* BRN EXREA JUMP TO EXIT WITH REAL VALUE
*
* EXREA CONTINUES BY EXECUTING THE NEXT CODE WORD
*
EXREA RTN
JSR RCBLD BUILD RCBLK
BRN EXIXR JUMP TO EXIT WITH RESULT IN XR
.FI
*
* EXSID -- EXIT SETTING ID FIELD
*
* EXSID IS USED TO EXIT AFTER BUILDING ANY OF THE FOLLOWING
* BLOCKS (ARBLK, TBBLK, PDBLK, VCBLK). IT SETS THE IDVAL.
*
* (XR) PTR TO BLOCK WITH IDVAL FIELD
* (XL) MAY BE NON-COLLECTABLE
* BRN EXSID JUMP TO EXIT AFTER SETTING ID FIELD
*
* EXSID CONTINUES BY EXECUTING THE NEXT CODE WORD
*
EXSID RTN
MOV CURID,WA LOAD CURRENT ID VALUE
BNE WA,=CFP$M,EXSI1 JUMP IF NO OVERFLOW
ZER WA ELSE RESET FOR WRAPAROUND
*
* HERE WITH OLD IDVAL IN WA
*
EXSI1 ICV WA BUMP ID VALUE
MOV WA,CURID STORE FOR NEXT TIME
MOV WA,IDVAL(XR) STORE ID VALUE
BRN EXIXR EXIT WITH RESULT IN (XR)
EJC
*
* EXVNM -- EXIT WITH NAME OF VARIABLE
*
* EXVNM EXITS AFTER STACKING A VALUE WHICH IS A NMBLK
* REFERENCING THE NAME OF A GIVEN NATURAL VARIABLE.
*
* (XR) VRBLK POINTER
* (XL) MAY BE NON-COLLECTABLE
* BRN EXVNM EXIT WITH VRBLK POINTER IN XR
*
EXVNM RTN
MOV XR,XL COPY NAME BASE POINTER
MOV *NMSI$,WA SET SIZE OF NMBLK
JSR ALLOC ALLOCATE NMBLK
MOV =B$NML,(XR) STORE TYPE WORD
MOV XL,NMBAS(XR) STORE NAME BASE
MOV *VRVAL,NMOFS(XR) STORE NAME OFFSET
BRN EXIXR EXIT WITH RESULT IN XR
*
* FLPOP -- FAIL AND POP IN PATTERN MATCHING
*
* FLPOP POPS THE NODE AND CURSOR ON THE STACK AND THEN
* DROPS THROUGH INTO FAILP TO CAUSE PATTERN FAILURE
*
* (XL,XR) MAY BE NON-COLLECTABLE
* BRN FLPOP JUMP TO FAIL AND POP STACK
*
FLPOP RTN
ADD *NUM02,XS POP TWO ENTRIES OFF STACK
*
* FAILP -- FAILURE IN MATCHING PATTERN NODE
*
* FAILP IS USED AFTER FAILING TO MATCH A PATTERN NODE.
* SEE PATTERN MATCH ROUTINES FOR DETAILS OF USE.
*
* (XL,XR) MAY BE NON-COLLECTABLE
* BRN FAILP SIGNAL FAILURE TO MATCH
*
* FAILP CONTINUES BY MATCHING AN ALTERNATIVE FROM THE STACK
*
FAILP RTN
MOV (XS)+,XR LOAD ALTERNATIVE NODE POINTER
MOV (XS)+,WB RESTORE OLD CURSOR
MOV (XR),XL LOAD PCODE ENTRY POINTER
BRI XL JUMP TO EXECUTE CODE FOR NODE
EJC
*
* INDIR -- COMPUTE INDIRECT REFERENCE
*
* (WB) NONZERO/ZERO FOR BY NAME/VALUE
* BRN INDIR JUMP TO GET INDIRECT REF ON STACK
*
* INDIR CONTINUES BY EXECUTING THE NEXT CODE WORD
*
INDIR RTN
MOV (XS)+,XR LOAD ARGUMENT
BEQ (XR),=B$NML,INDR2 JUMP IF A NAME
JSR GTNVR ELSE CONVERT TO VARIABLE
ERR 244,INDIRECTION OPERAND IS NOT NAME
BZE WB,INDR1 SKIP IF BY VALUE
MOV XR,-(XS) ELSE STACK VRBLK PTR
MOV *VRVAL,-(XS) STACK NAME OFFSET
BRN EXITS EXIT WITH RESULT ON STACK
*
* HERE TO GET VALUE OF NATURAL VARIABLE
*
INDR1 BRI (XR) JUMP THROUGH VRGET FIELD OF VRBLK
*
* HERE IF OPERAND IS A NAME
*
INDR2 MOV NMBAS(XR),XL LOAD NAME BASE
MOV NMOFS(XR),WA LOAD NAME OFFSET
BNZ WB,EXNAM EXIT IF CALLED BY NAME
JSR ACESS ELSE GET VALUE FIRST
PPM EXFAL FAIL IF ACCESS FAILS
BRN EXIXR ELSE RETURN WITH VALUE IN XR
EJC
*
* MATCH -- INITIATE PATTERN MATCH
*
* (WB) MATCH TYPE CODE
* BRN MATCH JUMP TO INITIATE PATTERN MATCH
*
* MATCH CONTINUES BY EXECUTING THE PATTERN MATCH. SEE
* PATTERN MATCH ROUTINES (P$XXX) FOR FULL DETAILS.
*
MATCH RTN
MOV (XS)+,XR LOAD PATTERN OPERAND
JSR GTPAT CONVERT TO PATTERN
ERR 245,PATTERN MATCH RIGHT OPERAND IS NOT PATTERN
MOV XR,XL IF OK, SAVE PATTERN POINTER
BNZ WB,MTCH1 JUMP IF NOT MATCH BY NAME
MOV (XS),WA ELSE LOAD NAME OFFSET
MOV XL,-(XS) SAVE PATTERN POINTER
MOV 2(XS),XL LOAD NAME BASE
JSR ACESS ACCESS SUBJECT VALUE
PPM EXFAL FAIL IF ACCESS FAILS
MOV (XS),XL RESTORE PATTERN POINTER
MOV XR,(XS) STACK SUBJECT STRING VAL FOR MERGE
ZER WB RESTORE TYPE CODE
*
* MERGE HERE WITH SUBJECT VALUE ON STACK
*
.IF .CNBF
MTCH1 JSR GTSTG CONVERT SUBJECT TO STRING
.ELSE
MTCH1 MOV (XS),XR LOAD SUBJECT VALUE
ZER R$PMB ASSUME NOT A BUFFER
BNE (XR),=B$BCT,MTCHA BRANCH IF NOT
ICA XS ELSE POP VALUE
MOV XR,R$PMB SAVE POINTER
MOV BCLEN(XR),WA GET DEFINED LENGTH
MOV BCBUF(XR),XR POINT TO BFBLK
BRN MTCHB
*
* HERE IF NOT BUFFER TO CONVERT TO STRING
*
MTCHA JSR GTSTG NOT BUFFER - CONVERT TO STRING
.FI
ERR 246,PATTERN MATCH LEFT OPERAND IS NOT STRING
.IF .CNBF
MOV XR,R$PMS IF OK, STORE SUBJECT STRING POINTER
.ELSE
*
* MERGE WITH NULL STRING OR BUFFER
*
MTCHB MOV XR,R$PMS IF OK, STORE SUBJECT STRING POINTER
.FI
MOV WA,PMSSL AND LENGTH
MOV WB,-(XS) STACK MATCH TYPE CODE
ZER -(XS) STACK INITIAL CURSOR (ZERO)
ZER WB SET INITIAL CURSOR
MOV XS,PMHBS SET HISTORY STACK BASE PTR
ZER PMDFL RESET PATTERN ASSIGNMENT FLAG
MOV XL,XR SET INITIAL NODE POINTER
BNZ KVANC,MTCH2 JUMP IF ANCHORED
EJC
*
* MATCH (CONTINUED)
*
* HERE FOR UNANCHORED
*
MOV XR,-(XS) STACK INITIAL NODE POINTER
MOV =NDUNA,-(XS) STACK POINTER TO ANCHOR MOVE NODE
BRI (XR) START MATCH OF FIRST NODE
*
* HERE IN ANCHORED MODE
*
MTCH2 ZER -(XS) DUMMY CURSOR VALUE
MOV =NDABO,-(XS) STACK POINTER TO ABORT NODE
BRI (XR) START MATCH OF FIRST NODE
EJC
*
* RETRN -- RETURN FROM FUNCTION
*
* (WA) STRING POINTER FOR RETURN TYPE
* BRN RETRN JUMP TO RETURN FROM (SNOBOL) FUNC
*
* RETRN CONTINUES BY EXECUTING THE CODE AT THE RETURN POINT
* THE STACK IS CLEANED OF ANY GARBAGE LEFT BY OTHER
* ROUTINES WHICH MAY HAVE ALTERED FLPTR SINCE FUNCTION
* ENTRY BY USING FLPRT, RESERVED FOR USE ONLY BY
* FUNCTION CALL AND RETURN.
*
RETRN RTN
BNZ KVFNC,RTN01 JUMP IF NOT LEVEL ZERO
ERB 247,FUNCTION RETURN FROM LEVEL ZERO
*
* HERE IF NOT LEVEL ZERO RETURN
*
RTN01 MOV FLPRT,XS POP STACK
ICA XS REMOVE FAILURE OFFSET
MOV (XS)+,XR POP PFBLK POINTER
MOV (XS)+,FLPTR POP FAILURE POINTER
MOV (XS)+,FLPRT POP OLD FLPRT
MOV (XS)+,WB POP CODE POINTER OFFSET
MOV (XS)+,WC POP OLD CODE BLOCK POINTER
ADD WC,WB MAKE OLD CODE POINTER ABSOLUTE
LCP WB RESTORE OLD CODE POINTER
MOV WC,R$COD RESTORE OLD CODE BLOCK POINTER
DCV KVFNC DECREMENT FUNCTION LEVEL
MOV KVTRA,WB LOAD TRACE
ADD KVFTR,WB ADD FTRACE
BZE WB,RTN06 JUMP IF NO TRACING POSSIBLE
*
* HERE IF THERE MAY BE A TRACE
*
MOV WA,-(XS) SAVE FUNCTION RETURN TYPE
MOV XR,-(XS) SAVE PFBLK POINTER
MOV WA,KVRTN SET RTNTYPE FOR TRACE FUNCTION
MOV R$FNC,XL LOAD FNCLEVEL TRBLK PTR (IF ANY)
JSR KTREX EXECUTE POSSIBLE FNCLEVEL TRACE
MOV PFVBL(XR),XL LOAD VRBLK POINTER
BZE KVTRA,RTN02 JUMP IF TRACE IS OFF
MOV PFRTR(XR),XR ELSE LOAD RETURN TRACE TRBLK PTR
BZE XR,RTN02 JUMP IF NOT RETURN TRACED
DCV KVTRA ELSE DECREMENT TRACE COUNT
BZE TRFNC(XR),RTN03 JUMP IF PRINT TRACE
MOV *VRVAL,WA ELSE SET NAME OFFSET
MOV 1(XS),KVRTN MAKE SURE RTNTYPE IS SET RIGHT
JSR TRXEQ EXECUTE FULL TRACE
EJC
*
* RETRN (CONTINUED)
*
* HERE TO TEST FOR FTRACE
*
RTN02 BZE KVFTR,RTN05 JUMP IF FTRACE IS OFF
DCV KVFTR ELSE DECREMENT FTRACE
*
* HERE FOR PRINT TRACE OF FUNCTION RETURN
*
RTN03 JSR PRTSN PRINT STATEMENT NUMBER
MOV 1(XS),XR LOAD RETURN TYPE
JSR PRTST PRINT IT
MOV =CH$BL,WA LOAD BLANK
JSR PRTCH PRINT IT
MOV 0(XS),XL LOAD PFBLK PTR
MOV PFVBL(XL),XL LOAD FUNCTION VRBLK PTR
MOV *VRVAL,WA SET VRBLK NAME OFFSET
BNE XR,=SCFRT,RTN04 JUMP IF NOT FRETURN CASE
*
* FOR FRETURN, JUST PRINT FUNCTION NAME
*
JSR PRTNM PRINT NAME
JSR PRTFH TERMINATE PRINT LINE
BRN RTN05 MERGE
*
* HERE FOR RETURN OR NRETURN, PRINT FUNCTION NAME = VALUE
*
RTN04 JSR PRTNV PRINT NAME = VALUE
*
* HERE AFTER COMPLETING TRACE
*
RTN05 MOV (XS)+,XR POP PFBLK POINTER
MOV (XS)+,WA POP RETURN TYPE STRING
*
* MERGE HERE IF NO TRACE REQUIRED
*
RTN06 MOV WA,KVRTN SET RTNTYPE KEYWORD
MOV PFVBL(XR),XL LOAD POINTER TO FN VRBLK
EJC
* RETRN (CONTINUED)
*
* GET VALUE OF FUNCTION
*
RTN07 MOV XL,RTNBP SAVE BLOCK POINTER
MOV VRVAL(XL),XL LOAD VALUE
BEQ (XL),=B$TRT,RTN07 LOOP BACK IF TRAPPED
MOV XL,RTNFV ELSE SAVE FUNCTION RESULT VALUE
MOV (XS)+,RTNSV SAVE ORIGINAL FUNCTION VALUE
.IF .CNPF
MOV FARGS(XR),WB GET NUMBER OF ARGUMENTS
.ELSE
MOV (XS)+,XL POP SAVED POINTER
BZE XL,RTN7C NO ACTION IF NONE
BZE KVPFL,RTN7C JUMP IF NO PROFILING
JSR PRFLU ELSE PROFILE LAST FUNC STMT
BEQ KVPFL,=NUM02,RTN7A BRANCH ON VALUE OF PROFILE KEYWD
*
* HERE IF PROFILE = 1. START TIME MUST BE FRIGGED TO
* APPEAR EARLIER THAN IT ACTUALLY IS, BY AMOUNT USED BEFORE
* THE CALL.
*
LDI PFSTM LOAD CURRENT TIME
SBI ICVAL(XL) FRIG BY SUBTRACTING SAVED AMOUNT
BRN RTN7B AND MERGE
*
* HERE IF PROFILE = 2
*
RTN7A LDI ICVAL(XL) LOAD SAVED TIME
*
* BOTH PROFILE TYPES MERGE HERE
*
RTN7B STI PFSTM STORE BACK CORRECT START TIME
*
* MERGE HERE IF NO PROFILING
*
RTN7C MOV FARGS(XR),WB GET NUMBER OF ARGS
.FI
ADD PFNLO(XR),WB ADD NUMBER OF LOCALS
BZE WB,RTN10 JUMP IF NO ARGS/LOCALS
LCT WB,WB ELSE SET LOOP COUNTER
ADD PFLEN(XR),XR AND POINT TO END OF PFBLK
*
* LOOP TO RESTORE FUNCTIONS AND LOCALS
*
RTN08 MOV -(XR),XL LOAD NEXT VRBLK POINTER
*
* LOOP TO FIND VALUE BLOCK
*
RTN09 MOV XL,WA SAVE BLOCK POINTER
MOV VRVAL(XL),XL LOAD POINTER TO NEXT VALUE
BEQ (XL),=B$TRT,RTN09 LOOP BACK IF TRAPPED
MOV WA,XL ELSE RESTORE LAST BLOCK POINTER
MOV (XS)+,VRVAL(XL) RESTORE OLD VARIABLE VALUE
BCT WB,RTN08 LOOP TILL ALL PROCESSED
EJC
*
* RETRN (CONTINUED)
*
* NOW RESTORE FUNCTION VALUE AND EXIT
*
RTN10 MOV RTNBP,XL RESTORE PTR TO LAST FUNCTION BLOCK
MOV RTNSV,VRVAL(XL) RESTORE OLD FUNCTION VALUE
MOV RTNFV,XR RELOAD FUNCTION RESULT
MOV R$COD,XL POINT TO NEW CODE BLOCK
MOV KVSTN,KVLST SET LASTNO FROM STNO
MOV CDSTM(XL),KVSTN RESET PROPER STNO VALUE
MOV KVRTN,WA LOAD RETURN TYPE
BEQ WA,=SCRTN,EXIXR EXIT WITH RESULT IN XR IF RETURN
BEQ WA,=SCFRT,EXFAL FAIL IF FRETURN
*
* HERE FOR NRETURN
*
BEQ (XR),=B$NML,RTN11 JUMP IF IS A NAME
JSR GTNVR ELSE TRY CONVERT TO VARIABLE NAME
ERR 248,FUNCTION RESULT IN NRETURN IS NOT NAME
MOV XR,XL IF OK, COPY VRBLK (NAME BASE) PTR
MOV *VRVAL,WA SET NAME OFFSET
BRN RTN12 AND MERGE
*
* HERE IF RETURNED RESULT IS A NAME
*
RTN11 MOV NMBAS(XR),XL LOAD NAME BASE
MOV NMOFS(XR),WA LOAD NAME OFFSET
*
* MERGE HERE WITH RETURNED NAME IN (XL,WA)
*
RTN12 MOV XL,XR PRESERVE XL
LCW WB LOAD NEXT WORD
MOV XR,XL RESTORE XL
BEQ WB,=OFNE$,EXNAM EXIT IF CALLED BY NAME
MOV WB,-(XS) ELSE SAVE CODE WORD
JSR ACESS GET VALUE
PPM EXFAL FAIL IF ACCESS FAILS
MOV XR,XL IF OK, COPY RESULT
MOV (XS),XR RELOAD NEXT CODE WORD
MOV XL,(XS) STORE RESULT ON STACK
MOV (XR),XL LOAD ROUTINE ADDRESS
BRI XL JUMP TO EXECUTE NEXT CODE WORD
EJC
*
* STCOV -- SIGNAL STATEMENT COUNTER OVERFLOW
*
* BRN STCOV JUMP TO SIGNAL STATEMENT COUNT OFLO
*
* PERMIT UP TO 10 MORE STATEMENTS TO BE OBEYED SO THAT
* SETEXIT TRAP CAN REGAIN CONTROL.
* STCOV CONTINUES BY ISSUING THE ERROR MESSAGE
*
STCOV RTN
ICV ERRFT FATAL ERROR
LDI INTVT GET 10
ADI KVSTL ADD TO FORMER LIMIT
STI KVSTL STORE AS NEW STLIMIT
LDI INTVT GET 10
STI KVSTC SET AS NEW COUNT
ERB 249,STATEMENT COUNT EXCEEDS VALUE OF STLIMIT KEYWORD
EJC
*
* STMGO -- START EXECUTION OF NEW STATEMENT
*
* (XR) POINTER TO CDBLK FOR NEW STATEMENT
* BRN STMGO JUMP TO EXECUTE NEW STATEMENT
*
* STMGO CONTINUES BY EXECUTING THE NEXT STATEMENT
*
STMGO RTN
MOV XR,R$COD SET NEW CODE BLOCK POINTER
.IF .CNPF
MOV KVSTN,KVLST SET LASTNO
.ELSE
BZE KVPFL,STGO1 SKIP IF NO PROFILING
JSR PRFLU ELSE PROFILE THE STATEMENT
*
* MERGE PROFILE, NO-PROFILE CASES
*
STGO1 MOV KVSTN,KVLST SET LASTNO
.FI
MOV CDSTM(XR),KVSTN SET STNO
ADD *CDCOD,XR POINT TO FIRST CODE WORD
LCP XR SET CODE POINTER
LDI KVSTC GET STMT COUNT
ILT EXITS OMIT COUNTING IF NEGATIVE
IEQ STCOV FAIL IF STLIMIT REACHED
SBI INTV1 DECREMENT
STI KVSTC REPLACE IT
BZE R$STC,EXITS EXIT IF NO STCOUNT TRACE
*
* HERE FOR STCOUNT TRACE
*
ZER XR CLEAR GARBAGE VALUE IN XR
MOV R$STC,XL LOAD POINTER TO STCOUNT TRBLK
JSR KTREX EXECUTE KEYWORD TRACE
BRN EXITS AND THEN EXIT FOR NEXT CODE WORD
EJC
*
* STOPR -- TERMINATE RUN
*
* (WA) 0 OR ERROR MESSAGE CODE
* (XR) 0 OR ENDING MESSAGE POINTER
* BRN STOPR JUMP TO TERMINATE RUN
*
* TERMINATE RUN AND PRINT STATISTICS. ON ENTRY XR POINTS
* TO ENDING MESSAGE OR IS ZERO IF MESSAGE PRINTED ALREADY.
* (WA) AND (XR) ARE BOTH NON-ZERO ONLY IN THE CASE OF FATAL
* ERRORS DURING INITIAL COMPILE.
*
STOPR RTN
.IF .CSAX
JSR SYSAX CALL AFTER EXECUTION PROC
.ELSE
.FI
ADD RSMEM,DNAME USE THE RESERVE MEMORY
BZE WA,STPR1 SKIP IF NO ERROR MESSAGE
MOV XR,STPXR KEEP 0 OR ENDING MESSAGE
MOV TTERL,TTLST SEND ERROR AND STATS TO TERML
JSR PRTPG PAGE THROW
JSR ERMSG PRINT ERROR MESSAGE
MOV STPXR,XR RECOVER 0 OR ENDING MESSAGE
ZER EXSTS TO FORCE ENDING STATS OUT FOR ERROR
*
* PROCESS ENDING STATISTICS
*
STPR1 MTI KVSTN GET STATEMENT NUMBER
IEQ STPR6 SKIP IF COMPILE TIME
BNZ EXSTS,STPR4 SKIP IF NO STATS TO BE PRINTED
JSR PRTPG EJECT PRINTER
BZE XR,STPR2 SKIP IF NO MESSAGE
JSR PRTFB PRINT MESSAGE
*
* MERGE HERE IF NO MESSAGE TO PRINT
*
STPR2 JSR PRTFH PRINT BLANK LINE
MOV =STPM1,XR POINT TO MESSAGE /IN STATEMENT XXX/
JSR PRTMI PRINT IT
JSR SYSTM GET CURRENT TIME
SBI TIMSX MINUS START TIME = ELAPSED EXEC TIM
STI STPTI SAVE FOR LATER
MOV =STPM3,XR POINT TO MSG /EXECUTION TIME MSEC /
JSR PRTMI PRINT IT
LDI KVSTL GET STATEMENT LIMIT
ILT STPR3 SKIP IF NEGATIVE
SBI KVSTC MINUS COUNTER = COUNT
STI STPSI SAVE
MOV =STPM2,XR POINT TO MESSAGE /STMTS EXECUTED/
JSR PRTMI PRINT IT
.IF .CTMD
.ELSE
LDI STPTI RELOAD ELAPSED TIME
MLI INTTH *1000 (MICROSECS)
IOV STPR3 JUMP IF WE CANNOT COMPUTE
DVI STPSI DIVIDE BY STATEMENT COUNT
IOV STPR3 JUMP IF OVERFLOW
MOV =STPM4,XR POINT TO MSG (MCSEC PER STATEMENT /
JSR PRTMI PRINT IT
.FI
EJC
*
* STOPR (CONTINUED)
*
* MERGE TO SKIP MESSAGE (OVERFLOW OR NEGATIVE STLIMIT)
*
STPR3 MTI GBCNT LOAD COUNT OF COLLECTIONS
MOV =STPM5,XR POINT TO MESSAGE /REGENERATIONS /
JSR PRTMI PRINT IT
JSR PRTFH ONE MORE BLANK FOR LUCK
*
* CHECK IF DUMP REQUESTED
*
.IF .CNPF
STPR4 MOV KVDMP,XR LOAD DUMP KEYWORD
.ELSE
STPR4 JSR PRFLR PRINT PROFILE IF WANTED
MOV KVDMP,XR LOAD DUMP KEYWORD
.FI
JSR DUMPR EXECUTE DUMP IF REQUESTED
*
* MERGE TO END RUN FOR SEVERE COMPILATION ERRORS
*
STPR5 MOV =KVCOD,WA LOAD CODE VALUE
JSR SYSEJ EXIT TO SYSTEM
*
* TERMINATION DURING COMPILE
*
STPR6 BZE XR,STPR7 SKIP IF NO MESSAGE
JSR PRTSF ELSE PRINT IT
*
* NOTIFICATION THAT IT IS COMPILE TIME
*
STPR7 MOV =ENDIC,XR NOTIFY USER
JSR PRTSF SEND IT
BRN STPR5 END
EJC
*
* SUCCP -- SIGNAL SUCCESSFUL MATCH OF A PATTERN NODE
*
* SEE PATTERN MATCH ROUTINES FOR DETAILS
*
* (XR) CURRENT NODE
* (WB) CURRENT CURSOR
* (XL) MAY BE NON-COLLECTABLE
* BRN SUCCP SIGNAL SUCCESSFUL PATTERN MATCH
*
* SUCCP CONTINUES BY MATCHING THE SUCCESSOR NODE
*
SUCCP RTN
MOV PTHEN(XR),XR LOAD SUCCESSOR NODE
MOV (XR),XL LOAD NODE CODE ENTRY ADDRESS
BRI XL JUMP TO MATCH SUCCESSOR NODE
TTL S P I T B O L -- STACK OVERFLOW SECTION
*
* CONTROL COMES HERE IF THE MAIN STACK OVERFLOWS
*
SEC START OF STACK OVERFLOW SECTION
*
STAKV RTN ENTRY POINT FOR STACK OVERFLOW
ICV ERRFT FATAL ERROR
MOV FLPTR,XS POP STACK TO AVOID MORE FAILS
BNZ GBCFL,STAK1 JUMP IF GARBAGE COLLECTING
ERB 250,STACK OVERFLOW
*
* NO CHANCE OF RECOVERY IN MID GARBAGE COLLECTION
*
STAK1 MOV =ENDSO,XR POINT TO MESSAGE
ZER KVDMP MEMORY IS UNDUMPABLE
ZER WA NO ERROR MESSAGE
MOV TTERL,TTLST SEND MESSAGE TO TERML IF POSSIBLE
BRN STOPR GIVE UP
TTL S P I T B O L -- ERROR SECTION
*
* THIS SECTION OF CODE IS ENTERED WHENEVER A PROCEDURE
* RETURN VIA AN ERR PARAMETER OR AN ERB OPCODE IS OBEYED.
*
* (WA) IS THE ERROR CODE
*
* THE GLOBAL VARIABLE STAGE INDICATES THE POINT AT WHICH
* THE ERROR OCCURED AS FOLLOWS.
*
* STAGE=STGIC ERROR DURING INITIAL COMPILE
*
* STAGE=STGXC ERROR DURING COMPILE AT EXECUTE
* TIME (CODE, CONVERT FUNCTION CALLS)
*
* STAGE=STGEV ERROR DURING COMPILATION OF
* EXPRESSION AT EXECUTION TIME
* (EVAL, CONVERT FUNCTION CALL).
*
* STAGE=STGXT ERROR AT EXECUTE TIME. COMPILER
* NOT ACTIVE.
*
* STAGE=STGCE ERROR DURING INITIAL COMPILE AFTER
* SCANNING OUT THE END LINE.
*
* STAGE=STGXE ERROR DURING COMPILE AT EXECUTE
* TIME AFTER SCANNING END LINE.
*
* STAGE=STGEE ERROR DURING EXPRESSION EVALUATION
*
SEC START OF ERROR SECTION
*
ERROR RTN ERROR CODE ENTRY POINT
BGE ERRFT,=NUM03,ERR16 SKIP IF TOO MANY FATALS
BEQ R$CIM,=CMLAB,ERRG1 JUMP IF ERROR IN LABEL SCAN
MOV WA,KVERT SAVE ERROR CODE
ZER SCNRS RESET RESCAN SWITCH FOR SCANE
ZER SCNGO RESET GOTO SWITCH FOR SCANE
MOV STAGE,XR LOAD CURRENT STAGE
BSW XR,STGNO JUMP TO APPROPRIATE ERROR CIRCUIT
IFF STGIC,ERR01 INITIAL COMPILE
IFF STGXC,ERR08 EXECUTE TIME COMPILE
IFF STGEV,ERR08 EVAL COMPILING EXPR.
IFF STGEE,ERR08 EVAL EVALUATING EXPR
IFF STGXT,ERR12 EXECUTE TIME
IFF STGCE,ERR01 COMPILE - AFTER END
IFF STGXE,ERR08 XEQ COMPILE-PAST END
ESW END SWITCH ON ERROR TYPE
*
* ERROR DURING INITIAL COMPILE
* THE ERROR MESSAGE IS PRINTED AS PART OF THE COMPILER
* OUTPUT. THIS PRINTOUT INCLUDES THE OFFENDING LINE (IF NOT
* PRINTED ALREADY) AND AN ERROR FLAG UNDER THE APPROPRIATE
* COLUMN AS INDICATED BY SCNSE UNLESS SCNSE IS SET TO ZERO.
* AFTER PRINTING THE MESSAGE, THE GENERATED CODE IS
* MODIFIED TO AN ERROR CALL AND CONTROL IS RETURNED TO
* THE CMPIL PROCEDURE AFTER RESETTING THE STACK POINTER.
* IF THE ERROR OCCURS AFTER THE END LINE, CONTROL RETURNS
* IN A SLIGHTLY DIFFERENT MANNER TO ENSURE PROPER CLEANUP.
EJC
*
ERR01 MOV CMPXS,XS RESET STACK POINTER
SSL CMPSS RESTORE S-R STACK PTR FOR CMPIL
BNZ ERRSP,ERR06 JUMP IF ERROR SUPPRESS FLAG SET
JSR PRTFH PRINT A BLANK
MOV TTERL,TTLST SET FLAG FOR LISTR
ADD =NUM03,LSTLC CAUSE EJECT IF BELOW 4 LINES LEFT
MOV LSTLC,-(XS) KEEP LINE COUNT
JSR LISTR LIST LINE
JSR PRTFH TERMINATE LISTING
MOV (XS)+,WA RECOVER LINE COUNT
BGT LSTLC,WA,ERR02 SKIP IF NOT NEW PAGE
ADD =NUM04,LSTLC BUMP FOR LINES PRINTED
*
* PRINT FLAG UNDER BAD ELEMENT
*
ERR02 MOV SCNSE,WA LOAD SCAN ELEMENT OFFSET
.IF .CAHT
MOV WA,WB COPY OFFSET
ICV WA INCREASE FOR CH$EX
JSR ALOCS STRING BLOCK FOR ERROR FLAG
MOV XR,WA REMEMBER STRING PTR
PSC XR READY FOR CHARACTER STORING
BZE WB,ERR05 SKIP IF NO BLANKS BEFORE ERROR FLAG
MOV R$CIM,XL POINT TO BAD STATEMENT
PLC XL READY TO GET CHARS
LCT WB,WB LOOP COUNTER
*
* LOOP TO REPLACE ALL CHARS BUT TABS BY BLANKS
*
ERR03 LCH WC,(XL)+ GET NEXT CHAR
BEQ WC,=CH$HT,ERR04 SKIP IF TAB
MOV =CH$BL,WC GET A BLANK
EJC
*
* MERGE TO STORE BLANK OR TAB IN ERROR LINE
*
ERR04 SCH WC,(XR)+ STORE CHAR
BCT WB,ERR03 LOOP
EJC
*
* MERGE IN CASE OF NO PRECEDING BLANKS
*
ERR05 MOV =CH$EX,XL EXCLAMATION MARK
SCH XL,(XR) STORE AT END OF ERROR LINE
CSC XR END OF SCH LOOP
MOV =STNPD,PROFS ALLOW FOR STATEMENT NUMBER
MOV WA,XR POINT TO ERROR LINE
JSR PRTST PRINT ERROR LINE
.ELSE
MTI PRLEN GET PRINT BUFFER LENGTH
STI GTNSI STORE AS SIGNED INTEGER
ADD =STNPD,WA ADJUST FOR STATEMENT NUMBER
MTI WA COPY TO INTEGER ACCUMULATOR
RMI GTNSI REMAINDER MODULO PRINT BFR LENGTH
MFI PROFS USE AS CHARACTER OFFSET
MOV =CH$EX,WA GET EXCLAMATION MARK
JSR PRTCH GENERATE UNDER BAD COLUMN
.FI
*
* HERE AFTER PLACING ERROR FLAG AS REQUIRED
*
JSR ERMSG GENERATE FLAG AND ERROR MESSAGE
ZER TTLST REVERT TO REGULAR LISTING
ZER XR IN CASE OF FATAL ERROR
ICV CMERC BUMP ERROR COUNT
BNE STAGE,=STGIC,ERRG2 SPECIAL RETURN IF AFTER END LINE
*
* IF ERROR IN READR THEN EITHER CLOSE OUT
* CURRENT -COPY LEVEL, OR IF AT TOP THEN ABORT
*
BZE RDRER,ERR06 SKIP IF NOT ERROR WHILE READING
BZE R$COP,ERR16 ABORT IF AT TOP LEVEL INPUT FILE
ZER RDRER ELSE CLEAR READR ERROR FLAG
JSR COPND AND CLOSE OUT THIS COPY LEVEL
*
* LOOP TO SCAN TO END OF STATEMENT
*
ERR06 MOV R$CIM,XR POINT TO START OF IMAGE
BZE XR,ERR07 SKIP IF NO INPUT IMAGE
PLC XR POINT TO FIRST CHAR
LCH XR,(XR) GET FIRST CHAR
BEQ XR,=CH$MN,ERRG3 JUMP IF ERROR IN CONTROL CARD
ZER SCNRS CLEAR RESCAN FLAG
MNZ ERRSP SET ERROR SUPPRESS FLAG
JSR SCANE SCAN NEXT ELEMENT
BNE XL,=T$SMC,ERR06 LOOP BACK IF NOT STATEMENT END
ZER ERRSP CLEAR ERROR SUPPRESS FLAG
EJC
*
* GENERATE ERROR CALL IN CODE AND RETURN TO CMPIL
*
ERR07 MOV *CDCOD,CWCOF RESET OFFSET IN CCBLK
MOV =OCER$,WA LOAD COMPILE ERROR CALL
JSR CDWRD GENERATE IT
MOV CWCOF,CMSOC(XS) SET SUCCESS FILL IN OFFSET
MNZ CMFFC(XS) SET FAILURE FILL IN FLAG
JSR CDWRD GENERATE SUCC. FILL IN WORD
JMG CMPSE MERGE TO GENERATE ERROR AS CDFAL
EJC
*
* ERROR DURING EXECUTE TIME COMPILE OR EXPRESSION EVALUATION.
*
* EXECUTE TIME COMPILATION IS INITIATED THROUGH GTCOD OR
* GTEXP WHICH ARE CALLED BY COMPILE, CODE OR EVAL.
* BEFORE CAUSING STATEMENT FAILURE THROUGH EXFAL IT IS
* HELPFUL TO SET KEYWORD ERRTEXT AND FOR GENERALITY
* THESE ERRORS MAY BE HANDLED BY THE SETEXIT MECHANISM.
*
ERR08 JSR COPND CALL TO CLOSE OFF THIS LEVEL
BNZ R$COP,ERR08 LOOP IF NOT ALL -COPYS CLOSED
ZER R$CCB FORGET GARBAGE CODE BLOCK
SSL INISS RESTORE MAIN PROG S-R STACK PTR
JSR ERTEX GET FAIL MESSAGE TEXT
DCA XS ENSURE STACK OK ON LOOP START
*
* POP STACK UNTIL FIND FLPTR FOR MOST DEEPLY NESTED PROG.
* DEFINED FUNCTION CALL OR CALL OF EVAL / CODE.
*
ERR09 ICA XS POP STACK
BEQ XS,FLPRT,ERR11 JUMP IF PROG DEFINED FN CALL FOUND
BNE XS,GTCEF,ERR09 LOOP IF NOT EVAL OR CODE CALL YET
MOV =STGXT,STAGE RE-SET STAGE FOR EXECUTE
MOV R$GTC,R$COD RECOVER CODE PTR
MOV XS,FLPTR RESTORE FAIL POINTER
ZER R$CIM FORGET POSSIBLE IMAGE
*
* TEST ERRLIMIT
*
ERR10 BNZ KVERL,ERR14 JUMP IF ERRLIMIT NON-ZERO
BRN EXFAL FAIL
*
* RETURN FROM PROG. DEFINED FUNCTION IS OUTSTANDING
*
ERR11 MOV FLPTR,XS RESTORE STACK FROM FLPTR
BRN ERR10 MERGE
*
* ERROR AT EXECUTE TIME.
*
* THE ACTION TAKEN ON AN ERROR IS AS FOLLOWS.
*
* IF ERRLIMIT KEYWORD IS ZERO, THE RUN IS ABORTED.
* OTHERWISE, ERRLIMIT IS DECREMENTED AND AN ERRTYPE TRACE
* GENERATED IF REQUIRED. CONTROL RETURNS EITHER VIA A JUMP
* TO CONTINUE (TO TAKE THE FAILURE EXIT) OR A SPECIFIED
* SETEXIT TRAP IS EXECUTED AND CONTROL PASSES TO THE TRAP.
* IF 3 OR MORE FATAL ERRORS OCCUR AN ABORT OCCURS
* REGARDLESS OF ERRLIMIT AND SETEXIT - LOOPING IS ALL TOO
* PROBABLE OTHERWISE. FATAL ERRORS INCLUDE STACK OVERFLOW
* AND EXCEEDING STLIMIT.
EJC
*
ERR12 SSL INISS RESTORE MAIN PROG S-R STACK PTR
BNZ DMVCH,ERR15 JUMP IF IN MID-DUMP
*
* MERGE HERE AFTER DUMP TIDY UP
*
ERR13 ZER XR CLEAR XR FLAG
BZE KVERL,STOPR ABORT IF ERRLIMIT IS ZERO
JSR ERTEX GET FAIL MESSAGE TEXT
*
* MERGE AFTER ERRLIMIT TEST
*
ERR14 DCV KVERL DECREMENT ERRLIMIT
MOV R$ERT,XL LOAD ERRTYPE TRACE POINTER
JSR KTREX GENERATE ERRTYPE TRACE IF REQUIRED
MOV R$COD,R$CNT SET CDBLK PTR FOR CONTINUATION
MOV FLPTR,XR SET PTR TO FAILURE OFFSET
MOV (XR),STXOF SAVE FAILURE OFFSET FOR CONTINUE
MOV R$SXC,XR LOAD SETEXIT CDBLK POINTER
BZE XR,ERRG4 CONTINUE IF NO SETEXIT TRAP
ZER R$SXC ELSE RESET TRAP
MOV =NULLS,STXVR RESET SETEXIT ARG TO NULL
MOV (XR),XL LOAD PTR TO CODE BLOCK ROUTINE
BRI XL EXECUTE FIRST TRAP STATEMENT
*
* INTERRUPTED PARTLY THROUGH A DUMP WHILST STORE IS IN A
* MESS SO DO A TIDY UP OPERATION. SEE DUMPR FOR DETAILS.
*
ERR15 MOV DMVCH,XR CHAIN HEAD FOR AFFECTED VRBLKS
BZE XR,ERR13 DONE IF ZERO
MOV (XR),DMVCH SET NEXT LINK AS CHAIN HEAD
JSR SETVR RESTORE VRGET FIELD
BRN ERR15 LOOP THROUGH CHAIN
*
* TAKE DRACONIAN STEPS FOR REPEATED FATAL ERRORS
*
ERR16 MOV ERRTF,WA ERROR CODE
MOV WA,KVERT PLACE ERROR CODE FOR ERMSG
MNZ XR IN CASE COMPILE TIME
BEQ STAGE,=STGIC,STOPR JUMP IF SO
BEQ STAGE,=STGCE,STOPR ALSO COMPILE TIME
ZER XR INDICATE EXECUTION
BRN STOPR TERMINATE RUN
*
ERRAF ERB 251,TOO MANY FATAL ERRORS
*
* HERE FOR GLOBAL ERROR JUMPS
*
ERRG1 JMG CMPLE
ERRG2 JMG CMPEE
ERRG3 JMG CMPCE
ERRG4 JMG LCNXE
TTL S P I T B O L -- HERE ENDETH THE CODE
*
* END OF ASSEMBLY
*
END END MACRO-SPITBOL ASSEMBLY