I am attempting to post the assembler program here for reference, we'll see if
the listserv accepts it without mangling.
To use, call it passing the area you want it to return the calling program name
in. The call_level_e equate controls how many levels up it goes.
----------------------
&thispgm setc 'CALLERID'
title '&thispgm - Return name of program caller'
&thispgm csect
&thispgm amode 31
&thispgm rmode any
using *,r15
sysstate archlvl=OSREL, generate z/Architecture code +
osrel=SYSSTATE
macro , sysdatc can't be in open code
get_asmtime
gblc &asmtime
&d setc '&sysdatc' date as YYYYMMDD
&t aread clockd time as HHMMSSTH
&date setc '&d'(1,4).'-'.'&d'(5,2).'-'.'&d'(7,2) formatted date
&time setc '&t'(1,2).':'.'&t'(3,2).':'.'&t'(5,2) formatted time
&asmtime setc '&date &time'
mend
gblc &asmtime get assembly date & time
get_asmtime
j start skip over program id
dc al1(l'prog_id) count byte for program id
prog_id dc c'&thispgm &asmtime'
savearea dc 18f'0' save area and my base address
start bsm r14,r0 put caller's AMODE in r14
stm r14,r12,12(r13) save caller's registers
lr r2,r13 r2 -> caller's save area
la r13,savearea r13 -> my save area & base
st r13,8(,r2) set forward chain from caller
st r2,4(,r13) set backward chain to caller
drop r15
using savearea,r13 r13 is my base register
sr r15,r15 clear return code
l r14,=a(mainline+x'80000000') set 31 bit mode
bsm r0,r14 branch to mainline
eojgood sr r15,r15 good return: rc = 0
eoj l r13,4(,r13) point back to caller's save area
st r15,16(,r13) set return code
lm r14,r12,12(r13) restore caller's registers
oi 15(r13),x'01' set return indication
bsm r0,r14 return to caller & caller's mode
call_level_e equ 2 How many programs up do we go?
* Return codes:
* 0 - CALL LEVEL caller found, name returned
* 4 - Requested CALL LEVEL not found. Highest caller returned.
* 8 - Incorrect usage: CALLERID directly called by MVS or no
* parm provided. No caller returned.
*
* Registers:
* R0 - Standard system use, work register
* R1 - Standard system use, work register
* R2 - Standard system use
* R3 - Caller name parm
* R4 - Loop counter
* R5 - Save area chain pointer
* R6 - Entry point of caller
* R7 - Language Environment Program Prolog Area 1 (PPA1)
* R8 - Name of caller
* R9 -
* R10 -
* R11 -
* R12 -
* R13 - Base register, save area pointer
* R14 -
* R15 - Standard system use
mainline ds 0h
ltr r1,r1 if called with no parm
jnz main_l000
la r15,8 rc=8: usage error
j eoj return
main_l000 ds 0h end if
l r3,0(,r1) save caller name parm address
using caller_name_dsect,r3
la r4,call_level_e r4 = number of callers to find
sr r6,r6 init r6 to no entry point
sr r8,r8 init r8 to no callers found
l r5,savprev-saver(,r13) r5 -> my caller's save area
using saver,r5
main_l100 ds 0h do CALL LEVEL times
l r5,savprev climb chain
ltr r5,r5 if end of chain
jnz main_l120
ltr r8,r8 if no callers found
jnz main_l110
la r15,8 rc=8: usage error
j eoj return
main_l110 ds 0h else
la r15,4 rc=4: Not enough calls
j main_l190 found, leave
* end if
main_l120 ds 0h end if
l r1,savgrs15 r1 = candidate entry point
la r1,0(,r1) clear mode bit
cr r6,r1 if same as last entry point
je main_l100 iterate
lr r6,r1 r6 -> entry point
clc le_signature_c,5(r6) if not Lang Environment prog
je main_l130
la r8,5(,r6) use program id for caller
j main_l150
main_l130 ds 0h else
lr r7,r6 r7 -> Program Prolog Area
a r7,12(,r6)
tm 2(r7),x'10' if this is library object
jo main_l100 iterate
llc r0,0(,r7) r0 = offset to name length
cli 4(r6),x'01' if FASTLINK format PPA
jne main_l140
sll r0,1 offset is offset * 2
main_l140 ds 0h end if
ark r8,r7,r0 r8 -> entry name length
la r8,2(,r8) use entry name for caller
main_l150 ds 0h end if
jct r4,main_l100 -1 from remaining calls
main_l190 ds 0h end do
mvc caller_name_l,0(r8) move name to caller parm
j eoj return
yregs , register equates
ltorg , literal pool
le_signature_c dc c'CEE' Language Environment eye catcher
caller_name_dsect dsect
caller_name_l ds cl8 caller name (returned)
ihasaver savf4sa=NO,savf5sa=NO,savf7sa=NO,savf8sa=NO
end
----------------------------------------------------------------------
For IBM-MAIN subscribe / signoff / archive access instructions,
send email to [email protected] with the message: INFO IBM-MAIN
