*/

#if TCL_MAJOR_VERSION > 8
MODULE_SCOPE void	TclAdvanceContinuations(Tcl_Size *line, Tcl_Size **next,
			    int loc);
MODULE_SCOPE void	TclAdvanceLines(Tcl_Size *line, const char *start,
			    const char *end);
MODULE_SCOPE int	TclAliasCreate(Tcl_Interp *interp,
			    Tcl_Interp *childInterp, Tcl_Interp *parentInterp,
			    Tcl_Obj *namePtr, Tcl_Obj *targetPtr, Tcl_Size objc,
			    Tcl_Obj *const objv[]);
MODULE_SCOPE void	TclAppendBytesToByteArray(Tcl_Obj *objPtr,
			    const unsigned char *bytes, Tcl_Size len);
MODULE_SCOPE void	TclAppendUtfToUtf(Tcl_Obj *objPtr,
			    const char *bytes, Tcl_Size numBytes);
MODULE_SCOPE void	TclArgumentEnter(Tcl_Interp *interp,
			    Tcl_Obj *objv[], Tcl_Size objc, CmdFrame *cf);
MODULE_SCOPE void	TclArgumentRelease(Tcl_Interp *interp,

#define INTERP_INFO(interp) \
	((InterpInfo *) ((Interp *) (interp))->interpInfo)

/*
 * Prototypes for local static functions:
 */





static int		AliasDelete(Tcl_Interp *interp,
			    Tcl_Interp *childInterp, Tcl_Obj *namePtr);
static int		AliasDescribe(Tcl_Interp *interp,
			    Tcl_Interp *childInterp, Tcl_Obj *objPtr);
static int		AliasList(Tcl_Interp *interp, Tcl_Interp *childInterp);
static Tcl_ObjCmdProc	AliasNRCmd;
static Tcl_CmdDeleteProc AliasObjCmdDeleteProc;

	}
	if (objc > 5) {
	    parentInterp = GetInterp(interp, objv[4]);
	    if (parentInterp == NULL) {
		return TCL_ERROR;
	    }

	    return TclAliasCreate(interp, childInterp, parentInterp, objv[3],
		    objv[5], objc - 6, objv + 6);
	}

    aliasArgs:
	Tcl_WrongNumArgs(interp, 2, objv,
		"childPath childCmd ?parentPath parentCmd? ?arg ...?");
	return TCL_ERROR;

    childObjPtr = Tcl_NewStringObj(childCmd, -1);
    Tcl_IncrRefCount(childObjPtr);

    targetObjPtr = Tcl_NewStringObj(targetCmd, -1);
    Tcl_IncrRefCount(targetObjPtr);

    result = TclAliasCreate(childInterp, childInterp, targetInterp, childObjPtr,
	    targetObjPtr, argc, objv);

    for (i = 0; i < argc; i++) {
	Tcl_DecrRefCount(objv[i]);
    }
    TclStackFree(childInterp, objv);
    Tcl_DecrRefCount(targetObjPtr);

    childObjPtr = Tcl_NewStringObj(childCmd, -1);
    Tcl_IncrRefCount(childObjPtr);

    targetObjPtr = Tcl_NewStringObj(targetCmd, -1);
    Tcl_IncrRefCount(targetObjPtr);

    result = TclAliasCreate(childInterp, childInterp, targetInterp, childObjPtr,
	    targetObjPtr, objc, objv);

    Tcl_DecrRefCount(childObjPtr);
    Tcl_DecrRefCount(targetObjPtr);
    return result;
}


	nextAliasPtr = (Alias *) aliasCmdPtr->objClientData;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclAliasCreate --
 *
 *	Helper function to do the work to actually create an alias.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	An alias command is created and entered into the alias table for the
 *	child interpreter.
 *
 *----------------------------------------------------------------------
 */

int
TclAliasCreate(
    Tcl_Interp *interp,		/* Interp for error reporting. */
    Tcl_Interp *childInterp,	/* Interp where alias cmd will live or from
				 * which alias will be deleted. */
    Tcl_Interp *parentInterp,	/* Interp in which target command will be
				 * invoked. */
    Tcl_Obj *namePtr,		/* Name of alias cmd. */
    Tcl_Obj *targetCmdPtr,	/* Name of target cmd. */

    if (safe) {
	Tcl_Obj *clockObj;
	int status;

	TclNewLiteralStringObj(clockObj, "clock");
	Tcl_IncrRefCount(clockObj);
	status = TclAliasCreate(interp, childInterp, parentInterp, clockObj,
		clockObj, 0, NULL);
	Tcl_DecrRefCount(clockObj);
	if (status != TCL_OK) {
	    goto error2;
	}
    }

		return AliasDescribe(interp, childInterp, objv[2]);
	    }
	    if (TclGetString(objv[3])[0] == '\0') {
		if (objc == 4) {
		    return AliasDelete(interp, childInterp, objv[2]);
		}
	    } else {
		return TclAliasCreate(interp, childInterp, interp, objv[2],
			objv[3], objc - 4, objv + 4);
	    }
	}
	Tcl_WrongNumArgs(interp, 2, objv, "aliasName ?targetName? ?arg ...?");
	return TCL_ERROR;
    case OPT_ALIASES:
	if (objc != 2) {

#ifdef HAVE_CONFIG_H
#include "config.h"
#endif
#include "tclInt.h"
#include "tclOOInt.h"

/*
 * Commands in oo and oo::Helpers.
 */

static const struct StdCommands {
    const char *name;
    Tcl_ObjCmdProc *objProc;
    Tcl_ObjCmdProc *nreProc;
    CompileProc *compileProc;
} ooCmds[] = {
    {"define",		TclOODefineObjCmd, NULL, NULL},
    {"objdefine",	TclOOObjDefObjCmd, NULL, NULL},
    {"copy",		TclOOCopyObjectCmd, NULL, NULL},
    {"DelegateName",	TclOODelegateNameObjCmd, NULL, NULL},
    {NULL, NULL, NULL, NULL}
}, helpCmds[] = {
    {"callback",	TclOOCallbackObjCmd, NULL, NULL},
    {"mymethod",	TclOOCallbackObjCmd, NULL, NULL},
    {"classvariable",	TclOOClassVariableObjCmd, NULL, NULL},
    {"link",		TclOOLinkObjCmd, NULL, NULL},
    {"next",		NULL, TclOONextObjCmd, TclCompileObjectNextCmd},
    {"nextto",		NULL, TclOONextToObjCmd, TclCompileObjectNextToCmd},
    {"self",		TclOOSelfObjCmd, NULL, TclCompileObjectSelfCmd},
    {NULL, NULL, NULL, NULL}
};

/*
 * Commands in oo::define and oo::objdefine.
 */

static const struct DefineCommands {
    const char *name;
    Tcl_ObjCmdProc *objProc;
    int flag;
} defineCmds[] = {
    {"classmethod", TclOODefineClassMethodObjCmd, 0},
    {"constructor", TclOODefineConstructorObjCmd, 0},
    {"definitionnamespace", TclOODefineDefnNsObjCmd, 0},
    {"deletemethod", TclOODefineDeleteMethodObjCmd, 0},
    {"destructor", TclOODefineDestructorObjCmd, 0},
    {"export", TclOODefineExportObjCmd, 0},
    {"forward", TclOODefineForwardObjCmd, 0},
    {"initialise", TclOODefineInitialiseObjCmd, 0},
    {"initialize", TclOODefineInitialiseObjCmd, 0},
    {"method", TclOODefineMethodObjCmd, 0},
    {"private", TclOODefinePrivateObjCmd, 0},
    {"renamemethod", TclOODefineRenameMethodObjCmd, 0},
    {"self", TclOODefineSelfObjCmd, 0},
    {"unexport", TclOODefineUnexportObjCmd, 0},
    {NULL, NULL, 0}
}, objdefCmds[] = {

    TclNewLiteralStringObj(fPtr->unknownMethodNameObj, "unknown");
    TclNewLiteralStringObj(fPtr->constructorName, "<constructor>");
    TclNewLiteralStringObj(fPtr->destructorName, "<destructor>");
    TclNewLiteralStringObj(fPtr->clonedName, "<cloned>");
    TclNewLiteralStringObj(fPtr->defineName, "::oo::define");
    TclNewLiteralStringObj(fPtr->myName, "my");
    TclNewLiteralStringObj(fPtr->slotGetName, "Get");
    TclNewLiteralStringObj(fPtr->slotSetName, "Set");
    TclNewLiteralStringObj(fPtr->slotResolveName, "Resolve");
    TclNewLiteralStringObj(fPtr->slotDefOpName, "--default-operation");
    Tcl_IncrRefCount(fPtr->unknownMethodNameObj);
    Tcl_IncrRefCount(fPtr->constructorName);
    Tcl_IncrRefCount(fPtr->destructorName);
    Tcl_IncrRefCount(fPtr->clonedName);
    Tcl_IncrRefCount(fPtr->defineName);
    Tcl_IncrRefCount(fPtr->myName);
    Tcl_IncrRefCount(fPtr->slotGetName);
    Tcl_IncrRefCount(fPtr->slotSetName);
    Tcl_IncrRefCount(fPtr->slotResolveName);
    Tcl_IncrRefCount(fPtr->slotDefOpName);

    TclCreateObjCommandInNs(interp, "UnknownDefinition", fPtr->ooNs,
	    TclOOUnknownDefinition, NULL, NULL);
    TclNewLiteralStringObj(namePtr, "::oo::UnknownDefinition");
    Tcl_SetNamespaceUnknownHandler(interp, define, namePtr);
    Tcl_SetNamespaceUnknownHandler(interp, objdef, namePtr);
    Tcl_BounceRefCount(namePtr);

	    (Tcl_Class) fPtr->classCls, NULL, 0, &classConstructor, NULL);

    /*
     * Create non-object commands and plug ourselves into the Tcl [info]
     * ensemble.
     */

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

	CreateCmdInNS(interp, fPtr->helpersNs, helpCmds[i].name,
		helpCmds[i].objProc, helpCmds[i].nreProc,
		helpCmds[i].compileProc);
    }
    for (i = 0 ; ooCmds[i].name ; i++) {
	CreateCmdInNS(interp, fPtr->ooNs, ooCmds[i].name,
		ooCmds[i].objProc, ooCmds[i].nreProc,
		ooCmds[i].compileProc);
    }




    TclOOInitInfo(interp);

    /*
     * Now make the class of slots.
     */

    TclDecrRefCount(fPtr->unknownMethodNameObj);
    TclDecrRefCount(fPtr->constructorName);
    TclDecrRefCount(fPtr->destructorName);
    TclDecrRefCount(fPtr->clonedName);
    TclDecrRefCount(fPtr->defineName);
    TclDecrRefCount(fPtr->myName);
    TclDecrRefCount(fPtr->slotGetName);
    TclDecrRefCount(fPtr->slotSetName);
    TclDecrRefCount(fPtr->slotResolveName);
    TclDecrRefCount(fPtr->slotDefOpName);
    TclOODecrRefCount(fPtr->objectCls->thisPtr);
    TclOODecrRefCount(fPtr->classCls->thisPtr);

    Tcl_Free(fPtr);

    /*
     * Don't leave the interpreter field pointing to freed data.

    tracePtr->refCount = 1;

    oPtr->myCommand = TclNRCreateCommandInNs(interp, "my", oPtr->namespacePtr,
	    TclOOPrivateObjectCmd, PrivateNRObjectCmd, oPtr, MyDeleted);
    oPtr->myclassCommand = TclNRCreateCommandInNs(interp, "myclass",
	    oPtr->namespacePtr, TclOOMyClassObjCmd, MyClassNRObjCmd, oPtr,
	    MyClassDeleted);
    oPtr->linkedCmdsList = NULL;
    return oPtr;
}

/*
 * ----------------------------------------------------------------------
 *
 * SquelchCachedName --

static void
MyDeleted(
    void *clientData)		/* Reference to the object whose [my] has been
				 * squelched. */
{
    Object *oPtr = (Object *) clientData;
    Tcl_Size linkc, i;
    Tcl_Obj **linkv, *link;

    if (oPtr->linkedCmdsList) {
	TclListObjGetElements(NULL, oPtr->linkedCmdsList, &linkc, &linkv);
	for (i=0 ; i<linkc ; i++) {
	    link = linkv[i];
	    (void) Tcl_DeleteCommand(oPtr->fPtr->interp, TclGetString(link));
	}
	Tcl_DecrRefCount(oPtr->linkedCmdsList);
	oPtr->linkedCmdsList = NULL;
    }
    oPtr->myCommand = NULL;
}

static void
MyClassDeleted(
    void *clientData)
{

Tcl_Obj *
Tcl_GetObjectName(
    Tcl_Interp *interp,
    Tcl_Object object)
{
    return TclOOObjectName(interp, (Object *) object);
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOOObjectMyName --
 *
 *	Utility function that returns the name of the object's [my], or NULL
 *	if it has been deleted (or otherwise doesn't exist).
 *
 * ----------------------------------------------------------------------
 */
Tcl_Obj *
TclOOObjectMyName(
    Tcl_Interp *interp,
    Object *oPtr)
{
    Tcl_Obj *namePtr;
    if (!oPtr->myCommand) {
	return NULL;
    }
    TclNewObj(namePtr);
    Tcl_GetCommandFullName(interp, oPtr->myCommand, namePtr);
    return namePtr;
}

/*
 * ----------------------------------------------------------------------
 *
 * assorted trivial 'getter' functions
 *
 * ----------------------------------------------------------------------

#endif
#include "tclInt.h"
#include "tclOOInt.h"
#include "tclTomMath.h"

static inline Tcl_Object *AddConstructionFinalizer(Tcl_Interp *interp);
static Tcl_NRPostProc	AfterNRDestructor;
static Tcl_NRPostProc	PostClassConstructor;
static Tcl_NRPostProc	FinalizeConstruction;
static Tcl_NRPostProc	FinalizeEval;
static Tcl_NRPostProc	NextRestoreFrame;

/*
 * ----------------------------------------------------------------------
 *

    Tcl_SetObjResult(interp, TclOOObjectName(interp, oPtr));
    return TCL_OK;
}

/*
 * ----------------------------------------------------------------------
 *
 * MixinClassDelegates --
 *
 *	Internal utility for setting up the class delegate.
 *	Runs after the class has called [oo::define] on its argument.
 *
 * ----------------------------------------------------------------------
 */

/*
 * Look up the delegate for a class.
 */
static inline Class *
GetClassDelegate(
    Tcl_Interp *interp,
    Class *clsPtr)
{
    Tcl_Obj *delegateName = Tcl_ObjPrintf("%s:: oo ::delegate",
	    clsPtr->thisPtr->namespacePtr->fullName);
    Class *delegatePtr = TclOOGetClassFromObj(interp, delegateName);
    Tcl_DecrRefCount(delegateName);
    return delegatePtr;
}

/*
 * Patches in the appropriate class delegates' superclasses.
 * Sonewhat nessy because the list of superclasses isn't modified frequently.
 */
static inline void
SetDelegateSuperclasses(
    Tcl_Interp *interp,
    Class *clsPtr,
    Class *delegatePtr)
{
    /* Build new list of superclasses */
    int i, j = delegatePtr->superclasses.num, k;
    Class *superPtr, **supers = (Class **) Tcl_Alloc(sizeof(Class *) *
	    (delegatePtr->superclasses.num + clsPtr->superclasses.num));
    if (delegatePtr->superclasses.num) {
	memcpy(supers, delegatePtr->superclasses.list,
		sizeof(Class *) * delegatePtr->superclasses.num);
    }
    FOREACH(superPtr, clsPtr->superclasses) {
	Class *superDelegatePtr = GetClassDelegate(interp, superPtr);
	if (!superDelegatePtr) {
	    continue;
	}
	for (k=0 ; k<=j ; k++) {
	    if (k == j) {
		supers[j++] = superDelegatePtr;
		TclOOAddToSubclasses(delegatePtr, superDelegatePtr);
		AddRef(superDelegatePtr->thisPtr);
		break;
	    } else if (supers[k] == superDelegatePtr) {
		break;
	    }
	}
    }

    /* Install new list of superclasses */
    if (delegatePtr->superclasses.num) {
	Tcl_Free(delegatePtr->superclasses.list);
    }
    delegatePtr->superclasses.list = supers;
    delegatePtr->superclasses.num = j;

    /* Definitely don't need to bump any epoch here */
}

/*
 * Mixes the delegate into its controlling class.
 */
static inline void
InstallDelegateAsMixin(
    Tcl_Interp *interp,
    Class *clsPtr,
    Class *delegatePtr)
{
    Class **mixins;
    int i;

    if (clsPtr->thisPtr->mixins.num == 0) {
	TclOOObjectSetMixins(clsPtr->thisPtr, 1, &delegatePtr);
	return;
    }
    mixins = (Class **) TclStackAlloc(interp,
	    sizeof(Class *) * (clsPtr->thisPtr->mixins.num + 1));
    for (i = 0; i < clsPtr->thisPtr->mixins.num; i++) {
	mixins[i] = clsPtr->thisPtr->mixins.list[i];
	if (mixins[i] == delegatePtr) {
	    TclStackFree(interp, (void *) mixins);
	    return;
	}
    }
    mixins[clsPtr->thisPtr->mixins.num] = delegatePtr;
    TclOOObjectSetMixins(clsPtr->thisPtr, clsPtr->thisPtr->mixins.num + 1, mixins);
    TclStackFree(interp, mixins);
}

/*
 * Patches in the appropriate class delegates.
 */
static void
MixinClassDelegates(
    Tcl_Interp *interp,
    Object *oPtr,
    Tcl_Obj *delegateName)
{
    Class *clsPtr = oPtr->classPtr, *delegatePtr;
    if (clsPtr) {
	delegatePtr = TclOOGetClassFromObj(interp, delegateName);
	if (delegatePtr) {
	    SetDelegateSuperclasses(interp, clsPtr, delegatePtr);
	    InstallDelegateAsMixin(interp, clsPtr, delegatePtr);
	}
    }
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOO_Class_Constructor --
 *
 *	Implementation for oo::class constructor.
 *
 * ----------------------------------------------------------------------
 */

int
TclOO_Class_Constructor(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
    size_t skip = Tcl_ObjectContextSkippedArgs(context);
    Tcl_Obj **invoke, *delegateName;


    if ((size_t) objc > skip + 1) {
	Tcl_WrongNumArgs(interp, skip, objv,
		"?definitionScript?");
	return TCL_ERROR;
    }

    /*
     * Make the class definition delegate. This is special; it doesn't reenter
     * here (and the class definition delegate doesn't run any constructors).
     *
     * This needs to be done before consideration of whether to pass the script
     * argument to [oo::define]. [Bug 680503]
     */

    delegateName = Tcl_ObjPrintf("%s:: oo ::delegate",
	    oPtr->namespacePtr->fullName);
    Tcl_IncrRefCount(delegateName);
    Tcl_NewObjectInstance(interp, (Tcl_Class) oPtr->fPtr->classCls,
	    TclGetString(delegateName), NULL, TCL_INDEX_NONE, NULL, 0);


    /*
     * If there's nothing else to do, we're done.
     */

    if ((size_t) objc == skip) {
	Tcl_InterpState saved = Tcl_SaveInterpState(interp, TCL_OK);
	MixinClassDelegates(interp, oPtr, delegateName);
	Tcl_DecrRefCount(delegateName);
	return Tcl_RestoreInterpState(interp, saved);
    }

    /*
     * Delegate to [oo::define] to do the work.
     */

    invoke = (Tcl_Obj **) TclStackAlloc(interp, 3 * sizeof(Tcl_Obj *));
    invoke[0] = oPtr->fPtr->defineName;
    invoke[1] = TclOOObjectName(interp, oPtr);
    invoke[2] = objv[objc - 1];

    /*
     * Must add references or errors in configuration script will cause
     * trouble.
     */

    Tcl_IncrRefCount(invoke[0]);
    Tcl_IncrRefCount(invoke[1]);
    Tcl_IncrRefCount(invoke[2]);
    TclNRAddCallback(interp, PostClassConstructor,
	    invoke, oPtr, delegateName, NULL);

    /*
     * Tricky point: do not want the extra reported level in the Tcl stack
     * trace, so use TCL_EVAL_NOERR.
     */

    return TclNREvalObjv(interp, 3, invoke, TCL_EVAL_NOERR, NULL);
}

/*
 *	Called *after* [oo::define] inside the constructor of a class.
 *	Cleans up some temporary storage and sets up the delegate.
 */
static int
PostClassConstructor(
    void *data[],
    Tcl_Interp *interp,
    int result)
{
    Tcl_Obj **invoke = (Tcl_Obj **) data[0];
    Object *oPtr = (Object *) data[1];
    Tcl_Obj *delegateName = (Tcl_Obj *) data[2];
    Tcl_InterpState saved;


    TclDecrRefCount(invoke[0]);
    TclDecrRefCount(invoke[1]);
    TclDecrRefCount(invoke[2]);

    TclStackFree(interp, invoke);


    saved = Tcl_SaveInterpState(interp, result);
    MixinClassDelegates(interp, oPtr, delegateName);
    Tcl_DecrRefCount(delegateName);






    return Tcl_RestoreInterpState(interp, saved);
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOO_Class_Create --

    Tcl_SetObjResult(interp, varNamePtr);
    return TCL_OK;
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOOLinkObjCmd --
 *
 *	Implementation of the [link] command, that makes a command that
 *	invokes a method on the current object. The name of the command and
 *	the name of the method match by default. Note that this command is
 *	only ever to be used inside the body of a procedure-like method,
 *	and is typically intended for constructors.
 *
 * ----------------------------------------------------------------------
 */
int
TclOOLinkObjCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const *objv)
{
    /* Set up common bits. */
    CallFrame *framePtr = ((Interp *) interp)->varFramePtr;
    CallContext *context;
    Object *oPtr;
    Tcl_Obj *myCmd, **linkv, *src, *dst;
    Tcl_Size linkc;
    const char *srcStr;
    int i;

    if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"%s may only be called from inside a method",
		TclGetString(objv[0])));
	OO_ERROR(interp, CONTEXT_REQUIRED);
	return TCL_ERROR;
    }
    context = (CallContext *) framePtr->clientData;
    oPtr = context->oPtr;
    if (!oPtr->myCommand) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"cannot link to non-existent callback handle"));
	OO_ERROR(interp, MY_GONE);
	return TCL_ERROR;
    }
    myCmd = Tcl_NewObj();
    Tcl_GetCommandFullName(interp, oPtr->myCommand, myCmd);
    if (!oPtr->linkedCmdsList) {
	oPtr->linkedCmdsList = Tcl_NewListObj(0, NULL);
	Tcl_IncrRefCount(oPtr->linkedCmdsList);
    }

    /* For each argument */
    for (i=1; i<objc; i++) {
	/* Parse as list of (one or) two items: source and destination names */
	if (TclListObjGetElements(interp, objv[i], &linkc, &linkv) != TCL_OK) {
	    Tcl_BounceRefCount(myCmd);
	    return TCL_ERROR;
	}
	switch (linkc) {
	case 1:
	    /* Degenerate case */
	    src = dst = linkv[0];
	    break;
	case 2:
	    src = linkv[0];
	    dst = linkv[1];
	    break;
	default:
	    Tcl_BounceRefCount(myCmd);
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "bad link description; must only have one or two elements"));
	    OO_ERROR(interp, CMDLINK_FORMAT);
	    return TCL_ERROR;
	}

	/* Qualify the source if necessary */
	srcStr = TclGetString(src);
	if (srcStr[0] != ':' || srcStr[1] != ':') {
	    src = Tcl_ObjPrintf("%s::%s",
		    context->oPtr->namespacePtr->fullName, srcStr);
	}

	/* Make the alias command */
	if (TclAliasCreate(interp, interp, interp, src, myCmd, 1, &dst) != TCL_OK) {
	    Tcl_BounceRefCount(myCmd);
	    Tcl_BounceRefCount(src);
	    return TCL_ERROR;
	}

	/* Remember the alias for cleanup if necessary */
	Tcl_ListObjAppendElement(NULL, oPtr->linkedCmdsList, src);
    }
    Tcl_BounceRefCount(myCmd);
    return TCL_OK;
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOONextObjCmd, TclOONextToObjCmd --
 *
 *	Implementation of the [next] and [nextto] commands. Note that these
 *	commands are only ever to be used inside the body of a procedure-like
 *	method.
 *
 * ----------------------------------------------------------------------

    /*
     * Return the name of the cloned object.
     */

    Tcl_SetObjResult(interp, TclOOObjectName(interp, (Object *) o2Ptr));
    return TCL_OK;
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOOCallbackObjCmd --
 *
 *	Implementation of the [callback] command, which constructs callbacks
 *	into the current object.
 *
 * ----------------------------------------------------------------------
 */
int
TclOOCallbackObjCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const *objv)
{
    Interp *iPtr = (Interp *) interp;
    CallFrame *framePtr = iPtr->varFramePtr;
    CallContext *contextPtr;
    Tcl_Obj *namePtr, *listPtr;

    /*
     * Start with sanity checks on the calling context to make sure that we
     * are invoked from a suitable method context. If so, we can safely
     * retrieve the handle to the object call context.
     */

    if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"%s may only be called from inside a method",
		TclGetString(objv[0])));
	OO_ERROR(interp, CONTEXT_REQUIRED);
	return TCL_ERROR;
    }

    contextPtr = (CallContext *) framePtr->clientData;
    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "method ...");
	return TCL_ERROR;
    }

    /* Get the [my] real name. */
    namePtr = TclOOObjectMyName(interp, contextPtr->oPtr);
    if (!namePtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"no possible safe callback without my", TCL_AUTO_LENGTH));
	OO_ERROR(interp, NO_MY);
	return TCL_ERROR;
    }

    /* No check that the method exists; could be dynamically added. */

    listPtr = Tcl_NewListObj(1, &namePtr);
    (void) TclListObjAppendElements(NULL, listPtr, objc-1, objv+1);
    Tcl_SetObjResult(interp, listPtr);
    return TCL_OK;
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOOClassVariableObjCmd --
 *
 *	Implementation of the [classvariable] command, which links to
 *	variables in the class of the current object.
 *
 * ----------------------------------------------------------------------
 */
int
TclOOClassVariableObjCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const *objv)
{
    Interp *iPtr = (Interp *) interp;
    CallFrame *framePtr = iPtr->varFramePtr;
    CallContext *contextPtr;
    Class *clsPtr;
    Tcl_Namespace *clsNsPtr, *ourNsPtr;
    Var *arrayPtr, *otherPtr;
    int i;

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "name ...");
	return TCL_ERROR;
    }

    /*
     * Start with sanity checks on the calling context to make sure that we
     * are invoked from a suitable method context. If so, we can safely
     * retrieve the handle to the object call context.
     */

    if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"%s may only be called from inside a method",
		TclGetString(objv[0])));
	OO_ERROR(interp, CONTEXT_REQUIRED);
	return TCL_ERROR;
    }

    /* Get a reference to the class's namespace */
    contextPtr = (CallContext *) framePtr->clientData;
    clsPtr = CurrentlyInvoked(contextPtr).mPtr->declaringClassPtr;
    if (clsPtr == NULL) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"method not defined by a class", TCL_AUTO_LENGTH));
	OO_ERROR(interp, UNMATCHED_CONTEXT);
	return TCL_ERROR;
    }
    clsNsPtr = clsPtr->thisPtr->namespacePtr;

    /* Check the list of variable names */
    for (i = 1; i < objc; i++) {
	const char *varName = TclGetString(objv[i]);
	if (Tcl_StringMatch(varName, "*(*)")) {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "bad variable name \"%s\": can't create a %s",
		    varName, "scalar variable that looks like an array element"));
	    Tcl_SetErrorCode(interp, "TCL", "UPVAR", "LOCAL_ELEMENT", NULL);
	    return TCL_ERROR;
	}
	if (Tcl_StringMatch(varName, "*::*")) {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "bad variable name \"%s\": can't create a %s",
		    varName, "local variable with a namespace separator in it"));
	    Tcl_SetErrorCode(interp, "TCL", "UPVAR", "LOCAL_ELEMENT", NULL);
	    return TCL_ERROR;
	}
    }

    /* Lastly, link the caller's local variables to the class's variables */
    ourNsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr;
    for (i = 1; i < objc; i++) {
	/* Locate the other variable. */
	iPtr->varFramePtr->nsPtr = (Namespace *) clsNsPtr;
	otherPtr = TclObjLookupVarEx(interp, objv[i], NULL,
		(TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG|TCL_AVOID_RESOLVERS),
		"access", /*createPart1*/ 1, /*createPart2*/ 0, &arrayPtr);
	iPtr->varFramePtr->nsPtr = (Namespace *) ourNsPtr;
	if (otherPtr == NULL) {
	    return TCL_ERROR;
	}

	/* Create the new variable and link it to otherPtr. */
	if (TclPtrObjMakeUpvarIdx(interp, otherPtr, objv[i], 0,
		TCL_INDEX_NONE) != TCL_OK) {
	    return TCL_ERROR;
	}
    }

    return TCL_OK;
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOODelegateNameObjCmd --
 *
 *	Implementation of the [oo::DelegateName] command, which is a utility
 *	that gets the name of the class delegate for a class. It's trivial,
 *	but makes working with them much easier as delegate names are
 *	intentionally hard to create by accident.
 *
 *	Not part of TclOO public API. No public documentation.
 *
 * ----------------------------------------------------------------------
 */
int
TclOODelegateNameObjCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const *objv)
{
    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "class");
	return TCL_ERROR;
    }
    Class *clsPtr = TclOOGetClassFromObj(interp, objv[1]);
    if (clsPtr == NULL) {
	return TCL_ERROR;
    }
    Tcl_SetObjResult(interp, Tcl_ObjPrintf("%s:: oo ::delegate",
	    clsPtr->thisPtr->namespacePtr->fullName));
    return TCL_OK;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

typedef struct DeclaredSlot {
    const char *name;
    const Tcl_MethodType getterType;
    const Tcl_MethodType setterType;
    const Tcl_MethodType resolverType;
} DeclaredSlot;

#define SLOT(name,getter,setter,resolver) \
    {"::oo::" name,							\
	    {TCL_OO_METHOD_VERSION_1, "core method: " name " Getter",	\
		    getter, NULL, NULL},				\
	    {TCL_OO_METHOD_VERSION_1, "core method: " name " Setter",	\
		    setter, NULL, NULL},				\
	    {TCL_OO_METHOD_VERSION_1, "core method: " name " Resolver",	\
		    resolver, NULL, NULL}}

typedef struct DeclaredSlotMethod {
    const char *name;
    int flags;
    const Tcl_MethodType implType;
} DeclaredSlotMethod;

#define SLOT_METHOD(name,impl,flags) \
    {name, flags, {TCL_OO_METHOD_VERSION_1,				\
	    "core method: " name " slot", impl, NULL, NULL}}

/*
 * A [string match] pattern used to determine if a method should be exported.
 */

#define PUBLIC_PATTERN		"[a-z]*"

/*

static inline int	InitDefineContext(Tcl_Interp *interp,
			    Tcl_Namespace *namespacePtr, Object *oPtr,
			    int objc, Tcl_Obj *const objv[]);
static inline void	RecomputeClassCacheFlag(Object *oPtr);
static int		RenameDeleteMethod(Tcl_Interp *interp, Object *oPtr,
			    int useClass, Tcl_Obj *const fromPtr,
			    Tcl_Obj *const toPtr);
static int		Slot_Append(void *,
			    Tcl_Interp *interp, Tcl_ObjectContext context,
			    int objc, Tcl_Obj *const *objv);
static int		Slot_AppendNew(void *,
			    Tcl_Interp *interp, Tcl_ObjectContext context,
			    int objc, Tcl_Obj *const *objv);
static int		Slot_Clear(void *,
			    Tcl_Interp *interp, Tcl_ObjectContext context,
			    int objc, Tcl_Obj *const *objv);
static int		Slot_Prepend(void *,
			    Tcl_Interp *interp, Tcl_ObjectContext context,
			    int objc, Tcl_Obj *const *objv);
static int		Slot_Remove(void *,
			    Tcl_Interp *interp, Tcl_ObjectContext context,
			    int objc, Tcl_Obj *const *objv);
static int		Slot_Resolve(void *,
			    Tcl_Interp *interp, Tcl_ObjectContext context,
			    int objc, Tcl_Obj *const *objv);
static int		Slot_Set(void *,
			    Tcl_Interp *interp, Tcl_ObjectContext context,
			    int objc, Tcl_Obj *const *objv);
static int		Slot_Unimplemented(void *,
			    Tcl_Interp *interp, Tcl_ObjectContext,
			    int, Tcl_Obj *const *);
static int		Slot_Unknown(void *,
			    Tcl_Interp *interp, Tcl_ObjectContext context,
			    int objc, Tcl_Obj *const *objv);
static int		ClassFilter_Get(void *clientData,
			    Tcl_Interp *interp, Tcl_ObjectContext context,
			    int objc, Tcl_Obj *const *objv);
static int		ClassFilter_Set(void *clientData,
			    Tcl_Interp *interp, Tcl_ObjectContext context,
			    int objc, Tcl_Obj *const *objv);
static int		ClassMixin_Get(void *clientData,

	    Configurable_ObjectReadableProps_Get,
	    Configurable_ObjectReadableProps_Set, NULL),
    SLOT("configuresupport::objwritableproperties",
	    Configurable_ObjectWritableProps_Get,
	    Configurable_ObjectWritableProps_Set, NULL),
    {NULL, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}}
};

static const DeclaredSlotMethod slotMethods[] = {
    SLOT_METHOD("Get",		Slot_Unimplemented, 0),
    SLOT_METHOD("Resolve",	Slot_Resolve,	0),
    SLOT_METHOD("Set",		Slot_Unimplemented, 0),
    SLOT_METHOD("-append",	Slot_Append,	PUBLIC_METHOD),
    SLOT_METHOD("-appendifnew",	Slot_AppendNew,	PUBLIC_METHOD),
    SLOT_METHOD("-clear",	Slot_Clear,	PUBLIC_METHOD),
    SLOT_METHOD("-prepend",	Slot_Prepend,	PUBLIC_METHOD),
    SLOT_METHOD("-remove",	Slot_Remove,	PUBLIC_METHOD),
    SLOT_METHOD("-set",		Slot_Set,	PUBLIC_METHOD),
    SLOT_METHOD("unknown",	Slot_Unknown,	0),
    {NULL, 0, {0, 0, 0, 0, 0}}
};

/*
 * How to build the in-namespace name of a private variable. This is a pattern
 * used with Tcl_ObjPrintf().
 */

#define PRIVATE_VARIABLE_PATTERN "%d : %s"

    }
    return TCL_OK;
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOODefineInitialiseObjCmd --
 *
 *	Implementation of the "initialise" subcommand of the "oo::define"
 *	command.
 *
 * ----------------------------------------------------------------------
 */

int
TclOODefineInitialiseObjCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const *objv)
{
    Tcl_Object object;
    Tcl_Obj *lambdaWords[3], *applyArgs[2];
    int result;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "body");
	return TCL_ERROR;
    }

    /* Build the lambda */
    object = TclOOGetDefineCmdContext(interp);
    if (object == NULL) {
	return TCL_ERROR;
    }
    lambdaWords[0] = Tcl_NewObj();
    lambdaWords[1] = objv[1];
    lambdaWords[2] = TclNewNamespaceObj(Tcl_GetObjectNamespace(object));

    /* Delegate to [apply] to run it */
    applyArgs[0] = Tcl_NewStringObj("apply", -1);
    applyArgs[1] = Tcl_NewListObj(3, lambdaWords);
    Tcl_IncrRefCount(applyArgs[0]);
    Tcl_IncrRefCount(applyArgs[1]);
    result = Tcl_ApplyObjCmd(NULL, interp, 2, applyArgs);
    Tcl_DecrRefCount(applyArgs[0]);
    Tcl_DecrRefCount(applyArgs[1]);
    return result;
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOODefineMethodObjCmd --
 *
 *	Implementation of the "method" subcommand of the "oo::define" and
 *	"oo::objdefine" commands.
 *
 * ----------------------------------------------------------------------
 */

	    return TCL_ERROR;
	}
    } else {
	if (TclOONewProcMethod(interp, oPtr->classPtr, isPublic, objv[1],
		objv[objc - 2], objv[objc - 1], NULL) == NULL) {
	    return TCL_ERROR;
	}
    }
    return TCL_OK;
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOODefineClassMethodObjCmd --
 *
 *	Implementation of the "classmethod" subcommand of the "oo::define"
 *	command. Defines a class method. See define(n) for details.
 *
 * ----------------------------------------------------------------------
 */

int
TclOODefineClassMethodObjCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const *objv)
{
    Class *clsPtr;
    int isPublic;
    Tcl_Obj *forwardArgs[2], *prefixObj;
    Method *mPtr;

    if (objc != 2 && objc != 4) {
	Tcl_WrongNumArgs(interp, 1, objv, "name ?args body?");
	return TCL_ERROR;
    }
    clsPtr = TclOOGetClassDefineCmdContext(interp);
    if (!clsPtr) {
	return TCL_ERROR;
    }

    isPublic = Tcl_StringMatch(TclGetString(objv[1]), PUBLIC_PATTERN)
	    ? PUBLIC_METHOD : 0;

    /*
     * Create the method on the delegate class if the caller gave arguments
     * and body.
     */
    if (objc == 4) {
	Tcl_Obj *delegateName = Tcl_ObjPrintf("%s:: oo ::delegate",
		clsPtr->thisPtr->namespacePtr->fullName);
	Class *delegatePtr = TclOOGetClassFromObj(interp, delegateName);

	Tcl_DecrRefCount(delegateName);
	if (!delegatePtr) {
	    return TCL_ERROR;
	}
	if (IsPrivateDefine(interp)) {
	    isPublic = 0;
	}
	if (TclOONewProcMethod(interp, delegatePtr, isPublic, objv[1],
		objv[2], objv[3], NULL) == NULL) {
	    return TCL_ERROR;
	}
    }

    /* Make the connection to the delegate by forwarding */
    if (IsPrivateDefine(interp)) {
	isPublic = TRUE_PRIVATE_METHOD;
    }
    forwardArgs[0] = Tcl_NewStringObj("myclass", -1);
    forwardArgs[1] = objv[1];
    prefixObj = Tcl_NewListObj(2, forwardArgs);
    mPtr = TclOONewForwardMethod(interp, clsPtr, isPublic, objv[1], prefixObj);
    if (mPtr == NULL) {
	Tcl_DecrRefCount(prefixObj);
	return TCL_ERROR;
    }
    return TCL_OK;
}

/*
 * ----------------------------------------------------------------------
 *

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

int
TclOODefineSlots(
    Foundation *fPtr)
{

    Tcl_Interp *interp = fPtr->interp;

    Tcl_Object object = Tcl_NewObjectInstance(interp, (Tcl_Class)
	    fPtr->classCls, "::oo::Slot", NULL, TCL_INDEX_NONE, NULL, 0);
    Tcl_Class slotCls;
    const DeclaredSlotMethod *smPtr;
    const DeclaredSlot *slotPtr;

    if (object == NULL) {
	return TCL_ERROR;
    }
    slotCls = (Tcl_Class) ((Object *) object)->classPtr;
    if (slotCls == NULL) {
	return TCL_ERROR;
    }

    for (smPtr = slotMethods; smPtr->name; smPtr++) {
	Tcl_Obj *name = Tcl_NewStringObj(smPtr->name, -1);
	Tcl_NewMethod(interp, slotCls, name, smPtr->flags,
		&smPtr->implType, NULL);
	Tcl_BounceRefCount(name);
    }

    for (slotPtr = slots ; slotPtr->name ; slotPtr++) {
	Tcl_Object slotObject = Tcl_NewObjectInstance(interp,
		slotCls, slotPtr->name, NULL, TCL_INDEX_NONE, NULL, 0);


	if (slotObject == NULL) {
	    continue;
	}
	TclNewInstanceMethod(interp, slotObject, fPtr->slotGetName, 0,
		&slotPtr->getterType, NULL);
	TclNewInstanceMethod(interp, slotObject, fPtr->slotSetName, 0,
		&slotPtr->setterType, NULL);
	if (slotPtr->resolverType.callProc) {
	    TclNewInstanceMethod(interp, slotObject, fPtr->slotResolveName, 0,
		    &slotPtr->resolverType, NULL);
	}
    }
    return TCL_OK;
}

/*
 * ----------------------------------------------------------------------
 *
 * CallSlotGet, CallSlotSet, CallSlotResolve, ResolveAll --
 *
 *	How to call the standard low-level methods of a slot.
 *	ResolveAll is the lifting of CallSlotResolve to work over a whole
 *	list of items.
 *
 * ----------------------------------------------------------------------
 */

/* Call [$slot Get] to retrieve the list of contents of the slot */
static inline Tcl_Obj *
CallSlotGet(
    Tcl_Interp *interp,
    Object *slot)
{
    Tcl_Obj *getArgs[2];
    int code;
    
    getArgs[0] = slot->fPtr->myName;
    getArgs[1] = slot->fPtr->slotGetName;
    code = TclOOPrivateObjectCmd(slot, interp, 2, getArgs);
    if (code != TCL_OK) {
	return NULL;
    }
    return Tcl_GetObjResult(interp);
}

/* Call [$slot Set $list] to set the list of contents of the slot */
static inline int
CallSlotSet(
    Tcl_Interp *interp,
    Object *slot,
    Tcl_Obj *list)
{
    Tcl_Obj *setArgs[3];
    setArgs[0] = slot->fPtr->myName;
    setArgs[1] = slot->fPtr->slotSetName;
    setArgs[2] = list;
    return TclOOPrivateObjectCmd(slot, interp, 3, setArgs);
}

/* Call [$slot Resolve $item] to convert a slot item into canonical form */
static inline Tcl_Obj *
CallSlotResolve(
    Tcl_Interp *interp,
    Object *slot,
    Tcl_Obj *item)
{
    Tcl_Obj *resolveArgs[3];
    int code;

    resolveArgs[0] = slot->fPtr->myName;
    resolveArgs[1] = slot->fPtr->slotResolveName;
    resolveArgs[2] = item;
    code = TclOOPrivateObjectCmd(slot, interp, 3, resolveArgs);
    if (code != TCL_OK) {
	return NULL;
    }
    return Tcl_GetObjResult(interp);
}

static inline Tcl_Obj *
ResolveAll(
    Tcl_Interp *interp,
    Object *slot,
    int objc,
    Tcl_Obj *const *objv)
{
    Tcl_Obj **resolvedItems = (Tcl_Obj **) TclStackAlloc(interp,
	    sizeof(Tcl_Obj *) * objc);
    Tcl_Obj *resolvedList;
    int i;

    for (i = 0; i < objc; i++) {
	resolvedItems[i] = CallSlotResolve(interp, slot, objv[i]);
	if (resolvedItems[i] == NULL) {
	    for (int j = 0; j < i; j++) {
		Tcl_DecrRefCount(resolvedItems[j]);
	    }
	    TclStackFree(interp, (void *) resolvedItems);
	    return NULL;
	}
	Tcl_IncrRefCount(resolvedItems[i]);
	Tcl_ResetResult(interp);
    }
    resolvedList = Tcl_NewListObj(objc, resolvedItems);
    for (i = 0; i < objc; i++) {
	TclDecrRefCount(resolvedItems[i]);
    }
    TclStackFree(interp, (void *) resolvedItems);
    return resolvedList;
}

/*
 * ----------------------------------------------------------------------
 *
 * Slot_Append --
 *
 *	Implementation of the "-append" slot operation.
 *
 * ----------------------------------------------------------------------
 */
static int
Slot_Append(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
    int skip = Tcl_ObjectContextSkippedArgs(context), code;
    Tcl_Obj *resolved, *list;

    if (skip == objc) {
	return TCL_OK;
    }

    /* Resolve all values */
    resolved = ResolveAll(interp, oPtr, objc - skip, objv + skip);
    if (resolved == NULL) {
	return TCL_ERROR;
    }

    /* Get slot contents; store in list */
    list = CallSlotGet(interp, oPtr);
    if (list == NULL) {
	Tcl_DecrRefCount(resolved);
	return TCL_ERROR;
    }
    Tcl_IncrRefCount(list);
    Tcl_ResetResult(interp);

    /* Append */
    if (Tcl_IsShared(list)) {
	Tcl_Obj *dup = Tcl_DuplicateObj(list);
	Tcl_IncrRefCount(dup);
	Tcl_DecrRefCount(list);
	list = dup;
    }
    if (Tcl_ListObjAppendList(interp, list, resolved) != TCL_OK) {
	Tcl_DecrRefCount(list);
	Tcl_DecrRefCount(resolved);
	return TCL_ERROR;
    }
    Tcl_DecrRefCount(resolved);

    /* Set slot contents */
    code = CallSlotSet(interp, oPtr, list);
    Tcl_DecrRefCount(list);
    return code;
}

/*
 * ----------------------------------------------------------------------
 *
 * Slot_AppendNew --
 *
 *	Implementation of the "-appendifnew" slot operation.
 *
 * ----------------------------------------------------------------------
 */
static int
Slot_AppendNew(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
    int skip = Tcl_ObjectContextSkippedArgs(context), code, isNew;
    Tcl_Obj *resolved, *list, **listv;
    Tcl_Size listc, i;
    Tcl_HashTable unique;

    if (skip == objc) {
	return TCL_OK;
    }

    /* Resolve all values */
    resolved = ResolveAll(interp, oPtr, objc - skip, objv + skip);
    if (resolved == NULL) {
	return TCL_ERROR;
    }

    /* Get slot contents; store in list */
    list = CallSlotGet(interp, oPtr);
    if (list == NULL) {
	Tcl_DecrRefCount(resolved);
	return TCL_ERROR;
    }
    Tcl_IncrRefCount(list);
    Tcl_ResetResult(interp);

    /* Prepare a set of items in the list to set */
    if (TclListObjGetElements(interp, list, &listc, &listv) != TCL_OK) {
	Tcl_DecrRefCount(list);
	Tcl_DecrRefCount(resolved);
	return TCL_ERROR;
    }
    Tcl_InitObjHashTable(&unique);
    for (i=0 ; i<listc; i++) {
	Tcl_CreateHashEntry(&unique, listv[i], &isNew);
    }

    /* Append the new items if they're not already there */
    if (Tcl_IsShared(list)) {
	Tcl_Obj *dup = Tcl_DuplicateObj(list);
	Tcl_IncrRefCount(dup);
	Tcl_DecrRefCount(list);
	list = dup;
    }
    TclListObjGetElements(NULL, resolved, &listc, &listv);
    for (i=0 ; i<listc; i++) {
	Tcl_CreateHashEntry(&unique, listv[i], &isNew);
	if (isNew) {
	    Tcl_ListObjAppendElement(interp, list, listv[i]);
	}
    }
    Tcl_DecrRefCount(resolved);
    Tcl_DeleteHashTable(&unique);

    /* Set slot contents */
    code = CallSlotSet(interp, oPtr, list);
    Tcl_DecrRefCount(list);
    return code;
}

/*
 * ----------------------------------------------------------------------
 *
 * Slot_Clear --
 *
 *	Implementation of the "-clear" slot operation.
 *
 * ----------------------------------------------------------------------
 */
static int
Slot_Clear(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
    int skip = Tcl_ObjectContextSkippedArgs(context), code;
    Tcl_Obj *list;

    if (skip != objc) {
	Tcl_WrongNumArgs(interp, skip, objv, NULL);
	return TCL_ERROR;
    }
    list = Tcl_NewObj();
    Tcl_IncrRefCount(list);
    code = CallSlotSet(interp, oPtr, list);
    Tcl_DecrRefCount(list);
    return code;
}

/*
 * ----------------------------------------------------------------------
 *
 * Slot_Prepend --
 *
 *	Implementation of the "-prepend" slot operation.
 *
 * ----------------------------------------------------------------------
 */
static int
Slot_Prepend(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
    int skip = Tcl_ObjectContextSkippedArgs(context), code;
    Tcl_Obj *list, *oldList;
    if (skip == objc) {
	return TCL_OK;
    }

    /* Resolve all values */
    list = ResolveAll(interp, oPtr, objc - skip, objv + skip);
    if (list == NULL) {
	return TCL_ERROR;
    }
    Tcl_IncrRefCount(list);

    /* Get slot contents and append to list */
    oldList = CallSlotGet(interp, oPtr);
    if (oldList == NULL) {
	Tcl_DecrRefCount(list);
	return TCL_ERROR;
    }
    Tcl_ListObjAppendList(NULL, list, oldList);
    Tcl_ResetResult(interp);

    /* Set slot contents */
    code = CallSlotSet(interp, oPtr, list);
    Tcl_DecrRefCount(list);
    return code;
}

/*
 * ----------------------------------------------------------------------
 *
 * Slot_Remove --
 *
 *	Implementation of the "-remove" slot operation.
 *
 * ----------------------------------------------------------------------
 */
static int
Slot_Remove(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
    int skip = Tcl_ObjectContextSkippedArgs(context), code, isNew;
    Tcl_Size listc, i;
    Tcl_Obj *resolved, *oldList, *newList, **listv;
    Tcl_HashTable removeSet;

    if (skip == objc) {
	return TCL_OK;
    }

    /* Resolve all values */
    resolved = ResolveAll(interp, oPtr, objc - skip, objv + skip);
    if (resolved == NULL) {
	return TCL_ERROR;
    }

    /* Get slot contents; store in list */
    oldList = CallSlotGet(interp, oPtr);
    if (oldList == NULL) {
	Tcl_DecrRefCount(resolved);
	return TCL_ERROR;
    }
    Tcl_IncrRefCount(oldList);
    Tcl_ResetResult(interp);

    /* Prepare a set of items in the list to remove */
    TclListObjGetElements(NULL, resolved, &listc, &listv);
    Tcl_InitObjHashTable(&removeSet);
    for (i=0 ; i<listc; i++) {
	Tcl_CreateHashEntry(&removeSet, listv[i], &isNew);
    }
    Tcl_DecrRefCount(resolved);

    /* Append the new items from the old items if they're not in the remove set */
    if (TclListObjGetElements(interp, oldList, &listc, &listv) != TCL_OK) {
	Tcl_DecrRefCount(oldList);
	Tcl_DeleteHashTable(&removeSet);
	return TCL_ERROR;
    }
    newList = Tcl_NewObj();
    for (i=0 ; i<listc; i++) {
	if (Tcl_FindHashEntry(&removeSet, listv[i]) == NULL) {
	    Tcl_ListObjAppendElement(NULL, newList, listv[i]);
	}
    }
    Tcl_DecrRefCount(oldList);
    Tcl_DeleteHashTable(&removeSet);

    /* Set slot contents */
    Tcl_IncrRefCount(newList);
    code = CallSlotSet(interp, oPtr, newList);
    Tcl_DecrRefCount(newList);
    return code;
}

/*
 * ----------------------------------------------------------------------
 *
 * Slot_Resolve --
 *
 *	Default implementation of the "Resolve" slot accessor. Just returns
 *	its argument unchanged; particular slots may override.
 *
 * ----------------------------------------------------------------------
 */
static int
Slot_Resolve(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    int skip = Tcl_ObjectContextSkippedArgs(context);
    if (skip + 1 != objc) {
	Tcl_WrongNumArgs(interp, skip, objv, "list");
	return TCL_ERROR;
    }
    Tcl_SetObjResult(interp, objv[objc - 1]);
    return TCL_OK;
}

/*
 * ----------------------------------------------------------------------
 *
 * Slot_Set --
 *
 *	Implementation of the "-set" slot operation.
 *
 * ----------------------------------------------------------------------
 */
static int
Slot_Set(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
    int skip = Tcl_ObjectContextSkippedArgs(context), code;
    Tcl_Obj *list;

    /* Resolve all values */
    if (skip == objc) {
	list = Tcl_NewObj();
    } else {
	list = ResolveAll(interp, oPtr, objc - skip, objv + skip);
	if (list == NULL) {
	    return TCL_ERROR;
	}
    }
    Tcl_IncrRefCount(list);

    /* Set slot contents */
    code = CallSlotSet(interp, oPtr, list);
    Tcl_DecrRefCount(list);
    return code;
}

/*
 * ----------------------------------------------------------------------
 *
 * Slot_Unimplemented --
 *
 *	Default implementation of the "Get" and "Set" slot accessors. Just
 *	returns an error; actual slots must override.
 *
 * ----------------------------------------------------------------------
 */
static int
Slot_Unimplemented(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    TCL_UNUSED(Tcl_ObjectContext),
    TCL_UNUSED(int),
    TCL_UNUSED(Tcl_Obj *const *))
{
    Tcl_SetObjResult(interp, Tcl_NewStringObj("unimplemented", -1));
    OO_ERROR(interp, ABSTRACT_SLOT);
    return TCL_ERROR;
}

/*
 * ----------------------------------------------------------------------
 *
 * Slot_Unknown --
 *
 *	Unknown method name handler for slots. Delegates to the default slot
 *	operation (--default-operation forwarded method) unless the first
 *	argument starts with a dash.
 *
 * ----------------------------------------------------------------------
 */
static int
Slot_Unknown(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
    int skip = Tcl_ObjectContextSkippedArgs(context), code;
    if (skip >= objc) {
	Tcl_Obj *args[2];
	args[0] = oPtr->fPtr->myName;
	args[1] = oPtr->fPtr->slotDefOpName;
	return TclOOPrivateObjectCmd(oPtr, interp, 2, args);
    } else if (TclGetString(objv[skip])[0] != '-') {
	Tcl_Obj **args = (Tcl_Obj **) TclStackAlloc(interp,
		sizeof(Tcl_Obj *) * (objc - skip + 2));
	args[0] = oPtr->fPtr->myName;
	args[1] = oPtr->fPtr->slotDefOpName;
	memcpy(args+2, objv+skip, sizeof(Tcl_Obj*) * (objc - skip));
	code = TclOOPrivateObjectCmd(oPtr, interp, objc - skip + 2, args);
	TclStackFree(interp, args);
	return code;
    }
    return TclNRObjectContextInvokeNext(interp, context, objc, objv, skip);
}

/*
 * ----------------------------------------------------------------------
 *
 * ClassFilter_Get, ClassFilter_Set --
 *

				/* Configurations for the variable resolver
				 * used inside methods. */
    Tcl_Command myclassCommand;	/* Reference to this object's class dispatcher
				 * command. */
    PropertyStorage properties;	/* Information relating to the lists of
				 * properties that this object *claims* to
				 * support. */
    Tcl_Obj *linkedCmdsList;	/* List of names of linked commands. */
};

enum ObjectFlags {
    OBJECT_DESTRUCTING = 1,	/* Indicates that an object is being or has
				 *  been destroyed  */
    DESTRUCTOR_CALLED = 2,	/* Indicates that evaluation of destructor
				 * script for the object has began */

				 * constructor. */
    Tcl_Obj *destructorName;	/* Shared object containing the "name" of a
				 * destructor. */
    Tcl_Obj *clonedName;	/* Shared object containing the name of a
				 * "<cloned>" pseudo-constructor. */
    Tcl_Obj *defineName;	/* Fully qualified name of oo::define. */
    Tcl_Obj *myName;		/* The "my" shared object. */
    Tcl_Obj *slotGetName;	/* The "Get" name used by slots. */
    Tcl_Obj *slotSetName;	/* The "Set" name used by slots. */
    Tcl_Obj *slotResolveName;	/* The "Resolve" name used by slots. */
    Tcl_Obj *slotDefOpName;	/* The "--default-operation" name used by slots. */
};

/*
 * The number of MInvoke records in the CallChain before we allocate
 * separately.
 */
#define CALL_CHAIN_STATIC_SIZE 4

 * Commands relating to OO support.
 *----------------------------------------------------------------
 */

MODULE_SCOPE int		TclOOInit(Tcl_Interp *interp);
MODULE_SCOPE Tcl_ObjCmdProc	TclOODefineObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc	TclOOObjDefObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc	TclOODefineClassMethodObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc	TclOODefineConstructorObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc	TclOODefineDefnNsObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc	TclOODefineDeleteMethodObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc	TclOODefineDestructorObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc	TclOODefineExportObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc	TclOODefineForwardObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc	TclOODefineInitialiseObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc	TclOODefineMethodObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc	TclOODefineRenameMethodObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc	TclOODefineUnexportObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc	TclOODefineClassObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc	TclOODefineSelfObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc	TclOODefineObjSelfObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc	TclOODefinePrivateObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc	TclOODefinePropertyCmd;
MODULE_SCOPE Tcl_ObjCmdProc	TclOOUnknownDefinition;
MODULE_SCOPE Tcl_ObjCmdProc	TclOOCallbackObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc	TclOOClassVariableObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc	TclOOCopyObjectCmd;
MODULE_SCOPE Tcl_ObjCmdProc	TclOODelegateNameObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc	TclOOLinkObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc	TclOONextObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc	TclOONextToObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc	TclOOSelfObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc	TclOOInfoObjectPropCmd;
MODULE_SCOPE Tcl_ObjCmdProc	TclOOInfoClassPropCmd;

/*

			    Tcl_Var *aryPtr);
MODULE_SCOPE int	TclNRObjectContextInvokeNext(Tcl_Interp *interp,
			    Tcl_ObjectContext context, Tcl_Size objc,
			    Tcl_Obj *const *objv, Tcl_Size skip);
MODULE_SCOPE void	TclOODefineBasicMethods(Class *clsPtr,
			    const DeclaredClassMethod *dcm);
MODULE_SCOPE Tcl_Obj *	TclOOObjectName(Tcl_Interp *interp, Object *oPtr);
MODULE_SCOPE Tcl_Obj *	TclOOObjectMyName(Tcl_Interp *interp, Object *oPtr);
MODULE_SCOPE void	TclOOReleaseClassContents(Tcl_Interp *interp,
			    Object *oPtr);
MODULE_SCOPE int	TclOORemoveFromInstances(Object *oPtr, Class *clsPtr);
MODULE_SCOPE int	TclOORemoveFromMixins(Class *mixinPtr, Object *oPtr);
MODULE_SCOPE int	TclOORemoveFromMixinSubs(Class *subPtr,
			    Class *mixinPtr);
MODULE_SCOPE int	TclOORemoveFromSubclasses(Class *subPtr,

 * contains the commented version of everything; *this* file is automatically
 * generated.
 */

static const char *tclOOSetupScript =
/* !BEGIN!: Do not edit below this line. */
"::namespace eval ::oo {\n"
































































































































































"\tdefine Slot forward --default-operation my -append\n"









"\tdefine Slot unexport destroy\n"

"\tobjdefine define::superclass forward --default-operation my -set\n"
"\tobjdefine define::mixin forward --default-operation my -set\n"
"\tobjdefine objdefine::mixin forward --default-operation my -set\n"
"\tdefine object method <cloned> -unexport {originObject} {\n"
"\t\tforeach p [info procs [info object namespace $originObject]::*] {\n"
"\t\t\tset args [info args $p]\n"
"\t\t\tset idx -1\n"

"\t\t\t\t} else {\n"
"\t\t\t\t\tset vNew $vOrigin\n"
"\t\t\t\t}\n"
"\t\t\t}\n"
"\t\t}\n"
"\t}\n"
"\tdefine class method <cloned> -unexport {originObject} {\n"
"\t\tset targetObject [self]\n"
"\t\tnext $originObject\n"
"\t\tset originDelegate [::oo::DelegateName $originObject]\n"
"\t\tset targetDelegate [::oo::DelegateName $targetObject]\n"
"\t\tif {\n"
"\t\t\t[info object isa class $originDelegate]\n"
"\t\t\t&& ![info object isa class $targetDelegate]\n"
"\t\t} then {\n"
"\t\t\t::oo::copy $originDelegate $targetDelegate\n"
"\t\t\t::oo::objdefine $targetObject mixin -set \\\n"
"\t\t\t\t{*}[lmap c [info object mixin $targetObject] {\n"
"\t\t\t\t\tif {$c eq $originDelegate} {set targetDelegate} {set c}\n"
"\t\t\t\t}]\n"
"\t\t}\n"
"\t}\n"
"\tclass create singleton\n"
"\tdefine singleton superclass -set class\n"
"\tdefine singleton variable -set object\n"
"\tdefine singleton unexport create createWithNamespace\n"
"\tdefine singleton method new args {\n"
"\t\tif {![info exists object] || ![info object isa object $object]} {\n"
"\t\t\tset object [next {*}$args]\n"
"\t\t\t::oo::objdefine $object {\n"
"\t\t\t\tmethod destroy {} {\n"
"\t\t\t\t\treturn -code error -errorcode {TCL OO SINGLETON} \\\n"
"\t\t\t\t\t\t\"may not destroy a singleton object\"\n"
"\t\t\t\t}\n"
"\t\t\t\tmethod <cloned> -unexport {originObject} {\n"
"\t\t\t\t\treturn -code error -errorcode {TCL OO SINGLETON} \\\n"
"\t\t\t\t\t\t\"may not clone a singleton object\"\n"

"\t\t\t\t}\n"
"\t\t\t}\n"

"\t\t}\n"
"\t\treturn $object\n"
"\t}\n"
"\tclass create abstract\n"
"\tdefine abstract superclass -set class\n"
"\tdefine abstract unexport create createWithNamespace new\n"

"\tnamespace eval configuresupport::configurableclass {\n"

"\t\t::proc properties args {::tailcall property {*}$args}\n"
"\t\t::namespace path ::oo::define\n"
"\t\t::namespace export property\n"
"\t}\n"
"\tnamespace eval configuresupport::configurableobject {\n"
"\t\t::proc properties args {::tailcall property {*}$args}\n"
"\t\t::namespace path ::oo::objdefine\n"
"\t\t::namespace export property\n"
"\t}\n"
"\tdefine configuresupport::configurable {\n"
"\t\tdefinitionnamespace -instance configuresupport::configurableobject\n"
"\t\tdefinitionnamespace -class configuresupport::configurableclass\n"

"\t}\n"
"\tclass create configurable\n"
"\tdefine configurable superclass -set class\n"
"\tdefine configurable constructor {{definitionScript \"\"}} {\n"
"\t\too::define [self] {mixin -append ::oo::configuresupport::configurable}\n"
"\t\tnext $definitionScript\n"
"\t}\n"
"\tdefine configurable definitionnamespace -class configuresupport::configurableclass\n"

"}\n"
/* !END!: Do not edit above this line. */
;

#endif /* TCL_OO_SCRIPT_H */

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

	lappend ::result {*}$args
    }
    set result {}
} -body {
    trace add execution oo::define::initialise enter appendToResultVar
    oo::class create ::cls {
	superclass parent
	initialise {proc xyzzy {} {}}
    }
    return $result
} -cleanup {
    catch {
	trace remove execution oo::define::initialise enter appendToResultVar
    }
    rename ::appendToResultVar {}
    parent destroy
} -result {{initialise {proc xyzzy {} {}}} enter}







test ooUtil-4.1 {TIP 478: singleton} -setup {
    oo::class create parent
} -body {
    oo::singleton create xyz {
	superclass parent
    }

# Copyright © 2013 Andreas Kupries
# Copyright © 2017 Gerald Lester
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.

::namespace eval ::oo {

































































































































































































































    # ----------------------------------------------------------------------
    #
    # Slot --
    #
    #	The class of slot operations, which are basically lists at the low
    #	level of TclOO; this provides a more consistent interface to them.
    #
    # ----------------------------------------------------------------------


    # ------------------------------------------------------------------
    #









































    # Slot --default-operation --
    #
    #	If a slot can't figure out what method to call directly, it
    #	uses --default-operation.
    #
    # ------------------------------------------------------------------
    define Slot forward --default-operation my -append


















































    # Hide destroy
    define Slot unexport destroy


    # Set the default operation differently for these slots
    objdefine define::superclass forward --default-operation my -set
    objdefine define::mixin forward --default-operation my -set
    objdefine objdefine::mixin forward --default-operation my -set

    # ----------------------------------------------------------------------

    # oo::class <cloned> --
    #
    #	Handler for cloning classes, which fixes up the delegates.
    #
    # ----------------------------------------------------------------------

    define class method <cloned> -unexport {originObject} {
	set targetObject [self]
	next $originObject
	# Rebuild the class inheritance delegation class
	set originDelegate [::oo::DelegateName $originObject]
	set targetDelegate [::oo::DelegateName $targetObject]
	if {
	    [info object isa class $originDelegate]
	    && ![info object isa class $targetDelegate]
	} then {
	    ::oo::copy $originDelegate $targetDelegate
	    ::oo::objdefine $targetObject mixin -set \
		{*}[lmap c [info object mixin $targetObject] {
		    if {$c eq $originDelegate} {set targetDelegate} {set c}
		}]
	}
    }

    # ----------------------------------------------------------------------
    #
    # oo::singleton --
    #
    #	A metaclass that is used to make classes that only permit one instance
    #	of them to exist. See singleton(n).
    #
    # ----------------------------------------------------------------------

    class create singleton
    define singleton superclass -set class
    define singleton variable -set object
    define singleton unexport create createWithNamespace
    define singleton method new args {
	if {![info exists object] || ![info object isa object $object]} {
	    set object [next {*}$args]
	    ::oo::objdefine $object {
		method destroy {} {
		    return -code error -errorcode {TCL OO SINGLETON} \
			"may not destroy a singleton object"
		}
		method <cloned> -unexport {originObject} {
		    return -code error -errorcode {TCL OO SINGLETON} \
			"may not clone a singleton object"
		}
	    }
	}
	return $object

    }

    # ----------------------------------------------------------------------
    #
    # oo::abstract --
    #
    #	A metaclass that is used to make classes that can't be directly
    #	instantiated. See abstract(n).
    #
    # ----------------------------------------------------------------------

    class create abstract
    define abstract superclass -set class
    define abstract unexport create createWithNamespace new


    # ----------------------------------------------------------------------
    #
    # oo::configuresupport --
    #
    #	Namespace that holds all the implementation details of TIP #558.
    #	Also includes the commands:

    #	These cause very fast basic implementation methods for a property
    #	following the standard model of property implementation naming.
    #	Property schemes that use other models (such as to be more Tk-like)
    #	should not use these (or the oo::cconfigurable metaclass).
    #
    # ----------------------------------------------------------------------


    # ------------------------------------------------------------------
    #
    # oo::configuresupport::configurableclass,
    # oo::configuresupport::configurableobject --
    #
    #	Namespaces used as implementation vectors for oo::define and
    #	oo::objdefine when the class/instance is configurable.
    #	Note that these also contain commands implemented in C,
    #	especially the [property] definition command.
    #
    # ------------------------------------------------------------------

    namespace eval configuresupport::configurableclass {
	# Plural alias just in case; deliberately NOT documented!
	::proc properties args {::tailcall property {*}$args}
	::namespace path ::oo::define
	::namespace export property
    }

    namespace eval configuresupport::configurableobject {
	# Plural alias just in case; deliberately NOT documented!
	::proc properties args {::tailcall property {*}$args}
	::namespace path ::oo::objdefine
	::namespace export property
    }

    # ------------------------------------------------------------------
    #
    # oo::configuresupport::configurable --
    #
    #	The class that contains the implementation of the actual
    #	'configure' method (mixed into actually configurable classes).
    #	The 'configure' method is in tclOOBasic.c.
    #
    # ------------------------------------------------------------------

    define configuresupport::configurable {
	definitionnamespace -instance configuresupport::configurableobject
	definitionnamespace -class configuresupport::configurableclass

    }

    # ----------------------------------------------------------------------
    #
    # oo::configurable --
    #
    #	A metaclass that is used to make classes that can be configured in
    #	their creation phase (and later too). All the metaclass itself does is
    #	arrange for the class created to have a 'configure' method and for
    #	oo::define and oo::objdefine (on the class and its instances) to have
    #	a property definition for setting things up for 'configure'.
    #
    # ----------------------------------------------------------------------

    class create configurable
    define configurable superclass -set class

    define configurable constructor {{definitionScript ""}} {
	::oo::define [self] {mixin -append ::oo::configuresupport::configurable}
	next $definitionScript
    }

    define configurable definitionnamespace -class configuresupport::configurableclass

}

# Local Variables:
# mode: tcl
# c-basic-offset: 4
# fill-column: 78
# End: