	#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
	bnequ 0f; jmp cnc08; 0:
#
#      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
	blequ 0f; jmp srh03; 0:
	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
