*COPY                                                 GUPVAR            10000000
DSKSTT   DC    0F'0',CL8'ESTATE'                               @SC86295 10001000
DSKSTNM  DS    CL18          File name                         @SC86295 10002000
         ORG   DSKSTT+FDBD-FABD                                @SC86295 10003000
         DS    XL(FDBINFO)   Room for FDB                      @SC86295 10004000
*COPY                                                 GUPSPC            10005000
*          Specific preliminaries                                       10006000
&STORDS  SETC  'KSTORG'      Storage DSECT for Kermit globals  @SC89268         
*                                                                               
LFID     EQU   18            Filespec length                        CMS 10007000
STKDWDS  EQU   511           Requested stack length                 CMS 10008000
KWRKBASE EQU   11            Base register for work area       @SC89268         
KSUBBASE EQU   12            Base register for CSECT           @SC89268         
         FSTB  ,                                                    CMS 10009000
         NUCON ,                                                    CMS 10010000
*COPY                                                 GUPFIN            10011000
*          (NO EPILOG)                                              CMS 10012000
*COPY                                                 GUPNIT            10013000
*          CMS user interface                                       CMS 10014000
         LR    3,1                                                  CMS 10015000
         MVI   SRCNAM,0      NO NAME YET                            CMS 10016000
         MVC   SRCNAM+8(10),=C'ASSEMBLEA1' DEFAULTS                 CMS 10017000
         MVC   CTLNAM+8(10),=C'UPDATE  A1'                          CMS 10018000
         MVI   FLG,XXCOR+XX8                                        CMS 10019000
*                                                                   CMS 10020000
         BAL   14,PRMCK                                             CMS 10021000
         MVC   SRCNAM(8),0(3)   FN                                  CMS 10022000
         MVC   CTLNAM(8),0(3)                                       CMS 10023000
         MVC   MRKD,0(3)                                            CMS 10024000
         MVI   OUTNAM,C'$'                                          CMS 10025000
         MVC   OUTNAM+1(7),0(3)                                     CMS 10026000
         BAL   14,PRMCK                                             CMS 10027000
         MVC   SRCNAM+8(8),0(3)   FT                                CMS 10028000
         BAL   14,PRMCK                                             CMS 10029000
         MVC   SRCNAM+16(2),0(3)  FM                                CMS 10030000
         BAL   14,PRMCK                                             CMS 10031000
         MVC   CTLNAM(8),0(3)                                       CMS 10032000
         CLI   0(3),C'='                                            CMS 10033000
         BNE   *+10                                                 CMS 10034000
         MVC   CTLNAM(8),SRCNAM   COPY SOURCE NAME                  CMS 10035000
         BAL   14,PRMCK                                             CMS 10036000
         MVC   CTLNAM+8(8),0(3)   FT                                CMS 10037000
         BAL   14,PRMCK                                             CMS 10038000
         MVC   CTLNAM+16(2),0(3)  FM                                CMS 10039000
         BAL   14,PRMCK                                             CMS 10040000
PRMERR   LINEDIT TEXT='INVALID PARAMETER ''........''',DOT=NO,      CMS+10041000
               SUB=(CHARA,(3))                                      CMS 10042000
         B     ERREX                                                CMS 10043000
*                                                                   CMS 10044000
PRMCK    LA    3,8(3)        NEXT PARAMETER                         CMS 10045000
         CLI   0(3),C'('                                            CMS 10046000
         BE    PRMZ          DONE                                   CMS 10047000
         CLI   0(3),255                                             CMS 10048000
         BNER  14                                                   CMS 10049000
         SH    3,PRMCK+2                                            CMS 10050000
PRMZ     MVC   OUTNAM+8(10),SRCNAM+8                                CMS 10051000
OPTLP    LA    3,8(3)                                               CMS 10052000
         CLI   0(3),C')'                                            CMS 10053000
         BE    OPTZ          DONE                                   CMS 10054000
         CLI   0(3),255                                             CMS 10055000
         BE    OPTZ          DONE                                   CMS 10056000
         LA    4,LOPTB                                              CMS 10057000
         LA    5,OPTBZ                                              CMS 10058000
         LA    6,OPTB        SET UP BXLE                            CMS 10059000
OPTCK    CLC   0(8,3),0(6)                                          CMS 10060000
         BE    OPTFND                                               CMS 10061000
         BXLE  6,4,OPTCK                                            CMS 10062000
         B     PRMERR                                               CMS 10063000
OPTFND   OC    FLG,8(6)      SET FLAGS                              CMS 10064000
         OC    FLG,9(6)                                             CMS 10065000
         XC    FLG,9(6)      CLEAR FLAGS                            CMS 10066000
         B     OPTLP         KEEP LOOKING                           CMS 10067000
*                                                                   CMS 10068000
*          OPTION TABLE                                             CMS 10069000
OPTB     DC    C'SEQ8    ',AL1(XX8,0)                               CMS 10070000
         DC    C'NOSEQ8  ',AL1(0,XX8)                               CMS 10071000
         DC    C'STOR    ',AL1(XXCOR,0)                             CMS 10072000
OPTBZ    DC    C'NOSTOR  ',AL1(0,XXCOR)                             CMS 10073000
LOPTB    EQU   *-OPTBZ       LENGTH OF ITEM                         CMS 10074000
*                                                                   CMS 10075000
OPTZ     CLI   SRCNAM,0      ANY FN AT ALL?                         CMS 10076000
         BNE   OPN           OK                                     CMS 10077000
         PTEXT 'NO FILENAME SPECIFIED'                              CMS 10078000
         B     ERRMSG                                               CMS 10079000
*                                                                   CMS 10080000
OPNERR   LINEDIT TEXT='FILE ''....................'' NOT FOUND',    CMS+10081000
               DOT=NO,SUB=(CHAR8A,(2))                              CMS 10082000
         B     ERREX                                                CMS 10083000
DSKERR   LA    2,8(1)                                               CMS 10084000
         LINEDIT TEXT='DISK ERROR ON FILE ''....................''',   +10085000
               DOT=NO,SUB=(CHAR8A,(2))                              CMS 10086000
         B     ERREX                                                CMS 10087000
*COPY                                                 GUPSUB            10088000
         TITLE 'DISKIO Routine - performs disk I/O functions'           10089000
* Function selected on entry by R0:                                     10090000
* 1=> open (in): R1->pattern FDB, R2->name.  Returns R0->FAB, R1->FDB   10091000
* 2=> open (out): (same, but no complete FDB if new file)               10092000
* 3=> test name: R2->name.  Returns R1->FDB if found (else R15=1)       10093000
* 4=> close file: R1->adr(FAB).                                         10094000
DISKIO   ENTER                                                          10095000
         USING FABD,3                                          @SC86295 10096000
         SR    4,4           Signal no block assigned          @SC86295 10097000
         BCT   0,DSKOPNO                                       @SC86295 10098000
*                                                                       10099000
* Open for input file whose name is at (R2), FDB at (R1)                10100000
         BAL   9,DSKALC      Get FAB                           @SC86295 10101000
DSKOP0   BAL   2,DSKLKP      Get FST, ADT ptrs                 @SC86295 10102000
         BNZ   DSKER1        Not found                         @SC86295 10103000
         BAL   14,DSKVALS                                      @SC86295 10104000
         B     RTRN0                                           @SC86295 10105000
*                                                                       10106000
* Open for output file whose name is at (R2), FDB at (R1)               10107000
DSKOPNO  BCT   0,DSKTEST                                       @SC86295 10108000
         BAL   9,DSKALC      Get FAB                           @SC86295 10109000
       FSERASE FSCB=(3)                                        @SC86295 10110000
         B     RTRN0                                           @SC86295 10111000
*                                                                       10112000
* Test for existence of file whose name is at (R2)                      10113000
DSKTEST  BCT   0,DSKCLOS                                       @SC86295 10114000
         MVC   DSKSTNM,0(2)                                    @SC86295 10115000
         LA    3,DSKSTT                                        @SC86295 10116000
         B     DSKOP0        Test file                         @SC86295 10117000
*                                                                       10118000
* Close file whose ticket is at (R1), release block                     10119000
DSKCLOS  DS    0H                                                       10120000
         ICM   3,15,0(1)     Get FAB ptr, if any               @SC86295 10121000
         BZ    RTRN0         None, ignore                      @SC86295 10122000
         XC    0(4,1),0(1)   Yes, now clear ticket             @SC86295 10123000
       FSCLOSE FSCB=(3)                                        @SC86295 10124000
         LA    0,FABDWDS                                       @SC86295 10125000
       DMSFRET DWORDS=(0),LOC=(1)                              @SC86295 10126000
         B     RTRN0                                           @SC86295 10127000
*                                                                       10128000
* Return on error, release useless block, if any                        10129000
DSKER1   LTR   1,4           Any block assigned?               @SC86295 10130000
         BZ    RTRN1         No                                @SC86295 10131000
         LA    0,FABDWDS     Yes, release it                   @SC86295 10132000
       DMSFRET DWORDS=(0),LOC=(1)                              @SC86295 10133000
         B     RTRN1         Flag error                        @SC86295 10134000
*                                                                       10135000
DSKALC   LR    5,1           Save FDB ptr                      @SC86295 10136000
         MVC   DSKSTNM,0(2)                                    @SC86295 10137000
         LA    0,FABDWDS                                       @SC86295 10138000
       DMSFREE DWORDS=(0),ERR=DSKER1                           @SC86295 10139000
         LR    3,1           New block ptr                     @SC86295 10140000
         LR    4,1                                             @SC86295 10141000
         L     1,4(13)                                         @SC86295 10142000
         ST    3,20(1)       Return R0                         @SC86295 10143000
         XC    0(8*FABDWDS,3),0(3)                             @SC86295 10144000
         MVC   FDBD(FDBCOP),0(5) Copy user's FDB               @SC86295 10145000
         MVC   FABFN(18),0(2)                                  @SC86295 10146000
         OI    FDBFLGS,FDBEPL                                  @SC86295 10147000
         MVI   FABANIT+3,1                                     @SC86295 10148000
         BR    9                                               @SC86295 10149000
*                                                                       10150000
DSKLKP  DMSKEY NUCLEUS                                         @SC86295 10151000
        GETFST DSKSTT        Call system routine for FST       @SC86295 10152000
         LR    8,1           And FST ptr                       @SC86295 10153000
         LTR   1,15          Save return code                  @SC86295 10154000
        DMSKEY RESET                                           @SC86295 10155000
         LTR   15,1          Test return code                  @SC86295 10156000
         BR    2                                               @SC86295 10157000
*                                                                       10158000
         USING FSTSECT,8                                                10159000
*                                                                       10160000
DSKVALS  LA    0,FDBD        Ptr to FDB                        @SC86295 10161000
         L     1,4(13)                                         @SC86295 10162000
         ST    0,24(1)       Return ptr to caller              @SC86295 10163000
         MVC   FDBRCF,FSTFV  Copy format                       @SC86295 10164000
         MVC   FDBLRC,FSTIL+2 No, copy from FST                @SC86295 10165000
         BR    14                                              @SC86295 10166000
*                                                                       10167000
         DROP  8                                                        10168000
*                                                                       10169000
         LOCALS ,                                              @SC86295 10170000
DISKIO   EXIT                                                           10171000
