         TITLE    'OBTAIN LOCCT,ROM,TREE - WRITE FILE - PUNCH DECK'
*        CATALOG NO. 705540 - M:LOCCTROM
************************************************************************
         SYSTEM   BPM
         SYSTEM   SIG7FDP
         DEF      LOCCT
         REF      M:C
         REF      M:PO
         REF      M:EO
M:EI     EQU      M:EO
************************************************************************
NOPAGES  EQU      4
CARDSIZ  EQU      30
NL       EQU      X'15'
EOB      EQU      X'26'
         SPACE    5
*********
*  PROC TO OBTAIN FROM CURRENT MONITOR THE INFO NEEDED
*    TO DETERMINE WHAT TYPE OF SYSTEM IT IS,(E.G.,UTS,BPM,..).
*********
MONTYPE  CNAME
         PROC
         LOCAL    MONADDR
MONADDR  EQU      X'2B'             LOC.IN MONITOR CONTAINING INFO
LF       LW,AF(1) MONADDR
         SLS,AF(1)  -28
         AND,AF(1)  L(X'00000007')
         PEND
*********
         PAGE     REGISTER
************************************************************************
R0       EQU      0
R1       EQU      1
R2       EQU      2
R3       EQU      3
R4       EQU      4
R5       EQU      5
R6       EQU      6
R7       EQU      7
SR1      EQU      8
SR2      EQU      9
SR3      EQU      10
SR4      EQU      11
D1       EQU      12
D2       EQU      13
D3       EQU      14
D4       EQU      15
         PAGE
************************************************************************
*  THIS PROCESSOR WILL OBTAIN FROM THE ABS SCRATCH AREA ON RAD THE
*     LOCCT, ROM, AND TREE TABLES FOR A SET OF LOAD AND TREE CONTROL
*     COMMANDS PROCESSED BY THE MONITOR SYSTEM CCI. A HARD COPY WILL
*     BE GENERATED(PUNCHED CARDS) AND A FILE WILL ALSO BE PUT ON RAD.
*     THE FILE GENERATED ON RAD WILL BE DEFINED EITHER BY AN ASSIGN M:EO
*     OR BY THE NAME DEFINED ON THE CONTROL COMMAND : !LOCCT <NAME>
*     THE NAME ON THE CALLING CC TAKES PRECEDENCE OVER ANY ASSIGN. THE
*     HARD COPY IS OUTPUT TO M:PO.
*  IF THE LOCCT PROCESSOR IS BEING RUN UNDER A UTS SYSTEM, THE LOCCT
*     TABLE WILL BE OBTAINED FROM COMMON STORAGE RATHER THEN
*     FROM ABS SCRATCH ON DISC, (WORD-0 = SIZE OF LOCCT).
************************************************************************
LOCCT    EQU      %      <<->>   ENTRY
         M:GL     0                 GET COMMON LIMITS
         LW,D2    *SR1              SIZE OF LOCCT IN WRDS
         AI,D2    X'1FF'            CNVT TO #PGS
         SLS,D2   -9
         AI,D2    1                 FOR CARD WRK AREA
         OR,D2    =X'08000000'
         CAL1,8   D2                GET PAGES
         SLS,SR1  9                 # WORDS
         LW,D2    SR2
         LW,D1    SR2               BASE ADDRESS OF CARD BUFFER
         AI,D2    CARDSIZ           BASE ADDRESS OF LOCCT BUFFER
         LW,R2    SR1
         LI,R1    0
         AI,D1    -1
         STW,R1   *D1,R2            SET WORK AREA TO ZERO
         BDR,R2   %-1            ---
         AI,D1    1
         LW,D3    SR1
         AI,D3    -CARDSIZ
         SLS,D3   2                 # BYTES IN WORK AREA
         M:READ   M:C,(BUF,*D1),(SIZE,80),(ERR,CE),(ABN,CA),(WAIT)
         LB,R2    *D1               OLD OR NEW TYPE CCI/LOCCT INTERFACE
         CI,R2    ':'               NEW TYPE CONTAINS ':' AS CHAR.1
         BNE      %+2               OLD..OLD BPM/BTM TYPE CCI/LOCCT
*                                   NEW..NEW TYPE CCI/LOCCT
         M:WRITE  M:LL,(BUF,*D1),(SIZE,80),(WAIT)
         LI,R2    CCPL-ENDYN
         LW,R7    *R0
         AI,R7    1
         LW,R3    ENDYN,R2          MOVE PLIST (CCPL)
         PSW,R3   *R0                 INFO TO TSTACK
         BIR,R2   %-2            ---
         LI,SR1   1                 START CC
         STW,SR1  CCP,R7              SCAN IN COLUMN-2
         STW,D1   FLGS,R7           SET CC BUFFER ADDRESS IN CCPL
         LI,SR1   0
         BAL,SR4  NAMSCAN  ***      GET CC ID (I.E.,LOCCT)
         BCS,8    E0       EEE  YES.CC BAD,THIS EXIT SHOULD NEVER HAPPEN
         BAL,SR4  NAMSCAN  ***  NO..GET NAME FIELD
         BCS,8    E1       EEE  YES.NAME FIELD BAD
         LW,R1    CSL,R7        NO..# CHAR.IN NAME
         CI,R1    15-5              MAX.NAME SIZE -5 CHAR.FOR 'LOCCT'
         BG       E4       EEE  YES.NAME TOO BIG
         CI,R1    0             NO..SEE IF A NAME
         BE       LOCCT3        NO..  GIVEN ON LOCCT CC
         AI,R1    5             YES.SIZE OF 'LOCCT'
         LW,R2    LOCCTEXT          BUILD TEXTC FORM OF:
         STB,R1   R2                  'LOCCTXXX---XX'
         LW,R3    LOCCTEXT+1          AND PUT IN OPEN
         STW,R2   OPNP+7,R7         CALL ON MONITOR
         STW,R3   OPNP+8,R7           WHERE: 'XX---XX' = NAME
         LI,R4    6                 APPEND
         LI,R5    0                   NAME
         LW,SR4   CSL,R7              TO 'LOCCT'
         LW,SR2   R7                  IN WRITE PLIST
         AI,SR2   CHARS
         LW,R1    R7
         AI,R1    OPNP+7
         LB,R3    *SR2,R5
         STB,R3   *R1,R4
         AI,R4    1
         AI,R5    1
         BDR,SR4  %-4            ---
         AI,R4    3
         SLS,R4   -2
         AI,R1    -1
         LI,R3    2                 SET # WORDS
         STB,R4   *R1,R3              USED
LOCCT0   EQU      %
         M:SETDCB M:PO,(ERR,PE),(ABN,PA)
         M:DEVICE M:PO,(BIN)
ABSRETRY EQU      %
         M:SETDCB M:EI,(ERR,RE),(ABN,RA)
         B        GETCOM            GET LOCCT FROM COMMON
GENFILE  EQU      %
         M:SETDCB M:EO,(ERR,WE),(ABN,WA)
         CAL1,1   OPNP,R7  ***      OPEN OUTPUT FILE
         LI,R1    0
         STW,R1   *D1
         BAL,SR4  FINDEND  ***      FIND END OF LOCCT,ROM,TREE TABLES
* (R7)=TOTAL SIZE OF LOCCT,ROM,TREE TABLES
LOCCT1   EQU      %
         LI,R2    CARDSIZ-1
         LI,R1    0
         STW,R1   *D1,R2            SET CARD BUFFER
         BDR,R2   %-1            ---  TO ZERO (EXCEPT WORD-0,CONTROL-WD)
          LI,R1   X'3E'             BINARY CARD CONTROL CODE
         CI,R7    (120-12-4)/4      CHECK TOTAL WORDS LEFT TO PUNCH
         BG       %+2           NO..END CARD TO BE PUNCHED
          LI,R1   X'1E'         YES.BINARY END CARD CONTROL CODE
         STB,R1   *D1               SET CODE INTO IMAGE
         LI,R2    3
         LI,R3    120-12            MAX.BYTE COUNT
         CI,R7    (120-12-4)/4
         BG       %+4               END CARD TO BE PUNCHED
         LW,R3    R7            YES.REMAINING BYTE COUNT
         SLS,R3   2
         AI,R3    4
         STB,R3   *D1,R2              TO IMAGE
         LI,R4    (120-12-4)/4
         AI,D2    -1                BUILD CARD IMAGE
         CI,R7    (120-12-4)/4        FROM LOCCT,ROM,TREE TABLES
         BG       %+2            ---  IN CARD BUFFER
         LW,R4    R7
         PSW,R4   *R0
         LW,R5    *D2,R4            MOVE
         STW,R5   *D1,R4              IN IMAGE
         BDR,R4   %-2            ---
         AI,D2    1
         PLW,R4   *R0
         AW,D2    R4                TO NEXT IMAGE
         M:TRAP   (IGNORE,FX)
         LI,R4    0
         LI,R5    120/4
         AI,D1    -1
         AW,R4    *D1,R5            FORM A WORD
         BDR,R5   %-1            ---  CHECKSUM OF IMAGE
         LH,R5    R4
         AND,R4   L(X'0000FFFF')
         CI,R5    0
         BEZ      %+3            ---TAKE CARE OF OVERFLOW
         AW,R4    R5
         B        %-5            ---
         AI,D1    1
         SLD,R4   -8                FORM
         SLS,R5   -8                  BYTE CHECKSUM
         CI,R4    0                   OF IMAGE
         BEZ      %+3            ---TAKE CARE OF OVERFLOW
         AH,R4    R5
         B        %-5            ---
         SLD,R4   16
         LI,R3    2                 SET BYTE CHECKSUM
         STB,R4   *D1,R3              INTO IMAGE
         M:WRITE  M:EO,(BUF,*D1),(SIZE,120),(ERR,WE),(ABN,WA),(WAIT)
         M:WRITE  M:PO,(BUF,*D1),(SIZE,120),(ERR,PE),(ABN,PA),(WAIT)
         AI,R7    -(120-12-4)/4
         BGZ      LOCCT2        NO..ALL DONE
         M:CLOSE  M:EO,(SAVE)   YES.
         CAL1,9   1                 EXIT
********
LOCCT2   EQU      %
         LI,R2    1                 INCREMENT
         MTB,1    *D1,R2              TO NEXT SEQUENCE #
         LI,R2    2
         LI,R3    0                 SET CHECKSUM
         STB,R3   *D1,R2              TO ZERO
         B        LOCCT1         ---
LOCCT3   EQU      %
         LW,R3    R7
         AI,R3    OPNP+6
         STB,R1   *R3               DISCONNECT WRITE PLIST PARAMETER LST
         B        LOCCT0         ---
************************************************************************
         PAGE
************************************************************************
*  UTS SYSTEM, GET LOCCT TABLE FROM COMMON STORAGE & MOVE IT TO BUFFER.
*      ENTER :    (D2) = BUFFER ADDRESS
*                 (D3) = BUFFER SIZE (BYTES)
************************************************************************
GETCOM   EQU      %
         LCI      15
         PSM,R1   *R0
         M:GL     0        ***      GET COMMON LIMITS
         SW,SR2   SR1               CNVT #WRDS TO #PAGES
         SLS,SR2  -9
*                                      (SR1) = LOWER LIMIT
*                                      (SR2) = UPPER LIMIT
         LW,R1    *SR1              GET SIZE OF LOCCT TABLE
         AI,D2    -1
         LW,R2    *SR1,R1           MOVE LOCCT TABLE FROM COMMON TO
         STW,R2   *D2,R1              LOCCT PROCESSOR BUFFER
         BDR,R1   %-2
         OR,SR2   =X'0D000000'
         CAL1,8   SR2               FREE COMMON PAGES
         LCI      15
         PLM,R1   *R0
         B        GENFILE  <<->>    EXIT
************************************************************************
         PAGE
************************************************************************
MAXDCBS  EQU      36                REL.SECT.# TO READ LOCCT FROM
* USER    EQU     36                WHEN USER
* USER    EQU     0                 WHEN PROCESSOR
USER     EQU      0
READABS  EQU      %                 READ ABS AREA OF RAD
         GEN,8,24 X'16',M:EI
         GEN,6,26 X'3F',X'10'
         PZE      RE
         PZE      RA
         PZE      *D2
         PZE      *D3
         DATA     MAXDCBS-USER      KEY FOR REL.SECT.IN ABS SCRATCH AREA
         DATA     0
************************************************************************
         PAGE
************************************************************************
CCPL     EQU      %
         GEN,8,24 NODELM,BA(DELM)   # DELIMITERS,BA(DELIMITERS)
         GEN,8,24 CNTCOL,E0         CONT.COL.,CONT.READ ILLEGAL
         PZE      LISTC             LIST OUTPUT S.R.
CCP      EQU      %-CCPL
         DATA     0                 CURRENT CHAR.POSITION
FLGS     EQU      %-CCPL
         GEN,8,24 0,BUFFER          FLAGS,CC BUFFER (SUPPLIED)
CSL      EQU      %-CCPL
         DATA     0                 CHAR.STRING LENGTH
         DATA     0                 CHAR.POSITION OF 1-ST CHAR.OF FIELD
CHARS    EQU      %-CCPL
         RES      9                 CHAR.STRING BUFFER
*********
OPNP     EQU      %-CCPL
         GEN,8,24 X'14',M:EO
         DATA     X'C1400009'
         PZE      OE
         PZE      OA
         DATA     2
         DATA     2
         DATA     X'01000808'
         TEXTC    'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX'
         DATA     X'02010002'
         RES      2
**********
ENDYN    EQU      %
********
READC    EQU      0                 NO CONTINUATION CARD AUTOMATIC READ
LISTC    EQU      0                 NO AUTOMATIC LIST
BUFFER   EQU      0                 BUFFER ADDRESS TO BE SUPPLIED
DELM     EQU      %
         DATA,1   '.',',',' ',' ','
',' ','(',')'
NODELM   EQU      BA(%)-BA(DELM)
CNTCOL   EQU      1
         BOUND    4
LOCCTEXT TEXTC    'LOCCT'
************************************************************************
         PAGE
************************************************************************
*  FIND THE END OF LOCCT,ROM,TREE TABLES FOR PURPOSES OF GENERATING
*    A HARD COPY (PUNCHED CARDS)
*        ENTRY:   (D2) = WORK AREAS BASE ADDRESS
*        EXIT :   (R7) = SIZE (WORDS)OF LOCCT,ETC.IN WORK AREA
************************************************************************
FINDEND  EQU      %                ENTER
         LW,R1    D2                BASE ADDRESS
         LW,R6    D2                SET UP
         SLS,D3   -2                  END OF
         AW,R6    D3                  LOCCT,ETC.
         SLS,D3   2                   TABLES ADDRESS + 1
         LW,R2    1,R1              ROM REL.ADDR.
         BEZ      FINDEND4       ---NO ROM TABLE
         CW,R2    2,R1              TREE REL.ADDR.
         BG       FINDEND1       ---USE ROM REL.ADDR.
         BAL,SR3  FINDROMX ***      CHECK ROM TABLE(S)
         LW,R2    2,R1              USE TREE REL. ADDR.
FINDENDA EQU      %
         AW,R2    D2                RELOCATE ADDR.
         LW,R3    -1,R2             TREE SIZE
         AW,R2    R3                DETERMINE
         AI,R2    -1                  ENDING ADDR.OF LOCCT,ETC.
FINDEND0 EQU      %
         SW,R2    D2                CALCULATE
         STW,R2   R7                  TOTAL LENGTH OF LOCCT,ETC.
         B        *SR4           --EXIT
FINDEND1 EQU      %
         BAL,SR3  FINDROMX ***      CHECK ROM TABLE(S)
         B        FINDEND0       ---
FINDEND4 EQU      %
         LW,R2    2,R1              TREE REL.ADDR.
         BNEZ     FINDENDA       ---
         LI,R2    0                 NO TREE TABLE OR ROM TABLE
         LI,R3    17
         AH,R2    *D2,R3            CALCULATE
         SLS,R2   1                   ADDRESS OF
         LI,R3    18                  END OF LOCCT TABLE + 1
         AH,R2    *D2,R3
         LI,R3    19
         AH,R2    *D2,R3
         SLS,R2   1
         AI,R2    21
         B        FINDEND0       ---
************************************************************************
*   THIS ROUTINE WILL CHECK FOR A VALID ROM TABLE, I.E., ANY ROM NAME
*     WHICH REFERENCES LABELED TAPE IS IN ERROR.
************************************************************************
FINDENDX EQU      %                ENTER     (R2)=REL.ADDR.
         LCI      2
         PSM,R3   *R0
         AW,R2    D2                RELOCATE ADDR.
FINDEND2 EQU      %
         LI,R4    11                GET ROM TABLE ENTRY
         LB,R3    *R2,R4              END CONTROL BYTE
         CI,R3    X'02'
         BANZ     E2       EEE   ---CANNOT ACCEPT WHEN ROM FROM TAPE
         CI,R3    X'40'
         BAZ      FINDEND3       ---YES-AT END
         AI,R2    7                 CONTINUE SEARCH TO NEXT ENTRY
         CW,R2    R6
         BGE      E3       EEE   ---CANNOT FIND END OF TABLES
         B        FINDEND2       ---
FINDEND3 EQU      %
         AI,R2    7                 POINT TO END + 1
         LCI      2
         PLM,R3   *R0
         B        *SR3           --EXIT      (R2)=END ADDR. + 1
************************************************************************
*   THIS ROUTINE WILL SEARCH TREE TABLE FOR ALL ROM TABLES REFERENCED
************************************************************************
FINDROMX EQU      %                ENTER
         PSW,SR3  *R0
         LI,R7    0
         LW,R3    2,R1              TREE ADDRESS
         AW,R3    D2                RELOCATE IT
         LW,R4    -1,R3             GET TREE SIZE
         AI,R4    -1
         AW,R4    R3                END OF TREE +1
FINDROM1 EQU      %
         LW,R2    3,R3              GET ROM POINTER FROM TREE
         SLS,R2   -16
         AW,R2    1,R1
         BAL,SR3  FINDENDX ***      GO CHECK ROM NAMES
         CW,R2    R7                NEW END OF ROM TABLE +1
         BLE      %+2            ---NO
         STW,R2   R7                YES
         AI,R3    11                TO NEXT TREE ENTRY
         CW,R3    R4                AT END OF TREE TABLE
         BL       FINDROM1       ---NO
         LW,R2    R7                POINTS TO END +1
         PLW,SR3  *R0
         B        *SR3           --EXIT
************************************************************************
         PAGE
************************************************************************
*  ERROR SUBROUTINES AND MESSAGES
************************************************************************
E0       EQU      %                ENTER
         M:PRINT  (MESS,ME0)
ECOMMON  EQU      %
         M:PRINT  (MESS,ABORT)
         CAL1,9   1                 EXIT
********
ME0      EQU      %
         TEXTC    '*** UNKNOWN CC OR CONTINUATION ILLEGAL'
********
ABORT    EQU      %
         TEXTC    ' L O C C T - P R O C E S S O R - A B O R T E D'
*****************
E1       EQU      %
         CI,SR1   NL                CHECK IF !LOCCT CC CONTAINS A NAME
         BE       E1A            ---NO...
         CI,SR1   EOB
         BE       E1A            ---NO..
*                                   YES.BUT IT IS INVALID
E1B      EQU      %
         M:PRINT  (MESS,ME1)       ENTER
         B        ECOMMON        ---
E1A      EQU      %
         LW,R1    CSL,R7
         CI,R1    0                 CHECK IF NAME SIZE =0
         BNE      E1B               NO..NAME IS INVALID
         AI,SR4   1
         B        *SR4           --EXIT
********
ME1      EQU      %
         TEXTC    '*** NAME INVALID'
*****************
E2       EQU      %
         M:PRINT  (MESS,ME2)       ENTER
         B        ECOMMON        ---
********
ME2      EQU      %
         TEXTC    '*** CANNOT GENERATE LOCCT WITH ROMS ON LABELED TAPE'
*****************
E3       EQU      %
         M:PRINT  (MESS,ME3)       ENTER
         B        ECOMMON        ---
********
ME3      EQU      %
         TEXTC    '*** ROM TABLE END CANNOT BE FOUND'
*****************
E4       EQU      %                ENTER
         M:PRINT  (MESS,ME4)
         B        ECOMMON        ---
********
ME4      EQU      %
         TEXTC    '*** NAME > 10 CHARACTERS'
*****************
CE       EQU      %                ENTER
CA       EQU      %                ENTER
         BAL,SR4  CONV     ***      CONVERT ERROR/ABNORMAL CODE
         STW,R4   MCEA+7
         M:PRINT  (MESS,MCEA)
         B        ECOMMON        ---
********
MCEA     EQU      %
         TEXTC    '*** I/O ERR/ABN FOR READ C=XXXX'
*****************
WE       EQU      %                ENTER
WA       EQU      %                ENTER
         BAL,SR4  CONV     ***      CONVERT ERROR/ABNORMAL CODE
         STW,R4   MWEA+8
         M:PRINT  (MESS,MWEA)
         B        ECOMMON        ---
********
MWEA     EQU      %
         TEXTC    '*** I/O ERR/ABN FOR WRITE EO = XXXX'
*****************
PE       EQU      %                ENTER
PA       EQU      %                ENTER
         BAL,SR4  CONV     ***      CONVERT ERROR/ABNORMAL CODE
         STW,R4   MPEA+8
         M:PRINT  (MESS,MPEA)
         B        ECOMMON        ---
********
MPEA     EQU      %
         TEXTC    '*** I/O ERR/ABN FOR WRITE PO = XXXX'
*****************
OE       EQU      %                ENTER
OA       EQU      %                ENTER
         BAL,SR4  CONV     ***      CONVERT ERROR/ABNORMAL CODE
         STW,R4   MOEA+6
         M:PRINT  (MESS,MOEA)
         B        ECOMMON        ---
********
MOEA     EQU      %
         TEXTC    '*** OPEN EO ERR/ABN =  XXXX'
*****************
RE       EQU      %                ENTER
RA       EQU      %                ENTER
         BAL,SR4  CONV     ***      CONVERT ERROR/ABNORMAL CODE
         CW,R4    L(C'0057')
         BE       RETRY         YES.IF =, MODIFY BUF. SIZE AND RETRY
         STW,R4   MREA+6        NO..
         M:PRINT  (MESS,MREA)
         B        ECOMMON        ---
RETRY    EQU      %
         AI,D3    -4                DECRIMENT NO.WORDS FOR ABS READ BY 1
         B        ABSRETRY       ---
********
MREA     EQU      %
         TEXTC    '*** ABS READ ERR/ABN = XXXX'
************************************************************************
         PAGE
************************************************************************
*  CONVERT HEXADECIMAL ERROR/ABNORMAL CODE IN REG. SR3 OR SR1
*    TO EBCDIC - EXIT WITH EBCDIC VALUE IN REG. R4
************************************************************************
CONV     EQU      %                ENTER
         LI,R1    4
         LB,SR3   SR3
         BNEZ     %+4           YES.ERROR CODE
         AND,SR1  L(X'000000FF') NO.ABNORMAL CODE
         BEZ      ECOMMON  EEE  NO..ANY CODE
         STW,SR1  SR3           YES.
         STW,SR3  R3
         SLS,R3   16
         LI,R5    0
CONV1    EQU      %
         LI,R2    0
         SLD,R2   4
         LB,SR1   CONVTBL,R2
         STB,SR1  R4,R5
         AI,R5    1
         BDR,R1   CONV1
         B        *SR4   <<->>     EXIT
********
CONVTBL  EQU      %
         DATA,1   '0','1','2','3'
         DATA,1   '4','5','6','7'
         DATA,1   '8','9','A','B'
         DATA,1   'C','D','E','F'
         BOUND    4
************************************************************************
         PAGE
*                 CHANGE STACK POINTER AMOUNT SPEC. BY 1ST ARGUMENT.
*                 SECOND ARGUMENT SPEC. AVAILABLE REGISTER.
BUMP     CNAME
         PROC
LF       LI,AF(2) AF(1)
         MSP,AF(2)  *R0
         PEND
*                 PUSH OR PULL N WORDS SPECIFIED BY 1ST ARGUMENT INTO
*                 REG'S STARTING AT 2ND ARGUMENT.
PUSH     CNAME    X'9',X'B'
PULL     CNAME    X'8',X'A'
         PROC
         DO       NUM(AF)=1
LF       GEN,1,7,4,3,17 1,NAME(1),AF(1),0,R0
         ELSE
         DO       AF(1)=1
LF       GEN,1,7,4,3,17 1,NAME(1),AF(2),0,R0
         ELSE
         DO       AF(1)=16
LF       LCI      0
         ELSE
LF       LCI      AF(1)
         FIN
         GEN,1,7,4,3,17 1,NAME(2),AF(2),0,R0
         FIN
         FIN
         PEND
         PAGE
K0       EQU      X'0'
K1       EQU      X'1'
K2       EQU      X'2'
K6       EQU      X'6'
K8       EQU      X'8'
K24      EQU      X'24'
K40      EQU      X'40'
K50      EQU      X'50'
KFF      EQU      X'FF'
KN1      EQU      -X'1'
KBLANK   EQU      ' '
KCRET    EQU      X'15'
KEOB     EQU      X'26'
KSCOLON  EQU      ';'
Y2       DATA     X'20000000'
Y4       DATA     X'40000000'
Y8       DATA     X'80000000'
YDFFFFFFF DATA    X'DFFFFFFF'
         PAGE
*        NXACTCHR-NEXT ACTIVE CHARACTER ROUTINE GETS THE NEXT ACTIVE
*        CHARACTER FROM THE INPUT RECORD. IF A SEMICOLON IS ENCOUNTERED,
*        THE OUTR ROUTINE IS CALLED IF SPECIFIED. THEN THE NEXT
*        RECORD IS OBTAINED BY CALLING THE SPECIFIED CONTINUATION
*        ROUTINE IF A LEGAL CONTINUATION RECORD IS NOT OBTAINABLE.
*        ENTER WITH ADR OF CHAR PARAM LIST IN R7,
*        JIT POINTER IN R5 AND CUR CHAR OR ZERO IN SR1.
NXACTCHR EQU      %
         CI,SR1   K0                CHECK IF CUR CHAR = 0
         BNE      NXACH3            BRANCH IF NOT
NXACH1   EQU      %
         LW,R2    CCP,R7
         CI,R2    K50               CHECK IF CUR CHAR POSITION = 80
         BE       NXACH5            BRACH IF YES
         LW,R3    CBUF,R7
         LB,SR1   *R3,R2            PICK UP NEXT CHAR
         CI,SR1   KSCOLON           CHECK IF CUR CHAR IS A ;
         BE       NXACH6            BRANCH IF YES
         CI,SR1   KCRET             CHECK IF CARRIAGE RETURN
         BE       NXACH51
         CI,SR1   KEOB
         BE       NXACH51
         CI,SR1   '.'               IF CHAR. = '.',THEN ASSUMED TO BE
         BNE      NXACH1A           NOT..  END OF IMAGE
         LI,R1    K50               YES..FORCE END OF IMAGE
         STW,R1   CCP,R7
         LI,SR1   KCRET             CHANGE '.' TO NL CHAR.
         B        NXACH51
NXACH1A  EQU      %
         LW,R1    FLAGS,R7
         CW,R1    Y4                CHECK IF IN BLANK-OUT MODE
         BAZ      NXACH2            BRACH IF NOT
         LI,R4    K40
         STB,R4   *R3,R2            BLANK OUT CUR CHAR IN RECORD
NXACH2   EQU      %
         MTW,1    CCP,R7            SET CCP = CCP+1
NXACH3   EQU      %
         LW,R1    FLAGS,R7          (R1) = FLAGS
         CI,SR1   K40               CHECK IF CUR CHAR IS A BLANK
         BNE      NXACH4            BRANCH IF NOT
         CW,R1    Y8                CHECK IF BLANK IS ACTIVE
         BAZ      NXACH1            BRANCH IF NOT
NXACH4   EQU      %
         CI,SR1   KCRET             CHECK IF CARRIAGE RETURN
         BE       NXACH51
         CI,SR1   KEOB
         BE       NXACH51
         CI,SR1   '.'               END OF IMAGE IF '.'
         BE       NXACH51           YES.
         LW,R1    CLD,R7            (R1) = # OF DELIM, BYTE ADR OF DLM
         LB,R2    R1                (R2) = # OF DELIM
NXACH8   EQU      %
         CB,SR1   0,R1              CHECK IF CUR CHAR IS A DELIM
         BE       NXACH9            BRANCH IF YES
         AI,R1    K1
         BDR,R2   NXACH8
         LCI      K0                SET  CC1 = 0
         B        *SR4              EXIT
NXACH9   EQU      %
         LCI      K8                SET CC1 TO INDICATE CUR CHAR IS DLM
         B        *SR4
*
NXACH5   EQU      %
         LI,SR1   KEOB              SET CUR CHAR  = EOB
NXACH51  EQU      %
         PUSH     SR4
         LW,R1    OUTR,R7
         BEZ      NXACH52
         BAL,SR4  *R1               LIST LAST RECORD
NXACH52  EQU      %
         PULL     SR4
         B        NXACH9
*
NXACH6   EQU      %
         PUSH     2,SR3
         LW,R1    OUTR,R7
         BEZ      NXACH7
         BAL,SR4  *R1               GO TO OUTR ROUTINE
NXACH7   EQU      %
         LW,R1    CONTR,R7
         LB,R2    R1
         STW,R2   CCP,R7            SET CCP = CP (CONTINUATION POS)
         BAL,SR4  *R1               GET CONTINUATION RECORD
         LB,R2    SR3               (R2) = I/O COMPLETE CODE
         PULL     2,SR3
         CI,R2    K6                CHECK IF CONT. RECORD OBTAINED
         BE       NXACH1            BRANCH IF YES
         LI,SR1   KFF               SET CUR CHAR = FF
         LCI      K8                SET CC1 =1, ERR IN GETTING CONT
         B        *SR4                                            RECORD
         PAGE
*        NAMSCAN-SCANS FOR LEGAL ALPHA NUMERIC NAME.
*        IF LEGAL CC1 =0, IF NOT CC1 = 1
*        ENTER WITH ADR OF CCPL IN R7, CUR CHAR OR ZERO IN SR1
*
*
*
NAMSCAN  EQU      %
         PUSH     13,SR4
         LW,R5    R3
         BAL,SR4  GETCHST           GET CHARACTER STRING
         BCS,8    COMEXIT2          BRANCH IF ILLEGAL STRING
         LI,R4    K0
NAMS1    EQU      %
         LB,R3    *R7,R2            SET (R3) = ITH CHAR
         LB,R3    CHTBL,R3          CHECK IF CHAR LEGAL ALPHANUMERIC
         BEZ      COMEXIT2            BRANCH IF NOT
         OR,R4    R3                   MERGE TYPE
NAMS2    EQU      %
         AI,R2    K1
         BDR,R1   NAMS1             SET N# N-1
         CI,R4    K2                CHECK IF AT LEAST ONE ALPHABETIC
         BL       COMEXIT2
         B        COMEXIT1
         PAGE
*        CHARSCAN-COMPARES CUR CHAR WITH CHAR IN SR2. IF =, CC1 =0.
*        IF NOT CC1 = 1.
*        ENTER WITH PARAMETER LIST ADR IN R7, CUR CHAR OR ZERO IN SR1,
*        AND COMPARISON CHAR IN SR2.
*
CHARSCAN EQU      %
         PUSH     13,SR4
         LW,R5    R3
         BAL,SR4  NXACTCHR          GET NEXT ACTIVE CHAR
CHRS1    EQU      %
         CW,SR1   SR2
         BNE      CHRS3             BRANCH IF NOT
         LI,SR1   K0                SET CUR CHAR = 0
         PULL     13,SR4
         LCI      K0                SET CC1 =  0
         B        *SR4
CHRS3    EQU      %
         PULL     13,SR4
         LCI      K8
         B        *SR4              EXIT
CHRS0    EQU      0
         PAGE
*        HEXSCAN-SCANS FOR HEXIDECIMAL NUMBER.
*        IF LEGAL HEX # CC1 = 0 ,IF NOT CC1 = 1
*        ENTER WITH ADR OF PARAMETER LIST IN R7, CUR CHAR OR 0 IN SR1
*
*
*
HEXSCAN  EQU      %
         PUSH     13,SR4
         LW,R5    R3
         BAL,SR4  GETCHST           GET CHAR STRING
         BCS,8    COMEXIT2          BRANCH IF ILLEGAL CHAR STRING
HEXS1    EQU      %
         LB,R3    *R7,R2            SET (R3) =  ITH CHAR IN STRING
         LB,R3    CHTBL,R3
         BEZ      COMEXIT2          BRANCH IF NOT LEGAL ALPHANUMERIC
         CI,R3    K2                CHECKIF LEGAL HEX CHAR
         BG       COMEXIT2          BRANCH IF NOT
         AI,R2    K1
         BDR,R1   HEXS1             SET N =N-1
COMEXIT1 EQU      %
         LW,R3    YDFFFFFFF         RESET BUFFER
         AND,R3   FLAGS,R7                   EMPTY
         STW,R3   FLAGS,R7                        FLAG
         PULL     13,SR4
         LCI      K0                SET CC1 = 0
         B        *SR4              EXIT
         PAGE
*        QUOTSCAN-COMPARE QUOTE CONSTANT WITH CHAR STRING AND IF = SETS
*        CC1= 0 ,OTHERWISE SETS CC1 = 1.
*        QUOTE CONSTANT AND CHAR STRING CAN BE = ONLY IF THEY ARE
*        OF THE SAME LENGTH
*        ENTER WITH ADR OF PARAM LIST IN R7, CUR CHAR OR 0 IN SR1,
*        AND WORD ADR OF QUOTE CONSTANT IN SR2.
QUOTSCAN EQU      %
         PUSH     13,SR4
         LW,R5    R3
         BAL,SR4  GETCHST           GET CHAR STRING
         BCS,8    COMEXIT2          BRANCH IF ILLEGAL STRING
         LW,R4    SR2               (R4) = QUOTE CONSTANT ADR
         SLS,R4   2                 CONVERT TO BYTE ADR
         CB,R1    QC0,R4            COMPARE LENGTHS
         BNE      COMEXIT2
QUTS1    EQU      %
         AI,R4    K1
         LB,R3    *R7,R2
         CB,R3    QC0,R4            COMPARE CHARS
         BNE      COMEXIT2
         AI,R2    K1
         BDR,R1   QUTS1
         B        COMEXIT1
*
         PAGE
*        DECSCAN- SCANS FOR DECIMAL #.
*        IF LEGAL DEC # CC1 = 0, IF NOT CC1= 1
*        ENTER WITH ADR OF PARAM LIST IN R7 AND CUR CHAR OR 0 IN SR1.
*
*
DECSCAN  EQU      %
         PUSH     13,SR4
         LW,R5    R3
         BAL,SR4  GETCHST           GET CHAR STRING
         BCS,8    COMEXIT2          BRANCH IF ILLEGAL CHAR STRING
DECS1    EQU      %
         LB,R3    *R7,R2            SET (R3) = ITH CHAR IN STRING
         LB,R3    CHTBL,R3          CHECK IF
         CI,R3    K1                         LEGAL DECIMAL  CHAR
         BNE      COMEXIT2          BRANCH IF NOT
         AI,R2    K1
         BDR,R1   DECS1             SET N = N-1
         B        COMEXIT1
*
COMEXIT2 EQU      %
         PULL     13,SR4
         LCI      K8                SET CC1 = 1
         B        *SR4              EXIT
         PAGE
*        CHSTSCAN-CHARACTER STRING SCAN- GETS THE NEXT CHARACTER
*                 STRING UP TO THE NEXT DELIMITER AND MOVES THE
*                 STRING TO THE PARAMETER LIST BUFFER.
*        ENTER WITH JOB POINTER IN R5, PARAM LIST POINTER IN R7,
*        CUR CHAR OR ZERO IN SR1
*        IF  N= 0  OR N > 31 CC1 IS SET  TO 1 . IF CHAR STRING IS NOT
*        OBTAINABLE BECAUSE OF ERROR IN TRYING TO OBTAIN A CONT. RECORD,
*        CC1 AND CC2 ARE BOTH SET TO ONE
*
CHSTSCAN EQU      %
         PUSH     13,SR4
         LW,R5    R3
         LI,R1    KBLANK
         LI,R2    BAPLB             (R2) = BYTE ADR OF PARAM LIST BUF
         LI,R3    K24
CHSTS1   EQU      %
         STB,R1   *R7,R2            FILL PARAM LIST BUFFER
         AI,R2    K1                            WITH BLANKS
         BDR,R3   CHSTS1
*
         LI,R2    K0                SET
         LW,R3    Y8                   BLANK
         STS,R2   FLAGS,R7                   NOT ACTIVE
*
         LI,R1    K0
         LI,R2    PLB
         AW,R2    R7
         LI,R3    K24
CHSTS2   EQU      %
         PUSH     3,R1
         BAL,SR4  NXACTCHR          GET NEXT ACTIVE CHAR
         BCS,8    CHSTS4            CHECK IF CHAR IS A DELIMITER
         LW,R3    Y8                SET
         STS,R3   FLAGS,R7              BLANK ACTIVE
         PULL     3,R1
         CI,R1    K0                CHECK IF FIRST CHAR OF FIELD
         BNE      CHSTS22
         LW,D1    CCP,R7            SET PCCP = CHAR POSITION OF 1ST
         AI,D1    KN1
         STW,D1   PCCP,R7                         CHAR OF FIELD
CHSTS22  EQU      %
         STB,SR1  *R2,R1            STORE CHAR IN BUFFER
         LI,SR1   K0                SET CUR CHAR =0
         AI,R1    K1                SET  N= N+1
         BDR,R3   CHSTS2
CHSTS21  EQU      %
         STW,R1   CSL,R7
         LI,R2    K0
         LW,R3    Y8
         STS,R2   FLAGS,R7
         PULL     13,SR4
         LC       Y8
         B        *SR4
CHSTS3   EQU      %
         STW,R1   CSL,R7            STORE N IN PARAM LIST
         LI,R2    K0                SET
         LW,R3    Y8                   BLANK
         STS,R2   FLAGS,R7                   NOT
         PULL     13,SR4
         LCI      K0
         B        *SR4              EXIT
CHSTS4   EQU      %
         PULL     3,R1
         CI,R1    K0                CHECK IF  N= 0
         BNE      CHSTS3
         B        CHSTS21
*
         PAGE
*        GETCHST-GETS THE NEXT CHAR STRING IF THE PARAM LIST BUFFER
*        IS EMPTY AND MARKS THE PARAM LIST BUFFER AS FULL. SETS
*        (R0) = (R1) = N, (R2) = BYTE ADR OF PARAM LIST BUFFER.
*        ENTER WITH ADR OF PARAM LIST IN R7, CUR CHAR OR 0 IN SR1.
*
*
GETCHST  EQU      %
         LI,R4    K0                FOR CONTINUATION
         LW,R3    Y2                CHECK
         AND,R3   FLAGS,R7               IF PARAM LIST BUF IS FULL
         BNEZ     GCHST1            BRANCH IF FULL
         PUSH     1,SR4
         STW,R5   R3
         BAL,SR4  CHSTSCAN          SCAN FOR CHAR STRING
         STCF     R4
         PULL     1,SR4
GCHST1   EQU      %
         LW,R1    CSL,R7
         LI,R2    BAPLB             (R2) = BYTE ADR OF PARAM LIST BUF
         LW,R3    Y2                SET
         STS,R3   FLAGS,R7               PARAM LIST BUF NOT EMPTY FLAG
         LC       R4
         B        *SR4              EXIT
         PAGE
C300     EQU      X'00030000'
C3000    EQU      X'03000000'
C33      EQU      X'00000303'
C3300    EQU      X'03030000'
C333     EQU      X'00030303'
C3333    EQU      X'03030303'
C222     EQU      X'00020202'
C2223    EQU      X'02020203'
C1100    EQU      X'01010000'
C1111    EQU      X'01010101'
CHTBL    DATA     0,0,0,0               0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
         DATA     0,0,0,0               0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
         DATA     0,0,0,0               0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
         DATA     0,0,0,0               0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
         DATA     0,0,0,3               0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3
         DATA     0,0,3,0               0 0 0 0 0 0 0 0 0 0 0 3 0 0 0 0
         DATA     0,0,0,C300            0 0 0 0 0 0 0 0 0 0 0 0 0 3 0 0
         DATA     0,0,C33,C3000         0 0 0 0 0 0 0 0 0 0 3 3 3 0 0 0
         DATA     C222,C2223,C3300,0    0 2 2 2 2 2 2 3 3 3 0 0 0 0 0 0
         DATA     C333,C3333,C3300,0    0 3 3 3 3 3 3 3 3 3 0 0 0 0 0 0
         DATA     C33,C3333,C3300,0     0 0 3 3 3 3 3 3 3 3 0 0 0 0 0 0
         DATA     0,0,0,0               0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
         DATA     C222,C2223,C3300,0    0 2 2 2 2 2 2 3 3 3 0 0 0 0 0 0
         DATA     C333,C3333,C3300,0    0 3 3 3 3 3 3 3 3 3 0 0 0 0 0 0
         DATA     C33,C3333,C3300,0     0 0 3 3 3 3 3 3 3 3 0 0 0 0 0 0
         DATA     C1111,C1111,C1100,0   1 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0
QC0      EQU      0
CLD      EQU      0
CONTR    EQU      1
OUTR     EQU      2
FLAGS    EQU      4
CBUF     EQU      4
PCCP     EQU      6
PLB      EQU      7
BAPLB    EQU      4*PLB
         END      LOCCT

