Article 158342 of comp.os.vms:
I think the most amazing DCL trick I have seen is the use of the FAO
directive "!AD" to access values in memory. For example, the following
procedure displays the name of the procedure(s) which called it! (It
was originally written by Michael Clay, with a minor addition by me to
cleanup the temporary file).

$!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
$!
$! PROCEDURE: GET_CALLER.COM
$!
$! ABSTRACT:
$!
$!    This code fragment obtains the name of the procedure which called this
$!    procedure.
$!
$! HISTORY:
$!
$!    15-MAY-1993  MDC  Written by Michael Clay
$!
$!-----------------------------------------------------------------------------
$
$  fac =  f$parse(f$environment("procedure"),,,"name")
$  pid =  f$getjpi(0,"pid")
$!
$!
$! Define known symbol values ...
$!
$  ctl$ag_clidata =  %x7FFE2A5C   ! From SYS$SYSTEM:SYS.STB
$  ppd$l_prc      =  %x00000008   ! From SYS$SYSTEM:DCLDEF.STB
$  idf_l_lnk      =  %x00000000   ! From SYS$SYSTEM:DCLDEF.STB
$  idf_l_filename =  %x00000068   ! From SYS$SYSTEM:DCLDEF.STB
$!
$!
$! Get value of PRC_L_IDFLNK from DCLDEF.STB (changes with version of VMS) ...
$!
$  temp_file =  "sys$scratch:''fac'_''pid'.tmp"
$  on warning then goto FINISH
$  on control_y then goto FINISH
$  search sys$system:dcldef.stb PRC_L_IDFLNK /exact /format=passall /output='temp_file'
$  open/read temp_file 'temp_file'
$  read temp_file symbols
$  close temp_file
$  delete/nolog 'temp_file';*
$  loc_sym =  f$locate("PRC_L_IDFLNK",symbols)
$  prc_l_idflnk =  f$cvui((loc_sym-5)*8,32,symbols)
$!
$! Traverse IDF list
$!
$  ppd =  ctl$ag_clidata
$  prc =  f$cvui(0,32,f$fao("!AD",4,ppd+ppd$l_prc))
$  idf =  f$cvui(0,32,f$fao("!AD",4,prc+prc_l_idflnk))
$  next_filename:
$     if idf .eq. 0 then goto FINISH
$     filename_ascic =  f$cvui(0,32,f$fao("!AD",4,idf+idf_l_filename))
$     filename_len   =  f$cvui(0,8,f$fao("!AD",1,filename_ascic))
$     filename       =  f$fao("!AD",filename_len,filename_ascic+1)
$     write sys$output " -> ",filename
$     idf =  f$cvui(0,32,f$fao("!AD",4,idf+idf_l_lnk))
$     goto next_filename
$!
$FINISH:
$ set noon
$ close/nolog temp_file
$ if f$search(temp_file) .nes. "" then delete/nolog 'temp_file';*
$ exit
$!-----------------------------------------------------------------------

-- 
Ken Bosward, VMS Systems Administrator, BHP Ltd.
E-mail: bosward.ken.kw@bhp.com.au


