PUN TITLE 'DMSPUN (CMS) VM/370 - RELEASE 6' 00001000
SPACE 2 00002000
*. 00003000
* MODULE NAME: DMSPUN 00004000
* 00005000
* FUNCTION: TO PUNCH CMS FILES TO THE VIRTUAL CARD PUNCH 00006000
* 00007000
* ATTRIBUTES: DISK RESIDENT, TRANSIENT, SERIALLY REUSABLE 00008000
* NOTE: PUNCH MUST BE GENMOD'D WITH THE SYSTEM OPTION 00008100
* 00009000
* ENTRY POINT: DMSPUN(PUNCH) 00010000
* 00011000
* ENTRY CONDITIONS: UPON ENTRY, R13 POINTS TO A 24-FULLWORD SAVE 00012000
* AREA PROVIDED BY DMSITS, AND R1 POINTS TO A PARAMETER LIST 00013000
* IN THE FOLLOWING FORMAT: 00014000
* DS 0F 00015000
* PLIST DC CL8'PUNCH' 00016000
* DC CL8'FILENAME' MUST BE GIVEN 00017000
* DC CL8'FILETYPE' MUST BE GIVEN 00018000
* <DC CL8'FILEMODE'> IF NOT GIVEN, 'A ' IS USED 00019000
* <DC CL8'('> NEEDED IF OPTIONS GIVEN 00020000
* <DC CL8'OPTION 1'> (OPTIONS IN SUCCESSIVE 00021000
* <DC CL8'OPTION N'> 'CL8' GROUPS) 00022000
* <DC CL8')'> OPTION END - NOT REQUIRED 00023000
* DC 8X'FF' FENCE - END OF PLIST 00024000
* 00025000
* THE VALID OPTIONS ARE: 00026000
* HEADER OR H - THE FIRST CARD PUNCHED WILL BE A 00027000
* HEADER CARD THAT DESCRIBES THE FILE. THE 00028000
* HEADER CARD IS A VALID READ CONTROL CARD. 00029000
* THE HEADER OPTION IS THE DEFAULT. 00030000
* NOHEADER OR NOH - NO HEADER CARD IS PUNCHED. 00031000
* MEMBER OR MEM - A 'MACLIB' OR 'TXTLIB' FILE IS TO 00032000
* BE SEARCHED, AND ONE OR ALL MEMBERS ARE TO 00033000
* BE PUNCHED. (MUST BE FOLLOWED BY THE MEMBER 00034000
* NAME OR '*') 00035000
* 00036000
* EXIT CONDITIONS: AT EXIT R15 CONTAINS ONE OF THE FOLLOWING CODES: 00037000
* CODE MEANING 00038000
* 0 NO ERROR - NORMAL COMPLETION 00039000
* 20 ILLEGAL * IN FILEID (FN AND FT MUST BE GIVEN) 00040000
* 24 OPTION ERROR, INCOMPLETE FILEID 00041000
* 28 FILE NOT FOUND 00042000
* 32 LIBRARY ERROR, RECORD TOO LONG 00043000
* 36 PUNCH DEVICE NONEXISTENT OR NOT SUPPORTED 00044000
* 36 TARGET DISK NOT ACCESSED @VA12416 00044500
* 100 DISK ERROR, PUNCH ERROR 00045000
* 00046000
* CALLS TO OTHER ROUTINES: DMSSTT - GET FST COPY 00047000
* DMSBRD - READ NEXT RECORD FROM FILE 00048000
* DMSCPF - CLOSE PUNCH 00049000
* DMSFNS - CLOSE FILE 00050000
* DMSFRE - GET, RELEASE FREE STORAGE 00051000
* DMSCIOSI- PUNCH THE BUFFERED RECORDS 00052000
* DMSERR - PROCESS ERROR MESSAGES 00053000
* 00054000
EJECT 00055000
* 00056000
* EXTERNAL REFERENCES: NUCON, ADTSECT 00057000
* 00058000
* TABLES/WORKAREAS: R13 AREA PROVIDED BY DMSITS 00059000
* (USED WITH UIOSECT DSECT) 00060000
* 00061000
* REGISTER USAGE: 00062000
* R1 PLIST POINTER AT ENTRY 00063000
* R2 PLIST POINTER SAVE 00064000
* R5 INTERNAL RETURN REGISTER 00065000
* R11 BASE REG IN BUFFER 00066000
* R12 BASE REG IN CODE 00067000
* R13 BASE REG IN UIOSECT 00068000
* R14 RETURN REG AT ENTRY 00069000
* R15 RETURN CODE 00070000
* 00071000
* NOTES: DMSPUN PROVIDES A 4096-BYTE BUFFER ON A PAGE BOUNDARY FOR 00072000
* PUNCHING. DMSPUN FILLS THIS BUFFER WITH CHAINED PUNCH CCWS, 00073000
* TIC CCWS, AND DATA. DMSCIOSI IS CALLED TO ISSUE A START I/O 00074000
* AGAINST THE CCW CHAIN IN THE BUFFER. THIS PROCEDURE IS MUCH 00075000
* MORE EFFICIENT THAN ISSUING A SEPARATE START I/O FOR EACH 00076000
* RECORD TO BE PUNCHED. DMSPUN EXECUTES IN THE TRANSIENT AREA, 00077000
* WHICH IS TWO PAGES LONG. THE EXECUTABLE CODE OCCUPIES THE 00078000
* FIRST PAGE, AND THE BUFFER OCCUPIES THE SECOND PAGE. 00079000
* 00080000
* OPERATION: 00081000
* SETUP - 00082000
* 1. CHECK TO ENSURE THAT A VIRTUAL PUNCH IS AVAILABLE. 00083000
* 2. SCAN OPTIONS AND SET SWITCHES. 00084000
* 3. CALL DMSSTT(STATE) TO VERIFY EXISTENCE OF FILE. 00085000
* 4. CHECK RECORD LENGTH AGAINST 80, THE ALLOWABLE MAXIMUM. 00086000
* 00087000
* HEADER ROUTINE - 00088000
* 5. IF HEADER WANTED, BUILD THE HEADER CARD IN THE BUFFER. 00089000
* 00090000
* LIBRARY LOOKUP ROUTINE - 00091000
* 6. IF MEMBER OPTION, READ LIBRARY DICTIONARY POINTER AND 00092000
* CALL DMSFRE TO GET FREE STORAGE FOR THE DICTIONARY. READ 00093000
* THE DICTIONARY AND LOCATE THE FIRST, OR ONLY, MEMBER 00094000
* TO BE PUNCHED. 00095000
* 00096000
* MAIN LOOP - 00097000
* 7. CONSTRUCT PUNCH AND TIC CCWS IN THE NEXT AVAILABLE 00098000
* BUFFER LOCATION. 00099000
* 8. CALL DMSBRD(RDBUF) TO READ A RECORD FROM THE FILE INTO 00100000
* THE BUFFER. IF END-OF-FILE RETURNED, GO TO 11. 00101000
* 9. IF BUFFER IS FULL, CALL DMSCIOSI TO PUNCH IT. 00102000
* 10. GO TO 7. 00103000
* 00104000
EJECT 00105000
* 00106000
* RETURNS - 00107000
* 11. IF BUFFER IS NOT EMPTY, CALL DMSCIOSI TO PUNCH IT. 00108000
* 12. CALL CP CLOSE TO CLOSE THE PUNCH. 00109000
* 13. CALL DMSFNS TO CLOSE THE FILE. 00110000
* 14. IF MEMBER OPTION, CALL DMSFRE TO RELEASE FREE STORAGE. 00111000
* 15. RETURN TO CMS. 00112000
* 00113000
* NOTE: IF AN ERROR IS DETECTED, DMSERR IS CALLED TO PROCESS 00114000
* AN ERROR MESSAGE, AND THEN THE 'RETURNS' SECTION IS ENTERED 00115000
* AT AN APPROPRIATE POINT TO CLOSE ONLY THOSE THINGS THAT HAS 00116000
* BEEN OPENED AT THE TIME OF THE ERROR. 00117000
*. 00118000
********************************************************************** 00119000
EJECT 00120000
********************************************************************** 00121000
* 00122000
* START OF PROGRAM 00123000
* 00124000
********************************************************************** 00125000
SPACE 1 00126000
DMSPUN START X'E000' 00127000
ENTRY PUNCH 00128000
PUNCH EQU DMSPUN 00129000
USING *,R12,R11 00130000
USING NUCON,0 NUCON ADDRESSABILITY @V305066 00130100
LR R12,R15 ESTABLISH ADDRESSABILITY 00131000
L R11,=A(PUNCH+4096) 00132000
USING UIOSECT,R13 00133000
ST R14,UIOSAVE SAVE RETURN ADDRESS 00134000
LA R3,BUFDATA SET COUNTER TO BEGINNING OF BUFFER 00135000
SR R4,R4 AND ZERO BATCTR 00136000
STM R3,R4,BUFCTR ... 00137000
SPACE 1 00138000
LA R2,13 ASSUME DEVICE '00D' 00139000
DC X'83',X'23',XL2'0024' ISSUE DEVICE TYPE DIAGNOSE 00140000
BC 1,ERR008A DEVICE NOT ATTACHED - ERROR 8 00141000
ST R3,UIODIAG RESULTS STORED 00142000
CLI UIOVTYPC,CLASURO UNIT RECORD OUTPUT CLASS? 00143000
BNE ERR008 NO, ERROR 8 00144000
TM UIOVTYPE,TYPPUN IS IT A PUNCH? 00145000
BZ ERR008 NO, ERROR 8 00146000
SPACE 1 00147000
DEVOK LR R2,R1 SAVE PLIST POINTER TO FREE R1 00148000
MVI SWS,HEAD CLEAR SWITCHES TO HEADING DEFAULT 00149000
LM R8,R10,SCANFO R8=X'FF', R9=C'*', R10=C'(' 00150000
LM R3,R7,8(R2) REGS 3-7 CONTAIN GIVEN FILEID 00151000
CLR R3,R8 NO FILEID GIVEN? 00152000
BE ERR054 INCOMPLETE FILEID 00153000
CLR R3,R9 FILENAME GIVEN AS '*'? 00154000
BE ERR062 ILLEGAL * 00155000
CLR R3,R10 OPTION START? 00156000
BE ERR054 INCOMPLETE FILEID 00157000
CLR R5,R8 NO FILETYPE GIVEN? 00158000
BE ERR054 INCOMPLETE FILEID 00159000
CLR R5,R9 FILETYPE GIVEN AS '*'? 00160000
BE ERR062 ILLEGAL * 00161000
CLR R5,R10 OPTION START? 00162000
BE ERR054 INCOMPLETE FILEID 00163000
LR R9,R7 SAVE 24(PLIST) IN R9 00164000
CLR R7,R8 FILEMODE NOT GIVEN? 00165000
BE MODEA ASSUME FM = A 00166000
CLR R7,R10 OPTION START? 00167000
BE MODEA MODE NOT GIVEN - ASSUME FM = A 00168000
ICM R7,B'0011',BITS FILEMODE GIVEN - USE IT 00169000
B SETLIST 00170000
SPACE 1 00171000
MODEA L R7,AMODE ASSUME FILEMODE OF 'A ' 00172000
SETLIST STM R3,R7,FILENAME SET FILE SYSTEM PLIST WITH FILEID 00173000
L R1,BITS INITIALIZE OTHER FIELDS TO '0001' 00174000
STH R1,FILENOIT ... 00175000
MVC FILE(8),=CL8'STATE' SET FILE PLIST FOR STATE CALL 00176000
SPACE 1 00177000
*** SCAN OPTIONS, SET APPROPRIATE SWITCHES 00178000
SPACE 1 00179000
CLR R9,R8 24(PLIST) = X'FF'? 00180000
BE CKEXIST IF SO, END OF PLIST 00181000
CLR R9,R10 24(PLIST) = C'('? 00182000
BNE SCAN4 IF NOT, FILEMODE WAS GIVEN 00183000
LA R9,32(,R2) POINT TO OPTIONS 00184000
SPACE 1 00185000
SCAN1 CLI 0(R9),C')' END OF OPTIONS? 00186000
BE CKEXIST YES 00187000
CLI 0(R9),X'FF' END OF PLIST? 00188000
BE CKEXIST YES 00189000
CLC 0(8,R9),=CL8'HEADER' 00190000
BE SCAN1A BRANCH IF HEADER WANTED 00191000
CLC 0(8,R9),=CL8'H' 00192000
BNE SCAN2 GO CHECK NEXT POSSIBILITY 00193000
SPACE 1 00194000
SCAN1A OI SWS,HEAD TURN ON HEADER WANTED SWITCH 00195000
NI SWS,255-NOHDR TURN OFF NOHEADER SWITCH, IF ON @VA02870 00195100
LA R9,8(,R9) INCREMENT R9 TO NEXT OPTION 00196000
B SCAN1 00197000
SPACE 1 00198000
SCAN2 CLC 0(8,R9),=CL8'NOHEADER' 00199000
BE SCAN2A BRANCH IF NOHEADER WANTED 00200000
CLC 0(8,R9),=CL8'NOH' 00201000
BNE SCAN3 GO CHECK NEXT POSSIBILITY 00202000
SPACE 1 00203000
SCAN2A OI SWS,NOHDR TURN ON NOHEADER WANTED SWITCH 00204000
LA R9,8(,R9) INCREMENT R9 TO NEXT OPTION 00205000
B SCAN1 00206000
SPACE 1 00207000
SCAN3 CLC 0(8,R9),=CL8'MEM' 00208000
BE SCAN3A 00209000
CLC 0(8,R9),=CL8'MEMBER' 00210000
BNE ERR003 OPTION NOT RECOGNIZED - ERROR 00211000
SCAN3A OI SWS,MEMB TURN ON MEMBER SWITCH 00212000
CLC 8(8,R9),=CL8'*' ALL MEMBERS WANTED? 00213000
BE SCAN3B BRANCH IF SO 00214000
CLI 8(R9),C')' END OF OPTIONS? 00215000
BE ERR029 ERROR IF SO 00216000
CLI 8(R9),X'FF' END OF PLIST? 00217000
BE ERR029 ERROR IF SO 00218000
MVC NAME1(8),8(R9) SINGLE MEMBER WANTED - SAVE ITS NAME 00219000
OI SWS,NAME SIGNAL SINGLE MEMBER 00220000
SPACE 1 00221000
SCAN3B LA R9,16(,R9) POINT TO NEXT OPTION 00222000
B SCAN1 GO SCAN IT 00223000
SPACE 1 00224000
SCAN4 CLI 32(R2),X'FF' END OF PLIST? 00225000
BE CKEXIST YES, NO (MORE) OPTIONS TO SCAN 00226000
CLI 32(R2),C'(' BEGINNING OF OPTIONS? 00227000
BNE SCAN4A IF NOT, DON'T KNOW WHAT IT IS 00228000
LA R9,40(,R2) POINT R9 TO BEGINNING OF OPTIONS 00229000
B SCAN1 AND START SCANNING 00230000
SPACE 1 00231000
SCAN4A LA R9,32(,R2) POINT R9 TO UNKNOWN OPTION 00232000
B ERR003 AND SIGNAL ERROR 00233000
SPACE 1 00234000
EJECT 00235000
********************************************************************* 00236000
* 00237000
* CHECK EXISTENCE OF FILE, CHECK SWITCHES TO DETERMINE 00238000
* THE ORDER IN WHICH ROUTINES WILL BE PERFORMED 00239000
* 00240000
********************************************************************* 00241000
SPACE 1 00242000
CKEXIST TM SWS,NOHDR RESOLVE CONFLICTING SWITCHES 00243000
BZ CK1 NO PROBLEM, BRANCH 00244000
NI SWS,255-HEAD NOHEADER TAKES EFFECT IF SPECIFIED 00245000
SPACE 1 00246000
CK1 LA R1,FILE SET FOR CMS CALL 00247000
L R15,ASTATE STATE @V305066 00248100
BALR R14,R15 ... @V305066 00248200
BNZ STATERR ERROR RETURN @V305066 00248300
L R3,FILEBUFF GET LOCATION OF FST COPY 00250000
MVC FILEMODE(2),24(R3) SET ACTUAL FILEMODE 00251000
MVC FILECOMM(8),=CL8'RDBUF' SET FILE PLIST FOR READ 00252000
L R4,32(,R3) RECORD LENGTH IN R4 00253000
ST R4,FILESIZE SET INTO FILE PLIST 00254000
LA R5,80 MAX LENGTH IN R5 00255000
CR R4,R5 IS LENGTH OK? 00256000
BH ERR044 RECORD TOO LONG - ERROR 00257000
ST R3,PUNFST SAVE A(FST) FOR LATER @VA01108 00258000
LA R5,MAINRD SET LOOP ADDRESS @VA01108 00258100
TM SWS,MEMB PUNCHING FROM A LIBRARY? @VA01108 00258200
BO MEMBS YES, LOOK UP MEMBER @VA01108 00258300
EJECT 00265000
********************************************************************** 00266000
* 00267000
* ROUTINE TO SET UP HEADER CARD 00268000
* 00269000
********************************************************************** 00270000
SPACE 1 00271000
HEADSET TM SWS,HEAD IS A HEADING CARD WANTED? @VA01108 00272000
BCR 8,R5 NO, 'BZ' RETURN @VA01108 00272100
LM R9,R10,BUFCTR R9= NEXT BUFFER LOCATION @VA01108 00272200
LA R6,16(,R9) R6= DATA LOCATION 00273000
LA R8,96(,R9) R8= FUTURE NEXT BUFFER LOCATION 00274000
L R7,CCWCNT R7= RIGHT HALF WRITE CCW 00275000
STM R6,R8,0(R9) FORM CCWS 00276000
MVI 0(R9),X'41' INSERT PUNCH COMMAND 00277000
MVI 8(R9),X'08' INSERT TIC COMMAND 00278000
LA R10,1(,R10) INCREMENT BATCH COUNT 00279000
ST R8,BUFCTR UPDATE BUFCTR 00280000
ST R10,BATCTR AND BATCTR 00281000
MVC 0(80,R6),BBUF CLEAR BUFFER AREA 00282000
SPACE 1 00283000
MVC 0(5,R6),PCHDR SET COLS 1-5 OF HEADER CARD 00284000
TM SWS,MEMB PUNCHING FROM A LIBRARY? @VA01108 00285000
BZ HEADSET1 BRANCH IF NOT - 'NORMAL' HEADER @VA01108 00285100
MVC 7(8,R6),0(R1) MOVE IN MEMBER NAME @VA01108 00285200
CLC FILETYPE(3),=CL3'MAC' IS IT A MACLIB? 00288000
BE MACHEAD 00289000
MVC 16(8,R6),=CL8'TEXT' MUST BE TXTLIB - MAKE FT= TEXT 00290000
B HEADSET2 00291000
MACHEAD MVC 16(8,R6),=CL8'MEMBER' MAKE FILETYPE= MEMBER 00292000
B HEADSET2 00293000
SPACE 1 00294000
HEADSET1 MVC 7(8,R6),FILENAME MOVE IN FILENAME 00295000
MVC 16(8,R6),FILETYPE MOVE IN FILETYPE 00296000
HEADSET2 MVC 25(2,R6),FILEMODE AND FILEMODE 00297000
L R3,PUNFST GET A(FST) FOR THIS FILE @VA01108 00297100
L R14,FVSFSTAD-STATEFST(R3) GET A(ADT THIS FILE) 00298000
USING ADTSECT,R14 TEMP BASE REG 00299000
MVC 28(6,R6),ADTID MOVE IN DISK LABEL 00300000
DROP R14 00301000
CLC 18(2,R3),BITS IS TIME IN FST= ZERO? 00302000
BE NOTIME YES 00303000
CLI 18(R3),X'24' VALID TIME? 00304000
BH NOTIME NO 00305000
MVC 44(6,R6),TPAT MOVE IN TIME EDIT PATTERN 00306000
ED 44(6,R6),18(R3) 00307000
NOTIME MVI 40(R6),C'/' INSERT SLASH 00308000
MVC 41(2,R6),38(R3) MOVE IN YEAR 00309000
CLC 16(2,R3),BITS IS DATE IN FST=ZERO? 00310000
BE NODATE 00311000
CLI 16(R3),X'01' VALID DATE? 00312000
BL NODATE 00313000
CLI 16(R3),X'12' CHECK MORE... 00314000
BH NODATE 00315000
MVC 34(6,R6),DPAT MOVE IN DATE EDIT PATTERN 00316000
ED 34(6,R6),16(R3) 00317000
NODATE C R8,LIMIT IS BUFFER GETTING FULL? 00318000
BNL PUNCHER YES 00319000
BR R5 00320000
EJECT 00321000
********************************************************************** 00322000
* READ AND CHECK FOR 'LIB' LIBRARY. GET STORAGE AND READ DICTIONARY 00323000
* INTO IT. IF MEMBER NAME WANTED SEARCH FOR IT AND SET REGS. 00324000
* R4-DICTIONARY LOCATION OF CURRENT NAME. 00325000
* DICTIONARY FORM- 00326000
* CL8'NAME' 00327000
* CL2'INDEX' 00328000
* CL2'LENGTH' 00329000
* 00330000
********************************************************************** 00331000
SPACE 1 00332000
MEMBS EQU * 00333000
LA R7,MEMBUF POINT TO BUFFER 00334000
ST R7,FILEBUFF SET IN PLIST 00335000
LA R6,1 00336000
STCM R6,3,FILEITNO SET ITEM NO. TO 1ST RECORD 00337000
LA R1,FILE READ DICTIONARY POINTER 00338000
L R15,ARDBUF RDBUF @V305066 00339000
BALR R14,R15 ... @V305066 00339100
BNZ LIBRERR ERROR RETURN @V305066 00339200
CLC 3(3,R7),=CL3'LIB' IS IT A LIBRARY FILE 00341000
BNE ERR033 NOT A LIB FILE 00342000
SR R0,R0 CLEAR REG 0 @VA07196 00343000
ICM R0,B'0011',10(R7) GET LENGTH OF DICTIONARY @VA07196 00343500
ST R0,DICTLEN SAVE 00344000
LTR R0,R0 IF LENGTH IS ZERO... 00345000
BZ ERR039 THERE ARE NO ENTRIES IN LIBRARY 00346000
LA R1,60 FIX FOR MINIMUM NUMBER DOUBLE WORDS 00347000
AR R0,R1 * 00348000
SRL R0,3 * 00349000
ST R0,STRLEN SAVE AMOUNT REQUESTED 00350000
DMSFREE DWORDS=(0) 00351000
ST R1,STRADR SAVE ADDRESS 00352000
ST R1,DICTADR SAVE STORAGE START 00353000
L R6,DICTLEN GET BUF AREA ADDR 00354000
LA R3,0(R1,R6) SET END 00355000
LA R2,72 SET INDEX FACTOR 00356000
ST R3,DICTEND SAVE END OF DICTIONARY 00357000
BCTR R3,R0 DECR FOR BXLE 00358000
LH R4,6(R7) GET INDEX FOR READ 00359000
LR R6,R1 00360000
* 00361000
RDLOOP STH R4,FILEITNO SET ITEM NO 00362000
LA R1,FILE READ PARM LIST 00363000
L R15,ARDBUF RDBUF @V305066 00364000
BALR R14,R15 ... @V305066 00364100
BNZ READERR ERROR RETURN @V305066 00364200
MVC 0(72,R6),0(R7) MOVE TO DICTIONARY 00366000
LA R4,1(,R4) INCR INDEX 00367000
BXLE R6,R2,RDLOOP GET EVERY ONE 00368000
* 00369000
L R3,DICTEND END OF DICTIONARY 00370000
L R4,DICTADR GET START ADDR 00371000
LA R2,12 00372000
BCTR R3,0 DECREMENT FOR BXLE 00373000
RDLOOP1 CLI 0(R4),X'00' NULL ENTRY? 00374000
BNZ NAMLOOP2 NO 00375000
BXLE R4,R2,RDLOOP1 LOOK AGAIN 00376000
B ERR039A ERROR NO ENTRIES 00377000
* 00378000
NAMLOOP2 ST R4,DICTADR 00379000
TM SWS,NAME ONLY ONE MEMBER WANTED? 00380000
BNO NAMLOOP1 NO,THEN WE CAN START 00381000
LA R2,12 00382000
NAMLOOP CLC 0(8,R4),NAME1 IS IT NAME 00383000
BE NAMLOOP1 YES, FOUND IT 00384000
BXLE R4,R2,NAMLOOP LOOK AT NEXT 00385000
B ERR013 NAME NOT FOUND 00386000
* 00387000
NAMLOOP1 ST R4,DICTADR ENSURE DICTADR IS UP TO DATE @VA01108 00388000
CLC 0(2,R4),BITS IS FIRST SLOT EMPTY? @VA01108 00388100
BNE NAMLOOP3 NO 00389000
LA R4,12(R4) POINT TO NEXT IF FIRST EMPTY 00390000
B NAMLOOP2 00391000
NAMLOOP3 EQU * 00392000
L R4,DICTADR SET DICTADR BACK 12 FOR CORRECT..@VA01108 00393000
S R4,=F'12' ...ENTRY INTO PUNCHING LOOP @VA01108 00393100
ST R4,DICTADR ... @VA01108 00393200
B MEMFIND ENTER PUNCH LOOP @VA01108 00393300
EJECT 00396000
********************************************************************** 00397000
* 00398000
* MAIN PROCESSING LOOP 00399000
* 00400000
********************************************************************** 00401000
SPACE 1 00402000
MAINLOOP EQU * 00403000
LA R5,MEMLOOP SET RETURN ADDR IN CASE MEMBER OPTION 00404000
TM SWS,MEMB PUNCHING A LIBRARY MEMBER? 00405000
BO MEMLOOP YES 00406000
LA R5,MAINRD NO, CHANGE RETURN LOOP ADDRESS 00407000
BR R5 AND GO READ A RECORD 00408000
SPACE 1 00409000
MEMLOOP L R1,FILEBUFF POINT TO LAST RECORD READ 00410000
CLC 0(4,R1),=X'61FFFF61' END OF MEMBER RECORD? 00411000
BE MEMEND BRANCH IF SO 00412000
LA R4,1(,R4) INCREMENT RECORD NUMBER 00413000
STH R4,FILEITNO AND SET IN FILE PLIST 00414000
B MAINRD READ NEXT RECORD 00415000
SPACE 1 00416000
MEMEND LA R15,12 SIMULATE EOF IN CASE FINISHED 00417000
TM SWS,NAME MEMBER NAME GIVEN? 00418000
BO READERR 00419000
SPACE 1 00420000
MEMFIND L R1,DICTADR PREPARE TO LOCATE NEXT MEMBER 00421000
LA R1,12(,R1) POINT TO NEXT DICTIONARY ENTRY 00422000
C R1,DICTEND END OF ALL MEMBERS? 00423000
BNL READERR YES, END 00424000
ST R1,DICTADR NO,STORE NEW ADDRESS 00425000
CLI 0(R1),X'00' NULL DICTIONARY ENTRY? 00426000
BE MEMFIND IF SO, LOOK AGAIN 00427000
LH R4,8(,R1) IF NOT, GET STARTING LOCATION 00428000
STH R4,FILEITNO AND SET IT IN PLIST @VA01108 00428100
BAL R5,HEADSET PUNCH HEADER FOR THIS MEMBER @VA01108 00428200
LA R5,MEMLOOP SET LOOP ADDRESS @VA01108 00428300
BYALIAS L R1,DICTADR CHECK IF NEXT ENTRY IS AN ALIAS @VA01108 00428400
LA R1,12(,R1) POINT TO NEXT DICTIONARY ENTRY @VA01108 00428500
C R1,DICTEND IS IT THE END? @VA01108 00428600
BNL MAINRD YES, NO ALIAS PROBLEM @VA01108 00428700
LH R2,8(,R1) INDEX OF NEXT MEMBER @VA01283 00428800
CH R2,FILEITNO IS IT THE SAME AS THIS MEMBER? @VA01283 00428900
BNE MAINRD NO, READ NEXT RECORD @VA01108 00429000
ST R1,DICTADR DON'T REPUNCH SAME MEM NEXT TIME @VA01108 00429200
B BYALIAS NOW CHECK IF NEW NEXT IS AN ALIAS@VA01108 00429300
SPACE 1 00429400
SPACE 1 00430000
MAINRD EQU * 00431000
LM R9,R10,BUFCTR R9= NEXT BUFFER LOCATION 00432000
LA R6,16(,R9) R6= DATA LOCATION 00433000
LA R8,96(,R9) R8= FUTURE NEXT BUFFER LOCATION 00434000
L R7,CCWCNT R7= RIGHT HALF WRITE CCW 00435000
STM R6,R8,0(R9) FORM CCWS 00436000
MVI 0(R9),X'41' INSERT PUNCH CCW 00437000
MVI 8(R9),X'08' INSERT TIC COMMAND 00438000
LA R10,1(,R10) INCREMENT BATCH COUNT 00439000
MVC 0(80,R6),BBUF CLEAR BUFFER AREA 00440000
SPACE 1 00441000
ST R6,FILEBUFF SET BUFFER ADDRESS IN FILE PLIST 00442000
LA R1,FILE SET TO READ RECORD 00443000
L R15,ARDBUF RDBUF @V305066 00444000
BALR R14,R15 ... @V305066 00444100
BNZ READERR ERROR RETURN @V305066 00444200
ST R8,BUFCTR UPDATE BUFCTR 00446000
ST R10,BATCTR AND BATCTR 00447000
C R8,LIMIT IS BUFFER GETTING FULL? 00448000
BNL PUNCHER YES, GO EMPTY IT 00449000
BR R5 NO, GO BACK TO PROCESS NEXT RECORD 00450000
EJECT 00451000
********************************************************************* 00452000
* 00453000
* ROUTINE TO CALL DMSCIOSI TO PUNCH BUFFERED CCW CHAIN 00454000
* 00455000
********************************************************************* 00456000
SPACE 1 00457000
PUNCHER EQU * 00458000
L R9,BUFCTR GET NEXT BUFFER LOCATION 00459000
LM R6,R7,CCWNOP SET NOP AT END OF BUFFER 00460000
STM R6,R7,0(R9) ... 00461000
LA R1,BUFPUN SET FOR DMSCIOSI CALL 00462000
SVC 202 00463000
DC AL4(BUFERR) 00464000
LA R6,BUFDATA RESTORE BUFCTR TO BEGINNING OF BUFFER 00465000
SR R7,R7 AND ZERO BATCTR 00466000
STM R6,R7,BUFCTR ... 00467000
BR R5 RETURN TO PROCESS NEXT RECORD 00468000
EJECT 00469000
********************************************************************** 00470000
* 00471000
* ERROR MESSAGES 00472000
* 00473000
********************************************************************** 00474000
SPACE 1 00475000
ERRMSG1 LA R0,FILENAME 00476000
DMSERR MF=(E,'SYS'),LET=S,NUM=(4),TEXTA=(3), *00477000
SUB=(DEC,(15),CHAR8A,(0)) 00478000
BR R5 00479000
SPACE 1 00480000
LIBRERR NI SWS,255-MEMB CONSIDER AS NOT MEMB, FREE STG NOT GOT 00481000
READERR CH R15,H12 IS IT EOF? 00482000
BE NORMRET YES, ALL DONE 00483000
SPACE 1 00484000
ERR104 LA R3,BRDERR 00485000
LA R4,104 00486000
BAL R5,ERRMSG1 00487000
LA R15,100 00488000
B CLOSRET 00489000
SPACE 1 00490000
BUFERR EQU * 00491000
ERR118 C R15,=F'100' MSG GIVEN BY DMSCIO? 00492000
BE CLOSRET1 BRANCH IF SO 00493000
LA R3,CIOERR 00494000
LA R4,123 00495000
BAL R5,ERRMSG1 00496000
LA R15,100 00497000
B CLOSRET1 00498000
ERRMSG36 EQU * @VA12416 00498150
LA R0,FILEMODE POINT TO MODE LETTER @VA12416 00498300
DMSERR TEXT='DISK ''..'' NOT ACCESSED',NUM=69, X00498450
LET=E,SUB=(CHARA,((R0),1)),TYPCALL=SVC @VA12416 00498600
LA R15,36 GIVE RETCODE @VA12416 00498750
B ERRET AND GO RETURN TO CALLER @VA12416 00498900
SPACE 1 00499000
ERRMSG2 LA R0,FILENAME 00500000
DMSERR MF=(E,'SYS'),LET=E,NUM=(4),TEXTA=(3), *00501000
SUB=(CHAR8A,(0)) 00502000
BR R5 00503000
SPACE 1 00504000
STATERR EQU * @VA12416 00505000
C R15,=F'36' WAS DISK NOT ACCESSED? @VA12416 00505100
BE ERRMSG36 GIVE MSG @VA12416 00505200
C R15,=F'28' FILE NOT FOUND FROM STATE? @VA12416 00505300
BNE ERRET NO, MESSAGE GIVEN BY STATE 00506000
ERR002 LA R3,NOFILE 00507000
LA R4,2 00508000
BAL R5,ERRMSG2 00509000
LA R15,28 00510000
B ERRET 00511000
SPACE 1 00512000
ERR008 LA R3,UNS 00513000
LA R4,8 00514000
BAL R5,ERRMSG2 00515000
LA R15,36 00516000
B ERRET 00517000
SPACE 1 00518000
ERR008A LA R3,INV 00519000
LA R4,8 00520000
BAL R5,ERRMSG2 00521000
LA R15,36 00522000
B ERRET 00523000
SPACE 1 00524000
ERR039 NI SWS,255-MEMB 00525000
ERR039A LA R3,NOMEMB 00526000
LA R4,39 00527000
BAL R5,ERRMSG2 00528000
LA R15,32 00529000
B FINRET 00530000
SPACE 1 00531000
ERR033 LA R3,NOTLIB 00532000
LA R4,33 00533000
BAL R5,ERRMSG2 00534000
NI SWS,255-MEMB 00535000
LA R15,32 00536000
B FINRET 00537000
SPACE 1 00538000
ERR062 LA R3,ASTER 00539000
LA R4,62 00540000
BAL R5,ERRMSG2 00541000
LA R15,20 00542000
B ERRET 00543000
SPACE 1 00544000
ERR044 LA R3,EXCED 00545000
LA R4,44 00546000
BAL R5,ERRMSG2 00547000
LA R15,32 00548000
B ERRET 00549000
SPACE 1 00550000
ERR054 LA R3,INCID 00551000
LA R4,54 00552000
BAL R5,ERRMSG2 00553000
LA R15,24 00554000
B ERRET 00555000
SPACE 1 00556000
ERRMSG3 DMSERR MF=(E,'SYS'),LET=E,NUM=(4),TEXTA=(3), *00557000
SUB=(CHARA,(9),CHARA,(6)) 00558000
BR R5 00559000
SPACE 1 00560000
ERR003 LA R3,BADOPT 00561000
LA R4,3 00562000
BAL R5,ERRMSG3 00563000
LA R15,24 00564000
B ERRET 00565000
SPACE 1 00566000
ERR013 LA R9,NAME1 00567000
LA R3,MEMNF 00568000
LA R4,13 00569000
BAL R5,ERRMSG3 00570000
LA R15,32 00571000
B FINRET 00572000
SPACE 1 00573000
ERR029 LR R6,R9 00574000
LA R9,8(,R9) 00575000
LA R3,BADPARM 00576000
LA R4,29 00577000
BAL R5,ERRMSG3 00578000
LA R15,24 00579000
B ERRET 00580000
EJECT 00581000
NOFILE DC AL1(L'NOFILEMS) 00582000
NOFILEMS DC C'FILE ''....................'' NOT FOUND' 00583000
SPACE 1 00584000
NOMEMB DC AL1(L'NOMEMBMS) 00585000
NOMEMBMS DC C'NO ENTRIES IN LIBRARY ''....................''' 00586000
SPACE 1 00587000
NOTLIB DC AL1(L'NOTLIBMS) 00588000
NOTLIBMS DC C'FILE ''....................'' IS NOT A LIBRARY' 00589000
SPACE 1 00590000
INCID DC AL1(L'INCIDMS) 00591000
INCIDMS DC C'INCOMPLETE FILEID SPECIFIED' 00592000
SPACE 1 00593000
EXCED DC AL1(L'EXCEDMS) 00594000
EXCEDMS DC C'RECORD EXCEEDS ALLOWABLE MAXIMUM' 00595000
SPACE 1 00596000
ASTER DC AL1(L'ASTERMS) 00597000
ASTERMS DC C'INVALID * IN FILEID' 00598000
SPACE 1 00599000
BRDERR DC AL1(L'BRDERRMS) 00600000
BRDERRMS DC C'ERROR ''...'' READING FILE ''....................'' FR*00601000
OM DISK' 00602000
SPACE 1 00603000
CIOERR DC AL1(L'CIOERRMS) 00604000
CIOERRMS DC C'ERROR ''...'' PUNCHING FILE ''....................''' 00605000
SPACE 1 00606000
INV DC AL1(L'INVMS) 00607000
INVMS DC C'DEVICE ''00D'' INVALID OR NONEXISTENT' 00608000
SPACE 1 00609000
UNS DC AL1(L'UNSMS) 00610000
UNSMS DC C'DEVICE ''00D'' UNSUPPORTED DEVICE TYPE' 00611000
SPACE 1 00612000
BADOPT DC AL1(L'BADOPTMS) 00613000
BADOPTMS DC C'INVALID OPTION ''........''' 00614000
SPACE 1 00615000
BADPARM DC AL1(L'BADPARMS) 00616000
BADPARMS DC C'INVALID PARAMETER ''........'' IN THE OPTION ''.......*00617000
.'' FIELD' 00618000
SPACE 1 00619000
MEMNF DC AL1(L'MEMNFMS) 00620000
MEMNFMS DC C'MEMBER ''........'' NOT FOUND' 00621000
EJECT 00622000
********************************************************************** 00623000
* 00624000
* RETURNS 00625000
* 00626000
********************************************************************** 00627000
SPACE 1 00628000
NORMRET SR R15,R15 CLEAR RETURN FOR NORMAL END 00629000
SPACE 1 00630000
CLOSRET LR R6,R15 SAVE RETURN CODE IN R6 00631000
L R8,BUFCTR ADDR OF NEXT LOC IN BUFFER 00632000
LA R3,BUFDATA ADDR OF START OF BUFFER 00633000
CR R3,R8 IS BUFFER EMPTY? 00634000
BE BUFMT YES, NO RESIDUAL DATA TO PUNCH 00635000
LM R3,R4,CCWNOP NO, PUT NOP AT END OF BUFFER 00636000
STM R3,R4,0(R8) ... 00637000
LA R1,BUFPUN ADDRESS OF PLIST TO PUNCH BUFFER 00638000
SVC 202 00639000
DC AL4(BUFERR) 00640000
BUFMT LA R3,BUFDATA RESTORE COUNTER TO BUFFER BEGINNING 00641000
SR R4,R4 AND ZERO BATCTR 00642000
STM R3,R4,BUFCTR ... 00643000
LR R15,R6 00644000
SPACE 1 00645000
CLOSRET1 LR R6,R15 SAVE RETURN CODE IN R6 00646000
LA R1,CLOSIO SET UP TO CLOSE PRINTER 00647000
MVC CLOSION(16),FILENAME NAME OF FILE BEING OUTPUT 00648000
SVC 202 00649000
DC AL4(*+4) IGNORE ERRORS 00650000
LR R15,R6 00651000
SPACE 1 00652000
FINRET LR R6,R15 SAVE RETURN CODE IN R6 00653000
MVC FILECOMM(8),=CL8'FINIS' SET TO CLOSE FILE 00654000
LA R1,FILE ADDRESS OF FILE PLIST 00655000
L R15,AFINIS FINIS @V305066 00656000
BALR R14,R15 ... @V305066 00656100
TM SWS,MEMB IF MEMBER OPTION, RELEASE STG 00658000
BZ NOFRET 00659000
L R1,STRADR ADDRESS OF MEMBER STG 00660000
L R0,STRLEN LENGTH OF MEMBER STG 00661000
DMSFRET DWORDS=(0),LOC=(1) 00662000
SPACE 1 00663000
NOFRET LR R15,R6 RESTORE RETURN CODE 00664000
SPACE 1 00665000
ERRET L R14,UIOSAVE RESTORE RETURN ADDRESS 00666000
BR R14 00667000
EJECT 00668000
********************************************************************** 00669000
* 00670000
* STORAGE AREAS AND PLISTS 00671000
* 00672000
********************************************************************** 00673000
SPACE 1 00674000
FILE DS 0D 00675000
FILECOMM DC CL8' ' FILE SYSTEM COMMAND 00676000
FILENAME DC CL8' ' FILENAME 00677000
FILETYPE DC CL8' ' FILETYPE 00678000
FILEMODE DC CL2' ' FILEMODE 00679000
FILEITNO DC H'0' RECORD NUMBER 00680000
FILEBUFF DC A(*-*) BUFFER ADDRESS 00681000
FILESIZE DC A(80) BUFFER SIZE 00682000
FILEFV DC CL2'F' FIXED/VARIABLE FLAG 00683000
FILENOIT DC H'1' NUMBER OF RECORDS 00684000
FILENORD DC F'0' NUMBER OF BYTES READ 00685000
DC 8X'FF' 00686000
SPACE 1 00687000
CLOSIO DS 0D 00688000
DC CL8'CP' 00689000
DC CL8'CLOSE' 00690000
DC CL8'00D' 00691000
DC CL8'NAME' 00692000
CLOSION DS 16C 00693000
DC 8X'FF' 00694000
SPACE 1 00695000
BUFPUN DC CL8'DMSCIOSI' 00696000
DC A(BUFCTR) ADDRESS OF BUFFER FOR DMSCIOSI 00697000
DC A(*-*) 00698000
DC 8X'FF' 00699000
SPACE 1 00700000
CCWNOP CCW X'03',0,X'20',1 00701000
CCWCNT DC XL4'60000050' RIGHT HALF OF WRITE CCW 00702000
SPACE 1 00703000
BBUF DC CL80' ' 00704000
MEMBUF DS CL80 00705000
MEMFILE DC A(1,MEMBUF) 00706000
SPACE 1 00707000
SCANFO DS 0F 00708000
DC X'FFFFFFFF5C4040404D404040' WORDS OF FF,*,( 00709000
AMODE DC X'C1400000' 00710000
BITS DC F'1' 00711000
H12 DC H'12' 00712000
SWS DS 1C SWITCHES 00713000
MEMB EQU X'08' PRINT LIBRARY MEMBER(S) 00714000
NAME EQU X'04' MEMBER NAME GIVEN 00715000
HEAD EQU X'02' HEADER CARD WANTED (DEFAULT) 00716000
NOHDR EQU X'01' NO HEADER CARD WANTED 00717000
SPACE 1 00718000
NAME1 DS 8C NAME OF MEMBER 00719000
DICTADR DS 1F 00720000
DICTLEN DS 1F 00721000
DICTEND DS 1F 00722000
STRADR DS 1F 00723000
STRLEN DS 1F 00724000
SPACE 1 00725000
PCHDR DC C':READ ' 00726000
TPAT DC X'4021207A2020' 00727000
DPAT DC X'402120612020' 00728000
PUNFST DC A(*-*) ADDRESS OF FST FOR THIS FILE @VA01108 00728100
SPACE 1 00729000
LIMIT DC A(BUFCTR+3990) 00730000
SPACE 1 00731000
LTORG 00732000
EJECT 00733000
ORG PUNCH+4096 00734000
PAGETWO EQU * 00735000
BUFCTR DC A(BUFDATA) 00736000
BATCTR DC A(*-*) 00737000
DS 2F 00738000
BUFDATA DS 500D 00739000
EJECT 00740000
********************************************************************** 00741000
* 00742000
* DSECTS 00743000
* 00744000
********************************************************************** 00745000
SPACE 1 00746000
UIOSECT DSECT 00747000
UIOSAVE DS 1F RETURN REGISTER SAVE AREA 00748000
UIODIAG DS 0F DIAGNOSE 24 STORAGE AREA 00749000
UIOVTYPC DS 1C VIRTUAL DEVICE TYPE CLASS 00750000
CLASURI EQU X'20' UNIT RECORD INPUT DEVICE 00751000
CLASURO EQU X'10' UNIT RECORD OUTPUT DEVICE 00752000
UIOVTYPE DS 1C VIRTUAL DEVICE TYPE 00753000
TYPRDR EQU X'80' CARD READER 00754000
TYPPUN EQU X'80' CARD PUNCH 00755000
TYP1403 EQU X'41' PRINTER - 1403 00756000
TYP3211 EQU X'42' PRINTER - 3211 00757000
UIOVSTAT DS 1C VIRTUAL DEVICE STATUS 00758000
UIOVFLAG DS 1C VIRTUAL DEVICE FLAGS 00759000
EJECT 00760000
FVS 00761000
NUCON 00762000
ADT 00763000
REGEQU 00764000
END 00765000