LST TITLE 'DMSLST (CMS) VM/370 - RELEASE 6' 00001000 SPACE 2 00002000 *. 00007000 * 00008000 * MODULE NAME: 00009000 * 00010000 * DMSLST (LISTFILE) 00011000 * 00012000 * FUNCTION: 00013000 * 00014000 * LISTFILE COMMAND. INFORMATION ABOUT THE SPECIFIED 00015000 * FILE(S) IS OUTPUT FOR THE USER. 00016000 * 00017000 * ATTRIBUTES: 00018000 * 00019000 * DISK RESIDENT, TRANSIENT 00020000 * NOTE: LISTFILE MUST BE GENMOD'D WITH THE SYSTEM OPTION 00020100 * 00021000 * ENTRY POINTS: 00022000 * 00023000 * DMSLSTA (LISTFILE) - INPUT LINE FROM THE TERMINAL. 00024000 * 00025000 * ENTRY CONDITIONS: 00026000 * 00027000 * LIST - 00028000 * GPR1 = A(PLIST) 00029000 * GPR14 = A(CALLED ROUTINE) 00030000 * PLIST = CL8 - CALLED ROUTINE 00031000 * CL8 - FILENAME|* 00032000 * CL8 - FILETYPE|* 00033000 * CL8 - FILEMODE|*|BLANK 00034000 * 00035000 * OPTIONAL AND IN ANY ORDER: 00036000 * CL8'(' 00037000 * CL8'FMODE'|'FTYPE'|'FNAME' 00038000 * CL8'DATE' 00039000 * CL8'FORMAT' 00040000 * CL8'FULLDATE|SHORTDATE|ISODATE' HRC005DS 00040500 * CL8'ALLOC' 00041000 * CL8'EXEC|APPEND' 00042000 * CL8'HEADER'|'NOHEADER' 00043000 * CL8'LABEL' 00044000 * CL8'STACK' HRC321DS 00044100 * CL8'FIFO ' 'LIFO' HRC321DS 00044200 * 00045000 * XL8 - FENCE 00046000 * 00047000 * EXIT CONDITIONS: 00048000 * 00049000 * NORMAL - 00050000 * GPR15 = 0 : LIST IS OUTPUT CORRECTLY 00051000 * 00052000 * ERROR - 00053000 * GPR15 = XXX : ERRORS OCCURRED 00054000 * 24 INVALID PARAMETER/OPTION, CONFLICTING OPTIONS 00055000 * 28 FILE NOT FOUND, INVALID FILEMODE 00056000 * 36 DISK NOT ACCESSED, DISK NOT READ-WRITE 00057000 * 00058000 * CALLS TO OTHER ROUTINES: 00059000 * 00060000 * DMSLAD - FIND THE ACTIVE DISK TABLE BLOCK MATCHING 00061000 * THE MODE SPECIFIED 00062000 * 00063000 * DMSLADN - FIND THE NEXT ADT BLOCK IN THE ACTIVE DISK 00064000 * TABLE 00065000 * 00066000 * DMSCWR - TYPE A LINE OF FILE INFORMATION AT THE USER'S 00067000 * TERMINAL 00068000 * 00069000 * DMSERS - DELETE THE SPECIFIED FILE 00070000 * 00071000 * DMSFNSA - CLOSE THE SPECIFIED FILE 00072000 * 00073000 * DMSBWR - WRITE THE SPECIFIED FILE OUT ON DISK 00074000 * 00075000 * DMSERR - TYPE AN ERROR MESSAGE AT THE USER CONSOLE 00076000 * 00077000 * EXTERNAL REFERENCES: 00078000 * 00079000 * ADT - ACTIVE DISK TABLE 00080000 * 00081000 * TABLES/WORKAREAS: 00082000 * 00083000 * NONE 00084000 * 00085000 * REGISTER USAGE: 00086000 * 00087000 * GPR1 = A(PLIST) 00088000 * GPR12 = BASE REGISTER 00089000 * 00090000 * NOTES: 00091000 * 00092000 * LISTFILE is treated as a "command" or a "function" HRC309DS 00093000 * according to the high-order byte of R1 at input, viz: HRC309DS 00093050 * If = x'0B', it was issued as a command from DMSINT. HRC309DS 00093100 * If = X'0D', it was issued from an EXEC FILE (DMSEXT), HRC309DS 00093150 * with "&CONTROL" set to either "CMS" or "ALL". HRC309DS 00093200 * If = x'01', it was issued from an EXEC file (DMSEXT), HRC309DS 00093250 * with "&CONTROL OFF" in effect. HRC309DS 00093300 * Otherwise, it is assumed to be a function. HRC309DS 00093350 * HRC309DS 00093400 * If DMSLST is called as a function, all error messages HRC309DS 00093450 * are ommitted. Also, if LISTFILE is called from EXEC HRC309DS 00093500 * with "&CONTROL OFF" in effect, the "file not found" HRC309DS 00093550 * error message is omitted. HRC309DS 00093600 * 00094000 * OPERATION: 00095000 * 00096000 * THE DISK(S) SEARCHED FOR THE GIVEN FILE(S) ARE 00097000 * DETERMINED BY DMSLSTA AS FOLLOWS: 00098000 * 00099000 * 1. IF FILEMODE IS GIVEN, DMSLAD IS CALLED TO 00100000 * REFERENCE THE GIVEN DISK; IF FOUND, DMSLSTA 00101000 * SEARCHES THE DIRECTORY TO FIND THE GIVEN 00102000 * FILE(S). IF NOT FOUND BY DMSLAD, I.E., THE DISK 00103000 * IS NOT LOGGED IN, AN ERROR IS RETURNED. 00104000 * 00105000 * 2. IF THE FILEMODE IS OMITTED, DMSLADN IS CALLED 00106000 * (REPEATEDLY IF NECESSARY), AND DMSLSTA SEARCHES 00107000 * THE PRIMARY DISK AND ALL ITS EXTENSIONS, 00108000 * TO FIND THE GIVEN FILE(S). 00109000 * 00110000 * 3. IF THE FILEMODE WAS GIVEN AS ASTERISK (*), THEN 00111000 * DMSLADN IS 00112000 * CALLED AS ABOVE, AND ALL DISKS, READ-WRITE AND 00113000 * READ-ONLY, 00114000 * ARE SEARCHED BY DMSLSTA FOR THE GIVEN FILE(S). 00115000 * 00116000 * WHEN DMSLSTA, IN SCANNING A PARTICULAR FST TABLE AS 00117000 * OBTAINED FROM DMSLAD OR DMSLADN, FINDS AN FST ENTRY 00118000 * WHOSE FILENAME AND FILETYPE SATISFY THE 00119000 * PARAMETER LIST, IT MOVES THE FILENAME, FILETYPE, 00120000 * FILEMODE, AND ANY OTHER REQUESTED INFORMATION FROM 00121000 * THAT FILE STATUS TABLE TO THE BUFFER. IF THE EXEC 00122000 * OPTION IS NOT REQUESTED, IT THEN CALLS 00123000 * DMSCWR TO TYPE THE CONTENTS OF THE BUFFER AT THE 00124000 * TERMINAL. (THE OUTPUT LINES MAY BE PRECEDED BY AN 00125000 * APPROPRIATE HEADING.) 00126000 * DMSLSTA REPEATS THIS PROCEDURE FOR EACH FILE STATUS 00127000 * TABLE SATISFYING THE FILENAME AND FILETYPE LISTING 00128000 * REQUIREMENTS. 00129000 * WHEN SCAN OF ALL PARTICIPATING FILE STATUS TABLES IS 00130000 * COMPLETED, DMSLSTA RETURNS TO THE CALLER. 00131000 * 00132000 * If the STACK option is specified, the output is HRC321DS 00132025 * placed in the stack in FIFO order. The STACK option HRC321DS 00132050 * implies the NOHEADER option. HRC321DS 00132075 * HRC321DS 00132100 * If the FIFO option is specified, the output is placed HRC321DS 00132125 * in the stack in FIFO order. The FIFO option implies HRC321DS 00132150 * the NOHEADER option. HRC321DS 00132175 * HRC321DS 00132200 * If the LIFO option is specified, the output is placed HRC321DS 00132225 * in the stack in LIFO order. The LIFO option implies HRC321DS 00132250 * the NOHEADER option. HRC321DS 00132275 * HRC321DS 00132300 * IF THE EXEC OPTION IS REQUESTED, THE CONTENTS OF THE 00133000 * BUFFER ARE NOT WRITTEN TO THE TERMINAL. INSTEAD, A 00134000 * CMS EXEC FILE, CONTAINING THE DUMMY ARGUMENTS "&1 &2" 00135000 * FOLLOWED BY THE BUFFER CONTENTS IS CREATED. THIS 00136000 * FILE MAY LATER BE ACCESSED BY THE EXEC PROGRAM, WHICH 00137000 * WILL REPLACE THE DUMMY ARGUMENTS. 00138000 * 00139000 * THE APPEND OPTION IS PRINCIPALLY THE SAME AS THE 00140000 * EXEC OPTION IN ITS MANNER OF EXECUTION, BUT WHEREAS 00141000 * THE EXEC OPTION WILL ERASE AN EXTANT CMS EXEC FILE, 00142000 * APPEND CAUSES NEW INFORMATION TO BE PLACED INTO SUCH 00143000 * A FILE. IF A 'CMS EXEC FILE DOES NOT EXIST WHEN THE 00144000 * APPEND OPTION IS SPECIFIED, ONE WILL BE CREATED -- IN 00145000 * A MANNER IDENTICAL TO HAVING SPECIFIED THE EXEC OPTION. 00146000 * 00147000 * THERE IS A VARIED AMOUNT OF INFORMATION THAT THE USER 00148000 * MAY REQUEST BE TYPED OR PLACED INTO CMS EXEC FILE. 00149000 * THE INFORMATION IS SERIALLY PRODUCED; I.E., IF THE 00150000 * DATA FROM THE RIGHTMOST COLUMNS ARE WANTED, THE DATA 00151000 * UP TO THOSE COLUMNS WILL BE PROVIDED. 00152000 * 00153000 * THE DEFAULT AMOUNT OF INFORMATION IS FILENAME, 00154000 * FILETYPE, FILEMODE, WITH NOHEADER. IF MORE 00155000 * INFORMATION IS REQUESTED, BY SPECIFYING FORMAT, 00156000 * ALLOC, DATE, OR LABEL, HEADER BECOMES THE DEFAULT 00157000 * OPTION. 00158000 * 00159000 * IF FORMAT IS ENTERED, THE RECORD FORMAT OF THE FILE, 00160000 * FIXED OR VARIABLE, AND THE LOGICAL RECORD LENGTH WILL 00161000 * BE PROVIDED. 00162000 * 00163000 * IF ALLOC IS ENTERED, THE AMOUNT OF DISK SPACE THAT 00164000 * CMS HAS ALLOCATED TO THE FILE IN TERMS OF BOTH THE 00165000 * NUMBER OF PHYSICAL BLOCKS USED, AND THE NUMBER OF 00166000 * LOGICAL RECORDS WITHIN THE FILE WILL BE PROVIDED. 00167000 * 00168000 * IF DATE IS ENTERED, THE CREATION DATE (MM/DD/YY) AND 00169000 * TIME (HH.MM) OF THE FILE WILL BE PROVIDED. 00170000 * 00171000 * IF LABEL IS ENTERED, THE VOLSER OF THE DISK UPON 00172000 * WHICH THE FILE RESIDES WILL BE INCLUDED AS THE FINAL 00173000 * ITEM. 00174000 * 00175000 * ALL OF THE ABOVE INFORMATION, EXCEPT DISK LABEL, 00176000 * COMES FROM THE FILE STATUS TABLE (FST) FOR THE 00177000 * RESPECTIVE FILE. THE DISK LABEL IS OBTAINED FROM THE 00178000 * ACTIVE DEVICE TABLE (ADT) FOR THAT DISK. 00179000 * 00180000 *. 00181000 EJECT 00182000 MACRO 00183000 &LOC OPTION &NAME,&MIN,&ADDR 00184000 LCLA &M,&L 00185000 LCLC &A 00186000 &M SETA 1 00187000 AIF (N'&MIN EQ 0).SEQ1 00188000 &M SETA &MIN 00189000 .SEQ1 ANOP 00190000 &L SETA K'&NAME 00191000 &A SETC '&NAME' 00192000 AIF (N'&ADDR EQ 0).SEQ2 00193000 &A SETC '&ADDR' 00194000 .SEQ2 ANOP 00195000 &LOC DC AL1(&M,&L),CL8'&NAME',AL2(&A-LISTFILE) 00196000 MEND 00197000 SPACE 3 00198000 DMSLST START 0 00199000 LISTFILE EQU * 00200000 USING NUCON,R0 00201000 LR R12,15 SET UP A BASE REGISTER 00202000 USING LISTFILE,R12 00203000 SSM OK81 00204000 ST R14,RETREG AND SAVE THE RETURN REGISTER 00205000 ST R1,SAVEDR1 AND SAVE R1 VALUE AT INPUT @VM01710 00205100 SR R15,R15 NOW BUILD A DEFAULT SIGNAL 00206000 MVC DESMODE(2),DMODE INITIALIAZE THE MODE FIELD 00207000 MVC ERRADDR(4),=A(ERRADDR+4) ASSUME NOT EXEC OPTION. P3017 00208000 MVI FLAG,HEADINIT INITIALIZE FLAG V0028 00209150 MVI FLAG2,X'00' HRC005DS 00209550 MVI COMNAME+1,X'07' ASSUME AN 8-BYTE FILENAME 00210000 MVI COMTYPE+1,X'07' AND 8-BYTE FILETYPE 00211000 LA R2,NAMESTAR BUT ALLOW THAT NEITHER IS SPECIFIED 00212000 LA R3,PARMCKN THOUGH THERE MAY BE A FILENAME 00213000 SCAN LA R1,8(,R1) LET'S PEEK AHEAD A BIT 00214000 CLI 0(R1),C'(' OPTIONS START YET? 00215000 BE OPTSCAN SORT THEM OUT, IF YES. 00216000 CLI 0(R1),X'FF' ARE WE DONE YET? 00217000 BCR 8,R2 YES. THEN GO WHEREVER 00218000 BR R3 NO. THEN ELSEWHERE 00219000 EJECT 00220000 *********************************************************************** 00221000 * 00222000 * SCAN FILENAMES, FILETYPES, AND FILEMODES 00223000 * 00224000 *********************************************************************** 00225000 PARMCKN LA R4,COMNAME+1 POINT TO COMPARISON FOR FILENAME 00226000 LA R2,TYPESTAR RESET THE DEFAULT VECTOR 00227000 LA R3,PARMCKT RESET THE NEXT SCAN POINTER 00228000 LA R8,NAME1 POINT TO A HOLDING FIELD 00229000 LA R9,1 SET UP A FLAG (FOR LATER) 00230000 B PC0 NOW, JOIN THE COMMON ROUTINE 00231000 PARMCKT LA R4,COMTYPE+1 POINT TO COMPARISON FOR FILETYPE 00232000 LA R2,JOIN RESET THE DEFAULT VECTOR 00233000 LA R3,PARMCKM RESET THE NEXT SCAN POINTER 00234000 LA R8,NAME2 POINT TO A HOLDING FIELD 00235000 PC0 LR R5,R1 SAVE THE POINTER 00236000 LA R6,7 SET UP MAXIMUM LENGTH INDICATOR 00237000 SR R7,R7 EMPTY OUT A WORK REGISTER 00238000 CLI 0(R5),C'*' IS IT "ANY"? 00239000 BNE PC1 NO. THEN LET'S SEE WHAT 00240000 CLI 1(R5),C' ' IS IT LEGAL? 00241000 BNE ERR2 NO! BUT THAT MEANS WE CAN'T FIND IT. SO.. 00242000 B NOCONCAT JUST AN ASTERISK 00243000 PC1 CLI 1(R5),C'*' LOOKING FOR A CONCATENATED FORM? 00244000 BNE UPCOUNT NOT YET. 00245000 CR R9,R6 YES. BUT HOW LONG 00246000 BE CONCAT ALMOST MAXIMUM 00247000 CLI 2(R5),C' ' IS IT IMBEDDED? 00248000 BE CONCAT OTHERWISE, WE CAN'T FIND IT ANYWAY 00249000 UPCOUNT CLI 1(R5),C' ' IS IT THE END YET? 00250000 BE NOCONCAT YES. 00251000 LA R5,1(,R5) TRY THE NEXT CHARACTER POSITION 00252000 LA R7,1(,R7) UP THE COUNT SCANNED ALREADY 00253000 BCT R6,PC1 DECREMENT THE COUNT ALLOWABLE 00254000 B NOCONCAT ? GUESS WE'RE DONE. 00255000 CONCAT STC R7,0(,R4) PUT THIS NUMBER WHERE NEEDED 00256000 NOCONCAT EX R7,MOVEM PUT COMPUTED FORM IN THE HOLDING FIELD 00257000 B SCAN NOW, BACK FOR MORE 00258000 PARMCKM CLI 2(R1),C' ' DID WE GET MORE THAN 2 CHARACTERS V0205 00259100 BNE ERR6 YES. DEFINITELY AN ERROR 00260000 OI FLAG,USERMODE SIGNAL NOT DEFAULT MODE V0042 00260100 MVC DESMODE(2),0(R1) SAVE WHATEVER IT IS 00261000 LA R3,ERR1 SET UP THE NEXT SCAN EXIT-POINTER 00263000 B SCAN AND OFF WE GO AGAIN 00264000 SPACE 00265000 MOVEM MVC 0(8,R8),0(R1) (EXECUTED MOVE FOR FN & FT) 00266000 EJECT 00267000 *********************************************************************** 00268000 * 00269000 * OPTION SCANNING ROUTINE 00270000 * 00271000 *********************************************************************** 00272000 SPACE 2 00273000 OPTSCAN LA R4,8(,R1) GET FIRST ARGUMENT. 00274000 LR R11,R2 SAVE EXIT-ADDRESS. 00275000 LA R8,4 LOAD BXLE INCREMENT REGISTER. 00276000 LA R10,8 LOAD USEFUL '8' 00277000 USING TABIMAGE,R9 00278000 LA R9,LASTENT POINT TO END OF OPTION TABLE. 00279000 LA R9,BRAD BUT, BACKUP A BIT! 00280000 DROP R9 00281000 USING TABIMAGE,R2 00282000 SCANON LA R2,FIRSTENT POINT TO START OF OPTION TABLE 00283000 SR R6,R6 MAKE SURE THIS REGISTER IS EMPTY. 00284000 IC R6,TRUNCLEN GET LENGTH OF SHORTEST FORM OF OPTION 00285000 LA R2,OPT NOW POINT TO FULL FORM. 00286000 DROP R2 00287000 TRYNEXT CLI 0(R4),X'FF' IS/WAS THIS THE LAST PARAMETER? 00288000 BCR 8,R11 YES, THEN ON TO THE MAIN ROUTINE. 00289000 CLI 0(R4),C')' IS THIS GUY A PARENTHESIS NUT? 00290000 BNE NOTEND NO. 00291000 CLI 8(R4),X'FF' YES...DID HE SLIP IN AN EXTRA FIELD? 00292000 BCR 8,R11 NO. THEN, WE'RE DONE. 00293000 LA R1,8(,R4) WELL, THAT'S NOT TOO GOOD. 00294000 B ERR1 GIVE HIM A SLAP ON THE WRIST. 00295000 NOTEND LR R3,R10 GET MAXIMUM SCAN LENGTH. 00296000 LR R5,R3 ...FOR BOTH. 00297000 CLCL R2,R4 SCAN AWAY. 00298000 BE MATCH IF EQUAL, GO HANDLE. 00299000 CLI 0(R4),C' ' ALMOST EQUAL? 00300000 BE MAYBEOK YES. GO SEE IF IT IS ENOUGH. 00301000 WASNT AR R4,R5 POINT TO THE END OF THE SCANNED OPTION. 00302000 SR R4,R10 NOW BACKUP SO THAT WE CAN TRY AGAIN. 00303000 AR R2,R3 POINT TO END OF THE OPTION IN THE TABLE 00304000 IC R6,2(,R2) GET MINIMUM LENGTH OF NEXT TABLE ENTRY. 00305000 BXLE R2,R8,TRYNEXT WHIP THROUGH THE TABLE. 00306000 B ERR4 NOW GO SHOW HIM WHAT HE ENTERED. 00309000 MAYBEOK AR R6,R5 ADD SCANNED LENGTH TO MINIMUM REQUIRED. 00310000 CR R10,R6 COMPARE TO MAXIMUM TOKEN LENGTH. 00311000 BL WASNT IF IT IS LOW, THERE IS NO MATCH. 00312000 MATCH AR R4,R5 POINT TO THE NEXT OFFERING. 00313000 AR R2,R3 POINT TO OFFSET FOR SPECIFIC HANDLER. 00314000 SR R3,R3 SET UP A SIGNAL REGISTER. 00315000 LH R2,0(,R2) NOW LOAD IT 00316000 AR R2,R12 AND TURN IT INTO SOMETHING USEFUL. 00317000 BALR R2,R2 GO THERE. 00318000 LTR R3,R3 ANYTHING REALLY HAPPEN OUT THERE? 00319000 BZ SCANON ONLY A FLAG WAS SET ON THIS PASS. 00320000 CR R15,R3 ANYTHING NEW OR BIGGER? 00321000 BNL SCANON NOPE. THEN WE'LL KEEP THE OLD SETTINGS. 00322000 LR R15,R3 OH, THEN WE BETTER SAVE THE NEW LENGTH. 00323000 LR R14,R6 ...AND THE NEW ENTRY ADDRESS. 00324000 B SCANON NOW WE CAN GO BACK FOR MORE. 00325000 EJECT 00326000 *********************************************************************** 00327000 * 00328000 * OPTION HANDLING ROUTINES 00329000 * 00330000 *********************************************************************** 00331000 SPACE 2 00332000 ALLOC LA R3,44 don't truncate "BLOCKS" HRC320DS 00333000 LA R6,PREC 00334000 BR R2 00335000 SPACE 00336000 APPEND TM FLAG,CMSEXEC 00337000 BO ERR7 00338000 OI FLAG,APPND 00339000 BR R2 00340000 SPACE 00341000 DT LA R3,61 HRC005DS 00342490 LA R6,PTIM 00343000 BR R2 00344000 SPACE 00345000 SHORTDAT EQU * HRC005DS 00345040 TM FLAG2,FLG2ISO HRC005DS 00345080 BO ERR8A HRC005DS 00345120 TM FLAG2,FLG2FULL HRC005DS 00345160 BO ERR8B HRC005DS 00345200 OI FLAG2,FLG2SHRT HRC005DS 00345240 B DT HRC005DS 00345280 FULLDATE EQU * HRC005DS 00345320 TM FLAG2,FLG2ISO HRC005DS 00345360 BO ERR8C HRC005DS 00345400 TM FLAG2,FLG2SHRT HRC005DS 00345440 BO ERR8B HRC005DS 00345480 OI FLAG2,FLG2FULL HRC005DS 00345520 B DT HRC005DS 00345560 ISODATE EQU * HRC005DS 00345600 TM FLAG2,FLG2FULL HRC005DS 00345640 BO ERR8C HRC005DS 00345680 TM FLAG2,FLG2SHRT HRC005DS 00345720 BO ERR8A HRC005DS 00345760 OI FLAG2,FLG2ISO HRC005DS 00345800 B DT HRC005DS 00345840 EXEC TM FLAG,APPND 00346000 BO ERR7 00347000 OI FLAG,CMSEXEC 00348000 BR R2 00349000 SPACE 00350000 FIFO EQU * HRC321DS 00350050 OI FLAG2,FLG2STCK we are stacking output HRC321DS 00350100 TM FLAG,HEAD header specified already? HRC321DS 00350150 BO ERR8E yes, and this is a conflict HRC321DS 00350200 OI FLAG,NOHEAD no header by default HRC321DS 00350250 TM FLAG2,FLG2LIFI already processed LIFO/FIFO? HRC321DS 00350300 BNO FIFO1 no, so FIFO is valid HRC321DS 00350350 TM FLAG2,FLG2LIFO was the LIFO option specified? HRC321DS 00350400 BO ERR8D yes, complain about it HRC321DS 00350450 FIFO1 EQU * HRC321DS 00350500 OI FLAG2,FLG2FIFO remember FIFO HRC321DS 00350550 OI FLAG2,FLG2LIFI remember we did this HRC321DS 00350600 BR R2 return HRC321DS 00350650 SPACE 1 HRC321DS 00350700 FM LA R3,22 00351000 LA R6,PMOD 00352000 BR R2 00353000 SPACE 00354000 FN LA R3,8 00355000 LA R6,PNAM 00356000 BR R2 00357000 SPACE 00358000 FMT LA R3,30 00359000 LA R6,PFORM 00360000 BR R2 00361000 SPACE 00362000 FT LA R3,17 00363000 LA R6,PTYP 00364000 BR R2 00365000 SPACE 00366000 HDR TM FLAG,NOHEAD 00367000 BO ERR8 00368000 TM FLAG2,FLG2STCK are we stacking output? HRC321DS 00368100 BNO HDR2 no, proceed HRC321DS 00368200 TM FLAG2,FLG2FIFO was the FIFO option specified? HRC321DS 00368300 BO ERR8E yes, complain about it HRC321DS 00368400 TM FLAG2,FLG2LIFO was the LIFO option specified? HRC321DS 00368500 BO ERR8F yes, complain about it HRC321DS 00368600 HDR2 EQU * HRC321DS 00368700 OI FLAG,HEAD 00369000 NI FLAG,255-HEADINIT V0027 00369100 BR R2 00370000 SPACE 00371000 LABEL LA R3,69 better formatted header HRC320DS 00372490 LA R6,PLAB 00373000 BR R2 00374000 SPACE 00375000 LIFO EQU * HRC321DS 00375050 OI FLAG2,FLG2STCK we are stacking output HRC321DS 00375100 TM FLAG,HEAD header specified already? HRC321DS 00375150 BO ERR8F yes, and this is a conflict HRC321DS 00375200 OI FLAG,NOHEAD no header by default HRC321DS 00375250 TM FLAG2,FLG2LIFI already processed LIFO/FIFO? HRC321DS 00375300 BNO LIFO1 no, so LIFO is valid HRC321DS 00375350 TM FLAG2,FLG2FIFO was the FIFO option specified? HRC321DS 00375400 BO ERR8D yes, complain about it HRC321DS 00375450 LIFO1 EQU * HRC321DS 00375500 NI FLAG2,255-FLG2FIFO replace STACK default (FIFO) HRC321DS 00375550 OI FLAG2,FLG2LIFO remember LIFO HRC321DS 00375600 OI FLAG2,FLG2LIFI remember we did this HRC321DS 00375650 BR R2 return HRC321DS 00375700 SPACE 1 HRC321DS 00375750 NOHDR TM FLAG,HEAD 00376000 BO ERR8 00377000 OI FLAG,NOHEAD 00378000 NI FLAG,255-HEADINIT V0027 00378100 BR R2 00379000 SPACE 1 HRC321DS 00379050 STACK EQU * HRC321DS 00379100 TM FLAG2,FLG2STCK FIFO or LIFO already handled? HRC321DS 00379150 BO R2 no further work required HRC321DS 00379200 TM FLAG,HEAD header specified already? HRC321DS 00379250 BO ERR8G yes, and this is a conflict HRC321DS 00379300 OI FLAG,NOHEAD no header by default HRC321DS 00379350 OI FLAG2,FLG2STCK we are stacking output HRC321DS 00379400 OI FLAG2,FLG2FIFO stack FIFO by default HRC321DS 00379450 BR R2 return HRC321DS 00379500 EJECT 00380000 *********************************************************************** 00381000 * 00382000 * OPTION TABLE 00383000 * 00384000 *********************************************************************** 00385000 SPACE 00386000 FIRSTENT OPTION EXEC 00387000 SPACE 00388000 OPTION APPEND,2 00389000 SPACE 00390000 OPTION NOHEADER,3,NOHDR 00391000 SPACE 00392000 OPTION FNAME,2,FN 00393000 SPACE 00394000 OPTION FTYPE,2,FT P0132 00395000 SPACE 00396000 OPTION FORMAT,2,FMT P0132 00397000 SPACE 00398000 OPTION DATE,,DT 00399000 SPACE 00400000 OPTION SHORTDAT,3 HRC005DS 00400100 SPACE , HRC005DS 00400200 OPTION ISODATE,3 HRC005DS 00400300 SPACE , HRC005DS 00400400 OPTION FULLDATE,3 HRC005DS 00400500 SPACE , HRC005DS 00400600 OPTION ALLOC,2 00401000 SPACE 00402000 OPTION LABEL 00403000 SPACE 00404000 OPTION FIFO HRC321DS 00404050 SPACE 1 HRC321DS 00404100 OPTION LIFO HRC321DS 00404150 SPACE 1 HRC321DS 00404200 OPTION STACK HRC321DS 00404250 SPACE 1 HRC321DS 00404300 OPTION FMODE,2,FM P0132 00405000 SPACE 00406000 LASTENT OPTION HEADER,,HDR 00407000 EJECT 00408000 NAMESTAR MVC NAME1(8),=CL8'*' MOVE IN THE DEFAULT FILENAME. 00409000 TYPESTAR MVC NAME2(8),=CL8'*' MOVE IN THE DEFAULT FILETYPE. 00410000 JOIN LTR R15,R15 WERE ANY FORMATTING OPTIONS SPECIFIED? 00411000 BNZ JOIN0 IF YES, SKIP THE DEFAULTS. 00412000 IC R15,DFLTLEN GET THE DEFAULT PRINT LENGTH. 00413000 L R14,DFLTENT GET THE DEFAULT PRINT ENTRY ADDRESS. 00414000 JOIN0 STC R15,PRINTLEN SAVE THE PRINT LENGTH. 00415000 STC R15,DTYPELEN ALSO, PUT IT IN THE PLIST. 00416000 LR R11,R14 SAVE THE PRINT ROUTINE ENTRY. 00417000 MVI TYPLOC,C' ' ... 00418000 MVC TYPLOC+1(72),TYPLOC CLEAR THE BUFFER P3091 00419000 SR R9,R9 EMPTY A REGISTER. 00420000 TM FLAG,USERMODE DEFAULT MODE? V0042 00420100 BNO POINTA YES. V0042 00420150 CLI DESMODE+1,C' ' WAS MODE-NUMBER BLANK? 00421000 BE JOIN1 IF SO, SKIP THE CHECKING. 00422000 CLI DESMODE+1,C'0' IS IT LESS THAN ZERO? 00423000 BL ERR6A ERROR, IF IT IS. 00424000 CLI DESMODE+1,C'5' HIGHEST ALLOWABLE P0724 00425000 BH ERR6A WRONG, IF HIGHER. 00426000 OI FLAG,MODENUM SIGNAL THAT MODE MUST MATCH. 00427000 JOIN1 CLI DESMODE,C'*' WAS AN ASTERISK SPECIFIED? P0724 00428000 BNE CKLET NO. THEN KEEP CHECKING. P0724 00429000 TM FLAG,MODENUM WAS A MODE-NUMBER SPECIFIED? 00430000 BO ERR6A THAT'S NOT ALLOWED. 00431000 POINTA LA R1,DMODE-24 POINT TO A MODE-LETTER OF 'A'. V0042 00432100 B SEARCH GO GET A(ADT) 00433000 CKLET CLI DESMODE,C'A' COMPARE AGAINST MODE OF A. P0724 00434000 BL ERR6A ERROR IF LOW. P0724 00435000 CLI DESMODE,C'I' COMPARE AGAINST MODE OF I. HRC002DS 00436690 BNH FINDIT ERROR IF HIGH. HRC002DS 00437380 CLI DESMODE,C'J' COMPARE AGAINST MODE OF J. HRC002DS 00438070 BL ERR6A ERROR IF LOW. HRC002DS 00438760 CLI DESMODE,C'R' COMPARE AGAINST MODE OF R. HRC002DS 00439450 BNH FINDIT OK IT IF HIGH. HRC002DS 00440140 CLI DESMODE,C'S' COMPARE AGAINST MODE OF S. HRC002DS 00440830 BL ERR6A ERROR IF LOW. HRC002DS 00441520 CLI DESMODE,C'Z' COMPARE AGAINST MODE OF Z. HRC002DS 00442210 BH ERR6A ERROR IF HIGH. HRC002DS 00442900 FINDIT LA R1,DESMODE-24 POINT TO SUPPLIED MODE-LETTER. 00444000 SEARCH L R15,VCADTLKP GET ADDRESS OF DMSLAD. @VM03093 00445100 BALR R14,R15 GO THERE. 00446000 BNZ ERR6A ERROR, IF NOT FOUND. 00447000 LR R9,R1 SAVE ADDRESS OF THE ADT. 00448000 CLI DESMODE,C'*' WAS MODE AN ASTERISK? 00449000 BE TESTAPP WE'RE OK THEN. 00450000 USING ADTSECT,R9 00451000 TM ADTFLG1,ADTFRO+ADTFRW IS THE DISK ACCESSED? 00452000 BNZ TESTAPP YES, BRANCH @VA04384 00453100 TM ADTFLG2,ADTFROS CMS DISK ? @VA04384 00453200 BO ERR6A NO, INVALID MODE MESSAGE @VA04384 00453300 B ERR3 DISK ISN'T ACCESSED @VA04384 00453400 DROP R9 00454000 TESTAPP TM FLAG,APPND WAS APPEND SPECIFIED? 00455000 BO SETAPP DON'T ERASE 'CMS EXEC', IF IT WAS. 00456000 TM FLAG,CMSEXEC WAS EXEC SPECIFIED? 00457000 BNO JOIN2 SKIP THE FOLLOWING, IF NOT. 00458000 LA R1,ERASEP POINT TO THE ERASE PLIST. 00459000 L R15,AERASE GO ERASE 'CMS EXEC A1' @V305066 00460000 SSM OK00 ALLOW INTERRUPTS @VA06227 00460050 BALR R14,R15 (IF ANY) @V305066 00460100 SSM OK81 DON'T ALLOW INTERRUPTS @VA06227 00461000 SETAPP MVC TYPECMS(LWRB),DWRBUF SET UP THE WRBUF PLIST. 00462000 MVC ERRADDR(4),=A(ERR9) BE PREPARED FOR WRBUF ERROR. P3017 00463000 LA R1,DMODE-24 POINT TO MODE-LETTER 'A'. 00464000 L R15,VCADTLKP GET ADDRESS OF DMSLAD. @VM03093 00465100 BALR R14,R15 GO THERE. 00466000 USING ADTSECT,R1 00467000 TM ADTFLG1,ADTFRO+ADTFRW IS THE A DISK ACCESSED @VA14113 00467500 BNZ ADISK YES. @VA14113 00467520 MVC DESMODE(2),DMODE SET UP A MODE IN MSG. @VA14113 00467540 B ERR3 A DISK ISN'T ACCESSED. @VA14113 00467560 ADISK EQU * @VA14113 00467580 TM ADTFLG1,ADTFRW IS THE A-DISK READ-WRITE? 00468000 BNO ERR5 MUST BE...SO, ERROR, IF NOT. 00469000 B JOIN3A GET COMMON, NOW. V0028 00470100 DROP R1 00471000 JOIN2 MVC TYPECMS(16),DTYPECMS SET UP TYPLIN PLIST. 00472000 JOIN3A CLI DESMODE,C'*' WAS MODE AN ASTERISK? 00477000 USING ADTSECT,R9 00478000 BNE JOIN6 NO? THEN GO SEE WHAT IS THERE. 00479000 LA R13,ADTFRO+ADTFRW SIGNAL THAT WE'LL TAKE ANYTHING. 00480000 B CKSTAT CHECK IT OUT. 00481000 JOIN4 LR R1,R9 GET THE LAST ADDRESS. 00482000 JOIN5 L R15,VCADTNXT SET UP TO FIND NEXT. @VM03093 00483100 BALR R14,R15 NOW, GO FIND IT. 00484000 BNZ FINI ALL DONE IF COND. CODE IS NON-ZERO. 00485000 LR R9,R1 SAVE THAT ADDRESS. 00486000 CKSTAT EX R13,DTM IS IT THE KIND WE'RE LOOKING FOR? 00487000 BZ JOIN5 IF NOT, KEEP TRYING. 00488000 JOIN6 L R6,ADTFDA START WITH THE FIRST HYPERBLOCK. 00489000 SR R3,R3 EMPTY OUT A REGISTER. 00490000 SR R7,R7 AND ANOTHER. 00491000 L R4,0(,R6) SET INDICES FOR BXLE-LOOP. 00492000 L R5,4(,R6) ... 00493000 SR R5,R4 ... 00494000 LA R6,8(,R6) SET POINTER TO START OF TABLE. 00495000 LOOP CL R7,0(R6,R3) IS THERE AN ENTRY? 00496000 BE BUMP NO. GO TRY ANOTHER ONE. 00497000 LA R8,0(R6,R3) GET ACTUAL ADDRESS. 00498000 TM FLAG,MODENUM CARE ABOUT MODE-NUMBERS? 00499000 BNO CLINAM NO. HOW 'BOUT FILENAMES? 00500000 CLC 25(1,R8),DESMODE+1 DOES THE NUMBER MATCH? 00501000 BNE BUMP NO...TRY ANOTHER. 00502000 CLINAM CLI NAME1,C'*' ANY FILENAME DO? 00503000 BE WHATYPE YES. HOW 'BOUT FILETYPE? 00504000 COMNAME CLC NAME1(8),0(R8) IS WHAT WE'VE GOT, WHAT HE WANTS? 00505000 BNE BUMP NOPE. TRY AGAIN. 00506000 WHATYPE CLI NAME2,C'*' ANYONE CARE WHAT THE FILETYPE IS? 00507000 BE PRINT NO? LET'S SHOW THIS ONE,THEN. 00508000 COMTYPE CLC NAME2(8),8(R8) DOES THE TYPE MATCH? 00509000 BE PRINT YES. SHOW IT. 00510000 BUMP BXLE R3,R4,LOOP KEEP LOOKING. 00511000 L R6,0(R6,R3) IS THERE AN EXTENSION? 00512000 SR R3,R3 INITIALIZE (JUST IN CASE) 00513000 LTR R6,R6 WELL? 00514000 BNZ LOOP SEARCH THROUGH EXTENSION. 00515000 CLI DESMODE,C'*' ANY MODE DO? 00516000 BE JOIN4 YES. LET'S FIND ANOTHER. 00517000 TM FLAG,FOUNDIT DID WE EVER FIND ANYTHING? 00520000 BO DONE YES. LET'S FINISH UP THEN. 00521000 B ERR2 TSK. TSK. 00522000 SPACE 00523000 DTM TM ADTFLG1,*-* EXECUTED MODE CHECKER 00524000 EJECT 00525000 PRINT TM FLAG,NOHEAD+FOUNDIT HAVE WE COME THIS WAY BEFORE? 00526000 BC 5,HEADN SKIP THIS STUFF IF WE HAVE. 00527000 CLI TYPECMS,C'W' ARE WE WRBUF'ING? 00528000 BE HEADN YES, NO HEADING REQUIRED. 00529000 TM FLAG,HEADINIT ANY USER HEADING REQUEST. V0027 00530100 BNO PHEAD IF SO, HONOR IT. V0027 00530150 CLI PRINTLEN,X'16' DO WE EXCEED STANDARD V0027 00530200 BNH HEADN OK THEN. V0027 00530250 PHEAD SR R1,R1 SIGNAL V0027 00530300 IC R1,PRINTLEN GET HEADING LENGTH. 00531000 EX R1,HDMVC PUT HEADING INTO BUFFER. 00532000 LA R1,TYPECMS LOAD ADDRESS OF PLIST. 00533000 SPACE 1 HRC321DS 00533050 TM FLAG2,FLG2FIFO should we stack header instead? HRC321DS 00533100 BO PRNFIFO yes, FIFO HRC321DS 00533150 TM FLAG2,FLG2LIFO should we stack header LIFO? HRC321DS 00533200 BNO PRINTIT no, just type it HRC321DS 00533250 MVC FIFOLIFO(4),=C'LIFO' HRC321DS 00533300 B PRSTACK HRC321DS 00533350 PRNFIFO EQU * HRC321DS 00533400 MVC FIFOLIFO(4),=C'FIFO' HRC321DS 00533450 PRSTACK EQU * set up the parameter list HRC321DS 00533500 MVC STACKLEN(1),CHARB+3 HRC321DS 00533550 MVC STACKADR(3),BUFLOC HRC321DS 00533600 LA R1,STACK HRC321DS 00533650 SPACE 1 HRC321DS 00533700 PRINTIT EQU * HRC321DS 00533750 SVC X'CA' TYPE! 00534000 MVI MODE-1,C' ' NOW CLEAN UP... 00535000 MVC MODE(57),MODE-1 ... THE BUFFER. 00536000 HEADN CLC CMSX(16),0(R8) WAS IT 'CMS EXEC'? 00537000 BNE OTHER NO? NO SWET. 00538000 CLI ADTM,C'A' ON THE 'A' DISK? @VA03537 00538100 BNE OTHER NOPE, ALL RIGHT @VA03537 00538200 CLI TYPECMS,C'W' ARE WE WRITING AN EXEC FILE? 00539000 BE BUMP O FIND SOMETHING ELSE. 00540000 OTHER MVC DATE(15),DATE-1 CLEAR OUT END OF BUFFER. 00541000 OI FLAG,FOUNDIT BRAG ABOUT FINDING SOMETHING. 00542000 BR R11 GO TO THE WRITE PLACE. 00543000 * 00544000 PLAB EQU * HRC005DS 00545290 MVC VOLID(6),ADTID MOVE IN THE VOLUME LABEL. HRC005DS 00545580 PTIM EQU * TIME 00546000 LA R10,TIME SET REC BUFFER HRC005DS 00546500 LA R1,18(,R8) SET TIME LOCATION 00547000 LA R14,TPATRN SET PATTERN BUFFER 00549000 CLI 0(R1),X'24' VALID TIME? 00552000 BNH NOTIME1 VALID. 00553000 NOTIME SR R1,R1 SIGNAL INVALID TIME. BLANK OUT. 00554000 NOTIME1 BAL R15,VERIFY GO VERIFY LEGIT TIME 00555000 PDATE EQU * 00556000 LA R1,16(,R8) 00562000 LA R10,CHARDATE HRC005DS 00563490 LA R14,DPATRN 00564000 CLI 0(R1),1 CHECK VALID DATE. 00565000 BL NODATE BAD MONTH 00566000 CLI 0(R1),X'12' GREATER THAN YULETIDE? NEVER! 00567000 BNH NODATE1 VALID MONTH 00568000 NODATE MVC CHARDATE(9),=C' 00000000' INVALID DATE HRC005DS 00569290 B PDATE1 HRC005DS 00569580 NODATE1 BAL R15,VERIFY 00570000 MVC CHARDATE+5(2),=C'19' ASSUME 20TH CENTURY HRC005DS 00570040 MVC CHARDATE+7(2),38(R8) HRC005DS 00570080 CLI 38(R8),C'5' DATES BEFORE 1960 ARE 21ST CENTURHRC005DS 00570120 BH PDATE1 GOT CENTURY HRC005DS 00570160 MVC CHARDATE+5(2),=C'20' MAKE IT 21ST CENTURY HRC005DS 00570200 PDATE1 EQU * HRC005DS 00570240 MVI DATE+2,C'/' HRC005DS 00570280 MVI DATE+5,C'/' HRC005DS 00570320 MVC DATE(2),CHARDATE+1 MM HRC005DS 00570360 MVC DATE+3(2),CHARDATE+3 DD HRC005DS 00570400 TM FLAG2,FLG2FULL+FLG2ISO IS THIS A LONG DATE HRC005DS 00570440 BNZ PDATEFUL CHECK FULLDATE HRC005DS 00570480 MVC DATE+6(2),CHARDATE+7 YY HRC005DS 00570520 B PREC HRC005DS 00570560 PDATEFUL TM FLAG2,FLG2FULL HRC005DS 00570600 BNO PDATEISO HRC005DS 00570640 MVC DATE+6(4),CHARDATE+5 CCYY HRC005DS 00570680 B PREC HRC005DS 00570720 PDATEISO MVI DATE+4,C'-' CCYY-MM-DD HRC005DS 00570760 MVI DATE+7,C'-' HRC005DS 00570800 MVC DATE+0(4),CHARDATE+5 CCYY HRC005DS 00570840 MVC DATE+5(2),CHARDATE+1 MM HRC005DS 00570880 MVC DATE+8(2),CHARDATE+3 DD HRC005DS 00570920 PREC EQU * NO. OF RECORDS 00571000 LH R1,36(,R8) GET THE NUMBER OF DATA BLOCKS 00572000 N R1,=X'0000FFFF' NO PROPAGATED BITS FROM 'LH' 00573000 CVD R1,DEC CONVERT IT TO DECIMAL 00574000 MVC NOREC(6),RPATRN CORRECT PATTERN FOR NO. REC. 00575000 ED NOREC(6),DEC+5 EDIT UP TO 5 DIGITS (WORST CASE) 00576000 PITEM EQU * 00577000 LH R1,26(,R8) GET THE NO OF ITEMS 00578000 N R1,=X'0000FFFF' NO SIGN 00579000 CVD R1,DEC CONVERT 00580000 MVC ITM(6),RPATRN MOVE PATTERN 00581000 ED ITM(6),DEC+5 AND EDIT 00582000 PFORM EQU * 00583000 LH R1,34(,R8) AND GET WIDTH 00584000 N R1,=X'0000FFFF' THROW OUT JUNK 00585000 CVD R1,DEC AND CONVERT 00586000 MVC FORM+1(6),RPATRN MOVE PATTERN 00587000 ED FORM+1(6),DEC+5 AND EDIT 00588000 MVC FORM(1),30(R8) SET THE FORMAT 00589000 PMOD MVC MODE(2),24(R8) MOVE IN THE MODE 00590000 MVC MODE(1),ADTM REPLACE MODE-LETTER BY DISK-TABLE MODE 00591000 PTYP MVC TYPE(8),8(R8) MOVE IN THE TYPE 00592000 PNAM MVC NAME(8),0(R8) MOVE IN THE NAME 00593000 LA 1,TYPECMS SET PARAMETER LIST 00594000 SPACE 1 HRC321DS 00594050 TM FLAG2,FLG2FIFO should we stack line instead? HRC321DS 00594100 BO STKFIFO yes, FIFO HRC321DS 00594150 TM FLAG2,FLG2LIFO should we stack line LIFO? HRC321DS 00594200 BNO TYPEIT no, just type it HRC321DS 00594250 MVC FIFOLIFO(4),=C'LIFO' HRC321DS 00594300 B STACKLN HRC321DS 00594350 STKFIFO EQU * HRC321DS 00594400 MVC FIFOLIFO(4),=C'FIFO' HRC321DS 00594450 STACKLN EQU * HRC321DS 00594500 MVC STACKLEN(1),CHARB+3 HRC321DS 00594550 MVC STACKADR(3),BUFLOC HRC321DS 00594600 LA R1,STACKPL HRC321DS 00594650 SPACE 1 HRC321DS 00594700 TYPEIT EQU * HRC321DS 00594750 CNOP 2,4 P3017 00595000 SVC X'CA' 00596000 ERRADDR DC AL4(*+4) P3017 00597000 B BUMP CONTINUE SEARCH 00598000 * 00599000 VERIFY EQU * VERIFY LEGITIMATE TIME AND DATE CODES 00600000 LTR R1,R1 VALID CODES. 00601000 BCR 8,R15 IF NOT (R1=0), EXIT (LEAVE BLANKS THERE) 00602000 VER1 MVC 0(6,R10),0(R14) MOVE IN CORRECT PATTERN 00603000 ED 0(6,R10),0(R1) EDIT TIME OR DATE 00604000 BR R15 00605000 SPACE 00606000 HDMVC MVC TYPLOC(1),HEADMS 00607000 SPACE 00608000 FINI TM FLAG,FOUNDIT WAS FILE FOUND? 00609000 BNO ERR2 00610000 DONE SR R11,R11 CLEAR ERROR INDICATOR IN R11, 00611000 CLI TYPECMS,C'W' DID WE 'WRBUF' CMS EXEC ? 00612000 BNE GETOUT IF NOT, FORGET IT. 00613000 MVC TYPECMS(8),=CL8'FINIS' IF YES, CLOSE CMS EXEC FILE. 00614000 LA 1,TYPECMS ... 00615000 SVC X'CA' ... 00616000 DC AL4(*+4) ... 00617000 * 00618000 GETOUT L R14,RETREG RESTORE R14 = RETURN-REGISTER 00619000 LR R15,R11 ERROR INDICATOR INTO R15, 00620000 BR R14 AND 'PUNT', ALL FINISHED. 00621000 * 00622000 EJECT 00623000 *********************************************************************** 00624000 * 00625000 * ERROR PROCESSING ROUTINES AND MESSAGES 00626000 * 00627000 ********************************************************************** 00628000 SPACE 00629000 ERR1 LR R4,R1 00630000 LA R13,70 00631000 LA R6,BADPARM 00632000 LA R11,24 RET CODE OF 24 @VA09741 00633000 B TELLALL 00634000 SPACE 00635000 ERR2 LA R13,2 00636000 LA R6,NTFND 00637000 LA R11,28 00638000 CLI SAVEDR1,X'0B' LISTFILE called from cmd line? HRC309DS 00639100 BE TELL yes, issue error message HRC309DS 00639200 CLI SAVEDR1,X'0D' from EXEC with '&CONTROL MSG'? HRC309DS 00639300 BE TELL yes, issue error message HRC309DS 00639400 B GETOUT NO MSG IF CALLED AS A FUNCTION, @VM01710 00639500 * OR FROM EXEC WITH '&CONTROL NOMSG' ON. 00639600 SPACE 00640000 ERR3 LA R13,69 00641000 LA R11,36 00642000 MVC ACCMSG+6(1),DESMODE 00643000 LA R6,NOTACC 00644000 B TELL 00645000 SPACE 00646000 ERR4 LA R13,3 00647000 LA R11,24 00648000 LA R6,BADOPT 00649000 B TELLALL 00650000 SPACE 00651000 ERR5 LA R13,37 00652000 LA R11,36 00653000 LA R6,NOTWR 00654000 B TELL 00655000 SPACE 00656000 ERR6A LA R1,DESMODE 00657000 ERR6 LR R4,R1 00658000 LA R11,24 00659000 LA R13,48 00660000 LA R6,BADMODE 00661000 B TELLALL 00662000 SPACE 00663000 ERR7 LA R6,CONFLCT1 00664000 B ERRCNFLC HRC005DS 00665990 SPACE 00668000 ERR8 LA R6,CONFLCT2 00669000 B ERRCNFLC HRC005DS 00670090 SPACE , HRC005DS 00670180 ERR8A LA R6,CONFLCT3 HRC005DS 00670270 B ERRCNFLC HRC005DS 00670360 SPACE , HRC005DS 00670450 ERR8B LA R6,CONFLCT4 HRC005DS 00670540 B ERRCNFLC HRC005DS 00670630 SPACE , HRC005DS 00670720 ERR8C LA R6,CONFLCT5 HRC005DS 00670810 B ERRCNFLC HRC321DS 00670820 ERR8D LA R6,CONFLCT6 FIFO and LIFO conflict HRC321DS 00670830 B ERRCNFLC HRC321DS 00670840 ERR8E LA R6,CONFLCT7 FIFO and HEADER conflict HRC321DS 00670850 B ERRCNFLC HRC321DS 00670860 ERR8F LA R6,CONFLCT8 LIFO and HEADER conflict HRC321DS 00670870 B ERRCNFLC HRC321DS 00670880 ERR8G LA R6,CONFLCT9 STACK and HEADER conflict HRC321DS 00670890 ERRCNFLC LA R11,24 HRC005DS 00670900 LA R13,66 HRC005DS 00670990 SPACE 2 00672000 TELL DMSERR MF=(E,ERRLIST1),TEXTA=(6),LET=E,NUM=(13) 00673000 SPACE 00674000 B GETOUT 00675000 SPACE 2 00676000 TELLALL DMSERR MF=(E,ERRLIST1),TEXTA=(6),LET=E,NUM=(13), X00677000 SUB=(CHARA,(4)) 00678000 B GETOUT 00679000 SPACE 00680000 ERR9 DMSERR NUM=105,LET=S,SUB=(DEC,(15)), X00681000 TEXT='Error ''..'' writing file ''CMS EXEC A1'' on disk' 00682000 LA R11,100 P3017 00683000 B GETOUT P3017 00684000 SPACE 00685000 * ERROR MESSAGES AND LENGTHS 00686000 SPACE 00687000 NOTWR DC AL1(L'WRMSG) 00688000 WRMSG DC C'Disk ''A'' is read-only' HRC321DS 00689000 * 00690000 NTFND DC AL1(L'NTFNDMSG) 00691000 NTFNDMSG DC C'File not found' HRC321DS 00692000 * 00693000 NOTACC DC AL1(L'ACCMSG) 00694000 ACCMSG DC C'Disk ''Z'' not accessed' HRC321DS 00695000 * 00696000 BADPARM DC AL1(L'PARMSG) 00697000 PARMSG DC C'Invalid parameter ''........''' HRC321DS 00698000 * 00699000 BADOPT DC AL1(L'OPTMSG) 00700000 OPTMSG DC C'Invalid option ''........''' HRC321DS 00701000 * 00702000 BADMODE DC AL1(L'MODEMSG) 00703000 MODEMSG DC C'Invalid filemode ''........''' HRC321DS 00704000 * 00705000 CONFLCT1 DC AL1(L'CONFMSG1) 00706000 CONFMSG1 DC C'''APPEND'' and ''EXEC'' are conflicting options' 00707000 * 00708000 CONFLCT2 DC AL1(L'CONFMSG2) 00709000 CONFMSG2 DC C'''HEADER'' and ''NOHEADER'' are conflicting options' 00710000 * HRC005DS 00710090 CONFLCT3 DC AL1(L'CONFMSG3) HRC005DS 00710180 CONFMSG3 DC C'''SHORTDATE'' and ''ISODATE'' are conflicting options'*00710270 , HRC005DS 00710360 CONFLCT4 DC AL1(L'CONFMSG4) HRC005DS 00710450 CONFMSG4 DC C'''SHORTDATE'' and ''FULLDATE'' are conflicting options*00710540 ' , HRC005DS 00710630 CONFLCT5 DC AL1(L'CONFMSG5) HRC005DS 00710720 CONFMSG5 DC C'''FULLDATE'' and ''ISODATE'' are conflicting options' *00710810 , HRC005DS 00710900 CONFLCT6 DC AL1(L'CONFMSG6) HRC321DS 00710905 CONFMSG6 DC C'''FIFO'' and ''LIFO'' are conflicting options' 00710910 * HRC321DS 00710915 CONFLCT7 DC AL1(L'CONFMSG7) HRC321DS 00710920 CONFMSG7 DC C'''FIFO'' and ''HEADER'' are conflicting options' 00710925 * HRC321DS 00710930 CONFLCT8 DC AL1(L'CONFMSG8) HRC321DS 00710935 CONFMSG8 DC C'''LIFO'' and ''HEADER'' are conflicting options' 00710940 * HRC321DS 00710945 CONFLCT9 DC AL1(L'CONFMSG9) HRC321DS 00710950 CONFMSG9 DC C'''STACK'' and ''HEADER'' are conflicting options' 00710955 SPACE 2 00711000 ERRLIST1 DMSERR MF=L 00712000 SPACE 2 00713000 EJECT 00714000 *********************************************************************** 00715000 * 00716000 * STORAGE AREA AND DEFINITIONS 00717000 * 00718000 ********************************************************************** 00719000 SPACE 00720000 SPACE 00721000 HEADMS DC C'Filename Filetype Fm Format Recs Blocks ' V0027 00722100 HEADATE2 DC C' Date Time Label ' HRC320DS 00723040 DS 0F 00724000 DTYPECMS DC CL8'TYPLIN' 00725000 DC AL1(1) 00726000 DC AL3(TYPLOC) 00727000 DC C'B' 00728000 DC AL3(72) 00729000 DTYPELEN EQU *-1 00730000 * 00731000 DS 0F PARAMETER-LIST TO ERASE OLD "CMS EXEC" .. 00732000 ERASEP DC CL8'ERASE' ... 00733000 CMSX DC CL8'CMS' ... 00734000 DC CL8'EXEC' ... 00735000 DMODE DC CL2'A ' ... 00736000 * 00737000 DS 0F PARAMETER-LIST TO 'WRBUF' NEW "CMS EXEC" 00738000 DWRBUF DC CL8'WRBUF' ... 00739000 DC CL8'CMS' 00740000 DC CL8'EXEC' 00741000 DC CL2'A1' 00742000 DC H'0' 00743000 DC A(TYPLOC-7) 00744000 DC F'80' 00745000 DC CL2'F' 00746000 DC H'1' 00747000 DC CL7' &&1 &&2 ' 00748000 LWRB EQU *-DWRBUF (NO. OF BYTES FOR MOVING) 00749000 * 00750000 RPATRN DC X'402020202120' (FOR NUMBER OF ITEMS OR RECORDS) 00751000 DPATRN DC X'F021202020' (FOR DATE .... HRC005DS 00752490 TPATRN DC X'4021207A2020' ... AND TIME) HRC005DS 00752980 CHARDATE DC C' MMDDCCYY' HRC005DS 00753470 * 00754000 SAVEDR1 DS 1F R1 AT INPUT SAVED HERE @VM01710 00754100 RETREG DS 1F RETURN-LOCATION 00755000 DEC DS 1D FOR DECIMAL NUMBER CONVERSION 00756000 NAME1 DS 2F 00757000 NAME2 DS 2F 00758000 PRINTENT DS 1F 00759000 PRINTLEN DS 1C 00760000 SPACE 00761000 * 'LIVE' TYPLIN OR WRBUF PARAMETER-LIST... 00762000 DS 0F 00763000 TYPECMS DC CL9' ' 00764000 BUFLOC DC AL3(*-*) 00765000 CHARB DC A(0) 00766000 DC CL31' ' 00767000 TYPLOC DC CL27' ' 00768000 DC CL47' ' better formatted header HRC320DS 00769000 PAD DC 4F'0' 00770000 SPACE 1 HRC321DS 00770050 * ATTN parameter list to stack the output HRC321DS 00770100 DS 0F HRC321DS 00770150 STACKPL DC CL8'ATTN' HRC321DS 00770200 FIFOLIFO DS CL4 HRC321DS 00770250 STACKLEN DS AL1 HRC321DS 00770300 STACKADR DS AL3 HRC321DS 00770350 * 00771000 DESMODE DC CL8'A' V0205 00772100 FLAGS DC F'0' HRC005DS 00773590 FLAG EQU FLAGS,1 HRC005DS 00774180 FLAG2 EQU FLAGS+1,1 HRC005DS 00774770 FLAG3 EQU FLAGS+2,1 HRC005DS 00775360 FLAG4 EQU FLAGS+3,1 HRC005DS 00775950 * 00777000 DFLTENT DC A(PMOD) 00778000 DFLTLEN DC X'16' 00779000 * 00780000 OK81 DC X'81' 00781000 OK00 DC X'00' @VA06227 00781500 * 00782000 NAME EQU TYPLOC HRC005DS 00783490 TYPE EQU TYPLOC+9 00784000 MODE EQU TYPLOC+18 better formatted header HRC320DS 00785000 FORM EQU TYPLOC+22 better formatted header HRC320DS 00786990 ITM EQU TYPLOC+30 don't truncate number of blocks HRC320DS 00787980 NOREC EQU TYPLOC+37 don't truncate number of blocks HRC320DS 00788970 DATE EQU TYPLOC+45 HRC005DS 00789960 TIME EQU TYPLOC+55 HRC005DS 00790950 VOLID EQU TYPLOC+63 better formatted header HRC320DS 00791940 * 00793000 * FLAG SETTINGS 00794000 MODENUM EQU X'80' EXPLICIT MODENUMBER REFERENCE REQUIRED 00795000 USERMODE EQU X'40' USER SPECIFIED MODE V0042 00796100 HEAD EQU X'20' HEADING IS REQUIRED 00797000 NOHEAD EQU X'10' HEADING IS TO BE SUPPRESSED 00798000 APPND EQU X'08' APPEND TO EXISTING CMS EXEC FILE 00799000 CMSEXEC EQU X'04' CMS EXEC FILE REQUESTED 00800000 HEADINIT EQU X'02' HEADER INITIALIZATION FLAG. V0027 00801100 FOUNDIT EQU X'01' NO FILE FOUND IF OFF 00802000 * 00803000 * FLAG2 SETTINGS HRC005DS 00803100 FLG2ISO EQU X'80' ISO DATE WANTED YYYY-MM-DD HRC005DS 00803200 FLG2SHRT EQU X'40' SHORT DATE WANTED MM/DD/YY HRC005DS 00803300 FLG2FULL EQU X'20' FULL DATE WANTED MM/DD/YYYY HRC005DS 00803400 FLG2STCK EQU X'10' stack results HRC321DS 00803420 FLG2FIFO EQU X'08' stack results FIFO HRC321DS 00803440 FLG2LIFO EQU X'04' stack results LIFO HRC321DS 00803460 FLG2LIFI EQU X'02' LIFO or FIFO option handled HRC321DS 00803480 * HRC005DS 00803500 LTORG 00804000 * 00805000 TABIMAGE DSECT 00806000 TRUNCLEN DS AL1 00807000 OPTLEN DS AL1 00808000 OPT DS CL8 00809000 BRAD DS AL2 00810000 EJECT 00811000 NUCON 00812000 ADT 00813000 REGEQU 00814000 END 00815000