From:	MERC::"uunet!CRVAX.SRI.COM!RELAY-INFO-VAX" 20-MAR-1993 01:09 20-MAR-1993 01:09:00.00
To:	Info-VAX@KL.SRI.COM
CC:	
Subj:	Re: get name of calling routine in FORTRAN (w/ code)


> Does anybody know of a way to do the following in VAX FORTRAN:
> PROGRAM MAIN
> ...
> CALL XYZZY
> ...
> END
>
> SUBROUTINE SUB
> ...
> CALL XYZZY
> ...
> RETURN
> END
> SUBROUTINE XYZZY
> character*30 routine
> integer line
> ... <--- smart code here that does the trick
> WRITE(*,*)'XYZZY was called from routine',routine,'line ',line
> RETURN
> END
> 
> Thanks in advance!
> 

I wrote a few lines of code back in 1986 or 1987 when I was learning about
various VMS linker/image file related issues.  I never used it for anything,
(i.e. it's still very crude) but it may be enlightening.  It could probably
be modified to decode DEBUG packets as well as TRACEBACK packets - you could
get the line number that way.

The output should look something like this:

TEST                            00000C34         3124
DO_TEST                         00000C19         3097
TEST_MAIN                       00000C09         3081

Where the first column holds the routine name, and the second and third
columns hold the PC (in hex and dec).

Instructions:

1) Separate TEST.FOR, PC_TO_NAME.FOR, PC_TO_NAME.INC, and GETPC.MAR
2) Compile TEST.FOR and PC_TO_NAME.FOR
3) Assemble GETPC.MAR
4) $ link test,pc_to_name,getpc	! MUST be linked /trace !
5) $ run test

================================TEST.FOR===================================
	program test_main
	call do_test
	end

	subroutine do_test
	call test1
	end

	subroutine test1
	implicit none
	integer*4 pc,getpc,i
	character name*31
	i=0
	pc=getpc(i)
	do while (pc .ge. 0)
	  call pc_to_name(pc,name)
	  write(*,'(X,A31,X,Z8.8,X,I)')name,pc,pc
	  i=i+1
	  pc=getpc(i)
	enddo
	end
===========================PC_TO_NAME.FOR==================================
	subroutine pc_to_name(pc,name)
	implicit none
	include 'pc_to_name.inc'
	logical*1 done
	integer*4 pc,filenamelen,imagelun,status,block,pos,old_base
	character name*31,filename*252,record*512,old_name*31
	record /packet/ packet
	record /itmlst/ jpi(2)
	record /header/ header
	record /gst/ gst
	external jpi$_imagname
!
!	Get image file name
!
	jpi(1).buflen=252
	jpi(1).code=%loc(jpi$_imagname)
	jpi(1).bufadr=%loc(filename)
	jpi(1).retlenadr=%loc(filenamelen)
	jpi(2).end_list=0
	call sys$getjpi(,,,jpi,,,)
!
!	Open image file
!
	call lib$get_lun(imagelun)
	open(unit=imagelun,file=filename,recl=128,readonly,shared,
	1	form='unformatted',status='old',iostat=status,
	1	access='direct')
	if (status .eq. 0) then
	  read(imagelun,rec=1)record
	  header.string=record(1:44)
	  gst.string=record(header.offset_C+1:header.offset_C+20)
	  block=gst.dstvbn
	  pos=0
	  old_base=0
	  done=.false.
	  name=' '
	  do while (.not. done)
	    call get_packet(imagelun,packet,block,pos,done)
	    if (packet.type .eq. -66) then
	      if (pc .ge. old_base .and. pc .lt. packet.base) then
	        name=old_name
	        done=.true.
	      else
	        old_base=packet.base
	        old_name=packet.name
	      endif
	    endif
	  enddo
	  if (name .le. ' ') write(name,'(Z8.8)')pc
	endif
	close(imagelun)
	call lib$free_lun(imagelun)
	return
	end

	integer*4 function get_byte(lun,byte,block,pos)
	implicit none
	character byte,record*512
	integer*4 block,pos,lun
	if (pos .eq. 0 .or. pos .eq. 512) then
	  if (pos .eq. 512) block=block+1
	  read(lun,rec=block,iostat=get_byte)record
	  pos=0
	endif
	pos=pos+1
	byte=record(pos:pos)
	return
	end

	subroutine get_packet(lun,packet,block,pos,eof)
	implicit none
	include 'pc_to_name.inc'
	record /packet/ packet
	logical*1 eof
	integer*4 status,i,get_byte,block,pos,lun
	eof=.false.
	status=get_byte(lun,packet.string(1:1),block,pos)
	if (packet.len .gt. 0 .and. status .eq. 0) then
	  packet.name=' '
	  do i=2,2+packet.len-1
	    status=get_byte(lun,packet.string(i:i),block,pos)
	  enddo
	else
	  eof=.true.
	endif
	return
	end
==============================PC_TO_NAME.INC===============================
	structure /header/
	  union
	  map
	    integer*2 size,offset_b,offset_c,offset_d,offset_e,
	1	spare1,maj_id,min_id
	    byte blocks,type
	    integer*2 spare2
	    integer*4 priv(2)
	    integer*2 io_chan,seg
	    integer*4 flags,gblsec_id,version,iafva
	  end map
	  map
	    character string*44
	  end map
	  end union
	end structure

	structure /gst/
	  union
	  map
	    integer*4 dstvbn,gstvbn
	    integer*2 dstblks,gstrecs
	    integer*4 fill(2)
	  end map
	  map
	    character string*20
	  end map
	  end union
	end structure

	structure /itmlst/
	  union
	  map
	    integer*2 buflen,code
	    integer*4 bufadr,retlenadr
	  end map
	  map
	    integer*4 end_list
	  end map
	  end union
	end structure

	structure /packet/
	  union
	  map
	    byte len,type,flag
	    integer*4 base
	    byte namlen
	    character name*31
	  end map
	  map
	    character string*255
	  end map
	  end union
	end structure
=================================GETPC.MAR=================================
	.title	getpc
	$sfdef
	.psect	$code,pic,con,rel,lcl,shr,exe,rd,nowrt,long
	.entry	getpc	^M<>

	moval	(FP),R0
	clrl	R1

10$:	incl	R1
	cmpl	R1,@4(AP)
	bgtr	20$
	movl	sf$l_save_fp(R0),R0
	brb	10$

20$:	movl	sf$l_save_pc(R0),R0
	ret

	.end
-- 
--------------------------------------------------------------------------------
William P. Bame                    | sneakernet: William P. Bame
internet: bill@office.ab.umd.edu   |             M.I.E.M.S.S.
          bbame@achi1.ab.umd.edu   |             22 South Greene Street
AT&T    : [Work] (410) 328-3062    |             Baltimore, MD 21201
CIS     : 71620,425                |             Room: T1R55
--------------------------------------------------------------------------------

