*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
         PAGE
         TITLE    'UTILITY ROUTINES'
UTIL     DSECT    1
PLSECT   CSECT    1
         SYSTEM   SIG7
*
         DEF      BCD2BIN,BIN2BCD,CALL1,CLOSEI,CLOSEO,GETPAGE
         DEF      HEX2BIN
         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      BOG
         REF      M:EISN            EI SNS
         REF      INSER             INPUT CURRENT SERIAL#
         REF      M:EOSN            OUT SNS
         REF      OUTSER            CURRENT OUTPUT SERIAL#
         REF      CCTAB
*
*
*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
*
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
         B        *SR4
*
         BOUND    8
BCD2BIN5 DATA     X'F0',X'F9'
HEX2BIN4 DATA     'A','F'
*
*
*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'    '
         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
*
*
*P*      NAME:    CALL1
*P*
*P*      PURPOSE: TO ISSUE A CAL1,1 BASED ON INFORMATION SUPPLIED
*P*               IN REGISTERS.
*P*
*DO*
*P*
*
* INPUT
*        R1       FUNCTION CODE
*        R2-RN    WORDS 1-N OF FPT
*        DCBADD   DCB ADDRESS
*
*
*FIN*
CALL1    SLS,R1   24                CAL1 UTILITY
         AW,R1    DCBADD,R7
         CAL1,1   R1
         B        *SR4
*
*
*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
         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
*
*
*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
         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
*
*
*P*      NAME:    CLRARG
*P*
*P*      PURPOSE: TO ZERO THE ARGUMENT TABLE ARGTBL.
*P*
*
*
CLRARG   LI,R1    16
         LW,R2    R7
         STW,R0   ARGTBL,R2         FILL -ARGTBL- WITH ZEROS
         AI,R2    1
         BDR,R1   %-2
         MTW,3    DEVICE,R7         MAKE DC THE DEFAULT
         B        *SR4              RETURN
*
*
*P*      NAME:    GETPAGE
*P*
*P*      PURPOSE: TO GET ADDITIONAL PAGES OF MEMORY FOR THE RDWRT COPY
*P*               BUFFER.  THIS ROUTINE IS USED ONLY IN CPV.
*P*
*
* 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
*
*
*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
*
*
*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
*
*
*P*      NAME:    RELPAGES
*P*
*P*      PURPOSE: TO RELEASE ADDITIONAL I/O BUFFER PAGES WHICH WERE
*P*               OBTAINES BY GETPAGE.  THIS ROUTINE IS USED ONLY IN CPVV.
*P*
*DO*
*P*
*
* INPUT
*        NPAGE    NUMBER OF PAGES IN POSSESSION (EXCLUDING CONTEX)
* OUTPUT
*        NPAGE    (ZERO)
*
*
*FIN*
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
*
*
*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
*
*
*P*      NAME:    PRTNOF
*P*
*P*      PURPOSE: TO CONVERT AND PRINT A FILE COUNT SUPPLIED IN SR2
*P*               FOLLOWED BY A FOUR-WORD TEXT STRING SUPPLIED BY THE
*P*               CALLER.
*P*
*DO*
*P*
*
* INPUT
*        SR2      NO. OF FILES
*        R5       POINTER TO 4-WORD MESSAGE (LAST CHAR = NL)
*
*
*FIN*
PRTNOF   RES
         LW,R1    SR2               NO. OF FILES
         BEZ      *SR4              NONE, NO MESSAGE
         PSW,SR4  *R7               SAVE RETURN
         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
         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
         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
         USECT    UTIL
         PLW,SR4  *R7               RESTORE LINK REGISTER
         B        *SR4              RETURN
*
*
*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
         MTH,0    CCTAB,R4
         BLZ      UNP1              UNPRINTABLE CHAR FOUND
         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
*
*
*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
         LB,R6    R3                CHECK FOR SLASH
         CI,R6    X'84'             AND CHANGE TO DASH
         BNE      %+2
         MTB,-4   R3
         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
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      #DELIM
         REF      ARGBUFF
         REF      COPYSTDF
         REF      MAXSN
         DO       VERSION=2
         REF      OV:NMSZ,OH:NM
         REF      IN%ARG
         REF      OUT%ARG
         FIN
         REF      ARGBUF4
         REF      NCHAR
         REF      DEV%SAV
         REF      SAVCMBX
         REF      MAXCMBX
         REF      LTSTCMBX
         REF      MODE
         REF      DEL%CT
*
         LCI      7                 SAVE REGISTERS
         PSM,R5   *R7
*
         LI,R5    0                 INITIALIZE
         LW,R2    TERM,R7
         CI,R2    X'4B'             ACCOUNT NO. WITHOUT DC
         BNE      ENDDEV1           NO, MEBBE FT#X SANS FT
         MTW,0    COPYSTDF,R7
         BGEZ     DEV2              GO SET CODE FOR DC
*
DEVARG   LW,R6    CMBX,R7
         LI,R1    6
         AI,R5    0                 IF GETTING SERIAL#
         BEZ      %+2               USE SERIAL# DELIMITERS
         LI,R1    X'40006'
         BAL,SR4  GETARG            GET DEV  ARGUMENT
*
         CI,R5    0                 TEST FOR DEVICE CODE
         BNE      REELNO
         LW,R1    =X'02000000'+DEVTBL   EDIT DEVICE CODE
         BAL,SR4  FIXARG
         STW,R1   DEVICE,R7         STORE DEVICE ID CODE
         CW,R6    CMBX,R7           DID WE GET A REAL DEVICE CODE
         BGE      ENDDEV            NO, LEAVE OLD SNS,ETC
         LW,R1    CMBX,R7           SAVE END FOR ERROR MESSAGES
         STW,R1   DEVICE+2,R7       FROM BLDCB
         STW,R5   DEVICE+1,R7       YES, RESET SN COUNT
         B        ENDDEV
DEV2     EQU      %
         LI,R1    3
         STW,R1   DEVICE,R7
         B        ENDDEV4
*
REELNO   LW,R1    =X'03000104'      EDIT REEL NO.
         LW,R2    DEVICE,R7
         CI,R2    7                 TEST IF ANS TAPE
         BNE      %+2               NO
         LW,R1    =X'03000606'      MUST BE 6 CHAR FOR ANS
         BAL,SR4  TEXTARG
         CI,R5    1                 TEST FOR FIRST REEL NO.
         BNE      %+2
         STW,R6   DEVICE+2,R7       STORE CMBX OF FIRST REEL NO
         STW,R5   DEVICE+1,R7       STORE REEL NO. COUNT
*
ENDDEV   LW,R1    TERM,R7           TEST FOR TERMINATION ON NO. SIGN
         CI,R1    X'7B'
         BNE      ENDDEV3
         CI,R5    MAXSN             CHECK FOR MAX SERIAL NUMBERS
         BL       ENDDEV2
         LI,R1    35                TOO MANY REEL NUMBERS
         BAL,SR4  ERROR
         B        DEVARG
ENDDEV1  CI,R2    '#'
         BNE      DEVARG            NOT FT#X SANS FT
         LI,R2    6                 SET FT DEVICE CODE
         STW,R2   DEVICE,R7
ENDDEV2  AI,R5    1                 INCREMENT REEL NO. COUNTER
         B        DEVARG
ENDDEV3  RES
         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
ENDDEV4  EQU      %
         MTW,-1   CMBX,R7           REUSE DOT (NULL FILE NAME
         BAL,SR4  FILTRAN           SCAN ACCT,PSWD
*
RETURN   LCI      7                 RESTORE REGISTERS
         PLM,R5   *R7
         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
*
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
         MTW,0    NCHAR,R7
         BEZ      NEXT2             ALLOW NULL NAME
         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
         LB,R2    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,R2    1
         LH,R3    GUDOPL,R2
         LB,R1    GUDDEV,R2
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    X'7B'
         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
         B        *SR4
CK%DEVO  EQU      %
         FIN
         LW,R1    SAVCMBX,R7        IS DEVICE CODE OPTIONAL
         BEZ      ERR               NO
         STW,R1   CMBX,R7           TREAT STRING AS FID - RESET CMBX
         LI,R1    '/'               SIMULATE 'DC/'
         STW,R1   TERM,R7           SET DELIMITER
         LI,R1    3                 SET CODE FOR DC
         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
         STW,R1   #DELIM,R7         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    16                CLEAR ARGUMENT BUFFER
         LW,R2    =C'    '
         LI,R3    ARGBUFF-1
         AW,R3    R7
         STW,R2   *R3,R1
         BDR,R1   %-1
         LW,D4    #DELIM,R7         GET DELIM FLAG
         LI,D3    ARGBUF4+32
*
P5       CW,R6    MAXCMBX,R7        TEST FOR MAXIMUM COMMAND INDEX
         BL       P10
P7       EQU      %
         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    17                ARE WE SCANNING A CHAR STRING
         BGE      P15               YES - SKIP 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      CW,R5    D3                TEST FOR MAXIMUM ARGUMENT LENGTH
         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
         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    17                ARE WE PAST INITIAL QUOTE
         BE       RETURN4           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      P17               NO
         LI,R1    ARGBUF4+1
         LB,R1    *R7,R1            GET FIRST CHAR
         CI,R1    'X'               IS IT AN X
         BNE      P17               NO
         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

