© Copyright B.V. Bixoft 1989-2003. All rights reserved.
This software is free; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by the Free
Software Foundation; either
version 2 of the License,
or (at your option) any later version.
More information is available from
the Free Software Foundation or
the Open Source Initiative.
This software is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details.
You should have received a copy of the GNU General Public License along with this software; if not, write to either of the following:
|
the Free Software Foundation, Inc. 59 Temple Place, Suite 330 Boston, MA 02111-1307 United States of America |
B.V. Bixoft Rogge 9 7261 JA Ruurlo The Netherlands |
|
email: bixoft@bixoft.nl phone: +31-6-22755401 |
Remark:
This software - and more programs and macros - are available in a format more
suitable for uploading to your mainframe. Please e-mail
B.V. Bixoft with your request
and you will receive a zipped IEBUPDTE job with the program sources.
* 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: bixoft@bixoft.nl 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
BCTR R7,R0 * Decrement length by 1 for MVC 07850000
EX R7,CHECKMV2 * Copy key of current record 07860000
L R14,UALV1SAV * Retrieve return address 07870000
BR R14 * Return to mainline of phase2 07880000
* 07890000
.CHECKDN ANOP 07900000
* 07910000
SPACE 3 07920000
* 07930000
* CHECKOI: to open the file for input, it must be currently closed. 07940000
* If it is open, then a warning is issued. In the process of 07950000
* opening a read of the version control record is to be enforced. 07960000
* The required FDBREQ-bits are set, but the key must be set to zeroes. 07970000
* 07980000
CHECKOI EQU * * Open input request 07990000
TM FDBSTAT,FDBINPUT * Is the file open ?? 08000000
BNO CHECKOX * No: set key for version record 08010000
NI FDBREQ,FDBNOOI * Reset open input request bit 08020000
TM FDBSTAT,FDBUPDAT * Is the file open for update ?? 08030000
BNO CHECKOI2 * No: go issue warning 08040000
LA R15,019 * Load error nr 08050000
L R3,=AL4(ERROR) * Get address of error handler 08060000
BR R3 * Execute it, return to caller 08070000
* 08080000
CHECKOI2 LA R15,005 * Load error nr 08090000
L R3,=AL4(ERROR) * Get address of error handler 08100000
BR R3 * Execute it, return to caller 08110000
* 08120000
SPACE 3 08130000
* 08140000
* CHECKOU: to open the file for update, it must be currently closed. 08150000
* If it is open, then a warning is issued. This routine is executed 08160000
* only for explicit open-update requests. 08170000
* 08180000
CHECKOU EQU * * Open update request 08190000
TM FDBSTAT,FDBINPUT * Is the file open ?? 08200000
BNO CHECKOX * No: set key for version record 08210000
NI FDBREQ,FDBNOOU * Reset open update request bits 08220000
TM FDBSTAT,FDBUPDAT * Is the file open for update ?? 08230000
BO CHECKOU8 * Yes: go issue warning 08240000
LA R15,030 * Load error nr 08250000
L R3,=AL4(ERROR) * Get address of error handler 08260000
BR R3 * Execute it, return to caller 08270000
* 08280000
CHECKOU8 LA R15,005 * Load error nr 08290000
L R3,=AL4(ERROR) * Get address of error handler 08300000
BR R3 * Execute it, return to caller 08310000
* 08320000
SPACE 3 08330000
* 08340000
* CHECKOX routine contains coding for both open-checking routines. 08350000
* 08360000
CHECKOX MVC UAKEY,FDBLKEY * Copy key of version record 08370000
XC UALRECAD,UALRECAD * Set compare record addr to 0 08380000
XC UALRECLV,UALRECLV * Set compare record length to 0 08390000
CLI UAKEY,X'FF' * First byte of version key ok?? 08400000
BNE CHECKOX3 * Yes: continue 08410000
NI FDBREQ,FDBNORX * Reset read request 08420000
MVC UAKEY,=&MAXKEY.C'0' * And reset start-key to zeroes 08430000
* 08440000
CHECKOX3 EQU * 08450000
TM FDBREQ,FDBOPRND * Open is random ?? 08460000
BO CHECKOX5 * Yes: go read if necessary 08470000
TM FDBREQ,FDBREAD * Read required ?? 08480000
BO CHECKSN * Yes: execute skip-read checker 08490000
B CHECKSK * No: execute skip-checker 08500000
* 08510000
CHECKOX5 TM FDBREQ,FDBREAD * Read required ?? 08520000
BO CHECKRR * Y: execute read random checker 08530000
BR R14 * No: accept open request 08540000
* 08550000
SPACE 3 08560000
* 08570000
* CHECKSK: to skip to a position in the file, it must be open for 08580000
* sequential processing. For skipping at least the first four digits 08590000
* of the key must be valid. 08600000
* 08610000
CHECKSK EQU * * Skip request 08620000
L R10,=AL4(NUMTAB) * Get addr of TRT-table for key 08630000
TRT UAKEY(4),0(R10) * Check that key is numeric 08640000
BZ CHECKSK2 * Yes: skip the error 08650000
NI FDBREQ,FDBNOSK * Reset skip request bit 08660000
LA R15,037 * Load error nr 08670000
L R3,=AL4(ERROR) * Get address of error handler 08680000
BR R3 * Execute it, return to caller 08690000
* 08700000
CHECKSK2 EQU * 08710000
AIF (&OPT).CHEKSK3 * Optimized mode: always open 08720000
TM FDBSTAT,FDBINPUT * Is the file open ?? 08730000
BO CHECKSK3 * Yes: skip error 08740000
TM FDBREQ,FDBOPEN * Is file to be opened ?? 08750000
BO CHECKSK3 * Yes: skip error 08760000
NI FDBREQ,FDBNOSK * Reset skip-request bit 08770000
LA R15,031 * Load error nr 08780000
L R3,=AL4(ERROR) * Get address of error handler 08790000
BR R3 * Execute it, return to caller 08800000
* 08810000
.CHEKSK3 ANOP 08820000
* 08830000
CHECKSK3 TM FDBSTAT,FDBACRND * File is open, is sequential ?? 08840000
BNOR R14 * Yes: accept SK-request 08850000
NI FDBREQ,FDBNOSK * Reset skip-request bit 08860000
LA R15,036 * Load error number 08870000
L R3,=AL4(ERROR) * Get address of error handler 08880000
BR R3 * Execute it, return to caller 08890000
* 08900000
SPACE 3 08910000
* 08920000
* CHECKRS: to read a record sequentially, the file must be open for 08930000
* sequential processing. Reading past end of file will cause a 08940000
* warning message to be issued, and the request to be ignored. 08950000
* 08960000
CHECKRS EQU * * Read sequential request 08970000
AIF (&OPT).CHEKRS5 * Optimized: file always open 08980000
TM FDBSTAT,FDBINPUT * Is the file open ?? 08990000
BO CHECKRS5 * Yes: skip this error 09000000
TM FDBREQ,FDBOPEN * Is file to be opened ?? 09010000
BNO CHECKRS2 * No: issue error 09020000
TM FDBREQ,FDBOPRND * Open random request ?? 09030000
BNOR R14 * No: ok, yes: error 09040000
* 09050000
CHECKRS2 NI FDBREQ,FDBNORX * Reset read request bit 09060000
LA R15,032 * Load error nr 09070000
L R3,=AL4(ERROR) * Get address of error handler 09080000
BR R3 * Execute it, return to caller 09090000
* 09100000
.CHEKRS5 ANOP 09110000
* 09120000
CHECKRS5 EQU * 09130000
TM FDBSTAT,FDBACRND * Access is random ?? 09140000
BNO CHECKRS6 * No: go check EOF-condition 09150000
ST R14,UALV2SAV * Save return address 09160000
LA R15,007 * Load error number 09170000
L R3,=AL4(ERROR) * Get address of error handler 09180000
BASR R14,R3 * Execute it, then return here 09190000
L R14,UALV2SAV * Reload correct return address 09200000
B CHECKRR * And default to read random 09210000
* 09220000
CHECKRS6 TM FDBSTAT,FDBEOF * End-of-file condition raised?? 09230000
BNOR R14 * No: accept RS-request 09240000
TM FDBREQ,FDBSKIP * Was a skip requested as well ? 09250000
BOR R14 * Yes: accept RS-request 09260000
NI FDBREQ,FDBNORX * Reset read request 09270000
LA R15,038 * Load error nr 09280000
L R3,=AL4(ERROR) * Get address of error handler 09290000
BR R3 * Execute it, return to caller 09300000
* 09310000
SPACE 3 09320000
* 09330000
* CHECKRR: to read a record randomly, the file must be open for 09340000
* random processing, and the full key must be given. 09350000
* 09360000
CHECKRR EQU * * Read random request 09370000
L R10,=AL4(NUMTAB) * Get addr of TRT-table for key 09380000
XR R7,R7 * Clear register 09390000
IC R7,FDBKEYLV * to contain length of key 09400000
BCTR R7,R0 * Decrement by one for TRT 09410000
EX R7,CHECKTRT * Check that key is numeric 09420000
BZ CHECKRR2 * Yes: skip the error 09430000
NI FDBREQ,FDBNORX * Reset read request bit 09440000
LA R15,039 * Load error nr 09450000
L R3,=AL4(ERROR) * Get address of error handler 09460000
BR R3 * Execute it, return to caller 09470000
* 09480000
* Optimized version cannot skip open checking: when the file is not 09490000
* open yet, the FDBACRND-bit still is zero, causing an erroneous 09500000
* error 008 on any call with opcode RI or RU. 09510000
* 09520000
CHECKRR2 EQU * 09530000
TM FDBSTAT,FDBINPUT * Is the file open ?? 09540000
BO CHECKRR4 * Yes: skip error 09550000
TM FDBREQ,FDBOPEN * Is file to be opened ?? 09560000
BNO CHECKRR3 * Yes: skip error 09570000
TM FDBREQ,FDBOPRND * Is file to be opened random ?? 09580000
BOR R14 * Yes: accept the request 09590000
* 09600000
CHECKRR3 NI FDBREQ,FDBNORX * Reset read-request bit 09610000
LA R15,032 * Load error nr 09620000
L R3,=AL4(ERROR) * Get address of error handler 09630000
BR R3 * Execute it, return to caller 09640000
* 09650000
CHECKRR4 TM FDBSTAT,FDBACRND * Is it open for random ?? 09660000
BOR R14 * Yes: accept the request 09670000
ST R14,UALV2SAV * Save return address 09680000
LA R15,008 * Load error number 09690000
L R3,=AL4(ERROR) * Get address of error handler 09700000
BASR R14,R3 * Execute it, then return here 09710000
L R14,UALV2SAV * Reload original return address 09720000
B CHECKRS * Try to read sequantial 09730000
* 09740000
SPACE 3 09750000
* 09760000
* CHECKWS: to rewrite a record sequentially, the file must be open 09770000
* for update in sequential mode, and the record to be updated must 09780000
* have been read just before the write request. 09790000
* 09800000
CHECKWS EQU * * Write sequential request 09810000
TM FDBSTAT,FDBACRND * Access is random ?? 09820000
BNO CHECKWX * No: skip this error 09830000
ST R14,UALV2SAV * Save return address 09840000
LA R15,009 * Load error nr 09850000
L R3,=AL4(ERROR) * Get address of error handler 09860000
BASR R14,R3 * Execute it, then return here 09870000
L R14,UALV2SAV * Reload return address 09880000
B CHECKWX * Default to 'WR'-processing 09890000
* 09900000
SPACE 3 09910000
* 09920000
* CHECKWR: to rewrite a record randomly, the file must be open 09930000
* for update in random mode, and the record to be updated must 09940000
* have been read just before the write request. 09950000
* 09960000
CHECKWR EQU * * Write random request 09970000
TM FDBSTAT,FDBACRND * Access is random ?? 09980000
BO CHECKWX * Yes: skip this error 09990000
ST R14,UALV2SAV * Save return address 10000000
LA R15,010 * Load error nr 10010000
L R3,=AL4(ERROR) * Get address of error handler 10020000
BASR R14,R3 * Execute it, then return here 10030000
L R14,UALV2SAV * Reload return address 10040000
* * And default to 'WS'-processing 10050000
SPACE 3 10060000
* 10070000
* CHECKWX: to rewrite a record, whether random or sequential, it is 10080000
* required that the record to be updated has been read just before 10090000
* the write request. this checking is done here for both modes. 10100000
* 10110000
CHECKWX EQU * 10120000
TM FDBSTAT,FDBUPDAT * Is the file open for update ?? 10130000
BO CHECKWX1 * Yes: skip this error 10140000
NI FDBREQ,FDBNOWX * Reset write request bit 10150000
LA R15,033 * Load error nr 10160000
L R3,=AL4(ERROR) * Get address of error handler 10170000
BR R3 * Execute it, return to caller 10180000
* 10190000
CHECKWX1 TM FDBLREQ,FDBREAD * Previous operation was read ?? 10200000
BO CHECKWX2 * Yes: skip this error 10210000
NI FDBREQ,FDBNOWX * Reset write request bit 10220000
LA R15,041 * Load error nr 10230000
L R3,=AL4(ERROR) * Get address of error handler 10240000
BR R3 * Execute it, return to caller 10250000
* 10260000
CHECKWX2 TM FDBSTAT,FDBEOF * Previous read succcessful?? 10270000
BNO CHECKWX3 * Yes: skip this error 10280000
NI FDBREQ,FDBNOWX * Reset write request bit 10290000
LA R15,041 * Load error nr 10300000
L R3,=AL4(ERROR) * Get address of error handler 10310000
BR R3 * Execute it, return to caller 10320000
* 10330000
CHECKWX3 XR R7,R7 * Clear register 10340000
IC R7,FDBKEYLV * to contain length of key 10350000
LA R8,LNSKEY(R7) * Load start addr of data area 10360000
BCTR R7,R0 * Decrement length by 1 for TRT 10370000
EX R7,CHECKCLC * Check that key is still equal 10380000
BE CHECKWX4 * Yes: skip this error 10390000
CHECKWXR NI FDBREQ,FDBNOWX * Reset write request bit 10400000
LA R15,043 * Load error nr 10410000
L R3,=AL4(ERROR) * Get address of error handler 10420000
BR R3 * Execute it, return to caller 10430000
* 10440000
CHECKWX4 EQU * 10450000
EX R7,CHECKCLK * Check that keys are equal 10460000
BER R14 * It is ok, accept the request 10470000
B CHECKWXR * Wrong: issue error 10480000
* 10490000
SPACE 3 10500000
* 10510000
* CHECKIR: to insert a record, the file must be open for update. 10520000
* An insert is not required to follow an unsuccessful read. 10530000
* The key, however must be numeric. 10540000
* 10550000
CHECKIR EQU * * Insert request 10560000
L R10,=AL4(NUMTAB) * Get addr of TRT-table for key 10570000
XR R7,R7 * Clear register 10580000
IC R7,FDBKEYLV * to contain length of key 10590000
LA R8,LNSKEY(R7) * Load address of data area 10600000
BCTR R7,R0 * Decrement length by 1 for TRT 10610000
EX R7,CHECKTRT * Check that key is numeric 10620000
BZ CHECKIR2 * Ok, then skip the error 10630000
NI FDBREQ,FDBNOIR * Reset insert request bit 10640000
LA R15,040 * Load error nr 10650000
L R3,=AL4(ERROR) * Get address of error handler 10660000
BR R3 * Execute it, return to caller 10670000
* 10680000
CHECKIR2 EQU * 10690000
EX R7,CHECKCLK * Check that keys are equal 10700000
BE CHECKIR3 * Ok, then skip the error 10710000
NI FDBREQ,FDBNOIR * Reset insert request bit 10720000
LA R15,045 * Load error nr 10730000
L R3,=AL4(ERROR) * Get address of error handler 10740000
BR R3 * Execute it, return to caller 10750000
* 10760000
CHECKIR3 EQU * 10770000
EX R7,CHECKCLZ * Is this the version record ?? 10780000
BNE CHECKIR4 * No: ok, skip the error 10790000
NI FDBREQ,FDBNOIR * Reset insert request bit 10800000
LA R15,047 * Load error nr 10810000
L R3,=AL4(ERROR) * Get address of error handler 10820000
BR R3 * Execute it, return to caller 10830000
* 10840000
CHECKIR4 TM FDBSTAT,FDBUPDAT * Is the file open for update ?? 10850000
BOR R14 * Yes: request is ok 10860000
NI FDBREQ,FDBNOIR * Reset request bit for insert 10870000
LA R15,034 * Load error nr 10880000
L R3,=AL4(ERROR) * Get address of error handler 10890000
BR R3 * Execute it, return to caller 10900000
* 10910000
SPACE 3 10920000
* 10930000
* CHECKDR: to delete a record, the file must be open for update and 10940000
* the record must have been read just before this delete request. 10950000
* 10960000
CHECKDR EQU * * Delete request 10970000
TM FDBSTAT,FDBUPDAT * Is the file open for update ?? 10980000
BO CHECKDR2 * Yes: skip this error 10990000
NI FDBREQ,FDBNODR * Reset delete request bit 11000000
LA R15,035 * Load error nr 11010000
L R3,=AL4(ERROR) * Get address of error handler 11020000
BR R3 * Execute it, return to caller 11030000
* 11040000
CHECKDR2 TM FDBLREQ,FDBREAD * Previous operation was read ?? 11050000
BO CHECKDR3 * Yes: skip this error 11060000
NI FDBREQ,FDBNODR * Reset delete request bit 11070000
LA R15,042 * Load error nr 11080000
L R3,=AL4(ERROR) * Get address of error handler 11090000
BR R3 * Execute it, return to caller 11100000
* 11110000
CHECKDR3 TM FDBSTAT,FDBEOF * Previous read reached eof ?? 11120000
BNO CHECKDR4 * No: skip this error 11130000
NI FDBREQ,FDBNODR * Reset delete request bit 11140000
LA R15,042 * Load error nr 11150000
L R3,=AL4(ERROR) * Get address of error handler 11160000
BR R3 * Execute it, return to caller 11170000
* 11180000
CHECKDR4 XR R7,R7 * Clear register 11190000
IC R7,FDBKEYLV * to contain length of key 11200000
LA R8,LNSKEY(R7) * Load address of data area 11210000
BCTR R7,R0 * Decrement length by 1 for TRT 11220000
EX R7,CHECKCLC * Check that key is still equal 11230000
BE CHECKDR5 * Yes: skip this error 11240000
CHECKDRR NI FDBREQ,FDBNODR * Reset delete request bit 11250000
LA R15,044 * Load error nr 11260000
L R3,=AL4(ERROR) * Get address of error handler 11270000
BR R3 * Execute it, then return 11280000
* 11290000
CHECKDR5 EQU * 11300000
EX R7,CHECKCLK * Check that keys are equal 11310000
BNE CHECKDRR * Wrong: issue error 11320000
* 11330000
CHECKDR6 EQU * 11340000
EX R7,CHECKCLZ * Is it the version record ?? 11350000
BNER R14 * It is ok, accept the request 11360000
NI FDBREQ,FDBNODR * Reset delete request bit 11370000
LA R15,048 * Load error nr 11380000
L R3,=AL4(ERROR) * Get address of error handler 11390000
BR R3 * Execute it, then return 11400000
* 11410000
SPACE 3 11420000
* 11430000
* CHECKCA: to close the file, it must be open. 11440000
* If not open, a warning is issued and the request is ignored. 11450000
* 11460000
CHECKCA EQU * * Close request 11470000
AIF (&OPT).CHEKCA * File always open (optimized) 11480000
TM FDBSTAT,FDBINPUT * Is the file open ?? 11490000
BOR R14 * Yes: return & continue 11500000
NI FDBREQ,FDBNOCA * Reset close request 11510000
LA R15,006 * Load error nr 11520000
L R3,=AL4(ERROR) * Get address of error handler 11530000
BR R3 * Execute it, return to caller 11540000
AGO .CHEKCA9 11550000
.CHEKCA ANOP 11560000
BR R14 * Optimized: return immediate 11570000
.CHEKCA9 ANOP 11580000
* 11590000
SPACE 3 11600000
AIF (NOT &DBG).CHECKSD * Checksd only in test mode 11610000
* 11620000
* CHECKSD: no checking is required. A snapdump is produced by calling 11630000
* RSNAP. No further action is required. 11640000
* 11650000
CHECKSD EQU * * Request to produce a snap-dump 11660000
ESNAP , * Call RSNAP-routine 11670000
AIF (&OPT).CHEKSD5 11680000
L R3,=AL4(RSETBASE) * Load new base address 11690000
L R14,=AL4(EXIT) * Take shortcut 11700000
BR R3 * To end the program 11710000
AGO .CHEKSD9 11720000
.CHEKSD5 ANOP 11730000
L R3,=AL4(PHASE4) * Load new base address 11740000
L R14,=AL4(EXIT) * Retrieve address of exit 11750000
BR R14 * Take shortcut 11760000
.CHEKSD9 ANOP 11770000
* 11780000
.CHECKSD ANOP 11790000
* 11800000
SPACE 3 11810000
* 11820000
* CHECKXX: routine forces an error since the requested function 11830000
* is not known or not supported. 11840000
* 11850000
CHECKXX EQU * * Invalid function-code in parm 11860000
LA R15,027 * Load error number 11870000
L R14,=AL4(EXIT) * Get fast exit address 11880000
L R3,=AL4(ERROR) * Get address of error handler 11890000
BR R3 * Execute it, return to exit 11900000
* 11910000
SPACE 3 11920000
* 11930000
CHECKCLC CLC FDBLKEY(0),0(R8) * Comp last key with key in parm 11940000
CHECKCLK CLC UAKEY(0),0(R8) * Compare keys in parameter 11950000
CHECKCLZ CLC UAKEY(0),=&MAXKEY.C'0' * Version record has key zero 11960000
* 11970000
CHECKTRT TRT UAKEY(0),0(R10) * Check that key is numeric 11980000
* 11990000
CHECKMV1 MVC FDBXKEY(0),UAKEY * Save key for read operation 12000000
CHECKMV2 MVC UAKEY(0),0(R8) * Cpy key of current rec to parm 12010000
CHECKMV3 MVC UAKEY(0),FDBXKEY * Restore key for read operation 12020000
* 12030000
SPACE 3 12040000
* 12050000
DROP R3 * Drop base register for phase 2 12060000
FASE2END EQU * 12070000
* 12080000
EJECT 12090000
USING PHASE3,R3 * And reestablish addressability 12100000
PHASE3 EQU * 12110000
* 12120000
* The FDBREQ field of all FDBs have now been set. 12130000
* Now we must process the FDBs one by one according to their request 12140000
* bit settings. Thus all requested I/O handlers shall be executed. 12150000
* For asynchronous processing to be effective, it is essential that 12160000
* as many requests overlap as possible. This is achieved by looping 12170000
* through all FDBs for each possible asynchronous request. Thus the 12180000
* requested files will be handled more in parallel, especially with 12190000
* combined opcodes: SN, WN, DN, and get sequential with implied open. 12200000
* 12210000
* Remarks on optimized coding: 12220000
* Since the capability to handle more than one file (FDB) at a time 12230000
* is currently not being used, we need to loop through the FDBs only 12240000
* once. Therefore the repeated loop-logic is skipped when optimizing. 12250000
* While the opcodes WN and DN are not being used (yet), the order 12260000
* of handling the request bits can be changed so that a read-request 12270000
* is recognized earlier. Thus a few unsuccessful compares can be 12280000
* avoided for each read request. Additionally, after executing a 12290000
* request that cannot be followed by another (combined) request 12300000
* we skip to the end of phase3 at once. 12310000
* 12320000
LA R5,UAFDBPTR * Point to entry of FDB-chain 12330000
LOOP3 L R5,FDBNEXT * Make next FDB the current one 12340000
LTR R5,R5 * If it is zero, we're through 12350000
BZ LOOP3EX * If no next FDB, then exit loop 12360000
CLI FDBREQ,FDBNOREQ * Anything to do for this file ? 12370000
BE LOOP3 * No: try next FDB 12380000
* 12390000
* If an insert is not requested while the RPL is still in insert 12400000
* status, then the RPL must be reset to normal 12410000
* 12420000
TM FDBSTAT,FDBRPLIR * Is RPL in insert mode?? 12430000
BNO LOOP3E * No: skip resetting the RPL 12440000
TM FDBREQ,FDBINSRT * Is insert requested ?? 12450000
BO LOOP3E * Yes: leave the RPL as it is 12460000
L R2,FDBRPL * Retrieve RPL-address 12470000
LA R6,FDBREC * Address of record in buffer 12480000
MODCB RPL=(R2), * Reset current RPL from insert *12490000
AREA=(S,0(R6)), * specify the correct data area*12500000
OPTCD=(UPD,LOC), * updating, locate mode *12510000
MF=(G,UAWORKAR,MODCNILV) * use UAWORKAR to build plist 12520000
LTR R15,R15 * Modcb was ok ?? 12530000
BZ LOOP3D * Yes: skip error 12540000
ST R15,UAVSAMRC * Save retcode for error handler 12550000
LA R15,063 * Load error number 12560000
L R3,=AL4(ERROR) * Get address of error handler 12570000
BASR R14,R3 * Execute it, then return here 12580000
B LOOP3E * Skip resetting the RPL-status 12590000
* 12600000
LOOP3D NI FDBSTAT,FDBRPLNI * Reset RPL-status to non-insert 12610000
* 12620000
SPACE 3 12630000
* 12640000
LOOP3E EQU * 12650000
* 12660000
* Open is to be executed first, because it may have been implied by 12670000
* another request, which can be executed only after opening. 12680000
* 12690000
TM FDBREQ,FDBOPEN * File is to be opened ?? 12700000
BNO LOOP3SK * No: skip open routine 12710000
BAS R14,ROP * Execute open routine 12720000
* 12730000
* Skip is to be executed after open (which may have been implied by 12740000
* a skip request), since a sequential open forces a skip request. 12750000
* Moreover skip should be executed before read, since open (and 12760000
* therefore skip) may have been implied by a read sequential request. 12770000
* Furthermore skip should be executed first, or it shall be impossible 12780000
* to support a combined skip-then-read request. 12790000
* 12800000
PRINT GEN 12810000
GBLC &TARGET * Target of branch instructions 12820000
&TARGET SETC 'LOOP3' * Normal process: loop thru FDBs 12830000
AIF (NOT &OPT).LOOP3SK * When optimizing, then 12840000
&TARGET SETC 'LOOPRXT' * go test read-request 12850000
.LOOP3SK ANOP 12860000
* 12870000
LOOP3SK TM FDBREQ,FDBSKIP * Skip to specified key ?? 12880000
BNO &TARGET * No: skip skip routine 12890000
BAS R14,RSK * Execute skip routine 12900000
B &TARGET * Check next FDB 12910000
* 12920000
LOOP3EX EQU * 12930000
* 12940000
SPACE 3 12950000
* 12960000
* Write is to be executed before read, or it will be impossible to 12970000
* support a combined write-then-read request. 12980000
* 12990000
&TARGET SETC 'LOOPWX' * Normal process: loop thru FDBs 13000000
AIF (NOT &OPT).LOOPWX * When optimizing, then 13010000
&TARGET SETC 'LOOPDRT' * go test for delete-request 13020000
AGO .LOOPWXT * and omit FDB-loop logic 13030000
.LOOPWX ANOP 13040000
* 13050000
LA R5,UAFDBPTR * Point to entry of FDB-chain 13060000
LOOPWX L R5,FDBNEXT * Make next FDB the current one 13070000
LTR R5,R5 * If it is zero, we're through 13080000
BZ LOOPWXEX * If no next FDB, then exit loop 13090000
* 13100000
.LOOPWXT ANOP 13110000
LOOPWXT TM FDBREQ,FDBWRITE * Write record specified ?? 13120000
BNO &TARGET * No: skip write routine 13130000
BAS R14,RWX * Execute write routine 13140000
* 13150000
AIF (NOT &OPT).LOOPWXU * When optimizing: 13160000
B LOOPCAEX * Skip remainder of phase3 13170000
* 13180000
.LOOPWXU AIF (&OPT).LOOPWXX * Opcode WN only in test mode 13190000
* 13200000
* If the write operation is to be followed by a read, then the saved 13210000
* key is to be restored into the parameter area. 13220000
* 13230000
TM FDBREQ,FDBREAD * Read is to follow this write?? 13240000
BNO &TARGET * No: continue with next FDB 13250000
TM FDBSTAT,FDBACRND * Access is random ?? 13260000
BNO &TARGET * No: key not required 13270000
XR R7,R7 * Clear register 13280000
IC R7,FDBKEYLV * to contain key length 13290000
BCTR R7,R0 * Decrement length by 1 for MVC 13300000
EX R7,LOOPWXMV * and restore saved key 13310000
B &TARGET * Go check next FDB 13320000
* 13330000
LOOPWXMV MVC UAKEY(0),FDBXKEY * Restore extra key into parm 13340000
* 13350000
.LOOPWXX ANOP 13360000
LOOPWXEX EQU * 13370000
* 13380000
SPACE 3 13390000
* 13400000
* Delete is to be executed before read, or it will be impossible to 13410000
* support a combined delete-then-read request. 13420000
* 13430000
&TARGET SETC 'LOOPDR' * Normal process: loop thru FDBs 13440000
AIF (NOT &OPT).LOOPDR * When optimizing, then 13450000
&TARGET SETC 'LOOPIRT' * go test for insert-request 13460000
AGO .LOOPDRT * and omit FDB-loop logic 13470000
.LOOPDR ANOP 13480000
* 13490000
LA R5,UAFDBPTR * Point to entry of FDB-chain 13500000
LOOPDR L R5,FDBNEXT * Make next FDB the current one 13510000
LTR R5,R5 * If it is zero, we're through 13520000
BZ LOOPDREX * If no next FDB, then exit loop 13530000
* 13540000
.LOOPDRT ANOP 13550000
LOOPDRT TM FDBREQ,FDBDEL * Delete record specified ?? 13560000
BNO &TARGET * No: skip delete routine 13570000
BAS R14,RDR * Execute delete routine 13580000
* 13590000
AIF (NOT &OPT).LOOPDRU * When optimizing: 13600000
B LOOPCAEX * Proceed to end of phase3 13610000
.LOOPDRU AIF (&OPT).LOOPDRX * DN only allowed in test mode 13620000
* 13630000
* If the delete operation is to be followed by a read, then the saved 13640000
* key is to be restored into the parameter area. 13650000
* 13660000
TM FDBREQ,FDBREAD * Read is to follow this write?? 13670000
BNO LOOPDR * No: continue with next FDB 13680000
TM FDBSTAT,FDBACRND * Access is random ?? 13690000
BNO LOOPDR * No: key not required 13700000
XR R7,R7 * Clear register 13710000
IC R7,FDBKEYLV * to contain key length 13720000
BCTR R7,R0 * Decrement length by 1 for MVC 13730000
EX R7,LOOPDRMV * and restore saved key 13740000
B LOOPDR * Go check next FDB 13750000
* 13760000
LOOPDRMV MVC UAKEY(0),FDBXKEY * Restore extra key into parm 13770000
* 13780000
.LOOPDRX ANOP 13790000
LOOPDREX EQU * 13800000
* 13810000
SPACE 3 13820000
* 13830000
* Read is to be executed after open, skip, write, and delete since 13840000
* these requests may be either implied or they need to be supported 13850000
* as a combined operation. 13860000
* 13870000
&TARGET SETC 'LOOPRX' * Normal process: loop thru FDBs 13880000
AIF (NOT &OPT).LOOPRX * When optimizing, then 13890000
&TARGET SETC 'LOOPWXT' * go test for write-request 13900000
AGO .LOOPRXT * and omit FDB-loop logic 13910000
.LOOPRX ANOP 13920000
* 13930000
LA R5,UAFDBPTR * Point to entry of FDB-chain 13940000
LOOPRX L R5,FDBNEXT * Make next FDB the current one 13950000
LTR R5,R5 * If it is zero, we're through 13960000
BZ LOOPRXEX * If no next FDB, then exit loop 13970000
* 13980000
.LOOPRXT ANOP 13990000
LOOPRXT TM FDBREQ,FDBREAD * Read record specified ?? 14000000
BNO &TARGET * No: skip read routine 14010000
BAS R14,RRX * Execute read routine 14020000
* 14030000
AIF (&OPT).LOOPRXU * When optimizing: drop-through 14040000
B &TARGET * And go check next FDB 14050000
.LOOPRXU ANOP , * To check for re-read request 14060000
* 14070000
* If a read request could not be satisfied from the current data buffer 14080000
* then the request bit is set for restart read. A skip request has been 14090000
* started: thus a skip will occur. Subsequently the read will be 14100000
* satisfiable. 14110000
* 14120000
LOOPRXEX EQU * 14130000
&TARGET SETC 'LOOPRYEX' * Normal process: loop thru FDBs 14140000
AIF (NOT &OPT).LOOPRY * When optimizing, then 14150000
&TARGET SETC 'LOOPCAEX' * no more requests to be handled 14160000
.LOOPRY ANOP 14170000
* 14180000
TM UASTAT,UARQREAD * Restart read processing ?? 14190000
BNO &TARGET * No: carry on 14200000
NI UASTAT,UARQNORX * Reset restart request 14210000
* 14220000
AIF (&OPT).LOOPRYX 14230000
LA R5,UAFDBPTR * Point to entry of FDB-chain 14240000
LOOPRY L R5,FDBNEXT * Make next FDB the current one 14250000
LTR R5,R5 * If it is zero, we're through 14260000
BZ LOOPRYEX * If no next FDB, then exit loop 14270000
TM FDBREQ,FDBREAD2 * Read record specified ?? 14280000
BNO LOOPRY * No: skip read routine 14290000
.LOOPRYX NI FDBREQ,FDBNOIR * Reset reread (=insert) request 14300000
BAS R14,RRX * And re-execute read routine 14310000
* 14320000
&TARGET SETC 'LOOPRY' * Normal process: loop thru FDBs 14330000
AIF (NOT &OPT).LOOPRZ * When optimizing, then 14340000
&TARGET SETC 'LOOPCAEX' * there are no more requests 14350000
.LOOPRZ ANOP 14360000
B &TARGET * And go check next FDB 14370000
* 14380000
LOOPRYEX EQU * 14390000
* 14400000
SPACE 3 14410000
* 14420000
* Insert is currently not combined with any other request, so we 14430000
* just leave it trailing behind, as the last asynchronous request. 14440000
* 14450000
&TARGET SETC 'LOOPIR' * Normal process: loop thru FDBs 14460000
AIF (NOT &OPT).LOOPIR * When optimizing, then 14470000
&TARGET SETC 'LOOPCAT' * go test for close-request 14480000
AGO .LOOPIRT * and omit FDB-loop logic 14490000
.LOOPIR ANOP 14500000
* 14510000
LA R5,UAFDBPTR * Point to entry of FDB-chain 14520000
LOOPIR L R5,FDBNEXT * Make next FDB the current one 14530000
LTR R5,R5 * If it is zero, we're through 14540000
BZ LOOPIREX * If no next FDB, then exit loop 14550000
* 14560000
.LOOPIRT ANOP **!! 14570000
LOOPIRT TM FDBREQ,FDBINSRT * Insert record specified ?? 14580000
BNO &TARGET * No: skip insert routine 14590000
BAS R14,RIR * Execute insert routine 14600000
* 14610000
AIF (NOT &OPT).LOOPIRU * When optimizing: 14620000
&TARGET SETC 'LOOPCAEX' * Skip remainder of phase3 14630000
.LOOPIRU B &TARGET * And go check next FDB 14640000
* 14650000
LOOPIREX EQU * 14660000
* 14670000
SPACE 3 14680000
* 14690000
* Finally close requests need to be executed if requested. 14700000
* Close is a synchronous request. 14710000
* 14720000
&TARGET SETC 'LOOPCA' * Normal process: loop thru FDBs 14730000
AIF (NOT &OPT).LOOPCA * When optimizing, then 14740000
&TARGET SETC 'LOOPCAEX' * go test for insert-request 14750000
AGO .LOOPCAT * and omit FDB-loop logic 14760000
.LOOPCA ANOP 14770000
* 14780000
LA R5,UAFDBPTR * Point to entry of FDB-chain 14790000
LOOPCA L R5,FDBNEXT * Make next FDB the current one 14800000
LTR R5,R5 * If it is zero, we're through 14810000
BZ LOOPCAEX * If no next FDB, then exit loop 14820000
* 14830000
.LOOPCAT ANOP 14840000
LOOPCAT TM FDBREQ,FDBCLOSE * Close this file ?? 14850000
BNO &TARGET * No: skip close routine 14860000
BAS R14,RCA * Execute close routine 14870000
* 14880000
AIF (&OPT).LOOPCAX 14890000
B &TARGET * And go check next FDB 14900000
.LOOPCAX ANOP 14910000
* 14920000
LOOPCAEX EQU * 14930000
* 14940000
PRINT &PRT * Set print option 14950000
* 14960000
SPACE 3 14970000
* 14980000
* Phase 3 is done. Continue with phase 4 14990000
* 15000000
L R3,=AL4(PHASE4) * Get start address of phase 4 15010000
BR R3 * And go execute it 15020000
* 15030000
EJECT 15040000
* 15050000
* ROP processes any open requests: sequential / random 15060000
* input / update 15070000
* 15080000
ROP EQU * * Process open request 15090000
ST R14,UALV1SAV * Save R14 level 1 15100000
* 15110000
* If any last request is still present in the FDB, it is invalidated 15120000
* by the open request, so we wipe it out. 15130000
* 15140000
MVI FDBLREQ,FDBNOREQ * Blank last request issued 15150000
MVI FDBLKEY,X'40' * and the associated key