*M*      UTILITY    MISC. ROUTINES FOR PCL
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
         PCC      0
         TITLE    'UTILITY ROUTINES'
UTIL     DSECT    1
PLSECT   CSECT    1
         SYSTEM   SIG7
*
         DEF      BCD2BIN           XLATOR
         DEF      BIN2BCD           XLATOR
         DEF      CLOSEI            CLOSE DCB
         DEF      CLOSEO            CLOSE DCB
         DEF      HEX2BIN
         DEF      HEX2BCD           XLATOR
         DEF      MBS               DATA MOVER
         DEF      CLRARG            RESET ARGTBL
         DEF      REVARG            SWITCH ARGTBL/TOARG
         DEF      SIXBACK           XLATOR
         DEF      PRTNOF
         DEF      UNPRINT
         DEF      SIXPACK
*
         REF      M:EI,M:EO         DCBS
         REF      TOARG             OTHER ARGTBL
         REF      ARGTBL            PERIPHERAL DESCRIPTION
         REF      LCCHARS
         REF      LISTPOS           IF DOING NO UPSPACE STUFF, UPSPACE
         REF      LOSPACE           SEE LISTPOS
         REF      PRTBUF,J:JIT,M:UC,M:LO
         REF      BOG
         REF      M:EISN            EI SNS
         REF      INSER             INPUT CURRENT SERIAL#
         REF      M:EOSN            OUT SNS
         REF      OUTSER            CURRENT OUTPUT SERIAL#
         REF      CCTAB
         PAGE
*
*
*P*      NAME:    BCD2BIN
*P*
*P*      ENTRY:   HEX2BIN
*P*
*P*      PURPOSE: TO CONVERT A STRING OF EBCDIC DECIMAL(BCD2BIN) OR
*P*               HEXADECIMAL(HEX2BIN) CHARACTERS
*P*               TO A BINARY VALUE.
*P*
*DO*
*P*
*
* 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)
*
*FIN*
*
         USECT    UTIL
HEX2BIN  LI,R4    100               FLAG FOR SWITCH
         LI,R1    ARGBUF4+1
         LW,R2    NCHAR,R7
         B        %+2
BCD2BIN  LI,R4    -100
         PSW,R5   *R7               SAVE R5
         LI,R5    0
         CI,R2    0                 TEST FOR NULL ARGUMENT
         BE       BCD2BIN4-1
*
BCD2BIN1 LB,R3    *R7,R1            GET NEXT CHARACTER
         CLM,R3   BCD2BIN5          TEST FOR NUMERIC (0-9)
         BCR,9    BCD2BIN2
         BIR,R4   %+3
         CLM,R3   HEX2BIN4          CHECK FO A-F
         BCR,9    HEX2BIN1
         LI,R4    1                 FLAG NON-NUMERIC CHARACTER RETURN
         B        BCD2BIN4
*
HEX2BIN1 AI,R3    -'A'+10+'0'
BCD2BIN2 AI,R3    -'0'
         BIR,R4   BCD2BIN6
         LC       R5                CAN WE ADD ANOTHER CHAR
         BCS,15   HEX2BIN2          NO
         SLS,R5   4
         B        %+3
BCD2BIN6 MI,R5    10
         BDP      %+3
         AW,R5    R3                ADD CURRENT DIGIT
         BNOV     BCD2BIN3
HEX2BIN2 RES
         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
         CI,R4    1                 TEST RESULT FOR RETURN
         B        *SR4
*
         BOUND    8
BCD2BIN5 DATA     X'F0',X'F9'
HEX2BIN4 DATA     'A','F'
         PAGE
*
*
*P*      NAME:    BIN2BCD
*P*
*P*      PURPOSE: TO CONVERT A BINARY VALUE TO AN EIGHT-CHARACTER
*P*               EBCDIC DECIMAL INTEGER WITH LEADING BLANKS.
*P*
*DO*
*P*
*
* 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
*
*FIN*
*
BIN2BCD  PSW,R5   *R7               SAVE REGISTERS
*
         LW,R4    =C'    '          INITIALIZE
         LW,R5    =C'    '
         INT,R2   R1
         STH,R2   R3
         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
*
         PAGE
*
*P*      NAME:    CLOSEI
*P*
*P*      PURPOSE: TO CLOSE THE M:EI DCB IF IT IS OPEN.
*P*
*
*
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
         CI,R1    2                 ONLY REMEMBER FOR NONFILES
         BAZ      *SR4
         LW,R1    M:EISN-1          ANY SNS IN DCB
         CI,R1    X'FF00'
         BAZ      *SR4
         LB,R1    M:EI+11           CURRNT VOLUME#
         BEZ      *SR4
         LW,R1    M:EISN-1,R1
         STW,R1   INSER             SAVE SN FOR AUTO VOL ON OPEN
         B        *SR4
         PAGE
*
*
*P*      NAME:    CLOSEO
*P*
*P*      PURPOSE: TO CLOSE THE M:EO DCB IF IT IS OPEN.
*P*
*
*
CLOSEO   LW,R1    M:EO
         CW,R1    =X'00200000'
         BAZ      *SR4
         CAL1,1   CLSEO
         USECT    PLSECT
CLSEO    GEN,8,7,17      X'15',0,M:EO
         DATA     X'80000000'
         DATA     2                 SAVE
         USECT    UTIL
         CI,R1    2                 ONLY REMEMBER FOR NONFILES
         BAZ      *SR4
         LW,R1    M:EOSN-1          ANY SNS IN DCB
         CI,R1    X'FF00'
         BAZ      *SR4
         LB,R1    M:EO+11           CURRNT VOLUME#
         BEZ      *SR4
         LW,R1    M:EOSN-1,R1
         STW,R1   OUTSER            SAVE SN FOR AUTO VOL ON OPEN
         B        *SR4
         PAGE
*
*
*P*      NAME:    CLRARG
*P*
*P*      PURPOSE: TO ZERO THE ARGUMENT TABLE ARGTBL.
*P*
*
*
CLRARG   LI,R1    16
         LW,R2    R7
         STW,R0   ARGTBL+15,R2      CLEAR FROM TOP DOWN
         AI,R2    -1                SO ENTRY AT +1 CAN CLEAR MORE
         BDR,R1   %-2
         MTW,3    DEVICE,R7         MAKE DC THE DEFAULT
         B        *SR4              RETURN
         PAGE
*
*
*P*      NAME:    HEX2BCD
*P*
*P*      PURPOSE: TO CONVERT A WORD IN HEXADECIMAL TO A TWO-WORD BCD
*P*               EQUIVALENT.
*P*
*DO*
*P*
*
* INPUT
*        R1       HEXADECIMAL WORD (BINARY)
* OUTPUT
*        R2,R3    BCD EQUIVALENT OF HEX WORD
*
*
*FIN*
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
         PAGE
*
*
*P*      NAME:    MBS
*P*
*P*      PURPOSE: TO MOVE A BYTE STRING OF ANY LENGTH.
*P*
*DO*
*P*
*
* INPUT
*        R1       NO. OF BYTES TO BE MOVED
*        R2       SOURCE BYTE INDEX
*        R3       DESTINATION BYTE INDEX
*
*
*FIN*
MBS      LB,R4    *R7,R2            MOVE BYTE STRING
         STB,R4   *R7,R3
         AI,R2    1
         AI,R3    1
         BDR,R1   %-4
         B        *SR4
         PAGE
*
*
*P*      NAME:    REVARG
*P*
*P*      PURPOSE: TO BRING UP THE INPUT OR OUTPUT ARGUMENTS FOR ACCESS
*P*               BY EXCHANGING THE FIRST 15 WORDS OF ARGBUF AND TOARG.
*P*
*DO*
*P*
*
* INPUT
*        TOARG    OUTPUT ARGUMENT TABLE
*        ARGTBL   INPUT ARGUMENT TABLE
*
*
*FIN*
REVARG   LI,R1    16
         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
         PAGE
*
*
*P*      NAME:    PRTNOF
*P*      PURPOSE: GENERATES A MESSAGE WITH UP TO 4
*P*               DECIMAL NUMBERS IN IT. THEY GET PUT
*P*               ON TOP OF % CHARS IN THE CALLER-SUPPLIED MESSAGE,
*P*      INPUT:   SR1-SR2 = INPUT HALFWORD NUMBERS..USED RIGHT TO LEFT
*P*               AND DESTROYED.
*P*               R5 = POINTER TO SKELETON MESSAGE (TEXT FORM)
*P*               SR4 = RETURN
*P*               NO MESSAGE IS OUTPUT IF SR2 IS ZERO
PRTNOF   RES
         CAL1,1   LONOVFC
         LW,R1    SR2               NO. OF FILES
         BEZ      *SR4              NONE, NO MESSAGE
         PSW,SR4  *R7               SAVE RETURN
         PSW,R6   *R7
         ANLZ,R6  PRTBUFI7
         SLS,R6   2                 BA(OUTPUT BUFFER)
         SLS,R5   2                 BA(INPUT MESSAGE)
PRTN1    RES
         AI,R1    0                 ARE WE SKIPPING
         BEZ      %+2               YES
         AI,R6    1
PRTN2    LB,R2    0,R5              MOVE TEXT PART OF MESSAGE
         STB,R2   0,R6
         AI,R5    1
         CI,R2    X'15'             IS THIS END OF MESSAGE
         BLE      PRTN9             YES
         CI,R2    '%'               IS THIS PLACE FOR NEXT NUMBER
         BNE      PRTN1             NO
         LI,R1    X'FFFF'           GET NEXT ONE
         AND,R1   SR2
         SLD,SR1  -16               SHIFT FOR ITERATION
         BEZ      PRTN2             NOTHING HERE
         LB,R2    0,R5              IF DOUBLE % USE FULL WORD
         CI,R2    '%'
         BNE      %+5
         STH,SR2  R1
         SCS,R1   16
         SLD,SR1  -16
         AI,R5    1
         BAL,SR4  BIN2BCD           CONVERT TO BCD
         LCW,R4   R4
         LB,R1    R4,R4             MOVE INTO MESSAGE
         STB,R1   0,R6
         AI,R6    1
         BIR,R4   %-3
         B        PRTN2
*
PRTN9    RES
         ANLZ,R4  PRTBUFI7          BUFFER ADDRESS
         STB,R2   0,R6              REMOVE PUNCTIATION FROM
         AI,R6    -1                END OF MESSAGE
         LC       0,R6
         BCR,8    %-3
         SLS,R4   2                 GET SIZE OF MESSAGE
         SW,R6    R4
         SLS,R4   -2
         LI,R1    0
         XW,R1    LISTPOS
         BEZ      %+2
         CAL1,1   LOSPACE
         LI,R1    M:LO
         LC       BOG
         BCR,12   PRTNOF2           BRANCH IF BATCH
         CI,D1    5                 IS THIS A LIST
         BNE      PRTNOF1           NO
         LI,R3    X'6F00'           IS M:LO A TERMINAL TOO
         CW,R3    M:LO+1
         BAZ      PRTNOF1           YES
         CAL1,1   FPTDEL            PRINT MESSAGE ON LO
PRTNOF1  LI,R1    M:UC
         AI,R6    1
PRTNOF2  CAL1,1   FPTDEL            WRITE MESSAGE
         USECT    PLSECT
FPTDEL   GEN,8,7,17      X'91',0,R1
         DATA     X'34000010'
         PZE      *R4               BUFFER
         PZE      *R6               SIZE
         DATA     1                 BTD
PRTBUFI7 MTW,0    PRTBUF,R7         FOR ANLZ INSTRUCTION
LONOVFC  GEN,8,24 5,M:LO
         DATA     0
         USECT    UTIL
         PLW,R6   *R7
         PLW,SR4  *R7               RESTORE LINK REGISTER
         B        *SR4              RETURN
         PAGE
*
*
*P*      NAME:    UNPRINT
*P*
*P*      PURPOSE: TO TEST AN ARGUMENT FOR UNPRINTABLE CHARACTERS
*P*               AND, IF FOUND, ENTER ARGUMENT IN THE BUFFER AS A
*P*               HEXDECIMAL STRING INSTEAD OF A CHARACTER STRING.
*P*
*DO*
*P*
*
* 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)
*
*
*FIN*
UNPRINT LCI       6
         PSM,R3   *R7               SAVE REGISTERS
         LB,R3    *R1               GET ARGUMENT LENGTH
         BEZ      UNPX              NOTHING TO PRINT
         LW,R5    D3                GEN BYTE ADDRESS
         SCS,R5   2
         AW,R5    R3
UNP2     LB,R4    *R1,R3            MOVE ARGUMENT TO BUFFER
         STB,R4   0,R5
         AI,R5    -1
         LI,R2    1
         SCS,R2   0,R4
         SLS,R4   -5
         CW,R2    CCTAB,R4
         BAZ      UNP1              NOT PRINTABLE
         BDR,R3   UNP2
UNPX     RES
         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
         LW,R5    D3
         SCS,R5   2
         AW,R3    R5
         AI,R5    1
         LI,R4    'X'
         STB,R4   0,R5
         LI,R4    ''''
         AI,R5    1
         STB,R4   0,R5
         STB,R4   0,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  0,R3
         SLS,R4   -4
         BDR,R6   UNP4
         BDR,R5   UNP3
         B        UNP0
         PAGE
*
*
*P*      NAME:    SIXPACK
*P*
*P*      PURPOSE: TO HASH A SIX-CHARACTER ANS TAPE SERIAL NUMBER
*P*               INTO ONE WORD.  THIS ROUTINE IS USED ONLY IN CPV.
*P*
*P*
*DO*
*P*
*INPUT: R1 CONTAINS BYTE ADDRESS OF SERIAL NUMBER
*OUTPUT: R2 CONTAINS HASHED RESULT
*ENTRY: BAL,SR4  SIXPACK
*
*FIN*
SIXPACK  LCI      2
         PSM,R5   *R7
         LI,R5    0
         LI,R4    6
SIXPACK1 EQU      %
         LB,R3    0,R1
         AI,R1    1
         SLS,R3   26
         SLD,R2   2
         SLS,R3   -28
         CI,R3    9                 CHECK FOR SPECIAL CHARACTER
         BLE      %+3
         SLS,R2   -2                CHAKGE TO BLANK
         B        %-5
         MI,R5    10
         AW,R5    R3
         BDR,R4   SIXPACK1
         SLS,R2   20
         OR,R2    R5
SIXPACK2 LCI      2
         PLM,R5   *R7
         B        *SR4
VERSION  EQU      2                 1=BPM, 2=UTS/CPV
         PAGE
*
*P*      NAME: SIXBACK
*P*      PURPOSE: TO CONVERT SIXPACKED SERIAL# BACK TO EBCDIC.
*P*      CALL: R2 IS PACKED SN, R2-R3 IS RETURNED TEXT, BLANK PADDED
*P*               SR4 IS LINK.
*
SIXBACK  RES
         LCI      7
         PSM,R4   *R7
         SLD,R2   -20
         SLS,R3   -12
         LW,R5    R3
         LW,SR1   =C'    '
         LI,R6    6
SIXBACK1 LI,R4    0
         DW,R4    =10
         SLD,R2   -2
         SLS,R3   -26
         OR,R3    R4
         BEZ      %+2
         AI,R3    X'80'
         AI,R3    X'40'
         SLD,SR1  -8
         STB,R3   SR1
         BDR,R6   SIXBACK1
         LD,R2    SR1
         LCI      7
         PLM,R4   *R7
         B        *SR4
         PAGE
DEVTRAN  DSECT    1
         TITLE    'DEVTRAN'
*
*P*      NAME:    DEVTRAN
*P*
*P*
*P*      PURPOSE: TO TRANSLATE A DEVICE SPECIFICATION OF A PCL
*P*               COMMAND.
*DO*
*P*
*
* INPUT
*        CMBX     COMMAND BUFFER INDEX OF NEXT ARGUMENT
*        TERM     TERMINATOR OF CURRENT ARGUMENT
* OUTPUT
*        DEVICE   +0    DEVICE ID CODE
*                 +1    NUMBER OF REEL NO.S
*                 +2    COMMAND BUFFER INDEX OF FIRST REEL NO.
*
*
*FIN*
         REF      ERROR
         REF      CMBX,TERM,DEVICE
         REF      FILE
         REF      ARGBUFF
         REF      MAXSN
         DO       VERSION=2
         REF      OV:NMSZ,OH:NM
         REF      IN%ARG
         REF      OUT%ARG
         FIN
         REF      ARGBUF4
         REF      NCHAR
         REF      MAXCMBX
         REF      LTSTCMBX
         REF      MODE
         REF      DEL%CT
*
         LCI      7                 SAVE REGISTERS
         PSM,R5   *R7
*
         LW,R6    TERM,R7
         LI,R1    17                NEVER SHOULD BE HERE FROM ( OR )
         CI,R6    '('
         BE       %+3
         CI,R6    ')'
         BNE      %+2
         BAL,SR4  ERROR
         LI,R1    3                 SET FOR DC DEFAULT
         CI,R6    '.'               ACCOUNT WITHOUT DC
         BE       DEV2              YES, SET DC, GET ACCOUNT
         CI,R6    '/'               FILENAME WITHOUT DC
         BE       DEV2              YES, SET DC.
         CI,R6    ','               START OF RANGE
         BE       DEV2              YES
         LI,R1    6                 NOW FT DEFAULT
         CW,R1    DEVICE,R7         SN WITHOUT FT ONLY IF
         BNE      %+3               DEFAULT IS FT (NOT DC)
         CI,R6    '#'               IS IT SN WITHOUT FT
         BE       DEV2              YEP.
         CI,R6    '#'               IF # OR - DELIMITER,
         BE       %+2
         CI,R6    '-'               AND DEFAULT DC, IS PART OF FILE NAME
         BNE      %+2
         MTW,-1   CMBX,R7           SO USE IT THERE
*
DEVARG   LW,R6    CMBX,R7
         LI,R1    6
         BAL,SR4  GETARG            GET DEV  ARGUMENT
         LW,R1    =X'02000000'+DEVTBL   EDIT DEVICE CODE
         BAL,SR4  FIXARG
DEV2     RES
         STW,R1   DEVICE,R7         STORE DEVICE ID CODE
         LW,R1    CMBX,R7           SAVE END FOR ERROR MESSAGES
         STW,R1   DEVICE+2,R7       FROM BLDCB
         STW,R0   DEVICE+1,R7       CLEAR SN COUNT
         B        ENDDEV
*
REELNO   RES
         LI,R1    X'40006'          SN ARGS..# - 'XX'
         BAL,SR4  GETARG
         LW,R1    =X'3000104'
         LW,R2    DEVICE,R7
         CI,R2    7                 TEST IF ANS TAPE
         BNE      %+2               NO
         AI,R1    2                 MAX 6 CHAR FOR ANS
         BAL,SR4  TEXTARG
         MTW,1    DEVICE+1,R7       COUNT IT
*
ENDDEV   LW,R1    TERM,R7           TEST FOR TERMINATION ON NO. SIGN
         CI,R1    '#'
         BE       REELNO            ANOTHER SERIAL NUMBER HERE
         DO       VERSION=2
         CI,R1    '-'          DOES DEVICE TYPE FOLLOW?
         BNE      ENDDEV3K     NO
         LI,R1    6                 ARGUMENT DELIMITERS
         BAL,SR4  GETARG
         LI,R2    0
         LW,R3    ARGBUFF,R7   GET ARGUMENT FROM BUFFER.
         SLD,R2   8            ISOLATE LENGTH.
         AI,R2    -2
         BNEZ     ERR34
         SLS,R3   -16
         CI,R3    '7T'
         BNE      %+3          NOT 7T
         LI,R1    3
         STW,R1   MODE+1,R7    ENTER CODE FOR 7T IN ARGTBLE
         LI,R1    OUT%ARG           ASSUME OUT
         CI,D1    1
         BE       %+2          OUTPUT DEVICE.
         LI,R1    IN%ARG            INPUT
         STW,R3   *R1,R7
         B        ENDDEV3G
ERR34    LI,R1    34
         BAL,SR4  ERROR
ENDDEV3G LW,R1    TERM,R7
         FIN
ENDDEV3K EQU      %
         CI,R1    X'4B'             TEST FOR TERMINATION ON PERIOD
         BNE      RETURN
         BAL,SR4  FILTRAN           SCAN ACCT,PSWD
*
RETURN   LCI      7                 RESTORE REGISTERS
         PLM,R5   *R7
         CI,R2    1                 TEST RESULT OF INTARG CALL
         B        *SR4
*
DEVTBL   DATA     11                DEVICE CODE TABLE
         TEXTC    'CR'
         TEXTC    'PR'
         TEXTC    'DC'
         TEXTC    'LT'
         TEXTC    'DP'
         TEXTC    'FT'
         TEXTC    'AT'
         DO1      VERSION=2
         TEXTC    'ME'
         DO1      VERSION=1
         TEXTC    '  '
         TEXTC    'LP'
         TEXTC    'CP'
         TEXTC    'PP'
         TITLE    'FILTRAN'
FILTRAN  DSECT    1
*
*P*      NAME:    FILTRAN
*P*
*P*
*P*      PURPOSE: TO TRANSLATE THE NAME, ACCOUNT, AND PASSWORD FIELDS
*P*               OF A FILE ID IN A COMMAND.
*P*
*DO*
*P*
*
* INPUT
*        CMBX     COMMAND BUFFER INDEX OF NEXT ARGUMENT
*        TERM     TERMINATOR OF CURRENT ARGUMENT
* OUTPUT
*        FILE     +0    FIL ID COUNT (1-N,2-N,A,3-N,A,P)
*                 +1    COMMAND BUFFER INDEX OF FILE NAME
*
*
*FIN*
*
         LCI      7                 SAVE REGISTERS
         PSM,R5   *R7
*
         LI,R5    1                 INITIALIZE
         LW,R6    CMBX,R7
         CI,SR4   RETURN            IF CALLED FROM DEVTRAN
         BNE      NEXTARG
         BDR,R6   NEXT2             AT THE '.', DONT GET FILE NAME
*
NEXTARG  LI,R1    12
         BAL,SR4  GETARG            GET NEXT ARGUMENT
         CI,D2    1
         BG       NEXT2             ERROR REPORTED BY GETARG
         LW,R4    R5                SAVE PARAMETER COUNT
         LW,R3    DEVICE,R7
         CI,R3    7                 TEST IF ANS TAPE
         BNE      %+2               NO
         AI,R4    3                 SELECT 3RD EDIT TABLE
         LW,R1    EDITCNST-1,R4     EDIT FILE ID PARAMETER
         BAL,SR4  TEXTARG
*
NEXT2    EQU      %
         LW,R1    TERM,R7
         CI,R1    '.'               ACCT NO. OR PASS WORD PRESENT
         BNE      STORE
         LW,R3    DEVICE,R7    RESTORE DEVICE CODE.
         CI,R3    7                 IS DEVICE ANS TAPE
         BE       ERR7              YES-ERROR
         CI,R5    3                 CHECK FOR MAXIMUM PARAMETER COUNT
         BE       ERR7
         AI,R5    1                 INCREMENT PARAMETER COUNT
         B        NEXTARG
ERR7     LI,R1    7                 ERROR 07
         BAL,SR4  ERROR
         B        NEXTARG
*
STORE    STW,R5   FILE,R7           STORE PARAMETER COUNT
         STW,R6   FILE+1,R7         STORE CMBX OF FILE NAME
         B        RETURN
*
EDITCNST DATA     X'0400011F'       NAME
         DATA     X'05000008'       ACCOUNT
         DATA     X'06000108'       PASSWORD
         DATA     X'04000111'       ANS NAME
         TITLE    'FIXARG'
*
*P*      NAME:    FIXARG
*P*
*P*      PURPOSE: TO LOOK UP AN ARGUMENT IN A TABLE AND RETURN WITH THE
*P*               INDEX OF THE ARGUMENT AS AN ID.
*P*
*DO*
*P*
*
* INPUT
*
*        R1       0-7    ERROR CODE DESIRED
*                 15-31  TABLE ADDRESS
*        ARGBUFF  ARGUMENT STORAGE BUFFER
*
* OUTPUT
*
*        R1       ARGUMENT ID CODE (INDEX)
*
*
*FIN*
*
FIXARG   DSECT    1
*
         LW,R2    R1                SAVE INPUT
         LW,R1    *R2               GET MAX. TABLE INDEX
*
         LW,R3    ARGBUFF,R7        SEARCH TABLE FOR MATCH
         CW,R3    *R2,R1
         BE       %+2
         BDR,R1   %-2
         CW,R2    =X'02000000'+DEVTBL  IS DEVICE BEING
         BNE      ERR          NO.
         DO       VERSION=2
         MTB,-2   R3                MAKE HW TABLE LOOKUP VALUE
         BGZ      %+3               TWO CHARS MAX
         SLS,R3   8
         SAS,R3   -16
         MTB,0    J:JIT             IF ME IN BATCH
         BNEZ     FIXA1             FIX IT
         CI,R3    'ME'-X'10000'
         BNE      FIXA1
         CI,D1    1                 ME IS CR OR LP IN BATCH
         BNE      %+2
         LI,R1    9                 HAD TO BE EIGHT IF 'ME'
         LH,R3    GUDOPL-4,R1
         LB,R1    GUDDEV-2,R1
FIXA1    RES
         AI,R1    0                 IF WEVE GOT A CODE, JUST STORE TYPE
         BNEZ     ST%DCB
         LW,R1    TERM,R7      TEST IF TERM IS #.
         CI,R1    '#'
         BE       CK%DEVO           OR DASH, WHICH
         CI,R1    '-'               MAKES A FILE NAME
         BE       CK%DEVO      YES--DO NOT CHECK.
*                              SYSTEM TABLE.
         LI,R1    OV:NMSZ      DEVICE IN SYSTEM TABLE.
CMP%NXT  EQU      %
         CH,R3    OH:NM,R1
         BE       %+3
         BDR,R1   CMP%NXT
         B        CK%DEVO
         LI,R1    0
ST%DCB   EQU      %
         CB,R3    TXTT              IF XT, ITS PROBABLY A TAPE
         BNE      %+2               AND ZERO IS THE RESOURCE TYPE
         LI,R3    0
         STH,R0   R3                CLEAR SIGN BITS
         CI,D1    1
         BE       ST%OUT
         STW,R3   IN%ARG,R7    SAVE INPUT ARGUMENT
         LI,R2    1                 TRY INPUT OPEN
         B        %+3
ST%OUT   EQU      %
         LI,R2    2                 TRY OUTPUT OPEN
         STW,R3   OUT%ARG,R7
         AI,R1    0                 IF WEVE GOT A CODE, RETURN
         BNEZ     *SR4
         CAL1,1   OPN%DEV
         CAL1,1   CLS%DEV
DEV%ABN  LI,R3    X'7F00'           GET DEVICE TYPE FROM DCB
         AND,R3   M:DEV+1
         LI,R1    9                 SET LP IF LISTING DEVICE
         CI,R3    X'4000'
         BANZ     *SR4
         SLS,R3   -8
         LH,R3    OH:NM,R3
         LH,R1    DEVTYPES
         CH,R3    DEVTYPES,R1
         BE       %+2
         BDR,R1   %-2
         LB,R1    PCLTYPES,R1
         BNEZ     *SR4
         CI,R3    X'FD5D6'          ANYTHING BUT NO DEVICE IS OK
         BE       CK%DEVO0
         LB,R1    DFDV,R2
         B        *SR4
DFDV     DATA     X'20B00'          PR-INPUT, PP-OUTPUT
CK%DEVO0 LW,R2    =X'02000000'+DEVTBL RESTORE ERR CODE
CK%DEVO  EQU      %
         FIN
         LW,R1    DEVICE,R7         IF DEFAULT DC, DEVICE CODE
         CI,R1    3                 IS OPTIONAL
         BNE      ERR+2
         STW,R6   CMBX,R7           TREAT AS DC/ MISSING
         LI,R2    '/'
         STW,R2   TERM,R7
         LI,R3    0                 NO DDEVTYPE FOR DEFAULT DC
         B        ST%DCB
TXTT     TEXT     'T'
GUDOPL   TEXT     'CRLP'
GUDDEV   DATA     X'1090000'
ERR      EQU      %
*
         AI,R1    0
         BNEZ     *SR4
         LB,R1    R2                SET GIVEN ERROR CODE
         BEZ      *SR4
         PSW,SR4  *R7               SAVE RETURN
         BAL,SR4  ERROR
         LI,R1    0                 CLEAR ID CODE
*
         PLW,SR4  *R7
         B        *SR4
OPN%DEV  GEN,8,24 20,M:DEV
         DATA     X'1040000',X'80000002',X'80000003'
CLS%DEV  GEN,8,24 21,M:DEV
         DATA     0
DEVTYPES GEN,16,16 HA(PCLTYPES)-HA(%),'CR'
         TEXT     'PRDC9TDP7TMELPCPPP'
PCLTYPES DATA     X'10203'          CR,PR,DC
         DATA     X'6050608'        9T,DP,7T,ME
         DATA     X'90A0B00'        LP,CP,PP
M:DEV    DSECT    1
         DATA     X'8003',0,0,DEV%ABN,DEV%ABN
         DO1      17
         DATA     0
         TITLE    'GETARG'
*P*      NAME:    GETARG
*P*
*P*      PURPOSE: TO EXTRACT THE NEXT ARGUMENT FROM THE COMMAND BUFFER
*P*               AND PLACE IT IN TEXTC FORMAT IN THE ARGUMENT BUFFER.
*P*
*DO*
*P*
GETARG   DSECT    1
* GET ARGUMENT
*
* INPUT
*
*        CMBX     COMMAND BUFFER INDEX FOR CURRENT ARGUMENT
*        MAXCMBX  MAXIMUM COMMAND BUFFER INDEX
*
* OUTPUT
*
*        LTSTCMBX BUFFER INDEX OF START OF ARGUMENT
*        CMBX     COMMAND BUFFER INDEX FOR NEXT ARGUMENT
*        ARGBUFF  ARGUMENT BUFFER
*        TERM     TERMINATION CHARACTER
*        NCHAR    NUMBER OF CHARACTERS IN ARGUMENT BUFFER
*
*
*FIN*
         LCI      7                 SAVE REGISTERS
         PSM,R5   *R7
         LW,D4    R1                SET DELIMITER SET
         LW,R6    CMBX,R7           GET COMMAND BUFFER INDEX
         STW,R6   LTSTCMBX
         LI,R5    ARGBUF4+1         INITIALIZE -ARGBUF- INDEX
         LI,SR1   0                 TURN OFF BLANK DELIMITER SWITCH
         LI,SR2   0                 TURN OFF IGNORE CHARACTER SWITCH
         LI,SR3   0                 TURN OFF CHAR STRING IND
         LI,R1    8
         LW,R2    =C'    '
         LI,R3    ARGBUFF-1
         AW,R3    R7
         STW,R2   *R3,R1
         BDR,R1   %-1
*
P5       CW,R6    MAXCMBX,R7        TEST FOR MAXIMUM COMMAND INDEX
         BL       P10
P7       EQU      %
         CI,D4    16                IF SCANNING CHAR STR,, MISSING QUOTE
         BAZ      %+3
         LI,R1    17
         BAL,SR4  ERROR
         LI,R4    X'15'             SET END OF COMMAND
         B        RETURN2
*
P10      LB,R4    *R7,R6            GET NEXT CHARACTER
         AI,R6    1                 INCREMENT COMMAND BUFFER INDEX
         STW,R6   CMBX,R7           UPDATE CMBX FOR ERROR MESSAGE
         CI,D4    X'10'             ARE WE SCANNING A CHARACTER STR
         BANZ     P15               YES, NO BLANK TESTING
         CI,R4    X'15'
         BE       RETURN2           STOP ON CR IN BATCH
         CI,R4    X'0D'
         BE       P7
*
         CI,R4    X'40'             TEST FOR BLANK
         BNE      P11          SIGNIFICANT CHARACTER.
         CI,D1    3            CHECK FOR DELETE COMMAND.
         BNE      P12          NOT DELETE.
         MTW,1    DEL%CT,R7    UPDATE DELETE BLANK COUNT.
         B        P12
P11      EQU      %
         CI,D1    3            CHECK IF DELETE COMMAND.
         BNE      P11A         NO
         LI,R1    0
         XW,R1    DEL%CT,R7    CHECK DELETE COMMAND FOR BLANKS.
         CI,R1    1
         BLE      P11A
         LI,R1    55
         BAL,SR4  ERROR
         B        RETURN
P11A     EQU      %
         CI,R4    X'05'             TEST FOR TAB CHARACTER
         BNE      P15
         LI,R4    X'40'             CHANGE TAB TO BLANK
P12      EQU      %
         CI,SR1   0                 TEST BLANK DELIMITER SWITCH
         BE       P5
         LI,SR1   0                 TURN OFF BLANK DELIMITER SWITCH
         LI,SR2   1                 TURN ON IGNORE CHARACTER SWITCH
         B        P5
*
P15      LW,R2    R4                GET DELIMITER FLAG FOR CHARACTER
         LI,R3    0
         SLD,R2   -5
         SLS,R3   -27
         AW,R2    D4                SELECT DELIMITER TABLE
         LW,R1    DELIMIT,R2
         SLS,R1   0,R3
         CI,R1    0                 TEST FOR DELIMITER
         BL       RETURN1
P17      EQU      %
         CI,SR2   0                 TEST IGNORE CHARACTER SWITCH
         BE       P20
P18      LI,R4    X'40'             SET DELIMITER TO BLANK
         AI,R6    -1                DECREMENT COMMAND BUFFER INDEX
         B        RETURN2
*
P19      AI,R6    1
P20      AI,D4    0                 IF D4 NEGATIVE, MUST HAVE DELIMITER
         BGEZ     P22
         LI,R1    17                NO CANN FIGURE OUT THIS ONE
         BAL,SR4  ERROR
         LI,D4    6                 NOT TWICE
P22      CI,R5    ARGBUF4+32        TEST FOR MAX ARG SIZE
         BL       P25
         BG       P26               ERROR ALREADY REPORTED
         LI,R1    1                 SET ERROR FLAG (ERROR 01)
         BAL,SR4  ERROR             ERROR 01
         B        P26
*
P25      LB,SR1   *R7,R5            GET PREV BYTE IN CASE HEX CONVERT
         CI,D4    6
         BG       %+4
         CLM,R4   LCCHARS           IF LOWER CASE, TRANSLATE
         BCS,9    %+2
         AI,R4    'A'-'a'
         STB,R4   *R7,R5            PACK CHARACTER IN ARGUMENT BUFFER
         CI,D4    22                ARE WE CONVERTING HEX
         BNE      P26               NO
         CLM,R4   BCD2BIN5          CHECK CHARACTER LEGALITY
         BCR,9    %+4
         CLM,R4   HEX2BIN4
         BCS,9    P30               BADDIE
         AI,R4    10-'A'+'0'
         AI,R4    -'0'              MAKE BIN
         SLS,SR1  4                 ADD TO PREVIOUS
         AW,R4    SR1
         STB,R4   *R7,R5            STUFF IT IN
         CI,SR1   X'F00'            WAS IT A FIRST HALF
         BANZ     %+2               YES, SKIP INCREMENT
P26      AI,R5    1                 INCREMENT CHARACTER COUNT
         LI,SR1   1
         B        P5
*
P30      LI,R1    52
         BAL,SR4  ERROR
         LI,R4    '0'               CHANGE TO '0'
         B        P25
*
RETURN1  RES
         CI,R4    X'7D'             IS DELIM A QUOTE
         BNE      RETURN2           NO
         CI,D4    6                 ARE WE SCANNING A FID
         BL       RETURN2           NO
         BE       P18               NO, STOP ONE BEFORE APOST
         CI,R5    ARGBUF4+1         HAVE WE STORED A CHARACTER
         BNE      RETURN3           YES
         CI,D4    16                ARE WE PAST INITIAL QUOTE
         BANZ     RETURN3           YES
         LI,D4    17                SET DELIM MODE TO SCAN FOR QUOTES
         B        P5
RETURN3  CI,D4    17                ARE WE SCANNING '--'
         BE       RETURN4           YES, CHECK '' IN STRING
         BG       RETURN5           END OF HEX STRING
         CI,R5    ARGBUF4+2         IS 2ND CHAR A QUOTE
         BNE      P18               NO, STOP PRE'
         LI,R1    ARGBUF4+1
         LB,R1    *R7,R1            GET FIRST CHAR
         CI,R1    'X'               IS IT AN X
         BNE      P18               NO, STOP PRE'
         LI,D4    22                SET DELIM MODE FOR HEX SCAN
         LI,R5    ARGBUF4+1         START OVER AGAIN
         MTB,-7   *R7,R5            MAKE RIGHT HALF BYTE 0
         B        P5
RETURN5  LB,R4    *R7,R5            DO WE HAVE HALF A CHARACTER
         CI,R4    ' '
         BE       RETURN6           NO
         SLS,R4   4
         STB,R4   *R7,R5
         AI,R5    1                 YES, ADD OTHER HALF=0
         B        RETURN6
RETURN4  CW,R6    MAXCMBX,R7        TEST FOR END OF COMMAND
         BL       %+3               NO
         LI,R4    X'15'             SET TERMINATOR
         B        RETURN2
         LB,R4    *R7,R6
         CI,R4    X'7D'             IS DOUBLE QUOTE IN CHAR STRING
         BE       P19               YES - STORE AND CONTINUE
RETURN6  RES
         LI,D4    X'80006'          SET DELIMITER NEXT FLAG
         B        P5                GO SCAN FOR DELIMITER
*
RETURN2  STW,R4   TERM,R7           SAVE DELIMITER
         STW,R6   CMBX,R7           SAVE COMMAND BUFFER INDEX
         AI,R5    -ARGBUF4-1        SAVE CHARACTER COUNT
         STW,R5   NCHAR,R7
         LI,R1    ARGBUF4
         STB,R5   *R7,R1
         LCI      7                 RESTORE REGISTERS
         PLM,R5   *R7
         B        *SR4
*                   BLANK .(  );    / ,   #
DELIMIT  DATA     0,0,X'80140006',X'40100004',0,0,0,0
         DATA     X'80140006',X'C0100014',0,0,0,0
         DATA         X'80140006',X'40100004',0,0,0,0
         DATA     X'00000004',0,0,0,0
         DATA     X'00000004',0,0,0,0
         TITLE    'INTARG'
*P*      NAME:    INTARG
*P*
*P*      PURPOSE: TO CONVERT AN INTEGER ARGUMENT TO BINARY.  THE
*P*               CONVERTED INTEGER IS COMPARED WITH VALUE LIMITS
*P*               SUPPLIED BY THE CALLER.
*P*
*DO*
*P*
*
*
* INPUT
*
*        R1       MINIMUM INTEGER VALUE
*        R2       MAXIMUM INTEGER VALUE
*        ARGBUFF  ARGUMENT BUFFER
*        NCHAR    LENGTH OF CURRENT ARGUMENT
*
* OUTPUT
*
*        R1       INTEGER IN BINARY
*        R2       TYPE OF RETURN (0-NORMAL,1-INVALID,2-RANGE)
*
*FIN*
INTARG   DSECT    1
*
         LCI      7                 SAVE REGISTERS
         PSM,R5   *R7
*
         STW,R1   R6                SAVE RANGE VALUES
         STW,R2   R5
*
         LI,R1    ARGBUF4+1         CONVERT INTEGER TO BINARY
         LW,R2    NCHAR,R7
         BAL,SR4  BCD2BIN
         LW,R1    R3                PUT RESULT IN R1
         LI,R2    0                 FLAG IF O.K.
*
         CI,R4    0                 TEST FOR VALID CONVERSION
         BE       RANGE
         LI,R2    1                 FLAG INVALID INTEGER
         B        RETURN
*
RANGE    LW,R4    R6                EDIT RANGE OF INTEGER
         CLR,R4   R3
         BCR,6    RETURN
         LI,R2    2                 FLAG RANGE ERROR
         B        RETURN
*
         TITLE    'TEXTARG'
*
*P*      NAME:    TEXTARG
*P*
*P*      PURPOSE: TO CHECK THE LENGTH OF THE ARGUMENT IN ARGBUFF TO
*P*               DETERMINE IF IT FALLS WITHIN THE LIMITS SUPPLIED BY
*P*               THE CALLER.
*P*
*do*
*P*
*
* INPUT
*
*        R1       0-7    ERROR CODE DESIRED
*                 16-23  MIN. NO. OF CHARACTERS
*                 24-31  MAX. NO. OF CHARACTERS
*        ARGBUFF  ARGUMENT STORAGE BUFFER
*
*
*FIN*
TEXTARG  DSECT    1
*
         PSW,SR4  *R7               SAVE RETURN  RESGISTER
*
         LI,R3    2                 GET MIN. VALUE
         LB,R2    R1,R3
         AI,R3    1                 GET MAX. VALUE
         LB,R3    R1,R3
*
         CLR,R2   NCHAR,R7          TEST NO. OF CHARACTERS
         BCR,6    %+3
*
         LB,R1    R1                SET GIVEN ERROR CODE
         BAL,SR4  ERROR
*
         PLW,SR4  *R7               RESTORE REGISTERS
         B        *SR4
         END

