/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* PACKAGE: [incr Tcl]
|
* PACKAGE: [incr Tcl]
|
* DESCRIPTION: Object-Oriented Extensions to Tcl
|
* DESCRIPTION: Object-Oriented Extensions to Tcl
|
*
|
*
|
* This file contains procedures that belong in the Tcl/Tk core.
|
* This file contains procedures that belong in the Tcl/Tk core.
|
* Hopefully, they'll migrate there soon.
|
* Hopefully, they'll migrate there soon.
|
*
|
*
|
* ========================================================================
|
* ========================================================================
|
* AUTHOR: Michael J. McLennan
|
* AUTHOR: Michael J. McLennan
|
* Bell Labs Innovations for Lucent Technologies
|
* Bell Labs Innovations for Lucent Technologies
|
* mmclennan@lucent.com
|
* mmclennan@lucent.com
|
* http://www.tcltk.com/itcl
|
* http://www.tcltk.com/itcl
|
*
|
*
|
* RCS: $Id: itcl_migrate.c,v 1.1.1.1 2002-01-16 10:24:46 markom Exp $
|
* RCS: $Id: itcl_migrate.c,v 1.1.1.1 2002-01-16 10:24:46 markom Exp $
|
* ========================================================================
|
* ========================================================================
|
* Copyright (c) 1993-1998 Lucent Technologies, Inc.
|
* Copyright (c) 1993-1998 Lucent Technologies, Inc.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* See the file "license.terms" for information on usage and redistribution
|
* See the file "license.terms" for information on usage and redistribution
|
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
*/
|
*/
|
#include "itclInt.h"
|
#include "itclInt.h"
|
|
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* _Tcl_GetCallFrame --
|
* _Tcl_GetCallFrame --
|
*
|
*
|
* Checks the call stack and returns the call frame some number
|
* Checks the call stack and returns the call frame some number
|
* of levels up. It is often useful to know the invocation
|
* of levels up. It is often useful to know the invocation
|
* context for a command.
|
* context for a command.
|
*
|
*
|
* Results:
|
* Results:
|
* Returns a token for the call frame 0 or more levels up in
|
* Returns a token for the call frame 0 or more levels up in
|
* the call stack.
|
* the call stack.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* None.
|
* None.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
Tcl_CallFrame*
|
Tcl_CallFrame*
|
_Tcl_GetCallFrame(interp, level)
|
_Tcl_GetCallFrame(interp, level)
|
Tcl_Interp *interp; /* interpreter being queried */
|
Tcl_Interp *interp; /* interpreter being queried */
|
int level; /* number of levels up in the call stack (>= 0) */
|
int level; /* number of levels up in the call stack (>= 0) */
|
{
|
{
|
Interp *iPtr = (Interp*)interp;
|
Interp *iPtr = (Interp*)interp;
|
CallFrame *framePtr;
|
CallFrame *framePtr;
|
|
|
if (level < 0) {
|
if (level < 0) {
|
panic("itcl: _Tcl_GetCallFrame called with bad number of levels");
|
panic("itcl: _Tcl_GetCallFrame called with bad number of levels");
|
}
|
}
|
|
|
framePtr = iPtr->varFramePtr;
|
framePtr = iPtr->varFramePtr;
|
while (framePtr && level > 0) {
|
while (framePtr && level > 0) {
|
framePtr = framePtr->callerVarPtr;
|
framePtr = framePtr->callerVarPtr;
|
level--;
|
level--;
|
}
|
}
|
return (Tcl_CallFrame*)framePtr;
|
return (Tcl_CallFrame*)framePtr;
|
}
|
}
|
|
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* _Tcl_ActivateCallFrame --
|
* _Tcl_ActivateCallFrame --
|
*
|
*
|
* Makes an existing call frame the current frame on the
|
* Makes an existing call frame the current frame on the
|
* call stack. Usually called in conjunction with
|
* call stack. Usually called in conjunction with
|
* _Tcl_GetCallFrame to simulate the effect of an "uplevel"
|
* _Tcl_GetCallFrame to simulate the effect of an "uplevel"
|
* command.
|
* command.
|
*
|
*
|
* Note that this procedure is different from Tcl_PushCallFrame,
|
* Note that this procedure is different from Tcl_PushCallFrame,
|
* which adds a new call frame to the call stack. This procedure
|
* which adds a new call frame to the call stack. This procedure
|
* assumes that the call frame is already initialized, and it
|
* assumes that the call frame is already initialized, and it
|
* merely activates it on the call stack.
|
* merely activates it on the call stack.
|
*
|
*
|
* Results:
|
* Results:
|
* Returns a token for the call frame that was in effect before
|
* Returns a token for the call frame that was in effect before
|
* activating the new context. That call frame can be restored
|
* activating the new context. That call frame can be restored
|
* by calling _Tcl_ActivateCallFrame again.
|
* by calling _Tcl_ActivateCallFrame again.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* None.
|
* None.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
Tcl_CallFrame*
|
Tcl_CallFrame*
|
_Tcl_ActivateCallFrame(interp, framePtr)
|
_Tcl_ActivateCallFrame(interp, framePtr)
|
Tcl_Interp *interp; /* interpreter being queried */
|
Tcl_Interp *interp; /* interpreter being queried */
|
Tcl_CallFrame *framePtr; /* call frame to be activated */
|
Tcl_CallFrame *framePtr; /* call frame to be activated */
|
{
|
{
|
Interp *iPtr = (Interp*)interp;
|
Interp *iPtr = (Interp*)interp;
|
CallFrame *oldFramePtr;
|
CallFrame *oldFramePtr;
|
|
|
oldFramePtr = iPtr->varFramePtr;
|
oldFramePtr = iPtr->varFramePtr;
|
iPtr->varFramePtr = (CallFrame *) framePtr;
|
iPtr->varFramePtr = (CallFrame *) framePtr;
|
|
|
return (Tcl_CallFrame *) oldFramePtr;
|
return (Tcl_CallFrame *) oldFramePtr;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* _TclNewVar --
|
* _TclNewVar --
|
*
|
*
|
* Create a new heap-allocated variable that will eventually be
|
* Create a new heap-allocated variable that will eventually be
|
* entered into a hashtable.
|
* entered into a hashtable.
|
*
|
*
|
* Results:
|
* Results:
|
* The return value is a pointer to the new variable structure. It is
|
* The return value is a pointer to the new variable structure. It is
|
* marked as a scalar variable (and not a link or array variable). Its
|
* marked as a scalar variable (and not a link or array variable). Its
|
* value initially is NULL. The variable is not part of any hash table
|
* value initially is NULL. The variable is not part of any hash table
|
* yet. Since it will be in a hashtable and not in a call frame, its
|
* yet. Since it will be in a hashtable and not in a call frame, its
|
* name field is set NULL. It is initially marked as undefined.
|
* name field is set NULL. It is initially marked as undefined.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Storage gets allocated.
|
* Storage gets allocated.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
Var *
|
Var *
|
_TclNewVar()
|
_TclNewVar()
|
{
|
{
|
register Var *varPtr;
|
register Var *varPtr;
|
|
|
varPtr = (Var *) ckalloc(sizeof(Var));
|
varPtr = (Var *) ckalloc(sizeof(Var));
|
varPtr->value.objPtr = NULL;
|
varPtr->value.objPtr = NULL;
|
varPtr->name = NULL;
|
varPtr->name = NULL;
|
varPtr->nsPtr = NULL;
|
varPtr->nsPtr = NULL;
|
varPtr->hPtr = NULL;
|
varPtr->hPtr = NULL;
|
varPtr->refCount = 0;
|
varPtr->refCount = 0;
|
varPtr->tracePtr = NULL;
|
varPtr->tracePtr = NULL;
|
varPtr->searchPtr = NULL;
|
varPtr->searchPtr = NULL;
|
varPtr->flags = (VAR_SCALAR | VAR_UNDEFINED | VAR_IN_HASHTABLE);
|
varPtr->flags = (VAR_SCALAR | VAR_UNDEFINED | VAR_IN_HASHTABLE);
|
return varPtr;
|
return varPtr;
|
}
|
}
|
|
|
