fix line endings

5 files changed, 5928 insertions, 5928 deletions

diff --git a/generic/tclOO.c b/generic/tclOO.c
index 34bc039..295544f 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -1,2789 +1,2789 @@
-/*

- * tclOO.c --

- *

- *	This file contains the object-system core (NB: not Tcl_Obj, but ::oo)

- *

- * Copyright (c) 2005-2006 by Donal K. Fellows

- *

- * See the file "license.terms" for information on usage and redistribution of

- * this file, and for a DISCLAIMER OF ALL WARRANTIES.

- *

- * RCS: @(#) $Id: tclOO.c,v 1.1.2.59 2006/10/08 15:39:58 dkf Exp $

- */

-

-#include "tclInt.h"

-#include "tclOO.h"

-

-/*

- * Commands in oo::define.

- */

-

-static const struct {

-    const char *name;

-    Tcl_ObjCmdProc *objProc;

-    int flag;

-} defineCmds[] = {

-    {"constructor", TclOODefineConstructorObjCmd, 0},

-    {"copy", TclOODefineCopyObjCmd, 0},

-    {"destructor", TclOODefineDestructorObjCmd, 0},

-    {"export", TclOODefineExportObjCmd, 0},

-    {"self.export", TclOODefineExportObjCmd, 1},

-    {"filter", TclOODefineFilterObjCmd, 0},

-    {"self.filter", TclOODefineFilterObjCmd, 1},

-    {"forward", TclOODefineForwardObjCmd, 0},

-    {"self.forward", TclOODefineForwardObjCmd, 1},

-    {"method", TclOODefineMethodObjCmd, 0},

-    {"self.method", TclOODefineMethodObjCmd, 1},

-    {"mixin", TclOODefineMixinObjCmd, 0},

-    {"self.mixin", TclOODefineMixinObjCmd, 1},

-#ifdef SUPPORT_OO_PARAMETERS

-    {"parameter", TclOODefineParameterObjCmd, 0},

-#endif

-    {"superclass", TclOODefineSuperclassObjCmd, 0},

-    {"unexport", TclOODefineUnexportObjCmd, 0},

-    {"self.unexport", TclOODefineUnexportObjCmd, 1},

-    {"self.class", TclOODefineSelfClassObjCmd, 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 Class *		AllocClass(Tcl_Interp *interp, Object *useThisObj);

-static Object *		AllocObject(Tcl_Interp *interp, const char *nameStr);

-static void		DeclareClassMethod(Tcl_Interp *interp, Class *clsPtr,

-			    const char *name, int isPublic,

-			    Tcl_MethodCallProc callProc);

-static void		KillFoundation(ClientData clientData,

-			    Tcl_Interp *interp);

-static int		ObjectCmd(Object *oPtr, Tcl_Interp *interp, int objc,

-			    Tcl_Obj *const *objv, int publicOnly,

-			    Tcl_HashTable *cachePtr);

-static void		ObjectNamespaceDeleted(ClientData clientData);

-static void		ObjectDeletedTrace(ClientData clientData,

-			    Tcl_Interp *interp, const char *oldName,

-			    const char *newName, int flags);

-static void		ReleaseClassContents(Tcl_Interp *interp,Object *oPtr);

-

-static int		PublicObjectCmd(ClientData clientData,

-			    Tcl_Interp *interp, int objc,

-			    Tcl_Obj *const *objv);

-static int		PrivateObjectCmd(ClientData clientData,

-			    Tcl_Interp *interp, int objc,

-			    Tcl_Obj *const *objv);

-

-static int		SimpleInvoke(ClientData clientData,

-			    Tcl_Interp *interp, Tcl_ObjectContext context,

-			    int objc, Tcl_Obj *const *objv);

-static int		InvokeProcedureMethod(ClientData clientData,

-			    Tcl_Interp *interp, Tcl_ObjectContext context,

-			    int objc, Tcl_Obj *const *objv);

-static void		DeleteProcedureMethod(ClientData clientData);

-static int		CloneProcedureMethod(ClientData clientData,

-			    ClientData *newClientData);

-static int		InvokeForwardMethod(ClientData clientData,

-			    Tcl_Interp *interp, Tcl_ObjectContext context,

-			    int objc, Tcl_Obj *const *objv);

-static void		DeleteForwardMethod(ClientData clientData);

-static int		CloneForwardMethod(ClientData clientData,

-			    ClientData *newClientData);

-static Tcl_Obj **	InitEnsembleRewrite(Tcl_Interp *interp, int objc,

-			    Tcl_Obj *const *objv, int toRewrite,

-			    int rewriteLength, Tcl_Obj *const *rewriteObjs,

-			    int *lengthPtr);

-

-static int		ClassCreate(ClientData clientData, Tcl_Interp *interp,

-			    Tcl_ObjectContext context, int objc,

-			    Tcl_Obj *const *objv);

-static int		ClassNew(ClientData clientData, Tcl_Interp *interp,

-			    Tcl_ObjectContext context, int objc,

-			    Tcl_Obj *const *objv);

-static int		ObjectDestroy(ClientData clientData,

-			    Tcl_Interp *interp, Tcl_ObjectContext context,

-			    int objc, Tcl_Obj *const *objv);

-static int		ObjectEval(ClientData clientData, Tcl_Interp *interp,

-			    Tcl_ObjectContext context, int objc,

-			    Tcl_Obj *const *objv);

-static int		ObjectLinkVar(ClientData clientData,

-			    Tcl_Interp *interp, Tcl_ObjectContext context,

-			    int objc, Tcl_Obj *const *objv);

-static int		ObjectUnknown(ClientData clientData,

-			    Tcl_Interp *interp, Tcl_ObjectContext context,

-			    int objc, Tcl_Obj *const *objv);

-static int		ObjectVarName(ClientData clientData,

-			    Tcl_Interp *interp, Tcl_ObjectContext context,

-			    int objc, Tcl_Obj *const *objv);

-

-static int		NextObjCmd(ClientData clientData, Tcl_Interp *interp,

-			    int objc, Tcl_Obj *const *objv);

-static int		SelfObjCmd(ClientData clientData, Tcl_Interp *interp,

-			    int objc, Tcl_Obj *const *objv);

-

-/*

- * The types of methods defined by the core OO system.

- */

-

-static const Tcl_MethodType procMethodType = {

-    TCL_OO_METHOD_VERSION_CURRENT, "procedural method",

-    InvokeProcedureMethod, DeleteProcedureMethod, CloneProcedureMethod

-};

-static const Tcl_MethodType fwdMethodType = {

-    TCL_OO_METHOD_VERSION_CURRENT, "forward",

-    InvokeForwardMethod, DeleteForwardMethod, CloneForwardMethod

-};

-static const Tcl_MethodType coreMethodType = {

-    TCL_OO_METHOD_VERSION_CURRENT, "core method",

-    SimpleInvoke, NULL, 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. */

-{

-    Interp *iPtr = (Interp *) interp;

-    Foundation *fPtr;

-    int i;

-    Tcl_DString buffer;

-

-    /*

-     * Construct the foundation of the object system. This is a structure

-     * holding references to the magical bits that need to be known about in

-     * other places.

-     */

-

-    fPtr = iPtr->ooFoundation = (Foundation *) ckalloc(sizeof(Foundation));

-    memset(fPtr, 0, sizeof(Foundation));

-    fPtr->ooNs = Tcl_CreateNamespace(interp, "::oo", fPtr, NULL);

-    Tcl_Export(interp, fPtr->ooNs, "[a-z]*", 1);

-    fPtr->defineNs = Tcl_CreateNamespace(interp, "::oo::define", NULL, NULL);

-    fPtr->helpersNs = Tcl_CreateNamespace(interp, "::oo::Helpers", NULL,

-	    NULL);

-    Tcl_CreateObjCommand(interp, "::oo::Helpers::next", NextObjCmd, NULL,

-	    NULL);

-    Tcl_CreateObjCommand(interp, "::oo::Helpers::self", SelfObjCmd, NULL,

-	    NULL);

-    Tcl_CreateObjCommand(interp, "::oo::define", TclOODefineObjCmd, NULL,

-	    NULL);

-    Tcl_DStringInit(&buffer);

-    for (i=0 ; defineCmds[i].name ; i++) {

-	Tcl_DStringAppend(&buffer, "::oo::define::", 14);

-	Tcl_DStringAppend(&buffer, defineCmds[i].name, -1);

-	Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer),

-		defineCmds[i].objProc, (void *) defineCmds[i].flag, NULL);

-	Tcl_DStringFree(&buffer);

-    }

-    fPtr->epoch = 0;

-    fPtr->nsCount = 0;

-    fPtr->unknownMethodNameObj = Tcl_NewStringObj("unknown", -1);

-    Tcl_IncrRefCount(fPtr->unknownMethodNameObj);

-

-    Tcl_CallWhenDeleted(interp, KillFoundation, fPtr);

-

-    /*

-     * Create the objects at the core of the object system. These need to be

-     * spliced manually.

-     */

-

-    fPtr->objectCls = AllocClass(interp, AllocObject(interp, "::oo::object"));

-    fPtr->classCls = AllocClass(interp, AllocObject(interp, "::oo::class"));

-    fPtr->objectCls->thisPtr->selfCls = fPtr->classCls;

-    fPtr->objectCls->thisPtr->flags |= ROOT_OBJECT;

-    fPtr->objectCls->superclasses.num = 0;

-    ckfree((char *) fPtr->objectCls->superclasses.list);

-    fPtr->objectCls->superclasses.list = NULL;

-    fPtr->classCls->thisPtr->selfCls = fPtr->classCls;

-    TclOOAddToInstances(fPtr->objectCls->thisPtr, fPtr->classCls);

-    TclOOAddToInstances(fPtr->classCls->thisPtr, fPtr->classCls);

-

-    /*

-     * Basic method declarations for the core classes.

-     */

-

-    DeclareClassMethod(interp, fPtr->objectCls, "destroy", 1, ObjectDestroy);

-    DeclareClassMethod(interp, fPtr->objectCls, "eval", 0, ObjectEval);

-    DeclareClassMethod(interp, fPtr->objectCls, "unknown", 0, ObjectUnknown);

-    DeclareClassMethod(interp, fPtr->objectCls, "variable", 0, ObjectLinkVar);

-    DeclareClassMethod(interp, fPtr->objectCls, "varname", 0, ObjectVarName);

-    DeclareClassMethod(interp, fPtr->classCls, "create", 1, ClassCreate);

-    DeclareClassMethod(interp, fPtr->classCls, "new", 1, ClassNew);

-

-    /*

-     * Finish setting up the class of classes.

-     */

-

-    {

-	Tcl_Obj *namePtr, *argsPtr, *bodyPtr;

-

-	/*

-	 * Mark the 'new' method in oo::class as private; classes, unlike

-	 * general objects, must have explicit names.

-	 */

-

-	namePtr = Tcl_NewStringObj("new", -1);

-	Tcl_NewMethod(interp, (Tcl_Object) fPtr->classCls->thisPtr, namePtr,

-		0 /* ==private */, NULL, NULL);

-

-	argsPtr = Tcl_NewStringObj("{definitionScript {}}", -1);

-	bodyPtr = Tcl_NewStringObj(

-		"if {[catch {define [self] $definitionScript} msg opt]} {\n"

-		"set ei [split [dict get $opt -errorinfo] \\n]\n"

-		"dict set opt -errorinfo [join [lrange $ei 0 end-2] \\n]\n"

-		"dict set opt -errorline 0xdeadbeef\n"

-		"}\n"

-		"return -options $opt $msg", -1);

-	fPtr->classCls->constructorPtr = TclOONewProcClassMethod(interp,

-		fPtr->classCls, 0, NULL, argsPtr, bodyPtr);

-    }

-

-    return TCL_OK;

-}

-

-/*

- * ----------------------------------------------------------------------

- *

- * KillFoundation --

- *

- *	Delete those parts of the OO core that are not deleted automatically

- *	when the objects and classes themselves are destroyed.

- *

- * ----------------------------------------------------------------------

- */

-

-static void

-KillFoundation(

-    ClientData clientData,	/* Pointer to the OO system foundation

-				 * structure. */

-    Tcl_Interp *interp)		/* The interpreter containing the OO system

-				 * foundation. */

-{

-    Foundation *fPtr = clientData;

-

-    TclDecrRefCount(fPtr->unknownMethodNameObj);

-    ckfree((char *) fPtr);

-}

-

-/*

- * ----------------------------------------------------------------------

- *

- * AllocObject --

- *

- *	Allocate an object of basic type. Does not splice the object into its

- *	class's instance list.

- *

- * ----------------------------------------------------------------------

- */

-

-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. */

-{

-    Foundation *fPtr = ((Interp *) interp)->ooFoundation;

-    Tcl_Obj *cmdnameObj;

-    Tcl_DString buffer;

-    Object *oPtr;

-

-    oPtr = (Object *) ckalloc(sizeof(Object));

-    memset(oPtr, 0, sizeof(Object));

-    while (1) {

-	char objName[10 + TCL_INTEGER_SPACE];

-

-	sprintf(objName, "::oo::Obj%d", ++fPtr->nsCount);

-	oPtr->namespacePtr = Tcl_CreateNamespace(interp, objName, oPtr,

-		ObjectNamespaceDeleted);

-	if (oPtr->namespacePtr != NULL) {

-	    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);

-    }

-    TclSetNsPath((Namespace *) oPtr->namespacePtr, 1, &fPtr->helpersNs);

-    oPtr->selfCls = fPtr->objectCls;

-    Tcl_InitObjHashTable(&oPtr->methods);

-    Tcl_InitObjHashTable(&oPtr->publicContextCache);

-    Tcl_InitObjHashTable(&oPtr->privateContextCache);

-    oPtr->filters.num = 0;

-    oPtr->filters.list = NULL;

-    oPtr->mixins.num = 0;

-    oPtr->mixins.list = NULL;

-    oPtr->classPtr = NULL;

-    oPtr->flags = 0;

-

-    /*

-     * Initialize the traces.

-     */

-

-    Tcl_DStringInit(&buffer);

-    if (nameStr) {

-	if (nameStr[0] != ':' || nameStr[1] != ':') {

-	    Tcl_DStringAppend(&buffer,

-		    Tcl_GetCurrentNamespace(interp)->fullName, -1);

-	    Tcl_DStringAppend(&buffer, "::", 2);

-	}

-	Tcl_DStringAppend(&buffer, nameStr, -1);

-    } else {

-	Tcl_DStringAppend(&buffer, oPtr->namespacePtr->fullName, -1);

-    }

-    oPtr->command = Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer),

-	    PublicObjectCmd, oPtr, NULL);

-    if (nameStr) {

-	Tcl_DStringFree(&buffer);

-	Tcl_DStringAppend(&buffer, oPtr->namespacePtr->fullName, -1);

-    }

-    Tcl_DStringAppend(&buffer, "::my", 4);

-    oPtr->myCommand = Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer),

-	    PrivateObjectCmd, oPtr, NULL);

-    Tcl_DStringFree(&buffer);

-

-    TclNewObj(cmdnameObj);

-    Tcl_GetCommandFullName(interp, oPtr->command, cmdnameObj);

-    Tcl_TraceCommand(interp, TclGetString(cmdnameObj),

-	    TCL_TRACE_DELETE, ObjectDeletedTrace, oPtr);

-    TclDecrRefCount(cmdnameObj);

-

-    return oPtr;

-}

-

-/*

- * ----------------------------------------------------------------------

- *

- * ObjectDeletedTrace --

- *

- *	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

-ObjectDeletedTrace(

-    ClientData clientData,	/* The object being deleted. */

-    Tcl_Interp *interp,		/* The interpreter containing the object. */

-    const char *oldName,	/* What the object was (last) called. */

-    const char *newName,	/* Always NULL. */

-    int flags)			/* Why was the object deleted? */

-{

-    Interp *iPtr = (Interp *) interp;

-    Object *oPtr = clientData;

-    Class *clsPtr;

-

-    Tcl_Preserve(oPtr);

-    oPtr->flags |= OBJECT_DELETED;

-    if (!Tcl_InterpDeleted(interp)) {

-	CallContext *contextPtr = TclOOGetCallContext(iPtr->ooFoundation,

-		oPtr, NULL, DESTRUCTOR, NULL);

-

-	if (contextPtr != NULL) {

-	    int result;

-	    Tcl_InterpState state;

-

-	    contextPtr->flags |= DESTRUCTOR;

-	    contextPtr->skip = 0;

-	    state = Tcl_SaveInterpState(interp, TCL_OK);

-	    result = TclOOInvokeContext(interp, contextPtr, 0, NULL);

-	    if (result != TCL_OK) {

-		Tcl_BackgroundError(interp);

-	    }

-	    (void) Tcl_RestoreInterpState(interp, state);

-	    TclOODeleteContext(contextPtr);

-	}

-    }

-

-    clsPtr = oPtr->classPtr;

-    if (clsPtr != NULL) {

-	ReleaseClassContents(interp, oPtr);

-    }

-

-    Tcl_DeleteNamespace(oPtr->namespacePtr);

-    if (clsPtr) {

-	Tcl_Release(clsPtr);

-    }

-    Tcl_Release(oPtr);

-

-    /*

-     * What else to do to delete an object?

-     */

-}

-

-/*

- * ----------------------------------------------------------------------

- *

- * ReleaseClassContents --

- *

- *	Tear down the special class data structure, including deleting all

- *	dependent classes and objects.

- *

- * ----------------------------------------------------------------------

- */

-

-static void

-ReleaseClassContents(

-    Tcl_Interp *interp,		/* The interpreter containing the class. */

-    Object *oPtr)		/* The object representing the class. */

-{

-    int i, n;

-    Class *clsPtr, **list;

-    Object **insts;

-

-    clsPtr = oPtr->classPtr;

-    Tcl_Preserve(clsPtr);

-

-    /*

-     * Must empty list before processing the members of the list so that

-     * things happen in the correct order even if something tries to play

-     * fast-and-loose.

-     */

-

-    list = clsPtr->mixinSubs.list;

-    n = clsPtr->mixinSubs.num;

-    clsPtr->mixinSubs.list = NULL;

-    clsPtr->mixinSubs.num = 0;

-    clsPtr->mixinSubs.size = 0;

-    for (i=0 ; i<n ; i++) {

-	Tcl_Preserve(list[i]);

-    }

-    for (i=0 ; i<n ; i++) {

-	if (!(list[i]->flags & OBJECT_DELETED) && interp != NULL) {

-	    Tcl_DeleteCommandFromToken(interp, list[i]->thisPtr->command);

-	}

-	Tcl_Release(list[i]);

-    }

-    if (list != NULL) {

-	ckfree((char *) list);

-    }

-

-    list = clsPtr->subclasses.list;

-    n = clsPtr->subclasses.num;

-    clsPtr->subclasses.list = NULL;

-    clsPtr->subclasses.num = 0;

-    clsPtr->subclasses.size = 0;

-    for (i=0 ; i<n ; i++) {

-	Tcl_Preserve(list[i]);

-    }

-    for (i=0 ; i<n ; i++) {

-	if (!(list[i]->flags & OBJECT_DELETED) && interp != NULL) {

-	    Tcl_DeleteCommandFromToken(interp, list[i]->thisPtr->command);

-	}

-	Tcl_Release(list[i]);

-    }

-    if (list != NULL) {

-	ckfree((char *) list);

-    }

-

-    insts = clsPtr->instances.list;

-    n = clsPtr->instances.num;

-    clsPtr->instances.list = NULL;

-    clsPtr->instances.num = 0;

-    clsPtr->instances.size = 0;

-    for (i=0 ; i<n ; i++) {

-	Tcl_Preserve(insts[i]);

-    }

-    for (i=0 ; i<n ; i++) {

-	if (!(insts[i]->flags & OBJECT_DELETED) && interp != NULL) {

-	    Tcl_DeleteCommandFromToken(interp, insts[i]->command);

-	}

-	Tcl_Release(insts[i]);

-    }

-    if (insts != NULL) {

-	ckfree((char *) insts);

-    }

-

-    if (clsPtr->filters.num) {

-	Tcl_Obj *filterObj;

-

-	FOREACH(filterObj, clsPtr->filters) {

-	    TclDecrRefCount(filterObj);

-	}

-	ckfree((char *) clsPtr->filters.list);

-	clsPtr->filters.num = 0;

-    }

-}

-

-/*

- * ----------------------------------------------------------------------

- *

- * 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 = clientData;

-    FOREACH_HASH_DECLS;

-    Class *clsPtr, *mixinPtr;

-    CallContext *contextPtr;

-    Method *mPtr;

-    Tcl_Obj *filterObj;

-    int i;

-

-    /*

-     * Instruct everyone to no longer use any allocated fields of the object.

-     */

-

-    if (!(oPtr->flags & OBJECT_DELETED)) {

-	Tcl_Preserve(oPtr);

-	if (oPtr->classPtr != NULL) {

-	    ReleaseClassContents(NULL, oPtr);

-	}

-    }

-    oPtr->flags |= OBJECT_DELETED;

-

-    /*

-     * Splice the object out of its context. After this, we must *not* call

-     * methods on the object.

-     */

-

-    if (!(oPtr->flags & ROOT_OBJECT)) {

-	TclOORemoveFromInstances(oPtr, oPtr->selfCls);

-    }

-    FOREACH(mixinPtr, oPtr->mixins) {

-	TclOORemoveFromInstances(oPtr, mixinPtr);

-    }

-    if (i) {

-	ckfree((char *)oPtr->mixins.list);

-    }

-    FOREACH(filterObj, oPtr->filters) {

-	TclDecrRefCount(filterObj);

-    }

-    if (i) {

-	ckfree((char *)oPtr->filters.list);

-    }

-    FOREACH_HASH_VALUE(mPtr, &oPtr->methods) {

-	TclOODeleteMethod(mPtr);

-    }

-    Tcl_DeleteHashTable(&oPtr->methods);

-    FOREACH_HASH_VALUE(contextPtr, &oPtr->publicContextCache) {

-	if (contextPtr) {

-	    TclOODeleteContext(contextPtr);

-	}

-    }

-    Tcl_DeleteHashTable(&oPtr->publicContextCache);

-    FOREACH_HASH_VALUE(contextPtr, &oPtr->privateContextCache) {

-	if (contextPtr) {

-	    TclOODeleteContext(contextPtr);

-	}

-    }

-    Tcl_DeleteHashTable(&oPtr->privateContextCache);

-

-    clsPtr = oPtr->classPtr;

-    if (clsPtr != NULL && !(oPtr->flags & ROOT_OBJECT)) {

-	Class *superPtr, *mixinPtr;

-

-	clsPtr->flags |= OBJECT_DELETED;

-	FOREACH(mixinPtr, clsPtr->mixins) {

-	    if (!(mixinPtr->flags & OBJECT_DELETED)) {

-		TclOORemoveFromSubclasses(clsPtr, mixinPtr);

-	    }

-	}

-	if (i) {

-	    ckfree((char *) clsPtr->mixins.list);

-	    clsPtr->mixins.num = 0;

-	}

-	FOREACH(superPtr, clsPtr->superclasses) {

-	    if (!(superPtr->flags & OBJECT_DELETED)) {

-		TclOORemoveFromSubclasses(clsPtr, superPtr);

-	    }

-	}

-	if (i) {

-	    ckfree((char *) clsPtr->superclasses.list);

-	    clsPtr->superclasses.num = 0;

-	}

-	if (clsPtr->subclasses.list) {

-	    ckfree((char *) clsPtr->subclasses.list);

-	    clsPtr->subclasses.num = 0;

-	}

-	if (clsPtr->instances.list) {

-	    ckfree((char *) clsPtr->instances.list);

-	    clsPtr->instances.num = 0;

-	}

-	if (clsPtr->mixinSubs.list) {

-	    ckfree((char *) clsPtr->mixinSubs.list);

-	    clsPtr->mixinSubs.num = 0;

-	}

-	if (clsPtr->classHierarchy.list) {

-	    ckfree((char *) clsPtr->classHierarchy.list);

-	    clsPtr->classHierarchy.num = 0;

-	}

-

-	FOREACH_HASH_VALUE(mPtr, &clsPtr->classMethods) {

-	    TclOODeleteMethod(mPtr);

-	}

-	Tcl_DeleteHashTable(&clsPtr->classMethods);

-	TclOODeleteMethod(clsPtr->constructorPtr);

-	TclOODeleteMethod(clsPtr->destructorPtr);

-	Tcl_EventuallyFree(clsPtr, TCL_DYNAMIC);

-    }

-

-    /*

-     * Delete the object structure itself.

-     */

-

-    if (!(oPtr->flags & OBJECT_DELETED)) {

-	Tcl_EventuallyFree(oPtr, TCL_DYNAMIC);

-	Tcl_Release(oPtr);

-    } else {

-	Tcl_EventuallyFree(oPtr, TCL_DYNAMIC);

-    }

-}

-

-/*

- * ----------------------------------------------------------------------

- *

- * TclOORemoveFromInstances --

- *

- *	Utility function to remove an object from the list of instances within

- *	a class.

- *

- * ----------------------------------------------------------------------

- */

-

-void

-TclOORemoveFromInstances(

-    Object *oPtr,		/* The instance to remove. */

-    Class *clsPtr)		/* The class (possibly) containing the

-				 * reference to the instance. */

-{

-    int i;

-    Object *instPtr;

-

-    FOREACH(instPtr, clsPtr->instances) {

-	if (oPtr == instPtr) {

-	    goto removeInstance;

-	}

-    }

-    return;

-

-  removeInstance:

-    clsPtr->instances.num--;

-    if (i < clsPtr->instances.num) {

-	clsPtr->instances.list[i] =

-		clsPtr->instances.list[clsPtr->instances.num];

-    }

-    clsPtr->instances.list[clsPtr->instances.num] = NULL;

-}

-

-/*

- * ----------------------------------------------------------------------

- *

- * 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 **)

-		    ckalloc(sizeof(Object *) * ALLOC_CHUNK);

-	} else {

-	    clsPtr->instances.list = (Object **)

-		    ckrealloc((char *) clsPtr->instances.list,

-		    sizeof(Object *) * clsPtr->instances.size);

-	}

-    }

-    clsPtr->instances.list[clsPtr->instances.num++] = oPtr;

-}

-

-/*

- * ----------------------------------------------------------------------

- *

- * TclOORemoveFromSubclasses --

- *

- *	Utility function to remove a class from the list of subclasses within

- *	another class.

- *

- * ----------------------------------------------------------------------

- */

-

-void

-TclOORemoveFromSubclasses(

-    Class *subPtr,		/* The subclass to remove. */

-    Class *superPtr)		/* The superclass to (possibly) remove the

-				 * subclass reference from. */

-{

-    int i;

-    Class *subclsPtr;

-

-    FOREACH(subclsPtr, superPtr->subclasses) {

-	if (subPtr == subclsPtr) {

-	    goto removeSubclass;

-	}

-    }

-    return;

-

-  removeSubclass:

-    superPtr->subclasses.num--;

-    if (i < superPtr->subclasses.num) {

-	superPtr->subclasses.list[i] =

-	    superPtr->subclasses.list[superPtr->subclasses.num];

-    }

-    superPtr->subclasses.list[superPtr->subclasses.num] = NULL;

-}

-

-/*

- * ----------------------------------------------------------------------

- *

- * 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 (superPtr->subclasses.num >= superPtr->subclasses.size) {

-	superPtr->subclasses.size += ALLOC_CHUNK;

-	if (superPtr->subclasses.size == ALLOC_CHUNK) {

-	    superPtr->subclasses.list = (Class **)

-		    ckalloc(sizeof(Class *) * ALLOC_CHUNK);

-	} else {

-	    superPtr->subclasses.list = (Class **)

-		    ckrealloc((char *) superPtr->subclasses.list,

-		    sizeof(Class *) * superPtr->subclasses.size);

-	}

-    }

-    superPtr->subclasses.list[superPtr->subclasses.num++] = subPtr;

-}

-

-/*

- * ----------------------------------------------------------------------

- *

- * TclOORemoveFromMixinSubs --

- *

- *	Utility function to remove a class from the list of mixinSubs within

- *	another class.

- *

- * ----------------------------------------------------------------------

- */

-

-void

-TclOORemoveFromMixinSubs(

-    Class *subPtr,		/* The subclass to remove. */

-    Class *superPtr)		/* The superclass to (possibly) remove the

-				 * subclass reference from. */

-{

-    int i;

-    Class *subclsPtr;

-

-    FOREACH(subclsPtr, superPtr->mixinSubs) {

-	if (subPtr == subclsPtr) {

-	    goto removeSubclass;

-	}

-    }

-    return;

-

-  removeSubclass:

-    superPtr->mixinSubs.num--;

-    if (i < superPtr->mixinSubs.num) {

-	superPtr->mixinSubs.list[i] =

-	    superPtr->mixinSubs.list[superPtr->mixinSubs.num];

-    }

-    superPtr->mixinSubs.list[superPtr->mixinSubs.num] = NULL;

-}

-

-/*

- * ----------------------------------------------------------------------

- *

- * 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 (superPtr->mixinSubs.num >= superPtr->mixinSubs.size) {

-	superPtr->mixinSubs.size += ALLOC_CHUNK;

-	if (superPtr->mixinSubs.size == ALLOC_CHUNK) {

-	    superPtr->mixinSubs.list = (Class **)

-		    ckalloc(sizeof(Class *) * ALLOC_CHUNK);

-	} else {

-	    superPtr->mixinSubs.list = (Class **)

-		    ckrealloc((char *) superPtr->mixinSubs.list,

-		    sizeof(Class *) * superPtr->mixinSubs.size);

-	}

-    }

-    superPtr->mixinSubs.list[superPtr->mixinSubs.num++] = subPtr;

-}

-

-/*

- * ----------------------------------------------------------------------

- *

- * AllocClass --

- *

- *	Allocate a basic class. Does not splice the class object into its

- *	class's instance list.

- *

- * ----------------------------------------------------------------------

- */

-

-static Class *

-AllocClass(

-    Tcl_Interp *interp,		/* Interpreter within which to allocate the

-				 * class. */

-    Object *useThisObj)		/* Object that is to act as the class

-				 * representation, or NULL if a new object

-				 * (with automatic name) is to be used. */

-{

-    Class *clsPtr;

-    Foundation *fPtr = ((Interp *) interp)->ooFoundation;

-

-    clsPtr = (Class *) ckalloc(sizeof(Class));

-    memset(clsPtr, 0, sizeof(Class));

-    if (useThisObj == NULL) {

-	clsPtr->thisPtr = AllocObject(interp, NULL);

-    } else {

-	clsPtr->thisPtr = useThisObj;

-    }

-    clsPtr->thisPtr->selfCls = fPtr->classCls;

-    if (fPtr->classCls != NULL) {

-	TclOOAddToInstances(clsPtr->thisPtr, fPtr->classCls);

-	TclOOAddToSubclasses(clsPtr, fPtr->objectCls);

-    }

-    {

-	Tcl_Namespace *path[2];

-

-	path[0] = fPtr->helpersNs;

-	path[1] = fPtr->ooNs;

-	TclSetNsPath((Namespace *) clsPtr->thisPtr->namespacePtr, 2, path);

-    }

-    clsPtr->thisPtr->classPtr = clsPtr;

-    clsPtr->flags = 0;

-    clsPtr->superclasses.num = 1;

-    clsPtr->superclasses.list = (Class **) ckalloc(sizeof(Class *));

-    clsPtr->superclasses.list[0] = fPtr->objectCls;

-    clsPtr->subclasses.num = 0;

-    clsPtr->subclasses.list = NULL;

-    clsPtr->subclasses.size = 0;

-    clsPtr->instances.num = 0;

-    clsPtr->instances.list = NULL;

-    clsPtr->instances.size = 0;

-    clsPtr->filters.list = NULL;

-    clsPtr->filters.num = 0;

-    clsPtr->mixins.list = NULL;

-    clsPtr->mixins.num = 0;

-    clsPtr->mixinSubs.list = NULL;

-    clsPtr->mixinSubs.num = 0;

-    clsPtr->mixinSubs.size = 0;

-    clsPtr->classHierarchy.list = NULL;

-    clsPtr->classHierarchy.num = 0;

-    clsPtr->classHierarchyEpoch = fPtr->epoch-1;

-    Tcl_InitObjHashTable(&clsPtr->classMethods);

-    clsPtr->constructorPtr = NULL;

-    clsPtr->destructorPtr = NULL;

-    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 *name,		/* Name of object to create, 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. */

-{

-    Object *oPtr = AllocObject(interp, NULL);

-    CallContext *contextPtr;

-

-    oPtr->selfCls = (Class *) cls;

-    TclOOAddToInstances(oPtr, (Class *) cls);

-

-    if (name != NULL) {

-	Tcl_Obj *cmdnameObj;

-

-	TclNewObj(cmdnameObj);

-	Tcl_GetCommandFullName(interp, oPtr->command, cmdnameObj);

-	if (TclRenameCommand(interp, TclGetString(cmdnameObj),

-		name) != TCL_OK) {

-	    Tcl_ResetResult(interp);

-	    Tcl_AppendResult(interp, "can't create object \"", name,

-		    "\": command already exists with that name", NULL);

-	    TclDecrRefCount(cmdnameObj);

-	    Tcl_DeleteCommandFromToken(interp, oPtr->command);

-	    return NULL;

-	}

-	TclDecrRefCount(cmdnameObj);

-    }

-

-    /*

-     * Check to see if we're really creating a class. If so, allocate the

-     * class structure as well.

-     */

-

-    if (TclOOIsReachable((((Interp *) interp)->ooFoundation)->classCls,

-	    (Class *) cls)) {

-	/*

-	 * Is a class, so attach a class structure. Note that the AllocClass

-	 * function splices the structure into the object, so we don't have

-	 * to.

-	 */

-

-	AllocClass(interp, oPtr);

-	oPtr->selfCls = (Class *) cls; // Repatch

-    }

-

-    if (objc >= 0) {

-	contextPtr = TclOOGetCallContext(((Interp *)interp)->ooFoundation,

-		oPtr, NULL, CONSTRUCTOR, NULL);

-	if (contextPtr != NULL) {

-	    int result;

-	    Tcl_InterpState state;

-

-	    Tcl_Preserve(oPtr);

-	    state = Tcl_SaveInterpState(interp, TCL_OK);

-	    contextPtr->flags |= CONSTRUCTOR;

-	    contextPtr->skip = skip;

-	    result = TclOOInvokeContext(interp, contextPtr, objc, objv);

-	    TclOODeleteContext(contextPtr);

-	    Tcl_Release(oPtr);

-	    if (result != TCL_OK) {

-		Tcl_DiscardInterpState(state);

-		Tcl_DeleteCommandFromToken(interp, oPtr->command);

-		return NULL;

-	    }

-	    (void) Tcl_RestoreInterpState(interp, state);

-	}

-    }

-

-    return (Tcl_Object) oPtr;

-}

-

-/*

- * ----------------------------------------------------------------------

- *

- * Tcl_NewMethod --

- *

- *	Attach a method to an object.

- *

- * ----------------------------------------------------------------------

- */

-

-Tcl_Method

-Tcl_NewMethod(

-    Tcl_Interp *interp,		/* Unused? */

-    Tcl_Object object,		/* The object that has the method attached to

-				 * it. */

-    Tcl_Obj *nameObj,		/* The name of the method. May be NULL; if so,

-				 * up to caller to manage storage (e.g., when

-				 * it is a constructor or destructor). */

-    int isPublic,		/* Whether this is a public method. */

-    const Tcl_MethodType *typePtr,

-				/* The type of method this is, which defines

-				 * how to invoke, delete and clone the

-				 * method. */

-    ClientData clientData)	/* Some data associated with the particular

-				 * method to be created. */

-{

-    register Object *oPtr = (Object *) object;

-    register Method *mPtr;

-    Tcl_HashEntry *hPtr;

-    int isNew;

-

-    if (nameObj == NULL) {

-	mPtr = (Method *) ckalloc(sizeof(Method));

-	mPtr->namePtr = NULL;

-	goto populate;

-    }

-    hPtr = Tcl_CreateHashEntry(&oPtr->methods, (char *) nameObj, &isNew);

-    if (isNew) {

-	mPtr = (Method *) ckalloc(sizeof(Method));

-	mPtr->namePtr = nameObj;

-	Tcl_IncrRefCount(nameObj);

-	Tcl_SetHashValue(hPtr, mPtr);

-    } else {

-	mPtr = Tcl_GetHashValue(hPtr);

-	if (mPtr->typePtr != NULL && mPtr->typePtr->deleteProc != NULL) {

-	    mPtr->typePtr->deleteProc(mPtr->clientData);

-	}

-    }

-

-  populate:

-    mPtr->typePtr = typePtr;

-    mPtr->clientData = clientData;

-    mPtr->flags = 0;

-    mPtr->declaringObjectPtr = oPtr;

-    mPtr->declaringClassPtr = NULL;

-    if (isPublic) {

-	mPtr->flags |= PUBLIC_METHOD;

-    }

-    oPtr->epoch++;

-    return (Tcl_Method) mPtr;

-}

-

-/*

- * ----------------------------------------------------------------------

- *

- * Tcl_NewClassMethod --

- *

- *	Attach a method to a class.

- *

- * ----------------------------------------------------------------------

- */

-

-Tcl_Method

-Tcl_NewClassMethod(

-    Tcl_Interp *interp,		/* The interpreter containing the class. */

-    Tcl_Class cls,		/* The class to attach the method to. */

-    Tcl_Obj *nameObj,		/* The name of the object. May be NULL (e.g.,

-				 * for constructors or destructors); if so, up

-				 * to caller to manage storage. */

-    int isPublic,		/* Whether this is a public method. */

-    const Tcl_MethodType *typePtr,

-				/* The type of method this is, which defines

-				 * how to invoke, delete and clone the

-				 * method. */

-    ClientData clientData)	/* Some data associated with the particular

-				 * method to be created. */

-{

-    register Class *clsPtr = (Class *) cls;

-    register Method *mPtr;

-    Tcl_HashEntry *hPtr;

-    int isNew;

-

-    if (nameObj == NULL) {

-	mPtr = (Method *) ckalloc(sizeof(Method));

-	mPtr->namePtr = NULL;

-	goto populate;

-    }

-    hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, (char *)nameObj,&isNew);

-    if (isNew) {

-	mPtr = (Method *) ckalloc(sizeof(Method));

-	mPtr->namePtr = nameObj;

-	Tcl_IncrRefCount(nameObj);

-	Tcl_SetHashValue(hPtr, mPtr);

-    } else {

-	mPtr = Tcl_GetHashValue(hPtr);

-	if (mPtr->typePtr != NULL && mPtr->typePtr->deleteProc != NULL) {

-	    mPtr->typePtr->deleteProc(mPtr->clientData);

-	}

-    }

-

-  populate:

-    ((Interp *) interp)->ooFoundation->epoch++;

-    mPtr->typePtr = typePtr;

-    mPtr->clientData = clientData;

-    mPtr->flags = 0;

-    mPtr->declaringObjectPtr = NULL;

-    mPtr->declaringClassPtr = clsPtr;

-    if (isPublic) {

-	mPtr->flags |= PUBLIC_METHOD;

-    }

-

-    return (Tcl_Method) mPtr;

-}

-

-/*

- * ----------------------------------------------------------------------

- *

- * DeleteMethodStruct --

- *

- *	Function used when deleting a method. Always called indirectly via

- *	Tcl_EventuallyFree().

- *

- * ----------------------------------------------------------------------

- */

-

-static void

-DeleteMethodStruct(

-    char *buffer)

-{

-    Method *mPtr = (Method *) buffer;

-

-    if (mPtr->typePtr != NULL && mPtr->typePtr->deleteProc != NULL) {

-	mPtr->typePtr->deleteProc(mPtr->clientData);

-    }

-    if (mPtr->namePtr != NULL) {

-	TclDecrRefCount(mPtr->namePtr);

-    }

-

-    ckfree(buffer);

-}

-

-/*

- * ----------------------------------------------------------------------

- *

- * TclOODeleteMethod --

- *

- *	How to delete a method.

- *

- * ----------------------------------------------------------------------

- */

-

-void

-TclOODeleteMethod(

-    Method *mPtr)

-{

-    if (mPtr != NULL) {

-	Tcl_EventuallyFree(mPtr, DeleteMethodStruct);

-    }

-}

-

-/*

- * ----------------------------------------------------------------------

- *

- * DeclareClassMethod --

- *

- *	Helper that makes it cleaner to create very simple methods during

- *	basic system initialization. Not suitable for general use.

- *

- * ----------------------------------------------------------------------

- */

-

-static void

-DeclareClassMethod(

-    Tcl_Interp *interp,

-    Class *clsPtr,		/* Class to attach the method to. */

-    const char *name,		/* Name of the method. */

-    int isPublic,		/* Whether the method is public. */

-    Tcl_MethodCallProc callPtr)

-				/* Method implementation function. */

-{

-    Tcl_Obj *namePtr;

-

-    TclNewStringObj(namePtr, name, strlen(name));

-    Tcl_IncrRefCount(namePtr);

-    Tcl_NewClassMethod(interp, (Tcl_Class) clsPtr, namePtr, isPublic,

-	    &coreMethodType, callPtr);

-    TclDecrRefCount(namePtr);

-}

-

-/*

- * ----------------------------------------------------------------------

- *

- * SimpleInvoke --

- *

- *	How to invoke a simple method.

- *

- * ----------------------------------------------------------------------

- */

-

-static int

-SimpleInvoke(

-    ClientData clientData,	/* Pointer to function that implements the

-				 * method. */

-    Tcl_Interp *interp,

-    Tcl_ObjectContext context,	/* The method calling context. */

-    int objc,			/* Number of arguments. */

-    Tcl_Obj *const *objv)	/* Arguments as actually seen. */

-{

-    Tcl_MethodCallProc callPtr = clientData;

-

-    return (*callPtr)(NULL, interp, context, objc, objv);

-}

-

-/*

- * ----------------------------------------------------------------------

- *

- * TclOONewProcMethod --

- *

- *	Create a new procedure-like method for an object.

- *

- * ----------------------------------------------------------------------

- */

-

-Method *

-TclOONewProcMethod(

-    Tcl_Interp *interp,		/* The interpreter containing the object. */

-    Object *oPtr,		/* The object to modify. */

-    int isPublic,		/* Whether this is a public method. */

-    Tcl_Obj *nameObj,		/* The name of the method, which must not be

-				 * NULL. */

-    Tcl_Obj *argsObj,		/* The formal argument list for the method,

-				 * which must not be NULL. */

-    Tcl_Obj *bodyObj)		/* The body of the method, which must not be

-				 * NULL. */

-{

-    int argsc;

-    Tcl_Obj **argsv;

-    register ProcedureMethod *pmPtr;

-    const char *procName;

-

-    if (Tcl_ListObjGetElements(interp, argsObj, &argsc, &argsv) != TCL_OK) {

-	return NULL;

-    }

-    pmPtr = (ProcedureMethod *) ckalloc(sizeof(ProcedureMethod));

-    procName = TclGetString(nameObj);

-    if (TclCreateProc(interp, NULL, procName, argsObj, bodyObj,

-	    &pmPtr->procPtr) != TCL_OK) {

-	ckfree((char *) pmPtr);

-	return NULL;

-    }

-    return (Method *) Tcl_NewMethod(interp, (Tcl_Object) oPtr, nameObj,

-	    isPublic, &procMethodType, pmPtr);

-}

-

-/*

- * ----------------------------------------------------------------------

- *

- * TclOONewProcClassMethod --

- *

- *	Create a new procedure-like method for a class.

- *

- * ----------------------------------------------------------------------

- */

-

-Method *

-TclOONewProcClassMethod(

-    Tcl_Interp *interp,		/* The interpreter containing the class. */

-    Class *clsPtr,		/* The class to modify. */

-    int isPublic,		/* Whether this is a public method. */

-    Tcl_Obj *nameObj,		/* The name of the method, which may be NULL;

-				 * if so, up to caller to manage storage

-				 * (e.g., because it is a constructor or

-				 * destructor). */

-    Tcl_Obj *argsObj,		/* The formal argument list for the method,

-				 * which may be NULL; if so, it is equivalent

-				 * to an empty list. */

-    Tcl_Obj *bodyObj)		/* The body of the method, which must not be

-				 * NULL. */

-{

-    int argsLen;		/* -1 => delete argsObj before exit */

-    register ProcedureMethod *pmPtr;

-    const char *procName;

-

-    if (argsObj == NULL) {

-	argsLen = -1;

-	TclNewObj(argsObj);

-	Tcl_IncrRefCount(argsObj);

-	procName = "<destructor>";

-    } else if (Tcl_ListObjLength(interp, argsObj, &argsLen) != TCL_OK) {

-	return NULL;

-    } else {

-	procName = (nameObj==NULL ? "<constructor>" : TclGetString(nameObj));

-    }

-    pmPtr = (ProcedureMethod *) ckalloc(sizeof(ProcedureMethod));

-    if (TclCreateProc(interp, NULL, procName, argsObj, bodyObj,

-	    &pmPtr->procPtr) != TCL_OK) {

-	if (argsLen == -1) {

-	    TclDecrRefCount(argsObj);

-	}

-	ckfree((char *) pmPtr);

-	return NULL;

-    }

-    if (argsLen == -1) {

-	TclDecrRefCount(argsObj);

-    }

-    return (Method *) Tcl_NewClassMethod(interp, (Tcl_Class) clsPtr, nameObj,

-	    isPublic, &procMethodType, pmPtr);

-}

-

-/*

- * ----------------------------------------------------------------------

- *

- * InvokeProcedureMethod --

- *

- *	How to invoke a procedure-like method.

- *

- * ----------------------------------------------------------------------

- */

-

-static int

-InvokeProcedureMethod(

-    ClientData clientData,	/* Pointer to some per-method context. */

-    Tcl_Interp *interp,

-    Tcl_ObjectContext context,	/* The method calling context. */

-    int objc,			/* Number of arguments. */

-    Tcl_Obj *const *objv)	/* Arguments as actually seen. */

-{

-    CallContext *contextPtr = (CallContext *) context;

-    ProcedureMethod *pmPtr = (ProcedureMethod *) clientData;

-    int result, flags = FRAME_IS_METHOD, skip = contextPtr->skip;

-    CallFrame *framePtr, **framePtrPtr;

-    Object *oPtr = contextPtr->oPtr;

-    Command cmd;

-    const char *namePtr;

-    Tcl_Obj *nameObj;

-

-    cmd.nsPtr = (Namespace *) oPtr->namespacePtr;

-    pmPtr->procPtr->cmdPtr = &cmd;

-    if (contextPtr->flags & CONSTRUCTOR) {

-	namePtr = "<constructor>";

-	flags |= FRAME_IS_CONSTRUCTOR;

-	nameObj = Tcl_NewStringObj("<constructor>", -1);

-	Tcl_IncrRefCount(nameObj);

-    } else if (contextPtr->flags & DESTRUCTOR) {

-	namePtr = "<destructor>";

-	flags |= FRAME_IS_DESTRUCTOR;

-	nameObj = Tcl_NewStringObj("<destructor>", -1);

-	Tcl_IncrRefCount(nameObj);

-    } else {

-	nameObj = objv[contextPtr->skip-1];

-	namePtr = TclGetString(nameObj);

-    }

-    result = TclProcCompileProc(interp, pmPtr->procPtr,

-	    pmPtr->procPtr->bodyPtr, (Namespace *) oPtr->namespacePtr,

-	    "body of method", namePtr);

-    if (result != TCL_OK) {

-	return result;

-    }

-

-    if (contextPtr->callChain[contextPtr->index].isFilter) {

-	flags |= FRAME_IS_FILTER;

-    }

-    framePtrPtr = &framePtr;

-    result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr,

-	    oPtr->namespacePtr, flags);

-    if (result != TCL_OK) {

-	return result;

-    }

-    framePtr->ooContextPtr = contextPtr;

-    framePtr->objc = objc;

-    framePtr->objv = objv;	/* ref counts for args are incremented below */

-    framePtr->procPtr = pmPtr->procPtr;

-

-    if (contextPtr->flags & OO_UNKNOWN_METHOD) {

-	skip--;

-    }

-    result = TclObjInterpProcCore(interp, framePtr, nameObj, skip);

-    if (contextPtr->flags & (CONSTRUCTOR | DESTRUCTOR)) {

-	TclDecrRefCount(nameObj);

-    }

-    return result;

-}

-

-/*

- * ----------------------------------------------------------------------

- *

- * DeleteProcedureMethod, CloneProcedureMethod --

- *

- *	How to delete and clone procedure-like methods.

- *

- * ----------------------------------------------------------------------

- */

-

-static void

-DeleteProcedureMethod(

-    ClientData clientData)

-{

-    register ProcedureMethod *pmPtr = (ProcedureMethod *) clientData;

-

-    TclProcDeleteProc(pmPtr->procPtr);

-    ckfree((char *) pmPtr);

-}

-

-static int

-CloneProcedureMethod(

-    ClientData clientData,

-    ClientData *newClientData)

-{

-    ProcedureMethod *pmPtr = (ProcedureMethod *) clientData;

-    ProcedureMethod *pm2Ptr = (ProcedureMethod *)

-	    ckalloc(sizeof(ProcedureMethod));

-

-    pm2Ptr->procPtr = pmPtr->procPtr;

-    pm2Ptr->procPtr->refCount++;

-    *newClientData = pm2Ptr;

-    return TCL_OK;

-}

-

-/*

- * ----------------------------------------------------------------------

- *

- * TclOONewForwardMethod --

- *

- *	Create a forwarded method for an object.

- *

- * ----------------------------------------------------------------------

- */

-

-Method *

-TclOONewForwardMethod(

-    Tcl_Interp *interp,		/* Interpreter for error reporting. */

-    Object *oPtr,		/* The object to attach the method to. */

-    int isPublic,		/* Whether the method is public or not. */

-    Tcl_Obj *nameObj,		/* The name of the method. */

-    Tcl_Obj *prefixObj)		/* List of arguments that form the command

-				 * prefix to forward to. */

-{

-    int prefixLen;

-    register ForwardMethod *fmPtr;

-

-    if (Tcl_ListObjLength(interp, prefixObj, &prefixLen) != TCL_OK) {

-	return NULL;

-    }

-    if (prefixLen < 1) {

-	Tcl_AppendResult(interp, "method forward prefix must be non-empty",

-		NULL);

-	return NULL;

-    }

-

-    fmPtr = (ForwardMethod *) ckalloc(sizeof(ForwardMethod));

-    fmPtr->prefixObj = prefixObj;

-    Tcl_IncrRefCount(prefixObj);

-    return (Method *) Tcl_NewMethod(interp, (Tcl_Object) oPtr, nameObj,

-	    isPublic, &fwdMethodType, fmPtr);

-}

-

-/*

- * ----------------------------------------------------------------------

- *

- * TclOONewForwardClassMethod --

- *

- *	Create a new forwarded method for a class.

- *

- * ----------------------------------------------------------------------

- */

-

-Method *

-TclOONewForwardClassMethod(

-    Tcl_Interp *interp,		/* Interpreter for error reporting. */

-    Class *clsPtr,		/* The class to attach the method to. */

-    int isPublic,		/* Whether the method is public or not. */

-    Tcl_Obj *nameObj,		/* The name of the method. */

-    Tcl_Obj *prefixObj)		/* List of arguments that form the command

-				 * prefix to forward to. */

-{

-    int prefixLen;

-    register ForwardMethod *fmPtr;

-

-    if (Tcl_ListObjLength(interp, prefixObj, &prefixLen) != TCL_OK) {

-	return NULL;

-    }

-    if (prefixLen < 1) {

-	Tcl_AppendResult(interp, "method forward prefix must be non-empty",

-		NULL);

-	return NULL;

-    }

-

-    fmPtr = (ForwardMethod *) ckalloc(sizeof(ForwardMethod));

-    fmPtr->prefixObj = prefixObj;

-    Tcl_IncrRefCount(prefixObj);

-    return (Method *) Tcl_NewClassMethod(interp, (Tcl_Class) clsPtr, nameObj,

-	    isPublic, &fwdMethodType, fmPtr);

-}

-

-/*

- * ----------------------------------------------------------------------

- *

- * InvokeForwardMethod --

- *

- *	How to invoke a forwarded method. Works by doing some ensemble-like

- *	command rearranging and then invokes some other Tcl command.

- *

- * ----------------------------------------------------------------------

- */

-

-static int

-InvokeForwardMethod(

-    ClientData clientData,	/* Pointer to some per-method context. */

-    Tcl_Interp *interp,

-    Tcl_ObjectContext context,	/* The method calling context. */

-    int objc,			/* Number of arguments. */

-    Tcl_Obj *const *objv)	/* Arguments as actually seen. */

-{

-    CallContext *contextPtr = (CallContext *) context;

-    ForwardMethod *fmPtr = (ForwardMethod *) clientData;

-    Tcl_Obj **argObjs, **prefixObjs;

-    int numPrefixes, result, len;

-

-    /*

-     * Build the real list of arguments to use. Note that we know that the

-     * prefixObj field of the ForwardMethod structure holds a reference to a

-     * non-empty list, so there's a whole class of failures ("not a list") we

-     * can ignore here.

-     */

-

-    Tcl_ListObjGetElements(NULL, fmPtr->prefixObj, &numPrefixes, &prefixObjs);

-    argObjs = InitEnsembleRewrite(interp, objc, objv, contextPtr->skip,

-	    numPrefixes, prefixObjs, &len);

-

-    result = Tcl_EvalObjv(interp, len, argObjs, TCL_EVAL_INVOKE);

-    ckfree((char *) argObjs);

-    return result;

-}

-

-/*

- * ----------------------------------------------------------------------

- *

- * DeleteForwardMethod, CloneForwardMethod --

- *

- *	How to delete and clone forwarded methods.

- *

- * ----------------------------------------------------------------------

- */

-

-static void

-DeleteForwardMethod(

-    ClientData clientData)

-{

-    ForwardMethod *fmPtr = (ForwardMethod *) clientData;

-

-    TclDecrRefCount(fmPtr->prefixObj);

-    ckfree((char *) fmPtr);

-}

-

-static int

-CloneForwardMethod(

-    ClientData clientData,

-    ClientData *newClientData)

-{

-    ForwardMethod *fmPtr = (ForwardMethod *) clientData;

-    ForwardMethod *fm2Ptr = (ForwardMethod *) ckalloc(sizeof(ForwardMethod));

-

-    fm2Ptr->prefixObj = fmPtr->prefixObj;

-    Tcl_IncrRefCount(fm2Ptr->prefixObj);

-    *newClientData = fm2Ptr;

-    return TCL_OK;

-}

-

-/*

- * ----------------------------------------------------------------------

- *

- * PublicObjectCmd, PrivateObjectCmd, ObjectCmd --

- *

- *	Main entry point for object invokations. The Public* and Private*

- *	wrapper functions are just thin wrappers round the main ObjectCmd

- *	function that does call chain creation, management and invokation.

- *

- * ----------------------------------------------------------------------

- */

-

-static int

-PublicObjectCmd(

-    ClientData clientData,

-    Tcl_Interp *interp,

-    int objc,

-    Tcl_Obj *const *objv)

-{

-    return ObjectCmd(clientData, interp, objc, objv, 1,

-	    &((Object *)clientData)->publicContextCache);

-}

-

-static int

-PrivateObjectCmd(

-    ClientData clientData,

-    Tcl_Interp *interp,

-    int objc,

-    Tcl_Obj *const *objv)

-{

-    return ObjectCmd(clientData, interp, objc, objv, 0,

-	    &((Object *)clientData)->privateContextCache);

-}

-

-static int

-ObjectCmd(

-    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 publicOnly,		/* Whether this is an invokation through the

-				 * public or the private command interface. */

-    Tcl_HashTable *cachePtr)	/* What call chain cache to use. */

-{

-    Interp *iPtr = (Interp *) interp;

-    CallContext *contextPtr;

-    int result;

-

-    if (objc < 2) {

-	Tcl_WrongNumArgs(interp, 1, objv, "method ?arg ...?");

-	return TCL_ERROR;

-    }

-

-    contextPtr = TclOOGetCallContext(iPtr->ooFoundation, oPtr, objv[1],

-	    (publicOnly ? PUBLIC_METHOD :0) | (oPtr->flags & FILTER_HANDLING),

-	    cachePtr);

-    if (contextPtr == NULL) {

-	Tcl_AppendResult(interp, "impossible to invoke method \"",

-		TclGetString(objv[1]),

-		"\": no defined method or unknown method", NULL);

-	return TCL_ERROR;

-    }

-

-    Tcl_Preserve(oPtr);

-    result = TclOOInvokeContext(interp, contextPtr, objc, objv);

-    if (!(contextPtr->flags & OO_UNKNOWN_METHOD)

-	    && !(oPtr->flags & OBJECT_DELETED)) {

-	Tcl_HashEntry *hPtr;

-

-	hPtr = Tcl_FindHashEntry(cachePtr, (char *) objv[1]);

-	if (hPtr != NULL && Tcl_GetHashValue(hPtr) == NULL) {

-	    Tcl_SetHashValue(hPtr, contextPtr);

-	} else {

-	    TclOODeleteContext(contextPtr);

-	}

-    } else {

-	TclOODeleteContext(contextPtr);

-    }

-    Tcl_Release(oPtr);

-

-    return result;

-}

-

-/*

- * ----------------------------------------------------------------------

- *

- * ClassCreate --

- *

- *	Implementation for oo::class->create method.

- *

- * ----------------------------------------------------------------------

- */

-

-static int

-ClassCreate(

-    ClientData clientData,	/* Ignored. */

-    Tcl_Interp *interp,		/* Interpreter in which to create the object;

-				 * also used for error reporting. */

-    Tcl_ObjectContext context,	/* The object/call context. */

-    int objc,			/* Number of arguments. */

-    Tcl_Obj *const *objv)	/* The actual arguments. */

-{

-    Object *oPtr = (Object *) Tcl_ObjectContextObject(context);

-    Tcl_Object newObject;

-    const char *objName;

-    int len;

-

-    /*

-     * Sanity check; should not be possible to invoke this method on a

-     * non-class.

-     */

-

-    if (oPtr->classPtr == NULL) {

-	Tcl_Obj *cmdnameObj;

-

-	TclNewObj(cmdnameObj);

-	Tcl_GetCommandFullName(interp, oPtr->command, cmdnameObj);

-	Tcl_AppendResult(interp, "object \"", TclGetString(cmdnameObj),

-		"\" is not a class", NULL);

-	TclDecrRefCount(cmdnameObj);

-	return TCL_ERROR;

-    }

-

-    /*

-     * Check we have the right number of (sensible) arguments.

-     */

-

-    if (objc - Tcl_ObjectContextSkippedArgs(context) < 1) {

-	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,

-		"objectName ?arg ...?");

-	return TCL_ERROR;

-    }

-    objName = Tcl_GetStringFromObj(

-	    objv[Tcl_ObjectContextSkippedArgs(context)], &len);

-    if (len == 0) {

-	Tcl_AppendResult(interp, "object name must not be empty", NULL);

-	return TCL_ERROR;

-    }

-

-    /*

-     * Make the object and return its name.

-     */

-

-    newObject = Tcl_NewObjectInstance(interp, (Tcl_Class) oPtr->classPtr,

-	    objName, objc, objv, Tcl_ObjectContextSkippedArgs(context)+1);

-    if (newObject == NULL) {

-	return TCL_ERROR;

-    }

-    Tcl_GetCommandFullName(interp, Tcl_GetObjectCommand(newObject),

-	    Tcl_GetObjResult(interp));

-    return TCL_OK;

-}

-

-/*

- * ----------------------------------------------------------------------

- *

- * ClassNew --

- *

- *	Implementation for oo::class->new method.

- *

- * ----------------------------------------------------------------------

- */

-

-static int

-ClassNew(

-    ClientData clientData,	/* Ignored. */

-    Tcl_Interp *interp,		/* Interpreter in which to create the object;

-				 * also used for error reporting. */

-    Tcl_ObjectContext context,	/* The object/call context. */

-    int objc,			/* Number of arguments. */

-    Tcl_Obj *const *objv)	/* The actual arguments. */

-{

-    Object *oPtr = (Object *) Tcl_ObjectContextObject(context);

-    Tcl_Object newObject;

-

-    /*

-     * Sanity check; should not be possible to invoke this method on a

-     * non-class.

-     */

-

-    if (oPtr->classPtr == NULL) {

-	Tcl_Obj *cmdnameObj;

-

-	TclNewObj(cmdnameObj);

-	Tcl_GetCommandFullName(interp, oPtr->command, cmdnameObj);

-	Tcl_AppendResult(interp, "object \"", TclGetString(cmdnameObj),

-		"\" is not a class", NULL);

-	TclDecrRefCount(cmdnameObj);

-	return TCL_ERROR;

-    }

-

-    /*

-     * Make the object and return its name.

-     */

-

-    newObject = Tcl_NewObjectInstance(interp, (Tcl_Class) oPtr->classPtr,

-	    NULL, objc, objv, Tcl_ObjectContextSkippedArgs(context));

-    if (newObject == NULL) {

-	return TCL_ERROR;

-    }

-    Tcl_GetCommandFullName(interp, Tcl_GetObjectCommand(newObject),

-	    Tcl_GetObjResult(interp));

-    return TCL_OK;

-}

-

-/*

- * ----------------------------------------------------------------------

- *

- * ObjectDestroy --

- *

- *	Implementation for oo::object->destroy method.

- *

- * ----------------------------------------------------------------------

- */

-

-static int

-ObjectDestroy(

-    ClientData clientData,	/* Ignored. */

-    Tcl_Interp *interp,		/* Interpreter in which to create the object;

-				 * also used for error reporting. */

-    Tcl_ObjectContext context,	/* The object/call context. */

-    int objc,			/* Number of arguments. */

-    Tcl_Obj *const *objv)	/* The actual arguments. */

-{

-    if (objc != Tcl_ObjectContextSkippedArgs(context)) {

-	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,

-		NULL);

-	return TCL_ERROR;

-    }

-    Tcl_DeleteCommandFromToken(interp,

-	    Tcl_GetObjectCommand(Tcl_ObjectContextObject(context)));

-    return TCL_OK;

-}

-

-/*

- * ----------------------------------------------------------------------

- *

- * ObjectEval --

- *

- *	Implementation for oo::object->eval method.

- *

- * ----------------------------------------------------------------------

- */

-

-static int

-ObjectEval(

-    ClientData clientData,	/* Ignored. */

-    Tcl_Interp *interp,		/* Interpreter in which to create the object;

-				 * also used for error reporting. */

-    Tcl_ObjectContext context,	/* The object/call context. */

-    int objc,			/* Number of arguments. */

-    Tcl_Obj *const *objv)	/* The actual arguments. */

-{

-    CallContext *contextPtr = (CallContext *) context;

-    Tcl_Object object = Tcl_ObjectContextObject(context);

-    CallFrame *framePtr, **framePtrPtr;

-    Tcl_Obj *objnameObj;

-    int result;

-

-    if (objc-1 < Tcl_ObjectContextSkippedArgs(context)) {

-	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,

-		"arg ?arg ...?");

-	return TCL_ERROR;

-    }

-

-    /*

-     * Make the object's namespace the current namespace and evaluate the

-     * command(s).

-     */

-

-    /* This is needed to satisfy GCC 3.3's strict aliasing rules */

-    framePtrPtr = &framePtr;

-    result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr,

-	    Tcl_GetObjectNamespace(object), 0);

-    if (result != TCL_OK) {

-	return TCL_ERROR;

-    }

-    framePtr->objc = objc;

-    framePtr->objv = objv;	/* Reference counts do not need to be

-				 * incremented here. */

-

-    if (contextPtr->flags & PUBLIC_METHOD) {

-	TclNewObj(objnameObj);

-	Tcl_GetCommandFullName(interp, Tcl_GetObjectCommand(object),

-		objnameObj);

-    } else {

-	TclNewStringObj(objnameObj, "my", 2);

-    }

-    Tcl_IncrRefCount(objnameObj);

-

-    if (objc == Tcl_ObjectContextSkippedArgs(context)+1) {

-	result = Tcl_EvalObjEx(interp,

-		objv[Tcl_ObjectContextSkippedArgs(context)], 0);

-    } else {

-	Tcl_Obj *objPtr;

-

-	/*

-	 * More than one argument: concatenate them together with spaces

-	 * between, then evaluate the result. Tcl_EvalObjEx will delete the

-	 * object when it decrements its refcount after eval'ing it.

-	 */

-

-	objPtr = Tcl_ConcatObj(objc-Tcl_ObjectContextSkippedArgs(context),

-		objv+Tcl_ObjectContextSkippedArgs(context));

-	result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT);

-    }

-

-    if (result == TCL_ERROR) {

-	TclFormatToErrorInfo(interp,

-		"\n    (in \"%s eval\" script line %d)",

-		TclGetString(objnameObj), interp->errorLine);

-    }

-

-    /*

-     * Restore the previous "current" namespace.

-     */

-

-    TclPopStackFrame(interp);

-    TclDecrRefCount(objnameObj);

-    return result;

-}

-

-/*

- * ----------------------------------------------------------------------

- *

- * ObjectUnknown --

- *

- *	Default unknown method handler method (defined in oo::object). This

- *	just creates a suitable error message.

- *

- * ----------------------------------------------------------------------

- */

-

-static int

-ObjectUnknown(

-    ClientData clientData,	/* Ignored. */

-    Tcl_Interp *interp,		/* Interpreter in which to create the object;

-				 * also used for error reporting. */

-    Tcl_ObjectContext context,	/* The object/call context. */

-    int objc,			/* Number of arguments. */

-    Tcl_Obj *const *objv)	/* The actual arguments. */

-{

-    CallContext *contextPtr = (CallContext *) context;

-    Object *oPtr = contextPtr->oPtr;

-    const char **methodNames;

-    int numMethodNames, i;

-

-    /*

-     * Get the list of methods that we want to know about.

-     */

-

-    numMethodNames = TclOOGetSortedMethodList(oPtr,

-	    contextPtr->flags & PUBLIC_METHOD, &methodNames);

-

-    /*

-     * Special message when there are no visible methods at all.

-     */

-

-    if (numMethodNames == 0) {

-	Tcl_Obj *tmpBuf;

-

-	TclNewObj(tmpBuf);

-	Tcl_GetCommandFullName(interp, oPtr->command, tmpBuf);

-	Tcl_AppendResult(interp, "object \"", TclGetString(tmpBuf),

-		"\" has no visible methods", NULL);

-	TclDecrRefCount(tmpBuf);

-	return TCL_ERROR;

-    }

-

-    Tcl_AppendResult(interp, "unknown method \"",

-	    TclGetString(objv[Tcl_ObjectContextSkippedArgs(context)-1]),

-	    "\": must be ", NULL);

-    for (i=0 ; i<numMethodNames-1 ; i++) {

-	if (i) {

-	    Tcl_AppendResult(interp, ", ", NULL);

-	}

-	Tcl_AppendResult(interp, methodNames[i], NULL);

-    }

-    if (i) {

-	Tcl_AppendResult(interp, " or ", NULL);

-    }

-    Tcl_AppendResult(interp, methodNames[i], NULL);

-    ckfree((char *) methodNames);

-    return TCL_ERROR;

-}

-

-/*

- * ----------------------------------------------------------------------

- *

- * ObjectLinkVar --

- *

- *	Implementation of oo::object->variable method.

- *

- * ----------------------------------------------------------------------

- */

-

-static int

-ObjectLinkVar(

-    ClientData clientData,	/* Ignored. */

-    Tcl_Interp *interp,		/* Interpreter in which to create the object;

-				 * also used for error reporting. */

-    Tcl_ObjectContext context,	/* The object/call context. */

-    int objc,			/* Number of arguments. */

-    Tcl_Obj *const *objv)	/* The actual arguments. */

-{

-    Interp *iPtr = (Interp *) interp;

-    Tcl_Object object = Tcl_ObjectContextObject(context);

-    Namespace *savedNsPtr;

-    int i;

-

-    if (objc-Tcl_ObjectContextSkippedArgs(context) < 1) {

-	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,

-		"varName ?varName ...?");

-	return TCL_ERROR;

-    }

-

-    /*

-     * Do nothing if we are not called from the body of a method. In this

-     * respect, we are like the [global] command.

-     */

-

-    if (iPtr->varFramePtr == NULL ||

-	    !(iPtr->varFramePtr->isProcCallFrame & FRAME_IS_METHOD)) {

-	return TCL_OK;

-    }

-

-    for (i=Tcl_ObjectContextSkippedArgs(context) ; i<objc ; i++) {

-	Var *varPtr, *aryPtr;

-	Tcl_Obj **argObjs;

-	const char *varName;

-	int len;

-

-	/*

-	 * Parse to see if we have a single value in the argument (just the

-	 * name of a variable to use in both the namespace and local scope) or

-	 * a two-argument list (namespace variable name and local variable

-	 * name). Other cases are an error.

-	 */

-

-	if (Tcl_ListObjGetElements(interp, objv[i], &len, &argObjs)!=TCL_OK) {

-	    return TCL_ERROR;

-	}

-	if (len != 1 && len != 2) {

-	    Tcl_AppendResult(interp, "argument must be list "

-		    "of one or two variable names", NULL);

-	    return TCL_ERROR;

-	}

-

-	varName = TclGetString(argObjs[len-1]);

-	if (strstr(varName, "::") != NULL) {

-	    /*

-	     * The local var name must not contain a '::' but the ns name is

-	     * OK. Naturally, if they're the same, then the restriction is

-	     * applied equally to both.

-	     */

-

-	    Tcl_AppendResult(interp, "variable name \"", varName,

-		    "\" illegal: must not contain namespace separator", NULL);

-	    return TCL_ERROR;

-	}

-

-	/*

-	 * Switch to the object's namespace for the duration of this call.

-	 * Like this, the variable is looked up in the namespace of the

-	 * object, and not in the namespace of the caller. Otherwise this

-	 * would only work if the caller was a method of the object itself,

-	 * which might not be true if the method was exported. This is a bit

-	 * of a hack, but the simplest way to do this (pushing a stack frame

-	 * would be horribly expensive by comparison). We never have to worry

-	 * about the case where we're dealing with the global namespace; we've

-	 * already checked that we are inside a method.

-	 */

-

-	savedNsPtr = iPtr->varFramePtr->nsPtr;

-	iPtr->varFramePtr->nsPtr = (Namespace *)

-		Tcl_GetObjectNamespace(object);

-	varPtr = TclObjLookupVar(interp, argObjs[0], NULL, TCL_NAMESPACE_ONLY,

-		"define", 1, 0, &aryPtr);

-	iPtr->varFramePtr->nsPtr = savedNsPtr;

-

-	if (varPtr == NULL || aryPtr != NULL) {

-	    /*

-	     * Variable cannot be an element in an array. If aryPtr is not

-	     * NULL, it is an element, so throw up an error and return.

-	     */

-

-	    TclVarErrMsg(interp, TclGetString(argObjs[0]), NULL, "define",

-		    "name refers to an element in an array");

-	    return TCL_ERROR;

-	}

-

-	/*

-	 * Arrange for the lifetime of the variable to be correctly managed.

-	 * This is copied out of Tcl_VariableObjCmd...

-	 */

-

-	if (!TclIsVarNamespaceVar(varPtr)) {

-	    TclSetVarNamespaceVar(varPtr);

-	    varPtr->refCount++;

-	}

-

-	if (TclPtrMakeUpvar(interp, varPtr, varName, 0, -1) != TCL_OK) {

-	    return TCL_ERROR;

-	}

-    }

-    return TCL_OK;

-}

-

-/*

- * ----------------------------------------------------------------------

- *

- * ObjectVarName --

- *

- *	Implementation of the oo::object->varname method.

- *

- * ----------------------------------------------------------------------

- */

-

-static int

-ObjectVarName(

-    ClientData clientData,	/* Ignored. */

-    Tcl_Interp *interp,		/* Interpreter in which to create the object;

-				 * also used for error reporting. */

-    Tcl_ObjectContext context,	/* The object/call context. */

-    int objc,			/* Number of arguments. */

-    Tcl_Obj *const *objv)	/* The actual arguments. */

-{

-    Interp *iPtr = (Interp *) interp;

-    Var *varPtr, *aryVar;

-    Tcl_Obj *varNamePtr;

-

-    if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {

-	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,

-		"varName");

-	return TCL_ERROR;

-    }

-

-    /*

-     * Switch to the object's namespace for the duration of this call. Like

-     * this, the variable is looked up in the namespace of the object, and not

-     * in the namespace of the caller. Otherwise this would only work if the

-     * caller was a method of the object itself, which might not be true if

-     * the method was exported. This is a bit of a hack, but the simplest way

-     * to do this (pushing a stack frame would be horribly expensive by

-     * comparison, and is only done when we'd otherwise interfere with the

-     * global namespace).

-     */

-

-    if (iPtr->varFramePtr == NULL) {

-	Tcl_CallFrame *dummyFrame;

-

-	TclPushStackFrame(interp, &dummyFrame,

-		Tcl_GetObjectNamespace(Tcl_ObjectContextObject(context)),0);

-	varPtr = TclObjLookupVar(interp, objv[objc-1], NULL,

-		TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG, "refer to",1,1,&aryVar);

-	TclPopStackFrame(interp);

-    } else {

-	Namespace *savedNsPtr;

-

-	savedNsPtr = iPtr->varFramePtr->nsPtr;

-	iPtr->varFramePtr->nsPtr = (Namespace *)

-		Tcl_GetObjectNamespace(Tcl_ObjectContextObject(context));

-	varPtr = TclObjLookupVar(interp, objv[objc-1], NULL,

-		TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG, "refer to",1,1,&aryVar);

-	iPtr->varFramePtr->nsPtr = savedNsPtr;

-    }

-

-    if (varPtr == NULL) {

-	return TCL_ERROR;

-    }

-

-    TclNewObj(varNamePtr);

-    Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, varNamePtr);

-    Tcl_SetObjResult(interp, varNamePtr);

-    return TCL_OK;

-}

-

-/*

- * ----------------------------------------------------------------------

- *

- * NextObjCmd --

- *

- *	Implementation of the [next] command. Note that this command is only

- *	ever to be used inside the body of a procedure-like method.

- *

- * ----------------------------------------------------------------------

- */

-

-static int

-NextObjCmd(

-    ClientData clientData,

-    Tcl_Interp *interp,

-    int objc,

-    Tcl_Obj *const *objv)

-{

-    Interp *iPtr = (Interp *) interp;

-    CallFrame *framePtr = iPtr->varFramePtr, *savedFramePtr;

-    CallContext *contextPtr;

-    int index, result, skip;

-

-    /*

-     * Start with sanity checks on the calling context and the method context.

-     */

-

-    if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {

-	Tcl_AppendResult(interp, TclGetString(objv[0]),

-		" may only be called from inside a method", NULL);

-	return TCL_ERROR;

-    }

-

-    contextPtr = framePtr->ooContextPtr;

-

-    index = contextPtr->index;

-    skip = contextPtr->skip;

-    if (index+1 >= contextPtr->numCallChain) {

-	Tcl_AppendResult(interp, "no superclass ",

-		(contextPtr->flags & CONSTRUCTOR ? "constructor" :

-		(contextPtr->flags & DESTRUCTOR ? "destructor" : "method")),

-		" implementation", 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 invokations (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. From here on, the skip is always 1.

-     */

-

-    contextPtr->index = index+1;

-    contextPtr->skip = 1;

-

-    /*

-     * Invoke the (advanced) method call context in the caller context. Note

-     * that this is like [uplevel 1] and not [eval].

-     */

-

-    savedFramePtr = iPtr->varFramePtr;

-    iPtr->varFramePtr = savedFramePtr->callerVarPtr;

-    result = TclOOInvokeContext(interp, contextPtr, objc, objv);

-    iPtr->varFramePtr = savedFramePtr;

-

-    /*

-     * Restore the call chain context index as we've finished the inner invoke

-     * and want to operate in the outer context again.

-     */

-

-    contextPtr->index = index;

-    contextPtr->skip = skip;

-

-    return result;

-}

-

-/*

- * ----------------------------------------------------------------------

- *

- * SelfObjCmd --

- *

- *	Implementation of the [self] command, which provides introspection of

- *	the call context.

- *

- * ----------------------------------------------------------------------

- */

-

-static int

-SelfObjCmd(

-    ClientData clientData,

-    Tcl_Interp *interp,

-    int objc,

-    Tcl_Obj *const *objv)

-{

-    static const char *subcmds[] = {

-	"caller", "class", "filter", "method", "namespace", "next", "object",

-	"target", NULL

-    };

-    enum SelfCmds {

-	SELF_CALLER, SELF_CLASS, SELF_FILTER, SELF_METHOD, SELF_NS, SELF_NEXT,

-	SELF_OBJECT, SELF_TARGET

-    };

-    Interp *iPtr = (Interp *) interp;

-    CallFrame *framePtr = iPtr->varFramePtr;

-    CallContext *contextPtr;

-    int index;

-

-    /*

-     * Start with sanity checks on the calling context and the method context.

-     */

-

-    if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {

-	Tcl_AppendResult(interp, TclGetString(objv[0]),

-		" may only be called from inside a method", NULL);

-	return TCL_ERROR;

-    }

-

-    contextPtr = framePtr->ooContextPtr;

-

-    /*

-     * Now we do "conventional" argument parsing for a while. Note that no

-     * subcommand takes arguments.

-     */

-

-    if (objc > 2) {

-	Tcl_WrongNumArgs(interp, 1, objv, "subcommand");

-	return TCL_ERROR;

-    }

-    if (objc == 1) {

-	index = SELF_OBJECT;

-    } else if (Tcl_GetIndexFromObj(interp, objv[1], subcmds, "subcommand", 0,

-	    &index) != TCL_OK) {

-	return TCL_ERROR;

-    }

-

-    switch ((enum SelfCmds) index) {

-    case SELF_OBJECT:

-	Tcl_GetCommandFullName(interp, contextPtr->oPtr->command,

-		Tcl_GetObjResult(interp));

-	return TCL_OK;

-    case SELF_NS:

-	Tcl_SetObjResult(interp, Tcl_NewStringObj(

-		contextPtr->oPtr->namespacePtr->fullName,-1));

-	return TCL_OK;

-    case SELF_CLASS: {

-	Method *mPtr = contextPtr->callChain[contextPtr->index].mPtr;

-	Object *declarerPtr;

-

-	if (mPtr->declaringClassPtr != NULL) {

-	    declarerPtr = mPtr->declaringClassPtr->thisPtr;

-	} else if (mPtr->declaringObjectPtr != NULL) {

-	    declarerPtr = mPtr->declaringObjectPtr;

-	} else {

-	    /*

-	     * This should be unreachable code.

-	     */

-

-	    Tcl_AppendResult(interp, "method without declarer!", NULL);

-	    return TCL_ERROR;

-	}

-

-	Tcl_GetCommandFullName(interp, declarerPtr->command,

-		Tcl_GetObjResult(interp));

-	return TCL_OK;

-    }

-    case SELF_METHOD:

-	if (contextPtr->flags & CONSTRUCTOR) {

-	    Tcl_AppendResult(interp, "<constructor>", NULL);

-	} else if (contextPtr->flags & DESTRUCTOR) {

-	    Tcl_AppendResult(interp, "<destructor>", NULL);

-	} else {

-	    Method *mPtr = contextPtr->callChain[contextPtr->index].mPtr;

-

-	    Tcl_SetObjResult(interp, mPtr->namePtr);

-	}

-	return TCL_OK;

-    case SELF_FILTER:

-	if (!contextPtr->callChain[contextPtr->index].isFilter) {

-	    Tcl_AppendResult(interp, "not inside a filtering context", NULL);

-	    return TCL_ERROR;

-	} else {

-	    Method *mPtr =

-		    contextPtr->callChain[contextPtr->filterLength].mPtr;

-	    Tcl_Obj *cmdName;

-

-	    // TODO: should indicate who has the filter registration, not the

-	    // first non-filter after the filter!

-	    TclNewObj(cmdName);

-	    Tcl_GetCommandFullName(interp, contextPtr->oPtr->command,

-		    cmdName);

-	    Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), cmdName);

-	    // TODO: Add what type of filter this is

-	    Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),

-		    mPtr->namePtr);

-	    return TCL_OK;

-	}

-    case SELF_CALLER:

-	if ((framePtr->callerVarPtr != NULL) &&

-		(framePtr->callerVarPtr->isProcCallFrame & FRAME_IS_METHOD)) {

-	    CallContext *callerPtr = framePtr->callerVarPtr->ooContextPtr;

-	    Method *mPtr = callerPtr->callChain[callerPtr->index].mPtr;

-	    Object *declarerPtr;

-	    Tcl_Obj *tmpObj;

-

-	    if (mPtr->declaringClassPtr != NULL) {

-		declarerPtr = mPtr->declaringClassPtr->thisPtr;

-	    } else if (mPtr->declaringObjectPtr != NULL) {

-		declarerPtr = mPtr->declaringObjectPtr;

-	    } else {

-		/*

-		 * This should be unreachable code.

-		 */

-

-		Tcl_AppendResult(interp, "method without declarer!", NULL);

-		return TCL_ERROR;

-	    }

-

-	    TclNewObj(tmpObj);

-	    Tcl_GetCommandFullName(interp, declarerPtr->command, tmpObj);

-	    Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), tmpObj);

-	    TclNewObj(tmpObj);

-	    Tcl_GetCommandFullName(interp, callerPtr->oPtr->command, tmpObj);

-	    Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), tmpObj);

-	    if (callerPtr->flags & CONSTRUCTOR) {

-		Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),

-			Tcl_NewStringObj("<constructor>", -1));

-	    } else if (callerPtr->flags & DESTRUCTOR) {

-		Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),

-			Tcl_NewStringObj("<destructor>", -1));

-	    } else {

-		Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),

-			mPtr->namePtr);

-	    }

-	    return TCL_OK;

-	} else {

-	    Tcl_AppendResult(interp, "caller is not an object", NULL);

-	    return TCL_ERROR;

-	}

-    case SELF_NEXT:

-	if (contextPtr->index < contextPtr->numCallChain-1) {

-	    Method *mPtr = contextPtr->callChain[contextPtr->index+1].mPtr;

-	    Object *declarerPtr;

-	    Tcl_Obj *tmpObj;

-

-	    if (mPtr->declaringClassPtr != NULL) {

-		declarerPtr = mPtr->declaringClassPtr->thisPtr;

-	    } else if (mPtr->declaringObjectPtr != NULL) {

-		declarerPtr = mPtr->declaringObjectPtr;

-	    } else {

-		/*

-		 * This should be unreachable code.

-		 */

-

-		Tcl_AppendResult(interp, "method without declarer!", NULL);

-		return TCL_ERROR;

-	    }

-

-	    TclNewObj(tmpObj);

-	    Tcl_GetCommandFullName(interp, declarerPtr->command, tmpObj);

-	    Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), tmpObj);

-	    if (contextPtr->flags & CONSTRUCTOR) {

-		Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),

-			Tcl_NewStringObj("<constructor>", -1));

-	    } else if (contextPtr->flags & DESTRUCTOR) {

-		Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),

-			Tcl_NewStringObj("<destructor>", -1));

-	    } else {

-		Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),

-			mPtr->namePtr);

-	    }

-	}

-	return TCL_OK;

-    case SELF_TARGET:

-	if (!contextPtr->callChain[contextPtr->index].isFilter) {

-	    Tcl_AppendResult(interp, "not inside a filtering context", NULL);

-	    return TCL_ERROR;

-	} else {

-	    Method *mPtr;

-	    Object *declarerPtr;

-	    Tcl_Obj *cmdName;

-	    int i;

-

-	    for (i=contextPtr->index ; i<contextPtr->numCallChain ; i++) {

-		if (!contextPtr->callChain[i].isFilter) {

-		    break;

-		}

-	    }

-	    if (i == contextPtr->numCallChain) {

-		Tcl_Panic("filtering call chain without terminal non-filter");

-	    }

-	    mPtr = contextPtr->callChain[i].mPtr;

-	    if (mPtr->declaringClassPtr != NULL) {

-		declarerPtr = mPtr->declaringClassPtr->thisPtr;

-	    } else if (mPtr->declaringObjectPtr != NULL) {

-		declarerPtr = mPtr->declaringObjectPtr;

-	    } else {

-		/*

-		 * This should be unreachable code.

-		 */

-

-		Tcl_AppendResult(interp, "method without declarer!", NULL);

-		return TCL_ERROR;

-	    }

-	    TclNewObj(cmdName);

-	    Tcl_GetCommandFullName(interp, declarerPtr->command, cmdName);

-	    Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), cmdName);

-	    Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),

-		    mPtr->namePtr);

-	    return TCL_OK;

-	}

-    }

-    return TCL_ERROR;

-}

-

-/*

- * ----------------------------------------------------------------------

- *

- * Tcl_GetObjectFromObj --

- *

- *	Utility function to get an object from a Tcl_Obj containing its name.

- *

- * ----------------------------------------------------------------------

- */

-

-Tcl_Object

-Tcl_GetObjectFromObj(

-    Tcl_Interp *interp,

-    Tcl_Obj *objPtr)

-{

-    Command *cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objPtr);

-

-    if (cmdPtr == NULL || cmdPtr->objProc != PublicObjectCmd) {

-	Tcl_AppendResult(interp, TclGetString(objPtr),

-		" does not refer to an object", NULL);

-	return NULL;

-    }

-    return cmdPtr->objClientData;

-}

-

-/*

- * ----------------------------------------------------------------------

- *

- * 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 = startPtr->superclasses.list[0];

-	goto tailRecurse;

-    }

-    FOREACH(superPtr, startPtr->superclasses) {

-	if (TclOOIsReachable(targetPtr, superPtr)) {

-	    return 1;

-	}

-    }

-    return 0;

-}

-

-/*

- * ----------------------------------------------------------------------

- *

- * TclOOGetProcFromMethod, TclOOGetFwdFromMethod --

- *

- *	Utility functions used for procedure-like and forwarding method

- *	introspection.

- *

- * ----------------------------------------------------------------------

- */

-

-Proc *

-TclOOGetProcFromMethod(

-    Method *mPtr)

-{

-    if (mPtr->typePtr == &procMethodType) {

-	ProcedureMethod *pmPtr = mPtr->clientData;

-

-	return pmPtr->procPtr;

-    }

-    return NULL;

-}

-

-Tcl_Obj *

-TclOOGetFwdFromMethod(

-    Method *mPtr)

-{

-    if (mPtr->typePtr == &fwdMethodType) {

-	ForwardMethod *fwPtr = mPtr->clientData;

-

-	return fwPtr->prefixObj;

-    }

-    return NULL;

-}

-

-/*

- * ----------------------------------------------------------------------

- *

- * InitEnsembleRewrite --

- *

- *	Utility function that wraps up a lot of the complexity involved in

- *	doing ensemble-like command forwarding. Here is a picture of memory

- *	management plan:

- *

- *                    <-----------------objc---------------------->

- *      objv:        |=============|===============================|

- *                    <-toRewrite->           |

- *                                             \

- *                    <-rewriteLength->         \

- *      rewriteObjs: |=================|         \

- *                           |                    |

- *                           V                    V

- *      argObjs:     |=================|===============================|

- *                    <------------------*lengthPtr------------------->

- *

- * ----------------------------------------------------------------------

- */

-

-static Tcl_Obj **

-InitEnsembleRewrite(

-    Tcl_Interp *interp,		/* Place to log the rewrite info. */

-    int objc,			/* Number of real arguments. */

-    Tcl_Obj *const *objv,	/* The real arguments. */

-    int toRewrite,		/* Number of real arguments to replace. */

-    int rewriteLength,		/* Number of arguments to insert instead. */

-    Tcl_Obj *const *rewriteObjs,/* Arguments to insert instead. */

-    int *lengthPtr)		/* Where to write the resulting length of the

-				 * array of rewritten arguments. */

-{

-    Interp *iPtr = (Interp *) interp;

-    int isRootEnsemble = (iPtr->ensembleRewrite.sourceObjs == NULL);

-    Tcl_Obj **argObjs;

-    unsigned len = rewriteLength + objc - toRewrite;

-

-    argObjs = (Tcl_Obj **) ckalloc(sizeof(Tcl_Obj *) * len);

-    memcpy(argObjs, rewriteObjs, rewriteLength * sizeof(Tcl_Obj *));

-    memcpy(argObjs + rewriteLength, objv + toRewrite,

-	    sizeof(Tcl_Obj *) * (objc - toRewrite));

-

-    /*

-     * Now plumb this into the core ensemble rewrite logging system so that

-     * Tcl_WrongNumArgs() can rewrite its result appropriately. The rules for

-     * how to store the rewrite rules get complex solely because of the case

-     * where an ensemble rewrites itself out of the picture; when that

-     * happens, the quality of the error message rewrite falls drastically

-     * (and unavoidably).

-     */

-

-    if (isRootEnsemble) {

-	iPtr->ensembleRewrite.sourceObjs = objv;

-	iPtr->ensembleRewrite.numRemovedObjs = toRewrite;

-	iPtr->ensembleRewrite.numInsertedObjs = rewriteLength;

-    } else {

-	int numIns = iPtr->ensembleRewrite.numInsertedObjs;

-

-	if (numIns < toRewrite) {

-	    iPtr->ensembleRewrite.numRemovedObjs += toRewrite - numIns;

-	    iPtr->ensembleRewrite.numInsertedObjs += rewriteLength - 1;

-	} else {

-	    iPtr->ensembleRewrite.numInsertedObjs +=

-		    rewriteLength - toRewrite;

-	}

-    }

-

-    *lengthPtr = len;

-    return argObjs;

-}

-

-Tcl_Method

-Tcl_ObjectContextMethod(

-    Tcl_ObjectContext context)

-{

-    CallContext *contextPtr = (CallContext *) context;

-    return (Tcl_Method) contextPtr->callChain[contextPtr->index].mPtr;

-}

-

-int

-Tcl_ObjectContextIsFiltering(

-    Tcl_ObjectContext context)

-{

-    CallContext *contextPtr = (CallContext *) context;

-    return contextPtr->callChain[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_Object

-Tcl_MethodDeclarerObject(

-    Tcl_Method method)

-{

-    return (Tcl_Object) ((Method *) method)->declaringObjectPtr;

-}

-

-Tcl_Class

-Tcl_MethodDeclarerClass(

-    Tcl_Method method)

-{

-    return (Tcl_Class) ((Method *) method)->declaringClassPtr;

-}

-

-Tcl_Obj *

-Tcl_MethodName(

-    Tcl_Method method)

-{

-    return ((Method *) method)->namePtr;

-}

-

-int

-Tcl_MethodIsType(

-    Tcl_Method method,

-    const Tcl_MethodType *typePtr,

-    ClientData *clientDataPtr)

-{

-    Method *mPtr = (Method *) method;

-

-    if (mPtr->typePtr == typePtr) {

-	if (clientDataPtr != NULL) {

-	    *clientDataPtr = mPtr->clientData;

-	}

-	return 1;

-    }

-    return 0;

-}

-

-int

-Tcl_MethodIsPublic(

-    Tcl_Method method)

-{

-    return (((Method *)method)->flags & PUBLIC_METHOD) ? 1 : 0;

-}

-

-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)->flags & OBJECT_DELETED) ? 1 : 0;

-}

-

-Tcl_Object

-Tcl_GetClassAsObject(

-    Tcl_Class clazz)

-{

-    return (Tcl_Object) ((Class *)clazz)->thisPtr;

-}

-

-/*

- * Local Variables:

- * mode: c

- * c-basic-offset: 4

- * fill-column: 78

- * End:

- */

+/*
+ * tclOO.c --
+ *
+ *	This file contains the object-system core (NB: not Tcl_Obj, but ::oo)
+ *
+ * Copyright (c) 2005-2006 by Donal K. Fellows
+ *
+ * See the file "license.terms" for information on usage and redistribution of
+ * this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * RCS: @(#) $Id: tclOO.c,v 1.1.2.60 2006/10/11 02:01:16 dgp Exp $
+ */
+
+#include "tclInt.h"
+#include "tclOO.h"
+
+/*
+ * Commands in oo::define.
+ */
+
+static const struct {
+    const char *name;
+    Tcl_ObjCmdProc *objProc;
+    int flag;
+} defineCmds[] = {
+    {"constructor", TclOODefineConstructorObjCmd, 0},
+    {"copy", TclOODefineCopyObjCmd, 0},
+    {"destructor", TclOODefineDestructorObjCmd, 0},
+    {"export", TclOODefineExportObjCmd, 0},
+    {"self.export", TclOODefineExportObjCmd, 1},
+    {"filter", TclOODefineFilterObjCmd, 0},
+    {"self.filter", TclOODefineFilterObjCmd, 1},
+    {"forward", TclOODefineForwardObjCmd, 0},
+    {"self.forward", TclOODefineForwardObjCmd, 1},
+    {"method", TclOODefineMethodObjCmd, 0},
+    {"self.method", TclOODefineMethodObjCmd, 1},
+    {"mixin", TclOODefineMixinObjCmd, 0},
+    {"self.mixin", TclOODefineMixinObjCmd, 1},
+#ifdef SUPPORT_OO_PARAMETERS
+    {"parameter", TclOODefineParameterObjCmd, 0},
+#endif
+    {"superclass", TclOODefineSuperclassObjCmd, 0},
+    {"unexport", TclOODefineUnexportObjCmd, 0},
+    {"self.unexport", TclOODefineUnexportObjCmd, 1},
+    {"self.class", TclOODefineSelfClassObjCmd, 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 Class *		AllocClass(Tcl_Interp *interp, Object *useThisObj);
+static Object *		AllocObject(Tcl_Interp *interp, const char *nameStr);
+static void		DeclareClassMethod(Tcl_Interp *interp, Class *clsPtr,
+			    const char *name, int isPublic,
+			    Tcl_MethodCallProc callProc);
+static void		KillFoundation(ClientData clientData,
+			    Tcl_Interp *interp);
+static int		ObjectCmd(Object *oPtr, Tcl_Interp *interp, int objc,
+			    Tcl_Obj *const *objv, int publicOnly,
+			    Tcl_HashTable *cachePtr);
+static void		ObjectNamespaceDeleted(ClientData clientData);
+static void		ObjectDeletedTrace(ClientData clientData,
+			    Tcl_Interp *interp, const char *oldName,
+			    const char *newName, int flags);
+static void		ReleaseClassContents(Tcl_Interp *interp,Object *oPtr);
+
+static int		PublicObjectCmd(ClientData clientData,
+			    Tcl_Interp *interp, int objc,
+			    Tcl_Obj *const *objv);
+static int		PrivateObjectCmd(ClientData clientData,
+			    Tcl_Interp *interp, int objc,
+			    Tcl_Obj *const *objv);
+
+static int		SimpleInvoke(ClientData clientData,
+			    Tcl_Interp *interp, Tcl_ObjectContext context,
+			    int objc, Tcl_Obj *const *objv);
+static int		InvokeProcedureMethod(ClientData clientData,
+			    Tcl_Interp *interp, Tcl_ObjectContext context,
+			    int objc, Tcl_Obj *const *objv);
+static void		DeleteProcedureMethod(ClientData clientData);
+static int		CloneProcedureMethod(ClientData clientData,
+			    ClientData *newClientData);
+static int		InvokeForwardMethod(ClientData clientData,
+			    Tcl_Interp *interp, Tcl_ObjectContext context,
+			    int objc, Tcl_Obj *const *objv);
+static void		DeleteForwardMethod(ClientData clientData);
+static int		CloneForwardMethod(ClientData clientData,
+			    ClientData *newClientData);
+static Tcl_Obj **	InitEnsembleRewrite(Tcl_Interp *interp, int objc,
+			    Tcl_Obj *const *objv, int toRewrite,
+			    int rewriteLength, Tcl_Obj *const *rewriteObjs,
+			    int *lengthPtr);
+
+static int		ClassCreate(ClientData clientData, Tcl_Interp *interp,
+			    Tcl_ObjectContext context, int objc,
+			    Tcl_Obj *const *objv);
+static int		ClassNew(ClientData clientData, Tcl_Interp *interp,
+			    Tcl_ObjectContext context, int objc,
+			    Tcl_Obj *const *objv);
+static int		ObjectDestroy(ClientData clientData,
+			    Tcl_Interp *interp, Tcl_ObjectContext context,
+			    int objc, Tcl_Obj *const *objv);
+static int		ObjectEval(ClientData clientData, Tcl_Interp *interp,
+			    Tcl_ObjectContext context, int objc,
+			    Tcl_Obj *const *objv);
+static int		ObjectLinkVar(ClientData clientData,
+			    Tcl_Interp *interp, Tcl_ObjectContext context,
+			    int objc, Tcl_Obj *const *objv);
+static int		ObjectUnknown(ClientData clientData,
+			    Tcl_Interp *interp, Tcl_ObjectContext context,
+			    int objc, Tcl_Obj *const *objv);
+static int		ObjectVarName(ClientData clientData,
+			    Tcl_Interp *interp, Tcl_ObjectContext context,
+			    int objc, Tcl_Obj *const *objv);
+
+static int		NextObjCmd(ClientData clientData, Tcl_Interp *interp,
+			    int objc, Tcl_Obj *const *objv);
+static int		SelfObjCmd(ClientData clientData, Tcl_Interp *interp,
+			    int objc, Tcl_Obj *const *objv);
+
+/*
+ * The types of methods defined by the core OO system.
+ */
+
+static const Tcl_MethodType procMethodType = {
+    TCL_OO_METHOD_VERSION_CURRENT, "procedural method",
+    InvokeProcedureMethod, DeleteProcedureMethod, CloneProcedureMethod
+};
+static const Tcl_MethodType fwdMethodType = {
+    TCL_OO_METHOD_VERSION_CURRENT, "forward",
+    InvokeForwardMethod, DeleteForwardMethod, CloneForwardMethod
+};
+static const Tcl_MethodType coreMethodType = {
+    TCL_OO_METHOD_VERSION_CURRENT, "core method",
+    SimpleInvoke, NULL, 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. */
+{
+    Interp *iPtr = (Interp *) interp;
+    Foundation *fPtr;
+    int i;
+    Tcl_DString buffer;
+
+    /*
+     * Construct the foundation of the object system. This is a structure
+     * holding references to the magical bits that need to be known about in
+     * other places.
+     */
+
+    fPtr = iPtr->ooFoundation = (Foundation *) ckalloc(sizeof(Foundation));
+    memset(fPtr, 0, sizeof(Foundation));
+    fPtr->ooNs = Tcl_CreateNamespace(interp, "::oo", fPtr, NULL);
+    Tcl_Export(interp, fPtr->ooNs, "[a-z]*", 1);
+    fPtr->defineNs = Tcl_CreateNamespace(interp, "::oo::define", NULL, NULL);
+    fPtr->helpersNs = Tcl_CreateNamespace(interp, "::oo::Helpers", NULL,
+	    NULL);
+    Tcl_CreateObjCommand(interp, "::oo::Helpers::next", NextObjCmd, NULL,
+	    NULL);
+    Tcl_CreateObjCommand(interp, "::oo::Helpers::self", SelfObjCmd, NULL,
+	    NULL);
+    Tcl_CreateObjCommand(interp, "::oo::define", TclOODefineObjCmd, NULL,
+	    NULL);
+    Tcl_DStringInit(&buffer);
+    for (i=0 ; defineCmds[i].name ; i++) {
+	Tcl_DStringAppend(&buffer, "::oo::define::", 14);
+	Tcl_DStringAppend(&buffer, defineCmds[i].name, -1);
+	Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer),
+		defineCmds[i].objProc, (void *) defineCmds[i].flag, NULL);
+	Tcl_DStringFree(&buffer);
+    }
+    fPtr->epoch = 0;
+    fPtr->nsCount = 0;
+    fPtr->unknownMethodNameObj = Tcl_NewStringObj("unknown", -1);
+    Tcl_IncrRefCount(fPtr->unknownMethodNameObj);
+
+    Tcl_CallWhenDeleted(interp, KillFoundation, fPtr);
+
+    /*
+     * Create the objects at the core of the object system. These need to be
+     * spliced manually.
+     */
+
+    fPtr->objectCls = AllocClass(interp, AllocObject(interp, "::oo::object"));
+    fPtr->classCls = AllocClass(interp, AllocObject(interp, "::oo::class"));
+    fPtr->objectCls->thisPtr->selfCls = fPtr->classCls;
+    fPtr->objectCls->thisPtr->flags |= ROOT_OBJECT;
+    fPtr->objectCls->superclasses.num = 0;
+    ckfree((char *) fPtr->objectCls->superclasses.list);
+    fPtr->objectCls->superclasses.list = NULL;
+    fPtr->classCls->thisPtr->selfCls = fPtr->classCls;
+    TclOOAddToInstances(fPtr->objectCls->thisPtr, fPtr->classCls);
+    TclOOAddToInstances(fPtr->classCls->thisPtr, fPtr->classCls);
+
+    /*
+     * Basic method declarations for the core classes.
+     */
+
+    DeclareClassMethod(interp, fPtr->objectCls, "destroy", 1, ObjectDestroy);
+    DeclareClassMethod(interp, fPtr->objectCls, "eval", 0, ObjectEval);
+    DeclareClassMethod(interp, fPtr->objectCls, "unknown", 0, ObjectUnknown);
+    DeclareClassMethod(interp, fPtr->objectCls, "variable", 0, ObjectLinkVar);
+    DeclareClassMethod(interp, fPtr->objectCls, "varname", 0, ObjectVarName);
+    DeclareClassMethod(interp, fPtr->classCls, "create", 1, ClassCreate);
+    DeclareClassMethod(interp, fPtr->classCls, "new", 1, ClassNew);
+
+    /*
+     * Finish setting up the class of classes.
+     */
+
+    {
+	Tcl_Obj *namePtr, *argsPtr, *bodyPtr;
+
+	/*
+	 * Mark the 'new' method in oo::class as private; classes, unlike
+	 * general objects, must have explicit names.
+	 */
+
+	namePtr = Tcl_NewStringObj("new", -1);
+	Tcl_NewMethod(interp, (Tcl_Object) fPtr->classCls->thisPtr, namePtr,
+		0 /* ==private */, NULL, NULL);
+
+	argsPtr = Tcl_NewStringObj("{definitionScript {}}", -1);
+	bodyPtr = Tcl_NewStringObj(
+		"if {[catch {define [self] $definitionScript} msg opt]} {\n"
+		"set ei [split [dict get $opt -errorinfo] \\n]\n"
+		"dict set opt -errorinfo [join [lrange $ei 0 end-2] \\n]\n"
+		"dict set opt -errorline 0xdeadbeef\n"
+		"}\n"
+		"return -options $opt $msg", -1);
+	fPtr->classCls->constructorPtr = TclOONewProcClassMethod(interp,
+		fPtr->classCls, 0, NULL, argsPtr, bodyPtr);
+    }
+
+    return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * KillFoundation --
+ *
+ *	Delete those parts of the OO core that are not deleted automatically
+ *	when the objects and classes themselves are destroyed.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+KillFoundation(
+    ClientData clientData,	/* Pointer to the OO system foundation
+				 * structure. */
+    Tcl_Interp *interp)		/* The interpreter containing the OO system
+				 * foundation. */
+{
+    Foundation *fPtr = clientData;
+
+    TclDecrRefCount(fPtr->unknownMethodNameObj);
+    ckfree((char *) fPtr);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * AllocObject --
+ *
+ *	Allocate an object of basic type. Does not splice the object into its
+ *	class's instance list.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+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. */
+{
+    Foundation *fPtr = ((Interp *) interp)->ooFoundation;
+    Tcl_Obj *cmdnameObj;
+    Tcl_DString buffer;
+    Object *oPtr;
+
+    oPtr = (Object *) ckalloc(sizeof(Object));
+    memset(oPtr, 0, sizeof(Object));
+    while (1) {
+	char objName[10 + TCL_INTEGER_SPACE];
+
+	sprintf(objName, "::oo::Obj%d", ++fPtr->nsCount);
+	oPtr->namespacePtr = Tcl_CreateNamespace(interp, objName, oPtr,
+		ObjectNamespaceDeleted);
+	if (oPtr->namespacePtr != NULL) {
+	    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);
+    }
+    TclSetNsPath((Namespace *) oPtr->namespacePtr, 1, &fPtr->helpersNs);
+    oPtr->selfCls = fPtr->objectCls;
+    Tcl_InitObjHashTable(&oPtr->methods);
+    Tcl_InitObjHashTable(&oPtr->publicContextCache);
+    Tcl_InitObjHashTable(&oPtr->privateContextCache);
+    oPtr->filters.num = 0;
+    oPtr->filters.list = NULL;
+    oPtr->mixins.num = 0;
+    oPtr->mixins.list = NULL;
+    oPtr->classPtr = NULL;
+    oPtr->flags = 0;
+
+    /*
+     * Initialize the traces.
+     */
+
+    Tcl_DStringInit(&buffer);
+    if (nameStr) {
+	if (nameStr[0] != ':' || nameStr[1] != ':') {
+	    Tcl_DStringAppend(&buffer,
+		    Tcl_GetCurrentNamespace(interp)->fullName, -1);
+	    Tcl_DStringAppend(&buffer, "::", 2);
+	}
+	Tcl_DStringAppend(&buffer, nameStr, -1);
+    } else {
+	Tcl_DStringAppend(&buffer, oPtr->namespacePtr->fullName, -1);
+    }
+    oPtr->command = Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer),
+	    PublicObjectCmd, oPtr, NULL);
+    if (nameStr) {
+	Tcl_DStringFree(&buffer);
+	Tcl_DStringAppend(&buffer, oPtr->namespacePtr->fullName, -1);
+    }
+    Tcl_DStringAppend(&buffer, "::my", 4);
+    oPtr->myCommand = Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer),
+	    PrivateObjectCmd, oPtr, NULL);
+    Tcl_DStringFree(&buffer);
+
+    TclNewObj(cmdnameObj);
+    Tcl_GetCommandFullName(interp, oPtr->command, cmdnameObj);
+    Tcl_TraceCommand(interp, TclGetString(cmdnameObj),
+	    TCL_TRACE_DELETE, ObjectDeletedTrace, oPtr);
+    TclDecrRefCount(cmdnameObj);
+
+    return oPtr;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * ObjectDeletedTrace --
+ *
+ *	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
+ObjectDeletedTrace(
+    ClientData clientData,	/* The object being deleted. */
+    Tcl_Interp *interp,		/* The interpreter containing the object. */
+    const char *oldName,	/* What the object was (last) called. */
+    const char *newName,	/* Always NULL. */
+    int flags)			/* Why was the object deleted? */
+{
+    Interp *iPtr = (Interp *) interp;
+    Object *oPtr = clientData;
+    Class *clsPtr;
+
+    Tcl_Preserve(oPtr);
+    oPtr->flags |= OBJECT_DELETED;
+    if (!Tcl_InterpDeleted(interp)) {
+	CallContext *contextPtr = TclOOGetCallContext(iPtr->ooFoundation,
+		oPtr, NULL, DESTRUCTOR, NULL);
+
+	if (contextPtr != NULL) {
+	    int result;
+	    Tcl_InterpState state;
+
+	    contextPtr->flags |= DESTRUCTOR;
+	    contextPtr->skip = 0;
+	    state = Tcl_SaveInterpState(interp, TCL_OK);
+	    result = TclOOInvokeContext(interp, contextPtr, 0, NULL);
+	    if (result != TCL_OK) {
+		Tcl_BackgroundError(interp);
+	    }
+	    (void) Tcl_RestoreInterpState(interp, state);
+	    TclOODeleteContext(contextPtr);
+	}
+    }
+
+    clsPtr = oPtr->classPtr;
+    if (clsPtr != NULL) {
+	ReleaseClassContents(interp, oPtr);
+    }
+
+    Tcl_DeleteNamespace(oPtr->namespacePtr);
+    if (clsPtr) {
+	Tcl_Release(clsPtr);
+    }
+    Tcl_Release(oPtr);
+
+    /*
+     * What else to do to delete an object?
+     */
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * ReleaseClassContents --
+ *
+ *	Tear down the special class data structure, including deleting all
+ *	dependent classes and objects.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+ReleaseClassContents(
+    Tcl_Interp *interp,		/* The interpreter containing the class. */
+    Object *oPtr)		/* The object representing the class. */
+{
+    int i, n;
+    Class *clsPtr, **list;
+    Object **insts;
+
+    clsPtr = oPtr->classPtr;
+    Tcl_Preserve(clsPtr);
+
+    /*
+     * Must empty list before processing the members of the list so that
+     * things happen in the correct order even if something tries to play
+     * fast-and-loose.
+     */
+
+    list = clsPtr->mixinSubs.list;
+    n = clsPtr->mixinSubs.num;
+    clsPtr->mixinSubs.list = NULL;
+    clsPtr->mixinSubs.num = 0;
+    clsPtr->mixinSubs.size = 0;
+    for (i=0 ; i<n ; i++) {
+	Tcl_Preserve(list[i]);
+    }
+    for (i=0 ; i<n ; i++) {
+	if (!(list[i]->flags & OBJECT_DELETED) && interp != NULL) {
+	    Tcl_DeleteCommandFromToken(interp, list[i]->thisPtr->command);
+	}
+	Tcl_Release(list[i]);
+    }
+    if (list != NULL) {
+	ckfree((char *) list);
+    }
+
+    list = clsPtr->subclasses.list;
+    n = clsPtr->subclasses.num;
+    clsPtr->subclasses.list = NULL;
+    clsPtr->subclasses.num = 0;
+    clsPtr->subclasses.size = 0;
+    for (i=0 ; i<n ; i++) {
+	Tcl_Preserve(list[i]);
+    }
+    for (i=0 ; i<n ; i++) {
+	if (!(list[i]->flags & OBJECT_DELETED) && interp != NULL) {
+	    Tcl_DeleteCommandFromToken(interp, list[i]->thisPtr->command);
+	}
+	Tcl_Release(list[i]);
+    }
+    if (list != NULL) {
+	ckfree((char *) list);
+    }
+
+    insts = clsPtr->instances.list;
+    n = clsPtr->instances.num;
+    clsPtr->instances.list = NULL;
+    clsPtr->instances.num = 0;
+    clsPtr->instances.size = 0;
+    for (i=0 ; i<n ; i++) {
+	Tcl_Preserve(insts[i]);
+    }
+    for (i=0 ; i<n ; i++) {
+	if (!(insts[i]->flags & OBJECT_DELETED) && interp != NULL) {
+	    Tcl_DeleteCommandFromToken(interp, insts[i]->command);
+	}
+	Tcl_Release(insts[i]);
+    }
+    if (insts != NULL) {
+	ckfree((char *) insts);
+    }
+
+    if (clsPtr->filters.num) {
+	Tcl_Obj *filterObj;
+
+	FOREACH(filterObj, clsPtr->filters) {
+	    TclDecrRefCount(filterObj);
+	}
+	ckfree((char *) clsPtr->filters.list);
+	clsPtr->filters.num = 0;
+    }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * 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 = clientData;
+    FOREACH_HASH_DECLS;
+    Class *clsPtr, *mixinPtr;
+    CallContext *contextPtr;
+    Method *mPtr;
+    Tcl_Obj *filterObj;
+    int i;
+
+    /*
+     * Instruct everyone to no longer use any allocated fields of the object.
+     */
+
+    if (!(oPtr->flags & OBJECT_DELETED)) {
+	Tcl_Preserve(oPtr);
+	if (oPtr->classPtr != NULL) {
+	    ReleaseClassContents(NULL, oPtr);
+	}
+    }
+    oPtr->flags |= OBJECT_DELETED;
+
+    /*
+     * Splice the object out of its context. After this, we must *not* call
+     * methods on the object.
+     */
+
+    if (!(oPtr->flags & ROOT_OBJECT)) {
+	TclOORemoveFromInstances(oPtr, oPtr->selfCls);
+    }
+    FOREACH(mixinPtr, oPtr->mixins) {
+	TclOORemoveFromInstances(oPtr, mixinPtr);
+    }
+    if (i) {
+	ckfree((char *)oPtr->mixins.list);
+    }
+    FOREACH(filterObj, oPtr->filters) {
+	TclDecrRefCount(filterObj);
+    }
+    if (i) {
+	ckfree((char *)oPtr->filters.list);
+    }
+    FOREACH_HASH_VALUE(mPtr, &oPtr->methods) {
+	TclOODeleteMethod(mPtr);
+    }
+    Tcl_DeleteHashTable(&oPtr->methods);
+    FOREACH_HASH_VALUE(contextPtr, &oPtr->publicContextCache) {
+	if (contextPtr) {
+	    TclOODeleteContext(contextPtr);
+	}
+    }
+    Tcl_DeleteHashTable(&oPtr->publicContextCache);
+    FOREACH_HASH_VALUE(contextPtr, &oPtr->privateContextCache) {
+	if (contextPtr) {
+	    TclOODeleteContext(contextPtr);
+	}
+    }
+    Tcl_DeleteHashTable(&oPtr->privateContextCache);
+
+    clsPtr = oPtr->classPtr;
+    if (clsPtr != NULL && !(oPtr->flags & ROOT_OBJECT)) {
+	Class *superPtr, *mixinPtr;
+
+	clsPtr->flags |= OBJECT_DELETED;
+	FOREACH(mixinPtr, clsPtr->mixins) {
+	    if (!(mixinPtr->flags & OBJECT_DELETED)) {
+		TclOORemoveFromSubclasses(clsPtr, mixinPtr);
+	    }
+	}
+	if (i) {
+	    ckfree((char *) clsPtr->mixins.list);
+	    clsPtr->mixins.num = 0;
+	}
+	FOREACH(superPtr, clsPtr->superclasses) {
+	    if (!(superPtr->flags & OBJECT_DELETED)) {
+		TclOORemoveFromSubclasses(clsPtr, superPtr);
+	    }
+	}
+	if (i) {
+	    ckfree((char *) clsPtr->superclasses.list);
+	    clsPtr->superclasses.num = 0;
+	}
+	if (clsPtr->subclasses.list) {
+	    ckfree((char *) clsPtr->subclasses.list);
+	    clsPtr->subclasses.num = 0;
+	}
+	if (clsPtr->instances.list) {
+	    ckfree((char *) clsPtr->instances.list);
+	    clsPtr->instances.num = 0;
+	}
+	if (clsPtr->mixinSubs.list) {
+	    ckfree((char *) clsPtr->mixinSubs.list);
+	    clsPtr->mixinSubs.num = 0;
+	}
+	if (clsPtr->classHierarchy.list) {
+	    ckfree((char *) clsPtr->classHierarchy.list);
+	    clsPtr->classHierarchy.num = 0;
+	}
+
+	FOREACH_HASH_VALUE(mPtr, &clsPtr->classMethods) {
+	    TclOODeleteMethod(mPtr);
+	}
+	Tcl_DeleteHashTable(&clsPtr->classMethods);
+	TclOODeleteMethod(clsPtr->constructorPtr);
+	TclOODeleteMethod(clsPtr->destructorPtr);
+	Tcl_EventuallyFree(clsPtr, TCL_DYNAMIC);
+    }
+
+    /*
+     * Delete the object structure itself.
+     */
+
+    if (!(oPtr->flags & OBJECT_DELETED)) {
+	Tcl_EventuallyFree(oPtr, TCL_DYNAMIC);
+	Tcl_Release(oPtr);
+    } else {
+	Tcl_EventuallyFree(oPtr, TCL_DYNAMIC);
+    }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOORemoveFromInstances --
+ *
+ *	Utility function to remove an object from the list of instances within
+ *	a class.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+void
+TclOORemoveFromInstances(
+    Object *oPtr,		/* The instance to remove. */
+    Class *clsPtr)		/* The class (possibly) containing the
+				 * reference to the instance. */
+{
+    int i;
+    Object *instPtr;
+
+    FOREACH(instPtr, clsPtr->instances) {
+	if (oPtr == instPtr) {
+	    goto removeInstance;
+	}
+    }
+    return;
+
+  removeInstance:
+    clsPtr->instances.num--;
+    if (i < clsPtr->instances.num) {
+	clsPtr->instances.list[i] =
+		clsPtr->instances.list[clsPtr->instances.num];
+    }
+    clsPtr->instances.list[clsPtr->instances.num] = NULL;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * 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 **)
+		    ckalloc(sizeof(Object *) * ALLOC_CHUNK);
+	} else {
+	    clsPtr->instances.list = (Object **)
+		    ckrealloc((char *) clsPtr->instances.list,
+		    sizeof(Object *) * clsPtr->instances.size);
+	}
+    }
+    clsPtr->instances.list[clsPtr->instances.num++] = oPtr;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOORemoveFromSubclasses --
+ *
+ *	Utility function to remove a class from the list of subclasses within
+ *	another class.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+void
+TclOORemoveFromSubclasses(
+    Class *subPtr,		/* The subclass to remove. */
+    Class *superPtr)		/* The superclass to (possibly) remove the
+				 * subclass reference from. */
+{
+    int i;
+    Class *subclsPtr;
+
+    FOREACH(subclsPtr, superPtr->subclasses) {
+	if (subPtr == subclsPtr) {
+	    goto removeSubclass;
+	}
+    }
+    return;
+
+  removeSubclass:
+    superPtr->subclasses.num--;
+    if (i < superPtr->subclasses.num) {
+	superPtr->subclasses.list[i] =
+	    superPtr->subclasses.list[superPtr->subclasses.num];
+    }
+    superPtr->subclasses.list[superPtr->subclasses.num] = NULL;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * 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 (superPtr->subclasses.num >= superPtr->subclasses.size) {
+	superPtr->subclasses.size += ALLOC_CHUNK;
+	if (superPtr->subclasses.size == ALLOC_CHUNK) {
+	    superPtr->subclasses.list = (Class **)
+		    ckalloc(sizeof(Class *) * ALLOC_CHUNK);
+	} else {
+	    superPtr->subclasses.list = (Class **)
+		    ckrealloc((char *) superPtr->subclasses.list,
+		    sizeof(Class *) * superPtr->subclasses.size);
+	}
+    }
+    superPtr->subclasses.list[superPtr->subclasses.num++] = subPtr;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOORemoveFromMixinSubs --
+ *
+ *	Utility function to remove a class from the list of mixinSubs within
+ *	another class.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+void
+TclOORemoveFromMixinSubs(
+    Class *subPtr,		/* The subclass to remove. */
+    Class *superPtr)		/* The superclass to (possibly) remove the
+				 * subclass reference from. */
+{
+    int i;
+    Class *subclsPtr;
+
+    FOREACH(subclsPtr, superPtr->mixinSubs) {
+	if (subPtr == subclsPtr) {
+	    goto removeSubclass;
+	}
+    }
+    return;
+
+  removeSubclass:
+    superPtr->mixinSubs.num--;
+    if (i < superPtr->mixinSubs.num) {
+	superPtr->mixinSubs.list[i] =
+	    superPtr->mixinSubs.list[superPtr->mixinSubs.num];
+    }
+    superPtr->mixinSubs.list[superPtr->mixinSubs.num] = NULL;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * 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 (superPtr->mixinSubs.num >= superPtr->mixinSubs.size) {
+	superPtr->mixinSubs.size += ALLOC_CHUNK;
+	if (superPtr->mixinSubs.size == ALLOC_CHUNK) {
+	    superPtr->mixinSubs.list = (Class **)
+		    ckalloc(sizeof(Class *) * ALLOC_CHUNK);
+	} else {
+	    superPtr->mixinSubs.list = (Class **)
+		    ckrealloc((char *) superPtr->mixinSubs.list,
+		    sizeof(Class *) * superPtr->mixinSubs.size);
+	}
+    }
+    superPtr->mixinSubs.list[superPtr->mixinSubs.num++] = subPtr;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * AllocClass --
+ *
+ *	Allocate a basic class. Does not splice the class object into its
+ *	class's instance list.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static Class *
+AllocClass(
+    Tcl_Interp *interp,		/* Interpreter within which to allocate the
+				 * class. */
+    Object *useThisObj)		/* Object that is to act as the class
+				 * representation, or NULL if a new object
+				 * (with automatic name) is to be used. */
+{
+    Class *clsPtr;
+    Foundation *fPtr = ((Interp *) interp)->ooFoundation;
+
+    clsPtr = (Class *) ckalloc(sizeof(Class));
+    memset(clsPtr, 0, sizeof(Class));
+    if (useThisObj == NULL) {
+	clsPtr->thisPtr = AllocObject(interp, NULL);
+    } else {
+	clsPtr->thisPtr = useThisObj;
+    }
+    clsPtr->thisPtr->selfCls = fPtr->classCls;
+    if (fPtr->classCls != NULL) {
+	TclOOAddToInstances(clsPtr->thisPtr, fPtr->classCls);
+	TclOOAddToSubclasses(clsPtr, fPtr->objectCls);
+    }
+    {
+	Tcl_Namespace *path[2];
+
+	path[0] = fPtr->helpersNs;
+	path[1] = fPtr->ooNs;
+	TclSetNsPath((Namespace *) clsPtr->thisPtr->namespacePtr, 2, path);
+    }
+    clsPtr->thisPtr->classPtr = clsPtr;
+    clsPtr->flags = 0;
+    clsPtr->superclasses.num = 1;
+    clsPtr->superclasses.list = (Class **) ckalloc(sizeof(Class *));
+    clsPtr->superclasses.list[0] = fPtr->objectCls;
+    clsPtr->subclasses.num = 0;
+    clsPtr->subclasses.list = NULL;
+    clsPtr->subclasses.size = 0;
+    clsPtr->instances.num = 0;
+    clsPtr->instances.list = NULL;
+    clsPtr->instances.size = 0;
+    clsPtr->filters.list = NULL;
+    clsPtr->filters.num = 0;
+    clsPtr->mixins.list = NULL;
+    clsPtr->mixins.num = 0;
+    clsPtr->mixinSubs.list = NULL;
+    clsPtr->mixinSubs.num = 0;
+    clsPtr->mixinSubs.size = 0;
+    clsPtr->classHierarchy.list = NULL;
+    clsPtr->classHierarchy.num = 0;
+    clsPtr->classHierarchyEpoch = fPtr->epoch-1;
+    Tcl_InitObjHashTable(&clsPtr->classMethods);
+    clsPtr->constructorPtr = NULL;
+    clsPtr->destructorPtr = NULL;
+    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 *name,		/* Name of object to create, 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. */
+{
+    Object *oPtr = AllocObject(interp, NULL);
+    CallContext *contextPtr;
+
+    oPtr->selfCls = (Class *) cls;
+    TclOOAddToInstances(oPtr, (Class *) cls);
+
+    if (name != NULL) {
+	Tcl_Obj *cmdnameObj;
+
+	TclNewObj(cmdnameObj);
+	Tcl_GetCommandFullName(interp, oPtr->command, cmdnameObj);
+	if (TclRenameCommand(interp, TclGetString(cmdnameObj),
+		name) != TCL_OK) {
+	    Tcl_ResetResult(interp);
+	    Tcl_AppendResult(interp, "can't create object \"", name,
+		    "\": command already exists with that name", NULL);
+	    TclDecrRefCount(cmdnameObj);
+	    Tcl_DeleteCommandFromToken(interp, oPtr->command);
+	    return NULL;
+	}
+	TclDecrRefCount(cmdnameObj);
+    }
+
+    /*
+     * Check to see if we're really creating a class. If so, allocate the
+     * class structure as well.
+     */
+
+    if (TclOOIsReachable((((Interp *) interp)->ooFoundation)->classCls,
+	    (Class *) cls)) {
+	/*
+	 * Is a class, so attach a class structure. Note that the AllocClass
+	 * function splices the structure into the object, so we don't have
+	 * to.
+	 */
+
+	AllocClass(interp, oPtr);
+	oPtr->selfCls = (Class *) cls; // Repatch
+    }
+
+    if (objc >= 0) {
+	contextPtr = TclOOGetCallContext(((Interp *)interp)->ooFoundation,
+		oPtr, NULL, CONSTRUCTOR, NULL);
+	if (contextPtr != NULL) {
+	    int result;
+	    Tcl_InterpState state;
+
+	    Tcl_Preserve(oPtr);
+	    state = Tcl_SaveInterpState(interp, TCL_OK);
+	    contextPtr->flags |= CONSTRUCTOR;
+	    contextPtr->skip = skip;
+	    result = TclOOInvokeContext(interp, contextPtr, objc, objv);
+	    TclOODeleteContext(contextPtr);
+	    Tcl_Release(oPtr);
+	    if (result != TCL_OK) {
+		Tcl_DiscardInterpState(state);
+		Tcl_DeleteCommandFromToken(interp, oPtr->command);
+		return NULL;
+	    }
+	    (void) Tcl_RestoreInterpState(interp, state);
+	}
+    }
+
+    return (Tcl_Object) oPtr;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * Tcl_NewMethod --
+ *
+ *	Attach a method to an object.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+Tcl_Method
+Tcl_NewMethod(
+    Tcl_Interp *interp,		/* Unused? */
+    Tcl_Object object,		/* The object that has the method attached to
+				 * it. */
+    Tcl_Obj *nameObj,		/* The name of the method. May be NULL; if so,
+				 * up to caller to manage storage (e.g., when
+				 * it is a constructor or destructor). */
+    int isPublic,		/* Whether this is a public method. */
+    const Tcl_MethodType *typePtr,
+				/* The type of method this is, which defines
+				 * how to invoke, delete and clone the
+				 * method. */
+    ClientData clientData)	/* Some data associated with the particular
+				 * method to be created. */
+{
+    register Object *oPtr = (Object *) object;
+    register Method *mPtr;
+    Tcl_HashEntry *hPtr;
+    int isNew;
+
+    if (nameObj == NULL) {
+	mPtr = (Method *) ckalloc(sizeof(Method));
+	mPtr->namePtr = NULL;
+	goto populate;
+    }
+    hPtr = Tcl_CreateHashEntry(&oPtr->methods, (char *) nameObj, &isNew);
+    if (isNew) {
+	mPtr = (Method *) ckalloc(sizeof(Method));
+	mPtr->namePtr = nameObj;
+	Tcl_IncrRefCount(nameObj);
+	Tcl_SetHashValue(hPtr, mPtr);
+    } else {
+	mPtr = Tcl_GetHashValue(hPtr);
+	if (mPtr->typePtr != NULL && mPtr->typePtr->deleteProc != NULL) {
+	    mPtr->typePtr->deleteProc(mPtr->clientData);
+	}
+    }
+
+  populate:
+    mPtr->typePtr = typePtr;
+    mPtr->clientData = clientData;
+    mPtr->flags = 0;
+    mPtr->declaringObjectPtr = oPtr;
+    mPtr->declaringClassPtr = NULL;
+    if (isPublic) {
+	mPtr->flags |= PUBLIC_METHOD;
+    }
+    oPtr->epoch++;
+    return (Tcl_Method) mPtr;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * Tcl_NewClassMethod --
+ *
+ *	Attach a method to a class.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+Tcl_Method
+Tcl_NewClassMethod(
+    Tcl_Interp *interp,		/* The interpreter containing the class. */
+    Tcl_Class cls,		/* The class to attach the method to. */
+    Tcl_Obj *nameObj,		/* The name of the object. May be NULL (e.g.,
+				 * for constructors or destructors); if so, up
+				 * to caller to manage storage. */
+    int isPublic,		/* Whether this is a public method. */
+    const Tcl_MethodType *typePtr,
+				/* The type of method this is, which defines
+				 * how to invoke, delete and clone the
+				 * method. */
+    ClientData clientData)	/* Some data associated with the particular
+				 * method to be created. */
+{
+    register Class *clsPtr = (Class *) cls;
+    register Method *mPtr;
+    Tcl_HashEntry *hPtr;
+    int isNew;
+
+    if (nameObj == NULL) {
+	mPtr = (Method *) ckalloc(sizeof(Method));
+	mPtr->namePtr = NULL;
+	goto populate;
+    }
+    hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, (char *)nameObj,&isNew);
+    if (isNew) {
+	mPtr = (Method *) ckalloc(sizeof(Method));
+	mPtr->namePtr = nameObj;
+	Tcl_IncrRefCount(nameObj);
+	Tcl_SetHashValue(hPtr, mPtr);
+    } else {
+	mPtr = Tcl_GetHashValue(hPtr);
+	if (mPtr->typePtr != NULL && mPtr->typePtr->deleteProc != NULL) {
+	    mPtr->typePtr->deleteProc(mPtr->clientData);
+	}
+    }
+
+  populate:
+    ((Interp *) interp)->ooFoundation->epoch++;
+    mPtr->typePtr = typePtr;
+    mPtr->clientData = clientData;
+    mPtr->flags = 0;
+    mPtr->declaringObjectPtr = NULL;
+    mPtr->declaringClassPtr = clsPtr;
+    if (isPublic) {
+	mPtr->flags |= PUBLIC_METHOD;
+    }
+
+    return (Tcl_Method) mPtr;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * DeleteMethodStruct --
+ *
+ *	Function used when deleting a method. Always called indirectly via
+ *	Tcl_EventuallyFree().
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+DeleteMethodStruct(
+    char *buffer)
+{
+    Method *mPtr = (Method *) buffer;
+
+    if (mPtr->typePtr != NULL && mPtr->typePtr->deleteProc != NULL) {
+	mPtr->typePtr->deleteProc(mPtr->clientData);
+    }
+    if (mPtr->namePtr != NULL) {
+	TclDecrRefCount(mPtr->namePtr);
+    }
+
+    ckfree(buffer);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOODeleteMethod --
+ *
+ *	How to delete a method.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+void
+TclOODeleteMethod(
+    Method *mPtr)
+{
+    if (mPtr != NULL) {
+	Tcl_EventuallyFree(mPtr, DeleteMethodStruct);
+    }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * DeclareClassMethod --
+ *
+ *	Helper that makes it cleaner to create very simple methods during
+ *	basic system initialization. Not suitable for general use.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+DeclareClassMethod(
+    Tcl_Interp *interp,
+    Class *clsPtr,		/* Class to attach the method to. */
+    const char *name,		/* Name of the method. */
+    int isPublic,		/* Whether the method is public. */
+    Tcl_MethodCallProc callPtr)
+				/* Method implementation function. */
+{
+    Tcl_Obj *namePtr;
+
+    TclNewStringObj(namePtr, name, strlen(name));
+    Tcl_IncrRefCount(namePtr);
+    Tcl_NewClassMethod(interp, (Tcl_Class) clsPtr, namePtr, isPublic,
+	    &coreMethodType, callPtr);
+    TclDecrRefCount(namePtr);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * SimpleInvoke --
+ *
+ *	How to invoke a simple method.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+SimpleInvoke(
+    ClientData clientData,	/* Pointer to function that implements the
+				 * method. */
+    Tcl_Interp *interp,
+    Tcl_ObjectContext context,	/* The method calling context. */
+    int objc,			/* Number of arguments. */
+    Tcl_Obj *const *objv)	/* Arguments as actually seen. */
+{
+    Tcl_MethodCallProc callPtr = clientData;
+
+    return (*callPtr)(NULL, interp, context, objc, objv);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOONewProcMethod --
+ *
+ *	Create a new procedure-like method for an object.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+Method *
+TclOONewProcMethod(
+    Tcl_Interp *interp,		/* The interpreter containing the object. */
+    Object *oPtr,		/* The object to modify. */
+    int isPublic,		/* Whether this is a public method. */
+    Tcl_Obj *nameObj,		/* The name of the method, which must not be
+				 * NULL. */
+    Tcl_Obj *argsObj,		/* The formal argument list for the method,
+				 * which must not be NULL. */
+    Tcl_Obj *bodyObj)		/* The body of the method, which must not be
+				 * NULL. */
+{
+    int argsc;
+    Tcl_Obj **argsv;
+    register ProcedureMethod *pmPtr;
+    const char *procName;
+
+    if (Tcl_ListObjGetElements(interp, argsObj, &argsc, &argsv) != TCL_OK) {
+	return NULL;
+    }
+    pmPtr = (ProcedureMethod *) ckalloc(sizeof(ProcedureMethod));
+    procName = TclGetString(nameObj);
+    if (TclCreateProc(interp, NULL, procName, argsObj, bodyObj,
+	    &pmPtr->procPtr) != TCL_OK) {
+	ckfree((char *) pmPtr);
+	return NULL;
+    }
+    return (Method *) Tcl_NewMethod(interp, (Tcl_Object) oPtr, nameObj,
+	    isPublic, &procMethodType, pmPtr);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOONewProcClassMethod --
+ *
+ *	Create a new procedure-like method for a class.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+Method *
+TclOONewProcClassMethod(
+    Tcl_Interp *interp,		/* The interpreter containing the class. */
+    Class *clsPtr,		/* The class to modify. */
+    int isPublic,		/* Whether this is a public method. */
+    Tcl_Obj *nameObj,		/* The name of the method, which may be NULL;
+				 * if so, up to caller to manage storage
+				 * (e.g., because it is a constructor or
+				 * destructor). */
+    Tcl_Obj *argsObj,		/* The formal argument list for the method,
+				 * which may be NULL; if so, it is equivalent
+				 * to an empty list. */
+    Tcl_Obj *bodyObj)		/* The body of the method, which must not be
+				 * NULL. */
+{
+    int argsLen;		/* -1 => delete argsObj before exit */
+    register ProcedureMethod *pmPtr;
+    const char *procName;
+
+    if (argsObj == NULL) {
+	argsLen = -1;
+	TclNewObj(argsObj);
+	Tcl_IncrRefCount(argsObj);
+	procName = "<destructor>";
+    } else if (Tcl_ListObjLength(interp, argsObj, &argsLen) != TCL_OK) {
+	return NULL;
+    } else {
+	procName = (nameObj==NULL ? "<constructor>" : TclGetString(nameObj));
+    }
+    pmPtr = (ProcedureMethod *) ckalloc(sizeof(ProcedureMethod));
+    if (TclCreateProc(interp, NULL, procName, argsObj, bodyObj,
+	    &pmPtr->procPtr) != TCL_OK) {
+	if (argsLen == -1) {
+	    TclDecrRefCount(argsObj);
+	}
+	ckfree((char *) pmPtr);
+	return NULL;
+    }
+    if (argsLen == -1) {
+	TclDecrRefCount(argsObj);
+    }
+    return (Method *) Tcl_NewClassMethod(interp, (Tcl_Class) clsPtr, nameObj,
+	    isPublic, &procMethodType, pmPtr);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InvokeProcedureMethod --
+ *
+ *	How to invoke a procedure-like method.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InvokeProcedureMethod(
+    ClientData clientData,	/* Pointer to some per-method context. */
+    Tcl_Interp *interp,
+    Tcl_ObjectContext context,	/* The method calling context. */
+    int objc,			/* Number of arguments. */
+    Tcl_Obj *const *objv)	/* Arguments as actually seen. */
+{
+    CallContext *contextPtr = (CallContext *) context;
+    ProcedureMethod *pmPtr = (ProcedureMethod *) clientData;
+    int result, flags = FRAME_IS_METHOD, skip = contextPtr->skip;
+    CallFrame *framePtr, **framePtrPtr;
+    Object *oPtr = contextPtr->oPtr;
+    Command cmd;
+    const char *namePtr;
+    Tcl_Obj *nameObj;
+
+    cmd.nsPtr = (Namespace *) oPtr->namespacePtr;
+    pmPtr->procPtr->cmdPtr = &cmd;
+    if (contextPtr->flags & CONSTRUCTOR) {
+	namePtr = "<constructor>";
+	flags |= FRAME_IS_CONSTRUCTOR;
+	nameObj = Tcl_NewStringObj("<constructor>", -1);
+	Tcl_IncrRefCount(nameObj);
+    } else if (contextPtr->flags & DESTRUCTOR) {
+	namePtr = "<destructor>";
+	flags |= FRAME_IS_DESTRUCTOR;
+	nameObj = Tcl_NewStringObj("<destructor>", -1);
+	Tcl_IncrRefCount(nameObj);
+    } else {
+	nameObj = objv[contextPtr->skip-1];
+	namePtr = TclGetString(nameObj);
+    }
+    result = TclProcCompileProc(interp, pmPtr->procPtr,
+	    pmPtr->procPtr->bodyPtr, (Namespace *) oPtr->namespacePtr,
+	    "body of method", namePtr);
+    if (result != TCL_OK) {
+	return result;
+    }
+
+    if (contextPtr->callChain[contextPtr->index].isFilter) {
+	flags |= FRAME_IS_FILTER;
+    }
+    framePtrPtr = &framePtr;
+    result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr,
+	    oPtr->namespacePtr, flags);
+    if (result != TCL_OK) {
+	return result;
+    }
+    framePtr->ooContextPtr = contextPtr;
+    framePtr->objc = objc;
+    framePtr->objv = objv;	/* ref counts for args are incremented below */
+    framePtr->procPtr = pmPtr->procPtr;
+
+    if (contextPtr->flags & OO_UNKNOWN_METHOD) {
+	skip--;
+    }
+    result = TclObjInterpProcCore(interp, framePtr, nameObj, skip);
+    if (contextPtr->flags & (CONSTRUCTOR | DESTRUCTOR)) {
+	TclDecrRefCount(nameObj);
+    }
+    return result;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * DeleteProcedureMethod, CloneProcedureMethod --
+ *
+ *	How to delete and clone procedure-like methods.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+DeleteProcedureMethod(
+    ClientData clientData)
+{
+    register ProcedureMethod *pmPtr = (ProcedureMethod *) clientData;
+
+    TclProcDeleteProc(pmPtr->procPtr);
+    ckfree((char *) pmPtr);
+}
+
+static int
+CloneProcedureMethod(
+    ClientData clientData,
+    ClientData *newClientData)
+{
+    ProcedureMethod *pmPtr = (ProcedureMethod *) clientData;
+    ProcedureMethod *pm2Ptr = (ProcedureMethod *)
+	    ckalloc(sizeof(ProcedureMethod));
+
+    pm2Ptr->procPtr = pmPtr->procPtr;
+    pm2Ptr->procPtr->refCount++;
+    *newClientData = pm2Ptr;
+    return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOONewForwardMethod --
+ *
+ *	Create a forwarded method for an object.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+Method *
+TclOONewForwardMethod(
+    Tcl_Interp *interp,		/* Interpreter for error reporting. */
+    Object *oPtr,		/* The object to attach the method to. */
+    int isPublic,		/* Whether the method is public or not. */
+    Tcl_Obj *nameObj,		/* The name of the method. */
+    Tcl_Obj *prefixObj)		/* List of arguments that form the command
+				 * prefix to forward to. */
+{
+    int prefixLen;
+    register ForwardMethod *fmPtr;
+
+    if (Tcl_ListObjLength(interp, prefixObj, &prefixLen) != TCL_OK) {
+	return NULL;
+    }
+    if (prefixLen < 1) {
+	Tcl_AppendResult(interp, "method forward prefix must be non-empty",
+		NULL);
+	return NULL;
+    }
+
+    fmPtr = (ForwardMethod *) ckalloc(sizeof(ForwardMethod));
+    fmPtr->prefixObj = prefixObj;
+    Tcl_IncrRefCount(prefixObj);
+    return (Method *) Tcl_NewMethod(interp, (Tcl_Object) oPtr, nameObj,
+	    isPublic, &fwdMethodType, fmPtr);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOONewForwardClassMethod --
+ *
+ *	Create a new forwarded method for a class.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+Method *
+TclOONewForwardClassMethod(
+    Tcl_Interp *interp,		/* Interpreter for error reporting. */
+    Class *clsPtr,		/* The class to attach the method to. */
+    int isPublic,		/* Whether the method is public or not. */
+    Tcl_Obj *nameObj,		/* The name of the method. */
+    Tcl_Obj *prefixObj)		/* List of arguments that form the command
+				 * prefix to forward to. */
+{
+    int prefixLen;
+    register ForwardMethod *fmPtr;
+
+    if (Tcl_ListObjLength(interp, prefixObj, &prefixLen) != TCL_OK) {
+	return NULL;
+    }
+    if (prefixLen < 1) {
+	Tcl_AppendResult(interp, "method forward prefix must be non-empty",
+		NULL);
+	return NULL;
+    }
+
+    fmPtr = (ForwardMethod *) ckalloc(sizeof(ForwardMethod));
+    fmPtr->prefixObj = prefixObj;
+    Tcl_IncrRefCount(prefixObj);
+    return (Method *) Tcl_NewClassMethod(interp, (Tcl_Class) clsPtr, nameObj,
+	    isPublic, &fwdMethodType, fmPtr);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InvokeForwardMethod --
+ *
+ *	How to invoke a forwarded method. Works by doing some ensemble-like
+ *	command rearranging and then invokes some other Tcl command.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InvokeForwardMethod(
+    ClientData clientData,	/* Pointer to some per-method context. */
+    Tcl_Interp *interp,
+    Tcl_ObjectContext context,	/* The method calling context. */
+    int objc,			/* Number of arguments. */
+    Tcl_Obj *const *objv)	/* Arguments as actually seen. */
+{
+    CallContext *contextPtr = (CallContext *) context;
+    ForwardMethod *fmPtr = (ForwardMethod *) clientData;
+    Tcl_Obj **argObjs, **prefixObjs;
+    int numPrefixes, result, len;
+
+    /*
+     * Build the real list of arguments to use. Note that we know that the
+     * prefixObj field of the ForwardMethod structure holds a reference to a
+     * non-empty list, so there's a whole class of failures ("not a list") we
+     * can ignore here.
+     */
+
+    Tcl_ListObjGetElements(NULL, fmPtr->prefixObj, &numPrefixes, &prefixObjs);
+    argObjs = InitEnsembleRewrite(interp, objc, objv, contextPtr->skip,
+	    numPrefixes, prefixObjs, &len);
+
+    result = Tcl_EvalObjv(interp, len, argObjs, TCL_EVAL_INVOKE);
+    ckfree((char *) argObjs);
+    return result;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * DeleteForwardMethod, CloneForwardMethod --
+ *
+ *	How to delete and clone forwarded methods.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+DeleteForwardMethod(
+    ClientData clientData)
+{
+    ForwardMethod *fmPtr = (ForwardMethod *) clientData;
+
+    TclDecrRefCount(fmPtr->prefixObj);
+    ckfree((char *) fmPtr);
+}
+
+static int
+CloneForwardMethod(
+    ClientData clientData,
+    ClientData *newClientData)
+{
+    ForwardMethod *fmPtr = (ForwardMethod *) clientData;
+    ForwardMethod *fm2Ptr = (ForwardMethod *) ckalloc(sizeof(ForwardMethod));
+
+    fm2Ptr->prefixObj = fmPtr->prefixObj;
+    Tcl_IncrRefCount(fm2Ptr->prefixObj);
+    *newClientData = fm2Ptr;
+    return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * PublicObjectCmd, PrivateObjectCmd, ObjectCmd --
+ *
+ *	Main entry point for object invokations. The Public* and Private*
+ *	wrapper functions are just thin wrappers round the main ObjectCmd
+ *	function that does call chain creation, management and invokation.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+PublicObjectCmd(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    return ObjectCmd(clientData, interp, objc, objv, 1,
+	    &((Object *)clientData)->publicContextCache);
+}
+
+static int
+PrivateObjectCmd(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    return ObjectCmd(clientData, interp, objc, objv, 0,
+	    &((Object *)clientData)->privateContextCache);
+}
+
+static int
+ObjectCmd(
+    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 publicOnly,		/* Whether this is an invokation through the
+				 * public or the private command interface. */
+    Tcl_HashTable *cachePtr)	/* What call chain cache to use. */
+{
+    Interp *iPtr = (Interp *) interp;
+    CallContext *contextPtr;
+    int result;
+
+    if (objc < 2) {
+	Tcl_WrongNumArgs(interp, 1, objv, "method ?arg ...?");
+	return TCL_ERROR;
+    }
+
+    contextPtr = TclOOGetCallContext(iPtr->ooFoundation, oPtr, objv[1],
+	    (publicOnly ? PUBLIC_METHOD :0) | (oPtr->flags & FILTER_HANDLING),
+	    cachePtr);
+    if (contextPtr == NULL) {
+	Tcl_AppendResult(interp, "impossible to invoke method \"",
+		TclGetString(objv[1]),
+		"\": no defined method or unknown method", NULL);
+	return TCL_ERROR;
+    }
+
+    Tcl_Preserve(oPtr);
+    result = TclOOInvokeContext(interp, contextPtr, objc, objv);
+    if (!(contextPtr->flags & OO_UNKNOWN_METHOD)
+	    && !(oPtr->flags & OBJECT_DELETED)) {
+	Tcl_HashEntry *hPtr;
+
+	hPtr = Tcl_FindHashEntry(cachePtr, (char *) objv[1]);
+	if (hPtr != NULL && Tcl_GetHashValue(hPtr) == NULL) {
+	    Tcl_SetHashValue(hPtr, contextPtr);
+	} else {
+	    TclOODeleteContext(contextPtr);
+	}
+    } else {
+	TclOODeleteContext(contextPtr);
+    }
+    Tcl_Release(oPtr);
+
+    return result;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * ClassCreate --
+ *
+ *	Implementation for oo::class->create method.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+ClassCreate(
+    ClientData clientData,	/* Ignored. */
+    Tcl_Interp *interp,		/* Interpreter in which to create the object;
+				 * also used for error reporting. */
+    Tcl_ObjectContext context,	/* The object/call context. */
+    int objc,			/* Number of arguments. */
+    Tcl_Obj *const *objv)	/* The actual arguments. */
+{
+    Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
+    Tcl_Object newObject;
+    const char *objName;
+    int len;
+
+    /*
+     * Sanity check; should not be possible to invoke this method on a
+     * non-class.
+     */
+
+    if (oPtr->classPtr == NULL) {
+	Tcl_Obj *cmdnameObj;
+
+	TclNewObj(cmdnameObj);
+	Tcl_GetCommandFullName(interp, oPtr->command, cmdnameObj);
+	Tcl_AppendResult(interp, "object \"", TclGetString(cmdnameObj),
+		"\" is not a class", NULL);
+	TclDecrRefCount(cmdnameObj);
+	return TCL_ERROR;
+    }
+
+    /*
+     * Check we have the right number of (sensible) arguments.
+     */
+
+    if (objc - Tcl_ObjectContextSkippedArgs(context) < 1) {
+	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+		"objectName ?arg ...?");
+	return TCL_ERROR;
+    }
+    objName = Tcl_GetStringFromObj(
+	    objv[Tcl_ObjectContextSkippedArgs(context)], &len);
+    if (len == 0) {
+	Tcl_AppendResult(interp, "object name must not be empty", NULL);
+	return TCL_ERROR;
+    }
+
+    /*
+     * Make the object and return its name.
+     */
+
+    newObject = Tcl_NewObjectInstance(interp, (Tcl_Class) oPtr->classPtr,
+	    objName, objc, objv, Tcl_ObjectContextSkippedArgs(context)+1);
+    if (newObject == NULL) {
+	return TCL_ERROR;
+    }
+    Tcl_GetCommandFullName(interp, Tcl_GetObjectCommand(newObject),
+	    Tcl_GetObjResult(interp));
+    return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * ClassNew --
+ *
+ *	Implementation for oo::class->new method.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+ClassNew(
+    ClientData clientData,	/* Ignored. */
+    Tcl_Interp *interp,		/* Interpreter in which to create the object;
+				 * also used for error reporting. */
+    Tcl_ObjectContext context,	/* The object/call context. */
+    int objc,			/* Number of arguments. */
+    Tcl_Obj *const *objv)	/* The actual arguments. */
+{
+    Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
+    Tcl_Object newObject;
+
+    /*
+     * Sanity check; should not be possible to invoke this method on a
+     * non-class.
+     */
+
+    if (oPtr->classPtr == NULL) {
+	Tcl_Obj *cmdnameObj;
+
+	TclNewObj(cmdnameObj);
+	Tcl_GetCommandFullName(interp, oPtr->command, cmdnameObj);
+	Tcl_AppendResult(interp, "object \"", TclGetString(cmdnameObj),
+		"\" is not a class", NULL);
+	TclDecrRefCount(cmdnameObj);
+	return TCL_ERROR;
+    }
+
+    /*
+     * Make the object and return its name.
+     */
+
+    newObject = Tcl_NewObjectInstance(interp, (Tcl_Class) oPtr->classPtr,
+	    NULL, objc, objv, Tcl_ObjectContextSkippedArgs(context));
+    if (newObject == NULL) {
+	return TCL_ERROR;
+    }
+    Tcl_GetCommandFullName(interp, Tcl_GetObjectCommand(newObject),
+	    Tcl_GetObjResult(interp));
+    return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * ObjectDestroy --
+ *
+ *	Implementation for oo::object->destroy method.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+ObjectDestroy(
+    ClientData clientData,	/* Ignored. */
+    Tcl_Interp *interp,		/* Interpreter in which to create the object;
+				 * also used for error reporting. */
+    Tcl_ObjectContext context,	/* The object/call context. */
+    int objc,			/* Number of arguments. */
+    Tcl_Obj *const *objv)	/* The actual arguments. */
+{
+    if (objc != Tcl_ObjectContextSkippedArgs(context)) {
+	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+		NULL);
+	return TCL_ERROR;
+    }
+    Tcl_DeleteCommandFromToken(interp,
+	    Tcl_GetObjectCommand(Tcl_ObjectContextObject(context)));
+    return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * ObjectEval --
+ *
+ *	Implementation for oo::object->eval method.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+ObjectEval(
+    ClientData clientData,	/* Ignored. */
+    Tcl_Interp *interp,		/* Interpreter in which to create the object;
+				 * also used for error reporting. */
+    Tcl_ObjectContext context,	/* The object/call context. */
+    int objc,			/* Number of arguments. */
+    Tcl_Obj *const *objv)	/* The actual arguments. */
+{
+    CallContext *contextPtr = (CallContext *) context;
+    Tcl_Object object = Tcl_ObjectContextObject(context);
+    CallFrame *framePtr, **framePtrPtr;
+    Tcl_Obj *objnameObj;
+    int result;
+
+    if (objc-1 < Tcl_ObjectContextSkippedArgs(context)) {
+	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+		"arg ?arg ...?");
+	return TCL_ERROR;
+    }
+
+    /*
+     * Make the object's namespace the current namespace and evaluate the
+     * command(s).
+     */
+
+    /* This is needed to satisfy GCC 3.3's strict aliasing rules */
+    framePtrPtr = &framePtr;
+    result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr,
+	    Tcl_GetObjectNamespace(object), 0);
+    if (result != TCL_OK) {
+	return TCL_ERROR;
+    }
+    framePtr->objc = objc;
+    framePtr->objv = objv;	/* Reference counts do not need to be
+				 * incremented here. */
+
+    if (contextPtr->flags & PUBLIC_METHOD) {
+	TclNewObj(objnameObj);
+	Tcl_GetCommandFullName(interp, Tcl_GetObjectCommand(object),
+		objnameObj);
+    } else {
+	TclNewStringObj(objnameObj, "my", 2);
+    }
+    Tcl_IncrRefCount(objnameObj);
+
+    if (objc == Tcl_ObjectContextSkippedArgs(context)+1) {
+	result = Tcl_EvalObjEx(interp,
+		objv[Tcl_ObjectContextSkippedArgs(context)], 0);
+    } else {
+	Tcl_Obj *objPtr;
+
+	/*
+	 * More than one argument: concatenate them together with spaces
+	 * between, then evaluate the result. Tcl_EvalObjEx will delete the
+	 * object when it decrements its refcount after eval'ing it.
+	 */
+
+	objPtr = Tcl_ConcatObj(objc-Tcl_ObjectContextSkippedArgs(context),
+		objv+Tcl_ObjectContextSkippedArgs(context));
+	result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT);
+    }
+
+    if (result == TCL_ERROR) {
+	TclFormatToErrorInfo(interp,
+		"\n    (in \"%s eval\" script line %d)",
+		TclGetString(objnameObj), interp->errorLine);
+    }
+
+    /*
+     * Restore the previous "current" namespace.
+     */
+
+    TclPopStackFrame(interp);
+    TclDecrRefCount(objnameObj);
+    return result;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * ObjectUnknown --
+ *
+ *	Default unknown method handler method (defined in oo::object). This
+ *	just creates a suitable error message.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+ObjectUnknown(
+    ClientData clientData,	/* Ignored. */
+    Tcl_Interp *interp,		/* Interpreter in which to create the object;
+				 * also used for error reporting. */
+    Tcl_ObjectContext context,	/* The object/call context. */
+    int objc,			/* Number of arguments. */
+    Tcl_Obj *const *objv)	/* The actual arguments. */
+{
+    CallContext *contextPtr = (CallContext *) context;
+    Object *oPtr = contextPtr->oPtr;
+    const char **methodNames;
+    int numMethodNames, i;
+
+    /*
+     * Get the list of methods that we want to know about.
+     */
+
+    numMethodNames = TclOOGetSortedMethodList(oPtr,
+	    contextPtr->flags & PUBLIC_METHOD, &methodNames);
+
+    /*
+     * Special message when there are no visible methods at all.
+     */
+
+    if (numMethodNames == 0) {
+	Tcl_Obj *tmpBuf;
+
+	TclNewObj(tmpBuf);
+	Tcl_GetCommandFullName(interp, oPtr->command, tmpBuf);
+	Tcl_AppendResult(interp, "object \"", TclGetString(tmpBuf),
+		"\" has no visible methods", NULL);
+	TclDecrRefCount(tmpBuf);
+	return TCL_ERROR;
+    }
+
+    Tcl_AppendResult(interp, "unknown method \"",
+	    TclGetString(objv[Tcl_ObjectContextSkippedArgs(context)-1]),
+	    "\": must be ", NULL);
+    for (i=0 ; i<numMethodNames-1 ; i++) {
+	if (i) {
+	    Tcl_AppendResult(interp, ", ", NULL);
+	}
+	Tcl_AppendResult(interp, methodNames[i], NULL);
+    }
+    if (i) {
+	Tcl_AppendResult(interp, " or ", NULL);
+    }
+    Tcl_AppendResult(interp, methodNames[i], NULL);
+    ckfree((char *) methodNames);
+    return TCL_ERROR;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * ObjectLinkVar --
+ *
+ *	Implementation of oo::object->variable method.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+ObjectLinkVar(
+    ClientData clientData,	/* Ignored. */
+    Tcl_Interp *interp,		/* Interpreter in which to create the object;
+				 * also used for error reporting. */
+    Tcl_ObjectContext context,	/* The object/call context. */
+    int objc,			/* Number of arguments. */
+    Tcl_Obj *const *objv)	/* The actual arguments. */
+{
+    Interp *iPtr = (Interp *) interp;
+    Tcl_Object object = Tcl_ObjectContextObject(context);
+    Namespace *savedNsPtr;
+    int i;
+
+    if (objc-Tcl_ObjectContextSkippedArgs(context) < 1) {
+	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+		"varName ?varName ...?");
+	return TCL_ERROR;
+    }
+
+    /*
+     * Do nothing if we are not called from the body of a method. In this
+     * respect, we are like the [global] command.
+     */
+
+    if (iPtr->varFramePtr == NULL ||
+	    !(iPtr->varFramePtr->isProcCallFrame & FRAME_IS_METHOD)) {
+	return TCL_OK;
+    }
+
+    for (i=Tcl_ObjectContextSkippedArgs(context) ; i<objc ; i++) {
+	Var *varPtr, *aryPtr;
+	Tcl_Obj **argObjs;
+	const char *varName;
+	int len;
+
+	/*
+	 * Parse to see if we have a single value in the argument (just the
+	 * name of a variable to use in both the namespace and local scope) or
+	 * a two-argument list (namespace variable name and local variable
+	 * name). Other cases are an error.
+	 */
+
+	if (Tcl_ListObjGetElements(interp, objv[i], &len, &argObjs)!=TCL_OK) {
+	    return TCL_ERROR;
+	}
+	if (len != 1 && len != 2) {
+	    Tcl_AppendResult(interp, "argument must be list "
+		    "of one or two variable names", NULL);
+	    return TCL_ERROR;
+	}
+
+	varName = TclGetString(argObjs[len-1]);
+	if (strstr(varName, "::") != NULL) {
+	    /*
+	     * The local var name must not contain a '::' but the ns name is
+	     * OK. Naturally, if they're the same, then the restriction is
+	     * applied equally to both.
+	     */
+
+	    Tcl_AppendResult(interp, "variable name \"", varName,
+		    "\" illegal: must not contain namespace separator", NULL);
+	    return TCL_ERROR;
+	}
+
+	/*
+	 * Switch to the object's namespace for the duration of this call.
+	 * Like this, the variable is looked up in the namespace of the
+	 * object, and not in the namespace of the caller. Otherwise this
+	 * would only work if the caller was a method of the object itself,
+	 * which might not be true if the method was exported. This is a bit
+	 * of a hack, but the simplest way to do this (pushing a stack frame
+	 * would be horribly expensive by comparison). We never have to worry
+	 * about the case where we're dealing with the global namespace; we've
+	 * already checked that we are inside a method.
+	 */
+
+	savedNsPtr = iPtr->varFramePtr->nsPtr;
+	iPtr->varFramePtr->nsPtr = (Namespace *)
+		Tcl_GetObjectNamespace(object);
+	varPtr = TclObjLookupVar(interp, argObjs[0], NULL, TCL_NAMESPACE_ONLY,
+		"define", 1, 0, &aryPtr);
+	iPtr->varFramePtr->nsPtr = savedNsPtr;
+
+	if (varPtr == NULL || aryPtr != NULL) {
+	    /*
+	     * Variable cannot be an element in an array. If aryPtr is not
+	     * NULL, it is an element, so throw up an error and return.
+	     */
+
+	    TclVarErrMsg(interp, TclGetString(argObjs[0]), NULL, "define",
+		    "name refers to an element in an array");
+	    return TCL_ERROR;
+	}
+
+	/*
+	 * Arrange for the lifetime of the variable to be correctly managed.
+	 * This is copied out of Tcl_VariableObjCmd...
+	 */
+
+	if (!TclIsVarNamespaceVar(varPtr)) {
+	    TclSetVarNamespaceVar(varPtr);
+	    varPtr->refCount++;
+	}
+
+	if (TclPtrMakeUpvar(interp, varPtr, varName, 0, -1) != TCL_OK) {
+	    return TCL_ERROR;
+	}
+    }
+    return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * ObjectVarName --
+ *
+ *	Implementation of the oo::object->varname method.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+ObjectVarName(
+    ClientData clientData,	/* Ignored. */
+    Tcl_Interp *interp,		/* Interpreter in which to create the object;
+				 * also used for error reporting. */
+    Tcl_ObjectContext context,	/* The object/call context. */
+    int objc,			/* Number of arguments. */
+    Tcl_Obj *const *objv)	/* The actual arguments. */
+{
+    Interp *iPtr = (Interp *) interp;
+    Var *varPtr, *aryVar;
+    Tcl_Obj *varNamePtr;
+
+    if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
+	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+		"varName");
+	return TCL_ERROR;
+    }
+
+    /*
+     * Switch to the object's namespace for the duration of this call. Like
+     * this, the variable is looked up in the namespace of the object, and not
+     * in the namespace of the caller. Otherwise this would only work if the
+     * caller was a method of the object itself, which might not be true if
+     * the method was exported. This is a bit of a hack, but the simplest way
+     * to do this (pushing a stack frame would be horribly expensive by
+     * comparison, and is only done when we'd otherwise interfere with the
+     * global namespace).
+     */
+
+    if (iPtr->varFramePtr == NULL) {
+	Tcl_CallFrame *dummyFrame;
+
+	TclPushStackFrame(interp, &dummyFrame,
+		Tcl_GetObjectNamespace(Tcl_ObjectContextObject(context)),0);
+	varPtr = TclObjLookupVar(interp, objv[objc-1], NULL,
+		TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG, "refer to",1,1,&aryVar);
+	TclPopStackFrame(interp);
+    } else {
+	Namespace *savedNsPtr;
+
+	savedNsPtr = iPtr->varFramePtr->nsPtr;
+	iPtr->varFramePtr->nsPtr = (Namespace *)
+		Tcl_GetObjectNamespace(Tcl_ObjectContextObject(context));
+	varPtr = TclObjLookupVar(interp, objv[objc-1], NULL,
+		TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG, "refer to",1,1,&aryVar);
+	iPtr->varFramePtr->nsPtr = savedNsPtr;
+    }
+
+    if (varPtr == NULL) {
+	return TCL_ERROR;
+    }
+
+    TclNewObj(varNamePtr);
+    Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, varNamePtr);
+    Tcl_SetObjResult(interp, varNamePtr);
+    return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * NextObjCmd --
+ *
+ *	Implementation of the [next] command. Note that this command is only
+ *	ever to be used inside the body of a procedure-like method.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+NextObjCmd(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    Interp *iPtr = (Interp *) interp;
+    CallFrame *framePtr = iPtr->varFramePtr, *savedFramePtr;
+    CallContext *contextPtr;
+    int index, result, skip;
+
+    /*
+     * Start with sanity checks on the calling context and the method context.
+     */
+
+    if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
+	Tcl_AppendResult(interp, TclGetString(objv[0]),
+		" may only be called from inside a method", NULL);
+	return TCL_ERROR;
+    }
+
+    contextPtr = framePtr->ooContextPtr;
+
+    index = contextPtr->index;
+    skip = contextPtr->skip;
+    if (index+1 >= contextPtr->numCallChain) {
+	Tcl_AppendResult(interp, "no superclass ",
+		(contextPtr->flags & CONSTRUCTOR ? "constructor" :
+		(contextPtr->flags & DESTRUCTOR ? "destructor" : "method")),
+		" implementation", 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 invokations (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. From here on, the skip is always 1.
+     */
+
+    contextPtr->index = index+1;
+    contextPtr->skip = 1;
+
+    /*
+     * Invoke the (advanced) method call context in the caller context. Note
+     * that this is like [uplevel 1] and not [eval].
+     */
+
+    savedFramePtr = iPtr->varFramePtr;
+    iPtr->varFramePtr = savedFramePtr->callerVarPtr;
+    result = TclOOInvokeContext(interp, contextPtr, objc, objv);
+    iPtr->varFramePtr = savedFramePtr;
+
+    /*
+     * Restore the call chain context index as we've finished the inner invoke
+     * and want to operate in the outer context again.
+     */
+
+    contextPtr->index = index;
+    contextPtr->skip = skip;
+
+    return result;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * SelfObjCmd --
+ *
+ *	Implementation of the [self] command, which provides introspection of
+ *	the call context.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+SelfObjCmd(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    static const char *subcmds[] = {
+	"caller", "class", "filter", "method", "namespace", "next", "object",
+	"target", NULL
+    };
+    enum SelfCmds {
+	SELF_CALLER, SELF_CLASS, SELF_FILTER, SELF_METHOD, SELF_NS, SELF_NEXT,
+	SELF_OBJECT, SELF_TARGET
+    };
+    Interp *iPtr = (Interp *) interp;
+    CallFrame *framePtr = iPtr->varFramePtr;
+    CallContext *contextPtr;
+    int index;
+
+    /*
+     * Start with sanity checks on the calling context and the method context.
+     */
+
+    if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
+	Tcl_AppendResult(interp, TclGetString(objv[0]),
+		" may only be called from inside a method", NULL);
+	return TCL_ERROR;
+    }
+
+    contextPtr = framePtr->ooContextPtr;
+
+    /*
+     * Now we do "conventional" argument parsing for a while. Note that no
+     * subcommand takes arguments.
+     */
+
+    if (objc > 2) {
+	Tcl_WrongNumArgs(interp, 1, objv, "subcommand");
+	return TCL_ERROR;
+    }
+    if (objc == 1) {
+	index = SELF_OBJECT;
+    } else if (Tcl_GetIndexFromObj(interp, objv[1], subcmds, "subcommand", 0,
+	    &index) != TCL_OK) {
+	return TCL_ERROR;
+    }
+
+    switch ((enum SelfCmds) index) {
+    case SELF_OBJECT:
+	Tcl_GetCommandFullName(interp, contextPtr->oPtr->command,
+		Tcl_GetObjResult(interp));
+	return TCL_OK;
+    case SELF_NS:
+	Tcl_SetObjResult(interp, Tcl_NewStringObj(
+		contextPtr->oPtr->namespacePtr->fullName,-1));
+	return TCL_OK;
+    case SELF_CLASS: {
+	Method *mPtr = contextPtr->callChain[contextPtr->index].mPtr;
+	Object *declarerPtr;
+
+	if (mPtr->declaringClassPtr != NULL) {
+	    declarerPtr = mPtr->declaringClassPtr->thisPtr;
+	} else if (mPtr->declaringObjectPtr != NULL) {
+	    declarerPtr = mPtr->declaringObjectPtr;
+	} else {
+	    /*
+	     * This should be unreachable code.
+	     */
+
+	    Tcl_AppendResult(interp, "method without declarer!", NULL);
+	    return TCL_ERROR;
+	}
+
+	Tcl_GetCommandFullName(interp, declarerPtr->command,
+		Tcl_GetObjResult(interp));
+	return TCL_OK;
+    }
+    case SELF_METHOD:
+	if (contextPtr->flags & CONSTRUCTOR) {
+	    Tcl_AppendResult(interp, "<constructor>", NULL);
+	} else if (contextPtr->flags & DESTRUCTOR) {
+	    Tcl_AppendResult(interp, "<destructor>", NULL);
+	} else {
+	    Method *mPtr = contextPtr->callChain[contextPtr->index].mPtr;
+
+	    Tcl_SetObjResult(interp, mPtr->namePtr);
+	}
+	return TCL_OK;
+    case SELF_FILTER:
+	if (!contextPtr->callChain[contextPtr->index].isFilter) {
+	    Tcl_AppendResult(interp, "not inside a filtering context", NULL);
+	    return TCL_ERROR;
+	} else {
+	    Method *mPtr =
+		    contextPtr->callChain[contextPtr->filterLength].mPtr;
+	    Tcl_Obj *cmdName;
+
+	    // TODO: should indicate who has the filter registration, not the
+	    // first non-filter after the filter!
+	    TclNewObj(cmdName);
+	    Tcl_GetCommandFullName(interp, contextPtr->oPtr->command,
+		    cmdName);
+	    Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), cmdName);
+	    // TODO: Add what type of filter this is
+	    Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
+		    mPtr->namePtr);
+	    return TCL_OK;
+	}
+    case SELF_CALLER:
+	if ((framePtr->callerVarPtr != NULL) &&
+		(framePtr->callerVarPtr->isProcCallFrame & FRAME_IS_METHOD)) {
+	    CallContext *callerPtr = framePtr->callerVarPtr->ooContextPtr;
+	    Method *mPtr = callerPtr->callChain[callerPtr->index].mPtr;
+	    Object *declarerPtr;
+	    Tcl_Obj *tmpObj;
+
+	    if (mPtr->declaringClassPtr != NULL) {
+		declarerPtr = mPtr->declaringClassPtr->thisPtr;
+	    } else if (mPtr->declaringObjectPtr != NULL) {
+		declarerPtr = mPtr->declaringObjectPtr;
+	    } else {
+		/*
+		 * This should be unreachable code.
+		 */
+
+		Tcl_AppendResult(interp, "method without declarer!", NULL);
+		return TCL_ERROR;
+	    }
+
+	    TclNewObj(tmpObj);
+	    Tcl_GetCommandFullName(interp, declarerPtr->command, tmpObj);
+	    Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), tmpObj);
+	    TclNewObj(tmpObj);
+	    Tcl_GetCommandFullName(interp, callerPtr->oPtr->command, tmpObj);
+	    Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), tmpObj);
+	    if (callerPtr->flags & CONSTRUCTOR) {
+		Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
+			Tcl_NewStringObj("<constructor>", -1));
+	    } else if (callerPtr->flags & DESTRUCTOR) {
+		Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
+			Tcl_NewStringObj("<destructor>", -1));
+	    } else {
+		Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
+			mPtr->namePtr);
+	    }
+	    return TCL_OK;
+	} else {
+	    Tcl_AppendResult(interp, "caller is not an object", NULL);
+	    return TCL_ERROR;
+	}
+    case SELF_NEXT:
+	if (contextPtr->index < contextPtr->numCallChain-1) {
+	    Method *mPtr = contextPtr->callChain[contextPtr->index+1].mPtr;
+	    Object *declarerPtr;
+	    Tcl_Obj *tmpObj;
+
+	    if (mPtr->declaringClassPtr != NULL) {
+		declarerPtr = mPtr->declaringClassPtr->thisPtr;
+	    } else if (mPtr->declaringObjectPtr != NULL) {
+		declarerPtr = mPtr->declaringObjectPtr;
+	    } else {
+		/*
+		 * This should be unreachable code.
+		 */
+
+		Tcl_AppendResult(interp, "method without declarer!", NULL);
+		return TCL_ERROR;
+	    }
+
+	    TclNewObj(tmpObj);
+	    Tcl_GetCommandFullName(interp, declarerPtr->command, tmpObj);
+	    Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), tmpObj);
+	    if (contextPtr->flags & CONSTRUCTOR) {
+		Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
+			Tcl_NewStringObj("<constructor>", -1));
+	    } else if (contextPtr->flags & DESTRUCTOR) {
+		Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
+			Tcl_NewStringObj("<destructor>", -1));
+	    } else {
+		Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
+			mPtr->namePtr);
+	    }
+	}
+	return TCL_OK;
+    case SELF_TARGET:
+	if (!contextPtr->callChain[contextPtr->index].isFilter) {
+	    Tcl_AppendResult(interp, "not inside a filtering context", NULL);
+	    return TCL_ERROR;
+	} else {
+	    Method *mPtr;
+	    Object *declarerPtr;
+	    Tcl_Obj *cmdName;
+	    int i;
+
+	    for (i=contextPtr->index ; i<contextPtr->numCallChain ; i++) {
+		if (!contextPtr->callChain[i].isFilter) {
+		    break;
+		}
+	    }
+	    if (i == contextPtr->numCallChain) {
+		Tcl_Panic("filtering call chain without terminal non-filter");
+	    }
+	    mPtr = contextPtr->callChain[i].mPtr;
+	    if (mPtr->declaringClassPtr != NULL) {
+		declarerPtr = mPtr->declaringClassPtr->thisPtr;
+	    } else if (mPtr->declaringObjectPtr != NULL) {
+		declarerPtr = mPtr->declaringObjectPtr;
+	    } else {
+		/*
+		 * This should be unreachable code.
+		 */
+
+		Tcl_AppendResult(interp, "method without declarer!", NULL);
+		return TCL_ERROR;
+	    }
+	    TclNewObj(cmdName);
+	    Tcl_GetCommandFullName(interp, declarerPtr->command, cmdName);
+	    Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), cmdName);
+	    Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
+		    mPtr->namePtr);
+	    return TCL_OK;
+	}
+    }
+    return TCL_ERROR;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * Tcl_GetObjectFromObj --
+ *
+ *	Utility function to get an object from a Tcl_Obj containing its name.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+Tcl_Object
+Tcl_GetObjectFromObj(
+    Tcl_Interp *interp,
+    Tcl_Obj *objPtr)
+{
+    Command *cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objPtr);
+
+    if (cmdPtr == NULL || cmdPtr->objProc != PublicObjectCmd) {
+	Tcl_AppendResult(interp, TclGetString(objPtr),
+		" does not refer to an object", NULL);
+	return NULL;
+    }
+    return cmdPtr->objClientData;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * 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 = startPtr->superclasses.list[0];
+	goto tailRecurse;
+    }
+    FOREACH(superPtr, startPtr->superclasses) {
+	if (TclOOIsReachable(targetPtr, superPtr)) {
+	    return 1;
+	}
+    }
+    return 0;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOGetProcFromMethod, TclOOGetFwdFromMethod --
+ *
+ *	Utility functions used for procedure-like and forwarding method
+ *	introspection.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+Proc *
+TclOOGetProcFromMethod(
+    Method *mPtr)
+{
+    if (mPtr->typePtr == &procMethodType) {
+	ProcedureMethod *pmPtr = mPtr->clientData;
+
+	return pmPtr->procPtr;
+    }
+    return NULL;
+}
+
+Tcl_Obj *
+TclOOGetFwdFromMethod(
+    Method *mPtr)
+{
+    if (mPtr->typePtr == &fwdMethodType) {
+	ForwardMethod *fwPtr = mPtr->clientData;
+
+	return fwPtr->prefixObj;
+    }
+    return NULL;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InitEnsembleRewrite --
+ *
+ *	Utility function that wraps up a lot of the complexity involved in
+ *	doing ensemble-like command forwarding. Here is a picture of memory
+ *	management plan:
+ *
+ *                    <-----------------objc---------------------->
+ *      objv:        |=============|===============================|
+ *                    <-toRewrite->           |
+ *                                             \
+ *                    <-rewriteLength->         \
+ *      rewriteObjs: |=================|         \
+ *                           |                    |
+ *                           V                    V
+ *      argObjs:     |=================|===============================|
+ *                    <------------------*lengthPtr------------------->
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static Tcl_Obj **
+InitEnsembleRewrite(
+    Tcl_Interp *interp,		/* Place to log the rewrite info. */
+    int objc,			/* Number of real arguments. */
+    Tcl_Obj *const *objv,	/* The real arguments. */
+    int toRewrite,		/* Number of real arguments to replace. */
+    int rewriteLength,		/* Number of arguments to insert instead. */
+    Tcl_Obj *const *rewriteObjs,/* Arguments to insert instead. */
+    int *lengthPtr)		/* Where to write the resulting length of the
+				 * array of rewritten arguments. */
+{
+    Interp *iPtr = (Interp *) interp;
+    int isRootEnsemble = (iPtr->ensembleRewrite.sourceObjs == NULL);
+    Tcl_Obj **argObjs;
+    unsigned len = rewriteLength + objc - toRewrite;
+
+    argObjs = (Tcl_Obj **) ckalloc(sizeof(Tcl_Obj *) * len);
+    memcpy(argObjs, rewriteObjs, rewriteLength * sizeof(Tcl_Obj *));
+    memcpy(argObjs + rewriteLength, objv + toRewrite,
+	    sizeof(Tcl_Obj *) * (objc - toRewrite));
+
+    /*
+     * Now plumb this into the core ensemble rewrite logging system so that
+     * Tcl_WrongNumArgs() can rewrite its result appropriately. The rules for
+     * how to store the rewrite rules get complex solely because of the case
+     * where an ensemble rewrites itself out of the picture; when that
+     * happens, the quality of the error message rewrite falls drastically
+     * (and unavoidably).
+     */
+
+    if (isRootEnsemble) {
+	iPtr->ensembleRewrite.sourceObjs = objv;
+	iPtr->ensembleRewrite.numRemovedObjs = toRewrite;
+	iPtr->ensembleRewrite.numInsertedObjs = rewriteLength;
+    } else {
+	int numIns = iPtr->ensembleRewrite.numInsertedObjs;
+
+	if (numIns < toRewrite) {
+	    iPtr->ensembleRewrite.numRemovedObjs += toRewrite - numIns;
+	    iPtr->ensembleRewrite.numInsertedObjs += rewriteLength - 1;
+	} else {
+	    iPtr->ensembleRewrite.numInsertedObjs +=
+		    rewriteLength - toRewrite;
+	}
+    }
+
+    *lengthPtr = len;
+    return argObjs;
+}
+
+Tcl_Method
+Tcl_ObjectContextMethod(
+    Tcl_ObjectContext context)
+{
+    CallContext *contextPtr = (CallContext *) context;
+    return (Tcl_Method) contextPtr->callChain[contextPtr->index].mPtr;
+}
+
+int
+Tcl_ObjectContextIsFiltering(
+    Tcl_ObjectContext context)
+{
+    CallContext *contextPtr = (CallContext *) context;
+    return contextPtr->callChain[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_Object
+Tcl_MethodDeclarerObject(
+    Tcl_Method method)
+{
+    return (Tcl_Object) ((Method *) method)->declaringObjectPtr;
+}
+
+Tcl_Class
+Tcl_MethodDeclarerClass(
+    Tcl_Method method)
+{
+    return (Tcl_Class) ((Method *) method)->declaringClassPtr;
+}
+
+Tcl_Obj *
+Tcl_MethodName(
+    Tcl_Method method)
+{
+    return ((Method *) method)->namePtr;
+}
+
+int
+Tcl_MethodIsType(
+    Tcl_Method method,
+    const Tcl_MethodType *typePtr,
+    ClientData *clientDataPtr)
+{
+    Method *mPtr = (Method *) method;
+
+    if (mPtr->typePtr == typePtr) {
+	if (clientDataPtr != NULL) {
+	    *clientDataPtr = mPtr->clientData;
+	}
+	return 1;
+    }
+    return 0;
+}
+
+int
+Tcl_MethodIsPublic(
+    Tcl_Method method)
+{
+    return (((Method *)method)->flags & PUBLIC_METHOD) ? 1 : 0;
+}
+
+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)->flags & OBJECT_DELETED) ? 1 : 0;
+}
+
+Tcl_Object
+Tcl_GetClassAsObject(
+    Tcl_Class clazz)
+{
+    return (Tcl_Object) ((Class *)clazz)->thisPtr;
+}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/generic/tclOO.h b/generic/tclOO.h
index c14a9c7..134cb9b 100644
--- a/generic/tclOO.h
+++ b/generic/tclOO.h
@@ -1,352 +1,352 @@
-/*

- * tclOO.h --

- *

- *	This file contains the structure definitions and some of the function

- *	declarations for the object-system (NB: not Tcl_Obj, but ::oo).

- *

- * Copyright (c) 2006 by Donal K. Fellows

- *

- * See the file "license.terms" for information on usage and redistribution of

- * this file, and for a DISCLAIMER OF ALL WARRANTIES.

- *

- * RCS: @(#) $Id: tclOO.h,v 1.1.2.34 2006/10/08 15:39:59 dkf Exp $

- */

-

-// vvvvvvvvvvvvvvvvvvvvvv MOVE TO TCL.DECLS vvvvvvvvvvvvvvvvvvvvvv

-Tcl_Object		Tcl_GetClassAsObject(Tcl_Class clazz);

-Tcl_Class		Tcl_GetObjectAsClass(Tcl_Object object);

-Tcl_Command		Tcl_GetObjectCommand(Tcl_Object object);

-Tcl_Object		Tcl_GetObjectFromObj(Tcl_Interp *interp,

-			    Tcl_Obj *objPtr);

-Tcl_Namespace *		Tcl_GetObjectNamespace(Tcl_Object object);

-Tcl_Class		Tcl_MethodDeclarerClass(Tcl_Method method);

-Tcl_Object		Tcl_MethodDeclarerObject(Tcl_Method method);

-int			Tcl_MethodIsPublic(Tcl_Method method);

-int			Tcl_MethodIsType(Tcl_Method method,

-			    const Tcl_MethodType *typePtr,

-			    ClientData *clientDataPtr);

-Tcl_Obj *		Tcl_MethodName(Tcl_Method method);

-Tcl_Method		Tcl_NewMethod(Tcl_Interp *interp, Tcl_Object object,

-			    Tcl_Obj *nameObj, int isPublic,

-			    const Tcl_MethodType *typePtr,

-			    ClientData clientData);

-Tcl_Method		Tcl_NewClassMethod(Tcl_Interp *interp, Tcl_Class cls,

-			    Tcl_Obj *nameObj, int isPublic,

-			    const Tcl_MethodType *typePtr,

-			    ClientData clientData);

-Tcl_Object		Tcl_NewObjectInstance(Tcl_Interp *interp,

-			    Tcl_Class cls, const char *name, int objc,

-			    Tcl_Obj *const *objv, int skip);

-int			Tcl_ObjectDeleted(Tcl_Object object);

-int			Tcl_ObjectContextIsFiltering(

-			    Tcl_ObjectContext context);

-Tcl_Method		Tcl_ObjectContextMethod(Tcl_ObjectContext context);

-Tcl_Object		Tcl_ObjectContextObject(Tcl_ObjectContext context);

-int			Tcl_ObjectContextSkippedArgs(

-			    Tcl_ObjectContext context);

-// ^^^^^^^^^^^^^^^^^^^^^^ MOVE TO TCL.DECLS ^^^^^^^^^^^^^^^^^^^^^^

-

-/*

- * Forward declarations.

- */

-

-struct Class;

-struct Object;

-

-/*

- * The data that needs to be stored per method. This record is used to collect

- * information about all sorts of methods, including forwards, constructors

- * and destructors.

- */

-

-typedef struct Method {

-    const Tcl_MethodType *typePtr;

-				/* The type of method. If NULL, this is a

-				 * special flag record which is just used for

-				 * the setting of the flags field. */

-    ClientData clientData;	/* Type-specific data. */

-    Tcl_Obj *namePtr;		/* Name of the method. */

-    struct Object *declaringObjectPtr;

-				/* The object that declares this method, or

-				 * NULL if it was declared by a class. */

-    struct Class *declaringClassPtr;

-				/* The class that declares this method, or

-				 * NULL if it was declared directly on an

-				 * object. */

-    int flags;			/* Assorted flags. Includes whether this

-				 * method is public/exported or not. */

-} Method;

-

-/*

- * Procedure-like methods have the following extra information. It is a

- * single-field structure because this allows for future expansion without

- * changing vast amounts of code.

- */

-

-typedef struct ProcedureMethod {

-    Proc *procPtr;

-} ProcedureMethod;

-

-/*

- * Forwarded methods have the following extra information. It is a

- * single-field structure because this allows for future expansion without

- * changing vast amounts of code.

- */

-

-typedef struct ForwardMethod {

-    Tcl_Obj *prefixObj;

-} ForwardMethod;

-

-/*

- * Helper definitions that declare a "list" array. The two varieties are

- * either optimized for simplicity (in the case that the whole array is

- * typically assigned at once) or efficiency (in the case that the array is

- * expected to be expanded over time). These lists are designed to be iterated

- * over with the help of the FOREACH macro (see later in this file).

- *

- * The "num" field always counts the number of listType_t elements used in the

- * "list" field. When a "size" field exists, it describes how many elements

- * are present in the list; when absent, exactly "num" elements are present.

- */

-

-#define LIST_STATIC(listType_t) \

-    struct { int num; listType_t *list; }

-#define LIST_DYNAMIC(listType_t) \

-    struct { int num, size; listType_t *list; }

-

-/*

- * Now, the definition of what an object actually is.

- */

-

-typedef struct Object {

-    Tcl_Namespace *namespacePtr;/* This object's tame namespace. */

-    Tcl_Command command;	/* Reference to this object's public

-				 * command. */

-    Tcl_Command myCommand;	/* Reference to this object's internal

-				 * command. */

-    struct Class *selfCls;	/* This object's class. */

-    Tcl_HashTable methods;	/* Object-local Tcl_Obj (method name) to

-				 * Method* mapping. */

-    LIST_STATIC(struct Class *) mixins;

-				/* Classes mixed into this object. */

-    LIST_STATIC(Tcl_Obj *) filters;

-				/* List of filter names. */

-    struct Class *classPtr;	/* All classes have this non-NULL; it points

-				 * to the class structure. Everything else has

-				 * this NULL. */

-    int flags;

-    int epoch;			/* Per-object epoch, incremented when the way

-				 * an object should resolve call chains is

-				 * changed. */

-    Tcl_HashTable publicContextCache;	/* Place to keep unused contexts. */

-    Tcl_HashTable privateContextCache;	/* Place to keep unused contexts. */

-} Object;

-

-#define OBJECT_DELETED	1	/* Flag to say that an object has been

-				 * destroyed. */

-#define ROOT_OBJECT 0x1000	/* Flag to say that this object is the root of

-				 * the class hierarchy and should be treated

-				 * specially during teardown. */

-#define FILTER_HANDLING 0x2000	/* Flag set when the object is processing a

-				 * filter; when set, filters are *not*

-				 * processed on the object, preventing nasty

-				 * recursive filtering problems. */

-

-/*

- * And the definition of a class. Note that every class also has an associated

- * object, through which it is manipulated.

- */

-

-typedef struct Class {

-    Object *thisPtr;		/* Reference to the object associated with

-				 * this class. */

-    int flags;			/* Assorted flags. */

-    LIST_STATIC(struct Class *) superclasses;

-				/* List of superclasses, used for generation

-				 * of method call chains. */

-    LIST_DYNAMIC(struct Class *) subclasses;

-				/* List of subclasses, used to ensure deletion

-				 * of dependent entities happens properly when

-				 * the class itself is deleted. */

-    LIST_DYNAMIC(Object *) instances;

-				/* List of instances, used to ensure deletion

-				 * of dependent entities happens properly when

-				 * the class itself is deleted. */

-    LIST_STATIC(Tcl_Obj *) filters;

-				/* List of filter names, used for generation

-				 * of method call chains. */

-    LIST_STATIC(struct Class *) mixins;

-				/* List of mixin classes, used for generation

-				 * of method call chains. */

-    LIST_DYNAMIC(struct Class *) mixinSubs;

-				/* List of classes that this class is mixed

-				 * into, used to ensure deletion of dependent

-				 * entities happens properly when the class

-				 * itself is deleted. */

-    LIST_STATIC(struct Class *) classHierarchy;

-				/* List of classes that comprise the basic

-				 * class hierarchy for this class's

-				 * superclasses. If NULL (and this isn't the

-				 * root object class) then this needs

-				 * recomputing. */

-    int classHierarchyEpoch;	/* Differs from the global epoch when it is

-				 * time to recompute the class hierarchy. */

-    Tcl_HashTable classMethods;	/* Hash table of all methods. Hash maps from

-				 * the (Tcl_Obj*) method name to the (Method*)

-				 * method record. */

-    Method *constructorPtr;	/* Method record of the class constructor (if

-				 * any). */

-    Method *destructorPtr;	/* Method record of the class destructor (if

-				 * any). */

-} Class;

-

-/*

- * The foundation of the object system within an interpreter contains

- * references to the key classes and namespaces, together with a few other

- * useful bits and pieces. Probably ought to eventually go in the Interp

- * structure itself.

- */

-

-typedef struct Foundation {

-    Class *objectCls;		/* The root of the object system. */

-    Class *classCls;		/* The class of all classes. */

-    Tcl_Namespace *ooNs;	/* Master ::oo namespace. */

-    Tcl_Namespace *defineNs;	/* Namespace containing special commands for

-				 * manipulating objects and classes. The

-				 * "oo::define" command acts as a special kind

-				 * of ensemble for this namespace. */

-    Tcl_Namespace *helpersNs;	/* Namespace containing the commands that are

-				 * only valid when executing inside a

-				 * procedural method. */

-    int epoch;			/* Used to invalidate method chains when the

-				 * class structure changes. */

-    int nsCount;		/* Counter so we can allocate a unique

-				 * namespace to each object. */

-    Tcl_Obj *unknownMethodNameObj;

-				/* Shared object containing the name of the

-				 * unknown method handler method. */

-} Foundation;

-

-/*

- * A call context structure is built when a method is called. They contain the

- * chain of method implementations that are to be invoked by a particular

- * call, and the process of calling walks the chain, with the [next] command

- * proceeding to the next entry in the chain.

- */

-

-#define CALL_CHAIN_STATIC_SIZE 4

-

-struct MInvoke {

-    Method *mPtr;		/* Reference to the method implementation

-				 * record. */

-    int isFilter;		/* Whether this is a filter invokation. */

-};

-

-typedef struct CallContext {

-    Object *oPtr;		/* The object associated with this call. */

-    int globalEpoch;		/* Global (class) epoch counter snapshot. */

-    int localEpoch;		/* Local (single object) epoch counter

-				 * snapshot. */

-    int flags;			/* Assorted flags, see below. */

-    int index;			/* Index into the call chain of the currently

-				 * executing method implementation. */

-    int skip;

-    int numCallChain;		/* Size of the call chain. */

-    struct MInvoke *callChain;	/* Array of call chain entries. May point to

-				 * staticCallChain if the number of entries is

-				 * small. */

-    struct MInvoke staticCallChain[CALL_CHAIN_STATIC_SIZE];

-    int filterLength;		/* Number of entries in the call chain that

-				 * are due to processing filters and not the

-				 * main call chain. */

-} CallContext;

-

-/*

- * Bits for the 'flags' field of the call context.

- */

-

-#define OO_UNKNOWN_METHOD	1 /* This is an unknown method. */

-#define PUBLIC_METHOD		2 /* This is a public (exported) method. */

-#define CONSTRUCTOR		4 /* This is a constructor. */

-#define DESTRUCTOR		8 /* This is a destructor. */

-

-/*

- * Private definitions, some of which perhaps ought to be exposed properly or

- * maybe just put in the internal stubs table.

- */

-

-MODULE_SCOPE Method *	TclOONewProcMethod(Tcl_Interp *interp, Object *oPtr,

-			    int isPublic, Tcl_Obj *nameObj, Tcl_Obj *argsObj,

-			    Tcl_Obj *bodyObj);

-MODULE_SCOPE Method *	TclOONewForwardMethod(Tcl_Interp *interp, Object *oPtr,

-			    int isPublic, Tcl_Obj *nameObj,

-			    Tcl_Obj *prefixObj);

-MODULE_SCOPE Method *	TclOONewProcClassMethod(Tcl_Interp *interp,

-			    Class *clsPtr, int isPublic, Tcl_Obj *nameObj,

-			    Tcl_Obj *argsObj, Tcl_Obj *bodyObj);

-MODULE_SCOPE Method *	TclOONewForwardClassMethod(Tcl_Interp *interp,

-			    Class *clsPtr, int isPublic, Tcl_Obj *nameObj,

-			    Tcl_Obj *prefixObj);

-MODULE_SCOPE void	TclOODeleteMethod(Method *method);

-MODULE_SCOPE int	TclObjInterpProcCore(register Tcl_Interp *interp,

-			    CallFrame *framePtr, Tcl_Obj *procNameObj,

-			    int skip);

-MODULE_SCOPE void	TclOOAddToInstances(Object *oPtr, Class *clsPtr);

-MODULE_SCOPE void	TclOOAddToSubclasses(Class *subPtr, Class *superPtr);

-MODULE_SCOPE void	TclOOAddToMixinSubs(Class *subPtr, Class *mixinPtr);

-MODULE_SCOPE Proc *	TclOOGetProcFromMethod(Method *mPtr);

-MODULE_SCOPE Tcl_Obj *	TclOOGetFwdFromMethod(Method *mPtr);

-MODULE_SCOPE int	TclOOIsReachable(Class *targetPtr, Class *startPtr);

-MODULE_SCOPE void	TclOORemoveFromInstances(Object *oPtr, Class *clsPtr);

-MODULE_SCOPE void	TclOORemoveFromSubclasses(Class *subPtr,

-			    Class *superPtr);

-MODULE_SCOPE void	TclOORemoveFromMixinSubs(Class *subPtr,

-			    Class *mixinPtr);

-MODULE_SCOPE void	TclOODeleteContext(CallContext *contextPtr);

-MODULE_SCOPE CallContext *TclOOGetCallContext(Foundation *fPtr, Object *oPtr,

-			    Tcl_Obj *methodNameObj, int flags,

-			    Tcl_HashTable *cachePtr);

-MODULE_SCOPE int	TclOOInvokeContext(Tcl_Interp *interp,

-			    CallContext *contextPtr, int objc,

-			    Tcl_Obj *const *objv);

-MODULE_SCOPE int	TclOOGetSortedMethodList(Object *oPtr,

-			    int publicOnly, const char ***stringsPtr);

-

-/*

- * A convenience macro for iterating through the lists used in the internal

- * memory management of objects. This is a bit gnarly because we want to do

- * the assignment of the picked-out value only when the body test succeeds,

- * but we cannot rely on the assigned value being useful, forcing us to do

- * some nasty stuff with the comma operator. The compiler's optimizer should

- * be able to sort it all out!

- *

- * REQUIRES DECLARATION: int i;

- */

-

-#define FOREACH(var,ary) \

-	for(i=0 ; (i<(ary).num?((var=(ary).list[i]),1):0) ; i++)

-

-/*

- * Convenience macros for iterating through hash tables. FOREACH_HASH_DECLS

- * sets up the declarations needed for the main macro, FOREACH_HASH, which

- * does the actual iteration. FOREACH_HASH_VALUE is a restricted version that

- * only iterates over values.

- */

-

-#define FOREACH_HASH_DECLS \

-    Tcl_HashEntry *hPtr;Tcl_HashSearch search

-#define FOREACH_HASH(key,val,tablePtr) \

-    for(hPtr=Tcl_FirstHashEntry((tablePtr),&search); hPtr!=NULL ? \

-	    ((key)=(void *)Tcl_GetHashKey((tablePtr),hPtr),\

-	    (val)=Tcl_GetHashValue(hPtr),1):0; hPtr=Tcl_NextHashEntry(&search))

-#define FOREACH_HASH_VALUE(val,tablePtr) \

-    for(hPtr=Tcl_FirstHashEntry((tablePtr),&search); hPtr!=NULL ? \

-	    ((val)=Tcl_GetHashValue(hPtr),1):0;hPtr=Tcl_NextHashEntry(&search))

-

-/*

- * Local Variables:

- * mode: c

- * c-basic-offset: 4

- * fill-column: 78

- * End:

- */

+/*
+ * tclOO.h --
+ *
+ *	This file contains the structure definitions and some of the function
+ *	declarations for the object-system (NB: not Tcl_Obj, but ::oo).
+ *
+ * Copyright (c) 2006 by Donal K. Fellows
+ *
+ * See the file "license.terms" for information on usage and redistribution of
+ * this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * RCS: @(#) $Id: tclOO.h,v 1.1.2.35 2006/10/11 02:01:16 dgp Exp $
+ */
+
+// vvvvvvvvvvvvvvvvvvvvvv MOVE TO TCL.DECLS vvvvvvvvvvvvvvvvvvvvvv
+Tcl_Object		Tcl_GetClassAsObject(Tcl_Class clazz);
+Tcl_Class		Tcl_GetObjectAsClass(Tcl_Object object);
+Tcl_Command		Tcl_GetObjectCommand(Tcl_Object object);
+Tcl_Object		Tcl_GetObjectFromObj(Tcl_Interp *interp,
+			    Tcl_Obj *objPtr);
+Tcl_Namespace *		Tcl_GetObjectNamespace(Tcl_Object object);
+Tcl_Class		Tcl_MethodDeclarerClass(Tcl_Method method);
+Tcl_Object		Tcl_MethodDeclarerObject(Tcl_Method method);
+int			Tcl_MethodIsPublic(Tcl_Method method);
+int			Tcl_MethodIsType(Tcl_Method method,
+			    const Tcl_MethodType *typePtr,
+			    ClientData *clientDataPtr);
+Tcl_Obj *		Tcl_MethodName(Tcl_Method method);
+Tcl_Method		Tcl_NewMethod(Tcl_Interp *interp, Tcl_Object object,
+			    Tcl_Obj *nameObj, int isPublic,
+			    const Tcl_MethodType *typePtr,
+			    ClientData clientData);
+Tcl_Method		Tcl_NewClassMethod(Tcl_Interp *interp, Tcl_Class cls,
+			    Tcl_Obj *nameObj, int isPublic,
+			    const Tcl_MethodType *typePtr,
+			    ClientData clientData);
+Tcl_Object		Tcl_NewObjectInstance(Tcl_Interp *interp,
+			    Tcl_Class cls, const char *name, int objc,
+			    Tcl_Obj *const *objv, int skip);
+int			Tcl_ObjectDeleted(Tcl_Object object);
+int			Tcl_ObjectContextIsFiltering(
+			    Tcl_ObjectContext context);
+Tcl_Method		Tcl_ObjectContextMethod(Tcl_ObjectContext context);
+Tcl_Object		Tcl_ObjectContextObject(Tcl_ObjectContext context);
+int			Tcl_ObjectContextSkippedArgs(
+			    Tcl_ObjectContext context);
+// ^^^^^^^^^^^^^^^^^^^^^^ MOVE TO TCL.DECLS ^^^^^^^^^^^^^^^^^^^^^^
+
+/*
+ * Forward declarations.
+ */
+
+struct Class;
+struct Object;
+
+/*
+ * The data that needs to be stored per method. This record is used to collect
+ * information about all sorts of methods, including forwards, constructors
+ * and destructors.
+ */
+
+typedef struct Method {
+    const Tcl_MethodType *typePtr;
+				/* The type of method. If NULL, this is a
+				 * special flag record which is just used for
+				 * the setting of the flags field. */
+    ClientData clientData;	/* Type-specific data. */
+    Tcl_Obj *namePtr;		/* Name of the method. */
+    struct Object *declaringObjectPtr;
+				/* The object that declares this method, or
+				 * NULL if it was declared by a class. */
+    struct Class *declaringClassPtr;
+				/* The class that declares this method, or
+				 * NULL if it was declared directly on an
+				 * object. */
+    int flags;			/* Assorted flags. Includes whether this
+				 * method is public/exported or not. */
+} Method;
+
+/*
+ * Procedure-like methods have the following extra information. It is a
+ * single-field structure because this allows for future expansion without
+ * changing vast amounts of code.
+ */
+
+typedef struct ProcedureMethod {
+    Proc *procPtr;
+} ProcedureMethod;
+
+/*
+ * Forwarded methods have the following extra information. It is a
+ * single-field structure because this allows for future expansion without
+ * changing vast amounts of code.
+ */
+
+typedef struct ForwardMethod {
+    Tcl_Obj *prefixObj;
+} ForwardMethod;
+
+/*
+ * Helper definitions that declare a "list" array. The two varieties are
+ * either optimized for simplicity (in the case that the whole array is
+ * typically assigned at once) or efficiency (in the case that the array is
+ * expected to be expanded over time). These lists are designed to be iterated
+ * over with the help of the FOREACH macro (see later in this file).
+ *
+ * The "num" field always counts the number of listType_t elements used in the
+ * "list" field. When a "size" field exists, it describes how many elements
+ * are present in the list; when absent, exactly "num" elements are present.
+ */
+
+#define LIST_STATIC(listType_t) \
+    struct { int num; listType_t *list; }
+#define LIST_DYNAMIC(listType_t) \
+    struct { int num, size; listType_t *list; }
+
+/*
+ * Now, the definition of what an object actually is.
+ */
+
+typedef struct Object {
+    Tcl_Namespace *namespacePtr;/* This object's tame namespace. */
+    Tcl_Command command;	/* Reference to this object's public
+				 * command. */
+    Tcl_Command myCommand;	/* Reference to this object's internal
+				 * command. */
+    struct Class *selfCls;	/* This object's class. */
+    Tcl_HashTable methods;	/* Object-local Tcl_Obj (method name) to
+				 * Method* mapping. */
+    LIST_STATIC(struct Class *) mixins;
+				/* Classes mixed into this object. */
+    LIST_STATIC(Tcl_Obj *) filters;
+				/* List of filter names. */
+    struct Class *classPtr;	/* All classes have this non-NULL; it points
+				 * to the class structure. Everything else has
+				 * this NULL. */
+    int flags;
+    int epoch;			/* Per-object epoch, incremented when the way
+				 * an object should resolve call chains is
+				 * changed. */
+    Tcl_HashTable publicContextCache;	/* Place to keep unused contexts. */
+    Tcl_HashTable privateContextCache;	/* Place to keep unused contexts. */
+} Object;
+
+#define OBJECT_DELETED	1	/* Flag to say that an object has been
+				 * destroyed. */
+#define ROOT_OBJECT 0x1000	/* Flag to say that this object is the root of
+				 * the class hierarchy and should be treated
+				 * specially during teardown. */
+#define FILTER_HANDLING 0x2000	/* Flag set when the object is processing a
+				 * filter; when set, filters are *not*
+				 * processed on the object, preventing nasty
+				 * recursive filtering problems. */
+
+/*
+ * And the definition of a class. Note that every class also has an associated
+ * object, through which it is manipulated.
+ */
+
+typedef struct Class {
+    Object *thisPtr;		/* Reference to the object associated with
+				 * this class. */
+    int flags;			/* Assorted flags. */
+    LIST_STATIC(struct Class *) superclasses;
+				/* List of superclasses, used for generation
+				 * of method call chains. */
+    LIST_DYNAMIC(struct Class *) subclasses;
+				/* List of subclasses, used to ensure deletion
+				 * of dependent entities happens properly when
+				 * the class itself is deleted. */
+    LIST_DYNAMIC(Object *) instances;
+				/* List of instances, used to ensure deletion
+				 * of dependent entities happens properly when
+				 * the class itself is deleted. */
+    LIST_STATIC(Tcl_Obj *) filters;
+				/* List of filter names, used for generation
+				 * of method call chains. */
+    LIST_STATIC(struct Class *) mixins;
+				/* List of mixin classes, used for generation
+				 * of method call chains. */
+    LIST_DYNAMIC(struct Class *) mixinSubs;
+				/* List of classes that this class is mixed
+				 * into, used to ensure deletion of dependent
+				 * entities happens properly when the class
+				 * itself is deleted. */
+    LIST_STATIC(struct Class *) classHierarchy;
+				/* List of classes that comprise the basic
+				 * class hierarchy for this class's
+				 * superclasses. If NULL (and this isn't the
+				 * root object class) then this needs
+				 * recomputing. */
+    int classHierarchyEpoch;	/* Differs from the global epoch when it is
+				 * time to recompute the class hierarchy. */
+    Tcl_HashTable classMethods;	/* Hash table of all methods. Hash maps from
+				 * the (Tcl_Obj*) method name to the (Method*)
+				 * method record. */
+    Method *constructorPtr;	/* Method record of the class constructor (if
+				 * any). */
+    Method *destructorPtr;	/* Method record of the class destructor (if
+				 * any). */
+} Class;
+
+/*
+ * The foundation of the object system within an interpreter contains
+ * references to the key classes and namespaces, together with a few other
+ * useful bits and pieces. Probably ought to eventually go in the Interp
+ * structure itself.
+ */
+
+typedef struct Foundation {
+    Class *objectCls;		/* The root of the object system. */
+    Class *classCls;		/* The class of all classes. */
+    Tcl_Namespace *ooNs;	/* Master ::oo namespace. */
+    Tcl_Namespace *defineNs;	/* Namespace containing special commands for
+				 * manipulating objects and classes. The
+				 * "oo::define" command acts as a special kind
+				 * of ensemble for this namespace. */
+    Tcl_Namespace *helpersNs;	/* Namespace containing the commands that are
+				 * only valid when executing inside a
+				 * procedural method. */
+    int epoch;			/* Used to invalidate method chains when the
+				 * class structure changes. */
+    int nsCount;		/* Counter so we can allocate a unique
+				 * namespace to each object. */
+    Tcl_Obj *unknownMethodNameObj;
+				/* Shared object containing the name of the
+				 * unknown method handler method. */
+} Foundation;
+
+/*
+ * A call context structure is built when a method is called. They contain the
+ * chain of method implementations that are to be invoked by a particular
+ * call, and the process of calling walks the chain, with the [next] command
+ * proceeding to the next entry in the chain.
+ */
+
+#define CALL_CHAIN_STATIC_SIZE 4
+
+struct MInvoke {
+    Method *mPtr;		/* Reference to the method implementation
+				 * record. */
+    int isFilter;		/* Whether this is a filter invokation. */
+};
+
+typedef struct CallContext {
+    Object *oPtr;		/* The object associated with this call. */
+    int globalEpoch;		/* Global (class) epoch counter snapshot. */
+    int localEpoch;		/* Local (single object) epoch counter
+				 * snapshot. */
+    int flags;			/* Assorted flags, see below. */
+    int index;			/* Index into the call chain of the currently
+				 * executing method implementation. */
+    int skip;
+    int numCallChain;		/* Size of the call chain. */
+    struct MInvoke *callChain;	/* Array of call chain entries. May point to
+				 * staticCallChain if the number of entries is
+				 * small. */
+    struct MInvoke staticCallChain[CALL_CHAIN_STATIC_SIZE];
+    int filterLength;		/* Number of entries in the call chain that
+				 * are due to processing filters and not the
+				 * main call chain. */
+} CallContext;
+
+/*
+ * Bits for the 'flags' field of the call context.
+ */
+
+#define OO_UNKNOWN_METHOD	1 /* This is an unknown method. */
+#define PUBLIC_METHOD		2 /* This is a public (exported) method. */
+#define CONSTRUCTOR		4 /* This is a constructor. */
+#define DESTRUCTOR		8 /* This is a destructor. */
+
+/*
+ * Private definitions, some of which perhaps ought to be exposed properly or
+ * maybe just put in the internal stubs table.
+ */
+
+MODULE_SCOPE Method *	TclOONewProcMethod(Tcl_Interp *interp, Object *oPtr,
+			    int isPublic, Tcl_Obj *nameObj, Tcl_Obj *argsObj,
+			    Tcl_Obj *bodyObj);
+MODULE_SCOPE Method *	TclOONewForwardMethod(Tcl_Interp *interp, Object *oPtr,
+			    int isPublic, Tcl_Obj *nameObj,
+			    Tcl_Obj *prefixObj);
+MODULE_SCOPE Method *	TclOONewProcClassMethod(Tcl_Interp *interp,
+			    Class *clsPtr, int isPublic, Tcl_Obj *nameObj,
+			    Tcl_Obj *argsObj, Tcl_Obj *bodyObj);
+MODULE_SCOPE Method *	TclOONewForwardClassMethod(Tcl_Interp *interp,
+			    Class *clsPtr, int isPublic, Tcl_Obj *nameObj,
+			    Tcl_Obj *prefixObj);
+MODULE_SCOPE void	TclOODeleteMethod(Method *method);
+MODULE_SCOPE int	TclObjInterpProcCore(register Tcl_Interp *interp,
+			    CallFrame *framePtr, Tcl_Obj *procNameObj,
+			    int skip);
+MODULE_SCOPE void	TclOOAddToInstances(Object *oPtr, Class *clsPtr);
+MODULE_SCOPE void	TclOOAddToSubclasses(Class *subPtr, Class *superPtr);
+MODULE_SCOPE void	TclOOAddToMixinSubs(Class *subPtr, Class *mixinPtr);
+MODULE_SCOPE Proc *	TclOOGetProcFromMethod(Method *mPtr);
+MODULE_SCOPE Tcl_Obj *	TclOOGetFwdFromMethod(Method *mPtr);
+MODULE_SCOPE int	TclOOIsReachable(Class *targetPtr, Class *startPtr);
+MODULE_SCOPE void	TclOORemoveFromInstances(Object *oPtr, Class *clsPtr);
+MODULE_SCOPE void	TclOORemoveFromSubclasses(Class *subPtr,
+			    Class *superPtr);
+MODULE_SCOPE void	TclOORemoveFromMixinSubs(Class *subPtr,
+			    Class *mixinPtr);
+MODULE_SCOPE void	TclOODeleteContext(CallContext *contextPtr);
+MODULE_SCOPE CallContext *TclOOGetCallContext(Foundation *fPtr, Object *oPtr,
+			    Tcl_Obj *methodNameObj, int flags,
+			    Tcl_HashTable *cachePtr);
+MODULE_SCOPE int	TclOOInvokeContext(Tcl_Interp *interp,
+			    CallContext *contextPtr, int objc,
+			    Tcl_Obj *const *objv);
+MODULE_SCOPE int	TclOOGetSortedMethodList(Object *oPtr,
+			    int publicOnly, const char ***stringsPtr);
+
+/*
+ * A convenience macro for iterating through the lists used in the internal
+ * memory management of objects. This is a bit gnarly because we want to do
+ * the assignment of the picked-out value only when the body test succeeds,
+ * but we cannot rely on the assigned value being useful, forcing us to do
+ * some nasty stuff with the comma operator. The compiler's optimizer should
+ * be able to sort it all out!
+ *
+ * REQUIRES DECLARATION: int i;
+ */
+
+#define FOREACH(var,ary) \
+	for(i=0 ; (i<(ary).num?((var=(ary).list[i]),1):0) ; i++)
+
+/*
+ * Convenience macros for iterating through hash tables. FOREACH_HASH_DECLS
+ * sets up the declarations needed for the main macro, FOREACH_HASH, which
+ * does the actual iteration. FOREACH_HASH_VALUE is a restricted version that
+ * only iterates over values.
+ */
+
+#define FOREACH_HASH_DECLS \
+    Tcl_HashEntry *hPtr;Tcl_HashSearch search
+#define FOREACH_HASH(key,val,tablePtr) \
+    for(hPtr=Tcl_FirstHashEntry((tablePtr),&search); hPtr!=NULL ? \
+	    ((key)=(void *)Tcl_GetHashKey((tablePtr),hPtr),\
+	    (val)=Tcl_GetHashValue(hPtr),1):0; hPtr=Tcl_NextHashEntry(&search))
+#define FOREACH_HASH_VALUE(val,tablePtr) \
+    for(hPtr=Tcl_FirstHashEntry((tablePtr),&search); hPtr!=NULL ? \
+	    ((val)=Tcl_GetHashValue(hPtr),1):0;hPtr=Tcl_NextHashEntry(&search))
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c
index 5f8d008..0361e43 100644
--- a/generic/tclOOCall.c
+++ b/generic/tclOOCall.c
@@ -1,803 +1,803 @@
-/*

- * tclOO.c --

- *

- *	This file contains the method call chain management code for the

- *	object-system core.

- *

- * Copyright (c) 2005-2006 by Donal K. Fellows

- *

- * See the file "license.terms" for information on usage and redistribution of

- * this file, and for a DISCLAIMER OF ALL WARRANTIES.

- *

- * RCS: @(#) $Id: tclOOCall.c,v 1.1.2.1 2006/10/08 15:39:59 dkf Exp $

- */

-

-#include "tclInt.h"

-#include "tclOO.h"

-

-/*

- * Extra flags used for call chain management.

- */

-

-#define DEFINITE_PRIVATE 0x100000

-#define DEFINITE_PUBLIC  0x200000

-#define KNOWN_STATE	 (DEFINITE_PRIVATE | DEFINITE_PUBLIC)

-#define SPECIAL		 (CONSTRUCTOR | DESTRUCTOR)

-

-/*

- * Function declarations for things defined in this file.

- */

-

-static void		AddClassFiltersToCallContext(Object *oPtr,

-			    Class *clsPtr, CallContext *contextPtr,

-			    Tcl_HashTable *doneFilters);

-static void		AddClassMethodNames(Class *clsPtr, int publicOnly,

-			    Tcl_HashTable *namesPtr);

-static void		AddMethodToCallChain(Method *mPtr,

-			    CallContext *contextPtr,

-			    Tcl_HashTable *doneFilters);

-static void		AddSimpleChainToCallContext(Object *oPtr,

-			    Tcl_Obj *methodNameObj, CallContext *contextPtr,

-			    Tcl_HashTable *doneFilters, int isPublic);

-static void		AddSimpleClassChainToCallContext(Class *classPtr,

-			    Tcl_Obj *methodNameObj, CallContext *contextPtr,

-			    Tcl_HashTable *doneFilters, int isPublic);

-static int		CmpStr(const void *ptr1, const void *ptr2);

-static void		InitClassHierarchy(Foundation *fPtr, Class *classPtr);

-

-/*

- * ----------------------------------------------------------------------

- *

- * TclOODeleteContext --

- *

- *	Destroys a method call-chain context, which should not be in use.

- *

- * ----------------------------------------------------------------------

- */

-

-void

-TclOODeleteContext(

-    CallContext *contextPtr)

-{

-    if (contextPtr->callChain != contextPtr->staticCallChain) {

-	ckfree((char *) contextPtr->callChain);

-    }

-    ckfree((char *) contextPtr);

-}

-

-/*

- * ----------------------------------------------------------------------

- *

- * TclOOInvokeContext --

- *

- *	Invokes a single step along a method call-chain context. Note that the

- *	invokation of a step along the chain can cause further steps along the

- *	chain to be invoked. Note that this function is written to be as light

- *	in stack usage as possible.

- *

- * ----------------------------------------------------------------------

- */

-

-int

-TclOOInvokeContext(

-    Tcl_Interp *interp,		/* Interpreter for error reporting, and many

-				 * other sorts of context handling (e.g.,

-				 * commands, variables) depending on method

-				 * implementation. */

-    CallContext *contextPtr,	/* The method call context. */

-    int objc,			/* The number of arguments. */

-    Tcl_Obj *const *objv)	/* The arguments as actually seen. */

-{

-    Method *mPtr = contextPtr->callChain[contextPtr->index].mPtr;

-    int result, isFirst = (contextPtr->index == 0);

-    int isFilter = contextPtr->callChain[contextPtr->index].isFilter;

-    int wasFilter;

-

-    /*

-     * If this is the first step along the chain, we preserve the method

-     * entries in the chain so that they do not get deleted out from under our

-     * feet.

-     */

-

-    if (isFirst) {

-	int i;

-

-	for (i=0 ; i<contextPtr->numCallChain ; i++) {

-	    Tcl_Preserve(contextPtr->callChain[i].mPtr);

-	}

-    }

-

-    /*

-     * Save whether we were in a filter and set up whether we are now.

-     */

-

-    wasFilter = contextPtr->oPtr->flags & FILTER_HANDLING;

-    if (isFilter || contextPtr->flags & FILTER_HANDLING) {

-	contextPtr->oPtr->flags |= FILTER_HANDLING;

-    } else {

-	contextPtr->oPtr->flags &= ~FILTER_HANDLING;

-    }

-

-    /*

-     * Run the method implementation.

-     */

-

-    result = mPtr->typePtr->callProc(mPtr->clientData, interp,

-	    (Tcl_ObjectContext) contextPtr, objc, objv);

-

-    /*

-     * Restore the old filter-ness, release any locks on method

-     * implementations, and return the result code.

-     */

-

-    if (wasFilter) {

-	contextPtr->oPtr->flags |= FILTER_HANDLING;

-    } else {

-	contextPtr->oPtr->flags &= ~FILTER_HANDLING;

-    }

-    if (isFirst) {

-	int i;

-

-	for (i=0 ; i<contextPtr->numCallChain ; i++) {

-	    Tcl_Release(contextPtr->callChain[i].mPtr);

-	}

-    }

-    return result;

-}

-

-static void

-InitClassHierarchy(

-    Foundation *fPtr,

-    Class *classPtr)

-{

-    if (classPtr == fPtr->objectCls) {

-	return;

-    }

-    if (classPtr->classHierarchyEpoch != fPtr->epoch) {

-	int i;

-	Class *superPtr;

-

-	if (classPtr->classHierarchy.num != 0) {

-	    ckfree((char *) classPtr->classHierarchy.list);

-	}

-	FOREACH(superPtr, classPtr->superclasses) {

-	    InitClassHierarchy(fPtr, superPtr);

-	}

-	if (i == 1) {

-	    Class **hierlist = (Class **)

-		    ckalloc(sizeof(Class*) * (1+superPtr->classHierarchy.num));

-

-	    hierlist[0] = superPtr;

-	    memcpy(hierlist+1, superPtr->classHierarchy.list,

-		    sizeof(Class*) * superPtr->classHierarchy.num);

-	    classPtr->classHierarchy.num = 1 + superPtr->classHierarchy.num;

-	    classPtr->classHierarchy.list = hierlist;

-	    classPtr->classHierarchyEpoch = fPtr->epoch;

-	    return;

-	} else {

-	    int num = classPtr->superclasses.num, j = 0, k, realNum;

-	    Class **hierlist;		/* Temporary work space. */

-

-	    FOREACH(superPtr, classPtr->superclasses) {

-		num += superPtr->classHierarchy.num;

-	    }

-	    hierlist = (Class **) ckalloc(sizeof(Class *) * num);

-	    FOREACH(superPtr, classPtr->superclasses) {

-		hierlist[j++] = superPtr;

-		if (superPtr == fPtr->objectCls) {

-		    continue;

-		}

-		memcpy(hierlist+j, superPtr->classHierarchy.list,

-			sizeof(Class *) * superPtr->classHierarchy.num);

-		j += superPtr->classHierarchy.num;

-	    }

-	    realNum = num;

-	    for (j=0 ; j<num-1 ; j++) {

-		for (k=num-1 ; k>j ; k--) {

-		    if (hierlist[j] == hierlist[k]) {

-			hierlist[j] = NULL;

-			realNum--;

-			break;

-		    }

-		}

-	    }

-	    classPtr->classHierarchy.num = realNum;

-	    classPtr->classHierarchy.list = (Class **)

-		    ckalloc(sizeof(Class *) * realNum);

-	    for (j=k=0 ; j<num ; j++) {

-		if (hierlist[j] != NULL) {

-		    classPtr->classHierarchy.list[k++] = hierlist[j];

-		}

-	    }

-	    ckfree((char *) hierlist);

-	}

-    }

-}

-

-/*

- * ----------------------------------------------------------------------

- *

- * TclOOGetSortedMethodList --

- *

- *	Discovers the list of method names supported by an object.

- *

- * ----------------------------------------------------------------------

- */

-

-int

-TclOOGetSortedMethodList(

-    Object *oPtr,		/* The object to get the method names for. */

-    int publicOnly,		/* Whether we just want the public method

-				 * names. */

-    const char ***stringsPtr)	/* Where to write a pointer to the array of

-				 * strings to. */

-{

-    Tcl_HashTable names;

-    FOREACH_HASH_DECLS;

-    int i;

-    const char **strings;

-    Class *mixinPtr;

-    Tcl_Obj *namePtr;

-    Method *mPtr;

-    void *isWanted;

-

-    Tcl_InitObjHashTable(&names);

-

-    FOREACH_HASH(namePtr, mPtr, &oPtr->methods) {

-	int isNew;

-

-	hPtr = Tcl_CreateHashEntry(&names, (char *) namePtr, &isNew);

-	if (isNew) {

-	    isWanted = (void *) (!publicOnly || mPtr->flags & PUBLIC_METHOD);

-	    Tcl_SetHashValue(hPtr, isWanted);

-	}

-    }

-

-    AddClassMethodNames(oPtr->selfCls, publicOnly, &names);

-    FOREACH(mixinPtr, oPtr->mixins) {

-	AddClassMethodNames(mixinPtr, publicOnly, &names);

-    }

-

-    if (names.numEntries == 0) {

-	Tcl_DeleteHashTable(&names);

-	return 0;

-    }

-

-    strings = (const char **) ckalloc(sizeof(char *) * names.numEntries);

-    i = 0;

-    FOREACH_HASH(namePtr, isWanted, &names) {

-	if (!publicOnly || isWanted) {

-	    strings[i++] = TclGetString(namePtr);

-	}

-    }

-

-    /*

-     * Note that 'i' may well be less than names.numEntries when we are

-     * dealing with public method names.

-     */

-

-    qsort(strings, (unsigned) i, sizeof(char *), CmpStr);

-

-    Tcl_DeleteHashTable(&names);

-    *stringsPtr = strings;

-    return i;

-}

-

-/* Comparator for GetSortedMethodList */

-static int

-CmpStr(

-    const void *ptr1,

-    const void *ptr2)

-{

-    const char **strPtr1 = (const char **) ptr1;

-    const char **strPtr2 = (const char **) ptr2;

-

-    return TclpUtfNcmp2(*strPtr1, *strPtr2, strlen(*strPtr1)+1);

-}

-

-/*

- * ----------------------------------------------------------------------

- *

- * AddClassMethodNames --

- *

- *	Adds the method names defined by a class (or its superclasses) to the

- *	collection being built. The collection is built in a hash table to

- *	ensure that duplicates are excluded. Helper for GetSortedMethodList().

- *

- * ----------------------------------------------------------------------

- */

-

-static void

-AddClassMethodNames(

-    Class *clsPtr,		/* Class to get method names from. */

-    const int publicOnly,	/* Whether we are interested in just the

-				 * public method names. */

-    Tcl_HashTable *const namesPtr)

-				/* Reference to the hash table to put the

-				 * information in. The hash table maps the

-				 * Tcl_Obj * method name to an integral value

-				 * describing whether the method is wanted.

-				 * This ensures that public/private override

-				 * semantics are handled correctly.*/

-{

-    /*

-     * Scope all declarations so that the compiler can stand a good chance of

-     * making the recursive step highly efficient. We also hand-implement the

-     * tail-recursive case using a while loop; C compilers typically cannot do

-     * tail-recursion optimization usefully.

-     */

-

-    if (clsPtr->mixins.num != 0) {

-	Class *mixinPtr;

-	int i;

-

-	// TODO: Beware of infinite loops!

-	FOREACH(mixinPtr, clsPtr->mixins) {

-	    AddClassMethodNames(mixinPtr, publicOnly, namesPtr);

-	}

-    }

-

-    while (1) {

-	FOREACH_HASH_DECLS;

-	Tcl_Obj *namePtr;

-	Method *mPtr;

-

-	FOREACH_HASH(namePtr, mPtr, &clsPtr->classMethods) {

-	    int isNew;

-

-	    hPtr = Tcl_CreateHashEntry(namesPtr, (char *) namePtr, &isNew);

-	    if (isNew) {

-		int isWanted = (!publicOnly || mPtr->flags & PUBLIC_METHOD);

-

-		Tcl_SetHashValue(hPtr, (void *) isWanted);

-	    }

-	}

-

-	if (clsPtr->superclasses.num != 1) {

-	    break;

-	}

-	clsPtr = clsPtr->superclasses.list[0];

-    }

-    if (clsPtr->superclasses.num != 0) {

-	Class *superPtr;

-	int i;

-

-	FOREACH(superPtr, clsPtr->superclasses) {

-	    AddClassMethodNames(superPtr, publicOnly, namesPtr);

-	}

-    }

-}

-

-/*

- * ----------------------------------------------------------------------

- *

- * TclOOGetCallContext --

- *

- *	Responsible for constructing the call context, an ordered list of all

- *	method implementations to be called as part of a method invokation.

- *	This method is central to the whole operation of the OO system.

- *

- * ----------------------------------------------------------------------

- */

-

-CallContext *

-TclOOGetCallContext(

-    Foundation *fPtr,		/* The foundation of the object system. */

-    Object *oPtr,		/* The object to get the context for. */

-    Tcl_Obj *methodNameObj,	/* The name of the method to get the context

-				 * for. NULL when getting a constructor or

-				 * destructor chain. */

-    int flags,			/* What sort of context are we looking for.

-				 * Only the bits OO_PUBLIC_METHOD,

-				 * CONSTRUCTOR, DESTRUCTOR and FILTER_HANDLING

-				 * are useful. */

-    Tcl_HashTable *cachePtr)	/* Where to cache the chain. Ignored for both

-				 * constructors and destructors. */

-{

-    CallContext *contextPtr;

-    int i, count, doFilters;

-    Tcl_HashEntry *hPtr;

-    Tcl_HashTable doneFilters;

-

-    if (flags&(SPECIAL|FILTER_HANDLING) || (oPtr->flags&FILTER_HANDLING)) {

-	hPtr = NULL;

-	doFilters = 0;

-    } else {

-	doFilters = 1;

-	hPtr = Tcl_FindHashEntry(cachePtr, (char *) methodNameObj);

-	if (hPtr != NULL && Tcl_GetHashValue(hPtr) != NULL) {

-	    contextPtr = Tcl_GetHashValue(hPtr);

-	    Tcl_SetHashValue(hPtr, NULL);

-	    if ((contextPtr->globalEpoch == fPtr->epoch)

-		    && (contextPtr->localEpoch == oPtr->epoch)) {

-		return contextPtr;

-	    }

-	    TclOODeleteContext(contextPtr);

-	}

-    }

-    contextPtr = (CallContext *) ckalloc(sizeof(CallContext));

-    contextPtr->numCallChain = 0;

-    contextPtr->callChain = contextPtr->staticCallChain;

-    contextPtr->filterLength = 0;

-    contextPtr->globalEpoch = fPtr->epoch;

-    contextPtr->localEpoch = oPtr->epoch;

-    contextPtr->flags = 0;

-    contextPtr->skip = 2;

-    if (flags & (PUBLIC_METHOD | SPECIAL | FILTER_HANDLING)) {

-	contextPtr->flags |= flags & (PUBLIC_METHOD|SPECIAL|FILTER_HANDLING);

-    }

-    contextPtr->oPtr = oPtr;

-    contextPtr->index = 0;

-

-    /*

-     * Ensure that the class hierarchy is trivially iterable.

-     */

-

-    InitClassHierarchy(fPtr, oPtr->selfCls);

-

-    /*

-     * Add all defined filters (if any, and if we're going to be processing

-     * them; they're not processed for constructors, destructors or when we're

-     * in the middle of processing a filter).

-     */

-

-    if (doFilters) {

-	Tcl_Obj *filterObj;

-	Class *mixinPtr;

-

-	doFilters = 1;

-	Tcl_InitObjHashTable(&doneFilters);

-	FOREACH(mixinPtr, oPtr->mixins) {

-	    AddClassFiltersToCallContext(oPtr, mixinPtr, contextPtr,

-		    &doneFilters);

-	}

-	FOREACH(filterObj, oPtr->filters) {

-	    AddSimpleChainToCallContext(oPtr, filterObj, contextPtr,

-		    &doneFilters, 0);

-	}

-	AddClassFiltersToCallContext(oPtr, oPtr->selfCls, contextPtr,

-		&doneFilters);

-	Tcl_DeleteHashTable(&doneFilters);

-    }

-    count = contextPtr->filterLength = contextPtr->numCallChain;

-

-    /*

-     * Add the actual method implementations.

-     */

-

-    AddSimpleChainToCallContext(oPtr, methodNameObj, contextPtr, NULL, flags);

-

-    /*

-     * Check to see if the method has no implementation. If so, we probably

-     * need to add in a call to the unknown method. Otherwise, set up the

-     * cacheing of the method implementation (if relevant).

-     */

-

-    if (count == contextPtr->numCallChain) {

-	/*

-	 * Method does not actually exist. If we're dealing with constructors

-	 * or destructors, this isn't a problem.

-	 */

-

-	if (flags & SPECIAL) {

-	    TclOODeleteContext(contextPtr);

-	    return NULL;

-	}

-	AddSimpleChainToCallContext(oPtr, fPtr->unknownMethodNameObj,

-		contextPtr, NULL, 0);

-	contextPtr->flags |= OO_UNKNOWN_METHOD;

-	contextPtr->globalEpoch = -1;

-	if (count == contextPtr->numCallChain) {

-	    TclOODeleteContext(contextPtr);

-	    return NULL;

-	}

-    } else if (doFilters) {

-	if (hPtr == NULL) {

-	    hPtr = Tcl_CreateHashEntry(cachePtr, (char *) methodNameObj, &i);

-	}

-	Tcl_SetHashValue(hPtr, NULL);

-    }

-    return contextPtr;

-}

-

-/*

- * ----------------------------------------------------------------------

- *

- * AddClassFiltersToCallContext --

- *

- *	Logic to make extracting all the filters from the class context much

- *	easier.

- *

- * ----------------------------------------------------------------------

- */

-

-static void

-AddClassFiltersToCallContext(

-    Object *const oPtr,		/* Object that the filters operate on. */

-    Class *clsPtr,		/* Class to get the filters from. */

-    CallContext *const contextPtr,

-				/* Context to fill with call chain entries. */

-    Tcl_HashTable *const doneFilters)

-				/* Where to record what filters have been

-				 * processed. Keys are objects, values are

-				 * ignored. */

-{

-    int i;

-    Class *superPtr;

-    Tcl_Obj *filterObj;

-

-  tailRecurse:

-    if (clsPtr == NULL) {

-	return;

-    }

-

-    /*

-     * Add all the class filters from the current class. Note that the filters

-     * are added starting at the object root, as this allows the object to

-     * override how filters work to extend their behaviour.

-     */

-

-    FOREACH(filterObj, clsPtr->filters) {

-	int isNew;

-

-	(void) Tcl_CreateHashEntry(doneFilters, (char *) filterObj, &isNew);

-	if (isNew) {

-	    AddSimpleChainToCallContext(oPtr, filterObj, contextPtr,

-		    doneFilters, 0);

-	}

-    }

-

-    /*

-     * Now process the recursive case. Notice the tail-call optimization.

-     */

-

-    switch (clsPtr->superclasses.num) {

-    case 1:

-	clsPtr = clsPtr->superclasses.list[0];

-	goto tailRecurse;

-    default:

-	FOREACH(superPtr, clsPtr->superclasses) {

-	    AddClassFiltersToCallContext(oPtr, superPtr, contextPtr,

-		    doneFilters);

-	}

-    case 0:

-	return;

-    }

-}

-

-/*

- * ----------------------------------------------------------------------

- *

- * AddSimpleChainToCallContext --

- *

- *	The core of the call-chain construction engine, this handles calling a

- *	particular method on a particular object. Note that filters and

- *	unknown handling are already handled by the logic that uses this

- *	function.

- *

- * ----------------------------------------------------------------------

- */

-

-static void

-AddSimpleChainToCallContext(

-    Object *oPtr,		/* Object to add call chain entries for. */

-    Tcl_Obj *methodNameObj,	/* Name of method to add the call chain

-				 * entries for. */

-    CallContext *contextPtr,	/* Where to add the call chain entries. */

-    Tcl_HashTable *doneFilters,	/* Where to record what call chain entries

-				 * have been processed. */

-    int flags)			/* What sort of call chain are we building. */

-{

-    int i;

-

-    if (!(flags & (KNOWN_STATE | SPECIAL))) {

-	Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&oPtr->methods,

-		(char *) methodNameObj);

-

-	if (hPtr != NULL) {

-	    Method *mPtr = Tcl_GetHashValue(hPtr);

-

-	    if (flags & PUBLIC_METHOD) {

-		if (!(mPtr->flags & PUBLIC_METHOD)) {

-		    return;

-		} else {

-		    flags |= DEFINITE_PUBLIC;

-		}

-	    } else {

-		flags |= DEFINITE_PRIVATE;

-	    }

-	}

-    }

-    if (!(flags & SPECIAL)) {

-	Tcl_HashEntry *hPtr;

-	Class *mixinPtr, *superPtr;

-

-	FOREACH(mixinPtr, oPtr->mixins) {

-	    AddSimpleClassChainToCallContext(mixinPtr, methodNameObj,

-		    contextPtr, doneFilters, flags);

-	}

-	FOREACH(mixinPtr, oPtr->selfCls->mixins) {

-	    AddSimpleClassChainToCallContext(mixinPtr, methodNameObj,

-		    contextPtr, doneFilters, flags);

-	}

-	FOREACH(superPtr, oPtr->selfCls->classHierarchy) {

-	    int j=i;// HACK: save index so we can nest FOREACHes

-	    FOREACH(mixinPtr, superPtr->mixins) {

-		AddSimpleClassChainToCallContext(mixinPtr, methodNameObj,

-			contextPtr, doneFilters, flags);

-	    }

-	    i=j;

-	}

-	hPtr = Tcl_FindHashEntry(&oPtr->methods, (char *) methodNameObj);

-	if (hPtr != NULL) {

-	    AddMethodToCallChain(Tcl_GetHashValue(hPtr), contextPtr,

-		    doneFilters);

-	}

-    }

-    AddSimpleClassChainToCallContext(oPtr->selfCls, methodNameObj, contextPtr,

-	    doneFilters, flags);

-}

-

-/*

- * ----------------------------------------------------------------------

- *

- * AddSimpleClassChainToCallContext --

- *

- *	Construct a call-chain from a class hierarchy.

- *

- * ----------------------------------------------------------------------

- */

-

-static void

-AddSimpleClassChainToCallContext(

-    Class *classPtr,		/* Class to add the call chain entries for. */

-    Tcl_Obj *const methodNameObj,

-				/* Name of method to add the call chain

-				 * entries for. */

-    CallContext *const contextPtr,

-				/* Where to add the call chain entries. */

-    Tcl_HashTable *const doneFilters,

-				/* Where to record what call chain entries

-				 * have been processed. */

-    int flags)			/* What sort of call chain are we building. */

-{

-    /*

-     * We hard-code the tail-recursive form. It's by far the most common case

-     * *and* it is much more gentle on the stack.

-     */

-

-  tailRecurse:

-    if (flags & CONSTRUCTOR) {

-	AddMethodToCallChain(classPtr->constructorPtr, contextPtr,

-		doneFilters);

-    } else if (flags & DESTRUCTOR) {

-	AddMethodToCallChain(classPtr->destructorPtr, contextPtr,

-		doneFilters);

-    } else {

-	Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&classPtr->classMethods,

-		(char *) methodNameObj);

-

-	if (hPtr != NULL) {

-	    register Method *mPtr = Tcl_GetHashValue(hPtr);

-

-	    if (!(flags & KNOWN_STATE)) {

-		if (flags & PUBLIC_METHOD) {

-		    if (mPtr->flags & PUBLIC_METHOD) {

-			flags |= DEFINITE_PUBLIC;

-		    } else {

-			return;

-		    }

-		} else {

-		    flags |= DEFINITE_PRIVATE;

-		}

-	    }

-	    AddMethodToCallChain(mPtr, contextPtr, doneFilters);

-	}

-    }

-

-    switch (classPtr->superclasses.num) {

-    case 1:

-	classPtr = classPtr->superclasses.list[0];

-	goto tailRecurse;

-    default:

-    {

-	int i;

-	Class *superPtr;

-

-	FOREACH(superPtr, classPtr->superclasses) {

-	    AddSimpleClassChainToCallContext(superPtr, methodNameObj,

-		    contextPtr, doneFilters, flags);

-	}

-    }

-    case 0:

-	return;

-    }

-}

-

-/*

- * ----------------------------------------------------------------------

- *

- * AddMethodToCallChain --

- *

- *	Utility method that manages the adding of a particular method

- *	implementation to a call-chain.

- *

- * ----------------------------------------------------------------------

- */

-

-static void

-AddMethodToCallChain(

-    Method *mPtr,		/* Actual method implementation to add to call

-				 * chain (or NULL, a no-op). */

-    CallContext *contextPtr,	/* The call chain to add the method

-				 * implementation to. */

-    Tcl_HashTable *doneFilters)	/* Where to record what filters have been

-				 * processed. If NULL, not processing filters.

-				 * Note that this function does not update

-				 * this hashtable. */

-{

-    int i;

-

-    /*

-     * Return if this is just an entry used to record whether this is a public

-     * method. If so, there's nothing real to call and so nothing to add to

-     * the call chain.

-     */

-

-    if (mPtr == NULL || mPtr->typePtr == NULL) {

-	return;

-    }

-

-    /*

-     * First test whether the method is already in the call chain. Skip over

-     * any leading filters.

-     */

-

-    for (i=contextPtr->filterLength ; i<contextPtr->numCallChain ; i++) {

-	if (contextPtr->callChain[i].mPtr == mPtr

-		&& contextPtr->callChain[i].isFilter == (doneFilters!=NULL)) {

-	    /*

-	     * Call chain semantics states that methods come as *late* in the

-	     * call chain as possible. This is done by copying down the

-	     * following methods. Note that this does not change the number of

-	     * method invokations in the call chain; it just rearranges them.

-	     */

-

-	    for (; i+1<contextPtr->numCallChain ; i++) {

-		contextPtr->callChain[i] = contextPtr->callChain[i+1];

-	    }

-	    contextPtr->callChain[i].mPtr = mPtr;

-	    contextPtr->callChain[i].isFilter = (doneFilters != NULL);

-	    return;

-	}

-    }

-

-    /*

-     * Need to really add the method. This is made a bit more complex by the

-     * fact that we are using some "static" space initially, and only start

-     * realloc-ing if the chain gets long.

-     */

-

-    if (contextPtr->numCallChain == CALL_CHAIN_STATIC_SIZE) {

-	contextPtr->callChain = (struct MInvoke *)

-		ckalloc(sizeof(struct MInvoke)*(contextPtr->numCallChain+1));

-	memcpy(contextPtr->callChain, contextPtr->staticCallChain,

-		sizeof(struct MInvoke) * (contextPtr->numCallChain + 1));

-    } else if (contextPtr->numCallChain > CALL_CHAIN_STATIC_SIZE) {

-	contextPtr->callChain = (struct MInvoke *)

-		ckrealloc((char *) contextPtr->callChain,

-		sizeof(struct MInvoke) * (contextPtr->numCallChain + 1));

-    }

-    contextPtr->callChain[contextPtr->numCallChain].mPtr = mPtr;

-    contextPtr->callChain[contextPtr->numCallChain].isFilter =

-	    (doneFilters != NULL);

-    contextPtr->numCallChain++;

-}

-

-/*

- * Local Variables:

- * mode: c

- * c-basic-offset: 4

- * fill-column: 78

- * End:

- */

+/*
+ * tclOO.c --
+ *
+ *	This file contains the method call chain management code for the
+ *	object-system core.
+ *
+ * Copyright (c) 2005-2006 by Donal K. Fellows
+ *
+ * See the file "license.terms" for information on usage and redistribution of
+ * this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * RCS: @(#) $Id: tclOOCall.c,v 1.1.2.2 2006/10/11 02:01:16 dgp Exp $
+ */
+
+#include "tclInt.h"
+#include "tclOO.h"
+
+/*
+ * Extra flags used for call chain management.
+ */
+
+#define DEFINITE_PRIVATE 0x100000
+#define DEFINITE_PUBLIC  0x200000
+#define KNOWN_STATE	 (DEFINITE_PRIVATE | DEFINITE_PUBLIC)
+#define SPECIAL		 (CONSTRUCTOR | DESTRUCTOR)
+
+/*
+ * Function declarations for things defined in this file.
+ */
+
+static void		AddClassFiltersToCallContext(Object *oPtr,
+			    Class *clsPtr, CallContext *contextPtr,
+			    Tcl_HashTable *doneFilters);
+static void		AddClassMethodNames(Class *clsPtr, int publicOnly,
+			    Tcl_HashTable *namesPtr);
+static void		AddMethodToCallChain(Method *mPtr,
+			    CallContext *contextPtr,
+			    Tcl_HashTable *doneFilters);
+static void		AddSimpleChainToCallContext(Object *oPtr,
+			    Tcl_Obj *methodNameObj, CallContext *contextPtr,
+			    Tcl_HashTable *doneFilters, int isPublic);
+static void		AddSimpleClassChainToCallContext(Class *classPtr,
+			    Tcl_Obj *methodNameObj, CallContext *contextPtr,
+			    Tcl_HashTable *doneFilters, int isPublic);
+static int		CmpStr(const void *ptr1, const void *ptr2);
+static void		InitClassHierarchy(Foundation *fPtr, Class *classPtr);
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOODeleteContext --
+ *
+ *	Destroys a method call-chain context, which should not be in use.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+void
+TclOODeleteContext(
+    CallContext *contextPtr)
+{
+    if (contextPtr->callChain != contextPtr->staticCallChain) {
+	ckfree((char *) contextPtr->callChain);
+    }
+    ckfree((char *) contextPtr);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOInvokeContext --
+ *
+ *	Invokes a single step along a method call-chain context. Note that the
+ *	invokation of a step along the chain can cause further steps along the
+ *	chain to be invoked. Note that this function is written to be as light
+ *	in stack usage as possible.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOOInvokeContext(
+    Tcl_Interp *interp,		/* Interpreter for error reporting, and many
+				 * other sorts of context handling (e.g.,
+				 * commands, variables) depending on method
+				 * implementation. */
+    CallContext *contextPtr,	/* The method call context. */
+    int objc,			/* The number of arguments. */
+    Tcl_Obj *const *objv)	/* The arguments as actually seen. */
+{
+    Method *mPtr = contextPtr->callChain[contextPtr->index].mPtr;
+    int result, isFirst = (contextPtr->index == 0);
+    int isFilter = contextPtr->callChain[contextPtr->index].isFilter;
+    int wasFilter;
+
+    /*
+     * If this is the first step along the chain, we preserve the method
+     * entries in the chain so that they do not get deleted out from under our
+     * feet.
+     */
+
+    if (isFirst) {
+	int i;
+
+	for (i=0 ; i<contextPtr->numCallChain ; i++) {
+	    Tcl_Preserve(contextPtr->callChain[i].mPtr);
+	}
+    }
+
+    /*
+     * Save whether we were in a filter and set up whether we are now.
+     */
+
+    wasFilter = contextPtr->oPtr->flags & FILTER_HANDLING;
+    if (isFilter || contextPtr->flags & FILTER_HANDLING) {
+	contextPtr->oPtr->flags |= FILTER_HANDLING;
+    } else {
+	contextPtr->oPtr->flags &= ~FILTER_HANDLING;
+    }
+
+    /*
+     * Run the method implementation.
+     */
+
+    result = mPtr->typePtr->callProc(mPtr->clientData, interp,
+	    (Tcl_ObjectContext) contextPtr, objc, objv);
+
+    /*
+     * Restore the old filter-ness, release any locks on method
+     * implementations, and return the result code.
+     */
+
+    if (wasFilter) {
+	contextPtr->oPtr->flags |= FILTER_HANDLING;
+    } else {
+	contextPtr->oPtr->flags &= ~FILTER_HANDLING;
+    }
+    if (isFirst) {
+	int i;
+
+	for (i=0 ; i<contextPtr->numCallChain ; i++) {
+	    Tcl_Release(contextPtr->callChain[i].mPtr);
+	}
+    }
+    return result;
+}
+
+static void
+InitClassHierarchy(
+    Foundation *fPtr,
+    Class *classPtr)
+{
+    if (classPtr == fPtr->objectCls) {
+	return;
+    }
+    if (classPtr->classHierarchyEpoch != fPtr->epoch) {
+	int i;
+	Class *superPtr;
+
+	if (classPtr->classHierarchy.num != 0) {
+	    ckfree((char *) classPtr->classHierarchy.list);
+	}
+	FOREACH(superPtr, classPtr->superclasses) {
+	    InitClassHierarchy(fPtr, superPtr);
+	}
+	if (i == 1) {
+	    Class **hierlist = (Class **)
+		    ckalloc(sizeof(Class*) * (1+superPtr->classHierarchy.num));
+
+	    hierlist[0] = superPtr;
+	    memcpy(hierlist+1, superPtr->classHierarchy.list,
+		    sizeof(Class*) * superPtr->classHierarchy.num);
+	    classPtr->classHierarchy.num = 1 + superPtr->classHierarchy.num;
+	    classPtr->classHierarchy.list = hierlist;
+	    classPtr->classHierarchyEpoch = fPtr->epoch;
+	    return;
+	} else {
+	    int num = classPtr->superclasses.num, j = 0, k, realNum;
+	    Class **hierlist;		/* Temporary work space. */
+
+	    FOREACH(superPtr, classPtr->superclasses) {
+		num += superPtr->classHierarchy.num;
+	    }
+	    hierlist = (Class **) ckalloc(sizeof(Class *) * num);
+	    FOREACH(superPtr, classPtr->superclasses) {
+		hierlist[j++] = superPtr;
+		if (superPtr == fPtr->objectCls) {
+		    continue;
+		}
+		memcpy(hierlist+j, superPtr->classHierarchy.list,
+			sizeof(Class *) * superPtr->classHierarchy.num);
+		j += superPtr->classHierarchy.num;
+	    }
+	    realNum = num;
+	    for (j=0 ; j<num-1 ; j++) {
+		for (k=num-1 ; k>j ; k--) {
+		    if (hierlist[j] == hierlist[k]) {
+			hierlist[j] = NULL;
+			realNum--;
+			break;
+		    }
+		}
+	    }
+	    classPtr->classHierarchy.num = realNum;
+	    classPtr->classHierarchy.list = (Class **)
+		    ckalloc(sizeof(Class *) * realNum);
+	    for (j=k=0 ; j<num ; j++) {
+		if (hierlist[j] != NULL) {
+		    classPtr->classHierarchy.list[k++] = hierlist[j];
+		}
+	    }
+	    ckfree((char *) hierlist);
+	}
+    }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOGetSortedMethodList --
+ *
+ *	Discovers the list of method names supported by an object.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOOGetSortedMethodList(
+    Object *oPtr,		/* The object to get the method names for. */
+    int publicOnly,		/* Whether we just want the public method
+				 * names. */
+    const char ***stringsPtr)	/* Where to write a pointer to the array of
+				 * strings to. */
+{
+    Tcl_HashTable names;
+    FOREACH_HASH_DECLS;
+    int i;
+    const char **strings;
+    Class *mixinPtr;
+    Tcl_Obj *namePtr;
+    Method *mPtr;
+    void *isWanted;
+
+    Tcl_InitObjHashTable(&names);
+
+    FOREACH_HASH(namePtr, mPtr, &oPtr->methods) {
+	int isNew;
+
+	hPtr = Tcl_CreateHashEntry(&names, (char *) namePtr, &isNew);
+	if (isNew) {
+	    isWanted = (void *) (!publicOnly || mPtr->flags & PUBLIC_METHOD);
+	    Tcl_SetHashValue(hPtr, isWanted);
+	}
+    }
+
+    AddClassMethodNames(oPtr->selfCls, publicOnly, &names);
+    FOREACH(mixinPtr, oPtr->mixins) {
+	AddClassMethodNames(mixinPtr, publicOnly, &names);
+    }
+
+    if (names.numEntries == 0) {
+	Tcl_DeleteHashTable(&names);
+	return 0;
+    }
+
+    strings = (const char **) ckalloc(sizeof(char *) * names.numEntries);
+    i = 0;
+    FOREACH_HASH(namePtr, isWanted, &names) {
+	if (!publicOnly || isWanted) {
+	    strings[i++] = TclGetString(namePtr);
+	}
+    }
+
+    /*
+     * Note that 'i' may well be less than names.numEntries when we are
+     * dealing with public method names.
+     */
+
+    qsort(strings, (unsigned) i, sizeof(char *), CmpStr);
+
+    Tcl_DeleteHashTable(&names);
+    *stringsPtr = strings;
+    return i;
+}
+
+/* Comparator for GetSortedMethodList */
+static int
+CmpStr(
+    const void *ptr1,
+    const void *ptr2)
+{
+    const char **strPtr1 = (const char **) ptr1;
+    const char **strPtr2 = (const char **) ptr2;
+
+    return TclpUtfNcmp2(*strPtr1, *strPtr2, strlen(*strPtr1)+1);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * AddClassMethodNames --
+ *
+ *	Adds the method names defined by a class (or its superclasses) to the
+ *	collection being built. The collection is built in a hash table to
+ *	ensure that duplicates are excluded. Helper for GetSortedMethodList().
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+AddClassMethodNames(
+    Class *clsPtr,		/* Class to get method names from. */
+    const int publicOnly,	/* Whether we are interested in just the
+				 * public method names. */
+    Tcl_HashTable *const namesPtr)
+				/* Reference to the hash table to put the
+				 * information in. The hash table maps the
+				 * Tcl_Obj * method name to an integral value
+				 * describing whether the method is wanted.
+				 * This ensures that public/private override
+				 * semantics are handled correctly.*/
+{
+    /*
+     * Scope all declarations so that the compiler can stand a good chance of
+     * making the recursive step highly efficient. We also hand-implement the
+     * tail-recursive case using a while loop; C compilers typically cannot do
+     * tail-recursion optimization usefully.
+     */
+
+    if (clsPtr->mixins.num != 0) {
+	Class *mixinPtr;
+	int i;
+
+	// TODO: Beware of infinite loops!
+	FOREACH(mixinPtr, clsPtr->mixins) {
+	    AddClassMethodNames(mixinPtr, publicOnly, namesPtr);
+	}
+    }
+
+    while (1) {
+	FOREACH_HASH_DECLS;
+	Tcl_Obj *namePtr;
+	Method *mPtr;
+
+	FOREACH_HASH(namePtr, mPtr, &clsPtr->classMethods) {
+	    int isNew;
+
+	    hPtr = Tcl_CreateHashEntry(namesPtr, (char *) namePtr, &isNew);
+	    if (isNew) {
+		int isWanted = (!publicOnly || mPtr->flags & PUBLIC_METHOD);
+
+		Tcl_SetHashValue(hPtr, (void *) isWanted);
+	    }
+	}
+
+	if (clsPtr->superclasses.num != 1) {
+	    break;
+	}
+	clsPtr = clsPtr->superclasses.list[0];
+    }
+    if (clsPtr->superclasses.num != 0) {
+	Class *superPtr;
+	int i;
+
+	FOREACH(superPtr, clsPtr->superclasses) {
+	    AddClassMethodNames(superPtr, publicOnly, namesPtr);
+	}
+    }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOGetCallContext --
+ *
+ *	Responsible for constructing the call context, an ordered list of all
+ *	method implementations to be called as part of a method invokation.
+ *	This method is central to the whole operation of the OO system.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+CallContext *
+TclOOGetCallContext(
+    Foundation *fPtr,		/* The foundation of the object system. */
+    Object *oPtr,		/* The object to get the context for. */
+    Tcl_Obj *methodNameObj,	/* The name of the method to get the context
+				 * for. NULL when getting a constructor or
+				 * destructor chain. */
+    int flags,			/* What sort of context are we looking for.
+				 * Only the bits OO_PUBLIC_METHOD,
+				 * CONSTRUCTOR, DESTRUCTOR and FILTER_HANDLING
+				 * are useful. */
+    Tcl_HashTable *cachePtr)	/* Where to cache the chain. Ignored for both
+				 * constructors and destructors. */
+{
+    CallContext *contextPtr;
+    int i, count, doFilters;
+    Tcl_HashEntry *hPtr;
+    Tcl_HashTable doneFilters;
+
+    if (flags&(SPECIAL|FILTER_HANDLING) || (oPtr->flags&FILTER_HANDLING)) {
+	hPtr = NULL;
+	doFilters = 0;
+    } else {
+	doFilters = 1;
+	hPtr = Tcl_FindHashEntry(cachePtr, (char *) methodNameObj);
+	if (hPtr != NULL && Tcl_GetHashValue(hPtr) != NULL) {
+	    contextPtr = Tcl_GetHashValue(hPtr);
+	    Tcl_SetHashValue(hPtr, NULL);
+	    if ((contextPtr->globalEpoch == fPtr->epoch)
+		    && (contextPtr->localEpoch == oPtr->epoch)) {
+		return contextPtr;
+	    }
+	    TclOODeleteContext(contextPtr);
+	}
+    }
+    contextPtr = (CallContext *) ckalloc(sizeof(CallContext));
+    contextPtr->numCallChain = 0;
+    contextPtr->callChain = contextPtr->staticCallChain;
+    contextPtr->filterLength = 0;
+    contextPtr->globalEpoch = fPtr->epoch;
+    contextPtr->localEpoch = oPtr->epoch;
+    contextPtr->flags = 0;
+    contextPtr->skip = 2;
+    if (flags & (PUBLIC_METHOD | SPECIAL | FILTER_HANDLING)) {
+	contextPtr->flags |= flags & (PUBLIC_METHOD|SPECIAL|FILTER_HANDLING);
+    }
+    contextPtr->oPtr = oPtr;
+    contextPtr->index = 0;
+
+    /*
+     * Ensure that the class hierarchy is trivially iterable.
+     */
+
+    InitClassHierarchy(fPtr, oPtr->selfCls);
+
+    /*
+     * Add all defined filters (if any, and if we're going to be processing
+     * them; they're not processed for constructors, destructors or when we're
+     * in the middle of processing a filter).
+     */
+
+    if (doFilters) {
+	Tcl_Obj *filterObj;
+	Class *mixinPtr;
+
+	doFilters = 1;
+	Tcl_InitObjHashTable(&doneFilters);
+	FOREACH(mixinPtr, oPtr->mixins) {
+	    AddClassFiltersToCallContext(oPtr, mixinPtr, contextPtr,
+		    &doneFilters);
+	}
+	FOREACH(filterObj, oPtr->filters) {
+	    AddSimpleChainToCallContext(oPtr, filterObj, contextPtr,
+		    &doneFilters, 0);
+	}
+	AddClassFiltersToCallContext(oPtr, oPtr->selfCls, contextPtr,
+		&doneFilters);
+	Tcl_DeleteHashTable(&doneFilters);
+    }
+    count = contextPtr->filterLength = contextPtr->numCallChain;
+
+    /*
+     * Add the actual method implementations.
+     */
+
+    AddSimpleChainToCallContext(oPtr, methodNameObj, contextPtr, NULL, flags);
+
+    /*
+     * Check to see if the method has no implementation. If so, we probably
+     * need to add in a call to the unknown method. Otherwise, set up the
+     * cacheing of the method implementation (if relevant).
+     */
+
+    if (count == contextPtr->numCallChain) {
+	/*
+	 * Method does not actually exist. If we're dealing with constructors
+	 * or destructors, this isn't a problem.
+	 */
+
+	if (flags & SPECIAL) {
+	    TclOODeleteContext(contextPtr);
+	    return NULL;
+	}
+	AddSimpleChainToCallContext(oPtr, fPtr->unknownMethodNameObj,
+		contextPtr, NULL, 0);
+	contextPtr->flags |= OO_UNKNOWN_METHOD;
+	contextPtr->globalEpoch = -1;
+	if (count == contextPtr->numCallChain) {
+	    TclOODeleteContext(contextPtr);
+	    return NULL;
+	}
+    } else if (doFilters) {
+	if (hPtr == NULL) {
+	    hPtr = Tcl_CreateHashEntry(cachePtr, (char *) methodNameObj, &i);
+	}
+	Tcl_SetHashValue(hPtr, NULL);
+    }
+    return contextPtr;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * AddClassFiltersToCallContext --
+ *
+ *	Logic to make extracting all the filters from the class context much
+ *	easier.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+AddClassFiltersToCallContext(
+    Object *const oPtr,		/* Object that the filters operate on. */
+    Class *clsPtr,		/* Class to get the filters from. */
+    CallContext *const contextPtr,
+				/* Context to fill with call chain entries. */
+    Tcl_HashTable *const doneFilters)
+				/* Where to record what filters have been
+				 * processed. Keys are objects, values are
+				 * ignored. */
+{
+    int i;
+    Class *superPtr;
+    Tcl_Obj *filterObj;
+
+  tailRecurse:
+    if (clsPtr == NULL) {
+	return;
+    }
+
+    /*
+     * Add all the class filters from the current class. Note that the filters
+     * are added starting at the object root, as this allows the object to
+     * override how filters work to extend their behaviour.
+     */
+
+    FOREACH(filterObj, clsPtr->filters) {
+	int isNew;
+
+	(void) Tcl_CreateHashEntry(doneFilters, (char *) filterObj, &isNew);
+	if (isNew) {
+	    AddSimpleChainToCallContext(oPtr, filterObj, contextPtr,
+		    doneFilters, 0);
+	}
+    }
+
+    /*
+     * Now process the recursive case. Notice the tail-call optimization.
+     */
+
+    switch (clsPtr->superclasses.num) {
+    case 1:
+	clsPtr = clsPtr->superclasses.list[0];
+	goto tailRecurse;
+    default:
+	FOREACH(superPtr, clsPtr->superclasses) {
+	    AddClassFiltersToCallContext(oPtr, superPtr, contextPtr,
+		    doneFilters);
+	}
+    case 0:
+	return;
+    }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * AddSimpleChainToCallContext --
+ *
+ *	The core of the call-chain construction engine, this handles calling a
+ *	particular method on a particular object. Note that filters and
+ *	unknown handling are already handled by the logic that uses this
+ *	function.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+AddSimpleChainToCallContext(
+    Object *oPtr,		/* Object to add call chain entries for. */
+    Tcl_Obj *methodNameObj,	/* Name of method to add the call chain
+				 * entries for. */
+    CallContext *contextPtr,	/* Where to add the call chain entries. */
+    Tcl_HashTable *doneFilters,	/* Where to record what call chain entries
+				 * have been processed. */
+    int flags)			/* What sort of call chain are we building. */
+{
+    int i;
+
+    if (!(flags & (KNOWN_STATE | SPECIAL))) {
+	Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&oPtr->methods,
+		(char *) methodNameObj);
+
+	if (hPtr != NULL) {
+	    Method *mPtr = Tcl_GetHashValue(hPtr);
+
+	    if (flags & PUBLIC_METHOD) {
+		if (!(mPtr->flags & PUBLIC_METHOD)) {
+		    return;
+		} else {
+		    flags |= DEFINITE_PUBLIC;
+		}
+	    } else {
+		flags |= DEFINITE_PRIVATE;
+	    }
+	}
+    }
+    if (!(flags & SPECIAL)) {
+	Tcl_HashEntry *hPtr;
+	Class *mixinPtr, *superPtr;
+
+	FOREACH(mixinPtr, oPtr->mixins) {
+	    AddSimpleClassChainToCallContext(mixinPtr, methodNameObj,
+		    contextPtr, doneFilters, flags);
+	}
+	FOREACH(mixinPtr, oPtr->selfCls->mixins) {
+	    AddSimpleClassChainToCallContext(mixinPtr, methodNameObj,
+		    contextPtr, doneFilters, flags);
+	}
+	FOREACH(superPtr, oPtr->selfCls->classHierarchy) {
+	    int j=i;// HACK: save index so we can nest FOREACHes
+	    FOREACH(mixinPtr, superPtr->mixins) {
+		AddSimpleClassChainToCallContext(mixinPtr, methodNameObj,
+			contextPtr, doneFilters, flags);
+	    }
+	    i=j;
+	}
+	hPtr = Tcl_FindHashEntry(&oPtr->methods, (char *) methodNameObj);
+	if (hPtr != NULL) {
+	    AddMethodToCallChain(Tcl_GetHashValue(hPtr), contextPtr,
+		    doneFilters);
+	}
+    }
+    AddSimpleClassChainToCallContext(oPtr->selfCls, methodNameObj, contextPtr,
+	    doneFilters, flags);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * AddSimpleClassChainToCallContext --
+ *
+ *	Construct a call-chain from a class hierarchy.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+AddSimpleClassChainToCallContext(
+    Class *classPtr,		/* Class to add the call chain entries for. */
+    Tcl_Obj *const methodNameObj,
+				/* Name of method to add the call chain
+				 * entries for. */
+    CallContext *const contextPtr,
+				/* Where to add the call chain entries. */
+    Tcl_HashTable *const doneFilters,
+				/* Where to record what call chain entries
+				 * have been processed. */
+    int flags)			/* What sort of call chain are we building. */
+{
+    /*
+     * We hard-code the tail-recursive form. It's by far the most common case
+     * *and* it is much more gentle on the stack.
+     */
+
+  tailRecurse:
+    if (flags & CONSTRUCTOR) {
+	AddMethodToCallChain(classPtr->constructorPtr, contextPtr,
+		doneFilters);
+    } else if (flags & DESTRUCTOR) {
+	AddMethodToCallChain(classPtr->destructorPtr, contextPtr,
+		doneFilters);
+    } else {
+	Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&classPtr->classMethods,
+		(char *) methodNameObj);
+
+	if (hPtr != NULL) {
+	    register Method *mPtr = Tcl_GetHashValue(hPtr);
+
+	    if (!(flags & KNOWN_STATE)) {
+		if (flags & PUBLIC_METHOD) {
+		    if (mPtr->flags & PUBLIC_METHOD) {
+			flags |= DEFINITE_PUBLIC;
+		    } else {
+			return;
+		    }
+		} else {
+		    flags |= DEFINITE_PRIVATE;
+		}
+	    }
+	    AddMethodToCallChain(mPtr, contextPtr, doneFilters);
+	}
+    }
+
+    switch (classPtr->superclasses.num) {
+    case 1:
+	classPtr = classPtr->superclasses.list[0];
+	goto tailRecurse;
+    default:
+    {
+	int i;
+	Class *superPtr;
+
+	FOREACH(superPtr, classPtr->superclasses) {
+	    AddSimpleClassChainToCallContext(superPtr, methodNameObj,
+		    contextPtr, doneFilters, flags);
+	}
+    }
+    case 0:
+	return;
+    }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * AddMethodToCallChain --
+ *
+ *	Utility method that manages the adding of a particular method
+ *	implementation to a call-chain.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+AddMethodToCallChain(
+    Method *mPtr,		/* Actual method implementation to add to call
+				 * chain (or NULL, a no-op). */
+    CallContext *contextPtr,	/* The call chain to add the method
+				 * implementation to. */
+    Tcl_HashTable *doneFilters)	/* Where to record what filters have been
+				 * processed. If NULL, not processing filters.
+				 * Note that this function does not update
+				 * this hashtable. */
+{
+    int i;
+
+    /*
+     * Return if this is just an entry used to record whether this is a public
+     * method. If so, there's nothing real to call and so nothing to add to
+     * the call chain.
+     */
+
+    if (mPtr == NULL || mPtr->typePtr == NULL) {
+	return;
+    }
+
+    /*
+     * First test whether the method is already in the call chain. Skip over
+     * any leading filters.
+     */
+
+    for (i=contextPtr->filterLength ; i<contextPtr->numCallChain ; i++) {
+	if (contextPtr->callChain[i].mPtr == mPtr
+		&& contextPtr->callChain[i].isFilter == (doneFilters!=NULL)) {
+	    /*
+	     * Call chain semantics states that methods come as *late* in the
+	     * call chain as possible. This is done by copying down the
+	     * following methods. Note that this does not change the number of
+	     * method invokations in the call chain; it just rearranges them.
+	     */
+
+	    for (; i+1<contextPtr->numCallChain ; i++) {
+		contextPtr->callChain[i] = contextPtr->callChain[i+1];
+	    }
+	    contextPtr->callChain[i].mPtr = mPtr;
+	    contextPtr->callChain[i].isFilter = (doneFilters != NULL);
+	    return;
+	}
+    }
+
+    /*
+     * Need to really add the method. This is made a bit more complex by the
+     * fact that we are using some "static" space initially, and only start
+     * realloc-ing if the chain gets long.
+     */
+
+    if (contextPtr->numCallChain == CALL_CHAIN_STATIC_SIZE) {
+	contextPtr->callChain = (struct MInvoke *)
+		ckalloc(sizeof(struct MInvoke)*(contextPtr->numCallChain+1));
+	memcpy(contextPtr->callChain, contextPtr->staticCallChain,
+		sizeof(struct MInvoke) * (contextPtr->numCallChain + 1));
+    } else if (contextPtr->numCallChain > CALL_CHAIN_STATIC_SIZE) {
+	contextPtr->callChain = (struct MInvoke *)
+		ckrealloc((char *) contextPtr->callChain,
+		sizeof(struct MInvoke) * (contextPtr->numCallChain + 1));
+    }
+    contextPtr->callChain[contextPtr->numCallChain].mPtr = mPtr;
+    contextPtr->callChain[contextPtr->numCallChain].isFilter =
+	    (doneFilters != NULL);
+    contextPtr->numCallChain++;
+}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c
index eed352a..b13192e 100644
--- a/generic/tclOODefineCmds.c
+++ b/generic/tclOODefineCmds.c
@@ -1,1083 +1,1083 @@
-/*

- * tclOODefineCmds.c --

- *

- *	This file contains the implementation of the ::oo::define command,

- *	part of the object-system core (NB: not Tcl_Obj, but ::oo)

- *

- * Copyright (c) 2006 by Donal K. Fellows

- *

- * See the file "license.terms" for information on usage and redistribution of

- * this file, and for a DISCLAIMER OF ALL WARRANTIES.

- *

- * RCS: @(#) $Id: tclOODefineCmds.c,v 1.1.2.24 2006/10/08 15:39:59 dkf Exp $

- */

-

-#include "tclInt.h"

-#include "tclOO.h"

-

-static Method *		CloneClassMethod(Tcl_Interp *interp, Class *clsPtr,

-			    Method *mPtr, Tcl_Obj *namePtr);

-static Method *		CloneObjectMethod(Tcl_Interp *interp, Object *oPtr,

-			    Method *mPtr, Tcl_Obj *namePtr);

-static Object *		GetDefineCmdContext(Tcl_Interp *interp);

-

-int

-TclOODefineObjCmd(

-    ClientData clientData,

-    Tcl_Interp *interp,

-    int objc,

-    Tcl_Obj *const *objv)

-{

-    CallFrame *framePtr, **framePtrPtr;

-    Foundation *fPtr = ((Interp *) interp)->ooFoundation;

-    int result;

-    Object *oPtr;

-

-    if (objc < 3) {

-	Tcl_WrongNumArgs(interp, 1, objv, "objectName arg ?arg ...?");

-	return TCL_ERROR;

-    }

-

-    oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);

-    if (oPtr == NULL) {

-	return TCL_ERROR;

-    }

-

-    /*

-     * Make the oo::define namespace the current namespace and evaluate the

-     * command(s).

-     */

-

-    /* This is needed to satisfy GCC 3.3's strict aliasing rules */

-    framePtrPtr = &framePtr;

-    result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr,

-	    (Tcl_Namespace *) fPtr->defineNs, FRAME_IS_OO_DEFINE);

-    if (result != TCL_OK) {

-	return TCL_ERROR;

-    }

-    framePtr->ooContextPtr = oPtr;

-    framePtr->objc = objc;

-    framePtr->objv = objv;	/* Reference counts do not need to be

-				 * incremented here. */

-

-    if (objc == 3) {

-	result = Tcl_EvalObjEx(interp, objv[2], 0);

-

-	if (result == TCL_ERROR) {

-	    int length;

-	    const char *objName = Tcl_GetStringFromObj(objv[1], &length);

-	    int limit = 200;

-	    int overflow = (length > limit);

-

-	    TclFormatToErrorInfo(interp,

-		    "\n    (in definition script for object \"%.*s%s\" line %d)",

-		    (overflow ? limit : length), objName,

-		    (overflow ? "..." : ""), interp->errorLine);

-	}

-    } else {

-	Tcl_Obj *objPtr, *obj2Ptr, **objs;

-	Interp *iPtr = (Interp *) interp;

-	Tcl_Command cmd;

-	int dummy;

-

-	/*

-	 * More than one argument: fire them through the ensemble processing

-	 * engine so that everything appears to be good and proper in error

-	 * messages. Note that we cannot just concatenate and send through

-	 * Tcl_EvalObjEx, as that doesn't do ensemble processing, and we

-	 * cannot go through Tcl_EvalObjv without the extra work to pre-find

-	 * the command, as that finds command names in the wrong namespace at

-	 * the moment. Ugly!

-	 */

-

-	if (iPtr->ensembleRewrite.sourceObjs == NULL) {

-	    iPtr->ensembleRewrite.sourceObjs = objv;

-	    iPtr->ensembleRewrite.numRemovedObjs = 3;

-	    iPtr->ensembleRewrite.numInsertedObjs = 1;

-	} else {

-	    int ni = iPtr->ensembleRewrite.numInsertedObjs;

-	    if (ni < 3) {

-		iPtr->ensembleRewrite.numRemovedObjs += 3 - ni;

-	    } else {

-		iPtr->ensembleRewrite.numInsertedObjs -= 2;

-	    }

-	}

-

-	/*

-	 * Build the list of arguments using a Tcl_Obj as a workspace. See

-	 * comments above for why these contortions are necessary.

-	 */

-

-	TclNewObj(objPtr);

-	TclNewObj(obj2Ptr);

-	cmd = Tcl_FindCommand(interp, TclGetString(objv[2]), fPtr->defineNs,

-		TCL_NAMESPACE_ONLY);

-	if (cmd == NULL) {

-	    /* punt this case! */

-	    Tcl_AppendObjToObj(obj2Ptr, objv[2]);

-	} else {

-	    Tcl_GetCommandFullName(interp, cmd, obj2Ptr);

-	}

-	Tcl_ListObjAppendElement(NULL, objPtr, obj2Ptr);

-	Tcl_ListObjReplace(NULL, objPtr, 1, 0, objc-3, objv+3);

-	Tcl_ListObjGetElements(NULL, objPtr, &dummy, &objs);

-

-	result = Tcl_EvalObjv(interp, objc-2, objs, TCL_EVAL_INVOKE);

-	TclDecrRefCount(objPtr);

-    }

-

-    /*

-     * Restore the previous "current" namespace.

-     */

-

-    TclPopStackFrame(interp);

-    return result;

-}

-

-static Object *

-GetDefineCmdContext(

-    Tcl_Interp *interp)

-{

-    Interp *iPtr = (Interp *) interp;

-

-    if ((iPtr->framePtr == NULL)

-	    || (iPtr->framePtr->isProcCallFrame != FRAME_IS_OO_DEFINE)) {

-	Tcl_AppendResult(interp, "this command may only be called from within "

-		"the context of the ::oo::define command", NULL);

-	return NULL;

-    }

-    return (Object *) iPtr->framePtr->ooContextPtr;

-}

-

-int

-TclOODefineConstructorObjCmd(

-    ClientData clientData,

-    Tcl_Interp *interp,

-    int objc,

-    Tcl_Obj *const *objv)

-{

-    Object *oPtr;

-    Class *clsPtr;

-    int bodyLength;

-

-    if (objc != 3) {

-	Tcl_WrongNumArgs(interp, 1, objv, "arguments body");

-	return TCL_ERROR;

-    }

-

-    /*

-     * Extract and validate the context, which is the class that we wish to

-     * modify.

-     */

-

-    oPtr = GetDefineCmdContext(interp);

-    if (oPtr == NULL) {

-	return TCL_ERROR;

-    }

-    if (oPtr->classPtr == NULL) {

-	Tcl_AppendResult(interp, "only classes may have constructors defined",

-		NULL);

-	return TCL_ERROR;

-    }

-    clsPtr = oPtr->classPtr;

-

-    (void) Tcl_GetStringFromObj(objv[2], &bodyLength);

-    if (bodyLength > 0) {

-	/*

-	 * Create the method structure.

-	 */

-

-	Method *mPtr;

-

-	mPtr = TclOONewProcClassMethod(interp, clsPtr, 1, NULL, objv[1],

-		objv[2]);

-	if (mPtr == NULL) {

-	    return TCL_ERROR;

-	}

-

-	/*

-	 * Place the method structure in the class record. Note that we might

-	 * not immediately delete the constructor as this might be being done

-	 * during execution of the constructor itself.

-	 */

-

-	TclOODeleteMethod(clsPtr->constructorPtr);

-	clsPtr->constructorPtr = mPtr;

-    } else {

-	/*

-	 * Delete the constructor method record and set the field in the class

-	 * record to NULL.

-	 */

-

-	TclOODeleteMethod(clsPtr->constructorPtr);

-	clsPtr->constructorPtr = NULL;

-    }

-

-    return TCL_OK;

-}

-

-int

-TclOODefineCopyObjCmd(

-    ClientData clientData,

-    Tcl_Interp *interp,

-    int objc,

-    Tcl_Obj *const *objv)

-{

-    Object *oPtr, *o2Ptr;

-    FOREACH_HASH_DECLS;

-    Method *mPtr;

-    Tcl_Obj *keyPtr;

-    int i;

-

-    if (objc > 2) {

-	Tcl_WrongNumArgs(interp, 1, objv, "?targetName?");

-	return TCL_ERROR;

-    }

-

-    oPtr = GetDefineCmdContext(interp);

-    if (oPtr == NULL) {

-	return TCL_ERROR;

-    }

-

-    /*

-     * Create a new object of the correct class. Note that constructors are

-     * not called. Also note that we must resolve the object name ourselves

-     * because we do not want to create the object in the current namespace,

-     * but rather in the context of the namespace of the caller of the overall

-     * [oo::define] command.

-     */

-

-    {

-	char *name;

-	Tcl_DString buffer;

-

-	if (objc == 1) {

-	    name = NULL;

-	} else {

-	    name = TclGetString(objv[1]);

-	    Tcl_DStringInit(&buffer);

-	    if (name[0]!=':' || name[1]!=':') {

-		Interp *iPtr = (Interp *) interp;

-		CallFrame *callerFramePtr = iPtr->varFramePtr->callerVarPtr;

-

-		if (callerFramePtr != NULL) {

-		    Tcl_DStringAppend(&buffer,

-			    callerFramePtr->nsPtr->fullName, -1);

-		}

-		Tcl_DStringAppend(&buffer, "::", 2);

-		Tcl_DStringAppend(&buffer, name, -1);

-		name = Tcl_DStringValue(&buffer);

-	    }

-	}

-	o2Ptr = (Object *) Tcl_NewObjectInstance(interp,

-		(Tcl_Class) oPtr->selfCls, name, -1, NULL, -1);

-	if (name != NULL) {

-	    Tcl_DStringFree(&buffer);

-	}

-    }

-    if (o2Ptr == NULL) {

-	return TCL_ERROR;

-    }

-

-    /*

-     * Copy the methods, mixins and filters.

-     */

-

-    FOREACH_HASH(keyPtr, mPtr, &oPtr->methods) {

-	(void) CloneObjectMethod(interp, o2Ptr, mPtr, keyPtr);

-    }

-    o2Ptr->mixins.num = oPtr->mixins.num;

-    o2Ptr->mixins.list = (Class **) ckalloc(sizeof(Class*) * oPtr->mixins.num);

-    memcpy(o2Ptr->mixins.list, oPtr->mixins.list,

-	    sizeof(Class *) * oPtr->mixins.num);

-    o2Ptr->filters.num = oPtr->filters.num;

-    o2Ptr->filters.list = (Tcl_Obj **)

-	    ckalloc(sizeof(Tcl_Obj *) * oPtr->filters.num);

-    memcpy(o2Ptr->filters.list, oPtr->filters.list,

-	    sizeof(Tcl_Obj *) * oPtr->filters.num);

-    for (i=0 ; i<o2Ptr->filters.num ; i++) {

-	Tcl_IncrRefCount(o2Ptr->filters.list[i]);

-    }

-    o2Ptr->flags = oPtr->flags & ~ROOT_OBJECT;

-

-    /*

-     * Copy the class, if present.

-     */

-

-    if (oPtr->classPtr) {

-	Class *clsPtr = oPtr->classPtr;

-	Class *cls2Ptr = o2Ptr->classPtr;

-	Class *superPtr;

-

-	cls2Ptr->flags = clsPtr->flags;

-	FOREACH(superPtr, cls2Ptr->superclasses) {

-	    TclOORemoveFromSubclasses(cls2Ptr, superPtr);

-	}

-	if (cls2Ptr->superclasses.num) {

-	    cls2Ptr->superclasses.list = (Class **)

-		    ckrealloc((char *) cls2Ptr->superclasses.list,

-		    sizeof(Class *) * clsPtr->superclasses.num);

-	} else {

-	    cls2Ptr->superclasses.list = (Class **)

-		    ckalloc(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);

-	}

-

-	cls2Ptr->filters.num = clsPtr->filters.num;

-	cls2Ptr->filters.list = (Tcl_Obj **)

-		ckalloc(sizeof(Tcl_Obj *) * clsPtr->filters.num);

-	memcpy(cls2Ptr->filters.list, clsPtr->filters.list,

-		sizeof(Tcl_Obj *) * clsPtr->filters.num);

-	for (i=0 ; i<cls2Ptr->filters.num ; i++) {

-	    Tcl_IncrRefCount(cls2Ptr->filters.list[i]);

-	}

-

-	FOREACH_HASH(keyPtr, mPtr, &clsPtr->classMethods) {

-	    (void) CloneClassMethod(interp, cls2Ptr, mPtr, keyPtr);

-	}

-	if (clsPtr->constructorPtr) {

-	    cls2Ptr->constructorPtr = CloneClassMethod(interp, cls2Ptr,

-		    clsPtr->constructorPtr, NULL);

-	}

-	if (clsPtr->destructorPtr) {

-	    cls2Ptr->destructorPtr = CloneClassMethod(interp, cls2Ptr,

-		    clsPtr->destructorPtr, NULL);

-	}

-    }

-

-    /*

-     * Return the name of the cloned object.

-     */

-

-    Tcl_GetCommandFullName(interp, o2Ptr->command, Tcl_GetObjResult(interp));

-    return TCL_OK;

-}

-

-static Method *

-CloneObjectMethod(

-    Tcl_Interp *interp,

-    Object *oPtr,

-    Method *mPtr,

-    Tcl_Obj *namePtr)

-{

-    if (mPtr->typePtr == NULL) {

-	return (Method *) Tcl_NewMethod(interp, (Tcl_Object) oPtr, namePtr,

-		mPtr->flags & PUBLIC_METHOD, NULL, NULL);

-    } else if (mPtr->typePtr->cloneProc) {

-	ClientData newClientData;

-

-	if (mPtr->typePtr->cloneProc(mPtr->clientData,

-		&newClientData) != TCL_OK) {

-	    return NULL;

-	}

-	return (Method *) Tcl_NewMethod(interp, (Tcl_Object) oPtr, namePtr,

-		mPtr->flags & PUBLIC_METHOD, mPtr->typePtr, newClientData);

-    } else {

-	return (Method *) Tcl_NewMethod(interp, (Tcl_Object) oPtr, namePtr,

-		mPtr->flags & PUBLIC_METHOD, mPtr->typePtr, mPtr->clientData);

-    }

-}

-

-static Method *

-CloneClassMethod(

-    Tcl_Interp *interp,

-    Class *clsPtr,

-    Method *mPtr,

-    Tcl_Obj *namePtr)

-{

-    if (mPtr->typePtr == NULL) {

-	return (Method *) Tcl_NewClassMethod(interp, (Tcl_Class) clsPtr,

-		namePtr, mPtr->flags & PUBLIC_METHOD, NULL, NULL);

-    } else if (mPtr->typePtr->cloneProc) {

-	ClientData newClientData;

-

-	if (mPtr->typePtr->cloneProc(mPtr->clientData,

-		&newClientData) != TCL_OK) {

-	    return NULL;

-	}

-	return (Method *) Tcl_NewClassMethod(interp, (Tcl_Class) clsPtr,

-		namePtr, mPtr->flags & PUBLIC_METHOD, mPtr->typePtr,

-		newClientData);

-    } else {

-	return (Method *) Tcl_NewClassMethod(interp, (Tcl_Class) clsPtr,

-		namePtr, mPtr->flags & PUBLIC_METHOD, mPtr->typePtr,

-		mPtr->clientData);

-    }

-}

-

-int

-TclOODefineDestructorObjCmd(

-    ClientData clientData,

-    Tcl_Interp *interp,

-    int objc,

-    Tcl_Obj *const *objv)

-{

-    Object *oPtr;

-    Class *clsPtr;

-    int bodyLength;

-

-    if (objc != 2) {

-	Tcl_WrongNumArgs(interp, 1, objv, "body");

-	return TCL_ERROR;

-    }

-

-    oPtr = GetDefineCmdContext(interp);

-    if (oPtr == NULL) {

-	return TCL_ERROR;

-    }

-    if (oPtr->classPtr == NULL) {

-	Tcl_AppendResult(interp, "only classes may have destructors defined",

-		NULL);

-	return TCL_ERROR;

-    }

-    clsPtr = oPtr->classPtr;

-

-    (void) Tcl_GetStringFromObj(objv[1], &bodyLength);

-    if (bodyLength > 0) {

-	/*

-	 * Create the method structure.

-	 */

-

-	Method *mPtr;

-

-	mPtr = TclOONewProcClassMethod(interp, clsPtr, 1, NULL, NULL,

-		objv[1]);

-	if (mPtr == NULL) {

-	    return TCL_ERROR;

-	}

-

-	/*

-	 * Place the method structure in the class record. Note that we might

-	 * not immediately delete the destructor as this might be being done

-	 * during execution of the destructor itself.

-	 */

-

-	TclOODeleteMethod(clsPtr->destructorPtr);

-	clsPtr->destructorPtr = mPtr;

-    } else {

-	/*

-	 * Delete the destructor method record and set the field in the class

-	 * record to NULL.

-	 */

-

-	TclOODeleteMethod(clsPtr->destructorPtr);

-	clsPtr->destructorPtr = NULL;

-    }

-

-    return TCL_OK;

-}

-

-int

-TclOODefineExportObjCmd(

-    ClientData clientData,

-    Tcl_Interp *interp,

-    int objc,

-    Tcl_Obj *const *objv)

-{

-    int isSelfExport = (clientData != NULL);

-    Object *oPtr;

-    Method *mPtr;

-    Tcl_HashEntry *hPtr;

-    Class *clsPtr;

-    int i, isNew;

-

-    if (objc < 2) {

-	Tcl_WrongNumArgs(interp, 1, objv, "name ?name ...?");

-	return TCL_ERROR;

-    }

-

-    oPtr = GetDefineCmdContext(interp);

-    if (oPtr == NULL) {

-	return TCL_ERROR;

-    }

-    clsPtr = oPtr->classPtr;

-    isSelfExport |= (clsPtr == NULL);

-

-    for (i=1 ; i<objc ; i++) {

-	if (isSelfExport) {

-	    hPtr = Tcl_CreateHashEntry(&oPtr->methods, (char *) objv[i],

-		    &isNew);

-	} else {

-	    hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, (char*) objv[i],

-		    &isNew);

-	}

-

-	if (isNew) {

-	    mPtr = (Method *) ckalloc(sizeof(Method));

-	    memset(mPtr, 0, sizeof(Method));

-	    Tcl_SetHashValue(hPtr, mPtr);

-	} else {

-	    mPtr = Tcl_GetHashValue(hPtr);

-	}

-	mPtr->flags |= PUBLIC_METHOD;

-    }

-    if (isSelfExport) {

-	oPtr->epoch++;

-    } else {

-	((Interp *)interp)->ooFoundation->epoch++;

-    }

-    return TCL_OK;

-}

-

-int

-TclOODefineFilterObjCmd(

-    ClientData clientData,

-    Tcl_Interp *interp,

-    int objc,

-    Tcl_Obj *const *objv)

-{

-    int isSelfFilter = (clientData != NULL);

-    Object *oPtr;

-    int i;

-

-    oPtr = GetDefineCmdContext(interp);

-    if (oPtr == NULL) {

-	return TCL_ERROR;

-    }

-    isSelfFilter |= (oPtr->classPtr == NULL);

-

-    if (!isSelfFilter) {

-	if (oPtr->classPtr->filters.num) {

-	    Tcl_Obj *filterObj;

-

-	    FOREACH(filterObj, oPtr->classPtr->filters) {

-		TclDecrRefCount(filterObj);

-	    }

-	}

-

-	if (objc == 1) {

-	    // deleting filters

-	    ckfree((char *) oPtr->classPtr->filters.list);

-	    oPtr->classPtr->filters.list = NULL;

-	    oPtr->classPtr->filters.num = 0;

-	} else {

-	    // creating filters

-	    Tcl_Obj **filters;

-

-	    if (oPtr->classPtr->filters.num == 0) {

-		filters = (Tcl_Obj **) ckalloc(sizeof(Tcl_Obj *) * (objc-1));

-	    } else {

-		filters = (Tcl_Obj **) ckrealloc(

-			(char *) oPtr->classPtr->filters.list,

-			sizeof(Tcl_Obj *) * (objc-1));

-	    }

-	    for (i=1 ; i<objc ; i++) {

-		filters[i-1] = objv[i];

-		Tcl_IncrRefCount(objv[i]);

-	    }

-	    oPtr->classPtr->filters.list = filters;

-	    oPtr->classPtr->filters.num = objc-1;

-	}

-	// may be many objects affected

-	((Interp *)interp)->ooFoundation->epoch++;

-    } else {

-	if (oPtr->filters.num) {

-	    Tcl_Obj *filterObj;

-

-	    FOREACH(filterObj, oPtr->filters) {

-		TclDecrRefCount(filterObj);

-	    }

-	}

-	if (objc == 1) {

-	    // deleting filters

-	    ckfree((char *) oPtr->filters.list);

-	    oPtr->filters.list = NULL;

-	    oPtr->filters.num = 0;

-	} else {

-	    // creating filters

-	    Tcl_Obj **filters;

-

-	    if (oPtr->filters.num == 0) {

-		filters = (Tcl_Obj **) ckalloc(sizeof(Tcl_Obj *) * (objc-1));

-	    } else {

-		filters = (Tcl_Obj **) ckrealloc((char *) oPtr->filters.list,

-			sizeof(Tcl_Obj *) * (objc-1));

-	    }

-	    for (i=1 ; i<objc ; i++) {

-		filters[i-1] = objv[i];

-		Tcl_IncrRefCount(objv[i]);

-	    }

-	    oPtr->filters.list = filters;

-	    oPtr->filters.num = objc-1;

-	}

-	oPtr->epoch++; // per-object

-    }

-    return TCL_OK;

-}

-

-int

-TclOODefineForwardObjCmd(

-    ClientData clientData,

-    Tcl_Interp *interp,

-    int objc,

-    Tcl_Obj *const *objv)

-{

-    int isSelfForward = (clientData != NULL);

-    Object *oPtr;

-    Method *mPtr;

-    int isPublic;

-    Tcl_Obj *prefixObj;

-

-    if (objc < 3) {

-	Tcl_WrongNumArgs(interp, 1, objv, "name cmdName ?arg ...?");

-	return TCL_ERROR;

-    }

-

-    oPtr = GetDefineCmdContext(interp);

-    if (oPtr == NULL) {

-	return TCL_ERROR;

-    }

-    isSelfForward |= (oPtr->classPtr == NULL);

-    isPublic = Tcl_StringMatch(TclGetString(objv[1]), "[a-z]*");

-

-    /*

-     * Create the method structure.

-     */

-

-    prefixObj = Tcl_NewListObj(objc-2, objv+2);

-    if (isSelfForward) {

-	mPtr = TclOONewForwardMethod(interp, oPtr, isPublic, objv[1],

-		prefixObj);

-    } else {

-	mPtr = TclOONewForwardClassMethod(interp, oPtr->classPtr, isPublic,

-		objv[1], prefixObj);

-    }

-    if (mPtr == NULL) {

-	TclDecrRefCount(prefixObj);

-	return TCL_ERROR;

-    }

-    return TCL_OK;

-}

-

-int

-TclOODefineMethodObjCmd(

-    ClientData clientData,

-    Tcl_Interp *interp,

-    int objc,

-    Tcl_Obj *const *objv)

-{

-    int isSelfMethod = (clientData != NULL);

-    Object *oPtr;

-    int bodyLength;

-

-    if (objc != 4) {

-	Tcl_WrongNumArgs(interp, 1, objv, "name args body");

-	return TCL_ERROR;

-    }

-

-    oPtr = GetDefineCmdContext(interp);

-    if (oPtr == NULL) {

-	return TCL_ERROR;

-    }

-    isSelfMethod |= (oPtr->classPtr == NULL);

-

-    (void) Tcl_GetStringFromObj(objv[3], &bodyLength);

-    if (bodyLength > 0) {

-	/*

-	 * Create the method structure.

-	 */

-

-	Method *mPtr;

-	int isPublic = Tcl_StringMatch(TclGetString(objv[1]), "[a-z]*");

-

-	if (isSelfMethod) {

-	    mPtr = TclOONewProcMethod(interp, oPtr, isPublic, objv[1],

-		    objv[2], objv[3]);

-	} else {

-	    mPtr = TclOONewProcClassMethod(interp, oPtr->classPtr, isPublic,

-		    objv[1], objv[2], objv[3]);

-	}

-	if (mPtr == NULL) {

-	    return TCL_ERROR;

-	}

-    } else {

-	/*

-	 * Delete the method structure from the appropriate hash table.

-	 */

-

-	Tcl_HashEntry *hPtr;

-

-	if (isSelfMethod) {

-	    hPtr = Tcl_FindHashEntry(&oPtr->methods, (char *)objv[1]);

-	} else {

-	    hPtr = Tcl_FindHashEntry(&oPtr->classPtr->classMethods,

-		    (char *)objv[1]);

-	}

-	if (hPtr != NULL) {

-	    Method *mPtr = (Method *) Tcl_GetHashValue(hPtr);

-

-	    Tcl_DeleteHashEntry(hPtr);

-	    TclOODeleteMethod(mPtr);

-	}

-    }

-

-    return TCL_OK;

-}

-

-int

-TclOODefineMixinObjCmd(

-    ClientData clientData,

-    Tcl_Interp *interp,

-    const int objc,

-    Tcl_Obj *const *objv)

-{

-    int isSelfMixin = (clientData != NULL);

-    Object *oPtr = GetDefineCmdContext(interp);

-    Class *mixinPtr;

-    int i;

-

-    if (oPtr == NULL) {

-	return TCL_ERROR;

-    }

-    isSelfMixin |= (oPtr->classPtr == NULL);

-

-    if (isSelfMixin) {

-	if (objc == 1) {

-	    if (oPtr->mixins.num != 0) {

-		FOREACH(mixinPtr, oPtr->mixins) {

-		    TclOORemoveFromInstances(oPtr, mixinPtr);

-		}

-		ckfree((char *) oPtr->mixins.list);

-		oPtr->mixins.num = 0;

-	    }

-	} else {

-	    Class **mixins = (Class **) ckalloc(sizeof(Class *) * (objc-1));

-

-	    for (i=1 ; i<objc ; i++) {

-		Object *o2Ptr;

-

-		o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[i]);

-		if (o2Ptr == NULL) {

-		freeAndErrorSelf:

-		    ckfree((char *) mixins);

-		    return TCL_ERROR;

-		}

-		if (o2Ptr->classPtr == NULL) {

-		    Tcl_AppendResult(interp, "may only mix in classes; \"",

-			    TclGetString(objv[i]), "\" is not a class", NULL);

-		    goto freeAndErrorSelf;

-		}

-		mixins[i-1] = o2Ptr->classPtr;

-	    }

-	    if (oPtr->mixins.num != 0) {

-		FOREACH(mixinPtr, oPtr->mixins) {

-		    TclOORemoveFromInstances(oPtr, mixinPtr);

-		}

-		ckfree((char *) oPtr->mixins.list);

-	    }

-	    oPtr->mixins.num = objc-1;

-	    oPtr->mixins.list = mixins;

-	    FOREACH(mixinPtr, oPtr->mixins) {

-		TclOOAddToInstances(oPtr, mixinPtr);

-	    }

-	}

-	oPtr->epoch++;

-    } else {

-	register Class *clsPtr = oPtr->classPtr;

-

-	if (objc == 1) {

-	    if (clsPtr->mixins.num != 0) {

-		FOREACH(mixinPtr, clsPtr->mixins) {

-		    TclOORemoveFromMixinSubs(clsPtr, mixinPtr);

-		}

-		ckfree((char *) clsPtr->mixins.list);

-		clsPtr->mixins.num = 0;

-	    }

-	} else {

-	    Class **mixins = (Class **) ckalloc(sizeof(Class *) * (objc-1));

-

-	    for (i=1 ; i<objc ; i++) {

-		Object *o2Ptr;

-

-		o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[i]);

-		if (o2Ptr == NULL) {

-		freeAndErrorClass:

-		    ckfree((char *) mixins);

-		    return TCL_ERROR;

-		}

-		if (o2Ptr->classPtr == NULL) {

-		    Tcl_AppendResult(interp, "may only mix in classes; \"",

-			    TclGetString(objv[i]), "\" is not a class", NULL);

-		    goto freeAndErrorClass;

-		}

-		mixins[i-1] = o2Ptr->classPtr;

-	    }

-	    if (clsPtr->mixins.num != 0) {

-		FOREACH(mixinPtr, clsPtr->mixins) {

-		    TclOORemoveFromMixinSubs(clsPtr, mixinPtr);

-		}

-		ckfree((char *) clsPtr->mixins.list);

-	    }

-	    clsPtr->mixins.num = objc-1;

-	    clsPtr->mixins.list = mixins;

-	    FOREACH(mixinPtr, clsPtr->mixins) {

-		TclOOAddToMixinSubs(clsPtr, mixinPtr);

-	    }

-	}

-	((Interp *)interp)->ooFoundation->epoch++;

-    }

-    return TCL_OK;

-}

-

-#ifdef SUPPORT_OO_PARAMETERS

-// Not sure whether we want to retain this in the core oo system since it is

-// easy to add "after market".

-int

-TclOODefineParameterObjCmd(

-    ClientData clientData,

-    Tcl_Interp *interp,

-    int objc,

-    Tcl_Obj *const *objv)

-{

-    Object *oPtr = GetDefineCmdContext(interp);

-

-    if (oPtr == NULL) {

-	return TCL_ERROR;

-    }

-

-    /*

-     * Must nail down the semantics of this!

-     */

-

-    Tcl_AppendResult(interp, "TODO: not yet finished", NULL);

-    return TCL_ERROR;

-}

-#endif

-

-int

-TclOODefineSelfClassObjCmd(

-    ClientData clientData,

-    Tcl_Interp *interp,

-    int objc,

-    Tcl_Obj *const *objv)

-{

-    Object *oPtr, *o2Ptr;

-    Foundation *fPtr = ((Interp *)interp)->ooFoundation;

-

-    /*

-     * Parse the context to get the object to operate on.

-     */

-

-    oPtr = GetDefineCmdContext(interp);

-    if (oPtr == NULL) {

-	return TCL_ERROR;

-    }

-    if (oPtr == fPtr->objectCls->thisPtr) {

-	Tcl_AppendResult(interp,

-		"may not modify the class of the root object", NULL);

-	return TCL_ERROR;

-    }

-    if (oPtr == fPtr->classCls->thisPtr) {

-	Tcl_AppendResult(interp,

-		"may not modify the class of the class of classes", NULL);

-	return TCL_ERROR;

-    }

-

-    /*

-     * Parse the argument to get the class to set the object's class to.

-     */

-

-    if (objc != 2) {

-	Tcl_WrongNumArgs(interp, 1, objv, "className");

-	return TCL_ERROR;

-    }

-    o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);

-    if (o2Ptr == NULL) {

-	return TCL_ERROR;

-    }

-    if (o2Ptr->classPtr == NULL) {

-	Tcl_AppendResult(interp, "the class of an object must be a class",

-		NULL);

-	return TCL_ERROR;

-    }

-

-    /*

-     * Apply semantic checks. In particular, classes and non-classes are not

-     * interchangable (too complicated to do the conversion!) so we must

-     * produce an error if any attempt is made to swap from one to the other.

-     */

-

-    if ((oPtr->classPtr == NULL) == TclOOIsReachable(fPtr->classCls,

-	    o2Ptr->classPtr)) {

-	Tcl_AppendResult(interp, "may not change a ",

-		(oPtr->classPtr==NULL ? "non-" : ""), "class object into a ",

-		(oPtr->classPtr==NULL ? "" : "non-"), "class object", NULL);

-	return TCL_ERROR;

-    }

-

-    /*

-     * Set the object's class.

-     */

-

-    if (oPtr->selfCls != o2Ptr->classPtr) {

-	TclOORemoveFromInstances(oPtr, oPtr->selfCls);

-	oPtr->selfCls = o2Ptr->classPtr;

-	TclOOAddToInstances(oPtr, oPtr->selfCls);

-	if (oPtr->classPtr != NULL) {

-	    fPtr->epoch++;

-	} else {

-	    oPtr->epoch++;

-	}

-    }

-    return TCL_OK;

-}

-

-int

-TclOODefineSuperclassObjCmd(

-    ClientData clientData,

-    Tcl_Interp *interp,

-    int objc,

-    Tcl_Obj *const *objv)

-{

-    Object *oPtr, *o2Ptr;

-    Foundation *fPtr = ((Interp *)interp)->ooFoundation;

-    Class **superclasses, *superPtr;

-    int i, j;

-

-    if (objc < 2) {

-	Tcl_WrongNumArgs(interp, 1, objv, "className ?className ...?");

-	return TCL_ERROR;

-    }

-

-    /*

-     * Get the class to operate on.

-     */

-

-    oPtr = GetDefineCmdContext(interp);

-    if (oPtr == NULL) {

-	return TCL_ERROR;

-    }

-    if (oPtr->classPtr == NULL) {

-	Tcl_AppendResult(interp, "only classes may have superclasses defined",

-		NULL);

-	return TCL_ERROR;

-    }

-    if (oPtr == fPtr->objectCls->thisPtr) {

-	Tcl_AppendResult(interp,

-		"may not modify the superclass of the root object", NULL);

-	return TCL_ERROR;

-    }

-

-    /*

-     * Allocate some working space.

-     */

-

-    superclasses = (Class **) ckalloc(sizeof(Class *) * (objc-1));

-

-    /*

-     * Parse the arguments to get the class to use as superclasses.

-     */

-

-    for (i=0 ; i<objc-1 ; i++) {

-	o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[i+1]);

-	if (o2Ptr == NULL) {

-	    goto failedAfterAlloc;

-	}

-	if (o2Ptr->classPtr == NULL) {

-	    Tcl_AppendResult(interp, "only a class can be a superclass",NULL);

-	    goto failedAfterAlloc;

-	}

-	for (j=0 ; j<i ; j++) {

-	    if (superclasses[j] == o2Ptr->classPtr) {

-		Tcl_AppendResult(interp,

-			"class should only be a direct superclass once",NULL);

-		goto failedAfterAlloc;

-	    }

-	}

-	if (TclOOIsReachable(oPtr->classPtr, o2Ptr->classPtr)) {

-	    Tcl_AppendResult(interp,

-		    "attempt to form circular dependency graph", NULL);

-	failedAfterAlloc:

-	    ckfree((char *) superclasses);

-	    return TCL_ERROR;

-	}

-	superclasses[i] = o2Ptr->classPtr;

-    }

-

-    /*

-     * Install the list of superclasses into the class. Note that this also

-     * involves splicing the class out of the superclasses' subclass list that

-     * it used to be a member of and splicing it into the new superclasses'

-     * subclass list.

-     */

-

-    if (oPtr->classPtr->superclasses.num != 0) {

-	FOREACH(superPtr, oPtr->classPtr->superclasses) {

-	    TclOORemoveFromSubclasses(oPtr->classPtr, superPtr);

-	}

-	ckfree((char *) oPtr->classPtr->superclasses.list);

-    }

-    oPtr->classPtr->superclasses.list = superclasses;

-    oPtr->classPtr->superclasses.num = objc-1;

-    FOREACH(superPtr, oPtr->classPtr->superclasses) {

-	TclOOAddToSubclasses(oPtr->classPtr, superPtr);

-    }

-    fPtr->epoch++;

-

-    return TCL_OK;

-}

-

-int

-TclOODefineUnexportObjCmd(

-    ClientData clientData,

-    Tcl_Interp *interp,

-    int objc,

-    Tcl_Obj *const *objv)

-{

-    int isSelfUnexport = (clientData != NULL);

-    Object *oPtr;

-    Method *mPtr;

-    Tcl_HashEntry *hPtr;

-    Class *clsPtr;

-    int i, isNew;

-

-    if (objc < 2) {

-	Tcl_WrongNumArgs(interp, 1, objv, "name ?name ...?");

-	return TCL_ERROR;

-    }

-

-    oPtr = GetDefineCmdContext(interp);

-    if (oPtr == NULL) {

-	return TCL_ERROR;

-    }

-    clsPtr = oPtr->classPtr;

-    isSelfUnexport |= (oPtr->classPtr == NULL);

-

-    for (i=1 ; i<objc ; i++) {

-	if (isSelfUnexport) {

-	    hPtr = Tcl_CreateHashEntry(&oPtr->methods, (char *) objv[i],

-		    &isNew);

-	} else {

-	    hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, (char*) objv[i],

-		    &isNew);

-	}

-

-	if (isNew) {

-	    mPtr = (Method *) ckalloc(sizeof(Method));

-	    memset(mPtr, 0, sizeof(Method));

-	    Tcl_SetHashValue(hPtr, mPtr);

-	} else {

-	    mPtr = Tcl_GetHashValue(hPtr);

-	}

-	mPtr->flags &= ~PUBLIC_METHOD;

-    }

-    if (isSelfUnexport) {

-	oPtr->epoch++;

-    } else {

-	((Interp *)interp)->ooFoundation->epoch++;

-    }

-    return TCL_OK;

-}

-

-/*

- * Local Variables:

- * mode: c

- * c-basic-offset: 4

- * fill-column: 78

- * End:

- */

+/*
+ * tclOODefineCmds.c --
+ *
+ *	This file contains the implementation of the ::oo::define command,
+ *	part of the object-system core (NB: not Tcl_Obj, but ::oo)
+ *
+ * Copyright (c) 2006 by Donal K. Fellows
+ *
+ * See the file "license.terms" for information on usage and redistribution of
+ * this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * RCS: @(#) $Id: tclOODefineCmds.c,v 1.1.2.25 2006/10/11 02:01:16 dgp Exp $
+ */
+
+#include "tclInt.h"
+#include "tclOO.h"
+
+static Method *		CloneClassMethod(Tcl_Interp *interp, Class *clsPtr,
+			    Method *mPtr, Tcl_Obj *namePtr);
+static Method *		CloneObjectMethod(Tcl_Interp *interp, Object *oPtr,
+			    Method *mPtr, Tcl_Obj *namePtr);
+static Object *		GetDefineCmdContext(Tcl_Interp *interp);
+
+int
+TclOODefineObjCmd(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    CallFrame *framePtr, **framePtrPtr;
+    Foundation *fPtr = ((Interp *) interp)->ooFoundation;
+    int result;
+    Object *oPtr;
+
+    if (objc < 3) {
+	Tcl_WrongNumArgs(interp, 1, objv, "objectName arg ?arg ...?");
+	return TCL_ERROR;
+    }
+
+    oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
+    if (oPtr == NULL) {
+	return TCL_ERROR;
+    }
+
+    /*
+     * Make the oo::define namespace the current namespace and evaluate the
+     * command(s).
+     */
+
+    /* This is needed to satisfy GCC 3.3's strict aliasing rules */
+    framePtrPtr = &framePtr;
+    result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr,
+	    (Tcl_Namespace *) fPtr->defineNs, FRAME_IS_OO_DEFINE);
+    if (result != TCL_OK) {
+	return TCL_ERROR;
+    }
+    framePtr->ooContextPtr = oPtr;
+    framePtr->objc = objc;
+    framePtr->objv = objv;	/* Reference counts do not need to be
+				 * incremented here. */
+
+    if (objc == 3) {
+	result = Tcl_EvalObjEx(interp, objv[2], 0);
+
+	if (result == TCL_ERROR) {
+	    int length;
+	    const char *objName = Tcl_GetStringFromObj(objv[1], &length);
+	    int limit = 200;
+	    int overflow = (length > limit);
+
+	    TclFormatToErrorInfo(interp,
+		    "\n    (in definition script for object \"%.*s%s\" line %d)",
+		    (overflow ? limit : length), objName,
+		    (overflow ? "..." : ""), interp->errorLine);
+	}
+    } else {
+	Tcl_Obj *objPtr, *obj2Ptr, **objs;
+	Interp *iPtr = (Interp *) interp;
+	Tcl_Command cmd;
+	int dummy;
+
+	/*
+	 * More than one argument: fire them through the ensemble processing
+	 * engine so that everything appears to be good and proper in error
+	 * messages. Note that we cannot just concatenate and send through
+	 * Tcl_EvalObjEx, as that doesn't do ensemble processing, and we
+	 * cannot go through Tcl_EvalObjv without the extra work to pre-find
+	 * the command, as that finds command names in the wrong namespace at
+	 * the moment. Ugly!
+	 */
+
+	if (iPtr->ensembleRewrite.sourceObjs == NULL) {
+	    iPtr->ensembleRewrite.sourceObjs = objv;
+	    iPtr->ensembleRewrite.numRemovedObjs = 3;
+	    iPtr->ensembleRewrite.numInsertedObjs = 1;
+	} else {
+	    int ni = iPtr->ensembleRewrite.numInsertedObjs;
+	    if (ni < 3) {
+		iPtr->ensembleRewrite.numRemovedObjs += 3 - ni;
+	    } else {
+		iPtr->ensembleRewrite.numInsertedObjs -= 2;
+	    }
+	}
+
+	/*
+	 * Build the list of arguments using a Tcl_Obj as a workspace. See
+	 * comments above for why these contortions are necessary.
+	 */
+
+	TclNewObj(objPtr);
+	TclNewObj(obj2Ptr);
+	cmd = Tcl_FindCommand(interp, TclGetString(objv[2]), fPtr->defineNs,
+		TCL_NAMESPACE_ONLY);
+	if (cmd == NULL) {
+	    /* punt this case! */
+	    Tcl_AppendObjToObj(obj2Ptr, objv[2]);
+	} else {
+	    Tcl_GetCommandFullName(interp, cmd, obj2Ptr);
+	}
+	Tcl_ListObjAppendElement(NULL, objPtr, obj2Ptr);
+	Tcl_ListObjReplace(NULL, objPtr, 1, 0, objc-3, objv+3);
+	Tcl_ListObjGetElements(NULL, objPtr, &dummy, &objs);
+
+	result = Tcl_EvalObjv(interp, objc-2, objs, TCL_EVAL_INVOKE);
+	TclDecrRefCount(objPtr);
+    }
+
+    /*
+     * Restore the previous "current" namespace.
+     */
+
+    TclPopStackFrame(interp);
+    return result;
+}
+
+static Object *
+GetDefineCmdContext(
+    Tcl_Interp *interp)
+{
+    Interp *iPtr = (Interp *) interp;
+
+    if ((iPtr->framePtr == NULL)
+	    || (iPtr->framePtr->isProcCallFrame != FRAME_IS_OO_DEFINE)) {
+	Tcl_AppendResult(interp, "this command may only be called from within "
+		"the context of the ::oo::define command", NULL);
+	return NULL;
+    }
+    return (Object *) iPtr->framePtr->ooContextPtr;
+}
+
+int
+TclOODefineConstructorObjCmd(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    Object *oPtr;
+    Class *clsPtr;
+    int bodyLength;
+
+    if (objc != 3) {
+	Tcl_WrongNumArgs(interp, 1, objv, "arguments body");
+	return TCL_ERROR;
+    }
+
+    /*
+     * Extract and validate the context, which is the class that we wish to
+     * modify.
+     */
+
+    oPtr = GetDefineCmdContext(interp);
+    if (oPtr == NULL) {
+	return TCL_ERROR;
+    }
+    if (oPtr->classPtr == NULL) {
+	Tcl_AppendResult(interp, "only classes may have constructors defined",
+		NULL);
+	return TCL_ERROR;
+    }
+    clsPtr = oPtr->classPtr;
+
+    (void) Tcl_GetStringFromObj(objv[2], &bodyLength);
+    if (bodyLength > 0) {
+	/*
+	 * Create the method structure.
+	 */
+
+	Method *mPtr;
+
+	mPtr = TclOONewProcClassMethod(interp, clsPtr, 1, NULL, objv[1],
+		objv[2]);
+	if (mPtr == NULL) {
+	    return TCL_ERROR;
+	}
+
+	/*
+	 * Place the method structure in the class record. Note that we might
+	 * not immediately delete the constructor as this might be being done
+	 * during execution of the constructor itself.
+	 */
+
+	TclOODeleteMethod(clsPtr->constructorPtr);
+	clsPtr->constructorPtr = mPtr;
+    } else {
+	/*
+	 * Delete the constructor method record and set the field in the class
+	 * record to NULL.
+	 */
+
+	TclOODeleteMethod(clsPtr->constructorPtr);
+	clsPtr->constructorPtr = NULL;
+    }
+
+    return TCL_OK;
+}
+
+int
+TclOODefineCopyObjCmd(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    Object *oPtr, *o2Ptr;
+    FOREACH_HASH_DECLS;
+    Method *mPtr;
+    Tcl_Obj *keyPtr;
+    int i;
+
+    if (objc > 2) {
+	Tcl_WrongNumArgs(interp, 1, objv, "?targetName?");
+	return TCL_ERROR;
+    }
+
+    oPtr = GetDefineCmdContext(interp);
+    if (oPtr == NULL) {
+	return TCL_ERROR;
+    }
+
+    /*
+     * Create a new object of the correct class. Note that constructors are
+     * not called. Also note that we must resolve the object name ourselves
+     * because we do not want to create the object in the current namespace,
+     * but rather in the context of the namespace of the caller of the overall
+     * [oo::define] command.
+     */
+
+    {
+	char *name;
+	Tcl_DString buffer;
+
+	if (objc == 1) {
+	    name = NULL;
+	} else {
+	    name = TclGetString(objv[1]);
+	    Tcl_DStringInit(&buffer);
+	    if (name[0]!=':' || name[1]!=':') {
+		Interp *iPtr = (Interp *) interp;
+		CallFrame *callerFramePtr = iPtr->varFramePtr->callerVarPtr;
+
+		if (callerFramePtr != NULL) {
+		    Tcl_DStringAppend(&buffer,
+			    callerFramePtr->nsPtr->fullName, -1);
+		}
+		Tcl_DStringAppend(&buffer, "::", 2);
+		Tcl_DStringAppend(&buffer, name, -1);
+		name = Tcl_DStringValue(&buffer);
+	    }
+	}
+	o2Ptr = (Object *) Tcl_NewObjectInstance(interp,
+		(Tcl_Class) oPtr->selfCls, name, -1, NULL, -1);
+	if (name != NULL) {
+	    Tcl_DStringFree(&buffer);
+	}
+    }
+    if (o2Ptr == NULL) {
+	return TCL_ERROR;
+    }
+
+    /*
+     * Copy the methods, mixins and filters.
+     */
+
+    FOREACH_HASH(keyPtr, mPtr, &oPtr->methods) {
+	(void) CloneObjectMethod(interp, o2Ptr, mPtr, keyPtr);
+    }
+    o2Ptr->mixins.num = oPtr->mixins.num;
+    o2Ptr->mixins.list = (Class **) ckalloc(sizeof(Class*) * oPtr->mixins.num);
+    memcpy(o2Ptr->mixins.list, oPtr->mixins.list,
+	    sizeof(Class *) * oPtr->mixins.num);
+    o2Ptr->filters.num = oPtr->filters.num;
+    o2Ptr->filters.list = (Tcl_Obj **)
+	    ckalloc(sizeof(Tcl_Obj *) * oPtr->filters.num);
+    memcpy(o2Ptr->filters.list, oPtr->filters.list,
+	    sizeof(Tcl_Obj *) * oPtr->filters.num);
+    for (i=0 ; i<o2Ptr->filters.num ; i++) {
+	Tcl_IncrRefCount(o2Ptr->filters.list[i]);
+    }
+    o2Ptr->flags = oPtr->flags & ~ROOT_OBJECT;
+
+    /*
+     * Copy the class, if present.
+     */
+
+    if (oPtr->classPtr) {
+	Class *clsPtr = oPtr->classPtr;
+	Class *cls2Ptr = o2Ptr->classPtr;
+	Class *superPtr;
+
+	cls2Ptr->flags = clsPtr->flags;
+	FOREACH(superPtr, cls2Ptr->superclasses) {
+	    TclOORemoveFromSubclasses(cls2Ptr, superPtr);
+	}
+	if (cls2Ptr->superclasses.num) {
+	    cls2Ptr->superclasses.list = (Class **)
+		    ckrealloc((char *) cls2Ptr->superclasses.list,
+		    sizeof(Class *) * clsPtr->superclasses.num);
+	} else {
+	    cls2Ptr->superclasses.list = (Class **)
+		    ckalloc(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);
+	}
+
+	cls2Ptr->filters.num = clsPtr->filters.num;
+	cls2Ptr->filters.list = (Tcl_Obj **)
+		ckalloc(sizeof(Tcl_Obj *) * clsPtr->filters.num);
+	memcpy(cls2Ptr->filters.list, clsPtr->filters.list,
+		sizeof(Tcl_Obj *) * clsPtr->filters.num);
+	for (i=0 ; i<cls2Ptr->filters.num ; i++) {
+	    Tcl_IncrRefCount(cls2Ptr->filters.list[i]);
+	}
+
+	FOREACH_HASH(keyPtr, mPtr, &clsPtr->classMethods) {
+	    (void) CloneClassMethod(interp, cls2Ptr, mPtr, keyPtr);
+	}
+	if (clsPtr->constructorPtr) {
+	    cls2Ptr->constructorPtr = CloneClassMethod(interp, cls2Ptr,
+		    clsPtr->constructorPtr, NULL);
+	}
+	if (clsPtr->destructorPtr) {
+	    cls2Ptr->destructorPtr = CloneClassMethod(interp, cls2Ptr,
+		    clsPtr->destructorPtr, NULL);
+	}
+    }
+
+    /*
+     * Return the name of the cloned object.
+     */
+
+    Tcl_GetCommandFullName(interp, o2Ptr->command, Tcl_GetObjResult(interp));
+    return TCL_OK;
+}
+
+static Method *
+CloneObjectMethod(
+    Tcl_Interp *interp,
+    Object *oPtr,
+    Method *mPtr,
+    Tcl_Obj *namePtr)
+{
+    if (mPtr->typePtr == NULL) {
+	return (Method *) Tcl_NewMethod(interp, (Tcl_Object) oPtr, namePtr,
+		mPtr->flags & PUBLIC_METHOD, NULL, NULL);
+    } else if (mPtr->typePtr->cloneProc) {
+	ClientData newClientData;
+
+	if (mPtr->typePtr->cloneProc(mPtr->clientData,
+		&newClientData) != TCL_OK) {
+	    return NULL;
+	}
+	return (Method *) Tcl_NewMethod(interp, (Tcl_Object) oPtr, namePtr,
+		mPtr->flags & PUBLIC_METHOD, mPtr->typePtr, newClientData);
+    } else {
+	return (Method *) Tcl_NewMethod(interp, (Tcl_Object) oPtr, namePtr,
+		mPtr->flags & PUBLIC_METHOD, mPtr->typePtr, mPtr->clientData);
+    }
+}
+
+static Method *
+CloneClassMethod(
+    Tcl_Interp *interp,
+    Class *clsPtr,
+    Method *mPtr,
+    Tcl_Obj *namePtr)
+{
+    if (mPtr->typePtr == NULL) {
+	return (Method *) Tcl_NewClassMethod(interp, (Tcl_Class) clsPtr,
+		namePtr, mPtr->flags & PUBLIC_METHOD, NULL, NULL);
+    } else if (mPtr->typePtr->cloneProc) {
+	ClientData newClientData;
+
+	if (mPtr->typePtr->cloneProc(mPtr->clientData,
+		&newClientData) != TCL_OK) {
+	    return NULL;
+	}
+	return (Method *) Tcl_NewClassMethod(interp, (Tcl_Class) clsPtr,
+		namePtr, mPtr->flags & PUBLIC_METHOD, mPtr->typePtr,
+		newClientData);
+    } else {
+	return (Method *) Tcl_NewClassMethod(interp, (Tcl_Class) clsPtr,
+		namePtr, mPtr->flags & PUBLIC_METHOD, mPtr->typePtr,
+		mPtr->clientData);
+    }
+}
+
+int
+TclOODefineDestructorObjCmd(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    Object *oPtr;
+    Class *clsPtr;
+    int bodyLength;
+
+    if (objc != 2) {
+	Tcl_WrongNumArgs(interp, 1, objv, "body");
+	return TCL_ERROR;
+    }
+
+    oPtr = GetDefineCmdContext(interp);
+    if (oPtr == NULL) {
+	return TCL_ERROR;
+    }
+    if (oPtr->classPtr == NULL) {
+	Tcl_AppendResult(interp, "only classes may have destructors defined",
+		NULL);
+	return TCL_ERROR;
+    }
+    clsPtr = oPtr->classPtr;
+
+    (void) Tcl_GetStringFromObj(objv[1], &bodyLength);
+    if (bodyLength > 0) {
+	/*
+	 * Create the method structure.
+	 */
+
+	Method *mPtr;
+
+	mPtr = TclOONewProcClassMethod(interp, clsPtr, 1, NULL, NULL,
+		objv[1]);
+	if (mPtr == NULL) {
+	    return TCL_ERROR;
+	}
+
+	/*
+	 * Place the method structure in the class record. Note that we might
+	 * not immediately delete the destructor as this might be being done
+	 * during execution of the destructor itself.
+	 */
+
+	TclOODeleteMethod(clsPtr->destructorPtr);
+	clsPtr->destructorPtr = mPtr;
+    } else {
+	/*
+	 * Delete the destructor method record and set the field in the class
+	 * record to NULL.
+	 */
+
+	TclOODeleteMethod(clsPtr->destructorPtr);
+	clsPtr->destructorPtr = NULL;
+    }
+
+    return TCL_OK;
+}
+
+int
+TclOODefineExportObjCmd(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    int isSelfExport = (clientData != NULL);
+    Object *oPtr;
+    Method *mPtr;
+    Tcl_HashEntry *hPtr;
+    Class *clsPtr;
+    int i, isNew;
+
+    if (objc < 2) {
+	Tcl_WrongNumArgs(interp, 1, objv, "name ?name ...?");
+	return TCL_ERROR;
+    }
+
+    oPtr = GetDefineCmdContext(interp);
+    if (oPtr == NULL) {
+	return TCL_ERROR;
+    }
+    clsPtr = oPtr->classPtr;
+    isSelfExport |= (clsPtr == NULL);
+
+    for (i=1 ; i<objc ; i++) {
+	if (isSelfExport) {
+	    hPtr = Tcl_CreateHashEntry(&oPtr->methods, (char *) objv[i],
+		    &isNew);
+	} else {
+	    hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, (char*) objv[i],
+		    &isNew);
+	}
+
+	if (isNew) {
+	    mPtr = (Method *) ckalloc(sizeof(Method));
+	    memset(mPtr, 0, sizeof(Method));
+	    Tcl_SetHashValue(hPtr, mPtr);
+	} else {
+	    mPtr = Tcl_GetHashValue(hPtr);
+	}
+	mPtr->flags |= PUBLIC_METHOD;
+    }
+    if (isSelfExport) {
+	oPtr->epoch++;
+    } else {
+	((Interp *)interp)->ooFoundation->epoch++;
+    }
+    return TCL_OK;
+}
+
+int
+TclOODefineFilterObjCmd(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    int isSelfFilter = (clientData != NULL);
+    Object *oPtr;
+    int i;
+
+    oPtr = GetDefineCmdContext(interp);
+    if (oPtr == NULL) {
+	return TCL_ERROR;
+    }
+    isSelfFilter |= (oPtr->classPtr == NULL);
+
+    if (!isSelfFilter) {
+	if (oPtr->classPtr->filters.num) {
+	    Tcl_Obj *filterObj;
+
+	    FOREACH(filterObj, oPtr->classPtr->filters) {
+		TclDecrRefCount(filterObj);
+	    }
+	}
+
+	if (objc == 1) {
+	    // deleting filters
+	    ckfree((char *) oPtr->classPtr->filters.list);
+	    oPtr->classPtr->filters.list = NULL;
+	    oPtr->classPtr->filters.num = 0;
+	} else {
+	    // creating filters
+	    Tcl_Obj **filters;
+
+	    if (oPtr->classPtr->filters.num == 0) {
+		filters = (Tcl_Obj **) ckalloc(sizeof(Tcl_Obj *) * (objc-1));
+	    } else {
+		filters = (Tcl_Obj **) ckrealloc(
+			(char *) oPtr->classPtr->filters.list,
+			sizeof(Tcl_Obj *) * (objc-1));
+	    }
+	    for (i=1 ; i<objc ; i++) {
+		filters[i-1] = objv[i];
+		Tcl_IncrRefCount(objv[i]);
+	    }
+	    oPtr->classPtr->filters.list = filters;
+	    oPtr->classPtr->filters.num = objc-1;
+	}
+	// may be many objects affected
+	((Interp *)interp)->ooFoundation->epoch++;
+    } else {
+	if (oPtr->filters.num) {
+	    Tcl_Obj *filterObj;
+
+	    FOREACH(filterObj, oPtr->filters) {
+		TclDecrRefCount(filterObj);
+	    }
+	}
+	if (objc == 1) {
+	    // deleting filters
+	    ckfree((char *) oPtr->filters.list);
+	    oPtr->filters.list = NULL;
+	    oPtr->filters.num = 0;
+	} else {
+	    // creating filters
+	    Tcl_Obj **filters;
+
+	    if (oPtr->filters.num == 0) {
+		filters = (Tcl_Obj **) ckalloc(sizeof(Tcl_Obj *) * (objc-1));
+	    } else {
+		filters = (Tcl_Obj **) ckrealloc((char *) oPtr->filters.list,
+			sizeof(Tcl_Obj *) * (objc-1));
+	    }
+	    for (i=1 ; i<objc ; i++) {
+		filters[i-1] = objv[i];
+		Tcl_IncrRefCount(objv[i]);
+	    }
+	    oPtr->filters.list = filters;
+	    oPtr->filters.num = objc-1;
+	}
+	oPtr->epoch++; // per-object
+    }
+    return TCL_OK;
+}
+
+int
+TclOODefineForwardObjCmd(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    int isSelfForward = (clientData != NULL);
+    Object *oPtr;
+    Method *mPtr;
+    int isPublic;
+    Tcl_Obj *prefixObj;
+
+    if (objc < 3) {
+	Tcl_WrongNumArgs(interp, 1, objv, "name cmdName ?arg ...?");
+	return TCL_ERROR;
+    }
+
+    oPtr = GetDefineCmdContext(interp);
+    if (oPtr == NULL) {
+	return TCL_ERROR;
+    }
+    isSelfForward |= (oPtr->classPtr == NULL);
+    isPublic = Tcl_StringMatch(TclGetString(objv[1]), "[a-z]*");
+
+    /*
+     * Create the method structure.
+     */
+
+    prefixObj = Tcl_NewListObj(objc-2, objv+2);
+    if (isSelfForward) {
+	mPtr = TclOONewForwardMethod(interp, oPtr, isPublic, objv[1],
+		prefixObj);
+    } else {
+	mPtr = TclOONewForwardClassMethod(interp, oPtr->classPtr, isPublic,
+		objv[1], prefixObj);
+    }
+    if (mPtr == NULL) {
+	TclDecrRefCount(prefixObj);
+	return TCL_ERROR;
+    }
+    return TCL_OK;
+}
+
+int
+TclOODefineMethodObjCmd(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    int isSelfMethod = (clientData != NULL);
+    Object *oPtr;
+    int bodyLength;
+
+    if (objc != 4) {
+	Tcl_WrongNumArgs(interp, 1, objv, "name args body");
+	return TCL_ERROR;
+    }
+
+    oPtr = GetDefineCmdContext(interp);
+    if (oPtr == NULL) {
+	return TCL_ERROR;
+    }
+    isSelfMethod |= (oPtr->classPtr == NULL);
+
+    (void) Tcl_GetStringFromObj(objv[3], &bodyLength);
+    if (bodyLength > 0) {
+	/*
+	 * Create the method structure.
+	 */
+
+	Method *mPtr;
+	int isPublic = Tcl_StringMatch(TclGetString(objv[1]), "[a-z]*");
+
+	if (isSelfMethod) {
+	    mPtr = TclOONewProcMethod(interp, oPtr, isPublic, objv[1],
+		    objv[2], objv[3]);
+	} else {
+	    mPtr = TclOONewProcClassMethod(interp, oPtr->classPtr, isPublic,
+		    objv[1], objv[2], objv[3]);
+	}
+	if (mPtr == NULL) {
+	    return TCL_ERROR;
+	}
+    } else {
+	/*
+	 * Delete the method structure from the appropriate hash table.
+	 */
+
+	Tcl_HashEntry *hPtr;
+
+	if (isSelfMethod) {
+	    hPtr = Tcl_FindHashEntry(&oPtr->methods, (char *)objv[1]);
+	} else {
+	    hPtr = Tcl_FindHashEntry(&oPtr->classPtr->classMethods,
+		    (char *)objv[1]);
+	}
+	if (hPtr != NULL) {
+	    Method *mPtr = (Method *) Tcl_GetHashValue(hPtr);
+
+	    Tcl_DeleteHashEntry(hPtr);
+	    TclOODeleteMethod(mPtr);
+	}
+    }
+
+    return TCL_OK;
+}
+
+int
+TclOODefineMixinObjCmd(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    const int objc,
+    Tcl_Obj *const *objv)
+{
+    int isSelfMixin = (clientData != NULL);
+    Object *oPtr = GetDefineCmdContext(interp);
+    Class *mixinPtr;
+    int i;
+
+    if (oPtr == NULL) {
+	return TCL_ERROR;
+    }
+    isSelfMixin |= (oPtr->classPtr == NULL);
+
+    if (isSelfMixin) {
+	if (objc == 1) {
+	    if (oPtr->mixins.num != 0) {
+		FOREACH(mixinPtr, oPtr->mixins) {
+		    TclOORemoveFromInstances(oPtr, mixinPtr);
+		}
+		ckfree((char *) oPtr->mixins.list);
+		oPtr->mixins.num = 0;
+	    }
+	} else {
+	    Class **mixins = (Class **) ckalloc(sizeof(Class *) * (objc-1));
+
+	    for (i=1 ; i<objc ; i++) {
+		Object *o2Ptr;
+
+		o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[i]);
+		if (o2Ptr == NULL) {
+		freeAndErrorSelf:
+		    ckfree((char *) mixins);
+		    return TCL_ERROR;
+		}
+		if (o2Ptr->classPtr == NULL) {
+		    Tcl_AppendResult(interp, "may only mix in classes; \"",
+			    TclGetString(objv[i]), "\" is not a class", NULL);
+		    goto freeAndErrorSelf;
+		}
+		mixins[i-1] = o2Ptr->classPtr;
+	    }
+	    if (oPtr->mixins.num != 0) {
+		FOREACH(mixinPtr, oPtr->mixins) {
+		    TclOORemoveFromInstances(oPtr, mixinPtr);
+		}
+		ckfree((char *) oPtr->mixins.list);
+	    }
+	    oPtr->mixins.num = objc-1;
+	    oPtr->mixins.list = mixins;
+	    FOREACH(mixinPtr, oPtr->mixins) {
+		TclOOAddToInstances(oPtr, mixinPtr);
+	    }
+	}
+	oPtr->epoch++;
+    } else {
+	register Class *clsPtr = oPtr->classPtr;
+
+	if (objc == 1) {
+	    if (clsPtr->mixins.num != 0) {
+		FOREACH(mixinPtr, clsPtr->mixins) {
+		    TclOORemoveFromMixinSubs(clsPtr, mixinPtr);
+		}
+		ckfree((char *) clsPtr->mixins.list);
+		clsPtr->mixins.num = 0;
+	    }
+	} else {
+	    Class **mixins = (Class **) ckalloc(sizeof(Class *) * (objc-1));
+
+	    for (i=1 ; i<objc ; i++) {
+		Object *o2Ptr;
+
+		o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[i]);
+		if (o2Ptr == NULL) {
+		freeAndErrorClass:
+		    ckfree((char *) mixins);
+		    return TCL_ERROR;
+		}
+		if (o2Ptr->classPtr == NULL) {
+		    Tcl_AppendResult(interp, "may only mix in classes; \"",
+			    TclGetString(objv[i]), "\" is not a class", NULL);
+		    goto freeAndErrorClass;
+		}
+		mixins[i-1] = o2Ptr->classPtr;
+	    }
+	    if (clsPtr->mixins.num != 0) {
+		FOREACH(mixinPtr, clsPtr->mixins) {
+		    TclOORemoveFromMixinSubs(clsPtr, mixinPtr);
+		}
+		ckfree((char *) clsPtr->mixins.list);
+	    }
+	    clsPtr->mixins.num = objc-1;
+	    clsPtr->mixins.list = mixins;
+	    FOREACH(mixinPtr, clsPtr->mixins) {
+		TclOOAddToMixinSubs(clsPtr, mixinPtr);
+	    }
+	}
+	((Interp *)interp)->ooFoundation->epoch++;
+    }
+    return TCL_OK;
+}
+
+#ifdef SUPPORT_OO_PARAMETERS
+// Not sure whether we want to retain this in the core oo system since it is
+// easy to add "after market".
+int
+TclOODefineParameterObjCmd(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    Object *oPtr = GetDefineCmdContext(interp);
+
+    if (oPtr == NULL) {
+	return TCL_ERROR;
+    }
+
+    /*
+     * Must nail down the semantics of this!
+     */
+
+    Tcl_AppendResult(interp, "TODO: not yet finished", NULL);
+    return TCL_ERROR;
+}
+#endif
+
+int
+TclOODefineSelfClassObjCmd(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    Object *oPtr, *o2Ptr;
+    Foundation *fPtr = ((Interp *)interp)->ooFoundation;
+
+    /*
+     * Parse the context to get the object to operate on.
+     */
+
+    oPtr = GetDefineCmdContext(interp);
+    if (oPtr == NULL) {
+	return TCL_ERROR;
+    }
+    if (oPtr == fPtr->objectCls->thisPtr) {
+	Tcl_AppendResult(interp,
+		"may not modify the class of the root object", NULL);
+	return TCL_ERROR;
+    }
+    if (oPtr == fPtr->classCls->thisPtr) {
+	Tcl_AppendResult(interp,
+		"may not modify the class of the class of classes", NULL);
+	return TCL_ERROR;
+    }
+
+    /*
+     * Parse the argument to get the class to set the object's class to.
+     */
+
+    if (objc != 2) {
+	Tcl_WrongNumArgs(interp, 1, objv, "className");
+	return TCL_ERROR;
+    }
+    o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
+    if (o2Ptr == NULL) {
+	return TCL_ERROR;
+    }
+    if (o2Ptr->classPtr == NULL) {
+	Tcl_AppendResult(interp, "the class of an object must be a class",
+		NULL);
+	return TCL_ERROR;
+    }
+
+    /*
+     * Apply semantic checks. In particular, classes and non-classes are not
+     * interchangable (too complicated to do the conversion!) so we must
+     * produce an error if any attempt is made to swap from one to the other.
+     */
+
+    if ((oPtr->classPtr == NULL) == TclOOIsReachable(fPtr->classCls,
+	    o2Ptr->classPtr)) {
+	Tcl_AppendResult(interp, "may not change a ",
+		(oPtr->classPtr==NULL ? "non-" : ""), "class object into a ",
+		(oPtr->classPtr==NULL ? "" : "non-"), "class object", NULL);
+	return TCL_ERROR;
+    }
+
+    /*
+     * Set the object's class.
+     */
+
+    if (oPtr->selfCls != o2Ptr->classPtr) {
+	TclOORemoveFromInstances(oPtr, oPtr->selfCls);
+	oPtr->selfCls = o2Ptr->classPtr;
+	TclOOAddToInstances(oPtr, oPtr->selfCls);
+	if (oPtr->classPtr != NULL) {
+	    fPtr->epoch++;
+	} else {
+	    oPtr->epoch++;
+	}
+    }
+    return TCL_OK;
+}
+
+int
+TclOODefineSuperclassObjCmd(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    Object *oPtr, *o2Ptr;
+    Foundation *fPtr = ((Interp *)interp)->ooFoundation;
+    Class **superclasses, *superPtr;
+    int i, j;
+
+    if (objc < 2) {
+	Tcl_WrongNumArgs(interp, 1, objv, "className ?className ...?");
+	return TCL_ERROR;
+    }
+
+    /*
+     * Get the class to operate on.
+     */
+
+    oPtr = GetDefineCmdContext(interp);
+    if (oPtr == NULL) {
+	return TCL_ERROR;
+    }
+    if (oPtr->classPtr == NULL) {
+	Tcl_AppendResult(interp, "only classes may have superclasses defined",
+		NULL);
+	return TCL_ERROR;
+    }
+    if (oPtr == fPtr->objectCls->thisPtr) {
+	Tcl_AppendResult(interp,
+		"may not modify the superclass of the root object", NULL);
+	return TCL_ERROR;
+    }
+
+    /*
+     * Allocate some working space.
+     */
+
+    superclasses = (Class **) ckalloc(sizeof(Class *) * (objc-1));
+
+    /*
+     * Parse the arguments to get the class to use as superclasses.
+     */
+
+    for (i=0 ; i<objc-1 ; i++) {
+	o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[i+1]);
+	if (o2Ptr == NULL) {
+	    goto failedAfterAlloc;
+	}
+	if (o2Ptr->classPtr == NULL) {
+	    Tcl_AppendResult(interp, "only a class can be a superclass",NULL);
+	    goto failedAfterAlloc;
+	}
+	for (j=0 ; j<i ; j++) {
+	    if (superclasses[j] == o2Ptr->classPtr) {
+		Tcl_AppendResult(interp,
+			"class should only be a direct superclass once",NULL);
+		goto failedAfterAlloc;
+	    }
+	}
+	if (TclOOIsReachable(oPtr->classPtr, o2Ptr->classPtr)) {
+	    Tcl_AppendResult(interp,
+		    "attempt to form circular dependency graph", NULL);
+	failedAfterAlloc:
+	    ckfree((char *) superclasses);
+	    return TCL_ERROR;
+	}
+	superclasses[i] = o2Ptr->classPtr;
+    }
+
+    /*
+     * Install the list of superclasses into the class. Note that this also
+     * involves splicing the class out of the superclasses' subclass list that
+     * it used to be a member of and splicing it into the new superclasses'
+     * subclass list.
+     */
+
+    if (oPtr->classPtr->superclasses.num != 0) {
+	FOREACH(superPtr, oPtr->classPtr->superclasses) {
+	    TclOORemoveFromSubclasses(oPtr->classPtr, superPtr);
+	}
+	ckfree((char *) oPtr->classPtr->superclasses.list);
+    }
+    oPtr->classPtr->superclasses.list = superclasses;
+    oPtr->classPtr->superclasses.num = objc-1;
+    FOREACH(superPtr, oPtr->classPtr->superclasses) {
+	TclOOAddToSubclasses(oPtr->classPtr, superPtr);
+    }
+    fPtr->epoch++;
+
+    return TCL_OK;
+}
+
+int
+TclOODefineUnexportObjCmd(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    int isSelfUnexport = (clientData != NULL);
+    Object *oPtr;
+    Method *mPtr;
+    Tcl_HashEntry *hPtr;
+    Class *clsPtr;
+    int i, isNew;
+
+    if (objc < 2) {
+	Tcl_WrongNumArgs(interp, 1, objv, "name ?name ...?");
+	return TCL_ERROR;
+    }
+
+    oPtr = GetDefineCmdContext(interp);
+    if (oPtr == NULL) {
+	return TCL_ERROR;
+    }
+    clsPtr = oPtr->classPtr;
+    isSelfUnexport |= (oPtr->classPtr == NULL);
+
+    for (i=1 ; i<objc ; i++) {
+	if (isSelfUnexport) {
+	    hPtr = Tcl_CreateHashEntry(&oPtr->methods, (char *) objv[i],
+		    &isNew);
+	} else {
+	    hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, (char*) objv[i],
+		    &isNew);
+	}
+
+	if (isNew) {
+	    mPtr = (Method *) ckalloc(sizeof(Method));
+	    memset(mPtr, 0, sizeof(Method));
+	    Tcl_SetHashValue(hPtr, mPtr);
+	} else {
+	    mPtr = Tcl_GetHashValue(hPtr);
+	}
+	mPtr->flags &= ~PUBLIC_METHOD;
+    }
+    if (isSelfUnexport) {
+	oPtr->epoch++;
+    } else {
+	((Interp *)interp)->ooFoundation->epoch++;
+    }
+    return TCL_OK;
+}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c
index e1264b3..dbd14aa 100644
--- a/generic/tclOOInfo.c
+++ b/generic/tclOOInfo.c
@@ -1,901 +1,901 @@
-/*

- * tclOODefineCmds.c --

- *

- *	This file contains the implementation of the ::oo-related [info]

- *	subcommands.

- *

- * Copyright (c) 2006 by Donal K. Fellows

- *

- * See the file "license.terms" for information on usage and redistribution of

- * this file, and for a DISCLAIMER OF ALL WARRANTIES.

- *

- * RCS: @(#) $Id: tclOOInfo.c,v 1.1.2.17 2006/10/08 15:39:59 dkf Exp $

- */

-

-#include "tclInt.h"

-#include "tclOO.h"

-

-static int		InfoObjectClassCmd(Object *oPtr, Tcl_Interp *interp,

-			    int objc, Tcl_Obj *const objv[]);

-static int		InfoObjectDefnCmd(Object *oPtr, Tcl_Interp *interp,

-			    int objc, Tcl_Obj *const objv[]);

-static int		InfoObjectFiltersCmd(Object *oPtr, Tcl_Interp *interp,

-			    int objc, Tcl_Obj *const objv[]);

-static int		InfoObjectForwardCmd(Object *oPtr, Tcl_Interp *interp,

-			    int objc, Tcl_Obj *const objv[]);

-static int		InfoObjectIsACmd(Tcl_Interp *interp, int objc,

-			    Tcl_Obj *const objv[]);

-static int		InfoObjectMethodsCmd(Object *oPtr, Tcl_Interp *interp,

-			    int objc, Tcl_Obj *const objv[]);

-static int		InfoObjectMixinsCmd(Object *oPtr, Tcl_Interp *interp,

-			    int objc, Tcl_Obj *const objv[]);

-static int		InfoObjectVarsCmd(Object *oPtr, Tcl_Interp *interp,

-			    int objc, Tcl_Obj *const objv[]);

-static int		InfoClassConstrCmd(Class *clsPtr, Tcl_Interp *interp,

-			    int objc, Tcl_Obj *const objv[]);

-static int		InfoClassDefnCmd(Class *clsPtr, Tcl_Interp *interp,

-			    int objc, Tcl_Obj *const objv[]);

-static int		InfoClassDestrCmd(Class *clsPtr, Tcl_Interp *interp,

-			    int objc, Tcl_Obj *const objv[]);

-static int		InfoClassFiltersCmd(Class *clsPtr, Tcl_Interp *interp,

-			    int objc, Tcl_Obj *const objv[]);

-static int		InfoClassForwardCmd(Class *clsPtr, Tcl_Interp *interp,

-			    int objc, Tcl_Obj *const objv[]);

-static int		InfoClassInstancesCmd(Class *clsPtr,

-			    Tcl_Interp*interp, int objc, Tcl_Obj*const objv[]);

-static int		InfoClassMethodsCmd(Class *clsPtr, Tcl_Interp *interp,

-			    int objc, Tcl_Obj *const objv[]);

-static int		InfoClassMixinsCmd(Class *clsPtr, Tcl_Interp *interp,

-			    int objc, Tcl_Obj *const objv[]);

-#ifdef SUPPORT_OO_PARAMETERS

-static int		InfoClassParametersCmd(Class *clsPtr,

-			    Tcl_Interp*interp, int objc, Tcl_Obj*const objv[]);

-#endif

-static int		InfoClassSubsCmd(Class *clsPtr, Tcl_Interp *interp,

-			    int objc, Tcl_Obj *const objv[]);

-static int		InfoClassSupersCmd(Class *clsPtr, Tcl_Interp *interp,

-			    int objc, Tcl_Obj *const objv[]);

-

-int

-TclInfoObjectCmd(

-    ClientData clientData,

-    Tcl_Interp *interp,

-    int objc,

-    Tcl_Obj *const *objv)

-{

-    static const char *subcommands[] = {

-	"class", "definition", "filters", "forward", "isa", "methods",

-	"mixins", "vars", NULL

-    };

-    enum IOSubCmds {

-	IOClass, IODefinition, IOFilters, IOForward, IOIsA, IOMethods,

-	IOMixins, IOVars

-    };

-    int idx;

-    Object *oPtr;

-

-    if (objc < 4) {

-	Tcl_WrongNumArgs(interp, 2, objv, "objName subcommand ?arg ...?");

-	return TCL_ERROR;

-    }

-    if (Tcl_GetIndexFromObj(interp, objv[3], subcommands, "subcommand", 0,

-	    &idx) != TCL_OK) {

-	return TCL_ERROR;

-    }

-    if (idx == IOIsA) {

-	return InfoObjectIsACmd(interp, objc, objv);

-    }

-    oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]);

-    if (oPtr == NULL) {

-	return TCL_ERROR;

-    }

-    switch ((enum IOSubCmds) idx) {

-    case IOClass:

-	return InfoObjectClassCmd(oPtr, interp, objc, objv);

-    case IODefinition:

-	return InfoObjectDefnCmd(oPtr, interp, objc, objv);

-    case IOFilters:

-	return InfoObjectFiltersCmd(oPtr, interp, objc, objv);

-    case IOForward:

-	return InfoObjectForwardCmd(oPtr, interp, objc, objv);

-    case IOMethods:

-	return InfoObjectMethodsCmd(oPtr, interp, objc, objv);

-    case IOMixins:

-	return InfoObjectMixinsCmd(oPtr, interp, objc, objv);

-    case IOVars:

-	return InfoObjectVarsCmd(oPtr, interp, objc, objv);

-    case IOIsA:

-	Tcl_Panic("unexpected fallthrough");

-    }

-    return TCL_ERROR; /* NOTREACHED */

-}

-

-int

-TclInfoClassCmd(

-    ClientData clientData,

-    Tcl_Interp *interp,

-    int objc,

-    Tcl_Obj *const *objv)

-{

-    static const char *subcommands[] = {

-	"constructor", "definition", "destructor", "filters", "forward",

-	"instances", "methods", "mixins",

-#ifdef SUPPORT_OO_PARAMETERS

-	"parameters",

-#endif

-	"subclasses", "superclasses", NULL

-    };

-    enum ICSubCmds {

-	ICConstructor, ICDefinition, ICDestructor, ICFilters, ICForward,

-	ICInstances, ICMethods, ICMixins,

-#ifdef SUPPORT_OO_PARAMETERS

-	ICParameters,

-#endif

-	ICSubs, ICSupers

-    };

-    int idx;

-    Object *oPtr;

-

-    if (objc < 4) {

-	Tcl_WrongNumArgs(interp, 2, objv, "className subcommand ?arg ...?");

-	return TCL_ERROR;

-    }

-    oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]);

-    if (oPtr == NULL) {

-	return TCL_ERROR;

-    }

-    if (oPtr->classPtr == NULL) {

-	Tcl_AppendResult(interp, "\"", TclGetString(objv[2]),

-		"\" is not a class", NULL);

-	return TCL_ERROR;

-    }

-    if (Tcl_GetIndexFromObj(interp, objv[3], subcommands, "subcommand", 0,

-	    &idx) != TCL_OK) {

-	return TCL_ERROR;

-    }

-

-    switch((enum ICSubCmds) idx) {

-    case ICConstructor:

-	return InfoClassConstrCmd(oPtr->classPtr, interp, objc, objv);

-    case ICDefinition:

-	return InfoClassDefnCmd(oPtr->classPtr, interp, objc, objv);

-    case ICDestructor:

-	return InfoClassDestrCmd(oPtr->classPtr, interp, objc, objv);

-    case ICFilters:

-	return InfoClassFiltersCmd(oPtr->classPtr, interp, objc, objv);

-    case ICForward:

-	return InfoClassForwardCmd(oPtr->classPtr, interp, objc, objv);

-    case ICInstances:

-	return InfoClassInstancesCmd(oPtr->classPtr, interp, objc, objv);

-    case ICMethods:

-	return InfoClassMethodsCmd(oPtr->classPtr, interp, objc, objv);

-    case ICMixins:

-	return InfoClassMixinsCmd(oPtr->classPtr, interp, objc, objv);

-#ifdef SUPPORT_OO_PARAMETERS

-    case ICParameters:

-	return InfoClassParametersCmd(oPtr->classPtr, interp, objc, objv);

-#endif

-    case ICSubs:

-	return InfoClassSubsCmd(oPtr->classPtr, interp, objc, objv);

-    case ICSupers:

-	return InfoClassSupersCmd(oPtr->classPtr, interp, objc, objv);

-    }

-    Tcl_Panic("unexpected fallthrough");

-    return TCL_ERROR; /* NOTREACHED */

-}

-

-static int

-InfoObjectClassCmd(

-    Object *oPtr,

-    Tcl_Interp *interp,

-    int objc,

-    Tcl_Obj *const objv[])

-{

-    if (objc == 4) {

-	Tcl_GetCommandFullName(interp, oPtr->selfCls->thisPtr->command,

-		Tcl_GetObjResult(interp));

-	return TCL_OK;

-    } else if (objc != 5) {

-	Tcl_WrongNumArgs(interp, 2, objv, "objName class ?className?");

-	return TCL_ERROR;

-    } else {

-	Object *o2Ptr;

-	Class *mixinPtr;

-	int i;

-

-	o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[4]);

-	if (o2Ptr == NULL) {

-	    return TCL_ERROR;

-	}

-	if (o2Ptr->classPtr == NULL) {

-	    Tcl_AppendResult(interp, "object \"", TclGetString(objv[4]),

-		    "\" is not a class", NULL);

-	    return TCL_ERROR;

-	}

-

-	FOREACH(mixinPtr, oPtr->mixins) {

-	    if (TclOOIsReachable(o2Ptr->classPtr, mixinPtr)) {

-		Tcl_SetObjResult(interp, Tcl_NewIntObj(1));

-		return TCL_OK;

-	    }

-	}

-	Tcl_SetObjResult(interp, Tcl_NewIntObj(

-		TclOOIsReachable(o2Ptr->classPtr, oPtr->selfCls)));

-	return TCL_OK;

-    }

-}

-

-static int

-InfoObjectDefnCmd(

-    Object *oPtr,

-    Tcl_Interp *interp,

-    int objc,

-    Tcl_Obj *const objv[])

-{

-    Tcl_HashEntry *hPtr;

-    Proc *procPtr;

-    CompiledLocal *localPtr;

-    Tcl_Obj *argsObj;

-

-    if (objc != 5) {

-	Tcl_WrongNumArgs(interp, 2, objv, "objName definition methodName");

-	return TCL_ERROR;

-    }

-

-    hPtr = Tcl_FindHashEntry(&oPtr->methods, (char *) objv[4]);

-    if (hPtr == NULL) {

-	Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[4]),

-		"\"", NULL);

-	return TCL_ERROR;

-    }

-    procPtr = TclOOGetProcFromMethod(Tcl_GetHashValue(hPtr));

-    if (procPtr == NULL) {

-	Tcl_AppendResult(interp,

-		"definition not available for this kind of method", NULL);

-	return TCL_ERROR;

-    }

-

-    TclNewObj(argsObj);

-    for (localPtr=procPtr->firstLocalPtr; localPtr!=NULL;

-	    localPtr=localPtr->nextPtr) {

-	if (TclIsVarArgument(localPtr)) {

-	    Tcl_Obj *argObj;

-

-	    TclNewObj(argObj);

-	    Tcl_ListObjAppendElement(NULL, argObj,

-		    Tcl_NewStringObj(localPtr->name, -1));

-	    if (localPtr->defValuePtr != NULL) {

-		Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr);

-	    }

-	    Tcl_ListObjAppendElement(NULL, argsObj, argObj);

-	}

-    }

-    Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), argsObj);

-

-    /*

-     * This is copied from the [info body] implementation. See the comments

-     * there for why this copy has to be done here.

-     */

-

-    if (procPtr->bodyPtr->bytes == NULL) {

-	(void) Tcl_GetString(procPtr->bodyPtr);

-    }

-    Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),

-	    Tcl_NewStringObj(procPtr->bodyPtr->bytes,

-	    procPtr->bodyPtr->length));

-    return TCL_OK;

-}

-

-static int

-InfoObjectFiltersCmd(

-    Object *oPtr,

-    Tcl_Interp *interp,

-    int objc,

-    Tcl_Obj *const objv[])

-{

-    int i;

-    Tcl_Obj *filterObj;

-

-    if (objc != 4) {

-	Tcl_WrongNumArgs(interp, 2, objv, "objName filters");

-	return TCL_ERROR;

-    }

-    FOREACH(filterObj, oPtr->filters) {

-	Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), filterObj);

-    }

-    return TCL_OK;

-}

-

-static int

-InfoObjectForwardCmd(

-    Object *oPtr,

-    Tcl_Interp *interp,

-    int objc,

-    Tcl_Obj *const objv[])

-{

-    Tcl_HashEntry *hPtr;

-    Tcl_Obj *prefixObj;

-

-    if (objc != 5) {

-	Tcl_WrongNumArgs(interp, 2, objv, "objName forward methodName");

-	return TCL_ERROR;

-    }

-

-    hPtr = Tcl_FindHashEntry(&oPtr->methods, (char *) objv[4]);

-    if (hPtr == NULL) {

-	Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[4]),

-		"\"", NULL);

-	return TCL_ERROR;

-    }

-    prefixObj = TclOOGetFwdFromMethod(Tcl_GetHashValue(hPtr));

-    if (prefixObj == NULL) {

-	Tcl_AppendResult(interp,

-		"prefix argument list not available for this kind of method",

-		NULL);

-	return TCL_ERROR;

-    }

-

-    Tcl_SetObjResult(interp, prefixObj);

-    return TCL_OK;

-}

-

-static int

-InfoObjectIsACmd(

-    Tcl_Interp *interp,

-    int objc,

-    Tcl_Obj *const objv[])

-{

-    static const char *categories[] = {

-	"class", "metaclass", "mixin", "object", "typeof", NULL

-    };

-    enum IsACats {

-	IsClass, IsMetaclass, IsMixin, IsObject, IsType

-    };

-    Object *oPtr, *o2Ptr;

-    int idx, i;

-

-    if (objc < 5) {

-	Tcl_WrongNumArgs(interp, 2, objv, "objName isa category ?arg ...?");

-	return TCL_ERROR;

-    }

-    if (Tcl_GetIndexFromObj(interp, objv[4], categories, "category", 0,

-	    &idx) != TCL_OK) {

-	return TCL_ERROR;

-    }

-

-    if (idx == IsObject) {

-	int ok = (Tcl_GetObjectFromObj(interp, objv[2]) != NULL);

-

-	if (!ok) {

-	    Tcl_ResetResult(interp);

-	}

-	Tcl_SetObjResult(interp, Tcl_NewIntObj(ok ? 1 : 0));

-	return TCL_OK;

-    }

-    oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]);

-    if (oPtr == NULL) {

-	return TCL_ERROR;

-    }

-

-    switch ((enum IsACats) idx) {

-    case IsClass:

-	if (objc != 5) {

-	    Tcl_WrongNumArgs(interp, 2, objv, "objName isa class");

-	    return TCL_ERROR;

-	}

-	Tcl_SetObjResult(interp, Tcl_NewIntObj(oPtr->classPtr ? 1 : 0));

-	return TCL_OK;

-    case IsMetaclass:

-	if (objc != 5) {

-	    Tcl_WrongNumArgs(interp, 2, objv, "objName isa metaclass");

-	    return TCL_ERROR;

-	}

-	if (oPtr->classPtr == NULL) {

-	    Tcl_SetObjResult(interp, Tcl_NewIntObj(0));

-	} else {

-	    Foundation *fPtr = ((Interp *)interp)->ooFoundation;

-

-	    Tcl_SetObjResult(interp, Tcl_NewIntObj(

-		    TclOOIsReachable(fPtr->classCls, oPtr->classPtr) ? 1 : 0));

-	}

-	return TCL_OK;

-    case IsMixin:

-	if (objc != 6) {

-	    Tcl_WrongNumArgs(interp, 2, objv, "objName isa mixin className");

-	    return TCL_ERROR;

-	}

-	o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[5]);

-	if (o2Ptr == NULL) {

-	    return TCL_ERROR;

-	}

-	if (o2Ptr->classPtr == NULL) {

-	    Tcl_AppendResult(interp, "non-classes cannot be mixins", NULL);

-	    return TCL_ERROR;

-	} else {

-	    Class *mixinPtr;

-

-	    FOREACH(mixinPtr, oPtr->mixins) {

-		if (mixinPtr == o2Ptr->classPtr) {

-		    Tcl_SetObjResult(interp, Tcl_NewIntObj(1));

-		    return TCL_OK;

-		}

-	    }

-	}

-	Tcl_SetObjResult(interp, Tcl_NewIntObj(0));

-	return TCL_OK;

-    case IsType:

-	if (objc != 6) {

-	    Tcl_WrongNumArgs(interp, 2, objv, "objName isa typeof className");

-	    return TCL_ERROR;

-	}

-	o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[5]);

-	if (o2Ptr == NULL) {

-	    return TCL_ERROR;

-	}

-	if (o2Ptr->classPtr == NULL) {

-	    Tcl_AppendResult(interp, "non-classes cannot be types", NULL);

-	    return TCL_ERROR;

-	}

-	if (TclOOIsReachable(o2Ptr->classPtr, oPtr->selfCls)) {

-	    Tcl_SetObjResult(interp, Tcl_NewIntObj(1));

-	} else {

-	    Tcl_SetObjResult(interp, Tcl_NewIntObj(0));

-	}

-	return TCL_OK;

-    case IsObject:

-	Tcl_Panic("unexpected fallthrough");

-    }

-    return TCL_ERROR;

-}

-

-static int

-InfoObjectMethodsCmd(

-    Object *oPtr,

-    Tcl_Interp *interp,

-    int objc,

-    Tcl_Obj *const objv[])

-{

-    int flag = PUBLIC_METHOD;

-    FOREACH_HASH_DECLS;

-    Tcl_Obj *namePtr;

-    Method *mPtr;

-

-    if (objc != 4 && objc != 5) {

-	Tcl_WrongNumArgs(interp, 2, objv, "objName methods ?-private?");

-	return TCL_ERROR;

-    }

-    if (objc == 5) {

-	int len;

-	const char *str = Tcl_GetStringFromObj(objv[4], &len);

-

-	if (len < 2 || strncmp("-private", str, (unsigned)len)) {

-	    Tcl_AppendResult(interp, "unknown switch \"", str,

-		    "\": must be -private", NULL);

-	    return TCL_ERROR;

-	}

-	flag = 0;

-    }

-    FOREACH_HASH(namePtr, mPtr, &oPtr->methods) {

-	if (mPtr->typePtr != NULL && (mPtr->flags & flag) == flag) {

-	    Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), namePtr);

-	}

-    }

-    return TCL_OK;

-}

-

-static int

-InfoObjectMixinsCmd(

-    Object *oPtr,

-    Tcl_Interp *interp,

-    int objc,

-    Tcl_Obj *const objv[])

-{

-    Class *mixinPtr;

-    int i;

-

-    if (objc != 4) {

-	Tcl_WrongNumArgs(interp, 2, objv, "objName mixins");

-	return TCL_ERROR;

-    }

-    FOREACH(mixinPtr, oPtr->mixins) {

-	Tcl_Obj *tmpObj;

-

-	TclNewObj(tmpObj);

-	Tcl_GetCommandFullName(interp, mixinPtr->thisPtr->command, tmpObj);

-	Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), tmpObj);

-    }

-    return TCL_OK;

-}

-

-static int

-InfoObjectVarsCmd(

-    Object *oPtr,

-    Tcl_Interp *interp,

-    int objc,

-    Tcl_Obj *const objv[])

-{

-    const char *pattern = NULL, *name;

-    FOREACH_HASH_DECLS;

-    Var *varPtr;

-

-    if (objc != 4 && objc != 5) {

-	Tcl_WrongNumArgs(interp, 2, objv, "objName vars ?pattern?");

-	return TCL_ERROR;

-    }

-    if (objc == 5) {

-	pattern = TclGetString(objv[4]);

-    }

-

-    FOREACH_HASH(name, varPtr, &((Namespace *) oPtr->namespacePtr)->varTable) {

-	if (varPtr->flags & VAR_UNDEFINED) {

-	    continue;

-	}

-	if (pattern != NULL && !Tcl_StringMatch(name, pattern)) {

-	    continue;

-	}

-	Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),

-		Tcl_NewStringObj(name, -1));

-    }

-

-    return TCL_OK;

-}

-

-static int

-InfoClassConstrCmd(

-    Class *clsPtr,

-    Tcl_Interp *interp,

-    int objc,

-    Tcl_Obj *const objv[])

-{

-    Proc *procPtr;

-    CompiledLocal *localPtr;

-    Tcl_Obj *argsObj;

-

-    if (objc != 4) {

-	Tcl_WrongNumArgs(interp, 2, objv, "className constructor");

-	return TCL_ERROR;

-    }

-

-    if (clsPtr->constructorPtr == NULL) {

-	return TCL_OK;

-    }

-    procPtr = TclOOGetProcFromMethod(clsPtr->constructorPtr);

-    if (procPtr == NULL) {

-	Tcl_AppendResult(interp,

-		"definition not available for this kind of method", NULL);

-	return TCL_ERROR;

-    }

-

-    TclNewObj(argsObj);

-    for (localPtr=procPtr->firstLocalPtr; localPtr!=NULL;

-	    localPtr=localPtr->nextPtr) {

-	if (TclIsVarArgument(localPtr)) {

-	    Tcl_Obj *argObj;

-

-	    TclNewObj(argObj);

-	    Tcl_ListObjAppendElement(NULL, argObj,

-		    Tcl_NewStringObj(localPtr->name, -1));

-	    if (localPtr->defValuePtr != NULL) {

-		Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr);

-	    }

-	    Tcl_ListObjAppendElement(NULL, argsObj, argObj);

-	}

-    }

-    Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), argsObj);

-    if (procPtr->bodyPtr->bytes == NULL) {

-	(void) Tcl_GetString(procPtr->bodyPtr);

-    }

-    Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),

-	    Tcl_NewStringObj(procPtr->bodyPtr->bytes,

-	    procPtr->bodyPtr->length));

-    return TCL_OK;

-}

-

-static int

-InfoClassDefnCmd(

-    Class *clsPtr,

-    Tcl_Interp *interp,

-    int objc,

-    Tcl_Obj *const objv[])

-{

-    Tcl_HashEntry *hPtr;

-    Proc *procPtr;

-    CompiledLocal *localPtr;

-    Tcl_Obj *argsObj;

-

-    if (objc != 5) {

-	Tcl_WrongNumArgs(interp, 2, objv, "className definition methodName");

-	return TCL_ERROR;

-    }

-

-    hPtr = Tcl_FindHashEntry(&clsPtr->classMethods, (char *) objv[4]);

-    if (hPtr == NULL) {

-	Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[4]),

-		"\"", NULL);

-	return TCL_ERROR;

-    }

-    procPtr = TclOOGetProcFromMethod(Tcl_GetHashValue(hPtr));

-    if (procPtr == NULL) {

-	Tcl_AppendResult(interp,

-		"definition not available for this kind of method", NULL);

-	return TCL_ERROR;

-    }

-

-    TclNewObj(argsObj);

-    for (localPtr=procPtr->firstLocalPtr; localPtr!=NULL;

-	    localPtr=localPtr->nextPtr) {

-	if (TclIsVarArgument(localPtr)) {

-	    Tcl_Obj *argObj;

-

-	    TclNewObj(argObj);

-	    Tcl_ListObjAppendElement(NULL, argObj,

-		    Tcl_NewStringObj(localPtr->name, -1));

-	    if (localPtr->defValuePtr != NULL) {

-		Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr);

-	    }

-	    Tcl_ListObjAppendElement(NULL, argsObj, argObj);

-	}

-    }

-    Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), argsObj);

-    if (procPtr->bodyPtr->bytes == NULL) {

-	(void) Tcl_GetString(procPtr->bodyPtr);

-    }

-    Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),

-	    Tcl_NewStringObj(procPtr->bodyPtr->bytes,

-	    procPtr->bodyPtr->length));

-    return TCL_OK;

-}

-

-static int

-InfoClassDestrCmd(

-    Class *clsPtr,

-    Tcl_Interp *interp,

-    int objc,

-    Tcl_Obj *const objv[])

-{

-    Proc *procPtr;

-

-    if (objc != 4) {

-	Tcl_WrongNumArgs(interp, 2, objv, "className destructor");

-	return TCL_ERROR;

-    }

-

-    if (clsPtr->destructorPtr == NULL) {

-	return TCL_OK;

-    }

-    procPtr = TclOOGetProcFromMethod(clsPtr->destructorPtr);

-    if (procPtr == NULL) {

-	Tcl_AppendResult(interp,

-		"definition not available for this kind of method", NULL);

-	return TCL_ERROR;

-    }

-

-    if (procPtr->bodyPtr->bytes == NULL) {

-	(void) Tcl_GetString(procPtr->bodyPtr);

-    }

-    Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),

-	    Tcl_NewStringObj(procPtr->bodyPtr->bytes,

-	    procPtr->bodyPtr->length));

-    return TCL_OK;

-}

-

-static int

-InfoClassFiltersCmd(

-    Class *clsPtr,

-    Tcl_Interp *interp,

-    int objc,

-    Tcl_Obj *const objv[])

-{

-    int i;

-    Tcl_Obj *filterObj;

-

-    if (objc != 4) {

-	Tcl_WrongNumArgs(interp, 2, objv, "className filters");

-	return TCL_ERROR;

-    }

-    FOREACH(filterObj, clsPtr->filters) {

-	Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), filterObj);

-    }

-    return TCL_OK;

-}

-

-static int

-InfoClassForwardCmd(

-    Class *clsPtr,

-    Tcl_Interp *interp,

-    int objc,

-    Tcl_Obj *const objv[])

-{

-    Tcl_HashEntry *hPtr;

-    Tcl_Obj *prefixObj;

-

-    if (objc != 5) {

-	Tcl_WrongNumArgs(interp, 2, objv, "className forward methodName");

-	return TCL_ERROR;

-    }

-

-    hPtr = Tcl_FindHashEntry(&clsPtr->classMethods, (char *) objv[4]);

-    if (hPtr == NULL) {

-	Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[4]),

-		"\"", NULL);

-	return TCL_ERROR;

-    }

-    prefixObj = TclOOGetFwdFromMethod(Tcl_GetHashValue(hPtr));

-    if (prefixObj == NULL) {

-	Tcl_AppendResult(interp,

-		"prefix argument list not available for this kind of method",

-		NULL);

-	return TCL_ERROR;

-    }

-

-    Tcl_SetObjResult(interp, prefixObj);

-    return TCL_OK;

-}

-

-static int

-InfoClassInstancesCmd(

-    Class *clsPtr,

-    Tcl_Interp *interp,

-    int objc,

-    Tcl_Obj *const objv[])

-{

-    Object *oPtr;

-    int i;

-    const char *pattern = NULL;

-

-    if (objc != 4 && objc != 5) {

-	Tcl_WrongNumArgs(interp, 2, objv, "className instances ?pattern?");

-	return TCL_ERROR;

-    }

-    if (objc == 5) {

-	pattern = TclGetString(objv[4]);

-    }

-    FOREACH(oPtr, clsPtr->instances) {

-	Tcl_Obj *tmpObj;

-

-	TclNewObj(tmpObj);

-	Tcl_GetCommandFullName(interp, oPtr->command, tmpObj);

-	if (pattern && !Tcl_StringMatch(TclGetString(tmpObj), pattern)) {

-	    TclDecrRefCount(tmpObj);

-	    continue;

-	}

-	Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), tmpObj);

-    }

-    return TCL_OK;

-}

-

-static int

-InfoClassMethodsCmd(

-    Class *clsPtr,

-    Tcl_Interp *interp,

-    int objc,

-    Tcl_Obj *const objv[])

-{

-    int flag = PUBLIC_METHOD;

-    FOREACH_HASH_DECLS;

-    Tcl_Obj *namePtr;

-    Method *mPtr;

-

-    if (objc != 4 && objc != 5) {

-	Tcl_WrongNumArgs(interp, 2, objv, "className methods ?-private?");

-	return TCL_ERROR;

-    }

-    if (objc == 5) {

-	int len;

-	const char *str = Tcl_GetStringFromObj(objv[4], &len);

-

-	if (len < 2 || strncmp("-private", str, (unsigned) len)) {

-	    Tcl_AppendResult(interp, "unknown switch \"", str,

-		    "\": must be -private", NULL);

-	    return TCL_ERROR;

-	}

-	flag = 0;

-    }

-    FOREACH_HASH(namePtr, mPtr, &clsPtr->classMethods) {

-	if (mPtr->typePtr != NULL && (mPtr->flags & flag) == flag) {

-	    Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), namePtr);

-	}

-    }

-    return TCL_OK;

-}

-

-static int

-InfoClassMixinsCmd(

-    Class *clsPtr,

-    Tcl_Interp *interp,

-    int objc,

-    Tcl_Obj *const objv[])

-{

-    Class *mixinPtr;

-    int i;

-

-    if (objc != 4) {

-	Tcl_WrongNumArgs(interp, 2, objv, "className mixins");

-	return TCL_ERROR;

-    }

-    FOREACH(mixinPtr, clsPtr->mixins) {

-	Tcl_Obj *tmpObj;

-

-	TclNewObj(tmpObj);

-	Tcl_GetCommandFullName(interp, mixinPtr->thisPtr->command, tmpObj);

-	Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), tmpObj);

-    }

-    return TCL_OK;

-}

-

-#ifdef SUPPORT_OO_PARAMETERS

-static int

-InfoClassParametersCmd(

-    Class *clsPtr,

-    Tcl_Interp *interp,

-    int objc,

-    Tcl_Obj *const objv[])

-{

-    Tcl_AppendResult(interp, "TODO: not yet implemented", NULL);

-    return TCL_ERROR;

-}

-#endif

-

-static int

-InfoClassSubsCmd(

-    Class *clsPtr,

-    Tcl_Interp *interp,

-    int objc,

-    Tcl_Obj *const objv[])

-{

-    Class *subclassPtr;

-    int i;

-    const char *pattern = NULL;

-

-    if (objc != 4 && objc != 5) {

-	Tcl_WrongNumArgs(interp, 2, objv, "className subclasses ?pattern?");

-	return TCL_ERROR;

-    }

-    if (objc == 5) {

-	pattern = TclGetString(objv[4]);

-    }

-    FOREACH(subclassPtr, clsPtr->subclasses) {

-	Tcl_Obj *tmpObj;

-

-	TclNewObj(tmpObj);

-	Tcl_GetCommandFullName(interp, subclassPtr->thisPtr->command, tmpObj);

-	if (pattern && !Tcl_StringMatch(TclGetString(tmpObj), pattern)) {

-	    TclDecrRefCount(tmpObj);

-	    continue;

-	}

-	Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), tmpObj);

-    }

-    return TCL_OK;

-}

-

-static int

-InfoClassSupersCmd(

-    Class *clsPtr,

-    Tcl_Interp *interp,

-    int objc,

-    Tcl_Obj *const objv[])

-{

-    Class *superPtr;

-    int i;

-

-    if (objc != 4) {

-	Tcl_WrongNumArgs(interp, 2, objv, "className superclasses");

-	return TCL_ERROR;

-    }

-    FOREACH(superPtr, clsPtr->superclasses) {

-	Tcl_Obj *tmpObj;

-

-	TclNewObj(tmpObj);

-	Tcl_GetCommandFullName(interp, superPtr->thisPtr->command, tmpObj);

-	Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), tmpObj);

-    }

-    return TCL_OK;

-}

-

-/*

- * Local Variables:

- * mode: c

- * c-basic-offset: 4

- * fill-column: 78

- * End:

- */

+/*
+ * tclOODefineCmds.c --
+ *
+ *	This file contains the implementation of the ::oo-related [info]
+ *	subcommands.
+ *
+ * Copyright (c) 2006 by Donal K. Fellows
+ *
+ * See the file "license.terms" for information on usage and redistribution of
+ * this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * RCS: @(#) $Id: tclOOInfo.c,v 1.1.2.18 2006/10/11 02:01:16 dgp Exp $
+ */
+
+#include "tclInt.h"
+#include "tclOO.h"
+
+static int		InfoObjectClassCmd(Object *oPtr, Tcl_Interp *interp,
+			    int objc, Tcl_Obj *const objv[]);
+static int		InfoObjectDefnCmd(Object *oPtr, Tcl_Interp *interp,
+			    int objc, Tcl_Obj *const objv[]);
+static int		InfoObjectFiltersCmd(Object *oPtr, Tcl_Interp *interp,
+			    int objc, Tcl_Obj *const objv[]);
+static int		InfoObjectForwardCmd(Object *oPtr, Tcl_Interp *interp,
+			    int objc, Tcl_Obj *const objv[]);
+static int		InfoObjectIsACmd(Tcl_Interp *interp, int objc,
+			    Tcl_Obj *const objv[]);
+static int		InfoObjectMethodsCmd(Object *oPtr, Tcl_Interp *interp,
+			    int objc, Tcl_Obj *const objv[]);
+static int		InfoObjectMixinsCmd(Object *oPtr, Tcl_Interp *interp,
+			    int objc, Tcl_Obj *const objv[]);
+static int		InfoObjectVarsCmd(Object *oPtr, Tcl_Interp *interp,
+			    int objc, Tcl_Obj *const objv[]);
+static int		InfoClassConstrCmd(Class *clsPtr, Tcl_Interp *interp,
+			    int objc, Tcl_Obj *const objv[]);
+static int		InfoClassDefnCmd(Class *clsPtr, Tcl_Interp *interp,
+			    int objc, Tcl_Obj *const objv[]);
+static int		InfoClassDestrCmd(Class *clsPtr, Tcl_Interp *interp,
+			    int objc, Tcl_Obj *const objv[]);
+static int		InfoClassFiltersCmd(Class *clsPtr, Tcl_Interp *interp,
+			    int objc, Tcl_Obj *const objv[]);
+static int		InfoClassForwardCmd(Class *clsPtr, Tcl_Interp *interp,
+			    int objc, Tcl_Obj *const objv[]);
+static int		InfoClassInstancesCmd(Class *clsPtr,
+			    Tcl_Interp*interp, int objc, Tcl_Obj*const objv[]);
+static int		InfoClassMethodsCmd(Class *clsPtr, Tcl_Interp *interp,
+			    int objc, Tcl_Obj *const objv[]);
+static int		InfoClassMixinsCmd(Class *clsPtr, Tcl_Interp *interp,
+			    int objc, Tcl_Obj *const objv[]);
+#ifdef SUPPORT_OO_PARAMETERS
+static int		InfoClassParametersCmd(Class *clsPtr,
+			    Tcl_Interp*interp, int objc, Tcl_Obj*const objv[]);
+#endif
+static int		InfoClassSubsCmd(Class *clsPtr, Tcl_Interp *interp,
+			    int objc, Tcl_Obj *const objv[]);
+static int		InfoClassSupersCmd(Class *clsPtr, Tcl_Interp *interp,
+			    int objc, Tcl_Obj *const objv[]);
+
+int
+TclInfoObjectCmd(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    static const char *subcommands[] = {
+	"class", "definition", "filters", "forward", "isa", "methods",
+	"mixins", "vars", NULL
+    };
+    enum IOSubCmds {
+	IOClass, IODefinition, IOFilters, IOForward, IOIsA, IOMethods,
+	IOMixins, IOVars
+    };
+    int idx;
+    Object *oPtr;
+
+    if (objc < 4) {
+	Tcl_WrongNumArgs(interp, 2, objv, "objName subcommand ?arg ...?");
+	return TCL_ERROR;
+    }
+    if (Tcl_GetIndexFromObj(interp, objv[3], subcommands, "subcommand", 0,
+	    &idx) != TCL_OK) {
+	return TCL_ERROR;
+    }
+    if (idx == IOIsA) {
+	return InfoObjectIsACmd(interp, objc, objv);
+    }
+    oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]);
+    if (oPtr == NULL) {
+	return TCL_ERROR;
+    }
+    switch ((enum IOSubCmds) idx) {
+    case IOClass:
+	return InfoObjectClassCmd(oPtr, interp, objc, objv);
+    case IODefinition:
+	return InfoObjectDefnCmd(oPtr, interp, objc, objv);
+    case IOFilters:
+	return InfoObjectFiltersCmd(oPtr, interp, objc, objv);
+    case IOForward:
+	return InfoObjectForwardCmd(oPtr, interp, objc, objv);
+    case IOMethods:
+	return InfoObjectMethodsCmd(oPtr, interp, objc, objv);
+    case IOMixins:
+	return InfoObjectMixinsCmd(oPtr, interp, objc, objv);
+    case IOVars:
+	return InfoObjectVarsCmd(oPtr, interp, objc, objv);
+    case IOIsA:
+	Tcl_Panic("unexpected fallthrough");
+    }
+    return TCL_ERROR; /* NOTREACHED */
+}
+
+int
+TclInfoClassCmd(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    static const char *subcommands[] = {
+	"constructor", "definition", "destructor", "filters", "forward",
+	"instances", "methods", "mixins",
+#ifdef SUPPORT_OO_PARAMETERS
+	"parameters",
+#endif
+	"subclasses", "superclasses", NULL
+    };
+    enum ICSubCmds {
+	ICConstructor, ICDefinition, ICDestructor, ICFilters, ICForward,
+	ICInstances, ICMethods, ICMixins,
+#ifdef SUPPORT_OO_PARAMETERS
+	ICParameters,
+#endif
+	ICSubs, ICSupers
+    };
+    int idx;
+    Object *oPtr;
+
+    if (objc < 4) {
+	Tcl_WrongNumArgs(interp, 2, objv, "className subcommand ?arg ...?");
+	return TCL_ERROR;
+    }
+    oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]);
+    if (oPtr == NULL) {
+	return TCL_ERROR;
+    }
+    if (oPtr->classPtr == NULL) {
+	Tcl_AppendResult(interp, "\"", TclGetString(objv[2]),
+		"\" is not a class", NULL);
+	return TCL_ERROR;
+    }
+    if (Tcl_GetIndexFromObj(interp, objv[3], subcommands, "subcommand", 0,
+	    &idx) != TCL_OK) {
+	return TCL_ERROR;
+    }
+
+    switch((enum ICSubCmds) idx) {
+    case ICConstructor:
+	return InfoClassConstrCmd(oPtr->classPtr, interp, objc, objv);
+    case ICDefinition:
+	return InfoClassDefnCmd(oPtr->classPtr, interp, objc, objv);
+    case ICDestructor:
+	return InfoClassDestrCmd(oPtr->classPtr, interp, objc, objv);
+    case ICFilters:
+	return InfoClassFiltersCmd(oPtr->classPtr, interp, objc, objv);
+    case ICForward:
+	return InfoClassForwardCmd(oPtr->classPtr, interp, objc, objv);
+    case ICInstances:
+	return InfoClassInstancesCmd(oPtr->classPtr, interp, objc, objv);
+    case ICMethods:
+	return InfoClassMethodsCmd(oPtr->classPtr, interp, objc, objv);
+    case ICMixins:
+	return InfoClassMixinsCmd(oPtr->classPtr, interp, objc, objv);
+#ifdef SUPPORT_OO_PARAMETERS
+    case ICParameters:
+	return InfoClassParametersCmd(oPtr->classPtr, interp, objc, objv);
+#endif
+    case ICSubs:
+	return InfoClassSubsCmd(oPtr->classPtr, interp, objc, objv);
+    case ICSupers:
+	return InfoClassSupersCmd(oPtr->classPtr, interp, objc, objv);
+    }
+    Tcl_Panic("unexpected fallthrough");
+    return TCL_ERROR; /* NOTREACHED */
+}
+
+static int
+InfoObjectClassCmd(
+    Object *oPtr,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const objv[])
+{
+    if (objc == 4) {
+	Tcl_GetCommandFullName(interp, oPtr->selfCls->thisPtr->command,
+		Tcl_GetObjResult(interp));
+	return TCL_OK;
+    } else if (objc != 5) {
+	Tcl_WrongNumArgs(interp, 2, objv, "objName class ?className?");
+	return TCL_ERROR;
+    } else {
+	Object *o2Ptr;
+	Class *mixinPtr;
+	int i;
+
+	o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[4]);
+	if (o2Ptr == NULL) {
+	    return TCL_ERROR;
+	}
+	if (o2Ptr->classPtr == NULL) {
+	    Tcl_AppendResult(interp, "object \"", TclGetString(objv[4]),
+		    "\" is not a class", NULL);
+	    return TCL_ERROR;
+	}
+
+	FOREACH(mixinPtr, oPtr->mixins) {
+	    if (TclOOIsReachable(o2Ptr->classPtr, mixinPtr)) {
+		Tcl_SetObjResult(interp, Tcl_NewIntObj(1));
+		return TCL_OK;
+	    }
+	}
+	Tcl_SetObjResult(interp, Tcl_NewIntObj(
+		TclOOIsReachable(o2Ptr->classPtr, oPtr->selfCls)));
+	return TCL_OK;
+    }
+}
+
+static int
+InfoObjectDefnCmd(
+    Object *oPtr,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const objv[])
+{
+    Tcl_HashEntry *hPtr;
+    Proc *procPtr;
+    CompiledLocal *localPtr;
+    Tcl_Obj *argsObj;
+
+    if (objc != 5) {
+	Tcl_WrongNumArgs(interp, 2, objv, "objName definition methodName");
+	return TCL_ERROR;
+    }
+
+    hPtr = Tcl_FindHashEntry(&oPtr->methods, (char *) objv[4]);
+    if (hPtr == NULL) {
+	Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[4]),
+		"\"", NULL);
+	return TCL_ERROR;
+    }
+    procPtr = TclOOGetProcFromMethod(Tcl_GetHashValue(hPtr));
+    if (procPtr == NULL) {
+	Tcl_AppendResult(interp,
+		"definition not available for this kind of method", NULL);
+	return TCL_ERROR;
+    }
+
+    TclNewObj(argsObj);
+    for (localPtr=procPtr->firstLocalPtr; localPtr!=NULL;
+	    localPtr=localPtr->nextPtr) {
+	if (TclIsVarArgument(localPtr)) {
+	    Tcl_Obj *argObj;
+
+	    TclNewObj(argObj);
+	    Tcl_ListObjAppendElement(NULL, argObj,
+		    Tcl_NewStringObj(localPtr->name, -1));
+	    if (localPtr->defValuePtr != NULL) {
+		Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr);
+	    }
+	    Tcl_ListObjAppendElement(NULL, argsObj, argObj);
+	}
+    }
+    Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), argsObj);
+
+    /*
+     * This is copied from the [info body] implementation. See the comments
+     * there for why this copy has to be done here.
+     */
+
+    if (procPtr->bodyPtr->bytes == NULL) {
+	(void) Tcl_GetString(procPtr->bodyPtr);
+    }
+    Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
+	    Tcl_NewStringObj(procPtr->bodyPtr->bytes,
+	    procPtr->bodyPtr->length));
+    return TCL_OK;
+}
+
+static int
+InfoObjectFiltersCmd(
+    Object *oPtr,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const objv[])
+{
+    int i;
+    Tcl_Obj *filterObj;
+
+    if (objc != 4) {
+	Tcl_WrongNumArgs(interp, 2, objv, "objName filters");
+	return TCL_ERROR;
+    }
+    FOREACH(filterObj, oPtr->filters) {
+	Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), filterObj);
+    }
+    return TCL_OK;
+}
+
+static int
+InfoObjectForwardCmd(
+    Object *oPtr,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const objv[])
+{
+    Tcl_HashEntry *hPtr;
+    Tcl_Obj *prefixObj;
+
+    if (objc != 5) {
+	Tcl_WrongNumArgs(interp, 2, objv, "objName forward methodName");
+	return TCL_ERROR;
+    }
+
+    hPtr = Tcl_FindHashEntry(&oPtr->methods, (char *) objv[4]);
+    if (hPtr == NULL) {
+	Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[4]),
+		"\"", NULL);
+	return TCL_ERROR;
+    }
+    prefixObj = TclOOGetFwdFromMethod(Tcl_GetHashValue(hPtr));
+    if (prefixObj == NULL) {
+	Tcl_AppendResult(interp,
+		"prefix argument list not available for this kind of method",
+		NULL);
+	return TCL_ERROR;
+    }
+
+    Tcl_SetObjResult(interp, prefixObj);
+    return TCL_OK;
+}
+
+static int
+InfoObjectIsACmd(
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const objv[])
+{
+    static const char *categories[] = {
+	"class", "metaclass", "mixin", "object", "typeof", NULL
+    };
+    enum IsACats {
+	IsClass, IsMetaclass, IsMixin, IsObject, IsType
+    };
+    Object *oPtr, *o2Ptr;
+    int idx, i;
+
+    if (objc < 5) {
+	Tcl_WrongNumArgs(interp, 2, objv, "objName isa category ?arg ...?");
+	return TCL_ERROR;
+    }
+    if (Tcl_GetIndexFromObj(interp, objv[4], categories, "category", 0,
+	    &idx) != TCL_OK) {
+	return TCL_ERROR;
+    }
+
+    if (idx == IsObject) {
+	int ok = (Tcl_GetObjectFromObj(interp, objv[2]) != NULL);
+
+	if (!ok) {
+	    Tcl_ResetResult(interp);
+	}
+	Tcl_SetObjResult(interp, Tcl_NewIntObj(ok ? 1 : 0));
+	return TCL_OK;
+    }
+    oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]);
+    if (oPtr == NULL) {
+	return TCL_ERROR;
+    }
+
+    switch ((enum IsACats) idx) {
+    case IsClass:
+	if (objc != 5) {
+	    Tcl_WrongNumArgs(interp, 2, objv, "objName isa class");
+	    return TCL_ERROR;
+	}
+	Tcl_SetObjResult(interp, Tcl_NewIntObj(oPtr->classPtr ? 1 : 0));
+	return TCL_OK;
+    case IsMetaclass:
+	if (objc != 5) {
+	    Tcl_WrongNumArgs(interp, 2, objv, "objName isa metaclass");
+	    return TCL_ERROR;
+	}
+	if (oPtr->classPtr == NULL) {
+	    Tcl_SetObjResult(interp, Tcl_NewIntObj(0));
+	} else {
+	    Foundation *fPtr = ((Interp *)interp)->ooFoundation;
+
+	    Tcl_SetObjResult(interp, Tcl_NewIntObj(
+		    TclOOIsReachable(fPtr->classCls, oPtr->classPtr) ? 1 : 0));
+	}
+	return TCL_OK;
+    case IsMixin:
+	if (objc != 6) {
+	    Tcl_WrongNumArgs(interp, 2, objv, "objName isa mixin className");
+	    return TCL_ERROR;
+	}
+	o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[5]);
+	if (o2Ptr == NULL) {
+	    return TCL_ERROR;
+	}
+	if (o2Ptr->classPtr == NULL) {
+	    Tcl_AppendResult(interp, "non-classes cannot be mixins", NULL);
+	    return TCL_ERROR;
+	} else {
+	    Class *mixinPtr;
+
+	    FOREACH(mixinPtr, oPtr->mixins) {
+		if (mixinPtr == o2Ptr->classPtr) {
+		    Tcl_SetObjResult(interp, Tcl_NewIntObj(1));
+		    return TCL_OK;
+		}
+	    }
+	}
+	Tcl_SetObjResult(interp, Tcl_NewIntObj(0));
+	return TCL_OK;
+    case IsType:
+	if (objc != 6) {
+	    Tcl_WrongNumArgs(interp, 2, objv, "objName isa typeof className");
+	    return TCL_ERROR;
+	}
+	o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[5]);
+	if (o2Ptr == NULL) {
+	    return TCL_ERROR;
+	}
+	if (o2Ptr->classPtr == NULL) {
+	    Tcl_AppendResult(interp, "non-classes cannot be types", NULL);
+	    return TCL_ERROR;
+	}
+	if (TclOOIsReachable(o2Ptr->classPtr, oPtr->selfCls)) {
+	    Tcl_SetObjResult(interp, Tcl_NewIntObj(1));
+	} else {
+	    Tcl_SetObjResult(interp, Tcl_NewIntObj(0));
+	}
+	return TCL_OK;
+    case IsObject:
+	Tcl_Panic("unexpected fallthrough");
+    }
+    return TCL_ERROR;
+}
+
+static int
+InfoObjectMethodsCmd(
+    Object *oPtr,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const objv[])
+{
+    int flag = PUBLIC_METHOD;
+    FOREACH_HASH_DECLS;
+    Tcl_Obj *namePtr;
+    Method *mPtr;
+
+    if (objc != 4 && objc != 5) {
+	Tcl_WrongNumArgs(interp, 2, objv, "objName methods ?-private?");
+	return TCL_ERROR;
+    }
+    if (objc == 5) {
+	int len;
+	const char *str = Tcl_GetStringFromObj(objv[4], &len);
+
+	if (len < 2 || strncmp("-private", str, (unsigned)len)) {
+	    Tcl_AppendResult(interp, "unknown switch \"", str,
+		    "\": must be -private", NULL);
+	    return TCL_ERROR;
+	}
+	flag = 0;
+    }
+    FOREACH_HASH(namePtr, mPtr, &oPtr->methods) {
+	if (mPtr->typePtr != NULL && (mPtr->flags & flag) == flag) {
+	    Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), namePtr);
+	}
+    }
+    return TCL_OK;
+}
+
+static int
+InfoObjectMixinsCmd(
+    Object *oPtr,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const objv[])
+{
+    Class *mixinPtr;
+    int i;
+
+    if (objc != 4) {
+	Tcl_WrongNumArgs(interp, 2, objv, "objName mixins");
+	return TCL_ERROR;
+    }
+    FOREACH(mixinPtr, oPtr->mixins) {
+	Tcl_Obj *tmpObj;
+
+	TclNewObj(tmpObj);
+	Tcl_GetCommandFullName(interp, mixinPtr->thisPtr->command, tmpObj);
+	Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), tmpObj);
+    }
+    return TCL_OK;
+}
+
+static int
+InfoObjectVarsCmd(
+    Object *oPtr,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const objv[])
+{
+    const char *pattern = NULL, *name;
+    FOREACH_HASH_DECLS;
+    Var *varPtr;
+
+    if (objc != 4 && objc != 5) {
+	Tcl_WrongNumArgs(interp, 2, objv, "objName vars ?pattern?");
+	return TCL_ERROR;
+    }
+    if (objc == 5) {
+	pattern = TclGetString(objv[4]);
+    }
+
+    FOREACH_HASH(name, varPtr, &((Namespace *) oPtr->namespacePtr)->varTable) {
+	if (varPtr->flags & VAR_UNDEFINED) {
+	    continue;
+	}
+	if (pattern != NULL && !Tcl_StringMatch(name, pattern)) {
+	    continue;
+	}
+	Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
+		Tcl_NewStringObj(name, -1));
+    }
+
+    return TCL_OK;
+}
+
+static int
+InfoClassConstrCmd(
+    Class *clsPtr,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const objv[])
+{
+    Proc *procPtr;
+    CompiledLocal *localPtr;
+    Tcl_Obj *argsObj;
+
+    if (objc != 4) {
+	Tcl_WrongNumArgs(interp, 2, objv, "className constructor");
+	return TCL_ERROR;
+    }
+
+    if (clsPtr->constructorPtr == NULL) {
+	return TCL_OK;
+    }
+    procPtr = TclOOGetProcFromMethod(clsPtr->constructorPtr);
+    if (procPtr == NULL) {
+	Tcl_AppendResult(interp,
+		"definition not available for this kind of method", NULL);
+	return TCL_ERROR;
+    }
+
+    TclNewObj(argsObj);
+    for (localPtr=procPtr->firstLocalPtr; localPtr!=NULL;
+	    localPtr=localPtr->nextPtr) {
+	if (TclIsVarArgument(localPtr)) {
+	    Tcl_Obj *argObj;
+
+	    TclNewObj(argObj);
+	    Tcl_ListObjAppendElement(NULL, argObj,
+		    Tcl_NewStringObj(localPtr->name, -1));
+	    if (localPtr->defValuePtr != NULL) {
+		Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr);
+	    }
+	    Tcl_ListObjAppendElement(NULL, argsObj, argObj);
+	}
+    }
+    Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), argsObj);
+    if (procPtr->bodyPtr->bytes == NULL) {
+	(void) Tcl_GetString(procPtr->bodyPtr);
+    }
+    Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
+	    Tcl_NewStringObj(procPtr->bodyPtr->bytes,
+	    procPtr->bodyPtr->length));
+    return TCL_OK;
+}
+
+static int
+InfoClassDefnCmd(
+    Class *clsPtr,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const objv[])
+{
+    Tcl_HashEntry *hPtr;
+    Proc *procPtr;
+    CompiledLocal *localPtr;
+    Tcl_Obj *argsObj;
+
+    if (objc != 5) {
+	Tcl_WrongNumArgs(interp, 2, objv, "className definition methodName");
+	return TCL_ERROR;
+    }
+
+    hPtr = Tcl_FindHashEntry(&clsPtr->classMethods, (char *) objv[4]);
+    if (hPtr == NULL) {
+	Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[4]),
+		"\"", NULL);
+	return TCL_ERROR;
+    }
+    procPtr = TclOOGetProcFromMethod(Tcl_GetHashValue(hPtr));
+    if (procPtr == NULL) {
+	Tcl_AppendResult(interp,
+		"definition not available for this kind of method", NULL);
+	return TCL_ERROR;
+    }
+
+    TclNewObj(argsObj);
+    for (localPtr=procPtr->firstLocalPtr; localPtr!=NULL;
+	    localPtr=localPtr->nextPtr) {
+	if (TclIsVarArgument(localPtr)) {
+	    Tcl_Obj *argObj;
+
+	    TclNewObj(argObj);
+	    Tcl_ListObjAppendElement(NULL, argObj,
+		    Tcl_NewStringObj(localPtr->name, -1));
+	    if (localPtr->defValuePtr != NULL) {
+		Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr);
+	    }
+	    Tcl_ListObjAppendElement(NULL, argsObj, argObj);
+	}
+    }
+    Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), argsObj);
+    if (procPtr->bodyPtr->bytes == NULL) {
+	(void) Tcl_GetString(procPtr->bodyPtr);
+    }
+    Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
+	    Tcl_NewStringObj(procPtr->bodyPtr->bytes,
+	    procPtr->bodyPtr->length));
+    return TCL_OK;
+}
+
+static int
+InfoClassDestrCmd(
+    Class *clsPtr,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const objv[])
+{
+    Proc *procPtr;
+
+    if (objc != 4) {
+	Tcl_WrongNumArgs(interp, 2, objv, "className destructor");
+	return TCL_ERROR;
+    }
+
+    if (clsPtr->destructorPtr == NULL) {
+	return TCL_OK;
+    }
+    procPtr = TclOOGetProcFromMethod(clsPtr->destructorPtr);
+    if (procPtr == NULL) {
+	Tcl_AppendResult(interp,
+		"definition not available for this kind of method", NULL);
+	return TCL_ERROR;
+    }
+
+    if (procPtr->bodyPtr->bytes == NULL) {
+	(void) Tcl_GetString(procPtr->bodyPtr);
+    }
+    Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
+	    Tcl_NewStringObj(procPtr->bodyPtr->bytes,
+	    procPtr->bodyPtr->length));
+    return TCL_OK;
+}
+
+static int
+InfoClassFiltersCmd(
+    Class *clsPtr,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const objv[])
+{
+    int i;
+    Tcl_Obj *filterObj;
+
+    if (objc != 4) {
+	Tcl_WrongNumArgs(interp, 2, objv, "className filters");
+	return TCL_ERROR;
+    }
+    FOREACH(filterObj, clsPtr->filters) {
+	Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), filterObj);
+    }
+    return TCL_OK;
+}
+
+static int
+InfoClassForwardCmd(
+    Class *clsPtr,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const objv[])
+{
+    Tcl_HashEntry *hPtr;
+    Tcl_Obj *prefixObj;
+
+    if (objc != 5) {
+	Tcl_WrongNumArgs(interp, 2, objv, "className forward methodName");
+	return TCL_ERROR;
+    }
+
+    hPtr = Tcl_FindHashEntry(&clsPtr->classMethods, (char *) objv[4]);
+    if (hPtr == NULL) {
+	Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[4]),
+		"\"", NULL);
+	return TCL_ERROR;
+    }
+    prefixObj = TclOOGetFwdFromMethod(Tcl_GetHashValue(hPtr));
+    if (prefixObj == NULL) {
+	Tcl_AppendResult(interp,
+		"prefix argument list not available for this kind of method",
+		NULL);
+	return TCL_ERROR;
+    }
+
+    Tcl_SetObjResult(interp, prefixObj);
+    return TCL_OK;
+}
+
+static int
+InfoClassInstancesCmd(
+    Class *clsPtr,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const objv[])
+{
+    Object *oPtr;
+    int i;
+    const char *pattern = NULL;
+
+    if (objc != 4 && objc != 5) {
+	Tcl_WrongNumArgs(interp, 2, objv, "className instances ?pattern?");
+	return TCL_ERROR;
+    }
+    if (objc == 5) {
+	pattern = TclGetString(objv[4]);
+    }
+    FOREACH(oPtr, clsPtr->instances) {
+	Tcl_Obj *tmpObj;
+
+	TclNewObj(tmpObj);
+	Tcl_GetCommandFullName(interp, oPtr->command, tmpObj);
+	if (pattern && !Tcl_StringMatch(TclGetString(tmpObj), pattern)) {
+	    TclDecrRefCount(tmpObj);
+	    continue;
+	}
+	Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), tmpObj);
+    }
+    return TCL_OK;
+}
+
+static int
+InfoClassMethodsCmd(
+    Class *clsPtr,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const objv[])
+{
+    int flag = PUBLIC_METHOD;
+    FOREACH_HASH_DECLS;
+    Tcl_Obj *namePtr;
+    Method *mPtr;
+
+    if (objc != 4 && objc != 5) {
+	Tcl_WrongNumArgs(interp, 2, objv, "className methods ?-private?");
+	return TCL_ERROR;
+    }
+    if (objc == 5) {
+	int len;
+	const char *str = Tcl_GetStringFromObj(objv[4], &len);
+
+	if (len < 2 || strncmp("-private", str, (unsigned) len)) {
+	    Tcl_AppendResult(interp, "unknown switch \"", str,
+		    "\": must be -private", NULL);
+	    return TCL_ERROR;
+	}
+	flag = 0;
+    }
+    FOREACH_HASH(namePtr, mPtr, &clsPtr->classMethods) {
+	if (mPtr->typePtr != NULL && (mPtr->flags & flag) == flag) {
+	    Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), namePtr);
+	}
+    }
+    return TCL_OK;
+}
+
+static int
+InfoClassMixinsCmd(
+    Class *clsPtr,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const objv[])
+{
+    Class *mixinPtr;
+    int i;
+
+    if (objc != 4) {
+	Tcl_WrongNumArgs(interp, 2, objv, "className mixins");
+	return TCL_ERROR;
+    }
+    FOREACH(mixinPtr, clsPtr->mixins) {
+	Tcl_Obj *tmpObj;
+
+	TclNewObj(tmpObj);
+	Tcl_GetCommandFullName(interp, mixinPtr->thisPtr->command, tmpObj);
+	Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), tmpObj);
+    }
+    return TCL_OK;
+}
+
+#ifdef SUPPORT_OO_PARAMETERS
+static int
+InfoClassParametersCmd(
+    Class *clsPtr,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const objv[])
+{
+    Tcl_AppendResult(interp, "TODO: not yet implemented", NULL);
+    return TCL_ERROR;
+}
+#endif
+
+static int
+InfoClassSubsCmd(
+    Class *clsPtr,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const objv[])
+{
+    Class *subclassPtr;
+    int i;
+    const char *pattern = NULL;
+
+    if (objc != 4 && objc != 5) {
+	Tcl_WrongNumArgs(interp, 2, objv, "className subclasses ?pattern?");
+	return TCL_ERROR;
+    }
+    if (objc == 5) {
+	pattern = TclGetString(objv[4]);
+    }
+    FOREACH(subclassPtr, clsPtr->subclasses) {
+	Tcl_Obj *tmpObj;
+
+	TclNewObj(tmpObj);
+	Tcl_GetCommandFullName(interp, subclassPtr->thisPtr->command, tmpObj);
+	if (pattern && !Tcl_StringMatch(TclGetString(tmpObj), pattern)) {
+	    TclDecrRefCount(tmpObj);
+	    continue;
+	}
+	Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), tmpObj);
+    }
+    return TCL_OK;
+}
+
+static int
+InfoClassSupersCmd(
+    Class *clsPtr,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const objv[])
+{
+    Class *superPtr;
+    int i;
+
+    if (objc != 4) {
+	Tcl_WrongNumArgs(interp, 2, objv, "className superclasses");
+	return TCL_ERROR;
+    }
+    FOREACH(superPtr, clsPtr->superclasses) {
+	Tcl_Obj *tmpObj;
+
+	TclNewObj(tmpObj);
+	Tcl_GetCommandFullName(interp, superPtr->thisPtr->command, tmpObj);
+	Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), tmpObj);
+    }
+    return TCL_OK;
+}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */