CPY TITLE 'DMSCPY (CMS) VM/370 - RELEASE 6' 00001000
SPACE 2 00003000
* 00004000
* 00005000
* 00006000
* 00007000
* MODULE NAME: 00008000
* 00009000
* DMSCPY (COPYFILE) 00010000
* 00011000
* FUNCTION: 00012000
* 00013000
* TO COPY DISK FILES, SPECIFYING VARIOUS CONVERSIONS. 00014000
* 00015000
* ATTRIBUTES: 00016000
* 00017000
* REENTRANT, DISK RESIDENT 00018000
* 00019000
* ENTRY POINTS: 00020000
* 00021000
* DMSCPY - ENTERED BY ISSUING 'COPYFILE' COMMAND 00022000
* 00023000
* ENTRY CONDITIONS: 00024000
* 00025000
* R1 -> PLIST 00026000
* 00027000
* EXIT CONDITIONS: 00028000
* 00029000
* NORMAL - 00030000
* RC=0 00031000
* 00032000
* ERROR - AN ERROR MESSAGE IS TYPED, AND REGISTER 15 IS 00033000
* SET TO THE ERROR MESSAGE NUMBER. 00034000
* 00035000
* CALLS TO OTHER ROUTINES: 00036000
* 00037000
* STRINIT: TO INITIALIZE STORAGE 00038000
* GETMAIN (OS MACRO): TO ALLOCATE STORAGE AND BUFFERS 00039000
* WAITRD: TO READ FORM THE CONSOLE 00040000
* FSTLKP: TO FIND THE FST FOR A FILE 00041000
* ADTLKP: TO FIND ADT FOR OUTPUT DISK (TO SEE IF IT'S RDONLY) 00042000
* RDBUF: TO READ A RECORD FROM A DISK FILE 00043000
* WRBUF: TO WRITE A RECORD TO A DISK FILE 00044000
* FREEMAIN (OS MACRO): TO FREE ALLOCATED STORAGE 00045000
* FINIS: TO RELEASE ACTIVE FILES 00046000
* ERASE: TO ERASE FILES 00047000
* DMSERR: TO TYPE OUT INFORMATION ERROR MESSAGES 00048000
* ALTER: TO ALTER TEMP FILE NAME TO REAL OUTPUT FILE NAME 00049000
* 00050000
* EXTERNAL REFERENCES: 00051000
* 00052000
* NONE. 00053000
* 00054000
* TABLES / WORKAREAS: 00055000
* 00056000
* A WORK AREA IS ALLOCATED USING THE 'GETMAIN' MACRO, 00057000
* AND FREED USING THE 'FREEMAIN' MACRO. IN ADDITION, 00058000
* INPUT/OUTPUT BUFFERS ARE ALLOCATED AND FREED WHEN 00059000
* NECESSARY. 00060000
* 00061000
* REGISTER USAGE: 00062000
* 00063000
* XR = R2 IS A SCRATCH REGISTER 00064000
* WR = R3 POINTS TO THE WORK AREA 00065000
* BR = R4 IS THE FIRST BASE REGISTER 00066000
* XR2 = R5 IS A SCRATCH REGISTER 00067000
* XR3 = R6 IS A SCRATCH REGISTER 00068000
* CDR = R7 POINTS TO THE COPY PHASE TABLES 00069000
* RR = R8 IS THE INTERNAL 'BAL' REGISTER 00070000
* SPR = R9 IS THE POINTER TO THE 'SPECS' CONTROL 00071000
* BLOCKS 00072000
* BR2, BR3, BR4 (R10-R12) ARE ADDITIONAL BASE REGISTERS 00073000
* 00074000
* NOTES: 00075000
* 00076000
* NONE. 00077000
* 00078000
* OPERATION: 00079000
* 00080000
* OPERATION TAKES PLACE IN SEVERAL STEPS. 00081000
* 00082000
* STEP 1. THE WORK SPACE IA ALLOCATED VIA 'GETMAIN' 00083000
* AND ITS FIELDS ARE INITIALIZED. 00084000
* 00085000
* STEP 2. THE FILE NAME LIST IS SCANNED. A FLAG BYTE 00086000
* IS SET UP FOR EACH FILE NAME, INDICATING THE FIELDS, 00087000
* IF ANY, IN WHICH AN ASTERISK OR AN EQUAL SIGN OCCURS. 00088000
* 00089000
* STEP 3. THE OPTION LIST IS SCANNED. FOR EACH OPTION 00090000
* IN THE USER-SUPPLIED LIST, A SPECIAL ROUTINE IS 00091000
* ENTERED TO HANDLE IT. THE HANDLING ROUTINE CAN SET A 00092000
* FLAG, AND CAN HANDLE SUB-FIELDS OF THE OPTION NAME. 00093000
* 00094000
* STEP 4. ADDITIONAL OPTION PROCESSING. THIS 00095000
* INCLUDES: 00096000
* CHECKING FOR OPTION CONFLICTS. 00097000
* SETTING MULTIPLE OR SINGLE MODE, AS SPECIFIED. 00098000
* READING 'SPECS' LIST, IF THAT OPTION WAS 00099000
* GIVEN. 00100000
* SETTING UP TRANSLATE TABLE, IF NECESSARY. 00101000
* READING TABLE FOR TERMINAL IF 'TRANSLATE' 00102000
* SPECIFIED. 00103000
* 00104000
* STEPS 4 AND 5. PERFORM THE ACTUAL COPYING OPERATION. 00105000
* 00106000
* DUE TO THE NUMBER OF OPTIONS AND MODES AVAILABLE, IT 00107000
* WAS FELT THAT A STRAIGHTFORWARD CODING OF THE COPYING 00108000
* STEP WOULD LEAD TO VERY COMPLEX AND HARD-TO-MANAGE 00109000
* CODE. IN ORDER TO AVOID THIS PROBLEM, A DIFFERENT 00110000
* SCHEME WAS USED. THIS SCHEME WAS DESIGNED WITH THE 00111000
* FOLLOWING OBJECTIVES IN MIND: 00112000
* FAST EXECUTION SPEED 00113000
* EASY TO DEBUG CODE 00114000
* EASY TO MODIFY CODE 00115000
* 00116000
* THE IDEA BEHIND THE COPYING OPERATION IS THE 00117000
* FOLLOWING: THE COPYING OPERATION IS BROKEN UP INTO A 00118000
* LARGE NUMBER OF SMALL ROUTINES, HANDLING THE VARIOUS 00119000
* TASKS TO BE PERFORMED AS PART OF THE COPYING 00120000
* OPERATION. EACH OF THE ROUTINES IS MADE TO BE AS 00121000
* STRAIGHT-LINE AS POSSIBLE, SO THAT IT WON'T DEPEND ON 00122000
* WHICH OPTIONS HAVE BEEN SPECIFIED. 00123000
* 00124000
* IT MUST, THEREFORE, BE DETERMINED IN ADVANCE WHICH OF 00125000
* THESE ROUTINES ARE TO BE EXECUTED. A ONE-BYTE CODE IS 00126000
* ASSIGNED TO EACH OF THE ROUTINES, AND TABLES ARE MADE 00127000
* UP, DEPENDING UPON THE OPTIONS WHICH WERE SPECIFIED, 00128000
* TO CALL ONLY THE ROUTINES WHICH SHOULD BE INVOKED FOR 00129000
* THE SPECIFIED OPTIONS. 00130000
* 00131000
* STEP 4, THEN, SETS UP THE CODE STRINGS, DEPENDING 00132000
* UPON WHICH OPTIONS WERE SPECIFIED. THE CODE STRINGS 00133000
* ARE GROUPED INTO 'PHASES', REPRESENTING THE DIFFERENT 00134000
* LOGICAL PHASES OF THE COPYING OPERATION. (PHASES ARE 00135000
* NECESSARY FOR A DIFFERENT REASON: THEY REPRESENT THE 00136000
* ONLY REAL MEANS FOR PROVIDING FOR CONDITIONAL 00137000
* BRANCHES AMONG ROUTINES DURING THE COPYING OPERATION 00138000
* - A CONDITIONAL BRANCH IS ACCOMPLISHED BY A 00139000
* CONDITIONAL CHANGE OF PHASE.) 00140000
* 00141000
* STEP 5 PERFORMS THE ACTUAL COPYING OPERATION BY 00142000
* BRANCHING TO THE ROUTINES, IN TURN, AS SPECIFIED BY 00143000
* THE CODE TABLES. 00144000
* 00145000
*. 00146000
EJECT 00147000
MACRO 00148000
&NM TABLE &LIST 00149000
GBLC &OPLIST(35) OPTION LIST 00150000
LCLA &I 00151000
LCLC &T,&TT 00152000
* FOR EACH OPTION IN THE LIST THERE ARE TWO MACRO ARGUMENTS: 00153000
* OPTION NAME AND MINIMUM NUMBER OF LETTERS. 00154000
SPACE 00155000
&NM DS 0D 00156000
.LOOP ANOP 00157000
&I SETA &I+2 00158000
AIF (&I GT N'&SYSLIST).MEND 00159000
&T SETC '&SYSLIST(&I-1)' 00160000
&OPLIST(&I/2) SETC '&T' 00161000
&TT SETC '&T'(1,7) 00162000
$&TT DC CL8'&T',AL1(&SYSLIST(&I)-1),AL3(@&TT) 00163000
AGO .LOOP 00164000
.MEND MEND 00165000
EJECT 00166000
MACRO 00167000
&NM CONFLICT &LIST 00168000
GBLC &OPLIST(35) OPTION LIST 00169000
LCLA &I,&J,&L(20),&P,&Q,&K 00170000
LCLC &T 00171000
&NM DS 0H 00172000
.ILOOP ANOP 00173000
&I SETA &I+1 00174000
AIF (&I GT N'&SYSLIST).ENDI 00175000
&J SETA 0 00176000
.JLOOP ANOP 00177000
&J SETA &J+1 00178000
AIF (&J GT N'&SYSLIST(&I)).ENDJ 00179000
&T SETC '&SYSLIST(&I,&J)' 00180000
&K SETA 0 00181000
.KLOOP ANOP 00182000
&K SETA &K+1 00183000
AIF ('&T' EQ '&OPLIST(&K)').ENDK 00184000
AIF ('&OPLIST(&K)' NE '').KLOOP 00185000
MNOTE 12,'ILLEGAL PARAMETER: &T' 00186000
.ENDK ANOP 00187000
&L(&J) SETA &K-1 00188000
AGO .JLOOP 00189000
.ENDJ ANOP 00190000
&P SETA 0 00191000
.PLOOP ANOP 00192000
&P SETA &P+1 00193000
AIF (&P GE 2).ENDP **** CHANGE &J TO 2 **** 00194000
&Q SETA &P 00195000
.QLOOP ANOP 00196000
&Q SETA &Q+1 00197000
AIF (&Q GE &J).PLOOP 00198000
AIF (&L(&P) GT &L(&Q)).G 00199000
DC FL1'&L(&P),&L(&Q)' 00200000
AGO .QLOOP 00201000
.G ANOP 00202000
DC FL1'&L(&Q),&L(&P)' 00203000
AGO .QLOOP 00204000
.ENDP ANOP 00205000
AGO .ILOOP 00206000
.ENDI ANOP 00207000
MEND 00208000
EJECT 00209000
MACRO 00210000
&NM CODE &CODE,&B 00211000
GBLA &NROUTS,&KKK 00212000
GBLC &ROUTS(80) 00213000
LCLA &I 00214000
LCLC &T 00215000
AIF ('&B' EQ '').NOB 00216000
AIF ('&B'(1,1) EQ 'N').N 00217000
BN&B *+12 00218000
AGO .NOB 00219000
.N ANOP 00220000
&T SETC '&B'(2,1) 00221000
B&T *+12 00222000
.NOB ANOP 00223000
&NM MVI 0(CDR),$@&CODE 00224000
LA CDR,1(,CDR) 00225000
.LOOP ANOP 00226000
&I SETA &I+1 00227000
AIF ('&CODE' EQ '&ROUTS(&I)').NOLIST 00228000
AIF (&I LT &NROUTS).LOOP 00229000
&NROUTS SETA &NROUTS+1 00230000
&ROUTS(&NROUTS) SETC '&CODE' 00231000
.NOLIST ANOP 00232000
&KKK SETA &KKK+1 00233000
.* THE FOLLOWING LINES ARE USED JUST TO MAKE THE LISTING EASIER TO 00234000
.* FOLLOW. 00235000
B $$&CODE (DOCUMENTATION) 00236000
ORG *-4 (DOCUMENTATION) 00237000
MEND 00238000
EJECT 00239000
MACRO 00240000
ROUTINES &XX 00241000
GBLA &NROUTS 00242000
GBLC &ROUTS(80) 00243000
LCLA &I 00244000
LCLC &T 00245000
ROUTAB DC A(ERUNX) 00246000
.LOOP ANOP 00247000
&I SETA &I+1 00248000
&T SETC '&ROUTS(&I)' 00249000
$@&T EQU &I 00250000
DC A($$&T) 00251000
AIF (&I LT &NROUTS).LOOP 00252000
ROUTMAX EQU &I 00253000
MEND 00254000
EJECT 00255000
MACRO 00256000
&NM PHBEG &XXX 00257000
GBLA &KKK 00258000
GBLC &PPP 00259000
AIF (&KKK EQ 0).OKKK 00260000
MNOTE 8,'NO PHEND FOR PHASE &PPP' 00261000
&KKK SETA 0 00262000
.OKKK ANOP 00263000
&PPP SETC '&NM' 00264000
M&NM EQU * 00265000
LA CDR,PH&NM POINT TO PHASE CONTROL BYTES 00266000
MEND 00267000
SPACE 2 00268000
MACRO 00269000
&NM PHEND &XXX 00270000
GBLA &KPH,&PL(20),&KKK 00271000
GBLC &PPP,&PH(20) 00272000
LCLA &I 00273000
AIF ('&NM' EQ '&PPP').OKPPP 00274000
MNOTE 8,'LABEL ''&PPP'' ASSUMED' 00275000
.OKPPP ANOP 00276000
.L ANOP 00277000
&I SETA &I+1 00278000
AIF ('&PPP' EQ '&PH(&I)').F 00279000
AIF (&I LT &KPH).L 00280000
MNOTE 8,'NO ''PW'' SPECIFIED FOR PHASE ''&PPP''' 00281000
.F ANOP 00282000
AIF (&KKK LE &PL(&I)).OKTTT 00283000
MNOTE 8,'PH&PPP SHOULD HAVE LENGTH AT LEAST XL&KKK' 00284000
.OKTTT ANOP 00285000
M&PPP.E EQU * 00286000
&KKK SETA 0 00287000
MEND 00288000
SPACE 5 00289000
MACRO 00290000
&N PW &L 00291000
GBLA &PL(20),&KPH 00292000
GBLC &PH(20) 00293000
&KPH SETA &KPH+1 00294000
&PH(&KPH) SETC '&N' 00295000
&PL(&KPH) SETA &L 00296000
PH&N DS XL&L 00297000
MEND 00298000
EJECT 00299000
MACRO 00300000
GOGEN &XXXX 00301000
GBLA &KPH 00302000
GBLC &PH(20) 00303000
LCLA &I 00304000
LCLC &T 00305000
.LOOP ANOP 00306000
&I SETA &I+1 00307000
&T SETC '&PH(&I)' 00308000
$$GO&T EQU * 00309000
PHASE &T 00310000
SPACE 00311000
AIF (&I LT &KPH).LOOP 00312000
MEND 00313000
EJECT 00314000
MACRO 00315000
&NM NEXT &XXX 00316000
&NM B NEXT 00317000
MEND 00318000
SPACE 3 00319000
MACRO 00320000
&NM SKIP &N 00321000
&NM LA CDR,&N+1(,CDR) 00322000
B GO 00323000
MEND 00324000
SPACE 3 00325000
MACRO 00326000
&NM PHASE &PH 00327000
&NM LA CDR,PH&PH 00328000
B GO 00329000
MEND 00330000
EJECT 00331000
MACRO 00332000
&NM CKRW &RW,&EOF=ERRWX 00333000
&NM SR R14,R14 00334000
IC R14,&RW.BYTES(R15) GET JUMP CODE FROM RETURN CODE 00335000
B *+4(R14) JUMP BASED ON RETURN CODE 00336000
B *+16 ZERO RETURN CODE -- NORMAL 00337000
BAL RR,ERRWX UNEXPECTED ERROR 00338000
B ERACT FILE ALREADY ACTIVE FOR WR/RD 00339000
BAL RR,&EOF END OF FILE ON RDBUF 00340000
MEND 00341000
* FOR EACH FILE NAME PASSED TO THIS ROUTINE, THERE WILL BE THREE 00342000
* PLISTS REFERRING TO IT: 00343000
SPACE 00344000
* PLIST1 THIS PLIST CONTAINS THE FILE NAME AS PASSED TO THIS 00345000
* ROUTINE. SUCH A FILE NAME WILL CONTAIN BOTH *'S AND ='S. 00346000
* A POINTER TO A PLIST1 WILL BE A POINTER INTO THE MIDDLE 00347000
* OF THE PLIST PASSED TO THIS ROUTINE. MORE SPECIFICALLY, 00348000
* IT WILL POINT TO 8 BYTES BEFORE THE APPEARANCE OF THAT FILE 00349000
* NAME IN THE PLIST PASSED TO 'COPY'. THIS PLIST WILL NEVER 00350000
* BE MODIFIED. 00351000
SPACE 00352000
* PLIST2 THIS PLIST CONTAINS THE FILE NAME WITHOUT ANY ='S. 00353000
* THE SAME PLIST ALSO CONTAINS POINTERS TO THE ASSOCIATED 00354000
* PLIST1 AND PLIST3, AS WELL AS SOME OTHER POINTERS. (SEE 00355000
* DSECT DESCRIPTION OF PLIST2 JUST BELOW.) 00356000
* THIS PLIST WILL PHYSICALLY BE IN THE WORK AREA, AND WILL 00357000
* BE ONE OF FIPLIST2, CIPLIST2 OR OUPLIST2. 00358000
SPACE 00359000
* PLIST3 THIS PLIST IS THE RDBUF/WRBUF PLIST, AND THE FILE NAME 00360000
* FILE NAME IN THIS CASE WILL NOT CONTAIN EITHER ANY *'S 00361000
* OR ANY ='S. 00362000
* THIS PLIST IS PHYSICALLY IN THE WORK AREA, AND WILL BE ONE 00363000
* OF RDPLIST, WRPLIST OR OVPLIST. 00364000
EJECT 00365000
PLIST1 DSECT 00366000
DS CL8 PADDING FOR OPERATION 00367000
PNA1 DS CL8 FILE NAME 00368000
PTY1 DS CL8 FILE TYPE 00369000
PMO1 DS CL2 FILE MODE 00370000
DS CL6 PADDING 00371000
PNEXTNA DS X NEXT NAME IN 'COPY' PLIST 00372000
SPACE 00373000
PNEXT1 EQU PMO1 UPDATE TO THIS ADDRESS 00374000
SPACE 2 00375000
PLIST2 DSECT 00376000
DS CL8 OPERATION (IF NEEDED) 00377000
PNA2 DS CL8 FILE NAME 00378000
PTY2 DS CL8 FILE TYPE 00379000
PMO2 DS CL2 FILE MODE 00380000
* THE NEXT TWO FIELDS ARE COPIED OVER FROM THE ADT. 00381000
PHYP DS CL8 POINTER TO CURRENT FST HYPERBLOK 00382000
PSTFST EQU PHYP+2 POINTER TO FST FROM STATE @VA04333 00383000
PFST DS A POINTER TO CURRENT FST 00384000
PADT DS A POINTER TO CURRENT ADT 00385000
SPACE 00386000
* THE NEXT IS A POINTER INTO EITHER THE INFLAGS STRING, OR TO OUTFLAG. 00387000
PFLG DS A POINTER TO FLAG BYTE FOR FILE 00388000
PPLIST1 DS A POINTER TO PLIST1 00389000
PPLIST3 DS A POINTER TO PLIST3 00390000
SPACE 00391000
PLEN2 EQU (*+7-PLIST2)/8 LENGTH OF PLIST2 IN DOUBLEWORDS 00392000
SPACE 2 00393000
PLIST3 DSECT 00394000
DS CL8 OPERATION: RDBUF OR WRBUF 00395000
PNA3 DS CL8 FILE NAME 00396000
PTY3 DS CL8 FILE TYPE 00397000
PMO3 DS CL2 FILE MODE 00398000
PITEM3 DC H'0' ITEM NUMBER 00399000
PBUFFA3 DS A BUFFER ADDRESS 00400000
PBUFFS3 DS F BUFFER SIZE 00401000
PFV3 DS CL2 F/V FLAG 00402000
PNI3 DC H'1' NUMBER OF ITEMS TO R/W 00403000
PRET3 DS F RDBUF: NO BYTES READ RETURNED 00404000
EJECT 00405000
* THE FOLLOWING DSECT DESCRIBES THE CONTROL WORDS ASSOCIATED WITH 00406000
* EACH DESCRIPTION OF A 'SPECS' OPTION. 00407000
SPSECT DSECT 00408000
SPINDISP DS A DISPLACEMENT INTO INPUT BUFFER-1 00409000
SPLAST DS A LAST COLUMN IN INPUT BUFFER 00410000
SPACE 00411000
* FOR A STRAIGHT STRING SUBSTITUTION, THE LAST TWO ADDRESSES ARE AS 00412000
* FOLLOWS: 00413000
* SPINDISP ADDRESS OF STRING TO BE SUBSTITUTED, WITH SIGN BIT 00414000
* TURNED ON 00415000
* SPLAST LENGTH OF STRING TO BE SUBSTITUTED 00416000
SPACE 00417000
* THE FOLLOWING FIELD CONTAINS THE ( (COLUMN NUMBER) - 1). 00418000
SPOUDISP DS A DISPLACEMENT INTO OUTPUT BUFFER 00419000
SPNEXT EQU * POINTER TO NEXT CONTROL BLOCK 00420000
SPACE 00421000
SPBLEN EQU *-SPSECT LENGTH OF CTL WORD BLOCK 00422000
EJECT 00423000
* THE FOLLOWING DSECT DESCRIBES THE CONTROL WORDS ASSOCIATED WITH EACH 00424000
* 'COPY' OPTION. THESE CONTROL WORDS ARE GENERATED BY THE 'OPTAB' 00425000
* MACRO. 00426000
OPSECT DSECT 00427000
OPNAME DS CL8 OPTION NAME 00428000
OPMIN DS 0AL1 (MINIMUM NUMBER OF LETTERS)-1 00429000
OPADD DS A ADDRESS OF BRANCH ROUTINE 00430000
SPACE 00431000
OPSLEN EQU *-OPSECT LENGTH OF BLOCK 00432000
* THE WORKSPACE WHICH IS DESCRIBED HEREIN IS ALLOCATED BY A GETMAIN 00433000
* MACRO AT THE START OF 'COPY' PROCESSING. 00434000
* ALL FIELDS GIVEN BY 'DC' BELOW ARE INITIALIZED TO THAT VALUE BELOW. 00435000
* ALL OTHER FIELDS ARE INITIALIZED TO 0. 00436000
WORK DSECT 00437000
SAVE13 DS A SAVE OLD R13 00438000
SAVEAREA DS 18A NEW SAVE AREA 00439000
PLPTR DS A POINTER TO 'COPY' PLIST 00440000
RC DC X'00' RETURN CODE FROM 'COPY' 00441000
EJECT 00442000
WORK DSECT CONTINED 00443000
SPACE 00444000
* FIELDS HAVING TO DO WITH OPTION PROCESSING. 00445000
SPACE 00446000
* ONE 'OPBYTES' BYTE IS FILLED IN FOR EACH OPTION SPECIFIED. 00447000
OPBYTES DS 50X 00448000
NOPS DC H'0' NUMBER OF OPTIONS SPECIFIED. 00449000
SPACE 00450000
OPF1 DC AL1(0) FIRST OPTION FLAG BYTE 00451000
SPACE 00452000
OP1TYPE EQU X'80' TYPE OPTION SPECIFIED 00453000
OP1OLDD EQU X'40' OLDDATE OPTION SPECIFIED 00454000
OP1DEFO EQU X'20' DEFAULT OUTPUT FILE NAME '= = =' 00455000
OP1FRL EQU X'10' 'FRLABEL' OPTION SPECIFIED 00456000
OP1TOL EQU X'08' TOLABEL OPTION SPECIFIED 00457000
OP1TRUNC EQU X'04' TRUNC OPTION SPECIFIED 00458000
OP1SPECS EQU X'02' SPECS OPTION SPECIFIED 00459000
OP1NOPR EQU X'01' NOPROMPT OPTION SPECIFIED 00460000
SPACE 2 00461000
OPF2 DC AL1(0) SECOND OPTION FLAG BYTE 00462000
SPACE 00463000
OP2MULT EQU X'80' MULTIPLE MODE IMPLIED @VA05078 00464000
OP2REPL EQU X'40' REPLACE OPTION SPECIFIED 00465000
OP2OVLY EQU X'20' OVLY OPTION SPECIFIED 00466000
OP2APPE EQU X'10' APPEND OPTION SPECIFIED 00467000
OP2NEWF EQU X'08' NEWFILE OPTION SPECIFIED (OR *00468000
DEFAULTED) 00469000
* X'04' NOT USED @VA11777 00470000
OP2PACK EQU X'02' 'PACK' OPTION 00471000
OP2UNPA EQU X'01' 'UNPACK' OPTION 00472000
SPACE 2 00473000
OPF3 DS AL1(0) THIRD OPTION FLAG BYTE 00474000
SPACE 00475000
OP3EBCD EQU X'80' 'EBCDIC' OPTION SPECIFIED 00476000
OP3TRAN EQU X'40' 'TRANS' OPTION SPECIFIED 00477000
OP3UPCA EQU X'20' 'UPCASE' OPTION SPECIFIED 00478000
OP3LOCA EQU X'10' 'LOWCASE' OPTION SPECIFIED 00479000
* X'08' NOT USED @VA11777 00480000
OP3MODE3 EQU X'04' 'OLDDATE WITH MODE A3' @VA03020 00481000
OP3MORIN EQU X'02' THERE IS(ARE) MORE INPUT FILE(S) @VA03971 00482000
OP3PHCV EQU X'01' 'OVLY' PHASE CV IS BEING EXECUTED@VA03971 00483000
EJECT 00484000
WORK DSECT 00485000
SPACE 2 00486000
* OTHER OPTION FIELDS 00487000
RECFM DS C SPECIFIED RECFM 00488000
LRECL DC F'0' SPECIFIED LRECL 00489000
FROMN DC F'0' SPECIFIED 'FROM' NUMBER 00490000
FORN DC F'0' SPECIFIED 'FOR' NUMBER 00491000
FILLC DC X'40000000' DEFAULT FILL CHAR IS BLANK 00492000
FRL DS CL8 'FRLABEL' LABEL 00493000
TOL DS CL8 'TOLABEL' LABEL 00494000
FRLL DS H (LENGTH OF FRLABEL) - 1 00495000
TOLL DS H (LENGTH OF TOLABEL) - 1 00496000
SPACE 00497000
FOREND DS F TEMPORARY USED WITH 'FOR' PROC 00498000
EJECT 00499000
WORK DSECT CONTINUED 00500000
SPACE 00501000
* STORAGE ASSOCIATED WITH 'SPECS' SPECIFICATIONS 00502000
SPACE 00503000
MAXSPECS EQU 20 MAX NUMBER OF SPECS ALLOWED 00504000
SPECSB DC (MAXSPECS)A(0,0,0) 'SPECS' DESCRIPTION BLOCKS 00505000
* THE PRECEDING CONTROL BLOCKS ARE DESCRIBED BY THE SPSECT DSECT. 00506000
SPACE 00507000
SPECSBE DC X'FF' X'FF' MEANS END OF SPECS 00508000
SPECC DS C CURRENT SPEC DELIMITER CHAR 00509000
SPECST DS CL130 SPEC STRINGS 00510000
SPECSTM DS A (*) END OF SPECST -- INIT TO A(*) 00511000
SPECSTE DS A END OF SPEC STRINGS 00512000
SPECTMP DS A TEMP FOR PROCESSING SPECS 00513000
SPACE 00514000
* THE FOLLOWING FIELD CONTAINS THE MAXIMUM DISPLACEMENT OF ANY 00515000
* SPECIFICATION INTO THE OUTPUT BUFFER. THIS FIGURE IS NEEDED TO 00516000
* COMPUTE THE MAXIMUM SIZE OF THE OUTPUT BUFFER. 00517000
SPECMAX DC F'0' 00518000
SPACE 3 00519000
EJECT 00525000
WORK DSECT 00526000
* PACK/UNPACK OPTION AREA 00527000
* PACK FILE HEADER BUFFER 00528000
PACKFHB DS 0F 00529000
PACKVER DC H'1' PACK VERSION NUMBER 00530000
PACKCHAR DS C SPECIAL PACK CHARACTER 00531000
PACKRECF DS C RECFM OF FILE BEING PACKED 00532000
PACKLREC DS F LRECL OF FILE BEING PACKED 00533000
PACKBL EQU *-PACKFHB LENGTH OF HEADER BUFFER 00534000
SPACE 00535000
* THERE ARE TWO SETS OF BUFFER POINTERS, ONE FOR THE 'PACK' BUFFER, 00536000
* AND ONE FOR THE REAL FILE BUFFER. WHICH IS INPUT AND WHICH IS OUTPUT 00537000
* DEPENDS ON WHETHER A PACK OR UNPACK IS BEING DONE. 00538000
SPACE 00539000
* PACK BUFFER POINTERS. 00540000
PACKBUF DS A POINTER TO NEXT AVAILABLE BYTE *00541000
PACK BUFFER 00542000
PACKLEFT DS F NUMBER OF BYTES LEFT IN PACK *00543000
BUFFER 00544000
SPACE 00545000
* POINTERS TO THE REAL FILE BUFFER. 00546000
PKBX DS A NEXT AVAILABLE BYTE IN BUFFER 00547000
PKBXE DS A POINTER TO BYTE BEYOND END OF *00548000
BUFFER 00549000
PKBXE2 DS A 2 BYTES LESS THAN PKBXE 00550000
PKBXE3 DS A 3 BYTES LESS THAN PKBXE 00551000
PKBXE4 DS A 4 BYTES LESS THAN PKBXE 00552000
SPACE 00553000
PKCC DS 2C TWO COPIES OF PACKCHAR 00554000
SPACE 00555000
* THE FLAG BYTE APPEARS AS PART OF EACH DATA SPECIFICATION IN THE 00556000
* PACKED FILE FORMAT. IN THIS FLAG BYTE, IF NOT ALL THE PKFFF BITS 00557000
* ARE ON, THEN ONLY PKDAF IS A FLAG BIT, AND ALL THE REST ARE LENGTH 00558000
* BITS SPECIFYING THE LENGTH OF THE DATA FIELD. IF ALL THE PKFFF BITS 00559000
* ARE ON, THEN ALL THE BITS IN THE BYTE ARE FLAG BITS AND ARE VALID. 00560000
PKFLAG DS B FLAG BYTE 00561000
PKDAF EQU B'10000000' DATA FIELD -- THIS BYTE IS FOL- *00562000
LOWED BY A FIELD OF NONEQUAL *00563000
CHARS 00564000
PKFFF EQU B'01111000' MAX LENGTH SPEC IS 119+1. 00565000
PKERF EQU B'00000100' END OF RECORD BIT FOR V RECORD 00566000
PKSCF EQU B'00000010' SPECIAL (NON-FILL) CHARACTER BIT 00567000
PKELF EQU B'00000001' EXTRA LONG FIELD BIT -- LONGER *00568000
THAN 256 CHARACTERS. 00569000
EJECT 00570000
WORK DSECT CONTINUED 00571000
* PLIST'S FOR THE ROUTINE 00572000
DS 0D 00573000
SPACE 00574000
ERPLIST DC CL8'ERASE',3D'0',8X'FF' ERASE PLIST 00575000
FIPLIST DC CL8'FINIS',3D'0',8X'FF' FINIS PLIST 00576000
RNPLIST DC CL8'RENAME',6D'0',8X'FF' RENAME PLIST 00577000
STPLIST DC CL8'STATE',3D'0',8X'FF' STATE PLIST 00578000
SPACE 2 00579000
* TERMINAL READ PLIST 00580000
CRPLIST DS 0F 00581000
DC CL8'WAITRD' OPERATION 00582000
DC AL1(1) 00583000
DC AL3(0) INIT TO A(STRING) 00584000
DS C COVERSION INDICATOR 00585000
DS AL3 BYTE COUNT STORED HERE 00586000
* THE FOLLOWING PLIST'S ARE DESCRIBED BY THE PLIST2 DSECT. 00587000
SPACE 00588000
FIPLIST2 DC (PLEN2)D'0' FIRST INPUT FILE PLIST2 00589000
CIPLIST2 DC (PLEN2)D'0' CURRENT INPUT FILE PLIST2 00590000
OUPLIST2 DC (PLEN2)D'0' OUTPUT FILE PLIST2 00591000
SPACE 00592000
* THE FOLLOWING IS THE NAME, TYPE AND MODE FOR THE FIRST INPUT FILE, 00593000
* WITH ALL *'S SUBSTITUTED. THIS INFO IS NEEDED TO SUBSTITUTE FOR 00594000
* ='S IN OTHER INPUT FILES AND IN OUTPUT FILE. 00595000
FNA DS CL8 FILE NAME 00596000
FTY DS CL8 FILE TYPE 00597000
FMO DS CL2 FILE MODE 00598000
SPACE 00599000
PPLIST2 DS A POINTER TO CURRENT PLIST2 00600000
POUPL1 DS A POINTER TO OUTPUT FILE PLIST1 00601000
EJECT 00602000
WORK DSECT CONTINUED 00603000
SPACE 00604000
* RDBUF AND WRBUF PLISTS, DESCRIBED BY PLIST3 DSECT. 00605000
SPACE 00606000
RDPLIST DS 0F 00607000
DC CL8'RDBUF' OPERATION 00608000
RDFNAME DS CL8 FILE NAME 00609000
RDFTYPE DS CL8 FILE TYPE 00610000
RDFMODE DS CL2 FILE MODE 00611000
RDITEM DC H'0' ITEM NUMBER 00612000
RDBUFFA DS A BUFFER ADDRESS 00613000
RDBUFFS DS F BUFFER SIZE 00614000
RDFV DS CL2 F OR V -- RECFM 00615000
RDNI DC H'1' NO OF ITEMS TO READ 00616000
RDRET DS F NO OF BYTES READ RETURNED HERE 00617000
SPACE 00618000
WRPLIST DS 0F 00619000
DC CL8'WRBUF' OPERATION 00620000
WRFNAME DS CL8 FILE NAME 00621000
WRFTYPE DS CL8 FILE TYPE 00622000
WRFMODE DS CL2 FILE MODE 00623000
WRITEM DC H'0' ITEM NUMBER 00624000
WRBUFFA DS A BUFFER ADDRESS 00625000
WRBUFFS DS F BUFFER SIZE 00626000
WRFV DS CL2 F OR V -- RECFM 00627000
WRNI DC H'1' NUMBER OF ITEMS TO WRITE 00628000
SPACE 00629000
OVPLIST DS 0F 00630000
DC CL8'RDBUF' OPERATION 00631000
OVFNAME DS CL8 FILE NAME 00632000
OVFTYPE DS CL8 FILE TYPE 00633000
OVFMODE DS CL2 FILE MODE 00634000
OVITEM DC H'0' ITEM NUMBER 00635000
OVBUFFA DS A BUFFER ADDRESS 00636000
OVBUFFS DS F BUFFER SIZE 00637000
OVFV DS CL2 F OR V -- RECFM 00638000
OVNI DC H'1' NUMBER OF ITEMS TO READ 00639000
OVRET DS F NO OF BYTES READ RETURNED HERE 00640000
EJECT 00641000
WORK DSECT CONTINUED 00642000
SPACE 00643000
* THE FOLLOWING CONTROL WORDS ARE ASSOCIATED WITH THE INPUT/OUTPUT 00644000
* BUFFERS. THESE BUFFERS ARE ALLOCATED BY A SEPARATE GETMAIN MACRO. 00645000
SPACE 00646000
BUFAD DC A(0) BUFFER ADDRESS 00647000
BUFLEN DC F'0' BUFFER LENGTH 00648000
SPACE 00649000
* BOTH THE INPUT AND OUTPUT BUFFERS ARE CONTAINED IN THE SAME BUFFER 00650000
* AREA. THE INPUT BUFFER IS AT THE BEGINNING, AND OBUFAD GIVES THE 00651000
* LOCATION OF THE OUTPUT BUFFER. 00652000
OBUFAD DC A(0) 00653000
OBUFLEN DC F'0' LENGTH OF OUTPUT BUFFER 00654000
VBUFEND DS A END OF OUTBUF FOR VARIABLE *00655000
OUTPUT 00656000
SPACE 00657000
BUFNEED DS F BUFFER SIZE NEEDED 00658000
BINBYTE DS X BUFFER INITIALIZATION BYTE 00659000
* THE PRECEDING BYTE WILL BE SET TO X'FF' IF IT IS NECESSARY TO 00660000
* INITIALIZE THE OUTPUT BUFFER TO THE FILL CHARACTER AFTER EACH WRBUF. 00661000
SPACE 00662000
* THE FOLLOWING HALFWORD CONTAINS THE ITEM NUMBER OF THE FIRST OUTPUT 00663000
* RECORD. IT IS USED TO DETERMINE WHETHER ANY RECORDS WERE WRITTEN TO 00664000
* THE OUTPUT FILE. 00665000
OFREC DS H FIRST OUTPUT RECORD ITEM # 00666000
EJECT 00667000
WORK DSECT CONTINUED 00668000
SPACE 00669000
* FLAGS FOR FILE SPECIFICATIONS 00670000
MAXIN EQU 40 MAXIMUM NUMBER OF FILE NAMES *00671000
IN 'COPY' PLIST 00672000
INFLAGS DC (MAXIN)B'00000000' FLAG BYTES 00673000
INEND DC X'FF' END OF INFLAGS 00674000
OUTFLAGS DC B'00000000' OUTPUT FILE FLAGS 00675000
SPACE 00676000
* THE FOLLOWING ARE THE FLAGS SET IN INFLAGS AND OUTFLAG 00677000
FENA EQU X'80' = SIGN IN FILE NAME 00678000
FETY EQU X'40' = SIGN IN FILE TYPE 00679000
FEMO EQU X'20' = SIGN IN FILE MODE 00680000
FE EQU FENA+FETY+FEMO = SIGN SOMEWHERE 00681000
FSNA EQU X'10' STAR IN FILE NAME 00682000
FSTY EQU X'08' STAR IN FILE TYPE 00683000
FSMO EQU X'04' STAR IN FILE MODE 00684000
FS EQU FSNA+FSTY+FSMO STAR SOMEWHERE 00685000
SPACE 00686000
* FLAG FS IS SET IN CFLAGS IF THERE IS A STAR IN ANY FILE NA/TY/MO 00687000
* EXCEPT THE FIRST INPUT FILE. THIS SITUATION IS ILLEGAL IN 00688000
* MULTIPLE FILE MODE. 00689000
CFLAGS DC B'00000000' 00690000
EJECT 00691000
WORK DSECT CONTINUED 00692000
SPACE 00693000
* PHASE CONTROL BYTES 00694000
SPACE 00695000
IN PW 12 INITIALIZATION PHASE @VA05624 00696000
IN2 PW 13 LOOP THRU INPUT FOR LRGST LRECL @VA05624 00697000
IN3 PW 5 SET LRECL AND RECFM @VA05624 00698000
RE PW 9 'MULT' MODE RESTART PHASE 00699000
PO PW 31 PROCESS OUTPUT FILE NAME @VA06129 00700000
PC PW 9 PRE-COPY PHASE 00701000
CO PW 15 COPY PHASE 00702000
CV PW 8 SPECIAL OVLY PHASE @VA03971 00703000
EO PW 17 EOF ON INPUT FILE @VA05624 00704000
NI PW 10 NEW INPUT FILE PHASE 00705000
CL PW 9 CLOSING PHASE @VA03972 00706000
EJECT 00707000
WORK DSECT CONTINUED 00708000
SPACE 00709000
* MISCELLANEOUS STORAGE SPACE 00710000
SPACE 1 @VA04333 00711000
PFSTAC DS 1F COPY OF FST FROM STATE @VA04333 00712000
FFSTD DS 1F TIME AND DATE FOR MODE A3 @VA04333 00713000
FFSTYR DS 1H YEAR FOR MODE A3 @VA04333 00714000
SPACE 00715000
ERLIST DMSERR MF=L,SUB=(,0,,0,,0,,0,,0,,0) ERROR MESSAGE PLIST 00716000
SPACE 00717000
TRTAB DS CL256 TRANSLATE TABLE 00718000
SPACE 00719000
STRING DS 0D,CL136 STRING STORAGE 00720000
STEMP DS CL16 STRING TEMP 00721000
SPACE 2 00722000
* FLAG DOSF IS USED TO SAVE THE CONTENTS OF THE DOS SIMULATION FLAGS 00723000
* LOCATED IN NUCON. 00724000
DOSF DS X @V305066 00725000
SPACE 2 00726000
WORKLEN EQU (*+7-WORK)/8 WORKAREA LENGTH IN DOUBLEWORDS 00727000
R0 EQU 0 00728000
R1 EQU 1 00729000
R2 EQU 2 00730000
R3 EQU 3 00731000
R4 EQU 4 00732000
R5 EQU 5 00733000
R6 EQU 6 00734000
R7 EQU 7 00735000
R8 EQU 8 00736000
R9 EQU 9 00737000
R10 EQU 10 00738000
R11 EQU 11 00739000
R12 EQU 12 00740000
R13 EQU 13 00741000
R14 EQU 14 00742000
R15 EQU 15 00743000
SPACE 00744000
* REGISTER XR MUST EQUAL R2, SINCE IT IS USED BY TRT. 00745000
XR EQU R2 SCRATCH REGISTER 00746000
WR EQU R3 POINTER TO WORKSAPPACE AREA 00747000
BR EQU R4 BASE REGISTER 00748000
XR2 EQU R5 SECOND SCRATCH REGISTER 00749000
XR3 EQU R6 THIRD SCRATCH REGISTER 00750000
CDR EQU R7 PHASE CODE POINTER 00751000
RR EQU R8 INTERNAL SUB RETURN REG 00752000
SPR EQU R9 POINTER TO SPSECT 00753000
BR2 EQU R10 SECOND BASE REGISTER 00754000
BR3 EQU R11 THIRD BASE REGISTER 00755000
BR4 EQU R12 FOURTH BASE REGISTER 00756000
SPACE 2 00757000
USING DMSCPY,BR,BR2,BR3,BR4 BASE REGISTERS 00758000
USE WORK,WR WORKAREA POINTER 00759000
USE SPSECT,SPR 00760000
DMSCPY CSECT 00761000
SAVE (14,12),,* 00762000
LA XR,X'FFF' 00763000
LR BR,R15 SET BASE REGISTER 00764000
LA BR2,1(XR,BR) SET SECOND BASE REG 00765000
LA BR3,1(XR,BR2) SET THIRD BASE REGISTER 00766000
LA BR4,1(XR,BR3) SET FOURTH BASE REGISTER 00767000
LA XR,0(,R1) 'COPY' PLIST POINTER 00768000
STRINIT CALL STORAGE INITIALIZATION 00769000
USING NUCON,R0 @V305066 00770000
DMSKEY NUCLEUS @V305066 00771000
IC R5,DOSFLAGS GET NUCON'S DOSFLAGS @V305066 00772000
NI DOSFLAGS,255-DOSSVC TURN OFF DOS SVC HANDLE @V305066 00773000
DMSKEY RESET @V305066 00774000
GETMAIN R,LV=WORKLEN*8 GET WORK AREA SPACE 00775000
LR WR,R1 POINT TO WORK AREA 00776000
SR R15,R15 00777000
LR R0,WR 00778000
LA R1,8*WORKLEN 00779000
MVCL R0,R14 ZERO OUT WORK AREA 00780000
SPACE 00781000
* INITIALIZE FIELDS IN WORK AREA 00782000
SPACE 00783000
STC R5,DOSF TEMPORARILY STORE DOSFLAGS @V305066 00784000
ST R13,SAVE13 SAVE REGISTER 13 00785000
LA R13,SAVEAREA POINT TO NEW SAVE AREA 00786000
ST XR,PLPTR SAVE 'COPY' PLIST POINTER 00787000
MVI FILLC,C' ' 00788000
MVI SPECSBE,X'FF' 00789000
LA R1,SPECSTM 00790000
ST R1,SPECSTM 00791000
MVI PACKVER+1,C'1' 00792000
MVC ERPLIST,=CL8'ERASE' 00793000
MVC ERPLIST+8+3*8(8),=8X'FF' 00794000
MVC FIPLIST,=CL8'FINIS' 00795000
MVC FIPLIST+8+3*8(8),=8X'FF' 00796000
MVC RNPLIST,=CL8'RENAME' 00797000
MVC RNPLIST+8+6*8(8),=8X'FF' 00798000
MVC STPLIST,=CL8'STATE' 00799000
MVC STPLIST+3*8(8),=8X'FF' 00800000
MVC CRPLIST(8),=CL8'WAITRD' 00801000
LA XR,STRING 00802000
ST XR,CRPLIST+8 00803000
MVI CRPLIST+8,1 00804000
MVC RDPLIST(8),=CL8'RDBUF' 00805000
MVI RDNI+1,1 00806000
MVC WRPLIST(8),=CL8'WRBUF' 00807000
MVI WRNI+1,1 00808000
MVC OVPLIST(8),=CL8'RDBUF' 00809000
MVI OVNI+1,1 00810000
MVI INEND,X'FF' 00811000
* WE CREAT ONE 'INFLAGS' FLAG BYTE FOR EACH INPUT FILE. 00812000
LA XR3,INFLAGS 00813000
SPACE 00814000
L XR2,PLPTR POINTER TO 'COPY' PLIST 00815000
USE PLIST1,XR2 00816000
SPACE 00817000
* FOR USE OF PLIST1, SEE DSECT DESCRIPTION. 00818000
SPACE 00819000
* IF THE OPTION LIST BEGINS IMMEDIATELY, THEN THERE ARE NO FILES 00820000
* SPECIFIED. 00821000
CLI PNA1,C'(' FIRST TOKEN IS AN OPTION? 00822000
BE ERNOIN ERROR -- NO INPUT FILES 00823000
CLI PNA1,X'FF' NO TOKENS WHATSOEVER? 00824000
BE ERNOIN ERROR -- NO INPUT FILES 00825000
SPACE 00826000
* SET UP TRANSLATE TABLE FOR THE IDENTIFICATION OF =, *, ( AND X'FF' 00827000
* IN THE FILE NAMES. (THE LATTER TWO SIGNAL THE START OF THE OPTION 00828000
* LIST.) 00829000
XC TRTAB,TRTAB ALL FIELDS 0 EXCEPT: 00830000
MVI TRTAB+C'*',4 * -> 4 00831000
MVI TRTAB+C'=',8 = -> 8 00832000
MVI TRTAB+C'(',12 ( -> 12 00833000
MVI TRTAB+X'FF',12 FF -> 12 00834000
SPACE 2 00835000
CLI PNEXTNA,X'FF' NO 2ND FILEID SPECIFIED? 00836000
BE DEFO USE DEFAULT NAME 00837000
CLI PNEXTNA,C'(' 00838000
BNE INLUP OTHERWISE, GO START PROCESSING 00839000
DEFO EQU * 00840000
OI OPF1,OP1DEFO SET DEFAULT OUTPUT NAME FLAG 00841000
B INLUP1 GO PROCESS INPUT FILENAME 00842000
EJECT 00843000
* COME HERE EACH TIME TO PROCESS NAME OF NEXT INPUT FILE. 00844000
INLUP EQU * 00845000
TM OPF1,OP1DEFO DEFAULT OUTPUT FILE NAME? 00846000
BO INLUPE WE'RE THRU IF SO 00847000
SPACE 00848000
* IF THE NEXT NAME AFTER THE CURRENT ONE BEGINS WITH C'(' OR X'FF', 00849000
* THEN THIS NAME IS AN OUTPUT FILE RATHER THAN AN INPUT FILE. 00850000
CLI PNEXTNA,X'FF' 00851000
BE INLUPE END OF INPUT FILE NAME PROC 00852000
CLI PNEXTNA,C'(' 00853000
BE INLUPE 00854000
SPACE 00855000
* XR3 POINTS TO THE CURRENT FILE FLAG BYTE. IF THIS BYTE ALREADY 00856000
* CONTAINS X'FF' RATHER THAN ZERO, THEN WE DON'T HAVE ROOM FOR ANY 00857000
* MORE INPUT FILE NAMES. 00858000
CLI 0(XR3),X'FF' 00859000
BE ERTMI TOO MANY INPUT FILE NAMES 00860000
SPACE 00861000
* WE FIRST CHECK FOR ILLEGAL CHARACTERS IN THE FILENAME. 00862000
INLUP1 EQU * 00863000
MVI TRTAB+C'*',0 DON'T CATCH *'S 00864000
MVI TRTAB+C'=',0 DON'T CATCH ='S 00865000
TRT PNA1(18),TRTAB CHECK FOR ILLEGAL CHARS 00866000
BNZ ERILC ERROR IF ANY FOUND 00867000
CLI PMO1+2,C' ' MORE THAN TWO CHARS IN FMODE? 00868000
BNE ERFM ERROR IF THERE ARE 00869000
MVI TRTAB+C'*',4 CHECK FOR *'S IN NAME 00870000
TRT PNA1(18),TRTAB SEARCH 00871000
BZ INLUPNS SKIP FOLLOWING CODE IF NONE 00872000
SPACE 00873000
* IF THERE IS AN ASTERISK IN THE FILE NAME, WE RECORD THIS FACT IN THE 00874000
* FLAG BYTE, AND THEN GO ON TO CHECK FOR AN EQUAL SIGN. 00875000
TRT PNA1,TRTAB STAR IN FILE NAME? 00876000
BZ *+8 SKIP IF NOT 00877000
OI 0(XR3),FSNA SET FLAG IF SO 00878000
TRT PTY1,TRTAB STAR IN FILE TYPE? 00879000
BZ *+8 SKIP IF NOT 00880000
OI 0(XR3),FSTY SET FLAG IF SO 00881000
TRT PMO1,TRTAB STAR IN FILE MODE? 00882000
BZ *+8 SKIP IF NOT 00883000
OI 0(XR3),FSMO SET FLAG IF SO 00884000
SPACE 00885000
MVI TRTAB+C'*',0 DON'T FIND A STAR ANYMORE 00886000
C XR2,PLPTR IS THIS THE FIRST INPUT FILE? 00887000
BE INLUPNS GO IF NOT 00888000
OI CFLAGS,FS OTHERWISE, SET 'COMBINED' FLAG 00889000
SPACE 00890000
SPACE 00891000
* COME HERE TO CHECK FOR EQUAL SIGN. 00892000
INLUPNS EQU * 00893000
MVI TRTAB+C'=',8 CATCH ='S 00894000
TRT PNA1(18),TRTAB SEARCH FOR ='S 00895000
BZ INLUPR GO IF NONE 00896000
* THERE IS AN EQUAL SIGN SOMEWHERE IN THE NAME. WE NOW FIND IT. 00897000
INLUPEQ EQU * 00898000
C XR2,PLPTR IS THIS FIRST INPUT FILE? 00899000
BE ERILC YES -- EQUAL SIGN ILLEGAL 00900000
TRT PNA1,TRTAB EQUAL SIGN IN NAME? 00901000
BZ *+8 SKIP IF NOT 00902000
OI 0(XR3),FENA SET FLAG 00903000
TRT PTY1,TRTAB EQUAL SIGN IN TYPE? 00904000
BZ *+8 SKIP IF NOT 00905000
OI 0(XR3),FETY SET FLAG 00906000
TRT PMO1,TRTAB EQUAL SIGN IN MODE? 00907000
BZ *+8 SKIP IF NOT 00908000
OI 0(XR3),FEMO SET FLAG 00909000
SPACE 00910000
* COME HERE WHEN FINISHED PROCESSING ONE INPUT FILE NAME, TO CHECK 00911000
* FOR NEXT 00912000
INLUPR EQU * 00913000
LA XR3,1(,XR3) POINT TO NEXT FLAG BYTE 00914000
LA XR2,PNEXT1 POINT TO NEXT FILE NAME 00915000
B INLUP GO PROCESS IT 00916000
SPACE 00917000
* COME HERE AT END OF INPUT FILE NAME PROCESSING 00918000
INLUPE EQU * 00919000
MVI 0(XR3),X'FF' SET X'FF' TO LAST FLAG BYTE 00920000
CLI INFLAGS,X'FF' WERE THERE ANY INPUT FILES? 00921000
BE ERNOIN NO INPUT FILES SPECIFIED 00922000
TM OPF1,OP1DEFO IS DEFAULT OUTPUT FILEID USED? 00923000
BZ OUTF GO IF NOT 00924000
MVI OUTFLAGS,FE SET ALL = FLAGS IN OUTFLAGS 00925000
LA R1,=3CL8'=' SET OUTPUT FILEID OF '= = =' 00926000
SH R1,=H'8' MAKE IT INTO A PLIST PTR 00927000
ST R1,POUPL1 SAVE AS OUTPUT PLIST PTR 00928000
B OUTCK 00929000
SPACE 00930000
* AT THIS POINT, REGISTER XR2 IS A PLIST1 POINTER FOR THE OUTPUT 00931000
* FILE NAME. 00932000
OUTF EQU * 00933000
ST XR2,POUPL1 STORE OUTPUT PLIST1 PTR 00934000
MVI TRTAB+C'*',4 RECOGNIZE *'S 00935000
MVI TRTAB+C'=',0 DON'T CATCH ='S 00936000
TRT PNA1(18),TRTAB SEARCH FOR ILLEGAL CHARS 00937000
BNZ ERILC GO IF ANY 00938000
CLI PMO1+2,C' ' MORE THAN TWO CHARS IN FMODE? @VA04194 00939000
BNE ERFM ERROR IF THERE ARE @VA04194 00940000
MVI TRTAB+C'=',8 CATCH ='S 00941000
TRT PNA1(18),TRTAB ANY ='S? 00942000
BZ OUTCR GO IF NONE 00943000
SPACE 00944000
OUTEQ EQU * 00945000
TRT PNA1,TRTAB CHECK FOR ='S IN FILE NAME 00946000
BZ *+8 SKIP IF NONE 00947000
OI OUTFLAGS,FENA SET FLAG IF SO 00948000
TRT PTY1,TRTAB CHECK FILE TYPE 00949000
BZ *+8 00950000
OI OUTFLAGS,FETY SET FLAG 00951000
TRT PMO1,TRTAB CHECK FILE MODE 00952000
BZ *+8 00953000
OI OUTFLAGS,FEMO 00954000
SPACE 00955000
* IF A STAR WAS SPECIFIED IN THE FIRST INPUT FILE IN THE SAME 00956000
* PLACE THAT AN EQUAL WAS SPECIFIED IN THE OUTPUT FILE, THEN WE 00957000
* DEFAULT TO 'MULTIPLE' OUTPUT FILE MODE. 00958000
OUTCK EQU * 00959000
IC R0,INFLAGS GET FIRST INPUT FILE FLAGS 00960000
IC R1,OUTFLAGS GET OUTPUT FILE FLAGS 00961000
N R1,=AL1(0,0,0,FE) MASK OUT 'EQUAL' BITS 00962000
SRL R1,3 SHIFT 'EQUAL' BITS TO 'STAR' *00963000
POSITIONS 00964000
NR R1,R0 'AND' THE FIELDS TOGETHER 00965000
BZ *+8 SKIP IF NO MATCHES 00966000
OI OPF2,OP2MULT SET 'MULTIPLE' MODE FLAG 00967000
SPACE 00968000
* END OF FILE NAME PROCESSING 00969000
OUTCR EQU * 00970000
LA XR2,8(,XR2) ADVANCE XR2 TO FIRST OPTION TOKN 00971000
TM OPF1,OP1DEFO DEFAULT OUTPUT FILENAME USED? 00972000
BO *+8 SKIP IF SO 00973000
LA XR2,24(,XR2) IF NOT, SKIP OVER OUTPUT FILE 00974000
* PROCESS OPTION LIST. 00975000
CLI 0(XR2),X'FF' ANY OPTIONS SPECIFIED? 00976000
BE ENDOP GO IF NOT 00977000
MVC STEMP(7),1(XR2) COPY FROM AFTER INITIAL '(' 00978000
MVI STEMP+7,C' ' FILL IN FINAL BLANK 00979000
CLI STEMP,C' ' DOES INITIAL ( HAVE AN OPTION? 00980000
BNE OP1 GO PROCESS IT IF SO 00981000
SPACE 00982000
* COME HERE TO PROCESS EACH NEW OPTION. 00983000
OPLUP EQU * 00984000
LA XR2,8(,XR2) POINT TO NEXT OPTION TOKEN 00985000
CLI 0(XR2),X'FF' END OF OPTION LIST? 00986000
BE ENDOP GO IF SO 00987000
CLI 0(XR2),C')' RIGHT PAREN? 00988000
BE OPRPAR GO IF YES 00989000
MVC STEMP(8),0(XR2) COPY OPTION INTO STEMP 00990000
SPACE 00991000
* AT THIS POINT, 'STEMP' CONTAINS THE OPTION 00992000
OP1 EQU * 00993000
LA R1,STEMP+7 WE SEARCH FOR FINAL NON-BLANK 00994000
LA XR3,8 MAX 8 CHARS 00995000
CLI 0(R1),C' ' IS THIS A BLANK? 00996000
BCTR R1,0 DECREMENT ADDRESS 00997000
BCTR XR3,0 DECREMENT CHAR COUNT 00998000
BE *-8 LOOP IF A BLANK 00999000
SPACE 01000000
* AT THIS POINT, XR3 CONTAINS OPTION (LENGTH - 1). 01001000
* WE NOW SEARCH THROUGH THE OPTION NAME CONTROL BLOCKS FOR THIS OPTION 01002000
* NAME. 01003000
USE OPSECT,XR 01004000
* THESE CONTROL BLOCKS ARE GENERATED BY THE OPTAB MACRO AT LOCATION 01005000
* OPTAB. 01006000
LA XR,OPTAB POINT TO FIRST BLOCK 01007000
LA R14,OPSLEN LENGTH OF A BLOCK 01008000
LA R15,OPTEND-OPSLEN END OF CONTROL BLOCKS 01009000
B OPFLUP ENTER SEARCH LOOP 01010000
SPACE 01011000
OPCLC CLC STEMP(0),OPNAME LENGTH FILLED IN BY EX 01012000
OPCLI CLI OPMIN,0 OPERAND FILLED IN BY EX 01013000
SPACE 01014000
* SEARCH LOOP 01015000
CNOP 0,8 01016000
OPFLUP EQU * 01017000
EX XR3,OPCLI WERE ENOUGH CHARS SPECIFIED *01018000
FOR THIS OPTION? 01019000
BH OPLEND SKIP IF NOT 01020000
EX XR3,OPCLC IS THIS THE OPTION? 01021000
BE OPFIND LOOP IF IT IS NOT 01022000
SPACE 01023000
OPLEND EQU * 01024000
BXLE XR,R14,OPFLUP LOOP BACK FOR NEXT 01025000
SPACE 01026000
B ERILO ILLEGAL OPTION 01027000
SPACE 01028000
* COME HERE WHEN OPTION FOUND 01029000
OPFIND EQU * 01030000
SPACE 01031000
* WE COMPUTE THE NUMBER OF THIS OPTION IN THE TABLE BY DIVIDING THE 01032000
* LENGTH OF A TABLE ENTRY INTO THE DISPLACEMENT INTO THE TABLE. 01033000
LR R1,XR CURRENT TABLE ADDRESS 01034000
LA R0,OPTAB START OF TABLE 01035000
SR R1,R0 DISPLACEMENT INTO TABLE 01036000
SR R0,R0 FOR DIVISION 01037000
D R0,=A(OPSLEN) DIVIDE BY LENGTH OF TABLE ENTRY 01038000
SPACE 01039000
* AT THIS POINT, THE QUOTIENT IS IN R1. 01040000
LH R15,NOPS GET NUMBER OF OPTIONS SO FAR 01041000
LA R15,1(,R15) ADD 1 01042000
STH R15,NOPS 01043000
STC R1,OPBYTES-1(R15) SAVE THIS OPTION VALUE 01044000
L R15,OPADD GET BRANCH ADDRESS FOR OPTION *01045000
HANDLER 01046000
BR R15 GO HANDLE THE OPTION 01047000
SPACE 2 01048000
EJECT 01049000
* PROCESS TYPE AND NOTYPE OPTIONS. 01050000
@TYPE EQU * 01051000
OI OPF1,OP1TYPE SET FLAG 01052000
SPACE 01053000
@NOTYPE EQU * 01054000
B OPLUP 01055000
EJECT 01056000
EJECT 01062000
* HANDLE OLDDATE AND NEWDATE OPTIONS. 01063000
@OLDDATE EQU * 01064000
OI OPF1,OP1OLDD SET FLAG 01065000
SPACE 01066000
@NEWDATE EQU * 01067000
B OPLUP 01068000
EJECT 01069000
* HANDLE LRECL OPTION 01070000
@LRECL EQU * 01071000
LA XR2,8(,XR2) POINT TO NEXT OPTION FIELD 01072000
BAL RR,GETNUM GET NUMERIC LRECL 01073000
C R1,=A(X'FFFF') TOO BIG? 01074000
BH ERARG ILLEGAL ARGUMENT 01075000
ST R1,LRECL OTHERWISE SAVE VALUE 01076000
B OPLUP GO FOR NEXT OPTION 01077000
EJECT 01078000
* HANDLE RECFM OPTION 01079000
@RECFM EQU * 01080000
LA XR2,8(,XR2) POINT TO SUB-FIELD 01081000
CLI 1(XR2),C' ' MORE THAN 1 CHAR? 01082000
BNE ERARG ILLEGAL IF YES 01083000
MVC RECFM,0(XR2) COPY THE FIELD 01084000
CLI RECFM,C'F' IS IT 'F'? 01085000
BE OPLUP OK IF IT IS 01086000
CLI RECFM,C'V' IS IT 'V'? 01087000
BE OPLUP GO IF IT IS 01088000
B ERARG ILLEGAL SUB-ARGUMENT 01089000
EJECT 01090000
* HANDLE 'EBCDIC', 'TRANS', 'UPCASE' AND 'LOWCASE' OPTIONS. 01091000
@EBCDIC EQU * 01092000
OI OPF3,OP3EBCD SET FLAG 01093000
B OPLUP GO FOR NEXT OPTION 01094000
SPACE 2 01095000
@TRANS EQU * 01096000
OI OPF3,OP3TRAN SET 'TRANS' FLAG 01097000
B OPLUP 01098000
SPACE 2 01099000
@UPCASE EQU * 01100000
OI OPF3,OP3UPCA SET 'UPCASE' FLAG 01101000
B OPLUP 01102000
SPACE 2 01103000
@LOWCASE EQU * 01104000
OI OPF3,OP3LOCA SET 'LOWCASE' FLAG 01105000
B OPLUP 01106000
EJECT 01107000
* HANDLE 'FROM' OPTION 01108000
@FROM EQU * 01109000
LA XR2,8(,XR2) POINT TO FIRST SUB-FIELD 01110000
BAL RR,GETNUM GET NUMERIC FIELD 01111000
ST R1,FROMN STORE RESULT 01112000
B OPLUP GO FOR NEXT OPTION 01113000
EJECT 01114000
* HANDLE 'FRLABEL' 01115000
@FRLABEL EQU * 01116000
LA XR2,8(,XR2) POINT TO LABEL 01117000
MVC FRL,0(XR2) COPY 8 BYTE FIELD 01118000
OI OPF1,OP1FRL SET FLAG TO INDICATE 01119000
* COMPUTE (LENGTH OF LABEL) -1 01120000
LA XR,8(,XR2) POINT BEYOND END OF LABEL 01121000
BCTR XR,0 DECREMENT POINTER 01122000
CLI 0(XR),C' ' IS IT A BLANK? 01123000
BE *-6 LOOP BACK IF NOT 01124000
SR XR,XR2 XR CONTAINS (LENGTH - 1) 01125000
STH XR,FRLL STORE IN WORK FIELD 01126000
B OPLUP GO FOR NEXT OPTION 01127000
EJECT 01128000
* HANDLE 'FOR' OPTION 01129000
@FOR EQU * 01130000
LA XR2,8(,XR2) POINT TO FIRST SUB-FIELD 01131000
BAL RR,GETNUM GET NUMERIC FIELD 01132000
ST R1,FORN STORE RESULT 01133000
B OPLUP GO FOR NEXT OPTION 01134000
EJECT 01135000
* HANDLE 'TOLABEL' 01136000
@TOLABEL EQU * 01137000
LA XR2,8(,XR2) POINT TO LABEL FIELD 01138000
MVC TOL,0(XR2) COPY 8 BYTE FIELD 01139000
OI OPF1,OP1TOL SET FLAG TO INDICATE 01140000
* COMPUTE (LENGTH OF LABEL) - 1 01141000
LA XR,8(,XR2) POINT BEYOND END OF LABEL 01142000
BCTR XR,0 DECREMENT POINTER 01143000
CLI 0(XR),C' ' IS IT A BLANK? 01144000
BE *-6 LOOP BACK IF NOT 01145000
SR XR,XR2 XR CONTAINS (LENGTH - 1) 01146000
STH XR,TOLL STORE IN WORK FIELD 01147000
B OPLUP GO FOR NEXT OPTION 01148000
EJECT 01149000
* HANDLE TRUNC AND NOTRUNC OPTIONS 01150000
@TRUNC EQU * 01151000
OI OPF1,OP1TRUNC SET FLAG TO INDICATE TRUNC 01152000
SPACE 01153000
@NOTRUNC EQU * 01154000
B OPLUP GO FOR NEXT OPTION 01155000
EJECT 01156000
* HANDLE 'FILL' OPTION 01157000
@FILL EQU * 01158000
LA XR2,8(,XR2) POINT TO FILL CHAR 01159000
CLI 2(XR2),C' ' MORE THAN TWO CHARS SPECIFIED? 01160000
BNE ERARG ERROR IF SO 01161000
IC R1,0(XR2) GET FIRST CHAR OF FILL 01162000
CLI 1(XR2),C' ' ONLY ONE CHAR SPECIFIED? 01163000
BE *+12 USE THAT CHAR IF SO 01164000
BAL RR,GETHEX GET HEX FOR 2 CHARACTERS 01165000
B ERARG ERROR RETURN FROM GETHEX 01166000
STC R1,FILLC STORE AS FILL CHARACTER 01167000
B OPLUP GO FOR NEXT OPTION 01168000
EJECT 01169000
EJECT 01193000
* HANDLE 'PACK' AND 'UNPACK' OPTIONS 01194000
@PACK EQU * 01195000
OI OPF2,OP2PACK SET 'PACK' OPTION FLAG 01196000
B OPLUP GO FOR NEXT OPTION 01197000
SPACE 2 01198000
@UNPACK EQU * 01199000
OI OPF2,OP2UNPA SET 'UNPACK' OPTION FLAG 01200000
B OPLUP GO FOR NEXT OPTION 01201000
EJECT 01202000
* HANDLE 'REPLACE', 'OVLY', 'APPEND' AND 'NEWFILE' OPTIONS 01203000
@REPLACE EQU * 01204000
OI OPF2,OP2REPL SET 'REPLACE' FLAG 01205000
B OPLUP GO FOR NEXT OPTION 01206000
SPACE 2 01207000
@OVLY EQU * 01208000
OI OPF2,OP2OVLY SET 'OVLY' FLAG 01209000
B OPLUP 01210000
SPACE 2 01211000
@APPEND EQU * 01212000
OI OPF2,OP2APPE SET 'APPEND' FLAG 01213000
B OPLUP 01214000
SPACE 2 01215000
* 'NEWFILE' FLAG WILL BE SET LATER AS THE DEFAULT. 01216000
@NEWFILE EQU * 01217000
OI OPF2,OP2NEWF SET 'NEWFILE' FLAG 01218000
B OPLUP GO FOR NEXT OPTION 01219000
EJECT 01220000
* HANDLE 'SPECS' AND 'NOSPECS' OPTIONS 01221000
@SPECS EQU * 01222000
OI OPF1,OP1SPECS SET SPECS FLAG 01223000
SPACE 2 01224000
@NOSPECS EQU * 01225000
B OPLUP GO FOR NEXT OPTION 01226000
EJECT 01227000
* HANDLE 'PROMPT' AND 'NOPROMPT' OPTIONS 01228000
@NOPROMP EQU * 01229000
OI OPF1,OP1NOPR SET NOPROMPT FLAG 01230000
SPACE 2 01231000
@PROMPT EQU * 01232000
B OPLUP GO FOR NEXT OPTION 01233000
EJECT 01234000
* HANDLE 'SINGLE' OPTION @VA05078 01235000
@SINGLE EQU * 01236000
NI OPF2,X'FF'-OP2MULT TURN OFF 'MULTIPLE' FLAG 01237000
B OPLUP GO FOR NEXT OPTION 01238000
EJECT 01239000
* COME HERE IF A RIGHT PAREN IS FOUND IN THE OPTION LIST. 01240000
OPRPAR EQU * 01241000
CLI 8(XR2),X'FF' IS THIS THE LAST OPTION? 01242000
BE ENDOP FINISHED WITH OPTIONS IF SO 01243000
SPACE 01244000
* OTHERWISE, WE HAVE AN ERROR SITUATION 01245000
MVC STEMP(2),0(XR2) COPY RIGHT PAREN INTO STEMP 01246000
MVC STEMP+2(6),8(XR2) COPY NEXT OPTION INTO STEMP 01247000
B ERILO GO TYPE ERROR MESSAGE 01248000
SPACE 01249000
* COME HERE AFTER ALL OPTIONS HAVE BEEN PROCESSED. 01250000
ENDOP EQU * 01251000
* IF REPLACE, OVLY AND APPEND WERE NOT SPECIFIED, THEN WE SET NEWFILE 01252000
* FLAG. 01253000
TM OPF2,OP2REPL+OP2OVLY+OP2APPE+OP2NEWF 01254000
BNZ ENDOP0 ONE WAS SPECIFIED 01255000
OI OPF2,OP2NEWF SET NEWFILE FLAG 01256000
L R1,POUPL1 POINT TO OUTPUT NAME PLIST 01257000
USE PLIST1,R1 01258000
CLC PNA1(24),=3CL8'=' OUTPUT NAME ALL ='S? 01259000
BNE *+8 SKIP IF NOT 01260000
XI OPF2,OP2NEWF+OP2REPL OTHERWISE, NEWF OFF AND REPL ON 01261000
ENDOP0 EQU * 01262000
SPACE 2 01263000
TM OPF2,OP2MULT IS 'MULTIPLE' MODE IN EFFECT? 01264000
BZ ENDOP1 SKIP CHECKING IF NOT 01265000
SPACE 01266000
* IN MULTIPLE MODE, IT IS ILLEGAL FOR *'S TO APPEAR IN ANY @VA05078 01267000
* FILE NA/TY/MO SPECIFICATION EXCEPT THAT FOR THE FIRST INPUT FILE. 01268000
* WE HAVE SET THE FLAG FS IN CFLAGS TO INDICATE WHETHER THE USER HAS 01269000
* ENTERED SUCH AN ASTERISK. 01270000
TM CFLAGS,FS ILLEGAL ASTERISK? 01271000
BZ ENDOP1 GO FOR NEXT OPTION IF NOT 01272000
SPACE 01273000
* OTHERWISE, WE GO BACK AND SEARCH OUR FLAG BYTES FOR THE ILLEGAL 01274000
* SPECIFICATION, SO THAT WE CAN TYPE IT OUT IN THE ERROR MESSAGE. 01275000
L XR2,PLPTR POINT TO 'COPY' PLIST 01276000
LA XR,INFLAGS POINT TO FIRST FLAG BYTE 01277000
USE PLIST1,XR2 01278000
SPACE 01279000
ENDOPM EQU * 01280000
LA XR2,PNEXT1 POINT TO NEXT FILE SPEC 01281000
LA XR,1(,XR) POINT TO NEXT FLAG BYTE 01282000
TM 0(XR),FS STAR SPECIFIED? 01283000
BZ ENDOPM LOOP IF NOT 01284000
B ERMST OTHERWISE, GO TYPE MESSAGE 01285000
SPACE 5 01286000
* IF BOTH 'TOLABEL' AND 'FRLABEL' WERE SPECIFIED, WE CHECK FOR ILLEGAL 01287000
* SITUATIONS. 01288000
ENDOP1 EQU * 01289000
TM OPF1,OP1FRL+OP1TOL BOTH 'FRLABEL' AND 'TOLABEL'? 01290000
BNO ENDOP2 GO IF NOT BOTH 01291000
LH XR,TOLL GET (LEN - 1) OF TOLABEL 01292000
B *+10 SKIP DUMMY CLC INSTRUCTION 01293000
CLC TOL(0),FRL LENGTH FILLED IN BY EX P3090 01294000
EX XR,*-6 COMPARE 'TOLABEL' WITH 'FRLABEL' 01295000
BNE ENDOP2 UNEQUAL -- NOTHING TO DO 01296000
SPACE 01297000
* OTHERWISE, IT'S ONE OF TWO POSSIBLE ERRORS. WE MUST DECIDE WHICH SO 01298000
* THAT WE CAN GIVE A PROPER ERROR MESSAGE. 01299000
CH XR,FRLL COMPARE LENGTHS OF LABELS 01300000
BE ERLAE BOTH LABELS ARE EQUAL 01301000
BL ERLAS 'FRL' IS SUBSTRING OF 'TOL' 01302000
SPACE 01303000
ENDOP2 EQU * 01304000
* CHECK FOR CONFLICTS IN OPTIONS. 01305000
* WE DO THIS BY GETTING THE CODE BYTES FOR THE OPTIONS AND CHECKING 01306000
* EACH PAIR AGAINST THE 'CONFTAB' OPTION CONFLICT LIST. 01307000
SR XR2,XR2 OPTION COUNTER (OUTSIDE LOOP) 01308000
LA R15,CONFEND-2 END OF CONFTAB CONFLICT TABLE 01309000
LA R14,2 LENGTH OF CONFTAB ELEMENT 01310000
SPACE 01311000
* OUTER LOOP. COME HERE TO PROCESS NEW OPTION. 01312000
CF1 EQU * 01313000
LA XR2,1(,XR2) POINT TO NEXT OPTION 01314000
CH XR2,NOPS END OF OPTION LIST? 01315000
BH CFEND YES -- END OF CONFLICT TEST 01316000
LR XR3,XR2 INITIALIZE INNER LOOP REG 01317000
SPACE 01318000
* THE INNER LOOP, USING REGISTER XR3, COMPARE ALL OPTION BYTES WITH 01319000
* THE OPTION BYTE POINTED TO BY THE OUTER LOOP REGISTER, XR2. 01320000
CF2 EQU * 01321000
LA XR3,1(,XR3) POINT TO NEXT OPTION BYTE 01322000
CH XR3,NOPS END OF OPTION LIST? 01323000
BH CF1 YES -- RETURN TO OUTER LOOP 01324000
SR R0,R0 01325000
IC R0,OPBYTES-1(XR2) GET OUTER LOOP OPTION 01326000
SR R1,R1 01327000
IC R1,OPBYTES-1(XR3) GET INNER LOOP OPTION BYTE 01328000
CR R0,R1 EQUAL OPTION BYTES? 01329000
BE ERDOP DUPLICATE OPTION 01330000
SPACE 01331000
* OTHERWISE, WE ARRANGE THE TWO OPTION BYTES IN HALFWORD FORM, SO 01332000
* THAT THE ONE ON THE LEFT IS LOWER. 01333000
BL *+8 SKIP IF FIRST LOWER 01334000
SLL R1,8 SHIFT SECOND BYTE LEFT 01335000
BH *+8 SKIP IF FIRST HIGHER 01336000
SLL R0,8 SHIFT FIRST BYTE LEFT 01337000
AR R0,R1 FORM HALFWORD 01338000
LA R1,CONFTAB POINT TO CONFLICT TABLE 01339000
CH R0,0(,R1) CONFLICTING BYTES? 01340000
BE ERCONF YES -- GO TYPE ERROR MESSAGE 01341000
BXLE R1,R14,*-8 LOOP THROUGH TABLE 01342000
B CF2 GO BACK TO INNER LOOP 01343000
SPACE 2 01344000
* COME HERE WHEN OUTER LOOP IS COMPLETED. 01345000
CFEND EQU * 01346000
EJECT 01347000
* IF PACK OR UNPACK OPTION WAS SPECIFIED, THEN WE DO NOT ALLOW @VA11777 01348000
* ANY MULTIPLE INPUT FILE, IN THE SENSE OF APPENDING (ALTHOUGH, OF 01349000
* COURSE, THE MULTIPLE OUTPUT FILE MODE MAY BE IN EFFECT). SO @VA05078 01350000
* WE CHECK FOR THIS. 01351000
TM OPF2,OP2PACK+OP2UNPA ANY OF THESE IN EFFECT?@VA11777 01352000
BZ SPRS GO IF NOT 01353000
CLI INFLAGS+1,X'FF' MULTIPLE INPUT FILE SPEC? 01354000
BNE ERGUP ERROR IF SO 01355000
TM INFLAGS,FS ANY *'S IN INPUT FILE SPEC? 01356000
BZ SPRS WE'RE THROUGH IF NOT 01357000
TM OPF2,OP2MULT OTHERWISE, WE'D BETTER BE MULT 01358000
BO SPRS OK IF YES 01359000
B ERGUP ERROR IF NOT 01360000
* OPTION TABLE 01361000
OPTAB TABLE TYPE,1, *01362000
NOTYPE,3, *01363000
NEWDATE,4, *01364000
OLDDATE,4, *01365000
RECFM,3, *01366000
EBCDIC,2,UPCASE,2,LOWCASE,2,TRANS,3, *01367000
LRECL,2, *01368000
FROM,2,FRLABEL,3, *01369000
FOR,3,TOLABEL,3, *01370000
TRUNC,3, *01371000
NOTRUNC,4, *01372000
FILL,2, *01373000
PROMPT,2,NOPROMPT,4, *01374000
PACK,2,UNPACK,3, *01376000
SPECS,2,NOSPECS,4, *01377000
REPLACE,3, *01378000
OVLY,2, *01379000
APPEND,2, *01380000
NEWFILE,4, *01381000
SINGLE,2 01383000
OPTEND EQU * TABLE END 01384000
EJECT 01385000
* CONFLICT TABLE 01386000
CONFTAB CONFLICT (TYPE,NOTYPE), *01387000
(NEWDATE,OLDDATE), *01388000
(APPEND,NEWDATE,OLDDATE,RECFM,LRECL,NEWFILE,OVLY, *01389000
REPLACE), *01390000
(TRUNC,NOTRUNC), *01391000
(SPECS,NOSPECS), P1109*01392000
(PROMPT,NOPROMPT), *01393000
(PACK,TRUNC,LRECL,RECFM,SPECS,OVLY,APPEND, @VA11777*01398000
EBCDIC,TRANS,UPCASE,LOWCASE), @VA11777*01399000
(UNPACK,TRUNC,LRECL,RECFM,SPECS,OVLY,APPEND, @VA11777*01400000
PACK,EBCDIC,TRANS,UPCASE,LOWCASE), @VA11777*01401000
(REPLACE,OVLY,NEWFILE), *01402000
(FROM,PACK,UNPACK), @VA11777*01403000
(FRLABEL,FROM,PACK,UNPACK), @VA11777*01404000
(FOR,PACK,UNPACK), @VA11777*01405000
(TOLABEL,FOR,PACK,UNPACK), @VA11777*01406000
(OVLY,NEWFILE) 01407000
CONFEND EQU * END OF CONFLICT TABLE 01408000
* READ 'SPECS' LIST FROM TERMINAL, IF THE OPTION WAS SPECIFIED, AND 01409000
* SET UP CONTROL BLOCKS. 01410000
SPRS EQU * 01411000
TM OPF1,OP1SPECS 'SPECS' SPECIFIED? 01412000
BZ SPRE GO IF NOT 01413000
LA SPR,SPECSB-SPBLEN POINT TO SPECS CTL BLOCKS 01414000
LA R1,SPECST POINT TO TEMP STRING STORAGE 01415000
ST R1,SPECSTE INITIALIZE POINTER 01416000
TM OPF1,OP1NOPR WAS 'NOPROMPT' SPECIFIED 01417000
BZ SPRI NO -- GO TYPE MESSAGE 01418000
SPACE 01419000
* RETURN HERE FROM SPRI 01420000
SPR1 EQU * 01421000
SPACE 01422000
* SET UP 'WAITRD' PLIST 01423000
MVI CRPLIST+12,C'T' NO UPCASE OR BLANK FILL 01424000
LA R1,CRPLIST POINT TO WAITRD PLIST 01425000
SVC 202 READ A LINE 01426000
LA XR,STRING-1 POINT TO DATA AREA 01427000
L R1,CRPLIST+12 LENGTH OF TERMINAL LINE 01428000
LA R1,0(R1,XR) END OF TERMINAL INPUT LINE 01429000
ST R1,SPECTMP STORE IN TEMPORARY 01430000
SPACE 01431000
* COME HERE TO PROCESS NEXT SPECIFICATION 01432000
SPRLUP EQU * 01433000
LA XR,1(,XR) POINT TO NEXT INPUT CHAR 01434000
C XR,SPECTMP END OF INPUT? 01435000
BH SPREND FINISHED IF SO 01436000
CLI 0(XR),C' ' BLANK? 01437000
BE SPRLUP SKIP IT 01438000
CLC =C'++',0(XR) CONTINUATION INDICATOR? 01439000
BE SPR1 GO READ NEW LINE IF YES 01440000
LA SPR,SPNEXT POINT TO NEXT SPEC CTL BLOCK 01441000
CLI SPINDISP,X'FF' ARE WE OUT OF CONTROL BLOCKS? 01442000
BE ERTMS TOO MANY SPECIFICATIONS 01443000
CLI 0(XR),X'80' FIRST CHAR NON-ALPHAMERIC? 01444000
BL SPRLS GO HANDLE IT IF SO 01445000
CLI 0(XR),C'H' FIRST CHAR AN H? 01446000
BE SPRLH HANDLE HEX STRING IF SO 01447000
CLI 0(XR),X'88' FIRST CHAR A SMALL H? 01448000
BE SPRLH HANDLE HEX STRING IF SO 01449000
SPACE 01450000
* OTHERWISE, THE FIRST FIELD IS IN THE FORM NN-MM, AND WE MUST CONVERT 01451000
* THESE TWO NUMBERS INTO INTERNAL FORM. 01452000
LR XR2,XR SAVE POINTER 01453000
SPACE 01454000
* WE FIND THE HYPHEN SEPARATING THE TWO FIELDS. 01455000
SPACE 01456000
SPRLN EQU * 01457000
LA XR,1(,XR) GET NEXT CHAR 01458000
C XR,SPECTMP END OF INPUT TERM LINE 01459000
BH ERILS ILLEGAL SPECIFICATION 01460000
CLI 0(XR),C'-' HYPHEN? 01461000
BNE SPRLN LOOP IF NOT 01462000
SPACE 01463000
* AT THIS POINT, XR POINTS TO THE HYPHEN. WE CHANGE IT 01464000
* TEMPORARILY TO A BLANK, SO THAT THE NUMBER CONVERTER WON'T BE 01465000
* CONFUSED BY IT. 01466000
MVI 0(XR),C' ' CHANGE - TO BLANK 01467000
BAL RR,GETNUMS GET NUMBER 01468000
MVI 0(XR),C'-' RESTORE HYPHEN 01469000
BCTR R1,0 STORE (FIRST COL)-1 01470000
ST R1,SPINDISP STORE FIRST FIELD IN CTL BLOCK 01471000
SPACE 01472000
* WE NOW CONVERT THE SECOND NUMBER IN THE FIELD. 01473000
SPRLN2 EQU * 01474000
LA XR,1(,XR) POINT TO NEXT CHAR 01475000
C XR,SPECTMP END OF INPUT LINE? 01476000
BH ERILS ERROR IF SO 01477000
CLI 0(XR),C' ' BLANK? 01478000
BE SPRLN2 THEN SKIP IT 01479000
LR XR2,XR SAVE POINTER TO BEG OF FIELD 01480000
SPACE 01481000
* WE FIND THE END OF THE SECOND NUMBER, AND THEN WE CONVERT IT TO 01482000
* INTERNAL FORM. 01483000
SPRLN3 EQU * 01484000
LA XR,1(,XR) POINT TO NEXT CHAR 01485000
C XR,SPECTMP END OF LINE? 01486000
BH ERILS ERROR IF SO 01487000
CLI 0(XR),C' ' BLANK? 01488000
BNE SPRLN3 NO -- LOOP BACK 01489000
BAL RR,GETNUMS CONVERT NUMBER TO INTERNAL FORM 01490000
C R1,SPINDISP LOWER THAN FIRST SPEC? 01491000
BL ERILS ERROR IF SO 01492000
ST R1,SPLAST SAVE VALUE IN CTL BLOCK 01493000
B SPRT GO GET NEXT NUMBER 01494000
SPACE 2 01495000
* COME HERE FOR A STRING SPECIFICATION. 01496000
SPRLS EQU * 01497000
MVC SPECC,0(XR) SAVE DELIMITER 01498000
LR XR2,XR COPY POINTER 01499000
SPACE 01500000
* FIND END OF STRING 01501000
SPRLS2 EQU * 01502000
LA XR,1(,XR) GET NEXT CHAR 01503000
C XR,SPECTMP END OF INPUT LINE? 01504000
BH ERILS ERROR IF SO 01505000
CLC SPECC,0(XR) HAVE WE FOUND DELIMITER? 01506000
BNE SPRLS2 LOOP IF NOT 01507000
SPACE 01508000
LR R1,XR POINT TO END OF STRING 01509000
SR R1,XR2 01510000
BCTR R1,0 R1 CONTAINS LENGTH 01511000
LTR R1,R1 ANY STRING? 01512000
BNP ERILS ZERO LENGTH ILLEGAL 01513000
SPACE 01514000
L R15,SPECSTE POINT TO CURRENT END OF STRING *01515000
STORAGE 01516000
ST R15,SPINDISP SAVE ADDRESS IN CONTROL BLOCK 01517000
OI SPINDISP,X'80' SET 'STRING' FLAG 01518000
ST R1,SPLAST SAVE LENGTH IN CONTROL BLOCK 01519000
LA R14,1(R1,R15) POINT TO END OF STRING STORAGE 01520000
C R14,SPECSTM WILL WE EXCEED STRING STORAGE? 01521000
BNL ERSPECSX GO IF YES 01522000
ST R14,SPECSTE SAVE NEW POINTER 01523000
BCTR R1,0 DECREMENT LENGTH FOR EX 01524000
B *+10 SKIP OVER MVC 01525000
MVC 0(0,R15),1(XR2) LENGTH FILLED IN BY EX 01526000
EX R1,*-6 MOVE STRING INTO STORAGE AREA 01527000
B SPRT GO GET NEXT NUMBER 01528000
SPACE 2 01529000
* COME HERE WHEN 'FROM' TARGET IS HEX FIELD 01530000
SPRLH EQU * 01531000
LR XR2,XR SAVE POINTER TO 'H' 01532000
CLI 1(XR),C' ' NEXT CHAR A BLANK? 01533000
BE ERILS ILLEGAL IF SO 01534000
C XR,SPECTMP END OF BUFFER? 01535000
BE ERILS ERROR IF SO 01536000
L XR3,SPECSTE POINT TO CURRENT END OF STRING *01537000
STORAGE 01538000
ST XR3,SPINDISP STORE AS DISPLACEMENT IN CTL BLK 01539000
OI SPINDISP,X'80' SET 'STRING' FLAG 01540000
BCTR XR2,0 XR2 -> 2 BYTES BEFORE FIRST DIG 01541000
SPACE 01542000
* COME HERE TO GET NEXT HEX DIGIT PAIR 01543000
SPRLH1 EQU * 01544000
LA XR2,2(,XR2) POINT TO NEXT HEX DIGIT PAIR 01545000
C XR2,SPECSTM END OF BUFFER? 01546000
BE ERILS ERROR IF SO 01547000
BAL RR,GETHEX GET HEX VALUE 01548000
B ERILS ERROR RETURN FROM GETHEX 01549000
C XR3,SPECSTM ARE WE EXCEEDING STRING STORAGE? 01550000
BNL ERSPECSX STOP HERE IF WE ARE 01551000
STC R1,0(XR3) STORE CHAR IN STRING BUFFER 01552000
LA XR3,1(,XR3) POINT TO NEXT STRING STORAGE CHR 01553000
CLI 2(XR2),C' ' END OF HEX STRING? 01554000
BNE SPRLH1 LOOP BACK IF NOT 01555000
SPACE 01556000
* COME HERE AT END OF HEX STRING 01557000
LR R1,XR3 COPY CURRENT STRING STORAGE PTR 01558000
S R1,SPECSTE LENGTH OF STRING 01559000
ST R1,SPLAST STORE AS LENGTH IN CTL BLK 01560000
ST XR3,SPECSTE STORE NEW END OF STOR BUFFER 01561000
LA XR,2(,XR2) RESET XR2 TO END OF HEX FIELD 01562000
SPACE 2 01563000
* WE NOW FIND AND CONVERT THE NUMBER REPRESENTING THE DISPLACEMENT 01564000
* INTO THE OUTPUT BUFFER. 01565000
SPRT EQU * 01566000
LA XR,1(,XR) GET NEXT CHAR 01567000
C XR,SPECTMP END OF INPUT LINE? 01568000
BH ERILS YES -- ERROR 01569000
CLI 0(XR),C' ' BLANK? 01570000
BE SPRT YES -- SKIP IT 01571000
LR XR2,XR SAVE POINTER TO FIRST CHAR 01572000
SPACE 01573000
* FIND END OF NUMBER AND CONVERT IT TO INTERNAL FORM. 01574000
SPRT1 EQU * 01575000
LA XR,1(,XR) GET NEXT CHAR 01576000
C XR,SPECTMP END OF INPUT LINE? 01577000
BH SPRT2 END OF LOOP IF YES 01578000
CLI 0(XR),C' ' BLANK? 01579000
BNE SPRT1 LOOP IF NOT 01580000
SPACE 01581000
SPRT2 EQU * 01582000
MVI 0(XR),C' ' CHANGE END OF FIELD TO BLANK 01583000
BAL RR,GETNUMS GET NUMERIC FIELD 01584000
BCTR R1,0 DECREMENT COLUMN NUMBER 01585000
ST R1,SPOUDISP SAVE AS OUTPUT DISPLACEMENT 01586000
SPACE 01587000
* WE SAVE THE LARGEST OUTPUT BUFFER DISPLACEMENT IN SPECMAX. 01588000
C R1,SPECMAX LARGER THAN LARGEST SO FAR? 01589000
BL *+8 SKIP IF NOT 01590000
ST R1,SPECMAX STORE IT IF YES 01591000
B SPRLUP GO FOR NEXT SPEC 01592000
SPACE 3 01593000
* COME HERE WHEN OUT OF SPECIFICATIONS 01594000
SPREND EQU * 01595000
MVI SPNEXT,X'FF' SIGNAL END OF SPECS 01596000
CLI SPECSB,X'FF' ANY SPECS SPECIFIED? 01597000
BE ERNS NO -- THIS IS AN ERROR 01598000
SPACE 01599000
SPRE EQU * 01600000
EJECT 01601000
* SET UP TRANSLATE TABLE, IN CASE IT'S GOING TO BE NEEDED. 01602000
SR XR,XR 01603000
LA R14,1 01604000
LA R15,255 01605000
SPACE 01606000
* INITIALIZE EACH BYTE TO ITSELF. 01607000
STC XR,TRTAB(XR) STORE BYTE IN TABLE 01608000
BXLE XR,R14,*-4 LOOP THROUGH TABLE 01609000
SPACE 01610000
* SET SPECIAL 026 TO 029 CONVERSIONS, IF 'EBCDIC' OPTION SPECIFIED. 01611000
TM OPF3,OP3EBCD 'EBCDIC' OPTION SPECIFIED? 01612000
BNO SETTR1 SKIP CODE IF NOT 01613000
MVI TRTAB+C'<',C')' < TO ) 01614000
MVI TRTAB+C'&&',C'+' & TO + 01615000
MVI TRTAB+C'%',C'(' % TO ( 01616000
MVI TRTAB+C'#',C'=' # TO = 01617000
MVI TRTAB+C'@',C'''' @ TO ' 01618000
MVI TRTAB+C'''',C':' ' TO : 01619000
SPACE 2 01620000
* SET 'LOWCASE' CONVERSIONS, IF SPECIFIED 01621000
SETTR1 EQU * 01622000
TM OPF3,OP3LOCA 'LOWCASE' SPECIFIED? 01623000
BZ SETTR2 SKIP IF NOT 01624000
XC TRTAB+C'A'(9),BLANKS TRANSLATE A-I 01625000
XC TRTAB+C'J'(9),BLANKS TRANSLATE J-R 01626000
XC TRTAB+C'S'(8),BLANKS TRANSLATE S-Z 01627000
SPACE 01628000
* SET 'UPCASE' CONVERSIONS, IF SPECIFIED 01629000
SETTR2 EQU * 01630000
TM OPF3,OP3UPCA 'UPCASE' OPTION SPECIFIED? 01631000
BZ SETTR3 SKIP IF NOT 01632000
XC TRTAB+X'81'(9),BLANKS TRANSLATE SMALL A-I 01633000
XC TRTAB+X'91'(9),BLANKS TRANSLATE SMALL J-R 01634000
XC TRTAB+X'A2'(8),BLANKS TRANSLATE SMALL S-Z 01635000
SPACE 01636000
SETTR3 EQU * 01637000
EJECT 01638000
* READ TRANSLATE TABLE FROM TERMINAL, IF DESIRED 01639000
RTR EQU * 01640000
TM OPF3,OP3TRAN 'TRANSLAT' OPTION SPECIFIED? 01641000
BZ RTREX SKIP IF NOT 01642000
SR XR3,XR3 INDICATE WHETHER *01643000
A NULL LIST IS ENTERED 01644000
TM OPF1,OP1NOPR 'NOPROMPT' OPTION SPECIFIED? 01645000
BZ RTRI GO TYPE PROMPT IF NOT 01646000
SPACE 01647000
RTR1 EQU * 01648000
MVI CRPLIST+12,C'T' NO UPCASE OR BLANK FILL 01649000
LA R1,CRPLIST POINT TO 'WAITRD' PLIST 01650000
SVC 202 READ A LINE FROM THE TERMINAL 01651000
LA XR2,STRING-1 POINT TO JUST BEFORE LINE 01652000
L XR,CRPLIST+12 GET LENGTH OF LINE 01653000
LA XR,0(XR,XR2) XR -> LAST CHARACTER IN LINE 01654000
SPACE 01655000
* COME HERE TO GET NEXT TRANSLATE PAIR 01656000
RTRL EQU * 01657000
LA XR2,1(,XR2) POINT TO NEXT CHAR IN BUFFER 01658000
CLI 0(XR2),C' ' BLANK? 01659000
BE *-8 SKIP IT IF SO 01660000
CR XR2,XR END OF BUFFER? 01661000
BH RTRE WE'RE FINISHED IF SO 01662000
BE ERTRS ERROR IF LAST CHAR OF BUFFER 01663000
CLC =C'++',0(XR2) CONTINUATION SPECIFIED? 01664000
BE RTR1 GO DO ANOTHER READ, IF SO 01665000
SR R1,R1 01666000
IC R1,0(XR2) GET CHARACTER 01667000
CLI 1(XR2),C' ' IS NEXT CHAR A BLANK? 01668000
BE *+12 THEN USE THE CHARACTER IF SO 01669000
BAL RR,GETHEX OTHERWISE, CONVERT TO HEX 01670000
B ERTRS ERROR RETURN FROM GETHEX 01671000
LA XR3,TRTAB(R1) POINT TO SPOT IN TRANSLATE TAB 01672000
LA XR2,1(,XR2) SKIP OVER THIS FIELD 01673000
LA XR2,1(,XR2) FIND FIRST NON-BLANK 01674000
CLI 0(XR2),C' ' BLANK? 01675000
BE *-8 THEN SKIP IT 01676000
CR XR2,XR END OF BUFFER? 01677000
BH ERTRS ERROR IF SO 01678000
BL *+8 SKIP IF NOT AT END 01679000
MVI 1(XR2),C' ' FORCE NEXT CHAR BLANK 01680000
IC R1,0(XR2) GET FIRST CHAR IN FIELD 01681000
CLI 1(XR2),C' ' NEXT CHAR A BLANK? 01682000
BE *+12 THEN USE CHARACTER IF SO 01683000
BAL RR,GETHEX GET HEX FIELD IF NOT 01684000
B ERTRS ERROR RETURN FROM GETHEX 01685000
STC R1,0(XR3) STORE CHARACTER IN TRANSLATE TAB 01686000
LA XR2,1(,XR2) INCREMENT STRING POINTER 01687000
B RTRL LOOP BACK FOR NEXT 01688000
SPACE 01689000
* COME HERE WHEN FINISHED 01690000
RTRE EQU * 01691000
LTR XR3,XR3 WERE THERE ANY TRANSLATIONS? 01692000
BZ ERNT ERROR IF NOT 01693000
SPACE 01694000
RTREX EQU * 01695000
* PHASE IN -- INITIALIZATION PHASE 01696000
IN PHBEG 01697000
CODE FPT POINT TO FIRST INPUT FILE 01698000
CODE CKIC CHECK FOR ILLEGAL CHAR IN FILEID 01699000
CODE FFFST FIND FIRST FST FOR FILE 01700000
CODE SKFST SKIP IF FST EXISTS 01701000
CODE ERNIF ERROR -- NO INPUT FILE NAME 01702000
CODE MRWP MAKE RDBUF/WRBUF PLIST 01703000
CODE FPT2 EXTRA FIRST FILE PROCESSING 01704000
CODE TACT TEST IF FILE ALREADY ACTIVE (ER) 01705000
MING EQU * 01710000
TM OPF2,OP2OVLY+OP2MULT+OP2APPE MULT OUT,APPE,OVLY @VA06259 01711000
BNZ MINGPO YES. ALREADY HAVE LRECL & RECFM @VA06259 01712000
CLI RECFM,0 RECFM SPECIFIED? @VA05624 01713000
BE MINGIN2 NO, LOOP NECESSARY @VA05624 01714000
CLC LRECL,=F'0' LRECL SPECIFIED? @VA05624 01715000
BE MINGIN2 NO, LOOP NECESSARY @VA05624 01716000
MINGPO CODE GOPO ENTER PHASE PO @VA05624 01717000
B MRE GO BUILD RESTART PHASE @VA05624 01718000
MINGIN2 CODE GOIN2 ENTER PHASE IN2 @VA05624 01719000
IN PHEND 01720000
EJECT 01721000
*IN2 PHASE IN2 -- INITIALIZATION FOR SINGLE OUTPUT MODE 01722000
IN2 PHBEG @VA05624 01723000
CLI RECFM,0 RECFM SPECIFIED? @VA05624 01724000
BNE MIN2LR YES, DON'T MODIFY BUT SET LRECL @VA05624 01725000
MVI RECFM,C' ' SIGNAL PH PO TO USE ANYWAY @VA05624 01726000
CODE CFMA FIND 'BEST' RECFM @VA05624 01727000
CLC LRECL,=F'0' LRECL SPECIFIED? @VA05624 01728000
BNE MIN2S YES, DON'T MODIFY @VA05624 01729000
MIN2LR MVC LRECL,=F'-1' SIGNAL PH PO TO USE ANYWAY @VA05624 01730000
CODE CRLA FIND LARGEST LRECL @VA05624 01731000
MIN2S CODE NVPT NEXT 'VERTICAL' FILE @VA05624 01732000
CODE FNFST GET NEXT FST @VA05624 01733000
CODE SKNFST SKIP IF NOT FOUND @VA05624 01734000
CODE GOIN2 SET LRECL AND/OR RECFM @VA05624 01735000
CODE NHPT NEXT 'HORIZONTAL' FILE @VA05624 01736000
CODE SKFND SKIP IF MORE INPUT @VA05624 01737000
CODE GOIN3 ALL DONE, GO RESTART INPUT @VA05624 01738000
CODE SUBE MUST REPLACE = @VA05624 01739000
CODE FFFST FIRST 'HORIZONTAL' FILE @VA05624 01740000
CODE CKIC CHECK FOR ILLEGAL CHARACTERS @VA05624 01741000
CODE GOIN2 SET LRECL AND/OR RECFM @VA05624 01742000
IN2 PHEND @VA05624 01743000
SPACE 2 01744000
IN3 PHBEG @VA05624 01745000
CODE FPT FIRST INPUT FILE @VA05624 01746000
CODE FFFST FIRST 'HORIZONTAL' FILE @VA05624 01747000
CODE MRWP SET READ PARAMETERS @VA05624 01748000
CODE FPT2 ADDITIONAL FIRST FILE STUFF @VA05624 01749000
CODE GOPO GO SETUP OUTPUT @VA05624 01750000
B MPO GO DO OUTPUT @VA05624 01751000
IN3 PHEND @VA05624 01752000
EJECT 01753000
* PHASE RE - RESTART PHASE (MULTIPLE MODE ONLY) 01754000
RE PHBEG 01755000
CODE FPT POINT TO FIRST INPUT FILE 01756000
CODE FNFST FIND NEXT FST FOR FILE 01757000
CODE SKFST SKIP IF FST EXISTS 01758000
CODE EXIT EXIT IF IT DOES NOT 01759000
CODE MRWP MAKE RDBUF/WRBUF PLIST 01760000
CODE FPT2 EXTRA FIRST FILE PROCESSING 01761000
CODE TACT TEST IF FILE ALREADY ACTIVE 01762000
CODE GOPO ENTER PHASE PO 01765000
RE PHEND 01766000
EJECT 01767000
* PHASE PO -- PHASE TO PROCESS OUTPUT FILE NAME 01768000
PO PHBEG 01769000
CODE OPT POINT TO OUTPUT FILE 01770000
CODE SUBE SUBSTITUTE FOR EQUAL SIGNS 01771000
CODE CKIC CHECK FOR ILLEGAL CHAR IN FILEID 01772000
CODE FWFST FIND FST FOR FILE (IF ANY) 01773000
CODE SOMODE SET CORRECT OUTPUT FILE MODE 01774000
CODE MRWP MAKE RDBUF/WRBUF PLIST 01775000
CODE TRW TEST IF OUTPUT DISK IS RW 01776000
CLI RECFM,0 RECFM OPTION SPECIFIED? 01777000
CODE CFMS,NE USE SPECIFIED RECFM IF SO 01778000
CLC LRECL,=F'0' LRECL OPTION SPECIFIED? 01779000
CODE CRLS,NE USE SPECIFIED LRECL 01780000
TM OPF2,OP2NEWF NEW OUTPUT FILE? 01781000
BO MPON GO HANDLE IT 01782000
TM OPF2,OP2APPE APPEND OPTION? 01783000
BO MPOA GO HANDLE IT 01784000
TM OPF2,OP2OVLY OVLY OPTION? 01785000
BO MPOV GO HANDLE IT 01786000
B MPOR OTHERWISE, IT'S REPLACE 01787000
SPACE 5 01788000
* NEW FILE OPTION OF PHASE PO 01789000
MPON EQU * 01790000
CODE SKNFST SKIP IF NO FST 01791000
CODE ERNX ERROR -- NEW FILE ALREADY EXISTS 01792000
SPACE 3 01793000
* REPLACE OPTION OF PHASE PO 01794000
MPOR EQU * 01795000
CODE WTEMP USE CMSUT FILEID IN OUTPUT *01796000
PLIST 01797000
CLI RECFM,0 RECFM SPECIFIED? 01798000
CODE CFMI,E COPY INPUT FILE RECFM IF NOT 01799000
CLC LRECL,=F'0' LRECL SPECIFIED? 01800000
CODE CRLI,E COPY INPUT FILE LRECL IF NOT 01801000
B MPOPE GO FINISH PHASE PO 01802000
SPACE 5 01803000
* OVERLAY OPTION OF PHASE PO 01804000
MPOV EQU * 01805000
CODE SKFST SKIP IF FST EXISTS 01806000
CODE ERNVF ERROR - OVERLAY FILE NOT EXIST 01807000
CODE TACT TEST IF FILE ALREADY ACTIVE (ER) 01808000
CODE WTEMP USE CMSUT FILEID IN OUTPUT *01809000
PLIST 01810000
CODE FFFST @VA06129 01811000
CODE VPT POINT TO OVERLAY FILE 01812000
CODE MRWP MAKE RDBUF/WRBUF PLIST 01813000
B MPOPE GO FINISH PHASE PO 01814000
SPACE 5 01815000
* APPEND OPTION OF PHASE PO 01816000
MPOA EQU * 01817000
CODE TACT ERROR IF FILE ALREADY ACTIVE 01818000
CODE SKNFST SKIP IF FST DOESN'T EXIST 01819000
CODE APITEM SET ITEM NUMBER FOR APPEND 01820000
CODE SKFST SKIP IF FST EXISTS 01821000
CODE CFMI COPY INPUT FILE RECFM 01822000
CODE SKFST SKIP IF FST EXISTS 01823000
CODE CRLI COPY INPUT FILE LRECL 01824000
B MPOPE GO FINISH PHASE PO 01825000
SPACE 5 01826000
* FINISH UP PHASE PO 01827000
MPOPE EQU * 01828000
TM OPF1,OP1TYPE TYPE OPTION SPECIFIED? 01829000
CODE IOTYPE,O TYPE NAMES OF FILES IF SO 01830000
CODE SFIT SAVE ITEM # OF FIRST RECORD 01831000
CODE GOPC ENTER PRE-COPY PHASE 01832000
PO PHEND 01833000
EJECT 01834000
* PHASE PC -- PRE-COPY PHASE. 01835000
* THIS PHASE WILL BE ENTERED AFTER EACH NEW INPUT FILE IS IDENTIFIED. 01836000
PC PHBEG 01837000
TM OPF2,OP2PACK 'PACK' OPTION SPECIFIED? 01838000
CODE PCPACK,O PERFORM BUFFER COMPUTATIONS IFSO 01839000
TM OPF2,OP2UNPA 'UNPACK' OPTION SPECIFIED? 01840000
CODE PCUNPA,O READ FILE HEADER BUFFER IF SO 01841000
CODE PCSET SET UP I/O BUFFERS 01842000
TM OPF2,OP2PACK 'PACK' OPTION SPECIFIED? 01843000
CODE PCPAB,O SET UP PACK BUFFERS IF SO 01844000
TM OPF2,OP2UNPA 'UNPACK' OPTION SPECIFIED? 01845000
CODE PCUPB,O SET UN UNPACK BUFFERS IF SO 01846000
CLC FROMN,=F'0' ANY 'FROM' NUMBER SPECIFIED? 01847000
CODE SKIPN,NE SKIP TO FROM NUMBER 01848000
TM OPF1,OP1FRL ANY FRLABEL SPECIFIED? 01849000
CODE SKIPL,O SKIP TO FRLABEL IF SO 01850000
CLC FORN,=F'0' ANY 'FOR' NUMBER SPECIFIED? 01851000
CODE SETFOR,NE SET UP FOR 'FOR' NUMBER IF SO 01852000
CODE GOCO ENTER PHASE CO -- COPY PHASE 01853000
PC PHEND 01854000
EJECT 01855000
* PHASE CO -- COPY PHASE 01856000
CO PHBEG 01857000
CODE IBUFF INITIALIZE OUTPUT BUFFER IF NECC 01858000
TM OPF2,OP2OVLY OVERLAY FILE? 01859000
CODE RDOVLY,O READ OVERLAY FILE INTO OUTPUT *01860000
BUFFER, IF SO (EOF -> PHCL) 01861000
CLC FORN,=F'0' ANY 'FOR' NUMBER SPECIFIED? 01862000
CODE CKFORN,NE CHECK TO SEE IF IT'S BEEN *01863000
REACHED (FOUND -> PHEO) 01864000
TM OPF2,OP2UNPA 'UNPACK' OPTION SPECIFIED? 01865000
CODE RDIN,Z IF NOT, READ CURRENT INPUT *01866000
FILE (EOF -> PHEO) 01867000
TM OPF1,OP1SPECS INPUT BUFFER = OUTPUT BUFFER? 01868000
CODE SVE,NO SET VBUFEND IF SO 01869000
TM OPF1,OP1TOL 'TOLABEL' SPECIFIED? 01870000
CODE CKTOL,O CHECK 'TOLABEL' IF SO (FOUND *01871000
-> PHEO) 01872000
TM OPF1,OP1SPECS 'SPECS' OPTION SPECIFIED? 01873000
CODE COPSP,O COPY INPUT BUFFER TO OUTPUT *01874000
BUFFER ACCORDING TO SPECS 01875000
TM OPF1,OP1TRUNC 'TRUNC' OPTION SPECIFIED? 01876000
CODE TRUNC,O TRUNCATE OUTPUT BUFFER IF SO 01877000
TM OPF3,OP3EBCD+OP3TRAN+OP3UPCA+OP3LOCA ANY TRANSLATION? 01878000
CODE TRANS,NZ TRANSLATE OUTPUT BUFFER IF SO 01879000
TM OPF2,OP2PACK 'PACK' OPTION SPECIFIED? 01882000
CODE PACK,O PACK THE DATA IF SO 01883000
TM OPF2,OP2UNPA 'UNPACK' OPTION SPECIFIED? 01884000
CODE UNPACK,O UNPACK THE DATA IF SO 01885000
TM OPF2,OP2PACK 'PACK' OPTION SPECIFIED? 01886000
CODE WROUT,Z WRITE WRPLIST IF NOT 01887000
CODE GOCO LOOP BACK TO PHASE CO 01888000
CO PHEND 01889000
EJECT 01890000
TM OPF2,OP2OVLY 'OVLY' OPTION SPECIFIED? @VA03971 01891000
BZ MCVE NO; THEN DON'T BOTHER WITH PHCV @VA03971 01892000
SPACE 1 01893000
* PHASE CV -- SPECIAL COPY PHASE FOR 'OVLY' OPTION 01894000
* (COPIES REMAINDER OF OVERLAY FILE, IN CASE A PREMATURE 01895000
* EOF OCCURRED ON THE LAST (OR ONLY) INPUT FILE.) 01896000
SPACE 1 01897000
CV PHBEG @VA03971 01898000
CODE IBUFF INIT. OUTPUT BUFFER IF NECESSARY @VA03971 01899000
CODE RDOVLY READ OVERLAY FILE INTO OUTPUT @VA03971*01900000
BUFFER (EOF -> PHCL) 01901000
TM OPF1,OP1SPECS INPUT BUFFER = OUTPUT BUFFER? @VA03971 01902000
BO CVNOSPEC NO; SKIP @VA03971 01903000
CODE SVE YES; SET VBUFEND @VA03971 01904000
B CVTRUNC @VA03971 01905000
CVNOSPEC CODE COPSP NO; COPY INPUT BUFFER TO OUTPUT @VA03971*01906000
BUFFER ACCORDING TO 'SPECS' OPT. 01907000
CVTRUNC TM OPF1,OP1TRUNC 'TRUNC' OPTION SPECIFIED? @VA03971 01908000
CODE TRUNC,O TRUNCATE OUTPUT BUFFER IF SO @VA03971 01909000
TM OPF3,OP3EBCD+OP3TRAN+OP3UPCA+OP3LOCA ANY TRANSL?@VA03971 01910000
CODE TRANS,NZ TRANSLATE OUTPUT BUFFER IF SO @VA03971 01911000
CODE WROUT WRITE WR P-LIST @VA03971 01912000
CODE GOCV LOOP BACK TO PHASE CV @VA03971 01913000
CV PHEND @VA03971 01914000
EJECT 01915000
* PHASE EO -- ENTERED WHEN EOF REACH ON INPUT FILE (OR 'FOR' 01916000
* SPECIFICATION IS FILLED). 01917000
EO PHBEG 01918000
CODE FINI FINIS INPUT FILE 01919000
TM OPF2,OP2PACK 'PACK' OPTION SPECIFIED? 01920000
CODE EOPACK,O FINISH UP WITH OUTPUT FILE, IFSO 01921000
TM OPF2,OP2MULT MULTIPLE FILE MODE? 01922000
BO MEOM GO IF YES 01923000
SPACE 01924000
* OTHERWISE, SINGLE FILE MODE 01925000
CODE NVPT POINT TO NEXT 'VERTICAL' INPUT *01926000
FILE 01927000
CODE FNFST FIND NEXT FST 01928000
CODE SKNFST SKIP IF NO FST FOUND 01929000
CODE GONI IF FOUND, ENTER NEXT INPUT PHASE 01930000
SPACE 01931000
* OTHERWISE, GET NEXT 'HORIZONTAL' INPUT FILE 01932000
MEOM EQU * 01933000
CODE NHPT GET NEXT 'HORIZONTAL' FILE @VA03971 01934000
CODE SKFND SKIP IF THERE IS ONE @VA03971 01935000
TM OPF2,OP2OVLY 'OVLY' OPTION SPECIFIED? @VA03971 01936000
BZ EONOVLY NO; SKIP @VA03971 01937000
CODE SETCV SET UP FOR AND ENTER PHASE CV @VA03971 01938000
B EOSUBE @VA03971 01939000
EONOVLY CODE GOCL ENTER CLOSING PHASE @VA03971 01940000
EOSUBE EQU * @VA03971 01941000
CODE SUBE SUBSTITUTE FOR = SIGNS 01942000
CODE FFFST FIND FIRST FST FOR FILE, IF ANY 01943000
TM OPF2,OP2MULT MULTIPLE OUTPUT? @VA05624 01944000
BO CDCKIC YES, CKIC MUST BE DONE @VA05624 01945000
CLI RECFM,C' ' RECFM SPECIFIED @VA05624 01946000
BE CDSKFST NO, CKIC ALREADY DONE @VA05624 01947000
CLC LRECL,=F'-1' LRECL SPECIFIED? @VA05624 01948000
BE CDSKFST NO, CKIC ALREADY DONE @VA05624 01949000
CDCKIC CODE CKIC CHECK FOR ILLEGAL CHAR IN FILEID @VA05624 01950000
CDSKFST CODE SKFST SKIP IF FST EXISTS @VA05624 01951000
CODE ERNIF ERROR -- NO INPUT FILE 01952000
CODE GONI IF FOUND, ENTER NEXT INPUT PHASE 01953000
EO PHEND 01954000
EJECT 01955000
* PHASE NI -- PROCESS NEXT INPUT FILE NAME 01956000
NI PHBEG 01957000
CODE MRWP MAKE RDBUF/WRBUF PLIST 01958000
CODE TACT ERROR IF FILE ALREADY ACTIVE 01959000
TM OPF1,OP1TYPE TYPE OPTION SPECIFIED? 01960000
CODE NITYPE,O TYPE NAME OF NEXT INPUT FILE 01961000
TM OPF2,OP2OVLY OVERLAY FILE SPECIFIED? 01962000
CODE OVBK,O BACKSPACE OVERLAY FILE IF SO 01963000
CODE GOPC ENTER PRE-COPY PHASE 01964000
NI PHEND 01965000
EJECT 01966000
* PHASE CL -- CLOSING PHASE 01967000
* THIS PHASE IS ENTERED WHEN: 01968000
* 1. EOF ON OVERLAY FILE 01969000
* 2. NO MORE 'HORIZONTAL' FILE NAMES. 01970000
CL PHBEG 01971000
CODE FINO FINIS OUTPUT FILE @VA03972 01972000
TM OPF2,OP2OVLY WAS 'OVLY' SPECIFIED? @VA03972 01973000
BZ CLTOL NO; SKIP @VA03972 01974000
CODE FINV FINIS OVERLAY FILE @VA03972 01975000
CODE FINI FINIS INPUT FILE @VA03972 01976000
CLTOL TM OPF1,OP1TOL WAS 'TOLABEL' SPECIFIED? @VA03972 01977000
CODE CKOR,O CHECK IF ANY RECORDS AT ALL @VA03972*01978000
WERE COPIED TO THE OUTPUT FILE 01979000
TM OPF1,OP1OLDD 'OLDDATE' SPECIFIED? 01980000
CODE SDATE,O GO CHANGE DATE IF SO 01981000
TM OPF2,OP2REPL+OP2OVLY REPLACE OR OVERLAY? 01982000
CODE ERASEO,NZ ERASE OLD OUTPUT FILE IF SO 01983000
TM OPF2,OP2NEWF+OP2REPL+OP2OVLY NEW OR REPLACE OR OVLY? 01984000
CODE RENAME,NZ RENAME TEMP FILE TO NEW NAME, *01985000
IF SO 01986000
TM OPF2,OP2MULT MULTIPLE FILE MODE? @VA05078 01987000
BO MCLM GO IF YES 01988000
CODE EXIT EXIT FROM DMSCPY IF SINGLE 01989000
B MCLE 01990000
MCLM EQU * 01991000
CODE GORE ENTER PHASE RE -- RESTART FOR *01992000
MULTIPLE FILE MODE 01993000
CL PHEND 01994000
* START COPYING PROCESS BY ENTERING INITIALIZATION PHASE 01995000
PHASE IN 01996000
LTORG 01997000
DS 0H 01998000
ORG DMSCPY+X'1000' 01999000
ORG 02000000
EJECT 02001000
SPACE 5 02002000
* COME HERE TO GO TO THE NEXT PHASE BYTE OPERATION. 02003000
NEXT EQU * 02004000
LA CDR,1(,CDR) POINT TO NEXT OPERATION BYTE 02005000
SPACE 02006000
* COME HERE WHEN CDR POINTS TO THE NEXT PHASE OPERATION BYTE 02007000
GO EQU * 02008000
SR R15,R15 02009000
IC R15,0(CDR) GET NEXT PHASE BYTE 02010000
CH R15,=AL2(ROUTMAX) LARGER THAN MAXIMUM? 02011000
BH ERUNX UNEXPECTED ERROR 02012000
AR R15,R15 MULTIPLY BY 4 02013000
AR R15,R15 02014000
L R15,ROUTAB(R15) LOAD BRANCH ADDRESS 02015000
BR R15 GO TO IT 02016000
EJECT 02017000
* THE FOLLOWING MACRO GENERATES THE ROUTINE BRANCH TABLE. IT GETS 02018000
* THE NAMES FROM THE 'CODE' MACROS, AND SO MUST BE PLACED AFTER ALL 02019000
* SUCH MACROS. 02020000
ROUTINES 02021000
EJECT 02022000
* THE FOLLOWING MACRO GENERATES THE ROUTINES WHICH ARE USED TO 02023000
* CHANGE TO A NEW PHASE. 02024000
GOGEN 02025000
EJECT 02026000
* SET UP POINTERS FOR FIRST INPUT FILE 02027000
$$FPT EQU * 02028000
LA XR,FIPLIST2 POINT TO PLIST2 FOR FIRST *02029000
INPUT FILE 02030000
USE PLIST2,XR 02031000
ST XR,PPLIST2 CURRENT PLIST2 02032000
LA XR2,RDPLIST USE RDPLIST AS CURRENT PLIST3 02033000
ST XR2,PPLIST3 SAVE POINTER TO IT 02034000
LA XR2,INFLAGS CURRENT FLAG BYTE 02035000
ST XR2,PFLG 02036000
L XR2,PLPTR FIRST PLIST1 IS 'COPY' PLIST 02037000
ST XR2,PPLIST1 STORE IT 02038000
SPACE 02039000
* WE CAN SIMPLY COPY THE INPUT FILE NA/TY/MO FROM PLIST1 TO PLIST2, 02040000
* SINCE NO = SIGNS ARE POSSIBLE IN THAT NAME. 02041000
USE PLIST1,XR2 02042000
MVC PNA2(18),PNA1 COPY FIELDS 02043000
NEXT GO FOR NEXT OPERATION 02044000
EJECT 02045000
* MAKE A COSMETIC CALL TO 'STATE' TO CHECK FOR ILLEGAL CHARS IN THE 02046000
* THE SPECIFIED FILEID, AND TO CHECK FOR ILLEGAL FILEMODE. 02047000
$$CKIC EQU * 02048000
L XR,PPLIST2 POINT TO CURRENT PLIST2 02049000
USE PLIST2,XR 02050000
MVC STPLIST+8(18),PNA2 COPY FILEID TO STATE PLIST 02051000
CLI STPLIST+8+16,C'*' IF AN ASTERICK IS SPECIFIED @VA00958 02052000
BNE MODEOK THE MODE NUMBER MUST @VA00958 02053000
MVI STPLIST+8+17,C' ' BE A BLANK @VA00958 02054000
MODEOK EQU * 02055000
LA R1,STPLIST POINT TO STATE PLIST 02056000
SVC 202 CALL 'STATE' 02057000
DC AL4(CKICER) TO CKICER ON ERROR 02058000
USE PLIST2,R1 @VA04333 02059000
L R15,PSTFST GET ADDRESS OF FST @VA04333 02060000
ST R15,PFSTAC AND SAVE FOR LATER USE @VA04333 02061000
SPACE 02062000
CKICN EQU * 02063000
NEXT 02064000
SPACE 02065000
* IF RC = 1 OR 28, THEN THE CONDITION IS 'FILE NOT FOUND', WHICH WE 02066000
* IGNORE (STATE DOES NOT TYPE A MESSAGE IN THIS CASE.) ON OTHER 02067000
* RETURN CODES, THEN AN ILLEGAL CHAR, ETC, WAS FOUND, AND STATE HAS 02068000
* TYPED OUT A DIAGNOSTIC MESSAGE. WE SIMPLY PASS THE RETURN CODE BACK 02069000
* TO THE USER. 02070000
* HOWEVER IF THE RETURN CODE FROM STATE IS 36 ( DISK NOT @VA09572 02070250
* ACCESSED) WE WILL PUT OUT THE APPROPRIATE MESSAGE AND EXIT. @VA09572 02070500
SPACE 02070750
CKICER EQU * 02071000
XC PFSTAC,PFSTAC CLEAR STATE FST ADDRESS @VA04333 02072000
CH R15,=H'36' WAS DISK NOT ACCESSED? @VA09572 02072350
BE ERROR36 GIVE MSG @VA09572 02072700
CH R15,=H'1' RC = 1? 02073000
BE CKINPUT CHECK FOR INPUT FILE @VA07488 02074100
CH R15,=H'28' RC = 28? 02075000
BE CKINPUT CHECK FOR INPUT FILE @VA07488 02076100
STC R15,RC STORE RETURN CODE 02077000
B EXIT AND TAKE ERROR EXIT 02078000
EJECT 02079000
CKINPUT EQU * @VA07488 02079100
LA R6,OUTFLAGS GET OUTFLAG ADDRESS @VA07488 02079200
USE PLIST2,XR2 @VA07488 02079300
CL R6,PFLG IS FLAG POINTER FOR INPUT @VA07488 02079400
BE CKICN NO-FILE IS OUTPUT IGNOR CC @VA07488 02079500
LA XR,INPUT SET UP FOR ERROR MSG @VA07488 02079600
B ERNF GO TO ERROR RTN. @VA07488 02079700
* GET FIRST FST FOR SPECIFIED FILE 02080000
$$FFFST EQU * 02081000
L XR2,PPLIST2 POINT TO CURRENT PLIST2 02082000
USE PLIST2,XR2 02083000
GETFST PLIST2,F,ERR=FFFSTER GET FIRST FST FOR PLIST2 FILE 02084000
LR XR,R0 SAVE ADT POINTER IN XR 02085000
USE ADTSECT,XR 02086000
MVC PHYP(8),ADTCHBA COPY TWO FIELDS FROM ADT FOR *02087000
LATER USE IN GETTING NEXT FST 02088000
L R15,ADTCFST GET NEW FST DISPLACEMENT@VA05129 02089000
ST R1,PFST SAVE FST POINTER 02090000
ST XR,PADT SAVE ADT POINTER 02091000
NEXT @VA05659 02092000
SPACE 02093000
* COME HERE IF THERE IS NO FST 02094000
FFFSTER EQU * 02095000
MVC PHYP(8),=D'0' ZERO OUT FST FIELD 02096000
XC PFST,PFST 02097000
NEXT GO FOR NEXT OPERATION 02098000
EJECT 02099000
* SKIP IF FST EXISTS 02100000
$$SKFST EQU * 02101000
L XR,PPLIST2 POINT TO CURRENT PLIST2 02102000
USE PLIST2,XR 02103000
CLC PFST,=F'0' ANY FST FOUND? 02104000
BE SKFSTN GO IF NOT 02105000
SKIP 1 SKIP 1 OPERATION IF SO 02106000
SPACE 2 02107000
* COME HERE IF AN FST DOES NOT EXIST 02108000
SKFSTN EQU * 02109000
NEXT GET NEXT OPERATION (NO SKIP) 02110000
EJECT 02111000
* SKIP IF NO FST EXISTS 02112000
$$SKNFST EQU * 02113000
L XR,PPLIST2 POINT TO PLIST2 02114000
USE PLIST2,XR 02115000
CLC PFST,=F'0' ANY FST FOUND? 02116000
BNE SKNFSTS GO IF SO 02117000
SKIP 1 SKIP IF NOT 02118000
SPACE 2 02119000
* COME HERE IF AN FST EXISTS 02120000
SKNFSTS EQU * 02121000
NEXT NO SKIP IF FST EXISTS 02122000
EJECT 02123000
* HANDLE ERRORS ASSOCIATED WITH NO INPUT FILE EXISTING. 02124000
SPACE 02125000
* NO INPUT FILE EXISTS 02126000
$$ERNIF EQU * 02127000
LA XR,=CL8'INPUT' 02128000
B ERNF GO TYPE ERROR MESSAGE 02129000
SPACE 02130000
* NO OVERLAY FILE NAME 02131000
$$ERNVF EQU * 02132000
LA XR,=CL8'OVERLAY' 02133000
B ERNF 02134000
EJECT 02135000
* ADDITIONAL FIRST FILE PROCESSING 02136000
$$FPT2 EQU * 02137000
SPACE 02138000
* MAKE FIRST FILE THE CURRENT INPUT FILE 02139000
MVC CIPLIST2(8*PLEN2),FIPLIST2 02140000
SPACE 02141000
* WE SAVE THE FIRST FILE NAME IN A SPECIAL PLACE SO THAT IT CAN 02142000
* BE EASILY RETRIEVED LATER. IT IS USED IN THE SUBSTITUTION 02143000
* FOR =. 02144000
MVC FNA(18),RDFNAME 02145000
NEXT GO FOR NEXT OPERATION 02146000
EJECT 02147000
* TYPE MESSAGES ASSOCIATED WITH 'TYPE' OPTION 02148000
SPACE 02149000
* TYPE MESSAGE 'COPY FNAME TO/OVLY/APPEND FNAME (NEW/OLD FILE)' 02150000
$$IOTYPE EQU * 02151000
TM OPF2,OP2REPL+OP2NEWF REPLACE OR NEW FILE? 02152000
BZ *+8 SKIP IF NOT 02153000
LA XR2,=CL8'TO' TYPE 'TO' 02154000
TM OPF2,OP2OVLY OVERLAY OPTION? 02155000
BZ *+8 SKIP IF NOT 02156000
LA XR2,=CL8'OVERLAY' TYPE 'OVERLAY' 02157000
TM OPF2,OP2APPE APPEND OPTION? 02158000
BZ *+8 SKIP IF NOT 02159000
LA XR2,=CL8'APPEND' TYPE 'APPEND' 02160000
SPACE 02161000
LA R14,=C'OLD' TYPE '(OLD FILE)' 02162000
CLC PFST-PLIST2+OUPLIST2,=F'0' BUT DID THE FST EXIST? 02163000
BNE *+8 SKIP IF IT DID 02164000
LA R14,=C'NEW' OTHERWISE, IT'S '(NEW FILE)' 02165000
B FNTYPEIO GO TO TYPE MESSAGE 02166000
SPACE 3 02167000
* TYPE MESSAGE 'COPY FNAME' 02168000
$$NITYPE EQU * 02169000
B FNTYPENI GO TYPE MESSAGE 02170000
EJECT 02171000
* CREATE RDBUF/WRBUF PLIST -- FILL IN INFO FROM FST AND ADT 02172000
$$MRWP EQU * 02173000
L R1,PPLIST2 POINT TO PLIST2 02174000
USE PLIST2,R1 02175000
L XR,PPLIST3 POINT TO PLIST3 02176000
USE PLIST3,XR 02177000
XC PITEM3,PITEM3 ZERO OUT ITEM NO FIELD 02178000
L XR2,PFST POINT TO FST 02179000
LTR XR2,XR2 IS THERE ANY? 02180000
BZ MRWPNF NOTHING TO DO IF NOT 02181000
USE FSTSECT,XR2 02182000
MVC PNA3(16),FSTN COPY FILE NAME/TYPE FROM FST 02183000
MVC PMO3,FSTM COPY FILE MODE NUMBER 02184000
L XR3,PADT POINT TO ACTIVE DISK TABLE 02185000
USE ADTSECT,XR3 02186000
MVC PMO3(1),ADTM COPY MODE LETTER 02187000
MVC PFV3,FSTFV COPY RECFM 02188000
MVC PBUFFS3,FSTIL COPY LRECL 02189000
NEXT GO FOR NEXT OPERATION 02190000
SPACE 2 02191000
* COME HERE IF THERE IS NO FST POINTER 02192000
* IN THIS CASE, COPY INFO FROM PLIST2 02193000
MRWPNF EQU * 02194000
CLI PMO2+1,C' ' ANY FILEMODE DIGIT SPECIFIED? 02195000
BNE *+8 SKIP IF SO 02196000
MVI PMO2+1,C'1' OTHERWISE, DEFAULT TO 1 02197000
MVC PNA3(18),PNA2 COPY FILE NA/TY/MO FROM PLIST2 02198000
NEXT GO FOR NEXT OPERATION 02199000
EJECT 02200000
* TEST TO SEE WHETHER FILE IS ALREADY ACTIVE. ERROR OUT IF SO. 02201000
$$TACT EQU * 02202000
L XR,PFSTAC GET STATE FST ADDRESS @VA04333 02203000
USE FSTSECT,XR 02204000
LTR XR,XR ANY FST POINTER? 02205000
BZ TACT1 NO -> FILE CAN'T BE ACTIVE 02206000
TM FSTFB,FSTFAW IS FILE ACTIVE FOR OUTPUT? @VA04333 02207000
BNZ ERACT ERROR IF SO 02208000
SPACE 02209000
TACT1 EQU * 02210000
NEXT GO FOR NEXT OPERATION 02211000
EJECT 02212000
EJECT 02224000
* GET NEXT FST FOR FILE 02225000
$$FNFST EQU * 02226000
L XR2,PPLIST2 POINT TO PLIST2 02227000
USE PLIST2,XR2 02228000
SPACE 02229000
* IF THERE WERE NO ASTERISKS SPECIFIED IN THE FILEID AS TYPED IN, 02230000
* THEN WE DO NOT LOOK FOR THE NEXT FST. 02231000
L R1,PFLG POINT TO FLAG BYTE FOR FILEID 02232000
TM 0(R1),FS ANY ASTERISKS SPECIFIED? 02233000
BZ FNFSTER NO NEXT FST IF NOT 02234000
L XR,PADT GET PTR TO OLD ADT 02235000
USE ADTSECT,XR 02236000
SPACE 02237000
* RESET ADT POINTERS TO WHAT THEY WERE WHEN LAST FST WAS OBTAINED. 02238000
DMSEXS MVC,ADTCHBA(8),PHYP EXECUTE IN SYSTEM STATUS 02239000
GETFST PLIST2,N,ERR=FNFSTER,ADT=(XR) GET NEXT FST 02240000
LR XR,R0 SET NEW ADT POINTER 02241000
MVC PHYP(8),ADTCHBA SAVE NEW FST INFO 02242000
L R15,ADTCFST GET NEW FST DISPLACEMENT@VA05129 02243000
ST R1,PFST SAVE NEW FST POINTER 02244000
ST XR,PADT STORE NEW ADT POINTER 02245000
NEXT @VA05659 02246000
SPACE 2 02247000
* COME HERE IF NO NEXT FST 02248000
FNFSTER EQU * 02249000
MVC PHYP(8),=D'0' INDICATE NO FST 02250000
XC PFST,PFST 02251000
NEXT GO FOR NEXT OPERATION 02252000
EJECT 02253000
* POINT TO NEXT OUTPUT FILE 02254000
$$OPT EQU * 02255000
LA XR,OUPLIST2 POINT TO NEW PLIST2 02256000
USE PLIST2,XR 02257000
ST XR,PPLIST2 MAKE IT CURRENT PLIST2 02258000
LA XR2,WRPLIST POINT TO NEW PLIST3 02259000
ST XR2,PPLIST3 STORE POINTER TO IT 02260000
LA XR2,OUTFLAGS POINT TO OUTPUT FLAG BYTE 02261000
ST XR2,PFLG STORE FLAG BYTE POINTER 02262000
MVC PPLIST1,POUPL1 GET OUTPUT FILE NAME PLIST1 02263000
NEXT 02264000
EJECT 02265000
* COPY FILE NAME FROM PLIST1 TO PLIST2, SUBSTITUTING FOR = SIGNS 02266000
$$SUBE EQU * 02267000
L XR2,PPLIST2 POINT TO PLIST2 02268000
USE PLIST2,XR2 02269000
L XR,PPLIST1 POINT TO PLIST1 02270000
USE PLIST1,XR 02271000
MVC PNA2(18),PNA1 COPY FILE NAME/TYPE/MODE 02272000
L XR3,PFLG POINT TO FLAG BYTE FOR FILE 02273000
TM 0(XR3),FE ANY = SIGNS IN THIS FILE NAME? 02274000
BNZ SUBEN GO IF THERE ARE ANY 02275000
NEXT FINISHED IF NOT 02276000
SPACE 02277000
* COME HERE IF THERE ARE ANY EQUAL SIGNS. 02278000
* SUBSTITUTE IN FILE NAME, IF ANY. 02279000
SUBEN EQU * 02280000
TM 0(XR3),FENA = SIGN IN FILE NAME? 02281000
BZ SUBET GO IF NOT 02282000
MVC STEMP(8),PNA1 COPY NAME TO TEMP 02283000
LA R1,FNA SUBSTITUTION FIELD FOR = 02284000
BAL RR,SUBES MAKE SUBSTITUTION 02285000
MVC PNA2,STRING COPY SUBSTITUTED FIELD 02286000
SPACE 02287000
* SUBSTITUTE FOR FILE TYPE 02288000
SUBET EQU * 02289000
TM 0(XR3),FETY = SIGN IN FILE TYPE 02290000
BZ SUBEM GO IF NOT 02291000
MVC STEMP(8),PTY1 COPY TYPE TO TEMP 02292000
LA R1,FTY SUBSTITUTION FIELD 02293000
BAL RR,SUBES MAKE SUBSTITUTION 02294000
MVC PTY2,STRING COPY SUBSTITUTED FIELD 02295000
SPACE 02296000
* SUBSTITUTE FOR FILE MODE 02297000
SUBEM EQU * 02298000
TM 0(XR3),FEMO = SIGN IN FILE MODE? 02299000
BZ SUBEX 02300000
MVC STEMP(2),PMO1 COPY FILE MODE TO TEMP 02301000
LA R1,FMO POINT TO SUBSTITUTION FIELD 02302000
BAL RR,SUBES 02303000
MVC PMO2,STRING 02304000
SPACE 02305000
SUBEX EQU * 02306000
NEXT 02307000
EJECT 02308000
* SUBSTITUTION SUBROUTINE USED BY $$SUBE ROUTINE. 02309000
* STEMP CONTAINS THE STRING WHICH IS TO BE SCANNED, AND R1 POINTS TO 02310000
* THE FIELD TO BE SUBSTITUTED FOR = SIGNS. 02311000
* THE NEW STRING WILL BE CREATED IN 'STRING' FIELD. 02312000
SUBES EQU * 02313000
MVC STRING(9),BLANKS INITIALIZE OUTPUT FIELD 02314000
MVI STEMP+8,C' ' TO GUARANTEE BLANK TERMINATOR 02315000
LA R14,STRING-1 'TO' POINTER 02316000
LA R15,STEMP-1 'FROM' POINTER 02317000
SPACE 02318000
* COME HERE AFTER EACH SUBSTITUTION HAS BEEN MADE. 02319000
SUBES1 EQU * 02320000
LA R14,1(,R14) POINT TO NEXT TARGET CHAR 02321000
LA R15,1(,R15) POINT TO NEXT 'FROM' CHAR 02322000
MVC 0(1,R14),0(R15) COPY CHARACTER 02323000
CLI 0(R15),C' ' WAS IT A BLANK? 02324000
BE 0(,RR) LEAVE SUBROUTINE IF SO 02325000
CLI 0(R15),C'=' WAS IT AN = SIGN? 02326000
BNE SUBES1 LOOP BACK IF NOT 02327000
MVC 0(8,R14),0(R1) COPY SUBSTITUTION FIELD 02328000
MVI 8(R14),C' ' ENSURE TERMINATING BLANK 02329000
LA R14,1(,R14) FIND TERMINATING BLANK 02330000
CLI 0(R14),C' ' 02331000
BNE *-8 02332000
BCT R14,SUBES1 DECREMENT AND REENTER SCAN LOOP 02333000
EJECT 02334000
* FIND FST FOR OUTPUT FILE 02335000
$$FWFST EQU * 02336000
LA XR2,OUPLIST2 POINT TO PLIST2 FOR OUTPUT FILE 02337000
USE PLIST2,XR2 02338000
GETFST PLIST2,F,ERR=FWFSTER,MODE=W GET FST FOR OUTPUT FILE 02339000
LR XR,R0 SAVE ADT POINTER IN XR 02340000
USE ADTSECT,XR 02341000
MVC PHYP(8),ADTCHBA COPY TWO FIELDS FROM ADT 02342000
ST R1,PFST SAVE FST POINTER 02343000
ST XR,PADT SAVE ADT POINTER 02344000
USE FSTSECT,R1 02345000
CLI PMO2+1,C' ' WAS MODE NUMBER OF OUTPUT FILE *02346000
SPECIFIED? 02347000
BNE *+10 SKIP IF IT WAS 02348000
MVC PMO2+1(1),FSTM+1 USE MODE NUMBER IN FST FOR *02349000
EXISTING FILE 02350000
NEXT 02351000
SPACE 02352000
* COME HERE IF THERE IS NO FST 02353000
FWFSTER EQU * 02354000
MVC PHYP(8),=D'0' ZERO OUT FST FIELD 02355000
XC PFST,PFST 02356000
NEXT 02357000
EJECT 02358000
* SET CORRECT MODE NUMBER FOR OUTPUT FILEID. 02359000
$$SOMODE EQU * 02360000
LA XR2,OUPLIST2 POINT TO PLIST2 FOR OUTPUT FILE 02361000
USE PLIST2,XR2 02362000
CLI PMO2+1,C' ' IS MODE NUMBER A BLANK? 02363000
BNE *+10 SKIP IF NOT 02364000
MVC PMO2+1(1),RDFMODE+1 FORCE MODE NUMBER TO THAT OF *02365000
FIRST INPUT FILE 02366000
CLI PMO2+1,C'Y' IS MODE 'NUMBER' A Y? 02367000
BNE *+8 SKIP IF NOT 02368000
MVI PMO2+1,C'2' FORCE MODE NUMBER TO 2 02369000
NEXT 02370000
EJECT 02371000
* TEST IF DISK IS READ/WRITE. 02372000
$$TRW EQU * 02373000
L XR,PPLIST2 POINT TO PLIST2 02374000
USE PLIST2,XR 02375000
L XR,PPLIST3 POINT TO PLIST3 02376000
USE PLIST3,XR 02377000
GETADT PLIST3,ERR=ERDISK,MODE=W GET POINTER TO DISK 02378000
USE ADTSECT,R1 02379000
TM ADTFLG1,ADTFRW DISK READ/WRITE? 02380000
BZ ERDISK ERROR IF NOT 02381000
NEXT 02382000
EJECT 02383000
* COPY RECFM SPECIFIED IN OPTION LIST 02384000
$$CFMS EQU * 02385000
L XR,PPLIST2 POINT TO PLIST2 02386000
USE PLIST2,XR 02387000
L XR,PPLIST3 POINT TO PLIST3 02388000
USE PLIST3,XR 02389000
MVC PFV3(1),RECFM COPY RECFM 02390000
SPACE 3 02391000
EJECT 02392000
* COPY LRECL SPECIFIED IN OPTION LIST 02393000
$$CRLS EQU * 02394000
L XR,PPLIST2 POINT TO PLIST2 02395000
USE PLIST2,XR 02396000
L XR,PPLIST3 POINT TO PLIST3 02397000
USE PLIST3,XR 02398000
MVC PBUFFS3,LRECL COPY LRECL 02399000
NEXT 02400000
EJECT 02401000
* COPY LRECL TO SPECIFIED FROM CURRENT INPUT FILE 02402000
$$CFMA EQU * @VA05624 02403000
CLI RECFM,C'V' OUPTUT RECFM ALREAD 'V'? @VA05624 02404000
BE CFMAN YES, DON'T UPDATE @VA05624 02405000
L XR2,PPLIST2 ADDR OF CURR PLIST @VA05624 02406000
USE PLIST2,XR2 @VA05624 02407000
L XR3,PFST ADDRESS OF FST @VA05624 02408000
USE FSTSECT,XR3 @VA05624 02409000
MVC RECFM(1),FSTFV SUPPLY FROM INPUT REGARDLESS @VA05624 02410000
CFMAN NEXT @VA05624 02411000
SPACE 3 02412000
* COPY LARGEST LRECL TO SPECIFIED LIST 02413000
$$CRLA EQU * @VA05624 02414000
L XR2,PPLIST2 ADDR OF CURR PLIST2 @VA05624 02415000
USE PLIST2,XR2 @VA05624 02416000
L XR3,PFST ADDRESS OF FST @VA05624 02417000
USE FSTSECT,XR3 @VA05624 02418000
L XR3,FSTIL GET LRECL @VA05624 02419000
C XR3,LRECL LARGER THAN CURRENT @VA05624 02420000
BNH CRLAN NO, DON'T UPDATE @VA05624 02421000
ST XR3,LRECL YES, MAKE IT THE LARGER @VA05624 02422000
CRLAN NEXT @VA05624 02423000
EJECT 02424000
$$ERNX EQU * 02425000
B ERNX 02426000
EJECT 02427000
* USE CMSUT FILEID AS FILE NAME IN OUTPUT PLIST. 02428000
$$WTEMP EQU * 02429000
MVC WRFNAME(16),=CL16'COPYFILECMSUT1' @VM08876 02430000
SPACE 2 02431000
* NOTE THAT FILE MODE IS ALREADY IN WRPLIST. HOWEVER, WE FORCE THE 02432000
* MODE NUMBER TO 1 FOR THE CMSUT FILE. 02433000
MVI WRFMODE+1,C'1' 02434000
SPACE 02435000
* NOW WE ERASE THIS FILE IN CASE IT ALREADY EXISTS. 02436000
MVC ERPLIST+8(18),WRFNAME COPY NAME INTO ERASE PLIST 02437000
LA R1,ERPLIST 02438000
SVC 202 02439000
DC AL4(*+4) 02440000
NEXT 02441000
EJECT 02442000
* COPY INPUT FILE RECFM IN CASE IT WAS NOT SPECIFIED IN OPTION LIST. 02443000
$$CFMI EQU * 02444000
MVC WRFV(1),RDFV COPY RECFM 02445000
NEXT 02446000
SPACE 5 02447000
* COPY INPUT FILE LRECL IN CASE IT WAS NOT SPECIFIED IN OPTION LIST. 02448000
$$CRLI EQU * 02449000
MVC WRBUFFS,RDBUFFS 02450000
NEXT 02451000
EJECT 02452000
* SET UP POINTERS TO OVERLAY FILE 02453000
$$VPT EQU * 02454000
L XR,PPLIST2 POINT TO PLIST2 02455000
USE PLIST2,XR 02456000
LA R1,OVPLIST POINT TO OVERLAY PLIST 02457000
ST R1,PPLIST3 USE IT AS PLIST3 02458000
NEXT 02459000
EJECT 02460000
* SET ITEM NUMBER IN OUTPUT PLIST FOR 'APPEND' OPTION BY COPYING 02461000
* ITEM COUNT FROM THE FST FOR THE FILE. 02462000
$$APITEM EQU * 02463000
L XR,OUPLIST2+PFST-PLIST2 POINT TO FST FOR OUTPUT FILE 02464000
USE FSTSECT,XR 02465000
MVC WRITEM,FSTIC COPY OVER ITEM NUMBER 02466000
NEXT 02467000
EJECT 02468000
* WE SAVE THE ITEM NUMBER OF THE FIRST RECORD WHICH IS GOING TO GO 02469000
* INTO THE OUTPUT FILE. THIS WILL ALLOW US TO CHECK LATER TO SEE IF 02470000
* ANY RECORDS WERE COPIED INTO THE OUTPUT FILE. 02471000
$$SFIT EQU * 02472000
MVC OFREC,WRITEM COPY ITEM NUMBER 02473000
NEXT 02474000
EJECT 02475000
* PRELIMINARY BUFFER SIZE MANIPULATION FOR 'PACK' BUFFER OPERATION. 02476000
$$PCPACK EQU * 02477000
MVC WRBUFFS,=F'800' OUTPUT BUFFER SIZE IS 800 02478000
MVI WRFV,C'F' OUTPUT RECFM IS F 02479000
SPACE 02480000
* SET UP THE PACK FILE BUFFER HEADER 02481000
MVC PACKVER,=H'1' VERSION 1 OF 'PACK' FORMAT 02482000
MVC PACKCHAR,FILLC MOST IMPORTANT CHAR IS FILL CHAR 02483000
MVC PACKRECF,RDFV COPY RECFM OF INPUT FILE 02484000
MVC PACKLREC,RDBUFFS COPY LRECL OF INPUT FILE 02485000
NEXT 02486000
EJECT 02487000
* PRELIMINARY BUFFER SIZE MANIPULATION FOR THE 'UNPACK' OPERATION. 02488000
* WE DON'T KNOW THE SIZE OF THE OUTPUT FILE UNTIL WE READ IN 02489000
* THE PACK FILE BUFFER HEADER FROM THE PACKED FILE. WE DO THIS NOW BY 02490000
* READING THE FIRST FEW BYTES OF THE FIRST BLOCK OF THE FILE INTO 02491000
* THE BUFFER HEADER AREA IN THE WORK AREA. 02492000
$$PCUNPA EQU * 02493000
CLC RDBUFFS,=F'800' INPUT LRECL = 800? 02494000
BNE ERILP NOT PACKED FORMAT IF NOT 02495000
CLI RDFV,C'F' INPUT RECFM = F? 02496000
BNE ERILP NOT PACKED IF NOT 02497000
SPACE 02498000
* READ PACKED FILE BUFFER HEADER INTO WORK AREA 02499000
* WE READ A WHOLE 800 BYTE RECORD INTO A GETMAINED AREA. WE GETMAIN 02500000
* 880 BYTES SO THAT IF THE OUTPUT FILE HAS RECFM 80, WE WON'T HAVE 02501000
* DO A GETMAIN/FREEMAIN LATER. 02502000
CLC BUFLEN,=F'0' HAS A BUFFER BEEN ALLOCATED? 02503000
BP PCUNPA1 THEN IT'S ALREADY 880 BYTES LONG 02504000
GETMAIN R,LV=880 ALLOCATE BUFFER 02505000
MVC BUFLEN,=F'880' SET BUFFER LENGTH 02506000
ST R1,BUFAD STORE BUFFER ADDRESS 02507000
SPACE 02508000
PCUNPA1 EQU * 02509000
MVC RDBUFFA,BUFAD COPY BUFFER ADDRESS INTO PLIST 02510000
LA R1,RDPLIST POINT TO INPUT PLIST 02511000
SVC 202 READ FILE BUFFER HEADER 02512000
DC AL4(*+4) ERROR RETURN @VA04664 02513000
SPACE 02514000
CKRW RD CHECK FOR READ ERROR 02515000
L R1,BUFAD OUTPUT BUFFER ADDRESS 02516000
MVC PACKFHB(PACKBL),0(R1) COPY PACKED FILE BUFFER HEADER 02517000
CLC PACKVER,=H'1' IS THIS VERSION 1 PACKED FORMAT 02518000
BNE ERILP NOT PACKED FORMAT IF NOT 02519000
CLI PACKRECF,C'F' SEE IF HEADER IS FOR F FILE @VA13261 02519150
BE RECFMOK RECFM IS VALID, CONTINUE UNPACK @VA13261 02519300
CLI PACKRECF,C'V' SEE IF HEADER IS FOR V FILE @VA13261 02519450
BNE ERILP NOT PACKED FORMAT IF NOT F OR V @VA13261 02519600
RECFMOK EQU * @VA13261 02519750
MVC WRFV,PACKRECF GET RECFM OF OUTPUT FILE 02520000
MVC WRBUFFS,PACKLREC GET LRECL OF OUTPUT FILE 02521000
NEXT 02522000
EJECT 02523000
* SET UP I/O BUFFERS AND INITIALIZE OUTPUT BUFFER TO FILL CHARACTER. 02524000
$$PCSET EQU * 02525000
TM OPF1,OP1SPECS 'SPECS' OPTION SPECIFIED? 02526000
BO PCSETS GO IF YES 02527000
TM OPF2,OP2PACK+OP2UNPA 'PACK' OR 'UNPACK' SPECIFIED? 02528000
BNZ PCSETT GO HANDLE IT IF YES 02529000
SPACE 02530000
* OTHERWISE, ONLY ONE BUFFER IS NEED FOR BOTH INPUT AND OUTPUT. 02531000
* THE SIZE OF THIS BUFFER IS MAX SIZE OF INPUT, OUTPUT AND OVERLAY 02532000
* BUFFER SIZES, AND 256. 02533000
L R0,RDBUFFS GET SIZE OF INPUT BUFFER 02534000
C R0,WRBUFFS COMPARE TO OUTPUT BUFFER SIZE 02535000
BH *+8 SKIP IF LOWER 02536000
L R0,WRBUFFS USE OUTPUT BUFFER SIZE 02537000
C R0,OVBUFFS COMPARE TO OVERLAY BUFFER SIZE 02538000
BH *+8 SKIP IF HIGHER 02539000
L R0,OVBUFFS USE OVERLAY BUFFER SIZE 02540000
CH R0,=H'256' 256 MINIMUM 02541000
BH *+8 SKIP IF GREATER 02542000
LA R0,256 USE 256 02543000
ST R0,BUFNEED BUFFER SIZE NEEDED 02544000
ST R0,OBUFLEN SAVE OUTPUT BUFFER LENGTH 02545000
XC OBUFAD,OBUFAD NO OUTPUT BUFFER DISPLACEMENT 02546000
B PCSETC GO ALLOCATE BUFFER 02547000
SPACE 3 02548000
* COME HERE IF 'SPECS' OPTION WAS SPECIFIED. IN THIS CASE 02549000
* THERE ARE SEPARATE INPUT AND OUTPUT BUFFERS, AND THE OUTPUT BUFFER 02550000
* LIES AT THE END OF THE INPUT BUFFER. 02551000
SPACE 02552000
* THE SIZE OF THE OUTPUT BUFFER IS THE MAXIMUM OF: 02553000
* 1. THE OUTPUT LRECL 02554000
* 2. OVERLAY LRECL 02555000
* 3. MAX(OUTPUT BUFFER DISPLACEMENT SPEC)+MAX(INPUT LRECL,130) 02556000
* 4. 256 02557000
PCSETS EQU * 02558000
L R0,RDBUFFS GET INPUT LRECL 02559000
CH R0,=H'130' GREATER THAN 130? 02560000
BH *+8 SKIP IF IT IS 02561000
LA R0,130 OTHERWISE, USE 130 02562000
A R0,SPECMAX ADD MAX OUTPUT BUFFER DISPLACE- *02563000
MENT SPEC 02564000
C R0,OVBUFFS COMPARE TO OVERLAY LRECL 02565000
BH *+8 SKIP IF ALREADY GREATER 02566000
L R0,OVBUFFS USE IT 02567000
C R0,WRBUFFS COMPARE WITH OUTPUT LRECL 02568000
BH *+8 SKIP IF ALREADY GREATER 02569000
L R0,WRBUFFS OTHERWISE USE IT 02570000
CH R0,=H'256' GREATER THAN 256 02571000
BH *+8 SKIP IF IT IS 02572000
LA R0,256 OTHERWISE USE 256 02573000
ST R0,OBUFLEN SAVE OUTPUT BUFFER LENGTH 02574000
SPACE 02575000
* AND NOW, THE TOTAL BUFFER SIZE NEED IS THE MAXIMUM OF: 02576000
* 1. C(R0) + INPUT LRECL 02577000
* 2. 512 02578000
A R0,RDBUFFS ADD INPUT LRECL 02579000
CH R0,=H'512' COMPARE WITH 512 02580000
BH *+8 SKIP IF GREATER 02581000
LA R0,512 02582000
ST R0,BUFNEED SAVE BUFFER SIZE NEEDED 02583000
MVC OBUFAD,RDBUFFS SAVE OUTPUT BUFFER DISPLACEMENT 02584000
B PCSETC GO ALLOCATE BUFFER 02585000
SPACE 2 02586000
* COME HERE IF 'PACK' OR 'UNPACK' OPTION IS SPECIFIED. IN THIS CASE, 02587000
* THE SIZE OF THE NEEDED BUFFER IS THE SUM OF THE SIZES OF THE 02588000
* INPUT AND OUTPUT BUFFERS. 02589000
PCSETT EQU * 02590000
L R0,RDBUFFS GET SIZE OF INPUT BUFFER 02591000
L R1,WRBUFFS GET SIZE OF OUTPUT BUFFER 02592000
ST R0,OBUFAD STORE DISPLACEMENT OF OUTPUT BUF 02593000
ST R1,OBUFLEN STORE LENGTH OF OUTPUT BUFFER 02594000
AR R0,R1 COMPUTE SUM 02595000
ST R0,BUFNEED BUFFER SIZE NEEDED 02596000
B PCSETC GO ALLOCATE BUFFER 02597000
SPACE 3 02598000
* COME HERE WHEN THE NEEDED BUFFER SIZE HAS BEEN DETERMINED, AND PLACED 02599000
* IN LOCATION 'BUFNEED'. IN ADDTION, THE DISPLACEMENT OF THE OUTPUT 02600000
* BUFFER IS LOCATION 'OBUFAD' -- IT WILL EQUAL EITHER 0 (TO INDICATE 02601000
* THATE THE INPUT AND OUTPUT BUFFERS ARE THE SAME) OR INPUT LRECL 02602000
* (TO INDICATE THAT THE OUTPUT BUFFER LIES AT THE END OF THE INPUT 02603000
* BUFFER). 02604000
SPACE 02605000
* THE PROCEDURE IS TO CHECK TO SEE WHETHER WE HAVE ALREADY ALLOCATED 02606000
* A LARGE ENOUGH BUFFER. IF WE HAVE THEN WE SIMPLY USE IT. OTHERWISE, 02607000
* WE FREEMAIN THE OLD BUFFER AND GETMAIN A NEW BUFFER. 02608000
PCSETC EQU * 02609000
L R0,BUFLEN GET SIZE OF EXISTING BUFFER 02610000
C R0,BUFNEED IS IT GREATER THAN WE NEED? 02611000
BNL PCSETO IT'S BIG ENOUGH 02612000
L R1,BUFAD GET OLD BUFFER ADDRESS 02613000
LTR R1,R1 IS THERE AN OLD BUFFER? 02614000
BZ PCSETG NO FREEMAIN IF NOT 02615000
FREEMAIN R,LV=(0),A=(1) FREEMAIN THE OLD BUFFER 02616000
SPACE 02617000
PCSETG EQU * 02618000
L R0,BUFNEED GET SIZE OF NEEDED BUFFER 02619000
ST R0,BUFLEN SAVE AS NEW BUFFER LENGTH 02620000
GETMAIN R,LV=(0) ALLOCATE THE BUFFER 02621000
LA R1,0(,R1) CLEAR ANY HIGH BYTE 02622000
ST R1,BUFAD STORE BUFFER ADDRESS 02623000
SPACE 02624000
PCSETO EQU * 02625000
L R1,BUFAD 02626000
A R1,OBUFAD ADD OUTPUT BUFFER DISPLACEMENT 02627000
ST R1,OBUFAD AND SAVE OUTPUT BUFFER ADDRESS 02628000
LM R14,R15,OBUFAD GET BUFFER ADDRESS/LENGTH 02629000
SR R0,R0 02630000
L R1,FILLC LOAD FILL CHARACTER AND 0 LEN 02631000
MVCL R14,R0 INITIALIZE BUFFER TO FILL CHAR 02632000
EJECT 02633000
* WE NOW DETERMINE WHETHER IT WILL BE NECESSARY TO INITIALIZE THE 02634000
* BUFFER TO THE FILL CHARACTER AFTER EACH WRBUF OPERATION. THIS 02635000
* IS DETERMINED ACCORDING TO THE FOLLOWING TABLE: 02636000
SPACE 02637000
* INPUT OVLY OUTPUT 'SPECS' INIT EACH 02638000
* RECFM RECFM RECFM SPECIFIED? TIME? 02639000
* ----- ----- ------ ---------- --------- 02640000
* F FN F Y N 02641000
* F FN F N N 02642000
* F FN V Y N 02643000
* F FN V N N 02644000
* F V F Y Y 02645000
* F V F N Y 02646000
* F V V Y Y 02647000
* F V V N N 02648000
* V FN F Y Y 02649000
* V FN F N Y 02650000
* V FN V Y Y 02651000
* V FN V N N 02652000
* V V F Y Y 02653000
* V V F N Y 02654000
* V V V Y Y 02655000
* V V V N N 02656000
SPACE 02657000
* WHERE: 02658000
* F = FIXED RECFM 02659000
* V = VARIABLE RECFM 02660000
* FN = FIXED RECFM OR NONE (IF NO OVERLAY FILE) 02661000
* Y = YES 02662000
* N = NO 02663000
SPACE 02664000
SR R1,R1 02665000
CLI RDFV,C'V' INPUT RECFM = V? 02666000
BNE *+8 SKIP IF NOT 02667000
LA R1,B'00001000' ADD 1 IN FIRST COL IF SO 02668000
CLI OVFV,C'V' OVERLAY FILE RECFM = V? 02669000
BNE *+8 SKIP IF NOT 02670000
LA R1,B'00000100'(,R1) ADD 1 IN SECOND COL IF SO 02671000
CLI WRFV,C'V' OUTPUT RECFM = V? 02672000
BNE *+8 SKIP IF NOT 02673000
LA R1,B'00000010'(,R1) ADD 1 IN THIRD COL IF SO 02674000
TM OPF1,OP1SPECS 'SPECS' OPTION SPECIFIED? 02675000
BO *+8 SKIP IF SO 02676000
LA R1,B'00000001'(,R1) ADD 1 IN FOURTH COL IF NOT 02677000
L R0,=BL.32'0000111011101110' LOAD FUNCTION BITS (5TH COL) 02678000
SLL R0,16(R1) SHIFT FCN BIT INTO SIGN POSITION 02679000
MVI BINBYTE,0 SAY 'NO INITIALIZATION' 02680000
LTR R0,R0 BUT IS FCN BIT A 1? 02681000
BZ *+8 SKIP IF IT ISN'T @VA09465 02682000
MVI BINBYTE,X'FF' THEN MUST INITIALIZE 02683000
TM OPF2,OP2PACK+OP2UNPA PACK OR UNPACK SPECIFIED? 02684000
BZ *+8 SKIP IF NOT 02685000
MVI BINBYTE,0 IF SO, DON'T INITIALIZE 02686000
SPACE 02687000
* INITIALIZE THE BUFFER ADDRESSES IN THE THREE RDBUF/WRBUF PLISTS. 02688000
MVC RDBUFFA,BUFAD INPUT FILE PLIST 02689000
MVC WRBUFFA,OBUFAD OUTPUT FILE PLIST 02690000
MVC OVBUFFA,OBUFAD OVERLAY FILE PLIST 02691000
NEXT 02692000
EJECT 02693000
* INITIALIZE BUFFER POINTERS FOR 'PACK' OPERATION. 02694000
$$PCPAB EQU * 02695000
L R1,OBUFAD GET ADDRESS OF BUFFER ADDRESS 02696000
MVC 0(PACKBL,R1),PACKFHB COPY PACK FILE HEADER BUFFER *02697000
INTO OUTPUT FILE BUFFER 02698000
LA R1,PACKBL(,R1) POINT TO FIRST AVAILABLE BYTE 02699000
ST R1,PACKBUF STORE AS CURRENT BUFFER POINTER 02700000
LA R1,800-PACKBL COMPUTE NUMBER OF BYTES LEFT 02701000
ST R1,PACKLEFT STORE INTO FIELD 02702000
MVC PKCC(1),FILLC INITIALIZE PKCC 02703000
MVC PKCC+1(1),FILLC 02704000
NEXT 02705000
SPACE 4 02706000
* INITIALIZE BUFFER POINTERS FOR 'UNPACK' OPERATION. 02707000
$$PCUPB EQU * 02708000
MVC RDITEM,=H'1' SET ITEM NUMBER FOR INPUT FILE. 02709000
LA R1,RDPLIST POINT TO INPUT PLIST 02710000
SVC 202 READ FIRST BLOCK FROM INPUT FILE 02711000
DC AL4(*+4) ERROR RETURN @VA04664 02712000
CKRW RD CHECK FOR READ ERROR 02713000
L R1,RDBUFFA GET ADDRESS OF INPUT BUFFER 02714000
LA R1,PACKBL(,R1) POINT BEYOND PACK FILE HEADER 02715000
ST R1,PACKBUF STORE AS NEXT BYTE IN BUFFER 02716000
LA R1,800-PACKBL COMPUTE BYTES LEFT IN BUFFER 02717000
ST R1,PACKLEFT STORE AS NUMBER OF BYTES LEFT 02718000
NEXT 02719000
EJECT 02720000
* SKIP TO 'FROM' NUMBER ON INPUT FILE 02721000
$$SKIPN EQU * 02722000
L R0,FROMN GET FROM NUMBER 02723000
BCTR R0,0 REDUCE BY 1 02724000
STH R0,RDITEM AND STORE AS ITEM NUMBER 02725000
L XR,CIPLIST2+PFST-PLIST2 POINT TO FST FOR CURRENT INPUT 02726000
USE FSTSECT,XR 02727000
CLC FSTIC,RDITEM COMPARE REQUESTED SIZE WITH *02728000
NUMBER OF ITEMS IN FILE 02729000
BNH ERNFN GO IF 'FROM' NUMBER IS TOO HIGH 02730000
NEXT 02731000
EJECT 02732000
* SKIP TO 'FRLABEL' 02733000
$$SKIPL EQU * 02734000
SR XR,XR ITEM NUMBER 02735000
L XR2,RDBUFFA INPUT BUFFER ADDRESS 02736000
LH XR3,FRLL GET FRLABEL (LENGTH - 1) 02737000
SPACE 02738000
* COME HERE TO DO EACH NEW RDBUF 02739000
SKIPLL EQU * 02740000
LA XR,1(,XR) INCREMENT ITEM NUMBER 02741000
STH XR,RDITEM SAVE IN OUTPUT PLIST 02742000
LA R1,RDPLIST POINT TO OUTPUT PLIST 02743000
SVC 202 READ A RECORD 02744000
DC AL4(*+4) 02745000
CKRW RD,EOF=ERNFL CHECK RETURN CODE 02746000
C XR3,RDRET COMPARE LABEL LENGTH WITH *02747000
LENGTH OF RECORD READ 02748000
BH SKIPLL NO MATCH IF RECORD IS SHORTER 02749000
EX XR3,SKIPLC COMPARE LABEL WITH RECORD 02750000
BNE SKIPLL LOOP IF NOT 02751000
SPACE 02752000
* COME HERE WHEN MATCH FOUND 02753000
SKIPLS EQU * 02754000
BCTR XR,0 REDUCE ITEM NUMBER 02755000
STH XR,RDITEM STORE ITEM NUMBER IN PLIST 02756000
NEXT 02757000
SPACE 02758000
SKIPLC CLC FRL(0),0(XR2) LENGTH FILLED IN BY EX 02759000
EJECT 02760000
* PRELIMINARY SETUP CODE FOR 'FOR' NUMBER. 02761000
* WE COMPUTE THE RECORD NUMBER OF THE LAST RECORD TO BE READ. 02762000
$$SETFOR EQU * 02763000
L R1,FORN GET 'FOR' NUMBER 02764000
AH R1,RDITEM ADD CURRENT ITEM NUMBER 02765000
ST R1,FOREND SAVE AS FINAL VALUE 02766000
NEXT 02767000
EJECT 02768000
* INITIALIZE OUTPUT BUFFER TO FILL CHARACTER, IF NECESSARY 02769000
$$IBUFF EQU * 02770000
L R1,OBUFAD GET ADDRESS OF OUTPUT BUFF P3090 02771000
LA R1,1(,R1) POINT TO BUFFER+1 P3090 02772000
ST R1,VBUFEND STORE AS VARIABLE BUFFER P3090*02773000
END, IN CASE NECESSARY P3090 02774000
CLI BINBYTE,0 BUFFER INITIALIZATION NECESSARY? 02775000
BE IBUFFN GO IF NOT 02776000
LM R14,R15,OBUFAD LOAD BUFFER ADDRESS/LENGTH 02777000
SR R0,R0 02778000
L R1,FILLC GET FILL CHARACTER 02779000
MVCL R14,R0 INITIALIZE BUFFER 02780000
SPACE 02781000
IBUFFN EQU * 02782000
NEXT 02783000
EJECT 02784000
* READ OVERLAY FILE INTO OUTPUT BUFFER 02785000
$$RDOVLY EQU * 02786000
LH R1,OVITEM GET OVERLAY ITEM NUMBER 02787000
LA R1,1(,R1) INCREMENT 02788000
STH R1,OVITEM 02789000
LA R1,OVPLIST GET OVERLAY PLIST ADDRESS 02790000
SVC 202 READ OVERLAY FILE 02791000
DC AL4(*+4) 02792000
CKRW RD,EOF=RDOVLYE CHECK RETURN CODE 02793000
L R1,OVRET GET NO BYTES READ 02794000
A R1,OBUFAD ADD TO OUTPUT BUFFER ADDRESS 02795000
ST R1,VBUFEND SAVE AS VARIABLE BUFFER END 02796000
NEXT 02797000
SPACE 02798000
* END OF FILE ON OVERLAY FILE 02799000
RDOVLYE EQU * 02800000
PHASE CL ENTER CLOSING PHASE 02801000
EJECT 02802000
* CHECK TO SEE IF 'FOR' NUMBER HAS BEEN REACHED. 02803000
$$CKFORN EQU * 02804000
CLC RDITEM,FOREND+2 HAS IT BEEN REACHED? 02805000
BNL CKFORNE GO IF IT HAS 02806000
NEXT 02807000
SPACE 02808000
* IT IT'S BEEN REACHED, ENTER PHASE EO 02809000
CKFORNE EQU * 02810000
PHASE EO 02811000
EJECT 02812000
* READ INPUT FILE INTO INPUT BUFFER 02813000
$$RDIN EQU * 02814000
LH R1,RDITEM GET INPUT ITEM NUMBER 02815000
LA R1,1(,R1) INCREMENT 02816000
STH R1,RDITEM AND STORE 02817000
LA R1,RDPLIST POINT TO INPUT PLIST 02818000
SVC 202 02819000
DC AL4(*+4) 02820000
CKRW RD,EOF=RDINE CHECK RETURN CODE 02821000
NEXT 02822000
SPACE 02823000
* ENTER PHASE EO ON EOF ON INPUT FILE. 02824000
RDINE EQU * 02825000
PHASE EO 02826000
EJECT 02827000
* IF INPUT AND OUTPUT BUFFERS ARE THE SAME, THEN SET VBUFEND ACCORDING 02828000
* TO INPUT FILE RECORD SIZE. 02829000
$$SVE EQU * 02830000
L R1,RDRET GET SIZE OF INPUT RECORD 02831000
A R1,BUFAD ADD BUFFER ADDRESS 02832000
C R1,VBUFEND IS IT BEYOND EXISTING VBUFEND? 02833000
BL *+8 DON'T SET IT IF NOT 02834000
ST R1,VBUFEND SET NEW VBUFEND 02835000
NEXT 02836000
EJECT 02837000
* CHECK WHETHER 'TOLABEL' HAS BEEN REACHED. 02838000
$$CKTOL EQU * 02839000
LH XR3,TOLL GET LABEL (LENGTH - 1) 02840000
C XR3,RDRET COMPARE LABEL LENGTH WITH *02841000
LENGTH OF RECORD READ 02842000
BH CKTOLN NO MATCH IF RECORD IS SHORTER 02843000
L R1,RDBUFFA POINT TO INPUT BUFFER 02844000
EX XR3,CKTOLC COMPARE LABEL WITH RECORD 02845000
BNE CKTOLN GO IF NO MATCH 02846000
PHASE EO ENTER PHASE EO IF A MATCH 02847000
SPACE 02848000
CKTOLN EQU * 02849000
NEXT 02850000
SPACE 02851000
CKTOLC CLC TOL(0),0(R1) LENGTH FILLED IN BY EX 02852000
EJECT 02853000
* COPY DATA FROM INPUT BUFFER TO OUTPUT BUFFER ACCORDING TO 'SPECS' 02854000
* SPECIFICATIONS. 02855000
$$COPSP EQU * 02856000
LA SPR,SPECSB-SPBLEN POINT TO 'SPECS' CTL BLOCK 02857000
SPACE 02858000
* COME HERE TO HANDLE NEXT SPECIFICATION. 02859000
COPSPL EQU * 02860000
LA SPR,SPNEXT GET NEXT SPEC BLOCK 02861000
CLI 0(SPR),X'FF' END OF SPECIFICATIONS? 02862000
BE COPSPE GO IF YES 02863000
LM R0,R1,SPINDISP GET INPUT BUFFER DISPS 02864000
LTR R0,R0 BUT WAS IT A CONSTANT STRING? 02865000
BM COPSPO GO IF IT WAS 02866000
TM OPF3,OP3PHCV ARE WE IN PHASE CV? @VA03971 02867000
BO COPSPL YES; IGNORE COLUMN PAIR SPECS @VA03971 02868000
C R0,RDRET BEG COL > INPUT BUFFER LENGTH? 02869000
BNL COPSPL SKIP SPECIFICATION IF NOT 02870000
C R1,RDRET END COL > INPUT BUFFER LENGTH? 02871000
BL *+8 SKIP IF NOT 02872000
L R1,RDRET OTHERWISE, TRUNCATE SPEC 02873000
SR R1,R0 GET LENGTH OF SPEC 02874000
A R0,RDBUFFA R0 -> 'FROM' ADDRESS 02875000
SPACE 02876000
COPSPO EQU * 02877000
L R14,SPOUDISP GET DISPLACEMENT INTO OUTPUT BUF 02878000
A R14,OBUFAD ADD BUFFER ADDRESS 02879000
LR R15,R1 'TO' LENGTH = 'FROM' LENGTH 02880000
MVCL R14,R0 MOVE STRING 02881000
C R14,VBUFEND COMPARE WITH VARIABLE BUFFER END 02882000
BL *+8 SKIP IF LESS 02883000
ST R14,VBUFEND OTHERWISE, SET NEW VALUE 02884000
B COPSPL GO FOR NEXT SPECIFICATION 02885000
SPACE 02886000
COPSPE EQU * 02887000
NEXT 02888000
EJECT 02889000
* 'TRUNC' OPTION SPECIFIED -- REMOVE FILL CHARACTERS FROM END 02890000
$$TRUNC EQU * 02891000
L R1,VBUFEND GET BUFFER END 02892000
SPACE 02893000
TRUNCL EQU * 02894000
BCTR R1,0 BACKSPACE POINTER 02895000
C R1,OBUFAD BEGINNING OF OUTPUT BUFFER? 02896000
BE TRUNCE STOP THERE IF SO 02897000
CLC FILLC(1),0(R1) IS IT A FILL CHAR? 02898000
BE TRUNCL LOOP BACK IF NOT 02899000
SPACE 02900000
TRUNCE EQU * 02901000
LA R1,1(,R1) INCREMENT TO GET NEW VBUFEND 02902000
ST R1,VBUFEND AND STORE VALUE 02903000
NEXT 02904000
EJECT 02905000
* TRANSLATE OUTPUT BUFFER USING TRANSLATE TABLE 02906000
$$TRANS EQU * 02907000
L XR,OBUFAD GET ADDRESS OF OUTPUT BUFFER 02908000
LA R0,256 MAXIMUM NO BYTES PER TRANSLATE 02909000
L R1,VBUFEND END OF BUFFER 02910000
SR R1,XR R1 <- BUFFER LENGTH 02911000
SPACE 02912000
TRANSL EQU * 02913000
LTR R1,R1 ANYTHING LEFT TO TRANSLATE? 02914000
BZ TRANSE FINISHED IF NOT 02915000
LR R15,R1 GET LENGTH REMAINING 02916000
CR R15,R0 COMPARE WITH 256 02917000
BL *+6 SKIP IF LOWER 02918000
LR R15,R0 USE 256 (MAXIMUM) 02919000
SR R1,R15 REDUCE LENGTH REMAINING 02920000
BCTR R15,0 REDUCE FOR EX 02921000
EX R15,TRANSM TRANSLATE CHARS 02922000
AR XR,R0 INCREASE TRANSLATE TARGET ADDR 02923000
B TRANSL AND LOOP BACK 02924000
SPACE 02925000
TRANSM TR 0(0,XR),TRTAB LENGTH FILLED IN BY EX 02926000
SPACE 02927000
TRANSE EQU * 02928000
NEXT 02929000
EJECT 02930000
EJECT 02954000
* PERFORM 'PACK' OPERATION. 02955000
$$PACK EQU * 02956000
L XR,RDBUFFA POINT TO INPUT BUFFER 02957000
L R15,RDRET GET INPUT BUFFER SIZE 02958000
LA R15,0(XR,R15) POINT TO BYTE BEYOND END OF BUF 02959000
ST R15,PKBXE SAVE AS END-OF-BUFFER PTR 02960000
BCTR R15,0 SUBTRACT 2 02961000
BCTR R15,0 02962000
ST R15,PKBXE2 SAVE AS END-OF-BUFFER MINUS 2 02963000
BCTR R15,0 SUBTRACT 1 MORE 02964000
ST R15,PKBXE3 SAVE AS END-OF-BUFFER MINUS 3 02965000
BCTR R15,0 02966000
ST R15,PKBXE4 SAVE AS END-OF-BUFFER MINUS 4 02967000
SPACE 5 02968000
* MAIN RETURN POINT IN PACK LOOP, TO DECIDE WHAT TO DO NEXT. 02969000
PACKR EQU * 02970000
ST XR,PKBX SAVE CURRENT INPUT BUF POINTER 02971000
C XR,PKBXE COMPARE WITH END OF BUFFER PTR 02972000
BNL PACKE GO IF WE'VE REACHED THE END 02973000
CLC 0(1,XR),PKCC IS NEXT CHAR BLANK (FILL CHAR)? 02974000
BE PACKB GO PACK BLANKS IF SO 02975000
C XR,PKBXE2 ARE WE 2 BYTES FROM END? 02976000
BNE PACKR1 SKIP TEST IF NOT 02977000
CLC 0(1,XR),1(XR) LAST TWO BYTES OF BUF EQUAL? 02978000
BE PACKS GO PACK SPECIAL CHARS IF SO 02979000
SPACE 02980000
PACKR1 EQU * 02981000
C XR,PKBXE3 AT LEAST 3 CHARS FROM END? 02982000
BH PACKD PACK DATA IF NOT 02983000
CLC 0(2,XR),1(XR) 3 CHARS EQUAL? 02984000
BE PACKS PACK SPECIAL CHARS IF SO 02985000
SPACE 3 02986000
* COME HERE TO PACK 'DATA' -- I.E., NON-EQUAL CHARACTERS. WE MUST FIND 02987000
* THE END OF THIS DATA AREA. THIS WILL BE EITHER END OF RECORD OR 02988000
* CONSECUTIVE CHARACTERS. 02989000
PACKD EQU * 02990000
MVI PKFLAG,PKDAF SET 'DATA' FLAG 02991000
LA R14,1 INCREMENT BY 1 FOR BXLE 02992000
L R15,PKBXE2 LOOP UNTIL END OF BUF-2 02993000
BCTR XR,0 DECREMENT POINTER FOR LOOP 02994000
B PACKDLB ENTER LOOP 02995000
SPACE 02996000
CNOP 0,8 DOUBLE-WORD ALIGN FOR SPEED 02997000
PACKDL EQU * 02998000
CLC 0(1,XR),1(XR) NEXT TWO CHARS IDENTICAL? 02999000
BE PACKDLE GO IF SO 03000000
SPACE 03001000
PACKDLB EQU * 03002000
BXLE XR,R14,PACKDL LOOP THROUGH BUFFER 03003000
L XR,PKBXE POINT TO END OF BUFFER 03004000
B PACKF GO PACK DATA 03005000
SPACE 03006000
* COME HERE IF TWO EQUAL CHARACTERS ARE FOUND. 03007000
PACKDLE EQU * 03008000
CLC 0(1,XR),PKCC ARE THEY BLANKS? (FILL CHARS?) 03009000
BE PACKF GO IF YES 03010000
CLC 0(1,XR),2(XR) ARE THREE CHARS EQUAL? 03011000
BNE PACKDLB RE-ENTER LOOP IF NOT 03012000
C XR,PKBXE3 ARE THEY THE LAST 3 CHARS OF REC 03013000
BE PACKF PACK AS SPECIAL CHARS IF SO 03014000
CLC 0(1,XR),3(XR) ARE FOUR CHARS EQUAL? 03015000
BNE PACKDLB RE-ENTER SEARCH LOOP IF NOT 03016000
C XR,PKBXE4 ARE WE WITHING 4 BYTES OF END? 03017000
BH PACKDLB YES -- 4 BYTES NOT AVAILABLE 03018000
B PACKF OTHERWISE, WE STOP SCAN 03019000
SPACE 2 03020000
* COME HERE TO PACK BLANKS (FILL CHARACTERS) INTO OUTPUT BUFFER. 03021000
PACKB EQU * 03022000
MVI PKFLAG,0 SET FILL CHAR FLAGS (NONE) 03023000
B PACKBS 03024000
SPACE 03025000
* COME HERE TO PACK NON-FILL HCARACTER 03026000
PACKS EQU * 03027000
MVI PKFLAG,PKFFF+PKSCF SET 'SPECIAL CHAR' FLAG 03028000
SPACE 03029000
PACKBS EQU * 03030000
LR R14,XR COPY INPUT BUFFER POINTER 03031000
L R15,PKBXE POINT TO END OF INPUT BUFFER 03032000
SR R15,R14 GET LENGTH OF INPUT BUF REMAINNG 03033000
IC R1,0(XR) GET CHAR WE'RE LOOKING FOR 03034000
SLL R1,24 PUT INTO LEFTMOST BYTE OF R1 03035000
CLCL R14,R0 FIND FIRST NON-EQUAL CHARACTER 03036000
LR XR,R14 RESTORE POINTER TO CURRENT CHAR 03037000
SPACE 03038000
* AT THIS POINT, PACKFLAG INDICATES WHAT KIND OF SEARCH (BLANKS, 03039000
* SPECIAL CHARS, DATA) WE HAVE BEEN MAKING, AND XR POINTS TO THE END OF 03040000
* THAT FIELD. IN ADDITION, PKBX POINTS TO THE BEGINNING OF THAT FIELD. 03041000
PACKF EQU * 03042000
LR XR2,XR COPY END OF FIELD PTR 03043000
S XR2,PKBX XR2 CONTAINS LENGTH OF FIELD. 03044000
BCTR XR2,0 LENGTH OF FIELD MINUS 1 03045000
CH XR2,=AL2(PKFFF-1) CAN WE FIT LENGTH INTO FLAG BYT? 03046000
BNH *+8 SKIP IF WE CAN 03047000
OI PKFLAG,PKFFF OTHERWISE, SET SPECIAL FLAGS 03048000
CH XR2,=H'255' CAN IT FIT INTO ONE BYTE? 03049000
BNH *+8 SKIP IF IT CAN 03050000
OI PKFLAG,PKELF OTHERWISE, SET EXTRA LONG FLAG 03051000
CLI RDFV,C'F' IS INPUT FILE FIXED FORMAT? 03052000
BE PACKF1 THEN DON'T USE END OF REC FLAG 03053000
C XR,PKBXE ARE WE AT END OF RECORD? 03054000
BL PACKF1 SKIP IF WE ARE NOT 03055000
OI PKFLAG,PKFFF+PKERF ELSE, SET END OF RECORD FLAG 03056000
SPACE 03057000
PACKF1 EQU * 03058000
SPACE 03059000
* AT THIS POINT, THE FLAGS IN THE FLAG BYTE ARE DETERMINED. 03060000
TM PKFLAG,PKFFF WILL WE NEED MORE THAN 1 BYTE? 03061000
BO PACKF2 GO IF WE WILL 03062000
IC R0,PKFLAG GET FLAG BYTE 03063000
OR R0,XR2 OR IN LENGTH-1 03064000
BAL RR,PACKP1 PUT INTO PACK FILE 03065000
B PACKT AND GO FINISH PACKING FIELD 03066000
SPACE 03067000
* MORE THAN ONE BYTE WILL BE NECESSARY. 03068000
PACKF2 EQU * 03069000
IC R0,PKFLAG GET FLAG BYTE 03070000
BAL RR,PACKP1 PUT IT INTO THE PACK FILE 03071000
TM PKFLAG,PKELF EXTRA LONG FLAG SET? 03072000
BZ PACKF3 GO IF NOT 03073000
LR R0,XR2 GET LENGTH FIELD 03074000
SRL R0,8 MOVE LEFT BYTE RIGHT 1 03075000
BAL RR,PACKP1 AND PACK IT INTO OUTPUT 03076000
SPACE 03077000
PACKF3 EQU * 03078000
LR R0,XR2 GET LENGTH FIELD 03079000
BAL RR,PACKP1 PUT 2ND BYTE INTO PACK FILE 03080000
SPACE 03081000
* COME HERE WHEN THE FLAG AND LENGTH BYTE(S) HAVE BEEN PLACED INTO PACK 03082000
* FILE. AT THIS POINT, PKFLAG CONTAINS THE FLAG BYTE, XR POINTS TO 03083000
* THE BYTE BEYOND THE END OF THE FIELD, AND PKBX POINTS TO THE FIRST 03084000
* BYTE OF THE FIELD. 03085000
PACKT EQU * 03086000
LA XR2,1(,XR2) RE-INCREMENT TO GET FIELD LENGTH 03087000
TM PKFLAG,PKDAF+PKSCF FILL CHARACTER FIELD? 03088000
BZ PACKR NOTHING TO DO IF SO 03089000
TM PKFLAG,PKDAF DATA FIELD? 03090000
BO PACKTD FO IF IT IS 03091000
SPACE 03092000
* OTHERWISE, IT'S A SPECIAL CHARACTER FIELD. 03093000
LR R1,XR POINT TO END OF FIELD 03094000
BCTR R1,0 BACK UP ONE BYTE 03095000
IC R0,0(R1) GET THE SPECIAL CHAR 03096000
BAL RR,PACKP1 PUT IT INTO OUTPUT FILE 03097000
B PACKR GO INTO MAIN PACK LOOP 03098000
SPACE 2 03099000
* COME HERE TO COPY THE DATA FIELD FROM THE INPUT FILE TO THE 03100000
* PACKED FILE. 03101000
PACKTD EQU * 03102000
L R0,PKBX POINT TO BEGINNING OF FIELD 03103000
LR R1,XR2 R1 CONTAINS LENGTH OF FIELD 03104000
LM R14,R15,PACKBUF GET CURRENT ADDR/LENGTH OF REST *03105000
OF CURRENT PACK BUFFER. 03106000
LR XR3,R15 COPY LENGTH REMAINING 03107000
CR R1,R15 IS THERE ENOUGH SPACE REMAINING? 03108000
BH *+6 SKIP IF THERE IS NOT 03109000
LR R15,R1 OUTPUT LENGTH = INPUT LENGTH 03110000
SR XR3,R15 NEW LENGTH REMAINING IN PACK BF 03111000
ST XR3,PACKLEFT SAVE IT 03112000
MVCL R14,R0 MOVE DATA 03113000
ST R14,PACKBUF STORE NEW END OF PACK BUFFER 03114000
ST R0,PKBX STORE NEW CURRENT INPUT PTR 03115000
LR XR2,R1 SAVE LENGTH REMAINING TO COPY 03116000
CLC PACKLEFT,=F'0' OUTPUT BUFFER FULL? 03117000
BNE *+8 SKIP IF NOT 03118000
BAL RR,PACKW IF SO, THEN GO WRITE IT OUT. 03119000
LTR XR2,XR2 ANY MORE INPUT BUFFER TO COPY? 03120000
BZ PACKR RE-ENTER MAIN LOOP IF NOT 03121000
B PACKTD GO COPY IT IF SO 03122000
SPACE 2 03123000
* COME HERE WHEN PACKING OPERATION IS COMPLETED. 03124000
PACKE EQU * 03125000
NEXT 03126000
SPACE 5 03127000
* THE FOLLOWING SUBROUTINE PUTS ONE CHARACTER INTO THE PACK FILE BUFF. 03128000
PACKP1 EQU * 03129000
STM R14,R12,12(R13) SAVE REGISTERS 03130000
LM R14,R15,PACKBUF GET ADDR/LEN OF REST OF PACKBUF 03131000
STC R0,0(R14) STORE CHARACTER INTO PACK BUFF 03132000
LA R14,1(,R14) INCREMENT BUFFER ADDR PTR 03133000
BCTR R15,0 DECREMENT LEN REMAINING PTR 03134000
STM R14,R15,PACKBUF STORE NEW VALUES 03135000
LTR R15,R15 ANY SPACE REMAINING? 03136000
BNZ *+8 SKIP IF SO 03137000
BAL RR,PACKW IF NOT, WRITE BUFFER OUT 03138000
LM R14,R12,12(R13) RESTORE REGISTERS 03139000
BR RR RETURN TO CALLER 03140000
SPACE 5 03141000
* THE FOLLOWING SUBROUTINE WRITES OUT A RECORD OF THE PACK BUFFER. 03142000
PACKW EQU * 03143000
LH R1,WRITEM INCREMENT ITEM NUMBER 03144000
LA R1,1(,R1) 03145000
STH R1,WRITEM 03146000
LA R1,WRPLIST POINT TO WRBUF PLIST 03147000
SVC 202 WRITE OUT A RECORD 03148000
DC AL4(*+4) ERROR RETURN @VA04664 03149000
CKRW WR CHECK RETURN CODE 03150000
MVC PACKBUF,WRBUFFA RE-INITIALIZE PACKBUF 03151000
MVC PACKLEFT,=F'800' RE-INITIALIZE PACKLEN 03152000
BR RR RETURN TO CALLER 03153000
EJECT 03154000
* PERFORM UNPACK OPERATION 03155000
$$UNPACK EQU * 03156000
L R1,WRBUFFA POINT TO OUTPUT BUFFER 03157000
ST R1,PKBX INITIALIZE CURRENT POINTER 03158000
A R1,OBUFLEN ADD LENGTH OF OUTPUT BUFFER 03159000
ST R1,PKBXE SAVE AS END OF BUFFER 03160000
BAL RR,UNPAG1 GET FIRST FLAG BYTE FOR RECORD 03161000
STC R0,PKFLAG STORE AS FLAG BYTE 03162000
CLI PKFLAG,X'FF' IS IT END OF FILE FLAG? 03163000
BNE UNPAL1 GO IF IT ISN'T 03164000
PHASE EO OTHERWISE, ENTER PHASE EO 03165000
SPACE 2 03166000
* COME HERE TO GET THE NEXT FLAG BYTE FOR THE FIELD. 03167000
UNPAL EQU * 03168000
BAL RR,UNPAG1 GET NEXT FLAG BYTE 03169000
STC R0,PKFLAG STORE AS FLAG BYTE 03170000
CLI PKFLAG,X'FF' END OF FILE FLAG? 03171000
BNE *+8 SKIP IF NOT 03172000
BAL RR,ERUPX IMPOSSIBLE CONDITION IF SO 03173000
SPACE 03174000
UNPAL1 EQU * 03175000
TM PKFLAG,PKFFF IS FIELD LENGTH IN FLAG BYTE? 03176000
BO UNPAL2 GO IF IT ISN'T 03177000
LR XR2,R0 COPY FLAG BYTE 03178000
N XR2,=AL1(0,0,0,B'01111111') TURN OFF HIGH BIT FLAG 03179000
XR R0,XR2 LET R0 CONTAINS ONLY FLAGS 03180000
STC R0,PKFLAG AND STORE AS NEW FLAG BYTE 03181000
B UNPAT GO DETERMINE TYPE OF FIELD 03182000
SPACE 03183000
* COME HERE IF THE REAL LENGTH IS IN SUBSEQUENT BYTES IN PACKED FIELD. 03184000
UNPAL2 EQU * 03185000
BAL RR,UNPAG1 GET FIRST (OR ONLY) LENGTH BYTE 03186000
LR XR2,R0 COPY IT TO XR2 03187000
TM PKFLAG,PKELF IS IT AN EXTRA-LONG FIELD? 03188000
BZ UNPAT WE'RE FINISHED IF NOT 03189000
SLL XR2,8 OTHERWISE SHIFT LEFT FIRST BYTE 03190000
BAL RR,UNPAG1 GO GET SECOND BYTE FROM FILE 03191000
AR XR2,R0 AND ADD IT TO GET TOTAL LENGTH 03192000
SPACE 2 03193000
* AT THIS POINT, PKFLAG CONTAINS THE FLAGS INDICATING THE TYPE OF 03194000
* FIELD, AND XR2 CONTAINS THE LENGTH OF THE FIELD. 03195000
UNPAT EQU * 03196000
LA XR2,1(,XR2) INCREMENT XR2 TO GET REAL LENGTH 03197000
TM PKFLAG,PKDAF+PKSCF IS IT A BLANK (FILL CHAR) FIELD? 03198000
BZ UNPAB GO HANDLE IT IF IT IS 03199000
TM PKFLAG,PKDAF IS IT A DATA FIELD? 03200000
BO UNPAD GO HANDLE IT IF IT IS 03201000
TM PKFLAG,PKSCF IS IT SPECIAL (NON-FILL) CHAR? 03202000
BO UNPAS GO HANDLE IT 03203000
BAL RR,ERUPX IMPOSSIBLE CONDITION 03204000
SPACE 03205000
* THE FIELD IS BLANK (FILL CHARACTERS) 03206000
UNPAB EQU * 03207000
IC R0,PACKCHAR GET FILL CHARACTER 03208000
B UNPABS GO PROPOGATE IT 03209000
SPACE 03210000
* COME HERE IF THE FIELD IS SPECIAL CHARACTER 03211000
UNPAS EQU * 03212000
BAL RR,UNPAG1 GO GET SPECIAL CHAR FROM PACK BF 03213000
SPACE 03214000
* PROPOGATE THE CHARACTER IN R0 FOR THE LENGTH IN XR2 03215000
UNPABS EQU * 03216000
LR R1,R0 COPY OVER CHARACTER 03217000
SLL R1,24 MOVE INTO LEFT-MOST BYTE 03218000
L R14,PKBX GET CURRENT OUTBUF PTR 03219000
LR R15,XR2 GET LENGTH OF FIELD 03220000
MVCL R14,R0 PROPOGATE CHARACTER FOR FIELD 03221000
ST R14,PKBX STORE NEW FIELD PTR 03222000
B UNPALE GO FOR NEXT FIELD 03223000
SPACE 2 03224000
UNPAD EQU * 03225000
CLC PACKLEFT,=F'0' PACKED BUFFER EMPTY? 03226000
BNE *+8 SKIP IF NOT 03227000
BAL RR,UNPAR READ A RECORD IF IT IS 03228000
LM R0,R1,PACKBUF GET ADDR/LEN LEFT 03229000
L R14,PKBX CURRENT OUTPUT BUFFER PTR 03230000
LR R15,XR2 LENGTH TO BE COPIED 03231000
CR R1,R15 COMPARE LENGTHS 03232000
BH *+6 SKIP IF OUTPUT BUFFER LONG ENUF 03233000
LR R15,R1 SET LENGTHS EQUAL 03234000
SR XR2,R15 03235000
MVCL R14,R0 COPY DATA TO UNPACKED FILE 03236000
STM R0,R1,PACKBUF STORE NEW PACKED BUFFERS PTRS 03237000
ST R14,PKBX STORE NEW OUTPUT BUFFER PTR 03238000
LTR XR2,XR2 ANY MORE TO MOVE? 03239000
BP UNPAD LOOP BACK IF THERE IS 03240000
SPACE 03241000
* WE COME HERE AFTER WE'VE COPIED OVER THE FIELD. WE MAKE A TEENY 03242000
* LITTLE CHECK TO SEE IF WE'RE WIPING ANYTHING OUT. 03243000
UNPALE EQU * 03244000
L R14,PKBX CURRENT BUFFER POINTER 03245000
C R14,PKBXE BEYOND END OF BUFFER? 03246000
BNH *+8 SKIP IF NOT 03247000
BAL RR,ERUPX IMPOSSIBLE CONDITION IF SO 03248000
EJECT 03249000
* WE MUST NOW DECIDE WHETHER WE HAVE REACHED THE END OF THE END OF THE 03250000
* RECORD. IF SO, WE ARE FINISHED. IF NOT, WE RETURN TO UNPAL TO 03251000
* PROCESS THE NEXT FIELD OF THE RECORD. 03252000
* WE MAKE OUR DECISION BASED ON THREE FACTORS: 03253000
* 1. WHETHER THE OUTPUT FILE RECFM IS F OR V 03254000
* 2. WHETHER THE END-OF-RECORD FLAG IS SET IN THE LAST FLAG 03255000
* BYTE 03256000
* 3. WHETHER WE ARE AT THE END OF THE OUTPUT BUFFER. 03257000
* 03258000
* THE DECISION IS MADE ACCORDING TO THE FOLLOWING TABLE: 03259000
* 03260000
* F OR V EOR FLG END OF BUF WHERE TO GO 03261000
* ------- -------- ---------- ----------- 03262000
* F 1 NO IMPOSSIBLE 03263000
* F 1 YES IMPOSSIBLE 03264000
* F 0 NO UNPAL 03265000
* F 0 YES WE'RE THRU 03266000
* V 1 NO WE'RE THRU 03267000
* V 1 YES WE'RE THRU 03268000
* V 0 NO UNPAL 03269000
* V 0 YES IMPOSSIBLE 03270000
SPACE 03271000
SR R1,R1 03272000
C R14,PKBXE ARE WE AT END OF BUFFER? 03273000
BL *+8 SKIP IF WE ARE NOT 03274000
LA R1,1 TURN ON BIT IF SO 03275000
TM PKFLAG,PKERF END OF REC FLAG SET? 03276000
BO *+8 SKIP IF SO 03277000
LA R1,2(,R1) TURN ON BIT IF NOT 03278000
CLI WRFV,C'V' OUTPUT RECFM V? 03279000
BNE *+8 SKIP IF NOT 03280000
LA R1,4(,R1) TURN ON BIT IF SO 03281000
IC R1,UNPALT(R1) GET BRANCH BYTE 03282000
B *+4(R1) BRANCH TO ROUTINE 03283000
B UNPAN WE'RE THRU 03284000
B UNPAL GO BACK FOR NEXT FIELD 03285000
BAL RR,ERUPX IMPOSSIBLE CONDITION 03286000
SPACE 03287000
UNPALT DC FL1'8,8,4,0,0,0,4,8' 03288000
SPACE 03289000
UNPAN EQU * 03290000
MVC VBUFEND,PKBX SET VARIABLE BUFFER END 03291000
NEXT 03292000
SPACE 2 03293000
* THIS SUBROUTINE GETS ONE BYTE FROM THE PACKED INPUT BUFFER. 03294000
UNPAG1 EQU * 03295000
STM R14,R12,12(R13) SAVE REGISTERS 03296000
CLC PACKLEFT,=F'0' INPUT BUFFER EXHAUSTED? 03297000
BNE *+8 SKIP IF NOT 03298000
BAL RR,UNPAR IF SO, READ ANOTHER RECORD 03299000
LM R14,R15,PACKBUF GET BUFFER PTR/LEN 03300000
SR R0,R0 03301000
IC R0,0(R14) GET NEXT BYTE FROM BUFFER 03302000
LA R14,1(,R14) INCREMENT BUFFER POINTER 03303000
BCTR R15,0 DECREMENT BYTES LEFT 03304000
STM R14,R15,PACKBUF STORE NEW VALUES 03305000
LM R14,R15,12(R13) RESTORE REGISTERS 03306000
LM R1,R12,12+12(R13) 03307000
BR RR RETURN TO CALLER 03308000
SPACE 2 03309000
* THIS SUBROUTINE READS A PACKED INPUT RECORD. 03310000
UNPAR EQU * 03311000
LH R1,RDITEM INCREMENT ITEM NUMBER 03312000
LA R1,1(,R1) 03313000
STH R1,RDITEM 03314000
LA R1,RDPLIST POINT TO RDBUF PLIST 03315000
SVC 202 READ A RECORD 03316000
DC AL4(*+4) ERROR RETURN @VA04664 03317000
CKRW RD CHECK FOR ERROR CODE BAD 03318000
MVC PACKBUF,RDBUFFA RE-INITIALIZE BUFFER POINTER 03319000
MVC PACKLEFT,=F'800' 800 BYTES LEFT IN BUFFER 03320000
BR RR RETURN TO CALLER 03321000
EJECT 03322000
* WRITE TO OUTPUT FILE 03323000
$$WROUT EQU * 03324000
CLI WRFV,C'V' VARIABLE OUTPUT RECFM? 03325000
BNE WROUTG GO IF NOT 03326000
L R1,VBUFEND GET VARIABLE BUFFER END 03327000
S R1,OBUFAD GET LENGTH OF BUFFER 03328000
ST R1,WRBUFFS STORE IN WRBUF PLIST 03329000
SPACE 03330000
WROUTG EQU * 03331000
LH R1,WRITEM GET OUTPUT ITEM NUMBER 03332000
LA R1,1(,R1) INCREMENT 03333000
STH R1,WRITEM AND STORE 03334000
TM OPF2,OP2OVLY OVERLAY? @VA03023 03335000
BO AROUND YES, SKIP TEST @VA03023 03336000
CLI WRFV,C'V' IS OUTPUT VARIABLE? @VA03023 03337000
BE AROUND YES, SKIP TEST @VA03023 03338000
CLI RDFV,C'V' IS INPUT VARIABLE? @VA03023 03339000
BE AROUND YES, SKIP TEST @VA03023 03340000
TM RDPLIST+37,FSTITAV IS A RECORD AVAILABLE? @VA06024 03341000
BZ NEXT NO @VA03023 03342000
AROUND LA R1,WRPLIST POINT TO WRBUF PLIST @VA03023 03343000
SVC 202 03344000
DC AL4(*+4) 03345000
CKRW WR CHECK RETURN CODE 03346000
NEXT 03347000
EJECT 03348000
* FINIS INPUT FILE 03349000
$$FINI EQU * 03350000
MVC FIPLIST+8(18),RDFNAME PUT NAME IN FINIS PLIST 03351000
CLI FIPLIST+25,C'3' IS IT MODE 3? @VA03020 03352000
BNE GOFINI NO, CONTINUE @VA03020 03353000
TM OPF1,OP1OLDD HAS OLDDATE BEEN SPECIFIED? @VA03020 03354000
BZ NODATE NO, DONT GET DATE @VA07638 03355000
LA R1,FIPLIST POINT TO PLIST @VA03020 03356000
GETFST FIPLIST,ERR=FINIER GET FST FOR INPUT FILE @VA03020 03357000
USE FSTSECT,R1 @VA03020 03358000
TM OPF2,OP2MULT IN CASE OF MULT.OUTPUT FILS @VA09042 03358100
BO MULTFILE GET THE DATE FOR EACH ONE @VA09042 03358200
CLC FFSTD(4),=XL4'0' IF WE HAVE THE DATE ALREADY @VA09042 03358300
BNE NODATE DO NOT OVERLAY IT @VA09042 03358400
MULTFILE EQU * @VA09042 03358500
MVC FFSTD(4),FSTD GET DATE AND TIME @VA03020 03359000
MVC FFSTYR(2),FSTYR GET YEAR @VA03020 03360000
OI OPF3,OP3MODE3 PUT THE FLAG ON @VA03020 03361000
DROP R1 @VA03020 03362000
NODATE DS 0H @VA07638 03362075
LA XR2,CIPLIST2 POINT TO CURRENT PLIST2 @VA07638 03362150
USE PLIST2,XR2 ADDRESSABILITY @VA07638 03362225
L R15,PADT POINT TO ADT @VA07638 03362300
USE ADTSECT,R15 ADDRESSABILITY @VA07638 03362375
TM ADTFLG1,ADTFRW IS IT R/W DISK? @VA09043 03362385
BNO GOFINI IF IT IS NOT GOFINI @VA09043 03362395
L R15,ADTCFST POINT TO CURRENT FST @VA07638 03362450
SH R15,=H'40' BACK UP TO LAST ENTRY @VA07638 03362525
STCM R15,15,PHYP+4 SAVE IT @VA07638 03362600
LA XR2,FIPLIST2 POINT TO FIRST PLIST2 @VA07638 03362675
USE PLIST2,XR2 ADDRESSABILITY @VA07638 03362750
STCM R15,15,PHYP+4 SAVE IN FIRST LIST TOO @VA07638 03362825
DROP XR2 @VA07638 03362900
GOFINI LA R1,FIPLIST POINT TO FINIS PLIST @VA03020 03363000
SVC 202 03364000
DC AL4(*+4) @VA03972 03365000
NEXT 03366000
SPACE 03367000
FINIER EQU * 03368000
LA R6,FINIER FOR ERROR MESSAGE @VA08136 03368250
BAL RR,ERRWXX UNEXPECTED ERROR @VA08136 03368500
USING PHCL,CDR PHASE ADDRESSABILITY @VA08136 03368750
MVI PHCL+1,$@FINO SET CLOSE OUTPUT FILE @VA08136 03369000
MVI PHCL+2,$@EXIT SET EXIT @VA08136 03369250
DROP CDR @VA08136 03369500
NEXT CONTINUE @VA08136 03369750
EJECT 03370000
* END OF FILE ROUTINE FOR 'PACK' MODE. 03371000
$$EOPACK EQU * 03372000
LA R0,X'FF' PUT EOF BYTE INTO PACKED FILE 03373000
BAL RR,PACKP1 GO PACK IT IN 03374000
CLC PACKLEFT,=F'800' IS THE CURRENT OUTPUT REC EMPTY 03375000
BE EOPACKN NO WRITE IF SO 03376000
LH R1,WRITEM INCREMENT ITEM NUMBER 03377000
LA R1,1(,R1) 03378000
STH R1,WRITEM 03379000
LA R1,WRPLIST POINT TO OUTPUT PLIST 03380000
SVC 202 WRITE OUTPUT RECORD 03381000
DC AL4(*+4) ERROR RETURN @AV04664 03382000
CKRW WR CHECK FOR WRBUF ERROR 03383000
SPACE 03384000
EOPACKN EQU * 03385000
NEXT 03386000
EJECT 03387000
* POINT TO NEXT 'VERTICAL' FILE 03388000
$$NVPT EQU * 03389000
LA XR2,CIPLIST2 POINT TO CURRENT INPUT PLIST2 03390000
USE PLIST2,XR2 03391000
ST XR2,PPLIST2 STORE AS CURRENT PLIST2 03392000
* PLIST1 AND PLIST3 POINTERS ARE ALREADY SET. 03393000
NEXT 03394000
EJECT 03395000
* POINT TO NEXT 'HORIZONTAL' FILE 03396000
$$NHPT EQU * 03397000
LA XR2,CIPLIST2 POINT TO CURRENT INPUT PLIST2 03398000
USE PLIST2,XR2 03399000
ST XR2,PPLIST2 STORE AS CURRENT PLIST2 03400000
L XR,PPLIST1 GET PREVIOUS PLIST1 03401000
USE PLIST1,XR 03402000
LA XR,PNEXT1 MOVE UP ONE IN 'COPY' PLIST 03403000
ST XR,PPLIST1 THIS IS NEW PLIST1 03404000
L XR,PFLG POINT TO OLD FLAG BYTE 03405000
LA XR,1(,XR) POINT TO NEW FLAG BYTE 03406000
ST XR,PFLG AND STORE 03407000
CLI 0(XR),X'FF' ANY MORE 'HORIZONTAL' FILENAMES? 03408000
BE NHPTNONE NO; SKIP @VA03971 03409000
OI OPF3,OP3MORIN YES; REMEMBER IT @VA03971 03410000
CLI RC,28 CHECK IF RC=28 FILE ALREADY ACTIVE @VA13698 03410300
BE ERRACT YES, FILE ACTIVE GO CLOSE AND END @VA13698 03410600
NEXT @VA03971 03411000
NHPTNONE NI OPF3,X'FF'-OP3MORIN RESET 'MORE INPUT FILES' @VA03971 03412000
NEXT @VA03971 03413000
ERRACT EQU * ERROR, FILE ALREADY ACTIVE @VA13698 03413300
PHASE CL GO TO CLOSING PHASE FOR OUTPUT @VA13698 03413600
EJECT 03414000
* SKIP IF ANOTHER INPUT FILE EXISTS 03415000
$$SKFND TM OPF3,OP3MORIN ANY MORE INPUT FILES? @VA03971 03416000
BZ SKNFND NO; JUST KEEP GOING @VA03971 03417000
SKIP 1 @VA03971 03418000
SPACE 2 03419000
* DON'T SKIP IF THERE ARE NO MORE INPUT FILES 03420000
SKNFND NEXT @VA03971 03421000
EJECT 03422000
* SET UP FOR AND ENTER PHASE CV 03423000
$$SETCV LH R1,OVITEM GET OVERLAY FILE ITEM NUMBER @VA03971 03424000
BCTR R1,R0 DECREMENT IT BY 1 @VA03971 03425000
STH R1,OVITEM BECAUSE WE HAVE TO READ IT AGAIN @VA03971 03426000
OI OPF3,OP3PHCV 'PHASE CV BEING EXECUTED' @VA03971 03427000
PHASE CV ENTER PHASE CV @VA03971 03428000
EJECT 03429000
* IF THERE IS AN OVERLAY FILE, WE MUST BACKSPACE IT IF WE ARE TO 03430000
* READ AN ADDITIONAL INPUT FILE. 03431000
$$OVBK EQU * 03432000
LH R1,OVITEM GET OVERLAY FILE ITEM NUMBER 03433000
BCTR R1,0 DECREMENT 03434000
STH R1,OVITEM AND STORE 03435000
NEXT 03436000
EJECT 03437000
* WE CHECK TO SEE IF ANY RECORDS HAVE BEEN COPIED TO THE OUTPUT 03438000
* FILE AT ALL 03439000
$$CKOR EQU * 03440000
CLC WRITEM,OFREC HAS OUTPUT ITEM # CHANGED? 03441000
BE ERNRO ERROR IF HAS NOT 03442000
NEXT 03443000
EJECT 03444000
* FINIS OUTPUT FILE 03445000
$$FINO EQU * 03446000
CLI RC,X'00' DO WE HAVE A RET.CODE ALREADY? @VA09493 03446015
BH NOSECMSG IF YES DON'T GIVE HIM 2ND MSG.. @VA09493 03446030
SLR R0,R0 ZERO FOR ACT LKP @VA08136 03446050
LA R1,WRPLIST POINT TO WRITE PLIST @VA08136 03446100
L R15,AACTLKP ACT LKP POINTER @VA08136 03446150
BALR R14,R15 CALL LKP @VA08136 03446200
BNZ NOAFT ERROR ON RETURN @VA08136 03446250
LR XR,R1 R1 RETURNS AFT POINTER @VA08136 03446300
USING AFTSECT,XR AFT ADDRESSABILITY @VA08136 03446350
LH XR2,WRITEM ITEM NUMBER IN WRITE PLIST @VA08136 03446400
DMSEXS STH,XR2,AFTIC STORE INTO AFT ENTRY @VA08136 03446450
DROP XR IN SYSTEM STATUS @VA08136 03446500
NOSECMSG EQU * @VA09493 03446750
MVC FIPLIST+8(18),WRFNAME MOVE FILE NAME INTO FINIS PLIST 03447000
LA R1,FIPLIST POINT TO FINIS PLIST 03448000
SVC 202 03449000
DC AL4(NOFILE) @VA04736 03450000
NEXT 03451000
SPACE 3 @VA04736 03452000
NOFILE EQU * @VA04736 03453000
SR R15,R15 CLEAR A REGISTER @VA04736 03454000
STH R15,WRITEM INDICATE NO OUTPUT FILE @VA04736 03455000
B NEXT @VA04736 03456000
SPACE 2 @VA08136 03456100
NOAFT EQU * @VA08136 03456200
CLC WRITEM,OFREC OUTPUT ITEM NUMBER CHANGE @VA09884 03456230
BE ERNRO ERROR - NO FILE @VA09884 03456260
LA R6,NOAFT FOR ERROR MESSAGE @VA08136 03456300
BAL RR,ERRWXX UNEXPECTED ERROR @VA08136 03456400
USING PHCL,CDR PHASE ADDRESSABILITY @VA08136 03456500
MVI PHCL+1,$@EXIT SET EXIT @VA08136 03456600
DROP CDR @VA08136 03456700
NEXT CONTINUE @VA08136 03456800
EJECT 03457000
* FINIS OVERLAY FILE 03458000
$$FINV EQU * 03459000
MVC FIPLIST+8(18),OVFNAME MOVE NAME INTO FINIS PLIST 03460000
LA R1,FIPLIST POINT TO FINIS PLIST 03461000
SVC 202 03462000
DC AL4(FINVER) 03463000
NEXT 03464000
SPACE 03465000
FINVER EQU * 03466000
BAL RR,ERRWX UNEXPECTED ERROR 03467000
EJECT 03468000
* ERASE OUTPUT FILE 03469000
$$ERASEO EQU * 03470000
* COPY NAME INTO 'ERASE' PLIST 03471000
MVC ERPLIST+8(18),OUPLIST2+PNA2-PLIST2 03472000
LA R1,ERPLIST POINT TO ERASE PLIST 03473000
SVC 202 03474000
DC AL4(*+4) 03475000
NEXT 03476000
EJECT 03477000
* FOR 'OLDDATE' OPTION, COPY DATE AND YEAR FROM FST FOR FIRST INPUT 03478000
* FILE INTO FST FOR OUTPUT FILE. 03479000
$$SDATE EQU * 03480000
SPACE 03481000
* WRPLIST POINTS TO 'COPYFILE CMSUT' FOR REPLACE, OVLY, OR NEWFILE, 03482000
* AND THE OUTPUT FILE NAME OTHERWISE. 03483000
GETFST WRPLIST,ERR=SDATER GET FST FOR OUTPUT FILE 03484000
USE FSTSECT,R1 03485000
L XR,FIPLIST2+PFST-PLIST2 POINT TO FST FOR 1ST INPUT FILE 03486000
DMSKEY NUCLEUS GET NUCLEUS STORAGE KEY 03487000
TM FMO+1,X'F3' FILE MODE OF 3? @VA09042 03488100
BNO SDAT NO,DON'T USE SAVE AREA @VA09042 03488200
MVC FSTD(4),FFSTD GET ORIGINAL DATE AND TIME @VA03020 03490000
MVC FSTYR(2),FFSTYR GET ORIGINAL YEAR @VA03020 03491000
B RESET GO RESET THE KEY @VA03020 03492000
SDAT MVC FSTD,FSTD-FSTSECT(XR) COPY DATE @VA03020 03493000
MVC FSTYR,FSTYR-FSTSECT(XR) COPY YEAR 03494000
RESET EQU * @VA03020 03495000
DMSKEY RESET RESET PSW KEY 03496000
NEXT 03497000
SPACE 03498000
* IF ERROR, WE CHANGE THE WRPLIST OP FIELD FOR THE ERROR MESSAGE. 03499000
SDATER EQU * 03500000
LA R1,WRPLIST POINT TO PLIST 03501000
MVC 0(8,R1),=CL8'FSTLKP' CHANGE FOR ERROR MESSAGE 03502000
BAL RR,ERRWX GO TYPE ERROR MESSAGE 03503000
EJECT 03504000
* RENAME TEMP NAME TO NEW NAME 03505000
$$RENAME EQU * 03506000
SR R15,R15 CLEAR REGISTER @VA04736 03507000
CH R15,WRITEM IS THERE AN OUTPUT FILE? @VA04736 03508000
BE NEXT BRANCH IF NOT @VA04736 03509000
MVC RNPLIST+8(24),WRFNAME COPY TEMP NAME INTO RENAME PLIST 03510000
* COPY REAL NAME INTO RENAME PLIST 03511000
MVC RNPLIST+32(18),OUPLIST2+PNA2-PLIST2 03512000
LA R1,RNPLIST POINT TO RENAME PLIST 03513000
SVC 202 03514000
DC AL4(RENAMEE) 03515000
NEXT 03516000
SPACE 03517000
RENAMEE EQU * 03518000
BAL RR,ERRWX UNEXPECTED ERROR 03519000
$$EXIT EQU * 03520000
EXIT EQU * 03521000
L R0,BUFLEN GET I/O BUFFER LENGTH 03522000
L R1,BUFAD GET I/O BUFFER ADDRESS 03523000
LTR R1,R1 WAS AN I/O BUFFER ALLOCATED? 03524000
BZ EXITF DON'T FREEMAIN IF NOT 03525000
FREEMAIN R,LV=(0),A=(1) FREEMAIN BUFFER 03526000
SPACE 03527000
EXITF EQU * 03528000
L R13,SAVE13 RESTORE REG 13 03529000
SR XR,XR 03530000
IC XR,RC GET RETURN CODE 03531000
IC R5,DOSF GET SAVED DOSFLAGS @V305066 03532000
LR R1,WR POINT TO WORK SPACE 03533000
FREEMAIN R,LV=8*WORKLEN,A=(1) FREEMAIN WORK SPACE 03534000
LR R15,XR GET RETURN CODE 03535000
SPACE 03536000
* IF WE PUT 255 AS THE RETURN CODE, THEN WE REALLY MEANT 256. 03537000
CH R15,=H'255' IS IT 255 03538000
BNE *+8 SKIP IF NOT 03539000
LA R15,256 RESET IT TO 256 IF SO 03540000
LR XR,R15 SAVE R15 FOR LATER @VM03042 03541000
DMSKEY NUCLEUS @V305066 03542000
OI MISFLAGS,RELPAGES EXECUTE WITH SYSTEM KEY @V305066 03543000
STC R5,DOSFLAGS STORE BACK IN NUCON @V305066 03544000
DMSKEY RESET @V305066 03545000
LR R15,XR RESTORE RETURN CODE @VM03042 03546000
RETURN (14,12),RC=(15) 03547000
* GETNUM SUBROUTINE. 03548000
* THE SUBROUTINE IS USED TO CONVERT AN INPUTTED DECIMAL TO 03549000
* INTERNAL FORM. 03550000
GETNUM EQU * 03551000
LA RR,0(,RR) INDICATE MAIN ENTRY POINT 03552000
SPACE 03553000
GETNUMC EQU * 03554000
MVC STEMP(8),0(XR2) COPY FIELD 03555000
MVI STEMP+8,C'X' FORCE CONVERSION ERROR ON 9TH CH 03556000
STM 14,1,0(R13) SAVE REGS 03557000
SR R14,R14 03558000
SR R15,R15 03559000
LA R1,STEMP-1 CHAR POINTER REG 03560000
SPACE 03561000
GT1 EQU * 03562000
LA R1,1(,R1) POINT TO NEXT CHAR 03563000
CLI 0(R1),C' ' BLANK? 03564000
BE GTE 03565000
CLI 0(R1),C'0' NUMERIC? 03566000
BL GTER ERROR IF NOT 03567000
CLI 0(R1),C'9' 03568000
BH GTER 03569000
IC R15,0(R1) GET CHAR 03570000
SH R15,=AL2(C'0') DISPLACE TO 0 03571000
MH R14,=H'10' SHIFT RESULT SO FAR LEFT 1 DIGIT 03572000
AR R14,R15 ADD IN NEW DIGIT 03573000
B GT1 LOOP BACK 03574000
SPACE 03575000
GTE EQU * 03576000
LTR R1,R14 GET NUMBER 03577000
LM R14,R15,0(R13) RESTORE REGS 03578000
BZ GTER ZERO IS ILLEGAL 03579000
BR RR RETURN FROM SUBROUTINE 03580000
SPACE 2 03581000
* THE FOLLOWING ENTRY POINT IS TAKEN FROM THE 'SPECS' SPECIFICATIONS 03582000
* HANDLING ROUTINE. 03583000
GETNUMS EQU * 03584000
O RR,=AL1(X'80',0,0,0) INDICATE GETNUMS ENTRY 03585000
B GETNUMC 03586000
SPACE 2 03587000
* ERROR ENCOUNTERED 03588000
GTER EQU * 03589000
LTR RR,RR WHICH ENTRY? 03590000
BM ERILS USE 'SPECS' ERROR MESSAGE 03591000
B ERARG SUB-PARAM ERROR MESSAGE 03592000
EJECT 03593000
* GETNAME SUBROUTINE. 03594000
* THIS SUBROUTINE IS USED TO FORM AN OPTION NAME FROM AN OPTION 03595000
* CODE, SO THAT THE NAME CAN APPEAR IN AN ERROR MESSAGE. 03596000
GETNAME EQU * 03597000
N R1,=A(X'FF') GET OPTION BYTE 03598000
MH R1,=AL2(OPSLEN) MULTIPLY BY LENGTH OF OPTAB 03599000
LA R1,OPTAB(R1) POINT TO NAME IN OPTAB 03600000
BR RR RETURN 03601000
SPACE 4 03602000
* GETHEX SUBROUTINE. THIS SUBROUTINE TAKES TWO BYTE HEX INPUT AND 03603000
* CONVERTS IT TO INTERNAL FORM, RETURNING THE VALUE IN R1. 03604000
* UPON ENTERING, XR2 POINTS TO THE TWO BYTE FIELD. THE ROUTINE GIVES 03605000
* A NON-JUMP RETURN IF THERE IS AN ERROR, AND A JUMP RETURN IF THERE 03606000
* IS NOT. 03607000
GETHEX EQU * 03608000
MVC STEMP(2),0(XR2) COPY THE TWO-BYTE FIELD 03609000
TR STEMP(2),GETHEXT TRANSLATE THE NUMBER 03610000
CLI STEMP,X'FF' FIRST CHAR ILLEGAL? 03611000
BCR 8,RR (BER) ERROR RETURN IF SO 03612000
CLI STEMP+1,X'FF' SECOND CHAR ILLEGAL? 03613000
BCR 8,RR (BER) ERROR RETURN IF SO 03614000
SR R0,R0 03615000
SR R1,R1 03616000
IC R0,STEMP GET FIRST CHAR VALUE 03617000
IC R1,STEMP+1 GET SECOND CHAR VALUE 03618000
SLL R0,4 SHIFT FIRST CHAR VAL LEFT 03619000
AR R1,R0 COMBINE THE TWO 03620000
B 4(RR) AND GIVE JUMP RETURN 03621000
SPACE 03622000
* GETHEX TRANSLATE TABLE 03623000
GETHEXT DC 256X'FF' MOSTLY ILLEGAL CHARS 03624000
ORG GETHEXT+C'0' 03625000
DC AL1(0,1,2,3,4,5,6,7,8,9) SET NUMERIC DIGITS 03626000
ORG GETHEXT+C'A' 03627000
DC AL1(10,11,12,13,14,15) SET CAPITAL LETTERS 03628000
ORG GETHEXT+X'81' 03629000
DC AL1(10,11,12,13,14,15) SET SMALL LETTERS 03630000
ORG 03631000
* INFORMATIONAL MESSAGES 03632000
SPRI EQU * 03633000
DMSERR NUM=601,LET=R,TEXT='ENTER SPECIFICATION LIST:',DOT=NO 03634000
B SPR1 03635000
SPACE 3 03636000
* WARNING: THE NEXT TWO MESSAGES HAVE THE SAME MESSAGE NUMBER. 03637000
FNTYPEIO EQU * 03638000
DMSERR NUM=721,LET=I,MF=(E,ERLIST), *03639000
SUB=(CHAR8A,RDFNAME,CHARA,(XR2), *03640000
CHAR8A,OUPLIST2+PNA2-PLIST2,CHARA,(R14)), *03641000
TEXT='COPY ''....................'' ........ ''.........*03642000
...........'' (... FILE)' 03643000
NEXT 03644000
SPACE 3 03645000
* WARNING: THIS MESSAGE HAS THE SAME NUMBER AS THE PRECEDING MESSAGE. 03646000
FNTYPENI EQU * 03647000
DMSERR NUM=721,LET=I,SUB=(CHAR8A,RDFNAME), *03648000
TEXT='COPY ''....................''' 03649000
NEXT 03650000
SPACE 3 03651000
SPACE 3 03657000
RTRI EQU * 03658000
DMSERR NUM=602,LET=R,TEXT='ENTER TRANSLATION LIST:',DOT=NO 03659000
B RTR1 03660000
EJECT 03661000
* ERROR MESSAGES 03662000
ERILO EQU * 03663000
LA XR,STEMP 03664000
DMSERR NUM=3,LET=E,SUB=(CHARA,(XR)), *03665000
TEXT='INVALID OPTION ''........''' 03666000
MVI RC,24 03667000
B EXIT 03668000
SPACE 3 03669000
ERNOIN EQU * 03670000
DMSERR NUM=42,LET=E,TEXT='NO FILEID(S) SPECIFIED' 03671000
MVI RC,24 03672000
B EXIT 03673000
SPACE 3 03674000
ERDISK EQU * 03675000
L XR,PPLIST2 POINT TO PLIST2 03676000
USE PLIST2,XR 03677000
LA XR,PMO2 POINT TO FILE MODE 03678000
DMSERR NUM=37,LET=E,SUB=(CHARA,(XR)), *03679000
TEXT='DISK ''..'' IS READ/ONLY' 03680000
MVI RC,36 03681000
B EXIT 03682000
SPACE 3 03683000
ERNX EQU * 03684000
L XR,PPLIST2 POINT TO PLIST2 03685000
USE PLIST2,XR 03686000
L XR,PPLIST3 POINT TO PLIST3 03687000
USE PLIST3,XR 03688000
LA XR,PNA3 POINT TO FILE NAME 03689000
DMSERR NUM=24,LET=E,SUB=(CHAR8A,(XR)), *03690000
TEXT='FILE ''....................'' ALREADY EXISTS -- SP*03691000
ECIFY ''REPLACE''' 03692000
MVI RC,28 03693000
B EXIT 03694000
SPACE 3 03695000
ERRWX EQU * 03696000
LR R6,RR FOR ERROR MESSAGE @VA08136 03696250
LA RR,ERRWXEND NO RETURN @VA08136 03696500
ERRWXX EQU * WILL RETURN ON RR @VA08136 03696750
LR XR,R1 PLIST POINTERS 03697000
LR XR2,R15 03698000
DMSERR NUM=901,LET=T,MF=(E,ERLIST), *03699000
SUB=(HEX,(R6),CHAR8A,(XR),HEX,(XR),HEX,(BR),DEC,(XR2)), *03700000
TEXT='UNEXPECTED ERROR AT ......: PLIST ''..............*03701000
...............'' AT ......, BASE: ......, RC ........' 03702000
MVI RC,255 03703000
BR RR RETURN OR CONTINUE @VA08136 03703300
ERRWXEND EQU * CONTINUE @VA08136 03703600
USING PHCL,CDR FORCE ADDRESSABILITY @VA05996 03704000
MVI PHCL+1,$@FINI SET CLOSE INPUT FILE @VA05996 03705000
MVI PHCL+2,$@FINO SET CLOSE OUTPUT FILE @VA06125 03706000
MVI PHCL+3,$@EXIT SET BRANCH TO EXIT @VA06125 03707000
DROP CDR FREE THE REGISTER @VA05996 03708000
B NEXT GO TO HANDLE THE ABORT @VA05996 03709000
SPACE 3 03710000
ERACT EQU * 03711000
L XR,PPLIST2 POINT TO PLIST2 03712000
USE PLIST2,XR 03713000
L XR,PPLIST3 POINT TO PLIST3 03714000
USE PLIST3,XR 03715000
LA XR,PNA3 POINT TO FILENAME 03716000
USE ,XR 03717000
DMSERR NUM=30,LET=E,SUB=(CHAR8A,(XR)), @VA12493*03718000
TEXT='FILE ''....................'' ALREADY ACTIVE' 03719000
MVI RC,28 03720000
PHASE EO @VA04736 03721000
SPACE 3 03722000
* XR -> 'INPUT' OR 'OVERLAY' 03723000
ERROR36 EQU * @VA09572 03723150
LA R5,24(R1) POINT TO MODE LETTER @VA09572 03723300
DMSERR TEXT='DISK ''..'' NOT ACCESSED',NUM=69, X03723450
LET=E,SUB=(CHARA,((R5),1)),TYPCALL=SVC @VA09572 03723600
MVI RC,36 GIVE RETCODE @VA09572 03723750
B EXIT @VA09572 03723900
ERNF EQU * 03724000
L XR2,PPLIST2 POINT TO PLIST2 03725000
USE PLIST2,XR2 03726000
LA XR2,PNA2 POINT TO FILENAME 03727000
DMSERR NUM=2,LET=E,MF=(E,ERLIST), *03728000
SUB=(CHARA,(XR),CHAR8A,(XR2)), *03729000
TEXT='........ FILE ''....................'' NOT FOUND' 03730000
MVI RC,28 03731000
B EXIT 03732000
SPACE 3 03733000
ERSPECSX EQU * 03734000
DMSERR NUM=101,LET=S,SUB=(CHARA,(XR2)), *03735000
TEXT='''SPECS'' TEMP STRING STORAGE EXHAUSTED AT ''.....*03736000
...''' 03737000
MVI RC,88 03738000
B EXIT 03739000
SPACE 3 03740000
ERTMI EQU * 03741000
DMSERR NUM=102,LET=S,TEXT='TOO MANY FILEIDS' 03742000
MVI RC,88 RETURN CODE = 88 P1091 03743000
B EXIT 03744000
SPACE 3 03745000
* ILLEGAL ASTERISK IN INPUT FILEID OTHER THAN THE FIRST (MULTIPLE MODE) 03746000
ERMST EQU * 03747000
LA R1,=C'*' POINT TO AN ASTERISK 03748000
SPACE 03749000
* ILLEGAL CHARACTER CAUGHT BY TRT. R1 POINTS TO THE CHAR. 03750000
ERILC EQU * 03751000
USE PLIST1,XR2 03752000
LR XR,R1 POINT TO ILLEGAL CHARACTER 03753000
CLI 0(XR),X'FF' IS THE ILLEGAL CHAR X'FF'? 03754000
BE ERIFI INCOMPLETE FILEID IF SO 03755000
CLI 0(XR),C'(' IS THE ILLEGAL CHAR C'(' 03756000
BE ERIFI INCOMPLETE FILEID IF SO 03757000
DMSERR NUM=62,LET=E,MF=(E,ERLIST), *03758000
SUB=(CHARA,((XR),1),CHAR8A,PNA1), *03759000
TEXT='INVALID CHAR ''..'' IN FILEID ''..................*03760000
..''' 03761000
MVI RC,20 RETURN CODE = 20 P0767 03762000
B EXIT 03763000
SPACE 3 03764000
* FILEID CONTAINS A X'FF' OR C'(' -- INCOMPLETE FILEID SPECIFIED 03765000
ERIFI EQU * 03766000
DMSERR NUM=54,LET=E, @VM03248*03767000
TEXT='INCOMPLETE FILEID SPECIFIED' @VM03248 03768000
MVI RC,24 03769000
B EXIT 03770000
SPACE 3 03771000
* NULL SPECIFICATION LIST ENTERED 03772000
ERNS EQU * 03773000
LA XR2,=CL13'SPECIFICATION' 03774000
B ERNST 03775000
SPACE 03776000
* NULL TRANSLATION LIST ENTERED 03777000
ERNT EQU * 03778000
LA XR2,=CL13'TRANSLATION' 03779000
SPACE 03780000
ERNST EQU * 03781000
DMSERR NUM=63,LET=E,SUB=(CHARA,(XR2)), *03782000
TEXT='NO ............. LIST ENTERED' 03783000
MVI RC,40 RETURN CODE = 40 P1091 03784000
B EXIT 03785000
SPACE 3 03786000
ERTMS EQU * 03787000
DMSERR NUM=103,LET=S, P1091*03788000
TEXT='NUMBER OF SPECS EXCEEDS MAX .....', P1091*03789000
SUB=(DEC,MAXSPECS) 03790000
MVI RC,88 03791000
B EXIT 03792000
SPACE 3 03793000
* ILLEGAL SPECIFICATION 03794000
ERILS EQU * 03795000
LA XR,BLANKS SUBSTITUTE BLANK FIELD 03796000
B ERITS 03797000
SPACE 03798000
* INVALID TRANSLATION SPECIFICATION 03799000
ERTRS EQU * 03800000
LA XR,=C'TRANSLATION' SUBSTITUTE 'TRANSLATION' 03801000
SPACE 03802000
ERITS EQU * 03803000
DMSERR NUM=64,LET=E,MF=(E,ERLIST), *03804000
SUB=(CHARA,(XR),CHARA,(XR2)), *03805000
TEXT='INVALID ........... SPECIFICATION AT OR NEAR ''...*03806000
.....''' 03807000
MVI RC,24 03808000
B EXIT 03809000
SPACE 3 03810000
ERDOP EQU * 03811000
LR R1,R0 GET OPTION CODE 03812000
BAL RR,GETNAME GET OPTION NAME 03813000
LR XR,R1 XR -> OPTION NAME 03814000
DMSERR NUM=65,LET=E,SUB=(CHARA,(XR)), *03815000
TEXT='''........'' OPTION SPECIFIED TWICE' 03816000
MVI RC,24 03817000
B EXIT 03818000
SPACE 3 03819000
ERCONF EQU * 03820000
LR R1,R0 GET OPTION BYTE 03821000
BAL RR,GETNAME GET OPTION NAME 03822000
LR XR,R1 SAVE POINTER TO OPTION NAME 03823000
LR R1,R0 GET SECOND OPTION NAME 03824000
SRL R1,8 03825000
BAL RR,GETNAME GET SECOND OPTION NAME 03826000
LR XR2,R1 SAVE PTR TO 2ND OPTION NAME 03827000
DMSERR NUM=66,LET=E,MF=(E,ERLIST), *03828000
SUB=(CHARA,(XR),CHARA,(XR2)), *03829000
TEXT='''........'' AND ''........'' ARE CONFLICTING OPTI*03830000
ONS' 03831000
MVI RC,24 03832000
B EXIT 03833000
SPACE 3 03834000
* XR2 POINTS TO ILLEGAL SUB-PARAMETER 03835000
ERARG EQU * 03836000
LH R15,NOPS 03837000
SR R1,R1 03838000
IC R1,OPBYTES-1(R15) GET OPTION BYTE FOR LAST OPTION 03839000
BAL RR,GETNAME GET OPTION NAME 03840000
LR XR,R1 POINT TO LAST OPTION NAME 03841000
DMSERR NUM=29,LET=E,MF=(E,ERLIST), *03842000
SUB=(CHARA,(XR2),CHARA,(XR)), *03843000
TEXT='INVALID PARAMETER ''........'' IN THE ''........''*03844000
OPTION FIELD' 03845000
MVI RC,24 03846000
B EXIT 03847000
SPACE 3 03848000
ERUNX EQU * 03849000
LR XR,R15 SAVE PHASE CODE 03850000
DMSERR NUM=903,LET=T,SUB=(HEX,(XR)), *03851000
TEXT='IMPOSSIBLE PHASE CODE ''..''' 03852000
MVI RC,255 03853000
B EXIT 03854000
SPACE 3 03855000
ERGUP EQU * 03856000
DMSERR NUM=67,LET=E, *03857000
TEXT='COMBINED INPUT FILES ILLEGAL WITH PACK OR UNPACK O*03858000
PTIONS' 03859000
MVI RC,24 03860000
B EXIT 03861000
SPACE 3 03862000
ERUPX EQU * 03863000
DMSERR NUM=904,LET=T,SUB=(HEX,(RR),HEX,(BR)),MF=(E,ERLIST), *03864000
TEXT='UNEXPECTED UNPACK ERROR AT ......, BASE ......' 03865000
MVI RC,255 03866000
B EXIT 03867000
SPACE 03868000
ERILP EQU * 03869000
LA XR,RDFNAME POINT TO INPUT FILE NAME 03870000
DMSERR NUM=68,LET=E,SUB=(CHAR8A,(XR)), *03871000
TEXT='INPUT FILE ''....................'' NOT IN PACKED *03872000
FORMAT' 03873000
MVI RC,32 03874000
B EXIT 03875000
SPACE 3 03876000
* 'FROM' NUMBER IS NOT IN FILE. XR -> FST FOR FILE. 03877000
ERNFN EQU * 03878000
USE FSTSECT,XR 03879000
LH XR,FSTIC GET NUMBER OF ITEMS IN FILE 03880000
N XR,=A(X'FFFF') AVOID NEGATIVE RESULT OF LH 03881000
DMSERR NUM=156,LET=E,MF=(E,ERLIST), *03882000
TEXT='''FROM ........'' NOT FOUND -- FILE ''............*03883000
........'' HAS ONLY ''........'' RECORDS', *03884000
SUB=(DECA,FROMN,CHAR8A,RDFNAME,DEC,(XR)) 03885000
MVI RC,32 03886000
B EXIT 03887000
SPACE 3 03888000
* 'FRLABEL' LABEL NOT FOUND 03889000
ERNFL EQU * 03890000
DMSERR NUM=157,LET=E,MF=(E,ERLIST), *03891000
SUB=(CHAR8A,FRL,CHAR8A,RDFNAME), *03892000
TEXT='LABEL ''........'' NOT FOUND IN FILE ''...........*03893000
.........''' 03894000
MVI RC,32 03895000
PHASE EO @VA04736 03896000
SPACE 3 03897000
ERFM EQU * 03898000
USE PLIST1,XR2 03899000
DMSERR NUM=48,LET=E,TEXT='INVALID MODE ''........''', *03900000
SUB=(CHARA,PMO1) 03901000
MVI RC,24 03902000
B EXIT 03903000
SPACE 3 03904000
ERNRO EQU * 03905000
DMSERR NUM=173,LET=E,SUB=(CHAR8A,OUPLIST2+PNA2-PLIST2), *03906000
TEXT='NO RECORDS WERE COPIED TO OUTPUT FILE ''..........*03907000
..........''' 03908000
MVI RC,40 03909000
B EXIT 03910000
SPACE 3 03911000
ERLAE EQU * 03912000
LA XR,=C'EQUALS' 03913000
LA XR2,6 LENGTH OF 'EQUALS' 03914000
B ERLAC 03915000
SPACE 03916000
ERLAS EQU * 03917000
LA XR,=C'IS AN INITIAL SUBSTRING OF' 03918000
LA XR2,26 LENGTH OF 'IS AN INIT... OF' 03919000
SPACE 03920000
ERLAC EQU * 03921000
DMSERR NUM=172,LET=E,MF=(E,ERLIST), *03922000
SUB=(CHARA,TOL,CHARA,((XR),(XR2)),CHARA,FRL), *03923000
TEXT='TOLABEL ''........'' .......................... FR*03924000
LABEL ''........''' 03925000
MVI RC,24 03926000
B EXIT 03927000
* RDBUF/WRBUF RETURN CODE BRANCHES 03928000
RDBYTES DC X'00',8X'04',X'08',2X'04',X'0C',10X'04' 03929000
WRBYTES DC X'00',8X'04',X'08',15X'04' 03930000
* CODE VALUES 03931000
* 00 = NORMAL RETURN 03932000
* 04 = UNEXPECTED RETURN CODE 03933000
* 08 = FILE ALREADY ACTIVE FOR WRITE/READ 03934000
* 0C = EOF FOR RDBUF 03935000
SPACE 3 03936000
BLANKS DC CL20' ' BLANK AREA 03937000
INPUT DC CL8'INPUT' @VA07488 03937100
EJECT 03938000
LTORG 03939000
* FILE STATUS BLOCK 03940000
FSTB 03941000
EJECT 03942000
* ACTIVE DISK TABLE 03943000
ADT 03944000
* CMS NUCLEUS ROUTINES 03945000
NUCON 03946000
AFT @VA08136 03946500
END 03947000