home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Columbia Kermit
/
kermit.zip
/
archives
/
ibm370.tar.gz
/
ibm370.tar
/
ikmgup.asm
< prev
next >
Wrap
Assembly Source File
|
1992-09-30
|
26KB
|
327 lines
*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