***********************************************************************
*M*      DEF      TO WRITE PO/BO TAPE & PROCESS INCLUDE,IGNORE,DELETE CC
***********************************************************************
*
*        CATALOG NO. 704876(SYSGEN DEF)
         SYSTEM   BPM
         SYSTEM   SIG7FDP
********
*  EXTERNAL DEFS
********
         DEF      DEF
         DEF      DEFPATCH
********
*  EXTERNAL REFS
********
         REF      M:C
         REF      M:SI,M:BO         :
         REF      M:PO
         REF      M:TM
         REF      F:INCLUDE
         REF      UTMBPMWRITEMON
         REF      MTMKBF
********
         PAGE
********
*  REGISTERS
********
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
************************************************************************
*     THIS PROCESSOR WRITES PO/BO TAPES
*     PO TAPES CONTAIN A BOOTABLE MONITOR AND ALL LMNS
*     FROM THE RUNNING ACCOUNT, ALSO ANY ELEMENT FILES
*     ON :INCLUDE COMMANDS.  ALL ELEMENT FILES IN THE
*     RUNNING ACCOUNT MAY BE OPTIONALLY DELETED.
*     BO TAPES CONTAIN A BOOTABLE MONITOR AND LMNS
*     FROM THE :SYS ACCOUNT AS WELL AS ALL ELEMENT FILES
*     FROM THE RUNNING ACCOUNT AND ANY KEYED FILES FROM
*     THE RUNNING ACCOUNT THAT HAVE BEEN :INCLUDED
*     THE CONTROL COMMANDS ARE:
*          :WRITE PO,SN
*                 BO,SN
*          :INCLUDE   (NAME1,NAME2....)
*          :IGNORE     (NAME3,NAME4....)
*          :DELETE
*          END
*     ALL COMMANDS PRECEEDING THE :WRITE APPLY TO THAT TAPE
*     AND MAY APPEAR IN ANY ORDER
************************************************************************
DEF      EQU      %           ENTRY.
         LW,R6    *R0               DYNAMIC DATA
         AI,R6    1                   BASE ADDR.IN TSTACK
         LI,R2    DYN-ENDYN
         LW,R1    ENDYN,R2          MOVE DYNAMIC DATA
         PSW,R1   *R0                 TO TSTACK
         BIR,R2   %-2
         LI,R7    CCPL
         AW,R7    R6
         LW,D1    R6
         AI,D1    CCBUF
         LC       *X'4F'           UTS LOOK AT JIT ONLINE FLG
         BCR,8    READFRST          BATCH
         CAL1,1   PROMPT            SET PROMPT = '%'
         M:TYPE   (MESS,TYPIS)      TYPE MESSAGE
         MTW,1    TYPEFLG,R7        SET FLAG FOR M:C SCAN
READFRST EQU      %                 READ M:C FOR TYPE
********
*   READ MONITOR SYSTEM CONTROL COMMAND 'DEF   TYPE'
********
         M:READ   M:C,(BUF,*D1),(SIZE,80),(WAIT)
         LI,SR1   X'80'
         STW,SR1  RECSIZE
         M:PRINT  (MESS,DEFCONT)
         STW,D1   FLGS,R7           SET UP CC BUF.ADDR.IN CCPL
*  PROCESS DEF 'TYPE'
         LI,SR1   0
         MTW,0    TYPEFLG,R7        ARE WE UTS ON-LINE?
         BNEZ     %+3               YES. SKIP SCAN FOR 'DEF'
         BAL,SR4  NAMSCAN  ***      GET RID OF 'DEF'
         NOP      0
         BAL,SR4  NAMSCAN  ***      GET 'TYPE'
         BCS,8    BLNKTYP
         LW,D1    CHARS,R7          GET 4 CHARACTERS
         SAS,D1   -16
         CH,D1    YC3D7
         BE       OKTYPE
BLNKTYP  EQU      %
         M:PRINT  (MESS,TYPMSG)
OKTYPE   EQU      %
         LI,R1    2
         STW,R1   TYPEFLG,R7        SET DEF SYSGEN 'TYPE' FLAG
         LI,SR1   0
         BAL,SR4  CHSTSCAN ***      GET VERSION# FIELD IF ANY
         NOP      0
         LW,SR1   CHARS,R7          GET 1-ST 4 CHAR.ONLY
         SLS,SR1  -8                SAVE ONLY 1-ST 3 CHAR.
         LI,R2    ' '
         STB,R2   SR1
         STW,SR1  VERSN#,R7
         BAL,SR4  PAGER             GET A PAGE FOR TABLES
INIT     LI,R1    INCLSTRT          INCLEND HAS ADDRESS OF
         AW,R1    R6                INCLSTRT
         STW,R1   INCLEND,R6        IN CASE OF NO INCLUDES
         STW,SR2  IGSTRT,R6         INITIALIZE IGNORE TABLE
          STW,SR2   IGEND,R6          POINTS TO LINK ENTRY
          STW,SR2   NXTNAME,R6        POINTS TO NEXT RREE ENTRY
DEFRDCC  EQU      %
         LI,SR1   0
         LW,D1    FLGS,R7           RESTORE CCBUF ADDRESS
         AND,D1   L(X'1FFFF')
         LI,SR4   1                 START SCAN IN
         STW,SR4  CCP,R7              COLUMN-2
         EXU      UPSPACE
         BAL,SR4  READCC   ***      GET CC
         BAL,SR4  LISTCC   ***
         CW,SR3   L(X'06000000')    READCC O.K.
         BNE      DEFRDCC       NO..
         BAL,SR4  NAMSCAN  ***  YES.GET CC ID
         BCS,8    ID       EEE      INVALID ID
         LI,R1    0                 ZERO WRTFLG  IN CASE
         STW,R1   WRTFLG,R6         OF EOF LATER
         LW,R1    CHARS,R7
         CW,R1    L(C'INCL')
         BE       DEFINCL       YES.ID = 'INCLUDE'
          CW,R1     L(C'IGNO')       NO.
          BE        DEFIG            YES.  ID='IGNORE'?
         CW,R1    L(C'WRIT')        IS THE COMMAND :WRITE?
         BE       DEFWRITE          YES
         CW,R1    L(C'DELE')    NO..
         BNE      ID       EEE  NO..ID = 'DELETE'
         MTW,-1   DELETEF,R6    YES.SET FLAG TO DELETE E.F.'S
         B        DEFRDCC
DEFINCL  EQU      %
            MTW,0      INCLSTRT,R6
          BNEZ       INCLON           NO. FIRST INCLUDE?
          MTW,1     NXTNAME,R6       BUMP PAST LINK
          LW,SR2     NXTNAME,R6       YES.
         STW,SR2    INCLSTRT,R6     SET START OF INCLUDE TABLE
          BAL,R4     DEFTABLR  :***   BUILD ENTRIES
         B          INCLBK           NORMAL CLEANUP
INCLON    EQU       %
          LW,R1      INCLEND,R6
          CW,R1     NXTNAME,R6       LINKING NEEDED?
          BE        %+4              NO.
          MTW,1     NXTNAME,R6       YES. BUMP PAST LINK
          LW,SR2    NXTNAME,R6
          STW,SR2    *R1              STORE LINK ADDRESS
          BAL,R4     DEFTABLR  ***    BUILD ENTRIES
INCLBK    LW,SR1     NXTNAME,R6
          STW,SR1     INCLEND,R6     SET LINK READY
          B           DEFRDCC
DEFIG     EQU       %
*                                   1ST TIME IGNEND =
*                                   1ST WRD OF GOTTEN PAGE
          LW,R1        IGEND,R6
          CW,R1     NXTNAME,R6       LINKING NEEDED?
          BE        %+4              NO
          MTW,1     NXTNAME,R6       YES. BUMP PAST LINK
          LW,SR2    NXTNAME,R6
          STW,SR2          *R1              STORE LINK ADDRESS
          BAL,R4      DEFTABLR  ***    BUILD ENTRIES
          LW,SR1      NXTNAME,R6
          STW,SR1     IGEND,R6         SET LINK ADDRESS READY
          B           DEFRDCC
DEFWRITE EQU      %                 ENTERED ON WRITE COMMAND
         BAL,SR4  NAMSCAN           GET NEXT FIELD
         BCS,8    PODFLT            NULL OR BAD SO PO
         LW,R1    CHARS,R7          GET FIELD
         SLS,R1   -16               ONLY TWO CHARS
         CI,R1    'PO'              IS IT PO?
         BE       DFWRTPO           YES
         CI,R1    'BO'              IS IT BO?
         BE       DFWRTBO           YES
PODFLT   EQU      %                 ILLEGAL FIELD SO PO
         M:PRINT  (MESS,PODE)       SAY SO
DFWRTPO  EQU      %                 :
         LI,R5    M:PO              SET DCB POINTER
         BAL,R1   OUTSN             CHECK FOR OUTSN FIELD
         LI,R1    X'20'             WRTFLG = ORG
         STW,R1   WRTFLG,R6         :
         LI,R1    POIGS             SET UP AUTOMATIC IGNORES
         LW,R2    IGEND,R6          BY LINKING IN TABLE
         STW,R1   *R2               STORE LINK
         LI,R1    POINCLS           SET UP AUTO INCLS
         LW,R2    INCLEND,R6        :
         STW,R1   *R2               :
POON     EQU      %                 :
         LCI      15                :
         PSM,R1   *R0               SAVE REGS
         LW,R5    R7                SAVE BASE FOR GETWRITEMON
         LW,SR1   VERSN#,R6         VERSION NUMBER
         LI,R7    M:PO              DCB
         LW,R6    L(X'01010202')    FLAG FOR PO
         BAL,SR4  GETRITEMON        WRITE BOOTABLE MONITOR
         LCI      15                :
         PLM,R1   *R0               GET REGS BACK
PAGE     M:DEVICE M:LL,(PAGE)       :
         M:PRINT  (MESS,TITLM)      PO TAPE CONTENTS
GTPG     M:GP     10
         BCS,8    NOROOM
         SLS,SR1  9                 SIZE IN WORDS
         B        CCA               GO FINISH TAPE
DFWRTBO  EQU      %                 :
         LI,R5    M:BO              SET DCB POINTER
         BAL,R1   OUTSN             CHECK FOR OUTSN FIELD
         LI,R1    X'10'             WRTFLG = ORG
         STW,R1   WRTFLG,R6         :
         LCI      15                ---------------
         PSM,R1   *R0               SET THING UP FOR
         LW,R5    R7                WRITEMON AND GO
         LW,SR1   VERSN#,R6         GET THE RIGHT ONE
         LW,R6    L(X'01000202')    :
         LI,R7    M:BO              :
         BAL,SR4  GETRITEMON        :
         LCI      15                :
         PLM,R1   *R0               ----------------
         LI,R1    BOINCLS           SET AUTO INCLS
         LW,R2    INCLEND,R6        :
         STW,R1   *R2               :
         EXU      PAGE              :
         M:PRINT  (MESS,TITLMB)     BO TAPE CONTENTS
         B        GTPG              GET BUFFER AND FINISH TAPE
OUTSN    EQU      %                 CHECKS FOR OUTSN FIELD
         MTW,0    ENDFLG,R6                                          RL3
         BNEZ     *R1                                                RL3
         LI,SR1   0                 :
         BAL,SR4  CHSTSCAN          GET NEXT FIELD
         BCS,8    *R1               THERE WASN'T ONE
         LW,R2    CHARS,R7          GET FIRST FOUR CHARS
STRSN    STW,R2   SER+3             STORE IN FPT
,SER     M:OPEN   *R5,(OUTSN,'XXXX')
         M:CLOSE  *R5
         B        *R1
DEFTABLR  EQU         %
         LI,SR2   '('
         BAL,SR4  CHARSCAN ***
         BCS,8    DELFT    EEE      SYNTAX ERROR
DEFNAM   EQU      %
         BAL,SR4  NAMSCAN  ***      GET NAME
         BCS,8    NAM      EEE      NAME INVALID
         LW,R1    CSL,R7            # CHAR.IN NAME
         CI,R1    15
         BG       NAM      EEE      NAME > 15 CHAR.
         LW,R2    NXTNAME,R6        OBTAIN BYTE ADDR.
         CW,R2    ENDWKARA,R6       WILL NAME FIT IN CURRENT PAGE?
         BLE      %+2               YES
         BAL,SR4  PAGER             NO GET ANOTHER
         SLS,R2   2                   OF NEXT NAME SLOT IN WORK AREA
         STB,R1   0,R2              NAME SIZE
         LI,R3    0
         LI,D1    CHARS
         AW,D1    R7
DEFNAMOV EQU      %
         AI,R2    1             YES.
         LB,D2    *D1,R3            MOVE NAME
         STB,D2   0,R2                TO WORK AREA
         AI,R3    1
         BDR,R1   DEFNAMOV
         AI,R2    4                 UPDATE WORK AREA
         SLS,R2   -2                  POINTER FOR
         STW,R2   NXTNAME,R6          NEXT NAME
NXTFLD   EQU      %             YES.HERE FROM ERR S.R.'S
         LI,SR2   ','
         BAL,SR4  CHARSCAN ***
         BCR,8    DEFNAM        YES.ANY MORE NAMES
         CI,SR1   ')'           NO..
         BNE      DEL      EEE      SYNTAX ERROR
EOCC     EQU      %
         LI,SR1   0
         LI,SR2   0
         BAL,SR4  CHARSCAN ***      FIND END OF CC
         CI,SR1   KCRET
         BE       *R4
         CI,SR1   KNL
         BE      0,R4
         CI,SR1   EOB
         BNE      EOCC
          B           *R4             RETURN
************************************************************************
PAGER    EQU      %                 GETS ONE PAGE AND ZEROS IT
         PSW,SR1  *R0               SAVE SR1
         M:GP     1                 GET A PAGE
         BCS,8    NOROOM            DIDN'T GET ONE
         LI,R5    512               ZERO THE PAGE
         AI,SR2   -1                :
         LI,SR1   0                 :
         STW,SR1  *SR2,R5           :
         BDR,R5   %-1               :
         AI,SR2   1                 :
         MTW,1    PGCNT,R6          COUNT PAGES
         LW,SR1   SR2               :
         AI,SR1   507               :
         STW,SR1  ENDWKARA,R6       KEEP TRACK OF END
         PLW,SR1  *R0               GET SR1 BACK
         B        *SR4              RETURN
LSTWRT   EQU      %                 ENTERED ON M:SI EOF
         LI,SR1   0                 FOR RELEASING PAGES
         MTW,-1   ENDFLG,R6         SET EXIT AT END
         MTW,0    WRTFLG,R6         WAS LAST COMMAND WRITE?
         BNEZ     ALLDONE           YES
         B        PODFLT            NO. GO WRITE PO
         PAGE
************************************************************************
*  READCC WILL READ NEXT CC
*        (D1) = CC BUFFER ADDRESS
*  READCONT WILL  READ CONTINUATION CC
************************************************************************
READCC   EQU      %           ENTER.
         PSW,SR4  *R0
         BAL,SR4  LISTCC   ***      LIST PREV.CC IF NOT LISTED
         M:READ   M:SI,(BUF,*D1),(SIZE,80),(ERR,LSTWRT),(ABN,LSTWRT)
         LH,SR4   M:SI+4            GET ARS SIZE
         SLS,SR4  -1
         STW,SR4  RECSIZE
         LI,SR4   LISTCONT          SET TO
         STW,SR4  CCP-1,R7            LIST  THIS  CC
         LI,SR3   0
         LH,SR4   *D1               GET FIRST TWO CHARS
         CH,SR4   XEND              END COMMAND?
         BNE      %+4               NO. CONTINUE
         LI,SR1   0                 FOR PAGE RELEASE
         MTW,-1   ENDFLG,R6         EXIT FLAG SET
         B        ALLDONE           FINISH UP
         LB,SR4   *D1
         CI,SR4   ':'               CC MUST BEGIN WITH ':'
         BNE      NO:      EEE  NO..
         LI,SR4   X'1FFFF'
         AND,SR4  FLGS,R7
        STW,SR4   FLGS,R7
         LW,SR3   L(X'06000000') OK.CC READ O.K. FLAG
         PLW,SR4  *R0
         B        *SR4    <<->>     RETURN
********
READCONT EQU      %           ENTER.READ CONTINUATION CC
         LW,D1    FLGS,R7           OBTAIN CC BUFFER ADDR.
         B        READCC
************************************************************************
         PAGE
************************************************************************
*  LISTCC WILL LIST A CC IF NOT ALLREADY LISTED
*        (D1) = CC BUFFER ADDRESS
*  LISTCONT IS CONTINUATION CC LIST ENTRY
************************************************************************
LISTCC   EQU      %           ENTER.
         LW,D4    CCP-1,R7
         AND,D4   L(X'1FFFF')
         BEZ      LISTCC1       YES.CC LISTED
         LW,D4    CCP-1,R7      NO..
         AND,D4   L(X'FFFE0000')    SET TO
         STW,D4   CCP-1,R7            NOT LIST NEXT TIME
         LH,D4    M:SI+4            GET ARS
         SLS,D4   -1                :
         PSW,R1   *R0
         LW,R1    D4
         AI,R1    -1
         LB,R1    *D1,R1            GET LAST BYTE
         CI,R1    X'15'             IS IT CARRIAGE RETURN
         BNE      %+2               NO
         AI,D4    -1                YES
         PLW,R1   *R0
         M:WRITE  M:LL,(BUF,*D1),(SIZE,*D4),(WAIT)
LISTCC1  EQU      %
         B        *SR4    <<->>     RETURN
********
LISTCONT EQU      %           ENTER.LIST CONTINUED CC
         LW,D1    FLGS,R7           OBTAIN CC BUFFER ADDR.
         B        LISTCC
************************************************************************
         PAGE
**********
*  OBTAIN APPROPRIATE WRITEMON OVERLAY ACCORDING TO 'TYPE'
**********
GETRITEMON EQU UTMBPMWRITEMON
         PAGE
************************************************************************
*  ERROR S.R.'S AND MESSAGES
************************************************************************
DEFCONT  EQU      %
         TEXTC    ': : : :  SYSGEN DEF IN CONTROL  : : : :'
********
DEFDONE  EQU      %
         TEXTC    ': : : :  DEF COMPLETED  : : : :'
********
BLNKLINE EQU      %
         TEXTC    '   '
********
ID       EQU      %                 ID ERROR
         BAL,SR4  LISTCC   ***
         M:PRINT  (MESS,IDM)
         LI,R4   DEFRDCC
         PSW,R4  *R0
ERRCOM   EQU      %           COMMON ERROR ENTRY
         LW,SR4   FLGS,R7           RESET
         AND,SR4  L(X'1FFFF')         FLAGS
         STW,SR4  FLGS,R7             IN CCPL
         M:PRINT  (MESS,NXTCC)
         BAL,SR4  EOCCSCAN ***      FIND END OF CC
          PLW,R4     *R0
          B     *R4          BAL RETURN
IDM      EQU      %
         TEXTC    '** CC TYPE UNKNOWN'
NXTCC    EQU      %
         TEXTC    '**** GET NEXT CC'
********
********
DELFT    EQU      %                 DELIMITER ERROR
         PSW,R4   *R0
         BAL,SR4  LISTCC   ***
         M:PRINT  (MESS,DELFTM)
         B        ERRCOM   <->      EXIT
DELFTM   EQU      %
         TEXTC    '** SYNTAX ERROR, NO''('''
********
DEL      EQU      %                 INVALID TERMINATOR
         PSW,R4   *R0
         BAL,SR4  LISTCC   ***
         M:PRINT  (MESS,DELMMM)
         B        ERRCOM   <->      EXIT
DELMMM   EQU      %
         TEXTC    '** DELIMITER MUST BE '','' OR '')'''
********
NAM      EQU      %                 NAME INVALID
         PSW,R4   *R0
         LW,SR4   FLGS,R7
         AND,SR4  L(X'1FFFF')
         STW,SR4  FLGS,R7
         BAL,SR4  LISTCC   ***
         M:PRINT  (MESS,NAMM)
         B        NXTFLD   <->      EXIT
NAMM     EQU      %
         TEXTC    '** NAME INVALID OR >15 CHAR.LONG'
********
NOROOM   EQU      %                 WORK AREA TOO
         BAL,SR4  LISTCC   ***
         BAL,SR4  EOCCSCAN ***      FIND END OF CC
         EXU      UPSPACE
         M:PRINT  (MESS,NOROOMM)
ABORTX   EQU      %
         M:PRINT  (MESS,ABORTM)
         EXU      UPSPACE
         M:PRINT  (MESS,DEFDONE)
*
         CAL1,9   1                 EXIT
*
NOROOMM  EQU      %
         TEXTC    '**** NOT ENOUGH CORE AVAILABLE'
PODE     TEXTC    '****  WRITING PO BY DEFAULT  ***'
WRNGORG  TEXTC    '*** ILLEGAL INCLUDE - WILL BE COPIED LATER'
NOCOPY   TEXT     ' NOT COPIED - RANDOM'
NCSIZ    EQU      BA(%)-BA(NOCOPY)
NCMOV    GEN,8,24 NCSIZ,1
ABORTM   EQU      %
         TEXTC    '****** SYSGEN DEF ABORTED'
********
********
NO:      EQU      %                 NO ':' IN COLUMN-1
         CI,SR4   '*'               COLUMN-1 = '*'
         BNE      NO:X              NO..
         PLW,SR4  *R0               YES.COMMENT CARD
         B        READCC            GET NEXT CC
NO:X     EQU      %
         PLW,SR4  *R0
         BAL,SR4  LISTCC   ***
         M:PRINT  (MESS,NO:M)
         LI,R4    DEFRDCC
         PSW,R4   *R0
         B        ERRCOM   <->      EXIT
NO:M     EQU      %
         TEXTC    '** NO '':'' IN COLUMN-1'
********
TITLM    EQU      %
         TEXTC    '..... PO TAPE CONTENTS .....'
TITLMB   TEXTC    '..... B0 TAPE CONTENTS .....'
********
TITLM1   EQU      %
         TEXTC    '    *** INCLUDE ITEMS ***'
********
TITLM2   EQU      %
         TEXTC    '    *** OTHER ITEMS ***'
********
NOFND    EQU      %
         TEXTC    '******** INCLUDE FILE NOT FOUND'
********                            :
TYPIS    TEXTC    'TYPE IS? '       :
TYPMSG   TEXTC    '*****   UNKNOWN   TYPE   -- CP-V --   USED   *****'
********
POBAD    EQU      %
         TEXTC    '**** CANNOT OPEN OUTPUT DEVICE'
CNTWRT   TEXTC    '*****CANNOT WRITE TAPE'
********
EOCCSCAN EQU      %                 FIND END OF CC
         PSW,SR4  *R0
         LW,SR4   FLGS,R7
         AND,SR4  L(X'1FFFF')
         STW,SR4  FLGS,R7
EOCC1    EQU      %
         LI,SR2   KCRET
         BAL,SR4  CHARSCAN ***
         BCR,8    EOCC2
         CI,SR1   EOB
         BE       EOCC2
         CI,SR1   KNL
         BE       EOCC2
         LI,SR1   0
         B        EOCC1
EOCC2    EQU      %
         PLW,SR4  *R0
         B        *SR4    <<->>     RETURN
************************************************************************
         PAGE
************************************************************************
*     DEF IS NOW READY TO GENERATE THE PO/BO TAPE
*    ALTHOUGH THE BOOTABLE MONITOR HAS ALREADY BEEN WRITTEN
************************************************************************
CCE      EQU      %           ENTER.FROM EOF
CCA      EQU      %           ENTER.  ON C DEVICE
         LCI      2
         PSM,SR1  *R0
UPSPACE  M:PRINT  (MESS,BLNKLINE)
         M:PRINT  (MESS,TITLM1)
         EXU      UPSPACE
         M:SETDCB M:TM,(ERR,0)
         LW,R3    INCLSTRT,R6       CHECK FOR CODE
         BEZ      NOINCL
         B        NXTON             ON FIRST LINK
NXTINCL  EQU      %
         LI,D1    OPNTMSQN          OPEN TM PLIST ADDR.
         AW,D1    R6                  TO INCLUDE OPTION FILE-NAME
         LI,D2    FPARAM            FILE PARAMETER LIST
         AW,D2    R6                  ADDR.
         LW,R1    D1
         AI,R1    OPNAME-OPNTMSQN
          LW,R2       INCLSTRT,R6      ADDRESS NEXT ENTRY
          BEZ         NOINCL          NO INCLUDES FOOOOUND
         LCI      4             NO..
         LM,SR1   *R2               GET NEXT INCLUDE NAME
         STM,SR1  1,R1                & PUT IN OPEN PLIST
         CD,SR1   SPEC:HAND         BY-PASS THIS INCLUDE
         BNE      %+3                 IF IT IS 'SPEC:HAND' FILE
         CW,SR3   SPEC:HAND+2
         BE       NXTINCNM
         LI,R1    2                 GET INCLUDE ACCOUNT LIST COUNT
         LB,SR1   F:INCLUDE+22,R1
         STW,SR1  INCLACN,R7
         LI,SR4   F:INCLUDE+21
NXINAC1  LI,SR2   X'200'
         STS,SR1  OPACCN-1,R7
         LCI      2                 -----------------
         PLM,SR1  *R0               GET BUFFER SIZE
         LCI      2                 AND ADDRESS AND
         PSM,SR1  *R0               MAKE SIZE BYTES
         SLS,SR1  2                 ------------------
         CAL1,1   *D1               OPEN DISC
         LW,D3    D2
         AI,D3    1
*                                   IS FILE NAME OF OPEN SAME
*                                   AS INCLUDE NAME,CHK BYTE CT
*                                   & NAME IF NOT,MUST BE SYNON
         LB,R3    *D3
         CB,R3    *R2
         BNE      SYNINCL
         LB,D4    *D3,R3
         CB,D4    *R2,R3
         BNE      SYNINCL
         BDR,R3   %-3
*                                   ORG OF INCLUDE CORRECT
*                                   FOR PO (CONSEC),BO (KEYED)
*                                   IF NOT FORGET IT
         LW,D3    M:TM+ORG          ---------------
         CI,D3    X'F0'
         BANZ     %+2
         AI,D3    X'10'
         LI,D4    X'F0'
         CS,D3    RANORG
         BE       FORGET
         LI,D4    X'200'
         AND,D4   OPACCN-1,R7       IF FROM DIFFERENT ACCOUNT
         BNEZ     %+3               WRONG TYPE IS OK
         AND,D3   WRTFLG,R6
         BNEZ     FORGET
         LI,D3    X'30'
         AND,D3   M:TM+ORG
         SLS,D3   -4
         LW,D4    M:TM+KEYM         SAME
         LB,D4    D4                ----------------
         CAL1,1   RESETDCB          TURN OFF SECURITY INFO
         LI,D1    OPNPO             OPEN PO/BO PLIST ADDR
         AW,D1    R6                  TO WRITE INCLUDE OPTION FILE-NAME
         CAL1,1   *D1               OPEN M:PO/M:BO
         M:PRINT  (MESS,*R2)        DISPLAY FILE-NAME
         M:SETDCB M:TM,(ABN,RTMAINCL)
RDWRITEM EQU      %
         CAL1,1   RDSQN    ***      READ M:TM
         LW,R1    M:TM+RWS
         CAL1,1   WRTPE
         B        RDWRITEM
********
RTMAINCL EQU      %                 EOF ON TM FOR THIS INCLUDE FILE-NAME
         BAL,D1   PGCNTL
RTMAIN1  EQU      %
         M:CLOSE  M:TM,(SAVE)
         M:CLOSE  *R5,(SAVE)
         B        NXTINCNM
********
FORGET   EQU      %                 INCLUDE ITEM HAS WRONG ORG
         M:CLOSE  M:TM,(SAVE)       CLOSE DISC
         EXU      UPSPACE           :
         M:PRINT  (MESS,*R2)        PRINT FILE NAME
         M:PRINT  (MESS,WRNGORG)    ILLEGAL INCLUDE
         EXU      UPSPACE           :
         B        NXTINCNM          CONTINUE
**********
SYNINCL  EQU      %
         LI,SR3   SYNAME
SYN1     LB,R3    *D3
         LB,D4    *D3,R3
         STB,D4   *SR3,R3
         BDR,R3   %-2
         LB,SR4   *D3               THIS CODE PUTS THE
         STB,SR4  *SR3              SYNON NAME AND PARENT
         AI,SR4   4                 NAME INTO A SPECIAL
         SLS,SR4  -2                FPT FOR WRITING SYNON
         LI,R3    -2                INCLUDES TO TAPE.
         STB,SR4  *SR3,R3
         CI,SR3   RLNAME
         BE       WRTSYN
         LI,SR3   RLNAME
         LW,D3    R2
         B        SYN1
WRTSYN   EQU      %
         CAL1,1   RESETDCB          TURN OFF SECURITY INFO
         CAL1,1   OPNSYN
         M:PRINT  (MESS,RLNAME)
         B        RTMAIN1
OTMAINCL EQU      %
         LB,R1    SR3               IS IT NO FILE
         CI,R1    3
         BNE      NOFNDM            SOME KIND OF MISTEAK
         AI,SR4   2
         LM,SR1   *SR4              TRY NEXT ACCOUNT IN LIST
         STM,SR1  OPACCN,R7
         LI,SR1   X'200'            SET ACCOUNT PRESENT
         MTW,-2   INCLACN,R7        ANY ACCOUNTS LEFT TO SEARCH
         BGEZ     NXINAC1           MORE TO TRY
NOFNDM   RES                        GIVE UP LOOKING
         EXU      UPSPACE
         M:PRINT  (MESS,*R2)          FILE NAME
         M:PRINT  (MESS,NOFND)
         EXU      UPSPACE
NXTINCNM EQU      %
         LB,R3    *R2               DETERMINE
         AI,R3    4                   NEXT INCLUDE
         SLS,R3   -2                  FILE-NAME
          AWM,R3      INCLSTRT,R6     ADVANCE THROUGH
          LW,R3       INCLSTRT,R6     TABLE
NXTON    LB,R4    *R3               GET BYTE COUNT
         BEZ      NXTLNK            MUST BE LINK
         CI,R4    X'40'             IS IT BLANK?
         BAZ      NXTINCL           REALLY COUNT
         BE       %+3               BLANK
         LI,R1    X'200'            MUST BE 4F                       RL3
         AWM,R1   OPNAME+5,R6       TURN ON :SYS
         AI,R3    1                 ADVANCE ONE WORD
         B        BLNKLNK           AND CONTINUE
NXTLNK   LW,R3    *R3               GET LINK
         BEZ      NOINCL            END OF TABLE
BLNKLNK  STW,R3   INCLSTRT,R6       STORE CURRENT POSITION
          B           NXTON
********
NOINCL   EQU      %                 INCLUDES ALL DONE OR NONE TO DO
         LW,SR1   WRTFLG,R6         ---------------
         CI,SR1   X'10'             IF THIS IS A BO
         BNE      ITSPO             TAPE WRITE LASTLM
         CAL1,1   OPNPOLST          OTHERWISE CONTINUE
         M:CLOSE  M:BO,(SAVE)       :
         M:PRINT  (MESS,LASTLM)     :
ITSPO    EQU      %                 -----------------
         MTW,0    SYNFLG,R6
         BNEZ     POOUT
         EXU      UPSPACE
         M:PRINT  (MESS,TITLM2)
         EXU      UPSPACE
OPNNXT   RES
         LCI      2
         PLM,SR1  *R0
         LCI      2
         PSM,SR1  *R0
         SLS,SR1  2
         LI,D1    OPNTM             OPEN TM PLIST ADDR.
         AW,D1    R6                  TO OBTAIN NEXT FILE
         LI,D2    FPARAM            FILE PARAMETER LIST
         AW,D2    R6                  ADDR.
         CAL1,1   *D1      ***      OPEN M:TM TO NEXT
         LW,R2    D2
NOTSPEC  EQU      %
         LW,R2    1,R2
         SLS,R2   -16
         CI,R2    X'340'            CHECK FOR STAR FILES INDIRECTORY
         BG       %+3
         CI,R2    X'300'
         BGE      CLSDSK
         LW,D3    M:TM+ORG
         CI,D3    X'F0'
         BANZ     %+2
         AI,D3    X'10'
         LI,D4    X'F0'
         CS,D3    RANORG            IS IT RANDOM ORGANIZATION
         BE       ISSPECRN
         AND,D3   WRTFLG,R6
         SLS,D3   -4                ORG CORRECT FOR IGNORE
         BEZ      ISSPEC            NO,(BO,CONSEC PO,KEYED)
         STW,D3   OPNPO+4,R6        YES,PUT ORG IN PLIST
IGNOR1   EQU      %                 :
         LW,R2        D2         YES.
         AI,R2        1          FILE NAMES ARE
          LW,R3       IGSTRT,R6        IN FPARAM GET BA
IGNOR     LB,D3       *R3              GET COUNT FROM IGTBL
         BEZ          CHAIN           IS THIS LINK? YES.
         CB,D3        *R2        NO.. COMP WITH FPARAM
         BE           CHECKOUT       YES. EQUAL? TEST.
IGBK     AI,D3        4              NO. GET NEXT ENTRY
         SLS,D3       -2
         AW,R3       D3
         B           IGNOR
CHAIN    LW,R3       *R3            GET NEXT ADDRESS
         BNEZ       IGNOR          NO. IS THIS EOT?
         B            RDWRITE    YEES.
CHECKOUT LW,R4      D3
CHECKARN LB,D4      *R3,R4     GET BYTE FROM IGNORE TBL
         CB,D4      *R2,R4     COMP WITH FPARAM.
         BNE       IGBK           NO.. SAME?
         BDR,R4   CHECKARN       YES.. TRY AGAIN.
ISSPEC   EQU      %
         MTW,0    DELETEF,R6
         BEZ      CLSDSK            DELETE NOT SPECIFIED
         M:CLOSE  M:TM,(REL)    YES.RELEASE THIS FILE
         B        NXTFILE
CLSDSK   EQU      %
         M:SETDCB M:TM,(ABN,OTMA)   MAKE SURE OF ABN (SYNON)         RL3
         M:CLOSE  M:TM,(SAVE)
NXTFILE  RES
         LI,R2    X'10000'          TURN OFF FIRST FILE
         STW,R2   OPNTMFP,R6        FOR OPENNEXT
         B        OPNNXT
ISSPECRN RES
         LI,10    -1                SET RAND FLAG
ISSPECIO RES                        IO ABN ON OPEN, MUST SKIP
         LB,R2    M:TM+23           MOVE FILE NAME TO MESSAGE
         ANLZ,R3  %+2               SAVE END OF NAME
         LB,D3    M:TM+23,R2
         STB,D3   *D2,R2
         BDR,R2   %-2
         LB,R2    M:TM+23           CALCULATE MESS SIZE
         AI,R2    NCSIZ
         STB,R2   *D2
         AW,R3    NCMOV             MOVE IN 'NOT COPIED - RANDOM'
         LI,R2    BA(NOCOPY)
         MBS,R2   0
         AI,R3    -6                BACK TO 'RANDOM' IN CASE IO ABN
         LW,D4    10                GET ABN CODE
         BLZ      ISSPECPR          RANDOM, JUST PRINT
         MTB,-2   *D2               ADJUST BYTE COUNT
         SLD,D3   8                 SPREAD CODE-CUBCODE
         SLS,D4   -1
         SLD,D3   -8
ISSPECLP LI,D3    0                 GET NEXT DIGIT
         SLD,D3   4
         AI,D3    '0'               CONVERT
         CI,D3    '9'               IS IT HEX
         BLE      %+2               NO
         AI,D3    -'0'+'A'-10
         STB,D3   0,R3
         AI,R3    1
         AI,D4    0                 ARE WE DONE..DONT WORRY ABOUT
         BNEZ     ISSPECLP          DOING DCB ADDR..COUNT PRINTS ONLY 4
ISSPECPR M:PRINT  (MESS,*D2)
         LH,R3    M:TM              CLOSE M:TM IF OPEN
         CI,R3    X'20'
         BAZ      NXTFILE
         B        ISSPEC
RDWRITE  EQU      %
         LW,R2    *D1
         LW,D4    KEYM,R2           OBTAIN KEY-MAX FROM INPUT
         LB,D4    D4
         CAL1,1   RESETDCB          TURN OFF SECURITY INFO
         LI,D1    OPNPO             OPEN PO/BO PLIST ADDR
         AW,D1    R6                  TO WRITE FILE
         CAL1,1   *D1               OPEN M:PO/M:BO
         LI,D1    FPARAM+1          ADDR.OF
         AW,D1    R6                  FILE NAME
         M:PRINT  (MESS,*D1)        DISPLAY FILE NAME
         M:SETDCB M:TM,(ABN,RTMA)
RDWRFILE EQU      %
         CAL1,1   RDDSK    ***      READ M:TM
RDWRITE1 EQU      %
         LW,R1    M:TM+RWS          GET ACTUAL RECORD SIZE
         CAL1,1   WRTPE             WRITE M:PO/M:BO
         B        RDWRFILE
********
RTMA     EQU      %                 EOF ON TM FOR THIS FILE
         BAL,D1   PGCNTL
         B        RTMA1
*************************************************************
*     THIS RTN CHECKS IF ABN FOR EOF, IF SO GOES TO RLPGS,
*     IF NOT, IS BUFFER TOO SMALL IF NOT PRINTS ERR/ABN
*     CODE AND RETURNS TO INST. AFTER ISSUING CAL.
*     IF BUFFER TOO SMALL, THEN IF MAX PAGES NOT OBTAINED MORE
*     PAGES GOTTEN, RECORD POSITIONED 1 BACK AND EXTRA PAGE
*     FLAG SET AND RETURN TO ISSUING CAL
*************************************************************
PGCNTL   EQU      %
         LB,SR3   SR3
         CI,SR3   6
         BE       RLPGS
         CI,SR3   7
         BNE      *SR1
         STW,SR1  D1
         LCI      2
         PLM,SR1  *R0
         LCI      2
         PSM,SR1  *R0
         CI,SR1   5200
         BG       NOROOM
         LD,SR3   SR1
         M:GP     255
         LW,SR2   SR4
         LW,SR4   SR1               GOT ANY PAGES
         BEZ      NOROOM
         SLS,SR1  9
         AW,SR1   SR3
         SLS,SR1  2
         M:PRECORD M:TM,(N,1),(REV),(ABN,ERRDONE)
         LI,D2    -1
         AI,D1    -1
         B        *D1
RLPGS    EQU      %
         CI,D2    -1
         BNE      *D1
         OR,SR4   L(X'09000000')
         CAL1,8   SR4
         B        *D1
RTMA1    EQU      %
         M:CLOSE  *R5,(SAVE)
         B        CLSDSK
********
OTMA     EQU      %                 EOF ON OPEN TM
         LB,D3    SR3
         CI,D3    2                 END OF ALL FILES
         BE       OTMAX         YES.
         CI,D3    8             NO..SYNONYMOUS FILE
         BNE      ISSPECIO          NO..SKIP THIS FILE ENTIRELY
*                                   SYNON FILE HANDLING,
*                                   SR1=SIZE OF BUFFER
*                                   SR2=BUF ADDR
*                                   1ST FILE, ADDR AT INCLSTRT
*                                   INCREMENT SYNFLG,ADD #WRDS TO
*                                   BUF ADDR,SUBTRACT FROM WRDS
*                                   AVAILABLE , SAVE SR1, SR2
*                                   PUT SYNON NAME IN TABLE
         LI,D1    FPARAM+1
         AW,D1    R6
         LW,R4    D1
         LW,D1    0,R4              IS IT LASTLM
         CW,D1    POIGS
         BNE      %+5
         LW,D1    1,R4
         LI,D2    -X'100'
         CS,D1    POIGS+1
         BE       NXTFILE           YES, DONT PUT IN SYNON
         LW,D1    R4
         LB,R4    *D1
         AI,R4    4
         SLS,R4   -2
         LCI      2
         PLM,SR1  *R0
         LW,SR3   SR2
         MTW,0    SYNFLG,R6
         BNEZ     %+2
         STW,SR2  INCLSTRT,R6
         MTW,1    SYNFLG,R6
         AW,SR2   R4
         SW,SR1   R4
         LCI      2
         PSM,SR1  *R0
         LB,R4    *D1
         STB,R4   *SR3
         LB,SR1   *D1,R4
         STB,SR1  *SR3,R4
         BDR,R4   %-2
         B        NXTFILE
OTMAX    EQU      %
         LW,R1    WRTFLG,R6
         CI,R1    X'10'
         BNE      LSTLM
         M:OPEN   M:BO
         M:CLOSE  M:BO,(REM),(SAVE)
         B        ERRDNNE
LSTLM    EQU      %
         MTW,0    SYNFLG,R6         ANY SYNONOMOUS FILES ENCOUNTERED
         BEZ      %+2
         B        OTMAY
POOUT    EQU      %
         CAL1,1   OPNPOLST ***      WRITE NULL FILE 'LASTLM' TO M:PO
         M:CLOSE  M:PO,(REM),(SAVE)
         M:PRINT  (MESS,LASTLM)
ERRDNNE  EXU      UPSPACE           :
         LCI      2                 COMPUTE #OF PAGES
         PLM,SR1  *R0               OF BUFFERS:
         AI,SR1   X'1FF'            :
         SLS,SR1  -9                :
ALLDONE  EQU      %                 :
         AW,SR1   PGCNT,R6          ADD IN COUNT FROM PAGER
         OR,SR1   L(X'09000000')    MAKE INTO FPT
         CAL1,8   SR1               FREE PAGES
         MTW,0    ENDFLG,R6         EXIT NOW?
         BEZ      NXTTPE            NO. DO NEXT TAPE
         M:PRINT  (MESS,DEFDONE)
         CAL1,9   1                 EXIT
********
OTMAY    EQU      %
         LI,R2    0
         STW,R2   *SR2
         LW,R3    INCLSTRT,R6
         B        NXTON
********
OPOA     EQU      %                 CANNOT OPEN PO/BO TAPE
         EXU      UPSPACE
         M:PRINT  (MESS,POBAD)
         B        ERRDONE
********
NXTTPE   EQU      %
         LI,R1    #ZEROS            THIS CODE STORES
         LI,R2    0                 ZEROS INTO THE
         LI,R3    IGSTRT            FLAGS AND COUNTERS
         AW,R3    R6                TO INITIALIZE FOR
         AI,R3    -1                THE NEXT TAPE
         STW,R2   *R3,R1            :
         BDR,R1   %-1               -----------------
         LW,R1    L(X'01000000')    TURN ON FILE NAME
         STW,R1   OPNTMFP,R6        IN READ TM
         LW,R1    L(X'02010002')    TURN OFF :SYS
         STW,R1   OPNAME+5,R6       :
         LW,R1    L(X'8000000E')    PUT ORG  *D3 BACK
         STW,R1   OPNPO+4,R6        INTO OPNPO FPT
         M:SETDCB *R5,(ABN,0),(ERR,0)
         LI,SR4   INIT              PAGER RETURNS TO INIT
         B        PAGER             START OVER - NEW TAPE
ERRDONE  EQU      %
         M:PRINT  (MESS,CNTWRT)
         M:SETDCB *R5,(ABN,ERRDNNE)
         M:OPEN   *R5
         M:CLOSE  *R5,(REL),(REM)
         B        ERRDNNE
         PAGE
************************************************************************
*  DYNAMIC DATA
*        SPECIAL POINTERS IN R6 & R7
************************************************************************
DYN      EQU      %             --->POINTED TO BY R6
CCPL     EQU      %-DYN         --->POINTED TO BY R7
         GEN,8,24 NODELM,BA(DELM)   #DELIMITERS,BA(DELIMITERS)
         GEN,8,24 CNTCOL,READCONT   CONTINUE COL.,CONTINUE READ S.R.
         PZE      0                 LIST OUTPUT S.R. (SUPPLIED)
CCP      EQU      %-CCPL-DYN
         DATA     0                 CURRENT CHAR.POSITION
FLGS     EQU      %-CCPL-DYN
         GEN,8,24 0,0               FLAGS,CC BUFFER (SUPPLIED)
CSL      EQU      %-CCPL-DYN
         DATA     0                 CHAR.STRING LENGTH
         DATA     0                 CHAR.POS.OF 1-ST CHAR.IN FIELD
CHARS    EQU      %-CCPL-DYN
         RES      9                 CHAR.STRING BUFFER
********
CCBUF    EQU      %-DYN
         RES      20
********
IGSTRT    EQU       %-DYN            START OF IGNORE TABLE
          DATA      0
IGEND     EQU       %-DYN            END OF IGNORE TABLE
          DATA      0
INCLSTRT  EQU       %-DYN            START OF INCLUDE TABLE
          DATA      0
INCLEND   EQU       %-DYN            END OF INCLUDE TABLE
         PZE      0                 ADDR.IN WORK AREA OF 1-ST INCL.NAME
NXTNAME  EQU      %-DYN
         PZE      0                 ADDR.IN WORK AREA OF NEXT INCL.NAME
PGCNT    EQU      %-DYN             COUNT OF PAGES GOTEN BY PAGER
         DATA     0                 :
ENDFLG   EQU      %-DYN             SAYS TO EXIT AT END IF SET
         DATA     0
ENDWKARA EQU      %-DYN
         DATA     0                 END OF WORK AREA +1
DELETEF  EQU      %-DYN
         DATA     0                 DELETE OPTION FLAG (=-1 TO DELETE)
SYNFLG   EQU      %-DYN
         DATA     0                 SYNONOMOUS FILE FOUND FLAG
*                                      = 0   NONE ENCOUNTERED
*                                      > 0   YES, SYNONOMOUS FILES FOUND
#ZEROS   EQU      %-DYN-IGSTRT      # OF WORDS TO REINITIALIZE
VERSN#   EQU      %-DYN             VERSION NUMBER FOR WRITEMON
         DATA     0                 :
WRTFLG   EQU      %-DYN             FLAG FOR PO OR BO
         DATA     0                 =ORG OF OPNNXT FILES
TYPEFLG  EQU      %-DYN
         DATA     0
********
OPNTMSQN EQU      %-DYN
         GEN,8,24 X'14',M:TM        OPEN DISC TO FILE
         DATA     X'41200001'
         PZE      OTMAINCL          ABN
         DATA     1                 IN
         PZE      *D2               FPARAM
OPNAME   EQU      %-DYN
         DATA     X'1000404'
         RES      4                 FILE-NAME
         DATA     X'2010202'
OPACCN   EQU      %-DYN
         TEXT     ':SYS'
         TEXT     '    '
INCLACN  EQU      %-DYN
         DATA     0
********
OPNPO    EQU      %-DYN
         GEN,8,24 X'94',5           OPEN TAPE
         DATA     X'4D480002'
         PZE      OPOA              ABN
         DATA     10                TRIES
         PZE      *D3               ORG
         DATA     2                 OUT
         DATA     2                 SAVE
         PZE      *D4               KEYM
         DATA     X'0B000001'
         DATA     0
FPARAM   EQU      %-DYN
         RES      90                FILE PARAMETERS
********
OPNTM    EQU      %-DYN
         GEN,8,24 X'14',M:TM        OPEN DISC TO NEXT FILE
         DATA     X'49200401'
         PZE      OTMA              ABN
         DATA     10                TRIES
         DATA     1                 IN
         PZE      *D2               FPARAM
OPNTMFP  EQU      %-DYN
         DATA     X'01000000'
         DATA     X'02010002'
         DATA     0
         DATA     0
********
ENDYN    EQU      %                 END OF DYNAMIC DATA
************************************************************************
         PAGE
************************************************************************
*  OTHER DATA, PLISTS, ETC.
************************************************************************
DELM     EQU      %
         DATA,1   '.',',',' ','(',')',X'26',X'0D',X'15'
NODELM   EQU      BA(%)-BA(DELM)
CNTCOL   EQU      1
         BOUND    4
********
EOB      EQU      X'26'
ARS      EQU      4
ORG      EQU      5
KEYM     EQU      12
RWS      EQU      13
********
RDSQN    EQU      %
         GEN,8,24 X'10',M:TM        READ DISC
         DATA     X'70000010'
         PZE      RTMAINCL          ABN
         PZE      *SR2              BUF
         PZE      *SR1              SIZE
********
RDDSK    EQU      %
         GEN,8,24 X'10',M:TM        READ DISC
         DATA     X'70000010'
         PZE      RTMA              ABN
         PZE      *SR2              BUF
         PZE      *SR1              SIZE
********
WRTPE    EQU      %
         GEN,8,24 X'91',5           WRITE TAPE
         DATA     X'38000030'
         PZE      *SR2              BUF
         PZE      *R1               SIZE
         PZE      MTMKBF            KEY
********
OPNSYN   EQU      %
         GEN,8,24 X'94',5           FPT FOR SYNON TO TAPE
         DATA     X'45480802'
         DATA     OPOA              ABN
         DATA     0                 ORG
         DATA     2
         DATA     2                 OUT-SAVE
         DATA     0                 KEYMAX
         DATA     X'01000004'
RLNAME   RES      4
         DATA     X'0B010008'
SYNAME   RES      8
**********
RESETDCB RES                        FPT TO TURN OFF SECURITY INFO
         GEN,8,24 X'94',5           IN THE OUTPUT DCB
         DATA     X'7001'           ADJUSST DCB CAL
         DATA     1
RST      COM,8,8,16 AF,CF(2),0
         RST      3                 NO PASSWORD
         RST      5                 READ ACCNTS
         RST      6                 WRITE ACCOUNTES
         RST      X'14'             EXECUTE ACCOUNTS
         RST,1    X'15'             VEHICLE
OPNPOLST EQU      %
         GEN,8,24 X'94',5           OPEN TAPE
         DATA     X'07400002'
         DATA     1                 CONSEC
         DATA     1                 SEQ
         DATA     2                 OUT
         DATA     2                 SAVE
         DATA     X'01010202'       FILE NAME CONTROL
LASTLM   EQU      %
         TEXTC    'LASTLM'          FILE-NAME
*********
         BOUND    8
POIGS    EQU      %                 AUTO IGNORES FOR PO
         TEXTC    'LASTLM'
SPEC:HAND TEXTC   'SPEC:HAND'
         DATA     0
POINCLS  EQU      %                 AUTO INCLUDES FOR UTS PO
         TEXTC    'BPM'
         TEXTC    'UTS'
         TEXTC    'SIG7FDP'
         TEXTC    ':BLIB'
         TEXTC    'M:CDCB'
         TEXTC    'M:OCDCB'
         TEXTC    'M:BIDCB'
         TEXTC    'M:CIDCB'
         TEXTC    'M:SIDCB'
         TEXTC    'M:EIDCB'
         TEXTC    'M:BODCB'
         TEXTC    'M:CODCB'
         TEXTC    'M:SODCB'
         TEXTC    'M:PODCB'
         TEXTC    'M:GODCB'
         TEXTC    'M:LODCB'
         TEXTC    'M:DODCB'
         TEXTC    'M:EODCB'
         TEXTC    'M:LLDCB'
         TEXTC    'M:SLDCB'
         TEXTC    'M:ALDCB'
         TEXTC    'M:LIDCB'
         TEXTC    'T:P2SI'
         DATA     0
BOINCLS  EQU      %                 AUTO INCLUDES FOR UTS BO
         TEXTC    'XDELTA'
         TEXTC    'LOGON'
XTEL     TEXTC    'TEL'
         TEXTC    'SUPER'
         TEXTC    'DEFCOM'
         TEXTC    'SYMCON'
         TEXTC    'ANLZ'
         TEXTC    'ERRMSG'
         TEXTC    'GHOST1'
         TEXTC    'RECOVER'
         TEXTC    'ALLOCAT'
         TEXTC    'FIX'
INCLIN   TEXTC    'M:MON'           ENTRY POINT FOR BPM BO
         TEXTC    'PCL'                                              RL3
         TEXTC    'CCI'
         TEXTC    'LOADER'
         TEXTC    'PASS2'
         TEXTC    'LOCCT'
         TEXTC    'PASS3'
         TEXTC    'DEF'
         DATA     0
**********
         PAGE
*                 CHANGE STACK POINTER AMOUNT SPEC. BY 1ST ARGUMENT.
*                 SECOND ARGUMENT SPEC. AVAILABLE REGISTER.
BUMP     CNAME
         PROC
LF       LI,AF(2) AF(1)
         MSP,AF(2)  *R0
         PEND
*                 PUSH OR PULL N WORDS SPECIFIED BY 1ST ARGUMENT INTO
*                 REG'S STARTING AT 2ND ARGUMENT.
PUSH     CNAME    X'9',X'B'
PULL     CNAME    X'8',X'A'
         PROC
         DO       NUM(AF)=1
LF       GEN,1,7,4,3,17 1,NAME(1),AF(1),0,R0
         ELSE
         DO       AF(1)=1
LF       GEN,1,7,4,3,17 1,NAME(1),AF(2),0,R0
         ELSE
         DO       AF(1)=16
LF       LCI      0
         ELSE
LF       LCI      AF(1)
         FIN
         GEN,1,7,4,3,17 1,NAME(2),AF(2),0,R0
         FIN
         FIN
         PEND
         PAGE
K0       EQU      X'0'
K1       EQU      X'1'
K2       EQU      X'2'
K6       EQU      X'6'
K8       EQU      X'8'
K24      EQU      X'24'
K40      EQU      X'40'
K50      EQU      X'50'
KFF      EQU      X'FF'
KN1      EQU      -X'1'
KBLANK   EQU      ' '
KCRET    EQU      X'0D'             CARRIGE RETURN
KNL      EQU      X'15'             LINE FEED
KEOB     EQU      X'26'
KSCOLON  EQU      ';'
RECSIZE  DATA     80
Y2       DATA     X'20000000'
Y4       DATA     X'40000000'
Y8       DATA     X'80000000'
YDFFFFFFF DATA    X'DFFFFFFF'
RANORG   DATA     X'30'
PROMPT   GEN,8,24 X'2C','%'         SET PROMPT FPT
XEND     DATA     'END '            :
YC3D7    DATA     X'C3D70000'
         PAGE
*        NXACTCHR-NEXT ACTIVE CHARACTER ROUTINE GETS THE NEXT ACTIVE
*        CHARACTER FROM THE INPUT RECORD. IF A SEMICOLON IS ENCOUNTERED,
*        THE OUTR ROUTINE IS CALLED IF SPECIFIED. THEN THE NEXT
*        RECORD IS OBTAINED BY CALLING THE SPECIFIED CONTINUATION
*        ROUTINE IF A LEGAL CONTINUATION RECORD IS NOT OBTAINABLE.
*        ENTER WITH ADR OF CHAR PARAM LIST IN R7,
*        JIT POINTER IN R5 AND CUR CHAR OR ZERO IN SR1.
NXACTCHR EQU      %
         CI,SR1   K0                CHECK IF CUR CHAR = 0
         BNE      NXACH3            BRANCH IF NOT
NXACH1   EQU      %
         LW,R2    CCP,R7
         CW,R2    RECSIZE           CHECK IF CUR.POS.= REC SIZE
         BE       NXACH5            BRACH IF YES
         LW,R3    CBUF,R7
         LB,SR1   *R3,R2            PICK UP NEXT CHAR
         CI,SR1   KSCOLON           CHECK IF CUR CHAR IS A ;
         BE       NXACH6            BRANCH IF YES
         CI,SR1   KCRET             CHECK IF CARRIAGE RETURN
         BE       NXACH51
         CI,SR1   KNL
         BE       NXACH51
         CI,SR1   KEOB
         BE       NXACH51
         CI,SR1   '.'               IF CHAR. = '.', THEN END OF IMAGE
         BNE      NXACH1A           NO..
         LW,R1    RECSIZE           YES,SET TO END OF IMAGE
         STW,R1   CCP,R7
         LI,SR1   KCRET             SET CHAR. TO NL
         B        NXACH51
NXACH1A  EQU      %
         LW,R1    FLAGS,R7
         CW,R1    Y4                CHECK IF IN BLANK-OUT MODE
         BAZ      NXACH2            BRACH IF NOT
         LI,R4    K40
         STB,R4   *R3,R2            BLANK OUT CUR CHAR IN RECORD
NXACH2   EQU      %
         MTW,1    CCP,R7            SET CCP = CCP+1
NXACH3   EQU      %
         LW,R1    FLAGS,R7          (R1) = FLAGS
         CI,SR1   K40               CHECK IF CUR CHAR IS A BLANK
         BNE      NXACH4            BRANCH IF NOT
         CW,R1    Y8                CHECK IF BLANK IS ACTIVE
         BAZ      NXACH1            BRANCH IF NOT
NXACH4   EQU      %
         CI,SR1   KCRET             CHECK IF CARRIAGE RETURN
         BE       NXACH51
         CI,SR1   KNL
         BE       NXACH51
         CI,SR1   KEOB
         BE       NXACH51
         CI,SR1   '.'               END OF IMAGE
         BE       NXACH51           YES.
         LW,R1    CLD,R7            (R1) = # OF DELIM, BYTE ADR OF DLM
         LB,R2    R1                (R2) = # OF DELIM
NXACH8   EQU      %
         CB,SR1   0,R1              CHECK IF CUR CHAR IS A DELIM
         BE       NXACH9            BRANCH IF YES
         AI,R1    K1
         BDR,R2   NXACH8
         LCI      K0                SET  CC1 = 0
         B        *SR4              EXIT
NXACH9   EQU      %
         LCI      K8                SET CC1 TO INDICATE CUR CHAR IS DLM
         B        *SR4
*
NXACH5   EQU      %
         LI,SR1   KEOB              SET CUR CHAR  = EOB
NXACH51  EQU      %
         PUSH     SR4
         LW,R1    OUTR,R7
         BEZ      NXACH52
         BAL,SR4  *R1               LIST LAST RECORD
NXACH52  EQU      %
         PULL     SR4
         B        NXACH9
*
NXACH6   EQU      %
         PUSH     2,SR3
         LW,R1    OUTR,R7
         BEZ      NXACH7
         BAL,SR4  *R1               GO TO OUTR ROUTINE
NXACH7   EQU      %
         LW,R1    CONTR,R7
         LB,R2    R1
         STW,R2   CCP,R7            SET CCP = CP (CONTINUATION POS)
         BAL,SR4  *R1               GET CONTINUATION RECORD
         LB,R2    SR3               (R2) = I/O COMPLETE CODE
         PULL     2,SR3
         CI,R2    K6                CHECK IF CONT. RECORD OBTAINED
         BE       NXACH1            BRANCH IF YES
         LI,SR1   KFF               SET CUR CHAR = FF
         LCI      K8                SET CC1 =1, ERR IN GETTING CONT
         B        *SR4                                            RECORD
         PAGE
*        NAMSCAN-SCANS FOR LEGAL ALPHA NUMERIC NAME.
*        IF LEGAL CC1 =0, IF NOT CC1 = 1
*        ENTER WITH ADR OF CCPL IN R7, CUR CHAR OR ZERO IN SR1
*
*
*
NAMSCAN  EQU      %
         PUSH     13,SR4
         LW,R5    R3
         BAL,SR4  GETCHST           GET CHARACTER STRING
         BCS,8    COMEXIT2          BRANCH IF ILLEGAL STRING
         LI,R4    K0
NAMS1    EQU      %
         LB,R3    *R7,R2            SET (R3) = ITH CHAR
         LB,R3    CHTBL,R3          CHECK IF CHAR LEGAL ALPHANUMERIC
         BEZ      COMEXIT2            BRANCH IF NOT
         OR,R4    R3                   MERGE TYPE
NAMS2    EQU      %
         AI,R2    K1
         BDR,R1   NAMS1             SET N# N-1
         CI,R4    K2                CHECK IF AT LEAST ONE ALPHABETIC
         BL       COMEXIT2
         B        COMEXIT1
         PAGE
*        CHARSCAN-COMPARES CUR CHAR WITH CHAR IN SR2. IF =, CC1 =0.
*        IF NOT CC1 = 1.
*        ENTER WITH PARAMETER LIST ADR IN R7, CUR CHAR OR ZERO IN SR1,
*        AND COMPARISON CHAR IN SR2.
*
CHARSCAN EQU      %
         PUSH     13,SR4
         LW,R5    R3
         BAL,SR4  NXACTCHR          GET NEXT ACTIVE CHAR
CHRS1    EQU      %
         CW,SR1   SR2
         BNE      CHRS3             BRANCH IF NOT
         LI,SR1   K0                SET CUR CHAR = 0
         PULL     13,SR4
         LCI      K0                SET CC1 =  0
         B        *SR4
CHRS3    EQU      %
         PULL     13,SR4
         LCI      K8
         B        *SR4              EXIT
CHRS0    EQU      0
         PAGE
*        HEXSCAN-SCANS FOR HEXIDECIMAL NUMBER.
*        IF LEGAL HEX # CC1 = 0 ,IF NOT CC1 = 1
*        ENTER WITH ADR OF PARAMETER LIST IN R7, CUR CHAR OR 0 IN SR1
*
*
*
HEXSCAN  EQU      %
         PUSH     13,SR4
         LW,R5    R3
         BAL,SR4  GETCHST           GET CHAR STRING
         BCS,8    COMEXIT2          BRANCH IF ILLEGAL CHAR STRING
HEXS1    EQU      %
         LB,R3    *R7,R2            SET (R3) =  ITH CHAR IN STRING
         LB,R3    CHTBL,R3
         BEZ      COMEXIT2          BRANCH IF NOT LEGAL ALPHANUMERIC
         CI,R3    K2                CHECKIF LEGAL HEX CHAR
         BG       COMEXIT2          BRANCH IF NOT
         AI,R2    K1
         BDR,R1   HEXS1             SET N =N-1
COMEXIT1 EQU      %
         LW,R3    YDFFFFFFF         RESET BUFFER
         AND,R3   FLAGS,R7                   EMPTY
         STW,R3   FLAGS,R7                        FLAG
         PULL     13,SR4
         LCI      K0                SET CC1 = 0
         B        *SR4              EXIT
         PAGE
*        QUOTSCAN-COMPARE QUOTE CONSTANT WITH CHAR STRING AND IF = SETS
*        CC1= 0 ,OTHERWISE SETS CC1 = 1.
*        QUOTE CONSTANT AND CHAR STRING CAN BE = ONLY IF THEY ARE
*        OF THE SAME LENGTH
*        ENTER WITH ADR OF PARAM LIST IN R7, CUR CHAR OR 0 IN SR1,
*        AND WORD ADR OF QUOTE CONSTANT IN SR2.
QUOTSCAN EQU      %
         PUSH     13,SR4
         LW,R5    R3
         BAL,SR4  GETCHST           GET CHAR STRING
         BCS,8    COMEXIT2          BRANCH IF ILLEGAL STRING
         LW,R4    SR2               (R4) = QUOTE CONSTANT ADR
         SLS,R4   2                 CONVERT TO BYTE ADR
         CB,R1    QC0,R4            COMPARE LENGTHS
         BNE      COMEXIT2
QUTS1    EQU      %
         AI,R4    K1
         LB,R3    *R7,R2
         CB,R3    QC0,R4            COMPARE CHARS
         BNE      COMEXIT2
         AI,R2    K1
         BDR,R1   QUTS1
         B        COMEXIT1
*
         PAGE
*        DECSCAN- SCANS FOR DECIMAL #.
*        IF LEGAL DEC # CC1 = 0, IF NOT CC1= 1
*        ENTER WITH ADR OF PARAM LIST IN R7 AND CUR CHAR OR 0 IN SR1.
*
*
DECSCAN  EQU      %
         PUSH     13,SR4
         LW,R5    R3
         BAL,SR4  GETCHST           GET CHAR STRING
         BCS,8    COMEXIT2          BRANCH IF ILLEGAL CHAR STRING
DECS1    EQU      %
         LB,R3    *R7,R2            SET (R3) = ITH CHAR IN STRING
         LB,R3    CHTBL,R3          CHECK IF
         CI,R3    K1                         LEGAL DECIMAL  CHAR
         BNE      COMEXIT2          BRANCH IF NOT
         AI,R2    K1
         BDR,R1   DECS1             SET N = N-1
         B        COMEXIT1
*
COMEXIT2 EQU      %
         PULL     13,SR4
         LCI      K8                SET CC1 = 1
         B        *SR4              EXIT
         PAGE
*        CHSTSCAN-CHARACTER STRING SCAN- GETS THE NEXT CHARACTER
*                 STRING UP TO THE NEXT DELIMITER AND MOVES THE
*                 STRING TO THE PARAMETER LIST BUFFER.
*        ENTER WITH JOB POINTER IN R5, PARAM LIST POINTER IN R7,
*        CUR CHAR OR ZERO IN SR1
*        IF  N= 0  OR N > 31 CC1 IS SET  TO 1 . IF CHAR STRING IS NOT
*        OBTAINABLE BECAUSE OF ERROR IN TRYING TO OBTAIN A CONT. RECORD,
*        CC1 AND CC2 ARE BOTH SET TO ONE
*
CHSTSCAN EQU      %
         PUSH     13,SR4
         LW,R5    R3
         LI,R1    KBLANK
         LI,R2    BAPLB             (R2) = BYTE ADR OF PARAM LIST BUF
         LI,R3    K24
CHSTS1   EQU      %
         STB,R1   *R7,R2            FILL PARAM LIST BUFFER
         AI,R2    K1                            WITH BLANKS
         BDR,R3   CHSTS1
*
         LI,R2    K0                SET
         LW,R3    Y8                   BLANK
         STS,R2   FLAGS,R7                   NOT ACTIVE
*
         LI,R1    K0
         LI,R2    PLB
         AW,R2    R7
         LI,R3    K24
CHSTS2   EQU      %
         PUSH     3,R1
         BAL,SR4  NXACTCHR          GET NEXT ACTIVE CHAR
         BCS,8    CHSTS4            CHECK IF CHAR IS A DELIMITER
         LW,R3    Y8                SET
         STS,R3   FLAGS,R7              BLANK ACTIVE
         PULL     3,R1
         CI,R1    K0                CHECK IF FIRST CHAR OF FIELD
         BNE      CHSTS22
         LW,D1    CCP,R7            SET PCCP = CHAR POSITION OF 1ST
         AI,D1    KN1
         STW,D1   PCCP,R7                         CHAR OF FIELD
CHSTS22  EQU      %
         STB,SR1  *R2,R1            STORE CHAR IN BUFFER
         LI,SR1   K0                SET CUR CHAR =0
         AI,R1    K1                SET  N= N+1
         BDR,R3   CHSTS2
CHSTS21  EQU      %
         STW,R1   CSL,R7
         LI,R2    K0
         LW,R3    Y8
         STS,R2   FLAGS,R7
         PULL     13,SR4
         LC       Y8
         B        *SR4
CHSTS3   EQU      %
         STW,R1   CSL,R7            STORE N IN PARAM LIST
         LI,R2    K0                SET
         LW,R3    Y8                   BLANK
         STS,R2   FLAGS,R7                   NOT
         PULL     13,SR4
         LCI      K0
         B        *SR4              EXIT
CHSTS4   EQU      %
         PULL     3,R1
         CI,R1    K0                CHECK IF  N= 0
         BNE      CHSTS3
         B        CHSTS21
*
         PAGE
*        GETCHST-GETS THE NEXT CHAR STRING IF THE PARAM LIST BUFFER
*        IS EMPTY AND MARKS THE PARAM LIST BUFFER AS FULL. SETS
*        (R0) = (R1) = N, (R2) = BYTE ADR OF PARAM LIST BUFFER.
*        ENTER WITH ADR OF PARAM LIST IN R7, CUR CHAR OR 0 IN SR1.
*
*
GETCHST  EQU      %
         LI,R4    K0                FOR CONTINUATION
         LW,R3    Y2                CHECK
         AND,R3   FLAGS,R7               IF PARAM LIST BUF IS FULL
         BNEZ     GCHST1            BRANCH IF FULL
         PUSH     1,SR4
         STW,R5   R3
         BAL,SR4  CHSTSCAN          SCAN FOR CHAR STRING
         STCF     R4
         PULL     1,SR4
GCHST1   EQU      %
         LW,R1    CSL,R7
         LI,R2    BAPLB             (R2) = BYTE ADR OF PARAM LIST BUF
         LW,R3    Y2                SET
         STS,R3   FLAGS,R7               PARAM LIST BUF NOT EMPTY FLAG
         LC       R4
         B        *SR4              EXIT
         PAGE
C300     EQU      X'00030000'
C3000    EQU      X'03000000'
C33      EQU      X'00000303'
C3300    EQU      X'03030000'
C333     EQU      X'00030303'
C3333    EQU      X'03030303'
C222     EQU      X'00020202'
C2223    EQU      X'02020203'
C1100    EQU      X'01010000'
C1111    EQU      X'01010101'
CHTBL    DATA     0,0,0,0               0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
         DATA     0,0,0,0               0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
         DATA     0,0,0,0               0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
         DATA     0,0,0,0               0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
         DATA     0,0,0,3               0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3
         DATA     0,0,3,0               0 0 0 0 0 0 0 0 0 0 0 3 0 0 0 0
         DATA     0,0,0,C300            0 0 0 0 0 0 0 0 0 0 0 0 0 3 0 0
         DATA     0,0,C33,C3000         0 0 0 0 0 0 0 0 0 0 3 3 3 0 0 0
         DATA     C222,C2223,C3300,0    0 2 2 2 2 2 2 3 3 3 0 0 0 0 0 0
         DATA     C333,C3333,C3300,0    0 3 3 3 3 3 3 3 3 3 0 0 0 0 0 0
         DATA     C33,C3333,C3300,0     0 0 3 3 3 3 3 3 3 3 0 0 0 0 0 0
         DATA     0,0,0,0               0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
         DATA     C222,C2223,C3300,0    0 2 2 2 2 2 2 3 3 3 0 0 0 0 0 0
         DATA     C333,C3333,C3300,0    0 3 3 3 3 3 3 3 3 3 0 0 0 0 0 0
         DATA     C33,C3333,C3300,0     0 0 3 3 3 3 3 3 3 3 0 0 0 0 0 0
         DATA     C1111,C1111,C1100,0   1 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0
QC0      EQU      0
CLD      EQU      0
CONTR    EQU      1
OUTR     EQU      2
FLAGS    EQU      4
CBUF     EQU      4
PCCP     EQU      6
PLB      EQU      7
BAPLB    EQU      4*PLB
DEFPATCH EQU      %
         RES      25
************************************************************************
         END      DEF

