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 * IF NOT GIVEN, 'A ' IS USED 00019000 * NEEDED IF OPTIONS GIVEN 00020000 * (OPTIONS IN SUCCESSIVE 00021000 * 'CL8' GROUPS) 00022000 * 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