V10/cmd/spitbol/spitv35.ppmin
TTL S P I T B O L - REVISION HISTORY
EJC
* R E V I S I O N H I S T O R Y
* -------------------------------
*
*
* VERSION 3.5B (FEB 81... - SGD PATCHES)
* -----------------------------------
*
* SGD03 - ADDITION OF .CNCI AND SYSCI (INT->STRING
* SYSTEM ROUTINE OPTION)
* SGD04 - (06-MAY-1981) MODIFIED INILN TO 132
* SGD05 - (13-MAY-1981) INSERTED MISSING WTB AFTER SYSMM
* CALLS
* SGD06 - (25-MAY-1981) MERGED IN PROFILER PATCHES
* (NOT MARKED)
* SGD07 - (25-MAY-1981) MUCHO PATCHES TO PROFILER (MARKED,
* BUT BEST JUST TO EXTRACT ENMASSE)
* SGD08 - (25-MAY-1981) USE STRING LENGTH IN HASHS
* SGD09 - (25-MAY-1981) FIXED SERIOUS PARSER PROBLEM
* RELATING TO (X Y) ON LINE BEING VIEWED AS PATTERN
* MATCH. FIXED BY ADDITION OF NEW CMTYP VALUE
* C$CNP (CONCATENATION - NOT PATTERN MATCH)
* SGD10 - (01-AUG-1981) FIXED EXIT(N) RESPECIFICATION CODE
* TO PROPERLY OBSERVE HEADER SEMANTICS ON RETURN.
* SGD11 - (07-AUG-1981) BYPASS PRTPG CALL AT INITIALIZATION
* FOLLOWING COMPILATION IF NO OUTPUT GENERATED.
* THIS PREVENTS OUTPUT FILES CONSISTING OF THE
* HEADERS AND A FEW BLANK LINES WHEN THERE IS NO
* SOURCE LISTING AND NO COMPILATION STATS.
* ALSO FIX TIMSX INITIALIZATION IN SAME CODE.
* SGD12 - (17-AUG-1981) B$EFC CODE DID NOT CHECK FOR
* UNCONVERTED RESULT RETURNING NULL STRING. FIXED.
* SGDBF - ( NOV-1981) ADDED BUFFER TYPE AND SYMBOL CNBF
* SGD13 - (03-MAR-1982) LOAD PFVBL FIELD IN RETRN FOR
* RETURN TRACING. THIS WAS CAUSING BUG ON RETURN
* TRACES THAT TRIED TO ACCESS THE VARIABLE NAME
* SGD14 - ADDED CHAR FUNCTION. CHAR(N) RETURNS NTH
* CHARACTER OF HOST MACHINE CHARACTER SET.
* NOT CONDITIONALIZED OR MARKED.
* SGD15 - FIXED PROBLEM RELATING TO COMPILATION OF GOTO
* FIELDS CONTAINING SMALL INTEGERS (IN CONST SEC).
*
* REG01 - (XX-AUG-82)
* ADDED CFP$U TO EASE TRANSLATION ON SMALLER
* SYSTEMS - CONDITIONAL .CUCF
* ADDED LOWER CASE SUPPORT - CONDITIONAL .CULC
* ADDED SET I/O FUNCTION - CONDITIONAL .CUST
*
* REG02 - (XX-SEP-82)
* CHANGED INILN AND AND INILS TO 258
*
* REG03 - (XX-OCT-82)
* CONDITIONALIZED THE PAGE EJECT AFTER CALL TO SYSBX
* AND ADDED ANOTHER BEFORE CALL TO SYSBX, SO THAT,
* IF DESIRED BY THE IMPLEMENTOR, STANDARD OUTPUT
* WILL REFLECT ASSIGNMENTS MADE BY EXECUTING PROGRAM
* ONLY. CONDITIONAL .CUEJ CONTROLS - IF DEFINED
* EJECT IS BEFORE CALL TO SYSBX.
*
* REG04 - (XX-NOV-82)
* FIXED DIFFICULTIES WITH LISTINGS DURING EXECUTION
* WHEN NO LISTING GENERATED DURING COMPILATION.
*
* -LIST TO CODE() CAUSED BOMB. FIX IS TO RESET
* R$TTL AND R$STL TO NULLS NOT 0 AFTER COMPILATION.
* (LISTR AND LISTT EXPECT NULLS)
*
* WHEN LISTING AND STATISTICS ROUTED TO DIFFERENT
* FILE THAN EXECUTION OUTPUT, ERROR MESSAGE IS SENT
* TO EXECUTION OUTPUT (AND GETS SEPARATED FROM
* ... IN STATEMENT ... MSG). LABO1 CALLS SYSAX AND
* STOPR DOES NOT CALL SYSAX IF ENTERED FROM LABO1.
*
* REG05 - (XX-NOV-82)
* PREVENT CLEAR() FROM CLOBBERING PROTECTED VARIABLES
* AT LABEL SCLR5.
*
* REG06 - (XX-NOV-82)
* FIXED GTEXP FROM ACCEPTING TRAILING SEMICOLON OR
* COLON. NOT LEGAL WAY TO END AN EXPRESSION.
*
* VERSION 3.5A (OCT 79 - SGD PATCHES)
* -----------------------------------
*
* SGD01 - PATCH IN ASIGN TO FIX MULTIPLE TRAP BLOCK PROBLEM
* (ASG10+2)
* SGD02 - PATCH IN GTARR TO FIX NULL CONVERT (GTAR9+0)
*
TTL S P I T B O L -- BASIC INFORMATION
EJC
*
* GENERAL STRUCTURE
* -----------------
*
* THIS PROGRAM IS A TRANSLATOR FOR A VERSION OF THE SNOBOL4
* PROGRAMMING LANGUAGE. LANGUAGE DETAILS ARE CONTAINED IN
* THE MANUAL MACRO SPITBOL BY DEWAR AND MCCANN, TECHNICAL
* REPORT 90, UNIVERSITY OF LEEDS 1976. THE LANGUAGE
* IS IDENTICAL TO THAT IMPLEMENTED BY THE BTL TRANSLATOR
* (R. E. GRISWOLD ET AL.) WITH THE FOLLOWING EXCEPTIONS.
*
* 1) REDEFINITION OF STANDARD SYSTEM FUNCTIONS AND
* OPERATORS IS NOT PERMITTED.
*
* 2) THE VALUE FUNCTION IS NOT PROVIDED.
*
* 3) ACCESS TRACING IS PROVIDED IN ADDITION TO THE
* OTHER STANDARD TRACE MODES.
*
* 4) THE KEYWORD STFCOUNT IS NOT PROVIDED.
*
* 5) THE KEYWORD FULLSCAN IS NOT PROVIDED AND ALL PATTERN
* MATCHING TAKES PLACE IN FULLSCAN MODE (I.E. WITH NO
* HEURISTICS APPLIED).
*
* 6) A SERIES OF EXPRESSIONS SEPARATED BY COMMAS MAY
* BE GROUPED WITHIN PARENTHESES TO PROVIDE A SELECTION
* CAPABILITY. THE SEMANTICS ARE THAT THE SELECTION
* ASSUMES THE VALUE OF THE FIRST EXPRESSION WITHIN IT
* WHICH SUCCEEDS AS THEY ARE EVALUATED FROM THE LEFT.
* IF NO EXPRESSION SUCCEEDS THE ENTIRE STATEMENT FAILS
*
* 7) AN EXPLICIT PATTERN MATCHING OPERATOR IS PROVIDED.
* THIS IS THE BINARY QUERY (SEE GIMPEL SIGPLAN OCT 74)
*
* 8) THE ASSIGNMENT OPERATOR IS INTRODUCED AS IN THE
* GIMPEL REFERENCE.
*
* 9) THE EXIT FUNCTION IS PROVIDED FOR GENERATING LOAD
* MODULES - CF. GIMPELS SITBOL.
*
*
* THE METHOD USED IN THIS PROGRAM IS TO TRANSLATE THE
* SOURCE CODE INTO AN INTERNAL PSEUDO-CODE (SEE FOLLOWING
* SECTION). AN INTERPRETOR IS THEN USED TO EXECUTE THIS
* GENERATED PSEUDO-CODE. THE NATURE OF THE SNOBOL4 LANGUAGE
* IS SUCH THAT THE LATTER TASK IS MUCH MORE COMPLEX THAN
* THE ACTUAL TRANSLATION PHASE. ACCORDINGLY, NEARLY ALL THE
* CODE IN THE PROGRAM SECTION IS CONCERNED WITH THE ACTUAL
* EXECUTION OF THE SNOBOL4 PROGRAM.
EJC
*
* INTERPRETIVE CODE FORMAT
* ------------------------
*
* THE INTERPRETIVE PSEUDO-CODE CONSISTS OF A SERIES OF
* ADDRESS POINTERS. THE EXACT FORMAT OF THE CODE IS
* DESCRIBED IN CONNECTION WITH THE CDBLK FORMAT. THE
* PURPOSE OF THIS SECTION IS TO GIVE GENERAL INSIGHT INTO
* THE INTERPRETIVE APPROACH INVOLVED.
*
* THE BASIC FORM OF THE CODE IS RELATED TO REVERSE POLISH.
* IN OTHER WORDS, THE OPERANDS PRECEDE THE OPERATORS WHICH
* ARE ZERO ADDRESS OPERATORS. THERE ARE SOME EXCEPTIONS TO
* THESE RULES, NOTABLY THE UNARY NOT OPERATOR AND THE
* SELECTION CONSTRUCTION WHICH CLEARLY REQUIRE ADVANCE
* KNOWLEDGE OF THE OPERATOR INVOLVED.
*
* THE OPERANDS ARE MOVED TO THE TOP OF THE MAIN STACK AND
* THE OPERATORS ARE APPLIED TO THE TOP STACK ENTRIES. LIKE
* OTHER VERSIONS OF SPITBOL, THIS PROCESSOR DEPENDS ON
* KNOWING WHETHER OPERANDS ARE REQUIRED BY NAME OR BY VALUE
* AND MOVES THE APPROPRIATE OBJECT TO THE STACK. THUS NO
* NAME/VALUE CHECKS ARE INCLUDED IN THE OPERATOR CIRCUITS.
*
* THE ACTUAL POINTERS IN THE CODE POINT TO A BLOCK WHOSE
* FIRST WORD IS THE ADDRESS OF THE INTERPRETOR ROUTINE
* TO BE EXECUTED FOR THE CODE WORD.
*
* IN THE CASE OF OPERATORS, THE POINTER IS TO A WORD WHICH
* CONTAINS THE ADDRESS OF THE OPERATOR TO BE EXECUTED. IN
* THE CASE OF OPERANDS SUCH AS CONSTANTS, THE POINTER IS TO
* THE OPERAND ITSELF. ACCORDINGLY, ALL OPERANDS CONTAIN
* A FIELD WHICH POINTS TO THE ROUTINE TO LOAD THE VALUE OF
* THE OPERAND ONTO THE STACK. IN THE CASE OF A VARIABLE,
* THERE ARE THREE SUCH POINTERS. ONE TO LOAD THE VALUE,
* ONE TO STORE THE VALUE AND A THIRD TO JUMP TO THE LABEL.
*
* THE HANDLING OF FAILURE RETURNS DESERVES SPECIAL COMMENT.
* THE LOCATION FLPTR CONTAINS THE POINTER TO THE LOCATION
* ON THE MAIN STACK WHICH CONTAINS THE FAILURE RETURN
* WHICH IS IN THE FORM OF A BYTE OFFSET IN THE CURRENT
* CODE BLOCK (CDBLK OR EXBLK). WHEN A FAILURE OCCURS, THE
* STACK IS POPPED AS INDICATED BY THE SETTING OF FLPTR AND
* CONTROL IS PASSED TO THE APPROPRIATE LOCATION IN THE
* CURRENT CODE BLOCK WITH THE STACK POINTER POINTING TO THE
* FAILURE OFFSET ON THE STACK AND FLPTR UNCHANGED.
EJC
*
* INTERNAL DATA REPRESENTATIONS
* -----------------------------
*
* REPRESENTATION OF VALUES
*
* A VALUE IS REPRESENTED BY A POINTER TO A BLOCK WHICH
* DESCRIBES THE TYPE AND PARTICULARS OF THE DATA VALUE.
* IN GENERAL, A VARIABLE IS A LOCATION CONTAINING SUCH A
* POINTER (ALTHOUGH IN THE CASE OF TRACE ASSOCIATIONS THIS
* IS MODIFIED, SEE DESCRIPTION OF TRBLK).
*
* THE FOLLOWING IS A LIST OF POSSIBLE DATATYPES SHOWING THE
* TYPE OF BLOCK USED TO HOLD THE VALUE. THE DETAILS OF
* EACH BLOCK FORMAT ARE GIVEN LATER.
*
* DATATYPE BLOCK TYPE
* -------- ----------
*
*
* ARRAY ARBLK OR VCBLK
*
* CODE CDBLK
*
* EXPRESSION EXBLK OR SEBLK
*
* INTEGER ICBLK
*
* NAME NMBLK
*
* PATTERN P0BLK OR P1BLK OR P2BLK
*
* REAL RCBLK
*
* STRING SCBLK
*
* TABLE TBBLK
*
* PROGRAM DATATYPE PDBLK
EJC
*
* REPRESENTATION OF VARIABLES
* ---------------------------
*
* DURING THE COURSE OF EVALUATING EXPRESSIONS, IT IS
* NECESSARY TO GENERATE NAMES OF VARIABLES (FOR EXAMPLE
* ON THE LEFT SIDE OF A BINARY EQUALS OPERATOR). THESE ARE
* NOT TO BE CONFUSED WITH OBJECTS OF DATATYPE NAME WHICH
* ARE IN FACT VALUES.
*
* FROM A LOGICAL POINT OF VIEW, SUCH NAMES COULD BE SIMPLY
* REPRESENTED BY A POINTER TO THE APPROPRIATE VALUE CELL.
* HOWEVER IN THE CASE OF ARRAYS AND PROGRAM DEFINED
* DATATYPES, THIS WOULD VIOLATE THE RULE THAT THERE MUST BE
* NO POINTERS INTO THE MIDDLE OF A BLOCK IN DYNAMIC STORE.
* ACCORDINGLY, A NAME IS ALWAYS REPRESENTED BY A BASE AND
* OFFSET. THE BASE POINTS TO THE START OF THE BLOCK
* CONTAINING THE VARIABLE VALUE AND THE OFFSET IS THE
* OFFSET WITHIN THIS BLOCK IN BYTES. THUS THE ADDRESS
* OF THE ACTUAL VARIABLE IS DETERMINED BY ADDING THE BASE
* AND OFFSET VALUES.
*
* THE FOLLOWING ARE THE INSTANCES OF VARIABLES REPRESENTED
* IN THIS MANNER.
*
* 1) NATURAL VARIABLE BASE IS PTR TO VRBLK
* OFFSET IS *VRVAL
*
* 2) TABLE ELEMENT BASE IS PTR TO TEBLK
* OFFSET IS *TEVAL
*
* 3) ARRAY ELEMENT BASE IS PTR TO ARBLK
* OFFSET IS OFFSET TO ELEMENT
*
* 4) VECTOR ELEMENT BASE IS PTR TO VCBLK
* OFFSET IS OFFSET TO ELEMENT
*
* 5) PROG DEF DTP BASE IS PTR TO PDBLK
* OFFSET IS OFFSET TO FIELD VALUE
*
* IN ADDITION THERE ARE TWO CASES OF OBJECTS WHICH ARE
* LIKE VARIABLES BUT CANNOT BE HANDLED IN THIS MANNER.
* THESE ARE CALLED PSEUDO-VARIABLES AND ARE REPRESENTED
* WITH A SPECIAL BASE POINTER AS FOLLOWS=
*
* EXPRESSION VARIABLE PTR TO EVBLK (SEE EVBLK)
*
* KEYWORD VARIABLE PTR TO KVBLK (SEE KVBLK)
*
* PSEUDO-VARIABLES ARE HANDLED AS SPECIAL CASES BY THE
* ACCESS PROCEDURE (ACESS) AND THE ASSIGNMENT PROCEDURE
* (ASIGN). SEE THESE TWO PROCEDURES FOR DETAILS.
EJC
*
* ORGANIZATION OF DATA AREA
* -------------------------
*
*
* THE DATA AREA IS DIVIDED INTO TWO REGIONS.
*
* STATIC AREA
*
* THE STATIC AREA BUILDS UP FROM THE BOTTOM AND CONTAINS
* DATA AREAS WHICH ARE ALLOCATED DYNAMICALLY BUT ARE NEVER
* DELETED OR MOVED AROUND. THE MACRO-PROGRAM ITSELF
* USES THE STATIC AREA FOR THE FOLLOWING.
*
* 1) ALL VARIABLE BLOCKS (VRBLK).
*
* 2) THE HASH TABLE FOR VARIABLE BLOCKS.
*
* 3) MISCELLANEOUS BUFFERS AND WORK AREAS (SEE PROGRAM
* INITIALIZATION SECTION).
*
* IN ADDITION, THE SYSTEM PROCEDURES MAY USE THIS AREA FOR
* INPUT/OUTPUT BUFFERS, EXTERNAL FUNCTIONS ETC. SPACE IN
* THE STATIC REGION IS ALLOCATED BY CALLING PROCEDURE ALOST
*
* THE FOLLOWING GLOBAL VARIABLES DEFINE THE CURRENT
* LOCATION AND SIZE OF THE STATIC AREA.
*
* STATB ADDRESS OF START OF STATIC AREA
* STATE ADDRESS+1 OF LAST WORD IN AREA.
*
* THE MINIMUM SIZE OF STATIC IS GIVEN APPROXIMATELY BY
* 12 + *E$HNB + *E$STS + SPACE FOR ALPHABET STRING
* AND STANDARD PRINT BUFFER.
EJC
*
* DYNAMIC AREA
*
* THE DYNAMIC AREA IS BUILT UPWARDS IN MEMORY AFTER THE
* STATIC REGION. DATA IN THIS AREA MUST ALL BE IN STANDARD
* BLOCK FORMATS SO THAT IT CAN BE PROCESSED BY THE GARBAGE
* COLLECTOR (PROCEDURE GBCOL). GBCOL COMPACTS BLOCKS DOWN
* IN THIS REGION AS REQUIRED BY SPACE EXHAUSTION AND CAN
* ALSO MOVE ALL BLOCKS UP TO ALLOW FOR EXPANSION OF THE
* STATIC REGION.
* WITH THE EXCEPTION OF TABLES AND ARRAYS, NO SPITBOL
* OBJECT ONCE BUILT IN DYNAMIC MEMORY IS EVER SUBSEQUENTLY
* MODIFIED. OBSERVING THIS RULE NECESSITATES A COPYING
* ACTION DURING STRING AND PATTERN CONCATENATION.
*
* GARBAGE COLLECTION IS FUNDAMENTAL TO THE ALLOCATION OF
* SPACE FOR VALUES. SPITBOL USES A VERY EFFICIENT GARBAGE
* COLLECTOR WHICH INSISTS THAT POINTERS INTO DYNAMIC STORE
* SHOULD BE IDENTIFIABLE WITHOUT USE OF BIT TABLES,
* MARKER BITS ETC. TO SATISFY THIS REQUIREMENT, DYNAMIC
* MEMORY MUST NOT START AT TOO LOW AN ADDRESS AND LENGTHS
* OF ARRAYS, TABLES, STRINGS, CODE AND EXPRESSION BLOCKS
* MAY NOT EXCEED THE NUMERICAL VALUE OF THE LOWEST DYNAMIC
* ADDRESS. TO AVOID EITHER PENALIZING USERS WITH MODEST
* REQUIREMENTS OR RESTRICTING THOSE WITH GREATER NEEDS ON
* HOST SYSTEMS WHERE DYNAMIC MEMORY IS ALLOCATED IN LOW
* ADDRESSES, THE MINIMUM DYNAMIC ADDRESS MAY BE SPECIFIED
* SUFFICIENTLY HIGH TO PERMIT ARBITRARILY LARGE SPITBOL
* OBJECTS TO BE CREATED ( WITH THE POSSIBILITY IN EXTREME
* CASES OF WASTING LARGE AMOUNTS OF MEMORY BELOW THE
* START ADDRESS). THIS MINIMUM VALUE IS MADE AVAILABLE
* IN VARIABLE MXLEN BY A SYSTEM ROUTINE, SYSMX.
* ALTERNATIVELY SYSMX MAY INDICATE THAT A
* DEFAULT MAY BE USED IN WHICH DYNAMIC IS PLACED
* AT THE LOWEST POSSIBLE ADDRESS FOLLOWING STATIC.
*
* THE FOLLOWING GLOBAL WORK CELLS DEFINE THE LOCATION AND
* LENGTH OF THE DYNAMIC AREA.
*
* DNAMB START OF DYNAMIC AREA
* DNAMP NEXT AVAILABLE LOCATION
* DNAME LAST AVAILABLE LOCATION + 1
*
* DNAMB IS ALWAYS HIGHER THAN STATE SINCE THE ALOST
* PROCEDURE MAINTAINS SOME EXPANSION SPACE ABOVE STATE.
* *** DNAMB MUST NEVER BE PERMITTED TO HAVE A VALUE LESS
* THAN THAT IN MXLEN ***
*
* SPACE IN THE DYNAMIC REGION IS ALLOCATED BY THE ALLOC
* PROCEDURE. THE DYNAMIC REGION MAY BE USED BY SYSTEM
* PROCEDURES PROVIDED THAT ALL THE RULES ARE OBEYED.
EJC
*
* REGISTER USAGE
* --------------
*
* (CP) CODE POINTER REGISTER. USED TO
* HOLD A POINTER TO THE CURRENT
* LOCATION IN THE INTERPRETIVE PSEUDO
* CODE (I.E. PTR INTO A CDBLK).
*
* (XL,XR) GENERAL INDEX REGISTERS. USUALLY
* USED TO HOLD POINTERS TO BLOCKS IN
* DYNAMIC STORAGE. AN IMPORTANT
* RESTRICTION IS THAT THE VALUE IN
* XL MUST BE COLLECTABLE FOR
* A GARBAGE COLLECT CALL. A VALUE
* IS COLLECTABLE IF IT EITHER POINTS
* OUTSIDE THE DYNAMIC AREA, OR IF IT
* POINTS TO THE START OF A BLOCK IN
* THE DYNAMIC AREA.
*
* (XS) STACK POINTER. USED TO POINT TO
* THE STACK FRONT. THE STACK MAY
* BUILD UP OR DOWN AND IS USED
* TO STACK SUBROUTINE RETURN POINTS
* AND OTHER RECURSIVELY SAVED DATA.
*
* (XT) AN ALTERNATIVE NAME FOR XL DURING
* ITS USE IN ACCESSING STACKED ITEMS.
*
* (WA,WB,WC) GENERAL WORK REGISTERS. CANNOT BE
* USED FOR INDEXING, BUT MAY HOLD
* VARIOUS TYPES OF DATA.
*
* (IA) USED FOR ALL SIGNED INTEGER
* ARITHMETIC, BOTH THAT USED BY THE
* TRANSLATOR AND THAT ARISING FROM
* USE OF SNOBOL4 ARITHMETIC OPERATORS
*
* (RA) REAL ACCUMULATOR. USED FOR ALL
* FLOATING POINT ARITHMETIC.
EJC
*
* SPITBOL CONDITIONAL ASSEMBLY SYMBOLS
* ------------------------------------
*
* IN THE SPITBOL TRANSLATOR, THE FOLLOWING CONDITIONAL
* ASSEMBLY SYMBOLS ARE REFERRED TO. TO INCORPORATE THE
* FEATURES REFERRED TO, THE MINIMAL SOURCE SHOULD BE
* PREFACED BY SUITABLE CONDITIONAL ASSEMBLY SYMBOL
* DEFINITIONS.
* IN ALL CASES IT IS PERMISSIBLE TO DEFAULT THE DEFINITIONS
* IN WHICH CASE THE ADDITIONAL FEATURES WILL BE OMITTED
* FROM THE TARGET CODE.
*
* .CASL DEFINE TO INCLUDE 26 SHIFTED LETTRS
* .CAHT DEFINE TO INCLUDE HORIZONTAL TAB
* .CAVT DEFINE TO INCLUDE VERTICAL TAB
* .CIOD IF DEFINED, DEFAULT DELIMITER IS
* NOT USED IN PROCESSING 3RD ARG OF
* INPUT() AND OUTPUT()
* .CNBT DEFINE TO OMIT BATCH INITIALISATION
* .CNCI DEFINE TO ENABLE SYSCI ROUTINE
* .CNEX DEFINE TO OMIT EXIT() CODE.
* .CNLD DEFINE TO OMIT LOAD() CODE.
* .CNPF DEFINE TO OMIT PROFILE STUFF
* .CNRA DEFINE TO OMIT ALL REAL ARITHMETIC
* .CNSR DEFINE TO OMIT SORT, RSORT
* .CSAX DEFINE IF SYSAX IS TO BE CALLED
* .CSN6 DEFINE TO PAD STMT NOS TO 6 CHARS
* .CSN8 DEFINE TO PAD STMT NOS TO 8 CHARS
* .CUCF DEFINE TO INCLUDE CFP$U
* .CULC DEFINE TO INCLUDE &CASE (LC NAMES)
* .CUST DEFINE TO INCLUDE SET() CODE
TTL S P I T B O L -- PROCEDURES SECTION
*
* THIS SECTION STARTS WITH DESCRIPTIONS OF THE OPERATING
* SYSTEM DEPENDENT PROCEDURES WHICH ARE USED BY THE SPITBOL
* TRANSLATOR. ALL SUCH PROCEDURES HAVE FIVE LETTER NAMES
* BEGINNING WITH SYS. THEY ARE LISTED IN ALPHABETICAL
* ORDER.
* ALL PROCEDURES HAVE A SPECIFICATION CONSISTING OF A
* MODEL CALL, PRECEDED BY A POSSIBLY EMPTY LIST OF REGISTER
* CONTENTS GIVING PARAMETERS AVAILABLE TO THE PROCEDURE AND
* FOLLOWED BY A POSSIBLY EMPTY LIST OF REGISTER CONTENTS
* REQUIRED ON RETURN FROM THE CALL OR WHICH MAY HAVE HAD
* THEIR CONTENTS DESTROYED. ONLY THOSE REGISTERS EXPLICITLY
* MENTIONED IN THE LIST AFTER THE CALL MAY HAVE THEIR
* VALUES CHANGED.
* THE SEGMENT OF CODE PROVIDING THE EXTERNAL PROCEDURES IS
* CONVENIENTLY REFERRED TO AS OSINT (OPERATING SYSTEM
* INTERFACE). THE SYSXX PROCEDURES IT CONTAINS PROVIDE
* FACILITIES NOT USUALLY AVAILABLE AS PRIMITIVES IN
* ASSEMBLY LANGUAGES. FOR PARTICULAR TARGET MACHINES,
* IMPLEMENTORS MAY CHOOSE FOR SOME MINIMAL OPCODES WHICH
* DO NOT HAVE REASONABLY DIRECT TRANSLATIONS, TO USE CALLS
* OF ADDITIONAL PROCEDURES WHICH THEY PROVIDE IN OSINT.
* E.G. MWB OR TRC MIGHT BE TRANSLATED AS JSR SYSMB,
* JSR SYSTC IN SOME IMPLEMENTATIONS.
*
* IN THE DESCRIPTIONS, REFERENCE IS MADE TO --BLK
* FORMATS (-- = A PAIR OF LETTERS). SEE THE SPITBOL
* DEFINITIONS SECTION FOR DETAILED DESCRIPTIONS OF ALL
* SUCH BLOCK FORMATS EXCEPT FCBLK FOR WHICH SYSFC SHOULD
* BE CONSULTED.
*
* SECTION 0 CONTAINS INP,INR SPECIFICATIONS OF INTERNAL
* PROCEDURES,ROUTINES. THIS GIVES A SINGLE PASS TRANSLATOR
* INFORMATION MAKING IT EASY TO GENERATE ALTERNATIVE CALLS
* IN THE TRANSLATION OF JSR-S FOR PROCEDURES OF DIFFERENT
* TYPES IF THIS PROVES NECESSARY.
*
SEC START OF PROCEDURES SECTION
EJC
*
* SYSAX -- AFTER EXECUTION
*
SYSAX EXP DEFINE EXTERNAL ENTRY POINT
*
* IF THE CONDITIONAL ASSEMBLY SYMBOL .CSAX IS DEFINED,
* THIS ROUTINE IS CALLED IMMEDIATELY AFTER EXECUTION AND
* BEFORE PRINTING OF EXECUTION STATISTICS OR DUMP OUTPUT.
* PURPOSE OF CALL IS FOR IMPLEMENTOR TO DETERMINE AND
* IF THE CALL IS NOT REQUIRED IT WILL BE OMITTED IF .CSAX
* IS UNDEFINED. IN THIS CASE SYSAX NEED NOT BE CODED.
*
* JSR SYSAX CALL AFTER EXECUTION
EJC
*
* SYSBX -- BEFORE EXECUTION
*
SYSBX EXP DEFINE EXTERNAL ENTRY POINT
*
* CALLED AFTER INITIAL SPITBOL COMPILATION AND BEFORE
* COMMENCING EXECUTION IN CASE OSINT NEEDS
* TO ASSIGN FILES OR PERFORM OTHER NECESSARY SERVICES.
* OSINT MAY ALSO CHOOSE TO SEND A MESSAGE TO ONLINE
* TERMINAL (IF ANY) INDICATING THAT EXECUTION IS STARTING.
*
* JSR SYSBX CALL BEFORE EXECUTION STARTS
EJC
*
* SYSDC -- DATE CHECK
*
SYSDC EXP DEFINE EXTERNAL ENTRY POINT
*
* SYSDC IS CALLED TO CHECK THAT THE EXPIRY DATE FOR A TRIAL
* VERSION OF SPITBOL IS UNEXPIRED.
*
* JSR SYSDC CALL TO CHECK DATE
* RETURN ONLY IF DATE IS OK
EJC
*
* SYSDM -- DUMP CORE
*
SYSDM EXP DEFINE EXTERNAL ENTRY POINT
*
* SYSDM IS CALLED BY A SPITBOL PROGRAM CALL OF DUMP(N) WITH
* N GE 3. ITS PURPOSE IS TO PROVIDE A CORE DUMP.
* N COULD HOLD AN ENCODING OF THE START ADRS FOR DUMP AND
* AMOUNT TO BE DUMPED E.G. N = 256*A + S , S = START ADRS
* IN KILOWORDS, A = KILOWORDS TO DUMP
*
* (XR) PARAMETER N OF CALL DUMP(N)
* JSR SYSDM CALL TO ENTER ROUTINE
EJC
*
* SYSDT -- GET CURRENT DATE
*
SYSDT EXP DEFINE EXTERNAL ENTRY POINT
*
* SYSDT IS USED TO OBTAIN THE CURRENT DATE. THE DATE IS
* RETURNED AS A CHARACTER STRING IN ANY FORMAT APPROPRIATE
* TO THE OPERATING SYSTEM IN USE. IT MAY ALSO CONTAIN THE
* CURRENT TIME OF DAY. SYSDT IS USED TO IMPLEMENT THE
* SNOBOL4 FUNCTION DATE.
*
* JSR SYSDT CALL TO GET DATE
* (XL) POINTER TO BLOCK CONTAINING DATE
*
* THE FORMAT OF THE BLOCK IS LIKE AN SCBLK EXCEPT THAT
* THE FIRST WORD NEED NOT BE SET. THE RESULT IS COPIED
* INTO SPITBOL DYNAMIC MEMORY ON RETURN.
EJC
*
* SYSEF -- EJECT FILE
*
SYSEF EXP DEFINE EXTERNAL ENTRY POINT
*
* SYSEF IS USED TO WRITE A PAGE EJECT TO A NAMED FILE. IT
* MAY ONLY BE USED FOR FILES WHERE THIS CONCEPT MAKES
* SENSE. NOTE THAT SYSEF IS NOT NORMALLY USED FOR THE
* STANDARD OUTPUT FILE (SEE SYSEP).
*
* (WA) PTR TO FCBLK OR ZERO
* (XR) EJECT ARGUMENT (SCBLK PTR)
* JSR SYSEF CALL TO EJECT FILE
* PPM LOC RETURN HERE IF FILE DOES NOT EXIST
* PPM LOC RETURN HERE IF INAPPROPRIATE FILE
* PPM LOC RETURN HERE IF I/O ERROR
EJC
*
* SYSEJ -- END OF JOB
*
SYSEJ EXP DEFINE EXTERNAL ENTRY POINT
*
* SYSEJ IS CALLED ONCE AT THE END OF EXECUTION TO
* TERMINATE THE RUN. THE SIGNIFICANCE OF THE ABEND AND
* CODE VALUES IS SYSTEM DEPENDENT. IN GENERAL, THE CODE
* VALUE SHOULD BE MADE AVAILABLE FOR TESTING, AND THE
* ABEND VALUE SHOULD CAUSE SOME POST-MORTEM ACTION SUCH AS
* A DUMP. NOTE THAT SYSEJ DOES NOT RETURN TO ITS CALLER.
* SEE SYSXI FOR DETAILS OF FCBLK CHAIN
*
* (WA) VALUE OF ABEND KEYWORD
* (WB) VALUE OF CODE KEYWORD
* (XL) O OR PTR TO HEAD OF FCBLK CHAIN
* JSR SYSEJ CALL TO END JOB
*
* THE FOLLOWING SPECIAL VALUES ARE USED AS CODES IN (WB)
* 999 EXECUTION SUPPRESSED
* 998 STANDARD OUTPUT FILE FULL OR UNAVAILABLE IN A SYSXI
* LOAD MODULE. IN THESE CASES (WA) CONTAINS THE NUMBER
* OF THE STATEMENT CAUSING PREMATURE TERMINATION.
EJC
*
* SYSEM -- GET ERROR MESSAGE TEXT
*
SYSEM EXP DEFINE EXTERNAL ENTRY POINT
*
* SYSEM IS USED TO OBTAIN THE TEXT OF ERR, ERB CALLS IN THE
* SOURCE PROGRAM GIVEN THE ERROR CODE NUMBER. IT IS ALLOWED
* TO RETURN A NULL STRING IF THIS FACILITY IS UNAVAILABLE.
*
* (WA) ERROR CODE NUMBER
* JSR SYSEM CALL TO GET TEXT
* (XR) TEXT OF MESSAGE
*
* THE RETURNED VALUE IS A POINTER TO A BLOCK IN SCBLK
* FORMAT EXCEPT THAT THE FIRST WORD NEED NOT BE SET. THE
* STRING IS COPIED INTO DYNAMIC MEMORY ON RETURN.
* IF THE NULL STRING IS RETURNED EITHER BECAUSE SYSEM DOES
* NOT PROVIDE ERROR MESSAGE TEXTS OR BECAUSE WA IS OUT OF
* RANGE, SPITBOL WILL PRINT THE STRING STORED IN ERRTEXT
* KEYWORD.
EJC
*
* SYSEN -- ENDFILE
*
SYSEN EXP DEFINE EXTERNAL ENTRY POINT
*
* SYSEN IS USED TO IMPLEMENT THE SNOBOL4 FUNCTION ENDFILE.
* THE MEANING IS SYSTEM DEPENDENT. IN GENERAL, ENDFILE
* IMPLIES THAT NO FURTHER I/O OPERATIONS WILL BE PERFORMED,
* BUT DOES NOT GUARANTEE THIS TO BE THE CASE. THE FILE
* SHOULD BE CLOSED AFTER THE CALL, A SUBSEQUENT READ
* OR WRITE MAY REOPEN THE FILE AT THE START OR IT MAY BE
* NECESSARY TO REOPEN THE FILE VIA SYSIO.
*
* (WA) PTR TO FCBLK OR ZERO
* (XR) ENDFILE ARGUMENT (SCBLK PTR)
* JSR SYSEN CALL TO ENDFILE
* PPM LOC RETURN HERE IF FILE DOES NOT EXIST
* PPM LOC RETURN HERE IF ENDFILE NOT ALLOWED
* PPM LOC RETURN HERE IF I/O ERROR
* (WA,WB) DESTROYED
*
* THE SECOND ERROR RETURN IS USED FOR FILES FOR WHICH
* ENDFILE IS NOT PERMITTED. FOR EXAMPLE, IT MAY BE EXPECTED
* THAT THE STANDARD INPUT AND OUTPUT FILES ARE IN THIS
* CATEGORY.
EJC
*
* SYSEP -- EJECT PRINTER PAGE
*
SYSEP EXP DEFINE EXTERNAL ENTRY POINT
*
* SYSEP IS CALLED TO PERFORM A PAGE EJECT ON THE STANDARD
* PRINTER OUTPUT FILE (CORRESPONDING TO SYSPR OUTPUT).
*
* JSR SYSEP CALL TO EJECT PRINTER OUTPUT
EJC
*
* SYSEX -- CALL EXTERNAL FUNCTION
*
SYSEX EXP DEFINE EXTERNAL ENTRY POINT
*
* SYSEX IS CALLED TO PASS CONTROL TO AN EXTERNAL FUNCTION
* PREVIOUSLY LOADED WITH A CALL TO SYSLD.
*
* (XS) POINTER TO ARGUMENTS ON STACK
* (XL) POINTER TO CONTROL BLOCK (EFBLK)
* (WA) NUMBER OF ARGUMENTS ON STACK
* JSR SYSEX CALL TO PASS CONTROL TO FUNCTION
* PPM LOC RETURN HERE IF FUNCTION CALL FAILS
* (XS) POPPED PAST ARGUMENTS
* (XR) RESULT RETURNED
*
* THE ARGUMENTS ARE STORED ON THE STACK WITH
* THE LAST ARGUMENT AT 0(XS). ON RETURN, XS
* IS POPPED PAST THE ARGUMENTS.
*
* THE FORM OF THE ARGUMENTS AS PASSED IS THAT USED IN THE
* SPITBOL TRANSLATOR (SEE DEFINITIONS AND DATA STRUCTURES
* SECTION). THE CONTROL BLOCK FORMAT IS ALSO DESCRIBED
* (UNDER EFBLK) IN THIS SECTION.
*
* THERE ARE TWO WAYS OF RETURNING A RESULT.
*
* 1) RETURN A POINTER TO A BLOCK IN DYNAMIC STORAGE. THIS
* BLOCK MUST BE IN EXACTLY CORRECT FORMAT, INCLUDING
* THE FIRST WORD. ONLY FUNCTIONS WRITTEN WITH INTIMATE
* KNOWLEDGE OF THE SYSTEM WILL RETURN IN THIS WAY.
*
* 2) STRING, INTEGER AND REAL RESULTS MAY BE RETURNED BY
* POINTING TO A PSEUDO-BLOCK OUTSIDE DYNAMIC MEMORY.
* THIS BLOCK IS IN ICBLK, RCBLK OR SCBLK FORMAT EXCEPT
* THAT THE FIRST WORD WILL BE OVERWRITTEN
* BY A TYPE WORD ON RETURN AND SO NEED NOT
* BE CORRECTLY SET. SUCH A RESULT IS
* COPIED INTO MAIN STORAGE BEFORE PROCEEDING.
* UNCONVERTED RESULTS MAY SIMILARLY BE RETURNED IN A
* PSEUDO-BLOCK WHICH IS IN CORRECT FORMAT INCLUDING
* TYPE WORD RECOGNISABLE BY GARBAGE COLLECTOR SINCE
* BLOCK IS COPIED INTO DYNAMIC MEMORY.
EJC
*
* SYSFC -- FILE CONTROL BLOCK ROUTINE
*
SYSFC EXP DEFINE EXTERNAL ENTRY POINT
*
* SEE ALSO SYSIO
* INPUT AND OUTPUT HAVE 3 ARGUMENTS REFERRED TO AS SHOWN
* INPUT(VARIABLE NAME,FILE ARG1,FILE ARG2)
* OUTPUT(VARIABLE NAME,FILE ARG1,FILE ARG2)
* FILE ARG1 MAY BE AN INTEGER OR STRING USED TO IDENTIFY
* AN I/O CHANNEL. IT IS CONVERTED TO A STRING FOR CHECKING.
* THE EXACT SIGNIFICANCE OF FILE ARG2
* IS NOT RIGOROUSLY PRESCRIBED BUT TO IMPROVE PORTABILITY,
* THE SCHEME DESCRIBED IN THE SPITBOL USER MANUAL
* SHOULD BE ADOPTED WHEN POSSIBLE. THE PREFERRED FORM IS
* A STRING $F$,R$R$,C$C$,I$I$,...,Z$Z$ WHERE
* $F$ IS AN OPTIONAL FILE NAME WHICH IS PLACED FIRST.
* REMAINING ITEMS MAY BE OMITTED OR INCLUDED IN ANY ORDER.
* $R$ IS MAXIMUM RECORD LENGTH
* $C$ IS A CARRIAGE CONTROL CHARACTER OR CHARACTER STRING
* $I$ IS SOME FORM OF CHANNEL IDENTIFICATION USED IN THE
* ABSENCE OF $F$ TO ASSOCIATE THE VARIABLE
* WITH A FILE ALLOCATED DYNAMICALLY BY JCL COMMANDS AT
* SPITBOL LOAD TIME.
* ,...,Z$Z$ ARE ADDITIONAL FIELDS.
* IF , (COMMA) CANNOT BE USED AS A DELIMITER, .CIOD
* SHOULD BE DEFINED TO INTRODUCE BY CONDITIONAL ASSEMBLY
* ANOTHER DELIMITER (SEE
* IODEL EQU *
* EARLY IN DEFINITIONS SECTION).
* SYSFC IS CALLED WHEN A VARIABLE IS INPUT OR OUTPUT
* ASSOCIATED TO CHECK FILE ARG1 AND FILE ARG2 AND
* TO REPORT WHETHER AN FCBLK (FILE CONTROL
* BLOCK) IS NECESSARY AND IF SO WHAT SIZE IT SHOULD BE.
* THIS MAKES IT POSSIBLE FOR SPITBOL RATHER THAN OSINT TO
* ALLOCATE SUCH A BLOCK IN DYNAMIC MEMORY IF REQUIRED
* OR ALTERNATIVELY IN STATIC MEMORY.
* THE SIGNIFICANCE OF AN FCBLK , IF ONE IS REQUESTED, IS
* ENTIRELY UP TO THE SYSTEM INTERFACE. THE ONLY RESTRICTION
* IS THAT IF THE FCBLK SHOULD APPEAR TO LIE IN DYNAMIC
* MEMORY , POINTERS TO IT SHOULD BE PROPER POINTERS TO
* THE START OF A RECOGNISABLE AND GARBAGE COLLECTABLE
* BLOCK (THIS CONDITION WILL BE MET IF SYSFC REQUESTS
* SPITBOL TO PROVIDE AN FCBLK).
* AN OPTION IS PROVIDED FOR OSINT TO RETURN A POINTER IN
* XL TO AN FCBLK WHICH IT PRIVATELY ALLOCATED. THIS PTR
* WILL BE MADE AVAILABLE WHEN I/O OCCURS LATER.
* PRIVATE FCBLKS MAY HAVE ARBITRARY CONTENTS AND SPITBOL
* STORES NOTHING IN THEM.
EJC
* THE REQUESTED SIZE FOR AN FCBLK IN DYNAMIC MEMORY
* SHOULD ALLOW A 2 WORD OVERHEAD FOR BLOCK TYPE AND
* LENGTH FIELDS. INFORMATION SUBSEQUENTLY STORED IN THE
* REMAINING WORDS MAY BE ARBITRARY IF AN XNBLK (EXTERNAL
* NON-RELOCATABLE BLOCK) IS REQUESTED. IF THE REQUEST IS
* FOR AN XRBLK (EXTERNAL RELOCATABLE BLOCK) THE
* CONTENTS OF WORDS SHOULD BE COLLECTABLE (I.E. ANY
* APPARENT POINTERS INTO DYNAMIC SHOULD BE GENUINE BLOCK
* POINTERS). THESE RESTRICTIONS DO NOT APPLY IF AN FCBLK
* IS ALLOCATED OUTSIDE DYNAMIC OR IS NOT ALLOCATED AT ALL.
* IF AN FCBLK IS REQUESTED, ITS FIELDS WILL BE INITIALISED
* TO ZERO BEFORE ENTRY TO SYSIO WITH THE EXCEPTION OF
* WORDS 0 AND 1 IN WHICH THE BLOCK TYPE AND LENGTH
* FIELDS ARE PLACED FOR FCBLKS IN DYNAMIC MEMORY ONLY.
* FOR THE POSSIBLE USE OF SYSEJ AND SYSXI, IF FCBLKS
* ARE USED, A CHAIN IS BUILT SO THAT THEY MAY ALL BE
* FOUND - SEE SYSXI FOR DETAILS.
* IF BOTH FILE ARG1 AND FILE ARG2 ARE NULL, CALLS OF SYSFC
* AND SYSIO ARE OMITTED.
* IF FILE ARG1 IS NULL (STANDARD INPUT/OUTPUT FILE), SYSFC
* IS CALLED TO CHECK NON-NULL FILE ARG2 BUT ANY REQUEST
* FOR AN FCBLK WILL BE IGNORED, SINCE SPITBOL HANDLES THE
* STANDARD FILES SPECIALLY AND CANNOT READILY KEEP FCBLK
* POINTERS FOR THEM.
* FILEARG1 IS TYPE CHECKED BY SPITBOL SO FURTHER CHECKING
* MAY BE UNNECCESSARY IN MANY IMPLEMENTATIONS.
* FILE ARG2 IS PASSED SO THAT SYSFC MAY ANALYSE AND
* CHECK IT. HOWEVER TO ASSIST IN THIS, SPITBOL ALSO PASSES
* ON THE STACK THE COMPONENTS OF THIS ARGUMENT WITH
* FILE NAME, $F$ (OTHERWISE NULL) EXTRACTED AND STACKED
* FIRST.
* THE OTHER FIELDS, IF ANY, ARE EXTRACTED AS SUBSTRINGS,
* POINTERS TO THEM ARE STACKED AND A COUNT OF ALL ITEMS
* STACKED IS PLACED IN WC. IF AN FCBLK WAS EARLIER
* ALLOCATED AND POINTED TO VIA FILE ARG1, SYSFC IS ALSO
* PASSED A POINTER TO THIS FCBLK.
*
* (XL) FILE ARG1 SCBLK PTR (2ND ARG)
* (XR) FILEARG2 (3RD ARG) OR NULL
* -(XS)...-(XS) SCBLKS FOR $F$,$R$,$C$,...
* (WC) NO. OF STACKED SCBLKS ABOVE
* (WA) EXISTING FILE ARG1 FCBLK PTR OR 0
* (WB) 0/3 FOR INPUT/OUTPUT ASSOCN
* JSR SYSFC CALL TO CHECK NEED FOR FCBLK
* PPM LOC INVALID FILE ARGUMENT
* (XS) POPPED (WC) TIMES
* (WA NON ZERO) BYTE SIZE OF REQUESTED FCBLK
* (WA=0,XL NON ZERO) PRIVATE FCBLK PTR IN XL
* (WA=XL=0) NO FCBLK WANTED, NO PRIVATE FCBLK
* (WC) 0/1/2 REQUEST ALLOC OF XRBLK/XNBLK
* /STATIC BLOCK FOR USE AS FCBLK
* (WB) DESTROYED
EJC
*
* SYSHS -- GIVE ACCESS TO HOST COMPUTER FEATURES
*
SYSHS EXP DEFINE EXTERNAL ENTRY POINT
*
* PROVIDES MEANS FOR IMPLEMENTING SPECIAL FEATURES
* ON DIFFERENT HOST COMPUTERS. THE ONLY DEFINED ENTRY IS
* THAT WHERE ALL ARGUMENTS ARE NULL IN WHICH CASE SYSHS
* RETURNS AN SCBLK CONTAINING NAME OF COMPUTER,
* NAME OF OPERATING SYSTEM AND NAME OF SITE SEPARATED BY
* COLONS. THE SCBLK NEED NOT HAVE A CORRECT FIRST FIELD
* AS THIS IS SUPPLIED ON COPYING STRING TO DYNAMIC MEMORY.
* SPITBOL DOES NO ARGUMENT CHECKING BUT DOES PROVIDE A
* SINGLE ERROR RETURN FOR ARGUMENTS CHECKED AS ERRONEOUS
* BY OSINT. IT ALSO PROVIDES A SINGLE EXECUTION ERROR
* RETURN. IF THESE ARE INADEQUATE, USE MAY BE MADE OF THE
* MINIMAL ERROR SECTION DIRECT AS DESCRIBED IN MINIMAL
* DOCUMENTATION, SECTION 10.
* SEVERAL NON-ERROR RETURNS ARE PROVIDED. THE FIRST
* CORRESPONDS TO THE DEFINED ENTRY OR, FOR IMPLEMENTATION
* DEFINED ENTRIES, ANY STRING MAY BE RETURNED. THE OTHERS
* PERMIT RESPECTIVELY, RETURN A NULL RESULT, RETURN WITH A
* RESULT TO BE STACKED WHICH IS POINTED AT BY XR, AND A
* RETURN CAUSING SPITBOL STATEMENT FAILURE. IF A RETURNED
* RESULT IS IN DYNAMIC MEMORY IT MUST OBEY GARBAGE
* COLLECTOR RULES. THE ONLY RESULTS COPIED ON RETURN
* ARE STRINGS RETURNED VIA PPM LOC3 RETURN.
*
* (WA) ARGUMENT 1
* (XL) ARGUMENT 2
* (XR) ARGUMENT 3
* JSR SYSHS CALL TO GET HOST INFORMATION
* PPM LOC1 ERRONEOUS ARG
* PPM LOC2 EXECUTION ERROR
* PPM LOC3 SCBLK PTR IN XL OR 0 IF UNAVAILABLE
* PPM LOC4 RETURN A NULL RESULT
* PPM LOC5 RETURN RESULT IN XR
* PPM LOC6 CAUSE STATEMENT FAILURE
EJC
*
* SYSID -- RETURN SYSTEM IDENTIFICATION
*
SYSID EXP DEFINE EXTERNAL ENTRY POINT
*
* THIS ROUTINE SHOULD RETURN STRINGS TO HEAD THE STANDARD
* PRINTER OUTPUT. THE FIRST STRING WILL BE APPENDED TO
* A HEADING LINE OF THE FORM
* MACRO SPITBOL VERSION V.V
* SUPPLIED BY SPITBOL ITSELF. V.V ARE DIGITS GIVING THE
* MAJOR VERSION NUMBER AND GENERALLY AT LEAST A MINOR
* VERSION NUMBER RELATING TO OSINT SHOULD BE SUPPLIED TO
* GIVE SAY
* MACRO SPITBOL VERSION V.V(M.M)
* THE SECOND STRING SHOULD IDENTIFY AT LEAST THE MACHINE
* AND OPERATING SYSTEM. PREFERABLY IT SHOULD INCLUDE
* THE DATE AND TIME OF THE RUN.
* OPTIONALLY THE STRINGS MAY INCLUDE SITE NAME OF THE
* THE IMPLEMENTOR AND/OR MACHINE ON WHICH RUN TAKES PLACE,
* UNIQUE SITE OR COPY NUMBER AND OTHER INFORMATION AS
* APPROPRIATE WITHOUT MAKING IT SO LONG AS TO BE A
* NUISANCE TO USERS.
* THE FIRST WORDS OF THE SCBLKS POINTED AT NEED NOT BE
* CORRECTLY SET.
*
* JSR SYSID CALL FOR SYSTEM IDENTIFICATION
* (XR) SCBLK PTR FOR ADDITION TO HEADER
* (XL) PTR TO SECOND HEADER SCBLK
EJC
*
* SYSIL -- GET INPUT RECORD LENGTH
*
SYSIL EXP DEFINE EXTERNAL ENTRY POINT
*
* SYSIL IS USED TO GET THE LENGTH OF THE NEXT INPUT RECORD
* FROM A FILE PREVIOUSLY INPUT ASSOCIATED WITH A SYSIO
* CALL. THE LENGTH RETURNED IS USED TO ESTABLISH A BUFFER
* FOR A SUBSEQUENT SYSIN CALL.
*
* (WA) PTR TO FCBLK OR ZERO
* JSR SYSIL CALL TO GET RECORD LENGTH
* (WA) LENGTH OR ZERO IF FILE CLOSED
*
* NO HARM IS DONE IF THE VALUE RETURNED IS TOO LONG SINCE
* UNUSED SPACE WILL BE RECLAIMED AFTER THE SYSIN CALL.
*
* NOTE THAT IT IS THE SYSIL CALL (NOT THE SYSIO CALL) WHICH
* CAUSES THE FILE TO BE OPENED AS REQUIRED FOR THE FIRST
* RECORD INPUT FROM THE FILE.
EJC
*
* SYSIN -- READ INPUT RECORD
*
SYSIN EXP DEFINE EXTERNAL ENTRY POINT
*
* SYSIN IS USED TO READ A RECORD FROM THE FILE WHICH WAS
* REFERENCED IN A PRIOR CALL TO SYSIL (I.E. THESE CALLS
* ALWAYS OCCUR IN PAIRS). THE BUFFER PROVIDED IS AN
* SCBLK FOR A STRING OF LENGTH SET FROM THE SYSIL CALL.
* IF THE ACTUAL LENGTH READ IS LESS THAN THIS, THE LENGTH
* FIELD OF THE SCBLK MUST BE MODIFIED BEFORE RETURNING
* UNLESS BUFFER IS RIGHT PADDED WITH ZEROES.
* IT IS ALSO PERMISSIBLE TO TAKE ANY OF THE ALTERNATIVE
* RETURNS AFTER SCBLK LENGTH HAS BEEN MODIFIED.
*
* (WA) PTR TO FCBLK OR ZERO
* (XR) POINTER TO BUFFER (SCBLK PTR)
* JSR SYSIN CALL TO READ RECORD
* PPM LOC ENDFILE OR NO I/P FILE AFTER SYSXI
* PPM LOC RETURN HERE IF I/O ERROR
* PPM LOC RETURN HERE IF RECORD FORMAT ERROR
* (WA,WB,WC) DESTROYED
EJC
*
* SYSIO -- INPUT/OUTPUT FILE ASSOCIATION
*
SYSIO EXP DEFINE EXTERNAL ENTRY POINT
*
* SEE ALSO SYSFC.
* SYSIO IS CALLED IN RESPONSE TO A SNOBOL4 INPUT OR OUTPUT
* FUNCTION CALL EXCEPT WHEN FILE ARG1 AND FILE ARG2
* ARE BOTH NULL.
* ITS CALL ALWAYS FOLLOWS IMMEDIATELY AFTER A CALL
* OF SYSFC. IF SYSFC REQUESTED ALLOCATION
* OF AN FCBLK, ITS ADDRESS WILL BE IN WA.
* FOR INPUT FILES, NON-ZERO VALUES OF $R$ SHOULD BE
* COPIED TO WC FOR USE IN ALLOCATING INPUT BUFFERS. IF $R$
* IS DEFAULTED OR NOT IMPLEMENTED, WC SHOULD BE ZEROISED.
* ONCE A FILE HAS BEEN OPENED, SUBSEQUENT INPUT(),OUTPUT()
* CALLS IN WHICH THE SECOND ARGUMENT IS IDENTICAL WITH THAT
* IN A PREVIOUS CALL, MERELY ASSOCIATE THE ADDITIONAL
* VARIABLE NAME (FIRST ARGUMENT) TO THE FILE AND DO NOT
* RESULT IN RE-OPENING THE FILE.
* IN SUBSEQUENT ASSOCIATED ACCESSES TO THE FILE A POINTER
* TO ANY FCBLK ALLOCATED WILL BE MADE AVAILABLE.
*
* (XL) FILE ARG1 SCBLK PTR (2ND ARG)
* (XR) FILE ARG2 SCBLK PTR (3RD ARG)
* (WA) FCBLK PTR (0 IF NONE)
* (WB) 0 FOR INPUT, 3 FOR OUTPUT
* JSR SYSIO CALL TO ASSOCIATE FILE
* PPM LOC RETURN HERE IF FILE DOES NOT EXIST
* PPM LOC RETURN IF INPUT/OUTPUT NOT ALLOWED
* (XL) FCBLK POINTER (0 IF NONE)
* (WC) 0 (FOR DEFAULT) OR MAX RECORD LNGTH
* (WA,WB) DESTROYED
*
* THE SECOND ERROR RETURN IS USED IF THE FILE NAMED EXISTS
* BUT INPUT/OUTPUT FROM THE FILE IS NOT ALLOWED. FOR
* EXAMPLE, THE STANDARD OUTPUT FILE MAY BE IN THIS CATEGORY
* AS REGARDS INPUT ASSOCIATION.
EJC
*
* SYSLD -- LOAD EXTERNAL FUNCTION
*
SYSLD EXP DEFINE EXTERNAL ENTRY POINT
*
* SYSLD IS CALLED IN RESPONSE TO THE USE OF THE SNOBOL4
* LOAD FUNCTION. THE NAMED FUNCTION IS LOADED (WHATEVER
* THIS MEANS), AND A POINTER IS RETURNED. THE POINTER WILL
* BE USED ON SUBSEQUENT CALLS TO THE FUNCTION (SEE SYSEX).
*
* (XR) POINTER TO FUNCTION NAME (SCBLK)
* (XL) POINTER TO LIBRARY NAME (SCBLK)
* JSR SYSLD CALL TO LOAD FUNCTION
* PPM LOC RETURN HERE IF FUNC DOES NOT EXIST
* PPM LOC RETURN HERE IF I/O ERROR
* (XR) POINTER TO LOADED CODE
*
* THE SIGNIFICANCE OF THE POINTER RETURNED IS UP TO THE
* SYSTEM INTERFACE ROUTINE. THE ONLY RESTRICTION IS THAT
* IF THE POINTER IS WITHIN DYNAMIC STORAGE, IT MUST BE
* A PROPER BLOCK POINTER.
EJC
*
* SYSMM -- GET MORE MEMORY
*
SYSMM EXP DEFINE EXTERNAL ENTRY POINT
*
* SYSMM IS CALLED IN AN ATTEMPT TO ALLOCATE MORE DYNAMIC
* MEMORY. THIS MEMORY MUST BE ALLOCATED CONTIGUOUSLY WITH
* THE CURRENT DYNAMIC DATA AREA.
*
* THE AMOUNT ALLOCATED IS UP TO THE SYSTEM TO DECIDE. ANY
* VALUE IS ACCEPTABLE INCLUDING ZERO IF ALLOCATION IS
* IMPOSSIBLE.
*
* JSR SYSMM CALL TO GET MORE MEMORY
* (XR) NUMBER OF ADDITIONAL WORDS OBTAINED
EJC
*
* SYSMX -- SUPPLY MXLEN
*
SYSMX EXP DEFINE EXTERNAL ENTRY POINT
*
* BECAUSE OF THE METHOD OF GARBAGE COLLECTION, NO SPITBOL
* OBJECT IS ALLOWED TO OCCUPY MORE BYTES OF MEMORY THAN
* THE INTEGER GIVING THE LOWEST ADDRESS OF DYNAMIC
* (GARBAGE COLLECTABLE) MEMORY. MXLEN IS THE NAME USED TO
* REFER TO THIS MAXIMUM LENGTH OF AN OBJECT AND FOR MOST
* USERS OF MOST IMPLEMENTATIONS, PROVIDED DYNAMIC MEMORY
* STARTS AT AN ADDRESS OF AT LEAST A FEW THOUSAND WORDS,
* THERE IS NO PROBLEM.
* IF THE DEFAULT STARTING ADDRESS IS LESS THAN SAY 10000 OR
* 20000, THEN A LOAD TIME OPTION SHOULD BE PROVIDED WHERE A
* USER CAN REQUEST THAT HE BE ABLE TO CREATE LARGER
* OBJECTS. THIS ROUTINE INFORMS SPITBOL OF THIS REQUEST IF
* ANY. THE VALUE RETURNED IS EITHER AN INTEGER
* REPRESENTING THE DESIRED VALUE OF MXLEN (AND HENCE THE
* MINIMUM DYNAMIC STORE ADDRESS WHICH MAY RESULT IN
* NON-USE OF SOME STORE) OR ZERO IF A DEFAULT IS ACCEPTABLE
* IN WHICH MXLEN IS SET TO THE LOWEST ADDRESS ALLOCATED
* TO DYNAMIC STORE BEFORE COMPILATION STARTS.
* IF A NON-ZERO VALUE IS RETURNED, THIS IS USED FOR KEYWORD
* MAXLNGTH. OTHERWISE THE INITIAL LOW ADDRESS OF DYNAMIC
* MEMORY IS USED FOR THIS KEYWORD.
*
* JSR SYSMX CALL TO GET MXLEN
* (WA) EITHER MXLEN OR 0 FOR DEFAULT
EJC
*
* SYSOU -- OUTPUT RECORD
*
SYSOU EXP DEFINE EXTERNAL ENTRY POINT
*
* SYSOU IS USED TO WRITE A RECORD TO A FILE PREVIOUSLY
* ASSOCIATED WITH A SYSIO CALL.
*
* (WA) PTR TO FCBLK OR ZERO
* (XR) RECORD TO BE WRITTEN (SCBLK)
* JSR SYSOU CALL TO OUTPUT RECORD
* PPM LOC FILE FULL OR NO FILE AFTER SYSXI
* PPM LOC RETURN HERE IF I/O ERROR
* (WA,WB,WC) DESTROYED
*
* NOTE THAT IT IS THE SYSOU CALL (NOT THE SYSIO CALL) WHICH
* CAUSES THE FILE TO BE OPENED AS REQUIRED FOR THE FIRST
* RECORD OUTPUT TO THE FILE.
EJC
*
* SYSPI -- PRINT ON INTERACTIVE CHANNEL
*
SYSPI EXP DEFINE EXTERNAL ENTRY POINT
*
* IF SPITBOL IS RUN FROM AN ONLINE TERMINAL, OSINT CAN
* REQUEST THAT MESSAGES SUCH AS COPIES OF COMPILATION
* ERRORS BE SENT TO THE TERMINAL (SEE SYSPP). IF RELEVANT
* REPLY WAS MADE BY SYSPP THEN SYSPI IS CALLED TO SEND SUCH
* MESSAGES TO THE INTERACTIVE CHANNEL.
* SYSPI IS ALSO USED FOR SENDING OUTPUT TO THE TERMINAL
* THROUGH THE SPECIAL VARIABLE NAME, TERMINAL.
*
* (XR) PTR TO LINE BUFFER (SCBLK)
* (WA) LINE LENGTH
* JSR SYSPI CALL TO PRINT LINE
* PPM LOC FAILURE RETURN
* (WA,WB) DESTROYED
EJC
*
* SYSPP -- OBTAIN PRINT PARAMETERS
*
SYSPP EXP DEFINE EXTERNAL ENTRY POINT
*
* SYSPP IS CALLED ONCE DURING COMPILATION TO OBTAIN
* PARAMETERS REQUIRED FOR CORRECT PRINTED OUTPUT FORMAT
* AND TO SELECT OTHER OPTIONS. IT MAY ALSO BE CALLED AGAIN
* AFTER SYSXI WHEN A LOAD MODULE IS RESUMED. IN THIS
* CASE THE VALUE RETURNED IN WA MAY BE LESS THAN OR EQUAL
* TO THAT RETURNED IN INITIAL CALL BUT MAY NOT BE
* GREATER.
* THE INFORMATION RETURNED IS -
* 1. LINE LENGTH IN CHARS FOR STANDARD PRINT FILE
* 2. NO OF LINES/PAGE. 0 IS PREFERABLE FOR A NON-PAGED
* DEVICE (E.G. ONLINE TERMINAL) IN WHICH CASE LISTING
* PAGE THROWS ARE SUPPRESSED AND PAGE HEADERS
* RESULTING FROM -TITLE,-STITL LINES ARE KEPT SHORT.
* 3. AN INITIAL -NOLIST OPTION TO SUPPRESS LISTING UNLESS
* THE PROGRAM CONTAINS AN EXPLICIT -LIST.
* 4. OPTIONS TO SUPPRESS LISTING OF COMPILATION AND/OR
* EXECUTION STATS (USEFUL FOR ESTABLISHED PROGRAMS) -
* COMBINED WITH 3. GIVES POSSIBILITY OF LISTING
* FILE NEVER BEING OPENED.
* 5. OPTION TO HAVE COPIES OF ERRORS SENT TO AN
* INTERACTIVE CHANNEL IN ADDITION TO STANDARD PRINTER.
* 6. OPTION TO KEEP PAGE HEADERS SHORT (E.G. IF LISTING
* TO AN ONLINE TERMINAL).
* 7. AN OPTION TO CHOOSE EXTENDED OR COMPACT LISTING
* FORMAT. IN THE FORMER A PAGE EJECT AND IN THE LATTER
* A FEW LINE FEEDS PRECEDE THE PRINTING OF EACH
* OF-- LISTING, COMPILATION STATISTICS, EXECUTION
* OUTPUT AND EXECUTION STATISTICS.
* 8. AN OPTION TO SUPPRESS EXECUTION AS THOUGH A
* -NOEXECUTE CARD WERE SUPPLIED.
* 9. AN OPTION TO REQUEST THAT NAME /TERMINAL/ BE PRE-
* ASSOCIATED TO AN ONLINE TERMINAL VIA SYSPI AND SYSRI
* 10. AN INTERMEDIATE (STANDARD) LISTING OPTION REQUIRING
* THAT PAGE EJECTS OCCUR IN SOURCE LISTINGS. REDUNDANT
* IF EXTENDED OPTION CHOSEN BUT PARTIALLY EXTENDS
* COMPACT OPTION.
* 11. OPTION TO SUPPRESS SYSID IDENTIFICATION.
*
* JSR SYSPP CALL TO GET PRINT PARAMETERS
* (WA) PRINT LINE LENGTH IN CHARS
* (WB) NUMBER OF LINES/PAGE
* (WC) BITS VALUE ...JIHGFEDCBA WHERE
* A = 1 TO SEND ERROR COPY TO INT.CH.
* B = 1 MEANS STD PRINTER IS INT. CH.
* C = 1 FOR -NOLIST OPTION
* D = 1 TO SUPPRESS COMPILN. STATS
* E = 1 TO SUPPRESS EXECN. STATS
* F = 1/0 FOR EXTNDED/COMPACT LISTING
* G = 1 FOR -NOEXECUTE
* H = 1 PRE-ASSOCIATE /TERMINAL/
* I = 1 FOR STANDARD LISTING OPTION.
* J = 1 SUPPRESSES LISTING HEADER
EJC
*
* SYSPR -- PRINT LINE ON STANDARD OUTPUT FILE
*
SYSPR EXP DEFINE EXTERNAL ENTRY POINT
*
* SYSPR IS USED TO PRINT A SINGLE LINE ON THE STANDARD
* OUTPUT FILE.
*
* (XR) POINTER TO LINE BUFFER (SCBLK)
* (WA) LINE LENGTH
* JSR SYSPR CALL TO PRINT LINE
* PPM LOC TOO MUCH O/P OR NO FILE AFTER SYSXI
* (WA,WB) DESTROYED
*
* THE BUFFER POINTED TO IS THE LENGTH OBTAINED FROM THE
* SYSPP CALL AND IS FILLED OUT WITH TRAILING BLANKS. THE
* VALUE IN WA IS THE ACTUAL LINE LENGTH WHICH MAY BE LESS
* THAN THE MAXIMUM LINE LENGTH POSSIBLE. THERE IS NO SPACE
* CONTROL ASSOCIATED WITH THE LINE, ALL LINES ARE PRINTED
* SINGLE SPACED. NOTE THAT NULL LINES (WA=0) ARE POSSIBLE
* IN WHICH CASE A BLANK LINE IS TO BE PRINTED.
*
* THE ERROR EXIT IS USED FOR SYSTEMS WHICH LIMIT THE AMOUNT
* OF PRINTED OUTPUT. IF POSSIBLE, PRINTING SHOULD BE
* PERMITTED AFTER THIS CONDITION HAS BEEN SIGNALLED ONCE TO
* ALLOW FOR DUMP AND OTHER DIAGNOSTIC INFORMATION.
* ASSUMING THIS TO BE POSSIBLE, SPITBOL MAY MAKE MORE SYSPR
* CALLS. IF THE ERROR RETURN OCCURS ANOTHER TIME, EXECUTION
* IS TERMINATED BY A CALL OF SYSEJ WITH ENDING CODE 998.
EJC
*
* SYSRD -- READ RECORD FROM STANDARD INPUT FILE
*
SYSRD EXP DEFINE EXTERNAL ENTRY POINT
*
* SYSRD IS USED TO READ A RECORD FROM THE STANDARD INPUT
* FILE. THE BUFFER PROVIDED IS AN SCBLK FOR A STRING THE
* LENGTH OF WHICH IN CHARACTERS IS GIVEN IN WC, THIS
* CORRESPONDING TO THE MAXIMUM LENGTH OF STRING WHICH
* SPITBOL IS PREPARED TO RECEIVE. AT COMPILE TIME IT
* CORRESPONDS TO XXX IN THE MOST RECENT -INXXX CARD
* (DEFAULT 72) AND AT EXECUTION TIME TO THE MOST RECENT
* ,R$R$ (RECORD LENGTH) IN THE THIRD ARG OF AN INPUT()
* STATEMENT FOR THE STANDARD INPUT FILE (DEFAULT 80).
* IF FEWER THAN (WC) CHARACTERS ARE READ, THE LENGTH
* FIELD OF THE SCBLK MUST BE ADJUSTED BEFORE RETURNING
* UNLESS THE BUFFER IS RIGHT PADDED WITH ZEROES.
* IT IS ALSO PERMISSIBLE TO TAKE THE ALTERNATIVE RETURN
* AFTER SUCH AN ADJUSTMENT HAS BEEN MADE.
* SPITBOL MAY CONTINUE TO MAKE CALLS AFTER AN ENDFILE
* RETURN SO THIS ROUTINE SHOULD BE PREPARED TO MAKE
* REPEATED ENDFILE RETURNS.
*
* (XR) POINTER TO BUFFER (SCBLK PTR)
* (WC) LENGTH OF BUFFER IN CHARACTERS
* JSR SYSRD CALL TO READ LINE
* PPM LOC ENDFILE OR NO I/P FILE AFTER SYSXI
* (WA,WB,WC) DESTROYED
EJC
*
* SYSRI -- READ RECORD FROM INTERACTIVE CHANNEL
*
SYSRI EXP DEFINE EXTERNAL ENTRY POINT
*
* READS A RECORD FROM ONLINE TERMINAL FOR SPITBOL VARIABLE,
* TERMINAL. IF ONLINE TERMINAL IS UNAVAILABLE THEN CODE THE
* ENDFILE RETURN ONLY.
* THE BUFFER PROVIDED IS OF LENGTH 120 CHARACTERS. SYSRI
* SHOULD REPLACE THE COUNT IN THE SECOND WORD OF THE SCBLK
* BY THE ACTUAL CHARACTER COUNT UNLESS BUFFER IS RIGHT
* PADDED WITH ZEROES.
* IT IS ALSO PERMISSIBLE TO TAKE THE ALTERNATIVE
* RETURN AFTER ADJUSTING THE COUNT.
* THE END OF FILE RETURN MAY BE USED IF THIS MAKES
* SENSE ON THE TARGET MACHINE (E.G. IF THERE IS AN
* EOF CHARACTER.)
*
* (XR) PTR TO 120 CHAR BUFFER (SCBLK PTR)
* JSR SYSRI CALL TO READ LINE FROM TERMINAL
* PPM LOC END OF FILE RETURN
* (WA,WB,WC) MAY BE DESTROYED
EJC
*
* SYSRW -- REWIND FILE
*
SYSRW EXP DEFINE EXTERNAL ENTRY POINT
*
* SYSRW IS USED TO REWIND A FILE I.E. REPOSITION THE FILE
* AT THE START BEFORE THE FIRST RECORD. THE FILE SHOULD BE
* CLOSED AND THE NEXT READ OR WRITE CALL WILL OPEN THE
* FILE AT THE START.
*
* (WA) PTR TO FCBLK OR ZERO
* (XR) REWIND ARG (SCBLK PTR)
* JSR SYSRW CALL TO REWIND FILE
* PPM LOC RETURN HERE IF FILE DOES NOT EXIST
* PPM LOC RETURN HERE IF REWIND NOT ALLOWED
* PPM LOC RETURN HERE IF I/O ERROR
EJC
*
* SYSST -- SET FILE POINTER
*
SYSST EXP DEFINE EXTERNAL ENTRY POINT
*
* SYSST IS CALLED TO CHANGE THE POSITION OF A FILE
* POINTER. THIS IS ACCOMPLISHED IN A SYSTEM DEPENDENT
* MANNER, AND THUS THE 2ND AND 3RD ARGUMENTS ARE PASSED
* UNCONVERTED.
*
* (WA) FCBLK POINTER
* (WB) 2ND ARGUMENT
* (WC) 3RD ARGUMENT
* JSR SYSST CALL TO SET FILE POINTER
* PPM LOC RETURN HERE IF INVALID 2ND ARG
* PPM LOC RETURN HERE IF INVALID 3RD ARG
* PPM LOC RETURN HERE IF FILE DOES NOT EXIST
* PPM LOC RETURN HERE IF SET NOT ALLOWED
* PPM LOC RETURN HERE IF I/O ERROR
*
EJC
*
* SYSTM -- GET EXECUTION TIME SO FAR
*
SYSTM EXP DEFINE EXTERNAL ENTRY POINT
*
* SYSTM IS USED TO OBTAIN THE AMOUNT OF EXECUTION TIME
* USED SO FAR SINCE SPITBOL WAS GIVEN CONTROL. THE UNITS
* ARE DESCRIBED AS MILLISECONDS IN THE SPITBOL OUTPUT, BUT
* THE EXACT MEANING IS SYSTEM DEPENDENT. WHERE APPROPRIATE,
* THIS VALUE SHOULD RELATE TO PROCESSOR RATHER THAN CLOCK
* TIMING VALUES.
*
* JSR SYSTM CALL TO GET TIMER VALUE
* (IA) TIME SO FAR IN MILLISECONDS
EJC
*
* SYSTT -- TRACE TOGGLE
*
SYSTT EXP DEFINE EXTERNAL ENTRY POINT
*
* CALLED BY SPITBOL FUNCTION TRACE() WITH NO ARGS TO
* TOGGLE THE SYSTEM TRACE SWITCH. THIS PERMITS TRACING OF
* LABELS IN SPITBOL CODE TO BE TURNED ON OR OFF.
*
* JSR SYSTT CALL TO TOGGLE TRACE SWITCH
EJC
*
* SYSUL -- UNLOAD EXTERNAL FUNCTION
*
SYSUL EXP DEFINE EXTERNAL ENTRY POINT
*
* SYSUL IS USED TO UNLOAD A FUNCTION PREVIOUSLY
* LOADED WITH A CALL TO SYSLD.
*
* (XR) PTR TO CONTROL BLOCK (EFBLK)
* JSR SYSUL CALL TO UNLOAD FUNCTION
*
* THE FUNCTION CANNOT BE CALLED FOLLOWING A SYSUL CALL
* UNTIL ANOTHER SYSLD CALL IS MADE FOR THE SAME FUNCTION.
*
* THE EFBLK CONTAINS THE FUNCTION CODE POINTER AND ALSO A
* POINTER TO THE VRBLK CONTAINING THE FUNCTION NAME (SEE
* DEFINITIONS AND DATA STRUCTURES SECTION).
EJC
*
* SYSXI -- EXIT TO PRODUCE LOAD MODULE
*
SYSXI EXP DEFINE EXTERNAL ENTRY POINT
*
* WHEN SYSXI IS CALLED, XL CONTAINS EITHER A STRING POINTER
* OR ZERO. IN THE FORMER CASE, THE STRING GIVES THE
* CHARACTER NAME OF A PROGRAM. THE INTENTION IS THAT
* SPITBOL EXECUTION SHOULD BE TERMINATED FORTHWITH AND
* THE NAMED PROGRAM LOADED AND EXECUTED. THIS TYPE OF CHAIN
* EXECUTION IS VERY SYSTEM DEPENDENT AND IMPLEMENTORS MAY
* CHOOSE TO OMIT IT OR FIND IT IMPOSSIBLE TO PROVIDE.
* IF (XL) IS ZERO,IA CONTAINS ONE OF THE FOLLOWING INTEGERS
*
* -1, -2, -3
* CREATE IF POSSIBLE A LOAD MODULE CONTAINING ONLY THE
* IMPURE AREA OF MEMORY WHICH NEEDS TO BE LOADED WITH
* A COMPATIBLE PURE SEGMENT FOR SUBSEQUENT EXECUTIONS.
* VERSION NUMBERS TO CHECK COMPATIBILITY SHOULD BE
* KEPT IN BOTH SEGMENTS AND CHECKED ON LOADING.
* TO ASSIST WITH THIS CHECK, (XR) ON ENTRY IS A
* POINTER TO AN SCBLK CONTAINING THE SPITBOL MAJOR
* VERSION NUMBER V.V (SEE SYSID).
*
* 0 IF POSSIBLE, RETURN CONTROL TO JOB CONTROL
* COMMAND LEVEL. THE EFFECT IF AVAILABLE WILL BE
* SYSTEM DEPENDENT.
*
* +1, +2, +3
* CREATE IF POSSIBLE A LOAD MODULE FROM ALL OF
* MEMORY. IT SHOULD BE POSSIBLE TO LOAD AND EXECUTE
* THIS MODULE DIRECTLY.
*
* IN THE CASE OF SAVED LOAD MODULES, THE STATUS OF OPEN
* FILES IS NOT PRESERVED AND IMPLEMENTORS MAY CHOOSE TO
* OFFER MEANS OF ATTACHING FILES BEFORE EXECUTION OF LOAD
* MODULES STARTS OR LEAVE IT TO THE USER TO INCLUDE
* SUITABLE INPUT(), OUTPUT() CALLS IN HIS PROGRAM.
* SYSXI SHOULD MAKE A NOTE THAT NO I/O CHANNELS,
* INCLUDING STANDARD FILES, HAVE FILES ATTACHED SO THAT
* CALLS OF SYSIN, SYSOU, SYSPR, SYSRD SHOULD FAIL UNLESS
* NEW ASSOCIATIONS ARE MADE FOR THE LOAD MODULE.
* AT LEAST IN THE CASE OF THE STANDARD OUTPUT FILE, IT IS
* RECOMMENDED THAT EITHER THE USER BE REQUIRED TO ATTACH
* A FILE OR THAT A DEFAULT FILE IS ATTACHED, SINCE THE
* PROBLEM OF ERROR MESSAGES GENERATED BY THE LOAD MODULE
* IS OTHERWISE SEVERE. AS A LAST RESORT, IF SPITBOL
* ATTEMPTS TO WRITE TO THE STANDARD OUTPUT FILE AND GETS A
* REPLY INDICATING THAT SUCH OUPUT IS UNACCEPTABLE IT STOPS
* BY USING AN ENTRY TO SYSEJ WITH ENDING CODE 998.
* AS DESCRIBED BELOW, PASSING OF SOME ARGUMENTS MAKES IT
* CLEAR THAT LOAD MODULE WILL USE A STANDARD OUTPUT FILE.
*
* IF USE IS MADE OF FCBLKS FOR I/O ASSOCIATION, SPITBOL
* BUILDS A CHAIN SO THAT THOSE IN USE MAY BE FOUND IN SYSXI
* AND SYSEJ. THE NODES ARE 4 WORDS LONG. THIRD WORD
* CONTAINS LINK TO NEXT NODE OR 0, FOURTH WORD CONTAINS
* FCBLK POINTER.
EJC
*
* SYSXI (CONTINUED)
*
* (XL) ZERO OR SCBLK PTR
* (XR) PTR TO V.V SCBLK
* (IA) SIGNED INTEGER ARGUMENT
* (WB) 0 OR PTR TO HEAD OF FCBLK CHAIN
* JSR SYSXI CALL TO EXIT
* PPM LOC REQUESTED ACTION NOT POSSIBLE
* PPM LOC ACTION CAUSED IRRECOVERABLE ERROR
* (REGISTERS) SHOULD BE PRESERVED OVER CALL
*
* LOADING AND RUNNING THE LOAD MODULE OR RETURNING FROM
* JCL COMMAND LEVEL CAUSES EXECUTION TO RESUME AT THE POINT
* AFTER THE ERROR RETURNS WHICH FOLLOW THE CALL OF SYSXI.
* THE VALUE PASSED AS EXIT ARGUMENT IS USED TO INDICATE
* OPTIONS REQUIRED ON RESUMPTION OF LOAD MODULE.
* +1 OR -1 REQUIRE THAT ON RESUMPTION, SYSID AND SYSPP BE
* CALLED AND A HEADING PRINTED ON THE STANDARD OUTPUT FILE.
* +2 OR -2 INDICATE THAT SYSPP WILL BE CALLED BUT NOT SYSID
* AND NO HEADING WILL BE PUT ON STANDARD OUTPUT FILE.
* ABOVE OPTIONS HAVE THE OBVIOUS IMPLICATION THAT A
* STANDARD O/P FILE MUST BE PROVIDED FOR THE LOAD MODULE.
* +3 OR -3 INDICATE CALLS OF NEITHER SYSID NOR SYSPP
* AND NO HEADING WILL BE PLACED ON STANDARD OUTPUT FILE.
* NO RETURN FROM SYSXI IS POSSIBLE IF ANOTHER PROGRAM
* IS LOADED AND ENTERED.
EJC
*
* INTRODUCE THE INTERNAL PROCEDURES.
*
ACESS INP R,1
ACOMP INP N,5
ALLOC INP E,0
ALOBF INP E,0
ALOCS INP E,0
ALOST INP E,0
APNDB INP E,2
ARITH INP N,3
ASIGN INP R,1
ASINP INP R,1
BLKLN INP E,0
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
COPYB INP N,1
DFFNC INP E,0
DTACH INP E,0
DTYPE INP E,0
DUMPR INP E,0
ERMSG INP E,0
ERTEX INP E,0
EVALI INP R,4
EVALP INP R,1
EVALS INP R,3
EVALX INP R,1
EXBLD INP E,0
EXPAN INP E,0
EXPAP INP E,1
EXPDM INP N,0
EXPOP INP N,0
FLSTG INP R,0
GBCOL INP E,0
GBCPF INP E,0
GTARR INP E,1
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
GTREA INP E,1
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
INSBF INP E,2
IOFCB INP N,2
IOPPF INP N,0
IOPUT INP N,6
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
PRFLR INP E,0
PRFLU INP E,0
PRPAR INP E,0
PRTCH INP E,0
PRTIC INP E,0
PRTIS INP E,0
PRTIN INP E,0
PRTMI INP E,0
PRTMX INP E,0
PRTNL INP R,0
PRTNM INP R,0
PRTNV INP E,0
PRTPG INP E,0
PRTPS INP E,0
PRTSN INP E,0
PRTST INP R,0
EJC
PRTTR INP E,0
PRTVL INP R,0
PRTVN INP E,0
RCBLD INP E,0
READR INP E,0
SBSTR INP E,0
SCANE INP E,0
SCNGF INP E,0
SETVR INP E,0
SORTA INP N,0
SORTC INP E,1
SORTF INP E,0
SORTH INP E,0
TFIND INP E,1
TRACE INP N,2
TRBLD INP E,0
TRIMR INP E,0
TRXEQ INP R,0
XSCAN INP E,0
XSCNI INP N,2
*
* INTRODUCE THE INTERNAL ROUTINES
*
ARREF INR
CFUNC INR
EXFAL INR
EXINT INR
EXITS INR
EXIXR INR
EXNAM INR
EXNUL INR
EXREA INR
EXSID INR
EXVNM INR
FAILP INR
FLPOP INR
INDIR INR
MATCH INR
RETRN INR
STCOV INR
STMGO INR
STOPR INR
SUCCP INR
SYSAB INR
SYSTU INR
TTL S P I T B O L -- DEFINITIONS AND DATA STRUCTURES
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.
*
CFP$A EQU * NUMBER OF CHARACTERS IN ALPHABET
*
CFP$B EQU * BYTES/WORD ADDRESSING FACTOR
*
CFP$C EQU * NUMBER OF CHARACTERS PER WORD
*
CFP$F EQU * OFFSET IN BYTES 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
*
* THE FOLLOWING DEFINITIONS REQUIRE THE SUPPLY OF EITHER
* A SINGLE PARAMETER IF REAL ARITHMETIC IS OMITTED OR
* THREE PARAMETERS IF REAL ARITHMETIC IS INCLUDED.
*
*
CFP$R EQU * NUMBER OF WORDS IN REAL CONSTANT
*
CFP$S EQU * NUMBER OF SIG DIGS FOR REAL OUTPUT
*
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+)
*
* 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
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.
*
* TAB CHARACTERS - SYNTACTICALLY EQUIVALENT TO BLANK
*
CH$HT EQU * HORIZONTAL TAB
*
* 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 A DELIMITER OTHER THAN CH$CM MUST BE USED IN
* THE THIRD ARGUMENT OF INPUT(),OUTPUT() THEN .CIOD SHOULD
* BE DEFINED AND A PARAMETER SUPPLIED FOR IODEL.
*
IODEL EQU *
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
BL$BC EQU BL$AR+1 BCBLK BUFFER
BL$CD EQU BL$BC+1 CDBLK CODE
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
BL$RC EQU BL$P2+1 RCBLK REAL
BL$SC EQU BL$RC+1 SCBLK STRING
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
BL$BF EQU BL$TR+1 BFBLK
BL$CC EQU BL$BF+1 CCBLK
BL$CM EQU BL$CC+1 CMBLK
BL$CT EQU BL$CM+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
* BCBLK BUFFER CONTROL BLOCK
* 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 BYTES
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 BYTES 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.
*
* 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.
*
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 BYTES
CCUSE EQU CCLEN+1 OFFSET PAST LAST USED WORD (BYTES)
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 BYTES
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 BYTES
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
*
* 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 BYTES
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.
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 BYTES
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
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 BYTES
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 (BYTES) 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 BYTES 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 BYTES (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 BYTES
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)
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.
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 BYTES 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
* +------------------------------------+
* I SVCHS I
* +------------------------------------+
* 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
SVFPK EQU SVFNP+SVKVC PREEVAL FCN + CONST KEYWD + VAL
*
* 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 ITEM AND APPLY FUNCTIONS FALL 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 FUNCTIONS USING THIS ARE APPLY AND ITEM.
*
* 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$ABE EQU 0 ABEND
K$ANC EQU K$ABE+CFP$B ANCHOR
K$CAS EQU K$ANC+CFP$B CASE
K$COD EQU K$CAS+CFP$B CODE
K$DMP EQU K$COD+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
K$PFL EQU K$OUP+CFP$B PROFILE
K$TRA EQU K$PFL+CFP$B TRACE
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$STC EQU K$RTN+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$$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 BYTES
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 OR TRTRF I
* +------------------------------------+
* I TRFNC OR TRFPT 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
TRTER EQU TRTAG PTR TO TERMINAL VRBLK OR NULL
TRTRF EQU TRTAG PTR TO TRBLK HOLDING FCBLK PTR
TRFNC EQU TRTAG+1 TRACE FUNCTION VRBLK (ZERO IF NONE)
TRFPT EQU TRFNC FCBLK PTR FOR SYSIO
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
TRTOU EQU TRTVL+1 TRACE TYPE FOR OUTPUT ASSOCIATION
TRTFC EQU TRTOU+1 TRACE TYPE FOR FCBLK IDENTIFICATION
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.
* TRTRF POINTS TO THE TRAP BLOCK WHICH IN TURN POINTS
* TO AN FCBLK USED FOR I/O ASSOCIATION.
* TRFPT IS THE FCBLK PTR RETURNED BY SYSIO.
*
* 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.
* TRTRF POINTS TO THE TRAP BLOCK WHICH IN TURN POINTS
* TO AN FCBLK USED FOR I/O ASSOCIATION.
* TRFPT IS THE FCBLK PTR RETURNED BY SYSIO.
*
* 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 FILE ARG1 TRAP BLOCK
*
* 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. THIS TRAP BLOCK IS USED
* TO HOLD A POINTER TO THE FCBLK WHICH AN
* IMPLEMENTATION MAY REQUEST TO HOLD INFORMATION
* ABOUT A FILE.
*
* TRTYP IS SET TO TRTFC
* TRNEXT POINTS TO NEXT TRBLK OR TRVAL IS VARIABLE VAL
* TRFNM IS 0
* TRFPT IS THE FCBLK POINTER.
*
* 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)
* 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 BYTES
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 (LJRZ) 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.
* THIS TYPE OF BLOCK MAY BE USED AS A FILE CONTROL BLOCK.
* SEE SYSFC,SYSIN,SYSOU,S$INP,S$OUP FOR DETAILS.
*
* +------------------------------------+
* I XNTYP I
* +------------------------------------+
* I XNLEN I
* +------------------------------------+
* / /
* / XNDTA /
* / /
* +------------------------------------+
*
XNTYP EQU 0 POINTER TO DUMMY ROUTINE B$XNT
XNLEN EQU XNTYP+1 LENGTH OF XNBLK IN BYTES
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.
* THIS TYPE OF BLOCK MAY BE USED AS A FILE CONTROL BLOCK.
* SEE SYSFC,SYSIN,SYSOU,S$INP,S$OUP FOR DETAILS.
*
* +------------------------------------+
* I XRTYP I
* +------------------------------------+
* I XRLEN I
* +------------------------------------+
* / /
* / XRPTR /
* / /
* +------------------------------------+
*
XRTYP EQU 0 POINTER TO DUMMY ROUTINE B$XRT
XRLEN EQU XRTYP+1 LENGTH OF XRBLK IN BYTES
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
CNVRT EQU CNVST+1 CONVERT CODE FOR REALS
CNVBT EQU CNVRT+1 CONVERT CODE FOR BUFFER
CNVTT EQU CNVBT+1 BSW CODE FOR CONVERT
*
* INPUT IMAGE LENGTH
*
INILN EQU 132 DEFAULT IMAGE LENGTH FOR COMPILER
INILS EQU 80 IMAGE LENGTH IF -SEQU IN EFFECT
*
IONMB EQU 2 NAME BASE USED FOR IOCHN IN SYSIO
IONMO EQU 4 NAME OFFSET USED FOR IOCHN IN SYSIO
*
* 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
NINI8 EQU 998
NINI9 EQU 999
THSND EQU 1000
EJC
*
* 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 120 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
*
STNPD EQU 8 STATEMENT NO. PAD COUNT
*
* 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
*
CC$CA EQU 0 -CASE
CC$DO EQU CC$CA+1 -DOUBLE
CC$DU EQU CC$DO+1 -DUMP
CC$EJ EQU CC$DU+1 -EJECT
CC$ER EQU CC$EJ+1 -ERRORS
CC$EX EQU CC$ER+1 -EXECUTE
CC$FA EQU CC$EX+1 -FAIL
CC$LI EQU CC$FA+1 -LIST
CC$NR EQU CC$LI+1 -NOERRORS
CC$NX EQU CC$NR+1 -NOEXECUTE
CC$NF EQU CC$NX+1 -NOFAIL
CC$NL EQU CC$NF+1 -NOLIST
CC$NO EQU CC$NL+1 -NOOPT
CC$NP EQU CC$NO+1 -NOPRINT
CC$OP EQU CC$NP+1 -OPTIMISE
CC$PR EQU CC$OP+1 -PRINT
CC$SI EQU CC$PR+1 -SINGLE
CC$SP EQU CC$SI+1 -SPACE
CC$ST EQU CC$SP+1 -STITL
CC$TI EQU CC$ST+1 -TITLE
CC$TR EQU CC$TI+1 -TRACE
CC$NC 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
EJC
*
* 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
*
* 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)
*
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
*
CCNMS DTC /CASE/
DTC /DOUB/
DTC /DUMP/
DTC /EJEC/
DTC /ERRO/
DTC /EXEC/
DTC /FAIL/
DTC /LIST/
DTC /NOER/
DTC /NOEX/
DTC /NOFA/
DTC /NOLI/
DTC /NOOP/
DTC /NOPR/
DTC /OPTI/
DTC /PRIN/
DTC /SING/
DTC /SPAC/
DTC /STIT/
DTC /TITL/
DTC /TRAC/
*
* HEADER MESSAGES FOR DUMPR PROCEDURE (SCBLK FORMAT)
*
DMHDK DAC B$SCL DUMP OF KEYWORD VALUES
DAC 22
DTC /DUMP OF KEYWORD VALUES/
*
DMHDV DAC B$SCL DUMP OF NATURAL VARIABLES
DAC 25
DTC /DUMP OF NATURAL VARIABLES/
EJC
*
* MESSAGE TEXT FOR COMPILATION STATISTICS
*
ENCM1 DAC B$SCL
DAC 10
DTC /STORE USED/
*
ENCM2 DAC B$SCL
DAC 10
DTC /STORE LEFT/
*
ENCM3 DAC B$SCL
DAC 11
DTC /COMP ERRORS/
*
ENCM4 DAC B$SCL
DAC 14
DTC /COMP TIME-MSEC/
*
ENCM5 DAC B$SCL EXECUTION SUPPRESSED
DAC 20
DTC /EXECUTION SUPPRESSED/
*
* STRING CONSTANT FOR ABNORMAL END
*
ENDAB DAC B$SCL
DAC 12
DTC /ABNORMAL END/
EJC
*
* MEMORY OVERFLOW DURING INITIALISATION
*
ENDMO DAC B$SCL
ENDML DAC 15
DTC /MEMORY OVERFLOW/
*
* STRING CONSTANT FOR MESSAGE ISSUED BY L$END
*
ENDMS DAC B$SCL
DAC 10
DTC /NORMAL END/
*
* FAIL MESSAGE FOR STACK FAIL SECTION
*
ENDSO DAC B$SCL STACK OVERFLOW IN GARBAGE COLLECTOR
DAC 36
DTC /STACK OVERFLOW IN GARBAGE COLLECTION/
*
* STRING CONSTANT FOR TIME UP
*
ENDTU DAC B$SCL
DAC 15
DTC /ERROR - TIME UP/
EJC
*
* STRING CONSTANT FOR ERROR MESSAGE (ERROR SECTION)
*
ERMMS DAC B$SCL ERROR
DAC 5
DTC /ERROR/
*
ERMNS DAC B$SCL STRING / -- /
DAC 4
DTC / -- /
*
* STRING CONSTANT FOR PAGE NUMBERING
*
LSTMS DAC B$SCL PAGE
DAC 5
DTC /PAGE /
*
* LISTING HEADER MESSAGE
*
HEADR DAC B$SCL
DAC 25
DTC /MACRO SPITBOL VERSION 3.5/
*
HEADV DAC B$SCL FOR EXIT() VERSION NO. CHECK
DAC 3
DTC /3.5/
*
* 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
NDFNB DAC P$FNB FENCE()
NDFND DAC P$FND FENCE()
NDEXC DAC P$EXC EXPRESSION
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
*
* OPDVS IS USED WHEN SCANNING BELOW THE TOP LEVEL TO
* INSURE THAT THE CONCATENATION WILL NOT BE LATER
* MISTAKEN FOR PATTERN MATCHING
*
OPDVP DAC O$CNC CONCATENATION - NOT PATTERN MATCH
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 O$IMA IMMEDIATE ASSIGNMENT
DAC C$BVN
DAC LLDLD
DAC RRDLD
*
DAC O$INV INDIRECTION
DAC C$IND
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$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
*
* ADDRESS CONST CONTAINING PROFILE TABLE ENTRY SIZE
*
PFI2A DAC PF$I2
*
* PROFILER MESSAGE STRINGS
*
PFMS1 DAC B$SCL
DAC 15
DTC /PROGRAM PROFILE/
PFMS2 DAC B$SCL
DAC 42
DTC /STMT NUMBER OF -- EXECUTION TIME --/
PFMS3 DAC B$SCL
DAC 47
DTC /NUMBER EXECUTIONS TOTAL(MSEC) PER EXCN(MCSEC)/
*
*
* 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
EJC
*
* STRING CONSTANTS (SCBLK FORMAT) FOR DTYPE PROCEDURE
*
SCARR DAC B$SCL ARRAY
DAC 5
DTC /ARRAY/
*
SCBUF DAC B$SCL BUFFER
DAC 6
DTC /BUFFER/
*
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/
*
SCREA DAC B$SCL REAL
DAC 4
DTC /REAL/
*
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
DAC SCBUF BFBLK BUFFER
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
DAC SCREA RCBLK REAL
DAC SCSTR SCBLK STRING
DAC SCEXP SEBLK EXPRESSION
DAC SCTAB TBBLK TABLE
DAC SCARR VCBLK ARRAY
DAC SCEXT XNBLK EXTERNAL
DAC SCEXT XRBLK EXTERNAL
*
* STRING CONSTANT FOR REAL ZERO
*
SCRE0 DAC B$SCL
DAC 2
DTC /0./
EJC
*
* USED TO RE-INITIALISE KVSTL
*
STLIM DIC +50000 DEFAULT STATEMENT LIMIT
*
* 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 IN STATEMENT
DAC 12
DTC /IN STATEMENT/
*
STPM2 DAC B$SCL
DAC 14
DTC /STMTS EXECUTED/
*
STPM3 DAC B$SCL
DAC 13
DTC /RUN TIME-MSEC/
*
STPM4 DAC B$SCL
DAC 12
DTC $MCSEC / STMT$
*
STPM5 DAC B$SCL
DAC 13
DTC /REGENERATIONS/
*
* CHARS FOR /TU/ ENDING CODE
*
STRTU DTC /TU/
*
* 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
DAC SCREA REAL
DAC SCBUF BUFFER
DAC 0 ZERO MARKS END OF LIST
EJC
*
* MESSAGES (SCBLK FORMAT) USED BY TRACE PROCEDURES
*
*
TMASB DAC B$SCL ASTERISKS FOR TRACE STATEMENT NO
DAC 13
DTC /************ /
*
TMBEB DAC B$SCL BLANK-EQUAL-BLANK
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$END DBC SVLBL END
DAC 3
DTC /END/
DAC L$END
*
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
*
V$SET DBC SVFNN SET
DAC 3
DTC /SET/
DAC S$SET
DAC 3
*
V$TAB DBC SVFNP TAB
DAC 3
DTC /TAB/
DAC S$TAB
DAC 1
*
V$CAS DBC SVKNM CASE
DAC 4
DTC /CASE/
DAC K$CAS
*
V$CHR DBC SVFNP CHAR
DAC 4
DTC /CHAR/
DAC S$CHR
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
*
V$EXT DBC SVFNN EXIT
DAC 4
DTC /EXIT/
DAC S$EXT
DAC 1
*
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
*
V$LOD DBC SVFNN LOAD
DAC 4
DTC /LOAD/
DAC S$LOD
DAC 2
*
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
*
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
*
*
V$SRT DBC SVFNN SORT
DAC 4
DTC /SORT/
DAC S$SRT
DAC 2
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$ABE DBC SVKNM ABEND
DAC 5
DTC /ABEND/
DAC K$ABE
*
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
*
V$FEN DBC SVFPK FENCE
DAC 5
DTC /FENCE/
DAC K$FEN
DAC S$FNC
DAC 1
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
*
V$RSR DBC SVFNN RSORT
DAC 5
DTC /RSORT/
DAC S$RSR
DAC 2
*
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
*
V$APN DBC SVFNN
DAC 6
DTC /APPEND/
DAC S$APN
DAC 2
*
V$BKX DBC SVFNP BREAKX
DAC 6
DTC /BREAKX/
DAC S$BKX
DAC 1
*
V$BUF DBC SVFNN BUFFER
DAC 6
DTC /BUFFER/
DAC S$BUF
DAC 2
*
V$DEF DBC SVFNN DEFINE
DAC 6
DTC /DEFINE/
DAC S$DEF
DAC 2
*
V$DET DBC SVFNN DETACH
DAC 6
DTC /DETACH/
DAC S$DET
DAC 1
EJC
*
* STANDARD VARIABLE BLOCKS (CONTINUED)
*
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
*
V$INS DBC SVFNN INSERT
DAC 6
DTC /INSERT/
DAC S$INS
DAC 4
*
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$REW DBC SVFNN REWIND
DAC 6
DTC /REWIND/
DAC S$REW
DAC 1
*
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$CNV
DAC 2
*
V$ENF DBC SVFNN ENDFILE
DAC 7
DTC /ENDFILE/
DAC S$ENF
DAC 1
*
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)
*
*
V$PFL DBC SVKNM PROFILE
DAC 7
DTC /PROFILE/
DAC K$PFL
*
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$ALP DBC SVKWC ALPHABET
DAC 8
DTC /ALPHABET/
DAC K$ALP
*
V$CNT DBC SVLBL CONTINUE
DAC 8
DTC /CONTINUE/
DAC L$CNT
EJC
*
* STANDARD VARIABLE BLOCKS (CONTINUED)
*
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$CAS CCASE
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
DAC V$PFL PROFILE
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$CAS START OF 4 CHAR VARIABLES
DAC V$ABE 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
*
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
*
CSWDB DAC 0 0/1 FOR -SINGLE/-DOUBLE
CSWER DAC 0 0/1 FOR -ERRORS/-NOERRORS
CSWEX DAC 0 0/1 FOR -EXECUTE/-NOEXECUTE
CSWFL DAC 1 0/1 FOR -NOFAIL/-FAIL
CSWIN DAC INILN XXX FOR -INXXX
CSWLS DAC 1 0/1 FOR -NOLIST/-LIST
CSWNO DAC 0 0/1 FOR -OPTIMISE/-NOOPT
CSWPR DAC 0 0/1 FOR -NOPRINT/-PRINT
*
* GLOBAL LOCATION USED BY PATST PROCEDURE
*
CTMSK DBC 0 LAST BIT POSITION USED IN R$CTP
CURID DAC 0 CURRENT ID VALUE
EJC
*
* 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 AREA FOR DTACH
*
DTCNB DAC 0 NAME BASE
DTCNM DAC 0 NAME PTR
*
* 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.
*
ERICH DAC 0 COPY ERROR REPORTS TO INT.CHAN IF 1
ERLST DAC 0 FOR LISTR WHEN ERRORS GO TO INT.CH.
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
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
GTNRD DAC 0 FLAG FOR OK REAL NUMBER
*
* 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
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
*
* WORK AREAS FOR GTVAR PROCEDURE
*
GTVRC DAC 0 SAVE WC
*
* FLAG FOR HEADER PRINTING
*
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
*
INISS DAC 0 SAVE SUBROUTINE STACK PTR
INITR DAC 0 SAVE TERMINAL FLAG
*
* SAVE AREA FOR INSBF
*
INSAB DAC 0 ENTRY WA + ENTRY WB
INSSA DAC 0 SAVE ENTRY WA
INSSB DAC 0 SAVE ENTRY WB
INSSC DAC 0 SAVE ENTRY WC
*
* WORK AREAS FOR IOPUT
*
IOPTT DAC 0 TYPE OF ASSOCIATION
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).
*
KVABE DAC 0 ABEND
KVANC DAC 0 ANCHOR
KVCAS DAC 0 CASE
KVCOD DAC 0 CODE
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
KVPFL DAC 0 PROFILE
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)
KVSTL DIC +50000 STLIMIT
KVSTC DIC +50000 STCOUNT (COUNTS DOWN FROM STLIMIT)
*
* WORK AREAS FOR LOAD FUNCTION
*
LODFN DAC 0 POINTER TO VRBLK FOR FUNC NAME
LODNA DAC 0 COUNT NUMBER OF ARGUMENTS
*
* 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
*
* 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 GETS INT REP OF TABLE ENTRY SIZE
*
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
*
* FLAGS USED FOR STANDARD FILE LISTING OPTIONS
*
PRICH DAC 0 PRINTER ON INTERACTIVE CHANNEL
PRSTD DAC 0 TESTED BY PRTPG
PRSTO DAC 0 STANDARD LISTING OPTION FLAG
*
* 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
*
PRBUF DAC 0 PTR TO PRINT BFR IN STATIC
PRECL DAC 0 EXTENDED/COMPACT LISTING FLAG
PRLEN DAC 0 LENGTH OF PRINT BUFFER IN CHARS
PRLNW DAC 0 LENGTH OF PRINT BUFFER IN WORDS
PROFS DAC 0 OFFSET TO NEXT LOCATION IN PRBUF
PRTEF DAC 0 ENDFILE FLAG
*
* WORK AREAS FOR PRTST PROCEDURE
*
PRSVA DAC 0 SAVE WA
PRSVB DAC 0 SAVE WB
PRSVC DAC 0 SAVE CHAR COUNTER
*
* WORK AREA FOR PRTNL
*
PRTSA DAC 0 SAVE WA
PRTSB 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
*
* 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$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$FCB DAC 0 FCBLK CHAIN HEAD
R$FNC DAC 0 TRBLK POINTER FOR FNCLEVEL TRACE
R$GTC DAC 0 KEEP CODE PTR FOR GTCOD,GTEXP
R$IO1 DAC 0 FILE ARG1 FOR IOPUT
R$IO2 DAC 0 FILE ARG2 FOR IOPUT
R$IOF DAC 0 FCBLK PTR OR 0
R$ION DAC 0 NAME BASE PTR
R$IOP DAC 0 PREDECESSOR BLOCK PTR FOR IOPUT
R$IOT DAC 0 TRBLK PTR FOR IOPUT
R$PMB DAC 0 BUFFER PTR IN PATTERN MATCH
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
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
*
* GLOBAL VALUE FOR INDICATING STAGE (SEE ERROR SECTION)
*
STAGE DAC 0 INITIAL VALUE = INITIAL COMPILE
*
* 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
*
* 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
TIMUP DAC 0 SET WHEN TIME UP OCCURS
*
* WORK AREAS FOR XSCAN PROCEDURE
*
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
*
SEC START OF PROGRAM SECTION
JSR SYSTM INITIALISE TIMER
*
* 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 -IN72
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
STI TIMSX STORE TIME IN CORRECT PLACE
LDI STLIM GET DEFAULT STLIMIT
STI KVSTL STATEMENT LIMIT
STI KVSTC STATEMENT COUNT
MOV WB,STATB STORE START ADRS OF STATIC
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
*
* 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
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 =CFP$A,WA ADD NO. OF CHARS IN ALPHABET
ADD =NSTMX,WA ADD CHARS FOR GTSTG BFR
CTB WA,8 CONVERT TO BYTES, 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,INI06 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
*
INI06 MOV XR,DNAMB DYNAMIC BASE ADRS
MOV XR,DNAMP DYNAMIC PTR
BNZ WA,INI07 SKIP IF NON-ZERO MXLEN
DCA XR POINT A WORD IN FRONT
MOV XR,KVMXL USE AS MAXLNGTH
MOV XR,MXLEN AND AS MXLEN
EJC
*
* LOOP HERE IF NECESSARY TILL ENOUGH MEMORY OBTAINED
* SO THAT DNAME IS ABOVE DNAMB
*
INI07 MOV XL,DNAME STORE DYNAMIC END ADDRESS
BLT DNAMB,XL,INI09 SKIP IF HIGH ENOUGH
JSR SYSMM REQUEST MORE MEMORY
WTB XR GET AS BAUS (SGD05)
ADD XR,XL BUMP BY AMOUNT OBTAINED
BNZ XR,INI07 TRY AGAIN
MOV =ENDMO,XR POINT TO FAILURE MESSAGE
MOV ENDML,WA MESSAGE LENGTH
JSR SYSPR PRINT IT (PRTST NOT YET USABLE)
PPM SHOULD NOT FAIL
JSR SYSEJ PACK UP (STOPR NOT YET USABLE)
*
* INITIALISE PRINT BUFFER WITH BLANK WORDS
*
INI09 MOV PRLEN,WC 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 WC,(XR)+ AND STRING LENGTH
CTW WC,0 GET NUMBER OF WORDS IN BUFFER
MOV WC,PRLNW STORE FOR BUFFER CLEAR
LCT WC,WC WORDS TO CLEAR
*
* LOOP TO CLEAR BUFFER
*
INI10 MOV NULLW,(XR)+ STORE BLANK
BCT WC,INI10 LOOP
*
* INITIALIZE NUMBER OF HASH HEADERS
*
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 BYTES 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 BYTES 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 AND OUTPUT
*
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
MOV INITR,WC TERMINAL FLAG
BZE WC,INI13 SKIP IF NO TERMINAL
JSR PRPAR ASSOCIATE TERMINAL
EJC
*
* CHECK FOR EXPIRY DATE
*
INI13 JSR SYSDC CALL DATE CHECK
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 (REG04)
MOV =NULLS,R$STL FORGET SUB-TITLE (REG04)
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,INIX0 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
BZE HEADP,INIX0 NO EJECT IF NOTHING PRINTED (SDG11)
JSR PRTPG EJECT PRINTER
EJC
*
* PREPARE NOW TO START EXECUTION
*
* SET DEFAULT INPUT RECORD LENGTH
*
INIX0 BGT CSWIN,=INILN,INIX1 SKIP IF NOT DEFAULT -IN72 USED
MOV =INILS,CSWIN ELSE USE DEFAULT RECORD LENGTH
*
* RESET TIMER
*
INIX1 JSR SYSTM GET TIME AGAIN
STI TIMSX STORE FOR END RUN PROCESSING
ADD CSWEX,NOXEQ ADD -NOEXECUTE FLAG
BNZ NOXEQ,INIX2 JUMP IF EXECUTION SUPPRESSED
ZER GBCNT INITIALISE COLLECT COUNT
JSR SYSBX CALL BEFORE STARTING EXECUTION
*
* MERGE WHEN LISTING FILE SET FOR EXECUTION
*
INIY0 MNZ HEADP MARK HEADERS OUT REGARDLESS
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
MOV CMPSN,PFNTE COPY STMTS COMPILED COUNT IN CASE
JSR SYSTM TIME YET AGAIN
STI PFSTM
BRI (XR) START XEQ WITH FIRST STATEMENT
*
* HERE IF EXECUTION IS SUPPRESSED
*
INIX2 JSR PRTNL PRINT A BLANK LINE
MOV =ENCM5,XR POINT TO /EXECUTION SUPPRESSED/
JSR PRTST PRINT STRING
JSR PRTNL OUTPUT LINE
ZER WA SET ABEND VALUE TO ZERO
MOV =NINI9,WB SET SPECIAL CODE VALUE
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
PPM OADD1 JUMP IF REAL OPERANDS
*
* 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
*
* HERE TO ADD TWO REALS
*
OADD1 ADR RCVAL(XL) ADD RIGHT OPERAND TO LEFT
RNO EXREA RETURN REAL IF NO OVERFLOW
ERB 261,ADDITION CAUSED REAL OVERFLOW
EJC
*
* UNARY PLUS (AFFIRMATION)
*
O$AFF ENT ENTRY POINT
MOV (XS)+,XR LOAD OPERAND
JSR GTNUM CONVERT TO NUMERIC
ERR 004,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 005,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 006,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
EJC
*
* 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
EJC
*
* 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 BYTES
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 BYTES
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$ASS ENT ENTRY POINT
*
* O$RPL (PATTERN REPLACEMENT) MERGES HERE
*
OASS0 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
EJC
*
* COMPILATION ERROR
*
O$CER ENT ENTRY POINT
ERB 007,COMPILATION ERROR ENCOUNTERED DURING EXECUTION
EJC
*
* 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 008,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 009,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
BEQ WA,=B$RCL,OCOM3 JUMP IF REAL
JSR GTNUM ELSE CONVERT TO NUMERIC
ERR 010,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 011,COMPLEMENTATION CAUSED INTEGER OVERFLOW
*
* HERE TO COMPLEMENT REAL
*
OCOM3 LDR RCVAL(XR) LOAD REAL VALUE
NGR NEGATE
BRN EXREA RETURN REAL RESULT
EJC
*
* BINARY SLASH (DIVISION)
*
O$DVD ENT ENTRY POINT
JSR ARITH FETCH ARITHMETIC OPERANDS
ERR 012,DIVISION LEFT OPERAND IS NOT NUMERIC
ERR 013,DIVISION RIGHT OPERAND IS NOT NUMERIC
PPM ODVD2 JUMP IF REAL OPERANDS
*
* HERE TO DIVIDE TWO INTEGERS
*
DVI ICVAL(XL) DIVIDE LEFT OPERAND BY RIGHT
INO EXINT RESULT OK IF NO OVERFLOW
ERB 014,DIVISION CAUSED INTEGER OVERFLOW
*
* HERE TO DIVIDE TWO REALS
*
ODVD2 DVR RCVAL(XL) DIVIDE LEFT OPERAND BY RIGHT
RNO EXREA RETURN REAL IF NO OVERFLOW
ERB 262,DIVISION CAUSED REAL OVERFLOW
EJC
*
* EXPONENTIATION
*
O$EXP ENT ENTRY POINT
MOV (XS)+,XR LOAD EXPONENT
JSR GTNUM CONVERT TO NUMBER
ERR 015,EXPONENTIATION RIGHT OPERAND IS NOT NUMERIC
BNE WA,=B$ICL,OEXP7 JUMP IF REAL
MOV XR,XL MOVE EXPONENT
MOV (XS)+,XR LOAD BASE
JSR GTNUM CONVERT TO NUMERIC
ERR 016,EXPONENTIATION LEFT OPERAND IS NOT NUMERIC
LDI ICVAL(XL) LOAD EXPONENT
ILT OEXP8 ERROR IF NEGATIVE EXPONENT
BEQ WA,=B$RCL,OEXP3 JUMP IF BASE IS REAL
*
* 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 017,EXPONENTIATION CAUSED INTEGER OVERFLOW
EJC
*
* EXPONENTIATION (CONTINUED)
*
* 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
*
* HERE FOR ERROR OF 0**0 OR 0.0**0
*
OEXP4 ERB 018,EXPONENTIATION RESULT IS UNDEFINED
*
* 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 266,EXPONENTIATION CAUSED REAL OVERFLOW
*
* HERE IF REAL EXPONENT
*
OEXP7 ERB 267,EXPONENTIATION RIGHT OPERAND IS REAL NOT INTEGER
*
* HERE FOR NEGATIVE EXPONENT
*
OEXP8 ERB 019,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
BRN EVLX6 JUMP TO FAILURE LOC IN EVALX
EJC
*
* FAILURE DURING EVALUATION OF A COMPLEX OR DIRECT GOTO
*
O$FIF ENT ENTRY POINT
ERB 020,GOTO EVALUATION FAILURE
EJC
*
* 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
EJC
*
* FUNCTION NAME ERROR
*
O$FNE ENT ENTRY POINT
LCW WA GET NEXT CODE WORD
BNE WA,=ORNM$,OFNE1 FAIL IF NOT EVALUATING EXPRESSION
BZE 2(XS),EVLX3 OK IF EXPR. WAS WANTED BY VALUE
*
* HERE FOR ERROR
*
OFNE1 ERB 021,FUNCTION CALLED BY NAME RETURNED A VALUE
EJC
*
* 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 022,UNDEFINED FUNCTION CALLED
EJC
*
* 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 023,GOTO OPERAND IS NOT A NATURAL VARIABLE
EJC
*
* EXECUTE DIRECT GOTO
*
O$GOD ENT ENTRY POINT
MOV (XS),XR LOAD OPERAND
MOV (XR),WA LOAD FIRST WORD
BEQ WA,=B$CDS,BCDS0 JUMP IF CODE BLOCK TO CODE ROUTINE
BEQ WA,=B$CDC,BCDC0 JUMP IF CODE BLOCK TO CODE ROUTINE
ERB 024,GOTO OPERAND IN DIRECT GOTO IS NOT CODE
EJC
*
* 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 025,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
EJC
*
* INDIRECTION (BY NAME)
*
O$INN ENT ENTRY POINT
MNZ WB SET FLAG FOR RESULT BY NAME
BRN INDIR JUMP TO COMMON ROUTINE
EJC
*
* INTERROGATION
*
O$INT ENT ENTRY POINT
MOV =NULLS,(XS) REPLACE OPERAND WITH NULL
BRN EXITS EXIT FOR NEXT CODE WORD
EJC
*
* 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
EJC
*
* 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
EJC
*
* 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)
EJC
*
* 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
EJC
*
* BINARY ASTERISK (MULTIPLICATION)
*
O$MLT ENT ENTRY POINT
JSR ARITH FETCH ARITHMETIC OPERANDS
ERR 026,MULTIPLICATION LEFT OPERAND IS NOT NUMERIC
ERR 027,MULTIPLICATION RIGHT OPERAND IS NOT NUMERIC
PPM OMLT1 JUMP IF REAL OPERANDS
*
* HERE TO MULTIPLY TWO INTEGERS
*
MLI ICVAL(XL) MULTIPLY LEFT OPERAND BY RIGHT
INO EXINT RETURN INTEGER IF NO OVERFLOW
ERB 028,MULTIPLICATION CAUSED INTEGER OVERFLOW
*
* HERE TO MULTIPLY TWO REALS
*
OMLT1 MLR RCVAL(XL) MULTIPLY LEFT OPERAND BY RIGHT
RNO EXREA RETURN REAL IF NO OVERFLOW
ERB 263,MULTIPLICATION CAUSED REAL OVERFLOW
EJC
*
* 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
EJC
*
* USE OF UNDEFINED OPERATOR
*
O$OUN ENT ENTRY POINT
ERB 029,UNDEFINED OPERATOR REFERENCED
EJC
*
* 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 030,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
EJC
*
* 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
EJC
*
* 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
EJC
*
* POP TOP ITEM ON STACK
*
O$POP ENT ENTRY POINT
ICA XS POP TOP STACK ENTRY
BRN EXITS OBEY NEXT CODE WORD
EJC
*
* TERMINATE EXECUTION (CODE COMPILED FOR END STATEMENT)
*
O$STP ENT ENTRY POINT
BRN LEND0 JUMP TO END CIRCUIT
EJC
*
* 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
BRN EVLX4 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 POINTER
* (XS) ---------------- REPLACEMENT VALUE
*
O$RPL ENT ENTRY POINT
JSR GTSTG CONVERT REPLACEMENT VAL TO STRING
ERR 031,PATTERN REPLACEMENT RIGHT OPERAND IS NOT STRING
*
* GET RESULT LENGTH AND ALLOCATE RESULT SCBLK
*
MOV (XS),XL LOAD SUBJECT STRING POINTER
BEQ (XL),=B$BCT,ORPL4 BRANCH IF BUFFER ASSIGNMENT
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,OASS0 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 OASS0 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
BRN OASS0 JUMP TO ASSIGN NULL VALUE
*
* HERE FOR BUFFER SUBSTRING ASSIGNMENT
*
ORPL4 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
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 EVLX3 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 032,SUBTRACTION LEFT OPERAND IS NOT NUMERIC
ERR 033,SUBTRACTION RIGHT OPERAND IS NOT NUMERIC
PPM OSUB1 JUMP IF REAL OPERANDS
*
* HERE TO SUBTRACT TWO INTEGERS
*
SBI ICVAL(XL) SUBTRACT RIGHT OPERAND FROM LEFT
INO EXINT RETURN INTEGER IF NO OVERFLOW
ERB 034,SUBTRACTION CAUSED INTEGER OVERFLOW
*
* HERE TO SUBTRACT TWO REALS
*
OSUB1 SBR RCVAL(XL) SUBTRACT RIGHT OPERAND FROM LEFT
RNO EXREA RETURN REAL IF NO OVERFLOW
ERB 264,SUBTRACTION CAUSED REAL OVERFLOW
EJC
*
* DUMMY OPERATOR TO RETURN CONTROL TO TRXEQ PROCEDURE
*
O$TXR ENT ENTRY POINT
BRN TRXQ1 JUMP INTO TRXEQ PROCEDURE
EJC
*
* 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 035,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
EJC
*
* ABORT
*
L$ABO ENT ENTRY POINT
*
* MERGE HERE IF EXECUTION TERMINATES IN ERROR
*
LABO1 MOV KVERT,WA LOAD ERROR CODE
BZE WA,LABO2 JUMP IF NO ERROR HAS OCCURED
JSR SYSAX CALL AFTER EXECUTION PROC (REG04)
JSR PRTPG ELSE EJECT PRINTER
JSR ERMSG PRINT ERROR MESSAGE
ZER XR INDICATE NO MESSAGE TO PRINT
BRN STOPR JUMP TO ROUTINE TO STOP RUN
*
* HERE IF NO ERROR HAD OCCURED
*
LABO2 ERB 036,GOTO ABORT WITH NO PRECEDING ERROR
EJC
*
* CONTINUE
*
L$CNT ENT ENTRY POINT
*
* MERGE HERE AFTER EXECUTION ERROR
*
LCNT1 MOV R$CNT,XR LOAD CONTINUATION CODE BLOCK PTR
BZE XR,LCNT2 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
*
LCNT2 ERB 037,GOTO CONTINUE WITH NO PRECEDING ERROR
EJC
*
* END
*
L$END ENT ENTRY POINT
*
* MERGE HERE FROM END CODE CIRCUIT
*
LEND0 MOV =ENDMS,XR POINT TO MESSAGE /NORMAL TERM../
BRN STOPR JUMP TO ROUTINE TO STOP RUN
EJC
*
* FRETURN
*
L$FRT ENT ENTRY POINT
MOV =SCFRT,WA POINT TO STRING /FRETURN/
BRN RETRN JUMP TO COMMON RETURN ROUTINE
EJC
*
* NRETURN
*
L$NRT ENT ENTRY POINT
MOV =SCNRT,WA POINT TO STRING /NRETURN/
BRN RETRN JUMP TO COMMON RETURN ROUTINE
EJC
*
* RETURN
*
L$RTN ENT ENTRY POINT
MOV =SCRTN,WA POINT TO STRING /RETURN/
BRN RETRN JUMP TO COMMON RETURN ROUTINE
EJC
*
* UNDEFINED LABEL
*
L$UND ENT ENTRY POINT
ERB 038,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
EJC
*
* 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
EJC
*
* 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
EJC
*
* ARBLK
*
* THE ROUTINE FOR ARBLK IS NEVER EXECUTED
*
B$ART ENT BL$AR ENTRY POINT (ARBLK)
EJC
*
* BCBLK
*
* THE ROUTINE FOR A BCBLK IS NEVER EXECUTED
*
* (XR) POINTER TO BCBLK
*
B$BCT ENT BL$BC ENTRY POINT (BCBLK)
EJC
*
* BFBLK
*
* THE ROUTINE FOR A BFBLK IS NEVER EXECUTED
*
* (XR) POINTER TO BFBLK
*
B$BFT ENT BL$BF ENTRY POINT (BFBLK)
EJC
*
* CCBLK
*
* THE ROUTINE FOR CCBLK IS NEVER ENTERED
*
B$CCT ENT BL$CC ENTRY POINT (CCBLK)
EJC
*
* 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)
BCDC0 MOV FLPTR,XS POP GARBAGE OFF STACK
MOV CDFAL(XR),(XS) SET FAILURE OFFSET
BRN STMGO ENTER STMT
EJC
*
* CDBLK (CONTINUED)
*
* ENTRY FOR SIMPLE FAILURE CODE AT CDFAL
*
* (XR) POINTER TO CDBLK
*
B$CDS ENT BL$CD ENTRY POINT (CDBLK)
BCDS0 MOV FLPTR,XS POP GARBAGE OFF STACK
MOV *CDFAL,(XS) SET FAILURE OFFSET
BRN STMGO ENTER STMT
EJC
*
* CMBLK
*
* THE ROUTINE FOR A CMBLK IS NEVER EXECUTED
*
B$CMT ENT BL$CM ENTRY POINT (CMBLK)
EJC
*
* 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
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,4 SWITCH ON TYPE
IFF 0,BEFC7 NO CONVERSION NEEDED
IFF 1,BEFC2 STRING
IFF 2,BEFC3 INTEGER
IFF 3,BEFC4 REAL
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 039,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 040,EXTERNAL FUNCTION ARGUMENT IS NOT INTEGER
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 265,EXTERNAL FUNCTION ARGUMENT IS NOT REAL
*
* INTEGER CASE MERGES HERE
*
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 ID
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
MOV =B$RCL,WA REAL
*
* 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
EJC
*
* 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 041,FIELD FUNCTION ARGUMENT IS WRONG DATATYPE
EJC
*
* FFBLK (CONTINUED)
*
* 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
EJC
*
* KVBLK
*
* THE ROUTINE FOR A KVBLK IS NEVER EXECUTED.
*
B$KVT ENT BL$KV ENTRY POINT (KVBLK)
EJC
*
* 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
EJC
*
* 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 BYTES 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
*
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
*
* NO PROFILING MERGES HERE
*
BPF7C MOV XR,-(XS) STACK ICBLK PTR (OR ZERO)
MOV R$COD,WA LOAD OLD CODE BLOCK POINTER
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 BYTE 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 PRTCH PRINT TO TERMINATE OUTPUT
JSR PRTNL TERMINATE PRINT LINE
*
* 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
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
EJC
*
* 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
EJC
*
* TBBLK
*
* THE ROUTINE FOR A TBBLK IS NEVER EXECUTED
*
B$TBT ENT BL$TB ENTRY POINT (TBBLK)
EJC
*
* TEBLK
*
* THE ROUTINE FOR A TEBLK IS NEVER EXECUTED
*
B$TET ENT BL$TE ENTRY POINT (TEBLK)
EJC
*
* 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
EJC
*
* VRBLK (CONTINUED)
*
* 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 042,ATTEMPT TO CHANGE VALUE OF PROTECTED VARIABLE
EJC
*
* VRBLK (CONTINUED)
*
* 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
EJC
*
* VRBLK (CONTINUED)
*
* 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
EJC
*
* VRBLK (CONTINUED)
*
* 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 PRTCH PRINT IT
JSR PRTNL TERMINATE LINE
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)
EJC
*
* 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.
EJC
*
* COMPOUNT PATTERN STRUCTURES (CONTINUED)
*
* 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 INNTER STACK BASE CREATED BY P$FNA
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
EJC
*
* 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
EJC
*
* 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
EJC
*
* 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
EJC
*
* 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
EJC
*
* ANY (MULTI-CHARACTER ARGUMENT CASE)
*
* PARM1 POINTER TO CTBLK
* PARM2 BIT MASK TO SELECT BIT IN CTBLK
*
P$ANY ENT BL$P2 P2BLK
*
* EXPRESSION ARGUMENT CASE MERGES HERE
*
PANY1 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 BYTE 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
EJC
*
* ANY (EXPRESSION ARGUMENT)
*
* PARM1 EXPRESSION POINTER
*
P$AYD ENT BL$P1 P1BLK
JSR EVALS EVALUATE STRING ARGUMENT
ERR 043,ANY EVALUATED ARGUMENT IS NOT STRING
PPM FAILP FAIL IF EVALUATION FAILURE
PPM PANY1 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
EJC
*
* 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
JSR EVALS EVALUATE STRING EXPRESSION
ERR 044,BREAK EVALUATED ARGUMENT IS NOT STRING
PPM FAILP FAIL IF EVALUATION FAILS
PPM PBRK1 MERGE WITH MULTI-CHAR CASE IF OK
EJC
*
* 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)
*
* PARM1 POINTER TO CTBLK
* PARM2 BIT MASK TO SELECT BIT COLUMN
*
P$BRK ENT BL$P2 P2BLK
*
* EXPRESSION ARGUMENT MERGES HERE
*
PBRK1 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 BYTE 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
EJC
*
* 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
JSR EVALS EVALUATE STRING ARGUMENT
ERR 045,BREAKX EVALUATED ARGUMENT IS NOT STRING
PPM FAILP FAIL IF EVALUATION FAILS
PPM PBRK1 MERGE WITH BREAK IF ALL OK
EJC
*
* 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 046,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
BRN PSTR1 ELSE MERGE WITH STRING CIRCUIT
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
EJC
*
* 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
EJC
*
* 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
EJC
*
* 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
EJC
*
* 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
EJC
*
* 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
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
EJC
*
* 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
EJC
*
* 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
*
* EXPRESSION ARGUMENT CASE MERGES HERE
*
PLEN1 ADD PARM1(XR),WB PUSH CURSOR INDICATED AMOUNT
BLE WB,PMSSL,SUCCP SUCCEED IF NOT OFF END
BRN FAILP ELSE FAIL
EJC
*
* LEN (EXPRESSION ARGUMENT)
*
* PARM1 EXPRESSION POINTER
*
P$LND ENT BL$P1 P1BLK
JSR EVALI EVALUATE INTEGER ARGUMENT
ERR 047,LEN EVALUATED ARGUMENT IS NOT INTEGER
ERR 048,LEN EVALUATED ARGUMENT IS NEGATIVE OR TOO LARGE
PPM FAILP FAIL IF EVALUATION FAILS
PPM PLEN1 MERGE WITH NORMAL CIRCUIT IF OK
EJC
*
* NOTANY (EXPRESSION ARGUMENT)
*
* PARM1 EXPRESSION POINTER
*
P$NAD ENT BL$P1 P1BLK
JSR EVALS EVALUATE STRING ARGUMENT
ERR 049,NOTANY EVALUATED ARGUMENT IS NOT STRING
PPM FAILP FAIL IF EVALUATION FAILS
PPM PNAY1 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)
*
* PARM1 POINTER TO CTBLK
* PARM2 BIT MASK TO SELECT BIT COLUMN
*
P$NAY ENT BL$P2 P2BLK
*
* EXPRESSION ARGUMENT CASE MERGES HERE
*
PNAY1 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 BYTE 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
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
BZE R$PMB,PNTH8 SKIP IF SUBJECT NOT BUFFER
MOV R$PMB,XL ELSE GET PTR TO BCBLK INSTEAD
*
* HERE WITH XL POINTING TO SCBLK OR BCBLK
*
PNTH8 MOV XL,-(XS) STACK SUBJECT POINTER
BRN EXITS EXIT WITH SPECIAL ENTRY ON STACK
EJC
*
* POS (INTEGER ARGUMENT)
*
* PARM1 INTEGER ARGUMENT
*
P$POS ENT BL$P1 P1BLK
*
* EXPRESSION ARGUMENT CASE MERGES HERE
*
PPOS1 BEQ WB,PARM1(XR),SUCCP SUCCEED IF AT RIGHT LOCATION
BRN FAILP ELSE FAIL
EJC
*
* POS (EXPRESSION ARGUMENT)
*
* PARM1 EXPRESSION POINTER
*
P$PSD ENT BL$P1 P1BLK
JSR EVALI EVALUATE INTEGER ARGUMENT
ERR 050,POS EVALUATED ARGUMENT IS NOT INTEGER
ERR 051,POS EVALUATED ARGUMENT IS NEGATIVE OR TOO LARGE
PPM FAILP FAIL IF EVALUATION FAILS
PPM PPOS1 MERGE WITH NORMAL CASE IF OK
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
EJC
*
* 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)
EJC
*
* 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
EJC
*
* 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
EJC
*
* RPOS (EXPRESSION ARGUMENT)
*
* PARM1 EXPRESSION POINTER
*
P$RPD ENT BL$P1 P1BLK
JSR EVALI EVALUATE INTEGER ARGUMENT
ERR 052,RPOS EVALUATED ARGUMENT IS NOT INTEGER
ERR 053,RPOS EVALUATED ARGUMENT IS NEGATIVE OR TOO LARGE
PPM FAILP FAIL IF EVALUATION FAILS
PPM PRPS1 MERGE WITH NORMAL CASE IF OK
EJC
*
* RPOS (INTEGER ARGUMENT)
*
* PARM1 INTEGER ARGUMENT
*
P$RPS ENT BL$P1 P1BLK
*
* EXPRESSION ARGUMENT CASE MERGES HERE
*
PRPS1 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)
*
* PARM1 INTEGER ARGUMENT
*
P$RTB ENT BL$P1 P1BLK
*
* EXPRESSION ARGUMENT CASE MERGES HERE
*
PRTB1 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
EJC
*
* RTAB (EXPRESSION ARGUMENT)
*
* PARM1 EXPRESSION POINTER
*
P$RTD ENT BL$P1 P1BLK
JSR EVALI EVALUATE INTEGER ARGUMENT
ERR 054,RTAB EVALUATED ARGUMENT IS NOT INTEGER
ERR 055,RTAB EVALUATED ARGUMENT IS NEGATIVE OR TOO LARGE
PPM FAILP FAIL IF EVALUATION FAILS
PPM PRTB1 MERGE WITH NORMAL CASE IF SUCCESS
EJC
*
* SPAN (EXPRESSION ARGUMENT)
*
* PARM1 EXPRESSION POINTER
*
P$SPD ENT BL$P1 P1BLK
JSR EVALS EVALUATE STRING ARGUMENT
ERR 056,SPAN EVALUATED ARGUMENT IS NOT STRING
PPM FAILP FAIL IF EVALUATION FAILS
PPM PSPN1 MERGE WITH MULTI-CHAR CASE IF OK
EJC
*
* SPAN (MULTI-CHARACTER ARGUMENT CASE)
*
* PARM1 POINTER TO CTBLK
* PARM2 BIT MASK TO SELECT BIT COLUMN
*
P$SPN ENT BL$P2 P2BLK
*
* EXPRESSION ARGUMENT CASE MERGES HERE
*
PSPN1 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 BYTE 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
EJC
*
* MULTI-CHARACTER STRING
*
* 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
*
* MERGE HERE AFTER EVALUATING EXPRESSION WITH STRING VALUE
*
PSTR1 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)
*
* PARM1 INTEGER ARGUMENT
*
P$TAB ENT BL$P1 P1BLK
*
* EXPRESSION ARGUMENT CASE MERGES HERE
*
PTAB1 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
EJC
*
* TAB (EXPRESSION ARGUMENT)
*
* PARM1 EXPRESSION POINTER
*
P$TBD ENT BL$P1 P1BLK
JSR EVALI EVALUATE INTEGER ARGUMENT
ERR 057,TAB EVALUATED ARGUMENT IS NOT INTEGER
ERR 058,TAB EVALUATED ARGUMENT IS NEGATIVE OR TOO LARGE
PPM FAILP FAIL IF EVALUATION FAILS
PPM PTAB1 MERGE WITH NORMAL CASE IF OK
EJC
*
* 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
EJC
*
* 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 059,ANY ARGUMENT IS NOT STRING OR EXPRESSION
BRN EXIXR JUMP FOR NEXT CODE WORD
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 275,APPEND FIRST ARGUMENT IS NOT BUFFER
*
* HERE TO DO THE APPEND
*
SAPN1 JSR APNDB DO THE APPEND
ERR 276,APPEND SECOND ARGUMENT IS NOT STRING
PPM EXFAL NO ROOM - FAIL
BRN EXNUL EXIT WITH NULL RESULT
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 BYTES
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 060,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 061,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 062,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 063,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 BYTES
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 064,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 065,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 JSR GTINT CONVERT HIGH BOUND TO INTEGER
ERR 066,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 BYTES
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 BYTES
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 BYTES
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 067,ARRAY DIMENSION IS ZERO,NEGATIVE OR OUT OF RANGE
*
* HERE IF ARRAY IS TOO LARGE
*
SAR11 ERB 068,ARRAY SIZE EXCEEDS MAXIMUM PERMITTED
EJC
*
* BUFFER
*
S$BUF ENT ENTRY POINT
MOV (XS)+,XL GET INITIAL VALUE
MOV (XS)+,XR GET REQUESTED ALLOCATION
JSR GTINT CONVERT TO INTEGER
ERR 269,BUFFER FIRST ARGUMENT IS NOT INTEGER
LDI ICVAL(XR) GET VALUE
ILE SBF01 BRANCH IF NEGATIVE OR ZERO
MFI WA,SBF02 MOVE WITH OVERFLOW CHECK
JSR ALOBF ALLOCATE THE BUFFER
JSR APNDB COPY IT IN
ERR 270,BUFFER SECOND ARGUMENT IS NOT STRING OR BUFFER
ERR 271,BUFFER INITIAL VALUE TOO BIG FOR ALLOCATION
BRN EXSID EXIT SETTING IDVAL
*
* HERE FOR INVALID ALLOCATION SIZE
*
SBF01 ERB 272,BUFFER FIRST ARGUMENT IS NOT POSITIVE
*
* HERE FOR ALLOCATION SIZE INTEGER OVERFLOW
*
SBF02 ERB 273,BUFFER SIZE IS TOO BIG
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 069,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 070,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
EJC
*
* CHAR
*
S$CHR ENT ENTRY POINT
JSR GTSMI CONVERT ARG TO INTEGER
ERR 281,CHAR ARGUMENT NOT INTEGER
PPM SCHR1 TOO BIG ERROR EXIT
BGE WC,=CFP$A,SCHR1 SEE IF OUT OF RANGE OF HOST SET
MOV =NUM01,WA IF NOT SET SCBLK ALLOCATION
MOV WC,WB SAVE CHAR CODE
JSR ALOCS ALLOCATE 1 BAU SCBLK
MOV XR,XL COPY SCBLK POINTER
PSC XL GET SET TO STUFF CHAR
SCH WB,(XL)+ STUFF IT
ZER XL CLEAR SLOP IN XL
BRN EXIXR EXIT WITH SCBLK POINTER
*
* HERE IF CHAR ARGUMENT IS OUT OF RANGE
*
SCHR1 ERB 282,CHAR ARGUMENT NOT IN RANGE
EJC
*
* CLEAR
*
S$CLR ENT ENTRY POINT
JSR XSCNI INITIALIZE TO SCAN ARGUMENT
ERR 071,CLEAR ARGUMENT IS NOT STRING
PPM SCLR2 JUMP IF NULL
*
* LOOP TO SCAN OUT NAMES IN FIRST ARGUMENT. VARIABLES IN
* THE LIST ARE FALGGED 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
ERR 072,CLEAR ARGUMENT HAS NULL VARIABLE NAME
ZER VRGET(XR) ELSE FLAG BY ZEROING VRGET FIELD
BNZ WA,SCLR1 LOOP BACK IF STOPPED BY COMMA
*
* 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
* PRROTECTED VARIABLES (ARB, ETC) ARE EXEMPT
*
SCLR5 BEQ VRSTO(XR),=B$VRE,SCLR4 CHECK FOR PROTECTED VARIABLE (REG05)
MOV XR,XL COPY VRBLK POINTER (REG05)
*
* 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
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 073,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 BYTES 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$CNV ENT ENTRY POINT
JSR GTSTG CONVERT SECOND ARGUMENT TO STRING
ERR 074,CONVERT SECOND ARGUMENT IS NOT STRING
JSR FLSTG FOLD LOWER CASE TO UPPER CASE
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 WA,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
IFF CNVRT,SCV08 REAL
IFF CNVBT,SCV28 BUFFER
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
*
* HERE TO CONVERT TO REAL
*
SCV08 JSR GTREA CONVERT TO REAL
PPM EXFAL FAIL IF CONVERSION NOT POSSIBLE
BRN EXIXR ELSE RETURN REAL
*
* 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 BYTES
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
*
* CONVERT TO BUFFER
*
SCV28 MOV XR,-(XS) STACK STRING FOR PROCEDURE
JSR GTSTG CONVERT TO STRING
PPM EXFAL FAIL IF CONVERSION NOT POSSIBLE
MOV XR,XL SAVE STRING POINTER
JSR ALOBF ALLOCATE BUFFER OF SAME SIZE
JSR APNDB COPY IN THE STRING
PPM ALREADY STRING - CANT FAIL TO CNV
PPM MUST BE ENOUGH ROOM
BRN EXSID EXIT SETTING IDVAL FIELD
EJC
*
* COPY
*
S$COP ENT ENTRY POINT
JSR COPYB COPY THE BLOCK
PPM EXITS RETURN IF NO IDVAL FIELD
BRN EXSID EXIT SETTING ID VALUE
EJC
*
* DATA
*
S$DAT ENT ENTRY POINT
JSR XSCNI PREPARE TO SCAN ARGUMENT
ERR 075,DATA ARGUMENT IS NOT STRING
ERR 076,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 077,DATA ARGUMENT IS MISSING A LEFT PAREN
*
* HERE AFTER SCANNING DATATYPE NAME
*
SDAT1 MOV SCLEN(XR),WA GET LENGTH
JSR FLSTG FOLD LOWER CASE TO UPPER CASE
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 078,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 079,DATA ARGUMENT IS MISSING A RIGHT PAREN
*
* HERE AFTER SCANNING OUT ONE FIELD NAME
*
SDAT3 JSR GTNVR LOCATE VRBLK FOR FIELD NAME
ERR 080,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 BYTES
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$DEF 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 081,DEFINE FIRST ARGUMENT IS NOT STRING
ERR 082,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 083,DEFINE FIRST ARGUMENT IS MISSING A LEFT PAREN
*
* HERE AFTER SCANNING OUT FUNCTION NAME
*
SDF02 JSR GTNVR GET VARIABLE NAME
ERR 084,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
BNZ WA,SDF04 SKIP IF DELIMITER FOUND
ERB 085,NULL ARG NAME OR MISSING ) IN DEFINE FIRST ARG.
EJC
*
* DEFINE (CONTINUED)
*
* HERE AFTER SCANNING AN ARGUMENT NAME
*
SDF04 BNE XR,=NULLS,SDF05 SKIP IF NON-NULL
BZE WB,SDF06 IGNORE NULL IF CASE OF NO ARGUMENTS
*
* HERE AFTER DEALING WITH THE CASE OF NO ARGUMENTS
*
SDF05 JSR GTNVR GET VRBLK POINTER
PPM SDF03 LOOP BACK TO 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
*
* HERE AFTER SCANNING OUT FUNCTION ARGUMENT NAMES
*
SDF06 MOV WB,DEFNA SAVE NUMBER OF ARGUMENTS
ZER WB ZERO COUNT OF LOCALS
*
* LOOP TO SCAN LOCAL NAMES AND STACK VRBLK POINTERS
*
SDF07 MOV =CH$CM,WC SET DELIMITER ONE = COMMA
MOV WC,XL SET DELIMITER TWO = COMMA
JSR XSCAN SCAN OUT NEXT LOCAL NAME
BNE XR,=NULLS,SDF08 SKIP IF NON-NULL
BZE WB,SDF09 IGNORE NULL IF CASE OF NO LOCALS
*
* HERE AFTER SCANNING OUT A LOCAL NAME
*
SDF08 JSR GTNVR GET VRBLK POINTER
PPM SDF07 LOOP BACK TO IGNORE NULL NAME
ICV WB IF OK, INCREMENT COUNT
MOV XR,-(XS) STACK VRBLK POINTER
BNZ WA,SDF07 LOOP BACK IF STOPPED BY A COMMA
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 BYTES
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 086,DEFINE FUNCTION ENTRY POINT IS NOT DEFINED LABEL
EJC
*
* DETACH
*
S$DET ENT ENTRY POINT
MOV (XS)+,XR LOAD ARGUMENT
JSR GTVAR LOCATE VARIABLE
ERR 087,DETACH ARGUMENT IS NOT APPROPRIATE NAME
JSR DTACH DETACH I/O ASSOCIATION FROM NAME
BRN EXNUL RETURN NULL RESULT
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 088,DUMP ARGUMENT IS NOT INTEGER
ERR 089,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 090,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 091,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
JSR IOFCB CALL FCBLK ROUTINE
ERR 092,EJECT ARGUMENT IS NOT A SUITABLE NAME
PPM SEJC1 NULL ARGUMENT
JSR SYSEF CALL EJECT FILE FUNCTION
ERR 093,EJECT FILE DOES NOT EXIST
ERR 094,EJECT FILE DOES NOT PERMIT PAGE EJECT
ERR 095,EJECT CAUSED NON-RECOVERABLE OUTPUT ERROR
BRN EXNUL RETURN NULL AS RESULT
*
* HERE TO EJECT STANDARD OUTPUT FILE
*
SEJC1 JSR SYSEP CALL ROUTINE TO EJECT PRINTER
BRN EXNUL EXIT WITH NULL RESULT
EJC
*
* ENDFILE
*
S$ENF ENT ENTRY POINT
JSR IOFCB CALL FCBLK ROUTINE
ERR 096,ENDFILE ARGUMENT IS NOT A SUITABLE NAME
ERR 097,ENDFILE ARGUMENT IS NULL
JSR SYSEN CALL ENDFILE ROUTINE
ERR 098,ENDFILE FILE DOES NOT EXIST
ERR 099,ENDFILE FILE DOES NOT PERMIT ENDFILE
ERR 100,ENDFILE CAUSED NON-RECOVERABLE OUTPUT ERROR
MOV XL,WB REMEMBER VRBLK PTR FROM IOFCB CALL
*
* LOOP TO FIND TRTRF BLOCK
*
SENF1 MOV XL,XR COPY POINTER
MOV TRVAL(XR),XR CHAIN ALONG
BNE (XR),=B$TRT,EXNUL SKIP OUT IF CHAIN END
BNE TRTYP(XR),=TRTFC,SENF1 LOOP IF NOT FOUND
MOV TRVAL(XR),TRVAL(XL) REMOVE TRTRF
MOV TRTRF(XR),ENFCH POINT TO HEAD OF IOCHN
MOV TRFPT(XR),WC POINT TO FCBLK
MOV WB,XR FILEARG1 VRBLK FROM IOFCB
JSR SETVR RESET IT
MOV =R$FCB,XL PTR TO HEAD OF FCBLK CHAIN
SUB *NUM02,XL ADJUST READY TO ENTER LOOP
*
* FIND FCBLK
*
SENF2 MOV XL,XR COPY PTR
MOV 2(XL),XL GET NEXT LINK
BZE XL,SENF4 STOP IF CHAIN END
BEQ 3(XL),WC,SENF3 JUMP IF FCBLK FOUND
BRN SENF2 LOOP
*
* REMOVE FCBLK
*
SENF3 MOV 2(XL),2(XR) DELETE FCBLK FROM CHAIN
*
* LOOP WHICH DETACHES ALL VBLS ON IOCHN CHAIN
*
SENF4 MOV ENFCH,XL GET CHAIN HEAD
BZE XL,EXNUL FINISHED IF CHAIN END
MOV TRTRF(XL),ENFCH CHAIN ALONG
MOV IONMO(XL),WA NAME OFFSET
MOV IONMB(XL),XL NAME BASE
JSR DTACH DETACH NAME
BRN SENF4 LOOP TILL DONE
EJC
*
* EQ
*
S$EQF ENT ENTRY POINT
JSR ACOMP CALL ARITHMETIC COMPARISON ROUTINE
ERR 101,EQ FIRST ARGUMENT IS NOT NUMERIC
ERR 102,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 103,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
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 104,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
MOV R$FCB,WB GET FCBLK CHAIN HEADER
*
* MERGE TO CALL OSINT EXIT ROUTINE
*
SEXT1 MOV =HEADV,XR POINT TO V.V STRING
JSR SYSXI CALL EXTERNAL ROUTINE
ERR 105,EXIT ACTION NOT AVAILABLE IN THIS IMPLEMENTATION
ERR 106,EXIT ACTION CAUSED IRRECOVERABLE ERROR
IEQ EXNUL RETURN IF ARGUMENT 0
ZER GBCNT RESUMING EXECUTION SO RESET
IGT SEXT2 SKIP IF POSITIVE
NGI MAKE POSITIVE
*
* CHECK FOR OPTION RESPECIFICATION
*
SEXT2 MFI WC GET VALUE IN WORK REG
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)+,WC RESTORE VALUE
*
* DEAL WITH HEADER OPTION (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 EXECUTION TIME START (SGD11)
STI TIMSX SAVE AS INITIAL TIME
LDI KVSTC RESET TO ENSURE ...
STI KVSTL ... CORRECT EXECUTION STATS
BRN EXNUL RESUME EXECUTION
EJC
*
* FIELD
*
S$FLD ENT ENTRY POINT
JSR GTSMI GET SECOND ARGUMENT (FIELD NUMBER)
ERR 107,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 108,FIELD FIRST ARGUMENT IS NOT DATATYPE NAME
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 259,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
*
* GE
*
S$GEF ENT ENTRY POINT
JSR ACOMP CALL ARITHMETIC COMPARISON ROUTINE
ERR 109,GE FIRST ARGUMENT IS NOT NUMERIC
ERR 110,GE SECOND ARGUMENT IS NOT NUMERIC
PPM EXFAL FAIL IF LT
PPM EXNUL RETURN NULL IF EQ
PPM EXNUL RETURN NULL IF GT
EJC
*
* GT
*
S$GTF ENT ENTRY POINT
JSR ACOMP CALL ARITHMETIC COMPARISON ROUTINE
ERR 111,GT FIRST ARGUMENT IS NOT NUMERIC
ERR 112,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
MOV (XS)+,XR GET THIRD ARG
MOV (XS)+,XL GET SECOND ARG
MOV (XS)+,WA GET FIRST ARG
JSR SYSHS ENTER SYSHS ROUTINE
ERR 254,ERRONEOUS ARGUMENT FOR HOST
ERR 255,ERROR DURING EXECUTION OF HOST
PPM SHST1 STORE HOST STRING
PPM EXNUL RETURN NULL RESULT
PPM EXIXR RETURN XR
PPM EXFAL FAIL RETURN
*
* RETURN HOST STRING
*
SHST1 BZE XL,EXNUL NULL STRING IF SYSHS UNCOOPERATIVE
MOV SCLEN(XL),WA LENGTH
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 113,INPUT THIRD ARGUMENT IS NOT A STRING
ERR 114,INAPPROPRIATE SECOND ARGUMENT FOR INPUT
ERR 115,INAPPROPRIATE FIRST ARGUMENT FOR INPUT
ERR 116,INAPPROPRIATE FILE SPECIFICATION FOR INPUT
PPM EXFAL FAIL IF FILE DOES NOT EXIST
ERR 117,INPUT FILE CANNOT BE READ
BRN EXNUL RETURN NULL STRING
EJC
*
* INSERT
*
S$INS ENT ENTRY POINT
MOV (XS)+,XL GET STRING ARG
JSR GTSMI GET REPLACE LENGTH
ERR 277,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 278,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 279,INSERT FIRST ARGUMENT NOT BUFFER
*
* HERE WHEN EVERYTHING LOADED UP
*
SINS1 JSR INSBF CALL TO INSERT
ERR 280,INSERT FOURTH ARGUMENT NOT A STRING
PPM EXFAL FAIL IF OUT OF RANGE
BRN EXNUL ELSE OK - EXIT WITH NULL
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
*
* 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 118,LE FIRST ARGUMENT IS NOT NUMERIC
ERR 119,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 120,LEN ARGUMENT IS NOT INTEGER OR EXPRESSION
ERR 121,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 122,LEQ FIRST ARGUMENT IS NOT STRING
ERR 123,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 124,LGE FIRST ARGUMENT IS NOT STRING
ERR 125,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 126,LGT FIRST ARGUMENT IS NOT STRING
ERR 127,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 128,LLE FIRST ARGUMENT IS NOT STRING
ERR 129,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 130,LLT FIRST ARGUMENT IS NOT STRING
ERR 131,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 132,LNE FIRST ARGUMENT IS NOT STRING
ERR 133,LNE SECOND ARGUMENT IS NOT STRING
PPM EXNUL RETURN NULL IF LLT
PPM EXFAL FAIL IF LEQ
PPM EXNUL RETURN NULL IF LGT
EJC
*
* LOCAL
*
S$LOC ENT ENTRY POINT
JSR GTSMI GET SECOND ARGUMENT (LOCAL NUMBER)
ERR 134,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 135,LOCAL FIRST ARG IS NOT A PROGRAM FUNCTION NAME
EJC
*
* LOAD
*
S$LOD ENT ENTRY POINT
JSR GTSTG LOAD LIBRARY NAME
ERR 136,LOAD SECOND ARGUMENT IS NOT STRING
MOV XR,XL SAVE LIBRARY NAME
JSR XSCNI PREPARE TO SCAN FIRST ARGUMENT
ERR 137,LOAD FIRST ARGUMENT IS NOT STRING
ERR 138,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 139,LOAD FIRST ARGUMENT IS MISSING A LEFT PAREN
*
* HERE AFTER SUCCESSFULLY SCANNING FUNCTION NAME
*
SLOD1 JSR GTNVR LOCATE VRBLK
ERR 140,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 141,LOAD FIRST ARGUMENT IS MISSING A RIGHT PAREN
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
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
MOV (XS),XR ELSE RELOAD STRING POINTER
ICV WB SET CODE FOR REAL (3)
MOV =SCREA,XL POINT TO /REAL/
JSR IDENT CHECK FOR MATCH
PPM SLOD4 JUMP IF MATCH
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 BYTES
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
ERR 142,LOAD FUNCTION DOES NOT EXIST
ERR 143,LOAD FUNCTION CAUSED INPUT ERROR DURING LOAD
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
EJC
*
* LPAD
*
S$LPD ENT ENTRY POINT
JSR GTSTG GET PAD CHARACTER
ERR 144,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 145,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 146,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 147,LT FIRST ARGUMENT IS NOT NUMERIC
ERR 148,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 149,NE FIRST ARGUMENT IS NOT NUMERIC
ERR 150,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 151,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 152,OPSYN THIRD ARGUMENT IS NOT INTEGER
ERR 153,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 154,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 155,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 156,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 =NUM03,WB OUTPUT FLAG
JSR IOPUT CALL INPUT/OUTPUT ASSOC. ROUTINE
ERR 157,OUTPUT THIRD ARGUMENT IS NOT A STRING
ERR 158,INAPPROPRIATE SECOND ARGUMENT FOR OUTPUT
ERR 159,INAPPROPRIATE FIRST ARGUMENT FOR OUTPUT
ERR 160,INAPPROPRIATE FILE SPECIFICATION FOR OUTPUT
PPM EXFAL FAIL IF FILE DOES NOT EXIST
ERR 161,OUTPUT FILE CANNOT BE WRITTEN TO
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 162,POS ARGUMENT IS NOT INTEGER OR EXPRESSION
ERR 163,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
BEQ WA,=B$BCT,SPR05 JUMP IF BUFFER
ERB 164,PROTOTYPE ARGUMENT IS NOT VALID OBJECT
*
* 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
*
* HERE FOR BUFFER
*
SPR05 MOV BCBUF(XR),XR POINT TO BFBLK
MTI BFALC(XR) LOAD ALLOCATED LENGTH
BRN EXINT EXIT WITH INTEGER ALLOCATION
EJC
*
* REMDR
*
S$RMD ENT ENTRY POINT
ZER WB SET POSITIVE FLAG
MOV (XS),XR LOAD SECOND ARGUMENT
JSR GTINT CONVERT TO INTEGER
ERR 165,REMDR SECOND ARGUMENT IS NOT INTEGER
JSR ARITH CONVERT ARGS
PPM SRM01 FIRST ARG NOT INTEGER
PPM SECOND ARG CHECKED ABOVE
PPM SRM01 FIRST ARG REAL
LDI ICVAL(XR) LOAD LEFT ARGUMENT VALUE
RMI ICVAL(XL) GET REMAINDER
INO EXINT JUMP IF NO OVERFLOW
ERB 167,REMDR CAUSED INTEGER OVERFLOW
*
* FAIL FIRST ARGUMENT
*
SRM01 ERB 166,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 168,REPLACE THIRD ARGUMENT IS NOT STRING
MOV XR,XL SAVE THIRD ARG PTR
JSR GTSTG GET SECOND ARGUMENT
ERR 169,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 170,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 171,NULL OR UNEQUALLY LONG 2ND, 3RD ARGS TO REPLACE
EJC
*
* REWIND
*
S$REW ENT ENTRY POINT
JSR IOFCB CALL FCBLK ROUTINE
ERR 172,REWIND ARGUMENT IS NOT A SUITABLE NAME
ERR 173,REWIND ARGUMENT IS NULL
JSR SYSRW CALL SYSTEM REWIND FUNCTION
ERR 174,REWIND FILE DOES NOT EXIST
ERR 175,REWIND FILE DOES NOT PERMIT REWIND
ERR 176,REWIND CAUSED NON-RECOVERABLE ERROR
BRN EXNUL EXIT WITH NULL RESULT IF NO ERROR
EJC
*
* REVERSE
*
S$RVS ENT ENTRY POINT
JSR GTSTG LOAD STRING ARGUMENT
ERR 177,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 178,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 179,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 180,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 181,RTAB ARGUMENT IS NOT INTEGER OR EXPRESSION
ERR 182,RTAB ARGUMENT IS NEGATIVE OR TOO LARGE
BRN EXIXR RETURN PATTERN NODE
EJC
*
* SET
*
S$SET ENT ENTRY POINT
MOV (XS)+,R$IO2 SAVE THIRD ARG
MOV (XS)+,R$IO1 SAVE SECOND ARG
JSR IOFCB CALL FCBLK ROUTINE
ERR 291,SET FIRST ARGUMENT IS NOT A SUITABLE NAME
ERR 292,SET FIRST ARGUMENT IS NULL
MOV R$IO1,WB LOAD SECOND ARG
MOV R$IO2,WC LOAD THIRD ARG
JSR SYSST CALL SYSTEM SET ROUTINE
ERR 293,INAPPROPRIATE SECOND ARGUMENT TO SET
ERR 294,INAPPROPRIATE THIRD ARGUMENT TO SET
ERR 295,SET FILE DOES NOT EXIST
ERR 296,SET FILE DOES NOT PERMIT SETTING FILE POINTER
ERR 297,SET CAUSED NON-RECOVERABLE I/O ERROR
BRN EXNUL OTHERWISEW RETURN NULL
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 183,TAB ARGUMENT IS NOT INTEGER OR EXPRESSION
ERR 184,TAB ARGUMENT IS NEGATIVE OR TOO LARGE
BRN EXIXR RETURN PATTERN NODE
EJC
*
* 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 185,RPOS ARGUMENT IS NOT INTEGER OR EXPRESSION
ERR 186,RPOS ARGUMENT IS NEGATIVE OR TOO LARGE
BRN EXIXR RETURN PATTERN NODE
EJC
*
* RSORT
*
S$RSR ENT ENTRY POINT
MNZ WA MARK AS RSORT
JSR SORTA CALL SORT ROUTINE
BRN EXSID RETURN, SETTING IDVAL
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 187,SETEXIT ARGUMENT IS NOT LABEL NAME OR NULL
EJC
*
* SORT
*
S$SRT ENT ENTRY POINT
ZER WA MARK AS SORT
JSR SORTA CALL SORT ROUTINE
BRN EXSID RETURN, SETTING IDVAL
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 188,SPAN ARGUMENT IS NOT STRING OR EXPRESSION
BRN EXIXR JUMP FOR NEXT CODE WORD
EJC
*
* SIZE
*
S$SI$ ENT ENTRY POINT
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
ERR 189,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 190,STOPTR FIRST ARGUMENT IS NOT APPROPRIATE NAME
ERR 191,STOPTR SECOND ARGUMENT IS NOT TRACE TYPE
BRN EXNUL RETURN NULL
EJC
*
* SUBSTR
*
S$SUB ENT ENTRY POINT
JSR GTSMI LOAD THIRD ARGUMENT
ERR 192,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 193,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
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
ERR 194,SUBSTR FIRST ARGUMENT IS NOT STRING
*
* MERGE WITH BFBLK OR SCBLK PTR IN XR. WA HAS LENGTH
*
SSUBB MOV SBSSV,WC RELOAD THIRD ARGUMENT
BNZ WC,SSUB1 SKIP IF THIRD ARG GIVEN
MOV WA,WC ELSE GET STRING LENGTH
BGT WB,WC,EXFAL FAIL IF IMPROPER
SUB WB,WC REDUCE BY OFFSET TO START
*
* MERGE
*
SSUB1 MOV WA,XL SAVE STRING LENGTH
MOV WC,WA SET LENGTH OF SUBSTRING
ADD WB,WC ADD 2ND ARG TO 3RD ARG
BGT WC,XL,EXFAL JUMP IF IMPROPER SUBSTRING
MOV XR,XL COPY POINTER TO FIRST ARG
JSR SBSTR BUILD SUBSTRING
BRN EXIXR AND JUMP FOR NEXT CODE WORD
EJC
*
* TABLE
*
S$TBL ENT ENTRY POINT
MOV (XS)+,XL GET INITIAL LOOKUP VALUE
ICA XS POP SECOND ARGUMENT
JSR GTSMI LOAD ARGUMENT
ERR 195,TABLE ARGUMENT IS NOT INTEGER
ERR 196,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 BYTES
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 197,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 198,TRACE FIRST ARGUMENT IS NOT APPROPRIATE NAME
ERR 199,TRACE SECOND ARGUMENT IS NOT TRACE TYPE
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 200,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 201,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
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 TRFPT(XR),XL GET FILE CTRL BLK PTR OR ZERO
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
JSR SYSRD READ NEXT STANDARD INPUT IMAGE
PPM ACS03 JUMP TO FAIL EXIT IF END OF FILE
BRN ACS07 ELSE MERGE WITH OTHER FILE CASE
*
* HERE FOR INPUT FROM OTHER THAN STANDARD INPUT FILE
*
ACS06 MOV XL,WA FCBLK PTR
JSR SYSIL GET INPUT RECORD MAX LENGTH (TO WA)
JSR ALOCS ALLOCATE STRING OF CORRECT SIZE
MOV XL,WA FCBLK PTR
JSR SYSIN CALL SYSTEM INPUT ROUTINE
PPM ACS03 JUMP TO FAIL EXIT IF END OF FILE
PPM ACS22 ERROR
PPM ACS23 ERROR
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 KVABE(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
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,5 SWITCH ON KEYWORD NUMBER
IFF K$$AL,ACS16 JUMP IF ALPHABET
IFF K$$RT,ACS17 RTNTYPE
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
BRN ACS07 MERGE WITH RECORD READ
*
* ERROR RETURNS
*
ACS22 MOV XR,DNAMP POP UNUSED SCBLK
ERB 202,INPUT FROM FILE CAUSED NON-RECOVERABLE ERROR
*
ACS23 MOV XR,DNAMP POP UNUSED SCBLK
ERB 203,INPUT FILE RECORD HAS INCORRECT FORMAT
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
PPM ACMP4 JUMP IF REAL ARGUMENTS
*
* 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
*
* 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
*
* HERE IF ARG1 LT ARG2
*
ACMP5 EXI 3 TAKE LT EXIT
*
* HERE IF OVERFLOW ON REAL SUBTRACTION
*
ACMP6 LDR RCVAL(XL) RELOAD ARG2
RLT ACMP1 GT IF NEGATIVE
BRN ACMP5 ELSE LT
*
* 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 BYTES
* 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 (SGD05)
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 204,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 BYTES 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 (SGD05)
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
*
* 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
* (XR) BCBLK PTR
* (WA,WB) DESTROYED
*
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 BFCHR(XL) CLEAR FIRST WORD (NULL PAD)
MOV WA,XL RESTORE ENTRY XL
EXI RETURN TO CALLER
*
* HERE FOR MXLEN EXCEEDED
*
ALB01 ERB 274,REQUESTED BUFFER ALLOCATION EXCEEDS MXLEN
ENP END PROCEDURE ALOBF
EJC
*
* 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 BYTES
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 205,STRING LENGTH EXCEEDS VALUE OF MAXLNGTH KEYWORD
ENP END PROCEDURE ALOCS
EJC
*
* ALOST -- ALLOCATE SPACE IN STATIC REGION
*
* (WA) LENGTH REQUIRED IN BYTES
* 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
*
* APNDB -- APPEND STRING TO BUFFER
*
* THIS ROUTINE IS USED BY BUFFER HANDLING ROUTINES TO
* APPEND DATA TO AN EXISTING BFBLK.
*
* (XR) EXISTING BCBLK TO BE APPENDED
* (XL) CONVERTABLE TO STRING
* JSR APNDB CALL TO APPEND TO BUFFER
* PPM LOC THREAD IF (XL) CANT BE CONVERTED
* PPM LOC IF NOT ENOUGH ROOM
* (WA,WB) DESTROYED
*
* IF MORE CHARACTERS ARE SPECIFIED THAN CAN BE INSERTED,
* THEN NO ACTION IS TAKEN AND THE SECOND RETURN IS TAKEN.
*
APNDB PRC E,2 ENTRY POINT
MOV BCLEN(XR),WA LOAD OFFSET TO INSERT
ZER WB REPLACE SECTION IS NULL
JSR INSBF CALL TO INSERT AT END
PPM APN01 CONVERT ERROR
PPM APN02 NO ROOM
EXI RETURN TO CALLER
*
* HERE TO TAKE CONVERT FAILURE EXIT
*
APN01 EXI 1 RETURN TO CALLER ALTERNATE
*
* HERE FOR NO FIT EXIT
*
APN02 EXI 2 ALTERNATE EXIT TO CALLER
ENP END PROCEDURE APNDB
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
* PPM LOC TRANSFER LOC FOR REAL OPERANDS
*
* 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
*
* 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
EJC
*
* ARITH (CONTINUED)
*
* ENTRY POINT
*
ARITH PRC N,3 ENTRY POINT
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
BEQ WA,=B$RCL,ARTH4 JUMP IF REAL
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
BEQ WA,=B$RCL,ARTH4 JUMP IF RIGHT ARG IS REAL
*
* 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
*
* 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
*
* 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 DURING EXPRESSION EVALUATION
*
ASG03 ICA XS REMOVE STACKED VALUE ENTRY
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(WC),-(XS) STACK VALUE TO OUTPUT (SGD01)
JSR GTSTG CONVERT TO STRING
PPM ASG12 GET DATATYPE NAME IF UNCONVERTIBLE
*
* MERGE WITH STRING FOR OUTPUT
*
ASG11 MOV TRFPT(XL),WA FCBLK PTR
BZE WA,ASG13 JUMP IF STANDARD OUTPUT FILE
*
* HERE FOR OUTPUT TO NON-STANDARD OUTPUT FILE
*
JSR SYSOU CALL SYSTEM OUTPUT ROUTINE
ERR 206,OUTPUT CAUSED FILE OVERFLOW
ERR 207,OUTPUT CAUSED NON-RECOVERABLE ERROR
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 ON THE PRINTER
*
ASG13 JSR PRTST PRINT STRING VALUE
BEQ TRTER(XL),=V$TER,ASG20 JUMP IF TERMINAL OUTPUT
JSR PRTNL END OF LINE
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 208,KEYWORD VALUE ASSIGNED IS NOT INTEGER
LDI ICVAL(XR) ELSE LOAD VALUE
BEQ XL,=K$STL,ASG16 JUMP IF SPECIAL CASE OF STLIMIT
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
BEQ XL,=K$PFL,ASG21 JUMP IF SPECIAL CASE OF PROFILE
BLT XL,=K$P$$,ASG15 JUMP UNLESS PROTECTED
ERB 209,KEYWORD IN ASSIGNMENT IS PROTECTED
*
* HERE TO DO ASSIGNMENT IF NOT PROTECTED
*
ASG15 MOV WA,KVABE(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
*
* 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 210,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 211,VALUE ASSIGNED TO KEYWORD ERRTEXT NOT A STRING
MOV XR,R$ETX MAKE ASSIGNMENT
EXI RETURN TO CALLER
*
* PRINT STRING TO TERMINAL
*
ASG20 JSR PRTTR PRINT
EXI RETURN
*
* 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 268,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
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 BYTES
* (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$BC,BLN04 BCBLK
IFF BL$BF,BLN11 BFBLK
IFF BL$CD,BLN01 CDBLK
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
IFF BL$RC,BLN09 RCBLK
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,BC)
*
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
*
* HERE FOR RCBLK
*
BLN09 MOV *RCSI$,WA SET SIZE OF RCBLK
EXI RETURN TO BLKLN CALLER
*
* HERE FOR SCBLK
*
BLN10 MOV SCLEN(XR),WA LOAD LENGTH IN CHARACTERS
CTB WA,SCSI$ CALCULATE LENGTH IN BYTES
EXI RETURN TO BLKLN CALLER
*
* HERE FOR BFBLK
*
BLN11 MOV BFALC(XR),WA GET ALLOCATION IN BYTES
CTB WA,BFSI$ CALCULATE LENGTH IN BYTES
EXI RETURN TO BLKLN CALLER
ENP END PROCEDURE BLKLN
EJC
*
* COPYB -- COPY A BLOCK
*
* (XS) BLOCK TO BE COPIED
* JSR COPYB 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
*
COPYB PRC N,1 ENTRY POINT
MOV (XS),XR LOAD ARGUMENT
BEQ XR,=NULLS,COP10 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,COP05 JUMP IF TABLE
BEQ WB,=B$VCT,COP01 JUMP IF VECTOR
BEQ WB,=B$PDT,COP01 JUMP IF PROGRAM DEFINED
BEQ WB,=B$BCT,COP11 JUMP IF BUFFER
BNE WB,=B$ART,COP10 RETURN COPY IF NOT ARRAY
*
* HERE FOR ARRAY (ARBLK)
*
ADD AROFS(XR),XR POINT TO PROTOTYPE FIELD
BRN COP02 JUMP TO MERGE
*
* HERE FOR VECTOR, PROGRAM DEFINED
*
COP01 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)
*
COP02 MOV (XR),XL LOAD NEXT POINTER
*
* LOOP TO GET VALUE AT END OF TRBLK CHAIN
*
COP03 BNE (XL),=B$TRT,COP04 JUMP IF NOT TRAPPED
MOV TRVAL(XL),XL ELSE POINT TO NEXT VALUE
BRN COP03 AND LOOP BACK
EJC
*
* COPYB (CONTINUED)
*
* HERE WITH UNTRAPPED VALUE IN XL
*
COP04 MOV XL,(XR)+ STORE REAL VALUE, BUMP POINTER
BNE XR,DNAMP,COP02 LOOP BACK IF MORE TO GO
BRN COP09 ELSE JUMP TO EXIT
*
* HERE TO COPY A TABLE
*
COP05 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
*
COP06 MOV (XS),XR LOAD TABLE POINTER
BEQ WC,TBLEN(XR),COP09 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
*
COP07 MOV TENXT(XR),XL LOAD POINTER TO NEXT TEBLK
MOV (XS),TENXT(XR) SET END OF CHAIN POINTER IN CASE
BEQ (XL),=B$TBT,COP06 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
*
COP08 MOV TEVAL(XL),XL LOAD VALUE
BEQ (XL),=B$TRT,COP08 LOOP BACK IF TRAPPED
MOV XL,TEVAL(XR) STORE UNTRAPPED VALUE IN TEBLK
BRN COP07 BACK FOR NEXT TEBLK
*
* COMMON EXIT POINT
*
COP09 MOV (XS)+,XR LOAD POINTER TO BLOCK
EXI RETURN
*
* ALTERNATIVE RETURN
*
COP10 EXI 1 RETURN
EJC
*
* HERE TO COPY BUFFER
*
COP11 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 COP09 BRANCH TO EXIT
ENP END PROCEDURE COPYB
*
* 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 212,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
BNZ VRLEN(XR),CGVL0 JUMP IF NOT SYSTEM VARIABLE
MOV XR,-(XS) STACK XR
MOV VRSVP(XR),XR POINT TO SVBLK
MOV SVBIT(XR),WA GET SVBLK PROPERTY BITS
MOV (XS)+,XR RECOVER XR
ANB BTCKW,WA CHECK IF CONSTANT KEYWORD
NZB WA,CGV00 JUMP IF CONSTANT KEYWORD
*
* 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 SET TO THE
* VALUE OF CSWNO (ZERO IF -OPTIMISE, 1 IF -NOOPT) 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
MOV CSWNO,WC RESET CONSTANT 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$CNP,CGV24 CONCATENATION (NOT PATTERN MATCH)
IFF C$UNM,CGV27 UNOPS WITH NAME OPND
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 (BYTES)
BTW WB CONVERT BYTES 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 BYTES
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 213,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
BNE STAGE,=STGIC,CMP02 SKIP UNLESS INITIAL COMPILE
JSR READR READ NEXT INPUT IMAGE
BZE XR,CMP09 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
*
* 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,CMP32 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 214,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
BEQ WC,=CH$HT,CMP07 JUMP IF HORIZONTAL TAB
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,CMP10 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,CMP10 JUMP IF OK (END OF IMAGE)
*
* HERE FOR BAD TRANSFER LABEL
*
CMP08 ERB 215,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,CMP10 JUMP IF CODE CALL (OK)
ERB 216,SYNTAX ERROR. MISSING END LINE
*
* HERE AFTER PROCESSING END LINE (MERGE HERE ON END ERROR)
*
CMP10 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 217,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,CMP31 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 218,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
EXI AND RETURN TO CMPIL CALLER
*
* HERE AT END OF GOTO FIELD
*
CMP31 MOV CMFGO(XS),WB GET FAIL GOTO
ORB CMSGO(XS),WB OR IN SUCCESS GOTO
BNZ WB,CMP18 OK IF NON-NULL FIELD
ERB 219,SYNTAX ERROR. EMPTY GOTO FIELD
*
* CONTROL CARD FOUND
*
CMP32 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,CNC09 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
FLC WA FOLD TO UPPER CASE
BEQ WA,=CH$LI,CNC07 SPECIAL CASE OF -INXXX
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
JSR SBSTR EXTRACT SUBSTRING FOR COMPARISON
MOV SCLEN(XR),WA RELOAD LENGTH
JSR FLSTG FOLD TO UPPER CASE
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$NC 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$NC SWITCH
IFF CC$CA,CNC37 -CASE
IFF CC$DO,CNC10 -DOUBLE
IFF CC$DU,CNC11 -DUMP
IFF CC$EJ,CNC12 -EJECT
IFF CC$ER,CNC13 -ERRORS
IFF CC$EX,CNC14 -EXECUTE
IFF CC$FA,CNC15 -FAIL
IFF CC$LI,CNC16 -LIST
IFF CC$NR,CNC17 -NOERRORS
IFF CC$NX,CNC18 -NOEXECUTE
IFF CC$NF,CNC19 -NOFAIL
IFF CC$NL,CNC20 -NOLIST
IFF CC$NO,CNC21 -NOOPT
IFF CC$NP,CNC22 -NOPRINT
IFF CC$OP,CNC24 -OPTIMISE
IFF CC$PR,CNC25 -PRINT
IFF CC$SI,CNC27 -SINGLE
IFF CC$SP,CNC28 -SPACE
IFF CC$ST,CNC31 -STITLE
IFF CC$TI,CNC32 -TITLE
IFF CC$TR,CNC36 -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 247,INVALID CONTROL CARD
*
* SPECIAL PROCESSING FOR -INXXX
*
CNC07 LCH WA,(XR) GET NEXT CHAR
FLC WA FOLD TO UPPER CASE
BNE WA,=CH$LN,CNC06 FAIL IF NOT LETTER N
ADD =NUM02,SCNPT BUMP OFFSET PAST -IN
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
*
CNC08 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
*
CNC09 EXI RETURN
*
* -DOUBLE
*
CNC10 MNZ CSWDB SET SWITCH
BRN CNC08 MERGE
*
* -DUMP
* THIS IS USED FOR SYSTEM DEBUGGING . IT HAS THE EFFECT OF
* PRODUCING A CORE DUMP AT COMPILATION TIME
*
CNC11 JSR SYSDM CALL DUMPER
BRN CNC09 FINISHED
*
* -EJECT
*
CNC12 BZE CSWLS,CNC09 RETURN IF -NOLIST
JSR PRTPS EJECT
JSR LISTT LIST TITLE
BRN CNC09 FINISHED
*
* -ERRORS
*
CNC13 ZER CSWER CLEAR SWITCH
BRN CNC08 MERGE
*
* -EXECUTE
*
CNC14 ZER CSWEX CLEAR SWITCH
BRN CNC08 MERGE
*
* -FAIL
*
CNC15 MNZ CSWFL SET SWITCH
BRN CNC08 MERGE
*
* -LIST
*
CNC16 MNZ CSWLS SET SWITCH
BEQ STAGE,=STGIC,CNC08 DONE IF COMPILE TIME
*
* LIST CODE LINE IF EXECUTE TIME COMPILE
*
ZER LSTPF PERMIT LISTING
JSR LISTR LIST LINE
BRN CNC08 MERGE
EJC
*
* CNCRD (CONTINUED)
*
* -NOERRORS
*
CNC17 MNZ CSWER SET SWITCH
BRN CNC08 MERGE
*
* -NOEXECUTE
*
CNC18 MNZ CSWEX SET SWITCH
BRN CNC08 MERGE
*
* -NOFAIL
*
CNC19 ZER CSWFL CLEAR SWITCH
BRN CNC08 MERGE
*
* -NOLIST
*
CNC20 ZER CSWLS CLEAR SWITCH
BRN CNC08 MERGE
*
* -NOOPTIMISE
*
CNC21 MNZ CSWNO SET SWITCH
BRN CNC08 MERGE
*
* -NOPRINT
*
CNC22 ZER CSWPR CLEAR SWITCH
BRN CNC08 MERGE
*
* -OPTIMISE
*
CNC24 ZER CSWNO CLEAR SWITCH
BRN CNC08 MERGE
*
* -PRINT
*
CNC25 MNZ CSWPR SET SWITCH
BRN CNC08 MERGE
EJC
*
* CNCRD (CONTINUED)
*
* -SINGLE
*
CNC27 ZER CSWDB CLEAR SWITCH
BRN CNC08 MERGE
*
* -SPACE
*
CNC28 BZE CSWLS,CNC09 RETURN IF -NOLIST
JSR SCANE SCAN INTEGER AFTER -SPACE
MOV =NUM01,WC 1 SPACE IN CASE
BEQ XR,=T$SMC,CNC29 JUMP IF NO INTEGER
MOV XR,-(XS) STACK IT
JSR GTSMI CHECK INTEGER
PPM CNC06 FAIL IF NOT INTEGER
PPM CNC06 FAIL IF NEGATIVE OR LARGE
BNZ WC,CNC29 JUMP IF NON ZERO
MOV =NUM01,WC ELSE 1 SPACE
*
* MERGE WITH COUNT OF LINES TO SKIP
*
CNC29 ADD WC,LSTLC BUMP LINE COUNT
LCT WC,WC CONVERT TO LOOP COUNTER
BLT LSTLC,LSTNP,CNC30 JUMP IF FITS ON PAGE
JSR PRTPS EJECT
JSR LISTT LIST TITLE
BRN CNC09 MERGE
*
* SKIP LINES
*
CNC30 JSR PRTNL PRINT A BLANK
BCT WC,CNC30 LOOP
BRN CNC09 MERGE
EJC
*
* CNCRD (CONTINUED)
*
* -STITL
*
CNC31 MOV =R$STL,CNR$T PTR TO R$STL
BRN CNC33 MERGE
*
* -TITLE
*
CNC32 MOV =NULLS,R$STL CLEAR SUBTITLE
MOV =R$TTL,CNR$T PTR TO R$TTL
*
* COMMON PROCESSING FOR -TITLE, -STITL
*
CNC33 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,CNC34 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
*
CNC34 MOV CNR$T,XL POINT TO STORAGE LOCATION
MOV XR,(XL) STORE TITLE/SUBTITLE
BEQ XL,=R$STL,CNC09 RETURN IF STITL
BNZ PRECL,CNC09 RETURN IF EXTENDED LISTING
BZE PRICH,CNC09 RETURN IF REGULAR PRINTER
MOV SCLEN(XR),XL GET LENGTH OF TITLE
MOV XL,WA COPY IT
BZE XL,CNC35 JUMP IF NULL
ADD =NUM10,XL INCREMENT
BHI XL,PRLEN,CNC09 USE DEFAULT LSTP0 VAL IF TOO LONG
ADD =NUM04,WA POINT JUST PAST TITLE
*
* STORE OFFSET TO PAGE NN MESSAGE FOR SHORT TITLE
*
CNC35 MOV WA,LSTPO STORE OFFSET
BRN CNC09 RETURN
*
* -TRACE
* PROVIDED FOR SYSTEM DEBUGGING. TOGGLES THE SYSTEM LABEL
* TRACE SWITCH AT COMPILE TIME
*
CNC36 JSR SYSTT TOGGLE SWITCH
BRN CNC08 MERGE
*
* -CASE
* SETS VALUE OF KVCAS SO THAT NAMES ARE FOLDED OR NOT
* DURING COMPILATION.
*
CNC37 JSR SCANE SCAN INTEGER AFTER -CASE
ZER WC GET 0 IN CASE NONE THERE
BEQ XL,=T$SMC,CNC38 SKIP IF NO INTEGER
MOV XR,-(XS) STACK IT
JSR GTSMI CHECK INTEGER
PPM CNC06 FAIL IF NOT INTEGER
PPM CNC06 FAIL IF NEGATIVE OR TOO LARGE
CNC38 MOV WC,KVCAS STORE NEW CASE VALUE
BRN CNC09 MERGE
ENP END PROCEDURE CNCRD
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
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
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 248,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
*
* DTACH -- DETACH I/O ASSOCIATED NAMES
*
* DETACHES TRBLKS FROM I/O ASSOCIATED VARIABLES, REMOVES
* ENTRY FROM IOCHN CHAIN ATTACHED TO FILEARG1 VRBLK AND MAY
* REMOVE VRBLK ACCESS AND STORE TRAPS.
* INPUT, OUTPUT, TERMINAL ARE HANDLED SPECIALLY.
*
* (XL) I/O ASSOC. VBL NAME BASE PTR
* (WA) OFFSET TO NAME
* JSR DTACH CALL FOR DETACH OPERATION
* (XL,XR,WA,WB,WC) DESTROYED
*
DTACH PRC E,0 ENTRY POINT
MOV XL,DTCNB STORE NAME BASE (GBCOL NOT CALLED)
ADD WA,XL POINT TO NAME LOCATION
MOV XL,DTCNM STORE IT
*
* LOOP TO SEARCH FOR I/O TRBLK
*
DTCH1 MOV XL,XR COPY NAME POINTER
*
* CONTINUE AFTER BLOCK DELETION
*
DTCH2 MOV (XL),XL POINT TO NEXT VALUE
BNE (XL),=B$TRT,DTCH6 JUMP AT CHAIN END
MOV TRTYP(XL),WA GET TRAP BLOCK TYPE
BEQ WA,=TRTIN,DTCH3 JUMP IF INPUT
BEQ WA,=TRTOU,DTCH3 JUMP IF OUTPUT
ADD *TRNXT,XL POINT TO NEXT LINK
BRN DTCH1 LOOP
*
* DELETE AN OLD ASSOCIATION
*
DTCH3 MOV TRVAL(XL),(XR) DELETE TRBLK
MOV XL,WA DUMP XL ...
MOV XR,WB ... AND XR
MOV TRTRF(XL),XL POINT TO TRTRF TRAP BLOCK
BZE XL,DTCH5 JUMP IF NO IOCHN
BNE (XL),=B$TRT,DTCH5 JUMP IF INPUT, OUTPUT, TERMINAL
*
* LOOP TO SEARCH IOCHN CHAIN FOR NAME PTR
*
DTCH4 MOV XL,XR REMEMBER LINK PTR
MOV TRTRF(XL),XL POINT TO NEXT LINK
BZE XL,DTCH5 JUMP IF END OF CHAIN
MOV IONMB(XL),WC GET NAME BASE
ADD IONMO(XL),WC ADD OFFSET
BNE WC,DTCNM,DTCH4 LOOP IF NO MATCH
MOV TRTRF(XL),TRTRF(XR) REMOVE NAME FROM CHAIN
EJC
*
* DTACH (CONTINUED)
*
* PREPARE TO RESUME I/O TRBLK SCAN
*
DTCH5 MOV WA,XL RECOVER XL ...
MOV WB,XR ... AND XR
ADD *TRVAL,XL POINT TO VALUE FIELD
BRN DTCH2 CONTINUE
*
* EXIT POINT
*
DTCH6 MOV DTCNB,XR POSSIBLE VRBLK PTR
JSR SETVR RESET VRBLK IF NECESSARY
EXI RETURN
ENP END PROCEDURE DTACH
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 BYTE 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 EQ 2 FULL DUMP (INCL ARRAYS ETC.)
* DMARG GE 3 CORE DUMP
*
* 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
BGT XR,=NUM02,DMP29 JUMP IF CORE DUMP REQUIRED
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 PRTST PRINT IT
JSR PRTNL TERMINATE PRINT LINE
JSR PRTNL AND PRINT A BLANK LINE
*
* 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 PRTNL PRINT BLANK LINE
JSR PRTNL AND ANOTHER
MOV =DMHDK,XR POINT TO KEYWORD HEADING
JSR PRTST PRINT HEADING
JSR PRTNL END LINE
JSR PRTNL PRINT ONE BLANK LINE
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 PRTVL PRINT KEYWORD VALUE
JSR PRTNL TERMINATE PRINT LINE
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
BEQ WA,=B$BCT,DMP30 JUMP IF BUFFER
*
* 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 PRTNL PRINT BLANK LINE
MOV WA,DMPSA PRESERVE OFFSET
JSR PRTVL PRINT BLOCK VALUE (FOR TITLE)
MOV DMPSA,WA RECOVER OFFSET
JSR PRTNL END PRINT LINE
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
*
* CALL SYSTEM CORE DUMP ROUTINE
*
DMP29 JSR SYSDM CALL IT
BRN DMP28 RETURN
EJC
*
* DUMPR (CONTINUED)
*
* HERE TO DUMP BUFFER BLOCK
*
DMP30 JSR PRTNL PRINT BLANK LINE
JSR PRTVL PRINT VALUE ID FOR TITLE
JSR PRTNL FORCE NEW LINE
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 PRTCH PRINT IT
JSR PRTNL PRINT NEW LINE
MOV (XR),WA GET FIRST WD FOR BLKLN
BRN DMP15 MERGE TO GET NEXT BLOCK
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 PRTIS 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 PRTST PRINT ERROR MESSAGE TEXT
JSR PRTIS PRINT LINE
JSR PRTIS PRINT BLANK LINE
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
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
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
* PPM LOC TRANSFER LOC FOR SUCCESSFUL EVAL
* (THE NORMAL RETURN IS NEVER TAKEN)
* (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,4 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 4 TAKE SUCCESSFUL EXIT
*
* 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
* (WB) CURSOR
* JSR EVALS CALL TO EVALUATE STRING
* PPM LOC TRANSFER LOC FOR NON-STRING ARG
* PPM LOC TRANSFER LOC FOR EVALUATION FAILURE
* PPM LOC TRANSFER LOC FOR SUCCESSFUL EVAL
* (THE NORMAL RETURN IS NEVER TAKEN)
* (XR) PTR TO NODE WITH PARMS SET
* (XL,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.
*
EVALS PRC R,3 ENTRY POINT (RECURSIVE)
JSR EVALP EVALUATE EXPRESSION
PPM EVLS1 JUMP IF EVALUATION FAILS
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 =P$BRK,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
EXI 3 TAKE SUCCESS RETURN
*
* HERE IF EVALUATION FAILS
*
EVLS1 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)
*
EVLX3 MOV (XS)+,XR LOAD VALUE
BZE 1(XS),EVLX5 JUMP IF CALLED BY VALUE
ERB 249,EXPRESSION EVALUATED BY NAME RETURNED VALUE
*
* HERE FOR EXPRESSION RETURNING BY NAME (SEE O$RNM)
*
EVLX4 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 EVLX6 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)
*
EVLX6 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 BYTE 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 UNMISTAKABLE CONCAT.
*
* MERGE HERE WHEN XR SET UP WITH PROPER CONCATENATION DVBLK
*
EXP4A BNZ SCNBL,EXP26 MERGE BOP IF BLANKS, ELSE ERROR
DCV SCNSE ADJUST START OF ELEMENT LOCATION
ERB 220,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 221,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 222,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 223,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 224,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 BYTES
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 225,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 226,SYNTAX ERROR. MISSING RIGHT PAREN
*
* MISSING RIGHT PAREN IN GOTO FIELD
*
EXP22 ERB 227,SYNTAX ERROR. RIGHT PAREN MISSING FROM GOTO
*
* MISSING BRACKET IN GOTO
*
EXP23 ERB 228,SYNTAX ERROR. RIGHT BRACKET MISSING FROM GOTO
*
* MISSING ARRAY BRACKET
*
EXP24 ERB 229,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
*
* FLSTG -- FOLD STRING TO UPPER CASE
*
* FLSTG FOLDS A CHARACTER STRING CONTAINING LOWER CASE
* CHARACCTERS TO ONE CONTAINING UPPER CASE CHARACTERS.
* FOLDING IS ONLY DONE IF &CASE (KVCAS) IS NOT ZERO.
*
* (XR) STRING ARGUMENT
* (WA) LENGTH OF STRING
* JSR FLSTG CALL TO FOLD STRING
* (XR) RESULT STRING (POSSIBLY ORIGINAL)
* (WC) DESTROYED
*
FLSTG PRC R,0 ENTRY POINT
BZE KVCAS,FST99 SKIP IF &CASE IS 0
MOV XL,-(XS) SAVE XL ACROSS CALL
MOV XR,-(XS) SAVE ORIGINAL SCBLK PTR
JSR ALOCS ALLOCATE NEW STRING BLOCK
MOV (XS),XL POINT TO ORIGINAL SCBLK
MOV XR,-(XS) SAVE POINTER TO NEW SCBLK
PLC XL POINT TO ORIGINAL CHARS
PLC XR POINT TO NEW CHARS
ZER -(XS) INIT DID FOLD FLAG
LCT WC,WC LOAD LOOP COUNTER
FST01 LCH WA,(XL)+ LOAD CHARACTER
BGT =CH$$A,WA,FST02 SKIP IF LESS THAN LC A
BGT WA,=CH$$$,FST02 SKIP IF GREATER THAN LC Z
FLC WA FOLD CHARACTER TO UPPER CASE
MNZ (XS) SET DID FOLD CHARACTER FLAG
FST02 SCH WA,(XR)+ STORE (POSSIBLY FOLDED) CHARACTER
BCT WC,FST01 LOOP THRU ENTIRE STRING
CSC XR COMPLETE STORE CHARACTERS
BNZ (XS)+,FST10 SKIP IF FOLDING DONE
MOV (XS)+,DNAMP DO NOT NEED NEW SCBLK
MOV (XS)+,XR RETURN ORIGINAL SCBLK
BRN FST20 MERGE BELOW
FST10 MOV (XS)+,XR RETURN NEW SCBLK
ICA XS THROW AWAY ORIGINAL SCBLK POINTER
FST20 MOV SCLEN(XR),WA RELOAD STRING LENGTH
MOV (XS)+,XL RESTORE XL
FST99 EXI RETURN
ENP
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 BYTES 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
* BYTES. SET TO THE ADDRESS OF THE
* FIRST BYTE 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
BHI WA,=P$YYY,GBC06 SKIP IF NOT ENTRY PTR (IN USE)
BHI WA,=B$AAA,GBC07 JUMP IF ENTRY POINTER (UNUSED)
*
* 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
BHI WA,=P$YYY,GBC06 LOOP BACK IF NOT END OF CHAIN
BLO WA,=B$AAA,GBC06 LOOP BACK IF NOT END OF CHAIN
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
BHI WA,=P$YYY,GBC09 JUMP IF IN USE
BLO WA,=B$AAA,GBC09 JUMP IF IN USE
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 250,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
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
*
BHI WA,=P$YYY,GPF02 JUMP IF ALREADY PROCESSED
BHI WA,=B$AAA,GPF03 JUMP IF NOT ALREADY PROCESSED
*
* 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
IFF BL$BC,GPF18 BCBLK
IFF BL$BF,GPF02 BFBLK
IFF BL$CC,GPF07 CCBLK
IFF BL$CD,GPF08 CDBLK
IFF BL$CM,GPF04 CMBLK
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
IFF BL$RC,GPF02 RCBLK
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
*
* BCBLK
*
GPF18 MOV *BCSI$,WA SET LENGTH
MOV *BCBUF,WB AND OFFSET
BRN GPF05 ALL SET
ENP END PROCEDURE GBCPF
EJC
*
* GTARR -- GET ARRAY
*
* GTARR IS PASSED AN OBJECT AND RETURNS AN ARRAY IF POSSIBL
*
* (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
BNE WA,=B$TBT,GTA9A ELSE FAIL IF NOT A TABLE (SGD02)
*
* HERE WE CONVERT A TABLE TO AN ARRAY
*
MOV XR,-(XS) REPLACE TBBLK POINTER ON STACK
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 BYTES
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 RESTORE STACK FOR CONV ERR (SGD02)
*
* MERGE TO TAKE CONVERT ERROR WHEN STACK ADJUSTED OK
*
GTA9A 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 CHARACTER OF THE STRING FOR COLON OR
* SEMICOLON. THESE CHARACTERS CAN LEGITIMATELY END AN
* EXPRESSION IN OPEN CODE, SO EXPAN WILL NOT DETECT THEM
* AS ERRORS, BUT THEY ARE INVALID AS TERMINATORS FOR A
* STRING THAT IS BEING CONVERTED TO EXPRESSION FORM.
*
MOV XR,XL COPY INPUT STRING POINTER (REG06)
PLC XL,WA POINT ONE PAST THE STRING END (REG06)
LCH XL,-(XL) FETCH THE LAST CHARACTER (REG06)
BEQ XL,=CH$CL,GTEX2 ERROR IF IT IS A SEMICOLON (REG06)
BEQ XL,=CH$SM,GTEX2 OR IF IT IS A COLON (REG06)
*
* 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
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
*
* 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,GTN34 JUMP IF INTEGER (NO CONVERSION)
BEQ WA,=B$RCL,GTN34 JUMP IF REAL (NO CONVERSION)
*
* AT THIS POINT THE ONLY POSSIBILITY IS TO CONVERT A STRING
* TO AN INTEGER OR REAL AS APPROPRIATE.
*
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 +
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
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
BEQ WB,=CH$HT,GTNA2 HORIZONTAL TAB EQUIV TO BLANK
BNE WB,=CH$MN,GTN12 JUMP IF NOT MINUS (MAY BE REAL)
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
CVM GTN35 CURRENT*10-(NEW DIG) JUMP IF OVFLOW
MNZ GTNRD SET DIGIT READ FLAG
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
BEQ WB,=CH$HT,GTNA9 JUMP IF HORIZONTAL TAB
ITR ELSE CONVERT INTEGER TO REAL
NGR NEGATE TO GET POSITIVE VALUE
BRN GTN12 JUMP TO TRY FOR REAL
*
* HERE WE SCAN OUT BLANKS TO END OF STRING
*
GTN09 LCH WB,(XR)+ GET NEXT CHAR
BEQ WB,=CH$HT,GTNA9 JUMP IF HORIZONTAL TAB
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
*
* 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
BEQ WB,=CH$$E,GTN15 JUMP IF E FOR EXPONENT
BEQ WB,=CH$$D,GTN15 JUMP IF D FOR EXPONENT
*
* HERE CHECK FOR TRAILING BLANKS
*
GTN14 BEQ WB,=CH$BL,GTNB4 JUMP IF BLANK
BEQ WB,=CH$HT,GTNB4 JUMP IF HORIZONTAL TAB
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
BEQ WB,=CH$HT,GTNC0 JUMP IF HORIZONTAL TAB
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 BYTE 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 BYTE 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
*
* 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 EXI RETURN TO GTNUM CALLER
*
* 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
*
* HERE FOR UNCONVERTIBLE TO STRING OR CONVERSION ERROR
*
GTN36 MOV (XS)+,XR RELOAD ORIGINAL ARGUMENT
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
* (WA,WB) DESTROYED (CONVERSION ERROR ONLY)
* (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)
*
* 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 GNV01 JUMP IF CONVERSION ERROR
BZE WA,GNV01 NULL STRING IS AN ERROR
JSR FLSTG FOLD LOWER CASE TO UPPER CASE
MOV XL,-(XS) SAVE XL
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 BYTES
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 BYTE 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 BYTES
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 BYTES
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 OF NO CONVERSION REQUIRED
*
GTPT5 EXI RETURN TO GTPAT CALLER
ENP END PROCEDURE GTPAT
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
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 SMALL
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
BEQ WA,=B$RCL,GTS10 JUMP TO CONVERT REAL
BEQ WA,=B$NML,GTS03 JUMP TO CONVERT NAME
BEQ WA,=B$BCT,GTS32 JUMP TO CONVERT BUFFER
*
* 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
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
*
* 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
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
MOV =CH$LE,WA GET CHARACTER LETTER E
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
*
* 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
*
* 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
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 TO BFBLK
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
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 IS USED TO CONVERT A STRING TO A UNIQUE 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 (SGD07)
*
* 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
MFI XR,ICBL1 COPY SMALL INTEGERS
BLE XR,=NUM02,ICBL3 JUMP IF 0,1 OR 2
*
* 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 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
BEQ WC,=B$RCL,IDEN5 JUMP IF REALS
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
*
* 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
*
* 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 AND OUTPUT VARIABLES
*
* (XL) POINTER TO VBL NAME STRING
* (WB) TRBLK TYPE
* JSR INOUT CALL TO PERFORM INITIALISATION
* (XL) VRBLK PTR
* (XR) TRBLK PTR
* (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 BUILD VRBLK
PPM NO ERROR RETURN
MOV XR,WC SAVE VRBLK POINTER
MOV (XS)+,WB GET TRTER FIELD
ZER XL ZERO TRFPT
JSR TRBLD BUILD TRBLK
MOV WC,XL RECALL VRBLK POINTER
MOV VRSVP(XL),TRTER(XR) STORE SVBLK POINTER
MOV XR,VRVAL(XL) STORE TRBLK PTR IN VRBLK
MOV =B$VRA,VRGET(XL) SET TRAPPED ACCESS
MOV =B$VRV,VRSTO(XL) SET TRAPPED STORE
EXI RETURN TO CALLER
ENP END PROCEDURE INOUT
EJC
*
* 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 IS DIFFERENT THAN THE LENGTH 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 BFBLK
* (XL) OBJECT WHICH IS STRING CONVERTABLE
* (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 THREAD IF (XR) NOT CONVERTABLE
* PPM LOC THREAD IF INSERT NOT POSSIBLE
*
* 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
MOV WC,INSSC SAVE ENTRY WC
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 XL,-(XS) SAVE ENTRY XL
MOV XR,-(XS) SAVE BCBLK PTR
MOV XL,-(XS) STACK AGAIN FOR GTSTG
JSR GTSTG CALL TO CONVERT TO STRING
PPM INS05 TAKE STRING CONVERT ERR EXIT
MOV XR,XL SAVE STRING PTR
MOV (XS),XR RESTORE BCBLK PTR
ADD WC,WA ADD BUFFER LEN TO STRING LEN
SUB INSSB,WA BIAS OUT COMPONENT BEING REPLACED
MOV BCBUF(XR),XR POINT TO BFBLK
BGT WA,BFALC(XR),INS06 FAIL IF RESULT EXCEEDS ALLOCATION
MOV (XS),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
BZE WA,INS04 SKIP SHIFT IF NOTHING TO DO
BEQ INSSB,SCLEN(XL),INS04 SKIP SHIFT IF LENGTHS MATCH
MOV BCBUF(XR),XR POINT TO BFBLK
MOV XL,-(XS) SAVE SCBLK PTR
BLO INSSB,SCLEN(XL),INS01 BRN IF SHFT 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 MOVE TO ADJUST PADDING AT NEW BUFFER END
*
INS02 MOV (XS)+,XL RESTORE SCBLK PTR
MOV WC,WA COPY NEW BUFFER END
CTB WA,0 ROUND OUT
SUB WC,WA SUBTRACT TO GET REMAINDER
BZE WA,INS04 NO PAD IF ALREADY EVEN BOUNDARY
MOV (XS),XR GET BCBLK PTR
MOV BCBUF(XR),XR GET BFBLK PTR
PSC XR,WC PREPARE TO PAD
ZER WB CLEAR WB
LCT WA,WA LOAD LOOP COUNT
*
* LOOP HERE TO STUFF PAD CHARACTERS
*
INS03 SCH WB,(XR)+ STUFF ZERO PAD
BCT WA,INS03 BRANCH FOR MORE
EJC
*
* INSBF (CONTINUED)
*
* MERGE HERE WHEN PADDING OK. NOW COPY IN THE INSERT
* STRING TO THE HOLE.
*
INS04 MOV (XS),XR GET BCBLK PTR
MOV BCBUF(XR),XR GET BFBLK PTR
MOV SCLEN(XL),WA GET MOVE LENGTH
PLC XL PREPARE TO COPY FROM FIRST CHAR
PSC XR,INSSA PREPARE TO STORE IN HOLE
MVC COPY THE CHARACTERS
MOV (XS)+,XR RESTORE ENTRY XR
MOV (XS)+,XL RESTORE ENTRY XL
MOV INSSA,WA RESTORE ENTRY WA
MOV INSSB,WB RESTORE ENTRY WB
MOV INSSC,WC RESTORE ENTRY WC
EXI RETURN TO CALLER
*
* HERE TO TAKE STRING CONVERT ERROR EXIT
*
INS05 MOV (XS)+,XR RESTORE ENTRY XR
MOV (XS)+,XL RESTORE ENTRY XL
MOV INSSA,WA RESTORE ENTRY WA
MOV INSSB,WB RESTORE ENTRY WB
MOV INSSC,WC RESTORE ENTRY WC
EXI 1 ALTERNATE EXIT
*
* HERE FOR INVALID OFFSET OR LENGTH
*
INS06 MOV (XS)+,XR RESTORE ENTRY XR
MOV (XS)+,XL RESTORE ENTRY XL
*
* MERGE FOR LENGTH FAILURE EXIT WITH STACK SET
*
INS07 MOV INSSA,WA RESTORE ENTRY WA
MOV INSSB,WB RESTORE ENTRY WB
MOV INSSC,WC RESTORE ENTRY WC
EXI 2 ALTERNATE EXIT
ENP END PROCEDURE INSBF
EJC
*
* IOFCB -- GET INPUT/OUTPUT FCBLK POINTER
*
* USED BY ENDFILE, EJECT AND REWIND TO FIND THE FCBLK
* (IF ANY) CORRESPONDING TO THEIR ARGUMENT.
*
* -(XS) ARGUMENT
* JSR IOFCB CALL TO FIND FCBLK
* PPM LOC ARG IS AN UNSUITABLE NAME
* PPM LOC ARG IS NULL STRING
* (XS) POPPED
* (XL) PTR TO FILEARG1 VRBLK
* (XR) ARGUMENT
* (WA) FCBLK PTR OR 0
* (WB) DESTROYED
*
IOFCB PRC N,2 ENTRY POINT
JSR GTSTG GET ARG AS STRING
PPM IOFC2 FAIL
MOV XR,XL COPY STRING PTR
JSR GTNVR GET AS NATURAL VARIABLE
PPM IOFC3 FAIL IF NULL
MOV XL,WB COPY STRING POINTER AGAIN
MOV XR,XL COPY VRBLK PTR FOR RETURN
ZER WA IN CASE NO TRBLK FOUND
*
* LOOP TO FIND FILE ARG1 TRBLK
*
IOFC1 MOV VRVAL(XR),XR GET POSSIBLE TRBLK PTR
BNE (XR),=B$TRT,IOFC2 FAIL IF END OF CHAIN
BNE TRTYP(XR),=TRTFC,IOFC1 LOOP IF NOT FILE ARG TRBLK
MOV TRFPT(XR),WA GET FCBLK PTR
MOV WB,XR COPY ARG
EXI RETURN
*
* FAIL RETURN
*
IOFC2 EXI 1 FAIL
*
* NULL ARG
*
IOFC3 EXI 2 NULL ARG RETURN
ENP END PROCEDURE IOFCB
EJC
*
* IOPPF -- PROCESS FILEARG2 FOR IOPUT
*
* (R$XSC) FILEARG2 PTR
* JSR IOPPF CALL TO PROCESS FILEARG2
* (XL) FILEARG1 PTR
* (XR) FILE ARG2 PTR
* -(XS)..-(XS) FIELDS EXTRACTED FROM FILEARG2
* (WC) NO. OF FIELDS EXTRACTED
* (WB) INPUT/OUTPUT FLAG
* (WA) FCBLK PTR OR 0
*
IOPPF PRC N,0 ENTRY POINT
ZER WB TO COUNT FIELDS EXTRACTED
*
* LOOP TO EXTRACT FIELDS
*
IOPP1 MOV =IODEL,XL GET DELIMITER
MOV XL,WC COPY IT
JSR XSCAN GET NEXT FIELD
MOV XR,-(XS) STACK IT
ICV WB INCREMENT COUNT
BNZ WA,IOPP1 LOOP
MOV WB,WC COUNT OF FIELDS
MOV IOPTT,WB I/O MARKER
MOV R$IOF,WA FCBLK PTR OR 0
MOV R$IO2,XR FILE ARG2 PTR
MOV R$IO1,XL FILEARG1
EXI RETURN
ENP END PROCEDURE IOPPF
EJC
*
* IOPUT -- ROUTINE USED BY INPUT AND OUTPUT
*
* IOPUT SETS UP INPUT/OUTPUT ASSOCIATIONS. IT BUILDS
* SUCH TRACE AND FILE CONTROL BLOCKS AS ARE NECESSARY AND
* CALLS SYSFC,SYSIO TO PERFORM CHECKS ON THE
* ARGUMENTS AND TO OPEN THE FILES.
*
* +-----------+ +---------------+ +-----------+
* +-.I I I I------.I =B$XRT I
* I +-----------+ +---------------+ +-----------+
* I / / (R$FCB) I *4 I
* I / / +-----------+
* I +-----------+ +---------------+ I I-
* I I NAME +--.I =B$TRT I +-----------+
* I / / +---------------+ I I
* I (FIRST ARG) I =TRTIN/=TRTOU I +-----------+
* I +---------------+ I
* I I VALUE I I
* I +---------------+ I
* I I(TRTRF) 0 OR I--+ I
* I +---------------+ I I
* I I(TRFPT) 0 OR I----+ I
* I +---------------+ I I I
* I (I/O TRBLK) I I I
* I +-----------+ I I I
* I I I I I I
* I +-----------+ I I I
* I I I I I I
* I +-----------+ +---------------+ I I I
* I I +--.I =B$TRT I.-+ I I
* I +-----------+ +---------------+ I I
* I / / I =TRTFC I I I
* I / / +---------------+ I I
* I (FILEARG1 I VALUE I I I
* I VRBLK) +---------------+ I I
* I I(TRTRF) 0 OR I--+ I .
* I +---------------+ I . +-----------+
* I I(TRFPT) 0 OR I------./ FCBLK /
* I +---------------+ I +-----------+
* I (TRTRF) I
* I I
* I I
* I +---------------+ I
* I I =B$XRT I.-+
* I +---------------+
* I I *5 I
* I +---------------+
* +------------------I I
* +---------------+ +-----------+
* I(TRTRF) O OR I------.I =B$XRT I
* +---------------+ +-----------+
* I NAME OFFSET I I ETC I
* +---------------+
* (IOCHN - CHAIN OF NAME POINTERS)
EJC
*
* IOPUT (CONTINUED)
*
* NO ADDITIONAL TRAP BLOCKS ARE USED FOR STANDARD INPUT/OUT
* FILES. OTHERWISE AN I/O TRAP BLOCK IS ATTACHED TO SECOND
* ARG (FILEARG1) VRBLK. SEE DIAGRAM ABOVE FOR DETAILS OF
* THE STRUCTURE BUILT.
*
* -(XS) 1ST ARG (VBL TO BE ASSOCIATED)
* -(XS) 2ND ARG (FILE ARG1)
* -(XS) 3RD ARG (FILE ARG2)
* (WB) 0 FOR INPUT, 3 FOR OUTPUT ASSOC.
* JSR IOPUT CALL FOR INPUT/OUTPUT ASSOCIATION
* PPM LOC 3RD ARG NOT A STRING
* PPM LOC 2ND ARG NOT A SUITABLE NAME
* PPM LOC 1ST ARG NOT A SUITABLE NAME
* PPM LOC INAPPROPRIATE FILE SPEC FOR I/O
* PPM LOC I/O FILE DOES NOT EXIST
* PPM LOC I/O FILE CANNOT BE READ/WRITTEN
* (XS) POPPED
* (XL,XR,WA,WB,WC) DESTROYED
*
IOPUT PRC N,6 ENTRY POINT
ZER R$IOT IN CASE NO TRTRF BLOCK USED
ZER R$IOF IN CASE NO FCBLK ALOCATED
MOV WB,IOPTT STORE I/O TRACE TYPE
JSR XSCNI PREPARE TO SCAN FILEARG2
PPM IOP13 FAIL
PPM IOPA0 NULL FILE ARG2
*
IOPA0 MOV XR,R$IO2 KEEP FILE ARG2
MOV WA,XL COPY LENGTH
JSR GTSTG CONVERT FILEARG1 TO STRING
PPM IOP14 FAIL
MOV XR,R$IO1 KEEP FILEARG1 PTR
JSR GTNVR CONVERT TO NATURAL VARIABLE
PPM IOP00 JUMP IF NULL
BRN IOP04 JUMP TO PROCESS NON-NULL ARGS
*
* NULL FILEARG1
*
IOP00 BZE XL,IOP01 SKIP IF BOTH ARGS NULL
JSR IOPPF PROCESS FILEARG2
JSR SYSFC CALL FOR FILEARG2 CHECK
PPM IOP16 FAIL
BRN IOP11 COMPLETE FILE ASSOCIATION
EJC
*
* IOPUT (CONTINUED)
*
* HERE WITH 0 OR FCBLK PTR IN (XL)
*
IOP01 MOV IOPTT,WB GET TRACE TYPE
MOV R$IOT,XR GET 0 OR TRTRF PTR
JSR TRBLD BUILD TRBLK
MOV XR,WC COPY TRBLK POINTER
MOV (XS)+,XR GET VARIABLE FROM STACK
JSR GTVAR POINT TO VARIABLE
PPM IOP15 FAIL
MOV XL,R$ION SAVE NAME POINTER
MOV XL,XR COPY NAME POINTER
ADD WA,XR POINT TO VARIABLE
SUB *VRVAL,XR SUBTRACT OFFSET,MERGE INTO LOOP
*
* LOOP TO END OF TRBLK CHAIN IF ANY
*
IOP02 MOV XR,XL COPY BLK PTR
MOV VRVAL(XR),XR LOAD PTR TO NEXT TRBLK
BNE (XR),=B$TRT,IOP03 JUMP IF NOT TRAPPED
BNE TRTYP(XR),IOPTT,IOP02 LOOP IF NOT SAME ASSOCN
MOV TRNXT(XR),XR GET VALUE AND DELETE OLD TRBLK
*
* IOPUT (CONTINUED)
*
* STORE NEW ASSOCIATION
*
IOP03 MOV WC,VRVAL(XL) LINK TO THIS TRBLK
MOV WC,XL COPY POINTER
MOV XR,TRNXT(XL) STORE VALUE IN TRBLK
MOV R$ION,XR RESTORE POSSIBLE VRBLK POINTER
MOV WA,WB KEEP OFFSET TO NAME
JSR SETVR IF VRBLK, SET VRGET,VRSTO
MOV R$IOT,XR GET 0 OR TRTRF PTR
BNZ XR,IOP19 JUMP IF TRTRF BLOCK EXISTS
EXI RETURN TO CALLER
*
* NON STANDARD FILE
* SEE IF AN FCBLK HAS ALREADY BEEN ALLOCATED.
*
IOP04 ZER WA IN CASE NO FCBLK FOUND
EJC
*
* IOPUT (CONTINUED)
*
* SEARCH POSSIBLE TRBLK CHAIN TO PICK UP THE FCBLK
*
IOP05 MOV XR,WB REMEMBER BLK PTR
MOV VRVAL(XR),XR CHAIN ALONG
BNE (XR),=B$TRT,IOP06 JUMP IF END OF TRBLK CHAIN
BNE TRTYP(XR),=TRTFC,IOP05 LOOP IF MORE TO GO
MOV XR,R$IOT POINT TO FILE ARG1 TRBLK
MOV TRFPT(XR),WA GET FCBLK PTR FROM TRBLK
*
* WA = 0 OR FCBLK PTR
* WB = PTR TO PRECEDING BLK TO WHICH ANY TRTRF BLOCK
* FOR FILE ARG1 MUST BE CHAINED.
*
IOP06 MOV WA,R$IOF KEEP POSSIBLE FCBLK PTR
MOV WB,R$IOP KEEP PRECEDING BLK PTR
JSR IOPPF PROCESS FILEARG2
JSR SYSFC SEE IF FCBLK REQUIRED
PPM IOP16 FAIL
BZE WA,IOP12 SKIP IF NO NEW FCBLK WANTED
BLT WC,=NUM02,IOP6A JUMP IF FCBLK IN DYNAMIC
JSR ALOST GET IT IN STATIC
BRN IOP6B SKIP
*
* OBTAIN FCBLK IN DYNAMIC
*
IOP6A JSR ALLOC GET SPACE FOR FCBLK
*
* MERGE
*
IOP6B MOV XR,XL POINT TO FCBLK
MOV WA,WB COPY ITS LENGTH
BTW WB GET COUNT AS WORDS (SGD APR80)
LCT WB,WB LOOP COUNTER
*
* CLEAR FCBLK
*
IOP07 ZER (XR)+ CLEAR A WORD
BCT WB,IOP07 LOOP
BEQ WC,=NUM02,IOP09 SKIP IF IN STATIC - DONT SET FIELDS
MOV =B$XNT,(XL) STORE XNBLK CODE IN CASE
MOV WA,1(XL) STORE LENGTH
BNZ WC,IOP09 JUMP IF XNBLK WANTED
MOV =B$XRT,(XL) XRBLK CODE REQUESTED
*
EJC
* IOPUT (CONTINUED)
*
* COMPLETE FCBLK INITIALISATION
*
IOP09 MOV R$IOT,XR GET POSSIBLE TRBLK PTR
MOV XL,R$IOF STORE FCBLK PTR
BNZ XR,IOP10 JUMP IF TRBLK ALREADY FOUND
*
* A NEW TRBLK IS NEEDED
*
MOV =TRTFC,WB TRTYP FOR FCBLK TRAP BLK
JSR TRBLD MAKE THE BLOCK
MOV XR,R$IOT COPY TRTRF PTR
MOV R$IOP,XL POINT TO PRECEDING BLK
MOV VRVAL(XL),VRVAL(XR) COPY VALUE FIELD TO TRBLK
MOV XR,VRVAL(XL) LINK NEW TRBLK INTO CHAIN
MOV XL,XR POINT TO PREDECESSOR BLK
JSR SETVR SET TRACE INTERCEPTS
MOV VRVAL(XR),XR RECOVER TRBLK PTR
*
* XR IS PTR TO TRBLK, XL IS FCBLK PTR OR 0
*
IOP10 MOV R$IOF,TRFPT(XR) STORE FCBLK PTR
*
* CALL SYSIO TO COMPLETE FILE ACCESSING
*
IOP11 MOV R$IOF,WA COPY FCBLK PTR OR 0
MOV IOPTT,WB GET INPUT/OUTPUT FLAG
MOV R$IO2,XR GET FILE ARG2
MOV R$IO1,XL GET FILE ARG1
JSR SYSIO ASSOCIATE TO THE FILE
PPM IOP17 FAIL
PPM IOP18 FAIL
BNZ R$IOT,IOP01 NOT STD INPUT IF NON-NULL TRTRF BLK
BNZ IOPTT,IOP01 JUMP IF OUTPUT
BZE WC,IOP01 NO CHANGE TO STANDARD READ LENGTH
MOV WC,CSWIN STORE NEW READ LENGTH FOR STD FILE
BRN IOP01 MERGE TO FINISH THE TASK
*
* SYSFC MAY HAVE RETURNED A POINTER TO A PRIVATE FCBLK
*
IOP12 BNZ XL,IOP09 JUMP IF PRIVATE FCBLK
BRN IOP11 FINISH THE ASSOCIATION
*
* FAILURE RETURNS
*
IOP13 EXI 1 3RD ARG NOT A STRING
IOP14 EXI 2 2ND ARG UNSUITABLE
IOP15 EXI 3 1ST ARG UNSUITABLE
IOP16 EXI 4 FILE SPEC WRONG
IOP17 EXI 5 I/O FILE DOES NOT EXIST
IOP18 EXI 6 I/O FILE CANNOT BE READ/WRITTEN
EJC
*
* IOPUT (CONTINUED)
*
* ADD TO IOCHN CHAIN OF ASSSOCIATED VARIABLES UNLESS ALREAD
* PRESENT.
*
IOP19 MOV R$ION,WC WC = NAME BASE, WB = NAME OFFSET
*
* SEARCH LOOP
*
IOP20 MOV TRTRF(XR),XR NEXT LINK OF CHAIN
BZE XR,IOP21 NOT FOUND
BNE WC,IONMB(XR),IOP20 NO MATCH
BEQ WB,IONMO(XR),IOP22 EXIT IF MATCHED
BRN IOP20 LOOP
*
* NOT FOUND
*
IOP21 MOV *NUM05,WA SPACE NEEDED
JSR ALLOC GET IT
MOV =B$XRT,(XR) STORE XRBLK CODE
MOV WA,1(XR) STORE LENGTH
MOV WC,IONMB(XR) STORE NAME BASE
MOV WB,IONMO(XR) STORE NAME OFFSET
MOV R$IOT,XL POINT TO TRTRF BLK
MOV TRTRF(XL),WA GET PTR FIELD CONTENTS
MOV XR,TRTRF(XL) STORE PTR TO NEW BLOCK
MOV WA,TRTRF(XR) COMPLETE THE LINKING
*
* INSERT FCBLK ON FCBLK CHAIN FOR SYSEJ, SYSXI
*
IOP22 BZE R$IOF,IOP25 SKIP IF NO FCBLK
MOV R$FCB,XL PTR TO HEAD OF EXISTING CHAIN
*
* SEE IF FCBLK ALREADY ON CHAIN
*
IOP23 BZE XL,IOP24 NOT ON IF END OF CHAIN
BEQ 3(XL),R$IOF,IOP25 DONT DUPLICATE IF FIND IT
MOV 2(XL),XL GET NEXT LINK
BRN IOP23 LOOP
*
* NOT FOUND SO ADD AN ENTRY FOR THIS FCBLK
*
IOP24 MOV *NUM04,WA SPACE NEEDED
JSR ALLOC GET IT
MOV =B$XRT,(XR) STORE BLOCK CODE
MOV WA,1(XR) STORE LENGTH
MOV R$FCB,2(XR) STORE PREVIOUS LINK IN THIS NODE
MOV R$IOF,3(XR) STORE FCBLK PTR
MOV XR,R$FCB INSERT NODE INTO FCBLK CHAIN
*
* RETURN
*
IOP25 EXI RETURN TO CALLER
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 PRTVL PRINT KEYWORD VALUE
JSR PRTNL TERMINATE PRINT LINE
*
* 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 251,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,LCMP1 JUMP IF ARG 1 LENGTH IS SMALLER
MOV WB,WA ELSE SET ARG 2 LENGTH AS SMALLER
*
* HERE WITH SMALLER LENGTH IN (WA)
*
LCMP1 CMC LCMP4,LCMP3 COMPARE STRINGS, JUMP IF UNEQUAL
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
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)
*
LIST0 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
BNE STAGE,=STGIC,LIST1 SKIP IF EXECUTE TIME
BEQ WA,=CH$AS,LIST2 NO STMNT NUMBER LIST IF COMMENT
BEQ WA,=CH$MN,LIST2 NO STMNT NO. IF CONTROL CARD
*
* PRINT STATEMENT NUMBER
*
LIST1 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 PRTST PRINT IT
ICV LSTLC BUMP LINE COUNTER
BNZ ERLST,LIST3 JUMP IF ERROR COPY TO INT.CH.
JSR PRTNL TERMINATE LINE
BZE CSWDB,LIST3 JUMP IF -SINGLE MODE
JSR PRTNL ELSE ADD A BLANK LINE
ICV LSTLC AND BUMP LINE COUNTER
*
* HERE AFTER PRINTING SOURCE IMAGE
*
LIST3 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
BZE PRICH,LIST7 SKIP IF LISTING TO REGULAR PRINTER
BEQ R$TTL,=NULLS,LIST0 TERMINAL LISTING OMITS NULL TITLE
*
* LIST TITLE
*
LIST7 JSR LISTT LIST TITLE
BRN LIST0 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 PRTNL 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 PRTST ELSE PRINT SUB-TITLE
JSR PRTNL TERMINATE LINE
ICV LSTLC BUMP LINE COUNT
*
* RETURN POINT
*
LSTT1 JSR PRTNL 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,NXTS2 JUMP IF -NOLIST
MOV R$CIM,XR POINT TO IMAGE
BZE XR,NXTS2 JUMP IF NO IMAGE
PLC XR GET CHAR PTR
LCH WA,(XR) GET FIRST CHAR
BNE WA,=CH$MN,NXTS1 JUMP IF NOT CTRL CARD
BZE CSWPR,NXTS2 JUMP IF -NOPRINT
*
* HERE TO CALL LISTER
*
NXTS1 JSR LISTR LIST LINE
*
* HERE AFTER POSSIBLE LISTING
*
NXTS2 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,NXTS3 SKIP IF NOT TOO LONG
MOV WB,WA ELSE TRUNCATE
*
* HERE WITH LENGTH IN (WA)
*
NXTS3 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 BYTE 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
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 PRTST AND PRINT IT
JSR PRTNL FOLLOWED BY NEWLINE
JSR PRTNL AND ANOTHER
MOV =PFMS2,XR POINT TO FIRST HDR
JSR PRTST PRINT IT
JSR PRTNL NEW LINE
MOV =PFMS3,XR SECOND HDR
JSR PRTST PRINT IT
JSR PRTNL NEW LINE
JSR PRTNL AND ANOTHER BLANK LINE
ZER WB INITIAL STMT COUNT
MOV PFTBL,XR POINT TO TABLE ORIGIN
ADD *NUM02,XR BIAS PAST XNBLK HEADER (SGD07)
*
* LOOP HERE TO PRINT SUCCESSIVE 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
*
* MERGE AFTER PRINTING TIME
*
PRFL2 JSR PRTNL THATS ANOTHER LINE
*
* HERE TO GO TO NEXT ENTRY
*
PRFL3 ADD *PF$I2,XR BUMP INDEX PTR (SGD07)
BLT WB,PFNTE,PRFL1 LOOP IF MORE STMTS
MOV (XS)+,XR RESTORE CALLERS XR
MOV PFSVW,WB AND WB TOO
*
* HERE TO EXIT
*
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 (SGD07)
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 (SGD07)
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 ALLLLLLL THE REST
*
* 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
*
* MERGE HERE TO EXIT
*
PFLU3 MOV (XS)+,XR RESTORE CALLERS XR
MOV PFSVW,WA RESTORE SAVED REG
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
EJC
*
* PRPAR - PROCESS PRINT PARAMETERS
*
* (WC) IF NONZERO ASSOCIATE TERMINAL ONLY
* JSR PRPAR CALL TO PROCESS PRINT PARAMETERS
* (XL,XR,WA,WB,WC) DESTROYED
*
* SINCE MEMORY ALLOCATION IS UNDECIDED ON INITIAL CALL,
* TERMINAL CANNOT BE ASSOCIATED. THE ENTRY WITH WC NON-ZERO
* IS PROVIDED SO A LATER CALL CAN BE MADE TO COMPLETE THIS.
*
PRPAR PRC E,0 ENTRY POINT
BNZ WC,PRPA7 JUMP TO ASSOCIATE TERMINAL
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
MOV PRLEN,WB GET PRIOR LENGTH IF ANY
BZE WB,PRPA2 SKIP IF NO LENGTH
BGT WA,WB,PRPA3 SKIP STORING IF TOO BIG
*
* STORE PRINT BUFFER LENGTH
*
PRPA2 MOV WA,PRLEN STORE VALUE
*
* PROCESS BITS OPTIONS
*
PRPA3 MOV BITS3,WB BIT 3 MASK
ANB WC,WB GET -NOLIST BIT
ZRB WB,PRPA4 SKIP IF CLEAR
ZER CSWLS SET -NOLIST
*
* CHECK IF FAIL REPORTS GOTO INTERACTIVE CHANNEL
*
PRPA4 MOV BITS1,WB BIT 1 MASK
ANB WC,WB GET BIT
MOV WB,ERICH STORE INT. CHAN. ERROR FLAG
MOV BITS2,WB BIT 2 MASK
ANB WC,WB GET BIT
MOV WB,PRICH FLAG FOR STD PRINTER ON INT. CHAN.
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
EJC
*
* PRPAR (CONTINUED)
*
MOV BITS6,WB BIT 6 MASK
ANB WC,WB GET BIT
MOV WB,PRECL EXTENDED/COMPACT LISTING FLAG
SUB =NUM08,WA POINT 8 CHARS FROM LINE END
ZRB WB,PRPA5 JUMP IF NOT EXTENDED
MOV WA,LSTPO STORE FOR LISTING PAGE HEADINGS
*
* CONTINUE OPTION PROCESSING
*
PRPA5 MOV BITS7,WB BIT 7 MASK
ANB WC,WB GET BIT 7
MOV WB,CSWEX SET -NOEXECUTE IF NON-ZERO
MOV BIT10,WB BIT 10 MASK
ANB WC,WB GET BIT 10
MOV WB,HEADP PRETEND PRINTED TO OMIT HEADERS
MOV BITS9,WB BIT 9 MASK
ANB WC,WB GET BIT 9
MOV WB,PRSTO KEEP IT AS STD LISTING OPTION
ZRB WB,PRPA6 SKIP IF CLEAR
MOV PRLEN,WA GET PRINT BUFFER LENGTH
SUB =NUM08,WA POINT 8 CHARS FROM LINE END
MOV WA,LSTPO STORE PAGE OFFSET
*
* CHECK FOR TERMINAL
*
PRPA6 ANB BITS8,WC SEE IF TERMINAL TO BE ACTIVATED
BNZ WC,PRPA7 JUMP IF TERMINAL REQUIRED
BZE INITR,PRPA8 JUMP IF NO TERMINAL TO DETACH
MOV =V$TER,XL PTR TO /TERMINAL/
JSR GTNVR GET VRBLK POINTER
PPM CANT FAIL
MOV =NULLS,VRVAL(XR) CLEAR VALUE OF TERMINAL
JSR SETVR REMOVE ASSOCIATION
BRN PRPA8 RETURN
*
* ASSOCIATE TERMINAL
*
PRPA7 MNZ INITR NOTE TERMINAL ASSOCIATED
BZE DNAMB,PRPA8 CANT IF MEMORY NOT ORGANISED
MOV =V$TER,XL POINT TO TERMINAL STRING
MOV =TRTOU,WB OUTPUT TRACE TYPE
JSR INOUT ATTACH OUTPUT TRBLK TO VRBLK
MOV XR,-(XS) STACK TRBLK PTR
MOV =V$TER,XL POINT TO TERMINAL STRING
MOV =TRTIN,WB INPUT TRACE TYPE
JSR INOUT ATTACH INPUT TRACE BLK
MOV (XS)+,VRVAL(XR) ADD OUTPUT TRBLK TO CHAIN
*
* RETURN POINT
*
PRPA8 EXI RETURN
ENP END PROCEDURE PRPAR
EJC
*
* PRTCH -- PRINT A CHARACTER
*
* 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
MOV XR,-(XS) SAVE XR
BNE PROFS,PRLEN,PRCH1 JUMP IF ROOM IN BUFFER
JSR PRTNL ELSE PRINT THIS LINE
*
* HERE AFTER MAKING SURE WE HAVE ROOM
*
PRCH1 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
EXI RETURN TO PRTCH CALLER
ENP END PROCEDURE PRTCH
EJC
*
* PRTIC -- PRINT TO INTERACTIVE CHANNEL
*
* PRTIC IS CALLED TO PRINT THE CONTENTS OF THE STANDARD
* PRINT BUFFER TO THE INTERACTIVE CHANNEL. IT IS ONLY
* CALLED AFTER PRTST HAS SET UP THE STRING FOR PRINTING.
* IT DOES NOT CLEAR THE BUFFER.
*
* JSR PRTIC CALL FOR PRINT
* (WA,WB) DESTROYED
*
PRTIC PRC E,0 ENTRY POINT
MOV XR,-(XS) SAVE XR
MOV PRBUF,XR POINT TO BUFFER
MOV PROFS,WA NO OF CHARS
JSR SYSPI PRINT
PPM PRTC2 FAIL RETURN
*
* RETURN
*
PRTC1 MOV (XS)+,XR RESTORE XR
EXI RETURN
*
* ERROR OCCURED
*
PRTC2 ZER ERICH PREVENT LOOPING
ERB 252,ERROR ON PRINTING TO INTERACTIVE CHANNEL
BRN PRTC1 RETURN
ENP PROCEDURE PRTIC
EJC
*
* PRTIS -- PRINT TO INTERACTIVE AND STANDARD PRINTER
*
* PRTIS PUTS A LINE FROM THE PRINT BUFFER ONTO THE
* INTERACTIVE CHANNEL (IF ANY) AND THE STANDARD PRINTER.
* IT ALWAYS PRINTS TO THE STANDARD PRINTER BUT DOES
* NOT DUPLICATE LINES IF THE STANDARD PRINTER IS
* INTERACTIVE. IT CLEARS DOWN THE PRINT BUFFER.
*
* JSR PRTIS CALL FOR PRINTING
* (WA,WB) DESTROYED
*
PRTIS PRC E,0 ENTRY POINT
BNZ PRICH,PRTS1 JUMP IF STANDARD PRINTER IS INT.CH.
BZE ERICH,PRTS1 SKIP IF NOT DOING INT. ERROR REPS.
JSR PRTIC PRINT TO INTERACTIVE CHANNEL
*
* MERGE AND EXIT
*
PRTS1 JSR PRTNL PRINT TO STANDARD PRINTER
EXI RETURN
ENP END PROCEDURE PRTIS
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
EJC
*
* 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 PRTNL PRINT LINE
EXI RETURN TO PRTMI CALLER
ENP END PROCEDURE PRTMI
EJC
*
* PRTMX -- AS PRTMI WITH EXTRA COPY TO INTERACTIVE CHAN.
*
* JSR PRTMX CALL FOR PRINTING
* (WA,WB) DESTROYED
*
PRTMX PRC E,0 ENTRY POINT
JSR PRTST PRINT STRING MESSAGE
MOV =PRTMF,PROFS SET PTR TO COLUMN 15
JSR PRTIN PRINT INTEGER
JSR PRTIS PRINT LINE
EXI RETURN
ENP END PROCEDURE PRTMX
EJC
*
* PRTNL -- PRINT NEW LINE (END PRINT LINE)
*
* PRTNL PRINTS THE CONTENTS OF THE PRINT BUFFER, RESETS
* THE BUFFER TO ALL BLANKS AND RESETS THE PRINT POINTER.
*
* JSR PRTNL CALL TO PRINT LINE
*
PRTNL PRC R,0 ENTRY POINT
BNZ HEADP,PRNL0 WERE HEADERS PRINTED
JSR PRTPS NO - PRINT THEM
*
* CALL SYSPR
*
PRNL0 MOV XR,-(XS) SAVE ENTRY XR
MOV WA,PRTSA SAVE WA
MOV WB,PRTSB SAVE WB
MOV PRBUF,XR LOAD POINTER TO BUFFER
MOV PROFS,WA LOAD NUMBER OF CHARS IN BUFFER
JSR SYSPR CALL SYSTEM PRINT ROUTINE
PPM PRNL2 JUMP IF FAILED
LCT WA,PRLNW LOAD LENGTH OF BUFFER IN WORDS
ADD *SCHAR,XR POINT TO CHARS OF BUFFER
MOV NULLW,WB GET WORD OF BLANKS
*
* LOOP TO BLANK BUFFER
*
PRNL1 MOV WB,(XR)+ STORE WORD OF BLANKS, BUMP PTR
BCT WA,PRNL1 LOOP TILL ALL BLANKED
*
* EXIT POINT
*
MOV PRTSB,WB RESTORE WB
MOV PRTSA,WA RESTORE WA
MOV (XS)+,XR RESTORE ENTRY XR
ZER PROFS RESET PRINT BUFFER POINTER
EXI RETURN TO PRTNL CALLER
*
* FILE FULL OR NO OUTPUT FILE FOR LOAD MODULE
*
PRNL2 BNZ PRTEF,PRNL3 JUMP IF NOT FIRST TIME
MNZ PRTEF MARK FIRST OCCURRENCE
ERB 253,PRINT LIMIT EXCEEDED ON STANDARD OUTPUT CHANNEL
*
* STOP AT ONCE
*
PRNL3 MOV =NINI8,WB ENDING CODE
MOV KVSTN,WA STATEMENT NUMBER
JSR SYSEJ STOP
ENP END PROCEDURE PRTNL
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 PRTVL PRINT VALUE
JSR PRTNL TERMINATE LINE
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 CHANNEL DEPENDING ON THE LISTING OPTIONS CHOSEN.
*
* JSR PRTPG CALL FOR PAGE EJECT
*
PRTPG PRC E,0 ENTRY POINT
BEQ STAGE,=STGXT,PRP01 JUMP IF EXECUTION TIME
BZE LSTLC,PRP06 RETURN IF TOP OF PAGE ALREADY
ZER LSTLC CLEAR LINE COUNT
*
* CHECK TYPE OF LISTING
*
PRP01 MOV XR,-(XS) PRESERVE XR
BNZ PRSTD,PRP02 EJECT IF FLAG SET
BNZ PRICH,PRP03 JUMP IF INTERACTIVE LISTING CHANNEL
BZE PRECL,PRP03 JUMP IF COMPACT LISTING
*
* PERFORM AN EJECT
*
PRP02 JSR SYSEP EJECT
BRN PRP04 MERGE
*
* COMPACT OR INTERACTIVE CHANNEL LISTING. CANT PRINT
* BLANKS UNTIL CHECK MADE FOR HEADERS PRINTED AND FLAG SET.
*
*
PRP03 MOV HEADP,XR REMEMBER HEADP
MNZ HEADP SET TO AVOID REPEATED PRTPG CALLS
JSR PRTNL PRINT BLANK LINE
JSR PRTNL PRINT BLANK LINE
JSR PRTNL PRINT BLANK LINE
MOV =NUM03,LSTLC COUNT BLANK LINES
MOV XR,HEADP RESTORE HEADER FLAG
EJC
*
* PRPTG (CONTINUED)
*
* PRINT THE HEADING
*
PRP04 BNZ HEADP,PRP05 JUMP IF HEADER LISTED
MNZ HEADP MARK HEADERS PRINTED
MOV XL,-(XS) KEEP XL
MOV =HEADR,XR POINT TO LISTING HEADER
JSR PRTST PLACE IT
JSR SYSID GET SYSTEM IDENTIFICATION
JSR PRTST APPEND EXTRA CHARS
JSR PRTNL PRINT IT
MOV XL,XR EXTRA HEADER LINE
JSR PRTST PLACE IT
JSR PRTNL PRINT IT
JSR PRTNL PRINT A BLANK
JSR PRTNL AND ANOTHER
ADD =NUM04,LSTLC FOUR HEADER LINES PRINTED
MOV (XS)+,XL RESTORE XL
*
* MERGE IF HEADER NOT PRINTED
*
PRP05 MOV (XS)+,XR RESTORE XR
*
* RETURN
*
PRP06 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
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
*
* PRTST PLACES A STRING OF CHARACTERS IN THE PRINT BUFFER
*
* SEE PRTNL FOR GLOBAL LOCATIONS USED
*
* 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 PRTST CALL TO PRINT STRING
* (PROFS) UPDATED PAST CHARS PLACED
*
PRTST PRC R,0 ENTRY POINT
BNZ HEADP,PRST0 WERE HEADERS PRINTED
JSR PRTPS NO - PRINT THEM
*
* CALL SYSPR
*
PRST0 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
*
PRST1 MOV SCLEN(XR),WA LOAD STRING LENGTH
SUB WB,WA SUBTRACT COUNT OF CHARS ALREADY OUT
BZE WA,PRST4 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,PRST2 SKIP IF ROOM LEFT ON THIS LINE
JSR PRTNL ELSE PRINT THIS LINE
MOV PRLEN,XR AND SET FULL WIDTH AVAILABLE
EJC
*
* PRTST (CONTINUED)
*
* HERE WITH CHARS TO PRINT AND SOME ROOM IN BUFFER
*
PRST2 BLO WA,XR,PRST3 JUMP IF ROOM FOR REST OF STRING
MOV XR,WA ELSE SET TO FILL LINE
*
* MERGE HERE WITH CHARACTER COUNT IN WA
*
PRST3 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
MOV WB,PRSVC PRESERVE CHAR COUNTER
MVC MOVE CHARACTERS TO BUFFER
MOV PRSVC,WB RECOVER CHAR COUNTER
MOV (XS)+,XR RESTORE ARGUMENT POINTER
MOV (XS)+,XL RESTORE ENTRY XL
BRN PRST1 LOOP BACK TO TEST FOR MORE
*
* HERE TO EXIT AFTER PRINTING STRING
*
PRST4 MOV PRSVB,WB RESTORE ENTRY WB
MOV PRSVA,WA RESTORE ENTRY WA
EXI RETURN TO PRTST CALLER
ENP END PROCEDURE PRTST
EJC
*
* PRTTR -- PRINT TO TERMINAL
*
* CALLED TO PRINT CONTENTS OF STANDARD PRINT BUFFER TO
* ONLINE TERMINAL. CLEARS BUFFER DOWN AND RESETS PROFS.
*
* JSR PRTTR CALL FOR PRINT
* (WA,WB) DESTROYED
*
PRTTR PRC E,0 ENTRY POINT
MOV XR,-(XS) SAVE XR
JSR PRTIC PRINT BUFFER CONTENTS
MOV PRBUF,XR POINT TO PRINT BFR TO CLEAR IT
LCT WA,PRLNW GET BUFFER LENGTH
ADD *SCHAR,XR POINT PAST SCBLK HEADER
MOV NULLW,WB GET BLANKS
*
* LOOP TO CLEAR BUFFER
*
PRTT1 MOV WB,(XR)+ CLEAR A WORD
BCT WA,PRTT1 LOOP
ZER PROFS RESET PROFS
MOV (XS)+,XR RESTORE XR
EXI RETURN
ENP END PROCEDURE PRTTR
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
IFF BL$RC,PRV08 RCBLK
IFF BL$SC,PRV11 SCBLK
IFF BL$SE,PRV12 SEBLK
IFF BL$TB,PRV13 TBBLK
IFF BL$VC,PRV13 VCBLK
IFF BL$BC,PRV15 BCBLK
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, BCBLK 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
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
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
*
* 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
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.
*
* 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,READ3 EXIT IF ALREADY READ
BNE STAGE,=STGIC,READ3 EXIT IF NOT INITIAL COMPILE
MOV CSWIN,WA MAX READ LENGTH
JSR ALOCS ALLOCATE BUFFER
JSR SYSRD READ INPUT IMAGE
PPM READ4 JUMP IF END OF FILE
MNZ WB SET TRIMR TO PERFORM TRIM
BLE SCLEN(XR),CSWIN,READ1 USE SMALLER OF STRING LNTH ..
MOV CSWIN,SCLEN(XR) ... AND XXX OF -INXXX
*
* PERFORM THE TRIM
*
READ1 JSR TRIMR TRIM TRAILING BLANKS
*
* MERGE HERE AFTER READ
*
READ2 MOV XR,R$CNI STORE COPY OF POINTER
*
* MERGE HERE IF NO READ ATTEMPTED
*
READ3 EXI RETURN TO READR CALLER
*
* HERE ON END OF FILE
*
READ4 MOV XR,DNAMP POP UNUSED SCBLK
ZER XR ZERO PTR AS RESULT
BRN READ2 MERGE
ENP END PROCEDURE READR
EJC
*
* SBSTR -- BUILD A SUBSTRING
*
* (XL) PTR TO SCBLK/BFBLK WITH 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
* (XL) ZERO
* (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
*
* REAL CONSTANT T$CON PTR TO RCBLK
*
* 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
BLO =CFP$U,XR,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
IFF CH$HT,SCN05 HORIZONTAL TAB
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
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
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,SCN33 PLUS
IFF CH$MN,SCN34 MINUS
IFF CH$NT,SCN35 NOT
IFF CH$DL,SCN36 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 230,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 231,SYNTAX ERROR. INVALID NUMERIC ITEM
*
* HERE AFTER SCANNING OUT VARIABLE NAME
*
SCN15 JSR SBSTR BUILD STRING NAME OF VARIABLE
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 232,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 THREE 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 WC,SCN09 PLUS CAN BE PART OF CONSTANT
BZE WB,SCN48 PLUS CANNOT BE PART OF NAME
ADD WB,WC ELSE BUMP POINTER
*
SCN34 BZE WC,SCN09 MINUS CAN BE PART OF CONSTANT
BZE WB,SCN48 MINUS CANNOT BE PART OF NAME
ADD WB,WC ELSE BUMP POINTER
*
SCN35 ADD WB,WC NOT
SCN36 ADD WB,WC DOLLAR
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
*
* 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
BEQ WC,=CH$HT,SCN47 JUMP IF HORIZONTAL TAB
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 233,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
BEQ WA,=CH$HT,SCN51 EXCLAMATION IF HORIZONTAL TAB
*
* 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 234,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 POINT TO OPDV FOR COMPLEX GOTO
BLE XR,STATB,SCNG3 JUMP IF NOT IN STATIC (SGD15)
BLO XR,STATE,SCNG4 JUMP TO EXIT IF SIMPLE LABEL NAME
BRN SCNG3 COMPLEX GOTO - 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
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 STRUCTURE
* 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, BYTE
* 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.
*
* 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
* (XR) SORTED ARRAY
* (XL,WA,WB,WC) DESTROYED
EJC
*
* SORTA (CONTINUED)
*
SORTA PRC N,0 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
JSR GTARR CONVERT TO ARRAY
PPM SRT16 FAIL
MOV XR,-(XS) STACK PTR TO RESULTING KEY ARRAY
MOV XR,-(XS) ANOTHER COPY FOR COPYB
JSR COPYB 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 257,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 BYTES)
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
MOV *ARPRO,WC OFFSET BEFORE VALUES IF ONE DIM.
BEQ ARNDM(XL),=NUM01,SRT04 JUMP IN FACT IF ONE DIM.
BNE ARNDM(XL),=NUM02,SRT16 FAIL UNLESS TWO DIMENS
LDI ARLB2(XL) GET LOWER BOUND 2 AS DEFAULT
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 BYTES
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 BYTES).
* 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 BYTES
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 (BYTES)
* (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 BYTES
*
* 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 MAINTAI
* 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 256,SORT/RSORT 1ST ARG NOT SUITABLE ARRAY OR TABLE
SRT17 ERB 258,SORT/RSORT 2ND ARG OUT OF RANGE OR NON-INTEGER
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 BYTES
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 BYTES)
* (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 BYTES
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 BYTES
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
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
IFF BL$RC,TFN02 REAL
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
*
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 BYTE 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
*
* 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 =NULLS,TEVAL(XR) SET NULL AS INITIAL VALUE
MOV (XS)+,TENXT(XR) SET TBBLK PTR TO MARK END OF CHAIN
MOV (XS)+,TESUB(XR) STORE SUBSCRIPT VALUE
ICA XS POP PAST 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
* (XS) POPPED
* (XL,XR,WA,WB,WC,IA) DESTROYED
*
TRACE PRC N,2 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
FLC WA FOLD TO UPPER CASE
MOV (XS),XR LOAD NAME ARGUMENT
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)
BZE WA,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
BEQ WA,=CH$LR,TRC02 JUMP IF R (RETURN)
EJC
*
* TRACE (CONTINUED)
*
* HERE FOR F,C TO SET/RESET CALL TRACE
*
MOV XL,PFCTR(XR) SET/RESET CALL TRACE
BEQ WA,=CH$LC,EXNUL EXIT WITH NULL IF C (CALL)
*
* HERE FOR F,R TO SET/RESET RETURN TRACE
*
TRC02 MOV XL,PFRTR(XR) SET/RESET RETURN TRACE
EXI RETURN
*
* HERE FOR L TO SET/RESET LABEL TRACE
*
TRC03 JSR GTNVR POINT TO VRBLK
PPM TRC16 JUMP IF BAD NAME
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
*
* HERE WITH OLD LABEL TRACE ASSOCIATION DELETED
*
TRC04 BEQ XL,=STNDL,TRC16 ERROR IF UNDEFINED LABEL
MOV (XS)+,WB GET TRBLK PTR AGAIN
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 WB (OR ZERO)
*
TRC07 MOV VRSVP(XR),XR POINT TO SVBLK
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
*
MOV XL,R$FNC SET/RESET FNCLEVEL TRACE
EXI RETURN
*
* ERRTYPE
*
TRC08 MOV XL,R$ERT SET/RESET ERRTYPE TRACE
EXI RETURN
*
* STCOUNT
*
TRC09 MOV XL,R$STC SET/RESET STCOUNT TRACE
EXI 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)+,WB GET NEW TRBLK PTR AGAIN
ADD XL,WA POINT TO VARIABLE LOCATION
MOV WA,XR COPY VARIABLE POINTER
*
* LOOP TO SEARCH TRBLK CHAIN
*
TRC11 MOV (XR),XL POINT TO NEXT ENTRY
BNE (XL),=B$TRT,TRC13 JUMP IF NOT TRBLK
BLT WC,TRTYP(XL),TRC13 JUMP IF TOO FAR OUT ON CHAIN
BEQ WC,TRTYP(XL),TRC12 JUMP IF THIS MATCHES OUR TYPE
ADD *TRNXT,XL ELSE POINT TO LINK FIELD
MOV XL,XR COPY POINTER
BRN TRC11 AND LOOP BACK
*
* HERE TO DELETE AN OLD TRBLK OF THE TYPE WE WERE GIVEN
*
TRC12 MOV TRNXT(XL),XL GET PTR TO NEXT BLOCK OR VALUE
MOV XL,(XR) STORE TO DELETE THIS TRBLK
*
* HERE AFTER DELETING ANY OLD ASSOCIATION OF THIS TYPE
*
TRC13 BZE WB,TRC14 JUMP IF STOPTR CASE
MOV WB,(XR) ELSE LINK NEW TRBLK IN
MOV WB,XR COPY TRBLK POINTER
MOV XL,TRNXT(XR) STORE FORWARD POINTER
MOV WC,TRTYP(XR) STORE APPROPRIATE TRAP TYPE CODE
*
* HERE TO MAKE SURE VRGET,VRSTO ARE SET PROPERLY
*
TRC14 MOV WA,XR RECALL POSSIBLE VRBLK POINTER
SUB *VRVAL,XR POINT BACK TO VRBLK
JSR SETVR SET FIELDS IF VRBLK
EXI 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 TRFPT
* (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 TRFPT)
MOV (XS)+,TRTAG(XR) STORE TRTAG (OR TRFNM)
MOV WB,TRTYP(XR) STORE TYPE
MOV =NULLS,TRVAL(XR) FOR NOW, A NULL VALUE
EXI RETURN TO CALLER
ENP END PROCEDURE TRBLD
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
BEQ WB,=CH$HT,TRIM1 JUMP IF HORIZONTAL TAB
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 BLANKS
CTB WA,SCHAR GET LENGTH OF BLOCK IN BYTES
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 BLANK 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
*
TRXQ1 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
*
* THE SCAN STARTS FROM THE CURRENT POSITION AND CONTINUES
* UNTIL ONE OF THE FOLLOWING THREE 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 SET TO 0)
*
* 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
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
*
XSCN1 LCH WB,(XR)+ LOAD NEXT CHARACTER
BEQ WB,WC,XSCN3 JUMP IF DELIMITER ONE FOUND
BEQ WB,XL,XSCN4 JUMP IF DELIMITER TWO FOUND
DCV WA DECREMENT COUNT OF CHARS LEFT
BNZ WA,XSCN1 LOOP BACK IF MORE CHARS TO GO
*
* 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
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
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
JSR SBSTR BUILD SUB-STRING
MOV XSCRT,WA LOAD RETURN CODE
MOV XSCWB,WB RESTORE WB
EXI RETURN TO XSCAN CALLER
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 BYTE 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 235,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 BYTES
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 236,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 237,TABLE REFERENCED WITH MORE THAN ONE SUBSCRIPT
*
* HERE FOR BAD SUBSCRIPT
*
ARF12 ERB 238,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 BYTES
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
*
* 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
EJC
*
* 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
EJC
*
* 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
EJC
*
* 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
EJC
*
* 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
EJC
*
* 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
EJC
*
* 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 239,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 240,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
*
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
ERR 241,PATTERN MATCH LEFT OPERAND IS NOT STRING
*
* MERGE WITH BUFFER OR STRING
*
MTCHB MOV XR,R$PMS IF OK, STORE SUBJECT STRING POINTER
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
*
* 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 242,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 PTR (SGD13)
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 PRTNL 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
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
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
*
* 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
EJC
*
* RETRN (CONTINUED)
*
* HERE FOR NRETURN
*
BEQ (XR),=B$NML,RTN11 JUMP IF IS A NAME
JSR GTNVR ELSE TRY CONVERT TO VARIABLE NAME
ERR 243,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 244,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
BZE KVPFL,STGO1 SKIP IF NO PROFILING
JSR PRFLU ELSE PROFILE THE STATEMENT
STGO1 MOV KVSTN,KVLST SET LASTNO
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
*
* (XR) POINTS TO ENDING MESSAGE
* 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.
*
STOPR RTN
BZE XR,STPRA SKIP IF SYSAX ALREADY CALLED (REG04)
JSR SYSAX CALL AFTER EXECUTION PROC
STPRA ADD RSMEM,DNAME USE THE RESERVE MEMORY
BNE XR,=ENDMS,STPR0 SKIP IF NOT NORMAL END MESSAGE
BNZ EXSTS,STPR3 SKIP IF EXEC STATS SUPPRESSED
ZER ERICH CLEAR ERRORS TO INT.CH. FLAG
*
* LOOK TO SEE IF AN ENDING MESSAGE IS SUPPLIED
*
STPR0 JSR PRTPG EJECT PRINTER
BZE XR,STPR1 SKIP IF NO MESSAGE
JSR PRTST PRINT MESSAGE
*
* MERGE HERE IF NO MESSAGE TO PRINT
*
STPR1 JSR PRTIS PRINT BLANK LINE
MTI KVSTN GET STATEMENT NUMBER
MOV =STPM1,XR POINT TO MESSAGE /IN STATEMENT XXX/
JSR PRTMX 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 PRTMX PRINT IT
LDI KVSTL GET STATEMENT LIMIT
ILT STPR2 SKIP IF NEGATIVE
SBI KVSTC MINUS COUNTER = COUNT
STI STPSI SAVE
MOV =STPM2,XR POINT TO MESSAGE /STMTS EXECUTED/
JSR PRTMX PRINT IT
LDI STPTI RELOAD ELAPSED TIME
MLI INTTH *1000 (MICROSECS)
IOV STPR2 JUMP IF WE CANNOT COMPUTE
DVI STPSI DIVIDE BY STATEMENT COUNT
IOV STPR2 JUMP IF OVERFLOW
MOV =STPM4,XR POINT TO MSG (MCSEC PER STATEMENT /
JSR PRTMX PRINT IT
EJC
*
* STOPR (CONTINUED)
*
* MERGE TO SKIP MESSAGE (OVERFLOW OR NEGATIVE STLIMIT)
*
STPR2 MTI GBCNT LOAD COUNT OF COLLECTIONS
MOV =STPM5,XR POINT TO MESSAGE /REGENERATIONS /
JSR PRTMX PRINT IT
JSR PRTIS ONE MORE BLANK FOR LUCK
*
* CHECK IF DUMP REQUESTED
*
STPR3 JSR PRFLR PRINT PROFILE IF WANTED
*
MOV KVDMP,XR LOAD DUMP KEYWORD
JSR DUMPR EXECUTE DUMP IF REQUESTED
MOV R$FCB,XL GET FCBLK CHAIN HEAD
MOV KVABE,WA LOAD ABEND VALUE
MOV KVCOD,WB LOAD CODE VALUE
JSR SYSEJ EXIT TO SYSTEM
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
EJC
*
* SYSAB -- PRINT /ABNORMAL END/ AND TERMINATE
*
SYSAB RTN
MOV =ENDAB,XR POINT TO MESSAGE
MOV =NUM01,KVABE SET ABEND FLAG
JSR PRTNL SKIP TO NEW LINE
BRN STOPR JUMP TO PACK UP
EJC
*
* SYSTU -- PRINT /TIME UP/ AND TERMINATE
*
SYSTU RTN
MOV =ENDTU,XR POINT TO MESSAGE
MOV STRTU,WA GET CHARS /TU/
MOV WA,KVCOD PUT IN KVCOD
MOV TIMUP,WA CHECK STATE OF TIMEUP SWITCH
MNZ TIMUP SET SWITCH
BNZ WA,STOPR STOP RUN IF ALREADY SET
ERB 245,TRANSLATION/EXECUTION TIME EXPIRED
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
*
ICV ERRFT FATAL ERROR
MOV FLPTR,XS POP STACK TO AVOID MORE FAILS
BNZ GBCFL,STAK1 JUMP IF GARBAGE COLLECTING
ERB 246,STACK OVERFLOW
*
* NO CHANCE OF RECOVERY IN MID GARBAGE COLLECTION
*
STAK1 MOV =ENDSO,XR POINT TO MESSAGE
ZER KVDMP MEMORY IS UNDUMPABLE
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 BEQ R$CIM,=CMLAB,CMPLE JUMP IF ERROR IN SCANNING LABEL
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,ERR04 EXECUTE TIME COMPILE
IFF STGEV,ERR04 EVAL COMPILING EXPR.
IFF STGEE,ERR04 EVAL EVALUATING EXPR
IFF STGXT,ERR05 EXECUTE TIME
IFF STGCE,ERR01 COMPILE - AFTER END
IFF STGXE,ERR04 XEQ COMPILE-PAST END
ESW END SWITCH ON ERROR TYPE
EJC
*
* 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.
*
ERR01 MOV CMPXS,XS RESET STACK POINTER
SSL CMPSS RESTORE S-R STACK PTR FOR CMPIL
BNZ ERRSP,ERR03 JUMP IF ERROR SUPPRESS FLAG SET
MOV ERICH,ERLST SET FLAG FOR LISTR
JSR LISTR LIST LINE
JSR PRTIS TERMINATE LISTING
ZER ERLST CLEAR LISTR FLAG
MOV SCNSE,WA LOAD SCAN ELEMENT OFFSET
BZE WA,ERR02 SKIP IF NOT SET
LCT WB,WA LOOP COUNTER
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
MOV R$CIM,XL POINT TO BAD STATEMENT
PLC XL READY TO GET CHARS
*
* LOOP TO REPLACE ALL CHARS BUT TABS BY BLANKS
*
ERRA1 LCH WC,(XL)+ GET NEXT CHAR
BEQ WC,=CH$HT,ERRA2 SKIP IF TAB
MOV =CH$BL,WC GET A BLANK
EJC
*
* MERGE TO STORE BLANK OR TAB IN ERROR LINE
*
ERRA2 SCH WC,(XR)+ STORE CHAR
BCT WB,ERRA1 LOOP
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
*
* HERE AFTER PLACING ERROR FLAG AS REQUIRED
*
ERR02 JSR ERMSG GENERATE FLAG AND ERROR MESSAGE
ADD =NUM03,LSTLC BUMP PAGE CTR FOR BLANK, ERROR, BLK
ZER XR IN CASE OF FATAL ERROR
BHI ERRFT,=NUM03,STOPR PACK UP IF SEVERAL FATALS
*
* COUNT ERROR, INHIBIT EXECUTION IF REQUIRED
*
ICV CMERC BUMP ERROR COUNT
ADD CSWER,NOXEQ INHIBIT XEQ IF -NOERRORS
BNE STAGE,=STGIC,CMP10 SPECIAL RETURN IF AFTER END LINE
EJC
*
* LOOP TO SCAN TO END OF STATEMENT
*
ERR03 MOV R$CIM,XR POINT TO START OF IMAGE
PLC XR POINT TO FIRST CHAR
LCH XR,(XR) GET FIRST CHAR
BEQ XR,=CH$MN,CMPCE 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,ERR03 LOOP BACK IF NOT STATEMENT END
ZER ERRSP CLEAR ERROR SUPPRESS FLAG
*
* GENERATE ERROR CALL IN CODE AND RETURN TO CMPIL
*
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
BRN CMPSE MERGE TO GENERATE ERROR AS CDFAL
*
* ERROR DURING EXECUTE TIME COMPILE OR EXPRESSION EVALUATIO
*
* 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.
*
ERR04 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.
*
ERRA4 ICA XS POP STACK
BEQ XS,FLPRT,ERRC4 JUMP IF PROG DEFINED FN CALL FOUND
BNE XS,GTCEF,ERRA4 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
*
ERRB4 BNZ KVERL,ERR07 JUMP IF ERRLIMIT NON-ZERO
BRN EXFAL FAIL
*
* RETURN FROM PROG. DEFINED FUNCTION IS OUTSTANDING
*
ERRC4 MOV FLPTR,XS RESTORE STACK FROM FLPTR
BRN ERRB4 MERGE
EJC
*
* ERROR AT EXECUTE TIME.
*
* THE ACTION TAKEN ON AN ERROR IS AS FOLLOWS.
*
* IF ERRLIMIT KEYWORD IS ZERO, AN ABORT IS SIGNALLED,
* SEE CODING FOR SYSTEM LABEL ABORT AT L$ABO.
*
* 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 IS SIGNALLED
* REGARDLESS OF ERRLIMIT AND SETEXIT - LOOPING IS ALL TOO
* PROBABLE OTHERWISE. FATAL ERRORS INCLUDE STACK OVERFLOW
* AND EXCEEDING STLIMIT.
*
ERR05 SSL INISS RESTORE MAIN PROG S-R STACK PTR
BNZ DMVCH,ERR08 JUMP IF IN MID-DUMP
*
* MERGE HERE FROM ERR08
*
ERR06 BZE KVERL,LABO1 ABORT IF ERRLIMIT IS ZERO
JSR ERTEX GET FAIL MESSAGE TEXT
*
* MERGE FROM ERR04
*
ERR07 BGE ERRFT,=NUM03,LABO1 ABORT IF TOO MANY FATAL ERRORS
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,LCNT1 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.
*
ERR08 MOV DMVCH,XR CHAIN HEAD FOR AFFECTED VRBLKS
BZE XR,ERR06 DONE IF ZERO
MOV (XR),DMVCH SET NEXT LINK AS CHAIN HEAD
JSR SETVR RESTORE VRGET FIELD
BRN ERR08 LOOP THROUGH CHAIN
TTL S P I T B O L -- HERE ENDETH THE CODE
*
* END OF ASSEMBLY
*
END END MACRO-SPITBOL ASSEMBLY