summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2006-10-20 15:16:47 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2006-10-20 15:16:47 (GMT)
commitd3e1aa1876716ce04f520834edee8125724daac9 (patch)
tree6e5adffffcc577f30bfd88dbb0cfad5846a9e410
parent667340e02adf467adc84a317f84580be29dc5c71 (diff)
downloadtcl-d3e1aa1876716ce04f520834edee8125724daac9.zip
tcl-d3e1aa1876716ce04f520834edee8125724daac9.tar.gz
tcl-d3e1aa1876716ce04f520834edee8125724daac9.tar.bz2
Undo mistaken commit to wrong branch caused by CVS fumble... :-}
-rw-r--r--generic/tcl.h83
-rw-r--r--generic/tclBasic.c18
-rw-r--r--generic/tclCmdIL.c20
-rw-r--r--generic/tclInt.decls5
-rw-r--r--generic/tclInt.h73
-rw-r--r--generic/tclIntDecls.h6
-rw-r--r--generic/tclNamesp.c16
-rw-r--r--generic/tclOO.c3288
-rw-r--r--generic/tclOO.h389
-rw-r--r--generic/tclOOCall.c803
-rw-r--r--generic/tclOODefineCmds.c953
-rw-r--r--generic/tclOOInfo.c901
-rw-r--r--generic/tclProc.c275
-rw-r--r--generic/tclVar.c29
-rw-r--r--tests/info.test14
-rw-r--r--tests/oo.test1243
-rw-r--r--unix/Makefile.in26
-rw-r--r--win/Makefile.in10
-rw-r--r--win/makefile.bc4
-rw-r--r--win/makefile.vc6
20 files changed, 118 insertions, 8044 deletions
diff --git a/generic/tcl.h b/generic/tcl.h
index 2c95f26..3501c96 100644
--- a/generic/tcl.h
+++ b/generic/tcl.h
@@ -13,7 +13,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tcl.h,v 1.218 2006/10/20 14:04:00 dkf Exp $
+ * RCS: @(#) $Id: tcl.h,v 1.219 2006/10/20 15:16:47 dkf Exp $
*/
#ifndef _TCL
@@ -501,7 +501,6 @@ typedef struct Tcl_Interp {
typedef struct Tcl_AsyncHandler_ *Tcl_AsyncHandler;
typedef struct Tcl_Channel_ *Tcl_Channel;
typedef struct Tcl_ChannelTypeVersion_ *Tcl_ChannelTypeVersion;
-typedef struct Tcl_Class_ *Tcl_Class;
typedef struct Tcl_Command_ *Tcl_Command;
typedef struct Tcl_Condition_ *Tcl_Condition;
typedef struct Tcl_Dict_ *Tcl_Dict;
@@ -510,10 +509,7 @@ typedef struct Tcl_Encoding_ *Tcl_Encoding;
typedef struct Tcl_Event Tcl_Event;
typedef struct Tcl_InterpState_ *Tcl_InterpState;
typedef struct Tcl_LoadHandle_ *Tcl_LoadHandle;
-typedef struct Tcl_Method_ *Tcl_Method;
typedef struct Tcl_Mutex_ *Tcl_Mutex;
-typedef struct Tcl_Object_ *Tcl_Object;
-typedef struct Tcl_ObjectContext_ *Tcl_ObjectContext;
typedef struct Tcl_Pid_ *Tcl_Pid;
typedef struct Tcl_RegExp_ *Tcl_RegExp;
typedef struct Tcl_ThreadDataKey_ *Tcl_ThreadDataKey;
@@ -957,8 +953,6 @@ typedef struct Tcl_CallFrame {
char *dummy8;
int dummy9;
char* dummy10;
- void* dummy11;
- /*int dummy12;*/
} Tcl_CallFrame;
/*
@@ -2357,81 +2351,6 @@ typedef unsigned long mp_digit;
#define MP_DIGIT_DECLARED
#endif
-/*
- * Public datatypes for callbacks and structures used in the TIP#257 (OO)
- * implementation. These are used to implement custom types of method calls
- * and to allow the attachment of arbitrary data to objects and classes.
- */
-
-typedef int (*Tcl_MethodCallProc)_ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, Tcl_ObjectContext objectContext, int objc,
- Tcl_Obj *const *objv));
-typedef void (*Tcl_MethodDeleteProc)_ANSI_ARGS_((ClientData clientData));
-typedef int (*Tcl_MethodCloneProc)_ANSI_ARGS_((ClientData oldClientData,
- ClientData *newClientData));
-typedef void (*Tcl_ObjectMetadataDeleteProc)_ANSI_ARGS_((
- ClientData clientData));
-typedef ClientData (*Tcl_ObjectMetadataCloneProc)_ANSI_ARGS_((
- ClientData clientData));
-
-/*
- * The type of a method implementation. This describes how to call the method
- * implementation, how to delete it (when the object or class is deleted) and
- * how to create a clone of it (when the object or class is copied).
- */
-
-typedef struct {
- int version; /* Structure version field. Always to be equal
- * to TCL_OO_METHOD_VERSION_CURRENT in
- * declarations. */
- const char *name; /* Name of this type of method, mostly for
- * debugging purposes. */
- Tcl_MethodCallProc callProc;/* How to invoke this method. */
- Tcl_MethodDeleteProc deleteProc;
- /* How to delete this method's type-specific
- * data, or NULL if the type-specific data
- * does not need deleting. */
- Tcl_MethodCloneProc cloneProc;
- /* How to copy this method's type-specific
- * data, or NULL if the type-specific data can
- * be copied directly. */
-} Tcl_MethodType;
-
-/*
- * The correct value for the version field of the Tcl_MethodType structure.
- * This allows new versions of the structure to be introduced without breaking
- * binary compatability.
- */
-
-#define TCL_OO_METHOD_VERSION_CURRENT 1
-
-/*
- * The type of some object (or class) metadata. This describes how to delete
- * the metadata (when the object or class is deleted) and how to create a
- * clone of it (when the object or class is copied).
- */
-
-typedef struct {
- int version; /* Structure version field. Always to be equal
- * to TCL_OO_METADATA_VERSION_CURRENT in
- * declarations. */
- const char *name;
- Tcl_ObjectMetadataDeleteProc deleteProc;
- /* How to delete the metadata. This must not
- * be NULL. */
- Tcl_ObjectMetadataCloneProc cloneProc;
- /* How to clone the metadata. If NULL, the
- * metadata will not be copied. */
-} Tcl_ObjectMetadataType;
-
-/*
- * The correct value for the version field of the Tcl_ObjectMetadataType
- * structure. This allows new versions of the structure to be introduced
- * without breaking binary compatability.
- */
-
-#define TCL_OO_METHOD_VERSION_CURRENT 1
-
#ifndef TCL_NO_DEPRECATED
/*
* Deprecated Tcl functions:
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 0b9f15f..a7a31a6 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -13,7 +13,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclBasic.c,v 1.199 2006/10/20 14:04:00 dkf Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.200 2006/10/20 15:16:47 dkf Exp $
*/
#include "tclInt.h"
@@ -526,18 +526,13 @@ Tcl_CreateInterp(void)
#endif
/*
- * TIP #59: Make embedded configuration information available.
+ * TIP #59: Make embedded configuration information
+ * available.
*/
TclInitEmbeddedConfigurationInformation(interp);
/*
- * TIP #257: Install the OO engine (for testing).
- */
-
- TclOOInit(interp);
-
- /*
* Compute the byte order of this machine.
*/
@@ -1943,8 +1938,8 @@ TclInvokeObjectCommand(
int
TclRenameCommand(
Tcl_Interp *interp, /* Current interpreter. */
- const char *oldName, /* Existing command name. */
- const char *newName) /* New command name. */
+ char *oldName, /* Existing command name. */
+ char *newName) /* New command name. */
{
Interp *iPtr = (Interp *) interp;
CONST char *newTail;
@@ -1961,7 +1956,8 @@ TclRenameCommand(
* found.
*/
- cmd = Tcl_FindCommand(interp, oldName, NULL, /*flags*/ 0);
+ cmd = Tcl_FindCommand(interp, oldName, NULL,
+ /*flags*/ 0);
cmdPtr = (Command *) cmd;
if (cmdPtr == NULL) {
Tcl_AppendResult(interp, "can't ",
diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index 97170a9..cedfb6b 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -16,7 +16,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclCmdIL.c,v 1.88 2006/10/20 14:04:00 dkf Exp $
+ * RCS: @(#) $Id: tclCmdIL.c,v 1.89 2006/10/20 15:16:47 dkf Exp $
*/
#include "tclInt.h"
@@ -357,17 +357,17 @@ Tcl_InfoObjCmd(clientData, interp, objc, objv)
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
static CONST char *subCmds[] = {
- "args", "body", "class", "cmdcount", "commands",
+ "args", "body", "cmdcount", "commands",
"complete", "default", "exists", "functions", "globals",
- "hostname", "level", "library", "loaded", "locals",
- "nameofexecutable", "object", "patchlevel", "procs",
+ "hostname", "level", "library", "loaded",
+ "locals", "nameofexecutable", "patchlevel", "procs",
"script", "sharedlibextension", "tclversion", "vars",
(char *) NULL};
enum ISubCmdIdx {
- IArgsIdx, IBodyIdx, IClassIdx, ICmdCountIdx, ICommandsIdx,
+ IArgsIdx, IBodyIdx, ICmdCountIdx, ICommandsIdx,
ICompleteIdx, IDefaultIdx, IExistsIdx, IFunctionsIdx, IGlobalsIdx,
- IHostnameIdx, ILevelIdx, ILibraryIdx, ILoadedIdx, ILocalsIdx,
- INameOfExecutableIdx, IObjectIdx, IPatchLevelIdx, IProcsIdx,
+ IHostnameIdx, ILevelIdx, ILibraryIdx, ILoadedIdx,
+ ILocalsIdx, INameOfExecutableIdx, IPatchLevelIdx, IProcsIdx,
IScriptIdx, ISharedLibExtensionIdx, ITclVersionIdx, IVarsIdx
};
int index, result;
@@ -390,9 +390,6 @@ Tcl_InfoObjCmd(clientData, interp, objc, objv)
case IBodyIdx:
result = InfoBodyCmd(clientData, interp, objc, objv);
break;
- case IClassIdx:
- result = TclInfoClassCmd(clientData, interp, objc, objv);
- break;
case ICmdCountIdx:
result = InfoCmdCountCmd(clientData, interp, objc, objv);
break;
@@ -432,9 +429,6 @@ Tcl_InfoObjCmd(clientData, interp, objc, objv)
case INameOfExecutableIdx:
result = InfoNameOfExecutableCmd(clientData, interp, objc, objv);
break;
- case IObjectIdx:
- result = TclInfoObjectCmd(clientData, interp, objc, objv);
- break;
case IPatchLevelIdx:
result = InfoPatchLevelCmd(clientData, interp, objc, objv);
break;
diff --git a/generic/tclInt.decls b/generic/tclInt.decls
index c927ce1..e257ff8 100644
--- a/generic/tclInt.decls
+++ b/generic/tclInt.decls
@@ -12,7 +12,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: tclInt.decls,v 1.99 2006/10/20 14:04:00 dkf Exp $
+# RCS: @(#) $Id: tclInt.decls,v 1.100 2006/10/20 15:16:47 dkf Exp $
library tcl
@@ -390,8 +390,7 @@ declare 93 generic {
# int TclpStat(CONST char *path, Tcl_StatBuf *buf)
#}
declare 96 generic {
- int TclRenameCommand(Tcl_Interp *interp, CONST char *oldName,
- CONST char *newName)
+ int TclRenameCommand(Tcl_Interp *interp, char *oldName, char *newName)
}
declare 97 generic {
void TclResetShadowedCmdRefs(Tcl_Interp *interp, Command *newCmdPtr)
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 02bfbcb..57912ff 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -12,7 +12,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclInt.h,v 1.280 2006/10/20 14:04:00 dkf Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.281 2006/10/20 15:16:47 dkf Exp $
*/
#ifndef _TCLINT
@@ -112,8 +112,6 @@ typedef int ptrdiff_t;
#define NO_WIDE_TYPE
#endif
-struct Foundation; // Forward decl for OO support
-
/*
* The following procedures allow namespaces to be customized to support
* special name resolution rules for commands/variables.
@@ -892,15 +890,9 @@ typedef struct CallFrame {
* recognized by the compiler. The compiler
* emits code that refers to these variables
* using an index into this array. */
- void *ooContextPtr; /* TODO: Docme */
} CallFrame;
#define FRAME_IS_PROC 0x1
-#define FRAME_IS_METHOD 0x2 /* TODO: Docme */
-#define FRAME_IS_FILTER 0x4 /* TODO: Docme */
-#define FRAME_IS_OO_DEFINE 0x8 /* TODO: Docme */
-#define FRAME_IS_CONSTRUCTOR 0x10
-#define FRAME_IS_DESTRUCTOR 0x20
/*
*----------------------------------------------------------------
@@ -1522,8 +1514,6 @@ typedef struct Interp {
* inserted by an ensemble. */
} ensembleRewrite;
- struct Foundation *ooFoundation; // OO support
-
/*
* TIP #219 ... Global info for the I/O system ...
*/
@@ -2119,7 +2109,7 @@ MODULE_SCOPE void TclInitLimitSupport(Tcl_Interp *interp);
MODULE_SCOPE void TclInitNamespaceSubsystem(void);
MODULE_SCOPE void TclInitNotifier(void);
MODULE_SCOPE void TclInitObjSubsystem(void);
-MODULE_SCOPE void TclInitSubsystems(void);
+MODULE_SCOPE void TclInitSubsystems ();
MODULE_SCOPE int TclInterpReady(Tcl_Interp *interp);
MODULE_SCOPE int TclIsLocalScalar(CONST char *src, int len);
MODULE_SCOPE int TclJoinThread(Tcl_ThreadId id, int* result);
@@ -2387,12 +2377,6 @@ MODULE_SCOPE int Tcl_IncrObjCmd(ClientData clientData,
MODULE_SCOPE int Tcl_InfoObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]);
-MODULE_SCOPE int TclInfoClassCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *CONST objv[]);
-MODULE_SCOPE int TclInfoObjectCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *CONST objv[]);
MODULE_SCOPE int Tcl_InterpObjCmd(ClientData clientData,
Tcl_Interp *interp, int argc,
Tcl_Obj *CONST objv[]);
@@ -2534,55 +2518,6 @@ MODULE_SCOPE int Tcl_WhileObjCmd(ClientData clientData,
/*
*----------------------------------------------------------------
- * Commands relating to OO support.
- *----------------------------------------------------------------
- */
-
-MODULE_SCOPE int TclOOInit(Tcl_Interp *interp);
-MODULE_SCOPE int TclOODefineObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const *objv);
-MODULE_SCOPE int TclOODefineConstructorObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const *objv);
-MODULE_SCOPE int TclOODefineCopyObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- 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 TclOODefineFilterObjCmd(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 TclOODefineMixinObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const *objv);
-#ifdef SUPPORT_OO_PARAMETERS
-MODULE_SCOPE int TclOODefineParameterObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const *objv);
-#endif
-MODULE_SCOPE int TclOODefineSuperclassObjCmd(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 TclOODefineSelfClassObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const *objv);
-
-/*
- *----------------------------------------------------------------
* Compilation procedures for commands in the generic core:
*----------------------------------------------------------------
*/
@@ -3119,10 +3054,6 @@ MODULE_SCOPE void TclBNInitBignumFromWideUInt(mp_int* bignum,
#define TclIsNaN(d) ((d) != (d))
#endif
-// MOVE ME TO tclInt.decls
-void TclSetNsPath(Namespace *nsPtr, int pathLength,
- Tcl_Namespace *pathAry[]);
-
#include "tclPort.h"
#include "tclIntDecls.h"
#include "tclIntPlatDecls.h"
diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h
index 3e9ba60..1182640 100644
--- a/generic/tclIntDecls.h
+++ b/generic/tclIntDecls.h
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclIntDecls.h,v 1.89 2006/10/20 14:04:00 dkf Exp $
+ * RCS: @(#) $Id: tclIntDecls.h,v 1.90 2006/10/20 15:16:47 dkf Exp $
*/
#ifndef _TCLINTDECLS
@@ -424,7 +424,7 @@ EXTERN void TclProcDeleteProc _ANSI_ARGS_((ClientData clientData));
#define TclRenameCommand_TCL_DECLARED
/* 96 */
EXTERN int TclRenameCommand _ANSI_ARGS_((Tcl_Interp * interp,
- CONST char * oldName, CONST char * newName));
+ char * oldName, char * newName));
#endif
#ifndef TclResetShadowedCmdRefs_TCL_DECLARED
#define TclResetShadowedCmdRefs_TCL_DECLARED
@@ -1136,7 +1136,7 @@ typedef struct TclIntStubs {
void (*tclProcDeleteProc) _ANSI_ARGS_((ClientData clientData)); /* 93 */
void *reserved94;
void *reserved95;
- int (*tclRenameCommand) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * oldName, CONST char * newName)); /* 96 */
+ int (*tclRenameCommand) _ANSI_ARGS_((Tcl_Interp * interp, char * oldName, char * newName)); /* 96 */
void (*tclResetShadowedCmdRefs) _ANSI_ARGS_((Tcl_Interp * interp, Command * newCmdPtr)); /* 97 */
int (*tclServiceIdle) _ANSI_ARGS_((void)); /* 98 */
void *reserved99;
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index c3d4e7c..eae2530 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -22,7 +22,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclNamesp.c,v 1.102 2006/10/20 14:04:00 dkf Exp $
+ * RCS: @(#) $Id: tclNamesp.c,v 1.103 2006/10/20 15:16:47 dkf Exp $
*/
#include "tclInt.h"
@@ -117,8 +117,8 @@ typedef struct EnsembleConfig {
* all lists, and cannot be found by scanning
* the list from the namespace's ensemble
* field. */
- int flags; /* ORed combo of TCL_ENSEMBLE_PREFIX and
- * ENS_DEAD. */
+ int flags; /* ORed combo of ENS_DEAD and
+ * TCL_ENSEMBLE_PREFIX. */
/* OBJECT FIELDS FOR ENSEMBLE CONFIGURATION */
@@ -251,6 +251,8 @@ static void FreeEnsembleCmdRep(Tcl_Obj *objPtr);
static void DupEnsembleCmdRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr);
static void StringOfEnsembleCmdRep(Tcl_Obj *objPtr);
static void UnlinkNsPath(Namespace *nsPtr);
+static void SetNsPath(Namespace *nsPtr, int pathLength,
+ Tcl_Namespace *pathAry[]);
/*
* This structure defines a Tcl object type that contains a namespace
@@ -4108,7 +4110,7 @@ NamespacePathCmd(
* Now we have the list of valid namespaces, install it as the path.
*/
- TclSetNsPath(nsPtr, nsObjc, namespaceList);
+ SetNsPath(nsPtr, nsObjc, namespaceList);
result = TCL_OK;
badNamespace:
@@ -4121,7 +4123,7 @@ NamespacePathCmd(
/*
*----------------------------------------------------------------------
*
- * TclSetNsPath --
+ * SetNsPath --
*
* Sets the namespace command name resolution path to the given list of
* namespaces. If the list is empty (of zero length) the path is set to
@@ -4139,8 +4141,8 @@ NamespacePathCmd(
*/
/* EXPOSE ME? */
-void
-TclSetNsPath(
+static void
+SetNsPath(
Namespace *nsPtr, /* Namespace whose path is to be set. */
int pathLength, /* Length of pathAry */
Tcl_Namespace *pathAry[]) /* Array of namespaces that are the path. */
diff --git a/generic/tclOO.c b/generic/tclOO.c
deleted file mode 100644
index bca3477..0000000
--- a/generic/tclOO.c
+++ /dev/null
@@ -1,3288 +0,0 @@
-/*
- * tclOO.c --
- *
- * This file contains the object-system core (NB: not Tcl_Obj, but ::oo)
- *
- * Copyright (c) 2005-2006 by Donal K. Fellows
- *
- * See the file "license.terms" for information on usage and redistribution of
- * this file, and for a DISCLAIMER OF ALL WARRANTIES.
- *
- * RCS: @(#) $Id: tclOO.c,v 1.2 2006/10/20 14:04:00 dkf Exp $
- */
-
-#include "tclInt.h"
-#include "tclOO.h"
-
-/*
- * Commands in oo::define.
- */
-
-static const struct {
- const char *name;
- Tcl_ObjCmdProc *objProc;
- int flag;
-} defineCmds[] = {
- {"constructor", TclOODefineConstructorObjCmd, 0},
- {"copy", TclOODefineCopyObjCmd, 0},
- {"destructor", TclOODefineDestructorObjCmd, 0},
- {"export", TclOODefineExportObjCmd, 0},
- {"self.export", TclOODefineExportObjCmd, 1},
- {"filter", TclOODefineFilterObjCmd, 0},
- {"self.filter", TclOODefineFilterObjCmd, 1},
- {"forward", TclOODefineForwardObjCmd, 0},
- {"self.forward", TclOODefineForwardObjCmd, 1},
- {"method", TclOODefineMethodObjCmd, 0},
- {"self.method", TclOODefineMethodObjCmd, 1},
- {"mixin", TclOODefineMixinObjCmd, 0},
- {"self.mixin", TclOODefineMixinObjCmd, 1},
-#ifdef SUPPORT_OO_PARAMETERS
- {"parameter", TclOODefineParameterObjCmd, 0},
-#endif
- {"superclass", TclOODefineSuperclassObjCmd, 0},
- {"unexport", TclOODefineUnexportObjCmd, 0},
- {"self.unexport", TclOODefineUnexportObjCmd, 1},
- {"self.class", TclOODefineSelfClassObjCmd, 1},
- {NULL, NULL, 0}
-};
-
-/*
- * What sort of size of things we like to allocate.
- */
-
-#define ALLOC_CHUNK 8
-
-/*
- * Function declarations for things defined in this file.
- */
-
-static Class * AllocClass(Tcl_Interp *interp, Object *useThisObj);
-static Object * AllocObject(Tcl_Interp *interp, const char *nameStr);
-static Method * CloneClassMethod(Tcl_Interp *interp, Class *clsPtr,
- Method *mPtr, Tcl_Obj *namePtr);
-static Method * CloneObjectMethod(Tcl_Interp *interp, Object *oPtr,
- Method *mPtr, Tcl_Obj *namePtr);
-static void DeclareClassMethod(Tcl_Interp *interp, Class *clsPtr,
- const char *name, int isPublic,
- Tcl_MethodCallProc callProc);
-static void KillFoundation(ClientData clientData,
- Tcl_Interp *interp);
-static int ObjectCmd(Object *oPtr, Tcl_Interp *interp, int objc,
- Tcl_Obj *const *objv, int publicOnly,
- Tcl_HashTable *cachePtr);
-static void ObjectNamespaceDeleted(ClientData clientData);
-static void ObjectDeletedTrace(ClientData clientData,
- Tcl_Interp *interp, const char *oldName,
- const char *newName, int flags);
-static void ReleaseClassContents(Tcl_Interp *interp,Object *oPtr);
-
-static int PublicObjectCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const *objv);
-static int PrivateObjectCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const *objv);
-
-static int SimpleInvoke(ClientData clientData,
- Tcl_Interp *interp, Tcl_ObjectContext context,
- int objc, Tcl_Obj *const *objv);
-static int InvokeProcedureMethod(ClientData clientData,
- Tcl_Interp *interp, Tcl_ObjectContext context,
- int objc, Tcl_Obj *const *objv);
-static void DeleteProcedureMethod(ClientData clientData);
-static int CloneProcedureMethod(ClientData clientData,
- ClientData *newClientData);
-static int InvokeForwardMethod(ClientData clientData,
- Tcl_Interp *interp, Tcl_ObjectContext context,
- int objc, Tcl_Obj *const *objv);
-static void DeleteForwardMethod(ClientData clientData);
-static int CloneForwardMethod(ClientData clientData,
- ClientData *newClientData);
-static Tcl_Obj ** InitEnsembleRewrite(Tcl_Interp *interp, int objc,
- Tcl_Obj *const *objv, int toRewrite,
- int rewriteLength, Tcl_Obj *const *rewriteObjs,
- int *lengthPtr);
-
-static int ClassCreate(ClientData clientData, Tcl_Interp *interp,
- Tcl_ObjectContext context, int objc,
- Tcl_Obj *const *objv);
-static int ClassNew(ClientData clientData, Tcl_Interp *interp,
- Tcl_ObjectContext context, int objc,
- Tcl_Obj *const *objv);
-static int ObjectDestroy(ClientData clientData,
- Tcl_Interp *interp, Tcl_ObjectContext context,
- int objc, Tcl_Obj *const *objv);
-static int ObjectEval(ClientData clientData, Tcl_Interp *interp,
- Tcl_ObjectContext context, int objc,
- Tcl_Obj *const *objv);
-static int ObjectLinkVar(ClientData clientData,
- Tcl_Interp *interp, Tcl_ObjectContext context,
- int objc, Tcl_Obj *const *objv);
-static int ObjectUnknown(ClientData clientData,
- Tcl_Interp *interp, Tcl_ObjectContext context,
- int objc, Tcl_Obj *const *objv);
-static int ObjectVarName(ClientData clientData,
- Tcl_Interp *interp, Tcl_ObjectContext context,
- int objc, Tcl_Obj *const *objv);
-
-static int NextObjCmd(ClientData clientData, Tcl_Interp *interp,
- int objc, Tcl_Obj *const *objv);
-static int SelfObjCmd(ClientData clientData, Tcl_Interp *interp,
- int objc, Tcl_Obj *const *objv);
-
-/*
- * The types of methods defined by the core OO system.
- */
-
-static const Tcl_MethodType procMethodType = {
- TCL_OO_METHOD_VERSION_CURRENT, "procedural method",
- InvokeProcedureMethod, DeleteProcedureMethod, CloneProcedureMethod
-};
-static const Tcl_MethodType fwdMethodType = {
- TCL_OO_METHOD_VERSION_CURRENT, "forward",
- InvokeForwardMethod, DeleteForwardMethod, CloneForwardMethod
-};
-static const Tcl_MethodType coreMethodType = {
- TCL_OO_METHOD_VERSION_CURRENT, "core method",
- SimpleInvoke, NULL, NULL
-};
-
-/*
- * ----------------------------------------------------------------------
- *
- * TclOOInit --
- *
- * Called to initialise the OO system within an interpreter.
- *
- * Result:
- * TCL_OK if the setup succeeded. Currently assumed to always work.
- *
- * Side effects:
- * Creates namespaces, commands, several classes and a number of
- * callbacks. Upon return, the OO system is ready for use.
- *
- * ----------------------------------------------------------------------
- */
-
-int
-TclOOInit(
- Tcl_Interp *interp) /* The interpreter to install into. */
-{
- Interp *iPtr = (Interp *) interp;
- Foundation *fPtr;
- int i;
- Tcl_DString buffer;
-
- /*
- * Construct the foundation of the object system. This is a structure
- * holding references to the magical bits that need to be known about in
- * other places.
- */
-
- fPtr = iPtr->ooFoundation = (Foundation *) ckalloc(sizeof(Foundation));
- memset(fPtr, 0, sizeof(Foundation));
- fPtr->ooNs = Tcl_CreateNamespace(interp, "::oo", fPtr, NULL);
- Tcl_Export(interp, fPtr->ooNs, "[a-z]*", 1);
- fPtr->defineNs = Tcl_CreateNamespace(interp, "::oo::define", NULL, NULL);
- fPtr->helpersNs = Tcl_CreateNamespace(interp, "::oo::Helpers", NULL,
- NULL);
- Tcl_CreateObjCommand(interp, "::oo::Helpers::next", NextObjCmd, NULL,
- NULL);
- Tcl_CreateObjCommand(interp, "::oo::Helpers::self", SelfObjCmd, NULL,
- NULL);
- Tcl_CreateObjCommand(interp, "::oo::define", TclOODefineObjCmd, NULL,
- NULL);
- Tcl_DStringInit(&buffer);
- for (i=0 ; defineCmds[i].name ; i++) {
- Tcl_DStringAppend(&buffer, "::oo::define::", 14);
- Tcl_DStringAppend(&buffer, defineCmds[i].name, -1);
- Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer),
- defineCmds[i].objProc, (void *) defineCmds[i].flag, NULL);
- Tcl_DStringFree(&buffer);
- }
- fPtr->epoch = 0;
- fPtr->nsCount = 0;
- fPtr->unknownMethodNameObj = Tcl_NewStringObj("unknown", -1);
- Tcl_IncrRefCount(fPtr->unknownMethodNameObj);
-
- Tcl_CallWhenDeleted(interp, KillFoundation, fPtr);
-
- /*
- * Create the objects at the core of the object system. These need to be
- * spliced manually.
- */
-
- fPtr->objectCls = AllocClass(interp, AllocObject(interp, "::oo::object"));
- fPtr->classCls = AllocClass(interp, AllocObject(interp, "::oo::class"));
- fPtr->objectCls->thisPtr->selfCls = fPtr->classCls;
- fPtr->objectCls->thisPtr->flags |= ROOT_OBJECT;
- fPtr->objectCls->superclasses.num = 0;
- ckfree((char *) fPtr->objectCls->superclasses.list);
- fPtr->objectCls->superclasses.list = NULL;
- fPtr->classCls->thisPtr->selfCls = fPtr->classCls;
- TclOOAddToInstances(fPtr->objectCls->thisPtr, fPtr->classCls);
- TclOOAddToInstances(fPtr->classCls->thisPtr, fPtr->classCls);
-
- /*
- * Basic method declarations for the core classes.
- */
-
- DeclareClassMethod(interp, fPtr->objectCls, "destroy", 1, ObjectDestroy);
- DeclareClassMethod(interp, fPtr->objectCls, "eval", 0, ObjectEval);
- DeclareClassMethod(interp, fPtr->objectCls, "unknown", 0, ObjectUnknown);
- DeclareClassMethod(interp, fPtr->objectCls, "variable", 0, ObjectLinkVar);
- DeclareClassMethod(interp, fPtr->objectCls, "varname", 0, ObjectVarName);
- DeclareClassMethod(interp, fPtr->classCls, "create", 1, ClassCreate);
- DeclareClassMethod(interp, fPtr->classCls, "new", 1, ClassNew);
-
- /*
- * Finish setting up the class of classes.
- */
-
- {
- Tcl_Obj *namePtr, *argsPtr, *bodyPtr;
-
- /*
- * Mark the 'new' method in oo::class as private; classes, unlike
- * general objects, must have explicit names.
- */
-
- namePtr = Tcl_NewStringObj("new", -1);
- Tcl_NewMethod(interp, (Tcl_Object) fPtr->classCls->thisPtr, namePtr,
- 0 /* ==private */, NULL, NULL);
-
- argsPtr = Tcl_NewStringObj("{definitionScript {}}", -1);
- bodyPtr = Tcl_NewStringObj(
- "if {[catch {define [self] $definitionScript} msg opt]} {\n"
- "set ei [split [dict get $opt -errorinfo] \\n]\n"
- "dict set opt -errorinfo [join [lrange $ei 0 end-2] \\n]\n"
- "dict set opt -errorline 0xdeadbeef\n"
- "}\n"
- "return -options $opt $msg", -1);
- fPtr->classCls->constructorPtr = TclOONewProcClassMethod(interp,
- fPtr->classCls, 0, NULL, argsPtr, bodyPtr);
- }
-
- return TCL_OK;
-}
-
-/*
- * ----------------------------------------------------------------------
- *
- * KillFoundation --
- *
- * Delete those parts of the OO core that are not deleted automatically
- * when the objects and classes themselves are destroyed.
- *
- * ----------------------------------------------------------------------
- */
-
-static void
-KillFoundation(
- ClientData clientData, /* Pointer to the OO system foundation
- * structure. */
- Tcl_Interp *interp) /* The interpreter containing the OO system
- * foundation. */
-{
- Foundation *fPtr = clientData;
-
- TclDecrRefCount(fPtr->unknownMethodNameObj);
- ckfree((char *) fPtr);
-}
-
-/*
- * ----------------------------------------------------------------------
- *
- * AllocObject --
- *
- * Allocate an object of basic type. Does not splice the object into its
- * class's instance list.
- *
- * ----------------------------------------------------------------------
- */
-
-static Object *
-AllocObject(
- Tcl_Interp *interp, /* Interpreter within which to create the
- * object. */
- const char *nameStr) /* The name of the object to create, or NULL
- * if the OO system should pick the object
- * name itself. */
-{
- Foundation *fPtr = ((Interp *) interp)->ooFoundation;
- Tcl_Obj *cmdnameObj;
- Tcl_DString buffer;
- Object *oPtr;
-
- oPtr = (Object *) ckalloc(sizeof(Object));
- memset(oPtr, 0, sizeof(Object));
- while (1) {
- char objName[10 + TCL_INTEGER_SPACE];
-
- sprintf(objName, "::oo::Obj%d", ++fPtr->nsCount);
- oPtr->namespacePtr = Tcl_CreateNamespace(interp, objName, oPtr,
- ObjectNamespaceDeleted);
- if (oPtr->namespacePtr != NULL) {
- break;
- }
-
- /*
- * Could not make that namespace, so we make another. But first we
- * have to get rid of the error message from Tcl_CreateNamespace,
- * since that's something that should not be exposed to the user.
- */
-
- Tcl_ResetResult(interp);
- }
- TclSetNsPath((Namespace *) oPtr->namespacePtr, 1, &fPtr->helpersNs);
- oPtr->selfCls = fPtr->objectCls;
- Tcl_InitObjHashTable(&oPtr->methods);
- Tcl_InitObjHashTable(&oPtr->publicContextCache);
- Tcl_InitObjHashTable(&oPtr->privateContextCache);
- oPtr->filters.num = 0;
- oPtr->filters.list = NULL;
- oPtr->mixins.num = 0;
- oPtr->mixins.list = NULL;
- oPtr->classPtr = NULL;
- oPtr->flags = 0;
- oPtr->metadataPtr = NULL;
-
- /*
- * Initialize the traces.
- */
-
- Tcl_DStringInit(&buffer);
- if (nameStr) {
- if (nameStr[0] != ':' || nameStr[1] != ':') {
- Tcl_DStringAppend(&buffer,
- Tcl_GetCurrentNamespace(interp)->fullName, -1);
- Tcl_DStringAppend(&buffer, "::", 2);
- }
- Tcl_DStringAppend(&buffer, nameStr, -1);
- } else {
- Tcl_DStringAppend(&buffer, oPtr->namespacePtr->fullName, -1);
- }
- oPtr->command = Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer),
- PublicObjectCmd, oPtr, NULL);
- if (nameStr) {
- Tcl_DStringFree(&buffer);
- Tcl_DStringAppend(&buffer, oPtr->namespacePtr->fullName, -1);
- }
- Tcl_DStringAppend(&buffer, "::my", 4);
- oPtr->myCommand = Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer),
- PrivateObjectCmd, oPtr, NULL);
- Tcl_DStringFree(&buffer);
-
- TclNewObj(cmdnameObj);
- Tcl_GetCommandFullName(interp, oPtr->command, cmdnameObj);
- Tcl_TraceCommand(interp, TclGetString(cmdnameObj),
- TCL_TRACE_DELETE, ObjectDeletedTrace, oPtr);
- TclDecrRefCount(cmdnameObj);
-
- return oPtr;
-}
-
-/*
- * ----------------------------------------------------------------------
- *
- * ObjectDeletedTrace --
- *
- * This callback is triggered when the object is deleted by any
- * mechanism. It runs the destructors and arranges for the actual cleanup
- * of the object's namespace, which in turn triggers cleansing of the
- * object data structures.
- *
- * ----------------------------------------------------------------------
- */
-
-static void
-ObjectDeletedTrace(
- ClientData clientData, /* The object being deleted. */
- Tcl_Interp *interp, /* The interpreter containing the object. */
- const char *oldName, /* What the object was (last) called. */
- const char *newName, /* Always NULL. */
- int flags) /* Why was the object deleted? */
-{
- Interp *iPtr = (Interp *) interp;
- Object *oPtr = clientData;
- Class *clsPtr;
-
- Tcl_Preserve(oPtr);
- oPtr->flags |= OBJECT_DELETED;
- if (!Tcl_InterpDeleted(interp)) {
- CallContext *contextPtr = TclOOGetCallContext(iPtr->ooFoundation,
- oPtr, NULL, DESTRUCTOR, NULL);
-
- if (contextPtr != NULL) {
- int result;
- Tcl_InterpState state;
-
- contextPtr->flags |= DESTRUCTOR;
- contextPtr->skip = 0;
- state = Tcl_SaveInterpState(interp, TCL_OK);
- result = TclOOInvokeContext(interp, contextPtr, 0, NULL);
- if (result != TCL_OK) {
- Tcl_BackgroundError(interp);
- }
- (void) Tcl_RestoreInterpState(interp, state);
- TclOODeleteContext(contextPtr);
- }
- }
-
- clsPtr = oPtr->classPtr;
- if (clsPtr != NULL) {
- ReleaseClassContents(interp, oPtr);
- }
-
- Tcl_DeleteNamespace(oPtr->namespacePtr);
- if (clsPtr) {
- Tcl_Release(clsPtr);
- }
- Tcl_Release(oPtr);
-
- /*
- * What else to do to delete an object?
- */
-}
-
-/*
- * ----------------------------------------------------------------------
- *
- * ReleaseClassContents --
- *
- * Tear down the special class data structure, including deleting all
- * dependent classes and objects.
- *
- * ----------------------------------------------------------------------
- */
-
-static void
-ReleaseClassContents(
- Tcl_Interp *interp, /* The interpreter containing the class. */
- Object *oPtr) /* The object representing the class. */
-{
- int i, n;
- Class *clsPtr, **list;
- Object **insts;
-
- clsPtr = oPtr->classPtr;
- Tcl_Preserve(clsPtr);
-
- /*
- * Must empty list before processing the members of the list so that
- * things happen in the correct order even if something tries to play
- * fast-and-loose.
- */
-
- list = clsPtr->mixinSubs.list;
- n = clsPtr->mixinSubs.num;
- clsPtr->mixinSubs.list = NULL;
- clsPtr->mixinSubs.num = 0;
- clsPtr->mixinSubs.size = 0;
- for (i=0 ; i<n ; i++) {
- Tcl_Preserve(list[i]);
- }
- for (i=0 ; i<n ; i++) {
- if (!(list[i]->flags & OBJECT_DELETED) && interp != NULL) {
- Tcl_DeleteCommandFromToken(interp, list[i]->thisPtr->command);
- }
- Tcl_Release(list[i]);
- }
- if (list != NULL) {
- ckfree((char *) list);
- }
-
- list = clsPtr->subclasses.list;
- n = clsPtr->subclasses.num;
- clsPtr->subclasses.list = NULL;
- clsPtr->subclasses.num = 0;
- clsPtr->subclasses.size = 0;
- for (i=0 ; i<n ; i++) {
- Tcl_Preserve(list[i]);
- }
- for (i=0 ; i<n ; i++) {
- if (!(list[i]->flags & OBJECT_DELETED) && interp != NULL) {
- Tcl_DeleteCommandFromToken(interp, list[i]->thisPtr->command);
- }
- Tcl_Release(list[i]);
- }
- if (list != NULL) {
- ckfree((char *) list);
- }
-
- insts = clsPtr->instances.list;
- n = clsPtr->instances.num;
- clsPtr->instances.list = NULL;
- clsPtr->instances.num = 0;
- clsPtr->instances.size = 0;
- for (i=0 ; i<n ; i++) {
- Tcl_Preserve(insts[i]);
- }
- for (i=0 ; i<n ; i++) {
- if (!(insts[i]->flags & OBJECT_DELETED) && interp != NULL) {
- Tcl_DeleteCommandFromToken(interp, insts[i]->command);
- }
- Tcl_Release(insts[i]);
- }
- if (insts != NULL) {
- ckfree((char *) insts);
- }
-
- if (clsPtr->filters.num) {
- Tcl_Obj *filterObj;
-
- FOREACH(filterObj, clsPtr->filters) {
- TclDecrRefCount(filterObj);
- }
- ckfree((char *) clsPtr->filters.list);
- clsPtr->filters.num = 0;
- }
-
- if (clsPtr->metadataPtr != NULL) {
- FOREACH_HASH_DECLS;
- Tcl_ObjectMetadataType *metadataTypePtr;
- ClientData value;
-
- FOREACH_HASH(metadataTypePtr, value, clsPtr->metadataPtr) {
- metadataTypePtr->deleteProc(value);
- }
- Tcl_DeleteHashTable(clsPtr->metadataPtr);
- ckfree((char *) clsPtr->metadataPtr);
- clsPtr->metadataPtr = NULL;
- }
-}
-
-/*
- * ----------------------------------------------------------------------
- *
- * ObjectNamespaceDeleted --
- *
- * Callback when the object's namespace is deleted. Used to clean up the
- * data structures associated with the object. The complicated bit is
- * that this can sometimes happen before the object's command is deleted
- * (interpreter teardown is complex!)
- *
- * ----------------------------------------------------------------------
- */
-
-static void
-ObjectNamespaceDeleted(
- ClientData clientData) /* Pointer to the class whose namespace is
- * being deleted. */
-{
- Object *oPtr = clientData;
- FOREACH_HASH_DECLS;
- Class *clsPtr, *mixinPtr;
- CallContext *contextPtr;
- Method *mPtr;
- Tcl_Obj *filterObj;
- int i;
-
- /*
- * Instruct everyone to no longer use any allocated fields of the object.
- */
-
- if (!(oPtr->flags & OBJECT_DELETED)) {
- Tcl_Preserve(oPtr);
- if (oPtr->classPtr != NULL) {
- ReleaseClassContents(NULL, oPtr);
- }
- }
- oPtr->flags |= OBJECT_DELETED;
-
- /*
- * Splice the object out of its context. After this, we must *not* call
- * methods on the object.
- */
-
- if (!(oPtr->flags & ROOT_OBJECT)) {
- TclOORemoveFromInstances(oPtr, oPtr->selfCls);
- }
- FOREACH(mixinPtr, oPtr->mixins) {
- TclOORemoveFromInstances(oPtr, mixinPtr);
- }
- if (i) {
- ckfree((char *)oPtr->mixins.list);
- }
- FOREACH(filterObj, oPtr->filters) {
- TclDecrRefCount(filterObj);
- }
- if (i) {
- ckfree((char *)oPtr->filters.list);
- }
- FOREACH_HASH_VALUE(mPtr, &oPtr->methods) {
- TclOODeleteMethod(mPtr);
- }
- Tcl_DeleteHashTable(&oPtr->methods);
- FOREACH_HASH_VALUE(contextPtr, &oPtr->publicContextCache) {
- if (contextPtr) {
- TclOODeleteContext(contextPtr);
- }
- }
- Tcl_DeleteHashTable(&oPtr->publicContextCache);
- FOREACH_HASH_VALUE(contextPtr, &oPtr->privateContextCache) {
- if (contextPtr) {
- TclOODeleteContext(contextPtr);
- }
- }
- Tcl_DeleteHashTable(&oPtr->privateContextCache);
-
- if (oPtr->metadataPtr != NULL) {
- FOREACH_HASH_DECLS;
- Tcl_ObjectMetadataType *metadataTypePtr;
- ClientData value;
-
- FOREACH_HASH(metadataTypePtr, value, oPtr->metadataPtr) {
- metadataTypePtr->deleteProc(value);
- }
- Tcl_DeleteHashTable(oPtr->metadataPtr);
- ckfree((char *) oPtr->metadataPtr);
- oPtr->metadataPtr = NULL;
- }
-
- clsPtr = oPtr->classPtr;
- if (clsPtr != NULL && !(oPtr->flags & ROOT_OBJECT)) {
- Class *superPtr, *mixinPtr;
-
- clsPtr->flags |= OBJECT_DELETED;
- FOREACH(mixinPtr, clsPtr->mixins) {
- if (!(mixinPtr->flags & OBJECT_DELETED)) {
- TclOORemoveFromSubclasses(clsPtr, mixinPtr);
- }
- }
- if (i) {
- ckfree((char *) clsPtr->mixins.list);
- clsPtr->mixins.num = 0;
- }
- FOREACH(superPtr, clsPtr->superclasses) {
- if (!(superPtr->flags & OBJECT_DELETED)) {
- TclOORemoveFromSubclasses(clsPtr, superPtr);
- }
- }
- if (i) {
- ckfree((char *) clsPtr->superclasses.list);
- clsPtr->superclasses.num = 0;
- }
- if (clsPtr->subclasses.list) {
- ckfree((char *) clsPtr->subclasses.list);
- clsPtr->subclasses.num = 0;
- }
- if (clsPtr->instances.list) {
- ckfree((char *) clsPtr->instances.list);
- clsPtr->instances.num = 0;
- }
- if (clsPtr->mixinSubs.list) {
- ckfree((char *) clsPtr->mixinSubs.list);
- clsPtr->mixinSubs.num = 0;
- }
- if (clsPtr->classHierarchy.list) {
- ckfree((char *) clsPtr->classHierarchy.list);
- clsPtr->classHierarchy.num = 0;
- }
-
- FOREACH_HASH_VALUE(mPtr, &clsPtr->classMethods) {
- TclOODeleteMethod(mPtr);
- }
- Tcl_DeleteHashTable(&clsPtr->classMethods);
- TclOODeleteMethod(clsPtr->constructorPtr);
- TclOODeleteMethod(clsPtr->destructorPtr);
- Tcl_EventuallyFree(clsPtr, TCL_DYNAMIC);
- }
-
- /*
- * Delete the object structure itself.
- */
-
- if (!(oPtr->flags & OBJECT_DELETED)) {
- Tcl_EventuallyFree(oPtr, TCL_DYNAMIC);
- Tcl_Release(oPtr);
- } else {
- Tcl_EventuallyFree(oPtr, TCL_DYNAMIC);
- }
-}
-
-/*
- * ----------------------------------------------------------------------
- *
- * TclOORemoveFromInstances --
- *
- * Utility function to remove an object from the list of instances within
- * a class.
- *
- * ----------------------------------------------------------------------
- */
-
-void
-TclOORemoveFromInstances(
- Object *oPtr, /* The instance to remove. */
- Class *clsPtr) /* The class (possibly) containing the
- * reference to the instance. */
-{
- int i;
- Object *instPtr;
-
- FOREACH(instPtr, clsPtr->instances) {
- if (oPtr == instPtr) {
- goto removeInstance;
- }
- }
- return;
-
- removeInstance:
- clsPtr->instances.num--;
- if (i < clsPtr->instances.num) {
- clsPtr->instances.list[i] =
- clsPtr->instances.list[clsPtr->instances.num];
- }
- clsPtr->instances.list[clsPtr->instances.num] = NULL;
-}
-
-/*
- * ----------------------------------------------------------------------
- *
- * TclOOAddToInstances --
- *
- * Utility function to add an object to the list of instances within a
- * class.
- *
- * ----------------------------------------------------------------------
- */
-
-void
-TclOOAddToInstances(
- Object *oPtr, /* The instance to add. */
- Class *clsPtr) /* The class to add the instance to. It is
- * assumed that the class is not already
- * present as an instance in the class. */
-{
- if (clsPtr->instances.num >= clsPtr->instances.size) {
- clsPtr->instances.size += ALLOC_CHUNK;
- if (clsPtr->instances.size == ALLOC_CHUNK) {
- clsPtr->instances.list = (Object **)
- ckalloc(sizeof(Object *) * ALLOC_CHUNK);
- } else {
- clsPtr->instances.list = (Object **)
- ckrealloc((char *) clsPtr->instances.list,
- sizeof(Object *) * clsPtr->instances.size);
- }
- }
- clsPtr->instances.list[clsPtr->instances.num++] = oPtr;
-}
-
-/*
- * ----------------------------------------------------------------------
- *
- * TclOORemoveFromSubclasses --
- *
- * Utility function to remove a class from the list of subclasses within
- * another class.
- *
- * ----------------------------------------------------------------------
- */
-
-void
-TclOORemoveFromSubclasses(
- Class *subPtr, /* The subclass to remove. */
- Class *superPtr) /* The superclass to (possibly) remove the
- * subclass reference from. */
-{
- int i;
- Class *subclsPtr;
-
- FOREACH(subclsPtr, superPtr->subclasses) {
- if (subPtr == subclsPtr) {
- goto removeSubclass;
- }
- }
- return;
-
- removeSubclass:
- superPtr->subclasses.num--;
- if (i < superPtr->subclasses.num) {
- superPtr->subclasses.list[i] =
- superPtr->subclasses.list[superPtr->subclasses.num];
- }
- superPtr->subclasses.list[superPtr->subclasses.num] = NULL;
-}
-
-/*
- * ----------------------------------------------------------------------
- *
- * TclOOAddToSubclasses --
- *
- * Utility function to add a class to the list of subclasses within
- * another class.
- *
- * ----------------------------------------------------------------------
- */
-
-void
-TclOOAddToSubclasses(
- Class *subPtr, /* The subclass to add. */
- Class *superPtr) /* The superclass to add the subclass to. It
- * is assumed that the class is not already
- * present as a subclass in the superclass. */
-{
- if (superPtr->subclasses.num >= superPtr->subclasses.size) {
- superPtr->subclasses.size += ALLOC_CHUNK;
- if (superPtr->subclasses.size == ALLOC_CHUNK) {
- superPtr->subclasses.list = (Class **)
- ckalloc(sizeof(Class *) * ALLOC_CHUNK);
- } else {
- superPtr->subclasses.list = (Class **)
- ckrealloc((char *) superPtr->subclasses.list,
- sizeof(Class *) * superPtr->subclasses.size);
- }
- }
- superPtr->subclasses.list[superPtr->subclasses.num++] = subPtr;
-}
-
-/*
- * ----------------------------------------------------------------------
- *
- * TclOORemoveFromMixinSubs --
- *
- * Utility function to remove a class from the list of mixinSubs within
- * another class.
- *
- * ----------------------------------------------------------------------
- */
-
-void
-TclOORemoveFromMixinSubs(
- Class *subPtr, /* The subclass to remove. */
- Class *superPtr) /* The superclass to (possibly) remove the
- * subclass reference from. */
-{
- int i;
- Class *subclsPtr;
-
- FOREACH(subclsPtr, superPtr->mixinSubs) {
- if (subPtr == subclsPtr) {
- goto removeSubclass;
- }
- }
- return;
-
- removeSubclass:
- superPtr->mixinSubs.num--;
- if (i < superPtr->mixinSubs.num) {
- superPtr->mixinSubs.list[i] =
- superPtr->mixinSubs.list[superPtr->mixinSubs.num];
- }
- superPtr->mixinSubs.list[superPtr->mixinSubs.num] = NULL;
-}
-
-/*
- * ----------------------------------------------------------------------
- *
- * TclOOAddToMixinSubs --
- *
- * Utility function to add a class to the list of mixinSubs within
- * another class.
- *
- * ----------------------------------------------------------------------
- */
-
-void
-TclOOAddToMixinSubs(
- Class *subPtr, /* The subclass to add. */
- Class *superPtr) /* The superclass to add the subclass to. It
- * is assumed that the class is not already
- * present as a subclass in the superclass. */
-{
- if (superPtr->mixinSubs.num >= superPtr->mixinSubs.size) {
- superPtr->mixinSubs.size += ALLOC_CHUNK;
- if (superPtr->mixinSubs.size == ALLOC_CHUNK) {
- superPtr->mixinSubs.list = (Class **)
- ckalloc(sizeof(Class *) * ALLOC_CHUNK);
- } else {
- superPtr->mixinSubs.list = (Class **)
- ckrealloc((char *) superPtr->mixinSubs.list,
- sizeof(Class *) * superPtr->mixinSubs.size);
- }
- }
- superPtr->mixinSubs.list[superPtr->mixinSubs.num++] = subPtr;
-}
-
-/*
- * ----------------------------------------------------------------------
- *
- * AllocClass --
- *
- * Allocate a basic class. Does not splice the class object into its
- * class's instance list.
- *
- * ----------------------------------------------------------------------
- */
-
-static Class *
-AllocClass(
- Tcl_Interp *interp, /* Interpreter within which to allocate the
- * class. */
- Object *useThisObj) /* Object that is to act as the class
- * representation, or NULL if a new object
- * (with automatic name) is to be used. */
-{
- Class *clsPtr;
- Foundation *fPtr = ((Interp *) interp)->ooFoundation;
-
- clsPtr = (Class *) ckalloc(sizeof(Class));
- memset(clsPtr, 0, sizeof(Class));
- if (useThisObj == NULL) {
- clsPtr->thisPtr = AllocObject(interp, NULL);
- } else {
- clsPtr->thisPtr = useThisObj;
- }
- clsPtr->thisPtr->selfCls = fPtr->classCls;
- if (fPtr->classCls != NULL) {
- TclOOAddToInstances(clsPtr->thisPtr, fPtr->classCls);
- TclOOAddToSubclasses(clsPtr, fPtr->objectCls);
- }
- {
- Tcl_Namespace *path[2];
-
- path[0] = fPtr->helpersNs;
- path[1] = fPtr->ooNs;
- TclSetNsPath((Namespace *) clsPtr->thisPtr->namespacePtr, 2, path);
- }
- clsPtr->thisPtr->classPtr = clsPtr;
- clsPtr->flags = 0;
- clsPtr->superclasses.num = 1;
- clsPtr->superclasses.list = (Class **) ckalloc(sizeof(Class *));
- clsPtr->superclasses.list[0] = fPtr->objectCls;
- clsPtr->subclasses.num = 0;
- clsPtr->subclasses.list = NULL;
- clsPtr->subclasses.size = 0;
- clsPtr->instances.num = 0;
- clsPtr->instances.list = NULL;
- clsPtr->instances.size = 0;
- clsPtr->filters.list = NULL;
- clsPtr->filters.num = 0;
- clsPtr->mixins.list = NULL;
- clsPtr->mixins.num = 0;
- clsPtr->mixinSubs.list = NULL;
- clsPtr->mixinSubs.num = 0;
- clsPtr->mixinSubs.size = 0;
- clsPtr->classHierarchy.list = NULL;
- clsPtr->classHierarchy.num = 0;
- clsPtr->classHierarchyEpoch = fPtr->epoch-1;
- Tcl_InitObjHashTable(&clsPtr->classMethods);
- clsPtr->constructorPtr = NULL;
- clsPtr->destructorPtr = NULL;
- clsPtr->metadataPtr = NULL;
- return clsPtr;
-}
-
-/*
- * ----------------------------------------------------------------------
- *
- * Tcl_NewObjectInstance --
- *
- * Allocate a new instance of an object.
- *
- * ----------------------------------------------------------------------
- */
-
-Tcl_Object
-Tcl_NewObjectInstance(
- Tcl_Interp *interp, /* Interpreter context. */
- Tcl_Class cls, /* Class to create an instance of. */
- const char *name, /* Name of object to create, or NULL to ask
- * the code to pick its own unique name. */
- int objc, /* Number of arguments. Negative value means
- * do not call constructor. */
- Tcl_Obj *const *objv, /* Argument list. */
- int skip) /* Number of arguments to _not_ pass to the
- * constructor. */
-{
- Object *oPtr = AllocObject(interp, NULL);
- CallContext *contextPtr;
-
- oPtr->selfCls = (Class *) cls;
- TclOOAddToInstances(oPtr, (Class *) cls);
-
- if (name != NULL) {
- Tcl_Obj *cmdnameObj;
-
- TclNewObj(cmdnameObj);
- Tcl_GetCommandFullName(interp, oPtr->command, cmdnameObj);
- if (TclRenameCommand(interp, TclGetString(cmdnameObj),
- name) != TCL_OK) {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "can't create object \"", name,
- "\": command already exists with that name", NULL);
- TclDecrRefCount(cmdnameObj);
- Tcl_DeleteCommandFromToken(interp, oPtr->command);
- return NULL;
- }
- TclDecrRefCount(cmdnameObj);
- }
-
- /*
- * Check to see if we're really creating a class. If so, allocate the
- * class structure as well.
- */
-
- if (TclOOIsReachable((((Interp *) interp)->ooFoundation)->classCls,
- (Class *) cls)) {
- /*
- * Is a class, so attach a class structure. Note that the AllocClass
- * function splices the structure into the object, so we don't have
- * to.
- */
-
- AllocClass(interp, oPtr);
- oPtr->selfCls = (Class *) cls; // Repatch
- }
-
- if (objc >= 0) {
- contextPtr = TclOOGetCallContext(((Interp *)interp)->ooFoundation,
- oPtr, NULL, CONSTRUCTOR, NULL);
- if (contextPtr != NULL) {
- int result;
- Tcl_InterpState state;
-
- Tcl_Preserve(oPtr);
- state = Tcl_SaveInterpState(interp, TCL_OK);
- contextPtr->flags |= CONSTRUCTOR;
- contextPtr->skip = skip;
- result = TclOOInvokeContext(interp, contextPtr, objc, objv);
- TclOODeleteContext(contextPtr);
- Tcl_Release(oPtr);
- if (result != TCL_OK) {
- Tcl_DiscardInterpState(state);
- Tcl_DeleteCommandFromToken(interp, oPtr->command);
- return NULL;
- }
- (void) Tcl_RestoreInterpState(interp, state);
- }
- }
-
- return (Tcl_Object) oPtr;
-}
-
-/*
- * ----------------------------------------------------------------------
- *
- * Tcl_CopyObjectInstance --
- *
- * Creates a copy of an object. Does not copy the backing namespace,
- * since the correct way to do that (e.g., shallow/deep) depends on the
- * object/class's own policies.
- *
- * ----------------------------------------------------------------------
- */
-
-Tcl_Object
-Tcl_CopyObjectInstance(
- Tcl_Interp *interp,
- Tcl_Object sourceObject,
- const char *targetName)
-{
- Object *oPtr = (Object *) sourceObject, *o2Ptr;
- Interp *iPtr = (Interp *) interp;
- FOREACH_HASH_DECLS;
- Method *mPtr;
- Class *mixinPtr;
- Tcl_Obj *keyPtr, *filterObj;
- int i;
-
- /*
- * Sanity checks.
- */
-
- if (targetName == NULL && oPtr->classPtr != NULL) {
- Tcl_AppendResult(interp, "must supply a name when copying a class",
- NULL);
- return NULL;
- }
- if (oPtr->classPtr == iPtr->ooFoundation->classCls) {
- Tcl_AppendResult(interp, "may not clone the class of classes", NULL);
- return NULL;
- }
-
- /*
- * Build the instance. Note that this does not run any constructors.
- */
-
- o2Ptr = (Object *) Tcl_NewObjectInstance(interp,
- (Tcl_Class) oPtr->selfCls, targetName, -1, NULL, -1);
- if (o2Ptr == NULL) {
- return NULL;
- }
-
- /*
- * Copy the object-local methods to the new object.
- */
-
- FOREACH_HASH(keyPtr, mPtr, &oPtr->methods) {
- (void) CloneObjectMethod(interp, o2Ptr, mPtr, keyPtr);
- }
-
- /*
- * Copy the object's mixin references to the new object.
- */
-
- FOREACH(mixinPtr, o2Ptr->mixins) {
- if (mixinPtr != o2Ptr->selfCls) {
- TclOORemoveFromInstances(o2Ptr, mixinPtr);
- }
- }
- DUPLICATE(o2Ptr->mixins, oPtr->mixins, Class *);
- FOREACH(mixinPtr, o2Ptr->mixins) {
- if (mixinPtr != o2Ptr->selfCls) {
- TclOOAddToInstances(o2Ptr, mixinPtr);
- }
- }
-
- /*
- * Copy the object's filter list to the new object.
- */
-
- DUPLICATE(o2Ptr->filters, oPtr->filters, Tcl_Obj *);
- FOREACH(filterObj, o2Ptr->filters) {
- Tcl_IncrRefCount(filterObj);
- }
-
- /*
- * Copy the object's 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 | FILTER_HANDLING);
-
- /*
- * Copy the object's metadata.
- */
-
- if (oPtr->metadataPtr != NULL) {
- Tcl_ObjectMetadataType *metadataTypePtr;
- ClientData value, duplicate;
-
- FOREACH_HASH(metadataTypePtr, value, oPtr->metadataPtr) {
- if (metadataTypePtr->cloneProc == NULL) {
- continue;
- }
- duplicate = metadataTypePtr->cloneProc(value);
- if (duplicate != NULL) {
- Tcl_ObjectSetMetadata((Tcl_Object) o2Ptr, metadataTypePtr,
- duplicate);
- }
- }
- }
-
- /*
- * Copy the class, if present. Note that if there is a class present in
- * the source object, there must also be one in the copy.
- */
-
- if (oPtr->classPtr != NULL) {
- Class *clsPtr = oPtr->classPtr;
- Class *cls2Ptr = o2Ptr->classPtr;
- Class *superPtr;
-
- /*
- * Copy the class flags across.
- */
-
- cls2Ptr->flags = clsPtr->flags;
-
- /*
- * Ensure that the new class's superclass structure is the same as the
- * old class's.
- */
-
- FOREACH(superPtr, cls2Ptr->superclasses) {
- TclOORemoveFromSubclasses(cls2Ptr, superPtr);
- }
- if (cls2Ptr->superclasses.num) {
- cls2Ptr->superclasses.list = (Class **)
- ckrealloc((char *) cls2Ptr->superclasses.list,
- sizeof(Class *) * clsPtr->superclasses.num);
- } else {
- cls2Ptr->superclasses.list = (Class **)
- ckalloc(sizeof(Class *) * clsPtr->superclasses.num);
- }
- memcpy(cls2Ptr->superclasses.list, clsPtr->superclasses.list,
- sizeof(Class *) * clsPtr->superclasses.num);
- cls2Ptr->superclasses.num = clsPtr->superclasses.num;
- FOREACH(superPtr, cls2Ptr->superclasses) {
- TclOOAddToSubclasses(cls2Ptr, superPtr);
- }
-
- /*
- * Duplicate the source class's filters.
- */
-
- DUPLICATE(cls2Ptr->filters, clsPtr->filters, Tcl_Obj *);
- FOREACH(filterObj, cls2Ptr->filters) {
- Tcl_IncrRefCount(filterObj);
- }
-
- /*
- * Duplicate the source class's mixins (which cannot be circular
- * references to the duplicate).
- */
-
- FOREACH(mixinPtr, cls2Ptr->mixins) {
- TclOORemoveFromMixinSubs(cls2Ptr, mixinPtr);
- }
- if (cls2Ptr->mixins.num != 0) {
- ckfree((char *) clsPtr->mixins.list);
- }
- DUPLICATE(cls2Ptr->mixins, clsPtr->mixins, Class *);
- FOREACH(mixinPtr, cls2Ptr->mixins) {
- TclOOAddToMixinSubs(cls2Ptr, mixinPtr);
- }
-
- /*
- * Duplicate the source class's methods, constructor and destructor.
- */
-
- FOREACH_HASH(keyPtr, mPtr, &clsPtr->classMethods) {
- (void) CloneClassMethod(interp, cls2Ptr, mPtr, keyPtr);
- }
- if (clsPtr->constructorPtr) {
- cls2Ptr->constructorPtr = CloneClassMethod(interp, cls2Ptr,
- clsPtr->constructorPtr, NULL);
- }
- if (clsPtr->destructorPtr) {
- cls2Ptr->destructorPtr = CloneClassMethod(interp, cls2Ptr,
- clsPtr->destructorPtr, NULL);
- }
-
- /*
- * Duplicate the class's metadata.
- */
-
- if (clsPtr->metadataPtr != NULL) {
- Tcl_ObjectMetadataType *metadataTypePtr;
- ClientData value, duplicate;
-
- FOREACH_HASH(metadataTypePtr, value, clsPtr->metadataPtr) {
- if (metadataTypePtr->cloneProc == NULL) {
- continue;
- }
- duplicate = metadataTypePtr->cloneProc(value);
- if (duplicate != NULL) {
- Tcl_ClassSetMetadata((Tcl_Class) cls2Ptr, metadataTypePtr,
- duplicate);
- }
- }
- }
- }
-
- return (Tcl_Object) o2Ptr;
-}
-
-/*
- * ----------------------------------------------------------------------
- *
- * CloneObjectMethod, CloneClassMethod --
- *
- * Helper functions used for cloning methods. They work identically to
- * each other, except for the difference between them in how they
- * register the cloned method on a successful clone.
- *
- * ----------------------------------------------------------------------
- */
-
-static Method *
-CloneObjectMethod(
- Tcl_Interp *interp,
- Object *oPtr,
- Method *mPtr,
- Tcl_Obj *namePtr)
-{
- if (mPtr->typePtr == NULL) {
- return (Method *) Tcl_NewMethod(interp, (Tcl_Object) oPtr, namePtr,
- mPtr->flags & PUBLIC_METHOD, NULL, NULL);
- } else if (mPtr->typePtr->cloneProc) {
- ClientData newClientData;
-
- if (mPtr->typePtr->cloneProc(mPtr->clientData,
- &newClientData) != TCL_OK) {
- return NULL;
- }
- return (Method *) Tcl_NewMethod(interp, (Tcl_Object) oPtr, namePtr,
- mPtr->flags & PUBLIC_METHOD, mPtr->typePtr, newClientData);
- } else {
- return (Method *) Tcl_NewMethod(interp, (Tcl_Object) oPtr, namePtr,
- mPtr->flags & PUBLIC_METHOD, mPtr->typePtr, mPtr->clientData);
- }
-}
-
-static Method *
-CloneClassMethod(
- Tcl_Interp *interp,
- Class *clsPtr,
- Method *mPtr,
- Tcl_Obj *namePtr)
-{
- if (mPtr->typePtr == NULL) {
- return (Method *) Tcl_NewClassMethod(interp, (Tcl_Class) clsPtr,
- namePtr, mPtr->flags & PUBLIC_METHOD, NULL, NULL);
- } else if (mPtr->typePtr->cloneProc) {
- ClientData newClientData;
-
- if (mPtr->typePtr->cloneProc(mPtr->clientData,
- &newClientData) != TCL_OK) {
- return NULL;
- }
- return (Method *) Tcl_NewClassMethod(interp, (Tcl_Class) clsPtr,
- namePtr, mPtr->flags & PUBLIC_METHOD, mPtr->typePtr,
- newClientData);
- } else {
- return (Method *) Tcl_NewClassMethod(interp, (Tcl_Class) clsPtr,
- namePtr, mPtr->flags & PUBLIC_METHOD, mPtr->typePtr,
- mPtr->clientData);
- }
-}
-
-/*
- * ----------------------------------------------------------------------
- *
- * Tcl_NewMethod --
- *
- * Attach a method to an object.
- *
- * ----------------------------------------------------------------------
- */
-
-Tcl_Method
-Tcl_NewMethod(
- Tcl_Interp *interp, /* Unused? */
- Tcl_Object object, /* The object that has the method attached to
- * it. */
- Tcl_Obj *nameObj, /* The name of the method. May be NULL; if so,
- * up to caller to manage storage (e.g., when
- * it is a constructor or destructor). */
- int isPublic, /* Whether this is a public method. */
- const Tcl_MethodType *typePtr,
- /* The type of method this is, which defines
- * how to invoke, delete and clone the
- * method. */
- ClientData clientData) /* Some data associated with the particular
- * method to be created. */
-{
- register Object *oPtr = (Object *) object;
- register Method *mPtr;
- Tcl_HashEntry *hPtr;
- int isNew;
-
- if (nameObj == NULL) {
- mPtr = (Method *) ckalloc(sizeof(Method));
- mPtr->namePtr = NULL;
- goto populate;
- }
- hPtr = Tcl_CreateHashEntry(&oPtr->methods, (char *) nameObj, &isNew);
- if (isNew) {
- mPtr = (Method *) ckalloc(sizeof(Method));
- mPtr->namePtr = nameObj;
- Tcl_IncrRefCount(nameObj);
- Tcl_SetHashValue(hPtr, mPtr);
- } else {
- mPtr = Tcl_GetHashValue(hPtr);
- if (mPtr->typePtr != NULL && mPtr->typePtr->deleteProc != NULL) {
- mPtr->typePtr->deleteProc(mPtr->clientData);
- }
- }
-
- populate:
- mPtr->typePtr = typePtr;
- mPtr->clientData = clientData;
- mPtr->flags = 0;
- mPtr->declaringObjectPtr = oPtr;
- mPtr->declaringClassPtr = NULL;
- if (isPublic) {
- mPtr->flags |= PUBLIC_METHOD;
- }
- oPtr->epoch++;
- return (Tcl_Method) mPtr;
-}
-
-/*
- * ----------------------------------------------------------------------
- *
- * Tcl_NewClassMethod --
- *
- * Attach a method to a class.
- *
- * ----------------------------------------------------------------------
- */
-
-Tcl_Method
-Tcl_NewClassMethod(
- Tcl_Interp *interp, /* The interpreter containing the class. */
- Tcl_Class cls, /* The class to attach the method to. */
- Tcl_Obj *nameObj, /* The name of the object. May be NULL (e.g.,
- * for constructors or destructors); if so, up
- * to caller to manage storage. */
- int isPublic, /* Whether this is a public method. */
- const Tcl_MethodType *typePtr,
- /* The type of method this is, which defines
- * how to invoke, delete and clone the
- * method. */
- ClientData clientData) /* Some data associated with the particular
- * method to be created. */
-{
- register Class *clsPtr = (Class *) cls;
- register Method *mPtr;
- Tcl_HashEntry *hPtr;
- int isNew;
-
- if (nameObj == NULL) {
- mPtr = (Method *) ckalloc(sizeof(Method));
- mPtr->namePtr = NULL;
- goto populate;
- }
- hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, (char *)nameObj,&isNew);
- if (isNew) {
- mPtr = (Method *) ckalloc(sizeof(Method));
- mPtr->namePtr = nameObj;
- Tcl_IncrRefCount(nameObj);
- Tcl_SetHashValue(hPtr, mPtr);
- } else {
- mPtr = Tcl_GetHashValue(hPtr);
- if (mPtr->typePtr != NULL && mPtr->typePtr->deleteProc != NULL) {
- mPtr->typePtr->deleteProc(mPtr->clientData);
- }
- }
-
- populate:
- ((Interp *) interp)->ooFoundation->epoch++;
- mPtr->typePtr = typePtr;
- mPtr->clientData = clientData;
- mPtr->flags = 0;
- mPtr->declaringObjectPtr = NULL;
- mPtr->declaringClassPtr = clsPtr;
- if (isPublic) {
- mPtr->flags |= PUBLIC_METHOD;
- }
-
- return (Tcl_Method) mPtr;
-}
-
-/*
- * ----------------------------------------------------------------------
- *
- * DeleteMethodStruct --
- *
- * Function used when deleting a method. Always called indirectly via
- * Tcl_EventuallyFree().
- *
- * ----------------------------------------------------------------------
- */
-
-static void
-DeleteMethodStruct(
- char *buffer)
-{
- Method *mPtr = (Method *) buffer;
-
- if (mPtr->typePtr != NULL && mPtr->typePtr->deleteProc != NULL) {
- mPtr->typePtr->deleteProc(mPtr->clientData);
- }
- if (mPtr->namePtr != NULL) {
- TclDecrRefCount(mPtr->namePtr);
- }
-
- ckfree(buffer);
-}
-
-/*
- * ----------------------------------------------------------------------
- *
- * TclOODeleteMethod --
- *
- * How to delete a method.
- *
- * ----------------------------------------------------------------------
- */
-
-void
-TclOODeleteMethod(
- Method *mPtr)
-{
- if (mPtr != NULL) {
- Tcl_EventuallyFree(mPtr, DeleteMethodStruct);
- }
-}
-
-/*
- * ----------------------------------------------------------------------
- *
- * DeclareClassMethod --
- *
- * Helper that makes it cleaner to create very simple methods during
- * basic system initialization. Not suitable for general use.
- *
- * ----------------------------------------------------------------------
- */
-
-static void
-DeclareClassMethod(
- Tcl_Interp *interp,
- Class *clsPtr, /* Class to attach the method to. */
- const char *name, /* Name of the method. */
- int isPublic, /* Whether the method is public. */
- Tcl_MethodCallProc callPtr)
- /* Method implementation function. */
-{
- Tcl_Obj *namePtr;
-
- TclNewStringObj(namePtr, name, strlen(name));
- Tcl_IncrRefCount(namePtr);
- Tcl_NewClassMethod(interp, (Tcl_Class) clsPtr, namePtr, isPublic,
- &coreMethodType, callPtr);
- TclDecrRefCount(namePtr);
-}
-
-/*
- * ----------------------------------------------------------------------
- *
- * SimpleInvoke --
- *
- * How to invoke a simple method.
- *
- * ----------------------------------------------------------------------
- */
-
-static int
-SimpleInvoke(
- ClientData clientData, /* Pointer to function that implements the
- * method. */
- Tcl_Interp *interp,
- Tcl_ObjectContext context, /* The method calling context. */
- int objc, /* Number of arguments. */
- Tcl_Obj *const *objv) /* Arguments as actually seen. */
-{
- Tcl_MethodCallProc callPtr = clientData;
-
- return (*callPtr)(NULL, interp, context, objc, objv);
-}
-
-/*
- * ----------------------------------------------------------------------
- *
- * TclOONewProcMethod --
- *
- * Create a new procedure-like method for an object.
- *
- * ----------------------------------------------------------------------
- */
-
-Method *
-TclOONewProcMethod(
- Tcl_Interp *interp, /* The interpreter containing the object. */
- Object *oPtr, /* The object to modify. */
- int isPublic, /* Whether this is a public method. */
- Tcl_Obj *nameObj, /* The name of the method, which must not be
- * NULL. */
- Tcl_Obj *argsObj, /* The formal argument list for the method,
- * which must not be NULL. */
- Tcl_Obj *bodyObj) /* The body of the method, which must not be
- * NULL. */
-{
- int argsc;
- Tcl_Obj **argsv;
- register ProcedureMethod *pmPtr;
- const char *procName;
-
- if (Tcl_ListObjGetElements(interp, argsObj, &argsc, &argsv) != TCL_OK) {
- return NULL;
- }
- pmPtr = (ProcedureMethod *) ckalloc(sizeof(ProcedureMethod));
- procName = TclGetString(nameObj);
- if (TclCreateProc(interp, NULL, procName, argsObj, bodyObj,
- &pmPtr->procPtr) != TCL_OK) {
- ckfree((char *) pmPtr);
- return NULL;
- }
- return (Method *) Tcl_NewMethod(interp, (Tcl_Object) oPtr, nameObj,
- isPublic, &procMethodType, pmPtr);
-}
-
-/*
- * ----------------------------------------------------------------------
- *
- * TclOONewProcClassMethod --
- *
- * Create a new procedure-like method for a class.
- *
- * ----------------------------------------------------------------------
- */
-
-Method *
-TclOONewProcClassMethod(
- Tcl_Interp *interp, /* The interpreter containing the class. */
- Class *clsPtr, /* The class to modify. */
- int isPublic, /* Whether this is a public method. */
- Tcl_Obj *nameObj, /* The name of the method, which may be NULL;
- * if so, up to caller to manage storage
- * (e.g., because it is a constructor or
- * destructor). */
- Tcl_Obj *argsObj, /* The formal argument list for the method,
- * which may be NULL; if so, it is equivalent
- * to an empty list. */
- Tcl_Obj *bodyObj) /* The body of the method, which must not be
- * NULL. */
-{
- int argsLen; /* -1 => delete argsObj before exit */
- register ProcedureMethod *pmPtr;
- const char *procName;
-
- if (argsObj == NULL) {
- argsLen = -1;
- TclNewObj(argsObj);
- Tcl_IncrRefCount(argsObj);
- procName = "<destructor>";
- } else if (Tcl_ListObjLength(interp, argsObj, &argsLen) != TCL_OK) {
- return NULL;
- } else {
- procName = (nameObj==NULL ? "<constructor>" : TclGetString(nameObj));
- }
- pmPtr = (ProcedureMethod *) ckalloc(sizeof(ProcedureMethod));
- if (TclCreateProc(interp, NULL, procName, argsObj, bodyObj,
- &pmPtr->procPtr) != TCL_OK) {
- if (argsLen == -1) {
- TclDecrRefCount(argsObj);
- }
- ckfree((char *) pmPtr);
- return NULL;
- }
- if (argsLen == -1) {
- TclDecrRefCount(argsObj);
- }
- return (Method *) Tcl_NewClassMethod(interp, (Tcl_Class) clsPtr, nameObj,
- isPublic, &procMethodType, pmPtr);
-}
-
-/*
- * ----------------------------------------------------------------------
- *
- * InvokeProcedureMethod --
- *
- * How to invoke a procedure-like method.
- *
- * ----------------------------------------------------------------------
- */
-
-static int
-InvokeProcedureMethod(
- ClientData clientData, /* Pointer to some per-method context. */
- Tcl_Interp *interp,
- Tcl_ObjectContext context, /* The method calling context. */
- int objc, /* Number of arguments. */
- Tcl_Obj *const *objv) /* Arguments as actually seen. */
-{
- CallContext *contextPtr = (CallContext *) context;
- ProcedureMethod *pmPtr = (ProcedureMethod *) clientData;
- int result, flags = FRAME_IS_METHOD, skip = contextPtr->skip;
- CallFrame *framePtr, **framePtrPtr;
- Object *oPtr = contextPtr->oPtr;
- Command cmd;
- const char *namePtr;
- Tcl_Obj *nameObj;
-
- cmd.nsPtr = (Namespace *) oPtr->namespacePtr;
- pmPtr->procPtr->cmdPtr = &cmd;
- if (contextPtr->flags & CONSTRUCTOR) {
- namePtr = "<constructor>";
- flags |= FRAME_IS_CONSTRUCTOR;
- nameObj = Tcl_NewStringObj("<constructor>", -1);
- Tcl_IncrRefCount(nameObj);
- } else if (contextPtr->flags & DESTRUCTOR) {
- namePtr = "<destructor>";
- flags |= FRAME_IS_DESTRUCTOR;
- nameObj = Tcl_NewStringObj("<destructor>", -1);
- Tcl_IncrRefCount(nameObj);
- } else {
- nameObj = objv[contextPtr->skip-1];
- namePtr = TclGetString(nameObj);
- }
- result = TclProcCompileProc(interp, pmPtr->procPtr,
- pmPtr->procPtr->bodyPtr, (Namespace *) oPtr->namespacePtr,
- "body of method", namePtr);
- if (result != TCL_OK) {
- return result;
- }
-
- if (contextPtr->callChain[contextPtr->index].isFilter) {
- flags |= FRAME_IS_FILTER;
- }
- framePtrPtr = &framePtr;
- result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr,
- oPtr->namespacePtr, flags);
- if (result != TCL_OK) {
- return result;
- }
- framePtr->ooContextPtr = contextPtr;
- framePtr->objc = objc;
- framePtr->objv = objv; /* ref counts for args are incremented below */
- framePtr->procPtr = pmPtr->procPtr;
-
- if (contextPtr->flags & OO_UNKNOWN_METHOD) {
- skip--;
- }
- result = TclObjInterpProcCore(interp, framePtr, nameObj, skip);
- if (contextPtr->flags & (CONSTRUCTOR | DESTRUCTOR)) {
- TclDecrRefCount(nameObj);
- }
- return result;
-}
-
-/*
- * ----------------------------------------------------------------------
- *
- * DeleteProcedureMethod, CloneProcedureMethod --
- *
- * How to delete and clone procedure-like methods.
- *
- * ----------------------------------------------------------------------
- */
-
-static void
-DeleteProcedureMethod(
- ClientData clientData)
-{
- register ProcedureMethod *pmPtr = (ProcedureMethod *) clientData;
-
- TclProcDeleteProc(pmPtr->procPtr);
- ckfree((char *) pmPtr);
-}
-
-static int
-CloneProcedureMethod(
- ClientData clientData,
- ClientData *newClientData)
-{
- ProcedureMethod *pmPtr = (ProcedureMethod *) clientData;
- ProcedureMethod *pm2Ptr = (ProcedureMethod *)
- ckalloc(sizeof(ProcedureMethod));
-
- pm2Ptr->procPtr = pmPtr->procPtr;
- pm2Ptr->procPtr->refCount++;
- *newClientData = pm2Ptr;
- return TCL_OK;
-}
-
-/*
- * ----------------------------------------------------------------------
- *
- * TclOONewForwardMethod --
- *
- * Create a forwarded method for an object.
- *
- * ----------------------------------------------------------------------
- */
-
-Method *
-TclOONewForwardMethod(
- Tcl_Interp *interp, /* Interpreter for error reporting. */
- Object *oPtr, /* The object to attach the method to. */
- int isPublic, /* Whether the method is public or not. */
- Tcl_Obj *nameObj, /* The name of the method. */
- Tcl_Obj *prefixObj) /* List of arguments that form the command
- * prefix to forward to. */
-{
- int prefixLen;
- register ForwardMethod *fmPtr;
-
- if (Tcl_ListObjLength(interp, prefixObj, &prefixLen) != TCL_OK) {
- return NULL;
- }
- if (prefixLen < 1) {
- Tcl_AppendResult(interp, "method forward prefix must be non-empty",
- NULL);
- return NULL;
- }
-
- fmPtr = (ForwardMethod *) ckalloc(sizeof(ForwardMethod));
- fmPtr->prefixObj = prefixObj;
- Tcl_IncrRefCount(prefixObj);
- return (Method *) Tcl_NewMethod(interp, (Tcl_Object) oPtr, nameObj,
- isPublic, &fwdMethodType, fmPtr);
-}
-
-/*
- * ----------------------------------------------------------------------
- *
- * TclOONewForwardClassMethod --
- *
- * Create a new forwarded method for a class.
- *
- * ----------------------------------------------------------------------
- */
-
-Method *
-TclOONewForwardClassMethod(
- Tcl_Interp *interp, /* Interpreter for error reporting. */
- Class *clsPtr, /* The class to attach the method to. */
- int isPublic, /* Whether the method is public or not. */
- Tcl_Obj *nameObj, /* The name of the method. */
- Tcl_Obj *prefixObj) /* List of arguments that form the command
- * prefix to forward to. */
-{
- int prefixLen;
- register ForwardMethod *fmPtr;
-
- if (Tcl_ListObjLength(interp, prefixObj, &prefixLen) != TCL_OK) {
- return NULL;
- }
- if (prefixLen < 1) {
- Tcl_AppendResult(interp, "method forward prefix must be non-empty",
- NULL);
- return NULL;
- }
-
- fmPtr = (ForwardMethod *) ckalloc(sizeof(ForwardMethod));
- fmPtr->prefixObj = prefixObj;
- Tcl_IncrRefCount(prefixObj);
- return (Method *) Tcl_NewClassMethod(interp, (Tcl_Class) clsPtr, nameObj,
- isPublic, &fwdMethodType, fmPtr);
-}
-
-/*
- * ----------------------------------------------------------------------
- *
- * InvokeForwardMethod --
- *
- * How to invoke a forwarded method. Works by doing some ensemble-like
- * command rearranging and then invokes some other Tcl command.
- *
- * ----------------------------------------------------------------------
- */
-
-static int
-InvokeForwardMethod(
- ClientData clientData, /* Pointer to some per-method context. */
- Tcl_Interp *interp,
- Tcl_ObjectContext context, /* The method calling context. */
- int objc, /* Number of arguments. */
- Tcl_Obj *const *objv) /* Arguments as actually seen. */
-{
- CallContext *contextPtr = (CallContext *) context;
- ForwardMethod *fmPtr = (ForwardMethod *) clientData;
- Tcl_Obj **argObjs, **prefixObjs;
- int numPrefixes, result, len;
-
- /*
- * Build the real list of arguments to use. Note that we know that the
- * prefixObj field of the ForwardMethod structure holds a reference to a
- * non-empty list, so there's a whole class of failures ("not a list") we
- * can ignore here.
- */
-
- Tcl_ListObjGetElements(NULL, fmPtr->prefixObj, &numPrefixes, &prefixObjs);
- argObjs = InitEnsembleRewrite(interp, objc, objv, contextPtr->skip,
- numPrefixes, prefixObjs, &len);
-
- result = Tcl_EvalObjv(interp, len, argObjs, TCL_EVAL_INVOKE);
- ckfree((char *) argObjs);
- return result;
-}
-
-/*
- * ----------------------------------------------------------------------
- *
- * DeleteForwardMethod, CloneForwardMethod --
- *
- * How to delete and clone forwarded methods.
- *
- * ----------------------------------------------------------------------
- */
-
-static void
-DeleteForwardMethod(
- ClientData clientData)
-{
- ForwardMethod *fmPtr = (ForwardMethod *) clientData;
-
- TclDecrRefCount(fmPtr->prefixObj);
- ckfree((char *) fmPtr);
-}
-
-static int
-CloneForwardMethod(
- ClientData clientData,
- ClientData *newClientData)
-{
- ForwardMethod *fmPtr = (ForwardMethod *) clientData;
- ForwardMethod *fm2Ptr = (ForwardMethod *) ckalloc(sizeof(ForwardMethod));
-
- fm2Ptr->prefixObj = fmPtr->prefixObj;
- Tcl_IncrRefCount(fm2Ptr->prefixObj);
- *newClientData = fm2Ptr;
- return TCL_OK;
-}
-
-/*
- * ----------------------------------------------------------------------
- *
- * Tcl_ClassGetMetadata, Tcl_ClassSetMetadata, Tcl_ObjectGetMetadata,
- * Tcl_ObjectSetMetadata --
- *
- * Metadata management API. The metadata system allows code in extensions
- * to attach arbitrary non-NULL pointers to objects and classes without
- * the different things that might be interested being able to interfere
- * with each other. Apart from non-NULL-ness, these routines attach no
- * interpretation to the meaning of the metadata pointers.
- *
- * The Tcl_*GetMetadata routines get the metadata pointer attached that
- * has been related with a particular type, or NULL if no metadata
- * associated with the given type has been attached.
- *
- * The Tcl_*SetMetadata routines set or delete the metadata pointer that
- * is related to a particular type. The value associated with the type is
- * deleted (if present; no-op otherwise) if the value is NULL, and
- * attached (replacing the previous value, which is deleted if present)
- * otherwise. This means it is impossible to attach a NULL value for any
- * metadata type.
- *
- * ----------------------------------------------------------------------
- */
-
-ClientData
-Tcl_ClassGetMetadata(
- Tcl_Class clazz,
- const Tcl_ObjectMetadataType *typePtr)
-{
- Class *clsPtr = (Class *) clazz;
- Tcl_HashEntry *hPtr;
-
- /*
- * If there's no metadata store attached, the type in question has
- * definitely not been attached either!
- */
-
- if (clsPtr->metadataPtr == NULL) {
- return NULL;
- }
-
- /*
- * There is a metadata store, so look in it for the given type.
- */
-
- hPtr = Tcl_FindHashEntry(clsPtr->metadataPtr, (char *) typePtr);
-
- /*
- * Return the metadata value if we found it, otherwise NULL.
- */
-
- if (hPtr == NULL) {
- return NULL;
- } else {
- return Tcl_GetHashValue(hPtr);
- }
-}
-
-void
-Tcl_ClassSetMetadata(
- Tcl_Class clazz,
- const Tcl_ObjectMetadataType *typePtr,
- ClientData metadata)
-{
- Class *clsPtr = (Class *) clazz;
- Tcl_HashEntry *hPtr;
- int isNew;
-
- /*
- * Attach the metadata store if not done already.
- */
-
- if (clsPtr->metadataPtr == NULL) {
- if (metadata == NULL) {
- return;
- }
- clsPtr->metadataPtr = (Tcl_HashTable*) ckalloc(sizeof(Tcl_HashTable));
- Tcl_InitHashTable(clsPtr->metadataPtr, TCL_ONE_WORD_KEYS);
- }
-
- /*
- * If the metadata is NULL, we're deleting the metadata for the type.
- */
-
- if (metadata == NULL) {
- hPtr = Tcl_FindHashEntry(clsPtr->metadataPtr, (char *) typePtr);
- if (hPtr != NULL) {
- Tcl_DeleteHashEntry(hPtr);
- }
- return;
- }
-
- /*
- * Otherwise we're attaching the metadata. Note that if there was already
- * some metadata attached of this type, we delete that first.
- */
-
- hPtr = Tcl_CreateHashEntry(clsPtr->metadataPtr, (char *) typePtr, &isNew);
- if (!isNew) {
- typePtr->deleteProc(Tcl_GetHashValue(hPtr));
- }
- Tcl_SetHashValue(hPtr, metadata);
-}
-
-ClientData
-Tcl_ObjectGetMetadata(
- Tcl_Object object,
- const Tcl_ObjectMetadataType *typePtr)
-{
- Object *oPtr = (Object *) object;
- Tcl_HashEntry *hPtr;
-
- /*
- * If there's no metadata store attached, the type in question has
- * definitely not been attached either!
- */
-
- if (oPtr->metadataPtr == NULL) {
- return NULL;
- }
-
- /*
- * There is a metadata store, so look in it for the given type.
- */
-
- hPtr = Tcl_FindHashEntry(oPtr->metadataPtr, (char *) typePtr);
-
- /*
- * Return the metadata value if we found it, otherwise NULL.
- */
-
- if (hPtr == NULL) {
- return NULL;
- } else {
- return Tcl_GetHashValue(hPtr);
- }
-}
-
-void
-Tcl_ObjectSetMetadata(
- Tcl_Object object,
- const Tcl_ObjectMetadataType *typePtr,
- ClientData metadata)
-{
- Object *oPtr = (Object *) object;
- Tcl_HashEntry *hPtr;
- int isNew;
-
- /*
- * Attach the metadata store if not done already.
- */
-
- if (oPtr->metadataPtr == NULL) {
- if (metadata == NULL) {
- return;
- }
- oPtr->metadataPtr = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
- Tcl_InitHashTable(oPtr->metadataPtr, TCL_ONE_WORD_KEYS);
- }
-
- /*
- * If the metadata is NULL, we're deleting the metadata for the type.
- */
-
- if (metadata == NULL) {
- hPtr = Tcl_FindHashEntry(oPtr->metadataPtr, (char *) typePtr);
- if (hPtr != NULL) {
- Tcl_DeleteHashEntry(hPtr);
- }
- return;
- }
-
- /*
- * Otherwise we're attaching the metadata. Note that if there was already
- * some metadata attached of this type, we delete that first.
- */
-
- hPtr = Tcl_CreateHashEntry(oPtr->metadataPtr, (char *) typePtr, &isNew);
- if (!isNew) {
- typePtr->deleteProc(Tcl_GetHashValue(hPtr));
- }
- Tcl_SetHashValue(hPtr, metadata);
-}
-
-/*
- * ----------------------------------------------------------------------
- *
- * PublicObjectCmd, PrivateObjectCmd, ObjectCmd --
- *
- * Main entry point for object invokations. The Public* and Private*
- * wrapper functions are just thin wrappers round the main ObjectCmd
- * function that does call chain creation, management and invokation.
- *
- * ----------------------------------------------------------------------
- */
-
-static int
-PublicObjectCmd(
- ClientData clientData,
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const *objv)
-{
- return ObjectCmd(clientData, interp, objc, objv, 1,
- &((Object *)clientData)->publicContextCache);
-}
-
-static int
-PrivateObjectCmd(
- ClientData clientData,
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const *objv)
-{
- return ObjectCmd(clientData, interp, objc, objv, 0,
- &((Object *)clientData)->privateContextCache);
-}
-
-static int
-ObjectCmd(
- Object *oPtr, /* The object being invoked. */
- Tcl_Interp *interp, /* The interpreter containing the object. */
- int objc, /* How many arguments are being passed in. */
- Tcl_Obj *const *objv, /* The array of arguments. */
- int publicOnly, /* Whether this is an invokation through the
- * public or the private command interface. */
- Tcl_HashTable *cachePtr) /* What call chain cache to use. */
-{
- Interp *iPtr = (Interp *) interp;
- CallContext *contextPtr;
- int result;
-
- if (objc < 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "method ?arg ...?");
- return TCL_ERROR;
- }
-
- contextPtr = TclOOGetCallContext(iPtr->ooFoundation, oPtr, objv[1],
- (publicOnly ? PUBLIC_METHOD :0) | (oPtr->flags & FILTER_HANDLING),
- cachePtr);
- if (contextPtr == NULL) {
- Tcl_AppendResult(interp, "impossible to invoke method \"",
- TclGetString(objv[1]),
- "\": no defined method or unknown method", NULL);
- return TCL_ERROR;
- }
-
- Tcl_Preserve(oPtr);
- result = TclOOInvokeContext(interp, contextPtr, objc, objv);
- if (!(contextPtr->flags & OO_UNKNOWN_METHOD)
- && !(oPtr->flags & OBJECT_DELETED)) {
- Tcl_HashEntry *hPtr;
-
- hPtr = Tcl_FindHashEntry(cachePtr, (char *) objv[1]);
- if (hPtr != NULL && Tcl_GetHashValue(hPtr) == NULL) {
- Tcl_SetHashValue(hPtr, contextPtr);
- } else {
- TclOODeleteContext(contextPtr);
- }
- } else {
- TclOODeleteContext(contextPtr);
- }
- Tcl_Release(oPtr);
-
- return result;
-}
-
-/*
- * ----------------------------------------------------------------------
- *
- * ClassCreate --
- *
- * Implementation for oo::class->create method.
- *
- * ----------------------------------------------------------------------
- */
-
-static int
-ClassCreate(
- ClientData clientData, /* Ignored. */
- Tcl_Interp *interp, /* Interpreter in which to create the object;
- * also used for error reporting. */
- Tcl_ObjectContext context, /* The object/call context. */
- int objc, /* Number of arguments. */
- Tcl_Obj *const *objv) /* The actual arguments. */
-{
- Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
- Tcl_Object newObject;
- const char *objName;
- int len;
-
- /*
- * Sanity check; should not be possible to invoke this method on a
- * non-class.
- */
-
- if (oPtr->classPtr == NULL) {
- Tcl_Obj *cmdnameObj;
-
- TclNewObj(cmdnameObj);
- Tcl_GetCommandFullName(interp, oPtr->command, cmdnameObj);
- Tcl_AppendResult(interp, "object \"", TclGetString(cmdnameObj),
- "\" is not a class", NULL);
- TclDecrRefCount(cmdnameObj);
- return TCL_ERROR;
- }
-
- /*
- * Check we have the right number of (sensible) arguments.
- */
-
- if (objc - Tcl_ObjectContextSkippedArgs(context) < 1) {
- Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
- "objectName ?arg ...?");
- return TCL_ERROR;
- }
- objName = Tcl_GetStringFromObj(
- objv[Tcl_ObjectContextSkippedArgs(context)], &len);
- if (len == 0) {
- Tcl_AppendResult(interp, "object name must not be empty", NULL);
- return TCL_ERROR;
- }
-
- /*
- * Make the object and return its name.
- */
-
- newObject = Tcl_NewObjectInstance(interp, (Tcl_Class) oPtr->classPtr,
- objName, objc, objv, Tcl_ObjectContextSkippedArgs(context)+1);
- if (newObject == NULL) {
- return TCL_ERROR;
- }
- Tcl_GetCommandFullName(interp, Tcl_GetObjectCommand(newObject),
- Tcl_GetObjResult(interp));
- return TCL_OK;
-}
-
-/*
- * ----------------------------------------------------------------------
- *
- * ClassNew --
- *
- * Implementation for oo::class->new method.
- *
- * ----------------------------------------------------------------------
- */
-
-static int
-ClassNew(
- ClientData clientData, /* Ignored. */
- Tcl_Interp *interp, /* Interpreter in which to create the object;
- * also used for error reporting. */
- Tcl_ObjectContext context, /* The object/call context. */
- int objc, /* Number of arguments. */
- Tcl_Obj *const *objv) /* The actual arguments. */
-{
- Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
- Tcl_Object newObject;
-
- /*
- * Sanity check; should not be possible to invoke this method on a
- * non-class.
- */
-
- if (oPtr->classPtr == NULL) {
- Tcl_Obj *cmdnameObj;
-
- TclNewObj(cmdnameObj);
- Tcl_GetCommandFullName(interp, oPtr->command, cmdnameObj);
- Tcl_AppendResult(interp, "object \"", TclGetString(cmdnameObj),
- "\" is not a class", NULL);
- TclDecrRefCount(cmdnameObj);
- return TCL_ERROR;
- }
-
- /*
- * Make the object and return its name.
- */
-
- newObject = Tcl_NewObjectInstance(interp, (Tcl_Class) oPtr->classPtr,
- NULL, objc, objv, Tcl_ObjectContextSkippedArgs(context));
- if (newObject == NULL) {
- return TCL_ERROR;
- }
- Tcl_GetCommandFullName(interp, Tcl_GetObjectCommand(newObject),
- Tcl_GetObjResult(interp));
- return TCL_OK;
-}
-
-/*
- * ----------------------------------------------------------------------
- *
- * ObjectDestroy --
- *
- * Implementation for oo::object->destroy method.
- *
- * ----------------------------------------------------------------------
- */
-
-static int
-ObjectDestroy(
- ClientData clientData, /* Ignored. */
- Tcl_Interp *interp, /* Interpreter in which to create the object;
- * also used for error reporting. */
- Tcl_ObjectContext context, /* The object/call context. */
- int objc, /* Number of arguments. */
- Tcl_Obj *const *objv) /* The actual arguments. */
-{
- if (objc != Tcl_ObjectContextSkippedArgs(context)) {
- Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
- NULL);
- return TCL_ERROR;
- }
- Tcl_DeleteCommandFromToken(interp,
- Tcl_GetObjectCommand(Tcl_ObjectContextObject(context)));
- return TCL_OK;
-}
-
-/*
- * ----------------------------------------------------------------------
- *
- * ObjectEval --
- *
- * Implementation for oo::object->eval method.
- *
- * ----------------------------------------------------------------------
- */
-
-static int
-ObjectEval(
- ClientData clientData, /* Ignored. */
- Tcl_Interp *interp, /* Interpreter in which to create the object;
- * also used for error reporting. */
- Tcl_ObjectContext context, /* The object/call context. */
- int objc, /* Number of arguments. */
- Tcl_Obj *const *objv) /* The actual arguments. */
-{
- CallContext *contextPtr = (CallContext *) context;
- Tcl_Object object = Tcl_ObjectContextObject(context);
- CallFrame *framePtr, **framePtrPtr;
- Tcl_Obj *objnameObj;
- int result;
-
- if (objc-1 < Tcl_ObjectContextSkippedArgs(context)) {
- Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
- "arg ?arg ...?");
- return TCL_ERROR;
- }
-
- /*
- * Make the object's namespace the current namespace and evaluate the
- * command(s).
- */
-
- /* This is needed to satisfy GCC 3.3's strict aliasing rules */
- framePtrPtr = &framePtr;
- result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr,
- Tcl_GetObjectNamespace(object), 0);
- if (result != TCL_OK) {
- return TCL_ERROR;
- }
- framePtr->objc = objc;
- framePtr->objv = objv; /* Reference counts do not need to be
- * incremented here. */
-
- if (contextPtr->flags & PUBLIC_METHOD) {
- TclNewObj(objnameObj);
- Tcl_GetCommandFullName(interp, Tcl_GetObjectCommand(object),
- objnameObj);
- } else {
- TclNewStringObj(objnameObj, "my", 2);
- }
- Tcl_IncrRefCount(objnameObj);
-
- if (objc == Tcl_ObjectContextSkippedArgs(context)+1) {
- result = Tcl_EvalObjEx(interp,
- objv[Tcl_ObjectContextSkippedArgs(context)], 0);
- } else {
- Tcl_Obj *objPtr;
-
- /*
- * More than one argument: concatenate them together with spaces
- * between, then evaluate the result. Tcl_EvalObjEx will delete the
- * object when it decrements its refcount after eval'ing it.
- */
-
- objPtr = Tcl_ConcatObj(objc-Tcl_ObjectContextSkippedArgs(context),
- objv+Tcl_ObjectContextSkippedArgs(context));
- result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT);
- }
-
- if (result == TCL_ERROR) {
- TclFormatToErrorInfo(interp,
- "\n (in \"%s eval\" script line %d)",
- TclGetString(objnameObj), interp->errorLine);
- }
-
- /*
- * Restore the previous "current" namespace.
- */
-
- TclPopStackFrame(interp);
- TclDecrRefCount(objnameObj);
- return result;
-}
-
-/*
- * ----------------------------------------------------------------------
- *
- * ObjectUnknown --
- *
- * Default unknown method handler method (defined in oo::object). This
- * just creates a suitable error message.
- *
- * ----------------------------------------------------------------------
- */
-
-static int
-ObjectUnknown(
- ClientData clientData, /* Ignored. */
- Tcl_Interp *interp, /* Interpreter in which to create the object;
- * also used for error reporting. */
- Tcl_ObjectContext context, /* The object/call context. */
- int objc, /* Number of arguments. */
- Tcl_Obj *const *objv) /* The actual arguments. */
-{
- CallContext *contextPtr = (CallContext *) context;
- Object *oPtr = contextPtr->oPtr;
- const char **methodNames;
- int numMethodNames, i;
-
- /*
- * Get the list of methods that we want to know about.
- */
-
- numMethodNames = TclOOGetSortedMethodList(oPtr,
- contextPtr->flags & PUBLIC_METHOD, &methodNames);
-
- /*
- * Special message when there are no visible methods at all.
- */
-
- if (numMethodNames == 0) {
- Tcl_Obj *tmpBuf;
-
- TclNewObj(tmpBuf);
- Tcl_GetCommandFullName(interp, oPtr->command, tmpBuf);
- Tcl_AppendResult(interp, "object \"", TclGetString(tmpBuf),
- "\" has no visible methods", NULL);
- TclDecrRefCount(tmpBuf);
- return TCL_ERROR;
- }
-
- Tcl_AppendResult(interp, "unknown method \"",
- TclGetString(objv[Tcl_ObjectContextSkippedArgs(context)-1]),
- "\": must be ", NULL);
- for (i=0 ; i<numMethodNames-1 ; i++) {
- if (i) {
- Tcl_AppendResult(interp, ", ", NULL);
- }
- Tcl_AppendResult(interp, methodNames[i], NULL);
- }
- if (i) {
- Tcl_AppendResult(interp, " or ", NULL);
- }
- Tcl_AppendResult(interp, methodNames[i], NULL);
- ckfree((char *) methodNames);
- return TCL_ERROR;
-}
-
-/*
- * ----------------------------------------------------------------------
- *
- * ObjectLinkVar --
- *
- * Implementation of oo::object->variable method.
- *
- * ----------------------------------------------------------------------
- */
-
-static int
-ObjectLinkVar(
- ClientData clientData, /* Ignored. */
- Tcl_Interp *interp, /* Interpreter in which to create the object;
- * also used for error reporting. */
- Tcl_ObjectContext context, /* The object/call context. */
- int objc, /* Number of arguments. */
- Tcl_Obj *const *objv) /* The actual arguments. */
-{
- Interp *iPtr = (Interp *) interp;
- Tcl_Object object = Tcl_ObjectContextObject(context);
- Namespace *savedNsPtr;
- int i;
-
- if (objc-Tcl_ObjectContextSkippedArgs(context) < 1) {
- Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
- "varName ?varName ...?");
- return TCL_ERROR;
- }
-
- /*
- * Do nothing if we are not called from the body of a method. In this
- * respect, we are like the [global] command.
- */
-
- if (iPtr->varFramePtr == NULL ||
- !(iPtr->varFramePtr->isProcCallFrame & FRAME_IS_METHOD)) {
- return TCL_OK;
- }
-
- for (i=Tcl_ObjectContextSkippedArgs(context) ; i<objc ; i++) {
- Var *varPtr, *aryPtr;
- Tcl_Obj **argObjs;
- const char *varName;
- int len;
-
- /*
- * Parse to see if we have a single value in the argument (just the
- * name of a variable to use in both the namespace and local scope) or
- * a two-argument list (namespace variable name and local variable
- * name). Other cases are an error.
- */
-
- if (Tcl_ListObjGetElements(interp, objv[i], &len, &argObjs)!=TCL_OK) {
- return TCL_ERROR;
- }
- if (len != 1 && len != 2) {
- Tcl_AppendResult(interp, "argument must be list "
- "of one or two variable names", NULL);
- return TCL_ERROR;
- }
-
- varName = TclGetString(argObjs[len-1]);
- if (strstr(varName, "::") != NULL) {
- /*
- * The local var name must not contain a '::' but the ns name is
- * OK. Naturally, if they're the same, then the restriction is
- * applied equally to both.
- */
-
- Tcl_AppendResult(interp, "variable name \"", varName,
- "\" illegal: must not contain namespace separator", NULL);
- return TCL_ERROR;
- }
-
- /*
- * Switch to the object's namespace for the duration of this call.
- * Like this, the variable is looked up in the namespace of the
- * object, and not in the namespace of the caller. Otherwise this
- * would only work if the caller was a method of the object itself,
- * which might not be true if the method was exported. This is a bit
- * of a hack, but the simplest way to do this (pushing a stack frame
- * would be horribly expensive by comparison). We never have to worry
- * about the case where we're dealing with the global namespace; we've
- * already checked that we are inside a method.
- */
-
- savedNsPtr = iPtr->varFramePtr->nsPtr;
- iPtr->varFramePtr->nsPtr = (Namespace *)
- Tcl_GetObjectNamespace(object);
- varPtr = TclObjLookupVar(interp, argObjs[0], NULL, TCL_NAMESPACE_ONLY,
- "define", 1, 0, &aryPtr);
- iPtr->varFramePtr->nsPtr = savedNsPtr;
-
- if (varPtr == NULL || aryPtr != NULL) {
- /*
- * Variable cannot be an element in an array. If aryPtr is not
- * NULL, it is an element, so throw up an error and return.
- */
-
- TclVarErrMsg(interp, TclGetString(argObjs[0]), NULL, "define",
- "name refers to an element in an array");
- return TCL_ERROR;
- }
-
- /*
- * Arrange for the lifetime of the variable to be correctly managed.
- * This is copied out of Tcl_VariableObjCmd...
- */
-
- if (!TclIsVarNamespaceVar(varPtr)) {
- TclSetVarNamespaceVar(varPtr);
- varPtr->refCount++;
- }
-
- if (TclPtrMakeUpvar(interp, varPtr, varName, 0, -1) != TCL_OK) {
- return TCL_ERROR;
- }
- }
- return TCL_OK;
-}
-
-/*
- * ----------------------------------------------------------------------
- *
- * ObjectVarName --
- *
- * Implementation of the oo::object->varname method.
- *
- * ----------------------------------------------------------------------
- */
-
-static int
-ObjectVarName(
- ClientData clientData, /* Ignored. */
- Tcl_Interp *interp, /* Interpreter in which to create the object;
- * also used for error reporting. */
- Tcl_ObjectContext context, /* The object/call context. */
- int objc, /* Number of arguments. */
- Tcl_Obj *const *objv) /* The actual arguments. */
-{
- Interp *iPtr = (Interp *) interp;
- Var *varPtr, *aryVar;
- Tcl_Obj *varNamePtr;
-
- if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
- Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
- "varName");
- return TCL_ERROR;
- }
-
- /*
- * Switch to the object's namespace for the duration of this call. Like
- * this, the variable is looked up in the namespace of the object, and not
- * in the namespace of the caller. Otherwise this would only work if the
- * caller was a method of the object itself, which might not be true if
- * the method was exported. This is a bit of a hack, but the simplest way
- * to do this (pushing a stack frame would be horribly expensive by
- * comparison, and is only done when we'd otherwise interfere with the
- * global namespace).
- */
-
- if (iPtr->varFramePtr == NULL) {
- Tcl_CallFrame *dummyFrame;
-
- TclPushStackFrame(interp, &dummyFrame,
- Tcl_GetObjectNamespace(Tcl_ObjectContextObject(context)),0);
- varPtr = TclObjLookupVar(interp, objv[objc-1], NULL,
- TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG, "refer to",1,1,&aryVar);
- TclPopStackFrame(interp);
- } else {
- Namespace *savedNsPtr;
-
- savedNsPtr = iPtr->varFramePtr->nsPtr;
- iPtr->varFramePtr->nsPtr = (Namespace *)
- Tcl_GetObjectNamespace(Tcl_ObjectContextObject(context));
- varPtr = TclObjLookupVar(interp, objv[objc-1], NULL,
- TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG, "refer to",1,1,&aryVar);
- iPtr->varFramePtr->nsPtr = savedNsPtr;
- }
-
- if (varPtr == NULL) {
- return TCL_ERROR;
- }
-
- TclNewObj(varNamePtr);
- Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, varNamePtr);
- Tcl_SetObjResult(interp, varNamePtr);
- return TCL_OK;
-}
-
-/*
- * ----------------------------------------------------------------------
- *
- * NextObjCmd --
- *
- * Implementation of the [next] command. Note that this command is only
- * ever to be used inside the body of a procedure-like method.
- *
- * ----------------------------------------------------------------------
- */
-
-static int
-NextObjCmd(
- ClientData clientData,
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const *objv)
-{
- Interp *iPtr = (Interp *) interp;
- CallFrame *framePtr = iPtr->varFramePtr, *savedFramePtr;
- CallContext *contextPtr;
- int index, result, skip;
-
- /*
- * Start with sanity checks on the calling context and the method context.
- */
-
- if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
- Tcl_AppendResult(interp, TclGetString(objv[0]),
- " may only be called from inside a method", NULL);
- return TCL_ERROR;
- }
-
- contextPtr = framePtr->ooContextPtr;
-
- index = contextPtr->index;
- skip = contextPtr->skip;
- if (index+1 >= contextPtr->numCallChain) {
- Tcl_AppendResult(interp, "no superclass ",
- (contextPtr->flags & CONSTRUCTOR ? "constructor" :
- (contextPtr->flags & DESTRUCTOR ? "destructor" : "method")),
- " implementation", NULL);
- return TCL_ERROR;
- }
-
- /*
- * Advance to the next method implementation in the chain in the method
- * call context while we process the body. However, need to adjust the
- * argument-skip control because we're guaranteed to have a single prefix
- * arg (i.e., 'next') and not the variable amount that can happen because
- * method invokations (i.e., '$obj meth' and 'my meth'), constructors
- * (i.e., '$cls new' and '$cls create obj') and destructors (no args at
- * all) come through the same code. From here on, the skip is always 1.
- */
-
- contextPtr->index = index+1;
- contextPtr->skip = 1;
-
- /*
- * Invoke the (advanced) method call context in the caller context. Note
- * that this is like [uplevel 1] and not [eval].
- */
-
- savedFramePtr = iPtr->varFramePtr;
- iPtr->varFramePtr = savedFramePtr->callerVarPtr;
- result = TclOOInvokeContext(interp, contextPtr, objc, objv);
- iPtr->varFramePtr = savedFramePtr;
-
- /*
- * Restore the call chain context index as we've finished the inner invoke
- * and want to operate in the outer context again.
- */
-
- contextPtr->index = index;
- contextPtr->skip = skip;
-
- return result;
-}
-
-/*
- * ----------------------------------------------------------------------
- *
- * SelfObjCmd --
- *
- * Implementation of the [self] command, which provides introspection of
- * the call context.
- *
- * ----------------------------------------------------------------------
- */
-
-static int
-SelfObjCmd(
- ClientData clientData,
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const *objv)
-{
- static const char *subcmds[] = {
- "caller", "class", "filter", "method", "namespace", "next", "object",
- "target", NULL
- };
- enum SelfCmds {
- SELF_CALLER, SELF_CLASS, SELF_FILTER, SELF_METHOD, SELF_NS, SELF_NEXT,
- SELF_OBJECT, SELF_TARGET
- };
- Interp *iPtr = (Interp *) interp;
- CallFrame *framePtr = iPtr->varFramePtr;
- CallContext *contextPtr;
- int index;
-
- /*
- * Start with sanity checks on the calling context and the method context.
- */
-
- if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
- Tcl_AppendResult(interp, TclGetString(objv[0]),
- " may only be called from inside a method", NULL);
- return TCL_ERROR;
- }
-
- contextPtr = framePtr->ooContextPtr;
-
- /*
- * Now we do "conventional" argument parsing for a while. Note that no
- * subcommand takes arguments.
- */
-
- if (objc > 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "subcommand");
- return TCL_ERROR;
- }
- if (objc == 1) {
- index = SELF_OBJECT;
- } else if (Tcl_GetIndexFromObj(interp, objv[1], subcmds, "subcommand", 0,
- &index) != TCL_OK) {
- return TCL_ERROR;
- }
-
- switch ((enum SelfCmds) index) {
- case SELF_OBJECT:
- Tcl_GetCommandFullName(interp, contextPtr->oPtr->command,
- Tcl_GetObjResult(interp));
- return TCL_OK;
- case SELF_NS:
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- contextPtr->oPtr->namespacePtr->fullName,-1));
- return TCL_OK;
- case SELF_CLASS: {
- Method *mPtr = contextPtr->callChain[contextPtr->index].mPtr;
- Object *declarerPtr;
-
- if (mPtr->declaringClassPtr != NULL) {
- declarerPtr = mPtr->declaringClassPtr->thisPtr;
- } else if (mPtr->declaringObjectPtr != NULL) {
- declarerPtr = mPtr->declaringObjectPtr;
- } else {
- /*
- * This should be unreachable code.
- */
-
- Tcl_AppendResult(interp, "method without declarer!", NULL);
- return TCL_ERROR;
- }
-
- Tcl_GetCommandFullName(interp, declarerPtr->command,
- Tcl_GetObjResult(interp));
- return TCL_OK;
- }
- case SELF_METHOD:
- if (contextPtr->flags & CONSTRUCTOR) {
- Tcl_AppendResult(interp, "<constructor>", NULL);
- } else if (contextPtr->flags & DESTRUCTOR) {
- Tcl_AppendResult(interp, "<destructor>", NULL);
- } else {
- Method *mPtr = contextPtr->callChain[contextPtr->index].mPtr;
-
- Tcl_SetObjResult(interp, mPtr->namePtr);
- }
- return TCL_OK;
- case SELF_FILTER:
- if (!contextPtr->callChain[contextPtr->index].isFilter) {
- Tcl_AppendResult(interp, "not inside a filtering context", NULL);
- return TCL_ERROR;
- } else {
- Method *mPtr =
- contextPtr->callChain[contextPtr->filterLength].mPtr;
- Tcl_Obj *cmdName;
-
- // TODO: should indicate who has the filter registration, not the
- // first non-filter after the filter!
- TclNewObj(cmdName);
- Tcl_GetCommandFullName(interp, contextPtr->oPtr->command,
- cmdName);
- Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), cmdName);
- // TODO: Add what type of filter this is
- Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
- mPtr->namePtr);
- return TCL_OK;
- }
- case SELF_CALLER:
- if ((framePtr->callerVarPtr != NULL) &&
- (framePtr->callerVarPtr->isProcCallFrame & FRAME_IS_METHOD)) {
- CallContext *callerPtr = framePtr->callerVarPtr->ooContextPtr;
- Method *mPtr = callerPtr->callChain[callerPtr->index].mPtr;
- Object *declarerPtr;
- Tcl_Obj *tmpObj;
-
- if (mPtr->declaringClassPtr != NULL) {
- declarerPtr = mPtr->declaringClassPtr->thisPtr;
- } else if (mPtr->declaringObjectPtr != NULL) {
- declarerPtr = mPtr->declaringObjectPtr;
- } else {
- /*
- * This should be unreachable code.
- */
-
- Tcl_AppendResult(interp, "method without declarer!", NULL);
- return TCL_ERROR;
- }
-
- TclNewObj(tmpObj);
- Tcl_GetCommandFullName(interp, declarerPtr->command, tmpObj);
- Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), tmpObj);
- TclNewObj(tmpObj);
- Tcl_GetCommandFullName(interp, callerPtr->oPtr->command, tmpObj);
- Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), tmpObj);
- if (callerPtr->flags & CONSTRUCTOR) {
- Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
- Tcl_NewStringObj("<constructor>", -1));
- } else if (callerPtr->flags & DESTRUCTOR) {
- Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
- Tcl_NewStringObj("<destructor>", -1));
- } else {
- Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
- mPtr->namePtr);
- }
- return TCL_OK;
- } else {
- Tcl_AppendResult(interp, "caller is not an object", NULL);
- return TCL_ERROR;
- }
- case SELF_NEXT:
- if (contextPtr->index < contextPtr->numCallChain-1) {
- Method *mPtr = contextPtr->callChain[contextPtr->index+1].mPtr;
- Object *declarerPtr;
- Tcl_Obj *tmpObj;
-
- if (mPtr->declaringClassPtr != NULL) {
- declarerPtr = mPtr->declaringClassPtr->thisPtr;
- } else if (mPtr->declaringObjectPtr != NULL) {
- declarerPtr = mPtr->declaringObjectPtr;
- } else {
- /*
- * This should be unreachable code.
- */
-
- Tcl_AppendResult(interp, "method without declarer!", NULL);
- return TCL_ERROR;
- }
-
- TclNewObj(tmpObj);
- Tcl_GetCommandFullName(interp, declarerPtr->command, tmpObj);
- Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), tmpObj);
- if (contextPtr->flags & CONSTRUCTOR) {
- Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
- Tcl_NewStringObj("<constructor>", -1));
- } else if (contextPtr->flags & DESTRUCTOR) {
- Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
- Tcl_NewStringObj("<destructor>", -1));
- } else {
- Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
- mPtr->namePtr);
- }
- }
- return TCL_OK;
- case SELF_TARGET:
- if (!contextPtr->callChain[contextPtr->index].isFilter) {
- Tcl_AppendResult(interp, "not inside a filtering context", NULL);
- return TCL_ERROR;
- } else {
- Method *mPtr;
- Object *declarerPtr;
- Tcl_Obj *cmdName;
- int i;
-
- for (i=contextPtr->index ; i<contextPtr->numCallChain ; i++) {
- if (!contextPtr->callChain[i].isFilter) {
- break;
- }
- }
- if (i == contextPtr->numCallChain) {
- Tcl_Panic("filtering call chain without terminal non-filter");
- }
- mPtr = contextPtr->callChain[i].mPtr;
- if (mPtr->declaringClassPtr != NULL) {
- declarerPtr = mPtr->declaringClassPtr->thisPtr;
- } else if (mPtr->declaringObjectPtr != NULL) {
- declarerPtr = mPtr->declaringObjectPtr;
- } else {
- /*
- * This should be unreachable code.
- */
-
- Tcl_AppendResult(interp, "method without declarer!", NULL);
- return TCL_ERROR;
- }
- TclNewObj(cmdName);
- Tcl_GetCommandFullName(interp, declarerPtr->command, cmdName);
- Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), cmdName);
- Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
- mPtr->namePtr);
- return TCL_OK;
- }
- }
- return TCL_ERROR;
-}
-
-/*
- * ----------------------------------------------------------------------
- *
- * Tcl_GetObjectFromObj --
- *
- * Utility function to get an object from a Tcl_Obj containing its name.
- *
- * ----------------------------------------------------------------------
- */
-
-Tcl_Object
-Tcl_GetObjectFromObj(
- Tcl_Interp *interp,
- Tcl_Obj *objPtr)
-{
- Command *cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objPtr);
-
- if (cmdPtr == NULL || cmdPtr->objProc != PublicObjectCmd) {
- Tcl_AppendResult(interp, TclGetString(objPtr),
- " does not refer to an object", NULL);
- return NULL;
- }
- return cmdPtr->objClientData;
-}
-
-/*
- * ----------------------------------------------------------------------
- *
- * TclOOIsReachable --
- *
- * Utility function that tests whether a class is a subclass (whether
- * directly or indirectly) of another class.
- *
- * ----------------------------------------------------------------------
- */
-
-int
-TclOOIsReachable(
- Class *targetPtr,
- Class *startPtr)
-{
- int i;
- Class *superPtr;
-
- tailRecurse:
- if (startPtr == targetPtr) {
- return 1;
- }
- if (startPtr->superclasses.num == 1) {
- startPtr = startPtr->superclasses.list[0];
- goto tailRecurse;
- }
- FOREACH(superPtr, startPtr->superclasses) {
- if (TclOOIsReachable(targetPtr, superPtr)) {
- return 1;
- }
- }
- return 0;
-}
-
-/*
- * ----------------------------------------------------------------------
- *
- * TclOOGetProcFromMethod, TclOOGetFwdFromMethod --
- *
- * Utility functions used for procedure-like and forwarding method
- * introspection.
- *
- * ----------------------------------------------------------------------
- */
-
-Proc *
-TclOOGetProcFromMethod(
- Method *mPtr)
-{
- if (mPtr->typePtr == &procMethodType) {
- ProcedureMethod *pmPtr = mPtr->clientData;
-
- return pmPtr->procPtr;
- }
- return NULL;
-}
-
-Tcl_Obj *
-TclOOGetFwdFromMethod(
- Method *mPtr)
-{
- if (mPtr->typePtr == &fwdMethodType) {
- ForwardMethod *fwPtr = mPtr->clientData;
-
- return fwPtr->prefixObj;
- }
- return NULL;
-}
-
-/*
- * ----------------------------------------------------------------------
- *
- * InitEnsembleRewrite --
- *
- * Utility function that wraps up a lot of the complexity involved in
- * doing ensemble-like command forwarding. Here is a picture of memory
- * management plan:
- *
- * <-----------------objc---------------------->
- * objv: |=============|===============================|
- * <-toRewrite-> |
- * \
- * <-rewriteLength-> \
- * rewriteObjs: |=================| \
- * | |
- * V V
- * argObjs: |=================|===============================|
- * <------------------*lengthPtr------------------->
- *
- * ----------------------------------------------------------------------
- */
-
-static Tcl_Obj **
-InitEnsembleRewrite(
- Tcl_Interp *interp, /* Place to log the rewrite info. */
- int objc, /* Number of real arguments. */
- Tcl_Obj *const *objv, /* The real arguments. */
- int toRewrite, /* Number of real arguments to replace. */
- int rewriteLength, /* Number of arguments to insert instead. */
- Tcl_Obj *const *rewriteObjs,/* Arguments to insert instead. */
- int *lengthPtr) /* Where to write the resulting length of the
- * array of rewritten arguments. */
-{
- Interp *iPtr = (Interp *) interp;
- int isRootEnsemble = (iPtr->ensembleRewrite.sourceObjs == NULL);
- Tcl_Obj **argObjs;
- unsigned len = rewriteLength + objc - toRewrite;
-
- argObjs = (Tcl_Obj **) ckalloc(sizeof(Tcl_Obj *) * len);
- memcpy(argObjs, rewriteObjs, rewriteLength * sizeof(Tcl_Obj *));
- memcpy(argObjs + rewriteLength, objv + toRewrite,
- sizeof(Tcl_Obj *) * (objc - toRewrite));
-
- /*
- * Now plumb this into the core ensemble rewrite logging system so that
- * Tcl_WrongNumArgs() can rewrite its result appropriately. The rules for
- * how to store the rewrite rules get complex solely because of the case
- * where an ensemble rewrites itself out of the picture; when that
- * happens, the quality of the error message rewrite falls drastically
- * (and unavoidably).
- */
-
- if (isRootEnsemble) {
- iPtr->ensembleRewrite.sourceObjs = objv;
- iPtr->ensembleRewrite.numRemovedObjs = toRewrite;
- iPtr->ensembleRewrite.numInsertedObjs = rewriteLength;
- } else {
- int numIns = iPtr->ensembleRewrite.numInsertedObjs;
-
- if (numIns < toRewrite) {
- iPtr->ensembleRewrite.numRemovedObjs += toRewrite - numIns;
- iPtr->ensembleRewrite.numInsertedObjs += rewriteLength - 1;
- } else {
- iPtr->ensembleRewrite.numInsertedObjs +=
- rewriteLength - toRewrite;
- }
- }
-
- *lengthPtr = len;
- return argObjs;
-}
-
-Tcl_Method
-Tcl_ObjectContextMethod(
- Tcl_ObjectContext context)
-{
- CallContext *contextPtr = (CallContext *) context;
- return (Tcl_Method) contextPtr->callChain[contextPtr->index].mPtr;
-}
-
-int
-Tcl_ObjectContextIsFiltering(
- Tcl_ObjectContext context)
-{
- CallContext *contextPtr = (CallContext *) context;
- return contextPtr->callChain[contextPtr->index].isFilter;
-}
-
-Tcl_Object
-Tcl_ObjectContextObject(
- Tcl_ObjectContext context)
-{
- return (Tcl_Object) ((CallContext *)context)->oPtr;
-}
-
-int
-Tcl_ObjectContextSkippedArgs(
- Tcl_ObjectContext context)
-{
- return ((CallContext *)context)->skip;
-}
-
-Tcl_Object
-Tcl_MethodDeclarerObject(
- Tcl_Method method)
-{
- return (Tcl_Object) ((Method *) method)->declaringObjectPtr;
-}
-
-Tcl_Class
-Tcl_MethodDeclarerClass(
- Tcl_Method method)
-{
- return (Tcl_Class) ((Method *) method)->declaringClassPtr;
-}
-
-Tcl_Obj *
-Tcl_MethodName(
- Tcl_Method method)
-{
- return ((Method *) method)->namePtr;
-}
-
-int
-Tcl_MethodIsType(
- Tcl_Method method,
- const Tcl_MethodType *typePtr,
- ClientData *clientDataPtr)
-{
- Method *mPtr = (Method *) method;
-
- if (mPtr->typePtr == typePtr) {
- if (clientDataPtr != NULL) {
- *clientDataPtr = mPtr->clientData;
- }
- return 1;
- }
- return 0;
-}
-
-int
-Tcl_MethodIsPublic(
- Tcl_Method method)
-{
- return (((Method *)method)->flags & PUBLIC_METHOD) ? 1 : 0;
-}
-
-Tcl_Namespace *
-Tcl_GetObjectNamespace(
- Tcl_Object object)
-{
- return ((Object *)object)->namespacePtr;
-}
-
-Tcl_Command
-Tcl_GetObjectCommand(
- Tcl_Object object)
-{
- return ((Object *)object)->command;
-}
-
-Tcl_Class
-Tcl_GetObjectAsClass(
- Tcl_Object object)
-{
- return (Tcl_Class) ((Object *)object)->classPtr;
-}
-
-int
-Tcl_ObjectDeleted(
- Tcl_Object object)
-{
- return (((Object *)object)->flags & OBJECT_DELETED) ? 1 : 0;
-}
-
-Tcl_Object
-Tcl_GetClassAsObject(
- Tcl_Class clazz)
-{
- return (Tcl_Object) ((Class *)clazz)->thisPtr;
-}
-
-/*
- * Local Variables:
- * mode: c
- * c-basic-offset: 4
- * fill-column: 78
- * End:
- */
diff --git a/generic/tclOO.h b/generic/tclOO.h
deleted file mode 100644
index bfe66d6..0000000
--- a/generic/tclOO.h
+++ /dev/null
@@ -1,389 +0,0 @@
-/*
- * tclOO.h --
- *
- * This file contains the structure definitions and some of the function
- * declarations for the object-system (NB: not Tcl_Obj, but ::oo).
- *
- * Copyright (c) 2006 by Donal K. Fellows
- *
- * See the file "license.terms" for information on usage and redistribution of
- * this file, and for a DISCLAIMER OF ALL WARRANTIES.
- *
- * RCS: @(#) $Id: tclOO.h,v 1.2 2006/10/20 14:04:01 dkf Exp $
- */
-
-// vvvvvvvvvvvvvvvvvvvvvv MOVE TO TCL.DECLS vvvvvvvvvvvvvvvvvvvvvv
-Tcl_Object Tcl_CopyObjectInstance(Tcl_Interp *interp,
- Tcl_Object sourceObject, const char *targetName);
-Tcl_Object Tcl_GetClassAsObject(Tcl_Class clazz);
-Tcl_Class Tcl_GetObjectAsClass(Tcl_Object object);
-Tcl_Command Tcl_GetObjectCommand(Tcl_Object object);
-Tcl_Object Tcl_GetObjectFromObj(Tcl_Interp *interp,
- Tcl_Obj *objPtr);
-Tcl_Namespace * Tcl_GetObjectNamespace(Tcl_Object object);
-Tcl_Class Tcl_MethodDeclarerClass(Tcl_Method method);
-Tcl_Object Tcl_MethodDeclarerObject(Tcl_Method method);
-int Tcl_MethodIsPublic(Tcl_Method method);
-int Tcl_MethodIsType(Tcl_Method method,
- const Tcl_MethodType *typePtr,
- ClientData *clientDataPtr);
-Tcl_Obj * Tcl_MethodName(Tcl_Method method);
-Tcl_Method Tcl_NewMethod(Tcl_Interp *interp, Tcl_Object object,
- Tcl_Obj *nameObj, int isPublic,
- const Tcl_MethodType *typePtr,
- ClientData clientData);
-Tcl_Method Tcl_NewClassMethod(Tcl_Interp *interp, Tcl_Class cls,
- Tcl_Obj *nameObj, int isPublic,
- const Tcl_MethodType *typePtr,
- ClientData clientData);
-Tcl_Object Tcl_NewObjectInstance(Tcl_Interp *interp,
- Tcl_Class cls, const char *name, int objc,
- Tcl_Obj *const *objv, int skip);
-int Tcl_ObjectDeleted(Tcl_Object object);
-int Tcl_ObjectContextIsFiltering(
- Tcl_ObjectContext context);
-Tcl_Method Tcl_ObjectContextMethod(Tcl_ObjectContext context);
-Tcl_Object Tcl_ObjectContextObject(Tcl_ObjectContext context);
-int Tcl_ObjectContextSkippedArgs(
- Tcl_ObjectContext context);
-ClientData Tcl_ClassGetMetadata(Tcl_Class clazz,
- const Tcl_ObjectMetadataType *typePtr);
-void Tcl_ClassSetMetadata(Tcl_Class clazz,
- const Tcl_ObjectMetadataType *typePtr,
- ClientData metadata);
-ClientData Tcl_ObjectGetMetadata(Tcl_Object object,
- const Tcl_ObjectMetadataType *typePtr);
-void Tcl_ObjectSetMetadata(Tcl_Object object,
- const Tcl_ObjectMetadataType *typePtr,
- ClientData metadata);
-// ^^^^^^^^^^^^^^^^^^^^^^ MOVE TO TCL.DECLS ^^^^^^^^^^^^^^^^^^^^^^
-
-/*
- * Forward declarations.
- */
-
-struct Class;
-struct Object;
-
-/*
- * The data that needs to be stored per method. This record is used to collect
- * information about all sorts of methods, including forwards, constructors
- * and destructors.
- */
-
-typedef struct Method {
- const Tcl_MethodType *typePtr;
- /* The type of method. If NULL, this is a
- * special flag record which is just used for
- * the setting of the flags field. */
- ClientData clientData; /* Type-specific data. */
- Tcl_Obj *namePtr; /* Name of the method. */
- struct Object *declaringObjectPtr;
- /* The object that declares this method, or
- * NULL if it was declared by a class. */
- struct Class *declaringClassPtr;
- /* The class that declares this method, or
- * NULL if it was declared directly on an
- * object. */
- int flags; /* Assorted flags. Includes whether this
- * method is public/exported or not. */
-} Method;
-
-/*
- * Procedure-like methods have the following extra information. It is a
- * single-field structure because this allows for future expansion without
- * changing vast amounts of code.
- */
-
-typedef struct ProcedureMethod {
- Proc *procPtr;
-} ProcedureMethod;
-
-/*
- * Forwarded methods have the following extra information. It is a
- * single-field structure because this allows for future expansion without
- * changing vast amounts of code.
- */
-
-typedef struct ForwardMethod {
- Tcl_Obj *prefixObj;
-} ForwardMethod;
-
-/*
- * Helper definitions that declare a "list" array. The two varieties are
- * either optimized for simplicity (in the case that the whole array is
- * typically assigned at once) or efficiency (in the case that the array is
- * expected to be expanded over time). These lists are designed to be iterated
- * over with the help of the FOREACH macro (see later in this file).
- *
- * The "num" field always counts the number of listType_t elements used in the
- * "list" field. When a "size" field exists, it describes how many elements
- * are present in the list; when absent, exactly "num" elements are present.
- */
-
-#define LIST_STATIC(listType_t) \
- struct { int num; listType_t *list; }
-#define LIST_DYNAMIC(listType_t) \
- struct { int num, size; listType_t *list; }
-
-/*
- * Now, the definition of what an object actually is.
- */
-
-typedef struct Object {
- Tcl_Namespace *namespacePtr;/* This object's tame namespace. */
- Tcl_Command command; /* Reference to this object's public
- * command. */
- Tcl_Command myCommand; /* Reference to this object's internal
- * command. */
- struct Class *selfCls; /* This object's class. */
- Tcl_HashTable methods; /* Object-local Tcl_Obj (method name) to
- * Method* mapping. */
- LIST_STATIC(struct Class *) mixins;
- /* Classes mixed into this object. */
- LIST_STATIC(Tcl_Obj *) filters;
- /* List of filter names. */
- struct Class *classPtr; /* All classes have this non-NULL; it points
- * to the class structure. Everything else has
- * this NULL. */
- int flags;
- int epoch; /* Per-object epoch, incremented when the way
- * an object should resolve call chains is
- * changed. */
- Tcl_HashTable *metadataPtr; /* Mapping from pointers to metadata type to
- * the ClientData values that are the values
- * of each piece of attached metadata. This
- * field starts out as NULL and is only
- * allocated if metadata is attached. */
- Tcl_HashTable publicContextCache; /* Place to keep unused contexts. */
- Tcl_HashTable privateContextCache; /* Place to keep unused contexts. */
-} Object;
-
-#define OBJECT_DELETED 1 /* Flag to say that an object has been
- * destroyed. */
-#define ROOT_OBJECT 0x1000 /* Flag to say that this object is the root of
- * the class hierarchy and should be treated
- * specially during teardown. */
-#define FILTER_HANDLING 0x2000 /* Flag set when the object is processing a
- * filter; when set, filters are *not*
- * processed on the object, preventing nasty
- * recursive filtering problems. */
-
-/*
- * And the definition of a class. Note that every class also has an associated
- * object, through which it is manipulated.
- */
-
-typedef struct Class {
- Object *thisPtr; /* Reference to the object associated with
- * this class. */
- int flags; /* Assorted flags. */
- LIST_STATIC(struct Class *) superclasses;
- /* List of superclasses, used for generation
- * of method call chains. */
- LIST_DYNAMIC(struct Class *) subclasses;
- /* List of subclasses, used to ensure deletion
- * of dependent entities happens properly when
- * the class itself is deleted. */
- LIST_DYNAMIC(Object *) instances;
- /* List of instances, used to ensure deletion
- * of dependent entities happens properly when
- * the class itself is deleted. */
- LIST_STATIC(Tcl_Obj *) filters;
- /* List of filter names, used for generation
- * of method call chains. */
- LIST_STATIC(struct Class *) mixins;
- /* List of mixin classes, used for generation
- * of method call chains. */
- LIST_DYNAMIC(struct Class *) mixinSubs;
- /* List of classes that this class is mixed
- * into, used to ensure deletion of dependent
- * entities happens properly when the class
- * itself is deleted. */
- LIST_STATIC(struct Class *) classHierarchy;
- /* List of classes that comprise the basic
- * class hierarchy for this class's
- * superclasses. If NULL (and this isn't the
- * root object class) then this needs
- * recomputing. */
- int classHierarchyEpoch; /* Differs from the global epoch when it is
- * time to recompute the class hierarchy. */
- Tcl_HashTable classMethods; /* Hash table of all methods. Hash maps from
- * the (Tcl_Obj*) method name to the (Method*)
- * method record. */
- Method *constructorPtr; /* Method record of the class constructor (if
- * any). */
- Method *destructorPtr; /* Method record of the class destructor (if
- * any). */
- Tcl_HashTable *metadataPtr; /* Mapping from pointers to metadata type to
- * the ClientData values that are the values
- * of each piece of attached metadata. This
- * field starts out as NULL and is only
- * allocated if metadata is attached. */
-} Class;
-
-/*
- * The foundation of the object system within an interpreter contains
- * references to the key classes and namespaces, together with a few other
- * useful bits and pieces. Probably ought to eventually go in the Interp
- * structure itself.
- */
-
-typedef struct Foundation {
- Class *objectCls; /* The root of the object system. */
- Class *classCls; /* The class of all classes. */
- Tcl_Namespace *ooNs; /* Master ::oo namespace. */
- Tcl_Namespace *defineNs; /* Namespace containing special commands for
- * manipulating objects and classes. The
- * "oo::define" command acts as a special kind
- * of ensemble for this namespace. */
- Tcl_Namespace *helpersNs; /* Namespace containing the commands that are
- * only valid when executing inside a
- * procedural method. */
- int epoch; /* Used to invalidate method chains when the
- * class structure changes. */
- int nsCount; /* Counter so we can allocate a unique
- * namespace to each object. */
- Tcl_Obj *unknownMethodNameObj;
- /* Shared object containing the name of the
- * unknown method handler method. */
-} Foundation;
-
-/*
- * A call context structure is built when a method is called. They contain the
- * chain of method implementations that are to be invoked by a particular
- * call, and the process of calling walks the chain, with the [next] command
- * proceeding to the next entry in the chain.
- */
-
-#define CALL_CHAIN_STATIC_SIZE 4
-
-struct MInvoke {
- Method *mPtr; /* Reference to the method implementation
- * record. */
- int isFilter; /* Whether this is a filter invokation. */
-};
-
-typedef struct CallContext {
- Object *oPtr; /* The object associated with this call. */
- int globalEpoch; /* Global (class) epoch counter snapshot. */
- int localEpoch; /* Local (single object) epoch counter
- * snapshot. */
- int flags; /* Assorted flags, see below. */
- int index; /* Index into the call chain of the currently
- * executing method implementation. */
- int skip;
- int numCallChain; /* Size of the call chain. */
- struct MInvoke *callChain; /* Array of call chain entries. May point to
- * staticCallChain if the number of entries is
- * small. */
- struct MInvoke staticCallChain[CALL_CHAIN_STATIC_SIZE];
- int filterLength; /* Number of entries in the call chain that
- * are due to processing filters and not the
- * main call chain. */
-} CallContext;
-
-/*
- * Bits for the 'flags' field of the call context.
- */
-
-#define OO_UNKNOWN_METHOD 1 /* This is an unknown method. */
-#define PUBLIC_METHOD 2 /* This is a public (exported) method. */
-#define CONSTRUCTOR 4 /* This is a constructor. */
-#define DESTRUCTOR 8 /* This is a destructor. */
-
-/*
- * Private definitions, some of which perhaps ought to be exposed properly or
- * maybe just put in the internal stubs table.
- */
-
-MODULE_SCOPE Method * TclOONewProcMethod(Tcl_Interp *interp, Object *oPtr,
- int isPublic, Tcl_Obj *nameObj, Tcl_Obj *argsObj,
- Tcl_Obj *bodyObj);
-MODULE_SCOPE Method * TclOONewForwardMethod(Tcl_Interp *interp, Object *oPtr,
- int isPublic, Tcl_Obj *nameObj,
- Tcl_Obj *prefixObj);
-MODULE_SCOPE Method * TclOONewProcClassMethod(Tcl_Interp *interp,
- Class *clsPtr, int isPublic, Tcl_Obj *nameObj,
- Tcl_Obj *argsObj, Tcl_Obj *bodyObj);
-MODULE_SCOPE Method * TclOONewForwardClassMethod(Tcl_Interp *interp,
- Class *clsPtr, int isPublic, Tcl_Obj *nameObj,
- Tcl_Obj *prefixObj);
-MODULE_SCOPE void TclOODeleteMethod(Method *method);
-MODULE_SCOPE int TclObjInterpProcCore(register Tcl_Interp *interp,
- CallFrame *framePtr, Tcl_Obj *procNameObj,
- int skip);
-MODULE_SCOPE void TclOOAddToInstances(Object *oPtr, Class *clsPtr);
-MODULE_SCOPE void TclOOAddToSubclasses(Class *subPtr, Class *superPtr);
-MODULE_SCOPE void TclOOAddToMixinSubs(Class *subPtr, Class *mixinPtr);
-MODULE_SCOPE Proc * TclOOGetProcFromMethod(Method *mPtr);
-MODULE_SCOPE Tcl_Obj * TclOOGetFwdFromMethod(Method *mPtr);
-MODULE_SCOPE int TclOOIsReachable(Class *targetPtr, Class *startPtr);
-MODULE_SCOPE void TclOORemoveFromInstances(Object *oPtr, Class *clsPtr);
-MODULE_SCOPE void TclOORemoveFromSubclasses(Class *subPtr,
- Class *superPtr);
-MODULE_SCOPE void TclOORemoveFromMixinSubs(Class *subPtr,
- Class *mixinPtr);
-MODULE_SCOPE void TclOODeleteContext(CallContext *contextPtr);
-MODULE_SCOPE CallContext *TclOOGetCallContext(Foundation *fPtr, Object *oPtr,
- Tcl_Obj *methodNameObj, int flags,
- Tcl_HashTable *cachePtr);
-MODULE_SCOPE int TclOOInvokeContext(Tcl_Interp *interp,
- CallContext *contextPtr, int objc,
- Tcl_Obj *const *objv);
-MODULE_SCOPE int TclOOGetSortedMethodList(Object *oPtr,
- int publicOnly, const char ***stringsPtr);
-
-/*
- * A convenience macro for iterating through the lists used in the internal
- * memory management of objects. This is a bit gnarly because we want to do
- * the assignment of the picked-out value only when the body test succeeds,
- * but we cannot rely on the assigned value being useful, forcing us to do
- * some nasty stuff with the comma operator. The compiler's optimizer should
- * be able to sort it all out!
- *
- * REQUIRES DECLARATION: int i;
- */
-
-#define FOREACH(var,ary) \
- for(i=0 ; (i<(ary).num?((var=(ary).list[i]),1):0) ; i++)
-
-/*
- * Convenience macros for iterating through hash tables. FOREACH_HASH_DECLS
- * sets up the declarations needed for the main macro, FOREACH_HASH, which
- * does the actual iteration. FOREACH_HASH_VALUE is a restricted version that
- * only iterates over values.
- */
-
-#define FOREACH_HASH_DECLS \
- Tcl_HashEntry *hPtr;Tcl_HashSearch search
-#define FOREACH_HASH(key,val,tablePtr) \
- for(hPtr=Tcl_FirstHashEntry((tablePtr),&search); hPtr!=NULL ? \
- ((key)=(void *)Tcl_GetHashKey((tablePtr),hPtr),\
- (val)=Tcl_GetHashValue(hPtr),1):0; hPtr=Tcl_NextHashEntry(&search))
-#define FOREACH_HASH_VALUE(val,tablePtr) \
- for(hPtr=Tcl_FirstHashEntry((tablePtr),&search); hPtr!=NULL ? \
- ((val)=Tcl_GetHashValue(hPtr),1):0;hPtr=Tcl_NextHashEntry(&search))
-
-/*
- * Convenience macro for duplicating a list. Needs no external declaration,
- * but all arguments are used multiple times and so must have no side effects.
- */
-
-#define DUPLICATE(target,source,type) \
- do { \
- register unsigned len = sizeof(type) * ((target).num=(source).num);\
- if (len != 0) { \
- memcpy(((target).list=(type*)ckalloc(len)), (source).list, len); \
- } else { \
- (target).list = NULL; \
- } \
- } while(0)
-
-/*
- * Local Variables:
- * mode: c
- * c-basic-offset: 4
- * fill-column: 78
- * End:
- */
diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c
deleted file mode 100644
index 71663e4..0000000
--- a/generic/tclOOCall.c
+++ /dev/null
@@ -1,803 +0,0 @@
-/*
- * tclOO.c --
- *
- * This file contains the method call chain management code for the
- * object-system core.
- *
- * Copyright (c) 2005-2006 by Donal K. Fellows
- *
- * See the file "license.terms" for information on usage and redistribution of
- * this file, and for a DISCLAIMER OF ALL WARRANTIES.
- *
- * RCS: @(#) $Id: tclOOCall.c,v 1.2 2006/10/20 14:04:01 dkf Exp $
- */
-
-#include "tclInt.h"
-#include "tclOO.h"
-
-/*
- * Extra flags used for call chain management.
- */
-
-#define DEFINITE_PRIVATE 0x100000
-#define DEFINITE_PUBLIC 0x200000
-#define KNOWN_STATE (DEFINITE_PRIVATE | DEFINITE_PUBLIC)
-#define SPECIAL (CONSTRUCTOR | DESTRUCTOR)
-
-/*
- * Function declarations for things defined in this file.
- */
-
-static void AddClassFiltersToCallContext(Object *oPtr,
- Class *clsPtr, CallContext *contextPtr,
- Tcl_HashTable *doneFilters);
-static void AddClassMethodNames(Class *clsPtr, int publicOnly,
- Tcl_HashTable *namesPtr);
-static void AddMethodToCallChain(Method *mPtr,
- CallContext *contextPtr,
- Tcl_HashTable *doneFilters);
-static void AddSimpleChainToCallContext(Object *oPtr,
- Tcl_Obj *methodNameObj, CallContext *contextPtr,
- Tcl_HashTable *doneFilters, int isPublic);
-static void AddSimpleClassChainToCallContext(Class *classPtr,
- Tcl_Obj *methodNameObj, CallContext *contextPtr,
- Tcl_HashTable *doneFilters, int isPublic);
-static int CmpStr(const void *ptr1, const void *ptr2);
-static void InitClassHierarchy(Foundation *fPtr, Class *classPtr);
-
-/*
- * ----------------------------------------------------------------------
- *
- * TclOODeleteContext --
- *
- * Destroys a method call-chain context, which should not be in use.
- *
- * ----------------------------------------------------------------------
- */
-
-void
-TclOODeleteContext(
- CallContext *contextPtr)
-{
- if (contextPtr->callChain != contextPtr->staticCallChain) {
- ckfree((char *) contextPtr->callChain);
- }
- ckfree((char *) contextPtr);
-}
-
-/*
- * ----------------------------------------------------------------------
- *
- * TclOOInvokeContext --
- *
- * Invokes a single step along a method call-chain context. Note that the
- * invokation of a step along the chain can cause further steps along the
- * chain to be invoked. Note that this function is written to be as light
- * in stack usage as possible.
- *
- * ----------------------------------------------------------------------
- */
-
-int
-TclOOInvokeContext(
- Tcl_Interp *interp, /* Interpreter for error reporting, and many
- * other sorts of context handling (e.g.,
- * commands, variables) depending on method
- * implementation. */
- CallContext *contextPtr, /* The method call context. */
- int objc, /* The number of arguments. */
- Tcl_Obj *const *objv) /* The arguments as actually seen. */
-{
- Method *mPtr = contextPtr->callChain[contextPtr->index].mPtr;
- int result, isFirst = (contextPtr->index == 0);
- int isFilter = contextPtr->callChain[contextPtr->index].isFilter;
- int wasFilter;
-
- /*
- * If this is the first step along the chain, we preserve the method
- * entries in the chain so that they do not get deleted out from under our
- * feet.
- */
-
- if (isFirst) {
- int i;
-
- for (i=0 ; i<contextPtr->numCallChain ; i++) {
- Tcl_Preserve(contextPtr->callChain[i].mPtr);
- }
- }
-
- /*
- * Save whether we were in a filter and set up whether we are now.
- */
-
- wasFilter = contextPtr->oPtr->flags & FILTER_HANDLING;
- if (isFilter || contextPtr->flags & FILTER_HANDLING) {
- contextPtr->oPtr->flags |= FILTER_HANDLING;
- } else {
- contextPtr->oPtr->flags &= ~FILTER_HANDLING;
- }
-
- /*
- * Run the method implementation.
- */
-
- result = mPtr->typePtr->callProc(mPtr->clientData, interp,
- (Tcl_ObjectContext) contextPtr, objc, objv);
-
- /*
- * Restore the old filter-ness, release any locks on method
- * implementations, and return the result code.
- */
-
- if (wasFilter) {
- contextPtr->oPtr->flags |= FILTER_HANDLING;
- } else {
- contextPtr->oPtr->flags &= ~FILTER_HANDLING;
- }
- if (isFirst) {
- int i;
-
- for (i=0 ; i<contextPtr->numCallChain ; i++) {
- Tcl_Release(contextPtr->callChain[i].mPtr);
- }
- }
- return result;
-}
-
-static void
-InitClassHierarchy(
- Foundation *fPtr,
- Class *classPtr)
-{
- if (classPtr == fPtr->objectCls) {
- return;
- }
- if (classPtr->classHierarchyEpoch != fPtr->epoch) {
- int i;
- Class *superPtr;
-
- if (classPtr->classHierarchy.num != 0) {
- ckfree((char *) classPtr->classHierarchy.list);
- }
- FOREACH(superPtr, classPtr->superclasses) {
- InitClassHierarchy(fPtr, superPtr);
- }
- if (i == 1) {
- Class **hierlist = (Class **)
- ckalloc(sizeof(Class*) * (1+superPtr->classHierarchy.num));
-
- hierlist[0] = superPtr;
- memcpy(hierlist+1, superPtr->classHierarchy.list,
- sizeof(Class*) * superPtr->classHierarchy.num);
- classPtr->classHierarchy.num = 1 + superPtr->classHierarchy.num;
- classPtr->classHierarchy.list = hierlist;
- classPtr->classHierarchyEpoch = fPtr->epoch;
- return;
- } else {
- int num = classPtr->superclasses.num, j = 0, k, realNum;
- Class **hierlist; /* Temporary work space. */
-
- FOREACH(superPtr, classPtr->superclasses) {
- num += superPtr->classHierarchy.num;
- }
- hierlist = (Class **) ckalloc(sizeof(Class *) * num);
- FOREACH(superPtr, classPtr->superclasses) {
- hierlist[j++] = superPtr;
- if (superPtr == fPtr->objectCls) {
- continue;
- }
- memcpy(hierlist+j, superPtr->classHierarchy.list,
- sizeof(Class *) * superPtr->classHierarchy.num);
- j += superPtr->classHierarchy.num;
- }
- realNum = num;
- for (j=0 ; j<num-1 ; j++) {
- for (k=num-1 ; k>j ; k--) {
- if (hierlist[j] == hierlist[k]) {
- hierlist[j] = NULL;
- realNum--;
- break;
- }
- }
- }
- classPtr->classHierarchy.num = realNum;
- classPtr->classHierarchy.list = (Class **)
- ckalloc(sizeof(Class *) * realNum);
- for (j=k=0 ; j<num ; j++) {
- if (hierlist[j] != NULL) {
- classPtr->classHierarchy.list[k++] = hierlist[j];
- }
- }
- ckfree((char *) hierlist);
- }
- }
-}
-
-/*
- * ----------------------------------------------------------------------
- *
- * TclOOGetSortedMethodList --
- *
- * Discovers the list of method names supported by an object.
- *
- * ----------------------------------------------------------------------
- */
-
-int
-TclOOGetSortedMethodList(
- Object *oPtr, /* The object to get the method names for. */
- int publicOnly, /* Whether we just want the public method
- * names. */
- const char ***stringsPtr) /* Where to write a pointer to the array of
- * strings to. */
-{
- Tcl_HashTable names;
- FOREACH_HASH_DECLS;
- int i;
- const char **strings;
- Class *mixinPtr;
- Tcl_Obj *namePtr;
- Method *mPtr;
- void *isWanted;
-
- Tcl_InitObjHashTable(&names);
-
- FOREACH_HASH(namePtr, mPtr, &oPtr->methods) {
- int isNew;
-
- hPtr = Tcl_CreateHashEntry(&names, (char *) namePtr, &isNew);
- if (isNew) {
- isWanted = (void *) (!publicOnly || mPtr->flags & PUBLIC_METHOD);
- Tcl_SetHashValue(hPtr, isWanted);
- }
- }
-
- AddClassMethodNames(oPtr->selfCls, publicOnly, &names);
- FOREACH(mixinPtr, oPtr->mixins) {
- AddClassMethodNames(mixinPtr, publicOnly, &names);
- }
-
- if (names.numEntries == 0) {
- Tcl_DeleteHashTable(&names);
- return 0;
- }
-
- strings = (const char **) ckalloc(sizeof(char *) * names.numEntries);
- i = 0;
- FOREACH_HASH(namePtr, isWanted, &names) {
- if (!publicOnly || isWanted) {
- strings[i++] = TclGetString(namePtr);
- }
- }
-
- /*
- * Note that 'i' may well be less than names.numEntries when we are
- * dealing with public method names.
- */
-
- qsort(strings, (unsigned) i, sizeof(char *), CmpStr);
-
- Tcl_DeleteHashTable(&names);
- *stringsPtr = strings;
- return i;
-}
-
-/* Comparator for GetSortedMethodList */
-static int
-CmpStr(
- const void *ptr1,
- const void *ptr2)
-{
- const char **strPtr1 = (const char **) ptr1;
- const char **strPtr2 = (const char **) ptr2;
-
- return TclpUtfNcmp2(*strPtr1, *strPtr2, strlen(*strPtr1)+1);
-}
-
-/*
- * ----------------------------------------------------------------------
- *
- * AddClassMethodNames --
- *
- * Adds the method names defined by a class (or its superclasses) to the
- * collection being built. The collection is built in a hash table to
- * ensure that duplicates are excluded. Helper for GetSortedMethodList().
- *
- * ----------------------------------------------------------------------
- */
-
-static void
-AddClassMethodNames(
- Class *clsPtr, /* Class to get method names from. */
- const int publicOnly, /* Whether we are interested in just the
- * public method names. */
- Tcl_HashTable *const namesPtr)
- /* Reference to the hash table to put the
- * information in. The hash table maps the
- * Tcl_Obj * method name to an integral value
- * describing whether the method is wanted.
- * This ensures that public/private override
- * semantics are handled correctly.*/
-{
- /*
- * Scope all declarations so that the compiler can stand a good chance of
- * making the recursive step highly efficient. We also hand-implement the
- * tail-recursive case using a while loop; C compilers typically cannot do
- * tail-recursion optimization usefully.
- */
-
- if (clsPtr->mixins.num != 0) {
- Class *mixinPtr;
- int i;
-
- // TODO: Beware of infinite loops!
- FOREACH(mixinPtr, clsPtr->mixins) {
- AddClassMethodNames(mixinPtr, publicOnly, namesPtr);
- }
- }
-
- while (1) {
- FOREACH_HASH_DECLS;
- Tcl_Obj *namePtr;
- Method *mPtr;
-
- FOREACH_HASH(namePtr, mPtr, &clsPtr->classMethods) {
- int isNew;
-
- hPtr = Tcl_CreateHashEntry(namesPtr, (char *) namePtr, &isNew);
- if (isNew) {
- int isWanted = (!publicOnly || mPtr->flags & PUBLIC_METHOD);
-
- Tcl_SetHashValue(hPtr, (void *) isWanted);
- }
- }
-
- if (clsPtr->superclasses.num != 1) {
- break;
- }
- clsPtr = clsPtr->superclasses.list[0];
- }
- if (clsPtr->superclasses.num != 0) {
- Class *superPtr;
- int i;
-
- FOREACH(superPtr, clsPtr->superclasses) {
- AddClassMethodNames(superPtr, publicOnly, namesPtr);
- }
- }
-}
-
-/*
- * ----------------------------------------------------------------------
- *
- * TclOOGetCallContext --
- *
- * Responsible for constructing the call context, an ordered list of all
- * method implementations to be called as part of a method invokation.
- * This method is central to the whole operation of the OO system.
- *
- * ----------------------------------------------------------------------
- */
-
-CallContext *
-TclOOGetCallContext(
- Foundation *fPtr, /* The foundation of the object system. */
- Object *oPtr, /* The object to get the context for. */
- Tcl_Obj *methodNameObj, /* The name of the method to get the context
- * for. NULL when getting a constructor or
- * destructor chain. */
- int flags, /* What sort of context are we looking for.
- * Only the bits OO_PUBLIC_METHOD,
- * CONSTRUCTOR, DESTRUCTOR and FILTER_HANDLING
- * are useful. */
- Tcl_HashTable *cachePtr) /* Where to cache the chain. Ignored for both
- * constructors and destructors. */
-{
- CallContext *contextPtr;
- int i, count, doFilters;
- Tcl_HashEntry *hPtr;
- Tcl_HashTable doneFilters;
-
- if (flags&(SPECIAL|FILTER_HANDLING) || (oPtr->flags&FILTER_HANDLING)) {
- hPtr = NULL;
- doFilters = 0;
- } else {
- doFilters = 1;
- hPtr = Tcl_FindHashEntry(cachePtr, (char *) methodNameObj);
- if (hPtr != NULL && Tcl_GetHashValue(hPtr) != NULL) {
- contextPtr = Tcl_GetHashValue(hPtr);
- Tcl_SetHashValue(hPtr, NULL);
- if ((contextPtr->globalEpoch == fPtr->epoch)
- && (contextPtr->localEpoch == oPtr->epoch)) {
- return contextPtr;
- }
- TclOODeleteContext(contextPtr);
- }
- }
- contextPtr = (CallContext *) ckalloc(sizeof(CallContext));
- contextPtr->numCallChain = 0;
- contextPtr->callChain = contextPtr->staticCallChain;
- contextPtr->filterLength = 0;
- contextPtr->globalEpoch = fPtr->epoch;
- contextPtr->localEpoch = oPtr->epoch;
- contextPtr->flags = 0;
- contextPtr->skip = 2;
- if (flags & (PUBLIC_METHOD | SPECIAL | FILTER_HANDLING)) {
- contextPtr->flags |= flags & (PUBLIC_METHOD|SPECIAL|FILTER_HANDLING);
- }
- contextPtr->oPtr = oPtr;
- contextPtr->index = 0;
-
- /*
- * Ensure that the class hierarchy is trivially iterable.
- */
-
- InitClassHierarchy(fPtr, oPtr->selfCls);
-
- /*
- * Add all defined filters (if any, and if we're going to be processing
- * them; they're not processed for constructors, destructors or when we're
- * in the middle of processing a filter).
- */
-
- if (doFilters) {
- Tcl_Obj *filterObj;
- Class *mixinPtr;
-
- doFilters = 1;
- Tcl_InitObjHashTable(&doneFilters);
- FOREACH(mixinPtr, oPtr->mixins) {
- AddClassFiltersToCallContext(oPtr, mixinPtr, contextPtr,
- &doneFilters);
- }
- FOREACH(filterObj, oPtr->filters) {
- AddSimpleChainToCallContext(oPtr, filterObj, contextPtr,
- &doneFilters, 0);
- }
- AddClassFiltersToCallContext(oPtr, oPtr->selfCls, contextPtr,
- &doneFilters);
- Tcl_DeleteHashTable(&doneFilters);
- }
- count = contextPtr->filterLength = contextPtr->numCallChain;
-
- /*
- * Add the actual method implementations.
- */
-
- AddSimpleChainToCallContext(oPtr, methodNameObj, contextPtr, NULL, flags);
-
- /*
- * Check to see if the method has no implementation. If so, we probably
- * need to add in a call to the unknown method. Otherwise, set up the
- * cacheing of the method implementation (if relevant).
- */
-
- if (count == contextPtr->numCallChain) {
- /*
- * Method does not actually exist. If we're dealing with constructors
- * or destructors, this isn't a problem.
- */
-
- if (flags & SPECIAL) {
- TclOODeleteContext(contextPtr);
- return NULL;
- }
- AddSimpleChainToCallContext(oPtr, fPtr->unknownMethodNameObj,
- contextPtr, NULL, 0);
- contextPtr->flags |= OO_UNKNOWN_METHOD;
- contextPtr->globalEpoch = -1;
- if (count == contextPtr->numCallChain) {
- TclOODeleteContext(contextPtr);
- return NULL;
- }
- } else if (doFilters) {
- if (hPtr == NULL) {
- hPtr = Tcl_CreateHashEntry(cachePtr, (char *) methodNameObj, &i);
- }
- Tcl_SetHashValue(hPtr, NULL);
- }
- return contextPtr;
-}
-
-/*
- * ----------------------------------------------------------------------
- *
- * AddClassFiltersToCallContext --
- *
- * Logic to make extracting all the filters from the class context much
- * easier.
- *
- * ----------------------------------------------------------------------
- */
-
-static void
-AddClassFiltersToCallContext(
- Object *const oPtr, /* Object that the filters operate on. */
- Class *clsPtr, /* Class to get the filters from. */
- CallContext *const contextPtr,
- /* Context to fill with call chain entries. */
- Tcl_HashTable *const doneFilters)
- /* Where to record what filters have been
- * processed. Keys are objects, values are
- * ignored. */
-{
- int i;
- Class *superPtr;
- Tcl_Obj *filterObj;
-
- tailRecurse:
- if (clsPtr == NULL) {
- return;
- }
-
- /*
- * Add all the class filters from the current class. Note that the filters
- * are added starting at the object root, as this allows the object to
- * override how filters work to extend their behaviour.
- */
-
- FOREACH(filterObj, clsPtr->filters) {
- int isNew;
-
- (void) Tcl_CreateHashEntry(doneFilters, (char *) filterObj, &isNew);
- if (isNew) {
- AddSimpleChainToCallContext(oPtr, filterObj, contextPtr,
- doneFilters, 0);
- }
- }
-
- /*
- * Now process the recursive case. Notice the tail-call optimization.
- */
-
- switch (clsPtr->superclasses.num) {
- case 1:
- clsPtr = clsPtr->superclasses.list[0];
- goto tailRecurse;
- default:
- FOREACH(superPtr, clsPtr->superclasses) {
- AddClassFiltersToCallContext(oPtr, superPtr, contextPtr,
- doneFilters);
- }
- case 0:
- return;
- }
-}
-
-/*
- * ----------------------------------------------------------------------
- *
- * AddSimpleChainToCallContext --
- *
- * The core of the call-chain construction engine, this handles calling a
- * particular method on a particular object. Note that filters and
- * unknown handling are already handled by the logic that uses this
- * function.
- *
- * ----------------------------------------------------------------------
- */
-
-static void
-AddSimpleChainToCallContext(
- Object *oPtr, /* Object to add call chain entries for. */
- Tcl_Obj *methodNameObj, /* Name of method to add the call chain
- * entries for. */
- CallContext *contextPtr, /* Where to add the call chain entries. */
- Tcl_HashTable *doneFilters, /* Where to record what call chain entries
- * have been processed. */
- int flags) /* What sort of call chain are we building. */
-{
- int i;
-
- if (!(flags & (KNOWN_STATE | SPECIAL))) {
- Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&oPtr->methods,
- (char *) methodNameObj);
-
- if (hPtr != NULL) {
- Method *mPtr = Tcl_GetHashValue(hPtr);
-
- if (flags & PUBLIC_METHOD) {
- if (!(mPtr->flags & PUBLIC_METHOD)) {
- return;
- } else {
- flags |= DEFINITE_PUBLIC;
- }
- } else {
- flags |= DEFINITE_PRIVATE;
- }
- }
- }
- if (!(flags & SPECIAL)) {
- Tcl_HashEntry *hPtr;
- Class *mixinPtr, *superPtr;
-
- FOREACH(mixinPtr, oPtr->mixins) {
- AddSimpleClassChainToCallContext(mixinPtr, methodNameObj,
- contextPtr, doneFilters, flags);
- }
- FOREACH(mixinPtr, oPtr->selfCls->mixins) {
- AddSimpleClassChainToCallContext(mixinPtr, methodNameObj,
- contextPtr, doneFilters, flags);
- }
- FOREACH(superPtr, oPtr->selfCls->classHierarchy) {
- int j=i;// HACK: save index so we can nest FOREACHes
- FOREACH(mixinPtr, superPtr->mixins) {
- AddSimpleClassChainToCallContext(mixinPtr, methodNameObj,
- contextPtr, doneFilters, flags);
- }
- i=j;
- }
- hPtr = Tcl_FindHashEntry(&oPtr->methods, (char *) methodNameObj);
- if (hPtr != NULL) {
- AddMethodToCallChain(Tcl_GetHashValue(hPtr), contextPtr,
- doneFilters);
- }
- }
- AddSimpleClassChainToCallContext(oPtr->selfCls, methodNameObj, contextPtr,
- doneFilters, flags);
-}
-
-/*
- * ----------------------------------------------------------------------
- *
- * AddSimpleClassChainToCallContext --
- *
- * Construct a call-chain from a class hierarchy.
- *
- * ----------------------------------------------------------------------
- */
-
-static void
-AddSimpleClassChainToCallContext(
- Class *classPtr, /* Class to add the call chain entries for. */
- Tcl_Obj *const methodNameObj,
- /* Name of method to add the call chain
- * entries for. */
- CallContext *const contextPtr,
- /* Where to add the call chain entries. */
- Tcl_HashTable *const doneFilters,
- /* Where to record what call chain entries
- * have been processed. */
- int flags) /* What sort of call chain are we building. */
-{
- /*
- * We hard-code the tail-recursive form. It's by far the most common case
- * *and* it is much more gentle on the stack.
- */
-
- tailRecurse:
- if (flags & CONSTRUCTOR) {
- AddMethodToCallChain(classPtr->constructorPtr, contextPtr,
- doneFilters);
- } else if (flags & DESTRUCTOR) {
- AddMethodToCallChain(classPtr->destructorPtr, contextPtr,
- doneFilters);
- } else {
- Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&classPtr->classMethods,
- (char *) methodNameObj);
-
- if (hPtr != NULL) {
- register Method *mPtr = Tcl_GetHashValue(hPtr);
-
- if (!(flags & KNOWN_STATE)) {
- if (flags & PUBLIC_METHOD) {
- if (mPtr->flags & PUBLIC_METHOD) {
- flags |= DEFINITE_PUBLIC;
- } else {
- return;
- }
- } else {
- flags |= DEFINITE_PRIVATE;
- }
- }
- AddMethodToCallChain(mPtr, contextPtr, doneFilters);
- }
- }
-
- switch (classPtr->superclasses.num) {
- case 1:
- classPtr = classPtr->superclasses.list[0];
- goto tailRecurse;
- default:
- {
- int i;
- Class *superPtr;
-
- FOREACH(superPtr, classPtr->superclasses) {
- AddSimpleClassChainToCallContext(superPtr, methodNameObj,
- contextPtr, doneFilters, flags);
- }
- }
- case 0:
- return;
- }
-}
-
-/*
- * ----------------------------------------------------------------------
- *
- * AddMethodToCallChain --
- *
- * Utility method that manages the adding of a particular method
- * implementation to a call-chain.
- *
- * ----------------------------------------------------------------------
- */
-
-static void
-AddMethodToCallChain(
- Method *mPtr, /* Actual method implementation to add to call
- * chain (or NULL, a no-op). */
- CallContext *contextPtr, /* The call chain to add the method
- * implementation to. */
- Tcl_HashTable *doneFilters) /* Where to record what filters have been
- * processed. If NULL, not processing filters.
- * Note that this function does not update
- * this hashtable. */
-{
- int i;
-
- /*
- * Return if this is just an entry used to record whether this is a public
- * method. If so, there's nothing real to call and so nothing to add to
- * the call chain.
- */
-
- if (mPtr == NULL || mPtr->typePtr == NULL) {
- return;
- }
-
- /*
- * First test whether the method is already in the call chain. Skip over
- * any leading filters.
- */
-
- for (i=contextPtr->filterLength ; i<contextPtr->numCallChain ; i++) {
- if (contextPtr->callChain[i].mPtr == mPtr
- && contextPtr->callChain[i].isFilter == (doneFilters!=NULL)) {
- /*
- * Call chain semantics states that methods come as *late* in the
- * call chain as possible. This is done by copying down the
- * following methods. Note that this does not change the number of
- * method invokations in the call chain; it just rearranges them.
- */
-
- for (; i+1<contextPtr->numCallChain ; i++) {
- contextPtr->callChain[i] = contextPtr->callChain[i+1];
- }
- contextPtr->callChain[i].mPtr = mPtr;
- contextPtr->callChain[i].isFilter = (doneFilters != NULL);
- return;
- }
- }
-
- /*
- * Need to really add the method. This is made a bit more complex by the
- * fact that we are using some "static" space initially, and only start
- * realloc-ing if the chain gets long.
- */
-
- if (contextPtr->numCallChain == CALL_CHAIN_STATIC_SIZE) {
- contextPtr->callChain = (struct MInvoke *)
- ckalloc(sizeof(struct MInvoke)*(contextPtr->numCallChain+1));
- memcpy(contextPtr->callChain, contextPtr->staticCallChain,
- sizeof(struct MInvoke) * (contextPtr->numCallChain + 1));
- } else if (contextPtr->numCallChain > CALL_CHAIN_STATIC_SIZE) {
- contextPtr->callChain = (struct MInvoke *)
- ckrealloc((char *) contextPtr->callChain,
- sizeof(struct MInvoke) * (contextPtr->numCallChain + 1));
- }
- contextPtr->callChain[contextPtr->numCallChain].mPtr = mPtr;
- contextPtr->callChain[contextPtr->numCallChain].isFilter =
- (doneFilters != NULL);
- contextPtr->numCallChain++;
-}
-
-/*
- * Local Variables:
- * mode: c
- * c-basic-offset: 4
- * fill-column: 78
- * End:
- */
diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c
deleted file mode 100644
index 9f2635b..0000000
--- a/generic/tclOODefineCmds.c
+++ /dev/null
@@ -1,953 +0,0 @@
-/*
- * tclOODefineCmds.c --
- *
- * This file contains the implementation of the ::oo::define command,
- * part of the object-system core (NB: not Tcl_Obj, but ::oo).
- *
- * Copyright (c) 2006 by Donal K. Fellows
- *
- * See the file "license.terms" for information on usage and redistribution of
- * this file, and for a DISCLAIMER OF ALL WARRANTIES.
- *
- * RCS: @(#) $Id: tclOODefineCmds.c,v 1.2 2006/10/20 14:04:01 dkf Exp $
- */
-
-#include "tclInt.h"
-#include "tclOO.h"
-
-static Object * GetDefineCmdContext(Tcl_Interp *interp);
-
-int
-TclOODefineObjCmd(
- ClientData clientData,
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const *objv)
-{
- CallFrame *framePtr, **framePtrPtr;
- Foundation *fPtr = ((Interp *) interp)->ooFoundation;
- int result;
- Object *oPtr;
-
- if (objc < 3) {
- Tcl_WrongNumArgs(interp, 1, objv, "objectName arg ?arg ...?");
- return TCL_ERROR;
- }
-
- oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
- if (oPtr == NULL) {
- return TCL_ERROR;
- }
-
- /*
- * Make the oo::define namespace the current namespace and evaluate the
- * command(s).
- */
-
- /* This is needed to satisfy GCC 3.3's strict aliasing rules */
- framePtrPtr = &framePtr;
- result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr,
- (Tcl_Namespace *) fPtr->defineNs, FRAME_IS_OO_DEFINE);
- if (result != TCL_OK) {
- return TCL_ERROR;
- }
- framePtr->ooContextPtr = oPtr;
- framePtr->objc = objc;
- framePtr->objv = objv; /* Reference counts do not need to be
- * incremented here. */
-
- if (objc == 3) {
- result = Tcl_EvalObjEx(interp, objv[2], 0);
-
- if (result == TCL_ERROR) {
- int length;
- const char *objName = Tcl_GetStringFromObj(objv[1], &length);
- int limit = 200;
- int overflow = (length > limit);
-
- TclFormatToErrorInfo(interp,
- "\n (in definition script for object \"%.*s%s\" line %d)",
- (overflow ? limit : length), objName,
- (overflow ? "..." : ""), interp->errorLine);
- }
- } else {
- Tcl_Obj *objPtr, *obj2Ptr, **objs;
- Interp *iPtr = (Interp *) interp;
- Tcl_Command cmd;
- int dummy;
-
- /*
- * More than one argument: fire them through the ensemble processing
- * engine so that everything appears to be good and proper in error
- * messages. Note that we cannot just concatenate and send through
- * Tcl_EvalObjEx, as that doesn't do ensemble processing, and we
- * cannot go through Tcl_EvalObjv without the extra work to pre-find
- * the command, as that finds command names in the wrong namespace at
- * the moment. Ugly!
- */
-
- if (iPtr->ensembleRewrite.sourceObjs == NULL) {
- iPtr->ensembleRewrite.sourceObjs = objv;
- iPtr->ensembleRewrite.numRemovedObjs = 3;
- iPtr->ensembleRewrite.numInsertedObjs = 1;
- } else {
- int ni = iPtr->ensembleRewrite.numInsertedObjs;
- if (ni < 3) {
- iPtr->ensembleRewrite.numRemovedObjs += 3 - ni;
- } else {
- iPtr->ensembleRewrite.numInsertedObjs -= 2;
- }
- }
-
- /*
- * Build the list of arguments using a Tcl_Obj as a workspace. See
- * comments above for why these contortions are necessary.
- */
-
- TclNewObj(objPtr);
- TclNewObj(obj2Ptr);
- cmd = Tcl_FindCommand(interp, TclGetString(objv[2]), fPtr->defineNs,
- TCL_NAMESPACE_ONLY);
- if (cmd == NULL) {
- /* punt this case! */
- Tcl_AppendObjToObj(obj2Ptr, objv[2]);
- } else {
- Tcl_GetCommandFullName(interp, cmd, obj2Ptr);
- }
- Tcl_ListObjAppendElement(NULL, objPtr, obj2Ptr);
- Tcl_ListObjReplace(NULL, objPtr, 1, 0, objc-3, objv+3);
- Tcl_ListObjGetElements(NULL, objPtr, &dummy, &objs);
-
- result = Tcl_EvalObjv(interp, objc-2, objs, TCL_EVAL_INVOKE);
- TclDecrRefCount(objPtr);
- }
-
- /*
- * Restore the previous "current" namespace.
- */
-
- TclPopStackFrame(interp);
- return result;
-}
-
-static Object *
-GetDefineCmdContext(
- Tcl_Interp *interp)
-{
- Interp *iPtr = (Interp *) interp;
-
- if ((iPtr->framePtr == NULL)
- || (iPtr->framePtr->isProcCallFrame != FRAME_IS_OO_DEFINE)) {
- Tcl_AppendResult(interp, "this command may only be called from within"
- " the context of the ::oo::define command", NULL);
- return NULL;
- }
- return (Object *) iPtr->framePtr->ooContextPtr;
-}
-
-int
-TclOODefineConstructorObjCmd(
- ClientData clientData,
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const *objv)
-{
- Object *oPtr;
- Class *clsPtr;
- int bodyLength;
-
- if (objc != 3) {
- Tcl_WrongNumArgs(interp, 1, objv, "arguments body");
- return TCL_ERROR;
- }
-
- /*
- * Extract and validate the context, which is the class that we wish to
- * modify.
- */
-
- oPtr = GetDefineCmdContext(interp);
- if (oPtr == NULL) {
- return TCL_ERROR;
- }
- if (oPtr->classPtr == NULL) {
- Tcl_AppendResult(interp, "only classes may have constructors defined",
- NULL);
- return TCL_ERROR;
- }
- clsPtr = oPtr->classPtr;
-
- (void) Tcl_GetStringFromObj(objv[2], &bodyLength);
- if (bodyLength > 0) {
- /*
- * Create the method structure.
- */
-
- Method *mPtr;
-
- mPtr = TclOONewProcClassMethod(interp, clsPtr, 1, NULL, objv[1],
- objv[2]);
- if (mPtr == NULL) {
- return TCL_ERROR;
- }
-
- /*
- * Place the method structure in the class record. Note that we might
- * not immediately delete the constructor as this might be being done
- * during execution of the constructor itself.
- */
-
- TclOODeleteMethod(clsPtr->constructorPtr);
- clsPtr->constructorPtr = mPtr;
- } else {
- /*
- * Delete the constructor method record and set the field in the class
- * record to NULL.
- */
-
- TclOODeleteMethod(clsPtr->constructorPtr);
- clsPtr->constructorPtr = NULL;
- }
-
- return TCL_OK;
-}
-
-int
-TclOODefineCopyObjCmd(
- ClientData clientData,
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const *objv)
-{
- Tcl_Object oPtr, o2Ptr;
-
- if (objc > 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "?targetName?");
- return TCL_ERROR;
- }
-
- oPtr = (Tcl_Object) GetDefineCmdContext(interp);
- if (oPtr == NULL) {
- return TCL_ERROR;
- }
-
- /*
- * Create a cloned object of the correct class. Note that constructors are
- * not called. Also note that we must resolve the object name ourselves
- * because we do not want to create the object in the current namespace,
- * but rather in the context of the namespace of the caller of the overall
- * [oo::define] command.
- */
-
- if (objc == 1) {
- o2Ptr = Tcl_CopyObjectInstance(interp, oPtr, NULL);
- } else {
- char *name;
- Tcl_DString buffer;
-
- name = TclGetString(objv[1]);
- Tcl_DStringInit(&buffer);
- if (name[0]!=':' || name[1]!=':') {
- Interp *iPtr = (Interp *) interp;
- CallFrame *callerFramePtr = iPtr->varFramePtr->callerVarPtr;
-
- if (callerFramePtr != NULL) {
- Tcl_DStringAppend(&buffer,
- callerFramePtr->nsPtr->fullName, -1);
- }
- Tcl_DStringAppend(&buffer, "::", 2);
- Tcl_DStringAppend(&buffer, name, -1);
- name = Tcl_DStringValue(&buffer);
- }
- o2Ptr = Tcl_CopyObjectInstance(interp, oPtr, name);
- Tcl_DStringFree(&buffer);
- }
-
- if (o2Ptr == NULL) {
- return TCL_ERROR;
- }
-
- /*
- * Return the name of the cloned object.
- */
-
- Tcl_GetCommandFullName(interp, Tcl_GetObjectCommand(o2Ptr),
- Tcl_GetObjResult(interp));
- return TCL_OK;
-}
-
-int
-TclOODefineDestructorObjCmd(
- ClientData clientData,
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const *objv)
-{
- Object *oPtr;
- Class *clsPtr;
- int bodyLength;
-
- if (objc != 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "body");
- return TCL_ERROR;
- }
-
- oPtr = GetDefineCmdContext(interp);
- if (oPtr == NULL) {
- return TCL_ERROR;
- }
- if (oPtr->classPtr == NULL) {
- Tcl_AppendResult(interp, "only classes may have destructors defined",
- NULL);
- return TCL_ERROR;
- }
- clsPtr = oPtr->classPtr;
-
- (void) Tcl_GetStringFromObj(objv[1], &bodyLength);
- if (bodyLength > 0) {
- /*
- * Create the method structure.
- */
-
- Method *mPtr;
-
- mPtr = TclOONewProcClassMethod(interp, clsPtr, 1, NULL, NULL,
- objv[1]);
- if (mPtr == NULL) {
- return TCL_ERROR;
- }
-
- /*
- * Place the method structure in the class record. Note that we might
- * not immediately delete the destructor as this might be being done
- * during execution of the destructor itself.
- */
-
- TclOODeleteMethod(clsPtr->destructorPtr);
- clsPtr->destructorPtr = mPtr;
- } else {
- /*
- * Delete the destructor method record and set the field in the class
- * record to NULL.
- */
-
- TclOODeleteMethod(clsPtr->destructorPtr);
- clsPtr->destructorPtr = NULL;
- }
-
- return TCL_OK;
-}
-
-int
-TclOODefineExportObjCmd(
- ClientData clientData,
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const *objv)
-{
- int isSelfExport = (clientData != NULL);
- Object *oPtr;
- Method *mPtr;
- Tcl_HashEntry *hPtr;
- Class *clsPtr;
- int i, isNew;
-
- if (objc < 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "name ?name ...?");
- return TCL_ERROR;
- }
-
- oPtr = GetDefineCmdContext(interp);
- if (oPtr == NULL) {
- return TCL_ERROR;
- }
- clsPtr = oPtr->classPtr;
- isSelfExport |= (clsPtr == NULL);
-
- for (i=1 ; i<objc ; i++) {
- if (isSelfExport) {
- hPtr = Tcl_CreateHashEntry(&oPtr->methods, (char *) objv[i],
- &isNew);
- } else {
- hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, (char*) objv[i],
- &isNew);
- }
-
- if (isNew) {
- mPtr = (Method *) ckalloc(sizeof(Method));
- memset(mPtr, 0, sizeof(Method));
- Tcl_SetHashValue(hPtr, mPtr);
- } else {
- mPtr = Tcl_GetHashValue(hPtr);
- }
- mPtr->flags |= PUBLIC_METHOD;
- }
- if (isSelfExport) {
- oPtr->epoch++;
- } else {
- ((Interp *)interp)->ooFoundation->epoch++;
- }
- return TCL_OK;
-}
-
-int
-TclOODefineFilterObjCmd(
- ClientData clientData,
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const *objv)
-{
- int isSelfFilter = (clientData != NULL);
- Object *oPtr;
- int i;
-
- oPtr = GetDefineCmdContext(interp);
- if (oPtr == NULL) {
- return TCL_ERROR;
- }
- isSelfFilter |= (oPtr->classPtr == NULL);
-
- if (!isSelfFilter) {
- if (oPtr->classPtr->filters.num) {
- Tcl_Obj *filterObj;
-
- FOREACH(filterObj, oPtr->classPtr->filters) {
- TclDecrRefCount(filterObj);
- }
- }
-
- if (objc == 1) {
- // deleting filters
- ckfree((char *) oPtr->classPtr->filters.list);
- oPtr->classPtr->filters.list = NULL;
- oPtr->classPtr->filters.num = 0;
- } else {
- // creating filters
- Tcl_Obj **filters;
-
- if (oPtr->classPtr->filters.num == 0) {
- filters = (Tcl_Obj **) ckalloc(sizeof(Tcl_Obj *) * (objc-1));
- } else {
- filters = (Tcl_Obj **) ckrealloc(
- (char *) oPtr->classPtr->filters.list,
- sizeof(Tcl_Obj *) * (objc-1));
- }
- for (i=1 ; i<objc ; i++) {
- filters[i-1] = objv[i];
- Tcl_IncrRefCount(objv[i]);
- }
- oPtr->classPtr->filters.list = filters;
- oPtr->classPtr->filters.num = objc-1;
- }
- // may be many objects affected
- ((Interp *)interp)->ooFoundation->epoch++;
- } else {
- if (oPtr->filters.num) {
- Tcl_Obj *filterObj;
-
- FOREACH(filterObj, oPtr->filters) {
- TclDecrRefCount(filterObj);
- }
- }
- if (objc == 1) {
- // deleting filters
- ckfree((char *) oPtr->filters.list);
- oPtr->filters.list = NULL;
- oPtr->filters.num = 0;
- } else {
- // creating filters
- Tcl_Obj **filters;
-
- if (oPtr->filters.num == 0) {
- filters = (Tcl_Obj **) ckalloc(sizeof(Tcl_Obj *) * (objc-1));
- } else {
- filters = (Tcl_Obj **) ckrealloc((char *) oPtr->filters.list,
- sizeof(Tcl_Obj *) * (objc-1));
- }
- for (i=1 ; i<objc ; i++) {
- filters[i-1] = objv[i];
- Tcl_IncrRefCount(objv[i]);
- }
- oPtr->filters.list = filters;
- oPtr->filters.num = objc-1;
- }
- oPtr->epoch++; // per-object
- }
- return TCL_OK;
-}
-
-int
-TclOODefineForwardObjCmd(
- ClientData clientData,
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const *objv)
-{
- int isSelfForward = (clientData != NULL);
- Object *oPtr;
- Method *mPtr;
- int isPublic;
- Tcl_Obj *prefixObj;
-
- if (objc < 3) {
- Tcl_WrongNumArgs(interp, 1, objv, "name cmdName ?arg ...?");
- return TCL_ERROR;
- }
-
- oPtr = GetDefineCmdContext(interp);
- if (oPtr == NULL) {
- return TCL_ERROR;
- }
- isSelfForward |= (oPtr->classPtr == NULL);
- isPublic = Tcl_StringMatch(TclGetString(objv[1]), "[a-z]*");
-
- /*
- * Create the method structure.
- */
-
- prefixObj = Tcl_NewListObj(objc-2, objv+2);
- if (isSelfForward) {
- mPtr = TclOONewForwardMethod(interp, oPtr, isPublic, objv[1],
- prefixObj);
- } else {
- mPtr = TclOONewForwardClassMethod(interp, oPtr->classPtr, isPublic,
- objv[1], prefixObj);
- }
- if (mPtr == NULL) {
- TclDecrRefCount(prefixObj);
- return TCL_ERROR;
- }
- return TCL_OK;
-}
-
-int
-TclOODefineMethodObjCmd(
- ClientData clientData,
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const *objv)
-{
- int isSelfMethod = (clientData != NULL);
- Object *oPtr;
- int bodyLength;
-
- if (objc != 4) {
- Tcl_WrongNumArgs(interp, 1, objv, "name args body");
- return TCL_ERROR;
- }
-
- oPtr = GetDefineCmdContext(interp);
- if (oPtr == NULL) {
- return TCL_ERROR;
- }
- isSelfMethod |= (oPtr->classPtr == NULL);
-
- (void) Tcl_GetStringFromObj(objv[3], &bodyLength);
- if (bodyLength > 0) {
- /*
- * Create the method structure.
- */
-
- Method *mPtr;
- int isPublic = Tcl_StringMatch(TclGetString(objv[1]), "[a-z]*");
-
- if (isSelfMethod) {
- mPtr = TclOONewProcMethod(interp, oPtr, isPublic, objv[1],
- objv[2], objv[3]);
- } else {
- mPtr = TclOONewProcClassMethod(interp, oPtr->classPtr, isPublic,
- objv[1], objv[2], objv[3]);
- }
- if (mPtr == NULL) {
- return TCL_ERROR;
- }
- } else {
- /*
- * Delete the method structure from the appropriate hash table.
- */
-
- Tcl_HashEntry *hPtr;
-
- if (isSelfMethod) {
- hPtr = Tcl_FindHashEntry(&oPtr->methods, (char *)objv[1]);
- } else {
- hPtr = Tcl_FindHashEntry(&oPtr->classPtr->classMethods,
- (char *)objv[1]);
- }
- if (hPtr != NULL) {
- Method *mPtr = (Method *) Tcl_GetHashValue(hPtr);
-
- Tcl_DeleteHashEntry(hPtr);
- TclOODeleteMethod(mPtr);
- }
- }
-
- return TCL_OK;
-}
-
-int
-TclOODefineMixinObjCmd(
- ClientData clientData,
- Tcl_Interp *interp,
- const int objc,
- Tcl_Obj *const *objv)
-{
- int isSelfMixin = (clientData != NULL);
- Object *oPtr = GetDefineCmdContext(interp);
- Class *mixinPtr;
- int i;
-
- if (oPtr == NULL) {
- return TCL_ERROR;
- }
- isSelfMixin |= (oPtr->classPtr == NULL);
-
- if (isSelfMixin) {
- if (objc == 1) {
- if (oPtr->mixins.num != 0) {
- FOREACH(mixinPtr, oPtr->mixins) {
- TclOORemoveFromInstances(oPtr, mixinPtr);
- }
- ckfree((char *) oPtr->mixins.list);
- oPtr->mixins.num = 0;
- }
- } else {
- Class **mixins = (Class **) ckalloc(sizeof(Class *) * (objc-1));
-
- for (i=1 ; i<objc ; i++) {
- Object *o2Ptr;
-
- o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[i]);
- if (o2Ptr == NULL) {
- goto freeAndErrorSelf;
- }
- if (o2Ptr->classPtr == NULL) {
- Tcl_AppendResult(interp, "may only mix in classes; \"",
- TclGetString(objv[i]), "\" is not a class", NULL);
- freeAndErrorSelf:
- ckfree((char *) mixins);
- return TCL_ERROR;
- }
- mixins[i-1] = o2Ptr->classPtr;
- }
- if (oPtr->mixins.num != 0) {
- FOREACH(mixinPtr, oPtr->mixins) {
- if (mixinPtr != oPtr->selfCls) {
- TclOORemoveFromInstances(oPtr, mixinPtr);
- }
- }
- ckfree((char *) oPtr->mixins.list);
- }
- oPtr->mixins.num = objc-1;
- oPtr->mixins.list = mixins;
- FOREACH(mixinPtr, oPtr->mixins) {
- if (mixinPtr != oPtr->selfCls) {
- TclOOAddToInstances(oPtr, mixinPtr);
- }
- }
- }
- oPtr->epoch++;
- } else {
- register Class *clsPtr = oPtr->classPtr;
-
- if (objc == 1) {
- if (clsPtr->mixins.num != 0) {
- FOREACH(mixinPtr, clsPtr->mixins) {
- TclOORemoveFromMixinSubs(clsPtr, mixinPtr);
- }
- ckfree((char *) clsPtr->mixins.list);
- clsPtr->mixins.num = 0;
- }
- } else {
- Class **mixins = (Class **) ckalloc(sizeof(Class *) * (objc-1));
-
- for (i=1 ; i<objc ; i++) {
- Object *o2Ptr;
-
- o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[i]);
- if (o2Ptr == NULL) {
- goto freeAndErrorClass;
- }
- if (o2Ptr->classPtr == NULL) {
- Tcl_AppendResult(interp, "may only mix in classes; \"",
- TclGetString(objv[i]), "\" is not a class", NULL);
- freeAndErrorClass:
- ckfree((char *) mixins);
- return TCL_ERROR;
- }
- mixins[i-1] = o2Ptr->classPtr;
- }
- if (clsPtr->mixins.num != 0) {
- FOREACH(mixinPtr, clsPtr->mixins) {
- TclOORemoveFromMixinSubs(clsPtr, mixinPtr);
- }
- ckfree((char *) clsPtr->mixins.list);
- }
- clsPtr->mixins.num = objc-1;
- clsPtr->mixins.list = mixins;
- FOREACH(mixinPtr, clsPtr->mixins) {
- TclOOAddToMixinSubs(clsPtr, mixinPtr);
- }
- }
- ((Interp *)interp)->ooFoundation->epoch++;
- }
- return TCL_OK;
-}
-
-#ifdef SUPPORT_OO_PARAMETERS
-// Not sure whether we want to retain this in the core oo system since it is
-// easy to add "after market".
-int
-TclOODefineParameterObjCmd(
- ClientData clientData,
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const *objv)
-{
- Object *oPtr = GetDefineCmdContext(interp);
-
- if (oPtr == NULL) {
- return TCL_ERROR;
- }
-
- /*
- * Must nail down the semantics of this!
- */
-
- Tcl_AppendResult(interp, "TODO: not yet finished", NULL);
- return TCL_ERROR;
-}
-#endif
-
-int
-TclOODefineSelfClassObjCmd(
- ClientData clientData,
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const *objv)
-{
- Object *oPtr, *o2Ptr;
- Foundation *fPtr = ((Interp *)interp)->ooFoundation;
-
- /*
- * Parse the context to get the object to operate on.
- */
-
- oPtr = GetDefineCmdContext(interp);
- if (oPtr == NULL) {
- return TCL_ERROR;
- }
- if (oPtr == fPtr->objectCls->thisPtr) {
- Tcl_AppendResult(interp,
- "may not modify the class of the root object", NULL);
- return TCL_ERROR;
- }
- if (oPtr == fPtr->classCls->thisPtr) {
- Tcl_AppendResult(interp,
- "may not modify the class of the class of classes", NULL);
- return TCL_ERROR;
- }
-
- /*
- * Parse the argument to get the class to set the object's class to.
- */
-
- if (objc != 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "className");
- return TCL_ERROR;
- }
- o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
- if (o2Ptr == NULL) {
- return TCL_ERROR;
- }
- if (o2Ptr->classPtr == NULL) {
- Tcl_AppendResult(interp, "the class of an object must be a class",
- NULL);
- return TCL_ERROR;
- }
-
- /*
- * Apply semantic checks. In particular, classes and non-classes are not
- * interchangable (too complicated to do the conversion!) so we must
- * produce an error if any attempt is made to swap from one to the other.
- */
-
- if ((oPtr->classPtr == NULL) == TclOOIsReachable(fPtr->classCls,
- o2Ptr->classPtr)) {
- Tcl_AppendResult(interp, "may not change a ",
- (oPtr->classPtr==NULL ? "non-" : ""), "class object into a ",
- (oPtr->classPtr==NULL ? "" : "non-"), "class object", NULL);
- return TCL_ERROR;
- }
-
- /*
- * Set the object's class.
- */
-
- if (oPtr->selfCls != o2Ptr->classPtr) {
- TclOORemoveFromInstances(oPtr, oPtr->selfCls);
- oPtr->selfCls = o2Ptr->classPtr;
- TclOOAddToInstances(oPtr, oPtr->selfCls);
- if (oPtr->classPtr != NULL) {
- fPtr->epoch++;
- } else {
- oPtr->epoch++;
- }
- }
- return TCL_OK;
-}
-
-int
-TclOODefineSuperclassObjCmd(
- ClientData clientData,
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const *objv)
-{
- Object *oPtr, *o2Ptr;
- Foundation *fPtr = ((Interp *)interp)->ooFoundation;
- Class **superclasses, *superPtr;
- int i, j;
-
- if (objc < 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "className ?className ...?");
- return TCL_ERROR;
- }
-
- /*
- * Get the class to operate on.
- */
-
- oPtr = GetDefineCmdContext(interp);
- if (oPtr == NULL) {
- return TCL_ERROR;
- }
- if (oPtr->classPtr == NULL) {
- Tcl_AppendResult(interp, "only classes may have superclasses defined",
- NULL);
- return TCL_ERROR;
- }
- if (oPtr == fPtr->objectCls->thisPtr) {
- Tcl_AppendResult(interp,
- "may not modify the superclass of the root object", NULL);
- return TCL_ERROR;
- }
-
- /*
- * Allocate some working space.
- */
-
- superclasses = (Class **) ckalloc(sizeof(Class *) * (objc-1));
-
- /*
- * Parse the arguments to get the class to use as superclasses.
- */
-
- for (i=0 ; i<objc-1 ; i++) {
- o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[i+1]);
- if (o2Ptr == NULL) {
- goto failedAfterAlloc;
- }
- if (o2Ptr->classPtr == NULL) {
- Tcl_AppendResult(interp, "only a class can be a superclass",NULL);
- goto failedAfterAlloc;
- }
- for (j=0 ; j<i ; j++) {
- if (superclasses[j] == o2Ptr->classPtr) {
- Tcl_AppendResult(interp,
- "class should only be a direct superclass once",NULL);
- goto failedAfterAlloc;
- }
- }
- if (TclOOIsReachable(oPtr->classPtr, o2Ptr->classPtr)) {
- Tcl_AppendResult(interp,
- "attempt to form circular dependency graph", NULL);
- failedAfterAlloc:
- ckfree((char *) superclasses);
- return TCL_ERROR;
- }
- superclasses[i] = o2Ptr->classPtr;
- }
-
- /*
- * Install the list of superclasses into the class. Note that this also
- * involves splicing the class out of the superclasses' subclass list that
- * it used to be a member of and splicing it into the new superclasses'
- * subclass list.
- */
-
- if (oPtr->classPtr->superclasses.num != 0) {
- FOREACH(superPtr, oPtr->classPtr->superclasses) {
- TclOORemoveFromSubclasses(oPtr->classPtr, superPtr);
- }
- ckfree((char *) oPtr->classPtr->superclasses.list);
- }
- oPtr->classPtr->superclasses.list = superclasses;
- oPtr->classPtr->superclasses.num = objc-1;
- FOREACH(superPtr, oPtr->classPtr->superclasses) {
- TclOOAddToSubclasses(oPtr->classPtr, superPtr);
- }
- fPtr->epoch++;
-
- return TCL_OK;
-}
-
-int
-TclOODefineUnexportObjCmd(
- ClientData clientData,
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const *objv)
-{
- int isSelfUnexport = (clientData != NULL);
- Object *oPtr;
- Method *mPtr;
- Tcl_HashEntry *hPtr;
- Class *clsPtr;
- int i, isNew;
-
- if (objc < 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "name ?name ...?");
- return TCL_ERROR;
- }
-
- oPtr = GetDefineCmdContext(interp);
- if (oPtr == NULL) {
- return TCL_ERROR;
- }
- clsPtr = oPtr->classPtr;
- isSelfUnexport |= (oPtr->classPtr == NULL);
-
- for (i=1 ; i<objc ; i++) {
- if (isSelfUnexport) {
- hPtr = Tcl_CreateHashEntry(&oPtr->methods, (char *) objv[i],
- &isNew);
- } else {
- hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, (char*) objv[i],
- &isNew);
- }
-
- if (isNew) {
- mPtr = (Method *) ckalloc(sizeof(Method));
- memset(mPtr, 0, sizeof(Method));
- Tcl_SetHashValue(hPtr, mPtr);
- } else {
- mPtr = Tcl_GetHashValue(hPtr);
- }
- mPtr->flags &= ~PUBLIC_METHOD;
- }
- if (isSelfUnexport) {
- oPtr->epoch++;
- } else {
- ((Interp *)interp)->ooFoundation->epoch++;
- }
- return TCL_OK;
-}
-
-/*
- * Local Variables:
- * mode: c
- * c-basic-offset: 4
- * fill-column: 78
- * End:
- */
diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c
deleted file mode 100644
index 859aae4..0000000
--- a/generic/tclOOInfo.c
+++ /dev/null
@@ -1,901 +0,0 @@
-/*
- * tclOODefineCmds.c --
- *
- * This file contains the implementation of the ::oo-related [info]
- * subcommands.
- *
- * Copyright (c) 2006 by Donal K. Fellows
- *
- * See the file "license.terms" for information on usage and redistribution of
- * this file, and for a DISCLAIMER OF ALL WARRANTIES.
- *
- * RCS: @(#) $Id: tclOOInfo.c,v 1.2 2006/10/20 14:04:01 dkf Exp $
- */
-
-#include "tclInt.h"
-#include "tclOO.h"
-
-static int InfoObjectClassCmd(Object *oPtr, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int InfoObjectDefnCmd(Object *oPtr, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int InfoObjectFiltersCmd(Object *oPtr, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int InfoObjectForwardCmd(Object *oPtr, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int InfoObjectIsACmd(Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-static int InfoObjectMethodsCmd(Object *oPtr, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int InfoObjectMixinsCmd(Object *oPtr, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int InfoObjectVarsCmd(Object *oPtr, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int InfoClassConstrCmd(Class *clsPtr, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int InfoClassDefnCmd(Class *clsPtr, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int InfoClassDestrCmd(Class *clsPtr, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int InfoClassFiltersCmd(Class *clsPtr, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int InfoClassForwardCmd(Class *clsPtr, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int InfoClassInstancesCmd(Class *clsPtr,
- Tcl_Interp*interp, int objc, Tcl_Obj*const objv[]);
-static int InfoClassMethodsCmd(Class *clsPtr, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int InfoClassMixinsCmd(Class *clsPtr, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-#ifdef SUPPORT_OO_PARAMETERS
-static int InfoClassParametersCmd(Class *clsPtr,
- Tcl_Interp*interp, int objc, Tcl_Obj*const objv[]);
-#endif
-static int InfoClassSubsCmd(Class *clsPtr, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static int InfoClassSupersCmd(Class *clsPtr, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-
-int
-TclInfoObjectCmd(
- ClientData clientData,
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const *objv)
-{
- static const char *subcommands[] = {
- "class", "definition", "filters", "forward", "isa", "methods",
- "mixins", "vars", NULL
- };
- enum IOSubCmds {
- IOClass, IODefinition, IOFilters, IOForward, IOIsA, IOMethods,
- IOMixins, IOVars
- };
- int idx;
- Object *oPtr;
-
- if (objc < 4) {
- Tcl_WrongNumArgs(interp, 2, objv, "objName subcommand ?arg ...?");
- return TCL_ERROR;
- }
- if (Tcl_GetIndexFromObj(interp, objv[3], subcommands, "subcommand", 0,
- &idx) != TCL_OK) {
- return TCL_ERROR;
- }
- if (idx == IOIsA) {
- return InfoObjectIsACmd(interp, objc, objv);
- }
- oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]);
- if (oPtr == NULL) {
- return TCL_ERROR;
- }
- switch ((enum IOSubCmds) idx) {
- case IOClass:
- return InfoObjectClassCmd(oPtr, interp, objc, objv);
- case IODefinition:
- return InfoObjectDefnCmd(oPtr, interp, objc, objv);
- case IOFilters:
- return InfoObjectFiltersCmd(oPtr, interp, objc, objv);
- case IOForward:
- return InfoObjectForwardCmd(oPtr, interp, objc, objv);
- case IOMethods:
- return InfoObjectMethodsCmd(oPtr, interp, objc, objv);
- case IOMixins:
- return InfoObjectMixinsCmd(oPtr, interp, objc, objv);
- case IOVars:
- return InfoObjectVarsCmd(oPtr, interp, objc, objv);
- case IOIsA:
- Tcl_Panic("unexpected fallthrough");
- }
- return TCL_ERROR; /* NOTREACHED */
-}
-
-int
-TclInfoClassCmd(
- ClientData clientData,
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const *objv)
-{
- static const char *subcommands[] = {
- "constructor", "definition", "destructor", "filters", "forward",
- "instances", "methods", "mixins",
-#ifdef SUPPORT_OO_PARAMETERS
- "parameters",
-#endif
- "subclasses", "superclasses", NULL
- };
- enum ICSubCmds {
- ICConstructor, ICDefinition, ICDestructor, ICFilters, ICForward,
- ICInstances, ICMethods, ICMixins,
-#ifdef SUPPORT_OO_PARAMETERS
- ICParameters,
-#endif
- ICSubs, ICSupers
- };
- int idx;
- Object *oPtr;
-
- if (objc < 4) {
- Tcl_WrongNumArgs(interp, 2, objv, "className subcommand ?arg ...?");
- return TCL_ERROR;
- }
- oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]);
- if (oPtr == NULL) {
- return TCL_ERROR;
- }
- if (oPtr->classPtr == NULL) {
- Tcl_AppendResult(interp, "\"", TclGetString(objv[2]),
- "\" is not a class", NULL);
- return TCL_ERROR;
- }
- if (Tcl_GetIndexFromObj(interp, objv[3], subcommands, "subcommand", 0,
- &idx) != TCL_OK) {
- return TCL_ERROR;
- }
-
- switch((enum ICSubCmds) idx) {
- case ICConstructor:
- return InfoClassConstrCmd(oPtr->classPtr, interp, objc, objv);
- case ICDefinition:
- return InfoClassDefnCmd(oPtr->classPtr, interp, objc, objv);
- case ICDestructor:
- return InfoClassDestrCmd(oPtr->classPtr, interp, objc, objv);
- case ICFilters:
- return InfoClassFiltersCmd(oPtr->classPtr, interp, objc, objv);
- case ICForward:
- return InfoClassForwardCmd(oPtr->classPtr, interp, objc, objv);
- case ICInstances:
- return InfoClassInstancesCmd(oPtr->classPtr, interp, objc, objv);
- case ICMethods:
- return InfoClassMethodsCmd(oPtr->classPtr, interp, objc, objv);
- case ICMixins:
- return InfoClassMixinsCmd(oPtr->classPtr, interp, objc, objv);
-#ifdef SUPPORT_OO_PARAMETERS
- case ICParameters:
- return InfoClassParametersCmd(oPtr->classPtr, interp, objc, objv);
-#endif
- case ICSubs:
- return InfoClassSubsCmd(oPtr->classPtr, interp, objc, objv);
- case ICSupers:
- return InfoClassSupersCmd(oPtr->classPtr, interp, objc, objv);
- }
- Tcl_Panic("unexpected fallthrough");
- return TCL_ERROR; /* NOTREACHED */
-}
-
-static int
-InfoObjectClassCmd(
- Object *oPtr,
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const objv[])
-{
- if (objc == 4) {
- Tcl_GetCommandFullName(interp, oPtr->selfCls->thisPtr->command,
- Tcl_GetObjResult(interp));
- return TCL_OK;
- } else if (objc != 5) {
- Tcl_WrongNumArgs(interp, 2, objv, "objName class ?className?");
- return TCL_ERROR;
- } else {
- Object *o2Ptr;
- Class *mixinPtr;
- int i;
-
- o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[4]);
- if (o2Ptr == NULL) {
- return TCL_ERROR;
- }
- if (o2Ptr->classPtr == NULL) {
- Tcl_AppendResult(interp, "object \"", TclGetString(objv[4]),
- "\" is not a class", NULL);
- return TCL_ERROR;
- }
-
- FOREACH(mixinPtr, oPtr->mixins) {
- if (TclOOIsReachable(o2Ptr->classPtr, mixinPtr)) {
- Tcl_SetObjResult(interp, Tcl_NewIntObj(1));
- return TCL_OK;
- }
- }
- Tcl_SetObjResult(interp, Tcl_NewIntObj(
- TclOOIsReachable(o2Ptr->classPtr, oPtr->selfCls)));
- return TCL_OK;
- }
-}
-
-static int
-InfoObjectDefnCmd(
- Object *oPtr,
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const objv[])
-{
- Tcl_HashEntry *hPtr;
- Proc *procPtr;
- CompiledLocal *localPtr;
- Tcl_Obj *argsObj;
-
- if (objc != 5) {
- Tcl_WrongNumArgs(interp, 2, objv, "objName definition methodName");
- return TCL_ERROR;
- }
-
- hPtr = Tcl_FindHashEntry(&oPtr->methods, (char *) objv[4]);
- if (hPtr == NULL) {
- Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[4]),
- "\"", NULL);
- return TCL_ERROR;
- }
- procPtr = TclOOGetProcFromMethod(Tcl_GetHashValue(hPtr));
- if (procPtr == NULL) {
- Tcl_AppendResult(interp,
- "definition not available for this kind of method", NULL);
- return TCL_ERROR;
- }
-
- TclNewObj(argsObj);
- for (localPtr=procPtr->firstLocalPtr; localPtr!=NULL;
- localPtr=localPtr->nextPtr) {
- if (TclIsVarArgument(localPtr)) {
- Tcl_Obj *argObj;
-
- TclNewObj(argObj);
- Tcl_ListObjAppendElement(NULL, argObj,
- Tcl_NewStringObj(localPtr->name, -1));
- if (localPtr->defValuePtr != NULL) {
- Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr);
- }
- Tcl_ListObjAppendElement(NULL, argsObj, argObj);
- }
- }
- Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), argsObj);
-
- /*
- * This is copied from the [info body] implementation. See the comments
- * there for why this copy has to be done here.
- */
-
- if (procPtr->bodyPtr->bytes == NULL) {
- (void) Tcl_GetString(procPtr->bodyPtr);
- }
- Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
- Tcl_NewStringObj(procPtr->bodyPtr->bytes,
- procPtr->bodyPtr->length));
- return TCL_OK;
-}
-
-static int
-InfoObjectFiltersCmd(
- Object *oPtr,
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const objv[])
-{
- int i;
- Tcl_Obj *filterObj;
-
- if (objc != 4) {
- Tcl_WrongNumArgs(interp, 2, objv, "objName filters");
- return TCL_ERROR;
- }
- FOREACH(filterObj, oPtr->filters) {
- Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), filterObj);
- }
- return TCL_OK;
-}
-
-static int
-InfoObjectForwardCmd(
- Object *oPtr,
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const objv[])
-{
- Tcl_HashEntry *hPtr;
- Tcl_Obj *prefixObj;
-
- if (objc != 5) {
- Tcl_WrongNumArgs(interp, 2, objv, "objName forward methodName");
- return TCL_ERROR;
- }
-
- hPtr = Tcl_FindHashEntry(&oPtr->methods, (char *) objv[4]);
- if (hPtr == NULL) {
- Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[4]),
- "\"", NULL);
- return TCL_ERROR;
- }
- prefixObj = TclOOGetFwdFromMethod(Tcl_GetHashValue(hPtr));
- if (prefixObj == NULL) {
- Tcl_AppendResult(interp,
- "prefix argument list not available for this kind of method",
- NULL);
- return TCL_ERROR;
- }
-
- Tcl_SetObjResult(interp, prefixObj);
- return TCL_OK;
-}
-
-static int
-InfoObjectIsACmd(
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const objv[])
-{
- static const char *categories[] = {
- "class", "metaclass", "mixin", "object", "typeof", NULL
- };
- enum IsACats {
- IsClass, IsMetaclass, IsMixin, IsObject, IsType
- };
- Object *oPtr, *o2Ptr;
- int idx, i;
-
- if (objc < 5) {
- Tcl_WrongNumArgs(interp, 2, objv, "objName isa category ?arg ...?");
- return TCL_ERROR;
- }
- if (Tcl_GetIndexFromObj(interp, objv[4], categories, "category", 0,
- &idx) != TCL_OK) {
- return TCL_ERROR;
- }
-
- if (idx == IsObject) {
- int ok = (Tcl_GetObjectFromObj(interp, objv[2]) != NULL);
-
- if (!ok) {
- Tcl_ResetResult(interp);
- }
- Tcl_SetObjResult(interp, Tcl_NewIntObj(ok ? 1 : 0));
- return TCL_OK;
- }
- oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]);
- if (oPtr == NULL) {
- return TCL_ERROR;
- }
-
- switch ((enum IsACats) idx) {
- case IsClass:
- if (objc != 5) {
- Tcl_WrongNumArgs(interp, 2, objv, "objName isa class");
- return TCL_ERROR;
- }
- Tcl_SetObjResult(interp, Tcl_NewIntObj(oPtr->classPtr ? 1 : 0));
- return TCL_OK;
- case IsMetaclass:
- if (objc != 5) {
- Tcl_WrongNumArgs(interp, 2, objv, "objName isa metaclass");
- return TCL_ERROR;
- }
- if (oPtr->classPtr == NULL) {
- Tcl_SetObjResult(interp, Tcl_NewIntObj(0));
- } else {
- Foundation *fPtr = ((Interp *)interp)->ooFoundation;
-
- Tcl_SetObjResult(interp, Tcl_NewIntObj(
- TclOOIsReachable(fPtr->classCls, oPtr->classPtr) ? 1 : 0));
- }
- return TCL_OK;
- case IsMixin:
- if (objc != 6) {
- Tcl_WrongNumArgs(interp, 2, objv, "objName isa mixin className");
- return TCL_ERROR;
- }
- o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[5]);
- if (o2Ptr == NULL) {
- return TCL_ERROR;
- }
- if (o2Ptr->classPtr == NULL) {
- Tcl_AppendResult(interp, "non-classes cannot be mixins", NULL);
- return TCL_ERROR;
- } else {
- Class *mixinPtr;
-
- FOREACH(mixinPtr, oPtr->mixins) {
- if (mixinPtr == o2Ptr->classPtr) {
- Tcl_SetObjResult(interp, Tcl_NewIntObj(1));
- return TCL_OK;
- }
- }
- }
- Tcl_SetObjResult(interp, Tcl_NewIntObj(0));
- return TCL_OK;
- case IsType:
- if (objc != 6) {
- Tcl_WrongNumArgs(interp, 2, objv, "objName isa typeof className");
- return TCL_ERROR;
- }
- o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[5]);
- if (o2Ptr == NULL) {
- return TCL_ERROR;
- }
- if (o2Ptr->classPtr == NULL) {
- Tcl_AppendResult(interp, "non-classes cannot be types", NULL);
- return TCL_ERROR;
- }
- if (TclOOIsReachable(o2Ptr->classPtr, oPtr->selfCls)) {
- Tcl_SetObjResult(interp, Tcl_NewIntObj(1));
- } else {
- Tcl_SetObjResult(interp, Tcl_NewIntObj(0));
- }
- return TCL_OK;
- case IsObject:
- Tcl_Panic("unexpected fallthrough");
- }
- return TCL_ERROR;
-}
-
-static int
-InfoObjectMethodsCmd(
- Object *oPtr,
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const objv[])
-{
- int flag = PUBLIC_METHOD;
- FOREACH_HASH_DECLS;
- Tcl_Obj *namePtr;
- Method *mPtr;
-
- if (objc != 4 && objc != 5) {
- Tcl_WrongNumArgs(interp, 2, objv, "objName methods ?-private?");
- return TCL_ERROR;
- }
- if (objc == 5) {
- int len;
- const char *str = Tcl_GetStringFromObj(objv[4], &len);
-
- if (len < 2 || strncmp("-private", str, (unsigned)len)) {
- Tcl_AppendResult(interp, "unknown switch \"", str,
- "\": must be -private", NULL);
- return TCL_ERROR;
- }
- flag = 0;
- }
- FOREACH_HASH(namePtr, mPtr, &oPtr->methods) {
- if (mPtr->typePtr != NULL && (mPtr->flags & flag) == flag) {
- Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), namePtr);
- }
- }
- return TCL_OK;
-}
-
-static int
-InfoObjectMixinsCmd(
- Object *oPtr,
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const objv[])
-{
- Class *mixinPtr;
- int i;
-
- if (objc != 4) {
- Tcl_WrongNumArgs(interp, 2, objv, "objName mixins");
- return TCL_ERROR;
- }
- FOREACH(mixinPtr, oPtr->mixins) {
- Tcl_Obj *tmpObj;
-
- TclNewObj(tmpObj);
- Tcl_GetCommandFullName(interp, mixinPtr->thisPtr->command, tmpObj);
- Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), tmpObj);
- }
- return TCL_OK;
-}
-
-static int
-InfoObjectVarsCmd(
- Object *oPtr,
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const objv[])
-{
- const char *pattern = NULL, *name;
- FOREACH_HASH_DECLS;
- Var *varPtr;
-
- if (objc != 4 && objc != 5) {
- Tcl_WrongNumArgs(interp, 2, objv, "objName vars ?pattern?");
- return TCL_ERROR;
- }
- if (objc == 5) {
- pattern = TclGetString(objv[4]);
- }
-
- FOREACH_HASH(name, varPtr, &((Namespace *) oPtr->namespacePtr)->varTable) {
- if (varPtr->flags & VAR_UNDEFINED) {
- continue;
- }
- if (pattern != NULL && !Tcl_StringMatch(name, pattern)) {
- continue;
- }
- Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
- Tcl_NewStringObj(name, -1));
- }
-
- return TCL_OK;
-}
-
-static int
-InfoClassConstrCmd(
- Class *clsPtr,
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const objv[])
-{
- Proc *procPtr;
- CompiledLocal *localPtr;
- Tcl_Obj *argsObj;
-
- if (objc != 4) {
- Tcl_WrongNumArgs(interp, 2, objv, "className constructor");
- return TCL_ERROR;
- }
-
- if (clsPtr->constructorPtr == NULL) {
- return TCL_OK;
- }
- procPtr = TclOOGetProcFromMethod(clsPtr->constructorPtr);
- if (procPtr == NULL) {
- Tcl_AppendResult(interp,
- "definition not available for this kind of method", NULL);
- return TCL_ERROR;
- }
-
- TclNewObj(argsObj);
- for (localPtr=procPtr->firstLocalPtr; localPtr!=NULL;
- localPtr=localPtr->nextPtr) {
- if (TclIsVarArgument(localPtr)) {
- Tcl_Obj *argObj;
-
- TclNewObj(argObj);
- Tcl_ListObjAppendElement(NULL, argObj,
- Tcl_NewStringObj(localPtr->name, -1));
- if (localPtr->defValuePtr != NULL) {
- Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr);
- }
- Tcl_ListObjAppendElement(NULL, argsObj, argObj);
- }
- }
- Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), argsObj);
- if (procPtr->bodyPtr->bytes == NULL) {
- (void) Tcl_GetString(procPtr->bodyPtr);
- }
- Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
- Tcl_NewStringObj(procPtr->bodyPtr->bytes,
- procPtr->bodyPtr->length));
- return TCL_OK;
-}
-
-static int
-InfoClassDefnCmd(
- Class *clsPtr,
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const objv[])
-{
- Tcl_HashEntry *hPtr;
- Proc *procPtr;
- CompiledLocal *localPtr;
- Tcl_Obj *argsObj;
-
- if (objc != 5) {
- Tcl_WrongNumArgs(interp, 2, objv, "className definition methodName");
- return TCL_ERROR;
- }
-
- hPtr = Tcl_FindHashEntry(&clsPtr->classMethods, (char *) objv[4]);
- if (hPtr == NULL) {
- Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[4]),
- "\"", NULL);
- return TCL_ERROR;
- }
- procPtr = TclOOGetProcFromMethod(Tcl_GetHashValue(hPtr));
- if (procPtr == NULL) {
- Tcl_AppendResult(interp,
- "definition not available for this kind of method", NULL);
- return TCL_ERROR;
- }
-
- TclNewObj(argsObj);
- for (localPtr=procPtr->firstLocalPtr; localPtr!=NULL;
- localPtr=localPtr->nextPtr) {
- if (TclIsVarArgument(localPtr)) {
- Tcl_Obj *argObj;
-
- TclNewObj(argObj);
- Tcl_ListObjAppendElement(NULL, argObj,
- Tcl_NewStringObj(localPtr->name, -1));
- if (localPtr->defValuePtr != NULL) {
- Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr);
- }
- Tcl_ListObjAppendElement(NULL, argsObj, argObj);
- }
- }
- Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), argsObj);
- if (procPtr->bodyPtr->bytes == NULL) {
- (void) Tcl_GetString(procPtr->bodyPtr);
- }
- Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
- Tcl_NewStringObj(procPtr->bodyPtr->bytes,
- procPtr->bodyPtr->length));
- return TCL_OK;
-}
-
-static int
-InfoClassDestrCmd(
- Class *clsPtr,
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const objv[])
-{
- Proc *procPtr;
-
- if (objc != 4) {
- Tcl_WrongNumArgs(interp, 2, objv, "className destructor");
- return TCL_ERROR;
- }
-
- if (clsPtr->destructorPtr == NULL) {
- return TCL_OK;
- }
- procPtr = TclOOGetProcFromMethod(clsPtr->destructorPtr);
- if (procPtr == NULL) {
- Tcl_AppendResult(interp,
- "definition not available for this kind of method", NULL);
- return TCL_ERROR;
- }
-
- if (procPtr->bodyPtr->bytes == NULL) {
- (void) Tcl_GetString(procPtr->bodyPtr);
- }
- Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
- Tcl_NewStringObj(procPtr->bodyPtr->bytes,
- procPtr->bodyPtr->length));
- return TCL_OK;
-}
-
-static int
-InfoClassFiltersCmd(
- Class *clsPtr,
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const objv[])
-{
- int i;
- Tcl_Obj *filterObj;
-
- if (objc != 4) {
- Tcl_WrongNumArgs(interp, 2, objv, "className filters");
- return TCL_ERROR;
- }
- FOREACH(filterObj, clsPtr->filters) {
- Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), filterObj);
- }
- return TCL_OK;
-}
-
-static int
-InfoClassForwardCmd(
- Class *clsPtr,
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const objv[])
-{
- Tcl_HashEntry *hPtr;
- Tcl_Obj *prefixObj;
-
- if (objc != 5) {
- Tcl_WrongNumArgs(interp, 2, objv, "className forward methodName");
- return TCL_ERROR;
- }
-
- hPtr = Tcl_FindHashEntry(&clsPtr->classMethods, (char *) objv[4]);
- if (hPtr == NULL) {
- Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[4]),
- "\"", NULL);
- return TCL_ERROR;
- }
- prefixObj = TclOOGetFwdFromMethod(Tcl_GetHashValue(hPtr));
- if (prefixObj == NULL) {
- Tcl_AppendResult(interp,
- "prefix argument list not available for this kind of method",
- NULL);
- return TCL_ERROR;
- }
-
- Tcl_SetObjResult(interp, prefixObj);
- return TCL_OK;
-}
-
-static int
-InfoClassInstancesCmd(
- Class *clsPtr,
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const objv[])
-{
- Object *oPtr;
- int i;
- const char *pattern = NULL;
-
- if (objc != 4 && objc != 5) {
- Tcl_WrongNumArgs(interp, 2, objv, "className instances ?pattern?");
- return TCL_ERROR;
- }
- if (objc == 5) {
- pattern = TclGetString(objv[4]);
- }
- FOREACH(oPtr, clsPtr->instances) {
- Tcl_Obj *tmpObj;
-
- TclNewObj(tmpObj);
- Tcl_GetCommandFullName(interp, oPtr->command, tmpObj);
- if (pattern && !Tcl_StringMatch(TclGetString(tmpObj), pattern)) {
- TclDecrRefCount(tmpObj);
- continue;
- }
- Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), tmpObj);
- }
- return TCL_OK;
-}
-
-static int
-InfoClassMethodsCmd(
- Class *clsPtr,
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const objv[])
-{
- int flag = PUBLIC_METHOD;
- FOREACH_HASH_DECLS;
- Tcl_Obj *namePtr;
- Method *mPtr;
-
- if (objc != 4 && objc != 5) {
- Tcl_WrongNumArgs(interp, 2, objv, "className methods ?-private?");
- return TCL_ERROR;
- }
- if (objc == 5) {
- int len;
- const char *str = Tcl_GetStringFromObj(objv[4], &len);
-
- if (len < 2 || strncmp("-private", str, (unsigned) len)) {
- Tcl_AppendResult(interp, "unknown switch \"", str,
- "\": must be -private", NULL);
- return TCL_ERROR;
- }
- flag = 0;
- }
- FOREACH_HASH(namePtr, mPtr, &clsPtr->classMethods) {
- if (mPtr->typePtr != NULL && (mPtr->flags & flag) == flag) {
- Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), namePtr);
- }
- }
- return TCL_OK;
-}
-
-static int
-InfoClassMixinsCmd(
- Class *clsPtr,
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const objv[])
-{
- Class *mixinPtr;
- int i;
-
- if (objc != 4) {
- Tcl_WrongNumArgs(interp, 2, objv, "className mixins");
- return TCL_ERROR;
- }
- FOREACH(mixinPtr, clsPtr->mixins) {
- Tcl_Obj *tmpObj;
-
- TclNewObj(tmpObj);
- Tcl_GetCommandFullName(interp, mixinPtr->thisPtr->command, tmpObj);
- Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), tmpObj);
- }
- return TCL_OK;
-}
-
-#ifdef SUPPORT_OO_PARAMETERS
-static int
-InfoClassParametersCmd(
- Class *clsPtr,
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const objv[])
-{
- Tcl_AppendResult(interp, "TODO: not yet implemented", NULL);
- return TCL_ERROR;
-}
-#endif
-
-static int
-InfoClassSubsCmd(
- Class *clsPtr,
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const objv[])
-{
- Class *subclassPtr;
- int i;
- const char *pattern = NULL;
-
- if (objc != 4 && objc != 5) {
- Tcl_WrongNumArgs(interp, 2, objv, "className subclasses ?pattern?");
- return TCL_ERROR;
- }
- if (objc == 5) {
- pattern = TclGetString(objv[4]);
- }
- FOREACH(subclassPtr, clsPtr->subclasses) {
- Tcl_Obj *tmpObj;
-
- TclNewObj(tmpObj);
- Tcl_GetCommandFullName(interp, subclassPtr->thisPtr->command, tmpObj);
- if (pattern && !Tcl_StringMatch(TclGetString(tmpObj), pattern)) {
- TclDecrRefCount(tmpObj);
- continue;
- }
- Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), tmpObj);
- }
- return TCL_OK;
-}
-
-static int
-InfoClassSupersCmd(
- Class *clsPtr,
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const objv[])
-{
- Class *superPtr;
- int i;
-
- if (objc != 4) {
- Tcl_WrongNumArgs(interp, 2, objv, "className superclasses");
- return TCL_ERROR;
- }
- FOREACH(superPtr, clsPtr->superclasses) {
- Tcl_Obj *tmpObj;
-
- TclNewObj(tmpObj);
- Tcl_GetCommandFullName(interp, superPtr->thisPtr->command, tmpObj);
- Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), tmpObj);
- }
- return TCL_OK;
-}
-
-/*
- * Local Variables:
- * mode: c
- * c-basic-offset: 4
- * fill-column: 78
- * End:
- */
diff --git a/generic/tclProc.c b/generic/tclProc.c
index 8577470..6429488 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.c
@@ -11,12 +11,11 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclProc.c,v 1.94 2006/10/20 14:04:01 dkf Exp $
+ * RCS: @(#) $Id: tclProc.c,v 1.95 2006/10/20 15:16:47 dkf Exp $
*/
#include "tclInt.h"
#include "tclCompile.h"
-#include "tclOO.h"
/*
* Prototypes for static functions in this file
@@ -34,8 +33,7 @@ static int ObjInterpProcEx(ClientData clientData,
static void ProcBodyDup(Tcl_Obj *srcPtr, Tcl_Obj *dupPtr);
static void ProcBodyFree(Tcl_Obj *objPtr);
static int ProcessProcResultCode(Tcl_Interp *interp,
- Tcl_Obj *procNameObj, int returnCode,
- int isMethod);
+ char *procName, int nameLen, int returnCode);
static int SetLambdaFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
static int ProcCompileProc (Tcl_Interp *interp, Proc *procPtr,
Tcl_Obj *bodyPtr, Namespace *nsPtr,
@@ -111,12 +109,12 @@ Tcl_ProcObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *const objv[]) /* Argument objects. */
+ Tcl_Obj *CONST objv[]) /* Argument objects. */
{
register Interp *iPtr = (Interp *) interp;
Proc *procPtr;
char *fullName;
- const char *procName, *procArgs, *procBody;
+ CONST char *procName, *procArgs, *procBody;
Namespace *nsPtr, *altNsPtr, *cxtNsPtr;
Tcl_Command cmd;
Tcl_DString ds;
@@ -280,17 +278,17 @@ int
TclCreateProc(
Tcl_Interp *interp, /* interpreter containing proc */
Namespace *nsPtr, /* namespace containing this proc */
- const char *procName, /* unqualified name of this proc */
+ CONST char *procName, /* unqualified name of this proc */
Tcl_Obj *argsPtr, /* description of arguments */
Tcl_Obj *bodyPtr, /* command body */
Proc **procPtrPtr) /* returns: pointer to proc data */
{
Interp *iPtr = (Interp*)interp;
- const char **argArray = NULL;
+ CONST char **argArray = NULL;
register Proc *procPtr;
int i, length, result, numArgs;
- const char *args, *bytes, *p;
+ CONST char *args, *bytes, *p;
register CompiledLocal *localPtr = NULL;
Tcl_Obj *defPtr;
int precompiled = 0;
@@ -384,7 +382,7 @@ TclCreateProc(
for (i = 0; i < numArgs; i++) {
int fieldCount, nameLength, valueLength;
- const char **fieldValues;
+ CONST char **fieldValues;
/*
* Now divide the specifier up into name and default.
@@ -422,7 +420,7 @@ TclCreateProc(
p = fieldValues[0];
while (*p != '\0') {
if (*p == '(') {
- const char *q = p;
+ CONST char *q = p;
do {
q++;
} while (*q != '\0');
@@ -593,7 +591,7 @@ TclCreateProc(
int
TclGetFrame(
Tcl_Interp *interp, /* Interpreter in which to find frame. */
- const char *name, /* String describing frame. */
+ CONST char *name, /* String describing frame. */
CallFrame **framePtrPtr) /* Store pointer to frame here (or NULL if
* global frame indicated). */
{
@@ -682,7 +680,7 @@ TclObjGetFrame(
register Interp *iPtr = (Interp *) interp;
int curLevel, level, result;
CallFrame *framePtr;
- const char *name = TclGetString(objPtr);
+ CONST char *name = TclGetString(objPtr);
/*
* Parse object to figure out which level number to go to.
@@ -800,7 +798,7 @@ Tcl_UplevelObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *const objv[]) /* Argument objects. */
+ Tcl_Obj *CONST objv[]) /* Argument objects. */
{
register Interp *iPtr = (Interp *) interp;
int result;
@@ -890,7 +888,7 @@ Tcl_UplevelObjCmd(
Proc *
TclFindProc(
Interp *iPtr, /* Interpreter in which to look. */
- const char *procName) /* Name of desired procedure. */
+ CONST char *procName) /* Name of desired procedure. */
{
Tcl_Command cmd;
Tcl_Command origCmd;
@@ -1120,7 +1118,7 @@ TclInitCompiledLocals(
/*
*----------------------------------------------------------------------
*
- * TclObjInterpProc, ObjInterpProcEx --
+ * TclObjInterpProc --
*
* When a Tcl procedure gets invoked during bytecode evaluation, this
* object-based routine gets invoked to interpret the procedure.
@@ -1142,8 +1140,9 @@ TclObjInterpProc(
* invoked. */
int objc, /* Count of number of arguments to this
* procedure. */
- Tcl_Obj *const objv[]) /* Argument value objects. */
+ Tcl_Obj *CONST objv[]) /* Argument value objects. */
{
+
return ObjInterpProcEx(clientData, interp, objc, objv, /*skip*/ 1);
}
@@ -1155,14 +1154,25 @@ ObjInterpProcEx(
* invoked. */
int objc, /* Count of number of arguments to this
* procedure. */
- Tcl_Obj *const objv[], /* Argument value objects. */
+ Tcl_Obj *CONST objv[], /* Argument value objects. */
int skip) /* Number of initial arguments to be skipped,
- * i.e., words in the "command name" */
+ * ie, words in the "command name" */
{
Proc *procPtr = (Proc *) clientData;
Namespace *nsPtr = procPtr->cmdPtr->nsPtr;
CallFrame *framePtr, **framePtrPtr;
- int result;
+ register Var *varPtr;
+ register CompiledLocal *localPtr;
+ char *procName;
+ int nameLen, localCt, numArgs, argCt, i, imax, result;
+ Var *compiledLocals;
+ Tcl_Obj *CONST *argObjs;
+
+ /*
+ * Get the procedure's name.
+ */
+
+ procName = Tcl_GetStringFromObj(objv[0], &nameLen);
/*
* If necessary, compile the procedure's body. The compiler will allocate
@@ -1172,12 +1182,13 @@ ObjInterpProcEx(
*/
result = ProcCompileProc(interp, procPtr, procPtr->bodyPtr, nsPtr,
- "body of proc", TclGetString(objv[0]), &procPtr);
+ "body of proc", procName, &procPtr);
if (result != TCL_OK) {
return result;
}
+
/*
* Set up and push a new call frame for the new procedure invocation.
* This call frame will execute in the proc's namespace, which might be
@@ -1194,50 +1205,11 @@ ObjInterpProcEx(
return result;
}
+
framePtr->objc = objc;
framePtr->objv = objv; /* ref counts for args are incremented below */
framePtr->procPtr = procPtr;
- return TclObjInterpProcCore(interp, framePtr, objv[0], skip);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclObjInterpProcCore --
- *
- * When a Tcl procedure, procedure-like method or lambda term gets
- * invoked during bytecode evaluation, this object-based routine gets
- * invoked to interpret the body.
- *
- * Results:
- * A standard Tcl object result value.
- *
- * Side effects:
- * Depends on the commands in the procedure body.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclObjInterpProcCore(
- register Tcl_Interp *interp,/* Interpreter in which procedure was
- * invoked. */
- CallFrame *framePtr, /* The context to execute. The procPtr field
- * must be non-NULL. */
- Tcl_Obj *procNameObj, /* Procedure name for error reporting. */
- int skip) /* Number of initial arguments to be skipped,
- * i.e., words in the "command name". */
-{
- register Proc *procPtr = framePtr->procPtr;
- register Var *varPtr;
- register CompiledLocal *localPtr;
- int localCt, numArgs, argCt, i, imax, result;
- Var *compiledLocals;
- Tcl_Obj *const *argObjs;
- int isMethod = (framePtr->isProcCallFrame &
- (FRAME_IS_METHOD | FRAME_IS_CONSTRUCTOR | FRAME_IS_DESTRUCTOR));
-
/*
* Create the "compiledLocals" array. Make sure it is large enough to hold
* all the procedure's compiled local variables, including its formal
@@ -1257,8 +1229,8 @@ TclObjInterpProcCore(
*/
numArgs = procPtr->numArgs;
- argCt = framePtr->objc-skip; /* set it to the number of args to the proc */
- argObjs = &framePtr->objv[skip];
+ argCt = objc-skip; /* set it to the number of args to the proc */
+ argObjs = &objv[skip];
varPtr = framePtr->compiledLocals;
localPtr = procPtr->firstLocalPtr;
if (numArgs == 0) {
@@ -1342,7 +1314,7 @@ TclObjInterpProcCore(
incorrectArgs:
codePtr = (ByteCode *) procPtr->bodyPtr->internalRep.otherValuePtr;
- InitCompiledLocals(interp, codePtr, localPtr, varPtr, framePtr->nsPtr);
+ InitCompiledLocals(interp, codePtr, localPtr, varPtr, nsPtr);
/*
* Build up desired argument list for Tcl_WrongNumArgs
@@ -1352,9 +1324,9 @@ TclObjInterpProcCore(
ckalloc(sizeof(Tcl_Obj *) * (unsigned)(numArgs+1));
#ifdef AVOID_HACKS_FOR_ITCL
- desiredObjs[0] = framePtr->objv[0];
+ desiredObjs[0] = objv[0];
#else
- desiredObjs[0] = Tcl_NewListObj(skip, framePtr->objv);
+ desiredObjs[0] = Tcl_NewListObj(skip, objv);
#endif /* AVOID_HACKS_FOR_ITCL */
localPtr = procPtr->firstLocalPtr;
@@ -1408,7 +1380,7 @@ TclObjInterpProcCore(
ByteCode *codePtr = (ByteCode *)
procPtr->bodyPtr->internalRep.otherValuePtr;
- InitCompiledLocals(interp, codePtr, localPtr, varPtr, framePtr->nsPtr);
+ InitCompiledLocals(interp, codePtr, localPtr, varPtr, nsPtr);
}
/*
@@ -1418,8 +1390,8 @@ TclObjInterpProcCore(
#ifdef TCL_COMPILE_DEBUG
if (tclTraceExec >= 1) {
fprintf(stdout, "Calling proc ");
- for (i = 0; i < framePtr->objc; i++) {
- TclPrintObject(stdout, framePtr->objv[i], 15);
+ for (i = 0; i < objc; i++) {
+ TclPrintObject(stdout, objv[i], 15);
fprintf(stdout, " ");
}
fprintf(stdout, "\n");
@@ -1436,19 +1408,19 @@ TclObjInterpProcCore(
if (result != TCL_OK) {
if (skip == 1) {
- result = ProcessProcResultCode(interp, procNameObj, result,
- isMethod);
+ result = ProcessProcResultCode(interp, procName, nameLen, result);
} else {
/*
* Use a 'procName' that contains the first skip elements of objv
* for error reporting. This insures that we do not see just
* 'apply', but also the lambda expression that caused the error.
*/
-
+
Tcl_Obj *namePtr;
- namePtr = Tcl_NewListObj(skip, framePtr->objv);
- result = ProcessProcResultCode(interp, namePtr, result, isMethod);
+ namePtr = Tcl_NewListObj(skip, objv);
+ procName = Tcl_GetStringFromObj(namePtr, &nameLen);
+ result = ProcessProcResultCode(interp, procName, nameLen, result);
TclDecrRefCount(namePtr);
}
}
@@ -1502,8 +1474,8 @@ TclProcCompileProc(
* but could be any code fragment compiled in
* the context of this procedure.) */
Namespace *nsPtr, /* Namespace containing procedure. */
- const char *description, /* string describing this body of code. */
- const char *procName) /* Name of this procedure. */
+ CONST char *description, /* string describing this body of code. */
+ CONST char *procName) /* Name of this procedure. */
{
return ProcCompileProc(interp, procPtr, bodyPtr, nsPtr, description,
procName, NULL);
@@ -1708,11 +1680,10 @@ static int
ProcessProcResultCode(
Tcl_Interp *interp, /* The interpreter in which the procedure was
* called and returned returnCode. */
- Tcl_Obj *procNameObj, /* Name of the procedure. Used for error
+ char *procName, /* Name of the procedure. Used for error
* messages and trace information. */
- int returnCode, /* The unexpected result code. */
- int isMethod) /* Whether this is a procedure, method,
- * constructor or destructor. */
+ int nameLen, /* Number of bytes in procedure's name. */
+ int returnCode) /* The unexpected result code. */
{
Interp *iPtr = (Interp *) interp;
int overflow, limit = 60;
@@ -1732,111 +1703,10 @@ ProcessProcResultCode(
((returnCode == TCL_BREAK) ? "break" : "continue"),
"\" outside of a loop", NULL);
}
- if (isMethod & FRAME_IS_CONSTRUCTOR) {
- if (interp->errorLine != 0xDEADBEEF) { /* hack! */
- CallContext *contextPtr =
- ((Interp *) interp)->varFramePtr->ooContextPtr;
- Method *mPtr = contextPtr->callChain[contextPtr->index].mPtr;
- Tcl_Command declarer;
- Tcl_Obj *objectNameObj;
- const char *objectName, *kindName;
- int objectNameLen;
-
- if (mPtr->declaringObjectPtr != NULL) {
- declarer = mPtr->declaringObjectPtr->command;
- kindName = "object";
- } else {
- if (mPtr->declaringClassPtr == NULL) {
- Tcl_Panic("method not declared in class or object");
- }
- declarer = mPtr->declaringClassPtr->thisPtr->command;
- kindName = "class";
- }
- TclNewObj(objectNameObj);
- Tcl_GetCommandFullName(interp, declarer, objectNameObj);
- objectName = Tcl_GetStringFromObj(objectNameObj, &objectNameLen);
- overflow = (objectNameLen > limit);
-
- TclFormatToErrorInfo(interp,
- "\n (%s \"%.*s%s\" constructor line %d)",
- kindName, (overflow ? limit : objectNameLen), objectName,
- (overflow ? "..." : ""), interp->errorLine);
-
- TclDecrRefCount(objectNameObj);
- }
- } else if (isMethod & FRAME_IS_DESTRUCTOR) {
- CallContext *contextPtr =
- ((Interp *) interp)->varFramePtr->ooContextPtr;
- Method *mPtr = contextPtr->callChain[contextPtr->index].mPtr;
- Tcl_Command declarer;
- Tcl_Obj *objectNameObj;
- const char *objectName, *kindName;
- int objectNameLen;
-
- if (mPtr->declaringObjectPtr != NULL) {
- declarer = mPtr->declaringObjectPtr->command;
- kindName = "object";
- } else {
- if (mPtr->declaringClassPtr == NULL) {
- Tcl_Panic("method not declared in class or object");
- }
- declarer = mPtr->declaringClassPtr->thisPtr->command;
- kindName = "class";
- }
- TclNewObj(objectNameObj);
- Tcl_GetCommandFullName(interp, declarer, objectNameObj);
- objectName = Tcl_GetStringFromObj(objectNameObj, &objectNameLen);
- overflow = (objectNameLen > limit);
-
- TclFormatToErrorInfo(interp,
- "\n (%s \"%.*s%s\" destructor line %d)",
- kindName, (overflow ? limit : objectNameLen), objectName,
- (overflow ? "..." : ""), interp->errorLine);
-
- TclDecrRefCount(objectNameObj);
- } else if (isMethod & FRAME_IS_METHOD) {
- int nameLen, objectNameLen, objNameOverflow;
- CallContext *contextPtr =
- ((Interp *) interp)->varFramePtr->ooContextPtr;
- Method *mPtr = contextPtr->callChain[contextPtr->index].mPtr;
- Tcl_Obj *objectNameObj;
- const char *objectName, *kindName, *methodName =
- Tcl_GetStringFromObj(mPtr->namePtr, &nameLen);
- Tcl_Command declarer;
-
- if (mPtr->declaringObjectPtr != NULL) {
- declarer = mPtr->declaringObjectPtr->command;
- kindName = "object";
- } else {
- if (mPtr->declaringClassPtr == NULL) {
- Tcl_Panic("method not declared in class or object");
- }
- declarer = mPtr->declaringClassPtr->thisPtr->command;
- kindName = "class";
- }
- TclNewObj(objectNameObj);
- Tcl_GetCommandFullName(interp, declarer, objectNameObj);
- objectName = Tcl_GetStringFromObj(objectNameObj, &objectNameLen);
- overflow = (nameLen > limit);
- objNameOverflow = (objectNameLen > limit);
-
- TclFormatToErrorInfo(interp,
- "\n (%s \"%.*s%s\" method \"%.*s%s\" line %d)", kindName,
- (objNameOverflow ? limit : objectNameLen), objectName,
- (objNameOverflow ? "..." : ""), (overflow ? limit : nameLen),
- methodName, (overflow ? "..." : ""), interp->errorLine);
-
- TclDecrRefCount(objectNameObj);
- } else {
- int nameLen;
- const char *procName = Tcl_GetStringFromObj(procNameObj, &nameLen);
-
overflow = (nameLen > limit);
-
TclFormatToErrorInfo(interp, "\n (procedure \"%.*s%s\" line %d)",
(overflow ? limit : nameLen), procName,
(overflow ? "..." : ""), interp->errorLine);
- }
return TCL_ERROR;
}
@@ -2098,11 +1968,11 @@ DupLambdaInternalRep(
Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
register Tcl_Obj *copyPtr) /* Object with internal rep to set. */
{
- Proc *procPtr = srcPtr->internalRep.twoPtrValue.ptr1;
- Tcl_Obj *nsObjPtr = srcPtr->internalRep.twoPtrValue.ptr2;
+ Proc *procPtr = (Proc *) srcPtr->internalRep.twoPtrValue.ptr1;
+ Tcl_Obj *nsObjPtr = (Tcl_Obj *) srcPtr->internalRep.twoPtrValue.ptr2;
- copyPtr->internalRep.twoPtrValue.ptr1 = procPtr;
- copyPtr->internalRep.twoPtrValue.ptr2 = nsObjPtr;
+ copyPtr->internalRep.twoPtrValue.ptr1 = (void *) procPtr;
+ copyPtr->internalRep.twoPtrValue.ptr2 = (void *) nsObjPtr;
procPtr->refCount++;
Tcl_IncrRefCount(nsObjPtr);
@@ -2114,8 +1984,8 @@ FreeLambdaInternalRep(
register Tcl_Obj *objPtr) /* CmdName object with internal representation
* to free. */
{
- Proc *procPtr = objPtr->internalRep.twoPtrValue.ptr1;
- Tcl_Obj *nsObjPtr = objPtr->internalRep.twoPtrValue.ptr2;
+ Proc *procPtr = (Proc *) objPtr->internalRep.twoPtrValue.ptr1;
+ Tcl_Obj *nsObjPtr = (Tcl_Obj *) objPtr->internalRep.twoPtrValue.ptr2;
procPtr->refCount--;
if (procPtr->refCount == 0) {
@@ -2163,7 +2033,7 @@ SetLambdaFromAny(
bodyPtr, &procPtr) != TCL_OK) {
TclFormatToErrorInfo(interp,
"\n (parsing lambda expression \"%s\")",
- TclGetString(objPtr), NULL);
+ Tcl_GetString(objPtr), NULL);
return TCL_ERROR;
}
@@ -2200,35 +2070,18 @@ SetLambdaFromAny(
objPtr->typePtr->freeIntRepProc(objPtr);
- objPtr->internalRep.twoPtrValue.ptr1 = procPtr;
- objPtr->internalRep.twoPtrValue.ptr2 = nsObjPtr;
+ objPtr->internalRep.twoPtrValue.ptr1 = (void *) procPtr;
+ objPtr->internalRep.twoPtrValue.ptr2 = (void *) nsObjPtr;
objPtr->typePtr = &lambdaType;
return TCL_OK;
}
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_ApplyObjCmd --
- *
- * This object-based function is invoked to process the "apply" Tcl
- * command. See the user documentation for details on what it does.
- *
- * Results:
- * A standard Tcl object result value.
- *
- * Side effects:
- * Depends on the content of the lambda term (i.e., objv[1]).
- *
- *----------------------------------------------------------------------
- */
-
int
Tcl_ApplyObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *const objv[]) /* Argument objects. */
+ Tcl_Obj *CONST objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
Proc *procPtr = NULL;
@@ -2249,7 +2102,7 @@ Tcl_ApplyObjCmd(
lambdaPtr = objv[1];
if (lambdaPtr->typePtr == &lambdaType) {
- procPtr = lambdaPtr->internalRep.twoPtrValue.ptr1;
+ procPtr = (Proc *) lambdaPtr->internalRep.twoPtrValue.ptr1;
}
#define JOE_EXTENSION 0
@@ -2276,7 +2129,7 @@ Tcl_ApplyObjCmd(
if (result != TCL_OK) {
return result;
}
- procPtr = lambdaPtr->internalRep.twoPtrValue.ptr1;
+ procPtr = (Proc *) lambdaPtr->internalRep.twoPtrValue.ptr1;
}
procPtr->cmdPtr = &cmd;
@@ -2285,7 +2138,7 @@ Tcl_ApplyObjCmd(
* for that namespace. Note that TclObjInterpProc() will pop it.
*/
- nsObjPtr = lambdaPtr->internalRep.twoPtrValue.ptr2;
+ nsObjPtr = (Tcl_Obj *) lambdaPtr->internalRep.twoPtrValue.ptr2;
result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr);
if (result != TCL_OK) {
return result;
diff --git a/generic/tclVar.c b/generic/tclVar.c
index 6e515d2..5f47e7e 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -15,7 +15,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclVar.c,v 1.123 2006/10/20 14:04:01 dkf Exp $
+ * RCS: @(#) $Id: tclVar.c,v 1.124 2006/10/20 15:16:47 dkf Exp $
*/
#include "tclInt.h"
@@ -39,14 +39,6 @@ static CONST char *isArrayElement =
"name refers to an element in an array";
/*
- * A test to see if we are in a call frame that has local variables. This is
- * true if we are inside a procedure body or an object method body.
- */
-
-#define IsLocal(framePtr) \
- ((framePtr)->isProcCallFrame & (FRAME_IS_PROC | FRAME_IS_METHOD))
-
-/*
* Forward references to functions defined later in this file:
*/
@@ -407,7 +399,7 @@ TclObjLookupVar(
int localIndex = (int) part1Ptr->internalRep.longValue;
if ((varFramePtr != NULL)
- && IsLocal(varFramePtr)
+ && (varFramePtr->isProcCallFrame & FRAME_IS_PROC)
&& !(flags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY))
&& (localIndex < varFramePtr->numCompiledLocals)) {
/*
@@ -431,12 +423,13 @@ TclObjLookupVar(
(flags & TCL_GLOBAL_ONLY) ||
(*part1==':' && *(part1+1)==':') ||
(varFramePtr == NULL) ||
- (!IsLocal(varFramePtr) && (nsPtr == iPtr->globalNsPtr)));
+ (!(varFramePtr->isProcCallFrame & FRAME_IS_PROC)
+ && (nsPtr == iPtr->globalNsPtr)));
useReference = useGlobal || ((cachedNsPtr == nsPtr) && (
(flags & TCL_NAMESPACE_ONLY) ||
(varFramePtr &&
- !IsLocal(varFramePtr) &&
+ !(varFramePtr->isProcCallFrame & FRAME_IS_PROC) &&
!(flags & TCL_GLOBAL_ONLY) &&
/*
* Careful: an undefined ns variable could be hiding a valid
@@ -752,7 +745,7 @@ TclLookupSimpleVar(
if (((flags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY)) != 0)
|| (varFramePtr == NULL)
- || !IsLocal(varFramePtr)
+ || !(varFramePtr->isProcCallFrame & FRAME_IS_PROC)
|| (strstr(varName, "::") != NULL)) {
CONST char *tail;
int lookGlobal;
@@ -3246,7 +3239,7 @@ ObjMakeUpvar(
if (((otherP2 ? arrayPtr->nsPtr : otherPtr->nsPtr) == NULL)
&& ((myFlags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY))
|| (varFramePtr == NULL)
- || !IsLocal(varFramePtr)
+ || !(varFramePtr->isProcCallFrame & FRAME_IS_PROC)
|| (strstr(myName, "::") != NULL))) {
Tcl_AppendResult((Tcl_Interp *) iPtr, "bad variable name \"",
myName, "\": upvar won't create namespace variable that ",
@@ -3297,7 +3290,7 @@ TclPtrMakeUpvar(
CONST char *p;
if (index >= 0) {
- if (!IsLocal(varFramePtr)) {
+ if (!(varFramePtr->isProcCallFrame & FRAME_IS_PROC)) {
Tcl_Panic("ObjMakeUpvar called with an index outside from a proc");
}
varPtr = &(varFramePtr->compiledLocals[index]);
@@ -3560,7 +3553,8 @@ Tcl_GlobalObjCmd(
* If we are not executing inside a Tcl procedure, just return.
*/
- if ((iPtr->varFramePtr == NULL) || !IsLocal(iPtr->varFramePtr)) {
+ if ((iPtr->varFramePtr == NULL)
+ || !(iPtr->varFramePtr->isProcCallFrame & FRAME_IS_PROC)) {
return TCL_OK;
}
@@ -3711,7 +3705,8 @@ Tcl_VariableObjCmd(
* linked to the new namespace variable "varName".
*/
- if ((iPtr->varFramePtr != NULL) && IsLocal(iPtr->varFramePtr)) {
+ if ((iPtr->varFramePtr != NULL)
+ && (iPtr->varFramePtr->isProcCallFrame & FRAME_IS_PROC)) {
/*
* varName might have a scope qualifier, but the name for the
* local "link" variable must be the simple name at the tail.
diff --git a/tests/info.test b/tests/info.test
index 99f5fcf..8a8417e 100644
--- a/tests/info.test
+++ b/tests/info.test
@@ -11,7 +11,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: info.test,v 1.36 2006/10/20 14:04:01 dkf Exp $
+# RCS: @(#) $Id: info.test,v 1.37 2006/10/20 15:16:47 dkf Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
@@ -647,22 +647,18 @@ test info-21.1 {miscellaneous error conditions} {
} {1 {wrong # args: should be "info option ?arg arg ...?"}}
test info-21.2 {miscellaneous error conditions} {
list [catch {info gorp} msg] $msg
-} {1 {bad option "gorp": must be args, body, class, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
+} {1 {bad option "gorp": must be args, body, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
test info-21.3 {miscellaneous error conditions} {
list [catch {info c} msg] $msg
-} {1 {ambiguous option "c": must be args, body, class, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
+} {1 {ambiguous option "c": must be args, body, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
test info-21.4 {miscellaneous error conditions} {
list [catch {info l} msg] $msg
-} {1 {ambiguous option "l": must be args, body, class, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
+} {1 {ambiguous option "l": must be args, body, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
test info-21.5 {miscellaneous error conditions} {
list [catch {info s} msg] $msg
-} {1 {ambiguous option "s": must be args, body, class, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
+} {1 {ambiguous option "s": must be args, body, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
# cleanup
catch {namespace delete test_ns_info1 test_ns_info2}
::tcltest::cleanupTests
return
-
-# Local Variables:
-# mode: tcl
-# End:
diff --git a/tests/oo.test b/tests/oo.test
deleted file mode 100644
index 7fd4255..0000000
--- a/tests/oo.test
+++ /dev/null
@@ -1,1243 +0,0 @@
-# This file contains a collection of tests for Tcl's built-in object system.
-# Sourcing this file into Tcl runs the tests and generates output for errors.
-# No output means no errors were found.
-#
-# Copyright (c) 2006 Donal K. Fellows
-#
-# See the file "license.terms" for information on usage and redistribution of
-# this file, and for a DISCLAIMER OF ALL WARRANTIES.
-#
-# RCS: @(#) $Id: oo.test,v 1.2 2006/10/20 14:04:01 dkf Exp $
-
-if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest 2
- namespace import -force ::tcltest::*
-}
-
-testConstraint memory [llength [info commands memory]]
-
-test oo-0.1 {basic test of OO's ability to clean up its initial state} {
- interp create t
- interp delete t
-} {}
-test oo-0.2 {basic test of OO's ability to clean up its initial state} {
- interp eval [interp create] { namespace delete :: }
-} {}
-test oo-0.3 {basic test of OO's ability to clean up its initial state} -setup {
- proc getbytes {} {
- set lines [split [memory info] "\n"]
- lindex $lines 3 3
- }
-} -constraints memory -body {
- set end [getbytes]
- for {set i 0} {$i < 5} {incr i} {
- [oo::object new] destroy
- set tmp $end
- set end [getbytes]
- }
- set leakedBytes [expr {$end - $tmp}]
-} -cleanup {
- rename getbytes {}
-} -result 0
-test oo-0.4 {basic test of OO's ability to clean up its initial state} -setup {
- proc getbytes {} {
- set lines [split [memory info] "\n"]
- lindex $lines 3 3
- }
-} -constraints memory -body {
- set end [getbytes]
- for {set i 0} {$i < 5} {incr i} {
- oo::class create foo
- foo new
- foo destroy
- set tmp $end
- set end [getbytes]
- }
- set leakedBytes [expr {$end - $tmp}]
-} -cleanup {
- rename getbytes {}
-} -result 0
-
-test oo-1.1 {basic test of OO functionality: no classes} {
- set result {}
- lappend result [oo::object create foo]
- lappend result [oo::define foo {
- method bar args {
- global result
- lappend result {expand}$args
- return [llength $args]
- }
- }]
- lappend result [foo bar a b c]
- lappend result [foo destroy] [info commands foo]
-} {::foo {} a b c 3 {} {}}
-test oo-1.2 {basic test of OO functionality: no classes} -body {
- oo::define oo::object method missingArgs
-} -returnCodes 1 -result "wrong # args: should be \"oo::define oo::object method name args body\""
-test oo-1.3 {basic test of OO functionality: no classes} {
- catch {oo::define oo::object method missingArgs}
- set errorInfo
-} "wrong # args: should be \"oo::define oo::object method name args body\"
- while executing
-\"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.6 {basic test of OO functionality} -setup {
- oo::object create aninstance
-} -body {
- oo::define aninstance unexport destroy
- aninstance doesnotexist
-} -cleanup {
- rename aninstance {}
-} -returnCodes 1 -result {object "::aninstance" has no visible methods}
-
-test oo-2.1 {basic test of OO functionality: constructor} -setup {
- # This is a bit complex because it needs to run in a sub-interp as
- # we're modifying the root object class's constructor
- interp create subinterp
-} -body {
- subinterp eval {
- oo::define oo::object constructor {} {
- lappend ::result [info level 0]
- }
- lappend result 1
- lappend result 2 [oo::object create foo]
- }
-} -cleanup {
- interp delete subinterp
-} -result {1 {oo::object create foo} 2 ::foo}
-test oo-2.2 {basic test of OO functionality: constructor} {
- oo::class create testClass {
- constructor {} {
- global result
- lappend result "[self]->construct"
- }
- method bar {} {
- global result
- lappend result "[self]->bar"
- }
- }
- set result {}
- [testClass create foo] bar
- testClass destroy
- return $result
-} {::foo->construct ::foo->bar}
-
-test oo-3.1 {basic test of OO functionality: destructor} -setup {
- # This is a bit complex because it needs to run in a sub-interp as
- # we're modifying the root object class's constructor
- interp create subinterp
-} -body {
- subinterp eval {
- oo::define oo::object destructor {
- lappend ::result died
- }
- lappend result 1 [oo::object create foo]
- lappend result 2 [rename foo {}]
- oo::define oo::object destructor {}
- return $result
- }
-} -cleanup {
- interp delete subinterp
-} -result {1 ::foo died 2 {}}
-test oo-3.2 {basic test of OO functionality: destructor} -setup {
- # This is a bit complex because it needs to run in a sub-interp as
- # we're modifying the root object class's constructor
- interp create subinterp
-} -body {
- subinterp eval {
- oo::define oo::object destructor {
- lappend ::result died
- }
- lappend result 1 [oo::object create foo]
- lappend result 2 [rename foo {}]
- }
-} -cleanup {
- interp delete subinterp
-} -result {1 ::foo died 2 {}}
-
-test oo-4.1 {basic test of OO functionality: export} {
- set o [oo::object new]
- set result {}
- oo::define $o method Foo {} {lappend ::result Foo; return}
- lappend result [catch {$o Foo} msg] $msg
- oo::define $o export Foo
- lappend result [$o Foo] [$o destroy]
-} {1 {unknown method "Foo": must be destroy} Foo {} {}}
-test oo-4.2 {basic test of OO functionality: unexport} {
- set o [oo::object new]
- set result {}
- oo::define $o method foo {} {lappend ::result foo; return}
- lappend result [$o foo]
- oo::define $o unexport foo
- lappend result [catch {$o foo} msg] $msg [$o destroy]
-} {foo {} 1 {unknown method "foo": must be destroy} {}}
-
-test oo-5.1 {OO: manipulation of classes as objects} -setup {
- set obj [oo::object new]
-} -body {
- oo::define oo::object self.method foo {} { return "in object" }
- catch {$obj foo} result
- list [catch {$obj foo} result] $result [oo::object foo]
-} -cleanup {
- oo::define oo::object self.method foo {} {}
- $obj destroy
-} -result {1 {unknown method "foo": must be destroy} {in object}}
-
-test oo-6.1 {OO: forward} {
- oo::object create foo
- oo::define foo {
- forward a lappend
- forward b lappend result
- }
- set result {}
- foo a result 1
- foo b 2
- foo destroy
- return $result
-} {1 2}
-
-test oo-7.1 {OO: inheritance 101} -setup {
- oo::class create superClass
- oo::class create subClass
- subClass create instance
-} -body {
- oo::define superClass method doit x {lappend ::result $x}
- oo::define subClass superclass superClass
- set result [list [catch {subClass doit bad} msg] $msg]
- instance doit ok
- return $result
-} -cleanup {
- subClass destroy
- superClass destroy
-} -result {1 {unknown method "doit": must be create, destroy or new} ok}
-test oo-7.2 {OO: inheritance 101} -setup {
- oo::class create superClass
- oo::class create subClass
- subClass create instance
-} -body {
- oo::define superClass method doit x {lappend ::result |$x|}
- oo::define subClass superclass superClass
- oo::define instance method doit x {lappend ::result =$x=; next [incr x]}
- set result {}
- instance doit 1
- return $result
-} -cleanup {
- subClass destroy
- superClass destroy
-} -result {=1= |2|}
-test oo-7.3 {OO: inheritance 101} -setup {
- oo::class create superClass
- oo::class create subClass
- subClass create instance
-} -body {
- oo::define superClass method doit x {lappend ::result |$x|}
- oo::define subClass {
- superclass superClass
- method doit x {lappend ::result -$x-; next [incr x]}
- }
- oo::define instance method doit x {lappend ::result =$x=; next [incr x]}
- set result {}
- instance doit 1
- return $result
-} -cleanup {
- subClass destroy
- superClass destroy
-} -result {=1= -2- |3|}
-test oo-7.4 {OO: inheritance from oo::class} -body {
- oo::class create meta
- oo::define meta {
- superclass oo::class
- self.unexport create new
- self.method make {x {definitions {}}} {
- if {![string match ::* $x]} {
- set ns [uplevel 1 {::namespace current}]
- set x ${ns}::$x
- }
- set o [my create $x]
- lappend ::result "made $o"
- oo::define $o $definitions
- return $o
- }
- }
- set result [list [catch {meta create foo} msg] $msg]
- lappend result [meta make classinstance {
- lappend ::result "in definition script in [namespace current]"
- }]
- lappend result [classinstance create instance]
-} -cleanup {
- catch {classinstance destroy}
- catch {meta destroy}
-} -result {1 {unknown method "create": must be destroy or make} {made ::classinstance} {in definition script in ::oo::define} ::classinstance ::instance}
-test oo-7.5 {OO: inheritance from oo::class in the secondary chain} -body {
- oo::class create other
- oo::class create meta
- oo::define meta {
- superclass other oo::class
- self.unexport create new
- self.method make {x {definitions {}}} {
- if {![string match ::* $x]} {
- set ns [uplevel 1 {::namespace current}]
- set x ${ns}::$x
- }
- set o [my create $x]
- lappend ::result "made $o"
- oo::define $o $definitions
- return $o
- }
- }
- set result [list [catch {meta create foo} msg] $msg]
- lappend result [meta make classinstance {
- lappend ::result "in definition script in [namespace current]"
- }]
- lappend result [classinstance create instance]
-} -cleanup {
- catch {classinstance destroy}
- catch {meta destroy}
- catch {other destroy}
-} -result {1 {unknown method "create": must be destroy or make} {made ::classinstance} {in definition script in ::oo::define} ::classinstance ::instance}
-test oo-7.6 {OO: inheritance 101 - overridden methods should be oblivious} -setup {
- oo::class create Aclass
- oo::class create Bclass
- Bclass create Binstance
-} -body {
- oo::define Aclass {
- method incr {var step} {
- upvar 1 $var v
- ::incr v $step
- }
- }
- oo::define Bclass {
- superclass Aclass
- method incr {var {step 1}} {
- global result
- lappend result $var $step
- set r [next $var $step]
- lappend result returning:$r
- return $r
- }
- }
- set result {}
- set x 10
- lappend result x=$x
- lappend result [Binstance incr x]
- lappend result x=$x
-} -result {x=10 x 1 returning:11 11 x=11} -cleanup {
- Aclass destroy
-}
-test oo-7.7 {OO: inheritance and errorInfo} -setup {
- oo::class create A
- oo::class create B
- B create c
-} -body {
- oo::define A method foo {} {error foo!}
- oo::define B {
- superclass A
- method foo {} { next }
- }
- oo::define c method foo {} { next }
- catch {c ?} msg
- set result [list $msg]
- catch {c foo} msg
- lappend result $msg $errorInfo
-} -cleanup {
- A destroy
-} -result {{unknown method "?": must be destroy or foo} foo! {foo!
- while executing
-"error foo!"
- (class "::A" method "foo" line 1)
- invoked from within
-"next "
- (class "::B" method "foo" line 1)
- invoked from within
-"next "
- (object "::c" method "foo" line 1)
- invoked from within
-"c foo"}}
-
-test oo-8.1 {OO: global must work in methods} {
- oo::object create foo
- oo::define foo method bar x {global result; lappend result $x}
- set result {}
- foo bar this
- foo bar is
- lappend result a
- foo bar test
- foo destroy
- return $result
-} {this is a test}
-
-test oo-9.1 {OO: multiple inheritance} -setup {
- oo::class create A
- oo::class create B
- oo::class create C
- oo::class create D
- D create foo
-} -body {
- oo::define A method test {} {lappend ::result A; return ok}
- oo::define B {
- superclass A
- method test {} {lappend ::result B; next}
- }
- oo::define C {
- superclass A
- method test {} {lappend ::result C; next}
- }
- oo::define D {
- superclass B C
- method test {} {lappend ::result D; next}
- }
- set result {}
- lappend result [foo test]
-} -cleanup {
- D destroy
- C destroy
- B destroy
- A destroy
-} -result {D B C A ok}
-test oo-9.2 {OO: multiple inheritance} -setup {
- oo::class create A
- oo::class create B
- oo::class create C
- oo::class create D
- D create foo
-} -body {
- oo::define A method test {} {lappend ::result A; return ok}
- oo::define B {
- superclass A
- method test {} {lappend ::result B; next}
- }
- oo::define C {
- superclass A
- method test {} {lappend ::result C; next}
- }
- oo::define D {
- superclass B C
- method test {} {lappend ::result D; next}
- }
- set result {}
- lappend result [foo test]
-} -cleanup {
- A destroy
-} -result {D B C A ok}
-
-test oo-10.1 {OO: recursive invoke and modify} -setup {
- [oo::class create C] create O
-} -cleanup {
- C destroy
-} -body {
- oo::define C method foo x {
- lappend ::result $x
- if {$x} {
- [self object] foo [incr x -1]
- }
- }
- oo::define O method foo x {
- lappend ::result -$x-
- if {$x == 1} {
- # delete the method
- oo::define O method foo {} {}
- }
- next $x
- }
- set result {}
- O foo 2
- return $result
-} -result {-2- 2 -1- 1 0}
-
-test oo-11.1 {OO: cleanup} {
- oo::object create foo
- set result [list [catch {oo::object create foo} msg] $msg]
- lappend result [foo destroy] [oo::object create foo] [foo destroy]
-} {1 {can't create object "foo": command already exists with that name} {} ::foo {}}
-test oo-11.2 {OO: cleanup} {
- oo::class create bar
- bar create foo
- set result [list [catch {bar create foo} msg] $msg]
- lappend result [bar destroy] [oo::object create foo] [foo destroy]
-} {1 {can't create object "foo": command already exists with that name} {} ::foo {}}
-test oo-11.3 {OO: cleanup} {
- oo::class create bar0
- oo::class create bar
- oo::define bar superclass bar0
- bar create foo
- set result [list [catch {bar create foo} msg] $msg]
- lappend result [bar0 destroy] [oo::object create foo] [foo destroy]
-} {1 {can't create object "foo": command already exists with that name} {} ::foo {}}
-test oo-11.4 {OO: cleanup} {
- oo::class create bar0
- oo::class create bar1
- oo::define bar1 superclass bar0
- oo::class create bar2
- oo::define bar2 {
- superclass bar0
- destructor {lappend ::result destroyed}
- }
- oo::class create bar
- oo::define bar superclass bar1 bar2
- bar create foo
- set result [list [catch {bar create foo} msg] $msg]
- lappend result [bar0 destroy] [oo::object create foo] [foo destroy] \
- [oo::object create bar2] [bar2 destroy]
-} {1 {can't create object "foo": command already exists with that name} destroyed {} ::foo {} ::bar2 {}}
-
-test oo-12.1 {OO: filters} {
- oo::class create Aclass
- Aclass create Aobject
- oo::define Aclass {
- method concatenate args {
- global result
- lappend result {expand}$args
- join $args {}
- }
- method logFilter args {
- global result
- lappend result "calling [self object]->[self method] $args"
- set r [next {expand}$args]
- lappend result "result=$r"
- return $r
- }
- }
- oo::define Aobject filter logFilter
- set result {}
- lappend result [Aobject concatenate 1 2 3 4 5]
- Aclass destroy
- return $result
-} {{calling ::Aobject->logFilter 1 2 3 4 5} 1 2 3 4 5 result=12345 12345}
-test oo-12.2 {OO: filters} -setup {
- oo::class create Aclass
- Aclass create Aobject
-} -body {
- oo::define Aclass {
- method concatenate args {
- global result
- lappend result {expand}$args
- join $args {}
- }
- method logFilter args {
- global result
- lappend result "calling [self object]->[self method] $args"
- set r [next {expand}$args]
- lappend result "result=$r"
- return $r
- }
- }
- oo::define Aobject filter logFilter
- set result {}
- lappend result [Aobject concatenate 1 2 3 4 5] [Aobject destroy]
-} -cleanup {
- Aclass destroy
-} -result {{calling ::Aobject->logFilter 1 2 3 4 5} 1 2 3 4 5 result=12345 {calling ::Aobject->logFilter } result= 12345 {}}
-test oo-12.3 {OO: filters} -setup {
- oo::class create Aclass
- Aclass create Aobject
-} -body {
- oo::define Aclass {
- method concatenate args {
- global result
- lappend result {expand}$args
- join $args {}
- }
- method logFilter args {
- global result
- lappend result "calling [self object]->[self method] $args"
- set r [next {expand}$args]
- lappend result "result=$r"
- return $r
- }
- filter logFilter
- }
- set result {}
- lappend result [Aobject concatenate 1 2 3 4 5] [Aobject destroy]
-} -cleanup {
- Aclass destroy
-} -result {{calling ::Aobject->logFilter 1 2 3 4 5} 1 2 3 4 5 result=12345 {calling ::Aobject->logFilter } result= 12345 {}}
-test oo-12.4 {OO: filters} -setup {
- oo::class create Aclass
- Aclass create Aobject
-} -body {
- oo::define Aclass {
- method foo {} { return foo }
- method Bar {} { return 1 }
- method boo {} { if {[my Bar]} { next } { error forbidden } }
- filter boo
- }
- Aobject foo
-} -cleanup {
- Aclass destroy
-} -result foo
-test oo-12.5 {OO: filters} -setup {
- oo::class create Aclass
- Aclass create Aobject
-} -body {
- oo::define Aclass {
- method foo {} { return foo }
- method Bar {} { return [my Bar2] }
- method Bar2 {} { return 1 }
- method boo {} { if {[my Bar]} { next } { error forbidden } }
- filter boo
- }
- Aobject foo
-} -cleanup {
- Aclass destroy
-} -result foo
-test oo-12.6 {OO: filters} -setup {
- oo::class create Aclass
- Aclass create Aobject
-} -body {
- oo::define Aclass {
- method foo {} { return foo }
- method Bar {} { return [my Bar2] }
- method Bar2 {} { return [my Bar3] }
- method Bar3 {} { return 1 }
- method boo {} { if {[my Bar]} { next } { error forbidden } }
- filter boo
- }
- Aobject foo
-} -cleanup {
- Aclass destroy
-} -result foo
-test oo-12.7 {OO: filters} -setup {
- oo::class create Aclass
- Aclass create Aobject
-} -body {
- oo::define Aclass {
- method outerfoo {} { return [my InnerFoo] }
- method InnerFoo {} { return foo }
- method Bar {} { return [my Bar2] }
- method Bar2 {} { return [my Bar3] }
- method Bar3 {} { return 1 }
- method boo {} {
- lappend ::log [self target]
- if {[my Bar]} { next } else { error forbidden }
- }
- filter boo
- }
- set log {}
- list [Aobject outerfoo] $log
-} -cleanup {
- Aclass destroy
-} -result {foo {{::Aclass outerfoo} {::Aclass InnerFoo}}}
-
-test oo-13.1 {OO: changing an object's class} {
- oo::class create Aclass
- oo::define Aclass {method bar {} {lappend ::result "in A [self object]"}}
- oo::class create Bclass
- oo::define Bclass {method bar {} {lappend ::result "in B [self object]"}}
- set result [Aclass create foo]
- foo bar
- oo::define foo self.class Bclass
- foo bar
- Aclass destroy
- lappend result [info command foo]
- Bclass destroy
- return $result
-} {::foo {in A ::foo} {in B ::foo} foo}
-test oo-13.2 {OO: changing an object's class} -body {
- oo::object create foo
- oo::define foo self.class oo::class
-} -cleanup {
- foo destroy
-} -returnCodes 1 -result {may not change a non-class object into a class object}
-test oo-13.3 {OO: changing an object's class} -body {
- oo::class create foo
- oo::define foo self.class oo::object
-} -cleanup {
- foo destroy
-} -returnCodes 1 -result {may not change a class object into a non-class object}
-# todo: changing a class subtype (metaclass) to another class subtype
-
-test oo-14.1 {OO: mixins} {
- oo::class create Aclass
- oo::define Aclass method bar {} {lappend ::result "[self object] in bar"}
- oo::class create Bclass
- oo::define Bclass method boo {} {lappend ::result "[self object] in boo"}
- oo::define [Aclass create fooTest] mixin Bclass
- oo::define [Aclass create fooTest2] mixin Bclass
- set result [list [catch {fooTest ?} msg] $msg]
- fooTest bar
- fooTest boo
- fooTest2 bar
- fooTest2 boo
- oo::define fooTest2 mixin
- lappend result [Bclass destroy] [info command fooTest*] [Aclass destroy]
-} {1 {unknown method "?": must be bar, boo or destroy} {::fooTest in bar} {::fooTest in boo} {::fooTest2 in bar} {::fooTest2 in boo} {} fooTest2 {}}
-test oo-14.2 {OO: mixins} {
- oo::class create Aclass {
- method bar {} {return "[self object] in bar"}
- }
- oo::class create Bclass {
- method boo {} {return "[self object] in boo"}
- }
- oo::define Aclass mixin Bclass
- Aclass create fooTest
- set result [list [catch {fooTest ?} msg] $msg]
- lappend result [catch {fooTest bar} msg] $msg
- lappend result [catch {fooTest boo} msg] $msg
- lappend result [Bclass destroy] [info commands Aclass]
-} {1 {unknown method "?": must be bar, boo or destroy} 0 {::fooTest in bar} 0 {::fooTest in boo} {} {}}
-
-test oo-15.1 {OO: object cloning} {
- oo::class create Aclass
- oo::define Aclass method test {} {lappend ::result [self object]->test}
- Aclass create Ainstance
- set result {}
- Ainstance test
- oo::define Ainstance copy Binstance
- Binstance test
- Ainstance test
- Ainstance destroy
- namespace eval foo {
- oo::define Binstance copy Cinstance
- Cinstance test
- }
- Aclass destroy
- namespace delete foo
- lappend result [info commands Binstance]
-} {::Ainstance->test ::Binstance->test ::Ainstance->test ::foo::Cinstance->test {}}
-test oo-15.2 {OO: object cloning} {
- oo::object create foo
- oo::define foo {
- method m x {lappend ::result [self object] >$x<}
- forward f ::lappend ::result fwd
- }
- set result {}
- foo m 1
- foo f 2
- lappend result [oo::define foo copy bar]
- foo m 3
- foo f 4
- bar m 5
- bar f 6
- lappend result [foo destroy]
- bar m 7
- bar f 8
- lappend result [bar destroy]
-} {::foo >1< fwd 2 ::bar ::foo >3< fwd 4 ::bar >5< fwd 6 {} ::bar >7< fwd 8 {}}
-catch {foo destroy}
-catch {bar destroy}
-test oo-15.3 {OO: class cloning} {
- oo::class create foo {
- method testme {} {lappend ::result [self class]->[self object]}
- }
- set result {}
- foo create baseline
- baseline testme
- oo::define foo copy bar
- baseline testme
- bar create tester
- tester testme
- foo destroy
- tester testme
- bar destroy
- return $result
-} {::foo->::baseline ::foo->::baseline ::bar->::tester ::bar->::tester}
-
-test oo-16.1 {OO: object introspection} -body {
- info object
-} -returnCodes 1 -result "wrong \# args: should be \"info object objName subcommand ?arg ...?\""
-test oo-16.2 {OO: object introspection} -body {
- info object NOTANOBJECT class
-} -returnCodes 1 -result {NOTANOBJECT does not refer to an object}
-test oo-16.3 {OO: object introspection} -body {
- info object oo::object gorp
-} -returnCodes 1 -result {bad subcommand "gorp": must be class, definition, filters, forward, isa, methods, mixins, or vars}
-test oo-16.4 {OO: object introspection} -setup {
- oo::class create meta { superclass oo::class }
-} -body {
- list [info object oo::object class] \
- [info object oo::class class] \
- [info object oo::object isa class] \
- [info object oo::object isa metaclass] \
- [info object meta isa metaclass] \
- [info object oo::object isa object] \
- [info object oo::define isa object]
-} -cleanup {
- meta destroy
-} -result {::oo::class ::oo::class 1 0 1 1 0}
-test oo-16.5 {OO: object introspection} {info object oo::object methods} {}
-test oo-16.6 {OO: object introspection} {
- oo::object create foo
- set result [list [info object foo methods]]
- oo::define foo method bar {} {...}
- lappend result [info object foo methods] [foo destroy]
-} {{} bar {}}
-test oo-16.7 {OO: object introspection} -setup {
- oo::object create foo
-} -body {
- oo::define foo method bar {a {b c} args} {the body}
- set result [info object foo methods]
- lappend result [info object foo definition bar]
-} -cleanup {
- foo destroy
-} -result {bar {{a {b c} args} {the body}}}
-test oo-16.8 {OO: object introspection} {
- oo::object create foo
- oo::class create bar
- oo::define foo mixin bar
- set result [list [info object foo mixins] \
- [info object foo isa mixin bar] \
- [info object foo isa mixin oo::class]]
- foo destroy
- bar destroy
- return $result
-} {::bar 1 0}
-test oo-16.9 {OO: object introspection} {
- oo::class create Ac
- oo::class create Bc; oo::define Bc superclass Ac
- oo::class create Cc; oo::define Cc superclass Bc
- Cc create D
- list [info object D isa typeof oo::class] \
- [info object D isa typeof Ac] [Ac destroy]
-} {0 1 {}}
-test oo-16.10 {OO: object introspection} -setup {
- oo::object create foo
-} -body {
- oo::define foo export eval
- foo eval {variable c 3 a 1 b 2 ddd 4 e}
- lsort [info object foo vars ?]
-} -cleanup {
- foo destroy
-} -result {a b c}
-
-test oo-17.1 {OO: class introspection} -body {
- info class
-} -returnCodes 1 -result "wrong \# args: should be \"info class className subcommand ?arg ...?\""
-test oo-17.2 {OO: class introspection} -body {
- info class NOTANOBJECT gorp
-} -returnCodes 1 -result {NOTANOBJECT does not refer to an object}
-test oo-17.3 {OO: class introspection} -setup {
- oo::object create foo
-} -body {
- info class foo gorp
-} -returnCodes 1 -cleanup {
- foo destroy
-} -result {"foo" is not a class}
-test oo-17.4 {OO: class introspection} -body {
- info class oo::object gorp
-} -returnCodes 1 -result {bad subcommand "gorp": must be constructor, definition, destructor, filters, forward, instances, methods, mixins, subclasses, or superclasses}
-test oo-17.5 {OO: class introspection} -setup {
- oo::class create testClass
-} -body {
- testClass create foo
- testClass create bar
- testClass create spong
- lsort [info class testClass instances]
-} -cleanup {
- testClass destroy
-} -result {::bar ::foo ::spong}
-test oo-17.6 {OO: object introspection} -setup {
- oo::class create foo
-} -body {
- oo::define foo method bar {a {b c} args} {the body}
- set result [info class foo methods]
- lappend result [info class foo definition bar]
-} -cleanup {
- foo destroy
-} -result {bar {{a {b c} args} {the body}}}
-test oo-17.7 {OO: object introspection} {
- info class oo::class superclasses
-} ::oo::object
-test oo-17.8 {OO: object introspection} -setup {
- oo::class create testClass
- oo::class create superClass1
- oo::class create superClass2
-} -body {
- oo::define testClass superclass superClass1 superClass2
- list [info class testClass superclasses] \
- [lsort [info class oo::object subclass ::superClass?]]
-} -cleanup {
- testClass destroy
- superClass1 destroy
- superClass2 destroy
-} -result {{::superClass1 ::superClass2} {::superClass1 ::superClass2}}
-
-test oo-18.1 {OO: define command support} {
- list [catch {oo::define oo::object {error foo}} msg] $msg $errorInfo
-} {1 foo {foo
- while executing
-"error foo"
- (in definition script for object "oo::object" line 1)
- invoked from within
-"oo::define oo::object {error foo}"}}
-test oo-18.2 {OO: define command support} {
- list [catch {oo::define oo::object error foo} msg] $msg $errorInfo
-} {1 foo {foo
- while executing
-"oo::define oo::object error foo"}}
-test oo-18.3 {OO: define command support} {
- list [catch {oo::class create foo {error bar}} msg] $msg $errorInfo
-} {1 bar {bar
- while executing
-"error bar"
- (in definition script for object "::foo" line 1)
- invoked from within
-"oo::class create foo {error bar}"}}
-test oo-18.4 {OO: more error traces from the guts} -setup {
- oo::object create obj
-} -body {
- oo::define obj method bar {} {my eval {error foo}}
- list [catch {obj bar} msg] $msg $errorInfo
-} -cleanup {
- obj destroy
-} -result {1 foo {foo
- while executing
-"error foo"
- (in "my eval" script line 1)
- invoked from within
-"my eval {error foo}"
- (object "::obj" method "bar" line 1)
- invoked from within
-"obj bar"}}
-test oo-18.5 {OO: more error traces from the guts} -setup {
- [oo::class create cls] create obj
- set errorInfo {}
-} -body {
- oo::define cls {
- method eval script {next $script}
- export eval
- }
- oo::define obj method bar {} {my eval {error foo}}
- set result {}
- lappend result [catch {obj bar} msg] $msg $errorInfo
- lappend result [catch {obj eval {error bar}} msg] $msg $errorInfo
-} -cleanup {
- cls destroy
-} -result {1 foo {foo
- while executing
-"error foo"
- (in "my eval" script line 1)
- invoked from within
-"next $script"
- (class "::cls" method "eval" line 1)
- invoked from within
-"my eval {error foo}"
- (object "::obj" method "bar" line 1)
- invoked from within
-"obj bar"} 1 bar {bar
- while executing
-"error bar"
- (in "::obj eval" script line 1)
- invoked from within
-"next $script"
- (class "::cls" method "eval" line 1)
- invoked from within
-"obj eval {error bar}"}}
-
-test oo-19.1 {OO: varname method} -setup {
- oo::object create inst
- oo::define inst export eval
- set result {}
-} -body {
- inst eval {trace add variable x write foo}
- set ns [inst eval namespace current]
- proc foo args {
- global ns result
- set context [uplevel 1 namespace current]
- lappend result $args [expr {
- $ns eq $context ? "ok" : [list $ns ne $context]
- }] [expr {
- "${ns}::x" eq [uplevel 1 my varname x] ? "ok" : [list ${ns}::x ne [uplevel 1 my varname x]]
- }]
- }
- lappend result [inst eval set x 0]
-} -cleanup {
- inst destroy
- rename foo {}
-} -result {{x {} write} ok ok 0}
-
-test oo-20.1 {OO: variable method} -body {
- oo::class create testClass {
- constructor {} {
- my variable ok
- set ok {}
- }
- }
- lsort [info object [testClass new] vars]
-} -cleanup {
- catch {testClass destroy}
-} -result ok
-test oo-20.2 {OO: variable method} -body {
- oo::class create testClass {
- constructor {} {
- my variable a b c
- set a [set b [set c {}]]
- }
- }
- lsort [info object [testClass new] vars]
-} -cleanup {
- catch {testClass destroy}
-} -result {a b c}
-test oo-20.3 {OO: variable method} -body {
- oo::class create testClass {
- export varname
- method bar {} {
- my variable a(b)
- }
- }
- testClass create foo
- array set [foo varname a] {b c}
- foo bar
-} -returnCodes 1 -cleanup {
- catch {testClass destroy}
-} -result {can't define "a(b)": name refers to an element in an array}
-test oo-20.4 {OO: variable method} -body {
- oo::class create testClass {
- export varname
- method bar {} {
- my variable a(b)
- }
- }
- testClass create foo
- set [foo varname a] b
- foo bar
-} -returnCodes 1 -cleanup {
- catch {testClass destroy}
-} -result {can't define "a(b)": name refers to an element in an array}
-test oo-20.5 {OO: variable method} -body {
- oo::class create testClass {
- method bar {} {
- my variable a::b
- }
- }
- testClass create foo
- foo bar
-} -returnCodes 1 -cleanup {
- catch {testClass destroy}
-} -result {variable name "a::b" illegal: must not contain namespace separator}
-test oo-20.6 {OO: variable method} -setup {
- oo::class create testClass {
- self.export eval
- export varname
- }
-} -body {
- testClass eval variable a 0
- oo::define [testClass create foo] method bar {other} {
- $other variable a
- set a 3
- }
- oo::define [testClass create boo] export variable
- set [foo varname a] 1
- set [boo varname a] 2
- foo bar boo
- list [testClass eval set a] [set [foo varname a]] [set [boo varname a]]
-} -cleanup {
- testClass destroy
-} -result {0 1 3}
-test oo-20.7 {OO: variable method} -setup {
- oo::class create cls
-} -body {
- oo::define cls {
- method a {} {
- my variable {b c} d
- lappend c $d
- }
- method e {} {
- my variable b d
- return [list $b $d]
- }
- method f {x y} {
- my variable b d
- set b $x
- set d $y
- }
- }
- cls create obj
- obj f p q
- obj a
- obj a
- obj e
-} -cleanup {
- cls destroy
-} -result {{p q q} q}
-test oo-20.8 {OO: variable method} -setup {
- oo::class create cls
-} -body {
- oo::define cls {
- constructor {} {
- namespace eval foo {
- variable bar 1
- }
- }
- method ns {} {self namespace}
- method a {} {
- my variable {foo::bar c} d
- lappend c $d
- }
- method e {} {
- my variable {foo::bar b} d
- return [list $b $d]
- }
- method f {x} {
- my variable d
- set d $x
- }
- }
- cls create obj
- obj f p
- obj a
- obj a
- list [obj e] [set [obj ns]::foo::bar]
-} -cleanup {
- cls destroy
-} -result {{{1 p p} p} {1 p p}}
-test oo-20.9 {OO: variable method} -setup {
- oo::object create obj
-} -body {
- oo::define obj {
- method a {} {
- my variable {a ::b}
- }
- }
- obj a
-} -cleanup {
- obj destroy
-} -returnCodes 1 -result {variable name "::b" illegal: must not contain namespace separator}
-
-test oo-21.1 {OO: inheritance ordering} -setup {
- oo::class create A
-} -body {
- oo::define A method m {} {lappend ::result A}
- oo::class create B {
- superclass A
- method m {} {lappend ::result B;next}
- }
- oo::class create C {
- superclass A
- method m {} {lappend ::result C;next}
- }
- oo::class create D {
- superclass B C
- method m {} {lappend ::result D;next}
- }
- D create o
- oo::define o method m {} {lappend ::result o;next}
- set result {}
- o m
- return $result
-} -cleanup {
- A destroy
-} -result {o D B C A}
-test oo-21.2 {OO: inheritance ordering} -setup {
- oo::class create A
-} -body {
- oo::define A method m {} {lappend ::result A}
- oo::class create B {
- superclass A
- method m {} {lappend ::result B;next}
- }
- oo::class create C {
- superclass A
- method m {} {lappend ::result C;next}
- }
- oo::class create D {
- superclass B C
- method m {} {lappend ::result D;next}
- }
- oo::class create Emix {
- superclass C
- method m {} {lappend ::result Emix;next}
- }
- oo::class create Fmix {
- superclass Emix
- method m {} {lappend ::result Fmix;next}
- }
- D create o
- oo::define o method m {} {lappend ::result o;next}
- oo::define o mixin Fmix
- set result {}
- o m
- return $result
-} -cleanup {
- A destroy
-} -result {Fmix Emix o D B C A}
-test oo-21.3 {OO: inheritance ordering} -setup {
- oo::class create A
-} -body {
- oo::define A method m {} {lappend ::result A}
- oo::class create B {
- superclass A
- method m {} {lappend ::result B;next}
- method f {} {lappend ::result B-filt;next}
- }
- oo::class create C {
- superclass A
- method m {} {lappend ::result C;next}
- }
- oo::class create D {
- superclass B C
- method m {} {lappend ::result D;next}
- }
- oo::class create Emix {
- superclass C
- method m {} {lappend ::result Emix;next}
- method f {} {lappend ::result Emix-filt;next}
- }
- oo::class create Fmix {
- superclass Emix
- method m {} {lappend ::result Fmix;next}
- }
- D create o
- oo::define o {
- method m {} {lappend ::result o;next}
- mixin Fmix
- filter f
- }
- set result {}
- o m
- return $result
-} -cleanup {
- A destroy
-} -result {Emix-filt B-filt Fmix Emix o D B C A}
-test oo-21.4 {OO: inheritance ordering} -setup {
- oo::class create A
-} -body {
- oo::define A method m {} {lappend ::result A}
- oo::class create B {
- superclass A
- method m {} {lappend ::result B;next}
- method f {} {lappend ::result B-filt;next}
- method g {} {lappend ::result B-cfilt;next}
- }
- oo::class create C {
- superclass A
- method m {} {lappend ::result C;next}
- }
- oo::class create D {
- superclass B C
- method m {} {lappend ::result D;next}
- method g {} {lappend ::result D-cfilt;next}
- filter g
- }
- oo::class create Emix {
- superclass C
- method m {} {lappend ::result Emix;next}
- method f {} {lappend ::result Emix-filt;next}
- }
- oo::class create Fmix {
- superclass Emix
- method m {} {lappend ::result Fmix;next}
- }
- D create o
- oo::define o {
- method m {} {lappend ::result o;next}
- mixin Fmix
- filter f
- }
- set result {}
- o m
- return $result
-} -cleanup {
- A destroy
-} -result {Emix-filt B-filt D-cfilt B-cfilt Fmix Emix o D B C A}
-
-cleanupTests
-return
-
-# Local Variables:
-# mode: tcl
-# End:
diff --git a/unix/Makefile.in b/unix/Makefile.in
index 745cf60..8429f60 100644
--- a/unix/Makefile.in
+++ b/unix/Makefile.in
@@ -5,7 +5,7 @@
# "autoconf" program (constructs like "@foo@" will get replaced in the
# actual Makefile.
#
-# RCS: @(#) $Id: Makefile.in,v 1.195 2006/10/20 14:04:01 dkf Exp $
+# RCS: @(#) $Id: Makefile.in,v 1.196 2006/10/20 15:16:48 dkf Exp $
VERSION = @TCL_VERSION@
MAJOR_VERSION = @TCL_MAJOR_VERSION@
@@ -309,10 +309,9 @@ GENERIC_OBJS = regcomp.o regexec.o regfree.o regerror.o tclAlloc.o \
tclEnv.o tclEvent.o tclExecute.o tclFCmd.o tclFileName.o tclGet.o \
tclHash.o tclHistory.o tclIndexObj.o tclInterp.o tclIO.o tclIOCmd.o \
tclIORChan.o tclIOGT.o tclIOSock.o tclIOUtil.o tclLink.o tclListObj.o \
- tclLiteral.o tclLoad.o tclMain.o tclNamesp.o tclNotify.o tclObj.o \
- tclOO.o tclOOCall.o tclOODefineCmds.o tclOOInfo.o tclPanic.o \
- tclParse.o tclParseExpr.o tclPathObj.o \
- tclPipe.o tclPkg.o tclPkgConfig.o tclPosixStr.o \
+ tclLiteral.o tclLoad.o tclMain.o tclNamesp.o tclNotify.o \
+ tclObj.o tclPanic.o tclParse.o tclParseExpr.o tclPathObj.o tclPipe.o \
+ tclPkg.o tclPkgConfig.o tclPosixStr.o \
tclPreserve.o tclProc.o tclRegexp.o \
tclResolve.o tclResult.o tclScan.o tclStringObj.o \
tclStrToD.o tclThread.o \
@@ -410,10 +409,6 @@ GENERIC_SRCS = \
$(GENERIC_DIR)/tclNamesp.c \
$(GENERIC_DIR)/tclNotify.c \
$(GENERIC_DIR)/tclObj.c \
- $(GENERIC_DIR)/tclOO.c \
- $(GENERIC_DIR)/tclOOCall.c \
- $(GENERIC_DIR)/tclOODefineCmds.c \
- $(GENERIC_DIR)/tclOOInfo.c \
$(GENERIC_DIR)/tclParse.c \
$(GENERIC_DIR)/tclParseExpr.c \
$(GENERIC_DIR)/tclPathObj.c \
@@ -950,7 +945,6 @@ TCLREHDRS=$(GENERIC_DIR)/tclRegexp.h
COMPILEHDR=$(GENERIC_DIR)/tclCompile.h
FSHDR=$(GENERIC_DIR)/tclFileSystem.h
IOHDR=$(GENERIC_DIR)/tclIO.h
-OOHDR=$(GENERIC_DIR)/tclOO.h
MATHHDRS=$(GENERIC_DIR)/tommath.h $(GENERIC_DIR)/tclTomMath.h
regcomp.o: $(REGHDRS) $(GENERIC_DIR)/regcomp.c $(GENERIC_DIR)/regc_lex.c \
@@ -1081,18 +1075,6 @@ tclLiteral.o: $(GENERIC_DIR)/tclLiteral.c $(COMPILEHDR)
tclObj.o: $(GENERIC_DIR)/tclObj.c $(COMPILEHDR) $(MATHHDRS)
$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclObj.c
-tclOO.o: $(GENERIC_DIR)/tclOO.c $(OOHDR)
- $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclOO.c
-
-tclOOCall.o: $(GENERIC_DIR)/tclOOCall.c $(OOHDR)
- $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclOOCall.c
-
-tclOODefineCmds.o: $(GENERIC_DIR)/tclOODefineCmds.c $(OOHDR)
- $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclOODefineCmds.c
-
-tclOOInfo.o: $(GENERIC_DIR)/tclOOInfo.c $(OOHDR)
- $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclOOInfo.c
-
tclLoad.o: $(GENERIC_DIR)/tclLoad.c
$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclLoad.c
diff --git a/win/Makefile.in b/win/Makefile.in
index d368dd6..c78a018 100644
--- a/win/Makefile.in
+++ b/win/Makefile.in
@@ -5,7 +5,7 @@
# "autoconf" program (constructs like "@foo@" will get replaced in the
# actual Makefile.
#
-# RCS: @(#) $Id: Makefile.in,v 1.107 2006/10/20 14:04:01 dkf Exp $
+# RCS: @(#) $Id: Makefile.in,v 1.108 2006/10/20 15:16:48 dkf Exp $
VERSION = @TCL_VERSION@
@@ -253,10 +253,6 @@ GENERIC_OBJS = \
tclNamesp.$(OBJEXT) \
tclNotify.$(OBJEXT) \
tclObj.$(OBJEXT) \
- tclOO.$(OBJEXT) \
- tclOOCall.$(OBJEXT) \
- tclOODefineCmds.$(OBJEXT) \
- tclOOInfo.$(OBJEXT) \
tclPanic.$(OBJEXT) \
tclParse.$(OBJEXT) \
tclParseExpr.$(OBJEXT) \
@@ -389,10 +385,6 @@ tcltest: $(TCLTEST)
binaries: @LIBRARIES@ $(TCLSH)
-# Special dependencies to make development easier
-tclOO.$(OBJEXT) tclOOCall.$(OBJEXT) tclOODefineCmds.$(OBJEXT) tclOOInfo.$(OBJEXT) tclProc.$(OBJEXT): \
- $(GENERIC_DIR)/tclOO.h
-
libraries:
doc:
diff --git a/win/makefile.bc b/win/makefile.bc
index 006cbc6..a42a06b 100644
--- a/win/makefile.bc
+++ b/win/makefile.bc
@@ -234,10 +234,6 @@ TCLOBJS = \
$(TMPDIR)\tclNamesp.obj \
$(TMPDIR)\tclNotify.obj \
$(TMPDIR)\tclObj.obj \
- $(TMPDIR)\tclOO.obj \
- $(TMPDIR)\tclOOCall.obj \
- $(TMPDIR)\tclOODefineCmds.obj \
- $(TMPDIR)\tclOOInfo.obj \
$(TMPDIR)\tclPanic.obj \
$(TMPDIR)\tclParse.obj \
$(TMPDIR)\tclParseExpr.obj \
diff --git a/win/makefile.vc b/win/makefile.vc
index a214471..898c36a 100644
--- a/win/makefile.vc
+++ b/win/makefile.vc
@@ -12,7 +12,7 @@
# Copyright (c) 2001-2004 David Gravereaux.
#
#------------------------------------------------------------------------------
-# RCS: @(#) $Id: makefile.vc,v 1.152 2006/10/20 14:04:01 dkf Exp $
+# RCS: @(#) $Id: makefile.vc,v 1.153 2006/10/20 15:16:48 dkf Exp $
#------------------------------------------------------------------------------
# Check to see we are configured to build with MSVC (MSDEVDIR or MSVCDIR)
@@ -294,10 +294,6 @@ TCLOBJS = \
$(TMP_DIR)\tclNamesp.obj \
$(TMP_DIR)\tclNotify.obj \
$(TMP_DIR)\tclObj.obj \
- $(TMP_DIR)\tclOO.obj \
- $(TMP_DIR)\tclOOCall.obj \
- $(TMP_DIR)\tclOODefineCmds.obj \
- $(TMP_DIR)\tclOOInfo.obj \
$(TMP_DIR)\tclPanic.obj \
$(TMP_DIR)\tclParse.obj \
$(TMP_DIR)\tclParseExpr.obj \