ibm:vm370-lib:cms:dmscpy.assemble_src
Table of Contents
DMSCPY Source
References
- Fixes Applied : 11
- This Source Date : Tuesday, December 12, 1978
- Last Fix ID : [R13560DS]
Source Listing
- DMSCPY.ASSEMBLE.txt
- 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
ibm/vm370-lib/cms/dmscpy.assemble_src.txt · Last modified: 2023/08/06 13:35 by Site Administrator