P        CSECT    1
DATA     CSECT    0
TBLSECT  CSECT    1
TXTSECT  CSECT    1
         SYSTEM   SIG7
         SYSTEM   BPM
,,FPT    M:PT     1                 FPT'S IN PROTECTED MEMORY
         PCC      0
         TITLE    '****  REGISTERS  ****'
         SPACE    2
R0       EQU      0
R1       EQU      1
R2       EQU      2
R3       EQU      3
R4       EQU      4
R5       EQU      5
R6       EQU      6
R7       EQU      7
R8       EQU      8
R9       EQU      9
R10      EQU      10
R11      EQU      11
R12      EQU      12
R13      EQU      13
R14      EQU      14
R15      EQU      15
         SPACE    2
J:JIT    EQU      X'8C00'
PC       EQU      '-'               PROMPT CHAR
         TITLE    '****  DEFS  ****'
         SPACE    2
         DEF      P
         DEF      DATA
         DEF      TBLSECT
         DEF      TXTSECT
         DEF      COMTXT
         DEF      COMLOC
         DEF      COMFLAG
         DEF      FPT
         TITLE    '****  REFS  ****'
         SPACE    2
         REF      M:C
         REF      F:ERR
         TITLE    '****  PROCS  ****'
         SPACE    2
PUSH     CNAME    X'09',X'0B'
PULL     CNAME    X'08',X'0A'
         PROC
LF       EQU      %
         DO1      NUM(AF)>1
         LCI      AF(1)&X'F'
         GEN,8,4,20   NAME(NUM(AF)),AF(NUM(AF)),TSTACK
         PEND
         SPACE    2
BUILD    CNAME
         PROC
         LOCAL    MAIN,TBL,TYPE,ADDR
LF(1)    SET      %
MAIN     SET      %
         DO       SCOR(CF(2),E)
TBL      SET      AF
         ELSE
         USECT    TBLSECT
TBL      SET      %
LF(2-SCOR(CF(2),L))  SET  %
*
I        DO       NUM(AF)           PROCESS ALL AF ENTRIES
TYPE     SET      SCOR(AF(I,1),TEXT,HEX,DEC,RHEX,RDEC,SPACE,;
                    DUMPBUF)
ADDR     SET      S:UFV(AF(I,2))
         DO       TYPE=1&TCOR(AF(I,2),S:C)=1
         USECT    TXTSECT
ADDR     SET      %
         TEXTC    AF(I,2)           GENERATE THE SPECIFIED TEXT
         USECT    TBLSECT
         FIN
*
         GEN,1,7,4,1,19  AFA(I,2),AF(I,3),TYPE,I=NUM(AF),ADDR
*
         FIN
*
         USECT    MAIN
         FIN
         DO       SCOR(CF(2),L)=0
         STW,R0   TBLREGS
         BAL,R0   TBLDMP
         DATA     TBL
         FIN
         PEND
         TITLE    '****  PROCEDURE  ****'
         SPACE    2
         USECT    P
START    RES      0
         M:PC     PC
         M:INT    INTADDR
         M:DEVICE M:LO,VFC
         LW,R2    Y002
         CW,R2    M:SI
         BANZ     %+2               DON'T OPEN IF ALREADY OPEN
         M:OPEN   M:SI,IN,(ABN,SIABN),(ERR,SIABN)
         LC       J:JIT
         BCS,12   RDLOOP            BR IF NOT BATCH
         M:READ   M:C,(BUF,INBUF),(SIZE,80)   READ CONTROL CARD IMAGE
RDLOOP   LI,R0    0
         LW,R1    Y0008
         STS,R0   OPNFPT            RESET TESTF OPTION
         STW,R0   BUSYFLG           SET NOT BUSY
*
         BAL,R11  READ              READ NEXT COMMAND THRU M:SI
         BCS,1    EXIT              EOF
         MTW,1    BUSYFLG           SET BUSY
*
         LC       J:JIT
         BCR,8    COMLP1            NOT ONLINE
         CAL1,8   PLATFPT
         SLS,R11  -8
         AND,R11  M8                PLATEN WIDTH
         STW,R11  PLATEN
*
COMLP1   LI,R2    #COM
         LI,R3    0
         STW,R3   COMFLAG-1,R2      RESET COMMAND FLAGS
         BDR,R2   %-1
         STW,R3   BRKFLAG           NO BREAKS RECEIVED
*
         LI,R11   DTAB3             DELIMITER TABLE - BLANK ONLY
         STW,R11  DTBL
         BAL,R11  GETFIELD          GET COMMAND
         BCS,4    RDLOOP            NO FIELD
         AI,R7    0
         BEZ      COMLP5            EMPTY FIELD
         LI,R2    BA(COMTXT)+(#COM-1)*8
         LI,R3    #COM
COMLP2   LW,R4    R2                CURRENT BA OF COMMAND TO CHECK
         LI,R5    BA(FBUF)          BA OF COMMAND USER TYPED
         STB,R7   R5                # BYTES TO COMPARE
         CB,R7    0,R4
         BG       COMLP4            USER TYPED MORE CHARS THAN IN THIS ONE
         CBS,R4   1
         BE       FNDCOM            FOUND IT
COMLP4   AI,R2    -8                ADVANCE TO NEXT COMMAND
         BDR,R3   COMLP2
COMLP5   LI,R14   MUNKCOM           UNKNOWN COMMAND
         B        ERROR2
*
FNDCOM   MTW,1    COMFLAG-1,R3      SET COMMAND FLAG
         B        COMLOC-1,R3       EXECUTE THE COMMAND
         SPACE    2
*
*  EXIT COMMAND
*
EXIT     M:CLOSE  M:LO,SAVE
         M:EXIT
         SPACE    2
*
*  RENAME COMMAND:
*
*  RENAME  FID  TO  NAME
*
*    WHERE:
*      FID = DP#XXXX-RS/NAME.ACCT.PASS
*      NAME = 1-31 CHAR FILE NAME
*
RENAME   BAL,R11  FNAM
         LI,R14   MNONAME
         LW,R11   FNAME
         BEZ      ERROR2            MUST SPECIFY FILE NAME
*
         LI,R1    DTAB3             BLANK IS ONLY DELIMITER
         STW,R1   DTBL
         BAL,R11  GETFIELD          GET NEXT FIELD
         BCS,4    RN20              ERROR - NO FIELD
         LW,R1    FBUF
         CW,R1    ='TO  '
         BNE      RN20              MISSING VERB
         BAL,R11  GETFIELD          GET NEW FILE NAME
         BCS,4    RN22              MISSING FIELD
         AI,R7    0
         BEZ      RN22              MISSING FILE NAME
         LI,R14   MFNBAD
         CI,R7    31
         BG       ERROR2            NAME TOO LONG
         LW,R1    =X'01010808'
         STW,R1   CLSVLP
         STB,R7   CLSVLP+1
         LI,R4    BA(FBUF)
         LI,R5    BA(CLSVLP+1)+1
         STB,R7   R5
         MBS,R4   0                 MOVE NEW NAME TO CLS FPT
         B        COMNOPN           GO OPEN DCB
*
RN20     LI,R14   MNOVERB
         B        ERROR2
RN22     LI,R14   MMISFN            MISSING FILE NAME
         B        ERROR2
         SPACE    2
*
*  LIST AND MODIFY COMMANDS
*
LIST     LW,R1    Y0008
         STS,R1   OPNFPT            SET TEST FILE OPTION
*
MODIFY   BAL,R11  FNAM              SCAN FILE NAME
*
         BAL,R11  SCANOPT           SCAN OPTIONS
         LW,R11   MFLAG
         BEZ      COMNOPN           BR IF LIST
         LI,R14   MNOOPT
         LW,R11   SUBLOC
         BNEZ     COMNOPN
         B        ERROR2
         TITLE    '****  COMNOPN  ****'
         SPACE    2
*  OPEN THE INPUT DCB
         SPACE    2
COMNOPN  LI,R4    0
         STW,R4   COUNT             NO FILES PROCESSED YET
         LI,R5    X'400'
         LW,R11   FNAME
         BNEZ     %+2               BR IF FILE NAME SPECIFIED
         LI,R4    X'400'            NO NAME, SET NEXT FILE OPTION
         STS,R4   OPNFPT+1          SET/RESET NXTF
         STW,R4   NXTF
*
         LI,R4    0
         LI,R5    X'FF00'
         STS,R4   ACCT-1            RESET # WORDS USED IN ACCOUNT
         STS,R4   SN-1                AND SERIAL # VLPS IN OPN FPT
*
         LI,R5    X'200'
         LW,R4    ACCT
         BEZ      %+2
         STS,R5   ACCT-1            ACCOUNT SPECIFIED - SET 2 WORDS USED
         LI,R5    X'100'
         LW,R4    SN
         BEZ      %+2
         STS,R5   SN-1              SERIAL # PRESENT - SET 1 WORD USED
*
COMN20   LI,R10   0
         STW,R10  FITMOD            NO FIT CHANGES MADE YET
         STW,R10  CALFLAG
         MTW,0    BRKFLAG
         BNEZ     COMNX05           BREAK RECEIVED
         M:OPEN,E OPNFPT
         LB,R2    R10
         BEZ      COMN40            NO ERROR
         CI,R2    2
         BE       COMNX10           END OF FILES ON OPNNXT
         CI,R2    8
         BE       COMN35            SYNONYMOUS - IGNORE IT
*
COMN25   LW,R11   NXTF
         BNEZ     COMN30            BR IF ERROR ON NXTF OPEN
         LW,R3    FILPOS            END OF FILE NAME FIELD
         BAL,R11  ERRMARK
         BAL,R11  ERRMSG
         B        ERROR4
*
COMN30   SLS,R2   8
         SLS,R10  -17
         AND,R10  M7                SUB-CODE
         OR,R2    R10
         LI,R1    4                 COL #
         BAL,R10  PUTHEXR
         LW,R4    MEINAME           ADDRESS OF FILE NAME IN M:EI DCB
         SLS,R4   2
         BAL,R11  PRKEY
         BAL,R15  DUMPBUF
*
         LW,R4    CALFLAG
         BNEZ     COMN48            BR IF ERROR ON M:CLOSE
         LW,R4    MEINAME           ADDRESS OF FILE NAME IN M:EI DCB
         LI,R5    BA(FNAME)+1       COMPARE FILE NAMES IN DCB AND
         SLS,R4   2                   OPEN FPT
         LB,R6    0,R4
         CB,R6    FNAME
         BNE      COMN35            NOT THE SAME
         STB,R6   R5
         CBS,R4   1                 IF THE SAME, ANOTHER OPEN NXTF WILL
         BE       COMNXIT             RETURN THE SAME FILE NAME
*
COMN35   LCI      8
         LM,R8    *MEINAME
         STM,R8   FNAME             MOVE DCB NAME TO FPT
         B        COMN20            ISSUE ANOTHER OPEN
*
COMN40   LCI      8
         LM,R8    *MEINAME
         STM,R8   FNAME
         LW,R2    LFLAG
         BNEZ     LIST20            BR IF LIST COMMAND
         LW,R2    MFLAG
         BNEZ     MOD20             PROCESS MODIFY
*
COMN45   LI,15    =X'03010000'      IN CASE NO PASSWORD FOUND
         LI,11    X'10000'
         LI,1     CLSVLP
         LI,2     CLSVLP
COMN46   CW,11    0,1
         BANZ     COMN47            AT END
         LB,3     *1
         CI,3     3                 IS THIS PASSWORD
         BNE      %+2               NO
         LW,15    1                 YES - SAVE ADDRESS
         LW,2     1                 REMEMBER ADDR OF LAST VLP
         LI,3     X'FF'
         AND,3    0,1
         AI,3     1
         AW,1     3                 ADVANCE TO NEXT ONE
         B        COMN46
COMN47   STS,11   0,2               SET STOP BIT ON LAST
         LI,R10   0
         MTW,1    CALFLAG           INDICATE M:CLOSE CAL
         M:CLOSE,E  CLSFPT
         LB,R2    R10
         BNEZ     COMN25            ERROR
         LW,R11   MFLAG
         BEZ      COMNXIT           NOT MODIFY
         LCI      3
         LM,10    *15               PICK UP PASSWORD VLP
         OR,10    =X'10000'         SET STOP BIT
         LCI      3
         STM,10   TSTVLP            PUT INTO OPEN FPT
         LI,10    0
         CAL1,1   TSTFPT            DO TEST OPEN FOR FPARAMS
         AI,10    0
         BNEZ     COMNXIT           ERROR - DON'T LIST
         B        LIST50            GO LIST THE FILE
*
COMN48   LW,R2    NXTF
         BNEZ     COMN20            ISSUE ANOTHER OPEN IF NXTF
COMNXIT  B        RDLOOP
*
COMNX05  BUILD    (TEXT,' .. HALTED'),(DUMPBUF)
COMNX10  BUILD    (TEXT,' .. '),(DEC,*COUNT),(TEXT,' FILE')
         LW,R2    COUNT
         CI,R2    1
         BE       COMNX20
         BUILD    (TEXT,'S')
COMNX20  LW,R2    MFLAG
         BNEZ     COMNX25
         BUILD    (TEXT,' LISTED')
         B        COMNX28
COMNX25  BUILD    (TEXT,' MODIFIED')
COMNX28  BAL,R15  DUMPBUF
         B        RDLOOP
*
OPNERR   B        *R8
         SPACE    4
*  PROCESS LIST COMMAND AFTER A FILE HAS BEEN OPENED
         SPACE    2
LIST20   LW,R1    SUBLOC
         BEZ      LIST50            NO SEARCH CRITERIA - LIST THE FILE
         LI,R1    SUBLOC+1          ADDR OF FIRST SEARCH CRITERIA
LIST21   LW,R12   1,R1              VLP CODE
         BAL,R4   FITFND            IS THIS VLP IN FIT
         B        LIST35            NO
         AI,R6    1                 POINT TO FIT DATA
         LD,R8    R6                SAVE FIT POINTERS
         LW,R10   0,R1              # WORDS IN SUBLOC ENTRY
         AI,R10   -3                SUBTRACT THE 3 HEADER WORDS
         BLEZ     LIST40            NO DATA - LIST THE FILE
         AI,R1    3                 POINT TO SUBLOC DATA
LIST23   CI,R12   X'15'
         BE       LIST28            BR IF 'UNDER'
         LCI      2
         LM,R14   0,R1              GET NEXT SUBLOC DATA ENTRY
         CW,R14   0,R6              DOES IT MATCH THIS FIT ENTRY
         BNE      LIST25            NO
         CI,R7    1
         BE       LIST50            BR IF ONLY 1 WORD IN FIT VLP
         CW,R15   1,R6
         BE       LIST50            YES - LIST THE FILE
*
LIST25   AI,R6    2                 ADVANCE TO NEXT FIT ENTRY
         AI,R7    -2
         BGZ      LIST23            MORE TO GO
         LD,R6    R8                RESTORE FIT POINTERS
         AI,R1    2                 ADVANCE TO NEXT SUBLOC ENTRY
         AI,R10   -2
         BGZ      LIST23            MORE TO DO
*  NO MATCH - TRY NEXT SUBLOC BLOCK
LIST26   LW,R2    SUBLOC
         AI,R2    SUBLOC
         CW,R1    R2
         BL       LIST21            MORE TO DO
         B        COMN48            NO MATCH - IGNORE FILE
*
LIST28   LW,R4    R1                ADDRESS OF SUBLOC ENTRY
         LW,R5    R6                ADDRESS OF FIT ENTRY
         SLD,R4   2
         LB,R14   0,R4
         CB,R14   0,R5
         BNE      LIST30            NO MATCH IF COUNTS NOT EQUAL
         AI,R5    1                 SKIP TEXTC COUNT
         STB,R14  R5
         CBS,R4   1
         BE       LIST50            LIST THE FILE IF MATCH
LIST30   AI,R6    3                 ADVANCE TO NEXT FIT ENTRY
         AI,R7    -3
         BGZ      LIST28            MORE FIT ENTRIES
         LD,R6    R8
         AI,R1    3                 ADVANCE SUBLOC POINTER
         AI,R10   -3
         BGZ      LIST28
         B        LIST26            END OF THIS SUBLOC BLOCK
*
LIST35   AW,R1    0,R1              POINT TO NEXT SUBLOC BLOCK
         B        LIST26
*
LIST40   LW,R10   0,R6              FIRST DATA WORD
         CI,R12   3
         BE       LIST50            LIST IF PASSWORD
         CI,R12   5
         BE       LISTRD
         CI,R12   X'14'
         BGE      LIST35            IGNORE EX, UN IF NO READ RESTRICTION
         CW,R10   NONE              WR - IGNORE IF NONE
         BE       LIST35
         B        LIST50
LISTRD   CW,R10   ALL               RD - IGNORE IF ALL
         BE       LIST35
*
*  LIST THE FILE
*
LIST50   LW,R2    NXTF
         BEZ      LIST55            DON'T PRINT FILE NAME IF NOT NXTF
         LI,R4    BA(FNAME)
         BAL,R11  PRKEY
         MTW,1    COUNT             COUNT # FILES LISTED
LIST55   LW,R1    PRPOS
         AI,R1    -BA(PRBUF)
         AI,R1    4
         DW,R1    =5                FIND NEXT MULT OF 5 COLUMN #
         MI,R1    5
         CI,R1    10
         BGE      %+2
         LI,R1    10                MINIMUM OF COL 10
         LI,R4    BA(MSPACE)
         BAL,R10  PUTMESC
*
         LI,R2    -1
         STW,R2   TEMP              SIGNAL NO OPTIONS PRINTED YET
         LI,R2    #OPTS
LIST56   LB,R12   OPTTYP,R2         GET VLP CODE
         BAL,R4   FITFND            LOCATE IN FIT
         B        LIST75            NOT THERE
         AI,R6    1                 POINT TO FIT DATA
*
         MTW,1    TEMP
         BEZ      LIST60            BR IF FIRST OPTION
         BUILD    (TEXT,'; ')       SEPARATE OPTIONS
LIST60   LI,R4    4                 LEAVE ROOM FOR ENTRY + 'XX=' + COMMA
         BAL,R11  CHKROOM           MAKE SURE ENOUGH ROOM IN PRINT BUFFER
         LI,R4    BA(OPTS)
         AW,R4    R2
         AW,R4    R2
         LI,R5    2
         BAL,R10  MOVTXT            PUT IN TEXT OPTION
         BUILD    (TEXT,'=')
LIST62   CI,R12   X'15'
         BE       LIST70            BR IF 'UNDER'
         LW,R4    R6                ADDRESS OF ACCOUNT
         LI,R10   8                 ASSUME 8 BYTES IN ENTRY
         CI,R7    1
         BG       %+2
         LI,R10   4                 ONLY 4 BYTES
         LI,R5    0
LIST63   LB,R8    *R4,R5
         CI,R8    X'40'             SEARCH FOR END OF ACCOUNT
         BE       LIST64
         AI,R5    1
         BDR,R10  LIST63
LIST64   SLS,R4   2
         BAL,R10  MOVTXT            PUT IN THE ACCOUNT
         AI,R6    2                 POINT TO NEXT ACCOUNT
         AI,R7    -2
         BLEZ     LIST75            NO MORE
         LW,R8    -2,R6             GET LAST ACCOUNT
         CLM,R8   ALL
         BCR,3    LIST75            STOP IF IT WAS 'ALL '
         BCR,12   LIST75              OR 'NONE'
LIST66   BUILD    (TEXT,',')        SEPARATE
         LI,R4    1                 LEAVE ROOM FOR ENTRY PLUS COMMA
         BAL,R11  CHKROOM           PRINT BUFFER IF FULL
         B        LIST62
*
LIST70   LW,R4    R6
         SLS,R4   2
         BAL,R10  MOVTXTC           MOVE IN 'UNDER' NAME
         AI,R6    3
         AI,R7    -3
         BGZ      LIST66            MORE TO DO
*
LIST75   BDR,R2   LIST56            DO REST OF VLPS
         LW,R15   TEMP
         BGEZ     LIST78            BR IF AT LEAST ONE ATTRIBUTE FOUND
         LW,R15   NXTF
         BNEZ     LIST78            BR IF NXTF SET
         BUILD    (TEXT,'NO ATTRIBUTES')
LIST78   BAL,R15  DUMPBUF
         B        COMN48            DO NEXT FILE
         SPACE    4
*
*  PROCESS MODIFY COMMAND
*
MOD20    LI,R1    0
         STW,R1   CLSSIZE
         LI,R1    CLSVLP
         LI,R2    #OPTS
MOD25    LB,R12   OPTTYP,R2         GET NEXT VLP CODE
         BAL,R4   FITFND            IS IT IN FIT
         B        MODADD            NO - PUT DUMMY HEADER IN FPT
         LW,R8    1,R6              FIRST DATA WORD
         MTW,1    FITMOD            ASSUME CHANGE TO BE MADE
MODADD   SCS,R12  -8                ADD DUMMY ZERO LENGTH VLP TO FPT
         STW,R12  0,R1
         AI,R1    1
         B        MODNXT
*
*  MOVE EXISTING VLP TO FPT
*
MODMOV   MTW,-1   FITMOD
MODMOV1  AI,R7    1
         AWM,R7   CLSSIZE
MODMOV2  LW,R8    0,R6
         STW,R8   0,R1
         AI,R6    1
         AI,R1    1
         BDR,R7   MODMOV2
*
MODNXT   BDR,R2   MOD25
         LI,R12   X'10000'
         STW,R12  0,R1              PUT IN STOP FLAG
*
MOD30    LI,R1    SUBLOC+1
MOD32    LW,R12   1,R1              VLP CODE
MOD33    BAL,R4   VLPFND            FIND CODE IN CLS VLP LIST
         NOP
         STW,R6   CURLOC            SAVE ADDR OF CURRENT VLP CNTRL WD
         AI,R6    1                 POINT TO FIRST DATA WORD
         LI,R2    2
         CI,R12   X'15'
         BNE      %+2
         LI,R2    3                 SET # WORDS IN ENTRY
         LW,R13   2,R1
         BNEZ     MOD40             BR IF QUALIFIER
*  REMOVE EXISTING INFO PRIOR TO INSERTING NEW
         AI,R7    0
         BEZ      MOD40             NO EXISTING INFO
         MTW,1    FITMOD            INDICATE FIT CHANGED
         LI,R8    0
         LI,R9    X'FFFF'
         STS,R8   *CURLOC           RESET # WORDS USED
         LCW,R9   R7
         AI,R9    -1
         AWM,R9   CLSSIZE
         AW,R7    R6                POINT TO NEXT CTL WORD
MOD35    LI,R8    X'FF'
         AND,R8   0,R7
         AI,R8    1
         LW,R9    0,R7
MOD38    LW,R9    0,R7
         STW,R9   0,R6
         AD,R6    DOUBLEONE
         BDR,R8   MOD38             MOVE UP NEXT VLP CODE
         CI,R9    X'10000'
         BAZ      MOD35             NOT LAST - KEEP ON
         B        MOD33
*
*  ADD TO OR REMOVE FROM EXISTING ENTRY
*
MOD40    LW,R10   0,R1
         AI,R1    3
         AI,R10   -3                # WORDS IN SUBLOC ENTRY
         BLEZ     MOD58             NONE
         LD,R8    R6                SAVE POINTERS TO FPT DATA
MOD45    LI,R12   X'FF'
         BAL,R4   VLPFND            R6 = ADDR OF END OF VLP LIST
         LD,R4    R8
         AI,R13   0                 CHECK QUALIFIER
         BLZ      MOD60             BR IF REMOVE
         LW,R14   R2
         SLS,R14  8
         OR,R14   R2
         AWM,R14  *CURLOC           SET NEW VLP SIZE
         AWM,R2   CLSSIZE
         AW,R4    R5                POINT TO END OF VLP
         AI,R5    0
         BNEZ     MOD50
         MTW,1    CLSSIZE
MOD50    LW,R5    R6
MOD51    LW,R14   0,R5
         STW,R14  *R2,R5            MAKE ROOM FOR NEW ENTRY
         AI,R5    -1
         CW,R5    R4
         BGE      MOD51
         LW,R3    R2
MOD55    LW,R14   0,R1
         STW,R14  0,R4              INSERT NEW ENTRY
         AI,R1    1
         AI,R4    1
         BDR,R3   MOD55
         AW,R8    R2                INCR POINTER TO NEXT INSERTION PT
         MTW,1    FITMOD
*
         SW,R10   R2
         BGZ      MOD45             MORE TO DO
*
MOD58    LW,R2    SUBLOC            ADVANCE TO NEXT SUBLOC ENTRY
         AI,R2    SUBLOC+1
         CW,R1    R2
         BL       MOD32
*
         LW,R11   FITMOD
         BNEZ     COMN45            BR IF MODIFICATIONS TO DO
         M:CLOSE  M:EI              CLOSE WITH NO OPTIONS
         B        COMN48
*
*  REMOVE
*
MOD60    AI,R5    0
         BLEZ     MOD68             NOTHING TO LOOK AT
MOD62    CI,R2    3
         BE       MOD70             BR IF 'UNDER'
         LCI      2
         LM,R14   0,R1
         CW,R14   0,R4              LOOK FOR MATCH
         BNE      MOD75
         CW,R15   1,R4
         BNE      MOD75
MOD64    MTW,1    FITMOD
         LW,R15   R4
         LW,R3    R4
         AW,R3    R2
MOD65    LW,R14   0,R3              SLIDE ENTRIES UP
         STW,R14  0,R4
         AI,R3    1
         AI,R4    1
         CW,R3    R6
         BLE      MOD65
         LW,R4    R15
         LW,R3    R2
         SLS,R3   8
         OR,R3    R2
         LW,R14   *CURLOC           CLS VLP CONTROL WORD
         SW,R14   R3                DECR COUNTS
         CI,R14   X'FFFF'
         BANZ     %+2
         MTW,-1   CLSSIZE           DECR SIZE OF VLPS IF NO DATA
         STW,R14  *CURLOC
         LCW,R14  R2
         AWM,R14  CLSSIZE
         SW,R9    R2                DECR TOTAL # WORDS IN ENTRY
         B        MOD76             MORE TO DO
*
MOD68    LD,R4    R8
         AW,R1    R2
         SW,R10   R2
         BGZ      MOD62             MORE IN SUBLOC ENTRY
         B        MOD58
*
MOD70    LB,R3    *R1               TEXTC COUNT
         CB,R3    *R4
         BNE      MOD68             NOT EQUAL
         LW,R14   0,R1
         LW,R15   0,R4
         SLS,R14  2
         STB,R3   R15
         AD,R14   DOUBLEONE
         CBS,R14  0
         BE       MOD64             EQUAL
         B        MOD68
*
MOD75    AW,R4    R2
MOD76    SW,R5    R2
         BGZ      MOD62
         B        MOD68
         SPACE    4
*  SEARCH FPARAM BUFFER FOR A SPECIFIED VLP
*
*  INPUT:          R12 = VLP CODE
*
*  OUTPUT:         R6 = ADDRESS OF VLP CONTROL WORD
*                  R7 = # WORDS IN VLP
*                  RETURN SKIPPING IF FOUND
*
*  CALL:           BAL,R4
*
VLPFND   LI,R6    CLSVLP
         B        FITF4
FITFND   LI,R6    FPARAM
FITF4    LI,R7    X'FF'
         AND,R7   0,R6
         CB,R12   *R6
         BE       1,R4              FOUND
         LW,R5    0,R6
         CI,R5    X'10000'
         BANZ     0,R4              END - NOT FOUND
         AI,R7    1
         AW,R6    R7
         B        FITF4
         SPACE    4
CHKROOM  LW,R1    PRPOS
         AI,R1    8-BA(PRBUF)
         AW,R1    R4                ADD IN EXTRA CHARS
         CI,R12   X'15'
         BNE      %+2               NOT 'UNDER'
         AI,R1    3                 ADD EXTRA SIZE OF ENTRY
         CI,R1    33*4
         BGE      CHKR30            TOO BIG
         CW,R1    PLATEN
         BL       *R11              OK
CHKR30   BAL,R15  DUMPBUF
         BUILD    (SPACE,5)
         B        *R11
         TITLE    '****  FNAM  ****'
         SPACE    2
*  NAME:           FNAM
*
*  OUTPUT:         FNAME - FILE NAME
*                  ACCT - ACCOUNT
*                  PASS - PASSWORD
*                  SN - SERIAL #
*                  DEVTYP - DEVICE TYPE
*
*  DESCRIPTION:    PARSES FID (SERIAL #, FILE NAME, ACCOUNT, PASSWORD)
         SPACE    1
FNAM     STW,R11  FNRET             SAVE LINK
         LI,R2    0
         STW,R2   FNAME
         STW,R2   ACCT
         STW,R2   SN
*
         LI,R2    DTAB1             DELIMITERS = '# /(),'
         STW,R2   DTBL
         LW,R11   LDELIM            GET LAST DELIMITER CHAR
         CI,R11   '('
         BE       *FNRET            NO FILE NAME
         BAL,R11  GETFIELD          GET FIRST FIELD
         BCS,4    *FNRET            NO FILE NAME
         CI,R12   '#'               CHECK DELIMITER
         BNE      FNFID             NOT SERIAL #
         LI,R12   'DP'
         STW,R12  DEVTYP            SET DEFAULT DEVICE TYPE
         AI,R7    0
         BEZ      FNSN              NO TYPE SPECIFIED, USE DEFAULT
         LI,R14   MDTERR            'DEVICE TYPE NOT 2 CHARS'
         CI,R7    2
         BNE      ERROR2
         LH,R7    FBUF
         AND,R7   M16               GET THE USER SPECIFIED DEVICE TYPE
         STW,R7   DEVTYP
*
FNSN     BAL,R11  GETFIELD          GET NEXT FIELD
         BCS,4    FNF82             MISSING SERIAL #
         LI,R14   MMISFN            MISSING FILE NAME
         CI,R12   ' '
         BE       FNSN5             DELIMITER MUST BE BLANK OR
         CI,R12   '/'                 SLASH
         BNE      ERROR
FNSN5    LI,R14   MMISSN            MISSING SERIAL #
         AI,R7    0
         BEZ      ERROR2            EMPTY FIELD
*
         LI,R12   '-'
         BAL,R11  SPLITFLD          LOOK FOR RESOURCE TYPE
         LI,R14   MMISSN            'MISSING SERIAL #'
         AI,R6    0
         BEZ      ERROR2            NO SERIAL #
         LI,R14   MSNBAD            'SERIAL # > 4 CHARS'
         CI,R6    4
         BG       ERROR2
         LW,R2    FBUF
         STW,R2   SN                SAVE SERIAL #
         LI,R14   MNODEV            'MISSING DEVICE TYPE'
         AI,R7    0
         BLZ      FNSN8             NO DASH, NO DEV TYPE SPECIFIED
         BEZ      ERROR2            EMPTY FIELD
         LI,R14   MDTERR            'DEVICE TYPE NOT 2 CHARS'
         CI,R7    2
         BNE      ERROR2
         LH,R2    SBUF
         AND,R2   M16
         STW,R2   DEVTYP
*
FNSN8    BAL,R11  GETFIELD          GET FILE NAME
         BCS,4    *FNRET            NO FILE NAME
*
*  LOOK FOR NAME.ACCT.PASS
*
FNFID    LI,R14   MMISFN            'MISSING FILE NAME'
         CI,R12   ' '
         BE       FNF10             DELIMITER MUST BE BLANK
         CI,R12   '('                 OR LEFT PAREN
         BNE      ERROR2
         AI,R7    0
         BEZ      *FNRET            NO FILE NAME, ACCT OR PASS
*
FNF10    LI,R12   '.'
         BAL,R11  SPLITFLD          LOOK FOR ACCT AND PASS
         AI,R6    0
         BEZ      FNF20             NO FILE NAME
         LI,R14   MFNBAD            'FILE NAME > 31 CHARS'
         CI,R6    31
         BG       ERROR2
         LI,R4    BA(FBUF)
         LI,R5    BA(FNAME)+1
         STB,R6   R5
         STB,R6   FNAME             TEXTC COUNT
         MBS,R4   0                 MOVE FILE NAME
*
FNF20    LI,R2    BA(SBUF)
         LI,R3    BA(FBUF)
         LI,R4    FBUFSIZ
         STB,R4   R3
         MBS,R2   0                 MOVE SBUF TO FBUF
         LI,R2    BA(SBUF1)
         LI,R3    BA(FBUF1)
         STB,R4   R3
         MBS,R2   0                 MOVE SBUF1 TO FBUF1
*
         LI,R12   '.'
         BAL,R11  SPLITFLD          IS THERE A PASSWORD
         AI,R6    0
         BEZ      FNF30             NO ACCOUNT
         LI,R14   MACCTBAD          'ACCOUNT > 8 CHARS'
         CI,R6    8
         BG       ERROR2
         LCI      2
         LM,R8    FBUF
         STM,R8   ACCT
*
FNF30    LI,R14   MPASSBAD          'PASSWORD BAD'
         AI,R7    0
         BLZ      FNF40             NO PASSWORD
         BEZ      ERROR2            NULL PASWORD ILLEGAL
         CI,R7    8
         BG       ERROR2
         LCI      2
         LM,R8    SBUF
         STM,R8   PASS
*
FNF40    LI,R14   MMISFA            'MISSING FILE NAME OR ACCOUNT'
         LW,R11   FNAME
         OR,R11   ACCT
         BEZ      ERROR2
         LW,R3    ENDFLD
         STW,R3   FILPOS            REMEMBER END OF FILE NAME
         B        *FNRET            EXIT
*
FNF82    LI,R14   MMISSN            'MISSING SERIAL #'
         B        ERROR
         TITLE    '****  SCANOPT  ****'
         SPACE    2
*  SCAN FOR OPTIONS:
*    (OPT(SUBOPT,SUBOPT,...),OPT(SUBOPT,...),...)
*
*    OPT MAY BE:  RD, WR, EX, UN, PA
*      IF PRECEEDED BY '+', ADDS THE SPECIFIED SUB-OPTIONS TO THOSE
*        ALREADY IN THE FIT.  '-' REMOVES SPECIFIED SUB-OPTIONS FROM
*        THE FIT.  NEITHER INDICATES ANY EXISTING SUB-OPTIONS ARE
*        TO BE REMOVED AND THE SPECIFIED ONES TO BE ADDED.  'PA'
*        MAY NOT HAVE A QUALIFIER.
*
*    EXAMPLE:
*      (RD(ABCD,DDDD),-WR(1234),+EX(9999),UN)
         SPACE    1
SCANOPT  STW,R11  FNRET
         LI,R11   0
         STW,R11  SUBLOC
         LI,R11   DTAB2
         STW,R11  DTBL
         LI,R11   X'10000'
         STW,R11  CLSVLP
OPT10    BAL,R11  GETFIELD
         BCS,4    *FNRET            NO OPTIONS
         AI,R7    0
         BNEZ     OPT11             BR IF GOT NON-EMPTY FIELD
         CI,R12   ')'
         BE       *FNRET
         CI,R12   ','
         BE       OPT10             GET NEXT FIELD
         LI,R14   MMISTERM          MISSING TERMINATOR
         B        ERROR2
OPT11    LI,R4    1
         LB,R2    FBUF
         CI,R2    '+'               LOOK FOR QUALIFIERS
         BE       OPT12
         LI,R4    0
         CI,R2    '-'
         BNE      OPT14
         LI,R4    -1
OPT12    LW,R8    FBUF
         SLS,R8   8                 REMOVE QUALIFIER
         STW,R8   FBUF
         AI,R7    -1                DECR # CHARS IN FIELD
OPT14    STW,R4   QUALIF            SAVE QUALIFIER FLAG
         LI,R14   MUNKOPT           UNKNOWN OPTION
         CI,R7    2
         BNE      ERROR2
         LH,R11   FBUF
         LI,R2    #OPTS             NUMBER OF OPTIONS
         CH,R11   OPTS,R2
         BE       OPT20
         BDR,R2   %-2
         B        ERROR2
*
OPT20    LB,R3    OPTTYP,R2         VLP CODE FOR THIS OPTION
         STW,R3   OPTVLP
         LI,R8    2                 ASSUME ENTRY IS 2 WORDS LONG
         CI,R3    X'15'
         BNE      %+2
         LI,R8    3                 UNDER NAME IS 3 WORDS LONG
         STW,R8   SUBSIZE
         LW,R8    QUALIF
         BEZ      OPT25             NO QUALIFIER
         LI,R14   MQLIST            'QUALIFIER NOT LEGAL WITH LIST COMMAND'
         LW,R11   LFLAG
         BNEZ     ERRORB
         LI,R14   MQPASS            'QUALIFIER ILLEGAL WITH PASSWORD
         CI,R3    3
         BE       ERRORB
OPT25    BAL,R11  SUBSCAN           GET THE SUB-OPTIONS
         B        OPT10
         SPACE    2
SUBSCAN  STW,R11  SCANRET
         LI,R14   MTBLFULL
         LW,R1    SUBLOC
         CI,R1    #SUBLOC-3
         BG       ERROR2
         LI,R2    3
         LW,R4    QUALIF
         LCI      3
         STM,R2   SUBLOC+1,R1       PUT AWAY COUNT, VLP #, QUALIFIER
         AI,R1    SUBLOC+1
         STW,R1   CURLOC            LOC OF COUNT OF SIZE OF CURRENT ENTRY
         MTW,3    SUBLOC
         CI,R12   '('
         BNE      *SCANRET          RETURN IF NO SUB-OPTIONS
*
SUBS20   BAL,R11  GETFIELD
         BCS,4    *SCANRET
         AI,R7    0
         BEZ      *SCANRET
         LI,R14   MTBLFULL
         LW,R3    SUBLOC
         CI,R3    #SUBLOC-3
         BG       ERROR2            NOT ENOUGH ROOM
         LI,R14   MFLDLNG
         LW,R2    SUBSIZE
         CI,R2    2
         BE       SUBS50            IT'S AN ACCOUNT
         CI,R7    11                MAX SIZE FOR 'UNDER' NAME
         BG       ERROR2
         LW,R5    SUBLOC
         AI,R5    SUBLOC+1          DESTINATION
         STB,R7   *R5               PUT IN TEXTC COUNT
         LI,R4    FBUF
         SLD,R4   2
         AI,R5    1
         STB,R7   R5
         MBS,R4   0
         B        SUBS55
*
SUBS50   CI,R7    8
         BG       ERROR2
         LCI      2
         LM,R8    FBUF
         STM,R8   SUBLOC+1,R3       PUT IN SUB-OPTION
SUBS55   LI,R14   MTBLFULL
         AW,R3    R2
         STW,R3   SUBLOC
         AWM,R2   *CURLOC           INCR SIZE OF THIS ENTRY
         CI,R12   ','
         BE       SUBS20            MORE TO DO
         B        *SCANRET
         TITLE    '****  GETFIELD  ****'
         SPACE    2
*
*  CALL:           BAL,R11
*
*  OUTPUT:         R7 = # CHARACTERS IN FIELD
*                  R12 = DELIMITER
*                  CC = 0  A FIELD WAS FOUND
*                     = 4  NO MORE FIELDS EXIST
*
*  DESCRIPTION:    OBTAIN NEXT FIELD FROM INBUF, MOVE IT TO FBUF.
*                  LEADING BLANKS ARE IGNORED.  THE FIELD TERMINATES
*                  WITH THE FIRST DELIMITER ENCOUNTERED.  IF A SEMI-
*                  COLON IS ENCOUNTERED, IT WILL BE TREATED AS
*                  A BLANK, THE NEXT CARD WILL BE READ AND THE SCAN
*                  WILL CONTINUE ON THAT CARD.
         SPACE    1
GETFIELD LI,R7    (FBUFSIZ+3)/4
         LI,R8    0
         LW,R9    BLANKS
GETF05   STW,R8   FBUF1-1,R7
         STW,R9   FBUF-1,R7
         STW,R8   SBUF1-1,R7
         STW,R9   SBUF-1,R7
         BDR,R7   GETF05
         STW,R7   GETNCHK           CHECK FOR HEX AND CHAR FIELDS
         STW,R7   FLDFLG            NO SPECIAL FIELD IN PROGRESS
         LI,R9    -1                PROCESSING LEADING BLANKS
         B        GETF12
*
GETF10   AI,R9    0
         BNEZ     GETF15
GETF12   LW,R3    INPOS             PROCESSING FIELD - MARK CURRENT
         STW,R3   ENDFLD              POSITION AS END-OF-FIELD
*
GETF15   BAL,R10  GETCHAR           R12 = NEXT CHAR
         BCS,4    GETF40            NO MORE CHARS
         BCR,3    GETF20            NOT DELIMITER
         BCR,2    GETF35            DELIMITER - NOT BLANK
*  BLANK ENCOUNTERED
         AI,R9    0
         BNEZ     GETF10            LEADING BLANK - KEEP ON
         LI,R9    1                 INDICATE FIELD HAS TERMINATED
         MTW,1    GETNCHK           IGNORE SPECIAL FIELDS
         MTW,-1   ENDFLD            BACK UP END-OF-FIELD POINTER
         B        GETF15
*
*  NON-DELIMITER
*
GETF20   AI,R9    0
         BGZ      GETF30            END OF TRAILING BLANKS
         STB,R12  FBUF,R7           PUT AWAY THE CHAR
         STB,R14  FBUF1,R7          PUT AWAY FIELD FLAG
         AI,R7    0
         BNEZ     GETF22            BR IF NOT FIRST CHAR
         LW,R3    INPOS
         STW,R3   BEGFLD            MARK BEGINNING OF FIELD
GETF22   AI,R7    1
         LI,R9    0                 SET FIELD IN PROGRESS
         B        GETF10
*
*  FIELD TERMINATED BY NON-DELIMITER AFTER ONE OR MORE BLANKS
*
GETF30   MTW,-1   INPOS             BACK UP INPUT POINTER
GETF32   LI,R12   ' '               DELIMITER = BLANK
GETF35   STW,R12  LDELIM            SAVE LAST DELIMITER ENCOUNTERED
         LCI      0
         B        *R11
*
*  NO MORE CHARS IN BUFFER
*
GETF40   AI,R9    0
         BGZ      %+2               DON'T DECR POINTER IF TRAILING BLNKS
         MTW,-1   ENDFLD            BACK UP END-OF-FIELD POINTER
         AI,R7    0
         BNEZ     GETF32            SOME CHARS WERE FOUND
         LCI      4
         B        *R11
         TITLE    '****  SPLITFLD  ****'
         SPACE    2
*  NAME:           SPLITFLD
*
*  CALL:           BAL,R11
*
*  INPUT:          FIELD TO BE SPLIT IN FBUF
*                  R12 = CHAR WHICH SPLITS FIELD
*
*  OUTPUT:         FIRST STRING IN FBUF, SECOND IN SBUF
*                  R6 = # CHARS IN FIRST STRING
*                  R7 = # CHARS IN SECOND (-1 IF NO SPLIT CHAR FOUND)
*
*  DESCRIPTION:    STRING IN FBUF IS SEARCHED UNTIL THE SPLIT CHAR
*                  IS FOUND.  IF NOT FOUND, EXIT WITH R7 = -1.
*                  OTHERWISE, MOVE SECOND FIELD TO SBUF (BLANKING
*                  THE POSITIONS REMOVED FROM FBUF).  NOTE THAT R6
*                  WILL BE ZERO IF FIRST CHAR IN FIELD IS SPLIT CHAR.
         SPACE    1
SPLITFLD LI,R6    (FBUFSIZ+3)/4
         LI,R8    0
         LW,R9    BLANKS
SPLIT05  STW,R8   SBUF1-1,R6
         STW,R9   SBUF-1,R6
         BDR,R6   SPLIT05
         LI,R7    -1                ASSUME NO SPLIT CHAR FOUND
SPLIT10  LB,R13   FBUF1,R6
         BNEZ     SPLIT15           SKIP OVER CHAR AND HEX FIELDS
         LB,R13   FBUF,R6
         CW,R13   R12
         BE       SPLIT20           FOUND SPLIT CHAR
         CI,R13   X'40'
         BE       *R11              EXIT WHEN BLANK FOUND
SPLIT15  AI,R6    1
         CI,R6    FBUFSIZ
         BL       SPLIT10
         B        *R11              NO SPLIT CHAR FOUND
*
SPLIT20  LI,R7    0                 # CHARS IN SECOND STRING
         LI,R13   X'40'
         LW,R5    R6                CURRENT INDEX INTO FBUF
SPLIT25  STB,R13  FBUF,R5           BLANK LAST CHAR
         AI,R5    1
         CI,R5    FBUFSIZ
         BGE      *R11              DONE
         LB,R14   FBUF,R5
         MTB,0    FBUF1,R5
         BNEZ     SPLIT30           SPECIAL FIELD - IGNORE BLANKS
         CI,R14   X'40'
         BE       *R11
SPLIT30  STB,R14  SBUF,R7           STORE THIS CHAR
         LB,R14   FBUF1,R5          MOVE FIELD INDICATORS
         STB,R14  SBUF1,R7
         AI,R7    1
         B        SPLIT25
         TITLE    '****  GETCHAR  ****'
         SPACE    2
*  NAME:           GETCHAR
*
*  CALL:           BAL,R10
*
*  OUTPUT:         R12 = NEXT CHAR FROM INBUF
*                  R13 = CHAR AFTER ONE IN R12
*                  CC = 0  OK
*                     = 1  DELIMITER IN R12
*                     = 2  BLANK IN R12
*                     = 4  NO NEXT CHAR
*
*  DESCRIPTION:    GET NEXT CHAR FROM INBUF.  CHARACTER AND HEX FIELDS
*                  ARE RECOGNIZED, AND THE CONTROL SEQUENCES ARE
*                  STRIPPED OFF.  IF A SEMI-COLON IS FOUND, THE
*                  NEXT CARD IS READ AND GETCHAR RETURNS AS IF A
*                  BLANK WAS ENCOUNTERED.
         SPACE    1
GETCHAR  BAL,R15  NXTCHAR           GET NEXT CHAR FROM INBUF
         BCS,4    NOCHARS           NO MORE
         MTW,0    FLDFLG
         BLZ      HEXFLD            CURRENTLY IN HEX FIELD
         BGZ      CHARFLD           CURRENTLY IN CHAR FIELD
*  NO SPECIAL FIELD IN PROGRESS
         MTW,0    GETNCHK           ARE SPECIAL FIELDS TO BE IGNORED
         BNEZ     CHKDELIM          YES
         CI,R12   'X'
         BE       BEGHEX            MAY BE BEGINNING OF HEX FIELD
         CI,R12   ''''
         BE       BEGCHAR           BEGIN CHARACTER FIELD
         CI,R12   ';'
         BE       NXTCARD           CONTINUATION - READ NEXT CARD
*
CHKDELIM LB,R3    *DTBL             # CHARS IN DELIMITER TABLE
         CB,R12   *DTBL,R3
         BE       FNDELIM           FOUND A DELIMITER
         BDR,R3   %-2
GETOK    LI,R14   0                 NOT IN SPECIAL FIELD
         B        %+2
GETOK1   LI,R14   1                 CHAR OF HEX FIELD
         LCI      0                 NOT DELIMITER
         B        *R10
*
FNDELIM  CI,R12   X'40'
         BE       FNDBLNK
         LCI      1                 DELIMITER - NOT BLANK
         B        *R10
NXTCARD  PUSH     16,R0
         BAL,R11  READ              READ ANOTHER CARD
         BCS,1    UNEXPEOF          EOF
         PULL     16,R0
FNDBLNK  LCI      2
         B        *R10              BLANK
UNEXPEOF LI,R14   MUNEOF            'EOF AFTER CONTINUED CARD'
         B        ERROR
*
NOCHARS  MTW,0    FLDFLG
         BNEZ     UNTERM            NO MORE CHARS, UNTERMINATED FIELD
         LCI      4
         B        *R10
UNTERM   LI,R14   MUTFLD            'UNTERMIATED FIELD'
         B        ERROR
*
*  POSSIBLE BEGINNING OF HEX FIELD
*
BEGHEX   CI,R13   ''''              IS NEXT CHAR QUOTE
         BNE      CHKDELIM          NO - NOT HEX FIELD
         MTW,-1   FLDFLG            SET HEX FIELD IN PROGRESS
         BAL,R15  NXTCHAR           GET THE QUOTE
         BCS,1    UNTERM            NO CHARS AFTER QUOTE
         LW,R4    R3                SAVE INDEX OF FIRST CHAR IN STRING
BEGHEX2  LB,R12   INBUF,R3          GET NEXT CHAR
         CI,R12   ''''              FIND CLOSING QUOTE
         BE       BEGHEX4
         AI,R3    1
         CW,R3    INCNT
         BLE      BEGHEX2
         B        UNTERM            NO CLOSING QUOTE
*
BEGHEX4  SW,R3    R4                # CHARS IN FIELD
         LW,R4    R3
         BEZ      GETCHAR           EMPTY FIELD
BEGHEX5  LI,R14   0
         BAL,R15  NXTCHAR           GET NEXT CHAR
         STB,R12  R14               SAVE IT
         SCS,R12  -8                POSITION
         CI,R4    1                 IF ODD # CHARS IN FIELD, ONLY
         BANZ     BEGHEX6             GET ONE CHAR FIRST TIME
         BAL,R15  NXTCHAR           GET SECOND CHAR
         SLS,R12  16
         OR,R12   R14               COMBINE BOTH DIGITS
BEGHEX6  BAL,R15  HEX2BIN           CONVERT TO BINARY
         B        ERROR2            BAD HEX DIGIT
         LW,R12   R4                MOVE BINARY NUMBER
         B        GETOK1
*
*  BEGIN CHARACTER STRING
*
BEGCHAR  MTW,1    FLDFLG            SET CHAR FIELD IN PROGRESS
         B        GETCHAR
*
*  PROCESS HEX FIELD
*
HEXFLD   CI,R12   ''''
         BNE      HEXFLD2           NOT END
FLDEND   LI,R12   0
         STW,R12  FLDFLG            SIGNAL END OF SPECIAL FIELD
         B        GETCHAR
HEXFLD2  LI,R4    0
         MTW,-1   INPOS             BACK OVER CHAR JUST GOTTEN
         B        BEGHEX5           GET AND COMBINE 2 DIGITS
*
*  PROCESS CHARACTER FIELD
*
CHARFLD  CI,R12   ''''
         BNE      GETOK1            NOT END
         CI,R13   ''''              IS IT TWO IN A ROW
         BNE      FLDEND            NO - END OF FIELD
         BAL,R15  NXTCHAR           YES - SWALLOW THE SECOND ONE
         B        GETCHAR
*
*  GET NEXT CHAR IN R12, ONE AFTER IN R13
*
NXTCHAR  LI,R12   0                 ZAP IN CASE NO
         LI,R13   0                   CHARS IN BUFFER
         LW,R3    INPOS
         CW,R3    INCNT
         BG       NXTCH4            NO MORE
         MTW,1    INPOS             INCR POINTER TO NEXT CHAR
         LB,R12   INBUF,R3
         AI,R3    1
         CW,R3    INCNT             IS THERE ANOTHER
         BG       NXTCH2            NO
         LB,R13   INBUF,R3
         LCI      0
         B        *R15
NXTCH2   LCI      1
         B        *R15
NXTCH4   LCI      4
         B        *R15
         TITLE    '****  FLAG ERRORS  ****'
         SPACE    2
ERROR2   LW,R3    ENDFLD            POINT TO END OF LAST FIELD
         B        ERROR1
ERRORB   LW,R3    BEGFLD            POINT TO BEGINNING IF FIELD
         B        ERROR1
ERROR    LW,R3    INPOS             POINT TO CURRENT POSITION
         AI,R3    -1
ERROR1   PUSH     R11
         BAL,R11  ERRMARK           PRINT ERROR MARKER
         PULL     R11
ERROR3   BAL,R15  PRINT
ERROR4   BAL,R11  GETFIELD          FLUSH REMAINING INPUT
         BCR,4    ERROR4
         LC       J:JIT
         BCR,12   ERROR5            BATCH - ABORT
         BCS,4    RDLOOP            GHOST - TRY AGAIN
         MTW,0    M:SIFLG
         BEZ      RDLOOP            ONLINE TRY AGAIN IF M:SI TERMIANL
ERROR5   LI,R14   MERRXIT
         BAL,R15  PRINT
         M:XXX
         SPACE    2
ERRMARK  PUSH     R10
         LW,R1    R3
         AI,R1    1                 INDEX OF MARKER
         LI,R4    BA(M%)
         BAL,R10  PUTMESC           PUT IN MARKER
         BAL,R15  DUMPBUF
         PULL     R10
         B        *R11
         SPACE    2
ERRMSG   LB,R2    R10               MAJOR CODE
         SLS,R2   8
         SLS,R10  -17
         AND,R10  M7
         OR,R2    R10               COMBINE MAJOR AND SUB CODES
         STW,R2   KEY
         MTB,3    KEY               SET KEYM
         M:OPEN   F:ERR,(FILE,'ERRMSG',':SYS'),IN,;
                    (ABN,ERRABN),(ERR,ERRABN)
         M:READ   F:ERR,(BUF,INBUF),(SIZE,INBUFSIZ),(BTD,1),;
                    (KEY,KEY),(ERR,ERRABN),(ABN,ERRABN)
         LW,R2    F:ERR+4
         SLS,R2   -17               # BYTES READ
         STB,R2   INBUF             MAKE MESSAGE TEXTC
         LI,R14   INBUF
         BAL,R15  PRINT
ERRMX    M:CLOSE  F:ERR,(ERR,ERRMX1),(ABN,ERRMX1)
ERRMX1   B        *R11
*
ERRABN   LI,R2    0
         STB,R2   KEY               ZAP TEXTC COUNT
         BUILD    (TEXT,' **** I/O ERROR '),(HEX,*KEY),(DUMPBUF)
         B        ERRMX
         TITLE    '****  READ  ****'
         SPACE    2
*  NAME:           READ
*
*  CALL:           BAL,R11
*
*  OUTPUT:         RECORD IN INBUF, BYTE COUNT IN INCNT, INDEX OF
*                  NEXT BYTE TO ACCESS IN INPOS.
*                  CC = 0  NO ERROR
*                     = 1  EOF
*
         SPACE    1
READ     LI,R3    1
         STW,R3   INPOS             NEXT CHAR POSITION
         LI,R3    0
         STW,R3   INCNT             NOTHING READ YET
READ1    M:READ   M:SI,(BUF,INBUF),(SIZE,INBUFSIZ),(BTD,1),;
                    (ERR,SIABN),(ABN,SIABN)
         LH,R4    M:SI+4
         SLS,R4   -1                # BYTES READ
         AI,R4    0
         BEZ      READ1
         LB,R3    INBUF,R4          LAST CHAR READ
         CI,R3    X'40'
         BGE      %+2
         AI,R4    -1                SCRUB ACTIVATION CHAR
*
         LI,R3    PC
         STB,R3   INBUF
         LC       J:JIT
         BCR,8    READ10            NOT ONLINE
         LI,R3    X'F'
         AND,R3   M:SI
         CI,R3    3
         BNE      ECHOIN            M:SI NOT ASSIGNED TO DEVICE
         LI,R3    X'3F00'
         AND,R3   M:SI+1
         CI,R3    X'1000'
         BE       READ10            M:SI ASSIGNED TO TTY
ECHOIN   LW,R3    R4                SAVE BYTE COUNT
         AI,R3    2                 INCLUDE PROMPT AND VFC
         M:WRITE  M:LO,(BUF,INBUF-1),(SIZE,*R3),(BTD,3),WAIT
         MTW,1    M:SIFLG
READ10   STW,R4   INCNT
         LCI      0
         B        *R11
*
SIABN    LB,R3    R10
         CI,R3    5
         BE       RDEOF
         CI,R3    6
         BE       RDEOF
         PUSH     R10
         LI,R14   MSIERR
         BAL,R15  PRINT
         PULL     R10
         BAL,R11  ERRMSG
         M:XXX
RDEOF    LCI      1
         B        *R11
         TITLE    '****  HEX2BIN  ****'
         SPACE    2
*D*  NAME:         HEX2BIN
*D*
*D*  REGISTERS:    R3, R4, R12, R13, R14 VOLATILE
*D*
*D*  CALL:         BAL,R15
*D*                RETURN SKIPPING IF NO ERROR
*D*
*D*  INPUT:        R12, R13 = EBCDIC, LEFT JUSTIFIED
*D*
*D*  OUTPUT:       R4 = BINARY NUMBER
*D*
*D*  DESCRIPTION:  CONVERT TEXT EBCDIC HEX NUMBER TO BINARY.
*D*                CONVERSION PROCEEDS FROM LEFT TO RIGHT IN R12, R13,
*D*                TERMINATING WITH FIRST ZERO OR BLANK BYTE.
*D*                IF ERROR ENCOUNTERED, RETURNS TO BAL+1 WITH
*D*                ADDRESS OF ERROR MESSAGE IN R14.
         SPACE    1
HEX2BIN  LI,R4    0
         AI,R15   1                 ASSUME NO ERRORS
HEX2B2   LB,R3    R12               NEXT BYTE TO CONVERT
         CI,R3    X'BF'
         BAZ      *R15              ZERO OR BLANK - DONE
         CLM,R3   DECNUM
         BCS,9    HEX2B6            NOT 0-9
         AI,R3    -'0'              CONVERT TO BINARY
HEX2B4   SLS,R4   4
         AW,R4    R3                ADD TO TOTAL
         SLD,R12  8                 SHIFT OFF DIGIT
         B        HEX2B2
*
HEX2B6   CLM,R3   HEXNUM
         BCS,9    HEX2B8            NOT A-F
         AI,R3    10-'A'            CONVERT TO BINARY
         B        HEX2B4
*
HEX2B8   LI,R14   MBADHEX           BAD HEX DIGIT
         AI,R15   -1
         B        *R15              ERROR EXIT
         TITLE    '****  DEC2BIN  ****'
         SPACE    2
*D*  NAME:         DEC2BIN
*D*
*D*  REGISTERS:    R3, R5, R12, R13, R14 VOLATILE
*D*
*D*  CALL:         BAL,R15
*D*                RETURN SKIPPING IF NO ERROR
*D*
*D*  INPUT:        R12, R13 = EBCDIC, LEFT JUSTIFIED
*D*
*D*  OUTPUT:       R5 = BINARY NUMBER
*D*
*D*  DESCRIPTION:  CONVERT EBCDIC DECIMAL NUMBER TO BINARY.
*D*                CONVERSION PROCEEDS FROM LEFT TO RIGHT IN R12, R13,
*D*                TERMINATING WITH FIRST ZERO OR BLANK BYTE.
*D*                IF ERROR ENCOUNTERED, RETURNS TO BAL+1 WITH
*D*                ADDRESS OF ERROR MESSAGE IN R14.
         SPACE    1
DEC2BIN  LI,R5    0
         AI,R15   1                 ASSUME NO ERRORS
DEC2B2   LB,R3    R12               GET NEXT CHAR
         CI,R3    X'BF'
         BAZ      *R15              ZERO OR BLANK - DONE
         CLM,R3   DECNUM
         BCS,9    DEC2B8            ILLEGAL CHAR
         AI,R3    -'0'
         MI,R5    10
         AW,R5    R3
         SLD,R12  8
         B        DEC2B2
*
DEC2B8   LI,R14   MBADDEC           BAD DECIMAL DIGIT
         AI,R15   -1
         B        *R15              ERROR EXIT
         TITLE    '****  BIN2HEX / BIN2DEC  ****'
         SPACE    2
*D*  NAME:         BIN2HEX
*D*  ENTRY:        BIN2DEC
*D*
*D*  REGISTERS:    R2, R3, R5 VOLATILE
*D*
*D*  CALL:         BAL,R15
*D*
*D*  INPUT:        R2 = BINARY NUMBER (BIN2HEX)
*D*                R3 = BINARY NUMBER (BIN2DEC)
*D*
*D*  OUTPUT:       R12, R13 = EBCDIC LEFT JUSTIFIED, TRAILING BLANKS
*D*                R5 = # NON-BLANK CHARACTERS IN R12, R13
*D*
*D*  DESCRIPTION:  THE BINARY NUMBER IS CONVERTED TO EBCDIC
*D*                HEXADECIMAL (BIN2HEX) OR DECIMAL (BIN2DEC).
         SPACE    1
BIN2HEX  LI,R5    0                 # CHARS PROCESSED
         LW,R12   BLANKS
         LW,R13   BLANKS
BIN2H10  SLD,R12  -8
         SLD,R2   -4
         SLS,R3   -28               NEXT HEX DIGIT
         LB,R3    CNVRT,R3          CONVERT TO EBCDIC
         STB,R3   R12
         AI,R5    1
         AI,R2    0
         BNEZ     BIN2H10           NOT DONE YET
         B        *R15
         SPACE    1
BIN2DEC  LI,R5    0                 # CHARS PROCESSED
         LW,R12   BLANKS
         LW,R13   BLANKS
BIN2D10  LI,R2    0
         DW,R2    =10
         SLD,R12  -8
         LB,R2    CNVRT,R2          CONVERT REMAINDER TO EBCDIC
         STB,R2   R12
         AI,R5    1
         AI,R3    0
         BNEZ     BIN2D10           NOT DONE YET
         B        *R15
         TITLE    '****  MOVTXT, MOVTXTC  ****'
         SPACE    2
*D*  NAME:         MOVTXTC
*D*  ENTRY:        MOVTXT
*D*
*D*  REGISTERS:    R4, R5 VOLATILE
*D*
*D*  CALL:         BAL,R10
*D*
*D*  INPUT:        R4 = BA OF TEXT STRING
*D*                R5 = # BYTES (MOVTXT ONLY)
*D*
*D*  OUTPUT:       THE STRING IS MOVED TO NEXT POSITION IN PRINT BUFFER
*D*
*D*  DESCRIPTION:  MOVE TEXTC (MOVTXTC) OR TEXT (MOVTXT) STRING TO
*D*                THE PRINT BUFFER.
         SPACE    1
MOVTXTC  LB,R5    0,R4              TEXTC COUNT
         AI,R4    1                 POINT PAST COUNT
*
MOVTXT   SCS,R5   -8                POSITION BYTE COUNT FOR MBS
         OR,R5    PRPOS             ADD DESTINATION BYTE ADDR
         MBS,R4   0
         STW,R5   PRPOS             NEW DESTINATION
         B        *R10
         TITLE    '****  PUTMES, PUTMESC  ****'
         SPACE    2
*D*  NAME:         PUTMESC
*D*  ENTRY:        PUTMES
*D*
*D*  REGISTERS:    R1, R4, R5 VOLATILE
*D*
*D*  CALL:         BAL,R10
*D*
*D*  INPUT:        R1 = COLUMN NUMBER
*D*                R4 = BYTE ADDRESS OF TEXT OR TEXTC
*D*                R5 = BYTE COUNT (PUTMES ONLY)
*D*
*D*  DESCRIPTION:  PLACE TEXTC (PUTMESC) OR TEXT (PUTMES) STRING
*D*                AT THE INDICATED COLUMN IN PRINT BUFFER.  IF
*D*                SPECIFIED COLUMN IS BEYOND CURRENT POSITION,
*D*                BLANKS ARE MOVED IN, IF IT IS BEYOND CURRENT
*D*                POSITION, THE MESSAGE OVERWRITES PREVIOUS STRINGS.
         SPACE    1
PUTMES   LI,R15   MOVTXT
         B        %+2
PUTMESC  LI,R15   MOVTXTC
         AI,R1    BA(PRBUF)
PUTM05   CW,R1    PRPOS
         BLE      PUTM10            INSERT OVER EXISTING TEXT
         SW,R1    PRPOS             # BYTES TO BLANK
         SCS,R1   -8
         OR,R1    PRPOS             ADD BA OF DESTINATION
         MBS,0    BA(BLANKS)        MOVE BLANKS
PUTM10   STW,R1   PRPOS             SAVE NEW POSTION
         B        *R15              MOVE THE TEXT
         TITLE    '****  PUTHEXL, PUTHEXR, PUTDECL, PUTDECR  ****'
         SPACE    2
*D*  NAME:         PUTDECL
*D*  ENTRY:        PUTDECR
*D*  ENTRY:        PUTHEXL
*D*  ENTRY:        PUTHEXR
*D*
*D*  REGISTERS:    R1, R2, R3, R4, R5, R15 VOLATILE
*D*
*D*  CALL:         BAL,R10
*D*
*D*  INPUT:        R1 = COLUMN NUMBER
*D*                R2 = BINARY NUMBER (PUTHEXL, PUTHEXR)
*D*                R3 = BINARY NUMBER (PUTDECL, PUTDECR)
*D*
*D*  DESCRIPTION:  PLACE CONVERTED BINARY NUMBER AT A SPECIFIED
*D*                COLUMN NUMBER IN PRINT BUFFER.  COLUMN MAY BE
*D*                EITHER A BEGINNING COLUMN (PUTHEXL, PUTDECL)
*D*                FOR LEFT JUSTIFICATION, OR ENDING COLUMN
*D*                (PUTHEXR, PUTDECR) FOR RIGHT JUSTIFICATION.
*D*                BINARY NUMBER MAY BE CONVERTED TO EITHER
*D*                DECIMAL (PUTDECR/PUTDECL) OR HEX (PUTHEXL/PUTHEXR).
         SPACE    1
PUTDECL  BAL,R15  BIN2DEC           DECIMAL, LEFT JUSTIFIED
         B        PUTHEX2
PUTDECR  BAL,R15  BIN2DEC
         B        PUTHEX4
*
PUTHEXL  BAL,R15  BIN2HEX           HEX, LEFT JUSTIFIED
PUTHEX2  LI,R4    R12*4             BA OF TEXT
         B        PUTMES
PUTHEXR  BAL,R15  BIN2HEX           HEX, RIGHT JUSTIFIED
PUTHEX4  SW,R1    R5                POINT TO START
         AI,R1    1
         B        PUTHEX2
         TITLE    '****  MOVDEC, MOVHEX  ****'
         SPACE    2
*D*  NAME:         MOVHEX
*D*  ENTRY:        MOVDEC
*D*
*D*  REGISTERS:    R2, R3, R4, R5, R12, R13 VOLATILE
*D*
*D*  CALL:         BAL,R10
*D*
*D*  INPUT:        R2 = BINARY NUMBER (MOVHEX)
*D*                R3 = BINARY NUMBER (MOVDEC)
*D*
*D*  DESCRIPTION:  CONVERTS THE BINARY NUMBER TO EITHER EBCDIC
*D*                DECIMAL (MOVDEC) OR HEXADECIMAL (MOVHEX) AND
*D*                PUTS THE TEXT IN THE PRINT BUFFER.  IS THE SAME
*D*                AS CALLING BIN2DEC/BIN2HEX FOLLOWED BY MOVTXT.
         SPACE    1
MOVDEC   BAL,R15  BIN2DEC
MOVDEC2  LI,R4    R12*4             BA OF TEXT
         B        MOVTXT
*
MOVHEX   BAL,R15  BIN2HEX
         B        MOVDEC2
         TITLE    '****  DUMPBUF, INITBUF  ****'
         SPACE    2
*D*  NAME:         DUMPBUF
*D*  ENTRY:        PRINT
*D*  ENTRY:        INITBUF
*D*
*D*  REGISTERS:    ALL VOLATILE
*D*
*D*  CALL:         BAL,R15
*D*
*D*  DESCRIPTION:  DUMPBUF - DUMPS PRINT BUFFER TO M:LO
*D*                PRINT - PRINT TEXTC MESSAGE (R14 = MESSAGE ADDR)
*D*                INITBUF - REINITIALIZE BUFFER POINTERS.  AUTOMATICALLY
*D*                CALLED AT END OF DUMPBUF.
         SPACE    1
DUMPBUF  LW,R10   PRPOS             BA OF NEXT AVAIL BYTE
         AI,R10   -BA(PRBUF)        # BYTES TO WRITE
         BEZ      *R15              EXIT IF NOTHING TO WRITE
         M:WRITE  M:LO,(BUF,PRBUF),(SIZE,*R10),(BTD,0),WAIT
INITBUF  LI,R10   BA(PRBUF)         NEXT AVAILABLE BYTE
         STW,R10  PRPOS
         B        *R15
         SPACE    2
PRINT    LB,R10   *R14
         M:WRITE  M:LO,(BUF,*R14),(SIZE,*R10),(BTD,1),WAIT
         B        *R15
         TITLE    '****  TABLE DRIVEN OUTPUT  ****'
         SPACE    2
*D*  NAME:         BUILD
*D*
*D*  REGISTERS:    ALL VOLATILE
*D*
*D*  CALL:         BUILD PROC
*D*
*D*  DESCRIPTION:  PROC TO BUILD MESSAGES IN OUTPUT BUFFER.
*D*                PROC CALL IS OF THE FORM:
*D*                   BUILD    (OPT,ADDR,COL),(OPT,ADDR,COL), ...
*D*                OPTIONS ARE:
*D*                  TEXT:  ADDR MAY BE ADDRESS OF TEXTC OR A
*D*                         TEXT STRING IN QUOTES
*D*                  HEX, DEC:  ADDR IS VALUE TO CONVERT, OR IF
*D*                      *ADDR IS LOC CONTAINING VALUE.  VALUE IS
*D*                      PUT IN LEFT JUSTIFIED.
*D*                  RHEX, RDEC:  SAME AS DEC/HEX BUT RIGHT JUSTIFIED.
*D*                  SPACE:  SPACE OVER ADDR # SPACES.
*D*                  DUMPBUF, DUMPB, DUMPECHO:  CALL THE INDICATED ROUTINE.
*D*                IF COL IS SPECIFIED, IT IS COLUMN NUMBER TO PLACE
*D*                THE INDICATED ITEM.  IF NOT SPECIFIED, ITEM IS
*D*                PLACED AT NEXT LOCATION IN PRINT BUFFER.
*D*                THE ,E AND ,L OPTIONS AFTER PROC NAME MAY BE USED
*D*                TO GENERATE ONLY ROUTINE CALL OR ONLY TABLE,
*D*                RESPECTIVELY, AS IN SYSTEM BPM PROCS.
*D*
*D*                GENERATED TABLE:
*D*                  BIT 0  -  SET IF THIS IS LAST ENTRY IN CHAIN.
*D*                  BIT 1-7  -  COLUMN # (ZERO IF NONE)
*D*                  BIT 8-11  -  KEYWORD TYPE
*D*                  BIT 12  -  SET IF ADDR FIELD IS INDIRECT
*D*                  BIT 13-31  -  ADDR
         SPACE    1
TBLDMP   STW,R0   TBLRET            SAVE RETURN ADDRESS
         LCI      15
         STM,R1   TBLREGS+1         SAVE THE OTHER REGISTERS
         LW,R6    *TBLRET           GET TABLE ADDRESS
         MTW,1    TBLRET            INCR PAST TABLE POINTER
TBLDMP1  LW,R2    0,R6              GET NEXT TABLE ENTRY
         LB,R1    R2                COLUMN NUMBER
         LW,R5    0,R6
         SCS,R5   12                RIGHT JUSTIFY AND
         AND,R5   M4                  MASK ROUTINE #
         CW,R2    Y8
         AND,R2   M19               MASK OFF ADDR
         BAZ      %+2               NOT INDIRECT
         LW,R2    0,R2              GET INDIRECT
         LW,R3    R2                MOVE IN CASE DEC
         LW,R4    R2                MOVE IN CASE TEXT
         SLS,R4   2
         LI,R10   NXTTBL            RETURN
         LI,R15   NXTTBL            RETURN
         CI,R5    DUMP#
         BL       TBLDMP2           NOT DUMP COMMAND
         CI,R2    X'FF'
         BAZ      TBLDMP2           NOTHING SPECIFIED
         STB,R2   PRBUF             PUT IN VFC CHAR
TBLDMP2  AND,R1   M7                MASK COL #
         BNEZ     TVEC1-1,R5        COLUMN IS SPECIFIED
         B        %,R5              NO COLUMN
         B        MOVTXTC           TEXT
         B        MOVHEX            HEX
         B        MOVDEC            DEC
         B        MOVHEX            RHEX
         B        MOVDEC            RDEC
         B        SPACE             SPACE
         B        DUMPBUF           DUMPBUF
*
TVEC1    B        PUTMESC           TEXT
         B        PUTHEXL           HEX
         B        PUTDECL           DEC
         B        PUTHEXR           RHEX
         B        PUTDECR           RDEC
         B        SPACE             SPACE
DUMP#    EQU      %-TVEC1
         B        DUMPBUF           DUMPBUF
*
SPACE    LW,R1    R2                MOVE # SPACES
         AW,R1    PRPOS
         B        PUTM05
*
NXTTBL   LW,R2    0,R6              LAST TABLE ENTRY
         AI,R6    1                 POINT TO NEXT
         CW,R2    Y0008
         BAZ      TBLDMP1           NOT DONE YET
         LCI      0
         LM,R0    TBLREGS           RESTORE REGISTERS
         B        *TBLRET           RETURN
         TITLE    '****  PRKEY  ****'
         SPACE    2
*  NAME:           PRKEY
*
*  CALL:           BAL,R11
*
*  INPUT:          R4 = BA OF TEXTC KEY
*
*  DESCRIPTION:    THE KEY IS MOVED TO THE PRINT BUFFER.  IF THE
*                  KEY CONTAINS ANY NON-PRINTING CHARACTERS, A
*                  HEX TRANSLATION OF THE KEY IS PLACED IN THE
*                  PRINT BUFFER.
         SPACE    1
PRKEY    STW,R4   TEMP              SAVE ADDRESS OF KEY
         LI,R4    BA(MSPACE)
         BAL,R10  MOVTXTC           PUT IN A SPACE
*
         LW,R4    TEMP
         LW,R1    PRPOS             NEXT AVAIL BYTE IN PRINT BUFFER
         LB,R7    0,R4              # BYTES TO MOVE
PRK1     AI,R4    1                 ADVANCE TO NEXT SOURCE BYTE
         LB,R8    0,R4
         BNEZ     %+2               GOT SOMETHING
         LI,R8    X'40'             CHANGE - COC STOPS ON A ZERO
         STB,R8   0,R1              PUT IN PRINT BUFFER
         AI,R1    1
         BDR,R7   PRK1
         STW,R1   PRPOS
*
         LI,R4    BA(XTBL)
         LW,R5    TEMP
         MTB,1    R4                MASK FOR TTBS
         LB,R6    0,R5
         STB,R6   R5
         AI,R5    1                 SKIP TEXTC COUNT
         TTBS,R4  0
         BCR,1    *R11              BR IF ALL PRINTABLE
         LI,R4    BA(MHEX1)
         BAL,R10  MOVTXTC           '  (X'''
         LW,R1    PRPOS
         LW,R6    TEMP              ADDRESS OF KEY
         LB,R4    0,R6              # BYTES
PRK2     AI,R6    1                 INCR TO NEXT CHAR
         LB,R2    0,R6              GET NEXT CHAR
         BAL,R15  BIN2HEX           CONVERT TO EBCDIC
         CI,R5    1
         BNE      %+3
         SLS,R12  -8                INSERT LEADING ZERO
         OR,R12   =X'F0000000'
         SCS,R12  8
         STB,R12  0,R1              PUT IN PRBUF
         AI,R1    1
         SCS,R12  8
         STB,R12  0,R1              NEXT ONE TOO
         AI,R1    1
         CI,R1    BA(PRBUF)+33*4
         BGE      PRK4              BEYOND END OF BUFFER
         BDR,R4   PRK2
PRK4     STW,R1   PRPOS
         LI,R4    BA(MHEX2)         ')'''
         LW,R10   R11
         B        MOVTXTC
         TITLE    '****  INTERRUPT ROUTINE  ****'
         SPACE    2
INTADDR  MTW,1    BRKFLAG
         CAL1,8   MODEFPT           RESET # BREAKS RECEIVED
         M:TRTN
         TITLE    '****  HELP ROUTINE  ****'
         SPACE    2
HELP     LI,R14   MHELP
HLP10    MTW,0    BRKFLAG
         BNEZ     HLP20             STOP IF BREAK KEY PRESSED
         BAL,R15  PRINT
         AI,R10   4
         SLS,R10  -2
         AW,R14   R10               ADVANCE TO NEXT TEXTC
         CI,R14   MHELPEND
         BL       HLP10
HLP20    B        RDLOOP
         TITLE    '****  MESSAGES  ****'
         SPACE    2
MDTERR   TEXTC    ' DEVICE TYPE NOT 2 CHARS'
MMISFN   TEXTC    ' MISSING FILE NAME'
MMISSN   TEXTC    ' MISSING SERIAL #'
MSNBAD   TEXTC    ' SERIAL # > 4 CHARS'
MNODEV   TEXTC    ' MISSING DEVICE TYPE'
MFNBAD   TEXTC    ' FILE NAME > 31 CHARS'
MACCTBAD TEXTC    ' ACCOUNT > 8 CHARS'
MPASSBAD TEXTC    ' PASSWORD MISSING OR > 8 CHARS'
MMISFA   TEXTC    ' FILE NAME AND/OR ACCOUNT MUST BE SPECIFIED'
MUNEOF   TEXTC    ' UNEXPECTED EOF ON M:SI AFTER CONTINUATION SPECIFIED'
MUTFLD   TEXTC    ' UNTERMINATED FIELD'
MERRXIT  TEXTC    ' ..ABORTING'
MSIERR   TEXTC    ' I/O ERROR ON M:SI'
M%       TEXTC    '%'
MUNKCOM  TEXTC    ' UNKNOWN COMMAND'
MBADHEX  TEXTC    ' ILLEGAL HEX DIGIT'
MBADDEC  TEXTC    ' ILLEGAL DECIMAL DIGIT'
MNONAME  TEXTC    ' MUST SPECIFY FILE NAME WITH RENAME COMMAND'
MSPACE   TEXTC    ' '
MHEX1    TEXTC    '  (X'''
MHEX2    TEXTC    ')'''
MNOVERB  TEXTC    ' REQUIRED VERB MISSING'
MUNKOPT  TEXTC    ' UNKNOWN OPTION'
MQLIST   TEXTC    ' QUALIFIER ILLEGAL WITH LIST COMMAND'
MQPASS   TEXTC    ' QUALIFIER ILLEGAL WITH PASSWORD OPTION'
MFLDLNG  TEXTC    ' FIELD TOO LONG'
MTBLFULL TEXTC    ' TOO MANY OPTIONS - INTERNAL TABLE OVERFLOW'
MMISTERM TEXTC    ' MISSING TERMINATOR'
MNOOPT   TEXTC    ' OPTIONS MUST BE SPECIFIED WITH MODIFY COMMAND'
*
*  TEXT FOR HELP COMMAND
*
MHELP    EQU      %
 TEXTC 'ACOMMANDS (ONLY FIRST CHAR NECESSARY):'
 TEXTC '   RENAME  FID  TO  NAME'
 TEXTC '   MODIFY  FID (OPT, ... ,OPT)'
 TEXTC '   LIST  FID  (OPT, ... ,OPT)'
 TEXTC '   END'
 TEXTC '   X'
 TEXTC '   HELP'
 TEXTC '   ?'
 TEXTC 'AFID IS FILE NAME AND/OR ACCOUNT IN PCL FORMAT.'
 TEXTC ' OPT IS:    XX(SUBOPT, ... ,SUBOPT)'
 TEXTC '   WHERE XX IS ANY OF:  PA,RD,WR,EX,UN.'
 TEXTC '   + OR - MAY PRECEED EACH XX TO ADD TO OR REMOVE FROM'
 TEXTC '   EXISTING ATTRIBUTES.  IF NEITHER SPECIFIED, EXISTING'
 TEXTC '   ATTRIBUTES ARE REMOVED BEFORE ADDING NEW ONES.'
 TEXTC '   SUBOPT IS AN ACCOUNT, UNDER NAME OR PASSWORD.'
 TEXTC ' IF NO OPTIONS ON LIST COMMAND, ALL FILES LISTED.'
 TEXTC ' OTHERWISE, ONLY THOSE FILES THAT HAVE ATTRIBUTES'
 TEXTC ' MATCHING SPECIFIED OPTIONS ARE LISTED.'
 TEXTC 'ASEMI-COLON SPECIFIES CONTINUATION TO NEXT CARD.'
 TEXTC ' BREAK KEY HALTS CURRENT OPERATION.'
 TEXTC ' '
MHELPEND EQU      %
         TITLE    '****  STATIC DATA  ****'
         SPACE    2
M16      DATA     X'FFFF'
M19      DATA     X'7FFFF'
M4       DATA     X'F'
M7       DATA     X'3F'
M8       DATA     X'FF'
Y8       DATA     X'80000000'
Y0008    DATA     X'00080000'
Y002     DATA     X'00200000'
*
DTAB1    TEXTC    '# /(),'          DELIMITER TABLE
DTAB2    TEXTC    ' ,()'
DTAB3    TEXTC    ' ('
*
OPTS     DATA,2   0,'UN','EX','WR','RD','PA'
#OPTS    EQU      HA(%)-HA(OPTS)-1
         BOUND    4
OPTTYP   DATA,1   0,X'15',X'14',6,5,3
         BOUND    4
*
CNVRT    TEXT     '0123456789ABCDEF'
         BOUND    8
DECNUM   DATA     '0','9'
HEXNUM   DATA     'A','F'
ALL      DATA     'ALL ','NONE'
NONE     EQU      ALL+1
DOUBLEONE DATA    1,1
BLANKS   TEXT     '    '
*
MODEFPT  GEN,8,3,21  6,1,0
         PZE      *0
         DATA     3                 RESET # COC BREAKS RECEIVED
*
PLATFPT  GEN,8,4,20  6,6,0
         SPACE    4
*  TABLE FOR DETECTING NON-PRINTING CHARACTERS
         SPACE    2
XGEN     CNAME
         PROC
         LOCAL    LEGC,I
XTBL     EQU      %
         DO1      256/4
         DATA     X'01010101'
LEGC     SET      S:UT('ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789',;
                    '.(+&%*);,-/%:#@''=<>')
I        DO       NUM(LEGC)
         ORG,1    BA(XTBL)+LEGC(I)
         DATA,1   0
         FIN
         ORG      XTBL+(256/4)
         PEND
         SPACE    2
         XGEN
         TITLE    '****  DYNAMIC DATA  ****'
         SPACE    2
         USECT    DATA
         BOUND    8
TSTACKSZ EQU      80
TSTACK   DATA     %+1
         DATA,2   TSTACKSZ,0
         DO1      TSTACKSZ
         DATA     X'BAD'
INBUFSIZ EQU      81
         DATA     'A'               VFC FOR PRINTING INBUF
INBUF    RES      (INBUFSIZ+3)/4
*
FBUFSIZ  EQU      INBUFSIZ-1
FBUF     RES      (FBUFSIZ+3)/4
FBUF1    RES      (FBUFSIZ+3)/4
SBUF     RES      (FBUFSIZ+3)/4
SBUF1    RES      (FBUFSIZ+3)/4
*
PRBUF    RES      34
PRPOS    DATA     BA(PRBUF)
*
INCNT    RES      1
INPOS    RES      1
BEGFLD   RES      1
FLDFLG   DATA     0
ENDFLD   DATA     0
GETNCHK  DATA     0
M:SIFLG  DATA     0
FNRET    RES      1
FILPOS   RES      1
MEINAME  DATA     M:EI+X'17'
NXTF     RES      1
CALFLAG  RES      1
         BOUND    8
TCBSTK   DATA     0,0
BUSYFLG  DATA     0
PLATEN   DATA     100
RDALL    RES      1
LDELIM   RES      1
FITMOD   RES      1
CLSSIZE  RES      1
BRKFLAG  RES      1
TEMP     RES      1
DTBL     RES      1
KEY      RES      1
TBLRET   RES      1
QUALIF   RES      1
OPTVLP   RES      1
SUBSIZE  RES      1
SCANRET  RES      1
CURLOC   RES      1
COUNT    RES      1
TBLREGS  RES      16
FPARAM   RES      90
*
#SUBLOC  EQU      200
SUBLOC   RES      #SUBLOC+1
*
*  OPEN FPT
*
OPNFPT   GEN,8,24  X'14',M:EI
         DATA     X'C1240009'
         DATA     OPNERR,OPNERR
         DATA     4                 MODE = INOUT
         DATA     FPARAM
DEVTYP   RES      1
         DATA,1   1,0,8,8
FNAME    RES      8
         DATA,1   2,0,0,2
ACCT     RES      2
         DATA,1   3,0,2,2
PASS     RES      2
         DATA,1   7,1,0,1
SN       RES      1
*
TSTFPT   GEN,8,7,17  X'14',4,M:EI
         DATA     X'C0200009'
         DATA     OPNERR,OPNERR
         DATA     FPARAM
TSTVLP   RES      3
*
*  CLOSE FPT
*
CLSFPT   GEN,8,24  X'15',M:EI
         DATA     X'100'
#CLSVLP  EQU      50
CLSVLP   RES      #CLSVLP
         SPACE    4
*  PATCH AREA
         SPACE    2
PT       EQU      %
         DO1      40
         DATA     0
         TITLE    '****  COMMAND PROCS  ****'
         SPACE    2
COMTXT   CSECT    1
COMLOC   CSECT    1
COMFLAG  CSECT    0
         SPACE    2
COMMAND  CNAME    0,COMTXT,COMLOC,COMFLAG
         PROC
         LOCAL    R
         USECT    NAME(2)
         TEXTC    AF(1)
         DO1      S:NUMC(AF(1))<4
         TEXT     ' '
         ERROR,7,S:NUMC(AF(1))>7 'AF(1) > 7 CHARS'
*
R        SET      S:KEYS(3,*LOC,FLAG)
*
*  'LOC'
*
         USECT    NAME(3)
         B        AF(R(3),2)
*
*  'FLAG'
*
         USECT    NAME(4)
         DO       R(4)<=R(1)+1
AF(R(4),2) RES    1
         ELSE
         RES      1
         FIN
*
#COM     SET      #COM+1
         PEND
         SPACE    2
#COM     SET      0
         TITLE    '****  COMMAND TABLES  ****'
         SPACE    2
         COMMAND  'RENAME',(LOC,RENAME),(FLAG,RFLAG)
         COMMAND  'LIST',(LOC,LIST),(FLAG,LFLAG)
         COMMAND  'MODIFY',(LOC,MODIFY),(FLAG,MFLAG)
         COMMAND  'END',(LOC,EXIT)
         COMMAND  'X',(LOC,EXIT)
         COMMAND  'HELP',(LOC,HELP)
         COMMAND  '?',(LOC,HELP)
         TITLE    '****  DCBS  ****'
         SPACE    2
M:LO     DSECT    2
M:LO     M:DCB    (DEVICE,'ME'),(FILE,8),(ASN,DEVICE),;
                    (ERR,OPNERR),(ABN,OPNERR)
M:EI     DSECT    2
M:EI     M:DCB    (FILE,8),(SN,8),(PASS)
M:SI     DSECT    2
M:SI     M:DCB    (DEVICE,'ME'),(FILE,8),(SN,8),(ASN,DEVICE)
         USECT    P
         END      START
