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