| Quellcodebibliothek Statistik Leitseite products/Sources/formale Sprachen/HLASM/ Datei vom 7.9.2010 mit Größe 402 kB |
|
SSL bixsoft.hlasm Sprache: Hlasm |
|||||||||
|
* 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 selecto 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' * Prefi 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.45 Sekunden (vorverarbeitet) ¤*© Formatika GbR, Deutschland |
|
2026-03-28