home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
kermit.columbia.edu
/
kermit.columbia.edu.tar
/
kermit.columbia.edu
/
archives
/
deleteme.zip
/
ikcgup.asm
< prev
next >
Wrap
Assembly Source File
|
1992-09-30
|
14KB
|
177 lines
*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