home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Columbia Kermit
/
kermit.zip
/
pub
/
tapeutils
/
tuirao.asm
< prev
next >
Wrap
Assembly Source File
|
2020-01-01
|
118KB
|
1,456 lines
OSC TITLE '(PEP/CMS) - COPY OS DISK/TAPE FILE TO CMS DISK' 00000010
*********************************************************************** 00000020
* COPYRIGHT (C) 1981, 1989 BY J.F. CHANDLER AND P.G. FORD * 00000030
* PERMISSION IS HEREBY GRANTED TO USE OR COPY THIS PROGRAM, EXCEPT * 00000040
* FOR EXPLICITLY COMMERCIAL PURPOSES. * 00000050
*********************************************************************** 00000060
PRINT NOGEN 00000070
SPROSC START X'20000' USER-PROGRAM AREA EXECUTION 00000080
SPACE 1 00000090
*---------------------------------------------------------------------- 00000100
* JFC/PGF - 1981 JAN 00000110
* 00000120
* COMMAND FORMAT: 00000130
* 00000140
* SPROSC TAP<N> <FILEID> ( <OPTIONS> 00000160
* 00000171
* "FILEID" MAY BE GIVEN AS "= =" TO REQUEST USING A 00000172
* NAME DERIVED FROM THE DSN ON TAPE, OR AS "= = <FM>" 00000173
* TO SELECT A SPECIFIC FILEMODE AS WELL. WITH MULTI- 00000174
* FILE READS, ALL FILES AFTER THE FIRST ARE NAMED 00000175
* FROM THE TAPE DSN. 00000176
* 00000180
* OPTIONS: (SPECIFY FOR LABEL=NL TAPE FILES 00000190
* 00000210
* BLOCK <N> - DEFAULT 32756 00000220
* LRECL <N> - DEFAULT 80 00000230
* RECFM <T> - F, FB, V, VB, VS, VBS, U, D (+ A) 00000240
* ASCII - TRANSLATE FROM ASCII 00000250
* EBCDIC - DO NOT TRANSLATE FROM ASCII 00000260
* NL (<N>) - UNLABELED, DESIRED TAPE FILE 00000270
* 00000280
* (SPECIFY FOR LABEL=SL TAPE FILES ONLY) 00000290
* 00000300
* DSN <C> - CHECK LAST 17 BYTES AGAINST DSNAME 00000310
* (MUST BE LAST OPTION) 00000320
* VOL <C> - CHECK AGAINST TAPE VOLUME SERIAL 00000330
* SL (<N>) - LABELED, DESIRED TAPE FILE 00000340
* EOF <N> - NUMBER OF TAPE FILES TO COPY 1.1 00000350
* EOT - COPY TILL END OF TAPE 1.1 00000360
* PREFIX <XX>- SELECT ONLY FILES BEGINNING XX 1.4 00000365
* 00000370
* (GENERAL OPTIONS) 00000380
* 00000390
* FILE <N> - DESIRED TAPE FILE 00000400
* REBLOCK <N>- REPACK A VB OR VBS FILE 1.3 00000410
* 00000411
* EXAMPLE: SPROSC TAP1 = = (EOF 217 PREFIX IK 00000412
* LOAD ALL FILES WITH NAMES BEGINNING "IK" FROM AMONG THE NEXT 217 00000413
* FILES ON TAPE 181. IF THE TAPE IS ANSI, THE FILES WILL BE TRANS- 00000414
* LATED INTO EBCDIC. IF THE TAPE IS NOT LABELED, SPROSC WILL HALT. 00000415
* 00000416
* 00000420
* R E G I S T E R A S S I G N M E N T S 00000430
* 00000440
* 2 BUFFER PTR OR ZERO 00000450
* 3 PLIST ITEM DURING SCAN (SETUP OR TAPE LABEL) 00000460
* 4,5,6 SCRATCH 00000470
* 7 FILE SKIP COUNT 00000480
* 8 INTERNAL LINKAGE 00000490
* 9 BLOCK COPY COUNT 00000500
* 10 SECOND PROGRAM BASE REGISTER 00000510
* 11 BASE FOR AUX. STORAGE 00000520
* 12 FIRST BASE REGISTER (ORIGIN OF PGM) 00000530
* 00000540
* EXTERNAL REFERENCES: 00000550
* (CMS MACROS) 00000560
* DMSFREE DMSFRET DMSKEY FSCLOSE FSERASE FSWRITE 00000580
* LINEDIT NUCON REGEQU WRTERM 00000590
* 00000640
* 00000670
* UPDATE HISTORY: 00000680
* 1981 JAN - VERSION 1.0 00000690
* 1986 DEC - VERSION 1.1 - MULTI-FILE READS, CMS UNBLOCKING, 00000700
* VMS-STYLE PADDED RECORDS + CAR.CTRL. 00000710
* 1989 JUN - VERSION 1.2 - MULTI-VOL FILES, TAPE LABEL TOLERANCE 00000720
* 1990 OCT - VERSION 1.3 - ALLOW 1-LEVEL TAPE DSNAMES, IMPLEMENT 00000730
* REBLOCK, PERSISTENT FM NUMBER, CLOSE 00000740
* FILES, RECOGNIZE VOL2-HDR3-HDR4 00000750
* 1991 JAN - VERSION 1.4 - ALLOW TAPE SEARCH BY FILE NAME 00000755
* 00000760
*---------------------------------------------------------------------- 00000770
*------------------------------------------------------ LINKAGE, USINGS 00000780
USING *,R12,R10 PROGRAM BASES 00000790
USING NUCON,R0 ADDRESS PAGE 0 00000800
LR R12,R15 LOAD PROGRAM BASE 00000810
B BEGIN 00000820
VERSION DC C'SPROSC 1.4-NODD' 1.4 00000835
BEGIN DS 0H 00000840
LA R10,2048(,R12) PREPARE SECOND BASE 00000850
LA R10,2048(,R10) GOT IT 00000860
ST R14,SAVER14 SAVE RETURN ADDRESS 00000870
LR R3,R1 SAVE POINTER TO PLIST 00000880
SPACE 1 00000890
*------------------------------------------------------ CLEAR FLAGS ETC 00000900
XR R2,R2 CLEAR R2 TO INDICATE NO BUFFER YET 00000910
XR R11,R11 CLEAR AUX STORAGE PTR 00000920
LA R0,LSTOR 00000930
DMSFREE DWORDS=(0),ERR=ERR283 GET STORAGE AREA 00000940
ST R1,STOPTR SAVE PTR (ALSO ADR OF TLGBUF) 00000950
LR R11,R1 00000960
USING STOR,R11 00000970
XC ZSTUF(ZLEN),ZSTUF CLEAR FLAGS, ETC. 00000980
MVI OUTFM,C'A' SET DEFAULT FILEMODE 00000990
BAL R8,SETUP1 INIT. A FEW THINGS 00001000
MVC FINDCNT,=H'5' MAX. NUMBER OF LABEL RETRIES 00001010
MVI PRFSTR,C' ' INITIALIZE 1.4 00001015
SPACE 1 00001020
*------------------------------------------------------ GET DDNAME/TAPN 00001030
BAL R8,PRMCHK CHECK FOR DDNAME/TAPN 00001040
OI FLG,XXPM1 SIGNAL DDNAME PRESENT 00001050
CLI 0(R3),C'?' JUST ASKING FOR VERSION? 00001060
BNE CPYDDN NO, CONTINUE 00001070
WRTERM VERSION,L'VERSION 00001080
B EXIT 00001090
CPYDDN DS 0H 00001100
MVC DDNAME,0(R3) AND TO DDNAME 00001110
CLC =C'TAP0',DDNAME 'TAPN' DEVICE? 00001120
BH NOTTAP NO 00001130
CLC =C'TAP9',DDNAME TRY AGAIN 00001140
BL NOTTAP NO 00001150
CLI DDNAME+4,C' ' ONE LAST TEST 00001160
BNE NOTTAP NO - NOT 'TAPN' 00001170
SPACE 1 00001180
*------------------------------------------------------------ IT'S TAPN 00001190
MVC TAPDEV,DDNAME COPY TAPE DEVICE CODE 00001210
MVC DCBBLKSI,=AL2(32756) SET DEFAULT 00001220
MVC DCBLRECL,=AL2(80) ... 00001230
MVI DCBRECFM,DCBRECU 00001240
SPACE 1 00001320
*---------------------------------------------------------------------- 00001330
*---------------------------------------------------- GET OUTPUT FILEID 00001340
BAL R8,PRMCHK CHECK FOR FILENAME 00001360
OI FLG,XXPM2 OK, SIGNAL BOTH THERE 00001370
MVC OUTFN(16),0(R3) PRESENT, SO COPY NAME/TYPE 00001380
BAL R8,PRMCHK CHECK FOR FILETYPE 00001390
BAL R8,PRMCHK CHECK FOR FILEMODE 00001400
MVC OUTFM(1),0(R3) YES, COPY FILEMODE 00001410
CLI 1(R3),C' ' FILEMODE NUMBER? 00001420
BE NOMODE NO 00001430
MVC OUTFM+1(1),1(R3) YES, COPY IT 00001440
MVC CMDFMN,1(R3) SAVE INDEFINITELY 1.3 00001450
OI FLG2,XXFMN REMEMBER IT 1.1 00001460
CLI 2(R3),C' ' LEGAL FILEMODE? 00001470
BNE ERR098 GO WRITE MESSAGE 00001480
NOMODE DS 0H 00001490
BAL R8,PRMCHK ANYTHING FOLLOWING? 00001500
B ERR098 YES - ERROR 00001510
SPACE 1 00001520
*--------------------------------------------CHECK NEXT PARAMETER TOKEN 00001530
PRMCHK LA R3,8(R3) MOVE TO NEXT POSSIBLE PARAMETER 00001540
CLI 0(R3),X'FF' ANYTHING FOLLOWING? 00001550
BE ENDOPT NO, DONE SCANNING 00001560
CLI 0(R3),C'(' START OF OPTIONS? 00001570
BNER R8 NOT YET, RETURN 00001580
SPACE 1 00001590
*-------------------------------------------------------- PARSE OPTIONS 00001600
* NOTE: THIS CODE IS USED ALSO FOR INTERPRETING THE 00001610
* DCB INFORMATION ON TAPE LABELS; (R2) THEN CONTAINS 00001620
* THE READ BUFFER ADDRESS AND MUST BE PRESERVED 00001630
SPACE 1 00001640
OPTLOOP DS 0H 00001650
LA R3,8(,R3) POINT TO NEXT OPTION 00001660
CLI 0(R3),X'FF' END OF PLIST? 00001670
BE ENDOPT YES 00001680
CLI 0(R3),C')' END OF OPTIONS? 00001690
BE ENDOPT YES 00001700
LA R4,LOPTTAB LENGTH OF TABLE ITEM 00001710
LA R5,OPTTAB2 POINT TO LAST ENTRY 00001720
LA R6,OPTTAB1 POINT TO FIRST ENTRY 00001730
LA R1,7(,R3) POINT TO LAST CHAR OF TOKEN 00001740
CLI 0(R1),C' ' FIND LAST NON-BLANK 00001750
BNE *+8 FOUND IT 00001760
BCT R1,*-8 KEEP LOOKING 00001770
SR R1,R3 GET TOKEN LENGTH - 1 00001780
OPTSCAN DS 0H 00001790
CLM R1,1,8(R6) TOKEN LONG ENOUGH FOR MATCH? 00001800
BL OPTSLP NO, TRY AGAIN 00001810
EX R1,OPTCMP COMPLETE MATCH? 00001820
BE OPTFIND YES 00001830
OPTSLP BXLE R6,R4,OPTSCAN LOOP OVER OPTIONS 00001840
B ERR071 ILLEGAL OPTION 00001850
OPTFIND ICM R15,7,9(R6) POINT TO PARSING ROUTINE 00001860
BALR R14,R15 EXECUTE OPTION ROUTINE 00001870
B OPTLOOP PARSE NEXT OPTION 00001880
OPTCMP CLC 0(,R3),0(R6) OPTION FOUND? 00001890
SPACE 1 00001900
*---------------------------------------------- CHECK FOR VALID OPTIONS 00001910
ENDOPT DS 0H 00001920
TM FLG,XXLAB PROCESSING TAPE LABEL? 00001930
BO ENDLAB YES, RESUME TAPE READING 00001940
TM FLG,XXPM1+XXPM2 DDNAME + FILEID PRESENT? 00001950
BZ ERR001 NEITHER, SYNTAX ERROR 00001960
BO OPENTAPE BOTH, PROCEED TO COPY 00001980
ICM R0,15,LFIL JUST POSITIONING REQUEST? 00002000
BZ ERR083 NO, TOO BAD 00002010
SPACE 1 00002030
*---------------------------------------------------------------------- 00002040
*----------------------------------------------------PREPARE INPUT FILE 00002050
OPENTAPE DS 0H 00002210
L 0,TAPSIZE MAX TAPE RECORD SIZE 00002220
SRL 0,3 CONVERT TO DOUBLEWORDS 00002230
DMSFREE DWORDS=(0),ERR=ERR283 GET A BUFFER 00002240
STCM R1,7,TAPBUFF SET BUFFER ADDRESS FOR TAPE I/O 00002250
LR R2,R1 COPY ADDRESS TO R2 00002260
SPACE 1 00002270
CONT1 DS 0H 00002290
ST R2,OUTBUFF STORE BUFFER ADDR 00002300
CONT2 DS 0H FOR REPEAT FILES 00002310
SR R9,R9 CLEAR BLOCK READ COUNT 00002320
ICM R7,15,LFIL SPECIFIED FILE? 00002350
BZ READ NO 00002360
TM FLG,XXTSL SL? 00002370
BO READ YES, WILL FIND IT 00002380
BAL R8,TAPREW NL, POSITION TAPE 00002390
L R7,LFIL 00002400
BCT R7,*+8 FILES TO SKIP 00002410
B CONT3 FILE=1, DONE 00002420
MVC TAPOPRN,=CL8'FSF' 00002430
BAL R8,TAPEMOVE FIND IT 00002440
CONT3 TM FLG,XXPM2 JUST POSITIONING? 00002450
BZ TAPECLOS YES, DONE 00002460
SPACE 1 00002470
*---------------------------- START READING---------------------------- 00002480
READ DS 0H 00002490
TAPEREAD DS 0H 00002640
MVC TAPOPRN,=CL8'READ' SET TO READ 00002650
BAL R8,TAPEX1 EXECUTE TAPE OP 00002660
DC AL4(*+4) NO SPECIAL ERROR EXIT 00002670
L R0,TAPNORD LOAD LENGTH OF BLOCK READ 00002680
LTR R15,R15 TEST RETURN CODE 00002690
BZ TAPR2 OK 00002700
CH R15,=H'2' END OF FILE? 00002710
BE TAPEOF YES 00002720
CH R15,=H'8' LENGTH ERROR? 00002730
BNE FAIL NO - REAL ERROR 00002740
SPACE 1 00002750
*-------------------------------------------------------- DETECT LABELS 00002760
TAPR2 BAL R8,ASCTRN CHANGE FROM ASCII IF NEC. 00002770
TM FLG,XXLAB SEE IF READING LABELS ALREADY 00002780
BO TLABDS YES, DECIDE WHICH KIND 00002790
TM FLG,XX1ST SEE IF ALREADY STARTED PROCESSING 00002800
BO TAPR9 YES, MUST BE READING DATA FILE 00002810
OI FLG,XX1ST NOW STARTED 00002820
TM FLG,XXTSL EXPECTING LABELS? 00002830
BO TLABDS YES, LOOK 00002840
ICM R8,15,LFIL NO, SPECIFIED 'NL <N>'? 00002850
BNZ TAPR9 YES, DON'T RECOGNIZE LABELS 00002860
TLABDS BAL R8,WHLABT DECIDE IF A LABEL RECORD 00002870
B TAPR9 NOT A LABEL 00002880
SPACE 1 00002890
*-------------------------------------------------------- PROCESS LABEL 00002900
TL0 DS 0H ORIGIN OF LABEL PROCESSORS 00002910
SPACE 1 00002920
TLV1 LA R4,4(R2) POINT TO VOLID -- VOL1 -- 00002930
BAL R8,CKVOLSER CHECK FOR MATCH 00002940
LINEDIT TEXT='SPROSC780I TAPE VOLUME: ......',DISP=ERRMSG, +00002950
DOT=NO,SUB=(CHARA,(R4)) 00002960
TLV2 B TAPEREAD -- SKIP OVER VOL2 -- 1.3 00002970
SPACE 1 00002980
TLH2 CLI TAPDSN,X'FF' HDR1 SEEN YET? -- HDR2 -- 00002990
BNE TLH2DCB YES, INTERPRET DCB INFO 00003000
LA R7,1 BACK UP TO START OF LABEL FILE 00003010
B LABRTRY AND EXPECT HDR1 00003020
SPACE 1 00003030
NULFILE TM FLG,XXTSL EXPECTING LABEL? 00003040
BO TLE2 YES, TRY AGAIN 00003050
ICM R0,15,LFIL NO, WAS IT 'NL <N>'? 00003060
BNZ CLOSEOF YES, WE REACHED THE END 00003070
SPACE 1 00003080
TLE2 DS 0H BACK UP AND TRY AGAIN -- EOF2 -- 00003090
LA R7,3 SET COUNT = 3 00003100
LABRTRY LH R1,FINDCNT CHECK AVAILABLE TRIES 00003110
BCT R1,*+8 00003120
B ERR014 TOO MANY ERRORS 00003130
STH R1,FINDCNT 00003140
MVC TAPOPRN,=CL8'BSF' BACKSPACE FILES 00003150
BAL R8,SOFTMOVE ISSUE COMMANDS 00003160
DC AL4(WOUND) ERROR MUST MEAN LOAD POINT ON TAPE 00003170
MVI TAPOPRN,C'F' NOW FORWARD SKIP 00003180
BAL R8,TAPEX1 ... OVER THAT LAST FILE MARK 00003190
B TAPEREAD TRY AGAIN 00003200
SPACE 1 00003210
TLH1 MVC TAPDSN,4(R2) SAVE TAPE FILE DSNAME -- HDR1 -- 00003220
MVC TAPGEN,35(R2) SAVE GENERATION NO., IF ANY 00003230
NI FLG2,255-XXAPP 1.2 00003240
CLI 27(R2),C'0' IS THE VOLUME SEQUENCE VALID? 1.2 00003250
BNE TLH1OK NO, ASSUME SINGLE-VOLUME 1.2 00003260
CLC =C'0001',27(R2) IS THIS THE FIRST VOLUME? 1.2 00003270
BNL TLH1OK YES, FINE 1.2 00003280
OI FLG2,XXAPP NO, MUST APPEND TO PREVIOUS ATTEMPT 1.2 00003290
TLH1OK DS 0H 1.2 00003300
SR R14,R14 CLEAR FILE OFFSET 1.1 00003310
CLC =C'CMS/SPR',61(R2) HDR1 HAS FM NUMBER? 1.1 00003320
BNE FILCHK NO 1.1 00003330
CLI 60(R2),C'0' VALID? 1.1 00003340
BL FILCHK NO, FORGET IT 1.1 00003350
MVC OUTFM+1(1),60(R2) YES, USE IT 1.1 00003360
OI FLG2,XXFMN+XXFMH 1.1 00003370
B FILCHK 00003380
SPACE 1 00003390
TLE1 DS 0H -- EOF1 -- 00003400
LA R14,2 SET COUNT FOR 2 AHEAD (DATA+TRAILER) 00003410
*--------------------------------------------------TAPE AT HDR1 OR EOF1 00003420
FILCHK DS 0H 00003430
MVC TAPFIL,31(R2) SAVE FILE SERIAL NUMBER 00003440
LA R3,TAPFIL-8 SET PTR FOR 'SCAN' 00003450
BAL R8,CONV CONVERT STRING TO BINARY 00003460
LTR R0,R0 VALID FILE NUMBER? 1.2 00003470
BP *+8 OK 1.2 00003480
LA R0,1 NO, CALL IT FILE 1 1.2 00003490
LR R7,R0 KEEP CURRENT FILE NO. IN R7 00003500
ICM R0,15,LFIL GET REQUESTED FILE NUMBER 00003510
BNZ *+6 00003520
LR R0,R7 NO, USE CURRENT FILE 00003530
SR R7,R0 GET OFFSET IN DATA FILES 00003540
MH R7,=H'3' GET TO NUMBER OF TAPE MARKS 00003550
AR R7,R14 ADD EITHER 2 OR 0 (EOF/HDR) 00003560
BZ WDSN MATCHES, GO ON 00003570
SPACE 1 00003580
*------------------------------------------------------ MUST MOVE TAPE 00003590
TAPRETRY DS 0H (R7) HAS NO. TAPE FILES TO BACK UP 00003600
LH R1,FINDCNT CHECK AVAILABLE TRIES 00003610
BCT R1,*+8 00003620
B ERR009 MUST BE OSCILLATING 00003630
STH R1,FINDCNT 00003640
LTR R7,R7 BACKWARD IF POS. 00003650
BM SKPFWD AHEAD ON TAPE 00003660
BCT R0,SKPBCK (R0) HAD REQUESTED FILE NUMBER 00003670
* - REQUESTED FILE 1, MIGHT AS WELL REWIND 00003680
SPACE 1 00003690
*--------------------------------------------------------REWIND TO VOL1 00003700
BAL R8,TAPREW REWIND TAPE 00003710
WOUND OI FLG,XXLAB+XX1ST SET TO TRY LABELS AGAIN 00003720
B TAPEREAD AND START OVER 00003730
SPACE 1 00003740
*------------------------------------------------------------ BACKSPACE 00003750
SKPBCK LA R7,1(R7) MUST BACK UP ONE EXTRA 00003760
MVC TAPOPRN,=CL8'BSF' BACKSPACE FILES 00003770
BAL R8,TAPEMOVE SKIP FILES WITH MESSAGE 00003780
DC AL4(WOUND) MUST HAVE REACHED LOAD POINT 00003790
BCTR R7,0 NOW MUST SKIP FORWARD ONE 00003800
SPACE 1 00003810
*-------------------------------------------------------- FORWARD SPACE 00003820
SKPFWD LPR R7,R7 GET NUMBER TO SKIP 00003830
MVC TAPOPRN,=CL8'FSF' SKIP FORWARD 00003840
BAL R8,TAPEMOVE SKIP FILES 00003850
B TAPEREAD TRY NEXT LABEL 00003860
SPACE 1 00003870
*-------------------------------------------------------------- GET DCB 00003880
TLH2DCB BCT R3,ENDLAB R3=1 IF HDR2, SKIP DCB IF HDR3 OR HDR4 1.3 00003890
MVC TLBRCF,=AL1(4,38,36) TR MASK FOR INFO 1.3 00003900
TR TLBRCF,0(R2) FETCH RECFM BYTES 00003910
MVC TLBBLK,5(R2) FETCH BLKSIZE 00003920
MVC TLBLRC,10(R2) FETCH LRECL 00003930
LA R3,TLBPRM-8 POINT TO PSEUDO OPTION LIST 00003940
B OPTLOOP SCAN AND INTERPRET DCB INFO 00003950
* 00003960
ENDLAB DS 0H RETURN HERE FROM SCANNER 00003970
BAL R8,TAPFSF SKIP REST OF LABEL BLOCKS (IF ANY) 00003980
SPACE 1 00003990
*----------------------------------------------------------END OF LABEL 00004000
TAPEOF TM FLG,XX1ST ANY RECORDS READ? 00004010
BZ NULFILE NO, MUST TRY AGAIN 00004020
TM FLG,XXLAB SEE IF READING LABELS 00004030
BZ CLOSE NO, DONE READING 00004040
CLI TAPDSN,X'FF' HDR1 SEEN YET? 1.1 00004050
BE CLOSEOF NO, REACHED EOT 1.3 00004060
XI FLG,XXLAB TURN OFF FLAG 00004070
B READ START READING FILE 00004080
SPACE 1 00004090
*------------------------------------------------------ DISPLAY DSNAME 00004100
WDSN DS 0H 00004110
CLI DSN,C' ' DSNAME VERIFICATION REQUESTED? 00004120
BE WDSN1 NO 00004130
L R1,ADSN START OF LAST 17 BYTES 00004140
CLC TAPDSN,0(R1) COMPARE VALUES 00004150
BNE ERR016 WE LOSE 00004160
WDSN1 DS 0H 00004170
LA R4,21(R2) POINT TO VOLID ON HDR1 00004180
LINEDIT TEXT='SPROSC781I TAPE ...... DSN: . . . ..............+00004190
... ...... FILE ....',DISP=ERRMSG,DOT=NO,RENT=NO, +00004200
SUB=(CHARA,(R4),CHARA,TAPDSN,CHARA,TAPGEN,CHARA,TAPFIL) 00004210
TM FLG2,XXAPP CONTINUATION OF MULTI-REEL FILE? 1.2 00004220
BO *+8 YES, VOLSER IS THAT OF 1ST VOLUME 1.2 00004230
BAL R8,CKVOLSER CHECK FOR MATCH 00004240
TM FLG,XXPM2 COPYING TO DISK FILE? 00004250
BZ TAPPHDR NO, JUST POSITIONING TO HEADER LABEL 00004260
B TAPEREAD 00004270
SPACE 1 00004280
*--------------------------------------------------------NON-LABEL FILE 00004290
TAPR9 TM FLG,XXOPN SEE IF DCB INFO IS CHECKED 00004300
BO TAPOPN ALREADY CHECKED 00004310
LA R7,1 BACK UP IN CASE OF ERROR 00004320
L R0,LFIL SPECIFIC TAPE FILE REQUESTED 00004330
TM FLG,XXLAB SEE IF TRYING TO READ LABELS 00004340
BO TAPRETRY YES, BAD LABELS 00004350
TM FLG,XXTSL OK. SL TAPE? 00004360
BZ FSEQOK NO, THIS MUST BE OK 00004370
CLI TAPDSN,X'FF' YES, HDR1 SEEN? 00004380
BNE FSEQOK YES, FINE 00004390
NI FLG,255-XX1ST NO, TRY ALL OVER 00004400
B TAPRETRY BACK UP AND LOOK AGAIN 00004410
FSEQOK DS 0H 00004420
LA R0,TAPDSN 00004430
CLI DSN,C' ' USER GAVE DSN? 00004440
BE *+8 NO 00004450
LA R0,DSN YES, USE IT 00004460
BAL R8,GETFID EXTRACT FILE ID IF NEC. 00004470
LA R14,PRFSTR COMPARE WITH SPECIFIED PREFIX 1.4 00004471
LA R15,8 NOTE: PREFIX MAY BE ALL-BLANK 1.4 00004472
LA R0,OUTFN 1.4 00004473
LR R1,R15 1.4 00004474
CLCL R0,R14 1.4 00004475
BE *+12 COMPLETE MATCH, LET'S DO IT 1.4 00004476
CLI 0(R14),C' ' ALL NON-BLANK PREFIX MATCHES? 1.4 00004477
BNE SKIPFILE NO, SKIP THIS FILE 1.4 00004478
BAL R14,DCBEXIT2 TEST VALUES AND SET UP FSCB 00004480
OI FLG,XXOPN MARK IT CHECKED 00004490
TAPOPN L R0,TAPNORD GET BLOCK LENGTH AGAIN 00004500
LA R9,1(,R9) INCREMENT BLOCK COUNT 00004510
SPACE 1 00004520
*------------------------------------------------------------TEST RECFM 00004530
READ2 DS 0H 00004540
TM DCBRECFM,DCBRECDU RECFM=D? 1.1 00004550
BO READV YES, SIMILAR TO V 1.1 00004560
TM DCBRECFM,DCBRECU UNDEFINED LENGTH BLOCK? 00004570
BO WRITBLK WRITE IT OUT 00004580
TM DCBRECFM,DCBRECF FIXED LENGTH RECORDS 00004590
BO READF YES 00004600
SPACE 1 00004610
*----------------------------------------------------------RECFM=V READ 00004620
READV DS 0H 00004630
LA R1,OUT POINT TO OUTPUT FSCB 00004640
LA R6,4 LOAD LENGTH OF BDW/RDW 00004650
LR R3,R2 1ST RECORD IF RECFM=D 00004660
TM DCBRECFM,DCBRECDU 1.3 00004670
BO READV2 DB. SKIP BDW CHECK 1.3 00004680
LA R3,4(,R2) POINT TO FIRST OR ONLY RDW 00004690
CLM R0,3,0(R2) CHECK WITH LENGTH FROM BDW 00004700
BNE WRITXLEN INCORRECT, MUST BE RECFM=U 00004710
READV2 DS 0H 1.3 00004720
LR R5,R2 COPY BLOCK ADDRESS 00004730
AR R5,R0 POINT PAST THE BLOCK 00004740
BCTR R5,0 BACK UP 00004750
CLI OUTFM+1,C'4' FILEMODE 4 OUTPUT? 00004760
BE WRITVBS GO WRITE THE BLOCK (OR REBLOCK IT) 1.3 00004770
TM DCBRECFM,DCBRECSB SPANNED RECORDS? 00004780
BO WRITVBS GO WRITE THE BLOCK (OR REBLOCK) 1.3 00004790
TM DCBRECFM,DCBRECDU 1.1 00004800
BO READVB ASSUME DB 1.1 00004810
TM DCBRECFM,DCBRECBR BLOCKED RECORDS 00004820
BO READVB YES 00004830
SPACE 1 00004840
*-------------------------------------------------------- WRITE RECFM=V 00004850
LR R4,R0 COPY BLOCK LENGTH 1.1 00004860
BAL R8,SDWCHK GET SEGMENT LENGTH 1.1 00004870
BNZ ERR018 ERROR 1.1 00004880
B WRITFS WRITE IT OUT 00004890
SPACE 1 00004900
*------------------------------------------------------DEBLOCK RECFM=VB 00004910
READVB DS 0H 00004920
DMSKEY NUCLEUS INTO NUCLEUS PROTECT KEY FOR SPEED 00004930
READVB1 DS 0H 00004940
BAL R8,SDWCHK GET SEGMENT LENGTH 1.1 00004950
BNZ READVB2 ERROR, GET OUT OF LOOP 00004960
LTR R4,R4 LENGTH=0? 00004970
BZ READVB2 END, GET OUT OF LOOP 00004980
FSWRITE FSCB=(1),FORM=E,TYPCALL=BALR WRITE A RECORD 00004990
LTR R8,R15 TEST RETURN CODE 00005000
BNZ READVB2 LEAVE LOOP IF BAD 00005010
BXLE R3,R4,READVB1 LOOP OVER RECORDS IN BLOCK 00005020
READVB2 DS 0H 00005030
LR R8,R15 SAVE RETURN CODE 00005040
DMSKEY RESET BACK TO USER KEY 00005050
LTR R15,R8 TEST RC FROM LAST WRITE OR SPAN CHECK 00005060
BZ READVZ OK - NOW CHECK LENGTH 00005070
BM ERR018 SPANNED RECORD 00005080
MVC OUTCOMM,=CL8'WRBUF' RESTORE SVC 202 INDICATOR 00005090
B FAIL FIND OUT WHAT WENT WRONG 00005100
SPACE 00005110
READVZ BCTR R3,0 1.1 00005120
CR R3,R5 EXACTLY FINISHED BLOCK? 1.1 00005130
BE READ OK 1.1 00005140
OI FLG2,XXMLT NO, MAKE A NOTE 1.1 00005150
B READ 00005160
SPACE 1 00005170
*---------------------------------------------------------- RECFM=F,FB? 00005180
READF DS 0H 00005190
LH R1,DCBLRECL GET RECORD LENGTH 00005200
TM FLG2,XXASC 00005210
BZ READFE DON'T CHECK FOR PADDED BLOCK 1.1 00005220
LR R5,R0 1.1 00005230
AR R5,R2 POINT TO END 1.1 00005240
BCTR R5,0 1.1 00005250
CLI 0(R5),C'^' CHECK FOR VMS-STYLE PADDING 1.1 00005260
BE *-6 1.1 00005270
AR R5,R1 ROUND UP 1.1 00005280
SR R4,R4 1.1 00005290
SR R5,R2 GET EFFECTIVE LENGTH 1.1 00005300
DR R4,R1 1.1 00005310
MR R4,R1 GET MULTIPLE OF LRECL 1.1 00005320
LR R0,R5 USE THAT AS LENGTH 1.1 00005330
READFE CLI OUTFM+1,C'4' FILEMODE 4 OUTPUT FILE? 00005340
BNE READFB NO - DEBLOCK 00005350
LH R1,DCBBLKSI LOAD BLOCK SIZE 00005360
SR R1,R0 SHORT BLOCK? 00005370
BNH WRITBLK NO 00005380
AR R0,R2 POINT TO END OF BLOCK 00005390
LA R14,EOBID POINT TO END-OF-BLOCK INSERT 00005400
LA R15,4 LOAD LENGTH OF INSERT 00005410
MVCL R0,R14 INSERT END-OF-BLOCK INDICATOR AND FILL 00005420
SR R0,R2 RESTORE FULL BLOCK LENGTH 00005430
B WRITBLK WRITE THE BLOCK 00005440
SPACE 1 00005450
*------------------------------------------------------DEBLOCK RECFM=FB 00005460
READFB DS 0H 00005470
SR R14,R14 CLEAR UPPER DIVISOR REGISTER 00005480
LR R15,R0 COPY BLOCKSIZE FOR DIVIDE 00005490
DR R14,R1 GET BLOCKING FACTOR IN R15 00005500
ST R15,OUTANIT STORE RECORD COUNT IN FSCB 00005510
LTR R14,R14 ANY REMAINDER? 00005520
BZ WRITBLK NO, IT'S A PROPER MULTIPLE 00005530
MR R14,R1 OH WELL, TRUNCATE THE BLOCK AND COPY 00005540
LR R0,R15 00005550
SPACE 1 00005560
WRITXLEN OI FLG2,XXMLT NOTE BLOCK IS WRONG LENGTH 1.1 00005570
SPACE 1 00005580
*---------------------------------------------------- WRITE TO CMS FILE 00005590
WRITBLK DS 0H 00005600
ST R0,OUTSIZE STORE BLOCK LENGTH 00005610
WRITFS FSWRITE FSCB=OUT,FORM=E,ERROR=FAIL WRITE THE BLOCK 00005620
B READ READ THE NEXT BLOCK 00005630
SPACE 1 00005640
*----------------------------------------------- REBLOCK OR WRITE AS IS 00005650
SPACE 1 00005660
* ENTER WITH R2->BUFFER, R3->INPUT DATA, R5->LAST OF INPUT, R6=4 1.3 00005670
WRITVBS ICM R1,15,REBBUF REBLOCKING? 1.3 00005680
BZ WRITBLK NO, JUST WRITE IT 1.3 00005690
MVI SPNFLGS,0 CLEAR SPANNING FLAGS 1.3 00005700
L R1,REBEND END OF OUTPUT BUFFER 1.3 00005710
L R14,REBPTR START OF AVAILABLE SPACE 1.3 00005720
SR R1,R14 ROOM REMAINING 1.3 00005730
WRITVLP BAL R8,SDWCHK GET SEGMENT LENGTH IN R4 1.3 00005740
BZ WRITVNA NOT SPANNED HERE, USE IT 1.3 00005750
MVC SPNFLGS,2(R3) SPANNED, KEEP FLAGS 1.3 00005760
AR R3,R6 NOW SKIP OVER SDW 1.3 00005770
SR R4,R6 AND REDUCE THE LENGTH 1.3 00005780
BM ERR018 SOMETHING FUNNY HAPPENED 1.3 00005790
TM SPNFLGS,2 FIRST SEGMENT? 1.3 00005800
BO WRITVNB NO, SKIP SETTING UP NEW RDW 1.3 00005810
WRITVNA C R14,REBREC MAKE SURE WE DON'T HAVE ANY LEFTOVERS 1.3 00005820
BNE ERR018 WE DID. SOMETHING FAILED 1.3 00005830
XC 0(4,R14),0(R14) CLEAR NEW RDW 1.3 00005840
AR R14,R6 AND SPACE OVER IT 1.3 00005850
SR R1,R6 REDUCE SIZE OF REMAINING SPACE 1.3 00005860
WRITVNB CR R4,R1 ROOM FOR WHOLE SEGMENT? 1.3 00005870
BH WRITVW NO, MUST WRITE THE BLOCK NOW 1.3 00005880
L R15,REBREC START OF CURRENT OUTPUT RECORD 1.3 00005890
LA R0,0(R4,R14) END OF RECORD INCLUDING NEW SEGMENT 1.3 00005900
SR R0,R15 CURRENT LENGTH 1.3 00005910
STCM R0,3,0(R15) MAKE TENTATIVE RDW 1.3 00005920
LR R15,R4 SET UP LENGTH FOR COPY 1.3 00005930
LR R0,R3 INPUT PTR 1.3 00005940
MVCL R14,R0 COPY TO OUTPUT BUFFER 1.3 00005950
TM SPNFLGS,1 WAS THIS THE LAST SEGMENT OF A RECORD? 1.3 00005960
BO WRITVLQ NO 1.3 00005970
ST R14,REBREC YES, SET PTR TO NEXT RECORD 1.3 00005980
WRITVLQ BXLE R3,R4,WRITVLP UPDATE INPUT PTR AND LOOP 1.3 00005990
ST R14,REBPTR USED INPUT BLOCK, SAVE OUTPUT PTR 1.3 00006000
B READ GET MORE INPUT 1.3 00006010
SPACE 1 1.3 00006020
*-------------------------------------------- WRITE A FULL OUTPUT BLOCK 00006030
WRITVW ST R14,REBPTR MUST DUMP BLOCK, SAVE OUTPUT PTR 1.3 00006040
BAL R14,WRITVDMP DUMP IT 1.3 00006050
B ERR003 OOPS 1.3 00006060
B WRITVNB RESUME COPYING. R1, R14 UPDATED 1.3 00006070
SPACE 1 00006080
*----------------------------------------- WRITE OUTPUT BLOCK AND RESET 00006090
WRITVDMP ST R14,WRDRET SAVE RETURN ADR 1.3 00006100
LM R14,R15,REBBUF START OF BUFFER AND AMOUNT FILLED 1.3 00006110
SR R15,R14 TOTAL LENGTH 1.3 00006120
STCM R15,3,0(R14) FILL IN BDW 1.3 00006130
STM R14,R15,OUTBUFF SET UP OUTPUT FSCB 1.3 00006140
CR R15,R6 IS TOTAL LENGTH = 4? 1.3 00006150
L R15,WRDRET RETURN ADR, IF NECESSARY 1.3 00006160
BER R15 LENGTH=4, NOTHING TO OUTPUT 1.3 00006170
FSWRITE FSCB=OUT,FORM=E,ERROR=FAIL 1.3 00006180
* 1.3 00006190
LM R0,R1,REBREC PTRS TO START AND END OF PARTIAL RECORD1.3 00006200
SR R1,R0 GET LENGTH 1.3 00006210
L R14,REBBUF START OF BUFFER 1.3 00006220
AR R14,R6 ALLOW FOR BDW 1.3 00006230
ST R14,REBREC UPDATED START OF CURRENT RECORD 1.3 00006240
LR R15,R1 LENGTH TO COPY 1.3 00006250
MVCL R14,R0 NOW R14 IS OUTPUT PTR AGAIN 1.3 00006260
L R1,REBEND END OF BUFFER 1.3 00006270
SR R1,R14 ROOM NOW REMAINING 1.3 00006280
L R15,WRDRET RETRIEVE RETURN ADR (N.B. IN R15) 1.3 00006290
B 4(,R15) RETURN AND SKIP 1.3 00006300
SPACE 1 00006310
*------------------------------------------------------ CMS WRITE FAILS 00006320
FAIL DS 0H 00006330
ST R15,RETC STORE ERROR CODE 00006360
LR R8,R1 00006362
LINEDIT TEXT='........ ERROR ......',DOT=NO, +00006364
SUB=(CHARA,(R8),DEC,(R15)),RENT=NO 00006366
B CLOSE2 CONTINUE 00006370
SPACE 1 00006371
*---------------------------------------------------------- SKIP A FILE 00006372
SKIPFILE LINEDIT TEXT=' - SKIP',DOT=NO 1.4 00006373
BAL R8,TAPFSF SKIP OVER DATA FILE 1.4 00006376
B RPTCHK AND START OVER 1.4 00006377
SPACE 1 00006380
*---------------------------------------------------- DISPLAY GOOD COPY 00006390
CLOSE DS 0H 00006400
ICM R1,15,REBBUF ARE WE REBLOCKING? 1.3 00006410
BZ *+12 NO 1.3 00006420
BAL R14,WRITVDMP PROBABLY. DUMP LAST BLOCK, IF ANY 1.3 00006430
NOP 0 IGNORE ERROR IF NO PARTIAL BLOCK 1.3 00006440
SPACE 1 00006450
LINEDIT TEXT='SPROSC770I ''........'' (........ BLOCKS) COPIED+00006460
TO ''....................''',DISP=ERRMSG,RENT=NO, +00006470
SUB=(CHARA,DDNAME,DEC,(R9),CHAR8A,OUTFN),DOT=NO 00006480
FSCLOSE FSCB=OUT NOW CLOSE THE OUTPUT FILE 1.3 00006490
RPTCHK DS 0H 1.4 00006495
L R0,RPTCNT MORE FILES TO READ? 1.1 00006500
BCTR R0,0 1.1 00006510
LTR R0,R0 1.1 00006520
BNP CLOSE2 NO, DONE READING 1.1 00006530
MVI OUTFN,C'=' YES, SEEK NEW FILE ID 1.1 00006540
MVI DSN,C' ' CLEAR VALIDATION NAME 1.1 00006550
BAL R14,RPTSET SAVE NEW COUNT 1.1 00006560
XC ZST2(ZST2L),ZST2 1.1 00006570
NI FLG,255-XXOPN 1.1 00006580
OI FLG,XXLAB+XX1ST 1.1 00006590
NI FLG2,255-XXMLT-XXFMN-XXFMH 1.1 00006600
BAL R8,SETUP1 RE-INIT. FOR READ 1.1 00006610
BAL R8,TAPFSF SKIP OVER EOF LABEL 1.1 00006620
B CONT2 1.1 00006630
SPACE 1 00006640
CLOSEOF DS 0H 00006650
LINEDIT TEXT='SPROSC772I REACHED EOT ON ....',DOT=NO, +00006660
DISP=ERRMSG,SUB=(CHARA,TAPDEV) 00006670
MVC TAPOPRN,=CL8'BSF' 00006680
LA R7,2 00006690
BAL R8,SOFTMOVE SKIP OVER EOT INDICATOR 00006700
DC AL4(*+4) 00006710
SPACE 1 00006720
CLOSE2 DS 0H 00006730
B TAPECLOS 00006740
SPACE 1 00006760
*---------------------------------------------- LEAVE TAPE AT THIS FILE 00007080
TAPPHDR MVC TAPOPRN,=CL8'BSR' SKIP BACK OVER HDR1 00007090
BAL R8,TAPEX1 ISSUE COMMAND ONCE 00007100
SPACE 1 00007110
*------------------------------------------------------------TAPN CLOSE 00007120
TAPECLOS DS 0H 00007130
L R0,TAPSIZE MAX TAPE RECORD SIZE 00007140
LTR R1,R2 BUFFER THERE? 00007150
BZ CMSCLOSE NO, WE MUST BE DONE 00007160
SRL R0,3 CVRT TO DBLWRDS 00007170
DMSFRET DWORDS=(0),LOC=(1) RELEASE THE BUFFER 00007180
SR R2,R2 00007190
TM FLG,XXPM2 COPY DONE? 00007310
BZ EXITR NO FILEID GIVEN, JUST EXIT 00007320
TM FLG,XXTSL STANDARD LABEL? 00007330
BNO CMSCLOSE NO, WE ARE OK 00007340
BAL R8,TAPFSF SKIP TRAILER LABELS 00007350
SPACE 1 00007360
*--------------------------------------------------------CLOSE CMS FILE 00007370
CMSCLOSE DS 0H 00007380
FSCLOSE FSCB=OUT CLOSE THE OUTPUT FILE 00007390
EXITR TM FLG2,XXMLT ANY BLOCK SIZE ERRORS? 1.1 00007400
BZ EXITR2 NO, FINE 1.1 00007410
LINEDIT TEXT='SPROSC783I ONE OR MORE TAPE BLOCKS WERE OF IMPRO+00007420
PER LENGTH',DOT=NO,DISP=ERRMSG 1.1 00007430
EXITR2 L R15,RETC LOAD THE RETURN CODE 00007440
SPACE 1 00007450
* ---------------------------------------------------------EXIT LINKAGE 00007460
EXIT DS 0H 00007470
LR R2,R15 SAVE RETURN CODE 00007480
LTR R1,R11 GET PTR TO AUX STORAGE 00007490
BZ STORRETZ NONE 00007500
LA R0,LSTOR 00007510
DMSFRET LOC=(1),DWORDS=(0) 00007520
STORRETZ DS 0H 00007530
ICM R1,15,REBBUF ANY REBLOCK BUFFER? 1.3 00007540
BZ REBRETZ NO, OK 1.3 00007550
L R0,REBDWDS YES, GET LENGTH 1.3 00007560
DMSFRET DWORDS=(0),LOC=(1) RELEASE IT 1.3 00007570
REBRETZ DS 0H 1.3 00007580
LR R15,R2 00007590
L R14,SAVER14 RESTORE RETURN ADDRESS 00007600
BR R14 RETURN TO CMS 00007610
SPACE 1 00007620
*-----------------------------------------------------SOME INITIALIZING 00007630
SETUP1 MVI TAPDSN,C' ' INSERT BLANK DSN,SER=' ' 00007640
MVC TAPDSN+1(LINIT),TAPDSN AND EXTEND 00007650
MVI TAPDSN,X'FF' INIDICATE HDR1 LABEL NOT SEEN YET 00007660
MVI OUTFV,C'V' DEFAULT RECFM 00007670
MVI OUTFM+1,C'1' DEFAULT FM NUMBER 00007680
CLI CMDFMN,0 ANY FM NUMBER GIVEN IN COMMAND? 1.3 00007690
BE SETUP2 NO, USE DEFAULT 1.3 00007700
MVC OUTFM+1(1),CMDFMN YES, USE IT 1.3 00007710
OI FLG2,XXFMN REMEMBER WE GOT IT 1.3 00007720
SETUP2 DS 0H 1.3 00007730
LA R0,1 00007740
ST R0,OUTANIT 1 ITEM/WRITE 00007750
SR R0,R0 00007760
MVI DCBRECFM,0 CLEAR RECFM 00007770
STH R0,DCBBLKSI CLEAR BLKSIZE 00007780
STH R0,DCBLRECL CLEAR LRECL 00007790
BR R8 00007800
SPACE 1 00007810
*---------------------------------------------------------------------- 00007820
* EXECUTE 'TAPLIST' (R7) TIMES, LEAVE (R7)=0 00007830
* ECHO COMMAND LIST TO TERMINAL, RETURN TO (R8) 00007840
*---------------------------------------------------------------------- 00007850
SPACE 1 00007860
TAPREW MVC TAPOPRN,=CL8'REW' ENTER HERE TO REWIND 00007870
LA R7,1 OPERATION COUNT 00007880
SPACE 1 00007890
TAPEMOVE DS 0H 00007900
MVI TAPDSN,X'FF' THROW AWAY OLD HDR1, IF ANY 00007910
LINEDIT TEXT='SPROSC782I EXECUTING .... ........ ON .... ...',+00007920
RENT=NO,DISP=ERRMSG,DOT=NO, +00007930
SUB=(CHARA,TAPOPRN,DEC,(R7),CHARA,TAPDEV) 00007940
B SOFTMOVE 00007950
* 00007960
* ENTER HERE TO AVOID MESSAGE AND UNDOING 'HDR1' 00007970
TAPFSF MVC TAPOPRN,=CL8'FSF' FORWARD ONE FILE 00007980
TAPEX1 LA R7,1 REPEAT COUNT=1 00007990
SOFTMOVE DS 0H 00008000
LA R1,FAIL DEFAULT ERROR EXIT 00008010
CLI 0(R8),0 ANY IN-LINE EXIT ADR? 00008020
BNE *+12 NO, USE DEFAULT 00008030
ICM R1,15,0(R8) GET IN-LINE EXIT ADR 00008040
LA R8,4(,R8) SKIP ON RETURN 00008050
STCM R1,15,TAPEXIT STORE EXIT ADR 00008060
LA R1,TAPLIST 00008070
SVC 202 00008080
TAPEXIT DC AL4(FAIL) 00008090
BCT R7,*-6 00008100
BR R8 RETURN 00008110
SPACE 1 00008120
*--------------------------------------------------DETERMINE LABEL TYPE 00008130
* RETURN IF NOT A LABEL, ELSE DISPATCH TO HANDLER 00008140
* SET R3 = RELATIVE NUMBER OF LABEL TYPE WITHIN GROUP 1.3 00008150
* CLOBBER R4,R5,R6,R15 00008160
WHLABT LA R15,1 SET SWITCH FOR ASCII TEST 00008170
CH R0,=H'80' CORRECT LENGTH FOR LABEL? 00008180
BNER R8 NO, SKIP IT 00008190
MVC LABTYP,0(R2) YES, COULD BE 00008200
TM FLG2,XXASC IS IT DEFINITELY ASCII? 00008210
BZ WHLABL NO, TRY EBCDIC FIRST 00008220
TM FLG2,XXEBC REALLY? 00008230
BO WHLABL NO, TRY EBCDIC FIRST ANYWAY 00008240
LCR R15,R15 YES, ALREADY TRANSLATED 00008250
WHLABL ICM R3,15,LABTYP LOAD TYPE FOR COMPARISON 00008260
LA R4,LLBT SET UP BXH 00008270
LA R5,LBTABZ 00008280
LA R6,LBTAB-LLBT 00008290
BXH R6,R4,WHLABA NOT FOUND, TRY ASCII 00008300
CLM R3,14,0(R6) CHECK TABLE 00008310
BNE *-8 NOT THIS, TRY NEXT 00008320
SR R5,R5 00008330
CLM R3,1,4(R6) CHECK 4TH CHAR AGAINST LIMIT 1.3 00008340
BHR R8 TOO BIG, BAD 1.3 00008350
ICM R4,15,0(R6) GET SMALLEST NUMBER OF THIS TYPE 1.3 00008360
SR R3,R4 WITHIN RANGE? 1.3 00008370
BMR R8 TOO SMALL, GIVE UP 1.3 00008380
IC R5,5(R3,R6) GET OFFSET FOR DISPATCH 1.3 00008390
LA R8,TL0(R5) SET UP DISPATCH ADR 00008400
OI FLG,XXLAB+XXTSL INDICATE READING LABELS 00008410
LTR R15,R15 SURPRISE ASCII? 00008420
BNZR R8 NO, JUST DO IT 00008430
OI FLG2,XXASC YES, REQUIRE IT NOW 00008440
TR 0(80,R2),ATOE TRANSLATE WHOLE LABEL 00008450
BR R8 OK 00008460
WHLABA BCTR R15,R8 RETURN IF ALREADY TRIED ASCII 00008470
TR LABTYP,ATOE CONVERT LABEL TYPE TO EBCDIC 00008480
B WHLABL TRY AGAIN 00008490
SPACE 00008500
*-------------------------------------------- GET RECORD/SEGMENT LENGTH 00008510
* ON ENTRY: R3->RECORD, R6=4, R8=RETURN ADR, R5->LAST BYTE OF BLOCK 00008520
* USES R4. SETS R15 ON RETURN: 0->OK, -1=>BAD VB, -2=>BAD DB 00008530
SDWCHK SR R15,R15 00008540
BCTR R15,0 R15 = -1 00008550
TM DCBRECFM,DCBRECDU 1.1 00008560
BO SDWD RECFM=D 1.1 00008570
SR R4,R4 00008580
ICM R4,3,0(R3) RECORD LENGTH 00008590
CLI 2(R3),0 LOOK AT SPAN FLAGS 00008600
BNER R8 ERROR IF ANY ARE SET 00008610
B SDWZ 00008620
SDWD LR R4,R6 SDW LENGTH 1.1 00008630
BCTR R15,0 R15 = -2 1.1 00008640
CLC =C'^^^^',0(R3) SEE IF JUST PADDING 1.1 00008650
BNE SDWDA OK, CHECK ALIGNMENT 1.1 00008660
LA R5,3(,R3) CHANGE END OF BLOCK 1.1 00008670
B SDWZ AND RETURN 1.1 00008680
SDWDK LA R3,1(R3) 1.1 00008690
SDWDA CR R3,R5 1.1 00008700
BH SDWZZ RAN OFF THE END 1.1 00008710
CLI 0(R3),C'^' ANY MORE FOR ALIGNMENT? 1.1 00008720
BE SDWDK YES, KEEP LOOKING 1.1 00008730
MVC LABTYP,0(R3) GET CHAR SDW 1.1 00008740
SDWDL CLI 0(R3),C'0' CHECK FOR DIGITS 1.1 00008750
BLR R8 ERROR 1.1 00008760
CLI 0(R3),C'9' 1.1 00008770
BHR R8 1.1 00008780
LA R3,1(,R3) 1.1 00008790
BCT R4,SDWDL LOOP OVER SDW 1.1 00008800
SR R3,R6 BACK UP OVER SDW ... 1.1 00008810
PACK DEC,LABTYP 1.1 00008820
CVB R4,DEC GET LENGTH 1.1 00008830
* CONVERT VAX/VMS CARRIAGE CONTROL TO ANSI 1.1 00008840
TM FLG2,XXASC 1.1 00008850
BZ SDWZ 1.1 00008860
CH R4,=H'6' SEGMENT LENGTH INCLUDES ENOUGH? 1.1 00008870
BL SDWZ 1.1 00008880
BE *+12 1.1 00008890
CLI 6(R3),C' ' BINARY DATA? 1.1 00008900
BL SDWZ PROBABLY 1.1 00008910
CLI 5(R3),X'0D' FUNNY CAR.CTL? 1.1 00008920
BH SDWZ NOT THAT I KNOW OF 1.1 00008930
LA R3,1(R3) YES, REMOVE ONE 1.1 00008940
BCTR R4,0 1.1 00008950
MVI 4(R3),C' ' USUAL 1-SPACE 1.1 00008960
CLI 3(R3),X'0D' SPECIAL CHARS 1.1 00008970
BNL SDWZ NO, LEAVE IT AT THAT 1.1 00008980
MVC 4(1,R3),3(R3) 1.1 00008990
TR 4(1,R3),=C'+ 0- 1' GET ANSI CAR.CTL 1.1 00009000
* GET DATA PTRS 00009010
SDWZ AR R3,R6 POINT TO DATA 00009020
SDWZZ SR R4,R6 GET DATA LENGTH 00009030
BMR R8 ILLEGAL LENGTH 00009040
STM R3,R4,OUTBUFF STORE IN FSCB 00009050
SR R15,R15 SIGNAL OK 00009060
BR R8 00009070
SPACE 1 00009080
*------------------------------------------------- TRANSLATE FROM ASCII 00009090
ASCTRN TM FLG2,XXASC DO IT? 00009100
BZR R8 NO 00009110
TM FLG2,XXEBC REFUSE? 00009120
BOR R8 YES, MAYBE BINARY 00009130
LR R15,R0 COPY LENGTH OF BLOCK 00009140
AR R0,R2 POINT TO END OF BLOCK 00009150
ASCTLP LR R14,R0 00009160
SR R14,R15 POINT TO UNTRANSLATED STUFF 00009170
BCTR R15,0 CHANGE COUNT FOR TR 00009180
EX R15,TRNASC DO UP TO 256 BYTES 00009190
N R15,=F'-256' DEDUCT COUNT JUST DONE 00009200
BNZ ASCTLP LOOP IF MORE TO DO 00009210
SR R0,R2 GET BLOCK LENGTH AGAIN 00009220
BR R8 DONE, RETURN 00009230
TRNASC TR 0(,R14),ATOE TRANSLATE A BUNCH 00009240
SPACE 1 00009250
*------------------------------------------------ PROCESS EBCDIC OPTION 00009260
EBCDIC TM FLG2,XXASC ALREADY SPECIFIED? 00009270
BO ERR340 00009280
OI FLG2,XXEBC SIGNAL IT 00009290
BR R14 GO ON 00009300
SPACE 1 00009310
*------------------------------------------------- PROCESS ASCII OPTION 00009320
ASCII TM FLG2,XXEBC ALREADY SPECIFIED? 00009330
BO ERR340 00009340
OI FLG2,XXASC SIGNAL IT 00009350
BR R14 GO ON 00009360
SPACE 1 00009370
*--------------------------------------------------PROCESS BLOCK OPTION 00009380
BLKSIZE DS 0H 00009390
BAL R8,CONV CONVERT THE VALUE 00009400
LTR00 LTR R0,R0 VALUE SPECIFIED? 1.2 00009410
BNPR R14 NO, SKIP IT 1.2 00009420
STH R0,DCBBLKSI SAVE VALUE 00009430
BR R14 PARSE NEXT TOKEN 00009440
SPACE 1 00009450
*------------------------------------------------PROCESS REBLOCK OPTION 00009460
REBLOCK BAL R8,CONV CONVERT THE VALUE 1.3 00009470
LR R6,R0 SAVE VALUE 1.3 00009480
AH R0,=Y(7+4) ROUND UP AND ALSO NEED 4 EXTRA 1.3 00009490
SRL R0,3 CONVERT TO DBLWRD COUNT 1.3 00009500
ST R0,REBDWDS SAVE SIZE 1.3 00009510
DMSFREE DWORDS=(0),ERR=ERR283 1.3 00009520
ST R1,REBBUF SAVE PTR TO BUFFER 1.3 00009530
AR R6,R1 END OF BUFFER 1.3 00009540
XC 0(4,R1),0(R1) CLEAR OUT BDW 1.3 00009550
LA R4,4(,R1) PTR TO SPACE FOR A RECORD 1.3 00009560
LR R5,R4 ALSO CURRENT PTR 1.3 00009570
STM R4,R6,REBREC SAVE PTRS 1.3 00009580
BR R14 PARSE NEXT TOKEN 1.3 00009590
SPACE 1 00009600
*--------------------------------------------------PROCESS LRECL OPTION 00009610
LRECL DS 0H 00009620
BAL R8,CONV CONVERT THE VALUE 00009630
LTR R0,R0 VALUE SPECIFIED? 1.2 00009640
BNPR R14 NO, SKIP IT 1.2 00009650
STH R0,DCBLRECL SAVE VALUE 00009660
BR R14 PARSE NEXT TOKEN 00009670
SPACE 1 00009680
*-----------------------------------------------PROCESS EOT/EOF OPTIONS 00009690
RPTALL LA R0,4095 'LARGE' NUMBER OF FILES 1.1 00009700
B RPTSET 1.1 00009710
RPTNUM BAL R8,CONV CONVERT THE VALUE 1.1 00009720
RPTSET ST R0,RPTCNT SAVE VALUE 1.1 00009730
OI FLG,XXTSL IMPLIES LABELS 1.1 00009740
CLI OUTFN,C'=' MAKE SURE EXPECTED 1.1 00009750
BNE ERR340 NO 1.1 00009760
BR R14 PARSE NEXT TOKEN 1.1 00009790
SPACE 1 00009800
*---------------------------------------------PROCESS NL/SL/FILE OPTION 00009810
NLTP TM FLG,XXTSL CAN'T HAVE IT BOTH WAYS 00009820
BO ERR340 00009830
B TFIL0 00009840
SLTP OI FLG,XXTSL 00009850
TFIL0 DS 0H 00009860
CLI 8(R3),C'0' FOLLOWED BY FILE NUMBER? 00009880
BLR R14 NO 00009890
CLI 8(R3),C'9' 00009900
BHR R14 NO 00009910
TFILE BAL R8,CONV CONVERT TO BINARY 00009920
ST R0,LFIL SAVE FILE NUMBER 00009930
CVD R0,DEC 00009940
OI DEC+7,15 SET ZONE 00009950
UNPK TAPFIL,DEC KEEP FORMATTED COPY 00009960
BR 14 00009970
SPACE 1 1.4 00009971
*------------------------------------------------ PROCESS PREFIX OPTION 00009972
PREFIX DS 0H 1.4 00009973
BAL R1,TSTDLM CHECK VALUE PRESENT 1.4 00009974
MVC PRFSTR,8(R3) SAVE THE VALUE 1.4 00009975
LA R3,8(,R3) ADVANCE SCAN POINTER 1.4 00009976
BR R14 CONTINUE OPTION SCAN 1.4 00009977
SPACE 1 00009980
*--------------------------------------------------PROCESS RECFM OPTION 00009990
RECFM DS 0H 00010000
BAL R1,TSTDLM CHECK VALUE PRESENT 00010010
LA R1,8 TOKEN SIZE 00010020
LA R4,LRECFM SET UP FOR BXLE 00010030
LA R5,RECFMB DITTO 00010040
MVI DCBRECFM,0 CLEAR INPUT RECFM 00010050
RECFM1 DS 0H 00010060
LA R7,RECFMA POINT TO LOOKUP TABLE 00010070
IC R15,7(R1,R3) GET CHARACTER OF RECFM 00010080
RECFM2 DS 0H 00010090
CLM R15,1,0(R7) IS BYTE IN TABLE? 00010100
BE RECFM3 FOUND 00010110
BXLE R7,R4,RECFM2 LOOP 00010120
B ERR308 ILLEGAL RECFM 00010130
RECFM3 DS 0H 00010140
IC R15,DCBRECFM GET CURRENT FORMAT 00010150
EX R15,RECFM5 LEGAL COMBINATION? 00010160
BNZ ERR308 NO 00010170
OC DCBRECFM,2(R7) SET DCB FLAGS 00010180
BCT R1,RECFM1 LOOP OVER VALUE TOKEN 00010190
TM DCBRECFM,DCBRECU F/V/U IN VALUE? 00010200
BZ ERR308 NO, BAD 00010210
LA R3,8(,R3) ADVANCE OPTION POINTER 00010220
BR R14 RETURN 00010230
RECFM5 TM 1(R7),0 MASK FROM R15 00010240
SPACE 1 00010250
*------------------------------------------------ PROCESS VOLUME OPTION 00010260
VOLSER DS 0H 00010270
BAL R1,TSTDLM CHECK VALUE PRESENT 00010280
MVC VOLUME,8(R3) SAVE THE VALUE 00010290
LA R3,8(,R3) ADVANCE SCAN POINTER 00010300
OI FLG,XXTSL 00010310
BR R14 CONTINUE OPTION SCAN 00010320
SPACE 1 00010330
*------------------------------------------------ PROCESS DSNAME OPTION 00010340
DSNAME DS 0H 00010350
BAL R1,TSTDLM CHECK VALUE PRESENT 00010360
LA R6,DSN POINT TO OUTPUT 00010370
LA R5,L'DSN+1 LOAD MAX LENGTH + 1 00010380
MVI TRT+C'.',0 DON'T EXPECT ANY DOTS 00010390
DSNAME1 DS 0H 00010400
LA R4,8(,R3) POINT TO NEXT INDEX 00010410
LA R1,8(,R4) POINT PAST TOKEN 00010420
TRT 0(8,R4),TRT FIND BLANK (IF ANY) 00010430
SR R1,R4 GET LENGTH TO MOVE 00010440
LR R7,R1 COPY LENGTH 00010450
MVCL R6,R4 COPY INDEX TO DSN FIELD 00010460
LTR R5,R5 TEST REMAINING DSN LENGTH 00010470
BNH ERR017 BAD IF NONE LEFT 00010480
LA R3,8(,R3) POINT TO NEXT INDEX 00010490
CLI 8(R3),X'FF' IS THERE ONE? 00010500
BE DSNAME2 NO 00010510
MVI 0(R6),C'.' INSERT DELIMITER 00010520
LA R6,1(,R6) INCREMENT POINTER TO DSN 00010530
BCT R5,DSNAME1 DECREMENT REMAINING LENGTH 00010540
B ERR017 NONE LEFT 00010550
DSNAME2 DS 0H 00010560
LA R0,DSN POINT TO DSNAME FIELD 00010570
SH R6,=H'17' BACK UP 17 FROM END OF NAME 00010580
CR R6,R0 NAME LT 17 CHARACTERS? 00010590
BNL *+6 AT LEAST 17, USE LAST 17 00010600
LR R6,R0 SHORTER THAN 17, USE FIRST 17 00010610
ST R6,ADSN SAVE PTR TO NAME FOR COMPARISON 00010620
B ENDOPT THROUGH WITH OPTIONS 00010630
SPACE 1 00010640
*-------------------------------------------------- CONVERT CHAR->FIXED 00010650
CONV DS 0H 00010660
BAL R1,TSTDLM CHECK VALUE PRESENT 00010670
LA R1,8(,R3) POINT TO VALUE 00010680
LA R15,8 LOAD TOKEN LENGTH 00010690
SR R0,R0 CLEAR RESULT REG 00010700
CONV1 DS 0H 00010710
CLI 0(R1),C' ' END OF VALUE? 00010720
BE CONV2 YES 00010730
CLI 0(R1),C'0' LEGAL? 00010740
BL ERR308 NO 00010750
CLI 0(R1),C'9' LEGAL? 00010760
BH ERR308 NO 00010770
MH R0,=H'10' INCREMENT TOTAL 00010780
IC R4,0(,R1) LOAD THE BYTE 00010790
N R4,=F'15' GET BINARY VALUE 00010800
AR R0,R4 ADD TO TOTAL 00010810
LA R1,1(,R1) POINT TO NEXT BYTE 00010820
BCT R15,CONV1 LOOP OVER TOKEN 00010830
CONV2 DS 0H 00010840
LTR R0,R0 00010850
BP CONV9 POSITIVE VALUE IS OK 00010860
TM FLG,XXLAB READING TAPE LABEL? 1.2 00010870
BZ ERR308 NO, REPORT ERROR 1.2 00010880
CLC LTR00,0(R8) DOES THE CALLER CHECK THE VALUE? 1.2 00010890
BNE ERR308 NO, REPORT ERROR 1.2 00010900
CONV9 LA R3,8(,R3) POINT TO NEXT TOKEN 00010910
BR R8 RETURN 00010920
SPACE 1 00010930
*------------------------------------------------CHECK FOR OPTION VALUE 00010940
TSTDLM DS 0H 00010950
CLI 8(R3),X'FF' FENCE? 00010960
BE ERR095 BAD 00010970
CLI 8(R3),C')' END OF OPTIONS? 00010980
BE ERR095 BAD 00010990
BR R1 OK 00011000
SPACE 1 00011010
*----------------------------------------------EXTRACT FILE ID FROM DSN 00011020
* ENTER WITH R0->NAME, R2->BUFFER, R8=RETURN ADR 00011030
* NAME RUNS TO FIRST BLANK (44 CHARS MAX) 00011040
* MUST BE CAREFUL TO PRESERVE R2 00011050
GETFID ST R2,OUTBUFF IN CASE NOT SAVED YET 00011060
CLI OUTFN,C'=' NEED FILE ID? 00011070
BNE GTFDUN NO, JUST ERASE ANY OLD FILE 00011080
LTR R3,R0 PTR TO DSN 00011090
BZ ERR019 00011100
MVI TRT+C'.',0 JUST LOOK FOR BLANKS 00011110
LA R1,L'DSN(,R3) IN CASE NAME IS FULL-LENGTH 00011120
TRT 0(L'DSN,R3),TRT FIND 1ST BLANK, IF ANY 00011130
SR R1,R3 NAME LENGTH 00011140
BNP ERR019R NOTHING 00011150
MVI TRT+C'.',1 NOW LOOK FOR DOTS 00011160
LR R5,R1 COPY LENGTH 00011170
BCTR R5,0 00011180
TOKSET XC PTBFR(12),PTBFR CLEAR TOKEN PTRS 00011190
TOKLP MVC PTBFR,PTBFR+4 SHIFT PREVIOUS PTRS 00011200
LA R1,1(R5,R3) END OF NAME 00011210
EX R5,FCHAR LOOK FOR DOT 00011220
SR R1,R3 TOKEN LENGTH 00011230
BNP TOKLQ NULL, SKIP THIS ONE 00011240
STC R1,PTBFL LENGTH OF LAST TOKEN 00011250
STCM R3,7,PTBFL+1 AND ADR 00011260
TOKLQ LA R1,1(,R1) ALLOW FOR DOT 00011270
AR R3,R1 ADVANCE PTR 00011280
SR R5,R1 DECREMENT LENGTH 00011290
BNM TOKLP 00011300
CLI PTBFR+4,0 AT LEAST 2 TOKENS? 00011310
BNE TOKFM YES, OK 1.3 00011320
CLI PTBFL,0 AT LEAST 1? 1.3 00011330
BE ERR019R NO, TOO BAD 00011340
MVC PTBFR(4),PTBFL SHIFT BACK THE PTR: FOR FILENAME 1.3 00011350
MVC OUTFT,=C'TAPEFILE' USE DEFAULT FILETYPE 1.3 00011360
B TOKNT2 1.3 00011370
TOKFM TM FLG2,XXFMH FM NUM IN SEPARATE FIELD? 1.1 00011380
BO TOKNT YES, FM NOT IN DSN 1.1 00011390
CLI PTBFL,2 LAST TOKEN LENGTH=2? 1.1 00011400
BNE TOKNT NO, ISN'T FM 1.1 00011410
ICM R4,7,PTBFL+1 MAYBE FM, GET ADR 1.1 00011420
CLI 0(R4),C'A' ALPHABETIC? 1.1 00011430
BL TOKNT CAN'T BE FM 1.1 00011440
CLI 0(R4),C'Z' ALPHABETIC? 1.1 00011450
BH TOKNT CAN'T BE FM 1.1 00011460
CLI 1(R4),C'0' VALID NUMBER? 1.1 00011470
BL TOKNT 1.1 00011480
CLI 1(R4),C'6' 1.1 00011490
BH TOKNT NO GOOD 1.1 00011500
CLI PTBFR,0 AT LEAST 3 TOKENS? 1.1 00011510
BNE GTFFM YES, GOT FM 1.1 00011520
TOKNT MVC PTBFR,PTBFR+4 USE JUST LAST TWO TOKENS 1.1 00011530
TOKNT2 MVI PTBFL,0 NO FILEMODE SPECIFIED HERE 1.2 00011540
GTFFM CLI PTBFL,2 GOT FM? 00011550
BNE GTFFN NO, JUST COPY FN/FT 00011560
TM FLG2,XXFMN FM NUMBER ALREADY SET? 1.1 00011570
BO GTFFN YES, USE THAT 1.1 00011580
MVC OUTFM+1(1),1(R4) 00011590
OI FLG2,XXFMN NOW IT'S SET 1.3 00011600
GTFFN LA R0,OUTFN OUTPUT PTR 00011610
L R5,=X'40000000' 00011620
ICM R4,7,PTBFR+1 GET TOKEN ADR 00011630
IC R5,PTBFR AND LENGTH 00011640
LA R1,8 00011650
MVCL R0,R4 COPY WITH PADDING 00011660
CLI PTBFR+4,0 ANY FILETYPE? 1.3 00011670
BE GTFDUN NO, FINISHED 1.3 00011680
ICM R4,7,PTBFR+5 GET FT TOKEN ADR 00011690
IC R5,PTBFR+4 AND LENGTH 00011700
LA R1,8 00011710
MVCL R0,R4 COPY WITH PADDING 00011720
GTFDUN TM FLG2,XXFMN FM NUMBER SPECIFIED? 1.3 00011730
BO GTFOPN YES, FINE 1.3 00011740
ICM R2,15,REBBUF NO, SEE IF REBLOCK SPECIFIED 1.3 00011750
BZ GTFOPN NO, USE DEFAULT 1.3 00011760
MVI OUTFM+1,C'4' YES, SWITCH TO FM 4 1.3 00011770
GTFOPN L R2,OUTBUFF RESTORE 1.3 00011780
FSCLOSE FSCB=OUT CLOSE THE OUTPUT FILE 00011790
TM FLG2,XXAPP APPENDING TO PREVIOUS FILE? 1.2 00011800
BOR R8 YES, ALL SET 1.2 00011810
FSERASE FSCB=OUT NO, ERASE THE OUTPUT FILE 00011820
BR R8 00011830
FCHAR TRT 0(,R3),TRT FIND DOT 00011840
*---------------------------------------------------------------------- 00011850
* EXIT ROUTINE FOR DCB OPEN, ALSO USED BY TAPE SETUP 00011860
* ASSUME ALL USUAL BASE REGISTERS 00011870
*---------------------------------------------------------------------- 00011880
SPACE 1 00011890
DCBEXIT2 DS 0H 00012160
ST R14,DCBR14 SAVE RETURN ADDRESS 00012170
LH R0,DCBLRECL LOAD RECORD LENGTH 00012180
LH R15,DCBBLKSI LOAD BLOCKSIZE 00012190
TM DCBRECFM,DCBRECU UNDEFINED LENGTH BLOCKS? 00012200
BNM DCBRECUV YES, OR MAYBE UNKNOWN 00012210
TM DCBRECFM,DCBRECV VARYING LENGTH BLOCKS? 00012220
BO DCBRECUV YES 00012230
MVI OUTFV,C'F' SET FIXED LENGTH OUTPUT 00012240
LTR R15,R15 ANY BLOCKSIZE? 00012250
BH DCB1 YES 00012260
LTR R15,R0 USE THE RECORD LENGTH 00012270
BNH DCBERR ERROR IF BOTH UNSPECIFIED 00012280
STH R15,DCBBLKSI SAVE IN DCB 00012290
B DCBOK CONTINUE 00012300
DCB1 DS 0H 00012310
LTR R0,R0 ANY RECORD LENGTH? 00012320
BH DCB2 YES 00012330
LR R0,R15 USE THE BLOCKSIZE 00012340
STH R0,DCBLRECL SAVE IN DCB 00012350
DCB2 DS 0H 00012360
SR R14,R14 CLEAR FOR DIVIDE 00012370
DR R14,R0 GET BLOCKING FACTOR 00012380
MR R14,R0 GET BLKSIZE AS CORRECT MULTIPLE 00012390
STH R15,DCBBLKSI 00012400
B DCBOK RETURN FROM THIS EXIT 00012410
DCBRECUV DS 0H 00012420
MVI OUTFV,C'V' SET VARYING LENGTH OUTPUT 00012430
LA R14,4 LOAD BDW/RDW LENGTH 00012440
CR R0,R14 TEST LRECL 00012450
BH DCB4 OK 00012460
LR R0,R15 MAKE LRECL = BLKSIZE 00012470
SR R0,R14 SUBTRACT L'BDW 00012480
STH R0,DCBLRECL STORE IN DCB 00012490
DCB4 DS 0H 00012500
CR R15,R14 TEST BLKSIZE 00012510
BH DCB5 OK 00012520
LR R15,R0 MAKE BLKSIZE = LRECL 00012530
AR R15,R14 ADD L'BDW 00012540
STH R15,DCBBLKSI STORE IN DCB 00012550
DCB5 DS 0H 00012560
TM DCBRECFM,DCBRECDU RECFM=D? 00012570
BO DCB6 YES, CHECK LRECL 00012580
TM DCBRECFM,DCBRECSB SPANNED RECORDS? 00012590
BO DCBVS NO CONECTION BETWEEN LRECL AND BLKSIZE 00012600
TM DCBRECFM,DCBRECU RECFM=U? 00012610
BO DCBVS NO NEED FOR LRECL 00012620
DCB6 AR R0,R14 GET LRECL + 4 00012630
CR R0,R15 COMPARE WITH BLKSIZE 00012640
BNH DCBOK FINE 00012650
DCBERR DS 0H 00012660
OI FLG,XXERR INDICATE BAD DCB AT OPEN TIME 00012670
B DCBOK RETURN AND BOMB OUT 00012680
DCBVS DS 0H 00012690
MVI OUTFM+1,C'4' SET FILEMODE = 4 IF SPANNED 00012700
DCBOK DS 0H 00012710
L R14,DCBR14 RESTORE RETURN ADDRESS 00012720
BR R14 RETURN TO DMSSOP 00012730
SPACE 1 00012740
*---------------------------------------------------------------------- 00012890
* M E S S A G E S 00012900
*---------------------------------------------------------------------- 00012910
SPACE 1 00012920
NOTTAP DS 0H 00012925
ERR001 DS 0H 00012930
LINEDIT TEXT='SPROSC771E MISSING TAPE ID',DISP=ERRMSG,DOT=NO 00012940
LA R15,771 RC = 771 00012960
B EXIT RETURN 00012970
ERR003 DS 0H 1.3 00012980
LINEDIT TEXT='SPROSC773E REBLOCK SIZE TOO SMALL', 1.3+00012990
DISP=ERRMSG,DOT=NO 1.3 00013000
LA R15,773 RC = 773 1.3 00013010
B EXIT RETURN 1.3 00013020
ERR083 DS 0H 00013030
LINEDIT TEXT='SPROSC083E MISSING FILEID',DISP=ERRMSG,DOT=NO 00013040
LA R15,083 RC = 083 00013050
B EXIT RETURN 00013060
ERR098 DS 0H 00013070
LINEDIT TEXT='SPROSC098E ILLEGAL PARAMETER ''........''', +00013080
SUB=(CHARA,0(R3)),DISP=ERRMSG,DOT=NO 00013090
LA R15,098 RC = 098 00013100
B EXIT RETURN 00013110
ERR071 DS 0H 00013220
LINEDIT TEXT='SPROSC071E UNKNOWN OPTION ''........''', +00013230
SUB=(CHARA,(R3)),DISP=ERRMSG,DOT=NO 00013240
LA R15,071 RC = 071 00013250
B EXIT RETURN 00013260
ERR095 DS 0H 00013270
LINEDIT TEXT='SPROSC095E NO VALUE SUPPLIED FOR ''........'' OP+00013280
TION',SUB=(CHARA,(R6)),DISP=ERRMSG,DOT=NO 00013290
LA R15,095 00013300
B OPTERRZ RETURN 00013310
ERR308 LINEDIT TEXT='SPROSC308E ILLEGAL ........ VALUE ''........''',+00013320
SUB=(CHARA,(R6),CHARA,8(R3)),DISP=ERRMSG,DOT=NO,RENT=NO 00013330
LA R15,308 00013340
B OPTERRZ RETURN 00013350
ERR340 LINEDIT TEXT='SPROSC340E INCONSISTENT OPTION ''........''', +00013360
SUB=(CHARA,(R6)),DISP=ERRMSG,DOT=NO 00013370
LA R15,340 00013380
OPTERRZ DS 0H 00013390
TM FLG,XXLAB TAPE LABEL IN PROGRESS 00013400
BZ EXIT NO, JUST RETURN 00013410
ERR009 DS 0H 00013420
LINEDIT TEXT='SPROSC779E INVALID TAPE LABELS', +00013430
DISP=ERRMSG,DOT=NO 00013440
LA R15,779 RETURN CODE 00013450
B ERREXIT FREE BUFFER, THEN RETURN 00013460
ERR014 DS 0H 00013470
LINEDIT TEXT='SPROSC784E MISSING OR EMPTY FILE ON INPUT TAPE',+00013480
DISP=ERRMSG,DOT=NO 00013490
LA R15,784 RETURN CODE 00013500
B ERREXIT FREE BUFFER, THEN RETURN 00013510
CKVOLSER MVC LABVOL,0(R4) COPY ACTUAL VOLUME NAME 00013520
CLI VOLUME,C' ' VERIFICATION OF SERIAL REQUESTED? 00013530
BER R8 NO 00013540
CLC VOLUME,0(R4) YES, CHECK IT 00013550
BER R8 OK 00013560
LINEDIT TEXT='SPROSC785E VOLUME LABEL ''......'' DOES NOT MATC+00013570
H ''VOLID ......'' OPTION',DISP=ERRMSG,DOT=NO,RENT=NO, +00013580
SUB=(CHARA,(R4),CHARA,VOLUME) 00013590
LA R15,785 RETURN CODE 00013600
B ERREXIT FREE BUFFER, THEN RETURN 00013610
ERR016 DS 0H 00013620
LINEDIT TEXT='SPROSC786E DSNAME ''.................'' DOES NOT+00013630
MATCH ''DSN .................'' OPTION',DISP=ERRMSG, +00013640
SUB=(CHARA,TAPDSN,CHARA,DSN),DOT=NO,RENT=NO 00013650
LA R15,786 RETURN CODE 00013660
B ERREXIT FREE BUFFER, THEN RETURN 00013670
ERR017 DS 0H 00013680
LINEDIT TEXT='SPROSC787E DSNAME VALUE LONGER THAN 44 BYTES', +00013690
DISP=ERRMSG,DOT=NO 00013700
LA R15,787 RETURN CODE 00013710
B EXIT 00013720
ERR018 LINEDIT TEXT='SPROSC788E SPANNED OR INVALID RECORD FOUND IN IN+00013730
PUT FILE',DISP=ERRMSG,DOT=NO 00013740
LA R15,788 RETURN CODE 00013750
B ERREXIT 00013760
ERR019R L R2,OUTBUFF RESTORE BUFFER PTR 00013770
ERR019 LINEDIT TEXT='SPROSC789E NO DSN/FID AVAILABLE FOR INPUT FILE',+00013780
DISP=ERRMSG,DOT=NO 00013790
LA R15,789 00013800
ERREXIT ST R15,RETC ... AND STORE 00013810
B CLOSE2 FREE BUFFER, THEN RETURN 00013820
ERR283 LINEDIT TEXT='SPROSC283E INSUFFICIENT STORAGE FOR BUFFERS',DOT+00013830
=NO,DISP=ERRMSG 00013840
LA R15,283 00013850
B EXIT 00013860
SPACE 1 00013870
*-------------------------------------------------- OPTION LOOKUP TABLE 00013880
* FORM: C'OPTION',AL1(MIN LENGTH - 1),AL3(PROCESSOR) 00013890
OPTTAB1 DC C'RECFM ',X'4',AL3(RECFM) 00013900
DC C'FORMAT ',X'1',AL3(RECFM) 00013910
DC C'BLOCK ',X'1',AL3(BLKSIZE) 00013920
DC C'BLKSIZE ',X'4',AL3(BLKSIZE) 00013930
DC C'LRECL ',X'4',AL3(LRECL) 00013940
DC C'REBLOCK ',X'2',AL3(REBLOCK) 1.3 00013950
DC C'ASCII ',X'2',AL3(ASCII) 00013960
DC C'EBCDIC ',X'2',AL3(EBCDIC) 00013970
DC C'PREFIX ',X'2',AL3(PREFIX) 1.4 00013975
DC C'FILE ',X'3',AL3(TFILE) 00013980
DC C'NL ',X'1',AL3(NLTP) 00013990
OPTSL DC C'SL ',X'1',AL3(SLTP) 00014000
DC C'EOT ',X'2',AL3(RPTALL) 1.1 00014010
DC C'EOF ',X'2',AL3(RPTNUM) 1.1 00014020
DC C'VOLUME ',X'2',AL3(VOLSER) 00014030
DC C'VOLID ',X'4',AL3(VOLSER) 00014040
OPTTAB2 EQU * 00014050
DC C'DSNAME ',X'2',AL3(DSNAME) 00014060
LOPTTAB EQU *-OPTTAB2 00014070
SPACE 1 00014080
*------------------------------------------------------LABEL TYPE TABLE 00014090
LBTAB DC C'VOL12',AL1(TLV1-TL0,TLV2-TL0,0,0) 1.3 00014100
DC C'HDR14',AL1(TLH1-TL0,TLH2-TL0,TLH2-TL0,TLH2-TL0) 1.3 00014110
DC C'EOF14',AL1(TLE1-TL0,TLE2-TL0,TLE2-TL0,TLE2-TL0) 1.3 00014120
LBTABZ DS 0X LAST ITEM IN TABLE 00014130
DC C'EOV14',AL1(TLE1-TL0,TLE2-TL0,TLE2-TL0,TLE2-TL0) 1.3 00014140
LLBT EQU *-LBTABZ ITEM LENGTH 00014150
SPACE 1 00014160
*----------------------------------------------------RECFM LOOKUP TABLE 00014170
* FORM: C'OPTION',AL1(FORBIDDEN-BITS,BITS-TO-SET) 00014180
RECFMA DC AL1(C' ',0,0) 00014190
DC AL1(C'F',DCBRECU,DCBRECF) 00014200
DC AL1(C'V',DCBRECU,DCBRECV) 00014210
DC AL1(C'U',DCBRECU,DCBRECU) 00014220
DC AL1(C'D',DCBRECU,DCBRECDU) 00014230
DC AL1(C'A',DCBRECCC,DCBRECCA) 00014240
DC AL1(C'M',DCBRECCC,DCBRECCM) 00014250
DC AL1(C'R',DCBRECBR+DCBRECSB,DCBRECBR+DCBRECSB) 00014260
DC AL1(C'B',DCBRECBR,DCBRECBR) 00014270
RECFMB DC AL1(C'S',DCBRECSB,DCBRECSB) 00014280
LRECFM EQU *-RECFMB LENGTH OF TABLE ENTRY 00014290
SPACE 1 00014300
*------------------------------------------------ DCB OPTIONS FROM TAPE 00014310
TLBPRM DC CL8'RECFM' 00014320
TLBRCF DC CL3' ',CL5' ' 00014330
DC CL8'BLOCK' 00014340
TLBBLK DC CL5' ',CL3' ' 00014350
DC CL8'LRECL' 00014360
TLBLRC DC CL5' ',CL3' ' 00014370
DC X'FF' END OF 'OPTIONS' 00014380
SPACE 1 00014390
*---------------------------------------------- ASCII TRANSLATION TABLE 00014400
ATOE DC X'00010203372D2E2F',X'1605250B0C0D0E0F' 00014410
DC X'101112133C3D3226',X'18193F271C1D1E1F' 00014420
DC X'405A7F7B5B6C507D',X'4D5D5C4E6B604B61' 00014430
DC X'F0F1F2F3F4F5F6F7',X'F8F97A5E4C7E6E6F' 00014440
DC X'7CC1C2C3C4C5C6C7',X'C8C9D1D2D3D4D5D6' 00014450
DC X'D7D8D9E2E3E4E5E6',X'E7E8E9ADE0BD5F6D' 00014460
DC X'7981828384858687',X'8889919293949596' 00014470
DC X'979899A2A3A4A5A6',X'A7A8A9C04FD0A107' 00014480
* (2ND HALF = 1ST) 00014490
DC X'00010203372D2E2F',X'1605250B0C0D0E0F' 00014500
DC X'101112133C3D3226',X'18193F271C1D1E1F' 00014510
DC X'405A7F7B5B6C507D',X'4D5D5C4E6B604B61' 00014520
DC X'F0F1F2F3F4F5F6F7',X'F8F97A5E4C7E6E6F' 00014530
DC X'7CC1C2C3C4C5C6C7',X'C8C9D1D2D3D4D5D6' 00014540
DC X'D7D8D9E2E3E4E5E6',X'E7E8E9ADE0BD5F6D' 00014550
DC X'7981828384858687',X'8889919293949596' 00014560
DC X'979899A2A3A4A5A6',X'A7A8A9C04FD0A107' 00014570
SPACE 1 00014580
*-------------------------------------------------------- MISCELLANEOUS 00014590
STOPTR DS A PTR TO EXTRA STORAGE AREA 00014600
SAVER14 DS A RETURN ADDRESS TO DMSITS 00014610
EOBID DC X'61FFFF61' CMS SHORT BLOCK INDICATOR 00014620
TRT DC 64X'00',X'FF',191X'00' TRT-FOR-BLANK MASK 00014630
FINDCNT DC H'5' MAXIMUM ALLOWED RETRIES FOR LABELS 00014640
SPACE 1 00014650
DS 0F 00014680
*--------------------------------------------------------------- TAPEIO 00014740
TAPLIST DC CL8'TAPEIO' PLIST FOR TAPE READ 00014750
TAPOPRN DC CL8'READ' READ (OR OTHER) CODE 00014760
TAPDEV DS CL4 TAPN CODE 00014770
DC X'00' DEN/BPI/TRTCH CODE 00014780
TAPBUFF DS AL3 INPUT BUFFER ADDRESS 00014790
TAPSIZE DC A(65535) MAX BLOCK LENGTH 00014800
TAPNORD DC A(0) LENGTH ACTUALLY READ 00014810
DC 8X'FF' FENCE 00014820
SPACE 1 00014830
*---------------------------------------------------------- AUX STORAGE 00014850
STOR DSECT 00014860
DCB DS XL96 DUMMY DCB 00014870
* DCB QUANTITIES USED: 00014900
DCBRECFM EQU DCB+36,1 RECORD FORMAT FLAGS: 00014910
DCBRECU EQU X'C0' UNDEFINED 00014920
DCBRECF EQU X'80' FIXED-LENGTH 00014930
DCBRECV EQU X'40' VARYING 00014940
DCBRECDU EQU X'E0' VARYING ASCII *** NOT STANDARD *** 00014950
DCBRECCC EQU X'06' CARRIAGE CONTROL MASK 00014960
DCBRECCA EQU X'04' AMERICAN STANDARD CC 00014970
DCBRECCM EQU X'02' MACHINE CODE CC 00014980
DCBRECBR EQU X'10' BLOCKED RECORDS 00014990
DCBRECSB EQU X'08' SPANNED RECORDS 00015000
DCBBLKSI EQU DCB+62,2 BLOCK SIZE 00015040
DCBLRECL EQU DCB+82,2 LOGICAL RECORD LENGTH 00015050
SPACE 1 00015060
ZSTUF EQU * AREA TO ZERO 00015120
SPACE 1 00015130
*---------------------------------------------------------- OUTPUT FSCB 00015140
OUT DS 0F 00015150
OUTCOMM DS CL8 00015160
OUTFN DS CL8 OUTPUT FILE ID 00015170
OUTFT DS CL8 00015180
OUTFM DS CL2,H 00015190
OUTBUFF DS A BUFFER PTR 00015200
OUTSIZE DS F DATA LENGTH 00015210
OUTFV DS C RECFM 00015220
OUTFLG DS X'20' EPL 00015230
OUTNORD DS F BYTES READ 00015240
OUTAITN DS F'0' WRITE NEXT 00015250
OUTANIT DS F NUMBER OF RECORDS TO WRITE 00015260
OUTWPTR DS F'0' WRITE PTR 00015270
OUTRPTR DS F'0' READ PTR 00015280
SPACE 1 00015290
*---------------------------------------------------------------- FLAGS 00015300
FLG DS X FLAGS 00015310
XXERR EQU X'40' ERROR IN DCB CHECKING 00015330
XXLAB EQU X'20' READING FROM TAPE LABEL 00015340
XXTSL EQU X'10' STANDARD LABEL TAPE 00015350
XXOPN EQU X'08' DCB IS CHECKED AND OK 00015360
XX1ST EQU X'04' 1ST RECORD DONE 00015370
XXPM2 EQU X'02' FILE ID SPECIFIED 00015380
XXPM1 EQU X'01' DDNAME/TAPN SPECIFIED 00015390
SPACE 1 00015400
FLG2 DS X MORE FLAGS 00015410
XXEBC EQU X'80' ASCII TRANSLATION NOT NEEDED 00015420
XXASC EQU X'40' ASCII TRANSLATION NEEDED 00015430
XXFMN EQU X'20' USER GAVE FM NUMBER 1.1 00015440
XXFMH EQU X'10' FM NUMBER FOUND IN HDR1 LABEL 1.1 00015450
XXAPP EQU X'08' CONTINUING MULTI-REEL FILE 1.2 00015460
XXMLT EQU X'01' BLKSIZE ERROR DETECTED 1.1 00015470
SPACE 1 00015480
CMDFMN DS C FILEMODE NUMBER SPECIFIED IN COMMAND 1.3 00015490
*-------------------------------------------------------- MISCELLANEOUS 00015500
DEC DS D TEMP FOR PACK 00015510
RETC DS A COMMAND RETURN CODE 00015520
RPTCNT DS F NUMBER OF FILES TO READ 1.1 00015530
REBBUF DS A PTR TO REBLOCK BUFFER, OR ZERO IF NONE 1.3 00015540
REBREC DS A PTR TO START OF CURRENT RECORD 1.3 00015550
REBPTR DS A PTR TO NEXT SLOT IN BUFFER 1.3 00015560
REBEND DS A PTR TO END OF BUFFER 1.3 00015570
ZST2 EQU * STUFF TO ZERO FOR REPEAT PASS 00015580
LFIL DS F TAPE FILE NUMBER 00015590
DSNPTR DS F PTR TO DISK/TAPE DSN 00015600
ZST2L EQU *-ZST2 00015610
ZLEN EQU *-ZSTUF 00015620
SPACE 1 00015630
ADSN DS A POINTER TO LAST 17 BYTES OF DSN 00015640
PRFSTR DS CL8 DSN SELECTION PREFIX 1.4 00015655
DCBR14 DS A RETURN ADDRESS TO DMSSOP 00015660
WRDRET DS F RETURN ADR SAVED DURING REBLOCKING 1.3 00015670
REBDWDS DS F LENGTH OF REBLOCK BUFFER, IF ANY 1.3 00015680
PTBFR DS XL8 PTRS TO TOKENS IN DSNAME 00015690
PTBFL DS XL4 PTR TO LAST TOKEN (MUST FOLLOW PTBFR) 00015700
SPNFLGS DS X BLOCK SPANNING FLAGS FOR REBLOCKING 1.3 00015710
LABTYP DS CL4 TEMPORARY FOR TAPE LABEL SCAN 00015720
DDNAME DS CL8 INPUT DDNAME 00015725
* AREA TO BE INITIALIZED WITH BLANKS 00015730
TAPDSN DS CL17,C DSNAME FIELD FROM 'HDR1' TAPE LABEL 00015740
TAPGEN DS CL6 GENERATION NO. FROM 'HDR1' 00015750
DSN DS CL44 DSNAME FOR VERIFICATION 00015760
TAPFIL DS CL4,C UNPACKED FILE NUMBER FROM HEADER LABEL 00015770
VOLUME DS CL6 TAPE VOLUME SERIAL FOR VERIFICATION 00015780
LABVOL DS CL6 SAVED VOLUME NAME FROM LABEL 00015790
LINIT EQU *-TAPDSN-1 LENGTH TO CLEAR 00015800
LSTOR EQU (*+8-STOR)/8 LENGTH OF STORAGE IN DWORDS 00015810
SPACE 1 00015820
NUCON , CMS PAGE 0 00015850
REGEQU , SYMBOLIC REGISTER EQUATES 00015860
END SPROSC 00015880