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