         TITLE    'WMAQ-B00,08/22/73,DWG702985'
         SYSTEM   SIG7F
         CSECT    1
         PCC      0                 CONTROL CARDS NOT PRINTED.
WMAQ@    RES      0  ORIGIN OF WORKSPACE MGMT & ACQUISITION MODULE.
*
*  REF'S  AND  DEF'S
*
         DEF      WMAQ@             = START OF WMAQ MODULE.
         DEF      ALOCRS            ALLOCATES A 'RESULT' DATA BLK.
         DEF      ALOCNONX          NON-EXEC. ALLOCS., CALLS 'ALOCHNW'.
         DEF      ALOCHNW           ALLOCS. N WDS + 2-WD HDR + 1 IF ODD.
         DEF      ALOCTRES          ALLOCATES A TEXT 'RESULT' DATA BLK.
         DEF      ALOCBLK           ALLOCS. DATA BLK, SETS SIZE & REF=1.
         DEF      GIVEBACK          GIVE TAIL OF D.B. BACK TO FREE TBL.
         DEF      CKVDB              CK STRUCTURE OF VAR. DATA BLK.
         DEF      WSCHEK             CK WS (DIAG. TOOL)
         DEF      WSCKDSPL           CK WS STRUCT., DISPLACING DB PTRS
*                                      BY THE DYNAMIC OFFSET FOR THE WS
*                                      WHEN SAVED VS. WHEN LOADED.
         DEF      CTEST             TRIES TO GET MORE COMMON.
         DEF      SICLR             CLEARS STATE-INDICATOR TO GO-STATE.
         DEF      SICLR%              (ALTERNATE ENTRY TO SICLR).
         DEF      MAYDREF           DE-REFS DATA BLK IF 1 IS POINTED TO.
         DEF      DREF              DE-REFERENCES DATA BLK PT'ED TO.
         DEF      GARBCOLL          GARBAGE COLLECTOR.
         DEF      ACQNAME           ACQUIRES A NAME, PUTS NEW IN SYM TBL
         DEF      HASHINC           HASH INCREMENT (SEE COPY CMD 'HASH')
         DEF      FINDNAME          FINDS NAME IF IN SYMBOL TABLE
         DEF      IN2CODE           INTERNAL CHAR'S CODE BYTE TABLE.
         DEF      ACQNXCC           ACQ NEXT INTERNAL CHAR & ITS CODE.
         DEF      ACQCC             ACQ CURRENT CHAR & ITS CODE.
         DEF      ACQCODE           ACQ CODE OF CURRENT CHAR.
         DEF      ACQNXNB           ACQ NEXT NON-BLANK & ITS CODE.
         DEF      ACQNB             ACQ NON-BLANK & ITS CODE.
         DEF      ACQIT             ACQ NAME OR NUMERIC ITEM.
*                               REFS TO PROCEDURE:
         REF      GETDYN            GETS MORE DYNAMIC PAGES.
         REF      GETCOM            GETS 1 MORE PAGE OF COMMON.
         REF      ERWSFUL           ERROR -- WORKSPACE FULL.
         REF      SYSTERR           ERROR -- SYSTEM ERROR.
*                               REFS TO CONTEXT:
         REF      DYNBOUND          UPPER BOUND FOR DYNAMIC REGION.
         REF      STKLIMIT          CURRENT LIMIT FOR EXECUTION STACK.
         REF      LOCNEED           NEW LOC. NEEDED WHEN OVER STACK LIMT
         REF      CORLEFT           ZERO IF NO MORE PAGES AVAILABLE.
         REF      NEWBOUND          NEW UPPER BOUND NEEDED FOR DYNAMIC.
         REF      SYMT              PTS AT 1ST WD OF SYMBOL TABLE.
         REF      SYMTSIZE          NO.OF ENTRYS FOR SYMBOL TABLE.
         REF      NSYMTWDS          NO.OF WORDS IN SYMBOL TABLE.
         REF      NAMEBUF           BUFFER TO HOLD ACQUIRED NAME.
         REF      NAMEWDS           TEMP TO HOLD # WDS CONTAINING A NAME
         REF      NAMLIMIT          = MAX # CHARS USED FOR A NAME.
         REF      NAMEWDSZ          = MAX # WDS USED TO CONTAIN A NAME.
         REF      FREETOTL          TOTAL SPACE CONTAINED IN FREE TABLE.
         REF      FREETBL           FREE TABLE (2-WD ENTRIES--LOC & AMT)
         REF      MAXFRENS          MAX NO.OF FREE TABLE ENTRIES.
         REF      FBOUNDS           HOLDS FREE-BLK BOUNDS FOR GARB.COLL.
         REF      FAQMS             HOLDS FREE-ACCUMULATIONS TO FBOUNDS.
         REF      NR2MOVE           NO.OF REGIONS TO MOVE IN GARB.COLL.
         REF      BLKWANTD          HOLDS SIZE OF NEW DATA BLK WANTED.
         REF      RESULT            PTR TO 'RESULT' DATA BLK.
         REF      RSRANK            RANK FOR 'RESULT' DATA BLK.
         REF      RSTYPE            TYPE FOR 'RESULT' DATA BLK.
         REF      STRAYS            AREA FOR STRAY DATA BLK PTRS.
         REF      STRAYBLK          TOTAL SIZE OF STRAY DATA BLK PTR SET
         REF      DBROOT            IF NZ, PTS AT ROOT DB FOR LIST-FDEF.
         REF      DBSERIES          PTR INTO A LIST OR FUN. DESCPIPTOR.
         REF      CURRCS             PTR TO CODESTRING DATA BLK (+2)
         REF      DREFSAVE          SAVE REGS DURING DE-REFERENCING.
         REF      GARBSAVE          SAVE REGS FOR GARBAGE COLLECT, ET AL
         REF      GCTEMP            TEMP FOR GARBAGE COLLECT.
         REF      LINKGC            LINK TO GARBAGE COLLECTOR.
         REF      LINKWS            LINK FOR WORKSPACE MGMT ROUTINES.
         REF      TOPOSTAK          PTS AT TOP OF EXECUTION STACK.
         REF      STATEPTR          PTS AT TOP STATE-ENTRY IN STACK.
         REF      GOSTATE           PTS AT GO-STATE ENTRY IN STACK.
*                               REFS TO CONSTANTS:
         REF      X1FFFF            X'1FFFF'
         REF      ZEROZERO          0,0
         REF      BLANKS            WD CONTAINING ALL BLANKS.
         REF      NONAME            RANGE THAT EXCLUDES NAME-CHAR CODES.
         REF      FUNTYPES          RANGE OF FUN.DESCRIPTOR D.B. TYPES.
         REF      BITPOS            32-WD TBL OF BITS (BITPOS-K CONTAINS
*                                     A WD HAVING A 1 ONLY IN BIT POS K)
*
*  EQU'S  RELATED TO CONTEXT
*
HASHAQM  EQU      NAMEWDS           PARTIAL HASH VALUE ACCUMULATOR.
*
*  STANDARD EQU'S
*                        REGISTERS
R0       EQU      0
R1       EQU      1
R2       EQU      2
R3       EQU      3
R4       EQU      4
R5       EQU      5
R6       EQU      6
R7       EQU      7
R8       EQU      8
R9       EQU      9
R10      EQU      10
R11      EQU      11
R12      EQU      12
R13      EQU      13
R14      EQU      14
R15      EQU      15
*
*  OTHER EQU'S
*
STOPNMCD EQU      21                STOPNAME CODESTRING DESIGNATOR.
NAMECODE EQU      23                ORDINARY NAME CODESTRING DESIGNATOR.
LASTCSV  EQU      138               LAST CODESTRING DESIGNATOR, CODES
*                                     ABOVE THIS VALUE ARE FOR THE
*                                     NAME-START CHARS.
DELTA    EQU      X'48'             DELTA CHAR (EBCDIC MAPPING).
HASHINC  EQU      32                HASHING INCREMENT ON HASH-CRASH.
TOPRANK  EQU      63                 MAX. ALLOWED RANK.
TYPEXSEQ EQU      5                  TYPE FOR INDEX-SEQUENCE DATA BLKS.
TYPELIST EQU      6                 SIGNIFIES LIST TYPE DATA BLOCKS.
TYPLONGN EQU      X'12'       SIGNIFIES LONG-NAME TYPE DATA BLKS.
CATLC    EQU      11                 LINE-CHAIN CATEGORY OF STACK ENTRY.
LISTLOFF EQU      2                 OFFSET FROM LIST DB HDR TO LENGTH WD
XSIZOFF  EQU      2                 OFFSET TO FUN.DESCRS. XSIZE WD.
NFLOFF   EQU      7                 OFFSET FROM FUN.DESCR. HDR TO THE
*                                     WD CONTAINING NO.OF FUNCTION LINES
TRNKXSEQ EQU      X'0501'           TYPE & RANK OF INDEX-SEQ. DATA BLK.
*
*  DOUBLEWORD CONSTANTS
*
         BOUND    8
SANDT    DATA     'S','T'           USED IN TESTING FOR STOP OR TRACE.
*
*  WORD CONSTANTS
*
MINUS2   DATA     X'FFFFFFFE'       ALL BUT LAST BIT POSITION.
 PAGE
************************************************************************
*                                                                      *
*  ALLOCATION REQUEST ROUTINES:                                        *
*                                                                      *
*  ALOCRS -- ALLOCATES A DATA BLOCK FOR THE RESULT OF AN OPERATION.    *
*        IT SETS 'RESULT' TO PT AT THAT BLOCK AND PLANTS TYPE (GIVEN   *
*        BY 'RSTYPE') AND RANK (VIA 'RSRANK') IN THE HEADER.  SEE ALSO *
*        'ALOCBLK' FOR SIZE AND REF-COUNT SETTINGS.                    *
* ALOCTRES -- ENTRY PT UNDER ALOCRS FOR TEXT TYPE DATA BLK.            *
*        REGS:   R11 (ENTRY) NO.OF ELEMENTS (BITS, BYTES, WDS, OR      *
*                    DBLWDS) NEEDED FOR RESULT.                        *
*                R14 LINK, EXIT VIA *R14.                              *
*                R4  (EXIT) ALSO PTS AT NEW DATA BLOCK.                *
*                R7 AND R11 ARE VOLATILE; SEE ALSO 'ALOCBLK'.          *
*                                                                      *
*  ALOCNONX -- ALLOCATES SPACE FOR NON-EXECUTION PROCESSES, USING      *
*        ALOCHNW.  LINK IS R14:  RETURN+0 IF WS FULL & RETURN+1 IF OK. *
*                                                                      *
*  ALOCHNW -- ALLOCATES A DATA BLOCK OF N WDS + 2 WDS FOR HDR + AN     *
*        EXTRA WD IF NECESSARY TO REACH AN EVEN NO.  SEE ALSO 'ALOCBLK'*
*        REGS:   R11 (ENTRY) N WDS REQUESTED, NOT COUNTING HDR, NOT    *
*                    NECESSARILY AN EVEN NO.                           *
*                R11 IS CLOBBERED; SEE ALSO 'ALOCBLK'.                 *
*                R7  LINK; EXIT IS IN 'ALOCBLK'.                       *
*                                                                      *
*  ALOCBLK -- ALLOCATES A DATA BLOCK, SETS ITS SIZE FIELD, AND SETS    *
*        ITS REF-COUNT TO ONE.                                         *
*        REGS:   R11 (ENTRY) SIZE OF BLOCK WANTED, MUST BE EVEN NO.    *
*                R7  LINK, EXIT VIA 0,R7                               *
*                R4  (EXIT) PTS AT FIRST WD OF NEW DATA BLOCK.         *
*                R5, R10, AND R11 ARE VOLATILE.                        *
*                                                                      *
ALOCNONX BAL,R7   ALOCHNW           ALLOC. HDR + N WDS & EVEN SIZE...
         AI,R14   1                   OK, SET RETURN+1.
         B       *R14                 (IF WS FULL, ALOCBLK EXITS HERE)
*
ALOCRS   LW,R4    RSTYPE            VECTOR ON THE TYPE OF RESULT...
TYPER    B        TYPER,R4            0 -- IMPOSSIBLE                @
         B        LOGL                1 -- LOGICAL                   @
         B        TEXT                2 -- CHARACTER                 @
         B        UPRANK              3 -- INTEGER, ERGO WDS.        @
         B        REAL                4 -- REAL, ERGO DBLWDS.        @
         B        XSEQ                5 -- XSEQ (INDEX SEQUENCE)     @
         B        UPRANK              6 -- LIST, ERGO WDS.           @
REAL     SLS,R11  1
UPRANK   AW,R11   RSRANK            DATA BLK NEEDS 1 WD PER DIMENSION.
         LI,R7    SETRS             RETURN TO 'SETRS' AFTER GETTING BLK.
ALOCHNW  AI,R11   2                 2 WDS NEEDED FOR THE HEADER
         CI,R11   1                 CK FOR EVEN NO.OF WDS...
         BAZ      ALOCBLK             YEP, OK.
         AI,R11   1                   NOPE, GET AN EXTRA WD.
ALOCBLK  STW,R11  BLKWANTD          SAVE TOTAL BLK SIZE WANTED.
RETRY    SW,R11   FREETOTL          IS THAT MUCH FREE CURRENTLY...
         BLEZ     FRETSET             YES -- SEARCH THE FREE TABLE.
         STW,R8   LINKWS              NO, SAVE R8.
         BAL,R8   GARBCOLL          DO GARBAGE COLLECTION.
         LW,R8    LINKWS            RESTORE R8.
         LW,R10   CORLEFT           ARE MORE PAGES AVAILABLE...
         BEZ      OLAP                NO -- TRY TO OVERLAP INTO COMMON.
         AW,R11   DYNBOUND            YES, CALC. HI NEEDED DYNAMIC BOUND
         STW,R11  NEWBOUND          (WE'LL PROBABLY GET MUCH MORE).
         LCW,R11  DYNBOUND          = - THE 'OLD' BOUND.
         BAL,R14  GETDYN            GET NEW DYNAMIC PAGE OR PAGES.
         LW,R14   GARBSAVE+14 NOTE--GARBCOLL SAVED R14 HERE, SO THIS OK.
         AW,R11   DYNBOUND          CALC SIZE = 'NEW' - 'OLD' BOUNDS.
         AWM,R11  FREETOTL          ADD THAT SIZE INTO THE FREE TABLE.
         AWM,R11  FREETBL+1
         LW,R11   BLKWANTD          GET SIZE WANTED (WE MAY NOT SUCCEED)
         B        RETRY
OLAP     LW,R11   TOPOSTAK          CALC. SPACE BETWEEN STACK & LAST
         SW,R11   FREETBL             DYNAMIC WD IN USE.
         SW,R11   BLKWANTD          = SPACE LEFT OVER AFTER THE NEW BLK.
         SAS,R11  -2                DIVIDE BY 4 (4 IS MINIMUM ACCEPTBLE)
         SAS,R11  1                 TIMES 2 GIVES APPX. MIDPOINT.
         AI,R11   0                 TEST...
         BGZ      GOODY               OK.
         CI,R7    ALOCNONX+1          NONE OR LESS -- WS FULL, WHO CALLS
         BNE      ERWSFUL               EXECUTION PROCESS CALLED.
         B        1,R7                  NON-EXECUTION PROCESS CALLED.
GOODY    AW,R11   BLKWANTD          = AMT ADDED TO DYNAMIC.
         STW,R11  FREETOTL          PUT THAT AMT IN THE FREE TABLE.
         STW,R11  FREETBL+1
         AW,R11   FREETBL           CALC NEW DYNAMIC BOUNDARY, AND MAKE
         STW,R11  DYNBOUND            IT THE CURRENT EXEC. STACK LIMIT
         STW,R11  STKLIMIT            ALSO; THEN 'SEARCH' FOR NEW BLK.
FRETSET  LI,R5    FREETBL-2         PT AT ENTRY BEFORE FREE TABLE.
FREESRCH AI,R5    2                 PT AT NEXT FREE TABLE ENTRY.
         LW,R11   1,R5              GET ITS SIZE...
         BNEZ     SIZETEST            OK, TRY IT.
         STW,R8   LINKWS              ZERO MEANS NO ENTRY BIG ENUF.
         BAL,R8   GARBCOLL          DO GARBAGE COLLECTION.
         LW,R8    LINKWS            RESTORE R8.
         LW,R11   FREETBL+1         GET SIZE COLLECTED, WE KNOW IT'S OK.
         LI,R5    FREETBL           PT AT THAT ENTRY.
SIZETEST CW,R11   BLKWANTD          IS FREE BLK BIG ENUF...
         BL       FREESRCH            NO, KEEP SEARCHING THE FREE TBL.
         BG       SHRINK              YES, BIGGER THAN NEEDED.
         LW,R4    0,R5              EXACT SIZE NEEDED, PURGE THIS FREE
         SLS,R5   -1                  TABLE ENTRY BY MOVING LATER
MOVEUP   AI,R5    1                   ENTRIES UP THE TABLE.
         LD,R10   0,R5
         STD,R10  -2,R5
         BNEZ     MOVEUP            BOTTOM ENTRY IS DOUBLE ZERO.
         LW,R11   BLKWANTD          GET SIZE OF DATA BLOCK.
         AI,R5    -DA(FREETBL)-1    HAVE WE CLEARED OUT ALL OF FREE TBL
         BNEZ     FINALE              NO, JUST ONE ENTRY AMONG OTHERS.
         LW,R5    DYNBOUND            YES, SET 1ST FREE LOCATION TO BE
         STW,R5   FREETBL               THE BOUNDARY FOR DYNAMIC.
FINALE   STW,R11  0,R4              SET THE DATA BLK HDR'S SIZE FIELD.
         LCW,R11  BLKWANTD
         AWM,R11  FREETOTL          DECREASE THE TOTAL NO.OF FREE WDS.
         LI,R11   1
         STW,R11  1,R4              SET DATA BLK'S REF-COUNT = 1.
         B        0,R7              EXIT.
SHRINK   LW,R4    0,R5              = LOC OF NEW DATA BLOCK
         SW,R11   BLKWANTD          SHRINK THIS FREE TBL ENTRY'S SIZE.
         STW,R11  1,R5
         LW,R11   BLKWANTD          GET SIZE OF DATA BLOCK, AND ADJUST
         AWM,R11  0,R5                LOC OF FREE BLK THAT REMAINS.
         B        FINALE
SETRS    STW,R4   RESULT            RESULT REFS THE NEW DATA BLOCK.
         LW,R11   RSTYPE            GET TYPE
         SLS,R11  8                   MAKE ROOM FOR
         OR,R11   RSRANK                THE RANK AND
         STH,R11 *RESULT                  FINISH DATA BLK HEADER.
         B       *R14               EXIT.
TEXT     AI,R11   3                 ROUND NO.OF CHARS UP TO WD MULTIPLE.
         SLS,R11  -2                NO.OF WDS NEEDED FOR TEXT DATA.
         B        UPRANK
LOGL     AI,R11   31                ROUND NO.OF BITS UP TO WD MULTIPLE.
         SLS,R11  -5                NO.OF WDS NEEDED FOR LOGICAL DATA.
         B        UPRANK
ALOCTRES EQU      TEXT              ALLOCATE TEXT RESULT DATA BLK.
XSEQ     LI,R11   6                 AN INDEX SEQ BLK USES 6 WDS, ALMOST.
         BAL,R7   ALOCBLK
         STW,R4   RESULT            RESULT REFS THE NEW DATA BLOCK.
         LI,R11   TRNKXSEQ          SET TYPE AND RANK (= 1) FOR XSEQ.
         STH,R11 *RESULT
         B       *R14               EXIT.
************************************************************************
*                                                                      *
* GIVEBACK -- GIVES BACK A PORTION OF A DATA BLOCK.                    *
*        REGS:   R11 (ENTRY) NO.OF WDS NOT NEEDED.                     *
*                R7  LINK, EXIT VIA 0,R7                               *
*                R4  (ENTRY) PTS AT DATA BLOCK HEADER.                 *
*         NOTE -- SEE ALSO DREF.  R4 & R11 ARE VOLATILE.
*                                                                      *
GIVEBACK AND,R11  MINUS2            WON'T GIVE BACK AN ODD NO.OF WDS.
         BEZ      0,R7              FORGET IT.
         STW,R11  BLKWANTD          SAVE EVEN NO.OF WDS TO GIVE UP.
         LCW,R11  BLKWANTD          = - NO.OF WDS TO GIVE UP.
         AWM,R11  0,R4              TAKE THAT MANY FROM THE DATA BLK.
         INT,R11  0,R4              GET SIZE (SHRUNKEN) OF THAT DATA BLK
         AW,R4    R11               PT AT 1ST WD AFTER THAT DATA BLK.
         LW,R11   BLKWANTD          FAKE DATA BLK (TYPE ZERO) CONTAINING
         STW,R11  0,R4                'GIVE UP' AMT FOR ITS SIZE FIELD.
         LI,R11   1                 ALSO FAKE A REF-COUNT OF ONE FOR IT.
         STW,R11  1,R4
         B        DREF              NOW DEREFERENCE THE FAKE DATA BLK.
 PAGE
************************************************************************
*
*  CKVDB -- CHECKS STRUCTURE OF A VARIABLE OR TEMP DATA BLK.
*  CKVDB13 -- ALT.ENTRY; R13= EVEN, NONZERO SIZE
*        VERIFIES:
*                 SIZE IS EVEN AND NONZERO
*                 RANK IS PERMISSIBLE
*                 LENGTH WORDS LIE INSIDE THE DATA BLK
*                 TYPE IS LOGL,TEXT,INTG,REAL,XSEQ
*                 DATA LIES INSIDE THE DATA BLK
*                 NO LENGTH WORD IS NEGATIVE
*        REGS:   R4  (ENTRY) PTS AT DATA BLK HEADER.
*                R6  (ENTRY) CONTAINS TYPE.
*                R7  (LINK) RETURN-0  IF BAD DATA BLK.
*                           RETURN-1  IF OK.
*                R4,R5,R12,R13  ARE VOLATILE.
*
CKVDB    INT,R13  0,R4              GET DATA BLK SIZE.
         CI,R13   1                 VERIFY EVEN, NONZERO SIZE.
         BCS,5    0,R7                ERROR EXIT.
CKVDB13  AI,R13   -2                DISCOUNT DATA BLK HEADER.
         LI,R5    1                 SET FOR 1 ELEMENT OF DATA.
         LB,R12  *R4,R5             GET RANK.
         CI,R12   TOPRANK           VERIFY REASONABLE RANK...
         BG       0,R7                ERROR EXIT.
         SW,R13   R12               DISCOUNT ANY LENGTH WDS...
         BLZ      0,R7                TOO SHORT -- ERROR EXIT.
         CI,R6    TYPEXSEQ          VERIFY TYPE...
         BLE      CKVDBV,R6       @   OK, VECTOR ON TYPE.
CKVDBV   B        0,R7            @   0 OR HIGH -- ERROR EXIT.
         B        CKVDBL          @ LOGL
         B        CKVDBT          @ TEXT
         B        CKVDBI          @ INTG
         B        CKVDBR          @ REAL
         AI,R12   -1              @ XSEQ, VERIFY RANK =1...
         BNEZ     0,R7                ERROR EXIT.
         AI,R13   -3                VERIFY SIZE...
         BGEZ     1,R7                OK EXIT.
         B        0,R7                ERROR EXIT.
CKVDBL   SLS,R13  5                 32 ELEMS/WORD.
         B        CKVDBI
CKVDBT   SLS,R13  2                 4 ELEMS/WORD.
         B        CKVDBI
CKVDBR   SLS,R13  -1                HALF ELEM/WORD.
CKVDBI   AI,R4    1                 PT AT REF-COUNT WD.
CKVDBQ   AI,R12   -1                DECR RANK REMAINING...
         BGEZ     CKVDBM              MULT NEXT LENGTH.
         CW,R5    R13                 DONE, DO # ELEMS FIT...
         BLE      1,R7                  OK EXIT.
         B        0,R7                  ERROR EXIT.
CKVDBM   AI,R4    1                 PT AT NEXT LENGTH WD.
         MW,R5    0,R4              MULT THAT LENGTH...
         BOV      0,R7                OFLO -- ERROR EXIT.
         BGZ      CKVDBQ              LOOP IF ABOVE ZERO.
CKVDBN   BLZ      0,R7                NEG LENGTH WD -- ERROR EXIT.
         AI,R12   -1                DECR RANK REMAINING...
         BLZ      1,R7                DONE (EMPTY ARRAY) OK EXIT.
         AI,R4    1                 PT AT NEXT LENGTH WD.
         LW,R5    0,R4              TEST FOR NEG. LENGTH.
         B        CKVDBN
 PAGE
***********************************************************************
*
*  WSCHEK -- CHECKS WORKSPACE STRUCTURE.  THIS ENTRY PROVIDES
*            A DIAGNOSTIC TOOL; CALLS TO WSCHEK CAN BE PATCHED
*            IN WHEN IT IS SUSPECTED THAT SOME OPERATION IS DAMAGING
*            THE WORKSPACE.
*  WSCKDSPL -- CHECKS A LOADED WORKSPACE STRUCTURE AND
*            DISPLACES DATA BLOCK POINTERS IF THE WORKSPACE
*            WAS SAVED WITH A DIFFERENT DYNAMIC ORIGIN
*            (R2, UPON ENTRY, MUST CONTAIN THE DISPLACEMENT
*            VALUE OR ZERO -- NOTE R2 IS VOLATILE FOR THIS
*            ENTRY POINT).
*       REGS:    R14 -- LINK, RETURN-0 IF WS CHECKS OUT
*                             RETURN-1 IF BAD WS.
*                REGS ARE VOLATILE IF BAD WS
*                R2 IS VOLATILE FOR THE WSCKDSPL ENTRY;
*                   OTHERWISE, REGS ARE PRESERVED.
*       CHECKS PERFORMED:
*         - EACH EXECUTION-STACK ENTRY HAS A VALID CATEGORY
*         - NO DATA BLOCK OVERLAPS THE DYNAMIC BOUNDARY.
*         - EACH DATA BLK HAS A POSITIVE REF COUNT.                     U06-0004
*         - EACH DATA BLK SIZE IS EVEN & NONZERO.
*         - EACH DATA BLK TYPE FIELD IS VALID:
*            - (LOGL,TEXT,INTG,REAL,XSEQ) FURTHER TESTS ARE
*              MADE BY THE 'CKVDB' ROUTINE.
*            - (LIST) TRACKING WORD MUST BE ZERO.
*            - (CODESTRING) OFFSET ABOVE ZERO AND RTMOST
*              BYTE WITHIN 7 BYTES OF THE NEXT BLOCK.
*            - (INTRINSIC FUNCTION) SIZE = 2.
*            - (GROUP) LAST HALFWD WITHIN 3 HALFWDS OF THE
*              NEXT BLOCK.
*         - TOTAL REF-COUNT ACCUMULATION BALANCES THE TOTAL
*           NO.OF DATA BLOCK POINTERS.
*  THE DATA BLK POINTERS OF INTEREST ARE THOSE OCCURRING IN:
*    THE STRAY BLOCK 'STRAYS',
*    THE EXEC. STACK (V,X,Q,D,F CATEGORY ENTRIES),
*    THE SYMBOL TABLE (REF-INDICATORS & LONG-NAME PTRS),
*    THE DATA BLOCKS THEMSELVES (LISTS & FUNCTION DESCR'S).
*
WSCHEK   STW,R2   GARBSAVE+2        SAVE R2 FOR THIS ENTRY PT.
         LI,R2    0                 SET DISPLACEMENT VALUE = 0.
WSCKDSPL LCI      11                SAVE R3 THRU R13.
         STM,R3   GARBSAVE+3
         LI,R3    0                 CLEAR REF-ACCUMULATION.
         LI,R7    -1
WFREESET AI,R7    1
         LD,R4    FREETBL,R7        FREE FRAG. (LOC & SIZE)...
         AI,R5    0
         BEZ      WSTRAYS             NO MORE IN USE.
         STW,R3   1,R4              FAKE A DATA BLK OF THAT SIZE
         STW,R5   0,R4                MAKE IT A FREE BLK,
         B        WFREESET            REF-CNT = 0 & TYPE = 0.
WSTRAYS  LI,R13   STRAYBLK          = # STRAY DATA BLK PTRS.
         LI,R4    STRAYS            PT AT 1ST STRAY D. B. PTR.
         BAL,R7   AQMDP             ACCUM REF & DISPLACE.
         AI,R4    1                 PT AT NEXT.
         BDR,R13  AQMDP             LOOP THRU STRAYS.
         LW,R4    TOPOSTAK          PT AT TOP OF EXEC. STACK.
         B        WSTAK
WDROPOP  AI,R4    2                 SKIP 2-WD O-CATEGORY.
         B        WSTAK
W1       BAL,R7   AQMDP             ACCUM REF & DISPLACE.
WPOP     AI,R4    1                 PT AT NEXT EXEC.STACK WD.
WSTAK    LB,R6   *R4                = STACK ENTRY CATEGORY...
         AI,R6    -CATLC
         BLEZ     WSCAT+CATLC,R6      VECTOR IF LEGAL CATEGORY.
         BAL,R15  WSERR               OOPS -- BAD CATEGORY.
WSCAT    B        W1             @  V
         B        WPOP           @  A'
         B        WDROPOP        @  O
         B        W1             @  X
         B        WPOP           @  B
         B        WPOP           @  P
         B        WPOP           @  S
         AI,R4    1              @  Q -- MOVE TO CURRPTR WD.
         B        W1             @  D
         B        WPOP           @  A
         B        WFCAT          @  F
*        B        WLC            @  LINE-CHAIN
WLC      BAL,R7   AQMDP          @  ACCUM REF & DISPLACE.
         AI,R4    3                 PT AT NEXT ENTRY IN EXEC.STACK.
         B        WSTAK
WFCAT    LI,R5    X'7FFF'           EXTRACT ITS 'NEXT' FIELD...
         AND,R5   0,R4
         BEZ      WSYM              (FINAL) HIT SYMBOL TABLE.
         AI,R4    1                 (FUNC.) PT AT FDEFPTR WD.
         BAL,R7   AQMDP             ACCUM REF & DISPLACE.
         AI,R4    1                 PT AT CALLPTR WD.
         BAL,R7   AQMDP             ACCUM REF & DISPLACE.
         AI,R4    3                 PT 2 WDS PAST # SHAD. PAIRS.
         LW,R13   -2,R4             HOW MANY...
         BEZ      WFBU                NONE.
         BAL,R7   AQMDP             ACCUM REF & DISPLACE.
         AI,R4    2                 PT 2 WDS FURTHER.
         BDR,R13  AQMDP             LOOP TILL BEYOND.
WFBU     BDR,R4   WSTAK             BACK UP TO ENTRY PAST F-ENTRY &
*                                     GO CHECK ITS CATEGORY.
WSYM     LW,R13   SYMTSIZE          = # ENTRIES FOR SYM TBL.
         LI,R12   NAMEWDSZ          = MAX # WDS TO HOLD NAME.
         LW,R4    SYMT              PT AT 1ST REF-INDIC WD.
WSYME    LI,R7    WSYMN             EXIT AQMDP AT WSYMN.
AQMDP    LI,R5    X'1FFFF'
         AND,R5   0,R4              TEST FOR DATA BLK PTR...
         BEZ      0,R7                NIL -- EXIT.
         AWM,R2   0,R4                YES, DISPLACE IT PERHAPS.
         AI,R3    1                 ACCUM 1 MORE REFERENCE.
         B        0,R7              EXIT.
WSYMN    AI,R4    1                 PT AT NEXT NAME-INDIC WD
         CB,R12  *R4                  & CK FOR SHORT NAME...
         BL       WSYMS                 YES.
         BAL,R7   AQMDP                 NO, LONG OR NIL.
WSYMS    AI,R4    1                 PT AT NEXT REF-INDIC WD &
         BDR,R13  WSYME               LOOP TILL DONE.
         STW,R4   GCTEMP            DONE, R4 PTS AT 1ST DATA
         B        WDBQ                BLK, PROBABLY.
WDBV     BAL,R7   CKVDB13         @ CK VAR OR TEMP DATA BLK...
         BAL,R15  WSERR           @   OOPS -- BAD.
WNBLK    LW,R4    GCTEMP          @   OK, PT AT NEXT BLK UNLESS
WDBQ     CW,R4    DYNBOUND          REACHED DYNAMIC BOUNDARY...
         BL       WDB                 NOT YET.
         BE       WEND                YES, GOOD SO FAR.
         BAL,R15  WSERR               TOO FAR -- BAD.
WDB      INT,R13  0,R4              GET SIZE OF THIS DATA BLK.
         AWM,R13  GCTEMP            (UPDATE PTR TO NEXT BLK).
         CI,R13   1                 SIZE EVEN & NONZERO...
         BCR,5    WDBREF              OK.
         BAL,R15  WSERR               OOPS -- BAD.
WDBREF   SW,R3    1,R4              ACCT FOR BLK'S REF-COUNT.
         LB,R6   *R4                GET DATA BLK'S TYPE...
         BEZ      WNBLK               FREE BLOCK.
         LW,R8    1,R4                   (CK REF-COUNT)                 U06-0006
         BGZ      WDBREFOK                 (OK)                         U06-0007
         BAL,R15  WSERR                    (BAD)                        U06-0008
WDBREFOK CI,R6    TYPELIST                                              U06-0009
         BL       WDBV                VARIABLE OR TEMP.
         AI,R6    -TYPLONGN
         BLEZ     WDBT-TYPELIST+TYPLONGN,R6
         BAL,R15  WSERR               INVALID TYPE -- BAD.
WDBT     B        WLIST           @   LIST.
         B        WCS             @   CODESTRING.
         B        WFUND           @   FUNCTION DESCRIPTOR.
         B        WFUND           @     ''        ''
         B        WFUND           @     ''        ''
         B        WFUND           @     ''        ''
         B        WFUND           @     ''        ''
         B        WFUND           @     ''        ''
         B        WIF             @   INTRINSIC FUNCTION.
         B        WIF             @       ''       ''
         B        WIF             @       ''       ''
         B        WGRP            @   GROUP.
         B        WLN             @   LONG NAME.
WLN      EQU      WNBLK
WIF      AI,R13   -2                IS SIZE = 2...
         BEZ      WNBLK               YES.
         BAL,R15  WSERR               NO -- BAD.
WGRP     AI,R4    2                 PT AT WD CONTAINING
         LH,R8   *R4                  # NAMES IN THIS GROUP.
         SLS,R8   -1                GO WITH # OF FURTHER WDS
         B        WOFFCK              IN GROUP DATA BLK.
WCS      AI,R4    2                 PT AT WD CONTAINING OFFSET.
         LH,R8   *R4                VERIFY ABOVE ZERO...
         BGZ      WCSO                OK # BYTES OF CODESTRING.
         BAL,R15  WSERR               BAD.
WCSO     SLS,R8   -2                # MORE WDS IN CS DATA BLK.
WOFFCK   AW,R4    R8                PT AT LAST WD IN USE.
         OR,R4    BITPOS-31         (OR ODD GARBAGE WD).
         AI,R4    1                 PT AT NEXT WD; IT SHOULD BE
         CW,R4    GCTEMP              NEXT DATA BLK LOC.
         BE       WDBQ                  OK, IT IS.
         BAL,R15  WSERR                 BAD.
WLIST    AI,R4    3                 PT PAST LENGTH WD.
         LW,R13   -1,R4             GET LENGTH OF LIST...
         BEZ      WLISTZ              0, CK TRACKING WD ONLY
         BAL,R7   AQMDP             ACCUM REF & DISPLACE.
         AI,R4    1                 PT AT NEXT WD.
         BDR,R13  AQMDP             LOOP TILL TRACKING WD HIT.
WLISTZ   LW,R13   0,R4              TRACKING WD = 0...
         BEZ      WNBLK               YES -- OK.
         BAL,R15  WSERR               NO -- BAD.
WFUND    AI,R4    XSIZOFF           PT AT XSIZE WD.
         LI,R13   X'E0000'
         CW,R13   0,R4              DOES IT PT AT ERR-CTRL TBL...
         BAZ      WFUNDNFL            NO.
         BAL,R7   AQMDP               YES, ACCUM REF & DISPLACE.
WFUNDNFL LW,R13   NFLOFF-XSIZOFF,R4 GET # FUNCTION LINE PTRS...
         BEZ      WNBLK               NONE.
         AI,R4    -XSIZOFF+NFLOFF+1 PT AT 1ST LINE PTR.
         BAL,R7   AQMDP             ACCUM REF & DISPLACE.
         AI,R4    1                 PT AT NEXT WD.
         BDR,R13  AQMDP             LOOP TILL LOCAL-LABEL WD.
         LI,R13   X'FFFF'
         AND,R13  0,R4              GET # LABEL ENTRIES...
         BEZ      WNBLK               NONE.
         AI,R4    2                 PT AT ENTRY'S DB PTR WD.
         BAL,R7   AQMDP             ACCUM REF & DISPLACE.
         AI,R4    2                 PT AT NEXT, IF ANY.
         BDR,R13  AQMDP             LOOP TILL DONE
         B        WNBLK
WEND     AI,R3    0                 CK REF BALANCE...
         BEZ      WSOK                OK.
         LI,R15   WSERR               BAD (SET R15).
WSERR    AI,R14   1                 SET FOR RETURN-1 (ERROR).
         B       *R14
WSOK     LCI      12
         LM,R2    GARBSAVE+2        RESTORE REGS SAVED ON ENTRY.
         B       *R14               RETURN.
 PAGE
************************************************************************
*                                                                      *
*  CTEST -- WHEN MORE COMMON IS NEEDED, CTEST IS ENTERED.  IT DECIDES  *
*        WHETHER TO GET A NEW PAGE OF COMMON OR TO OVERLAP INTO THE    *
*        CURRENT DYNAMIC AREA.                                         *
*        REGS:   R8 -- LINK (VOLATILE) EXIT VIA *LINKWS.               *
*                                   RETURN+0 IF WS FULL.               *
*                                   RETURN+1 IF ENUF COMMON OBTAINED.  *
*                R1 -- (EXIT) PTS AT LOC REQUESTED BY LOCNEED IF OK.   *
*                                                                      *
CTEST    AI,R8    1                 SET FOR NORMAL RETURN.
         STW,R8   LINKWS            SAVE THAT LINKAGE.
         STW,R1   TOPOSTAK          SAVE PTR TO CURRENT TOP OF STACK.
CTEST1   LW,R8    CORLEFT           ARE PAGES AVAILABLE...
         BNEZ     GET1C               YES -- GET 1 MORE.
         BAL,R8   GARBCOLL            NO, DO GARBAGE COLLECTION.
         LW,R8    LOCNEED           CALC. SPACE BETWEEN LOC NEEDED &
         SW,R8    FREETBL             LAST DYNAMIC WD IN USE.
         SAS,R8   -2                DIVIDE BY 4 (4 IS MINIMUM ACCEPTBLE)
         SAS,R8   1                 TIMES 2 TO GET APPX. MIDPOINT
         AI,R8    0                 TEST...
         BGZ      CTESTOK             ENUF.
         MTW,-1   LINKWS              NOT ENUF, BACK UP FOR THE
         B       *LINKWS                WS FULL EXIT.
CTESTOK  STW,R8   FREETOTL          PUT ABOUT HALF OF LEFT-OVER SPACE
         STW,R8   FREETBL+1               IN FREE TABLE, SETTING THE
         AW,R8    FREETBL                 DYNAMIC BOUNDARY & STACK LIMIT
         STW,R8   DYNBOUND                EQUAL (AT MID POINT).
GOTC     STW,R8   STKLIMIT          SET NEW STACK LIMIT.
         LW,R1    LOCNEED           SET STACK PTR TO LOC NEEDED.
         B       *LINKWS            EXIT
GET1C    STW,R14  GARBSAVE+14       SAVE R14.
         BAL,R14  GETCOM            GET ANOTHER COMMON PAGE.
         LW,R14   GARBSAVE+14       RESTORE R14.
         LW,R1    LOCNEED           SET STACK PTR TO LOC NEEDED.
         CW,R1    STKLIMIT          MAKE SURE WE HAVE ENUF STACK...
         BG      *LINKWS              YES, EXIT
         LW,R1    TOPOSTAK            NO, RESET R1 IN CASE WS FULL.
         B        CTEST1            TRY FOR ANOTHER PAGE.
 PAGE
************************************************************************
*                                                                      *
*  SICLR -- CLEARS ENTRIES OFF THE STATE INDICATOR UNTIL REACHING THE  *
*        ENTRY THAT 'GOSTATE' POINTS TO.                               *
*  SICLR% -- ALTERNATE ENTRY PT, R1 PTS AT TOP OF STACK.               *
*       REGS:    R14 LINK, EXIT VIA *R14.                              *
*                R1  (EXIT) PTS AT NEW TOP OF STACK AFTER CLEARANCE.   *
*                R2  (EXIT) CATEGORY AT TOP OF STACK AFTER CLEARANCE.  *
*                VOLATILE: R4,R5,R7,R13      SEE ALSO 'DREF'.          *
*                                                                      *
SICLR    LW,R1    TOPOSTAK          PT AT TOP OF STACK.
         B        SICLR%
SICLROP  AI,R1    2                 DROP BOTH WDS OF O-CATEGORY.
         B        SICLR%
SICLRQ   AI,R1    1                 DROP 1ST WD OF Q-CATEGORY.
         MTW,-2   0,R1              MAKE CODESTRING PTR PT AT DB HDR.
SICLR1   LI,R4    0
         XW,R4    0,R1              CLEAR & DEREFERENCE IF DB PTR.
         BAL,R7   MAYDREF
SICLRG   AI,R1    1                 DROP A WD.
SICLR%   LB,R2   *R1                GET CATEGORY NOW AT TOP.
         CW,R1    GOSTATE           HAVE WE REACHED THE GO-STATE YET...
         BL       SICLRT,R2           NO, VECTOR ON THE CATEGORY.
         STW,R1   TOPOSTAK            YES, UPDATE TOP OF STACK PTR.
         STW,R1   STATEPTR          UPDATE STATE PTR EQUIVALENTALLY.
         B       *R14               EXIT.
SICLRT   B        SICLR1          @ V
         B        SICLRG          @ A-PRIME
         B        SICLROP         @ O
         B        SICLR1          @ X
         B        SICLRG          @ B
         B        SICLRG          @ P
         B        SICLRG          @ S
         B        SICLRQ          @ Q
         B        SICLR1          @ D
         B        SICLRG          @ A
*        B        SICLRF          @ F
*                                 @ (LINE-CHAIN NOT ALLOWED)
SICLRF   LI,R4    0               @
         XW,R4    1,R1              CLEAR & DEREF FDEFPTR WD UNLESS SI-
         BAL,R7   MAYDREF             DAMAGED ENTRY.
         LI,R4    0
         XW,R4    2,R1              CLEAR & DEREF CALLPTR WD AFTER
         AI,R4    -2                  CODESTRING PTR ADJUSTED TO DB HDR.
         BAL,R7   DREF
         AI,R1    4                 PT AT WD AFTER NO.OF SHADOW PAIRS.
         LW,R13   -1,R1             HOW MANY...
         BEZ      SICLR%              NONE, RESUME CLEARANCE.
         LI,R7    SICLRFX           SET RETURN FROM MAYDREF CALL, BELOW.
SICLRFS  LW,R5    0,R1              GET NAME PTR OF SHADOW PAIR ENTRY.
         LI,R4    0                 CLEAR & GET SHADOWED REFERENT.
         XW,R4    1,R1
         XW,R4   *SYMT,R5           UNSHADOW.
         AI,R1    2                 PT PAST THIS SHADOW PAIR.
         B        MAYDREF           DEREF LOCAL DATA BLK, IF ANY.
SICLRFX  BDR,R13  SICLRFS           LOOP TILL DONE WITH SHADOW PAIRS.
         B        SICLR%
 PAGE
*
* IN2CODE--BYTE TABLE.  FOR EACH POSSIBLE INTERNAL CHARACTER, THERE IS A
*        CORRESPONDING BYTE.  IN MOST CASES THIS IS THE CODESTRING VALUE
*        FOR THAT CHARACTER OR (FOR NAME CHARS) THE HASH CODE.  BLANK,
*        END-OF-INPUT, AND QUOTE USE SPECIAL VALUES; BAD (UNEXPECTED)
*        CHARS. USE THE SPECIAL CODE X'47'.
*                            *     *
*                 CODE       * HEX *    TRANSLATION CORRESPONDENCES:
*                 BYTES      *RANGE* (BYTE 0) (BYTE 1) (BYTE 2) (BYTE 3)
*               --------      -- --  -------- -------- -------- --------
IN2CODE  DATA X'47474747'    @00-03  BAD      BAD      BAD      BAD
         DATA X'47474747'    @04-07  BAD      BAD      BAD      BAD
         DATA X'47474747'    @08-0B  BAD      BAD      BAD      BAD
         DATA X'47474747'    @0C-0F  BAD      BAD      BAD      BAD
         DATA X'47474747'    @10-13  BAD      BAD      BAD      BAD
         DATA X'47324747'    @14-17  BAD      END-INPT BAD      BAD
         DATA X'47474747'    @18-1B  BAD      BAD      BAD      BAD
         DATA X'47474747'    @1C-1F  BAD      BAD      BAD      BAD
         DATA X'47474747'    @20-23  BAD      BAD      BAD      BAD
         DATA X'47474747'    @24-27  BAD      BAD      BAD      BAD
         DATA X'47474747'    @28-2B  BAD      BAD      BAD      BAD
         DATA X'47474747'    @2C-2F  BAD      BAD      BAD      BAD
         DATA X'47474747'    @30-33  BAD      BAD      BAD      BAD
         DATA X'47474747'    @34-37  BAD      BAD      BAD      BAD
         DATA X'47474747'    @38-3B  BAD      BAD      BAD      BAD
         DATA X'47474747'    @3C-3F  BAD      BAD      BAD      BAD
         DATA X'3365727E'    @40-43  BLANK    %FCT     %ECD     %
         DATA X'63784B9D'    @44-47  %MIN     %E       %GU      %UDL
         DATA X'D055832D'    @48-4B  %DLT     %I       %CPL     .(DOT)
         DATA X'66295B64'    @4C-4F  %LT      (        +        %ABS
         DATA X'854A2423'    @50-53  %CAP     %IB      %QQ      %Q
         DATA X'52736160'    @54-57  %TBR     %DCD     %O       %LOG
         DATA X'59142E86'    @58-5B  %REV     %COM     %SC      %CUP
         DATA X'5F2A264D'    @5C-5F  *        )        ;        %NOT
         DATA X'5C546253'    @60-63  %-(SUBR) /        %MAX     %RD1
         DATA X'75478084'    @64-67  %DRP     BAD      %W       %CPR
         DATA X'58477457'    @68-6B  %RV1     BAD      %TAK     ,
         DATA X'567D6851'    @6C-6F  %R       %U       %GT      %RND
         DATA X'6C7B7C4C'    @70-73  &        %DRS     -(NEG)   %GD
         DATA X'6782696E'    @74-77  %LE      %LOK     %GE      %NND
         DATA X'6F6D876A'    @78-7B  %NOR     %OR      :        %NE
         DATA X'7F346B81'    @7C-7F  @        '(QUOTE) =        %DEL
         DATA X'4799BBCE'    @80-83  BAD      %UA      %UB      %UC
         DATA X'F0BFA1FC'    @84-87  %UD      %UE      %UF      %UG
         DATA X'A9F44747'    @88-8B  %UH      %UI      BAD      BAD
         DATA X'47474747'    @8C-8F  BAD      BAD      BAD      BAD
         DATA X'47E6D2E2'    @90-93  BAD      %UJ      %UK      %UL
         DATA X'C5D6B58F'    @94-97  %UM      %UN      %UO      %UP
         DATA X'B1954747'    @98-9B  %UQ      %UR      BAD      BAD
         DATA X'47474747'    @9C-9F  BAD      BAD      BAD      BAD
         DATA X'4747C393'    @A0-A3  BAD      BAD      %US      %UT
         DATA X'A5F8EADA'    @A4-A7  %UU      %UV      %UW      %UX
         DATA X'DECA4747'    @A8-AB  %UY      %UZ      BAD      BAD
         DATA X'47474747'    @AC-AF  BAD      BAD      BAD      BAD
         DATA X'76775A47'    @B0-B3  %XP1     %XPD     %TPS     BAD
         DATA X'2728191A'    @B4-B7  %(       %)       %Q0      %Q1     U06-0011
         DATA X'1B1C1D1E'    @B8-BB  %Q2      %Q3      %Q4      %Q5
         DATA X'1F202122'    @BC-BF  %Q6      %Q7      %Q8      %Q9
         DATA X'47AB9BBD'    @C0-C3  BAD      A        B        C
         DATA X'91C7A3A7'    @C4-C7  D        E        F        G
         DATA X'B3EE4747'    @C8-CB  H        I        BAD      BAD
         DATA X'47474747'    @CC-CF  BAD      BAD      BAD      BAD
         DATA X'47D8DC9F'    @D0-D3  BAD      J        K        L
         DATA X'E4CC97B9'    @D4-D7  M        N        O        P
         DATA X'F6AF4747'    @D8-DB  Q        R        BAD      BAD
         DATA X'47474747'    @DC-DF  BAD      BAD      BAD      BAD
         DATA X'47478DFA'    @E0-E3  BAD      BAD      S        T
         DATA X'F2C1FEE8'    @E4-E7  U        V        W        X
         DATA X'D4E04747'    @E8-EB  Y        Z        BAD      BAD
         DATA X'47474747'    @EC-EF  BAD      BAD      BAD      BAD
         DATA X'00010203'    @F0-F3  0        1        2        3
         DATA X'04050607'    @F4-F7  4        5        6        7
         DATA X'08095D5E'    @F8-FB  8        9        #        %
         DATA X'2B2C5047'    @FC-FF  %GO      %IS      %MDV     BAD
 PAGE
************************************************************************
*                                                                      *
* ACQNXCC -- ACQUIRES THE NEXT INTERNAL-FORM CHAR AND ITS CODE (E.G.   *
*        CODESTRING VALUE, KEY INDICATOR, OR HASH VALUE).              *
* ACQCC -- ENTRY POINT FOR CURRENT CHAR, RATHER THAN NEXT ONE.         *
* ACQCODE -- ENTRY POINT TO JUST SET THE CODE                          *
*                                                                      *
*        REGS:   R1  (ENTRY) PTS AT LATEST, OR CURRENT, CHAR IN THE    *
*                    INPUT STRING.  (EXIT) PTS AT CHAR ACQUIRED.       *
*                R2  (EXIT) THE CHAR, ITSELF.                          *
*                R3  (EXIT) THE CODE FOR THAT CHAR.                    *
*                R4  LINK, EXIT VIA 0,R4                               *
*                                                                      *
ACQNXCC  AI,R1    1                 PT AT NEXT CHAR.
ACQCC    LB,R2    0,R1              GET CHAR.
ACQCODE  LB,R3    IN2CODE,R2        GET ITS CODE.
         B        0,R4              EXIT.
 PAGE
************************************************************************
*                                                                      *
* ACQNXNB -- ACQUIRES THE NEXT NON-BLANK INTERNAL-FORM CHAR AND ITS    *
*        CODE (E.G. CODESTRING VALUE, KEY INDICATOR, OR HASH VALUE).   *
* ACQNB -- ENTRY POINT THAT STARTS WITH CURRENT CHAR, RATHER THAN NEXT.*
*        REGS:   R1 (ENTRY) PTS AT LATEST, OR CURRENT, CHAR IN THE     *
*                   INPUT STRING.  (EXIT) PTS AT NON-BLANK CHAR ACQ'D. *
*                R2 (EXIT) THE NON-BLANK CHAR, ITSELF.                 *
*                R3 (EXIT) THE CODE FOR THAT CHAR.                     *
*                R4 LINK, EXIT VIA 0,R4                                *
*                                                                      *
ACQNXNB  AI,R1    1                 PT AT NEXT CHAR.
ACQNB    LB,R2    0,R1              GET CHAR.
         AI,R2    -' '              CK FOR BLANK.
         BEZ      ACQNXNB             YES, TRY NEXT ONE.
         AI,R2    ' '                 NO, RESTORE THAT CHAR.
         LB,R3    IN2CODE,R2        GET ITS CODE.
         B        0,R4              EXIT.
 PAGE
************************************************************************
*                                                                      *
* ACQNAME -- ACQUIRES A NAME (GIVEN THE NAME-START UPON ENTRY), HUNTS  *
*        FOR THAT NAME IN THE SYMBOL TABLE, IF NEW NAME ENTERS THAT    *
*        NAME, AND EXITS WITH THE PTR TO REFERENT-INDICATOR AND TYPE   *
*        OF NAME ACQUIRED (STOPNAME, TRACENAME, OR ORDINARY NAME).     *
*        REGS:   R1  (ENTRY) PTS AT NAME-START CHAR IN INPUT STRING.   *
*                    (EXIT) PTS AT (NON-BLANK) CHAR AFTER NAME.        *
*                R2  (ENTRY) CONTAINS NAME-START CHAR.                 *
*                    (EXIT) CONTAINS CHAR AFTER NAME.                  *
*                R3  (ENTRY) CODE FOR NAME-START CHAR, ITS HASH VALUE. *
*                    (EXIT) CODE FOR CHAR AFTER NAME.                  *
*                R4, R5, R7, R10, R11, R14 ARE VOLATILE.               *
*                R6  (EXIT) PTR TO REFERENT INDICATOR WD FOR NAME      *
*                R12 LINK -- 3 RETURNS:                                *
*                                   RETURN-0 -- SYMBOL TABLE FULL.     *
*                                               (ALSO USED FOR 'NAME-  *
*                                                NOT-FOUND' RETURN WHEN*
*                                                ACQNAME IS CALLED BY  *
*                                                FINDNAME, SEE BELOW). *
*                                   RETURN-1 -- WS FULL ON LONG NAME.  *
*                                   RETURN-2 -- NORMAL.                *
*                R13 (EXIT) TYPE OF NAME:                              *
*                                   21 = STOPNAME (S-DELTA-NAME)       *
*                                   22 = TRACENAME (T-DELTA-NAME)      *
*                                   23 = ORDINARY NAME                 *
*                                                                      *
ACQNAME  AI,R1    1                 PT AT CHAR AFTER THE NAME-START
         LI,R13   DELTA
         CB,R13   0,R1              IS IT A DELTA...
         BNE      NORMAL              NO, ORDINARY NAME
         CLM,R2   SANDT               YES, DID NAME START ON S OR T...
         BCS,9    NORMAL                NO, ORDINARY NAME
         LW,R13   R2                    YES, COMPUTE STOPNAME OR THE
         AI,R13   STOPNMCD-'S'      TRACENAME CODESTRING DESIGNATOR.
         BAL,R4   ACQNXCC           ACQ NEXT CHAR AND CODE
         CI,R3    LASTCSV           IS IT A NAME-START CHAR...
         BG       STPORTRC            YES, BEGINS NAME TO STOP OR TRACE.
         AI,R1    -3                  NO, ASSUME ORDINARY NAME
         BAL,R4   ACQNXCC           RE-ACQ THE S OR T.
         AI,R1    1                 PRETEND TO PT AT THE DELTA.
NORMAL   AI,R1    -1                FORGET ABOUT THE CHAR AFTER 1ST ONE.
         LI,R13   NAMECODE          ORDINARY NAME CODESTR. DESIGNATOR.
STPORTRC LI,R5    -1                PRE-SET NAME BUFFER BYTE OFFSETTER.
         LI,R14   NAMLIMIT          = NO.OF CHARS ACCEPTED PER NAME
         LI,R6    0                 CLEAR FOR DIVISION OF HASH TOTAL.
         LI,R7    0                 CLEAR HASH ACCUMULATOR.
         STW,R7   HASHAQM
         LI,R4    ENDTESTR          SO 'BDR,R14 ACQNXCC' WILL CAUSE A
*                                     RETURN TO 'ENDTESTR' UNLESS NAME
*                                     GETS TOO LONG.
NAMECHAR AWM,R3   HASHAQM           ADD LATEST HASH VALUE.
         AI,R5    1                 NEXT CHAR OFFSET INTO NAME BUFFER.
         STB,R2   NAMEBUF,R5        PUT CHAR IN NAME BUFFER.
         BDR,R14  ACQNXCC           ACQ NEXT CHAR IF NAME ISN'T TOO LONG
*                                     (RETURN IS TO 'ENDTESTR').
         BAL,R4   ACQNXCC           TOO LONG, SKIP TILL NON-NAME-CHAR.
         CLM,R3   NONAME              SHOWS UP.
         BCS,9    ACQNXCC           NOT YET, TRY AGAIN
         B        NAMEDONE          BINGO, FINALLY.
BLANKER  STB,R14  NAMEBUF,R5        FILL IN A BLANK.
         B        FILLER
ENDTESTR CLM,R3   NONAME            ANOTHER NAME-CHAR...
         BCS,9    NAMECHAR            YES, TRY AGAIN
NAMEDONE LW,R7    HASHAQM             NO, NAME IS DONE.
         SLS,R7   1                 GET PARTIAL HASH VALUE & CALC TOTAL
         LB,R4    NAMEBUF,R5        HASH VALUE = 2 * PARTIAL HASH VALUE
         AW,R7    R4                             + LAST CHAR (EBCDIC).
         BAL,R4   ACQNB             ACQ THE NON-BLANK AFTER THE NAME.
FINNAME  LI,R14   ' '               PREPARE FOR BLANK FILLING.
FILLER   AI,R5    1                 CK FOR WD BOUNDARY
         CI,R5    3
         BANZ     BLANKER             NO, APPEND A BLANK IN NAME BUFFER.
         SLS,R5   -2                  YES, GET NO.OF WDS FOR NAME.
         DW,R6    SYMTSIZE          REMAINDER (R6) WILL BE TENTATIVE
         SLS,R6   1                   ENTRY INTO SYM TBL.  CONVERT TO
         AI,R6    1                 POINTER TO NAME INDICATOR WD.
         LW,R14   SYMTSIZE          FOR COUNTDOWN IF HASHING CRASHING.
         CI,R5    1                 IS THIS A LONG OR SHORT NAME...
         BE       SHORT               SHORT NAME
*                                     LONG NAME
         SCS,R5   -8                PUT NO.OF NAME WDS IN BYTE 0, AND
         STW,R5   NAMEWDS             SAVE IT.
LONG     LW,R5   *SYMT,R6           GET A NAME INDICATOR WD.
         BEZ      NEWLNAME          NEW LONG NAME.
         LB,R4    R5                LOOK FOR MATCHING WORD COUNT.
         CB,R4    NAMEWDS
         BNE      RELONG            NO, TRY ANOTHER HASH LOC.
         AI,R5    -1                YES, PT AT REF WD IN OLD DATA BLK.
         AI,R6    -1
         LW,R7   *SYMT,R6           (TRY ANOTHER HASH LOC IF THIS
         AI,R6    1                  IS AN ALIEN LONG NAME PTR,
         CI,R7    X'40000'           I.E. DURING FILE-TYPE COPY CMD)
         BANZ     RELONG
LGNAMCK  LW,R7    NAMEBUF-1,R4      TEST LONG NAME FOR MATCHING WORDS,
         CW,R7   *R5,R4               GOING FROM LAST WD TO FIRST WD...
         BNE      RELONG                NO, TRY ANOTHER HASH LOC.
         BDR,R4   LGNAMCK               YES, LOOP TILL FIRST WD.
         B        FOUND             OK, FOUND MATCHING NAME.
RELONG   LI,R7    LONG              SET TO RETURN TO 'LONG'
NEWSTLOC AI,R6    2*HASHINC         INCR TO ANOTHER NAME INDICATOR WD.
         CW,R6    NSYMTWDS          ARE WE STILL IN THE SYM TBL...
         BL       INSIDE            YES.
         SW,R6    NSYMTWDS          NO, CYCLE BACK IN.
INSIDE   BDR,R14  0,R7              RETURN UNLESS WE'VE HIT ALL ENTRIES.
         B       *R12               OH-OH, TAKE SYM TBL FULL RETURN.
WSFULLLN AI,R12   1                 TAKE WS FULL RETURN, LONG NAME DATA
         B       *R12                 BLK WOULDN'T FIT.
NEWLNAME CI,R12   FINDNAME+1        WAS ACQNAME CALLED BY FINDNAME...
         BE      *R12                 YES -- TAKE 'NAME-NOT-FOUND' EXIT.
         LB,R11   NAMEWDS             NO, GET NO.OF WDS FOR THE NAME.
         BAL,R14  ALOCNONX          ALLOC DATA BLK, HEADER + THOSE WDS.
         B        WSFULLLN            OH-OH -- WS FULL.
         LI,R11   TYPLONGN          LONG NAME TYPE OF DATA BLOCK IS
         STB,R11 *R4                  SET IN TYPE-FIELD OF NEW D.B.
         AI,R4    2                 PT AT 1ST NAME WD POS IN NEW D.B.
         OR,R4    NAMEWDS           FILL IN WORD COUNT (= 2 TO 20) AND
         STW,R4  *SYMT,R6           SET NEW NAME INDICATOR WORD.
         LB,R7    NAMEWDS           PREPARE TO PUT NEW NAME IN THE D.B.
         AI,R4    -1                PT AT REF WD IN NEW DATA BLOCK.
NEWNAMWD LW,R10   NAMEBUF-1,R7      PUT NEW NAME IN LONG NAME DATA BLOCK
         STW,R10 *R4,R7               FROM LAST NAME WD TO FIRST.
         BDR,R7   NEWNAMWD
         B        FOUND             WE'VE FOUND A NEW NAME.
RESHORT  BAL,R7   NEWSTLOC          TRY ANOTHER HASH LOC.
SHORT    LW,R7   *SYMT,R6           GET A NAME INDICATOR WD.
         BEZ      NEWSNAME          NEW SHORT NAME.
         CW,R7    NAMEBUF           OLD ENTRY, DOES IT MATCH THIS NAME..
         BNE      RESHORT             NO, TRY AGAIN.
FOUND    AI,R6    -1                PT AT REFERENT-INDICATOR WD (I.E.
*                                   LOC RELATIVE TO 'SYMT')
         AI,R12   2                 SET FOR NORMAL RETURN.
         B       *R12               EXIT.
NEWSNAME CI,R12   FINDNAME+1        WAS ACQNAME CALLED BY FINDNAME...
         BE      *R12                 YES -- TAKE 'NAME-NOT-FOUND' EXIT.
         LW,R7    NAMEBUF             NO, GET NEW SHORT NAME & USE IT AS
         STW,R7  *SYMT,R6             THE NEW NAME INDICATOR WORD.
         B        FOUND             WE'VE FOUND A NEW NAME.
 PAGE
************************************************************************
*                                                                      *
*  FINDNAME -- FINDS A NAME (SEE 'ACQNAME' FOR ENTRY & EXIT SET-UPS).  *
*       R8 IS THE LINK -- IF NAME-NOT-FOUND, RETURN-0                  *
*                      -- IF NAME FOUND, RETURN-1                      *
*                                                                      *
*       WHEN 'FINDNAME' IS USED DURING COPYING, R6 PTS AT THE NAME-    *
*       INDICATOR WD OF AN EMPTY SYMBOL TABLE ENTRY IF THE NAME-NOT-   *
*       FOUND RETURN OCCURS.                                           *
*       (SEE ALSO 'ACQNAME' FOR OTHER REGISTER USAGES).                *
*                                                                      *
FINDNAME BAL,R12  ACQNAME           LOOK FOR THE NAME...
         B       *R8                  NOT FOUND (NEW NAME)
         B       *R8                  NOT FOUND (IMPOSSIBLE -- WS FULL)
         AI,R8    1                   FOUND.
         CI,R13   NAMECODE          BUT IS IT A NORMAL NAME...
         BE      *R8                  YES.
         BDR,R8  *R8                  NO, STOP OR TRACE NAME (ASSUME
*                                         NAME NOT FOUND).
 PAGE
************************************************************************
*                                                                      *
* ACQIT -- ACQUIRES A NAME OR NUMERIC ITEM, IF ANY, ENDING ON THE NEXT *
*        NON-BLANK AFTER THE ITEM.  ITEM PUT IN NAMEBUF, INIT. BLANKED.*
*        REGS:   R14 -- LINK, EXIT IS VIA 'ACQNB'                      *
*                R1  -- (ENTRY) PTS TO 1ST CHAR OF ITEM, IF ANY (AT    *
*                               THE VERY LEAST, PTS TO A NON-BLANK).   *
*                       (EXIT) PTS TO NON-BLANK DELIMITER FOR ITEM.    *
*                R2  -- (EXIT) CONTAINS THAT DELIMITER.                *
*                R3  -- (EXIT) CONTAINS ITS CODE.                      *
*                R5  -- (EXIT) CONTAINS NO.OF CHARS MAKING UP THE ITEM.*
*                R4 AND R8 ARE VOLATILE.                               *
*                                                                      *
ACQIT    AI,R1    -1                BACK UP MOMENTARILY.
         LI,R5    -NAMEWDSZ         = NO.OF WDS TO HOLD MAX POSS. NAME.
         LW,R8    BLANKS            BLANK THE ENTIRE NAME BUFFER.
ACQITB   STW,R8   NAMEBUF+NAMEWDSZ,R5
         BIR,R5   ACQITB            (R5 ENDS UP AT ZERO).
         LI,R8    NAMLIMIT          = MAX ACCEPTED CHARS PER NAME.
         BAL,R4   ACQNXCC           ACQ NEXT CHAR & ITS CODE.
         CLM,R3   NONAME            TEST FOR NAME-CHAR (INCLUDING DIGIT)
         BCR,9    ACQITZ              NO.
         STB,R2   NAMEBUF,R5          YES, PUT CHAR IN NAME BUFFER.
         AI,R5    1                 COUNT THAT CHAR (= OFFSET TO NEXT
*                                     BYTE IN NAMEBUF AS WELL).
         BDR,R8   ACQNXCC           LOOP TILL MAX CHAR RUNOUT.
         BAL,R4   ACQNXCC           GET NEXT CHAR & CODE.
         CLM,R3   NONAME            CHECK IT...
         BCS,9    ACQNXCC             NAME-CHAR OR DIGIT, SKIP & RETRY.
ACQITZ   LW,R4    R14               SWITCH LINKAGE TO EXIT AFTER
         B        ACQNB               SKIPPING BLANKS.
 PAGE
************************************************************************
*                                                                      *
*  MAYDREF -- EXTRACTS ADDR. FIELD OF R4 AND EITHER EXITS IF ZERO OR   *
*        ELSE ENTERS DREF.                                             *
*  DREF -- DEREFERENCES THE DATA BLOCK POINTED TO BY R4.  IF THE REF-  *
*        COUNT OF THAT BLOCK DECREMENTS TO ZERO, THE BLOCK IS RETURNED *
*        TO THE FREE TABLE.   HOWEVER, FUNCTION DESCRIPTARS AND LISTS  *
*        CANNOT BE FREED UNTIL THE DATA BLOCKS THEY REFERENCE HAVE     *
*        BEEN DEREFERENCED.                                            *
*        REGS:   R7 -- LINK (EXIT VIA 0,R7)                            *
*                R4 -- (ENTRY) PTS AT DATA BLOCK TO BE DEREFERENCED.   *
*                R4 IS VOLATILE, ALL OTHER REGS ARE PRESERVED.         *
*                                                                      *
MAYDREF  AND,R4   X1FFFF            EXTRACT ADDRESS FIELD.
         BEZ      0,R7              EXIT IF NIL.
DREF     MTW,-1   1,R4              DECR DATA BLOCK'S REF-COUNT.
         BGZ      0,R7              EXIT IF STILL BEING REFERENCED.
         LCI      6                 NO LONGER NEEDED -- SAVE REGS.
         STM,R5   DREFSAVE
         LB,R5   *R4                IS THE DATA BLK A LIST OR FUN.DESCR.
         AI,R5    -TYPELIST
         BLZ      DFREE               NO, ORDINARY DATA.
         BEZ      DLIST               YES, A LIST.
         AI,R5    TYPELIST
         CLM,R5   FUNTYPES
         BCS,9    DFREE               NO, GROUP, CODESTRING, OR INTRINS.
         STW,R4   DBROOT              YES, FUN.DESCR, SAVE PTR TO IT.
         LI,R9    2                 REF IT TWICE -- DBROOT & DBSERIES.
         STW,R9   1,R4
         AI,R4    XSIZOFF           PT AT XSIZE WD.
         LI,R9    X'E0000'
         CW,R9    0,R4              DOES IT PT AT ERR-CTRL TBL...
         BAZ      DFNFL               NO.
         STW,R4   DBSERIES            YES, SAVE PTR TO XSIZE WD.
         BAL,R10  DSDREF            DE-REF THE ERR-CTRL DATA BLK.
DFNFL    LW,R4    DBROOT            PT AT FUN.DESCR. AGAIN.
         LI,R6    NFLOFF+1          = OFFSET TO 1ST LINE PTR WD.
         AI,R4    NFLOFF            PT AT NO.OF FUNCTION LINES WD.
         LW,R9    0,R4
         BEZ      DSOUT               NONE, FREE THE FUNC.DESCRIPTOR.
DFLPTR   AI,R4    1                 PT AT FUNC.LINE PTR WD, AND MAKE IT
         MTW,-2   0,R4                AIM AT ITS DATA BLOCK HDR.
         BDR,R9   DFLPTR
         LW,R4    DBROOT            RESTORE PTR TO FUNCTION DESCRIPTOR.
         B        DSER              HANDLE DATA BLOCK PTR SERIES.
DLIST    LI,R6    LISTLOFF+1        OFFSET TO 1ST DB PTR IN THE LIST.
         STW,R4   DBROOT            SAVE PTR TO ROOT OF THE LIST.
         LI,R9    2                 WE WILL REF. ROOT TWICE FOR NOW (IN
         STW,R9   1,R4                'DBROOT' AND 'DBSERIES').         U06-0014
DSER     AW,R4    R6                PT AT 1ST DB PTR IN THE SERIES.
         STW,R4   DBSERIES          SAVE IT AS THE SERIES PTR.
         LW,R9    -1,R4             GET LENGTH OF THE SERIES...
         BEZ      DSOUT               0 -- FREE THE ROOT, IT DOESN'T PT.
         BAL,R10  DSDREF            DE-REF THE 1ST DB THE ROOT PTS AT.
         MTW,1    DBSERIES          INCR SERIES PTR.
         AI,R9    -1                DECR LENGTH OF SERIES REMAINING...
         BGZ      DSDREF              ANOTHER PTR EXISTS, LOOP TO DSDREF
         LB,R9   *DBROOT              END-SERIES -- TEST ROOT'S TYPE...
         AI,R9    -TYPELIST
         BEZ      DENDLIST             A LIST HAS ENDED.
         LI,R9    X'FFFF'              END OF FUN.DESCR LINE PTR SERIES.
         AND,R9  *DBSERIES          DO LABELS FOLLOW...
         BEZ      DSOUT               NO -- FREE THE FUN.DESCRIPTOR.
DFLBL    MTW,2    DBSERIES            YES, PT AT DB PTR FOR A LABEL.
         BAL,R10  DSDREF            DE-REF THE LABEL'S SCALAR DATA BLK.
         AI,R9    -1                WAS THAT THE LAST LABEL...
         BGZ      DFLBL               NO, LOOP BACK.
DSOUT    LI,R4    0
         STW,R4   DBSERIES          CLEAR 'DBSERIES'.
         XW,R4    DBROOT            CLEAR 'DBROOT' AND PT TO ROOT DB.
         B        DFREE             FREE THE ORIG. LIST OR FUN.DESCR.
DSDREF   LI,R4    0                 CLEAR AND EXTRACT THE DB PTR
         XW,R4   *DBSERIES            CONTAINED IN THIS SERIES.
         AND,R4   X1FFFF
         BEZ     *R10               NIL -- RETURN.
         MTW,-1   1,R4              DECR ITS REF-COUNT...
         BGZ     *R10               STILL BEING REF'D -- RETURN.
         LB,R5   *R4                NO LONGER NEEDED, IS THIS ALSO LIST
         AI,R5    -TYPELIST
         BNEZ     DFREE               NO, FREE THAT DATA BLOCK.
         STW,R4  *DBSERIES            YES, RESTORE ITS DB PTR.  (WE HAVE
         MTW,2    1,R4                  A TREE).  WE WILL REFERENCE THE
*                                       NEW LIST TWICE (IN OLD LIST AND
*                                       IN 'DBSERIES').
         AI,R4    LISTLOFF+1        OFFSET TO 1ST DB PTR IN NEW LIST.
         LW,R5    -1,R4             GET LENGTH OF NEW LIST.
         BEZ      DEMPTY              0 -- FREE NEW LIST, RESUME OLD.
         XW,R9    -1,R4             SAVE OLD LENGTH REMAINING, SET NEW.
         XW,R4    DBSERIES          SET NEW SERIES PTR, GET OLD ONE.
         AW,R5    DBSERIES          PT AT NEW LIST'S TRACKING WORD, AND
         STW,R4   0,R5              SAVE OLD SERIES PTR THERE (OLD PTR
*                                     ACTUALLY AIMS AT THE DB PTR TO
*                                     THE NEW LIST -- RESTORED ABOVE).
         B        DSDREF            START WORKING THE NEW SERIES.
DENDLIST LW,R6   *DBSERIES          PICK UP LIST'S TRACKING WORD (THE
         BEZ      DSOUT               DEFAULT VALUE IS ZERO, SO ZERO
*                                     INDICATES THE ROOT LIST; HOWEVER,
*                                     A SUB-LIST'S TRACKING WD PTS BACK
*                                     TO THE PRIOR NODE WHICH CONTAINS
*                                     A DB PTR TO THAT SUB-LIST -- SEE
*                                     CODE IN DSDREF).
         STW,R6   DBSERIES          RESTORE PRIOR SERIES PTR (TO THE
*                                     LIST JUST ENDED).
         LW,R6    0,R6              PT AT LIST JUST ENDED.  WE SAVED
         LW,R9    LISTLOFF,R6         PRIOR LENGTH-REMAINING THERE;
*                                     RESTORE IT.
DEMPTY   LI,R4    0                 CLEAR AND GET THE DB PTR THAT AIMED
         XW,R4   *DBSERIES            AT THE SUB-LIST TO BE FREED.
*      (FALL INTO DFREE)      NOTE--ITS REF-COUNT IS LEFT = 2.
DFREE    AND,R4   X1FFFF            USE ADDRESS FIELD ONLY.
         LI,R5    FREETBL-2         SET PTR TO FREE TABLE AND
         INT,R7  *R4                      SIZE OF BLK TO BE FREED.
         AWM,R7   FREETOTL          INCR TOTAL FREE SPACE NOW.
DSRCH    AI,R5    2                 PT AT LOC WD OF NEXT ENTRY.
         LW,R6    0,R5              GET THAT LOC...
         BEZ      DINSERT             0 MEANS WE'LL INSERT A NEW ENTRY.
         CW,R6    R4                TEST LOC VERSUS NEW LOC TO FREE...
         BG       DFHI                HI MEANS INSERT OR BACK-COALESCE.
         AW,R6    1,R5                LO -- ADD SIZE OF FREE-TBL ENTRY.
         CW,R6    R4                DOES IT FORWARD-COALESCE WITH NEW...
         BNE      DSRCH               NO, TRY NEXT FREE-TABLE ENTRY.
         AWM,R7   1,R5                YES, LENGTHEN THAT ENTRY.
         AW,R6    R7                DOES THAT ENTRY NOW MERGE WITH NEXT
         CW,R6    2,R5                FREE-TABLE ENTRY (2-WAY COALESCE)
         BNE      DEND              NO.
         LW,R6    3,R5              YES, GET NEXT ENTRY'S SIZE.
         AWM,R6   1,R5              ADD IT TO CURRENT ENTRY'S SIZE.
         SLS,R5   -1                PT AT CURRENT DBLWD ENTRY.
DSHRINK  AI,R5    1                 PT AT NEXT DBLWD ENTRY.
         LD,R6    2,R5              MOVE ITS SUCCESSOR UP ONE ENTRY.
         STD,R6   0,R5
         BNEZ     DSHRINK           KEEP MOVING UNTIL REACHING 0,0
*                                     (WHICH ENDS THE FREE-TBL).
         B        DEND
DCOALBAK AWM,R7   1,R5              LENGTHEN FREE-TABLE ENTRY, AND SET
         STW,R4   0,R5                ITS LOC TO BE NEW FREE BLK LOC.
DEND     LW,R4    DBROOT            IS THIS A LIST OR FUN.DESCRIPTOR...
         BNEZ    *R10                 YES, RESUME SERIES WORK.
         LCI      6                   NO, RESTORE REGS.
         LM,R5    DREFSAVE
         B        0,R7              EXIT.
DFHI     SW,R6    R7                BACK UP CURRENT LOC BY NEW'S SIZE.
         CW,R6    R4                DO THE FREE BLOCKS JOIN...
         BE       DCOALBAK            YES, BACK-COALESCE.
DINSERT  AI,R5    2                 PT AT CURRENT ENTRY'S SUCCESSOR.
         XW,R4    -2,R5             INSERT LOC & GET CURRENT LOC.
         XW,R7    -1,R5             INSERT SIZE & GET CURRENT SIZE.
         BNEZ     DINSERT           KEEP GOINT TILL ZERO IS GOTTEN.
         AI,R5    -FREETBL-MAXFRENS-MAXFRENS  DID FREE TABLE FILL UP...
         BLZ      DEND                NO.
         LI,R8    DEND                YES, RETURN TO 'DEND' AFTER
         B        GARBCOLL              GARBAGE COLLECTION.
 PAGE
************************************************************************
*                                                                      *
*  GARBCOLL -- PERFORMS GARBAGE COLLECTION, TERMINATING WITH A SINGLE  *
*        FREE-TABLE ENTRY INDICATING THE TOTAL FREE SPACE BETWEEN THE  *
*        LAST DATA BLOCK AND THE HIGH BOUND FOR DYNAMIC.  THIS MAY     *
*        REQUIRE EXTENSIVE DATA BLOCK POINTER ADJUSTMENTS (PERFORMED   *
*        PRIOR TO MOVING THE DATA BLOCKS).                             *
*        REGS:   R8 -- LINK  (EXIT VIA *LINKGC).                       *
*                R8 IS VOLATILE, ALL OTHER REGS ARE PRESERVED.         *
*                                                                      *
GARBCOLL STW,R8   LINKGC            SAVE LINK.
         LCI      0                 SAVE ALL REGS.
         STM,R0   GARBSAVE
         LW,R8    FREETOTL          GET TOTAL AMT OF FREE SPACE.
         BEZ     *LINKGC            NONE -- EXIT.
         MTW,0    FREETBL+2         IS THERE MORE THAN 1 FREE FRAGMENT.
         BNEZ     GFREE               YES, START WORKING ON FREE TABLE.
         AW,R8    FREETBL             NO, IS FREE BLK ADJACENT TO THE
         CW,R8    DYNBOUND                HIGH DYNAMIC BOUNDARY...
         BGE     *LINKGC                     JA -- EXIT VERY GRATIFIED.
GFREE    LI,R8    0                 CLEAR FREE-ACCUMULATION.
         LD,R2    ZEROZERO          R2 = 0  AND  R3 = 0 (R3 WILL BE USED
*                                     LATER AS A REF-COUNT ACCUMULATOR).
         LI,R1    -1                PRESET R1, IT IS DUALLY USED --
*                                     OFFSET FOR FREE-TBL MGMT. AND
*                                     NO.OF DATA REGIONS THAT NEED TO
*                                       BE MOVED.
GFSETS   AI,R1    1                 OFFSET TO A FREE ENTRY.
         LD,R4    FREETBL,R1        GET LOC & SIZE OF FREE BLOCK.
         STD,R2   FREETBL,R1        CLEAR THAT FREE TABLE ENTRY.
         STW,R2   1,R4              SET FREE-BLK'S REF-COUNT TO ZERO;
         STW,R5   0,R4                MAKE IT A TYPE-ZERO DATA BLK
*                                       WHOSE SIZE IS FOR WHOLE FREE
*                                         ENTRY.
         AW,R4    R5                GET BOUNDARY FOR THIS FREE REGION.
         STW,R4   FBOUNDS,R1
         AW,R8    R5                ACCUMULATE FREE FRAGS BELOW THIS
         STW,R8   FAQMS,R1            BOUNDARY.
         CW,R8    FREETOTL          HAVE WE REACHED TOTAL AMT FREE YET.
         BL       GFSETS              NO, WORK ON NEXT FREE-TABLE ENTRY.
         CW,R4    DYNBOUND            YES --IF LAST FREE REGION WAS AT
         BGE      GNRSET                END OF DYNAMIC, R1= NO.OF DATA
*                                         REGIONS TO BE MOVED.
         AI,R1    1                     OTHERWISE, WE HAVE TO MOVE 1
*                                         MORE (THE REGION AT END).
         STW,R8   FAQMS,R1          ITS FREE-ACCUMULATION IS SAME & WE
*                                     WILL SET THAT BOUND WHEN WE ARE
*                                       DAMNED GOOD AND READY (WHICHEVER
*                                         HAPPENS FIRST).
GNRSET   STW,R1   NR2MOVE           = NO.OF DATA REGIONS TO BE MOVED.
         LW,R4    FBOUNDS           PT AT 1ST DATA BLOCK THAT WILL MOVE.
GREF     AW,R3    1,R4              ACCUMULATE NO.OF REFERENCES TO THE
*                                     DATA BLKS THAT WILL MOVE (WE WILL
*                                       HAVE TO FIND EACH SUCH REF. AND
*                                         DISPLACE IT APPROPRIATELY).
         INT,R13  0,R4              GET THE SIZE OF THAT BLOCK.
         AW,R4    R13               PT AT ITS SUCCESSOR.
         CW,R4    DYNBOUND          HAVE WE HIT END OF DYNAMIC...
         BL       GREF                NO, KEEP GOING.
         STW,R4   FBOUNDS,R1          READY -- THAT BOUNDS LAST REGION.
         LI,R9    X'1FFFF'    NOTE--USED BY 'DISPLACE' FOR SELECTIVE
*                                   LOADS & STORES, LEAVE R9 ALONE.
*                                                   ----- -- ------
*
         LI,R11   STRAYBLK          = TOTAL # OF STRAY DATA BLK PTRS.
         LI,R1    STRAYS            PT AT 1ST STRAY DATA BLK PTR.
         BAL,R7   DISPLACE          DISPLACE IT IF APPR.
         AI,R1    1                 PT AT NEXT ONE.
         BDR,R11  DISPLACE          LOOP TILL DONE.
         LW,R1    TOPOSTAK          PT AT TOP ENTRY IN EXECUTION STACK.
         B        GSTAK             START LOOKING AT THE EXEC. STACK.
GDROPOP  AI,R1    2                 SKIP BOTH WDS OF O-CATEGORY.
         B        GSTAK
GDROP    AI,R1    1                 SKIP & PT AT WD HAVING A DB PTR.
G1       BAL,R7   DISPLACE          DISPLACE IT IF APPR.
GPOP     AI,R1    1                 PT AT NEXT ENTRY IN EXECUTION STACK.
GSTAK    LB,R2   *R1                GET CATEGORY OF EXEC. STACK ENTRY.
         B        GSCAT,R2          VECTOR ACCORDING TO CATEGORY.
GSCAT    B        G1              @   V
         B        GPOP            @   A-PRIME
         B        GDROPOP         @   O
         B        G1              @   X
         B        GPOP            @   B
         B        GPOP            @   P
         B        GPOP            @   S
         B        GDROP           @   Q
         B        G1              @   D
         B        GPOP            @   A
         B        GFCAT           @   F
*        B        GLC             @   LINE-CHAIN
GLC      BAL,R7   DISPLACE        @     DISPLACE ITS LINE-PTR IF APPR.
         AI,R1    3                 PT AT NEXT ENTRY IN EXEC. STACK.
         B        GSTAK
GFCAT    LI,R4    X'7FFF'           EXTR. ITS 'NEXT' FIELD.  ZERO TELLS
         AND,R4   0,R1                US WE'VE HIT THE 'FINAL' ENTRY.
         BEZ      GSYM                  OK, NOW CHECK THE SYMBOL TABLE.
         AI,R1    1                     RATS, PT AT 'FDEFPTR' ENTRY.
         BAL,R7   DISPLACE          DISPLACE IT IF APPR.
         AI,R1    1                 PT AT 'CALLPTR' ENTRY.
         BAL,R7   DISPLACE
         AI,R1    3                 PT AT 2ND WD PAST '# OF SHADOW PAIRS
         LW,R4    -2,R1               FOR THIS FUNCTION STATE', & GET #.
         BEZ      GFBU                  NONE -- BACK UP 1 WD & CK IT.
         BAL,R7   DISPLACE          DISPLACE SHADOWED REFERENT-INDICATOR
*                                     IF APPROPRIATE.
         AI,R1    2                 PT 2 ENTRIES FURTHER INTO STACK.
         BDR,R4   DISPLACE          LOOP IF ITS A SHADOWED REF-INDIC.
GFBU     BDR,R1   GSTAK             PT AT WD AFTER FUNCTION-STATE BLOCK
*                                     AND CHECK ITS CATEGORY.
GSYM     LW,R11   SYMTSIZE          = NO.OF DBLWDS IN SYMBOL TABLE.
         LI,R4    NAMEWDSZ          = MAX # WDS TO HOLD A NAME (A 77-
*                                     CHAR NAME OCCUPIES 20 WORDS).
         LW,R1    SYMT              PT AT 1ST WD OF SYMBOL TABLE (EVEN).
         LW,R12   BITPOS-12         (R-BIT FOR COPY REFERENT PTRS)
         LI,R13   X'40000'          (W-BIT FOR COPY NAME-INDICATORS)
GSYMW    LW,R6    1,R1              LOOK AT THIS ENTRY'S NAME-INDIC WD.
         BEZ      GSYMR               UNUSED NAME ENTRY.                U06-0016
         CB,R4    R6                  USED.  LONG OR SHORT NAME...
         BL       GSYMR                 SHORT.
         CW,R13   0,R1                  LONG, IS W-BIT SET...
         BANZ     GSYMR                   YES, DON'T DISPLACE COPY PTR.
         AI,R1    1                       NO, PT AT NAME-INDIC WD.
         BAL,R7   DISPLACE          DISPLACE LONG-NAME PTR, IF APPR.
         AI,R1    -1                PT AT REF-INDIC WD AGAIN.
GSYMR    CW,R12   0,R1              IS R-BIT SET...
         BANZ     GSYMU               YES, DON'T DISPLACE COPY PTR.
         BAL,R7   DISPLACE            NO, DISPLACE REF-PTR, IF APPR.
GSYMU    AI,R1    2                 PT AT NEXT ENTRY.
         BDR,R11  GSYMW             LOOP TILL PAST SYMBOL TABLE.
         B        GDBT        NOTE--END OF SYM TBL, R1 PTS AT 1ST DATA
*                                     (OR FREE) BLOCK AUTOMATICALLY.
GDBLIST  LW,R11   LISTLOFF,R1       = NO.OF DB PTRS IN LIST,
         AI,R11   1                   + 1 MORE FOR ITS TRACKING WORD.
         STW,R1   GCTEMP            SAVE PTR TO THIS LIST DATA BLK.
         AI,R1    LISTLOFF+1        PT AT 1ST PTR WD IN THE LIST.
         BAL,R7   DISPLACE          DISPLACE IT IF APPR.
         AI,R1    1                 PT AT NEXT WD.
         BDR,R11  DISPLACE          LOOP TILL PAST THE TRACKING WORD.
GDBRR1   LW,R1    GCTEMP            RESTORE DATA BLK PTR.
GNBLK    INT,R13  0,R1              GET SIZE OF THIS BLOCK.
         AW,R1    R13               PT AT NEXT BLOCK.
         CW,R1    DYNBOUND          HAVE WE EXCEEDED THE DATA BLK AREA.
         BL       GDBT                NO.
         BAL,R15  SYSTERR             YES -- SYSTEM ERROR.
GDBT     LB,R2   *R1                GET TYPE OF DATA (OR FREE) BLOCK.
         B        GDBQ,R2           VECTOR ACCORDING TO TYPE.
GDBQ     B        GNBLK       0   @   FREE
         B        GNBLK       1   @   LOGICAL DATA
         B        GNBLK       2   @   TEXT DATA
         B        GNBLK       3   @   INTEGER DATA
         B        GNBLK       4   @   REAL DATA
         B        GNBLK       5   @   INDEX-SEQUENCE DATA
         B        GDBLIST     6   @ * LIST
         B        GNBLK       7   @   CODESTRING
         B        GDBFUND     8   @ * FUNCTION DESCRIPTOR
         B        GDBFUND     9   @ * FUNCTION DESCRIPTOR
         B        GDBFUND     A   @ * FUNCTION DESCRIPTOR
         B        GDBFUND     B   @ * FUNCTION DESCRIPTOR
         B        GDBFUND     C   @ * FUNCTION DESCRIPTOR
         B        GDBFUND     D   @ * FUNCTION DESCRIPTOR
         B        GNBLK       E   @   INTRINSIC FUNCTION
         B        GNBLK       F   @   INTRINSIC FUNCTION
         B        GNBLK      10   @   INTRINSIC FUNCTION
         B        GNBLK      11   @   GROUP
         B        GNBLK      12   @   LONG-NAME
*
*                             NOTE--* INDICATES TYPES CONTAINING DB PTRS
*
GDBFUND  STW,R1   GCTEMP            SAVE PTR TO FUN.DESCR. DATA BLK.
         AI,R1    XSIZOFF           PT AT XSIZE WD.
         LI,R11   X'E0000'
         CW,R11   0,R1              DOES IT PT AT ERR-CTRL TBL...
         BAZ      GDBFUNDN            NO.
         BAL,R7   DISPLACE            YES, DISPLACE IT IF APPR.
GDBFUNDN LW,R11   NFLOFF-XSIZOFF,R1 GET NO.OF LINES IN FUNCTION...
         BEZ      GDBRR1              NONE -- FORGET IT.
         AI,R1    -XSIZOFF+NFLOFF+1 PT AT 1ST FUN.LINE DB PTR WD.
         BAL,R7   DISPLACE          DISPLACE IT IF APPR.
         AI,R1    1                 PT AT NEXT WD.
         BDR,R11  DISPLACE          LOOP TILL PAST LAST FUN.LINE PTR WD.
         LI,R11   X'FFFF'           EXTR. NO.OF LABEL ENTRIES.
         AND,R11  0,R1
         BEZ      GDBRR1            NONE.
         AI,R1    2                 PT AT 1ST LABEL'S DB PTR WD.
         BAL,R7   DISPLACE          DISPLACE IT IF APPR.
         AI,R1    2                 PT AT NEXT ONE, IF ANY.
         BDR,R11  DISPLACE          LOOP TILL PAST LAST LABEL ENTRY.
         B        GDBRR1
*                                                                      *
*  DISPLACE -- THIS IS A WEIRD ROUTINE -- HALF-OPEN, HALF-CLOSED.      *
*        IT TESTS A DATA BLOCK POINTER TO DETERMINE IF IT REFERENCES A *
*        DATA BLOCK THAT WILL CHANGE ITS POSITION IN CORE DUE TO AN    *
*        IMPENDING MOVE.  IF NOT, THE ROUTINE SIMPLY EXITS.  OTHERWISE *
*        THE POINTER IS ADJUSTED, DISPLACING ITS VALUE TO THE POSITION *
*        THAT DATA BLOCK WILL OCCUPY AFTER THE MOVE.  THEN, THE        *
*        ROUTINE DECREMENTS THE 'REFERENCE-ACCUMULATOR' WHICH INDICS.  *
*        THE NO.OF DATA BLK PTRS STILL REQUIRING ADJUSTMENT.  IF MORE  *
*        REMAIN, THE ROUTINE EXITS, BUT AFTER ADJUSTING THE LAST SUCH  *
*        PTR THE ROUTINE GOES ON TO PERFORM THE MOVEMENT OF DATA BLK   *
*        REGIONS; IT BECOMES AN OPEN ROUTINE AT THIS POINT, BY THE WAY.*
*            THE DISPLACEMENT STRATEGY IS TO ADJUST PTRS IN THE        *
*        FOLLOWING ORDER:                                              *
*                               1.  STRAY PTRS (IN PROCESSOR CONTEXT), *
*                               2.  PTRS IN THE EXECUTION STACK,       *
*                               3.  PTRS IN THE SYMBOL TABLE, AND      *
*                               4.  PTRS CONTAINED INSIDE DATA BLOCKS. *
*        IF LUCKY, HOWEVER, THE REFERENCE-ACCUMULATOR WILL CLEAR       *
*        QUICKLY -- SHORT-CUTTING THIS PROCEDURE, POSSIBLY EARLY IN    *
*        STEP 1.                                                       *
*                                                                      *
*        REGS:   R7 -- LINK (EXIT VIA 0,R7 UNTIL R3 CLEARS, THEN THE   *
*                            ROUTINE SWITCHES INTO OPEN PROCEDURE).    *
*                R9 -- (ENTRY) MUST BE X'1FFFF'                        *
*                R1 -- (ENTRY) CONTAINS LOC.OF WD CONTAINING THE DATA  *
*                      BLOCK POINTER (OR NIL) TO BE TESTED.            *
*                R3 -- REFERENCE-ACCUMULATOR.  IT BETTER BE CORRECT.   *
*                R6 AND R8  ARE VOLATILE.      -- ------ -- --------   *
*                                                                      *
DISPLACE LS,R8    0,R1              EXTR. THE ADDR. INDICATED VIA R1.
         BEZ      0,R7              NIL -- EXIT.
         CW,R8    FBOUNDS           IS IT BELOW THE 1ST DATA BLK TO MOVE
         BL       0,R7                YES -- EXIT, THE DB PTR IS OK.
         LW,R6    NR2MOVE             NO, DB PTR REQUIRE ADJUSTMENT;
*                                   GET NO.OF DATA REGIONS TO BE MOVED.
DLOCQ    AI,R6    -1                FIND THE HIGHEST REGION THAT IS
         CW,R8    FBOUNDS,R6          ABOVE THE DB PTR ADDRESS; THAT'S
         BL       DLOCQ               THE REGION CONTAINING THE ADDR.
         SW,R8    FAQMS,R6          ADJ. ADDR BY THE FREE ACCUMULATION
         STS,R8   0,R1                BELOW THAT DATA REGION.
         AI,R3    -1                DECR # OF REFS REMAINING TO MOVED
         BNEZ     0,R7                BLKS, AND EXIT IF ANY REMAIN.
         STW,R3   GCTEMP            CLEAR THE MOVE-REGION COUNT.
GMVSET   MTW,1    GCTEMP            BUMP THE MOVE-REGION COUNT.
         LW,R2    GCTEMP
         LW,R1    FBOUNDS,R2        = BOUND OF NEXT FREE BLOCK.
         SW,R1    FAQMS,R2          -(FREE ACCUMULATION BELOW THAT BND).
         STW,R1   FREETBL           SET DESTINATION-BOUND FOR MOVE.
         AW,R1    FAQMS-1,R2        +(PRIOR FREE ACCUMULATION).
         STW,R1   FREETBL+1         SET SOURCE-BOUND FOR MOVE; IT IS
*                                     HIGHER THAN THE DESTINATION BOUND.
         LW,R1    FBOUNDS-1,R2      GET PRIOR FREE BLOCK BOUND.
         SW,R1    FREETBL+1         = -(NO.OF WDS TO MOVE).
GMVQ     CI,R1    -15               BIG OR SMALL BLK REMAINING...
         BLE      GMV15               BIG -- MOVE 15 WDS OF THE BLK.
         LCW,R2   R1                  SMALL, GET SIZE OF BLK LEFT TO GO.
         SCS,R2   -4                MOVE SIZE TO BITS 0 - 3.
         LC       R2                SET COND. CODE = THAT SIZE.
         B        GMV
GMV15    LCI      15                SET COND. CODE FOR 15-WORD MOVE.
GMV      LM,R2   *FREETBL+1,R1      LOAD APPROACHING THE SOURCE-BOUND.
         STM,R2  *FREETBL,R1        STORE APPROACHING DESTINATION-BOUND.
         AI,R1    15                STEP UP BY 15 WORDS, AND LOOP UNTIL
         BLZ      GMVQ                LAST 1 TO 15 HAVE MOVED.
         MTW,-1   NR2MOVE           DECR # OF REGIONS REMAINING TO MOVE.
         BGZ      GMVSET            MORE, SET UP FOR MOVING NEXT REGION.
*                                   DONE -- FREETBL NOW CONTAINS LOC OF
*                                     1ST FREE WD IN COLLECTED FREE AREA
         LW,R1    FREETOTL          SET SIZE OF THAT FREE TABLE ENTRY TO
         STW,R1   FREETBL+1           THE TOTAL THAT WERE FREE ORIG'NLY.
*                                   (ALL OTHER FREETBL WDS WERE ZEROED).
         LCI      0                 RESTORE REGS, EXCEPT FOR R8.
         LM,R0    GARBSAVE
         B       *LINKGC            EXIT -- GARBAGE HAS BEEN COLLECTED.
 PAGE
************************************************************************
 SPACE 2
Z        SET      %-WMAQ@           SIZE OF WMAQ IN HEX.
 SPACE
Z        SET      Z+Z/10*6+Z/100*96+Z/1000*1536  SIZE IN DECIMAL.
 SPACE 2
         END

