diff options
Diffstat (limited to 'generic')
| -rw-r--r-- | generic/tcl.h | 83 | ||||
| -rw-r--r-- | generic/tclBasic.c | 18 | ||||
| -rw-r--r-- | generic/tclCmdIL.c | 20 | ||||
| -rw-r--r-- | generic/tclInt.decls | 5 | ||||
| -rw-r--r-- | generic/tclInt.h | 73 | ||||
| -rw-r--r-- | generic/tclIntDecls.h | 6 | ||||
| -rw-r--r-- | generic/tclNamesp.c | 16 | ||||
| -rw-r--r-- | generic/tclOO.c | 3288 | ||||
| -rw-r--r-- | generic/tclOO.h | 389 | ||||
| -rw-r--r-- | generic/tclOOCall.c | 803 | ||||
| -rw-r--r-- | generic/tclOODefineCmds.c | 953 | ||||
| -rw-r--r-- | generic/tclOOInfo.c | 901 | ||||
| -rw-r--r-- | generic/tclProc.c | 275 | ||||
| -rw-r--r-- | generic/tclVar.c | 29 |
14 files changed, 107 insertions, 6752 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. |