From:	SMTP%"RELAY-INFO-VAX@CRVAX.SRI.COM" 17-MAY-1993 18:00:55.58
To:	EVERHART
CC:	
Subj:	RE: DCL calling procedure name

Date: Mon, 17 May 93 10:46:16 -0700
Message-Id: <9305171746.AA08175@atc.boeing.com>
From: mdc8567@k9.boeing.com (M.D.Clay, Boeing Computer Services, (206)234-7153)
To: "INFO-VAX@sri.com"@BCSAIC
Cc: M.D.Clay
Subject: RE: DCL calling procedure name

H.Davids (hdavids@muxgw1.ms.philips.nl) added subroutine names to 
the DCL traceback procedure.  Updated procedure follows my sig.

Cheers,

   Michael Clay               (206)234-7153
   Boeing Computer Services   claym@bcsaic.boeing.com
   Seattle, WA


$!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
$!
$! PROCEDURE: DCL_TRACEBACK.COM
$!
$! ABSTRACT:
$!
$!    Produces a traceback of the DCL command procedures/subroutines which
$!    called this procedure.
$!
$!    Tested on VAX/VMS versions V5.4 through V5.5-2.
$!
$! HISTORY:
$!
$!    15-MAY-1993  MDC  Written by M.D.Clay (claym@bcsaic.boeing.com)
$!                      Boeing Computer Services, Seattle, WA
$!                      (206)234-7153
$!
$!    17-MAY-1993  HD   Modified by H.Davids (hdavids@muxgw1.ms.philips.nl)
$!                      to add subroutine names to trace.
$!
$!-----------------------------------------------------------------------------
$!
$  vms =  f$extract(0,4,f$getsyi("version"))
$  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
$  idf_l_current_subroutine = %x00000074        ! idem
$!
$!
$! Get value of PRC_L_IDFLNK (changes with version of VMS) ...
$!
$  prc_l_idflnk =  0
$  if vms .eqs. "V5.4" then prc_l_idflnk = %x000000BC
$  if vms .eqs. "V5.5" then prc_l_idflnk = %x000000C0
$  if prc_l_idflnk .eq. 0
$  then
$     temp_file =  "sys$scratch:''fac'_''pid'.tmp"
$     search sys$system:dcldef.stb PRC_L_IDFLNK -
       /format=passall -
       /output='temp_file'
$     open/read temp_lun 'temp_file'
$     read temp_lun symbols
$     close temp_lun
$     delete/nolog 'temp_file';*
$     loc_sym =  f$locate("PRC_L_IDFLNK",symbols)
$     prc_l_idflnk =  f$cvui((loc_sym-5)*8,32,symbols)
$     msg =  -
       "!/!56*-!/Please add the following line to !AS.COM:!/!/" + -
       "   $  if vms .eqs. ""!AS"" then prc_l_idflnk = %x!XL!/!56*-!/"
$     write sys$output f$fao( msg , fac , vms , prc_l_idflnk )
$  endif
$!
$!
$! 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))
$  idf =  f$cvui(0,32,f$fao("!AD",4,idf+idf_l_lnk))      ! Skip our entry ...
$  NEXT_IDF:
$     if idf .eq. 0 then goto LAST_IDF
$     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)
$     subrname_ascic =  f$cvui(0,32,f$fao("!AD",4,idf+idf_l_current_subroutine))
$     if subrname_ascic .ne. 0
$     then
$        subrname_ascic = subrname_ascic + 35   ! FIXME
$        subrname_len   =  f$cvui(0,8,f$fao("!AD",1,subrname_ascic))
$        subrname       =  f$fao("!AD",subrname_len,subrname_ascic+1)
$     else
$        subrname = "<main>"
$     endif
$     filename =  f$element( 1 , "]" , filename )
$     if filename .nes. "]"
$     then
$        write sys$error f$fao("  !AS \ !AS", filename, subrname)
$     endif
$     idf =  f$cvui(0,32,f$fao("!AD",4,idf+idf_l_lnk))
$     goto NEXT_IDF
$  LAST_IDF:
$  exit

