Itcl - the [incr Tcl] extension

 *  
 * ========================================================================
 *  AUTHOR:  Michael J. McLennan
 *           Bell Labs Innovations for Lucent Technologies
 *           [email protected]
 *           http://www.tcltk.com/itcl
 *
 *     RCS:  $Id: itclInt.h,v 1.17 2007/08/07 20:05:29 msofer Exp $
 * ========================================================================
 *           Copyright (c) 1993-1998  Lucent Technologies, Inc.
 * ------------------------------------------------------------------------
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */
#ifndef ITCLINT_H
#define ITCLINT_H

#include "tclInt.h"
#include "itcl.h"

#ifdef BUILD_itcl
# undef TCL_STORAGE_CLASS
# define TCL_STORAGE_CLASS DLLEXPORT
#endif

#define ITCL_TCL_PRE_8_5 (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION < 5)

#if !ITCL_TCL_PRE_8_5
#if (USE_TCL_STUBS)

/*
 * Fix Tcl bug #803489 the right way.  We need to always use the old Stub
 * slot positions, not the new broken ones part of TIP 127.  I do like
 * that these functions have moved to the public space (about time), but
 * the slot change is the killer and is the painful side affect.
 */



#   undef Tcl_CreateNamespace
#   define Tcl_CreateNamespace \
	(tclIntStubsPtr->tcl_CreateNamespace)
#   undef Tcl_DeleteNamespace
#   define Tcl_DeleteNamespace \
	(tclIntStubsPtr->tcl_DeleteNamespace)
#   undef Tcl_AppendExportList

	(tclIntStubsPtr->tcl_FindCommand)
#   undef Tcl_GetCommandFromObj
#   define Tcl_GetCommandFromObj \
	(tclIntStubsPtr->tcl_GetCommandFromObj)
#   undef Tcl_GetCommandFullName
#   define Tcl_GetCommandFullName \
	(tclIntStubsPtr->tcl_GetCommandFullName)
#endif /* use stubs */

/*
 * Use 8.5+ CallFrame
 */

#define ItclCallFrame CallFrame
#define Itcl_CallFrame Tcl_CallFrame

#define ItclInitVarFlags(varPtr) \
    (varPtr)->flags = 0

#define ItclInitVarArgument(varPtr) \
   (varPtr)->flags = VAR_ARGUMENT 

#define ItclVarHashCreateVar(tablePtr, key, newPtr) \
    TclVarHashCreateVar((tablePtr), (key), (newPtr))

#define ItclVarRefCount(varPtr) VarHashRefCount(varPtr)

#define ItclClearVarUndefined(varPtr)

#define ItclNextLocal(varPtr) ((varPtr)++)

#define ItclVarObjValue(varPtr) ((varPtr)->value.objPtr)

#define itclVarInHashSize sizeof(VarInHash)
#define itclVarLocalSize  sizeof(Var)

#else /* Compiling on Tcl8.x, x<5 */ 

/*
 * Redefine CallFrame to account for extra ClientData in 8.5.
 * Make sure that standard CallFrame comes first.
 */

typedef struct ItclCallFrame {
    Namespace *nsPtr;
    int isProcCallFrame;
    int objc;
    Tcl_Obj *CONST *objv;
    struct CallFrame *callerPtr;
    struct CallFrame *callerVarPtr;
    int level;
    Proc *procPtr;
    Tcl_HashTable *varTablePtr;
    int numCompiledLocals;
    Var* compiledLocals;
    ClientData clientData;
    struct localCache *localCachePtr;
} ItclCallFrame;

typedef struct Itcl_CallFrame {
    Tcl_Namespace *nsPtr;
    int dummy1;
    int dummy2;
    char *dummy3;
    char *dummy4;
    char *dummy5;
    int dummy6;
    char *dummy7;
    char *dummy8;
    int dummy9;
    char *dummy10;
    char *dummy11;
    char *dummy12;
} Itcl_CallFrame;

/*
 * Definition of runtime behaviour to be able to run irrespective of the Tcl
 * version.
 */

#define VarInHash Var

#define TclVarHashTable Tcl_HashTable

typedef struct ItclShortVar {
    int flags;
    union {
	Tcl_Obj *objPtr;
	TclVarHashTable *tablePtr;
	struct Var *linkPtr;
    } value;
} ItclShortVar;

typedef struct ItclVarInHash {
    ItclShortVar var;
    int refCount;
    Tcl_HashEntry entry;
} ItclVarInHash;

#define ItclOffset(type, field) ((int) ((char *) &((type *) 0)->field))

#define itclOldRuntime (itclVarFlagOffset!=0)

extern int itclVarFlagOffset; 
extern int itclVarRefCountOffset;
extern int itclVarInHashSize;
extern int itclVarLocalSize;
extern int itclVarValueOffset;

/*
 * VarReform related macros: provide access to the Var fields with offsets
 * determined at load time, so that the same code copes with the different
 * structs in Tcl8.5 and previous Tcl.
 */

#define ItclNextLocal(varPtr) \
    ((varPtr) = (Var *) (((char *)(varPtr))+itclVarLocalSize))

#define ItclVarObjValue(varPtr) \
    (*((Tcl_Obj **) (((char *)(varPtr))+itclVarValueOffset)))

#define ItclVarRefCount(varPtr) \
    (*((int *) (((char *)(varPtr))+itclVarRefCountOffset)))

#define ItclVarFlags(varPtr) \
    (*((int *)(((char *)(varPtr))+itclVarFlagOffset)))

/* Note that itclVarFlagOffset==0 exactly when we are running in Tcl8.5 */
#define ItclInitVarFlags(varPtr) \
    if (itclOldRuntime) { \
	(varPtr)->flags = (VAR_SCALAR | VAR_UNDEFINED | VAR_IN_HASHTABLE);\
    } else { \
        ((ItclShortVar *)(varPtr))->flags = 0;\
    }

/* This is used for CompiledLocal, not for Var & Co. That struct did not
 * change, but the correct flag init did! The flags bits themselves are
 * unchanged */

#define ItclInitVarArgument(varPtr) \
    if (itclOldRuntime) { \
	(varPtr)->flags = (VAR_SCALAR | VAR_ARGUMENT);\
    } else { \
	(varPtr)->flags = VAR_ARGUMENT;\
    }

#define TclIsVarNamespaceVar(varPtr) \
    (ItclVarFlags(varPtr) & VAR_NAMESPACE_VAR)

#define TclSetVarNamespaceVar(varPtr) \
    if (!TclIsVarNamespaceVar(varPtr)) {\
        ItclVarFlags(varPtr) |= VAR_NAMESPACE_VAR;\
        ItclVarRefCount(varPtr)++;\
    }

#define ItclClearVarUndefined(varPtr) \
    if (itclOldRuntime) { \
	ItclVarFlags(varPtr) &= ~VAR_UNDEFINED;\
    }

#ifndef MODULE_SCOPE
#define MODULE_SCOPE
#endif

MODULE_SCOPE Var * ItclVarHashCreateVar (TclVarHashTable * tablePtr, 
				const char * key, int * newPtr);

#endif /* Version dependent defs and macros */


#define ItclVarHashFindVar(tablePtr, key) \
    ItclVarHashCreateVar((tablePtr), (key), NULL)


/*
 * Some backward compatability adjustments.
 */

#if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0
#   define Tcl_GetString(obj)	Tcl_GetStringFromObj((obj), NULL)

    Var localStorage[20];     /* default storage for compiled locals */
} ItclContext;

/*
 *  Compatibility flags.  Used to support small "hacks".  These are stored
 *  in the global variable named itclCompatFlags.
 */

extern int itclCompatFlags;

#define ITCL_COMPAT_USECMDFLAGS 0x0001	/* Tcl8.4a1 introduced a different Command
					 * structure, and we need to adapt
					 * dynamically */
#define ITCL_COMPAT_USE_ISTATE_API 0x2  /* Tcl 8.5a2 added interp state APIs */

#include "itclIntDecls.h"

 *
 * ========================================================================
 *  AUTHOR:  Michael J. McLennan
 *           Bell Labs Innovations for Lucent Technologies
 *           [email protected]
 *           http://www.tcltk.com/itcl
 *
 *     RCS:  $Id: itcl_class.c,v 1.24 2007/08/07 20:05:29 msofer Exp $
 * ========================================================================
 *           Copyright (c) 1993-1998  Lucent Technologies, Inc.
 * ------------------------------------------------------------------------
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */
#include "itclInt.h"

 */
static void
ItclFreeClass(cdata)
    char *cdata;  /* class definition to be destroyed */
{
    ItclClass *cdefnPtr = (ItclClass*)cdata;


    Itcl_ListElem *elem;
    Tcl_HashSearch place;
    Tcl_HashEntry *entry;
    ItclVarDefn *vdefn;
    ItclVarLookup *vlookup;
    VarInHash *varPtr;


    /*
     *  Tear down the list of derived classes.  This list should
     *  really be empty if everything is working properly, but
     *  release it here just in case.
     */
    elem = Itcl_FirstListElem(&cdefnPtr->derived);
    while (elem) {
        Itcl_ReleaseData( Itcl_GetListValue(elem) );
        elem = Itcl_NextListElem(elem);
    }
    Itcl_DeleteList(&cdefnPtr->derived);

    /*
     *  Tear down the variable resolution table.  Some records
     *  appear multiple times in the table (for x, foo::x, etc.)
     *  so each one has a reference count.
     */


    entry = Tcl_FirstHashEntry(&cdefnPtr->resolveVars, &place);
    while (entry) {
        vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry);
        if (--vlookup->usage == 0) {
            /*
             *  If this is a common variable owned by this class,
             *  then release the class's hold on it.  If it's no
             *  longer being used, move it into a variable table
             *  for destruction.
             */
            if ( (vlookup->vdefn->member->flags & ITCL_COMMON) != 0 &&
                 vlookup->vdefn->member->classDefn == cdefnPtr ) {
                varPtr = (VarInHash*)vlookup->var.common;
                if (--ItclVarRefCount(varPtr) == 0) {
		    /*
		     * This is called after the namespace is already gone: the
		     * variable is already unset and ready to be freed.
		     */
		    

		    ckfree((char *)varPtr);
                }
            }
            ckfree((char*)vlookup);
        }
        entry = Tcl_NextHashEntry(&place);
    }


    Tcl_DeleteHashTable(&cdefnPtr->resolveVars);

    /*
     *  Tear down the virtual method table...
     */
    Tcl_DeleteHashTable(&cdefnPtr->resolveCmds);

            CompiledLocal *localPtr = procPtr->firstLocalPtr;
            Var *localVarPtr = varFramePtr->compiledLocals;
            int nameLen = strlen(name);
            int i;

            for (i=0; i < localCt; i++) {
                if (!TclIsVarTemporary(localPtr)) {
                    register char *localName = localPtr->name;
                    if ((name[0] == localName[0])
                            && (nameLen == localPtr->nameLength)
                            && (strcmp(name, localName) == 0)) {
                        *rPtr = (Tcl_Var)localVarPtr;
                        return TCL_OK;
                    }
                }
                ItclNextLocal(localVarPtr);
                localPtr = localPtr->nextPtr;
            }
        }

        /*
         *  If it's not a compiled local, then look in the frame's
         *  var hash table next.  This variable may have been
         *  created on the fly.
         */
        if (varFramePtr->varTablePtr != NULL) {
	    *rPtr = (Tcl_Var) ItclVarHashFindVar(varFramePtr->varTablePtr, name);
	    if (*rPtr) {

                return TCL_OK;
            }
        }
    }

    /*
     *  See if the variable is a known data member and accessible.

 *  table will point to the most-specific member.
 * ------------------------------------------------------------------------
 */
void
Itcl_BuildVirtualTables(cdefnPtr)
    ItclClass* cdefnPtr;       /* class definition being updated */
{
    Tcl_HashEntry *entry;
    Tcl_HashSearch place;
    ItclVarLookup *vlookup;
    ItclVarDefn *vdefn;
    ItclMemberFunc *mfunc;
    ItclHierIter hier;
    ItclClass *cdPtr;
    Namespace* nsPtr;

            /*
             *  If this is a common variable, then keep a reference to
             *  the variable directly.  Otherwise, keep an index into
             *  the object's variable table.
             */
            if ((vdefn->member->flags & ITCL_COMMON) != 0) {
                nsPtr = (Namespace*)cdPtr->namesp;
                vlookup->var.common = (Tcl_Var) ItclVarHashFindVar(&nsPtr->varTable, vdefn->member->name);


                assert(vlookup->var.common  != NULL);
            }
            else {
                /*
                 *  If this is a reference to the built-in "this"
                 *  variable, then its index is "0".  Otherwise,
                 *  add another slot to the end of the table.
                 */

 *
 * ========================================================================
 *  AUTHOR:  Michael J. McLennan
 *           Bell Labs Innovations for Lucent Technologies
 *           [email protected]
 *           http://www.tcltk.com/itcl
 *
 *     RCS:  $Id: itcl_cmds.c,v 1.31 2007/08/07 20:05:30 msofer Exp $
 * ========================================================================
 *           Copyright (c) 1993-1998  Lucent Technologies, Inc.
 * ------------------------------------------------------------------------
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */
#include "itclInt.h"

    set cmd [uplevel namespace which -command $ptr]\n\
    uplevel [list trace variable itcl-local-$ptr u \"::itcl::delete object $cmd; list\"]\n\
    return $ptr\n\
}";

int itclCompatFlags = -1;

#if ITCL_TCL_PRE_8_5
int itclVarFlagOffset; 
int itclVarRefCountOffset;
int itclVarInHashSize;
int itclVarLocalSize;
int itclVarValueOffset;
#endif


/*
 * ------------------------------------------------------------------------
 *  Initialize()
 *
 *  Invoked whenever a new interpeter is created to install the
 *  [incr Tcl] package.  Usually invoked within Tcl_AppInit() at

	    itclCompatFlags |= ITCL_COMPAT_USECMDFLAGS;
	}
#if USE_TCL_STUBS
	if ((maj == 8) && (min > 4) &&
		((type > TCL_ALPHA_RELEASE) || (ptch > 2))) {
	    itclCompatFlags |= ITCL_COMPAT_USE_ISTATE_API;
	}


#else
    itclCompatFlags = 0;
#endif

#if ITCL_TCL_PRE_8_5
#if USE_TCL_STUBS
	if ((maj == 8) && (min < 5)) {
#endif
	    itclVarFlagOffset     = ItclOffset(Var, flags);
	    itclVarRefCountOffset = ItclOffset(Var, refCount);
	    itclVarValueOffset    = ItclOffset(Var, value);
	    itclVarInHashSize     = sizeof(Var);
	    itclVarLocalSize	  = sizeof(Var);
#if USE_TCL_STUBS
	} else {
	    itclVarFlagOffset     = ItclOffset(ItclShortVar, flags);
	    itclVarRefCountOffset = ItclOffset(ItclVarInHash, refCount);
	    itclVarValueOffset    = ItclOffset(ItclShortVar, value);
	    itclVarInHashSize     = sizeof(ItclVarInHash);
	    itclVarLocalSize	  = sizeof(ItclShortVar);  
	}
#endif
#endif
    }

    /*
     *  Initialize the ensemble package first, since we need this
     *  for other parts of [incr Tcl].
     */
    if (Itcl_EnsembleInit(interp) != TCL_OK) {
        return TCL_ERROR;
    }
#endif
    
    /*
     *  Create the top-level data structure for tracking objects.
     *  Store this as "associated data" for easy access, but link
     *  it to the itcl namespace for ownership.
     */
    info = (ItclObjectInfo*)ckalloc(sizeof(ItclObjectInfo));
    info->interp = interp;

 *
 * ========================================================================
 *  AUTHOR:  Michael J. McLennan
 *           Bell Labs Innovations for Lucent Technologies
 *           [email protected]
 *           http://www.tcltk.com/itcl
 *
 *     RCS:  $Id: itcl_methods.c,v 1.21 2007/08/07 20:05:30 msofer Exp $
 * ========================================================================
 *           Copyright (c) 1993-1998  Lucent Technologies, Inc.
 * ------------------------------------------------------------------------
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */
#include "itclInt.h"

     *  If the implementation has not yet been defined, try to
     *  autoload it now.
     */

    if (!Itcl_IsMemberCodeImplemented(mcode)) {
        result = Tcl_VarEval(interp, "::auto_load ", member->fullname,
            (char*)NULL);

        if (result != TCL_OK) {
            char msg[256];
            sprintf(msg, "\n    (while autoloading code for \"%.100s\")",
                member->fullname);
            Tcl_AddErrorInfo(interp, msg);
            return result;
        }

    /*
     *  If the member is a constructor and the class has an
     *  initialization command, compile it here.
     */
    if ((member->flags & ITCL_CONSTRUCTOR) != 0 &&
        (member->classDefn->initCode != NULL)) {

        result = TclProcCompileProc(interp, mcode->procPtr,
            member->classDefn->initCode, (Namespace*)member->classDefn->namesp,
            "initialization code for", member->fullname);

        if (result != TCL_OK) {
            return result;
        }

    localPtr = (CompiledLocal*)ckalloc(
        (unsigned)(sizeof(CompiledLocal)-sizeof(localPtr->name) + nameLen+1)
    );

    localPtr->nextPtr = NULL;
    localPtr->nameLength = nameLen;
    localPtr->frameIndex = 0;  /* set this later */
    ItclInitVarArgument(localPtr);
    localPtr->resolveInfo = NULL;

    if (init != NULL) {
        localPtr->defValuePtr = Tcl_NewStringObj((CONST84 char *)init, -1);
        Tcl_IncrRefCount(localPtr->defValuePtr);
    } else {
        localPtr->defValuePtr = NULL;

     *  Set up the compiled locals in the call frame and assign
     *  argument variables.
     */
    if (member) {
        mcode = member->code;
        procPtr = mcode->procPtr;
























        /*
         * Invoking TclInitCompiledLocals with a framePtr->procPtr->bodyPtr
         * that is not a compiled byte code type leads to a crash. So
         * make sure that the body is compiled here. This needs to
         * be done even if the body of the Itcl method is not implemented
         * as a Tcl proc or has no implementation. The empty string should
         * have been defined as the body if no implementation was defined.
         */
        assert(mcode->procPtr->bodyPtr != NULL);

        result = TclProcCompileProc(interp, mcode->procPtr,
            mcode->procPtr->bodyPtr, (Namespace*)member->classDefn->namesp,
            "body for", member->fullname);

        if (result != TCL_OK) {
            return result;
        }

        /*
         *  If there are too many compiled locals to fit in the default
         *  storage space for the context, then allocate more space.
         */
        localCt = procPtr->numCompiledLocals;
        if (localCt > sizeof(contextPtr->localStorage)/itclVarLocalSize) {
            contextPtr->compiledLocals = (Var*)ckalloc(
                (unsigned)(localCt * itclVarLocalSize)
            );
        }

        /*
         * Initialize and resolve compiled variable references.
         * Class variables will have special resolution rules.
         * In that case, we call their "resolver" procs to get our
         * hands on the variable, and we make the compiled local a
         * link to the real variable.
         */

        framePtr->procPtr = procPtr;
        framePtr->numCompiledLocals = localCt;
        framePtr->compiledLocals = contextPtr->compiledLocals;

        TclInitCompiledLocals(interp, (CallFrame *) framePtr,
            (Namespace*)contextClass->namesp);
    }
    return result;
}



     *  Match the actual arguments against the procedure's formal
     *  parameters to compute local variables.
     */
    varPtr = framePtr->compiledLocals;

    for (argsLeft=mcode->argcount, argPtr=mcode->arglist, objv++, objc--;
         argsLeft > 0;
         argPtr=argPtr->nextPtr, argsLeft--, ItclNextLocal(varPtr), objv++, objc--)
    {
        if (!TclIsVarArgument(argPtr)) {
            Tcl_Panic("local variable %s is not argument but should be",
                argPtr->name);
            return TCL_ERROR;
        }
        if (TclIsVarTemporary(argPtr)) {
            Tcl_Panic("local variable is temporary but should be an argument");
            return TCL_ERROR;
        }

        /*
         *  Handle the special case of the last formal being "args".
         *  When it occurs, assign it a list consisting of all the
         *  remaining actual arguments.
         */
        if ((argsLeft == 1) && (strcmp(argPtr->name, "args") == 0)) {
            if (objc < 0) objc = 0;

            listPtr = Tcl_NewListObj(objc, objv);
            ItclVarObjValue(varPtr) = listPtr;
            Tcl_IncrRefCount(listPtr); /* local var is a reference */
	    ItclClearVarUndefined(varPtr);
            objc = 0;

            break;
        }

        /*
         *  Handle the special case of the last formal being "config".

                        configVars[vi]->member->classDefn->name, -1);
                    Tcl_AppendToObj(objPtr, "::", -1);
                    Tcl_AppendToObj(objPtr, configVars[vi]->member->name, -1);

                    Tcl_ListObjAppendElement(interp, listPtr, objPtr);
                }

                ItclVarObjValue(varPtr) = listPtr;
                Tcl_IncrRefCount(listPtr); /* local var is a reference */
		ItclClearVarUndefined(varPtr);

                objc = 0;  /* all remaining args handled */
            }

            else if (argPtr->defValuePtr) {
                value = Tcl_GetStringFromObj(argPtr->defValuePtr, (int*)NULL);

                        configVars[vi]->member->classDefn->name, -1);
                    Tcl_AppendToObj(objPtr, "::", -1);
                    Tcl_AppendToObj(objPtr, configVars[vi]->member->name, -1);

                    Tcl_ListObjAppendElement(interp, listPtr, objPtr);
                }

                ItclVarObjValue(varPtr) = listPtr;
                Tcl_IncrRefCount(listPtr); /* local var is a reference */
		ItclClearVarUndefined(varPtr);
            }
            else {
                objPtr = Tcl_NewStringObj("", 0);
                ItclVarObjValue(varPtr) = objPtr;
                Tcl_IncrRefCount(objPtr); /* local var is a reference */
		ItclClearVarUndefined(varPtr);
            }
        }

        /*
         *  Resume the usual processing of arguments...
         */
        else if (objc > 0) {          /* take next arg as value */
            objPtr = *objv;
            ItclVarObjValue(varPtr) = objPtr;
	    ItclClearVarUndefined(varPtr);
            Tcl_IncrRefCount(objPtr);  /* local var is a reference */
        }
        else if (argPtr->defValuePtr) {    /* ...or use default value */
            objPtr = argPtr->defValuePtr;
            ItclVarObjValue(varPtr) = objPtr;
	    ItclClearVarUndefined(varPtr);
            Tcl_IncrRefCount(objPtr);  /* local var is a reference */
        }
        else {
            if (mfunc) {
                objPtr = Tcl_GetObjResult(interp);
                Tcl_AppendToObj(objPtr, "wrong # args: should be \"", -1);
                Itcl_GetMemberFuncUsage(mfunc, contextObj, objPtr);

 *
 * ========================================================================
 *  AUTHOR:  Michael J. McLennan
 *           Bell Labs Innovations for Lucent Technologies
 *           [email protected]
 *           http://www.tcltk.com/itcl
 *
 *     RCS:  $Id: itcl_migrate.c,v 1.4 2007/08/07 20:05:30 msofer Exp $
 * ========================================================================
 *           Copyright (c) 1993-1998  Lucent Technologies, Inc.
 * ------------------------------------------------------------------------
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */
#include "itclInt.h"

 *
 *----------------------------------------------------------------------
 */

Var *
_TclNewVar()
{
    Var *varPtr;

    varPtr = (Var *) ckalloc(itclVarLocalSize);
    ItclInitVarFlags(varPtr);
    ItclVarObjValue(varPtr) = NULL;
#if ITCL_TCL_PRE_8_5
    if (itclOldRuntime) {
	varPtr->name = NULL;
	varPtr->nsPtr = NULL;
	varPtr->hPtr = NULL;
	varPtr->refCount = 0;
	varPtr->tracePtr = NULL;
	varPtr->searchPtr = NULL;
    }
#endif
    return varPtr;
}

#if ITCL_TCL_PRE_8_5
Var *
ItclVarHashCreateVar(
    TclVarHashTable *tablePtr,
    const char *key,
    int *newPtr)
{
#if (USE_TCL_STUBS)
    if (itclOldRuntime) {
#endif
	Tcl_HashEntry *hPtr;
	
	if (newPtr) {
	    Var *varPtr = _TclNewVar();

	    hPtr = Tcl_CreateHashEntry(tablePtr, key, newPtr);
	    varPtr->hPtr = hPtr;
	    Tcl_SetHashValue(hPtr, varPtr);	
	} else {
	    hPtr = Tcl_FindHashEntry(tablePtr, key);
	}	
	
	if (hPtr) {
	    return (Var *) Tcl_GetHashValue(hPtr);
	} else {
	    return NULL;
	}
#if (USE_TCL_STUBS)
    } else {
	/*
	 * An 8.5 runtime: TclVarHashCreateVar is at position 234 in the
	 * internal stubs table: call it.
	 */
	
	Var * (*TclVarHashCreateVar)(Tcl_HashTable *, const char *, int *) =
	    (Var * (*)(Tcl_HashTable *, const char *, int *)) *((&tclIntStubsPtr->reserved0)+234);
	return (*TclVarHashCreateVar)(tablePtr, key, newPtr);
    }
#endif
}
#endif

 *
 * ========================================================================
 *  AUTHOR:  Michael J. McLennan
 *           Bell Labs Innovations for Lucent Technologies
 *           [email protected]
 *           http://www.tcltk.com/itcl
 *
 *     RCS:  $Id: itcl_objects.c,v 1.17 2007/08/07 20:05:30 msofer Exp $
 * ========================================================================
 *           Copyright (c) 1993-1998  Lucent Technologies, Inc.
 * ------------------------------------------------------------------------
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */
#include "itclInt.h"

{
    Var *varPtr;
    Tcl_HashEntry *entry;
    ItclVarLookup *vlookup;
    ItclContext context;

    varPtr = _TclNewVar();
#if ITCL_TCL_PRE_8_5
    if (itclOldRuntime) {    
	varPtr->name = vdefn->member->name;
	varPtr->nsPtr = (Namespace*)vdefn->member->classDefn->namesp;

	/*
	 *  NOTE:  Tcl reports a "dangling upvar" error for variables
	 *         with a null "hPtr" field.  Put something non-zero
	 *         in here to keep Tcl_SetVar2() happy.  The only time
	 *         this field is really used is it remove a variable
	 *         from the hash table that contains it in CleanupVar,
	 *         but since these variables are protected by their
	 *         higher refCount, they will not be deleted by CleanupVar
	 *         anyway.  These variables are unset and removed in
	 *         ItclFreeObject().
	 */
	varPtr->hPtr = (Tcl_HashEntry*)0x1;
	ItclVarRefCount(varPtr) = 1;  /* protect from being deleted */
    }
#endif

    /*
     *  Install the new variable in the object's data array.
     *  Look up the appropriate index for the object using
     *  the data table in the class definition.
     */
    entry = Tcl_FindHashEntry(&contextObj->classDefn->resolveVars,

 *
 * ========================================================================
 *  AUTHOR:  Michael J. McLennan
 *           Bell Labs Innovations for Lucent Technologies
 *           [email protected]
 *           http://www.tcltk.com/itcl
 *
 *     RCS:  $Id: itcl_parse.c,v 1.12 2007/08/07 20:05:30 msofer Exp $
 * ========================================================================
 *           Copyright (c) 1993-1998  Lucent Technologies, Inc.
 * ------------------------------------------------------------------------
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */
#include "itclInt.h"

{
    ItclObjectInfo *info = (ItclObjectInfo*)clientData;
    ItclClass *cdefnPtr = (ItclClass*)Itcl_PeekStack(&info->cdefnStack);

    int newEntry;
    char *name, *init;
    ItclVarDefn *vdefn;

    Namespace *nsPtr;
    Var *varPtr;

    if ((objc < 2) || (objc > 3)) {
        Tcl_WrongNumArgs(interp, 1, objv, "varname ?init?");
        return TCL_ERROR;
    }

    /*
     *  Create the variable in the namespace associated with the
     *  class.  Do this the hard way, to avoid the variable resolver
     *  procedures.  These procedures won't work until we rebuild
     *  the virtual tables below.
     */
    nsPtr = (Namespace*)cdefnPtr->namesp;
    varPtr = ItclVarHashCreateVar(&nsPtr->varTable,
        vdefn->member->name, &newEntry);

#if ITCL_TCL_PRE_8_5
    if (newEntry && itclOldRuntime) {


	varPtr->nsPtr = nsPtr;



    }
#endif
    TclSetVarNamespaceVar(varPtr);



    ItclVarRefCount(varPtr)++;    /* another use by class */


    /*
     *  TRICKY NOTE:  Make sure to rebuild the virtual tables for this
     *    class so that this variable is ready to access.  The variable
     *    resolver for the parser namespace needs this info to find the
     *    variable if the developer tries to set it within the class

 *
 * ========================================================================
 *  AUTHOR:  Michael J. McLennan
 *           Bell Labs Innovations for Lucent Technologies
 *           [email protected]
 *           http://www.tcltk.com/itcl
 *
 *     RCS:  $Id: itcl_util.c,v 1.18 2007/08/07 20:05:30 msofer Exp $
 * ========================================================================
 *           Copyright (c) 1993-1998  Lucent Technologies, Inc.
 * ------------------------------------------------------------------------
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */
#include "itclInt.h"

    Tcl_Obj *objResult;             /* result object */
    char *errorInfo;                /* contents of errorInfo variable */
    char *errorCode;                /* contents of errorCode variable */
} InterpState;

#define TCL_STATE_VALID 0x01233210  /* magic bit pattern for validation */





/*
 * ------------------------------------------------------------------------
 *  Itcl_Assert()
 *
 *  Called whenever an assert() test fails.  Prints a diagnostic
 *  message and abruptly exits.