GBLC &LEVEL;
&LEVEL; SETC '1.00'
IXCADEMO TITLE '-- Information and prologue for IXCADEMO v&LEVEL; (ARM +
services sample program)'
IXCADEMO CSECT
IXCADEMO AMODE 31
IXCADEMO RMODE ANY
SPACE ,
*/* START OF SPECIFICATIONS *******************************************
*
*
*01* MODULE-NAME = IXCADEMO
*
*02* DESCRIPTIVE-NAME = Sample program to use ARM services.
*
*01* PROPRIETARY STATEMENT:
*
* LICENSED MATERIALS - PROPERTY OF IBM
* THIS MACRO IS "RESTRICTED MATERIALS OF IBM"
* 5655-068 (C) COPYRIGHT IBM CORP. 1994
* SEE COPYRIGHT INSTRUCTIONS
*
* STATUS = HBB5520
*
*01* FUNCTION =
* Sample program to illustrate use of ARM services: Register,
* WaitPred, Ready and Deregister.
*
*02* OPERATION =
*
* 1) Go to supervisor state.
* 2) Put out informational messages. Wait on WTOR.
* 3) Issue IXCARM Request=Register. Put out return/reason
* codes. Wait on WTOR.
* 4) If a restart, issue IXCARM Request=WaitPred. Put out
* return/reason codes. Wait on WTOR.
* 5) Issue IXCARM Request=Ready. Put out return/reason codes.
* Wait on WTOR.
* 6) Issue IXCARM Request=Deregister. Put out return/reason
* codes. Wait on WTOR.
* 7) Put out informational message.
* 8) Go to problem state.
*
* Example is written reentrantly. *
* *
**** END OF SPECIFICATIONS *******************************************/
SPACE ,
***********************************************************************
* *
* To link-edit this program, use statements like these: *
* *
* //LINK EXEC PGM=IEWL, *
* // PARM='XREF,MAP,LIST,RENT,LET,NCAL' *
* //SYSLMOD DD DSN=load_library,DISP=SHR *
* //OBJECT DD DSN=object_library,DISP=SHR *
* //SYSUT1 DD UNIT=SYSDA,SPACE=(CYL,(1,1)) *
* //SYSPRINT DD SYSOUT=* *
* //SYSLIN DD * *
* INCLUDE OBJECT(IXCADEMO) object module *
* ORDER IXCADEMO this csect first, for debugging *
* PAGE IXCADEMO page align, for debugging *
* ENTRY IXCADEMO this csect is entry point *
* MODE AMODE(31),RMODE(ANY) *
* SETCODE AC(1) *
* NAME IXCADEMO(R) *
* *
* The load library must be an APF library. *
* *
***********************************************************************
EJECT ,
USING IXCADEMO,R15
B START branch around constants
SPACE
DC AL1(ENDCON-*-1) length of constants
DC C' '
MODLNAME DC C'IXCADEMO' module name
DC C' V&LEVEL ' version
DC C'&SYSDATE ' date assembled
DC C'&SYSTIME ' time assembled
DC AL2(CSECTEND-IXCADEMO) length of CSECT
ENDCON DS 0C
SPACE
START DS 0H
STM R14,R12,12(R13) save caller's registers
LR R12,R15 load entry addr
DROP R15
USING IXCADEMO,R12 permanent addressability
SPACE
STORAGE OBTAIN, get working storage +
LENGTH=WORKLEN1, +
BNDRY=PAGE, +
LOC=(ANY,ANY)
SPACE
LR R2,R1 save addr of area
LR R14,R1 load addr of work area to be zeroed
L R15,=A(WORKLEN1) load length to be zeroed
SLR R1,R1 set padding byte & count to zero in +
source (R0 won't matter)
MVCL R14,R0 propagate X'00' from padding byte
SPACE
ST R13,4(,R2) save backward pointer to caller
ST R2,8(,R13) save forward pointer to this CSECT
LR R13,R2 point to workarea
USING WORKAREA,R13 save/work addressability
SPACE ,
* Save information useful for ABEND recovery and ABEND debugging
SPACE ,
MVC WORKID(L'MODLNAME),MODLNAME copy module name
MVC WORKID+L'MODLNAME(L'SAVECN),SAVECN copy rest
ST R12,BASESAVE save base register
ST R13,SAVESAVE save R13 of this routine
TITLE '-- ARM-related front-end for IXCADEMO'
MODESET MODE=SUP get supervisor state for ARM requests
SPACE ,
***********************************************************************
* *
* Build and issue entry message. *
* *
***********************************************************************
SPACE ,
MVC WTODYN(ENTRYMW),ENTRYM copy static message
USING PSA,R0
L R1,PSAAOLD point to ASCB
USING ASCB,R1
ICM R2,15,ASCBJBNI point to job name, if any
BNZ COPYNAME skip if a non-zero address
L R2,ASCBJBNS point to STC name
COPYNAME DS 0H
MVC SAVNAME(8),0(R2) copy name
MVC WTODYN+(ENTNAME-ENTRYM)(8),SAVNAME copy name
L R1,PSATOLD point to current task's TCB
USING TCB,R1
SLR R2,R2 ensure high byte is zero
ICM R2,7,TCBJSCBB get 24-bit JSCB address
USING IEZJSCB,R2
L R2,JSCBACT point to active JSCB
L R2,JSCBSSIB point to life-of-job SSIB
USING SSIB,R2
MVC SAVJESID,SSIBJBID copy JESx id
MVC WTODYN+(ENTJESID-ENTRYM)(8),SAVJESID copy JESx id
DROP R0,R1,R2
SPACE ,
WTO MF=(E,WTODYN) say starting
EJECT ,
BAL R14,SAYIT wait for response to a WTOR
SPACE ,
***********************************************************************
* *
* Ask to be registered. *
* *
***********************************************************************
SPACE ,
IXCARM REQUEST=REGISTER, get registered +
ELEMENT=ELEMNAME, element name +
EVENTEXIT=EVTEXTNM, event exit name +
EVENTEXITPL=EVTEXTPR, event exit parameter list +
EXITPLLEN=EVTEXTPL, event exit parameter list length +
RESTARTTIMEOUT=NORM, normal timeout interval +
ANSAREA=LCLANSWR, answer area +
RETCODE=SAVERC, return code +
RSNCODE=SAVERSN, reason code +
MF=(E,IXCARML) parameter list area
SPACE ,
* Put out return and reason codes.
MVC SAVESERV,=CL10'Register'
BAL R14,SAYRC say RC/RSN codes
SPACE ,
* See whether registered, perhaps as a restarted job or STC.
CLC SAVERC,=A(IXCARMRC4) rc=0 or =4?
BNH CHKREG skip if registered or re-registered
* Something wrong, RC>4.
EX R0,* cause 0C3 for dump
SPACE ,
* Determine whether this is a new registration or a registration after
* being restarted, and act accordingly.
CHKREG DS 0H
LA R2,LCLANSWR point to answer area (not actually +
used)
USING ARAA,R2 map answer area
SPACE ,
BAL R14,SAYIT wait for response to a WTOR
SPACE ,
DROP R2
CLC SAVERC,=A(IXCARMRC0) rc=0 (not restarted)?
BE DOREADY if yes, proceed
EJECT ,
* This is a restart.
BAL R14,SAYIT wait for response to a WTOR
SPACE ,
***********************************************************************
* *
* Wait for any restarted, predecessor elements. *
* *
***********************************************************************
SPACE ,
IXCARM REQUEST=WAITPRED, wait for any predecessor elements +
RETCODE=SAVERC, return code +
RSNCODE=SAVERSN, reason code +
MF=(E,IXCARML) parameter list area
SPACE ,
MVC SAVESERV,=CL10'WaitPred'
BAL R14,SAYRC say RC/RSN codes
SPACE ,
CLC SAVERC,=A(IXCARMRC4) rc=0 or =4?
BNH DOREADY skip if OK
* Something wrong, RC>4.
EX R0,* cause 0C3 for dump
EJECT ,
DOREADY DS 0H
BAL R14,SAYIT wait for response to a WTOR
SPACE ,
***********************************************************************
* *
* Say ready. *
* *
***********************************************************************
SPACE ,
IXCARM REQUEST=READY, say ready +
RETCODE=SAVERC, return code +
RSNCODE=SAVERSN, reason code +
MF=(E,IXCARML) parameter list area
SPACE ,
MVC SAVESERV,=CL10'Ready'
BAL R14,SAYRC say RC/RSN codes
SPACE ,
CLC SAVERC,=A(IXCARMRC4) rc=0 or =4?
BNH MAINLINE skip if OK
* Something wrong, RC>4.
EX R0,* cause 0C3 for dump
TITLE '-- Mainline for IXCADEMO'
***********************************************************************
* *
* The real reason (whatever it is) why we're here. *
* *
* The substantive application code would be here. *
* *
***********************************************************************
SPACE ,
MAINLINE DS 0H
TITLE '-- ARM-related backend for IXCADEMO'
BAL R14,SAYIT wait for response to a WTOR
SPACE ,
***********************************************************************
* *
* Now deregister and terminate. *
* *
***********************************************************************
SPACE ,
IXCARM REQUEST=DEREGISTER, get deregistered +
RETCODE=SAVERC, return code +
RSNCODE=SAVERSN, reason code +
MF=(E,IXCARML) parameter list area
SPACE ,
MVC SAVESERV,=CL10'Deregister'
BAL R14,SAYRC say RC/RSN codes
SPACE ,
CLC SAVERC,=A(IXCARMRC0) rc=0?
BNH DONE skip if OK
* Something wrong, RC>0.
EX R0,* cause 0C3 for dump
EJECT
***********************************************************************
* *
* Terminate. *
* *
***********************************************************************
SPACE ,
DONE DS 0H
SPACE ,
***********************************************************************
* *
* Build and issue exit message. *
* *
***********************************************************************
SPACE ,
MVC WTODYN(EXITMW),EXITM copy static message
MVC WTODYN+(EXTNAME-EXITM)(8),SAVNAME copy name
MVC WTODYN+(EXTNAME-EXITM)(8),SAVNAME copy name
MVC WTODYN+(EXTJESID-EXITM)(8),SAVJESID copy JESx id
SPACE ,
WTO MF=(E,WTODYN)
SPACE ,
MODESET MODE=PROB back to problem state
SPACE ,
L R2,SAVEAREA+4 save caller's R13
LH R11,RCHALF save return code
LR R1,R13 point to working storage
SPACE ,
STORAGE RELEASE, free working storage +
ADDR=(R1), address of area to be freed +
LENGTH=WORKLEN1
SPACE ,
LR R13,R2 restore caller's R13
XC 8(4,R13),8(R13) clear forward pointer of caller
L R14,12(,R13) restore caller's registers
LR R15,R11 set return code
LM R0,R12,20(R13) restore caller's registers
BR R14 return to caller
TITLE '-- SAYIT, subroutine to wait'
***********************************************************************
* *
* Subroutine to wait on a WTOR. *
* *
***********************************************************************
SPACE
SAYIT DS 0H
STM R0,R15,SAVEREGS save entry registers
SPACE
MVC WTODYN(WTORMWT),WTORM
SPACE
* Convert R12 to hex-like EBCDIC.
ST R12,FULLWORK
NC FULLWORK,=X'7FFFFFFF' turn off any AMODE(31) bit
UNPK DBLWORK(9),FULLWORK(5)
MVC WTODYN+(WTORR12-WTORM)(8),DBLWORK
TR WTODYN+(WTORR12-WTORM)(8),TRTTABLE
SPACE
* Convert R13 to hex-like EBCDIC.
ST R13,FULLWORK
UNPK DBLWORK(9),FULLWORK(5)
MVC WTODYN+(WTORR13-WTORM)(8),DBLWORK
TR WTODYN+(WTORR13-WTORM)(8),TRTTABLE
SPACE
* Convert PASN to hex-like EBCDIC.
EPAR R1 get PASN
ST R1,FULLWORK
UNPK DBLWORK(5),FULLWORK+2(3)
MVC WTODYN+(WTORASID-WTORM)(4),DBLWORK
TR WTODYN+(WTORASID-WTORM)(4),TRTTABLE
SPACE
* Convert TCB address to hex-like EBCDIC.
USING PSA,R0
UNPK DBLWORK(9),PSATOLD(5)
MVC WTODYN+(WTORTCB@-WTORM)(8),DBLWORK
TR WTODYN+(WTORTCB@-WTORM)(8),TRTTABLE
SPACE
* Convert RB address to hex-like EBCDIC.
L R1,PSATOLD get TCB address
USING TCB,R1
UNPK DBLWORK(9),TCBRBP(5)
MVC WTODYN+(WTORRB@-WTORM)(8),DBLWORK
TR WTODYN+(WTORRB@-WTORM)(8),TRTTABLE
DROP R0,R1
SPACE
* Convert point count to EBCDIC.
L R1,POINTCT get current count
LA R1,1(,R1) and add one
ST R1,POINTCT and save
L R0,POINTCT
CVD R0,DBLWORK
UNPK WTODYN+(WTORPT#-WTORM)(3),DBLWORK(8)
OI WTODYN+(WTORPT#-WTORM)+2,C'0'
SPACE
* Put out WTOR.
XC WTORECB,WTORECB ensure ECB zero
WTOR ,WTORRPLY, field to get reply +
1, length of reply +
WTORECB, ECB that'll be waited on +
MF=(E,WTODYN)
SPACE
* Wait on reply to WTOR.
WAIT ECB=WTORECB
SPACE
LM R0,R15,SAVEREGS load entry registers
BR R14 back to caller
TITLE '-- SAYRC, subroutine to report RC/RSN codes'
***********************************************************************
* *
* Subroutine to announce return and reason codes from an IXCARM ser- *
* vice. *
* *
***********************************************************************
SPACE
SAYRC DS 0H
STM R0,R15,SAVEREGS save entry registers
SPACE
MVC WTODYN(SERVMW),SERVM copy static message
MVC WTODYN+(SERVSRVC-SERVM)(10),SAVESERV copy service name
SPACE
* Convert return code to hex-like EBCDIC
UNPK DBLWORK(9),SAVERC(5)
MVC WTODYN+(SERVRC-SERVM)(8),DBLWORK
TR WTODYN+(SERVRC-SERVM)(8),TRTTABLE
SPACE
* Convert reason code to hex-like EBCDIC
UNPK DBLWORK(9),SAVERSN(5)
MVC WTODYN+(SERVRSN-SERVM)(8),DBLWORK
TR WTODYN+(SERVRSN-SERVM)(8),TRTTABLE
SPACE ,
WTO MF=(E,WTODYN) issue WTO
SPACE
LM R0,R15,SAVEREGS load entry registers
BR R14 back to caller
TITLE '-- Constants'
***********************************************************************
* *
* Constants *
* *
***********************************************************************
SPACE
SAVECN DC C' Savework Area'
SPACE
ELEMNAME DC CL16'IXCADEMO' element name
EVTEXTNM DC CL8'IEFBR14' event exit name
SPACE
EVTEXTPR DS 0F event exit parameter list
DC C'This is a parameter list'
EVTEXTLL EQU *-EVTEXTPR length of parameter list
EVTEXTPL DC A(L'EVTEXTPR) event exit parameter list length
SPACE ,
* Entry message.
ENTRYM DS 0X
DC AL1(0),AL1(ENTRYMW),AL2(0) WTO header
ENTRYMX DC C'ARMD1001I ' message prefix
DC C'IXCADEMO v&LEVEL in '
ENTNAME DS CL8 address space name
DC C'('
ENTJESID DS CL8 JES id
DC C') starting'
ENTRYMT EQU *-ENTRYMX length for TPUT
ENTRYMW EQU ENTRYMT+4 length for WTO
SPACE ,
* Exit message.
EXITM DS 0X
DC AL1(0),AL1(EXITMW),AL2(0) WTO header
EXITMX DC C'ARMD1002I ' message prefix
DC C'IXCADEMO v&LEVEL in '
EXTNAME DS CL8 address space name
DC C'('
EXTJESID DS CL8 JES id
DC C') finishing'
EXITMT EQU *-EXITMX length for TPUT
EXITMW EQU EXITMT+4 length for WTO
SPACE ,
* WTOR message.
WTORM DS 0X
DS 2FL4 addr of reply and of ECB
DC AL1(0),AL1(WTORMW),AL2(0) WTO header
WTORMX DC C'ARMD1003I ' message prefix
DC C'R12='
WTORR12 DS CL8
DC C', R13='
WTORR13 DS CL8
DC C', ASN='
WTORASID DS CL4
DC C', TCB at '
WTORTCB@ DS CL8
DC C', RB at '
WTORRB@ DS CL8
DC C', point '
WTORPT# DS CL3
DC C'; reply with anything'
WTORMT EQU *-WTORMX length for TPUT
WTORMW EQU WTORMT+4 length for WTO
WTORMWT EQU WTORMT+12 length for WTOR
SPACE ,
* Service (RC, RSN and type) message.
SERVM DS 0X
DC AL1(0),AL1(SERVMW),AL2(0) WTO header
SERVMX DC C'ARMD1004I ' message prefix
DC C'Service = '
SERVSRVC DS CL10
DC C', RC='
SERVRC DS CL8
DC C', RSN='
SERVRSN DS CL8
SERVMT EQU *-SERVMX length for TPUT
SERVMW EQU SERVMT+4 length for WTO
SPACE ,
* The following has to be at least 240 bytes into the CSECT
TRTTABLE EQU *-240
DC C'0123456789ABCDEF'
TITLE '-- Literals'
***********************************************************************
* *
* Literals *
* *
***********************************************************************
SPACE ,
LTORG
TITLE '-- Save/work area'
***********************************************************************
* *
* Save/work area DSECT *
* *
***********************************************************************
SPACE
WORKAREA DSECT
SAVEAREA DS 18F register save area
WORKID DS CL(L'MODLNAME+L'SAVECN) EBCDIC identifier
DS 0D alignment
BASESAVE DS A saved base register of IXCADEMO
SAVESAVE DS A saved R13 of caller
SAVEREGS DS 16F savearea for subroutines
SPACE
***********************************************************************
* *
* IXCARM's parameter list area. *
* *
***********************************************************************
SPACE
IXCARM MF=(L,IXCARML)
SPACE
FULLWORK DS F
SAVERC DS F return code from IXCARM service
SAVERSN DS F reason code from IXCARM service
WTORECB DS F ECB for WTOR/WAIT
POINTCT DS F WTOR/WAIT point number
FLAGS DS 0F
FLAG1 DS X
FLAG2 DS X
FLAG3 DS X
FLAG4 DS X
WTORRPLY DS X 1-byte reply area for WTOR
RCHALF DS H return code halfword
ORG *-1
RC DS X return code
SAVNAME DS CL8 job/STC name
SAVJESID DS CL8 JESx id
SPACE
LCLANSWR DS XL32 answer area
SAVESERV DS CL12 service name for message
DS 0F alignment for WTODYN
WTODYN DS CL136
DS 0D doubleword align
DBLWORK DS CL16
DS 0D doubleword align end of WORKAREA
SPACE
WORKLEN1 EQU *-WORKAREA length of workarea
TITLE '-- DSECTs and EQUs'
***********************************************************************
* *
* DSECTs, EQUs & whatnot *
* *
***********************************************************************
SPACE
PRINT NOGEN
YREGS , register EQUs
IHAPSA , PSA mapping
IHAASCB , ASCB mapping
IKJTCB , TCB mapping
IEZJSCB , JSCB mapping
IEFJSSIB , SSIB mapping
IXCYARM , ARM return and reason codes
IXCYARAA , ARM answer area mapping
SPACE
IXCADEMO CSECT ensure resumed CSECT
CSECTEND DS 0D
END
z/OS MVS Programming: Sysplex Services Guide
Copyright IBM Corporation 1990, 2014