         PAGE
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
         TITLE    'UTILITY ROUTINES'
UTIL     DSECT    1
PLSECT   CSECT    1
         SYSTEM   SIG7
*
         DEF      BCD2BIN,BIN2BCD,CALL1,CLOSEI,CLOSEO,GETPAGE
         DEF      HEX2BCD,MBS,RELPAGES,CLRARG,REVARG
         DEF      PRTNOF
         DEF      UNPRINT
         DEF      SIXPACK
*
         REF      M:EI,M:EO,DCBADD,NPAGE,TOARG,ARGTBL
         REF      BUFSIZE
         REF      PRTBUF,J:JIT,M:UC,M:LO
         REF      CCTAB
*
*
* BCD2BIN         BCD TO BINARY CONVERSION
*
* INPUT
*        R1       BYTE INDEX OF ARGUMENT (USER STORAGE)
*        R2       NO. OF CHARACTERS IN ARGUMENT
* OUTPUT
*        R1       BYTE INDEX OF TERMINATING CHARACTER (USER STORAGE)
*        R2       NO OF UNCONVERTED CHARACTERS REMAINING IN ARGUMENT
*        R3       BINARY INTEGER
*        R4       TYPE OF RETURN (0-NORMAL,1-NON-NUMERIC,2-OVERFLOW)
*
*
         USECT    UTIL
BCD2BIN  PSW,R5   *R7               SAVE REGISTERS
*
         LI,R4    0                 INITIALIZE SUM
         LI,R5    0
         CI,R2    0                 TEST FOR NULL ARGUMENT
         BE       BCD2BIN4
*
BCD2BIN1 LB,R3    *R7,R1            GET NEXT CHARACTER
         CLM,R3   BCD2BIN5          TEST FOR NUMERIC (0-9)
         BCR,9    BCD2BIN2
         LI,R4    1                 FLAG NON-NUMERIC CHARACTER RETURN
         B        BCD2BIN4
*
BCD2BIN2 AND,R3   =X'0000000F'      REMOVE LEADING -F-
         MI,R4    10                SHIFT PREVIOUS SUM
         BDP      %+3
         AW,R5    R3                ADD CURRENT DIGIT
         BNOV     BCD2BIN3
         LI,R4    2                 FLAG OVERFLOW RETURN
         B        BCD2BIN4
*
BCD2BIN3 AI,R1    1                 TEST FOR END OF ARGUMENT
         BDR,R2   BCD2BIN1
         LI,R4    0                 FLAG NORMAL RETURN
*
BCD2BIN4 LW,R3    R5                STORE SUM
         PLW,R5   *R7               RESTORE REGISTERS
         B        *SR4
*
         BOUND    8
BCD2BIN5 DATA     X'F0',X'F9'
*
*
* BIN2BCD         BINARY TO BCD CONVERSION
*
* INPUT
*        R1       POSITIVE BINARY INTEGER
* OUTPUT
*        R1       BINARY INTEGER / 100 000,000
*        R2,R3    BCD INTEGER (RIGHT JUSTIFIED, BLANK FILLED)
*        R4       NUMBER OF NON-BLANK CHARACTERS IN RESULT
*
*
BIN2BCD  PSW,R5   *R7               SAVE REGISTERS
*
         LW,R4    =C'    '          INITIALIZE
         LW,R5    =C'    '
         LW,R3    R1
         LI,R1    7
         B        BIN2BCD2
*
BIN2BCD1 CI,R3    0                 TEST FOR END OF INTEGER
         BE       BIN2BCD3
*
BIN2BCD2 LI,R2    0                 GET NEXT BCD INTEGER
         DW,R2    =10
         AI,R2    X'F0'
*
         STB,R2   R4,R1             STORE INTEGER
         AI,R1    -1
         BGEZ     BIN2BCD1
*
BIN2BCD3 LW,R2    R4                ORDER OUTPUT ARGUMENTS
         LCW,R4   R1
         AI,R4    7
         LW,R1    R3
         LW,R3    R5
*
         PLW,R5   *R7               RESTORE REGISTERS
         B        *SR4
*
*
* CALL1           CAL1,1 UTILITY
*
* INPUT
*        R1       FUNCTION CODE
*        R2-RN    WORDS 1-N OF FPT
*        DCBADD   DCB ADDRESS
*
*
CALL1    SLS,R1   24                CAL1 UTILITY
         AW,R1    DCBADD,R7
         CAL1,1   R1
         B        *SR4
*
*
* CLOSEI          CLOSE M:EI DCB
*
*
CLOSEI   LW,R1    M:EI
         CW,R1    =X'00200000'
         BAZ      *SR4
         CAL1,1   CLSEI
         USECT    PLSECT
CLSEI    GEN,8,7,17      X'15',0,M:EI
         DATA     0
         USECT    UTIL
         B        *SR4
*
*
* CLOSEO          CLOSE M:EO DCB
*
*
CLOSEO   LW,R1    M:EO
         CW,R1    =X'00200000'
         BAZ      *SR4
         LI,R1    X'8800'
         CS,R1    M:EO+1            9T TAPE
         BE       CLSEO1            YES
         LI,R1    X'8900'
         CS,R1    M:EO+1            7T TAPE
         BNE      ABNADD            NO
CLSEO1   LI,R1    3
         CS,R1    M:EO              LABEL
         BNE      ABNADD            YES-JUST SIMPLE CLOSE
         CAL1,1   FPTEOF            NO-FREE FORM TAPE WEOF AND  BACKSPAC
         CAL1,1   FPTPREC           NO-PREC BACK OVER FILE MARK
         USECT    PLSECT
FPTEOF   GEN,8,7,17      X'02',0,M:EO
FPTPREC  GEN,8,7,17      X'1D',0,M:EO
         DATA     X'40000010'
         DATA     ABNADD            ABNORMAL
         USECT    UTIL
ABNADD   EQU      %
         CAL1,1   CLSEO
         USECT    PLSECT
CLSEO    GEN,8,7,17      X'15',0,M:EO
         DATA     X'80000000'
         DATA     2                 SAVE
         USECT    UTIL
         B        *SR4
*
*
* CLRARG          CLEAR ARGUMENT TABLE (ARGTBL)
*
*
CLRARG   LI,R1    36                INITIALIZE
         LW,R2    R7
         STW,R0   ARGTBL,R2         FILL -ARGTBL- WITH ZEROS
         AI,R2    1
         BDR,R1   %-2
         B        *SR4              RETURN
*
*
* GETPAGE         GET PAGE OF MEMORY
*
* INPUT
*        NPAGE    NUMBER PAGES IN POSSESSION (EXCLUDING CONTEX)
* OUTPUT
*        NPAGE    NPAGE+1
*        CC1      0-PAGE OBTAINED, 1-PAGE NOT OBTAINED
*
*
GETPAGE  LW,R1    NPAGE,R7
         AI,R1    1                 NUMBER OF CURRENT PAGES+1
         SLS,R1   4                 X 16
         OR,R1    =X'08000000'      GETPAGE ORDER CODE
         PSW,SR2  *R7               SAVE SR2
         CAL1,8   R1                GO-GET THE PAGES
         PLW,SR2  *R7
         AWM,SR1  NPAGE,R7          COUNT THE NUMBER OF PAGES OBTAINED
         B        *SR4              RETURN
*
*
* HEX2BCD         HEXADECIMAL TO EBCDIC CONVERSION
*
* INPUT
*        R1       HEXADECIMAL WORD (BINARY)
* OUTPUT
*        R2,R3    BCD EQUIVALENT OF HEX WORD
*
*
HEX2BCD  PSW,R5   *R7               SAVE REGISTERS
*
         LI,R5    7                 INITIALIZE
*
HEX2BCD1 LI,R4    X'F'              GET HEX DIGIT (BINARY)
         AND,R4   R1
         AI,R4    X'B7'             CALCULATE EBCDIC EQUIVALENT
         CI,R4    X'C0'
         BG       HEX2BCD2
         AI,R4    X'39'
*
HEX2BCD2 STB,R4   R2,R5             STORE EBCDIC VALUE
         SCS,R1   -4
         AI,R5    -1                TEST FOR END OF WORD
         BGEZ     HEX2BCD1
*
         PLW,R5   *R7               RESTORE REGISTERS
         B        *SR4
*
*
* MBS             MOVE BYTE STRING
*
* INPUT
*        R1       NO. OF BYTES TO BE MOVED
*        R2       SOURCE BYTE INDEX
*        R3       DESTINATION BYTE INDEX
*
*
MBS      LB,R4    *R7,R2            MOVE BYTE STRING
         STB,R4   *R7,R3
         AI,R2    1
         AI,R3    1
         BDR,R1   %-4
         B        *SR4
*
*
* RELPAGES        RELEASE MEMORY PAGES
*
* INPUT
*        NPAGE    NUMBER OF PAGES IN POSSESSION (EXCLUDING CONTEX)
* OUTPUT
*        NPAGE    (ZERO)
*
*
RELPAGES LW,R1    NPAGE,R7          SET UP M:FP FPT
         BEZ      *SR4              NO PAGES TO RELEASE
         OR,R1    =X'09000000'
         CAL1,8   R1                RELEASE RD/WR BUFFER
         STW,R0   NPAGE,R7          CLEAR PAGE COUNT
         LI,R1    2048              RESTORE RD/WR BUFFER SIZE
         STW,R1   BUFSIZE,R7
         B        *SR4              RETURN
*
*
* REVARG          REVERSE ARGUMENT TABLES (TOARG,ARGTBL)
*
* INPUT
*        TOARG    OUTPUT ARGUMENT TABLE
*        ARGTBL   INPUT ARGUMENT TABLE
*
*
REVARG   LI,R1    15                INITIALIZE
         LW,R2    R7
*
         LW,R3    TOARG,R2          REVERSE TABLES
         LW,R4    ARGTBL,R2
         STW,R3   ARGTBL,R2
         STW,R4   TOARG,R2
         AI,R2    1
         BDR,R1   %-5
         B        *SR4              RETURN
*
*
* PRTNOF          PRINT NUMBER OF FILES + MESSAGE
*
* INPUT
*        SR2      NO. OF FILES
*        R5       POINTER TO 4-WORD MESSAGE (LAST CHAR = NL)
*
*
PRTNOF   PSW,SR4  *R7               SAVE LINK REGISTER
         LW,R1    SR2               NO. OF FILES
         BAL,SR4  BIN2BCD           CONVERT TO BCD
         CI,R4    6                 TEST IF MORE THAN 6 CHARS
         BG       %+2
         OR,R2    =X'4B4B0000'
         STW,R2   PRTBUF,R7
         STW,R3   PRTBUF+1,R7       STORE NUMBER IN BUFFER
         LCI      4
         LM,R1    *R5
         STM,R1   PRTBUF+2,R7       PUT MESSAGE IN BUFFER
         LI,R4    PRTBUF
         AW,R4    R7                BUFFER ADR
         LI,R1    M:LO
         LI,R2    23                MESSAGE SIZE
         MTW,0    J:JIT             ON-LINE MODE
         BGEZ     PRTNOF2           NO
         CI,D1    5                 IS THIS A LIST
         BNE      PRTNOF1           NO
         CAL1,1   FPTCMP            COMPARE M:UC AND M:LO
         CI,SR1   1                 SAME DEVICE
         BE       PRTNOF1           YES
         CAL1,1   FPTDEL            PRINT MESSAGE ON LO
PRTNOF1  LI,R1    M:UC
         LI,R2    24                PRINT MESSAGE ON UC
PRTNOF2  CAL1,1   FPTDEL            WRITE MESSAGE
         USECT    PLSECT
FPTDEL   GEN,8,7,17      X'91',0,R1
         DATA     X'34000010'
         PZE      *R4               BUFFER
         PZE      *R2               SIZE
         DATA     0                 BTD
FPTCMP   GEN,8,24 X'2B',M:LO
         DATA     M:UC
         USECT    UTIL
         PLW,SR4  *R7               RESTORE LINK REGISTER
         B        *SR4              RETURN
*
*
* UNPRINT         CHECK FOR UNPRINTABLE CHARS AND ENTER ARGUMENT IN
*                 BUFFER
*
* INPUT
*        R1       POINTER TO ARGUMENT IN TEXTC FORMAT
*        D3       BUFFER POINTER
* OUTPUT
*        R2       NUMBER OF CHARACTERS MOVED TO BUFFER
*        D3       BUFFER POINTER (SAME AS ON ENTRY)
*
*
UNPRINT LCI       6
         PSM,R3   *R7               SAVE REGISTERS
         LB,R3    *R1               GET ARGUMENT LENGTH
UNP2     LB,R4    *R1,R3            MOVE ARGUMENT TO BUFFER
         STB,R4   *D3,R3
         MTH,0    CCTAB,R4
         BLZ      UNP1              UNPRINTABLE CHAR FOUND
         BDR,R3   UNP2
         LB,R2    *R1               NO. CHARS MOVED
UNP0     LCI      6
         PLM,R3   *R7
         B        *SR4              EXIT
UNP1     LB,R3    *R1
         SLS,R3   1                 NO. OF HEX CHARS
         AI,R3    3                 TOTAL CHARS TO PRINT
         LW,R2    R3
         LI,R5    1
         LI,R4    'X'
         STB,R4   *D3,R5            FORMAT X'------'
         LI,R5    2
         LI,R4    ''''
         STB,R4   *D3,R5
         STB,R4   *D3,R3
         LB,R5    *R1               NO. CHARS IN ARGUMENT
UNP3     LI,R6    2
         LB,R4    *R1,R5            GET CHARACTER
UNP4     LI,SR1   X'F'
         AND,SR1  R4                GET HEX DIGIT
         AI,SR1   X'B7'             CALCULATE EBCDIC EQUIVALENT
         CI,SR1   X'C0'
         BG       %+2
         AI,SR1   X'39'
         AI,R3    -1
         STB,SR1  *D3,R3            STORE EBCDIC VALUE
         SLS,R4   -4
         BDR,R6   UNP4
         BDR,R5   UNP3
         B        UNP0
*
*
*SIXPACK HASHES A SIX CHARACTER SERIAL NUMBER INTO ONE WORD.
*INPUT: R1 CONTAINS BYTE ADDRESS OF SERIAL NUMBER
*OUTPUT: R2 CONTAINS HASHED RESULT
*ENTRY: BAL,SR4  SIXPACK
*
SIXPACK  LCI      2
         PSM,R5   *R7
         LI,R5    0
         LI,R4    6
SIXPACK1 EQU      %
         LB,R3    0,R1
         CLM,R3   BCD2BIN5          TEST IF CHAR IS NUMERIC
         BCR,9    SIXPACK5          YES
         LI,R6    3
SIXPACK4 CLM,R3   SIXPACK3-2,R6     TEST IF ALPHABETIC
         BCR,9    SIXPACK5          YES
         BDR,R6   SIXPACK4
         CI,R3    X'40'             TEST IF BLANK
         BNE      SIXPACK2          NO-INVALID
SIXPACK5 EQU      %
         AI,R1    1
         SLS,R3   26
         SLD,R2   2
         SLS,R3   -28
         MI,R5    10
         AW,R5    R3
         BDR,R4   SIXPACK1
         SLS,R2   20
         OR,R2    R5
SIXPACK2 LCI      2
         PLM,R5   *R7
         B        *SR4
         BOUND    8
SIXPACK3 DATA     X'C1',X'C9'
         DATA     X'D1',X'D9'
         DATA     X'E2',X'E9'
         END

