home *** CD-ROM | disk | FTP | other *** search
/ Columbia Kermit / kermit.zip / ibm370 / ikmgup.asm < prev    next >
Assembly Source File  |  2020-01-01  |  26KB  |  327 lines
  1. *COPY                                                 GUPVAR            10000000
  2.          MACRO                                                          10001000
  3.          GUPVAR                                                         10002000
  4. *          Specific variables                                           10003000
  5. FNAME    DS    CL130         Buffer for reading                         10004000
  6.          MEND                                                           10005000
  7. *COPY                                                 GUPSPC            10006000
  8.          MACRO                                                          10007000
  9.          GUPSPC                                                         10008000
  10.          GBLC  &STORDS                                         @SC89268 10009000
  11.          PRINT GEN                                                      10010000
  12. *          Specific preliminaries                                       10011000
  13. &STORDS  SETC  'KSTORG'      Storage DSECT for Kermit globals  @SC89268 10012000
  14. *                                                                       10013000
  15. LFID     EQU   22            Filespec length                            10014000
  16. STKDWDS  EQU   511           Requested stack length                     10015000
  17. KWRKBASE EQU   11            Base register for work area       @SC89268 10016000
  18. KSUBBASE EQU   12            Base register for CSECT           @SC89268 10017000
  19.          MEND                                                           10018000
  20. *COPY                                                 GUPFIN            10019000
  21.          MACRO                                                          10020000
  22.          GUPFIN                                                         10021000
  23.          MEND                                                           10022000
  24. *COPY                                                 GUPNIT            10023000
  25.          MACRO                                                          10024000
  26.          GUPNIT                                                         10025000
  27. *        MUSIC user interface                                           10026000
  28. *                                                                       10027000
  29.          LA    2,SRCNAM                  Fill the file names with       10028000
  30.          LA    3,3*LFID+3                blanks...                      10029000
  31.          SLR   4,4                                                      10030000
  32.          LR    5,4                                                      10031000
  33.          ICM   5,8,=X'40'                                               10032000
  34.          MVCL  2,4                                                      10033000
  35.          L     1,0(1)                                                   10034000
  36.          LH    2,0(1)                    Get length                     10035000
  37.          LA    5,2(1)                    Ptr to parm string             10036000
  38.          ST    5,STRADR                                                 10037000
  39.          ST    2,STRLEN                                                 10038000
  40.          WTEXT 'MUSIC-GUPI Version 1.3'                                 10039000
  41.          CALL  WORD,((5),STRLEN,NUMWRDS,WRDPOS,WRDLEN,PARSCHAR),VL      10040000
  42.          L     2,NUMWRDS      Any parms ???                             10041000
  43.          PTEXT 'Required positional parameters not specified',         +10042000
  44.                AREG=8,LREG=9                                            10043000
  45.          CH    2,=H'3'        Must be at least 3 !                      10044000
  46.          BL    PRSERR                                                   10045000
  47.          SLR   3,3                                                      10046000
  48. *                                                                       10047000
  49. FIXEM    L     1,WRDPOS(3)    Get word index                            10048000
  50.          A     1,STRADR       Add base address                          10049000
  51.          BCTR  1,0            Fixup Fortran type index                  10050000
  52.          ST    1,WRDPOS(3)    Save it back                              10051000
  53.          L     1,WRDLEN(3)    Get length                                10052000
  54.          BCTR  1,0            Convert to machine length                 10053000
  55.          ST    1,WRDLEN(3)    Save it back                              10054000
  56.          LA    3,4(3)         Next entry                                10055000
  57.          BCT   2,FIXEM        Until all done                            10056000
  58. *                                                                       10057000
  59.          PTEXT 'Filename too long. Max length 22.',AREG=8,LREG=9        10058000
  60.          LA    2,3            Three names to process                    10059000
  61.          SLR   3,3            Array index                               10060000
  62.          LA    4,SRCNAM                                                 10061000
  63. GETNAM   L     1,WRDLEN(3)    Get length of 1st parm.                   10062000
  64.          CH    1,=H'21'       Maximum name length...                    10063000
  65.          BH    PRSERR                                                   10064000
  66.          L     5,WRDPOS(3)    Get address into command line             10065000
  67.          EX    1,NAMMV        Moveit !                                  10066000
  68.          LA    4,LFID(4)      Next name                                 10067000
  69.          LA    3,4(3)         Next entries please                       10068000
  70.          BCT   2,GETNAM       Until all done                            10069000
  71. *                                                                       10070000
  72.          L     2,NUMWRDS      Get number of parms                       10071000
  73.          LA    6,XXCOR+XX8    Default flags                             10072000
  74.          PTEXT 'Invalid parameter',AREG=8,LREG=9 In case of error       10073000
  75.          SH    2,=H'3'        Skip over position parms                  10074000
  76.          BZ    OPTZ                                                     10075000
  77.          LA    3,12           Start at 4th element                      10076000
  78. OPTPARS  SR    0,0                                                      10077000
  79.          L     1,WRDLEN(3)    Get word length                           10078000
  80.          L     4,WRDPOS(3)    Get word address                          10079000
  81. OPTYES   CH    1,=H'8'        Room for option ?                         10080000
  82.          BNE   OPTNO                                                    10081000
  83.          CLC   =C'MARK(',0(4)                                           10082000
  84.          BNE   PRSERR         Check flags                               10083000
  85.          CLI   8(4),C')'      Need ending paren                         10084000
  86.          BNE   PRSERR                                                   10085000
  87.          MVC   MRKD(3),5(4)   Copy in case NOSEQ8                       10086000
  88.          B     OPTNEXT                                                  10087000
  89. OPTNO    CH    1,=H'5'        Must be 6 for "NO" parms.                 10088000
  90.          BNE   OPTCK                                                    10089000
  91.          CLC   =C'NO',0(4)    Is it a "NO" ?                            10090000
  92.          BNE   PRSERR                                                   10091000
  93.          LA    4,2(4)         Cut off the "NO"                          10092000
  94.          SH    1,=H'2'                                                  10093000
  95.          BCTR  0,0            Mask: ones                                10094000
  96. OPTCK    CH    1,=H'3'        Parm must be of length 4                  10095000
  97.          BNE   PRSERR                                                   10096000
  98.          LA    5,XX8          Test for SEQ8                             10097000
  99.          CLC   =C'SEQ8',0(4)                                            10098000
  100.          BE    OPTOK                                                    10099000
  101.          LA    5,XXCOR        Test for STOR                             10100000
  102.          CLC   =C'STOR',0(4)                                            10101000
  103.          BNE   PRSERR                                                   10102000
  104. OPTOK    OR    6,5            Turn on the flag                          10103000
  105.          NR    5,0                                                      10104000
  106.          XR    6,5            Turn it off if "NO"                       10105000
  107. OPTNEXT  LA    3,4(3)         Next array element                        10106000
  108.          BCT   2,OPTPARS                                                10107000
  109. *                                                                       10108000
  110. OPTZ     STC   6,FLG         Save current flags                         10109000
  111.          B     OPN                                                      10110000
  112. *                                                                       10111000
  113. FILERR   LA    4,FNAME       Buffer to use                              10112000
  114.          LR    5,1                                                      10113000
  115.          MVCL  4,0           Copy message                               10114000
  116.          LA    3,LFID        Length of a name field                     10115000
  117.          LR    5,3                                                      10116000
  118.          MVCL  4,2           Copy name                                  10117000
  119.          LA    1,FNAME       Start of buffer again                      10118000
  120.          SR    4,1                                                      10119000
  121.          WTEXT (1),(4)                                                  10120000
  122.          B     ERREX                                                    10121000
  123. *                                                                       10122000
  124. OPNERR   LA    1,L'OPNEM                                                10123000
  125.          BAL   0,FILERR                                                 10124000
  126. OPNEM    DC    C'File not found: '                                      10125000
  127. DSKERR   LA    2,8(1)                                                   10126000
  128.          LA    1,L'DSKEM                                                10127000
  129.          BAL   0,FILERR                                                 10128000
  130. DSKEM    DC    C'Disk error on file '                                   10129000
  131. *  Error while parsing                                                  10130000
  132. PRSERR   WTEXT (8),(9)                                                  10131000
  133.          WTEXT ' '           Print blank line                           10132000
  134.          WTEXT 'Usage: GUPI input-dsn update-dsn output-dsn  [Options]' 10133000
  135.          WTEXT ' '                                                      10134000
  136.          WTEXT '    Options:    STOR/NOSTOR  SEQ8/NOSEQ8  MARK(xxx)'    10135000
  137.          B     ERREX                                                    10136000
  138. *                                                                       10137000
  139. NAMMV    MVC   0(0,4),0(5)                                              10138000
  140. *                                                                       10139000
  141. STRADR   DS    F             Address of String to be parsed             10140000
  142. STRLEN   DS    F             Length of command line string              10141000
  143. NUMWRDS  DS    F             Number of words parsed                     10142000
  144. WRDPOS   DS    20F           Word Position array                        10143000
  145. WRDLEN   DS    20F           Word Length array                          10144000
  146. PARSCHAR DC    C' '          Parse using blank delimiter                10145000
  147.          MEND                                                           10146000
  148. *COPY                                                 GUPSUB            10147000
  149.          MACRO                                                          10148000
  150.          GUPSUB                                                         10149000
  151.          TITLE 'DISKIO Routine - performs disk I/O functions'           10150000
  152. * Function selected on entry by R0:                                     10151000
  153. * 1=> open (in): R1->pattern FDB, R2->name.  Returns R0->FAB, R1->FDB   10152000
  154. * 2=> open (out): (same, but no complete FDB if new file)               10153000
  155. * 4=> close file: R1->adr(FAB).                                         10154000
  156. * 9=> read: R1->FAB.  Returns R15=12 if EOF, 0 if ok; R0=# data         10155000
  157. * 10=> write: R1->FAB.  Returns R15=13 if disk full, 0 if ok.           10156000
  158. DISKIO   ENTER                                                          10157000
  159.          USING FABD,3                                                   10158000
  160.          SR    4,4           Signal no block assigned                   10159000
  161.          BCT   0,DSKOPNO                                                10160000
  162. *                                                                       10161000
  163. * Open for input file whose name is at (R2), FDB at (R1)                10162000
  164.          BAL   9,DSKALC      Get FAB                                    10163000
  165.          MVC   FABCOMM(8),=CL8'Open R'      I/O Operation               10164000
  166.          MFSET DSKST,OPEN,R=(OKOLD,RDOK)                                10165000
  167.          MFREQ DSKST                        Try to open file            10166000
  168.          MVC   FABRC(1),ZRC                                             10167000
  169.          CLI   ZRC,0                        Errors ???                  10168000
  170.          BNZ   DSKER1                                                   10169000
  171.          BAL   14,DSKVALS          Go copy info to FDBD                 10170000
  172.          MVC   FABUNIT(1),ZLU      Save file unit number                10171000
  173.          B     RTRN0                                                    10172000
  174. *                                                                       10173000
  175. * Open for output file whose name is at (R2), FDB at (R1)               10174000
  176. DSKOPNO  BCT   0,DSKTEST                                                10175000
  177.          BAL   9,DSKALC            Get FAB                              10176000
  178.          MVC   FABCOMM(8),=CL8'Open W'  I/O Operation                   10177000
  179.          MFSET DSKST,OPEN,R=(OKOLD,RDOK)                                10178000
  180.          MFREQ DSKST                                                    10179000
  181.          MVC   FABRC(1),ZRC                                             10180000
  182.          CLI   ZRC,30              Error deleting file ?                10181000
  183.          BE    DSKOP2              Yup, ignore it.                      10182000
  184.          MFSET DSKST,CLOSE,R=(DEL)                                      10183000
  185.          MFREQ DSKST               Delete the file...                   10184000
  186.          MVC   FABRC(1),ZRC                                             10185000
  187. DSKOP2   MVC   ZINFIN(LZINFDEF),ZINFDEF  Get default file attrs         10186000
  188.          SR    0,0                                                      10187000
  189.          ICM   0,3,FDBLRC    Insert logical record length               10188000
  190.          STH   0,MFIRSIZ                                                10189000
  191.          ST    0,FABLRTR     Set output buffer limit                    10190000
  192.          CLI   FDBRCF,C'F'   Fixed format ?                             10191000
  193.          BNE   *+8                                                      10192000
  194.          MVI   MFIRFM,X'02'  Yup, set to Fixed Compressed               10193000
  195.          MFSET DSKST,OPEN,R=(OKOLD,OKNEW,WROK)                          10194000
  196.          MFREQ DSKST          Do the I/O                                10195000
  197.          MVC   FABRC(1),ZRC   Save return code                          10196000
  198.          CLI   ZRC,0          Any errors ?                              10197000
  199.          BNZ   DSKER1                                                   10198000
  200.          MVC   ZINFOUT(LZINFDEF),ZINFIN  Copy creation file parms       10199000
  201.          BAL   14,DSKVALS          Copy parms to FDBD                   10200000
  202.          MVC   FABUNIT(1),ZLU      Save the Unit number                 10201000
  203.          B     RTRN0                                                    10202000
  204. *                                                                       10203000
  205. * Test for existence of file whose name is at (R2)                      10204000
  206. DSKTEST  BCT   0,DSKCLOS                                                10205000
  207.          B     RTRN1                                                    10206000
  208. *                                                                       10207000
  209. * Close file whose ticket is at (R1), release block                     10208000
  210. DSKCLOS  BCT   0,DSKRED                                                 10209000
  211.          ICM   3,15,0(1)           Get FAB ptr, if any                  10210000
  212.          BZ    RTRN0               None, ignore                         10211000
  213.          MVC   FABCOMM(8),=CL8'Close'  I/O Operation                    10212000
  214.          XC    0(4,1),0(1)         Yes, now clear ticket                10213000
  215.          MVC   ZLU(1),FABUNIT      Copy file Unit number                10214000
  216.          LR    6,3                 Save the address of the FAB          10215000
  217.          MFSET DSKST,CLOSE,R=(RLSE)                                     10216000
  218.          MFREQ DSKST               Close the file                       10217000
  219.          MVC   FABRC(1),ZRC        Save return code                     10218000
  220.          LR    1,6                 Get FAB address                      10219000
  221.          LA    0,FABDWDS                                                10220000
  222.        DMSFRET DWORDS=(0),LOC=(1)  Free up the FAB                      10221000
  223.          B     RTRN0                                                    10222000
  224. *                                                                       10223000
  225. * Read from file   R1->FAB                                              10224000
  226. DSKRED   SH    0,=H'4'                                                  10225000
  227.          BCT   0,DSKWRT                                                 10226000
  228.          LR    3,1                 Point to FAB                         10227000
  229.          MVC   FABCOMM(8),=CL8'Read'  I/O Operation                     10228000
  230.          L     0,FDBBUFF           Get buffer address                   10229000
  231.          ST    0,MFRBUF                                                 10230000
  232.          L     0,FDBBSIZ           Get I/O Length                       10231000
  233.          ST    0,MFRLEN                                                 10232000
  234.          MVC   ZLU(1),FABUNIT      Get unit number                      10233000
  235.          MFSET DSKST,IO,R=(RD)                                          10234000
  236.          MFREQ DSKST               Do the I/O                           10235000
  237.          MVC   FABRC(1),ZRC        Save the return code                 10236000
  238.          L     0,MFARSZ            Get length read from Save file.      10237000
  239.          L     1,4(13)             Return length of read operation      10238000
  240.          ST    0,20(1)             in R0                                10239000
  241.          CLI   ZRC,0               Any errors ???                       10240000
  242.          BE    RTRN0                                                    10241000
  243.          LA    15,12               End of file.                         10242000
  244.          CLI   ZRC,1               End of file maybe ???                10243000
  245.          BE    RTRN                                                     10244000
  246.          B     RTRN1               Well, just another error...          10245000
  247. *                                                                       10246000
  248. * Write to file    R1->FAB                                              10247000
  249. DSKWRT   LR    3,1                 Point to FAB                         10248000
  250.          MVC   FABCOMM(8),=CL8'Write'  I/O Operation                    10249000
  251.          L     0,FDBBUFF           Get buffer address                   10250000
  252.          ST    0,MFRBUF                                                 10251000
  253.          L     0,FDBBSIZ           Get I/O Length                       10252000
  254.          ST    0,MFRLEN                                                 10253000
  255.          MVC   ZLU(1),FABUNIT      Get unit number                      10254000
  256.          MFSET DSKST,IO,R=(WR)                                          10255000
  257.          MFREQ DSKST               Do the I/O                           10256000
  258.          MVC   FABRC(1),ZRC        Save the return code                 10257000
  259.          CLI   ZRC,0               Any errors ???                       10258000
  260.          BE    RTRN0                                                    10259000
  261.          LA    15,13               Disk full error code.                10260000
  262.          CLI   ZRC,40              Well, is it full ?                   10261000
  263.          BL    RTRN1                                                    10262000
  264.          CLI   ZRC,42              Three possible return codes          10263000
  265.          BH    RTRN1                                                    10264000
  266.          B     RTRN                                                     10265000
  267. *                                                                       10266000
  268. * Return on error, release useless block, if any                        10267000
  269. DSKER1   LTR   1,4           Any block assigned?                        10268000
  270.          BZ    RTRN1         No                                         10269000
  271.          LA    0,FABDWDS     Yes, release it                            10270000
  272.        DMSFRET DWORDS=(0),LOC=(1)                                       10271000
  273.          B     RTRN1         Flag error                                 10272000
  274. * Allocate FAB and copy default FDB                                     10273000
  275. DSKALC   LR    5,1           Save FDB ptr                               10274000
  276.          MVC   MFNAME,0(2)                                              10275000
  277.          LA    0,FABDWDS                                                10276000
  278.        DMSFREE DWORDS=(0),ERR=DSKER1                                    10277000
  279.          LR    3,1           New block ptr                              10278000
  280.          LR    4,1                                                      10279000
  281.          L     1,4(13)                                                  10280000
  282.          ST    3,20(1)       Return R0                                  10281000
  283.          XC    0(8*FABDWDS,3),0(3)                                      10282000
  284.          MVC   FDBD(FDBCOP),0(5) Copy user's FDB                        10283000
  285.          MVC   FABFN(LFID),0(2)  Copy filename to FAB                   10284000
  286.          BR    9                                                        10285000
  287. *                                                                       10286000
  288. DSKVALS  LA    0,FDBD        Ptr to FDB                                 10287000
  289.          L     1,4(13)                                                  10288000
  290.          ST    0,24(1)       Return ptr to caller                       10289000
  291. ***  GET FILE'S DATE...                                                 10290000
  292.          L     1,MFOPRM      Set file size in KBytes                    10291000
  293.          ST    1,FDBSIZE                                                10292000
  294.          SLR   1,1           Set record format character                10293000
  295.          IC    1,MFORFM      Ignore 'Compressed' modes.                 10294000
  296.          SLL   1,1                                                      10295000
  297.          LA    0,RFMTAB                                                 10296000
  298.          AR    1,0                                                      10297000
  299.          MVC   FDBRCF,0(1)                                              10298000
  300.          MVC   FDBLRC(2),MFORSIZ  Get logical record length             10299000
  301.          BR    14                                                       10300000
  302. *                                                                       10301000
  303. RFMTAB   DC    C'U F FCV VC'      Record Format Table                   10302000
  304. *   MFIO Basic Caller's Request Block                                   10303000
  305. DSKST    MFARG 0,RLAB=ZRC,ULAB=ZLU                                      10304000
  306.          MFARG NAME=MFNAME,INFIN=ZINFIN,INFOUT=ZINFOUT,ARG=ZARG         10305000
  307.          MFARG PHYS=ZPHYS                                               10306000
  308.          MFGEN ,                                                        10307000
  309. *   All other MFIO Control Blocks                                       10308000
  310. MFNAME   MFVAR NAME,PRE=MF                                              10309000
  311. ZINFIN   MFVAR INFIN,PRE=MFI                                            10310000
  312. ZINFOUT  MFVAR INFOUT,PRE=MFO                                           10311000
  313. ZARG     MFVAR ARG,PRE=MF                                               10312000
  314. ZPHYS    MFVAR PHYS,PRE=MF                                              10313000
  315. *                                                                       10314000
  316. * Default File Creation Values...                                       10315000
  317. ZINFDEF  DC    F'32',F'-100',F'-1',H'80',X'0400',X'0000C0C0'            10316000
  318. LZINFDEF EQU   *-ZINFDEF                                                10317000
  319.          LOCALS ,                                                       10318000
  320.          EXIT                                                           10319000
  321.          PUSH  PRINT                                                    10320000
  322.          PRINT NOGEN                                                    10321000
  323.          MUSVC                                                          10322000
  324.          REGS                                                           10323000
  325.          POP   PRINT                                                    10324000
  326.          MEND                                                           10325000
  327.