Tcl Source Code

2012-03-26  Donal K. Fellows  <[email protected]>

	IMPLEMENTATION OF TIP#380.

	* doc/define.n, doc/object.n, generic/tclOO.c, generic/tclOOBasic.c:
	* generic/tclOOCall.c, generic/tclOODefineCmds.c, generic/tclOOInt.h:
	* tests/oo.test: Switch definitions of lists of things in objects and
	classes to a slot-based approach, which gives a lot more flexibility
	and programmability at the script-level. Introduce new [::oo::Slot]
	class which is the implementation of these things.

	***POTENTIAL INCOMPATIBILITY***
	The unknown method handler now may be asked to deal with the case
	where no method name is provided at all. The default implementation
	generates a compatible error message, and any override that forces the
	presence of a first argument (i.e., a method name) will continue to
	function as at present as well, so this is a pretty small change.

	* generic/tclOOBasic.c (TclOO_Object_Destroy): Made it easier to do a
	tailcall inside a normally-invoked destructor; prevented leakage out
	to calling command.

2012-03-25  Jan Nijtmans  <[email protected]>

	* generic/tclInt.decls:      [Bug 3508771]: load tclreg.dll in cygwin
	* generic/tclIntPlatDecls.h: tclsh. Implement TclWinConvertError,
	* generic/tclStubInit.c:     TclWinConvertWSAError, and various more
	* unix/Makefile.in:          win32-specific internal functions for
	* unix/tcl.m4:               Cygwin, so win32 extensions using those
	* unix/configure:            can be loaded in the cygwin version of
	* win/tclWinError.c:         tclsh.

2012-03-23  Jan Nijtmans  <[email protected]>

	* generic/tclInt.decls:       Revert some cygwin-related signature
	* generic/tclIntPlatDecls.h:  changes from [835f8e1e9d] (2010-01-22).
	* win/tclWinError.c:          They were an attempt to make the cygwin
	                              port compile again, but since cygwin is
	                              based on unix this serves no purpose any
	                              more.
	* win/tclWinSerial.c:         Use EAGAIN in stead of EWOULDBLOCK,
	* win/tclWinSock.c:           because in VS10+ the value of
	                              EWOULDBLOCK is no longer the same as
	                              EAGAIN.
	* unix/Makefile.in:           Add tclWinError.c to the CYGWIN build.
	* unix/tcl.m4:
	* unix/configure:

2012-03-20  Jan Nijtmans  <[email protected]>

	* generic/tcl.decls:         [Bug 3508771]: load tclreg.dll in cygwin
	* generic/tclInt.decls:      tclsh. Implement TclWinGetPlatformId,
	* generic/tclIntPlatDecls.h: Tcl_WinUtfToTChar, Tcl_WinTCharToUtf (and
	* generic/tclPlatDecls.h:    a dummy TclWinCPUID) for Cygwin, so win32
	* generic/tclStubInit.c:     extensions using those can be loaded in
	* unix/tclUnixCompat.c:      the cygwin version of tclsh.

2012-03-19  Venkat Iyer <[email protected]>

	* library/tzdata/America/Atikokan: Update to tzdata2012b.
	* library/tzdata/America/Blanc-Sablon
	* library/tzdata/America/Dawson_Creek
	* library/tzdata/America/Edmonton

	by getaddrinfo() for all three arguments to socket() instead of
	only using ai_family. Try to keep the most meaningful error while
	iterating over the result list, because using the last error can
	be misleading.

2012-03-15  Jan Nijtmans  <[email protected]>

	* generic/tcl.h: [Bug 3288345]: Wrong Tcl_StatBuf used on Cygwin
	* unix/tclUnixFile.c
	* unix/tclUnixPort.h
	* win/cat.c:           Remove cygwin stuff no longer needed
	* win/tclWinFile.c
	* win/tclWinPort.h

2012-03-12  Jan Nijtmans  <[email protected]>

	* win/tclWinFile.c: [Bug 3388350]: mingw64 compiler warnings

2012-03-11  Donal K. Fellows  <[email protected]>

	* doc/*.n, doc/*.3: A number of small spelling and wording fixes.

2012-03-08  Donal K. Fellows  <[email protected]>

.
This arranges for each of the named methods, \fIname\fR, to be exported
(i.e. usable outside an instance through the instance object's command) by the
class being defined. Note that the methods themselves may be actually defined
by a superclass; subclass exports override superclass visibility, and may in
turn be overridden by instances.
.TP
\fBfilter\fR ?\fI\-slotOperation\fR? ?\fImethodName ...\fR?
.VS
This slot (see \fBSLOTTED DEFINITIONS\fR below)
.VE
sets or updates the list of method names that are used to guard whether
method call to instances of the class may be called and what the method's
results are. Each \fImethodName\fR names a single filtering method (which may
be exposed or not exposed); it is not an error for a non-existent method to be
named since they may be defined by subclasses.
.VS
By default, this slot works by appending.
.VE
.TP
\fBforward\fI name cmdName \fR?\fIarg ...\fR?
.
This creates or updates a forwarded method called \fIname\fR. The method is
defined be forwarded to the command called \fIcmdName\fR, with additional
arguments, \fIarg\fR etc., added before those arguments specified by the
caller of the method. The \fIcmdName\fR will always be resolved using the

be \fIargList\fR, and the body of the method will be \fIbodyScript\fR. When
the body of the method is evaluated, the current namespace of the method will
be a namespace that is unique to the current object. The method will be
exported if \fIname\fR starts with a lower-case letter, and non-exported
otherwise; this behavior can be overridden via \fBexport\fR and
\fBunexport\fR.
.TP
\fBmixin\fR ?\fI\-slotOperation\fR? ?\fIclassName ...\fR?
.VS
This slot (see \fBSLOTTED DEFINITIONS\fR below)
.VE
sets or updates the list of additional classes that are to be mixed into
all the instances of the class being defined. Each \fIclassName\fR argument
names a single class that is to be mixed in.

.VS
By default, this slot works by replacement.
.VE
.TP
\fBrenamemethod\fI fromName toName\fR
.
This renames the method called \fIfromName\fR in a class to \fItoName\fR. The
method must have previously existed in the class, and \fItoName\fR must not
previously refer to a method in that class. Does not affect the superclasses
of the class, nor does it affect the subclasses or instances of the class

supported values of \fIsubcommand\fR). It follows the same general pattern of
argument handling as the \fBoo::define\fR and \fBoo::objdefine\fR commands,
and
.QW "\fBoo::define \fIcls \fBself \fIsubcommand ...\fR"
operates identically to
.QW "\fBoo::objdefine \fIcls subcommand ...\fR" .
.TP
\fBsuperclass\fI ?\fI\-slotOperation\fR? \fR?\fIclassName ...\fR?
.VS
This slot (see \fBSLOTTED DEFINITIONS\fR below)
.VE
allows the alteration of the superclasses of the class being defined.
Each \fIclassName\fR argument names one class that is to be a superclass of
the defined class. Note that objects must not be changed from being classes to
being non-classes or vice-versa, that an empty parent class is equivalent to
\fBoo::object\fR, and that the parent classes of \fBoo::object\fR and
\fBoo::class\fR may not be modified.
.VS
By default, this slot works by replacement.
.VE
.TP
\fBunexport\fI name \fR?\fIname ...\fR?
.
This arranges for each of the named methods, \fIname\fR, to be not exported
(i.e. not usable outside the instance through the instance object's command,
but instead just through the \fBmy\fR command visible in each object's
context) by the class being defined. Note that the methods themselves may be
actually defined by a superclass; subclass unexports override superclass
visibility, and may be overridden by instance unexports.
.TP
\fBvariable\fR ?\fI\-slotOperation\fR? ?\fIname ...\fR?
.VS
This slot (see \fBSLOTTED DEFINITIONS\fR below) arranges for each of the named
variables to be automatically made
available in the methods, constructor and destructor declared by the class

being defined. Each variable name must not have any namespace
separators and must not look like an array access. All variables will be
actually present in the instance object on which the method is executed. Note
that the variable lists declared by a superclass or subclass are completely
disjoint, as are variable lists declared by instances; the list of variable
names is just for methods (and constructors and destructors) declared by this
class. By default, this slot works by appending.
.VE
.SS "CONFIGURING OBJECTS"
.PP
The following commands are supported in the \fIdefScript\fR for
\fBoo::objdefine\fR, each of which may also be used in the \fIsubcommand\fR
form:
.TP

\fBexport\fI name \fR?\fIname ...\fR?
.
This arranges for each of the named methods, \fIname\fR, to be exported
(i.e. usable outside the object through the object's command) by the object
being defined. Note that the methods themselves may be actually defined by a
class or superclass; object exports override class visibility.
.TP
\fBfilter\fR ?\fI\-slotOperation\fR? ?\fImethodName ...\fR?
.VS
This slot (see \fBSLOTTED DEFINITIONS\fR below)
.VE
sets or updates the list of method names that are used to guard whether a
method call to the object may be called and what the method's results are.
Each \fImethodName\fR names a single filtering method (which may be exposed or
not exposed); it is not an error for a non-existent method to be named. Note

that the actual list of filters also depends on the filters set upon any
classes that the object is an instance of.
.VS
By default, this slot works by appending.
.VE
.TP
\fBforward\fI name cmdName \fR?\fIarg ...\fR?
.
This creates or updates a forwarded object method called \fIname\fR. The
method is defined be forwarded to the command called \fIcmdName\fR, with
additional arguments, \fIarg\fR etc., added before those arguments specified
by the caller of the method. Forwarded methods should be deleted using the
\fBmethod\fR subcommand. The method will be exported if \fIname\fR starts with
a lower-case letter, and non-exported otherwise.
.TP
\fBmethod\fI name argList bodyScript\fR
.
This creates, updates or deletes an object method. The name of the method is
\fIname\fR, the formal arguments to the method (defined using the same format
as for the Tcl \fBproc\fR command) will be \fIargList\fR, and the body of the
method will be \fIbodyScript\fR. When the body of the method is evaluated, the
current namespace of the method will be a namespace that is unique to the
object. The method will be exported if \fIname\fR starts with a lower-case
letter, and non-exported otherwise.
.TP
\fBmixin\fR ?\fI\-slotOperation\fR? ?\fIclassName ...\fR?
.VS
This slot (see \fBSLOTTED DEFINITIONS\fR below)
.VE
sets or updates a per-object list of additional classes that are to be
mixed into the object. Each argument, \fIclassName\fR, names a single class
that is to be mixed in.
.VS
By default, this slot works by replacement.
.VE
.TP
\fBrenamemethod\fI fromName toName\fR
.
This renames the method called \fIfromName\fR in an object to \fItoName\fR.
The method must have previously existed in the object, and \fItoName\fR must
not previously refer to a method in that object. Does not affect the classes
that the object is an instance of. Does not change the export status of the
method; if it was exported before, it will be afterwards.
.TP
\fBunexport\fI name \fR?\fIname ...\fR?
.
This arranges for each of the named methods, \fIname\fR, to be not exported
(i.e. not usable outside the object through the object's command, but instead
just through the \fBmy\fR command visible in the object's context) by the
object being defined. Note that the methods themselves may be actually defined
by a class; instance unexports override class visibility.
.TP
\fBvariable\fR ?\fI\-slotOperation\fR? ?\fIname ...\fR?
.VS
This slot (see \fBSLOTTED DEFINITIONS\fR below) arranges for each of the named
variables to be automatically made available in the methods declared by the

object being defined.  Each variable name must not have any namespace
separators and must not look like an array access. All variables will be
actually present in the object on which the method is executed. Note that the
variable lists declared by the classes and mixins of which the object is an
instance are completely disjoint; the list of variable names is just for
methods declared by this object. By default, this slot works by appending.
.SH "SLOTTED DEFINITIONS"
Some of the configurable definitions of a class or object are \fIslotted
definitions\fR. This means that the configuration is implemented by a slot
object, that is an instance of the class \fBoo::Slot\fR, which manages a list
of values (class names, variable names, etc.) that comprises the contents of
the slot. The class defines three operations (as methods) that may be done on
the slot:
.VE
.TP
\fIslot\fR \fB\-append\fR ?\fImember ...\fR?
.VS
This appends the given \fImember\fR elements to the slot definition.
.VE
.TP
\fIslot\fR \fB\-clear\fR
.VS
This sets the slot definition to the empty list.
.VE
.TP
\fIslot\fR \fB\-set\fR ?\fImember ...\fR?
.VS
This replaces the slot definition with the given \fImember\fR elements.
.PP
A consequence of this is that any use of a slot's default operation where the
first member argument begins with a hyphen will be an error. One of the above
operations should be used explicitly in those circumstances.
.SS "SLOT IMPLEMENTATION"
Internally, slot objects also define a method \fB\-\-default\-operation\fR
which is forwarded to the default operation of the slot (thus, for the class
.QW \fBvariable\fR
slot, this is forwarded to
.QW "\fBmy \-append\fR" ),
and these methods which provide the implementation interface:
.VE
.TP
\fIslot\fR \fBGet\fR
.VS
Returns a list that is the current contents of the slot. This method must
always be called from a stack frame created by a call to \fBoo::define\fR or
\fBoo::objdefine\fR.
.VE
.TP
\fIslot\fR \fBSet \fIelementList\fR
.VS
Sets the contents of the slot to the list \fIelementList\fR and returns the
empty string. This method must always be called from a stack frame created by
a call to \fBoo::define\fR or \fBoo::objdefine\fR.
.PP
The implementation of these methods is slot-dependent (and responsible for
accessing the correct part of the class or object definition). Slots also have
an unknown method handler to tie all these pieces together, and they hide
their \fBdestroy\fR method so that it is not invoked inadvertently. It is
\fIrecommended\fR that any user changes to the slot mechanism be restricted to
defining new operations whose names start with a hyphen.
.VE
.SH EXAMPLES
This example demonstrates how to use both forms of the \fBoo::define\fR and
\fBoo::objdefine\fR commands (they work in the same way), as well as
illustrating four of the subcommands of them.
.PP
.CS

}
o bar                \fI\(-> prints "hello world"\fR
o foo                \fI\(-> error "unknown method foo"\fR
o Foo Bar            \fI\(-> error "unknown method Foo"\fR
\fBoo::objdefine\fR o \fBrenamemethod\fR bar lollipop
o lollipop           \fI\(-> prints "hello world"\fR
.CE
.PP
This example shows how additional classes can be mixed into an object. It also
shows how \fBmixin\fR is a slot that supports appending:
.PP
.CS
oo::object create inst
inst m1              \fI\(-> error "unknown method m1"\fR
inst m2              \fI\(-> error "unknown method m2"\fR

oo::class create A {
    \fBmethod\fR m1 {} {
        puts "red brick"
    }
}
\fBoo::objdefine\fR inst {
    \fBmixin\fR A
}
inst m1              \fI\(-> prints "red brick"\fR
inst m2              \fI\(-> error "unknown method m2"\fR

oo::class create B {
    \fBmethod\fR m2 {} {
        puts "blue brick"
    }
}
\fBoo::objdefine\fR inst {
    \fBmixin -append\fR B
}
inst m1              \fI\(-> prints "red brick"\fR
inst m2              \fI\(-> prints "blue brick"\fR
.CE
.SH "SEE ALSO"
next(n), oo::class(n), oo::object(n)
.SH KEYWORDS
class, definition, method, object, slot

.\" Local variables:
.\" mode: nroff
.\" fill-column: 78
.\" End:

.TP
\fIobj \fBeval\fR ?\fIarg ...\fR?
.
This method concatenates the arguments, \fIarg\fR, as if with \fBconcat\fR,
and then evaluates the resulting script in the namespace that is uniquely
associated with \fIobj\fR, returning the result of the evaluation.
.TP
\fIobj \fBunknown ?\fImethodName\fR? ?\fIarg ...\fR?
.
This method is called when an attempt to invoke the method \fImethodName\fR on
object \fIobj\fR fails. The arguments that the user supplied to the method are
given as \fIarg\fR arguments.
.VS
If \fImethodName\fR is absent, the object was invoked with no method name at
all (or any other arguments).
.VE
The default implementation (i.e., the one defined by the \fBoo::object\fR
class) generates a suitable error, detailing what methods the object supports
given whether the object was invoked by its public name or through the
\fBmy\fR command.
.TP
\fIobj \fBvariable \fR?\fIvarName ...\fR?
.
This method arranges for each variable called \fIvarName\fR to be linked from
the object \fIobj\fR's unique namespace into the caller's context. Thus, if it
is invoked from inside a procedure then the namespace variable in the object
is linked to the local variable in the procedure. Each \fIvarName\fR argument

    Tcl_ObjCmdProc *objProc;
    int flag;
} defineCmds[] = {
    {"constructor", TclOODefineConstructorObjCmd, 0},
    {"deletemethod", TclOODefineDeleteMethodObjCmd, 0},
    {"destructor", TclOODefineDestructorObjCmd, 0},
    {"export", TclOODefineExportObjCmd, 0},

    {"forward", TclOODefineForwardObjCmd, 0},
    {"method", TclOODefineMethodObjCmd, 0},

    {"renamemethod", TclOODefineRenameMethodObjCmd, 0},
    {"self", TclOODefineSelfObjCmd, 0},

    {"unexport", TclOODefineUnexportObjCmd, 0},

    {NULL, NULL, 0}
}, objdefCmds[] = {
    {"class", TclOODefineClassObjCmd, 1},
    {"deletemethod", TclOODefineDeleteMethodObjCmd, 1},
    {"export", TclOODefineExportObjCmd, 1},

    {"forward", TclOODefineForwardObjCmd, 1},
    {"method", TclOODefineMethodObjCmd, 1},

    {"renamemethod", TclOODefineRenameMethodObjCmd, 1},
    {"unexport", TclOODefineUnexportObjCmd, 1},

    {NULL, NULL, 0}
};

/*
 * What sort of size of things we like to allocate.
 */

static void		DeletedHelpersNamespace(ClientData clientData);
static int		FinalizeAlloc(ClientData data[],
			    Tcl_Interp *interp, int result);
static int		FinalizeNext(ClientData data[],
			    Tcl_Interp *interp, int result);
static int		FinalizeObjectCall(ClientData data[],
			    Tcl_Interp *interp, int result);
static int		InitFoundation(Tcl_Interp *interp);
static void		KillFoundation(ClientData clientData,
			    Tcl_Interp *interp);
static void		MyDeleted(ClientData clientData);
static void		ObjectNamespaceDeleted(ClientData clientData);
static void		ObjectRenamedTrace(ClientData clientData,
			    Tcl_Interp *interp, const char *oldName,
			    const char *newName, int flags);

static char initScript[] =
    "package ifneeded TclOO " TCLOO_PATCHLEVEL " {# Already present, OK?};"
    "namespace eval ::oo { variable version " TCLOO_VERSION " };"
    "namespace eval ::oo { variable patchlevel " TCLOO_PATCHLEVEL " };";
/*     "tcl_findLibrary tcloo $oo::version $oo::version" */
/*     " tcloo.tcl OO_LIBRARY oo::library;"; */

static const char *slotScript =
"::oo::define ::oo::Slot {\n"
"    method Get {} {error unimplemented}\n"
"    method Set list {error unimplemented}\n"
"    method -set args {\n"
"        uplevel 1 [list [namespace which my] Set $args]\n"
"    }\n"
"    method -append args {\n"
"        uplevel 1 [list [namespace which my] Set [list"
"                {*}[uplevel 1 [list [namespace which my] Get]] {*}$args]]\n"
"    }\n"
"    method -clear {} {uplevel 1 [list [namespace which my] Set {}]}\n"
"    forward --default-operation my -append\n"
"    method unknown {args} {\n"
"        set def --default-operation\n"
"        if {[llength $args] == 0} {\n"
"            return [uplevel 1 [list [namespace which my] $def]]\n"
"        } elseif {![string match -* [lindex $args 0]]} {\n"
"            return [uplevel 1 [list [namespace which my] $def {*}$args]]\n"
"        }\n"
"        next {*}$args\n"
"    }\n"
"    export -set -append -clear\n"
"    unexport unknown destroy\n"
"}\n"
"::oo::objdefine ::oo::define::superclass forward --default-operation my -set\n"
"::oo::objdefine ::oo::define::mixin forward --default-operation my -set\n"
"::oo::objdefine ::oo::objdefine::mixin forward --default-operation my -set\n";

MODULE_SCOPE const TclOOStubs tclOOStubs;

/*
 * Convenience macro for getting the foundation from an interpreter.
 */

#define GetFoundation(interp) \
	((Foundation *)((Interp *)(interp))->objectFoundation)

/*
 * Macros to make inspecting into the guts of an object cleaner. Note that the
 * roots oo::object and oo::class have _both_ their object and class flags
 * tagged with ROOT_OBJECT and ROOT_CLASS respectively.
 */

#define Deleted(oPtr) (((Object *)(oPtr))->command == NULL)
#define IsRootObject(ocPtr) ((ocPtr)->flags & ROOT_OBJECT)
#define IsRootClass(ocPtr) ((ocPtr)->flags & ROOT_CLASS)
#define IsRoot(ocPtr) ((ocPtr)->flags & (ROOT_OBJECT|ROOT_CLASS))

/*
 * ----------------------------------------------------------------------
 *
 * TclOOInit --
 *
 *	Called to initialise the OO system within an interpreter.

TclOOInit(
    Tcl_Interp *interp)		/* The interpreter to install into. */
{
    /*
     * Build the core of the OO system.
     */

    if (InitFoundation(interp) != TCL_OK) {
	return TCL_ERROR;
    }

    /*
     * Run our initialization script and, if that works, declare the package
     * to be fully provided.
     */

    if (Tcl_Eval(interp, initScript) != TCL_OK) {

 *	Set up the core of the OO core class system. This is a structure
 *	holding references to the magical bits that need to be known about in
 *	other places, plus the oo::object and oo::class classes.
 *
 * ----------------------------------------------------------------------
 */

static int
InitFoundation(
    Tcl_Interp *interp)
{
    static Tcl_ThreadDataKey tsdKey;
    ThreadLocalData *tsdPtr =
	    Tcl_GetThreadData(&tsdKey, sizeof(ThreadLocalData));
    Foundation *fPtr = ckalloc(sizeof(Foundation));

    fPtr->objectCls = AllocClass(interp,
	    AllocObject(interp, "::oo::object", NULL));
    fPtr->classCls = AllocClass(interp,
	    AllocObject(interp, "::oo::class", NULL));
    fPtr->objectCls->thisPtr->selfCls = fPtr->classCls;
    fPtr->objectCls->thisPtr->flags |= ROOT_OBJECT;
    fPtr->objectCls->flags |= ROOT_OBJECT;
    fPtr->objectCls->superclasses.num = 0;
    ckfree(fPtr->objectCls->superclasses.list);
    fPtr->objectCls->superclasses.list = NULL;
    fPtr->classCls->thisPtr->selfCls = fPtr->classCls;
    fPtr->classCls->thisPtr->flags |= ROOT_CLASS;
    fPtr->classCls->flags |= ROOT_CLASS;
    TclOOAddToInstances(fPtr->objectCls->thisPtr, fPtr->classCls);
    TclOOAddToInstances(fPtr->classCls->thisPtr, fPtr->classCls);
    AddRef(fPtr->objectCls->thisPtr);
    AddRef(fPtr->objectCls);

    /*
     * Basic method declarations for the core classes.

	    NULL);
    Tcl_CreateObjCommand(interp, "::oo::define", TclOODefineObjCmd, NULL,
	    NULL);
    Tcl_CreateObjCommand(interp, "::oo::objdefine", TclOOObjDefObjCmd, NULL,
	    NULL);
    Tcl_CreateObjCommand(interp, "::oo::copy", TclOOCopyObjectCmd, NULL,NULL);
    TclOOInitInfo(interp);

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

    if (TclOODefineSlots(fPtr) != TCL_OK) {
	return TCL_ERROR;
    }
    return Tcl_Eval(interp, slotScript);
}

/*
 * ----------------------------------------------------------------------
 *
 * DeletedDefineNamespace, DeletedObjdefNamespace, DeletedHelpersNamespace --
 *

    ClientData clientData,	/* The object being deleted. */
    Tcl_Interp *interp,		/* The interpreter containing the object. */
    const char *oldName,	/* What the object was (last) called. */
    const char *newName,	/* Always NULL. */
    int flags)			/* Why was the object deleted? */
{
    Object *oPtr = clientData;
    Foundation *fPtr = oPtr->fPtr;


    /*
     * If this is a rename and not a delete of the object, we just flush the
     * cache of the object name.
     */

    if (flags & TCL_TRACE_RENAME) {

     * We also do not run destructors on the core class objects when the
     * interpreter is being deleted; their incestuous nature causes problems
     * in that case when the destructor is partially deleted before the uses
     * of it have gone. [Bug 2949397]
     */

    AddRef(oPtr);
    AddRef(fPtr->classCls);
    AddRef(fPtr->objectCls);
    AddRef(fPtr->classCls->thisPtr);
    AddRef(fPtr->objectCls->thisPtr);
    oPtr->command = NULL;


    if (!(oPtr->flags & DESTRUCTOR_CALLED) && !Tcl_InterpDeleted(interp)) {

	CallContext *contextPtr =
		TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL);


	int result;
	Tcl_InterpState state;

	oPtr->flags |= DESTRUCTOR_CALLED;
	if (contextPtr != NULL) {
	    contextPtr->callPtr->flags |= DESTRUCTOR;
	    contextPtr->skip = 0;
	    state = Tcl_SaveInterpState(interp, TCL_OK);
	    result = Tcl_NRCallObjProc(interp, TclOOInvokeContext,
		    contextPtr, 0, NULL);
	    if (result != TCL_OK) {
		Tcl_BackgroundError(interp);
	    }
	    Tcl_RestoreInterpState(interp, state);
	    TclOODeleteContext(contextPtr);
	}
    }

    /*
     * OK, the destructor's been run. Time to splat the class data (if any)
     * and nuke the namespace (which triggers the final crushing of the object
     * structure itself).
     *
     * The class of objects needs some special care; if it is deleted (and
     * we're not killing the whole interpreter) we force the delete of the
     * class of classes now as well. Due to the incestuous nature of those two
     * classes, if one goes the other must too and yet the tangle can
     * sometimes not go away automatically; we force it here. [Bug 2962664]
     */

    if (!Tcl_InterpDeleted(interp) && IsRootObject(oPtr)
	    && !Deleted(fPtr->classCls->thisPtr)) {
	Tcl_DeleteCommandFromToken(interp, fPtr->classCls->thisPtr->command);



    }

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


	ReleaseClassContents(interp, oPtr);
    }

    /*
     * The namespace is only deleted if it hasn't already been deleted. [Bug
     * 2950259]
     */

    if (((Namespace *) oPtr->namespacePtr)->earlyDeleteProc != NULL) {
	Tcl_DeleteNamespace(oPtr->namespacePtr);
    }
    if (oPtr->classPtr) {
	DelRef(oPtr->classPtr);
    }
    DelRef(fPtr->classCls->thisPtr);
    DelRef(fPtr->objectCls->thisPtr);
    DelRef(fPtr->classCls);
    DelRef(fPtr->objectCls);
    DelRef(oPtr);
}

/*
 * ----------------------------------------------------------------------
 *
 * ReleaseClassContents --
 *
 *	Tear down the special class data structure, including deleting all
 *	dependent classes and objects.
 *
 * ----------------------------------------------------------------------
 */

static void
ReleaseClassContents(
    Tcl_Interp *interp,		/* The interpreter containing the class. */
    Object *oPtr)		/* The object representing the class. */
{
    FOREACH_HASH_DECLS;
    int i;
    Class *clsPtr = oPtr->classPtr, *mixinSubclassPtr, *subclassPtr;
    Object *instancePtr;
    Foundation *fPtr = oPtr->fPtr;

    /*
     * Sanity check!
     */

    if (!Deleted(oPtr)) {
	if (IsRootClass(oPtr)) {
	    Tcl_Panic("deleting class structure for non-deleted %s",
		    "::oo::class");
	} else if (IsRootObject(oPtr)) {
	    Tcl_Panic("deleting class structure for non-deleted %s",
		    "::oo::object");
	} else {
	    Tcl_Panic("deleting class structure for non-deleted %s",
		    "general object");
	}
    }

    /*
     * Lock a number of dependent objects until we've stopped putting our
     * fingers in them.
     */

    FOREACH(mixinSubclassPtr, clsPtr->mixinSubs) {
	if (mixinSubclassPtr != NULL) {
	    AddRef(mixinSubclassPtr);
	    AddRef(mixinSubclassPtr->thisPtr);
	}
    }
    FOREACH(subclassPtr, clsPtr->subclasses) {
	if (subclassPtr != NULL && !IsRoot(subclassPtr)) {
	    AddRef(subclassPtr);
	    AddRef(subclassPtr->thisPtr);
	}
    }
    if (!IsRootClass(oPtr)) {
	FOREACH(instancePtr, clsPtr->instances) {
	    if (instancePtr != NULL && !IsRoot(instancePtr)) {
		AddRef(instancePtr);
	    }
	}
    }

    /*
     * Squelch classes that this class has been mixed into.
     */

    FOREACH(mixinSubclassPtr, clsPtr->mixinSubs) {
	if (mixinSubclassPtr == NULL) {
	    continue;
	}
	if (!Deleted(mixinSubclassPtr->thisPtr)) {
	    Tcl_DeleteCommandFromToken(interp,
		    mixinSubclassPtr->thisPtr->command);
	}
	DelRef(mixinSubclassPtr->thisPtr);
	DelRef(mixinSubclassPtr);
    }
    if (clsPtr->mixinSubs.list != NULL) {
	ckfree(clsPtr->mixinSubs.list);
	clsPtr->mixinSubs.list = NULL;
	clsPtr->mixinSubs.num = 0;
    }

    /*
     * Squelch subclasses of this class.
     */

    FOREACH(subclassPtr, clsPtr->subclasses) {
	if (subclassPtr == NULL || IsRoot(subclassPtr)) {
	    continue;
	}
	if (!Deleted(subclassPtr->thisPtr)) {
	    Tcl_DeleteCommandFromToken(interp, subclassPtr->thisPtr->command);
	}
	DelRef(subclassPtr->thisPtr);
	DelRef(subclassPtr);
    }
    if (clsPtr->subclasses.list != NULL) {
	ckfree(clsPtr->subclasses.list);
	clsPtr->subclasses.list = NULL;
	clsPtr->subclasses.num = 0;
    }

    /*
     * Squelch instances of this class (includes objects we're mixed into).
     */

    if (!IsRootClass(oPtr)) {
	FOREACH(instancePtr, clsPtr->instances) {
	    if (instancePtr == NULL || IsRoot(instancePtr)) {
		continue;
	    }
	    if (!Deleted(instancePtr)) {
		Tcl_DeleteCommandFromToken(interp, instancePtr->command);
	    }
	    DelRef(instancePtr);
	}
    }
    if (clsPtr->instances.list != NULL) {
	ckfree(clsPtr->instances.list);
	clsPtr->instances.list = NULL;
	clsPtr->instances.num = 0;
    }

    /*
     * Special: We delete these after everything else.
     */








    if (IsRootClass(oPtr) && !Deleted(fPtr->objectCls->thisPtr)) {




	Tcl_DeleteCommandFromToken(interp, fPtr->objectCls->thisPtr->command);
    }






    /*




















     * Squelch method implementation chain caches.


















     */

    if (clsPtr->constructorChainPtr) {
	TclOODeleteChain(clsPtr->constructorChainPtr);
	clsPtr->constructorChainPtr = NULL;
    }
    if (clsPtr->destructorChainPtr) {
	TclOODeleteChain(clsPtr->destructorChainPtr);
	clsPtr->destructorChainPtr = NULL;
    }
    if (clsPtr->classChainCache) {

	CallChain *callPtr;

	FOREACH_HASH_VALUE(callPtr, clsPtr->classChainCache) {
	    TclOODeleteChain(callPtr);
	}
	Tcl_DeleteHashTable(clsPtr->classChainCache);
	ckfree(clsPtr->classChainCache);
	clsPtr->classChainCache = NULL;
    }

    /*
     * Squelch our filter list.
     */

    if (clsPtr->filters.num) {
	Tcl_Obj *filterObj;

	FOREACH(filterObj, clsPtr->filters) {
	    Tcl_DecrRefCount(filterObj);
	}
	ckfree(clsPtr->filters.list);
	clsPtr->filters.num = 0;
    }

    /*
     * Squelch our metadata.
     */

    if (clsPtr->metadataPtr != NULL) {

	Tcl_ObjectMetadataType *metadataTypePtr;
	ClientData value;

	FOREACH_HASH(metadataTypePtr, value, clsPtr->metadataPtr) {
	    metadataTypePtr->deleteProc(value);
	}
	Tcl_DeleteHashTable(clsPtr->metadataPtr);

				 * being deleted. */
{
    Object *oPtr = clientData;
    FOREACH_HASH_DECLS;
    Class *clsPtr = oPtr->classPtr, *mixinPtr;
    Method *mPtr;
    Tcl_Obj *filterObj, *variableObj;
    int i;

    /*
     * Instruct everyone to no longer use any allocated fields of the object.
     * Also delete the commands that refer to the object at this point (if
     * they still exist) because otherwise their references to the object
     * point into freed memory, allowing crashes.
     */


    if (oPtr->command) {
	Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->command);
    }
    if (oPtr->myCommand) {
	Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->myCommand);







    }

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

    if (!IsRootObject(oPtr)) {
	TclOORemoveFromInstances(oPtr, oPtr->selfCls);
    }

    FOREACH(mixinPtr, oPtr->mixins) {
	TclOORemoveFromInstances(oPtr, mixinPtr);
    }
    if (i) {

	Tcl_DeleteHashTable(oPtr->metadataPtr);
	ckfree(oPtr->metadataPtr);
	oPtr->metadataPtr = NULL;
    }

    if (clsPtr != NULL) {
	Class *superPtr;


	Tcl_ObjectMetadataType *metadataTypePtr;
	ClientData value;

	if (clsPtr->metadataPtr != NULL) {
	    FOREACH_HASH(metadataTypePtr, value, clsPtr->metadataPtr) {
		metadataTypePtr->deleteProc(value);
	    }
	    Tcl_DeleteHashTable(clsPtr->metadataPtr);
	    ckfree(clsPtr->metadataPtr);
	    clsPtr->metadataPtr = NULL;
	}

	FOREACH(filterObj, clsPtr->filters) {
	    Tcl_DecrRefCount(filterObj);
	}
	if (i) {
	    ckfree(clsPtr->filters.list);
	    clsPtr->filters.num = 0;
	}
	FOREACH(mixinPtr, clsPtr->mixins) {
	    if (!Deleted(mixinPtr->thisPtr)) {
		TclOORemoveFromMixinSubs(clsPtr, mixinPtr);
	    }
	}
	if (i) {
	    ckfree(clsPtr->mixins.list);
	    clsPtr->mixins.num = 0;
	}
	FOREACH(superPtr, clsPtr->superclasses) {
	    if (!Deleted(superPtr->thisPtr)) {
		TclOORemoveFromSubclasses(clsPtr, superPtr);
	    }
	}
	if (i) {
	    ckfree(clsPtr->superclasses.list);
	    clsPtr->superclasses.num = 0;
	}

    }

    /*
     * Delete the object structure itself.
     */

    DelRef(oPtr);






}

/*
 * ----------------------------------------------------------------------
 *
 * TclOORemoveFromInstances --
 *

	if (oPtr == instPtr) {
	    goto removeInstance;
	}
    }
    return;

  removeInstance:
    if (Deleted(clsPtr->thisPtr)) {
	clsPtr->instances.list[i] = NULL;
    } else {
	clsPtr->instances.num--;
	if (i < clsPtr->instances.num) {
	    clsPtr->instances.list[i] =
		    clsPtr->instances.list[clsPtr->instances.num];
	}
	clsPtr->instances.list[clsPtr->instances.num] = NULL;
    }
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOOAddToInstances --
 *
 *	Utility function to add an object to the list of instances within a
 *	class.
 *
 * ----------------------------------------------------------------------
 */

void
TclOOAddToInstances(
    Object *oPtr,		/* The instance to add. */
    Class *clsPtr)		/* The class to add the instance to. It is
				 * assumed that the class is not already
				 * present as an instance in the class. */
{
    if (Deleted(clsPtr->thisPtr)) {
	return;
    }
    if (clsPtr->instances.num >= clsPtr->instances.size) {
	clsPtr->instances.size += ALLOC_CHUNK;
	if (clsPtr->instances.size == ALLOC_CHUNK) {
	    clsPtr->instances.list = ckalloc(sizeof(Object *) * ALLOC_CHUNK);
	} else {
	    clsPtr->instances.list = ckrealloc(clsPtr->instances.list,
		    sizeof(Object *) * clsPtr->instances.size);

	if (subPtr == subclsPtr) {
	    goto removeSubclass;
	}
    }
    return;

  removeSubclass:
    if (Deleted(superPtr->thisPtr)) {
	superPtr->subclasses.list[i] = NULL;
    } else {
	superPtr->subclasses.num--;
	if (i < superPtr->subclasses.num) {
	    superPtr->subclasses.list[i] =
		    superPtr->subclasses.list[superPtr->subclasses.num];
	}
	superPtr->subclasses.list[superPtr->subclasses.num] = NULL;
    }
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOOAddToSubclasses --
 *
 *	Utility function to add a class to the list of subclasses within
 *	another class.
 *
 * ----------------------------------------------------------------------
 */

void
TclOOAddToSubclasses(
    Class *subPtr,		/* The subclass to add. */
    Class *superPtr)		/* The superclass to add the subclass to. It
				 * is assumed that the class is not already
				 * present as a subclass in the superclass. */
{
    if (Deleted(superPtr->thisPtr)) {
	return;
    }
    if (superPtr->subclasses.num >= superPtr->subclasses.size) {
	superPtr->subclasses.size += ALLOC_CHUNK;
	if (superPtr->subclasses.size == ALLOC_CHUNK) {
	    superPtr->subclasses.list = ckalloc(sizeof(Class*) * ALLOC_CHUNK);
	} else {
	    superPtr->subclasses.list = ckrealloc(superPtr->subclasses.list,
		    sizeof(Class *) * superPtr->subclasses.size);

	if (subPtr == subclsPtr) {
	    goto removeSubclass;
	}
    }
    return;

  removeSubclass:
    if (Deleted(superPtr->thisPtr)) {
	superPtr->mixinSubs.list[i] = NULL;
    } else {
	superPtr->mixinSubs.num--;
	if (i < superPtr->mixinSubs.num) {
	    superPtr->mixinSubs.list[i] =
		    superPtr->mixinSubs.list[superPtr->mixinSubs.num];
	}
	superPtr->mixinSubs.list[superPtr->mixinSubs.num] = NULL;
    }
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOOAddToMixinSubs --
 *
 *	Utility function to add a class to the list of mixinSubs within
 *	another class.
 *
 * ----------------------------------------------------------------------
 */

void
TclOOAddToMixinSubs(
    Class *subPtr,		/* The subclass to add. */
    Class *superPtr)		/* The superclass to add the subclass to. It
				 * is assumed that the class is not already
				 * present as a subclass in the superclass. */
{
    if (Deleted(superPtr->thisPtr)) {
	return;
    }
    if (superPtr->mixinSubs.num >= superPtr->mixinSubs.size) {
	superPtr->mixinSubs.size += ALLOC_CHUNK;
	if (superPtr->mixinSubs.size == ALLOC_CHUNK) {
	    superPtr->mixinSubs.list = ckalloc(sizeof(Class *) * ALLOC_CHUNK);
	} else {
	    superPtr->mixinSubs.list = ckrealloc(superPtr->mixinSubs.list,
		    sizeof(Class *) * superPtr->mixinSubs.size);

	    /*
	     * It's an error if the object was whacked in the constructor.
	     * Force this if it isn't already an error (don't want to lose
	     * errors by accident...) [Bug 2903011]
	     */

	    if (result != TCL_ERROR && Deleted(oPtr)) {
		Tcl_SetResult(interp, "object deleted in constructor",
			TCL_STATIC);
		Tcl_SetErrorCode(interp, "TCL", "OO", "STILLBORN", NULL);
		result = TCL_ERROR;
	    }
	    TclOODeleteContext(contextPtr);
	    if (result != TCL_OK) {
		Tcl_DiscardInterpState(state);

		/*
		 * Take care to not delete a deleted object; that would be
		 * bad. [Bug 2903011]
		 */

		if (!Deleted(oPtr)) {
		    Tcl_DeleteCommandFromToken(interp, oPtr->command);
		}
		return NULL;
	    }
	    Tcl_RestoreInterpState(interp, state);
	}
    }

    contextPtr->callPtr->flags |= CONSTRUCTOR;
    contextPtr->skip = skip;

    /*
     * Fire off the constructors non-recursively.
     */

    AddRef(oPtr);
    TclNRAddCallback(interp, FinalizeAlloc, contextPtr, oPtr, state,
	    objectPtr);
    TclPushTailcallPoint(interp);
    return TclOOInvokeContext(contextPtr, interp, objc, objv);
}

static int
FinalizeAlloc(
    ClientData data[],
    Tcl_Interp *interp,
    int result)
{
    CallContext *contextPtr = data[0];
    Object *oPtr = data[1];
    Tcl_InterpState state = data[2];
    Tcl_Object *objectPtr = data[3];
    //int flags = oPtr->flags;

    /*
     * It's an error if the object was whacked in the constructor. Force this
     * if it isn't already an error (don't want to lose errors by accident...)
     * [Bug 2903011]
     */

    if (result != TCL_ERROR && Deleted(oPtr)) {
	Tcl_SetResult(interp, "object deleted in constructor", TCL_STATIC);
	Tcl_SetErrorCode(interp, "TCL", "OO", "STILLBORN", NULL);
	result = TCL_ERROR;
    }
    TclOODeleteContext(contextPtr);
    if (result != TCL_OK) {
	Tcl_DiscardInterpState(state);

	/*
	 * Take care to not delete a deleted object; that would be bad. [Bug
	 * 2903011]
	 */

	if (!Deleted(oPtr)) {
	    Tcl_DeleteCommandFromToken(interp, oPtr->command);
	}
	DelRef(oPtr);
	return TCL_ERROR;
    }
    Tcl_RestoreInterpState(interp, state);
    *objectPtr = (Tcl_Object) oPtr;
    DelRef(oPtr);
    return TCL_OK;
}

/*
 * ----------------------------------------------------------------------
 *
 * Tcl_CopyObjectInstance --

    if (targetName == NULL && oPtr->classPtr != NULL) {
	Tcl_AppendResult(interp, "must supply a name when copying a class",
		NULL);
	Tcl_SetErrorCode(interp, "TCL", "OO", "NO_COPY_TARGET", NULL);
	return NULL;
    }
    if (IsRootClass(oPtr)) {
	Tcl_AppendResult(interp, "may not clone the class of classes", NULL);
	Tcl_SetErrorCode(interp, "TCL", "OO", "CLONING_CLASS", NULL);
	return NULL;
    }

    /*
     * Build the instance. Note that this does not run any constructors.

     * Copy the object's flags to the new object, clearing those that must be
     * kept object-local. The duplicate is never deleted at this point, nor is
     * it the root of the object system or in the midst of processing a filter
     * call.
     */

    o2Ptr->flags = oPtr->flags & ~(
	    OBJECT_DELETED | ROOT_OBJECT | ROOT_CLASS | FILTER_HANDLING);

    /*
     * Copy the object's metadata.
     */

    if (oPtr->metadataPtr != NULL) {
	Tcl_ObjectMetadataType *metadataTypePtr;

				 * filters and the object's methods (which is
				 * the normal case). */
{
    CallContext *contextPtr;
    Tcl_Obj *methodNamePtr;
    int result;

    /*
     * If we've no method name, throw this directly into the unknown
     * processing.
     */

    if (objc < 2) {
	flags |= FORCE_UNKNOWN;
	methodNamePtr = NULL;

	goto noMapping;
    }

    /*
     * Give plugged in code a chance to remap the method name.
     */

    methodNamePtr = objv[1];

    return (Tcl_Class) ((Object *)object)->classPtr;
}

int
Tcl_ObjectDeleted(
    Tcl_Object object)
{
    return Deleted(object) ? 1 : 0;
}

Tcl_Object
Tcl_GetClassAsObject(
    Tcl_Class clazz)
{
    return (Tcl_Object) ((Class *)clazz)->thisPtr;

	oPtr->flags |= DESTRUCTOR_CALLED;
	contextPtr = TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL);
	if (contextPtr != NULL) {
	    contextPtr->callPtr->flags |= DESTRUCTOR;
	    contextPtr->skip = 0;
	    TclNRAddCallback(interp, AfterNRDestructor, contextPtr,
		    NULL, NULL, NULL);
	    TclPushTailcallPoint(interp);
	    return TclOOInvokeContext(contextPtr, interp, 0, NULL);
	}
    }
    if (oPtr->command) {
	Tcl_DeleteCommandFromToken(interp, oPtr->command);
    }
    return TCL_OK;

    Tcl_Obj *const *objv)	/* The actual arguments. */
{
    CallContext *contextPtr = (CallContext *) context;
    Object *oPtr = contextPtr->oPtr;
    const char **methodNames;
    int numMethodNames, i, skip = Tcl_ObjectContextSkippedArgs(context);

    /*
     * If no method name, generate an error asking for a method name. (Only by
     * overriding *this* method can an object handle the absence of a method
     * name without an error).
     */

    if (objc < skip+1) {
	Tcl_WrongNumArgs(interp, skip, objv, "method ?arg ...?");
	return TCL_ERROR;
    }

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

/*
 * Extra flags used for call chain management.
 */

#define DEFINITE_PROTECTED 0x100000
#define DEFINITE_PUBLIC    0x200000
#define KNOWN_STATE	   (DEFINITE_PROTECTED | DEFINITE_PUBLIC)
#define SPECIAL		   (CONSTRUCTOR | DESTRUCTOR | FORCE_UNKNOWN)

/*
 * Function declarations for things defined in this file.
 */

static void		AddClassFiltersToCallContext(Object *const oPtr,
			    Class *clsPtr, struct ChainBuilder *const cbPtr,

    callPtr = ckalloc(sizeof(CallChain));
    InitCallChain(callPtr, oPtr, flags);

    cb.callChainPtr = callPtr;
    cb.filterLength = 0;
    cb.oPtr = oPtr;

    /*
     * If we're working with a forced use of unknown, do that now.
     */

    if (flags & FORCE_UNKNOWN) {
	AddSimpleChainToCallContext(oPtr, oPtr->fPtr->unknownMethodNameObj,
		&cb, NULL, 0, NULL);
	callPtr->flags |= OO_UNKNOWN_METHOD;
	callPtr->epoch = -1;
	if (count == callPtr->numChain) {
	    TclOODeleteChain(callPtr);
	    return NULL;
	}
	goto returnContext;
    }

    /*
     * Add all defined filters (if any, and if we're going to be processing
     * them; they're not processed for constructors, destructors or when we're
     * in the middle of processing a filter).
     */

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

/*
 * Some things that make it easier to declare a slot.
 */

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

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

/*
 * Forward declarations.
 */

static inline void	BumpGlobalEpoch(Tcl_Interp *interp, Class *classPtr);
static Tcl_Command	FindCommand(Tcl_Interp *interp, Tcl_Obj *stringObj,
			    Tcl_Namespace *const namespacePtr);
static inline Class *	GetClassInOuterContext(Tcl_Interp *interp,
			    Tcl_Obj *className, const char *errMsg);
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		ClassFilterGet(ClientData clientData,
			    Tcl_Interp *interp, Tcl_ObjectContext context,
			    int objc, Tcl_Obj *const *objv);
static int		ClassFilterSet(ClientData clientData,
			    Tcl_Interp *interp, Tcl_ObjectContext context,
			    int objc, Tcl_Obj *const *objv);
static int		ClassMixinGet(ClientData clientData,
			    Tcl_Interp *interp, Tcl_ObjectContext context,
			    int objc, Tcl_Obj *const *objv);
static int		ClassMixinSet(ClientData clientData,
			    Tcl_Interp *interp, Tcl_ObjectContext context,
			    int objc, Tcl_Obj *const *objv);
static int		ClassSuperGet(ClientData clientData,
			    Tcl_Interp *interp, Tcl_ObjectContext context,
			    int objc, Tcl_Obj *const *objv);
static int		ClassSuperSet(ClientData clientData,
			    Tcl_Interp *interp, Tcl_ObjectContext context,
			    int objc, Tcl_Obj *const *objv);
static int		ClassVarsGet(ClientData clientData,
			    Tcl_Interp *interp, Tcl_ObjectContext context,
			    int objc, Tcl_Obj *const *objv);
static int		ClassVarsSet(ClientData clientData,
			    Tcl_Interp *interp, Tcl_ObjectContext context,
			    int objc, Tcl_Obj *const *objv);
static int		ObjFilterGet(ClientData clientData,
			    Tcl_Interp *interp, Tcl_ObjectContext context,
			    int objc, Tcl_Obj *const *objv);
static int		ObjFilterSet(ClientData clientData,
			    Tcl_Interp *interp, Tcl_ObjectContext context,
			    int objc, Tcl_Obj *const *objv);
static int		ObjMixinGet(ClientData clientData,
			    Tcl_Interp *interp, Tcl_ObjectContext context,
			    int objc, Tcl_Obj *const *objv);
static int		ObjMixinSet(ClientData clientData,
			    Tcl_Interp *interp, Tcl_ObjectContext context,
			    int objc, Tcl_Obj *const *objv);
static int		ObjVarsGet(ClientData clientData,
			    Tcl_Interp *interp, Tcl_ObjectContext context,
			    int objc, Tcl_Obj *const *objv);
static int		ObjVarsSet(ClientData clientData,
			    Tcl_Interp *interp, Tcl_ObjectContext context,
			    int objc, Tcl_Obj *const *objv);

/*
 * Now define the slots used in declarations.
 */

static const struct DeclaredSlot slots[] = {
    SLOT("define::filter",      ClassFilterGet, ClassFilterSet),
    SLOT("define::mixin",       ClassMixinGet,  ClassMixinSet),
    SLOT("define::superclass",  ClassSuperGet,  ClassSuperSet),
    SLOT("define::variable",    ClassVarsGet,   ClassVarsSet),
    SLOT("objdefine::filter",   ObjFilterGet,   ObjFilterSet),
    SLOT("objdefine::mixin",    ObjMixinGet,    ObjMixinSet),
    SLOT("objdefine::variable", ObjVarsGet,     ObjVarsSet),
    {NULL}
};

/*
 * ----------------------------------------------------------------------
 *
 * BumpGlobalEpoch --
 *	Utility that ensures that call chains that are invalid will get thrown
 *	away at an appropriate time. Note that exactly which epoch gets

    }
    return TCL_OK;
}

/*
 * ----------------------------------------------------------------------
 *





































 * TclOODefineForwardObjCmd --
 *	Implementation of the "forward" subcommand of the "oo::define" and
 *	"oo::objdefine" commands.
 *
 * ----------------------------------------------------------------------
 */

    }
    return TCL_OK;
}

/*
 * ----------------------------------------------------------------------
 *










































































































 * TclOODefineUnexportObjCmd --
 *	Implementation of the "unexport" subcommand of the "oo::define" and
 *	"oo::objdefine" commands.
 *
 * ----------------------------------------------------------------------
 */

    }
    return TCL_OK;
}

/*
 * ----------------------------------------------------------------------
 *
 * Tcl_ClassSetConstructor, Tcl_ClassSetDestructor --
 *	How to install a constructor or destructor into a class; API to call
 *	from C.
 *
 * ----------------------------------------------------------------------
 */























































































void
Tcl_ClassSetConstructor(
    Tcl_Interp *interp,
    Tcl_Class clazz,
    Tcl_Method method)
{
    Class *clsPtr = (Class *) clazz;

	if (clsPtr->destructorChainPtr) {
	    TclOODeleteChain(clsPtr->destructorChainPtr);
	    clsPtr->destructorChainPtr = NULL;
	}
	BumpGlobalEpoch(interp, clsPtr);
    }
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOODefineSlots --
 *	Create the "::oo::Slot" class and its standard instances. Class
 *	definition is empty at the stage (added by scripting).
 *
 * ----------------------------------------------------------------------
 */

int
TclOODefineSlots(
    Foundation *fPtr)
{
    const struct DeclaredSlot *slotInfoPtr;
    Tcl_Obj *getName = Tcl_NewStringObj("Get", -1);
    Tcl_Obj *setName = Tcl_NewStringObj("Set", -1);
    Class *slotCls;

    slotCls = ((Object *) Tcl_NewObjectInstance(fPtr->interp, (Tcl_Class)
	    fPtr->classCls, "::oo::Slot", NULL, -1, NULL, 0))->classPtr;
    if (slotCls == NULL) {
	return TCL_ERROR;
    }
    Tcl_IncrRefCount(getName);
    Tcl_IncrRefCount(setName);
    for (slotInfoPtr = slots ; slotInfoPtr->name ; slotInfoPtr++) {
	Tcl_Object slotObject = Tcl_NewObjectInstance(fPtr->interp,
		(Tcl_Class) slotCls, slotInfoPtr->name, NULL,-1,NULL,0);

	if (slotObject == NULL) {
	    continue;
	}
	Tcl_NewInstanceMethod(fPtr->interp, slotObject, getName, 0,
		&slotInfoPtr->getterType, NULL);
	Tcl_NewInstanceMethod(fPtr->interp, slotObject, setName, 0,
		&slotInfoPtr->setterType, NULL);
    }
    Tcl_DecrRefCount(getName);
    Tcl_DecrRefCount(setName);
    return TCL_OK;
}

/*
 * ----------------------------------------------------------------------
 *
 * ClassFilterGet, ClassFilterSet --
 *	Implementation of the "filter" slot accessors of the "oo::define"
 *	command.
 *
 * ----------------------------------------------------------------------
 */

static int
ClassFilterGet(
    ClientData clientData,
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    Tcl_Obj *resultObj, *filterObj;
    int i;

    if (Tcl_ObjectContextSkippedArgs(context) != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		NULL);
	return TCL_ERROR;
    }
    if (oPtr == NULL) {
	return TCL_ERROR;
    } else if (!oPtr->classPtr) {
	Tcl_AppendResult(interp, "attempt to misuse API", NULL);
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	return TCL_ERROR;
    }

    resultObj = Tcl_NewObj();
    FOREACH(filterObj, oPtr->classPtr->filters) {
	Tcl_ListObjAppendElement(NULL, resultObj, filterObj);
    }
    Tcl_SetObjResult(interp, resultObj);
    return TCL_OK;
}

static int
ClassFilterSet(
    ClientData clientData,
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    int filterc;
    Tcl_Obj **filterv;

    if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"filterList");
	return TCL_ERROR;
    }
    objv += Tcl_ObjectContextSkippedArgs(context);

    if (oPtr == NULL) {
	return TCL_ERROR;
    } else if (!oPtr->classPtr) {
	Tcl_AppendResult(interp, "attempt to misuse API", NULL);
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	return TCL_ERROR;
    } else if (Tcl_ListObjGetElements(interp, objv[0], &filterc,
	    &filterv) != TCL_OK) {
	return TCL_ERROR;
    }

    TclOOClassSetFilters(interp, oPtr->classPtr, filterc, filterv);
    return TCL_OK;
}

/*
 * ----------------------------------------------------------------------
 *
 * ClassMixinGet, ClassMixinSet --
 *	Implementation of the "mixin" slot accessors of the "oo::define"
 *	command.
 *
 * ----------------------------------------------------------------------
 */

static int
ClassMixinGet(
    ClientData clientData,
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    Tcl_Obj *resultObj;
    Class *mixinPtr;
    int i;

    if (Tcl_ObjectContextSkippedArgs(context) != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		NULL);
	return TCL_ERROR;
    }
    if (oPtr == NULL) {
	return TCL_ERROR;
    } else if (!oPtr->classPtr) {
	Tcl_AppendResult(interp, "attempt to misuse API", NULL);
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	return TCL_ERROR;
    }

    resultObj = Tcl_NewObj();
    FOREACH(mixinPtr, oPtr->classPtr->mixins) {
	Tcl_ListObjAppendElement(NULL, resultObj,
		TclOOObjectName(interp, mixinPtr->thisPtr));
    }
    Tcl_SetObjResult(interp, resultObj);
    return TCL_OK;

}

static int
ClassMixinSet(
    ClientData clientData,
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    int mixinc, i;
    Tcl_Obj **mixinv;
    Class **mixins;

    if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"mixinList");
	return TCL_ERROR;
    }
    objv += Tcl_ObjectContextSkippedArgs(context);

    if (oPtr == NULL) {
	return TCL_ERROR;
    } else if (!oPtr->classPtr) {
	Tcl_AppendResult(interp, "attempt to misuse API", NULL);
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	return TCL_ERROR;
    } else if (Tcl_ListObjGetElements(interp, objv[0], &mixinc,
	    &mixinv) != TCL_OK) {
	return TCL_ERROR;
    }

    mixins = TclStackAlloc(interp, sizeof(Class *) * mixinc);

    for (i=0 ; i<mixinc ; i++) {
	mixins[i] = GetClassInOuterContext(interp, mixinv[i],
		"may only mix in classes");
	if (mixins[i] == NULL) {
	    goto freeAndError;
	}
	if (TclOOIsReachable(oPtr->classPtr, mixins[i])) {
	    Tcl_AppendResult(interp, "may not mix a class into itself", NULL);
	    Tcl_SetErrorCode(interp, "TCL", "OO", "SELF_MIXIN", NULL);
	    goto freeAndError;
	}
    }

    TclOOClassSetMixins(interp, oPtr->classPtr, mixinc, mixins);
    TclStackFree(interp, mixins);
    return TCL_OK;

  freeAndError:
    TclStackFree(interp, mixins);
    return TCL_ERROR;
}

/*
 * ----------------------------------------------------------------------
 *
 * ClassSuperGet, ClassSuperSet --
 *	Implementation of the "superclass" slot accessors of the "oo::define"
 *	command.
 *
 * ----------------------------------------------------------------------
 */

static int
ClassSuperGet(
    ClientData clientData,
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    Tcl_Obj *resultObj;
    Class *superPtr;
    int i;

    if (Tcl_ObjectContextSkippedArgs(context) != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		NULL);
	return TCL_ERROR;
    }
    if (oPtr == NULL) {
	return TCL_ERROR;
    } else if (!oPtr->classPtr) {
	Tcl_AppendResult(interp, "attempt to misuse API", NULL);
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	return TCL_ERROR;
    }

    resultObj = Tcl_NewObj();
    FOREACH(superPtr, oPtr->classPtr->superclasses) {
	Tcl_ListObjAppendElement(NULL, resultObj,
		TclOOObjectName(interp, superPtr->thisPtr));
    }
    Tcl_SetObjResult(interp, resultObj);
    return TCL_OK;
}

static int
ClassSuperSet(
    ClientData clientData,
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    int superc, i, j;
    Tcl_Obj **superv;
    Class **superclasses, *superPtr;

    if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"superclassList");
	return TCL_ERROR;
    }
    objv += Tcl_ObjectContextSkippedArgs(context);

    if (oPtr == NULL) {
	return TCL_ERROR;
    } else if (!oPtr->classPtr) {
	Tcl_AppendResult(interp, "attempt to misuse API", NULL);
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	return TCL_ERROR;
    } else if (oPtr == oPtr->fPtr->objectCls->thisPtr) {
	Tcl_AppendResult(interp,
		"may not modify the superclass of the root object", NULL);
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	return TCL_ERROR;
    } else if (Tcl_ListObjGetElements(interp, objv[0], &superc,
	    &superv) != TCL_OK) {
	return TCL_ERROR;
    }

    /*
     * Allocate some working space.
     */

    superclasses = (Class **) ckalloc(sizeof(Class *) * superc);

    /*
     * Parse the arguments to get the class to use as superclasses.
     */

    for (i=0 ; i<superc ; i++) {
	superclasses[i] = GetClassInOuterContext(interp, superv[i],
		"only a class can be a superclass");
	if (superclasses[i] == NULL) {
	    goto failedAfterAlloc;
	}
	for (j=0 ; j<i ; j++) {
	    if (superclasses[j] == superclasses[i]) {
		Tcl_AppendResult(interp,
			"class should only be a direct superclass once",NULL);
		Tcl_SetErrorCode(interp, "TCL", "OO", "REPETITIOUS", NULL);
		goto failedAfterAlloc;
	    }
	}
	if (TclOOIsReachable(oPtr->classPtr, superclasses[i])) {
	    Tcl_AppendResult(interp,
		    "attempt to form circular dependency graph", NULL);
	    Tcl_SetErrorCode(interp, "TCL", "OO", "CIRCULARITY", NULL);
	failedAfterAlloc:
	    ckfree((char *) superclasses);
	    return TCL_ERROR;
	}
    }

    /*
     * Install the list of superclasses into the class. Note that this also
     * involves splicing the class out of the superclasses' subclass list that
     * it used to be a member of and splicing it into the new superclasses'
     * subclass list.
     */

    if (oPtr->classPtr->superclasses.num != 0) {
	FOREACH(superPtr, oPtr->classPtr->superclasses) {
	    TclOORemoveFromSubclasses(oPtr->classPtr, superPtr);
	}
	ckfree((char *) oPtr->classPtr->superclasses.list);
    }
    oPtr->classPtr->superclasses.list = superclasses;
    oPtr->classPtr->superclasses.num = superc;
    FOREACH(superPtr, oPtr->classPtr->superclasses) {
	TclOOAddToSubclasses(oPtr->classPtr, superPtr);
    }
    BumpGlobalEpoch(interp, oPtr->classPtr);

    return TCL_OK;
}

/*
 * ----------------------------------------------------------------------
 *
 * ClassVarsGet, ClassVarsSet --
 *	Implementation of the "variable" slot accessors of the "oo::define"
 *	command.
 *
 * ----------------------------------------------------------------------
 */

static int
ClassVarsGet(
    ClientData clientData,
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    Tcl_Obj *resultObj, *variableObj;
    int i;

    if (Tcl_ObjectContextSkippedArgs(context) != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		NULL);
	return TCL_ERROR;
    }
    if (oPtr == NULL) {
	return TCL_ERROR;
    } else if (!oPtr->classPtr) {
	Tcl_AppendResult(interp, "attempt to misuse API", NULL);
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	return TCL_ERROR;
    }

    resultObj = Tcl_NewObj();
    FOREACH(variableObj, oPtr->classPtr->variables) {
	Tcl_ListObjAppendElement(NULL, resultObj, variableObj);
    }
    Tcl_SetObjResult(interp, resultObj);
    return TCL_OK;
}

static int
ClassVarsSet(
    ClientData clientData,
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    int varc;
    Tcl_Obj **varv, *variableObj;
    int i;

    if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"filterList");
	return TCL_ERROR;
    }
    objv += Tcl_ObjectContextSkippedArgs(context);

    if (oPtr == NULL) {
	return TCL_ERROR;
    } else if (!oPtr->classPtr) {
	Tcl_AppendResult(interp, "attempt to misuse API", NULL);
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	return TCL_ERROR;
    } else if (Tcl_ListObjGetElements(interp, objv[0], &varc,
	    &varv) != TCL_OK) {
	return TCL_ERROR;
    }

    for (i=0 ; i<varc ; i++) {
	const char *varName = Tcl_GetString(varv[i]);

	if (strstr(varName, "::") != NULL) {
	    Tcl_AppendResult(interp, "invalid declared variable name \"",
		    varName, "\": must not contain namespace separators",
		    NULL);
	    Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", NULL);
	    return TCL_ERROR;
	}
	if (Tcl_StringMatch(varName, "*(*)")) {
	    Tcl_AppendResult(interp, "invalid declared variable name \"",
		    varName, "\": must not refer to an array element", NULL);
	    Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", NULL);
	    return TCL_ERROR;
	}
    }

    for (i=0 ; i<varc ; i++) {
	Tcl_IncrRefCount(varv[i]);
    }
    FOREACH(variableObj, oPtr->classPtr->variables) {
	Tcl_DecrRefCount(variableObj);
    }
    if (i != varc) {
	if (varc == 0) {
	    ckfree((char *) oPtr->classPtr->variables.list);
	} else if (i) {
	    oPtr->classPtr->variables.list = (Tcl_Obj **)
		    ckrealloc((char *) oPtr->classPtr->variables.list,
		    sizeof(Tcl_Obj *) * varc);
	} else {
	    oPtr->classPtr->variables.list = (Tcl_Obj **)
		    ckalloc(sizeof(Tcl_Obj *) * varc);
	}
    }
    if (varc > 0) {
	memcpy(oPtr->classPtr->variables.list, varv,
		sizeof(Tcl_Obj *) * varc);
    }
    oPtr->classPtr->variables.num = varc;
    return TCL_OK;
}

/*
 * ----------------------------------------------------------------------
 *
 * ObjectFilterGet, ObjectFilterSet --
 *	Implementation of the "filter" slot accessors of the "oo::objdefine"
 *	command.
 *
 * ----------------------------------------------------------------------
 */

static int
ObjFilterGet(
    ClientData clientData,
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    Tcl_Obj *resultObj, *filterObj;
    int i;

    if (Tcl_ObjectContextSkippedArgs(context) != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		NULL);
	return TCL_ERROR;
    } else if (oPtr == NULL) {
	return TCL_ERROR;
    }

    resultObj = Tcl_NewObj();
    FOREACH(filterObj, oPtr->filters) {
	Tcl_ListObjAppendElement(NULL, resultObj, filterObj);
    }
    Tcl_SetObjResult(interp, resultObj);
    return TCL_OK;
}

static int
ObjFilterSet(
    ClientData clientData,
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    int filterc;
    Tcl_Obj **filterv;

    if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"filterList");
	return TCL_ERROR;
    } else if (oPtr == NULL) {
	return TCL_ERROR;
    }
    objv += Tcl_ObjectContextSkippedArgs(context);
    if (Tcl_ListObjGetElements(interp, objv[0], &filterc,
	    &filterv) != TCL_OK) {
	return TCL_ERROR;
    }

    TclOOObjectSetFilters(oPtr, filterc, filterv);
    return TCL_OK;
}

/*
 * ----------------------------------------------------------------------
 *
 * ObjectMixinGet, ObjectMixinSet --
 *	Implementation of the "mixin" slot accessors of the "oo::objdefine"
 *	command.
 *
 * ----------------------------------------------------------------------
 */

static int
ObjMixinGet(
    ClientData clientData,
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    Tcl_Obj *resultObj;
    Class *mixinPtr;
    int i;

    if (Tcl_ObjectContextSkippedArgs(context) != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		NULL);
	return TCL_ERROR;
    } else if (oPtr == NULL) {
	return TCL_ERROR;
    }

    resultObj = Tcl_NewObj();
    FOREACH(mixinPtr, oPtr->mixins) {
	Tcl_ListObjAppendElement(NULL, resultObj,
		TclOOObjectName(interp, mixinPtr->thisPtr));
    }
    Tcl_SetObjResult(interp, resultObj);
    return TCL_OK;
}

static int
ObjMixinSet(
    ClientData clientData,
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    int mixinc;
    Tcl_Obj **mixinv;
    Class **mixins;
    int i;

    if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"mixinList");
	return TCL_ERROR;
    } else if (oPtr == NULL) {
	return TCL_ERROR;
    }
    objv += Tcl_ObjectContextSkippedArgs(context);
    if (Tcl_ListObjGetElements(interp, objv[0], &mixinc,
	    &mixinv) != TCL_OK) {
	return TCL_ERROR;
    }

    mixins = TclStackAlloc(interp, sizeof(Class *) * mixinc);

    for (i=0 ; i<mixinc ; i++) {
	mixins[i] = GetClassInOuterContext(interp, mixinv[i],
		"may only mix in classes");
	if (mixins[i] == NULL) {
	    TclStackFree(interp, mixins);
	    return TCL_ERROR;
	}
    }

    TclOOObjectSetMixins(oPtr, mixinc, mixins);
    TclStackFree(interp, mixins);
    return TCL_OK;
}

/*
 * ----------------------------------------------------------------------
 *
 * ObjectVarsGet, ObjectVarsSet --
 *	Implementation of the "variable" slot accessors of the "oo::objdefine"
 *	command.
 *
 * ----------------------------------------------------------------------
 */

static int
ObjVarsGet(
    ClientData clientData,
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    Tcl_Obj *resultObj, *variableObj;
    int i;

    if (Tcl_ObjectContextSkippedArgs(context) != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		NULL);
	return TCL_ERROR;
    } else if (oPtr == NULL) {
	return TCL_ERROR;
    }

    resultObj = Tcl_NewObj();
    FOREACH(variableObj, oPtr->variables) {
	Tcl_ListObjAppendElement(NULL, resultObj, variableObj);
    }
    Tcl_SetObjResult(interp, resultObj);
    return TCL_OK;
}

static int
ObjVarsSet(
    ClientData clientData,
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    int varc, i;
    Tcl_Obj **varv, *variableObj;

    if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"variableList");
	return TCL_ERROR;
    } else if (oPtr == NULL) {
	return TCL_ERROR;
    }
    objv += Tcl_ObjectContextSkippedArgs(context);
    if (Tcl_ListObjGetElements(interp, objv[0], &varc,
	    &varv) != TCL_OK) {
	return TCL_ERROR;
    }

    for (i=0 ; i<varc ; i++) {
	const char *varName = Tcl_GetString(varv[i]);

	if (strstr(varName, "::") != NULL) {
	    Tcl_AppendResult(interp, "invalid declared variable name \"",
		    varName, "\": must not contain namespace separators",
		    NULL);
	    Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", NULL);
	    return TCL_ERROR;
	}
	if (Tcl_StringMatch(varName, "*(*)")) {
	    Tcl_AppendResult(interp, "invalid declared variable name \"",
		    varName, "\": must not refer to an array element", NULL);
	    Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", NULL);
	    return TCL_ERROR;
	}
    }
    for (i=0 ; i<varc ; i++) {
	Tcl_IncrRefCount(varv[i]);
    }

    FOREACH(variableObj, oPtr->variables) {
	Tcl_DecrRefCount(variableObj);
    }
    if (i != varc) {
	if (varc == 0) {
	    ckfree((char *) oPtr->variables.list);
	} else if (i) {
	    oPtr->variables.list = (Tcl_Obj **)
		    ckrealloc((char *) oPtr->variables.list,
		    sizeof(Tcl_Obj *) * varc);
	} else {
	    oPtr->variables.list = (Tcl_Obj **)
		    ckalloc(sizeof(Tcl_Obj *) * varc);
	}
    }
    if (varc > 0) {
	memcpy(oPtr->variables.list, varv, sizeof(Tcl_Obj *)*varc);
    }
    oPtr->variables.num = varc;
    return TCL_OK;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

				 * instance of the class, and has had nothing
				 * added that changes the dispatch chain (i.e.
				 * no methods, mixins, or filters. */
#define ROOT_CLASS 0x8000	/* Flag to say that this object is the root
				 * class of classes, and should be treated
				 * specially during teardown (and in a few
				 * other spots). */
#define FORCE_UNKNOWN 0x10000	/* States that we are *really* looking up the
				 * unknown method handler at that point. */

/*
 * And the definition of a class. Note that every class also has an associated
 * object, through which it is manipulated.
 */

typedef struct Class {

			    Tcl_Obj *const *objv);
MODULE_SCOPE int	TclOODefineDestructorObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const *objv);
MODULE_SCOPE int	TclOODefineExportObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const *objv);



MODULE_SCOPE int	TclOODefineForwardObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const *objv);
MODULE_SCOPE int	TclOODefineMethodObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const *objv);



MODULE_SCOPE int	TclOODefineRenameMethodObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const *objv);



MODULE_SCOPE int	TclOODefineUnexportObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const *objv);



MODULE_SCOPE int	TclOODefineClassObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const *objv);
MODULE_SCOPE int	TclOODefineSelfObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const *objv);
MODULE_SCOPE int	TclOOUnknownDefinition(ClientData clientData,

MODULE_SCOPE void	TclOOAddToMixinSubs(Class *subPtr, Class *mixinPtr);
MODULE_SCOPE void	TclOOAddToSubclasses(Class *subPtr, Class *superPtr);
MODULE_SCOPE int	TclNRNewObjectInstance(Tcl_Interp *interp,
			    Tcl_Class cls, const char *nameStr,
			    const char *nsNameStr, int objc,
			    Tcl_Obj *const *objv, int skip,
			    Tcl_Object *objectPtr);
MODULE_SCOPE int	TclOODefineSlots(Foundation *fPtr);
MODULE_SCOPE void	TclOODeleteChain(CallChain *callPtr);
MODULE_SCOPE void	TclOODeleteChainCache(Tcl_HashTable *tablePtr);
MODULE_SCOPE void	TclOODeleteContext(CallContext *contextPtr);
MODULE_SCOPE void	TclOODelMethodRef(Method *method);
MODULE_SCOPE CallContext *TclOOGetCallContext(Object *oPtr,
			    Tcl_Obj *methodNameObj, int flags,
			    Tcl_Obj *cacheInThisObj);

\"oo::define oo::object method missingArgs\""
test oo-1.4 {basic test of OO functionality} -body {
    oo::object create {}
} -returnCodes 1 -result {object name must not be empty}
test oo-1.5 {basic test of OO functionality} -body {
    oo::object doesnotexist
} -returnCodes 1 -result {unknown method "doesnotexist": must be create, destroy or new}
test oo-1.5.1 {basic test of OO functionality} -setup {
    oo::object create aninstance
} -returnCodes error -body {
    aninstance
} -cleanup {
    rename aninstance {}
} -result {wrong # args: should be "aninstance method ?arg ...?"}
test oo-1.6 {basic test of OO functionality} -setup {
    oo::object create aninstance
} -body {
    oo::objdefine aninstance unexport destroy
    aninstance doesnotexist
} -cleanup {
    rename aninstance {}

	method level {} {
	    expr {[next] - [info frame]}
	}
    }
    list [i level] [i frames] [dict get [c frame] object]
} -cleanup {
    c destroy
} -result {1 {{* cmd {info frame 0} method frames class ::c level 0} {* cmd {info frame 0} method frames object ::i level 0}} ::c}
test oo-22.2 {OO and info frame: Bug 3001438} -setup {
    oo::class create c
} -body {
    oo::define c method test {{x 1}} {
	if {$x} {my test 0}
	lsort {q w e r t y u i o p}; # Overwrite the Tcl stack
	info frame 0

    cls create obj
    oo::objdefine obj {
	method dummy2 {} {}
	method unknown args {next {*}$args}
    }
    obj foo bar
} -result {unknown method "foo": must be destroy, dummy, dummy2 or unknown}
test oo-24.3 {unknown method method - absent method name} -setup {
    set o [oo::object new]
} -cleanup {
    $o destroy
} -body {
    oo::objdefine $o method unknown args {
	return "unknown: >>$args<<"
    }
    list [$o] [$o foobar] [$o foo bar]
} -result {{unknown: >><<} {unknown: >>foobar<<} {unknown: >>foo bar<<}}

# Probably need a better set of tests, but this is quite difficult to devise
test oo-25.1 {call chain caching} -setup {
    oo::class create cls {
	method ab {} {return ok}
    }
    set result {}

	method get {} {return $x}
    }
    list [foo exists] [foo set 7] [foo exists] [foo get] [foo unset] \
	[foo exists] [catch {foo get} msg] $msg
} -cleanup {
    foo destroy
} -result {0 7 1 7 {} 0 1 {can't read "x": no such variable}}
test oo-27.14 {variables declaration - multiple use} -setup {
    oo::class create master
} -cleanup {
    master destroy
} -body {
    oo::class create foo {
	superclass master
	variable x
	variable y
	method boo {} {
	    return [incr x],[incr y]
	}
    }
    foo create bar
    list [bar boo] [bar boo]
} -result {1,1 2,2}
test oo-27.15 {variables declaration - multiple use} -setup {
    oo::class create master
} -cleanup {
    master destroy
} -body {
    oo::class create foo {
	superclass master
	variable
	variable x y
	method boo {} {
	    return [incr x],[incr y]
	}
    }
    foo create bar
    list [bar boo] [bar boo]
} -result {1,1 2,2}
test oo-27.16 {variables declaration - multiple use} -setup {
    oo::class create master
} -cleanup {
    master destroy
} -body {
    oo::class create foo {
	superclass master
	variable x
	variable -clear
	variable y
	method boo {} {
	    return [incr x],[incr y]
	}
    }
    foo create bar
    list [bar boo] [bar boo]
} -result {1,1 1,2}
test oo-27.17 {variables declaration - multiple use} -setup {
    oo::class create master
} -cleanup {
    master destroy
} -body {
    oo::class create foo {
	superclass master
	variable x
	variable -set y
	method boo {} {
	    return [incr x],[incr y]
	}
    }
    foo create bar
    list [bar boo] [bar boo]
} -result {1,1 1,2}
test oo-27.18 {variables declaration - multiple use} -setup {
    oo::class create master
} -cleanup {
    master destroy
} -body {
    oo::class create foo {
	superclass master
	variable x
	variable -? y
	method boo {} {
	    return [incr x],[incr y]
	}
    }
    foo create bar
    list [bar boo] [bar boo]
} -returnCodes error -match glob -result {unknown method "-?": must be *}

# A feature that's not supported because the mechanism may change without
# warning, but is supposed to work...
test oo-28.1 {scripted extensions to oo::define} -setup {
    interp create foo
    foo eval {oo::class create cls {export eval}}
} -cleanup {

	    rename coro {}
	}
    }
    list [leaktest {[cls new] destroy}] [info class instances cls]
} -cleanup {
    cls destroy
} -result {0 {}}

oo::class create SampleSlot {
    superclass oo::Slot
    constructor {} {
	variable contents {a b c} ops {}
    }
    method contents {} {variable contents; return $contents}
    method ops {} {variable ops; return $ops}
    method Get {} {
	variable contents
	variable ops
	lappend ops [info level] Get
	return $contents
    }
    method Set {lst} {
	variable contents $lst
	variable ops
	lappend ops [info level] Set $lst
	return
    }
}

test oo-32.1 {TIP 380: slots - class test} -setup {
    SampleSlot create sampleSlot
} -body {
    list [info level] [sampleSlot contents] [sampleSlot ops]
} -cleanup {
    rename sampleSlot {}
} -result {0 {a b c} {}}
test oo-32.2 {TIP 380: slots - class test} -setup {
    SampleSlot create sampleSlot
} -body {
    list [info level] [sampleSlot -clear] \
	[sampleSlot contents] [sampleSlot ops]
} -cleanup {
    rename sampleSlot {}
} -result {0 {} {} {1 Set {}}}
test oo-32.3 {TIP 380: slots - class test} -setup {
    SampleSlot create sampleSlot
} -body {
    list [info level] [sampleSlot -append g h i] \
	[sampleSlot contents] [sampleSlot ops]
} -cleanup {
    rename sampleSlot {}
} -result {0 {} {a b c g h i} {1 Get 1 Set {a b c g h i}}}
test oo-32.4 {TIP 380: slots - class test} -setup {
    SampleSlot create sampleSlot
} -body {
    list [info level] [sampleSlot -set d e f] \
	[sampleSlot contents] [sampleSlot ops]
} -cleanup {
    rename sampleSlot {}
} -result {0 {} {d e f} {1 Set {d e f}}}
test oo-32.5 {TIP 380: slots - class test} -setup {
    SampleSlot create sampleSlot
} -body {
    list [info level] [sampleSlot -set d e f] [sampleSlot -append g h i] \
	[sampleSlot contents] [sampleSlot ops]
} -cleanup {
    rename sampleSlot {}
} -result {0 {} {} {d e f g h i} {1 Set {d e f} 1 Get 1 Set {d e f g h i}}}

test oo-33.1 {TIP 380: slots - defaulting} -setup {
    set s [SampleSlot new]
} -body {
    list [$s x y] [$s contents]
} -cleanup {
    rename $s {}
} -result {{} {a b c x y}}
test oo-33.2 {TIP 380: slots - defaulting} -setup {
    set s [SampleSlot new]
} -body {
    list [$s destroy; $s unknown] [$s contents]
} -cleanup {
    rename $s {}
} -result {{} {a b c destroy unknown}}
test oo-32.3 {TIP 380: slots - defaulting} -setup {
    set s [SampleSlot new]
} -body {
    oo::objdefine $s forward --default-operation  my -set
    list [$s destroy; $s unknown] [$s contents] [$s ops]
} -cleanup {
    rename $s {}
} -result {{} unknown {1 Set destroy 1 Set unknown}}
test oo-33.4 {TIP 380: slots - errors} -setup {
    set s [SampleSlot new]
} -body {
    # Method names beginning with "-" are special to slots
    $s -grill q
} -returnCodes error -cleanup {
    rename $s {}
} -result {unknown method "-grill": must be -append, -clear, -set, contents or ops}

SampleSlot destroy

test oo-34.1 {TIP 380: slots - presence} -setup {
    set obj [oo::object new]
    set result {}
} -body {
    oo::define oo::object {
	::lappend ::result [::info object class filter]
	::lappend ::result [::info object class mixin]
	::lappend ::result [::info object class superclass]
	::lappend ::result [::info object class variable]
    }
    oo::objdefine $obj {
	::lappend ::result [::info object class filter]
	::lappend ::result [::info object class mixin]
	::lappend ::result [::info object class variable]
    }
    return $result
} -cleanup {
    $obj destroy
} -result {::oo::Slot ::oo::Slot ::oo::Slot ::oo::Slot ::oo::Slot ::oo::Slot ::oo::Slot}
test oo-34.2 {TIP 380: slots - presence} {
    lsort [info class instances oo::Slot]
} {::oo::define::filter ::oo::define::mixin ::oo::define::superclass ::oo::define::variable ::oo::objdefine::filter ::oo::objdefine::mixin ::oo::objdefine::variable}
proc getMethods obj {
    list [lsort [info object methods $obj -all]] \
	[lsort [info object methods $obj -private]]
}
test oo-34.3 {TIP 380: slots - presence} {
    getMethods oo::define::filter
} {{-append -clear -set} {Get Set}}
test oo-34.4 {TIP 380: slots - presence} {
    getMethods oo::define::mixin
} {{-append -clear -set} {--default-operation Get Set}}
test oo-34.5 {TIP 380: slots - presence} {
    getMethods oo::define::superclass
} {{-append -clear -set} {--default-operation Get Set}}
test oo-34.6 {TIP 380: slots - presence} {
    getMethods oo::define::variable
} {{-append -clear -set} {Get Set}}
test oo-34.7 {TIP 380: slots - presence} {
    getMethods oo::objdefine::filter
} {{-append -clear -set} {Get Set}}
test oo-34.8 {TIP 380: slots - presence} {
    getMethods oo::objdefine::mixin
} {{-append -clear -set} {--default-operation Get Set}}
test oo-34.9 {TIP 380: slots - presence} {
    getMethods oo::objdefine::variable
} {{-append -clear -set} {Get Set}}

cleanupTests
return

# Local Variables:
# mode: tcl
# End: