*********************************************************************** * * * WRITTEN BY : STEVE SCOTT * * DATE: 01/02 * * * *********************************************************************** RXVSAM AMODE 31 RXVSAM RMODE ANY *********************************************************************** * * * RXVSAM() - ASSEMBLER REXX FUNCTION TO PERFORM OPERATIONS * * AGAINST VSAM DATASETS. PARAMETERS ARE AS FOLLOWS: * * * * RXVSAM(DDNAME, FUNCTION, PARAM1, PARAM2,.....) * * * * DDNAME - 8 CHARACTER DDNAME TO BE USED FOR THE DATASET. MUST BE * * ALLOCATED PRIOR TO USE. * * * * FUNCTION - REQUESTED OPERATION AGAINST DATASET. VALID OPTIONS * * ARE: * * OPEN - OPEN DATASET (READ ONLY) * * OPENU - OPEN DATASET FOR UPDATE * * OPENL - OPEN DATASET TO LOAD DATA * * OPENRU - OPEN DATASET AND CLEAR, UPDATE TO FOLLOW * * CLOSE - CLOSE DATASET (IF U OPEN U MUST CLOSE!) * * READ - READ A RECORD * * READU - READ A RECORD FOR UPDATING * * WRITE - UPDATE/WRITE NEW RECORD * * DELETE - DELETE A RECORD * * POINT - POINT TO RECORD FOR SUBSEQUENT READ * * ENDREQ - CANCEL READU REQUEST * * * * PARAM1, PARAM2,.... - PARAMETERS ARE DEPENDENT UPON FUNCTION * * REQUESTED. AVAILABLE OPTIONS BY FUNCTION ARE: * * OPEN * * ESDS - DATASET IS AN ENTRY SEQUENCED DS * * OPENU * * ESDS - DATASET IS AN ENTRY SEQUENCED DS * * OPENL * * ESDS - DATASET IS AN ENTRY SEQUENCED DS * * OPENRU * * ESDS - DATASET IS AN ENTRY SEQUENCED DS * * CLOSE * * NO ADDITIONAL PARAMETERS * * READ * * KEY= - OPTIONAL. KEYED READS ARE MAINTAINED * * SEPERATELY FROM SEQUENTIAL ACCESS. FOR * * SUBSEQUENT SEQUENTIAL ACCESS USE THE * * "POINT" FUNCTION. THE "KEY=" PARAMETER * * WITH THE READ FUNCTION IMPLIES * * DIRECT ACCESS. * * NNNNN - OPTIONAL. NUMBER OF RECORDS TO PLACE * * IN THE DATA STACK. MUTUALLY EXCLUSIVE * * WITH THE "KEY=" PARAMETER; USE "POINT" * * THEN READ NNNNN INSTEAD * * READU * * KEY= - OPTIONAL. KEYED READS ARE MAINTAINED * * SEPERATELY FROM SEQUENTIAL ACCESS. FOR * * SUBSEQUENT SEQUENTIAL ACCESS USE THE * * "POINT" FUNCTION. THE "KEY=" PARAMETER * * WITH THE READ FUNCTION IMPLIES * * DIRECT ACCESS. * * WRITE * * NO ADDITIONAL PARAMETERS. ONE RECORD IS WRITTEN * * FROM THE DATA STACK. * * DELETE * * KEY= - OPTIONAL. KEYED READS ARE MAINTAINED * * SEPERATELY FROM SEQUENTIAL ACCESS. * * POINT * * KEY= - REQUIRED. POSITIONS READ POINTER FOR * * SUBSEQUENT SEQUENTIAL ACCESS. * * ENDREQ * * NO ADDITIONAL OPTIONS REQUIRED. * * * *********************************************************************** * REGISTER USAGE * *********************************************************************** * * * R0 - WORK * * R1 - WORK/ADDRESS OF PARAMETER LIST * * R2 - WORK * * R3 - BASE * * R4 - WORK * * R5 - BASE 2 * * R6 - WORK * * R7 - WORK * * R8 - WORK * * R9 - WORK * * R10 - ** UNUSED ** * * R11 - ** UNUSED ** * * R12 - ** UNUSED ** * * R13 - PROGRAM SAVE AREA * * R14 - BAL/WORK * * R15 - WORK/SYSTEM * * * *********************************************************************** EJECT * RXVSAM START 0 VSAMIO FUNC=PLIST * R0 EQU 0 R1 EQU 1 R2 EQU 2 R3 EQU 3 R4 EQU 4 R5 EQU 5 R6 EQU 6 R7 EQU 7 R8 EQU 8 R9 EQU 9 R10 EQU 10 R11 EQU 11 R12 EQU 12 R13 EQU 13 R14 EQU 14 R15 EQU 15 * STM R14,R12,12(R13) LR R3,R15 3'S THE BASE LA R5,4095(R3) LA R5,1(,R5) USING RXVSAM,R3 SET USING STATUS USING RXVSAM+4096,R5 SET USING STATUS * STORAGE OBTAIN,LENGTH=STORLEN ST R13,4(R1) SET CHAIN ST R1,8(R13) LR R13,R1 GET SAVE AREA ADDR IN R13 USING STORAGE,R13 * L R1,4(R13) GET CALLER SAVE AREA ADDR LM R0,R1,20(R1) RESTORE ENVB AND EFPL POINTERS ST R0,ENV SAVE IT FOR CALLS TO REXX SERVICES ST R1,EFPLADD SAVE EXTERNAL FUNCTION PARM LIST ADDR * LR R4,R1 PUT IN R4 AND SET UP USING USING EFPL,R4 * MVC RC,=CL2'00' * ********************************************************************* * VALIDATE AND PROCESS THE PARAMETER LIST ********************************************************************* * L R1,EFPLARG GET REXX PARMS ST R1,ARGLIST SAVE ADDRESS OF ARGUMENT LIST * L R14,4(,R1) GET LENGTH OF DDNAME C R14,=F'8' 8 BYTES OR LESS PLEASE BH BADDNM OTHWISE HIT THE ROAD XC DDNAME,DDNAME CLEAR REQUEST TYPE AREA MVC DDNAME,=CL8' ' SPACE L R15,0(,R1) BCTR R14,0 DECREMENT FOR MOVE EX R14,MOVDDN * XC REQBUF,REQBUF CLEAR REQUEST TYPE AREA MVI REQBUF,X'40' SPACE MVC REQBUF+1(L'REQBUF-1),REQBUF SPACE IT ALL L R14,12(,R1) GET REQUEST PARM LENGTH C R14,=A(L'REQBUF) TOO BIG? BH BADREQ TELL EM SO L R15,8(,R1) GET REQUEST PARM ADDRESS EX R14,MOVREQ EXECUTE THE MOVE * * GET VSANCHOR VARIABLE ADDRESS * MVC VARCON,=CL8'IRXEXCOM' LA R14,VARCON GET ADDR OF CONSTANT ST R14,VP1 SAVE IT IN PARM LIST XC VP2,VP2 XC VP3,VP3 XC VARSHVB(L'VARSHVB),VARSHVB LA R15,VARSHVB ST R15,VP4 OI VP4,X'80' USING SHVBLOCK,R15 XC SHVNEXT,SHVNEXT NO NEXT BLOCK XC SHVUSER,SHVUSER MVI SHVCODE,SHVFETCH FUNCTION CODE=FETCH VARIABLE XC SHVRET,SHVRET MVC SHVBUFL,=A(L'VSANCHOR) MVC SHVNAMA,=A(VARNAME) MVC SHVNAML,=F'8' LA R1,VSANCHOR ST R1,SHVVALA XC SHVVALL,SHVVALL BAL R14,CALLVAR LTR R15,R15 BNZ BADXECOM * LA R15,VARSHVB RELOAD VARBLOCK ADDR CLI SHVRET,0 EVERTHYING OK? BNE BADVAR DROP R15 * CLC VSANCHOR(4),=CL4'INIT' INTIAL VALUE? BNE VARGOOD NO--> VAR' GOOD, ROOFUS! STORAGE OBTAIN,LENGTH=VS$#@LEN ST R1,VS$#@LST XC 0(VS$#@LEN,R1),0(R1) MVC VSANCHOR(4),VS$#@LST MOVE ADDR INTO VARIABLE BUFFER * * SET VSANCHOR VARIABLE TO LIST ADDRESS * MVC VARCON,=CL8'IRXEXCOM' LA R14,VARCON GET ADDR OF CONSTANT ST R14,VP1 SAVE IT IN PARM LIST XC VP2,VP2 XC VP3,VP3 XC VARSHVB(L'VARSHVB),VARSHVB LA R15,VARSHVB ST R15,VP4 OI VP4,X'80' USING SHVBLOCK,R15 XC SHVNEXT,SHVNEXT NO NEXT BLOCK XC SHVUSER,SHVUSER MVI SHVCODE,SHVSTORE FUNCTION CODE=STORE VARIABLE XC SHVRET,SHVRET XC SHVBUFL,SHVBUFL MVC SHVNAMA,=A(VARNAME) MVC SHVNAML,=F'8' LA R1,VSANCHOR ST R1,SHVVALA MVC SHVVALL,=F'4' BAL R14,CALLVAR LTR R15,R15 BNZ BADXECOM * LA R15,VARSHVB RELOAD VARBLOCK ADDR CLI SHVRET,0 EVERTHYING OK? BNE BADVAR DROP R15 * VARGOOD DS 0H MVC VS$#@LST,VSANCHOR OBTAIN ADDR OF STG AREA FROM VARIABLE * CLC =CL6'OPENRU',REQBUF OPEN RESET/UPDATE? BE REQORU YES--> PERFORM OPERATION * CLC =CL5'OPENL',REQBUF OPEN FOR LOAD? BE REQOPL YES--> PERFORM OPERATION * CLC =CL5'OPENU',REQBUF OPEN UPDATE REQUEST? BE REQOPU YES--> PERFORM OPERATION * CLC =CL4'OPEN',REQBUF OPEN REQUEST? BE REQOPEN YES--> PERFORM OPERATION * CLC =CL5'CLOSE',REQBUF CLOSE REQUEST? BE REQCLOSE YES--> PERFORM OPERATION * CLC =CL6'DELETE',REQBUF DELETE? BE REQDEL YES--> PERFORM OPERATION * CLC =CL5'READU',REQBUF READ UPDATE? BE REQREAD YES--> PERFORM OPERATION * CLC =CL4'READ',REQBUF READ REQUEST? BE REQREAD YES--> PERFORM OPERATION * CLC =CL5'WRITE',REQBUF WRITE REQUEST? BE REQWRITE YES--> PERFORM OPERATION * CLC =CL5'POINT',REQBUF POINT REQUEST? BE REQPOINT YES--> PERFORM OPERATION * CLC =CL5'ENDREQ',REQBUF END REQUEST? BE REQENDRQ YES--> PERFORM OPERATION * B BADREQ NO MATCH=NOT VALID * * EXECUTED INSTRUCTIONS MOVREQ MVC REQBUF(0),0(R15) MOVDDN MVC DDNAME(0),0(R15) MOVNUM MVC NUMBUF(0),0(R15) MOVKEY MVC KEYBUF(0),0(R15) PACKNUM PACK DWORD,NUMBUF(0) * ********************************************************************* * PROCESS OPEN REQUEST ********************************************************************* REQOPEN DS 0H * L R1,ARGLIST GET ARGUMENT LIST CLC 16(4,R1),=F'-1' END OF ARG LIST? BE REQOPEN1 GO W/DEFAULT * L R15,16(,R1) GET ARG 3 ADDR CLC 0(4,R15),=CL4'ESDS' ENTRY SEQUENCED DATASET? BNE REQOPEN1 YES--> SET UP ACCESS * VSAMIO DDNAME,FUNC=OPEN,INTENT=READ,DBUF=30,IBUF=10, X FTYPE=ESDS B REQOPEN2 * REQOPEN1 DS 0H VSAMIO DDNAME,FUNC=OPEN,INTENT=READ,DBUF=30,IBUF=10 * REQOPEN2 DS 0H USING VS$#@IOD,R1 ICM R1,15,VS$#@LST CHECK PARAMETER LIST ADDRESS BZ BADOPEN BYPASS GETMAIN IF PRESENT MVC VSRC,VS$#@RCD GET RETURN CODE CLC VS$#@RCD,=XL3'00' BNE BADOPEN DROP R1 * B RETURN * ********************************************************************* * PROCESS OPEN RESET/UPDATE ********************************************************************* REQORU DS 0H * L R1,ARGLIST GET ARGUMENT LIST CLC 16(4,R1),=F'-1' END OF ARG LIST? BE REQORU1 GO W/DEFAULT * L R15,16(,R1) GET ARG 3 ADDR CLC 0(4,R15),=CL4'ESDS' ENTRY SEQUENCED DATASET? BNE REQORU1 YES--> SET UP ACCESS * VSAMIO DDNAME,FUNC=OPEN,INTENT=RESUPD,DBUF=30,IBUF=10, X FTYPE=ESDS B REQORU2 * REQORU1 DS 0H VSAMIO DDNAME,FUNC=OPEN,INTENT=RESUPD,DBUF=30,IBUF=10 * REQORU2 DS 0H USING VS$#@IOD,R1 ICM R1,15,VS$#@LST CHECK PARAMETER LIST ADDRESS BZ BADOPEN BYPASS GETMAIN IF PRESENT MVC VSRC,VS$#@RCD GET RETURN CODE CLC VS$#@RCD,=XL3'00' BNE BADOPEN DROP R1 * B RETURN * ********************************************************************* * PROCESS OPEN FOR LOAD ********************************************************************* REQOPL DS 0H * L R1,ARGLIST GET ARGUMENT LIST CLC 16(4,R1),=F'-1' END OF ARG LIST? BE REQOPL1 GO W/DEFAULT * L R15,16(,R1) GET ARG 3 ADDR CLC 0(4,R15),=CL4'ESDS' ENTRY SEQUENCED DATASET? BNE REQOPL1 YES--> SET UP ACCESS * VSAMIO DDNAME,FUNC=OPEN,INTENT=LOAD,DBUF=30,IBUF=10, X FTYPE=ESDS B REQOPL2 * REQOPL1 DS 0H VSAMIO DDNAME,FUNC=OPEN,INTENT=LOAD,DBUF=30,IBUF=10 * REQOPL2 DS 0H USING VS$#@IOD,R1 ICM R1,15,VS$#@LST CHECK PARAMETER LIST ADDRESS BZ BADOPEN BYPASS GETMAIN IF PRESENT MVC VSRC,VS$#@RCD GET RETURN CODE CLC VS$#@RCD,=XL3'00' BNE BADOPEN DROP R1 * B RETURN * ********************************************************************* * PROCESS OPEN FOR UPDATE ********************************************************************* REQOPU DS 0H * L R1,ARGLIST GET ARGUMENT LIST CLC 16(4,R1),=F'-1' END OF ARG LIST? BE REQOPU1 GO W/DEFAULT * L R15,16(,R1) GET ARG 3 ADDR CLC 0(4,R15),=CL4'ESDS' ENTRY SEQUENCED DATASET? BNE REQOPU1 YES--> SET UP ACCESS * VSAMIO DDNAME,FUNC=OPEN,INTENT=UPDATE,DBUF=30,IBUF=10, X FTYPE=ESDS B REQOPU2 * REQOPU1 DS 0H VSAMIO DDNAME,FUNC=OPEN,INTENT=UPDATE,DBUF=30,IBUF=10 * REQOPU2 DS 0H USING VS$#@IOD,R1 ICM R1,15,VS$#@LST CHECK PARAMETER LIST ADDRESS BZ BADOPEN BYPASS GETMAIN IF PRESENT MVC VSRC,VS$#@RCD GET RETURN CODE CLC VS$#@RCD,=XL3'00' BNE BADOPEN DROP R1 * B RETURN * ********************************************************************* * PROCESS CLOSE REQUEST ********************************************************************* REQCLOSE DS 0H * VSAMIO DDNAME,FUNC=CLOSE * USING VS$#@IOD,R1 ICM R1,15,VS$#@LST CHECK PARAMETER LIST ADDRESS BZ BADCLOSE BYPASS GETMAIN IF PRESENT MVC VSRC,VS$#@RCD GET RETURN CODE CLC VS$#@RCD,=XL3'00' BNE BADCLOSE DROP R1 * B RETURN * ********************************************************************* * PROCESS DELETE REQUEST ********************************************************************* REQDEL DS 0H * * MVC RC,=CL2'NO' * B RETURN * ********************************************************************* * PROCESS READ ********************************************************************* REQREAD DS 0H * L R1,ARGLIST GET ARGUMENT LIST CLC 16(4,R1),=F'-1' END OF ARG LIST? BE RDJST01 SETUP DEFAULT AMOUNT * L R15,16(,R1) GET ARG 3 ADDR CLC 0(4,R15),=CL4'KEY=' KEYED READ? BE RDWKEY01 YES--> SET UP ACCESS * L R14,20(R1) LENGTH OF PARM IN R14 C R14,=F'9' 1B MAX AMOUNT QUEUED BH BADSPARM * BCTR R14,0 EX R14,MOVNUM MOVE OUR NUMBER IN LA R15,NUMBUF LOAD ADDR OF "NUMBER" L R14,20(,R1) RELOAD LENGTH CKNUM01 DS 0H CLI 0(R15),X'F0' BL BADNUM CLI 0(R15),X'F9' BH BADNUM AH R15,=H'1' NEXT CHARACTER BCT R14,CKNUM01 LOOP FOR LENGTH OF VALUE * LA R15,NUMBUF OK, VALIDATED, RELOAD NUM ADDR L R14,20(R1) GET LENGTH IN R14 BCTR R14,0 EX R14,PACKNUM PACK THE NUMBER INTO DWORD CVB R7,DWORD PUT IT IN R7 B RDNXT01 AND GET ON WITH IT * RDWKEY01 DS 0H LA R7,1 SET R7 FOR ONE RECORD READ L R14,20(R1) R15'S GOT THE ADDR, PUT LENGTH IN R14 CH R14,=H'255' MORE THAN MAX FOR KEY? BH BADKEY YUP, TELL 'EM SH R14,=H'4' SUBTRACT LENGTH OF "KEY=" LA R15,4(,R15) POINT PAST "KEY=" BCTR R14,0 MINUS ONE FOR MOVE EX R14,MOVKEY MOVE KEY INTO KEYBUF FIELD L R14,20(R1) RELOAD LENGTH SH R14,=H'4' MINUS THE "KEY=" STUFF * USING VS$#@IOD,R1 ICM R1,15,VS$#@LST GET PARAMETER LIST ADDRESS BZ BADRREAD EXIT IF ZERO STC R14,VS$#@KYL STORE THE KEY LENGTH DROP R1 CLC =CL5'READU',REQBUF READ UPDATE? BE RDWKEY02 YES--> GO EXECUET * VSAMIO DDNAME,FUNC=READ,IOREG=R6,EOFNRF=RDNRF,KEY=KEYBUF, X KEYLEN=PRESET USING VS$#@IOD,R1 ICM R1,15,VS$#@LST CHECK PARAMETER LIST ADDRESS BZ BADRREAD BYPASS GETMAIN IF PRESENT MVC VSRC,VS$#@RCD GET RETURN CODE CLC VS$#@RCD,=XL3'00' BNE BADRREAD * B STKIT01 * RDWKEY02 DS 0H * VSAMIO DDNAME,FUNC=READU,IOREG=R6,EOFNRF=RDNRF,KEY=KEYBUF, X KEYLEN=PRESET USING VS$#@IOD,R1 ICM R1,15,VS$#@LST CHECK PARAMETER LIST ADDRESS BZ BADRREAD BYPASS GETMAIN IF PRESENT MVC VSRC,VS$#@RCD GET RETURN CODE CLC VS$#@RCD,=XL3'00' BNE BADRREAD * B STKIT01 * RDJST01 DS 0H OK, JUST 1K WORTH, IF THAT LA R7,1000 DEFAULT 1000 RECORDS RDNXT01 DS 0H CLC =CL5'READU',REQBUF READ UPDATE? BE RDNXT02 VSAMIO DDNAME,FUNC=READ,IOREG=R6,EOFNRF=RDNRF USING VS$#@IOD,R1 ICM R1,15,VS$#@LST CHECK PARAMETER LIST ADDRESS BZ BADREAD BYPASS GETMAIN IF PRESENT MVC VSRC,VS$#@RCD GET RETURN CODE CLC VS$#@RCD,=XL3'00' BNE BADREAD B STKIT01 * RDNXT02 DS 0H * VSAMIO DDNAME,FUNC=READU,IOREG=R6,EOFNRF=RDNRF USING VS$#@IOD,R1 ICM R1,15,VS$#@LST CHECK PARAMETER LIST ADDRESS BZ BADRREAD BYPASS GETMAIN IF PRESENT MVC VSRC,VS$#@RCD GET RETURN CODE CLC VS$#@RCD,=XL3'00' BNE BADRREAD * STKIT01 DS 0H ST R6,DATAPTR STORE DATA ADDRESS IN FULLWORD LA R15,DATAPTR ST R15,STKDE STORE DATA ADDRESS IN PARAMETER LENGTH LH R15,VS$#@RLN GET RECORD LENGTH DROP R1 ST R15,DATALEN STORE IN PARM LIST XC STKENV,STKENV SAVE ADDR F ENVIRONMENT BLOCK MVC FUNCTION,=CL8'QUEUE' SET FUNCTION CODE LA R15,FUNCTION ST R15,STKFNCA STORE ADDR OF FUNCTION LA R15,DATALEN AND SET UP PARM LIST ST R15,STKDEL LA R15,CALLRSLT ST R15,STKRSLT OI STKRSLT,X'80' SET HIGH BIT ON * BAL R14,CALLSTK GO QUEUE THE DATA * CLC =CL5'READU',REQBUF READ UPDATE? BE RDNRF YES--> PUT EOF MARKER * BCT R7,RDNXT01 * B RETURN RDNRF DS 0H LA R15,=CL7'>>EOF<<' ST R15,DATAPTR LA R15,DATAPTR ST R15,STKDE STORE DATA ADDRESS IN PARAMETER LENGTH LH R15,=H'7' GET RECORD LENGTH ST R15,DATALEN STORE IN PARM LIST XC STKENV,STKENV SAVE ADDR F ENVIRONMENT BLOCK MVC FUNCTION,=CL8'QUEUE' SET FUNCTION CODE LA R15,FUNCTION ST R15,STKFNCA STORE ADDR OF FUNCTION LA R15,DATALEN AND SET UP PARM LIST ST R15,STKDEL LA R15,CALLRSLT ST R15,STKRSLT OI STKRSLT,X'80' SET HIGH BIT ON * BAL R14,CALLSTK GO QUEUE THE DATA B RETURN ********************************************************************* * PROCESS WRITE REQUEST ********************************************************************* REQWRITE DS 0H * LA R15,DATAPTR ST R15,STKDE STORE DATA ADDRESS IN PARAMETER LENGTH XC STKENV,STKENV SAVE ADDR F ENVIRONMENT BLOCK MVC FUNCTION,=CL8'PULL' SET FUNCTION CODE LA R15,FUNCTION ST R15,STKFNCA STORE ADDR OF FUNCTION LA R15,DATALEN AND SET UP PARM LIST ST R15,STKDEL LA R15,CALLRSLT ST R15,STKRSLT OI STKRSLT,X'80' SET HIGH BIT ON * BAL R14,CALLSTK GO QUEUE THE DATA * ICM R15,15,CALLRSLT GET RESULT AREA BNZ NOTQUED NON-ZERO = NON-FUNCTIONAL * L R6,DATAPTR L R15,DATALEN GET LENGTH STH R15,RECLEN * SEQWRIT DS 0H VSAMIO DDNAME,FUNC=WRITE,AREA=(R6),LENGTH=RECLEN USING VS$#@IOD,R1 ICM R1,15,VS$#@LST CHECK PARAMETER LIST ADDRESS BZ BADWRITE BYPASS GETMAIN IF PRESENT MVC VSRC,VS$#@RCD GET RETURN CODE CLC VS$#@RCD,=XL3'00' BNE BADWRITE * B RETURN * ********************************************************************* * PROCESS POINT REQUEST ********************************************************************* REQPOINT DS 0H * L R1,ARGLIST GET ARGUMENT LIST CLC 16(4,R1),=F'-1' END OF ARG LIST? BE RDJST01 SETUP DEFAULT AMOUNT * L R15,16(,R1) GET ARG 3 ADDR CLC 0(4,R15),=CL4'KEY=' KEY? BE PTKEY01 YES--> SET UP ACCESS * MVC RC,=CL2'KM' B RETURN * PTKEY01 DS 0H L R14,20(R1) R15'S GOT THE ADDR, PUT LENGTH IN R14 CH R14,=H'255' MORE THAN MAX FOR KEY? BH BADKEY YUP, TELL 'EM SH R14,=H'4' SUBTRACT LENGTH OF "KEY=" LA R15,4(,R15) POINT PAST "KEY=" BCTR R14,0 MINUS ONE FOR MOVE EX R14,MOVKEY MOVE KEY INTO KEYBUF FIELD L R14,20(R1) RELOAD LENGTH * USING VS$#@IOD,R1 ICM R1,15,VS$#@LST GET PARAMETER LIST ADDRESS BZ BADPOINT EXIT IF ZERO STC R14,VS$#@KYL STORE THE KEY LENGTH DROP R1 * VSAMIO DDNAME,FUNC=POINT,EOFNRF=RDNRF,KEY=KEYBUF, X KEYLEN=PRESET USING VS$#@IOD,R1 ICM R1,15,VS$#@LST CHECK PARAMETER LIST ADDRESS BZ BADPOINT BYPASS GETMAIN IF PRESENT MVC VSRC,VS$#@RCD GET RETURN CODE CLC VS$#@RCD,=XL3'00' BNE BADPOINT * B RETURN * ********************************************************************* * PROCESS POINT REQUEST ********************************************************************* REQENDRQ DS 0H * VSAMIO DDNAME,FUNC=ENDREQ USING VS$#@IOD,R1 ICM R1,15,VS$#@LST CHECK PARAMETER LIST ADDRESS BZ BADERQ BYPASS GETMAIN IF PRESENT MVC VSRC,VS$#@RCD GET RETURN CODE CLC VS$#@RCD,=XL3'00' BNE BADERQ * B RETURN * EJECT ********************************************************************* * CALL DATA STACK ROUTINE ********************************************************************* CALLSTK DS 0H * ST R14,CALLSTKE * L R1,ENV ; ENVBLOCK ADDRESS L R1,ENVBLOCK_IRXEXTE-ENVBLOCK(,R1) ; IRXEXTE ADDRESS USING IRXEXTE,R1 ; TELL ASSEMBLER L R15,IRXSTK ; RESULT ROUTINE DROP R1 * L R0,ENV ; OPTIONAL ENVIRONMENT BLOCK LA R1,STKPL ; IRXSTK PLIST BALR R14,R15 ; CALL IT * CALLSTKX DS 0H * L R14,CALLSTKE BR R14 ********************************************************************* * CALL VARIABLE REQUEST ROUTINE ********************************************************************* CALLVAR DS 0H * ST R14,CALLVARE * L R1,ENV ; ENVBLOCK ADDRESS L R1,ENVBLOCK_IRXEXTE-ENVBLOCK(,R1) ; IRXEXTE ADDRESS USING IRXEXTE,R1 ; TELL ASSEMBLER L R15,IRXEXCOM ; VARIABLE ACCESS ROUTINE DROP R1 * L R0,ENV ; OPTIONAL ENVIRONMENT BLOCK LA R1,VARPL ; IRXEXCOM PARM LIST BALR R14,R15 ; CALL IT * CALLVARX DS 0H * L R14,CALLVARE BR R14 ******************************************************************* * ERROR RETURNS ******************************************************************* BADDNM DS 0H MVC RC,=CL2'12' B RETURN BADREQ DS 0H MVC RC,=CL2'13' B RETURN BADOPEN DS 0H MVC RC,=CL2'20' B RETURN BADCLOSE DS 0H MVC RC,=CL2'21' B RETURN BADREAD DS 0H MVC RC,=CL2'22' B RETURN BADRREAD DS 0H MVC RC,=CL2'23' B RETURN LENERR DS 0H MVC RC,=CL2'24' B RETURN BADPOINT DS 0H MVC RC,=CL2'29' B RETURN BADVAR DS 0H MVC RC,=CL2'30' B RETURN BADNUM DS 0H MVC RC,=CL2'31' B RETURN BADKEY DS 0H MVC RC,=CL2'32' B RETURN BADXECOM DS 0H MVC RC,=CL2'35' B RETURN BADSPARM DS 0H MVC RC,=CL2'37' B RETURN NOTQUED DS 0H MVC RC,=CL2'41' B RETURN BADWRITE DS 0H MVC RC,=CL2'45' B RETURN BADRWRIT DS 0H MVC RC,=CL2'46' B RETURN BADERQ DS 0H MVC RC,=CL2'50' B RETURN ******************************************************************* * ******************************************************************* RETURN DS 0H L R15,EFPLEVAL GET EVAL BLOCK ADDR L R15,0(,R15) THEN POINT TO EVALBLOCK USING EVALBLOCK,R15 * MVC WK5(3),VSRC UNPK WK9,WK5 UNPACK XC DWORD,DWORD CLEAR MVN DWORD,WK9 TR DWORD,=C'0123456789ABCDEF' * MVC EVALBLOCK_EVLEN,=F'8' MVC EVALBLOCK_EVDATA(2),RC SET REXX RETURN MVC EVALBLOCK_EVDATA+2(6),DWORD DROP R15 * LR R1,R13 GET SA ADDR L R13,4(R13) RESTORE CALLER SAVE AREA MVC 16(4,R13),=F'0' MOVE CALL RETURN CODE * STORAGE RELEASE,ADDR=(R1),LENGTH=STORLEN * LM R14,R12,12(R13) THEN THE REGISTERS XR R15,R15 CLEAR R15 BR R14 EXIT * EJECT ********************************************************************** * LITERALS * ********************************************************************** VS$#@LST DS F VARNAME DC CL8'VSANCHOR' LTORG , EJECT ********************************************************************** * PROGRAM STORAGE * ********************************************************************** STORAGE DSECT , SAVEAREA DS 9D R13 SAVEAREA * DWORD DS D CALLSTKE DS F CALLVARE DS F EFPLADD DS F OLDSE DS F ENV DS F EVB DS F DATAPTR DS F ANSLEN DS 1F ANSWER AREA LENGTH RQDLEN DS 1F REQUIRED LENGTH RETCODE DS 1F RETURN CODE RSNCODE DS 1F REASON CODE RC DS F VSRC DS XL3 DS 0F VSANCHOR DS CL255 * ****************************************************************** * DATA STACK ROUNTINE PARAMETERS AND DATA ****************************************************************** STKPL DS 0F PARAMETER LIST FOR DATA STACK RTN STKFNCA DS F ADDR OF FUNCTION REQUESTED STKDE DS F ADDR OF DATA STACK ELEMENT STKDEL DS F ADD OF LENGTH OF DATA STACK ELEMENT STKRSLT DS F ADDR OF RESULT NUMBER STKENV DS F ADDR OF ENVIRONMENT BLOCK STKRTNC DS F ADDR OF RETURN CODE * ****************************************************************** * REXX VARIABLE ROUTING PARAMETERS ****************************************************************** VARPL DS 0F PARAMETER LIST FOR VARIABLE ROUTINE VP1 DS F PARM 1 VP2 DS F PARM 2 VP3 DS F PARM 3 VP4 DS F PARM 4 * * AND OF COURSE, THE STUFF THAT THE ABOVE POINTS TO * VARCON DS CL8 IDENTIFIER, "IRXEXCOM" VARSHVB DS XL(SHVBLEN) 1ST SHARED VARIABLE BLOCK * * RECLEN DS H * FUNCTION DS CL8 DATALEN DS F CALLRSLT DS F RTNCODE DS F ARGLIST DS F * WK5 DS CL5 WK9 DS CL9 DDNAME DS CL8 REQBUF DS CL255 NUMBUF DS CL255 KEYBUF DS CL255 * INAREA DS CL32767 * STOREND EQU * STORLEN EQU STOREND-STORAGE EJECT CVT DSECT=YES IRXENVB ; ENVIRONMENT BLOCK (R0 ON ENTRY) IRXEFPL DSECT=YES ; EXTERNAL FUNCTION PLIST (R1) IRXARGTB ; MAP THE ARGUMENT LIST. IRXSHVB ; SHARED VARIABLES BLOCK IRXEVALB ; EVALBLOCK TO RETURN RESULT. IRXEXTE ; EXTERNAL ENTRY POINTS END RXVSAM