         TITLE    'SYSGEN PASS2 CCI - CONTROL COMMAND INTERPRETER'
*********************************************************************
*M*      P2CCI    CONTROL COMMAND INTERPRETER FOR PASS2             *
*********************************************************************
*                 CATALOG NO. 704896 - M:SYSCCI2 (SYSGEN PASS2 C.C.I.)
         SYSTEM   BPM
         SYSTEM   SIG7FDP
*
*
* * * * * * * * * * SYSGEN PASS2  * * * * * * * * * *
* * * * * * * * * * * * * * * * * * * * * * * * * * *
* * * * * * * * * * CP-V  MONITOR * * * * * * * * * *
*
*
*                 SYMBOLIC REGISTER DEF'S.
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
*                 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
************************************************************************
*  D E F ' S
*****************
         DEF      PASS2
         DEF      PRINTMSG,OUTLLERR,PASS2OUT
         DEF      ABNMOD
         DEF      READSTRG,RDINCFCH
         DEF      READCONT
         DEF      SSIZE,CORE
         DEF      RATPTR,#RATS,RATBMAXPTR,#MXSTRM
         DEF      SYMBCOUNT,DCTSIZE,DCT16TEMP
         DEF      FIRSTDP
         DEF      PRIVDEV,P2DYNEND
         DEF      FETCHCSL,FETCHADR
         DEF      FETCHLST
         DEF      TBSZPTR,TBMAXPTR,TBFLGSPTR
         DEF      DCT4TEMP,TYCOUNT
         DEF      #GRANPER
         DEF      SYMBVAL,SYMBACT
         DEF      SCPUFLG
         REF      SCPU
         DEF      SDGANSG,FETCHBUF
         DEF      COCS
         DEF      AVTBLGTH
         DEF      P2OVLOP
         DEF      P2ERR
         DEF      P2PATCH
         DEF      LORBIN,HIRBIN,#RBTS
         DEF      GETPGS,NOROOM,#PAGES,GETPGPTR,ENDUSED
         DEF      SYMBPTR,SYMBDEV,SYMBTYPE,#LDV,LDVPTR
         DEF      SBLTYPTR,TYPMNEAD,TYPMNESZ,BTXPTR
         DEF      OTXPTR,GTXPTR,LDVCONST
         DEF      P2ABRT,PASS2ABRT
         DEF      SVDFTP
         DEF      DUALFLG
         DEF      FEDX#
         DEF      INT#
         DEF      COCFEX#
         DEF      CONVTBL
         DEF      LISTIT
         DEF      ERROUTS
         DEF      DECS1
         DEF      FLAGS
         DEF      HEXS1
         DEF      FDB:DCT
         DEF      FDB:FEX
         DEF      GOTTENPGS
         DEF      CONVT
         DEF      SWAPUTS,SCYLPSA
         DEF      BIGLOC
         DEF      HAND2FLG
         DEF      MINCOCFL
         DEF      CPOOL
         DEF      MPOOL
         DEF      TCLSIZES
         DEF      TPSZWID
         DEF      DCT1TEMP
         DEF      LPART#,FAUTPTR
         DEF      MCDEV
         DEF      DP3275
         DEF      M17
         DEF      EXPHWRT
         DEF      M15X17
         DEF      M12LFT
         DEF      RBSIZ
         DEF      PRNTP2SI
         DEF      LOGIT
         DEF      ABNERR2
************************************************************************
*  R E F ' S
*****************
         REF      M:SI,M:TM,M:C
         REF      M:EI
         REF      M:EO
         REF      UBCHAN
         REF      UBMONITOR
         REF      UBBLIMIT,UBOLIMIT,UBELIMIT
         REF      SDEVICE
         REF      COC,SPROCS,IMC
         REF      UTXPART
         REF      GHOST
************************************************************************
         REF      CHDVEND
         REF      OPLBLT,LDEVICE,M:X1
         REF      RESOURCE,UBGLIMIT
         REF      FRGD,INTLB,FAUTH
         PAGE
************************************************************************
*  PASS2 STACK ALLOCATION -- POINTED TO VIA (R3).
************************************************************************
BASESTAC EQU      0      REL.DISPLACEMENT TO STACK BASE
********                          ****
SSIZE    EQU      BASESTAC+1        1ST DISC SECTOR SIZE (PSA DISC)
CORE     EQU      BASESTAC+2          CORE SIZE(FROM :MONITOR)
SDGANSG  EQU      BASESTAC+3        #SECT/GRAN FOR 1ST DISC (PSA DISC)
#GRANPER EQU      BASESTAC+4        #GRAN PER
CCBUFRS  EQU      BASESTAC+5        BASE OF BUFFERS
********                          ****
BUFFADDR EQU      CCBUFRS+0           POINTER TO CC BUFFER(=BUFFER)
BUFFER   EQU      CCBUFRS+1           CONTROL COMMAND BUFFER(20 WORDS)
BUFFADDR1 EQU     CCBUFRS+21        EXTRA WORD FOR LONG READS
FETCHLST EQU      CCBUFRS+22        CC PROCESSOR PARAM.LIST (7 WORDS)
FETCHCCP EQU      CCBUFRS+25        CURNT.CHAR.POS.PROCESSED IN CC
FETCHCSL EQU      CCBUFRS+27        CHAR.STRING LENGTH OF FIELD IN CC
FETCHBUF EQU      CCBUFRS+29        CC CHAR.STRING BUFFER (9 WORDS)
FETCHADR EQU      CCBUFRS+38        POINTER TO FETCHLST (=FETCHLST)
XBUFADDR EQU      CCBUFRS+39        POINTER TO XBUFFER (=XBUFFER)
XBUFFER  EQU      CCBUFRS+40        ERROR BUFFER FOR % CHAR.
SCPUFLG  EQU      CCBUFRS+60        SLAVE CPU'S PRESENCE FLAG
         PAGE
CHANFLG  EQU      SCPUFLG+1         CHAN CC ENCOUNTERED
P2OVLOP  EQU      SCPUFLG+2         FLGS FOR OPTION MON. OVERLAYS
P2ERR    EQU      SCPUFLG+3         COUNT OF # OF ERR MESSAGES
P2ABRT   EQU      SCPUFLG+4         PASS2 DELAYED ABORT FLAG
MINCOCFL EQU      SCPUFLG+5         MINICOC PRESENCE FLAG
****
RCHAN    EQU      SCPUFLG+6         #CHAN CMNDS FOR UBCHAN
CHCTR    EQU      RCHAN+1           CTR OF CHAN BY ROOT
DVCTR    EQU      RCHAN+2           CTR OF DEVICE BY ROOT
CCPTR    EQU      RCHAN+3           PTR TO CMND PROCESSING
****
DYSTORND EQU      CCPTR+1           END AVAILABLE CORE
SAVEPAGE EQU      CCPTR+2           #PAGES CORE, 1ST PAGE ADR.
GETPGPTR EQU      CCPTR+3           LAST ADR. OF PAGE GOTTEN
#PAGES   EQU      CCPTR+4           #PAGES GOTTEN FOR PERM AREA
ENDUSED  EQU      CCPTR+5           END OF CURRENT USED AREA
****
DP3275   EQU      ENDUSED+1         # OF 3275 DP'S AND CHANNEL SYMBOL
*                                   (MAX=36 CHANNEL SYMBOLS IN TBL)
COCS     EQU      DP3275+10         #COCS & ADDRESS (MAX = 8)
COCFEX#  EQU      COCS+5            8-BYTE COC ASSOCIATED FEX # TBL
AVTBLGTH EQU      COCFEX#+3         # OF TAPE ENTRIES
LORBIN   EQU      COCFEX#+4         LOW RBT DCT INDEX
HIRBIN   EQU      COCFEX#+5         HIGH RBT DCT INDEX
#RBTS    EQU      COCFEX#+6         # OF RBTS DEFINED ON :DEVICE CC
DUALFLG  EQU      COCFEX#+7         DUALFLG FOR :CHAN CC
BIGLOC   EQU      COCFEX#+8         BIG FLAG SET IN XMONITOR MODULE
****
SCYLPSA  EQU      BIGLOC+1          #GRAN/PHY CYLIN IN LEFT HALF
*                                   AND # PHY CYLIN IN RIGHT HALF
SWAPUTS  EQU      SCYLPSA+1         DP SWAPPER
HAND2FLG EQU      SCYLPSA+2         HANDLERS2 PRESENCE FLAG
PRIVDEV  EQU      SCYLPSA+3         TOT # OF PRIVATE PACKS
****
DCTSIZE  EQU      PRIVDEV+1         #DCTS+1 (AFTER UBCHAN)
TYPMNEAD EQU      DCTSIZE+1         PTR TO TYPMNE TABLE IN PERM AREA
TYPMNESZ EQU      DCTSIZE+2         #TYPMNE ENTRIES
TBSZPTR  EQU      DCTSIZE+3         PTR TO TB:SZ     :MUST
TBMAXPTR EQU      DCTSIZE+4         PTR TO TB:MAX    : BE
TBFLGSPTR EQU     DCTSIZE+5         PTR TO TB:FLGS   :IN
TBFLGS1PTR EQU    DCTSIZE+6         PTR TO TB:FLGS1  :ORDER
TYCOUNT  EQU      DCTSIZE+7         PTR TO COUNT OF OCCUR. OF TYPE
BTXPTR   EQU      DCTSIZE+8         PTR TO BTX TBL
OTXPTR   EQU      DCTSIZE+9         PTR TO OTX TBL
GTXPTR   EQU      DCTSIZE+10        PTR TO GTX TBL
DCT1TEMP EQU      DCTSIZE+11        PTR TO DCT1 TEMP
DCT4TEMP EQU      DCTSIZE+12        PTR TO DCT4 TEMP
DCT16TEMP EQU     DCTSIZE+13        PTR TO DCT16 TEMP
****
SYMBPTR  EQU      DCT16TEMP+1       PTR TO SYMB DEV TYPE TABLE
SYMBDEV  EQU      SYMBPTR+1         #SYMB DEVICE TYPES
SYMBTYPE EQU      SYMBPTR+2         PTR TO SYMB TYPE INDEX TBL
SYMBCOUNT EQU     SYMBPTR+3         # SYMB DEVICES
SYMBVAL  EQU      SYMBPTR+4         #ENTRIES IN SYMBACT
SYMBACT  EQU      SYMBPTR+5         DW TEXT OF SYMB DEVICES
FAUTPTR  EQU      SYMBPTR+6         FAUTH ENTRIES
#MXSTRM  EQU      SYMBPTR+7         # MXSTRM ENTRIES
****
#RATS    EQU      #MXSTRM+1         #RAT ENTRIES
RATPTR   EQU      #RATS+1           PTR TO RAT TABLE
RATBMAXPTR EQU    #RATS+2           PTR TO BMAX TABLE
LDVPTR   EQU      #RATS+3           PTR TO LDEV TABLE
#LDV     EQU      #RATS+4           #LDEV ENTRIES
SBLTYPTR EQU      #RATS+5           PTR TO SB:LTY TALBE
LDVCONST EQU      #RATS+6           CONSTANT FOR LDEV INDEX
SVDFDK  EQU       #RATS+7           1ST DISK TYPE INDEX
SVDFTP   EQU      #RATS+8           1ST TAPE TYPE INDEX
LPART#   EQU      #RATS+9
MCDEV    EQU      #RATS+10          MC DEV FLAG
TCLSIZES EQU      #RATS+11          POINTER TO CLIST SIZE HW TABLE
TPSZWID  EQU      #RATS+12          PTR. TO PAPER WIDTH & SIZE TBL
MPOOL    EQU      RCHAN             RCHAN REDEFINED FOR USE BY XMONITOR
CPOOL    EQU      CHCTR             CHCTR REDEFINED FOR USE BY XMONITOR
FDB:DCT  EQU      #RATS+13          PTR TO DCTX TABLE FOR FECP DEVICES
FDB:FEX  EQU      #RATS+14          PTR TO FDB:FEX FEX # TBL
FEB:CDX  EQU      #RATS+15          PTR TO FEB:CDX FE DCTX TBL
FEDX#    EQU      #RATS+16          CONTAINS  0 OR NUMBER OF FECP DEVICES
*                                   IN RT H.W. & HIGHEST FEX# IN LT H.W.
INT#     EQU      #RATS+17          SINCE FEX RANGES FROM 1 TO 4
*                                    A MAXIMUM OF 3 WORDS USED FOR
*                                   FOR SAVING CORRESPONDING INTERRUPTS
FIRSTDP  EQU      #RATS+20          FIRST BYTE = DEVICE TYPE INDEX (+1)
*                                   RIGHT HALF = DEVICE NAME FOR FIRST
*                                    DP (YY PART OF YYNDD)
P2DYNEND EQU      #RATS+21
         PAGE
*****************************************************
*
* * * START CCI TO DETERMINE CARD TYPE AND PROCESSING ROUTINE
*
PASS2    EQU      %
         M:TRAP   (IGNORE,BOTH)
         LW,R3    *R0
         BUMP     P2DYNEND,R1
         LI,R1    P2DYNEND
         LI,R2    K0
         STW,R2   *R3,R1            CLEAR RESERVE AREA
         BDR,R1   %-1
*
* NOW SET POINTERS IN DYNAMIC RESERVE
*
         LI,R1    BUFFER
         AW,R1    R3
         STW,R1   BUFFADDR,R3
*
         LI,R1    XBUFFER
         AW,R1    R3
         STW,R1   XBUFADDR,R3
         LW,R2    XBLANKS
         LI,R4    K14
         AI,R1    KN1
         STW,R2   *R1,R4
         BDR,R4   %-1
*
         LCI      K7                 PLIST
         LM,SR1   FETCHSTR            FOR
         LW,D1    BUFFADDR,R3          FETCH
         LCI      K7
         STM,SR1  FETCHLST,R3
*
         LW,SR4   Y05               SET TO NO VFC
         AI,SR4   M:LL
         LI,D1    K0
         CAL1,1   SR4
*
         LI,R1    FETCHLST
         AW,R1    R3
         STW,R1   FETCHADR,R3
         BAL,SR4  STARTP2M
*
         LC       *X'4F'            GET ADDRESS OF JIT
         BCR,8    READFRST
         M:TYPE   (MESS,TYPURSER)
         B        BLDCMND
*
READFRST EQU      %
         LCI      5
         LM,SR4   READC
         LW,D3    BUFFADDR,R3
         LW,R5    R3
         CAL1,1   SR4      ***      READ !PASS2   'TYPE'  CC
         PAGE
*     ROUTINE TO BUILD IDL FILE OF PASS2 COMMANDS
*     READ FROM M:SI, WRITE KEYED FILE THROUGH M:XI
*
BLDCMND  EQU      %
         LCI      15
         PSM,R1   *R0
         LW,R1    *X'4F'
         AND,R1   =X'0000FFFF'
         SLS,R1   8                 FORM IDL FILENAME
         OR,R1    =X'030000D3'
         STW,R1   FILENAME
         CAL1,1   OPENX1
         M:OPEN   M:EO,(FILE,'T:P2SI'),(CONSEC),(SEQUEN),(OUT),;
                       (SAVE),(ABN,ABNEO),(ERR,ERREO),(WRITE,'NONE')
READSI   EQU      %
         LCI      5
         LM,SR4   RDSI              LOAD FPT FOR READ
         LW,D3    BUFFADDR,R3
         CAL1,1   SR4               READ,ABN/ERR = ABNSI
         LW,SR4   *D3
         LW,D1    =X'FFFFFF00'
         AND,D1   SR4
         CW,D1    XEND
         BE       ENDPROC
         LH,SR3   M:SI+4            GET RECORD SIZE
         SLS,SR3  -1
         STW,SR3  BUFX1             STORE AS SIZE FOR WRITE
         STW,SR3  R4                SAVE FOR SEARCH
         CI,SR3   81                CC OVER 80 CHARS?
         BL      %+7                NO
         LW,SR3   BUFFADDR1,R3      GET LAST CHAR READ
         SLS,SR3  -24               GET INTO PROPER POSITION
         CI,SR3   KCRET
         BE       %+3
         CI,SR3   KNL
         BNE      ERRBORT3
         LI,R1    0
         LB,SR3   *D3               GET 1ST BYTE
         CI,SR3   '*'               IS IT ASTERISK
         BE       WRITEX1           YES,GO WRITE W. CURRENT KEY
         CI,SR3   KCRET
         BE       READSI
         CI,SR3   KNL
         BE       READSI
         CW,SR4   XUTM              IS IT UTM COMMAND
         BNE      %+3               NO
         LI,R1    UTINDX            SET UP INDEX FOR :MON CMND
         B        WRITEX1-1
         CW,SR4   XHAND
         BNE      %+2
         MTW,1    HAND2FLG,R3       SET FLAG WHEN :HANDLERS2 ENCOUNTERED
         LI,R1    -#CMNDS
         LI,SR3   CMNDS             TABLE SEARCH FROM TOP
         AI,SR3   #CMNDS
         CW,SR4   *SR3,R1
         BE       CMNDCOUNT
         BIR,R1   %-2
         LI,SR4   0
         XW,SR4   CONTFLG           CONTINUATION ?
         BNEZ     WRITEX1           YES
         LW,D4    BUFFADDR,R3
         STB,SR4  *D4
         B        WRITEX1
CMNDCOUNT EQU     %
         AI,R1    #CMNDS            GET TRUE INDEX
         BNEZ     WRITEX1-1         NOT CHAN CMND
         MTB,1    CCFND,R1          COUNT CHAN
         AI,R1    1                 CHANGE INDEX TO DEVICE
         B        %+2
         MTB,1    CCFND,R1
WRITEX1  EQU      %
         LI,R2    0
         LW,D4    BUFFADDR,R3       SEARCH FOR SEMICOLON
         LI,D3    KSCOLON
         CB,D3    *D4,R2
         BE       SETFLG
         AI,R2    1
         BDR,R4   %-3
         B        SETFLG+1
SETFLG   MTW,1    CONTFLG
         LI,D4    KEYCMND
         AW,D4    R1                GET TRUE KEY ADDR
         STW,D4   KEYX1
         LW,D2    BUFFADDR,R3
         STW,D2   BUFADD
RETRYWRT CAL1,1   WRIX1             WRITE OUT EACH RECORD OF PASS2 SI
         MTW,1    KEYCMND,R1
*                                   ABN/ERR =ABNX1
         CI,R1    0
         BNE      STOKEY
         LW,SR4   *KEYX1
         SLS,SR4  -8
         CW,SR4   =X'03C3C4'        IS IT CD
         BNE      %+4
         LW,SR4   *KEYX1
         STW,SR4  KEYCMND+1
         B        STOKEY+1
         CW,SR4   =X'03C1E2'        IS IT AS
         BE       READSI
STOKEY   EQU      %
         LW,SR4   *KEYX1            GET KEY USED
         STW,SR4  CURKEY            KEY ALREADY INCREMENTED
         B        READSI            GET NEXT RECORD
*
ENDPROC  EQU      %
         LI,R1    2
         MTB,0    CCFND,R1          HAS THERE BEEN A CMND
         BEZ      GETDUM
         AI,R1    1
         CI,R1    #CMNDS
         BL       ENDPROC+1
ENDUP    LH,R2    CCFND
         LI,R1    X'FF'
         AND,R2   R1
         STW,R2   DVCTR,R3
         LB,R2    CCFND
         STW,R2   CHCTR,R3
         LI,SR3   KEYCMND
         LI,R4    3
         LI,R2    0
         STB,R2   *SR3,R4           ZERO OUT KEY #
         AI,SR3   1
         CI,SR3   KEYCMND+#STDKEYS
         BL       %-3
         LW,R2    =X'03C1E200'
         STW,R2   CURKEY            SET CURRENT KEY TO ASTERISK
         M:CLOSE  M:X1,(SAVE)
         LW,R1    M:EI+22           HAS M:EI BEEN ASSIGNED
         CI,R1    X'FF00'
         BANZ     READCMND          BRANCH IF SO
         M:OPEN   M:EI,(FILE,'M:MODNUM',':SYS'),(ABN,ABNMOD),;
                  (ERR,ABNMOD),(SAVE)     SET M:EI TO MOD. NUMBER FILE
         M:CLOSE  M:EI,(SAVE)        IN :SYS ACCOUNT
         B        READCMND
*
GETDUM   EQU      %
         LI,D2    CMNDS
         AW,D2    R1                BUFFER ADDR
         STW,D2   BUFADD
         LI,D3    4
         STW,D3   BUFX1
         LI,D4    KEYCMND
         AW,D4    R1
         STW,D4   KEYX1             KEY ADDR
         CAL1,1   WRIX1
         AI,R1    1
         CI,R1    #CMNDS            ALL DONE
         BL       ENDPROC+1         NO
         B        ENDUP
         PAGE
*
READCMND EQU      %                 ENTRY FOR 1ST READ ONLY
         LI,R1    0
         STW,R1   CCPTR,R3
         LI,R1    ABNKEY
         STW,R1   OPENX1+2          CHANGE ERROR
         STW,R1   OPENX1+3          ABN ADDR
         LI,R1    1                 SET MODE
         STW,R1   OUTINX1           IN
         CAL1,1   OPENX1
*
NEXTCARD EQU      %
READSTRG EQU      %                 RETURN FOR READING NXT CC
         LI,SR4   X'1FFFF'
         LS,SR4   FETCHCCP+1,R3
         STW,SR4  FETCHCCP+1,R3
         LW,R5    R3
         LW,R1    CCPTR,R3          GET CURRENT KEY INDEX
         BLZ      PASS2OUT
         BAL,R4   RDINCFCH          READ RECORD
READOK   EQU      %
         LI,R1    3                 THIS CODE CHECKS FOR DUPLICATE
         LB,R1    CURKEY,R1         CALLS TO THE COMMAND PROCESSORS
         CI,R1    1                 O.K. IF IT'S A 1
         BLE      GETBRNCH
         LW,R1    CCPTR,R3          NEED TO CHECK FOR SPECIAL CASE OF
         CI,R1    20                MORE THAN 1 :FECP CC (KEY #20)
         BNE      ERRBORT4          ONLY :CHAN, :DEVICE, & :FECP
*                                   MAY HAVE MORE THAN 1 CC
         B        ENTRY,R1
GETBRNCH LW,R1    CCPTR,R3
         BLZ      PASS2OUT
         B        ENTRY,R1
PRTASTR  M:PRINT  (MESS,ASTER)
         PAGE
*
* * * GET OUT OF PASS2 SYSGEN HERE * * *
*
PASS2OUT EQU      %
         EXU      PRTASTR
         M:PRINT  (MESS,BLANK)
         LW,R1    =X'00200000'
         CW,R1    M:X1
         BAZ      %+2
         M:CLOSE  M:X1,(SAVE)
         CW,R1    M:EO
         BAZ      %+2
         M:CLOSE  M:EO,(SAVE)
PASS2DUN EQU      %
         M:PRINT  (MESS,DOTDOT)
         M:PRINT  (MESS,BLANK)
         LW,SR3   P2ERR,R3          GET COUNT OF ERR AND WARNINGS
****THIS CODE CONVERTS THE # OF WARNINGS AND ERRORS TO DECIMAL
         LD,R4    XBLANKS
         STW,R4   UNISAV
         SCD,R4   8
         CW,SR3   TEN
         BL       UNITS             B IF # IS < 10
         LI,SR4   0
         XW,SR3   SR4               SET UP FOR DEVIDE
         DW,SR3   TEN
         CW,SR4   TEN               SR4= QUOTIENT. NOW CHECKING
         BL       TENS              FOR ERRORS IN THE HUNDREDS
         STW,SR3  UNISAV            HERE IF IN THE HUNDREDS
         LI,SR3   0
         DW,SR3   TEN
TENS     AW,R4    SR4               EITHER TENS OR HUNDREDS
         SCD,R4   8
         AW,R4    SR3
         LW,SR3   UNISAV
         CW,SR3   XBLANKS
         BE       %+3
         SCD,R4   8
UNITS    AW,R4    SR3
         SCS,R4   8
PUTNMSG  STW,R4   P2ERRMSG+3        STORE COUNT IN MESSAGE
         M:PRINT  (MESS,P2ERRMSG)    PRINT # OF ERR. AND WARNINGS
         M:PRINT  (MESS,BLANK)
         M:PRINT  (MESS,DOTDOT)
         M:PRINT  (MESS,DOTDOT)
         LI,R2    CCFNDEND*4-3      -3 SINCE ONLY 1 BYTE OF LAST WORD USED
         LI,R4    0
         LB,R1    CCFND,R4
         BEZ      GETMISCC
         AI,R4    1
         BDR,R2   %-3
         B        CONTINU
GETMISCC M:PRINT  (MESS,BLANK)
         M:PRINT  (MESS,MISCCMSG)
         M:PRINT  (MESS,BLANK)
CCMISLUP LW,R1    R4
         MI,R1    3
         LCI      3
         LM,D1    CCTBL,R1          PICK UP MISSING CC NAME
         STM,D1   MISSCC+3
         M:PRINT  (MESS,MISSCC)
         LM,D1    MISSCC            AFTER PRINTING IT, BLANK OUT
         STM,D1   MISSCC+3
         CI,R4    CCFNDEND*4        ALL THRU CC PRESENCE COUNT
         BGE      CONTINU-1         BRANCH IF SO
         B        %+3
         LB,R1    CCFND,R4          GET NEXT CC PRESENCE COUNT BYTE
         BEZ      CCMISLUP          0, IF CC NOT IN INPUT TO PASS2
         AI,R4    1
         BDR,R2   %-3
         M:PRINT  (MESS,DOTDOT)
CONTINU  EQU      %
         MTW,0    P2ABRT,R3         DELAYED ABORT CONDITION
         BNEZ     PASS2ABRT-1       YES
         LCI      4
         LM,D1    ENDP2
         STM,D1   DOTDOT+7
         BAL,SR4  PASS2MSG
         CAL1,9   1                 M:EXIT  RETURN TO MONITOR
*
* * * *  THE      END  * * * *
*
*
         BAL,SR4  ABRTMSG
PASS2ABRT  EQU    %
         CAL1,9   2
*
*******PASS2 DELAYED ABORT EXIT*******
         PAGE
RDINCFCH BAL,SR4  READCC            READ
         LI,SR1   K0                 SET AND
         LW,R7    FETCHADR,R3       GO GET NAME
         BAL,SR4  NAMSCAN
         BCS,8    ERRBORT1          TRY AGAIN IF ERROR
         LW,R1    FETCHBUF,R3       GET IMAGE 1ST WORD
         B        *R4               RETURN
*
READCONT EQU      %                 HERE IF READ IS CONTINUED NEXT CARD
READCC   PUSH     SR4
         BAL,SR4  LISTIT            LIST CC IF NEEDED                   896
         LI,SR4   LISTIT            SET CCPL TO LIST NEXT CC            896
         STW,SR4  FETCHCCP-1,R5                                         896
         LW,D3    BUFFADDR,R5       R5= SAVED R3 DYN STORAGE PTR
         STW,D3   BUFFRD
READIT   CAL1,1   READFILE
         LH,SR3   M:X1+4            GET ARS SIZE
         BNEZ     %+2
         LI,SR3   80**1
         SLS,SR3  -1                GET SIZE
         STW,SR3  RECSIZE
         MTW,1    CURKEY            UPDATE CURRENT KEY
*                                   KEY CHANGED AFTER ABNKEY
         LI,SR3   K1
         STW,SR3  FETCHCCP,R5
*
*                      COL.1 MUST = ':'  LL LISTING OCCURS IF NOT
         PUSH     15,R1              AGAIN UNTIL COLON FOUND.
         B        READFIN           DO NOT LIST CC NOW                  896
*
ABNRETUR PULL     SR4
         LW,R3    R5
         CAL1,9   2                 YES,ERROR EXIT
*
ABNKEY   EQU      %                 ABN/ERR RETURN FROM KEYED READ
         PULL     SR4
         LB,D1    SR3               GET ERROR CODE
         CI,D1    X'43'             NO RECORD W. KEY
         BNE      ABNERR            NO
         LI,R1    0
         STW,R1   FETCHCCP-1,R3
         MTW,1    CCPTR,R3          INCRE.CCPTR
         LW,R1    CCPTR,R3
         CI,R1    #STDKEYS
         BL       RESETKY           NOT DONE ALL KEYS
         AI,R1    -2                CHECK IF COC SPECIFIED
         LB,R1    CCFND,R1
         BNEZ     CONTINUP
         M:PRINT  (MESS,ASTER)
         MTW,1    P2ERR,R3
         M:PRINT  (MESS,NOCOC)
         PUSH     SR4
         LI,D3    NOCOC
         BAL,SR4  PRNTP2SI
         PULL     SR4
CONTINUP EQU      %
         LI,R1    -5                FLG TO GO TO PASS2OUT
         STW,R1   CCPTR,R3
         B        %+5
RESETKY  EQU      %
         LW,D1    KEYCMND,R1        SET UP NEW KEY
         STW,D1   CURKEY            FOR LATER READ
*                                   SEE WHERE CAME FROM
         CI,R1    2                 WAS IT UBCHAN
         BE       CHDVEND           YES,RET. FOR PROCESSING
         AI,R1    -1
         LB,R1    CCFND,R1
         BEZ      %+2               SKIP A LINE OF ASTERISKS IF CC
*                                   IS MISSING
         EXU      PRTASTR
         CI,SR4   NXACH7+4          CHAR SCAN RTN ?
         BE       ERRBORT2
         CI,R4    READOK            READING NEW CMND
         BE       READSTRG+4        RET. TO READ NXT CMND
         B        PASS2OUT
*
ABNERR   EQU      %
         LH,SR3   SR3
         M:PRINT  (MESS,ABNMSG)
         B        ABNERR2
ABNMOD   LH,SR3   SR3
         M:PRINT  (MESS,ABNMODMG)
         B        ABNERR2
ABNMODMG TEXTC    '***  ERROR IN M:EI FILE'
ABNMSG   TEXTC    '*** ERROR PROCESSING COMMANDS FROM KEYED FILE'
NOCOC    TEXTC    '*** NO :COC COMMAND - A BATCH ONLY',;
                  ' SYSTEM BEING GENERATED'
*
OUTLLERR EQU      %            LIST ERROR COLUMN INDICATOR (EXIT IN SR4)
*        NOTE THAT ANY CODE CALLING THIS ROUTINE MUST HAVE R5 SET
*        TO THE START OF P2CCI'S TEMPSTACK.  NORMALLY R3 IS ALWAYS
*        POINTING THERE, BUT THERE ARE SOME EXCEPTIONS
*
*
         MTW,1    P2ERR,R5          INCREMENT ERROR COUNT
         PUSH     SR4
         PUSH     15,R1
         BAL,SR4  LISTIT            LIST CC IF NEEDED                   896
         LW,SR4   FETCHCCP-1,R5     SET CCPL TO                         896
         AND,SR4  M15X17              NO LIST OF THIS                   896
         STW,SR4  FETCHCCP-1,R5       CC AGAIN                          896
OUTLLER1 LW,R7    FETCHCCP,R5
         AI,R7    -1
         CI,SR1   K0
         BE       %+2
         AI,R7    KN1
         LW,SR3   XBUFADDR,R5
         LI,SR4   K5B               GET '%'
         STB,SR4  *SR3,R7
*
*
LISTCAL1 EQU      %    SR3=ADDRESS OF BUFFER ; SR4= BYTE COUNT
         LW,SR1   LLFPT
         LW,SR2   LLFPT+1           GET 1ST 2 WORDS OF FPT
         LI,SR4   K50
         CAL1,1   SR1               PRINT W/O VFC
         STW,SR3  EOBUF
         STW,SR4  EOBUFSZ
         LI,SR4   %+2
         CAL1,1   EOFPT             WRITE IT TO T:P2SI    FILE
         CW,SR3   BUFFADDR,R5
         BE       READFIN           BR.IF NOT ERROR LISTING
         LI,SR4   KBLANK
         STB,SR4  *SR3,R7
         B        LISTIT1
READFIN  EQU      %
         LW,SR3   BUFFADDR,R5       GET 1ST
         LB,SR3   *SR3               BYTE OF
         CI,SR3   KCOLON            BUFFER IMAGE
         BE       READFIN1
         CI,SR3   '*'               IF COLUMN-1 = *, THEN COMMENT CARD
         BNE      TRUERR            NO..ERROR
READFINA EQU      %
         PULL     15,R1             YES.COMMENT CARD
         PULL     SR4
         B        READCONT          GET NEXT CC
TRUERR   EQU      %
         LI,SR1   0
         BAL,SR4  OUTLLERR          IF NOT COLON, LIST AND READ AGAIN
         BAL,SR4  UNKCCMSG
         B        READFINA
READFIN1 PULL     15,R1
         PULL     SR4               SAVED AT READCC/READCONT OR OUTLLERR
READFIN2 LW,SR3   Y06               ARBIT.SET AS IF CONTINUE CARD
         B        *SR4
*
         PAGE                                                           896
*  LIST CC IF NOT ALREADY LISTED                                        896
LISTIT   EQU      %                                                     896
         PUSH     SR4                                                   896
         PUSH     15,R1                                                 896
         LW,R1    FETCHCCP-1,R5                                         896
         AND,R1   M17                                                   896
         BEZ      LISTIT1           IF = 0 , DO NOT PERFORM LIST OF CC  896
         LW,R1    CCPTR,R5
         LB,R1    CCFND,R1          CHECK IF THIS COMMAND IS PRESENT
         BEZ      LISTIT1           SKIP LISTING IT IF SO
         LW,R1    FETCHCCP-1,R5     SET TO NOT LIST                     896
         AND,R1   M15X17              NEXT TIME IN                      896
         STW,R1   FETCHCCP-1,R5                                         896
         LW,SR3   BUFFADDR,R5       LIST OF THIS CC IS NEEDED           896
         LW,SR1   LLFPT                                                 896
         LW,SR2   LLFPT+1                                               896
         LH,SR4   M:X1+4
         SLS,SR4  -1
         LW,R1    SR4
         AI,R1    -1
         LB,R1    *SR3,R1           GET LAST BYTE
         CI,R1    X'15'             IS IT CARRIAGE RETURN
         BNE      %+2               NO
         AI,SR4   -1                YES
         LW,R1    *SR3              CHECK IF IT'S THE :CHAN CC
         CW,R1    CMNDS
         BNE      %+2
         EXU      PRTASTR           IF SO PRINT A LINE OF ASTERISKS
         CAL1,1   SR1               LIST IT - P L E A S E -             896
         LI,R4    '*'
         CB,R4    *SR3
         BE       LISTIT1
         STW,SR4  EOBUFSZ
         STW,SR3  EOBUF
         LI,SR4   LISTIT1
         CAL1,1   EOFPT
LISTIT1  EQU      %                                                     896
         PULL     15,R1                                                 896
         PULL     SR4                                                   896
         B        *SR4                                                  896
*
*        THIS ROUTINE LOGS ERROR MESSAGE INTO T:P2SI    FILE & LP
*        ENTRY IS VIA BAL,SR4  LOGIT   /  OR VIA BAL,SR4  PRNTP2SI
*
LOGIT    MTW,1    P2ERR,R3          INCREMENT ERROR COUNT
         CAL1,2   LLIST             LIST ERROR ON PRINTER
PRNTP2SI STW,D3   EOBUF
         LB,D3    *D3
         STW,D3   EOBUFSZ
         LI,D3    1
         STW,D3   EOBTD
         CAL1,1   EOFPT             LIST ERROR IN T:P2SI    FILE
         MTW,-1   EOBTD
         B        *SR4
         PAGE
*
ERRBORT1 BAL,SR4  OUTLLERR
         BAL,SR4  UNKCCMSG
         B        NEXTCARD
*
ERRBORT2 EQU %
         LI,SR4   PASS2OUT
         MTW,1    P2ERR,R3
         BAL,SR3  PRINTMSG
         TEXTC    '*** CANNOT READ CONTINUATION RECORD - PASS2 ABORTED'
CURNCARD RES      1
STARTP2M BAL,SR3  PRINTMSG
         TEXTC    '.......... E00 PASS2 CCI IN CONTROL ..........'
ERRBORT3 LI,SR4   PASS2DUN
         MTW,1    P2ERR,R3
         BAL,SR3  PRINTMSG
         TEXTC    '***RECORD EXCEEDS 80 CHARS. PASS2 ABORTED'
ERRBORT4 LI,SR4   ERRT:P2           AFTER PRINTOUT RETURN TO NEXT
*                                   CONTROL COMMAND READ
         MTW,1    P2ERR,R3
         BAL,SR3  PRINTMSG
ERR4MSG  TEXTC    '***DUPLIATE CC OTHER THAN DEVICE/CHAN.',;
                  '  DUPLICATE IGNORED'
ERRT:P2  LI,D3    ERR4MSG
         BAL,SR4  PRNTP2SI
         B        READSTRG
UNKCCMSG PUSH     SR4
         LI,D3    ERRUNKN
         BAL,SR4  PRNTP2SI
         PULL     SR4
         BAL,SR3  PRINTMSG
ERRUNKN  TEXTC    '*** UNKNOWN OR MISPLACED CC'
PASS2MSG BAL,SR3  PRINTMSG
DOTDOT   TEXTC    '...................................',;
                  '........................'
ENDP2    TEXT     '  END OF PASS2  '
MISCCMSG TEXTC    'THE FOLLOWING COMMANDS WERE NOT FOUND IN THE',;
                  ' INPUT TO THIS PASS2:'
MISSCC   TEXTC    '                        '
ABRTMSG  MTW,1    P2ERR,R3
         BAL,SR3  PRINTMSG
         TEXTC    '***PASS2 DELAYED ABORT DUE TO FATAL ERROR'
PRINTMSG PUSH     2,SR1
         LW,SR1   Y01
         LW,SR2   Y8
         CAL1,2   SR1               PRINT MESSAGE (ADDRESS IN SR3)
         PULL     2,SR1
         B        *SR4
*
ASTER    TEXTC    '********************************'
BLANK    TEXTC    '   '
TYPURSER DATA     X'1AC5F0F0'       'E00     VERSION
         DATA     X'40D7C1E2'        PAS
         DATA     X'E2F240C1'        S2 A
         DATA     X'E340E8D6'        T YO
         DATA     X'E4D940E2'        UR S
         DATA     X'C5D9E5C9'        ERVI
         DATA     X'C3C51540'        CE  '
         PAGE
         DEF      CHARSCAN
         DEF      CHSTSCAN
         DEF      DECSCAN
         DEF      HEXSCAN
         DEF      NAMSCAN
         DEF      NXACTCHR
         DEF      QUOTSCAN
         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'
KNL      EQU      X'15'
KEOB     EQU      X'26'
KSCOLON  EQU      ';'
XEND     DATA     X'C5D5C400'
CONTFLG  DATA     0
PROMPT   GEN,8,24 X'2C',X'15'       ISSUE A NEW LINE PROMTP
MSIWRD   GEN,8,24 X'10',M:SI
         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   KEOB
         BE       NXACH51
         CI,SR1   KNL
         BE       NXACH51
         CI,SR1   '.'               IF CHAR. = ., THEN ASSUME IT IS
         BNE      NXACH1A           NOT..  TRUE END OF IMAGE
         LW,R1    RECSIZE
         STW,R1   CCP,R7
         LI,SR1   KCRET             SET '.' TO NL CHAR.
         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   KEOB
         BE       NXACH51
         CI,SR1   '.'               END OF IMAGE IF CHAR. = '.'
         BE       NXACH51           YES..
         CI,SR1   KNL
         BE       NXACH51
         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      %
         XW,SR3   D1
         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
         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
         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
*        RETURNS CONVERTED VALUE IN D1
*
*
*
HEXSCAN  EQU      %
         XW,SR3   D1
         PUSH     13,SR4
         LW,R5    R3
         BAL,SR4  GETCHST           GET CHAR STRING
         BCS,8    COMEXIT2          BRANCH IF ILLEGAL CHAR STRING
         LI,SR3   0
HEXS1    EQU      %
         LB,R4    *R7,R2            SET (R4)=ITH CHAR IN STRING
         LB,R3    CHTBL,R4
         BEZ      COMEXIT2          BRANCH IF NOT LEGAL ALPHANUMERIC
         CI,R3    K2                CHECKIF LEGAL HEX CHAR
         BG       COMEXIT2          BRANCH IF NOT
         SLS,SR3  4
         BCS,8    COMEXIT2
         AI,R4    -'0'
         BGEZ     %+2
         AI,R4    '0'-'A'+10
         OR,SR3   R4                ADD HEX DIGIT TO TOTAL THUS FAR
         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
         XW,SR3   D1
         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      %
         XW,SR3   D1
         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.
*        RETURNS CONVERTED VALUE IN D1
*
*
DECSCAN  EQU      %
         XW,SR3   D1
         PUSH     13,SR4
         LW,R5    R3
         BAL,SR4  GETCHST           GET CHAR STRING
         BCS,8    COMEXIT2          BRANCH IF ILLEGAL CHAR STRING
         LI,SR4   0
DECS1    EQU      %
         LB,R4    *R7,R2            SET (R4)=ITH CHAR IN STRING
         LB,R3    CHTBL,R4
         CI,R3    K1                         LEGAL DECIMAL  CHAR
         BNE      COMEXIT2          BRANCH IF NOT
         AI,R2    K1
         MI,SR4   10
         BCS,4    COMEXIT2
         AI,R4    -'0'
         AW,SR4   R4
         BDR,R1   DECS1             SET N = N-1
         STW,SR4  SR3
         B        COMEXIT1
*
COMEXIT2 EQU      %
         PULL     13,SR4
         XW,SR3   D1
         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
         CI,SR1   ','               CHECK FOR DOUBLE COMMA
         BNE      GCHST2            BRANCH IF CURRENT DELIM. IS NOT A COMMA
         CW,SR1   PREV              WAS THE IMMEDIATE PREVIOUS CHARACTER
         BE       GCHST3            A COMMA?  BRANCH IF SO.
GCHST2   STW,SR1  PREV              SAVE IN PREV. LOCATION
         LW,R3    Y2                SET
         STS,R3   FLAGS,R7               PARAM LIST BUF NOT EMPTY FLAG
GCHST3   LC       R4
         B        *SR4              EXIT
         PAGE
C300     EQU      X'00030000'
C3000    EQU      X'03000000'
C3003    EQU      X'03000003'
C330     EQU      X'00030300'
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,C3003
         DATA     C300,0,3,C3003
         DATA     C300,0,0,C330
         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
CCP      EQU      3
FLAGS    EQU      4
CBUF     EQU      4
CSL      EQU      5
PCCP     EQU      6
PLB      EQU      7
BAPLB    EQU      4*PLB
         PAGE
FETCHSTR EQU      %
         GEN,8,24 NDELIM,BA(CCDELIM)
         GEN,8,24 CNCLM,READCONT    CONT.COL.NO.; CONTINUE READ RTN.
         DATA     CCLIST,0           2WDS   FOR OUTR AND CCP
         GEN,8,24 0,0               STORE BUFFER ADDRESS BEFORE OPING
         DATA     0,0                 CSL, FCPF
CCDELIM  DATA,4   '(),.'
         DATA,3   ' +-'
NDELIM   EQU      BA(%)-BA(CCDELIM)
         BOUND    4
CNCLM    EQU      0                 CONTINUE COL. NO. 0-79
CCLIST   EQU      0                 0=NO AUTOMATIC OUTPUT LISTING
*
LLFPT    GEN,8,24 X'11',M:LL
         GEN,4,24,4   3,1,0
*
READC    GEN,8,24 X'10',M:C         PLIST: READ C DEVICE
         GEN,4,28 7,16
         DATA     ABNRETUR,0,80
*
EOFPT    GEN,8,24 X'11',M:EO
         GEN,8,24 X'F4',0
         DATA     ERREO
         DATA     ABNEO
EOBUF    DATA     0
EOBUFSZ  DATA     0
EOBTD    DATA     0
         PAGE
K7       EQU      X'7'
K14      EQU      X'14'
K5B      EQU      X'5B'
*
KCOLON   EQU      ':'
TEN      DATA     10
UNISAV   DATA     0
         BOUND    8
XBLANKS  DATA     X'40404040'
         DATA     X'F0F0F040'
Y2       DATA     X'20000000'
Y4       DATA     X'40000000'
Y8       DATA     X'80000000'
Y01      DATA     X'01000000'
Y05      DATA     X'05000000'
Y06      DATA     X'06000000'
YDFFFFFFF DATA    X'DFFFFFFF'
RECSIZE  DATA     80                FOR RECORD  SIZE ON READ
*
M17      DATA     X'1FFFF'                                              896
M15X17   DATA     X'7FFF'**17                                           896
HLDTYP   DATA     0                 TMP STOR 4 MODGEN TYPE REF/DEF/DICT
HLDDISP  DATA     0                 TMP HOLD FOR DISP TO REF SLOT IN PLIST
M12LFT   DATA     X'FFF00000'
EXPHWRT  DATA     X'103E0000'       DO NOT SEPARATE THIS AND NEXT WORD
         DATA     X'101E0000'
*
*
         PAGE
CMNDS    EQU      %
         DATA     ':CHA'
         DATA     ':DEV'
         DATA     ':FAU'
         DATA     ':SDE'
         DATA     ':RES'
         DATA     ':LDE'
         DATA     ':OPL'
         DATA     ':PAR'
XHAND    DATA     ':HAN'            FOR HANDLERS2 C C
UTINDX   EQU      %-CMNDS
         DATA     ':MON'
         DATA     ':SCP'
         DATA     ':IMC'
         DATA     ':ELI'
         DATA     ':BLI'
         DATA     ':OLI'
         DATA     ':GLI'
FRG      EQU      %-CMNDS
         DATA     ':FRG'
         DATA     ':INT'
         DATA     ':SPR'
         DATA     ':COC'
         DATA     ':GHO'
#CMNDS   EQU      %-CMNDS
*
*
KEYCMND  EQU      %
CURKEY   EQU      %
         DATA     X'03C1E200'       ASTERISK IF NO CMND FIRST
         DATA     X'03C3C400'       CD FOR CHAN/DEVICE
         DATA     X'03C6C100'       FA
         DATA     X'03E2C400'       SD
         DATA     X'03D9C500'       RE
         DATA     X'03D3C400'       LD
         DATA     X'03D6D700'       OP
         DATA     X'03D7C100'       PA
         DATA     X'03C8C100'       HA (HANDLERS2 CC)
         DATA     X'03D4D600'       MO
         DATA     X'03E2C300'       SC
         DATA     X'03C9D400'       IM
         DATA     X'03C5D300'       EL
         DATA     X'03C2D300'       BL
         DATA     X'03D6D300'       OL
         DATA     X'03C7D300'       GL
         DATA     X'03C6D900'       FR
         DATA     X'03C9D500'       IN
         DATA     X'03E2D700'       SP
         DATA     X'03C3D600'       CO
         DATA     X'03C7C800'       GH
#STDKEYS EQU      %-KEYCMND
*
CCTBL    EQU      %
         TEXT     ':CHAN      '
         TEXT     ':DEVICE    '
         TEXT     ':FAUTH     '
         TEXT     ':SDEVICE   '
         TEXT     ':RES       '
         TEXT     ':LDEV      '
         TEXT     ':OPLBLT    '
         TEXT     ':PART      '
         TEXT     ':HANDLERS2 '
         TEXT     ':MON       '
         TEXT     ':SCPU      '
         TEXT     ':IMC       '
         TEXT     ':ELIMIT    '
         TEXT     ':BLIMIT    '
         TEXT     ':OLIMIT    '
         TEXT     ':GLIMIT    '
         TEXT     ':FRGD      '
         TEXT     ':INTLB     '
         TEXT     ':SPROCS    '
         TEXT     ':COC       '
         TEXT     ':GHOST      '
         PAGE
CCFND    DATA     0,0,0,0,0         BYTE FLG BY POSITION
         DATA     0
CCFNDEND EQU      %-CCFND
*                                   CHAN/DEVICE/FAUTH/SDEVICE
*                                   RES/LDEV/OPLBLT/PART
*                                   HANDLERS2/MON/SCPU/IMC
*                                   ELIMIT/BLIMIT/OLIMIT/GLIMIT
*                                   FRGD/INTLB/SPROCS/COC
*                                   GHOST
XUTM     DATA     ':UTM'
LISTFLG  DATA     0                 LIST COMMANDS AS READ FROM SI
*
READFILE GEN,8,24 X'10',M:X1
         DATA     X'F8000010'
         DATA     ABNKEY,ABNKEY
BUFFRD   DATA     0,80              BUFF ADDR; SIZE
KEYREAD  DATA     CURKEY            ADDR OF KEY STARTS W. * KEY
*
RDSI     GEN,8,24  X'10',M:SI       M:SI
         GEN,4,28  7,16
         DATA     ABNSI,0,81
*
WRIX1    GEN,8,24  X'11',M:X1
         DATA     X'F8000020'
         DATA     ABNX1,ABNX1       ERR,ABN
BUFADD   DATA     0                 BUF ADDR
BUFX1    DATA     0
KEYX1    DATA     0                 KEY  ADDR
*
*
ABNSI    EQU      %
ABNX1    EQU      %
         LH,SR3   SR3
         CI,SR3   X'600'
         BE       ENDPROC
         CI,SR3   X'500'
         BE       ENDPROC
         LW,SR4   *KEYX1            SPECIAL CHECK FOR MORE THAN 1
         SLS,SR4  -8                :FECP CC
         CW,SR4   =X'3C6C5'
         BNE      ABNERR2
         LW,R4    KEYCMND           INSURE THAT PREVIOUS RECORD WAS
         SLS,R4   -8                ALSO AN FECP RECORD
         CW,R4    SR4
         BNE      ABNERR2
         LW,R4    KEYCMND           GET NEXT RECORD KEY FOR FECP
         STW,R4   *KEYX1            CONTINUATION
         B        RETRYWRT          AND RETRY WRITE TO M:X1
ABNERR2  EQU      %
         PSW,SR4  *R0
         BAL,SR4  CONVT
         PLW,SR4  *R0
         STH,R4   IOERR+7
         SLS,R4   -16
         CI,R4    '07'
         BE       ERRBORT3
         CI,R4    '16'
         BE       ERRBORT4
         STH,R4   IOERR+5
         MTW,1    P2ABRT,R3
         MTW,1    P2ERR,R3
         M:PRINT  (MESS,IOERR)
         B        PASS2OUT
IOERR    TEXTC    '***  I/O ERR/ABN = XX  /   XX  ***'
TMIOERR  TEXTC    '***  I/O ERR/ABN = XX  /   XX  *** ',;
                  '             LMN WAS BEING WRITTEN TO M:TM'
XSERR    TEXTC    '*** DIFFICULTY PROCESSING PASS2 COMMANDS'
OPENX1   GEN,8,24 X'14',M:X1
         DATA     X'DF480001'
         DATA     ABNX1,ABNX1       ERROR,ABN
         DATA     80,10             RECLGTH,TRIES
         DATA     2,2               KEYED,DIRECT
OUTINX1  DATA     2                 OUT LATER IN
         DATA     2                 SAVE
         DATA     3                 KEYM
         DATA     X'01010102'
FILENAME DATA     0,0
ABNEO    EQU      %
ERREO    EQU      %
         LH,SR3   SR3
         MTW,1    P2ERR,R3
         PSW,R4   *R0
         BAL,SR4  CONVT
         STH,R4   IOERR+7
         SLS,R4   -16
         STH,R4   IOERR+5
         M:PRINT  (MESS,MEOMSG)
         PUSH     4,SR4
         LI,D3    MEOMSG
         BAL,SR4  PRNTP2SI
         PULL     4,SR4
         M:PRINT  (MESS,IOERR)
         PLW,R4   *R0
         B        *SR4
MEOMSG   TEXTC    'ERROR WHILE WRITING T:P2SI'
         PAGE
ENTRY    EQU      %
         DATA     0
         B        UBCHAN
         B        FAUTH
         B        SDEVICE
         B        RESOURCE
         B        LDEVICE
         B        OPLBLT
         B        UTXPART
         B        READSTRG          NO PROCESSING REQUIRED
*                                   FOR HANDLERS2 CC
         B        UBMONITOR
         B        SCPU
         B        IMC
         B        UBELIMIT
         B        UBBLIMIT
         B        UBOLIMIT
         B        UBGLIMIT
         B        FRGD
         B        INTLB
         B        SPROCS
         B        COC
         B        GHOST
         PAGE
* ROUTINE GETS ONE PAGE AT A TIME AND ZEROES IT OUT
*    UPON ENTRY
*     R2 = ABS DISPLACEMENT INTO STACK OF WRD FOR #PAGES OBTAINED
*     R1 = LINK REGISTER
*     UPON EXIT
*    SR2 IS AS BEFORE
*
GETPGS   EQU      %
         PSW,R4   *R0
         PSW,SR2  *R0
         M:GP     1
         BCS,8    NOROOM
         MTW,1    *R2,R3            INCRE. #PGS GOTTEN
         AI,R2    -1
         STW,SR2  *R2,R3
         LI,R4    511
         AWM,R4   *R2,R3            ADDR = LST WRD OF PAGE
         LI,R2    0
         STW,R2   *SR2,R4           ZERO OUT PAGE
         BDR,R4   %-1
         STW,R2   *SR2
         PLW,SR2  *R0
         PLW,R4   *R0
         B        0,R1
NOROOM   EQU      %
         M:PRINT  (MESS,NOSP)
         MTW,1    P2ERR,R3
         M:PRINT  (MESS,OUT)
         CAL1,9   2                 EXIT ABORT
NOSP     TEXTC    '*** INADEQUATE SPACE TO BUILD INTERMEDIATE',;
                  ' TABLES'
OUT      TEXTC    '*** PASS2 ABORTS'
         PAGE
************************************************************
*     CONVERT HEX ERR/ABN CODE TO EBCDIC                   *
*     UPON ENTRY                                           *
*       SR3 = MAJOR AND MINOR CODE  ....XXYY               *
*     UPON EXIT                                            *
*       R4 = CONVERTED CODE                                *
*     ALL OTHER REGISTERS SAVED                            *
************************************************************
CONVT    EQU      %
         LCI      15
         PSM,R5   *R0
         STH,SR3  R3                R3 =XXYY....
         LB,R2    R3                R2 = MAJOR CODE XX
         SLS,R3   8                 GET RID OF MAJOR CODE
         SLS,R3   -25               ADJUST MINOR CODE
         SLS,R3   24                R2 = ....XX,R3=YY....
         SLD,R2   -8                R2 =0,R3=XXYY
         LI,R5    0
         LI,R1    4
CONV1    EQU      %
         LI,R2    0
         SLD,R2   4
         LB,SR1   CONVTBL,R2
         STB,SR1  R4,R5
         AI,R5    1
         BDR,R1   CONV1
         LCI      15
         PLM,R5   *R0
         B        *SR4
CONVTBL  EQU      %
         DATA,1   '0','1','2','3','4','5','6','7'
         DATA,1   '8','9','A','B','C','D','E','F'
         BOUND    4
         PAGE
         DEF      SYNTAX
         DEF      LLIST
SYNTAX   EQU      %
         LW,R5    *R0               DATA
         AI,R5    1                 TO
         MSP,R1   *R0               TEMP STACK
         LCI      15                SAVE
         PSM,R1   *R0               REGISTERS.
         AI,R1    -1                MOVE
         LW,R6    *R2,R1
         STW,R6   *R5,R1
         AI,R1    1                 THE
         BDR,R1   %-4               DATA
         LI,R6    DFLTFMT           SET PTR TO FORMAT HWDS
         LW,R2    *R4               IS DEFAULT TO BE USED
         BLZ      %+3               YES
         LW,R6    R4                NO, USE SPECIAL FMT HWDS
         AW,R4    R2                GET START OF KEYWORDS
         AI,R6    1                 INCREMENT PTR
         STW,R1   -1,R6             PUT ZERO IN -1,R6
         PSW,R4   *R0               SAVE KWDTBL POINTER
EXEC     LW,R4    -1,R6
         LH,R4    *R6,R4
         AND,R4   M8
         CI,R4    MAXPROC
         BG       BADCB
         B        PROC,R4
EX1      MTW,1    -1,R6             SUCCESS RETURN
         B        EXEC
EX2      LW,R4    -1,R6             ERROR RETURN
         LH,R4    *R6,R4
         BGEZ     %+2
         BAL,SR4  ERR
         SLS,R4   17
         SLS,R4   -25
         STW,R4   -1,R6
         B        EXEC
PROC     B        EX1            0  NOP
         B        EX2            1  GOTO
         B        LEFT           2  LPAREN
         B        FLEFT          3  FINDLPAREN
         B        RIGHT          4  RPAREN
         B        FRIGHT         5  FINDRPAREN
         B        COMMA          6  COMMA
         B        FCOMMA         7  FINDCOMMA
         B        INTEROPT       8  ),( OR)
         B        KWD            9  KEYWORD SEARCH
         B        PROCKWD       10  PROCESS STD KWD
         B        ANTXT         11  TEXT FORM OF ALPHA-NUMERIC FIELD
         B        ANTXTC        12  TEXTC FORM OF ALPHA-NUMERIC FIELD
         B        DEC           13  DEC FIELD
         B        HEX           14  HEX FIELD
         B        CNVTXTC       15  CONVERT TEXT TO TEXTC
         B        CNVDEC        16  CONVERT TEXT TO BINARY FROM DEC
         B        CNVHEX        17  CONVERT TEXT TO BENARY FROM HEX
         B        WDTBL          18 STORE IN WDTBL
         B        DWTBL         19  STORE IN  DWTBL
         B        GETSTRG           20 GET NEXT CHAR STRING
         B        STEPPTR           21  INCREMENT TEMPSTACK PTR ADDRESS
MAXPROC  EQU      %-PROC
         PAGE
LEFT     LI,SR2   '('
         LI,D3    LFTMSG
         B        CHAR
RIGHT    LI,SR2   ')'
         LI,D3    RHTMSG
         B        CHAR
COMMA    LI,SR2   ','
         LI,D3    COMMSG
CHAR     BAL,SR4  CHARSCAN
         BCR,8    EX1
         B        EX2
FLEFT    LI,SR2   '('
         B        FIND
FRIGHT   LI,SR2   ')'
         B        FIND
FCOMMA   LI,SR2   ','
FIND     BAL,SR4  CHARSCAN
         BCR,8    EX1
         CI,SR1   X'0D'
         BE       ENDSYN
         CI,SR1   X'15'
         BE       ENDSYN
         CI,SR1   X'26'
         BE       ENDSYN
         LI,SR1   0
         B        FIND
INTEROPT LI,SR2   ')'
         LI,D3    RHTMSG
         BAL,SR4  CHARSCAN
         BCS,8    EX2               FIRST MUST BE ')'
         LI,SR2   ','
         LI,D3    COMMSG
         BAL,SR4  CHARSCAN
         BCS,8    CHKEND            BRANCH IF NOT A COMMA
         LW,SR2   Y2                NEED TO MASK OUT BUFFER FULL FLAG
         STS,SR1  FLAGS,R7
         B        LEFT              THEN LOOK FOR LEFT PAREN
CHKEND   EQU      %
         CI,SR1   X'15'
         BE       ENDSYN
         CI,SR1   X'0D'
         BE       ENDSYN
         CI,SR1   X'26'
         BE       ENDSYN
         B        EX2               SECOND MUST BE ',' OR END
KWD      LI,D3    KWDMSG
         BAL,SR4  CHSTSCAN          GET STRING
         BCS,8    EX2               BAD ONE
         LW,D1    7,R7              FIRST TWO
         LW,D2    8,R7              WORDS.
         PLW,SR3  *R0               RWDTBL
         PSW,SR3  *R0               POINTER.
KWDCHK   CW,D1    *SR3              CHECK FIRST WORD
         BE       FHKWD             GO CHECK SECOND
         AI,SR3   2                 FIND
         MTW,0    *SR3              NEXT
         BLZ      KWDCHK            ENTRY
         AI,SR3   1                 IN
         MTW,0    *SR3              TABLE.
         BGEZ     EX2               END OF TABLE- UNKNOWN KEYWORD
         B        KWDCHK
FHKWD    AI,SR3   1                 CHECK IF SECOND WORD
         MTW,0    *SR3              MUST BE CHECKED.
         BGEZ     EX1               NO.
         CW,D2    *SR3              YES.
         BE       FHKWD
         B        KWDCHK+2
STEPPTR  LW,R4    -1,R6
         LH,R4    *R6,R4            FORMAT = 1,7,8  AF(2) = DISP TO TEMPSTACK
         SLS,R4   -8
         AW,R4    R5
         LI,R2    1
         AWM,R2   *R4               INCREMENT ADDRESS AT DISP,R5
         B        EX1
PROCKWD  LW,SR3   *SR3              GET DYNAMIC STORAGE DISP.
         LB,R4    SR3               AND CODE FOR OPERATION
         BEZ      FLAG              0=>FLAG
         CI,R4    X'70'
         BE       FLGTABMRG
         CI,SR1   ','               COMMA SHOULD FOLLOW KWD
         BE       %+3
         LI,D3    COMMSG
         BAL,SR4  ERR
         CI,R4    X'F0'             CHECK FOR TABLE OP.
         BANZ     TBLGEN
         LI,SR1   0
         LI,D3    VALMSG
         BAL,SR4  CONV,R4           READ AND CONVERT VALUE
         BCS,8    EX2               BAD VALUE
         LW,D3    *SR3,R5           DUP KWD FLG (BIT-0) AND LIMITS
         BLZ      %+3
         LI,D3    KWDMSG            DUPLICATE
         B        EX2               KEYWORD
         SLS,D3   1                 SHIFT OFF NO-ENTRY FLAG
         SAD,D3   -17
         SLS,D4   -16
         CI,D4    0
         BE       %+5               UPPER LIMIT=0 => NO LIMIT CHECK.
         CLR,D3   D1                CHECK VALUE
         BCR,6    %+3               AGAINST LIMITS.
         LI,D3    VALMSG            NOT WITHIN LIMITS
         B        EX2
         STW,D1   *SR3,R5           OK, STORE VALUE
         LI,R4    1
         MTB,0    SR3,R4
         BEZ      EX1
         MTB,-2   SR3,R4            DECREMENT # OF VAL. STILL TO FOLLOW
         AI,SR3   1                 UPDATE PTR TO NEXT WORD IN TSTACK
         B        PROCKWD+1
         B        EX1
CONV     B        BADCB
         B        DECSCAN
         B        HEXSCAN
         B        NDD
         B        NEWDYN
         B        NEWDYN
         B        KYSTRG
         B        BADCB
         B        KWGT
         B        ORTBL
         B        BADCB
         B        BADCB
         B        BADCB
         B        BADCB
         B        BADCB
         B        BADCB
         B        BADCB
FLGTABMRG EQU     %
         LH,R4    SR3
         AND,R4   M8                GET FLAG
         AND,SR3  M16               GET DISP INTO TEMPSTACK
         LW,R2    *SR3,R5           GET BYTE ADDRESS
         LB,R1    0,R2              GET BYTE
         EOR,R1   R4                MERGE SPECIFIED FLAG
         STB,R1   0,R2
         B        EX1
TBLGEN   AI,R4    -X'40'            REMOVE TABLE FLAG FROM OP CODE
         BLZ      BADCB             WASN'T THERE-TABLE ERROR-ABORT
         LH,D2    SR3               GET FLAG TO STORE
         AND,SR3  M16
         LW,D4    *SR3,R5           MAX VALUE FOR INPUT
         CI,R4    X'F0'             ONLY TBL FLAG MUST BE SET
         BANZ     BADCB
         AI,SR3   1
         AW,SR3   R5                TABLE BASE
TBVAL1   BAL,1    TBLVAL
         LW,2     12
         CI,8     '-'
         BNE      %+2
         BAL,1    TBLVAL
         CW,12    2
         BL       TBERR
         STB,13   *10,2
         AI,2     1
         CW,2     12
         BLE      %-3
TBLCOM   CI,8     ','
         BE       TBVAL1
         CI,8     '-'
         BNE      EX1
         BAL,1    TBLVAL
         B        TBLCOM
TBLVAL   LI,SR1   0
         BAL,SR4  CONV,R4           GET VALUE
         BCR,8    %+4
TBERR    LI,D3    VALMSG
         BAL,SR4  ERR               BAD VALUE
         B        TBLCOM
         CW,D1    D4                WILL IT FIT IN THE TABLE
         BGE      %-4               BRANCH IF NOT
         B        *1
FLAG     LH,R2    SR3               GET FLAG BIT POSITION(S)
         BEZ      NEWDYN             NO FLAG, NEWDYN
         STH,R4   SR3               AND
         LW,R4    SR3               BYTE DISPLACEMENT FROM R5
         LB,D1    *R5,R4            SET
         OR,D1    R2                FLAG
         STB,D1   *R5,R4            BIT(S).
         B        EX1
KWGT     AND,SR3  M17
         STW,SR3  -1,R6
         B        EXEC
NDD      PSW,SR4  *R0
         SD,SR1   SR1
         BAL,SR4  CHARSCAN          PICK UP NEXT CHAR (N)
         LW,D2    SR1
         LI,SR1   0
         BAL,SR4  HEXSCAN           PICK UP TWO HEX DIGITS (DD)
         BCS,8    NDDER             BAD DD
         MTW,-2   5,R7
         BNEZ     NDDER             DD NOT TWO DIGITS
         SLS,D2   8
         AW,D1    D2
         PLW,SR4  *R0
         B        *SR4
NDDER    PLW,SR4  *R0
         LCI      8
         B        *SR4
KYSTRG   EQU      %                 GET STRING,STORE,START NEWDYN
         LI,D3    STRGMSG
         BAL,SR4  CHSTSCAN
         BCS,8    EX2
         LW,SR4   7,R7
         SLS,SR4  -16
         STW,SR4  *SR3,R5
         B        NEWDYN
ORTBL    EQU      %
         LI,D3    STRGMSG
         BAL,SR4  CHSTSCAN
         BCS,8    EX2
         XW,SR3   D1
         LI,SR4   %+3
         LI,R4    DECS1-1
         B        CNVDX+1
         BCS,8    EX2
         CI,D1    X'FF'
         BG       EX2
         SLS,D1   16
         OR,SR3   D1
         LI,R4    X'41'
         B        TBLGEN
NEWDYN   EQU      %
         PLW,R2   *R0               SAVE KWD PTR
         LCI      15
         PSM,R1   *R0
         LI,SR1   0
         PSW,R2   *R0
         B        ENDSYN            DEFAULT THIS SET
NEWDYN1  EQU      %
         AI,R4    -5
         BGZ      %+3
         LI,R4    0
         STW,R4   *SR4              NO MORE DEFAULTING
         LW,R4    *R0
         AI,R4    -15-14            NEW DYN LOC
         STW,R4   15+4,R4           SET NEW R5
         LW,R1    0,R4              #DYN
         LW,R2    1,R4              DYN ADDR
         MSP,R1   *R0
         LW,R5    R4
         AW,R5    R1
         CI,R1    30
         BGE      %+2
         LI,R1    30
         AI,R1    -1
         LW,R6    *R2,R1
         XW,R6    *R4,R1
         STW,R6   *R5,R1
         AI,R1    1
         BDR,R1   %-5
         LCI      15
         PLM,R1   *R0
         PSW,R2   *R0
         LW,D2    SR4
         CI,R4    5
         BE       %+5
         CI,R4    4
         BNE      EX1
         BAL,SR4  HEXSCAN
         B        %+2
         BAL,SR4  DECSCAN
         BCS,8    EX2
         LW,R4    *R0
         LW,R2    -16+5,R4
         CW,D1    *SR3,R2
         BE       EX2
         AW,R2    -16+1,R4
         CW,R2    R5
         BL       %-4
         B        *D2
ANTXT    LI,D3    NAMMSG
         BAL,SR4  NAMSCAN           PICK UP TEXT
         BCS,8    EX2               BAP
         LW,SR3   5,R7              CHECK SIZE
         CI,SR3   16                16=MAX
         BG       EX2
         LCI      4
         LM,D1    7,R7              MOVE TO REGS
         B        EX1
ANTXTC   LI,D3    NAMMSG
         BAL,SR4  NAMSCAN           PICK UP TEXT
         BCS,8    EX2
TXTC     LW,SR3   5,R7
         CI,SR3   15                MAX CHARS =15
         BG       EX2
         LCI      4
         LM,D1    7,R7
         SLD,D3   -8                CONVERT TO
         STB,D2   D3                TEXTC
         SLD,D1   -8
         STB,SR3  D1
         AI,SR3   1
         B        EX1
DEC      LI,D3    VALMSG
         BAL,SR4  DECSCAN
         BCS,8    EX2
         LI,SR3   4
         B        EX1
HEX      LI,D3    VALMSG
         BAL,SR4  HEXSCAN
         BCS,8    EX2
         LI,SR3   4
         B        EX1
CNVTXTC  LI,D3    NAMMSG
         B        TXTC
CNVDEC   LI,R4    DECS1-1           USE DECSCAN'S ROUTINE
         B        CNVDX
CNVHEX   LI,R4    HEXS1-1           USE HEXSCAN'S ROUTINE
CNVDX    LI,SR4   DEC+2             RETURN ADDR
         LI,D3    VALMSG            ERROR MSG
         LW,R1    5,R7              BYTE COUNT
         LI,R2    28                DISPLACEMENT TO FIRST CHAR (4*7)
         PUSH     13,SR4            SIMULATE ENTRY FROM DECSCAN
         B        0,R4
GETSTRG  LI,D3    STRGMSG
         BAL,SR4  CHSTSCAN          GET STRING
         BCS,8    EX2               BAD STRING
         LW,SR3   5,R7              CHECK SIZE
         CI,SR3   8                 8=MAX
         BLE      %+2               OKAY
         LI,SR3   8                 NO,SET TO 8
         LCI      4                 GET STRING
         LM,D1    7,R7              INTO REGISTERS
         B        EX1
WDTBL    LI,R1    4
         B        TBL
DWTBL    LI,R1    8
TBL      CW,SR3   R1                CHECK DATA SIZE
         BLE      %+4
         MTW,-1   -1,R6             BACK UP INSTRUCTION COUNTER
         LI,D3    VALMSG            FOR ERROR DISPOSITION.
         B        EX2
         LW,R4    -1,R6             GET
         LH,R4    *R6,R4            POINTER
         SLS,R4   -8                TO TABLE POINTER.
         AW,R4    R5
         LW,R2    0,R4              GET TABLE POINTER
         SLS,R1   -2
         AWM,R1   0,R4              ADJUST TABLE POINTER
         LW,D3    -1,R4
         CW,D3    0,R4              IS THERE ROOM LEFT
         BL       ERREND            NO
         AI,R2    -1                PUT
         LW,D3    SR4,R1            DATA
         STW,D3   *R2,R1            IN
         BDR,R1   %-2               TABLE.
         B        EX1
ERREND   LI,D3    TBLMSG
         BAL,SR4  ERR
         LI,SR2   KEOB              FIND END OF CC
         LI,SR1   0
         BAL,SR4  CHARSCAN
         BCR,8    %+3
         CI,SR1   KCRET
         BE       %+3
         CI,SR1   KNL
         BNE      %-6
         PLW,SR3  *R0               ADJUST STACK
         PULL     15,R1
         B        ERROUTS
ENDSYN   PLW,SR3  *R0
         SLD,SR3  -17               FIND OF
         SLS,SR4  -15               KWDTBL.
         AW,SR4   SR3               WHICH LOCATION HAS
         LW,SR3   *SR4              #WORDS OF DYNAM TO DEFAULT
         BEZ      %+8               IF NOT SPECIFIED.
         AI,R5    -1
         LW,D1    *SR3,R5           DEFAULT
         BGEZ     %+4               THEM.
         SLS,D1   1                 /
         SAS,D1   -17               EXTEND SIGN
         STW,D1   *SR3,R5           /
         BDR,SR3  %-5               /
         CI,SR1   0
         BE       NEWDYN1
         XW,R3    R5
         BAL,SR4  LISTIT
         LCI      15                RESTORE
         PLM,R1   *R0               REGS AND
         B        *SR4              RETURN
ERR      PSW,SR4  *R0
         XW,R5    R3
         BAL,SR4  OUTLLERR          ENTER '%' UNDER ERROR
         XW,R5    R3
         CAL1,2   LLIST             WRITE MESSAGE
         BAL,SR4  PRNTP2SI
         LW,D3    YDFFFFFFF         RESET
         AND,D3   FLAGS,R7          BUFFER
         STW,D3   FLAGS,R7          FLAG
         PLW,SR4  *R0
         B        *SR4
LLIST    GEN,8,24 1,M:LL            M:PRINT FPT
         PZE      *0
         PZE      *D3               MSG ADDRESS
LFTMSG   TEXTC    '***SYNTAX ERROR- ''('' EXPECTED'
RHTMSG   TEXTC    '***SYNTAX ERROR- '')'' EXPECTED'
COMMSG   TEXTC    '***SYNTAX ERROR- '','' EXPECTED'
KWDMSG   TEXTC    '***INVALID, UNKNOWN, OR DUPLICATE KEYWORD'
NAMMSG   TEXTC    '***INVALID ALPHANUMERIC STRING'
STRGMSG  TEXTC    '*** INVALID CHARACTER STRING'
VALMSG   TEXTC    '***ILLEGAL TYPE OR SIZE'
TBLMSG   TEXTC    '***TOO MANY VALUES'
BADCBMSG TEXTC    '***ERROR IN PROCESSOR- JOB ABORTED'
P2ERRMSG TEXTC    '#######        ERRORS AND OR WARNINGS IN',;
                  ' THIS PASS2        #######'
BADCB    LI,D3    BADCBMSG
         MTW,1    P2ERR,R3
         LW,R5    R3
         BAL,SR4  LISTIT
         CAL1,2   LLIST
         CAL1,9   2
DFLTFMT  DATA,2   0,0,3             FLEFT
         GEN,1,7,8 1,0,9            KWD
         GEN,1,7,8 1,0,10           PROCKWD
         GEN,1,7,8 1,0,8            INTEROPT
         DATA,1   1,1,0,0           GOTO,NOP
M8       DATA     X'FF'
M16      DATA     X'FFFF'
Y113E    DATA     X'113E0000'
         PAGE
         DEF      MODGEN
         REF      MODIFY
MODGEN   PSW,R1   *R0
         LB,R1    *SR3              GET
         CI,R1    X'F0'             NAME OR INSTRUCTION
         BANZ     EXU               INSTRUCTION
         LB,R1    *SR3,R1           OP CODE
         AI,R1    -X'F0'
         BLZ      BADCB             ILLEGAL OP CODE
         PUSH     10,SR4
         STB,R1   HLDTYP
         BAL,SR4  MODPROC,R1
         BCS,8    MODER             ERROR - ABORT
         LB,R1    *SR3              SKIP TO NEXT INFORMATION
         AI,R1    4
         SLS,R1   -2
         AW,SR3   R1
         PULL     10,SR4
         B        MODGEN+1
EXU      PLW,R1   *R0
         LC       SR3
         EXU      *SR3
         STCF     SR3
         AI,SR3   1                 INCREMENT TO NAME
         B        MODGEN
MODER0   LI,D3    NOPG
         B        %+2
MODER    LI,D3    MODMSG
         MTW,1    P2ERR,R3
         CAL1,2   LLIST
         LI,D3    TABLMSG
         CAL1,2   LLIST
         LW,14    10
         CAL1,2   LLIST             PRINT WHAT IT IS
         PULL     10,SR4
         PLW,R1   *R0
         LW,SR4   SR3
         B        ERROUTM
MODMSG   TEXTC    '*** MODIFY ERROR - SKIP TO NEXT CC'
TABLMSG  TEXTC    '*** THE FOLLOWING TABLE WAS BEING GENERATED:'
MODPROC  B        DEFABS
         B        DEFREL
         B        DICTMOD
         B        DICTMOD           REF
         B        DEFABS            FOR A DEF ASSOCIATED WITH A REF
         B        ABSREF            FOR REF ASSOCIATED WITH ABOVE DEF
         B        BADCB
         B        BADCB
         B        BADCB
         B        BADCB
         B        BADCB
         B        BADCB
         B        BADCB
         B        BADCB
         B        BADCB
         B        BADCB
DEFABS   LI,D3    0                 NAME2=0
         B        DEFW
DEFREL   LW,D3    01NAME            NAME2=X'01000000'
         CW,SR1   MAX00,R7          IS LOC IN SECT0
         BGE      MODER0            NO, RETURN TO P2CCI
         LW,D1    SR1               VALUE=(SR1)-2*DW BIAS
         SW,D1    HEADBIAS,R7
         SW,D1    HEADBIAS,R7
DEFW     LB,D2    *SR3              NAME LENGTH +1
         AI,D2    -1
         LCI      4
         LM,R1    *SR3              GET NAME1
         STB,D2   R1                CORRECT COUNT
         STM,R1   CDT+1,R7          PUT NAME1 IN CDT
         AI,D2    (CDT+1)*4+4       FIND WHERE TO PUT NAME2
         SLS,D2   -2
         MTB,-4   HLDTYP
         BNEZ     %+4
         STW,D2   HLDDISP           SAVE DISP TO VALUE2 (NAME2 FOR ABSDEF)
         MTW,1    SR4
         B        *SR4              SKIP B MODIFY UNTIL REF INFO IS IN
         STW,D3   *D2,R7            PUT IT IN
         AI,D2    1                 TO VALUE2
         STW,D1   *D2,R7            PUT IT IN
         LI,D1    2                 GEN OPCODE
         MTB,4    D1
         STW,D1   CDT,R7            PUT IT IN
         B        MODIFY
DICTMOD  LW,D3    01NAME            FOR SETTING NAME1 = X'01000000'
         CW,SR1   MAX00,R7          ARE WE STILL IN CSECT
         BGE      MODER0            BRANCH IF NOT
         STW,D3   CDT+1,R7          NAME
         LW,D1    SR1               VALUE=(SR1)-2*DW BIAS
         SW,D1    HEADBIAS,R7
         SW,D1    HEADBIAS,R7
         STW,D1   CDT+2,R7          LOC
ABSREF   EQU      %
         LB,R1    *SR3
         AI,R1    -1                GET RESOLUTION CODE
         LB,R1    *SR3,R1           AND CONVERT TO BINARY
         LB,R2    CHTBL,R1
         B        %+1,R2
         B        BADCB           0 NOT HEX CHAR
         AI,R1    'A'-10-'0'      1 0-9
         B        %+2             2 A-F
         B        BADCB           3 NOT HEX CHAR
         AI,R1    10-'A'
         LB,D2    *SR3              GET BYTE COUNT FOR REF'S
         AI,D2    -2                WILL BE ZERO FOR DICT'S
         BGZ      REF
         MTB,3    R1                PUT IN DICT CODE
         STW,R1   CDT,R7
         B        MODIFY
         PAGE
REF      STW,R1   CDT,R7            PUT IN RES. CODE
         LCI      4
         LM,R1    *SR3              GET NAME
         STB,D2   R1                CORRECT COUNT
         LB,D1    HLDTYP
         CI,D1    5                 IS IT A REF ASSOCIATED WITH A DEF
         BNE      REGREF
         LW,D1    HLDDISP           GET DISPLACEMENT TO NAME2
         LCI      4
         STM,R1   *D1,R7            STORE AWAY NAME2 IN PLIST
         LW,R1    CDT,R7
         MTB,4    R1                SET MODIFY TYPE TO 4
         STW,R1   CDT,R7
         AI,D2    3
         SLS,D2   -2                CONVERT TO WORDS
         AW,D1    D2
         LI,R1    0
         STW,R1   *D1,R7            SET NAME2 VALUE TO 0
         B        MODIFY
REGREF   EQU      %
         LCI      4
         STM,R1   CDT+3,R7          PUT NAME IN NAME2 SLOT IN PLIST
         LW,R1    Y113E
         STS,R1   CDT+2,R7
         AI,D2    (CDT+3)*4+4       FIND WHERE TO PUT NAME2
         SLS,D2   -2
         LI,R1    0
         STW,R1   *D2,R7
         B        MODIFY
         PAGE
         LOCAL    TREE,HEAD,PLIST
         DEF      COREALLOC,WRITELM
COREALLOC EQU     %
         LW,R7    *R0
         AI,R7    PLISTLOC+1
         CI,R7    1
         BAZ      %+3               YES.DW BOUNDARY
         PSW,R0   *R0               NO..
         AI,R7    1
         LI,R4    -#DUMLM             MOVE HEAD, TREE,
         LW,D3    DUMLM+#DUMLM,R4     PLIST, CHANGE TABLES
         PSW,D3   *R0               TO TSTACK
         BIR,R4   %-2
         PUSH     10,SR4
         CAL1,8   GETPG
         STW,SR1  GOTTENPGS
         SLS,SR2  -1                USE DW ADDRESSING
         SLS,SR1  8
         AI,D1    1                 RFDF GIVEN
         BGZ      RFDFOK            YES.
         LCW,D1   D2                NO..
         BLEZ     00NORFDF          YES. SECT0 GIVEN
         LW,D2    SR1               NO..
         DW,D2    X3                RFDF=TOTAL/3
         LW,D1    D2
NO00     LW,D2    SR1               00=(TOTAL-2*RFDF)*8/9
         SW,D2    D1
         SW,D2    D1
         BLZ      ERROUT            NOT ENOUGH SPACE
         SLS,D2   3
         DW,D2    X3
         DW,D2    X3
         B        SIZESOK
00NORFDF SAS,D1   3                 RFDF=(TOTAL-9/8*00)/2
         AI,D1    -9                ROUND PROPERLY
         SW,D1    D2
         SAS,D1   -4                -DW SIZE OF 00+RELDICT
         AW,D1    SR1               DW SIZE OF RFDF+EXPR
         BLZ      ERROUT            NOT ENOUGH SPACE
RFDFOK   SLS,D1   -1                DW
         AI,D2    1
         BEZ      NO00              NO..SECT0 GIVEN
         SLS,D2   -1                YES.DW
SIZESOK  AWM,SR2  TREERFDF,R7       RFDF ADDR IN TREE
         LW,D3    SR2
         AW,D3    D1                EXPR ADDR
         STW,D3   TREEEXP,R7        IN TREE
         STH,SR2  D3                RFDF ADDR IN L. HWD
         STW,D3   PLRDFEXP,R7       IN PLIST
         STH,D3   D3
         AW,D3    D1                UPPER LIMITS
         AI,D3    -(1**16+1)
         STW,D3   PLUPLMS,R7        IN PLIST
         LW,D4    D2                GET
         AI,D4    7                 SIZE
         SLS,D4   -3                OF RELDICT
         AI,D3    1                 AND ITS ADDR
         STH,D3   D3                IN BOTH HWDS
         AW,D3    D4                SECT0 ADDR IN RT. HWD
         STW,D3   PLRD00,R7         IN PLIST
         STH,D2   D3                SECT0 SIZE IN L. HWD
         STW,D3   TREE00,R7         IN TREE
         SLS,D3   16                ADDR IN L. HWD
         STW,D3   HEAD00,R7         IN HEAD
         SLS,D3   -16               BACK TO RT HWD
         STW,D3   HEADBIAS,R7       IN HEAD
         AW,D2    D3                END OF SPACE
         STW,D2   MAX00,R7          SAVE END OF SECT0
         AWM,D2   MAX00,R7          (WD ADDR)
         SW,D2    SR2               GET TOTAL SIZE
         CW,D2    SR1
         BG       ERROUT            TOO BIG
         SLS,SR2  1                 WORD ADDRESSING NOW
         LW,SR1   SR2
         LI,D4    0                 ZERO OUT
         STD,D4   *SR1              WORK
         AI,SR1   2                 AREA
         BDR,D2   %-2
         SLS,D3   1                 WD ADDR OF SECT0
         LCI      4                 GET DUMMY RFDF ENTRY
         LM,R1    DEFENTRY
         STW,D3   R2                PUT SECT0 BIAS IN IT
         STM,R1   *SR2              PUT IN RFDF
         LI,D3    TREE+1            GET TREE ADDR
         AW,D3    R7
         STW,D3   PLTREE,R7         IN PLIST
         AWM,R7   *R7               SET CDT ADDR IN PLIST
         LW,D4    8ES               'E' OUT RELDICT
         LW,SR1   R2                SECT0 WD ADDR
         LW,R2    PLRD00,R7         GET
         SLS,R2   -16               RELDICT DW ADDR
         SW,R2    HEADBIAS,R7       -#DWDS IN RELDICT
         STD,D4   *SR1,R2
         BIR,R2   %-1
         PULL     10,SR4
         B        *SR4
ERROUT   LW,R5    R3
         BAL,SR4  LISTIT            LIST CARD
         PULL     10,SR4
ERROUTS  LI,D3    NOPG
         CAL1,2   LLIST
         MTW,1    P2ABRT,R3
ERROUTM  LW,R1    GOTTENPGS
         OR,R1    =X'09000000'
         CAL1,8   R1
         LI,SR1   -1                SET FLAG FOR WRITELM
         AI,SR4   -1                FIND ERROR RETURN ADDRESS
         MTB,0    *SR4              (FIRST INSTR WITH 0 OP CODE)
         BNEZ     %-2
         LW,SR4   *SR4
         B        *SR4
NOPG     TEXTC    '***INADEQUATE CORE SPACE - SKIP TO NEXT CC'
ERRTM    LH,SR3   SR3
         BAL,SR4  CONVT
         STH,R4   TMIOERR+7
         SLS,R4   -16
         STH,R4   TMIOERR+5
         LCI      3
         LM,R1    *D3
         STM,R1   TMIOERR+9
         LI,D3    TMIOERR
         BAL,SR4  LOGIT
         B        EXITWRT
         PAGE
WRITELM  EQU      %
         CI,SR1   -1
         BE       NOWRT             ERROR, SKIP WRITE
         PUSH     13,R1
         LW,D1    HEADBIAS,R7       CALCULATE
         SW,SR1    D1              SECT0
         SW,SR1   D1                SIZE
         BEZ      %+3
         AI,SR1   2                 ROUND SIZE TO DOUBLE-WORD LENGTH
         SLS,SR1  -1                PUT
         STH,SR1  D1                IN
         STW,D1   TREE00,R7         TREE
         STW,D1   HEAD00,R7
         LI,D2    X'FFFF'
         LW,D1    TREERFDF,R7
         LS,D1    HEADRFDF,R7
         STW,D1   HEADRFDF,R7
         LI,D1    X'18'
         AWM,D1   HEAD,R7
         LW,R3    TREERFDF,R7       PUT
         SLS,R3   1                 CSECT
         LW,D1    CSEC03            DEF
         STW,D1   0,R3              IN
         LW,D1    FWDREF            REFDEF
         STW,D1   3,R3              STACK.
         M:SETDCB M:TM,(ERR,ERRTM),(ABN,ERRTM)
         LCI      3                 GET
         LM,R1    *D3               FILE
EXITWRT  EQU      %
         STM,R1   FILEN,R7          NAME IN OPEN FPT
         STM,R1   TREE+1,R7         AND TREE
         CAL1,1   OPEN,R7           OPEN THE FILE
         LW,R3    R7
         AI,R3    HEAD              WRITE
         LI,R2    X'FF'
         AND,R2   HEAD,R7
         LI,R1    HEADKEY           THE
         CAL1,1   WRITE             HEAD.
         AI,R3    TREE-HEAD         WRITE
         LI,R2    TREESIZ           OUT
         LI,R1    TREEKEY           THE
         CAL1,1   WRITE             TREE.
         LW,R1    R7                SET
         AI,R1    FILEN             UP
         MTB,1    *R1               THE
         LB,R4    *R1               KEY (FOR RFDF)
         STB,D1   *R1,R4            (D1)= 01050000
         LI,D2    TREERFDF          WRITE
         LI,R6    2                 REFDEF
         BAL,SR3  RECWRT            STACK.
         LI,D2    TREEEXP           WRITE
         BAL,SR3  RECWRT            EXPRESSION STACK.
         LW,R2    TREE00,R7         RELDICT BYTE SIZE (L.HWD)
         LW,R3    PLRD00,R7         RELDICT LOC (L. HWD)
         SW,R3    HEADBIAS,R7       ZAP RT. HWD
         LI,R6    -16               WRITE
         BAL,SR3  RECWRT+2          RELDICT
         LI,R6    3                 WRITE
         LI,D2    TREE00            OUT
         BAL,SR3  RECWRT            SECT0.
         CAL1,1   CLOSE
         LW,R1    GOTTENPGS
         OR,R1    =X'09000000'
         CAL1,8   R1                RELEASE ONLY GOTTEN PAGES
         PULL     13,R1
NOWRT    EQU      %
         LI,D1    -#DUMLM           READJUST
         MSP,D1   *R0               STACK
         PLW,D1   *R0               POINTER
         CW,D1    R0                AND
         BE       *SR4              RETURN
         PSW,D1   *R0
         B        *SR4
RECWRT   LW,R2    *D2,R7            GET SIZE AND ADDR
         SLD,R2   -16               SEPARATE
         SLS,R2   0,R6              CNVT TO BYTES
         SLS,R3   -15               CNVT TO WDS
         CAL1,1   WRITE
         MTB,1    *R1,R4            INCREMENT KEY
         B        *SR3
         PAGE
DUMLM    EQU      %
R7LOC    EQU      %
PLISTLOC EQU      %-DUMLM
PLIST    EQU      %-R7LOC
PLTREE   EQU      PLIST+2
PLRDFEXP EQU      PLIST+3
PLRD00   EQU      PLIST+4
PLUPLMS  EQU      PLIST+7
         DATA     CDT,0,0,0,0,0,0,0
CDT      EQU      %-R7LOC           CHANGE DESCRIPTION TABLE
         RES      10
HEAD     EQU      %-R7LOC
HEADBIAS EQU      HEAD+2
HEAD00   EQU      HEAD+3
HEADRFDF EQU      HEAD+5
         DATA     X'8100FF18',X'40000000',0,0,0,12
         DATA     0,0,0,0,0,0
         DEF      TREE00
TREE     EQU      %-R7LOC
TREE00   EQU      TREE+6
TREERFDF EQU      TREE+7
TREEEXP  EQU      TREE+9
         DATA     12,0,0,0,0,0,0,4**16,0,0,0,0
TREESIZ  EQU      (%-R7LOC-TREE)*4
MAX00    EQU      %-R7LOC
         RES      1                 END OF SECT0 (WD ADDRESS)
OPEN     EQU      %-R7LOC
         GEN,8,24 X'14',M:TM
         GEN,8,7,9,8 7,36,0,1
         DATA     2,2,2,2,63
         GEN,8,8,8,8 1,1,3,3
FILEN    EQU      %-R7LOC
         RES      3
#DUMLM   EQU      %-DUMLM
WRITE    GEN,8,24 X'11',M:TM
         GEN,5,23,4 7,3,0           WAIT,NEWKEY
         PZE      *R3               BUFFER
         PZE      *R2               SIZE
         PZE      *R1               KEY
CLOSE    GEN,8,24 X'15',M:TM
         GEN,1,31 1,0
         DATA     2                 SAVE
GETPG    GEN,8,24 8,100
GOTTENPGS  DATA   0
X3       DATA     3
8ES      DATA     X'EEEEEEEE'
DEFENTRY DATA     X'04000000',0,X'00000100',X'01000000'
01NAME   EQU      DEFENTRY+3
CSEC03   DATA     X'03060000'
FWDREF   DATA     X'01050000'
HEADKEY  TEXTC    'HEAD'
TREEKEY  TEXTC    'TREE'
PREV     DATA     0
RBSIZ    EQU      10
P2PATCH  EQU      %
         RES      50
         END      PASS2
