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 ( 00000160 * 00000171 * "FILEID" MAY BE GIVEN AS "= =" TO REQUEST USING A 00000172 * NAME DERIVED FROM THE DSN ON TAPE, OR AS "= = " 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 - DEFAULT 32756 00000220 * LRECL - DEFAULT 80 00000230 * RECFM - F, FB, V, VB, VS, VBS, U, D (+ A) 00000240 * ASCII - TRANSLATE FROM ASCII 00000250 * EBCDIC - DO NOT TRANSLATE FROM ASCII 00000260 * NL () - UNLABELED, DESIRED TAPE FILE 00000270 * 00000280 * (SPECIFY FOR LABEL=SL TAPE FILES ONLY) 00000290 * 00000300 * DSN - CHECK LAST 17 BYTES AGAINST DSNAME 00000310 * (MUST BE LAST OPTION) 00000320 * VOL - CHECK AGAINST TAPE VOLUME SERIAL 00000330 * SL () - LABELED, DESIRED TAPE FILE 00000340 * EOF - NUMBER OF TAPE FILES TO COPY 1.1 00000350 * EOT - COPY TILL END OF TAPE 1.1 00000360 * PREFIX - SELECT ONLY FILES BEGINNING XX 1.4 00000365 * 00000370 * (GENERAL OPTIONS) 00000380 * 00000390 * FILE - DESIRED TAPE FILE 00000400 * REBLOCK - 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 '? 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 '? 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