         TITLE    'LABEL'
         SYSTEM   BPM
         SYSTEM   SIG7FDP
         DEF      START
         DEF      PLB,CSL
         DEF      INITPGM
         REF      M:LO,M:SI
*
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
SR1      EQU      8
R9       EQU      9
SR2      EQU      9
R10      EQU      10
SR3      EQU      10
R11      EQU      11
SR4      EQU      11
D1       EQU      12
D2       EQU      13
D3       EQU      14
D4       EQU      15
VSERMAX  EQU      25
K0       EQU      0
K1       EQU      1
K2       EQU      2
K3       EQU      3
K4       EQU      4
K5       EQU        5
K6       EQU      6
K7       EQU      7
K8       EQU      8
K10      EQU      10
K24      EQU      24
K65      EQU      65
K72      EQU      72
K73      EQU      73
K80      EQU      80
K95      EQU      95
KA       EQU      10
KNF0     EQU      -X'F0'
KN1      EQU      -1
KN2      EQU      -2
KBLANK   EQU      ' '
KLPAREN  EQU      '('
KRPAREN  EQU      ')'
KCOMMA   EQU      ','
KSCOLN   EQU      ';'
ERRCD1   EQU      1
ERRCD2   EQU      2
ERRCD3   EQU      3
ERRCD4   EQU      4
ERRCD5   EQU      5
ERRCD6   EQU      6
ERRCD7   EQU      7
ERRCD8   EQU      8
ERRCD9   EQU      9
         PAGE
F:TAPOT  DSECT    1
F:TAPOT  M:DCB    (DEVICE,'9T'),;
                  (OUT),;
                  (INSN)
         PAGE
F:TAPIN  DSECT    1
F:TAPIN  M:DCB    (DEVICE,'9T'),;
                  (IN),;
                  (INSN,'TPIN')
         PAGE
         CSECT    0
INITPGM  EQU      %
TMRK     TEXTC    '   TAPE MARK...'
NOLBLSW  DATA
         BOUND    8
NOLBL2   TEXT     'NO LABEL'
NOLBL1   TEXT     'NLBL'
TMRKCNT  DATA
RPRTCNT  DATA
*
LBLTBL   DATA       'XXXX'
         DATA       'NLBL'
         DATA       ':LBL'
         DATA       ':ACN'
         DATA       ':BOF'
         DATA       'HDR1'
         DATA       'HDR2'
         DATA       'EOF1'
         DATA       'EOF2'
         DATA       'EOV1'
         DATA       'EOV2'
VOL1T    RES
         DATA       'VOL1'
SAVR11   DATA
BLANKS   DATA     C'    '
PRTLBLSW DATA
PRTREC   GEN,8,24 83,'***'
CKVOL    DATA                       * INPUT FOR
RECEND   DATA     '*END'
         DATA     '    '
RECSIZE  DATA
DLMADR   GEN,8,24 NDELIM,BA(DELIMCHR)
*
DELIMCHR EQU      %
         DATA     '(), '
         DATA,1   '.'
NDELIM   EQU      BA(%)-BA(DELIMCHR)   NO. OF DELIM CHARACTERS
         BOUND    4
         RES,1    4908
         PAGE
         RES      ABSVAL(%)&1||1
VOL1     DATA     C'VOL1'
SERNO1   DATA     C'    '
SERNO2   DATA     C'    '
         DATA     C'    '
         DATA,16  C'                '
         DATA     C'    '
         DATA     C'    '
USERID   DATA     C'    '
         DATA     C'    '
         DATA,16  C'                '
         DATA,16  C'                '
HDR1     DATA,16  C'HDR1SCRATCH TAPE'
         DATA,12  '            '
         DATA,4   '0001'
         DATA,16  C'                '
         DATA,6   ' 00000'
         DATA,10  '          '
         DATA,16  C'                '
HDR2     DATA     C'HDR2'
         DATA,12  C'            '
         DATA,16  C'                '
         DATA,16  C'                '
         DATA,16  C'                '
         DATA,16  C'                '
         BOUND    8
VSERTBL  RES,8    25
VSERINDX DATA
VSERCNT  DATA
SSERNO   DATA
SSERCNT  DATA
SVOLSW   DATA
UIDDUPSW DATA
CPRTSW   DATA
         RES      1
         BOUND    8
         RES      -1
NXTREEL  TEXTC    'NEXT REEL: XXXXXXXX'
SERIALNO EQU      %-2
OPNOUT   GEN,8,24 20,F:TAPOT
         DATA     X'01000003'
         DATA     2                 OUTPUT
         DATA     X'7010101'
         TEXT     'TPOT'
NTAPSW   DATA
CCERRSW  DATA
CSL      DATA
CRDIN    RES      20                CCTL CARD INPUT AREA
PRTCRD   DATA     X'1F404040'
CERRMSG  RES      7                 CRD ERROR MESSAGE AREA
         BOUND    8
PLB      RES      6                 PARAMETER LIST BUFFER
ERRMTBL  DATA                       DUMMY ENTRY
         DATA     ERRM1
         DATA     ERRM2
         DATA     ERRM3
         DATA     ERRM4
         DATA     ERRM5
         DATA     ERRM6
         DATA     ERRM7
         DATA     ERRM8
         DATA     ERRM9
         DATA     ERRM0
ERRM0    TEXT     'BLP REQUIRES C0 PRIVILEGE'
ERRM1    TEXT     'EXPECTED LEFT PAREN MISSING '
ERRM2    TEXT     'ILLEGAL KEYWORD             '
ERRM3    TEXT     'EXPECTED RIGHT PAREN MISSING'
ERRM4    TEXT     'SYNTAX ERROR                '
ERRM5    TEXT     'SN LIMIT EXCEDED            '
ERRM6    TEXT     'ILLEGAL VALUE               '
ERRM7    TEXT     'CHAR STRING SIZE ERROR      '
ERRM8    TEXT     'DUPLICATE PARAMETER         '
ERRM9    TEXT     'EXPECTED COMMA MISSING      '
EMSG1    TEXTC    'CONTROL CARD ERROR, LABEL ABORTING'
*
KWTABLE  EQU      %-1
         TEXT     'NOLA'            NO LABEL
         TEXT     'PRIN'            PRINT LABELS
         TEXT     'MSN '            MULTIPLE SNS
         TEXT     'USER'            USER ID
         TEXT     'SN  '            SERIAL NUMBER
         TEXT     'BLP '
KWTBLCT  EQU      %-KWTABLE-1       NO. KEYWORD ENTRIES
*
KWJTABLE EQU      %-1
         B        LNOLABEL
         B        LPRTLBL
         B        LSVOLSER
         B        LUSERID
         B        LVOLSER
         B        LBLP
         TITLE    'COMMAND HANDLER'
LABELPROC CSECT   1
         DEF      LABELPROC
START    EQU      %
B0010    EQU      %
         BAL,R11  GETCRD
B0015    EQU      %
         BAL,SR4  GETCHAR
         CI,SR1   KLPAREN
         BNE      B0030
         BAL,R11  GETCHAR           GET KEYWORD
         BCS,8    AKWERR
         LW,R1    PLB
         LI,R2    KWTABLE           R2= ADDR KEYWORD TABLE
         LI,R3    KWTBLCT           R3= NO. KEYWORDS
         BAL,R11  KWLOOKUP
         B        KWJTABLE,R3       PROCESS KEYWORD PARAMETER
         TITLE    'PROCESSING'
CTLEND   EQU      %
         MTW,0    CCERRSW
         BNE      CTLEND2
         LW,R0    NOLBLSW           IS THERE ANYTHING TO DO
         OR,R0    VSERINDX
         OR,R0    SSERCNT
         OR,R0    PRTLBLSW
         BNEZ     B0400
CTLEND2  EQU      %
         M:PRINT  (MESS,EMSG1)
         M:EXIT
CTLEND4  EQU      %
         MTW,0    PRTLBLSW
         BNEZ     B0800             PRINT LABELS
         M:EXIT
         TITLE    'CHARACTER SCAN ROUTINE'
GETCHAR  EQU      %
         LI,R1    KBLANK
         LI,R3    -K24              BLANK PLB
         STB,R1   PLB+6,R3
         BIR,R3   %-1
         AI,R7    1                 TO NEXT INPUT CHAR
         B        GCHAR9-1          SEARCH FOR NONBLANK:
GCHAR2   EQU      %
         AI,R7    K1
GCHAR2A  EQU      %
         CI,R7    K73
         BE       GCHAR4            ALL DONE
         LB,SR1   *R6,R7            PICK UP NEXT CHARACTER
         CI,SR1   KSCOLN
         BE       GCHAR8
         CI,SR1   KBLANK
         BE       GCHAR9-1
         LW,R4    DLMADR            R4= BYTE ADDR OF DELIMITER LIST
         LB,R5    R4                R5= NO. OF DELIM CHARACTERS
GCHAR3   EQU      %
         CB,SR1   0,R4
         BE       GCHAREX
         AI,R4    K1
         BDR,R5   GCHAR3
         STB,SR1  PLB,R3            PUT IN PLB
         AI,R3    K1
         CI,R3    K24
         BNE      GCHAR2
GCHAR4   EQU      %
         LCI      K8                SYNTAX ERROR
         B        *R11
GCHAR8   EQU      %
         STW,R11  SAVR11            * GET CONTINUATION
         BAL,R11  GETCRD            * CARD AND
         LW,R11   SAVR11            * SKIP TO
         LI,SR1   KBLANK            * FIRST NON-BLANK CHAR
GCHAR9   EQU      %
         CB,SR1   *R6,R7            *
         BNE      GCHAR5            GT NE
         AI,R7    K1                *
         CI,R7    K73
         BE       GCHAR4
         B        GCHAR9            *
GCHAR5   CB,SR1   PLB               ANYTHING THERE YET
         BE       GCHAR2A           YUP
         LB,SR1   *R6,R7            GET THE CHARACTER
GCHAREX  EQU      %
         CI,R3    K0
         BE       GCHAR4
         STW,R3   CSL               STORE CHAR STRING LENGTH
         LCI      0
         B        *R11
         TITLE    'PROCEDURE'
B0400    EQU      %
         MTW,0    NOLBLSW           DO NOLBLS FIRST
         BNEZ     B0500
B0420    EQU      %
         MTW,0    SSERCNT           ANY SNS
         BNEZ     B0600             GET NEXT SERIAL NO.
         LW,R1    VSERCNT
         CW,R1    VSERINDX          CK FOR TABLE END
         BE       CTLEND4           ALL DONE
         MTW,1    VSERCNT
         LD,R2    VSERTBL,R1
B0430    EQU      %
         STD,R2   SERNO1
         STD,R2   SERIALNO
         M:TYPE   (MESS,NXTREEL)
         LI,R4    '0'
         LI,R5    2
         STB,R4   SERNO2,R5
B0470    EQU      %
         CAL1,1   OPNOUT
         LW,1     OPNOUT+2          IF INPUT, SET OUT
         BDR,1    %+4               OUT
         M:SYS
         MTH,2    F:TAPOT+1
         M:SLAVE
         M:WRITE  F:TAPOT,(BUF,VOL1),(SIZE,80)
         M:WRITE  F:TAPOT,(BUF,HDR1),(SIZE,80)
         M:WRITE  F:TAPOT,(BUF,HDR2),(SIZE,80)
         M:WEOF   F:TAPOT           WRITE TAPE MARK
         M:WEOF   F:TAPOT           WRITE TAPE MARK
         M:CLOSE  F:TAPOT,(SAVE),(REM)
         MTW,0    NOLBLSW
         BNEZ     B0500
         B        B0420
*
         PAGE
B0500    EQU      %
         MTW,-1   NOLBLSW
         BGEZ     B0510
         LW,1     VOL1T             RESTORE TEXT
         STW,1    VOL1
         B        B0420
B0510    EQU      %
         M:TYPE   (MESS,NXTREEL)
         B        B0470
*
*
B0600    EQU      %
         MTW,0    SSERCNT           CK NO. REELS FOE END
         BE       B0420
         LW,R2    BLANKS
         LI,R5    K6
         LW,D2    SSERNO
         BAL,R11  BINDEC            CONVERT BINARY TO DECIMAL
         MTW,-1   SSERCNT
         MTW,1    SSERNO
         B        B0430
         TITLE    'USERID COMMAND'
LUSERID  EQU      %
         CI,SR1   KCOMMA
         BNE      SYNTAX
         BAL,R11  GETCHAR
         BCS,8    SYNTAX
         CI,SR1   KRPAREN
         BNE      SYNTAX
         CI,R3    K1
         BL       SIZERR
         CI,R3    14                MAX USER ID
         BG       SIZERR
         MTW,0    UIDDUPSW
         BNEZ     DUPERR
         LI,R1    BA(VOL1)+37       USER ID
         LI,R2    BA(PLB)
LUSERID4 EQU      %
         LB,R4    0,R2
         STB,R4   0,R1
         AI,R1    K1
         AI,R2    K1
         BDR,R3   LUSERID4
         MTW,1    UIDDUPSW
         B        PARMEXIT
         TITLE    'SN COMMAND'
LVOLSER  EQU      %
         CI,SR1   KCOMMA
         BNE      SYNTAX
LVOLSER2 EQU      %
         BAL,R11  GETCHAR
         BCS,8    SYNTAX
         CI,R3    K6
         BNE      SIZERR
         LD,R2    PLB
         LW,R4    VSERINDX
         CI,R4    VSERMAX
         BNE      LVOLSER4
         LI,R5    ERRCD5
         B        ERRRTN
LVOLSER4 EQU      %
         STD,R2   VSERTBL,R4
         AI,R4    K1
         STW,R4   VSERINDX
         CI,SR1   KCOMMA
         BE       LVOLSER2
         CI,SR1   KRPAREN
         BNE      SYNTAX
*
PARMEXIT EQU      %
         BAL,R11  GETCHAR
         CI,SR1   KCOMMA
         BE       B0015
         CI,SR1   KBLANK
         BE       B0010
         B        SYNTAX
         TITLE    'MSN COMMAND'
LSVOLSER EQU      %
         CI,SR1   KCOMMA
         BNE      SYNTAX
         BAL,R11  GETCHAR
         BCS,8    SYNTAX
         CI,SR1   KCOMMA
         BNE      SYNTAX
         CI,R3    K6
         BNE      SIZERR
         STW,R3   R5                R5= NO. CHARACTERS TO CONVERT
         LI,R1    PLB               R1= WD ADDR OF PARM LIST BUFFER
         BAL,R11  DECBIN            CONVERT DECIMAL TO BINARY
         BCS,8    VALUERR           ERROR, NOT DEC
         STW,R2   SSERNO            START SER NO. BINARY
         BAL,R11  GETCHAR           GET REEL COUNT FIELD
         BCS,8    SYNTAX
         CI,SR1   KRPAREN
         BNE      SYNTAX
         CI,R3    K2
         BG       SIZERR
         STW,R3   R5
         LI,R1    PLB
         BAL,R11  DECBIN            CONVERT DECIMAL TO BINARY
         BCS,8    VALUERR
         STW,R2   SSERCNT           NO. REELS TO PROCESS
         MTW,1    SVOLSW
         B        PARMEXIT
         TITLE    'PRINTLABEL COMMAND'
LPRTLBL  EQU      %
         CI,SR1   KRPAREN
         BE       LPRTLBL4
         CI,SR1   KCOMMA
         BNE      SYNTAX
         BAL,R11  GETCHAR
         BCS,8    SYNTAX
         CI,SR1   KRPAREN
         BNE      EXRPAREN
         CI,R3    K2
         BG       SIZERR
         STW,R3   R5
         LI,R1    PLB
         BAL,R11  DECBIN
         BCS,8    VALUERR
         STW,R2   PRTLBLSW
         B        PARMEXIT
LPRTLBL4 EQU      %
         MTW,1    PRTLBLSW
         B        PARMEXIT
         TITLE    'NOLABEL COMMAND'
LNOLABEL EQU      %
         CI,SR1   KRPAREN
         BE       LNOLBL4
         CI,SR1   KCOMMA
         BNE      SYNTAX
         BAL,R11  GETCHAR
         BCS,8    SYNTAX
         CI,SR1   KRPAREN
         BNE      EXRPAREN
         CI,R3    K2
         BG       SIZERR
         STW,R3   R5
         LI,R1    PLB
         BAL,R11  DECBIN
         BCS,8    VALUERR
         STW,R2   NOLBLSW
         B        LNOLBL6
LNOLBL4  EQU      %
         MTW,1    NOLBLSW
LNOLBL6  EQU      %
         LW,R2    NOLBL1
         STW,R2   VOL1
         LD,R2    NOLBL2
         STD,R2   SERIALNO
         B        PARMEXIT
         TITLE    'BLP COMMAND'
LBLP     RES
         CI,SR1   ')'               N OPTINS
         BNE      EXRPAREN
         M:SYS
         BCS,8    EXPRIV
         M:SLAVE
         LI,SR4   1                 SET INPUT OPNE
         STW,SR4  OPNOUT+2
         B        PARMEXIT
         TITLE    'SUBROUTINES'
*
*        DECBIN- CONVERTS EBCDIC DECIMAL TO BINARY
*
*        ENTER WITH
*              R5= NO. OF CHARACTERS TO CONVERT
*              R1= WORD ADDR OF 1ST CHARACTER
*        EXIT WITH
*              R2= RESULT IF NO ERROR AND CC1= 0
*              CC1= 1 IF RESULT IN ERROR, I.E. GREATER
*              THANA 31 BIT INTEGER
*
DECBIN   EQU      %
         LI,R2    K0
         LI,R3    K0
DECBIN1  EQU      %
         LB,R4    *R1,R2            PICKUP DECIMAL BCD CHARACTER
         AI,R4    KNF0              REMOVE LEADING F
         MI,R3    KA                MULTIPLY RESULT BY 10
         BCS,4    DECBIN2           CHECK IF ILLEGAL RESULT
         AW,R3    R4
         AI,R2    K1
         BDR,R5   DECBIN1           CHECK IF DONE
         STW,R3   R2
         LCI      K0                SET CC1= 0 RESULT OK
         B        *R11
*
DECBIN2  EQU      %
         LCI      K8                SET CC1= 1 RESULT IN ERROR
         B        *R11
         PAGE
B0030    EQU      %
         LI,R5    ERRCD1
         B        ERRRTN
AKWERR   EQU      %
         LI,R5    ERRCD2
         B        ERRRTN
EXRPAREN EQU      %
         LI,R5    ERRCD3
         B        ERRRTN
VALUERR  EQU      %
         LI,R5    ERRCD6
         B        ERRRTN
*
SIZERR   EQU      %
         LI,R5    ERRCD7
         B        ERRRTN
*
DUPERR   EQU      %
         LI,R5    ERRCD8
         B        ERRRTN
*
EXCOMMA  EQU      %
         LI,R5    ERRCD9
         B        ERRRTN
*
EXPRIV   LI,R5    10
         B        ERRRTN
*
SYNTAX   EQU      %
         LI,R5    ERRCD4
ERRRTN   EQU      %
         BAL,R11  ERRSUB            PRINT ERROR MESSAGE
         B        B0010
         SPACE    3
ERRSUB   EQU      %
         MTW,1    CCERRSW
         LW,R1    ERRMTBL,R5        ADDRESS FO ERROR MESSAGE
         LI,R3    0
         LI,R4    CERRMSG           R4= ADDR OF OUTPUT MSG AREA
ERRSUB1  EQU      %
         LW,R2    *R1,R3            * MOVE MESSAGE
         STW,R2   *R4,R3            *      TO PRINT LINE
         AI,R3    K1
         CI,R3    K7
         BNE      ERRSUB1
         M:PRINT  (MESS,PRTCRD)
         LI,R3    0
         LW,R2    BLANKS
ERRSUB2  EQU      %
         STW,R2   *R4,R3
         AI,R3    K1
         CI,R3    K7
         BNE      ERRSUB2
         MTW,1    CPRTSW
         B        *R11
         PAGE
GETCRD   EQU      %
         LC       *79
         BCR,12   GETCRD2           NOT INTERACTIVE
         M:KEYIN  (MESS,PROMPT),(REPLY,CRDIN),(SIZE,80),(ECB,CRDIN)
         LB,7     CRDIN
         LI,8     '('
         STB,8    CRDIN
         LI,8     ')'
         STB,8    CRDIN,7
         BDR,7    %+2
         AI,7     -2                SPECIAL STUFF FOR ONE CHAR INUT
         CB,8     CRDIN,7
         BNE      %+2               DID HE USE )S
         AI,7     -1                YES, BLANK OURS
         AI,7     -78               AND REST OF BUFFER
         LI,8     KBLANK
         STB,8    CRDIN+20,7
         BIR,7    %-1
         CB,8     CRDIN             TEST ONE CHAR INPUT
         BNE      GETCRD2+1         NO
         B        CTLEND            YES
PROMPT   TEXTC    'LABEL ('
GETCRD2  EQU      %
         M:READ   M:SI,(BUF,CRDIN),(ABN,CTLEND)
         LI,R6    CRDIN             R6= ADDRESS OF CARD AREA
         LI,R7    -1
         M:WRITE  M:LO,(BUF,CRDIN),(SIZE,80)
         B        *R11
         SPACE    3
KWLOOKUP EQU      %
         CW,R1    *R2,R3
         BE       *R11              FOUND IT
         BDR,R3   KWLOOKUP
         B        AKWERR            UNRECOGNIZED KEYWORD
        PAGE
B0800    EQU      %
         M:OPEN   F:TAPIN
         B          B0810+1
B0810    MTW,1      RPRTCNT
B0840    EQU        %
         BAL,R11    READREC
         LI,R1      K10
         LW,R2      CKVOL
B0850    EQU        %
         CW,R2      LBLTBL,R1
         BE         B0860
         BDR,R1     B0850
         LW,R2      RPRTCNT
         CI,R2      K2
         BE         B0810
         BG       B0870             SKIP RECORDS
         MTW,1      RPRTCNT
B0860    EQU        %
         M:PRINT    (MESS,PRTREC)
         B          B0840
         SPACE    2
B0870    EQU      %
         M:PFIL   F:TAPIN,(EOF)     SKIP FILE TO TAPE MARK
         BAL,R11  RDREC9
         B        B0840+1
         SPACE      3
READREC  EQU        %
         LI,R5    K80
         LI,R1    KBLANK
RDREC1   STB,R1   CKVOL,R5
         BDR,R5   RDREC1
         STB,R1   CKVOL
         M:READ     F:TAPIN,(BUF,CKVOL),(SIZE,5000),;
                  (ABN,RDREC8)
RDREC5   EQU        %
         LW,R5      F:TAPIN+4
         SLS,R5     -17
         STW,R5   D2
         LI,R5    K4
         STW,R11  SAVR11
         BAL,R11  BINDEC
         LW,R11   SAVR11
RDREC6   EQU        %
         LI,R5      K0
         STW,R5     TMRKCNT
         LW,R5      =C'*END'
         STW,R5     RECEND
         LW,R5      BLANKS
         STW,R5     RECEND+1
         STW,R2   RECSIZE
         LI,R5    K95
         STB,R5   PRTREC
         B          *R11
*
RDREC8   EQU        %
         SLS,R10    -24
         CI,R10     K7
         BNE      %+3
         LW,R2    =C'XXXX'
         B        RDREC6
         CI,R10     K5              CK FOR TAPE MARK
         BNE        RDREC5
RDREC9   EQU      %
         M:PRINT    (MESS,TMRK)
         MTW,1      TMRKCNT
         LW,R5      TMRKCNT
         CI,R5      K2
         BE       RDREC10
         M:CLOSE    F:TAPIN
         M:OPEN     F:TAPIN
         LI,R5      K0
         STW,R5     RPRTCNT
         B          READREC
*
RDREC10  EQU      %
         M:CLOSE  F:TAPIN,(SAVE),(REM)
         LI,R5    0
         STW,R5   TMRKCNT
         STW,R5   RPRTCNT
         MTW,-1   PRTLBLSW
         BNEZ     B0800
         M:EXIT
*
         PAGE
*
*        BINDEC- CONVERT BINARY TO DECIMAL
*        ENTER WITH- D2= BIN NO. TO CONV RIGHT JUSTIFIED  CLOBBERS D1
*                    R5= MAX NO. OF RESULTANT DECIMAL DIGITS, LE 8
*
*        EXIT WITH-  R2,R3 DECIMAL RESULT LEFT JUSTIFIED
*
BINDEC   EQU      %
         LI,D1    K0
         DW,D1    XA
         SLD,R2   -8
         STB,D1   R2
         OR,R2    YF0404040
         BDR,R5   BINDEC
         B        *R11
*
XA       DATA     X'A'
YF0404040 DATA    X'F0404040'
         END      START

