text: /*
   * tclOO.c --
   *
   *	This file contains the object-system core (NB: not Tcl_Obj, but ::oo)
   *
   * Copyright (c) 2005-2012 by Donal K. Fellows
   * Copyright (c) 2017 by Nathan Coulter
   *
   * See the file "license.terms" for information on usage and redistribution of
   * this file, and for a DISCLAIMER OF ALL WARRANTIES.
   */
  
  #ifdef HAVE_CONFIG_H
  #include "config.h"
  #endif
  #include "tclInt.h"
  #include "tclOOInt.h"
  
  /*
   * Commands in oo::define.
   */
  
  static const struct {
      const char *name;
      Tcl_ObjCmdProc *objProc;
      int flag;
  } defineCmds[] = {
      {"constructor", TclOODefineConstructorObjCmd, 0},
      {"definitionnamespace", TclOODefineDefnNsObjCmd, 0},
      {"deletemethod", TclOODefineDeleteMethodObjCmd, 0},
      {"destructor", TclOODefineDestructorObjCmd, 0},
      {"export", TclOODefineExportObjCmd, 0},
      {"forward", TclOODefineForwardObjCmd, 0},
      {"method", TclOODefineMethodObjCmd, 0},
      {"private", TclOODefinePrivateObjCmd, 0},
      {"renamemethod", TclOODefineRenameMethodObjCmd, 0},
      {"self", TclOODefineSelfObjCmd, 0},
      {"unexport", TclOODefineUnexportObjCmd, 0},
      {NULL, NULL, 0}
  }, objdefCmds[] = {
      {"class", TclOODefineClassObjCmd, 1},
      {"deletemethod", TclOODefineDeleteMethodObjCmd, 1},
      {"export", TclOODefineExportObjCmd, 1},
      {"forward", TclOODefineForwardObjCmd, 1},
      {"method", TclOODefineMethodObjCmd, 1},
      {"private", TclOODefinePrivateObjCmd, 1},
      {"renamemethod", TclOODefineRenameMethodObjCmd, 1},
      {"self", TclOODefineObjSelfObjCmd, 0},
      {"unexport", TclOODefineUnexportObjCmd, 1},
      {NULL, NULL, 0}
  };
  
  /*
   * What sort of size of things we like to allocate.
   */
  
  #define ALLOC_CHUNK 8
  
  /*
   * Function declarations for things defined in this file.
   */
  
  static Object *		AllocObject(Tcl_Interp *interp, const char *nameStr,
  			    Namespace *nsPtr, const char *nsNameStr);
  static int		CloneClassMethod(Tcl_Interp *interp, Class *clsPtr,
  			    Method *mPtr, Tcl_Obj *namePtr,
  			    Method **newMPtrPtr);
  static int		CloneObjectMethod(Tcl_Interp *interp, Object *oPtr,
  			    Method *mPtr, Tcl_Obj *namePtr);
  static void		DeletedDefineNamespace(ClientData clientData);
  static void		DeletedObjdefNamespace(ClientData clientData);
  static void		DeletedHelpersNamespace(ClientData clientData);
  static Tcl_NRPostProc	FinalizeAlloc;
  static Tcl_NRPostProc	FinalizeNext;
  static Tcl_NRPostProc	FinalizeObjectCall;
  static inline void	InitClassPath(Tcl_Interp * interp, Class *clsPtr);
  static void		InitClassSystemRoots(Tcl_Interp *interp,
  			    Foundation *fPtr);
  static int		InitFoundation(Tcl_Interp *interp);
  static Tcl_InterpDeleteProc	KillFoundation;
  static void		MyDeleted(ClientData clientData);
  static void		ObjectNamespaceDeleted(ClientData clientData);
  static Tcl_CommandTraceProc	ObjectRenamedTrace;
  static inline void	RemoveClass(Class **list, int num, int idx);
  static inline void	RemoveObject(Object **list, int num, int idx);
  static inline void	SquelchCachedName(Object *oPtr);
  
  static int		PublicNRObjectCmd(ClientData clientData,
  			    Tcl_Interp *interp, int objc,
  			    Tcl_Obj *const *objv);
  static int		PrivateNRObjectCmd(ClientData clientData,
  			    Tcl_Interp *interp, int objc,
  			    Tcl_Obj *const *objv);
  static int		MyClassNRObjCmd(ClientData clientData,
  			    Tcl_Interp *interp, int objc,
  			    Tcl_Obj *const *objv);
  static void		MyClassDeleted(ClientData clientData);
  
  /*
   * Methods in the oo::object and oo::class classes. First, we define a helper
   * macro that makes building the method type declaration structure a lot
   * easier. No point in making life harder than it has to be!
   *
   * Note that the core methods don't need clone or free proc callbacks.
   */
  
  #define DCM(name,visibility,proc) \
      {name,visibility,\
  	{TCL_OO_METHOD_VERSION_CURRENT,"core method: "#name,proc,NULL,NULL}}
  
  static const DeclaredClassMethod objMethods[] = {
      DCM("destroy", 1,	TclOO_Object_Destroy),
      DCM("eval", 0,	TclOO_Object_Eval),
      DCM("unknown", 0,	TclOO_Object_Unknown),
      DCM("variable", 0,	TclOO_Object_LinkVar),
      DCM("varname", 0,	TclOO_Object_VarName),
      {NULL, 0, {0, NULL, NULL, NULL, NULL}}
  }, clsMethods[] = {
      DCM("create", 1,	TclOO_Class_Create),
      DCM("new", 1,	TclOO_Class_New),
      DCM("createWithNamespace", 0, TclOO_Class_CreateNs),
      {NULL, 0, {0, NULL, NULL, NULL, NULL}}
  };
  
  /*
   * And for the oo::class constructor...
   */
  
  static const Tcl_MethodType classConstructor = {
      TCL_OO_METHOD_VERSION_CURRENT,
      "oo::class constructor",
      TclOO_Class_Constructor, NULL, NULL
  };
  
  /*
   * Scripted parts of TclOO. First, the main script (cannot be outside this
   * file).
   */
  
  static const char *initScript =
  "package ifneeded TclOO " TCLOO_PATCHLEVEL " {# Already present, OK?};"
  "namespace eval ::oo { variable version " TCLOO_VERSION " };"
  "namespace eval ::oo { variable patchlevel " TCLOO_PATCHLEVEL " };";
  /* "tcl_findLibrary tcloo $oo::version $oo::version" */
  /* " tcloo.tcl OO_LIBRARY oo::library;"; */
  
  /*
   * The scripted part of the definitions of TclOO.
   */
  
  #include "tclOOScript.h"
  
  /*
   * The actual definition of the variable holding the TclOO stub table.
   */
  
  MODULE_SCOPE const TclOOStubs tclOOStubs;
  
  /*
   * Convenience macro for getting the foundation from an interpreter.
   */
  
  #define GetFoundation(interp) \
  	((Foundation *)((Interp *)(interp))->objectFoundation)
  
  /*
   * Macros to make inspecting into the guts of an object cleaner.
   *
   * The ocPtr parameter (only in these macros) is assumed to work fine with
   * either an oPtr or a classPtr. Note that the roots oo::object and oo::class
   * have _both_ their object and class flags tagged with ROOT_OBJECT and
   * ROOT_CLASS respectively.
   */
  
  #define Destructing(oPtr)	((oPtr)->flags & OBJECT_DESTRUCTING)
  #define IsRootObject(ocPtr)	((ocPtr)->flags & ROOT_OBJECT)
  #define IsRootClass(ocPtr)	((ocPtr)->flags & ROOT_CLASS)
  #define IsRoot(ocPtr)		((ocPtr)->flags & (ROOT_OBJECT|ROOT_CLASS))
  
  #define RemoveItem(type, lst, i) \
      do {						\
  	Remove ## type ((lst).list, (lst).num, i);	\
  	(lst).num--;					\
      } while (0)
  
  /*
   * ----------------------------------------------------------------------
   *
   * RemoveClass, RemoveObject --
   *
   *	Helpers for the RemoveItem macro for deleting a class or object from a
   *	list. Setting the "empty" location to NULL makes debugging a little
   *	easier.
   *
   * ----------------------------------------------------------------------
   */
  
  static inline void
  RemoveClass(
      Class **list,
      int num,
      int idx)
  {
      for (; idx < num - 1; idx++) {
  	list[idx] = list[idx + 1];
      }
      list[idx] = NULL;
  }
  
  static inline void
  RemoveObject(
      Object **list,
      int num,
      int idx)
  {
      for (; idx < num - 1; idx++) {
  	list[idx] = list[idx + 1];
      }
      list[idx] = NULL;
  }
  
  /*
   * ----------------------------------------------------------------------
   *
   * TclOOInit --
   *
   *	Called to initialise the OO system within an interpreter.
   *
   * Result:
   *	TCL_OK if the setup succeeded. Currently assumed to always work.
   *
   * Side effects:
   *	Creates namespaces, commands, several classes and a number of
   *	callbacks. Upon return, the OO system is ready for use.
   *
   * ----------------------------------------------------------------------
   */
  
  int
  TclOOInit(
      Tcl_Interp *interp)		/* The interpreter to install into. */
  {
      /*
       * Build the core of the OO system.
       */
  
      if (InitFoundation(interp) != TCL_OK) {
  	return TCL_ERROR;
      }
  
      /*
       * Run our initialization script and, if that works, declare the package
       * to be fully provided.
       */
  
      if (Tcl_EvalEx(interp, initScript, -1, 0) != TCL_OK) {
  	return TCL_ERROR;
      }
  
      return Tcl_PkgProvideEx(interp, "TclOO", TCLOO_PATCHLEVEL,
  	    (void *) &tclOOStubs);
  }
  
  /*
   * ----------------------------------------------------------------------
   *
   * TclOOGetFoundation --
   *
   *	Get a reference to the OO core class system.
   *
   * ----------------------------------------------------------------------
   */
  
  Foundation *
  TclOOGetFoundation(
      Tcl_Interp *interp)
  {
      return GetFoundation(interp);
  }
  
  /*
   * ----------------------------------------------------------------------
   *
   * InitFoundation --
   *
   *	Set up the core of the OO core class system. This is a structure
   *	holding references to the magical bits that need to be known about in
   *	other places, plus the oo::object and oo::class classes.
   *
   * ----------------------------------------------------------------------
   */
  
  static int
  InitFoundation(
      Tcl_Interp *interp)
  {
      static Tcl_ThreadDataKey tsdKey;
      ThreadLocalData *tsdPtr =
  	    (ThreadLocalData *)Tcl_GetThreadData(&tsdKey, sizeof(ThreadLocalData));
      Foundation *fPtr = (Foundation *)Tcl_Alloc(sizeof(Foundation));
      Tcl_Obj *namePtr;
      Tcl_DString buffer;
      Command *cmdPtr;
      int i;
  
      /*
       * Initialize the structure that holds the OO system core. This is
       * attached to the interpreter via an assocData entry; not very efficient,
       * but the best we can do without hacking the core more.
       */
  
      memset(fPtr, 0, sizeof(Foundation));
      ((Interp *) interp)->objectFoundation = fPtr;
      fPtr->interp = interp;
      fPtr->ooNs = Tcl_CreateNamespace(interp, "::oo", fPtr, NULL);
      Tcl_Export(interp, fPtr->ooNs, "[a-z]*", 1);
      fPtr->defineNs = Tcl_CreateNamespace(interp, "::oo::define", fPtr,
  	    DeletedDefineNamespace);
      fPtr->objdefNs = Tcl_CreateNamespace(interp, "::oo::objdefine", fPtr,
  	    DeletedObjdefNamespace);
      fPtr->helpersNs = Tcl_CreateNamespace(interp, "::oo::Helpers", fPtr,
  	    DeletedHelpersNamespace);
      fPtr->epoch = 1;
      fPtr->tsdPtr = tsdPtr;
      TclNewLiteralStringObj(fPtr->unknownMethodNameObj, "unknown");
      TclNewLiteralStringObj(fPtr->constructorName, "<constructor>");
      TclNewLiteralStringObj(fPtr->destructorName, "<destructor>");
      TclNewLiteralStringObj(fPtr->clonedName, "<cloned>");
      TclNewLiteralStringObj(fPtr->defineName, "::oo::define");
      Tcl_IncrRefCount(fPtr->unknownMethodNameObj);
      Tcl_IncrRefCount(fPtr->constructorName);
      Tcl_IncrRefCount(fPtr->destructorName);
      Tcl_IncrRefCount(fPtr->clonedName);
      Tcl_IncrRefCount(fPtr->defineName);
      Tcl_CreateObjCommand(interp, "::oo::UnknownDefinition",
  	    TclOOUnknownDefinition, NULL, NULL);
      TclNewLiteralStringObj(namePtr, "::oo::UnknownDefinition");
      Tcl_SetNamespaceUnknownHandler(interp, fPtr->defineNs, namePtr);
      Tcl_SetNamespaceUnknownHandler(interp, fPtr->objdefNs, namePtr);
  
      /*
       * Create the subcommands in the oo::define and oo::objdefine spaces.
       */
  
      Tcl_DStringInit(&buffer);
      for (i = 0 ; defineCmds[i].name ; i++) {
  	TclDStringAppendLiteral(&buffer, "::oo::define::");
  	Tcl_DStringAppend(&buffer, defineCmds[i].name, -1);
  	Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer),
  		defineCmds[i].objProc, INT2PTR(defineCmds[i].flag), NULL);
  	Tcl_DStringFree(&buffer);
      }
      for (i = 0 ; objdefCmds[i].name ; i++) {
  	TclDStringAppendLiteral(&buffer, "::oo::objdefine::");
  	Tcl_DStringAppend(&buffer, objdefCmds[i].name, -1);
  	Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer),
  		objdefCmds[i].objProc, INT2PTR(objdefCmds[i].flag), NULL);
  	Tcl_DStringFree(&buffer);
      }
  
      Tcl_CallWhenDeleted(interp, KillFoundation, NULL);
  
      /*
       * Create the special objects at the core of the object system.
       */
  
      InitClassSystemRoots(interp, fPtr);
  
      /*
       * Basic method declarations for the core classes.
       */
  
      for (i = 0 ; objMethods[i].name ; i++) {
  	TclOONewBasicMethod(interp, fPtr->objectCls, &objMethods[i]);
      }
      for (i = 0 ; clsMethods[i].name ; i++) {
  	TclOONewBasicMethod(interp, fPtr->classCls, &clsMethods[i]);
      }
  
      /*
       * Finish setting up the class of classes by marking the 'new' method as
       * private; classes, unlike general objects, must have explicit names. We
       * also need to create the constructor for classes.
       */
  
      TclNewLiteralStringObj(namePtr, "new");
      Tcl_NewInstanceMethod(interp, (Tcl_Object) fPtr->classCls->thisPtr,
  	    namePtr /* keeps ref */, 0 /* private */, NULL, NULL);
      fPtr->classCls->constructorPtr = (Method *) Tcl_NewMethod(interp,
  	    (Tcl_Class) fPtr->classCls, NULL, 0, &classConstructor, NULL);
  
      /*
       * Create non-object commands and plug ourselves into the Tcl [info]
       * ensemble.
       */
  
      cmdPtr = (Command *) Tcl_NRCreateCommand(interp, "::oo::Helpers::next",
  	    NULL, TclOONextObjCmd, NULL, NULL);
      cmdPtr->compileProc = TclCompileObjectNextCmd;
      cmdPtr = (Command *) Tcl_NRCreateCommand(interp, "::oo::Helpers::nextto",
  	    NULL, TclOONextToObjCmd, NULL, NULL);
      cmdPtr->compileProc = TclCompileObjectNextToCmd;
      cmdPtr = (Command *) Tcl_CreateObjCommand(interp, "::oo::Helpers::self",
  	    TclOOSelfObjCmd, NULL, NULL);
      cmdPtr->compileProc = TclCompileObjectSelfCmd;
      Tcl_CreateObjCommand(interp, "::oo::define", TclOODefineObjCmd, NULL,
  	    NULL);
      Tcl_CreateObjCommand(interp, "::oo::objdefine", TclOOObjDefObjCmd, NULL,
  	    NULL);
      Tcl_CreateObjCommand(interp, "::oo::copy", TclOOCopyObjectCmd, NULL,NULL);
      TclOOInitInfo(interp);
  
      /*
       * Now make the class of slots.
       */
  
      if (TclOODefineSlots(fPtr) != TCL_OK) {
  	return TCL_ERROR;
      }
  
      /*
       * Evaluate the remaining definitions, which are a compiled-in Tcl script.
       */
  
      return Tcl_EvalEx(interp, tclOOSetupScript, -1, 0);
  }
  
  /*
   * ----------------------------------------------------------------------
   *
   * InitClassSystemRoots --
   *
   *	Creates the objects at the core of the object system. These need to be
   *	spliced manually.
   *
   * ----------------------------------------------------------------------
   */
  
  static void
  InitClassSystemRoots(
      Tcl_Interp *interp,
      Foundation *fPtr)
  {
      Class fakeCls;
      Object fakeObject;
      Tcl_Obj *defNsName;
  
      /* Stand up a phony class for bootstrapping. */
      fPtr->objectCls = &fakeCls;
      /* referenced in TclOOAllocClass to increment the refCount. */
      fakeCls.thisPtr = &fakeObject;
  
      fPtr->objectCls = TclOOAllocClass(interp,
  	    AllocObject(interp, "object", (Namespace *)fPtr->ooNs, NULL));
      /* Corresponding TclOODecrRefCount in KillFoudation */
      AddRef(fPtr->objectCls->thisPtr);
  
      /*
       * This is why it is unnecessary in this routine to replace the
       * incremented reference count of fPtr->objectCls that was swallowed by
       * fakeObject.
       */
  
      fPtr->objectCls->superclasses.num = 0;
      Tcl_Free(fPtr->objectCls->superclasses.list);
      fPtr->objectCls->superclasses.list = NULL;
  
      /*
       * Special initialization for the primordial objects.
       */
  
      fPtr->objectCls->thisPtr->flags |= ROOT_OBJECT;
      fPtr->objectCls->flags |= ROOT_OBJECT;
      TclNewLiteralStringObj(defNsName, "::oo::objdefine");
      fPtr->objectCls->objDefinitionNs = defNsName;
      Tcl_IncrRefCount(defNsName);
  
      fPtr->classCls = TclOOAllocClass(interp,
  	    AllocObject(interp, "class", (Namespace *)fPtr->ooNs, NULL));
      /* Corresponding TclOODecrRefCount in KillFoudation */
      AddRef(fPtr->classCls->thisPtr);
  
      /*
       * Increment reference counts for each reference because these
       * relationships can be dynamically changed.
       *
       * Corresponding TclOODecrRefCount for all incremented refcounts is in
       * KillFoundation.
       */
  
      /*
       * Rewire bootstrapped objects.
       */
  
      fPtr->objectCls->thisPtr->selfCls = fPtr->classCls;
      AddRef(fPtr->classCls->thisPtr);
      TclOOAddToInstances(fPtr->objectCls->thisPtr, fPtr->classCls);
  
      fPtr->classCls->thisPtr->selfCls = fPtr->classCls;
      AddRef(fPtr->classCls->thisPtr);
      TclOOAddToInstances(fPtr->classCls->thisPtr, fPtr->classCls);
  
      fPtr->classCls->thisPtr->flags |= ROOT_CLASS;
      fPtr->classCls->flags |= ROOT_CLASS;
      TclNewLiteralStringObj(defNsName, "::oo::define");
      fPtr->classCls->clsDefinitionNs = defNsName;
      Tcl_IncrRefCount(defNsName);
  
      /* Standard initialization for new Objects */
      TclOOAddToSubclasses(fPtr->classCls, fPtr->objectCls);
  
      /*
       * THIS IS THE ONLY FUNCTION THAT DOES NON-STANDARD CLASS SPLICING.
       * Everything else is careful to prohibit looping.
       */
  }
  
  /*
   * ----------------------------------------------------------------------
   *
   * DeletedDefineNamespace, DeletedObjdefNamespace, DeletedHelpersNamespace --
   *
   *	Simple helpers used to clear fields of the foundation when they no
   *	longer hold useful information.
   *
   * ----------------------------------------------------------------------
   */
  
  static void
  DeletedDefineNamespace(
      ClientData clientData)
  {
      Foundation *fPtr = (Foundation *)clientData;
  
      fPtr->defineNs = NULL;
  }
  
  static void
  DeletedObjdefNamespace(
      ClientData clientData)
  {
      Foundation *fPtr = (Foundation *)clientData;
  
      fPtr->objdefNs = NULL;
  }
  
  static void
  DeletedHelpersNamespace(
      ClientData clientData)
  {
      Foundation *fPtr = (Foundation *)clientData;
  
      fPtr->helpersNs = NULL;
  }
  
  /*
   * ----------------------------------------------------------------------
   *
   * KillFoundation --
   *
   *	Delete those parts of the OO core that are not deleted automatically
   *	when the objects and classes themselves are destroyed.
   *
   * ----------------------------------------------------------------------
   */
  
  static void
  KillFoundation(
      TCL_UNUSED(void *),
      Tcl_Interp *interp)	/* The interpreter containing the OO system
  			 * foundation. */
  {
      Foundation *fPtr = GetFoundation(interp);
  
      TclDecrRefCount(fPtr->unknownMethodNameObj);
      TclDecrRefCount(fPtr->constructorName);
      TclDecrRefCount(fPtr->destructorName);
      TclDecrRefCount(fPtr->clonedName);
      TclDecrRefCount(fPtr->defineName);
      TclOODecrRefCount(fPtr->objectCls->thisPtr);
      TclOODecrRefCount(fPtr->classCls->thisPtr);
  
      Tcl_Free(fPtr);
  }
  
  /*
   * ----------------------------------------------------------------------
   *
   * AllocObject --
   *
   *	Allocate an object of basic type. Does not splice the object into its
   *	class's instance list.  The caller must set the classPtr on the object
   *	to either a class or NULL, call TclOOAddToInstances to add the object
   *	to the class's instance list, and if the object itself is a class, use
   *	call TclOOAddToSubclasses() to add it to the right class's list of
   *	subclasses.
   *
   * ----------------------------------------------------------------------
   */
  
  static Object *
  AllocObject(
      Tcl_Interp *interp,		/* Interpreter within which to create the
  				 * object. */
      const char *nameStr,	/* The name of the object to create, or NULL
  				 * if the OO system should pick the object
  				 * name itself (equal to the namespace
  				 * name). */
      Namespace *nsPtr,		/* The namespace to create the object in, or
  				 * NULL if *nameStr is NULL */
      const char *nsNameStr)	/* The name of the namespace to create, or
  				 * NULL if the OO system should pick a unique
  				 * name itself. If this is non-NULL but names
  				 * a namespace that already exists, the effect
  				 * will be the same as if this was NULL. */
  {
      Foundation *fPtr = GetFoundation(interp);
      Object *oPtr;
      Command *cmdPtr;
      CommandTrace *tracePtr;
      size_t creationEpoch;
  
      oPtr = (Object *)Tcl_Alloc(sizeof(Object));
      memset(oPtr, 0, sizeof(Object));
  
      /*
       * Every object has a namespace; make one. Note that this also normally
       * computes the creation epoch value for the object, a sequence number
       * that is unique to the object (and which allows us to manage method
       * caching without comparing pointers).
       *
       * When creating a namespace, we first check to see if the caller
       * specified the name for the namespace. If not, we generate namespace
       * names using the epoch until such time as a new namespace is actually
       * created.
       */
  
      if (nsNameStr != NULL) {
  	oPtr->namespacePtr = Tcl_CreateNamespace(interp, nsNameStr, oPtr, NULL);
  	if (oPtr->namespacePtr != NULL) {
  	    creationEpoch = ++fPtr->tsdPtr->nsCount;
  	    goto configNamespace;
  	}
  	Tcl_ResetResult(interp);
      }
  
      while (1) {
  	char objName[10 + TCL_INTEGER_SPACE];
  
  	sprintf(objName, "::oo::Obj%" TCL_Z_MODIFIER "u", ++fPtr->tsdPtr->nsCount);
  	oPtr->namespacePtr = Tcl_CreateNamespace(interp, objName, oPtr, NULL);
  	if (oPtr->namespacePtr != NULL) {
  	    creationEpoch = fPtr->tsdPtr->nsCount;
  	    break;
  	}
  
  	/*
  	 * Could not make that namespace, so we make another. But first we
  	 * have to get rid of the error message from Tcl_CreateNamespace,
  	 * since that's something that should not be exposed to the user.
  	 */
  
  	Tcl_ResetResult(interp);
      }
  
    configNamespace:
      ((Namespace *) oPtr->namespacePtr)->refCount++;
  
      /*
       * Make the namespace know about the helper commands. This grants access
       * to the [self] and [next] commands.
       */
  
      if (fPtr->helpersNs != NULL) {
  	TclSetNsPath((Namespace *) oPtr->namespacePtr, 1, &fPtr->helpersNs);
      }
      TclOOSetupVariableResolver(oPtr->namespacePtr);
  
      /*
       * Suppress use of compiled versions of the commands in this object's
       * namespace and its children; causes wrong behaviour without expensive
       * recompilation. [Bug 2037727]
       */
  
      ((Namespace *) oPtr->namespacePtr)->flags |= NS_SUPPRESS_COMPILATION;
  
      /*
       * Set up a callback to get notification of the deletion of a namespace
       * when enough of the namespace still remains to execute commands and
       * access variables in it. [Bug 2950259]
       */
  
      ((Namespace *) oPtr->namespacePtr)->earlyDeleteProc = ObjectNamespaceDeleted;
  
      /*
       * Fill in the rest of the non-zero/NULL parts of the structure.
       */
  
      oPtr->fPtr = fPtr;
      oPtr->creationEpoch = creationEpoch;
  
      /*
       * An object starts life with a refCount of 2 to mark the two stages of
       * destruction it occur:  A call to ObjectRenamedTrace(), and a call to
       * ObjectNamespaceDeleted().
       */
  
      oPtr->refCount = 2;
      oPtr->flags = USE_CLASS_CACHE;
  
      /*
       * Finally, create the object commands and initialize the trace on the
       * public command (so that the object structures are deleted when the
       * command is deleted).
       */
  
      if (!nameStr) {
  	nameStr = oPtr->namespacePtr->name;
  	nsPtr = (Namespace *)oPtr->namespacePtr;
  	if (nsPtr->parentPtr != NULL) {
  	    nsPtr = nsPtr->parentPtr;
  	}
      }
      oPtr->command = TclCreateObjCommandInNs(interp, nameStr,
  	(Tcl_Namespace *)nsPtr, TclOOPublicObjectCmd, oPtr, NULL);
  
      /*
       * Add the NRE command and trace directly. While this breaks a number of
       * abstractions, it is faster and we're inside Tcl here so we're allowed.
       */
  
      cmdPtr = (Command *) oPtr->command;
      cmdPtr->nreProc = PublicNRObjectCmd;
      cmdPtr->tracePtr = tracePtr = (CommandTrace *)Tcl_Alloc(sizeof(CommandTrace));
      tracePtr->traceProc = ObjectRenamedTrace;
      tracePtr->clientData = oPtr;
      tracePtr->flags = TCL_TRACE_RENAME|TCL_TRACE_DELETE;
      tracePtr->nextPtr = NULL;
      tracePtr->refCount = 1;
  
      oPtr->myCommand = TclNRCreateCommandInNs(interp, "my", oPtr->namespacePtr,
  	    TclOOPrivateObjectCmd, PrivateNRObjectCmd, oPtr, MyDeleted);
      oPtr->myclassCommand = TclNRCreateCommandInNs(interp, "myclass",
  	    oPtr->namespacePtr, TclOOMyClassObjCmd, MyClassNRObjCmd, oPtr,
              MyClassDeleted);
      return oPtr;
  }
  
  /*
   * ----------------------------------------------------------------------
   *
   * SquelchCachedName --
   *
   *	Encapsulates how to throw away a cached object name. Called from
   *	object rename traces and at object destruction.
   *
   * ----------------------------------------------------------------------
   */
  
  static inline void
  SquelchCachedName(
      Object *oPtr)
  {
      if (oPtr->cachedNameObj) {
  	Tcl_DecrRefCount(oPtr->cachedNameObj);
  	oPtr->cachedNameObj = NULL;
      }
  }
  
  /*
   * ----------------------------------------------------------------------
   *
   * MyDeleted, MyClassDeleted --
   *
   *	These callbacks are triggered when the object's [my] or [myclass]
   *	commands are deleted by any mechanism. They just mark the object as
   *	not having a [my] command or [myclass] command, and so prevent cleanup
   *	of those commands when the object itself is deleted.
   *
   * ----------------------------------------------------------------------
   */
  
  static void
  MyDeleted(
      ClientData clientData)	/* Reference to the object whose [my] has been
  				 * squelched. */
  {
      Object *oPtr = (Object *)clientData;
  
      oPtr->myCommand = NULL;
  }
  
  static void
  MyClassDeleted(
      ClientData clientData)
  {
      Object *oPtr = (Object *)clientData;
      oPtr->myclassCommand = NULL;
  }
  
  /*
   * ----------------------------------------------------------------------
   *
   * ObjectRenamedTrace --
   *
   *	This callback is triggered when the object is deleted by any
   *	mechanism. It runs the destructors and arranges for the actual cleanup
   *	of the object's namespace, which in turn triggers cleansing of the
   *	object data structures.
   *
   * ----------------------------------------------------------------------
   */
  
  static void
  ObjectRenamedTrace(
      ClientData clientData,	/* The object being deleted. */
      TCL_UNUSED(Tcl_Interp *),
      TCL_UNUSED(const char *) /*oldName*/,
      TCL_UNUSED(const char *) /*newName*/,
      int flags)			/* Why was the object deleted? */
  {
      Object *oPtr = (Object *)clientData;
  
      /*
       * If this is a rename and not a delete of the object, we just flush the
       * cache of the object name.
       */
  
      if (flags & TCL_TRACE_RENAME) {
  	SquelchCachedName(oPtr);
  	return;
      }
  
      /*
       * The namespace is only deleted if it hasn't already been deleted. [Bug
       * 2950259].
       */
  
      if (!Destructing(oPtr)) {
  	Tcl_DeleteNamespace(oPtr->namespacePtr);
      }
      oPtr->command = NULL;
      TclOODecrRefCount(oPtr);
      return;
  }
  
  /*
   * ----------------------------------------------------------------------
   *
   * TclOODeleteDescendants --
   *
   *	Delete all descendants of a particular class.
   *
   * ----------------------------------------------------------------------
   */
  
  void
  TclOODeleteDescendants(
      Tcl_Interp *interp,		/* The interpreter containing the class. */
      Object *oPtr)		/* The object representing the class. */
  {
      Class *clsPtr = oPtr->classPtr, *subclassPtr, *mixinSubclassPtr;
      Object *instancePtr;
  
      /*
       * Squelch classes that this class has been mixed into.
       */
  
      if (clsPtr->mixinSubs.num > 0) {
  	while (clsPtr->mixinSubs.num > 0) {
  	    mixinSubclassPtr =
  		    clsPtr->mixinSubs.list[clsPtr->mixinSubs.num - 1];
  
  	    /*
  	     * This condition also covers the case where mixinSubclassPtr ==
  	     * clsPtr
  	     */
  
  	    if (!Destructing(mixinSubclassPtr->thisPtr)
  		    && !(mixinSubclassPtr->thisPtr->flags & DONT_DELETE)) {
  		Tcl_DeleteCommandFromToken(interp,
  			mixinSubclassPtr->thisPtr->command);
  	    }
  	    TclOORemoveFromMixinSubs(mixinSubclassPtr, clsPtr);
  	}
      }
      if (clsPtr->mixinSubs.size > 0) {
  	Tcl_Free(clsPtr->mixinSubs.list);
  	clsPtr->mixinSubs.size = 0;
      }
  
      /*
       * Squelch subclasses of this class.
       */
  
      if (clsPtr->subclasses.num > 0) {
  	while (clsPtr->subclasses.num > 0) {
  	    subclassPtr = clsPtr->subclasses.list[clsPtr->subclasses.num - 1];
  	    if (!Destructing(subclassPtr->thisPtr) && !IsRoot(subclassPtr)
  		    && !(subclassPtr->thisPtr->flags & DONT_DELETE)) {
  		Tcl_DeleteCommandFromToken(interp,
  			subclassPtr->thisPtr->command);
  	    }
  	    TclOORemoveFromSubclasses(subclassPtr, clsPtr);
  	}
      }
      if (clsPtr->subclasses.size > 0) {
  	Tcl_Free(clsPtr->subclasses.list);
  	clsPtr->subclasses.list = NULL;
  	clsPtr->subclasses.size = 0;
      }
  
      /*
       * Squelch instances of this class (includes objects we're mixed into).
       */
  
      if (clsPtr->instances.num > 0) {
  	while (clsPtr->instances.num > 0) {
  	    instancePtr = clsPtr->instances.list[clsPtr->instances.num - 1];
  
  	    /*
  	     * This condition also covers the case where instancePtr == oPtr
  	     */
  
  	    if (!Destructing(instancePtr) && !IsRoot(instancePtr) &&
  		    !(instancePtr->flags & DONT_DELETE)) {
  		Tcl_DeleteCommandFromToken(interp, instancePtr->command);
  	    }
  	    TclOORemoveFromInstances(instancePtr, clsPtr);
  	}
      }
      if (clsPtr->instances.size > 0) {
  	Tcl_Free(clsPtr->instances.list);
  	clsPtr->instances.list = NULL;
  	clsPtr->instances.size = 0;
      }
  }
  
  /*
   * ----------------------------------------------------------------------
   *
   * TclOOReleaseClassContents --
   *
   *	Tear down the special class data structure, including deleting all
   *	dependent classes and objects.
   *
   * ----------------------------------------------------------------------
   */
  
  void
  TclOOReleaseClassContents(
      Tcl_Interp *interp,		/* The interpreter containing the class. */
      Object *oPtr)		/* The object representing the class. */
  {
      FOREACH_HASH_DECLS;
      int i;
      Class *clsPtr = oPtr->classPtr, *tmpClsPtr;
      Method *mPtr;
      Foundation *fPtr = oPtr->fPtr;
      Tcl_Obj *variableObj;
      PrivateVariableMapping *privateVariable;
  
      /*
       * Sanity check!
       */
  
      if (!Destructing(oPtr)) {
  	if (IsRootClass(oPtr)) {
  	    Tcl_Panic("deleting class structure for non-deleted %s",
  		    "::oo::class");
  	} else if (IsRootObject(oPtr)) {
  	    Tcl_Panic("deleting class structure for non-deleted %s",
  		    "::oo::object");
  	}
      }
  
      /*
       * Stop using the class for definition information.
       */
  
      if (clsPtr->clsDefinitionNs) {
  	Tcl_DecrRefCount(clsPtr->clsDefinitionNs);
  	clsPtr->clsDefinitionNs = NULL;
      }
      if (clsPtr->objDefinitionNs) {
  	Tcl_DecrRefCount(clsPtr->objDefinitionNs);
  	clsPtr->objDefinitionNs = NULL;
      }
  
      /*
       * Squelch method implementation chain caches.
       */
  
      if (clsPtr->constructorChainPtr) {
  	TclOODeleteChain(clsPtr->constructorChainPtr);
  	clsPtr->constructorChainPtr = NULL;
      }
      if (clsPtr->destructorChainPtr) {
  	TclOODeleteChain(clsPtr->destructorChainPtr);
  	clsPtr->destructorChainPtr = NULL;
      }
      if (clsPtr->classChainCache) {
  	CallChain *callPtr;
  
  	FOREACH_HASH_VALUE(callPtr, clsPtr->classChainCache) {
  	    TclOODeleteChain(callPtr);
  	}
  	Tcl_DeleteHashTable(clsPtr->classChainCache);
  	Tcl_Free(clsPtr->classChainCache);
  	clsPtr->classChainCache = NULL;
      }
  
      /*
       * Squelch our filter list.
       */
  
      if (clsPtr->filters.num) {
  	Tcl_Obj *filterObj;
  
  	FOREACH(filterObj, clsPtr->filters) {
  	    TclDecrRefCount(filterObj);
  	}
  	Tcl_Free(clsPtr->filters.list);
  	clsPtr->filters.list = NULL;
  	clsPtr->filters.num = 0;
      }
  
      /*
       * Squelch our metadata.
       */
  
      if (clsPtr->metadataPtr != NULL) {
  	Tcl_ObjectMetadataType *metadataTypePtr;
  	ClientData value;
  
  	FOREACH_HASH(metadataTypePtr, value, clsPtr->metadataPtr) {
  	    metadataTypePtr->deleteProc(value);
  	}
  	Tcl_DeleteHashTable(clsPtr->metadataPtr);
  	Tcl_Free(clsPtr->metadataPtr);
  	clsPtr->metadataPtr = NULL;
      }
  
      if (clsPtr->mixins.num) {
  	FOREACH(tmpClsPtr, clsPtr->mixins) {
  	    TclOORemoveFromMixinSubs(clsPtr, tmpClsPtr);
  	    TclOODecrRefCount(tmpClsPtr->thisPtr);
  	}
  	Tcl_Free(clsPtr->mixins.list);
  	clsPtr->mixins.list = NULL;
  	clsPtr->mixins.num = 0;
      }
  
      if (clsPtr->superclasses.num > 0) {
  	FOREACH(tmpClsPtr, clsPtr->superclasses) {
  	    TclOORemoveFromSubclasses(clsPtr, tmpClsPtr);
  	    TclOODecrRefCount(tmpClsPtr->thisPtr);
  	}
  	Tcl_Free(clsPtr->superclasses.list);
  	clsPtr->superclasses.num = 0;
  	clsPtr->superclasses.list = NULL;
      }
  
      FOREACH_HASH_VALUE(mPtr, &clsPtr->classMethods) {
  	TclOODelMethodRef(mPtr);
      }
      Tcl_DeleteHashTable(&clsPtr->classMethods);
      TclOODelMethodRef(clsPtr->constructorPtr);
      TclOODelMethodRef(clsPtr->destructorPtr);
  
      FOREACH(variableObj, clsPtr->variables) {
  	TclDecrRefCount(variableObj);
      }
      if (i) {
  	Tcl_Free(clsPtr->variables.list);
      }
  
      FOREACH_STRUCT(privateVariable, clsPtr->privateVariables) {
  	TclDecrRefCount(privateVariable->variableObj);
  	TclDecrRefCount(privateVariable->fullNameObj);
      }
      if (i) {
  	Tcl_Free(clsPtr->privateVariables.list);
      }
  
      if (IsRootClass(oPtr) && !Destructing(fPtr->objectCls->thisPtr)) {
  	Tcl_DeleteCommandFromToken(interp, fPtr->objectCls->thisPtr->command);
      }
  }
  
  /*
   * ----------------------------------------------------------------------
   *
   * ObjectNamespaceDeleted --
   *
   *	Callback when the object's namespace is deleted. Used to clean up the
   *	data structures associated with the object. The complicated bit is
   *	that this can sometimes happen before the object's command is deleted
   *	(interpreter teardown is complex!)
   *
   * ----------------------------------------------------------------------
   */
  
  static void
  ObjectNamespaceDeleted(
      ClientData clientData)	/* Pointer to the class whose namespace is
  				 * being deleted. */
  {
      Object *oPtr = (Object *)clientData;
      Foundation *fPtr = oPtr->fPtr;
      FOREACH_HASH_DECLS;
      Class *mixinPtr;
      Method *mPtr;
      Tcl_Obj *filterObj, *variableObj;
      PrivateVariableMapping *privateVariable;
      Tcl_Interp *interp = oPtr->fPtr->interp;
      int i;
  
      if (Destructing(oPtr)) {
  	/*
  	 * TODO:  Can ObjectNamespaceDeleted ever be called twice?  If not,
  	 * this guard could be removed.
  	 */
  
  	return;
      }
  
      /*
       * One rule for the teardown routines is that if an object is in the
       * process of being deleted, nothing else may modify its bookeeping
       * records.  This is the flag that
       */
  
      oPtr->flags |= OBJECT_DESTRUCTING;
  
      /*
       * Let the dominoes fall!
       */
  
      if (oPtr->classPtr) {
  	TclOODeleteDescendants(interp, oPtr);
      }
  
      /*
       * We do not run destructors on the core class objects when the
       * interpreter is being deleted; their incestuous nature causes problems
       * in that case when the destructor is partially deleted before the uses
       * of it have gone. [Bug 2949397]
       */
  
      if (!Tcl_InterpDeleted(interp) && !(oPtr->flags & DESTRUCTOR_CALLED)) {
  	CallContext *contextPtr =
  		TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL, NULL, NULL);
  	int result;
  	Tcl_InterpState state;
  
  	oPtr->flags |= DESTRUCTOR_CALLED;
  
  	if (contextPtr != NULL) {
  	    contextPtr->callPtr->flags |= DESTRUCTOR;
  	    contextPtr->skip = 0;
  	    state = Tcl_SaveInterpState(interp, TCL_OK);
  	    result = Tcl_NRCallObjProc(interp, TclOOInvokeContext,
  		    contextPtr, 0, NULL);
  	    if (result != TCL_OK) {
  		Tcl_BackgroundException(interp, result);
  	    }
  	    Tcl_RestoreInterpState(interp, state);
  	    TclOODeleteContext(contextPtr);
  	}
      }
  
      /*
       * Instruct everyone to no longer use any allocated fields of the object.
       * Also delete the command that refers to the object at this point (if it
       * still exists) because otherwise its pointer to the object points into
       * freed memory.
       */
  
      if (((Command *) oPtr->command)->flags && CMD_DYING) {
  	/*
  	 * Something has already started the command deletion process. We can
  	 * go ahead and clean up the the namespace,
  	 */
      } else {
  	/*
  	 * The namespace must have been deleted directly.  Delete the command
  	 * as well.
  	 */
  
  	Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->command);
      }
  
      if (oPtr->myclassCommand) {
  	Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->myclassCommand);
      }
      if (oPtr->myCommand) {
  	Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->myCommand);
      }
  
      /*
       * Splice the object out of its context. After this, we must *not* call
       * methods on the object.
       */
  
      /* TODO: Should this be protected with a !IsRoot() condition? */
      TclOORemoveFromInstances(oPtr, oPtr->selfCls);
  
      if (oPtr->mixins.num > 0) {
  	FOREACH(mixinPtr, oPtr->mixins) {
  	    TclOORemoveFromInstances(oPtr, mixinPtr);
  	    TclOODecrRefCount(mixinPtr->thisPtr);
  	}
  	if (oPtr->mixins.list != NULL) {
  	    Tcl_Free(oPtr->mixins.list);
  	}
      }
  
      FOREACH(filterObj, oPtr->filters) {
  	TclDecrRefCount(filterObj);
      }
      if (i) {
  	Tcl_Free(oPtr->filters.list);
      }
  
      if (oPtr->methodsPtr) {
  	FOREACH_HASH_VALUE(mPtr, oPtr->methodsPtr) {
  	    TclOODelMethodRef(mPtr);
  	}
  	Tcl_DeleteHashTable(oPtr->methodsPtr);
  	Tcl_Free(oPtr->methodsPtr);
      }
  
      FOREACH(variableObj, oPtr->variables) {
  	TclDecrRefCount(variableObj);
      }
      if (i) {
  	Tcl_Free(oPtr->variables.list);
      }
  
      FOREACH_STRUCT(privateVariable, oPtr->privateVariables) {
  	TclDecrRefCount(privateVariable->variableObj);
  	TclDecrRefCount(privateVariable->fullNameObj);
      }
      if (i) {
  	Tcl_Free(oPtr->privateVariables.list);
      }
  
      if (oPtr->chainCache) {
  	TclOODeleteChainCache(oPtr->chainCache);
      }
  
      SquelchCachedName(oPtr);
  
      if (oPtr->metadataPtr != NULL) {
  	Tcl_ObjectMetadataType *metadataTypePtr;
  	ClientData value;
  
  	FOREACH_HASH(metadataTypePtr, value, oPtr->metadataPtr) {
  	    metadataTypePtr->deleteProc(value);
  	}
  	Tcl_DeleteHashTable(oPtr->metadataPtr);
  	Tcl_Free(oPtr->metadataPtr);
  	oPtr->metadataPtr = NULL;
      }
  
      /*
       * Because an object can be a class that is an instance of itself, the
       * class object's class structure should only be cleaned after most of
       * the cleanup on the object is done.
       *
       * The class of objects needs some special care; if it is deleted (and
       * we're not killing the whole interpreter) we force the delete of the
       * class of classes now as well. Due to the incestuous nature of those two
       * classes, if one goes the other must too and yet the tangle can
       * sometimes not go away automatically; we force it here. [Bug 2962664]
       */
  
      if (IsRootObject(oPtr) && !Destructing(fPtr->classCls->thisPtr)
  	    && !Tcl_InterpDeleted(interp)) {
  	Tcl_DeleteCommandFromToken(interp, fPtr->classCls->thisPtr->command);
      }
  
      if (oPtr->classPtr != NULL) {
  	TclOOReleaseClassContents(interp, oPtr);
      }
  
      /*
       * Delete the object structure itself.
       */
  
      TclNsDecrRefCount((Namespace *)oPtr->namespacePtr);
      oPtr->namespacePtr = NULL;
      TclOODecrRefCount(oPtr->selfCls->thisPtr);
      oPtr->selfCls = NULL;
      TclOODecrRefCount(oPtr);
      return;
  }
  
  /*
   * ----------------------------------------------------------------------
   *
   * TclOODecrRefCount --
   *
   *	Decrement the refcount of an object and deallocate storage then object
   *	is no longer referenced.  Returns 1 if storage was deallocated, and 0
   *	otherwise.
   *
   * ----------------------------------------------------------------------
   */
  
  int
  TclOODecrRefCount(
      Object *oPtr)
  {
      if (oPtr->refCount-- <= 1) {
  
  	if (oPtr->classPtr != NULL) {
  	    Tcl_Free(oPtr->classPtr);
  	}
  	Tcl_Free(oPtr);
  	return 1;
      }
      return 0;
  }
  
  /*
   * ----------------------------------------------------------------------
   *
   * TclOOObjectDestroyed --
   *
   *	Returns TCL_OK if an object is entirely deleted, i.e. the destruction
   *	sequence has completed.
   *
   * ----------------------------------------------------------------------
   */
  int TclOOObjectDestroyed(Object *oPtr) {
      return (oPtr->namespacePtr == NULL);
  }
  
  /*
   * ----------------------------------------------------------------------
   *
   * TclOORemoveFromInstances --
   *
   *	Utility function to remove an object from the list of instances within
   *	a class.
   *
   * ----------------------------------------------------------------------
   */
  
  int
  TclOORemoveFromInstances(
      Object *oPtr,		/* The instance to remove. */
      Class *clsPtr)		/* The class (possibly) containing the
  				 * reference to the instance. */
  {
      int i, res = 0;
      Object *instPtr;
  
      FOREACH(instPtr, clsPtr->instances) {
  	if (oPtr == instPtr) {
  	    RemoveItem(Object, clsPtr->instances, i);
  	    TclOODecrRefCount(oPtr);
  	    res++;
  	    break;
  	}
      }
      return res;
  }
  
  /*
   * ----------------------------------------------------------------------
   *
   * TclOOAddToInstances --
   *
   *	Utility function to add an object to the list of instances within a
   *	class.
   *
   * ----------------------------------------------------------------------
   */
  
  void
  TclOOAddToInstances(
      Object *oPtr,		/* The instance to add. */
      Class *clsPtr)		/* The class to add the instance to. It is
  				 * assumed that the class is not already
  				 * present as an instance in the class. */
  {
      if (clsPtr->instances.num >= clsPtr->instances.size) {
  	clsPtr->instances.size += ALLOC_CHUNK;
  	if (clsPtr->instances.size == ALLOC_CHUNK) {
  	    clsPtr->instances.list = (Object **)Tcl_Alloc(sizeof(Object *) * ALLOC_CHUNK);
  	} else {
  	    clsPtr->instances.list = (Object **)Tcl_Realloc(clsPtr->instances.list,
  		    sizeof(Object *) * clsPtr->instances.size);
  	}
      }
      clsPtr->instances.list[clsPtr->instances.num++] = oPtr;
      AddRef(oPtr);
  }
  
  /*
   * ----------------------------------------------------------------------
   *
   * TclOORemoveFromMixins --
   *
   *	Utility function to remove a class from the list of mixins within an
   *	object.
   *
   * ----------------------------------------------------------------------
   */
  
  int
  TclOORemoveFromMixins(
      Class *mixinPtr,		/* The mixin to remove. */
      Object *oPtr)		/* The object (possibly) containing the
  				 * reference to the mixin. */
  {
      int i, res = 0;
      Class *mixPtr;
  
      FOREACH(mixPtr, oPtr->mixins) {
  	if (mixinPtr == mixPtr) {
  	    RemoveItem(Class, oPtr->mixins, i);
  	    TclOODecrRefCount(mixPtr->thisPtr);
  	    res++;
  	    break;
  	}
      }
      if (oPtr->mixins.num == 0) {
  	Tcl_Free(oPtr->mixins.list);
  	oPtr->mixins.list = NULL;
      }
      return res;
  }
  
  /*
   * ----------------------------------------------------------------------
   *
   * TclOORemoveFromSubclasses --
   *
   *	Utility function to remove a class from the list of subclasses within
   *	another class. Returns the number of removals performed.
   *
   * ----------------------------------------------------------------------
   */
  
  int
  TclOORemoveFromSubclasses(
      Class *subPtr,		/* The subclass to remove. */
      Class *superPtr)		/* The superclass to possibly remove the
  				 * subclass reference from. */
  {
      int i, res = 0;
      Class *subclsPtr;
  
      FOREACH(subclsPtr, superPtr->subclasses) {
  	if (subPtr == subclsPtr) {
  	    RemoveItem(Class, superPtr->subclasses, i);
  	    TclOODecrRefCount(subPtr->thisPtr);
  	    res++;
  	}
      }
      return res;
  }
  
  /*
   * ----------------------------------------------------------------------
   *
   * TclOOAddToSubclasses --
   *
   *	Utility function to add a class to the list of subclasses within
   *	another class.
   *
   * ----------------------------------------------------------------------
   */
  
  void
  TclOOAddToSubclasses(
      Class *subPtr,		/* The subclass to add. */
      Class *superPtr)		/* The superclass to add the subclass to. It
  				 * is assumed that the class is not already
  				 * present as a subclass in the superclass. */
  {
      if (Destructing(superPtr->thisPtr)) {
  	return;
      }
      if (superPtr->subclasses.num >= superPtr->subclasses.size) {
  	superPtr->subclasses.size += ALLOC_CHUNK;
  	if (superPtr->subclasses.size == ALLOC_CHUNK) {
  	    superPtr->subclasses.list = (Class **)Tcl_Alloc(sizeof(Class *) * ALLOC_CHUNK);
  	} else {
  	    superPtr->subclasses.list = (Class **)Tcl_Realloc(superPtr->subclasses.list,
  		    sizeof(Class *) * superPtr->subclasses.size);
  	}
      }
      superPtr->subclasses.list[superPtr->subclasses.num++] = subPtr;
      AddRef(subPtr->thisPtr);
  }
  
  /*
   * ----------------------------------------------------------------------
   *
   * TclOORemoveFromMixinSubs --
   *
   *	Utility function to remove a class from the list of mixinSubs within
   *	another class.
   *
   * ----------------------------------------------------------------------
   */
  
  int
  TclOORemoveFromMixinSubs(
      Class *subPtr,		/* The subclass to remove. */
      Class *superPtr)		/* The superclass to possibly remove the
  				 * subclass reference from. */
  {
      int i, res = 0;
      Class *subclsPtr;
  
      FOREACH(subclsPtr, superPtr->mixinSubs) {
  	if (subPtr == subclsPtr) {
  	    RemoveItem(Class, superPtr->mixinSubs, i);
  	    TclOODecrRefCount(subPtr->thisPtr);
  	    res++;
  	    break;
  	}
      }
      return res;
  }
  
  /*
   * ----------------------------------------------------------------------
   *
   * TclOOAddToMixinSubs --
   *
   *	Utility function to add a class to the list of mixinSubs within
   *	another class.
   *
   * ----------------------------------------------------------------------
   */
  
  void
  TclOOAddToMixinSubs(
      Class *subPtr,		/* The subclass to add. */
      Class *superPtr)		/* The superclass to add the subclass to. It
  				 * is assumed that the class is not already
  				 * present as a subclass in the superclass. */
  {
      if (Destructing(superPtr->thisPtr)) {
  	return;
      }
      if (superPtr->mixinSubs.num >= superPtr->mixinSubs.size) {
  	superPtr->mixinSubs.size += ALLOC_CHUNK;
  	if (superPtr->mixinSubs.size == ALLOC_CHUNK) {
  	    superPtr->mixinSubs.list = (Class **)Tcl_Alloc(sizeof(Class *) * ALLOC_CHUNK);
  	} else {
  	    superPtr->mixinSubs.list = (Class **)Tcl_Realloc(superPtr->mixinSubs.list,
  		    sizeof(Class *) * superPtr->mixinSubs.size);
  	}
      }
      superPtr->mixinSubs.list[superPtr->mixinSubs.num++] = subPtr;
      AddRef(subPtr->thisPtr);
  }
  
  /*
   * ----------------------------------------------------------------------
   *
   * TclOOAllocClass --
   *
   *	Allocate a basic class. Does not add class to its class's instance
   *	list.
   *
   * ----------------------------------------------------------------------
   */
  
  static inline void
  InitClassPath(
      Tcl_Interp *interp,
      Class *clsPtr)
  {
      Foundation *fPtr = GetFoundation(interp);
  
      if (fPtr->helpersNs != NULL) {
  	Tcl_Namespace *path[2];
  
  	path[0] = fPtr->helpersNs;
  	path[1] = fPtr->ooNs;
  	TclSetNsPath((Namespace *) clsPtr->thisPtr->namespacePtr, 2, path);
      } else {
  	TclSetNsPath((Namespace *) clsPtr->thisPtr->namespacePtr, 1,
  		&fPtr->ooNs);
      }
  }
  
  Class *
  TclOOAllocClass(
      Tcl_Interp *interp,		/* Interpreter within which to allocate the
  				 * class. */
      Object *useThisObj)		/* Object that is to act as the class
  				 * representation. */
  {
      Foundation *fPtr = GetFoundation(interp);
      Class *clsPtr = (Class *)Tcl_Alloc(sizeof(Class));
  
      memset(clsPtr, 0, sizeof(Class));
      clsPtr->thisPtr = useThisObj;
  
      /*
       * Configure the namespace path for the class's object.
       */
  
      InitClassPath(interp, clsPtr);
  
      /*
       * Classes are subclasses of oo::object, i.e. the objects they create are
       * objects.
       */
  
      clsPtr->superclasses.num = 1;
      clsPtr->superclasses.list = (Class **)Tcl_Alloc(sizeof(Class *));
      clsPtr->superclasses.list[0] = fPtr->objectCls;
      AddRef(fPtr->objectCls->thisPtr);
  
      /*
       * Finish connecting the class structure to the object structure.
       */
  
      clsPtr->thisPtr->classPtr = clsPtr;
  
      /*
       * That's the complicated bit. Now fill in the rest of the non-zero/NULL
       * fields.
       */
  
      Tcl_InitObjHashTable(&clsPtr->classMethods);
      return clsPtr;
  }
  
  /*
   * ----------------------------------------------------------------------
   *
   * Tcl_NewObjectInstance --
   *
   *	Allocate a new instance of an object.
   *
   * ----------------------------------------------------------------------
   */
  Tcl_Object
  Tcl_NewObjectInstance(
      Tcl_Interp *interp,		/* Interpreter context. */
      Tcl_Class cls,		/* Class to create an instance of. */
      const char *nameStr,	/* Name of object to create, or NULL to ask
  				 * the code to pick its own unique name. */
      const char *nsNameStr,	/* Name of namespace to create inside object,
  				 * or NULL to ask the code to pick its own
  				 * unique name. */
      int objc,			/* Number of arguments. Negative value means
  				 * do not call constructor. */
      Tcl_Obj *const *objv,	/* Argument list. */
      int skip)			/* Number of arguments to _not_ pass to the
  				 * constructor. */
  {
      Class *classPtr = (Class *) cls;
      Object *oPtr;
      ClientData clientData[4];
  
      oPtr = TclNewObjectInstanceCommon(interp, classPtr, nameStr, nsNameStr);
      if (oPtr == NULL) {
  	return NULL;
      }
  
      /*
       * Run constructors, except when objc < 0, which is a special flag case
       * used for object cloning only.
       */
  
      if (objc >= 0) {
  	CallContext *contextPtr =
  		TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL, NULL, NULL);
  
  	if (contextPtr != NULL) {
  	    int isRoot, result;
  	    Tcl_InterpState state;
  
  	    state = Tcl_SaveInterpState(interp, TCL_OK);
  	    contextPtr->callPtr->flags |= CONSTRUCTOR;
  	    contextPtr->skip = skip;
  
  	    /*
  	     * Adjust the ensemble tracking record if necessary. [Bug 3514761]
  	     */
  
  	    isRoot = TclInitRewriteEnsemble(interp, skip, skip, objv);
  	    result = Tcl_NRCallObjProc(interp, TclOOInvokeContext, contextPtr,
  		    objc, objv);
  
  	    if (isRoot) {
  		TclResetRewriteEnsemble(interp, 1);
  	    }
  
  	    clientData[0] = contextPtr;
  	    clientData[1] = oPtr;
  	    clientData[2] = state;
  	    clientData[3] = &oPtr;
  
  	    result = FinalizeAlloc(clientData, interp, result);
  	    if (result != TCL_OK) {
  		return NULL;
  	    }
  	}
      }
  
      return (Tcl_Object) oPtr;
  }
  
  int
  TclNRNewObjectInstance(
      Tcl_Interp *interp,		/* Interpreter context. */
      Tcl_Class cls,		/* Class to create an instance of. */
      const char *nameStr,	/* Name of object to create, or NULL to ask
  				 * the code to pick its own unique name. */
      const char *nsNameStr,	/* Name of namespace to create inside object,
  				 * or NULL to ask the code to pick its own
  				 * unique name. */
      int objc,			/* Number of arguments. Negative value means
  				 * do not call constructor. */
      Tcl_Obj *const *objv,	/* Argument list. */
      int skip,			/* Number of arguments to _not_ pass to the
  				 * constructor. */
      Tcl_Object *objectPtr)	/* Place to write the object reference upon
  				 * successful allocation. */
  {
      Class *classPtr = (Class *) cls;
      CallContext *contextPtr;
      Tcl_InterpState state;
      Object *oPtr;
  
      oPtr = TclNewObjectInstanceCommon(interp, classPtr, nameStr, nsNameStr);
      if (oPtr == NULL) {
  	return TCL_ERROR;
      }
  
      /*
       * Run constructors, except when objc < 0 (a special flag case used for
       * object cloning only). If there aren't any constructors, we do nothing.
       */
  
      if (objc < 0) {
  	*objectPtr = (Tcl_Object) oPtr;
  	return TCL_OK;
      }
      contextPtr = TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL, NULL, NULL);
      if (contextPtr == NULL) {
  	*objectPtr = (Tcl_Object) oPtr;
  	return TCL_OK;
      }
  
      state = Tcl_SaveInterpState(interp, TCL_OK);
      contextPtr->callPtr->flags |= CONSTRUCTOR;
      contextPtr->skip = skip;
  
      /*
       * Adjust the ensemble tracking record if necessary. [Bug 3514761]
       */
  
      if (TclInitRewriteEnsemble(interp, skip, skip, objv)) {
  	TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL);
      }
  
      /*
       * Fire off the constructors non-recursively.
       */
  
      TclNRAddCallback(interp, FinalizeAlloc, contextPtr, oPtr, state,
  	    objectPtr);
      TclPushTailcallPoint(interp);
      return TclOOInvokeContext(contextPtr, interp, objc, objv);
  }
  
  Object *
  TclNewObjectInstanceCommon(
      Tcl_Interp *interp,
      Class *classPtr,
      const char *nameStr,
      const char *nsNameStr)
  {
      Tcl_HashEntry *hPtr;
      Foundation *fPtr = GetFoundation(interp);
      Object *oPtr;
      const char *simpleName = NULL;
      Namespace *nsPtr = NULL, *dummy;
      Namespace *inNsPtr = (Namespace *) TclGetCurrentNamespace(interp);
  
      if (nameStr) {
  	TclGetNamespaceForQualName(interp, nameStr, inNsPtr,
  		TCL_CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy, &dummy, &simpleName);
  
  	/*
  	 * Disallow creation of an object over an existing command.
  	 */
  
  	hPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simpleName);
  	if (hPtr) {
  	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
  		    "can't create object \"%s\": command already exists with"
  		    " that name", nameStr));
  	    Tcl_SetErrorCode(interp, "TCL", "OO", "OVERWRITE_OBJECT", NULL);
  	    return NULL;
  	}
      }
  
      /*
       * Create the object.
       */
  
      oPtr = AllocObject(interp, simpleName, nsPtr, nsNameStr);
      oPtr->selfCls = classPtr;
      AddRef(classPtr->thisPtr);
      TclOOAddToInstances(oPtr, classPtr);
  
      /*
       * Check to see if we're really creating a class. If so, allocate the
       * class structure as well.
       */
  
      if (TclOOIsReachable(fPtr->classCls, classPtr)) {
  	/*
  	 * Is a class, so attach a class structure. Note that the
  	 * TclOOAllocClass function splices the structure into the object, so
  	 * we don't have to. Once that's done, we need to repatch the object
  	 * to have the right class since TclOOAllocClass interferes with that.
  	 */
  
  	TclOOAllocClass(interp, oPtr);
  	TclOOAddToSubclasses(oPtr->classPtr, fPtr->objectCls);
      } else {
  	oPtr->classPtr = NULL;
      }
      return oPtr;
  }
  
  static int
  FinalizeAlloc(
      ClientData data[],
      Tcl_Interp *interp,
      int result)
  {
      CallContext *contextPtr = (CallContext *)data[0];
      Object *oPtr = (Object *)data[1];
      Tcl_InterpState state = (Tcl_InterpState)data[2];
      Tcl_Object *objectPtr = (Tcl_Object *)data[3];
  
      /*
       * Ensure an error if the object was deleted in the constructor. Don't
       * want to lose errors by accident. [Bug 2903011]
       */
  
      if (result != TCL_ERROR && Destructing(oPtr)) {
  	Tcl_SetObjResult(interp, Tcl_NewStringObj(
  		"object deleted in constructor", -1));
  	Tcl_SetErrorCode(interp, "TCL", "OO", "STILLBORN", NULL);
  	result = TCL_ERROR;
      }
      if (result != TCL_OK) {
  	Tcl_DiscardInterpState(state);
  
  	/*
  	 * Take care to not delete a deleted object; that would be bad. [Bug
  	 * 2903011] Also take care to make sure that we have the name of the
  	 * command before we delete it. [Bug 9dd1bd7a74]
  	 */
  
  	if (!Destructing(oPtr)) {
  	    (void) TclOOObjectName(interp, oPtr);
  	    Tcl_DeleteCommandFromToken(interp, oPtr->command);
  	}
  
  	/*
  	 * This decrements the refcount of oPtr.
  	 */
  
  	TclOODeleteContext(contextPtr);
  	return TCL_ERROR;
      }
      Tcl_RestoreInterpState(interp, state);
      *objectPtr = (Tcl_Object) oPtr;
  
      /*
       * This decrements the refcount of oPtr.
       */
  
      TclOODeleteContext(contextPtr);
      return TCL_OK;
  }
  
  /*
   * ----------------------------------------------------------------------
   *
   * Tcl_CopyObjectInstance --
   *
   *	Creates a copy of an object. Does not copy the backing namespace,
   *	since the correct way to do that (e.g., shallow/deep) depends on the
   *	object/class's own policies.
   *
   * ----------------------------------------------------------------------
   */
  
  Tcl_Object
  Tcl_CopyObjectInstance(
      Tcl_Interp *interp,
      Tcl_Object sourceObject,
      const char *targetName,
      const char *targetNamespaceName)
  {
      Object *oPtr = (Object *) sourceObject, *o2Ptr;
      FOREACH_HASH_DECLS;
      Method *mPtr;
      Class *mixinPtr;
      CallContext *contextPtr;
      Tcl_Obj *keyPtr, *filterObj, *variableObj, *args[3];
      PrivateVariableMapping *privateVariable;
      int i, result;
  
      /*
       * Sanity check.
       */
  
      if (IsRootClass(oPtr)) {
  	Tcl_SetObjResult(interp, Tcl_NewStringObj(
  		"may not clone the class of classes", -1));
  	Tcl_SetErrorCode(interp, "TCL", "OO", "CLONING_CLASS", NULL);
  	return NULL;
      }
  
      /*
       * Build the instance. Note that this does not run any constructors.
       */
  
      o2Ptr = (Object *) Tcl_NewObjectInstance(interp,
  	    (Tcl_Class) oPtr->selfCls, targetName, targetNamespaceName, -1,
  	    NULL, -1);
      if (o2Ptr == NULL) {
  	return NULL;
      }
  
      /*
       * Copy the object-local methods to the new object.
       */
  
      if (oPtr->methodsPtr) {
  	FOREACH_HASH(keyPtr, mPtr, oPtr->methodsPtr) {
  	    if (CloneObjectMethod(interp, o2Ptr, mPtr, keyPtr) != TCL_OK) {
  		Tcl_DeleteCommandFromToken(interp, o2Ptr->command);
  		return NULL;
  	    }
  	}
      }
  
      /*
       * Copy the object's mixin references to the new object.
       */
  
      if (o2Ptr->mixins.num != 0) {
  	FOREACH(mixinPtr, o2Ptr->mixins) {
  	    if (mixinPtr && mixinPtr != o2Ptr->selfCls) {
  		TclOORemoveFromInstances(o2Ptr, mixinPtr);
  	    }
  	    TclOODecrRefCount(mixinPtr->thisPtr);
  	}
  	Tcl_Free(o2Ptr->mixins.list);
      }
      DUPLICATE(o2Ptr->mixins, oPtr->mixins, Class *);
      FOREACH(mixinPtr, o2Ptr->mixins) {
  	if (mixinPtr && mixinPtr != o2Ptr->selfCls) {
  	    TclOOAddToInstances(o2Ptr, mixinPtr);
  	}
  
  	/*
  	 * For the reference just created in DUPLICATE.
  	 */
  
  	AddRef(mixinPtr->thisPtr);
      }
  
      /*
       * Copy the object's filter list to the new object.
       */
  
      DUPLICATE(o2Ptr->filters, oPtr->filters, Tcl_Obj *);
      FOREACH(filterObj, o2Ptr->filters) {
  	Tcl_IncrRefCount(filterObj);
      }
  
      /*
       * Copy the object's variable resolution lists to the new object.
       */
  
      DUPLICATE(o2Ptr->variables, oPtr->variables, Tcl_Obj *);
      FOREACH(variableObj, o2Ptr->variables) {
  	Tcl_IncrRefCount(variableObj);
      }
  
      DUPLICATE(o2Ptr->privateVariables, oPtr->privateVariables,
  	    PrivateVariableMapping);
      FOREACH_STRUCT(privateVariable, o2Ptr->privateVariables) {
  	Tcl_IncrRefCount(privateVariable->variableObj);
  	Tcl_IncrRefCount(privateVariable->fullNameObj);
      }
  
      /*
       * Copy the object's flags to the new object, clearing those that must be
       * kept object-local. The duplicate is never deleted at this point, nor is
       * it the root of the object system or in the midst of processing a filter
       * call.
       */
  
      o2Ptr->flags = oPtr->flags & ~(
  	    OBJECT_DESTRUCTING | ROOT_OBJECT | ROOT_CLASS | FILTER_HANDLING);
  
      /*
       * Copy the object's metadata.
       */
  
      if (oPtr->metadataPtr != NULL) {
  	Tcl_ObjectMetadataType *metadataTypePtr;
  	ClientData value, duplicate;
  
  	FOREACH_HASH(metadataTypePtr, value, oPtr->metadataPtr) {
  	    if (metadataTypePtr->cloneProc == NULL) {
  		duplicate = value;
  	    } else {
  		if (metadataTypePtr->cloneProc(interp, value,
  			&duplicate) != TCL_OK) {
  		    Tcl_DeleteCommandFromToken(interp, o2Ptr->command);
  		    return NULL;
  		}
  	    }
  	    if (duplicate != NULL) {
  		Tcl_ObjectSetMetadata((Tcl_Object) o2Ptr, metadataTypePtr,
  			duplicate);
  	    }
  	}
      }
  
      /*
       * Copy the class, if present. Note that if there is a class present in
       * the source object, there must also be one in the copy.
       */
  
      if (oPtr->classPtr != NULL) {
  	Class *clsPtr = oPtr->classPtr;
  	Class *cls2Ptr = o2Ptr->classPtr;
  	Class *superPtr;
  
  	/*
  	 * Copy the class flags across.
  	 */
  
  	cls2Ptr->flags = clsPtr->flags;
  
  	/*
  	 * Ensure that the new class's superclass structure is the same as the
  	 * old class's.
  	 */
  
  	FOREACH(superPtr, cls2Ptr->superclasses) {
  	    TclOORemoveFromSubclasses(cls2Ptr, superPtr);
  	    TclOODecrRefCount(superPtr->thisPtr);
  	}
  	if (cls2Ptr->superclasses.num) {
  	    cls2Ptr->superclasses.list = (Class **)Tcl_Realloc(cls2Ptr->superclasses.list,
  		    sizeof(Class *) * clsPtr->superclasses.num);
  	} else {
  	    cls2Ptr->superclasses.list =
  		    (Class **)Tcl_Alloc(sizeof(Class *) * clsPtr->superclasses.num);
  	}
  	memcpy(cls2Ptr->superclasses.list, clsPtr->superclasses.list,
  		sizeof(Class *) * clsPtr->superclasses.num);
  	cls2Ptr->superclasses.num = clsPtr->superclasses.num;
  	FOREACH(superPtr, cls2Ptr->superclasses) {
  	    TclOOAddToSubclasses(cls2Ptr, superPtr);
  
  	    /*
  	     * For the new item in cls2Ptr->superclasses that memcpy just
  	     * created.
  	     */
  
  	    AddRef(superPtr->thisPtr);
  	}
  
  	/*
  	 * Duplicate the source class's filters.
  	 */
  
  	DUPLICATE(cls2Ptr->filters, clsPtr->filters, Tcl_Obj *);
  	FOREACH(filterObj, cls2Ptr->filters) {
  	    Tcl_IncrRefCount(filterObj);
  	}
  
  	/*
  	 * Copy the source class's variable resolution lists.
  	 */
  
  	DUPLICATE(cls2Ptr->variables, clsPtr->variables, Tcl_Obj *);
  	FOREACH(variableObj, cls2Ptr->variables) {
  	    Tcl_IncrRefCount(variableObj);
  	}
  
  	DUPLICATE(cls2Ptr->privateVariables, clsPtr->privateVariables,
  		PrivateVariableMapping);
  	FOREACH_STRUCT(privateVariable, cls2Ptr->privateVariables) {
  	    Tcl_IncrRefCount(privateVariable->variableObj);
  	    Tcl_IncrRefCount(privateVariable->fullNameObj);
  	}
  
  	/*
  	 * Duplicate the source class's mixins (which cannot be circular
  	 * references to the duplicate).
  	 */
  
  	if (cls2Ptr->mixins.num != 0) {
  	    FOREACH(mixinPtr, cls2Ptr->mixins) {
  		TclOORemoveFromMixinSubs(cls2Ptr, mixinPtr);
  		TclOODecrRefCount(mixinPtr->thisPtr);
  	    }
  	    Tcl_Free(clsPtr->mixins.list);
  	}
  	DUPLICATE(cls2Ptr->mixins, clsPtr->mixins, Class *);
  	FOREACH(mixinPtr, cls2Ptr->mixins) {
  	    TclOOAddToMixinSubs(cls2Ptr, mixinPtr);
  
  	    /*
  	     * For the copy just created in DUPLICATE.
  	     */
  
  	    AddRef(mixinPtr->thisPtr);
  	}
  
  	/*
  	 * Duplicate the source class's methods, constructor and destructor.
  	 */
  
  	FOREACH_HASH(keyPtr, mPtr, &clsPtr->classMethods) {
  	    if (CloneClassMethod(interp, cls2Ptr, mPtr, keyPtr,
  		    NULL) != TCL_OK) {
  		Tcl_DeleteCommandFromToken(interp, o2Ptr->command);
  		return NULL;
  	    }
  	}
  	if (clsPtr->constructorPtr) {
  	    if (CloneClassMethod(interp, cls2Ptr, clsPtr->constructorPtr,
  		    NULL, &cls2Ptr->constructorPtr) != TCL_OK) {
  		Tcl_DeleteCommandFromToken(interp, o2Ptr->command);
  		return NULL;
  	    }
  	}
  	if (clsPtr->destructorPtr) {
  	    if (CloneClassMethod(interp, cls2Ptr, clsPtr->destructorPtr, NULL,
  		    &cls2Ptr->destructorPtr) != TCL_OK) {
  		Tcl_DeleteCommandFromToken(interp, o2Ptr->command);
  		return NULL;
  	    }
  	}
  
  	/*
  	 * Duplicate the class's metadata.
  	 */
  
  	if (clsPtr->metadataPtr != NULL) {
  	    Tcl_ObjectMetadataType *metadataTypePtr;
  	    ClientData value, duplicate;
  
  	    FOREACH_HASH(metadataTypePtr, value, clsPtr->metadataPtr) {
  		if (metadataTypePtr->cloneProc == NULL) {
  		    duplicate = value;
  		} else {
  		    if (metadataTypePtr->cloneProc(interp, value,
  			    &duplicate) != TCL_OK) {
  			Tcl_DeleteCommandFromToken(interp, o2Ptr->command);
  			return NULL;
  		    }
  		}
  		if (duplicate != NULL) {
  		    Tcl_ClassSetMetadata((Tcl_Class) cls2Ptr, metadataTypePtr,
  			    duplicate);
  		}
  	    }
  	}
      }
  
      TclResetRewriteEnsemble(interp, 1);
      contextPtr = TclOOGetCallContext(o2Ptr, oPtr->fPtr->clonedName, 0, NULL,
  	    NULL, NULL);
      if (contextPtr) {
  	args[0] = TclOOObjectName(interp, o2Ptr);
  	args[1] = oPtr->fPtr->clonedName;
  	args[2] = TclOOObjectName(interp, oPtr);
  	Tcl_IncrRefCount(args[0]);
  	Tcl_IncrRefCount(args[1]);
  	Tcl_IncrRefCount(args[2]);
  	result = Tcl_NRCallObjProc(interp, TclOOInvokeContext, contextPtr, 3,
  		args);
  	TclDecrRefCount(args[0]);
  	TclDecrRefCount(args[1]);
  	TclDecrRefCount(args[2]);
  	TclOODeleteContext(contextPtr);
  	if (result == TCL_ERROR) {
  	    Tcl_AddErrorInfo(interp,
  		    "\n    (while performing post-copy callback)");
  	}
  	if (result != TCL_OK) {
  	    Tcl_DeleteCommandFromToken(interp, o2Ptr->command);
  	    return NULL;
  	}
      }
  
      return (Tcl_Object) o2Ptr;
  }
  
  /*
   * ----------------------------------------------------------------------
   *
   * CloneObjectMethod, CloneClassMethod --
   *
   *	Helper functions used for cloning methods. They work identically to
   *	each other, except for the difference between them in how they
   *	register the cloned method on a successful clone.
   *
   * ----------------------------------------------------------------------
   */
  
  static int
  CloneObjectMethod(
      Tcl_Interp *interp,
      Object *oPtr,
      Method *mPtr,
      Tcl_Obj *namePtr)
  {
      if (mPtr->typePtr == NULL) {
  	Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr, namePtr,
  		mPtr->flags & PUBLIC_METHOD, NULL, NULL);
      } else if (mPtr->typePtr->cloneProc) {
  	ClientData newClientData;
  
  	if (mPtr->typePtr->cloneProc(interp, mPtr->clientData,
  		&newClientData) != TCL_OK) {
  	    return TCL_ERROR;
  	}
  	Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr, namePtr,
  		mPtr->flags & PUBLIC_METHOD, mPtr->typePtr, newClientData);
      } else {
  	Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr, namePtr,
  		mPtr->flags & PUBLIC_METHOD, mPtr->typePtr, mPtr->clientData);
      }
      return TCL_OK;
  }
  
  static int
  CloneClassMethod(
      Tcl_Interp *interp,
      Class *clsPtr,
      Method *mPtr,
      Tcl_Obj *namePtr,
      Method **m2PtrPtr)
  {
      Method *m2Ptr;
  
      if (mPtr->typePtr == NULL) {
  	m2Ptr = (Method *) Tcl_NewMethod(interp, (Tcl_Class) clsPtr,
  		namePtr, mPtr->flags & PUBLIC_METHOD, NULL, NULL);
      } else if (mPtr->typePtr->cloneProc) {
  	ClientData newClientData;
  
  	if (mPtr->typePtr->cloneProc(interp, mPtr->clientData,
  		&newClientData) != TCL_OK) {
  	    return TCL_ERROR;
  	}
  	m2Ptr = (Method *) Tcl_NewMethod(interp, (Tcl_Class) clsPtr,
  		namePtr, mPtr->flags & PUBLIC_METHOD, mPtr->typePtr,
  		newClientData);
      } else {
  	m2Ptr = (Method *) Tcl_NewMethod(interp, (Tcl_Class) clsPtr,
  		namePtr, mPtr->flags & PUBLIC_METHOD, mPtr->typePtr,
  		mPtr->clientData);
      }
      if (m2PtrPtr != NULL) {
  	*m2PtrPtr = m2Ptr;
      }
      return TCL_OK;
  }
  
  /*
   * ----------------------------------------------------------------------
   *
   * Tcl_ClassGetMetadata, Tcl_ClassSetMetadata, Tcl_ObjectGetMetadata,
   * Tcl_ObjectSetMetadata --
   *
   *	Metadata management API. The metadata system allows code in extensions
   *	to attach arbitrary non-NULL pointers to objects and classes without
   *	the different things that might be interested being able to interfere
   *	with each other. Apart from non-NULL-ness, these routines attach no
   *	interpretation to the meaning of the metadata pointers.
   *
   *	The Tcl_*GetMetadata routines get the metadata pointer attached that
   *	has been related with a particular type, or NULL if no metadata
   *	associated with the given type has been attached.
   *
   *	The Tcl_*SetMetadata routines set or delete the metadata pointer that
   *	is related to a particular type. The value associated with the type is
   *	deleted (if present; no-op otherwise) if the value is NULL, and
   *	attached (replacing the previous value, which is deleted if present)
   *	otherwise. This means it is impossible to attach a NULL value for any
   *	metadata type.
   *
   * ----------------------------------------------------------------------
   */
  
  ClientData
  Tcl_ClassGetMetadata(
      Tcl_Class clazz,
      const Tcl_ObjectMetadataType *typePtr)
  {
      Class *clsPtr = (Class *) clazz;
      Tcl_HashEntry *hPtr;
  
      /*
       * If there's no metadata store attached, the type in question has
       * definitely not been attached either!
       */
  
      if (clsPtr->metadataPtr == NULL) {
  	return NULL;
      }
  
      /*
       * There is a metadata store, so look in it for the given type.
       */
  
      hPtr = Tcl_FindHashEntry(clsPtr->metadataPtr, (char *) typePtr);
  
      /*
       * Return the metadata value if we found it, otherwise NULL.
       */
  
      if (hPtr == NULL) {
  	return NULL;
      }
      return Tcl_GetHashValue(hPtr);
  }
  
  void
  Tcl_ClassSetMetadata(
      Tcl_Class clazz,
      const Tcl_ObjectMetadataType *typePtr,
      ClientData metadata)
  {
      Class *clsPtr = (Class *) clazz;
      Tcl_HashEntry *hPtr;
      int isNew;
  
      /*
       * Attach the metadata store if not done already.
       */
  
      if (clsPtr->metadataPtr == NULL) {
  	if (metadata == NULL) {
  	    return;
  	}
  	clsPtr->metadataPtr = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable));
  	Tcl_InitHashTable(clsPtr->metadataPtr, TCL_ONE_WORD_KEYS);
      }
  
      /*
       * If the metadata is NULL, we're deleting the metadata for the type.
       */
  
      if (metadata == NULL) {
  	hPtr = Tcl_FindHashEntry(clsPtr->metadataPtr, (char *) typePtr);
  	if (hPtr != NULL) {
  	    typePtr->deleteProc(Tcl_GetHashValue(hPtr));
  	    Tcl_DeleteHashEntry(hPtr);
  	}
  	return;
      }
  
      /*
       * Otherwise we're attaching the metadata. Note that if there was already
       * some metadata attached of this type, we delete that first.
       */
  
      hPtr = Tcl_CreateHashEntry(clsPtr->metadataPtr, (char *) typePtr, &isNew);
      if (!isNew) {
  	typePtr->deleteProc(Tcl_GetHashValue(hPtr));
      }
      Tcl_SetHashValue(hPtr, metadata);
  }
  
  ClientData
  Tcl_ObjectGetMetadata(
      Tcl_Object object,
      const Tcl_ObjectMetadataType *typePtr)
  {
      Object *oPtr = (Object *) object;
      Tcl_HashEntry *hPtr;
  
      /*
       * If there's no metadata store attached, the type in question has
       * definitely not been attached either!
       */
  
      if (oPtr->metadataPtr == NULL) {
  	return NULL;
      }
  
      /*
       * There is a metadata store, so look in it for the given type.
       */
  
      hPtr = Tcl_FindHashEntry(oPtr->metadataPtr, (char *) typePtr);
  
      /*
       * Return the metadata value if we found it, otherwise NULL.
       */
  
      if (hPtr == NULL) {
  	return NULL;
      }
      return Tcl_GetHashValue(hPtr);
  }
  
  void
  Tcl_ObjectSetMetadata(
      Tcl_Object object,
      const Tcl_ObjectMetadataType *typePtr,
      ClientData metadata)
  {
      Object *oPtr = (Object *) object;
      Tcl_HashEntry *hPtr;
      int isNew;
  
      /*
       * Attach the metadata store if not done already.
       */
  
      if (oPtr->metadataPtr == NULL) {
  	if (metadata == NULL) {
  	    return;
  	}
  	oPtr->metadataPtr = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable));
  	Tcl_InitHashTable(oPtr->metadataPtr, TCL_ONE_WORD_KEYS);
      }
  
      /*
       * If the metadata is NULL, we're deleting the metadata for the type.
       */
  
      if (metadata == NULL) {
  	hPtr = Tcl_FindHashEntry(oPtr->metadataPtr, (char *) typePtr);
  	if (hPtr != NULL) {
  	    typePtr->deleteProc(Tcl_GetHashValue(hPtr));
  	    Tcl_DeleteHashEntry(hPtr);
  	}
  	return;
      }
  
      /*
       * Otherwise we're attaching the metadata. Note that if there was already
       * some metadata attached of this type, we delete that first.
       */
  
      hPtr = Tcl_CreateHashEntry(oPtr->metadataPtr, (char *) typePtr, &isNew);
      if (!isNew) {
  	typePtr->deleteProc(Tcl_GetHashValue(hPtr));
      }
      Tcl_SetHashValue(hPtr, metadata);
  }
  
  /*
   * ----------------------------------------------------------------------
   *
   * TclOOPublicObjectCmd, TclOOPrivateObjectCmd, TclOOInvokeObject --
   *
   *	Main entry point for object invocations. The Public* and Private*
   *	wrapper functions (implementations of both object instance commands
   *	and [my]) are just thin wrappers round the main TclOOObjectCmdCore
   *	function. Note that the core is function is NRE-aware.
   *
   * ----------------------------------------------------------------------
   */
  
  int
  TclOOPublicObjectCmd(
      ClientData clientData,
      Tcl_Interp *interp,
      int objc,
      Tcl_Obj *const *objv)
  {
      return Tcl_NRCallObjProc(interp, PublicNRObjectCmd, clientData,objc,objv);
  }
  
  static int
  PublicNRObjectCmd(
      ClientData clientData,
      Tcl_Interp *interp,
      int objc,
      Tcl_Obj *const *objv)
  {
      return TclOOObjectCmdCore((Object *)clientData, interp, objc, objv, PUBLIC_METHOD,
  	    NULL);
  }
  
  int
  TclOOPrivateObjectCmd(
      ClientData clientData,
      Tcl_Interp *interp,
      int objc,
      Tcl_Obj *const *objv)
  {
      return Tcl_NRCallObjProc(interp, PrivateNRObjectCmd,clientData,objc,objv);
  }
  
  static int
  PrivateNRObjectCmd(
      ClientData clientData,
      Tcl_Interp *interp,
      int objc,
      Tcl_Obj *const *objv)
  {
      return TclOOObjectCmdCore((Object *)clientData, interp, objc, objv, 0, NULL);
  }
  
  int
  TclOOInvokeObject(
      Tcl_Interp *interp,		/* Interpreter for commands, variables,
  				 * results, error reporting, etc. */
      Tcl_Object object,		/* The object to invoke. */
      Tcl_Class startCls,		/* Where in the class chain to start the
  				 * invoke from, or NULL to traverse the whole
  				 * chain including filters. */
      int publicPrivate,		/* Whether this is an invoke from a public
  				 * context (PUBLIC_METHOD), a private context
  				 * (PRIVATE_METHOD), or a *really* private
  				 * context (any other value; conventionally
  				 * 0). */
      int objc,			/* Number of arguments. */
      Tcl_Obj *const *objv)	/* Array of argument objects. It is assumed
  				 * that the name of the method to invoke will
  				 * be at index 1. */
  {
      switch (publicPrivate) {
      case PUBLIC_METHOD:
  	return TclOOObjectCmdCore((Object *) object, interp, objc, objv,
  		PUBLIC_METHOD, (Class *) startCls);
      case PRIVATE_METHOD:
  	return TclOOObjectCmdCore((Object *) object, interp, objc, objv,
  		PRIVATE_METHOD, (Class *) startCls);
      default:
  	return TclOOObjectCmdCore((Object *) object, interp, objc, objv, 0,
  		(Class *) startCls);
      }
  }
  
  /*
   * ----------------------------------------------------------------------
   *
   * TclOOMyClassObjCmd, MyClassNRObjCmd --
   *
   *	Special trap door to allow an object to delegate simply to its class.
   *
   * ----------------------------------------------------------------------
   */
  
  int
  TclOOMyClassObjCmd(
      ClientData clientData,
      Tcl_Interp *interp,
      int objc,
      Tcl_Obj *const *objv)
  {
      return Tcl_NRCallObjProc(interp, MyClassNRObjCmd, clientData, objc, objv);
  }
  
  static int
  MyClassNRObjCmd(
      ClientData clientData,
      Tcl_Interp *interp,
      int objc,
      Tcl_Obj *const *objv)
  {
      Object *oPtr = (Object *)clientData;
  
      if (objc < 2) {
  	Tcl_WrongNumArgs(interp, 1, objv, "methodName ?arg ...?");
  	return TCL_ERROR;
      }
      return TclOOObjectCmdCore(oPtr->selfCls->thisPtr, interp, objc, objv, 0,
  	    NULL);
  }
  
  /*
   * ----------------------------------------------------------------------
   *
   * TclOOObjectCmdCore, FinalizeObjectCall --
   *
   *	Main function for object invocations. Does call chain creation,
   *	management and invocation. The function FinalizeObjectCall exists to
   *	clean up after the non-recursive processing of TclOOObjectCmdCore.
   *
   * ----------------------------------------------------------------------
   */
  
  int
  TclOOObjectCmdCore(
      Object *oPtr,		/* The object being invoked. */
      Tcl_Interp *interp,		/* The interpreter containing the object. */
      int objc,			/* How many arguments are being passed in. */
      Tcl_Obj *const *objv,	/* The array of arguments. */
      int flags,			/* Whether this is an invocation through the
  				 * public or the private command interface. */
      Class *startCls)		/* Where to start in the call chain, or NULL
  				 * if we are to start at the front with
  				 * filters and the object's methods (which is
  				 * the normal case). */
  {
      CallContext *contextPtr;
      Tcl_Obj *methodNamePtr;
      CallFrame *framePtr = ((Interp *) interp)->varFramePtr;
      Object *callerObjPtr = NULL;
      Class *callerClsPtr = NULL;
      int result;
  
      /*
       * If we've no method name, throw this directly into the unknown
       * processing.
       */
  
      if (objc < 2) {
  	flags |= FORCE_UNKNOWN;
  	methodNamePtr = NULL;
  	goto noMapping;
      }
  
      /*
       * Determine if we're in a context that can see the extra, private methods
       * in this class.
       */
  
      if (framePtr->isProcCallFrame & FRAME_IS_METHOD) {
  	CallContext *callerContextPtr = (CallContext *)framePtr->clientData;
  	Method *callerMethodPtr =
  		callerContextPtr->callPtr->chain[callerContextPtr->index].mPtr;
  
  	if (callerMethodPtr->declaringObjectPtr) {
  	    callerObjPtr = callerMethodPtr->declaringObjectPtr;
  	}
  	if (callerMethodPtr->declaringClassPtr) {
  	    callerClsPtr = callerMethodPtr->declaringClassPtr;
  	}
      }
  
      /*
       * Give plugged in code a chance to remap the method name.
       */
  
      methodNamePtr = objv[1];
      if (oPtr->mapMethodNameProc != NULL) {
  	Class **startClsPtr = &startCls;
  	Tcl_Obj *mappedMethodName = Tcl_DuplicateObj(methodNamePtr);
  
  	result = oPtr->mapMethodNameProc(interp, (Tcl_Object) oPtr,
  		(Tcl_Class *) startClsPtr, mappedMethodName);
  	if (result != TCL_OK) {
  	    TclDecrRefCount(mappedMethodName);
  	    if (result == TCL_BREAK) {
  		goto noMapping;
  	    } else if (result == TCL_ERROR) {
  		Tcl_AddErrorInfo(interp, "\n    (while mapping method name)");
  	    }
  	    return result;
  	}
  
  	/*
  	 * Get the call chain for the remapped name.
  	 */
  
  	Tcl_IncrRefCount(mappedMethodName);
  	contextPtr = TclOOGetCallContext(oPtr, mappedMethodName,
  		flags | (oPtr->flags & FILTER_HANDLING), callerObjPtr,
  		callerClsPtr, methodNamePtr);
  	TclDecrRefCount(mappedMethodName);
  	if (contextPtr == NULL) {
  	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
  		    "impossible to invoke method \"%s\": no defined method or"
  		    " unknown method", TclGetString(methodNamePtr)));
  	    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD_MAPPED",
  		    TclGetString(methodNamePtr), NULL);
  	    return TCL_ERROR;
  	}
      } else {
  	/*
  	 * Get the call chain.
  	 */
  
      noMapping:
  	contextPtr = TclOOGetCallContext(oPtr, methodNamePtr,
  		flags | (oPtr->flags & FILTER_HANDLING), callerObjPtr,
  		callerClsPtr, NULL);
  	if (contextPtr == NULL) {
  	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
  		    "impossible to invoke method \"%s\": no defined method or"
  		    " unknown method", TclGetString(methodNamePtr)));
  	    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
  		    TclGetString(methodNamePtr), NULL);
  	    return TCL_ERROR;
  	}
      }
  
      /*
       * Check to see if we need to apply magical tricks to start part way
       * through the call chain.
       */
  
      if (startCls != NULL) {
  	for (; contextPtr->index < contextPtr->callPtr->numChain;
  		contextPtr->index++) {
  	    struct MInvoke *miPtr =
  		    &contextPtr->callPtr->chain[contextPtr->index];
  
  	    if (miPtr->isFilter) {
  		continue;
  	    }
  	    if (miPtr->mPtr->declaringClassPtr == startCls) {
  		break;
  	    }
  	}
  	if (contextPtr->index >= contextPtr->callPtr->numChain) {
  	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
  		    "no valid method implementation", -1));
  	    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
  		    TclGetString(methodNamePtr), NULL);
  	    TclOODeleteContext(contextPtr);
  	    return TCL_ERROR;
  	}
      }
  
      /*
       * Invoke the call chain, locking the object structure against deletion
       * for the duration.
       */
  
      TclNRAddCallback(interp, FinalizeObjectCall, contextPtr, NULL,NULL,NULL);
      return TclOOInvokeContext(contextPtr, interp, objc, objv);
  }
  
  static int
  FinalizeObjectCall(
      ClientData data[],
      TCL_UNUSED(Tcl_Interp *),
      int result)
  {
      /*
       * Dispose of the call chain, which drops the lock on the object's
       * structure.
       */
  
      TclOODeleteContext((CallContext *)data[0]);
      return result;
  }
  
  /*
   * ----------------------------------------------------------------------
   *
   * Tcl_ObjectContextInvokeNext, TclNRObjectContextInvokeNext, FinalizeNext --
   *
   *	Invokes the next stage of the call chain described in an object
   *	context. This is the core of the implementation of the [next] command.
   *	Does not do management of the call-frame stack. Available in public
   *	(standard API) and private (NRE-aware) forms. FinalizeNext is a
   *	private function used to clean up in the NRE case.
   *
   * ----------------------------------------------------------------------
   */
  
  int
  Tcl_ObjectContextInvokeNext(
      Tcl_Interp *interp,
      Tcl_ObjectContext context,
      int objc,
      Tcl_Obj *const *objv,
      int skip)
  {
      CallContext *contextPtr = (CallContext *) context;
      int savedIndex = contextPtr->index;
      int savedSkip = contextPtr->skip;
      int result;
  
      if (contextPtr->index + 1 >= contextPtr->callPtr->numChain) {
  	/*
  	 * We're at the end of the chain; generate an error message unless the
  	 * interpreter is being torn down, in which case we might be getting
  	 * here because of methods/destructors doing a [next] (or equivalent)
  	 * unexpectedly.
  	 */
  
  	const char *methodType;
  
  	if (Tcl_InterpDeleted(interp)) {
  	    return TCL_OK;
  	}
  
  	if (contextPtr->callPtr->flags & CONSTRUCTOR) {
  	    methodType = "constructor";
  	} else if (contextPtr->callPtr->flags & DESTRUCTOR) {
  	    methodType = "destructor";
  	} else {
  	    methodType = "method";
  	}
  
  	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
  		"no next %s implementation", methodType));
  	Tcl_SetErrorCode(interp, "TCL", "OO", "NOTHING_NEXT", NULL);
  	return TCL_ERROR;
      }
  
      /*
       * Advance to the next method implementation in the chain in the method
       * call context while we process the body. However, need to adjust the
       * argument-skip control because we're guaranteed to have a single prefix
       * arg (i.e., 'next') and not the variable amount that can happen because
       * method invocations (i.e., '$obj meth' and 'my meth'), constructors
       * (i.e., '$cls new' and '$cls create obj') and destructors (no args at
       * all) come through the same code.
       */
  
      contextPtr->index++;
      contextPtr->skip = skip;
  
      /*
       * Invoke the (advanced) method call context in the caller context.
       */
  
      result = Tcl_NRCallObjProc(interp, TclOOInvokeContext, contextPtr, objc,
  	    objv);
  
      /*
       * Restore the call chain context index as we've finished the inner invoke
       * and want to operate in the outer context again.
       */
  
      contextPtr->index = savedIndex;
      contextPtr->skip = savedSkip;
  
      return result;
  }
  
  int
  TclNRObjectContextInvokeNext(
      Tcl_Interp *interp,
      Tcl_ObjectContext context,
      int objc,
      Tcl_Obj *const *objv,
      int skip)
  {
      CallContext *contextPtr = (CallContext *) context;
  
      if (contextPtr->index + 1 >= contextPtr->callPtr->numChain) {
  	/*
  	 * We're at the end of the chain; generate an error message unless the
  	 * interpreter is being torn down, in which case we might be getting
  	 * here because of methods/destructors doing a [next] (or equivalent)
  	 * unexpectedly.
  	 */
  
  	const char *methodType;
  
  	if (Tcl_InterpDeleted(interp)) {
  	    return TCL_OK;
  	}
  
  	if (contextPtr->callPtr->flags & CONSTRUCTOR) {
  	    methodType = "constructor";
  	} else if (contextPtr->callPtr->flags & DESTRUCTOR) {
  	    methodType = "destructor";
  	} else {
  	    methodType = "method";
  	}
  
  	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
  		"no next %s implementation", methodType));
  	Tcl_SetErrorCode(interp, "TCL", "OO", "NOTHING_NEXT", NULL);
  	return TCL_ERROR;
      }
  
      /*
       * Advance to the next method implementation in the chain in the method
       * call context while we process the body. However, need to adjust the
       * argument-skip control because we're guaranteed to have a single prefix
       * arg (i.e., 'next') and not the variable amount that can happen because
       * method invocations (i.e., '$obj meth' and 'my meth'), constructors
       * (i.e., '$cls new' and '$cls create obj') and destructors (no args at
       * all) come through the same code.
       */
  
      TclNRAddCallback(interp, FinalizeNext, contextPtr,
  	    INT2PTR(contextPtr->index), INT2PTR(contextPtr->skip), NULL);
      contextPtr->index++;
      contextPtr->skip = skip;
  
      /*
       * Invoke the (advanced) method call context in the caller context.
       */
  
      return TclOOInvokeContext(contextPtr, interp, objc, objv);
  }
  
  static int
  FinalizeNext(
      ClientData data[],
      TCL_UNUSED(Tcl_Interp *),
      int result)
  {
      CallContext *contextPtr = (CallContext *)data[0];
  
      /*
       * Restore the call chain context index as we've finished the inner invoke
       * and want to operate in the outer context again.
       */
  
      contextPtr->index = PTR2INT(data[1]);
      contextPtr->skip = PTR2INT(data[2]);
      return result;
  }
  
  /*
   * ----------------------------------------------------------------------
   *
   * Tcl_GetObjectFromObj --
   *
   *	Utility function to get an object from a Tcl_Obj containing its name.
   *
   * ----------------------------------------------------------------------
   */
  
  Tcl_Object
  Tcl_GetObjectFromObj(
      Tcl_Interp *interp,		/* Interpreter in which to locate the object.
  				 * Will have an error message placed in it if
  				 * the name does not refer to an object. */
      Tcl_Obj *objPtr)		/* The name of the object to look up, which is
  				 * exactly the name of its public command. */
  {
      Command *cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objPtr);
  
      if (cmdPtr == NULL) {
  	goto notAnObject;
      }
      if (cmdPtr->objProc != TclOOPublicObjectCmd) {
  	cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr);
  	if (cmdPtr == NULL || cmdPtr->objProc != TclOOPublicObjectCmd) {
  	    goto notAnObject;
  	}
      }
      return (Tcl_Object)cmdPtr->objClientData;
  
    notAnObject:
      Tcl_SetObjResult(interp, Tcl_ObjPrintf(
  	    "%s does not refer to an object", TclGetString(objPtr)));
      Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "OBJECT", TclGetString(objPtr),
  	    NULL);
      return NULL;
  }
  
  /*
   * ----------------------------------------------------------------------
   *
   * TclOOIsReachable --
   *
   *	Utility function that tests whether a class is a subclass (whether
   *	directly or indirectly) of another class.
   *
   * ----------------------------------------------------------------------
   */
  
  int
  TclOOIsReachable(
      Class *targetPtr,
      Class *startPtr)
  {
      int i;
      Class *superPtr;
  
    tailRecurse:
      if (startPtr == targetPtr) {
  	return 1;
      }
      if (startPtr->superclasses.num == 1 && startPtr->mixins.num == 0) {
  	startPtr = startPtr->superclasses.list[0];
  	goto tailRecurse;
      }
      FOREACH(superPtr, startPtr->superclasses) {
  	if (TclOOIsReachable(targetPtr, superPtr)) {
  	    return 1;
  	}
      }
      FOREACH(superPtr, startPtr->mixins) {
  	if (TclOOIsReachable(targetPtr, superPtr)) {
  	    return 1;
  	}
      }
      return 0;
  }
  
  /*
   * ----------------------------------------------------------------------
   *
   * TclOOObjectName, Tcl_GetObjectName --
   *
   *	Utility function that returns the name of the object. Note that this
   *	simplifies cache management by keeping the code to do it in one place
   *	and not sprayed all over. The value returned always has a reference
   *	count of at least one.
   *
   * ----------------------------------------------------------------------
   */
  
  Tcl_Obj *
  TclOOObjectName(
      Tcl_Interp *interp,
      Object *oPtr)
  {
      Tcl_Obj *namePtr;
  
      if (oPtr->cachedNameObj) {
  	return oPtr->cachedNameObj;
      }
      TclNewObj(namePtr);
      Tcl_GetCommandFullName(interp, oPtr->command, namePtr);
      Tcl_IncrRefCount(namePtr);
      oPtr->cachedNameObj = namePtr;
      return namePtr;
  }
  
  Tcl_Obj *
  Tcl_GetObjectName(
      Tcl_Interp *interp,
      Tcl_Object object)
  {
      return TclOOObjectName(interp, (Object *) object);
  }
  
  /*
   * ----------------------------------------------------------------------
   *
   * assorted trivial 'getter' functions
   *
   * ----------------------------------------------------------------------
   */
  
  Tcl_Method
  Tcl_ObjectContextMethod(
      Tcl_ObjectContext context)
  {
      CallContext *contextPtr = (CallContext *) context;
      return (Tcl_Method) contextPtr->callPtr->chain[contextPtr->index].mPtr;
  }
  
  int
  Tcl_ObjectContextIsFiltering(
      Tcl_ObjectContext context)
  {
      CallContext *contextPtr = (CallContext *) context;
      return contextPtr->callPtr->chain[contextPtr->index].isFilter;
  }
  
  Tcl_Object
  Tcl_ObjectContextObject(
      Tcl_ObjectContext context)
  {
      return (Tcl_Object) ((CallContext *)context)->oPtr;
  }
  
  int
  Tcl_ObjectContextSkippedArgs(
      Tcl_ObjectContext context)
  {
      return ((CallContext *)context)->skip;
  }
  
  Tcl_Namespace *
  Tcl_GetObjectNamespace(
      Tcl_Object object)
  {
      return ((Object *)object)->namespacePtr;
  }
  
  Tcl_Command
  Tcl_GetObjectCommand(
      Tcl_Object object)
  {
      return ((Object *)object)->command;
  }
  
  Tcl_Class
  Tcl_GetObjectAsClass(
      Tcl_Object object)
  {
      return (Tcl_Class) ((Object *)object)->classPtr;
  }
  
  int
  Tcl_ObjectDeleted(
      Tcl_Object object)
  {
      return ((Object *)object)->command == NULL;
  }
  
  Tcl_Object
  Tcl_GetClassAsObject(
      Tcl_Class clazz)
  {
      return (Tcl_Object) ((Class *)clazz)->thisPtr;
  }
  
  Tcl_ObjectMapMethodNameProc *
  Tcl_ObjectGetMethodNameMapper(
      Tcl_Object object)
  {
      return ((Object *) object)->mapMethodNameProc;
  }
  
  void
  Tcl_ObjectSetMethodNameMapper(
      Tcl_Object object,
      Tcl_ObjectMapMethodNameProc *mapMethodNameProc)
  {
      ((Object *) object)->mapMethodNameProc = mapMethodNameProc;
  }
  
  /*
   * Local Variables:
   * mode: c
   * c-basic-offset: 4
   * fill-column: 78
   * End:
   */
  