*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