*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