home *** CD-ROM | disk | FTP | other *** search
/ Columbia Kermit / kermit.zip / ibm370 / ikcgup.asm < prev    next >
Assembly Source File  |  2020-01-01  |  14KB  |  177 lines
  1. *COPY                                                 GUPVAR            10000000
  2. DSKSTT   DC    0F'0',CL8'ESTATE'                               @SC86295 10001000
  3. DSKSTNM  DS    CL18          File name                         @SC86295 10002000
  4.          ORG   DSKSTT+FDBD-FABD                                @SC86295 10003000
  5.          DS    XL(FDBINFO)   Room for FDB                      @SC86295 10004000
  6. *COPY                                                 GUPSPC            10005000
  7. *          Specific preliminaries                                       10006000
  8. &STORDS  SETC  'KSTORG'      Storage DSECT for Kermit globals  @SC89268         
  9. *                                                                               
  10. LFID     EQU   18            Filespec length                        CMS 10007000
  11. STKDWDS  EQU   511           Requested stack length                 CMS 10008000
  12. KWRKBASE EQU   11            Base register for work area       @SC89268         
  13. KSUBBASE EQU   12            Base register for CSECT           @SC89268         
  14.          FSTB  ,                                                    CMS 10009000
  15.          NUCON ,                                                    CMS 10010000
  16. *COPY                                                 GUPFIN            10011000
  17. *          (NO EPILOG)                                              CMS 10012000
  18. *COPY                                                 GUPNIT            10013000
  19. *          CMS user interface                                       CMS 10014000
  20.          LR    3,1                                                  CMS 10015000
  21.          MVI   SRCNAM,0      NO NAME YET                            CMS 10016000
  22.          MVC   SRCNAM+8(10),=C'ASSEMBLEA1' DEFAULTS                 CMS 10017000
  23.          MVC   CTLNAM+8(10),=C'UPDATE  A1'                          CMS 10018000
  24.          MVI   FLG,XXCOR+XX8                                        CMS 10019000
  25. *                                                                   CMS 10020000
  26.          BAL   14,PRMCK                                             CMS 10021000
  27.          MVC   SRCNAM(8),0(3)   FN                                  CMS 10022000
  28.          MVC   CTLNAM(8),0(3)                                       CMS 10023000
  29.          MVC   MRKD,0(3)                                            CMS 10024000
  30.          MVI   OUTNAM,C'$'                                          CMS 10025000
  31.          MVC   OUTNAM+1(7),0(3)                                     CMS 10026000
  32.          BAL   14,PRMCK                                             CMS 10027000
  33.          MVC   SRCNAM+8(8),0(3)   FT                                CMS 10028000
  34.          BAL   14,PRMCK                                             CMS 10029000
  35.          MVC   SRCNAM+16(2),0(3)  FM                                CMS 10030000
  36.          BAL   14,PRMCK                                             CMS 10031000
  37.          MVC   CTLNAM(8),0(3)                                       CMS 10032000
  38.          CLI   0(3),C'='                                            CMS 10033000
  39.          BNE   *+10                                                 CMS 10034000
  40.          MVC   CTLNAM(8),SRCNAM   COPY SOURCE NAME                  CMS 10035000
  41.          BAL   14,PRMCK                                             CMS 10036000
  42.          MVC   CTLNAM+8(8),0(3)   FT                                CMS 10037000
  43.          BAL   14,PRMCK                                             CMS 10038000
  44.          MVC   CTLNAM+16(2),0(3)  FM                                CMS 10039000
  45.          BAL   14,PRMCK                                             CMS 10040000
  46. PRMERR   LINEDIT TEXT='INVALID PARAMETER ''........''',DOT=NO,      CMS+10041000
  47.                SUB=(CHARA,(3))                                      CMS 10042000
  48.          B     ERREX                                                CMS 10043000
  49. *                                                                   CMS 10044000
  50. PRMCK    LA    3,8(3)        NEXT PARAMETER                         CMS 10045000
  51.          CLI   0(3),C'('                                            CMS 10046000
  52.          BE    PRMZ          DONE                                   CMS 10047000
  53.          CLI   0(3),255                                             CMS 10048000
  54.          BNER  14                                                   CMS 10049000
  55.          SH    3,PRMCK+2                                            CMS 10050000
  56. PRMZ     MVC   OUTNAM+8(10),SRCNAM+8                                CMS 10051000
  57. OPTLP    LA    3,8(3)                                               CMS 10052000
  58.          CLI   0(3),C')'                                            CMS 10053000
  59.          BE    OPTZ          DONE                                   CMS 10054000
  60.          CLI   0(3),255                                             CMS 10055000
  61.          BE    OPTZ          DONE                                   CMS 10056000
  62.          LA    4,LOPTB                                              CMS 10057000
  63.          LA    5,OPTBZ                                              CMS 10058000
  64.          LA    6,OPTB        SET UP BXLE                            CMS 10059000
  65. OPTCK    CLC   0(8,3),0(6)                                          CMS 10060000
  66.          BE    OPTFND                                               CMS 10061000
  67.          BXLE  6,4,OPTCK                                            CMS 10062000
  68.          B     PRMERR                                               CMS 10063000
  69. OPTFND   OC    FLG,8(6)      SET FLAGS                              CMS 10064000
  70.          OC    FLG,9(6)                                             CMS 10065000
  71.          XC    FLG,9(6)      CLEAR FLAGS                            CMS 10066000
  72.          B     OPTLP         KEEP LOOKING                           CMS 10067000
  73. *                                                                   CMS 10068000
  74. *          OPTION TABLE                                             CMS 10069000
  75. OPTB     DC    C'SEQ8    ',AL1(XX8,0)                               CMS 10070000
  76.          DC    C'NOSEQ8  ',AL1(0,XX8)                               CMS 10071000
  77.          DC    C'STOR    ',AL1(XXCOR,0)                             CMS 10072000
  78. OPTBZ    DC    C'NOSTOR  ',AL1(0,XXCOR)                             CMS 10073000
  79. LOPTB    EQU   *-OPTBZ       LENGTH OF ITEM                         CMS 10074000
  80. *                                                                   CMS 10075000
  81. OPTZ     CLI   SRCNAM,0      ANY FN AT ALL?                         CMS 10076000
  82.          BNE   OPN           OK                                     CMS 10077000
  83.          PTEXT 'NO FILENAME SPECIFIED'                              CMS 10078000
  84.          B     ERRMSG                                               CMS 10079000
  85. *                                                                   CMS 10080000
  86. OPNERR   LINEDIT TEXT='FILE ''....................'' NOT FOUND',    CMS+10081000
  87.                DOT=NO,SUB=(CHAR8A,(2))                              CMS 10082000
  88.          B     ERREX                                                CMS 10083000
  89. DSKERR   LA    2,8(1)                                               CMS 10084000
  90.          LINEDIT TEXT='DISK ERROR ON FILE ''....................''',   +10085000
  91.                DOT=NO,SUB=(CHAR8A,(2))                              CMS 10086000
  92.          B     ERREX                                                CMS 10087000
  93. *COPY                                                 GUPSUB            10088000
  94.          TITLE 'DISKIO Routine - performs disk I/O functions'           10089000
  95. * Function selected on entry by R0:                                     10090000
  96. * 1=> open (in): R1->pattern FDB, R2->name.  Returns R0->FAB, R1->FDB   10091000
  97. * 2=> open (out): (same, but no complete FDB if new file)               10092000
  98. * 3=> test name: R2->name.  Returns R1->FDB if found (else R15=1)       10093000
  99. * 4=> close file: R1->adr(FAB).                                         10094000
  100. DISKIO   ENTER                                                          10095000
  101.          USING FABD,3                                          @SC86295 10096000
  102.          SR    4,4           Signal no block assigned          @SC86295 10097000
  103.          BCT   0,DSKOPNO                                       @SC86295 10098000
  104. *                                                                       10099000
  105. * Open for input file whose name is at (R2), FDB at (R1)                10100000
  106.          BAL   9,DSKALC      Get FAB                           @SC86295 10101000
  107. DSKOP0   BAL   2,DSKLKP      Get FST, ADT ptrs                 @SC86295 10102000
  108.          BNZ   DSKER1        Not found                         @SC86295 10103000
  109.          BAL   14,DSKVALS                                      @SC86295 10104000
  110.          B     RTRN0                                           @SC86295 10105000
  111. *                                                                       10106000
  112. * Open for output file whose name is at (R2), FDB at (R1)               10107000
  113. DSKOPNO  BCT   0,DSKTEST                                       @SC86295 10108000
  114.          BAL   9,DSKALC      Get FAB                           @SC86295 10109000
  115.        FSERASE FSCB=(3)                                        @SC86295 10110000
  116.          B     RTRN0                                           @SC86295 10111000
  117. *                                                                       10112000
  118. * Test for existence of file whose name is at (R2)                      10113000
  119. DSKTEST  BCT   0,DSKCLOS                                       @SC86295 10114000
  120.          MVC   DSKSTNM,0(2)                                    @SC86295 10115000
  121.          LA    3,DSKSTT                                        @SC86295 10116000
  122.          B     DSKOP0        Test file                         @SC86295 10117000
  123. *                                                                       10118000
  124. * Close file whose ticket is at (R1), release block                     10119000
  125. DSKCLOS  DS    0H                                                       10120000
  126.          ICM   3,15,0(1)     Get FAB ptr, if any               @SC86295 10121000
  127.          BZ    RTRN0         None, ignore                      @SC86295 10122000
  128.          XC    0(4,1),0(1)   Yes, now clear ticket             @SC86295 10123000
  129.        FSCLOSE FSCB=(3)                                        @SC86295 10124000
  130.          LA    0,FABDWDS                                       @SC86295 10125000
  131.        DMSFRET DWORDS=(0),LOC=(1)                              @SC86295 10126000
  132.          B     RTRN0                                           @SC86295 10127000
  133. *                                                                       10128000
  134. * Return on error, release useless block, if any                        10129000
  135. DSKER1   LTR   1,4           Any block assigned?               @SC86295 10130000
  136.          BZ    RTRN1         No                                @SC86295 10131000
  137.          LA    0,FABDWDS     Yes, release it                   @SC86295 10132000
  138.        DMSFRET DWORDS=(0),LOC=(1)                              @SC86295 10133000
  139.          B     RTRN1         Flag error                        @SC86295 10134000
  140. *                                                                       10135000
  141. DSKALC   LR    5,1           Save FDB ptr                      @SC86295 10136000
  142.          MVC   DSKSTNM,0(2)                                    @SC86295 10137000
  143.          LA    0,FABDWDS                                       @SC86295 10138000
  144.        DMSFREE DWORDS=(0),ERR=DSKER1                           @SC86295 10139000
  145.          LR    3,1           New block ptr                     @SC86295 10140000
  146.          LR    4,1                                             @SC86295 10141000
  147.          L     1,4(13)                                         @SC86295 10142000
  148.          ST    3,20(1)       Return R0                         @SC86295 10143000
  149.          XC    0(8*FABDWDS,3),0(3)                             @SC86295 10144000
  150.          MVC   FDBD(FDBCOP),0(5) Copy user's FDB               @SC86295 10145000
  151.          MVC   FABFN(18),0(2)                                  @SC86295 10146000
  152.          OI    FDBFLGS,FDBEPL                                  @SC86295 10147000
  153.          MVI   FABANIT+3,1                                     @SC86295 10148000
  154.          BR    9                                               @SC86295 10149000
  155. *                                                                       10150000
  156. DSKLKP  DMSKEY NUCLEUS                                         @SC86295 10151000
  157.         GETFST DSKSTT        Call system routine for FST       @SC86295 10152000
  158.          LR    8,1           And FST ptr                       @SC86295 10153000
  159.          LTR   1,15          Save return code                  @SC86295 10154000
  160.         DMSKEY RESET                                           @SC86295 10155000
  161.          LTR   15,1          Test return code                  @SC86295 10156000
  162.          BR    2                                               @SC86295 10157000
  163. *                                                                       10158000
  164.          USING FSTSECT,8                                                10159000
  165. *                                                                       10160000
  166. DSKVALS  LA    0,FDBD        Ptr to FDB                        @SC86295 10161000
  167.          L     1,4(13)                                         @SC86295 10162000
  168.          ST    0,24(1)       Return ptr to caller              @SC86295 10163000
  169.          MVC   FDBRCF,FSTFV  Copy format                       @SC86295 10164000
  170.          MVC   FDBLRC,FSTIL+2 No, copy from FST                @SC86295 10165000
  171.          BR    14                                              @SC86295 10166000
  172. *                                                                       10167000
  173.          DROP  8                                                        10168000
  174. *                                                                       10169000
  175.          LOCALS ,                                              @SC86295 10170000
  176. DISKIO   EXIT                                                           10171000
  177.