From: system@SendSpamHere.ORG
Sent: Thursday, January 27, 2000 11:41 AM
To: Info-VAX@Mvb.Saic.Com
Subject: Re: Finding out the filename of the calling DCL procedure.

In article <389066E0.ECFF1D16@ubs.com>, Nicholas Barnes <nicholas-za.barnes@ubs.com> writes:
>OK, here's a little problemette which has been taxing us for a couple of days.
>
>It's not important or mission critical, but we figure that there must be an
>answer and it's annoying us.
>
>Consider two .COM files, ONE.COM and TWO.COM.
>
>ONE.COM has defined no logicals and no symbols, it runs TWO.COM with the
>parameterless command: @TWO
>
>The question is, is there any way that the code in TWO.COM can determine from
>which procedure it was called (i.e. derive the name ONE.COM from somewhere)?
>
>Now, the machine must have the details - after all, how does it know to return
>you to ONE.COM when TWO.COM has finished running? So, how do I get that
>information?
>
>Yes, there are several ways of doing it by actually passing TWO.COM the
>information in a logical/symbol/parameter, but we are looking for a way for
>TWO.COM to work out for itself what the information is.
>
>Any ideas?
>
>Nick.

Hackery anyone?

The following will return the previous procedure file spec in a DCL symbol
called PREVIOUS_PROCEDURE.

;++
; Copyright © 1993 - 1998  by Brian Schenkenberger and TMESIS.
; ALL RIGHTS RESERVED.
;                            Notice of Disclaimer
;                         -------------------------
; 
; This Software is provided "AS IS" and is supplied for informational purpose
; only.  No warranty is expressed or implied and no liability can be accepted
; for any direct, indirect or consequential damages or for any damage whatso-
; ever resulting in the loss of systems, data or profit from the use of this
; software or from any of the information contained herein.  The author makes
; no claims as to the suitablility or fitness of this Software or information
; contain herein for any particular purpose.  
;
;                         -------------------------
; NO TITLE TO AND/OR OWNERSHIP OF THIS SOFTWARE IS HEREBY TRANSFERRED.  ANY
; MODIFICATION WITHOUT THE PRIOR WRITTEN CONSENT OF THE COPYRIGHT HOLDER IS
; PROHIBITED.  ANY USE, IN WHOLE OR PART, OF THIS SOFTWARE FOR A COMMERCIAL
; PRODUCT WITHOUT THE PRIOR WRITTEN CONSENT OF THE COPYRIGHT HOLDER IS ALSO
; PROHIBITED.  THE TECHNIQUES EMPLOYED IN THE SOFTWARE ARE THE INTELLECTUAL
; PROPERTY OF THE COPYRIGHT HOLDER. 
;--

;++
.SBTTL	Determine the target architecture
;--
	.NTYPE	...ON_ALPHA...,R31
	.IIF EQ,<...ON_ALPHA...@-4&^XF>-5, ALPHA=0
	.IIF DF,ALPHA, .DISABLE	FLAGGING

;++
.SBTTL	Primitive program datum definitions
;--
	ZERO = 0		; |_ 
	BYTE = 1@0		; |_|_ 
	WORD = 1@1		; |___|___ 
	LONG = 1@2		; |_______|_______
	QUAD = 1@3		; |_______________|_______________
	OCTA = 1@4		; |_______________|_______________|
	PAGE = 1@9		; VAX page ; Alpha Pagelet
	BLOCK= 1@9		; Standard disk block size

;++
; The following macro is used to check the return status of system calls.
; It can take up to three arguments:
;   STS ...... register or memory containing the status value
;   ERROR .... instruction to execute if an error is detected
;   NORMAL ... change status to a success before taking ERROR
;--
	.MACRO	CHKSTS,STS=<R0>,NORMAL=<NO>,ERROR=<RET>,?LBL
	.IIF DIF,<R0>,<STS>,	MOVZWL	STS,R0
	.IIF IDN,<NORMAL>,<NO>,	BLBS	R0,LBL
	.IIF DIF,<NORMAL>,<NO>,	BBSS	#0,R0,LBL
	.IRP	ERR,<ERROR>
	.SHOW	MEB
	ERR
	.NOSHOW	MEB
	.ENDR
LBL:	.ENDM	CHKSTS

	.LIBRARY	"SYS$LIBRARY:STARLET.MLB"	; look here for:

	$DSCDEF
	$SSDEF

	.PSECT	DATA,WRT,NOEXE,5
PREV_PROC:	.ASCID	/PREVIOUS_PROCEDURE/
		.ALIGN	QUAD
FILENAME_DSC:	.LONG	<DSC$K_CLASS_S@<DSC$B_CLASS@3>>!-
                        <DSC$K_DTYPE_T@<DSC$B_DTYPE@3>>!0
		.ADDRESS	FILENAME_STR
FILENAME_STR:	.BYTE	^a" "[255]

	.PSECT	CODE,NOWRT,EXE,5
	.ENTRY	GO,0
	$CMEXEC_S	-
			routin	= GET_IDF_FILENAME
	CHKSTS

	PUSHAL	#LIB$K_CLI_LOCAL_SYM
	PUSHAQ	FILENAME_DSC
	PUSHAQ	PREV_PROC	
	CALLS	#3,G^LIB$SET_SYMBOL
	CHKSTS
	RET

	.ENTRY	GET_IDF_FILENAME,^m<R2,R3,R4,R5>
	MOVAB	G^EXE$SIGTORET,(FP)		; return signalled errors
	MOVAB	@#CTL$AG_CLIDATA,R1		; get address of the PPD
	MOVL	PPD$L_PRC(R1),R1		; adr of CLI own storage
	MOVL	PRC_L_IDFLNK(R1),R1		; get adr of IDF listhead
	MOVL	IDF_L_LNK(R1),R0		; get next IDF in queue
	BEQL	10$				; there is none!  at top!
	MOVL	R0,R1				; update IDF block pointer
10$:	MOVL	IDF_L_FILENAME(R1),R1		; get the filename (ASCIC)
	MOVZBL	(R1)+,R0			; get filename's length
	MOVW	R0,FILENAME_DSC			; store it in descriptor
	MOVC3	R0,(R1),FILENAME_STR		; copy name to descriptor
	MOVL	#SS$_NORMAL,R0			; say things went normal
	RET
	.END	GO

To build it:

$ MACRO PREV_PROC

Link On_VAX:

$ LINK PREV_PROC,SYS$SYSTEM:SYS.STB,DCLDEF.STB

Link On_Alpha:

$ LINK PREV_PROC/SYSEXE,SYS$LOADABLE_IMAGES:DCLDEF.STB

--
VAXman- OpenVMS APE certification number: AAA-0001           VAXman@TMESIS.COM