*/

#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		AliasCreate(Tcl_Interp *interp,
			    Tcl_Interp *childInterp, Tcl_Interp *parentInterp,
			    Tcl_Obj *namePtr, Tcl_Obj *targetPtr, Tcl_Size objc,
			    Tcl_Obj *const objv[]);
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 AliasCreate(interp, childInterp, parentInterp, objv[3],
	    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 = AliasCreate(childInterp, childInterp, targetInterp, childObjPtr,
    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 = AliasCreate(childInterp, childInterp, targetInterp, childObjPtr,
    result = TclAliasCreate(childInterp, childInterp, targetInterp, childObjPtr,
	    targetObjPtr, objc, objv);

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

	nextAliasPtr = (Alias *) aliasCmdPtr->objClientData;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * AliasCreate --
 * 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.
 *
 *----------------------------------------------------------------------
 */

static int
AliasCreate(
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 = AliasCreate(interp, childInterp, parentInterp, 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 AliasCreate(interp, childInterp, interp, objv[2],
		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 {
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->mcdName, "::oo::MixinClassDelegates");
    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->mcdName);
    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.
     */

    CreateCmdInNS(interp, fPtr->helpersNs, "next",
    for (i = 0 ; helpCmds[i].name ; i++) {
	    NULL, TclOONextObjCmd, TclCompileObjectNextCmd);
    CreateCmdInNS(interp, fPtr->helpersNs, "nextto",
	    NULL, TclOONextToObjCmd, TclCompileObjectNextToCmd);
    CreateCmdInNS(interp, fPtr->helpersNs, "self",
	    TclOOSelfObjCmd, NULL, TclCompileObjectSelfCmd);

	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);
    }
    CreateCmdInNS(interp, fPtr->ooNs, "define", TclOODefineObjCmd, NULL, NULL);
    CreateCmdInNS(interp, fPtr->ooNs, "objdefine", TclOOObjDefObjCmd, NULL, NULL);
    CreateCmdInNS(interp, fPtr->ooNs, "copy", TclOOCopyObjectCmd, NULL, NULL);

    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->mcdName);
    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	DecrRefsPostClassConstructor;
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, *nameObj;
    Tcl_Obj **invoke, *delegateName;

    size_t skip = Tcl_ObjectContextSkippedArgs(context);
    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]
     */

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

    /*
     * 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_OK;
	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, DecrRefsPostClassConstructor,
	    invoke, oPtr, NULL, NULL);
    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
DecrRefsPostClassConstructor(
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;
    int code;

    TclDecrRefCount(invoke[0]);
    TclDecrRefCount(invoke[1]);
    TclDecrRefCount(invoke[2]);
    invoke[0] = oPtr->fPtr->mcdName;
    invoke[1] = TclOOObjectName(interp, oPtr);
    Tcl_IncrRefCount(invoke[0]);
    TclStackFree(interp, invoke);

    Tcl_IncrRefCount(invoke[1]);
    saved = Tcl_SaveInterpState(interp, result);
    code = Tcl_EvalObjv(interp, 2, invoke, 0);
    TclDecrRefCount(invoke[0]);
    MixinClassDelegates(interp, oPtr, delegateName);
    Tcl_DecrRefCount(delegateName);
    TclDecrRefCount(invoke[1]);
    TclStackFree(interp, invoke);
    if (code != TCL_OK) {
	Tcl_DiscardInterpState(saved);
	return code;
    }
    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)				\
#define SLOT(name,getter,setter,resolver) \
    {"::oo::" name,							\
	    {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Getter", \
	    {TCL_OO_METHOD_VERSION_1, "core method: " name " Getter",	\
		    getter, NULL, NULL},				\
	    {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Setter", \
	    {TCL_OO_METHOD_VERSION_1, "core method: " name " Setter",	\
		    setter, NULL, NULL},				\
	    {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Resolver", \
	    {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)
{
    const DeclaredSlot *slotInfoPtr;
    Tcl_Interp *interp = fPtr->interp;
    Tcl_Obj *getName, *setName, *resolveName;
    Tcl_Object object = Tcl_NewObjectInstance(interp, (Tcl_Class)
	    fPtr->classCls, "::oo::Slot", NULL, TCL_INDEX_NONE, NULL, 0);
    Class *slotCls;
    Tcl_Class slotCls;
    const DeclaredSlotMethod *smPtr;
    const DeclaredSlot *slotPtr;

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

    for (smPtr = slotMethods; smPtr->name; smPtr++) {
    TclNewLiteralStringObj(getName, "Get");
    TclNewLiteralStringObj(setName, "Set");
    TclNewLiteralStringObj(resolveName, "Resolve");
    for (slotInfoPtr = slots ; slotInfoPtr->name ; slotInfoPtr++) {
	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,
		(Tcl_Class) slotCls, slotInfoPtr->name, NULL, TCL_INDEX_NONE,
		slotCls, slotPtr->name, NULL, TCL_INDEX_NONE, NULL, 0);
		NULL, 0);

	if (slotObject == NULL) {
	    continue;
	}
	TclNewInstanceMethod(interp, slotObject, getName, 0,
		&slotInfoPtr->getterType, NULL);
	TclNewInstanceMethod(interp, slotObject, setName, 0,
		&slotInfoPtr->setterType, NULL);
	if (slotInfoPtr->resolverType.callProc) {
	    TclNewInstanceMethod(interp, slotObject, resolveName, 0,
		    &slotInfoPtr->resolverType, NULL);
	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_BounceRefCount(getName);
    Tcl_BounceRefCount(setName);
    Tcl_BounceRefCount(resolveName);
    return TCL_OK;
    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 *mcdName;		/* The shared object for calling the helper to
				 * mix in class delegates. */
    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"
"\t::namespace path {}\n"
"\tnamespace eval Helpers {\n"
"\t\tnamespace path {}\n"
"\t\tproc callback {method args} {\n"
"\t\t\tlist [uplevel 1 {::namespace which my}] $method {*}$args\n"
"\t\t}\n"
"\t\tnamespace export callback\n"
"\t\tnamespace eval tmp {namespace import ::oo::Helpers::callback}\n"
"\t\tnamespace export -clear\n"
"\t\trename tmp::callback mymethod\n"
"\t\tnamespace delete tmp\n"
"\t\tproc classvariable {name args} {\n"
"\t\t\tset ns [info object namespace [uplevel 1 {self class}]]\n"
"\t\t\tforeach v [list $name {*}$args] {\n"
"\t\t\t\tif {[string match *(*) $v]} {\n"
"\t\t\t\t\tset reason \"can\'t create a scalar variable that looks like an array element\"\n"
"\t\t\t\t\treturn -code error -errorcode {TCL UPVAR LOCAL_ELEMENT} \\\n"
"\t\t\t\t\t\t[format {bad variable name \"%s\": %s} $v $reason]\n"
"\t\t\t\t}\n"
"\t\t\t\tif {[string match *::* $v]} {\n"
"\t\t\t\t\tset reason \"can\'t create a local variable with a namespace separator in it\"\n"
"\t\t\t\t\treturn -code error -errorcode {TCL UPVAR INVERTED} \\\n"
"\t\t\t\t\t\t[format {bad variable name \"%s\": %s} $v $reason]\n"
"\t\t\t\t}\n"
"\t\t\t\tlappend vs $v $v\n"
"\t\t\t}\n"
"\t\t\ttailcall namespace upvar $ns {*}$vs\n"
"\t\t}\n"
"\t\tproc link {args} {\n"
"\t\t\tset ns [uplevel 1 {::namespace current}]\n"
"\t\t\tforeach link $args {\n"
"\t\t\t\tif {[llength $link] == 2} {\n"
"\t\t\t\t\tlassign $link src dst\n"
"\t\t\t\t} elseif {[llength $link] == 1} {\n"
"\t\t\t\t\tlassign $link src\n"
"\t\t\t\t\tset dst $src\n"
"\t\t\t\t} else {\n"
"\t\t\t\t\treturn -code error -errorcode {TCL OO CMDLINK_FORMAT} \\\n"
"\t\t\t\t\t\t\"bad link description; must only have one or two elements\"\n"
"\t\t\t\t}\n"
"\t\t\t\tif {![string match ::* $src]} {\n"
"\t\t\t\t\tset src [string cat $ns :: $src]\n"
"\t\t\t\t}\n"
"\t\t\t\tinterp alias {} $src {} ${ns}::my $dst\n"
"\t\t\t\ttrace add command ${ns}::my delete [list \\\n"
"\t\t\t\t\t::oo::UnlinkLinkedCommand $src]\n"
"\t\t\t}\n"
"\t\t\treturn\n"
"\t\t}\n"
"\t}\n"
"\tproc UnlinkLinkedCommand {cmd args} {\n"
"\t\tif {[namespace which $cmd] ne {}} {\n"
"\t\t\trename $cmd {}\n"
"\t\t}\n"
"\t}\n"
"\tproc DelegateName {class} {\n"
"\t\tstring cat [info object namespace $class] {:: oo ::delegate}\n"
"\t}\n"
"\tproc MixinClassDelegates {class} {\n"
"\t\tif {![info object isa class $class]} {\n"
"\t\t\treturn\n"
"\t\t}\n"
"\t\tset delegate [DelegateName $class]\n"
"\t\tif {![info object isa class $delegate]} {\n"
"\t\t\treturn\n"
"\t\t}\n"
"\t\tforeach c [info class superclass $class] {\n"
"\t\t\tset d [DelegateName $c]\n"
"\t\t\tif {![info object isa class $d]} {\n"
"\t\t\t\tcontinue\n"
"\t\t\t}\n"
"\t\t\tdefine $delegate ::oo::define::superclass -appendifnew $d\n"
"\t\t}\n"
"\t\tobjdefine $class ::oo::objdefine::mixin -appendifnew $delegate\n"
"\t}\n"
"\tproc UpdateClassDelegatesAfterClone {originObject targetObject} {\n"
"\t\tset originDelegate [DelegateName $originObject]\n"
"\t\tset targetDelegate [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\tcopy $originDelegate $targetDelegate\n"
"\t\t\tobjdefine $targetObject ::oo::objdefine::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"
"\tproc define::classmethod {name args} {\n"
"\t\t::set argc [::llength [::info level 0]]\n"
"\t\t::if {$argc == 3} {\n"
"\t\t\t::return -code error -errorcode {TCL WRONGARGS} [::format \\\n"
"\t\t\t\t{wrong # args: should be \"%s name \?args body\?\"} \\\n"
"\t\t\t\t[::lindex [::info level 0] 0]]\n"
"\t\t}\n"
"\t\t::set cls [::uplevel 1 self]\n"
"\t\t::if {$argc == 4} {\n"
"\t\t\t::oo::define [::oo::DelegateName $cls] method $name {*}$args\n"
"\t\t}\n"
"\t\t::tailcall forward $name myclass $name\n"
"\t}\n"
"\tproc define::initialise {body} {\n"
"\t\t::set clsns [::info object namespace [::uplevel 1 self]]\n"
"\t\t::tailcall apply [::list {} $body $clsns]\n"
"\t}\n"
"\tnamespace eval define {\n"
"\t\t::namespace export initialise\n"
"\t\t::namespace eval tmp {::namespace import ::oo::define::initialise}\n"
"\t\t::namespace export -clear\n"
"\t\t::rename tmp::initialise initialize\n"
"\t\t::namespace delete tmp\n"
"\t}\n"
"\tdefine Slot {\n"
"\t\tmethod Get -unexport {} {\n"
"\t\t\treturn -code error -errorcode {TCL OO ABSTRACT_SLOT} \"unimplemented\"\n"
"\t\t}\n"
"\t\tmethod Set -unexport list {\n"
"\t\t\treturn -code error -errorcode {TCL OO ABSTRACT_SLOT} \"unimplemented\"\n"
"\t\t}\n"
"\t\tmethod Resolve -unexport list {\n"
"\t\t\treturn $list\n"
"\t\t}\n"
"\t\tmethod -set -export args {\n"
"\t\t\tset my [namespace which my]\n"
"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n"
"\t\t\ttailcall my Set $args\n"
"\t\t}\n"
"\t\tmethod -append -export args {\n"
"\t\t\tset my [namespace which my]\n"
"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n"
"\t\t\tset current [uplevel 1 [list $my Get]]\n"
"\t\t\ttailcall my Set [list {*}$current {*}$args]\n"
"\t\t}\n"
"\t\tmethod -appendifnew -export args {\n"
"\t\t\tset my [namespace which my]\n"
"\t\t\tset current [uplevel 1 [list $my Get]]\n"
"\t\t\tforeach a $args {\n"
"\t\t\t\tset a [uplevel 1 [list $my Resolve $a]]\n"
"\t\t\t\tif {$a ni $current} {\n"
"\t\t\t\t\tlappend current $a\n"
"\t\t\t\t}\n"
"\t\t\t}\n"
"\t\t\ttailcall my Set $current\n"
"\t\t}\n"
"\t\tmethod -clear -export {} {tailcall my Set {}}\n"
"\t\tmethod -prepend -export args {\n"
"\t\t\tset my [namespace which my]\n"
"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n"
"\t\t\tset current [uplevel 1 [list $my Get]]\n"
"\t\t\ttailcall my Set [list {*}$args {*}$current]\n"
"\t\t}\n"
"\t\tmethod -remove -export args {\n"
"\t\t\tset my [namespace which my]\n"
"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n"
"\t\t\tset current [uplevel 1 [list $my Get]]\n"
"\t\t\ttailcall my Set [lmap val $current {\n"
"\t\t\t\tif {$val in $args} continue else {set val}\n"
"\t\t\t}]\n"
"\t\t}\n"
"\t\tforward --default-operation my -append\n"
"\tdefine Slot forward --default-operation my -append\n"
"\t\tmethod unknown -unexport {args} {\n"
"\t\t\tset def --default-operation\n"
"\t\t\tif {[llength $args] == 0} {\n"
"\t\t\t\ttailcall my $def\n"
"\t\t\t} elseif {![string match -* [lindex $args 0]]} {\n"
"\t\t\t\ttailcall my $def {*}$args\n"
"\t\t\t}\n"
"\t\t\tnext {*}$args\n"
"\t\t}\n"
"\t\tunexport destroy\n"
"\tdefine Slot unexport destroy\n"
"\t}\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\t::oo::UpdateClassDelegatesAfterClone $originObject [self]\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"
"\t\tsuperclass class\n"
"\t\tvariable object\n"
"\t\tunexport create createWithNamespace\n"
"\t\tmethod new args {\n"
"\t\t\tif {![info exists object] || ![info object isa object $object]} {\n"
"\t\t\t\tset object [next {*}$args]\n"
"\t\t\t\t::oo::objdefine $object {\n"
"\t\t\t\t\tmethod destroy {} {\n"
"\t\t\t\t\t\t::return -code error -errorcode {TCL OO SINGLETON} \\\n"
"\t\t\t\t\t\t\t\"may not destroy a singleton object\"\n"
"\t\t\t\t\t}\n"
"\t\t\t\t\tmethod <cloned> -unexport {originObject} {\n"
"\t\t\t\t\t\t::return -code error -errorcode {TCL OO SINGLETON} \\\n"
"\t\t\t\t\t\t\t\"may not clone a singleton object\"\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\t}\n"
"\t\t\t\t}\n"
"\t\t\t}\n"
"\t\t\treturn $object\n"
"\t\t}\n"
"\t\treturn $object\n"
"\t}\n"
"\tclass create abstract {\n"
"\t\tsuperclass class\n"
"\t\tunexport create createWithNamespace new\n"
"\tclass create abstract\n"
"\tdefine abstract superclass -set class\n"
"\tdefine abstract unexport create createWithNamespace new\n"
"\t}\n"
"\tnamespace eval configuresupport {\n"
"\tnamespace eval configuresupport::configurableclass {\n"
"\t\t::namespace eval configurableclass {\n"
"\t\t\t::proc properties args {::tailcall property {*}$args}\n"
"\t\t\t::namespace path ::oo::define\n"
"\t\t\t::namespace export property\n"
"\t\t}\n"
"\t\t::namespace eval configurableobject {\n"
"\t\t\t::proc properties args {::tailcall property {*}$args}\n"
"\t\t\t::namespace path ::oo::objdefine\n"
"\t\t\t::namespace export property\n"
"\t\t}\n"
"\t\t::oo::define configurable {\n"
"\t\t\tdefinitionnamespace -instance configurableobject\n"
"\t\t\tdefinitionnamespace -class 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\t}\n"
"\t}\n"
"\tclass create configurable {\n"
"\t\tsuperclass class\n"
"\t\tconstructor {{definitionScript \"\"}} {\n"
"\t\t\tnext {mixin ::oo::configuresupport::configurable}\n"
"\t\t\tnext $definitionScript\n"
"\t\t}\n"
"\t\tdefinitionnamespace -class configuresupport::configurableclass\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"
"\t}\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
	initialize {proc xyzzy {} {}}
	initialise {proc xyzzy {} {}}
    }
    return $result
} -cleanup {
    catch {
	trace remove execution oo::define::initialise enter appendToResultVar
    }
    rename ::appendToResultVar {}
    parent destroy
} -result {{initialize {proc xyzzy {} {}}} enter}
} -result {{initialise {proc xyzzy {} {}}} enter}
test ooUtil-3.5 {TIP 478: class initialisation} -body {
    oo::define oo::object {
	::list [::namespace which initialise] [::namespace which initialize] \
	     [::namespace origin initialise] [::namespace origin initialize]
    }
} -result {::oo::define::initialise ::oo::define::initialize ::oo::define::initialise ::oo::define::initialise}

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 {
    ::namespace path {}

    #
    # Commands that are made available to objects by default.
    #
    namespace eval Helpers {
	namespace path {}

	# ------------------------------------------------------------------
	#
	# callback, mymethod --
	#
	#	Create a script prefix that calls a method on the current
	#	object. Same operation, two names.
	#
	# ------------------------------------------------------------------

	proc callback {method args} {
	    list [uplevel 1 {::namespace which my}] $method {*}$args
	}

	# Make the [callback] command appear as [mymethod] too.
	namespace export callback
	namespace eval tmp {namespace import ::oo::Helpers::callback}
	namespace export -clear
	rename tmp::callback mymethod
	namespace delete tmp

	# ------------------------------------------------------------------
	#
	# classvariable --
	#
	#	Link to a variable in the class of the current object.
	#
	# ------------------------------------------------------------------

	proc classvariable {name args} {
	    # Get a reference to the class's namespace
	    set ns [info object namespace [uplevel 1 {self class}]]
	    # Double up the list of variable names
	    foreach v [list $name {*}$args] {
		if {[string match *(*) $v]} {
		    set reason "can't create a scalar variable that looks like an array element"
		    return -code error -errorcode {TCL UPVAR LOCAL_ELEMENT} \
			[format {bad variable name "%s": %s} $v $reason]
		}
		if {[string match *::* $v]} {
		    set reason "can't create a local variable with a namespace separator in it"
		    return -code error -errorcode {TCL UPVAR INVERTED} \
			[format {bad variable name "%s": %s} $v $reason]
		}
		lappend vs $v $v
	    }
	    # Lastly, link the caller's local variables to the class's variables
	    tailcall namespace upvar $ns {*}$vs
	}

	# ------------------------------------------------------------------
	#
	# link --
	#
	#	Make a command that invokes a method on the current object.
	#	The name of the command and the name of the method match by
	#	default.
	#
	# ------------------------------------------------------------------

	proc link {args} {
	    set ns [uplevel 1 {::namespace current}]
	    foreach link $args {
		if {[llength $link] == 2} {
		    lassign $link src dst
		} elseif {[llength $link] == 1} {
		    lassign $link src
		    set dst $src
		} else {
		    return -code error -errorcode {TCL OO CMDLINK_FORMAT} \
			"bad link description; must only have one or two elements"
		}
		if {![string match ::* $src]} {
		    set src [string cat $ns :: $src]
		}
		interp alias {} $src {} ${ns}::my $dst
		trace add command ${ns}::my delete [list \
		    ::oo::UnlinkLinkedCommand $src]
	    }
	    return
	}
    }

    # ----------------------------------------------------------------------
    #
    # UnlinkLinkedCommand --
    #
    #	Callback used to remove linked command when the underlying mechanism
    #	that supports it is deleted.
    #
    # ----------------------------------------------------------------------

    proc UnlinkLinkedCommand {cmd args} {
	if {[namespace which $cmd] ne {}} {
	    rename $cmd {}
	}
    }

    # ----------------------------------------------------------------------
    #
    # DelegateName --
    #
    #	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.
    #
    # ----------------------------------------------------------------------

    proc DelegateName {class} {
	string cat [info object namespace $class] {:: oo ::delegate}
    }

    # ----------------------------------------------------------------------
    #
    # MixinClassDelegates --
    #
    #	Support code called *after* [oo::define] inside the constructor of a
    #	class that patches in the appropriate class delegates.
    #
    # ----------------------------------------------------------------------

    proc MixinClassDelegates {class} {
	if {![info object isa class $class]} {
	    return
	}
	set delegate [DelegateName $class]
	if {![info object isa class $delegate]} {
	    return
	}
	foreach c [info class superclass $class] {
	    set d [DelegateName $c]
	    if {![info object isa class $d]} {
		continue
	    }
	    define $delegate ::oo::define::superclass -appendifnew $d
	}
	objdefine $class ::oo::objdefine::mixin -appendifnew $delegate
    }

    # ----------------------------------------------------------------------
    #
    # UpdateClassDelegatesAfterClone --
    #
    #	Support code that is like [MixinClassDelegates] except for when a
    #	class is cloned.
    #
    # ----------------------------------------------------------------------

    proc UpdateClassDelegatesAfterClone {originObject targetObject} {
	# Rebuild the class inheritance delegation class
	set originDelegate [DelegateName $originObject]
	set targetDelegate [DelegateName $targetObject]
	if {
	    [info object isa class $originDelegate]
	    && ![info object isa class $targetDelegate]
	} then {
	    copy $originDelegate $targetDelegate
	    objdefine $targetObject ::oo::objdefine::mixin -set \
		{*}[lmap c [info object mixin $targetObject] {
		    if {$c eq $originDelegate} {set targetDelegate} {set c}
		}]
	}
    }

    # ----------------------------------------------------------------------
    #
    # oo::define::classmethod --
    #
    #	Defines a class method. See define(n) for details.
    #
    # Note that the ::oo::define namespace is semi-public and a bit weird
    # anyway, so we don't regard the namespace path as being under control:
    # fully qualified names are used for everything.
    #
    # ----------------------------------------------------------------------

    proc define::classmethod {name args} {
	# Create the method on the class if the caller gave arguments and body
	::set argc [::llength [::info level 0]]
	::if {$argc == 3} {
	    ::return -code error -errorcode {TCL WRONGARGS} [::format \
		{wrong # args: should be "%s name ?args body?"} \
		[::lindex [::info level 0] 0]]
	}
	::set cls [::uplevel 1 self]
	::if {$argc == 4} {
	    ::oo::define [::oo::DelegateName $cls] method $name {*}$args
	}
	# Make the connection by forwarding
	::tailcall forward $name myclass $name
    }

    # ----------------------------------------------------------------------
    #
    # oo::define::initialise, oo::define::initialize --
    #
    #	Do specific initialisation for a class. See define(n) for details.
    #
    # Note that the ::oo::define namespace is semi-public and a bit weird
    # anyway, so we don't regard the namespace path as being under control:
    # fully qualified names are used for everything.
    #
    # ----------------------------------------------------------------------

    proc define::initialise {body} {
	::set clsns [::info object namespace [::uplevel 1 self]]
	::tailcall apply [::list {} $body $clsns]
    }

    # Make the [initialise] definition appear as [initialize] too
    namespace eval define {
	::namespace export initialise
	::namespace eval tmp {::namespace import ::oo::define::initialise}
	::namespace export -clear
	::rename tmp::initialise initialize
	::namespace delete tmp
    }

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

    define Slot {
	# ------------------------------------------------------------------
	#
    # ------------------------------------------------------------------
    #
	# Slot Get --
	#
	#	Basic slot getter. Retrieves the contents of the slot.
	#	Particular slots must provide concrete non-erroring
	#	implementation.
	#
	# ------------------------------------------------------------------

	method Get -unexport {} {
	    return -code error -errorcode {TCL OO ABSTRACT_SLOT} "unimplemented"
	}

	# ------------------------------------------------------------------
	#
	# Slot Set --
	#
	#	Basic slot setter. Sets the contents of the slot.  Particular
	#	slots must provide concrete non-erroring implementation.
	#
	# ------------------------------------------------------------------

	method Set -unexport list {
	    return -code error -errorcode {TCL OO ABSTRACT_SLOT} "unimplemented"
	}

	# ------------------------------------------------------------------
	#
	# Slot Resolve --
	#
	#	Helper that lets a slot convert a list of arguments of a
	#	particular type to their canonical forms. Defaults to doing
	#	nothing (suitable for simple strings).
	#
	# ------------------------------------------------------------------

	method Resolve -unexport list {
	    return $list
	}

	# ------------------------------------------------------------------
	#
	# Slot -set, -append, -clear, --default-operation --
	#
	#	Standard public slot operations. If a slot can't figure out
	#	what method to call directly, it uses --default-operation.
	#
	# ------------------------------------------------------------------

    # 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
	method -set -export args {
	    set my [namespace which my]
	    set args [lmap a $args {uplevel 1 [list $my Resolve $a]}]
	    tailcall my Set $args
	}

	method -append -export args {
	    set my [namespace which my]
	    set args [lmap a $args {uplevel 1 [list $my Resolve $a]}]
	    set current [uplevel 1 [list $my Get]]
	    tailcall my Set [list {*}$current {*}$args]
	}
	method -appendifnew -export args {
	    set my [namespace which my]
	    set current [uplevel 1 [list $my Get]]
	    foreach a $args {
		set a [uplevel 1 [list $my Resolve $a]]
		if {$a ni $current} {
		    lappend current $a
		}
	    }
	    tailcall my Set $current
	}
	method -clear -export {} {tailcall my Set {}}
	method -prepend -export args {
	    set my [namespace which my]
	    set args [lmap a $args {uplevel 1 [list $my Resolve $a]}]
	    set current [uplevel 1 [list $my Get]]
	    tailcall my Set [list {*}$args {*}$current]
	}
	method -remove -export args {
	    set my [namespace which my]
	    set args [lmap a $args {uplevel 1 [list $my Resolve $a]}]
	    set current [uplevel 1 [list $my Get]]
	    tailcall my Set [lmap val $current {
		if {$val in $args} continue else {set val}
	    }]
	}

	# Default handling
	forward --default-operation my -append
	method unknown -unexport {args} {
	    set def --default-operation
	    if {[llength $args] == 0} {
		tailcall my $def
	    } elseif {![string match -* [lindex $args 0]]} {
		tailcall my $def {*}$args
	    }
	    next {*}$args
	}

	# Hide destroy
	unexport destroy
    # 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
	::oo::UpdateClassDelegatesAfterClone $originObject [self]
	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 {
	superclass class
	variable object
	unexport create createWithNamespace
	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
    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 {
	superclass class
	unexport create createWithNamespace new
    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).
    #
    # ----------------------------------------------------------------------

    namespace eval configuresupport {
	# ------------------------------------------------------------------
	#
	# 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.
	#
	# ------------------------------------------------------------------
    # ------------------------------------------------------------------
    #
    # 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 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::configurableclass {
	# Plural alias just in case; deliberately NOT documented!
	::proc properties args {::tailcall property {*}$args}
	::namespace path ::oo::define
	::namespace export property
    }

	::namespace eval configurableobject {
	    # Plural alias just in case; deliberately NOT documented!
	    ::proc properties args {::tailcall property {*}$args}
	    ::namespace path ::oo::objdefine
	    ::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.
	#
	# ------------------------------------------------------------------
    # ------------------------------------------------------------------
    #
    # 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.
    #
    # ------------------------------------------------------------------

	::oo::define configurable {
	    definitionnamespace -instance configurableobject
	    definitionnamespace -class configurableclass
    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 {
	superclass class
    class create configurable
    define configurable superclass -set class

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

	definitionnamespace -class configuresupport::configurableclass
    define configurable definitionnamespace -class configuresupport::configurableclass
    }
}

# Local Variables:
# mode: tcl
# c-basic-offset: 4
# fill-column: 78
# End: