* 00000100
* This program is free software; you can redistribute it and/or modify 00000200
* it under the terms of the GNU General Public License as published by 00000300
* the Free Software Foundation; either version 2 of the License 00000400
* or (at your option) any later version. 00000500
* The license text is available at the following internet addresses: 00000600
* - http://www.bixoft.com/english/gpl.htm 00000700
* - http://fsf.org 00000800
* - http://opensource.org 00000900
* 00001000
* This program is distributed in the hope that it will be useful, 00001100
* but WITHOUT ANY WARRANTY; without even the implied warranty of 00001200
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 00001300
* See the GNU General Public License for more details. 00001400
* 00001500
* You should have received a copy of the GNU General Public License 00001600
* along with this program; if not, write to either of the following: 00001700
* the Free Software Foundation, Inc. B.V. Bixoft 00001800
* 59 Temple Place, Suite 330 Rogge 9 00001900
* Boston, MA 02111-1307 7261 JA Ruurlo 00002000
* United States of America The Netherlands 00002100
* 00002200
* e-mail: [email protected] 00002300
* phone : +31-6-22755401 00002400
* 00002500
BXAIO00 TITLE 'Dynamic module for VSAM I/O handling' 00010000
*********************************************************************** 00020000
* Start create : 20-03-1989 00030000
* 1st delivery : 15-08-1989 00040000
* Designer : AF Kornelis 00050000
* Programmer : AF Kornelis 00060000
* Reason : Untie logical record lay-outs from physical file 00070000
* structure 00080000
*********************************************************************** 00090000
* Change 01 : 22-06-1990 00100000
* Programmer : JB 00110000
* Reason : Add 2 logical record lay-outs: PDD and CSC 00120000
* : Add supporting physical files: PDD and CSC 00130000
*********************************************************************** 00140000
* Change 02 : 31-10-1991 00150000
* Programmer : JB 00160000
* Reason : Add 1 logical record lay-out: CCX 00170000
* : Add supporting physical file: CCX 00180000
*********************************************************************** 00190000
* Change 03 : 31-05-1992 00200000
* Programmer : JB 00210000
* Reason : Add 1 logical record lay-out: ACD 00220000
* : Add supporting physical file: ACD 00230000
*********************************************************************** 00240000
* Change 04 : 31-05-1996 00250000
* Programmer : JB 00260000
* Reason : Add 1 logical record lay-out: SVD 00270000
* : Add supporting physical file: SVD 00280000
* : These changes were never implemented 00290000
*********************************************************************** 00300000
* Change 05 : Summer 2001 00310000
* Programmer : Abe F. Kornelis 00320000
* Reason : Remove warning errors from assembly 00330000
* Improve comments 00340000
*********************************************************************** 00350000
EJECT 00360000
*********************************************************************** 00370000
* 00380000
* When maintaining this program, please mind the following: 00390000
* - Never change any data or coding in the program at run-time. For 00400000
* storing data, always use getmained areas. Otherwise reenterability 00410000
* will be lost. 00420000
* - When suballocating storage areas (whether getmained or not) 00430000
* always allocate on a doubleword boundary. 00440000
* - Remember never to use r12, since it contains information that the 00450000
* PL/I estae/espie-routines need for error/exception handling. 00460000
* - Do not try to call this module recursively: it won't work. 00470000
* - Allocate all variable storage areas from subpool &sp (17). Since 00480000
* applications get their storage from subpool 0, the chances of 00490000
* destructive interference between BXAIO00 and application is 00500000
* minimal. By taking all storage from the same subpool, the 00510000
* chances of page-faults are minimized. 00520000
* - Debugging is controlled by the &DBG global variable: if it 00530000
* contains the value 1 then debugging code will be generated, 00540000
* otherwise debugging code will be skipped. 00550000
* - Optimization (speed and size of load) is controlled by &OPT 00560000
* - The program is reenterable. If it is to become refreshable, remove 00570000
* the crashmem area and have the uaerr error-exit dump in stead of 00580000
* using the crashmem area. 00590000
* 00600000
******* 00610000
* 00620000
* The following subjects still need to be taken care of: 00630000
* - IMS/LST conflicts 00640000
* - Check RPL-status before issuing any vsam-request 00650000
* - temporary modifications are marked by **!! 00660000
* 00670000
*********************************************************************** 00680000
EJECT 00690000
*********************************************************************** 00700000
* 00710000
* The structure of control blocks used in this program is as follows: 00720000
* ________ 00730000
* | | 00740000
* | Caller | 00750000
* | BXAIOxxx ________ 00760000
* |--------| | | 00770000
* |LNSUAPTR|--->|USERAREA| ________ 00780000
* |________| |--------| | | 00790000
* |UAFDBPTR|--->| FDB | 00800000
* |________| |--------| 00810000
* |FDBNEXT |---> next FDB --> next FDB etc 00820000
* |--------| 00830000
* | FDBACB |---> ACB ---> DDNAME ---> FILE 00840000
* LNSUAPTR is a pointer to |--------| 00850000
* the USERAREA, where all | FDBRPL |---> RPL ---> ACB ____ 00860000
* caller-dependent data |--------| _______ | ME | 00870000
* are to be found. | FDBMAP |--->| MME |---------->|----| 00880000
* |________| |-------| ____ | ME | 00890000
* UAFDBPTR is the entry to | MME |-->| ME | |----| 00900000
* the chain of FDBs. Each FDB |-------| |----| | . | 00910000
* contains information pertaining | . | | ME | | . | 00920000
* to one physical dataset. | . | |----| | . | 00930000
* | . | | . | |____| 00940000
* FDBMAP is a pointer to a list of |_______| | . | 00950000
* Map-Master-Elements. Each MME | . | 00960000
* corresponds with one parameter version. |____| 00970000
* Thus, for each dataset there is one and only one 00980000
* MME-list, which is the same for all callers. 00990000
* 01000000
* The MME in turn contains a pointer to a list of Map-Elements. 01010000
* Each Map-Element specifies one block of data that may be 01020000
* moved in one piece between the parameter (BXAIOPRM) and a 01030000
* physical record. 01040000
* 01050000
*********************************************************************** 01060000
EJECT 01070000
*********************************************************************** 01080000
* 01090000
* The program has been split up into the following sections: 01100000
* each section has its own addressability. 01110000
* 01120000
* - PHASE1 - housekeeping 01130000
* - general check of parameter 01140000
* - PHASE2 - evaluation of the requested function code 01150000
* - setup of FDBs to reflect the request 01160000
* - phase2 includes the checkxx routines 01170000
* - PHASE3 - execution of the requests 01180000
* - phase3 includes the rxx routines 01190000
* - PHASE4 - waiting for completion of asynchronous i/o 01200000
* - post-processing 01210000
* - cleanup of resources no longer needed 01220000
* - return to caller 01230000
* - RCHECK - second level routine that waits for vsam-i/o-completion 01240000
* - ERROR - error handling routine 01250000
* - error includes the error exits (for example: vserr) 01260000
* - RSETBASE - lowest-level subroutine, used for returning to a caller 01270000
* which may or may not use a different base address for 01280000
* its addressability. 01290000
* - RSNAP - debugging help routine, linked as a separate subprogram. 01300000
* - rsnap dumps control blocks that are both defined by this 01310000
* program and currently in use. 01320000
* 01330000
*********************************************************************** 01340000
EJECT 01350000
* 01360000
* The assembler program accepts as a JCL-parameter a specification 01370000
* for the variable SYSPARM. The value entered in the JCL will be 01380000
* passed to a global set symbol named &SYSPARM. The value specified 01390000
* in the JCL is passed as a single string. This macro decomposes the 01400000
* string into separate parameters. Then the parameters are checked 01410000
* and handled. 4 different keywords are allowed: 01420000
* - DEBUG : generate debugging code (rsnap routine, etc.) 01430000
* - NODEBUG : do not generate debugging code 01440000
* - OPT : generate a fully optimized program 01450000
* - NOOPT : generate a program with complete error checking 01460000
* 01470000
MACRO 01480000
CHECKPRM 01490000
* 01500000
GBLB &DBG,&OPT 01510000
&DBG SETB 0 * Default: no debug coding 01520000
&OPT SETB 1 * Default: full optimization 01530000
AIF ('.&SYSPARM' EQ '.').EXIT 01540000
* 01550000
* First the SYSPARM string is to be split into substrings 01560000
* 01570000
LCLC &P(5) * Array to contain parms 01580000
LCLA &I,&N,&X 01590000
&I SETA 0 * Character indec for &SYSPARM 01600000
&N SETA 1 * Next position to extract 01610000
&X SETA 1 * Parameter counter (array &P) 01620000
.LOOP1 ANOP 01630000
&I SETA &I+1 * Increment character index 01640000
AIF (&I GT K'&SYSPARM).LOOP1X * End-of-string ?? 01650000
AIF ('&SYSPARM'(&I,1) NE ',').LOOP1 * End-of-substring ?? 01660000
&P(&X) SETC '&SYSPARM'(&N,&I-&N) * Extract substring 01670000
&N SETA &I+1 * Set ptr to start of substring 01680000
&X SETA &X+1 * Increment substring counter 01690000
AGO .LOOP1 * and go check next character 01700000
* 01710000
.LOOP1X ANOP 01720000
&P(&X) SETC '&SYSPARM'(&N,&I-1) * Extract last substring 01730000
* 01740000
* Now check that keywords are valid 01750000
* * &X now is count of parms 01760000
&I SETA 0 * Index into array P 01770000
.LOOP2 ANOP 01780000
&I SETA &I+1 * Increment parm index 01790000
AIF (&I GT &X).LOOP2X * All parms checked ?? 01800000
AIF ('.&P(&I)' EQ '.').LOOP2 * Skip empty parm 01810000
AIF ('.&P(&I)' EQ '.OPT').OPT 01820000
AIF ('.&P(&I)' EQ '.NOOPT').NOOPT 01830000
AIF ('.&P(&I)' EQ '.DEBUG').DEBUG 01840000
AIF ('.&P(&I)' EQ '.NODEBUG').NODEBUG 01850000
MNOTE 4,'Invalid SYSPARM operand: &P(&I)' 01860000
AGO .LOOP2 * and go try next parm 01870000
* 01880000
.OPT ANOP 01890000
&OPT SETB 1 01900000
MNOTE 0,'Optimized coding will be generated' 01910000
AGO .LOOP2 01920000
* 01930000
.NOOPT ANOP 01940000
&OPT SETB 0 01950000
MNOTE 0,'Fault tolerant coding will be generated' 01960000
AGO .LOOP2 01970000
* 01980000
.DEBUG ANOP 01990000
&DBG SETB 1 02000000
MNOTE 0,'Debugging code will be included' 02010000
AGO .LOOP2 02020000
* 02030000
.NODEBUG ANOP 02040000
&DBG SETB 0 02050000
MNOTE 0,'Debugging code will be excluded' 02060000
AGO .LOOP2 02070000
* 02080000
.LOOP2X ANOP 02090000
.EXIT ANOP 02100000
* 02110000
MEND 02120000
* 02130000
EJECT 02140000
* 02150000
* The RSNAP-routine, which is available in debug mode only, may return 02160000
* an error code. If an error code is received, then the error handler 02170000
* should be invoked before continuing. Thus the error will be issued 02180000
* as it should. 02190000
* In order not to have to code the whole protocol for each call to 02200000
* the snap routine an extended snap macro (ESNAP) has been provided. 02210000
* This macro will generate a call to the RSNAP-routine with full 02220000
* error handling. 02230000
* 02240000
MACRO 02250000
ESNAP 02260000
* 02270000
GBLB &DBG,&ERR 02280000
AIF (NOT &DBG).ESNAP 02290000
* 02300000
L R15,=AL4(RSNAP) * Retrieve entry-point of RSNAP 02310000
BASR R14,R15 * Call the RSNAP-routine 02320000
LTR R15,R15 * Error in RSNAP ?? 02330000
AIF (&ERR).ESNAPER 02340000
BE *+14 * No: skip error handling 02350000
OI UASTAT,UASNAPER * Indicate snap is in error 02360000
L R3,=AL4(ERROR) * Load address of error handler 02370000
BASR R14,R3 * Issue error, then return here 02380000
* 02390000
MEXIT , * Macro complete 02400000
* 02410000
.ESNAPER ANOP , * Snap error in error-handler 02420000
BE *+16 * No: skip error handling 02430000
OI UASTAT,UASNAPER * Indicate snap is in error 02440000
L R14,UAERRSAV * Reload original return address 02450000
B ERROR * Restart error handler 02460000
* 02470000
.ESNAP ANOP 02480000
MEND 02490000
* 02500000
EJECT 02510000
PRINT NOGEN 02520000
* 02530000
* Register equates 02540000
* 02550000
R0 EQU 0 * Work register 02560000
R1 EQU 1 * Work register 02570000
R2 EQU 2 * Work register 02580000
R3 EQU 3 * Base register 02590000
R4 EQU 4 * Pointer to parameter area 02600000
R5 EQU 5 * Pointer to current FDB 02610000
R6 EQU 6 * 02620000
R7 EQU 7 * 02630000
R8 EQU 8 * 02640000
R9 EQU 9 * 02650000
R10 EQU 10 * 02660000
R11 EQU 11 * Data-area ptr (constants etc.) 02670000
R12 EQU 12 * Reserved for pli-environment 02680000
R13 EQU 13 * USERAREA pointer (see note) 02690000
R14 EQU 14 * Return address 02700000
R15 EQU 15 * Entry point addr / return code 02710000
* 02720000
* Note: Since the save-area is placed first in the user-data area 02730000
* R13 is a pointer to both of these areas. 02740000
* 02750000
SPACE 3 02760000
* 02770000
* The global &DBG controls debug/nodebug assembling options 02780000
* - when &dbg = 1 then debugging is active. 02790000
* The global &opt controls optimization. 02800000
* - when &opt = 1 then full optimization takes place. 02810000
* - when &opt = 0 then full fault tolerance will be generated. 02820000
* 02830000
GBLB &DBG,&OPT 02840000
* Check &SYSPARM to set &DBG and &OPT 02850000
CHECKPRM 02860000
* 02870000
GBLB &ERR 02880000
&ERR SETB 0 * Not assembling error-routine 02890000
* 02900000
SPACE 3 02910000
* 02920000
GBLA &NOOFFDB,&AANTFIL,&MAXKEY,&SP 02930000
&NOOFFDB SETA 8 * Nr of fdbs to be allocated 02940000
&AANTFIL SETA 6 * Max. nr of files 02950000
&MAXKEY SETA 15 * Length of longest key 02960000
&SP SETA 17 * Subpoolnr for storage requests 02970000
* The number 17 was chosen arbitrarily. 02980000
* Any number between 1 and 127 will do. 02990000
* 03000000
SPACE 3 03010000
* 03020000
* To keep the code reentrant, it is required that we have a workarea 03030000
* where code (to be modified) can be copied, before it is changed. 03040000
* Here we set up a global variable that contains the length we need. 03050000
* Whenever anything is moved into the workarea (uaworkar) make sure 03060000
* that it does not extend beyond the allocated area. If more room is 03070000
* needed for a workarea, increase the &WORKLV variable. If the &WORKLV 03080000
* is changed, always change it to a multiple of 8. Thus correct 03090000
* alignment is ensured for the data fields following the workarea. 03100000
* 03110000
GBLA &WORKLV * Var to contain required length 03120000
&WORKLV SETA 160 * Greatest length we expect 03130000
* 03140000
SPACE 3 03150000
* 03160000
GBLC &PRT * Controls print option 03170000
&PRT SETC 'NOGEN' * Nogen is default 03180000
AIF (NOT &DBG).NOGEN * When debugging then 03190000
&PRT SETC 'GEN' * generate full listing 03200000
.NOGEN ANOP 03210000
PRINT &PRT * Set print option 03220000
* 03230000
EJECT 03240000
* 03250000
* Setup save area, and establish addressability. For a save-area 03260000
* storage must be obtained from the system. The address of this 03270000
* private save-area is saved for subsequent calls. 03280000
* 03290000
BXAIO00 CSECT 03300000
BXAIO00 AMODE 31 * 31-bit addressing 03310000
BXAIO00 RMODE 24 * Residency below 16m 03320000
* 03330000
PHASE1 EQU * 03340000
USING BXAIO00,R15 * R15 assumed base 03350000
B BXAIO000 * Branch around text 03360000
DC AL1(23),CL23'BXAIO00 &SYSDATE &SYSTIME' 03370000
CONSTADR DC AL4(CONST) * Address of data-area 03380000
BXAIO000 STM R14,R12,SAVEDR14(R13) * Save regs of calling module 03390000
LR R3,R15 * Pick up base register 03400000
DROP R15 * Switch from temporary 03410000
USING PHASE1,R3 * to permanent base register 03420000
* 03430000
L R11,CONSTADR * Get address of data-area 03440000
USING CONST,R11 * and establish addressability 03450000
* 03460000
XR R6,R6 * Provide for hex-zeroes 03470000
* 03480000
* Obtain address of parameter from caller. If invalid, issue error. 03490000
* 03500000
AIF (&OPT).GOTPARM 03510000
LTR R1,R1 * Is a plist given ?? 03520000
BNE GOTPARM * Yes, skip error 03530000
NOPARM LA R15,026 * Indicate error number 03540000
L R14,=AL4(EXIT) * Let error return to exit 03550000
L R3,=AL4(ERROR) * Get address of error handler 03560000
BR R3 * Execute it, then exit 03570000
* 03580000
GOTPARM TM 4(R1),X'80' * Is the 2nd word the last one ? 03590000
BNO NOPARM * No: argument(s) invalid 03600000
.GOTPARM L R4,0(R1) * Get 1st plist element 03610000
AIF (&OPT).GOTPRM2 03620000
LA R4,0(R4) * Nullify leading bits 03630000
LTR R4,R4 * Is it valid ?? 03640000
BZ NOPARM * No: go issue error 03650000
.GOTPRM2 ANOP 03660000
USING DS83PARM,R4 * Use R4 to address parm area 03670000
USING DSFDB,R5 * Use R5 to address current FDB 03680000
* 03690000
L R2,4(R1) * Load address of second parm 03700000
LA R2,0(R2) * Remove end-of-plist marker 03710000
AIF (&OPT).FASE110 03720000
LTR R2,R2 * Is it valid ?? 03730000
BZ NOPARM * No: go issue error 03740000
* 03750000
.FASE110 USING DS83PRM2,R2 * Use R2 to address parm 2 03760000
L R1,LNSUAPTR * Get address of USERAREA 03770000
LTR R1,R1 * Is address valid ?? 03780000
BNZ GOTM * If not allocated: get storage 03790000
* 03800000
SPACE 3 03810000
* 03820000
* Since the private save-area-pointer is invalid, this must be the 03830000
* first call. Therefore storage is to be obtained for the USERAREA 03840000
* (including the new save-area). Storage for run-time FDBs is 03850000
* obtained at the same time. 03860000
* 03870000
GETM GETMAIN RC, * Conditional request (register)*03880000
SP=&SP, * from our private subpool *03890000
LV=L'USERAREA * for allocating the USERAREA 03900000
LTR R15,R15 * Storage allocated ?? 03910000
BZ GETMOK * Yes: skip error 03920000
LA R15,069 * Load error code 03930000
L R14,=AL4(EXIT) * Let error return to EXIT 03940000
L R3,=AL4(ERROR) * Get address of error handler 03950000
BR R3 * Execute it, then goto exit 03960000
* 03970000
GETMOK EQU * 03980000
ST R1,LNSUAPTR * Save area address 03990000
* 04000000
SPACE 3 04010000
* 04020000
* R1 now points to our private save-area. 04030000
* 04040000
GOTM EQU * 04050000
ST R13,SAVEPREV(R1) * Set backward pointer 04060000
C R6,SAVEPLI(R13) * PLI uses 1st word of savearea 04070000
BNE ENVIRPLI * For PLI env.: no forward ptr 04080000
ST R1,SAVENEXT(R13) * Set forward ptr (non-PLI env.) 04090000
ENVIRPLI LR R13,R1 * Point to new savearea 04100000
USING DSUSERAR,R13 * Address USERAREA & savearea 04110000
* 04120000
* In the UAERR routine R11 is used to determine whether R13 points to 04130000
* our own USERAREA or somewhere different. Therefore R11 is to be saved 04140000
* in its proper place. Thus this USERAREA will be recognizable. 04150000
* 04160000
ST R11,SAVEDR11(R13) * Mark this save-area as our own 04170000
* 04180000
* Copy data we will need from parm 2 to the USERAREA 04190000
* 04200000
LCLC &LM * Length modifier 04210000
&LM SETC 'L''UASELECT' * Default: full length 04220000
AIF (NOT &OPT).FASE120 * When optimizing: 04230000
&LM SETC '&AANTFIL' * copy only the needed bytes 04240000
.FASE120 MVC UASELECT(&LM),LNSFILES * Logical data-group selectors 04250000
MVC UAVERSI,LNSVERSI * Parameter 1 version nr 04260000
DROP R2 * End addressability to ds83prm2 04270000
* 04280000
SPACE 3 04290000
* 04300000
* Increment call-count and initialize return- and reasoncode to zero 04310000
* 04320000
AIF (&OPT AND (NOT &DBG)).FASE130 04330000
L R1,UACALLNR * Retrieve call-count 04340000
LA R1,1(R1) * Increment call-count by one 04350000
ST R1,UACALLNR * Store call-count in USERAREA 04360000
.FASE130 MVI UARETCD,C'0' * Set returncode 04370000
STH R6,UAREASN * Set reasoncode to H'0' 04380000
MVC UAKEY,LNSKEY * Copy key from parm 04390000
* 04400000
SPACE 3 04410000
* 04420000
* Check select/deselect codes for each logical file section 04430000
* 04440000
AIF (&OPT).FASE140 04450000
LA R7,UASELECT * First byte to be checked 04460000
LA R8,1 * Increment value for loop 04470000
LA R9,UASELECT+L'UASELECT-1 * Last byte to be checked 04480000
LOOP0 CLI 0(R7),C'0' * Valid deselect code ?? 04490000
BE LOOP0NX * Yes: check next selector 04500000
CLI 0(R7),C'1' * Valid select code ?? 04510000
BE LOOP0NX * Yes: check next selector 04520000
LA R15,003 * Load error message nr 04530000
L R3,=AL4(ERROR) * Get address of error handler 04540000
BASR R14,R3 * Execute it, then continue 04550000
MVI 0(R7),C'0' * Default to deselect section 04560000
LOOP0NX BXLE R7,R8,LOOP0 * Loop to try next selector 04570000
* 04580000
.FASE140 ANOP 04590000
* 04600000
* First we must map the individual requests for logical file sections 04610000
* (UASELECT) onto physical file requests (UAFILES). 04620000
* Mapping is now 1 to 1, but this may be changed in future. 04630000
* The bytes of UAFILES must always correspond 1 to 1 with the 04640000
* FDBNR field of each FDB in the FDB-chain. If two files are always 04650000
* to be treated identically then they should be given the same value 04660000
* for their FDBNR-fields. 04670000
* 04680000
AIF (NOT &OPT).MAPPIN0 04690000
MVC UAFILES(&LM),UASCCDI * Copy options (XLATE = 1 to 1) 04700000
AGO .MAPPINX 04710000
* 04720000
.MAPPIN0 ANOP 04730000
MAPPING0 MVC UAFILES(&LM),=&NOOFFDB.C'0' * Prefill with zeroes 04740000
CLI UASCCDI,C'1' * 1st logical section requested? 04750000
BNE MAPPING1 * No 04760000
MVI UAFILES+0,C'1' * Map section 1 to FDBNR 0 04770000
* 04780000
MAPPING1 CLI UASCPDI,C'1' * 2nd logical section requested? 04790000
BNE MAPPING2 * No 04800000
MVI UAFILES+1,C'1' * Map section 2 to FDBNR 1 04810000
* 04820000
MAPPING2 CLI UASCCXI,C'1' * 3rd logical section requested? 04830000
BNE MAPPING3 * No 04840000
MVI UAFILES+2,C'1' * Map section 3 to FDBNR 2 04850000
* 04860000
MAPPING3 CLI UASPDDI,C'1' * 4th logical section requested? 04870000
BNE MAPPING4 * No 04880000
MVI UAFILES+3,C'1' * Map section 4 to FDBNR 3 04890000
* 04900000
MAPPING4 CLI UASCSCI,C'1' * 5th logical section requested? 04910000
BNE MAPPING5 * No 04920000
MVI UAFILES+4,C'1' * Map section 5 to FDBNR 4 04930000
* 04940000
MAPPING5 CLI UASACDI,C'1' * 6th logical section requested? 04950000
BNE MAPPING9 * No 04960000
MVI UAFILES+5,C'1' * Map section 6 to FDBNR 5 04970000
* 04980000
MAPPING9 EQU * 04990000
AIF (&OPT).MAPPINX 05000000
CLC UAFILES,=&NOOFFDB.C'0' * Still all zeroes ?? 05010000
BNE MAPPINGX * No: carry on 05020000
LA R15,004 * Load error number 05030000
L R14,=AL4(EXIT) * Get return address for error 05040000
L R3,=AL4(ERROR) * Get address of error handler 05050000
BR R3 * Execute it, then goto exit 05060000
* 05070000
.MAPPINX ANOP 05080000
* 05090000
MAPPINGX EQU * 05100000
* 05110000
SPACE 3 05120000
* 05130000
* Phase 1 of the program is now done. Change base register for phase 2 05140000
* 05150000
L R3,=AL4(PHASE2) * Load address of next phase 05160000
AIF (&OPT).FASE1ND 05170000
BR R3 * And go execute it 05180000
* 05190000
.FASE1ND DROP R3 * End of phase 1 05200000
FASE1END EQU * 05210000
* 05220000
EJECT 05230000
USING PHASE2,R3 05240000
PHASE2 EQU * 05250000
* 05260000
* Now the mapping from logical data groups in the parameter onto 05270000
* physical VSAM files has taken place, the function code in the 05280000
* parameter is to be translated into request bits in the FDBREQ field 05290000
* of each file concerned. This is done by checking the function code 05300000
* against a table of supported function codes. The table also contains 05310000
* for each supported function code the address of a checking routine. 05320000
* 05330000
* Now run-time FDBs have been set up. Before we can set them according 05340000
* to the current request we must look up the requested function code in 05350000
* the table of supported opcodes. 05360000
* 05370000
L R7,=AL4(OPCODES) * Starting address of table 05380000
LA R8,L'OPC * Length of each element 05390000
L R9,=AL4(OPCODEND) * Ending address of table 05400000
USING DSOPC,R7 * Address table by DSECT 05410000
LOOP1 CLC LNSFCODE,OPCFCOD * Is it this element ?? 05420000
BE LOOP1EX * Yes: terminate inner loop 05430000
BXLE R7,R8,LOOP1 * Try next element 05440000
* * No valid function-code found 05450000
B LOOP250 * Skip to exit handling for err 05460000
LOOP1EX EQU * * Seek opcode is now done 05470000
ST R7,UAOPCADR * Save address in userarea 05480000
* 05490000
AIF (&OPT).LOOPA 05500000
* 05510000
* FDBs are to be generated on first call 05520000
* 05530000
CLC UAFDBPTR,=F'0' * FDBs allocated ?? 05540000
BE LOOPA * No: go force allocation 05550000
.LOOPA ANOP 05560000
* 05570000
TM OPCMASK,FDBOPEN * Is this an open-request ?? 05580000
BNO LOOP2INI * No: go initiate loop 2 05590000
* 05600000
* An open request is to be processed. Allocate run-time FDBs 05610000
* from the defaults chain when necessary. 05620000
* 05630000
LOOPA LA R5,=AL4(CCDFDB) * Point to root of default FDBs 05640000
LOOPA1 L R5,FDBNEXT * Get next default FDB 05650000
LTR R5,R5 * Is it valid ?? 05660000
BZ LOOP2INI * No: we're done 05670000
AIF (NOT &OPT).LOOPA1 05680000
* 05690000
* Optimized version is to check whether the FDB is to be opened. 05700000
* If not, then it should not be allocated. In test version 05710000
* however, all FDBs are to be allocated, or no errors will be 05720000
* generated for calls against unopened files. 05730000
* 05740000
XR R1,R1 * Clear register 05750000
IC R1,FDBNR * to contain FDB-group-number 05760000
LA R6,UAFILES(R1) * Get addr of file group switch 05770000
CLI 0(R6),C'1' * Switch is on ?? 05780000
BNE LOOPA1 * No: try next default FDB 05790000
.LOOPA1 ANOP 05800000
* 05810000
* This FDB is to be activated. If no runtime-fdb exists, then a 05820000
* new one will have to be allocated. 05830000
* 05840000
AIF (&OPT).LOOPA2 05850000
L R10,=AL4(SEEKSPC) * Get address of seekspace table 05860000
LA R6,FDBDDNAM * Point DDNAME in default FDB 05870000
TRT FDBDDNAM,0(R10) * Find addr of first blank 05880000
BNZ LOOPA105 * If no spaces, use full length 05890000
LA R1,L'FDBDDNAM(R6) * Point beyond DDNAME 05900000
LOOPA105 SR R1,R6 * Used length of DDNAME 05910000
BCTR R1,R0 * Decrement count by one for CLC 05920000
* 05930000
.LOOPA2 LA R9,UAFDBPTR * Point to root of FDBs 05940000
LOOPA2 L R10,0(R9) =FDBNEXT * Point to next FDB 05950000
LTR R10,R10 * Is it valid ?? 05960000
BZ LOOPA2EX * No: exit 05970000
LR R9,R10 * Copy address of next FDB 05980000
AIF (&OPT).LOOPA21 05990000
EX R1,LOOPACLC * Compare DDNAMEs 06000000
AGO .LOOPA22 06010000
* 06020000
.LOOPA21 CLC FDBDDLOC(3,R9),FDBDDNAM * DDNAME base is three chars 06030000
.LOOPA22 BNE LOOPA2 * Not =: try next default FDB 06040000
B LOOPA1 * Equal: dont allocate a new FDB 06050000
* 06060000
LOOPA2EX EQU * * Allocate new FDB 06070000
GETMAIN RC, * Conditional storage request *06080000
SP=&SP, * from our own subpool *06090000
LV=L'FDB * for allocating an FDB 06100000
LTR R15,R15 * Storage allocated ?? 06110000
BZ LOOPA120 * Yes: add it to the chain 06120000
LA R15,069 * Set error code 06130000
L R14,=AL4(EXIT) * Get return addr for error rout 06140000
L R3,=AL4(ERROR) * Get address of error handler 06150000
BR R3 * And execute it 06160000
* 06170000
LOOPA120 MVC 0(L'FDB,R1),FDB * Copy default FDB to new area 06180000
MVC 0(4,R1),0(R9) = FDBNEXT * Copy next-ptr from prev FDB 06190000
ST R1,0(R9) = FDBNEXT * Let prev FDB point to new one 06200000
AIF (&OPT).LOOP2IN 06210000
B LOOPA1 * Check remaining default FDBs 06220000
* 06230000
LOOPACLC CLC FDBDDLOC(0,R9),FDBDDNAM * Compare DDNAME with default 06240000
* 06250000
SPACE 3 06260000
.LOOP2IN ANOP 06270000
* 06280000
* Now that we have the opcode-element to be used we must loop 06290000
* through all run-time FDBs. Use their FDBNR-value as an index 06300000
* in UAFILES to determine whether this file is to be processed for 06310000
* the current request. If it is to be processed, set the FDBREQ-bits 06320000
* to indicate the actions phase 3 is to take. 06330000
* 06340000
LOOP2INI LA R5,UAFDBPTR * Point to entry of FDB-chain 06350000
LOOP2 L R5,FDBNEXT * Make next FDB the current one 06360000
LTR R5,R5 * Does it point to nowhere ?? 06370000
BZ LOOP2EX * If no next FDB, then exit loop 06380000
MVI FDBREQ,FDBNOREQ * Reset all request bits 06390000
MVI FDBRETCD,X'00' * Reset returncode to zero 06400000
XR R1,R1 * Clear register 06410000
STH R1,FDBREASN * Reset reasoncode for this FDB 06420000
IC R1,FDBNR * Load relative file nr to use 06430000
LA R6,UAFILES(R1) * Point to file switch 06440000
CLI 0(R6),C'1' * Indicator in parm = 1 ?? 06450000
BNE LOOP2 * No: go try next one 06460000
* 06470000
* Set the request bits associated with this opcode. If a checking 06480000
* routine is specified for the opcode, execute it. 06490000
* 06500000
OC FDBREQ,OPCMASK * Set request bits 06510000
LOOP250 L R8,OPCROUT * Get exit routine address 06520000
AIF (&OPT).LOOP210 06530000
LTR R8,R8 * Check on zero 06540000
BZ LOOP2 * If zero, skip execution 06550000
.LOOP210 BASR R14,R8 * Go execute exit routine 06560000
L R7,UAOPCADR * Reload opcode-element address 06570000
B LOOP2 * And go try next FDB 06580000
* 06590000
LOOP2EX EQU * 06600000
* 06610000
SPACE 3 06620000
* 06630000
* Phase 2 is now done. Go proceed to phase 3. 06640000
* 06650000
L R3,=AL4(PHASE3) * Get entry point of next phase 06660000
BR R3 * And go execute it 06670000
* 06680000
EJECT 06690000
* 06700000
* Checking routines to evalute the validity of the request 06710000
* first are listed the check-routines that combine requests 06720000
* explicitly. These execute the elementary checks that are listed 06730000
* thereafter. The elementary requests may in turn invoke other 06740000
* elementary request checking routines for implicit open requests. 06750000
* 06760000
SPACE 3 06770000
* 06780000
* CHECKSN: request to skip, then to read sequential. The request may 06790000
* imply open input as well. The open request will be forced by the 06800000
* execution of the checksk routine. 06810000
* 06820000
CHECKSN EQU * 06830000
ST R14,UALV1SAV * Save return address 06840000
BAS R14,CHECKSK * Execute check-rout for skip 06850000
L R14,UALV1SAV * Retrieve return address 06860000
B CHECKRS * Execute check-rout for read 06870000
* * which returns to R14 06880000
* 06890000
SPACE 3 06900000
AIF (NOT &DBG).CHECKWN * Allow WN in test mode only 06910000
* 06920000
* CHECKWN: request to write, then to read either sequential or random. 06930000
* Depending on the random/sequential status different elementary 06940000
* check-routines will be executed. If the file is not open, it does not 06950000
* matter which write-checker is executed: both will generate an abend. 06960000
* 06970000
CHECKWN EQU * * Temporarily not supported 06980000
ST R14,UALV1SAV * Save return address 06990000
TM FDBSTAT,FDBACRND * Access is currently random ?? 07000000
BO CHECKWNR * Yes: use random check-routines 07010000
BAS R14,CHECKWS * Execute check-rout for skip 07020000
L R14,UALV1SAV * Retrieve return address 07030000
B CHECKRS * Execute check-rout for read 07040000
* * which returns to R14 07050000
* 07060000
* For a random WN-operation we must juggle the key values, otherwise 07070000
* either the write will detect a key mismatch or the read will read 07080000
* the record just written. 07090000
* 07100000
CHECKWNR EQU * 07110000
XR R7,R7 * Clear register 07120000
IC R7,FDBKEYLV * to contain key length 07130000
LA R8,LNSKEY(R7) * Load address of data area 07140000
BCTR R7,R0 * Decrement length by 1 for MVCs 07150000
EX R7,CHECKMV1 * Save key for read operation 07160000
EX R7,CHECKMV2 * Copy key of current record 07170000
BAS R14,CHECKWR * Execute check-rout for write 07180000
* 07190000
* Reset key in parameter to reflect the value to be used for reading 07200000
* 07210000
XR R7,R7 * Clear register 07220000
IC R7,FDBKEYLV * to contain key length 07230000
BCTR R7,R0 * Decrement length by 1 for MVC 07240000
EX R7,CHECKMV3 * Reset key for read operation 07250000
BAS R14,CHECKRR * Execute check-rout for read 07260000
* 07270000
* Before exiting the key of the parm must be set to match the one in 07280000
* the record because the write will be executed first. 07290000
* 07300000
XR R7,R7 * Clear register 07310000
IC R7,FDBKEYLV * to contain key length 07320000
LA R8,LNSKEY(R7) * Load address of data area 07330000
BCTR R7,R0 * Decrement length by 1 for MVC 07340000
EX R7,CHECKMV2 * Copy key of current record 07350000
L R14,UALV1SAV * Retrieve return address 07360000
BR R14 * Return to mainline of phase2 07370000
* 07380000
.CHECKWN ANOP 07390000
* 07400000
SPACE 3 07410000
AIF (NOT &DBG).CHECKDN * Allow DN in test mode only 07420000
* 07430000
* CHECKDN: request to delete, then to read either sequential or random. 07440000
* Depending on the random/sequential status different elementary 07450000
* check-routines will be executed. If the file is not open, the 07460000
* delete-checker will generate an abend. 07470000
* 07480000
CHECKDN EQU * * Temporarily not supported 07490000
ST R14,UALV1SAV * Save return address 07500000
TM FDBSTAT,FDBACRND * Access is currently random ?? 07510000
BO CHECKDNR * Yes: use random check-routines 07520000
BAS R14,CHECKDR * Execute check-rout for delete 07530000
L R14,UALV1SAV * Retrieve return address 07540000
B CHECKRS * Execute check-rout for read 07550000
* * which returns to R14 07560000
* 07570000
* For a random DN-operation we must juggle the key values, otherwise 07580000
* either the delete will detect a key mismatch or the read will find 07590000
* a deleted record. 07600000
* 07610000
CHECKDNR EQU * 07620000
XR R7,R7 * Clear register 07630000
IC R7,FDBKEYLV * to contain key length 07640000
LA R8,LNSKEY(R7) * Load address of data area 07650000
BCTR R7,R0 * Decrement length by 1 for MVCs 07660000
EX R7,CHECKMV1 * Save key for read operation 07670000
EX R7,CHECKMV2 * Copy key of current record 07680000
BAS R14,CHECKDR * Execute check-rout for delete 07690000
* 07700000
* Reset key in parameter to reflect the value to be used for reading 07710000
* 07720000
XR R7,R7 * Clear register 07730000
IC R7,FDBKEYLV * to contain key length 07740000
BCTR R7,R0 * Decrement length by 1 for MVC 07750000
EX R7,CHECKMV3 * Reset key for read operation 07760000
BAS R14,CHECKRR * Execute check-rout for read 07770000
* 07780000
* Before exiting the key of the parm must be set to match the one in 07790000
* the record because the delete will be executed first. 07800000
* 07810000
XR R7,R7 * Clear register 07820000
IC R7,FDBKEYLV * to contain key length 07830000
LA R8,LNSKEY(R7) * Load address of data area 07840000
--> --------------------
--> maximum size reached
--> --------------------
¤ Dauer der Verarbeitung: 0.58 Sekunden
(vorverarbeitet)
¤
|
Haftungshinweis
Die Informationen auf dieser Webseite wurden
nach bestem Wissen sorgfältig zusammengestellt. Es wird jedoch weder Vollständigkeit, noch Richtigkeit,
noch Qualität der bereit gestellten Informationen zugesichert.
Bemerkung:
Die farbliche Syntaxdarstellung ist noch experimentell.
|
