V10/cmd/spitbol/spitv35.serr
#title s p i t b o l - revision history
#page
# 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)
#
#title s p i t b o l -- basic information
#page
#
# 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.
#page
#
# 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.
#page
#
# 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
#page
#
# 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.
#page
#
# 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.
#page
#
# 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.
#page
#
# 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.
#page
#
# 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
#title 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
#page
#
# SYSAX -- AFTER EXECUTION
#
.globl sysax # 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
#page
#
# SYSBX -- BEFORE EXECUTION
#
.globl sysbx # 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
#page
#
# SYSDC -- DATE CHECK
#
.globl sysdc # 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
#page
#
# SYSDM -- DUMP CORE
#
.globl sysdm # 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
#page
#
# SYSDT -- GET CURRENT DATE
#
.globl sysdt # 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.
#page
#
# SYSEF -- EJECT FILE
#
.globl sysef # 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
#page
#
# SYSEJ -- END OF JOB
#
.globl sysej # 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.
#page
#
# SYSEM -- GET ERROR MESSAGE TEXT
#
.globl sysem # 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.
#page
#
# SYSEN -- ENDFILE
#
.globl sysen # 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.
#page
#
# SYSEP -- EJECT PRINTER PAGE
#
.globl sysep # 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
#page
#
# SYSEX -- CALL EXTERNAL FUNCTION
#
.globl sysex # 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.
#page
#
# SYSFC -- FILE CONTROL BLOCK ROUTINE
#
.globl sysfc # 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.
#page
# 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
#page
#
# SYSHS -- GIVE ACCESS TO HOST COMPUTER FEATURES
#
.globl syshs # 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
#page
#
# SYSID -- RETURN SYSTEM IDENTIFICATION
#
.globl sysid # 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
#page
#
# SYSIL -- GET INPUT RECORD LENGTH
#
.globl sysil # 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.
#page
#
# SYSIN -- READ INPUT RECORD
#
.globl sysin # 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
#page
#
# SYSIO -- INPUT/OUTPUT FILE ASSOCIATION
#
.globl sysio # 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.
#page
#
# SYSLD -- LOAD EXTERNAL FUNCTION
#
.globl sysld # 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.
#page
#
# SYSMM -- GET MORE MEMORY
#
.globl sysmm # 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
#page
#
# SYSMX -- SUPPLY MXLEN
#
.globl sysmx # 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
#page
#
# SYSOU -- OUTPUT RECORD
#
.globl sysou # 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.
#page
#
# SYSPI -- PRINT ON INTERACTIVE CHANNEL
#
.globl syspi # 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
#page
#
# SYSPP -- OBTAIN PRINT PARAMETERS
#
.globl syspp # 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
#page
#
# SYSPR -- PRINT LINE ON STANDARD OUTPUT FILE
#
.globl syspr # 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.
#page
#
# SYSRD -- READ RECORD FROM STANDARD INPUT FILE
#
.globl sysrd # 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
#page
#
# SYSRI -- READ RECORD FROM INTERACTIVE CHANNEL
#
.globl sysri # 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
#page
#
# SYSRW -- REWIND FILE
#
.globl sysrw # 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
#page
#
# SYSST -- SET FILE POINTER
#
.globl sysst # 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
#
#page
#
# SYSTM -- GET EXECUTION TIME SO FAR
#
.globl systm # 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
#page
#
# SYSTT -- TRACE TOGGLE
#
.globl systt # 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
#page
#
# SYSUL -- UNLOAD EXTERNAL FUNCTION
#
.globl sysul # 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).
#page
#
# SYSXI -- EXIT TO PRODUCE LOAD MODULE
#
.globl sysxi # 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.
#page
#
# 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.
#page
#
# INTRODUCE THE INTERNAL PROCEDURES.
#
.globl acess
.globl acomp
.globl alloc
.globl alobf
.globl alocs
.globl alost
.globl apndb
.globl arith
.globl asign
.globl asinp
.globl blkln
.globl cdgcg
.globl cdgex
.globl cdgnm
.globl cdgvl
.globl cdwrd
.globl cmgen
.globl cmpil
.globl cncrd
.globl copyb
.globl dffnc
.globl dtach
.globl dtype
.globl dumpr
.globl ermsg
.globl ertex
.globl evali
.globl evalp
.globl evals
.globl evalx
.globl exbld
.globl expan
.globl expap
.globl expdm
.globl expop
.globl flstg
.globl gbcol
.globl gbcpf
.globl gtarr
#page
.globl gtcod
.globl gtexp
.globl gtint
.globl gtnum
.globl gtnvr
.globl gtpat
.globl gtrea
.globl gtsmi
.globl gtstg
.globl gtvar
.globl hashs
.globl icbld
.globl ident
.globl inout
.globl insbf
.globl iofcb
.globl ioppf
.globl ioput
.globl ktrex
.globl kwnam
.globl lcomp
.globl listr
.globl listt
.globl nexts
.globl patin
.globl patst
.globl pbild
.globl pconc
.globl pcopy
.globl prflr
.globl prflu
.globl prpar
.globl prtch
.globl prtic
.globl prtis
.globl prtin
.globl prtmi
.globl prtmx
.globl prtnl
.globl prtnm
.globl prtnv
.globl prtpg
.globl prtps
.globl prtsn
.globl prtst
#page
.globl prttr
.globl prtvl
.globl prtvn
.globl rcbld
.globl readr
.globl sbstr
.globl scane
.globl scngf
.globl setvr
.globl sorta
.globl sortc
.globl sortf
.globl sorth
.globl tfind
.globl trace
.globl trbld
.globl trimr
.globl trxeq
.globl xscan
.globl xscni
#
# INTRODUCE THE INTERNAL ROUTINES
#
.globl arref
.globl cfunc
.globl exfal
.globl exint
.globl exits
.globl exixr
.globl exnam
.globl exnul
.globl exrea
.globl exsid
.globl exvnm
.globl failp
.globl flpop
.globl indir
.globl match
.globl retrn
.globl stcov
.globl stmgo
.globl stopr
.globl succp
.globl sysab
.globl systu
#title 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.
#
.set cfp$a,256 # number of characters in alphabet
#
.set cfp$b,4 # bytes/word addressing factor
#
.set cfp$c,4 # number of characters per word
#
.set cfp$f,8 # offset in bytes to chars in
# SCBLK. SEE SCBLK FORMAT.
#
.set cfp$i,1 # number of words in integer constant
#
.set cfp$m,0x7fffffff# max positive integer in one word
#
.set cfp$n,32 # 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.
#
#
.set cfp$r,1 # number of words in real constant
#
.set cfp$s,6 # number of sig digs for real output
#
.set cfp$x,2 # max digits in real exponent
#
.set mxdgs,cfp$s+cfp$x# max digits in real number
#
.set nstmx,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.
#
.set cfp$u,128 # realistic upper bound on alphabet
#page
#
# 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.
#
.set e$srs,50 # 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.
#
.set e$sts,512 # 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.
#
.set e$cbs,512 # 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.
#
.set e$hnb,253 # 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.
#
.set e$hnw,3 # 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.
#
.set e$fsp,20 # 15 percent
#page
#
# DEFINITIONS OF CODES FOR LETTERS
#
.set ch$la,65 # letter a
.set ch$lb,66 # letter b
.set ch$lc,67 # letter c
.set ch$ld,68 # letter d
.set ch$le,69 # letter e
.set ch$lf,70 # letter f
.set ch$lg,71 # letter g
.set ch$lh,72 # letter h
.set ch$li,73 # letter i
.set ch$lj,74 # letter j
.set ch$lk,75 # letter k
.set ch$ll,76 # letter l
.set ch$lm,77 # letter m
.set ch$ln,78 # letter n
.set ch$lo,79 # letter o
.set ch$lp,80 # letter p
.set ch$lq,81 # letter q
.set ch$lr,82 # letter r
.set ch$ls,83 # letter s
.set ch$lt,84 # letter t
.set ch$lu,85 # letter u
.set ch$lv,86 # letter v
.set ch$lw,87 # letter w
.set ch$lx,88 # letter x
.set ch$ly,89 # letter y
.set ch$l$,90 # letter z
#
# DEFINITIONS OF CODES FOR DIGITS
#
.set ch$d0,48 # digit 0
.set ch$d1,49 # digit 1
.set ch$d2,50 # digit 2
.set ch$d3,51 # digit 3
.set ch$d4,52 # digit 4
.set ch$d5,53 # digit 5
.set ch$d6,54 # digit 6
.set ch$d7,55 # digit 7
.set ch$d8,56 # digit 8
.set ch$d9,57 # digit 9
#page
#
# 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.
#
.set ch$am,38 # keyword operator (ampersand)
.set ch$as,42 # multiplication symbol (asterisk)
.set ch$at,64 # cursor position operator (at)
.set ch$bb,60 # left array bracket (less than)
.set ch$bl,32 # blank
.set ch$br,124 # alternation operator (vertical bar)
.set ch$cl,58 # goto symbol (colon)
.set ch$cm,44 # comma
.set ch$dl,36 # indirection operator (dollar)
.set ch$dt,46 # name operator (dot)
.set ch$dq,34 # double quote
.set ch$eq,61 # equal sign
.set ch$ex,33 # exponentiation operator (exclm)
.set ch$mn,45 # minus sign
.set ch$nm,35 # number sign
.set ch$nt,126 # negation operator (not)
.set ch$pc,37 # percent
.set ch$pl,43 # plus sign
.set ch$pp,40 # left parenthesis
.set ch$rb,62 # right array bracket (grtr than)
.set ch$rp,41 # right parenthesis
.set ch$qu,63 # interrogation operator (question)
.set ch$sl,47 # slash
.set ch$sm,59 # semicolon
.set ch$sq,39 # single quote
.set ch$un,95 # special identifier char (underline)
.set ch$ob,91 # opening bracket
.set ch$cb,93 # closing bracket
#page
#
# REMAINING CHARS ARE OPTIONAL ADDITIONS TO THE STANDARDS.
#
# TAB CHARACTERS - SYNTACTICALLY EQUIVALENT TO BLANK
#
.set ch$ht,9 # horizontal tab
#
# LOWER CASE OR SHIFTED CASE ALPHABETIC CHARS
#
.set ch$$a,97 # shifted a
.set ch$$b,98 # shifted b
.set ch$$c,99 # shifted c
.set ch$$d,100 # shifted d
.set ch$$e,101 # shifted e
.set ch$$f,102 # shifted f
.set ch$$g,103 # shifted g
.set ch$$h,104 # shifted h
.set ch$$i,105 # shifted i
.set ch$$j,106 # shifted j
.set ch$$k,107 # shifted k
.set ch$$l,108 # shifted l
.set ch$$m,109 # shifted m
.set ch$$n,110 # shifted n
.set ch$$o,111 # shifted o
.set ch$$p,112 # shifted p
.set ch$$q,113 # shifted q
.set ch$$r,114 # shifted r
.set ch$$s,115 # shifted s
.set ch$$t,116 # shifted t
.set ch$$u,117 # shifted u
.set ch$$v,118 # shifted v
.set ch$$w,119 # shifted w
.set ch$$x,120 # shifted x
.set ch$$y,121 # shifted y
.set ch$$$,122 # 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.
#
.set iodel,0
#page
#
# 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.
#page
#
# 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
#
.set offs1,1
.set offs2,2
.set offs3,3
#
# 5) DETAILED COMMENTS ON THE SIGNIFICANCE AND FORMATS
# OF THE VARIOUS FIELDS.
#
# THE ORDER IS ALPHABETICAL BY IDENTIFICATION CODE.
#page
#
# 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
#
.set bl$ar,0 # arblk array
.set bl$bc,bl$ar+1 # bcblk buffer
.set bl$cd,bl$bc+1 # cdblk code
.set bl$ex,bl$cd+1 # exblk expression
.set bl$ic,bl$ex+1 # icblk integer
.set bl$nm,bl$ic+1 # nmblk name
.set bl$p0,bl$nm+1 # p0blk pattern
.set bl$p1,bl$p0+1 # p1blk pattern
.set bl$p2,bl$p1+1 # p2blk pattern
.set bl$rc,bl$p2+1 # rcblk real
.set bl$sc,bl$rc+1 # scblk string
.set bl$se,bl$sc+1 # seblk expression
.set bl$tb,bl$se+1 # tbblk table
.set bl$vc,bl$tb+1 # vcblk array
.set bl$xn,bl$vc+1 # xnblk external
.set bl$xr,bl$xn+1 # xrblk external
.set bl$pd,bl$xr+1 # pdblk program defined datatype
#
.set bl$$d,bl$pd+1 # number of block codes for data
#
# OTHER BLOCK CODES
#
.set bl$tr,bl$pd+1 # trblk
.set bl$bf,bl$tr+1 # bfblk
.set bl$cc,bl$bf+1 # ccblk
.set bl$cm,bl$cc+1 # cmblk
.set bl$ct,bl$cm+1 # ctblk
.set bl$df,bl$ct+1 # dfblk
.set bl$ef,bl$df+1 # efblk
.set bl$ev,bl$ef+1 # evblk
.set bl$ff,bl$ev+1 # ffblk
.set bl$kv,bl$ff+1 # kvblk
.set bl$pf,bl$kv+1 # pfblk
.set bl$te,bl$pf+1 # teblk
#
.set bl$$i,0 # default identification code
.set bl$$t,bl$tr+1 # code for data or trace block
.set bl$$$,bl$te+1 # number of block codes
#page
#
# 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.
#page
#
# 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 /
# / /
# +------------------------------------+
#
.set fcode,0 # pointer to code for function
.set fargs,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
#page
#
# 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.
#
.set idval,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).
#page
#
# 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 /
# / /
# +------------------------------------+
#page
#
# ARRAY BLOCK (CONTINUED)
#
.set artyp,0 # pointer to dummy routine b$art
.set arlen,idval+1 # length of arblk in bytes
.set arofs,arlen+1 # offset in arblk to arpro field
.set arndm,arofs+1 # number of dimensions
.set arlbd,arndm+1 # low bound (first subscript)
.set ardim,arlbd+cfp$i# dimension (first subscript)
.set arlb2,ardim+cfp$i# low bound (second subscript)
.set ardm2,arlb2+cfp$i# dimension (second subscript)
.set arpro,ardim+cfp$i# array prototype (one dimension)
.set arvls,arpro+1 # start of values (one dimension)
.set arpr2,ardm2+cfp$i# array prototype (two dimensions)
.set arvl2,arpr2+1 # start of values (two dimensions)
.set arsi$,arlbd # number of standard fields in block
.set ardms,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
# +------------------------------------+
#
.set bctyp,0 # ptr to dummy routine b$bct
.set bclen,idval+1 # defined buffer length
.set bcbuf,bclen+1 # ptr to bfblk
.set bcsi$,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.
#
#page
#
# STRING BUFFER BLOCK (BFBLK)
#
# A BFBLK IS BUILT BY A CALL TO BUFFER(...)
#
# +------------------------------------+
# I BFTYP I
# +------------------------------------+
# I BFALC I
# +------------------------------------+
# / /
# / BFCHR /
# / /
# +------------------------------------+
#
.set bftyp,0 # ptr to dummy routine b$bft
.set bfalc,bftyp+1 # allocated size of buffer
.set bfchr,bfalc+1 # characters of string
.set bfsi$,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.
#
#page
#
# 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 /
# / /
# +------------------------------------+
#
.set cctyp,0 # pointer to dummy routine b$cct
.set cclen,cctyp+1 # length of ccblk in bytes
.set ccuse,cclen+1 # offset past last used word (bytes)
.set cccod,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)
#page
#
# 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 /
# / /
# +------------------------------------+
#
.set cdjmp,0 # ptr to routine to execute statement
.set cdstm,cdjmp+1 # statement number
.set cdlen,offs2 # length of cdblk in bytes
.set cdfal,offs3 # failure exit (see below)
.set cdcod,cdfal+1 # executable pseudo-code
.set cdsi$,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
#page
#
# 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
#page
#
# 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
#
#page
#
# 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
#page
#
# 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
#page
#
# 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.
#page
#
# 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.
#page
#
# 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 /
# / /
# +------------------------------------+
#
.set cmidn,0 # pointer to dummy routine b$cmt
.set cmlen,cmidn+1 # length of cmblk in bytes
.set cmtyp,cmlen+1 # type (c$xxx, see list below)
.set cmopn,cmtyp+1 # operand pointer (see below)
.set cmvls,cmopn+1 # operand value pointers (see below)
.set cmrop,cmvls # right (only) operator operand
.set cmlop,cmvls+1 # left operator operand
.set cmsi$,cmvls # number of standard fields in cmblk
.set cmus$,cmsi$+1 # size of unary operator cmblk
.set cmbs$,cmsi$+2 # size of binary operator cmblk
.set cmar1,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
#page
#
# CMTYP IS SET TO INDICATE THE TYPE OF EXPRESSION ELEMENT
# AS SHOWN BY THE FOLLOWING TABLE OF DEFINITIONS.
#
.set c$arr,0 # array reference
.set c$fnc,c$arr+1 # function call
.set c$def,c$fnc+1 # deferred expression (unary *)
.set c$ind,c$def+1 # indirection (unary $)
.set c$key,c$ind+1 # keyword reference (unary ampersand)
.set c$ubo,c$key+1 # undefined binary operator
.set c$uuo,c$ubo+1 # undefined unary operator
.set c$uo$,c$uuo+1 # test value (=c$uuo+1=c$ubo+2)
.set c$$nm,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).
#
.set c$bvl,c$uuo+1 # binary op with value operands
.set c$uvl,c$bvl+1 # unary operator with value operand
.set c$alt,c$uvl+1 # alternation (binary bar)
.set c$cnc,c$alt+1 # concatenation
.set c$cnp,c$cnc+1 # concatenation, not pattern match
.set c$unm,c$cnp+1 # unary op with name operand
.set c$bvn,c$unm+1 # binary op (operands by value, name)
.set c$ass,c$bvn+1 # assignment
.set c$int,c$ass+1 # interrogation
.set c$neg,c$int+1 # negation (unary not)
.set c$sel,c$neg+1 # selection
.set c$pmt,c$sel+1 # pattern match
#
.set c$pr$,c$bvn # last preevaluable code
.set c$$nv,c$pmt+1 # number of different cmblk types
#page
#
# 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 *
# * *
# * *
# +------------------------------------+
#
.set cttyp,0 # pointer to dummy routine b$ctt
.set ctchs,cttyp+1 # start of character table words
.set ctsi$,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.
#page
#
# 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 /
# / /
# +------------------------------------+
#
.set dflen,fargs+1 # length of dfblk in bytes
.set dfpdl,dflen+1 # length of corresponding pdblk
.set dfnam,dfpdl+1 # pointer to scblk for datatype name
.set dffld,dfnam+1 # start of vrblk ptrs for field names
.set dfflb,dffld-1 # offset behind dffld for field func
.set dfsi$,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.
#page
#
# 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
# +------------------------------------+
#
.set dvopn,0 # entry address (ptr to o$xxx)
.set dvtyp,dvopn+1 # type code (c$xxx, see cmblk)
.set dvlpr,dvtyp+1 # left precedence (llxxx, see below)
.set dvrpr,dvlpr+1 # right precedence (rrxxx, see below)
.set dvus$,dvlpr+1 # size of unary operator dv
.set dvbs$,dvrpr+1 # size of binary operator dv
.set dvubs,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.
#page
#
# TABLE OF OPERATOR PRECEDENCE VALUES
#
.set rrass,10 # right equal
.set llass,00 # left equal
.set rrpmt,20 # right question mark
.set llpmt,30 # left question mark
.set rramp,40 # right ampersand
.set llamp,50 # left ampersand
.set rralt,70 # right vertical bar
.set llalt,60 # left vertical bar
.set rrcnc,90 # right blank
.set llcnc,80 # left blank
.set rrats,110 # right at
.set llats,100 # left at
.set rrplm,120 # right plus, minus
.set llplm,130 # left plus, minus
.set rrnum,140 # right number
.set llnum,150 # left number
.set rrdvd,160 # right slash
.set lldvd,170 # left slash
.set rrmlt,180 # right asterisk
.set llmlt,190 # left asterisk
.set rrpct,200 # right percent
.set llpct,210 # left percent
.set rrexp,230 # right exclamation
.set llexp,220 # left exclamation
.set rrdld,240 # right dollar, dot
.set lldld,250 # left dollar, dot
.set rrnot,270 # right not
.set llnot,260 # left not
.set lluno,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.
#page
#
# 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 /
# / /
# +------------------------------------+
#
.set eflen,fargs+1 # length of efblk in bytes
.set efuse,eflen+1 # use count (for opsyn)
.set efcod,efuse+1 # ptr to code (from sysld)
.set efvar,efcod+1 # ptr to associated vrblk
.set efrsl,efvar+1 # result type (see below)
.set eftar,efrsl+1 # argument types (see below)
.set efsi$,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
#page
#
# 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
# +------------------------------------+
#
.set evtyp,0 # pointer to dummy routine b$evt
.set evexp,evtyp+1 # pointer to exblk for expression
.set evvar,evexp+1 # pointer to trbev dummy trblk
.set evsi$,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.
#page
#
# 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 /
# / /
# +------------------------------------+
#
.set extyp,0 # ptr to routine b$exl to load expr
.set exstm,cdstm # stores stmnt no. during evaluation
.set exlen,exstm+1 # length of exblk in bytes
.set exflc,exlen+1 # failure code (=o$fex)
.set excod,exflc+1 # pseudo-code for expression
.set exsi$,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
#page
#
# 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
# +------------------------------------+
#
.set ffdfp,fargs+1 # pointer to associated dfblk
.set ffnxt,ffdfp+1 # ptr to next ffblk on chain or zero
.set ffofs,ffnxt+1 # offset (bytes) to field in pdblk
.set ffsi$,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
#page
#
# 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 *
# +------------------------------------+
#
.set icget,0 # ptr to routine b$icl to load int
.set icval,icget+1 # integer value
.set icsi$,icval+cfp$i# size of icblk
#
# THE LENGTH OF THE ICVAL FIELD IS CFP$I.
#page
#
# 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
# +------------------------------------+
#
.set kvtyp,0 # pointer to dummy routine b$kvt
.set kvvar,kvtyp+1 # pointer to dummy block trbkv
.set kvnum,kvvar+1 # keyword number
.set kvsi$,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.
#page
#
# 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
# +------------------------------------+
#
.set nmtyp,0 # ptr to routine b$nml to load name
.set nmbas,nmtyp+1 # base pointer for variable
.set nmofs,nmbas+1 # offset for variable
.set nmsi$,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.
#page
#
# 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
# +------------------------------------+
#
.set pcode,0 # ptr to match routine (p$xxx)
.set pthen,pcode+1 # pointer to subsequent node
.set pasi$,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.
#page
#
# 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
# +------------------------------------+
#
.set parm1,pthen+1 # first parameter value
.set pbsi$,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.
#page
#
# 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
# +------------------------------------+
#
.set parm2,parm1+1 # second parameter value
.set pcsi$,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.
#page
#
# 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 /
# / /
# +------------------------------------+
#
.set pdtyp,0 # ptr to dummy routine b$pdt
.set pddfp,idval+1 # ptr to associated dfblk
.set pdfld,pddfp+1 # start of field value pointers
.set pdfof,dffld-pdfld# difference in offset to field ptrs
.set pdsi$,pdfld # size of standard fields in pdblk
.set pddfs,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.
#page
#
# 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 /
# / /
# +------------------------------------+
#
.set pflen,fargs+1 # length of pfblk in bytes
.set pfvbl,pflen+1 # pointer to vrblk for function name
.set pfnlo,pfvbl+1 # number of locals
.set pfcod,pfnlo+1 # ptr to cdblk for first statement
.set pfctr,pfcod+1 # trblk ptr if call traced else 0
.set pfrtr,pfctr+1 # trblk ptr if return traced else 0
.set pfarg,pfrtr+1 # vrblk ptrs for arguments and locals
.set pfagb,pfarg-1 # offset behind pfarg for arg, local
.set pfsi$,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)
#page
#
# REAL CONSTANT BLOCK (RCBLK)
#
# AN RCBLK IS CREATED FOR EVERY REAL REFERENCED OR
# CREATED BY A PROGRAM.
#
# +------------------------------------+
# I RCGET I
# +------------------------------------+
# * RCVAL *
# +------------------------------------+
#
.set rcget,0 # ptr to routine b$rcl to load real
.set rcval,rcget+1 # real value
.set rcsi$,rcval+cfp$r# size of rcblk
#
# THE LENGTH OF THE RCVAL FIELD IS CFP$R.
#page
#
# STRING CONSTANT BLOCK (SCBLK)
#
# AN SCBLK IS BUILT FOR EVERY STRING REFERENCED OR CREATED
# BY A PROGRAM.
#
# +------------------------------------+
# I SCGET I
# +------------------------------------+
# I SCLEN I
# +------------------------------------+
# / /
# / SCHAR /
# / /
# +------------------------------------+
#
.set scget,0 # ptr to routine b$scl to load string
.set sclen,scget+1 # length of string in characters
.set schar,sclen+1 # characters of string
.set scsi$,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.
#page
#
# 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
# +------------------------------------+
#
.set setyp,0 # ptr to routine b$sel to load expr
.set sevar,setyp+1 # ptr to vrblk for variable
.set sesi$,sevar+1 # length of seblk in words
#page
#
# 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
# +------------------------------------+
#page
#
# STANDARD VARIABLE BLOCK (CONTINUED)
#
.set svbit,0 # bit string indicating attributes
.set svlen,1 # (=sclen) length of name in chars
.set svchs,2 # (=schar) characters of name
.set svsi$,2 # number of standard fields in svblk
.set svpre,1 # set if preevaluation permitted
.set svffc,svpre+svpre# set on if fast call permitted
.set svckw,svffc+svffc# set on if keyword value constant
.set svprd,svckw+svckw# set on if predicate function
.set svnbt,4 # number of bits to right of svknm
.set svknm,svprd+svprd# set on if keyword association
.set svfnc,svknm+svknm# set on if system function
.set svnar,svfnc+svfnc# set on if system function
.set svlbl,svnar+svnar# set on if system label
.set svval,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
#
.set svfnf,svfnc+svnar# function with no fast call
.set svfnn,svfnf+svffc# function with fast call, no preeval
.set svfnp,svfnn+svpre# function allowing preevaluation
.set svfpr,svfnn+svprd# predicate function
.set svfnk,svfnn+svknm# no preeval func + keyword
.set svkwv,svknm+svval# keyword + value
.set svkwc,svckw+svknm# keyword with constant value
.set svkvc,svkwv+svckw# constant keyword + value
.set svkvl,svkvc+svlbl# constant keyword + value + label
.set svfpk,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.
#page
#
# 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
#page
#
# 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
#
.set k$abe,0 # abend
.set k$anc,k$abe+cfp$b# anchor
.set k$cas,k$anc+cfp$b# case
.set k$cod,k$cas+cfp$b# code
.set k$dmp,k$cod+cfp$b# dump
.set k$erl,k$dmp+cfp$b# errlimit
.set k$ert,k$erl+cfp$b# errtype
.set k$ftr,k$ert+cfp$b# ftrace
.set k$inp,k$ftr+cfp$b# input
.set k$mxl,k$inp+cfp$b# maxlength
.set k$oup,k$mxl+cfp$b# output
.set k$pfl,k$oup+cfp$b# profile
.set k$tra,k$pfl+cfp$b# trace
.set k$trm,k$tra+cfp$b# trim
#
# PROTECTED KEYWORDS WITH ONE WORD INTEGER VALUES
#
.set k$fnc,k$trm+cfp$b# fnclevel
.set k$lst,k$fnc+cfp$b# lastno
.set k$stn,k$lst+cfp$b# stno
#
# KEYWORDS WITH CONSTANT PATTERN VALUES
#
.set k$abo,k$stn+cfp$b# abort
.set k$arb,k$abo+pasi$# arb
.set k$bal,k$arb+pasi$# bal
.set k$fal,k$bal+pasi$# fail
.set k$fen,k$fal+pasi$# fence
.set k$rem,k$fen+pasi$# rem
.set k$suc,k$rem+pasi$# succeed
#page
#
# KEYWORD NUMBER TABLE (CONTINUED)
#
# SPECIAL KEYWORDS
#
.set k$alp,k$suc+1 # alphabet
.set k$rtn,k$alp+1 # rtntype
.set k$stc,k$rtn+1 # stcount
.set k$etx,k$stc+1 # errtext
.set k$stl,k$etx+1 # stlimit
#
# RELATIVE OFFSETS OF SPECIAL KEYWORDS
#
.set k$$al,k$alp-k$alp# alphabet
.set k$$rt,k$rtn-k$alp# rtntype
.set k$$sc,k$stc-k$alp# stcount
.set k$$et,k$etx-k$alp# errtext
.set k$$sl,k$stl-k$alp# stlimit
#
# SYMBOLS USED IN ASIGN AND ACESS PROCEDURES
#
.set k$p$$,k$fnc # first protected keyword
.set k$v$$,k$abo # first keyword with constant value
.set k$s$$,k$alp # first keyword with special acess
#page
#
# 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 /
# / /
# +------------------------------------+
#
.set tbtyp,0 # pointer to dummy routine b$tbt
.set tblen,offs2 # length of tbblk in bytes
.set tbinv,offs3 # default initial lookup value
.set tbbuk,tbinv+1 # start of hash bucket pointers
.set tbsi$,tbbuk # size of standard fields in tbblk
.set tbnbk,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.
#page
#
# 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
# +------------------------------------+
#
.set tetyp,0 # pointer to dummy routine b$tet
.set tesub,tetyp+1 # subscript value
.set teval,tesub+1 # (=vrval) table element value
.set tenxt,teval+1 # link to next teblk
# SEE S$CNV WHERE RELATION IS ASSUMED WITH TENXT AND TBBUK
.set tesi$,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.
#page
#
# 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
# +------------------------------------+
#
.set tridn,0 # pointer to dummy routine b$trt
.set trtyp,tridn+1 # trap type code
.set trval,trtyp+1 # value of trapped variable (=vrval)
.set trnxt,trval # ptr to next trblk on trblk chain
.set trlbl,trval # ptr to actual label (traced label)
.set trkvr,trval # vrblk pointer for keyword trace
.set trtag,trval+1 # trace tag
.set trter,trtag # ptr to terminal vrblk or null
.set trtrf,trtag # ptr to trblk holding fcblk ptr
.set trfnc,trtag+1 # trace function vrblk (zero if none)
.set trfpt,trfnc # fcblk ptr for sysio
.set trsi$,trfnc+1 # number of words in trblk
#
.set trtin,0 # trace type for input association
.set trtac,trtin+1 # trace type for access trace
.set trtvl,trtac+1 # trace type for value trace
.set trtou,trtvl+1 # trace type for output association
.set trtfc,trtou+1 # trace type for fcblk identification
#page
#
# 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)
#page
# 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)
#page
#
# 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.
#page
#
# 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
# +------------------------------------+
#
.set vctyp,0 # pointer to dummy routine b$vct
.set vclen,offs2 # length of vcblk in bytes
.set vcvls,offs3 # start of vector values
.set vcsi$,vcvls # size of standard fields in vcblk
.set vcvlb,vcvls-1 # offset one word behind vcvls
.set vctbd,tbsi$-vcsi$# difference in sizes - see prtvl
#
# VCVLS ARE EITHER DATA POINTERS OR TRBLK POINTERS
#
# THE DIMENSION CAN BE DEDUCED FROM VCLEN.
#page
#
# 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 /
# / /
# +------------------------------------+
#page
#
# VARIABLE BLOCK (CONTINUED)
#
.set vrget,0 # pointer to routine to load value
.set vrsto,vrget+1 # pointer to routine to store value
.set vrval,vrsto+1 # variable value
.set vrvlo,vrval-vrsto# offset to value from store field
.set vrtra,vrval+1 # pointer to routine to jump to label
.set vrlbl,vrtra+1 # pointer to code for label
.set vrlbo,vrlbl-vrtra# offset to label from transfer field
.set vrfnc,vrlbl+1 # pointer to function block
.set vrnxt,vrfnc+1 # pointer to next vrblk on hash chain
.set vrlen,vrnxt+1 # length of name (or zero)
.set vrchs,vrlen+1 # characters of name (vrlen gt 0)
.set vrsvp,vrlen+1 # ptr to svblk (vrlen eq 0)
.set vrsi$,vrchs+1 # number of standard fields in vrblk
.set vrsof,vrlen-sclen# offset to dummy scblk for name
.set vrsvo,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.
#page
#
# 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 /
# / /
# +------------------------------------+
#
.set xntyp,0 # pointer to dummy routine b$xnt
.set xnlen,xntyp+1 # length of xnblk in bytes
.set xndta,xnlen+1 # data words
.set xnsi$,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.
#page
#
# 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 /
# / /
# +------------------------------------+
#
.set xrtyp,0 # pointer to dummy routine b$xrt
.set xrlen,xrtyp+1 # length of xrblk in bytes
.set xrptr,xrlen+1 # start of address pointers
.set xrsi$,xrptr # size of standard fields in xrblk
#page
#
# 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.
#
.set cnvst,8 # max standard type code for convert
.set cnvrt,cnvst+1 # convert code for reals
.set cnvbt,cnvrt+1 # convert code for buffer
.set cnvtt,cnvbt+1 # bsw code for convert
#
# INPUT IMAGE LENGTH
#
.set iniln,132 # default image length for compiler
.set inils,80 # image length if -sequ in effect
#
.set ionmb,2 # name base used for iochn in sysio
.set ionmo,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.
#
.set num01,1
.set num02,2
.set num03,3
.set num04,4
.set num05,5
.set num06,6
.set num07,7
.set num08,8
.set num09,9
.set num10,10
.set nini8,998
.set nini9,999
.set thsnd,1000
#page
#
# NUMBERS OF UNDEFINED SPITBOL OPERATORS
#
.set opbun,5 # no. of binary undefined ops
.set opuun,6 # no of unary undefined ops
#
# OFFSETS USED IN PRTSN, PRTMI AND ACESS
#
.set prsnf,13 # offset used in prtsn
.set prtmf,15 # offset to col 15 (prtmi)
.set rilen,120 # buffer length for sysri
#
# CODES FOR STAGES OF PROCESSING
#
.set stgic,0 # initial compile
.set stgxc,stgic+1 # execution compile (code)
.set stgev,stgxc+1 # expression eval during execution
.set stgxt,stgev+1 # execution time
.set stgce,stgxt+1 # initial compile after end line
.set stgxe,stgce+1 # exec. compile after end line
.set stgnd,stgce-stgic# difference in stage after end
.set stgee,stgxe+1 # eval evaluating expression
.set stgno,stgee+1 # number of codes
#page
#
#
# STATEMENT NUMBER PAD COUNT FOR LISTR
#
.set stnpd,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.
#
.set t$uop,0 # unary operator
.set t$lpr,t$uop+3 # left paren
.set t$lbr,t$lpr+3 # left bracket
.set t$cma,t$lbr+3 # comma
.set t$fnc,t$cma+3 # function call
.set t$var,t$fnc+3 # variable
.set t$con,t$var+3 # constant
.set t$bop,t$con+3 # binary operator
.set t$rpr,t$bop+3 # right paren
.set t$rbr,t$rpr+3 # right bracket
.set t$col,t$rbr+3 # colon
.set t$smc,t$col+3 # semi-colon
#
# THE FOLLOWING DEFINITIONS ARE USED ONLY IN THE GOTO FIELD
#
.set t$fgo,t$smc+1 # failure goto
.set t$sgo,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.
#
.set t$uok,t$fnc # last code ok before unary operator
#page
#
# DEFINITIONS OF VALUES FOR EXPAN JUMP TABLE
#
.set t$uo0,t$uop+0 # unary operator, state zero
.set t$uo1,t$uop+1 # unary operator, state one
.set t$uo2,t$uop+2 # unary operator, state two
.set t$lp0,t$lpr+0 # left paren, state zero
.set t$lp1,t$lpr+1 # left paren, state one
.set t$lp2,t$lpr+2 # left paren, state two
.set t$lb0,t$lbr+0 # left bracket, state zero
.set t$lb1,t$lbr+1 # left bracket, state one
.set t$lb2,t$lbr+2 # left bracket, state two
.set t$cm0,t$cma+0 # comma, state zero
.set t$cm1,t$cma+1 # comma, state one
.set t$cm2,t$cma+2 # comma, state two
.set t$fn0,t$fnc+0 # function call, state zero
.set t$fn1,t$fnc+1 # function call, state one
.set t$fn2,t$fnc+2 # function call, state two
.set t$va0,t$var+0 # variable, state zero
.set t$va1,t$var+1 # variable, state one
.set t$va2,t$var+2 # variable, state two
.set t$co0,t$con+0 # constant, state zero
.set t$co1,t$con+1 # constant, state one
.set t$co2,t$con+2 # constant, state two
.set t$bo0,t$bop+0 # binary operator, state zero
.set t$bo1,t$bop+1 # binary operator, state one
.set t$bo2,t$bop+2 # binary operator, state two
.set t$rp0,t$rpr+0 # right paren, state zero
.set t$rp1,t$rpr+1 # right paren, state one
.set t$rp2,t$rpr+2 # right paren, state two
.set t$rb0,t$rbr+0 # right bracket, state zero
.set t$rb1,t$rbr+1 # right bracket, state one
.set t$rb2,t$rbr+2 # right bracket, state two
.set t$cl0,t$col+0 # colon, state zero
.set t$cl1,t$col+1 # colon, state one
.set t$cl2,t$col+2 # colon, state two
.set t$sm0,t$smc+0 # semicolon, state zero
.set t$sm1,t$smc+1 # semicolon, state one
.set t$sm2,t$smc+2 # semicolon, state two
#
.set t$nes,t$sm2+1 # number of entries in branch table
#page
#
# DEFINITION OF OFFSETS USED IN CONTROL CARD PROCESSING
#
.set cc$ca,0 # -case
.set cc$do,cc$ca+1 # -double
.set cc$du,cc$do+1 # -dump
.set cc$ej,cc$du+1 # -eject
.set cc$er,cc$ej+1 # -errors
.set cc$ex,cc$er+1 # -execute
.set cc$fa,cc$ex+1 # -fail
.set cc$li,cc$fa+1 # -list
.set cc$nr,cc$li+1 # -noerrors
.set cc$nx,cc$nr+1 # -noexecute
.set cc$nf,cc$nx+1 # -nofail
.set cc$nl,cc$nf+1 # -nolist
.set cc$no,cc$nl+1 # -noopt
.set cc$np,cc$no+1 # -noprint
.set cc$op,cc$np+1 # -optimise
.set cc$pr,cc$op+1 # -print
.set cc$si,cc$pr+1 # -single
.set cc$sp,cc$si+1 # -space
.set cc$st,cc$sp+1 # -stitl
.set cc$ti,cc$st+1 # -title
.set cc$tr,cc$ti+1 # -trace
.set cc$nc,cc$tr+1 # number of control cards
.set ccnoc,4 # no. of chars included in match
.set ccofs,7 # offset to start of title/subtitle
#page
#
# 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.
#
.set cmstm,0 # tree for statement body
.set cmsgo,cmstm+1 # tree for success goto
.set cmfgo,cmsgo+1 # tree for fail goto
.set cmcgo,cmfgo+1 # conditional goto flag
.set cmpcd,cmcgo+1 # previous cdblk pointer
.set cmffp,cmpcd+1 # failure fill in flag for previous
.set cmffc,cmffp+1 # failure fill in flag for current
.set cmsop,cmffc+1 # success fill in offset for previous
.set cmsoc,cmsop+1 # success fill in offset for current
.set cmlbl,cmsoc+1 # ptr to vrblk for current label
.set cmtra,cmlbl+1 # ptr to entry cdblk
#
.set cmnen,cmtra+1 # count of stack entries for cmpil
#
# A FEW CONSTANTS USED BY THE PROFILER
.set pfpd1,8 # pad positions ...
.set pfpd2,20 # ... for profile ...
.set pfpd3,32 # ... printout
.set pf$i2,cfp$i+cfp$i# size of table entry (2 ints)
#
#title 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.
#
.data 0
#sec # start of constant section
#
# FREE STORE PERCENTAGE (USED BY ALLOC)
#
alfsp: .long e$fsp # free store percentage
#
# BIT CONSTANTS FOR GENERAL USE
#
bits0: .long 0 # all zero bits
bits1: .long 1 # one bit in low order position
bits2: .long 2 # bit in position 2
bits3: .long 4 # bit in position 3
bits4: .long 8 # bit in position 4
bits5: .long 16 # bit in position 5
bits6: .long 32 # bit in position 6
bits7: .long 64 # bit in position 7
bits8: .long 128 # bit in position 8
bits9: .long 256 # bit in position 9
bit10: .long 512 # bit in position 10
bitsm: .long cfp$m # mask for max integer
#
# BIT CONSTANTS FOR SVBLK (SVBIT FIELD) TESTS
#
btfnc: .long svfnc # bit to test for function
btknm: .long svknm # bit to test for keyword number
btlbl: .long svlbl # bit to test for label
btffc: .long svffc # bit to test for fast call
btckw: .long svckw # bit to test for constant keyword
btprd: .long svprd # bit to test for predicate function
btpre: .long svpre # bit to test for preevaluation
btval: .long svval # bit to test for value
#page
#
# LIST OF NAMES USED FOR CONTROL CARD PROCESSING
#
ccnms: .ascii "CASE"
.align 2
.ascii "DOUB"
.align 2
.ascii "DUMP"
.align 2
.ascii "EJEC"
.align 2
.ascii "ERRO"
.align 2
.ascii "EXEC"
.align 2
.ascii "FAIL"
.align 2
.ascii "LIST"
.align 2
.ascii "NOER"
.align 2
.ascii "NOEX"
.align 2
.ascii "NOFA"
.align 2
.ascii "NOLI"
.align 2
.ascii "NOOP"
.align 2
.ascii "NOPR"
.align 2
.ascii "OPTI"
.align 2
.ascii "PRIN"
.align 2
.ascii "SING"
.align 2
.ascii "SPAC"
.align 2
.ascii "STIT"
.align 2
.ascii "TITL"
.align 2
.ascii "TRAC"
.align 2
#
# HEADER MESSAGES FOR DUMPR PROCEDURE (SCBLK FORMAT)
#
dmhdk: .long b$scl # dump of keyword values
.long 22
.ascii "DUMP OF KEYWORD VALUES"
.align 2
#
dmhdv: .long b$scl # dump of natural variables
.long 25
.ascii "DUMP OF NATURAL VARIABLES"
.align 2
#page
#
# MESSAGE TEXT FOR COMPILATION STATISTICS
#
encm1: .long b$scl
.long 10
.ascii "STORE USED"
.align 2
#
encm2: .long b$scl
.long 10
.ascii "STORE LEFT"
.align 2
#
encm3: .long b$scl
.long 11
.ascii "COMP ERRORS"
.align 2
#
encm4: .long b$scl
.long 14
.ascii "COMP TIME-MSEC"
.align 2
#
encm5: .long b$scl # execution suppressed
.long 20
.ascii "EXECUTION SUPPRESSED"
.align 2
#
# STRING CONSTANT FOR ABNORMAL END
#
endab: .long b$scl
.long 12
.ascii "ABNORMAL END"
.align 2
#page
#
# MEMORY OVERFLOW DURING INITIALISATION
#
endmo: .long b$scl
endml: .long 15
.ascii "MEMORY OVERFLOW"
.align 2
#
# STRING CONSTANT FOR MESSAGE ISSUED BY L$END
#
endms: .long b$scl
.long 10
.ascii "NORMAL END"
.align 2
#
# FAIL MESSAGE FOR STACK FAIL SECTION
#
endso: .long b$scl # stack overflow in garbage collector
.long 36
.ascii "STACK OVERFLOW IN GARBAGE COLLECTION"
.align 2
#
# STRING CONSTANT FOR TIME UP
#
endtu: .long b$scl
.long 15
.ascii "ERROR - TIME UP"
.align 2
#page
#
# STRING CONSTANT FOR ERROR MESSAGE (ERROR SECTION)
#
ermms: .long b$scl # error
.long 5
.ascii "ERROR"
.align 2
#
ermns: .long b$scl # string / -- /
.long 4
.ascii " -- "
.align 2
#
# STRING CONSTANT FOR PAGE NUMBERING
#
lstms: .long b$scl # page
.long 5
.ascii "PAGE "
.align 2
#
# LISTING HEADER MESSAGE
#
headr: .long b$scl
.long 25
.ascii "MACRO SPITBOL VERSION 3.5"
.align 2
#
headv: .long b$scl # for exit() version no. check
.long 3
.ascii "3.5"
.align 2
#
# INTEGER CONSTANTS FOR GENERAL USE
# ICBLD OPTIMISATION USES THE FIRST THREE.
#
int$r: .long b$icl
intv0: .long 0 # 0
inton: .long b$icl
intv1: .long 1 # 1
inttw: .long b$icl
intv2: .long 2 # 2
intvt: .long 10 # 10
intvh: .long 100 # 100
intth: .long 1000 # 1000
#
# TABLE USED IN ICBLD OPTIMISATION
#
intab: .long int$r # pointer to 0
.long inton # pointer to 1
.long inttw # pointer to 2
#page
#
# 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: .long p$abb # arbno
ndabd: .long p$abd # arbno
ndarc: .long p$arc # arb
ndexb: .long p$exb # expression
ndfnb: .long p$fnb # fence()
ndfnd: .long p$fnd # fence()
ndexc: .long p$exc # expression
ndimb: .long p$imb # immediate assignment
ndimd: .long p$imd # immediate assignment
ndnth: .long p$nth # pattern end (null pattern)
ndpab: .long p$pab # pattern assignment
ndpad: .long p$pad # pattern assignment
nduna: .long 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: .long p$abo # abort
.long ndnth
ndarb: .long p$arb # arb
.long ndnth
ndbal: .long p$bal # bal
.long ndnth
ndfal: .long p$fal # fail
.long ndnth
ndfen: .long p$fen # fence
.long ndnth
ndrem: .long p$rem # rem
.long ndnth
ndsuc: .long p$suc # succeed
.long 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: .long b$scl # null string value
.long 0 # sclen = 0
nullw: .ascii " "
.align 2
#page
#
# OPERATOR DOPE VECTORS (SEE DVBLK FORMAT)
#
opdvc: .long o$cnc # concatenation
.long c$cnc
.long llcnc
.long rrcnc
#
# OPDVS IS USED WHEN SCANNING BELOW THE TOP LEVEL TO
# INSURE THAT THE CONCATENATION WILL NOT BE LATER
# MISTAKEN FOR PATTERN MATCHING
#
opdvp: .long o$cnc # concatenation - not pattern match
.long c$cnp
.long llcnc
.long rrcnc
#
# NOTE THAT THE ORDER OF THE REMAINING ENTRIES IS TIED TO
# THE ORDER OF THE CODING IN THE SCANE PROCEDURE.
#
opdvs: .long o$ass # assignment
.long c$ass
.long llass
.long rrass
#
.long 6 # unary equal
.long c$uuo
.long lluno
#
.long o$pmv # pattern match
.long c$pmt
.long llpmt
.long rrpmt
#
.long o$int # interrogation
.long c$uvl
.long lluno
#
.long 1 # binary ampersand
.long c$ubo
.long llamp
.long rramp
#
.long o$kwv # keyword reference
.long c$key
.long lluno
#
.long o$alt # alternation
.long c$alt
.long llalt
.long rralt
#page
#
# OPERATOR DOPE VECTORS (CONTINUED)
#
.long 5 # unary vertical bar
.long c$uuo
.long lluno
#
.long 0 # binary at
.long c$ubo
.long llats
.long rrats
#
.long o$cas # cursor assignment
.long c$unm
.long lluno
#
.long 2 # binary number sign
.long c$ubo
.long llnum
.long rrnum
#
.long 7 # unary number sign
.long c$uuo
.long lluno
#
.long o$dvd # division
.long c$bvl
.long lldvd
.long rrdvd
#
.long 9 # unary slash
.long c$uuo
.long lluno
#
.long o$mlt # multiplication
.long c$bvl
.long llmlt
.long rrmlt
#page
#
# OPERATOR DOPE VECTORS (CONTINUED)
#
.long 0 # deferred expression
.long c$def
.long lluno
#
.long 3 # binary percent
.long c$ubo
.long llpct
.long rrpct
#
.long 8 # unary percent
.long c$uuo
.long lluno
#
.long o$exp # exponentiation
.long c$bvl
.long llexp
.long rrexp
#
.long 10 # unary exclamation
.long c$uuo
.long lluno
#
.long o$ima # immediate assignment
.long c$bvn
.long lldld
.long rrdld
#
.long o$inv # indirection
.long c$ind
.long lluno
#
.long 4 # binary not
.long c$ubo
.long llnot
.long rrnot
#
.long 0 # negation
.long c$neg
.long lluno
#page
#
# OPERATOR DOPE VECTORS (CONTINUED)
#
.long o$sub # subtraction
.long c$bvl
.long llplm
.long rrplm
#
.long o$com # complementation
.long c$uvl
.long lluno
#
.long o$add # addition
.long c$bvl
.long llplm
.long rrplm
#
.long o$aff # affirmation
.long c$uvl
.long lluno
#
.long o$pas # pattern assignment
.long c$bvn
.long lldld
.long rrdld
#
.long o$nam # name reference
.long c$unm
.long lluno
#
# SPECIAL DVS FOR GOTO OPERATORS (SEE PROCEDURE SCNGF)
#
opdvd: .long o$god # direct goto
.long c$uvl
.long lluno
#
opdvn: .long o$goc # complex normal goto
.long c$unm
.long lluno
#page
#
# OPERATOR ENTRY ADDRESS POINTERS, USED IN CODE
#
oamn$: .long o$amn # array ref (multi-subs by value)
oamv$: .long o$amv # array ref (multi-subs by value)
oaon$: .long o$aon # array ref (one sub by name)
oaov$: .long o$aov # array ref (one sub by value)
ocer$: .long o$cer # compilation error
ofex$: .long o$fex # failure in expression evaluation
ofif$: .long o$fif # failure during goto evaluation
ofnc$: .long o$fnc # function call (more than one arg)
ofne$: .long o$fne # function name error
ofns$: .long o$fns # function call (single argument)
ogof$: .long o$gof # set goto failure trap
oinn$: .long o$inn # indirection by name
okwn$: .long o$kwn # keyword reference by name
olex$: .long o$lex # load expression by name
olpt$: .long o$lpt # load pattern
olvn$: .long o$lvn # load variable name
onta$: .long o$nta # negation, first entry
ontb$: .long o$ntb # negation, second entry
ontc$: .long o$ntc # negation, third entry
opmn$: .long o$pmn # pattern match by name
opms$: .long o$pms # pattern match (statement)
opop$: .long o$pop # pop top stack item
ornm$: .long o$rnm # return name from expression
orpl$: .long o$rpl # pattern replacement
orvl$: .long o$rvl # return value from expression
osla$: .long o$sla # selection, first entry
oslb$: .long o$slb # selection, second entry
oslc$: .long o$slc # selection, third entry
osld$: .long o$sld # selection, fourth entry
ostp$: .long o$stp # stop execution
ounf$: .long o$unf # unexpected failure
#page
#
# TABLE OF NAMES OF UNDEFINED BINARY OPERATORS FOR OPSYN
#
opsnb: .long ch$at # at
.long ch$am # ampersand
.long ch$nm # number
.long ch$pc # percent
.long ch$nt # not
#
# TABLE OF NAMES OF UNDEFINED UNARY OPERATORS FOR OPSYN
#
opnsu: .long ch$br # vertical bar
.long ch$eq # equal
.long ch$nm # number
.long ch$pc # percent
.long ch$sl # slash
.long ch$ex # exclamation
#
# ADDRESS CONST CONTAINING PROFILE TABLE ENTRY SIZE
#
pfi2a: .long pf$i2
#
# PROFILER MESSAGE STRINGS
#
pfms1: .long b$scl
.long 15
.ascii "PROGRAM PROFILE"
.align 2
pfms2: .long b$scl
.long 42
.ascii "STMT NUMBER OF -- EXECUTION TIME --"
.align 2
pfms3: .long b$scl
.long 47
.ascii "NUMBER EXECUTIONS TOTAL(MSEC) PER EXCN(MCSEC)"
.align 2
#
#
# REAL CONSTANTS FOR GENERAL USE. NOTE THAT THE CONSTANTS
# STARTING AT REAV1 FORM A POWERS OF TEN TABLE (GTSTG)
#
reav0: .float 0f0.0 # 0.0
reap1: .float 0f0.1 # 0.1
reap5: .float 0f0.5 # 0.5
reav1: .float 0f1.0 # 10**0
reavt: .float 0f1.0e+1 # 10**1
.float 0f1.0e+2 # 10**2
.float 0f1.0e+3 # 10**3
.float 0f1.0e+4 # 10**4
.float 0f1.0e+5 # 10**5
.float 0f1.0e+6 # 10**6
.float 0f1.0e+7 # 10**7
.float 0f1.0e+8 # 10**8
.float 0f1.0e+9 # 10**9
reatt: .float 0f1.0e+10 # 10**10
#page
#
# STRING CONSTANTS (SCBLK FORMAT) FOR DTYPE PROCEDURE
#
scarr: .long b$scl # array
.long 5
.ascii "ARRAY"
.align 2
#
scbuf: .long b$scl # buffer
.long 6
.ascii "BUFFER"
.align 2
#
sccod: .long b$scl # code
.long 4
.ascii "CODE"
.align 2
#
scexp: .long b$scl # expression
.long 10
.ascii "EXPRESSION"
.align 2
#
scext: .long b$scl # external
.long 8
.ascii "EXTERNAL"
.align 2
#
scint: .long b$scl # integer
.long 7
.ascii "INTEGER"
.align 2
#
scnam: .long b$scl # name
.long 4
.ascii "NAME"
.align 2
#
scnum: .long b$scl # numeric
.long 7
.ascii "NUMERIC"
.align 2
#
scpat: .long b$scl # pattern
.long 7
.ascii "PATTERN"
.align 2
#
screa: .long b$scl # real
.long 4
.ascii "REAL"
.align 2
#
scstr: .long b$scl # string
.long 6
.ascii "STRING"
.align 2
#
sctab: .long b$scl # table
.long 5
.ascii "TABLE"
.align 2
#page
#
# STRING CONSTANTS (SCBLK FORMAT) FOR KVRTN (SEE RETRN)
#
scfrt: .long b$scl # freturn
.long 7
.ascii "FRETURN"
.align 2
#
scnrt: .long b$scl # nreturn
.long 7
.ascii "NRETURN"
.align 2
#
scrtn: .long b$scl # return
.long 6
.ascii "RETURN"
.align 2
#
# DATATYPE NAME TABLE FOR DTYPE PROCEDURE. THE ORDER OF
# THESE ENTRIES IS TIED TO THE B$XXX DEFINITIONS FOR BLOCKS
#
scnmt: .long scarr # arblk array
.long scbuf # bfblk buffer
.long sccod # cdblk code
.long scexp # exblk expression
.long scint # icblk integer
.long scnam # nmblk name
.long scpat # p0blk pattern
.long scpat # p1blk pattern
.long scpat # p2blk pattern
.long screa # rcblk real
.long scstr # scblk string
.long scexp # seblk expression
.long sctab # tbblk table
.long scarr # vcblk array
.long scext # xnblk external
.long scext # xrblk external
#
# STRING CONSTANT FOR REAL ZERO
#
scre0: .long b$scl
.long 2
.ascii "0."
.align 2
#page
#
# USED TO RE-INITIALISE KVSTL
#
stlim: .long 50000 # default statement limit
#
# DUMMY FUNCTION BLOCK USED FOR UNDEFINED FUNCTIONS
#
stndf: .long o$fun # ptr to undefined function err call
.long 0 # dummy fargs count for call circuit
#
# DUMMY CODE BLOCK USED FOR UNDEFINED LABELS
#
stndl: .long l$und # code ptr points to undefined lbl
#
# DUMMY OPERATOR BLOCK USED FOR UNDEFINED OPERATORS
#
stndo: .long o$oun # ptr to undefined operator err call
.long 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: .long b$vrl # vrget
.long b$vrs # vrsto
.long nulls # vrval
.long b$vrg # vrtra
.long stndl # vrlbl
.long stndf # vrfnc
.long 0 # vrnxt
#page
#
# MESSAGES USED IN END OF RUN PROCESSING (STOPR)
#
stpm1: .long b$scl # in statement
.long 12
.ascii "IN STATEMENT"
.align 2
#
stpm2: .long b$scl
.long 14
.ascii "STMTS EXECUTED"
.align 2
#
stpm3: .long b$scl
.long 13
.ascii "RUN TIME-MSEC"
.align 2
#
stpm4: .long b$scl
.long 12
.ascii "MCSEC / STMT"
.align 2
#
stpm5: .long b$scl
.long 13
.ascii "REGENERATIONS"
.align 2
#
# CHARS FOR /TU/ ENDING CODE
#
strtu: .ascii "TU"
.align 2
#
# TABLE USED BY CONVERT FUNCTION TO CHECK DATATYPE NAME
# THE ENTRIES ARE ORDERED TO CORRESPOND TO BRANCH TABLE
# IN S$CNV
#
svctb: .long scstr # string
.long scint # integer
.long scnam # name
.long scpat # pattern
.long scarr # array
.long sctab # table
.long scexp # expression
.long sccod # code
.long scnum # numeric
.long screa # real
.long scbuf # buffer
.long 0 # zero marks end of list
#page
#
# MESSAGES (SCBLK FORMAT) USED BY TRACE PROCEDURES
#
#
tmasb: .long b$scl # asterisks for trace statement no
.long 13
.ascii "************ "
.align 2
#
tmbeb: .long b$scl # blank-equal-blank
.long 3
.ascii " = "
.align 2
#
# DUMMY TRBLK FOR EXPRESSION VARIABLE
#
trbev: .long b$trt # dummy trblk
#
# DUMMY TRBLK FOR KEYWORD VARIABLE
#
trbkv: .long b$trt # dummy trblk
#
# DUMMY CODE BLOCK TO RETURN CONTROL TO TRXEQ PROCEDURE
#
trxdr: .long o$txr # block points to return routine
trxdc: .long trxdr # pointer to block
#page
#
# 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: .long svfpr # eq
.long 2
.ascii "EQ"
.align 2
.long s$eqf
.long 2
#
v$gef: .long svfpr # ge
.long 2
.ascii "GE"
.align 2
.long s$gef
.long 2
#
v$gtf: .long svfpr # gt
.long 2
.ascii "GT"
.align 2
.long s$gtf
.long 2
#
v$lef: .long svfpr # le
.long 2
.ascii "LE"
.align 2
.long s$lef
.long 2
#
v$ltf: .long svfpr # lt
.long 2
.ascii "LT"
.align 2
.long s$ltf
.long 2
#
v$nef: .long svfpr # ne
.long 2
.ascii "NE"
.align 2
.long s$nef
.long 2
#
v$any: .long svfnp # any
.long 3
.ascii "ANY"
.align 2
.long s$any
.long 1
#
v$arb: .long svkvc # arb
.long 3
.ascii "ARB"
.align 2
.long k$arb
.long ndarb
#page
#
# STANDARD VARIABLE BLOCKS (CONTINUED)
#
v$arg: .long svfnn # arg
.long 3
.ascii "ARG"
.align 2
.long s$arg
.long 2
#
v$bal: .long svkvc # bal
.long 3
.ascii "BAL"
.align 2
.long k$bal
.long ndbal
#
v$end: .long svlbl # end
.long 3
.ascii "END"
.align 2
.long l$end
#
v$len: .long svfnp # len
.long 3
.ascii "LEN"
.align 2
.long s$len
.long 1
#
v$leq: .long svfpr # leq
.long 3
.ascii "LEQ"
.align 2
.long s$leq
.long 2
#
v$lge: .long svfpr # lge
.long 3
.ascii "LGE"
.align 2
.long s$lge
.long 2
#
v$lgt: .long svfpr # lgt
.long 3
.ascii "LGT"
.align 2
.long s$lgt
.long 2
#
v$lle: .long svfpr # lle
.long 3
.ascii "LLE"
.align 2
.long s$lle
.long 2
#page
#
# STANDARD VARIABLE BLOCKS (CONTINUED)
#
v$llt: .long svfpr # llt
.long 3
.ascii "LLT"
.align 2
.long s$llt
.long 2
#
v$lne: .long svfpr # lne
.long 3
.ascii "LNE"
.align 2
.long s$lne
.long 2
#
v$pos: .long svfnp # pos
.long 3
.ascii "POS"
.align 2
.long s$pos
.long 1
#
v$rem: .long svkvc # rem
.long 3
.ascii "REM"
.align 2
.long k$rem
.long ndrem
#
v$set: .long svfnn # set
.long 3
.ascii "SET"
.align 2
.long s$set
.long 3
#
v$tab: .long svfnp # tab
.long 3
.ascii "TAB"
.align 2
.long s$tab
.long 1
#
v$cas: .long svknm # case
.long 4
.ascii "CASE"
.align 2
.long k$cas
#
v$chr: .long svfnp # char
.long 4
.ascii "CHAR"
.align 2
.long s$chr
.long 1
#
v$cod: .long svfnk # code
.long 4
.ascii "CODE"
.align 2
.long k$cod
.long s$cod
.long 1
#
v$cop: .long svfnn # copy
.long 4
.ascii "COPY"
.align 2
.long s$cop
.long 1
#page
#
# STANDARD VARIABLE BLOCKS (CONTINUED)
#
v$dat: .long svfnn # data
.long 4
.ascii "DATA"
.align 2
.long s$dat
.long 1
#
v$dte: .long svfnn # date
.long 4
.ascii "DATE"
.align 2
.long s$dte
.long 0
#
v$dmp: .long svfnk # dump
.long 4
.ascii "DUMP"
.align 2
.long k$dmp
.long s$dmp
.long 1
#
v$dup: .long svfnn # dupl
.long 4
.ascii "DUPL"
.align 2
.long s$dup
.long 2
#
v$evl: .long svfnn # eval
.long 4
.ascii "EVAL"
.align 2
.long s$evl
.long 1
#
v$ext: .long svfnn # exit
.long 4
.ascii "EXIT"
.align 2
.long s$ext
.long 1
#
v$fal: .long svkvc # fail
.long 4
.ascii "FAIL"
.align 2
.long k$fal
.long ndfal
#
v$hst: .long svfnn # host
.long 4
.ascii "HOST"
.align 2
.long s$hst
.long 3
#page
#
# STANDARD VARIABLE BLOCKS (CONTINUED)
#
v$itm: .long svfnf # item
.long 4
.ascii "ITEM"
.align 2
.long s$itm
.long 999
#
v$lod: .long svfnn # load
.long 4
.ascii "LOAD"
.align 2
.long s$lod
.long 2
#
v$lpd: .long svfnp # lpad
.long 4
.ascii "LPAD"
.align 2
.long s$lpd
.long 3
#
v$rpd: .long svfnp # rpad
.long 4
.ascii "RPAD"
.align 2
.long s$rpd
.long 3
#
v$rps: .long svfnp # rpos
.long 4
.ascii "RPOS"
.align 2
.long s$rps
.long 1
#
v$rtb: .long svfnp # rtab
.long 4
.ascii "RTAB"
.align 2
.long s$rtb
.long 1
#
v$si$: .long svfnp # size
.long 4
.ascii "SIZE"
.align 2
.long s$si$
.long 1
#
#
v$srt: .long svfnn # sort
.long 4
.ascii "SORT"
.align 2
.long s$srt
.long 2
v$spn: .long svfnp # span
.long 4
.ascii "SPAN"
.align 2
.long s$spn
.long 1
#page
#
# STANDARD VARIABLE BLOCKS (CONTINUED)
#
v$stn: .long svknm # stno
.long 4
.ascii "STNO"
.align 2
.long k$stn
#
v$tim: .long svfnn # time
.long 4
.ascii "TIME"
.align 2
.long s$tim
.long 0
#
v$trm: .long svfnk # trim
.long 4
.ascii "TRIM"
.align 2
.long k$trm
.long s$trm
.long 1
#
v$abe: .long svknm # abend
.long 5
.ascii "ABEND"
.align 2
.long k$abe
#
v$abo: .long svkvl # abort
.long 5
.ascii "ABORT"
.align 2
.long k$abo
.long l$abo
.long ndabo
#
v$app: .long svfnf # apply
.long 5
.ascii "APPLY"
.align 2
.long s$app
.long 999
#
v$abn: .long svfnp # arbno
.long 5
.ascii "ARBNO"
.align 2
.long s$abn
.long 1
#
v$arr: .long svfnn # array
.long 5
.ascii "ARRAY"
.align 2
.long s$arr
.long 2
#page
#
# STANDARD VARIABLE BLOCKS (CONTINUED)
#
v$brk: .long svfnp # break
.long 5
.ascii "BREAK"
.align 2
.long s$brk
.long 1
#
v$clr: .long svfnn # clear
.long 5
.ascii "CLEAR"
.align 2
.long s$clr
.long 1
#
v$ejc: .long svfnn # eject
.long 5
.ascii "EJECT"
.align 2
.long s$ejc
.long 1
#
v$fen: .long svfpk # fence
.long 5
.ascii "FENCE"
.align 2
.long k$fen
.long s$fnc
.long 1
.long ndfen
#
v$fld: .long svfnn # field
.long 5
.ascii "FIELD"
.align 2
.long s$fld
.long 2
#
v$idn: .long svfpr # ident
.long 5
.ascii "IDENT"
.align 2
.long s$idn
.long 2
#
v$inp: .long svfnk # input
.long 5
.ascii "INPUT"
.align 2
.long k$inp
.long s$inp
.long 3
#
v$loc: .long svfnn # local
.long 5
.ascii "LOCAL"
.align 2
.long s$loc
.long 2
#page
#
# STANDARD VARIABLE BLOCKS (CONTINUED)
#
v$ops: .long svfnn # opsyn
.long 5
.ascii "OPSYN"
.align 2
.long s$ops
.long 3
#
v$rmd: .long svfnp # remdr
.long 5
.ascii "REMDR"
.align 2
.long s$rmd
.long 2
#
v$rsr: .long svfnn # rsort
.long 5
.ascii "RSORT"
.align 2
.long s$rsr
.long 2
#
v$tbl: .long svfnn # table
.long 5
.ascii "TABLE"
.align 2
.long s$tbl
.long 3
#
v$tra: .long svfnk # trace
.long 5
.ascii "TRACE"
.align 2
.long k$tra
.long s$tra
.long 4
#
v$anc: .long svknm # anchor
.long 6
.ascii "ANCHOR"
.align 2
.long k$anc
#
v$apn: .long svfnn
.long 6
.ascii "APPEND"
.align 2
.long s$apn
.long 2
#
v$bkx: .long svfnp # breakx
.long 6
.ascii "BREAKX"
.align 2
.long s$bkx
.long 1
#
v$buf: .long svfnn # buffer
.long 6
.ascii "BUFFER"
.align 2
.long s$buf
.long 2
#
v$def: .long svfnn # define
.long 6
.ascii "DEFINE"
.align 2
.long s$def
.long 2
#
v$det: .long svfnn # detach
.long 6
.ascii "DETACH"
.align 2
.long s$det
.long 1
#page
#
# STANDARD VARIABLE BLOCKS (CONTINUED)
#
v$dif: .long svfpr # differ
.long 6
.ascii "DIFFER"
.align 2
.long s$dif
.long 2
#
v$ftr: .long svknm # ftrace
.long 6
.ascii "FTRACE"
.align 2
.long k$ftr
#
v$ins: .long svfnn # insert
.long 6
.ascii "INSERT"
.align 2
.long s$ins
.long 4
#
v$lst: .long svknm # lastno
.long 6
.ascii "LASTNO"
.align 2
.long k$lst
#
v$nay: .long svfnp # notany
.long 6
.ascii "NOTANY"
.align 2
.long s$nay
.long 1
#
v$oup: .long svfnk # output
.long 6
.ascii "OUTPUT"
.align 2
.long k$oup
.long s$oup
.long 3
#
v$ret: .long svlbl # return
.long 6
.ascii "RETURN"
.align 2
.long l$rtn
#
v$rew: .long svfnn # rewind
.long 6
.ascii "REWIND"
.align 2
.long s$rew
.long 1
#
v$stt: .long svfnn # stoptr
.long 6
.ascii "STOPTR"
.align 2
.long s$stt
.long 2
#page
#
# STANDARD VARIABLE BLOCKS (CONTINUED)
#
v$sub: .long svfnn # substr
.long 6
.ascii "SUBSTR"
.align 2
.long s$sub
.long 3
#
v$unl: .long svfnn # unload
.long 6
.ascii "UNLOAD"
.align 2
.long s$unl
.long 1
#
v$col: .long svfnn # collect
.long 7
.ascii "COLLECT"
.align 2
.long s$col
.long 1
#
v$cnv: .long svfnn # convert
.long 7
.ascii "CONVERT"
.align 2
.long s$cnv
.long 2
#
v$enf: .long svfnn # endfile
.long 7
.ascii "ENDFILE"
.align 2
.long s$enf
.long 1
#
v$etx: .long svknm # errtext
.long 7
.ascii "ERRTEXT"
.align 2
.long k$etx
#
v$ert: .long svknm # errtype
.long 7
.ascii "ERRTYPE"
.align 2
.long k$ert
#
v$frt: .long svlbl # freturn
.long 7
.ascii "FRETURN"
.align 2
.long l$frt
#
v$int: .long svfpr # integer
.long 7
.ascii "INTEGER"
.align 2
.long s$int
.long 1
#
v$nrt: .long svlbl # nreturn
.long 7
.ascii "NRETURN"
.align 2
.long l$nrt
#page
#
# STANDARD VARIABLE BLOCKS (CONTINUED)
#
#
v$pfl: .long svknm # profile
.long 7
.ascii "PROFILE"
.align 2
.long k$pfl
#
v$rpl: .long svfnp # replace
.long 7
.ascii "REPLACE"
.align 2
.long s$rpl
.long 3
#
v$rvs: .long svfnp # reverse
.long 7
.ascii "REVERSE"
.align 2
.long s$rvs
.long 1
#
v$rtn: .long svknm # rtntype
.long 7
.ascii "RTNTYPE"
.align 2
.long k$rtn
#
v$stx: .long svfnn # setexit
.long 7
.ascii "SETEXIT"
.align 2
.long s$stx
.long 1
#
v$stc: .long svknm # stcount
.long 7
.ascii "STCOUNT"
.align 2
.long k$stc
#
v$stl: .long svknm # stlimit
.long 7
.ascii "STLIMIT"
.align 2
.long k$stl
#
v$suc: .long svkvc # succeed
.long 7
.ascii "SUCCEED"
.align 2
.long k$suc
.long ndsuc
#
v$alp: .long svkwc # alphabet
.long 8
.ascii "ALPHABET"
.align 2
.long k$alp
#
v$cnt: .long svlbl # continue
.long 8
.ascii "CONTINUE"
.align 2
.long l$cnt
#page
#
# STANDARD VARIABLE BLOCKS (CONTINUED)
#
v$dtp: .long svfnp # datatype
.long 8
.ascii "DATATYPE"
.align 2
.long s$dtp
.long 1
#
v$erl: .long svknm # errlimit
.long 8
.ascii "ERRLIMIT"
.align 2
.long k$erl
#
v$fnc: .long svknm # fnclevel
.long 8
.ascii "FNCLEVEL"
.align 2
.long k$fnc
#
v$mxl: .long svknm # maxlngth
.long 8
.ascii "MAXLNGTH"
.align 2
.long k$mxl
#
v$ter: .long 0 # terminal
.long 8
.ascii "TERMINAL"
.align 2
.long 0
#
v$pro: .long svfnn # prototype
.long 9
.ascii "PROTOTYPE"
.align 2
.long s$pro
.long 1
#
.long 0 # dummy entry to end list
.long 10 # length gt 9 (prototype)
#page
#
# LIST OF SVBLK POINTERS FOR KEYWORDS TO BE DUMPED. THE
# LIST IS IN THE ORDER WHICH APPEARS ON THE DUMP OUTPUT.
#
vdmkw: .long v$anc # anchor
.long v$cas # ccase
.long v$cod # code
.long v$dmp # dump
.long v$erl # errlimit
.long v$etx # errtext
.long v$ert # errtype
.long v$fnc # fnclevel
.long v$ftr # ftrace
.long v$inp # input
.long v$lst # lastno
.long v$mxl # maxlength
.long v$oup # output
.long v$pfl # profile
.long v$rtn # rtntype
.long v$stc # stcount
.long v$stl # stlimit
.long v$stn # stno
.long v$tra # trace
.long v$trm # trim
.long 0 # end of list
#
# TABLE USED BY GTNVR TO SEARCH SVBLK LISTS
#
vsrch: .long 0 # dummy entry to get proper indexing
.long v$eqf # start of 1 char variables (none)
.long v$eqf # start of 2 char variables
.long v$any # start of 3 char variables
.long v$cas # start of 4 char variables
.long v$abe # start of 5 char variables
.long v$anc # start of 6 char variables
.long v$col # start of 7 char variables
.long v$alp # start of 8 char variables
.long v$pro # start of 9 char variables
#title 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.
#
.data 1
#sec # start of working storage section
#page
#
# THIS AREA IS NOT CLEARED BY INITIAL CODE
#
cmlab: .long b$scl # string used to check label legality
.long 2
.ascii " "
.align 2
#
# LABEL TO MARK START OF WORK AREA
#
aaaaa: .long 0
#
# WORK AREAS FOR ALLOC PROCEDURE
#
aldyn: .long 0 # amount of dynamic store
alfsf: .long 0 # factor in free store pcntage check
allia: .long 0 # dump ia
allsv: .long 0 # save wb in alloc
#
# WORK AREAS FOR ALOST PROCEDURE
#
alsta: .long 0 # save wa in alost
#
# SAVE AREAS FOR ARRAY FUNCTION (S$ARR)
#
arcdm: .long 0 # count dimensions
arnel: .long 0 # count elements
arptr: .long 0 # offset ptr into arblk
arsvl: .long 0 # save integer low bound
#page
# WORK AREAS FOR ARREF ROUTINE
#
arfsi: .long 0 # save current evolving subscript
arfxs: .long 0 # save base stack pointer
#
# WORK AREAS FOR B$EFC BLOCK ROUTINE
#
befof: .long 0 # save offset ptr into efblk
#
# WORK AREAS FOR B$PFC BLOCK ROUTINE
#
bpfpf: .long 0 # save pfblk pointer
bpfsv: .long 0 # save old function value
bpfxt: .long 0 # pointer to stacked arguments
#
# SAVE AREAS FOR COLLECT FUNCTION (S$COL)
#
clsvi: .long 0 # save integer argument
#
# GLOBAL VALUES FOR CMPIL PROCEDURE
#
cmerc: .long 0 # count of initial compile errors
cmpxs: .long 0 # save stack ptr in case of errors
cmpsn: .long 1 # number of next statement to compile
cmpss: .long 0 # save subroutine stack ptr
#
# WORK AREA FOR CNCRD
#
cnscc: .long 0 # pointer to control card string
cnswc: .long 0 # word count
cnr$t: .long 0 # pointer to r$ttl or r$stl
cnttl: .long 0 # flag for -title, -stitl
#
# WORK AREAS FOR CONVERT FUNCTION (S$CNV)
#
cnvtp: .long 0 # save ptr into scvtb
#
# FLAG FOR SUPPRESSION OF COMPILATION STATISTICS.
#
cpsts: .long 0 # suppress comp. stats if non zero
#
# GLOBAL VALUES FOR CONTROL CARD SWITCHES
#
cswdb: .long 0 # 0/1 for -single/-double
cswer: .long 0 # 0/1 for -errors/-noerrors
cswex: .long 0 # 0/1 for -execute/-noexecute
cswfl: .long 1 # 0/1 for -nofail/-fail
cswin: .long iniln # xxx for -inxxx
cswls: .long 1 # 0/1 for -nolist/-list
cswno: .long 0 # 0/1 for -optimise/-noopt
cswpr: .long 0 # 0/1 for -noprint/-print
#
# GLOBAL LOCATION USED BY PATST PROCEDURE
#
ctmsk: .long 0 # last bit position used in r$ctp
curid: .long 0 # current id value
#page
#
# GLOBAL VALUE FOR CDWRD PROCEDURE
#
cwcof: .long 0 # next word offset in current ccblk
#
# WORK AREAS FOR DATA FUNCTION (S$DAT)
#
datdv: .long 0 # save vrblk ptr for datatype name
datxs: .long 0 # save initial stack pointer
#
# WORK AREAS FOR DEFINE FUNCTION (S$DEF)
#
deflb: .long 0 # save vrblk ptr for label
defna: .long 0 # count function arguments
defvr: .long 0 # save vrblk ptr for function name
defxs: .long 0 # save initial stack pointer
#
# WORK AREAS FOR DUMPR PROCEDURE
#
dmarg: .long 0 # dump argument
dmpkb: .long b$kvt # dummy kvblk for use in dumpr
dmpkt: .long trbkv # kvvar trblk pointer
dmpkn: .long 0 # keyword number (must follow dmpkb)
dmpsa: .long 0 # preserve wa over prtvl call
dmpsv: .long 0 # general scratch save
dmvch: .long 0 # chain pointer for variable blocks
dmpch: .long 0 # save sorted vrblk chain pointer
#
# GLOBAL LOCATIONS FOR DYNAMIC STORAGE POINTERS
#
dnamb: .long 0 # start of dynamic area
dnamp: .long 0 # next available loc in dynamic area
dname: .long 0 # end of available dynamic area
#
# WORK AREA FOR DTACH
#
dtcnb: .long 0 # name base
dtcnm: .long 0 # name ptr
#
# WORK AREAS FOR DUPL FUNCTION (S$DUP)
#
dupsi: .long 0 # store integer string length
#
# WORK AREA FOR ENDFILE (S$ENF)
#
enfch: .long 0 # for iochn chain head
#
# WORK AREA FOR ERROR PROCESSING.
#
erich: .long 0 # copy error reports to int.chan if 1
erlst: .long 0 # for listr when errors go to int.ch.
errft: .long 0 # fatal error flag
errsp: .long 0 # error suppression flag
#page
#
# DUMP AREA FOR ERTEX
#
ertwa: .long 0 # save wa
ertwb: .long 0 # save wb
#
# GLOBAL VALUES FOR EVALI
#
evlin: .long p$len # dummy pattern block pcode
evlis: .long 0 # pointer to subsequent node
evliv: .long 0 # value of parameter
# WORK AREA FOR EXPAN
#
expsv: .long 0 # save op dope vector pointer
#
# FLAG FOR SUPPRESSION OF EXECUTION STATS
#
exsts: .long 0 # suppress exec stats if set
#
# GLOBAL VALUES FOR EXFAL AND RETURN
#
flprt: .long 0 # location of fail offset for return
flptr: .long 0 # location of failure offset on stack
#
# WORK AREAS FOR GBCOL PROCEDURE
#
gbcfl: .long 0 # garbage collector active flag
gbclm: .long 0 # pointer to last move block (pass 3)
gbcnm: .long 0 # dummy first move block
gbcns: .long 0 # rest of dummy block (follows gbcnm)
gbsva: .long 0 # save wa
gbsvb: .long 0 # save wb
gbsvc: .long 0 # save wc
#
# GLOBAL LOCATION TO COUNT GARBAGE COLLECTIONS (GBCOL)
#
gbcnt: .long 0 # count of garbage collections
#
# WORK AREAS FOR GTNVR PROCEDURE
#
gnvhe: .long 0 # ptr to end of hash chain
gnvnw: .long 0 # number of words in string name
gnvsa: .long 0 # save wa
gnvsb: .long 0 # save wb
gnvsp: .long 0 # pointer into vsrch table
gnvst: .long 0 # pointer to chars of string
#
# GLOBAL VALUE FOR GTCOD AND GTEXP
#
gtcef: .long 0 # save fail ptr in case of error
#
# WORK AREAS FOR GTINT
#
gtina: .long 0 # save wa
gtinb: .long 0 # save wb
#page
#
# WORK AREAS FOR GTNUM PROCEDURE
#
gtnnf: .long 0 # zero/nonzero for result +/-
gtnsi: .long 0 # general integer save
gtndf: .long 0 # 0/1 for dec point so far no/yes
gtnes: .long 0 # zero/nonzero exponent +/-
gtnex: .long 0 # real exponent
gtnsc: .long 0 # scale (places after point)
gtnsr: .float 0f0.0 # general real save
gtnrd: .long 0 # flag for ok real number
#
# WORK AREAS FOR GTPAT PROCEDURE
#
gtpsb: .long 0 # save wb
#
# WORK AREAS FOR GTSTG PROCEDURE
#
gtssf: .long 0 # 0/1 for result +/-
gtsvc: .long 0 # save wc
gtsvb: .long 0 # save wb
gtswk: .long 0 # ptr to work area for gtstg
gtses: .long 0 # char + or - for exponent +/-
gtsrs: .float 0f0.0 # general real save
#
# GLOBAL LOCATIONS (CONSTANTS) FOR GTSTG PROCEDURE
#
gtsrn: .float 0f0.0 # rounding factor 0.5*10**-cfp$s
gtssc: .float 0f0.0 # scaling value 10**cfp$s
#
# WORK AREAS FOR GTVAR PROCEDURE
#
gtvrc: .long 0 # save wc
#
# FLAG FOR HEADER PRINTING
#
headp: .long 0 # header printed flag
#
# GLOBAL VALUES FOR VARIABLE HASH TABLE
#
hshnb: .long 0 # number of hash buckets
hshtb: .long 0 # pointer to start of vrblk hash tabl
hshte: .long 0 # pointer past end of vrblk hash tabl
#
# WORK AREA FOR INIT
#
iniss: .long 0 # save subroutine stack ptr
initr: .long 0 # save terminal flag
#
# SAVE AREA FOR INSBF
#
insab: .long 0 # entry wa + entry wb
inssa: .long 0 # save entry wa
inssb: .long 0 # save entry wb
inssc: .long 0 # save entry wc
#
# WORK AREAS FOR IOPUT
#
ioptt: .long 0 # type of association
#page
#
# 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: .long 0 # abend
kvanc: .long 0 # anchor
kvcas: .long 0 # case
kvcod: .long 0 # code
kvdmp: .long 0 # dump
kverl: .long 0 # errlimit
kvert: .long 0 # errtype
kvftr: .long 0 # ftrace
kvinp: .long 1 # input
kvmxl: .long 5000 # maxlength
kvoup: .long 1 # output
kvpfl: .long 0 # profile
kvtra: .long 0 # trace
kvtrm: .long 0 # trim
kvfnc: .long 0 # fnclevel
kvlst: .long 0 # lastno
kvstn: .long 0 # stno
#
# GLOBAL VALUES FOR OTHER KEYWORDS
#
kvalp: .long 0 # alphabet
kvrtn: .long nulls # rtntype (scblk pointer)
kvstl: .long 50000 # stlimit
kvstc: .long 50000 # stcount (counts down from stlimit)
#
# WORK AREAS FOR LOAD FUNCTION
#
lodfn: .long 0 # pointer to vrblk for func name
lodna: .long 0 # count number of arguments
#
# GLOBAL VALUES FOR LISTR PROCEDURE
#
lstlc: .long 0 # count lines on source list page
lstnp: .long 0 # max number of lines on page
lstpf: .long 1 # set nonzero if current image listed
lstpg: .long 0 # current source list page number
lstpo: .long 0 # offset to page nnn message
lstsn: .long 0 # remember last stmnum listed
#
# MAXIMUM SIZE OF SPITBOL OBJECTS
#
mxlen: .long 0 # initialised by sysmx call
#
# EXECUTION CONTROL VARIABLE
#
noxeq: .long 0 # set non-zero to inhibit execution
#
# PROFILER GLOBAL VALUES AND WORK LOCATIONS
#
pfdmp: .long 0 # set non-0 if &profile set non-0
pffnc: .long 0 # set non-0 if funct just entered
pfstm: .long 0 # to store starting time of stmt
pfetm: .long 0 # to store ending time of stmt
pfsvw: .long 0 # to save a w-reg
pftbl: .long 0 # gets adrs of (imag) table base
pfnte: .long 0 # nr of table entries
pfste: .long 0 # gets int rep of table entry size
#
#page
#
# GLOBAL VALUES USED IN PATTERN MATCH ROUTINES
#
pmdfl: .long 0 # pattern assignment flag
pmhbs: .long 0 # history stack base pointer
pmssl: .long 0 # length of subject string in chars
#
# FLAGS USED FOR STANDARD FILE LISTING OPTIONS
#
prich: .long 0 # printer on interactive channel
prstd: .long 0 # tested by prtpg
prsto: .long 0 # standard listing option flag
#
# GLOBAL VALUE FOR PRTNM PROCEDURE
#
prnmv: .long 0 # vrblk ptr from last name search
#
# WORK AREAS FOR PRTNM PROCEDURE
#
prnsi: .long 0 # scratch integer loc
#
# WORK AREAS FOR PRTSN PROCEDURE
#
prsna: .long 0 # save wa
#
# GLOBAL VALUES FOR PRINT PROCEDURES
#
prbuf: .long 0 # ptr to print bfr in static
precl: .long 0 # extended/compact listing flag
prlen: .long 0 # length of print buffer in chars
prlnw: .long 0 # length of print buffer in words
profs: .long 0 # offset to next location in prbuf
prtef: .long 0 # endfile flag
#
# WORK AREAS FOR PRTST PROCEDURE
#
prsva: .long 0 # save wa
prsvb: .long 0 # save wb
prsvc: .long 0 # save char counter
#
# WORK AREA FOR PRTNL
#
prtsa: .long 0 # save wa
prtsb: .long 0 # save wb
#
# WORK AREA FOR PRTVL
#
prvsi: .long 0 # save idval
#
# WORK AREAS FOR PATTERN MATCH ROUTINES
#
psave: .long 0 # temporary save for current node ptr
psavc: .long 0 # save cursor in p$spn, p$str
#page
#
# AMOUNT OF MEMORY RESERVED FOR END OF EXECUTION
#
rsmem: .long 0 # reserve memory
#
# WORK AREAS FOR RETRN ROUTINE
#
rtnbp: .long 0 # to save a block pointer
rtnfv: .long 0 # new function value (result)
rtnsv: .long 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: .long 0 # start of relocatable values
r$arf: .long 0 # array block pointer for arref
r$ccb: .long 0 # ptr to ccblk being built (cdwrd)
r$cim: .long 0 # ptr to current compiler input str
r$cmp: .long 0 # copy of r$cim used in cmpil
r$cni: .long 0 # ptr to next compiler input string
r$cnt: .long 0 # cdblk pointer for setexit continue
r$cod: .long 0 # pointer to current cdblk or exblk
r$ctp: .long 0 # ptr to current ctblk for patst
r$ert: .long 0 # trblk pointer for errtype trace
r$etx: .long nulls # pointer to errtext string
r$exs: .long 0 # = save xl in expdm
r$fcb: .long 0 # fcblk chain head
r$fnc: .long 0 # trblk pointer for fnclevel trace
r$gtc: .long 0 # keep code ptr for gtcod,gtexp
r$io1: .long 0 # file arg1 for ioput
r$io2: .long 0 # file arg2 for ioput
r$iof: .long 0 # fcblk ptr or 0
r$ion: .long 0 # name base ptr
r$iop: .long 0 # predecessor block ptr for ioput
r$iot: .long 0 # trblk ptr for ioput
r$pmb: .long 0 # buffer ptr in pattern match
r$pms: .long 0 # subject string ptr in pattern match
r$ra2: .long 0 # replace second argument last time
r$ra3: .long 0 # replace third argument last time
r$rpt: .long 0 # ptr to ctblk replace table last usd
r$scp: .long 0 # save pointer from last scane call
r$sxl: .long 0 # preserve xl in sortc
r$sxr: .long 0 # preserve xr in sorta/sortc
r$stc: .long 0 # trblk pointer for stcount trace
r$stl: .long 0 # source listing sub-title
r$sxc: .long 0 # code (cdblk) ptr for setexit trap
r$ttl: .long nulls # source listing title
r$xsc: .long 0 # string pointer for xscan
#page
#
# THE REMAINING POINTERS IN THIS LIST ARE USED TO POINT
# TO FUNCTION BLOCKS FOR NORMALLY UNDEFINED OPERATORS.
#
r$uba: .long stndo # binary at
r$ubm: .long stndo # binary ampersand
r$ubn: .long stndo # binary number sign
r$ubp: .long stndo # binary percent
r$ubt: .long stndo # binary not
r$uub: .long stndo # unary vertical bar
r$uue: .long stndo # unary equal
r$uun: .long stndo # unary number sign
r$uup: .long stndo # unary percent
r$uus: .long stndo # unary slash
r$uux: .long stndo # unary exclamation
r$yyy: .long 0 # last relocatable location
#
# WORK AREAS FOR SUBSTR FUNCTION (S$SUB)
#
sbssv: .long 0 # save third argument
#
# GLOBAL LOCATIONS USED IN SCAN PROCEDURE
#
scnbl: .long 0 # set non-zero if scanned past blanks
scncc: .long 0 # non-zero to scan control card name
scngo: .long 0 # set non-zero to scan goto field
scnil: .long 0 # length of current input image
scnpt: .long 0 # pointer to next location in r$cim
scnrs: .long 0 # set non-zero to signal rescan
scntp: .long 0 # save syntax type from last call
#
# WORK AREAS FOR SCAN PROCEDURE
#
scnsa: .long 0 # save wa
scnsb: .long 0 # save wb
scnsc: .long 0 # save wc
scnse: .long 0 # start of current element
scnof: .long 0 # save offset
#page
#
# WORK AREA USED BY SORTA, SORTC, SORTF, SORTH
#
srtdf: .long 0 # datatype field name
srtfd: .long 0 # found dfblk address
srtff: .long 0 # found field name
srtfo: .long 0 # offset to field name
srtnr: .long 0 # number of rows
srtof: .long 0 # offset within row to sort key
srtrt: .long 0 # root offset
srts1: .long 0 # save offset 1
srts2: .long 0 # save offset 2
srtsc: .long 0 # save wc
srtsf: .long 0 # sort array first row offset
srtsn: .long 0 # save n
srtso: .long 0 # offset to a(0)
srtsr: .long 0 # 0 , non-zero for sort, rsort
srtst: .long 0 # stride from one row to next
srtwc: .long 0 # dump wc
#
# GLOBAL VALUE FOR INDICATING STAGE (SEE ERROR SECTION)
#
stage: .long 0 # initial value = initial compile
#
# GLOBAL VALUES DEFINING EXTENT OF STATIC AREA (ALOST)
#
statb: .long 0 # start of static area
state: .long 0 # end of static area
#page
#
# GLOBAL STACK POINTER
#
stbas: .long 0 # pointer past stack base
#
# WORK AREAS FOR STOPR ROUTINE
#
stpsi: .long 0 # save value of stcount
stpti: .long 0 # save time elapsed
#
# GLOBAL VALUES FOR SETEXIT FUNCTION (S$STX)
#
stxof: .long 0 # failure offset
stxvr: .long nulls # vrblk pointer or null
#
# WORK AREAS FOR TFIND PROCEDURE
#
tfnsi: .long 0 # number of headers
#
# GLOBAL VALUE FOR TIME KEEPING
#
timsx: .long 0 # time at start of execution
timup: .long 0 # set when time up occurs
#
# WORK AREAS FOR XSCAN PROCEDURE
#
xscrt: .long 0 # save return code
xscwb: .long 0 # save register wb
#
# GLOBAL VALUES FOR XSCAN AND XSCNI PROCEDURES
#
xsofs: .long 0 # offset to current location in r$xsc
#
# LABEL TO MARK END OF WORK AREA
#
yyyyy: .long 0
#title 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
#
.text 0
.globl sec04
sec04:
#sec # start of program section
jsb systm # initialise timer
#
# INITIALISE WORK AREA (ESSENTIAL FOR BATCHED RUNS)
#
movl r9,r7 # preserve xr
movl $yyyyy,r6 # point to end of work area
subl2 $aaaaa,r6 # get length of work area
ashl $-2,r6,r6 # convert to words
# count for loop
movl $aaaaa,r9 # set up index register
#
# CLEAR WORK SPACE
#
ini01: clrl (r9)+ # clear a word
sobgtr r6,ini01 # loop till done
movl $stndo,r6 # undefined operators pointer
movl $r$yyy,r8 # point to table end
subl2 $r$uba,r8 # length of undef. operators table
ashl $-2,r8,r8 # convert to words
# loop counter
movl $r$uba,r9 # set up xr
#
# SET CORRECT VALUE INTO UNDEFINED OPERATORS TABLE
#
ini02: movl r6,(r9)+ # store value
sobgtr r8,ini02 # loop till all done
movl $num01,r6 # get a 1
movl r6,cmpsn # statement no
movl r6,cswfl # nofail
movl r6,cswls # list
movl r6,kvinp # input
movl r6,kvoup # output
movl r6,lstpf # nothing for listr yet
movl $iniln,r6 # input image length
movl r6,cswin # -in72
movl $b$kvt,dmpkb # dump
movl $trbkv,dmpkt # dump
movl $p$len,evlin # eval
#page
movl $nulls,r6 # get nullstring pointer
movl r6,kvrtn # return
movl r6,r$etx # errtext
movl r6,r$ttl # title for listing
movl r6,stxvr # setexit
movl r5,timsx # store time in correct place
movl stlim,r5 # get default stlimit
movl r5,kvstl # statement limit
movl r5,kvstc # statement count
movl r7,statb # store start adrs of static
movl $4*e$srs,rsmem # reserve memory
movl sp,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.
#
movl intvh,r5 # get 100
divl2 alfsp,r5 # form 100 / alfsp
movl r5,alfsf # store the factor
#
# INITIALIZE VALUES FOR REAL CONVERSION ROUTINE
#
movl $cfp$s,r7 # load counter for significant digits
movf reav1,r2 # load 1.0
#
# LOOP TO COMPUTE 10**(MAX NUMBER SIGNIFICANT DIGITS)
#
ini03: mulf2 reavt,r2 # * 10.0
sobgtr r7,ini03 # loop till done
movf r2,gtssc # store 10**(max sig digits)
movf reap5,r2 # load 0.5
divf2 gtssc,r2 # compute 0.5*10**(max sig digits)
movf r2,gtsrn # store as rounding bias
clrl r8 # set to read parameters
jsb prpar # read them
#page
#
# NOW COMPUTE STARTING ADDRESS FOR DYNAMIC STORE AND IF
# NECESSARY REQUEST MORE MEMORY.
#
subl2 $4*e$srs,r10 # allow for reserve memory
movl prlen,r6 # get print buffer length
addl2 $cfp$a,r6 # add no. of chars in alphabet
addl2 $nstmx,r6 # add chars for gtstg bfr
movab 3+(4*8)(r6),r6 # convert to bytes, allowing a margin
bicl2 $3,r6
movl statb,r9 # point to static base
addl2 r6,r9 # increment for above buffers
addl2 $4*e$hnb,r9 # increment for hash table
addl2 $4*e$sts,r9 # bump for initial static block
jsb sysmx # get mxlen
movl r6,kvmxl # provisionally store as maxlngth
movl r6,mxlen # and as mxlen
cmpl r9,r6 # skip if static hi exceeds mxlen
bgtru ini06
movl r6,r9 # use mxlen instead
addl2 $4,r9 # make bigger than mxlen
#
# HERE TO STORE VALUES WHICH MARK INITIAL DIVISION
# OF DATA AREA INTO STATIC AND DYNAMIC
#
ini06: movl r9,dnamb # dynamic base adrs
movl r9,dnamp # dynamic ptr
tstl r6 # skip if non-zero mxlen
bnequ ini07
subl2 $4,r9 # point a word in front
movl r9,kvmxl # use as maxlngth
movl r9,mxlen # and as mxlen
#page
#
# LOOP HERE IF NECESSARY TILL ENOUGH MEMORY OBTAINED
# SO THAT DNAME IS ABOVE DNAMB
#
ini07: movl r10,dname # store dynamic end address
cmpl dnamb,r10 # skip if high enough
blssu ini09
jsb sysmm # request more memory
moval 0[r9],r9 # get as baus (sgd05)
addl2 r9,r10 # bump by amount obtained
tstl r9 # try again
bnequ ini07
movl $endmo,r9 # point to failure message
movl endml,r6 # message length
jsb syspr # print it (prtst not yet usable)
.long invalid$ # should not fail
jsb sysej # pack up (stopr not yet usable)
#
# INITIALISE PRINT BUFFER WITH BLANK WORDS
#
ini09: movl prlen,r8 # no. of chars in print bfr
movl statb,r9 # point to static again
movl r9,prbuf # print bfr is put at static start
movl $b$scl,(r9)+ # store string type code
movl r8,(r9)+ # and string length
movab 3+(4*0)(r8),r8 # get number of words in buffer
ashl $-2,r8,r8
movl r8,prlnw # store for buffer clear
# words to clear
#
# LOOP TO CLEAR BUFFER
#
ini10: movl nullw,(r9)+ # store blank
sobgtr r8,ini10 # loop
#
# INITIALIZE NUMBER OF HASH HEADERS
#
movl $e$hnb,r6 # get number of hash headers
movl r6,r5 # convert to integer
movl r5,hshnb # store for use by gtnvr procedure
# counter for clearing hash table
movl r9,hshtb # pointer to hash table
#
# LOOP TO CLEAR HASH TABLE
#
ini11: clrl (r9)+ # blank a word
sobgtr r6,ini11 # loop
movl r9,hshte # end of hash table adrs is kept
#
# ALLOCATE WORK AREA FOR GTSTG CONVERSION PROCEDURE
#
movl $nstmx,r6 # get max num chars in output number
movab 3+(4*scsi$)(r6),r6 # no of bytes needed
bicl2 $3,r6
movl r9,gtswk # store bfr adrs
addl2 r6,r9 # bump for work bfr
#page
#
# BUILD ALPHABET STRING FOR ALPHABET KEYWORD AND REPLACE
#
movl r9,kvalp # save alphabet pointer
movl $b$scl,(r9) # string blk type
movl $cfp$a,r8 # no of chars in alphabet
movl r8,4*sclen(r9) # store as string length
movl r8,r7 # copy char count
movab 3+(4*scsi$)(r7),r7 # no. of bytes needed
bicl2 $3,r7
addl2 r9,r7 # current end address for static
movl r7,state # store static end adrs
# loop counter
movab cfp$f(r9),r9 # point to chars of string
clrl r7 # set initial character value
#
# LOOP TO ENTER CHARACTER CODES IN ORDER
#
ini12: movb r7,(r9)+ # store next code
incl r7 # bump code value
sobgtr r8,ini12 # loop till all stored
#csc r9 # complete store characters
#
# INITIALIZE VARIABLE BLOCKS FOR INPUT AND OUTPUT
#
movl $v$inp,r10 # point to string /input/
movl $trtin,r7 # trblk type for input
jsb inout # perform input association
movl $v$oup,r10 # point to string /output/
movl $trtou,r7 # trblk type for output
jsb inout # perform output association
movl initr,r8 # terminal flag
beqlu ini13 # skip if no terminal
jsb prpar # associate terminal
#page
#
# CHECK FOR EXPIRY DATE
#
ini13: jsb sysdc # call date check
movl sp,flptr # in case stack overflows in compiler
#
# NOW COMPILE SOURCE INPUT CODE
#
jsb cmpil # call compiler
movl r9,r$cod # set ptr to first code block
movl $nulls,r$ttl # forget title (reg04)
movl $nulls,r$stl # forget sub-title (reg04)
clrl r$cim # forget compiler input image
clrl r10 # clear dud value
clrl r7 # dont shift dynamic store up
jsb gbcol # clear garbage left from compile
tstl cpsts # skip if no listing of comp stats
beqlu 0f
jmp inix0
0:
jsb prtpg # eject page
#
# PRINT COMPILE STATISTICS
#
movl dnamp,r6 # next available loc
subl2 statb,r6 # minus start
ashl $-2,r6,r6 # convert to words
movl r6,r5 # convert to integer
movl $encm1,r9 # point to /memory used (words)/
jsb prtmi # print message
movl dname,r6 # end of memory
subl2 dnamp,r6 # minus next available loc
ashl $-2,r6,r6 # convert to words
movl r6,r5 # convert to integer
movl $encm2,r9 # point to /memory available (words)/
jsb prtmi # print line
movl cmerc,r5 # get count of errors as integer
movl $encm3,r9 # point to /compile errors/
jsb prtmi # print it
movl gbcnt,r5 # garbage collection count
subl2 intv1,r5 # adjust for unavoidable collect
movl $stpm5,r9 # point to /storage regenerations/
jsb prtmi # print gbcol count
jsb systm # get time
subl2 timsx,r5 # get compilation time
movl $encm4,r9 # point to compilation time (msec)/
jsb prtmi # print message
addl2 $num05,lstlc # bump line count
tstl headp # no eject if nothing printed (sdg11)
bnequ 0f
jmp inix0
0:
jsb prtpg # eject printer
#page
#
# PREPARE NOW TO START EXECUTION
#
# SET DEFAULT INPUT RECORD LENGTH
#
inix0: cmpl cswin,$iniln # skip if not default -in72 used
bgtru inix1
movl $inils,cswin # else use default record length
#
# RESET TIMER
#
inix1: jsb systm # get time again
movl r5,timsx # store for end run processing
addl2 cswex,noxeq # add -noexecute flag
bnequ inix2 # jump if execution suppressed
clrl gbcnt # initialise collect count
jsb sysbx # call before starting execution
#
# MERGE WHEN LISTING FILE SET FOR EXECUTION
#
iniy0: movl sp,headp # mark headers out regardless
clrl -(sp) # set failure location on stack
movl sp,flptr # save ptr to failure offset word
movl r$cod,r9 # load ptr to entry code block
movl $stgxt,stage # set stage for execute time
movl cmpsn,pfnte # copy stmts compiled count in case
jsb systm # time yet again
movl r5,pfstm
movl (r9),r11 # start xeq with first statement
jmp (r11)
#
# HERE IF EXECUTION IS SUPPRESSED
#
inix2: jsb prtnl # print a blank line
movl $encm5,r9 # point to /execution suppressed/
jsb prtst # print string
jsb prtnl # output line
clrl r6 # set abend value to zero
movl $nini9,r7 # set special code value
jsb sysej # end of job, exit to system
#title 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
#page
#
# BINARY PLUS (ADDITION)
#
o$add: # entry point
jsb arith # fetch arithmetic operands
.long er_001 # addition left operand is not numeric
.long er_002 # addition right operand is not numeric
.long oadd1 # jump if real operands
#
# HERE TO ADD TWO INTEGERS
#
addl2 4*icval(r10),r5 # add right operand to left
bvs 0f
jmp exint
0:
jmp er_003 # addition caused integer overflow
#
# HERE TO ADD TWO REALS
#
oadd1: addf2 4*rcval(r10),r2 # add right operand to left
bvs 0f
jmp exrea
0:
jmp er_261 # addition caused real overflow
#page
#
# UNARY PLUS (AFFIRMATION)
#
o$aff: # entry point
movl (sp)+,r9 # load operand
jsb gtnum # convert to numeric
.long er_004 # affirmation operand is not numeric
jmp exixr # return if converted to numeric
#page
#
# BINARY BAR (ALTERNATION)
#
o$alt: # entry point
movl (sp)+,r9 # load right operand
jsb gtpat # convert to pattern
.long er_005 # alternation right operand is not pattern
#
# MERGE HERE FROM SPECIAL (LEFT ALTERNATION) CASE
#
oalt1: movl $p$alt,r7 # set pcode for alternative node
jsb pbild # build alternative node
movl r9,r10 # save address of alternative node
movl (sp)+,r9 # load left operand
jsb gtpat # convert to pattern
.long er_006 # alternation left operand is not pattern
cmpl r9,$p$alt # jump if left arg is alternation
beqlu oalt2
movl r9,4*pthen(r10) # set left operand as successor
movl r10,r9 # move result to proper register
jmp 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: movl 4*parm1(r9),4*pthen(r10) # build the (b / c) node
movl 4*pthen(r9),-(sp)# set a as new left arg
movl r10,r9 # set (b / c) as new right arg
jmp oalt1 # merge back to build a / (b / c)
#page
#
# ARRAY REFERENCE (MULTIPLE SUBSCRIPTS, BY NAME)
#
o$amn: # entry point
movl (r3)+,r9 # load number of subscripts
movl r9,r7 # set flag for by name
jmp arref # jump to array reference routine
#page
#
# ARRAY REFERENCE (MULTIPLE SUBSCRIPTS, BY VALUE)
#
o$amv: # entry point
movl (r3)+,r9 # load number of subscripts
clrl r7 # set flag for by value
jmp arref # jump to array reference routine
#page
#
# ARRAY REFERENCE (ONE SUBSCRIPT, BY NAME)
#
o$aon: # entry point
movl (sp),r9 # load subscript value
movl 4*1(sp),r10 # load array value
movl (r10),r6 # load first word of array operand
cmpl r6,$b$vct # jump if vector reference
beqlu oaon2
cmpl r6,$b$tbt # jump if table reference
beqlu oaon3
#
# HERE TO USE CENTRAL ARRAY REFERENCE ROUTINE
#
oaon1: movl $num01,r9 # set number of subscripts to one
movl r9,r7 # set flag for by name
jmp arref # jump to array reference routine
#
# HERE IF WE HAVE A VECTOR REFERENCE
#
oaon2: cmpl (r9),$b$icl # use long routine if not integer
bnequ oaon1
movl 4*icval(r9),r5 # load integer subscript value
movl r5,r6 # copy as address int, fail if ovflo
bgeq 0f
jmp exfal
0:
tstl r6 # fail if zero
bnequ 0f
jmp exfal
0:
addl2 $vcvlb,r6 # compute offset in words
moval 0[r6],r6 # convert to bytes
movl r6,(sp) # complete name on stack
cmpl r6,4*vclen(r10) # exit if subscript not too large
bgequ 0f
jmp exits
0:
jmp exfal # else fail
#
# HERE FOR TABLE REFERENCE
#
oaon3: movl sp,r7 # set flag for name reference
jsb tfind # locate/create table element
.long exfal # fail if access fails
movl r10,4*1(sp) # store name base on stack
movl r6,(sp) # store name offset on stack
jmp exits # exit with result on stack
#page
#
# ARRAY REFERENCE (ONE SUBSCRIPT, BY VALUE)
#
o$aov: # entry point
movl (sp)+,r9 # load subscript value
movl (sp)+,r10 # load array value
movl (r10),r6 # load first word of array operand
cmpl r6,$b$vct # jump if vector reference
beqlu oaov2
cmpl r6,$b$tbt # jump if table reference
beqlu oaov3
#
# HERE TO USE CENTRAL ARRAY REFERENCE ROUTINE
#
oaov1: movl r10,-(sp) # restack array value
movl r9,-(sp) # restack subscript
movl $num01,r9 # set number of subscripts to one
clrl r7 # set flag for value call
jmp arref # jump to array reference routine
#
# HERE IF WE HAVE A VECTOR REFERENCE
#
oaov2: cmpl (r9),$b$icl # use long routine if not integer
bnequ oaov1
movl 4*icval(r9),r5 # load integer subscript value
movl r5,r6 # move as one word int, fail if ovflo
bgeq 0f
jmp exfal
0:
tstl r6 # fail if zero
bnequ 0f
jmp exfal
0:
addl2 $vcvlb,r6 # compute offset in words
moval 0[r6],r6 # convert to bytes
cmpl r6,4*vclen(r10) # fail if subscript too large
blssu 0f
jmp exfal
0:
jsb acess # access value
.long exfal # fail if access fails
jmp exixr # else return value to caller
#
# HERE FOR TABLE REFERENCE BY VALUE
#
oaov3: clrl r7 # set flag for value reference
jsb tfind # call table search routine
.long exfal # fail if access fails
jmp exixr # exit with result in xr
#page
#
# ASSIGNMENT
#
o$ass: # entry point
#
# O$RPL (PATTERN REPLACEMENT) MERGES HERE
#
oass0: movl (sp)+,r7 # load value to be assigned
movl (sp)+,r6 # load name offset
movl (sp),r10 # load name base
movl r7,(sp) # store assigned value as result
jsb asign # perform assignment
.long exfal # fail if assignment fails
jmp exits # exit with result on stack
#page
#
# COMPILATION ERROR
#
o$cer: # entry point
jmp er_007 # compilation error encountered during execution
#page
#
# UNARY AT (CURSOR ASSIGNMENT)
#
o$cas: # entry point
movl (sp)+,r8 # load name offset (parm2)
movl (sp)+,r9 # load name base (parm1)
movl $p$cas,r7 # set pcode for cursor assignment
jsb pbild # build node
jmp exixr # jump for next code word
#page
#
# CONCATENATION
#
o$cnc: # entry point
movl (sp),r9 # load right argument
cmpl r9,$nulls # jump if right arg is null
bnequ 0f
jmp ocnc3
0:
movl 4*1(sp),r10 # load left argument
cmpl r10,$nulls # jump if left argument is null
bnequ 0f
jmp ocnc4
0:
movl $b$scl,r6 # get constant to test for string
cmpl r6,(r10) # jump if left arg not a string
beqlu 0f
jmp ocnc2
0:
cmpl r6,(r9) # jump if right arg not a string
beqlu 0f
jmp ocnc2
0:
#
# MERGE HERE TO CONCATENATE TWO STRINGS
#
ocnc1: movl 4*sclen(r10),r6 # load left argument length
addl2 4*sclen(r9),r6 # compute result length
jsb alocs # allocate scblk for result
movl r9,4*1(sp) # store result ptr over left argument
movab cfp$f(r9),r9 # prepare to store chars of result
movl 4*sclen(r10),r6 # get number of chars in left arg
movab cfp$f(r10),r10 # prepare to load left arg chars
jsb sbmvc # move characters of left argument
movl (sp)+,r10 # load right arg pointer, pop stack
movl 4*sclen(r10),r6 # load number of chars in right arg
movab cfp$f(r10),r10 # prepare to load right arg chars
jsb sbmvc # move characters of right argument
jmp exits # exit with result on stack
#
# COME HERE IF ARGUMENTS ARE NOT BOTH STRINGS
#
ocnc2: jsb gtstg # convert right arg to string
.long ocnc5 # jump if right arg is not string
movl r9,r10 # save right arg ptr
jsb gtstg # convert left arg to string
.long ocnc6 # jump if left arg is not a string
movl r9,-(sp) # stack left argument
movl r10,-(sp) # stack right argument
movl r9,r10 # move left arg to proper reg
movl (sp),r9 # move right arg to proper reg
jmp ocnc1 # merge back to concatenate strings
#page
#
# CONCATENATION (CONTINUED)
#
# COME HERE FOR NULL RIGHT ARGUMENT
#
ocnc3: addl2 $4,sp # remove right arg from stack
jmp exits # return with left argument on stack
#
# HERE FOR NULL LEFT ARGUMENT
#
ocnc4: addl2 $4,sp # unstack one argument
movl r9,(sp) # store right argument
jmp exits # exit with result on stack
#
# HERE IF RIGHT ARGUMENT IS NOT A STRING
#
ocnc5: movl r9,r10 # move right argument ptr
movl (sp)+,r9 # load left arg pointer
#
# MERGE HERE WHEN LEFT ARGUMENT IS NOT A STRING
#
ocnc6: jsb gtpat # convert left arg to pattern
.long er_008 # concatenation left opnd is not string or pattern
movl r9,-(sp) # save result on stack
movl r10,r9 # point to right operand
jsb gtpat # convert to pattern
.long er_009 # concatenation right opd is not string or pattern
movl r9,r10 # move for pconc
movl (sp)+,r9 # reload left operand ptr
jsb pconc # concatenate patterns
jmp exixr # exit with result in xr
#page
#
# COMPLEMENTATION
#
o$com: # entry point
movl (sp)+,r9 # load operand
movl (r9),r6 # load type word
#
# MERGE BACK HERE AFTER CONVERSION
#
ocom1: cmpl r6,$b$icl # jump if integer
beqlu ocom2
cmpl r6,$b$rcl # jump if real
beqlu ocom3
jsb gtnum # else convert to numeric
.long er_010 # complementation operand is not numeric
jmp ocom1 # back to check cases
#
# HERE TO COMPLEMENT INTEGER
#
ocom2: movl 4*icval(r9),r5 # load integer value
mnegl r5,r5 # negate
bvs 0f
jmp exint
0:
jmp er_011 # complementation caused integer overflow
#
# HERE TO COMPLEMENT REAL
#
ocom3: movf 4*rcval(r9),r2 # load real value
mnegf r2,r2 # negate
jmp exrea # return real result
#page
#
# BINARY SLASH (DIVISION)
#
o$dvd: # entry point
jsb arith # fetch arithmetic operands
.long er_012 # division left operand is not numeric
.long er_013 # division right operand is not numeric
.long odvd2 # jump if real operands
#
# HERE TO DIVIDE TWO INTEGERS
#
divl2 4*icval(r10),r5 # divide left operand by right
bvs 0f
jmp exint
0:
jmp er_014 # division caused integer overflow
#
# HERE TO DIVIDE TWO REALS
#
odvd2: divf2 4*rcval(r10),r2 # divide left operand by right
bvs 0f
jmp exrea
0:
jmp er_262 # division caused real overflow
#page
#
# EXPONENTIATION
#
o$exp: # entry point
movl (sp)+,r9 # load exponent
jsb gtnum # convert to number
.long er_015 # exponentiation right operand is not numeric
cmpl r6,$b$icl # jump if real
beqlu 0f
jmp oexp7
0:
movl r9,r10 # move exponent
movl (sp)+,r9 # load base
jsb gtnum # convert to numeric
.long er_016 # exponentiation left operand is not numeric
movl 4*icval(r10),r5 # load exponent
bgeq 0f # error if negative exponent
jmp oexp8
0:
cmpl r6,$b$rcl # jump if base is real
beqlu oexp3
#
# HERE TO EXPONENTIATE AN INTEGER
#
movl r5,r6 # convert exponent to 1 word integer
bgeq 0f
jmp oexp2
0:
# set loop counter
movl intv1,r5 # load initial value of 1
tstl r6 # jump if non-zero exponent
bnequ oexp1
tstl r5 # give zero as result for nonzero**0
beql 0f
jmp exint
0:
jmp oexp4 # else error of 0**0
#
# LOOP TO PERFORM EXPONENTIATION
#
oexp1: mull2 4*icval(r9),r5 # multiply by base
bvs oexp2
sobgtr r6,oexp1 # loop back till computation complete
jmp exint # then return integer result
#
# HERE IF INTEGER OVERFLOW
#
oexp2: jmp er_017 # exponentiation caused integer overflow
#page
#
# EXPONENTIATION (CONTINUED)
#
# HERE TO EXPONENTIATE A REAL
#
oexp3: movl r5,r6 # convert exponent to one word
bgeq 0f
jmp oexp6
0:
# set loop counter
movf reav1,r2 # load 1.0 as initial value
tstl r6 # jump if non-zero exponent
bnequ oexp5
tstf r2 # return 1.0 if nonzero**zero
beql 0f
jmp exrea
0:
#
# HERE FOR ERROR OF 0**0 OR 0.0**0
#
oexp4: jmp er_018 # exponentiation result is undefined
#
# LOOP TO PERFORM EXPONENTIATION
#
oexp5: mulf2 4*rcval(r9),r2 # multiply by base
bvs oexp6
sobgtr r6,oexp5 # loop till computation complete
jmp exrea # then return real result
#
# HERE IF REAL OVERFLOW
#
oexp6: jmp er_266 # exponentiation caused real overflow
#
# HERE IF REAL EXPONENT
#
oexp7: jmp er_267 # exponentiation right operand is real not integer
#
# HERE FOR NEGATIVE EXPONENT
#
oexp8: jmp er_019 # exponentiation right operand is negative
#page
#
# 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: # entry point
jmp evlx6 # jump to failure loc in evalx
#page
#
# FAILURE DURING EVALUATION OF A COMPLEX OR DIRECT GOTO
#
o$fif: # entry point
jmp er_020 # goto evaluation failure
#page
#
# FUNCTION CALL (MORE THAN ONE ARGUMENT)
#
o$fnc: # entry point
movl (r3)+,r6 # load number of arguments
movl (r3)+,r9 # load function vrblk pointer
movl 4*vrfnc(r9),r10 # load function pointer
cmpl r6,4*fargs(r10) # use central routine if wrong num
beqlu 0f
jmp cfunc
0:
movl (r10),r11 # jump to function if arg count ok
jmp (r11)
#page
#
# FUNCTION NAME ERROR
#
o$fne: # entry point
movl (r3)+,r6 # get next code word
cmpl r6,$ornm$ # fail if not evaluating expression
bnequ ofne1
tstl 4*2(sp) # ok if expr. was wanted by value
bnequ 0f
jmp evlx3
0:
#
# HERE FOR ERROR
#
ofne1: jmp er_021 # function called by name returned a value
#page
#
# FUNCTION CALL (SINGLE ARGUMENT)
#
o$fns: # entry point
movl (r3)+,r9 # load function vrblk pointer
movl $num01,r6 # set number of arguments to one
movl 4*vrfnc(r9),r10 # load function pointer
cmpl r6,4*fargs(r10) # use central routine if wrong num
beqlu 0f
jmp cfunc
0:
movl (r10),r11 # jump to function if arg count ok
jmp (r11)
#page
# CALL TO UNDEFINED FUNCTION
#
o$fun: # entry point
jmp er_022 # undefined function called
#page
#
# EXECUTE COMPLEX GOTO
#
o$goc: # entry point
movl 4*1(sp),r9 # load name base pointer
cmpl r9,state # jump if not natural variable
bgequ ogoc1
addl2 $4*vrtra,r9 # else point to vrtra field
movl (r9),r11 # and jump through it
jmp (r11)
#
# HERE IF GOTO OPERAND IS NOT NATURAL VARIABLE
#
ogoc1: jmp er_023 # goto operand is not a natural variable
#page
#
# EXECUTE DIRECT GOTO
#
o$god: # entry point
movl (sp),r9 # load operand
movl (r9),r6 # load first word
cmpl r6,$b$cds # jump if code block to code routine
bnequ 0f
jmp bcds0
0:
cmpl r6,$b$cdc # jump if code block to code routine
bnequ 0f
jmp bcdc0
0:
jmp er_024 # goto operand in direct goto is not code
#page
#
# 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: # entry point
movl flptr,r9 # point to fail offset on stack
addl2 $4,(r9) # point failure to o$fif word
tstl (r3)+ # point to next code word
jmp exits # exit to continue
#page
#
# 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: # entry point
movl $p$imc,r7 # set pcode for last node
movl (sp)+,r8 # pop name offset (parm2)
movl (sp)+,r9 # pop name base (parm1)
jsb pbild # build p$imc node
movl r9,r10 # save ptr to node
movl (sp),r9 # load left argument
jsb gtpat # convert to pattern
.long er_025 # immediate assignment left operand is not pattern
movl r9,(sp) # save ptr to left operand pattern
movl $p$ima,r7 # set pcode for first node
jsb pbild # build p$ima node
movl (sp)+,4*pthen(r9)# set left operand as p$ima successor
jsb pconc # concatenate to form final pattern
jmp exixr # all done
#page
#
# INDIRECTION (BY NAME)
#
o$inn: # entry point
movl sp,r7 # set flag for result by name
jmp indir # jump to common routine
#page
#
# INTERROGATION
#
o$int: # entry point
movl $nulls,(sp) # replace operand with null
jmp exits # exit for next code word
#page
#
# INDIRECTION (BY VALUE)
#
o$inv: # entry point
clrl r7 # set flag for by value
jmp indir # jump to common routine
#page
#
# KEYWORD REFERENCE (BY NAME)
#
o$kwn: # entry point
jsb kwnam # get keyword name
jmp exnam # exit with result name
#page
#
# KEYWORD REFERENCE (BY VALUE)
#
o$kwv: # entry point
jsb kwnam # get keyword name
movl r9,dnamp # delete kvblk
jsb acess # access value
.long exnul # dummy (unused) failure return
jmp exixr # jump with value in xr
#page
#
# LOAD EXPRESSION BY NAME
#
o$lex: # entry point
movl $4*evsi$,r6 # set size of evblk
jsb alloc # allocate space for evblk
movl $b$evt,(r9) # set type word
movl $trbev,4*evvar(r9) # set dummy trblk pointer
movl (r3)+,r6 # load exblk pointer
movl r6,4*evexp(r9) # set exblk pointer
movl r9,r10 # move name base to proper reg
movl $4*evvar,r6 # set name offset = zero
jmp exnam # exit with name in (xl,wa)
#page
#
# LOAD PATTERN VALUE
#
o$lpt: # entry point
movl (r3)+,r9 # load pattern pointer
jmp exixr # stack ptr and obey next code word
#page
#
# LOAD VARIABLE NAME
#
o$lvn: # entry point
movl (r3)+,r6 # load vrblk pointer
movl r6,-(sp) # stack vrblk ptr (name base)
movl $4*vrval,-(sp) # stack name offset
jmp exits # exit with result on stack
#page
#
# BINARY ASTERISK (MULTIPLICATION)
#
o$mlt: # entry point
jsb arith # fetch arithmetic operands
.long er_026 # multiplication left operand is not numeric
.long er_027 # multiplication right operand is not numeric
.long omlt1 # jump if real operands
#
# HERE TO MULTIPLY TWO INTEGERS
#
mull2 4*icval(r10),r5 # multiply left operand by right
bvs 0f
jmp exint
0:
jmp er_028 # multiplication caused integer overflow
#
# HERE TO MULTIPLY TWO REALS
#
omlt1: mulf2 4*rcval(r10),r2 # multiply left operand by right
bvs 0f
jmp exrea
0:
jmp er_263 # multiplication caused real overflow
#page
#
# NAME REFERENCE
#
o$nam: # entry point
movl $4*nmsi$,r6 # set length of nmblk
jsb alloc # allocate nmblk
movl $b$nml,(r9) # set name block code
movl (sp)+,4*nmofs(r9)# set name offset from operand
movl (sp)+,4*nmbas(r9)# set name base from operand
jmp exixr # exit with result in xr
#page
#
# NEGATION
#
# INITIAL ENTRY
#
o$nta: # entry point
movl (r3)+,r6 # load new failure offset
movl flptr,-(sp) # stack old failure pointer
movl r6,-(sp) # stack new failure offset
movl sp,flptr # set new failure pointer
jmp exits # jump to continue execution
#
# ENTRY AFTER SUCCESSFUL EVALUATION OF OPERAND
#
o$ntb: # entry point
movl 4*2(sp),flptr # restore old failure pointer
jmp exfal # and fail
#
# ENTRY FOR FAILURE DURING OPERAND EVALUATION
#
o$ntc: # entry point
addl2 $4,sp # pop failure offset
movl (sp)+,flptr # restore old failure pointer
jmp exnul # exit giving null result
#page
#
# USE OF UNDEFINED OPERATOR
#
o$oun: # entry point
jmp er_029 # undefined operator referenced
#page
#
# 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: # entry point
movl $p$pac,r7 # load pcode for p$pac node
movl (sp)+,r8 # load name offset (parm2)
movl (sp)+,r9 # load name base (parm1)
jsb pbild # build p$pac node
movl r9,r10 # save ptr to node
movl (sp),r9 # load left operand
jsb gtpat # convert to pattern
.long er_030 # pattern assignment left operand is not pattern
movl r9,(sp) # save ptr to left operand pattern
movl $p$paa,r7 # set pcode for p$paa node
jsb pbild # build p$paa node
movl (sp)+,4*pthen(r9)# set left operand as p$paa successor
jsb pconc # concatenate to form final pattern
jmp exixr # jump for next code word
#page
#
# PATTERN MATCH (BY NAME, FOR REPLACEMENT)
#
o$pmn: # entry point
clrl r7 # set type code for match by name
jmp match # jump to routine to start match
#page
#
# 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: # entry point
movl $num02,r7 # set flag for statement to match
jmp match # jump to routine to start match
#page
#
# PATTERN MATCH (BY VALUE)
#
o$pmv: # entry point
movl $num01,r7 # set type code for value match
jmp match # jump to routine to start match
#page
#
# POP TOP ITEM ON STACK
#
o$pop: # entry point
addl2 $4,sp # pop top stack entry
jmp exits # obey next code word
#page
#
# TERMINATE EXECUTION (CODE COMPILED FOR END STATEMENT)
#
o$stp: # entry point
jmp lend0 # jump to end circuit
#page
#
# 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: # entry point
jmp evlx4 # return to evalx procedure
#page
#
# 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: # entry point
jsb gtstg # convert replacement val to string
.long er_031 # pattern replacement right operand is not string
#
# GET RESULT LENGTH AND ALLOCATE RESULT SCBLK
#
movl (sp),r10 # load subject string pointer
cmpl (r10),$b$bct # branch if buffer assignment
bnequ 0f
jmp orpl4
0:
addl2 4*sclen(r10),r6 # add subject string length
addl2 4*2(sp),r6 # add starting cursor
subl2 4*1(sp),r6 # minus final cursor = total length
bnequ 0f # jump if result is null
jmp orpl3
0:
movl r9,-(sp) # restack replacement string
jsb alocs # allocate scblk for result
movl 4*3(sp),r6 # get initial cursor (part 1 len)
movl r9,4*3(sp) # stack result pointer
movab cfp$f(r9),r9 # point to characters of result
#
# MOVE PART 1 (START OF SUBJECT) TO RESULT
#
tstl r6 # jump if first part is null
beqlu orpl1
movl 4*1(sp),r10 # else point to subject string
movab cfp$f(r10),r10 # point to subject string chars
jsb sbmvc # move first part to result
#page
# PATTERN REPLACEMENT (CONTINUED)
#
# NOW MOVE IN REPLACEMENT VALUE
#
orpl1: movl (sp)+,r10 # load replacement string, pop
movl 4*sclen(r10),r6 # load length
beqlu orpl2 # jump if null replacement
movab cfp$f(r10),r10 # else point to chars of replacement
jsb sbmvc # move in chars (part 2)
#
# NOW MOVE IN REMAINDER OF STRING (PART 3)
#
orpl2: movl (sp)+,r10 # load subject string pointer, pop
movl (sp)+,r8 # load final cursor, pop
movl 4*sclen(r10),r6 # load subject string length
subl2 r8,r6 # minus final cursor = part 3 length
bnequ 0f # jump to assign if part 3 is null
jmp oass0
0:
movab cfp$f(r10)[r8],r10 # else point to last part of string
jsb sbmvc # move part 3 to result
jmp oass0 # jump to perform assignment
#
# HERE IF RESULT IS NULL
#
orpl3: addl2 $4*num02,sp # pop subject str ptr, final cursor
movl $nulls,(sp) # set null result
jmp oass0 # jump to assign null value
#
# HERE FOR BUFFER SUBSTRING ASSIGNMENT
#
orpl4: movl r9,r10 # copy scblk replacement ptr
movl (sp)+,r9 # unstack bcblk ptr
movl (sp)+,r7 # get final cursor value
movl (sp)+,r6 # get initial cursor
subl2 r6,r7 # get length in wb
addl2 $4*num02,sp # get rid of name base/offset
jsb insbf # insert substring
.long invalid$ # convert fail impossible
.long exfal # fail if insert fails
jmp exnul # else null result
#page
#
# 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: # entry point
jmp evlx3 # return to evalx procedure
#page
#
# SELECTION
#
# INITIAL ENTRY
#
o$sla: # entry point
movl (r3)+,r6 # load new failure offset
movl flptr,-(sp) # stack old failure pointer
movl r6,-(sp) # stack new failure offset
movl sp,flptr # set new failure pointer
jmp exits # jump to execute first alternative
#
# ENTRY AFTER SUCCESSFUL EVALUATION OF ALTERNATIVE
#
o$slb: # entry point
movl (sp)+,r9 # load result
addl2 $4,sp # pop fail offset
movl (sp),flptr # restore old failure pointer
movl r9,(sp) # restack result
movl (r3)+,r6 # load new code offset
addl2 r$cod,r6 # point to absolute code location
movl r6,r3 # set new code pointer
jmp exits # jump to continue past selection
#
# ENTRY AT START OF SUBSEQUENT ALTERNATIVES
#
o$slc: # entry point
movl (r3)+,r6 # load new fail offset
movl r6,(sp) # store new fail offset
jmp exits # jump to execute next alternative
#
# ENTRY AT START OF LAST ALTERNATIVE
#
o$sld: # entry point
addl2 $4,sp # pop failure offset
movl (sp)+,flptr # restore old failure pointer
jmp exits # jump to execute last alternative
#page
#
# BINARY MINUS (SUBTRACTION)
#
o$sub: # entry point
jsb arith # fetch arithmetic operands
.long er_032 # subtraction left operand is not numeric
.long er_033 # subtraction right operand is not numeric
.long osub1 # jump if real operands
#
# HERE TO SUBTRACT TWO INTEGERS
#
subl2 4*icval(r10),r5 # subtract right operand from left
bvs 0f
jmp exint
0:
jmp er_034 # subtraction caused integer overflow
#
# HERE TO SUBTRACT TWO REALS
#
osub1: subf2 4*rcval(r10),r2 # subtract right operand from left
bvs 0f
jmp exrea
0:
jmp er_264 # subtraction caused real overflow
#page
#
# DUMMY OPERATOR TO RETURN CONTROL TO TRXEQ PROCEDURE
#
o$txr: # entry point
jmp trxq1 # jump into trxeq procedure
#page
#
# 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: # entry point
jmp er_035 # unexpected failure in -nofail mode
#title 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
#page
#
# ABORT
#
l$abo: # entry point
#
# MERGE HERE IF EXECUTION TERMINATES IN ERROR
#
labo1: movl kvert,r6 # load error code
beqlu labo2 # jump if no error has occured
jsb sysax # call after execution proc (reg04)
jsb prtpg # else eject printer
jsb ermsg # print error message
clrl r9 # indicate no message to print
jmp stopr # jump to routine to stop run
#
# HERE IF NO ERROR HAD OCCURED
#
labo2: jmp er_036 # goto abort with no preceding error
#page
#
# CONTINUE
#
l$cnt: # entry point
#
# MERGE HERE AFTER EXECUTION ERROR
#
lcnt1: movl r$cnt,r9 # load continuation code block ptr
beqlu lcnt2 # jump if no previous error
clrl r$cnt # clear flag
movl r9,r$cod # else store as new code block ptr
addl2 stxof,r9 # add failure offset
movl r9,r3 # load code pointer
movl flptr,sp # reset stack pointer
jmp exits # jump to take indicated failure
#
# HERE IF NO PREVIOUS ERROR
#
lcnt2: jmp er_037 # goto continue with no preceding error
#page
#
# END
#
l$end: # entry point
#
# MERGE HERE FROM END CODE CIRCUIT
#
lend0: movl $endms,r9 # point to message /normal term../
jmp stopr # jump to routine to stop run
#page
#
# FRETURN
#
l$frt: # entry point
movl $scfrt,r6 # point to string /freturn/
jmp retrn # jump to common return routine
#page
#
# NRETURN
#
l$nrt: # entry point
movl $scnrt,r6 # point to string /nreturn/
jmp retrn # jump to common return routine
#page
#
# RETURN
#
l$rtn: # entry point
movl $scrtn,r6 # point to string /return/
jmp retrn # jump to common return routine
#page
#
# UNDEFINED LABEL
#
l$und: # entry point
jmp er_038 # goto undefined label
#title 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
#
.align 2
.word bl$$i
b$aaa: # entry point of first block routine
#page
#
# EXBLK
#
# THE ROUTINE FOR AN EXBLK LOADS THE EXPRESSION ONTO
# THE STACK AS A VALUE.
#
# (XR) POINTER TO EXBLK
#
.align 2
.word bl$ex
b$exl: # entry point (exblk)
jmp exixr # stack xr and obey next code word
#page
#
# SEBLK
#
# THE ROUTINE FOR SEBLK IS ACCESSED FROM THE GENERATED
# CODE TO LOAD THE EXPRESSION VALUE ONTO THE STACK.
#
.align 2
.word bl$se
b$sel: # entry point (seblk)
jmp exixr # stack xr and obey next code word
#
# DEFINE SYMBOL WHICH MARKS END OF ENTRIES FOR EXPRESSIONS
#
.align 2
.word bl$$i
b$e$$: # entry point
#page
#
# TRBLK
#
# THE ROUTINE FOR A TRBLK IS NEVER EXECUTED
#
.align 2
.word bl$tr
b$trt: # entry point (trblk)
#
# DEFINE SYMBOL MARKING END OF TRAP AND EXPRESSION BLOCKS
#
.align 2
.word bl$$i
b$t$$: # end of trblk,seblk,exblk entries
#page
#
# ARBLK
#
# THE ROUTINE FOR ARBLK IS NEVER EXECUTED
#
.align 2
.word bl$ar
b$art: # entry point (arblk)
#page
#
# BCBLK
#
# THE ROUTINE FOR A BCBLK IS NEVER EXECUTED
#
# (XR) POINTER TO BCBLK
#
.align 2
.word bl$bc
b$bct: # entry point (bcblk)
#page
#
# BFBLK
#
# THE ROUTINE FOR A BFBLK IS NEVER EXECUTED
#
# (XR) POINTER TO BFBLK
#
.align 2
.word bl$bf
b$bft: # entry point (bfblk)
#page
#
# CCBLK
#
# THE ROUTINE FOR CCBLK IS NEVER ENTERED
#
.align 2
.word bl$cc
b$cct: # entry point (ccblk)
#page
#
# 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
#
.align 2
.word bl$cd
b$cdc: # entry point (cdblk)
bcdc0: movl flptr,sp # pop garbage off stack
movl 4*cdfal(r9),(sp)# set failure offset
jmp stmgo # enter stmt
#page
#
# CDBLK (CONTINUED)
#
# ENTRY FOR SIMPLE FAILURE CODE AT CDFAL
#
# (XR) POINTER TO CDBLK
#
.align 2
.word bl$cd
b$cds: # entry point (cdblk)
bcds0: movl flptr,sp # pop garbage off stack
movl $4*cdfal,(sp) # set failure offset
jmp stmgo # enter stmt
#page
#
# CMBLK
#
# THE ROUTINE FOR A CMBLK IS NEVER EXECUTED
#
.align 2
.word bl$cm
b$cmt: # entry point (cmblk)
#page
#
# CTBLK
#
# THE ROUTINE FOR A CTBLK IS NEVER EXECUTED
#
.align 2
.word bl$ct
b$ctt: # entry point (ctblk)
#page
#
# 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
#
.align 2
.word bl$df
b$dfc: # entry point
movl 4*dfpdl(r10),r6 # load length of pdblk
jsb alloc # allocate pdblk
movl $b$pdt,(r9) # store type word
movl r10,4*pddfp(r9) # store dfblk pointer
movl r9,r8 # save pointer to pdblk
addl2 r6,r9 # point past pdblk
movl 4*fargs(r10),r6 # set to count fields
#
# LOOP TO ACQUIRE FIELD VALUES FROM STACK
#
bdfc1: movl (sp)+,-(r9) # move a field value
sobgtr r6,bdfc1 # loop till all moved
movl r8,r9 # recall pointer to pdblk
jmp exsid # exit setting id field
#page
#
# EFBLK
#
# THE ROUTINE FOR AN EFBLK IS PASSED CONTROL FORM THE O$FNC
# ENTRY TO CALL AN EXTERNAL FUNCTION.
#
# (XL) POINTER TO EFBLK
#
.align 2
.word bl$ef
b$efc: # entry point (efblk)
movl 4*fargs(r10),r8 # load number of arguments
moval 0[r8],r8 # convert to offset
movl r10,-(sp) # save pointer to efblk
movl sp,r10 # copy pointer to arguments
#
# LOOP TO CONVERT ARGUMENTS
#
befc1: addl2 $4,r10 # point to next entry
movl (sp),r9 # load pointer to efblk
subl2 $4,r8 # decrement eftar offset
addl2 r8,r9 # point to next eftar entry
movl 4*eftar(r9),r9 # load eftar entry
casel r9,$0,$4 # switch on type
5:
.word befc7-5b # no conversion needed
.word befc2-5b # string
.word befc3-5b # integer
.word befc4-5b # real
#esw # end of switch on type
#
# HERE TO CONVERT TO STRING
#
befc2: movl (r10),-(sp) # stack arg ptr
jsb gtstg # convert argument to string
.long er_039 # external function argument is not string
jmp befc6 # jump to merge
#page
#
# EFBLK (CONTINUED)
#
# HERE TO CONVERT AN INTEGER
#
befc3: movl (r10),r9 # load next argument
movl r8,befof # save offset
jsb gtint # convert to integer
.long er_040 # external function argument is not integer
jmp befc5 # merge with real case
#
# HERE TO CONVERT A REAL
#
befc4: movl (r10),r9 # load next argument
movl r8,befof # save offset
jsb gtrea # convert to real
.long er_265 # external function argument is not real
#
# INTEGER CASE MERGES HERE
#
befc5: movl befof,r8 # restore offset
#
# STRING MERGES HERE
#
befc6: movl r9,(r10) # store converted result
#
# NO CONVERSION MERGES HERE
#
befc7: tstl r8 # loop back if more to go
bnequ befc1
#
# HERE AFTER CONVERTING ALL THE ARGUMENTS
#
movl (sp)+,r10 # restore efblk pointer
movl 4*fargs(r10),r6 # get number of args
jsb sysex # call routine to call external fnc
.long exfal # fail if failure
#page
#
# EFBLK (CONTINUED)
#
# RETURN HERE WITH RESULT IN XR
#
# FIRST DEFEND AGAINST NON-STANDARD NULL STRING RETURNED
#
movl 4*efrsl(r10),r7 # get result type id
bnequ befa8 # branch if not unconverted
cmpl (r9),$b$scl # jump if not a string
bnequ befc8
tstl 4*sclen(r9) # return null if null
bnequ 0f
jmp exnul
0:
#
# HERE IF CONVERTED RESULT TO CHECK FOR NULL STRING
#
befa8: cmpl r7,$num01 # jump if not a string
bnequ befc8
tstl 4*sclen(r9) # return null if null
bnequ 0f
jmp exnul
0:
#
# RETURN IF RESULT IS IN DYNAMIC STORAGE
#
befc8: cmpl r9,dnamb # jump if not in dynamic storage
blssu befc9
cmpl r9,dnamp # return result if already dynamic
bgtru 0f
jmp exixr
0:
#
# HERE WE COPY A RESULT INTO THE DYNAMIC REGION
#
befc9: movl (r9),r6 # get possible type word
tstl r7 # jump if unconverted result
beqlu bef11
movl $b$scl,r6 # string
cmpl r7,$num01 # yes jump
beqlu bef10
movl $b$icl,r6 # integer
cmpl r7,$num02 # yes jump
beqlu bef10
movl $b$rcl,r6 # real
#
# STORE TYPE WORD IN RESULT
#
bef10: movl r6,(r9) # stored before copying to dynamic
#
# MERGE FOR UNCONVERTED RESULT
#
bef11: jsb blkln # get length of block
movl r9,r10 # copy address of old block
jsb alloc # allocate dynamic block same size
movl r9,-(sp) # set pointer to new block as result
jsb sbmvw # copy old block to dynamic block
jmp exits # exit with result on stack
#page
#
# EVBLK
#
# THE ROUTINE FOR AN EVBLK IS NEVER EXECUTED
#
.align 2
.word bl$ev
b$evt: # entry point (evblk)
#page
#
# 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
#
.align 2
.word bl$ff
b$ffc: # entry point (ffblk)
movl r10,r9 # copy ffblk pointer
movl (r3)+,r8 # load next code word
movl (sp),r10 # load pdblk pointer
cmpl (r10),$b$pdt # jump if not pdblk at all
bnequ bffc2
movl 4*pddfp(r10),r6 # load dfblk pointer from pdblk
#
# LOOP TO FIND CORRECT FFBLK FOR THIS PDBLK
#
bffc1: cmpl r6,4*ffdfp(r9) # jump if this is the correct ffblk
beqlu bffc3
movl 4*ffnxt(r9),r9 # else link to next ffblk on chain
bnequ bffc1 # loop back if another entry to check
#
# HERE FOR BAD ARGUMENT
#
bffc2: jmp er_041 # field function argument is wrong datatype
#page
#
# FFBLK (CONTINUED)
#
# HERE AFTER LOCATING CORRECT FFBLK
#
bffc3: movl 4*ffofs(r9),r6 # load field offset
cmpl r8,$ofne$ # jump if called by name
beqlu bffc5
addl2 r6,r10 # else point to value field
movl (r10),r9 # load value
cmpl (r9),$b$trt # jump if not trapped
bnequ bffc4
subl2 r6,r10 # else restore name base,offset
movl r8,(sp) # save next code word over pdblk ptr
jsb acess # access value
.long exfal # fail if access fails
movl (sp),r8 # restore next code word
#
# HERE AFTER GETTING VALUE IN (XR)
#
bffc4: movl r9,(sp) # store value on stack (over pdblk)
movl r8,r9 # copy next code word
movl (r9),r10 # load entry address
movl r10,r11 # jump to routine for next code word
jmp (r11)
#
# HERE IF CALLED BY NAME
#
bffc5: movl r6,-(sp) # store name offset (base is set)
jmp exits # exit with name on stack
#page
#
# ICBLK
#
# THE ROUTINE FOR ICBLK IS EXECUTED FROM THE GENERATED
# CODE TO LOAD AN INTEGER VALUE ONTO THE STACK.
#
# (XR) POINTER TO ICBLK
#
.align 2
.word bl$ic
b$icl: # entry point (icblk)
jmp exixr # stack xr and obey next code word
#page
#
# KVBLK
#
# THE ROUTINE FOR A KVBLK IS NEVER EXECUTED.
#
.align 2
.word bl$kv
b$kvt: # entry point (kvblk)
#page
#
# 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
#
.align 2
.word bl$nm
b$nml: # entry point (nmblk)
jmp exixr # stack xr and obey next code word
#page
#
# PDBLK
#
# THE ROUTINE FOR A PDBLK IS NEVER EXECUTED
#
.align 2
.word bl$pd
b$pdt: # entry point (pdblk)
#page
#
# 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)
#
.align 2
.word bl$pf
b$pfc: # entry point (pfblk)
movl r10,bpfpf # save pfblk ptr (need not be reloc)
movl r10,r9 # copy for the moment
movl 4*pfvbl(r9),r10 # point to vrblk for function
#
# LOOP TO FIND OLD VALUE OF FUNCTION
#
bpf01: movl r10,r7 # save pointer
movl 4*vrval(r10),r10# load value
cmpl (r10),$b$trt # loop if trblk
beqlu bpf01
#
# SET VALUE TO NULL AND SAVE OLD FUNCTION VALUE
#
movl r10,bpfsv # save old value
movl r7,r10 # point back to block with value
movl $nulls,4*vrval(r10) # set value to null
movl 4*fargs(r9),r6 # load number of arguments
addl2 $4*pfarg,r9 # point to pfarg entries
tstl r6 # jump if no arguments
beqlu bpf04
movl sp,r10 # ptr to last arg
moval 0[r6],r6 # convert no. of args to bytes offset
addl2 r6,r10 # point before first arg
movl r10,bpfxt # remember arg pointer
#page
#
# PFBLK (CONTINUED)
#
# LOOP TO SAVE OLD ARGUMENT VALUES AND SET NEW ONES
#
bpf02: movl (r9)+,r10 # load vrblk ptr for next argument
#
# LOOP THROUGH POSSIBLE TRBLK CHAIN TO FIND VALUE
#
bpf03: movl r10,r8 # save pointer
movl 4*vrval(r10),r10# load next value
cmpl (r10),$b$trt # loop back if trblk
beqlu bpf03
#
# SAVE OLD VALUE AND GET NEW VALUE
#
movl r10,r6 # keep old value
movl bpfxt,r10 # point before next stacked arg
movl -(r10),r7 # load argument (new value)
movl r6,(r10) # save old value
movl r10,bpfxt # keep arg ptr for next time
movl r8,r10 # point back to block with value
movl r7,4*vrval(r10) # set new value
cmpl sp,bpfxt # loop if not all done
bnequ bpf02
#
# NOW PROCESS LOCALS
#
bpf04: movl bpfpf,r10 # restore pfblk pointer
movl 4*pfnlo(r10),r6 # load number of locals
beqlu bpf07 # jump if no locals
movl $nulls,r7 # get null constant
# set local counter
#
# LOOP TO PROCESS LOCALS
#
bpf05: movl (r9)+,r10 # load vrblk ptr for next local
#
# LOOP THROUGH POSSIBLE TRBLK CHAIN TO FIND VALUE
#
bpf06: movl r10,r8 # save pointer
movl 4*vrval(r10),r10# load next value
cmpl (r10),$b$trt # loop back if trblk
beqlu bpf06
#
# SAVE OLD VALUE AND SET NULL AS NEW VALUE
#
movl r10,-(sp) # stack old value
movl r8,r10 # point back to block with value
movl r7,4*vrval(r10) # set null as new value
sobgtr r6,bpf05 # loop till all locals processed
#page
#
# PFBLK (CONTINUED)
#
# HERE AFTER PROCESSING ARGUMENTS AND LOCALS
#
bpf07: clrl r9 # zero reg xr in case
tstl kvpfl # skip if profiling is off
beqlu bpf7c
cmpl kvpfl,$num02 # branch on type of profile
beqlu bpf7a
#
# HERE IF &PROFILE = 1
#
jsb systm # get current time
movl r5,pfetm # save for a sec
subl2 pfstm,r5 # find time used by caller
jsb icbld # build into an icblk
movl pfetm,r5 # reload current time
jmp bpf7b # merge
#
# HERE IF &PROFILE = 2
#
bpf7a: movl pfstm,r5 # get start time of calling stmt
jsb icbld # assemble an icblk round it
jsb systm # get now time
#
# BOTH TYPES OF PROFILE MERGE HERE
#
bpf7b: movl r5,pfstm # set start time of 1st func stmt
movl sp,pffnc # flag function entry
#
# NO PROFILING MERGES HERE
#
bpf7c: movl r9,-(sp) # stack icblk ptr (or zero)
movl r$cod,r6 # load old code block pointer
movl r3,r7 # get code pointer
subl2 r6,r7 # make code pointer into offset
movl bpfpf,r10 # recall pfblk pointer
movl bpfsv,-(sp) # stack old value of function name
movl r6,-(sp) # stack code block pointer
movl r7,-(sp) # stack code offset
movl flprt,-(sp) # stack old flprt
movl flptr,-(sp) # stack old failure pointer
movl r10,-(sp) # stack pointer to pfblk
clrl -(sp) # dummy zero entry for fail return
jsb sbchk # check for stack overflow
movl sp,flptr # set new fail return value
movl sp,flprt # set new flprt
movl kvtra,r6 # load trace value
addl2 kvftr,r6 # add ftrace value
bnequ bpf09 # jump if tracing possible
incl kvfnc # else bump fnclevel
#
# HERE TO ACTUALLY JUMP TO FUNCTION
#
bpf08: movl 4*pfcod(r10),r9 # point to code
movl (r9),r11 # off to execute function
jmp (r11)
#
# HERE IF TRACING IS POSSIBLE
#
bpf09: movl 4*pfctr(r10),r9 # load possible call trace trblk
movl 4*pfvbl(r10),r10# load vrblk pointer for function
movl $4*vrval,r6 # set name offset for variable
tstl kvtra # jump if trace mode is off
beqlu bpf10
tstl r9 # or if there is no call trace
beqlu bpf10
#
# HERE IF CALL TRACED
#
decl kvtra # decrement trace count
tstl 4*trfnc(r9) # jump if print trace
beqlu bpf11
jsb trxeq # execute function type trace
#page
#
# PFBLK (CONTINUED)
#
# HERE TO TEST FOR FTRACE TRACE
#
bpf10: tstl kvftr # jump if ftrace is off
beqlu bpf16
decl kvftr # else decrement ftrace
#
# HERE FOR PRINT TRACE
#
bpf11: jsb prtsn # print statement number
jsb prtnm # print function name
movl $ch$pp,r6 # load left paren
jsb prtch # print left paren
movl 4*1(sp),r10 # recover pfblk pointer
tstl 4*fargs(r10) # skip if no arguments
beqlu bpf15
clrl r7 # else set argument counter
jmp bpf13 # jump into loop
#
# LOOP TO PRINT ARGUMENT VALUES
#
bpf12: movl $ch$cm,r6 # load comma
jsb prtch # print to separate from last arg
#
# MERGE HERE FIRST TIME (NO COMMA REQUIRED)
#
bpf13: movl r7,(sp) # save arg ctr (over failoffs is ok)
moval 0[r7],r7 # convert to byte offset
addl2 r7,r10 # point to next argument pointer
movl 4*pfarg(r10),r9 # load next argument vrblk ptr
subl2 r7,r10 # restore pfblk pointer
movl 4*vrval(r9),r9 # load next value
jsb prtvl # print argument value
#page
#
# HERE AFTER DEALING WITH ONE ARGUMENT
#
movl (sp),r7 # restore argument counter
incl r7 # increment argument counter
cmpl r7,4*fargs(r10) # loop if more to print
blssu bpf12
#
# MERGE HERE IN NO ARGS CASE TO PRINT PAREN
#
bpf15: movl $ch$rp,r6 # load right paren
jsb prtch # print to terminate output
jsb prtnl # terminate print line
#
# MERGE HERE TO EXIT WITH TEST FOR FNCLEVEL TRACE
#
bpf16: incl kvfnc # increment fnclevel
movl r$fnc,r10 # load ptr to possible trblk
jsb ktrex # call keyword trace routine
#
# CALL FUNCTION AFTER TRACE TESTS COMPLETE
#
movl 4*1(sp),r10 # restore pfblk pointer
jmp bpf08 # jump back to execute function
#page
#
# RCBLK
#
# THE ROUTINE FOR AN RCBLK IS EXECUTED FROM THE GENERATED
# CODE TO LOAD A REAL VALUE ONTO THE STACK.
#
# (XR) POINTER TO RCBLK
#
.align 2
.word bl$rc
b$rcl: # entry point (rcblk)
jmp exixr # stack xr and obey next code word
#page
#
# SCBLK
#
# THE ROUTINE FOR AN SCBLK IS EXECUTED FROM THE GENERATED
# CODE TO LOAD A STRING VALUE ONTO THE STACK.
#
# (XR) POINTER TO SCBLK
#
.align 2
.word bl$sc
b$scl: # entry point (scblk)
jmp exixr # stack xr and obey next code word
#page
#
# TBBLK
#
# THE ROUTINE FOR A TBBLK IS NEVER EXECUTED
#
.align 2
.word bl$tb
b$tbt: # entry point (tbblk)
#page
#
# TEBLK
#
# THE ROUTINE FOR A TEBLK IS NEVER EXECUTED
#
.align 2
.word bl$te
b$tet: # entry point (teblk)
#page
#
# VCBLK
#
# THE ROUTINE FOR A VCBLK IS NEVER EXECUTED
#
.align 2
.word bl$vc
b$vct: # entry point (vcblk)
#page
#
# VRBLK
#
# THE VRBLK ROUTINES ARE EXECUTED FROM THE GENERATED CODE.
# THERE ARE SIX ENTRIES FOR VRBLK COVERING VARIOUS CASES
#
.align 2
.word bl$$i
b$vr$: # 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
#
.align 2
.word bl$$i
b$vra: # entry point
movl r9,r10 # copy name base (vrget = 0)
movl $4*vrval,r6 # set name offset
jsb acess # access value
.long exfal # fail if access fails
jmp exixr # else exit with result in xr
#page
#
# 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: # entry point
jmp er_042 # attempt to change value of protected variable
#page
#
# 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: # entry point
movl 4*vrlbo(r9),r9 # load code pointer
movl (r9),r10 # load entry address
movl r10,r11 # jump to routine for next code word
jmp (r11)
#page
#
# 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: # entry point
movl 4*vrval(r9),-(sp)# load value onto stack (vrget = 0)
jmp exits # obey next code word
#page
#
# 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: # entry point
movl (sp),4*vrvlo(r9)# store value, leave on stack
jmp exits # obey next code word
#page
#
# 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: # entry point
subl2 $4*vrtra,r9 # point back to start of vrblk
movl r9,r10 # copy vrblk pointer
movl $4*vrval,r6 # set name offset
movl 4*vrlbl(r10),r9 # load pointer to trblk
tstl kvtra # jump if trace is off
beqlu bvrt2
decl kvtra # else decrement trace count
tstl 4*trfnc(r9) # jump if print trace case
beqlu bvrt1
jsb trxeq # else execute full trace
jmp bvrt2 # merge to jump to label
#
# HERE FOR PRINT TRACE -- PRINT COLON ( LABEL NAME )
#
bvrt1: jsb prtsn # print statement number
movl r10,r9 # copy vrblk pointer
movl $ch$cl,r6 # colon
jsb prtch # print it
movl $ch$pp,r6 # left paren
jsb prtch # print it
jsb prtvn # print label name
movl $ch$rp,r6 # right paren
jsb prtch # print it
jsb prtnl # terminate line
movl 4*vrlbl(r10),r9 # point back to trblk
#
# MERGE HERE TO JUMP TO LABEL
#
bvrt2: movl 4*trlbl(r9),r9 # load pointer to actual code
movl (r9),r11 # execute statement at label
jmp (r11)
#page
#
# 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: # entry point
movl (sp),r7 # load value (leave copy on stack)
subl2 $4*vrsto,r9 # point to vrblk
movl r9,r10 # copy vrblk pointer
movl $4*vrval,r6 # set offset
jsb asign # call assignment routine
.long exfal # fail if assignment fails
jmp exits # else return with result on stack
#page
#
# XNBLK
#
# THE ROUTINE FOR AN XNBLK IS NEVER EXECUTED
#
.align 2
.word bl$xn
b$xnt: # entry point (xnblk)
#page
#
# XRBLK
#
# THE ROUTINE FOR AN XRBLK IS NEVER EXECUTED
#
.align 2
.word bl$xr
b$xrt: # entry point (xrblk)
#
# MARK ENTRY ADDRESS PAST LAST BLOCK ACTION ROUTINE
#
.align 2
.word bl$$i
b$yyy: # last block routine entry point
#title 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.
#
.align 2
.word bl$$i
p$aaa: # 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)).
#page
#
# 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
# +---+
#page
#
# 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
#page
#
# 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.
#page
#
# 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.
#page
#
# 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.
#page
#
# 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.
#page
#
# 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
#page
#
# 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.
#page
#
# 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.
#page
#
# ARBNO
#
# SEE COMPOUND PATTERNS SECTION FOR STUCTURE AND
# ALGORITHM FOR MATCHING THIS NODE TYPE.
#
# NO PARAMETERS
#
.align 2
.word bl$p0
p$aba: # p0blk
movl r7,-(sp) # stack cursor
movl r9,-(sp) # stack dummy node ptr
movl pmhbs,-(sp) # stack old stack base ptr
movl $ndabb,-(sp) # stack ptr to node ndabb
movl sp,pmhbs # store new stack base ptr
jmp succp # succeed
#page
#
# ARBNO (REMOVE P$ABA SPECIAL STACK ENTRY)
#
# NO PARAMETERS (DUMMY PATTERN)
#
p$abb: # entry point
movl r7,pmhbs # restore history stack base ptr
jmp flpop # fail and pop dummy node ptr
#page
#
# ARBNO (CHECK IF ARG MATCHED NULL STRING)
#
# NO PARAMETERS (DUMMY PATTERN)
#
.align 2
.word bl$p0
p$abc: # p0blk
movl pmhbs,r10 # keep p$abb stack base
movl 4*3(r10),r6 # load initial cursor
movl 4*1(r10),pmhbs # restore outer stack base ptr
cmpl r10,sp # jump if no history stack entries
beqlu pabc1
movl r10,-(sp) # else save inner pmhbs entry
movl $ndabd,-(sp) # stack ptr to special node ndabd
jmp pabc2 # merge
#
# OPTIMISE CASE OF NO EXTRA ENTRIES ON STACK FROM ARBNO ARG
#
pabc1: addl2 $4*num04,sp # remove ndabb entry and cursor
#
# MERGE TO CHECK FOR MATCHING OF NULL STRING
#
pabc2: cmpl r6,r7 # allow further attempt if non-null
beqlu 0f
jmp succp
0:
movl 4*pthen(r9),r9 # bypass alternative node so as to ..
jmp succp # ... refuse further match attempts
#page
#
# ARBNO (TRY FOR ALTERNATIVES IN ARBNO ARGUMENT)
#
# NO PARAMETERS (DUMMY PATTERN)
#
p$abd: # entry point
movl r7,pmhbs # restore inner stack base ptr
jmp failp # and fail
#page
#
# ABORT
#
# NO PARAMETERS
#
.align 2
.word bl$p0
p$abo: # p0blk
jmp exfal # signal statement failure
#page
#
# ALTERNATION
#
# PARM1 ALTERNATIVE NODE
#
.align 2
.word bl$p1
p$alt: # p1blk
movl r7,-(sp) # stack cursor
movl 4*parm1(r9),-(sp)# stack pointer to alternative
jsb sbchk # check for stack overflow
jmp succp # if all ok, then succeed
#page
#
# ANY (ONE CHARACTER ARGUMENT) (1-CHAR STRING ALSO)
#
# PARM1 CHARACTER ARGUMENT
#
.align 2
.word bl$p1
p$ans: # p1blk
cmpl r7,pmssl # fail if no chars left
bnequ 0f
jmp failp
0:
movl r$pms,r10 # else point to subject string
movab cfp$f(r10)[r7],r10 # point to current character
movzbl (r10),r6 # load current character
cmpl r6,4*parm1(r9) # fail if no match
beqlu 0f
jmp failp
0:
incl r7 # else bump cursor
jmp succp # and succeed
#page
#
# ANY (MULTI-CHARACTER ARGUMENT CASE)
#
# PARM1 POINTER TO CTBLK
# PARM2 BIT MASK TO SELECT BIT IN CTBLK
#
.align 2
.word bl$p2
p$any: # p2blk
#
# EXPRESSION ARGUMENT CASE MERGES HERE
#
pany1: cmpl r7,pmssl # fail if no characters left
bnequ 0f
jmp failp
0:
movl r$pms,r10 # else point to subject string
movab cfp$f(r10)[r7],r10 # get char ptr to current character
movzbl (r10),r6 # load current character
movl 4*parm1(r9),r10 # point to ctblk
moval 0[r6],r6 # change to byte offset
addl2 r6,r10 # point to entry in ctblk
movl 4*ctchs(r10),r6 # load word from ctblk
mcoml 4*parm2(r9),r11 # and with selected bit
bicl2 r11,r6
bnequ 0f # fail if no match
jmp failp
0:
incl r7 # else bump cursor
jmp succp # and succeed
#page
#
# ANY (EXPRESSION ARGUMENT)
#
# PARM1 EXPRESSION POINTER
#
.align 2
.word bl$p1
p$ayd: # p1blk
jsb evals # evaluate string argument
.long er_043 # any evaluated argument is not string
.long failp # fail if evaluation failure
.long pany1 # merge multi-char case if ok
#page
#
# 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)
#
.align 2
.word bl$p0
p$arb: # p0blk
movl 4*pthen(r9),r9 # load successor pointer
movl r7,-(sp) # stack dummy cursor
movl r9,-(sp) # stack successor pointer
movl r7,-(sp) # stack cursor
movl $ndarc,-(sp) # stack ptr to special node ndarc
movl (r9),r11 # execute next node matching null
jmp (r11)
#page
#
# P$ARC EXTEND ARB MATCH
#
# NO PARAMETERS (DUMMY PATTERN)
#
p$arc: # entry point
cmpl r7,pmssl # fail and pop stack to successor
bnequ 0f
jmp flpop
0:
incl r7 # else bump cursor
movl r7,-(sp) # stack updated cursor
movl r9,-(sp) # restack pointer to ndarc node
movl 4*2(sp),r9 # load successor pointer
movl (r9),r11 # off to reexecute successor node
jmp (r11)
#page
#
# BAL
#
# NO PARAMETERS
#
# THE P$BAL NODE IS PART OF THE COMPOUND STRUCTURE BUILT
# FOR BAL (SEE SECTION ON COMPOUND PATTERNS).
#
.align 2
.word bl$p0
p$bal: # p0blk
clrl r8 # zero parentheses level counter
movl r$pms,r10 # point to subject string
movab cfp$f(r10)[r7],r10 # point to current character
jmp pbal2 # jump into scan loop
#
# LOOP TO SCAN OUT CHARACTERS
#
pbal1: movzbl (r10)+,r6 # load next character, bump pointer
incl r7 # push cursor for character
cmpl r6,$ch$pp # jump if left paren
beqlu pbal3
cmpl r6,$ch$rp # jump if right paren
beqlu pbal4
tstl r8 # else succeed if at outer level
beqlu pbal5
#
# HERE AFTER PROCESSING ONE CHARACTER
#
pbal2: cmpl r7,pmssl # loop back unless end of string
bnequ pbal1
jmp failp # in which case, fail
#
# HERE ON LEFT PAREN
#
pbal3: incl r8 # bump paren level
jmp pbal2 # loop back to check end of string
#
# HERE FOR RIGHT PAREN
#
pbal4: tstl r8 # fail if no matching left paren
bnequ 0f
jmp failp
0:
decl r8 # else decrement level counter
bnequ pbal2 # loop back if not at outer level
#
# HERE AFTER SUCCESSFULLY SCANNING A BALANCED STRING
#
pbal5: movl r7,-(sp) # stack cursor
movl r9,-(sp) # stack ptr to bal node for extend
jmp succp # and succeed
#page
#
# BREAK (EXPRESSION ARGUMENT)
#
# PARM1 EXPRESSION POINTER
#
.align 2
.word bl$p1
p$bkd: # p1blk
jsb evals # evaluate string expression
.long er_044 # break evaluated argument is not string
.long failp # fail if evaluation fails
.long pbrk1 # merge with multi-char case if ok
#page
#
# BREAK (ONE CHARACTER ARGUMENT)
#
# PARM1 CHARACTER ARGUMENT
#
.align 2
.word bl$p1
p$bks: # p1blk
movl pmssl,r8 # get subject string length
subl2 r7,r8 # get number of characters left
bnequ 0f # fail if no characters left
jmp failp
0:
# set counter for chars left
movl r$pms,r10 # point to subject string
movab cfp$f(r10)[r7],r10 # point to current character
#
# LOOP TO SCAN TILL BREAK CHARACTER FOUND
#
pbks1: movzbl (r10)+,r6 # load next char, bump pointer
cmpl r6,4*parm1(r9) # succeed if break character found
bnequ 0f
jmp succp
0:
incl r7 # else push cursor
sobgtr r8,pbks1 # loop back if more to go
jmp failp # fail if end of string, no break chr
#page
#
# BREAK (MULTI-CHARACTER ARGUMENT)
#
# PARM1 POINTER TO CTBLK
# PARM2 BIT MASK TO SELECT BIT COLUMN
#
.align 2
.word bl$p2
p$brk: # p2blk
#
# EXPRESSION ARGUMENT MERGES HERE
#
pbrk1: movl pmssl,r8 # load subject string length
subl2 r7,r8 # get number of characters left
bnequ 0f # fail if no characters left
jmp failp
0:
# set counter for characters left
movl r$pms,r10 # else point to subject string
movab cfp$f(r10)[r7],r10 # point to current character
movl r9,psave # save node pointer
#
# LOOP TO SEARCH FOR BREAK CHARACTER
#
pbrk2: movzbl (r10)+,r6 # load next char, bump pointer
movl 4*parm1(r9),r9 # load pointer to ctblk
moval 0[r6],r6 # convert to byte offset
addl2 r6,r9 # point to ctblk entry
movl 4*ctchs(r9),r6 # load ctblk word
movl psave,r9 # restore node pointer
mcoml 4*parm2(r9),r11 # and with selected bit
bicl2 r11,r6
beqlu 0f # succeed if break character found
jmp succp
0:
incl r7 # else push cursor
sobgtr r8,pbrk2 # loop back unless end of string
jmp failp # fail if end of string, no break chr
#page
#
# 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
#
.align 2
.word bl$p0
p$bkx: # p0blk
incl r7 # step cursor past previous break chr
jmp succp # succeed to rematch break
#page
#
# 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
#
.align 2
.word bl$p1
p$bxd: # p1blk
jsb evals # evaluate string argument
.long er_045 # breakx evaluated argument is not string
.long failp # fail if evaluation fails
.long pbrk1 # merge with break if all ok
#page
#
# CURSOR ASSIGNMENT
#
# PARM1 NAME BASE
# PARM2 NAME OFFSET
#
.align 2
.word bl$p2
p$cas: # p2blk
movl r9,-(sp) # save node pointer
movl r7,-(sp) # save cursor
movl 4*parm1(r9),r10 # load name base
movl r7,r5 # load cursor as integer
movl 4*parm2(r9),r7 # load name offset
jsb icbld # get icblk for cursor value
movl r7,r6 # move name offset
movl r9,r7 # move value to assign
jsb asinp # perform assignment
.long flpop # fail on assignment failure
movl (sp)+,r7 # else restore cursor
movl (sp)+,r9 # restore node pointer
jmp succp # and succeed matching null
#page
#
# EXPRESSION NODE (P$EXA, INITIAL ENTRY)
#
# SEE COMPOUND PATTERNS DESCRIPTION FOR THE STRUCTURE AND
# ALGORITHMS FOR HANDLING EXPRESSION NODES.
#
# PARM1 EXPRESSION POINTER
#
.align 2
.word bl$p1
p$exa: # p1blk
jsb evalp # evaluate expression
.long failp # fail if evaluation fails
cmpl r6,$p$aaa # jump if result is not a pattern
blequ pexa1
#
# HERE IF RESULT OF EXPRESSION IS A PATTERN
#
movl r7,-(sp) # stack dummy cursor
movl r9,-(sp) # stack ptr to p$exa node
movl pmhbs,-(sp) # stack history stack base ptr
movl $ndexb,-(sp) # stack ptr to special node ndexb
movl sp,pmhbs # store new stack base pointer
movl r10,r9 # copy node pointer
movl (r9),r11 # match first node in expression pat
jmp (r11)
#
# HERE IF RESULT OF EXPRESSION IS NOT A PATTERN
#
pexa1: cmpl r6,$b$scl # jump if it is already a string
beqlu pexa2
movl r10,-(sp) # else stack result
movl r9,r10 # save node pointer
jsb gtstg # convert result to string
.long er_046 # expression does not evaluate to pattern
movl r9,r8 # copy string pointer
movl r10,r9 # restore node pointer
movl r8,r10 # copy string pointer again
#
# MERGE HERE WITH STRING POINTER IN XL
#
pexa2: tstl 4*sclen(r10) # just succeed if null string
bnequ 0f
jmp succp
0:
jmp pstr1 # else merge with string circuit
#page
#
# 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: # entry point
movl r7,pmhbs # restore outer level stack pointer
jmp flpop # fail and pop p$exa node ptr
#page
#
# 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: # entry point
movl r7,pmhbs # restore inner stack base pointer
jmp failp # and fail into expr pattern alternvs
#page
#
# FAIL
#
# NO PARAMETERS
#
.align 2
.word bl$p0
p$fal: # p0blk
jmp failp # just signal failure
#page
#
# FENCE
#
# SEE COMPOUND PATTERNS SECTION FOR THE STRUCTURE AND
# ALGORITHM FOR MATCHING THIS NODE TYPE.
#
# NO PARAMETERS
#
.align 2
.word bl$p0
p$fen: # p0blk
movl r7,-(sp) # stack dummy cursor
movl $ndabo,-(sp) # stack ptr to abort node
jmp succp # and succeed matching null
#page
#
# FENCE (FUNCTION)
#
# SEE COMPOUND PATTERNS COMMENTS AT START OF THIS SECTION
# FOR DETAILS OF SCHEME
#
# NO PARAMETERS
#
.align 2
.word bl$p0
p$fna: # p0blk
movl pmhbs,-(sp) # stack current history stack base
movl $ndfnb,-(sp) # stack indir ptr to p$fnb (failure)
movl sp,pmhbs # begin new history stack
jmp succp # succeed
#page
#
# FENCE (FUNCTION) (RESET HISTORY STACK AND FAIL)
#
# NO PARAMETERS (DUMMY PATTERN)
#
.align 2
.word bl$p0
p$fnb: # p0blk
movl r7,pmhbs # restore outer pmhbs stack base
jmp failp # ...and fail
#page
#
# FENCE (FUNCTION) (MAKE FENCE TRAP ENTRY ON STACK)
#
# NO PARAMETERS (DUMMY PATTERN)
#
.align 2
.word bl$p0
p$fnc: # p0blk
movl pmhbs,r10 # get inner stack base ptr
movl 4*num01(r10),pmhbs # restore outer stack base
cmpl r10,sp # optimize if no alternatives
beqlu pfnc1
movl r10,-(sp) # else stack inner stack base
movl $ndfnd,-(sp) # stack ptr to ndfnd
jmp succp # succeed
#
# HERE WHEN FENCE FUNCTION LEFT NOTHING ON THE STACK
#
pfnc1: addl2 $4*num02,sp # pop off p$fnb entry
jmp succp # succeed
#page
#
# FENCE (FUNCTION) (SKIP PAST ALTERNATIVES ON FAILURE)
#
# NO PARAMETERS (DUMMY PATTERN)
#
.align 2
.word bl$p0
p$fnd: # p0blk
movl r7,sp # pop stack to fence() history base
jmp flpop # pop base entry and fail
#page
#
# 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
#
.align 2
.word bl$p0
p$ima: # p0blk
movl r7,-(sp) # stack cursor
movl r9,-(sp) # stack dummy node pointer
movl pmhbs,-(sp) # stack old stack base pointer
movl $ndimb,-(sp) # stack ptr to special node ndimb
movl sp,pmhbs # store new stack base pointer
jmp succp # and succeed
#page
#
# 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: # entry point
movl r7,pmhbs # restore history stack base ptr
jmp flpop # fail and pop dummy node ptr
#page
#
# 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
#
.align 2
.word bl$p2
p$imc: # p2blk
movl pmhbs,r10 # load pointer to p$imb entry
movl r7,r6 # copy final cursor
movl 4*3(r10),r7 # load initial cursor
movl 4*1(r10),pmhbs # restore outer stack base pointer
cmpl r10,sp # jump if no history stack entries
beqlu pimc1
movl r10,-(sp) # else save inner pmhbs pointer
movl $ndimd,-(sp) # and a ptr to special node ndimd
jmp pimc2 # merge
#
# HERE IF NO ENTRIES MADE ON HISTORY STACK
#
pimc1: addl2 $4*num04,sp # remove ndimb entry and cursor
#
# MERGE HERE TO PERFORM ASSIGNMENT
#
pimc2: movl r6,-(sp) # save current (final) cursor
movl r9,-(sp) # save current node pointer
movl r$pms,r10 # point to subject string
subl2 r7,r6 # compute substring length
jsb sbstr # build substring
movl r9,r7 # move result
movl (sp),r9 # reload node pointer
movl 4*parm1(r9),r10 # load name base
movl 4*parm2(r9),r6 # load name offset
jsb asinp # perform assignment
.long flpop # fail if assignment fails
movl (sp)+,r9 # else restore node pointer
movl (sp)+,r7 # restore cursor
jmp succp # and succeed
#page
#
# 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: # entry point
movl r7,pmhbs # restore inner stack base pointer
jmp failp # and fail
#page
#
# LEN (INTEGER ARGUMENT)
#
# PARM1 INTEGER ARGUMENT
#
.align 2
.word bl$p1
p$len: # p1blk
#
# EXPRESSION ARGUMENT CASE MERGES HERE
#
plen1: addl2 4*parm1(r9),r7 # push cursor indicated amount
cmpl r7,pmssl # succeed if not off end
bgtru 0f
jmp succp
0:
jmp failp # else fail
#page
#
# LEN (EXPRESSION ARGUMENT)
#
# PARM1 EXPRESSION POINTER
#
.align 2
.word bl$p1
p$lnd: # p1blk
jsb evali # evaluate integer argument
.long er_047 # len evaluated argument is not integer
.long er_048 # len evaluated argument is negative or too large
.long failp # fail if evaluation fails
.long plen1 # merge with normal circuit if ok
#page
#
# NOTANY (EXPRESSION ARGUMENT)
#
# PARM1 EXPRESSION POINTER
#
.align 2
.word bl$p1
p$nad: # p1blk
jsb evals # evaluate string argument
.long er_049 # notany evaluated argument is not string
.long failp # fail if evaluation fails
.long pnay1 # merge with multi-char case if ok
#page
#
# NOTANY (ONE CHARACTER ARGUMENT)
#
# PARM1 CHARACTER ARGUMENT
#
.align 2
.word bl$p1
p$nas: # entry point
cmpl r7,pmssl # fail if no chars left
bnequ 0f
jmp failp
0:
movl r$pms,r10 # else point to subject string
movab cfp$f(r10)[r7],r10 # point to current character in strin
movzbl (r10),r6 # load current character
cmpl r6,4*parm1(r9) # fail if match
bnequ 0f
jmp failp
0:
incl r7 # else bump cursor
jmp succp # and succeed
#page
#
# NOTANY (MULTI-CHARACTER STRING ARGUMENT)
#
# PARM1 POINTER TO CTBLK
# PARM2 BIT MASK TO SELECT BIT COLUMN
#
.align 2
.word bl$p2
p$nay: # p2blk
#
# EXPRESSION ARGUMENT CASE MERGES HERE
#
pnay1: cmpl r7,pmssl # fail if no characters left
bnequ 0f
jmp failp
0:
movl r$pms,r10 # else point to subject string
movab cfp$f(r10)[r7],r10 # point to current character
movzbl (r10),r6 # load current character
moval 0[r6],r6 # convert to byte offset
movl 4*parm1(r9),r10 # load pointer to ctblk
addl2 r6,r10 # point to entry in ctblk
movl 4*ctchs(r10),r6 # load entry from ctblk
mcoml 4*parm2(r9),r11 # and with selected bit
bicl2 r11,r6
beqlu 0f # fail if character is matched
jmp failp
0:
incl r7 # else bump cursor
jmp succp # and succeed
#page
#
# 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: # entry point
movl pmhbs,r10 # load pointer to base of stack
movl 4*1(r10),r6 # load saved pmhbs (or pattern type)
cmpl r6,$num02 # jump if outer level (pattern type)
blequ pnth2
#
# HERE WE ARE AT THE END OF MATCHING AN EXPRESSION PATTERN
#
movl r6,pmhbs # restore outer stack base pointer
movl 4*2(r10),r9 # restore pointer to p$exa node
cmpl r10,sp # jump if no history stack entries
beqlu pnth1
movl r10,-(sp) # else stack inner stack base ptr
movl $ndexc,-(sp) # stack ptr to special node ndexc
jmp succp # and succeed
#
# HERE IF NO HISTORY STACK ENTRIES DURING PATTERN
#
pnth1: addl2 $4*num04,sp # remove p$exb entry and node ptr
jmp succp # and succeed
#
# HERE IF END OF MATCH AT OUTER LEVEL
#
pnth2: movl r7,pmssl # save final cursor in safe place
tstl pmdfl # jump if no pattern assignments
beqlu pnth6
#page
#
# 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: subl2 $4,r10 # point past cursor entry
movl -(r10),r6 # load node pointer
cmpl r6,$ndpad # jump if ndpad entry
beqlu pnth4
cmpl r6,$ndpab # jump if not ndpab entry
bnequ pnth5
#
# HERE FOR NDPAB ENTRY, STACK INITIAL CURSOR
# NOTE THAT THERE MUST BE MORE ENTRIES ON THE STACK.
#
movl 4*1(r10),-(sp) # stack initial cursor
jsb sbchk # check for stack overflow
jmp pnth3 # loop back if ok
#
# HERE FOR NDPAD ENTRY. THE STARTING CURSOR FROM THE
# MATCHING NDPAD ENTRY IS NOW THE TOP STACK ENTRY.
#
pnth4: movl 4*1(r10),r6 # load final cursor
movl (sp),r7 # load initial cursor from stack
movl r10,(sp) # save history stack scan ptr
subl2 r7,r6 # compute length of string
#
# BUILD SUBSTRING AND PERFORM ASSIGNMENT
#
movl r$pms,r10 # point to subject string
jsb sbstr # construct substring
movl r9,r7 # copy substring pointer
movl (sp),r10 # reload history stack scan ptr
movl 4*2(r10),r10 # load pointer to p$pac node with nam
movl 4*parm2(r10),r6 # load name offset
movl 4*parm1(r10),r10# load name base
jsb asinp # perform assignment
.long exfal # match fails if name eval fails
movl (sp)+,r10 # else restore history stack ptr
#page
#
# END OF PATTERN MATCH (CONTINUED)
#
# HERE CHECK FOR END OF ENTRIES
#
pnth5: cmpl r10,sp # loop if more entries to scan
bnequ pnth3
#
# HERE AFTER DEALING WITH PATTERN ASSIGNMENTS
#
pnth6: movl pmhbs,sp # wipe out history stack
movl (sp)+,r7 # load initial cursor
movl (sp)+,r8 # load match type code
movl pmssl,r6 # load final cursor value
movl r$pms,r10 # point to subject string
clrl r$pms # clear subject string ptr for gbcol
tstl r8 # jump if call by name
beqlu pnth7
cmpl r8,$num02 # exit if statement level call
bnequ 0f
jmp exits
0:
#
# HERE WE HAVE A CALL BY VALUE, BUILD SUBSTRING
#
subl2 r7,r6 # compute length of string
jsb sbstr # build substring
jmp exixr # and exit with substring value
#
# HERE FOR CALL BY NAME, MAKE STACK ENTRIES FOR O$RPL
#
pnth7: movl r7,-(sp) # stack initial cursor
movl r6,-(sp) # stack final cursor
tstl r$pmb # skip if subject not buffer
beqlu pnth8
movl r$pmb,r10 # else get ptr to bcblk instead
#
# HERE WITH XL POINTING TO SCBLK OR BCBLK
#
pnth8: movl r10,-(sp) # stack subject pointer
jmp exits # exit with special entry on stack
#page
#
# POS (INTEGER ARGUMENT)
#
# PARM1 INTEGER ARGUMENT
#
.align 2
.word bl$p1
p$pos: # p1blk
#
# EXPRESSION ARGUMENT CASE MERGES HERE
#
ppos1: cmpl r7,4*parm1(r9) # succeed if at right location
bnequ 0f
jmp succp
0:
jmp failp # else fail
#page
#
# POS (EXPRESSION ARGUMENT)
#
# PARM1 EXPRESSION POINTER
#
.align 2
.word bl$p1
p$psd: # p1blk
jsb evali # evaluate integer argument
.long er_050 # pos evaluated argument is not integer
.long er_051 # pos evaluated argument is negative or too large
.long failp # fail if evaluation fails
.long ppos1 # merge with normal case if ok
#page
#
# PATTERN ASSIGNMENT (INITIAL ENTRY, SAVE CURSOR)
#
# SEE COMPOUND PATTERNS DESCRIPTION FOR THE STRUCTURE AND
# ALGORITHMS FOR MATCHING THIS NODE TYPE.
#
# NO PARAMETERS
#
.align 2
.word bl$p0
p$paa: # p0blk
movl r7,-(sp) # stack initial cursor
movl $ndpab,-(sp) # stack ptr to ndpab special node
jmp succp # and succeed matching null
#page
#
# 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: # entry point
jmp failp # just fail (entry is already popped)
#page
#
# 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
#
.align 2
.word bl$p2
p$pac: # p2blk
movl r7,-(sp) # stack dummy cursor value
movl r9,-(sp) # stack pointer to p$pac node
movl r7,-(sp) # stack final cursor
movl $ndpad,-(sp) # stack ptr to special ndpad node
movl sp,pmdfl # set dot flag non-zero
jmp succp # and succeed
#page
#
# 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: # entry point
jmp flpop # fail and remove p$pac node
#page
#
# REM
#
# NO PARAMETERS
#
.align 2
.word bl$p0
p$rem: # p0blk
movl pmssl,r7 # point cursor to end of string
jmp succp # and succeed
#page
#
# RPOS (EXPRESSION ARGUMENT)
#
# PARM1 EXPRESSION POINTER
#
.align 2
.word bl$p1
p$rpd: # p1blk
jsb evali # evaluate integer argument
.long er_052 # rpos evaluated argument is not integer
.long er_053 # rpos evaluated argument is negative or too large
.long failp # fail if evaluation fails
.long prps1 # merge with normal case if ok
#page
#
# RPOS (INTEGER ARGUMENT)
#
# PARM1 INTEGER ARGUMENT
#
.align 2
.word bl$p1
p$rps: # p1blk
#
# EXPRESSION ARGUMENT CASE MERGES HERE
#
prps1: movl pmssl,r8 # get length of string
subl2 r7,r8 # get number of characters remaining
cmpl r8,4*parm1(r9) # succeed if at right location
bnequ 0f
jmp succp
0:
jmp failp # else fail
#page
#
# RTAB (INTEGER ARGUMENT)
#
# PARM1 INTEGER ARGUMENT
#
.align 2
.word bl$p1
p$rtb: # p1blk
#
# EXPRESSION ARGUMENT CASE MERGES HERE
#
prtb1: movl r7,r8 # save initial cursor
movl pmssl,r7 # point to end of string
cmpl r7,4*parm1(r9) # fail if string not long enough
bgequ 0f
jmp failp
0:
subl2 4*parm1(r9),r7 # else set new cursor
cmpl r7,r8 # and succeed if not too far already
blssu 0f
jmp succp
0:
jmp failp # in which case, fail
#page
#
# RTAB (EXPRESSION ARGUMENT)
#
# PARM1 EXPRESSION POINTER
#
.align 2
.word bl$p1
p$rtd: # p1blk
jsb evali # evaluate integer argument
.long er_054 # rtab evaluated argument is not integer
.long er_055 # rtab evaluated argument is negative or too large
.long failp # fail if evaluation fails
.long prtb1 # merge with normal case if success
#page
#
# SPAN (EXPRESSION ARGUMENT)
#
# PARM1 EXPRESSION POINTER
#
.align 2
.word bl$p1
p$spd: # p1blk
jsb evals # evaluate string argument
.long er_056 # span evaluated argument is not string
.long failp # fail if evaluation fails
.long pspn1 # merge with multi-char case if ok
#page
#
# SPAN (MULTI-CHARACTER ARGUMENT CASE)
#
# PARM1 POINTER TO CTBLK
# PARM2 BIT MASK TO SELECT BIT COLUMN
#
.align 2
.word bl$p2
p$spn: # p2blk
#
# EXPRESSION ARGUMENT CASE MERGES HERE
#
pspn1: movl pmssl,r8 # copy subject string length
subl2 r7,r8 # calculate number of characters left
bnequ 0f # fail if no characters left
jmp failp
0:
movl r$pms,r10 # point to subject string
movab cfp$f(r10)[r7],r10 # point to current character
movl r7,psavc # save initial cursor
movl r9,psave # save node pointer
# set counter for chars left
#
# LOOP TO SCAN MATCHING CHARACTERS
#
pspn2: movzbl (r10)+,r6 # load next character, bump pointer
moval 0[r6],r6 # convert to byte offset
movl 4*parm1(r9),r9 # point to ctblk
addl2 r6,r9 # point to ctblk entry
movl 4*ctchs(r9),r6 # load ctblk entry
movl psave,r9 # restore node pointer
mcoml 4*parm2(r9),r11 # and with selected bit
bicl2 r11,r6
beqlu pspn3 # jump if no match
incl r7 # else push cursor
sobgtr r8,pspn2 # loop back unless end of string
#
# HERE AFTER SCANNING MATCHING CHARACTERS
#
pspn3: cmpl r7,psavc # succeed if chars matched
beqlu 0f
jmp succp
0:
jmp failp # else fail if null string matched
#page
#
# SPAN (ONE CHARACTER ARGUMENT)
#
# PARM1 CHARACTER ARGUMENT
#
.align 2
.word bl$p1
p$sps: # p1blk
movl pmssl,r8 # get subject string length
subl2 r7,r8 # calculate number of characters left
bnequ 0f # fail if no characters left
jmp failp
0:
movl r$pms,r10 # else point to subject string
movab cfp$f(r10)[r7],r10 # point to current character
movl r7,psavc # save initial cursor
# set counter for characters left
#
# LOOP TO SCAN MATCHING CHARACTERS
#
psps1: movzbl (r10)+,r6 # load next character, bump pointer
cmpl r6,4*parm1(r9) # jump if no match
bnequ psps2
incl r7 # else push cursor
sobgtr r8,psps1 # and loop unless end of string
#
# HERE AFTER SCANNING MATCHING CHARACTERS
#
psps2: cmpl r7,psavc # succeed if chars matched
beqlu 0f
jmp succp
0:
jmp failp # fail if null string matched
#page
#
# 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
#
.align 2
.word bl$p1
p$str: # p1blk
movl 4*parm1(r9),r10 # get pointer to string
#
# MERGE HERE AFTER EVALUATING EXPRESSION WITH STRING VALUE
#
pstr1: movl r9,psave # save node pointer
movl r$pms,r9 # load subject string pointer
movab cfp$f(r9)[r7],r9# point to current character
addl2 4*sclen(r10),r7 # compute new cursor position
cmpl r7,pmssl # fail if past end of string
blequ 0f
jmp failp
0:
movl r7,psavc # save updated cursor
movl 4*sclen(r10),r6 # get number of chars to compare
movab cfp$f(r10),r10 # point to chars of test string
jsb sbcmc # compare, fail if not equal
.long failp
.long failp
movl psave,r9 # if all matched, restore node ptr
movl psavc,r7 # restore updated cursor
jmp succp # and succeed
#page
#
# SUCCEED
#
# SEE SECTION ON COMPOUND PATTERNS FOR DETAILS OF THE
# STRUCTURE AND ALGORITHMS FOR MATCHING THIS NODE TYPE
#
# NO PARAMETERS
#
.align 2
.word bl$p0
p$suc: # p0blk
movl r7,-(sp) # stack cursor
movl r9,-(sp) # stack pointer to this node
jmp succp # succeed matching null
#page
#
# TAB (INTEGER ARGUMENT)
#
# PARM1 INTEGER ARGUMENT
#
.align 2
.word bl$p1
p$tab: # p1blk
#
# EXPRESSION ARGUMENT CASE MERGES HERE
#
ptab1: cmpl r7,4*parm1(r9) # fail if too far already
blequ 0f
jmp failp
0:
movl 4*parm1(r9),r7 # else set new cursor position
cmpl r7,pmssl # succeed if not off end
bgtru 0f
jmp succp
0:
jmp failp # else fail
#page
#
# TAB (EXPRESSION ARGUMENT)
#
# PARM1 EXPRESSION POINTER
#
.align 2
.word bl$p1
p$tbd: # p1blk
jsb evali # evaluate integer argument
.long er_057 # tab evaluated argument is not integer
.long er_058 # tab evaluated argument is negative or too large
.long failp # fail if evaluation fails
.long ptab1 # merge with normal case if ok
#page
#
# ANCHOR MOVEMENT
#
# NO PARAMETERS (DUMMY NODE)
#
p$una: # entry point
movl r7,r9 # copy initial pattern node pointer
movl (sp),r7 # get initial cursor
cmpl r7,pmssl # match fails if at end of string
bnequ 0f
jmp exfal
0:
incl r7 # else increment cursor
movl r7,(sp) # store incremented cursor
movl r9,-(sp) # restack initial node ptr
movl $nduna,-(sp) # restack unanchored node
movl (r9),r11 # rematch first node
jmp (r11)
#page
#
# 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
#
.align 2
.word bl$$i
p$yyy: # mark last entry in pattern section
#title 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.
#page
#
# ANY
#
s$any: # entry point
movl $p$ans,r7 # set pcode for single char case
movl $p$any,r10 # pcode for multi-char case
movl $p$ayd,r8 # pcode for expression case
jsb patst # call common routine to build node
.long er_059 # any argument is not string or expression
jmp exixr # jump for next code word
#page
#
# APPEND
#
s$apn: # entry point
movl (sp)+,r10 # get append argument
movl (sp)+,r9 # get bcblk
cmpl (r9),$b$bct # ok if first arg is bcblk
beqlu sapn1
jmp er_275 # append first argument is not buffer
#
# HERE TO DO THE APPEND
#
sapn1: jsb apndb # do the append
.long er_276 # append second argument is not string
.long exfal # no room - fail
jmp exnul # exit with null result
#page
#
# APPLY
#
# APPLY DOES NOT PERMIT THE DIRECT (FAST) CALL SO THAT
# WA CONTAINS THE ACTUAL NUMBER OF ARGUMENTS PASSED.
#
s$app: # entry point
tstl r6 # jump if no arguments
beqlu sapp3
decl r6 # else get applied func arg count
movl r6,r7 # copy
moval 0[r7],r7 # convert to bytes
movl sp,r10 # copy stack pointer
addl2 r7,r10 # point to function argument on stack
movl (r10),r9 # load function ptr (apply 1st arg)
tstl r6 # jump if no args for applied func
beqlu sapp2
movl r6,r7 # else set counter for loop
#
# LOOP TO MOVE ARGUMENTS UP ON STACK
#
sapp1: subl2 $4,r10 # point to next argument
movl (r10),4*1(r10) # move argument up
sobgtr r7,sapp1 # loop till all moved
#
# MERGE HERE TO CALL FUNCTION (WA = NUMBER OF ARGUMENTS)
#
sapp2: addl2 $4,sp # adjust stack ptr for apply 1st arg
jsb gtnvr # get variable block addr for func
.long sapp3 # jump if not natural variable
movl 4*vrfnc(r9),r10 # else point to function block
jmp cfunc # go call applied function
#
# HERE FOR INVALID FIRST ARGUMENT
#
sapp3: jmp er_060 # apply first arg is not natural variable name
#page
#
# ARBNO
#
# ARBNO BUILDS A COMPOUND PATTERN. SEE DESCRIPTION AT
# START OF PATTERN MATCHING SECTION FOR STRUCTURE FORMED.
#
s$abn: # entry point
clrl r9 # set parm1 = 0 for the moment
movl $p$alt,r7 # set pcode for alternative node
jsb pbild # build alternative node
movl r9,r10 # save ptr to alternative pattern
movl $p$abc,r7 # pcode for p$abc
clrl r9 # p0blk
jsb pbild # build p$abc node
movl r10,4*pthen(r9) # put alternative node as successor
movl r10,r6 # remember alternative node pointer
movl r9,r10 # copy p$abc node ptr
movl (sp),r9 # load arbno argument
movl r6,(sp) # stack alternative node pointer
jsb gtpat # get arbno argument as pattern
.long er_061 # arbno argument is not pattern
jsb pconc # concat arg with p$abc node
movl r9,r10 # remember ptr to concd patterns
movl $p$aba,r7 # pcode for p$aba
clrl r9 # p0blk
jsb pbild # build p$aba node
movl r10,4*pthen(r9) # concatenate nodes
movl (sp),r10 # recall ptr to alternative node
movl r9,4*parm1(r10) # point alternative back to argument
jmp exits # jump for next code word
#page
#
# ARG
#
s$arg: # entry point
jsb gtsmi # get second arg as small integer
.long er_062 # arg second argument is not integer
.long exfal # fail if out of range or negative
movl r9,r6 # save argument number
movl (sp)+,r9 # load first argument
jsb gtnvr # locate vrblk
.long sarg1 # jump if not natural variable
movl 4*vrfnc(r9),r9 # else load function block pointer
cmpl (r9),$b$pfc # jump if not program defined
bnequ sarg1
tstl r6 # fail if arg number is zero
bnequ 0f
jmp exfal
0:
cmpl r6,4*fargs(r9) # fail if arg number is too large
blequ 0f
jmp exfal
0:
moval 0[r6],r6 # else convert to byte offset
addl2 r6,r9 # point to argument selected
movl 4*pfagb(r9),r9 # load argument vrblk pointer
jmp exvnm # exit to build nmblk
#
# HERE IF 1ST ARGUMENT IS BAD
#
sarg1: jmp er_063 # arg first argument is not program function name
#page
#
# ARRAY
#
s$arr: # entry point
movl (sp)+,r10 # load initial element value
movl (sp)+,r9 # load first argument
jsb gtint # convert first arg to integer
.long sar02 # jump if not integer
#
# HERE FOR INTEGER FIRST ARGUMENT, BUILD VCBLK
#
movl 4*icval(r9),r5 # load integer value
bgtr 0f # jump if zero or neg (bad dimension)
jmp sar10
0:
movl r5,r6 # else convert to one word, test ovfl
bgeq 0f
jmp sar11
0:
movl r6,r7 # copy elements for loop later on
addl2 $vcsi$,r6 # add space for standard fields
moval 0[r6],r6 # convert length to bytes
cmpl r6,mxlen # fail if too large
blssu 0f
jmp sar11
0:
jsb alloc # allocate space for vcblk
movl $b$vct,(r9) # store type word
movl r6,4*vclen(r9) # set length
movl r10,r8 # copy default value
movl r9,r10 # copy vcblk pointer
addl2 $4*vcvls,r10 # point to first element value
#
# LOOP TO SET VECTOR ELEMENTS TO DEFAULT VALUE
#
sar01: movl r8,(r10)+ # store one value
sobgtr r7,sar01 # loop till all stored
jmp exsid # exit setting idval
#page
#
# ARRAY (CONTINUED)
#
# HERE IF FIRST ARGUMENT IS NOT AN INTEGER
#
sar02: movl r9,-(sp) # replace argument on stack
jsb xscni # initialize scan of first argument
.long er_064 # array first argument is not integer or string
.long exnul # dummy (unused) null string exit
movl r$xsc,-(sp) # save prototype pointer
movl r10,-(sp) # save default value
clrl arcdm # zero count of dimensions
clrl arptr # zero offset to indicate pass one
movl intv1,r5 # load integer one
movl r5,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: movl intv1,r5 # load one as default low bound
movl r5,arsvl # save as low bound
movl $ch$cl,r8 # set delimiter one = colon
movl $ch$cm,r10 # set delimiter two = comma
jsb xscan # scan next bound
cmpl r6,$num01 # jump if not colon
bnequ sar04
#
# HERE WE HAVE A COLON ENDING A LOW BOUND
#
jsb gtint # convert low bound
.long er_065 # array first argument lower bound is not integer
movl 4*icval(r9),r5 # load value of low bound
movl r5,arsvl # store low bound value
movl $ch$cm,r8 # set delimiter one = comma
movl r8,r10 # and delimiter two = comma
jsb xscan # scan high bound
#page
#
# ARRAY (CONTINUED)
#
# MERGE HERE TO PROCESS UPPER BOUND
#
sar04: jsb gtint # convert high bound to integer
.long er_066 # array first argument upper bound is not integer
movl 4*icval(r9),r5 # get high bound
subl2 arsvl,r5 # subtract lower bound
bvc 0f
jmp sar10
0:
tstl r5 # bad dimension if negative
bgeq 0f
jmp sar10
0:
addl2 intv1,r5 # add 1 to get dimension
bvc 0f
jmp sar10
0:
movl arptr,r10 # load offset (also pass indicator)
beqlu sar05 # jump if first pass
#
# HERE IN SECOND PASS TO STORE LBD AND DIM IN ARBLK
#
addl2 (sp),r10 # point to current location in arblk
movl r5,4*cfp$i(r10) # store dimension
movl arsvl,r5 # load low bound
movl r5,(r10) # store low bound
addl2 $4*ardms,arptr # bump offset to next bounds
jmp sar06 # jump to check for end of bounds
#
# HERE IN PASS 1
#
sar05: incl arcdm # bump dimension count
mull2 arnel,r5 # multiply dimension by count so far
bvc 0f
jmp sar11
0:
movl r5,arnel # else store updated element count
#
# MERGE HERE AFTER PROCESSING ONE SET OF BOUNDS
#
sar06: tstl r6 # loop back unless end of bounds
beqlu 0f
jmp sar03
0:
tstl arptr # jump if end of pass 2
beqlu 0f
jmp sar09
0:
#page
#
# ARRAY (CONTINUED)
#
# HERE AT END OF PASS ONE, BUILD ARBLK
#
movl arnel,r5 # get number of elements
movl r5,r7 # get as addr integer, test ovflo
bgeq 0f
jmp sar11
0:
moval 0[r7],r7 # else convert to length in bytes
movl $4*arsi$,r6 # set size of standard fields
movl arcdm,r8 # set dimension count to control loop
#
# LOOP TO ALLOW SPACE FOR DIMENSIONS
#
sar07: addl2 $4*ardms,r6 # allow space for one set of bounds
sobgtr r8,sar07 # loop back till all accounted for
movl r6,r10 # save size (=arofs)
#
# NOW ALLOCATE SPACE FOR ARBLK
#
addl2 r7,r6 # add space for elements
addl2 $4,r6 # allow for arpro prototype field
cmpl r6,mxlen # fail if too large
blssu 0f
jmp sar11
0:
jsb alloc # else allocate arblk
movl (sp),r7 # load default value
movl r9,(sp) # save arblk pointer
movl r6,r8 # save length in bytes
ashl $-2,r6,r6 # convert length back to words
# set counter to control loop
#
# LOOP TO CLEAR ENTIRE ARBLK TO DEFAULT VALUE
#
sar08: movl r7,(r9)+ # set one word
sobgtr r6,sar08 # loop till all set
#page
#
# ARRAY (CONTINUED)
#
# NOW SET INITIAL FIELDS OF ARBLK
#
movl (sp)+,r9 # reload arblk pointer
movl (sp),r7 # load prototype
movl $b$art,(r9) # set type word
movl r8,4*arlen(r9) # store length in bytes
clrl 4*idval(r9) # zero id till we get it built
movl r10,4*arofs(r9) # set prototype field ptr
movl arcdm,4*arndm(r9)# set number of dimensions
movl r9,r8 # save arblk pointer
addl2 r10,r9 # point to prototype field
movl r7,(r9) # store prototype ptr in arblk
movl $4*arlbd,arptr # set offset for pass 2 bounds scan
movl r7,r$xsc # reset string pointer for xscan
movl r8,(sp) # store arblk pointer on stack
clrl xsofs # reset offset ptr to start of string
jmp sar03 # jump back to rescan bounds
#
# HERE AFTER FILLING IN BOUNDS INFORMATION (END PASS TWO)
#
sar09: movl (sp)+,r9 # reload pointer to arblk
jmp exsid # exit setting idval
#
# HERE FOR BAD DIMENSION
#
sar10: jmp er_067 # array dimension is zero,negative or out of range
#
# HERE IF ARRAY IS TOO LARGE
#
sar11: jmp er_068 # array size exceeds maximum permitted
#page
#
# BUFFER
#
s$buf: # entry point
movl (sp)+,r10 # get initial value
movl (sp)+,r9 # get requested allocation
jsb gtint # convert to integer
.long er_269 # buffer first argument is not integer
movl 4*icval(r9),r5 # get value
bleq sbf01 # branch if negative or zero
movl r5,r6 # move with overflow check
bgeq 0f
jmp sbf02
0:
jsb alobf # allocate the buffer
jsb apndb # copy it in
.long er_270 # buffer second argument is not string or buffer
.long er_271 # buffer initial value too big for allocation
jmp exsid # exit setting idval
#
# HERE FOR INVALID ALLOCATION SIZE
#
sbf01: jmp er_272 # buffer first argument is not positive
#
# HERE FOR ALLOCATION SIZE INTEGER OVERFLOW
#
sbf02: jmp er_273 # buffer size is too big
#page
#
# BREAK
#
s$brk: # entry point
movl $p$bks,r7 # set pcode for single char case
movl $p$brk,r10 # pcode for multi-char case
movl $p$bkd,r8 # pcode for expression case
jsb patst # call common routine to build node
.long er_069 # break argument is not string or expression
jmp exixr # jump for next code word
#page
#
# BREAKX
#
# BREAKX IS A COMPOUND PATTERN. SEE DESCRIPTION AT START
# OF PATTERN MATCHING SECTION FOR STRUCTURE FORMED.
#
s$bkx: # entry point
movl $p$bks,r7 # pcode for single char argument
movl $p$brk,r10 # pcode for multi-char argument
movl $p$bxd,r8 # pcode for expression case
jsb patst # call common routine to build node
.long er_070 # breakx argument is not string or expression
#
# NOW HOOK BREAKX NODE ON AT FRONT END
#
movl r9,-(sp) # save ptr to break node
movl $p$bkx,r7 # set pcode for breakx node
jsb pbild # build it
movl (sp),4*pthen(r9)# set break node as successor
movl $p$alt,r7 # set pcode for alternation node
jsb pbild # build (parm1=alt=breakx node)
movl r9,r6 # save ptr to alternation node
movl (sp),r9 # point to break node
movl r6,4*pthen(r9) # set alternate node as successor
jmp exits # exit with result on stack
#page
#
# CHAR
#
s$chr: # entry point
jsb gtsmi # convert arg to integer
.long er_281 # char argument not integer
.long schr1 # too big error exit
cmpl r8,$cfp$a # see if out of range of host set
bgequ schr1
movl $num01,r6 # if not set scblk allocation
movl r8,r7 # save char code
jsb alocs # allocate 1 bau scblk
movl r9,r10 # copy scblk pointer
movab cfp$f(r10),r10 # get set to stuff char
movb r7,(r10)+ # stuff it
clrl r10 # clear slop in xl
jmp exixr # exit with scblk pointer
#
# HERE IF CHAR ARGUMENT IS OUT OF RANGE
#
schr1: jmp er_282 # char argument not in range
#page
#
# CLEAR
#
s$clr: # entry point
jsb xscni # initialize to scan argument
.long er_071 # clear argument is not string
.long 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: movl $ch$cm,r8 # set delimiter one = comma
movl r8,r10 # delimiter two = comma
jsb xscan # scan next variable name
jsb gtnvr # locate vrblk
.long er_072 # clear argument has null variable name
clrl 4*vrget(r9) # else flag by zeroing vrget field
tstl r6 # loop back if stopped by comma
bnequ sclr1
#
# HERE AFTER FLAGGING VARIABLES IN ARGUMENT LIST
#
sclr2: movl hshtb,r7 # point to start of hash table
#
# LOOP THROUGH SLOTS IN HASH TABLE
#
sclr3: cmpl r7,hshte # exit returning null if none left
bnequ 0f
jmp exnul
0:
movl r7,r9 # else copy slot pointer
addl2 $4,r7 # bump slot pointer
subl2 $4*vrnxt,r9 # set offset to merge into loop
#
# LOOP THROUGH VRBLKS ON ONE HASH CHAIN
#
sclr4: movl 4*vrnxt(r9),r9 # point to next vrblk on chain
beqlu sclr3 # jump for next bucket if chain end
tstl 4*vrget(r9) # jump if not flagged
bnequ sclr5
#page
#
# CLEAR (CONTINUED)
#
# HERE FOR FLAGGED VARIABLE, DO NOT SET VALUE TO NULL
#
jsb setvr # for flagged var, restore vrget
jmp sclr4 # and loop back for next vrblk
#
# HERE TO SET VALUE OF A VARIABLE TO NULL
# PRROTECTED VARIABLES (ARB, ETC) ARE EXEMPT
#
sclr5: cmpl 4*vrsto(r9),$b$vre # check for protected variable (reg05)
beqlu sclr4
movl r9,r10 # copy vrblk pointer (reg05)
#
# LOOP TO LOCATE VALUE AT END OF POSSIBLE TRBLK CHAIN
#
sclr6: movl r10,r6 # save block pointer
movl 4*vrval(r10),r10# load next value field
cmpl (r10),$b$trt # loop back if trapped
beqlu sclr6
#
# NOW STORE THE NULL VALUE
#
movl r6,r10 # restore block pointer
movl $nulls,4*vrval(r10) # store null constant value
jmp sclr4 # loop back for next vrblk
#page
#
# CODE
#
s$cod: # entry point
movl (sp)+,r9 # load argument
jsb gtcod # convert to code
.long exfal # fail if conversion is impossible
jmp exixr # else return code as result
#page
#
# COLLECT
#
s$col: # entry point
movl (sp)+,r9 # load argument
jsb gtint # convert to integer
.long er_073 # collect argument is not integer
movl 4*icval(r9),r5 # load collect argument
movl r5,clsvi # save collect argument
clrl r7 # set no move up
jsb gbcol # perform garbage collection
movl dname,r6 # point to end of memory
subl2 dnamp,r6 # subtract next location
ashl $-2,r6,r6 # convert bytes to words
movl r6,r5 # convert words available as integer
subl2 clsvi,r5 # subtract argument
bvc 0f
jmp exfal
0:
tstl r5 # fail if not enough
bgeq 0f
jmp exfal
0:
addl2 clsvi,r5 # else recompute available
jmp exint # and exit with integer result
#page
#
# CONVERT
#
s$cnv: # entry point
jsb gtstg # convert second argument to string
.long er_074 # convert second argument is not string
jsb flstg # fold lower case to upper case
movl (sp),r10 # load first argument
cmpl (r10),$b$pdt # jump if not program defined
bnequ scv01
#
# HERE FOR PROGRAM DEFINED DATATYPE
#
movl 4*pddfp(r10),r10# point to dfblk
movl 4*dfnam(r10),r10# load datatype name
jsb ident # compare with second arg
.long exits # exit if ident with arg as result
jmp exfal # else fail
#
# HERE IF NOT PROGRAM DEFINED DATATYPE
#
scv01: movl r9,-(sp) # save string argument
movl $svctb,r10 # point to table of names to compare
clrl r7 # initialize counter
movl r6,r8 # save length of argument string
#
# LOOP THROUGH TABLE ENTRIES
#
scv02: movl (r10)+,r9 # load next table entry, bump pointer
bnequ 0f # fail if zero marking end of list
jmp exfal
0:
cmpl r8,4*sclen(r9) # jump if wrong length
beqlu 0f
jmp scv05
0:
movl r10,cnvtp # else store table pointer
movab cfp$f(r9),r9 # point to chars of table entry
movl (sp),r10 # load pointer to string argument
movab cfp$f(r10),r10 # point to chars of string arg
movl r8,r6 # set number of chars to compare
jsb sbcmc # compare, jump if no match
.long scv04
.long scv04
#page
#
# CONVERT (CONTINUED)
#
# HERE WE HAVE A MATCH
#
scv03: movl r7,r10 # copy entry number
addl2 $4,sp # pop string arg off stack
movl (sp)+,r9 # load first argument
casel r10,$0,$cnvtt # jump to appropriate routine
5:
.word scv06-5b # string
.word scv07-5b # integer
.word scv09-5b # name
.word scv10-5b # pattern
.word scv11-5b # array
.word scv19-5b # table
.word scv25-5b # expression
.word scv26-5b # code
.word scv27-5b # numeric
.word scv08-5b # real
.word scv28-5b # buffer
#esw # end of switch table
#
# HERE IF NO MATCH WITH TABLE ENTRY
#
scv04: movl cnvtp,r10 # restore table pointer, merge
#
# MERGE HERE IF LENGTHS DID NOT MATCH
#
scv05: incl r7 # bump entry number
jmp scv02 # loop back to check next entry
#
# HERE TO CONVERT TO STRING
#
scv06: movl r9,-(sp) # replace string argument on stack
jsb gtstg # convert to string
.long exfal # fail if conversion not possible
jmp exixr # else return string
#page
#
# CONVERT (CONTINUED)
#
# HERE TO CONVERT TO INTEGER
#
scv07: jsb gtint # convert to integer
.long exfal # fail if conversion not possible
jmp exixr # else return integer
#
# HERE TO CONVERT TO REAL
#
scv08: jsb gtrea # convert to real
.long exfal # fail if conversion not possible
jmp exixr # else return real
#
# HERE TO CONVERT TO NAME
#
scv09: cmpl (r9),$b$nml # return if already a name
bnequ 0f
jmp exixr
0:
jsb gtnvr # else try string to name convert
.long exfal # fail if conversion not possible
jmp exvnm # else exit building nmblk for vrblk
#
# HERE TO CONVERT TO PATTERN
#
scv10: jsb gtpat # convert to pattern
.long exfal # fail if conversion not possible
jmp exixr # else return pattern
#
# CONVERT TO ARRAY
#
scv11: jsb gtarr # get an array
.long exfal # fail if not convertible
jmp exsid # exit setting id field
#
# CONVERT TO TABLE
#
scv19: movl (r9),r6 # load first word of block
movl r9,-(sp) # replace arblk pointer on stack
cmpl r6,$b$tbt # return arg if already a table
bnequ 0f
jmp exits
0:
cmpl r6,$b$art # else fail if not an array
beqlu 0f
jmp exfal
0:
#page
#
# CONVERT (CONTINUED)
#
# HERE TO CONVERT AN ARRAY TO TABLE
#
cmpl 4*arndm(r9),$num02 # fail if not 2-dim array
beqlu 0f
jmp exfal
0:
movl 4*ardm2(r9),r5 # load dim 2
subl2 intv2,r5 # subtract 2 to compare
beql 0f # fail if dim2 not 2
jmp exfal
0:
#
# HERE WE HAVE AN ARBLK OF THE RIGHT SHAPE
#
movl 4*ardim(r9),r5 # load dim 1 (number of elements)
movl r5,r6 # get as one word integer
movl r6,r7 # copy to control loop
addl2 $tbsi$,r6 # add space for standard fields
moval 0[r6],r6 # convert length to bytes
jsb alloc # allocate space for tbblk
movl r9,r8 # copy tbblk pointer
movl r9,-(sp) # save tbblk pointer
movl $b$tbt,(r9)+ # store type word
clrl (r9)+ # store zero for idval for now
movl r6,(r9)+ # store length
movl $nulls,(r9)+ # null initial lookup value
#
# LOOP TO INITIALIZE BUCKET PTRS TO POINT TO TABLE
#
scv20: movl r8,(r9)+ # set bucket ptr to point to tbblk
sobgtr r7,scv20 # loop till all initialized
movl $4*arvl2,r7 # set offset to first arblk element
#
# LOOP TO COPY ELEMENTS FROM ARRAY TO TABLE
#
scv21: movl 4*1(sp),r10 # point to arblk
cmpl r7,4*arlen(r10) # jump if all moved
beqlu scv24
addl2 r7,r10 # else point to current location
addl2 $4*num02,r7 # bump offset
movl (r10),r9 # load subscript name
subl2 $4,r10 # adjust ptr to merge (trval=1+1)
#page
#
# CONVERT (CONTINUED)
#
# LOOP TO CHASE DOWN TRBLK CHAIN FOR VALUE
#
scv22: movl 4*trval(r10),r10# point to next value
cmpl (r10),$b$trt # loop back if trapped
beqlu scv22
#
# HERE WITH NAME IN XR, VALUE IN XL
#
scv23: movl r10,-(sp) # stack value
movl 4*1(sp),r10 # load tbblk pointer
jsb tfind # build teblk (note wb gt 0 by name)
.long exfal # fail if acess fails
movl (sp)+,4*teval(r10) # store value in teblk
jmp scv21 # loop back for next element
#
# HERE AFTER MOVING ALL ELEMENTS TO TBBLK
#
scv24: movl (sp)+,r9 # load tbblk pointer
addl2 $4,sp # pop arblk pointer
jmp exsid # exit setting idval
#
# CONVERT TO EXPRESSION
#
scv25: jsb gtexp # convert to expression
.long exfal # fail if conversion not possible
jmp exixr # else return expression
#
# CONVERT TO CODE
#
scv26: jsb gtcod # convert to code
.long exfal # fail if conversion is not possible
jmp exixr # else return code
#
# CONVERT TO NUMERIC
#
scv27: jsb gtnum # convert to numeric
.long exfal # fail if unconvertible
jmp exixr # return number
#page
#
# CONVERT TO BUFFER
#
scv28: movl r9,-(sp) # stack string for procedure
jsb gtstg # convert to string
.long exfal # fail if conversion not possible
movl r9,r10 # save string pointer
jsb alobf # allocate buffer of same size
jsb apndb # copy in the string
.long invalid$ # already string - cant fail to cnv
.long invalid$ # must be enough room
jmp exsid # exit setting idval field
#page
#
# COPY
#
s$cop: # entry point
jsb copyb # copy the block
.long exits # return if no idval field
jmp exsid # exit setting id value
#page
#
# DATA
#
s$dat: # entry point
jsb xscni # prepare to scan argument
.long er_075 # data argument is not string
.long er_076 # data argument is null
#
# SCAN OUT DATATYPE NAME
#
movl $ch$pp,r8 # delimiter one = left paren
movl r8,r10 # delimiter two = left paren
jsb xscan # scan datatype name
tstl r6 # skip if left paren found
bnequ sdat1
jmp er_077 # data argument is missing a left paren
#
# HERE AFTER SCANNING DATATYPE NAME
#
sdat1: movl 4*sclen(r9),r6 # get length
jsb flstg # fold lower case to upper case
movl r9,r10 # save name ptr
movl 4*sclen(r9),r6 # get length
movab 3+(4*scsi$)(r6),r6 # compute space needed
bicl2 $3,r6
jsb alost # request static store for name
movl r9,-(sp) # save datatype name
jsb sbmvw # copy name to static
movl (sp),r9 # get name ptr
clrl r10 # scrub dud register
jsb gtnvr # locate vrblk for datatype name
.long er_078 # data argument has null datatype name
movl r9,datdv # save vrblk pointer for datatype
movl sp,datxs # store starting stack value
clrl r7 # zero count of field names
#
# LOOP TO SCAN FIELD NAMES AND STACK VRBLK POINTERS
#
sdat2: movl $ch$rp,r8 # delimiter one = right paren
movl $ch$cm,r10 # delimiter two = comma
jsb xscan # scan next field name
tstl r6 # jump if delimiter found
bnequ sdat3
jmp er_079 # data argument is missing a right paren
#
# HERE AFTER SCANNING OUT ONE FIELD NAME
#
sdat3: jsb gtnvr # locate vrblk for field name
.long er_080 # data argument has null field name
movl r9,-(sp) # stack vrblk pointer
incl r7 # increment counter
cmpl r6,$num02 # loop back if stopped by comma
beqlu sdat2
#page
#
# DATA (CONTINUED)
#
# NOW BUILD THE DFBLK
#
movl $dfsi$,r6 # set size of dfblk standard fields
addl2 r7,r6 # add number of fields
moval 0[r6],r6 # convert length to bytes
movl r7,r8 # preserve no. of fields
jsb alost # allocate space for dfblk
movl r8,r7 # get no of fields
movl datxs,r10 # point to start of stack
movl (r10),r8 # load datatype name
movl r9,(r10) # save dfblk pointer on stack
movl $b$dfc,(r9)+ # store type word
movl r7,(r9)+ # store number of fields (fargs)
movl r6,(r9)+ # store length (dflen)
subl2 $4*pddfs,r6 # compute pdblk length (for dfpdl)
movl r6,(r9)+ # store pdblk length (dfpdl)
movl r8,(r9)+ # store datatype name (dfnam)
movl r7,r8 # copy number of fields
#
# LOOP TO MOVE FIELD NAME VRBLK POINTERS TO DFBLK
#
sdat4: movl -(r10),(r9)+ # move one field name vrblk pointer
sobgtr r8,sdat4 # loop till all moved
#
# NOW DEFINE THE DATATYPE FUNCTION
#
movl r6,r8 # copy length of pdblk for later loop
movl datdv,r9 # point to vrblk
movl datxs,r10 # point back on stack
movl (r10),r10 # load dfblk pointer
jsb dffnc # define function
#page
#
# 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: movl $4*ffsi$,r6 # set length of ffblk
jsb alloc # allocate space for ffblk
movl $b$ffc,(r9) # set type word
movl $num01,4*fargs(r9) # store fargs (always one)
movl datxs,r10 # point back on stack
movl (r10),4*ffdfp(r9)# copy dfblk ptr to ffblk
subl2 $4,r8 # decrement old dfpdl to get next ofs
movl r8,4*ffofs(r9) # set offset to this field
clrl 4*ffnxt(r9) # tentatively set zero forward ptr
movl r9,r10 # copy ffblk pointer for dffnc
movl (sp),r9 # load vrblk pointer for field
movl 4*vrfnc(r9),r9 # load current function pointer
cmpl (r9),$b$ffc # skip if not currently a field func
bnequ sdat6
#
# HERE WE MUST CHAIN AN OLD FFBLK PTR TO PRESERVE IT IN THE
# CASE OF MULTIPLE FIELD FUNCTIONS WITH THE SAME NAME
#
movl r9,4*ffnxt(r10) # link new ffblk to previous chain
#
# MERGE HERE TO DEFINE FIELD FUNCTION
#
sdat6: movl (sp)+,r9 # load vrblk pointer
jsb dffnc # define field function
cmpl sp,datxs # loop back till all done
bnequ sdat5
addl2 $4,sp # pop dfblk pointer
jmp exnul # return with null result
#page
#
# DATATYPE
#
s$dtp: # entry point
movl (sp)+,r9 # load argument
jsb dtype # get datatype
jmp exixr # and return it as result
#page
#
# DATE
#
s$dte: # entry point
jsb sysdt # call system date routine
movl 4*1(r10),r6 # load length for sbstr
bnequ 0f # return null if length is zero
jmp exnul
0:
clrl r7 # set zero offset
jsb sbstr # use sbstr to build scblk
jmp exixr # return date string
#page
#
# DEFINE
#
s$def: # entry point
movl (sp)+,r9 # load second argument
clrl deflb # zero label pointer in case null
cmpl r9,$nulls # jump if null second argument
beqlu sdf01
jsb gtnvr # else find vrblk for label
.long sdf13 # jump if not a variable name
movl r9,deflb # else set specified entry
#
# SCAN FUNCTION NAME
#
sdf01: jsb xscni # prepare to scan first argument
.long er_081 # define first argument is not string
.long er_082 # define first argument is null
movl $ch$pp,r8 # delimiter one = left paren
movl r8,r10 # delimiter two = left paren
jsb xscan # scan out function name
tstl r6 # jump if left paren found
bnequ sdf02
jmp er_083 # define first argument is missing a left paren
#
# HERE AFTER SCANNING OUT FUNCTION NAME
#
sdf02: jsb gtnvr # get variable name
.long er_084 # define first argument has null function name
movl r9,defvr # save vrblk pointer for function nam
clrl r7 # zero count of arguments
movl sp,defxs # save initial stack pointer
tstl deflb # jump if second argument given
bnequ sdf03
movl r9,deflb # else default is function name
#
# LOOP TO SCAN ARGUMENT NAMES AND STACK VRBLK POINTERS
#
sdf03: movl $ch$rp,r8 # delimiter one = right paren
movl $ch$cm,r10 # delimiter two = comma
jsb xscan # scan out next argument name
tstl r6 # skip if delimiter found
bnequ sdf04
jmp er_085 # null arg name or missing ) in define first arg.
#page
#
# DEFINE (CONTINUED)
#
# HERE AFTER SCANNING AN ARGUMENT NAME
#
sdf04: cmpl r9,$nulls # skip if non-null
bnequ sdf05
tstl r7 # ignore null if case of no arguments
beqlu sdf06
#
# HERE AFTER DEALING WITH THE CASE OF NO ARGUMENTS
#
sdf05: jsb gtnvr # get vrblk pointer
.long sdf03 # loop back to ignore null name
movl r9,-(sp) # stack argument vrblk pointer
incl r7 # increment counter
cmpl r6,$num02 # loop back if stopped by a comma
beqlu sdf03
#
# HERE AFTER SCANNING OUT FUNCTION ARGUMENT NAMES
#
sdf06: movl r7,defna # save number of arguments
clrl r7 # zero count of locals
#
# LOOP TO SCAN LOCAL NAMES AND STACK VRBLK POINTERS
#
sdf07: movl $ch$cm,r8 # set delimiter one = comma
movl r8,r10 # set delimiter two = comma
jsb xscan # scan out next local name
cmpl r9,$nulls # skip if non-null
bnequ sdf08
tstl r7 # ignore null if case of no locals
beqlu sdf09
#
# HERE AFTER SCANNING OUT A LOCAL NAME
#
sdf08: jsb gtnvr # get vrblk pointer
.long sdf07 # loop back to ignore null name
incl r7 # if ok, increment count
movl r9,-(sp) # stack vrblk pointer
tstl r6 # loop back if stopped by a comma
bnequ sdf07
#page
#
# DEFINE (CONTINUED)
#
# HERE AFTER SCANNING LOCALS, BUILD PFBLK
#
sdf09: movl r7,r6 # copy count of locals
addl2 defna,r6 # add number of arguments
movl r6,r8 # set sum args+locals as loop count
addl2 $pfsi$,r6 # add space for standard fields
moval 0[r6],r6 # convert length to bytes
jsb alloc # allocate space for pfblk
movl r9,r10 # save pointer to pfblk
movl $b$pfc,(r9)+ # store first word
movl defna,(r9)+ # store number of arguments
movl r6,(r9)+ # store length (pflen)
movl defvr,(r9)+ # store vrblk ptr for function name
movl r7,(r9)+ # store number of locals
clrl (r9)+ # deal with label later
clrl (r9)+ # zero pfctr
clrl (r9)+ # zero pfrtr
tstl r8 # skip if no args or locals
beqlu sdf11
movl r10,r6 # keep pfblk pointer
movl defxs,r10 # point before arguments
# get count of args+locals for loop
#
# LOOP TO MOVE LOCALS AND ARGS TO PFBLK
#
sdf10: movl -(r10),(r9)+ # store one entry and bump pointers
sobgtr r8,sdf10 # loop till all stored
movl r6,r10 # recover pfblk pointer
#page
#
# DEFINE (CONTINUED)
#
# NOW DEAL WITH LABEL
#
sdf11: movl defxs,sp # pop stack
movl deflb,r9 # point to vrblk for label
movl 4*vrlbl(r9),r9 # load label pointer
cmpl (r9),$b$trt # skip if not trapped
bnequ sdf12
movl 4*trlbl(r9),r9 # else point to real label
#
# HERE AFTER LOCATING REAL LABEL POINTER
#
sdf12: cmpl r9,$stndl # jump if label is not defined
beqlu sdf13
movl r9,4*pfcod(r10) # else store label pointer
movl defvr,r9 # point back to vrblk for function
jsb dffnc # define function
jmp exnul # and exit returning null
#
# HERE FOR ERRONEOUS LABEL
#
sdf13: jmp er_086 # define function entry point is not defined label
#page
#
# DETACH
#
s$det: # entry point
movl (sp)+,r9 # load argument
jsb gtvar # locate variable
.long er_087 # detach argument is not appropriate name
jsb dtach # detach i/o association from name
jmp exnul # return null result
#page
#
# DIFFER
#
s$dif: # entry point
movl (sp)+,r9 # load second argument
movl (sp)+,r10 # load first argument
jsb ident # call ident comparison routine
.long exfal # fail if ident
jmp exnul # return null if differ
#page
#
# DUMP
#
s$dmp: # entry point
jsb gtsmi # load dump arg as small integer
.long er_088 # dump argument is not integer
.long er_089 # dump argument is negative or too large
jsb dumpr # else call dump routine
jmp exnul # and return null as result
#page
#
# DUPL
#
s$dup: # entry point
jsb gtsmi # get second argument as small intege
.long er_090 # dupl second argument is not integer
.long sdup7 # jump if negative ot too big
movl r9,r7 # save duplication factor
jsb gtstg # get first arg as string
.long sdup4 # jump if not a string
#
# HERE FOR CASE OF DUPLICATION OF A STRING
#
movl r6,r5 # acquire length as integer
movl r5,dupsi # save for the moment
movl r7,r5 # get duplication factor as integer
mull2 dupsi,r5 # form product
bvs sdup3
tstl r5 # return null if result length = 0
bneq 0f
jmp exnul
0:
movl r5,r6 # get as addr integer, check ovflo
bgeq 0f
jmp sdup3
0:
#
# MERGE HERE WITH RESULT LENGTH IN WA
#
sdup1: movl r9,r10 # save string pointer
jsb alocs # allocate space for string
movl r9,-(sp) # save as result pointer
movl r10,r8 # save pointer to argument string
movab cfp$f(r9),r9 # prepare to store chars of result
# set counter to control loop
#
# LOOP THROUGH DUPLICATIONS
#
sdup2: movl r8,r10 # point back to argument string
movl 4*sclen(r10),r6 # get number of characters
movab cfp$f(r10),r10 # point to chars in argument string
jsb sbmvc # move characters to result string
sobgtr r7,sdup2 # loop till all duplications done
jmp exits # then exit for next code word
#page
#
# DUPL (CONTINUED)
#
# HERE IF TOO LARGE, SET MAX LENGTH AND LET ALOCS CATCH IT
#
sdup3: movl dname,r6 # set impossible length for alocs
jmp sdup1 # merge back
#
# HERE IF NOT A STRING
#
sdup4: jsb gtpat # convert argument to pattern
.long er_091 # dupl first argument is not string or pattern
#
# HERE TO DUPLICATE A PATTERN ARGUMENT
#
movl r9,-(sp) # store pattern on stack
movl $ndnth,r9 # start off with null pattern
tstl r7 # null pattern is result if dupfac=0
beqlu sdup6
movl r7,-(sp) # preserve loop count
#
# LOOP TO DUPLICATE BY SUCCESSIVE CONCATENATION
#
sdup5: movl r9,r10 # copy current value as right argumnt
movl 4*1(sp),r9 # get a new copy of left
jsb pconc # concatenate
decl (sp) # count down
bnequ sdup5 # loop
addl2 $4,sp # pop loop count
#
# HERE TO EXIT AFTER CONSTRUCTING PATTERN
#
sdup6: movl r9,(sp) # store result on stack
jmp exits # exit with result on stack
#
# FAIL IF SECOND ARG IS OUT OF RANGE
#
sdup7: addl2 $4,sp # pop first argument
jmp exfal # fail
#page
#
# EJECT
#
s$ejc: # entry point
jsb iofcb # call fcblk routine
.long er_092 # eject argument is not a suitable name
.long sejc1 # null argument
jsb sysef # call eject file function
.long er_093 # eject file does not exist
.long er_094 # eject file does not permit page eject
.long er_095 # eject caused non-recoverable output error
jmp exnul # return null as result
#
# HERE TO EJECT STANDARD OUTPUT FILE
#
sejc1: jsb sysep # call routine to eject printer
jmp exnul # exit with null result
#page
#
# ENDFILE
#
s$enf: # entry point
jsb iofcb # call fcblk routine
.long er_096 # endfile argument is not a suitable name
.long er_097 # endfile argument is null
jsb sysen # call endfile routine
.long er_098 # endfile file does not exist
.long er_099 # endfile file does not permit endfile
.long er_100 # endfile caused non-recoverable output error
movl r10,r7 # remember vrblk ptr from iofcb call
#
# LOOP TO FIND TRTRF BLOCK
#
senf1: movl r10,r9 # copy pointer
movl 4*trval(r9),r9 # chain along
cmpl (r9),$b$trt # skip out if chain end
beqlu 0f
jmp exnul
0:
cmpl 4*trtyp(r9),$trtfc # loop if not found
bnequ senf1
movl 4*trval(r9),4*trval(r10) # remove trtrf
movl 4*trtrf(r9),enfch# point to head of iochn
movl 4*trfpt(r9),r8 # point to fcblk
movl r7,r9 # filearg1 vrblk from iofcb
jsb setvr # reset it
movl $r$fcb,r10 # ptr to head of fcblk chain
subl2 $4*num02,r10 # adjust ready to enter loop
#
# FIND FCBLK
#
senf2: movl r10,r9 # copy ptr
movl 4*2(r10),r10 # get next link
beqlu senf4 # stop if chain end
cmpl 4*3(r10),r8 # jump if fcblk found
beqlu senf3
jmp senf2 # loop
#
# REMOVE FCBLK
#
senf3: movl 4*2(r10),4*2(r9)# delete fcblk from chain
#
# LOOP WHICH DETACHES ALL VBLS ON IOCHN CHAIN
#
senf4: movl enfch,r10 # get chain head
bnequ 0f # finished if chain end
jmp exnul
0:
movl 4*trtrf(r10),enfch # chain along
movl 4*ionmo(r10),r6 # name offset
movl 4*ionmb(r10),r10# name base
jsb dtach # detach name
jmp senf4 # loop till done
#page
#
# EQ
#
s$eqf: # entry point
jsb acomp # call arithmetic comparison routine
.long er_101 # eq first argument is not numeric
.long er_102 # eq second argument is not numeric
.long exfal # fail if lt
.long exnul # return null if eq
.long exfal # fail if gt
#page
#
# EVAL
#
s$evl: # entry point
movl (sp)+,r9 # load argument
jsb gtexp # convert to expression
.long er_103 # eval argument is not expression
movl (r3)+,r8 # load next code word
cmpl r8,$ofne$ # jump if called by value
bnequ sevl1
movl r3,r10 # copy code pointer
movl (r10),r6 # get next code word
cmpl r6,$ornm$ # by name unless expression
bnequ sevl2
tstl 4*1(sp) # jump if by name
bnequ sevl2
#
# HERE IF CALLED BY VALUE
#
sevl1: clrl r7 # set flag for by value
movl r8,-(sp) # save code word
jsb evalx # evaluate expression by value
.long exfal # fail if evaluation fails
movl r9,r10 # copy result
movl (sp),r9 # reload next code word
movl r10,(sp) # stack result
movl (r9),r11 # jump to execute next code word
jmp (r11)
#
# HERE IF CALLED BY NAME
#
sevl2: movl $num01,r7 # set flag for by name
jsb evalx # evaluate expression by name
.long exfal # fail if evaluation fails
jmp exnam # exit with name
#page
#
# EXIT
#
s$ext: # entry point
clrl r7 # clear amount of static shift
jsb gbcol # compact memory by collecting
jsb gtstg # convert arg to string
.long er_104 # exit argument is not suitable integer or string
movl r9,r10 # copy string ptr
jsb gtint # check it is integer
.long sext1 # skip if unconvertible
clrl r10 # note it is integer
movl 4*icval(r9),r5 # get integer arg
movl r$fcb,r7 # get fcblk chain header
#
# MERGE TO CALL OSINT EXIT ROUTINE
#
sext1: movl $headv,r9 # point to v.v string
jsb sysxi # call external routine
.long er_105 # exit action not available in this implementation
.long er_106 # exit action caused irrecoverable error
tstl r5 # return if argument 0
bneq 0f
jmp exnul
0:
clrl gbcnt # resuming execution so reset
tstl r5 # skip if positive
bgtr sext2
mnegl r5,r5 # make positive
#
# CHECK FOR OPTION RESPECIFICATION
#
sext2: movl r5,r8 # get value in work reg
cmpl r8,$num03 # skip if was 3
beqlu sext3
movl r8,-(sp) # save value
clrl r8 # set to read options
jsb prpar # read syspp options
movl (sp)+,r8 # restore value
#
# DEAL WITH HEADER OPTION (FIDDLED BY PRPAR)
#
sext3: movl sp,headp # assume no headers
cmpl r8,$num01 # skip if not 1
bnequ sext4
clrl headp # request header printing
#
# ALMOST READY TO RESUME RUNNING
#
sext4: jsb systm # get execution time start (sgd11)
movl r5,timsx # save as initial time
movl kvstc,r5 # reset to ensure ...
movl r5,kvstl # ... correct execution stats
jmp exnul # resume execution
#page
#
# FIELD
#
s$fld: # entry point
jsb gtsmi # get second argument (field number)
.long er_107 # field second argument is not integer
.long exfal # fail if out of range
movl r9,r7 # else save integer value
movl (sp)+,r9 # load first argument
jsb gtnvr # point to vrblk
.long sfld1 # jump (error) if not variable name
movl 4*vrfnc(r9),r9 # else point to function block
cmpl (r9),$b$dfc # error if not datatype function
bnequ sfld1
#
# HERE IF FIRST ARGUMENT IS A DATATYPE FUNCTION NAME
#
tstl r7 # fail if argument number is zero
bnequ 0f
jmp exfal
0:
cmpl r7,4*fargs(r9) # fail if too large
blequ 0f
jmp exfal
0:
moval 0[r7],r7 # else convert to byte offset
addl2 r7,r9 # point to field name
movl 4*dfflb(r9),r9 # load vrblk pointer
jmp exvnm # exit to build nmblk
#
# HERE FOR BAD FIRST ARGUMENT
#
sfld1: jmp er_108 # field first argument is not datatype name
#page
#
# FENCE
#
s$fnc: # entry point
movl $p$fnc,r7 # set pcode for p$fnc
clrl r9 # p0blk
jsb pbild # build p$fnc node
movl r9,r10 # save pointer to it
movl (sp)+,r9 # get argument
jsb gtpat # convert to pattern
.long er_259 # fence argument is not pattern
jsb pconc # concatenate to p$fnc node
movl r9,r10 # save ptr to concatenated pattern
movl $p$fna,r7 # set for p$fna pcode
clrl r9 # p0blk
jsb pbild # construct p$fna node
movl r10,4*pthen(r9) # set pattern as pthen
movl r9,-(sp) # set as result
jmp exits # do next code word
#page
#
# GE
#
s$gef: # entry point
jsb acomp # call arithmetic comparison routine
.long er_109 # ge first argument is not numeric
.long er_110 # ge second argument is not numeric
.long exfal # fail if lt
.long exnul # return null if eq
.long exnul # return null if gt
#page
#
# GT
#
s$gtf: # entry point
jsb acomp # call arithmetic comparison routine
.long er_111 # gt first argument is not numeric
.long er_112 # gt second argument is not numeric
.long exfal # fail if lt
.long exfal # fail if eq
.long exnul # return null if gt
#page
#
# HOST
#
s$hst: # entry point
movl (sp)+,r9 # get third arg
movl (sp)+,r10 # get second arg
movl (sp)+,r6 # get first arg
jsb syshs # enter syshs routine
.long er_254 # erroneous argument for host
.long er_255 # error during execution of host
.long shst1 # store host string
.long exnul # return null result
.long exixr # return xr
.long exfal # fail return
#
# RETURN HOST STRING
#
shst1: tstl r10 # null string if syshs uncooperative
bnequ 0f
jmp exnul
0:
movl 4*sclen(r10),r6 # length
clrl r7 # zero offset
jsb sbstr # build copy of string
movl r9,-(sp) # stack the result
jmp exits # return result on stack
#page
#
# IDENT
#
s$idn: # entry point
movl (sp)+,r9 # load second argument
movl (sp)+,r10 # load first argument
jsb ident # call ident comparison routine
.long exnul # return null if ident
jmp exfal # fail if differ
#page
#
# INPUT
#
s$inp: # entry point
clrl r7 # input flag
jsb ioput # call input/output assoc. routine
.long er_113 # input third argument is not a string
.long er_114 # inappropriate second argument for input
.long er_115 # inappropriate first argument for input
.long er_116 # inappropriate file specification for input
.long exfal # fail if file does not exist
.long er_117 # input file cannot be read
jmp exnul # return null string
#page
#
# INSERT
#
s$ins: # entry point
movl (sp)+,r10 # get string arg
jsb gtsmi # get replace length
.long er_277 # insert third argument not integer
.long exfal # fail if out of range
movl r8,r7 # copy to proper reg
jsb gtsmi # get replace position
.long er_278 # insert second argument not integer
.long exfal # fail if out of range
tstl r8 # fail if zero
bnequ 0f
jmp exfal
0:
decl r8 # decrement to get offset
movl r8,r6 # put in proper register
movl (sp)+,r9 # get buffer
cmpl (r9),$b$bct # press on if type ok
beqlu sins1
jmp er_279 # insert first argument not buffer
#
# HERE WHEN EVERYTHING LOADED UP
#
sins1: jsb insbf # call to insert
.long er_280 # insert fourth argument not a string
.long exfal # fail if out of range
jmp exnul # else ok - exit with null
#page
#
# INTEGER
#
s$int: # entry point
movl (sp)+,r9 # load argument
jsb gtnum # convert to numeric
.long exfal # fail if non-numeric
cmpl r6,$b$icl # return null if integer
bnequ 0f
jmp exnul
0:
jmp exfal # fail if real
#page
#
# ITEM
#
# ITEM DOES NOT PERMIT THE DIRECT (FAST) CALL SO THAT
# WA CONTAINS THE ACTUAL NUMBER OF ARGUMENTS PASSED.
#
s$itm: # entry point
#
# DEAL WITH CASE OF NO ARGS
#
tstl r6 # jump if at least one arg
bnequ sitm1
movl $nulls,-(sp) # else supply garbage null arg
movl $num01,r6 # and fix argument count
#
# CHECK FOR NAME/VALUE CASES
#
sitm1: movl r3,r9 # get current code pointer
movl (r9),r10 # load next code word
decl r6 # get number of subscripts
movl r6,r9 # copy for arref
cmpl r10,$ofne$ # jump if called by name
beqlu sitm2
#
# HERE IF CALLED BY VALUE
#
clrl r7 # set code for call by value
jmp arref # off to array reference routine
#
# HERE FOR CALL BY NAME
#
sitm2: movl sp,r7 # set code for call by name
movl (r3)+,r6 # load and ignore ofne$ call
jmp arref # off to array reference routine
#page
#
# LE
#
s$lef: # entry point
jsb acomp # call arithmetic comparison routine
.long er_118 # le first argument is not numeric
.long er_119 # le second argument is not numeric
.long exnul # return null if lt
.long exnul # return null if eq
.long exfal # fail if gt
#page
#
# LEN
#
s$len: # entry point
movl $p$len,r7 # set pcode for integer arg case
movl $p$lnd,r6 # set pcode for expr arg case
jsb patin # call common routine to build node
.long er_120 # len argument is not integer or expression
.long er_121 # len argument is negative or too large
jmp exixr # return pattern node
#page
#
# LEQ
#
s$leq: # entry point
jsb lcomp # call string comparison routine
.long er_122 # leq first argument is not string
.long er_123 # leq second argument is not string
.long exfal # fail if llt
.long exnul # return null if leq
.long exfal # fail if lgt
#page
#
# LGE
#
s$lge: # entry point
jsb lcomp # call string comparison routine
.long er_124 # lge first argument is not string
.long er_125 # lge second argument is not string
.long exfal # fail if llt
.long exnul # return null if leq
.long exnul # return null if lgt
#page
#
# LGT
#
s$lgt: # entry point
jsb lcomp # call string comparison routine
.long er_126 # lgt first argument is not string
.long er_127 # lgt second argument is not string
.long exfal # fail if llt
.long exfal # fail if leq
.long exnul # return null if lgt
#page
#
# LLE
#
s$lle: # entry point
jsb lcomp # call string comparison routine
.long er_128 # lle first argument is not string
.long er_129 # lle second argument is not string
.long exnul # return null if llt
.long exnul # return null if leq
.long exfal # fail if lgt
#page
#
# LLT
#
s$llt: # entry point
jsb lcomp # call string comparison routine
.long er_130 # llt first argument is not string
.long er_131 # llt second argument is not string
.long exnul # return null if llt
.long exfal # fail if leq
.long exfal # fail if lgt
#page
#
# LNE
#
s$lne: # entry point
jsb lcomp # call string comparison routine
.long er_132 # lne first argument is not string
.long er_133 # lne second argument is not string
.long exnul # return null if llt
.long exfal # fail if leq
.long exnul # return null if lgt
#page
#
# LOCAL
#
s$loc: # entry point
jsb gtsmi # get second argument (local number)
.long er_134 # local second argument is not integer
.long exfal # fail if out of range
movl r9,r7 # save local number
movl (sp)+,r9 # load first argument
jsb gtnvr # point to vrblk
.long sloc1 # jump if not variable name
movl 4*vrfnc(r9),r9 # else load function pointer
cmpl (r9),$b$pfc # jump if not program defined
bnequ sloc1
#
# HERE IF WE HAVE A PROGRAM DEFINED FUNCTION NAME
#
tstl r7 # fail if second arg is zero
bnequ 0f
jmp exfal
0:
cmpl r7,4*pfnlo(r9) # or too large
blequ 0f
jmp exfal
0:
addl2 4*fargs(r9),r7 # else adjust offset to include args
moval 0[r7],r7 # convert to bytes
addl2 r7,r9 # point to local pointer
movl 4*pfagb(r9),r9 # load vrblk pointer
jmp exvnm # exit building nmblk
#
# HERE IF FIRST ARGUMENT IS NO GOOD
#
sloc1: jmp er_135 # local first arg is not a program function name
#page
#
# LOAD
#
s$lod: # entry point
jsb gtstg # load library name
.long er_136 # load second argument is not string
movl r9,r10 # save library name
jsb xscni # prepare to scan first argument
.long er_137 # load first argument is not string
.long er_138 # load first argument is null
movl r10,-(sp) # stack library name
movl $ch$pp,r8 # set delimiter one = left paren
movl r8,r10 # set delimiter two = left paren
jsb xscan # scan function name
movl r9,-(sp) # save ptr to function name
tstl r6 # jump if left paren found
bnequ slod1
jmp er_139 # load first argument is missing a left paren
#
# HERE AFTER SUCCESSFULLY SCANNING FUNCTION NAME
#
slod1: jsb gtnvr # locate vrblk
.long er_140 # load first argument has null function name
movl r9,lodfn # save vrblk pointer
clrl lodna # zero count of arguments
#
# LOOP TO SCAN ARGUMENT DATATYPE NAMES
#
slod2: movl $ch$rp,r8 # delimiter one is right paren
movl $ch$cm,r10 # delimiter two is comma
jsb xscan # scan next argument name
incl lodna # bump argument count
tstl r6 # jump if ok delimiter was found
bnequ slod3
jmp er_141 # load first argument is missing a right paren
#page
#
# 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: movl r9,-(sp) # stack datatype name pointer
movl $num01,r7 # set string code in case
movl $scstr,r10 # point to /string/
jsb ident # check for match
.long slod4 # jump if match
movl (sp),r9 # else reload name
addl2 r7,r7 # set code for integer (2)
movl $scint,r10 # point to /integer/
jsb ident # check for match
.long slod4 # jump if match
movl (sp),r9 # else reload string pointer
incl r7 # set code for real (3)
movl $screa,r10 # point to /real/
jsb ident # check for match
.long slod4 # jump if match
clrl r7 # else get code for no convert
#
# MERGE HERE WITH PROPER DATATYPE CODE IN WB
#
slod4: movl r7,(sp) # store code on stack
cmpl r6,$num02 # loop back if arg stopped by comma
beqlu slod2
tstl r6 # jump if that was the result type
beqlu slod5
#
# HERE WE SCAN OUT THE RESULT TYPE (ARG STOPPED BY ) )
#
movl mxlen,r8 # set dummy (impossible) delimiter 1
movl r8,r10 # and delimiter two
jsb xscan # scan result name
clrl r6 # set code for processing result
jmp slod3 # jump back to process result name
#page
#
# LOAD (CONTINUED)
#
# HERE AFTER PROCESSING ALL ARGS AND RESULT
#
slod5: movl lodna,r6 # get number of arguments
movl r6,r8 # copy for later
moval 0[r6],r6 # convert length to bytes
addl2 $4*efsi$,r6 # add space for standard fields
jsb alloc # allocate efblk
movl $b$efc,(r9) # set type word
movl r8,4*fargs(r9) # set number of arguments
clrl 4*efuse(r9) # set use count (dffnc will set to 1)
clrl 4*efcod(r9) # zero code pointer for now
movl (sp)+,4*efrsl(r9)# store result type code
movl lodfn,4*efvar(r9)# store function vrblk pointer
movl r6,4*eflen(r9) # store efblk length
movl r9,r7 # save efblk pointer
addl2 r6,r9 # point past end of efblk
# set number of arguments for loop
#
# LOOP TO SET ARGUMENT TYPE CODES FROM STACK
#
slod6: movl (sp)+,-(r9) # store one type code from stack
sobgtr r8,slod6 # loop till all stored
#
# NOW LOAD THE EXTERNAL FUNCTION AND PERFORM DEFINITION
#
movl (sp)+,r9 # load function string name
movl (sp),r10 # load library name
movl r7,(sp) # store efblk pointer
jsb sysld # call function to load external func
.long er_142 # load function does not exist
.long er_143 # load function caused input error during load
movl (sp)+,r10 # recall efblk pointer
movl r9,4*efcod(r10) # store code pointer
movl lodfn,r9 # point to vrblk for function
jsb dffnc # perform function definition
jmp exnul # return null result
#page
#
# LPAD
#
s$lpd: # entry point
jsb gtstg # get pad character
.long er_144 # lpad third argument not a string
movab cfp$f(r9),r9 # point to character (null is blank)
movzbl (r9),r7 # load pad character
jsb gtsmi # get pad length
.long er_145 # lpad second argument is not integer
.long slpd3 # skip if negative or large
#
# MERGE TO CHECK FIRST ARG
#
slpd1: jsb gtstg # get first argument (string to pad)
.long er_146 # lpad first argument is not string
cmpl r6,r8 # return 1st arg if too long to pad
blssu 0f
jmp exixr
0:
movl r9,r10 # 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
#
movl r8,r6 # copy length
jsb alocs # allocate scblk for new string
movl r9,-(sp) # save as result
movl 4*sclen(r10),r6 # load length of argument
subl2 r6,r8 # calculate number of pad characters
movab cfp$f(r9),r9 # point to chars in result string
# set counter for pad loop
#
# LOOP TO PERFORM PAD
#
slpd2: movb r7,(r9)+ # store pad character, bump ptr
sobgtr r8,slpd2 # loop till all pad chars stored
#csc r9 # complete store characters
#
# NOW COPY STRING
#
tstl r6 # exit if null string
bnequ 0f
jmp exits
0:
movab cfp$f(r10),r10 # else point to chars in argument
jsb sbmvc # move characters to result string
jmp exits # jump for next code word
#
# HERE IF 2ND ARG IS NEGATIVE OR LARGE
#
slpd3: clrl r8 # zero pad count
jmp slpd1 # merge
#page
#
# LT
#
s$ltf: # entry point
jsb acomp # call arithmetic comparison routine
.long er_147 # lt first argument is not numeric
.long er_148 # lt second argument is not numeric
.long exnul # return null if lt
.long exfal # fail if eq
.long exfal # fail if gt
#page
#
# NE
#
s$nef: # entry point
jsb acomp # call arithmetic comparison routine
.long er_149 # ne first argument is not numeric
.long er_150 # ne second argument is not numeric
.long exnul # return null if lt
.long exfal # fail if eq
.long exnul # return null if gt
#page
#
# NOTANY
#
s$nay: # entry point
movl $p$nas,r7 # set pcode for single char arg
movl $p$nay,r10 # pcode for multi-char arg
movl $p$nad,r8 # set pcode for expr arg
jsb patst # call common routine to build node
.long er_151 # notany argument is not string or expression
jmp exixr # jump for next code word
#page
#
# OPSYN
#
s$ops: # entry point
jsb gtsmi # load third argument
.long er_152 # opsyn third argument is not integer
.long er_153 # opsyn third argument is negative or too large
movl r8,r7 # if ok, save third argumnet
movl (sp)+,r9 # load second argument
jsb gtnvr # locate variable block
.long er_154 # opsyn second arg is not natural variable name
movl 4*vrfnc(r9),r10 # if ok, load function block pointer
tstl r7 # jump if operator opsyn case
bnequ sops2
#
# HERE FOR FUNCTION OPSYN (THIRD ARG ZERO)
#
movl (sp)+,r9 # load first argument
jsb gtnvr # get vrblk pointer
.long er_155 # opsyn first arg is not natural variable name
#
# MERGE HERE TO PERFORM FUNCTION DEFINITION
#
sops1: jsb dffnc # call function definer
jmp exnul # exit with null result
#
# HERE FOR OPERATOR OPSYN (THIRD ARG NON-ZERO)
#
sops2: jsb gtstg # get operator name
.long sops5 # jump if not string
cmpl r6,$num01 # error if not one char long
bnequ sops5
movab cfp$f(r9),r9 # else point to character
movzbl (r9),r8 # load character name
#page
#
# 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.
#
movl $r$uub,r6 # point to unop pointers in case
movl $opnsu,r9 # point to names of unary operators
addl2 $opbun,r7 # add no. of undefined binary ops
cmpl r7,$opuun # jump if unop (third arg was 1)
beqlu sops3
movl $r$uba,r6 # else point to binary operator ptrs
movl $opsnb,r9 # point to names of binary operators
movl $opbun,r7 # set number of undefined binops
#
# MERGE HERE TO CHECK LIST (WB = NUMBER TO CHECK)
#
sops3: # set counter to control loop
#
# LOOP TO SEARCH FOR NAME MATCH
#
sops4: cmpl r8,(r9) # jump if names match
beqlu sops6
addl2 $4,r6 # else push pointer to function ptr
addl2 $4,r9 # bump pointer
sobgtr r7,sops4 # loop back till all checked
#
# HERE IF BAD OPERATOR NAME
#
sops5: jmp er_156 # opsyn first arg is not correct operator name
#
# COME HERE ON FINDING A MATCH IN THE OPERATOR NAME TABLE
#
sops6: movl r6,r9 # copy pointer to function block ptr
subl2 $4*vrfnc,r9 # make it look like dummy vrblk
jmp sops1 # merge back to define operator
#page
#
# OUTPUT
#
s$oup: # entry point
movl $num03,r7 # output flag
jsb ioput # call input/output assoc. routine
.long er_157 # output third argument is not a string
.long er_158 # inappropriate second argument for output
.long er_159 # inappropriate first argument for output
.long er_160 # inappropriate file specification for output
.long exfal # fail if file does not exist
.long er_161 # output file cannot be written to
jmp exnul # return null string
#page
#
# POS
#
s$pos: # entry point
movl $p$pos,r7 # set pcode for integer arg case
movl $p$psd,r6 # set pcode for expression arg case
jsb patin # call common routine to build node
.long er_162 # pos argument is not integer or expression
.long er_163 # pos argument is negative or too large
jmp exixr # return pattern node
#page
#
# PROTOTYPE
#
s$pro: # entry point
movl (sp)+,r9 # load argument
movl 4*tblen(r9),r7 # length if table, vector (=vclen)
ashl $-2,r7,r7 # convert to words
movl (r9),r6 # load type word of argument block
cmpl r6,$b$art # jump if array
beqlu spro4
cmpl r6,$b$tbt # jump if table
beqlu spro1
cmpl r6,$b$vct # jump if vector
beqlu spro3
cmpl r6,$b$bct # jump if buffer
beqlu spr05
jmp er_164 # prototype argument is not valid object
#
# HERE FOR TABLE
#
spro1: subl2 $tbsi$,r7 # subtract standard fields
#
# MERGE FOR VECTOR
#
spro2: movl r7,r5 # convert to integer
jmp exint # exit with integer result
#
# HERE FOR VECTOR
#
spro3: subl2 $vcsi$,r7 # subtract standard fields
jmp spro2 # merge
#
# HERE FOR ARRAY
#
spro4: addl2 4*arofs(r9),r9 # point to prototype field
movl (r9),r9 # load prototype
jmp exixr # return prototype as result
#
# HERE FOR BUFFER
#
spr05: movl 4*bcbuf(r9),r9 # point to bfblk
movl 4*bfalc(r9),r5 # load allocated length
jmp exint # exit with integer allocation
#page
#
# REMDR
#
s$rmd: # entry point
clrl r7 # set positive flag
movl (sp),r9 # load second argument
jsb gtint # convert to integer
.long er_165 # remdr second argument is not integer
jsb arith # convert args
.long srm01 # first arg not integer
.long invalid$ # second arg checked above
.long srm01 # first arg real
movl 4*icval(r9),r5 # load left argument value
ashq $-32,r4,r4 # get remainder
ediv 4*icval(r10),r4,r11,r5
bvs 0f
jmp exint
0:
jmp er_167 # remdr caused integer overflow
#
# FAIL FIRST ARGUMENT
#
srm01: jmp er_166 # remdr first argument is not integer
#page
#
# 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: # entry point
jsb gtstg # load third argument as string
.long er_168 # replace third argument is not string
movl r9,r10 # save third arg ptr
jsb gtstg # get second argument
.long er_169 # replace second argument is not string
#
# CHECK TO SEE IF THIS IS THE SAME TABLE AS LAST TIME
#
cmpl r9,r$ra2 # jump if 2nd argument different
bnequ srpl1
cmpl r10,r$ra3 # jump if args same as last time
bnequ 0f
jmp srpl4
0:
#
# HERE WE BUILD A NEW REPLACE TABLE (NOTE WA = 2ND ARG LEN)
#
srpl1: movl 4*sclen(r10),r7 # load 3rd argument length
cmpl r6,r7 # jump if arguments not same length
beqlu 0f
jmp srpl5
0:
tstl r7 # jump if null 2nd argument
bnequ 0f
jmp srpl5
0:
movl r10,r$ra3 # save third arg for next time in
movl r9,r$ra2 # save second arg for next time in
movl kvalp,r10 # point to alphabet string
movl 4*sclen(r10),r6 # load alphabet scblk length
movl r$rpt,r9 # point to current table (if any)
bnequ srpl2 # jump if we already have a table
#
# HERE WE ALLOCATE A NEW TABLE
#
jsb alocs # allocate new table
movl r8,r6 # keep scblk length
movl r9,r$rpt # save table pointer for next time
#
# MERGE HERE WITH POINTER TO NEW TABLE BLOCK IN (XR)
#
srpl2: movab 3+(4*scsi$)(r6),r6 # compute length of scblk
bicl2 $3,r6
jsb sbmvw # copy to get initial table values
#page
#
# 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
#
movl r$ra2,r10 # point to second argument
# number of chars to plug
clrl r8 # zero char offset
movl r$ra3,r9 # point to 3rd arg
movab cfp$f(r9),r9 # get char ptr for 3rd arg
#
# LOOP TO PLUG CHARS
#
srpl3: movl r$ra2,r10 # point to 2nd arg
movab cfp$f(r10)[r8],r10 # point to next char
incl r8 # increment offset
movzbl (r10),r6 # get next char
movl r$rpt,r10 # point to translate table
movab cfp$f(r10)[r6],r10 # convert char to offset into table
movzbl (r9)+,r6 # get translated char
movb r6,(r10) # store in table
#csc r10 # complete store characters
sobgtr r7,srpl3 # loop till done
#page
#
# REPLACE (CONTINUED)
#
# HERE TO PERFORM TRANSLATE
#
srpl4: jsb gtstg # get first argument
.long er_170 # replace first argument is not string
tstl r6 # return null if null argument
bnequ 0f
jmp exnul
0:
movl r9,r10 # copy pointer
movl r6,r8 # save length
movab 3+(4*schar)(r6),r6 # get scblk length
bicl2 $3,r6
jsb alloc # allocate space for copy
movl r9,r7 # save address of copy
jsb sbmvw # move scblk contents to copy
movl r$rpt,r9 # point to replace table
movab cfp$f(r9),r9 # point to chars of table
movl r7,r10 # point to string to translate
movab cfp$f(r10),r10 # point to chars of string
movl r8,r6 # set number of chars to translate
jsb sbtrc # perform translation
movl r7,-(sp) # stack new string as result
jmp exits # return with result on stack
#
# ERROR POINT
#
srpl5: jmp er_171 # null or unequally long 2nd, 3rd args to replace
#page
#
# REWIND
#
s$rew: # entry point
jsb iofcb # call fcblk routine
.long er_172 # rewind argument is not a suitable name
.long er_173 # rewind argument is null
jsb sysrw # call system rewind function
.long er_174 # rewind file does not exist
.long er_175 # rewind file does not permit rewind
.long er_176 # rewind caused non-recoverable error
jmp exnul # exit with null result if no error
#page
#
# REVERSE
#
s$rvs: # entry point
jsb gtstg # load string argument
.long er_177 # reverse argument is not string
tstl r6 # return argument if null
bnequ 0f
jmp exixr
0:
movl r9,r10 # else save pointer to string arg
jsb alocs # allocate space for new scblk
movl r9,-(sp) # store scblk ptr on stack as result
movab cfp$f(r9),r9 # prepare to store in new scblk
movab cfp$f(r10)[r8],r10 # point past last char in argument
# set loop counter
#
# LOOP TO MOVE CHARS IN REVERSE ORDER
#
srvs1: movzbl -(r10),r7 # load next char from argument
movb r7,(r9)+ # store in result
sobgtr r8,srvs1 # loop till all moved
#csc r9 # complete store characters
jmp exits # and then jump for next code word
#page
#
# RPAD
#
s$rpd: # entry point
jsb gtstg # get pad character
.long er_178 # rpad third argument is not string
movab cfp$f(r9),r9 # point to character (null is blank)
movzbl (r9),r7 # load pad character
jsb gtsmi # get pad length
.long er_179 # rpad second argument is not integer
.long srpd3 # skip if negative or large
#
# MERGE TO CHECK FIRST ARG.
#
srpd1: jsb gtstg # get first argument (string to pad)
.long er_180 # rpad first argument is not string
cmpl r6,r8 # return 1st arg if too long to pad
blssu 0f
jmp exixr
0:
movl r9,r10 # 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
#
movl r8,r6 # copy length
jsb alocs # allocate scblk for new string
movl r9,-(sp) # save as result
movl 4*sclen(r10),r6 # load length of argument
subl2 r6,r8 # calculate number of pad characters
movab cfp$f(r9),r9 # point to chars in result string
# set counter for pad loop
#
# COPY ARGUMENT STRING
#
tstl r6 # jump if argument is null
beqlu srpd2
movab cfp$f(r10),r10 # else point to argument chars
jsb sbmvc # move characters to result string
#
# LOOP TO SUPPLY PAD CHARACTERS
#
srpd2: movb r7,(r9)+ # store pad character, bump ptr
sobgtr r8,srpd2 # loop till all pad chars stored
#csc r9 # complete character storing
jmp exits # and exit for next word
#
# HERE IF 2ND ARG IS NEGATIVE OR LARGE
#
srpd3: clrl r8 # zero pad count
jmp srpd1 # merge
#page
#
# RTAB
#
s$rtb: # entry point
movl $p$rtb,r7 # set pcode for integer arg case
movl $p$rtd,r6 # set pcode for expression arg case
jsb patin # call common routine to build node
.long er_181 # rtab argument is not integer or expression
.long er_182 # rtab argument is negative or too large
jmp exixr # return pattern node
#page
#
# SET
#
s$set: # entry point
movl (sp)+,r$io2 # save third arg
movl (sp)+,r$io1 # save second arg
jsb iofcb # call fcblk routine
.long er_291 # set first argument is not a suitable name
.long er_292 # set first argument is null
movl r$io1,r7 # load second arg
movl r$io2,r8 # load third arg
jsb sysst # call system set routine
.long er_293 # inappropriate second argument to set
.long er_294 # inappropriate third argument to set
.long er_295 # set file does not exist
.long er_296 # set file does not permit setting file pointer
.long er_297 # set caused non-recoverable i/o error
jmp exnul # otherwisew return null
#page
#
# TAB
#
s$tab: # entry point
movl $p$tab,r7 # set pcode for integer arg case
movl $p$tbd,r6 # set pcode for expression arg case
jsb patin # call common routine to build node
.long er_183 # tab argument is not integer or expression
.long er_184 # tab argument is negative or too large
jmp exixr # return pattern node
#page
#
# RPOS
#
s$rps: # entry point
movl $p$rps,r7 # set pcode for integer arg case
movl $p$rpd,r6 # set pcode for expression arg case
jsb patin # call common routine to build node
.long er_185 # rpos argument is not integer or expression
.long er_186 # rpos argument is negative or too large
jmp exixr # return pattern node
#page
#
# RSORT
#
s$rsr: # entry point
movl sp,r6 # mark as rsort
jsb sorta # call sort routine
jmp exsid # return, setting idval
#page
#
# SETEXIT
#
s$stx: # entry point
movl (sp)+,r9 # load argument
movl stxvr,r6 # load old vrblk pointer
clrl r10 # load zero in case null arg
cmpl r9,$nulls # jump if null argument (reset call)
beqlu sstx1
jsb gtnvr # else get specified vrblk
.long sstx2 # jump if not natural variable
movl 4*vrlbl(r9),r10 # else load label
cmpl r10,$stndl # jump if label is not defined
beqlu sstx2
cmpl (r10),$b$trt # jump if not trapped
bnequ sstx1
movl 4*trlbl(r10),r10# else load ptr to real label code
#
# HERE TO SET/RESET SETEXIT TRAP
#
sstx1: movl r9,stxvr # store new vrblk pointer (or null)
movl r10,r$sxc # store new code ptr (or zero)
cmpl r6,$nulls # return null if null result
bnequ 0f
jmp exnul
0:
movl r6,r9 # else copy vrblk pointer
jmp exvnm # and return building nmblk
#
# HERE IF BAD ARGUMENT
#
sstx2: jmp er_187 # setexit argument is not label name or null
#page
#
# SORT
#
s$srt: # entry point
clrl r6 # mark as sort
jsb sorta # call sort routine
jmp exsid # return, setting idval
#page
#
# SPAN
#
s$spn: # entry point
movl $p$sps,r7 # set pcode for single char arg
movl $p$spn,r10 # set pcode for multi-char arg
movl $p$spd,r8 # set pcode for expression arg
jsb patst # call common routine to build node
.long er_188 # span argument is not string or expression
jmp exixr # jump for next code word
#page
#
# SIZE
#
s$si$: # entry point
movl (sp),r9 # load argument
cmpl (r9),$b$bct # branch if not buffer
bnequ ssi$1
addl2 $4,sp # else pop argument
movl 4*bclen(r9),r5 # load defined length
jmp exint # exit with integer
#
# HERE IF NOT BUFFER
#
ssi$1: jsb gtstg # load string argument
.long er_189 # size argument is not string
movl r6,r5 # load length as integer
jmp exint # exit with integer result
#page
#
# STOPTR
#
s$stt: # entry point
clrl r10 # indicate stoptr case
jsb trace # call trace procedure
.long er_190 # stoptr first argument is not appropriate name
.long er_191 # stoptr second argument is not trace type
jmp exnul # return null
#page
#
# SUBSTR
#
s$sub: # entry point
jsb gtsmi # load third argument
.long er_192 # substr third argument is not integer
.long exfal # jump if negative or too large
movl r9,sbssv # save third argument
jsb gtsmi # load second argument
.long er_193 # substr second argument is not integer
.long exfal # jump if out of range
movl r9,r7 # save second argument
bnequ 0f # jump if second argument zero
jmp exfal
0:
decl r7 # else decrement for ones origin
movl (sp),r10 # get first arg ptr
cmpl (r10),$b$bct # branch if not buffer
bnequ ssuba
movl 4*bcbuf(r10),r9 # get bfblk ptr
movl 4*bclen(r10),r6 # get length
jmp ssubb # merge
#
# HERE IF NOT BUFFER TO GET STRING
#
ssuba: jsb gtstg # load first argument
.long er_194 # substr first argument is not string
#
# MERGE WITH BFBLK OR SCBLK PTR IN XR. WA HAS LENGTH
#
ssubb: movl sbssv,r8 # reload third argument
bnequ ssub1 # skip if third arg given
movl r6,r8 # else get string length
cmpl r7,r8 # fail if improper
blequ 0f
jmp exfal
0:
subl2 r7,r8 # reduce by offset to start
#
# MERGE
#
ssub1: movl r6,r10 # save string length
movl r8,r6 # set length of substring
addl2 r7,r8 # add 2nd arg to 3rd arg
cmpl r8,r10 # jump if improper substring
blequ 0f
jmp exfal
0:
movl r9,r10 # copy pointer to first arg
jsb sbstr # build substring
jmp exixr # and jump for next code word
#page
#
# TABLE
#
s$tbl: # entry point
movl (sp)+,r10 # get initial lookup value
addl2 $4,sp # pop second argument
jsb gtsmi # load argument
.long er_195 # table argument is not integer
.long er_196 # table argument is out of range
tstl r8 # jump if non-zero
bnequ stbl1
movl $tbnbk,r8 # else supply default value
#
# MERGE HERE WITH NUMBER OF HEADERS IN WA
#
stbl1: movl r8,r6 # copy number of headers
addl2 $tbsi$,r6 # adjust for standard fields
moval 0[r6],r6 # convert length to bytes
jsb alloc # allocate space for tbblk
movl r9,r7 # copy pointer to tbblk
movl $b$tbt,(r9)+ # store type word
clrl (r9)+ # zero id for the moment
movl r6,(r9)+ # store length (tblen)
movl r10,(r9)+ # store initial lookup value
# set loop counter (num headers)
#
# LOOP TO INITIALIZE ALL BUCKET POINTERS
#
stbl2: movl r7,(r9)+ # store tbblk ptr in bucket header
sobgtr r8,stbl2 # loop till all stored
movl r7,r9 # recall pointer to tbblk
jmp exsid # exit setting idval
#page
#
# TIME
#
s$tim: # entry point
jsb systm # get timer value
subl2 timsx,r5 # subtract starting time
jmp exint # exit with integer value
#page
#
# TRACE
#
s$tra: # entry point
cmpl 4*3(sp),$nulls # jump if first argument is null
beqlu str03
movl (sp)+,r9 # load fourth argument
clrl r10 # tentatively set zero pointer
cmpl r9,$nulls # jump if 4th argument is null
beqlu str02
jsb gtnvr # else point to vrblk
.long str01 # jump if not variable name
movl 4*vrfnc(r9),r10 # else load function pointer
cmpl r10,$stndf # jump if function is defined
bnequ str02
#
# HERE FOR BAD FOURTH ARGUMENT
#
str01: jmp er_197 # trace fourth arg is not function name or null
#
# HERE WITH FUNCTION POINTER IN XL
#
str02: movl (sp)+,r9 # load third argument (tag)
clrl r7 # set zero as trtyp value for now
jsb trbld # build trblk for trace call
movl r9,r10 # move trblk pointer for trace
jsb trace # call trace procedure
.long er_198 # trace first argument is not appropriate name
.long er_199 # trace second argument is not trace type
jmp exnul # return null
#
# HERE TO CALL SYSTEM TRACE TOGGLE ROUTINE
#
str03: jsb systt # call it
addl2 $4*num04,sp # pop trace arguments
jmp exnul # return
#page
#
# TRIM
#
s$trm: # entry point
jsb gtstg # load argument as string
.long er_200 # trim argument is not string
tstl r6 # return null if argument is null
bnequ 0f
jmp exnul
0:
movl r9,r10 # copy string pointer
movab 3+(4*schar)(r6),r6 # get block length
bicl2 $3,r6
jsb alloc # allocate copy same size
movl r9,r7 # save pointer to copy
jsb sbmvw # copy old string block to new
movl r7,r9 # restore ptr to new block
jsb trimr # trim blanks (wb is non-zero)
jmp exixr # exit with result in xr
#page
#
# UNLOAD
#
s$unl: # entry point
movl (sp)+,r9 # load argument
jsb gtnvr # point to vrblk
.long er_201 # unload argument is not natural variable name
movl $stndf,r10 # get ptr to undefined function
jsb dffnc # undefine named function
jmp exnul # return null as result
#title 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.
#page
#
# 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 # entry point (recursive)
movl r10,r9 # copy name base
addl2 r6,r9 # point to variable location
movl (r9),r9 # load variable value
#
# LOOP HERE TO CHECK FOR SUCCESSIVE TRBLKS
#
acs02: cmpl (r9),$b$trt # jump if not trapped
beqlu 0f
jmp acs18
0:
#
# HERE IF TRAPPED
#
cmpl r9,$trbkv # jump if keyword variable
bnequ 0f
jmp acs12
0:
cmpl r9,$trbev # jump if not expression variable
bnequ acs05
#
# HERE FOR EXPRESSION VARIABLE, EVALUATE VARIABLE
#
movl 4*evexp(r10),r9 # load expression pointer
clrl r7 # evaluate by value
jsb evalx # evaluate expression
.long acs04 # jump if evaluation failure
jmp acs02 # check value for more trblks
#page
#
# ACESS (CONTINUED)
#
# HERE ON READING END OF FILE
#
acs03: addl2 $4*num03,sp # pop trblk ptr, name base and offset
movl r9,dnamp # pop unused scblk
#
# MERGE HERE WHEN EVALUATION OF EXPRESSION FAILS
#
acs04: movl (sp)+,r11 # take alternate (failure) return
jmp *(r11)+
#
# HERE IF NOT KEYWORD OR EXPRESSION VARIABLE
#
acs05: movl 4*trtyp(r9),r7 # load trap type code
beqlu 0f # jump if not input association
jmp acs10
0:
tstl kvinp # ignore input assoc if input is off
bnequ 0f
jmp acs09
0:
#
# HERE FOR INPUT ASSOCIATION
#
movl r10,-(sp) # stack name base
movl r6,-(sp) # stack name offset
movl r9,-(sp) # stack trblk pointer
movl 4*trfpt(r9),r10 # get file ctrl blk ptr or zero
bnequ acs06 # jump if not standard input file
cmpl 4*trter(r9),$v$ter # jump if terminal
bnequ 0f
jmp acs21
0:
#
# HERE TO READ FROM STANDARD INPUT FILE
#
movl cswin,r6 # length for read buffer
jsb alocs # build string of appropriate length
jsb sysrd # read next standard input image
.long acs03 # jump to fail exit if end of file
jmp acs07 # else merge with other file case
#
# HERE FOR INPUT FROM OTHER THAN STANDARD INPUT FILE
#
acs06: movl r10,r6 # fcblk ptr
jsb sysil # get input record max length (to wa)
jsb alocs # allocate string of correct size
movl r10,r6 # fcblk ptr
jsb sysin # call system input routine
.long acs03 # jump to fail exit if end of file
.long acs22 # error
.long acs23 # error
#page
#
# ACESS (CONTINUED)
#
# MERGE HERE AFTER OBTAINING INPUT RECORD
#
acs07: movl kvtrm,r7 # load trim indicator
jsb trimr # trim record as required
movl r9,r7 # copy result pointer
movl (sp),r9 # reload pointer to trblk
#
# LOOP TO CHASE TO END OF TRBLK CHAIN AND STORE VALUE
#
acs08: movl r9,r10 # save pointer to this trblk
movl 4*trnxt(r9),r9 # load forward pointer
cmpl (r9),$b$trt # loop if this is another trblk
beqlu acs08
movl r7,4*trnxt(r10) # else store result at end of chain
movl (sp)+,r9 # restore initial trblk pointer
movl (sp)+,r6 # restore name offset
movl (sp)+,r10 # restore name base pointer
#
# COME HERE TO MOVE TO NEXT TRBLK
#
acs09: movl 4*trnxt(r9),r9 # load forward ptr to next value
jmp acs02 # back to check if trapped
#
# HERE TO CHECK FOR ACCESS TRACE TRBLK
#
acs10: cmpl r7,$trtac # loop back if not access trace
beqlu 0f
jmp acs09
0:
tstl kvtra # ignore access trace if trace off
bnequ 0f
jmp acs09
0:
decl kvtra # else decrement trace count
tstl 4*trfnc(r9) # jump if print trace
beqlu acs11
#page
#
# ACESS (CONTINUED)
#
# HERE FOR FULL FUNCTION TRACE
#
jsb trxeq # call routine to execute trace
jmp acs09 # jump for next trblk
#
# HERE FOR CASE OF PRINT TRACE
#
acs11: jsb prtsn # print statement number
jsb prtnv # print name = value
jmp acs09 # jump back for next trblk
#
# HERE FOR KEYWORD VARIABLE
#
acs12: movl 4*kvnum(r10),r9 # load keyword number
cmpl r9,$k$v$$ # jump if not one word value
bgequ acs14
movl l^kvabe(r9),r5 # else load value as integer
#
# COMMON EXIT WITH KEYWORD VALUE AS INTEGER IN (IA)
#
acs13: jsb icbld # build icblk
jmp acs18 # jump to exit
#
# HERE IF NOT ONE WORD KEYWORD VALUE
#
acs14: cmpl r9,$k$s$$ # jump if special case
bgequ acs15
subl2 $k$v$$,r9 # else get offset
addl2 $ndabo,r9 # point to pattern value
jmp acs18 # jump to exit
#
# HERE IF SPECIAL KEYWORD CASE
#
acs15: movl kvrtn,r10 # load rtntype in case
movl kvstl,r5 # load stlimit in case
subl2 $k$s$$,r9 # get case number
casel r9,$0,$5 # switch on keyword number
5:
.word acs16-5b # jump if alphabet
.word acs17-5b # rtntype
.word acs19-5b # stcount
.word acs20-5b # errtext
.word acs13-5b # stlimit
#esw # end switch on keyword number
#page
#
# ACESS (CONTINUED)
#
# ALPHABET
#
acs16: movl kvalp,r10 # load pointer to alphabet string
#
# RTNTYPE MERGES HERE
#
acs17: movl r10,r9 # copy string ptr to proper reg
#
# COMMON RETURN POINT
#
acs18: addl2 $4*1,(sp) # return to acess caller
rsb
#
# HERE FOR STCOUNT (IA HAS STLIMIT)
#
acs19: subl2 kvstc,r5 # stcount = limit - left
jmp acs13 # merge back with integer result
#
# ERRTEXT
#
acs20: movl r$etx,r9 # get errtext string
jmp acs18 # merge with result
#
# HERE TO READ A RECORD FROM TERMINAL
#
acs21: movl $rilen,r6 # buffer length
jsb alocs # allocate buffer
jsb sysri # read record
.long acs03 # endfile
jmp acs07 # merge with record read
#
# ERROR RETURNS
#
acs22: movl r9,dnamp # pop unused scblk
jmp er_202 # input from file caused non-recoverable error
#
acs23: movl r9,dnamp # pop unused scblk
jmp er_203 # input file record has incorrect format
#enp # end procedure acess
#page
#
# 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
#
.data 1
acomp_s: .long 0
.text 0
acomp: movl (sp)+,acomp_s # entry point
jsb arith # load arithmetic operands
.long acmp7 # jump if first arg non-numeric
.long acmp8 # jump if second arg non-numeric
.long acmp4 # jump if real arguments
#
# HERE FOR INTEGER ARGUMENTS
#
subl2 4*icval(r10),r5 # subtract to compare
bvs acmp3
tstl r5 # else jump if arg1 lt arg2
blss acmp5
tstl r5 # jump if arg1 eq arg2
beql acmp2
#
# HERE IF ARG1 GT ARG2
#
acmp1: addl3 $4*4,acomp_s,r11 # take gt exit
jmp *(r11)+
#
# HERE IF ARG1 EQ ARG2
#
acmp2: addl3 $4*3,acomp_s,r11 # take eq exit
jmp *(r11)+
#page
#
# ACOMP (CONTINUED)
#
# HERE FOR INTEGER OVERFLOW ON SUBTRACT
#
acmp3: movl 4*icval(r10),r5 # load second argument
blss acmp1 # gt if negative
jmp acmp5 # else lt
#
# HERE FOR REAL OPERANDS
#
acmp4: subf2 4*rcval(r10),r2 # subtract to compare
bvs acmp6
tstf r2 # else jump if arg1 gt
bgtr acmp1
tstf r2 # jump if arg1 eq arg2
beql acmp2
#
# HERE IF ARG1 LT ARG2
#
acmp5: addl3 $4*2,acomp_s,r11 # take lt exit
jmp *(r11)+
#
# HERE IF OVERFLOW ON REAL SUBTRACTION
#
acmp6: movf 4*rcval(r10),r2 # reload arg2
tstf r2 # gt if negative
blss acmp1
jmp acmp5 # else lt
#
# HERE IF ARG1 NON-NUMERIC
#
acmp7: movl acomp_s,r11 # take error exit
jmp *(r11)+
#
# HERE IF ARG2 NON-NUMERIC
#
acmp8: addl3 $4*1,acomp_s,r11 # take error exit
jmp *(r11)+
#enp # end procedure acomp
#page
#
# 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 # entry point
#
# COMMON EXIT POINT
#
aloc1: movl dnamp,r9 # point to next available loc
addl2 r6,r9 # point past allocated block
bvc 0f
jmp aloc2
0:
cmpl r9,dname # jump if not enough room
bgtru aloc2
movl r9,dnamp # store new pointer
subl2 r6,r9 # point back to start of allocated bk
rsb # return to caller
#
# HERE IF INSUFFICIENT ROOM, TRY A GARBAGE COLLECTION
#
aloc2: movl r7,allsv # save wb
clrl r7 # set no upward move for gbcol
jsb gbcol # garbage collect
#
# SEE IF ROOM AFTER GBCOL OR SYSMM CALL
#
aloc3: movl dnamp,r9 # point to first available loc
addl2 r6,r9 # point past new block
bvc 0f
jmp alc3a
0:
cmpl r9,dname # jump if there is room now
blequ aloc4
#
# FAILED AGAIN, SEE IF WE CAN GET MORE CORE
#
alc3a: jsb sysmm # try to get more memory
moval 0[r9],r9 # convert to baus (sgd05)
addl2 r9,dname # bump ptr by amount obtained
tstl r9 # jump if got more core
bnequ aloc3
addl2 rsmem,dname # get the reserve memory
clrl rsmem # only permissible once
incl errft # fatal error
jmp er_204 # memory overflow
#page
#
# HERE AFTER SUCCESSFUL GARBAGE COLLECTION
#
aloc4: movl r5,allia # save ia
movl dname,r7 # get dynamic end adrs
subl2 dnamp,r7 # compute free store
ashl $-2,r7,r7 # convert bytes to words
movl r7,r5 # put free store in ia
mull2 alfsf,r5 # multiply by free store factor
bvs aloc5
movl dname,r7 # dynamic end adrs
subl2 dnamb,r7 # compute total amount of dynamic
ashl $-2,r7,r7 # convert to words
movl r7,aldyn # store it
subl2 aldyn,r5 # subtract from scaled up free store
bgtr aloc5 # jump if sufficient free store
jsb sysmm # try to get more store
moval 0[r9],r9 # convert to baus (sgd05)
addl2 r9,dname # adjust dynamic end adrs
#
# MERGE TO RESTORE IA AND WB
#
aloc5: movl allia,r5 # recover ia
movl allsv,r7 # restore wb
jmp aloc1 # jump back to exit
#enp # end procedure alloc
#page
#
# 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 # entry point
movl r6,r7 # hang onto allocation size
movab 3+(4*bfsi$)(r6),r6 # get total block size
bicl2 $3,r6
cmpl r6,mxlen # check for maxlen exceeded
bgequ alb01
addl2 $4*bcsi$,r6 # add in allocation for bcblk
jsb alloc # allocate frame
movl $b$bct,(r9) # set type
clrl 4*idval(r9) # no id yet
clrl 4*bclen(r9) # no defined length
movl r10,r6 # save xl
movl r9,r10 # copy bcblk ptr
addl2 $4*bcsi$,r10 # bias past partially built bcblk
movl $b$bft,(r10) # set bfblk type word
movl r7,4*bfalc(r10) # set allocated size
movl r10,4*bcbuf(r9) # set pointer in bcblk
clrl 4*bfchr(r10) # clear first word (null pad)
movl r6,r10 # restore entry xl
rsb # return to caller
#
# HERE FOR MXLEN EXCEEDED
#
alb01: jmp er_274 # requested buffer allocation exceeds mxlen
#enp # end procedure alobf
#page
#
# 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 # entry point
cmpl r6,kvmxl # jump if length exceeeds maxlength
bgtru alcs2
movl r6,r8 # else copy length
movab 3+(4*scsi$)(r6),r6 # compute length of scblk in bytes
bicl2 $3,r6
movl dnamp,r9 # point to next available location
addl2 r6,r9 # point past block
bvc 0f
jmp alcs0
0:
cmpl r9,dname # jump if there is room
blequ alcs1
#
# INSUFFICIENT MEMORY
#
alcs0: clrl r9 # else clear garbage xr value
jsb alloc # and use standard allocator
addl2 r6,r9 # point past end of block to merge
#
# MERGE HERE WITH XR POINTING BEYOND NEW BLOCK
#
alcs1: movl r9,dnamp # set updated storage pointer
clrl -(r9) # store zero chars in last word
subl2 $4,r6 # decrement length
subl2 r6,r9 # point back to start of block
movl $b$scl,(r9) # set type word
movl r8,4*sclen(r9) # store length in chars
rsb # return to alocs caller
#
# COME HERE IF STRING IS TOO LONG
#
alcs2: jmp er_205 # string length exceeds value of maxlngth keyword
#enp # end procedure alocs
#page
#
# 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 # entry point
#
# MERGE BACK HERE AFTER ALLOCATING NEW CHUNK
#
alst1: movl state,r9 # point to current end of area
addl2 r6,r9 # point beyond proposed block
bvc 0f
jmp alst2
0:
cmpl r9,dnamb # jump if overlap with dynamic area
bgequ alst2
movl r9,state # else store new pointer
subl2 r6,r9 # point back to start of block
rsb # return to alost caller
#
# HERE IF NO ROOM, PREPARE TO MOVE DYNAMIC STORAGE UP
#
alst2: movl r6,alsta # save wa
cmpl r6,$4*e$sts # skip if requested chunk is large
bgequ alst3
movl $4*e$sts,r6 # else set to get large enough chunk
#
# HERE WITH AMOUNT TO MOVE UP IN WA
#
alst3: jsb alloc # allocate block to ensure room
movl r9,dnamp # and delete it
movl r6,r7 # copy move up amount
jsb gbcol # call gbcol to move dynamic area up
movl alsta,r6 # restore wa
jmp alst1 # loop back to try again
#enp # end procedure alost
#page
#
# 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 # entry point
movl 4*bclen(r9),r6 # load offset to insert
clrl r7 # replace section is null
jsb insbf # call to insert at end
.long apn01 # convert error
.long apn02 # no room
addl2 $4*2,(sp) # return to caller
rsb
#
# HERE TO TAKE CONVERT FAILURE EXIT
#
apn01: movl (sp)+,r11 # return to caller alternate
jmp *(r11)+
#
# HERE FOR NO FIT EXIT
#
apn02: addl3 $4*1,(sp)+,r11 # alternate exit to caller
jmp *(r11)+
#enp # end procedure apndb
#page
#
# 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
#page
#
# ARITH (CONTINUED)
#
# ENTRY POINT
#
.data 1
arith_s: .long 0
.text 0
arith: movl (sp)+,arith_s # entry point
movl (sp)+,r10 # load right operand
movl (sp)+,r9 # load left operand
movl (r10),r6 # get right operand type word
cmpl r6,$b$icl # jump if integer
beqlu arth1
cmpl r6,$b$rcl # jump if real
beqlu arth4
movl r9,-(sp) # else replace left arg on stack
movl r10,r9 # copy left arg pointer
jsb gtnum # convert to numeric
.long arth6 # jump if unconvertible
movl r9,r10 # else copy converted result
movl (r10),r6 # get right operand type word
movl (sp)+,r9 # reload left argument
cmpl r6,$b$rcl # jump if right arg is real
beqlu arth4
#
# HERE IF RIGHT ARG IS AN INTEGER
#
arth1: cmpl (r9),$b$icl # jump if left arg not integer
bnequ arth3
#
# EXIT FOR INTEGER CASE
#
arth2: movl 4*icval(r9),r5 # load left operand value
addl3 $4*3,arith_s,r11 # return to arith caller
jmp (r11)
#
# HERE FOR RIGHT OPERAND INTEGER, LEFT OPERAND NOT
#
arth3: jsb gtnum # convert left arg to numeric
.long arth7 # jump if not convertible
cmpl r6,$b$icl # jump back if integer-integer
beqlu arth2
#
# HERE WE MUST CONVERT REAL-INTEGER TO REAL-REAL
#
movl r9,-(sp) # put left arg back on stack
movl 4*icval(r10),r5 # load right argument value
cvtlf r5,r2 # convert to real
jsb rcbld # get real block for right arg, merge
movl r9,r10 # copy right arg ptr
movl (sp)+,r9 # load left argument
jmp arth5 # merge for real-real case
#page
#
# ARITH (CONTINUED)
#
# HERE IF RIGHT ARGUMENT IS REAL
#
arth4: cmpl (r9),$b$rcl # jump if left arg real
beqlu arth5
jsb gtrea # else convert to real
.long arth7 # error if unconvertible
#
# HERE FOR REAL-REAL
#
arth5: movf 4*rcval(r9),r2 # load left operand value
addl3 $4*2,arith_s,r11 # take real-real exit
jmp *(r11)+
#
# HERE FOR ERROR CONVERTING RIGHT ARGUMENT
#
arth6: addl2 $4,sp # pop unwanted left arg
addl3 $4*1,arith_s,r11 # take appropriate error exit
jmp *(r11)+
#
# HERE FOR ERROR CONVERTING LEFT OPERAND
#
arth7: movl arith_s,r11 # take appropriate error return
jmp *(r11)+
#enp # end procedure arith
#page
#
# 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 # entry point (recursive)
#
# MERGE BACK HERE TO ASSIGN RESULT TO EXPRESSION VARIABLE.
#
asg01: addl2 r6,r10 # point to variable value
movl (r10),r9 # load variable value
cmpl (r9),$b$trt # jump if trapped
beqlu asg02
movl r7,(r10) # else perform assignment
clrl r10 # clear garbage value in xl
addl2 $4*1,(sp) # and return to asign caller
rsb
#
# HERE IF VALUE IS TRAPPED
#
asg02: subl2 r6,r10 # restore name base
cmpl r9,$trbkv # jump if keyword variable
bnequ 0f
jmp asg14
0:
cmpl r9,$trbev # jump if not expression variable
bnequ asg04
#
# HERE FOR ASSIGNMENT TO EXPRESSION VARIABLE
#
movl 4*evexp(r10),r9 # point to expression
movl r7,-(sp) # store value to assign on stack
movl $num01,r7 # set for evaluation by name
jsb evalx # evaluate expression by name
.long asg03 # jump if evaluation fails
movl (sp)+,r7 # else reload value to assign
jmp asg01 # loop back to perform assignment
#page
#
# ASIGN (CONTINUED)
#
# HERE FOR FAILURE DURING EXPRESSION EVALUATION
#
asg03: addl2 $4,sp # remove stacked value entry
movl (sp)+,r11 # take failure exit
jmp *(r11)+
#
# HERE IF NOT KEYWORD OR EXPRESSION VARIABLE
#
asg04: movl r9,-(sp) # save ptr to first trblk
#
# LOOP TO CHASE DOWN TRBLK CHAIN AND ASSIGN VALUE AT END
#
asg05: movl r9,r8 # save ptr to this trblk
movl 4*trnxt(r9),r9 # point to next trblk
cmpl (r9),$b$trt # loop back if another trblk
beqlu asg05
movl r8,r9 # else point back to last trblk
movl r7,4*trval(r9) # store value at end of chain
movl (sp)+,r9 # restore ptr to first trblk
#
# LOOP TO PROCESS TRBLK ENTRIES ON CHAIN
#
asg06: movl 4*trtyp(r9),r7 # load type code of trblk
cmpl r7,$trtvl # jump if value trace
beqlu asg08
cmpl r7,$trtou # jump if output association
beqlu asg10
#
# HERE TO MOVE TO NEXT TRBLK ON CHAIN
#
asg07: movl 4*trnxt(r9),r9 # point to next trblk on chain
cmpl (r9),$b$trt # loop back if another trblk
beqlu asg06
addl2 $4*1,(sp) # else end of chain, return to caller
rsb
#
# HERE TO PROCESS VALUE TRACE
#
asg08: tstl kvtra # ignore value trace if trace off
beqlu asg07
decl kvtra # else decrement trace count
tstl 4*trfnc(r9) # jump if print trace
beqlu asg09
jsb trxeq # else execute function trace
jmp asg07 # and loop back
#page
#
# ASIGN (CONTINUED)
#
# HERE FOR PRINT TRACE
#
asg09: jsb prtsn # print statement number
jsb prtnv # print name = value
jmp asg07 # loop back for next trblk
#
# HERE FOR OUTPUT ASSOCIATION
#
asg10: tstl kvoup # ignore output assoc if output off
beqlu asg07
movl r9,r10 # else copy trblk pointer
movl 4*trval(r8),-(sp)# stack value to output (sgd01)
jsb gtstg # convert to string
.long asg12 # get datatype name if unconvertible
#
# MERGE WITH STRING FOR OUTPUT
#
asg11: movl 4*trfpt(r10),r6 # fcblk ptr
beqlu asg13 # jump if standard output file
#
# HERE FOR OUTPUT TO NON-STANDARD OUTPUT FILE
#
jsb sysou # call system output routine
.long er_206 # output caused file overflow
.long er_207 # output caused non-recoverable error
addl2 $4*1,(sp) # else all done, return to caller
rsb
#
# IF NOT PRINTABLE, GET DATATYPE NAME INSTEAD
#
asg12: jsb dtype # call datatype routine
jmp asg11 # merge
#
# HERE TO PRINT A STRING ON THE PRINTER
#
asg13: jsb prtst # print string value
cmpl 4*trter(r10),$v$ter # jump if terminal output
bnequ 0f
jmp asg20
0:
jsb prtnl # end of line
addl2 $4*1,(sp) # return to caller
rsb
#page
#
# ASIGN (CONTINUED)
#
# HERE FOR KEYWORD ASSIGNMENT
#
asg14: movl 4*kvnum(r10),r10# load keyword number
cmpl r10,$k$etx # jump if errtext
bnequ 0f
jmp asg19
0:
movl r7,r9 # copy value to be assigned
jsb gtint # convert to integer
.long er_208 # keyword value assigned is not integer
movl 4*icval(r9),r5 # else load value
cmpl r10,$k$stl # jump if special case of stlimit
beqlu asg16
movl r5,r6 # else get addr integer, test ovflow
bgeq 0f
jmp asg18
0:
cmpl r6,mxlen # fail if too large
bgequ asg18
cmpl r10,$k$ert # jump if special case of errtype
beqlu asg17
cmpl r10,$k$pfl # jump if special case of profile
beqlu asg21
cmpl r10,$k$p$$ # jump unless protected
blssu asg15
jmp er_209 # keyword in assignment is protected
#
# HERE TO DO ASSIGNMENT IF NOT PROTECTED
#
asg15: movl r6,l^kvabe(r10) # store new value
addl2 $4*1,(sp) # return to asign caller
rsb
#
# HERE FOR SPECIAL CASE OF STLIMIT
#
# SINCE STCOUNT IS MAINTAINED AS (STLIMIT-STCOUNT)
# IT IS ALSO NECESSARY TO MODIFY STCOUNT APPROPRIATELY.
#
asg16: subl2 kvstl,r5 # subtract old limit
addl2 kvstc,r5 # add old counter
movl r5,kvstc # store new counter value
movl 4*icval(r9),r5 # reload new limit value
movl r5,kvstl # store new limit value
addl2 $4*1,(sp) # return to asign caller
rsb
#
# HERE FOR SPECIAL CASE OF ERRTYPE
#
asg17: cmpl r6,$nini9 # ok to signal if in range
bgtru 0f
jmp error
0:
#
# HERE IF VALUE ASSIGNED IS OUT OF RANGE
#
asg18: jmp er_210 # keyword value assigned is negative or too large
#
# HERE FOR SPECIAL CASE OF ERRTEXT
#
asg19: movl r7,-(sp) # stack value
jsb gtstg # convert to string
.long er_211 # value assigned to keyword errtext not a string
movl r9,r$etx # make assignment
addl2 $4*1,(sp) # return to caller
rsb
#
# PRINT STRING TO TERMINAL
#
asg20: jsb prttr # print
addl2 $4*1,(sp) # return
rsb
#
# HERE FOR KEYWORD PROFILE
#
asg21: cmpl r6,$num02 # moan if not 0,1, or 2
bgtru asg18
tstl r6 # just assign if zero
beqlu asg15
tstl pfdmp # branch if first assignment
beqlu asg22
cmpl r6,pfdmp # also if same value as before
beqlu asg23
jmp er_268 # inconsistent value assigned to keyword profile
#
asg22: movl r6,pfdmp # note value on first assignment
asg23: jsb systm # get the time
movl r5,pfstm # fudge some kind of start time
jmp asg15 # and go assign
#enp # end procedure asign
#page
#
# 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 # entry point, recursive
addl2 r6,r10 # point to variable
movl (r10),r9 # load current contents
cmpl (r9),$b$trt # jump if trapped
beqlu asnp1
movl r7,(r10) # else perform assignment
clrl r10 # clear garbage value in xl
addl2 $4*1,(sp) # return to asinp caller
rsb
#
# HERE IF VARIABLE IS TRAPPED
#
asnp1: subl2 r6,r10 # restore base pointer
movl pmssl,-(sp) # stack subject string length
movl pmhbs,-(sp) # stack history stack base ptr
movl r$pms,-(sp) # stack subject string pointer
movl pmdfl,-(sp) # stack dot flag
jsb asign # call full-blown assignment routine
.long asnp2 # jump if failure
movl (sp)+,pmdfl # restore dot flag
movl (sp)+,r$pms # restore subject string pointer
movl (sp)+,pmhbs # restore history stack base pointer
movl (sp)+,pmssl # restore subject string length
addl2 $4*1,(sp) # return to asinp caller
rsb
#
# HERE IF FAILURE IN ASIGN CALL
#
asnp2: movl (sp)+,pmdfl # restore dot flag
movl (sp)+,r$pms # restore subject string pointer
movl (sp)+,pmhbs # restore history stack base pointer
movl (sp)+,pmssl # restore subject string length
movl (sp)+,r11 # take failure exit
jmp *(r11)+
#enp # end procedure asinp
#page
#
# 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 # entry point
movl r6,r10 # copy first word
movzwl -2(r10),r10 # get entry id (bl$xx)
casel r10,$0,$bl$$$ # switch on block type
5:
.word bln01-5b # arblk
.word bln04-5b # bcblk
.word bln01-5b # cdblk
.word bln01-5b # exblk
.word bln07-5b # icblk
.word bln03-5b # nmblk
.word bln02-5b # p0blk
.word bln03-5b # p1blk
.word bln04-5b # p2blk
.word bln09-5b # rcblk
.word bln10-5b # scblk
.word bln02-5b # seblk
.word bln01-5b # tbblk
.word bln01-5b # vcblk
.word bln00-5b
.word bln00-5b
.word bln08-5b # pdblk
.word bln05-5b # trblk
.word bln11-5b # bfblk
.word bln00-5b
.word bln00-5b
.word bln06-5b # ctblk
.word bln01-5b # dfblk
.word bln01-5b # efblk
.word bln03-5b # evblk
.word bln05-5b # ffblk
.word bln03-5b # kvblk
.word bln01-5b # pfblk
.word bln04-5b # teblk
#esw # end of jump table on block type
#page
#
# BLKLN (CONTINUED)
#
# HERE FOR BLOCKS WITH LENGTH IN SECOND WORD
#
bln00: movl 4*1(r9),r6 # load length
rsb # return to blkln caller
#
# HERE FOR LENGTH IN THIRD WORD (AR,CD,DF,EF,EX,PF,TB,VC)
#
bln01: movl 4*2(r9),r6 # load length from third word
rsb # return to blkln caller
#
# HERE FOR TWO WORD BLOCKS (P0,SE)
#
bln02: movl $4*num02,r6 # load length (two words)
rsb # return to blkln caller
#
# HERE FOR THREE WORD BLOCKS (NM,P1,EV,KV)
#
bln03: movl $4*num03,r6 # load length (three words)
rsb # return to blkln caller
#
# HERE FOR FOUR WORD BLOCKS (P2,TE,BC)
#
bln04: movl $4*num04,r6 # load length (four words)
rsb # return to blkln caller
#
# HERE FOR FIVE WORD BLOCKS (FF,TR)
#
bln05: movl $4*num05,r6 # load length
rsb # return to blkln caller
#page
#
# BLKLN (CONTINUED)
#
# HERE FOR CTBLK
#
bln06: movl $4*ctsi$,r6 # set size of ctblk
rsb # return to blkln caller
#
# HERE FOR ICBLK
#
bln07: movl $4*icsi$,r6 # set size of icblk
rsb # return to blkln caller
#
# HERE FOR PDBLK
#
bln08: movl 4*pddfp(r9),r10 # point to dfblk
movl 4*dfpdl(r10),r6 # load pdblk length from dfblk
rsb # return to blkln caller
#
# HERE FOR RCBLK
#
bln09: movl $4*rcsi$,r6 # set size of rcblk
rsb # return to blkln caller
#
# HERE FOR SCBLK
#
bln10: movl 4*sclen(r9),r6 # load length in characters
movab 3+(4*scsi$)(r6),r6 # calculate length in bytes
bicl2 $3,r6
rsb # return to blkln caller
#
# HERE FOR BFBLK
#
bln11: movl 4*bfalc(r9),r6 # get allocation in bytes
movab 3+(4*bfsi$)(r6),r6 # calculate length in bytes
bicl2 $3,r6
rsb # return to blkln caller
#enp # end procedure blkln
#page
#
# 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
#
.data 1
copyb_s: .long 0
.text 0
copyb: movl (sp)+,copyb_s # entry point
movl (sp),r9 # load argument
cmpl r9,$nulls # return argument if it is null
bnequ 0f
jmp cop10
0:
movl (r9),r6 # else load type word
movl r6,r7 # copy type word
jsb blkln # get length of argument block
movl r9,r10 # copy pointer
jsb alloc # allocate block of same size
movl r9,(sp) # store pointer to copy
jsb sbmvw # copy contents of old block to new
movl (sp),r9 # reload pointer to start of copy
cmpl r7,$b$tbt # jump if table
beqlu cop05
cmpl r7,$b$vct # jump if vector
beqlu cop01
cmpl r7,$b$pdt # jump if program defined
beqlu cop01
cmpl r7,$b$bct # jump if buffer
bnequ 0f
jmp cop11
0:
cmpl r7,$b$art # return copy if not array
beqlu 0f
jmp cop10
0:
#
# HERE FOR ARRAY (ARBLK)
#
addl2 4*arofs(r9),r9 # point to prototype field
jmp cop02 # jump to merge
#
# HERE FOR VECTOR, PROGRAM DEFINED
#
cop01: addl2 $4*pdfld,r9 # point to pdfld = vcvls
#
# MERGE HERE FOR ARBLK, VCBLK, PDBLK TO DELETE TRAP
# BLOCKS FROM ALL VALUE FIELDS (THE COPY IS UNTRAPPED)
#
cop02: movl (r9),r10 # load next pointer
#
# LOOP TO GET VALUE AT END OF TRBLK CHAIN
#
cop03: cmpl (r10),$b$trt # jump if not trapped
bnequ cop04
movl 4*trval(r10),r10# else point to next value
jmp cop03 # and loop back
#page
#
# COPYB (CONTINUED)
#
# HERE WITH UNTRAPPED VALUE IN XL
#
cop04: movl r10,(r9)+ # store real value, bump pointer
cmpl r9,dnamp # loop back if more to go
bnequ cop02
jmp cop09 # else jump to exit
#
# HERE TO COPY A TABLE
#
cop05: clrl 4*idval(r9) # zero id to stop dump blowing up
movl $4*tesi$,r6 # set size of teblk
movl $4*tbbuk,r8 # set initial offset
#
# LOOP THROUGH BUCKETS IN TABLE
#
cop06: movl (sp),r9 # load table pointer
cmpl r8,4*tblen(r9) # jump to exit if all done
beqlu cop09
addl2 r8,r9 # else point to next bucket header
addl2 $4,r8 # bump offset
subl2 $4*tenxt,r9 # subtract link offset to merge
#
# LOOP THROUGH TEBLKS ON ONE CHAIN
#
cop07: movl 4*tenxt(r9),r10 # load pointer to next teblk
movl (sp),4*tenxt(r9)# set end of chain pointer in case
cmpl (r10),$b$tbt # back for next bucket if chain end
beqlu cop06
movl r9,-(sp) # else stack ptr to previous block
movl $4*tesi$,r6 # set size of teblk
jsb alloc # allocate new teblk
movl r9,r7 # save ptr to new teblk
jsb sbmvw # copy old teblk to new teblk
movl r7,r9 # restore pointer to new teblk
movl (sp)+,r10 # restore pointer to previous block
movl r9,4*tenxt(r10) # link new block to previous
movl r9,r10 # copy pointer to new block
#
# LOOP TO SET REAL VALUE AFTER REMOVING TRAP CHAIN
#
cop08: movl 4*teval(r10),r10# load value
cmpl (r10),$b$trt # loop back if trapped
beqlu cop08
movl r10,4*teval(r9) # store untrapped value in teblk
jmp cop07 # back for next teblk
#
# COMMON EXIT POINT
#
cop09: movl (sp)+,r9 # load pointer to block
addl3 $4*1,copyb_s,r11 # return
jmp (r11)
#
# ALTERNATIVE RETURN
#
cop10: movl copyb_s,r11 # return
jmp *(r11)+
#page
#
# HERE TO COPY BUFFER
#
cop11: movl 4*bcbuf(r9),r10 # get bfblk ptr
movl 4*bfalc(r10),r6 # get allocation
movab 3+(4*bfsi$)(r6),r6 # set total size
bicl2 $3,r6
movl r9,r10 # save bcblk ptr
jsb alloc # allocate bfblk
movl 4*bcbuf(r10),r7 # get old bfblk
movl r9,4*bcbuf(r10) # set pointer to new bfblk
movl r7,r10 # point to old bfblk
jsb sbmvw # copy bfblk too
clrl r10 # clear rubbish ptr
jmp 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 # entry point
movl 4*cmopn(r9),r10 # get unary goto operator
movl 4*cmrop(r9),r9 # point to goto operand
cmpl r10,$opdvd # jump if direct goto
beqlu cdgc2
jsb cdgnm # generate opnd by name if not direct
#
# RETURN POINT
#
cdgc1: movl r10,r6 # goto operator
jsb cdwrd # generate it
rsb # return to caller
#
# DIRECT GOTO
#
cdgc2: jsb cdgvl # generate operand by value
jmp cdgc1 # merge to return
#enp # end procedure cdgcg
#page
#
# 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 # entry point, recursive
cmpl (r10),$b$vr$ # jump if not variable
blequ cdgx1
#
# HERE FOR NATURAL VARIABLE, BUILD SEBLK
#
movl $4*sesi$,r6 # set size of seblk
jsb alloc # allocate space for seblk
movl $b$sel,(r9) # set type word
movl r10,4*sevar(r9) # store vrblk pointer
rsb # return to cdgex caller
#
# HERE IF NOT VARIABLE, BUILD EXBLK
#
cdgx1: movl r10,r9 # copy tree pointer
movl r8,-(sp) # save wc
movl cwcof,r10 # save current offset
movl (r9),r6 # get type word
cmpl r6,$b$cmt # call by value if not cmblk
bnequ cdgx2
cmpl 4*cmtyp(r9),$c$$nm # jump if cmblk only by value
bgequ cdgx2
#page
#
# CDGEX (CONTINUED)
#
# HERE IF EXPRESSION CAN BE EVALUATED BY NAME
#
jsb cdgnm # generate code by name
movl $ornm$,r6 # load return by name word
jmp cdgx3 # merge with value case
#
# HERE IF EXPRESSION CAN ONLY BE EVALUATED BY VALUE
#
cdgx2: jsb cdgvl # generate code by value
movl $orvl$,r6 # load return by value word
#
# MERGE HERE TO CONSTRUCT EXBLK
#
cdgx3: jsb cdwrd # generate return word
jsb exbld # build exblk
movl (sp)+,r8 # restore wc
rsb # return to cdgex caller
#enp # end procedure cdgex
#page
#
# 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 # entry point, recursive
movl r10,-(sp) # save entry xl
movl r7,-(sp) # save entry wb
jsb sbchk # check for stack overflow
movl (r9),r6 # load type word
cmpl r6,$b$cmt # jump if cmblk
beqlu cgn04
cmpl r6,$b$vr$ # jump if simple variable
blssu 0f
jmp cgn02
0:
#
# MERGE HERE FOR OPERAND YIELDING VALUE (E.G. CONSTANT)
#
cgn01: jmp er_212 # syntax error. value used where name is required
#
# HERE FOR NATURAL VARIABLE REFERENCE
#
cgn02: movl $olvn$,r6 # load variable load call
jsb cdwrd # generate it
movl r9,r6 # copy vrblk pointer
jsb cdwrd # generate vrblk pointer
#page
#
# CDGNM (CONTINUED)
#
# HERE TO EXIT WITH WC SET CORRECTLY
#
cgn03: movl (sp)+,r7 # restore entry wb
movl (sp)+,r10 # restore entry xl
rsb # return to cdgnm caller
#
# HERE FOR CMBLK
#
cgn04: movl r9,r10 # copy cmblk pointer
movl 4*cmtyp(r9),r9 # load cmblk type
cmpl r9,$c$$nm # error if not name operand
bgequ cgn01
casel r9,$0,$c$$nm # else switch on type
5:
.word cgn05-5b # array reference
.word cgn08-5b # function call
.word cgn09-5b # deferred expression
.word cgn10-5b # indirect reference
.word cgn11-5b # keyword reference
.word cgn08-5b # undefined binary op
.word cgn08-5b # undefined unary op
#esw # end switch on cmblk type
#
# HERE TO GENERATE CODE FOR ARRAY REFERENCE
#
cgn05: movl $4*cmopn,r7 # point to array operand
#
# LOOP TO GENERATE CODE FOR ARRAY OPERAND AND SUBSCRIPTS
#
cgn06: jsb cmgen # generate code for next operand
movl 4*cmlen(r10),r8 # load length of cmblk
cmpl r7,r8 # loop till all generated
blssu cgn06
#
# GENERATE APPROPRIATE ARRAY CALL
#
movl $oaon$,r6 # load one-subscript case call
cmpl r8,$4*cmar1 # jump to exit if one subscript case
beqlu cgn07
movl $oamn$,r6 # else load multi-subscript case call
jsb cdwrd # generate call
movl r8,r6 # copy cmblk length
ashl $-2,r6,r6 # convert to words
subl2 $cmvls,r6 # calculate number of subscripts
#page
#
# CDGNM (CONTINUED)
#
# HERE TO EXIT GENERATING WORD (NON-CONSTANT)
#
cgn07: movl sp,r8 # set result non-constant
jsb cdwrd # generate word
jmp cgn03 # back to exit
#
# HERE TO GENERATE CODE FOR FUNCTIONS AND UNDEFINED OPRS
#
cgn08: movl r10,r9 # copy cmblk pointer
jsb cdgvl # gen code by value for call
movl $ofne$,r6 # get extra call for by name
jmp cgn07 # back to generate and exit
#
# HERE TO GENERATE CODE FOR DEFERED EXPRESSION
#
cgn09: movl 4*cmrop(r10),r9 # check if variable
cmpl (r9),$b$vr$ # treat *variable as simple var
blssu 0f
jmp cgn02
0:
movl r9,r10 # copy ptr to expression tree
jsb cdgex # else build exblk
movl $olex$,r6 # set call to load expr by name
jsb cdwrd # generate it
movl r9,r6 # copy exblk pointer
jsb cdwrd # generate exblk pointer
jmp cgn03 # back to exit
#
# HERE TO GENERATE CODE FOR INDIRECT REFERENCE
#
cgn10: movl 4*cmrop(r10),r9 # get operand
jsb cdgvl # generate code by value for it
movl $oinn$,r6 # load call for indirect by name
jmp cgn12 # merge
#
# HERE TO GENERATE CODE FOR KEYWORD REFERENCE
#
cgn11: movl 4*cmrop(r10),r9 # get operand
jsb cdgnm # generate code by name for it
movl $okwn$,r6 # load call for keyword by name
#
# KEYWORD, INDIRECT MERGE HERE
#
cgn12: jsb cdwrd # generate code for operator
jmp cgn03 # exit
#enp # end procedure cdgnm
#page
#
# 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 # entry point, recursive
movl (r9),r6 # load type word
cmpl r6,$b$cmt # jump if cmblk
beqlu cgv01
cmpl r6,$b$vra # jump if icblk, rcblk, scblk
blssu cgv00
tstl 4*vrlen(r9) # jump if not system variable
bnequ cgvl0
movl r9,-(sp) # stack xr
movl 4*vrsvp(r9),r9 # point to svblk
movl 4*svbit(r9),r6 # get svblk property bits
movl (sp)+,r9 # recover xr
mcoml btckw,r11 # check if constant keyword
bicl2 r11,r6
bnequ cgv00 # jump if constant keyword
#
# HERE FOR VARIABLE VALUE REFERENCE
#
cgvl0: movl sp,r8 # indicate non-constant value
#
# MERGE HERE FOR SIMPLE CONSTANT (ICBLK,RCBLK,SCBLK)
# AND FOR VARIABLES CORRESPONDING TO CONSTANT KEYWORDS.
#
cgv00: movl r9,r6 # copy ptr to var or constant
jsb cdwrd # generate as code word
rsb # return to caller
#page
#
# CDGVL (CONTINUED)
#
# HERE FOR TREE NODE (CMBLK)
#
cgv01: movl r7,-(sp) # save entry wb
movl r10,-(sp) # save entry xl
movl r8,-(sp) # save entry constant flag
movl cwcof,-(sp) # save initial code offset
jsb sbchk # 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.
#
movl r9,r10 # copy cmblk pointer
movl 4*cmtyp(r9),r9 # load cmblk type
movl cswno,r8 # reset constant flag
cmpl r9,$c$pr$ # jump if not predicate value
blequ cgv02
movl sp,r8 # else force non-constant case
#
# HERE WITH WC SET APPROPRIATELY
#
cgv02: casel r9,$0,$c$$nv # switch to appropriate generator
5:
.word cgv03-5b # array reference
.word cgv05-5b # function call
.word cgv14-5b # deferred expression
.word cgv31-5b # indirect reference
.word cgv27-5b # keyword reference
.word cgv29-5b # undefined binop
.word cgv30-5b # undefined unop
.word cgv18-5b # binops with val opds
.word cgv19-5b # unops with valu opnd
.word cgv18-5b # alternation
.word cgv24-5b # concatenation
.word cgv24-5b # concatenation (not pattern match)
.word cgv27-5b # unops with name opnd
.word cgv26-5b # binary $ and .
.word cgv21-5b # assignment
.word cgv31-5b # interrogation
.word cgv28-5b # negation
.word cgv15-5b # selection
.word cgv18-5b # pattern match
#esw # end switch on cmblk type
#page
#
# CDGVL (CONTINUED)
#
# HERE TO GENERATE CODE FOR ARRAY REFERENCE
#
cgv03: movl $4*cmopn,r7 # set offset to array operand
#
# LOOP TO GENERATE CODE FOR ARRAY OPERAND AND SUBSCRIPTS
#
cgv04: jsb cmgen # gen value code for next operand
movl 4*cmlen(r10),r8 # load cmblk length
cmpl r7,r8 # loop back if more to go
blssu cgv04
#
# GENERATE CALL TO APPROPRIATE ARRAY REFERENCE ROUTINE
#
movl $oaov$,r6 # set one subscript call in case
cmpl r8,$4*cmar1 # jump to exit if 1-sub case
bnequ 0f
jmp cgv32
0:
movl $oamv$,r6 # else set call for multi-subscripts
jsb cdwrd # generate call
movl r8,r6 # copy length of cmblk
subl2 $4*cmvls,r6 # subtract standard length
ashl $-2,r6,r6 # get number of words
jmp cgv32 # jump to generate subscript count
#
# HERE TO GENERATE CODE FOR FUNCTION CALL
#
cgv05: movl $4*cmvls,r7 # set offset to first argument
#
# LOOP TO GENERATE CODE FOR ARGUMENTS
#
cgv06: cmpl r7,4*cmlen(r10) # jump if all generated
beqlu cgv07
jsb cmgen # else gen value code for next arg
jmp cgv06 # back to generate next argument
#
# HERE TO GENERATE ACTUAL FUNCTION CALL
#
cgv07: subl2 $4*cmvls,r7 # get number of arg ptrs (bytes)
ashl $-2,r7,r7 # convert bytes to words
movl 4*cmopn(r10),r9 # load function vrblk pointer
tstl 4*vrlen(r9) # jump if not system function
bnequ cgv12
movl 4*vrsvp(r9),r10 # load svblk ptr if system var
movl 4*svbit(r10),r6 # load bit mask
mcoml btffc,r11 # test for fast function call allowed
bicl2 r11,r6
beqlu cgv12 # jump if not
#page
#
# CDGVL (CONTINUED)
#
# HERE IF FAST FUNCTION CALL IS ALLOWED
#
movl 4*svbit(r10),r6 # reload bit indicators
mcoml btpre,r11 # test for preevaluation ok
bicl2 r11,r6
bnequ cgv08 # jump if preevaluation permitted
movl sp,r8 # else set result non-constant
#
# TEST FOR CORRECT NUMBER OF ARGS FOR FAST CALL
#
cgv08: movl 4*vrfnc(r9),r10 # load ptr to svfnc field
movl 4*fargs(r10),r6 # load svnar field value
cmpl r6,r7 # jump if argument count is correct
beqlu cgv11
cmpl r6,r7 # jump if too few arguments given
bgequ cgv09
#
# HERE IF TOO MANY ARGUMENTS, PREPARE TO GENERATE O$POPS
#
subl2 r6,r7 # get number of extra args
# set as count to control loop
movl $opop$,r6 # set pop call
jmp cgv10 # jump to common loop
#
# HERE IF TOO FEW ARGUMENTS, PREPARE TO GENERATE NULLS
#
cgv09: subl2 r7,r6 # get number of missing arguments
movl r6,r7 # load as count to control loop
movl $nulls,r6 # load ptr to null constant
#
# LOOP TO GENERATE CALLS TO FIX ARGUMENT COUNT
#
cgv10: jsb cdwrd # generate one call
sobgtr r7,cgv10 # loop till all generated
#
# HERE AFTER ADJUSTING ARG COUNT AS REQUIRED
#
cgv11: movl r10,r6 # copy pointer to svfnc field
jmp cgv36 # jump to generate call
#page
#
# CDGVL (CONTINUED)
#
# COME HERE IF FAST CALL IS NOT PERMITTED
#
cgv12: movl $ofns$,r6 # set one arg call in case
cmpl r7,$num01 # jump if one arg case
beqlu cgv13
movl $ofnc$,r6 # else load call for more than 1 arg
jsb cdwrd # generate it
movl r7,r6 # copy argument count
#
# ONE ARG CASE MERGES HERE
#
cgv13: jsb cdwrd # generate =o$fns or arg count
movl r9,r6 # copy vrblk pointer
jmp cgv32 # jump to generate vrblk ptr
#
# HERE FOR DEFERRED EXPRESSION
#
cgv14: movl 4*cmrop(r10),r10# point to expression tree
jsb cdgex # build exblk or seblk
movl r9,r6 # copy block ptr
jsb cdwrd # generate ptr to exblk or seblk
jmp cgv34 # jump to exit, constant test
#
# HERE TO GENERATE CODE FOR SELECTION
#
cgv15: clrl -(sp) # zero ptr to chain of forward jumps
clrl -(sp) # zero ptr to prev o$slc forward ptr
movl $4*cmvls,r7 # point to first alternative
movl $osla$,r6 # 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: jsb cdwrd # generate o$slc (o$sla first time)
movl cwcof,(sp) # set current loc as ptr to fill in
jsb cdwrd # generate garbage word there for now
jsb cmgen # gen value code for alternative
movl $oslb$,r6 # load o$slb pointer
jsb cdwrd # generate o$slb call
movl 4*1(sp),r6 # load old chain ptr
movl cwcof,4*1(sp) # set current loc as new chain head
jsb cdwrd # generate forward chain link
#page
#
# CDGVL (CONTINUED)
#
# NOW TO FILL IN THE SKIP OFFSET TO O$SLC,O$SLD
#
movl (sp),r9 # load offset to word to plug
addl2 r$ccb,r9 # point to actual location to plug
movl cwcof,(r9) # plug proper offset in
movl $oslc$,r6 # load o$slc ptr for next alternative
movl r7,r9 # copy offset (destroy garbage xr)
addl2 $4,r9 # bump extra time for test
cmpl r9,4*cmlen(r10) # loop back if not last alternative
blssu cgv16
#
# HERE TO GENERATE CODE FOR LAST ALTERNATIVE
#
movl $osld$,r6 # get header call
jsb cdwrd # generate o$sld call
jsb cmgen # generate code for last alternative
addl2 $4,sp # pop offset ptr
movl (sp)+,r9 # load chain ptr
#
# LOOP TO PLUG OFFSETS PAST STRUCTURE
#
cgv17: addl2 r$ccb,r9 # make next ptr absolute
movl (r9),r6 # load forward ptr
movl cwcof,(r9) # plug required offset
movl r6,r9 # copy forward ptr
tstl r6 # loop back if more to go
bnequ cgv17
jmp cgv33 # else jump to exit (not constant)
#
# HERE FOR BINARY OPS WITH VALUE OPERANDS
#
cgv18: movl 4*cmlop(r10),r9 # load left operand pointer
jsb cdgvl # gen value code for left operand
#
# HERE FOR UNARY OPS WITH VALUE OPERAND (BINOPS MERGE)
#
cgv19: movl 4*cmrop(r10),r9 # load right (only) operand ptr
jsb cdgvl # gen code by value
#page
#
# CDGVL (CONTINUED)
#
# MERGE HERE TO GENERATE OPERATOR CALL FROM CMOPN FIELD
#
cgv20: movl 4*cmopn(r10),r6 # load operator call pointer
jmp cgv36 # jump to generate it with cons test
#
# HERE FOR ASSIGNMENT
#
cgv21: movl 4*cmlop(r10),r9 # load left operand pointer
cmpl (r9),$b$vr$ # jump if not variable
blequ cgv22
#
# HERE FOR ASSIGNMENT TO SIMPLE VARIABLE
#
movl 4*cmrop(r10),r9 # load right operand ptr
jsb cdgvl # generate code by value
movl 4*cmlop(r10),r6 # reload left operand vrblk ptr
addl2 $4*vrsto,r6 # point to vrsto field
jmp cgv32 # jump to generate store ptr
#
# HERE IF NOT SIMPLE VARIABLE ASSIGNMENT
#
cgv22: jsb expap # test for pattern match on left side
.long cgv23 # jump if not pattern match
#
# HERE FOR PATTERN REPLACEMENT
#
movl 4*cmrop(r9),4*cmlop(r10) # save pattern ptr in safe place
movl 4*cmlop(r9),r9 # load subject ptr
jsb cdgnm # gen code by name for subject
movl 4*cmlop(r10),r9 # load pattern ptr
jsb cdgvl # gen code by value for pattern
movl $opmn$,r6 # load match by name call
jsb cdwrd # generate it
movl 4*cmrop(r10),r9 # load replacement value ptr
jsb cdgvl # gen code by value
movl $orpl$,r6 # load replace call
jmp cgv32 # jump to gen and exit (not constant)
#
# HERE FOR ASSIGNMENT TO COMPLEX VARIABLE
#
cgv23: movl sp,r8 # inhibit pre-evaluation
jsb cdgnm # gen code by name for left side
jmp cgv31 # merge with unop circuit
#page
#
# CDGVL (CONTINUED)
#
# HERE FOR CONCATENATION
#
cgv24: movl 4*cmlop(r10),r9 # load left operand ptr
cmpl (r9),$b$cmt # ordinary binop if not cmblk
beqlu 0f
jmp cgv18
0:
movl 4*cmtyp(r9),r7 # load cmblk type code
cmpl r7,$c$int # special case if interrogation
beqlu cgv25
cmpl r7,$c$neg # or negation
beqlu cgv25
cmpl r7,$c$fnc # else ordinary binop if not function
beqlu 0f
jmp cgv18
0:
movl 4*cmopn(r9),r9 # else load function vrblk ptr
tstl 4*vrlen(r9) # ordinary binop if not system var
beqlu 0f
jmp cgv18
0:
movl 4*vrsvp(r9),r9 # else point to svblk
movl 4*svbit(r9),r6 # load bit indicators
mcoml btprd,r11 # test for predicate function
bicl2 r11,r6
bnequ 0f # ordinary binop if not
jmp cgv18
0:
#
# HERE IF LEFT ARG OF CONCATENATION IS PREDICATE FUNCTION
#
cgv25: movl 4*cmlop(r10),r9 # reload left arg
jsb cdgvl # gen code by value
movl $opop$,r6 # load pop call
jsb cdwrd # generate it
movl 4*cmrop(r10),r9 # load right operand
jsb cdgvl # gen code by value as result code
jmp cgv33 # exit (not constant)
#
# HERE TO GENERATE CODE FOR PATTERN, IMMEDIATE ASSIGNMENT
#
cgv26: movl 4*cmlop(r10),r9 # load left operand
jsb cdgvl # gen code by value, merge
#
# HERE FOR UNOPS WITH ARG BY NAME (BINARY $ . MERGE)
#
cgv27: movl 4*cmrop(r10),r9 # load right operand ptr
jsb cdgnm # gen code by name for right arg
movl 4*cmopn(r10),r9 # get operator code word
cmpl (r9),$o$kwv # gen call unless keyword value
beqlu 0f
jmp cgv20
0:
#page
#
# 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
#
tstl r8 # gen call if non-constant (not var)
beqlu 0f
jmp cgv20
0:
movl sp,r8 # else set non-constant in case
movl 4*cmrop(r10),r9 # load ptr to operand vrblk
tstl 4*vrlen(r9) # gen (non-constant) if not sys var
beqlu 0f
jmp cgv20
0:
movl 4*vrsvp(r9),r9 # else load ptr to svblk
movl 4*svbit(r9),r6 # load bit mask
mcoml btckw,r11 # test for constant keyword
bicl2 r11,r6
bnequ 0f # go gen if not constant
jmp cgv20
0:
clrl r8 # else set result constant
jmp cgv20 # and jump back to generate call
#
# HERE TO GENERATE CODE FOR NEGATION
#
cgv28: movl $onta$,r6 # get initial word
jsb cdwrd # generate it
movl cwcof,r7 # save next offset
jsb cdwrd # generate gunk word for now
movl 4*cmrop(r10),r9 # load right operand ptr
jsb cdgvl # gen code by value
movl $ontb$,r6 # load end of evaluation call
jsb cdwrd # generate it
movl r7,r9 # copy offset to word to plug
addl2 r$ccb,r9 # point to actual word to plug
movl cwcof,(r9) # plug word with current offset
movl $ontc$,r6 # load final call
jmp cgv32 # jump to generate it (not constant)
#
# HERE TO GENERATE CODE FOR UNDEFINED BINARY OPERATOR
#
cgv29: movl 4*cmlop(r10),r9 # load left operand ptr
jsb cdgvl # generate code by value
#page
#
# CDGVL (CONTINUED)
#
# HERE TO GENERATE CODE FOR UNDEFINED UNARY OPERATOR
#
cgv30: movl $c$uo$,r7 # set unop code + 1
subl2 4*cmtyp(r10),r7 # set number of args (1 or 2)
#
# MERGE HERE FOR UNDEFINED OPERATORS
#
movl 4*cmrop(r10),r9 # load right (only) operand pointer
jsb cdgvl # gen value code for right operand
movl 4*cmopn(r10),r9 # load pointer to operator dv
movl 4*dvopn(r9),r9 # load pointer offset
moval 0[r9],r9 # convert word offset to bytes
addl2 $r$uba,r9 # point to proper function ptr
subl2 $4*vrfnc,r9 # set standard function offset
jmp cgv12 # merge with function call circuit
#
# HERE TO GENERATE CODE FOR INTERROGATION, INDIRECTION
#
cgv31: movl sp,r8 # set non constant
jmp cgv19 # merge
#
# HERE TO EXIT GENERATING A WORD, RESULT NOT CONSTANT
#
cgv32: jsb cdwrd # generate word, merge
#
# HERE TO EXIT WITH NO WORD GENERATED, NOT CONSTANT
#
cgv33: movl sp,r8 # indicate result is not constant
#
# COMMON EXIT POINT
#
cgv34: addl2 $4,sp # pop initial code offset
movl (sp)+,r6 # restore old constant flag
movl (sp)+,r10 # restore entry xl
movl (sp)+,r7 # restore entry wb
tstl r8 # jump if not constant
bnequ cgv35
movl r6,r8 # else restore entry constant flag
#
# HERE TO RETURN AFTER DEALING WITH WC SETTING
#
cgv35: rsb # return to cdgvl caller
#
# EXIT HERE TO GENERATE WORD AND TEST FOR CONSTANT
#
cgv36: jsb cdwrd # generate word
tstl r8 # jump to exit if not constant
bnequ cgv34
#page
#
# CDGVL (CONTINUED)
#
# HERE TO PREEVALUATE CONSTANT SUB-EXPRESSION
#
movl $orvl$,r6 # load call to return value
jsb cdwrd # generate it
movl (sp),r10 # load initial code offset
jsb exbld # build exblk for expression
clrl r7 # set to evaluate by value
jsb evalx # evaluate expression
.long invalid$ # should not fail
movl (r9),r6 # load type word of result
cmpl r6,$p$aaa # jump if not pattern
blequ cgv37
movl $olpt$,r6 # else load special pattern load call
jsb cdwrd # generate it
#
# MERGE HERE TO GENERATE POINTER TO RESULTING CONSTANT
#
cgv37: movl r9,r6 # copy constant pointer
jsb cdwrd # generate ptr
clrl r8 # set result constant
jmp cgv34 # jump back to exit
#enp # end procedure cdgvl
#page
#
# 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 # entry point
movl r9,-(sp) # save entry xr
movl r6,-(sp) # save code word to be generated
#
# MERGE BACK HERE AFTER ALLOCATING LARGER BLOCK
#
cdwd1: movl r$ccb,r9 # load ptr to ccblk being built
bnequ cdwd2 # jump if block allocated
#
# HERE WE ALLOCATE AN ENTIRELY FRESH BLOCK
#
movl $4*e$cbs,r6 # load initial length
jsb alloc # allocate ccblk
movl $b$cct,(r9) # store type word
movl $4*cccod,cwcof # set initial offset
movl r6,4*cclen(r9) # store block length
movl r9,r$ccb # store ptr to new block
#
# HERE WE HAVE A BLOCK WE CAN USE
#
cdwd2: movl cwcof,r6 # load current offset
addl2 $4*num04,r6 # adjust for test (four words)
cmpl r6,4*cclen(r9) # jump if room in this block
bgtru 0f
jmp cdwd4
0:
#
# HERE IF NO ROOM IN CURRENT BLOCK
#
cmpl r6,mxlen # jump if already at max size
blssu 0f
jmp cdwd5
0:
addl2 $4*e$cbs,r6 # else get new size
movl r10,-(sp) # save entry xl
movl r9,r10 # copy pointer
cmpl r6,mxlen # jump if not too large
blssu cdwd3
movl mxlen,r6 # else reset to max allowed size
#page
#
# CDWRD (CONTINUED)
#
# HERE WITH NEW BLOCK SIZE IN WA
#
cdwd3: jsb alloc # allocate new block
movl r9,r$ccb # store pointer to new block
movl $b$cct,(r9)+ # store type word in new block
movl r6,(r9)+ # store block length
addl2 $4*ccuse,r10 # point to ccuse,cccod fields in old
movl (r10),r6 # load ccuse value
jsb sbmvw # copy useful words from old block
movl (sp)+,r10 # restore xl
jmp cdwd1 # merge back to try again
#
# HERE WITH ROOM IN CURRENT BLOCK
#
cdwd4: movl cwcof,r6 # load current offset
addl2 $4,r6 # get new offset
movl r6,cwcof # store new offset
movl r6,4*ccuse(r9) # store in ccblk for gbcol
subl2 $4,r6 # restore ptr to this word
addl2 r6,r9 # point to current entry
movl (sp)+,r6 # reload word to generate
movl r6,(r9) # store word in block
movl (sp)+,r9 # restore entry xr
rsb # return to caller
#
# HERE IF COMPILED CODE IS TOO LONG FOR CDBLK
#
cdwd5: jmp er_213 # syntax error. statement is too complicated.
#enp # end procedure cdwrd
#page
#
# 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 # entry point, recursive
movl r10,r9 # copy cmblk pointer
addl2 r7,r9 # point to cmblk pointer
movl (r9),r9 # load cmblk pointer
jsb cdgvl # generate code by value
addl2 $4,r7 # bump offset
rsb # return to caller
#enp # end procedure cmgen
#page
#
# 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
#page
#
# 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.
#page
#
# CMPIL (CONTINUED)
#
# ENTRY POINT
#
cmpil: #prc # entry point
movl $cmnen,r7 # set number of stack work locations
#
# LOOP TO INITIALIZE STACK WORKING LOCATIONS
#
cmp00: clrl -(sp) # store a zero, make one entry
sobgtr r7,cmp00 # loop back until all set
movl sp,cmpxs # save stack pointer for error sec
#sss cmpss # save s-r stack pointer if any
#
# LOOP THROUGH STATEMENTS
#
cmp01: movl scnpt,r7 # set scan pointer offset
movl r7,scnse # set start of element location
movl $ocer$,r6 # point to compile error call
jsb cdwrd # generate as temporary cdfal
cmpl r7,scnil # jump if chars left on this image
blssu cmp04
#
# LOOP HERE AFTER COMMENT OR CONTROL CARD
# ALSO SPECIAL ENTRY AFTER CONTROL CARD ERROR
#
cmpce: clrl r9 # clear possible garbage xr value
cmpl stage,$stgic # skip unless initial compile
bnequ cmp02
jsb readr # read next input image
tstl r9 # jump if no input available
bnequ 0f
jmp cmp09
0:
jsb nexts # acquire next source image
movl cmpsn,lstsn # store stmt no for use by listr
clrl scnpt # reset scan pointer
jmp cmp04 # go process image
#
# FOR EXECUTE TIME COMPILE, PERMIT EMBEDDED CONTROL CARDS
# AND COMMENTS (BY SKIPPING TO NEXT SEMI-COLON)
#
cmp02: movl r$cim,r9 # get current image
movl scnpt,r7 # get current offset
movab cfp$f(r9)[r7],r9# prepare to get chars
#
# SKIP TO SEMI-COLON
#
cmp03: movzbl (r9)+,r8 # get char
incl scnpt # advance offset
cmpl r8,$ch$sm # skip if semi-colon found
beqlu cmp04
cmpl scnpt,scnil # loop if more chars
blssu cmp03
clrl r9 # clear garbage xr value
jmp cmp09 # end of image
#page
#
# 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: movl r$cim,r9 # point to current image
movl scnpt,r7 # load current offset
movl r7,r6 # copy for label scan
movab cfp$f(r9)[r7],r9# point to first character
movzbl (r9)+,r8 # load first character
cmpl r8,$ch$sm # no label if semicolon
bnequ 0f
jmp cmp12
0:
cmpl r8,$ch$as # loop back if comment card
bnequ 0f
jmp cmpce
0:
cmpl r8,$ch$mn # jump if control card
bnequ 0f
jmp cmp32
0:
movl r$cim,r$cmp # about to destroy r$cim
movl $cmlab,r10 # point to label work string
movl r10,r$cim # scane is to scan work string
movab cfp$f(r10),r10 # point to first character position
movb r8,(r10)+ # store char just loaded
movl $ch$sm,r8 # get a semicolon
movb r8,(r10) # store after first char
#csc r10 # finished character storing
clrl r10 # clear pointer
clrl scnpt # start at first character
movl scnil,-(sp) # preserve image length
movl $num02,scnil # read 2 chars at most
jsb scane # scan first char for type
movl (sp)+,scnil # restore image length
movl r10,r8 # note return code
movl r$cmp,r10 # get old r$cim
movl r10,r$cim # put it back
movl r7,scnpt # reinstate offset
tstl scnbl # blank seen - cant be label
beqlu 0f
jmp cmp12
0:
movl r10,r9 # point to current image
movab cfp$f(r9)[r7],r9# point to first char again
cmpl r8,$t$var # ok if letter
beqlu cmp06
cmpl r8,$t$con # ok if digit
beqlu cmp06
#
# DROP IN OR JUMP FROM ERROR SECTION IF SCANE FAILED
#
cmple: movl r$cmp,r$cim # point to bad line
jmp er_214 # bad label or misplaced continuation line
#
# LOOP TO SCAN LABEL
#
cmp05: cmpl r8,$ch$sm # skip if semicolon
beqlu cmp07
incl r6 # bump offset
cmpl r6,scnil # jump if end of image (label end)
beqlu cmp07
#page
#
# CMPIL (CONTINUED)
#
# ENTER LOOP AT THIS POINT
#
cmp06: movzbl (r9)+,r8 # else load next character
cmpl r8,$ch$ht # jump if horizontal tab
beqlu cmp07
cmpl r8,$ch$bl # loop back if non-blank
bnequ cmp05
#
# HERE AFTER SCANNING OUT LABEL
#
cmp07: movl r6,scnpt # save updated scan offset
subl2 r7,r6 # get length of label
bnequ 0f # skip if label length zero
jmp cmp12
0:
clrl r9 # clear garbage xr value
jsb sbstr # build scblk for label name
jsb gtnvr # locate/contruct vrblk
.long invalid$ # dummy (impossible) error return
movl r9,4*cmlbl(sp) # store label pointer
tstl 4*vrlen(r9) # jump if not system label
bnequ cmp11
cmpl 4*vrsvp(r9),$v$end # jump if not end label
bnequ cmp11
#
# HERE FOR END LABEL SCANNED OUT
#
addl2 $stgnd,stage # adjust stage appropriately
jsb scane # scan out next element
cmpl r10,$t$smc # jump if end of image
bnequ 0f
jmp cmp10
0:
cmpl r10,$t$var # else error if not variable
bnequ cmp08
#
# HERE CHECK FOR VALID INITIAL TRANSFER
#
cmpl 4*vrlbl(r9),$stndl # jump if not defined (error)
beqlu cmp08
movl 4*vrlbl(r9),4*cmtra(sp) # else set initial entry pointer
jsb scane # scan next element
cmpl r10,$t$smc # jump if ok (end of image)
bnequ 0f
jmp cmp10
0:
#
# HERE FOR BAD TRANSFER LABEL
#
cmp08: jmp er_215 # syntax error. undefined or erroneous entry label
#
# HERE FOR END OF INPUT (NO END LABEL DETECTED)
#
cmp09: addl2 $stgnd,stage # adjust stage appropriately
cmpl stage,$stgxe # jump if code call (ok)
bnequ 0f
jmp cmp10
0:
jmp er_216 # syntax error. missing end line
#
# HERE AFTER PROCESSING END LINE (MERGE HERE ON END ERROR)
#
cmp10: movl $ostp$,r6 # set stop call pointer
jsb cdwrd # generate as statement call
jmp cmpse # jump to generate as failure
#page
#
# CMPIL (CONTINUED)
#
# HERE AFTER PROCESSING LABEL OTHER THAN END
#
cmp11: cmpl stage,$stgic # jump if code call - redef. ok
beqlu 0f
jmp cmp12
0:
cmpl 4*vrlbl(r9),$stndl # else check for redefinition
bnequ 0f
jmp cmp12
0:
clrl 4*cmlbl(sp) # leave first label decln undisturbed
jmp er_217 # syntax error. duplicate label
#
# HERE AFTER DEALING WITH LABEL
#
cmp12: clrl r7 # set flag for statement body
jsb expan # get tree for statement body
movl r9,4*cmstm(sp) # store for later use
clrl 4*cmsgo(sp) # clear success goto pointer
clrl 4*cmfgo(sp) # clear failure goto pointer
clrl 4*cmcgo(sp) # clear conditional goto flag
jsb scane # scan next element
cmpl r10,$t$col # jump it not colon (no goto)
beqlu 0f
jmp cmp18
0:
#
# LOOP TO PROCESS GOTO FIELDS
#
cmp13: movl sp,scngo # set goto flag
jsb scane # scan next element
cmpl r10,$t$smc # jump if no fields left
bnequ 0f
jmp cmp31
0:
cmpl r10,$t$sgo # jump if s for success goto
beqlu cmp14
cmpl r10,$t$fgo # jump if f for failure goto
beqlu cmp16
#
# HERE FOR UNCONDITIONAL GOTO (I.E. NOT F OR S)
#
movl sp,scnrs # set to rescan element not f,s
jsb scngf # scan out goto field
tstl 4*cmfgo(sp) # error if fgoto already
bnequ cmp17
movl r9,4*cmfgo(sp) # else set as fgoto
jmp cmp15 # merge with sgoto circuit
#
# HERE FOR SUCCESS GOTO
#
cmp14: jsb scngf # scan success goto field
movl $num01,4*cmcgo(sp) # set conditional goto flag
#
# UNCONTIONAL GOTO MERGES HERE
#
cmp15: tstl 4*cmsgo(sp) # error if sgoto already given
bnequ cmp17
movl r9,4*cmsgo(sp) # else set sgoto
jmp cmp13 # loop back for next goto field
#
# HERE FOR FAILURE GOTO
#
cmp16: jsb scngf # scan goto field
movl $num01,4*cmcgo(sp) # set conditonal goto flag
tstl 4*cmfgo(sp) # error if fgoto already given
bnequ cmp17
movl r9,4*cmfgo(sp) # else store fgoto pointer
jmp cmp13 # loop back for next field
#page
#
# CMPIL (CONTINUED)
#
# HERE FOR DUPLICATED GOTO FIELD
#
cmp17: jmp er_218 # syntax error. duplicated goto field
#
# HERE TO GENERATE CODE
#
cmp18: clrl scnse # stop positional error flags
movl 4*cmstm(sp),r9 # load tree ptr for statement body
clrl r7 # collectable value for wb for cdgvl
clrl r8 # reset constant flag for cdgvl
jsb expap # test for pattern match
.long cmp19 # jump if not pattern match
movl $opms$,4*cmopn(r9) # else set pattern match pointer
movl $c$pmt,4*cmtyp(r9)
#
# HERE AFTER DEALING WITH SPECIAL PATTERN MATCH CASE
#
cmp19: jsb cdgvl # generate code for body of statement
movl 4*cmsgo(sp),r9 # load sgoto pointer
movl r9,r6 # copy it
tstl r9 # jump if no success goto
beqlu cmp21
clrl 4*cmsoc(sp) # clear success offset fillin ptr
cmpl r9,state # jump if complex goto
bgequ cmp20
#
# HERE FOR SIMPLE SUCCESS GOTO (LABEL)
#
addl2 $4*vrtra,r6 # point to vrtra field as required
jsb cdwrd # generate success goto
jmp cmp22 # jump to deal with fgoto
#
# HERE FOR COMPLEX SUCCESS GOTO
#
cmp20: cmpl r9,4*cmfgo(sp) # no code if same as fgoto
beqlu cmp22
clrl r7 # else set ok value for cdgvl in wb
jsb cdgcg # generate code for success goto
jmp cmp22 # jump to deal with fgoto
#
# HERE FOR NO SUCCESS GOTO
#
cmp21: movl cwcof,4*cmsoc(sp)# set success fill in offset
movl $ocer$,r6 # point to compile error call
jsb cdwrd # generate as temporary value
#page
#
# CMPIL (CONTINUED)
#
# HERE TO DEAL WITH FAILURE GOTO
#
cmp22: movl 4*cmfgo(sp),r9 # load failure goto pointer
movl r9,r6 # copy it
clrl 4*cmffc(sp) # set no fill in required yet
tstl r9 # jump if no failure goto given
beqlu cmp23
addl2 $4*vrtra,r6 # point to vrtra field in case
cmpl r9,state # jump to gen if simple fgoto
blequ cmpse
#
# HERE FOR COMPLEX FAILURE GOTO
#
movl cwcof,r7 # save offset to o$gof call
movl $ogof$,r6 # point to failure goto call
jsb cdwrd # generate
movl $ofif$,r6 # point to fail in fail word
jsb cdwrd # generate
jsb cdgcg # generate code for failure goto
movl r7,r6 # copy offset to o$gof for cdfal
movl $b$cdc,r7 # set complex case cdtyp
jmp cmp25 # jump to build cdblk
#
# HERE IF NO FAILURE GOTO GIVEN
#
cmp23: movl $ounf$,r6 # load unexpected failure call in cas
movl cswfl,r8 # get -nofail flag
bisl2 4*cmcgo(sp),r8 # check if conditional goto
beqlu cmpse # jump if -nofail and no cond. goto
movl sp,4*cmffc(sp) # else set fill in flag
movl $ocer$,r6 # and set compile error for temporary
#
# MERGE HERE WITH CDFAL VALUE IN WA, SIMPLE CDBLK
# ALSO SPECIAL ENTRY AFTER STATEMENT ERROR
#
cmpse: movl $b$cds,r7 # set cdtyp for simple case
#page
#
# 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: movl r$ccb,r9 # point to ccblk
movl 4*cmlbl(sp),r10 # get possible label pointer
beqlu cmp26 # skip if no label
clrl 4*cmlbl(sp) # clear flag for next statement
movl r9,4*vrlbl(r10) # put cdblk ptr in vrblk label field
#
# MERGE AFTER DOING LABEL
#
cmp26: movl r7,(r9) # set type word for new cdblk
movl r6,4*cdfal(r9) # set failure word
movl r9,r10 # copy pointer to ccblk
movl 4*ccuse(r9),r7 # load length gen (= new cdlen)
movl 4*cclen(r9),r8 # load total ccblk length
addl2 r7,r10 # point past cdblk
subl2 r7,r8 # get length left for chop off
movl $b$cct,(r10) # set type code for new ccblk at end
movl $4*cccod,4*ccuse(r10) # set initial code offset
movl $4*cccod,cwcof # reinitialise cwcof
movl r8,4*cclen(r10) # set new length
movl r10,r$ccb # set new ccblk pointer
movl cmpsn,4*cdstm(r9)# set statement number
incl cmpsn # bump statement number
#
# SET POINTERS IN PREVIOUS CODE BLOCK AS REQUIRED
#
movl 4*cmpcd(sp),r10 # load ptr to previous cdblk
tstl 4*cmffp(sp) # jump if no failure fill in required
beqlu cmp27
movl r9,4*cdfal(r10) # else set failure ptr in previous
#
# HERE TO DEAL WITH SUCCESS FORWARD POINTER
#
cmp27: movl 4*cmsop(sp),r6 # load success offset
beqlu cmp28 # jump if no fill in required
addl2 r6,r10 # else point to fill in location
movl r9,(r10) # store forward pointer
clrl r10 # clear garbage xl value
#page
#
# CMPIL (CONTINUED)
#
# NOW SET FILL IN POINTERS FOR THIS STATEMENT
#
cmp28: movl 4*cmffc(sp),4*cmffp(sp) # copy failure fill in flag
movl 4*cmsoc(sp),4*cmsop(sp) # copy success fill in offset
movl r9,4*cmpcd(sp) # save ptr to this cdblk
tstl 4*cmtra(sp) # jump if initial entry already set
bnequ cmp29
movl r9,4*cmtra(sp) # else set ptr here as default
#
# HERE AFTER COMPILING ONE STATEMENT
#
cmp29: cmpl stage,$stgce # jump if not end line just done
bgequ 0f
jmp cmp01
0:
tstl cswls # skip if -nolist
beqlu cmp30
jsb listr # list last line
#
# RETURN
#
cmp30: movl 4*cmtra(sp),r9 # load initial entry cdblk pointer
addl2 $4*cmnen,sp # pop work locations off stack
rsb # and return to cmpil caller
#
# HERE AT END OF GOTO FIELD
#
cmp31: movl 4*cmfgo(sp),r7 # get fail goto
bisl2 4*cmsgo(sp),r7 # or in success goto
beqlu 0f # ok if non-null field
jmp cmp18
0:
jmp er_219 # syntax error. empty goto field
#
# CONTROL CARD FOUND
#
cmp32: incl r7 # point past ch$mn
jsb cncrd # process control card
clrl scnse # clear start of element loc.
jmp cmpce # loop for next statement
#enp # end procedure cmpil
#page
#
# 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 # entry point
movl r7,scnpt # offset for control card scan
movl $ccnoc,r6 # number of chars for comparison
movab 3+(4*0)(r6),r6 # convert to word count
ashl $-2,r6,r6
movl r6,cnswc # save word count
#
# LOOP HERE IF MORE THAN ONE CONTROL CARD
#
cnc01: cmpl scnpt,scnil # return if end of image
blssu 0f
jmp cnc09
0:
movl r$cim,r9 # point to image
movl scnpt,r11 # [get in scratch register]
movab cfp$f(r9)[r11],r9# char ptr for first char
movzbl (r9)+,r6 # get first char
bicl2 $ch$bl,r6 # fold to upper case
cmpl r6,$ch$li # special case of -inxxx
bnequ 0f
jmp cnc07
0:
movl sp,scncc # set flag for scane
jsb scane # scan card name
clrl scncc # clear scane flag
tstl r10 # fail unless control card name
beqlu 0f
jmp cnc06
0:
movl $ccnoc,r6 # no. of chars to be compared
cmpl 4*sclen(r9),r6 # fail if too few chars
bgequ 0f
jmp cnc06
0:
movl r9,r10 # point to control card name
clrl r7 # zero offset for substring
jsb sbstr # extract substring for comparison
movl 4*sclen(r9),r6 # reload length
jsb flstg # fold to upper case
movl r9,cnscc # keep control card substring ptr
movl $ccnms,r9 # point to list of standard names
clrl r7 # initialise name offset
movl $cc$nc,r8 # number of standard names
#
# TRY TO MATCH NAME
#
cnc02: movl cnscc,r10 # point to name
movl cnswc,r6 # counter for inner loop
jmp cnc04 # jump into loop
#
# INNER LOOP TO MATCH CARD NAME CHARS
#
cnc03: addl2 $4,r9 # bump standard names ptr
addl2 $4,r10 # bump name pointer
#
# HERE TO INITIATE THE LOOP
#
cnc04: cmpl 4*schar(r10),(r9)# comp. up to cfp$c chars at once
bnequ cnc05
sobgtr r6,cnc03 # loop if more words to compare
#page
#
# CNCRD (CONTINUED)
#
# MATCHED - BRANCH ON CARD OFFSET
#
movl r7,r10 # get name offset
casel r10,$0,$cc$nc # switch
5:
.word cnc37-5b # -case
.word cnc10-5b # -double
.word cnc11-5b # -dump
.word cnc12-5b # -eject
.word cnc13-5b # -errors
.word cnc14-5b # -execute
.word cnc15-5b # -fail
.word cnc16-5b # -list
.word cnc17-5b # -noerrors
.word cnc18-5b # -noexecute
.word cnc19-5b # -nofail
.word cnc20-5b # -nolist
.word cnc21-5b # -noopt
.word cnc22-5b # -noprint
.word cnc24-5b # -optimise
.word cnc25-5b # -print
.word cnc27-5b # -single
.word cnc28-5b # -space
.word cnc31-5b # -stitle
.word cnc32-5b # -title
.word cnc36-5b # -trace
#esw # end switch
#
# NOT MATCHED YET. ALIGN STD NAMES PTR AND TRY AGAIN
#
cnc05: addl2 $4,r9 # bump standard names ptr
sobgtr r6,cnc05 # loop
incl r7 # bump names offset
sobgtr r8,cnc02 # continue if more names
#
# INVALID CONTROL CARD NAME
#
cnc06: jmp er_247 # invalid control card
#
# SPECIAL PROCESSING FOR -INXXX
#
cnc07: movzbl (r9),r6 # get next char
bicl2 $ch$bl,r6 # fold to upper case
cmpl r6,$ch$ln # fail if not letter n
beqlu 0f
jmp cnc06
0:
addl2 $num02,scnpt # bump offset past -in
jsb scane # scan integer after -in
movl r9,-(sp) # stack scanned item
jsb gtsmi # check if integer
.long cnc06 # fail if not integer
.long cnc06 # fail if negative or large
movl r9,cswin # keep integer
#page
#
# CNCRD (CONTINUED)
#
# CHECK FOR MORE CONTROL CARDS BEFORE RETURNING
#
cnc08: movl scnpt,r6 # preserve in case xeq time compile
jsb scane # look for comma
cmpl r10,$t$cma # loop if comma found
bnequ 0f
jmp cnc01
0:
movl r6,scnpt # restore scnpt in case xeq time
#
# RETURN POINT
#
cnc09: rsb # return
#
# -DOUBLE
#
cnc10: movl sp,cswdb # set switch
jmp cnc08 # merge
#
# -DUMP
# THIS IS USED FOR SYSTEM DEBUGGING . IT HAS THE EFFECT OF
# PRODUCING A CORE DUMP AT COMPILATION TIME
#
cnc11: jsb sysdm # call dumper
jmp cnc09 # finished
#
# -EJECT
#
cnc12: tstl cswls # return if -nolist
bnequ 0f
jmp cnc09
0:
jsb prtps # eject
jsb listt # list title
jmp cnc09 # finished
#
# -ERRORS
#
cnc13: clrl cswer # clear switch
jmp cnc08 # merge
#
# -EXECUTE
#
cnc14: clrl cswex # clear switch
jmp cnc08 # merge
#
# -FAIL
#
cnc15: movl sp,cswfl # set switch
jmp cnc08 # merge
#
# -LIST
#
cnc16: movl sp,cswls # set switch
cmpl stage,$stgic # done if compile time
beqlu cnc08
#
# LIST CODE LINE IF EXECUTE TIME COMPILE
#
clrl lstpf # permit listing
jsb listr # list line
jmp cnc08 # merge
#page
#
# CNCRD (CONTINUED)
#
# -NOERRORS
#
cnc17: movl sp,cswer # set switch
jmp cnc08 # merge
#
# -NOEXECUTE
#
cnc18: movl sp,cswex # set switch
jmp cnc08 # merge
#
# -NOFAIL
#
cnc19: clrl cswfl # clear switch
jmp cnc08 # merge
#
# -NOLIST
#
cnc20: clrl cswls # clear switch
jmp cnc08 # merge
#
# -NOOPTIMISE
#
cnc21: movl sp,cswno # set switch
jmp cnc08 # merge
#
# -NOPRINT
#
cnc22: clrl cswpr # clear switch
jmp cnc08 # merge
#
# -OPTIMISE
#
cnc24: clrl cswno # clear switch
jmp cnc08 # merge
#
# -PRINT
#
cnc25: movl sp,cswpr # set switch
jmp cnc08 # merge
#page
#
# CNCRD (CONTINUED)
#
# -SINGLE
#
cnc27: clrl cswdb # clear switch
jmp cnc08 # merge
#
# -SPACE
#
cnc28: tstl cswls # return if -nolist
bnequ 0f
jmp cnc09
0:
jsb scane # scan integer after -space
movl $num01,r8 # 1 space in case
cmpl r9,$t$smc # jump if no integer
beqlu cnc29
movl r9,-(sp) # stack it
jsb gtsmi # check integer
.long cnc06 # fail if not integer
.long cnc06 # fail if negative or large
tstl r8 # jump if non zero
bnequ cnc29
movl $num01,r8 # else 1 space
#
# MERGE WITH COUNT OF LINES TO SKIP
#
cnc29: addl2 r8,lstlc # bump line count
# convert to loop counter
cmpl lstlc,lstnp # jump if fits on page
blssu cnc30
jsb prtps # eject
jsb listt # list title
jmp cnc09 # merge
#
# SKIP LINES
#
cnc30: jsb prtnl # print a blank
sobgtr r8,cnc30 # loop
jmp cnc09 # merge
#page
#
# CNCRD (CONTINUED)
#
# -STITL
#
cnc31: movl $r$stl,cnr$t # ptr to r$stl
jmp cnc33 # merge
#
# -TITLE
#
cnc32: movl $nulls,r$stl # clear subtitle
movl $r$ttl,cnr$t # ptr to r$ttl
#
# COMMON PROCESSING FOR -TITLE, -STITL
#
cnc33: movl $nulls,r9 # null in case needed
movl sp,cnttl # set flag for next listr call
movl $ccofs,r7 # offset to title/subtitle
movl scnil,r6 # input image length
cmpl r6,r7 # jump if no chars left
blequ cnc34
subl2 r7,r6 # no of chars to extract
movl r$cim,r10 # point to image
jsb sbstr # get title/subtitle
#
# STORE TITLE/SUBTITLE
#
cnc34: movl cnr$t,r10 # point to storage location
movl r9,(r10) # store title/subtitle
cmpl r10,$r$stl # return if stitl
bnequ 0f
jmp cnc09
0:
tstl precl # return if extended listing
beqlu 0f
jmp cnc09
0:
tstl prich # return if regular printer
bnequ 0f
jmp cnc09
0:
movl 4*sclen(r9),r10 # get length of title
movl r10,r6 # copy it
tstl r10 # jump if null
beqlu cnc35
addl2 $num10,r10 # increment
cmpl r10,prlen # use default lstp0 val if too long
blssu 0f
jmp cnc09
0:
addl2 $num04,r6 # point just past title
#
# STORE OFFSET TO PAGE NN MESSAGE FOR SHORT TITLE
#
cnc35: movl r6,lstpo # store offset
jmp cnc09 # return
#
# -TRACE
# PROVIDED FOR SYSTEM DEBUGGING. TOGGLES THE SYSTEM LABEL
# TRACE SWITCH AT COMPILE TIME
#
cnc36: jsb systt # toggle switch
jmp cnc08 # merge
#
# -CASE
# SETS VALUE OF KVCAS SO THAT NAMES ARE FOLDED OR NOT
# DURING COMPILATION.
#
cnc37: jsb scane # scan integer after -case
clrl r8 # get 0 in case none there
cmpl r10,$t$smc # skip if no integer
beqlu cnc38
movl r9,-(sp) # stack it
jsb gtsmi # check integer
.long cnc06 # fail if not integer
.long cnc06 # fail if negative or too large
cnc38: movl r8,kvcas # store new case value
jmp cnc09 # merge
#enp # end procedure cncrd
#page
#
# 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 # entry point
cmpl (r10),$b$efc # skip if new function not external
bnequ dffn1
incl 4*efuse(r10) # else increment its use count
#
# HERE AFTER DEALING WITH NEW FUNCTION USE COUNT
#
dffn1: movl r9,r6 # save vrblk pointer
movl 4*vrfnc(r9),r9 # load old function pointer
cmpl (r9),$b$efc # jump if old function not external
bnequ dffn2
movl 4*efuse(r9),r7 # else get use count
decl r7 # decrement
movl r7,4*efuse(r9) # store decremented value
tstl r7 # jump if use count still non-zero
bnequ dffn2
jsb sysul # else call system unload function
#
# HERE AFTER DEALING WITH OLD FUNCTION USE COUNT
#
dffn2: movl r6,r9 # restore vrblk pointer
movl r10,r6 # copy function block ptr
cmpl r9,$r$yyy # skip checks if opsyn op definition
blssu dffn3
tstl 4*vrlen(r9) # jump if not system variable
bnequ dffn3
#
# FOR SYSTEM VARIABLE, CHECK FOR ILLEGAL REDEFINITION
#
movl 4*vrsvp(r9),r10 # point to svblk
movl 4*svbit(r10),r7 # load bit indicators
mcoml btfnc,r11 # is it a system function
bicl2 r11,r7
beqlu dffn3 # redef ok if not
jmp er_248 # attempted redefinition of system function
#
# HERE IF REDEFINITION IS PERMITTED
#
dffn3: movl r6,4*vrfnc(r9) # store new function pointer
movl r6,r10 # restore function block pointer
rsb # return to dffnc caller
#enp # end procedure dffnc
#page
#
# 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 # entry point
movl r10,dtcnb # store name base (gbcol not called)
addl2 r6,r10 # point to name location
movl r10,dtcnm # store it
#
# LOOP TO SEARCH FOR I/O TRBLK
#
dtch1: movl r10,r9 # copy name pointer
#
# CONTINUE AFTER BLOCK DELETION
#
dtch2: movl (r10),r10 # point to next value
cmpl (r10),$b$trt # jump at chain end
bnequ dtch6
movl 4*trtyp(r10),r6 # get trap block type
cmpl r6,$trtin # jump if input
beqlu dtch3
cmpl r6,$trtou # jump if output
beqlu dtch3
addl2 $4*trnxt,r10 # point to next link
jmp dtch1 # loop
#
# DELETE AN OLD ASSOCIATION
#
dtch3: movl 4*trval(r10),(r9)# delete trblk
movl r10,r6 # dump xl ...
movl r9,r7 # ... and xr
movl 4*trtrf(r10),r10# point to trtrf trap block
beqlu dtch5 # jump if no iochn
cmpl (r10),$b$trt # jump if input, output, terminal
bnequ dtch5
#
# LOOP TO SEARCH IOCHN CHAIN FOR NAME PTR
#
dtch4: movl r10,r9 # remember link ptr
movl 4*trtrf(r10),r10# point to next link
beqlu dtch5 # jump if end of chain
movl 4*ionmb(r10),r8 # get name base
addl2 4*ionmo(r10),r8 # add offset
cmpl r8,dtcnm # loop if no match
bnequ dtch4
movl 4*trtrf(r10),4*trtrf(r9) # remove name from chain
#page
#
# DTACH (CONTINUED)
#
# PREPARE TO RESUME I/O TRBLK SCAN
#
dtch5: movl r6,r10 # recover xl ...
movl r7,r9 # ... and xr
addl2 $4*trval,r10 # point to value field
jmp dtch2 # continue
#
# EXIT POINT
#
dtch6: movl dtcnb,r9 # possible vrblk ptr
jsb setvr # reset vrblk if necessary
rsb # return
#enp # end procedure dtach
#page
#
# DTYPE -- GET DATATYPE NAME
#
# (XR) OBJECT WHOSE DATATYPE IS REQUIRED
# JSR DTYPE CALL TO GET DATATYPE
# (XR) RESULT DATATYPE
#
dtype: #prc # entry point
cmpl (r9),$b$pdt # jump if prog.defined
beqlu dtyp1
movl (r9),r9 # load type word
movzwl -2(r9),r9 # get entry point id (block code)
moval 0[r9],r9 # convert to byte offset
movl l^scnmt(r9),r9 # load table entry
rsb # exit to dtype caller
#
# HERE IF PROGRAM DEFINED
#
dtyp1: movl 4*pddfp(r9),r9 # point to dfblk
movl 4*dfnam(r9),r9 # get datatype name from dfblk
rsb # return to dtype caller
#enp # end procedure dtype
#page
#
# 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 # entry point
tstl r9 # skip dump if argument is zero
bnequ 0f
jmp dmp28
0:
cmpl r9,$num02 # jump if core dump required
blequ 0f
jmp dmp29
0:
clrl r10 # clear xl
clrl r7 # zero move offset
movl r9,dmarg # save dump argument
jsb gbcol # collect garbage
jsb prtpg # eject printer
movl $dmhdv,r9 # point to heading for variables
jsb prtst # print it
jsb prtnl # terminate print line
jsb 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.
#
clrl dmvch # set null chain to start
movl hshtb,r6 # point to hash table
#
# LOOP THROUGH HEADERS IN HASH TABLE
#
dmp00: movl r6,r9 # copy hash bucket pointer
addl2 $4,r6 # bump pointer
subl2 $4*vrnxt,r9 # set offset to merge
#
# LOOP THROUGH VRBLKS ON ONE CHAIN
#
dmp01: movl 4*vrnxt(r9),r9 # point to next vrblk on chain
bnequ 0f # jump if end of this hash chain
jmp dmp09
0:
movl r9,r10 # else copy vrblk pointer
#page
#
# DUMPR (CONTINUED)
#
# LOOP TO FIND VALUE AND SKIP IF NULL
#
dmp02: movl 4*vrval(r10),r10# load value
cmpl r10,$nulls # loop for next vrblk if null value
beqlu dmp01
cmpl (r10),$b$trt # loop back if value is trapped
beqlu dmp02
#
# NON-NULL VALUE, PREPARE TO SEARCH CHAIN
#
movl r9,r8 # save vrblk pointer
addl2 $4*vrsof,r9 # adjust ptr to be like scblk ptr
tstl 4*sclen(r9) # jump if non-system variable
bnequ dmp03
movl 4*vrsvo(r9),r9 # else load ptr to name in svblk
#
# HERE WITH NAME POINTER FOR NEW BLOCK IN XR
#
dmp03: movl r9,r7 # save pointer to chars
movl r6,dmpsv # save hash bucket pointer
movl $dmvch,r6 # point to chain head
#
# LOOP TO SEARCH CHAIN FOR CORRECT INSERTION POINT
#
dmp04: movl r6,dmpch # save chain pointer
movl r6,r10 # copy it
movl (r10),r9 # load pointer to next entry
bnequ 0f # jump if end of chain to insert
jmp dmp08
0:
addl2 $4*vrsof,r9 # else get name ptr for chained vrblk
tstl 4*sclen(r9) # jump if not system variable
bnequ dmp05
movl 4*vrsvo(r9),r9 # 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: movl r7,r10 # point to entering vrblk string
movl 4*sclen(r10),r6 # load its length
movab cfp$f(r10),r10 # point to chars of entering string
cmpl r6,4*sclen(r9) # jump if entering length high
bgequ dmp06
movab cfp$f(r9),r9 # else point to chars of old string
jsb sbcmc # compare, insert if new is llt old
.long dmp08
.long dmp07
jmp dmp08 # or if leq (we had shorter length)
#
# HERE WHEN NEW LENGTH IS LONGER THAN OLD LENGTH
#
dmp06: movl 4*sclen(r9),r6 # load shorter length
movab cfp$f(r9),r9 # point to chars of old string
jsb sbcmc # compare, insert if new one low
.long dmp08
.long dmp07
#page
#
# DUMPR (CONTINUED)
#
# HERE WE MOVE OUT ON THE CHAIN
#
dmp07: movl dmpch,r10 # copy chain pointer
movl (r10),r6 # move to next entry on chain
jmp dmp04 # loop back
#
# HERE AFTER LOCATING THE PROPER INSERTION POINT
#
dmp08: movl dmpch,r10 # copy chain pointer
movl dmpsv,r6 # restore hash bucket pointer
movl r8,r9 # restore vrblk pointer
movl (r10),4*vrget(r9)# link vrblk to rest of chain
movl r9,(r10) # link vrblk into current chain loc
jmp dmp01 # loop back for next vrblk
#
# HERE AFTER PROCESSING ALL VRBLKS ON ONE CHAIN
#
dmp09: cmpl r6,hshte # loop back if more buckets to go
beqlu 0f
jmp dmp00
0:
#
# LOOP TO GENERATE DUMP OF NATURAL VARIABLE VALUES
#
dmp10: movl dmvch,r9 # load pointer to next entry on chain
beqlu dmp11 # jump if end of chain
movl (r9),dmvch # else update chain ptr to next entry
jsb setvr # restore vrget field
movl r9,r10 # copy vrblk pointer (name base)
movl $4*vrval,r6 # set offset for vrblk name
jsb prtnv # print name = value
jmp dmp10 # loop back till all printed
#
# PREPARE TO PRINT KEYWORDS
#
dmp11: jsb prtnl # print blank line
jsb prtnl # and another
movl $dmhdk,r9 # point to keyword heading
jsb prtst # print heading
jsb prtnl # end line
jsb prtnl # print one blank line
movl $vdmkw,r10 # point to list of keyword svblk ptrs
#page
#
# DUMPR (CONTINUED)
#
# LOOP TO DUMP KEYWORD VALUES
#
dmp12: movl (r10)+,r9 # load next svblk ptr from table
beqlu dmp13 # jump if end of list
movl $ch$am,r6 # load ampersand
jsb prtch # print ampersand
jsb prtst # print keyword name
movl 4*svlen(r9),r6 # load name length from svblk
movab 3+(4*svchs)(r6),r6 # get length of name
bicl2 $3,r6
addl2 r6,r9 # point to svknm field
movl (r9),dmpkn # store in dummy kvblk
movl $tmbeb,r9 # point to blank-equal-blank
jsb prtst # print it
movl r10,dmpsv # save table pointer
movl $dmpkb,r10 # point to dummy kvblk
movl $4*kvvar,r6 # set zero offset
jsb acess # get keyword value
.long invalid$ # failure is impossible
jsb prtvl # print keyword value
jsb prtnl # terminate print line
movl dmpsv,r10 # restore table pointer
jmp dmp12 # loop back till all printed
#
# HERE AFTER COMPLETING PARTIAL DUMP
#
dmp13: cmpl dmarg,$num01 # exit if partial dump complete
bnequ 0f
jmp dmp27
0:
movl dnamb,r9 # else point to first dynamic block
#
# LOOP THROUGH BLOCKS IN DYNAMIC STORAGE
#
dmp14: cmpl r9,dnamp # jump if end of used region
bnequ 0f
jmp dmp27
0:
movl (r9),r6 # else load first word of block
cmpl r6,$b$vct # jump if vector
beqlu dmp16
cmpl r6,$b$art # jump if array
beqlu dmp17
cmpl r6,$b$pdt # jump if program defined
beqlu dmp18
cmpl r6,$b$tbt # jump if table
beqlu dmp19
cmpl r6,$b$bct # jump if buffer
bnequ 0f
jmp dmp30
0:
#
# MERGE HERE TO MOVE TO NEXT BLOCK
#
dmp15: jsb blkln # get length of block
addl2 r6,r9 # point past this block
jmp dmp14 # loop back for next block
#page
#
# DUMPR (CONTINUED)
#
# HERE FOR VECTOR
#
dmp16: movl $4*vcvls,r7 # set offset to first value
jmp dmp19 # jump to merge
#
# HERE FOR ARRAY
#
dmp17: movl 4*arofs(r9),r7 # set offset to arpro field
addl2 $4,r7 # bump to get offset to values
jmp dmp19 # jump to merge
#
# HERE FOR PROGRAM DEFINED
#
dmp18: movl $4*pdfld,r7 # point to values, merge
#
# HERE FOR TABLE (OTHERS MERGE)
#
dmp19: tstl 4*idval(r9) # ignore block if zero id value
bnequ 0f
jmp dmp15
0:
jsb blkln # else get block length
movl r9,r10 # copy block pointer
movl r6,dmpsv # save length
movl r7,r6 # copy offset to first value
jsb prtnl # print blank line
movl r6,dmpsa # preserve offset
jsb prtvl # print block value (for title)
movl dmpsa,r6 # recover offset
jsb prtnl # end print line
cmpl (r9),$b$tbt # jump if table
beqlu dmp22
subl2 $4,r6 # point before first word
#
# LOOP TO PRINT CONTENTS OF ARRAY, VECTOR, OR PROGRAM DEF
#
dmp20: movl r10,r9 # copy block pointer
addl2 $4,r6 # bump offset
addl2 r6,r9 # point to next value
cmpl r6,dmpsv # exit if end (xr past block)
bnequ 0f
jmp dmp14
0:
subl2 $4*vrval,r9 # subtract offset to merge into loop
#
# LOOP TO FIND VALUE AND IGNORE NULLS
#
dmp21: movl 4*vrval(r9),r9 # load next value
cmpl r9,$nulls # loop back if null value
beqlu dmp20
cmpl (r9),$b$trt # loop back if trapped
beqlu dmp21
jsb prtnv # else print name = value
jmp dmp20 # loop back for next field
#page
#
# DUMPR (CONTINUED)
#
# HERE TO DUMP A TABLE
#
dmp22: movl $4*tbbuk,r8 # set offset to first bucket
movl $4*teval,r6 # set name offset for all teblks
#
# LOOP THROUGH TABLE BUCKETS
#
dmp23: movl r10,-(sp) # save tbblk pointer
addl2 r8,r10 # point to next bucket header
addl2 $4,r8 # bump bucket offset
subl2 $4*tenxt,r10 # subtract offset to merge into loop
#
# LOOP TO PROCESS TEBLKS ON ONE CHAIN
#
dmp24: movl 4*tenxt(r10),r10# point to next teblk
cmpl r10,(sp) # jump if end of chain
beqlu dmp26
movl r10,r9 # else copy teblk pointer
#
# LOOP TO FIND VALUE AND IGNORE IF NULL
#
dmp25: movl 4*teval(r9),r9 # load next value
cmpl r9,$nulls # ignore if null value
beqlu dmp24
cmpl (r9),$b$trt # loop back if trapped
beqlu dmp25
movl r8,dmpsv # else save offset pointer
jsb prtnv # print name = value
movl dmpsv,r8 # reload offset
jmp dmp24 # loop back for next teblk
#
# HERE TO MOVE TO NEXT HASH CHAIN
#
dmp26: movl (sp)+,r10 # restore tbblk pointer
cmpl r8,4*tblen(r10) # loop back if more buckets to go
bnequ dmp23
movl r10,r9 # else copy table pointer
addl2 r8,r9 # point to following block
jmp dmp14 # loop back to process next block
#
# HERE AFTER COMPLETING DUMP
#
dmp27: jsb prtpg # eject printer
#
# MERGE HERE IF NO DUMP GIVEN (DMARG=0)
#
dmp28: rsb # return to dump caller
#
# CALL SYSTEM CORE DUMP ROUTINE
#
dmp29: jsb sysdm # call it
jmp dmp28 # return
#page
#
# DUMPR (CONTINUED)
#
# HERE TO DUMP BUFFER BLOCK
#
dmp30: jsb prtnl # print blank line
jsb prtvl # print value id for title
jsb prtnl # force new line
movl $ch$dq,r6 # load double quote
jsb prtch # print it
movl 4*bclen(r9),r8 # load defined length
beqlu dmp32 # skip characters if none
# load count for loop
movl r9,r7 # save bcblk ptr
movl 4*bcbuf(r9),r9 # point to bfblk
movab cfp$f(r9),r9 # get set to load characters
#
# LOOP HERE STUFFING CHARACTERS IN OUTPUT STREAM
#
dmp31: movzbl (r9)+,r6 # get next character
jsb prtch # stuff it
sobgtr r8,dmp31 # branch for next one
movl r7,r9 # restore bcblk pointer
#
# MERGE TO STUFF CLOSING QUOTE MARK
#
dmp32: movl $ch$dq,r6 # stuff quote
jsb prtch # print it
jsb prtnl # print new line
movl (r9),r6 # get first wd for blkln
jmp dmp15 # merge to get next block
#enp # end procedure dumpr
#page
#
# 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 # entry point
jsb prtis # print error ptr or blank line
movl kvert,r6 # load error code
movl $ermms,r9 # point to error message /error/
jsb prtst # print it
jsb ertex # get error message text
addl2 $thsnd,r6 # bump error code for print
movl r6,r5 # fail code in int acc
jsb prtin # print code (now have error1xxx)
movl prbuf,r10 # point to print buffer
movl $num05,r11 # [get in scratch register]
movab cfp$f(r10)[r11],r10 # point to the 1
movl $ch$bl,r6 # load a blank
movb r6,(r10) # store blank over 1 (error xxx)
#csc r10 # complete store characters
clrl r10 # clear garbage pointer in xl
movl r9,r6 # keep error text
movl $ermns,r9 # point to / -- /
jsb prtst # print it
movl r6,r9 # get error text again
jsb prtst # print error message text
jsb prtis # print line
jsb prtis # print blank line
rsb # return to ermsg caller
#enp # end procedure ermsg
#page
#
# 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 # entry point
movl r6,ertwa # save wa
movl r7,ertwb # save wb
jsb sysem # get failure message text
movl r9,r10 # copy pointer to it
movl 4*sclen(r9),r6 # get length of string
beqlu ert02 # jump if null
clrl r7 # offset of zero
jsb sbstr # copy into dynamic store
movl r9,r$etx # store for relocation
#
# RETURN
#
ert01: movl ertwb,r7 # restore wb
movl ertwa,r6 # restore wa
rsb # return to caller
#
# RETURN ERRTEXT CONTENTS INSTEAD OF NULL
#
ert02: movl r$etx,r9 # get errtext
jmp ert01 # return
#enp
#page
#
# 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 # entry point (recursive)
jsb evalp # evaluate expression
.long evli1 # jump on failure
movl r10,-(sp) # stack result for gtsmi
movl 4*pthen(r9),r10 # load successor pointer
jsb gtsmi # convert arg to small integer
.long evli2 # jump if not integer
.long evli3 # jump if out of range
movl r9,evliv # store result in special dummy node
movl r10,evlis # store successor pointer
movl $evlin,r9 # point to dummy node with result
addl3 $4*3,(sp)+,r11 # take successful exit
jmp *(r11)+
#
# HERE IF EVALUATION FAILS
#
evli1: addl3 $4*2,(sp)+,r11 # take failure return
jmp *(r11)+
#
# HERE IF ARGUMENT IS NOT INTEGER
#
evli2: movl (sp)+,r11 # take non-integer error exit
jmp *(r11)+
#
# HERE IF ARGUMENT IS OUT OF RANGE
#
evli3: addl3 $4*1,(sp)+,r11 # take out-of-range error exit
jmp *(r11)+
#enp # end procedure evali
#page
#
# 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 # entry point (recursive)
movl 4*parm1(r9),r10 # load expression pointer
cmpl (r10),$b$exl # jump if exblk case
beqlu evlp1
#
# 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.
#
movl 4*sevar(r10),r10# load vrblk pointer
movl 4*vrval(r10),r10# load value of vrblk
movl (r10),r6 # load first word of value
cmpl r6,$b$t$$ # jump if not seblk, trblk or exblk
bgequ evlp3
#
# HERE FOR EXBLK OR SEBLK WITH EXPR VALUE OR TRAPPED VALUE
#
evlp1: movl r9,-(sp) # stack node pointer
movl r7,-(sp) # stack cursor
movl r$pms,-(sp) # stack subject string pointer
movl pmssl,-(sp) # stack subject string length
movl pmdfl,-(sp) # stack dot flag
movl pmhbs,-(sp) # stack history stack base pointer
movl 4*parm1(r9),r9 # load expression pointer
#page
#
# EVALP (CONTINUED)
#
# LOOP BACK HERE TO REEVALUATE EXPRESSION RESULT
#
evlp2: clrl r7 # set flag for by value
jsb evalx # evaluate expression
.long evlp4 # jump on failure
movl (r9),r6 # else load first word of value
cmpl r6,$b$e$$ # loop back to reevaluate expression
blequ evlp2
#
# HERE TO RESTORE PATTERN VALUES AFTER SUCCESSFUL EVAL
#
movl r9,r10 # copy result pointer
movl (sp)+,pmhbs # restore history stack base pointer
movl (sp)+,pmdfl # restore dot flag
movl (sp)+,pmssl # restore subject string length
movl (sp)+,r$pms # restore subject string pointer
movl (sp)+,r7 # restore cursor
movl (sp)+,r9 # restore node pointer
#
# COMMON EXIT POINT
#
evlp3: addl2 $4*1,(sp) # return to evalp caller
rsb
#
# HERE FOR FAILURE DURING EVALUATION
#
evlp4: movl (sp)+,pmhbs # restore history stack base pointer
movl (sp)+,pmdfl # restore dot flag
movl (sp)+,pmssl # restore subject string length
movl (sp)+,r$pms # restore subject string pointer
addl2 $4*num02,sp # remove node ptr, cursor
movl (sp)+,r11 # take failure exit
jmp *(r11)+
#enp # end procedure evalp
#page
#
# 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 # entry point (recursive)
jsb evalp # evaluate expression
.long evls1 # jump if evaluation fails
movl 4*pthen(r9),-(sp)# save successor pointer
movl r7,-(sp) # save cursor
movl r10,-(sp) # stack result ptr for patst
clrl r7 # dummy pcode for one char string
clrl r8 # dummy pcode for expression arg
movl $p$brk,r10 # appropriate pcode for our use
jsb patst # call routine to build node
.long evls2 # jump if not string
movl (sp)+,r7 # restore cursor
movl (sp)+,4*pthen(r9)# store successor pointer
addl3 $4*2,(sp)+,r11 # take success return
jmp *(r11)+
#
# HERE IF EVALUATION FAILS
#
evls1: addl3 $4*1,(sp)+,r11 # take failure return
jmp *(r11)+
#
# HERE IF ARGUMENT IS NOT STRING
#
evls2: addl2 $4*num02,sp # pop successor and cursor
movl (sp)+,r11 # take non-string error exit
jmp *(r11)+
#enp # end procedure evals
#page
#
# 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 # entry point, recursive
cmpl (r9),$b$exl # jump if exblk case
beqlu evlx2
#
# HERE FOR SEBLK
#
movl 4*sevar(r9),r10 # load vrblk pointer (name base)
movl $4*vrval,r6 # set name offset
tstl r7 # jump if called by name
beqlu 0f
jmp evlx1
0:
jsb acess # call routine to access value
.long evlx9 # jump if failure on access
#
# MERGE HERE TO EXIT FOR SEBLK CASE
#
evlx1: addl2 $4*1,(sp) # return to evalx caller
rsb
#page
#
# 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: movl r3,r8 # get code pointer
movl r$cod,r6 # load code block pointer
subl2 r6,r8 # get code pointer as offset
movl r6,-(sp) # stack old code block pointer
movl r8,-(sp) # stack relative code offset
movl flptr,-(sp) # stack old failure pointer
movl r7,-(sp) # stack name/value indicator
movl $4*exflc,-(sp) # stack new fail offset
movl flptr,gtcef # keep in case of error
movl r$cod,r$gtc # keep code block pointer similarly
movl sp,flptr # set new failure pointer
movl r9,r$cod # set new code block pointer
movl kvstn,4*exstm(r9)# remember stmnt number
addl2 $4*excod,r9 # point to first code word
movl r9,r3 # set code pointer
cmpl stage,$stgxt # jump if not execution time
beqlu 0f
jmp exits
0:
movl $stgee,stage # evaluating expression
jmp exits # jump to execute first code word
#page
#
# EVALX (CONTINUED)
#
# COME HERE IF SUCCESSFUL RETURN BY VALUE (SEE O$RVL)
#
evlx3: movl (sp)+,r9 # load value
tstl 4*1(sp) # jump if called by value
beqlu evlx5
jmp er_249 # expression evaluated by name returned value
#
# HERE FOR EXPRESSION RETURNING BY NAME (SEE O$RNM)
#
evlx4: movl (sp)+,r6 # load name offset
movl (sp)+,r10 # load name base
tstl 4*1(sp) # jump if called by name
bnequ evlx5
jsb acess # else access value first
.long evlx6 # jump if failure during access
#
# HERE AFTER LOADING CORRECT RESULT INTO XR OR XL,WA
#
evlx5: clrl r7 # note successful
jmp evlx7 # merge
#
# HERE FOR FAILURE IN EXPRESSION EVALUATION (SEE O$FEX)
#
evlx6: movl sp,r7 # note unsuccessful
#
# RESTORE ENVIRONMENT
#
evlx7: cmpl stage,$stgee # skip if was not previously xt
bnequ evlx8
movl $stgxt,stage # execute time
#
# MERGE WITH STAGE SET UP
#
evlx8: addl2 $4*num02,sp # pop name/value indicator, *exfal
movl (sp)+,flptr # restore old failure pointer
movl (sp)+,r8 # load code offset
addl2 (sp),r8 # make code pointer absolute
movl (sp)+,r$cod # restore old code block pointer
movl r8,r3 # restore old code pointer
tstl r7 # jump for successful return
bnequ 0f
jmp evlx1
0:
#
# MERGE HERE FOR FAILURE IN SEBLK CASE
#
evlx9: movl (sp)+,r11 # take failure exit
jmp *(r11)+
#enp # end of procedure evalx
#page
#
# 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 # entry point
movl r10,r6 # copy offset to start of code
subl2 $4*excod,r6 # calc reduction in offset in exblk
movl r6,-(sp) # stack for later
movl cwcof,r6 # load final offset
subl2 r10,r6 # compute length of code
addl2 $4*exsi$,r6 # add space for standard fields
jsb alloc # allocate space for exblk
movl r9,-(sp) # save pointer to exblk
movl $b$exl,4*extyp(r9) # store type word
clrl 4*exstm(r9) # zeroise stmnt number field
movl r6,4*exlen(r9) # store length
movl $ofex$,4*exflc(r9) # store failure word
addl2 $4*exsi$,r9 # set xr for sysmw
movl r10,cwcof # reset offset to start of code
addl2 r$ccb,r10 # point to start of code
subl2 $4*exsi$,r6 # length of code to move
movl r6,-(sp) # stack length of code
jsb sbmvw # move code to exblk
movl (sp)+,r6 # get length of code
ashl $-2,r6,r6 # convert byte count to word count
# prepare counter for loop
movl (sp),r10 # copy exblk ptr, dont unstack
addl2 $4*excod,r10 # point to code itself
movl 4*1(sp),r7 # 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: movl (r10)+,r9 # get next code word
cmpl r9,$osla$ # jump if selection found
beqlu exbl3
cmpl r9,$onta$ # jump if negation found
beqlu exbl3
sobgtr r6,exbl1 # loop to end of code
#
# NO SELECTION FOUND OR MERGE TO EXIT ON TERMINATION
#
exbl2: movl (sp)+,r9 # pop exblk ptr into xr
movl (sp)+,r10 # pop reduction constant
rsb # return to caller
#page
#
# EXBLD (CONTINUED)
#
# SELECTION OR NEGATION FOUND
# REDUCE THE OFFSETS AS NEEDED. OFFSETS OCCUR IN WORDS
# FOLLOWING CODE WORDS -
# =ONTA$, =OSLA$, =OSLB$, =OSLC$
#
exbl3: subl2 r7,(r10)+ # adjust offset
sobgtr r6,exbl4 # decrement count
#
exbl4: sobgtr r6,exbl5 # decrement count
#
# CONTINUE SEARCH FOR MORE OFFSETS
#
exbl5: movl (r10)+,r9 # get next code word
cmpl r9,$osla$ # jump if offset found
beqlu exbl3
cmpl r9,$oslb$ # jump if offset found
beqlu exbl3
cmpl r9,$oslc$ # jump if offset found
beqlu exbl3
cmpl r9,$onta$ # jump if offset found
beqlu exbl3
sobgtr r6,exbl5 # loop
jmp exbl2 # merge to return
#enp # end procedure exbld
#page
#
# 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.
#page
#
# EXPAN (CONTINUED)
#
# ENTRY POINT
#
expan: #prc # entry point
clrl -(sp) # set top of stack indicator
clrl r6 # set initial state to zero
clrl r8 # zero counter value
#
# LOOP HERE FOR SUCCESSIVE ENTRIES
#
exp01: jsb scane # scan next element
addl2 r6,r10 # add state to syntax code
casel r10,$0,$t$nes # switch on element type/state
5:
.word exp27-5b # unop, s=0
.word exp27-5b # unop, s=1
.word exp04-5b # unop, s=2
.word exp06-5b # left paren, s=0
.word exp06-5b # left paren, s=1
.word exp04-5b # left paren, s=2
.word exp08-5b # left brkt, s=0
.word exp08-5b # left brkt, s=1
.word exp09-5b # left brkt, s=2
.word exp02-5b # comma, s=0
.word exp05-5b # comma, s=1
.word exp11-5b # comma, s=2
.word exp10-5b # function, s=0
.word exp10-5b # function, s=1
.word exp04-5b # function, s=2
.word exp03-5b # variable, s=0
.word exp03-5b # variable, state one
.word exp04-5b # variable, s=2
.word exp03-5b # constant, s=0
.word exp03-5b # constant, s=1
.word exp04-5b # constant, s=2
.word exp05-5b # binop, s=0
.word exp05-5b # binop, s=1
.word exp26-5b # binop, s=2
.word exp02-5b # right paren, s=0
.word exp05-5b # right paren, s=1
.word exp12-5b # right paren, s=2
.word exp02-5b # right brkt, s=0
.word exp05-5b # right brkt, s=1
.word exp18-5b # right brkt, s=2
.word exp02-5b # colon, s=0
.word exp05-5b # colon, s=1
.word exp19-5b # colon, s=2
.word exp02-5b # semicolon, s=0
.word exp05-5b # semicolon, s=1
.word exp19-5b # semicolon, s=2
#esw # end switch on element type/state
#page
#
# 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: movl sp,scnrs # set to rescan element
movl $nulls,r9 # point to null, merge
#
# HERE FOR VAR OR CON IN STATES 0,1
#
# STACK THE VARIABLE/CONSTANT AND SET STATE=2
#
exp03: movl r9,-(sp) # stack pointer to operand
movl $num02,r6 # set state 2
jmp 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: movl sp,scnrs # set to rescan element
movl $opdvc,r9 # point to concat operator dv
tstl r7 # ok if at top level
beqlu exp4a
movl $opdvp,r9 # else point to unmistakable concat.
#
# MERGE HERE WHEN XR SET UP WITH PROPER CONCATENATION DVBLK
#
exp4a: tstl scnbl # merge bop if blanks, else error
beqlu 0f
jmp exp26
0:
decl scnse # adjust start of element location
jmp er_220 # syntax error. missing operator
#
# HERE FOR CMA,RPR,RBR,COL,SMC,BOP(S=1) BOP(S=0)
#
# THIS IS AN ERRONOUS CONTRUCTION
#
exp05: decl scnse # adjust start of element location
jmp er_221 # syntax error. missing operand
#
# HERE FOR LPR (S=0,1)
#
exp06: movl $num04,r10 # set new level indicator
clrl r9 # set zero value for cmopn
#page
#
# EXPAN (CONTINUED)
#
# MERGE HERE TO STORE OLD LEVEL ON STACK AND START NEW ONE
#
exp07: movl r9,-(sp) # stack cmopn value
movl r8,-(sp) # stack old counter
movl r7,-(sp) # stack old level indicator
jsb sbchk # check for stack overflow
clrl r6 # set new state to zero
movl r10,r7 # set new level indicator
movl $num01,r8 # initialize new counter
jmp exp01 # jump to scan next element
#
# HERE FOR LBR (S=0,1)
#
# THIS IS AN ILLEGAL USE OF LEFT BRACKET
#
exp08: jmp er_222 # syntax error. invalid use of left bracket
#
# HERE FOR LBR (S=2)
#
# SET NEW LEVEL AND START TO SCAN SUBSCRIPTS
#
exp09: movl (sp)+,r9 # load array ptr for cmopn
movl $num03,r10 # set new level indicator
jmp exp07 # jump to stack old and start new
#
# HERE FOR FNC (S=0,1)
#
# STACK OLD LEVEL AND START TO SCAN ARGUMENTS
#
exp10: movl $num05,r10 # set new lev indic (xr=vrblk=cmopn)
jmp exp07 # jump to stack old and start new
#
# HERE FOR CMA (S=2)
#
# INCREMENT ARGUMENT COUNT AND CONTINUE
#
exp11: incl r8 # increment counter
jsb expdm # dump operators at this level
clrl -(sp) # set new level for parameter
clrl r6 # set new state
cmpl r7,$num02 # loop back unless outer level
blequ 0f
jmp exp01
0:
jmp er_223 # syntax error. invalid use of comma
#page
#
# 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: cmpl r7,$num01 # end of normal goto
bnequ 0f
jmp exp20
0:
cmpl r7,$num05 # end of function arguments
beqlu exp13
cmpl r7,$num04 # end of grouping / selection
beqlu exp14
jmp er_224 # syntax error. unbalanced right parenthesis
#
# HERE AT END OF FUNCTION ARGUMENTS
#
exp13: movl $c$fnc,r10 # set cmtyp value for function
jmp exp15 # jump to build cmblk
#
# HERE FOR END OF GROUPING
#
exp14: cmpl r8,$num01 # jump if end of grouping
beqlu exp17
movl $c$sel,r10 # 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: jsb expdm # dump operators at this level
movl r8,r6 # copy count
addl2 $cmvls,r6 # add for standard fields at start
moval 0[r6],r6 # convert length to bytes
jsb alloc # allocate space for cmblk
movl $b$cmt,(r9) # store type code for cmblk
movl r10,4*cmtyp(r9) # store cmblk node type indicator
movl r6,4*cmlen(r9) # store length
addl2 r6,r9 # point past end of block
# set loop counter
#
# LOOP TO MOVE REMAINING WORDS TO CMBLK
#
exp16: movl (sp)+,-(r9) # move one operand ptr from stack
movl (sp)+,r7 # pop to old level indicator
sobgtr r8,exp16 # loop till all moved
#page
#
# EXPAN (CONTINUED)
#
# COMPLETE CMBLK AND STACK POINTER TO IT ON STACK
#
subl2 $4*cmvls,r9 # point back to start of block
movl (sp)+,r8 # restore old counter
movl (sp),4*cmopn(r9)# store operand ptr in cmblk
movl r9,(sp) # stack cmblk pointer
movl $num02,r6 # set new state
jmp exp01 # back for next element
#
# HERE AT END OF A PARENTHESIZED EXPRESSION
#
exp17: jsb expdm # dump operators at this level
movl (sp)+,r9 # restore xr
movl (sp)+,r7 # restore outer level
movl (sp)+,r8 # restore outer count
movl r9,(sp) # store opnd over unused cmopn val
movl $num02,r6 # set new state
jmp 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: movl $c$arr,r10 # set cmtyp for array reference
cmpl r7,$num03 # jump to build cmblk if end arrayref
beqlu exp15
cmpl r7,$num02 # jump if end of direct goto
bnequ 0f
jmp exp20
0:
jmp er_225 # syntax error. unbalanced right bracket
#page
#
# EXPAN (CONTINUED)
#
# HERE FOR COL,SMC (S=2)
#
# ERROR UNLESS TERMINATING STATEMENT BODY AT OUTER LEVEL
#
exp19: movl sp,scnrs # rescan terminator
movl r7,r10 # copy level indicator
casel r10,$0,$6 # switch on level indicator
5:
.word exp20-5b # normal outer level
.word exp22-5b # fail if normal goto
.word exp23-5b # fail if direct goto
.word exp24-5b # fail array brackets
.word exp21-5b # fail if in grouping
.word exp21-5b # fail function args
#esw # end switch on level
#
# HERE AT NORMAL END OF EXPRESSION
#
exp20: jsb expdm # dump remaining operators
movl (sp)+,r9 # load tree pointer
addl2 $4,sp # pop off bottom of stack marker
rsb # return to expan caller
#
# MISSING RIGHT PAREN
#
exp21: jmp er_226 # syntax error. missing right paren
#
# MISSING RIGHT PAREN IN GOTO FIELD
#
exp22: jmp er_227 # syntax error. right paren missing from goto
#
# MISSING BRACKET IN GOTO
#
exp23: jmp er_228 # syntax error. right bracket missing from goto
#
# MISSING ARRAY BRACKET
#
exp24: jmp er_229 # syntax error. missing right array bracket
#page
#
# EXPAN (CONTINUED)
#
# LOOP HERE WHEN AN OPERATOR CAUSES AN OPERATOR DUMP
#
exp25: movl r9,expsv
jsb expop # pop one operator
movl expsv,r9 # 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: movl 4*1(sp),r10 # load operator dvptr from stack
cmpl r10,$num05 # jump if bottom of stack level
blequ exp27
cmpl 4*dvrpr(r9),4*dvlpr(r10) # else pop if new prec is lo
blssu exp25
#
# 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: movl r9,-(sp) # stack operator dvptr on stack
jsb sbchk # check for stack overflow
movl $num01,r6 # set new state
cmpl r9,$opdvs # back for next element unless =
beqlu 0f
jmp exp01
0:
#
# 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).
#
clrl r6 # set state zero
jmp exp01 # jump for next element
#enp # end procedure expan
#page
#
# 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 # entry point
movl r10,-(sp) # save xl
cmpl (r9),$b$cmt # no match if not complex
bnequ expp2
movl 4*cmtyp(r9),r6 # else load type code
cmpl r6,$c$cnc # concatenation is a match
beqlu expp1
cmpl r6,$c$pmt # binary question mark is a match
beqlu expp1
cmpl r6,$c$alt # else not match unless alternation
bnequ expp2
#
# HERE FOR ALTERNATION. CHANGE (A B) / C TO A QM (B / C)
#
movl 4*cmlop(r9),r10 # load left operand pointer
cmpl (r10),$b$cmt # not match if left opnd not complex
bnequ expp2
cmpl 4*cmtyp(r10),$c$cnc # not match if left op not conc
bnequ expp2
movl 4*cmrop(r10),4*cmlop(r9) # xr points to (b / c)
movl r9,4*cmrop(r10) # set xl opnds to a, (b / c)
movl r10,r9 # point to this altered node
#
# EXIT HERE FOR PATTERN MATCH
#
expp1: movl (sp)+,r10 # restore entry xl
addl2 $4*1,(sp) # give pattern match return
rsb
#
# EXIT HERE IF NOT PATTERN MATCH
#
expp2: movl (sp)+,r10 # restore entry xl
movl (sp)+,r11 # give non-match return
jmp *(r11)+
#enp # end procedure expap
#page
#
# 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
#
.data 1
expdm_s: .long 0
.text 0
expdm: movl (sp)+,expdm_s # entry point
movl r10,r$exs # save xl value
#
# LOOP TO DUMP OPERATORS
#
exdm1: cmpl 4*1(sp),$num05 # jump if stack bottom (saved level
blequ exdm2
jsb expop # else pop one operator
jmp exdm1 # and loop back
#
# HERE AFTER POPPING ALL OPERATORS
#
exdm2: movl r$exs,r10 # restore xl
clrl r$exs # release save location
jmp *expdm_s # return to expdm caller
#enp # end procedure expdm
#page
#
# 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
#
.data 1
expop_s: .long 0
.text 0
expop: movl (sp)+,expop_s # entry point
movl 4*1(sp),r9 # load operator dv pointer
cmpl 4*dvlpr(r9),$lluno # jump if unary
beqlu expo2
#
# HERE FOR BINARY OPERATOR
#
movl $4*cmbs$,r6 # set size of binary operator cmblk
jsb alloc # allocate space for cmblk
movl (sp)+,4*cmrop(r9)# pop and store right operand ptr
movl (sp)+,r10 # pop and load operator dv ptr
movl (sp),4*cmlop(r9)# store left operand pointer
#
# COMMON EXIT POINT
#
expo1: movl $b$cmt,(r9) # store type code for cmblk
movl 4*dvtyp(r10),4*cmtyp(r9) # store cmblk node type code
movl r10,4*cmopn(r9) # store dvptr (=ptr to dac o$xxx)
movl r6,4*cmlen(r9) # store cmblk length
movl r9,(sp) # store resulting node ptr on stack
jmp *expop_s # return to expop caller
#
# HERE FOR UNARY OPERATOR
#
expo2: movl $4*cmus$,r6 # set size of unary operator cmblk
jsb alloc # allocate space for cmblk
movl (sp)+,4*cmrop(r9)# pop and store operand pointer
movl (sp),r10 # load operator dv pointer
jmp expo1 # merge back to exit
#enp # end procedure expop
#page
#
# 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 # entry point
tstl kvcas # skip if &case is 0
beqlu fst99
movl r10,-(sp) # save xl across call
movl r9,-(sp) # save original scblk ptr
jsb alocs # allocate new string block
movl (sp),r10 # point to original scblk
movl r9,-(sp) # save pointer to new scblk
movab cfp$f(r10),r10 # point to original chars
movab cfp$f(r9),r9 # point to new chars
clrl -(sp) # init did fold flag
# load loop counter
fst01: movzbl (r10)+,r6 # load character
cmpl $ch$$a,r6 # skip if less than lc a
bgtru fst02
cmpl r6,$ch$$$ # skip if greater than lc z
bgtru fst02
bicl2 $ch$bl,r6 # fold character to upper case
movl sp,(sp) # set did fold character flag
fst02: movb r6,(r9)+ # store (possibly folded) character
sobgtr r8,fst01 # loop thru entire string
#csc r9 # complete store characters
tstl (sp)+ # skip if folding done
bnequ fst10
movl (sp)+,dnamp # do not need new scblk
movl (sp)+,r9 # return original scblk
jmp fst20 # merge below
fst10: movl (sp)+,r9 # return new scblk
addl2 $4,sp # throw away original scblk pointer
fst20: movl 4*sclen(r9),r6 # reload string length
movl (sp)+,r10 # restore xl
fst99: rsb # return
#enp
#page
#
# 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.
#page
#
# 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.
#page
#
# GBCOL (CONTINUED)
#
gbcol: #prc # entry point
tstl dmvch # fail if in mid-dump
beqlu 0f
jmp gbc14
0:
movl sp,gbcfl # note gbcol entered
movl r6,gbsva # save entry wa
movl r7,gbsvb # save entry wb
movl r8,gbsvc # save entry wc
movl r10,-(sp) # save entry xl
movl r3,r6 # get code pointer value
subl2 r$cod,r6 # make relative
movl r6,r3 # and restore
#
# PROCESS STACK ENTRIES
#
movl sp,r9 # point to stack front
movl stbas,r10 # point past end of stack
cmpl r10,r9 # ok if d-stack
bgequ gbc00
movl r10,r9 # reverse if ...
movl sp,r10 # ... u-stack
#
# PROCESS THE STACK
#
gbc00: jsb gbcpf # process pointers on stack
#
# PROCESS SPECIAL WORK LOCATIONS
#
movl $r$aaa,r9 # point to start of relocatable locs
movl $r$yyy,r10 # point past end of relocatable locs
jsb gbcpf # process work fields
#
# PREPARE TO PROCESS VARIABLE BLOCKS
#
movl hshtb,r6 # point to first hash slot pointer
#
# LOOP THROUGH HASH SLOTS
#
gbc01: movl r6,r10 # point to next slot
addl2 $4,r6 # bump bucket pointer
movl r6,gbcnm # save bucket pointer
#page
#
# GBCOL (CONTINUED)
#
# LOOP THROUGH VARIABLES ON ONE HASH CHAIN
#
gbc02: movl (r10),r9 # load ptr to next vrblk
beqlu gbc03 # jump if end of chain
movl r9,r10 # else copy vrblk pointer
addl2 $4*vrval,r9 # point to first reloc fld
addl2 $4*vrnxt,r10 # point past last (and to link ptr)
jsb gbcpf # process reloc fields in vrblk
jmp gbc02 # loop back for next block
#
# HERE AT END OF ONE HASH CHAIN
#
gbc03: movl gbcnm,r6 # restore bucket pointer
cmpl r6,hshte # loop back if more buckets to go
bnequ gbc01
#page
#
# 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: movl dnamb,r9 # point to first block
movl r9,r8 # set as first eventual location
addl2 gbsvb,r8 # add offset for eventual move up
clrl gbcnm # clear initial forward pointer
movl $gbcnm,gbclm # initialize ptr to last move block
movl r9,gbcns # initialize first address
#
# LOOP THROUGH A SERIES OF BLOCKS IN USE
#
gbc05: cmpl r9,dnamp # jump if end of used region
beqlu gbc07
movl (r9),r6 # else get first word
cmpl r6,$p$yyy # skip if not entry ptr (in use)
bgequ gbc06
cmpl r6,$b$aaa # jump if entry pointer (unused)
bgequ gbc07
#
# HERE FOR BLOCK IN USE, LOOP TO RELOCATE REFERENCES
#
gbc06: movl r6,r10 # copy pointer
movl (r10),r6 # load forward pointer
movl r8,(r10) # relocate reference
cmpl r6,$p$yyy # loop back if not end of chain
bgequ gbc06
cmpl r6,$b$aaa # loop back if not end of chain
blequ gbc06
#page
#
# GBCOL (CONTINUED)
#
# AT END OF CHAIN, RESTORE FIRST WORD AND BUMP PAST
#
movl r6,(r9) # restore first word
jsb blkln # get length of this block
addl2 r6,r9 # bump actual pointer
addl2 r6,r8 # bump eventual pointer
jmp gbc05 # loop back for next block
#
# HERE AT END OF A SERIES OF BLOCKS IN USE
#
gbc07: movl r9,r6 # copy pointer past last block
movl gbclm,r10 # point to previous move block
subl2 4*1(r10),r6 # subtract starting address
movl r6,4*1(r10) # store length of block to be moved
#
# LOOP THROUGH A SERIES OF BLOCKS NOT IN USE
#
gbc08: cmpl r9,dnamp # jump if end of used region
beqlu gbc10
movl (r9),r6 # else load first word of next block
cmpl r6,$p$yyy # jump if in use
bgequ gbc09
cmpl r6,$b$aaa # jump if in use
blequ gbc09
jsb blkln # else get length of next block
addl2 r6,r9 # push pointer
jmp 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: subl2 $4*num02,r9 # point 2 words behind for move block
movl gbclm,r10 # point to previous move block
movl r9,(r10) # set forward ptr in previous block
clrl (r9) # zero forward ptr of new block
movl r9,gbclm # remember address of this block
movl r9,r10 # copy ptr to move block
addl2 $4*num02,r9 # point back to block in use
movl r9,4*1(r10) # store starting address
jmp gbc06 # jump to process block in use
#page
#
# GBCOL (CONTINUED)
#
# HERE FOR PASS THREE -- ACTUALLY MOVE THE BLOCKS DOWN
#
# (XL) POINTER TO OLD LOCATION
# (XR) POINTER TO NEW LOCATION
#
gbc10: movl dnamb,r9 # point to start of storage
addl2 gbcns,r9 # bump past unmoved blocks at start
#
# LOOP THROUGH MOVE DESCRIPTORS
#
gbc11: movl gbcnm,r10 # point to next move block
beqlu gbc12 # jump if end of chain
movl (r10)+,gbcnm # move pointer down chain
movl (r10)+,r6 # get length to move
jsb sbmvw # perform move
jmp gbc11 # loop back
#
# NOW TEST FOR MOVE UP
#
gbc12: movl r9,dnamp # set next available loc ptr
movl gbsvb,r7 # reload move offset
beqlu gbc13 # jump if no move required
movl r9,r10 # else copy old top of core
addl2 r7,r9 # point to new top of core
movl r9,dnamp # save new top of core pointer
movl r10,r6 # copy old top
subl2 dnamb,r6 # minus old bottom = length
addl2 r7,dnamb # bump bottom to get new value
jsb sbmwb # perform move (backwards)
#
# MERGE HERE TO EXIT
#
gbc13: movl gbsva,r6 # restore wa
movl r3,r8 # get code pointer
addl2 r$cod,r8 # make absolute again
movl r8,r3 # and replace absolute value
movl gbsvc,r8 # restore wc
movl (sp)+,r10 # restore entry xl
incl gbcnt # increment count of collections
clrl r9 # clear garbage value in xr
clrl gbcfl # note exit from gbcol
rsb # exit to gbcol caller
#
# GARBAGE COLLECTION NOT ALLOWED WHILST DUMPING
#
gbc14: incl errft # fatal error
jmp er_250 # insufficient memory to complete dump
#enp # end procedure gbcol
#page
#
# 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 # entry point
clrl -(sp) # set zero to mark bottom of stack
movl r10,-(sp) # 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: movl (r9),r10 # load field contents
movl r9,r8 # save field pointer
cmpl r10,dnamb # jump if not ptr into dynamic area
blssu gpf02
cmpl r10,dnamp # jump if not ptr into dynamic area
bgequ gpf02
#
# HERE WE HAVE A PTR TO A BLOCK IN THE DYNAMIC AREA.
# LINK THIS FIELD ONTO THE REFERENCE BACKCHAIN.
#
movl (r10),r6 # load ptr to chain (or entry ptr)
movl r9,(r10) # set this field as new head of chain
movl r6,(r9) # set forward pointer
#
# NOW SEE IF THIS BLOCK HAS BEEN PROCESSED BEFORE
#
cmpl r6,$p$yyy # jump if already processed
bgequ gpf02
cmpl r6,$b$aaa # jump if not already processed
bgequ gpf03
#
# HERE TO MOVE TO NEXT FIELD
#
gpf02: movl r8,r9 # restore field pointer
addl2 $4,r9 # bump to next field
cmpl r9,(sp) # loop back if more to go
bnequ gpf01
#page
#
# GBCPF (CONTINUED)
#
# HERE WE POP UP A LEVEL AFTER FINISHING A BLOCK
#
movl (sp)+,r10 # restore pointer past end
movl (sp)+,r8 # restore block pointer
bnequ gpf02 # continue loop unless outer levl
rsb # return to caller if outer level
#
# HERE TO PROCESS AN ACTIVE BLOCK WHICH HAS NOT BEEN DONE
#
gpf03: movl r10,r9 # copy block pointer
movl r6,r10 # copy first word of block
movzwl -2(r10),r10 # 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.
#
casel r10,$0,$bl$$$ # switch on block type
5:
.word gpf06-5b # arblk
.word gpf18-5b # bcblk
.word gpf08-5b # cdblk
.word gpf17-5b # exblk
.word gpf02-5b # icblk
.word gpf10-5b # nmblk
.word gpf10-5b # p0blk
.word gpf12-5b # p1blk
.word gpf12-5b # p2blk
.word gpf02-5b # rcblk
.word gpf02-5b # scblk
.word gpf02-5b # seblk
.word gpf08-5b # tbblk
.word gpf08-5b # vcblk
.word gpf02-5b # xnblk
.word gpf09-5b # xrblk
.word gpf13-5b # pdblk
.word gpf16-5b # trblk
.word gpf02-5b # bfblk
.word gpf07-5b # ccblk
.word gpf04-5b # cmblk
.word gpf02-5b # ctblk
.word gpf02-5b # dfblk
.word gpf02-5b # efblk
.word gpf10-5b # evblk
.word gpf11-5b # ffblk
.word gpf02-5b # kvblk
.word gpf14-5b # pfblk
.word gpf15-5b # teblk
#esw # end of jump table
#page
#
# GBCPF (CONTINUED)
#
# CMBLK
#
gpf04: movl 4*cmlen(r9),r6 # load length
movl $4*cmtyp,r7 # 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: addl2 r9,r6 # point past last reloc field
addl2 r7,r9 # point to first reloc field
movl r8,-(sp) # stack old field pointer
movl r6,-(sp) # stack new limit pointer
jsb sbchk # check for stack overflow
jmp gpf01 # if ok, back to process
#
# ARBLK
#
gpf06: movl 4*arlen(r9),r6 # load length
movl 4*arofs(r9),r7 # set offset to 1st reloc fld (arpro)
jmp gpf05 # all set
#
# CCBLK
#
gpf07: movl 4*ccuse(r9),r6 # set length in use
movl $4*ccuse,r7 # 1st word (make sure at least one)
jmp gpf05 # all set
#page
#
# GBCPF (CONTINUED)
#
# CDBLK, TBBLK, VCBLK
#
gpf08: movl 4*offs2(r9),r6 # load length
movl $4*offs3,r7 # set offset
jmp gpf05 # jump back
#
# XRBLK
#
gpf09: movl 4*xrlen(r9),r6 # load length
movl $4*xrptr,r7 # set offset
jmp gpf05 # jump back
#
# EVBLK, NMBLK, P0BLK
#
gpf10: movl $4*offs2,r6 # point past second field
movl $4*offs1,r7 # offset is one (only reloc fld is 2)
jmp gpf05 # all set
#
# FFBLK
#
gpf11: movl $4*ffofs,r6 # set length
movl $4*ffnxt,r7 # set offset
jmp gpf05 # all set
#
# P1BLK, P2BLK
#
gpf12: movl $4*parm2,r6 # length (parm2 is non-relocatable)
movl $4*pthen,r7 # set offset
jmp gpf05 # all set
#page
#
# GBCPF (CONTINUED)
#
# PDBLK
#
gpf13: movl 4*pddfp(r9),r10 # load ptr to dfblk
movl 4*dfpdl(r10),r6 # get pdblk length
movl $4*pdfld,r7 # set offset
jmp gpf05 # all set
#
# PFBLK
#
gpf14: movl $4*pfarg,r6 # length past last reloc
movl $4*pfcod,r7 # offset to first reloc
jmp gpf05 # all set
#
# TEBLK
#
gpf15: movl $4*tesi$,r6 # set length
movl $4*tesub,r7 # and offset
jmp gpf05 # all set
#
# TRBLK
#
gpf16: movl $4*trsi$,r6 # set length
movl $4*trval,r7 # and offset
jmp gpf05 # all set
#
# EXBLK
#
gpf17: movl 4*exlen(r9),r6 # load length
movl $4*exflc,r7 # set offset
jmp gpf05 # jump back
#
# BCBLK
#
gpf18: movl $4*bcsi$,r6 # set length
movl $4*bcbuf,r7 # and offset
jmp gpf05 # all set
#enp # end procedure gbcpf
#page
#
# 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 # entry point
movl (r9),r6 # load type word
cmpl r6,$b$art # exit if already an array
bnequ 0f
jmp gtar8
0:
cmpl r6,$b$vct # exit if already an array
bnequ 0f
jmp gtar8
0:
cmpl r6,$b$tbt # else fail if not a table (sgd02)
beqlu 0f
jmp gta9a
0:
#
# HERE WE CONVERT A TABLE TO AN ARRAY
#
movl r9,-(sp) # replace tbblk pointer on stack
clrl r9 # signal first pass
clrl r7 # 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: movl (sp),r10 # point to table
addl2 4*tblen(r10),r10# point past last bucket
subl2 $4*tbbuk,r10 # set first bucket offset
movl r10,r6 # 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: movl r6,r10 # copy bucket pointer
subl2 $4,r6 # decrement bucket pointer
#
# LOOP THROUGH TEBLKS ON ONE BUCKET CHAIN
#
gtar3: movl 4*tenxt(r10),r10# point to next teblk
cmpl r10,(sp) # jump if chain end (tbblk ptr)
beqlu gtar6
movl r10,cnvtp # else save teblk pointer
#
# LOOP TO FIND VALUE DOWN TRBLK CHAIN
#
gtar4: movl 4*teval(r10),r10# load value
cmpl (r10),$b$trt # loop till value found
beqlu gtar4
movl r10,r8 # copy value
movl cnvtp,r10 # restore teblk pointer
#page
#
# GTARR (CONTINUED)
#
# NOW CHECK FOR NULL AND TEST CASES
#
cmpl r8,$nulls # loop back to ignore null value
beqlu gtar3
tstl r9 # jump if second pass
bnequ gtar5
incl r7 # for the first pass, bump count
jmp gtar3 # and loop back for next teblk
#
# HERE IN SECOND PASS
#
gtar5: movl 4*tesub(r10),(r9)+ # store subscript name
movl r8,(r9)+ # store value in arblk
jmp gtar3 # loop back for next teblk
#
# HERE AFTER SCANNING TEBLKS ON ONE CHAIN
#
gtar6: cmpl r6,(sp) # loop back if more buckets to go
bnequ gtar2
tstl r9 # else jump if second pass
bnequ gtar7
#
# HERE AFTER COUNTING NON-NULL ELEMENTS
#
tstl r7 # fail if no non-null elements
bnequ 0f
jmp gtar9
0:
movl r7,r6 # else copy count
addl2 r7,r6 # double (two words/element)
addl2 $arvl2,r6 # add space for standard fields
moval 0[r6],r6 # convert length to bytes
cmpl r6,mxlen # fail if too long for array
blssu 0f
jmp gtar9
0:
jsb alloc # else allocate space for arblk
movl $b$art,(r9) # store type word
clrl 4*idval(r9) # zero id for the moment
movl r6,4*arlen(r9) # store length
movl $num02,4*arndm(r9) # set dimensions = 2
movl intv1,r5 # get integer one
movl r5,4*arlbd(r9) # store as lbd 1
movl r5,4*arlb2(r9) # store as lbd 2
movl intv2,r5 # load integer two
movl r5,4*ardm2(r9) # store as dim 2
movl r7,r5 # get element count as integer
movl r5,4*ardim(r9) # store as dim 1
clrl 4*arpr2(r9) # zero prototype field for now
movl $4*arpr2,4*arofs(r9) # set offset field (signal pass 2)
movl r9,r7 # save arblk pointer
addl2 $4*arvl2,r9 # point to first element location
jmp gtar1 # jump back to fill in elements
#page
#
# GTARR (CONTINUED)
#
# HERE AFTER FILLING IN ELEMENT VALUES
#
gtar7: movl r7,r9 # restore arblk pointer
movl r7,(sp) # 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.
#
movl 4*ardim(r9),r5 # get number of elements (nn)
mull2 intvh,r5 # multiply by 100
addl2 intv2,r5 # add 2 (nn02)
jsb icbld # build integer
movl r9,-(sp) # store ptr for gtstg
jsb gtstg # convert to string
.long invalid$ # convert fail is impossible
movl r9,r10 # copy string pointer
movl (sp)+,r9 # reload arblk pointer
movl r10,4*arpr2(r9) # store prototype ptr (nn02)
subl2 $num02,r6 # adjust length to point to zero
movab cfp$f(r10)[r6],r10 # point to zero
movl $ch$cm,r7 # load a comma
movb r7,(r10) # store a comma over the zero
#csc r10 # complete store characters
#
# NORMAL RETURN
#
gtar8: addl2 $4*1,(sp) # return to caller
rsb
#
# NON-CONVERSION RETURN
#
gtar9: movl (sp)+,r9 # restore stack for conv err (sgd02)
#
# MERGE TO TAKE CONVERT ERROR WHEN STACK ADJUSTED OK
#
gta9a: movl (sp)+,r11 # return
jmp *(r11)+
#enp # procedure gtarr
#page
#
# 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 # entry point
cmpl (r9),$b$cds # jump if already code
beqlu gtcd1
cmpl (r9),$b$cdc # jump if already code
beqlu gtcd1
#
# HERE WE MUST GENERATE A CDBLK BY COMPILATION
#
movl r9,-(sp) # stack argument for gtstg
jsb gtstg # convert argument to string
.long gtcd2 # jump if non-convertible
movl flptr,gtcef # save fail ptr in case of error
movl r$cod,r$gtc # also save code ptr
movl r9,r$cim # else set image pointer
movl r6,scnil # set image length
clrl scnpt # set scan pointer
movl $stgxc,stage # set stage for execute compile
movl cmpsn,lstsn # in case listr called
jsb cmpil # compile string
movl $stgxt,stage # reset stage for execute time
clrl r$cim # clear image
#
# MERGE HERE IF NO CONVERT REQUIRED
#
gtcd1: addl2 $4*1,(sp) # give normal gtcod return
rsb
#
# HERE IF UNCONVERTIBLE
#
gtcd2: movl (sp)+,r11 # give error return
jmp *(r11)+
#enp # end procedure gtcod
#page
#
# 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 # entry point
cmpl (r9),$b$e$$ # jump if already an expression
bgtru 0f
jmp gtex1
0:
movl r9,-(sp) # store argument for gtstg
jsb gtstg # convert argument to string
.long 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.
#
movl r9,r10 # copy input string pointer (reg06)
movab cfp$f(r10)[r6],r10 # point one past the string end (reg06)
movzbl -(r10),r10 # fetch the last character (reg06)
cmpl r10,$ch$cl # error if it is a semicolon (reg06)
beqlu gtex2
cmpl r10,$ch$sm # or if it is a colon (reg06)
beqlu gtex2
#
# HERE WE CONVERT A STRING BY COMPILATION
#
movl r9,r$cim # set input image pointer
clrl scnpt # set scan pointer
movl r6,scnil # set input image length
clrl r7 # set code for normal scan
movl flptr,gtcef # save fail ptr in case of error
movl r$cod,r$gtc # also save code ptr
movl $stgev,stage # adjust stage for compile
movl $t$uok,scntp # indicate unary operator acceptable
jsb expan # build tree for expression
clrl scnrs # reset rescan flag
cmpl scnpt,scnil # error if not end of image
bnequ gtex2
clrl r7 # set ok value for cdgex call
movl r9,r10 # copy tree pointer
jsb cdgex # build expression block
clrl r$cim # clear pointer
movl $stgxt,stage # restore stage for execute time
#
# MERGE HERE IF NO CONVERSION REQUIRED
#
gtex1: addl2 $4*1,(sp) # return to gtexp caller
rsb
#
# HERE IF UNCONVERTIBLE
#
gtex2: movl (sp)+,r11 # take error exit
jmp *(r11)+
#enp # end procedure gtexp
#page
#
# 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 # entry point
cmpl (r9),$b$icl # jump if already an integer
beqlu gtin2
movl r6,gtina # else save wa
movl r7,gtinb # save wb
jsb gtnum # convert to numeric
.long gtin3 # jump if unconvertible
cmpl r6,$b$icl # jump if integer
beqlu gtin1
#
# HERE WE CONVERT A REAL TO INTEGER
#
movf 4*rcval(r9),r2 # load real value
cvtfl r2,r5 # convert to integer (err if ovflow)
bvs gtin3
jsb icbld # if ok build icblk
#
# HERE AFTER SUCCESSFUL CONVERSION TO INTEGER
#
gtin1: movl gtina,r6 # restore wa
movl gtinb,r7 # restore wb
#
# COMMON EXIT POINT
#
gtin2: addl2 $4*1,(sp) # return to gtint caller
rsb
#
# HERE ON CONVERSION ERROR
#
gtin3: movl (sp)+,r11 # take convert error exit
jmp *(r11)+
#enp # end procedure gtint
#page
#
# 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 # entry point
movl (r9),r6 # load first word of block
cmpl r6,$b$icl # jump if integer (no conversion)
bnequ 0f
jmp gtn34
0:
cmpl r6,$b$rcl # jump if real (no conversion)
bnequ 0f
jmp gtn34
0:
#
# AT THIS POINT THE ONLY POSSIBILITY IS TO CONVERT A STRING
# TO AN INTEGER OR REAL AS APPROPRIATE.
#
movl r9,-(sp) # stack argument in case convert err
movl r9,-(sp) # stack argument for gtstg
jsb gtstg # convert argument to string
.long gtn36 # jump if unconvertible
#
# INITIALIZE NUMERIC CONVERSION
#
movl intv0,r5 # initialize integer result to zero
tstl r6 # jump to exit with zero if null
bnequ 0f
jmp gtn32
0:
# set bct counter for following loops
clrl gtnnf # tentatively indicate result +
movl r5,gtnex # initialise exponent to zero
clrl gtnsc # zero scale in case real
clrl gtndf # reset flag for dec point found
clrl gtnrd # reset flag for digits found
movf reav0,r2 # zero real accum in case real
movab cfp$f(r9),r9 # point to argument characters
#
# MERGE BACK HERE AFTER IGNORING LEADING BLANK
#
gtn01: movzbl (r9)+,r7 # load first character
cmpl r7,$ch$d0 # jump if not digit
blssu gtn02
cmpl r7,$ch$d9 # jump if first char is a digit
blequ gtn06
#page
#
# GTNUM (CONTINUED)
#
# HERE IF FIRST DIGIT IS NON-DIGIT
#
gtn02: cmpl r7,$ch$bl # jump if non-blank
bnequ gtn03
gtna2: sobgtr r6,gtn01 # else decr count and loop back
jmp gtn07 # jump to return zero if all blanks
#
# HERE FOR FIRST CHARACTER NON-BLANK, NON-DIGIT
#
gtn03: cmpl r7,$ch$pl # jump if plus sign
beqlu gtn04
cmpl r7,$ch$ht # horizontal tab equiv to blank
beqlu gtna2
cmpl r7,$ch$mn # jump if not minus (may be real)
beqlu 0f
jmp gtn12
0:
movl sp,gtnnf # if minus sign, set negative flag
#
# MERGE HERE AFTER PROCESSING SIGN
#
gtn04: sobgtr r6,gtn05 # jump if chars left
jmp gtn36 # else error
#
# LOOP TO FETCH CHARACTERS OF AN INTEGER
#
gtn05: movzbl (r9)+,r7 # load next character
cmpl r7,$ch$d0 # jump if not a digit
blssu gtn08
cmpl r7,$ch$d9 # jump if not a digit
bgtru gtn08
#
# MERGE HERE FOR FIRST DIGIT
#
gtn06: movl r5,gtnsi # save current value
mull2 $10,r5 # current*10-(new dig) jump if ovflow
bvc 0f
jmp gtn35
0: bicl2 $0xfffffff0,r7
subl2 r7,r5
bvc 1f
jmp gtn35
1:
movl sp,gtnrd # set digit read flag
sobgtr r6,gtn05 # else loop back if more chars
#
# HERE TO EXIT WITH CONVERTED INTEGER VALUE
#
gtn07: tstl gtnnf # jump if negative (all set)
beqlu 0f
jmp gtn32
0:
mnegl r5,r5 # else negate
bvs 0f
jmp gtn32
0:
jmp gtn36 # else signal error
#page
#
# GTNUM (CONTINUED)
#
# HERE FOR A NON-DIGIT CHARACTER WHILE ATTEMPTING TO
# CONVERT AN INTEGER, CHECK FOR TRAILING BLANKS OR REAL.
#
gtn08: cmpl r7,$ch$bl # jump if a blank
beqlu gtna9
cmpl r7,$ch$ht # jump if horizontal tab
beqlu gtna9
cvtlf r5,r2 # else convert integer to real
mnegf r2,r2 # negate to get positive value
jmp gtn12 # jump to try for real
#
# HERE WE SCAN OUT BLANKS TO END OF STRING
#
gtn09: movzbl (r9)+,r7 # get next char
cmpl r7,$ch$ht # jump if horizontal tab
beqlu gtna9
cmpl r7,$ch$bl # error if non-blank
beqlu 0f
jmp gtn36
0:
gtna9: sobgtr r6,gtn09 # loop back if more chars to check
jmp gtn07 # return integer if all blanks
#
# LOOP TO COLLECT MANTISSA OF REAL
#
gtn10: movzbl (r9)+,r7 # load next character
cmpl r7,$ch$d0 # jump if non-numeric
bgequ 0f
jmp gtn12
0:
cmpl r7,$ch$d9 # jump if non-numeric
blequ 0f
jmp gtn12
0:
#
# MERGE HERE TO COLLECT FIRST REAL DIGIT
#
gtn11: subl2 $ch$d0,r7 # convert digit to number
mulf2 reavt,r2 # multiply real by 10.0
bvc 0f
jmp gtn36
0:
movf r2,gtnsr # save result
movl r7,r5 # get new digit as integer
cvtlf r5,r2 # convert new digit to real
addf2 gtnsr,r2 # add to get new total
addl2 gtndf,gtnsc # increment scale if after dec point
movl sp,gtnrd # set digit found flag
sobgtr r6,gtn10 # loop back if more chars
jmp gtn22 # else jump to scale
#page
#
# GTNUM (CONTINUED)
#
# HERE IF NON-DIGIT FOUND WHILE COLLECTING A REAL
#
gtn12: cmpl r7,$ch$dt # jump if not dec point
bnequ gtn13
tstl gtndf # if dec point, error if one already
beqlu 0f
jmp gtn36
0:
movl $num01,gtndf # else set flag for dec point
sobgtr r6,gtn10 # loop back if more chars
jmp gtn22 # else jump to scale
#
# HERE IF NOT DECIMAL POINT
#
gtn13: cmpl r7,$ch$le # jump if e for exponent
beqlu gtn15
cmpl r7,$ch$ld # jump if d for exponent
beqlu gtn15
cmpl r7,$ch$$e # jump if e for exponent
beqlu gtn15
cmpl r7,$ch$$d # jump if d for exponent
beqlu gtn15
#
# HERE CHECK FOR TRAILING BLANKS
#
gtn14: cmpl r7,$ch$bl # jump if blank
beqlu gtnb4
cmpl r7,$ch$ht # jump if horizontal tab
beqlu gtnb4
jmp gtn36 # error if non-blank
#
gtnb4: movzbl (r9)+,r7 # get next character
sobgtr r6,gtn14 # loop back to check if more
jmp gtn22 # else jump to scale
#
# HERE TO READ AND PROCESS AN EXPONENT
#
gtn15: clrl gtnes # set exponent sign positive
movl intv0,r5 # initialize exponent to zero
movl sp,gtndf # reset no dec point indication
sobgtr r6,gtn16 # jump skipping past e or d
jmp gtn36 # error if null exponent
#
# CHECK FOR EXPONENT SIGN
#
gtn16: movzbl (r9)+,r7 # load first exponent character
cmpl r7,$ch$pl # jump if plus sign
beqlu gtn17
cmpl r7,$ch$mn # else jump if not minus sign
bnequ gtn19
movl sp,gtnes # set sign negative if minus sign
#
# MERGE HERE AFTER PROCESSING EXPONENT SIGN
#
gtn17: sobgtr r6,gtn18 # jump if chars left
jmp gtn36 # else error
#
# LOOP TO CONVERT EXPONENT DIGITS
#
gtn18: movzbl (r9)+,r7 # load next character
#page
#
# GTNUM (CONTINUED)
#
# MERGE HERE FOR FIRST EXPONENT DIGIT
#
gtn19: cmpl r7,$ch$d0 # jump if not digit
blssu gtn20
cmpl r7,$ch$d9 # jump if not digit
bgtru gtn20
mull2 $10,r5 # else current*10, subtract new digit
bvc 0f
jmp gtn36
0: bicl2 $0xfffffff0,r7
subl2 r7,r5
bvc 1f
jmp gtn36
1:
sobgtr r6,gtn18 # loop back if more chars
jmp gtn21 # jump if exponent field is exhausted
#
# HERE TO CHECK FOR TRAILING BLANKS AFTER EXPONENT
#
gtn20: cmpl r7,$ch$bl # jump if blank
beqlu gtnc0
cmpl r7,$ch$ht # jump if horizontal tab
beqlu gtnc0
jmp gtn36 # error if non-blank
#
gtnc0: movzbl (r9)+,r7 # get next character
sobgtr r6,gtn20 # loop back till all blanks scanned
#
# MERGE HERE AFTER COLLECTING EXPONENT
#
gtn21: movl r5,gtnex # save collected exponent
tstl gtnes # jump if it was negative
bnequ gtn22
mnegl r5,r5 # else complement
bvc 0f
jmp gtn36
0:
movl r5,gtnex # and store positive exponent
#
# MERGE HERE WITH EXPONENT (0 IF NONE GIVEN)
#
gtn22: tstl gtnrd # error if not digits collected
bnequ 0f
jmp gtn36
0:
tstl gtndf # error if no exponent or dec point
bnequ 0f
jmp gtn36
0:
movl gtnsc,r5 # else load scale as integer
subl2 gtnex,r5 # subtract exponent
bvc 0f
jmp gtn36
0:
tstl r5 # jump if we must scale up
blss gtn26
#
# HERE WE HAVE A NEGATIVE EXPONENT, SO SCALE DOWN
#
movl r5,r6 # load scale factor, err if ovflow
bgeq 0f
jmp gtn36
0:
#
# LOOP TO SCALE DOWN IN STEPS OF 10**10
#
gtn23: cmpl r6,$num10 # jump if 10 or less to go
blequ gtn24
divf2 reatt,r2 # else divide by 10**10
subl2 $num10,r6 # decrement scale
jmp gtn23 # and loop back
#page
#
# GTNUM (CONTINUED)
#
# HERE SCALE REST OF WAY FROM POWERS OF TEN TABLE
#
gtn24: tstl r6 # jump if scaled
beqlu gtn30
movl $cfp$r,r7 # else get indexing factor
movl $reav1,r9 # point to powers of ten table
moval 0[r6],r6 # convert remaining scale to byte ofs
#
# LOOP TO POINT TO POWERS OF TEN TABLE ENTRY
#
gtn25: addl2 r6,r9 # bump pointer
sobgtr r7,gtn25 # once for each value word
divf2 (r9),r2 # scale down as required
jmp gtn30 # and jump
#
# COME HERE TO SCALE RESULT UP (POSITIVE EXPONENT)
#
gtn26: mnegl r5,r5 # get absolute value of exponent
bvc 0f
jmp gtn36
0:
movl r5,r6 # acquire scale, error if ovflow
bgeq 0f
jmp gtn36
0:
#
# LOOP TO SCALE UP IN STEPS OF 10**10
#
gtn27: cmpl r6,$num10 # jump if 10 or less to go
blequ gtn28
mulf2 reatt,r2 # else multiply by 10**10
bvc 0f
jmp gtn36
0:
subl2 $num10,r6 # else decrement scale
jmp gtn27 # and loop back
#
# HERE TO SCALE UP REST OF WAY WITH TABLE
#
gtn28: tstl r6 # jump if scaled
beqlu gtn30
movl $cfp$r,r7 # else get indexing factor
movl $reav1,r9 # point to powers of ten table
moval 0[r6],r6 # convert remaining scale to byte ofs
#
# LOOP TO POINT TO PROPER ENTRY IN POWERS OF TEN TABLE
#
gtn29: addl2 r6,r9 # bump pointer
sobgtr r7,gtn29 # once for each word in value
mulf2 (r9),r2 # scale up
bvc 0f
jmp gtn36
0:
#page
#
# GTNUM (CONTINUED)
#
# HERE WITH REAL VALUE SCALED AND READY EXCEPT FOR SIGN
#
gtn30: tstl gtnnf # jump if positive
beqlu gtn31
mnegf r2,r2 # else negate
#
# HERE WITH PROPERLY SIGNED REAL VALUE IN (RA)
#
gtn31: jsb rcbld # build real block
jmp gtn33 # merge to exit
#
# HERE WITH PROPERLY SIGNED INTEGER VALUE IN (IA)
#
gtn32: jsb icbld # build icblk
#
# REAL MERGES HERE
#
gtn33: movl (r9),r6 # load first word of result block
addl2 $4,sp # pop argument off stack
#
# COMMON EXIT POINT
#
gtn34: addl2 $4*1,(sp) # return to gtnum caller
rsb
#
# COME HERE IF OVERFLOW OCCURS DURING COLLECTION OF INTEGER
#
gtn35: movl gtnsi,r5 # reload integer so far
cvtlf r5,r2 # convert to real
mnegf r2,r2 # make value positive
jmp gtn11 # merge with real circuit
#
# HERE FOR UNCONVERTIBLE TO STRING OR CONVERSION ERROR
#
gtn36: movl (sp)+,r9 # reload original argument
movl (sp)+,r11 # take convert-error exit
jmp *(r11)+
#enp # end procedure gtnum
#page
#
# 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 # entry point
cmpl (r9),$b$nml # jump if not name
bnequ gnv02
movl 4*nmbas(r9),r9 # else load name base if name
cmpl r9,state # skip if vrblk (in static region)
bgtru 0f
jmp gnv07
0:
#
# COMMON ERROR EXIT
#
gnv01: movl (sp)+,r11 # take convert-error exit
jmp *(r11)+
#
# HERE IF NOT NAME
#
gnv02: movl r6,gnvsa # save wa
movl r7,gnvsb # save wb
movl r9,-(sp) # stack argument for gtstg
jsb gtstg # convert argument to string
.long gnv01 # jump if conversion error
tstl r6 # null string is an error
beqlu gnv01
jsb flstg # fold lower case to upper case
movl r10,-(sp) # save xl
movl r9,-(sp) # stack string ptr for later
movl r9,r7 # copy string pointer
addl2 $4*schar,r7 # point to characters of string
movl r7,gnvst # save pointer to characters
movl r6,r7 # copy length
movab 3+(4*0)(r7),r7 # get number of words in name
ashl $-2,r7,r7
movl r7,gnvnw # save for later
jsb hashs # compute hash index for string
ashq $-32,r4,r4 # compute hash offset by taking mod
ediv hshnb,r4,r11,r5
movl r5,r8 # get as offset
moval 0[r8],r8 # convert offset to bytes
addl2 hshtb,r8 # point to proper hash chain
subl2 $4*vrnxt,r8 # subtract offset to merge into loop
#page
#
# GTNVR (CONTINUED)
#
# LOOP TO SEARCH HASH CHAIN
#
gnv03: movl r8,r10 # copy hash chain pointer
movl 4*vrnxt(r10),r10# point to next vrblk on chain
beqlu gnv08 # jump if end of chain
movl r10,r8 # save pointer to this vrblk
tstl 4*vrlen(r10) # jump if not system variable
bnequ gnv04
movl 4*vrsvp(r10),r10# else point to svblk
subl2 $4*vrsof,r10 # adjust offset for merge
#
# MERGE HERE WITH STRING PTR (LIKE VRBLK) IN XL
#
gnv04: cmpl r6,4*vrlen(r10) # back for next vrblk if lengths ne
bnequ gnv03
addl2 $4*vrchs,r10 # else point to chars of chain entry
movl gnvnw,r7 # get word counter to control loop
movl gnvst,r9 # point to chars of new name
#
# LOOP TO COMPARE CHARACTERS OF THE TWO NAMES
#
gnv05: cmpl (r9),(r10) # jump if no match for next vrblk
bnequ gnv03
addl2 $4,r9 # bump new name pointer
addl2 $4,r10 # bump vrblk in chain name pointer
sobgtr r7,gnv05 # else loop till all compared
movl r8,r9 # we have found a match, get vrblk
#
# EXIT POINT AFTER FINDING VRBLK OR BUILDING NEW ONE
#
gnv06: movl gnvsa,r6 # restore wa
movl gnvsb,r7 # restore wb
addl2 $4,sp # pop string pointer
movl (sp)+,r10 # restore xl
#
# COMMON EXIT POINT
#
gnv07: addl2 $4*1,(sp) # return to gtnvr caller
rsb
#
# NOT FOUND, PREPARE TO SEARCH SYSTEM VARIABLE TABLE
#
gnv08: clrl r9 # clear garbage xr pointer
movl r8,gnvhe # save ptr to end of hash chain
cmpl r6,$num09 # cannot be system var if length gt 9
bgtru gnv14
movl r6,r10 # else copy length
moval 0[r10],r10 # convert to byte offset
movl l^vsrch(r10),r10# point to first svblk of this length
#page
#
# GTNVR (CONTINUED)
#
# LOOP TO SEARCH ENTRIES IN STANDARD VARIABLE TABLE
#
gnv09: movl r10,gnvsp # save table pointer
movl (r10)+,r8 # load svbit bit string
movl (r10)+,r7 # load length from table entry
cmpl r6,r7 # jump if end of right length entires
bnequ gnv14
movl gnvnw,r7 # get word counter to control loop
movl gnvst,r9 # point to chars of new name
#
# LOOP TO CHECK FOR MATCHING NAMES
#
gnv10: cmpl (r9),(r10) # jump if name mismatch
bnequ gnv11
addl2 $4,r9 # else bump new name pointer
addl2 $4,r10 # bump svblk pointer
sobgtr r7,gnv10 # else loop until all checked
#
# HERE WE HAVE A MATCH IN THE STANDARD VARIABLE TABLE
#
clrl r8 # set vrlen value zero
movl $4*vrsi$,r6 # set standard size
jmp gnv15 # jump to build vrblk
#
# HERE IF NO MATCH WITH TABLE ENTRY IN SVBLKS TABLE
#
gnv11: addl2 $4,r10 # bump past word of chars
sobgtr r7,gnv11 # loop back if more to go
ashl $-svnbt,r8,r8 # remove uninteresting bits
#
# LOOP TO BUMP TABLE PTR FOR EACH FLAGGED WORD
#
gnv12: movl bits1,r7 # load bit to test
mcoml r8,r11 # test for word present
bicl2 r11,r7
beqlu gnv13 # jump if not present
addl2 $4,r10 # else bump table pointer
#
# HERE AFTER DEALING WITH ONE WORD (ONE BIT)
#
gnv13: ashl $-1,r8,r8 # remove bit already processed
tstl r8 # loop back if more bits to test
bnequ gnv12
jmp gnv09 # else loop back for next svblk
#
# HERE IF NOT SYSTEM VARIABLE
#
gnv14: movl r6,r8 # copy vrlen value
movl $vrchs,r6 # load standard size -chars
addl2 gnvnw,r6 # adjust for chars of name
moval 0[r6],r6 # convert length to bytes
#page
#
# GTNVR (CONTINUED)
#
# MERGE HERE TO BUILD VRBLK
#
gnv15: jsb alost # allocate space for vrblk (static)
movl r9,r7 # save vrblk pointer
movl $stnvr,r10 # point to model variable block
movl $4*vrlen,r6 # set length of standard fields
jsb sbmvw # set initial fields of new block
movl gnvhe,r10 # load pointer to end of hash chain
movl r7,4*vrnxt(r10) # add new block to end of chain
movl r8,(r9)+ # set vrlen field, bump ptr
movl gnvnw,r6 # get length in words
moval 0[r6],r6 # convert to length in bytes
tstl r8 # jump if system variable
beqlu gnv16
#
# HERE FOR NON-SYSTEM VARIABLE -- SET CHARS OF NAME
#
movl (sp),r10 # point back to string name
addl2 $4*schar,r10 # point to chars of name
jsb sbmvw # move characters into place
movl r7,r9 # restore vrblk pointer
jmp gnv06 # jump back to exit
#
# HERE FOR SYSTEM VARIABLE CASE TO FILL IN FIELDS WHERE
# NECESSARY FROM THE FIELDS PRESENT IN THE SVBLK.
#
gnv16: movl gnvsp,r10 # load pointer to svblk
movl r10,(r9) # set svblk ptr in vrblk
movl r7,r9 # restore vrblk pointer
movl 4*svbit(r10),r7 # load bit indicators
addl2 $4*svchs,r10 # point to characters of name
addl2 r6,r10 # point past characters
#
# SKIP PAST KEYWORD NUMBER (SVKNM) IF PRESENT
#
movl btknm,r8 # load test bit
mcoml r7,r11 # and to test
bicl2 r11,r8
beqlu gnv17 # jump if no keyword number
addl2 $4,r10 # else bump pointer
#page
#
# GTNVR (CONTINUED)
#
# HERE TEST FOR FUNCTION (SVFNC AND SVNAR)
#
gnv17: movl btfnc,r8 # get test bit
mcoml r7,r11 # and to test
bicl2 r11,r8
beqlu gnv18 # skip if no system function
movl r10,4*vrfnc(r9) # else point vrfnc to svfnc field
addl2 $4*num02,r10 # and bump past svfnc, svnar fields
#
# NOW TEST FOR LABEL (SVLBL)
#
gnv18: movl btlbl,r8 # get test bit
mcoml r7,r11 # and to test
bicl2 r11,r8
beqlu gnv19 # jump if bit is off (no system labl)
movl r10,4*vrlbl(r9) # else point vrlbl to svlbl field
addl2 $4,r10 # bump past svlbl field
#
# NOW TEST FOR VALUE (SVVAL)
#
gnv19: movl btval,r8 # load test bit
mcoml r7,r11 # and to test
bicl2 r11,r8
bnequ 0f # all done if no value
jmp gnv06
0:
movl (r10),4*vrval(r9)# else set initial value
movl $b$vre,4*vrsto(r9) # set error store access
jmp gnv06 # merge back to exit to caller
#enp # end procedure gtnvr
#page
#
# 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 # entry point
cmpl (r9),$p$aaa # jump if pattern already
bgequ gtpt5
#
# HERE IF NOT PATTERN, TRY FOR STRING
#
movl r7,gtpsb # save wb
movl r9,-(sp) # stack argument for gtstg
jsb gtstg # convert argument to string
.long gtpt2 # jump if impossible
#
# HERE WE HAVE A STRING
#
tstl r6 # jump if non-null
bnequ gtpt1
#
# HERE FOR NULL STRING. GENERATE POINTER TO NULL PATTERN.
#
movl $ndnth,r9 # point to nothen node
jmp gtpt4 # jump to exit
#page
#
# GTPAT (CONTINUED)
#
# HERE FOR NON-NULL STRING
#
gtpt1: movl $p$str,r7 # load pcode for multi-char string
cmpl r6,$num01 # jump if multi-char string
bnequ gtpt3
#
# HERE FOR ONE CHARACTER STRING, SHARE ONE CHARACTER ANY
#
movab cfp$f(r9),r9 # point to character
movzbl (r9),r6 # load character
movl r6,r9 # set as parm1
movl $p$ans,r7 # point to pcode for 1-char any
jmp gtpt3 # jump to build node
#
# HERE IF ARGUMENT IS NOT CONVERTIBLE TO STRING
#
gtpt2: movl $p$exa,r7 # set pcode for expression in case
cmpl (r9),$b$e$$ # jump to build node if expression
blequ gtpt3
#
# HERE WE HAVE AN ERROR (CONVERSION IMPOSSIBLE)
#
movl (sp)+,r11 # take convert error exit
jmp *(r11)+
#
# MERGE HERE TO BUILD NODE FOR STRING OR EXPRESSION
#
gtpt3: jsb pbild # call routine to build pattern node
#
# COMMON EXIT AFTER SUCCESSFUL CONVERSION
#
gtpt4: movl gtpsb,r7 # restore wb
#
# MERGE HERE TO EXIT OF NO CONVERSION REQUIRED
#
gtpt5: addl2 $4*1,(sp) # return to gtpat caller
rsb
#enp # end procedure gtpat
#page
#
# 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 # entry point
movl (r9),r6 # get first word of block
cmpl r6,$b$rcl # jump if real
beqlu gtre2
jsb gtnum # else convert argument to numeric
.long gtre3 # jump if unconvertible
cmpl r6,$b$rcl # jump if real was returned
beqlu gtre2
#
# HERE FOR CASE OF AN INTEGER TO CONVERT TO REAL
#
gtre1: movl 4*icval(r9),r5 # load integer
cvtlf r5,r2 # convert to real
jsb rcbld # build rcblk
#
# EXIT WITH REAL
#
gtre2: addl2 $4*1,(sp) # return to gtrea caller
rsb
#
# HERE ON CONVERSION ERROR
#
gtre3: movl (sp)+,r11 # take convert error exit
jmp *(r11)+
#enp # end procedure gtrea
#page
#
# 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)
#
.data 1
gtsmi_s: .long 0
.text 0
gtsmi: movl (sp)+,gtsmi_s # entry point
movl (sp)+,r9 # load argument
cmpl (r9),$b$icl # skip if already an integer
beqlu gtsm1
#
# HERE IF NOT AN INTEGER
#
jsb gtint # convert argument to integer
.long gtsm2 # jump if convert is impossible
#
# MERGE HERE WITH INTEGER
#
gtsm1: movl 4*icval(r9),r5 # load integer value
movl r5,r8 # move as one word, jump if ovflow
bgeq 0f
jmp gtsm3
0:
cmpl r8,mxlen # or if too small
bgtru gtsm3
movl r8,r9 # copy result to xr
addl3 $4*2,gtsmi_s,r11 # return to gtsmi caller
jmp (r11)
#
# HERE IF UNCONVERTIBLE TO INTEGER
#
gtsm2: movl gtsmi_s,r11 # take non-integer error exit
jmp *(r11)+
#
# HERE IF OUT OF RANGE
#
gtsm3: addl3 $4*1,gtsmi_s,r11 # take out-of-range error exit
jmp *(r11)+
#enp # end procedure gtsmi
#page
#
# 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)
#
.data 1
gtstg_s: .long 0
.text 0
gtstg: movl (sp)+,gtstg_s # entry point
movl (sp)+,r9 # load argument, pop stack
cmpl (r9),$b$scl # jump if already a string
bnequ 0f
jmp gts30
0:
#
# HERE IF NOT A STRING ALREADY
#
gts01: movl r9,-(sp) # restack argument in case error
movl r10,-(sp) # save xl
movl r7,gtsvb # save wb
movl r8,gtsvc # save wc
movl (r9),r6 # load first word of block
cmpl r6,$b$icl # jump to convert integer
beqlu gts05
cmpl r6,$b$rcl # jump to convert real
bnequ 0f
jmp gts10
0:
cmpl r6,$b$nml # jump to convert name
beqlu gts03
cmpl r6,$b$bct # jump to convert buffer
bnequ 0f
jmp gts32
0:
#
# HERE ON CONVERSION ERROR
#
gts02: movl (sp)+,r10 # restore xl
movl (sp)+,r9 # reload input argument
movl gtstg_s,r11 # take convert error exit
jmp *(r11)+
#page
#
# GTSTG (CONTINUED)
#
# HERE TO CONVERT A NAME (ONLY POSSIBLE IF NATURAL VAR)
#
gts03: movl 4*nmbas(r9),r10 # load name base
cmpl r10,state # error if not natural var (static)
bgequ gts02
addl2 $4*vrsof,r10 # else point to possible string name
movl 4*sclen(r10),r6 # load length
bnequ gts04 # jump if not system variable
movl 4*vrsvo(r10),r10# else point to svblk
movl 4*svlen(r10),r6 # and load name length
#
# MERGE HERE WITH STRING IN XR, LENGTH IN WA
#
gts04: clrl r7 # set offset to zero
jsb sbstr # use sbstr to copy string
jmp gts29 # jump to exit
#
# COME HERE TO CONVERT AN INTEGER
#
gts05: movl 4*icval(r9),r5 # load integer value
movl $num01,gtssf # set sign flag negative
tstl r5 # skip if integer is negative
blss gts06
mnegl r5,r5 # else negate integer
clrl gtssf # and reset negative flag
#page
#
# GTSTG (CONTINUED)
#
# HERE WITH SIGN FLAG SET AND SIGN FORCED NEGATIVE AS
# REQUIRED BY THE CVD INSTRUCTION.
#
gts06: movl gtswk,r9 # point to result work area
movl $nstmx,r7 # initialize counter to max length
movab cfp$f(r9)[r7],r9# prepare to store (right-left)
#
# LOOP TO CONVERT DIGITS INTO WORK AREA
#
gts07: ashq $-32,r4,r4 # convert one digit into wa
ediv $10,r4,r5,r6
mnegl r6,r6
bisb2 $0x30,r6
movb r6,-(r9) # store in work area
decl r7 # decrement counter
tstl r5 # loop if more digits to go
bneq gts07
#csc r9 # complete store characters
#
# MERGE HERE AFTER CONVERTING INTEGER OR REAL INTO WORK
# AREA. WB IS SET TO NSTMX - (NUMBER OF CHARS IN RESULT).
#
gts08: movl $nstmx,r6 # get max number of characters
subl2 r7,r6 # compute length of result
movl r6,r10 # remember length for move later on
addl2 gtssf,r6 # add one for negative sign if needed
jsb alocs # allocate string for result
movl r9,r8 # save result pointer for the moment
movab cfp$f(r9),r9 # point to chars of result block
tstl gtssf # skip if positive
beqlu gts09
movl $ch$mn,r6 # else load negative sign
movb r6,(r9)+ # and store it
#csc r9 # complete store characters
#
# HERE AFTER DEALING WITH SIGN
#
gts09: movl r10,r6 # recall length to move
movl gtswk,r10 # point to result work area
movab cfp$f(r10)[r7],r10 # point to first result character
jsb sbmvc # move chars to result string
movl r8,r9 # restore result pointer
jmp gts29 # jump to exit
#page
#
# GTSTG (CONTINUED)
#
# HERE TO CONVERT A REAL
#
gts10: movf 4*rcval(r9),r2 # load real
clrl gtssf # reset negative flag
tstf r2 # skip if zero
bneq 0f
jmp gts31
0:
tstf r2 # jump if real is positive
bgeq gts11
movl $num01,gtssf # else set negative flag
mnegf r2,r2 # and get absolute value of real
#
# NOW SCALE THE REAL TO THE RANGE (0.1 LE X LT 1.0)
#
gts11: movl intv0,r5 # initialize exponent to zero
#
# LOOP TO SCALE UP IN STEPS OF 10**10
#
gts12: movf r2,gtsrs # save real value
subf2 reap1,r2 # subtract 0.1 to compare
tstf r2 # jump if scale up not required
bgeq gts13
movf gtsrs,r2 # else reload value
mulf2 reatt,r2 # multiply by 10**10
subl2 intvt,r5 # decrement exponent by 10
jmp gts12 # loop back to test again
#
# TEST FOR SCALE DOWN REQUIRED
#
gts13: movf gtsrs,r2 # reload value
subf2 reav1,r2 # subtract 1.0
tstf r2 # jump if no scale down required
blss gts17
movf gtsrs,r2 # else reload value
#
# LOOP TO SCALE DOWN IN STEPS OF 10**10
#
gts14: subf2 reatt,r2 # subtract 10**10 to compare
tstf r2 # jump if large step not required
blss gts15
movf gtsrs,r2 # else restore value
divf2 reatt,r2 # divide by 10**10
movf r2,gtsrs # store new value
addl2 intvt,r5 # increment exponent by 10
jmp gts14 # loop back
#page
#
# GTSTG (CONTINUED)
#
# AT THIS POINT WE HAVE (1.0 LE X LT 10**10)
# COMPLETE SCALING WITH POWERS OF TEN TABLE
#
gts15: movl $reav1,r9 # point to powers of ten table
#
# LOOP TO LOCATE CORRECT ENTRY IN TABLE
#
gts16: movf gtsrs,r2 # reload value
addl2 intv1,r5 # increment exponent
addl2 $4*cfp$r,r9 # point to next entry in table
subf2 (r9),r2 # subtract it to compare
tstf r2 # loop till we find a larger entry
bgeq gts16
movf gtsrs,r2 # then reload the value
divf2 (r9),r2 # and complete scaling
movf r2,gtsrs # store value
#
# WE ARE NOW SCALED, SO ROUND BY ADDING 0.5 * 10**(-CFP$S)
#
gts17: movf gtsrs,r2 # get value again
addf2 gtsrn,r2 # add rounding factor
movf r2,gtsrs # store result
#
# THE ROUNDING OPERATION MAY HAVE PUSHED US UP PAST
# 1.0 AGAIN, SO CHECK ONE MORE TIME.
#
subf2 reav1,r2 # subtract 1.0 to compare
tstf r2 # skip if ok
blss gts18
addl2 intv1,r5 # else increment exponent
movf gtsrs,r2 # reload value
divf2 reavt,r2 # divide by 10.0 to rescale
jmp gts19 # jump to merge
#
# HERE IF ROUNDING DID NOT MUCK UP SCALING
#
gts18: movf gtsrs,r2 # reload rounded value
#page
#
# 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: movl $cfp$s,r10 # set num dec digits = cfp$s
movl $ch$mn,gtses # set exponent sign negative
tstl r5 # all set if exponent is negative
blss gts21
movl r5,r6 # else fetch exponent
cmpl r6,$cfp$s # skip if we can use special format
blequ gts20
movl r6,r5 # else restore exponent
mnegl r5,r5 # set negative for cvd
movl $ch$pl,gtses # set plus sign for exponent sign
jmp gts21 # jump to generate exponent
#
# HERE IF WE CAN USE THE FORMAT WITHOUT AN EXPONENT
#
gts20: subl2 r6,r10 # compute digits after decimal point
movl intv0,r5 # reset exponent to zero
#page
#
# 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: movl gtswk,r9 # point to work area
movl $nstmx,r7 # set character ctr to max length
movab cfp$f(r9)[r7],r9# prepare to store (right to left)
tstl r5 # skip exponent if it is zero
beql gts23
#
# LOOP TO GENERATE DIGITS OF EXPONENT
#
gts22: ashq $-32,r4,r4 # convert a digit into wa
ediv $10,r4,r5,r6
mnegl r6,r6
bisb2 $0x30,r6
movb r6,-(r9) # store in work area
decl r7 # decrement counter
tstl r5 # loop back if more digits to go
bneq gts22
#
# HERE GENERATE EXPONENT SIGN AND E
#
movl gtses,r6 # load exponent sign
movb r6,-(r9) # store in work area
movl $ch$le,r6 # get character letter e
movb r6,-(r9) # store in work area
subl2 $num02,r7 # decrement counter for sign and e
#
# HERE TO GENERATE THE FRACTION
#
gts23: mulf2 gtssc,r2 # convert real to integer (10**cfp$s)
cvtfl r2,r5 # get integer (overflow impossible)
mnegl r5,r5 # negate as required by cvd
#
# LOOP TO SUPPRESS TRAILING ZEROS
#
gts24: tstl r10 # jump if no digits left to do
beqlu gts27
ashq $-32,r4,r4 # else convert one digit
ediv $10,r4,r5,r6
mnegl r6,r6
bisb2 $0x30,r6
cmpl r6,$ch$d0 # jump if not a zero
bnequ gts26
decl r10 # decrement counter
jmp gts24 # loop back for next digit
#page
#
# GTSTG (CONTINUED)
#
# LOOP TO GENERATE DIGITS AFTER DECIMAL POINT
#
gts25: ashq $-32,r4,r4 # convert a digit into wa
ediv $10,r4,r5,r6
mnegl r6,r6
bisb2 $0x30,r6
#
# MERGE HERE FIRST TIME
#
gts26: movb r6,-(r9) # store digit
decl r7 # decrement counter
decl r10 # decrement counter
bnequ gts25 # loop back if more to go
#
# HERE GENERATE THE DECIMAL POINT
#
gts27: movl $ch$dt,r6 # load decimal point
movb r6,-(r9) # store in work area
decl r7 # decrement counter
#
# HERE GENERATE THE DIGITS BEFORE THE DECIMAL POINT
#
gts28: ashq $-32,r4,r4 # convert a digit into wa
ediv $10,r4,r5,r6
mnegl r6,r6
bisb2 $0x30,r6
movb r6,-(r9) # store in work area
decl r7 # decrement counter
tstl r5 # loop back if more to go
bneq gts28
#csc r9 # complete store characters
jmp gts08 # else jump back to exit
#
# EXIT POINT AFTER SUCCESSFUL CONVERSION
#
gts29: movl (sp)+,r10 # restore xl
addl2 $4,sp # pop argument
movl gtsvb,r7 # restore wb
movl gtsvc,r8 # restore wc
#
# MERGE HERE IF NO CONVERSION REQUIRED
#
gts30: movl 4*sclen(r9),r6 # load string length
addl3 $4*1,gtstg_s,r11 # return to caller
jmp (r11)
#
# HERE TO RETURN STRING FOR REAL ZERO
#
gts31: movl $scre0,r10 # point to string
movl $num02,r6 # 2 chars
clrl r7 # zero offset
jsb sbstr # copy string
jmp gts29 # return
#page
#
# HERE TO CONVERT A BUFFER BLOCK
#
gts32: movl r9,r10 # copy arg ptr
movl 4*bclen(r10),r6 # get size to allocate
beqlu gts33 # if null then return null
jsb alocs # allocate string frame
movl r9,r7 # save string ptr
movl 4*sclen(r9),r6 # get length to move
movab 3+(4*0)(r6),r6 # get as multiple of word size
bicl2 $3,r6
movl 4*bcbuf(r10),r10# point to bfblk
addl2 $4*scsi$,r9 # point to start of character area
addl2 $4*bfsi$,r10 # point to start of buffer chars
jsb sbmvw # copy words
movl r7,r9 # restore scblk ptr
jmp gts29 # exit with scblk
#
# HERE WHEN NULL BUFFER IS BEING CONVERTED
#
gts33: movl $nulls,r9 # point to null
jmp gts29 # exit with null
#enp # end procedure gtstg
#page
#
# 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 # entry point
cmpl (r9),$b$nml # jump if not a name
bnequ gtvr2
movl 4*nmofs(r9),r6 # else load name offset
movl 4*nmbas(r9),r10 # load name base
cmpl (r10),$b$evt # error if expression variable
beqlu gtvr1
cmpl (r10),$b$kvt # all ok if not keyword variable
bnequ gtvr3
#
# HERE ON CONVERSION ERROR
#
gtvr1: movl (sp)+,r11 # take convert error exit
jmp *(r11)+
#
# HERE IF NOT A NAME, TRY CONVERT TO NATURAL VARIABLE
#
gtvr2: movl r8,gtvrc # save wc
jsb gtnvr # locate vrblk if possible
.long gtvr1 # jump if convert error
movl r9,r10 # else copy vrblk name base
movl $4*vrval,r6 # and set offset
movl gtvrc,r8 # restore wc
#
# HERE FOR NAME OBTAINED
#
gtvr3: cmpl r10,state # all ok if not natural variable
bgequ gtvr4
cmpl 4*vrsto(r10),$b$vre # error if protected variable
beqlu gtvr1
#
# COMMON EXIT POINT
#
gtvr4: addl2 $4*1,(sp) # return to caller
rsb
#enp # end procedure gtvar
#page
#
# 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 # entry point
movl 4*sclen(r9),r8 # load string length in characters
movl r8,r7 # initialize with length
tstl r8 # jump if null string
beqlu hshs3
movab 3+(4*0)(r8),r8 # else get number of words of chars
ashl $-2,r8,r8
addl2 $4*schar,r9 # point to characters of string
cmpl r8,$e$hnw # use whole string if short
blequ hshs1
movl $e$hnw,r8 # else set to involve first e$hnw wds
#
# HERE WITH COUNT OF WORDS TO CHECK IN WC
#
hshs1: # set counter to control loop
#
# LOOP TO COMPUTE EXCLUSIVE OR
#
hshs2: xorl2 (r9)+,r7 # exclusive or next word of chars
sobgtr r8,hshs2 # loop till all processed
#
# MERGE HERE WITH EXCLUSIVE OR IN WB
#
hshs3: #zgb r7 # zeroise undefined bits
mcoml bitsm,r11 # ensure in range 0 to cfp$m
bicl2 r11,r7
movl r7,r5 # move result as integer
clrl r9 # clear garbage value in xr
rsb # return to hashs caller
#enp # end procedure hashs
#page
#
# 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 # entry point
movl r5,r9 # copy small integers
bgeq 0f
jmp icbl1
0:
cmpl r9,$num02 # jump if 0,1 or 2
blequ icbl3
#
# CONSTRUCT ICBLK
#
icbl1: movl dnamp,r9 # load pointer to next available loc
addl2 $4*icsi$,r9 # point past new icblk
cmpl r9,dname # jump if there is room
blequ icbl2
movl $4*icsi$,r6 # else load length of icblk
jsb alloc # use standard allocator to get block
addl2 r6,r9 # point past block to merge
#
# MERGE HERE WITH XR POINTING PAST THE BLOCK OBTAINED
#
icbl2: movl r9,dnamp # set new pointer
subl2 $4*icsi$,r9 # point back to start of block
movl $b$icl,(r9) # store type word
movl r5,4*icval(r9) # store integer value in icblk
rsb # return to icbld caller
#
# OPTIMISE BY NOT BUILDING ICBLKS FOR SMALL INTEGERS
#
icbl3: moval 0[r9],r9 # convert integer to offset
movl l^intab(r9),r9 # point to pre-built icblk
rsb # return
#enp # end procedure icbld
#page
#
# 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 # entry point
cmpl r9,r10 # jump if same pointer (ident)
bnequ 0f
jmp iden7
0:
movl (r9),r8 # else load arg 1 type word
cmpl r8,(r10) # differ if arg 2 type word differ
bnequ iden1
cmpl r8,$b$scl # jump if strings
beqlu iden2
cmpl r8,$b$icl # jump if integers
beqlu iden4
cmpl r8,$b$rcl # jump if reals
beqlu iden5
cmpl r8,$b$nml # jump if names
beqlu iden6
#
# FOR ALL OTHER DATATYPES, MUST BE DIFFER IF XR NE XL
#
# MERGE HERE FOR DIFFER
#
iden1: addl2 $4*1,(sp) # take differ exit
rsb
#
# HERE FOR STRINGS, IDENT ONLY IF LENGTHS AND CHARS SAME
#
iden2: movl 4*sclen(r9),r8 # load arg 1 length
cmpl r8,4*sclen(r10) # differ if lengths differ
bnequ iden1
movab 3+(4*0)(r8),r8 # get number of words in strings
ashl $-2,r8,r8
addl2 $4*schar,r9 # point to chars of arg 1
addl2 $4*schar,r10 # point to chars of arg 2
# 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: cmpl (r9),(r10) # differ if chars do not match
bnequ iden8
addl2 $4,r9 # else bump arg one pointer
addl2 $4,r10 # bump arg two pointer
sobgtr r8,iden3 # loop back till all checked
#page
#
# IDENT (CONTINUED)
#
# HERE TO EXIT FOR CASE OF TWO IDENT STRINGS
#
clrl r10 # clear garbage value in xl
clrl r9 # clear garbage value in xr
movl (sp)+,r11 # take ident exit
jmp *(r11)+
#
# HERE FOR INTEGERS, IDENT IF SAME VALUES
#
iden4: movl 4*icval(r9),r5 # load arg 1
subl2 4*icval(r10),r5 # subtract arg 2 to compare
bvs iden1
tstl r5 # differ if result is not zero
bneq iden1
movl (sp)+,r11 # take ident exit
jmp *(r11)+
#
# HERE FOR REALS, IDENT IF SAME VALUES
#
iden5: movf 4*rcval(r9),r2 # load arg 1
subf2 4*rcval(r10),r2 # subtract arg 2 to compare
bvs iden1
tstf r2 # differ if result is not zero
bneq iden1
movl (sp)+,r11 # take ident exit
jmp *(r11)+
#
# HERE FOR NAMES, IDENT IF BASES AND OFFSETS SAME
#
iden6: cmpl 4*nmofs(r9),4*nmofs(r10) # differ if different offset
bnequ iden1
cmpl 4*nmbas(r9),4*nmbas(r10) # differ if different base
bnequ iden1
#
# MERGE HERE TO SIGNAL IDENT FOR IDENTICAL POINTERS
#
iden7: movl (sp)+,r11 # take ident exit
jmp *(r11)+
#
# HERE FOR DIFFER STRINGS
#
iden8: clrl r9 # clear garbage ptr in xr
clrl r10 # clear garbage ptr in xl
addl2 $4*1,(sp) # return to caller (differ)
rsb
#enp # end procedure ident
#page
#
# 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 # entry point
movl r7,-(sp) # stack trblk type
movl 4*sclen(r10),r6 # get name length
clrl r7 # point to start of name
jsb sbstr # build a proper scblk
jsb gtnvr # build vrblk
.long invalid$ # no error return
movl r9,r8 # save vrblk pointer
movl (sp)+,r7 # get trter field
clrl r10 # zero trfpt
jsb trbld # build trblk
movl r8,r10 # recall vrblk pointer
movl 4*vrsvp(r10),4*trter(r9) # store svblk pointer
movl r9,4*vrval(r10) # store trblk ptr in vrblk
movl $b$vra,4*vrget(r10) # set trapped access
movl $b$vrv,4*vrsto(r10) # set trapped store
rsb # return to caller
#enp # end procedure inout
#page
#
# 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 # entry point
movl r6,inssa # save entry wa
movl r7,inssb # save entry wb
movl r8,inssc # save entry wc
addl2 r7,r6 # add to get offset past replace part
movl r6,insab # save wa+wb
movl 4*bclen(r9),r8 # get current defined length
cmpl inssa,r8 # fail if start offset too big
blequ 0f
jmp ins07
0:
cmpl r6,r8 # fail if final offset too big
blequ 0f
jmp ins07
0:
movl r10,-(sp) # save entry xl
movl r9,-(sp) # save bcblk ptr
movl r10,-(sp) # stack again for gtstg
jsb gtstg # call to convert to string
.long ins05 # take string convert err exit
movl r9,r10 # save string ptr
movl (sp),r9 # restore bcblk ptr
addl2 r8,r6 # add buffer len to string len
subl2 inssb,r6 # bias out component being replaced
movl 4*bcbuf(r9),r9 # point to bfblk
cmpl r6,4*bfalc(r9) # fail if result exceeds allocation
blequ 0f
jmp ins06
0:
movl (sp),r9 # restore bcblk ptr
movl r8,r6 # get buffer length
subl2 insab,r6 # subtract to get shift length
addl2 4*sclen(r10),r8 # add length of new
subl2 inssb,r8 # subtract old to get total new len
movl 4*bclen(r9),r7 # get old bclen
movl r8,4*bclen(r9) # stuff new length
tstl r6 # skip shift if nothing to do
bnequ 0f
jmp ins04
0:
cmpl inssb,4*sclen(r10) # skip shift if lengths match
bnequ 0f
jmp ins04
0:
movl 4*bcbuf(r9),r9 # point to bfblk
movl r10,-(sp) # save scblk ptr
cmpl inssb,4*sclen(r10) # brn if shft is for more room
blequ ins01
#page
#
# 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
#
movl inssa,r7 # get offset to insert
addl2 4*sclen(r10),r7 # add insert length to get dest off
movl r9,r10 # make copy
movl insab,r11 # [get in scratch register]
movab cfp$f(r10)[r11],r10 # prepare source for move
movab cfp$f(r9)[r7],r9# prepare destination reg for move
jsb sbmvc # move em out
jmp 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: movl r9,r10 # copy bfblk ptr
movab cfp$f(r10)[r7],r10 # set source reg for move backwards
movab cfp$f(r9)[r8],r9# set destination ptr for move
jsb sbmcb # move backwards (possible overlap)
#
# MERGE HERE AFTER MOVE TO ADJUST PADDING AT NEW BUFFER END
#
ins02: movl (sp)+,r10 # restore scblk ptr
movl r8,r6 # copy new buffer end
movab 3+(4*0)(r6),r6 # round out
bicl2 $3,r6
subl2 r8,r6 # subtract to get remainder
bnequ 0f # no pad if already even boundary
jmp ins04
0:
movl (sp),r9 # get bcblk ptr
movl 4*bcbuf(r9),r9 # get bfblk ptr
movab cfp$f(r9)[r8],r9# prepare to pad
clrl r7 # clear wb
# load loop count
#
# LOOP HERE TO STUFF PAD CHARACTERS
#
ins03: movb r7,(r9)+ # stuff zero pad
sobgtr r6,ins03 # branch for more
#page
#
# INSBF (CONTINUED)
#
# MERGE HERE WHEN PADDING OK. NOW COPY IN THE INSERT
# STRING TO THE HOLE.
#
ins04: movl (sp),r9 # get bcblk ptr
movl 4*bcbuf(r9),r9 # get bfblk ptr
movl 4*sclen(r10),r6 # get move length
movab cfp$f(r10),r10 # prepare to copy from first char
movl inssa,r11 # [get in scratch register]
movab cfp$f(r9)[r11],r9# prepare to store in hole
jsb sbmvc # copy the characters
movl (sp)+,r9 # restore entry xr
movl (sp)+,r10 # restore entry xl
movl inssa,r6 # restore entry wa
movl inssb,r7 # restore entry wb
movl inssc,r8 # restore entry wc
addl2 $4*2,(sp) # return to caller
rsb
#
# HERE TO TAKE STRING CONVERT ERROR EXIT
#
ins05: movl (sp)+,r9 # restore entry xr
movl (sp)+,r10 # restore entry xl
movl inssa,r6 # restore entry wa
movl inssb,r7 # restore entry wb
movl inssc,r8 # restore entry wc
movl (sp)+,r11 # alternate exit
jmp *(r11)+
#
# HERE FOR INVALID OFFSET OR LENGTH
#
ins06: movl (sp)+,r9 # restore entry xr
movl (sp)+,r10 # restore entry xl
#
# MERGE FOR LENGTH FAILURE EXIT WITH STACK SET
#
ins07: movl inssa,r6 # restore entry wa
movl inssb,r7 # restore entry wb
movl inssc,r8 # restore entry wc
addl3 $4*1,(sp)+,r11 # alternate exit
jmp *(r11)+
#enp # end procedure insbf
#page
#
# 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
#
.data 1
iofcb_s: .long 0
.text 0
iofcb: movl (sp)+,iofcb_s # entry point
jsb gtstg # get arg as string
.long iofc2 # fail
movl r9,r10 # copy string ptr
jsb gtnvr # get as natural variable
.long iofc3 # fail if null
movl r10,r7 # copy string pointer again
movl r9,r10 # copy vrblk ptr for return
clrl r6 # in case no trblk found
#
# LOOP TO FIND FILE ARG1 TRBLK
#
iofc1: movl 4*vrval(r9),r9 # get possible trblk ptr
cmpl (r9),$b$trt # fail if end of chain
bnequ iofc2
cmpl 4*trtyp(r9),$trtfc # loop if not file arg trblk
bnequ iofc1
movl 4*trfpt(r9),r6 # get fcblk ptr
movl r7,r9 # copy arg
addl3 $4*2,iofcb_s,r11 # return
jmp (r11)
#
# FAIL RETURN
#
iofc2: movl iofcb_s,r11 # fail
jmp *(r11)+
#
# NULL ARG
#
iofc3: addl3 $4*1,iofcb_s,r11 # null arg return
jmp *(r11)+
#enp # end procedure iofcb
#page
#
# 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
#
.data 1
ioppf_s: .long 0
.text 0
ioppf: movl (sp)+,ioppf_s # entry point
clrl r7 # to count fields extracted
#
# LOOP TO EXTRACT FIELDS
#
iopp1: movl $iodel,r10 # get delimiter
movl r10,r8 # copy it
jsb xscan # get next field
movl r9,-(sp) # stack it
incl r7 # increment count
tstl r6 # loop
bnequ iopp1
movl r7,r8 # count of fields
movl ioptt,r7 # i/o marker
movl r$iof,r6 # fcblk ptr or 0
movl r$io2,r9 # file arg2 ptr
movl r$io1,r10 # filearg1
jmp *ioppf_s # return
#enp # end procedure ioppf
#page
#
# 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)
#page
#
# 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
#
.data 1
ioput_s: .long 0
.text 0
ioput: movl (sp)+,ioput_s # entry point
clrl r$iot # in case no trtrf block used
clrl r$iof # in case no fcblk alocated
movl r7,ioptt # store i/o trace type
jsb xscni # prepare to scan filearg2
.long iop13 # fail
.long iopa0 # null file arg2
#
iopa0: movl r9,r$io2 # keep file arg2
movl r6,r10 # copy length
jsb gtstg # convert filearg1 to string
.long iop14 # fail
movl r9,r$io1 # keep filearg1 ptr
jsb gtnvr # convert to natural variable
.long iop00 # jump if null
jmp iop04 # jump to process non-null args
#
# NULL FILEARG1
#
iop00: tstl r10 # skip if both args null
bnequ 0f
jmp iop01
0:
jsb ioppf # process filearg2
jsb sysfc # call for filearg2 check
.long iop16 # fail
jmp iop11 # complete file association
#page
#
# IOPUT (CONTINUED)
#
# HERE WITH 0 OR FCBLK PTR IN (XL)
#
iop01: movl ioptt,r7 # get trace type
movl r$iot,r9 # get 0 or trtrf ptr
jsb trbld # build trblk
movl r9,r8 # copy trblk pointer
movl (sp)+,r9 # get variable from stack
jsb gtvar # point to variable
.long iop15 # fail
movl r10,r$ion # save name pointer
movl r10,r9 # copy name pointer
addl2 r6,r9 # point to variable
subl2 $4*vrval,r9 # subtract offset,merge into loop
#
# LOOP TO END OF TRBLK CHAIN IF ANY
#
iop02: movl r9,r10 # copy blk ptr
movl 4*vrval(r9),r9 # load ptr to next trblk
cmpl (r9),$b$trt # jump if not trapped
bnequ iop03
cmpl 4*trtyp(r9),ioptt# loop if not same assocn
bnequ iop02
movl 4*trnxt(r9),r9 # get value and delete old trblk
#
# IOPUT (CONTINUED)
#
# STORE NEW ASSOCIATION
#
iop03: movl r8,4*vrval(r10) # link to this trblk
movl r8,r10 # copy pointer
movl r9,4*trnxt(r10) # store value in trblk
movl r$ion,r9 # restore possible vrblk pointer
movl r6,r7 # keep offset to name
jsb setvr # if vrblk, set vrget,vrsto
movl r$iot,r9 # get 0 or trtrf ptr
beqlu 0f # jump if trtrf block exists
jmp iop19
0:
addl3 $4*6,ioput_s,r11 # return to caller
jmp (r11)
#
# NON STANDARD FILE
# SEE IF AN FCBLK HAS ALREADY BEEN ALLOCATED.
#
iop04: clrl r6 # in case no fcblk found
#page
#
# IOPUT (CONTINUED)
#
# SEARCH POSSIBLE TRBLK CHAIN TO PICK UP THE FCBLK
#
iop05: movl r9,r7 # remember blk ptr
movl 4*vrval(r9),r9 # chain along
cmpl (r9),$b$trt # jump if end of trblk chain
bnequ iop06
cmpl 4*trtyp(r9),$trtfc # loop if more to go
bnequ iop05
movl r9,r$iot # point to file arg1 trblk
movl 4*trfpt(r9),r6 # 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: movl r6,r$iof # keep possible fcblk ptr
movl r7,r$iop # keep preceding blk ptr
jsb ioppf # process filearg2
jsb sysfc # see if fcblk required
.long iop16 # fail
tstl r6 # skip if no new fcblk wanted
bnequ 0f
jmp iop12
0:
cmpl r8,$num02 # jump if fcblk in dynamic
blssu iop6a
jsb alost # get it in static
jmp iop6b # skip
#
# OBTAIN FCBLK IN DYNAMIC
#
iop6a: jsb alloc # get space for fcblk
#
# MERGE
#
iop6b: movl r9,r10 # point to fcblk
movl r6,r7 # copy its length
ashl $-2,r7,r7 # get count as words (sgd apr80)
# loop counter
#
# CLEAR FCBLK
#
iop07: clrl (r9)+ # clear a word
sobgtr r7,iop07 # loop
cmpl r8,$num02 # skip if in static - dont set fields
bnequ 0f
jmp iop09
0:
movl $b$xnt,(r10) # store xnblk code in case
movl r6,4*1(r10) # store length
tstl r8 # jump if xnblk wanted
beqlu 0f
jmp iop09
0:
movl $b$xrt,(r10) # xrblk code requested
#
#page
# IOPUT (CONTINUED)
#
# COMPLETE FCBLK INITIALISATION
#
iop09: movl r$iot,r9 # get possible trblk ptr
movl r10,r$iof # store fcblk ptr
tstl r9 # jump if trblk already found
bnequ iop10
#
# A NEW TRBLK IS NEEDED
#
movl $trtfc,r7 # trtyp for fcblk trap blk
jsb trbld # make the block
movl r9,r$iot # copy trtrf ptr
movl r$iop,r10 # point to preceding blk
movl 4*vrval(r10),4*vrval(r9) # copy value field to trblk
movl r9,4*vrval(r10) # link new trblk into chain
movl r10,r9 # point to predecessor blk
jsb setvr # set trace intercepts
movl 4*vrval(r9),r9 # recover trblk ptr
#
# XR IS PTR TO TRBLK, XL IS FCBLK PTR OR 0
#
iop10: movl r$iof,4*trfpt(r9)# store fcblk ptr
#
# CALL SYSIO TO COMPLETE FILE ACCESSING
#
iop11: movl r$iof,r6 # copy fcblk ptr or 0
movl ioptt,r7 # get input/output flag
movl r$io2,r9 # get file arg2
movl r$io1,r10 # get file arg1
jsb sysio # associate to the file
.long iop17 # fail
.long iop18 # fail
tstl r$iot # not std input if non-null trtrf blk
beqlu 0f
jmp iop01
0:
tstl ioptt # jump if output
beqlu 0f
jmp iop01
0:
tstl r8 # no change to standard read length
bnequ 0f
jmp iop01
0:
movl r8,cswin # store new read length for std file
jmp iop01 # merge to finish the task
#
# SYSFC MAY HAVE RETURNED A POINTER TO A PRIVATE FCBLK
#
iop12: tstl r10 # jump if private fcblk
beqlu 0f
jmp iop09
0:
jmp iop11 # finish the association
#
# FAILURE RETURNS
#
iop13: movl ioput_s,r11 # 3rd arg not a string
jmp *(r11)+
iop14: addl3 $4*1,ioput_s,r11 # 2nd arg unsuitable
jmp *(r11)+
iop15: addl3 $4*2,ioput_s,r11 # 1st arg unsuitable
jmp *(r11)+
iop16: addl3 $4*3,ioput_s,r11 # file spec wrong
jmp *(r11)+
iop17: addl3 $4*4,ioput_s,r11 # i/o file does not exist
jmp *(r11)+
iop18: addl3 $4*5,ioput_s,r11 # i/o file cannot be read/written
jmp *(r11)+
#page
#
# IOPUT (CONTINUED)
#
# ADD TO IOCHN CHAIN OF ASSSOCIATED VARIABLES UNLESS ALREAD
# PRESENT.
#
iop19: movl r$ion,r8 # wc = name base, wb = name offset
#
# SEARCH LOOP
#
iop20: movl 4*trtrf(r9),r9 # next link of chain
beqlu iop21 # not found
cmpl r8,4*ionmb(r9) # no match
bnequ iop20
cmpl r7,4*ionmo(r9) # exit if matched
beqlu iop22
jmp iop20 # loop
#
# NOT FOUND
#
iop21: movl $4*num05,r6 # space needed
jsb alloc # get it
movl $b$xrt,(r9) # store xrblk code
movl r6,4*1(r9) # store length
movl r8,4*ionmb(r9) # store name base
movl r7,4*ionmo(r9) # store name offset
movl r$iot,r10 # point to trtrf blk
movl 4*trtrf(r10),r6 # get ptr field contents
movl r9,4*trtrf(r10) # store ptr to new block
movl r6,4*trtrf(r9) # complete the linking
#
# INSERT FCBLK ON FCBLK CHAIN FOR SYSEJ, SYSXI
#
iop22: tstl r$iof # skip if no fcblk
beqlu iop25
movl r$fcb,r10 # ptr to head of existing chain
#
# SEE IF FCBLK ALREADY ON CHAIN
#
iop23: tstl r10 # not on if end of chain
beqlu iop24
cmpl 4*3(r10),r$iof # dont duplicate if find it
beqlu iop25
movl 4*2(r10),r10 # get next link
jmp iop23 # loop
#
# NOT FOUND SO ADD AN ENTRY FOR THIS FCBLK
#
iop24: movl $4*num04,r6 # space needed
jsb alloc # get it
movl $b$xrt,(r9) # store block code
movl r6,4*1(r9) # store length
movl r$fcb,4*2(r9) # store previous link in this node
movl r$iof,4*3(r9) # store fcblk ptr
movl r9,r$fcb # insert node into fcblk chain
#
# RETURN
#
iop25: addl3 $4*6,ioput_s,r11 # return to caller
jmp (r11)
#enp # end procedure ioput
#page
#
# 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 # entry point (recursive)
tstl r10 # immediate exit if keyword untraced
beqlu ktrx3
tstl kvtra # immediate exit if trace = 0
beqlu ktrx3
decl kvtra # else decrement trace
movl r9,-(sp) # save xr
movl r10,r9 # copy trblk pointer
movl 4*trkvr(r9),r10 # load vrblk pointer (nmbas)
movl $4*vrval,r6 # set name offset
tstl 4*trfnc(r9) # jump if print trace
beqlu ktrx1
jsb trxeq # else execute full trace
jmp ktrx2 # and jump to exit
#
# HERE FOR PRINT TRACE
#
ktrx1: movl r10,-(sp) # stack vrblk ptr for kwnam
movl r6,-(sp) # stack offset for kwnam
jsb prtsn # print statement number
movl $ch$am,r6 # load ampersand
jsb prtch # print ampersand
jsb prtnm # print keyword name
movl $tmbeb,r9 # point to blank-equal-blank
jsb prtst # print blank-equal-blank
jsb kwnam # get keyword pseudo-variable name
movl r9,dnamp # reset ptr to delete kvblk
jsb acess # get keyword value
.long invalid$ # failure is impossible
jsb prtvl # print keyword value
jsb prtnl # terminate print line
#
# HERE TO EXIT AFTER COMPLETING TRACE
#
ktrx2: movl (sp)+,r9 # restore entry xr
#
# MERGE HERE TO EXIT IF NO TRACE REQUIRED
#
ktrx3: rsb # return to ktrex caller
#enp # end procedure ktrex
#page
#
# 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
#
.data 1
kwnam_s: .long 0
.text 0
kwnam: movl (sp)+,kwnam_s # entry point
addl2 $4,sp # ignore name offset
movl (sp)+,r9 # load name base
cmpl r9,state # jump if not natural variable name
bgequ kwnm1
tstl 4*vrlen(r9) # error if not system variable
bnequ kwnm1
movl 4*vrsvp(r9),r9 # else point to svblk
movl 4*svbit(r9),r6 # load bit mask
mcoml btknm,r11 # and with keyword bit
bicl2 r11,r6
beqlu kwnm1 # error if no keyword association
movl 4*svlen(r9),r6 # else load name length in characters
movab 3+(4*svchs)(r6),r6 # compute offset to field we want
bicl2 $3,r6
addl2 r6,r9 # point to svknm field
movl (r9),r7 # load svknm value
movl $4*kvsi$,r6 # set size of kvblk
jsb alloc # allocate kvblk
movl $b$kvt,(r9) # store type word
movl r7,4*kvnum(r9) # store keyword number
movl $trbkv,4*kvvar(r9) # set dummy trblk pointer
movl r9,r10 # copy kvblk pointer
movl $4*kvvar,r6 # set proper offset
jmp *kwnam_s # return to kvnam caller
#
# HERE IF NOT KEYWORD NAME
#
kwnm1: jmp er_251 # keyword operand is not name of defined keyword
#enp # end procedure kwnam
#page
#
# 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
#
.data 1
lcomp_s: .long 0
.text 0
lcomp: movl (sp)+,lcomp_s # entry point
jsb gtstg # convert second arg to string
.long lcmp6 # jump if second arg not string
movl r9,r10 # else save pointer
movl r6,r7 # and length
jsb gtstg # convert first argument to string
.long lcmp5 # jump if not string
movl r6,r8 # save arg 1 length
movab cfp$f(r9),r9 # point to chars of arg 1
movab cfp$f(r10),r10 # point to chars of arg 2
cmpl r6,r7 # jump if arg 1 length is smaller
blequ lcmp1
movl r7,r6 # else set arg 2 length as smaller
#
# HERE WITH SMALLER LENGTH IN (WA)
#
lcmp1: jsb sbcmc # compare strings, jump if unequal
.long lcmp4
.long lcmp3
cmpl r7,r8 # if equal, jump if lengths unequal
bnequ lcmp2
addl3 $4*3,lcomp_s,r11 # else identical strings, leq exit
jmp *(r11)+
#page
#
# LCOMP (CONTINUED)
#
# HERE IF INITIAL STRINGS IDENTICAL, BUT LENGTHS UNEQUAL
#
lcmp2: cmpl r8,r7 # jump if arg 1 length gt arg 2 leng
bgequ lcmp4
#
# HERE IF FIRST ARG LLT SECOND ARG
#
lcmp3: addl3 $4*2,lcomp_s,r11 # take llt exit
jmp *(r11)+
#
# HERE IF FIRST ARG LGT SECOND ARG
#
lcmp4: addl3 $4*4,lcomp_s,r11 # take lgt exit
jmp *(r11)+
#
# HERE IF FIRST ARG IS NOT A STRING
#
lcmp5: movl lcomp_s,r11 # take bad first arg exit
jmp *(r11)+
#
# HERE FOR SECOND ARG NOT A STRING
#
lcmp6: addl3 $4*1,lcomp_s,r11 # take bad second arg error exit
jmp *(r11)+
#enp # end procedure lcomp
#page
#
# 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 # entry point
tstl cnttl # jump if -title or -stitl
beqlu 0f
jmp list5
0:
tstl lstpf # immediate exit if already listed
beqlu 0f
jmp list4
0:
cmpl lstlc,lstnp # jump if no room
blssu 0f
jmp list6
0:
#
# HERE AFTER PRINTING TITLE (IF NEEDED)
#
list0: movl r$cim,r9 # load pointer to current image
movab cfp$f(r9),r9 # point to characters
movzbl (r9),r6 # load first character
movl lstsn,r9 # load statement number
beqlu list2 # jump if no statement number
movl r9,r5 # else get stmnt number as integer
cmpl stage,$stgic # skip if execute time
bnequ list1
cmpl r6,$ch$as # no stmnt number list if comment
beqlu list2
cmpl r6,$ch$mn # no stmnt no. if control card
beqlu list2
#
# PRINT STATEMENT NUMBER
#
list1: jsb prtin # else print statement number
clrl lstsn # and clear for next time in
#page
#
# LISTR (CONTINUED)
#
# MERGE HERE AFTER PRINTING STATEMENT NUMBER (IF REQUIRED)
#
list2: movl $stnpd,profs # point past statement number
movl r$cim,r9 # load pointer to current image
jsb prtst # print it
incl lstlc # bump line counter
tstl erlst # jump if error copy to int.ch.
bnequ list3
jsb prtnl # terminate line
tstl cswdb # jump if -single mode
beqlu list3
jsb prtnl # else add a blank line
incl lstlc # and bump line counter
#
# HERE AFTER PRINTING SOURCE IMAGE
#
list3: movl sp,lstpf # set flag for line printed
#
# MERGE HERE TO EXIT
#
list4: rsb # return to listr caller
#
# PRINT TITLE AFTER -TITLE OR -STITL CARD
#
list5: clrl cnttl # clear flag
#
# EJECT TO NEW PAGE AND LIST TITLE
#
list6: jsb prtps # eject
tstl prich # skip if listing to regular printer
beqlu list7
cmpl r$ttl,$nulls # terminal listing omits null title
bnequ 0f
jmp list0
0:
#
# LIST TITLE
#
list7: jsb listt # list title
jmp list0 # merge
#enp # end procedure listr
#page
#
# LISTT -- LIST TITLE AND SUBTITLE
#
# USED DURING COMPILATION TO PRINT PAGE HEADING
#
# JSR LISTT CALL TO LIST TITLE
# (XR,WA) DESTROYED
#
listt: #prc # entry point
movl r$ttl,r9 # point to source listing title
jsb prtst # print title
movl lstpo,profs # set offset
movl $lstms,r9 # set page message
jsb prtst # print page message
incl lstpg # bump page number
movl lstpg,r5 # load page number as integer
jsb prtin # print page number
jsb prtnl # terminate title line
addl2 $num02,lstlc # count title line and blank line
#
# PRINT SUB-TITLE (IF ANY)
#
movl r$stl,r9 # load pointer to sub-title
beqlu lstt1 # jump if no sub-title
jsb prtst # else print sub-title
jsb prtnl # terminate line
incl lstlc # bump line count
#
# RETURN POINT
#
lstt1: jsb prtnl # print a blank line
rsb # return to caller
#enp # end procedure listt
#page
#
# 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 # entry point
tstl cswls # jump if -nolist
beqlu nxts2
movl r$cim,r9 # point to image
beqlu nxts2 # jump if no image
movab cfp$f(r9),r9 # get char ptr
movzbl (r9),r6 # get first char
cmpl r6,$ch$mn # jump if not ctrl card
bnequ nxts1
tstl cswpr # jump if -noprint
beqlu nxts2
#
# HERE TO CALL LISTER
#
nxts1: jsb listr # list line
#
# HERE AFTER POSSIBLE LISTING
#
nxts2: movl r$cni,r9 # point to next image
movl r9,r$cim # set as next image
clrl r$cni # clear next image pointer
movl 4*sclen(r9),r6 # get input image length
movl cswin,r7 # get max allowable length
cmpl r6,r7 # skip if not too long
blequ nxts3
movl r7,r6 # else truncate
#
# HERE WITH LENGTH IN (WA)
#
nxts3: movl r6,scnil # use as record length
clrl scnse # reset scnse
clrl lstpf # set line not listed yet
rsb # return to nexts caller
#enp # end procedure nexts
#page
#
# 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
#
.data 1
patin_s: .long 0
.text 0
patin: movl (sp)+,patin_s # entry point
movl r6,r10 # preserve expression arg pcode
jsb gtsmi # try to convert arg as small integer
.long ptin2 # jump if not integer
.long ptin3 # jump if out of range
#
# COMMON SUCCESSFUL EXIT POINT
#
ptin1: jsb pbild # build pattern node
addl3 $4*2,patin_s,r11 # return to caller
jmp (r11)
#
# HERE IF ARGUMENT IS NOT AN INTEGER
#
ptin2: movl r10,r7 # copy expr arg case pcode
cmpl (r9),$b$e$$ # all ok if expression arg
blequ ptin1
movl patin_s,r11 # else take error exit for wrong type
jmp *(r11)+
#
# HERE FOR ERROR OF OUT OF RANGE INTEGER ARGUMENT
#
ptin3: addl3 $4*1,patin_s,r11 # take out-of-range error exit
jmp *(r11)+
#enp # end procedure patin
#page
#
# 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.
#
.data 1
patst_s: .long 0
.text 0
patst: movl (sp)+,patst_s # entry point
jsb gtstg # convert argument as string
.long pats7 # jump if not string
cmpl r6,$num01 # jump if not one char string
bnequ pats2
#
# HERE FOR ONE CHAR STRING CASE
#
tstl r7 # treat as multi-char if evals call
beqlu pats2
movab cfp$f(r9),r9 # point to character
movzbl (r9),r9 # load character
#
# COMMON EXIT POINT AFTER SUCCESSFUL CONSTRUCTION
#
pats1: jsb pbild # call routine to build node
addl3 $4*1,patst_s,r11 # return to patst caller
jmp (r11)
#page
#
# PATST (CONTINUED)
#
# HERE FOR MULTI-CHARACTER STRING CASE
#
pats2: movl r10,-(sp) # save multi-char pcode
movl r9,-(sp) # save string pointer
movl ctmsk,r8 # load current mask bit
ashl $1,r8,r8 # shift to next position
tstl r8 # skip if position left in this tbl
bnequ pats4
#
# HERE WE MUST ALLOCATE A NEW CHARACTER TABLE
#
movl $4*ctsi$,r6 # set size of ctblk
jsb alloc # allocate ctblk
movl r9,r$ctp # store ptr to new ctblk
movl $b$ctt,(r9)+ # store type code, bump ptr
movl $cfp$a,r7 # set number of words to clear
movl bits0,r8 # load all zero bits
#
# LOOP TO CLEAR ALL BITS IN TABLE TO ZEROS
#
pats3: movl r8,(r9)+ # move word of zero bits
sobgtr r7,pats3 # loop till all cleared
movl bits1,r8 # set initial bit position
#
# MERGE HERE WITH BIT POSITION AVAILABLE
#
pats4: movl r8,ctmsk # save parm2 (new bit position)
movl (sp)+,r10 # restore pointer to argument string
movl 4*sclen(r10),r7 # load string length
beqlu pats6 # jump if null string case
# else set loop counter
movab cfp$f(r10),r10 # point to characters in argument
#page
#
# PATST (CONTINUED)
#
# LOOP TO SET BITS IN COLUMN OF TABLE
#
pats5: movzbl (r10)+,r6 # load next character
moval 0[r6],r6 # convert to byte offset
movl r$ctp,r9 # point to ctblk
addl2 r6,r9 # point to ctblk entry
movl r8,r6 # copy bit mask
bisl2 4*ctchs(r9),r6 # or in bits already set
movl r6,4*ctchs(r9) # store resulting bit string
sobgtr r7,pats5 # loop till all bits set
#
# COMPLETE PROCESSING FOR MUTI-CHAR STRING CASE
#
pats6: movl r$ctp,r9 # load ctblk ptr as parm1 for pbild
clrl r10 # clear garbage ptr in xl
movl (sp)+,r7 # load pcode for multi-char str case
jmp 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: movl r8,r7 # set pcode for expression argument
cmpl (r9),$b$e$$ # jump to exit if expression arg
bgtru 0f
jmp pats1
0:
movl patst_s,r11 # else take wrong type error exit
jmp *(r11)+
#enp # end procedure patst
#page
#
# 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 # entry point
movl r9,-(sp) # stack possible parm1
movl r7,r9 # copy pcode
movzwl -2(r9),r9 # load entry point id (bl$px)
cmpl r9,$bl$p1 # jump if one parameter
beqlu pbld1
cmpl r9,$bl$p0 # jump if no parameters
beqlu pbld3
#
# HERE FOR TWO PARAMETER CASE
#
movl $4*pcsi$,r6 # set size of p2blk
jsb alloc # allocate block
movl r8,4*parm2(r9) # store second parameter
jmp pbld2 # merge with one parm case
#
# HERE FOR ONE PARAMETER CASE
#
pbld1: movl $4*pbsi$,r6 # set size of p1blk
jsb alloc # allocate node
#
# MERGE HERE FROM TWO PARM CASE
#
pbld2: movl (sp),4*parm1(r9)# store first parameter
jmp pbld4 # merge with no parameter case
#
# HERE FOR CASE OF NO PARAMETERS
#
pbld3: movl $4*pasi$,r6 # set size of p0blk
jsb alloc # allocate node
#
# MERGE HERE FROM OTHER CASES
#
pbld4: movl r7,(r9) # store pcode
addl2 $4,sp # pop first parameter
movl $ndnth,4*pthen(r9) # set nothen successor pointer
rsb # return to pbild caller
#enp # end procedure pbild
#page
#
# 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 # entry point
clrl -(sp) # make room for one entry at bottom
movl sp,r8 # store pointer to start of list
movl $ndnth,-(sp) # stack nothen node as old node
movl r10,-(sp) # store right arg as copy of nothen
movl sp,r10 # initialize pointer to stack entries
jsb pcopy # copy first node of left arg
movl r6,4*2(r10) # store as result under list
#page
#
# PCONC (CONTINUED)
#
# THE FOLLOWING LOOP SCANS ENTRIES IN THE LIST AND MAKES
# SURE THAT THEIR SUCCESSORS HAVE BEEN COPIED.
#
pcnc1: cmpl r10,sp # jump if all entries processed
beqlu pcnc2
movl -(r10),r9 # else load next old address
movl 4*pthen(r9),r9 # load pointer to successor
jsb pcopy # copy successor node
movl -(r10),r9 # load pointer to new node (copy)
movl r6,4*pthen(r9) # 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.
#
cmpl (r9),$p$alt # loop back if not
bnequ pcnc1
movl 4*parm1(r9),r9 # else load pointer to alternative
jsb pcopy # copy it
movl (r10),r9 # restore ptr to new node
movl r6,4*parm1(r9) # store ptr to copied alternative
jmp pcnc1 # loop back for next entry
#
# HERE AT END OF COPY PROCESS
#
pcnc2: movl r8,sp # restore stack pointer
movl (sp)+,r9 # load pointer to copy
rsb # return to pconc caller
#enp # end procedure pconc
#page
#
# 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
#
.data 1
pcopy_s: .long 0
.text 0
pcopy: movl (sp)+,pcopy_s # entry point
movl r10,r7 # save xt
movl r8,r10 # point to start of list
#
# LOOP TO SEARCH LIST OF NODES COPIED ALREADY
#
pcop1: subl2 $4,r10 # point to next entry on list
cmpl r9,(r10) # jump if match
beqlu pcop2
subl2 $4,r10 # else skip over copied address
cmpl r10,sp # loop back if more to test
bnequ pcop1
#
# HERE IF NOT IN LIST, PERFORM COPY
#
movl (r9),r6 # load first word of block
jsb blkln # get length of block
movl r9,r10 # save pointer to old node
jsb alloc # allocate space for copy
movl r10,-(sp) # store old address on list
movl r9,-(sp) # store new address on list
jsb sbchk # check for stack overflow
jsb sbmvw # move words from old block to copy
movl (sp),r6 # load pointer to copy
jmp pcop3 # jump to exit
#
# HERE IF WE FIND ENTRY IN LIST
#
pcop2: movl -(r10),r6 # load address of copy from list
#
# COMMON EXIT POINT
#
pcop3: movl r7,r10 # restore xt
jmp *pcopy_s # return to pcopy caller
#enp # end procedure pcopy
#page
#
# 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
tstl pfdmp # no printing if no profiling done
bnequ 0f
jmp prfl4
0:
movl r9,-(sp) # preserve entry xr
movl r7,pfsvw # and also wb
jsb prtpg # eject
movl $pfms1,r9 # load msg /program profile/
jsb prtst # and print it
jsb prtnl # followed by newline
jsb prtnl # and another
movl $pfms2,r9 # point to first hdr
jsb prtst # print it
jsb prtnl # new line
movl $pfms3,r9 # second hdr
jsb prtst # print it
jsb prtnl # new line
jsb prtnl # and another blank line
clrl r7 # initial stmt count
movl pftbl,r9 # point to table origin
addl2 $4*num02,r9 # bias past xnblk header (sgd07)
#
# LOOP HERE TO PRINT SUCCESSIVE ENTRIES
#
prfl1: incl r7 # bump stmt nr
movl (r9),r5 # load nr of executions
beql prfl3 # no printing if zero
movl $pfpd1,profs # point where to print
jsb prtin # and print it
clrl profs # back to start of line
movl r7,r5 # load stmt nr
jsb prtin # print it there
movl $pfpd2,profs # and pad past count
movl 4*cfp$i(r9),r5 # load total exec time
jsb prtin # print that too
movl 4*cfp$i(r9),r5 # reload time
mull2 intth,r5 # convert to microsec
bvs prfl2
divl2 (r9),r5 # divide by executions
movl $pfpd3,profs # pad last print
jsb prtin # and print mcsec/execn
#
# MERGE AFTER PRINTING TIME
#
prfl2: jsb prtnl # thats another line
#
# HERE TO GO TO NEXT ENTRY
#
prfl3: addl2 $4*pf$i2,r9 # bump index ptr (sgd07)
cmpl r7,pfnte # loop if more stmts
blssu prfl1
movl (sp)+,r9 # restore callers xr
movl pfsvw,r7 # and wb too
#
# HERE TO EXIT
#
prfl4: rsb # return
#enp # end of prflr
#page
#
# 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
tstl pffnc # skip if just entered function
beqlu 0f
jmp pflu4
0:
movl r9,-(sp) # preserve entry xr
movl r6,pfsvw # save wa (sgd07)
tstl pftbl # branch if table allocated
bnequ pflu2
#
# 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...
#
subl2 $num01,pfnte # adjust for extra count (sgd07)
movl pfi2a,r5 # convrt entry size to int
movl r5,pfste # and store safely for later
movl pfnte,r5 # load table length as integer
mull2 pfste,r5 # multiply by entry size
movl r5,r6 # get back address-style
addl2 $num02,r6 # add on 2 word overhead
moval 0[r6],r6 # convert the whole lot to bytes
jsb alost # gimme the space
movl r9,pftbl # save block pointer
movl $b$xnt,(r9)+ # put block type and ...
movl r6,(r9)+ # ... length into header
movl r5,r6 # get back nr of wds in data area
# load the counter
#
# LOOP HERE TO ZERO THE BLOCK DATA
#
pflu1: clrl (r9)+ # blank a word
sobgtr r6,pflu1 # and alllllll the rest
#
# END OF ALLOCATION. MERGE BACK INTO ROUTINE
#
pflu2: movl kvstn,r5 # load nr of stmt just ended
subl2 intv1,r5 # make into index offset
mull2 pfste,r5 # make offset of table entry
movl r5,r6 # convert to address
moval 0[r6],r6 # get as baus
addl2 $4*num02,r6 # offset includes table header
movl pftbl,r9 # get table start
cmpl r6,4*num01(r9) # if out of table, skip it
bgequ pflu3
addl2 r6,r9 # else point to entry
movl (r9),r5 # get nr of executions so far
addl2 intv1,r5 # nudge up one
movl r5,(r9) # and put back
jsb systm # get time now
movl r5,pfetm # stash ending time
subl2 pfstm,r5 # subtract start time
addl2 4*cfp$i(r9),r5 # add cumulative time so far
movl r5,4*cfp$i(r9) # and put back new total
movl pfetm,r5 # load end time of this stmt ...
movl r5,pfstm # ... which is start time of next
#
# MERGE HERE TO EXIT
#
pflu3: movl (sp)+,r9 # restore callers xr
movl pfsvw,r6 # restore saved reg
rsb # 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: clrl pffnc # reset the condition flag
rsb # and immediate return
#enp # end of procedure prflu
#page
#
# 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 # entry point
tstl r8 # jump to associate terminal
beqlu 0f
jmp prpa7
0:
jsb syspp # get print parameters
tstl r7 # jump if lines/page specified
bnequ prpa1
movl $cfp$m,r7 # else use a large value
ashl $-1,r7,r7 # but not too large
#
# STORE LINE COUNT/PAGE
#
prpa1: movl r7,lstnp # store number of lines/page
movl r7,lstlc # pretend page is full initially
clrl lstpg # clear page number
movl prlen,r7 # get prior length if any
beqlu prpa2 # skip if no length
cmpl r6,r7 # skip storing if too big
bgtru prpa3
#
# STORE PRINT BUFFER LENGTH
#
prpa2: movl r6,prlen # store value
#
# PROCESS BITS OPTIONS
#
prpa3: movl bits3,r7 # bit 3 mask
mcoml r8,r11 # get -nolist bit
bicl2 r11,r7
beqlu prpa4 # skip if clear
clrl cswls # set -nolist
#
# CHECK IF FAIL REPORTS GOTO INTERACTIVE CHANNEL
#
prpa4: movl bits1,r7 # bit 1 mask
mcoml r8,r11 # get bit
bicl2 r11,r7
movl r7,erich # store int. chan. error flag
movl bits2,r7 # bit 2 mask
mcoml r8,r11 # get bit
bicl2 r11,r7
movl r7,prich # flag for std printer on int. chan.
movl bits4,r7 # bit 4 mask
mcoml r8,r11 # get bit
bicl2 r11,r7
movl r7,cpsts # flag for compile stats suppressn.
movl bits5,r7 # bit 5 mask
mcoml r8,r11 # get bit
bicl2 r11,r7
movl r7,exsts # flag for exec stats suppression
#page
#
# PRPAR (CONTINUED)
#
movl bits6,r7 # bit 6 mask
mcoml r8,r11 # get bit
bicl2 r11,r7
movl r7,precl # extended/compact listing flag
subl2 $num08,r6 # point 8 chars from line end
tstl r7 # jump if not extended
beqlu prpa5
movl r6,lstpo # store for listing page headings
#
# CONTINUE OPTION PROCESSING
#
prpa5: movl bits7,r7 # bit 7 mask
mcoml r8,r11 # get bit 7
bicl2 r11,r7
movl r7,cswex # set -noexecute if non-zero
movl bit10,r7 # bit 10 mask
mcoml r8,r11 # get bit 10
bicl2 r11,r7
movl r7,headp # pretend printed to omit headers
movl bits9,r7 # bit 9 mask
mcoml r8,r11 # get bit 9
bicl2 r11,r7
movl r7,prsto # keep it as std listing option
tstl r7 # skip if clear
beqlu prpa6
movl prlen,r6 # get print buffer length
subl2 $num08,r6 # point 8 chars from line end
movl r6,lstpo # store page offset
#
# CHECK FOR TERMINAL
#
prpa6: mcoml bits8,r11 # see if terminal to be activated
bicl2 r11,r8
beqlu 0f # jump if terminal required
jmp prpa7
0:
tstl initr # jump if no terminal to detach
beqlu prpa8
movl $v$ter,r10 # ptr to /terminal/
jsb gtnvr # get vrblk pointer
.long invalid$ # cant fail
movl $nulls,4*vrval(r9) # clear value of terminal
jsb setvr # remove association
jmp prpa8 # return
#
# ASSOCIATE TERMINAL
#
prpa7: movl sp,initr # note terminal associated
tstl dnamb # cant if memory not organised
beqlu prpa8
movl $v$ter,r10 # point to terminal string
movl $trtou,r7 # output trace type
jsb inout # attach output trblk to vrblk
movl r9,-(sp) # stack trblk ptr
movl $v$ter,r10 # point to terminal string
movl $trtin,r7 # input trace type
jsb inout # attach input trace blk
movl (sp)+,4*vrval(r9)# add output trblk to chain
#
# RETURN POINT
#
prpa8: rsb # return
#enp # end procedure prpar
#page
#
# 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 # entry point
movl r9,-(sp) # save xr
cmpl profs,prlen # jump if room in buffer
bnequ prch1
jsb prtnl # else print this line
#
# HERE AFTER MAKING SURE WE HAVE ROOM
#
prch1: movl prbuf,r9 # point to print buffer
movl profs,r11 # [get in scratch register]
movab cfp$f(r9)[r11],r9# point to next character location
movb r6,(r9) # store new character
#csc r9 # complete store characters
incl profs # bump pointer
movl (sp)+,r9 # restore entry xr
rsb # return to prtch caller
#enp # end procedure prtch
#page
#
# 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 # entry point
movl r9,-(sp) # save xr
movl prbuf,r9 # point to buffer
movl profs,r6 # no of chars
jsb syspi # print
.long prtc2 # fail return
#
# RETURN
#
prtc1: movl (sp)+,r9 # restore xr
rsb # return
#
# ERROR OCCURED
#
prtc2: clrl erich # prevent looping
jmp er_252 # error on printing to interactive channel
jmp prtc1 # return
#enp # procedure prtic
#page
#
# 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 # entry point
tstl prich # jump if standard printer is int.ch.
bnequ prts1
tstl erich # skip if not doing int. error reps.
beqlu prts1
jsb prtic # print to interactive channel
#
# MERGE AND EXIT
#
prts1: jsb prtnl # print to standard printer
rsb # return
#enp # end procedure prtis
#page
#
# 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 # entry point
movl r9,-(sp) # save xr
jsb icbld # build integer block
cmpl r9,dnamb # jump if icblk below dynamic
blequ prti1
cmpl r9,dnamp # jump if above dynamic
bgequ prti1
movl r9,dnamp # immediately delete it
#
# DELETE ICBLK FROM DYNAMIC STORE
#
prti1: movl r9,-(sp) # stack ptr for gtstg
jsb gtstg # convert to string
.long invalid$ # convert error is impossible
movl r9,dnamp # reset pointer to delete scblk
jsb prtst # print integer string
movl (sp)+,r9 # restore entry xr
rsb # return to prtin caller
#enp # end procedure prtin
#page
#
# 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 # entry point
jsb prtst # print string message
movl $prtmf,profs # set offset to col 15
jsb prtin # print integer
jsb prtnl # print line
rsb # return to prtmi caller
#enp # end procedure prtmi
#page
#
# PRTMX -- AS PRTMI WITH EXTRA COPY TO INTERACTIVE CHAN.
#
# JSR PRTMX CALL FOR PRINTING
# (WA,WB) DESTROYED
#
prtmx: #prc # entry point
jsb prtst # print string message
movl $prtmf,profs # set ptr to column 15
jsb prtin # print integer
jsb prtis # print line
rsb # return
#enp # end procedure prtmx
#page
#
# 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 # entry point
tstl headp # were headers printed
bnequ prnl0
jsb prtps # no - print them
#
# CALL SYSPR
#
prnl0: movl r9,-(sp) # save entry xr
movl r6,prtsa # save wa
movl r7,prtsb # save wb
movl prbuf,r9 # load pointer to buffer
movl profs,r6 # load number of chars in buffer
jsb syspr # call system print routine
.long prnl2 # jump if failed
movl prlnw,r6 # load length of buffer in words
addl2 $4*schar,r9 # point to chars of buffer
movl nullw,r7 # get word of blanks
#
# LOOP TO BLANK BUFFER
#
prnl1: movl r7,(r9)+ # store word of blanks, bump ptr
sobgtr r6,prnl1 # loop till all blanked
#
# EXIT POINT
#
movl prtsb,r7 # restore wb
movl prtsa,r6 # restore wa
movl (sp)+,r9 # restore entry xr
clrl profs # reset print buffer pointer
rsb # return to prtnl caller
#
# FILE FULL OR NO OUTPUT FILE FOR LOAD MODULE
#
prnl2: tstl prtef # jump if not first time
bnequ prnl3
movl sp,prtef # mark first occurrence
jmp er_253 # print limit exceeded on standard output channel
#
# STOP AT ONCE
#
prnl3: movl $nini8,r7 # ending code
movl kvstn,r6 # statement number
jsb sysej # stop
#enp # end procedure prtnl
#page
#
# 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 # entry point (recursive, see prtvl)
movl r6,-(sp) # save wa (offset is collectable)
movl r9,-(sp) # save entry xr
movl r10,-(sp) # save name base
cmpl r10,state # jump if not natural variable
bgequ prn02
#
# HERE FOR NATURAL VARIABLE NAME, RECOGNIZED BY THE FACT
# THAT THE NAME BASE POINTS INTO THE STATIC AREA.
#
movl r10,r9 # point to vrblk
jsb prtvn # print name of variable
#
# COMMON EXIT POINT
#
prn01: movl (sp)+,r10 # restore name base
movl (sp)+,r9 # restore entry value of xr
movl (sp)+,r6 # restore wa
rsb # return to prtnm caller
#
# HERE FOR CASE OF NON-NATURAL VARIABLE
#
prn02: movl r6,r7 # copy name offset
cmpl (r10),$b$pdt # jump if array or table
bnequ prn03
#
# FOR PROGRAM DEFINED DATATYPE, PRT FLD NAME, LEFT PAREN
#
movl 4*pddfp(r10),r9 # load pointer to dfblk
addl2 r6,r9 # add name offset
movl 4*pdfof(r9),r9 # load vrblk pointer for field
jsb prtvn # print field name
movl $ch$pp,r6 # load left paren
jsb prtch # print character
#page
#
# 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: cmpl (r10),$b$tet # jump if we got there (or not te)
bnequ prn04
movl 4*tenxt(r10),r10# else move out on chain
jmp 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: movl prnmv,r9 # point to vrblk we found last time
movl hshtb,r6 # point to hash table in case not
jmp prn07 # jump into search for special check
#
# LOOP THROUGH HASH SLOTS
#
prn05: movl r6,r9 # copy slot pointer
addl2 $4,r6 # bump slot pointer
subl2 $4*vrnxt,r9 # introduce standard vrblk offset
#
# LOOP THROUGH VRBLKS ON ONE HASH CHAIN
#
prn06: movl 4*vrnxt(r9),r9 # point to next vrblk on hash chain
#
# MERGE HERE FIRST TIME TO CHECK BLOCK WE FOUND LAST TIME
#
prn07: movl r9,r8 # copy vrblk pointer
beqlu prn09 # jump if chain end (or prnmv zero)
#page
#
# PRTNM (CONTINUED)
#
# LOOP TO FIND VALUE (CHASE DOWN POSSIBLE TRBLK CHAIN)
#
prn08: movl 4*vrval(r9),r9 # load value
cmpl (r9),$b$trt # loop if that was a trblk
beqlu prn08
#
# NOW WE HAVE THE VALUE, IS THIS THE BLOCK WE WANT
#
cmpl r9,r10 # jump if this matches the name base
beqlu prn10
movl r8,r9 # else point back to that vrblk
jmp prn06 # and loop back
#
# HERE TO MOVE TO NEXT HASH SLOT
#
prn09: cmpl r6,hshte # loop back if more to go
blssu prn05
movl r10,r9 # else not found, copy value pointer
jsb prtvl # print value
jmp prn11 # and merge ahead
#
# HERE WHEN WE FIND A MATCHING ENTRY
#
prn10: movl r8,r9 # copy vrblk pointer
movl r9,prnmv # save for next time in
jsb prtvn # print variable name
#
# MERGE HERE IF NO ENTRY FOUND
#
prn11: movl (r10),r8 # load first word of name base
cmpl r8,$b$pdt # jump if not program defined
bnequ prn13
#
# FOR PROGRAM DEFINED DATATYPE, ADD RIGHT PAREN AND EXIT
#
movl $ch$rp,r6 # load right paren, merge
#
# MERGE HERE TO PRINT FINAL RIGHT PAREN OR BRACKET
#
prn12: jsb prtch # print final character
movl r7,r6 # restore name offset
jmp prn01 # merge back to exit
#page
#
# PRTNM (CONTINUED)
#
# HERE FOR ARRAY OR TABLE
#
prn13: movl $ch$bb,r6 # load left bracket
jsb prtch # and print it
movl (sp),r10 # restore block pointer
movl (r10),r8 # load type word again
cmpl r8,$b$tet # jump if not table
bnequ prn15
#
# HERE FOR TABLE, PRINT SUBSCRIPT VALUE
#
movl 4*tesub(r10),r9 # load subscript value
movl r7,r10 # save name offset
jsb prtvl # print subscript value
movl r10,r7 # restore name offset
#
# MERGE HERE FROM ARRAY CASE TO PRINT RIGHT BRACKET
#
prn14: movl $ch$rb,r6 # load right bracket
jmp prn12 # merge back to print it
#
# HERE FOR ARRAY OR VECTOR, TO PRINT SUBSCRIPT(S)
#
prn15: movl r7,r6 # copy name offset
ashl $-2,r6,r6 # convert to words
cmpl r8,$b$art # jump if arblk
beqlu prn16
#
# HERE FOR VECTOR
#
subl2 $vcvlb,r6 # adjust for standard fields
movl r6,r5 # move to integer accum
jsb prtin # print linear subscript
jmp prn14 # merge back for right bracket
#page
#
# 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: movl 4*arofs(r10),r8 # load length of bounds info
addl2 $4,r8 # adjust for arpro field
ashl $-2,r8,r8 # convert to words
subl2 r8,r6 # get linear zero-origin subscript
movl r6,r5 # get integer value
movl 4*arndm(r10),r6 # set num of dimensions as loop count
addl2 4*arofs(r10),r10# point past bounds information
subl2 $4*arlbd,r10 # set ok offset for proper ptr later
#
# LOOP TO STACK SUBSCRIPT OFFSETS
#
prn17: subl2 $4*ardms,r10 # point to next set of bounds
movl r5,prnsi # save current offset
ashq $-32,r4,r4 # get remainder on dividing by dimens
ediv 4*ardim(r10),r4,r11,r5
movl r5,-(sp) # store on stack (one word)
movl prnsi,r5 # reload argument
divl2 4*ardim(r10),r5 # divide to get quotient
sobgtr r6,prn17 # loop till all stacked
clrl r9 # set offset to first set of bounds
movl 4*arndm(r10),r7 # load count of dims to control loop
jmp prn19 # jump into print loop
#
# LOOP TO PRINT SUBSCRIPTS FROM STACK ADJUSTING BY ADDING
# THE APPROPRIATE LOW BOUND VALUE FROM THE ARBLK
#
prn18: movl $ch$cm,r6 # load a comma
jsb prtch # print it
#
# MERGE HERE FIRST TIME IN (NO COMMA REQUIRED)
#
prn19: movl (sp)+,r5 # load subscript offset as integer
addl2 r9,r10 # point to current lbd
addl2 4*arlbd(r10),r5 # add lbd to get signed subscript
subl2 r9,r10 # point back to start of arblk
jsb prtin # print subscript
addl2 $4*ardms,r9 # bump offset to next bounds
sobgtr r7,prn18 # loop back till all printed
jmp prn14 # merge back to print right bracket
#enp # end procedure prtnm
#page
#
# 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 # entry point
jsb prtnm # print argument name
movl r9,-(sp) # save entry xr
movl r6,-(sp) # save name offset (collectable)
movl $tmbeb,r9 # point to blank equal blank
jsb prtst # print it
movl r10,r9 # copy name base
addl2 r6,r9 # point to value
movl (r9),r9 # load value pointer
jsb prtvl # print value
jsb prtnl # terminate line
movl (sp)+,r6 # restore name offset
movl (sp)+,r9 # restore entry xr
rsb # return to caller
#enp # end procedure prtnv
#page
#
# 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 # entry point
cmpl stage,$stgxt # jump if execution time
beqlu prp01
tstl lstlc # return if top of page already
bnequ 0f
jmp prp06
0:
clrl lstlc # clear line count
#
# CHECK TYPE OF LISTING
#
prp01: movl r9,-(sp) # preserve xr
tstl prstd # eject if flag set
bnequ prp02
tstl prich # jump if interactive listing channel
bnequ prp03
tstl precl # jump if compact listing
beqlu prp03
#
# PERFORM AN EJECT
#
prp02: jsb sysep # eject
jmp prp04 # merge
#
# COMPACT OR INTERACTIVE CHANNEL LISTING. CANT PRINT
# BLANKS UNTIL CHECK MADE FOR HEADERS PRINTED AND FLAG SET.
#
#
prp03: movl headp,r9 # remember headp
movl sp,headp # set to avoid repeated prtpg calls
jsb prtnl # print blank line
jsb prtnl # print blank line
jsb prtnl # print blank line
movl $num03,lstlc # count blank lines
movl r9,headp # restore header flag
#page
#
# PRPTG (CONTINUED)
#
# PRINT THE HEADING
#
prp04: tstl headp # jump if header listed
bnequ prp05
movl sp,headp # mark headers printed
movl r10,-(sp) # keep xl
movl $headr,r9 # point to listing header
jsb prtst # place it
jsb sysid # get system identification
jsb prtst # append extra chars
jsb prtnl # print it
movl r10,r9 # extra header line
jsb prtst # place it
jsb prtnl # print it
jsb prtnl # print a blank
jsb prtnl # and another
addl2 $num04,lstlc # four header lines printed
movl (sp)+,r10 # restore xl
#
# MERGE IF HEADER NOT PRINTED
#
prp05: movl (sp)+,r9 # restore xr
#
# RETURN
#
prp06: rsb # return
#enp # end procedure prtpg
#page
#
# 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 # entry point
movl prsto,prstd # copy option flag
jsb prtpg # print page
clrl prstd # clear flag
rsb # return
#enp # end procedure prtps
#page
#
# 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 # entry point
movl r9,-(sp) # save entry xr
movl r6,prsna # save entry wa
movl $tmasb,r9 # point to asterisks
jsb prtst # print asterisks
movl $num04,profs # point into middle of asterisks
movl kvstn,r5 # load statement number as integer
jsb prtin # print integer statement number
movl $prsnf,profs # point past asterisks plus blank
movl kvfnc,r9 # get fnclevel
movl $ch$li,r6 # set letter i
#
# LOOP TO GENERATE LETTER I FNCLEVEL TIMES
#
prsn1: tstl r9 # jump if all set
beqlu prsn2
jsb prtch # else print an i
decl r9 # decrement counter
jmp prsn1 # loop back
#
# MERRE WITH ALL LETTER I CHARACTERS GENERATED
#
prsn2: movl $ch$bl,r6 # get blank
jsb prtch # print blank
movl prsna,r6 # restore entry wa
movl (sp)+,r9 # restore entry xr
rsb # return to prtsn caller
#enp # end procedure prtsn
#page
#
# 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 # entry point
tstl headp # were headers printed
bnequ prst0
jsb prtps # no - print them
#
# CALL SYSPR
#
prst0: movl r6,prsva # save wa
movl r7,prsvb # save wb
clrl r7 # set chars printed count to zero
#
# LOOP TO PRINT SUCCESSIVE LINES FOR LONG STRING
#
prst1: movl 4*sclen(r9),r6 # load string length
subl2 r7,r6 # subtract count of chars already out
bnequ 0f # jump to exit if none left
jmp prst4
0:
movl r10,-(sp) # else stack entry xl
movl r9,-(sp) # save argument
movl r9,r10 # copy for eventual move
movl prlen,r9 # load print buffer length
subl2 profs,r9 # get chars left in print buffer
bnequ prst2 # skip if room left on this line
jsb prtnl # else print this line
movl prlen,r9 # and set full width available
#page
#
# PRTST (CONTINUED)
#
# HERE WITH CHARS TO PRINT AND SOME ROOM IN BUFFER
#
prst2: cmpl r6,r9 # jump if room for rest of string
blequ prst3
movl r9,r6 # else set to fill line
#
# MERGE HERE WITH CHARACTER COUNT IN WA
#
prst3: movl prbuf,r9 # point to print buffer
movab cfp$f(r10)[r7],r10 # point to location in string
movl profs,r11 # [get in scratch register]
movab cfp$f(r9)[r11],r9# point to location in buffer
addl2 r6,r7 # bump string chars count
addl2 r6,profs # bump buffer pointer
movl r7,prsvc # preserve char counter
jsb sbmvc # move characters to buffer
movl prsvc,r7 # recover char counter
movl (sp)+,r9 # restore argument pointer
movl (sp)+,r10 # restore entry xl
jmp prst1 # loop back to test for more
#
# HERE TO EXIT AFTER PRINTING STRING
#
prst4: movl prsvb,r7 # restore entry wb
movl prsva,r6 # restore entry wa
rsb # return to prtst caller
#enp # end procedure prtst
#page
#
# 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 # entry point
movl r9,-(sp) # save xr
jsb prtic # print buffer contents
movl prbuf,r9 # point to print bfr to clear it
movl prlnw,r6 # get buffer length
addl2 $4*schar,r9 # point past scblk header
movl nullw,r7 # get blanks
#
# LOOP TO CLEAR BUFFER
#
prtt1: movl r7,(r9)+ # clear a word
sobgtr r6,prtt1 # loop
clrl profs # reset profs
movl (sp)+,r9 # restore xr
rsb # return
#enp # end procedure prttr
#page
#
# 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 # entry point, recursive
movl r10,-(sp) # save entry xl
movl r9,-(sp) # save argument
jsb sbchk # check for stack overflow
#
# LOOP BACK HERE AFTER FINDING A TRAP BLOCK (TRBLK)
#
prv01: movl 4*idval(r9),prvsi# copy idval (if any)
movl (r9),r10 # load first word of block
movzwl -2(r10),r10 # load entry point id
casel r10,$0,$bl$$t # switch on block type
5:
.word prv05-5b # arblk
.word prv15-5b # bcblk
.word prv02-5b
.word prv02-5b
.word prv08-5b # icblk
.word prv09-5b # nmblk
.word prv02-5b
.word prv02-5b
.word prv02-5b
.word prv08-5b # rcblk
.word prv11-5b # scblk
.word prv12-5b # seblk
.word prv13-5b # tbblk
.word prv13-5b # vcblk
.word prv02-5b
.word prv02-5b
.word prv10-5b # pdblk
.word prv04-5b # trblk
#esw # end of switch on block type
#
# HERE FOR BLOCKS FOR WHICH WE JUST PRINT DATATYPE NAME
#
prv02: jsb dtype # get datatype name
jsb prtst # print datatype name
#
# COMMON EXIT POINT
#
prv03: movl (sp)+,r9 # reload argument
movl (sp)+,r10 # restore xl
rsb # return to prtvl caller
#
# HERE FOR TRBLK
#
prv04: movl 4*trval(r9),r9 # load real value
jmp prv01 # and loop back
#page
#
# PRTVL (CONTINUED)
#
# HERE FOR ARRAY (ARBLK)
#
# PRINT ARRAY ( PROTOTYPE ) BLANK NUMBER IDVAL
#
prv05: movl r9,r10 # preserve argument
movl $scarr,r9 # point to datatype name (array)
jsb prtst # print it
movl $ch$pp,r6 # load left paren
jsb prtch # print left paren
addl2 4*arofs(r10),r10# point to prototype
movl (r10),r9 # load prototype
jsb prtst # print prototype
#
# VCBLK, TBBLK, BCBLK MERGE HERE FOR ) BLANK NUMBER IDVAL
#
prv06: movl $ch$rp,r6 # load right paren
jsb prtch # print right paren
#
# PDBLK MERGES HERE TO PRINT BLANK NUMBER IDVAL
#
prv07: movl $ch$bl,r6 # load blank
jsb prtch # print it
movl $ch$nm,r6 # load number sign
jsb prtch # print it
movl prvsi,r5 # get idval
jsb prtin # print id number
jmp prv03 # back to exit
#
# HERE FOR INTEGER (ICBLK), REAL (RCBLK)
#
# PRINT CHARACTER REPRESENTATION OF VALUE
#
prv08: movl r9,-(sp) # stack argument for gtstg
jsb gtstg # convert to string
.long invalid$ # error return is impossible
jsb prtst # print the string
movl r9,dnamp # delete garbage string from storage
jmp prv03 # back to exit
#page
#
# PRTVL (CONTINUED)
#
# NAME (NMBLK)
#
# FOR PSEUDO-VARIABLE, JUST PRINT DATATYPE NAME (NAME)
# FOR ALL OTHER NAMES, PRINT DOT FOLLOWED BY NAME REP
#
prv09: movl 4*nmbas(r9),r10 # load name base
movl (r10),r6 # load first word of block
cmpl r6,$b$kvt # just print name if keyword
bnequ 0f
jmp prv02
0:
cmpl r6,$b$evt # just print name if expression var
bnequ 0f
jmp prv02
0:
movl $ch$dt,r6 # else get dot
jsb prtch # and print it
movl 4*nmofs(r9),r6 # load name offset
jsb prtnm # print name
jmp prv03 # back to exit
#
# PROGRAM DATATYPE (PDBLK)
#
# PRINT DATATYPE NAME CH$BL CH$NM IDVAL
#
prv10: jsb dtype # get datatype name
jsb prtst # print datatype name
jmp prv07 # merge back to print id
#
# HERE FOR STRING (SCBLK)
#
# PRINT QUOTE STRING-CHARACTERS QUOTE
#
prv11: movl $ch$sq,r6 # load single quote
jsb prtch # print quote
jsb prtst # print string value
jsb prtch # print another quote
jmp prv03 # back to exit
#page
#
# PRTVL (CONTINUED)
#
# HERE FOR SIMPLE EXPRESSION (SEBLK)
#
# PRINT ASTERISK VARIABLE-NAME
#
prv12: movl $ch$as,r6 # load asterisk
jsb prtch # print asterisk
movl 4*sevar(r9),r9 # load variable pointer
jsb prtvn # print variable name
jmp prv03 # jump back to exit
#
# HERE FOR TABLE (TBBLK) AND ARRAY (VCBLK)
#
# PRINT DATATYPE ( PROTOTYPE ) BLANK NUMBER IDVAL
#
prv13: movl r9,r10 # preserve argument
jsb dtype # get datatype name
jsb prtst # print datatype name
movl $ch$pp,r6 # load left paren
jsb prtch # print left paren
movl 4*tblen(r10),r6 # load length of block (=vclen)
ashl $-2,r6,r6 # convert to word count
subl2 $tbsi$,r6 # allow for standard fields
cmpl (r10),$b$tbt # jump if table
beqlu prv14
addl2 $vctbd,r6 # for vcblk, adjust size
#
# PRINT PROTOTYPE
#
prv14: movl r6,r5 # move as integer
jsb prtin # print integer prototype
jmp prv06 # merge back for rest
#page
#
# PRTVL (CONTINUED)
#
# HERE FOR BUFFER (BCBLK)
#
prv15: movl r9,r10 # preserve argument
movl $scbuf,r9 # point to datatype name (buffer)
jsb prtst # print it
movl $ch$pp,r6 # load left paren
jsb prtch # print left paren
movl 4*bcbuf(r10),r9 # point to bfblk
movl 4*bfalc(r9),r5 # load allocation size
jsb prtin # print it
movl $ch$cm,r6 # load comma
jsb prtch # print it
movl 4*bclen(r10),r5 # load defined length
jsb prtin # print it
jmp prv06 # merge to finish up
#enp # end procedure prtvl
#page
#
# 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 # entry point
movl r9,-(sp) # stack vrblk pointer
addl2 $4*vrsof,r9 # point to possible string name
tstl 4*sclen(r9) # jump if not system variable
bnequ prvn1
movl 4*vrsvo(r9),r9 # point to svblk with name
#
# MERGE HERE WITH DUMMY SCBLK POINTER IN XR
#
prvn1: jsb prtst # print string name of variable
movl (sp)+,r9 # restore vrblk pointer
rsb # return to prtvn caller
#enp # end procedure prtvn
#page
#
# 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 # entry point
movl dnamp,r9 # load pointer to next available loc
addl2 $4*rcsi$,r9 # point past new rcblk
cmpl r9,dname # jump if there is room
blequ rcbl1
movl $4*rcsi$,r6 # else load rcblk length
jsb alloc # use standard allocator to get block
addl2 r6,r9 # point past block to merge
#
# MERGE HERE WITH XR POINTING PAST THE BLOCK OBTAINED
#
rcbl1: movl r9,dnamp # set new pointer
subl2 $4*rcsi$,r9 # point back to start of block
movl $b$rcl,(r9) # store type word
movf r2,4*rcval(r9) # store real value in rcblk
rsb # return to rcbld caller
#enp # end procedure rcbld
#page
#
# 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 # entry point
movl r$cni,r9 # get ptr to next image
bnequ read3 # exit if already read
cmpl stage,$stgic # exit if not initial compile
bnequ read3
movl cswin,r6 # max read length
jsb alocs # allocate buffer
jsb sysrd # read input image
.long read4 # jump if end of file
movl sp,r7 # set trimr to perform trim
cmpl 4*sclen(r9),cswin# use smaller of string lnth ..
blequ read1
movl cswin,4*sclen(r9)# ... and xxx of -inxxx
#
# PERFORM THE TRIM
#
read1: jsb trimr # trim trailing blanks
#
# MERGE HERE AFTER READ
#
read2: movl r9,r$cni # store copy of pointer
#
# MERGE HERE IF NO READ ATTEMPTED
#
read3: rsb # return to readr caller
#
# HERE ON END OF FILE
#
read4: movl r9,dnamp # pop unused scblk
clrl r9 # zero ptr as result
jmp read2 # merge
#enp # end procedure readr
#page
#
# 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 # entry point
tstl r6 # jump if null substring
beqlu sbst2
jsb alocs # else allocate scblk
movl r8,r6 # move number of characters
movl r9,r8 # save ptr to new scblk
movab cfp$f(r10)[r7],r10 # prepare to load chars from old blk
movab cfp$f(r9),r9 # prepare to store chars in new blk
jsb sbmvc # move characters to new string
movl r8,r9 # then restore scblk pointer
#
# RETURN POINT
#
sbst1: clrl r10 # clear garbage pointer in xl
rsb # return to sbstr caller
#
# HERE FOR NULL SUBSTRING
#
sbst2: movl $nulls,r9 # set null string as result
jmp sbst1 # return
#enp # end procedure sbstr
#page
#
# 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).
#page
#
# 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
#page
#
# SCANE (CONTINUED)
#
# ENTRY POINT
#
scane: #prc # entry point
clrl scnbl # reset blanks flag
movl r6,scnsa # save wa
movl r7,scnsb # save wb
movl r8,scnsc # save wc
tstl scnrs # jump if no rescan
beqlu scn03
#
# HERE FOR RESCAN REQUEST
#
movl scntp,r10 # set previous returned scan type
movl r$scp,r9 # set previous returned pointer
clrl scnrs # reset rescan switch
jmp scn13 # jump to exit
#
# COME HERE TO READ NEW IMAGE TO TEST FOR CONTINUATION
#
scn01: jsb readr # read next image
movl $4*dvubs,r7 # set wb for not reading name
tstl r9 # treat as semi-colon if none
bnequ 0f
jmp scn30
0:
movab cfp$f(r9),r9 # else point to first character
movzbl (r9),r8 # load first character
cmpl r8,$ch$dt # jump if dot for continuation
beqlu scn02
cmpl r8,$ch$pl # else treat as semicolon unless plus
beqlu 0f
jmp scn30
0:
#
# HERE FOR CONTINUATION LINE
#
scn02: jsb nexts # acquire next source image
movl $num01,scnpt # set scan pointer past continuation
movl sp,scnbl # set blanks flag
#page
#
# SCANE (CONTINUED)
#
# MERGE HERE TO SCAN NEXT ELEMENT ON CURRENT LINE
#
scn03: movl scnpt,r6 # load current offset
cmpl r6,scnil # check continuation if end
bnequ 0f
jmp scn01
0:
movl r$cim,r10 # point to current line
movab cfp$f(r10)[r6],r10 # point to current character
movl r6,scnse # set start of element location
movl $opdvs,r8 # point to operator dv list
movl $4*dvubs,r7 # set constant for operator circuit
jmp scn06 # start scanning
#
# LOOP HERE TO IGNORE LEADING BLANKS AND TABS
#
scn05: tstl r7 # jump if trailing
bnequ 0f
jmp scn10
0:
incl scnse # increment start of element
cmpl r6,scnil # jump if end of image
bnequ 0f
jmp scn01
0:
movl sp,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: movzbl (r10)+,r9 # get next character
incl r6 # bump scan offset
movl r6,scnpt # store offset past char scanned
cmpl $cfp$u,r9 # quick check for other char
bgtru 0f
jmp scn07
0:
casel r9,$0,$cfp$u # switch on scanned character
5:
#
# SWITCH TABLE FOR SWITCH ON CHARACTER
#
#page
#
# SCANE (CONTINUED)
#
#page
#
# SCANE (CONTINUED)
#
.word scn07-5b
.word scn07-5b
.word scn07-5b
.word scn07-5b
.word scn07-5b
.word scn07-5b
.word scn07-5b
.word scn07-5b
.word scn07-5b
.word scn05-5b # horizontal tab
.word scn07-5b
.word scn07-5b
.word scn07-5b
.word scn07-5b
.word scn07-5b
.word scn07-5b
.word scn07-5b
.word scn07-5b
.word scn07-5b
.word scn07-5b
.word scn07-5b
.word scn07-5b
.word scn07-5b
.word scn07-5b
.word scn07-5b
.word scn07-5b
.word scn07-5b
.word scn07-5b
.word scn07-5b
.word scn07-5b
.word scn07-5b
.word scn07-5b
.word scn05-5b # blank
.word scn37-5b # exclamation mark
.word scn17-5b # double quote
.word scn41-5b # number sign
.word scn36-5b # dollar
.word scn38-5b # percent
.word scn44-5b # ampersand
.word scn16-5b # single quote
.word scn25-5b # left paren
.word scn26-5b # right paren
.word scn49-5b # asterisk
.word scn33-5b # plus
.word scn31-5b # comma
.word scn34-5b # minus
.word scn32-5b # dot
.word scn40-5b # slash
.word scn08-5b # digit 0
.word scn08-5b # digit 1
.word scn08-5b # digit 2
.word scn08-5b # digit 3
.word scn08-5b # digit 4
.word scn08-5b # digit 5
.word scn08-5b # digit 6
.word scn08-5b # digit 7
.word scn08-5b # digit 8
.word scn08-5b # digit 9
.word scn29-5b # colon
.word scn30-5b # semi-colon
.word scn28-5b # left bracket
.word scn46-5b # equal
.word scn27-5b # right bracket
.word scn45-5b # question mark
.word scn42-5b # at
.word scn09-5b # letter a
.word scn09-5b # letter b
.word scn09-5b # letter c
.word scn09-5b # letter d
.word scn09-5b # letter e
.word scn20-5b # letter f
.word scn09-5b # letter g
.word scn09-5b # letter h
.word scn09-5b # letter i
.word scn09-5b # letter j
.word scn09-5b # letter k
.word scn09-5b # letter l
.word scn09-5b # letter m
.word scn09-5b # letter n
.word scn09-5b # letter o
.word scn09-5b # letter p
.word scn09-5b # letter q
.word scn09-5b # letter r
.word scn21-5b # letter s
.word scn09-5b # letter t
.word scn09-5b # letter u
.word scn09-5b # letter v
.word scn09-5b # letter w
.word scn09-5b # letter x
.word scn09-5b # letter y
.word scn09-5b # letter z
.word scn28-5b # left bracket
.word scn07-5b
.word scn27-5b # right bracket
.word scn07-5b
.word scn24-5b # underline
.word scn07-5b
.word scn09-5b # shifted a
.word scn09-5b # shifted b
.word scn09-5b # shifted c
.word scn09-5b # shifted d
.word scn09-5b # shifted e
.word scn20-5b # shifted f
.word scn09-5b # shifted g
.word scn09-5b # shifted h
.word scn09-5b # shifted i
.word scn09-5b # shifted j
.word scn09-5b # shifted k
.word scn09-5b # shifted l
.word scn09-5b # shifted m
.word scn09-5b # shifted n
.word scn09-5b # shifted o
.word scn09-5b # shifted p
.word scn09-5b # shifted q
.word scn09-5b # shifted r
.word scn21-5b # shifted s
.word scn09-5b # shifted t
.word scn09-5b # shifted u
.word scn09-5b # shifted v
.word scn09-5b # shifted w
.word scn09-5b # shifted x
.word scn09-5b # shifted y
.word scn09-5b # shifted z
.word scn07-5b
.word scn43-5b # vertical bar
.word scn07-5b
.word scn35-5b # not
.word scn07-5b
#esw # end switch on character
#
# HERE FOR ILLEGAL CHARACTER (UNDERLINE MERGES)
#
scn07: tstl r7 # jump if scanning name or constant
bnequ 0f
jmp scn10
0:
jmp er_230 # syntax error. illegal character
#page
#
# SCANE (CONTINUED)
#
# HERE FOR DIGITS 0-9
#
scn08: tstl r7 # keep scanning if name/constant
bnequ 0f
jmp scn09
0:
clrl r8 # else set flag for scanning constant
#
# HERE FOR LETTER. LOOP HERE WHEN SCANNING NAME/CONSTANT
#
scn09: cmpl r6,scnil # jump if end of image
beqlu scn11
clrl r7 # set flag for scanning name/const
jmp scn06 # merge back to continue scan
#
# COME HERE FOR DELIMITER ENDING NAME OR CONSTANT
#
scn10: decl r6 # reset offset to point to delimiter
#
# COME HERE AFTER FINISHING SCAN OF NAME OR CONSTANT
#
scn11: movl r6,scnpt # store updated scan offset
movl scnse,r7 # point to start of element
subl2 r7,r6 # get number of characters
movl r$cim,r10 # point to line image
tstl r8 # jump if name
bnequ scn15
#
# HERE AFTER SCANNING OUT NUMERIC CONSTANT
#
jsb sbstr # get string for constant
movl r9,dnamp # delete from storage (not needed)
jsb gtnum # convert to numeric
.long scn14 # jump if conversion failure
#
# MERGE HERE TO EXIT WITH CONSTANT
#
scn12: movl $t$con,r10 # set result type of constant
#page
#
# SCANE (CONTINUED)
#
# COMMON EXIT POINT (XR,XL) SET
#
scn13: movl scnsa,r6 # restore wa
movl scnsb,r7 # restore wb
movl scnsc,r8 # restore wc
movl r9,r$scp # save xr in case rescan
movl r10,scntp # save xl in case rescan
clrl scngo # reset possible goto flag
rsb # return to scane caller
#
# HERE IF CONVERSION ERROR ON NUMERIC ITEM
#
scn14: jmp er_231 # syntax error. invalid numeric item
#
# HERE AFTER SCANNING OUT VARIABLE NAME
#
scn15: jsb sbstr # build string name of variable
tstl scncc # return if cncrd call
beqlu 0f
jmp scn13
0:
jsb gtnvr # locate/build vrblk
.long invalid$ # dummy (unused) error return
movl $t$var,r10 # set type as variable
jmp scn13 # back to exit
#
# HERE FOR SINGLE QUOTE (START OF STRING CONSTANT)
#
scn16: tstl r7 # terminator if scanning name or cnst
bnequ 0f
jmp scn10
0:
movl $ch$sq,r7 # set terminator as single quote
jmp scn18 # merge
#
# HERE FOR DOUBLE QUOTE (START OF STRING CONSTANT)
#
scn17: tstl r7 # terminator if scanning name or cnst
bnequ 0f
jmp scn10
0:
movl $ch$dq,r7 # set double quote terminator, merge
#
# LOOP TO SCAN OUT STRING CONSTANT
#
scn18: cmpl r6,scnil # error if end of image
beqlu scn19
movzbl (r10)+,r8 # else load next character
incl r6 # bump offset
cmpl r8,r7 # loop back if not terminator
bnequ scn18
#page
#
# SCANE (CONTINUED)
#
# HERE AFTER SCANNING OUT STRING CONSTANT
#
movl scnpt,r7 # point to first character
movl r6,scnpt # save offset past final quote
decl r6 # point back past last character
subl2 r7,r6 # get number of characters
movl r$cim,r10 # point to input image
jsb sbstr # build substring value
jmp scn12 # back to exit with constant result
#
# HERE IF NO MATCHING QUOTE FOUND
#
scn19: movl r6,scnpt # set updated scan pointer
jmp er_232 # syntax error. unmatched string quote
#
# HERE FOR F (POSSIBLE FAILURE GOTO)
#
scn20: movl $t$fgo,r9 # set return code for fail goto
jmp scn22 # jump to merge
#
# HERE FOR S (POSSIBLE SUCCESS GOTO)
#
scn21: movl $t$sgo,r9 # set success goto as return code
#
# SPECIAL GOTO CASES MERGE HERE
#
scn22: tstl scngo # treat as normal letter if not goto
bnequ 0f
jmp scn09
0:
#
# MERGE HERE FOR SPECIAL CHARACTER EXIT
#
scn23: tstl r7 # jump if end of name/constant
bnequ 0f
jmp scn10
0:
movl r9,r10 # else copy code
jmp scn13 # and jump to exit
#
# HERE FOR UNDERLINE
#
scn24: tstl r7 # part of name if scanning name
bnequ 0f
jmp scn09
0:
jmp scn07 # else illegal
#page
#
# SCANE (CONTINUED)
#
# HERE FOR LEFT PAREN
#
scn25: movl $t$lpr,r9 # set left paren return code
tstl r7 # return left paren unless name
bnequ scn23
tstl r8 # delimiter if scanning constant
bnequ 0f
jmp scn10
0:
#
# HERE FOR LEFT PAREN AFTER NAME (FUNCTION CALL)
#
movl scnse,r7 # point to start of name
movl r6,scnpt # set pointer past left paren
decl r6 # point back past last char of name
subl2 r7,r6 # get name length
movl r$cim,r10 # point to input image
jsb sbstr # get string name for function
jsb gtnvr # locate/build vrblk
.long invalid$ # dummy (unused) error return
movl $t$fnc,r10 # set code for function call
jmp scn13 # back to exit
#
# PROCESSING FOR SPECIAL CHARACTERS
#
scn26: movl $t$rpr,r9 # right paren, set code
jmp scn23 # take special character exit
#
scn27: movl $t$rbr,r9 # right bracket, set code
jmp scn23 # take special character exit
#
scn28: movl $t$lbr,r9 # left bracket, set code
jmp scn23 # take special character exit
#
scn29: movl $t$col,r9 # colon, set code
jmp scn23 # take special character exit
#
scn30: movl $t$smc,r9 # semi-colon, set code
jmp scn23 # take special character exit
#
scn31: movl $t$cma,r9 # comma, set code
jmp scn23 # take special character exit
#page
#
# 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: tstl r7 # dot can be part of name or constant
bnequ 0f
jmp scn09
0:
addl2 r7,r8 # else bump pointer
#
scn33: tstl r8 # plus can be part of constant
bnequ 0f
jmp scn09
0:
tstl r7 # plus cannot be part of name
bnequ 0f
jmp scn48
0:
addl2 r7,r8 # else bump pointer
#
scn34: tstl r8 # minus can be part of constant
bnequ 0f
jmp scn09
0:
tstl r7 # minus cannot be part of name
bnequ 0f
jmp scn48
0:
addl2 r7,r8 # else bump pointer
#
scn35: addl2 r7,r8 # not
scn36: addl2 r7,r8 # dollar
scn37: addl2 r7,r8 # exclamation
scn38: addl2 r7,r8 # percent
scn39: addl2 r7,r8 # asterisk
scn40: addl2 r7,r8 # slash
scn41: addl2 r7,r8 # number sign
scn42: addl2 r7,r8 # at sign
scn43: addl2 r7,r8 # vertical bar
scn44: addl2 r7,r8 # ampersand
scn45: addl2 r7,r8 # question mark
#
# ALL OPERATORS COME HERE (EQUAL MERGES DIRECTLY)
# (WC) POINTS TO THE BINARY/UNARY PAIR OF OPERATOR DVBLKS.
#
scn46: tstl r7 # operator terminates name/constant
bnequ 0f
jmp scn10
0:
movl r8,r9 # else copy dv pointer
movzbl (r10),r8 # load next character
movl $t$bop,r10 # set binary op in case
cmpl r6,scnil # should be binary if image end
beqlu scn47
cmpl r8,$ch$bl # should be binary if followed by blk
beqlu scn47
cmpl r8,$ch$ht # jump if horizontal tab
beqlu scn47
cmpl r8,$ch$sm # semicolon can immediately follow =
beqlu scn47
#
# HERE FOR UNARY OPERATOR
#
addl2 $4*dvbs$,r9 # point to dv for unary op
movl $t$uop,r10 # set type for unary operator
cmpl scntp,$t$uok # ok unary if ok preceding element
bgtru 0f
jmp scn13
0:
#page
#
# SCANE (CONTINUED)
#
# MERGE HERE TO REQUIRE PRECEDING BLANKS
#
scn47: tstl scnbl # all ok if preceding blanks, exit
beqlu 0f
jmp scn13
0:
#
# FAIL OPERATOR IN THIS POSITION
#
scn48: jmp er_233 # syntax error. invalid use of operator
#
# HERE FOR ASTERISK, COULD BE ** SUBSTITUTE FOR EXCLAMATION
#
scn49: tstl r7 # end of name if scanning name
bnequ 0f
jmp scn10
0:
cmpl r6,scnil # not ** if * at image end
beqlu scn39
movl r6,r9 # else save offset past first *
movl r6,scnof # save another copy
movzbl (r10)+,r6 # load next character
cmpl r6,$ch$as # not ** if next char not *
bnequ scn50
incl r9 # else step offset past second *
cmpl r9,scnil # ok exclam if end of image
beqlu scn51
movzbl (r10),r6 # else load next character
cmpl r6,$ch$bl # exclamation if blank
beqlu scn51
cmpl r6,$ch$ht # exclamation if horizontal tab
beqlu scn51
#
# UNARY *
#
scn50: movl scnof,r6 # recover stored offset
movl r$cim,r10 # point to line again
movab cfp$f(r10)[r6],r10 # point to current char
jmp scn39 # merge with unary *
#
# HERE FOR ** AS SUBSTITUTE FOR EXCLAMATION
#
scn51: movl r9,scnpt # save scan pointer past 2nd *
movl r9,r6 # copy scan pointer
jmp scn37 # merge with exclamation
#enp # end procedure scane
#page
#
# 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 # entry point
jsb scane # scan initial element
cmpl r10,$t$lpr # skip if left paren (normal goto)
beqlu scng1
cmpl r10,$t$lbr # skip if left bracket (direct goto)
beqlu scng2
jmp er_234 # syntax error. goto field incorrect
#
# HERE FOR LEFT PAREN (NORMAL GOTO)
#
scng1: movl $num01,r7 # set expan flag for normal goto
jsb expan # analyze goto field
movl $opdvn,r6 # point to opdv for complex goto
cmpl r9,statb # jump if not in static (sgd15)
blequ scng3
cmpl r9,state # jump to exit if simple label name
blequ scng4
jmp scng3 # complex goto - merge
#
# HERE FOR LEFT BRACKET (DIRECT GOTO)
#
scng2: movl $num02,r7 # set expan flag for direct goto
jsb expan # scan goto field
movl $opdvd,r6 # set opdv pointer for direct goto
#page
#
# SCNGF (CONTINUED)
#
# MERGE HERE TO BUILD OUTER UNARY OPERATOR BLOCK
#
scng3: movl r6,-(sp) # stack operator dv pointer
movl r9,-(sp) # stack pointer to expression tree
jsb expop # pop operator off
movl (sp)+,r9 # reload new expression tree pointer
#
# COMMON EXIT POINT
#
scng4: rsb # return to caller
#enp # end procedure scngf
#page
#
# 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 # entry point
cmpl r9,state # exit if not natural variable
bgequ setv1
#
# HERE IF WE HAVE A VRBLK
#
movl r9,r10 # copy vrblk pointer
movl $b$vrl,4*vrget(r9) # store normal get value
cmpl 4*vrsto(r9),$b$vre # skip if protected variable
beqlu setv1
movl $b$vrs,4*vrsto(r9) # store normal store value
movl 4*vrval(r10),r10# point to next entry on chain
cmpl (r10),$b$trt # jump if end of trblk chain
bnequ setv1
movl $b$vra,4*vrget(r9) # store trapped routine address
movl $b$vrv,4*vrsto(r9) # set trapped routine address
#
# MERGE HERE TO EXIT TO CALLER
#
setv1: rsb # return to setvr caller
#enp # end procedure setvr
#page
#
# 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
#page
#
# SORTA (CONTINUED)
#
.data 1
sorta_s: .long 0
.text 0
sorta: movl (sp)+,sorta_s # entry point
movl r6,srtsr # sort/rsort indicator
movl $4*num01,srtst # default stride of 1
clrl srtof # default zero offset to sort key
movl $nulls,srtdf # clear datatype field name
movl (sp)+,r$sxr # unstack argument 2
movl (sp)+,r9 # get first argument
jsb gtarr # convert to array
.long srt16 # fail
movl r9,-(sp) # stack ptr to resulting key array
movl r9,-(sp) # another copy for copyb
jsb copyb # get copy array for sorting into
.long invalid$ # cant fail
movl r9,-(sp) # stack pointer to sort array
movl r$sxr,r9 # get second arg
movl 4*1(sp),r10 # get ptr to key array
cmpl (r10),$b$vct # jump if arblk
bnequ srt02
cmpl r9,$nulls # jump if null second arg
beqlu srt01
jsb gtnvr # get vrblk ptr for it
.long er_257 # erroneous 2nd arg in sort/rsort of vector
movl r9,srtdf # store datatype field name vrblk
#
# COMPUTE N AND OFFSET TO ITEM A(0) IN VECTOR CASE
#
srt01: movl $4*vclen,r8 # offset to a(0)
movl $4*vcvls,r7 # offset to first item
movl 4*vclen(r10),r6 # get block length
subl2 $4*vcsi$,r6 # get no. of entries, n (in bytes)
jmp srt04 # merge
#
# HERE FOR ARRAY
#
srt02: movl 4*ardim(r10),r5 # get possible dimension
movl r5,r6 # convert to short integer
moval 0[r6],r6 # further convert to baus
movl $4*arvls,r7 # offset to first value if one
movl $4*arpro,r8 # offset before values if one dim.
cmpl 4*arndm(r10),$num01 # jump in fact if one dim.
bnequ 0f
jmp srt04
0:
cmpl 4*arndm(r10),$num02 # fail unless two dimens
beqlu 0f
jmp srt16
0:
movl 4*arlb2(r10),r5 # get lower bound 2 as default
cmpl r9,$nulls # jump if default second arg
beqlu srt03
jsb gtint # convert to integer
.long srt17 # fail
movl 4*icval(r9),r5 # get actual integer value
#page
#
# SORTA (CONTINUED)
#
# HERE WITH SORT COLUMN INDEX IN IA IN ARRAY CASE
#
srt03: subl2 4*arlb2(r10),r5 # subtract low bound
bvc 0f
jmp srt17
0:
tstl r5 # fail if below low bound
bgeq 0f
jmp srt17
0:
subl2 4*ardm2(r10),r5 # check against dimension
blss 0f # fail if too large
jmp srt17
0:
addl2 4*ardm2(r10),r5 # restore value
movl r5,r6 # get as small integer
moval 0[r6],r6 # offset within row to key
movl r6,srtof # keep offset
movl 4*ardm2(r10),r5 # second dimension is row length
movl r5,r6 # convert to short integer
movl r6,r9 # copy row length
moval 0[r6],r6 # convert to bytes
movl r6,srtst # store as stride
movl 4*ardim(r10),r5 # get number of rows
movl r5,r6 # as a short integer
moval 0[r6],r6 # convert n to baus
movl 4*arlen(r10),r8 # offset past array end
subl2 r6,r8 # adjust, giving space for n offsets
subl2 $4,r8 # point to a(0)
movl 4*arofs(r10),r7 # offset to word before first item
addl2 $4,r7 # 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: cmpl r6,$4*num01 # return if only a single item
bgtru 0f
jmp srt15
0:
movl r6,srtsn # store number of items (in baus)
movl r8,srtso # store offset to a(0)
movl 4*arlen(r10),r8 # length of array or vec (=vclen)
addl2 r10,r8 # point past end of array or vector
movl r7,srtsf # store offset to first row
addl2 r7,r10 # point to first item in key array
#
# LOOP THROUGH ARRAY
#
srt05: movl (r10),r9 # get an entry
#
# HUNT ALONG TRBLK CHAIN
#
srt06: cmpl (r9),$b$trt # jump out if not trblk
bnequ srt07
movl 4*trval(r9),r9 # get value field
jmp srt06 # loop
#page
#
# SORTA (CONTINUED)
#
# XR IS VALUE FROM END OF CHAIN
#
srt07: movl r9,(r10)+ # store as array entry
cmpl r10,r8 # loop if not done
blssu srt05
movl (sp),r10 # get adrs of sort array
movl srtsf,r9 # initial offset to first key
movl srtst,r7 # get stride
addl2 srtso,r10 # offset to a(0)
addl2 $4,r10 # point to a(1)
movl srtsn,r8 # get n
ashl $-2,r8,r8 # convert from bytes
movl r8,srtnr # store as row count
# loop counter
#
# STORE KEY OFFSETS AT TOP OF SORT ARRAY
#
srt08: movl r9,(r10)+ # store an offset
addl2 r7,r9 # bump offset by stride
sobgtr r8,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: movl srtsn,r6 # get n
movl srtnr,r8 # get number of rows
ashl $-1,r8,r8 # i = n / 2 (wc=i, index into array)
moval 0[r8],r8 # convert back to bytes
#
# LOOP TO FORM INITIAL HEAP
#
srt10: jsb sorth # sorth(i,n)
subl2 $4,r8 # i = i - 1
bnequ srt10 # loop if i gt 0
movl r6,r8 # 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: subl2 $4,r8 # i = i - 1 (n - 1 initially)
beqlu srt12 # jump if done
movl (sp),r9 # get sort array address
addl2 srtso,r9 # point to a(0)
movl r9,r10 # a(0) address
addl2 r8,r10 # a(i) address
movl 4*1(r10),r7 # copy a(i+1)
movl 4*1(r9),4*1(r10)# move a(1) to a(i+1)
movl r7,4*1(r9) # complete exchange of a(1), a(i+1)
movl r8,r6 # n = i for sorth
movl $4*num01,r8 # i = 1 for sorth
jsb sorth # sorth(1,n)
movl r6,r8 # restore wc
jmp srt11 # loop
#page
#
# SORTA (CONTINUED)
#
# OFFSETS HAVE BEEN PERMUTED INTO REQUIRED ORDER BY SORT.
# COPY ARRAY ELEMENTS OVER THEM.
#
srt12: movl (sp),r10 # base adrs of key array
movl r10,r8 # copy it
addl2 srtso,r8 # offset of a(0)
addl2 srtsf,r10 # adrs of first row of sort array
movl srtst,r7 # get stride
ashl $-2,r7,r7 # convert to words
#
# COPYING LOOP FOR SUCCESSIVE ITEMS. SORTED OFFSETS ARE
# HELD AT END OF SORT ARRAY.
#
srt13: addl2 $4,r8 # adrs of next of sorted offsets
movl r8,r9 # copy it for access
movl (r9),r9 # get offset
addl2 4*1(sp),r9 # add key array base adrs
movl r7,r6 # get count of words in row
#
# COPY A COMPLETE ROW
#
srt14: movl (r9)+,(r10)+ # move a word
sobgtr r6,srt14 # loop
decl srtnr # decrement row count
bnequ srt13 # repeat till all rows done
#
# RETURN POINT
#
srt15: movl (sp)+,r9 # pop result array ptr
addl2 $4,sp # pop key array ptr
clrl r$sxl # clear junk
clrl r$sxr # clear junk
jmp *sorta_s # return
#
# ERROR POINT
#
srt16: jmp er_256 # sort/rsort 1st arg not suitable array or table
srt17: jmp er_258 # sort/rsort 2nd arg out of range or non-integer
#enp # end procudure sorta
#page
#
# 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 # entry point
movl r6,srts1 # save offset 1
movl r7,srts2 # save offset 2
movl r8,srtsc # save wc
addl2 srtof,r10 # add offset to comparand field
movl r10,r9 # copy base + offset
addl2 r6,r10 # add key1 offset
addl2 r7,r9 # add key2 offset
movl (r10),r10 # get key1
movl (r9),r9 # get key2
cmpl srtdf,$nulls # jump if datatype field name used
beqlu 0f
jmp src11
0:
#page
#
# SORTC (CONTINUED)
#
# MERGE AFTER DEALING WITH FIELD NAME. TRY FOR STRINGS.
#
src01: movl (r10),r8 # get type code
cmpl r8,(r9) # skip if not same datatype
bnequ src02
cmpl r8,$b$scl # jump if both strings
beqlu src09
#
# NOW TRY FOR NUMERIC
#
src02: movl r10,r$sxl # keep arg1
movl r9,r$sxr # keep arg2
movl r10,-(sp) # stack
movl r9,-(sp) # args
jsb acomp # compare objects
.long src10 # not numeric
.long src10 # not numeric
.long src03 # key1 less
.long src08 # keys equal
.long src05 # key1 greater
#
# RETURN IF KEY1 SMALLER (SORT), GREATER (RSORT)
#
src03: tstl srtsr # jump if rsort
bnequ src06
#
src04: movl srtsc,r8 # restore wc
movl (sp)+,r11 # return
jmp *(r11)+
#
# RETURN IF KEY1 GREATER (SORT), SMALLER (RSORT)
#
src05: tstl srtsr # jump if rsort
bnequ src04
#
src06: movl srtsc,r8 # restore wc
addl2 $4*1,(sp) # return
rsb
#
# KEYS ARE OF SAME DATATYPE
#
src07: cmpl r10,r9 # item first created is less
blssu src03
cmpl r10,r9 # addresses rise in order of creation
bgtru src05
#
# DROP THROUGH OR MERGE FOR IDENTICAL OR EQUAL OBJECTS
#
src08: cmpl srts1,srts2 # test offsets or key addrss instead
blssu src04
jmp src06 # offset 1 greater
#page
#
# SORTC (CONTINUED)
#
# STRINGS
#
src09: movl r10,-(sp) # stack
movl r9,-(sp) # args
jsb lcomp # compare objects
.long invalid$ # cant
.long invalid$ # fail
.long src03 # key1 less
.long src08 # keys equal
.long src05 # key1 greater
#
# ARITHMETIC COMPARISON FAILED - RECOVER ARGS
#
src10: movl r$sxl,r10 # get arg1
movl r$sxr,r9 # get arg2
movl (r10),r8 # get type of key1
cmpl r8,(r9) # jump if keys of same type
beqlu src07
movl r8,r10 # get block type word
movl (r9),r9 # get block type word
movzwl -2(r10),r10 # entry point id for key1
movzwl -2(r9),r9 # entry point id for key2
cmpl r10,r9 # jump if key1 gt key2
bgtru src05
jmp src03 # key1 lt key2
#
# DATATYPE FIELD NAME USED
#
src11: jsb sortf # call routine to find field 1
movl r10,-(sp) # stack item pointer
movl r9,r10 # get key2
jsb sortf # find field 2
movl r10,r9 # place as key2
movl (sp)+,r10 # recover key1
jmp src01 # merge
#enp # procedure sortc
#page
#
# 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 # entry point
cmpl (r10),$b$pdt # return if not pdblk
bnequ srtf3
movl r9,-(sp) # keep xr
movl srtfd,r9 # get possible former dfblk ptr
beqlu srtf4 # jump if not
cmpl r9,4*pddfp(r10) # jump if not right datatype
bnequ srtf4
cmpl srtdf,srtff # jump if not right field name
bnequ srtf4
addl2 srtfo,r10 # add offset to required field
#
# HERE WITH XL POINTING TO FOUND FIELD
#
srtf1: movl (r10),r10 # get item from field
#
# RETURN POINT
#
srtf2: movl (sp)+,r9 # restore xr
#
srtf3: rsb # return
#page
#
# SORTF (CONTINUED)
#
# CONDUCT A SEARCH
#
srtf4: movl r10,r9 # copy original pointer
movl 4*pddfp(r9),r9 # point to dfblk
movl r9,srtfd # keep a copy
movl 4*fargs(r9),r8 # get number of fields
moval 0[r8],r8 # convert to bytes
addl2 4*dflen(r9),r9 # point past last field
#
# LOOP TO FIND NAME IN PDFBLK
#
srtf5: subl2 $4,r8 # count down
subl2 $4,r9 # point in front
cmpl (r9),srtdf # skip out if found
beqlu srtf6
tstl r8 # loop
bnequ srtf5
jmp srtf2 # return - not found
#
# FOUND
#
srtf6: movl (r9),srtff # keep field name ptr
addl2 $4*pdfld,r8 # add offset to first field
movl r8,srtfo # store as field offset
addl2 r8,r10 # point to field
jmp srtf1 # return
#enp # procedure sortf
#page
#
# 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
#
.data 1
sorth_s: .long 0
.text 0
sorth: movl (sp)+,sorth_s # entry point
movl r6,srtsn # save n
movl r8,srtwc # keep wc
movl (sp),r10 # sort array base adrs
addl2 srtso,r10 # add offset to a(0)
addl2 r8,r10 # point to a(j)
movl (r10),srtrt # get offset to root
addl2 r8,r8 # double j - cant exceed n
#
# LOOP TO MOVE DOWN TREE USING DOUBLED INDEX J
#
srh01: cmpl r8,srtsn # done if j gt n
bgtru srh03
cmpl r8,srtsn # skip if j equals n
beqlu srh02
movl (sp),r9 # sort array base adrs
movl 4*1(sp),r10 # key array base adrs
addl2 srtso,r9 # point to a(0)
addl2 r8,r9 # adrs of a(j)
movl 4*1(r9),r6 # get a(j+1)
movl (r9),r7 # get a(j)
#
# COMPARE SONS. (WA) RIGHT SON, (WB) LEFT SON
#
jsb sortc # compare keys - lt(a(j+1),a(j))
.long srh02 # a(j+1) lt a(j)
addl2 $4,r8 # point to greater son, a(j+1)
#page
#
# SORTH (CONTINUED)
#
# COMPARE ROOT WITH GREATER SON
#
srh02: movl 4*1(sp),r10 # key array base adrs
movl (sp),r9 # get sort array address
addl2 srtso,r9 # adrs of a(0)
movl r9,r7 # copy this adrs
addl2 r8,r9 # adrs of greater son, a(j)
movl (r9),r6 # get a(j)
movl r7,r9 # point back to a(0)
movl srtrt,r7 # get root
jsb sortc # compare them - lt(a(j),root)
.long srh03 # father exceeds sons - done
movl (sp),r9 # get sort array adrs
addl2 srtso,r9 # point to a(0)
movl r9,r10 # copy it
movl r8,r6 # copy j
ashl $-2,r8,r8 # convert to words
ashl $-1,r8,r8 # get j/2
moval 0[r8],r8 # convert back to bytes
addl2 r6,r10 # point to a(j)
addl2 r8,r9 # adrs of a(j/2)
movl (r10),(r9) # a(j/2) = a(j)
movl r6,r8 # recover j
addl2 r8,r8 # j = j*2. done if too big
bvc 0f
jmp srh03
0:
jmp srh01 # loop
#
# FINISH BY COPYING ROOT OFFSET BACK INTO ARRAY
#
srh03: ashl $-2,r8,r8 # convert to words
ashl $-1,r8,r8 # j = j/2
moval 0[r8],r8 # convert back to bytes
movl (sp),r9 # sort array adrs
addl2 srtso,r9 # adrs of a(0)
addl2 r8,r9 # adrs of a(j/2)
movl srtrt,(r9) # a(j/2) = root
movl srtsn,r6 # restore wa
movl srtwc,r8 # restore wc
jmp *sorth_s # return
#enp # end procedure sorth
#page
#page
#
# 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 # entry point
movl r7,-(sp) # save name/value indicator
movl r9,-(sp) # save subscript value
movl r10,-(sp) # save table pointer
movl 4*tblen(r10),r6 # load length of tbblk
ashl $-2,r6,r6 # convert to word count
subl2 $tbbuk,r6 # get number of buckets
movl r6,r5 # convert to integer value
movl r5,tfnsi # save for later
movl (r9),r10 # load first word of subscript
movzwl -2(r10),r10 # load block entry id (bl$xx)
casel r10,$0,$bl$$d # switch on block type
5:
.word tfn00-5b
.word tfn00-5b
.word tfn00-5b
.word tfn00-5b
.word tfn02-5b # jump if integer
.word tfn04-5b # jump if name
.word tfn03-5b # jump if pattern
.word tfn03-5b # jump if pattern
.word tfn03-5b # jump if pattern
.word tfn02-5b # real
.word tfn05-5b # jump if string
.word tfn00-5b
.word tfn00-5b
.word tfn00-5b
.word tfn00-5b
.word tfn00-5b
.word tfn00-5b
#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: movl 4*1(r9),r6 # load second word
#
# MERGE HERE WITH ONE WORD HASH SOURCE IN WA
#
tfn01: movl r6,r5 # convert to integer
jmp tfn06 # jump to merge
#page
#
# TFIND (CONTINUED)
#
# HERE FOR INTEGER OR REAL
#
tfn02: movl 4*1(r9),r5 # load value as hash source
bgeq tfn06 # ok if positive or zero
mnegl r5,r5 # make positive
bvs tfn06
jmp tfn06 # merge
#
# FOR PATTERN, USE FIRST WORD (PCODE) AS SOURCE
#
tfn03: movl (r9),r6 # load first word as hash source
jmp tfn01 # merge back
#
# FOR NAME, USE OFFSET AS HASH SOURCE
#
tfn04: movl 4*nmofs(r9),r6 # load offset as hash source
jmp tfn01 # merge back
#
# HERE FOR STRING
#
tfn05: jsb hashs # call routine to compute hash
#
# MERGE HERE WITH HASH SOURCE IN (IA)
#
tfn06: ashq $-32,r4,r4 # compute hash index by remaindering
ediv tfnsi,r4,r11,r5
movl r5,r8 # get as one word integer
moval 0[r8],r8 # convert to byte offset
movl (sp),r10 # get table ptr again
addl2 r8,r10 # point to proper bucket
movl 4*tbbuk(r10),r9 # load first teblk pointer
cmpl r9,(sp) # jump if no teblks on chain
beqlu tfn10
#
# LOOP THROUGH TEBLKS ON HASH CHAIN
#
tfn07: movl r9,r7 # save teblk pointer
movl 4*tesub(r9),r9 # load subscript value
movl 4*1(sp),r10 # load input argument subscript val
jsb ident # compare them
.long tfn08 # jump if equal (ident)
#
# HERE IF NO MATCH WITH THAT TEBLK
#
movl r7,r10 # restore teblk pointer
movl 4*tenxt(r10),r9 # point to next teblk on chain
cmpl r9,(sp) # jump if there is one
bnequ tfn07
#
# HERE IF NO MATCH WITH ANY TEBLK ON CHAIN
#
movl $4*tenxt,r8 # set offset to link field (xl base)
jmp tfn11 # jump to merge
#page
#
# TFIND (CONTINUED)
#
# HERE WE HAVE FOUND A MATCHING ELEMENT
#
tfn08: movl r7,r10 # restore teblk pointer
movl $4*teval,r6 # set teblk name offset
movl 4*2(sp),r7 # restore name/value indicator
bnequ tfn09 # jump if called by name
jsb acess # else get value
.long tfn12 # jump if reference fails
clrl r7 # restore name/value indicator
#
# COMMON EXIT FOR ENTRY FOUND
#
tfn09: addl2 $4*num03,sp # pop stack entries
addl2 $4*1,(sp) # return to tfind caller
rsb
#
# HERE IF NO TEBLKS ON THE HASH CHAIN
#
tfn10: addl2 $4*tbbuk,r8 # get offset to bucket ptr
movl (sp),r10 # set tbblk ptr as base
#
# MERGE HERE WITH (XL,WC) BASE,OFFSET OF FINAL LINK
#
tfn11: movl (sp),r9 # tbblk pointer
movl 4*tbinv(r9),r9 # load default value in case
movl 4*2(sp),r7 # load name/value indicator
beqlu tfn09 # exit with default if value call
#
# HERE WE MUST BUILD A NEW TEBLK
#
movl $4*tesi$,r6 # set size of teblk
jsb alloc # allocate teblk
addl2 r8,r10 # point to hash link
movl r9,(r10) # link new teblk at end of chain
movl $b$tet,(r9) # store type word
movl $nulls,4*teval(r9) # set null as initial value
movl (sp)+,4*tenxt(r9)# set tbblk ptr to mark end of chain
movl (sp)+,4*tesub(r9)# store subscript value
addl2 $4,sp # pop past name/value indicator
movl r9,r10 # copy teblk pointer (name base)
movl $4*teval,r6 # set offset
addl2 $4*1,(sp) # return to caller with new teblk
rsb
#
# ACESS FAIL RETURN
#
tfn12: movl (sp)+,r11 # alternative return
jmp *(r11)+
#enp # end procedure tfind
#page
#
# 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
#
.data 1
trace_s: .long 0
.text 0
trace: movl (sp)+,trace_s # entry point
jsb gtstg # get trace type string
.long trc15 # jump if not string
movab cfp$f(r9),r9 # else point to string
movzbl (r9),r6 # load first character
bicl2 $ch$bl,r6 # fold to upper case
movl (sp),r9 # load name argument
movl r10,(sp) # stack trblk ptr or zero
movl $trtac,r8 # set trtyp for access trace
cmpl r6,$ch$la # jump if a (access)
bnequ 0f
jmp trc10
0:
movl $trtvl,r8 # set trtyp for value trace
cmpl r6,$ch$lv # jump if v (value)
bnequ 0f
jmp trc10
0:
tstl r6 # jump if blank (value)
bnequ 0f
jmp trc10
0:
#
# HERE FOR L,K,F,C,R
#
cmpl r6,$ch$lf # jump if f (function)
beqlu trc01
cmpl r6,$ch$lr # jump if r (return)
beqlu trc01
cmpl r6,$ch$ll # jump if l (label)
beqlu trc03
cmpl r6,$ch$lk # jump if k (keyword)
bnequ 0f
jmp trc06
0:
cmpl r6,$ch$lc # else error if not c (call)
beqlu 0f
jmp trc15
0:
#
# HERE FOR F,C,R
#
trc01: jsb gtnvr # point to vrblk for name
.long trc16 # jump if bad name
addl2 $4,sp # pop stack
movl 4*vrfnc(r9),r9 # point to function block
cmpl (r9),$b$pfc # error if not program function
beqlu 0f
jmp trc17
0:
cmpl r6,$ch$lr # jump if r (return)
beqlu trc02
#page
#
# TRACE (CONTINUED)
#
# HERE FOR F,C TO SET/RESET CALL TRACE
#
movl r10,4*pfctr(r9) # set/reset call trace
cmpl r6,$ch$lc # exit with null if c (call)
bnequ 0f
jmp exnul
0:
#
# HERE FOR F,R TO SET/RESET RETURN TRACE
#
trc02: movl r10,4*pfrtr(r9) # set/reset return trace
addl3 $4*2,trace_s,r11 # return
jmp (r11)
#
# HERE FOR L TO SET/RESET LABEL TRACE
#
trc03: jsb gtnvr # point to vrblk
.long trc16 # jump if bad name
movl 4*vrlbl(r9),r10 # load label pointer
cmpl (r10),$b$trt # jump if no old trace
bnequ trc04
movl 4*trlbl(r10),r10# else delete old trace association
#
# HERE WITH OLD LABEL TRACE ASSOCIATION DELETED
#
trc04: cmpl r10,$stndl # error if undefined label
bnequ 0f
jmp trc16
0:
movl (sp)+,r7 # get trblk ptr again
beqlu trc05 # jump if stoptr case
movl r7,4*vrlbl(r9) # else set new trblk pointer
movl $b$vrt,4*vrtra(r9) # set label trace routine address
movl r7,r9 # copy trblk pointer
movl r10,4*trlbl(r9) # store real label in trblk
addl3 $4*2,trace_s,r11 # return
jmp (r11)
#
# HERE FOR STOPTR CASE FOR LABEL
#
trc05: movl r10,4*vrlbl(r9) # store label ptr back in vrblk
movl $b$vrg,4*vrtra(r9) # store normal transfer address
addl3 $4*2,trace_s,r11 # return
jmp (r11)
#page
#
# TRACE (CONTINUED)
#
# HERE FOR K (KEYWORD)
#
trc06: jsb gtnvr # point to vrblk
.long trc16 # error if not natural var
tstl 4*vrlen(r9) # error if not system var
beqlu 0f
jmp trc16
0:
addl2 $4,sp # pop stack
tstl r10 # jump if stoptr case
beqlu trc07
movl r9,4*trkvr(r10) # store vrblk ptr in trblk for ktrex
#
# MERGE HERE WITH TRBLK SET UP IN WB (OR ZERO)
#
trc07: movl 4*vrsvp(r9),r9 # point to svblk
cmpl r9,$v$ert # jump if errtype
beqlu trc08
cmpl r9,$v$stc # jump if stcount
beqlu trc09
cmpl r9,$v$fnc # else error if not fnclevel
beqlu 0f
jmp trc17
0:
#
# FNCLEVEL
#
movl r10,r$fnc # set/reset fnclevel trace
addl3 $4*2,trace_s,r11 # return
jmp (r11)
#
# ERRTYPE
#
trc08: movl r10,r$ert # set/reset errtype trace
addl3 $4*2,trace_s,r11 # return
jmp (r11)
#
# STCOUNT
#
trc09: movl r10,r$stc # set/reset stcount trace
addl3 $4*2,trace_s,r11 # return
jmp (r11)
#page
#
# TRACE (CONTINUED)
#
# A,V MERGE HERE WITH TRTYP VALUE IN WC
#
trc10: jsb gtvar # locate variable
.long trc16 # error if not appropriate name
movl (sp)+,r7 # get new trblk ptr again
addl2 r10,r6 # point to variable location
movl r6,r9 # copy variable pointer
#
# LOOP TO SEARCH TRBLK CHAIN
#
trc11: movl (r9),r10 # point to next entry
cmpl (r10),$b$trt # jump if not trblk
bnequ trc13
cmpl r8,4*trtyp(r10) # jump if too far out on chain
blssu trc13
cmpl r8,4*trtyp(r10) # jump if this matches our type
beqlu trc12
addl2 $4*trnxt,r10 # else point to link field
movl r10,r9 # copy pointer
jmp trc11 # and loop back
#
# HERE TO DELETE AN OLD TRBLK OF THE TYPE WE WERE GIVEN
#
trc12: movl 4*trnxt(r10),r10# get ptr to next block or value
movl r10,(r9) # store to delete this trblk
#
# HERE AFTER DELETING ANY OLD ASSOCIATION OF THIS TYPE
#
trc13: tstl r7 # jump if stoptr case
beqlu trc14
movl r7,(r9) # else link new trblk in
movl r7,r9 # copy trblk pointer
movl r10,4*trnxt(r9) # store forward pointer
movl r8,4*trtyp(r9) # store appropriate trap type code
#
# HERE TO MAKE SURE VRGET,VRSTO ARE SET PROPERLY
#
trc14: movl r6,r9 # recall possible vrblk pointer
subl2 $4*vrval,r9 # point back to vrblk
jsb setvr # set fields if vrblk
addl3 $4*2,trace_s,r11 # return
jmp (r11)
#
# HERE FOR BAD TRACE TYPE
#
trc15: addl3 $4*1,trace_s,r11 # take bad trace type error exit
jmp *(r11)+
#
# POP STACK BEFORE FAILING
#
trc16: addl2 $4,sp # pop stack
#
# HERE FOR BAD NAME ARGUMENT
#
trc17: movl trace_s,r11 # take bad name error exit
jmp *(r11)+
#enp # end procedure trace
#page
#
# 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 # entry point
movl r9,-(sp) # stack trtag (or trfnm)
movl $4*trsi$,r6 # set size of trblk
jsb alloc # allocate trblk
movl $b$trt,(r9) # store first word
movl r10,4*trfnc(r9) # store trfnc (or trfpt)
movl (sp)+,4*trtag(r9)# store trtag (or trfnm)
movl r7,4*trtyp(r9) # store type
movl $nulls,4*trval(r9) # for now, a null value
rsb # return to caller
#enp # end procedure trbld
#page
#
# 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 # entry point
movl r9,r10 # copy string pointer
movl 4*sclen(r9),r6 # load string length
beqlu trim2 # jump if null input
movab cfp$f(r10)[r6],r10 # else point past last character
tstl r7 # jump if no trim
beqlu trim3
movl $ch$bl,r8 # load blank character
#
# LOOP THROUGH CHARACTERS FROM RIGHT TO LEFT
#
trim0: movzbl -(r10),r7 # load next character
cmpl r7,$ch$ht # jump if horizontal tab
beqlu trim1
cmpl r7,r8 # jump if non-blank found
bnequ trim3
trim1: decl r6 # else decrement character count
bnequ trim0 # loop back if more to check
#
# HERE IF RESULT IS NULL (NULL OR ALL-BLANK INPUT)
#
trim2: movl r9,dnamp # wipe out input string block
movl $nulls,r9 # load null result
jmp trim5 # merge to exit
#page
#
# TRIMR (CONTINUED)
#
# HERE WITH NON-BLANK FOUND (MERGE FOR NO TRIM)
#
trim3: movl r6,4*sclen(r9) # set new length
movl r9,r10 # copy string pointer
movab cfp$f(r10)[r6],r10 # ready for storing blanks
movab 3+(4*schar)(r6),r6 # get length of block in bytes
bicl2 $3,r6
addl2 r9,r6 # point past new block
movl r6,dnamp # set new top of storage pointer
movl $cfp$c,r6 # get count of chars in word
clrl r8 # set blank char
#
# LOOP TO ZERO PAD LAST WORD OF CHARACTERS
#
trim4: movb r8,(r10)+ # store zero character
sobgtr r6,trim4 # loop back till all stored
#csc r10 # complete store characters
#
# COMMON EXIT POINT
#
trim5: clrl r10 # clear garbage xl pointer
rsb # return to caller
#enp # end procedure trimr
#page
#
# 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 # entry point (recursive)
movl r$cod,r8 # load code block pointer
movl r3,r7 # get current code pointer
subl2 r8,r7 # make code pointer into offset
movl kvtra,-(sp) # stack trace keyword value
movl r9,-(sp) # stack trblk pointer
movl r10,-(sp) # stack name base
movl r6,-(sp) # stack name offset
movl r8,-(sp) # stack code block pointer
movl r7,-(sp) # stack code pointer offset
movl flptr,-(sp) # stack old failure pointer
clrl -(sp) # set dummy fail offset
movl sp,flptr # set new failure pointer
clrl kvtra # reset trace keyword to zero
movl $trxdc,r8 # load new (dummy) code blk pointer
movl r8,r$cod # set as code block pointer
movl r8,r3 # and new code pointer
#page
#
# TRXEQ (CONTINUED)
#
# NOW PREPARE ARGUMENTS FOR FUNCTION
#
movl r6,r7 # save name offset
movl $4*nmsi$,r6 # load nmblk size
jsb alloc # allocate space for nmblk
movl $b$nml,(r9) # set type word
movl r10,4*nmbas(r9) # store name base
movl r7,4*nmofs(r9) # store name offset
movl 4*6(sp),r10 # reload pointer to trblk
movl r9,-(sp) # stack nmblk pointer (1st argument)
movl 4*trtag(r10),-(sp) # stack trace tag (2nd argument)
movl 4*trfnc(r10),r10# load trace function pointer
movl $num02,r6 # set number of arguments to two
jmp cfunc # jump to call function
#
# SEE O$TXR FOR DETAILS OF RETURN TO THIS POINT
#
trxq1: movl flptr,sp # point back to our stack entries
addl2 $4,sp # pop off garbage fail offset
movl (sp)+,flptr # restore old failure pointer
movl (sp)+,r7 # reload code offset
movl (sp)+,r8 # load old code base pointer
movl r8,r9 # copy cdblk pointer
movl 4*cdstm(r9),kvstn# restore stmnt no
movl (sp)+,r6 # reload name offset
movl (sp)+,r10 # reload name base
movl (sp)+,r9 # reload trblk pointer
movl (sp)+,kvtra # restore trace keyword value
addl2 r8,r7 # recompute absolute code pointer
movl r7,r3 # restore code pointer
movl r8,r$cod # and code block pointer
rsb # return to trxeq caller
#enp # end procedure trxeq
#page
#
# 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
#page
#
# XSCAN (CONTINUED)
#
xscan: #prc # entry point
movl r7,xscwb # preserve wb
movl r$xsc,r9 # point to argument string
movl 4*sclen(r9),r6 # load string length
movl xsofs,r7 # load current offset
subl2 r7,r6 # get number of remaining characters
beqlu xscn2 # jump if no characters left
movab cfp$f(r9)[r7],r9# point to current character
#
# LOOP TO SEARCH FOR DELIMITER
#
xscn1: movzbl (r9)+,r7 # load next character
cmpl r7,r8 # jump if delimiter one found
beqlu xscn3
cmpl r7,r10 # jump if delimiter two found
beqlu xscn4
decl r6 # decrement count of chars left
bnequ xscn1 # loop back if more chars to go
#
# HERE FOR RUNOUT
#
xscn2: movl r$xsc,r10 # point to string block
movl 4*sclen(r10),r6 # get string length
movl xsofs,r7 # load offset
subl2 r7,r6 # get substring length
clrl r$xsc # clear string ptr for collector
clrl xscrt # set zero (runout) return code
jmp xscn6 # jump to exit
#page
#
# XSCAN (CONTINUED)
#
# HERE IF DELIMITER ONE FOUND
#
xscn3: movl $num01,xscrt # set return code
jmp xscn5 # jump to merge
#
# HERE IF DELIMITER TWO FOUND
#
xscn4: movl $num02,xscrt # set return code
#
# MERGE HERE AFTER DETECTING A DELIMITER
#
xscn5: movl r$xsc,r10 # reload pointer to string
movl 4*sclen(r10),r8 # get original length of string
subl2 r6,r8 # minus chars left = chars scanned
movl r8,r6 # move to reg for sbstr
movl xsofs,r7 # set offset
subl2 r7,r6 # compute length for sbstr
incl r8 # adjust new cursor past delimiter
movl r8,xsofs # store new offset
#
# COMMON EXIT POINT
#
xscn6: clrl r9 # clear garbage character ptr in xr
jsb sbstr # build sub-string
movl xscrt,r6 # load return code
movl xscwb,r7 # restore wb
rsb # return to xscan caller
#enp # end procedure xscan
#page
#
# 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
#
.data 1
xscni_s: .long 0
.text 0
xscni: movl (sp)+,xscni_s # entry point
jsb gtstg # fetch argument as string
.long xsci1 # jump if not convertible
movl r9,r$xsc # else store scblk ptr for xscan
clrl xsofs # set offset to zero
tstl r6 # jump if null string
beqlu xsci2
addl3 $4*2,xscni_s,r11 # return to xscni caller
jmp (r11)
#
# HERE IF ARGUMENT IS NOT A STRING
#
xsci1: movl xscni_s,r11 # take not-string error exit
jmp *(r11)+
#
# HERE FOR NULL STRING
#
xsci2: addl3 $4*1,xscni_s,r11 # take null-string error exit
jmp *(r11)+
#enp # end procedure xscni
#title 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.
#page
# 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
movl r9,r6 # copy number of subscripts
movl sp,r10 # point to stack front
moval 0[r9],r9 # convert to byte offset
addl2 r9,r10 # point to array operand on stack
addl2 $4,r10 # final value for stack popping
movl r10,arfxs # keep for later
movl -(r10),r9 # load array operand pointer
movl r9,r$arf # keep array pointer
movl r10,r9 # save pointer to subscripts
movl r$arf,r10 # point xl to possible vcblk or tbblk
movl (r10),r8 # load first word
cmpl r8,$b$art # jump if arblk
beqlu arf01
cmpl r8,$b$vct # jump if vcblk
bnequ 0f
jmp arf07
0:
cmpl r8,$b$tbt # jump if tbblk
bnequ 0f
jmp arf10
0:
jmp er_235 # subscripted operand is not table or array
#
# HERE FOR ARRAY (ARBLK)
#
arf01: cmpl r6,4*arndm(r10) # jump if wrong number of dims
beqlu 0f
jmp arf09
0:
movl intv0,r5 # get initial subscript of zero
movl r9,r10 # point before subscripts
clrl r6 # initial offset to bounds
jmp arf03 # jump into loop
#
# LOOP TO COMPUTE SUBSCRIPTS BY MULTIPLICATIONS
#
arf02: mull2 4*ardm2(r9),r5 # multiply total by next dimension
#
# MERGE HERE FIRST TIME
#
arf03: movl -(r10),r9 # load next subscript
movl r5,arfsi # save current subscript
movl 4*icval(r9),r5 # load integer value in case
cmpl (r9),$b$icl # jump if it was an integer
beqlu arf04
#page
#
# ARREF (CONTINUED)
#
#
jsb gtint # convert to integer
.long arf12 # jump if not integer
movl 4*icval(r9),r5 # if ok, load integer value
#
# HERE WITH INTEGER SUBSCRIPT IN (IA)
#
arf04: movl r$arf,r9 # point to array
addl2 r6,r9 # offset to next bounds
subl2 4*arlbd(r9),r5 # subtract low bound to compare
bvc 0f
jmp arf13
0:
tstl r5 # out of range fail if too small
bgeq 0f
jmp arf13
0:
subl2 4*ardim(r9),r5 # subtract dimension
blss 0f # out of range fail if too large
jmp arf13
0:
addl2 4*ardim(r9),r5 # else restore subscript offset
addl2 arfsi,r5 # add to current total
addl2 $4*ardms,r6 # point to next bounds
cmpl r10,sp # loop back if more to go
bnequ arf02
#
# HERE WITH INTEGER SUBSCRIPT COMPUTED
#
movl r5,r6 # get as one word integer
moval 0[r6],r6 # convert to offset
movl r$arf,r10 # point to arblk
addl2 4*arofs(r10),r6 # add offset past bounds
addl2 $4,r6 # adjust for arpro field
tstl r7 # exit with name if name call
bnequ arf08
#
# MERGE HERE TO GET VALUE FOR VALUE CALL
#
arf05: jsb acess # get value
.long arf13 # fail if acess fails
#
# RETURN VALUE
#
arf06: movl arfxs,sp # pop stack entries
clrl r$arf # finished with array pointer
jmp exixr # exit with value in xr
#page
#
# ARREF (CONTINUED)
#
# HERE FOR VECTOR
#
arf07: cmpl r6,$num01 # error if more than 1 subscript
beqlu 0f
jmp arf09
0:
movl (sp),r9 # else load subscript
jsb gtint # convert to integer
.long arf12 # error if not integer
movl 4*icval(r9),r5 # else load integer value
subl2 intv1,r5 # subtract for ones offset
movl r5,r6 # get subscript as one word
bgeq 0f
jmp arf13
0:
addl2 $vcvls,r6 # add offset for standard fields
moval 0[r6],r6 # convert offset to bytes
cmpl r6,4*vclen(r10) # fail if out of range subscript
blssu 0f
jmp arf13
0:
tstl r7 # back to get value if value call
beqlu arf05
#
# RETURN NAME
#
arf08: movl arfxs,sp # pop stack entries
clrl r$arf # finished with array pointer
jmp exnam # else exit with name
#
# HERE IF SUBSCRIPT COUNT IS WRONG
#
arf09: jmp er_236 # array referenced with wrong number of subscripts
#
# TABLE
#
arf10: cmpl r6,$num01 # error if more than 1 subscript
bnequ arf11
movl (sp),r9 # else load subscript
jsb tfind # call table search routine
.long arf13 # fail if failed
tstl r7 # exit with name if name call
bnequ arf08
jmp arf06 # else exit with value
#
# HERE FOR BAD TABLE REFERENCE
#
arf11: jmp er_237 # table referenced with more than one subscript
#
# HERE FOR BAD SUBSCRIPT
#
arf12: jmp er_238 # array subscript is not integer
#
# HERE TO SIGNAL FAILURE
#
arf13: clrl r$arf # finished with array pointer
jmp exfal # fail
#page
#
# 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
cmpl r6,4*fargs(r10) # jump if too few arguments
blssu cfnc1
cmpl r6,4*fargs(r10) # jump if correct number of args
beqlu cfnc3
#
# HERE IF TOO MANY ARGUMENTS SUPPLIED, POP THEM OFF
#
movl r6,r7 # copy actual number
subl2 4*fargs(r10),r7 # get number of extra args
moval 0[r7],r7 # convert to bytes
addl2 r7,sp # pop off unwanted arguments
jmp cfnc3 # jump to go off to function
#
# HERE IF TOO FEW ARGUMENTS
#
cfnc1: movl 4*fargs(r10),r7 # load required number of arguments
cmpl r7,$nini9 # jump if case of var num of args
beqlu cfnc3
subl2 r6,r7 # calculate number missing
# set counter to control loop
#
# LOOP TO SUPPLY EXTRA NULL ARGUMENTS
#
cfnc2: movl $nulls,-(sp) # stack a null argument
sobgtr r7,cfnc2 # loop till proper number stacked
#
# MERGE HERE TO JUMP TO FUNCTION
#
cfnc3: movl (r10),r11 # jump through fcode field
jmp (r11)
#page
#
# 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
movl flptr,sp # pop stack
movl (sp),r9 # load failure offset
addl2 r$cod,r9 # point to failure code location
movl r9,r3 # set code pointer
jmp exits # do next code word
#page
#
# 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
jsb icbld # build icblk
#page
# 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
#
movl r9,-(sp) # stack result
#
#
# EXITS -- EXIT WITH RESULT IF ANY STACKED
#
# (XR,XL) MAY BE NON-COLLECTABLE
#
# BRN EXITS ENTER EXITS ROUTINE
#
exits: #rtn
movl (r3)+,r9 # load next code word
movl (r9),r10 # load entry address
movl r10,r11 # jump to execute next code word
jmp (r11)
#page
#
# 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
movl r10,-(sp) # stack name base
movl r6,-(sp) # stack name offset
jmp exits # do next code word
#page
#
# 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
movl $nulls,-(sp) # stack null value
jmp exits # do next code word
#page
#
# 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
jsb rcbld # build rcblk
jmp exixr # jump to exit with result in xr
#page
#
# 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
movl curid,r6 # load current id value
cmpl r6,$cfp$m # jump if no overflow
bnequ exsi1
clrl r6 # else reset for wraparound
#
# HERE WITH OLD IDVAL IN WA
#
exsi1: incl r6 # bump id value
movl r6,curid # store for next time
movl r6,4*idval(r9) # store id value
jmp exixr # exit with result in (xr)
#page
#
# 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
movl r9,r10 # copy name base pointer
movl $4*nmsi$,r6 # set size of nmblk
jsb alloc # allocate nmblk
movl $b$nml,(r9) # store type word
movl r10,4*nmbas(r9) # store name base
movl $4*vrval,4*nmofs(r9) # store name offset
jmp exixr # exit with result in xr
#page
#
# 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
addl2 $4*num02,sp # pop two entries off stack
#page
#
# 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
movl (sp)+,r9 # load alternative node pointer
movl (sp)+,r7 # restore old cursor
movl (r9),r10 # load pcode entry pointer
movl r10,r11 # jump to execute code for node
jmp (r11)
#page
#
# 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
movl (sp)+,r9 # load argument
cmpl (r9),$b$nml # jump if a name
beqlu indr2
jsb gtnvr # else convert to variable
.long er_239 # indirection operand is not name
tstl r7 # skip if by value
beqlu indr1
movl r9,-(sp) # else stack vrblk ptr
movl $4*vrval,-(sp) # stack name offset
jmp exits # exit with result on stack
#
# HERE TO GET VALUE OF NATURAL VARIABLE
#
indr1: movl (r9),r11 # jump through vrget field of vrblk
jmp (r11)
#
# HERE IF OPERAND IS A NAME
#
indr2: movl 4*nmbas(r9),r10 # load name base
movl 4*nmofs(r9),r6 # load name offset
tstl r7 # exit if called by name
beqlu 0f
jmp exnam
0:
jsb acess # else get value first
.long exfal # fail if access fails
jmp exixr # else return with value in xr
#page
#
# 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
movl (sp)+,r9 # load pattern operand
jsb gtpat # convert to pattern
.long er_240 # pattern match right operand is not pattern
movl r9,r10 # if ok, save pattern pointer
tstl r7 # jump if not match by name
bnequ mtch1
movl (sp),r6 # else load name offset
movl r10,-(sp) # save pattern pointer
movl 4*2(sp),r10 # load name base
jsb acess # access subject value
.long exfal # fail if access fails
movl (sp),r10 # restore pattern pointer
movl r9,(sp) # stack subject string val for merge
clrl r7 # restore type code
#
# MERGE HERE WITH SUBJECT VALUE ON STACK
#
mtch1: movl (sp),r9 # load subject value
clrl r$pmb # assume not a buffer
cmpl (r9),$b$bct # branch if not
bnequ mtcha
addl2 $4,sp # else pop value
movl r9,r$pmb # save pointer
movl 4*bclen(r9),r6 # get defined length
movl 4*bcbuf(r9),r9 # point to bfblk
jmp mtchb
#
# HERE IF NOT BUFFER TO CONVERT TO STRING
#
mtcha: jsb gtstg # not buffer - convert to string
.long er_241 # pattern match left operand is not string
#
# MERGE WITH BUFFER OR STRING
#
mtchb: movl r9,r$pms # if ok, store subject string pointer
movl r6,pmssl # and length
movl r7,-(sp) # stack match type code
clrl -(sp) # stack initial cursor (zero)
clrl r7 # set initial cursor
movl sp,pmhbs # set history stack base ptr
clrl pmdfl # reset pattern assignment flag
movl r10,r9 # set initial node pointer
tstl kvanc # jump if anchored
bnequ mtch2
#
# HERE FOR UNANCHORED
#
movl r9,-(sp) # stack initial node pointer
movl $nduna,-(sp) # stack pointer to anchor move node
movl (r9),r11 # start match of first node
jmp (r11)
#
# HERE IN ANCHORED MODE
#
mtch2: clrl -(sp) # dummy cursor value
movl $ndabo,-(sp) # stack pointer to abort node
movl (r9),r11 # start match of first node
jmp (r11)
#page
#
# 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
tstl kvfnc # jump if not level zero
bnequ rtn01
jmp er_242 # function return from level zero
#
# HERE IF NOT LEVEL ZERO RETURN
#
rtn01: movl flprt,sp # pop stack
addl2 $4,sp # remove failure offset
movl (sp)+,r9 # pop pfblk pointer
movl (sp)+,flptr # pop failure pointer
movl (sp)+,flprt # pop old flprt
movl (sp)+,r7 # pop code pointer offset
movl (sp)+,r8 # pop old code block pointer
addl2 r8,r7 # make old code pointer absolute
movl r7,r3 # restore old code pointer
movl r8,r$cod # restore old code block pointer
decl kvfnc # decrement function level
movl kvtra,r7 # load trace
addl2 kvftr,r7 # add ftrace
bnequ 0f # jump if no tracing possible
jmp rtn06
0:
#
# HERE IF THERE MAY BE A TRACE
#
movl r6,-(sp) # save function return type
movl r9,-(sp) # save pfblk pointer
movl r6,kvrtn # set rtntype for trace function
movl r$fnc,r10 # load fnclevel trblk ptr (if any)
jsb ktrex # execute possible fnclevel trace
movl 4*pfvbl(r9),r10 # load vrblk ptr (sgd13)
tstl kvtra # jump if trace is off
beqlu rtn02
movl 4*pfrtr(r9),r9 # else load return trace trblk ptr
beqlu rtn02 # jump if not return traced
decl kvtra # else decrement trace count
tstl 4*trfnc(r9) # jump if print trace
beqlu rtn03
movl $4*vrval,r6 # else set name offset
movl 4*1(sp),kvrtn # make sure rtntype is set right
jsb trxeq # execute full trace
#page
#
# RETRN (CONTINUED)
#
# HERE TO TEST FOR FTRACE
#
rtn02: tstl kvftr # jump if ftrace is off
beqlu rtn05
decl kvftr # else decrement ftrace
#
# HERE FOR PRINT TRACE OF FUNCTION RETURN
#
rtn03: jsb prtsn # print statement number
movl 4*1(sp),r9 # load return type
jsb prtst # print it
movl $ch$bl,r6 # load blank
jsb prtch # print it
movl (sp),r10 # load pfblk ptr
movl 4*pfvbl(r10),r10# load function vrblk ptr
movl $4*vrval,r6 # set vrblk name offset
cmpl r9,$scfrt # jump if not freturn case
bnequ rtn04
#
# FOR FRETURN, JUST PRINT FUNCTION NAME
#
jsb prtnm # print name
jsb prtnl # terminate print line
jmp rtn05 # merge
#
# HERE FOR RETURN OR NRETURN, PRINT FUNCTION NAME = VALUE
#
rtn04: jsb prtnv # print name = value
#
# HERE AFTER COMPLETING TRACE
#
rtn05: movl (sp)+,r9 # pop pfblk pointer
movl (sp)+,r6 # pop return type string
#
# MERGE HERE IF NO TRACE REQUIRED
#
rtn06: movl r6,kvrtn # set rtntype keyword
movl 4*pfvbl(r9),r10 # load pointer to fn vrblk
#page
# RETRN (CONTINUED)
#
# GET VALUE OF FUNCTION
#
rtn07: movl r10,rtnbp # save block pointer
movl 4*vrval(r10),r10# load value
cmpl (r10),$b$trt # loop back if trapped
beqlu rtn07
movl r10,rtnfv # else save function result value
movl (sp)+,rtnsv # save original function value
movl (sp)+,r10 # pop saved pointer
beqlu rtn7c # no action if none
tstl kvpfl # jump if no profiling
beqlu rtn7c
jsb prflu # else profile last func stmt
cmpl kvpfl,$num02 # branch on value of profile keywd
beqlu rtn7a
#
# HERE IF &PROFILE = 1. START TIME MUST BE FRIGGED TO
# APPEAR EARLIER THAN IT ACTUALLY IS, BY AMOUNT USED BEFORE
# THE CALL.
#
movl pfstm,r5 # load current time
subl2 4*icval(r10),r5 # frig by subtracting saved amount
jmp rtn7b # and merge
#
# HERE IF &PROFILE = 2
#
rtn7a: movl 4*icval(r10),r5 # load saved time
#
# BOTH PROFILE TYPES MERGE HERE
#
rtn7b: movl r5,pfstm # store back correct start time
#
# MERGE HERE IF NO PROFILING
#
rtn7c: movl 4*fargs(r9),r7 # get number of args
addl2 4*pfnlo(r9),r7 # add number of locals
beqlu rtn10 # jump if no args/locals
# else set loop counter
addl2 4*pflen(r9),r9 # and point to end of pfblk
#
# LOOP TO RESTORE FUNCTIONS AND LOCALS
#
rtn08: movl -(r9),r10 # load next vrblk pointer
#
# LOOP TO FIND VALUE BLOCK
#
rtn09: movl r10,r6 # save block pointer
movl 4*vrval(r10),r10# load pointer to next value
cmpl (r10),$b$trt # loop back if trapped
beqlu rtn09
movl r6,r10 # else restore last block pointer
movl (sp)+,4*vrval(r10) # restore old variable value
sobgtr r7,rtn08 # loop till all processed
#
# NOW RESTORE FUNCTION VALUE AND EXIT
#
rtn10: movl rtnbp,r10 # restore ptr to last function block
movl rtnsv,4*vrval(r10) # restore old function value
movl rtnfv,r9 # reload function result
movl r$cod,r10 # point to new code block
movl kvstn,kvlst # set lastno from stno
movl 4*cdstm(r10),kvstn # reset proper stno value
movl kvrtn,r6 # load return type
cmpl r6,$scrtn # exit with result in xr if return
bnequ 0f
jmp exixr
0:
cmpl r6,$scfrt # fail if freturn
bnequ 0f
jmp exfal
0:
#page
#
# RETRN (CONTINUED)
#
# HERE FOR NRETURN
#
cmpl (r9),$b$nml # jump if is a name
beqlu rtn11
jsb gtnvr # else try convert to variable name
.long er_243 # function result in nreturn is not name
movl r9,r10 # if ok, copy vrblk (name base) ptr
movl $4*vrval,r6 # set name offset
jmp rtn12 # and merge
#
# HERE IF RETURNED RESULT IS A NAME
#
rtn11: movl 4*nmbas(r9),r10 # load name base
movl 4*nmofs(r9),r6 # load name offset
#
# MERGE HERE WITH RETURNED NAME IN (XL,WA)
#
rtn12: movl r10,r9 # preserve xl
movl (r3)+,r7 # load next word
movl r9,r10 # restore xl
cmpl r7,$ofne$ # exit if called by name
bnequ 0f
jmp exnam
0:
movl r7,-(sp) # else save code word
jsb acess # get value
.long exfal # fail if access fails
movl r9,r10 # if ok, copy result
movl (sp),r9 # reload next code word
movl r10,(sp) # store result on stack
movl (r9),r10 # load routine address
movl r10,r11 # jump to execute next code word
jmp (r11)
#page
#
# 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
incl errft # fatal error
movl intvt,r5 # get 10
addl2 kvstl,r5 # add to former limit
movl r5,kvstl # store as new stlimit
movl intvt,r5 # get 10
movl r5,kvstc # set as new count
jmp er_244 # statement count exceeds value of stlimit keyword
#page
#
# 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
movl r9,r$cod # set new code block pointer
tstl kvpfl # skip if no profiling
beqlu stgo1
jsb prflu # else profile the statement
stgo1: movl kvstn,kvlst # set lastno
movl 4*cdstm(r9),kvstn# set stno
addl2 $4*cdcod,r9 # point to first code word
movl r9,r3 # set code pointer
movl kvstc,r5 # get stmt count
bgeq 0f # omit counting if negative
jmp exits
0:
tstl r5 # fail if stlimit reached
beql stcov
subl2 intv1,r5 # decrement
movl r5,kvstc # replace it
tstl r$stc # exit if no stcount trace
bnequ 0f
jmp exits
0:
#
# HERE FOR STCOUNT TRACE
#
clrl r9 # clear garbage value in xr
movl r$stc,r10 # load pointer to stcount trblk
jsb ktrex # execute keyword trace
jmp exits # and then exit for next code word
#page
#
# 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
tstl r9 # skip if sysax already called (reg04)
beqlu stpra
jsb sysax # call after execution proc
stpra: addl2 rsmem,dname # use the reserve memory
cmpl r9,$endms # skip if not normal end message
bnequ stpr0
tstl exsts # skip if exec stats suppressed
beqlu 0f
jmp stpr3
0:
clrl erich # clear errors to int.ch. flag
#
# LOOK TO SEE IF AN ENDING MESSAGE IS SUPPLIED
#
stpr0: jsb prtpg # eject printer
tstl r9 # skip if no message
beqlu stpr1
jsb prtst # print message
#
# MERGE HERE IF NO MESSAGE TO PRINT
#
stpr1: jsb prtis # print blank line
movl kvstn,r5 # get statement number
movl $stpm1,r9 # point to message /in statement xxx/
jsb prtmx # print it
jsb systm # get current time
subl2 timsx,r5 # minus start time = elapsed exec tim
movl r5,stpti # save for later
movl $stpm3,r9 # point to msg /execution time msec /
jsb prtmx # print it
movl kvstl,r5 # get statement limit
blss stpr2 # skip if negative
subl2 kvstc,r5 # minus counter = count
movl r5,stpsi # save
movl $stpm2,r9 # point to message /stmts executed/
jsb prtmx # print it
movl stpti,r5 # reload elapsed time
mull2 intth,r5 # *1000 (microsecs)
bvs stpr2
divl2 stpsi,r5 # divide by statement count
bvs stpr2
movl $stpm4,r9 # point to msg (mcsec per statement /
jsb prtmx # print it
#page
#
# STOPR (CONTINUED)
#
# MERGE TO SKIP MESSAGE (OVERFLOW OR NEGATIVE STLIMIT)
#
stpr2: movl gbcnt,r5 # load count of collections
movl $stpm5,r9 # point to message /regenerations /
jsb prtmx # print it
jsb prtis # one more blank for luck
#
# CHECK IF DUMP REQUESTED
#
stpr3: jsb prflr # print profile if wanted
#
movl kvdmp,r9 # load dump keyword
jsb dumpr # execute dump if requested
movl r$fcb,r10 # get fcblk chain head
movl kvabe,r6 # load abend value
movl kvcod,r7 # load code value
jsb sysej # exit to system
#page
#
# 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
movl 4*pthen(r9),r9 # load successor node
movl (r9),r10 # load node code entry address
movl r10,r11 # jump to match successor node
jmp (r11)
#page
#
# SYSAB -- PRINT /ABNORMAL END/ AND TERMINATE
#
sysab: #rtn
movl $endab,r9 # point to message
movl $num01,kvabe # set abend flag
jsb prtnl # skip to new line
jmp stopr # jump to pack up
#page
#
# SYSTU -- PRINT /TIME UP/ AND TERMINATE
#
systu: #rtn
movl $endtu,r9 # point to message
movl strtu,r6 # get chars /tu/
movl r6,kvcod # put in kvcod
movl timup,r6 # check state of timeup switch
movl sp,timup # set switch
tstl r6 # stop run if already set
beqlu 0f
jmp stopr
0:
jmp er_245 # translation/execution time expired
#title s p i t b o l -- stack overflow section
#
# CONTROL COMES HERE IF THE MAIN STACK OVERFLOWS
#
er_001: movzwl $1,r6
jmp error
er_002: movzwl $2,r6
jmp error
er_003: movzwl $3,r6
jmp error
er_004: movzwl $4,r6
jmp error
er_005: movzwl $5,r6
jmp error
er_006: movzwl $6,r6
jmp error
er_007: movzwl $7,r6
jmp error
er_008: movzwl $8,r6
jmp error
er_009: movzwl $9,r6
jmp error
er_010: movzwl $10,r6
jmp error
er_011: movzwl $11,r6
jmp error
er_012: movzwl $12,r6
jmp error
er_013: movzwl $13,r6
jmp error
er_014: movzwl $14,r6
jmp error
er_015: movzwl $15,r6
jmp error
er_016: movzwl $16,r6
jmp error
er_017: movzwl $17,r6
jmp error
er_018: movzwl $18,r6
jmp error
er_019: movzwl $19,r6
jmp error
er_020: movzwl $20,r6
jmp error
er_021: movzwl $21,r6
jmp error
er_022: movzwl $22,r6
jmp error
er_023: movzwl $23,r6
jmp error
er_024: movzwl $24,r6
jmp error
er_025: movzwl $25,r6
jmp error
er_026: movzwl $26,r6
jmp error
er_027: movzwl $27,r6
jmp error
er_028: movzwl $28,r6
jmp error
er_029: movzwl $29,r6
jmp error
er_030: movzwl $30,r6
jmp error
er_031: movzwl $31,r6
jmp error
er_032: movzwl $32,r6
jmp error
er_033: movzwl $33,r6
jmp error
er_034: movzwl $34,r6
jmp error
er_035: movzwl $35,r6
jmp error
er_036: movzwl $36,r6
jmp error
er_037: movzwl $37,r6
jmp error
er_038: movzwl $38,r6
jmp error
er_039: movzwl $39,r6
jmp error
er_040: movzwl $40,r6
jmp error
er_041: movzwl $41,r6
jmp error
er_042: movzwl $42,r6
jmp error
er_043: movzwl $43,r6
jmp error
er_044: movzwl $44,r6
jmp error
er_045: movzwl $45,r6
jmp error
er_046: movzwl $46,r6
jmp error
er_047: movzwl $47,r6
jmp error
er_048: movzwl $48,r6
jmp error
er_049: movzwl $49,r6
jmp error
er_050: movzwl $50,r6
jmp error
er_051: movzwl $51,r6
jmp error
er_052: movzwl $52,r6
jmp error
er_053: movzwl $53,r6
jmp error
er_054: movzwl $54,r6
jmp error
er_055: movzwl $55,r6
jmp error
er_056: movzwl $56,r6
jmp error
er_057: movzwl $57,r6
jmp error
er_058: movzwl $58,r6
jmp error
er_059: movzwl $59,r6
jmp error
er_060: movzwl $60,r6
jmp error
er_061: movzwl $61,r6
jmp error
er_062: movzwl $62,r6
jmp error
er_063: movzwl $63,r6
jmp error
er_064: movzwl $64,r6
jmp error
er_065: movzwl $65,r6
jmp error
er_066: movzwl $66,r6
jmp error
er_067: movzwl $67,r6
jmp error
er_068: movzwl $68,r6
jmp error
er_069: movzwl $69,r6
jmp error
er_070: movzwl $70,r6
jmp error
er_071: movzwl $71,r6
jmp error
er_072: movzwl $72,r6
jmp error
er_073: movzwl $73,r6
jmp error
er_074: movzwl $74,r6
jmp error
er_075: movzwl $75,r6
jmp error
er_076: movzwl $76,r6
jmp error
er_077: movzwl $77,r6
jmp error
er_078: movzwl $78,r6
jmp error
er_079: movzwl $79,r6
jmp error
er_080: movzwl $80,r6
jmp error
er_081: movzwl $81,r6
jmp error
er_082: movzwl $82,r6
jmp error
er_083: movzwl $83,r6
jmp error
er_084: movzwl $84,r6
jmp error
er_085: movzwl $85,r6
jmp error
er_086: movzwl $86,r6
jmp error
er_087: movzwl $87,r6
jmp error
er_088: movzwl $88,r6
jmp error
er_089: movzwl $89,r6
jmp error
er_090: movzwl $90,r6
jmp error
er_091: movzwl $91,r6
jmp error
er_092: movzwl $92,r6
jmp error
er_093: movzwl $93,r6
jmp error
er_094: movzwl $94,r6
jmp error
er_095: movzwl $95,r6
jmp error
er_096: movzwl $96,r6
jmp error
er_097: movzwl $97,r6
jmp error
er_098: movzwl $98,r6
jmp error
er_099: movzwl $99,r6
jmp error
er_100: movzwl $100,r6
jmp error
er_101: movzwl $101,r6
jmp error
er_102: movzwl $102,r6
jmp error
er_103: movzwl $103,r6
jmp error
er_104: movzwl $104,r6
jmp error
er_105: movzwl $105,r6
jmp error
er_106: movzwl $106,r6
jmp error
er_107: movzwl $107,r6
jmp error
er_108: movzwl $108,r6
jmp error
er_109: movzwl $109,r6
jmp error
er_110: movzwl $110,r6
jmp error
er_111: movzwl $111,r6
jmp error
er_112: movzwl $112,r6
jmp error
er_113: movzwl $113,r6
jmp error
er_114: movzwl $114,r6
jmp error
er_115: movzwl $115,r6
jmp error
er_116: movzwl $116,r6
jmp error
er_117: movzwl $117,r6
jmp error
er_118: movzwl $118,r6
jmp error
er_119: movzwl $119,r6
jmp error
er_120: movzwl $120,r6
jmp error
er_121: movzwl $121,r6
jmp error
er_122: movzwl $122,r6
jmp error
er_123: movzwl $123,r6
jmp error
er_124: movzwl $124,r6
jmp error
er_125: movzwl $125,r6
jmp error
er_126: movzwl $126,r6
jmp error
er_127: movzwl $127,r6
jmp error
er_128: movzwl $128,r6
jmp error
er_129: movzwl $129,r6
jmp error
er_130: movzwl $130,r6
jmp error
er_131: movzwl $131,r6
jmp error
er_132: movzwl $132,r6
jmp error
er_133: movzwl $133,r6
jmp error
er_134: movzwl $134,r6
jmp error
er_135: movzwl $135,r6
jmp error
er_136: movzwl $136,r6
jmp error
er_137: movzwl $137,r6
jmp error
er_138: movzwl $138,r6
jmp error
er_139: movzwl $139,r6
jmp error
er_140: movzwl $140,r6
jmp error
er_141: movzwl $141,r6
jmp error
er_142: movzwl $142,r6
jmp error
er_143: movzwl $143,r6
jmp error
er_144: movzwl $144,r6
jmp error
er_145: movzwl $145,r6
jmp error
er_146: movzwl $146,r6
jmp error
er_147: movzwl $147,r6
jmp error
er_148: movzwl $148,r6
jmp error
er_149: movzwl $149,r6
jmp error
er_150: movzwl $150,r6
jmp error
er_151: movzwl $151,r6
jmp error
er_152: movzwl $152,r6
jmp error
er_153: movzwl $153,r6
jmp error
er_154: movzwl $154,r6
jmp error
er_155: movzwl $155,r6
jmp error
er_156: movzwl $156,r6
jmp error
er_157: movzwl $157,r6
jmp error
er_158: movzwl $158,r6
jmp error
er_159: movzwl $159,r6
jmp error
er_160: movzwl $160,r6
jmp error
er_161: movzwl $161,r6
jmp error
er_162: movzwl $162,r6
jmp error
er_163: movzwl $163,r6
jmp error
er_164: movzwl $164,r6
jmp error
er_165: movzwl $165,r6
jmp error
er_166: movzwl $166,r6
jmp error
er_167: movzwl $167,r6
jmp error
er_168: movzwl $168,r6
jmp error
er_169: movzwl $169,r6
jmp error
er_170: movzwl $170,r6
jmp error
er_171: movzwl $171,r6
jmp error
er_172: movzwl $172,r6
jmp error
er_173: movzwl $173,r6
jmp error
er_174: movzwl $174,r6
jmp error
er_175: movzwl $175,r6
jmp error
er_176: movzwl $176,r6
jmp error
er_177: movzwl $177,r6
jmp error
er_178: movzwl $178,r6
jmp error
er_179: movzwl $179,r6
jmp error
er_180: movzwl $180,r6
jmp error
er_181: movzwl $181,r6
jmp error
er_182: movzwl $182,r6
jmp error
er_183: movzwl $183,r6
jmp error
er_184: movzwl $184,r6
jmp error
er_185: movzwl $185,r6
jmp error
er_186: movzwl $186,r6
jmp error
er_187: movzwl $187,r6
jmp error
er_188: movzwl $188,r6
jmp error
er_189: movzwl $189,r6
jmp error
er_190: movzwl $190,r6
jmp error
er_191: movzwl $191,r6
jmp error
er_192: movzwl $192,r6
jmp error
er_193: movzwl $193,r6
jmp error
er_194: movzwl $194,r6
jmp error
er_195: movzwl $195,r6
jmp error
er_196: movzwl $196,r6
jmp error
er_197: movzwl $197,r6
jmp error
er_198: movzwl $198,r6
jmp error
er_199: movzwl $199,r6
jmp error
er_200: movzwl $200,r6
jmp error
er_201: movzwl $201,r6
jmp error
er_202: movzwl $202,r6
jmp error
er_203: movzwl $203,r6
jmp error
er_204: movzwl $204,r6
jmp error
er_205: movzwl $205,r6
jmp error
er_206: movzwl $206,r6
jmp error
er_207: movzwl $207,r6
jmp error
er_208: movzwl $208,r6
jmp error
er_209: movzwl $209,r6
jmp error
er_210: movzwl $210,r6
jmp error
er_211: movzwl $211,r6
jmp error
er_212: movzwl $212,r6
jmp error
er_213: movzwl $213,r6
jmp error
er_214: movzwl $214,r6
jmp error
er_215: movzwl $215,r6
jmp error
er_216: movzwl $216,r6
jmp error
er_217: movzwl $217,r6
jmp error
er_218: movzwl $218,r6
jmp error
er_219: movzwl $219,r6
jmp error
er_220: movzwl $220,r6
jmp error
er_221: movzwl $221,r6
jmp error
er_222: movzwl $222,r6
jmp error
er_223: movzwl $223,r6
jmp error
er_224: movzwl $224,r6
jmp error
er_225: movzwl $225,r6
jmp error
er_226: movzwl $226,r6
jmp error
er_227: movzwl $227,r6
jmp error
er_228: movzwl $228,r6
jmp error
er_229: movzwl $229,r6
jmp error
er_230: movzwl $230,r6
jmp error
er_231: movzwl $231,r6
jmp error
er_232: movzwl $232,r6
jmp error
er_233: movzwl $233,r6
jmp error
er_234: movzwl $234,r6
jmp error
er_235: movzwl $235,r6
jmp error
er_236: movzwl $236,r6
jmp error
er_237: movzwl $237,r6
jmp error
er_238: movzwl $238,r6
jmp error
er_239: movzwl $239,r6
jmp error
er_240: movzwl $240,r6
jmp error
er_241: movzwl $241,r6
jmp error
er_242: movzwl $242,r6
jmp error
er_243: movzwl $243,r6
jmp error
er_244: movzwl $244,r6
jmp error
er_245: movzwl $245,r6
jmp error
er_246: movzwl $246,r6
jmp error
er_247: movzwl $247,r6
jmp error
er_248: movzwl $248,r6
jmp error
er_249: movzwl $249,r6
jmp error
er_250: movzwl $250,r6
jmp error
er_251: movzwl $251,r6
jmp error
er_252: movzwl $252,r6
jmp error
er_253: movzwl $253,r6
jmp error
er_254: movzwl $254,r6
jmp error
er_255: movzwl $255,r6
jmp error
er_256: movzwl $256,r6
jmp error
er_257: movzwl $257,r6
jmp error
er_258: movzwl $258,r6
jmp error
er_259: movzwl $259,r6
jmp error
er_260: movzwl $260,r6
jmp error
er_261: movzwl $261,r6
jmp error
er_262: movzwl $262,r6
jmp error
er_263: movzwl $263,r6
jmp error
er_264: movzwl $264,r6
jmp error
er_265: movzwl $265,r6
jmp error
er_266: movzwl $266,r6
jmp error
er_267: movzwl $267,r6
jmp error
er_268: movzwl $268,r6
jmp error
er_269: movzwl $269,r6
jmp error
er_270: movzwl $270,r6
jmp error
er_271: movzwl $271,r6
jmp error
er_272: movzwl $272,r6
jmp error
er_273: movzwl $273,r6
jmp error
er_274: movzwl $274,r6
jmp error
er_275: movzwl $275,r6
jmp error
er_276: movzwl $276,r6
jmp error
er_277: movzwl $277,r6
jmp error
er_278: movzwl $278,r6
jmp error
er_279: movzwl $279,r6
jmp error
er_280: movzwl $280,r6
jmp error
er_281: movzwl $281,r6
jmp error
er_282: movzwl $282,r6
jmp error
er_283: movzwl $283,r6
jmp error
er_284: movzwl $284,r6
jmp error
er_285: movzwl $285,r6
jmp error
er_286: movzwl $286,r6
jmp error
er_287: movzwl $287,r6
jmp error
er_288: movzwl $288,r6
jmp error
er_289: movzwl $289,r6
jmp error
er_290: movzwl $290,r6
jmp error
er_291: movzwl $291,r6
jmp error
er_292: movzwl $292,r6
jmp error
er_293: movzwl $293,r6
jmp error
er_294: movzwl $294,r6
jmp error
er_295: movzwl $295,r6
jmp error
er_296: movzwl $296,r6
jmp error
er_297: movzwl $297,r6
jmp error
.globl sec05
sec05:
#sec # start of stack overflow section
#
incl errft # fatal error
movl flptr,sp # pop stack to avoid more fails
tstl gbcfl # jump if garbage collecting
bnequ stak1
jmp er_246 # stack overflow
#
# NO CHANCE OF RECOVERY IN MID GARBAGE COLLECTION
#
stak1: movl $endso,r9 # point to message
clrl kvdmp # memory is undumpable
jmp stopr # give up
#title 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: cmpl r$cim,$cmlab # jump if error in scanning label
bnequ 0f
jmp cmple
0:
movl r6,kvert # save error code
clrl scnrs # reset rescan switch for scane
clrl scngo # reset goto switch for scane
movl stage,r9 # load current stage
casel r9,$0,$stgno # jump to appropriate error circuit
5:
.word err01-5b # initial compile
.word err04-5b # execute time compile
.word err04-5b # eval compiling expr.
.word err05-5b # execute time
.word err01-5b # compile - after end
.word err04-5b # xeq compile-past end
.word err04-5b # eval evaluating expr
#esw # end switch on error type
#page
#
# 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: movl cmpxs,sp # reset stack pointer
#ssl cmpss # restore s-r stack ptr for cmpil
tstl errsp # jump if error suppress flag set
beqlu 0f
jmp err03
0:
movl erich,erlst # set flag for listr
jsb listr # list line
jsb prtis # terminate listing
clrl erlst # clear listr flag
movl scnse,r6 # load scan element offset
beqlu err02 # skip if not set
movl r6,r7 # loop counter
incl r6 # increase for ch$ex
jsb alocs # string block for error flag
movl r9,r6 # remember string ptr
movab cfp$f(r9),r9 # ready for character storing
movl r$cim,r10 # point to bad statement
movab cfp$f(r10),r10 # ready to get chars
#
# LOOP TO REPLACE ALL CHARS BUT TABS BY BLANKS
#
erra1: movzbl (r10)+,r8 # get next char
cmpl r8,$ch$ht # skip if tab
beqlu erra2
movl $ch$bl,r8 # get a blank
#page
#
# MERGE TO STORE BLANK OR TAB IN ERROR LINE
#
erra2: movb r8,(r9)+ # store char
sobgtr r7,erra1 # loop
movl $ch$ex,r10 # exclamation mark
movb r10,(r9) # store at end of error line
#csc r9 # end of sch loop
movl $stnpd,profs # allow for statement number
movl r6,r9 # point to error line
jsb prtst # print error line
#
# HERE AFTER PLACING ERROR FLAG AS REQUIRED
#
err02: jsb ermsg # generate flag and error message
addl2 $num03,lstlc # bump page ctr for blank, error, blk
clrl r9 # in case of fatal error
cmpl errft,$num03 # pack up if several fatals
blssu 0f
jmp stopr
0:
#
# COUNT ERROR, INHIBIT EXECUTION IF REQUIRED
#
incl cmerc # bump error count
addl2 cswer,noxeq # inhibit xeq if -noerrors
cmpl stage,$stgic # special return if after end line
beqlu 0f
jmp cmp10
0:
#page
#
# LOOP TO SCAN TO END OF STATEMENT
#
err03: movl r$cim,r9 # point to start of image
movab cfp$f(r9),r9 # point to first char
movzbl (r9),r9 # get first char
cmpl r9,$ch$mn # jump if error in control card
bnequ 0f
jmp cmpce
0:
clrl scnrs # clear rescan flag
movl sp,errsp # set error suppress flag
jsb scane # scan next element
cmpl r10,$t$smc # loop back if not statement end
beqlu 0f
jmp err03
0:
clrl errsp # clear error suppress flag
#
# GENERATE ERROR CALL IN CODE AND RETURN TO CMPIL
#
movl $4*cdcod,cwcof # reset offset in ccblk
movl $ocer$,r6 # load compile error call
jsb cdwrd # generate it
movl cwcof,4*cmsoc(sp)# set success fill in offset
movl sp,4*cmffc(sp) # set failure fill in flag
jsb cdwrd # generate succ. fill in word
jmp 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: clrl r$ccb # forget garbage code block
#ssl iniss # restore main prog s-r stack ptr
jsb ertex # get fail message text
subl2 $4,sp # 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: addl2 $4,sp # pop stack
cmpl sp,flprt # jump if prog defined fn call found
beqlu errc4
cmpl sp,gtcef # loop if not eval or code call yet
bnequ erra4
movl $stgxt,stage # re-set stage for execute
movl r$gtc,r$cod # recover code ptr
movl sp,flptr # restore fail pointer
clrl r$cim # forget possible image
#
# TEST ERRLIMIT
#
errb4: tstl kverl # jump if errlimit non-zero
bnequ err07
jmp exfal # fail
#
# RETURN FROM PROG. DEFINED FUNCTION IS OUTSTANDING
#
errc4: movl flptr,sp # restore stack from flptr
jmp errb4 # merge
#page
#
# 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
tstl dmvch # jump if in mid-dump
bnequ err08
#
# MERGE HERE FROM ERR08
#
err06: tstl kverl # abort if errlimit is zero
bnequ 0f
jmp labo1
0:
jsb ertex # get fail message text
#
# MERGE FROM ERR04
#
err07: cmpl errft,$num03 # abort if too many fatal errors
blssu 0f
jmp labo1
0:
decl kverl # decrement errlimit
movl r$ert,r10 # load errtype trace pointer
jsb ktrex # generate errtype trace if required
movl r$cod,r$cnt # set cdblk ptr for continuation
movl flptr,r9 # set ptr to failure offset
movl (r9),stxof # save failure offset for continue
movl r$sxc,r9 # load setexit cdblk pointer
bnequ 0f # continue if no setexit trap
jmp lcnt1
0:
clrl r$sxc # else reset trap
movl $nulls,stxvr # reset setexit arg to null
movl (r9),r10 # load ptr to code block routine
movl r10,r11 # execute first trap statement
jmp (r11)
#
# INTERRUPTED PARTLY THROUGH A DUMP WHILST STORE IS IN A
# MESS SO DO A TIDY UP OPERATION. SEE DUMPR FOR DETAILS.
#
err08: movl dmvch,r9 # chain head for affected vrblks
beqlu err06 # done if zero
movl (r9),dmvch # set next link as chain head
jsb setvr # restore vrget field
jmp err08 # loop through chain
#title s p i t b o l -- here endeth the code
#
# END OF ASSEMBLY
#
#end # end macro-spitbol assembly