*COPY                                                 GUPVAR            10000000
         MACRO                                                          10001000
         GUPVAR                                                         10002000
*          Specific variables                                           10003000
FNAME    DS    CL130         Buffer for reading                         10004000
         MEND                                                           10005000
*COPY                                                 GUPSPC            10006000
         MACRO                                                          10007000
         GUPSPC                                                         10008000
         GBLC  &STORDS                                         @SC89268 10009000
         PRINT GEN                                                      10010000
*          Specific preliminaries                                       10011000
&STORDS  SETC  'KSTORG'      Storage DSECT for Kermit globals  @SC89268 10012000
*                                                                       10013000
LFID     EQU   22            Filespec length                            10014000
STKDWDS  EQU   511           Requested stack length                     10015000
KWRKBASE EQU   11            Base register for work area       @SC89268 10016000
KSUBBASE EQU   12            Base register for CSECT           @SC89268 10017000
         MEND                                                           10018000
*COPY                                                 GUPFIN            10019000
         MACRO                                                          10020000
         GUPFIN                                                         10021000
         MEND                                                           10022000
*COPY                                                 GUPNIT            10023000
         MACRO                                                          10024000
         GUPNIT                                                         10025000
*        MUSIC user interface                                           10026000
*                                                                       10027000
         LA    2,SRCNAM                  Fill the file names with       10028000
         LA    3,3*LFID+3                blanks...                      10029000
         SLR   4,4                                                      10030000
         LR    5,4                                                      10031000
         ICM   5,8,=X'40'                                               10032000
         MVCL  2,4                                                      10033000
         L     1,0(1)                                                   10034000
         LH    2,0(1)                    Get length                     10035000
         LA    5,2(1)                    Ptr to parm string             10036000
         ST    5,STRADR                                                 10037000
         ST    2,STRLEN                                                 10038000
         WTEXT 'MUSIC-GUPI Version 1.3'                                 10039000
         CALL  WORD,((5),STRLEN,NUMWRDS,WRDPOS,WRDLEN,PARSCHAR),VL      10040000
         L     2,NUMWRDS      Any parms ???                             10041000
         PTEXT 'Required positional parameters not specified',         +10042000
               AREG=8,LREG=9                                            10043000
         CH    2,=H'3'        Must be at least 3 !                      10044000
         BL    PRSERR                                                   10045000
         SLR   3,3                                                      10046000
*                                                                       10047000
FIXEM    L     1,WRDPOS(3)    Get word index                            10048000
         A     1,STRADR       Add base address                          10049000
         BCTR  1,0            Fixup Fortran type index                  10050000
         ST    1,WRDPOS(3)    Save it back                              10051000
         L     1,WRDLEN(3)    Get length                                10052000
         BCTR  1,0            Convert to machine length                 10053000
         ST    1,WRDLEN(3)    Save it back                              10054000
         LA    3,4(3)         Next entry                                10055000
         BCT   2,FIXEM        Until all done                            10056000
*                                                                       10057000
         PTEXT 'Filename too long. Max length 22.',AREG=8,LREG=9        10058000
         LA    2,3            Three names to process                    10059000
         SLR   3,3            Array index                               10060000
         LA    4,SRCNAM                                                 10061000
GETNAM   L     1,WRDLEN(3)    Get length of 1st parm.                   10062000
         CH    1,=H'21'       Maximum name length...                    10063000
         BH    PRSERR                                                   10064000
         L     5,WRDPOS(3)    Get address into command line             10065000
         EX    1,NAMMV        Moveit !                                  10066000
         LA    4,LFID(4)      Next name                                 10067000
         LA    3,4(3)         Next entries please                       10068000
         BCT   2,GETNAM       Until all done                            10069000
*                                                                       10070000
         L     2,NUMWRDS      Get number of parms                       10071000
         LA    6,XXCOR+XX8    Default flags                             10072000
         PTEXT 'Invalid parameter',AREG=8,LREG=9 In case of error       10073000
         SH    2,=H'3'        Skip over position parms                  10074000
         BZ    OPTZ                                                     10075000
         LA    3,12           Start at 4th element                      10076000
OPTPARS  SR    0,0                                                      10077000
         L     1,WRDLEN(3)    Get word length                           10078000
         L     4,WRDPOS(3)    Get word address                          10079000
OPTYES   CH    1,=H'8'        Room for option ?                         10080000
         BNE   OPTNO                                                    10081000
         CLC   =C'MARK(',0(4)                                           10082000
         BNE   PRSERR         Check flags                               10083000
         CLI   8(4),C')'      Need ending paren                         10084000
         BNE   PRSERR                                                   10085000
         MVC   MRKD(3),5(4)   Copy in case NOSEQ8                       10086000
         B     OPTNEXT                                                  10087000
OPTNO    CH    1,=H'5'        Must be 6 for "NO" parms.                 10088000
         BNE   OPTCK                                                    10089000
         CLC   =C'NO',0(4)    Is it a "NO" ?                            10090000
         BNE   PRSERR                                                   10091000
         LA    4,2(4)         Cut off the "NO"                          10092000
         SH    1,=H'2'                                                  10093000
         BCTR  0,0            Mask: ones                                10094000
OPTCK    CH    1,=H'3'        Parm must be of length 4                  10095000
         BNE   PRSERR                                                   10096000
         LA    5,XX8          Test for SEQ8                             10097000
         CLC   =C'SEQ8',0(4)                                            10098000
         BE    OPTOK                                                    10099000
         LA    5,XXCOR        Test for STOR                             10100000
         CLC   =C'STOR',0(4)                                            10101000
         BNE   PRSERR                                                   10102000
OPTOK    OR    6,5            Turn on the flag                          10103000
         NR    5,0                                                      10104000
         XR    6,5            Turn it off if "NO"                       10105000
OPTNEXT  LA    3,4(3)         Next array element                        10106000
         BCT   2,OPTPARS                                                10107000
*                                                                       10108000
OPTZ     STC   6,FLG         Save current flags                         10109000
         B     OPN                                                      10110000
*                                                                       10111000
FILERR   LA    4,FNAME       Buffer to use                              10112000
         LR    5,1                                                      10113000
         MVCL  4,0           Copy message                               10114000
         LA    3,LFID        Length of a name field                     10115000
         LR    5,3                                                      10116000
         MVCL  4,2           Copy name                                  10117000
         LA    1,FNAME       Start of buffer again                      10118000
         SR    4,1                                                      10119000
         WTEXT (1),(4)                                                  10120000
         B     ERREX                                                    10121000
*                                                                       10122000
OPNERR   LA    1,L'OPNEM                                                10123000
         BAL   0,FILERR                                                 10124000
OPNEM    DC    C'File not found: '                                      10125000
DSKERR   LA    2,8(1)                                                   10126000
         LA    1,L'DSKEM                                                10127000
         BAL   0,FILERR                                                 10128000
DSKEM    DC    C'Disk error on file '                                   10129000
*  Error while parsing                                                  10130000
PRSERR   WTEXT (8),(9)                                                  10131000
         WTEXT ' '           Print blank line                           10132000
         WTEXT 'Usage: GUPI input-dsn update-dsn output-dsn  [Options]' 10133000
         WTEXT ' '                                                      10134000
         WTEXT '    Options:    STOR/NOSTOR  SEQ8/NOSEQ8  MARK(xxx)'    10135000
         B     ERREX                                                    10136000
*                                                                       10137000
NAMMV    MVC   0(0,4),0(5)                                              10138000
*                                                                       10139000
STRADR   DS    F             Address of String to be parsed             10140000
STRLEN   DS    F             Length of command line string              10141000
NUMWRDS  DS    F             Number of words parsed                     10142000
WRDPOS   DS    20F           Word Position array                        10143000
WRDLEN   DS    20F           Word Length array                          10144000
PARSCHAR DC    C' '          Parse using blank delimiter                10145000
         MEND                                                           10146000
*COPY                                                 GUPSUB            10147000
         MACRO                                                          10148000
         GUPSUB                                                         10149000
         TITLE 'DISKIO Routine - performs disk I/O functions'           10150000
* Function selected on entry by R0:                                     10151000
* 1=> open (in): R1->pattern FDB, R2->name.  Returns R0->FAB, R1->FDB   10152000
* 2=> open (out): (same, but no complete FDB if new file)               10153000
* 4=> close file: R1->adr(FAB).                                         10154000
* 9=> read: R1->FAB.  Returns R15=12 if EOF, 0 if ok; R0=# data         10155000
* 10=> write: R1->FAB.  Returns R15=13 if disk full, 0 if ok.           10156000
DISKIO   ENTER                                                          10157000
         USING FABD,3                                                   10158000
         SR    4,4           Signal no block assigned                   10159000
         BCT   0,DSKOPNO                                                10160000
*                                                                       10161000
* Open for input file whose name is at (R2), FDB at (R1)                10162000
         BAL   9,DSKALC      Get FAB                                    10163000
         MVC   FABCOMM(8),=CL8'Open R'      I/O Operation               10164000
         MFSET DSKST,OPEN,R=(OKOLD,RDOK)                                10165000
         MFREQ DSKST                        Try to open file            10166000
         MVC   FABRC(1),ZRC                                             10167000
         CLI   ZRC,0                        Errors ???                  10168000
         BNZ   DSKER1                                                   10169000
         BAL   14,DSKVALS          Go copy info to FDBD                 10170000
         MVC   FABUNIT(1),ZLU      Save file unit number                10171000
         B     RTRN0                                                    10172000
*                                                                       10173000
* Open for output file whose name is at (R2), FDB at (R1)               10174000
DSKOPNO  BCT   0,DSKTEST                                                10175000
         BAL   9,DSKALC            Get FAB                              10176000
         MVC   FABCOMM(8),=CL8'Open W'  I/O Operation                   10177000
         MFSET DSKST,OPEN,R=(OKOLD,RDOK)                                10178000
         MFREQ DSKST                                                    10179000
         MVC   FABRC(1),ZRC                                             10180000
         CLI   ZRC,30              Error deleting file ?                10181000
         BE    DSKOP2              Yup, ignore it.                      10182000
         MFSET DSKST,CLOSE,R=(DEL)                                      10183000
         MFREQ DSKST               Delete the file...                   10184000
         MVC   FABRC(1),ZRC                                             10185000
DSKOP2   MVC   ZINFIN(LZINFDEF),ZINFDEF  Get default file attrs         10186000
         SR    0,0                                                      10187000
         ICM   0,3,FDBLRC    Insert logical record length               10188000
         STH   0,MFIRSIZ                                                10189000
         ST    0,FABLRTR     Set output buffer limit                    10190000
         CLI   FDBRCF,C'F'   Fixed format ?                             10191000
         BNE   *+8                                                      10192000
         MVI   MFIRFM,X'02'  Yup, set to Fixed Compressed               10193000
         MFSET DSKST,OPEN,R=(OKOLD,OKNEW,WROK)                          10194000
         MFREQ DSKST          Do the I/O                                10195000
         MVC   FABRC(1),ZRC   Save return code                          10196000
         CLI   ZRC,0          Any errors ?                              10197000
         BNZ   DSKER1                                                   10198000
         MVC   ZINFOUT(LZINFDEF),ZINFIN  Copy creation file parms       10199000
         BAL   14,DSKVALS          Copy parms to FDBD                   10200000
         MVC   FABUNIT(1),ZLU      Save the Unit number                 10201000
         B     RTRN0                                                    10202000
*                                                                       10203000
* Test for existence of file whose name is at (R2)                      10204000
DSKTEST  BCT   0,DSKCLOS                                                10205000
         B     RTRN1                                                    10206000
*                                                                       10207000
* Close file whose ticket is at (R1), release block                     10208000
DSKCLOS  BCT   0,DSKRED                                                 10209000
         ICM   3,15,0(1)           Get FAB ptr, if any                  10210000
         BZ    RTRN0               None, ignore                         10211000
         MVC   FABCOMM(8),=CL8'Close'  I/O Operation                    10212000
         XC    0(4,1),0(1)         Yes, now clear ticket                10213000
         MVC   ZLU(1),FABUNIT      Copy file Unit number                10214000
         LR    6,3                 Save the address of the FAB          10215000
         MFSET DSKST,CLOSE,R=(RLSE)                                     10216000
         MFREQ DSKST               Close the file                       10217000
         MVC   FABRC(1),ZRC        Save return code                     10218000
         LR    1,6                 Get FAB address                      10219000
         LA    0,FABDWDS                                                10220000
       DMSFRET DWORDS=(0),LOC=(1)  Free up the FAB                      10221000
         B     RTRN0                                                    10222000
*                                                                       10223000
* Read from file   R1->FAB                                              10224000
DSKRED   SH    0,=H'4'                                                  10225000
         BCT   0,DSKWRT                                                 10226000
         LR    3,1                 Point to FAB                         10227000
         MVC   FABCOMM(8),=CL8'Read'  I/O Operation                     10228000
         L     0,FDBBUFF           Get buffer address                   10229000
         ST    0,MFRBUF                                                 10230000
         L     0,FDBBSIZ           Get I/O Length                       10231000
         ST    0,MFRLEN                                                 10232000
         MVC   ZLU(1),FABUNIT      Get unit number                      10233000
         MFSET DSKST,IO,R=(RD)                                          10234000
         MFREQ DSKST               Do the I/O                           10235000
         MVC   FABRC(1),ZRC        Save the return code                 10236000
         L     0,MFARSZ            Get length read from Save file.      10237000
         L     1,4(13)             Return length of read operation      10238000
         ST    0,20(1)             in R0                                10239000
         CLI   ZRC,0               Any errors ???                       10240000
         BE    RTRN0                                                    10241000
         LA    15,12               End of file.                         10242000
         CLI   ZRC,1               End of file maybe ???                10243000
         BE    RTRN                                                     10244000
         B     RTRN1               Well, just another error...          10245000
*                                                                       10246000
* Write to file    R1->FAB                                              10247000
DSKWRT   LR    3,1                 Point to FAB                         10248000
         MVC   FABCOMM(8),=CL8'Write'  I/O Operation                    10249000
         L     0,FDBBUFF           Get buffer address                   10250000
         ST    0,MFRBUF                                                 10251000
         L     0,FDBBSIZ           Get I/O Length                       10252000
         ST    0,MFRLEN                                                 10253000
         MVC   ZLU(1),FABUNIT      Get unit number                      10254000
         MFSET DSKST,IO,R=(WR)                                          10255000
         MFREQ DSKST               Do the I/O                           10256000
         MVC   FABRC(1),ZRC        Save the return code                 10257000
         CLI   ZRC,0               Any errors ???                       10258000
         BE    RTRN0                                                    10259000
         LA    15,13               Disk full error code.                10260000
         CLI   ZRC,40              Well, is it full ?                   10261000
         BL    RTRN1                                                    10262000
         CLI   ZRC,42              Three possible return codes          10263000
         BH    RTRN1                                                    10264000
         B     RTRN                                                     10265000
*                                                                       10266000
* Return on error, release useless block, if any                        10267000
DSKER1   LTR   1,4           Any block assigned?                        10268000
         BZ    RTRN1         No                                         10269000
         LA    0,FABDWDS     Yes, release it                            10270000
       DMSFRET DWORDS=(0),LOC=(1)                                       10271000
         B     RTRN1         Flag error                                 10272000
* Allocate FAB and copy default FDB                                     10273000
DSKALC   LR    5,1           Save FDB ptr                               10274000
         MVC   MFNAME,0(2)                                              10275000
         LA    0,FABDWDS                                                10276000
       DMSFREE DWORDS=(0),ERR=DSKER1                                    10277000
         LR    3,1           New block ptr                              10278000
         LR    4,1                                                      10279000
         L     1,4(13)                                                  10280000
         ST    3,20(1)       Return R0                                  10281000
         XC    0(8*FABDWDS,3),0(3)                                      10282000
         MVC   FDBD(FDBCOP),0(5) Copy user's FDB                        10283000
         MVC   FABFN(LFID),0(2)  Copy filename to FAB                   10284000
         BR    9                                                        10285000
*                                                                       10286000
DSKVALS  LA    0,FDBD        Ptr to FDB                                 10287000
         L     1,4(13)                                                  10288000
         ST    0,24(1)       Return ptr to caller                       10289000
***  GET FILE'S DATE...                                                 10290000
         L     1,MFOPRM      Set file size in KBytes                    10291000
         ST    1,FDBSIZE                                                10292000
         SLR   1,1           Set record format character                10293000
         IC    1,MFORFM      Ignore 'Compressed' modes.                 10294000
         SLL   1,1                                                      10295000
         LA    0,RFMTAB                                                 10296000
         AR    1,0                                                      10297000
         MVC   FDBRCF,0(1)                                              10298000
         MVC   FDBLRC(2),MFORSIZ  Get logical record length             10299000
         BR    14                                                       10300000
*                                                                       10301000
RFMTAB   DC    C'U F FCV VC'      Record Format Table                   10302000
*   MFIO Basic Caller's Request Block                                   10303000
DSKST    MFARG 0,RLAB=ZRC,ULAB=ZLU                                      10304000
         MFARG NAME=MFNAME,INFIN=ZINFIN,INFOUT=ZINFOUT,ARG=ZARG         10305000
         MFARG PHYS=ZPHYS                                               10306000
         MFGEN ,                                                        10307000
*   All other MFIO Control Blocks                                       10308000
MFNAME   MFVAR NAME,PRE=MF                                              10309000
ZINFIN   MFVAR INFIN,PRE=MFI                                            10310000
ZINFOUT  MFVAR INFOUT,PRE=MFO                                           10311000
ZARG     MFVAR ARG,PRE=MF                                               10312000
ZPHYS    MFVAR PHYS,PRE=MF                                              10313000
*                                                                       10314000
* Default File Creation Values...                                       10315000
ZINFDEF  DC    F'32',F'-100',F'-1',H'80',X'0400',X'0000C0C0'            10316000
LZINFDEF EQU   *-ZINFDEF                                                10317000
         LOCALS ,                                                       10318000
         EXIT                                                           10319000
         PUSH  PRINT                                                    10320000
         PRINT NOGEN                                                    10321000
         MUSVC                                                          10322000
         REGS                                                           10323000
         POP   PRINT                                                    10324000
         MEND                                                           10325000
