         SYSTEM   SIG7FDP
UTSPROC  SET      0
S69PROC  SET      1
BITS     SET      1
         SYSTEM   UTS
*M*      SETAMR HANDLES SET AND A/M RECORD FOR TEL
         SPACE    3
************************************************************************
*P*      NAME:    SETAMR                                               *
*P*      PURPOSE:                                                      *
*P*               HANDLES PROCESSING OF ALL SET FUNCTIONS AND          *
*P*               ASSIGN/MERGE RECORD MANIPULATION FOR TEL             *
*P*      DESCRIPTION:                                                  *
*P*               MOST OF THE PROCESSING IN THIS MODULE IS INVOKED BY  *
*P*               THE SET COMMAND.  ASSIGN/MERGE RECORD ENTRIES ARE    *
*P*               BUILT BY FILLING IN A SKELETON OPEN PRIME PLIST      *
*P*               AND THEN COMPACTING IT TO ELIMINATE UNUSED ENTRIES.  *
*P*               UPDATES TO AN ASSIGNMENT INVOLVE EXPANDING THE       *
*P*               COMPACTED ENTRY TO MAKE THE CHANGES.                 *
*P*      REFERENCE:                                                    *
*P*               TEL IS DESCRIBED IN THE CP-V T/S REFERENCE MANUAL,   *
*P*               900907.                                              *
************************************************************************
         SPACE    3
*        **********
*        *  DEFS  *
*        **********
         DEF      ASSIGN            EDITS A/M RECORD ENTRIES
         DEF      FILENT
         DEF      MODE
         DEF      NAME
         DEF      PACC
         DEF      PLIST
         DEF      PPAS
         DEF      READAM
         DEF      RESET             PROCESSES R COMMAND
         DEF      SET               PROCESSES SET COMMAND
         DEF      SETFLE
         DEF      SETNUMB
         DEF      WRITEAM
         DEF      DCBSCAN
         TITLE    'SETAMR'
*        **********
*        *  REFS  *
*        **********
         REF      AMBUF             WINDOW PAGE TO READ A/M (SBUF2VPA)
         REF      CMNERR1           TYPES MSG & PROMPTS
         REF      DECBIN            CONVERTS DECIMAL EBCDIC TO BINARY
         REF      EXPNDSZ           TEMP IN SBUF1
         REF      FEXTIMG           TEMP IN SBUF1(FILE EXTENSION
*,*                                 BITS AT A/M READ TIME)
         REF      FID               RETURNS FID AS N.A.P
         REF      FIPROC            J:TELFLGS BIT
         REF      F0F9              DBLWD CONSTANTS
         REF      GETFIELD          GETS NEXT FIELD IN COMMAND LINE
         REF      GPFPT             FPT FOR GET PAGE CAL
         REF      J:ABUF            IN CORE ADDRESS OF ASSIGN/MERGE
*,*                                 RECORD, DEFINED IN JIT
         REF      J:ACCN            ACCOUNT FIELD IN JIT
         REF      J:CPPO            FILE EXTENSION BITS IN JIT
         REF      J:JIT             JIT
         REF      J:OPT             FLAGS REFERENCED BY PROCESSORS AND
*,*                                 SET/RESET BY TEL 'DONT'
         REF      J:TELFLGS         JIT FLAGS UNIQUE TO TEL. REFER
*,*                                 TO JIT DOCUMENTAION & MODULE TELMN
*,*                                 FOR BIT USAGE DETAILS & NAMES
         REF      M:TEL             DCB IN TEL'S CONTEXT PAGE
         REF      MSTRMODE          FPT FOR M:MASTER BEFORE SUA
         REF      NFND              CONVERTS FILE NAME TO TEXTC
         REF      NTJBST            ERROR 030100
         REF      OH:NM             OPLABEL NAMES.  TABLE
*,*                                 GENERATED BY PASS2, LOADED WITH TEL
         REF      OPENME            OPEN UC PLIST, 1ST WD NO DCB
         REF      OV:NMSZ           LENGTH OF OH:NM WITH OPLABELS AND
*,*                                 DEVICE TYPE MNEMONICS
         REF      PROMPT            TYPES BANG & READS TERMINAL
         REF      SB:RTY            RESOURCE TYPE, PARALLEL TO SH:RNM
         REF      SCAN              FINDS TERMINATOR FOR NEXT FIELD
         REF      SCAN#             ENTRY TO SCAN WHICH INCLUDES '#' AS
*,*                                 A DELIMITER
         REF      SETBUF            ADDR OF BUFR TO BUILD OPEN PRIME PLIST
         REF      SETBUFE           ADDR OF END OF SETBUF
         REF      SETBUFSZ          SIZE PLIST WORKING BUFFER
         REF      SETSTP            DELIMITER DOLIST
         REF      SH:RNM            RESOURCE NAME TBL, GENERATED BY
*,*                                 PASS2 AND LOADED WITH TEL
         REF      SINOREL           J:TELFLGS BIT
         REF      SISET             J:TELFLGS BIT
         REF      SV:RSIZ           SIZE OF SH:RNM
         REF      SYNTAX            TYPES ERROR MSG
         REF      SYN1              SYNTAX ERROR EXIT W/O MSG
         REF      SYSERR            ENTRY POINT FOR MONITOR DTECTED ERRS
         REF      SZCELL            TEMP CELL IN TELSTACK
         REF      T%ERRTXT          OPENS STACK & GETS ERRMSG
         REF      T%WRTERR          WRITES ERRMSG & CLEANS STACK
         REF      TB:FLGS           PHYSICAL DEVICE ATTRIBUTES, INDEXED
*,*                                 BY SB:RTY ENTRY
         REF      TELSTACK          TEL'S WINDOW PAGE, SBUF1VPA
         REF      TM:SI             M:SI IN TEXTC
         REF      TYPMNSZ           LENGTH OF OH:NM WITH DEVICE TYPE
*,*                                 MNEMONICS
         REF      VERB2             DWD LIST OF COMMAND VERBS, FIRST
*,*                                 DWD IS BLANKS
         REF      WRITE             M:UC WRITE FPT
         REF      DCBBUF
         REF      BLANKBUF
*        **********************
*        * REFS FROM LITERALS *
*        **********************
         REF      STDOPT            DEFAULT SETTING FOR J:OPT
         REF      XFF               DATA
         REF      XFFFF             DATA
         REF      Y05
         REF      Y06
         REF      Y07
         REF      YFFFF
*        ********************
*        * REFS FROM AMRDEF *
*        ********************
         REF      AM:ORG            AVAILABLE SPACE POINTER
         REF      AM:LNK            POINTER TO 1ST PLIST
         REF      AM:STDOP          INTER-JOB-STEP IMAGE OF J:OPT
         REF      AM:HED            LENGTH OF HEADER
         PAGE
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
XF0      EQU      F0F9              (DATA X'F0')
************************************************************************
DBUG     SET      0                 NORMAL ASSEMBLY
************************************************************************
         PAGE
************************************************************************
*  THESE PROCS ARE USED TO MANIPULATE TEL'S STACK IN SBUF1VPA          *
************************************************************************
*
* PROC TO CHANGE STACK POINTER THE AMOUNT SPECIFIED BY THE 1ST ARGUMENT
* USING THE REGISTER SPECIFIED BY THE 2ND ARGUMENT.
*
BUMP     CNAME
         PROC
LF       LI,AF(2) AF(1)
         MSP,AF(2)  TELSTACK
         PEND
*
* PUSH OR PULL N WORDS SPECIFIED BY 1ST ARGUMENT INTO REGS 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  0,NAME(1),AF(1),0,TELSTACK
         ELSE
         DO       AF(1)=1
LF       GEN,1,7,4,3,17  0,NAME(1),AF(2),0,TELSTACK
         ELSE
         DO       AF(1)=16
LF       LCI      0
         ELSE
LF       LCI      AF(1)
         FIN
         GEN,1,7,4,3,17  0,NAME(2),AF(2),0,TELSTACK
         FIN
         FIN
         PEND
         TITLE    'RESET COMMAND'
************************************************************************
*D*      NAME:    RESET                                                *
*D*      DESCRIPTION:                                                  *
*D*               THE RESET ROUTINE REMOVES ALL CURRENT DCB            *
*D*               ASSIGNMENTS BY RESETING THE HEAD OF THE ASSIGNED     *
*D*               CHAIN TO THE BEGINNING OF THE PLIST AREA IN THE      *
*D*               A/M RECORD.                                          *
*D*      CALL:                                                         *
*D*               ENTERED BY BRANCH FROM VECTOR1 OR VECTOR2 ON 'R'     *
*D*               OR 'RESET' COMMAND.  RETURNS TO PROMPT FOR NEW       *
*D*               COMMAND.                                             *
*D*      REGISTERS:     USES R4,R5 AND SR4. ALL OTHERS ARE UNTOUCHED.  *
*D*      INPUT:                                                        *
*D*               J:TELFLGS - CHECK FOR JOB STEP                       *
*D*               J:ABUF - CORE BUFR ADDRESS OF A/M RECORD             *
*D*               STDOPT - VALUE IN MONITOR ROOT USED TO RESET J:OPT   *
*D*      OUTPUT:  SETS J:OPT = AM:STDOP = STDOPT                       *
*D*               WRITES NEW A/M RECORD                                *
*D*      SCRATCH:                                                      *
*D*               ALL REGS USED ARE SCRATCH                            *
************************************************************************
RESET    EQU      %
************************************************************************
*E*      ERROR:                                                        *
*E*               GROUP 3, CODE=01,SUBCODE=00                          *
*E*      DESCRIPTION:                                                  *
*E*               USER TRIED TO RESET A/M RECORD BETWEEN JOB STEPS.    *
*E*               WE GIVE HIM ERROR MSG AND THEN ALLOW QUIT OR GO.     *
************************************************************************
         LI,R5    1
         LS,R5    J:TELFLGS         CHECK IF AT JOB STEP
         BNE      %+2               O.K., WE'RE AT JOB STEP
         B        NTJBST            REPORT ERROR 030100
         BAL,SR4  READAM            READ IN A-M RECORD
         LW,R4    J:ABUF            A-M BUFFER ADR
         LW,R5    AM:LNK,R4         ANY PLISTS?
         BEZ      NOPLSTS           NOPE, LET IT BE.
         STW,R5   AM:ORG,R4         SET AVAIL PNTER TO CURRENT PLIST
         LI,R5    0
         STW,R5   AM:LNK,R4         ZERO IN USE CHAIN
NOPLSTS  EQU      %
         LW,R5    STDOPT            RESET TO STANDARD OPTIONS
         STW,R5   J:OPT
         STW,R5   AM:STDOP,R4
         BAL,SR4  WRITEAM           RE-WRITE A-M RECORD
         B        PROMPT            GET NEXT COMMAND
*
         TITLE    'SET COMMAND VERB'
************************************************************************
*F*      NAME:    SET                                                  *
*F*      PURPOSE:                                                      *
*F*               PROCESSES THE SET COMMAND AND ITS OPTIONS.  THE SET  *
*F*               COMMAND IS ANALOGOUS TO THE ASSIGN CARD IN BATCH.    *
*F*               IT IS USED TO CREATE AND MODIFY ENTRIES IN THE       *
*F*               ASSIGN/MERGE RECORD WHICH ARE MERGED INTO THE DCB AT *
*F*               OPEN TIME.                                           *
*F*      DESCRIPTION:                                                  *
*F*               SET FUNCTIONS ARE ALLOWED ONLY AT JOB STEP TIME.     *
*F*               THE ENTIRE SET COMMAND IS PROCESSED BEFORE ANY       *
*F*               PERMANENT UPDATES ARE MADE TO THE A/M RECORD.        *
*F*      REFERENCE:                                                    *
*F*               REFER TO DETAIL DESCRIPTIONS FOR PROCESSING OF       *
*F*               INDIVIDUAL SET OPTIONS.                              *
************************************************************************
*D*      NAME:    SET                                                  *
*D*      DESCRIPTION:                                                  *
*D*               THIS IS THE MAIN ENTRY TO THE SET LOGIC.  THE        *
*D*               A/M RECORD IS READ IN AND THE SET COMMAND IS PARSED  *
*D*               TO THE TERMINATOR AFTER THE DCB NAME.  IF ';' AN     *
*D*               EXISTING ENTRY IS BEING UPDATED.  '/' IMPLIES A FILE *
*D*               NAME.  OTHERWISE, THE COMMAND IS SCANED FOR DEVICE   *
*D*               TYPE.  ZERO MEANS DELETE THE ENTRY FOR THIS DCB.     *
*D*      CALL:                                                         *
*D*               ENTERED BY BRANCH FROM VECTOR1 ON 'SET' COMMAND.     *
*D*               RETURNS EVENTUALLY TO 'PROMPT' IF PROCESSING IS      *
*D*               SUCCESSFUL.                                          *
*D*      REGISTERS:                                                    *
*D*               NO REGISTERS ARE PRESERVED.                          *
*D*      INPUT:                                                        *
*D*               COMMAND LINE IN TELBUF                               *
*D*               A/M RECORD                                           *
*D*               J:TELFLGS                                            *
*D*      OUTPUT:                                                       *
*D*               A/M RECORD IS REWRITTEN IF AN ENTRY IS RELEASED      *
*D*               J:TELFLGS, BIT 28, IS RESET IF M:SI IS RELEASED      *
*D*      DATA:                                                         *
*D*               SETSTP - BRANCH VECTOR INDEXED BY SCAN TERMINATOR    *
*D*               R4 = ADDR OF SETBUF                                  *
*D*      INTERFACE:                                                    *
*D*               READAM,WRITEAM - TO READ/WRITE A/M RECORD            *
*D*               ASSIGN - TO RELEASE DCB ENTRIES IF DEVICE = '0'      *
*D*               SETUPDAT - TO MODIFY EXISTING ENTRIES                *
*D*               SETFILE - IF FILE IMPLIED BY '/'                     *
*D*               SETFLE - FOR XX/                                     *
*D*               SETNUMB - FOR XX#                                    *
*D*               SYNTAX - FOR ERROR EXIT                              *
************************************************************************
         SPACE    3
SET      EQU      %
************************************************************************
*E*      ERROR:                                                        *
*E*               GROUP 3, CODDE=01,SUBCODE=00                         *
*E*      DESCRIPTION:                                                  *
*E*               USER TRIED TO DO SET BETWEEN JOB STEPS.  WE GIVE HIM *
*E*               THE ERROR MSG AND THEN ALLOW QUIT OR GO.             *
************************************************************************
         LI,R5    1                 INSURE WE'RE AT JOB STEP
         LS,R5    J:TELFLGS
         BNEZ     %+2               O.K.
         B        NTJBST            REPORT ERROR 030100
         PUSH     2,R1
         LI,R1    DCBBUF
         LI,R2    32
         BAL,R4   BLANKBUF
         PULL     2,R1
         LI,R3    DCBBUF
         BAL,SR3  SCAN
DCBSCAN  PUSH     R6
         BAL,SR3  DCBTXC
         LCI      3
         LM,R6    DCBBUF
         BAL,SR4  CHKDCBN           CHECK VALID DCB NAME
         BAL,11   READAM            GET  A/M                         RL2
         PULL     0                                                  RL2
         CI,0     ';'                                                RL2
         BE       SETUPDAT                                           RL2
         LI,R4    0
         LI,R5    SETBUFE           ZRO WORK AREA
         STW,R4   *R5                & SET R5=SETBUF
         CI,R5    SETBUF
         BE       %+2
         BDR,R5   %-3
         AI,R5    1                 SETBUF+1
         LB,R4    DCBBUF
         STB,R4   *R5               BYTE CNT TO SETBUF
         LB,SR3   DCBBUF,R4
         STB,SR3  *R5,R4            MOVE NAME TO BUF
         BDR,R4   %-2
         AI,R5    -1                R5(SETBUF)
         LB,12    DCBBUF
         AI,12    8                                                  RL2
         SLS,12   -2                                                 RL2
         LW,8     OPENME                                             RL2
         STW,8    *12,5             1ST WD OF PLIST                  RL2
         LI,3     D1                                                 RL2
         LD,D1    VERB2
         STW,R5   R4                SAVE A/M ENTRY ADDRESS
          LI,R7   0
         CI,R0    '/'               WAS A DC/FID IMPLIED
         BE       SETFILE           YES
         BAL,SR3  SCAN#             GET DEVICE FIELD
         CI,R7    0                 CHECK IF RESET REQUEST
         BE       SET10             B IF YES
         LI,D4    '0'               CHECK FOR RELEASE
         CB,D4    D1
         BNE      SET2
SET10    EQU      %
         LCI      3                                                  RL2
         LM,R6    1,R4              OF HIS OLD ENTRY SO JUST RELEASE THE
         LW,R4    J:ABUF            CURRENT ONE.
         BAL,SR4  ASSIGN+2
         CD,R6    TM:SI
         BNE      %+4
         LI,R7    -9                RESET SI BITS
         AND,R7   J:TELFLGS         AS SI IS RELEASED
         STW,R7   J:TELFLGS
         BAL,SR4  WRITEAM           WRITE THE ASSIGN/MERGE
         B        PROMPT            AND GO AGAIN
SET2     EXU      SETSTP,R5         TEST DELIMITER AND DO REQ'D LOGIC
         CW,D1    VERB2             INSURE WE'RE PROCESSING SOME CODE
         BE       SYNTAX            HE NEVER ENTERED ANOTHER FIELD
*
* SCAN FOR LEGAL CODE COMBINATION AND PROCESS ACCORDINGLY.
*
         CI,R7    2                 WD SHOULD ONLY HAVE A TWO CHARACTER
         BG       SYNTAX            DEVICE CODE OR OP LABEL
         SAS,D1   -16
         LI,R7    OV:NMSZ           TBL SIZE TO R7
         CH,D1    OH:NM,R7          TBL SRCH
         BE       SETDEVA           GOOD OP LABEL
         BDR,R7   %-2
         CH,D1    OH:NM             IS IT A 'NO' ENTRY???
         BE       SETDEVA           YES IT IS
         AND,D1   XFFFF
         CI,D1    'FT'              FREE FORM TPE?
         BNE      SYNTAX            CANT FIND
         LI,D1    '9T'              DEFAULT-> 9T
         B        SETDEVA
*
DOER     CI,R6    ';'               DOES HE WANT ANY MORE
         BE       SETKEYS           YES-DO KEYWORD OPTIONS
************************************************************************
*E*      ERROR:                                                        *
*E*               GROUP 3,CODE=01,SUBCODE=01                           *
*E*      DESCRIPTION:                                                  *
*E*               WHEN LOOKING FOR DEVICE OPTIONS ON SET COMMAND       *
*E*               FOUND FIELD NOT PRECEDED BY ';'. THIS IS ILLEGAL     *
*E*               SYNTAX.                                              *
************************************************************************
         CI,R1    1                 MORE DATA AT THIS POINT IMPLIES
         BLE      %+3                  A BAD FORMAT MSG
         LI,D1    X'030101'         ERROR CODE & SUBCODE
         B        CMNERR1           REPORT IT
* SET DEVICE = 'DP' BY DEFAULT WHEN DEVICE ISN'T SPEC'D AND WHEN SN
* AND FILE SPEC'D.
         BAL,SR4  ADJUST4
         LI,R7    X'40000'          WAS DEVICE SPEC'D
         CS,R7    2,R4
         BE       DOER10            YES
         LI,R3    7
         LS,R3    1,R4              WAS THIS A FILE ASSIGNMENT
         CI,R3    1
         BNE      DOER10            NO
         MTW,0    PFOUT,R4          WAS SN SPEC'D
         BEZ      DOER10            NO
         STS,R7   2,R4              SET = 'DP' BY DEFAULT
         LI,R7    'DP'
         STW,R7   P14,R4
DOER10   EQU      %
         PULL     R4
         BAL,SR4  TRUNDLE           COMPACT SKELETAL PLIST
         LCI      3
         LM,R6    DCBBUF
         LW,R4    J:ABUF
         BAL,SR4  ASSIGN            GET SLOT FOR ENTRY
         BAL,SR4  MOVESET           MOVE COMPLETED ENTRY
*                                   TO A/M BUF FOR WRITE OUT.
         BAL,SR4  WRITEAM           WRITE A/M AND GO FOR NEXT CARD
         B        PROMPT
DCBTXC   LW,SR1   R7
DCBTXC1  AI,R7    -1
         LB,R6    DCBBUF,R7
         AI,R7    1
         STB,R6   DCBBUF,R7
         BDR,R7   DCBTXC1
         STB,SR1  DCBBUF
         B        *SR3
         PAGE
************************************************************************
*D*      NAME:    SETDEV                                               *
*D*      ENTRY:   SETDEVA - ALTERNATE ENTRY WHICH FORCES RETURN TO     *
*D*                         'DOER'                                     *
*D*      DESCRIPTION:                                                  *
*D*               THIS ROUTINE IS USED FOR STREAM AND DEVICE           *
*D*               CONNECTIONS.  IT SETS P14 IN THE OPEN PLIST AND      *
*D*               STORES THE DEVICE CODE IN THE PLIST.                 *
*D*      CALL:                                                         *
*D*               CALLED BY  BAL,SR3  SETDEV                           *
*D*      REGISTERS:                                                    *
*D*               USES R5,R7,SR4. LINK ON SR3. ALL OTHERS ARE PRESERVED*
*D*      INPUT:                                                        *
*D*               D1 = DEVICE CODE IN RIGHT HW                         *
*D*      OUTPUT:                                                       *
*D*               R5 = P14 BIT FOR PLIST                               *
*D*               R7 = DISPL OF P14 WORD IN PLIST                      *
*D*      INTERFACE:                                                    *
*D*               PENT - TO SET PLIST ENTRY                            *
************************************************************************
SETDEVA  LI,SR3   DOER              PROVIDE RETURN
SETDEV   AND,D1   XFFFF             ISOLATE CODE
         LI,R7    P14               SET POSITION AND
         LI,R5    X'40000'          PARAMETER BIT
         BAL,SR4  PENT              PLACE IT
         B        *SR3
         PAGE
************************************************************************
*D*      NAME:    SETNUMB                                              *
*D*      DESCRIPTION:                                                  *
*D*               PROCESSES SETS TO DEVICES WITH SERIAL NUMBERS.       *
*D*               THE DEVICE IS VALIDATED FOR SN (TAPE OR DISC).  IF   *
*D*               THE SN IS FOLLOWED BY '-' AND DEVICE TYPE,  THE      *
*D*               DEVICE TYPE IS VALIDATED.  THE SN IS STORED INTO THE *
*D*               OPEN PRIME PLIST.                                    *
*D*      CALL:                                                         *
*D*               ENTERED BY BRANCH THROUGH VECTOR 'SETSTP' WHEN       *
*D*               SCAN IS TERMINATED BY '#'.                           *
*D*      REGISTERS:                                                    *
*D*               R4 IS PRESERVED. ALL OTHERS MAY BE CLOBBERED.        *
*D*      INPUT:                                                        *
*D*               R4 - ADDR OF SETBUF                                  *
*D*               R6 - TERMINATOR FROM SCAN                            *
*D*               R7 - FIELD COUNT FROM SCAN                           *
*D*               D1 - FIELD FROM SCAN (DEVICE MNEMONIC)               *
*D*      DATA:                                                         *
*D*               XH:RN1 - TABLE OF SYNONYMS FOR TAPES                 *
*D*               XH:RN2 - TABLE OF OTHER SYNONYMS                     *
*D*               SH:RNM - SYSTEM TABLE OF DEVICE NAMES                *
*D*               SB:RTY - DEVICE TYPES, PARALLEL TO SH:RNM            *
*D*               TB:FLGS - DEVICE ATTRIBUTES, BIT0=DISC, BIT1=TAPE    *
*D*      OUTPUT:                                                       *
*D*               DEVICE MNEMONIC AND SN ARE SET IN OPEN PRIME PLIST   *
*D*               REGISTERS ARE SET FROM SCAN OF SN                    *
*D*      INTERFACE:                                                    *
*D*               SCAN - SCAN NEXT FIELD                               *
*D*               SIXPACK - HASHES 6 DIGIT ANS SN TO 4 CHARS           *
*D*               ADJUST4 - COMPUTES LOCATION PAST DCB NAME            *
*D*               SETDEV - MAKES DEVICE ENTRY IN PLIST                 *
*D*               SETFILE1 - WHEN FILE NAME FOLLOWS '/'                *
*D*               DOER - TO SEARCH FOR DEVICE OPTION KEYWORDS          *
************************************************************************
SETNUMB  EQU      %
         CI,R7    2                 INSURE WE GOT A DEVICE CODE
         BG       SYNTAX
         SAS,D1   -16               SHFT FOR COMPARE
         LI,R7    XV:RS1            TPE TBL (9T)
         CH,D1    XH:RN1,R7         LOOK FOR TPE TYPE
         BE       SETNUMBC          GOT IT
         BDR,R7   %-2
         LI,R7    XV:RS2            'OTHER' TBL SIZE
         CH,D1    XH:RN2,R7         7T,DP..ETC
         BE       SETNUMBH          DONT DEFAULT THESE
         BDR,R7   %-2
         B        SYNTAX            NO FIND
SETNUMBC AND,D1   XFFFF             DELETE SIGN EXT.
         PUSH     D1                SAVE FIELD FOR ASN
         LI,D1    '9T'              DEFLT DEV FOR XH:RN1
*                 CAN OVERRIDE DEFAULT(9T) BY -TT
         B        SETNUMBG
*
SETNUMBH AND,D1   XFFFF             DELETE SIGN EXT.
         PUSH     D1                SAVE FIELD FOR ASN
SETNUMBG BAL,SR3  SETDEV            SET IN OPLBL FIELD
         LI,R3    D1
         LD,D1    VERB2
         BAL,SR3  SCAN#             LOOK FOR '-'
         LI,5     X'4002'                                            RL2
         PULL     R3
         CI,R3    'AT'
         BNE      SETNUMBI
         LI,R5    X'4005'
         CI,R6    '-'               ANS TPE MUST
         BE       %+3                 MUST BE LABELED
         CI,R6    '/'                  IST CURSORY
         BNE      SYNTAX                 CHECK.
         CI,R7    6                 'AT' SN=6 CHARS ALWAYS
         BNE      SYNTAX
         LI,SR4   SETNUMBD          SET RETURN REG.
         B        SIXPACK           HASH SN
SETNUMBI CI,R7    4
         BG       SYNTAX
         CI,R3    'DP'
         BNE      SETNUMBD
         LI,R5    X'4001'           YES, SET F11,F12 TO FILE
SETNUMBD BAL,SR4  ADJUST4
         STS,R5   1,R4
         AI,4     PFOUT                                              RL2
         STW,D1   1,R4              INSN                             RL2
         LW,D1    INSN              VLP CONTR WD
         STW,D1   0,R4                                               RL2
         XW,R4    *TELSTACK         RESTORE SETBUF TO R4
*                                      AND SAVE CURRENT POINTER
         STW,R3   D4                SAVE DEVICE CODE
         CI,R6    '-'
         BNE      SETNUMBE          EXPECT '/' NEXT
         LI,R3    D1
         LD,D1    VERB2
         BAL,SR3  SCAN
         CI,R7    2
         BNE      SYNTAX
         CI,D4    'AT'              ANS ONLY MUST BE
         BNE      %+3                  LABELED TAPE
         CI,R6    '/'               IS IT???
         BNE      SYNTAX            ABORT COMMND
         LI,R7    SV:RSIZ           TBL SIZE
         SAS,D1   -16               SHIFT ENTRY
         CH,D1    SH:RNM,R7
         BE       %+3
         BDR,R7   %-2
         B        RTYERR
         LB,R7    SB:RTY,R7         GET INDX TO TB:FLGS
         CI,R7    X'FF'             IS IT NONDEV TYPE?
         BE       RTYERR            BAD TYPE ENTERED
         AND,D4   XFF               MASK TO T OR P
         LC       TB:FLGS,R7        GET DEV TYPE
         BCR,8    RTYERR            NOT TPE OR DISK
         BCR,4    %+4               GO, SET FOR TAPE
         CI,D4    'P'               WAS IT A DP??
         BE       SETNUMBF
         B        RTYERR
         CI,D4    'T'               WAS AT,MT,9T,7T??
         BNE      RTYERR
SETNUMBF BAL,SR3  SETDEV
SETNUMBE EQU      %
         PULL     R3                RESTORE INDEX
         CI,R6    '/'
         BE       SETNUMBJ          FILE WAS SPECIFIED
         CI,D4    'LT'              'LT' & NO FILE
         BE       SYNTAX               IS AN ERROR
         LI,R5    X'F000'           MASK
         LS,R5    1-PFOUT,3         GET CURR. ENTRY
         STW,R5   1-PFOUT,3
         B        DOER
SETNUMBJ CI,D4    'FT'              'FT' & FILE SPECIFIED
         BE       SYNTAX               IS AN ERROR
         B        SETFILE           O.K.  PROCESS FILE NAME
         PAGE
*
* PROCESS INVOKED FOR SIMPLE FILE PLIST WITH NO INSN
* OR SN.    COMMAND FORM: SET X:XXX  YY/FILENAME
*     X:XXX=DCBNAME
*    YY= OP OR DEV LABEL.
*
SETFLE   EQU      %
         CI,R7    2                 # CHARS IN FIELD YY OK?
         BG       SYNTAX
         SAS,D1   -16               SFT FOR COMP
         INT,D2   D1                KNOCK OFF SIGN BITS
         CI,D2    'JR'              IS IT TP JOURNAL?
         BNE      %+3               NO
         LI,R5    X'4004'           SET ASN TO TP JOURNAL
         B        SETFASN
         CI,D2    'LT'
         BE       SETFLE1           LT=>9T OR DEFAULT
         CI,D2    'MT'              MT=>9T OR DEFAULT
         BNE      %+2               NEITHER, GO NORMAL
SETFLE1  LI,D1    -X'061D'          = '9T' WITH SIGN EXTENSION SET...
*                                   ... TO MAKE COMPARE WORK
         LI,R7    TYPMNSZ
         CH,D1    OH:NM,R7          DONT BOTHER TO CHK 'NO'
         BE       %+3
         BDR,R7   %-2
         B        SYNTAX
         PUSH     R7                SAVE INDEX
         BAL,SR3  SETDEV
         PULL     R7
         LI,R5    X'4002'           SET FOR TAPE
         LC       TB:FLGS,R7        GET DEV TYPE
         BCR,8    SYNTAX            NOT TPE OR DISC
         BCR,4    %+2
         LI,R5    X'4001'           SET FOR DISC
SETFASN  EQU      %
         BAL,SR4  ADJUST4           STEP OVER DCB NME
         STS,R5   1,R4              PLCE IN PLIST
         PULL     R4                EVEN UP FROM ADJUST4
*
* PROCESS INVOKED WHEN A / HAS TERMINATED THE SCAN. IT IMPLIES THAT A
* FILE PLIST IS TO BE BUILT.
*
SETFILE  RES     0
         PUSH     D2                SAVE DEVICE CODE
         BAL,SR3  GETFIELD          GET FID
         CI,R7    0                 INSURE WE GOT SOMETHING
         BE       SYNTAX
         CI,R6    '.'               TEST FOR COMPLEX FID
         BNE      %+3               NONE
         BAL,SR4  FID               BREAK FID
         B        SETFILE2
         LCI      2
         LM,SR2   J:ACCN
         LI,R7    0
SETFILE2 PUSH     R6                SAVE TERMINATOR
         PUSH     D1                SAVE NAME
         LW,D1    PPAS              GET PASSWORD VLP CONT. WD
         AI,D1    -X'010000'           & TURN OFF LAST INDICATOR
         CI,R7    0                 SEE IF WE HAVE ONE
         BNE      SETFILE3          WE DO
         LW,R7    VERB2             AND DUMMY WORD CONTENTS FOR COMPACT
         LW,SR1   VERB2
         B        %+2               LEAVE SIGNIF. OFF
SETFILE3 AI,D1    X'0200'           TURN ON EFFECTIVE WORD CNT
         LI,R5    0                 SIGNAL NO PP BITS FOR PENT
         PUSH     R7                HOLD PASSWORD
         LI,R7    PFPAS
         BAL,SR4  PENT
         PULL     D1
         AI,R7    1
         BAL,SR4  PENT
         STW,SR1  D1
         AI,R7    1
         BAL,SR4  PENT
         LW,SR1   PACC              IF PASSWORD FITS IN PLIST, NAME AND
         PULL     D1
         BAL,SR4  ADJUST4
         LCI      3                 ACCOUNT MAY BE ENTERED WITHOUT
         STM,SR1  PFACC,4
         BAL,SR3  NFND              AND MAKE IT TEXTC
         LW,R5    NAME
         LCI      4
         STM,5    PFNAM,4
         LI,R5    X'4001'           SET FILE INDICATOR BIT AND VARIABLE
         MTW,0    1,4                                                RL2
         BNEZ     %+2                                                RL2
         STS,5    1,R4                                               RL2
         PULL     R4                                                 RL2
         BAL,SR4  FEXTBITS          FILE EXT. IF 'M:'
         PULL     R6                REGAIN TERMINATOR
         PULL     D1                RESTORE DEVICE CODE TO D1
         B        DOER              FINISH UP
*
* THE FOLLOWING LOGIC IS ORGANIZED TO PROCESS THE VARIOUS KEYED OPTIONS
* WHICH MAY FOLLOW THE SEMI-COLON FOR DEVICE SPECIFICATIONS.
*
SETKEYS  CI,D1    'JR'              IS THIS FOR TP JOURNAL?
         BE       SYNTAX            YES, ILLEGAL
         BAL,SR3  GETFIELD          GO SCAN FOR KEYWORD
         CI,R7    0                 INSURE A KEYWORD WAS GIVEN
         BE       SYNTAX
         LI,R5    7                 MSK FOR TYPE FPT
         BAL,SR4  ADJUST4           IF SO, ALLOW CERTAIN FILE OPTIONS
         LS,R5    1,R4              FOR DEVICES MT,7T,9T.
         PULL     R4
         CI,R5    0
         BNEZ     FOPT
         LI,R5    SIZKEYS           DECODE KEYWD & ENTER CORRECT
         CW,D1    KEYS,R5           PROCESS-SAVE TERMINATOR IN R6
         BE       SETK
         BDR,R5   %-2
         LI,R5    SIZFKY
         CW,D1    FKEY,R5
         BE       JUNK
         BDR,R5   %-2
         B        SYNTAX
*
************************************************************************
*E*      ERROR:                                                        *
*E*               GROUP 03, CODE=01, SUBCODE=0A                        *
*E*      DESCRIPTION:                                                  *
*E*               A RECOGNIZED, BUT NON-DEVICE, KEYWORD WAS            *
*E*               FOUND WHILE PROCESSING A DEVICE SET.                 *
************************************************************************
JUNK     LI,R3    X'03010A'         ERROR CODE & SUBCODE
         B        BADOPT            INSERT KEYWORD IN MSG & TYPE
*
SETK     EXU      KEYVECT,R5        ENTER THE PROCESS
         LI,D1    -1
         B        LOPT
         TITLE    'SET COMMAND OPTION PROCESSING'
*
* THE FOLLOWING GROUPS OF CODE ARE NEEDED TO CREATE THE UNIQUE PLIST
* ENTRIES FOR THE DESIRED OPTION.
*
* TAB OPTION
*
TAB      CI,R6    '='               CHECK FOR EQUALS SIGN
         BNE      SYNTAX
         LW,R5    TELSTACK
         AI,R5    1
         BUMP     4,R6
         PUSH     R4                SAVE ENTRY ADDRESS
         LI,R4    0                 AND INITIALIZE TAB POSITION COUNT
         STW,R4   0,R5
         STW,R4   1,R5
         STW,R4   2,R5
         STW,R4   3,R5
         STW,R5   R0                SAVE PARAMETER LOCATION
TAB1     LW,D1    VERB2
         LI,R3    D1
         BAL,SR3  SCAN              GET TAB VALUE
         CI,R7    3                 ALLOW NO MORE THAN 3 CHARACTERS
         BG       SYNTAX
         BAL,SR4  DECBIN            CONVERT THE VALUE
         CI,R7    0
         BE       TAB2              FINISHED INPUT-INSERT INTO ENTRY
         STB,R7   *R0,R4            PLACE VALUE IN PARAMETER IMAGE
         AI,R4    1                 BUMP POSITION
         CI,R4    16
         BG       SYNTAX            TOO MANY TAB STOPS
         CI,R6    ','               ANY MORE
         BE       TAB1              YES-GET NEXT ONE
TAB2     LW,R3    R0                GET LAST TAB WORD INTO ENTRY-IF IT
         LW,D1    3,R3              FITS, THE THREE OTHERS ALSO WILL.
         LI,R7    DTABS+3
         LI,R5    0
         PULL     R4
         BAL,SR4  PENT
         BAL,SR4  ADJUST4           PUSH R4 AND ADD OFFSET           RL2
         LI,R7    DTABS
         LCI      3                 IT FIT SO PUT THE REST OF IT IN
         LM,D1    0,R3
         STM,D1   *R4,R7
         PULL     R4
         BUMP     -4,R5
         LI,7     DTABS+1                                            RL2
         LW,R5    BIT0              PLACE PRESENCE AND DEVICE PLIST BITS
TAB3     EQU      %                 SET DEVICE OPTIONS BIT
         BAL,SR4  ADJUST4                                            RL2
         STS,5    DPW,R4                                             RL2
         LI,R5    X'1000'
         STS,5    1,4                                                RL2
         PULL     R4                                                 RL2
         B        DOER              TABS COMPLETED
*
* LINES OPTION
*
LINES    LI,D2    DLINES            SET DISPLACEMENT
         LW,D3    Y04               AND PRESENCE BIT.
LINES1   CI,R6    '='               CHECK FOR EQUALS TERMINATOR
         BNE      SYNTAX
         LW,D1    VERB2
         LI,R3    D1
         BAL,SR3  SCAN              GET THE VALUE
         CI,R7    3                 MAX # OF CHARACTERS IS 3 (255)
         BG       SYNTAX
         BAL,SR4  DECBIN            CONVERT THE RESULT
         CW,D3    Y06               SPACE & LINES KEYS
         BAZ      %+3
         CI,R7    255               MAX SPACE & LINES VALUE
         BG       SYNTAX
         CW,D3    Y2                DATA KEY
         BAZ      %+3
         CI,R7    144               MAX DATA VALUE
         BG       SYNTAX
         LW,D1    R7                A ZERO VALUE EQUALS ONE LINE
         BNEZ     %+2
         LI,D1    1
         LW,R7    D2                PLACE IN PLIST
         LI,R5    0
         BAL,SR4  PENT
         LW,R5    D3                SET PRESENCE AND FLAG FOR DEVICE
         B        TAB3
*
* L OPTION
* ALSO PROCESS FOR OTHER BIT OPTIONS WITH IMAGE IN D1, MASKED BY D2.
*
LOPT     EQU      %
         LI,R7    DDRC
         LI,R5    -1
         BAL,SR4  PENT
         LW,R5    Y01
         B        TAB3              DO PRESENCE BITS
*
* SPACE OPTION
*
SPACE    LI,D2    DSPACE            SET DISPLACEMENT
         LW,D3    Y02               AND PRESENCE BIT.
         B        LINES1
*
* COUNT OPTION
*
COUNT    LI,D2    DCOUNT            SET DISPLACEMENT
         LW,D3    Y1                AND PRESENCE BIT.
         B        LINES1            COMPLETE THE PROCESS
*
* DATA OPTION
*
DATA     LI,D2    DDATA
         LW,D3    Y2
         B        LINES1
*
* SEQ OPTION
*
SEQ      LW,D2    L(X'80008')       SET SEQ BIT
         LI,D1    -1
         LI,R7    DDRC
         LI,R5    -1
         BAL,SR4  PENT
         LW,R5    Y01               SET PRESENCE PARAM
         BAL,SR4   ADJUST4          SAVE 4                           RL2
         STS,5    DPW,4                                              RL2
         PULL     R4                                                 RL2
         CI,R6    '='               DID HE SPECIFY AN ID
         BNE      DOER              NO
         LW,D1    VERB2             YES - PICK IT UP
         LI,R3    D1
         BAL,SR3  SCAN
         CI,R7    4                 ALLOW ONLY 4 CHARACTERS
         BG       SYNTAX
         LI,R5    0                 PLACE IO AS IS IN PLIST
         LI,R7    DSEQID
         BAL,SR4  PENT
         LW,R5    Y4
         B        TAB3
*
* NODRC OPTION
*
NODRC    LW,D2    L(X'400040')      SET BITS TO STORE A PRESENCE AND A
         LI,D1    X'F0000'          ZERO BIT IN DDRC
         B        LOPT
*
* NOVFC OPTION
*
NOVFC    LI,D2    X'20002'
         B        NODRC+1
*
* BCD OPTION
*
BCD      LW,D2    L(X'200020')
         B        NODRC+1
*
* NOFBCD OPTION
*
NOFBCD   LI,D2    X'4004'
         B        NODRC+1
*
* UNPACK OPTION
*
UNPACK   LW,D2    L(X'100010')
         B        NODRC+1
*
* NO L OPTION
*
NOL      LI,D2    X'10001'
         B        NODRC+1
         PAGE
*
* THE FOLLOWING HANDLES THE OPTIONS PERTAINING TO FILE SPECIFICATIONS.
*
FOPT     LI,R5    SIZFKY            SEARCH FILE OPTION LIST
         CW,D1    FKEY,R5
         BE       FOPT2
         BDR,R5   %-2
         LI,R5    SIZKEYS
         CW,D1    KEYS,R5
         BE       FOPT1
         BDR,R5   %-2
         B        SYNTAX
*
FOPT2    LB,R3    FTABLE,R5         GET ENTRY FROM OPT TABLE
         BAL,SR4  ADJUST4
         LI,D4    7                 MASK FOR F10,F11,F12
         AND,D4   1,R4              GET FLAG
         PULL     R4
         CI,D4    5                 IS IT ANS TAPE?
         BNE      %+2               NO
         LI,D4    4                 KNOCK OFF F12
         LS,R3    D4                COMPARE AGAINST OPTION
         BNEZ     FOPK,R5           DO THE OPTION
         PAGE
************************************************************************
*E*      ERROR:                                                        *
*E*               GROUP 03, CODE=01, SUBCODE=07-0C                     *
*E*      DESCRIPTION:                                                  *
*E*               THIS GROUP OF ERRORS OCCUR WHEN THE OPTION           *
*E*               SPECIFIED FOR A SET COMMAND IS ILLEGAL FOR THE       *
*E*               FILE TYPE SPECIFIED.  FILE TYPE IS DETERMINED        *
*E*               FROM F10-F12 IN THE SKELETON PLIST.                  *
*E*               SUBCODES ARE: 7 = UNKNOWN FILE TYPE                  *
*E*                             8 = FILE                               *
*E*                             9 = XEROX LABELED TAPE                 *
*E*                             A = DEVICE                             *
*E*                             B = TP JOURNAL TAPE                    *
*E*                             C = ANS LABELED TAPE                   *
************************************************************************
         BAL,SR4  ADJUST4
         LI,R3    7                 MASK FOR F10,F11,F12
         AND,R3   1,R4              GET FILE TYPE
         PULL     R4
         AI,R3    X'030107'         BASE TO GENERATE SUBCODE
*
BADOPT   EQU      %
         STD,D1   R6                SAVE OPTION TEXT IN R6 & R7
         LW,D1    R3                GET KEY (CODE + SUBCODE)
         BAL,SR4  T%ERRTXT          READ MSG
         BCS,1    %+3               DON'T STORE OPTION IF NO MSG
         LCI      2                 STORE OPTION TEXT..
         STM,R6   0,R1              ..IN MSG
         LI,R0    SYN1              SIMULATE BAL
         B        T%WRTERR          WRITE MSG & CLEAN STACK
*
         PAGE
************************************************************************
*E*      ERROR:                                                        *
*E*               GROUP 03, CODE=01, SUBCODE=0D                        *
*E*      DESCRIPTION:                                                  *
*E*               A DEVICE OPTION WAS SPECIFIED FOR A FILE DCB.        *
************************************************************************
FOPT1    LI,R3    X'03010D'         ERROR CODE & SUBCODE
         B        BADOPT            INSERT OPTION IN MSG & WRITE
*
         PAGE
*
* CONSECUTIVE OPTION
*
CONSEC   LI,D1    1
         LI,R7    P6
         LW,R5    Y04
         B        DOPENT                                             RL2
RSTORE   RES      0                                                  RL2
         BAL,SR3  GTFIELD1          CHK FOR '=' & SCAN
         BAL,SR4  DECBIN                                             RL2
         LW,D1    R7                BINARY TO D1
         BEZ      SYNTAX
         CW,D1    M24               MAX VALUE FOR RSTORE
         BG       SYNTAX            YES
         LI,R7    P20                                                RL2
         LI,5     X'1000'           P20 POSITION                     RL2
         B        DOPENT                                             RL2
*
RANDOM   RES      0                                                  RL2
         LI,D1    3                 RANDOM
         B        CONSEC+1                                           RL2
* KEYED OPTION
*
KEYED    LI,D1    2
         B        CONSEC+1
*
* SEQUEN OPTION
*
SEQUEN   LI,D1    1
         LI,R7    P7
         LW,R5    Y02
DOPENT   RES      0                                                  RL2
         LI,SR4   DOER              SIMULATE BAL...
         B        PENT              ... & RETN TO DOER
*
* DIRECT OPTION
*
DIRECT   LI,D1    2
         B        SEQUEN+1
*
* IN OPTION
*
IN       LI,D1    1
         CI,R6    ','
         BNE      IN1
         PUSH     D1
         LD,D1    VERB2
         LI,R3    D1
         BAL,SR3  SCAN
         CI,R7    0
         BE       SYNTAX
         CD,D1    SHARE
         BNE      %+3
         LI,D3    X'300'
         B        %+4
         CD,D1    EXCL
         BNE      SYNTAX
         LI,D3    X'200'
         PULL     D1
         LI,D2    X'300'
         LS,D1    D3
IN1      LI,R7    P8
         LW,R5    Y01
         B        DOPENT                                             RL2
         PAGE
*
* OUT OPTION
*
OUT      LI,D1    2
         B        IN+1
*
* INOUT OPTION
*
INOUT    LI,D1    4
         B        IN+1
*
* OUTIN OPTION
*
OUTIN    LI,D1    8
         B        IN+1
*
* RELEASE OPTION
*
REL      LI,D1    1
         LI,R7    P10
         LW,R5    Y004
         B        DOPENT                                             RL2
*
* JOB FILE OPTION
*
JOBOPT   LI,D1    3
         B        REL+1
*
* SAVE OPTION
*
SAVEOPT  LI,D1    2
         B        REL+1
*
* CYLINDER OPTION
*
CYLINDER LW,D2    Y002              SET CYL BIT(10) WORD 0
         LI,D1    -1
         LI,R7    0
         LI,R5    -1
         BAL,SR4  PENT
         B        DOER
*
* NOSEP OPTION
*
NOSEP    LW,D2    Y004              SET NOSEP BIT(9) WORD 0
         B        CYLINDER+1
*
* EXPIRE OPTION
*
EXPIRE   BAL,SR3  GTFIELD1
         CI,R7    0
         BE       SYNTAX            NO, ERROR
         CD,D1    NEVER             IS IT NEVER
         BE       EXPIRE50
         CI,R6    ','               WAS ',' SCANNED AS TERMINATOR
         BE       EXPIRE10          YES, MM,DD,YY ASSUMED
*
         CI,R7    3                 MORE THAN 3 DIGITS SCANNED
         BG       SYNTAX            ERROR
         BE       EXPIRE5
         CI,R7    2
         BE       EXPIRE3
         OR,D1    L(X'F0F0')
         SCS,D1   -8                SHIFT TO BYTE 3
EXPIRE3  OR,D1    XF0
         SCS,D1   -8                SHIFT TO BYTES 2,3
EXPIRE5  SCS,D1   -8                SHIFT TO BYTES 1,2,3
         LW,D2    L(X'F0F04040')
         B        EXPIRE50
*
EXPIRE10 RES      0                 PROCESS MM,DD,YY
         BAL,SR4  EXPIRE55          PERFORM VALIDITY CHECK ON MM
         CW,D1    EDAY              MM>12
         BG       SYNTAX            ERROR
         STH,D1   D4                SAVE MM
         LW,D1    VERB2
         BAL,SR3  SCAN              SCAN FOR YY
         CI,R6    ','               WAS ',' BETWEEN MM,DD
         BNE      SYNTAX            NO, ERROR
         BAL,SR4  EXPIRE55          PERFORM VALIDITY CHECK ON DD
         CW,D1    EMONTH            DD>31
         BG       SYNTAX            YES, ERROR
         LI,R7    1
         STH,D1   D4,R7             SCAN FOR MM,DD
         LW,D1    VERB2             SCAN FOR YY
         BAL,SR3  SCAN
         BAL,SR4  EXPIRE55          PERFORM VALIDITY CHECK ON YY
         LW,D2    ZEROS
         LI,R7    1
         STH,D1   D2,R7
         STW,D4   D1
*
EXPIRE50 RES      0
         BAL,SR4  ADJUST4
         LW,SR4   L(X'04000202')    EXPIR,DATE VLP CONTROL WORD
         LCI      3
         STM,SR4  PFEXP,R4
         PULL     R4
         B        DOER
*
EXPIRE55 RES      0                 PERFORM VALIDITY CHECK ON MM,DD,YY
         CI,R7    2                 DIGITS SCANNED>2
         BG       SYNTAX            YES, ERROR
         BE       EXPIRE58
         SCS,D1   -24               1 DIGIT SCANNES
         CW,D1    BCZRO1            IS IT=0
         BE       SYNTAX            YES, ERROR
         OR,D1    L(X'4040F000')    NO PUT ZERO IN BYTE 2
         B        *SR4
EXPIRE58 RES      0
         SCS,D1   -16               2 DIGITS SCANNED
         CW,D1    BCZRO2            IS IT 00
         BE       SYNTAX            YES, ERROR
         B        *SR4
         PAGE
TRIES    BAL,SR3  GTFIELD1
         CI,R7    3
         BG       SYNTAX
         BAL,SR4  DECBIN
         CI,R7    255
         BG       SYNTAX
         LW,D1    R7
         BEZ      DOER
         LI,R7    P5
         LW,R5    Y08
         B        DOPENT
*
RECL     BAL,SR3  GTFIELD1
         CI,R7    5
         BG       SYNTAX
         BAL,SR4  DECBIN
         CI,R7    X'7FFF'
         BG       SYNTAX
         LW,D1    R7
         BEZ      DOER              SKIP, TAKE DEFAULT
         LI,R7    P4
         LW,R5    Y1
         B        DOPENT
*
         TITLE    'C00 CPV SET OPTIONS'
*
*        KEYM
*
KEYM     EQU      %
         BAL,SR3  GTFIELD1
         CI,R7    2
         BG       SYNTAX
         BAL,SR4  DECBIN
         CI,R7    31
         BG       SYNTAX
         LW,D1    R7
         LI,R7    P13
         LW,R5    Y0008
         B        DOPENT
*
*        ABCERR
*
ABCERR   EQU      %
         LW,R3    1,R4
         LB,R3    R3
         AI,R3    4+4               ROUND OFF& COUNT FLINK WD
         SLS,R3   -2                CONVERT TO WDS
         AW,R3    R4
         LW,R5    Y001              ABCERR FLG
         STS,R5   *R3
         B        DOER
*
*        FORMAT
*
FORM     EQU      %
         BAL,SR3  GTFIELD1
         CI,R7    1
         BNE      SYNTAX
         LB,D1    D1
         LI,R3    SZFRM
         CB,D1    FRM,R3
         BE       %+3
         BDR,R3   %-2
         B        SYNTAX
         LW,D1    R3
         LI,R7    P6
         LW,R5    Y04
         B        DOPENT
*
*
         BOUND    4
FRM      DATA,1   0,'F','D','V','U'
SZFRM    EQU      BA(%)-BA(FRM)-1
         BOUND    4
*
*        LRECL
*
LRECL    EQU      %
         BAL,SR3  GTFIELD1
         CI,R7    5
         BG       SYNTAX
         BAL,SR4  DECBIN
         CI,R7    X'7FFF'
         BG       SYNTAX
         CI,R7    0
         BE       DOER              TAKE THE DEFAULT, SKIP
         LW,D1    R7
         LI,R7    P20
         LI,R5    X'1000'
         B        DOPENT
*
*        DENSITY
*
DENSITY  EQU      %
         BAL,SR3  GTFIELD1
         CW,D1    L(X'F1F6F0F0')
         BNE      DENST1            NOT 1600 BPI
* A ZERO WORD CANNOT BE STORED IN A/M ADCB FPT SO 0=2000 HERE.
         LI,D1    X'2000'           SET 1600 BPI
DENST2   LI,R7    P21
         LI,R5    X'800'
         B        DOPENT
*
DENST1   CW,D1    L(X'F8F0F040')
         BNE      SYNTAX
         LI,D1    1                 SET FOR 800 BPI
         B        DENST2
*
*        VOL
*
VOL      EQU      %
         BAL,SR3  GTFIELD1
         CI,R7    0
         BE       SYNTAX
         BAL,SR4  DECBIN
         CI,R7    50
         BG       SYNTAX
         LW,D1    R7
         LI,R7    P16
         LI,R5    X'00010000'
         B        DOPENT
*
*        ASCII
*
ASCII    EQU      %
         LI,D1    1                 CCF=1
EBCDIC1  LI,R7    P22
         LI,R5    X'400'
         B        DOPENT
*
*        EBCDIC
*
EBCDIC   LI,D1    X'2000'           0=2000 HERE AND FOR DENSITY
         B        EBCDIC1
*
*        BLKL
*
BLKL     EQU      %
         BAL,SR3  GTFIELD1
         CI,R7    5
         BG       SYNTAX
         BAL,SR4  DECBIN
         CI,R7    X'7FFF'
         BG       SYNTAX
         LW,D1    R7
         BEZ      SYNTAX
         LI,R7    P4
         LW,R5    Y1
         B        DOPENT
*
*        CONCAT
*
CONCATOP EQU      %
         BAL,SR3  GTFIELD1
         CI,R7    3
         BG       SYNTAX
         BAL,SR4  DECBIN
         CI,R7    255
         BG       SYNTAX
         CI,R7    2
         BL       SYNTAX
         LW,D1    R7
         LI,R7    P18
         LI,R5    X'4000'
         B        DOPENT
*
*        SPARE
*
SPARE    EQU      %
         BAL,SR3  GTFIELD1
         CI,R7    3
         BG       SYNTAX
         BAL,SR4  DECBIN
         CI,R7    255
         BG       SYNTAX
         LW,D1    R7
         BEZ      DOER              SKIP, TAKE DEFAULT
         LI,R7    P18
         LI,R5    X'4000'
         B        DOPENT
*
*        NEWX
*
NEWX     EQU      %
         BAL,SR3  GTFIELD1
         CI,R7    0
         BE       NEWX1
         CI,R7    3
         BG       SYNTAX
         BAL,SR4  DECBIN
         SLS,R7   8                 SHFT SLIDES OVER
         CI,R6    ','               GOT ANOTHER FIELD
         BE       NEWX2             BOTH FIELDS PRES
         LW,D1    R7
         LI,R7    P17
         LI,R5    X'8000'
         B        DOPENT
*
NEWX1    CI,R6    ','
         BNE      SYNTAX
NEWX2    STW,R7   D2
         LW,D1    VERB2
         LI,R3    D1
         BAL,SR3  SCAN
         CI,R7    3
         BG       SYNTAX
         BAL,SR4  DECBIN
         CI,R7    255
         BG       SYNTAX
         LW,D1    D2
         LI,R3    3
         STB,R7   D1,R3
         LI,R7    P17
         LI,R5    X'8000'
         B        DOPENT
*
*
         PAGE
*
*  SIXPACK HASHES A SIX CHAR SERIAL# INTO 1 WORD
*  R1=BYTE ADDRESS OF SERIAL #...SET IN THIS VERSION.
*  R2=RESULT
*  CALL BAL,SR4 SIXPACK
*
*
SIXPACK  EQU      %
         PUSH     5,R1              SAVE REGS
         LI,R1    D1+D1+D1+D1       BA OF SOURCE FOR SN
         LI,R5    0
         LI,R4    6
SIXPACK1 EQU      %
         LB,R3    0,R1
         AI,R1    1
         SLS,R3   26
         SLD,R2   2
         SLS,R3   -28
         MI,R5    10
         AW,R5    R3
         BDR,R4   SIXPACK1
         SLS,R2   20
         OR,R2    R5
         STW,R2   D1
         PULL     5,R1              EVEN UP
         B        *SR4
         PAGE
*
* SN OPTION PROCESSING.
*   LIMIT OF 3 SERIAL #S.  ANS TAPE MUST BE SIX CHARS
*   AND MUST BE HASHED.  OTHERS MAY BE FOUR CHARS OR
*   LESS AND ARE STORED AS IS.
*
*
SNOPT    EQU      %
         CI,R6    ';'               NO ARGS PRES??
         BE       NOSN              NONE, DO DELETE
         CI,R1    1                 CMMND LINE FINISHED?
         BLE      NOSN              YES, IMPLIES DELETE
         CI,R6    '='
         BNE      SYNTAX
         BAL,SR4  ADJUST4           PUSHES R4
         LW,R5    PFOUT,R4          GET CW IF ANY
         BNEZ     %+3               GOT ONE
         LW,R5    Y07               SKELETON CW
         STW,R5   PFOUT,R4
         PUSH     R5                * CW 1ST INTO STACK
         SLS,R5   16
         LB,R5    R5                GET PRESENT COUNT
         PUSH     R5                * COUNT 2ND INTO STACK
         CI,R5    3                 MAX # ALLOWED
         BGE      NOSNSPC           NO SPACE LEFT
         LI,D4    X'4000'
         STS,D4   1,R4              SET VLP PRES JUST IN CASE
         LI,D4    X'F'
         LS,D4    1,R4              GET ASN, LOOKING FOR ANS TPE
         CI,D4    5                 CHK FOR ANS TPE
         BE       %+2
         LI,D4    0                 IGNORE OTHERS
         PUSH     D4                * POSS ANS TPE 3RD INTO STACK
         LW,R5    TELSTACK
         AI,R5    -2
         LW,D4    1,R5              GET COUNT
         AI,D4    PFOUT
         AW,D4    R4                ABS POINTER TO LAST USED SLOT
SNOPT1   LD,D1    VERB2
         LI,R3    D1
         PUSH     R5
         BAL,SR3  SCAN
         PULL     R5
         CI,R7    0
         BE       SYNTAX            NO CHARS, ERROR
         CI,R7    6
         BG       SYNTAX
         MTW,0    2,R5              SEE IF ANS TAPE
         BEZ      SNOPT2
         CI,R7    6                 MUST BE EXACTLY SIX CHARS
         BNE      SYNTAX
         BAL,SR4  SIXPACK           HSH THE ANS SN.
SNOPT3   AI,D4    1                 BUMP FOR STORE
         MTW,1    1,R5              BUMP COUNT
         STW,D1   *D4               PUT SN AWAY
         CI,R6    ','               ANY MORE?
         BNE      SNOPTX            NO
         LW,SR3   1,R5              GET COUNT
         CI,SR3   3
         BGE      NOSNSPC           NO MORE ROOM IN PLIST
         B        SNOPT1            GET ANOTHER SN
*
SNOPT2   CI,R7    4                 STD CASE
         BG       SYNTAX
         B        SNOPT3
*
SNOPTX   PULL     3,D1              D1=CW, D2=COUNT, D3=ANS?
         LI,R5    2
         STB,D2   D1,R5             PUT COUNT IN CW
         AI,R5    1
         STB,D2   D1,R5             PUT LENGTH OF ENTRY
         STW,D1   PFOUT,R4          PUT CW AWAY
         PULL     R4
         B        DOER
************************************************************************
*E*      ERROR:                                                        *
*E*               GROUP 03, CODE=01, SUBCODE=11                        *
*E*      DESCRIPTION:                                                  *
*E*               THE USER SPECIFIED MORE THAN THE MAXIMUM NUMBER      *
*E*               OF SN'S.                                             *
************************************************************************
NOSNSPC  LI,D1    X'030111'         ERROR CODE & SUBCODE
         B        CMNERR1           GO TELL USER
*
*
NOSN     EQU      %
         BAL,SR4  ADJUST4           PUSHES R4
         LI,D4    X'F'
         LS,D4    1,R4              SEE IF PLIST DEVICE TYPE?
         BNEZ     %+4               NO-BRANCH
         LI,D4    -X'4001'          YES, RESET VLP BIT
         AND,D4   1,R4               AS 'SN' IS ONLY ONE POSSIBLE
         STW,D4   1,R4
         LI,R5    PFOUT+3
         LI,D4    0
         LI,R7    4
         STW,D4   *R4,R5            ZER0 THE SN'S &CW
         AI,R5    -1
         BDR,R7   %-2
         PULL     R4
         B        DOER
*
*
*
* GTFIELD1:  FOR SET OPTS THAT USE '=' (EQUAL SIGN)
*
GTFIELD1 EQU      %
         CI,R6    '='
         BNE      SYNTAX
         B        GETFIELD          (EXITS ON SR3)
*
*
         PAGE
*
*  READ ACCT OPTION PROCESSING
*
READOPT  EQU      %
         LI,R7    NOREAD            ENTRY TO DELE READ ACCTS
         BAL,SR3  NONONE            SEE IF DELE OR ENTER.
         BAL,SR3  GTFIELD1          GET 1ST ENTRY
         CI,R7    0
         BE SYNTAX
         CI,R7    8                 MAX #
         BG       SYNTAX
         BAL,SR4  ADJUST4           PUSHES R4
         AI,R4    PFRD              R4 ABS ADDR OF RD C.W.
         LW,D4    *R4
         BNEZ     %+3
         LW,D4    Y05
         STW,D4   *R4
         BAL,SR3  ACCTS
         LW,D1    Y05               RD CONTROL WD
         B        ACCEXIT           PUT IT AWAY
*
*  WRITE ACCT OPTION
*
WRITEOPT EQU      %
         LI,R7    NOWR              ENTRY TO DELE WRITE ACCTS
         BAL,SR3  NONONE
         BAL,SR3  GTFIELD1
         CI,R7    0
         BE       SYNTAX
         CI,R7    8                 MAX #
         BG       SYNTAX
         BAL,SR4  ADJUST4
         AI,R4    PFWRT
         LW,D4    *R4
         BNEZ     %+3
         LW,D4    Y06
         STW,D4   *R4
         BAL,SR3  ACCTS
         LW,D1    Y06               WRT DUMMY CW
         B        ACCEXIT
         PAGE
*
*  EXECUTE ACCT OPTION
*
EXECUTE  EQU      %
         LI,R7    NOEX              ENTRY TO DELE EXECU ACCTS
         BAL,SR3  NONONE            SEE IF DELE OR NOT.
         BAL,SR3  GTFIELD1
         CI,R7    0
         BE       SYNTAX
         CI,R7    8
         BG       SYNTAX
         BAL,SR4  ADJUST4
         AI,R4    PFEXU
         LW,D4    *R4
         BNEZ     %+3
         LW,D4    PLIST
         STW,D4   *R4
         BAL,SR3  ACCTS
         LW,D1    PLIST             EXU DUMMY CW
         B        ACCEXIT
*
*  UNDER 'PROCESSOR' OPTION
*
UNDEROP  EQU      %
         CI,R6    ';'               DELETE PROCESSOR NAME?
         BE       NOUNDE            YES
         CI,R1    1                 DELE? LINE FINISHED?
         BLE      NOUNDE            YES
         BAL,SR3  GTFIELD1
         CI,R7    0
         BE       SYNTAX
         CI,R7    11                MAX CHAR ALLOWED
         BG       SYNTAX
         PUSH     3,R4
         BAL,SR3  NFND              CVRT TO TEXTC
         LCI      3
         STM,R6   D1
         PULL     3,R4
         BAL,SR4  ADJUST4           PUSHES R4
         LW,SR4   =X'15000303'
         LCI      4
         STM,SR4  PFUND,R4
         PULL     R4
         B        DOER
*
*
* DELET EXISTING PROCESSOR NAME FROM ADCB PLIST THIS DCB
*
NOUNDE   BAL,SR4  ADJUST4           PUSHES R4
         LI,R5    PFUND+3
         LI,D4    0
         LI,R7    4
         STW,D4   *R4,R5
         AI,R5    -1
         BDR,R7   %-2
         PULL     R4
         B        DOER
*
         PAGE
*
*
* LINK=SR3
* R4=ABS ADDR OF OPTION
* RETURN D4 # OF WDS USED.
* D4 CONTAINS CW ON ENTRY
*
ACCTS    EQU      %
         PUSH     SR3
         SLS,D4   16
         LB,D4    D4                # WDS IN USE
         CI,D4    14                ANY SPACE LEFT????
         BG       ACCTERR           NOPE
*
         LW,R5    R4
         AW,R5    D4                ADD # ALREADY USED
         AI,R5    1                 PLUS CW
ACCTS3   LCI      2
         STM,D1   *R5               PUT EM AWAY
         AI,D4    2                 COUNT EM
         CI,R6    ','               ANY MORE?
         BNE      ACCTS4
         BAL,SR4  GTACCT            GET ANOTHER ACCT
         B        ACCTS3
ACCTS4   PULL     SR3
         B        *SR3
         PAGE
************************************************************************
*E*      ERROR:                                                        *
*E*               GROUP 03, CODE=01,SUBCODE= 0E,0F,10                  *
*E*      DESCRIPTION:                                                  *
*E*               THE NUMBER OF READ, WRITE OR EXECUTE ACCOUNTS IS     *
*E*               GREATER THAN 8.                                      *
*E*               SUBCODE 0E = READ                                    *
*E*                       0F = WRITE                                   *
*E*                       10 = EXECUTE                                 *
************************************************************************
ACCTERR  EQU      %
         LI,D1    X'03010E'         BASE FOR THE 3 ERRORS
         LB,R4    *R4               GET VLP CONTR WORD TYPE
         CI,R4    5                 ADD NOTHING IF READ
         BE       CMNERR1           IT'S READ (03010E)
         AI,D1    1                 INCR SUBCODE
         CI,R4    6                    & CHECK FOR WRITE
         BE       CMNERR1           IT'S WRITE (03010F)
         AI,D1    1                 NOT RD OR WR MUST BE EXECUTE...
         B        CMNERR1           ...(030110)
         PAGE
*
* GET ACCOUNT # FOR RD,WRT, AND EXU SET OPTIONS
* SR4=LINK
* D4= # OF ENTRIES (2WDS EACH. MAX OF 8)
* R5= DISPLACE INTO IN PROGRESS PLIST.
*
GTACCT   EQU      %
         LI,R3    D1
         LD,D1    VERB2
         PUSH     R5                SAVE
         BAL,SR3  SCAN
         PULL     R5                RECOVER COUNT
         CI,R7    0
         BE       SYNTAX
         CI,R7    8                 MAX #
         BG       SYNTAX
         CI,D4    15
         BGE      ACCTERR
         AI,R5    2
         B        *SR4
*
* ACCEXIT: EXIT ROUTINE FOR RD,WRT, AND EXU OPTIONS
*
ACCEXIT  LI,R5    2
         STB,D4   D1,R5             UPDATE # WDS IN USE
         AI,R5    1
         STB,D4   D1,R5
         STW,D1   *R4               PUT CW AWAY
         PULL     R4
         B        DOER
*
         PAGE
*
* THE FOLLOWING ROUTINES NOREAD,NOWR AND NOEX WIPE OUT
* THOSE ACCOUNTS WHICH HAVE BEEN SET DUE TO THE READ,WRIT AND
* EXECUTE OPTIONS.
*
NOREAD   LI,R7    PFRD
         B        WIPEOUT
*
NOWR     LI,R7    PFWRT
         B        WIPEOUT
*
NOEX     LI,R7    PFEXU
WIPEOUT  LI,D1    0
         BAL,SR4  ADJUST4
         LI,R5    0
         AW,R4    R7                POINT TO ENTRY
WIPEOUT1 STW,D1   *R4,R5
         AI,R5    1
         CI,R5    17
         BL       WIPEOUT1
         PULL     R4
         B        DOER
*
*
NONONE   EQU      %
         CI,R6    ';'               OPTION TERMINATED?
         BE       *R7               YES, DO DELETE
         CI,R1    1                 CMMND LINE EXHAUSTED?
         BLE      *R7               YES, DO DELETE
         B        *SR3              NO DEL, GO PROCESS OPTIONS.
         TITLE    'SET COMMAND UPDATE FUNCTION'
*
* PROCESS FOR UPDATING A PREVIOUSLY MADE SPECIFICATION. FIND THE OLD
* A/M ENTRY FIRST.
*
SETUPDAT LW,R4    J:ABUF
         BAL,SR4  ASSIGN+1          R6 AND R7 CONTAIN DCB NAME
************************************************************************
*E*      ERROR:                                                        *
*E*               GROUP 03, CODE=01, SUBCODE=03                        *
*E*      DESCRIPTION:                                                  *
*E*               USER ISSUED AN UPDATE SET & PREVIOUS                 *
*E*               ASSIGNMENT DOESN'T EXIST.                            *
************************************************************************
         LW,R4    R5                GET PLIST ADDR IN SETBUF
         BNEZ     %+3               FOUND ENTRY, GO EXPAND IT
         LI,D1    X'030103'         ERROR CODE & SUBCODE
         B        CMNERR1           TELL USER
*
         BAL,SR4  EXPAND            OPEN UP THE CURRENT A/M ENTRY
         B        SETKEYS           AND GO PROCESS IN THE NORMAL MANNER
*
*
* LINK   SR4
* R4     ADDR OF A/M BUFFER
* R5     ABS ENTRY ADDR OF DESTINATION IN A/M TABLE.
*
*        MOVESET
* CALLED FROM 'DOER' IN SET LOGIC. USED FOR NEW & UPDATE SETS.
* 'SZCELL' CONTAINS SZE OF ENTRY TO MOVE INTO A/M TABLE.*
*
*
MOVESET  EQU      %
         LI,R2    0                 ZRO FWD LINK &
         STW,R2   SETBUF            AS ITS LAST IN CHAIN.
         LW,R2    R4
         AI,R2    X'1FF'
         SW,R2    R5                SPACE LEFT IN A/M TABLE
         LW,R3    SZCELL            SZE OF ENTRY
         CW,R3    R2
         BG       AMFULL            WON'T FIT
         AW,R3    R5
         SW,R3    R4                FIND NEW AVAIL
         STW,R3   0,R4              SET NEW AVAIL HEAD
         LW,R3    SZCELL
         LI,R4    SETBUF
         AI,R4    -1
         AI,R5    -1
         AI,R3    1
         LW,R6    *R4,R3
         STW,R6   *R5,R3
         BDR,R3   %-2               MOVE IT A/M BUF
         B        *SR4
*
         TITLE    'ERROR AMPLIFIERS'
************************************************************************
*E*      ERROR:                                                        *
*E*               GROUP 3, CODE=01, SUBCODE=02                         *
*E*      DESCRIPTION:                                                  *
*E*               ONE OF THE FOLLOWING ERRORS WAS DETECTED WHILE       *
*E*               DECODING THE DEVICE PORTION OF A SET COMMAND.        *
*E*                  1.  RESOURCE NAME (-YY) DOESN'T EXIST             *
*E*                  2.  SERIAL NUMBER SPECIFIED FOR A NON TAPE OR     *
*E*                      DISC DEVICE.                                  *
*E*               WE TYPE THE ERROR MESSAGE AND PROMPT.                *
************************************************************************
RTYERR   LI,D1    X'030102'         ERROR CODE AND SUB-CODE
         B        CMNERR1           TELL USER & PROMPT
         SPACE    3
************************************************************************
*E*      ERROR:                                                        *
*E*               GROUP 03, CODE=01, SUBCODE=05                        *
*E*      DESCRIPTION:                                                  *
*E*               WHILE TRYING TO CREATE A NEW ENTRY OR EXPAND         *
*E*               AN OLD ONE, WE RAN OUT OF ROOM IN THE A/M            *
*E*               RECORD.  AFTER THE ERROR MSG IS PRINTED, THE         *
*E*               IN-CORE A/M PAGE IS RELEASED, FORCING A FRESH        *
*E*               COPY OF THE RECORD TO BE READ.                       *
************************************************************************
AMFULL   LI,D1    X'030105'         ERROR CODE & SUBCODE
         B        CMNERR1           TELL USER
         PAGE
************************************************************************
*E*      ERROR:                                                        *
*E*               GROUP 03, CODE=01, SUBCODE=06                        *
*E*      DESCRIPTION:                                                  *
*E*               AN INCONSISTENCY WAS FOUND IN AN EXISTING A/M        *
*E*               ENTRY WHILE EXPANDING IT FOR UPDATE. THIS IS         *
*E*               EITHER A LOGIC PROBLEM IN TEL OR THE A/M RECORD      *
*E*               HAS BEEN STEPPED ON.  THE USER SHOULD ISSUE A NEW    *
*E*               SET FOR THIS DCB.                                    *
************************************************************************
EXPNDERR LI,D1    X'030106'         ERROR CODE & SUBCODE
         B        CMNERR1           TELL USER
         TITLE    'TABLES, CONSTANTS, AND SUCH'
BIT0     EQU      Y8
NBIT0    EQU      M31
ZEROS   DATA      X'F0F0F0F0'
INSN     DATA     X'07000101'       SN VLP CONTROL WORD
*
*  BEGIN DOUBLEWORD TABLE
*
         BOUND    8
NEVER    TEXT     'NEVER   '
SHARE    TEXT     'SHARE   '
EXCL     TEXT     'EXCL    '
BCZRO2   TEXT     '  00'
BCZRO1   TEXT     '   0'
EMONTH   TEXT     '  31'
EDAY     TEXT     '  12'
*
* END OF DOUBLEWORD TABLE
*
*
* PLIST USED TO READ IN ASSIGN/MERGE TABLE.
*
AMR      GEN,8,24   X'2D',M:TEL
         GEN,4,28 X'3',X'10'
         GEN,1,31 1,R7
         GEN,32   4*512
*
* PLIST USED TO WRITE THE UPDATE ASSIGN/MERGE TABLE.
*
WAMR     GEN,8,24   X'2E',M:TEL
         GEN,4,28 3,0
         GEN,1,31 1,R7
         GEN,32   4*512
*
* BASIC PLIST SKELETON FOR FPT CREATED IN ASSIGN/MERGE TABLE. (FILE)
*
PLIST    GEN,8,24 X'14',0           THE 1ST FIVE WORDS ARE FIXED AND
         GEN,16,4,12  0,X'E',1      CANNOT BE ALTERED BY SEQUENCE
         GEN,12,20  X'14',0
MODE     GEN,32   2                 NORMAL OUTPUT MODE
SAVE     GEN,32   2                 NORMAL SAVE
NAME     GEN,8,8,8,8  1,0,3,3       NAME VARIABLE PARAM
         GEN,64   0
         GEN,32   0
PACC     GEN,8,8,8,8  2,0,2,2       ACCOUNT VARIABLE PARAM
         GEN,64   0
PPAS     GEN,8,8,8,8  3,1,0,2       PASSWORD PARAM DEFAULTS TO NULL
         GEN,64   0
PSIZE    EQU      %-PLIST
*
* THE FOLLOWING TABLE IS USED TO DETERMINE THE SHIFT REQUIRED (USING BIT
* 31) TO SET OR RESET THE FILE EXTENSION BITS IN JCPPO. IT IS A HALF-
* WORD TABLE AND IS USED BY LOOKING FOR A MATCH ON THE LAST TWO CHARS OF
* THE M: DCB NAME. THE RELATIVE POSITION DENOTES THE DISTANCE BIT 31
* MUST BE SHIFTED LEFT.
*
FILEXTP  DATA,2   C'GO',C'OC'
         DATA,2   C'LO',C'LL'
         DATA,2   C'DO',C'PO'
         DATA,2   C'BO',C'LI'
         DATA,2   C'SI',C'BI'
         DATA,2   C'SL',C'SO'
         DATA,2   C'CI',C'CO'
         DATA,2   C'AL',C'EI'
         DATA,2   C'EO',C'  '
SIZFILXP EQU      HA(%)-HA(FILEXTP)
*
         BOUND    4
XH:RN1   DATA,2   '  ','MT'
         DATA,2   'LT','FT'
         DATA,2   '9T','AT'
XV:RS1   EQU      HA(%)-HA(XH:RN1)-1
         BOUND    4
XH:RN2   DATA,2   '  ','7T'
         DATA,2   'DP'
XV:RS2   EQU      HA(%)-HA(XH:RN2)-1
         BOUND    4
*
* TABLE OF RECOGNIZED KEYWORDS FOR SET COMMAND DEVICE OPTIONS.
*
KEYS     TEXT     '    '
         TEXT     'L   '
         TEXT     'NOL '
         TEXT     'TAB '
         TEXT     'LINE'
         TEXT     'SPAC'
         TEXT     'DRC '
         TEXT     'NODR'
         TEXT     'VFC '
         TEXT     'NOVF'
         TEXT     'COUN'
         TEXT     'BCD '
         TEXT     'BIN '
         TEXT     'FBCD'
         TEXT     'NOFB'
         TEXT     'PACK'
         TEXT     'UNPA'
         TEXT     'DATA'
         TEXT     'SEQ '
         TEXT     'IN  '
         TEXT     'OUT '
         TEXT     'INOU'
         TEXT     'OUTI'
         TEXT     'RECL'
         TEXT     'TRIE'
         TEXT     'DEN '
         TEXT     'ASCI'
         TEXT     'ASC '
         TEXT     'EBCD'
         TEXT     'EBC '
         TEXT     'SN  '
SIZKEYS  EQU      %-KEYS-1
*
* VECTOR TABLE USED TO ENTER CORRECT KEYWORD PROCESS FOR SET COMMAND.
* PARALLEL TO TABLE 'KEYS'.
*
KEYVECT  B        JUNK
         LI,D2    X'10001'          L
         B        NOL
         B        TAB
         B        LINES
         B        SPACE
         LW,D2    L(X'400040')      DRC
         B        NODRC
         LI,D2    X'20002'          VFC
         B        NOVFC
         B        COUNT
         B        BCD
         LW,D2    L(X'200020')      BIN
         LI,D2    X'40004'          FBCD
         B        NOFBCD
         LW,D2    L(X'100010')      PACK
         B        UNPACK
         B        DATA
         B        SEQ
         B        IN
         B        OUT
         B        INOUT
         B        OUTIN
         B        RECL
         B        TRIES
         B        DENSITY
         B        ASCII
         B        ASCII
         B        EBCDIC
         B        EBCDIC
         B        SNOPT
         PAGE
* TABLE OF RECOGNIZED KEYWORDS FOR SET COMMAND FILES,
* LABELED TAPE, AND ANS TAPE. (SEE COMMENTS AT 'FTABLE'  )
*     F=FILE    L=LABEL TP     A=ANS TP
*
FKEY     TEXT     '    '
         TEXT     'CONS'            F/L
         TEXT     'KEYE'            F/L
         TEXT     'RAND'            F
         TEXT     'SEQU'            F/L
         TEXT     'DIRE'            F/L
         TEXT     'IN  '            F/L/A
         TEXT     'OUT '            F/L/A
         TEXT     'INOU'            F/L/A
         TEXT     'OUTI'            F/L/A
         TEXT     'REL '            F
         TEXT     'SAVE'            F
         TEXT     'JOB '            F
         TEXT     'CYLI'            F
         TEXT     'EXPI'            F/A  (EXPIRE)
         TEXT     'EXP '            F/A  (EXPIRE)
         TEXT     'KEYM'            F/L
         TEXT     'NEWX'            F
         TEXT     'NOSE'            F
         TEXT     'READ'            F/L
         TEXT     'RD  '            F/L
         TEXT     'RECL'            F/L
         TEXT     'RSTO'            F
         TEXT     'SPAR'            F
         TEXT     'TRIE'            F/L/A
         TEXT     'WRIT'            F/L
         TEXT     'WR  '            F/L
         TEXT     'VOL '            L/A
         TEXT     'ABCE'            A
         TEXT     'BLKL'            A
         TEXT     'BLK '            A
         TEXT     'CONC'            A
         TEXT     'CAT '            A
         TEXT     'FORM'            A
         TEXT     'FMT '            A
         TEXT     'LREC'            A
         TEXT     'REC '            A
         TEXT     'DEN '            L/A
         TEXT     'ASCI'            L/A
         TEXT     'ASC '            L/A
         TEXT     'EBCD'            L/A
         TEXT     'EBC '            L/A
         TEXT     'EX  '            F
         TEXT     'EXEC'            F
         TEXT     'UN  '            F
         TEXT     'UNDE'            F
         TEXT     'SN  '            F/L/A
SIZFKY   EQU      %-FKEY-1
         PAGE
* FTABLE IS PARALLEL TO TABLES FKEY AND FOPK.
* ANY CHANGE TO ANY ONE REQUIRES CORRESPONDING CHANGES
* TO THE OTHER TABLES.  THE TABLES ARE ORDER DEPENDANT
* AND REFLECT EACH OTHER.
* FTABLE HAS BYTE ENTRIES, EACH BYTE HAS BITS REPRESENTING
* WHICH ASN IT MAY BE A VALID OPTION FOR.
*  BIT 7=1 FILE OP.... BIT 6=1 LABEL TPE OP.... BIT5=1 ANS TPE OP.
* BIT 5,6,7=1 THE OPTION IS APPL TO ALL THREE TYPES, E.G.  'IN'  .
*
         BOUND    4
FTABLE   DATA,1   0,3,3,1           NUL,CONS,KEYED,RAND
         DATA,1   3,3,7,7           SEQUN,DIR,IN,OUT
         DATA,1   7,7,1,1           INOUT,OUTIN,REL,SAVE
         DATA,1   1                 JOB
         DATA,1   1,5,5,3,1         CYL,EXPI,EXP,KEYM,NEWX
         DATA,1   1,3,3,3,1         NOSEP,READ,RD,RECL,RSTORE
         DATA,1   1,7,3,3,6         SPAR,TRIES,WRITE,WR,VOL
         DATA,1   4,4,4,4,4,4,4     ABC,BLKL,BLK,CONCAT,CAT,FORM,FMT
         DATA,1   4,4,6,6,6,6,6     LRECL,REC,DEN,ASCI,ASC,EBCD,EBC
         DATA,1   1,1,1,1           EX,EXEC,UN,UNDE
         DATA,1   7,0,0,0           SNOPT,0,0,0
         PAGE
* VECTOR FOR TABLE FKEY
*
FOPK     B        FOPT1             SECURITY IS A CLOSED ERROR PATH
         B        CONSEC            F/L
         B        KEYED             F/L
         B        RANDOM            F
         B        SEQUEN            F/L
         B        DIRECT            F/L
         B        IN                F/L/A
         B        OUT               F/L/A
         B        INOUT             F/L/A
         B        OUTIN             F/L/A
         B        REL               F
         B        SAVEOPT           F
         B        JOBOPT            F
         B        CYLINDER          F
         B        EXPIRE            F/A
         B        EXPIRE            F/A
         B        KEYM              F/L
         B        NEWX              F
         B        NOSEP             F
         B        READOPT           F/L
         B        READOPT           F/L
         B        RECL              F/L
         B        RSTORE            F
         B        SPARE             F
         B        TRIES             F/L/A
         B        WRITEOPT          F/L
         B        WRITEOPT          F/L
         B        VOL               L/A
         B        ABCERR            A
         B        BLKL              A
         B        BLKL              A
         B        CONCATOP          A
         B        CONCATOP          A
         B        FORM              A
         B        FORM              A
         B        LRECL             A
         B        LRECL             A
         B        DENSITY           L/A
         B        ASCII             L/A
         B        ASCII             L/A
         B        EBCDIC            L/A
         B        EBCDIC            L/A
         B        EXECUTE           F
         B        EXECUTE           F
         B        UNDEROP           F
         B        UNDEROP           F
         B        SNOPT             F/L/A
*
         TITLE    'PARAMETER PLACES'
*
* TABLE OF DISPLACEMENT POSITIONS FOR EXPANSION OF BASIC PLIST. KEYED TO
* PRESENCE WORD OF PLIST.
*
PLACES   DATA,1   0,0,0,0
         DATA,1   P4,P5,P6,P7
         DATA,1   P8,0,P10,0
         DATA,1   0,P13,P14,0
         DATA,1   P16,P17,P18,0
         DATA,1   P20,P21,P22,0,0,0,0,0,0,0,0,0
         TITLE    'DEVICE PARAM PLACEMENTS'
         BOUND    4
*
* TABLE OF DISPLACEMENTS FOR EXPANSION OF DEVICE PLIST. KEYED TO DEVICE
* PRESENCE WORD OF PLIST.
*
THINGS   DATA,1     0,DTABS,DSEQID,DDATA
         DATA,1   DCOUNT,0,DLINES,DSPACE
         DATA,1   DDRC,0,0,0,0,0,0,0,0,0,0,0,0
         DATA,1   0,0,0,0,0,0,0,0,0,0,0,0
         BOUND    4
         TITLE    'PARAMETER DISPLACEMENTS'
*
*
*
* THE FOLLOWING ARE DISPLACEMENTS USED IN CREATING THE SKELETAL OPEN
* PRIME PLIST. A CHANGE HERE REQUIRES A SIMILAR CHANGE TO THE 'PLACES'
* OR 'THINGS' TABLES.
*
PP       EQU      3                 TO MOVE THIS WHOLE     *
P4       EQU      PP                TABLE UP OR DOWN ONLY  *
P5       EQU      P4+1              THE ENTRIES ON EITHER  *
P6       EQU      P5+1              SIDE OF THE INSERTION  *
P7       EQU      P6+1              OR DELETION NEED BE    *
P8       EQU      P7+1              MODIFIED. THE WHOLE    *
P10      EQU      P8+1              TABLE FROM PP TO DDRC  *
P13      EQU      P10+1             WILL ADJUST ITSELF.    *
P14      EQU      P13+1                                    *
P16      EQU      P14+1                                    *
P17      EQU      P16+1                                    *
P18      EQU      P17+1                                    *
P20      EQU      P18+1                                    *
P21      EQU      P20+1                                    *
P22      EQU      P21+1                                    *
VP       EQU      P22+1                                    *
PFNAM    EQU      VP                TO ALTER THE SIZE OF   *
PFACC    EQU      PFNAM+4           ANY VLP ONLY THE ENTRY *
PFPAS    EQU      PFACC+3           FOLLOWING IT NEED BE   *
PFEXP    EQU      PFPAS+3           MODIFIED.              *
PFOUT    EQU      PFEXP+3                                  *
PFRD     EQU      PFOUT+4                                  *
PFWRT    EQU      PFRD+17           ALLOW 8 RD ACCTS
PFEXU    EQU      PFWRT+17          ALLOW 8 WRT ACCTS
PFUND    EQU      PFEXU+17          ALLOW 8 EXU ACCTS
*
DPW      EQU      PFUND+4           DEV PARAM PRES WDS
DTABS    EQU      DPW+1             D
DSEQID   EQU      DTABS+4           D
DDATA    EQU      DSEQID+1          D
DCOUNT   EQU      DDATA+1           D
DLINES   EQU      DCOUNT+1          D
DSPACE   EQU      DLINES+1          D
DDRC     EQU      DSPACE+1          D'S=> DEV PARAMETERS
         TITLE    'SUB-ROUTINES'
         PAGE
* THE ASSIGN SUB-ROUTINE IS THE MANIPULATOR OF THE ASSIGN/MERGE TABLE.
* THROUGH THIS ROUTINE, ENTRIES ARE LOCATED, CHAINED, DELETED AND, WHEN
* REQUIRED, ADDITIONAL SPACE FOR ENTRIES IS OBTAINED AND INITIALIZED.
* THERE ARE ACTUALLY 3 ENTRIES TO ASSIGN. IN ALL CASES, REG 6
* AND 7 MUST CONTAIN THE ASSOCIATED DCB NAME, IN TEXTC FORMAT. REGISTER
* 4 MUST CONTAIN THE ADDRESS OF THE ASSIGN/MERGE TABLE.
*
* ENTRY 1-BAL,SR4 ASSIGN:
*        WILL CREATE A NEW ENTRY POSITION FOR THE GIVEN DCB AND RELEASE
*        ALL OTHER LIKE-DCB ENTRIES.
* ENTRY 2-BAL,SR4 ASSIGN+1:
*        WILL LOCATE THE CURRENT ENTRY FOR THE GIVEN DCB.
* ENTRY 3-BAL,SR4  ASSIGN+2:
*        WILL RELEASE THE MATCHING ENTRY(IF PRESENT) AND RETURN THE
*        SPACE TO THE AVAILABLE CHAIN. THE IN USE CHAIN IS RE-LINKED
*        AROUND THE REMOVED ENTRY.
* UPON EXIT FROM 1 AND 2:
*        REG 5 = ABSOLUTE ADDRESS OF DESIRED ENTRY. OTHER REGISTERS ARE
*        RETURNED INTACT. THE INPUT DCB NAME WILL BE STORED IN THE
*        ENTRY POINTED TO BY REG5. FOR ENTRIES 1 AND 3, THE REMAINING
*        WORDS WILL BE ZERO FILLED.
* REGISTER 5 MAY BE SET TO ZERO FOR THE FOLLOWING CONDITION:
*  ON EXIT FROM ENTRY 2 WHEN NO MATCH FOR THE DCB HAS BEEN FOUND.
*
ASSIGN   B        ASNEW1A           CREATE NEW ENTRY
         B        ASCURT            RETURN CURRENT ENTRY ADDRESS
         B        ASREL             RELEASE ENTRY AND RE-LINK
ASNEW    PUSH     5,R0
         CD,R6    TM:SI             IS IT M:SI?
         BNE      %+3
         LI,R3    SISET+SINOREL     SI ASSIGNED
         STS,R3   J:TELFLGS
         LW,R0    AM:ORG,R4
         LW,R1    AM:LNK,R4
         BNEZ     ASFIN1
*        NO ASSIGNS EXIST YET.
         LW,R1    R0                INIT PLIST CHAIN TO
         STW,R1   AM:LNK,R4         1ST AVAILABLE AREA.
         B        ASFIN
*
ASFIN1   CI,R0    X'1FF'            ANY ROOM LEFT IN PAGE?
         BGE      AMFULL            NO
         STW,R1   R2
         LW,R1    *R4,R1
         BNEZ     %-2
         LW,R1    R2
         STW,R0   *R4,R1            LINK TO LAST ENTRY
         LW,R1    R0                NEW ENTRY TO R1
ASFIN    LI,R3    0
         LW,R2    R1
         STW,R3   *R4,R2            ZERO THE REST OF A/M PG.
         AI,R2    1
         CI,R2    X'1FF'
         BLE      %-3
         AW,R1    R4                ABS ENTRY
*
         AI,R1    1                                                  RL2
         LB,R2    DCBBUF
         STB,R2   *R1
         LB,R3    DCBBUF,R2
         STB,3    *1,2                                               RL2
         BDR,2    %-2                                                RL2
         AI,R1    -1                                                 RL2
         STW,R1   R5                RETURN THE ENTRY ADDRESS
         PULL     5,R0
         B        *SR4
*
ASCURT   PUSH     3,R1
         LCI      2
         STM,R6   DCBBUF
         PUSH     R0                ';' IMPLIES UPDATE
         BAL,R3   ASCUR
         PULL     R0
         LW,R5    R1                PROVIDE ENTRY ADDRESS
         PULL   3,R1
         B        *SR4
ASCUR    EQU      %
         LW,R1    AM:LNK,R4         SCAN ASSIGNED CHAIN
ASCUR1   BEZ      *R3               NO FIND EXIT
         AW,R1    R4                ABSOLUTIZE LINK ADDRESS
         CW,6     1,R1                                               RL2
         BNE      ASCUR1A
         LB,R5    DCBBUF
         LW,15    1                                                  RL2
         AI,15    1                                                  RL2
         LB,0     *15,5                                              RL2
         CB,0     DCBBUF,R5
         BNE      ASCUR1A                                            RL2
         BDR,5    %-3                                                RL2
         LW,R5    *TELSTACK         LOOK FOR UPDATE FUNC
         CI,R5    ';'
         BNE      %+2               NOT UPDATE FUNCTION
         BAL,R5   ASGMV             FOR UPDATE MOVE ENTRY
         B        0,3               RET NEW ADDR IN R1
*
ASCUR1A  EQU      %
         STW,R1   R2                R2=ADR OF BACKWARD LINK
         LW,R1    0,R1
         B        ASCUR1
*
ASREL1   PUSH     6,R0
         B        ASREL2
*
ASREL    PUSH     6,R0              RELEASE ENTRY SAVE 0-5
         LCI      2
         STM,R6   DCBBUF
         BAL,R3   ASCUR             GO LOCATE ENTRY
*                                   RET ABS ENTRY ADDR R1
         CI,R1    0                 DID WE GET ONE
         BE       ASRELX            NO
ASREL2   SW,R1    R4                RESET TO REL POINTER
         CW,R1    AM:LNK,R4         IS IT THE 1ST ENTRY IN CHAIN?
         BE       AGREL1
         LW,R3    *R4,R1            NEXT LINK
         BEZ      AGREL2
AGREL    LW,R0    R3
         SW,R3    R1                ADJ FACTOR R3
         LW,R5    AM:ORG,R4
         SW,R5    R0                # WDS TO MOVE
         PUSH     3,R1
         AW,R1    R4                TO
         AW,R0    R4                FROM
         LI,R3    0
         LW,R2    *R0,R3            MOVE PLIST
         STW,R2   *R1,R3             UP
         AI,R3    1                   OVER
         CW,R3    R5                   DELETED ENTRY.
         BLE      %-4
         PULL     3,R1
         LW,R0    AM:ORG,R4
         SW,R0    R3
         STW,R0   AM:ORG,R4         ADJUST AVAIL. LINK
*        NOW ADJUST THE ENTRY LINKS UP.
AGREL3   LW,R0    *R4,R1            GET OLD LINK
         BEZ      ASRELX            END OF CHAIN
         SW,R0    R3                MINUS ADJ FACTOR
         STW,R0   *R4,R1
         STW,R0   R1
         B        AGREL3
*
*
ASRELX   PULL     6,R0
         B        *SR4
*
AGREL1   LW,R3    *R4,R1
         BNEZ     AGREL             FWD LINKS EXIST
         STW,R3   AM:LNK,R4         ONLY ENTRY, DELETE
         STW,R1   AM:ORG,R4         AND MAKE AVAIL.
         B        ASRELX
*        RELEASING LAST ENTRY
AGREL2   STW,R3   *R2               ZERO PREV LINK
         STW,R1   AM:ORG,R4         SET LAST AS NEW HEAD
         B        ASRELX
*
*
ASNEW1A  PUSH     SR4               RELEASE ANY LIKE ENTRIES
         LCI      2
         STM,R6   DCBBUF
         BAL,SR4  ASREL
         PULL     SR4
         PUSH     R0
         LW,R0    AM:ORG,R4         IS THERE ROOM FOR THIS ENTRY?
         AI,R0    PSIZE+3           MINIMUM POSSIBLE FPT SPACE NEED.
         CI,R0    X'1FF'            EXCEED ONE PG??
         BG       AMFULL            YES
         PULL     R0
         B        ASNEW
         PAGE
*
*        R5       LINK
*        R2       ENTER WITH PREV LINK ADDR
*        R1       RETURN ADDR OF SETBUF FOR UPDATE
*        TO UPDATE AN ENTRY: MOVE THE ENTRY FROM
*        THE ASSIGNED CHAIN TO A FIXED AREA (SETBUF)
*        ON TOP OF TELSTACK. COMPRESS THE ASSIGNED CHAIN
*        AND MOVE THE ENTRY THAT IS UPDATED TO THE
*        END OF THE CHAIN.
*
*
ASGMV    EQU      %
         PUSH     SR4               SAVE LINK
         PUSH     3,R3
         PUSH     R2                SAVE PREV LINK
         LW,R5    *R1               GET LINK TO NEXT
         BNEZ     ASGMV1
         LW,R5    AM:ORG,R4         END OF CHAIN
         SW,R1    R4                DISP TO CURR ENTRY
         SW,R5    R1                # WDS TO MOVE
         STW,R5   EXPNDSZ           SAVE #
         AW,R1    R4                ABS CURR ENTRY
         B        ASGMV2
ASGMV1   AW,R5    R4                ABS
         SW,R5    R1                #WDS TO SAVE
         STW,R5   EXPNDSZ
ASGMV2   LI,R2    SETBUFE           END OF TELSTACK
         LI,R3    0
         CI,R2    SETBUF            BEGIN OF PLIST AREA
         BL       %+3
         STW,R3   *R2               INIT PLIST AREA
         BDR,R2   %-3               R2 SET FOR MOVE
*
         AI,R1    -1
         LW,R3    *R1,R5            FROM
         STW,R3   *R2,R5            TO
         BDR,R5   %-2
         AI,R1    1
         PULL     R2                GET LAST LINK
         BAL,SR4  ASREL1
         LI,R1    SETBUF            ADDR OF ENTRY TO UPDATE
         PULL     3,R3
         PULL     SR4
         B        *R5
************************************************************************
*D*      NAME:    READAM                                               *
*D*      CALL:                                                         *
*D*               BAL,SR4   READAM                                     *
*D*      REGISTERS:     CLOBBERS SR3, ALL OTHERS ARE PRESERVED.        *
*D*      INPUT:   SR4 - LINK REGISTER                                  *
*D*               J:ABUF - SBUF2 ADDRESS IF ALREADY ACQUIRED           *
*D*               J:CPPO - FILE EXTENSION BITS IN JIT                  *
*D*      OUTPUT:                                                       *
*D*               J:ABUF - A/M RECORD ADDRESS                          *
*D*               A/M RECORD IN CORE IN SBUF2                          *
*D*               WORD 6 OF IN-CORE A/M RECORD SET WITH CURRENT J:CPPO *
*D*      SCRATCH:                                                      *
*D*               SR2 - ADDRESS OF SBUF2                               *
*D*               SR3 - SET BY RAMR CAL                                *
*D*      INTERFACE:                                                    *
*D*               SYSERR - DETECTS A900 ERROR & EXITS TO LOGOFF        *
*D*      DESCRIPTION:                                                  *
*D*               READAM CHECKS J:ABUF & IF ZERO, GETS SBUF2 WINDOW    *
*D*               PAGE.  AN SUA 60-01 RESULTS IF THE PAGE IS UNAVAIL-  *
*D*               ABLE.  THE A/M RECORD IS THEN READ INTO SBUF2. A READ*
*D*               ERROR OR ABNORMAL WILL CAUSE THE USER TO BE LOGGED   *
*D*               OFF BY SYSERR.  AFTER A SUCCESSFUL READ, J:ABUF IS   *
*D*               SET TO SBUF2.                                        *
************************************************************************
READAM   PUSH     5,R4
         LW,R4    J:ABUF            IS A/M ALREADY IN
         BNEZ     READAM1
         LI,SR2   AMBUF             GET 2ND BUFFER FOR
         CAL1,8   GPFPT               A-M RECORD
         BCR,8    GOTAMPG           GOT THE WINDOW PAGE
************************************************************************
*S*      SCREECH CODE:     60-01                                       *
*S*      REPORTED BY:     TEL                                          *
*S*      MESSAGE: TEL ISSUED SINGLE USER ABORT ON YOU                  *
*S*      TYPE:    SINGLE USER ABORT                                    *
*S*      REGISTERS:     NONE ARE SIGNIFICANT                           *
*S*      REMARKS:     TEL FAILED TO GET SBUF2 TO READ THE A/M RECORD.  *
*S*               THIS SCREECH INDICATES A PROBLEM IN MEMORY MANAGE-   *
*S*               MENT OF POOL PAGES.                                  *
************************************************************************
         CAL1,6   MSTRMODE
         SUA      X'60',1
*
GOTAMPG  EQU      %
         STW,SR2  7                 AM BUFFER ADDRESS
         LI,R5    SYSERR            SET M:TEL ERROR & ABN
         STW,R5   M:TEL+3
         STW,R5   M:TEL+4
         CAL1,1   AMR               READ A/M RECORD
         STW,R7   J:ABUF            STORE A/M BUFFER ADDR
         LI,R5    0                 CLEAN UP DCB
         STW,R5   M:TEL+3
         STW,R5   M:TEL+4
         LW,R4    J:CPPO            INIT. COPY OF FILE EXT. BITS
         STW,R4   FEXTIMG           SAVE TO RESTORE IF SET ABORTS
READAM1  EQU      %
         PULL     5,R4
         B        *SR4
         PAGE
* THIS SUB-ROUTINE PROVIDES THE WRITE OF THE ASSIGN/MERGE TABLE AND
* ALSO PLACES THE BIT ASSIGNMENT DATA INTO JIT.
* THE WRITE CALL IS IGNORED IF THE A/M IS NOT IN MEMORY.
* ENTER WITH A BAL,SR4
*
WRITEAM  PUSH     8,R4
         LW,R7    J:ABUF
         BEZ      WITEX             WRITE ONLU IF IN MEMORY
         LW,SR1   FEXTIMG           FILE EXT BITS...
         STW,SR1  J:CPPO            ...TO JIT
         LI,R5    SYSERR            ERROR RETURN
         STW,R5   M:TEL+3
         STW,R5   M:TEL+4
         CAL1,1   WAMR              WRITE OUT A/M RECORD
         LI,R5    0                 CLEAN UP DCB
         STW,R5   M:TEL+3
         STW,R5   M:TEL+4
WITEX    PULL     8,R4
         B        *SR4
         PAGE
************************************************************************
*D*      NAME:    CHKDCBN                                              *
*D*      CALL:    BAL,SR4   CHKDCBN                                    *
*D*               CALLED DURING INITIAL PARSE OF SET COMMAND           *
*D*      REGISTERS:     SAVES ALL REGISTERS USED                       *
*D*      INPUT:   DCB NAME IN TEXTC IN R6,R7,SR1                       *
*D*      DATA:    DCBNS - LIST OF DISALLOWED DCB NAMES                 *
*D*      OUTPUT:  NONE                                                 *
*D*      DESCRIPTION:     THE INPUT DCB IS COMPARED AGAINST LIST OF    *
*D*               INVALID DCB NAMES.  IF NO MATCH, RETURN IS TO        *
*D*               CALL+1.  OTHERWISE, AN ERROR MESSAGE IS              *
*D*               GENERATED AND THE SET IS ABORTED.                    *
************************************************************************
CHKDCBN  EQU      %
         PUSH     2,R4
*  VALIDATE M: OR F:
         LI,R5    X'FFFF'           MASK FOR CS
         LI,R4    C'M:'
         SLD,R4   8                 SHIFT MASK & DATA
         CS,R4    R6                IS IT M: ?
         BE       CHKOK             YES, NOW CHECK NAMES
         LI,R4    C'F:'             IS IT F: ?
         SLS,R4   8                 SHIFT ONLY DATA
         CS,R4    R6
         BNE      BADDCBN           IT'S NEITHER M: NOR F:
*  NOW SEE IF IT'S AN ILLEGAL DCB NAME
CHKOK    LI,R4    SIZDCBN
         LC       J:JIT
         BCS,8    %+2               ONLINE M:C SET OK
         AI,R4    -1                IN BATCH CHECK FOR M:C - ILLEGAL
         CD,R6    DCBNS,R4
         BE       BADDCBN           IT'S ILLEGAL
         BIR,R4   %-2
         PULL     2,R4              PASSED ALL CHECKS,
         B        *SR4                 RETURN
*
         BOUND    8
DCBNS1   EQU      %
         TEXTC    'M:UC'
         TEXTC    'M:OC'
         TEXTC    'M:XX'
         TEXTC    'M:*'
         TEXT     '    '
         TEXTC    'M:'
         TEXT     '    '
         TEXTC    'F:'
         TEXT     '    '
DCBNS    EQU      %
SIZDCBN  EQU      -(DA(DCBNS)-DA(DCBNS1))
         TEXTC    'M:C'             THIS MUST FOLLOW BAD DCB LIST
         TEXT     '    '
************************************************************************
*E*      ERROR:   GROUP 03, CODE=01, SUBCODE=15                        *
*E*      DESCRIPTION:     THE DCB NAMED IN THE SET COMMAND EITHER DID  *
*E*               NOT BEGIN WITH M: OR F:, OR IT IS ILLEGAL            *
*E*               TO SET IT.                                           *
************************************************************************
BADDCBN  PULL     2,R4
         LI,D1    X'030115'
         B        CMNERR1
         PAGE
* THE EXPAND ROUTINE IS USED TO PULL APART A COMPRESSED A/M ENTRY AND
* PUT IT IN THE NORMAL SKELETAL FORM. IN THIS MANNER, SPACE IS MADE
* AVAILABLE FOR THE INSERTION OF NEW ENTRIES OR THE ALTERATION OF
* CURRENT ONES.
* ENTER WITH BAL,SR4 AND:
*    R4=ADDRESS OF SETBUF
*        EXPAND CALLED ONLY BY 'SETUPDAT' ROUTINE.
*
*
EXPAND   PUSH     15,R1
         LI,R5    0
         XW,R5    EXPNDSZ           GET SIZE OF ENTRY
         BEZ      EXPNDERR
         CI,R5    SETBUFSZ          WILL REC FIT?
         BG       EXPNDERR          ERROR
         LW,R3    1,R4
         LB,R3    R3                SZE OF DCB NAME
         SLS,R3   -2                MAKE # OF WDS.
         AI,R3    1+1+2             ROUND DCB WDS, WD FOR LINK CELL
*                                   AND STEP OVER ADCB TO PP WD.
         SW,R5    R3                ENTRYSZE-DCB NAME&HEAD
         AW,R3    R4                PT TO ADCB FPT
         LI,R7    SETBUFSZ            BUFFER SIZE
         LI,D1    0                 MOVE PLIST TO BOTTOM OF ENTRY
         AI,R7    -1                                                 RL2
         XW,D1    *R3,R5            CLEARING THE OLD LOCATIONS AS WE GO
         XW,D1    *R4,R7            (HEADING AND PRESENCE WORDS STAY
         BDR,R5   %-3
         AI,R3    -2                                                 RL2
* NOW THAT THE INTACT PLIST IS MOVED TO THE BOTTOM OF THE ENTRY, WE CAN
* START EXPANDING IT UPWARD, STARTING FROM THE TOP OF THE PLIST.
         LI,R2    1                 DECODE PARAMETERS PRESENT
         LW,R1    2,R3              PICK UP PRESENCE WORD
EXPAND2  BAL,SR4  SHIFTY
         CI,R2    0
         BE       EXPAND3           NO MORE PARAMETERS INDICATED
         LB,R6    PLACES,R2         GET THE DISPLACEMENT POSITION
         BEZ      EXPNDERR          NO DEFINED POSITION - ERROR
         LI,R5    1
         BAL,SR4  EXPAND9
         B        EXPAND2
EXPAND3  LI,R1    X'4000'           CHECK FOR VARIABLE PARAMETERS
         LS,R1    1,R3
         BNEZ     EXPAND6           GO PROCESS VARIABLES
EXPAND4  LI,R1    X'1000'           HOW ABOUT A DEVICE ORIENTED PLIST
         LS,R1    1,R3
         BNEZ     EXPAND8           YUP-GO TO IT
EXPAND5  PULL     15,R1             ITS ALL GROWED UP NOW
         B        *SR4
*
*        PROCESS VLP'S
*        CW IN COMMENTS IS VLP CONTOL WORD
EXPAND6  LW,R6    *R4,R7             HE SET CMD ONLY HANDLES TWO
         LB,D1    R6                TYPE VLP
         CI,D1    1                 NAME?
         BE       %+3
         LW,D4    R6
         B        EXPAND7
         LI,R5    7                 MOVE NAME-ACCOUNT-PASSWORD
         LI,R6    PFNAM
         BAL,SR4  EXPAND9
         LW,D4    *R4,R7            D4 = PASSWORD KEY WORD
         LI,R5    3
         BAL,SR4  EXPAND9
         LI,R1    X'10000'          CHECK FOR MORE VARIABLES
         LS,R1    D4
         BNEZ     EXPAND4           NO MORE
         LW,D4    *R4,R7            D4=EXPIR. OR INSN/OUTSN KEYWORD
         LB,D1    D4
         CI,D1    4                 IS IT EXPIR.
         BNE      EXPAND7           NO, MUST BE INSN
         LI,R6    PFEXP
         LI,R5    3                 YES
         BAL,SR4  EXPAND9           MOVE EXPIR.
         LI,R1    X'10000'          CHECK FOR MORE VARIABLES
         LS,R1    D4
         BNEZ     EXPAND4           NO MORE
         LW,D4    *R4,R7
         LB,D1    D4                CONTROL BYTE
EXPAND7  CI,D1    7                 IS IT SN?
         BNE      EXPANDRD          GO TRY RD ACCTS
         BAL,SR4  EXPSUB1
         LI,R6    PFOUT
EXPAND71 BAL,SR4  EXPAND9           MOVE ENTRIES.
         LI,R1    X'10000'
         LS,R1    D4                LAST VLP?
         BNEZ     EXPAND4           YES
         LW,D4    *R4,R7
         LB,D1    D4
EXPANDRD CI,D1    5                 RD ACCTS?
         BNE      EXPANDWR          NO
         BAL,SR4  EXPSUB1
         LI,R6    PFRD
         B        EXPAND71          GO MOVE 'EM
*
EXPANDWR CI,D1    6                 WRT ACCTS?
         BNE      EXPANDEX          NO
         BAL,SR4  EXPSUB1
         LI,R6    PFWRT
         B        EXPAND71
*
EXPANDEX CI,D1    X'14'             EXEC ACCTS?
         BNE      EXPANDUN          NO
         BAL,SR4  EXPSUB1
         LI,R6    PFEXU
         B        EXPAND71
*
EXPANDUN CI,D1    X'15'             UNDER VLP?
         BNE      EXPNDERR          NO, THIS IS LAST SO ERROR.
         BAL,SR4  EXPSUB1
         LI,R6    PFUND
         BAL,SR4  EXPAND9
         B        EXPAND4
EXPAND8  LW,R1    *R4,R7            PICK UP DEVICE PRESENCE WORD
         LI,R5    1                 MOVE IT UP
         LI,R6    DPW
         BAL,SR4  EXPAND9
         LI,R2    1
EXPAND10 BAL,SR4  SHIFTY            DECODE PRESENCE WORD
         CI,R2    0                 TEST FOR COMPLETION
         BE       EXPAND5
         LB,R6    THINGS,R2
         BEZ      EXPNDERR          ERROR IN FORMAT
         CI,R6    DTABS             TABS IS A UNIQUE CASE
         BE       EXPAND11
         LI,R5    1
         BAL,SR4  EXPAND9
         B        EXPAND10
EXPAND11 LI,R5    4
         B        EXPAND11-2
EXPAND9  LI,D1    0
         XW,D1    *R4,R7            MOVE THE PARAMETER UP, CLEARING THE
         STW,D1   *R3,R6            OLD LOCATION
         AI,R7    1
         AI,R6    1
         BDR,R5   EXPAND9
         B        *SR4
*
EXPSUB1  LW,D3    D4                CW TO D3
         SLS,D3   16                SHFT TO # WDS IN USE
         LB,R5    D3                # TO MOVE
         AI,R5    1                 ADD IN CW TO COUNT
         B        *SR4              DO IT!
         PAGE
* THIS SUB-ROUTINE WILL DETERMINE THE VALUE OF A PRESENCE BIT AND RETURN
* ITS RELATIVE POSITION WITHIN A TEL SKELETAL PLIST. THIS IS DONE BY A
* REPETITIVE LEFT SHIFT AND COUNTING THE NUMBER OF SHIFTS REQUIRED TO
* BRING A ONE INTO POSITION ZERO OF THE WORD.
* THE INPUT PRESENCE IMAGE MUST BE IN R1.
* THE POSITION COUNT IS MAINTAINED IN R2, WHICH MUST BE INITIALIZED
* OUTSIDE OF THE SUB-ROUTINE. IF 0 IS RETURNED, NO BITS WERE PRESENT.
* THE SUB-ROUTINE WILL AUTO-MATICALLY RESET BIT ZERO AFTER SHIFTING SO
* THAT SUBSEQUENT CALLS WILL PROVIDE AN ACCUMULATIVE EFFECT.
* ENTER WITH BAL,SR4
*
SHIFTY   PUSH     R3
         LW,R3    R1                INITIAL TEST FOR BIT0
         BGZ      SHIFTY3
         BEZ      SHIFTY2
         LI,R2    1                 PARAMETER ONE INDICATED
SHIFTY1  AND,R1   NBIT0             RESET BIT 0
         PULL     R3
         B        *SR4
SHIFTY2  LI,R2    0                 NO BITS SET
         B        SHIFTY1+1
SHIFTY3  AI,R2    1
         SLS,R1   1
         BCS,4    SHIFTY1
         B        SHIFTY3
         PAGE
************************************************************************
*D*      NAME:    FEXTBITS                                             *
*D*      REGISTERS:     R4 IS PRESERVED, ALL OTHERS ARE VULNERABLE     *
*D*      CALL:    CALLED ONLY FROM SETFILE3 WHEN PROCESSING A          *
*D*               FILE-TYPE SET.                                       *
*D*      DATA:    FILEXTP - INTERNAL TABLE OF FILE-EXTENDABLE DCB NAMES*
*D*               SIZFILXP - SIZE OF FILEXTP IN HALF-WORDS             *
*D*      INPUT:   R4 - ADDRESS OF PLIST ENTRY BEING CHECKED            *
*D*               SR4 - LINK REGISTER                                  *
*D*      OUTPUT:  FEXTIMG - FILE EXTENSION BIT RESET IF NAME MATCHED   *
*D*      DESCRIPTION:     THE FILE EXTENSION BIT CORRESPONDING TO THIS *
*D*               DCB IS RESET IF THE DCB BEING PROCESSED IS A SYSTEM  *
*D*               DCB, I.E.  M:YY, WHERE YY IS FOUND IN THE FILEXTP    *
*D*               LIST.  FILE EXTENSION BITS ARE KEPT IN JIT AND COPIED*
*D*               INTO FEXTIMG IN TEL'S CONTEXT EACH TIME THE A/M      *
*D*               RECORD IS READ IN.  FEXTIMG IS TRANSFERRED TO JIT    *
*D*               AFTER THE A/M RECORD IS WRITTEN.  THUS, AN ABORT     *
*D*               WHILE PROCESSING A SET COMMAND WILL NOT RESULT IN    *
*D*               FAULTY SETTINGS FOR FILE EXTENSION SINCE FEXTIMG     *
*D*               WILL BE REINITIALIZED WHEN THE A/M RECORD IS         *
*D*               READ.                                                *
************************************************************************
FEXTBITS EQU      %
         LCI      2                 GET DCB NAME
         LM,D1    1,R4
         SLD,D1   8                 REMOVE BYTE COUNT
         LI,R0    X'FD47A'          CHECK FOR SYSTEM DCB
         CH,R0    D1
         BNE      *SR4              NOPE
         OR,D1    YFFFF
         LI,R7    0                 LOOK FOR MATCH IN FILE EXTEND BITS
BITS1    CH,D1    FILEXTP,R7
         BE       BITS4             FOUND ONE
         AI,R7    1
         CI,R7    SIZFILXP-1
         BLE      BITS1
         B        *SR4
BITS4    LI,SR2   -2                RESET APPROPRIATE EXTEND BIT
         SCS,SR2  0,R7              POSITION RSET MASK LEFT
         AND,SR2  FEXTIMG           RESET BIT IF ON AND
         STW,SR2  FEXTIMG           STORE RESULT.
         B        *SR4
         PAGE
************************************************************************
*D*      NAME:    PENT                                                 *
*D*      CALL:                                                         *
*D*               BAL,SR4   PENT                                       *
*D*      REGISTERS:                                                    *
*D*               PRESERVES ALL REGISTERS USED                         *
*D*      INPUT:                                                        *
*D*               R4 = SETBUF ADDRESS                                  *
*D*               R5 = POSITIONED PARAMETER PRESENCE BIT(S) OR,        *
*D*                    IF -1, INDICATES D2 HAS MASK FOR STS            *
*D*               R7 = DISPLACEMENT FROM TOP OF PLIST                  *
*D*               D1 = PARAMETER WORD                                  *
*D*               D2 = STS MASK FOR D1 IF R5 = -1                      *
*D*      OUTPUT:                                                       *
*D*               INFO IS STORED IN SKELETON PLIST IN SETBUF           *
*D*      INTERFACE:                                                    *
*D*               ADJUST4 - TO POSITION R4 PAST FIXED PLIST DATA       *
*D*      DESCRIPTION:                                                  *
*D*               ENTERS A PRE-FORMED PARAMETER WORD & PRESENCE BITS   *
*D*               INTO THE SKELETAL PLIST IN SETBUF                    *
************************************************************************
PENT     EQU      %
         PUSH     SR4               SAVE RETURN
         BAL,SR4  ADJUST4
         CI,R5    -1                IS MASK PRESENT?
         BE       PENT1             YES
         STW,D1   *R4,R7            STORE PARAMETER WORD
         STS,R5   2,R4              STORE PRESENCE BITS
         B        %+2
PENT1    STS,D1   *R4,R7            D2 HAS MASK FOR D1 BITS
         PULL     R4                PUSHED BY ADJUST4
         PULL     SR4
         B        *SR4              RETURN
         PAGE
* TRUNDLE ROUTINE WILL COMPACT THE PREFORMED PLIST, ELIMINATING ANY
* ZERO WORDS, RESULTING IN A CLOSED FORM USABLE BY THE MONITOR OPEN'
* LOGIC.
* ENTER WITH A BAL,SR4 WITH:
*        R4 = ABSOLUTE ADDRESS OF A/M ENTRY TO BE COMPACTED.
* THERE ARE NO ERROR RETURNS AND ALL REGISTERS ARE PRESERVED.
*  ENTRY POINT: 'TRUNDLE'...CALLED BY DOER IN SET LOGIC.
*
*
TRUNDLE  PUSH     5,R5              GET WORKING SPACE AND INDEXES
*                                   TRUNDLE                          RL2
         LI,R4    SETBUF
         LW,8     1,4                                                RL2
         LB,8     8                                                  RL2
         AI,8     4+4                                                RL2
         SLS,8    -2                                                 RL2
         LW,R7    8                 DCB WDS+CHN LINK WD
         AI,R7    3                 1ST 3 WDS OF PLIST
         STW,R7   SZCELL            KEEP TRCK OF LENG HERE
         AW,8     4                 PT  TO  PLIST                    RL2
         LW,7     8                                                  RL2
         LW,10    8                                                  RL2
         AI,10    DPW                                                RL2
*                                        COMPRESSING OF PARMS
         LI,R5    X'A000'           SET FIXED FLAGS IN 1ST PRESENCE WORD
         STS,R5   1,R7
         LI,R5    X'4000'           ARE THERE ANY VARIABLE PARAMS
         LS,R5    1,R7
         BEZ      TRUNDLE1          NO
         LI,R5    X'10000'          FLAG FOR LAST VLP
         LW,SR1   PFUND,R7          LOOKING FOR LAST VLP HERE
         BEZ      TRUNDLEF          NO PROCESSORS
         STS,R5   PFUND,R7
         B        TRUNZ             GO RESET ANY LAST VLP BITS
TRUNDLEF LW,SR1   PFEXU,R7
         BEZ      TRUNDLEE
         STS,R5   PFEXU,R7
         B        TRUNZ1
TRUNDLEE LW,SR1   PFWRT,R7
         BEZ      TRUNDLED
         STS,R5   PFWRT,R7
         B        TRUNZ2
TRUNDLED LW,SR1   PFRD,R7
         BEZ      TRUNDLEC
         STS,R5   PFRD,R7
         B        TRUNZ3
TRUNDLEC LW,SR1   PFOUT,R7
         BEZ      TRUNDLEA
         STS,R5   PFOUT,R7
         B        TRUNZ4
TRUNDLEA LW,SR1   PFEXP,R7          IS THERE AN EXPIR. DATE
         BEZ      TRUNDLEB          NO
         STS,R5   PFEXP,R7          YES, CONSIDER IT AS LAST VLP
         B        TRUNZ5
TRUNDLEB STS,R5   PFPAS,R7          CONSIDER PASS. AS LAST VLP
*                  TRUNDLE          *                                RL2
TRUNDLE1 RES      0                                                  RL2
         AI,7     3                 BYPASS  P BITS                   RL2
         LI,SR1   0                                                  RL2
         LI,SR2   SETBUFE
TRUNDLE2 LW,R5    0,R7              FIND A ZERO WORD
         BNEZ     TRUNDLE4
         LW,R6    R7
TRUNDLE3 AI,R6    1
         CW,R6    SR2               TEST FOR END OF ENTRY
         BE       TRUNDLE5          DONE
         LW,R5    0,R6
         BEZ      TRUNDLE3
         CW,6     10                                                 RL2
         BNE      TRUNA             NO
         LW,R5    0,R6              YES-ARE TABS SPECIFIED
         BCR,1    TRUNA             NO
         LI,R5    5                 YES-HANDLE UNIQUELY AS TAB WORDS CAN
TRUNB    XW,SR1   0,R6              LEGITIMITTILY CONTAIN ZEROS. THE
         XW,SR1   0,R7              TAB PARAMETER WILL ALWAYS HAVE FOUR
         AI,R6    1                 WORDS. WE MOVE THOSE PLUS THE
         AI,R7    1                 PRESENCE WORD TOGETHER AS ORIG.
         BDR,R5   TRUNB             CODED, TEERE WILL ALWAYS BE AT LEAST
         MTW,5    SZCELL            COUNT DPW&TABS WDS
         B        TRUNDLE4+2        1 ZRO WD FOUND BEFORE DPW+3
TRUNA    XW,SR1   0,R6              MOVE THE WORD UP, CLEARING THE OLD
         XW,SR1   0,R7              LOCATION IN THE PROCESS
TRUNDLE4 AI,R7    1
         MTW,1    SZCELL            COUNT THE WD
         CW,R7    SR2               CHECK FOR ENTRY LIMIT
         BL       TRUNDLE2
TRUNDLE5 PULL     5,R5
         B        *SR4
*
*
TRUNZ    LI,R5    X'EFFFF'          * CARE MUST BE TAKEN
         LS,R5    PFEXU,R7          * TO RESET ANY PREVIOUSLY
         STW,R5   PFEXU,R7          * SET LAST ENTRY INDICATORS
TRUNZ1   LI,R5    X'EFFFF'          * IN VLP CW'S OCCURRING
         LS,R5    PFWRT,R7          * EARLIER IN THE PLIST
         STW,R5   PFWRT,R7          *
TRUNZ2   LI,R5    X'EFFFF'          *
         LS,R5    PFRD,R7           *
         STW,R5   PFRD,R7           *
TRUNZ3   LI,R5    X'EFFFF'          *
         LS,R5    PFOUT,R7          *
         STW,R5   PFOUT,R7          *
TRUNZ4   LI,R5    X'EFFFF'          *
         LS,R5    PFEXP,R7          *
         STW,R5   PFEXP,R7          *
TRUNZ5   LI,R5    X'EFFFF'          * PASS IS LAST NECESS. TO CHK
         LS,R5    PFPAS,R7          * IF PASS EXIST SO DO ACCT&NAME.
         STW,R5   PFPAS,R7          *
         B        TRUNDLE1
*
         PAGE
*                 ENTER ON SR4                                       RL2
ADJUST4  PUSH     R4                ADJUST FOR NAME                  RL2
         LW,4     1,4                                                RL2
         LB,4     4                                                  RL2
         AI,4     4+4                                                RL2
         SLS,4    -2                                                 RL2
         AW,4     *TELSTACK
         B        *SR4                                               RL2
         PAGE
* THIS SUB-ROUTINE WILL CREATE A 'STANDARD' SHORT FORM PLIST IN THE
* ASSIGN/MERGE TABLE. THE IMAGE USED IS THAT OF LOCATION 'PLIST'.
* THE ENTRY CREATED IS ALWAYS SPECIFIED AS AN OUT MODE ENTRY.
* ENTER WITH A BAL,SR4 WITH:
*        REG R5 = ASSIGN TABLE ENTRY
*        REGS D1,D2,D3 = FILE NAME
*        REGS SR2,SR3  = ACCOUNT
*        REGS R7,SR1   = PASSWORD
*
FILENT   PUSH     15,R1
         LW,2     1,5                                                RL2
         LB,2     2                                                  RL2
         AI,2     4+4                                                RL2
         SLS,2   -2                 PLIST                            RL2
         AI,2    -3                 ADJUSTMENT                       RL2
         AW,5     2                                                  RL2
         PUSH     R0
         LCI      5
         LM,R0    PLIST
         STM,R0   3,R5              THERE GO THE FIXED WORDS
         PULL     R0
         LW,R6    PPAS              MOVE PASSWORD
         CI,R7    0                 IS THERE REALLY A PASSWORD
         BE       FILT3
         AI,R6    X'200'            YES-TURN ON PARAMETER WORD
FILT2    EQU      %
         LCI      3
         STM,R6   PPAS-PLIST+3,R5
         LW,SR1   PACC              ACCOUNT PARAM
         LCI      3
         STM,SR1  PACC-PLIST+3,R5
         STW,R5   R1                MOVE ENTRY ADDRESS
         BAL,SR3  NFND              MAKE NAME TEXTC
         LW,R5    NAME              AND STORE IT
         LCI      4
         STM,R5   NAME-PLIST+3,R1
         LW,R4    J:ABUF
         LI,R7    PSIZE+3           SIZE OF THIS ENTRY
         AWM,R7   AM:ORG,R4         UPDATE FREE HEAD
         LI,R7    -(FIPROC+1)       RESET THE
         AND,R7   J:TELFLGS            N.A.P PROCESSED
         STW,R7   J:TELFLGS            FLAG
         PULL     15,R1
         B        *SR4              RETURN
FILT3    LW,R7    VERB2             PAD SPACES FOR TRUNDLE...
         LW,SR1   VERB2             ...IN CASE OF UPDATE
         B        FILT2
         END

