/* --- Copyright University of Sussex 1998. All rights reserved. ----------
 * File:            C.alpha/src/aextern.s
 * Purpose:
 * Author:          John Gibson, Oct 14 1994 (see revisions)
 */

;;; ---------------- USER EXTERNAL CALLS / CALLBACK ----------------------

#_<

#_INCLUDE 'asm.ph'
#_INCLUDE 'external.ph'
#_INCLUDE 'numbers.ph'

vars Sys$-Extern$- _invocation_fp;

lconstant macro (
	_XP_PTR  	= @@XP_PTR,
	_DD_1		= @@DD_1,
	_BGI_LENGTH	= @@BGI_LENGTH,
	_BGI_SLICES	= @@BGI_SLICES,
	_EFC_FUNC	= @@EFC_FUNC,
	_EFC_ARG	= @@EFC_ARG,
	_EFC_ARG_DEST	= @@EFC_ARG_DEST,

	(_K_EXTERN_TYPE_l, _K_EXTERN_TYPE_b) = FIELD_lb(@@K_EXTERN_TYPE),

	;;; Used by _call_external before calling the routine (hence don't
	;;; need to be OS locals)
	rROUT	= rpl4,
	rARGC	= rpl3,
	rSTKA	= rpl2,
	rFBIT	= rpl1,
	);

#_IF WORD_BITS/==DOUBLE_BITS
lconstant macro _DD_2 = @@DD_2;
#_ENDIF

>_#

ASM_START_FILE


ASM_CODE_PSECT


;;; --------------------------------------------------------------------


	;;;    _call_external(____arg1, ..., ____argN, ___N, _________routine, ___________fltsingle)
	;;;
	;;; Call an external procedure, moving args from userstack
	;;; to stack and converting -- for users. Must be capable of
	;;; dealing with callback.
	;;;    Bit N set in the _________fltsingle arg says pass the Nth arg as a
	;;; single float if it's a (d)decimal (otherwise pass (d)decimals
	;;; as doubles). Note that bit 31 governs all args from 32nd onwards
	;;; (i.e. after each arg, _________fltsingle is shifted right _____________algebraically).

	;;; All pop registers are localised by procedures that call this.

ASM_ALIGN_QUAD
DEF_C_LAB (_call_external)
	stW	rsp, _svb_SAVED_SP	;;; save pop caller's stack frame
	lda	rsp, -32(rsp)		;;; and store return address
	stW	rret, 32-_WOFFS(rsp)	;;; in normal SF_RETURN_ADDR position

	;;; use pop local regs that are also OS locals to save things
	;;; across the call
	mov	rsvb,  rpl9		;;; save special var block
	mov	rnpl0, rpl8		;;; save 'unoffical' local
	mov	rnpl1, rpl7		;;;  "        "        "
#_IF DEF OSF1 or DEF LINUX
	mov	rnpl2, rpl6		;;; save 'unoffical' local
	mov	rnpl3, rpl5		;;;  "        "        "
	stW	rnpl4, 16(rsp)		;;;  "        "        "
#_ENDIF

	mov	rsp, rpl10		;;; save sp to restore after call
	bic	rsp, 15, rsp		;;; then octaword-align sp

	ldW	rARGC, _WOFFS*2(rusp)	;;; arg count ___N in rARGC
	ldW	rpb, _WOFFS(rusp)	;;; _________routine descriptor/exec addr
	ldW	rFBIT, 0(rusp)		;;; ___________fltsingle
	lda	rusp, _WOFFS*3(rusp)
#_IF DEF VMS
	mov	rARGC, r25		;;; arg count ___N in AI reg r25
#_ENDIF
	sWaddq	rARGC, rusp, rusp	;;; address of after last arg on stack
	mov	rsp, rSTKA		;;; place to store floats
	stW	rusp, _svb_SAVED_USP	;;; save usp for after call/callback
#_IF DEF VMS
	ldq	rret, 8(rpb)		;;; exec address of _________routine
#_ENDIF

	beq	rARGC, do_call		;;; br if no args
	ldW	rt0, -_WOFFS(rusp)	;;; else get first arg into rt0

#_IF DEF VMS
	.begin_exact
#_ENDIF
	br	rROUT, first_arg	;;; get addr of first routine in rROUT

	;;; Routines to store args in r/f16 - r/f21 and then successive stack
	;;; locations. Next integer routine address is (rROUT), single float
	;;; is 4*4(rROUT), double float is 8*4(rROUT)

;;; --- ARG 0
	mov	rt0, ra0		;;; 4 instructions for int arg
	beq	rARGC, do_call		;;; br if no args
	br	arg_loop
	nop

	fmov	ft0, fa0		;;; 4 instructions for single float
#_IF DEF VMS
	lda	r25, ^X100(r25)		;;; 1<<8 (1 = AI$K_ARG_FF, F float in reg)
#_ENDIF
	beq	rARGC, do_call
	br	arg_loop
#_IF not(DEF VMS)
	nop
#_ENDIF

	fmov	ft0, fa0		;;; 5 instructions for double float
#_IF DEF VMS
	lda	r25, ^X300(r25)		;;; 3<<8 (3 = AI$K_ARG_FG, G float in reg)
#_ENDIF
	beq	rARGC, do_call
	br	arg_loop
	nop
#_IF not(DEF VMS)
	nop
#_ENDIF

;;; --- ARG 1
	mov	rt0, ra1
	beq	rARGC, do_call
	br	arg_loop
	nop

	fmov	ft0, fa1
#_IF DEF VMS
	lda	r25, ^X800(r25)		;;; 1<<11
#_ENDIF
	beq	rARGC, do_call
	br	arg_loop
#_IF not(DEF VMS)
	nop
#_ENDIF

	fmov	ft0, fa1
#_IF DEF VMS
	lda	r25, ^X1800(r25)	;;; 3<<11
#_ENDIF
	beq	rARGC, do_call
	br	arg_loop
	nop
#_IF not(DEF VMS)
	nop
#_ENDIF

;;; --- ARG 2
	mov	rt0, ra2
	beq	rARGC, do_call
	br	arg_loop
	nop

	fmov	ft0, fa2
#_IF DEF VMS
	lda	r25, ^X4000(r25)	;;; 1<<14
#_ENDIF
	beq	rARGC, do_call
	br	arg_loop
#_IF not(DEF VMS)
	nop
#_ENDIF

	fmov	ft0, fa2
#_IF DEF VMS
	lda	r25, -^X4000(r25)	;;; 3<<14 + -1<<16
	ldah	r25, 1(r25)		;;; cancel out -1<<16 on last
#_ENDIF
	beq	rARGC, do_call
	br	arg_loop
#_IF not(DEF VMS)
	nop
	nop
#_ENDIF

;;; --- ARG 3
	mov	rt0, ra3
	beq	rARGC, do_call
	br	arg_loop
	nop

	fmov	ft0, fa3
#_IF DEF VMS
	ldah	r25, ^X2(r25)		;;; 1<<17
#_ENDIF
	beq	rARGC, do_call
	br	arg_loop
#_IF not(DEF VMS)
	nop
#_ENDIF

	fmov	ft0, fa3
#_IF DEF VMS
	ldah	r25, ^X6(r25)		;;; 3<<17
#_ENDIF
	beq	rARGC, do_call
	br	arg_loop
	nop
#_IF not(DEF VMS)
	nop
#_ENDIF

;;; --- ARG 4
	mov	rt0, ra4
	beq	rARGC, do_call
	br	arg_loop
	nop

	fmov	ft0, fa4
#_IF DEF VMS
	ldah	r25, ^X10(r25)		;;; 1<<20
#_ENDIF
	beq	rARGC, do_call
	br	arg_loop
#_IF not(DEF VMS)
	nop
#_ENDIF

	fmov	ft0, fa4
#_IF DEF VMS
	ldah	r25, ^X30(r25)		;;; 3<<20
#_ENDIF
	beq	rARGC, do_call
	br	arg_loop
	nop
#_IF not(DEF VMS)
	nop
#_ENDIF

;;; --- ARG 5
	mov	rt0, ra5
	beq	rARGC, do_call
	br	setup_stack
	nop

	fmov	ft0, fa5
#_IF DEF VMS
	ldah	r25, ^X80(r25)		;;; 1<<23
#_ENDIF
	beq	rARGC, do_call
	br	setup_stack
#_IF not(DEF VMS)
	nop
#_ENDIF

	fmov	ft0, fa5
#_IF DEF VMS
	ldah	r25, ^X180(r25)		;;; 3<<23
#_ENDIF
	beq	rARGC, do_call
	br	setup_stack
	nop
#_IF not(DEF VMS)
	nop
#_ENDIF

;;; --- SUBSEQUENT ARGS
	stq	rt0, 0(rSTKA)
	beq	rARGC, do_call
	lda	rSTKA, 8(rSTKA)
	br	arg_loop_stack

	stSF	ft0, 0(rSTKA)
	beq	rARGC, do_call
	lda	rSTKA, 8(rSTKA)
	br	arg_loop_stack

	stDF	ft0, 0(rSTKA)
	beq	rARGC, do_call
	lda	rSTKA, 8(rSTKA)
	br	arg_loop_stack

#_IF DEF VMS
	.end_exact
#_ENDIF



	;;; set up stack args -- alloc octa-aligned space on stack
	;;; (enough for 2 args already there)
setup_stack:
	bic	rARGC, 1, rt1		;;; round remaining number down to even
	sll	rt1, 3, rt1		;;; make quad offset
	subq	rsp, rt1, rsp		;;; alloc stack space
	mov	rsp, rSTKA		;;; work up stack using rSTKA

	;;; loops for 2nd and subsequent args
arg_loop:
	lda	rROUT, 13*4(rROUT)	;;; next store routine
arg_loop_stack:
	ldW	rt0, -_WOFFS(rusp)	;;; get next arg
	sra	rFBIT, 1, rFBIT	;;; shift down next _________fltsingle bit

first_arg:
	subq	rARGC, 1, rARGC	;;; decrement arg count

	;;; deal with arg in rt0

	blbc	rt0, !$3f		;;; br if structure

	;;; simple
	and	rt0, 2, rt1		;;; test integer bit
	lda	rusp, -_WOFFS(rusp)	;;; step arg ptr
	beq	rt1, !$1f		;;; br if decimal
	;;; integer
	sra	rt0, _:WORD_SHIFT, rt0 ;;; convert to m/c int
	jmp	rzero, (rROUT)		;;; store non-float arg in rt0

	;;; decimal -- pass as double float unless _________fltsingle bit set
!$1:	bic	rt0, 1, rt0		;;; clear tag bit on decimal
	lda	rt2, 8*4(rROUT)		;;; address to store double float arg
#_IF WORD_BITS==DOUBLE_BITS
	stq	rt0, 0(rSTKA)		;;; store in mem
	ldt	ft0, 0(rSTKA)		;;; reload image in float reg
	blbc	rFBIT, !$2f		;;; br if _________fltsingle bit clear
	;;; convert double to single
	lda	rt2, 4*4(rROUT)		;;; routine to store single float arg
	cvtDFSF	ft0, ft0		;;; checks T/G float okay as S/F float
#_ELSE
  #_IF not(DEF IEEE_FLOAT)
	inswl	rt0, 2, rt1		;;; rotate lo 32 right 16 to make F float
	extwl	rt0, 2, rt0
	or	rt0, rt1, rt0
  #_ENDIF
	stl	rt0, 0(rSTKA)		;;; store in mem
	ldSF	ft0, 0(rSTKA)		;;; reload as S/F float
	lda	rt1, 4*4(rROUT)		;;; address to store single float arg
	cmovlbs	rFBIT, rt1, rt2		;;; 4*4(rROUT) if _________fltsingle bit
#_ENDIF
!$2:	jmp	rzero, (rt2)		;;; store float arg in ft0

	;;; structure
!$3:	ldW	rt1, _KEY(rt0)		;;; get key
	lda	rusp, -_WOFFS(rusp)	;;; step arg ptr
	ldl	rt1, _K_EXTERN_TYPE_l(rt1)	;;; word with type
	extbl	rt1, _K_EXTERN_TYPE_b, rt1	;;; extern type
	bne	rt1, !$4f		;;; br if not EXTERN_TYPE_NORMAL (0)
	;;; ordinary structure -- just pass pointer
	jmp	rzero, (rROUT)		;;; store non-float arg in rt0

!$4:	cmpeq	rt1, _:EXTERN_TYPE_DEREF, rt2
	blbc	rt2, !$5f		;;; br if not EXTERN_TYPE_DEREF
	;;; pass word field at pointer (e.g. external pointer)
	ldW	rt0, 0(rt0)		;;; dereference it
	jmp	rzero, (rROUT)		;;; store non-float arg in rt0

!$5:	cmpeq	rt1, _:EXTERN_TYPE_DDEC, rt2
	blbc	rt2, !$7f		;;; br if not EXTERN_TYPE_DDEC
	;;; ddecimal -- pass as double float unless _________fltsingle bit set
#_IF WORD_BITS==DOUBLE_BITS
	ldDF	ft0, _DD_1(rt0)		;;; load T/G float to float reg
#_ELSE
	ldl	rt1, _DD_1(rt0)
	ldl	rt0, _DD_2(rt0)
	stl	rt1, 0(rSTKA)
	stl	rt0, 4(rSTKA)
	ldDF	ft0, 0(rSTKA)		;;; load T/G float to float reg
#_ENDIF
	lda	rt1, 8*4(rROUT)		;;; address to store double float arg
	blbc	rFBIT, !$6f		;;; br if _________fltsingle bit clear
	;;; convert double to single
	lda	rt1, 4*4(rROUT)		;;; routine to store single float arg
	cvtDFSF	ft0, ft0		;;; checks T/G float okay as S/F float
!$6:	jmp	rzero, (rt1)		;;; store it

	;;; else must be biginteger (EXTERN_TYPE_BIGINT)
	;;; pass least significant 64 bits
!$7:	ldW	rt1, _BGI_LENGTH(rt0)	;;; number of slices
	ldl	rfalse, _BGI_SLICES(rt0) ;;; get ls slice
	subq	rt1, 1, rt1		;;; decr number of slices
	beq	rt1, !$8f		;;; br if only 1
	ldl	rt2, _BGI_SLICES+4(rt0)	;;; else get second slice
	subq	rt1, 1, rt1		;;; decr number of slices
	sll	rt2, 31, rt2		;;; shift up
	bis	rfalse, rt2, rfalse	;;; add bits to rfalse
	beq	rt1, !$8f		;;; br if only 2 slices
	ldl	rt2, _BGI_SLICES+8(rt0)	;;; else get third slice
	sll	rt2, 62, rt2		;;; shift up
	bis	rfalse, rt2, rfalse	;;; add bits to rfalse
!$8:	mov	rfalse, rt0
	jmp	rzero, (rROUT)		;;; store non-float arg in rt0


	;;; args transferred -- call routine
do_call:
	;;; NEXT INSTRUCTION ENABLES ASYNC CALLBACK
	stW	rsp, _svb_IN_USER_EXTERN	;;; any nonzero value

#_IF DEF VMS
	jsr	rret, (rret)		;;; the call
#_ELSE
	jsr	rret, (rpb)		;;; the call
#_ENDIF

call_extern_unwind_return:
	mov	rpl9, rsvb		;;; restore special var block
	;;; NEXT INSTRUCTION DISABLES ASYNC CALLBACK
	stW	rzero, _svb_IN_USER_EXTERN

	;;; restore regs
	ldW	rfalse, _svb_FALSE	;;; restore rfalse
	mov	rpl8,  rnpl0		;;; restore 'unoffical' local
	mov	rpl7,  rnpl1		;;;     "        "        "
#_IF DEF OSF1 or DEF LINUX
	mov	rpl6, rnpl2		;;; restore 'unoffical' local
	mov	rpl5, rnpl3		;;;     "        "        "
	ldW	rnpl4, 16(rpl10)	;;;     "        "        "
#_ENDIF
	ldW	rret, 32-_WOFFS(rpl10)	;;; restore return address
	lda	rsp, 32(rpl10)		;;; restore caller's frame

	;;; set result_struct with possible float result from
	;;; ft0 in first 2 words and possible word result from rt0 in last
	ldW	rt1, _SVB_OFFS(Sys$-Extern$-result_struct)(rsvb)
	ldW	rusp, _svb_SAVED_USP	;;; usp with args removed
	stDF	ft0, 0(rt1)		;;; T/G float result
#_IF DEF OSF1 or DEF LINUX
	stq	rt0, 8(rt1)		;;; 64-bit result
#_ELSE
	stW	rt0, 8(rt1)		;;; word result
#_ENDIF

	ldW	rpb, _SF_OWNER(rsp)	;;; restore caller's pb
	stW	rzero, _svb_SAVED_SP	;;; says no longer in extern calls
	ret	rzero, (rret)


;;; --- EXTERNAL FUNCTION CLOSURES --------------------------------------

	;;; passed procedure descriptor/exec addr (= exfunc_closure) in rpb
	;;; (with args in r16-r21, r25 and on stack)
	;;; assign EFC_ARG to EFC_ARG_DEST and chain EFC_FUNC

ASM_ALIGN_QUAD
DEF_C_LAB(Sys$- _exfunc_clos_action)
	ldW	rt0, _EFC_FUNC(rpb)	;;; exptr to base procedure desc/exec
	ldW	rt1, _EFC_ARG(rpb)	;;; get arg
	ldW	rt2, _EFC_ARG_DEST(rpb)	;;; get destination address
	ldW	rpb, _XP_PTR(rt0)	;;; replace rpb with base desc/exec
	stW	rt1, 0(rt2)		;;; store arg at destination
#_IF DEF VMS
	ldq     rt0, 8(rpb)		;;; get entry point from desc
	jmp	rzero, (rt0)		;;; chain to it
#_ELSE
	jmp	rzero, (rpb)		;;; chain to it
#_ENDIF



;;; --- INTERFACE ROUTINE FOR EXTERNAL CALLBACK ------------------------------

	;;; C Synopsis:
	;;;
	;;; 	int _pop_external_callback(____argp)
	;;; 	unsigned ____argp[];
	;;;
	;;; (where ____argp[0] is the function code for Callback)

#_IF DEF VMS

$ROUTINE _pop_external_callback, -
	KIND = stack, -
	SAVED_REGS = <r2,r3,r4,r5,r6,r7,r8,r9,r10,r11,r12,r13,r14,r15,fp>, -
	HANDLER = _pop_errsig_handler

	$LINKAGE_SECTION
svbadr: .WORD	C_LAB(_special_var_block)
ecbadr:	.WORD	C_LAB(Sys$-Extern$-Callback)
uwradr:	.WORD	call_extern_unwind_return
guwadr:	.WORD	sys$goto_unwind

	$CODE_SECTION
	.base	rpb, $LS

	ldW	rsvb, svbadr		;;; recover rsvb

	;;; 4 word dummy stack frame to hold SF_NEXT_SEG_SP and SF_NEXT_SEG_HI
	lda	rsp, -_WOFFS*4(rsp)

	ldW	rnpl0, _svb_IN_USER_EXTERN  ;;; save this and restore at end
	;;; NEXT INSTRUCTION DISABLES ASYNC CALLBACK
	stW	rzero, _svb_IN_USER_EXTERN

	ldW	rfalse, _svb_FALSE
	ldW	rusp, _svb_SAVED_USP	;;; regain saved user sp
	ldW	rpb, ecbadr		;;; get Callback (clobbers .base)

	INIT_POP_REGISTERS		;;; set pop lvar registers to false

	ldW	rt0, _PD_EXECUTE(rpb)	;;; exec addr of Callback
	stW	ra0, -_WOFFS(rusp)	;;; push ____argp
	stW	rzero, -_WOFFS*2(rusp)	;;; push dummy break diff
	lda	rusp, -_WOFFS*2(rusp)

	ldW	rnpl2, _svb_INVOC_FP	;;; save current _invocation_fp
	stW	rfp, _svb_INVOC_FP	;;; then make my fp current

	jsr	rret, (rt0)		;;; call Callback

	stW	rnpl2, _svb_INVOC_FP	;;; reset previous _invocation_fp

	ldW	rt0, 0(rusp)		;;; return status
	lda	rusp, _WOFFS(rusp)
	stW	rusp, _svb_SAVED_USP	;;; resave user sp for _call_external

	bge	rt0, 1$			;;; normal return if status >= 0

	;;; negative return means unwind the external calls and return to
	;;; _call_external (whose return is frigged to continue the
	;;; abnormal exit)
	ldW	rpb, 0(rfp)		;;; restore my .base
	sll	rnpl2, #1, ra0		;;; create handle for _invocation_fp
	bis	ra0, #^X1F, ra0
	stl	ra0, 0(rsp)
	mov	rsp, ra0		;;; pointer to handle
	lda	ra1, uwradr		;;; new PC = call_extern_unwind_return
	clr	ra2			;;; zero 3rd and 4th args
	clr	ra3
	mov	#4, r25			;;; = 4 args
	ldW	rpb, guwadr		;;; sys$goto_unwind pdr desc
	ldq	rt0, 8(rpb)		;;; exec addr
	jsr	rret, (rt0)		;;; unwind

	;;; NEXT INSTRUCTION ENABLES ASYNC CALLBACK
1$:	stW	rnpl0, _svb_IN_USER_EXTERN  ;;; set back to value on entry

	$RETURN				;;; return into external code
$END_ROUTINE

	;;; for indirect weak reference
SET_C_LAB(Sys$- _external_callback_func) = _pop_external_callback


#_ELSE

	.set macro

	.section .rodata
adrtab:
	.WORD	C_LAB(_special_var_block)	;;; _WOFFS*0
	.WORD	C_LAB(Sys$-Extern$-Callback)	;;; _WOFFS*1

	.text
	.align  4

DEF_C_LAB(Sys$- _external_callback_func)
	.globl  _pop_external_callback
	.ent    _pop_external_callback
_pop_external_callback:
	ldgp    $29, 0(rpb)
	lda     rsp, -64(rsp)
	stq     rret, 0*8(rsp)
	stq     $9,   1*8(rsp)
	stq     $10,  2*8(rsp)
	stq     $11,  3*8(rsp)
	stq     $12,  4*8(rsp)
	stq     $13,  5*8(rsp)
	stq     $14,  6*8(rsp)
	stq     rfp,  7*8(rsp)		;;; $15
	mov	rsp, rfp
	.mask   0x0400FE00, -64		;;; saves regs 26, 9-15
	.frame  rfp, 64, rret, 0
	.prologue 1
	lda	rpb, adrtab		;;; don't know what work regs this uses

	ldW	rsvb, _WOFFS*0(rpb)	;;; recover rsvb

	;;; 4 word dummy stack frame to hold SF_NEXT_SEG_SP and SF_NEXT_SEG_HI
	lda	rsp, -_WOFFS*4(rsp)

	ldW	rnpl0, _svb_IN_USER_EXTERN  ;;; save this and restore at end
	;;; NEXT INSTRUCTION DISABLES ASYNC CALLBACK
	stW	rzero, _svb_IN_USER_EXTERN

	ldW	rfalse, _svb_FALSE
	ldW	rusp, _svb_SAVED_USP	;;; regain saved user sp
	ldW	rpb, _WOFFS*1(rpb)	;;; get Callback (clobbers rpb)

	INIT_POP_REGISTERS		;;; set pop lvar registers to false

	ldW	rt0, _PD_EXECUTE(rpb)	;;; exec addr of Callback
	stW	ra0, -_WOFFS(rusp)	;;; push ____argp
	stW	rzero, -_WOFFS*2(rusp)	;;; push dummy break diff
	lda	rusp, -_WOFFS*2(rusp)

	ldW	rnpl2, _svb_INVOC_FP	;;; save current _invocation_fp
	stW	rfp, _svb_INVOC_FP	;;; then make my fp current

	jsr	rret, (rt0)		;;; call Callback

	stW	rnpl2, _svb_INVOC_FP	;;; reset previous _invocation_fp

	ldW	rt0, 0(rusp)		;;; return status
	lda	rusp, _WOFFS(rusp)
	stW	rusp, _svb_SAVED_USP	;;; resave user sp for _call_external

	;;; NEXT INSTRUCTION ENABLES ASYNC CALLBACK
	stW	rnpl0, _svb_IN_USER_EXTERN  ;;; set back to value on entry

	ldgp    $29, 0(rret)		;;; restore gp
	mov	rfp, rsp		;;; erase dummy stack frame
	ldq     rret, 0*8(rsp)
	ldq     $9,   1*8(rsp)
	ldq     $10,  2*8(rsp)
	ldq     $11,  3*8(rsp)
	ldq     $12,  4*8(rsp)
	ldq     $13,  5*8(rsp)
	ldq     $14,  6*8(rsp)
	ldq     rfp,  7*8(rsp)		;;; restore fp
	lda     rsp, 64(rsp)
	ret     rzero, (rret), 1	;;; special hint
	.end	_pop_external_callback

#_ENDIF



ASM_END_FILE



/* --- Revision History ---------------------------------------------------
--- John Gibson, Mar 17 1998
	Changed __pop*_invocation_fp to pop variable _invocation_fp
 */
