Index: generic/tcl.h ================================================================== --- generic/tcl.h +++ generic/tcl.h @@ -11,11 +11,11 @@ * Copyright (c) 2002 by Kevin B. Kenny. All rights reserved. * * 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.210 2005/12/27 17:39:01 kennykb Exp $ + * RCS: @(#) $Id: tcl.h,v 1.210.2.7 2006/10/21 01:11:51 dkf Exp $ */ #ifndef _TCL #define _TCL @@ -502,19 +502,23 @@ } 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; typedef struct Tcl_EncodingState_ *Tcl_EncodingState; 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; typedef struct Tcl_ThreadId_ *Tcl_ThreadId; typedef struct Tcl_TimerToken_ *Tcl_TimerToken; @@ -951,10 +955,12 @@ int dummy6; char *dummy7; char *dummy8; int dummy9; char* dummy10; + void* dummy11; + /*int dummy12;*/ } Tcl_CallFrame; /* * Information about commands that is returned by Tcl_GetCommandInfo and * passed to Tcl_SetCommandInfo. objProc is an objc/objv object-based command @@ -2340,10 +2346,85 @@ #ifndef MP_DIGIT_DECLARED 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_METADATA_VERSION_CURRENT 1 + #ifndef TCL_NO_DEPRECATED /* * Deprecated Tcl functions: */ Index: generic/tclBasic.c ================================================================== --- generic/tclBasic.c +++ generic/tclBasic.c @@ -11,11 +11,11 @@ * Copyright (c) 2001, 2002 by Kevin B. Kenny. All rights reserved. * * 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.189 2006/02/01 19:26:01 dgp Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.189.2.2 2006/09/27 13:23:35 dkf Exp $ */ #include "tclInt.h" #include "tclCompile.h" #include @@ -530,16 +530,21 @@ #ifndef TCL_GENERIC_ONLY TclSetupEnv(interp); #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. */ order.s = 1; @@ -1941,12 +1946,12 @@ */ int TclRenameCommand( Tcl_Interp *interp, /* Current interpreter. */ - char *oldName, /* Existing command name. */ - char *newName) /* New command name. */ + const char *oldName, /* Existing command name. */ + const char *newName) /* New command name. */ { Interp *iPtr = (Interp *) interp; CONST char *newTail; Namespace *cmdNsPtr, *newNsPtr, *dummy1, *dummy2; Tcl_Command cmd; @@ -1959,12 +1964,11 @@ /* * Find the existing command. An error is returned if cmdName can't be * 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 ", ((newName == NULL)||(*newName == '\0'))? "delete":"rename", " \"", oldName, "\": command doesn't exist", NULL); Index: generic/tclCmdIL.c ================================================================== --- generic/tclCmdIL.c +++ generic/tclCmdIL.c @@ -14,11 +14,11 @@ * Copyright (c) 2005 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: tclCmdIL.c,v 1.86 2005/12/09 14:13:00 dkf Exp $ + * RCS: @(#) $Id: tclCmdIL.c,v 1.86.2.1 2006/08/30 14:23:01 dkf Exp $ */ #include "tclInt.h" #include "tclRegexp.h" @@ -355,21 +355,21 @@ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { static CONST char *subCmds[] = { - "args", "body", "cmdcount", "commands", + "args", "body", "class", "cmdcount", "commands", "complete", "default", "exists", "functions", "globals", - "hostname", "level", "library", "loaded", - "locals", "nameofexecutable", "patchlevel", "procs", + "hostname", "level", "library", "loaded", "locals", + "nameofexecutable", "object", "patchlevel", "procs", "script", "sharedlibextension", "tclversion", "vars", (char *) NULL}; enum ISubCmdIdx { - IArgsIdx, IBodyIdx, ICmdCountIdx, ICommandsIdx, + IArgsIdx, IBodyIdx, IClassIdx, ICmdCountIdx, ICommandsIdx, ICompleteIdx, IDefaultIdx, IExistsIdx, IFunctionsIdx, IGlobalsIdx, - IHostnameIdx, ILevelIdx, ILibraryIdx, ILoadedIdx, - ILocalsIdx, INameOfExecutableIdx, IPatchLevelIdx, IProcsIdx, + IHostnameIdx, ILevelIdx, ILibraryIdx, ILoadedIdx, ILocalsIdx, + INameOfExecutableIdx, IObjectIdx, IPatchLevelIdx, IProcsIdx, IScriptIdx, ISharedLibExtensionIdx, ITclVersionIdx, IVarsIdx }; int index, result; if (objc < 2) { @@ -388,10 +388,13 @@ result = InfoArgsCmd(clientData, interp, objc, objv); break; 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; case ICommandsIdx: result = InfoCommandsCmd(clientData, interp, objc, objv); @@ -427,10 +430,13 @@ result = InfoLocalsCmd(clientData, interp, objc, objv); break; 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; case IProcsIdx: result = InfoProcsCmd(clientData, interp, objc, objv); Index: generic/tclInt.decls ================================================================== --- generic/tclInt.decls +++ generic/tclInt.decls @@ -10,11 +10,11 @@ # Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. # # 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.94 2005/12/13 22:43:17 kennykb Exp $ +# RCS: @(#) $Id: tclInt.decls,v 1.94.2.1 2006/09/27 13:23:35 dkf Exp $ library tcl # Define the unsupported generic interfaces. @@ -388,11 +388,12 @@ # Replaced by Tcl_FSStat in 8.4: #declare 95 generic { # int TclpStat(CONST char *path, Tcl_StatBuf *buf) #} declare 96 generic { - int TclRenameCommand(Tcl_Interp *interp, char *oldName, char *newName) + int TclRenameCommand(Tcl_Interp *interp, CONST char *oldName, + CONST char *newName) } declare 97 generic { void TclResetShadowedCmdRefs(Tcl_Interp *interp, Command *newCmdPtr) } declare 98 generic { Index: generic/tclInt.h ================================================================== --- generic/tclInt.h +++ generic/tclInt.h @@ -10,11 +10,11 @@ * Copyright (c) 2001, 2002 by Kevin B. Kenny. All rights reserved. * * 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.267 2006/02/01 19:26:02 dgp Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.267.2.12 2006/10/21 01:11:51 dkf Exp $ */ #ifndef _TCLINT #define _TCLINT @@ -109,10 +109,12 @@ * having a tclWideIntType separate from the tclIntType. */ #ifdef TCL_WIDE_INT_IS_LONG #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. */ @@ -888,13 +890,19 @@ * compiler including arguments. */ Var* compiledLocals; /* Points to the array of local variables * 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_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 /* *---------------------------------------------------------------- * Data structures and procedures related to TclHandles, which are a very * lightweight method of preserving enough information to determine if an @@ -1508,16 +1516,27 @@ /* * TIP #219 ... Global info for the I/O system ... */ - Tcl_Obj* chanMsg; /* Error message set by channel drivers, for + Tcl_Obj *chanMsg; /* Error message set by channel drivers, for * the propagation of arbitrary Tcl errors. * This information, if present (chanMsg not * NULL), takes precedence over a posix error * code returned by a channel operation. */ + /* + * TIP #257 - Object Orientation Programming Infrastructure. + */ + + struct Foundation *ooFoundation; + /* Pointer to the structure that manages the + * core of the object-orientation support. + * The actual definition of this structure is + * in tclOO.h, so this is just an opaque + * pointer if that file isn't #included. */ + /* * Statistical information about the bytecode compiler and interpreter's * operation. */ @@ -2093,11 +2112,11 @@ MODULE_SCOPE void TclInitIOSubsystem(void); 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 (); +MODULE_SCOPE void TclInitSubsystems(void); 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); MODULE_SCOPE void TclLimitRemoveAllHandlers(Tcl_Interp *interp); MODULE_SCOPE Tcl_Obj * TclLindexList(Tcl_Interp* interp, @@ -2358,10 +2377,16 @@ MODULE_SCOPE int Tcl_IncrObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); 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[]); MODULE_SCOPE int Tcl_JoinObjCmd(ClientData clientData, @@ -2498,10 +2523,56 @@ Tcl_Obj *CONST objv[]); MODULE_SCOPE int Tcl_WhileObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); +/* + *---------------------------------------------------------------- + * 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 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: *---------------------------------------------------------------- */ @@ -3028,10 +3099,16 @@ #define TclIsNaN(d) (_isnan((d))) #else #define TclIsInfinite(d) ( (d) > DBL_MAX || (d) < -DBL_MAX ) #define TclIsNaN(d) ((d) != (d)) #endif + +// vvvvvvvvvvvvvvvvvvvvvv MOVE TO TCLINT.DECLS vvvvvvvvvvvvvvvvvvvvvv +void TclSetNsPath(Namespace *nsPtr, int pathLength, + Tcl_Namespace *pathAry[]); +Tcl_Object TclOOGetDefineCmdContext(Tcl_Interp *interp); +// ^^^^^^^^^^^^^^^^^^^^^^ MOVE TO TCLINT.DECLS ^^^^^^^^^^^^^^^^^^^^^^ #include "tclPort.h" #include "tclIntDecls.h" #include "tclIntPlatDecls.h" #include "tclTomMathDecls.h" Index: generic/tclIntDecls.h ================================================================== --- generic/tclIntDecls.h +++ generic/tclIntDecls.h @@ -9,11 +9,11 @@ * Copyright (c) 1998-1999 by Scriptics Corporation. * * 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.85 2005/12/13 22:43:18 kennykb Exp $ + * RCS: @(#) $Id: tclIntDecls.h,v 1.85.2.1 2006/09/27 13:24:02 dkf Exp $ */ #ifndef _TCLINTDECLS #define _TCLINTDECLS @@ -442,11 +442,11 @@ /* Slot 95 is reserved */ #ifndef TclRenameCommand_TCL_DECLARED #define TclRenameCommand_TCL_DECLARED /* 96 */ EXTERN int TclRenameCommand _ANSI_ARGS_((Tcl_Interp * interp, - char * oldName, char * newName)); + CONST char * oldName, CONST char * newName)); #endif #ifndef TclResetShadowedCmdRefs_TCL_DECLARED #define TclResetShadowedCmdRefs_TCL_DECLARED /* 97 */ EXTERN void TclResetShadowedCmdRefs _ANSI_ARGS_(( @@ -1171,11 +1171,11 @@ void (*tclProcCleanupProc) _ANSI_ARGS_((Proc * procPtr)); /* 91 */ int (*tclProcCompileProc) _ANSI_ARGS_((Tcl_Interp * interp, Proc * procPtr, Tcl_Obj * bodyPtr, Namespace * nsPtr, CONST char * description, CONST char * procName)); /* 92 */ void (*tclProcDeleteProc) _ANSI_ARGS_((ClientData clientData)); /* 93 */ void *reserved94; void *reserved95; - int (*tclRenameCommand) _ANSI_ARGS_((Tcl_Interp * interp, char * oldName, char * newName)); /* 96 */ + int (*tclRenameCommand) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * oldName, CONST char * newName)); /* 96 */ void (*tclResetShadowedCmdRefs) _ANSI_ARGS_((Tcl_Interp * interp, Command * newCmdPtr)); /* 97 */ int (*tclServiceIdle) _ANSI_ARGS_((void)); /* 98 */ void *reserved99; void *reserved100; char * (*tclSetPreInitScript) _ANSI_ARGS_((char * string)); /* 101 */ Index: generic/tclNamesp.c ================================================================== --- generic/tclNamesp.c +++ generic/tclNamesp.c @@ -20,11 +20,11 @@ * mmclennan@lucent.com * * 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.93 2006/02/01 18:27:47 dgp Exp $ + * RCS: @(#) $Id: tclNamesp.c,v 1.93.2.3 2006/07/10 01:17:32 dkf Exp $ */ #include "tclInt.h" /* @@ -115,12 +115,12 @@ * this field points to this ensemble, the * structure has already been unlinked from * all lists, and cannot be found by scanning * the list from the namespace's ensemble * field. */ - int flags; /* ORed combo of ENS_DEAD and - * TCL_ENSEMBLE_PREFIX. */ + int flags; /* ORed combo of TCL_ENSEMBLE_PREFIX and + * ENS_DEAD. */ /* OBJECT FIELDS FOR ENSEMBLE CONFIGURATION */ Tcl_Obj *subcommandDict; /* Dictionary providing mapping from * subcommands to their implementing command @@ -249,12 +249,10 @@ CONST char *subcmdName, Tcl_Obj *prefixObjPtr); 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 * reference. It is used in commands that take the name of a namespace as an * argument. The namespace reference is resolved, and the result in cached in @@ -3774,11 +3772,11 @@ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *CONST objv[]) /* Argument objects. */ { Tcl_Namespace *namespacePtr; - CallFrame *framePtr; + CallFrame *framePtr, **framePtrPtr; int i, result; if (objc < 4) { Tcl_WrongNumArgs(interp, 2, objv, "name arg ?arg...?"); return TCL_ERROR; @@ -3800,11 +3798,12 @@ /* * Make the specified namespace the current namespace. */ - result = TclPushStackFrame(interp, (Tcl_CallFrame **)&framePtr, + framePtrPtr = &framePtr; + result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, namespacePtr, /*isProcCallFrame*/ 0); if (result != TCL_OK) { return result; } framePtr->objc = objc; @@ -4078,11 +4077,11 @@ /* * Now we have the list of valid namespaces, install it as the path. */ - SetNsPath(nsPtr, nsObjc, namespaceList); + TclSetNsPath(nsPtr, nsObjc, namespaceList); result = TCL_OK; badNamespace: if (namespaceList != NULL && namespaceList != staticNs) { ckfree((char *) namespaceList); @@ -4091,11 +4090,11 @@ } /* *---------------------------------------------------------------------- * - * SetNsPath -- + * TclSetNsPath -- * * 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 * empty and the default old-style behaviour of command name resolution * is used. @@ -4109,12 +4108,12 @@ * *---------------------------------------------------------------------- */ /* EXPOSE ME? */ -static void -SetNsPath( +void +TclSetNsPath( Namespace *nsPtr, /* Namespace whose path is to be set. */ int pathLength, /* Length of pathAry */ Tcl_Namespace *pathAry[]) /* Array of namespaces that are the path. */ { NamespacePathEntry *tmpPathArray; ADDED generic/tclOO.c Index: generic/tclOO.c ================================================================== --- /dev/null +++ generic/tclOO.c @@ -0,0 +1,3443 @@ +/* + * 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.1.2.69 2006/10/31 09:20:33 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}, + {"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}, + {"superclass", TclOODefineSuperclassObjCmd, 0}, + {"unexport", TclOODefineUnexportObjCmd, 0}, + {"self.unexport", TclOODefineUnexportObjCmd, 1}, + {"self.class", TclOODefineSelfClassObjCmd, 1}, + {NULL, NULL, 0} +}; + +/* + * Structure containing definition information about class methods. + */ + +typedef struct DeclaredClassMethod { + const char *name; /* Name of the method in question. */ + int isPublic; /* Whether the method is public by default. */ + Tcl_MethodCallProc callProc;/* How to call the method. */ +} DeclaredClassMethod; + +/* + * 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 DeclaredClassMethod *dcm); +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 CopyObjectCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const *objv); +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 DeclaredClassMethodInvoke(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", + DeclaredClassMethodInvoke, NULL, NULL +}; + +/* + * Methods in the oo::object class. + */ + +static const DeclaredClassMethod objMethods[] = { + {"destroy", 1, ObjectDestroy}, + {"eval", 0, ObjectEval}, + {"unknown", 0, ObjectUnknown}, + {"variable", 0, ObjectLinkVar}, + {"varname", 0, ObjectVarName}, + {NULL, 0, NULL} +}; + +/* + * Additional methods in the oo::class class. + */ + +static const DeclaredClassMethod clsMethods[] = { + {"create", 1, ClassCreate}, + {"new", 1, ClassNew}, + {NULL, 0, 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_CreateObjCommand(interp, "::oo::copy", CopyObjectCmd, 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. + */ + + for (i=0 ; objMethods[i].name ; i++) { + DeclareClassMethod(interp, fPtr->objectCls, &objMethods[i]); + } + for (i=0 ; clsMethods[i].name ; i++) { + DeclareClassMethod(interp, fPtr->classCls, &clsMethods[i]); + } + + /* + * 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); + } + + /* + * Finish setting up the [info object] and [info class] commands. + */ + + TclOOInitInfo(interp); + 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 ; iflags & 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 ; iflags & 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 ; iflags & 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. Once that's done, we need to repatch the object to have the + * right class since AllocClass interferes with that. + */ + + AllocClass(interp, oPtr); + oPtr->selfCls = (Class *) cls; + } + + 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 flags, /* 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 (flags) { + mPtr->flags |= flags & (PUBLIC_METHOD | PRIVATE_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 flags, /* 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 (flags) { + mPtr->flags |= flags & (PUBLIC_METHOD | PRIVATE_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 DeclaredClassMethod *dcm) + /* Name of the method, whether it is public, + * and the function to implement it. */ +{ + Tcl_Obj *namePtr; + + TclNewStringObj(namePtr, dcm->name, strlen(dcm->name)); + Tcl_IncrRefCount(namePtr); + Tcl_NewClassMethod(interp, (Tcl_Class) clsPtr, namePtr, + (dcm->isPublic ? PUBLIC_METHOD : 0), &coreMethodType, + (ClientData) dcm); + TclDecrRefCount(namePtr); +} + +/* + * ---------------------------------------------------------------------- + * + * DeclaredClassMethodInvoke -- + * + * How to invoke a simple method. + * + * ---------------------------------------------------------------------- + */ + +static int +DeclaredClassMethodInvoke( + 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. */ +{ + const DeclaredClassMethod *dcm = clientData; + + return (dcm->callProc)(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 flags, /* 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, + flags, &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 flags, /* 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 = ""; + } else if (Tcl_ListObjLength(interp, argsObj, &argsLen) != TCL_OK) { + return NULL; + } else { + procName = (nameObj==NULL ? "" : 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, + flags, &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 = ""; + flags |= FRAME_IS_CONSTRUCTOR; + nameObj = Tcl_NewStringObj("", -1); + Tcl_IncrRefCount(nameObj); + } else if (contextPtr->flags & DESTRUCTOR) { + namePtr = ""; + flags |= FRAME_IS_DESTRUCTOR; + nameObj = Tcl_NewStringObj("", -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 flags, /* 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, + flags, &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 flags, /* 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, + flags, &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. + */ + + TclListObjGetElements(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, PUBLIC_METHOD, + &((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 flags, /* 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], + flags | (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 ; ivariable 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) ; ivarFramePtr->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, "", NULL); + } else if (contextPtr->flags & DESTRUCTOR) { + Tcl_AppendResult(interp, "", 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 { + struct MInvoke *miPtr = &contextPtr->callChain[contextPtr->index]; + Tcl_Obj *result[3]; + Object *oPtr; + const char *type; + + if (miPtr->filterDeclarer != NULL) { + oPtr = miPtr->filterDeclarer->thisPtr; + type = "class"; + } else { + oPtr = contextPtr->oPtr; + type = "object"; + } + + TclNewObj(result[0]); + Tcl_GetCommandFullName(interp, oPtr->command, result[0]); + result[1] = Tcl_NewStringObj(type, -1); + result[2] = miPtr->mPtr->namePtr; + Tcl_SetObjResult(interp, Tcl_NewListObj(3, result)); + 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("", -1)); + } else if (callerPtr->flags & DESTRUCTOR) { + Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), + Tcl_NewStringObj("", -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("", -1)); + } else if (contextPtr->flags & DESTRUCTOR) { + Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), + Tcl_NewStringObj("", -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 ; inumCallChain ; 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; +} + +/* + * ---------------------------------------------------------------------- + * + * CopyObjectCmd -- + * + * Implementation of the [oo::copy] command, which clones an object (but + * not its namespace). Note that no constructors are called during this + * process. + * + * ---------------------------------------------------------------------- + */ + +static int +CopyObjectCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + Tcl_Object oPtr, o2Ptr; + + if (objc < 2 || objc > 3) { + Tcl_WrongNumArgs(interp, 1, objv, "sourceName ?targetName?"); + return TCL_ERROR; + } + + oPtr = Tcl_GetObjectFromObj(interp, objv[1]); + 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 == 2) { + o2Ptr = Tcl_CopyObjectInstance(interp, oPtr, NULL); + } else { + char *name; + Tcl_DString buffer; + + name = TclGetString(objv[2]); + Tcl_DStringInit(&buffer); + if (name[0]!=':' || name[1]!=':') { + Interp *iPtr = (Interp *) interp; + + if (iPtr->varFramePtr != NULL) { + Tcl_DStringAppend(&buffer, + iPtr->varFramePtr->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; +} + +/* + * ---------------------------------------------------------------------- + * + * 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_ObjectContextMethod, ... -- + * + * Simple introspector functions. People would read the structures + * directly for this sort of information, except that we discourage that + * sort of thing as it makes it harder to evolve the internal data + * structures. None of these change anything. + * + * ---------------------------------------------------------------------- + */ + +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; +} + +/* + * ---------------------------------------------------------------------- + * + * Tcl_OOGetObjectClass, Tcl_OOGetClassClass -- + * + * Get the basic ::oo::object and ::oo::class classes. + * + * ---------------------------------------------------------------------- + */ + +Tcl_Class +Tcl_GetClassOfObjects( + Tcl_Interp *interp) +{ + Foundation *fPtr = ((Interp *) interp)->ooFoundation; + return (Tcl_Class) fPtr->objectCls; +} + +Tcl_Class +Tcl_GetClassOfClasses( + Tcl_Interp *interp) +{ + Foundation *fPtr = ((Interp *) interp)->ooFoundation; + return (Tcl_Class) fPtr->classCls; +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ ADDED generic/tclOO.h Index: generic/tclOO.h ================================================================== --- /dev/null +++ generic/tclOO.h @@ -0,0 +1,393 @@ +/* + * 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.1.2.41 2006/10/31 09:20:33 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); +Tcl_Class Tcl_GetClassOfClasses(Tcl_Interp *interp); +Tcl_Class Tcl_GetClassOfObjects(Tcl_Interp *interp); +// ^^^^^^^^^^^^^^^^^^^^^^ 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. */ + Class *filterDeclarer; /* What class decided to add the filter; if + * NULL, it was added by the object. */ +}; + +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]; +} CallContext; + +/* + * Bits for the 'flags' field of the call context. + */ + +#define PUBLIC_METHOD 0x01 /* This is a public (exported) method. */ +#define PRIVATE_METHOD 0x02 /* This is a private (class's direct instances + * only) method. */ +#define OO_UNKNOWN_METHOD 0x04 /* This is an unknown method. */ +#define CONSTRUCTOR 0x08 /* This is a constructor. */ +#define DESTRUCTOR 0x10 /* 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 void TclOOInitInfo(Tcl_Interp *interp); +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 flags, + 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: + */ ADDED generic/tclOOCall.c Index: generic/tclOOCall.c ================================================================== --- /dev/null +++ generic/tclOOCall.c @@ -0,0 +1,899 @@ +/* + * 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.1.2.5 2006/10/22 23:01:37 dkf Exp $ + */ + +#include "tclInt.h" +#include "tclOO.h" + +/* + * Structure containing a CallContext and any other values needed only during + * the construction of the CallContext. + */ + +struct ChainBuilder { + CallContext *contextPtr; /* The call context being built. */ + int filterLength; /* Number of entries in the call chain that + * are due to processing filters and not the + * main call chain. */ +}; + +/* + * Extra flags used for call chain management. + */ + +#define DEFINITE_PROTECTED 0x100000 +#define DEFINITE_PUBLIC 0x200000 +#define KNOWN_STATE (DEFINITE_PROTECTED | DEFINITE_PUBLIC) +#define SPECIAL (CONSTRUCTOR | DESTRUCTOR) + +/* + * Function declarations for things defined in this file. + */ + +static void AddClassFiltersToCallContext(Object *oPtr, + Class *clsPtr, struct ChainBuilder *cbPtr, + Tcl_HashTable *doneFilters); +static void AddClassMethodNames(Class *clsPtr, int flags, + Tcl_HashTable *namesPtr); +static void AddMethodToCallChain(Method *mPtr, + struct ChainBuilder *cbPtr, + Tcl_HashTable *doneFilters, Class *filterDecl); +static void AddSimpleChainToCallContext(Object *oPtr, + Tcl_Obj *methodNameObj, struct ChainBuilder *cbPtr, + Tcl_HashTable *doneFilters, int isPublic, + Class *filterDecl); +static void AddSimpleClassChainToCallContext(Class *classPtr, + Tcl_Obj *methodNameObj, struct ChainBuilder *cbPtr, + Tcl_HashTable *doneFilters, int isPublic, + Class *filterDecl); +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 ; inumCallChain ; 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 ; inumCallChain ; i++) { + Tcl_Release(contextPtr->callChain[i].mPtr); + } + } + return result; +} + +/* + * ---------------------------------------------------------------------- + * + * InitClassHierarchy -- + * + * Builds the basic class hierarchy cache. This does not include mixins. + * + * ---------------------------------------------------------------------- + */ + +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 ; jj ; 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 ; jclassHierarchy.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 flags, /* 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; /* Tcl_Obj* method name to "wanted in list" + * mapping. */ + FOREACH_HASH_DECLS; + int i; + Class *mixinPtr; + Tcl_Obj *namePtr; + Method *mPtr; + void *isWanted; + + Tcl_InitObjHashTable(&names); + + /* + * Process method names due to the object. + */ + + FOREACH_HASH(namePtr, mPtr, &oPtr->methods) { + int isNew; + + if ((mPtr->flags & PRIVATE_METHOD) && !(flags & PRIVATE_METHOD)) { + continue; + } + hPtr = Tcl_CreateHashEntry(&names, (char *) namePtr, &isNew); + if (isNew) { + isWanted = (void *) (!(flags & PUBLIC_METHOD) + || mPtr->flags & PUBLIC_METHOD); + Tcl_SetHashValue(hPtr, isWanted); + } + } + + /* + * Process method names due to private methods on the object's class. + */ + + if (flags & PRIVATE_METHOD) { + FOREACH_HASH(namePtr, mPtr, &oPtr->selfCls->classMethods) { + if (mPtr->flags & PRIVATE_METHOD) { + int isNew; + + hPtr = Tcl_CreateHashEntry(&names, (char *) namePtr, &isNew); + if (isNew) { + isWanted = (void *) 1; + Tcl_SetHashValue(hPtr, isWanted); + } + } + } + } + + /* + * Process (normal) method names from the class hierarchy and the mixin + * hierarchy. + */ + + AddClassMethodNames(oPtr->selfCls, flags, &names); + FOREACH(mixinPtr, oPtr->mixins) { + AddClassMethodNames(mixinPtr, flags, &names); + } + + /* + * See how many (visible) method names there are. If none, we do not (and + * should not) try to sort the list of them. + */ + + i = 0; + if (names.numEntries != 0) { + const char **strings; + + /* + * We need to build the list of methods to sort. We will be using + * qsort() for this, because it is very unlikely that the list will be + * heavily sorted when it is long enough to matter. + */ + + strings = (const char **) ckalloc(sizeof(char *) * names.numEntries); + FOREACH_HASH(namePtr, isWanted, &names) { + if (!(flags & PUBLIC_METHOD) || 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); + *stringsPtr = strings; + } + + Tcl_DeleteHashTable(&names); + 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 flags, /* 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, flags, 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 = (!(flags & PUBLIC_METHOD) + || (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, flags, 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 PUBLIC_METHOD, CONSTRUCTOR, + * PRIVATE_METHOD, DESTRUCTOR and + * FILTER_HANDLING are useful. */ + Tcl_HashTable *cachePtr) /* Where to cache the chain. Ignored for both + * constructors and destructors. */ +{ + struct ChainBuilder cb; + 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) { + cb.contextPtr = Tcl_GetHashValue(hPtr); + Tcl_SetHashValue(hPtr, NULL); + if ((cb.contextPtr->globalEpoch == fPtr->epoch) + && (cb.contextPtr->localEpoch == oPtr->epoch)) { + return cb.contextPtr; + } + TclOODeleteContext(cb.contextPtr); + } + } + cb.contextPtr = (CallContext *) ckalloc(sizeof(CallContext)); + cb.contextPtr->numCallChain = 0; + cb.contextPtr->callChain = cb.contextPtr->staticCallChain; + cb.filterLength = 0; + cb.contextPtr->globalEpoch = fPtr->epoch; + cb.contextPtr->localEpoch = oPtr->epoch; + cb.contextPtr->flags = 0; + cb.contextPtr->skip = 2; + if (flags & (PUBLIC_METHOD|PRIVATE_METHOD|SPECIAL|FILTER_HANDLING)) { + cb.contextPtr->flags |= + flags&(PUBLIC_METHOD|PRIVATE_METHOD|SPECIAL|FILTER_HANDLING); + } + cb.contextPtr->oPtr = oPtr; + cb.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, &cb, &doneFilters); + } + FOREACH(filterObj, oPtr->filters) { + AddSimpleChainToCallContext(oPtr, filterObj, &cb, &doneFilters, 0, + NULL); + } + AddClassFiltersToCallContext(oPtr, oPtr->selfCls, &cb, &doneFilters); + Tcl_DeleteHashTable(&doneFilters); + } + count = cb.filterLength = cb.contextPtr->numCallChain; + + /* + * Add the actual method implementations. + */ + + AddSimpleChainToCallContext(oPtr, methodNameObj, &cb, NULL, flags, NULL); + + /* + * 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 == cb.contextPtr->numCallChain) { + /* + * Method does not actually exist. If we're dealing with constructors + * or destructors, this isn't a problem. + */ + + if (flags & SPECIAL) { + TclOODeleteContext(cb.contextPtr); + return NULL; + } + AddSimpleChainToCallContext(oPtr, fPtr->unknownMethodNameObj, &cb, + NULL, 0, NULL); + cb.contextPtr->flags |= OO_UNKNOWN_METHOD; + cb.contextPtr->globalEpoch = -1; + if (count == cb.contextPtr->numCallChain) { + TclOODeleteContext(cb.contextPtr); + return NULL; + } + } else if (doFilters) { + if (hPtr == NULL) { + hPtr = Tcl_CreateHashEntry(cachePtr, (char *) methodNameObj, &i); + } + Tcl_SetHashValue(hPtr, NULL); + } + return cb.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. */ + struct ChainBuilder *const cbPtr, + /* 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, cbPtr, doneFilters, + 0, clsPtr); + } + } + + /* + * 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, cbPtr, 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. */ + struct ChainBuilder *cbPtr, /* 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. */ + Class *filterDecl) /* The class that declared the filter. If + * NULL, either the filter was declared by the + * object or this isn't a filter. */ +{ + 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_PROTECTED; + } + } + } + if (!(flags & SPECIAL)) { + Tcl_HashEntry *hPtr; + Class *mixinPtr, *superPtr; + + FOREACH(mixinPtr, oPtr->mixins) { + AddSimpleClassChainToCallContext(mixinPtr, methodNameObj, cbPtr, + doneFilters, flags, filterDecl); + } + FOREACH(mixinPtr, oPtr->selfCls->mixins) { + AddSimpleClassChainToCallContext(mixinPtr, methodNameObj, cbPtr, + doneFilters, flags, filterDecl); + } + FOREACH(superPtr, oPtr->selfCls->classHierarchy) { + int j=i; /* HACK: save index so can nest FOREACHes. */ + FOREACH(mixinPtr, superPtr->mixins) { + AddSimpleClassChainToCallContext(mixinPtr, methodNameObj, + cbPtr, doneFilters, flags, filterDecl); + } + i=j; + } + hPtr = Tcl_FindHashEntry(&oPtr->methods, (char *) methodNameObj); + if (hPtr != NULL) { + AddMethodToCallChain(Tcl_GetHashValue(hPtr), cbPtr, doneFilters, + filterDecl); + } + } + AddSimpleClassChainToCallContext(oPtr->selfCls, methodNameObj, cbPtr, + doneFilters, flags, filterDecl); +} + +/* + * ---------------------------------------------------------------------- + * + * 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. */ + struct ChainBuilder *const cbPtr, + /* 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. */ + Class *filterDecl) /* The class that declared the filter. If + * NULL, either the filter was declared by the + * object or this isn't a filter. */ +{ + /* + * 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, cbPtr, doneFilters, + filterDecl); + } else if (flags & DESTRUCTOR) { + AddMethodToCallChain(classPtr->destructorPtr, cbPtr, doneFilters, + filterDecl); + } 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_PROTECTED; + } + } + AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl); + } + } + + 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, cbPtr, + doneFilters, flags, filterDecl); + } + } + 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). */ + struct ChainBuilder *cbPtr, /* 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. */ + Class *filterDecl) /* The class that declared the filter. If + * NULL, either the filter was declared by the + * object or this isn't a filter. */ +{ + register CallContext *contextPtr = cbPtr->contextPtr; + 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; + } + + /* + * Enforce real private method handling here. We will skip adding this + * method IF + * 1) we are not allowing private methods, AND + * 2) this is a private method, AND + * 3) this is a class method, AND + * 4) this method was not declared by the class of the current object. + * + * This does mean that only classes really handle private methods. This + * should be sufficient for [incr Tcl] support though. + */ + + if (!(contextPtr->flags & PRIVATE_METHOD) + && (mPtr->flags & PRIVATE_METHOD) + && (mPtr->declaringClassPtr != NULL) + && (mPtr->declaringClassPtr != contextPtr->oPtr->selfCls)) { + return; + } + + /* + * First test whether the method is already in the call chain. Skip over + * any leading filters. + */ + + for (i=cbPtr->filterLength ; inumCallChain ; 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. + */ + + Class *declCls = contextPtr->callChain[i].filterDeclarer; + + for (; i+1numCallChain ; i++) { + contextPtr->callChain[i] = contextPtr->callChain[i+1]; + } + contextPtr->callChain[i].mPtr = mPtr; + contextPtr->callChain[i].isFilter = (doneFilters != NULL); + contextPtr->callChain[i].filterDeclarer = declCls; + 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[i].mPtr = mPtr; + contextPtr->callChain[i].isFilter = (doneFilters != NULL); + contextPtr->callChain[i].filterDeclarer = filterDecl; + contextPtr->numCallChain++; +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ ADDED generic/tclOODefineCmds.c Index: generic/tclOODefineCmds.c ================================================================== --- /dev/null +++ generic/tclOODefineCmds.c @@ -0,0 +1,880 @@ +/* + * 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.1.2.29 2006/10/23 13:20:59 dkf Exp $ + */ + +#include "tclInt.h" +#include "tclOO.h" + +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); + TclListObjGetElements(objPtr, dummy, objs); + + result = Tcl_EvalObjv(interp, objc-2, objs, TCL_EVAL_INVOKE); + TclDecrRefCount(objPtr); + } + + /* + * Restore the previous "current" namespace. + */ + + TclPopStackFrame(interp); + return result; +} + +Tcl_Object +TclOOGetDefineCmdContext( + 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 (Tcl_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 = (Object *) TclOOGetDefineCmdContext(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, PUBLIC_METHOD, 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 +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 = (Object *) TclOOGetDefineCmdContext(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, PUBLIC_METHOD, 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 = (Object *) TclOOGetDefineCmdContext(interp); + if (oPtr == NULL) { + return TCL_ERROR; + } + clsPtr = oPtr->classPtr; + isSelfExport |= (clsPtr == NULL); + + for (i=1 ; imethods, (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 = (Object *) TclOOGetDefineCmdContext(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) { + /* + * No list of filters was supplied, so we're deleting filters. + */ + + ckfree((char *) oPtr->classPtr->filters.list); + oPtr->classPtr->filters.list = NULL; + oPtr->classPtr->filters.num = 0; + } else { + /* + * We've got a list of filters, so we're 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 ; iclassPtr->filters.list = filters; + oPtr->classPtr->filters.num = objc-1; + } + + /* + * There may be many objects affected, so bump the global epoch. + */ + + ((Interp *)interp)->ooFoundation->epoch++; + } else { + if (oPtr->filters.num) { + Tcl_Obj *filterObj; + + FOREACH(filterObj, oPtr->filters) { + TclDecrRefCount(filterObj); + } + } + if (objc == 1) { + /* + * No list of filters was supplied, so we're deleting filters. + */ + + ckfree((char *) oPtr->filters.list); + oPtr->filters.list = NULL; + oPtr->filters.num = 0; + } else { + /* + * We've got a list of filters, so we're 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 ; ifilters.list = filters; + oPtr->filters.num = objc-1; + } + oPtr->epoch++; /* Only this object can be affected. */ + } + 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 = (Object *) TclOOGetDefineCmdContext(interp); + if (oPtr == NULL) { + return TCL_ERROR; + } + isSelfForward |= (oPtr->classPtr == NULL); + isPublic = Tcl_StringMatch(TclGetString(objv[1]), "[a-z]*") + ? PUBLIC_METHOD : 0; + + /* + * 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 = (Object *) TclOOGetDefineCmdContext(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]*") + ? PUBLIC_METHOD : 0; + + 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 = (Object *) TclOOGetDefineCmdContext(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 ; iclassPtr == 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 ; iclassPtr == 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; +} + +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 = (Object *) TclOOGetDefineCmdContext(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 = (Object *) TclOOGetDefineCmdContext(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 ; iclassPtr == NULL) { + Tcl_AppendResult(interp, "only a class can be a superclass",NULL); + goto failedAfterAlloc; + } + for (j=0 ; jclassPtr) { + 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 = (Object *) TclOOGetDefineCmdContext(interp); + if (oPtr == NULL) { + return TCL_ERROR; + } + clsPtr = oPtr->classPtr; + isSelfUnexport |= (oPtr->classPtr == NULL); + + for (i=1 ; imethods, (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: + */ ADDED generic/tclOOInfo.c Index: generic/tclOOInfo.c ================================================================== --- /dev/null +++ generic/tclOOInfo.c @@ -0,0 +1,1063 @@ +/* + * 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.1.2.20 2006/10/22 23:01:37 dkf Exp $ + */ + +#include "tclInt.h" +#include "tclOO.h" + +static Tcl_ObjCmdProc InfoObjectClassCmd; +static Tcl_ObjCmdProc InfoObjectDefnCmd; +static Tcl_ObjCmdProc InfoObjectFiltersCmd; +static Tcl_ObjCmdProc InfoObjectForwardCmd; +static Tcl_ObjCmdProc InfoObjectIsACmd; +static Tcl_ObjCmdProc InfoObjectMethodsCmd; +static Tcl_ObjCmdProc InfoObjectMixinsCmd; +static Tcl_ObjCmdProc InfoObjectVarsCmd; +static Tcl_ObjCmdProc InfoClassConstrCmd; +static Tcl_ObjCmdProc InfoClassDefnCmd; +static Tcl_ObjCmdProc InfoClassDestrCmd; +static Tcl_ObjCmdProc InfoClassFiltersCmd; +static Tcl_ObjCmdProc InfoClassForwardCmd; +static Tcl_ObjCmdProc InfoClassInstancesCmd; +static Tcl_ObjCmdProc InfoClassMethodsCmd; +static Tcl_ObjCmdProc InfoClassMixinsCmd; +static Tcl_ObjCmdProc InfoClassSubsCmd; +static Tcl_ObjCmdProc InfoClassSupersCmd; + +struct NameProcMap { const char *name; Tcl_ObjCmdProc *proc; }; + +/* + * List of commands that are used to implement the [info object] subcommands. + */ + +static const struct NameProcMap infoObjectCmds[] = { + {"::oo::InfoObject::class", InfoObjectClassCmd}, + {"::oo::InfoObject::definition", InfoObjectDefnCmd}, + {"::oo::InfoObject::filters", InfoObjectFiltersCmd}, + {"::oo::InfoObject::forward", InfoObjectForwardCmd}, + {"::oo::InfoObject::isa", InfoObjectIsACmd}, + {"::oo::InfoObject::methods", InfoObjectMethodsCmd}, + {"::oo::InfoObject::mixins", InfoObjectMixinsCmd}, + {"::oo::InfoObject::vars", InfoObjectVarsCmd}, + {NULL, NULL} +}; + +/* + * List of commands that are used to implement the [info class] subcommands. + */ + +static const struct NameProcMap infoClassCmds[] = { + {"::oo::InfoClass::constructor", InfoClassConstrCmd}, + {"::oo::InfoClass::definition", InfoClassDefnCmd}, + {"::oo::InfoClass::destructor", InfoClassDestrCmd}, + {"::oo::InfoClass::filters", InfoClassFiltersCmd}, + {"::oo::InfoClass::forward", InfoClassForwardCmd}, + {"::oo::InfoClass::instances", InfoClassInstancesCmd}, + {"::oo::InfoClass::methods", InfoClassMethodsCmd}, + {"::oo::InfoClass::mixins", InfoClassMixinsCmd}, + {"::oo::InfoClass::subclasses", InfoClassSubsCmd}, + {"::oo::InfoClass::superclasses", InfoClassSupersCmd}, + {NULL, NULL} +}; + +void +TclOOInitInfo( + Tcl_Interp *interp) +{ + Tcl_Namespace *nsPtr; + int i; + + /* + * Build the ensemble used to implement [info object]. + */ + + nsPtr = Tcl_CreateNamespace(interp, "::oo::InfoObject", NULL, NULL); + Tcl_CreateEnsemble(interp, nsPtr->fullName, nsPtr, TCL_ENSEMBLE_PREFIX); + Tcl_Export(interp, nsPtr, "[a-z]*", 1); + for (i=0 ; infoObjectCmds[i].name!=NULL ; i++) { + Tcl_CreateObjCommand(interp, infoObjectCmds[i].name, + infoObjectCmds[i].proc, NULL, NULL); + } + + /* + * Build the ensemble used to implement [info class]. + */ + + nsPtr = Tcl_CreateNamespace(interp, "::oo::InfoClass", NULL, NULL); + Tcl_CreateEnsemble(interp, nsPtr->fullName, nsPtr, TCL_ENSEMBLE_PREFIX); + Tcl_Export(interp, nsPtr, "[a-z]*", 1); + for (i=0 ; infoClassCmds[i].name!=NULL ; i++) { + Tcl_CreateObjCommand(interp, infoClassCmds[i].name, + infoClassCmds[i].proc, NULL, NULL); + } +} + +int +TclInfoObjectCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + Interp *iPtr = (Interp *) interp; + int result; + Tcl_Obj **newobjv = (Tcl_Obj **) ckalloc(sizeof(Tcl_Obj *) * objc-1); + int isRootEnsemble = (iPtr->ensembleRewrite.sourceObjs == NULL); + + if (isRootEnsemble) { + iPtr->ensembleRewrite.sourceObjs = objv; + iPtr->ensembleRewrite.numRemovedObjs = 2; + iPtr->ensembleRewrite.numInsertedObjs = 1; + } else { + int ni = iPtr->ensembleRewrite.numInsertedObjs; + if (ni < 2) { + iPtr->ensembleRewrite.numRemovedObjs += 2 - ni; + } else { + iPtr->ensembleRewrite.numInsertedObjs--; + } + } + + TclNewStringObj(newobjv[0], "::oo::InfoObject", + strlen("::oo::InfoObject")); + Tcl_IncrRefCount(newobjv[0]); + if (objc > 2) { + memcpy(newobjv+1, objv+2, sizeof(Tcl_Obj *) * (objc-2)); + } + result = Tcl_EvalObjv(interp, objc-1, newobjv, TCL_EVAL_INVOKE); + TclDecrRefCount(newobjv[0]); + ckfree((char *) newobjv); + if (isRootEnsemble) { + iPtr->ensembleRewrite.sourceObjs = NULL; + iPtr->ensembleRewrite.numRemovedObjs = 0; + iPtr->ensembleRewrite.numInsertedObjs = 0; + } + return result; +} + +int +TclInfoClassCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + Interp *iPtr = (Interp *) interp; + int result; + Tcl_Obj **newobjv = (Tcl_Obj **) ckalloc(sizeof(Tcl_Obj *) * objc-1); + int isRootEnsemble = (iPtr->ensembleRewrite.sourceObjs == NULL); + + if (isRootEnsemble) { + iPtr->ensembleRewrite.sourceObjs = objv; + iPtr->ensembleRewrite.numRemovedObjs = 2; + iPtr->ensembleRewrite.numInsertedObjs = 1; + } else { + int ni = iPtr->ensembleRewrite.numInsertedObjs; + if (ni < 2) { + iPtr->ensembleRewrite.numRemovedObjs += 2 - ni; + } else { + iPtr->ensembleRewrite.numInsertedObjs--; + } + } + + TclNewStringObj(newobjv[0], "::oo::InfoClass", strlen("::oo::InfoClass")); + Tcl_IncrRefCount(newobjv[0]); + if (objc > 2) { + memcpy(newobjv+1, objv+2, sizeof(Tcl_Obj *) * (objc-2)); + } + result = Tcl_EvalObjv(interp, objc-1, newobjv, TCL_EVAL_INVOKE); + TclDecrRefCount(newobjv[0]); + ckfree((char *) newobjv); + if (isRootEnsemble) { + iPtr->ensembleRewrite.sourceObjs = NULL; + iPtr->ensembleRewrite.numRemovedObjs = 0; + iPtr->ensembleRewrite.numInsertedObjs = 0; + } + return result; +} + +static int +InfoObjectClassCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Object *oPtr; + + if (objc != 2 && objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "objName ?className?"); + return TCL_ERROR; + } + + oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); + if (oPtr == NULL) { + return TCL_ERROR; + } + + if (objc == 2) { + Tcl_GetCommandFullName(interp, oPtr->selfCls->thisPtr->command, + Tcl_GetObjResult(interp)); + return TCL_OK; + } else { + Object *o2Ptr; + Class *mixinPtr; + int i; + + o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]); + if (o2Ptr == NULL) { + return TCL_ERROR; + } + if (o2Ptr->classPtr == NULL) { + Tcl_AppendResult(interp, "object \"", TclGetString(objv[2]), + "\" 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( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Object *oPtr; + Tcl_HashEntry *hPtr; + Proc *procPtr; + CompiledLocal *localPtr; + Tcl_Obj *argsObj; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 3, objv, "objName methodName"); + return TCL_ERROR; + } + + oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); + if (oPtr == NULL) { + return TCL_ERROR; + } + + hPtr = Tcl_FindHashEntry(&oPtr->methods, (char *) objv[2]); + if (hPtr == NULL) { + Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[2]), + "\"", 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( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + int i; + Tcl_Obj *filterObj; + Object *oPtr; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "objName"); + return TCL_ERROR; + } + + oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); + if (oPtr == NULL) { + return TCL_ERROR; + } + + FOREACH(filterObj, oPtr->filters) { + Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), filterObj); + } + return TCL_OK; +} + +static int +InfoObjectForwardCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Object *oPtr; + Tcl_HashEntry *hPtr; + Tcl_Obj *prefixObj; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "objName methodName"); + return TCL_ERROR; + } + + oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); + if (oPtr == NULL) { + return TCL_ERROR; + } + + hPtr = Tcl_FindHashEntry(&oPtr->methods, (char *) objv[2]); + if (hPtr == NULL) { + Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[2]), + "\"", 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( + ClientData clientData, + 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 < 3) { + Tcl_WrongNumArgs(interp, 1, objv, "category objName ?arg ...?"); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[1], 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 != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "objName"); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_NewIntObj(oPtr->classPtr ? 1 : 0)); + return TCL_OK; + case IsMetaclass: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "objName"); + 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 != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "objName className"); + return TCL_ERROR; + } + o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[3]); + 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 != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "objName className"); + return TCL_ERROR; + } + o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[3]); + 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( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Object *oPtr; + int flag = PUBLIC_METHOD; + FOREACH_HASH_DECLS; + Tcl_Obj *namePtr; + Method *mPtr; + + if (objc != 2 && objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "objName ?-private?"); + return TCL_ERROR; + } + oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); + if (oPtr == NULL) { + return TCL_ERROR; + } + if (objc == 3) { + int len; + const char *str = Tcl_GetStringFromObj(objv[2], &len); + + if (len == 13 && !strcmp("-localprivate", str)) { + flag = PRIVATE_METHOD; + } else if (len < 2 || strncmp("-private", str, (unsigned)len)) { + Tcl_AppendResult(interp, "unknown switch \"", str, + "\": must be -private", NULL); + return TCL_ERROR; + } else { + 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( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Class *mixinPtr; + Object *oPtr; + int i; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 3, objv, "objName"); + return TCL_ERROR; + } + oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); + if (oPtr == NULL) { + 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( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Object *oPtr; + const char *pattern = NULL, *name; + FOREACH_HASH_DECLS; + Var *varPtr; + + if (objc != 2 && objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "objName ?pattern?"); + return TCL_ERROR; + } + oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); + if (oPtr == NULL) { + return TCL_ERROR; + } + if (objc == 3) { + pattern = TclGetString(objv[2]); + } + + 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( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Proc *procPtr; + CompiledLocal *localPtr; + Tcl_Obj *argsObj; + Object *oPtr; + Class *clsPtr; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "className"); + return TCL_ERROR; + } + oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); + if (oPtr == NULL) { + return TCL_ERROR; + } + if (oPtr->classPtr == NULL) { + Tcl_AppendResult(interp, "\"", TclGetString(objv[1]), + "\" is not a class", NULL); + return TCL_ERROR; + } + clsPtr = oPtr->classPtr; + + 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( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_HashEntry *hPtr; + Proc *procPtr; + CompiledLocal *localPtr; + Tcl_Obj *argsObj; + Object *oPtr; + Class *clsPtr; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "className methodName"); + return TCL_ERROR; + } + oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); + if (oPtr == NULL) { + return TCL_ERROR; + } + if (oPtr->classPtr == NULL) { + Tcl_AppendResult(interp, "\"", TclGetString(objv[1]), + "\" is not a class", NULL); + return TCL_ERROR; + } + clsPtr = oPtr->classPtr; + + hPtr = Tcl_FindHashEntry(&clsPtr->classMethods, (char *) objv[2]); + if (hPtr == NULL) { + Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[2]), + "\"", 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( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Proc *procPtr; + Object *oPtr; + Class *clsPtr; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "className"); + return TCL_ERROR; + } + oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); + if (oPtr == NULL) { + return TCL_ERROR; + } + if (oPtr->classPtr == NULL) { + Tcl_AppendResult(interp, "\"", TclGetString(objv[1]), + "\" is not a class", NULL); + return TCL_ERROR; + } + clsPtr = oPtr->classPtr; + + 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( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + int i; + Tcl_Obj *filterObj; + Object *oPtr; + Class *clsPtr; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "className"); + return TCL_ERROR; + } + oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); + if (oPtr == NULL) { + return TCL_ERROR; + } + if (oPtr->classPtr == NULL) { + Tcl_AppendResult(interp, "\"", TclGetString(objv[1]), + "\" is not a class", NULL); + return TCL_ERROR; + } + clsPtr = oPtr->classPtr; + + FOREACH(filterObj, clsPtr->filters) { + Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), filterObj); + } + return TCL_OK; +} + +static int +InfoClassForwardCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_HashEntry *hPtr; + Tcl_Obj *prefixObj; + Object *oPtr; + Class *clsPtr; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "className methodName"); + return TCL_ERROR; + } + oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); + if (oPtr == NULL) { + return TCL_ERROR; + } + if (oPtr->classPtr == NULL) { + Tcl_AppendResult(interp, "\"", TclGetString(objv[1]), + "\" is not a class", NULL); + return TCL_ERROR; + } + clsPtr = oPtr->classPtr; + + hPtr = Tcl_FindHashEntry(&clsPtr->classMethods, (char *) objv[2]); + if (hPtr == NULL) { + Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[2]), + "\"", 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( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Object *oPtr; + Class *clsPtr; + int i; + const char *pattern = NULL; + + if (objc != 2 && objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "className ?pattern?"); + return TCL_ERROR; + } + oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); + if (oPtr == NULL) { + return TCL_ERROR; + } + if (oPtr->classPtr == NULL) { + Tcl_AppendResult(interp, "\"", TclGetString(objv[1]), + "\" is not a class", NULL); + return TCL_ERROR; + } + clsPtr = oPtr->classPtr; + if (objc == 3) { + pattern = TclGetString(objv[2]); + } + + 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( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + int flag = PUBLIC_METHOD; + FOREACH_HASH_DECLS; + Tcl_Obj *namePtr; + Method *mPtr; + Object *oPtr; + Class *clsPtr; + + if (objc != 2 && objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "className ?-private?"); + return TCL_ERROR; + } + oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); + if (oPtr == NULL) { + return TCL_ERROR; + } + if (oPtr->classPtr == NULL) { + Tcl_AppendResult(interp, "\"", TclGetString(objv[1]), + "\" is not a class", NULL); + return TCL_ERROR; + } + clsPtr = oPtr->classPtr; + if (objc == 3) { + int len; + const char *str = Tcl_GetStringFromObj(objv[2], &len); + + if (len == 13 && !strcmp("-localprivate", str)) { + flag = PRIVATE_METHOD; + } else if (len < 2 || strncmp("-private", str, (unsigned)len)) { + Tcl_AppendResult(interp, "unknown switch \"", str, + "\": must be -private", NULL); + return TCL_ERROR; + } else { + 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( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Object *oPtr; + Class *clsPtr, *mixinPtr; + int i; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "className"); + return TCL_ERROR; + } + oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); + if (oPtr == NULL) { + return TCL_ERROR; + } + if (oPtr->classPtr == NULL) { + Tcl_AppendResult(interp, "\"", TclGetString(objv[1]), + "\" is not a class", NULL); + return TCL_ERROR; + } + clsPtr = oPtr->classPtr; + + 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; +} + +static int +InfoClassSubsCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Object *oPtr; + Class *clsPtr, *subclassPtr; + int i; + const char *pattern = NULL; + + if (objc != 2 && objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "className ?pattern?"); + return TCL_ERROR; + } + oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); + if (oPtr == NULL) { + return TCL_ERROR; + } + if (oPtr->classPtr == NULL) { + Tcl_AppendResult(interp, "\"", TclGetString(objv[1]), + "\" is not a class", NULL); + return TCL_ERROR; + } + clsPtr = oPtr->classPtr; + if (objc == 3) { + pattern = TclGetString(objv[2]); + } + + 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( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Object *oPtr; + Class *clsPtr, *superPtr; + int i; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "className"); + return TCL_ERROR; + } + oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); + if (oPtr == NULL) { + return TCL_ERROR; + } + if (oPtr->classPtr == NULL) { + Tcl_AppendResult(interp, "\"", TclGetString(objv[1]), + "\" is not a class", NULL); + return TCL_ERROR; + } + clsPtr = oPtr->classPtr; + + 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: + */ Index: generic/tclProc.c ================================================================== --- generic/tclProc.c +++ generic/tclProc.c @@ -1,2115 +1,2256 @@ -/* - * tclProc.c -- - * - * This file contains routines that implement Tcl procedures, including - * the "proc" and "uplevel" commands. - * - * Copyright (c) 1987-1993 The Regents of the University of California. - * Copyright (c) 1994-1998 Sun Microsystems, Inc. - * Copyright (c) 2004-2006 Miguel Sofer - * - * 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.86 2006/02/01 20:17:28 msofer Exp $ - */ - -#include "tclInt.h" -#include "tclCompile.h" - -/* - * Prototypes for static functions in this file - */ - -static int ObjInterpProcEx(ClientData clientData,register Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[], int skip); -static void ProcBodyDup(Tcl_Obj *srcPtr, Tcl_Obj *dupPtr); -static void ProcBodyFree(Tcl_Obj *objPtr); -static int ProcessProcResultCode(Tcl_Interp *interp, - char *procName, int nameLen, int returnCode); -static int TclCompileNoOp(Tcl_Interp *interp, Tcl_Parse *parsePtr, - struct CompileEnv *envPtr); -static void InitCompiledLocals(Tcl_Interp *interp, - ByteCode *codePtr, CompiledLocal *localPtr, - Var *varPtr, Namespace *nsPtr); - -/* - * The ProcBodyObjType type - */ - -Tcl_ObjType tclProcBodyType = { - "procbody", /* name for this type */ - ProcBodyFree, /* FreeInternalRep function */ - ProcBodyDup, /* DupInternalRep function */ - NULL, /* UpdateString function; Tcl_GetString and - * Tcl_GetStringFromObj should panic - * instead. */ - NULL /* SetFromAny function; Tcl_ConvertToType - * should panic instead. */ -}; - -/* - * The [upvar]/[uplevel] level reference type. Uses the twoPtrValue field, - * encoding the type of level reference in ptr1 and the actual parsed out - * offset in ptr2. - * - * Uses the default behaviour throughout, and never disposes of the string - * rep; it's just a cache type. - */ - -static Tcl_ObjType levelReferenceType = { - "levelReference", - NULL, NULL, NULL, NULL -}; - -/* - *---------------------------------------------------------------------- - * - * Tcl_ProcObjCmd -- - * - * This object-based function is invoked to process the "proc" Tcl - * command. See the user documentation for details on what it does. - * - * Results: - * A standard Tcl object result value. - * - * Side effects: - * A new procedure gets created. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -int -Tcl_ProcObjCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *CONST objv[]) /* Argument objects. */ -{ - register Interp *iPtr = (Interp *) interp; - Proc *procPtr; - char *fullName; - CONST char *procName, *procArgs, *procBody; - Namespace *nsPtr, *altNsPtr, *cxtNsPtr; - Tcl_Command cmd; - Tcl_DString ds; - - if (objc != 4) { - Tcl_WrongNumArgs(interp, 1, objv, "name args body"); - return TCL_ERROR; - } - - /* - * Determine the namespace where the procedure should reside. Unless the - * command name includes namespace qualifiers, this will be the current - * namespace. - */ - - fullName = TclGetString(objv[1]); - TclGetNamespaceForQualName(interp, fullName, NULL, 0, - &nsPtr, &altNsPtr, &cxtNsPtr, &procName); - - if (nsPtr == NULL) { - Tcl_AppendResult(interp, "can't create procedure \"", fullName, - "\": unknown namespace", NULL); - return TCL_ERROR; - } - if (procName == NULL) { - Tcl_AppendResult(interp, "can't create procedure \"", fullName, - "\": bad procedure name", NULL); - return TCL_ERROR; - } - if ((nsPtr != iPtr->globalNsPtr) - && (procName != NULL) && (procName[0] == ':')) { - Tcl_AppendResult(interp, "can't create procedure \"", procName, - "\" in non-global namespace with name starting with \":\"", - NULL); - return TCL_ERROR; - } - - /* - * Create the data structure to represent the procedure. - */ - - if (TclCreateProc(interp, nsPtr, procName, objv[2], objv[3], - &procPtr) != TCL_OK) { - Tcl_AddErrorInfo(interp, "\n (creating proc \""); - Tcl_AddErrorInfo(interp, procName); - Tcl_AddErrorInfo(interp, "\")"); - return TCL_ERROR; - } - - /* - * Now create a command for the procedure. This will initially be in the - * current namespace unless the procedure's name included namespace - * qualifiers. To create the new command in the right namespace, we - * generate a fully qualified name for it. - */ - - Tcl_DStringInit(&ds); - if (nsPtr != iPtr->globalNsPtr) { - Tcl_DStringAppend(&ds, nsPtr->fullName, -1); - Tcl_DStringAppend(&ds, "::", 2); - } - Tcl_DStringAppend(&ds, procName, -1); - - cmd = Tcl_CreateObjCommand(interp, Tcl_DStringValue(&ds), - TclObjInterpProc, (ClientData) procPtr, TclProcDeleteProc); - - Tcl_DStringFree(&ds); - - /* - * Now initialize the new procedure's cmdPtr field. This will be used - * later when the procedure is called to determine what namespace the - * procedure will run in. This will be different than the current - * namespace if the proc was renamed into a different namespace. - */ - - procPtr->cmdPtr = (Command *) cmd; - - /* - * Optimize for no-op procs: if the body is not precompiled (like a TclPro - * procbody), and the argument list is just "args" and the body is empty, - * define a compileProc to compile a no-op. - * - * Notes: - * - cannot be done for any argument list without having different - * compiled/not-compiled behaviour in the "wrong argument #" case, or - * making this code much more complicated. In any case, it doesn't - * seem to make a lot of sense to verify the number of arguments we - * are about to ignore ... - * - could be enhanced to handle also non-empty bodies that contain only - * comments; however, parsing the body will slow down the compilation - * of all procs whose argument list is just _args_ - */ - - if (objv[3]->typePtr == &tclProcBodyType) { - goto done; - } - - procArgs = TclGetString(objv[2]); - - while (*procArgs == ' ') { - procArgs++; - } - - if ((procArgs[0] == 'a') && (strncmp(procArgs, "args", 4) == 0)) { - procArgs +=4; - while(*procArgs != '\0') { - if (*procArgs != ' ') { - goto done; - } - procArgs++; - } - - /* - * The argument list is just "args"; check the body - */ - - procBody = TclGetString(objv[3]); - while (*procBody != '\0') { - if (!isspace(UCHAR(*procBody))) { - goto done; - } - procBody++; - } - - /* - * The body is just spaces: link the compileProc - */ - - ((Command *) cmd)->compileProc = TclCompileNoOp; - } - - done: - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCreateProc -- - * - * Creates the data associated with a Tcl procedure definition. This - * function knows how to handle two types of body objects: strings and - * procbody. Strings are the traditional (and common) value for bodies, - * procbody are values created by extensions that have loaded a - * previously compiled script. - * - * Results: - * Returns TCL_OK on success, along with a pointer to a Tcl procedure - * definition in procPtrPtr where the cmdPtr field is not initialised. - * This definition should be freed by calling TclProcCleanupProc() when - * it is no longer needed. Returns TCL_ERROR if anything goes wrong. - * - * Side effects: - * If anything goes wrong, this function returns an error message in the - * interpreter. - * - *---------------------------------------------------------------------- - */ - -int -TclCreateProc( - Tcl_Interp *interp, /* interpreter containing proc */ - Namespace *nsPtr, /* namespace containing 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; - - register Proc *procPtr; - int i, length, result, numArgs; - CONST char *args, *bytes, *p; - register CompiledLocal *localPtr = NULL; - Tcl_Obj *defPtr; - int precompiled = 0; - - if (bodyPtr->typePtr == &tclProcBodyType) { - /* - * Because the body is a TclProProcBody, the actual body is already - * compiled, and it is not shared with anyone else, so it's OK not to - * unshare it (as a matter of fact, it is bad to unshare it, because - * there may be no source code). - * - * We don't create and initialize a Proc structure for the procedure; - * rather, we use what is in the body object. We increment the ref - * count of the Proc struct since the command (soon to be created) - * will be holding a reference to it. - */ - - procPtr = (Proc *) bodyPtr->internalRep.otherValuePtr; - procPtr->iPtr = iPtr; - procPtr->refCount++; - precompiled = 1; - } else { - /* - * If the procedure's body object is shared because its string value - * is identical to, e.g., the body of another procedure, we must - * create a private copy for this procedure to use. Such sharing of - * procedure bodies is rare but can cause problems. A procedure body - * is compiled in a context that includes the number of - * compiler-allocated "slots" for local variables. Each formal - * parameter is given a local variable slot (the - * "procPtr->numCompiledLocals = numArgs" assignment below). This - * means that the same code can not be shared by two procedures that - * have a different number of arguments, even if their bodies are - * identical. Note that we don't use Tcl_DuplicateObj since we would - * not want any bytecode internal representation. - */ - - if (Tcl_IsShared(bodyPtr)) { - bytes = Tcl_GetStringFromObj(bodyPtr, &length); - bodyPtr = Tcl_NewStringObj(bytes, length); - } - - /* - * Create and initialize a Proc structure for the procedure. We - * increment the ref count of the procedure's body object since there - * will be a reference to it in the Proc structure. - */ - - Tcl_IncrRefCount(bodyPtr); - - procPtr = (Proc *) ckalloc(sizeof(Proc)); - procPtr->iPtr = iPtr; - procPtr->refCount = 1; - procPtr->bodyPtr = bodyPtr; - procPtr->numArgs = 0; /* actual argument count is set below. */ - procPtr->numCompiledLocals = 0; - procPtr->firstLocalPtr = NULL; - procPtr->lastLocalPtr = NULL; - } - - /* - * Break up the argument list into argument specifiers, then process each - * argument specifier. If the body is precompiled, processing is limited - * to checking that the parsed argument is consistent with the one stored - * in the Proc. - * - * THIS FAILS IF THE ARG LIST OBJECT'S STRING REP CONTAINS NULS. - */ - - args = Tcl_GetStringFromObj(argsPtr, &length); - result = Tcl_SplitList(interp, args, &numArgs, &argArray); - if (result != TCL_OK) { - goto procError; - } - - if (precompiled) { - if (numArgs > procPtr->numArgs) { - Tcl_Obj *objPtr = Tcl_NewObj(); - TclObjPrintf(NULL, objPtr, - "procedure \"%s\": arg list contains %d entries, " - "precompiled header expects %d", procName, numArgs, - procPtr->numArgs); - Tcl_SetObjResult(interp, objPtr); - goto procError; - } - localPtr = procPtr->firstLocalPtr; - } else { - procPtr->numArgs = numArgs; - procPtr->numCompiledLocals = numArgs; - } - - for (i = 0; i < numArgs; i++) { - int fieldCount, nameLength, valueLength; - CONST char **fieldValues; - - /* - * Now divide the specifier up into name and default. - */ - - result = Tcl_SplitList(interp, argArray[i], &fieldCount, - &fieldValues); - if (result != TCL_OK) { - goto procError; - } - if (fieldCount > 2) { - ckfree((char *) fieldValues); - Tcl_AppendResult(interp, - "too many fields in argument specifier \"", - argArray[i], "\"", NULL); - goto procError; - } - if ((fieldCount == 0) || (*fieldValues[0] == 0)) { - ckfree((char *) fieldValues); - Tcl_AppendResult(interp, "argument with no name", NULL); - goto procError; - } - - nameLength = strlen(fieldValues[0]); - if (fieldCount == 2) { - valueLength = strlen(fieldValues[1]); - } else { - valueLength = 0; - } - - /* - * Check that the formal parameter name is a scalar. - */ - - p = fieldValues[0]; - while (*p != '\0') { - if (*p == '(') { - CONST char *q = p; - do { - q++; - } while (*q != '\0'); - q--; - if (*q == ')') { /* we have an array element */ - Tcl_AppendResult(interp, "formal parameter \"", - fieldValues[0], - "\" is an array element", NULL); - ckfree((char *) fieldValues); - goto procError; - } - } else if ((*p == ':') && (*(p+1) == ':')) { - Tcl_AppendResult(interp, "formal parameter \"", - fieldValues[0], - "\" is not a simple name", NULL); - ckfree((char *) fieldValues); - goto procError; - } - p++; - } - - if (precompiled) { - /* - * Compare the parsed argument with the stored one. For the flags, - * we and out VAR_UNDEFINED to support bridging precompiled <= 8.3 - * code in 8.4 where this is now used as an optimization - * indicator. Yes, this is a hack. -- hobbs - */ - - if ((localPtr->nameLength != nameLength) - || (strcmp(localPtr->name, fieldValues[0])) - || (localPtr->frameIndex != i) - || ((localPtr->flags & ~VAR_UNDEFINED) - != (VAR_SCALAR | VAR_ARGUMENT)) - || (localPtr->defValuePtr == NULL && fieldCount == 2) - || (localPtr->defValuePtr != NULL && fieldCount != 2)) { - Tcl_Obj *objPtr = Tcl_NewObj(); - TclObjPrintf(NULL, objPtr, - "procedure \"%s\": formal parameter %d is " - "inconsistent with precompiled body", procName, i); - Tcl_SetObjResult(interp, objPtr); - ckfree((char *) fieldValues); - goto procError; - } - - /* - * compare the default value if any - */ - - if (localPtr->defValuePtr != NULL) { - int tmpLength; - char *tmpPtr = Tcl_GetStringFromObj(localPtr->defValuePtr, - &tmpLength); - if ((valueLength != tmpLength) || - strncmp(fieldValues[1], tmpPtr, (size_t) tmpLength)) { - Tcl_Obj *objPtr = Tcl_NewObj(); - - TclObjPrintf(NULL, objPtr, - "procedure \"%s\": formal parameter \"%s\" has " - "default value inconsistent with precompiled body", - procName, fieldValues[0]); - Tcl_SetObjResult(interp, objPtr); - ckfree((char *) fieldValues); - goto procError; - } - } - if ((i == numArgs - 1) - && (localPtr->nameLength == 4) - && (localPtr->name[0] == 'a') - && (strcmp(localPtr->name, "args") == 0)) { - localPtr->flags |= VAR_IS_ARGS; - } - - localPtr = localPtr->nextPtr; - } else { - /* - * Allocate an entry in the runtime procedure frame's array of - * local variables for the argument. - */ - - localPtr = (CompiledLocal *) ckalloc((unsigned) - (sizeof(CompiledLocal) - sizeof(localPtr->name) - + nameLength + 1)); - if (procPtr->firstLocalPtr == NULL) { - procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr; - } else { - procPtr->lastLocalPtr->nextPtr = localPtr; - procPtr->lastLocalPtr = localPtr; - } - localPtr->nextPtr = NULL; - localPtr->nameLength = nameLength; - localPtr->frameIndex = i; - localPtr->flags = VAR_SCALAR | VAR_ARGUMENT; - localPtr->resolveInfo = NULL; - - if (fieldCount == 2) { - localPtr->defValuePtr = - Tcl_NewStringObj(fieldValues[1], valueLength); - Tcl_IncrRefCount(localPtr->defValuePtr); - } else { - localPtr->defValuePtr = NULL; - } - strcpy(localPtr->name, fieldValues[0]); - if ((i == numArgs - 1) - && (localPtr->nameLength == 4) - && (localPtr->name[0] == 'a') - && (strcmp(localPtr->name, "args") == 0)) { - localPtr->flags |= VAR_IS_ARGS; - } - } - - ckfree((char *) fieldValues); - } - - *procPtrPtr = procPtr; - ckfree((char *) argArray); - return TCL_OK; - - procError: - if (precompiled) { - procPtr->refCount--; - } else { - Tcl_DecrRefCount(bodyPtr); - while (procPtr->firstLocalPtr != NULL) { - localPtr = procPtr->firstLocalPtr; - procPtr->firstLocalPtr = localPtr->nextPtr; - - defPtr = localPtr->defValuePtr; - if (defPtr != NULL) { - Tcl_DecrRefCount(defPtr); - } - - ckfree((char *) localPtr); - } - ckfree((char *) procPtr); - } - if (argArray != NULL) { - ckfree((char *) argArray); - } - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * TclGetFrame -- - * - * Given a description of a procedure frame, such as the first argument - * to an "uplevel" or "upvar" command, locate the call frame for the - * appropriate level of procedure. - * - * Results: - * The return value is -1 if an error occurred in finding the frame (in - * this case an error message is left in the interp's result). 1 is - * returned if string was either a number or a number preceded by "#" and - * it specified a valid frame. 0 is returned if string isn't one of the - * two things above (in this case, the lookup acts as if string were - * "1"). The variable pointed to by framePtrPtr is filled in with the - * address of the desired frame (unless an error occurs, in which case it - * isn't modified). - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -TclGetFrame( - Tcl_Interp *interp, /* Interpreter in which to find frame. */ - CONST char *name, /* String describing frame. */ - CallFrame **framePtrPtr) /* Store pointer to frame here (or NULL if - * global frame indicated). */ -{ - register Interp *iPtr = (Interp *) interp; - int curLevel, level, result; - CallFrame *framePtr; - - /* - * Parse string to figure out which level number to go to. - */ - - result = 1; - curLevel = (iPtr->varFramePtr == NULL) ? 0 : iPtr->varFramePtr->level; - if (*name== '#') { - if (Tcl_GetInt(interp, name+1, &level) != TCL_OK || level < 0) { - goto levelError; - } - } else if (isdigit(UCHAR(*name))) { /* INTL: digit */ - if (Tcl_GetInt(interp, name, &level) != TCL_OK) { - goto levelError; - } - level = curLevel - level; - } else { - level = curLevel - 1; - result = 0; - } - - /* - * Figure out which frame to use, and return it to the caller. - */ - - if (level == 0) { - framePtr = NULL; - } else { - for (framePtr = iPtr->varFramePtr; framePtr != NULL; - framePtr = framePtr->callerVarPtr) { - if (framePtr->level == level) { - break; - } - } - if (framePtr == NULL) { - goto levelError; - } - } - *framePtrPtr = framePtr; - return result; - - levelError: - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "bad level \"", name, "\"", NULL); - return -1; -} - -/* - *---------------------------------------------------------------------- - * - * TclObjGetFrame -- - * - * Given a description of a procedure frame, such as the first argument - * to an "uplevel" or "upvar" command, locate the call frame for the - * appropriate level of procedure. - * - * Results: - * The return value is -1 if an error occurred in finding the frame (in - * this case an error message is left in the interp's result). 1 is - * returned if objPtr was either a number or a number preceded by "#" and - * it specified a valid frame. 0 is returned if objPtr isn't one of the - * two things above (in this case, the lookup acts as if objPtr were - * "1"). The variable pointed to by framePtrPtr is filled in with the - * address of the desired frame (unless an error occurs, in which case it - * isn't modified). - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -TclObjGetFrame( - Tcl_Interp *interp, /* Interpreter in which to find frame. */ - Tcl_Obj *objPtr, /* Object describing frame. */ - CallFrame **framePtrPtr) /* Store pointer to frame here (or NULL if - * global frame indicated). */ -{ - register Interp *iPtr = (Interp *) interp; - int curLevel, level, result; - CallFrame *framePtr; - CONST char *name = TclGetString(objPtr); - - /* - * Parse object to figure out which level number to go to. - */ - - result = 1; - curLevel = (iPtr->varFramePtr == NULL) ? 0 : iPtr->varFramePtr->level; - if (objPtr->typePtr == &levelReferenceType) { - if ((int) objPtr->internalRep.twoPtrValue.ptr1) { - level = curLevel - (int) objPtr->internalRep.twoPtrValue.ptr2; - } else { - level = (int) objPtr->internalRep.twoPtrValue.ptr2; - } - if (level < 0) { - goto levelError; - } - /* TODO: Consider skipping the typePtr checks */ - } else if (objPtr->typePtr == &tclIntType -#ifndef NO_WIDE_TYPE - || objPtr->typePtr == &tclWideIntType -#endif - ) { - if (Tcl_GetIntFromObj(NULL, objPtr, &level) != TCL_OK || level < 0) { - goto levelError; - } - level = curLevel - level; - } else { - if (*name == '#') { - if (Tcl_GetInt(interp, name+1, &level) != TCL_OK || level < 0) { - goto levelError; - } - - /* - * Cache for future reference. - * - * TODO: Use the new ptrAndLongRep intrep - */ - - TclFreeIntRep(objPtr); - objPtr->typePtr = &levelReferenceType; - objPtr->internalRep.twoPtrValue.ptr1 = (void *) 0; - objPtr->internalRep.twoPtrValue.ptr2 = (void *) level; - } else if (isdigit(UCHAR(*name))) { /* INTL: digit */ - if (Tcl_GetInt(interp, name, &level) != TCL_OK) { - return -1; - } - - /* - * Cache for future reference. - * - * TODO: Use the new ptrAndLongRep intrep - */ - - TclFreeIntRep(objPtr); - objPtr->typePtr = &levelReferenceType; - objPtr->internalRep.twoPtrValue.ptr1 = (void *) 1; - objPtr->internalRep.twoPtrValue.ptr2 = (void *) level; - level = curLevel - level; - } else { - /* - * Don't cache as the object *isn't* a level reference. - */ - - level = curLevel - 1; - result = 0; - } - } - - /* - * Figure out which frame to use, and return it to the caller. - */ - - if (level == 0) { - framePtr = NULL; - } else { - for (framePtr = iPtr->varFramePtr; framePtr != NULL; - framePtr = framePtr->callerVarPtr) { - if (framePtr->level == level) { - break; - } - } - if (framePtr == NULL) { - goto levelError; - } - } - *framePtrPtr = framePtr; - return result; - - levelError: - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "bad level \"", name, "\"", NULL); - return -1; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_UplevelObjCmd -- - * - * This object function is invoked to process the "uplevel" Tcl command. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl object result value. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -int -Tcl_UplevelObjCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *CONST objv[]) /* Argument objects. */ -{ - register Interp *iPtr = (Interp *) interp; - int result; - CallFrame *savedVarFramePtr, *framePtr; - - if (objc < 2) { - uplevelSyntax: - Tcl_WrongNumArgs(interp, 1, objv, "?level? command ?arg ...?"); - return TCL_ERROR; - } - - /* - * Find the level to use for executing the command. - */ - - result = TclObjGetFrame(interp, objv[1], &framePtr); - if (result == -1) { - return TCL_ERROR; - } - objc -= (result+1); - if (objc == 0) { - goto uplevelSyntax; - } - objv += (result+1); - - /* - * Modify the interpreter state to execute in the given frame. - */ - - savedVarFramePtr = iPtr->varFramePtr; - iPtr->varFramePtr = framePtr; - - /* - * Execute the residual arguments as a command. - */ - - if (objc == 1) { - result = Tcl_EvalObjEx(interp, objv[0], TCL_EVAL_DIRECT); - } else { - /* - * 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. - */ - - Tcl_Obj *objPtr; - - objPtr = Tcl_ConcatObj(objc, objv); - result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT); - } - if (result == TCL_ERROR) { - TclFormatToErrorInfo(interp, "\n (\"uplevel\" body line %d)", - interp->errorLine); - } - - /* - * Restore the variable frame, and return. - */ - - iPtr->varFramePtr = savedVarFramePtr; - return result; -} - -/* - *---------------------------------------------------------------------- - * - * TclFindProc -- - * - * Given the name of a procedure, return a pointer to the record - * describing the procedure. The procedure will be looked up using the - * usual rules: first in the current namespace and then in the global - * namespace. - * - * Results: - * NULL is returned if the name doesn't correspond to any procedure. - * Otherwise, the return value is a pointer to the procedure's record. If - * the name is found but refers to an imported command that points to a - * "real" procedure defined in another namespace, a pointer to that - * "real" procedure's structure is returned. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -Proc * -TclFindProc( - Interp *iPtr, /* Interpreter in which to look. */ - CONST char *procName) /* Name of desired procedure. */ -{ - Tcl_Command cmd; - Tcl_Command origCmd; - Command *cmdPtr; - - cmd = Tcl_FindCommand((Tcl_Interp *) iPtr, procName, NULL, /*flags*/ 0); - if (cmd == (Tcl_Command) NULL) { - return NULL; - } - cmdPtr = (Command *) cmd; - - origCmd = TclGetOriginalCommand(cmd); - if (origCmd != NULL) { - cmdPtr = (Command *) origCmd; - } - if (cmdPtr->objProc != TclObjInterpProc) { - return NULL; - } - return (Proc *) cmdPtr->objClientData; -} - -/* - *---------------------------------------------------------------------- - * - * TclIsProc -- - * - * Tells whether a command is a Tcl procedure or not. - * - * Results: - * If the given command is actually a Tcl procedure, the return value is - * the address of the record describing the procedure. Otherwise the - * return value is 0. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -Proc * -TclIsProc( - Command *cmdPtr) /* Command to test. */ -{ - Tcl_Command origCmd; - - origCmd = TclGetOriginalCommand((Tcl_Command) cmdPtr); - if (origCmd != NULL) { - cmdPtr = (Command *) origCmd; - } - if (cmdPtr->objProc == TclObjInterpProc) { - return (Proc *) cmdPtr->objClientData; - } - return (Proc *) 0; -} - -/* - *---------------------------------------------------------------------- - * - * InitCompiledLocals -- - * - * This routine is invoked in order to initialize the compiled locals - * table for a new call frame. - * - * Results: - * None. - * - * Side effects: - * May invoke various name resolvers in order to determine which - * variables are being referenced at runtime. - * - *---------------------------------------------------------------------- - */ - -static void -InitCompiledLocals( - Tcl_Interp *interp, /* Current interpreter. */ - ByteCode *codePtr, - CompiledLocal *localPtr, - Var *varPtr, - Namespace *nsPtr) /* Pointer to current namespace. */ -{ - Interp *iPtr = (Interp*) interp; - int haveResolvers = (nsPtr->compiledVarResProc || iPtr->resolverPtr); - CompiledLocal *firstLocalPtr; - - if (codePtr->flags & TCL_BYTECODE_RESOLVE_VARS) { - /* - * This is the first run after a recompile, or else the resolver epoch - * has changed: update the resolver cache. - */ - - firstLocalPtr = localPtr; - for (; localPtr != NULL; localPtr = localPtr->nextPtr) { - - if (localPtr->resolveInfo) { - if (localPtr->resolveInfo->deleteProc) { - localPtr->resolveInfo->deleteProc(localPtr->resolveInfo); - } else { - ckfree((char*)localPtr->resolveInfo); - } - localPtr->resolveInfo = NULL; - } - localPtr->flags &= ~VAR_RESOLVED; - - if (haveResolvers && - !(localPtr->flags & (VAR_ARGUMENT|VAR_TEMPORARY))) { - ResolverScheme *resPtr = iPtr->resolverPtr; - Tcl_ResolvedVarInfo *vinfo; - int result; - - if (nsPtr->compiledVarResProc) { - result = (*nsPtr->compiledVarResProc)(nsPtr->interp, - localPtr->name, localPtr->nameLength, - (Tcl_Namespace *) nsPtr, &vinfo); - } else { - result = TCL_CONTINUE; - } - - while ((result == TCL_CONTINUE) && resPtr) { - if (resPtr->compiledVarResProc) { - result = (*resPtr->compiledVarResProc)(nsPtr->interp, - localPtr->name, localPtr->nameLength, - (Tcl_Namespace *) nsPtr, &vinfo); - } - resPtr = resPtr->nextPtr; - } - if (result == TCL_OK) { - localPtr->resolveInfo = vinfo; - localPtr->flags |= VAR_RESOLVED; - } - } - } - localPtr = firstLocalPtr; - codePtr->flags &= ~TCL_BYTECODE_RESOLVE_VARS; - } - - /* - * Initialize the array of local variables stored in the call frame. Some - * variables may have special resolution rules. In that case, we call - * their "resolver" procs to get our hands on the variable, and we make - * the compiled local a link to the real variable. - */ - - if (haveResolvers) { - Tcl_ResolvedVarInfo *resVarInfo; - for (; localPtr != NULL; varPtr++, localPtr = localPtr->nextPtr) { - varPtr->value.objPtr = NULL; - varPtr->name = localPtr->name; /* will be just '\0' if temp var */ - varPtr->nsPtr = NULL; - varPtr->hPtr = NULL; - varPtr->refCount = 0; - varPtr->tracePtr = NULL; - varPtr->searchPtr = NULL; - varPtr->flags = localPtr->flags; - - /* - * Now invoke the resolvers to determine the exact variables that - * should be used. - */ - - resVarInfo = localPtr->resolveInfo; - if (resVarInfo && resVarInfo->fetchProc) { - Var *resolvedVarPtr = (Var*) (*resVarInfo->fetchProc)(interp, - resVarInfo); - if (resolvedVarPtr) { - resolvedVarPtr->refCount++; - varPtr->value.linkPtr = resolvedVarPtr; - varPtr->flags = VAR_LINK; - } - } - } - } else { - for (; localPtr != NULL; varPtr++, localPtr = localPtr->nextPtr) { - varPtr->value.objPtr = NULL; - varPtr->name = localPtr->name; /* will be just '\0' if temp var */ - varPtr->nsPtr = NULL; - varPtr->hPtr = NULL; - varPtr->refCount = 0; - varPtr->tracePtr = NULL; - varPtr->searchPtr = NULL; - varPtr->flags = localPtr->flags; - } - } -} - -/* - *---------------------------------------------------------------------- - * - * TclInitCompiledLocals -- - * - * This routine is invoked in order to initialize the compiled locals - * table for a new call frame. - * - * DEPRECATED: functionality has been inlined elsewhere; this function - * remains to insure binary compatibility with Itcl. - * - * Results: - * None. - * - * Side effects: - * May invoke various name resolvers in order to determine which - * variables are being referenced at runtime. - * - *---------------------------------------------------------------------- - */ - -void -TclInitCompiledLocals( - Tcl_Interp *interp, /* Current interpreter. */ - CallFrame *framePtr, /* Call frame to initialize. */ - Namespace *nsPtr) /* Pointer to current namespace. */ -{ - Var *varPtr = framePtr->compiledLocals; - Tcl_Obj *bodyPtr; - ByteCode *codePtr; - CompiledLocal *localPtr = framePtr->procPtr->firstLocalPtr; - - bodyPtr = framePtr->procPtr->bodyPtr; - if (bodyPtr->typePtr != &tclByteCodeType) { - Tcl_Panic("body object for proc attached to frame is not a byte code type"); - } - codePtr = (ByteCode *) bodyPtr->internalRep.otherValuePtr; - - InitCompiledLocals(interp, codePtr, localPtr, varPtr, nsPtr); -} - -/* - *---------------------------------------------------------------------- - * - * TclObjInterpProc -- - * - * When a Tcl procedure gets invoked during bytecode evaluation, this - * object-based routine gets invoked to interpret the procedure. - * - * Results: - * A standard Tcl object result value. - * - * Side effects: - * Depends on the commands in the procedure. - * - *---------------------------------------------------------------------- - */ - -int -TclObjInterpProc( - ClientData clientData, /* Record describing procedure to be - * interpreted. */ - register Tcl_Interp *interp,/* Interpreter in which procedure was - * invoked. */ - int objc, /* Count of number of arguments to this - * procedure. */ - Tcl_Obj *CONST objv[]) /* Argument value objects. */ -{ - - return ObjInterpProcEx(clientData, interp, objc, objv, /*skip*/ 1); -} - -static int -ObjInterpProcEx( - ClientData clientData, /* Record describing procedure to be - * interpreted. */ - register Tcl_Interp *interp,/* Interpreter in which procedure was - * invoked. */ - int objc, /* Count of number of arguments to this - * procedure. */ - Tcl_Obj *CONST objv[], /* Argument value objects. */ - int skip) /* Number of initial arguments to be skipped, - * ie, words in the "command name" */ -{ - register Proc *procPtr = (Proc *) clientData; - Namespace *nsPtr = procPtr->cmdPtr->nsPtr; - CallFrame *framePtr, **framePtrPtr; - 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 - * frame slots for the procedure's non-argument local variables. Note that - * compiling the body might increase procPtr->numCompiledLocals if new - * local variables are found while compiling. - */ - - result = TclProcCompileProc(interp, procPtr, procPtr->bodyPtr, nsPtr, - "body of proc", procName); - - 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 - * different than the current namespace. The proc's namespace is that of - * its command, which can change if the command is renamed from one - * namespace to another. - */ - - framePtrPtr = &framePtr; - result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, - (Tcl_Namespace *) nsPtr, FRAME_IS_PROC); - - if (result != TCL_OK) { - return result; - } - - - framePtr->objc = objc; - framePtr->objv = objv; /* ref counts for args are incremented below */ - framePtr->procPtr = procPtr; - - /* - * Create the "compiledLocals" array. Make sure it is large enough to hold - * all the procedure's compiled local variables, including its formal - * parameters. - */ - - localCt = procPtr->numCompiledLocals; - compiledLocals = (Var *) TclStackAlloc(interp, (int)(localCt*sizeof(Var))); - framePtr->numCompiledLocals = localCt; - framePtr->compiledLocals = compiledLocals; - - /* - * Match and assign the call's actual parameters to the procedure's formal - * arguments. The formal arguments are described by the first numArgs - * entries in both the Proc structure's local variable list and the call - * frame's local variable array. - */ - - numArgs = procPtr->numArgs; - 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) { - if (argCt) { - goto incorrectArgs; - } else { - goto runProc; - } - } - imax = ((argCt < numArgs - 1)? argCt : (numArgs - 1)); - for (i = 0; i < imax; i++) { - /* - * "Normal" arguments; last formal is special, depends on it being - * 'args'. - */ - - Tcl_Obj *objPtr = argObjs[i]; - - varPtr->value.objPtr = objPtr; - Tcl_IncrRefCount(objPtr); /* local var is a reference */ - varPtr->name = localPtr->name; - varPtr->nsPtr = NULL; - varPtr->hPtr = NULL; - varPtr->refCount = 0; - varPtr->tracePtr = NULL; - varPtr->searchPtr = NULL; - varPtr->flags = localPtr->flags; - varPtr++; - localPtr = localPtr->nextPtr; - } - for (; i < (numArgs - 1); i++) { - /* - * This loop is entered if argCt < (numArgs-1). Set default values; - * last formal is special. - */ - - if (localPtr->defValuePtr != NULL) { - Tcl_Obj *objPtr = localPtr->defValuePtr; - - varPtr->value.objPtr = objPtr; - Tcl_IncrRefCount(objPtr); /* local var is a reference */ - varPtr->name = localPtr->name; - varPtr->nsPtr = NULL; - varPtr->hPtr = NULL; - varPtr->refCount = 0; - varPtr->tracePtr = NULL; - varPtr->searchPtr = NULL; - varPtr->flags = localPtr->flags; - varPtr++; - localPtr = localPtr->nextPtr; - } else { - goto incorrectArgs; - } - } - - /* - * When we get here, the last formal argument remains to be defined: - * localPtr and varPtr point to the last argument to be initialized. - */ - - if (localPtr->flags & VAR_IS_ARGS) { - Tcl_Obj *listPtr = Tcl_NewListObj(argCt-i, &(argObjs[i])); - varPtr->value.objPtr = listPtr; - Tcl_IncrRefCount(listPtr); /* local var is a reference */ - } else if (argCt == numArgs) { - Tcl_Obj *objPtr = argObjs[i]; - varPtr->value.objPtr = objPtr; - Tcl_IncrRefCount(objPtr); /* local var is a reference */ - } else if ((argCt < numArgs) && (localPtr->defValuePtr != NULL)) { - Tcl_Obj *objPtr = localPtr->defValuePtr; - varPtr->value.objPtr = objPtr; - Tcl_IncrRefCount(objPtr); /* local var is a reference */ - } else { - Tcl_Obj **desiredObjs, *argObj; - ByteCode *codePtr; - - /* - * Do initialise all compiled locals, to avoid problems at - * DeleteLocalVars. - */ - - incorrectArgs: - codePtr = (ByteCode *) procPtr->bodyPtr->internalRep.otherValuePtr; - InitCompiledLocals(interp, codePtr, localPtr, varPtr, nsPtr); - - /* - * Build up desired argument list for Tcl_WrongNumArgs - */ - - desiredObjs = (Tcl_Obj **) - ckalloc(sizeof(Tcl_Obj *) * (unsigned)(numArgs+1)); - -#ifdef AVOID_HACKS_FOR_ITCL - desiredObjs[0] = objv[0]; -#else - desiredObjs[0] = Tcl_NewListObj(skip, objv); -#endif /* AVOID_HACKS_FOR_ITCL */ - - localPtr = procPtr->firstLocalPtr; - for (i=1 ; i<=numArgs ; i++) { - TclNewObj(argObj); - if (localPtr->defValuePtr != NULL) { - Tcl_AppendStringsToObj(argObj, "?", localPtr->name, "?", NULL); - } else if ((i==numArgs) && !strcmp(localPtr->name, "args")) { - Tcl_AppendStringsToObj(argObj, "...", NULL); - } else { - Tcl_AppendStringsToObj(argObj, localPtr->name, NULL); - } - desiredObjs[i] = argObj; - localPtr = localPtr->nextPtr; - } - - Tcl_ResetResult(interp); - Tcl_WrongNumArgs(interp, numArgs+1, desiredObjs, NULL); - result = TCL_ERROR; - -#ifdef AVOID_HACKS_FOR_ITCL - for (i=1 ; i<=numArgs ; i++) { - TclDecrRefCount(desiredObjs[i]); - } -#else - for (i=0 ; i<=numArgs ; i++) { - TclDecrRefCount(desiredObjs[i]); - } -#endif /* AVOID_HACKS_FOR_ITCL */ - ckfree((char *) desiredObjs); - goto procDone; - } - - varPtr->name = localPtr->name; - varPtr->nsPtr = NULL; - varPtr->hPtr = NULL; - varPtr->refCount = 0; - varPtr->tracePtr = NULL; - varPtr->searchPtr = NULL; - varPtr->flags = localPtr->flags; - - localPtr = localPtr->nextPtr; - varPtr++; - - /* - * Initialise and resolve the remaining compiledLocals. - */ - - runProc: - if (localPtr) { - ByteCode *codePtr = (ByteCode *) - procPtr->bodyPtr->internalRep.otherValuePtr; - - InitCompiledLocals(interp, codePtr, localPtr, varPtr, nsPtr); - } - - /* - * Invoke the commands in the procedure's body. - */ - -#ifdef TCL_COMPILE_DEBUG - if (tclTraceExec >= 1) { - fprintf(stdout, "Calling proc "); - for (i = 0; i < objc; i++) { - TclPrintObject(stdout, objv[i], 15); - fprintf(stdout, " "); - } - fprintf(stdout, "\n"); - fflush(stdout); - } -#endif /*TCL_COMPILE_DEBUG*/ - - procPtr->refCount++; - result = TclCompEvalObj(interp, procPtr->bodyPtr); - procPtr->refCount--; - if (procPtr->refCount <= 0) { - TclProcCleanupProc(procPtr); - } - - if (result != TCL_OK) { - result = ProcessProcResultCode(interp, procName, nameLen, result); - } - - /* - * Pop and free the call frame for this procedure invocation, then free - * the compiledLocals array if malloc'ed storage was used. - */ - - procDone: - /* - * Free the stack-allocated compiled locals and CallFrame. It is important - * to pop the call frame without freeing it first: the compiledLocals - * cannot be freed before the frame is popped, as the local variables must - * be deleted. But the compiledLocals must be freed first, as they were - * allocated later on the stack. - */ - - Tcl_PopCallFrame(interp); /* pop but do not free */ - TclStackFree(interp); /* free compiledLocals */ - TclStackFree(interp); /* free CallFrame */ - return result; -#undef NUM_LOCALS -} - -/* - *---------------------------------------------------------------------- - * - * TclProcCompileProc -- - * - * Called just before a procedure is executed to compile the body to byte - * codes. If the type of the body is not "byte code" or if the compile - * conditions have changed (namespace context, epoch counters, etc.) then - * the body is recompiled. Otherwise, this function does nothing. - * - * Results: - * None. - * - * Side effects: - * May change the internal representation of the body object to compiled - * code. - * - *---------------------------------------------------------------------- - */ - -int -TclProcCompileProc( - Tcl_Interp *interp, /* Interpreter containing procedure. */ - Proc *procPtr, /* Data associated with procedure. */ - Tcl_Obj *bodyPtr, /* Body of proc. (Usually procPtr->bodyPtr, - * 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. */ -{ - Interp *iPtr = (Interp*)interp; - int result; - Tcl_CallFrame *framePtr; - Proc *saveProcPtr; - ByteCode *codePtr = (ByteCode *) bodyPtr->internalRep.otherValuePtr; - - /* - * If necessary, compile the procedure's body. The compiler will allocate - * frame slots for the procedure's non-argument local variables. If the - * ByteCode already exists, make sure it hasn't been invalidated by - * someone redefining a core command (this might make the compiled code - * wrong). Also, if the code was compiled in/for a different interpreter, - * we recompile it. Note that compiling the body might increase - * procPtr->numCompiledLocals if new local variables are found while - * compiling. - * - * Precompiled procedure bodies, however, are immutable and therefore they - * are not recompiled, even if things have changed. - */ - - if (bodyPtr->typePtr == &tclByteCodeType) { - if (((Interp *) *codePtr->interpHandle != iPtr) - || (codePtr->compileEpoch != iPtr->compileEpoch) - || (codePtr->nsPtr != nsPtr)) { - if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) { - if ((Interp *) *codePtr->interpHandle != iPtr) { - Tcl_AppendResult(interp, - "a precompiled script jumped interps", NULL); - return TCL_ERROR; - } - codePtr->compileEpoch = iPtr->compileEpoch; - codePtr->nsPtr = nsPtr; - } else { - bodyPtr->typePtr->freeIntRepProc(bodyPtr); - bodyPtr->typePtr = NULL; - } - } - } - if (bodyPtr->typePtr != &tclByteCodeType) { -#ifdef TCL_COMPILE_DEBUG - if (tclTraceCompile >= 1) { - /* - * Display a line summarizing the top level command we are about - * to compile. - */ - - Tcl_Obj *message = Tcl_NewStringObj("Compiling ", -1); - - Tcl_IncrRefCount(message); - Tcl_AppendStringsToObj(message, description, " \"", NULL); - TclAppendLimitedToObj(message, procName, -1, 50, NULL); - fprintf(stdout, "%s\"\n", TclGetString(message)); - Tcl_DecrRefCount(message); - } -#endif - - /* - * Plug the current procPtr into the interpreter and coerce the code - * body to byte codes. The interpreter needs to know which proc it's - * compiling so that it can access its list of compiled locals. - * - * TRICKY NOTE: Be careful to push a call frame with the proper - * namespace context, so that the byte codes are compiled in the - * appropriate class context. - */ - - saveProcPtr = iPtr->compiledProcPtr; - iPtr->compiledProcPtr = procPtr; - - result = TclPushStackFrame(interp, &framePtr, - (Tcl_Namespace *) nsPtr, /* isProcCallFrame */ 0); - - if (result == TCL_OK) { - result = tclByteCodeType.setFromAnyProc(interp, bodyPtr); - TclPopStackFrame(interp); - } - - iPtr->compiledProcPtr = saveProcPtr; - - if (result != TCL_OK) { - if (result == TCL_ERROR) { - int length = strlen(procName); - int limit = 50; - int overflow = (length > limit); - - TclFormatToErrorInfo(interp, - "\n (compiling %s \"%.*s%s\", line %d)", - description, (overflow ? limit : length), procName, - (overflow ? "..." : ""), interp->errorLine); - } - return result; - } - } else if (codePtr->nsEpoch != nsPtr->resolverEpoch) { - /* - * The resolver epoch has changed, but we only need to invalidate the - * resolver cache. - */ - - codePtr->flags |= TCL_BYTECODE_RESOLVE_VARS; - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * ProcessProcResultCode -- - * - * Function called by TclObjInterpProc to process a return code other - * than TCL_OK returned by a Tcl procedure. - * - * Results: - * Depending on the argument return code, the result returned is another - * return code and the interpreter's result is set to a value to - * supplement that return code. - * - * Side effects: - * If the result returned is TCL_ERROR, traceback information about the - * procedure just executed is appended to the interpreter's errorInfo - * field. - * - *---------------------------------------------------------------------- - */ - -static int -ProcessProcResultCode( - Tcl_Interp *interp, /* The interpreter in which the procedure was - * called and returned returnCode. */ - char *procName, /* Name of the procedure. Used for error - * messages and trace information. */ - int nameLen, /* Number of bytes in procedure's name. */ - int returnCode) /* The unexpected result code. */ -{ - Interp *iPtr = (Interp *) interp; - int overflow, limit = 60; - - if (returnCode == TCL_OK) { - return TCL_OK; - } - if ((returnCode > TCL_CONTINUE) || (returnCode < TCL_OK)) { - return returnCode; - } - if (returnCode == TCL_RETURN) { - return TclUpdateReturnInfo(iPtr); - } - if (returnCode != TCL_ERROR) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "invoked \"", - ((returnCode == TCL_BREAK) ? "break" : "continue"), - "\" outside of a loop", NULL); - } - overflow = (nameLen > limit); - TclFormatToErrorInfo(interp, "\n (procedure \"%.*s%s\" line %d)", - (overflow ? limit : nameLen), procName, - (overflow ? "..." : ""), interp->errorLine); - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * TclProcDeleteProc -- - * - * This function is invoked just before a command procedure is removed - * from an interpreter. Its job is to release all the resources allocated - * to the procedure. - * - * Results: - * None. - * - * Side effects: - * Memory gets freed, unless the procedure is actively being executed. - * In this case the cleanup is delayed until the last call to the current - * procedure completes. - * - *---------------------------------------------------------------------- - */ - -void -TclProcDeleteProc( - ClientData clientData) /* Procedure to be deleted. */ -{ - Proc *procPtr = (Proc *) clientData; - - procPtr->refCount--; - if (procPtr->refCount <= 0) { - TclProcCleanupProc(procPtr); - } -} - -/* - *---------------------------------------------------------------------- - * - * TclProcCleanupProc -- - * - * This function does all the real work of freeing up a Proc structure. - * It's called only when the structure's reference count becomes zero. - * - * Results: - * None. - * - * Side effects: - * Memory gets freed. - * - *---------------------------------------------------------------------- - */ - -void -TclProcCleanupProc( - register Proc *procPtr) /* Procedure to be deleted. */ -{ - register CompiledLocal *localPtr; - Tcl_Obj *bodyPtr = procPtr->bodyPtr; - Tcl_Obj *defPtr; - Tcl_ResolvedVarInfo *resVarInfo; - - if (bodyPtr != NULL) { - Tcl_DecrRefCount(bodyPtr); - } - for (localPtr = procPtr->firstLocalPtr; localPtr != NULL; ) { - CompiledLocal *nextPtr = localPtr->nextPtr; - - resVarInfo = localPtr->resolveInfo; - if (resVarInfo) { - if (resVarInfo->deleteProc) { - (*resVarInfo->deleteProc)(resVarInfo); - } else { - ckfree((char *) resVarInfo); - } - } - - if (localPtr->defValuePtr != NULL) { - defPtr = localPtr->defValuePtr; - Tcl_DecrRefCount(defPtr); - } - ckfree((char *) localPtr); - localPtr = nextPtr; - } - ckfree((char *) procPtr); -} - -/* - *---------------------------------------------------------------------- - * - * TclUpdateReturnInfo -- - * - * This function is called when procedures return, and at other points - * where the TCL_RETURN code is used. It examines the returnLevel and - * returnCode to determine the real return status. - * - * Results: - * The return value is the true completion code to use for the procedure - * or script, instead of TCL_RETURN. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -TclUpdateReturnInfo( - Interp *iPtr) /* Interpreter for which TCL_RETURN exception - * is being processed. */ -{ - int code = TCL_RETURN; - - iPtr->returnLevel--; - if (iPtr->returnLevel < 0) { - Tcl_Panic("TclUpdateReturnInfo: negative return level"); - } - if (iPtr->returnLevel == 0) { - /* - * Now we've reached the level to return the requested -code. - */ - - code = iPtr->returnCode; - } - return code; -} - -/* - *---------------------------------------------------------------------- - * - * TclGetObjInterpProc -- - * - * Returns a pointer to the TclObjInterpProc function; this is different - * from the value obtained from the TclObjInterpProc reference on systems - * like Windows where import and export versions of a function exported - * by a DLL exist. - * - * Results: - * Returns the internal address of the TclObjInterpProc function. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -TclObjCmdProcType -TclGetObjInterpProc(void) -{ - return (TclObjCmdProcType) TclObjInterpProc; -} - -/* - *---------------------------------------------------------------------- - * - * TclNewProcBodyObj -- - * - * Creates a new object, of type "procbody", whose internal - * representation is the given Proc struct. The newly created object's - * reference count is 0. - * - * Results: - * Returns a pointer to a newly allocated Tcl_Obj, 0 on error. - * - * Side effects: - * The reference count in the ByteCode attached to the Proc is bumped up - * by one, since the internal rep stores a pointer to it. - * - *---------------------------------------------------------------------- - */ - -Tcl_Obj * -TclNewProcBodyObj( - Proc *procPtr) /* the Proc struct to store as the internal - * representation. */ -{ - Tcl_Obj *objPtr; - - if (!procPtr) { - return NULL; - } - - objPtr = Tcl_NewStringObj("", 0); - - if (objPtr) { - objPtr->typePtr = &tclProcBodyType; - objPtr->internalRep.otherValuePtr = (void *) procPtr; - - procPtr->refCount++; - } - - return objPtr; -} - -/* - *---------------------------------------------------------------------- - * - * ProcBodyDup -- - * - * Tcl_ObjType's Dup function for the proc body object. Bumps the - * reference count on the Proc stored in the internal representation. - * - * Results: - * None. - * - * Side effects: - * Sets up the object in dupPtr to be a duplicate of the one in srcPtr. - * - *---------------------------------------------------------------------- - */ - -static void -ProcBodyDup( - Tcl_Obj *srcPtr, /* object to copy */ - Tcl_Obj *dupPtr) /* target object for the duplication */ -{ - Proc *procPtr = (Proc *) srcPtr->internalRep.otherValuePtr; - - dupPtr->typePtr = &tclProcBodyType; - dupPtr->internalRep.otherValuePtr = (void *) procPtr; - procPtr->refCount++; -} - -/* - *---------------------------------------------------------------------- - * - * ProcBodyFree -- - * - * Tcl_ObjType's Free function for the proc body object. The reference - * count on its Proc struct is decreased by 1; if the count reaches 0, - * the proc is freed. - * - * Results: - * None. - * - * Side effects: - * If the reference count on the Proc struct reaches 0, the struct is - * freed. - * - *---------------------------------------------------------------------- - */ - -static void -ProcBodyFree( - Tcl_Obj *objPtr) /* the object to clean up */ -{ - Proc *procPtr = (Proc *) objPtr->internalRep.otherValuePtr; - procPtr->refCount--; - if (procPtr->refCount <= 0) { - TclProcCleanupProc(procPtr); - } -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileNoOp -- - * - * Function called to compile no-op's - * - * Results: - * The return value is TCL_OK, indicating successful compilation. - * - * Side effects: - * Instructions are added to envPtr to execute a no-op at runtime. - * - *---------------------------------------------------------------------- - */ - -static int -TclCompileNoOp( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *tokenPtr; - int i; - int savedStackDepth = envPtr->currStackDepth; - - tokenPtr = parsePtr->tokenPtr; - for(i = 1; i < parsePtr->numWords; i++) { - tokenPtr = tokenPtr + tokenPtr->numComponents + 1; - envPtr->currStackDepth = savedStackDepth; - - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - TclCompileTokens(interp, tokenPtr+1, tokenPtr->numComponents, - envPtr); - TclEmitOpcode(INST_POP, envPtr); - } - } - envPtr->currStackDepth = savedStackDepth; - TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr); - return TCL_OK; -} - -/* - * LAMBDA and APPLY implementation - * - */ - -static void DupLambdaInternalRep(Tcl_Obj *objPtr, - Tcl_Obj *copyPtr); -static void FreeLambdaInternalRep( - Tcl_Obj *objPtr); -static int SetLambdaFromAny(Tcl_Interp *interp, - Tcl_Obj *objPtr); - -Tcl_ObjType lambdaType = { - "lambdaExpr", /* name */ - FreeLambdaInternalRep, /* freeIntRepProc */ - DupLambdaInternalRep, /* dupIntRepProc */ - (Tcl_UpdateStringProc *) NULL, /* updateStringProc */ - SetLambdaFromAny /* setFromAnyProc */ -}; - -/* - * a lambdaType Tcl_Obj has the form - * - * ptr1 is a *Proc: pointer to a proc structure - * ptr2 is a *Tcl_Obj: the lambda's namespace - */ - -static void -DupLambdaInternalRep(srcPtr, copyPtr) - Tcl_Obj *srcPtr; /* Object with internal rep to copy. */ - register Tcl_Obj *copyPtr; /* Object with internal rep to set. */ -{ - Proc *procPtr = (Proc *) srcPtr->internalRep.twoPtrValue.ptr1; - Tcl_Obj *nsObjPtr = (Tcl_Obj *) srcPtr->internalRep.twoPtrValue.ptr2; - - copyPtr->internalRep.twoPtrValue.ptr1 = (VOID *) procPtr; - copyPtr->internalRep.twoPtrValue.ptr2 = (VOID *) nsObjPtr; - - procPtr->refCount++; - Tcl_IncrRefCount(nsObjPtr); - copyPtr->typePtr = &lambdaType; -} - -static void -FreeLambdaInternalRep(objPtr) - register Tcl_Obj *objPtr; /* CmdName object with internal - * representation to free. */ -{ - Proc *procPtr = (Proc *) objPtr->internalRep.twoPtrValue.ptr1; - Tcl_Obj *nsObjPtr = (Tcl_Obj *) objPtr->internalRep.twoPtrValue.ptr2; - - procPtr->refCount--; - if (procPtr->refCount == 0) { - TclProcCleanupProc(procPtr); - } - TclDecrRefCount(nsObjPtr); -} - - -static int -SetLambdaFromAny(interp, objPtr) - Tcl_Interp *interp; /* Used for error reporting if not NULL. */ - register Tcl_Obj *objPtr; /* The object to convert. */ -{ - char *name; - Tcl_Obj *argsPtr, *bodyPtr, *nsObjPtr, **objv, *errPtr; - int objc; - Proc *procPtr; - int result; - - /* - * Convert objPtr to list type first; if it cannot be - * converted, or if its length is not 2, then it cannot - * be converted to lambdaType. - */ - - result = Tcl_ListObjGetElements(interp, objPtr, &objc, &objv); - if ((result != TCL_OK) || ((objc != 2) && (objc != 3))) { - errPtr = Tcl_NewStringObj("can't interpret \"",-1); - Tcl_AppendObjToObj(errPtr, objPtr); - Tcl_AppendToObj(errPtr, "\" as a lambda expression", -1); - Tcl_SetObjResult(interp, errPtr); - return TCL_ERROR; - } - - argsPtr = objv[0]; - bodyPtr = objv[1]; - - /* - * Create and initialize the Proc struct. The cmdPtr field is - * set to NULL to signal that this is an anonymous function. - */ - - name = TclGetString(objPtr); - - if (TclCreateProc(interp, /*ignored nsPtr*/ NULL, name, argsPtr, - bodyPtr, &procPtr) != TCL_OK) { - TclFormatToErrorInfo(interp, - "\n (parsing lambda expression \"%s\")", - Tcl_GetString(objPtr), NULL); - return TCL_ERROR; - } - procPtr->refCount++; - procPtr->cmdPtr = (Command *) NULL; - - /* - * Set the namespace for this lambda: given by objv[2] understood - * as a global reference, or else global per default. - */ - - if (objc == 2) { - nsObjPtr = Tcl_NewStringObj("::", 2); - } else { - char *nsName = Tcl_GetString(objv[2]); - if ((*nsName != ':') || (*(nsName+1) != ':')) { - nsObjPtr = Tcl_NewStringObj("::", 2); - Tcl_AppendObjToObj(nsObjPtr, objv[2]); - } else { - nsObjPtr = objv[2]; - } - } - - Tcl_IncrRefCount(nsObjPtr); - - /* - * Free the list internalrep of objPtr - this will free argsPtr, but - * bodyPtr retains a reference from the Proc structure. Then finish - * the conversion to lambdaType. - */ - - objPtr->typePtr->freeIntRepProc(objPtr); - - objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) procPtr; - objPtr->internalRep.twoPtrValue.ptr2 = (VOID *) nsObjPtr; - objPtr->typePtr = &lambdaType; - return TCL_OK; -} - -int -Tcl_ApplyObjCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ -{ - Interp *iPtr = (Interp *) interp; - Proc *procPtr = NULL; - Tcl_Obj *lambdaPtr, *nsObjPtr, *errPtr; - int result; - Command cmd; - Tcl_Namespace *nsPtr; - -#define JOE_EXTENSION 0 -#if JOE_EXTENSION - Tcl_Obj *elemPtr; - int numElem; -#endif - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "lambdaExpr ?arg1 arg2 ...?"); - return TCL_ERROR; - } - - /* - * Set lambdaPtr, convert it to lambdaType in the current - * interp if necessary. - */ - - lambdaPtr = objv[1]; - if (lambdaPtr->typePtr == &lambdaType) { - procPtr = (Proc *) lambdaPtr->internalRep.twoPtrValue.ptr1; - -#if JOE_EXTENSION -/* - * Joe English's suggestion to allow cmdNames to function as lambdas. Requires - * also making tclCmdNameType non-static in tclObj.c - * - */ - } else if ((lambdaPtr->typePtr == &tclCmdNameType) - || (TCL_OK == (Tcl_ListObjGetElements(interp, lambdaPtr, &numElem, &elemPtr)) - && (numElem == 1))) { - return Tcl_EvalObjv(interp, objc-1, objv+1, 0); -#endif - } - - if ((procPtr == NULL) || (procPtr->iPtr != iPtr)) { - result = SetLambdaFromAny(interp, lambdaPtr); - if (result != TCL_OK) { - return result; - } - procPtr = (Proc *) lambdaPtr->internalRep.twoPtrValue.ptr1; - } - procPtr->cmdPtr = &cmd; - - /* - * Find the namespace where this lambda should run, and - * push a call frame for that namespace. Note that - * TclObjInterpProc() will pop it. - */ - - nsObjPtr = (Tcl_Obj *) lambdaPtr->internalRep.twoPtrValue.ptr2; - result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr); - if (result != TCL_OK) { - return result; - } - - if (nsPtr == (Tcl_Namespace *) NULL) { - errPtr = Tcl_NewStringObj("cannot find namespace \"",-1); - Tcl_AppendObjToObj(errPtr, nsObjPtr); - Tcl_AppendToObj(errPtr, "\"", -1); - Tcl_SetObjResult(interp, errPtr); - return TCL_ERROR; - } - - cmd.nsPtr = (Namespace *) nsPtr; - - return ObjInterpProcEx((ClientData) procPtr, interp, objc, objv, 2); -} - -/* - * Local Variables: - * mode: c - * c-basic-offset: 4 - * fill-column: 78 - * End: - */ +/* + * tclProc.c -- + * + * This file contains routines that implement Tcl procedures, including + * the "proc" and "uplevel" commands. + * + * Copyright (c) 1987-1993 The Regents of the University of California. + * Copyright (c) 1994-1998 Sun Microsystems, Inc. + * Copyright (c) 2004-2006 Miguel Sofer + * + * 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.86.2.7 2006/10/08 15:39:59 dkf Exp $ + */ + +#include "tclInt.h" +#include "tclCompile.h" +#include "tclOO.h" + +/* + * Prototypes for static functions in this file + */ + +static int ObjInterpProcEx(ClientData clientData, + register Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[], int skip); +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); +static int TclCompileNoOp(Tcl_Interp *interp, Tcl_Parse *parsePtr, + struct CompileEnv *envPtr); +static void InitCompiledLocals(Tcl_Interp *interp, + ByteCode *codePtr, CompiledLocal *localPtr, + Var *varPtr, Namespace *nsPtr); +static void DupLambdaInternalRep(Tcl_Obj *objPtr, + Tcl_Obj *copyPtr); +static void FreeLambdaInternalRep(Tcl_Obj *objPtr); +static int SetLambdaFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); + +/* + * The ProcBodyObjType type + */ + +Tcl_ObjType tclProcBodyType = { + "procbody", /* name for this type */ + ProcBodyFree, /* FreeInternalRep function */ + ProcBodyDup, /* DupInternalRep function */ + NULL, /* UpdateString function; Tcl_GetString and + * Tcl_GetStringFromObj should panic + * instead. */ + NULL /* SetFromAny function; Tcl_ConvertToType + * should panic instead. */ +}; + +/* + * The [upvar]/[uplevel] level reference type. Uses the twoPtrValue field, + * encoding the type of level reference in ptr1 and the actual parsed out + * offset in ptr2. + * + * Uses the default behaviour throughout, and never disposes of the string + * rep; it's just a cache type. + */ + +static Tcl_ObjType levelReferenceType = { + "levelReference", + NULL, NULL, NULL, NULL +}; + +/* + * The type of "lambda expression" terms (i.e., the first arguments to the + * [apply] command). A lambdaType Tcl_Obj has the form: + * + * ptr1 is a *Proc: pointer to a proc structure + * ptr2 is a *Tcl_Obj: the lambda's namespace + */ + +Tcl_ObjType lambdaType = { + "lambdaExpr", /* name */ + FreeLambdaInternalRep, /* freeIntRepProc */ + DupLambdaInternalRep, /* dupIntRepProc */ + NULL, /* updateStringProc */ + SetLambdaFromAny /* setFromAnyProc */ +}; + +/* + *---------------------------------------------------------------------- + * + * Tcl_ProcObjCmd -- + * + * This object-based function is invoked to process the "proc" Tcl + * command. See the user documentation for details on what it does. + * + * Results: + * A standard Tcl object result value. + * + * Side effects: + * A new procedure gets created. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_ProcObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + register Interp *iPtr = (Interp *) interp; + Proc *procPtr; + char *fullName; + const char *procName, *procArgs, *procBody; + Namespace *nsPtr, *altNsPtr, *cxtNsPtr; + Tcl_Command cmd; + Tcl_DString ds; + + if (objc != 4) { + Tcl_WrongNumArgs(interp, 1, objv, "name args body"); + return TCL_ERROR; + } + + /* + * Determine the namespace where the procedure should reside. Unless the + * command name includes namespace qualifiers, this will be the current + * namespace. + */ + + fullName = TclGetString(objv[1]); + TclGetNamespaceForQualName(interp, fullName, NULL, 0, + &nsPtr, &altNsPtr, &cxtNsPtr, &procName); + + if (nsPtr == NULL) { + Tcl_AppendResult(interp, "can't create procedure \"", fullName, + "\": unknown namespace", NULL); + return TCL_ERROR; + } + if (procName == NULL) { + Tcl_AppendResult(interp, "can't create procedure \"", fullName, + "\": bad procedure name", NULL); + return TCL_ERROR; + } + if ((nsPtr != iPtr->globalNsPtr) + && (procName != NULL) && (procName[0] == ':')) { + Tcl_AppendResult(interp, "can't create procedure \"", procName, + "\" in non-global namespace with name starting with \":\"", + NULL); + return TCL_ERROR; + } + + /* + * Create the data structure to represent the procedure. + */ + + if (TclCreateProc(interp, nsPtr, procName, objv[2], objv[3], + &procPtr) != TCL_OK) { + Tcl_AddErrorInfo(interp, "\n (creating proc \""); + Tcl_AddErrorInfo(interp, procName); + Tcl_AddErrorInfo(interp, "\")"); + return TCL_ERROR; + } + + /* + * Now create a command for the procedure. This will initially be in the + * current namespace unless the procedure's name included namespace + * qualifiers. To create the new command in the right namespace, we + * generate a fully qualified name for it. + */ + + Tcl_DStringInit(&ds); + if (nsPtr != iPtr->globalNsPtr) { + Tcl_DStringAppend(&ds, nsPtr->fullName, -1); + Tcl_DStringAppend(&ds, "::", 2); + } + Tcl_DStringAppend(&ds, procName, -1); + + cmd = Tcl_CreateObjCommand(interp, Tcl_DStringValue(&ds), + TclObjInterpProc, (ClientData) procPtr, TclProcDeleteProc); + + Tcl_DStringFree(&ds); + + /* + * Now initialize the new procedure's cmdPtr field. This will be used + * later when the procedure is called to determine what namespace the + * procedure will run in. This will be different than the current + * namespace if the proc was renamed into a different namespace. + */ + + procPtr->cmdPtr = (Command *) cmd; + + /* + * Optimize for no-op procs: if the body is not precompiled (like a TclPro + * procbody), and the argument list is just "args" and the body is empty, + * define a compileProc to compile a no-op. + * + * Notes: + * - cannot be done for any argument list without having different + * compiled/not-compiled behaviour in the "wrong argument #" case, or + * making this code much more complicated. In any case, it doesn't + * seem to make a lot of sense to verify the number of arguments we + * are about to ignore ... + * - could be enhanced to handle also non-empty bodies that contain only + * comments; however, parsing the body will slow down the compilation + * of all procs whose argument list is just _args_ + */ + + if (objv[3]->typePtr == &tclProcBodyType) { + goto done; + } + + procArgs = TclGetString(objv[2]); + + while (*procArgs == ' ') { + procArgs++; + } + + if ((procArgs[0] == 'a') && (strncmp(procArgs, "args", 4) == 0)) { + procArgs +=4; + while(*procArgs != '\0') { + if (*procArgs != ' ') { + goto done; + } + procArgs++; + } + + /* + * The argument list is just "args"; check the body + */ + + procBody = TclGetString(objv[3]); + while (*procBody != '\0') { + if (!isspace(UCHAR(*procBody))) { + goto done; + } + procBody++; + } + + /* + * The body is just spaces: link the compileProc + */ + + ((Command *) cmd)->compileProc = TclCompileNoOp; + } + + done: + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCreateProc -- + * + * Creates the data associated with a Tcl procedure definition. This + * function knows how to handle two types of body objects: strings and + * procbody. Strings are the traditional (and common) value for bodies, + * procbody are values created by extensions that have loaded a + * previously compiled script. + * + * Results: + * Returns TCL_OK on success, along with a pointer to a Tcl procedure + * definition in procPtrPtr where the cmdPtr field is not initialised. + * This definition should be freed by calling TclProcCleanupProc() when + * it is no longer needed. Returns TCL_ERROR if anything goes wrong. + * + * Side effects: + * If anything goes wrong, this function returns an error message in the + * interpreter. + * + *---------------------------------------------------------------------- + */ + +int +TclCreateProc( + Tcl_Interp *interp, /* interpreter containing proc */ + Namespace *nsPtr, /* namespace containing 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; + + register Proc *procPtr; + int i, length, result, numArgs; + const char *args, *bytes, *p; + register CompiledLocal *localPtr = NULL; + Tcl_Obj *defPtr; + int precompiled = 0; + + if (bodyPtr->typePtr == &tclProcBodyType) { + /* + * Because the body is a TclProProcBody, the actual body is already + * compiled, and it is not shared with anyone else, so it's OK not to + * unshare it (as a matter of fact, it is bad to unshare it, because + * there may be no source code). + * + * We don't create and initialize a Proc structure for the procedure; + * rather, we use what is in the body object. We increment the ref + * count of the Proc struct since the command (soon to be created) + * will be holding a reference to it. + */ + + procPtr = (Proc *) bodyPtr->internalRep.otherValuePtr; + procPtr->iPtr = iPtr; + procPtr->refCount++; + precompiled = 1; + } else { + /* + * If the procedure's body object is shared because its string value + * is identical to, e.g., the body of another procedure, we must + * create a private copy for this procedure to use. Such sharing of + * procedure bodies is rare but can cause problems. A procedure body + * is compiled in a context that includes the number of + * compiler-allocated "slots" for local variables. Each formal + * parameter is given a local variable slot (the + * "procPtr->numCompiledLocals = numArgs" assignment below). This + * means that the same code can not be shared by two procedures that + * have a different number of arguments, even if their bodies are + * identical. Note that we don't use Tcl_DuplicateObj since we would + * not want any bytecode internal representation. + */ + + if (Tcl_IsShared(bodyPtr)) { + bytes = Tcl_GetStringFromObj(bodyPtr, &length); + bodyPtr = Tcl_NewStringObj(bytes, length); + } + + /* + * Create and initialize a Proc structure for the procedure. We + * increment the ref count of the procedure's body object since there + * will be a reference to it in the Proc structure. + */ + + Tcl_IncrRefCount(bodyPtr); + + procPtr = (Proc *) ckalloc(sizeof(Proc)); + procPtr->iPtr = iPtr; + procPtr->refCount = 1; + procPtr->bodyPtr = bodyPtr; + procPtr->numArgs = 0; /* actual argument count is set below. */ + procPtr->numCompiledLocals = 0; + procPtr->firstLocalPtr = NULL; + procPtr->lastLocalPtr = NULL; + } + + /* + * Break up the argument list into argument specifiers, then process each + * argument specifier. If the body is precompiled, processing is limited + * to checking that the parsed argument is consistent with the one stored + * in the Proc. + * + * THIS FAILS IF THE ARG LIST OBJECT'S STRING REP CONTAINS NULS. + */ + + args = Tcl_GetStringFromObj(argsPtr, &length); + result = Tcl_SplitList(interp, args, &numArgs, &argArray); + if (result != TCL_OK) { + goto procError; + } + + if (precompiled) { + if (numArgs > procPtr->numArgs) { + Tcl_Obj *objPtr = Tcl_NewObj(); + TclObjPrintf(NULL, objPtr, + "procedure \"%s\": arg list contains %d entries, " + "precompiled header expects %d", procName, numArgs, + procPtr->numArgs); + Tcl_SetObjResult(interp, objPtr); + goto procError; + } + localPtr = procPtr->firstLocalPtr; + } else { + procPtr->numArgs = numArgs; + procPtr->numCompiledLocals = numArgs; + } + + for (i = 0; i < numArgs; i++) { + int fieldCount, nameLength, valueLength; + const char **fieldValues; + + /* + * Now divide the specifier up into name and default. + */ + + result = Tcl_SplitList(interp, argArray[i], &fieldCount, + &fieldValues); + if (result != TCL_OK) { + goto procError; + } + if (fieldCount > 2) { + ckfree((char *) fieldValues); + Tcl_AppendResult(interp, + "too many fields in argument specifier \"", + argArray[i], "\"", NULL); + goto procError; + } + if ((fieldCount == 0) || (*fieldValues[0] == 0)) { + ckfree((char *) fieldValues); + Tcl_AppendResult(interp, "argument with no name", NULL); + goto procError; + } + + nameLength = strlen(fieldValues[0]); + if (fieldCount == 2) { + valueLength = strlen(fieldValues[1]); + } else { + valueLength = 0; + } + + /* + * Check that the formal parameter name is a scalar. + */ + + p = fieldValues[0]; + while (*p != '\0') { + if (*p == '(') { + const char *q = p; + do { + q++; + } while (*q != '\0'); + q--; + if (*q == ')') { /* we have an array element */ + Tcl_AppendResult(interp, "formal parameter \"", + fieldValues[0], + "\" is an array element", NULL); + ckfree((char *) fieldValues); + goto procError; + } + } else if ((*p == ':') && (*(p+1) == ':')) { + Tcl_AppendResult(interp, "formal parameter \"", + fieldValues[0], + "\" is not a simple name", NULL); + ckfree((char *) fieldValues); + goto procError; + } + p++; + } + + if (precompiled) { + /* + * Compare the parsed argument with the stored one. For the flags, + * we and out VAR_UNDEFINED to support bridging precompiled <= 8.3 + * code in 8.4 where this is now used as an optimization + * indicator. Yes, this is a hack. -- hobbs + */ + + if ((localPtr->nameLength != nameLength) + || (strcmp(localPtr->name, fieldValues[0])) + || (localPtr->frameIndex != i) + || ((localPtr->flags & ~VAR_UNDEFINED) + != (VAR_SCALAR | VAR_ARGUMENT)) + || (localPtr->defValuePtr == NULL && fieldCount == 2) + || (localPtr->defValuePtr != NULL && fieldCount != 2)) { + Tcl_Obj *objPtr = Tcl_NewObj(); + TclObjPrintf(NULL, objPtr, + "procedure \"%s\": formal parameter %d is " + "inconsistent with precompiled body", procName, i); + Tcl_SetObjResult(interp, objPtr); + ckfree((char *) fieldValues); + goto procError; + } + + /* + * compare the default value if any + */ + + if (localPtr->defValuePtr != NULL) { + int tmpLength; + char *tmpPtr = Tcl_GetStringFromObj(localPtr->defValuePtr, + &tmpLength); + if ((valueLength != tmpLength) || + strncmp(fieldValues[1], tmpPtr, (size_t) tmpLength)) { + Tcl_Obj *objPtr = Tcl_NewObj(); + + TclObjPrintf(NULL, objPtr, + "procedure \"%s\": formal parameter \"%s\" has " + "default value inconsistent with precompiled body", + procName, fieldValues[0]); + Tcl_SetObjResult(interp, objPtr); + ckfree((char *) fieldValues); + goto procError; + } + } + if ((i == numArgs - 1) + && (localPtr->nameLength == 4) + && (localPtr->name[0] == 'a') + && (strcmp(localPtr->name, "args") == 0)) { + localPtr->flags |= VAR_IS_ARGS; + } + + localPtr = localPtr->nextPtr; + } else { + /* + * Allocate an entry in the runtime procedure frame's array of + * local variables for the argument. + */ + + localPtr = (CompiledLocal *) ckalloc((unsigned) + (sizeof(CompiledLocal) - sizeof(localPtr->name) + + nameLength + 1)); + if (procPtr->firstLocalPtr == NULL) { + procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr; + } else { + procPtr->lastLocalPtr->nextPtr = localPtr; + procPtr->lastLocalPtr = localPtr; + } + localPtr->nextPtr = NULL; + localPtr->nameLength = nameLength; + localPtr->frameIndex = i; + localPtr->flags = VAR_SCALAR | VAR_ARGUMENT; + localPtr->resolveInfo = NULL; + + if (fieldCount == 2) { + localPtr->defValuePtr = + Tcl_NewStringObj(fieldValues[1], valueLength); + Tcl_IncrRefCount(localPtr->defValuePtr); + } else { + localPtr->defValuePtr = NULL; + } + strcpy(localPtr->name, fieldValues[0]); + if ((i == numArgs - 1) + && (localPtr->nameLength == 4) + && (localPtr->name[0] == 'a') + && (strcmp(localPtr->name, "args") == 0)) { + localPtr->flags |= VAR_IS_ARGS; + } + } + + ckfree((char *) fieldValues); + } + + *procPtrPtr = procPtr; + ckfree((char *) argArray); + return TCL_OK; + + procError: + if (precompiled) { + procPtr->refCount--; + } else { + Tcl_DecrRefCount(bodyPtr); + while (procPtr->firstLocalPtr != NULL) { + localPtr = procPtr->firstLocalPtr; + procPtr->firstLocalPtr = localPtr->nextPtr; + + defPtr = localPtr->defValuePtr; + if (defPtr != NULL) { + Tcl_DecrRefCount(defPtr); + } + + ckfree((char *) localPtr); + } + ckfree((char *) procPtr); + } + if (argArray != NULL) { + ckfree((char *) argArray); + } + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * TclGetFrame -- + * + * Given a description of a procedure frame, such as the first argument + * to an "uplevel" or "upvar" command, locate the call frame for the + * appropriate level of procedure. + * + * Results: + * The return value is -1 if an error occurred in finding the frame (in + * this case an error message is left in the interp's result). 1 is + * returned if string was either a number or a number preceded by "#" and + * it specified a valid frame. 0 is returned if string isn't one of the + * two things above (in this case, the lookup acts as if string were + * "1"). The variable pointed to by framePtrPtr is filled in with the + * address of the desired frame (unless an error occurs, in which case it + * isn't modified). + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclGetFrame( + Tcl_Interp *interp, /* Interpreter in which to find frame. */ + const char *name, /* String describing frame. */ + CallFrame **framePtrPtr) /* Store pointer to frame here (or NULL if + * global frame indicated). */ +{ + register Interp *iPtr = (Interp *) interp; + int curLevel, level, result; + CallFrame *framePtr; + + /* + * Parse string to figure out which level number to go to. + */ + + result = 1; + curLevel = (iPtr->varFramePtr == NULL) ? 0 : iPtr->varFramePtr->level; + if (*name== '#') { + if (Tcl_GetInt(interp, name+1, &level) != TCL_OK || level < 0) { + goto levelError; + } + } else if (isdigit(UCHAR(*name))) { /* INTL: digit */ + if (Tcl_GetInt(interp, name, &level) != TCL_OK) { + goto levelError; + } + level = curLevel - level; + } else { + level = curLevel - 1; + result = 0; + } + + /* + * Figure out which frame to use, and return it to the caller. + */ + + if (level == 0) { + framePtr = NULL; + } else { + for (framePtr = iPtr->varFramePtr; framePtr != NULL; + framePtr = framePtr->callerVarPtr) { + if (framePtr->level == level) { + break; + } + } + if (framePtr == NULL) { + goto levelError; + } + } + *framePtrPtr = framePtr; + return result; + + levelError: + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "bad level \"", name, "\"", NULL); + return -1; +} + +/* + *---------------------------------------------------------------------- + * + * TclObjGetFrame -- + * + * Given a description of a procedure frame, such as the first argument + * to an "uplevel" or "upvar" command, locate the call frame for the + * appropriate level of procedure. + * + * Results: + * The return value is -1 if an error occurred in finding the frame (in + * this case an error message is left in the interp's result). 1 is + * returned if objPtr was either a number or a number preceded by "#" and + * it specified a valid frame. 0 is returned if objPtr isn't one of the + * two things above (in this case, the lookup acts as if objPtr were + * "1"). The variable pointed to by framePtrPtr is filled in with the + * address of the desired frame (unless an error occurs, in which case it + * isn't modified). + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclObjGetFrame( + Tcl_Interp *interp, /* Interpreter in which to find frame. */ + Tcl_Obj *objPtr, /* Object describing frame. */ + CallFrame **framePtrPtr) /* Store pointer to frame here (or NULL if + * global frame indicated). */ +{ + register Interp *iPtr = (Interp *) interp; + int curLevel, level, result; + CallFrame *framePtr; + const char *name = TclGetString(objPtr); + + /* + * Parse object to figure out which level number to go to. + */ + + result = 1; + curLevel = (iPtr->varFramePtr == NULL) ? 0 : iPtr->varFramePtr->level; + if (objPtr->typePtr == &levelReferenceType) { + if ((int) objPtr->internalRep.twoPtrValue.ptr1) { + level = curLevel - (int) objPtr->internalRep.twoPtrValue.ptr2; + } else { + level = (int) objPtr->internalRep.twoPtrValue.ptr2; + } + if (level < 0) { + goto levelError; + } + /* TODO: Consider skipping the typePtr checks */ + } else if (objPtr->typePtr == &tclIntType +#ifndef NO_WIDE_TYPE + || objPtr->typePtr == &tclWideIntType +#endif + ) { + if (Tcl_GetIntFromObj(NULL, objPtr, &level) != TCL_OK || level < 0) { + goto levelError; + } + level = curLevel - level; + } else { + if (*name == '#') { + if (Tcl_GetInt(interp, name+1, &level) != TCL_OK || level < 0) { + goto levelError; + } + + /* + * Cache for future reference. + * + * TODO: Use the new ptrAndLongRep intrep + */ + + TclFreeIntRep(objPtr); + objPtr->typePtr = &levelReferenceType; + objPtr->internalRep.twoPtrValue.ptr1 = (void *) 0; + objPtr->internalRep.twoPtrValue.ptr2 = (void *) level; + } else if (isdigit(UCHAR(*name))) { /* INTL: digit */ + if (Tcl_GetInt(interp, name, &level) != TCL_OK) { + return -1; + } + + /* + * Cache for future reference. + * + * TODO: Use the new ptrAndLongRep intrep + */ + + TclFreeIntRep(objPtr); + objPtr->typePtr = &levelReferenceType; + objPtr->internalRep.twoPtrValue.ptr1 = (void *) 1; + objPtr->internalRep.twoPtrValue.ptr2 = (void *) level; + level = curLevel - level; + } else { + /* + * Don't cache as the object *isn't* a level reference. + */ + + level = curLevel - 1; + result = 0; + } + } + + /* + * Figure out which frame to use, and return it to the caller. + */ + + if (level == 0) { + framePtr = NULL; + } else { + for (framePtr = iPtr->varFramePtr; framePtr != NULL; + framePtr = framePtr->callerVarPtr) { + if (framePtr->level == level) { + break; + } + } + if (framePtr == NULL) { + goto levelError; + } + } + *framePtrPtr = framePtr; + return result; + + levelError: + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "bad level \"", name, "\"", NULL); + return -1; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_UplevelObjCmd -- + * + * This object function is invoked to process the "uplevel" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl object result value. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_UplevelObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + register Interp *iPtr = (Interp *) interp; + int result; + CallFrame *savedVarFramePtr, *framePtr; + + if (objc < 2) { + uplevelSyntax: + Tcl_WrongNumArgs(interp, 1, objv, "?level? command ?arg ...?"); + return TCL_ERROR; + } + + /* + * Find the level to use for executing the command. + */ + + result = TclObjGetFrame(interp, objv[1], &framePtr); + if (result == -1) { + return TCL_ERROR; + } + objc -= (result+1); + if (objc == 0) { + goto uplevelSyntax; + } + objv += (result+1); + + /* + * Modify the interpreter state to execute in the given frame. + */ + + savedVarFramePtr = iPtr->varFramePtr; + iPtr->varFramePtr = framePtr; + + /* + * Execute the residual arguments as a command. + */ + + if (objc == 1) { + result = Tcl_EvalObjEx(interp, objv[0], TCL_EVAL_DIRECT); + } else { + /* + * 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. + */ + + Tcl_Obj *objPtr; + + objPtr = Tcl_ConcatObj(objc, objv); + result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT); + } + if (result == TCL_ERROR) { + TclFormatToErrorInfo(interp, "\n (\"uplevel\" body line %d)", + interp->errorLine); + } + + /* + * Restore the variable frame, and return. + */ + + iPtr->varFramePtr = savedVarFramePtr; + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TclFindProc -- + * + * Given the name of a procedure, return a pointer to the record + * describing the procedure. The procedure will be looked up using the + * usual rules: first in the current namespace and then in the global + * namespace. + * + * Results: + * NULL is returned if the name doesn't correspond to any procedure. + * Otherwise, the return value is a pointer to the procedure's record. If + * the name is found but refers to an imported command that points to a + * "real" procedure defined in another namespace, a pointer to that + * "real" procedure's structure is returned. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Proc * +TclFindProc( + Interp *iPtr, /* Interpreter in which to look. */ + const char *procName) /* Name of desired procedure. */ +{ + Tcl_Command cmd; + Tcl_Command origCmd; + Command *cmdPtr; + + cmd = Tcl_FindCommand((Tcl_Interp *) iPtr, procName, NULL, /*flags*/ 0); + if (cmd == (Tcl_Command) NULL) { + return NULL; + } + cmdPtr = (Command *) cmd; + + origCmd = TclGetOriginalCommand(cmd); + if (origCmd != NULL) { + cmdPtr = (Command *) origCmd; + } + if (cmdPtr->objProc != TclObjInterpProc) { + return NULL; + } + return (Proc *) cmdPtr->objClientData; +} + +/* + *---------------------------------------------------------------------- + * + * TclIsProc -- + * + * Tells whether a command is a Tcl procedure or not. + * + * Results: + * If the given command is actually a Tcl procedure, the return value is + * the address of the record describing the procedure. Otherwise the + * return value is 0. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Proc * +TclIsProc( + Command *cmdPtr) /* Command to test. */ +{ + Tcl_Command origCmd; + + origCmd = TclGetOriginalCommand((Tcl_Command) cmdPtr); + if (origCmd != NULL) { + cmdPtr = (Command *) origCmd; + } + if (cmdPtr->objProc == TclObjInterpProc) { + return (Proc *) cmdPtr->objClientData; + } + return (Proc *) 0; +} + +/* + *---------------------------------------------------------------------- + * + * InitCompiledLocals -- + * + * This routine is invoked in order to initialize the compiled locals + * table for a new call frame. + * + * Results: + * None. + * + * Side effects: + * May invoke various name resolvers in order to determine which + * variables are being referenced at runtime. + * + *---------------------------------------------------------------------- + */ + +static void +InitCompiledLocals( + Tcl_Interp *interp, /* Current interpreter. */ + ByteCode *codePtr, + CompiledLocal *localPtr, + Var *varPtr, + Namespace *nsPtr) /* Pointer to current namespace. */ +{ + Interp *iPtr = (Interp*) interp; + int haveResolvers = (nsPtr->compiledVarResProc || iPtr->resolverPtr); + CompiledLocal *firstLocalPtr; + + if (codePtr->flags & TCL_BYTECODE_RESOLVE_VARS) { + /* + * This is the first run after a recompile, or else the resolver epoch + * has changed: update the resolver cache. + */ + + firstLocalPtr = localPtr; + for (; localPtr != NULL; localPtr = localPtr->nextPtr) { + + if (localPtr->resolveInfo) { + if (localPtr->resolveInfo->deleteProc) { + localPtr->resolveInfo->deleteProc(localPtr->resolveInfo); + } else { + ckfree((char*)localPtr->resolveInfo); + } + localPtr->resolveInfo = NULL; + } + localPtr->flags &= ~VAR_RESOLVED; + + if (haveResolvers && + !(localPtr->flags & (VAR_ARGUMENT|VAR_TEMPORARY))) { + ResolverScheme *resPtr = iPtr->resolverPtr; + Tcl_ResolvedVarInfo *vinfo; + int result; + + if (nsPtr->compiledVarResProc) { + result = (*nsPtr->compiledVarResProc)(nsPtr->interp, + localPtr->name, localPtr->nameLength, + (Tcl_Namespace *) nsPtr, &vinfo); + } else { + result = TCL_CONTINUE; + } + + while ((result == TCL_CONTINUE) && resPtr) { + if (resPtr->compiledVarResProc) { + result = (*resPtr->compiledVarResProc)(nsPtr->interp, + localPtr->name, localPtr->nameLength, + (Tcl_Namespace *) nsPtr, &vinfo); + } + resPtr = resPtr->nextPtr; + } + if (result == TCL_OK) { + localPtr->resolveInfo = vinfo; + localPtr->flags |= VAR_RESOLVED; + } + } + } + localPtr = firstLocalPtr; + codePtr->flags &= ~TCL_BYTECODE_RESOLVE_VARS; + } + + /* + * Initialize the array of local variables stored in the call frame. Some + * variables may have special resolution rules. In that case, we call + * their "resolver" procs to get our hands on the variable, and we make + * the compiled local a link to the real variable. + */ + + if (haveResolvers) { + Tcl_ResolvedVarInfo *resVarInfo; + for (; localPtr != NULL; varPtr++, localPtr = localPtr->nextPtr) { + varPtr->value.objPtr = NULL; + varPtr->name = localPtr->name; /* will be just '\0' if temp var */ + varPtr->nsPtr = NULL; + varPtr->hPtr = NULL; + varPtr->refCount = 0; + varPtr->tracePtr = NULL; + varPtr->searchPtr = NULL; + varPtr->flags = localPtr->flags; + + /* + * Now invoke the resolvers to determine the exact variables that + * should be used. + */ + + resVarInfo = localPtr->resolveInfo; + if (resVarInfo && resVarInfo->fetchProc) { + Var *resolvedVarPtr = (Var*) (*resVarInfo->fetchProc)(interp, + resVarInfo); + if (resolvedVarPtr) { + resolvedVarPtr->refCount++; + varPtr->value.linkPtr = resolvedVarPtr; + varPtr->flags = VAR_LINK; + } + } + } + } else { + for (; localPtr != NULL; varPtr++, localPtr = localPtr->nextPtr) { + varPtr->value.objPtr = NULL; + varPtr->name = localPtr->name; /* will be just '\0' if temp var */ + varPtr->nsPtr = NULL; + varPtr->hPtr = NULL; + varPtr->refCount = 0; + varPtr->tracePtr = NULL; + varPtr->searchPtr = NULL; + varPtr->flags = localPtr->flags; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * TclInitCompiledLocals -- + * + * This routine is invoked in order to initialize the compiled locals + * table for a new call frame. + * + * DEPRECATED: functionality has been inlined elsewhere; this function + * remains to insure binary compatibility with Itcl. + * + * Results: + * None. + * + * Side effects: + * May invoke various name resolvers in order to determine which + * variables are being referenced at runtime. + * + *---------------------------------------------------------------------- + */ + +void +TclInitCompiledLocals( + Tcl_Interp *interp, /* Current interpreter. */ + CallFrame *framePtr, /* Call frame to initialize. */ + Namespace *nsPtr) /* Pointer to current namespace. */ +{ + Var *varPtr = framePtr->compiledLocals; + Tcl_Obj *bodyPtr; + ByteCode *codePtr; + CompiledLocal *localPtr = framePtr->procPtr->firstLocalPtr; + + bodyPtr = framePtr->procPtr->bodyPtr; + if (bodyPtr->typePtr != &tclByteCodeType) { + Tcl_Panic("body object for proc attached to frame is not a byte code type"); + } + codePtr = (ByteCode *) bodyPtr->internalRep.otherValuePtr; + + InitCompiledLocals(interp, codePtr, localPtr, varPtr, nsPtr); +} + +/* + *---------------------------------------------------------------------- + * + * TclObjInterpProc, ObjInterpProcEx -- + * + * When a Tcl procedure gets invoked during bytecode evaluation, this + * object-based routine gets invoked to interpret the procedure. + * + * Results: + * A standard Tcl object result value. + * + * Side effects: + * Depends on the commands in the procedure. + * + *---------------------------------------------------------------------- + */ + +int +TclObjInterpProc( + ClientData clientData, /* Record describing procedure to be + * interpreted. */ + register Tcl_Interp *interp,/* Interpreter in which procedure was + * invoked. */ + int objc, /* Count of number of arguments to this + * procedure. */ + Tcl_Obj *const objv[]) /* Argument value objects. */ +{ + return ObjInterpProcEx(clientData, interp, objc, objv, /*skip*/ 1); +} + +static int +ObjInterpProcEx( + ClientData clientData, /* Record describing procedure to be + * interpreted. */ + register Tcl_Interp *interp,/* Interpreter in which procedure was + * invoked. */ + int objc, /* Count of number of arguments to this + * procedure. */ + Tcl_Obj *const objv[], /* Argument value objects. */ + int skip) /* Number of initial arguments to be skipped, + * i.e., words in the "command name" */ +{ + register Proc *procPtr = (Proc *) clientData; + Namespace *nsPtr = procPtr->cmdPtr->nsPtr; + CallFrame *framePtr, **framePtrPtr; + int result; + + /* + * If necessary, compile the procedure's body. The compiler will allocate + * frame slots for the procedure's non-argument local variables. Note that + * compiling the body might increase procPtr->numCompiledLocals if new + * local variables are found while compiling. + */ + + result = TclProcCompileProc(interp, procPtr, procPtr->bodyPtr, nsPtr, + "body of proc", TclGetString(objv[0])); + + 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 + * different than the current namespace. The proc's namespace is that of + * its command, which can change if the command is renamed from one + * namespace to another. + */ + + framePtrPtr = &framePtr; + result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, + (Tcl_Namespace *) nsPtr, FRAME_IS_PROC); + + if (result != TCL_OK) { + 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 + * parameters. + */ + + localCt = procPtr->numCompiledLocals; + compiledLocals = (Var *) TclStackAlloc(interp, (int)(localCt*sizeof(Var))); + framePtr->numCompiledLocals = localCt; + framePtr->compiledLocals = compiledLocals; + + /* + * Match and assign the call's actual parameters to the procedure's formal + * arguments. The formal arguments are described by the first numArgs + * entries in both the Proc structure's local variable list and the call + * frame's local variable array. + */ + + numArgs = procPtr->numArgs; + argCt = framePtr->objc-skip; /* set it to the number of args to the proc */ + argObjs = &framePtr->objv[skip]; + varPtr = framePtr->compiledLocals; + localPtr = procPtr->firstLocalPtr; + if (numArgs == 0) { + if (argCt) { + goto incorrectArgs; + } else { + goto runProc; + } + } + imax = ((argCt < numArgs - 1)? argCt : (numArgs - 1)); + for (i = 0; i < imax; i++) { + /* + * "Normal" arguments; last formal is special, depends on it being + * 'args'. + */ + + Tcl_Obj *objPtr = argObjs[i]; + + varPtr->value.objPtr = objPtr; + Tcl_IncrRefCount(objPtr); /* local var is a reference */ + varPtr->name = localPtr->name; + varPtr->nsPtr = NULL; + varPtr->hPtr = NULL; + varPtr->refCount = 0; + varPtr->tracePtr = NULL; + varPtr->searchPtr = NULL; + varPtr->flags = localPtr->flags; + varPtr++; + localPtr = localPtr->nextPtr; + } + for (; i < (numArgs - 1); i++) { + /* + * This loop is entered if argCt < (numArgs-1). Set default values; + * last formal is special. + */ + + if (localPtr->defValuePtr != NULL) { + Tcl_Obj *objPtr = localPtr->defValuePtr; + + varPtr->value.objPtr = objPtr; + Tcl_IncrRefCount(objPtr); /* local var is a reference */ + varPtr->name = localPtr->name; + varPtr->nsPtr = NULL; + varPtr->hPtr = NULL; + varPtr->refCount = 0; + varPtr->tracePtr = NULL; + varPtr->searchPtr = NULL; + varPtr->flags = localPtr->flags; + varPtr++; + localPtr = localPtr->nextPtr; + } else { + goto incorrectArgs; + } + } + + /* + * When we get here, the last formal argument remains to be defined: + * localPtr and varPtr point to the last argument to be initialized. + */ + + if (localPtr->flags & VAR_IS_ARGS) { + Tcl_Obj *listPtr = Tcl_NewListObj(argCt-i, &(argObjs[i])); + varPtr->value.objPtr = listPtr; + Tcl_IncrRefCount(listPtr); /* local var is a reference */ + } else if (argCt == numArgs) { + Tcl_Obj *objPtr = argObjs[i]; + varPtr->value.objPtr = objPtr; + Tcl_IncrRefCount(objPtr); /* local var is a reference */ + } else if ((argCt < numArgs) && (localPtr->defValuePtr != NULL)) { + Tcl_Obj *objPtr = localPtr->defValuePtr; + varPtr->value.objPtr = objPtr; + Tcl_IncrRefCount(objPtr); /* local var is a reference */ + } else { + Tcl_Obj **desiredObjs, *argObj; + ByteCode *codePtr; + + /* + * Do initialise all compiled locals, to avoid problems at + * DeleteLocalVars. + */ + + incorrectArgs: + codePtr = (ByteCode *) procPtr->bodyPtr->internalRep.otherValuePtr; + InitCompiledLocals(interp, codePtr, localPtr, varPtr, framePtr->nsPtr); + + /* + * Build up desired argument list for Tcl_WrongNumArgs + */ + + desiredObjs = (Tcl_Obj **) + ckalloc(sizeof(Tcl_Obj *) * (unsigned)(numArgs+1)); + +#ifdef AVOID_HACKS_FOR_ITCL + desiredObjs[0] = framePtr->objv[0]; +#else + desiredObjs[0] = Tcl_NewListObj(skip, framePtr->objv); +#endif /* AVOID_HACKS_FOR_ITCL */ + + localPtr = procPtr->firstLocalPtr; + for (i=1 ; i<=numArgs ; i++) { + TclNewObj(argObj); + if (localPtr->defValuePtr != NULL) { + Tcl_AppendStringsToObj(argObj, "?", localPtr->name, "?", NULL); + } else if ((i==numArgs) && !strcmp(localPtr->name, "args")) { + Tcl_AppendStringsToObj(argObj, "...", NULL); + } else { + Tcl_AppendStringsToObj(argObj, localPtr->name, NULL); + } + desiredObjs[i] = argObj; + localPtr = localPtr->nextPtr; + } + + Tcl_ResetResult(interp); + Tcl_WrongNumArgs(interp, numArgs+1, desiredObjs, NULL); + result = TCL_ERROR; + +#ifdef AVOID_HACKS_FOR_ITCL + for (i=1 ; i<=numArgs ; i++) { + TclDecrRefCount(desiredObjs[i]); + } +#else + for (i=0 ; i<=numArgs ; i++) { + TclDecrRefCount(desiredObjs[i]); + } +#endif /* AVOID_HACKS_FOR_ITCL */ + ckfree((char *) desiredObjs); + goto procDone; + } + + varPtr->name = localPtr->name; + varPtr->nsPtr = NULL; + varPtr->hPtr = NULL; + varPtr->refCount = 0; + varPtr->tracePtr = NULL; + varPtr->searchPtr = NULL; + varPtr->flags = localPtr->flags; + + localPtr = localPtr->nextPtr; + varPtr++; + + /* + * Initialise and resolve the remaining compiledLocals. + */ + + runProc: + if (localPtr) { + ByteCode *codePtr = (ByteCode *) + procPtr->bodyPtr->internalRep.otherValuePtr; + + InitCompiledLocals(interp, codePtr, localPtr, varPtr, framePtr->nsPtr); + } + + /* + * Invoke the commands in the procedure's body. + */ + +#ifdef TCL_COMPILE_DEBUG + if (tclTraceExec >= 1) { + fprintf(stdout, "Calling proc "); + for (i = 0; i < framePtr->objc; i++) { + TclPrintObject(stdout, framePtr->objv[i], 15); + fprintf(stdout, " "); + } + fprintf(stdout, "\n"); + fflush(stdout); + } +#endif /*TCL_COMPILE_DEBUG*/ + + procPtr->refCount++; + result = TclCompEvalObj(interp, procPtr->bodyPtr); + procPtr->refCount--; + if (procPtr->refCount <= 0) { + TclProcCleanupProc(procPtr); + } + + if (result != TCL_OK) { + result = ProcessProcResultCode(interp, procNameObj, result, isMethod); + } + + /* + * Pop and free the call frame for this procedure invocation, then free + * the compiledLocals array if malloc'ed storage was used. + */ + + procDone: + /* + * Free the stack-allocated compiled locals and CallFrame. It is important + * to pop the call frame without freeing it first: the compiledLocals + * cannot be freed before the frame is popped, as the local variables must + * be deleted. But the compiledLocals must be freed first, as they were + * allocated later on the stack. + */ + + Tcl_PopCallFrame(interp); /* pop but do not free */ + TclStackFree(interp); /* free compiledLocals */ + TclStackFree(interp); /* free CallFrame */ + return result; +#undef NUM_LOCALS +} + +/* + *---------------------------------------------------------------------- + * + * TclProcCompileProc -- + * + * Called just before a procedure is executed to compile the body to byte + * codes. If the type of the body is not "byte code" or if the compile + * conditions have changed (namespace context, epoch counters, etc.) then + * the body is recompiled. Otherwise, this function does nothing. + * + * Results: + * None. + * + * Side effects: + * May change the internal representation of the body object to compiled + * code. + * + *---------------------------------------------------------------------- + */ + +int +TclProcCompileProc( + Tcl_Interp *interp, /* Interpreter containing procedure. */ + Proc *procPtr, /* Data associated with procedure. */ + Tcl_Obj *bodyPtr, /* Body of proc. (Usually procPtr->bodyPtr, + * 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. */ +{ + Interp *iPtr = (Interp*)interp; + int result; + Tcl_CallFrame *framePtr; + Proc *saveProcPtr; + ByteCode *codePtr = (ByteCode *) bodyPtr->internalRep.otherValuePtr; + + /* + * If necessary, compile the procedure's body. The compiler will allocate + * frame slots for the procedure's non-argument local variables. If the + * ByteCode already exists, make sure it hasn't been invalidated by + * someone redefining a core command (this might make the compiled code + * wrong). Also, if the code was compiled in/for a different interpreter, + * we recompile it. Note that compiling the body might increase + * procPtr->numCompiledLocals if new local variables are found while + * compiling. + * + * Precompiled procedure bodies, however, are immutable and therefore they + * are not recompiled, even if things have changed. + */ + + if (bodyPtr->typePtr == &tclByteCodeType) { + if (((Interp *) *codePtr->interpHandle != iPtr) + || (codePtr->compileEpoch != iPtr->compileEpoch) + || (codePtr->nsPtr != nsPtr)) { + if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) { + if ((Interp *) *codePtr->interpHandle != iPtr) { + Tcl_AppendResult(interp, + "a precompiled script jumped interps", NULL); + return TCL_ERROR; + } + codePtr->compileEpoch = iPtr->compileEpoch; + codePtr->nsPtr = nsPtr; + } else { + bodyPtr->typePtr->freeIntRepProc(bodyPtr); + bodyPtr->typePtr = NULL; + } + } + } + if (bodyPtr->typePtr != &tclByteCodeType) { +#ifdef TCL_COMPILE_DEBUG + if (tclTraceCompile >= 1) { + /* + * Display a line summarizing the top level command we are about + * to compile. + */ + + Tcl_Obj *message = Tcl_NewStringObj("Compiling ", -1); + + Tcl_IncrRefCount(message); + Tcl_AppendStringsToObj(message, description, " \"", NULL); + TclAppendLimitedToObj(message, procName, -1, 50, NULL); + fprintf(stdout, "%s\"\n", TclGetString(message)); + Tcl_DecrRefCount(message); + } +#endif + + /* + * Plug the current procPtr into the interpreter and coerce the code + * body to byte codes. The interpreter needs to know which proc it's + * compiling so that it can access its list of compiled locals. + * + * TRICKY NOTE: Be careful to push a call frame with the proper + * namespace context, so that the byte codes are compiled in the + * appropriate class context. + */ + + saveProcPtr = iPtr->compiledProcPtr; + iPtr->compiledProcPtr = procPtr; + + result = TclPushStackFrame(interp, &framePtr, + (Tcl_Namespace *) nsPtr, /* isProcCallFrame */ 0); + + if (result == TCL_OK) { + result = tclByteCodeType.setFromAnyProc(interp, bodyPtr); + TclPopStackFrame(interp); + } + + iPtr->compiledProcPtr = saveProcPtr; + + if (result != TCL_OK) { + if (result == TCL_ERROR) { + int length = strlen(procName); + int limit = 50; + int overflow = (length > limit); + + TclFormatToErrorInfo(interp, + "\n (compiling %s \"%.*s%s\", line %d)", + description, (overflow ? limit : length), procName, + (overflow ? "..." : ""), interp->errorLine); + } + return result; + } + } else if (codePtr->nsEpoch != nsPtr->resolverEpoch) { + /* + * The resolver epoch has changed, but we only need to invalidate the + * resolver cache. + */ + + codePtr->flags |= TCL_BYTECODE_RESOLVE_VARS; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ProcessProcResultCode -- + * + * Function called by TclObjInterpProc to process a return code other + * than TCL_OK returned by a Tcl procedure. + * + * Results: + * Depending on the argument return code, the result returned is another + * return code and the interpreter's result is set to a value to + * supplement that return code. + * + * Side effects: + * If the result returned is TCL_ERROR, traceback information about the + * procedure just executed is appended to the interpreter's errorInfo + * field. + * + *---------------------------------------------------------------------- + */ + +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 + * messages and trace information. */ + int returnCode, /* The unexpected result code. */ + int isMethod) /* Whether this is a procedure, method, + * constructor or destructor. */ +{ + Interp *iPtr = (Interp *) interp; + int overflow, limit = 60; + + if (returnCode == TCL_OK) { + return TCL_OK; + } + if ((returnCode > TCL_CONTINUE) || (returnCode < TCL_OK)) { + return returnCode; + } + if (returnCode == TCL_RETURN) { + return TclUpdateReturnInfo(iPtr); + } + if (returnCode != TCL_ERROR) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "invoked \"", + ((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; +} + +/* + *---------------------------------------------------------------------- + * + * TclProcDeleteProc -- + * + * This function is invoked just before a command procedure is removed + * from an interpreter. Its job is to release all the resources allocated + * to the procedure. + * + * Results: + * None. + * + * Side effects: + * Memory gets freed, unless the procedure is actively being executed. + * In this case the cleanup is delayed until the last call to the current + * procedure completes. + * + *---------------------------------------------------------------------- + */ + +void +TclProcDeleteProc( + ClientData clientData) /* Procedure to be deleted. */ +{ + Proc *procPtr = (Proc *) clientData; + + procPtr->refCount--; + if (procPtr->refCount <= 0) { + TclProcCleanupProc(procPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * TclProcCleanupProc -- + * + * This function does all the real work of freeing up a Proc structure. + * It's called only when the structure's reference count becomes zero. + * + * Results: + * None. + * + * Side effects: + * Memory gets freed. + * + *---------------------------------------------------------------------- + */ + +void +TclProcCleanupProc( + register Proc *procPtr) /* Procedure to be deleted. */ +{ + register CompiledLocal *localPtr; + Tcl_Obj *bodyPtr = procPtr->bodyPtr; + Tcl_Obj *defPtr; + Tcl_ResolvedVarInfo *resVarInfo; + + if (bodyPtr != NULL) { + Tcl_DecrRefCount(bodyPtr); + } + for (localPtr = procPtr->firstLocalPtr; localPtr != NULL; ) { + CompiledLocal *nextPtr = localPtr->nextPtr; + + resVarInfo = localPtr->resolveInfo; + if (resVarInfo) { + if (resVarInfo->deleteProc) { + (*resVarInfo->deleteProc)(resVarInfo); + } else { + ckfree((char *) resVarInfo); + } + } + + if (localPtr->defValuePtr != NULL) { + defPtr = localPtr->defValuePtr; + Tcl_DecrRefCount(defPtr); + } + ckfree((char *) localPtr); + localPtr = nextPtr; + } + ckfree((char *) procPtr); +} + +/* + *---------------------------------------------------------------------- + * + * TclUpdateReturnInfo -- + * + * This function is called when procedures return, and at other points + * where the TCL_RETURN code is used. It examines the returnLevel and + * returnCode to determine the real return status. + * + * Results: + * The return value is the true completion code to use for the procedure + * or script, instead of TCL_RETURN. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclUpdateReturnInfo( + Interp *iPtr) /* Interpreter for which TCL_RETURN exception + * is being processed. */ +{ + int code = TCL_RETURN; + + iPtr->returnLevel--; + if (iPtr->returnLevel < 0) { + Tcl_Panic("TclUpdateReturnInfo: negative return level"); + } + if (iPtr->returnLevel == 0) { + /* + * Now we've reached the level to return the requested -code. + */ + + code = iPtr->returnCode; + } + return code; +} + +/* + *---------------------------------------------------------------------- + * + * TclGetObjInterpProc -- + * + * Returns a pointer to the TclObjInterpProc function; this is different + * from the value obtained from the TclObjInterpProc reference on systems + * like Windows where import and export versions of a function exported + * by a DLL exist. + * + * Results: + * Returns the internal address of the TclObjInterpProc function. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +TclObjCmdProcType +TclGetObjInterpProc(void) +{ + return (TclObjCmdProcType) TclObjInterpProc; +} + +/* + *---------------------------------------------------------------------- + * + * TclNewProcBodyObj -- + * + * Creates a new object, of type "procbody", whose internal + * representation is the given Proc struct. The newly created object's + * reference count is 0. + * + * Results: + * Returns a pointer to a newly allocated Tcl_Obj, 0 on error. + * + * Side effects: + * The reference count in the ByteCode attached to the Proc is bumped up + * by one, since the internal rep stores a pointer to it. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclNewProcBodyObj( + Proc *procPtr) /* the Proc struct to store as the internal + * representation. */ +{ + Tcl_Obj *objPtr; + + if (!procPtr) { + return NULL; + } + + objPtr = Tcl_NewStringObj("", 0); + + if (objPtr) { + objPtr->typePtr = &tclProcBodyType; + objPtr->internalRep.otherValuePtr = (void *) procPtr; + + procPtr->refCount++; + } + + return objPtr; +} + +/* + *---------------------------------------------------------------------- + * + * ProcBodyDup -- + * + * Tcl_ObjType's Dup function for the proc body object. Bumps the + * reference count on the Proc stored in the internal representation. + * + * Results: + * None. + * + * Side effects: + * Sets up the object in dupPtr to be a duplicate of the one in srcPtr. + * + *---------------------------------------------------------------------- + */ + +static void +ProcBodyDup( + Tcl_Obj *srcPtr, /* object to copy */ + Tcl_Obj *dupPtr) /* target object for the duplication */ +{ + Proc *procPtr = (Proc *) srcPtr->internalRep.otherValuePtr; + + dupPtr->typePtr = &tclProcBodyType; + dupPtr->internalRep.otherValuePtr = (void *) procPtr; + procPtr->refCount++; +} + +/* + *---------------------------------------------------------------------- + * + * ProcBodyFree -- + * + * Tcl_ObjType's Free function for the proc body object. The reference + * count on its Proc struct is decreased by 1; if the count reaches 0, + * the proc is freed. + * + * Results: + * None. + * + * Side effects: + * If the reference count on the Proc struct reaches 0, the struct is + * freed. + * + *---------------------------------------------------------------------- + */ + +static void +ProcBodyFree( + Tcl_Obj *objPtr) /* the object to clean up */ +{ + Proc *procPtr = (Proc *) objPtr->internalRep.otherValuePtr; + procPtr->refCount--; + if (procPtr->refCount <= 0) { + TclProcCleanupProc(procPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileNoOp -- + * + * Function called to compile no-op's + * + * Results: + * The return value is TCL_OK, indicating successful compilation. + * + * Side effects: + * Instructions are added to envPtr to execute a no-op at runtime. + * + *---------------------------------------------------------------------- + */ + +static int +TclCompileNoOp( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + Tcl_Token *tokenPtr; + int i; + int savedStackDepth = envPtr->currStackDepth; + + tokenPtr = parsePtr->tokenPtr; + for(i = 1; i < parsePtr->numWords; i++) { + tokenPtr = tokenPtr + tokenPtr->numComponents + 1; + envPtr->currStackDepth = savedStackDepth; + + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + TclCompileTokens(interp, tokenPtr+1, tokenPtr->numComponents, + envPtr); + TclEmitOpcode(INST_POP, envPtr); + } + } + envPtr->currStackDepth = savedStackDepth; + TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr); + return TCL_OK; +} + +/* + * LAMBDA and APPLY implementation + */ + +static void +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; + + copyPtr->internalRep.twoPtrValue.ptr1 = procPtr; + copyPtr->internalRep.twoPtrValue.ptr2 = nsObjPtr; + + procPtr->refCount++; + Tcl_IncrRefCount(nsObjPtr); + copyPtr->typePtr = &lambdaType; +} + +static void +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; + + procPtr->refCount--; + if (procPtr->refCount == 0) { + TclProcCleanupProc(procPtr); + } + TclDecrRefCount(nsObjPtr); +} + +static int +SetLambdaFromAny( + Tcl_Interp *interp, /* Used for error reporting if not NULL. */ + register Tcl_Obj *objPtr) /* The object to convert. */ +{ + char *name; + Tcl_Obj *argsPtr, *bodyPtr, *nsObjPtr, **objv, *errPtr; + int objc; + Proc *procPtr; + int result; + + /* + * Convert objPtr to list type first; if it cannot be + * converted, or if its length is not 2, then it cannot + * be converted to lambdaType. + */ + + result = Tcl_ListObjGetElements(interp, objPtr, &objc, &objv); + if ((result != TCL_OK) || ((objc != 2) && (objc != 3))) { + errPtr = Tcl_NewStringObj("can't interpret \"",-1); + Tcl_AppendObjToObj(errPtr, objPtr); + Tcl_AppendToObj(errPtr, "\" as a lambda expression", -1); + Tcl_SetObjResult(interp, errPtr); + return TCL_ERROR; + } + + argsPtr = objv[0]; + bodyPtr = objv[1]; + + /* + * Create and initialize the Proc struct. The cmdPtr field is + * set to NULL to signal that this is an anonymous function. + */ + + name = TclGetString(objPtr); + + if (TclCreateProc(interp, /*ignored nsPtr*/ NULL, name, argsPtr, + bodyPtr, &procPtr) != TCL_OK) { + TclFormatToErrorInfo(interp, + "\n (parsing lambda expression \"%s\")", + TclGetString(objPtr), NULL); + return TCL_ERROR; + } + procPtr->refCount++; + procPtr->cmdPtr = (Command *) NULL; + + /* + * Set the namespace for this lambda: given by objv[2] understood + * as a global reference, or else global per default. + */ + + if (objc == 2) { + nsObjPtr = Tcl_NewStringObj("::", 2); + } else { + char *nsName = Tcl_GetString(objv[2]); + if ((*nsName != ':') || (*(nsName+1) != ':')) { + nsObjPtr = Tcl_NewStringObj("::", 2); + Tcl_AppendObjToObj(nsObjPtr, objv[2]); + } else { + nsObjPtr = objv[2]; + } + } + + Tcl_IncrRefCount(nsObjPtr); + + /* + * Free the list internalrep of objPtr - this will free argsPtr, but + * bodyPtr retains a reference from the Proc structure. Then finish + * the conversion to lambdaType. + */ + + objPtr->typePtr->freeIntRepProc(objPtr); + + objPtr->internalRep.twoPtrValue.ptr1 = procPtr; + objPtr->internalRep.twoPtrValue.ptr2 = 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. */ +{ + Interp *iPtr = (Interp *) interp; + Proc *procPtr = NULL; + Tcl_Obj *lambdaPtr, *nsObjPtr, *errPtr; + int result; + Command cmd; + Tcl_Namespace *nsPtr; + +#define JOE_EXTENSION 0 +#if JOE_EXTENSION + int numElem; +#endif + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "lambdaExpr ?arg1 arg2 ...?"); + return TCL_ERROR; + } + + /* + * Set lambdaPtr, convert it to lambdaType in the current interp if + * necessary. + */ + + lambdaPtr = objv[1]; + if (lambdaPtr->typePtr == &lambdaType) { + procPtr = lambdaPtr->internalRep.twoPtrValue.ptr1; + } +#if JOE_EXTENSION + /* + * Joe English's suggestion to allow cmdNames to function as lambdas. + * Requires also making tclCmdNameType non-static in tclObj.c + */ + else if ((lambdaPtr->typePtr == &tclCmdNameType) || + (Tcl_ListObjLength(interp, lambdaPtr, &numElem) == TCL_OK && + (numElem == 1))) { + return Tcl_EvalObjv(interp, objc-1, objv+1, 0); + } +#endif + + if ((procPtr == NULL) || (procPtr->iPtr != iPtr)) { + result = SetLambdaFromAny(interp, lambdaPtr); + if (result != TCL_OK) { + return result; + } + procPtr = lambdaPtr->internalRep.twoPtrValue.ptr1; + } + procPtr->cmdPtr = &cmd; + + /* + * Find the namespace where this lambda should run, and push a call frame + * for that namespace. Note that TclObjInterpProc() will pop it. + */ + + nsObjPtr = lambdaPtr->internalRep.twoPtrValue.ptr2; + result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr); + if (result != TCL_OK) { + return result; + } + + if (nsPtr == (Tcl_Namespace *) NULL) { + errPtr = Tcl_NewStringObj("cannot find namespace \"",-1); + Tcl_AppendObjToObj(errPtr, nsObjPtr); + Tcl_AppendToObj(errPtr, "\"", -1); + Tcl_SetObjResult(interp, errPtr); + return TCL_ERROR; + } + + cmd.nsPtr = (Namespace *) nsPtr; + + return ObjInterpProcEx((ClientData) procPtr, interp, objc, objv, 2); +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ Index: generic/tclVar.c ================================================================== --- generic/tclVar.c +++ generic/tclVar.c @@ -13,11 +13,11 @@ * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. * * 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.118 2006/02/01 17:48:11 dgp Exp $ + * RCS: @(#) $Id: tclVar.c,v 1.118.2.2 2006/08/24 02:54:36 dgp Exp $ */ #include "tclInt.h" /* @@ -36,10 +36,18 @@ static CONST char *badNamespace = "parent namespace doesn't exist"; static CONST char *missingName = "missing variable name"; 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: */ static void DeleteSearches(Var *arrayVarPtr); @@ -397,11 +405,11 @@ if (typePtr == &localVarNameType) { int localIndex = (int) part1Ptr->internalRep.longValue; if ((varFramePtr != NULL) - && (varFramePtr->isProcCallFrame & FRAME_IS_PROC) + && IsLocal(varFramePtr) && !(flags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY)) && (localIndex < varFramePtr->numCompiledLocals)) { /* * use the cached index if the names coincide. */ @@ -421,17 +429,16 @@ useGlobal = (cachedNsPtr == iPtr->globalNsPtr) && ( (flags & TCL_GLOBAL_ONLY) || (*part1==':' && *(part1+1)==':') || (varFramePtr == NULL) || - (!(varFramePtr->isProcCallFrame & FRAME_IS_PROC) - && (nsPtr == iPtr->globalNsPtr))); + (!IsLocal(varFramePtr) && (nsPtr == iPtr->globalNsPtr))); useReference = useGlobal || ((cachedNsPtr == nsPtr) && ( (flags & TCL_NAMESPACE_ONLY) || (varFramePtr && - !(varFramePtr->isProcCallFrame & FRAME_IS_PROC) && + !IsLocal(varFramePtr) && !(flags & TCL_GLOBAL_ONLY) && /* * Careful: an undefined ns variable could be hiding a valid * global reference. */ @@ -743,11 +750,11 @@ * necessary, create varFramePtr's local var hashtable. */ if (((flags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY)) != 0) || (varFramePtr == NULL) - || !(varFramePtr->isProcCallFrame & FRAME_IS_PROC) + || !IsLocal(varFramePtr) || (strstr(varName, "::") != NULL)) { CONST char *tail; int lookGlobal; lookGlobal = (flags & TCL_GLOBAL_ONLY) @@ -3236,11 +3243,11 @@ if (index < 0) { if (((otherP2 ? arrayPtr->nsPtr : otherPtr->nsPtr) == NULL) && ((myFlags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY)) || (varFramePtr == NULL) - || !(varFramePtr->isProcCallFrame & FRAME_IS_PROC) + || !IsLocal(varFramePtr) || (strstr(myName, "::") != NULL))) { Tcl_AppendResult((Tcl_Interp *) iPtr, "bad variable name \"", myName, "\": upvar won't create namespace variable that ", "refers to procedure variable", NULL); return TCL_ERROR; @@ -3268,11 +3275,11 @@ * given by otherP1 and otherP2, so that references to myName are * redirected to the other variable like a symbolic link. * *---------------------------------------------------------------------- */ - + int TclPtrMakeUpvar(interp, otherPtr, myName, myFlags, index) Tcl_Interp *interp; /* Interpreter containing variables. Used for * error messages, too. */ Var *otherPtr; /* Pointer to the variable being linked-to */ @@ -3285,14 +3292,14 @@ { Interp *iPtr = (Interp *) interp; CallFrame *varFramePtr = iPtr->varFramePtr; Var *varPtr; CONST char *errMsg; - CONST char *p; - + CONST char *p; + if (index >= 0) { - if (!(varFramePtr->isProcCallFrame & FRAME_IS_PROC)) { + if (!IsLocal(varFramePtr)) { Tcl_Panic("ObjMakeUpvar called with an index outside from a proc.\n"); } varPtr = &(varFramePtr->compiledLocals[index]); } else { /* @@ -3551,12 +3558,11 @@ /* * If we are not executing inside a Tcl procedure, just return. */ - if ((iPtr->varFramePtr == NULL) - || !(iPtr->varFramePtr->isProcCallFrame & FRAME_IS_PROC)) { + if ((iPtr->varFramePtr == NULL) || !IsLocal(iPtr->varFramePtr)) { return TCL_OK; } for (i=1 ; ivarFramePtr != NULL) - && (iPtr->varFramePtr->isProcCallFrame & FRAME_IS_PROC)) { + if ((iPtr->varFramePtr != NULL) && IsLocal(iPtr->varFramePtr)) { /* * varName might have a scope qualifier, but the name for the * local "link" variable must be the simple name at the tail. * * Locate tail in one pass: drop any prefix after two *or more* Index: tests/info.test ================================================================== --- tests/info.test +++ tests/info.test @@ -9,11 +9,11 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: info.test,v 1.34 2005/10/10 21:50:01 dkf Exp $ +# RCS: @(#) $Id: info.test,v 1.34.2.1 2006/08/30 15:35:16 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } @@ -645,20 +645,24 @@ test info-21.1 {miscellaneous error conditions} { list [catch {info} msg] $msg } {1 {wrong # args: should be "info option ?arg arg ...?"}} test info-21.2 {miscellaneous error conditions} { list [catch {info gorp} msg] $msg -} {1 {bad option "gorp": must be args, body, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}} +} {1 {bad option "gorp": must be args, body, class, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars}} test info-21.3 {miscellaneous error conditions} { list [catch {info c} msg] $msg -} {1 {ambiguous option "c": must be args, body, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}} +} {1 {ambiguous option "c": must be args, body, class, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars}} test info-21.4 {miscellaneous error conditions} { list [catch {info l} msg] $msg -} {1 {ambiguous option "l": must be args, body, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}} +} {1 {ambiguous option "l": must be args, body, class, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars}} test info-21.5 {miscellaneous error conditions} { list [catch {info s} msg] $msg -} {1 {ambiguous option "s": must be args, body, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}} +} {1 {ambiguous option "s": must be args, body, class, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars}} # cleanup catch {namespace delete test_ns_info1 test_ns_info2} ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# End: ADDED tests/oo.test Index: tests/oo.test ================================================================== --- /dev/null +++ tests/oo.test @@ -0,0 +1,1245 @@ +# This file contains a collection of tests for Tcl's built-in object system. +# Sourcing this file into Tcl runs the tests and generates output for errors. +# No output means no errors were found. +# +# Copyright (c) 2006 Donal K. Fellows +# +# See the file "license.terms" for information on usage and redistribution of +# this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: oo.test,v 1.1.2.40 2006/10/22 00:26:31 dkf Exp $ + +if {[lsearch [namespace children] ::tcltest] == -1} { + package require tcltest 2 + namespace import -force ::tcltest::* +} + +testConstraint memory [llength [info commands memory]] + +test oo-0.1 {basic test of OO's ability to clean up its initial state} { + interp create t + interp delete t +} {} +test oo-0.2 {basic test of OO's ability to clean up its initial state} { + interp eval [interp create] { namespace delete :: } +} {} +test oo-0.3 {basic test of OO's ability to clean up its initial state} -setup { + proc getbytes {} { + set lines [split [memory info] "\n"] + lindex $lines 3 3 + } +} -constraints memory -body { + set end [getbytes] + for {set i 0} {$i < 5} {incr i} { + [oo::object new] destroy + set tmp $end + set end [getbytes] + } + set leakedBytes [expr {$end - $tmp}] +} -cleanup { + rename getbytes {} +} -result 0 +test oo-0.4 {basic test of OO's ability to clean up its initial state} -setup { + proc getbytes {} { + set lines [split [memory info] "\n"] + lindex $lines 3 3 + } +} -constraints memory -body { + set end [getbytes] + for {set i 0} {$i < 5} {incr i} { + oo::class create foo + foo new + foo destroy + set tmp $end + set end [getbytes] + } + set leakedBytes [expr {$end - $tmp}] +} -cleanup { + rename getbytes {} +} -result 0 + +test oo-1.1 {basic test of OO functionality: no classes} { + set result {} + lappend result [oo::object create foo] + lappend result [oo::define foo { + method bar args { + global result + lappend result {expand}$args + return [llength $args] + } + }] + lappend result [foo bar a b c] + lappend result [foo destroy] [info commands foo] +} {::foo {} a b c 3 {} {}} +test oo-1.2 {basic test of OO functionality: no classes} -body { + oo::define oo::object method missingArgs +} -returnCodes 1 -result "wrong # args: should be \"oo::define oo::object method name args body\"" +test oo-1.3 {basic test of OO functionality: no classes} { + catch {oo::define oo::object method missingArgs} + set errorInfo +} "wrong # args: should be \"oo::define oo::object method name args body\" + while executing +\"oo::define oo::object method missingArgs\"" +test oo-1.4 {basic test of OO functionality} -body { + oo::object create {} +} -returnCodes 1 -result {object name must not be empty} +test oo-1.5 {basic test of OO functionality} -body { + oo::object doesnotexist +} -returnCodes 1 -result {unknown method "doesnotexist": must be create, destroy or new} +test oo-1.6 {basic test of OO functionality} -setup { + oo::object create aninstance +} -body { + oo::define aninstance unexport destroy + aninstance doesnotexist +} -cleanup { + rename aninstance {} +} -returnCodes 1 -result {object "::aninstance" has no visible methods} + +test oo-2.1 {basic test of OO functionality: constructor} -setup { + # This is a bit complex because it needs to run in a sub-interp as + # we're modifying the root object class's constructor + interp create subinterp +} -body { + subinterp eval { + oo::define oo::object constructor {} { + lappend ::result [info level 0] + } + lappend result 1 + lappend result 2 [oo::object create foo] + } +} -cleanup { + interp delete subinterp +} -result {1 {oo::object create foo} 2 ::foo} +test oo-2.2 {basic test of OO functionality: constructor} { + oo::class create testClass { + constructor {} { + global result + lappend result "[self]->construct" + } + method bar {} { + global result + lappend result "[self]->bar" + } + } + set result {} + [testClass create foo] bar + testClass destroy + return $result +} {::foo->construct ::foo->bar} + +test oo-3.1 {basic test of OO functionality: destructor} -setup { + # This is a bit complex because it needs to run in a sub-interp as + # we're modifying the root object class's constructor + interp create subinterp +} -body { + subinterp eval { + oo::define oo::object destructor { + lappend ::result died + } + lappend result 1 [oo::object create foo] + lappend result 2 [rename foo {}] + oo::define oo::object destructor {} + return $result + } +} -cleanup { + interp delete subinterp +} -result {1 ::foo died 2 {}} +test oo-3.2 {basic test of OO functionality: destructor} -setup { + # This is a bit complex because it needs to run in a sub-interp as + # we're modifying the root object class's constructor + interp create subinterp +} -body { + subinterp eval { + oo::define oo::object destructor { + lappend ::result died + } + lappend result 1 [oo::object create foo] + lappend result 2 [rename foo {}] + } +} -cleanup { + interp delete subinterp +} -result {1 ::foo died 2 {}} + +test oo-4.1 {basic test of OO functionality: export} { + set o [oo::object new] + set result {} + oo::define $o method Foo {} {lappend ::result Foo; return} + lappend result [catch {$o Foo} msg] $msg + oo::define $o export Foo + lappend result [$o Foo] [$o destroy] +} {1 {unknown method "Foo": must be destroy} Foo {} {}} +test oo-4.2 {basic test of OO functionality: unexport} { + set o [oo::object new] + set result {} + oo::define $o method foo {} {lappend ::result foo; return} + lappend result [$o foo] + oo::define $o unexport foo + lappend result [catch {$o foo} msg] $msg [$o destroy] +} {foo {} 1 {unknown method "foo": must be destroy} {}} + +test oo-5.1 {OO: manipulation of classes as objects} -setup { + set obj [oo::object new] +} -body { + oo::define oo::object self.method foo {} { return "in object" } + catch {$obj foo} result + list [catch {$obj foo} result] $result [oo::object foo] +} -cleanup { + oo::define oo::object self.method foo {} {} + $obj destroy +} -result {1 {unknown method "foo": must be destroy} {in object}} + +test oo-6.1 {OO: forward} { + oo::object create foo + oo::define foo { + forward a lappend + forward b lappend result + } + set result {} + foo a result 1 + foo b 2 + foo destroy + return $result +} {1 2} + +test oo-7.1 {OO: inheritance 101} -setup { + oo::class create superClass + oo::class create subClass + subClass create instance +} -body { + oo::define superClass method doit x {lappend ::result $x} + oo::define subClass superclass superClass + set result [list [catch {subClass doit bad} msg] $msg] + instance doit ok + return $result +} -cleanup { + subClass destroy + superClass destroy +} -result {1 {unknown method "doit": must be create, destroy or new} ok} +test oo-7.2 {OO: inheritance 101} -setup { + oo::class create superClass + oo::class create subClass + subClass create instance +} -body { + oo::define superClass method doit x {lappend ::result |$x|} + oo::define subClass superclass superClass + oo::define instance method doit x {lappend ::result =$x=; next [incr x]} + set result {} + instance doit 1 + return $result +} -cleanup { + subClass destroy + superClass destroy +} -result {=1= |2|} +test oo-7.3 {OO: inheritance 101} -setup { + oo::class create superClass + oo::class create subClass + subClass create instance +} -body { + oo::define superClass method doit x {lappend ::result |$x|} + oo::define subClass { + superclass superClass + method doit x {lappend ::result -$x-; next [incr x]} + } + oo::define instance method doit x {lappend ::result =$x=; next [incr x]} + set result {} + instance doit 1 + return $result +} -cleanup { + subClass destroy + superClass destroy +} -result {=1= -2- |3|} +test oo-7.4 {OO: inheritance from oo::class} -body { + oo::class create meta + oo::define meta { + superclass oo::class + self.unexport create new + self.method make {x {definitions {}}} { + if {![string match ::* $x]} { + set ns [uplevel 1 {::namespace current}] + set x ${ns}::$x + } + set o [my create $x] + lappend ::result "made $o" + oo::define $o $definitions + return $o + } + } + set result [list [catch {meta create foo} msg] $msg] + lappend result [meta make classinstance { + lappend ::result "in definition script in [namespace current]" + }] + lappend result [classinstance create instance] +} -cleanup { + catch {classinstance destroy} + catch {meta destroy} +} -result {1 {unknown method "create": must be destroy or make} {made ::classinstance} {in definition script in ::oo::define} ::classinstance ::instance} +test oo-7.5 {OO: inheritance from oo::class in the secondary chain} -body { + oo::class create other + oo::class create meta + oo::define meta { + superclass other oo::class + self.unexport create new + self.method make {x {definitions {}}} { + if {![string match ::* $x]} { + set ns [uplevel 1 {::namespace current}] + set x ${ns}::$x + } + set o [my create $x] + lappend ::result "made $o" + oo::define $o $definitions + return $o + } + } + set result [list [catch {meta create foo} msg] $msg] + lappend result [meta make classinstance { + lappend ::result "in definition script in [namespace current]" + }] + lappend result [classinstance create instance] +} -cleanup { + catch {classinstance destroy} + catch {meta destroy} + catch {other destroy} +} -result {1 {unknown method "create": must be destroy or make} {made ::classinstance} {in definition script in ::oo::define} ::classinstance ::instance} +test oo-7.6 {OO: inheritance 101 - overridden methods should be oblivious} -setup { + oo::class create Aclass + oo::class create Bclass + Bclass create Binstance +} -body { + oo::define Aclass { + method incr {var step} { + upvar 1 $var v + ::incr v $step + } + } + oo::define Bclass { + superclass Aclass + method incr {var {step 1}} { + global result + lappend result $var $step + set r [next $var $step] + lappend result returning:$r + return $r + } + } + set result {} + set x 10 + lappend result x=$x + lappend result [Binstance incr x] + lappend result x=$x +} -result {x=10 x 1 returning:11 11 x=11} -cleanup { + Aclass destroy +} +test oo-7.7 {OO: inheritance and errorInfo} -setup { + oo::class create A + oo::class create B + B create c +} -body { + oo::define A method foo {} {error foo!} + oo::define B { + superclass A + method foo {} { next } + } + oo::define c method foo {} { next } + catch {c ?} msg + set result [list $msg] + catch {c foo} msg + lappend result $msg $errorInfo +} -cleanup { + A destroy +} -result {{unknown method "?": must be destroy or foo} foo! {foo! + while executing +"error foo!" + (class "::A" method "foo" line 1) + invoked from within +"next " + (class "::B" method "foo" line 1) + invoked from within +"next " + (object "::c" method "foo" line 1) + invoked from within +"c foo"}} + +test oo-8.1 {OO: global must work in methods} { + oo::object create foo + oo::define foo method bar x {global result; lappend result $x} + set result {} + foo bar this + foo bar is + lappend result a + foo bar test + foo destroy + return $result +} {this is a test} + +test oo-9.1 {OO: multiple inheritance} -setup { + oo::class create A + oo::class create B + oo::class create C + oo::class create D + D create foo +} -body { + oo::define A method test {} {lappend ::result A; return ok} + oo::define B { + superclass A + method test {} {lappend ::result B; next} + } + oo::define C { + superclass A + method test {} {lappend ::result C; next} + } + oo::define D { + superclass B C + method test {} {lappend ::result D; next} + } + set result {} + lappend result [foo test] +} -cleanup { + D destroy + C destroy + B destroy + A destroy +} -result {D B C A ok} +test oo-9.2 {OO: multiple inheritance} -setup { + oo::class create A + oo::class create B + oo::class create C + oo::class create D + D create foo +} -body { + oo::define A method test {} {lappend ::result A; return ok} + oo::define B { + superclass A + method test {} {lappend ::result B; next} + } + oo::define C { + superclass A + method test {} {lappend ::result C; next} + } + oo::define D { + superclass B C + method test {} {lappend ::result D; next} + } + set result {} + lappend result [foo test] +} -cleanup { + A destroy +} -result {D B C A ok} + +test oo-10.1 {OO: recursive invoke and modify} -setup { + [oo::class create C] create O +} -cleanup { + C destroy +} -body { + oo::define C method foo x { + lappend ::result $x + if {$x} { + [self object] foo [incr x -1] + } + } + oo::define O method foo x { + lappend ::result -$x- + if {$x == 1} { + # delete the method + oo::define O method foo {} {} + } + next $x + } + set result {} + O foo 2 + return $result +} -result {-2- 2 -1- 1 0} + +test oo-11.1 {OO: cleanup} { + oo::object create foo + set result [list [catch {oo::object create foo} msg] $msg] + lappend result [foo destroy] [oo::object create foo] [foo destroy] +} {1 {can't create object "foo": command already exists with that name} {} ::foo {}} +test oo-11.2 {OO: cleanup} { + oo::class create bar + bar create foo + set result [list [catch {bar create foo} msg] $msg] + lappend result [bar destroy] [oo::object create foo] [foo destroy] +} {1 {can't create object "foo": command already exists with that name} {} ::foo {}} +test oo-11.3 {OO: cleanup} { + oo::class create bar0 + oo::class create bar + oo::define bar superclass bar0 + bar create foo + set result [list [catch {bar create foo} msg] $msg] + lappend result [bar0 destroy] [oo::object create foo] [foo destroy] +} {1 {can't create object "foo": command already exists with that name} {} ::foo {}} +test oo-11.4 {OO: cleanup} { + oo::class create bar0 + oo::class create bar1 + oo::define bar1 superclass bar0 + oo::class create bar2 + oo::define bar2 { + superclass bar0 + destructor {lappend ::result destroyed} + } + oo::class create bar + oo::define bar superclass bar1 bar2 + bar create foo + set result [list [catch {bar create foo} msg] $msg] + lappend result [bar0 destroy] [oo::object create foo] [foo destroy] \ + [oo::object create bar2] [bar2 destroy] +} {1 {can't create object "foo": command already exists with that name} destroyed {} ::foo {} ::bar2 {}} + +test oo-12.1 {OO: filters} { + oo::class create Aclass + Aclass create Aobject + oo::define Aclass { + method concatenate args { + global result + lappend result {expand}$args + join $args {} + } + method logFilter args { + global result + lappend result "calling [self object]->[self method] $args" + set r [next {expand}$args] + lappend result "result=$r" + return $r + } + } + oo::define Aobject filter logFilter + set result {} + lappend result [Aobject concatenate 1 2 3 4 5] + Aclass destroy + return $result +} {{calling ::Aobject->logFilter 1 2 3 4 5} 1 2 3 4 5 result=12345 12345} +test oo-12.2 {OO: filters} -setup { + oo::class create Aclass + Aclass create Aobject +} -body { + oo::define Aclass { + method concatenate args { + global result + lappend result {expand}$args + join $args {} + } + method logFilter args { + global result + lappend result "calling [self object]->[self method] $args" + set r [next {expand}$args] + lappend result "result=$r" + return $r + } + } + oo::define Aobject filter logFilter + set result {} + lappend result [Aobject concatenate 1 2 3 4 5] [Aobject destroy] +} -cleanup { + Aclass destroy +} -result {{calling ::Aobject->logFilter 1 2 3 4 5} 1 2 3 4 5 result=12345 {calling ::Aobject->logFilter } result= 12345 {}} +test oo-12.3 {OO: filters} -setup { + oo::class create Aclass + Aclass create Aobject +} -body { + oo::define Aclass { + method concatenate args { + global result + lappend result {expand}$args + join $args {} + } + method logFilter args { + global result + lappend result "calling [self object]->[self method] $args" + set r [next {expand}$args] + lappend result "result=$r" + return $r + } + filter logFilter + } + set result {} + lappend result [Aobject concatenate 1 2 3 4 5] [Aobject destroy] +} -cleanup { + Aclass destroy +} -result {{calling ::Aobject->logFilter 1 2 3 4 5} 1 2 3 4 5 result=12345 {calling ::Aobject->logFilter } result= 12345 {}} +test oo-12.4 {OO: filters} -setup { + oo::class create Aclass + Aclass create Aobject +} -body { + oo::define Aclass { + method foo {} { return foo } + method Bar {} { return 1 } + method boo {} { if {[my Bar]} { next } { error forbidden } } + filter boo + } + Aobject foo +} -cleanup { + Aclass destroy +} -result foo +test oo-12.5 {OO: filters} -setup { + oo::class create Aclass + Aclass create Aobject +} -body { + oo::define Aclass { + method foo {} { return foo } + method Bar {} { return [my Bar2] } + method Bar2 {} { return 1 } + method boo {} { if {[my Bar]} { next } { error forbidden } } + filter boo + } + Aobject foo +} -cleanup { + Aclass destroy +} -result foo +test oo-12.6 {OO: filters} -setup { + oo::class create Aclass + Aclass create Aobject +} -body { + oo::define Aclass { + method foo {} { return foo } + method Bar {} { return [my Bar2] } + method Bar2 {} { return [my Bar3] } + method Bar3 {} { return 1 } + method boo {} { if {[my Bar]} { next } { error forbidden } } + filter boo + } + Aobject foo +} -cleanup { + Aclass destroy +} -result foo +test oo-12.7 {OO: filters} -setup { + oo::class create Aclass + Aclass create Aobject +} -body { + oo::define Aclass { + method outerfoo {} { return [my InnerFoo] } + method InnerFoo {} { return foo } + method Bar {} { return [my Bar2] } + method Bar2 {} { return [my Bar3] } + method Bar3 {} { return 1 } + method boo {} { + lappend ::log [self target] + if {[my Bar]} { next } else { error forbidden } + } + filter boo + } + set log {} + list [Aobject outerfoo] $log +} -cleanup { + Aclass destroy +} -result {foo {{::Aclass outerfoo} {::Aclass InnerFoo}}} + +test oo-13.1 {OO: changing an object's class} { + oo::class create Aclass + oo::define Aclass {method bar {} {lappend ::result "in A [self object]"}} + oo::class create Bclass + oo::define Bclass {method bar {} {lappend ::result "in B [self object]"}} + set result [Aclass create foo] + foo bar + oo::define foo self.class Bclass + foo bar + Aclass destroy + lappend result [info command foo] + Bclass destroy + return $result +} {::foo {in A ::foo} {in B ::foo} foo} +test oo-13.2 {OO: changing an object's class} -body { + oo::object create foo + oo::define foo self.class oo::class +} -cleanup { + foo destroy +} -returnCodes 1 -result {may not change a non-class object into a class object} +test oo-13.3 {OO: changing an object's class} -body { + oo::class create foo + oo::define foo self.class oo::object +} -cleanup { + foo destroy +} -returnCodes 1 -result {may not change a class object into a non-class object} +# todo: changing a class subtype (metaclass) to another class subtype + +test oo-14.1 {OO: mixins} { + oo::class create Aclass + oo::define Aclass method bar {} {lappend ::result "[self object] in bar"} + oo::class create Bclass + oo::define Bclass method boo {} {lappend ::result "[self object] in boo"} + oo::define [Aclass create fooTest] mixin Bclass + oo::define [Aclass create fooTest2] mixin Bclass + set result [list [catch {fooTest ?} msg] $msg] + fooTest bar + fooTest boo + fooTest2 bar + fooTest2 boo + oo::define fooTest2 mixin + lappend result [Bclass destroy] [info command fooTest*] [Aclass destroy] +} {1 {unknown method "?": must be bar, boo or destroy} {::fooTest in bar} {::fooTest in boo} {::fooTest2 in bar} {::fooTest2 in boo} {} fooTest2 {}} +test oo-14.2 {OO: mixins} { + oo::class create Aclass { + method bar {} {return "[self object] in bar"} + } + oo::class create Bclass { + method boo {} {return "[self object] in boo"} + } + oo::define Aclass mixin Bclass + Aclass create fooTest + set result [list [catch {fooTest ?} msg] $msg] + lappend result [catch {fooTest bar} msg] $msg + lappend result [catch {fooTest boo} msg] $msg + lappend result [Bclass destroy] [info commands Aclass] +} {1 {unknown method "?": must be bar, boo or destroy} 0 {::fooTest in bar} 0 {::fooTest in boo} {} {}} + +test oo-15.1 {OO: object cloning} { + oo::class create Aclass + oo::define Aclass method test {} {lappend ::result [self object]->test} + Aclass create Ainstance + set result {} + Ainstance test + oo::copy Ainstance Binstance + Binstance test + Ainstance test + Ainstance destroy + namespace eval foo { + oo::copy Binstance Cinstance + Cinstance test + } + Aclass destroy + namespace delete foo + lappend result [info commands Binstance] +} {::Ainstance->test ::Binstance->test ::Ainstance->test ::foo::Cinstance->test {}} +test oo-15.2 {OO: object cloning} { + oo::object create foo + oo::define foo { + method m x {lappend ::result [self object] >$x<} + forward f ::lappend ::result fwd + } + set result {} + foo m 1 + foo f 2 + lappend result [oo::copy foo bar] + foo m 3 + foo f 4 + bar m 5 + bar f 6 + lappend result [foo destroy] + bar m 7 + bar f 8 + lappend result [bar destroy] +} {::foo >1< fwd 2 ::bar ::foo >3< fwd 4 ::bar >5< fwd 6 {} ::bar >7< fwd 8 {}} +catch {foo destroy} +catch {bar destroy} +test oo-15.3 {OO: class cloning} { + oo::class create foo { + method testme {} {lappend ::result [self class]->[self object]} + } + set result {} + foo create baseline + baseline testme + oo::copy foo bar + baseline testme + bar create tester + tester testme + foo destroy + tester testme + bar destroy + return $result +} {::foo->::baseline ::foo->::baseline ::bar->::tester ::bar->::tester} + +test oo-16.1 {OO: object introspection} -body { + info object +} -returnCodes 1 -result "wrong \# args: should be \"info object subcommand ?argument ...?\"" +test oo-16.2 {OO: object introspection} -body { + info object class NOTANOBJECT +} -returnCodes 1 -result {NOTANOBJECT does not refer to an object} +test oo-16.3 {OO: object introspection} -body { + info object gorp oo::object +} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be class, definition, filters, forward, isa, methods, mixins, or vars} +test oo-16.4 {OO: object introspection} -setup { + oo::class create meta { superclass oo::class } +} -body { + list [info object class oo::object] \ + [info object class oo::class] \ + [info object isa class oo::object] \ + [info object isa metaclass oo::object] \ + [info object isa metaclass meta] \ + [info object isa object oo::object] \ + [info object isa object oo::define] \ + [info object isa object NOTANOBJECT] +} -cleanup { + meta destroy +} -result {::oo::class ::oo::class 1 0 1 1 0 0} +test oo-16.5 {OO: object introspection} {info object methods oo::object} {} +test oo-16.6 {OO: object introspection} { + oo::object create foo + set result [list [info object methods foo]] + oo::define foo method bar {} {...} + lappend result [info object methods foo] [foo destroy] +} {{} bar {}} +test oo-16.7 {OO: object introspection} -setup { + oo::object create foo +} -body { + oo::define foo method bar {a {b c} args} {the body} + set result [info object methods foo] + lappend result [info object definition foo bar] +} -cleanup { + foo destroy +} -result {bar {{a {b c} args} {the body}}} +test oo-16.8 {OO: object introspection} { + oo::object create foo + oo::class create bar + oo::define foo mixin bar + set result [list [info object mixins foo] \ + [info object isa mixin foo bar] \ + [info object isa mixin foo oo::class]] + foo destroy + bar destroy + return $result +} {::bar 1 0} +test oo-16.9 {OO: object introspection} { + oo::class create Ac + oo::class create Bc; oo::define Bc superclass Ac + oo::class create Cc; oo::define Cc superclass Bc + Cc create D + list [info object isa typeof D oo::class] \ + [info object isa typeof D Ac] \ + [Ac destroy] +} {0 1 {}} +test oo-16.10 {OO: object introspection} -setup { + oo::object create foo +} -body { + oo::define foo export eval + foo eval {variable c 3 a 1 b 2 ddd 4 e} + lsort [info object vars foo ?] +} -cleanup { + foo destroy +} -result {a b c} + +test oo-17.1 {OO: class introspection} -body { + info class +} -returnCodes 1 -result "wrong \# args: should be \"info class subcommand ?argument ...?\"" +test oo-17.2 {OO: class introspection} -body { + info class superclass NOTANOBJECT +} -returnCodes 1 -result {NOTANOBJECT does not refer to an object} +test oo-17.3 {OO: class introspection} -setup { + oo::object create foo +} -body { + info class superclass foo +} -returnCodes 1 -cleanup { + foo destroy +} -result {"foo" is not a class} +test oo-17.4 {OO: class introspection} -body { + info class gorp oo::object +} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be constructor, definition, destructor, filters, forward, instances, methods, mixins, subclasses, or superclasses} +test oo-17.5 {OO: class introspection} -setup { + oo::class create testClass +} -body { + testClass create foo + testClass create bar + testClass create spong + lsort [info class instances testClass] +} -cleanup { + testClass destroy +} -result {::bar ::foo ::spong} +test oo-17.6 {OO: object introspection} -setup { + oo::class create foo +} -body { + oo::define foo method bar {a {b c} args} {the body} + set result [info class methods foo] + lappend result [info class definition foo bar] +} -cleanup { + foo destroy +} -result {bar {{a {b c} args} {the body}}} +test oo-17.7 {OO: object introspection} { + info class superclasses oo::class +} ::oo::object +test oo-17.8 {OO: object introspection} -setup { + oo::class create testClass + oo::class create superClass1 + oo::class create superClass2 +} -body { + oo::define testClass superclass superClass1 superClass2 + list [info class superclasses testClass] \ + [lsort [info class subclass oo::object ::superClass?]] +} -cleanup { + testClass destroy + superClass1 destroy + superClass2 destroy +} -result {{::superClass1 ::superClass2} {::superClass1 ::superClass2}} + +test oo-18.1 {OO: define command support} { + list [catch {oo::define oo::object {error foo}} msg] $msg $errorInfo +} {1 foo {foo + while executing +"error foo" + (in definition script for object "oo::object" line 1) + invoked from within +"oo::define oo::object {error foo}"}} +test oo-18.2 {OO: define command support} { + list [catch {oo::define oo::object error foo} msg] $msg $errorInfo +} {1 foo {foo + while executing +"oo::define oo::object error foo"}} +test oo-18.3 {OO: define command support} { + list [catch {oo::class create foo {error bar}} msg] $msg $errorInfo +} {1 bar {bar + while executing +"error bar" + (in definition script for object "::foo" line 1) + invoked from within +"oo::class create foo {error bar}"}} +test oo-18.4 {OO: more error traces from the guts} -setup { + oo::object create obj +} -body { + oo::define obj method bar {} {my eval {error foo}} + list [catch {obj bar} msg] $msg $errorInfo +} -cleanup { + obj destroy +} -result {1 foo {foo + while executing +"error foo" + (in "my eval" script line 1) + invoked from within +"my eval {error foo}" + (object "::obj" method "bar" line 1) + invoked from within +"obj bar"}} +test oo-18.5 {OO: more error traces from the guts} -setup { + [oo::class create cls] create obj + set errorInfo {} +} -body { + oo::define cls { + method eval script {next $script} + export eval + } + oo::define obj method bar {} {my eval {error foo}} + set result {} + lappend result [catch {obj bar} msg] $msg $errorInfo + lappend result [catch {obj eval {error bar}} msg] $msg $errorInfo +} -cleanup { + cls destroy +} -result {1 foo {foo + while executing +"error foo" + (in "my eval" script line 1) + invoked from within +"next $script" + (class "::cls" method "eval" line 1) + invoked from within +"my eval {error foo}" + (object "::obj" method "bar" line 1) + invoked from within +"obj bar"} 1 bar {bar + while executing +"error bar" + (in "::obj eval" script line 1) + invoked from within +"next $script" + (class "::cls" method "eval" line 1) + invoked from within +"obj eval {error bar}"}} + +test oo-19.1 {OO: varname method} -setup { + oo::object create inst + oo::define inst export eval + set result {} +} -body { + inst eval {trace add variable x write foo} + set ns [inst eval namespace current] + proc foo args { + global ns result + set context [uplevel 1 namespace current] + lappend result $args [expr { + $ns eq $context ? "ok" : [list $ns ne $context] + }] [expr { + "${ns}::x" eq [uplevel 1 my varname x] ? "ok" : [list ${ns}::x ne [uplevel 1 my varname x]] + }] + } + lappend result [inst eval set x 0] +} -cleanup { + inst destroy + rename foo {} +} -result {{x {} write} ok ok 0} + +test oo-20.1 {OO: variable method} -body { + oo::class create testClass { + constructor {} { + my variable ok + set ok {} + } + } + lsort [info object vars [testClass new]] +} -cleanup { + catch {testClass destroy} +} -result ok +test oo-20.2 {OO: variable method} -body { + oo::class create testClass { + constructor {} { + my variable a b c + set a [set b [set c {}]] + } + } + lsort [info object vars [testClass new]] +} -cleanup { + catch {testClass destroy} +} -result {a b c} +test oo-20.3 {OO: variable method} -body { + oo::class create testClass { + export varname + method bar {} { + my variable a(b) + } + } + testClass create foo + array set [foo varname a] {b c} + foo bar +} -returnCodes 1 -cleanup { + catch {testClass destroy} +} -result {can't define "a(b)": name refers to an element in an array} +test oo-20.4 {OO: variable method} -body { + oo::class create testClass { + export varname + method bar {} { + my variable a(b) + } + } + testClass create foo + set [foo varname a] b + foo bar +} -returnCodes 1 -cleanup { + catch {testClass destroy} +} -result {can't define "a(b)": name refers to an element in an array} +test oo-20.5 {OO: variable method} -body { + oo::class create testClass { + method bar {} { + my variable a::b + } + } + testClass create foo + foo bar +} -returnCodes 1 -cleanup { + catch {testClass destroy} +} -result {variable name "a::b" illegal: must not contain namespace separator} +test oo-20.6 {OO: variable method} -setup { + oo::class create testClass { + self.export eval + export varname + } +} -body { + testClass eval variable a 0 + oo::define [testClass create foo] method bar {other} { + $other variable a + set a 3 + } + oo::define [testClass create boo] export variable + set [foo varname a] 1 + set [boo varname a] 2 + foo bar boo + list [testClass eval set a] [set [foo varname a]] [set [boo varname a]] +} -cleanup { + testClass destroy +} -result {0 1 3} +test oo-20.7 {OO: variable method} -setup { + oo::class create cls +} -body { + oo::define cls { + method a {} { + my variable {b c} d + lappend c $d + } + method e {} { + my variable b d + return [list $b $d] + } + method f {x y} { + my variable b d + set b $x + set d $y + } + } + cls create obj + obj f p q + obj a + obj a + obj e +} -cleanup { + cls destroy +} -result {{p q q} q} +test oo-20.8 {OO: variable method} -setup { + oo::class create cls +} -body { + oo::define cls { + constructor {} { + namespace eval foo { + variable bar 1 + } + } + method ns {} {self namespace} + method a {} { + my variable {foo::bar c} d + lappend c $d + } + method e {} { + my variable {foo::bar b} d + return [list $b $d] + } + method f {x} { + my variable d + set d $x + } + } + cls create obj + obj f p + obj a + obj a + list [obj e] [set [obj ns]::foo::bar] +} -cleanup { + cls destroy +} -result {{{1 p p} p} {1 p p}} +test oo-20.9 {OO: variable method} -setup { + oo::object create obj +} -body { + oo::define obj { + method a {} { + my variable {a ::b} + } + } + obj a +} -cleanup { + obj destroy +} -returnCodes 1 -result {variable name "::b" illegal: must not contain namespace separator} + +test oo-21.1 {OO: inheritance ordering} -setup { + oo::class create A +} -body { + oo::define A method m {} {lappend ::result A} + oo::class create B { + superclass A + method m {} {lappend ::result B;next} + } + oo::class create C { + superclass A + method m {} {lappend ::result C;next} + } + oo::class create D { + superclass B C + method m {} {lappend ::result D;next} + } + D create o + oo::define o method m {} {lappend ::result o;next} + set result {} + o m + return $result +} -cleanup { + A destroy +} -result {o D B C A} +test oo-21.2 {OO: inheritance ordering} -setup { + oo::class create A +} -body { + oo::define A method m {} {lappend ::result A} + oo::class create B { + superclass A + method m {} {lappend ::result B;next} + } + oo::class create C { + superclass A + method m {} {lappend ::result C;next} + } + oo::class create D { + superclass B C + method m {} {lappend ::result D;next} + } + oo::class create Emix { + superclass C + method m {} {lappend ::result Emix;next} + } + oo::class create Fmix { + superclass Emix + method m {} {lappend ::result Fmix;next} + } + D create o + oo::define o method m {} {lappend ::result o;next} + oo::define o mixin Fmix + set result {} + o m + return $result +} -cleanup { + A destroy +} -result {Fmix Emix o D B C A} +test oo-21.3 {OO: inheritance ordering} -setup { + oo::class create A +} -body { + oo::define A method m {} {lappend ::result A} + oo::class create B { + superclass A + method m {} {lappend ::result B;next} + method f {} {lappend ::result B-filt;next} + } + oo::class create C { + superclass A + method m {} {lappend ::result C;next} + } + oo::class create D { + superclass B C + method m {} {lappend ::result D;next} + } + oo::class create Emix { + superclass C + method m {} {lappend ::result Emix;next} + method f {} {lappend ::result Emix-filt;next} + } + oo::class create Fmix { + superclass Emix + method m {} {lappend ::result Fmix;next} + } + D create o + oo::define o { + method m {} {lappend ::result o;next} + mixin Fmix + filter f + } + set result {} + o m + return $result +} -cleanup { + A destroy +} -result {Emix-filt B-filt Fmix Emix o D B C A} +test oo-21.4 {OO: inheritance ordering} -setup { + oo::class create A +} -body { + oo::define A method m {} {lappend ::result A} + oo::class create B { + superclass A + method m {} {lappend ::result B;next} + method f {} {lappend ::result B-filt;next} + method g {} {lappend ::result B-cfilt;next} + } + oo::class create C { + superclass A + method m {} {lappend ::result C;next} + } + oo::class create D { + superclass B C + method m {} {lappend ::result D;next} + method g {} {lappend ::result D-cfilt;next} + filter g + } + oo::class create Emix { + superclass C + method m {} {lappend ::result Emix;next} + method f {} {lappend ::result Emix-filt;next} + } + oo::class create Fmix { + superclass Emix + method m {} {lappend ::result Fmix;next} + } + D create o + oo::define o { + method m {} {lappend ::result o;next} + mixin Fmix + filter f + } + set result {} + o m + return $result +} -cleanup { + A destroy +} -result {Emix-filt B-filt D-cfilt B-cfilt Fmix Emix o D B C A} + +cleanupTests +return + +# Local Variables: +# mode: tcl +# End: Index: unix/Makefile.in ================================================================== --- unix/Makefile.in +++ unix/Makefile.in @@ -3,11 +3,11 @@ # then it is a template for a Makefile; to generate the actual Makefile, # run "./configure", which is a configuration script generated by the # "autoconf" program (constructs like "@foo@" will get replaced in the # actual Makefile. # -# RCS: @(#) $Id: Makefile.in,v 1.183 2005/12/14 02:09:20 das Exp $ +# RCS: @(#) $Id: Makefile.in,v 1.183.2.7 2006/10/11 01:59:27 dgp Exp $ VERSION = @TCL_VERSION@ MAJOR_VERSION = @TCL_MAJOR_VERSION@ MINOR_VERSION = @TCL_MINOR_VERSION@ PATCH_LEVEL = @TCL_PATCH_LEVEL@ @@ -302,13 +302,14 @@ tclCmdAH.o tclCmdIL.o tclCmdMZ.o tclCompCmds.o tclCompExpr.o \ tclCompile.o tclConfig.o tclDate.o tclDictObj.o tclEncoding.o \ tclEnv.o tclEvent.o tclExecute.o tclFCmd.o tclFileName.o tclGet.o \ tclHash.o tclHistory.o tclIndexObj.o tclInterp.o tclIO.o tclIOCmd.o \ tclIORChan.o tclIOGT.o tclIOSock.o tclIOUtil.o tclLink.o tclListObj.o \ - tclLiteral.o tclLoad.o tclMain.o tclNamesp.o tclNotify.o \ - tclObj.o tclPanic.o tclParse.o tclParseExpr.o tclPathObj.o tclPipe.o \ - tclPkg.o tclPkgConfig.o tclPosixStr.o \ + tclLiteral.o tclLoad.o tclMain.o tclNamesp.o tclNotify.o tclObj.o \ + tclOO.o tclOOCall.o tclOODefineCmds.o tclOOInfo.o tclPanic.o \ + tclParse.o tclParseExpr.o tclPathObj.o \ + tclPipe.o tclPkg.o tclPkgConfig.o tclPosixStr.o \ tclPreserve.o tclProc.o tclRegexp.o \ tclResolve.o tclResult.o tclScan.o tclStringObj.o \ tclStrToD.o tclThread.o \ tclThreadAlloc.o tclThreadJoin.o tclThreadStorage.o tclStubInit.o \ tclStubLib.o tclTimer.o tclTrace.o tclUtf.o tclUtil.o tclVar.o \ @@ -402,10 +403,14 @@ $(GENERIC_DIR)/tclLoad.c \ $(GENERIC_DIR)/tclMain.c \ $(GENERIC_DIR)/tclNamesp.c \ $(GENERIC_DIR)/tclNotify.c \ $(GENERIC_DIR)/tclObj.c \ + $(GENERIC_DIR)/tclOO.c \ + $(GENERIC_DIR)/tclOOCall.c \ + $(GENERIC_DIR)/tclOODefineCmds.c \ + $(GENERIC_DIR)/tclOOInfo.c \ $(GENERIC_DIR)/tclParse.c \ $(GENERIC_DIR)/tclParseExpr.c \ $(GENERIC_DIR)/tclPathObj.c \ $(GENERIC_DIR)/tclPipe.c \ $(GENERIC_DIR)/tclPkg.c \ @@ -930,10 +935,11 @@ $(GENERIC_DIR)/regcustom.h TCLREHDRS=$(GENERIC_DIR)/tclRegexp.h COMPILEHDR=$(GENERIC_DIR)/tclCompile.h FSHDR=$(GENERIC_DIR)/tclFileSystem.h IOHDR=$(GENERIC_DIR)/tclIO.h +OOHDR=$(GENERIC_DIR)/tclOO.h MATHHDRS=$(GENERIC_DIR)/tommath.h $(GENERIC_DIR)/tclTomMath.h regcomp.o: $(REGHDRS) $(GENERIC_DIR)/regcomp.c $(GENERIC_DIR)/regc_lex.c \ $(GENERIC_DIR)/regc_color.c $(GENERIC_DIR)/regc_locale.c \ $(GENERIC_DIR)/regc_nfa.c $(GENERIC_DIR)/regc_cvec.c @@ -1060,10 +1066,22 @@ $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclLiteral.c tclObj.o: $(GENERIC_DIR)/tclObj.c $(COMPILEHDR) $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclObj.c +tclOO.o: $(GENERIC_DIR)/tclOO.c $(OOHDR) + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclOO.c + +tclOOCall.o: $(GENERIC_DIR)/tclOOCall.c $(OOHDR) + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclOOCall.c + +tclOODefineCmds.o: $(GENERIC_DIR)/tclOODefineCmds.c $(OOHDR) + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclOODefineCmds.c + +tclOOInfo.o: $(GENERIC_DIR)/tclOOInfo.c $(OOHDR) + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclOOInfo.c + tclLoad.o: $(GENERIC_DIR)/tclLoad.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclLoad.c tclLoadAix.o: $(UNIX_DIR)/tclLoadAix.c $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclLoadAix.c Index: win/Makefile.in ================================================================== --- win/Makefile.in +++ win/Makefile.in @@ -1,755 +1,763 @@ -# -# This file is a Makefile for Tcl. If it has the name "Makefile.in" -# then it is a template for a Makefile; to generate the actual Makefile, -# run "./configure", which is a configuration script generated by the -# "autoconf" program (constructs like "@foo@" will get replaced in the -# actual Makefile. -# -# RCS: @(#) $Id: Makefile.in,v 1.96 2005/12/27 17:39:02 kennykb Exp $ - -VERSION = @TCL_VERSION@ - -#---------------------------------------------------------------- -# Things you can change to personalize the Makefile for your own -# site (you can make these changes in either Makefile.in or -# Makefile, but changes to Makefile will get lost if you re-run -# the configuration script). -#---------------------------------------------------------------- - -# Default top-level directories in which to install architecture- -# specific files (exec_prefix) and machine-independent files such -# as scripts (prefix). The values specified here may be overridden -# at configure-time with the --exec-prefix and --prefix options -# to the "configure" script. - -prefix = @prefix@ -exec_prefix = @exec_prefix@ -bindir = @bindir@ -libdir = @libdir@ -includedir = @includedir@ -mandir = @mandir@ - -# The following definition can be set to non-null for special systems -# like AFS with replication. It allows the pathnames used for installation -# to be different than those used for actually reference files at -# run-time. INSTALL_ROOT is prepended to $prefix and $exec_prefix -# when installing files. -INSTALL_ROOT = - -# Directory from which applications will reference the library of Tcl -# scripts (note: you can set the TCL_LIBRARY environment variable at -# run-time to override this value): -TCL_LIBRARY = $(prefix)/lib/tcl$(VERSION) - -# Path to use at runtime to refer to LIB_INSTALL_DIR: -LIB_RUNTIME_DIR = $(libdir) - -# Directory in which to install the program tclsh: -BIN_INSTALL_DIR = $(INSTALL_ROOT)$(bindir) - -# Directory in which to install the .a or .so binary for the Tcl library: -LIB_INSTALL_DIR = $(INSTALL_ROOT)$(libdir) - -# Path name to use when installing library scripts. -SCRIPT_INSTALL_DIR = $(INSTALL_ROOT)$(TCL_LIBRARY) - -# Directory in which to install the include file tcl.h: -INCLUDE_INSTALL_DIR = $(INSTALL_ROOT)$(includedir) - -# Directory in which to (optionally) install the private tcl headers: -PRIVATE_INCLUDE_INSTALL_DIR = $(INSTALL_ROOT)$(includedir) - -# Top-level directory in which to install manual entries: -MAN_INSTALL_DIR = $(INSTALL_ROOT)$(mandir) - -# Directory in which to install manual entry for tclsh: -MAN1_INSTALL_DIR = $(MAN_INSTALL_DIR)/man1 - -# Directory in which to install manual entries for Tcl's C library -# procedures: -MAN3_INSTALL_DIR = $(MAN_INSTALL_DIR)/man3 - -# Directory in which to install manual entries for the built-in -# Tcl commands: -MANN_INSTALL_DIR = $(MAN_INSTALL_DIR)/mann - -# Libraries built with optimization switches have this additional extension -TCL_DBGX = @TCL_DBGX@ - -# warning flags -CFLAGS_WARNING = @CFLAGS_WARNING@ - -# The default switches for optimization or debugging -CFLAGS_DEBUG = @CFLAGS_DEBUG@ -CFLAGS_OPTIMIZE = @CFLAGS_OPTIMIZE@ - -# To change the compiler switches, for example to change from optimization to -# debugging symbols, change the following line: -#CFLAGS = $(CFLAGS_DEBUG) -#CFLAGS = $(CFLAGS_OPTIMIZE) -#CFLAGS = $(CFLAGS_DEBUG) $(CFLAGS_OPTIMIZE) -CFLAGS = @CFLAGS@ @CFLAGS_DEFAULT@ - -# To enable compilation debugging reverse the comment characters on -# one of the following lines. -COMPILE_DEBUG_FLAGS = -#COMPILE_DEBUG_FLAGS = -DTCL_COMPILE_DEBUG -#COMPILE_DEBUG_FLAGS = -DTCL_COMPILE_DEBUG -DTCL_COMPILE_STATS - -# Special compiler flags to use when building man2tcl on Windows. -MAN2TCLFLAGS = @MAN2TCLFLAGS@ - -SRC_DIR = @srcdir@ -ROOT_DIR = @srcdir@/.. -GENERIC_DIR = @srcdir@/../generic -TOMMATH_DIR = @srcdir@/../libtommath -WIN_DIR = @srcdir@ -COMPAT_DIR = @srcdir@/../compat - -# Converts a POSIX path to a Windows native path. -CYGPATH = @CYGPATH@ - -GENERIC_DIR_NATIVE = $(shell $(CYGPATH) '$(GENERIC_DIR)') -TOMMATH_DIR_NATIVE = $(shell $(CYGPATH) '$(TOMMATH_DIR)') -WIN_DIR_NATIVE = $(shell $(CYGPATH) '$(WIN_DIR)') -ROOT_DIR_NATIVE = $(shell $(CYGPATH) '$(ROOT_DIR)' | sed 's/\\*$$//' ) - -LIBRARY_DIR = $(shell echo '$(ROOT_DIR_NATIVE)/library' | sed 's/\\/\//g' ) - -DLLSUFFIX = @DLLSUFFIX@ -LIBSUFFIX = @LIBSUFFIX@ -EXESUFFIX = @EXESUFFIX@ - -VER = @TCL_MAJOR_VERSION@@TCL_MINOR_VERSION@ -DOTVER = @TCL_MAJOR_VERSION@.@TCL_MINOR_VERSION@ -DDEVER = @TCL_DDE_MAJOR_VERSION@@TCL_DDE_MINOR_VERSION@ -DDEDOTVER = @TCL_DDE_MAJOR_VERSION@.@TCL_DDE_MINOR_VERSION@ -REGVER = @TCL_REG_MAJOR_VERSION@@TCL_REG_MINOR_VERSION@ -REGDOTVER = @TCL_REG_MAJOR_VERSION@.@TCL_REG_MINOR_VERSION@ - -TCL_STUB_LIB_FILE = @TCL_STUB_LIB_FILE@ -TCL_DLL_FILE = @TCL_DLL_FILE@ -TCL_LIB_FILE = @TCL_LIB_FILE@ -DDE_DLL_FILE = tcldde$(DDEVER)${DLLSUFFIX} -DDE_LIB_FILE = tcldde$(DDEVER)${LIBSUFFIX} -REG_DLL_FILE = tclreg$(REGVER)${DLLSUFFIX} -REG_LIB_FILE = tclreg$(REGVER)${LIBSUFFIX} -PIPE_DLL_FILE = tclpip$(VER)${DLLSUFFIX} - -SHARED_LIBRARIES = $(TCL_DLL_FILE) $(TCL_STUB_LIB_FILE) \ - $(DDE_DLL_FILE) $(REG_DLL_FILE) $(PIPE_DLL_FILE) -STATIC_LIBRARIES = $(TCL_LIB_FILE) $(REG_LIB_FILE) $(DDE_LIB_FILE) - -# TCL_EXE is the name of a tclsh executable that is available *BEFORE* -# running make for the first time. Certain build targets (make genstubs) -# need it to be available on the PATH. This executable should *NOT* be -# required just to do a normal build although it can be required to run -# make dist. -TCL_EXE = tclsh - -TCLSH = tclsh$(VER)${EXESUFFIX} -TCLTEST = tcltest${EXEEXT} -CAT32 = cat32$(EXEEXT) -MAN2TCL = man2tcl$(EXEEXT) - -@SET_MAKE@ - -# Setting the VPATH variable to a list of paths will cause the -# makefile to look into these paths when resolving .c to .obj -# dependencies. - -VPATH = $(GENERIC_DIR):$(TOMMATH_DIR):$(WIN_DIR):$(COMPAT_DIR) - -AR = @AR@ -RANLIB = @RANLIB@ -CC = @CC@ -RC = @RC@ -RES = @RES@ -AC_FLAGS = @EXTRA_CFLAGS@ @DEFS@ -CPPFLAGS = @CPPFLAGS@ -LDFLAGS_DEBUG = @LDFLAGS_DEBUG@ -LDFLAGS_OPTIMIZE = @LDFLAGS_OPTIMIZE@ -LDFLAGS = @LDFLAGS@ @LDFLAGS_DEFAULT@ -LDFLAGS_CONSOLE = @LDFLAGS_CONSOLE@ -LDFLAGS_WINDOW = @LDFLAGS_WINDOW@ -EXEEXT = @EXEEXT@ -OBJEXT = @OBJEXT@ -STLIB_LD = @STLIB_LD@ -SHLIB_LD = @SHLIB_LD@ -SHLIB_LD_LIBS = @SHLIB_LD_LIBS@ $(LIBS) -SHLIB_CFLAGS = @SHLIB_CFLAGS@ -SHLIB_SUFFIX = @SHLIB_SUFFIX@ -LIBS = @LIBS@ - -RMDIR = rm -rf -MKDIR = mkdir -p -SHELL = @SHELL@ -RM = rm -f -COPY = cp - -CC_SWITCHES = ${CFLAGS} ${CFLAGS_WARNING} ${TCL_SHLIB_CFLAGS} \ --I"${GENERIC_DIR_NATIVE}" -DTCL_TOMMATH -DMP_PREC=4 -I"${TOMMATH_DIR_NATIVE}" \ --I"${WIN_DIR_NATIVE}" ${AC_FLAGS} \ -${COMPILE_DEBUG_FLAGS} - -CC_OBJNAME = @CC_OBJNAME@ -CC_EXENAME = @CC_EXENAME@ - -STUB_CC_SWITCHES = ${CFLAGS} ${CFLAGS_WARNING} ${SHLIB_CFLAGS} \ --I"${GENERIC_DIR_NATIVE}" -DTCL_TOMMATH -DMP_PREC=4 -I"${TOMMATH_DIR_NATIVE}" \ --I"${WIN_DIR_NATIVE}" ${AC_FLAGS} \ -${COMPILE_DEBUG_FLAGS} - -TCLTEST_OBJS = \ - tclTest.$(OBJEXT) \ - tclTestObj.$(OBJEXT) \ - tclTestProcBodyObj.$(OBJEXT) \ - tclThreadTest.$(OBJEXT) \ - tclWinTest.$(OBJEXT) \ - testMain.$(OBJEXT) - -GENERIC_OBJS = \ - regcomp.$(OBJEXT) \ - regexec.$(OBJEXT) \ - regfree.$(OBJEXT) \ - regerror.$(OBJEXT) \ - tclAlloc.$(OBJEXT) \ - tclAsync.$(OBJEXT) \ - tclBasic.$(OBJEXT) \ - tclBinary.$(OBJEXT) \ - tclCkalloc.$(OBJEXT) \ - tclClock.$(OBJEXT) \ - tclCmdAH.$(OBJEXT) \ - tclCmdIL.$(OBJEXT) \ - tclCmdMZ.$(OBJEXT) \ - tclCompCmds.$(OBJEXT) \ - tclCompExpr.$(OBJEXT) \ - tclCompile.$(OBJEXT) \ - tclConfig.$(OBJEXT) \ - tclDate.$(OBJEXT) \ - tclDictObj.$(OBJEXT) \ - tclEncoding.$(OBJEXT) \ - tclEnv.$(OBJEXT) \ - tclEvent.$(OBJEXT) \ - tclExecute.$(OBJEXT) \ - tclFCmd.$(OBJEXT) \ - tclFileName.$(OBJEXT) \ - tclGet.$(OBJEXT) \ - tclHash.$(OBJEXT) \ - tclHistory.$(OBJEXT) \ - tclIndexObj.$(OBJEXT) \ - tclInterp.$(OBJEXT) \ - tclIO.$(OBJEXT) \ - tclIOCmd.$(OBJEXT) \ - tclIOGT.$(OBJEXT) \ - tclIORChan.$(OBJEXT) \ - tclIOSock.$(OBJEXT) \ - tclIOUtil.$(OBJEXT) \ - tclLink.$(OBJEXT) \ - tclLiteral.$(OBJEXT) \ - tclListObj.$(OBJEXT) \ - tclLoad.$(OBJEXT) \ - tclMain.$(OBJEXT) \ - tclNamesp.$(OBJEXT) \ - tclNotify.$(OBJEXT) \ - tclObj.$(OBJEXT) \ - tclPanic.$(OBJEXT) \ - tclParse.$(OBJEXT) \ - tclParseExpr.$(OBJEXT) \ - tclPathObj.$(OBJEXT) \ - tclPipe.$(OBJEXT) \ - tclPkg.$(OBJEXT) \ - tclPkgConfig.$(OBJEXT) \ - tclPosixStr.$(OBJEXT) \ - tclPreserve.$(OBJEXT) \ - tclProc.$(OBJEXT) \ - tclRegexp.$(OBJEXT) \ - tclResolve.$(OBJEXT) \ - tclResult.$(OBJEXT) \ - tclScan.$(OBJEXT) \ - tclStringObj.$(OBJEXT) \ - tclStrToD.$(OBJEXT) \ - tclStubInit.$(OBJEXT) \ - tclStubLib.$(OBJEXT) \ - tclThread.$(OBJEXT) \ - tclThreadAlloc.$(OBJEXT) \ - tclThreadJoin.$(OBJEXT) \ - tclThreadStorage.$(OBJEXT) \ - tclTimer.$(OBJEXT) \ - tclTomMathInterface.$(OBJEXT) \ - tclTrace.$(OBJEXT) \ - tclUtf.$(OBJEXT) \ - tclUtil.$(OBJEXT) \ - tclVar.$(OBJEXT) - -TOMMATH_OBJS = \ - bncore.${OBJEXT} \ - bn_reverse.${OBJEXT} \ - bn_fast_s_mp_mul_digs.${OBJEXT} \ - bn_fast_s_mp_sqr.${OBJEXT} \ - bn_mp_add.${OBJEXT} \ - bn_mp_add_d.${OBJEXT} \ - bn_mp_and.${OBJEXT} \ - bn_mp_clamp.${OBJEXT} \ - bn_mp_clear.${OBJEXT} \ - bn_mp_clear_multi.${OBJEXT} \ - bn_mp_cmp.${OBJEXT} \ - bn_mp_cmp_d.${OBJEXT} \ - bn_mp_cmp_mag.${OBJEXT} \ - bn_mp_copy.${OBJEXT} \ - bn_mp_count_bits.${OBJEXT} \ - bn_mp_div.${OBJEXT} \ - bn_mp_div_d.${OBJEXT} \ - bn_mp_div_2.${OBJEXT} \ - bn_mp_div_2d.${OBJEXT} \ - bn_mp_div_3.${OBJEXT} \ - bn_mp_exch.${OBJEXT} \ - bn_mp_expt_d.${OBJEXT} \ - bn_mp_grow.${OBJEXT} \ - bn_mp_init.${OBJEXT} \ - bn_mp_init_copy.${OBJEXT} \ - bn_mp_init_multi.${OBJEXT} \ - bn_mp_init_set.${OBJEXT} \ - bn_mp_init_size.${OBJEXT} \ - bn_mp_karatsuba_mul.${OBJEXT} \ - bn_mp_karatsuba_sqr.$(OBJEXT) \ - bn_mp_lshd.${OBJEXT} \ - bn_mp_mod.${OBJEXT} \ - bn_mp_mod_2d.${OBJEXT} \ - bn_mp_mul.${OBJEXT} \ - bn_mp_mul_2.${OBJEXT} \ - bn_mp_mul_2d.${OBJEXT} \ - bn_mp_mul_d.${OBJEXT} \ - bn_mp_neg.${OBJEXT} \ - bn_mp_or.${OBJEXT} \ - bn_mp_radix_size.${OBJEXT} \ - bn_mp_radix_smap.${OBJEXT} \ - bn_mp_read_radix.${OBJEXT} \ - bn_mp_rshd.${OBJEXT} \ - bn_mp_set.${OBJEXT} \ - bn_mp_shrink.${OBJEXT} \ - bn_mp_sqr.${OBJEXT} \ - bn_mp_sqrt.${OBJEXT} \ - bn_mp_sub.${OBJEXT} \ - bn_mp_sub_d.${OBJEXT} \ - bn_mp_to_unsigned_bin.${OBJEXT} \ - bn_mp_to_unsigned_bin_n.${OBJEXT} \ - bn_mp_toom_mul.${OBJEXT} \ - bn_mp_toom_sqr.${OBJEXT} \ - bn_mp_toradix_n.${OBJEXT} \ - bn_mp_unsigned_bin_size.${OBJEXT} \ - bn_mp_xor.${OBJEXT} \ - bn_mp_zero.${OBJEXT} \ - bn_s_mp_add.${OBJEXT} \ - bn_s_mp_mul_digs.${OBJEXT} \ - bn_s_mp_sqr.${OBJEXT} \ - bn_s_mp_sub.${OBJEXT} - - -WIN_OBJS = \ - tclWin32Dll.$(OBJEXT) \ - tclWinChan.$(OBJEXT) \ - tclWinConsole.$(OBJEXT) \ - tclWinSerial.$(OBJEXT) \ - tclWinError.$(OBJEXT) \ - tclWinFCmd.$(OBJEXT) \ - tclWinFile.$(OBJEXT) \ - tclWinInit.$(OBJEXT) \ - tclWinLoad.$(OBJEXT) \ - tclWinNotify.$(OBJEXT) \ - tclWinPipe.$(OBJEXT) \ - tclWinSock.$(OBJEXT) \ - tclWinThrd.$(OBJEXT) \ - tclWinTime.$(OBJEXT) - -COMPAT_OBJS = \ - strtoll.$(OBJEXT) strtoull.$(OBJEXT) - -PIPE_OBJS = stub16.$(OBJEXT) - -DDE_OBJS = tclWinDde.$(OBJEXT) - -REG_OBJS = tclWinReg.$(OBJEXT) - -STUB_OBJS = tclStubLib.$(OBJEXT) - -TCLSH_OBJS = tclAppInit.$(OBJEXT) - -TCL_OBJS = ${GENERIC_OBJS} $(TOMMATH_OBJS) ${WIN_OBJS} ${COMPAT_OBJS} - -TCL_DOCS = "$(ROOT_DIR_NATIVE)"/doc/*.[13n] - -all: binaries libraries doc - -tcltest: $(TCLTEST) - -binaries: @LIBRARIES@ $(TCLSH) - -libraries: - -doc: - -winhelp: $(ROOT_DIR)/tools/man2help.tcl $(MAN2TCL) - TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \ - ./$(TCLSH) "$(ROOT_DIR_NATIVE)"/tools/man2help.tcl tcl "$(VER)" $(TCL_DOCS) - hcw /c /e tcl.hpj - -$(MAN2TCL): $(ROOT_DIR)/tools/man2tcl.c - $(CC) $(CFLAGS_OPTIMIZE) $(MAN2TCLFLAGS) -o $(MAN2TCL) "$(ROOT_DIR_NATIVE)"/tools/man2tcl.c - -$(TCLSH): $(TCL_LIB_FILE) $(TCL_STUB_LIB_FILE) $(TCLSH_OBJS) tclsh.$(RES) - $(CC) $(CFLAGS) $(TCLSH_OBJS) $(TCL_LIB_FILE) $(LIBS) \ - tclsh.$(RES) $(CC_EXENAME) $(LDFLAGS_CONSOLE) - -$(TCLTEST): $(TCL_LIB_FILE) $(TCLTEST_OBJS) $(CAT32) tclsh.$(RES) - $(CC) $(CFLAGS) $(TCLTEST_OBJS) $(TCL_LIB_FILE) $(LIBS) \ - tclsh.$(RES) $(CC_EXENAME) $(LDFLAGS_CONSOLE) - -cat32.$(OBJEXT): cat.c - $(CC) -c $(CC_SWITCHES) @DEPARG@ $(CC_OBJNAME) - -$(CAT32): cat32.$(OBJEXT) - $(CC) $(CFLAGS) cat32.$(OBJEXT) $(CC_EXENAME) $(LIBS) $(LDFLAGS_CONSOLE) - -# The following targets are configured by autoconf to generate either -# a shared library or static library - -${TCL_STUB_LIB_FILE}: ${STUB_OBJS} - @$(RM) ${TCL_STUB_LIB_FILE} - @MAKE_LIB@ ${STUB_OBJS} - @POST_MAKE_LIB@ - -${TCL_DLL_FILE}: ${TCL_OBJS} tcl.$(RES) - @$(RM) ${TCL_DLL_FILE} - @MAKE_DLL@ ${TCL_OBJS} tcl.$(RES) $(SHLIB_LD_LIBS) - -${TCL_LIB_FILE}: ${TCL_OBJS} - @$(RM) ${TCL_LIB_FILE} - @MAKE_LIB@ ${TCL_OBJS} - @POST_MAKE_LIB@ - -${DDE_DLL_FILE}: ${DDE_OBJS} ${TCL_STUB_LIB_FILE} - @$(RM) ${DDE_DLL_FILE} - @MAKE_DLL@ ${DDE_OBJS} $(TCL_STUB_LIB_FILE) $(SHLIB_LD_LIBS) - -${DDE_LIB_FILE}: ${DDE_OBJS} ${TCL_LIB_FILE} - @$(RM) ${DDE_LIB_FILE} - @MAKE_LIB@ ${DDE_OBJS} ${TCL_LIB_FILE} - -${REG_DLL_FILE}: ${REG_OBJS} ${TCL_STUB_LIB_FILE} - @$(RM) ${REG_DLL_FILE} - @MAKE_DLL@ ${REG_OBJS} $(TCL_STUB_LIB_FILE) $(SHLIB_LD_LIBS) - -${REG_LIB_FILE}: ${REG_OBJS} ${TCL_LIB_FILE} - @$(RM) ${REG_LIB_FILE} - @MAKE_LIB@ ${REG_OBJS} ${TCL_LIB_FILE} - -# PIPE_DLL_FILE is actually an executable, don't build it -# like a DLL. - -${PIPE_DLL_FILE}: ${PIPE_OBJS} - @$(RM) ${PIPE_DLL_FILE} - @MAKE_EXE@ $(CFLAGS) ${PIPE_OBJS} $(LIBS) $(LDFLAGS_CONSOLE) - -# Add the object extension to the implicit rules. By default .obj is not -# automatically added. - -.SUFFIXES: .${OBJEXT} -.SUFFIXES: .$(RES) -.SUFFIXES: .rc - -# Special case object targets - -tclWinInit.${OBJEXT}: tclWinInit.c - $(CC) -c $(CC_SWITCHES) -DBUILD_tcl $(EXTFLAGS) @DEPARG@ $(CC_OBJNAME) - -tclWinPipe.${OBJEXT}: tclWinPipe.c - $(CC) -c $(CC_SWITCHES) -DBUILD_tcl -DTCL_PIPE_DLL=\"$(PIPE_DLL_FILE)\" \ - $(EXTFLAGS) @DEPARG@ $(CC_OBJNAME) - -testMain.${OBJEXT}: tclAppInit.c - $(CC) -c $(CC_SWITCHES) -DTCL_TEST @DEPARG@ $(CC_OBJNAME) - -tclTest.${OBJEXT}: tclTest.c - $(CC) -c $(CC_SWITCHES) @DEPARG@ $(CC_OBJNAME) - -tclTestObj.${OBJEXT}: tclTestObj.c - $(CC) -c $(CC_SWITCHES) @DEPARG@ $(CC_OBJNAME) - -tclWinTest.${OBJEXT}: tclWinTest.c - $(CC) -c $(CC_SWITCHES) @DEPARG@ $(CC_OBJNAME) - -tclAppInit.${OBJEXT} : tclAppInit.c - $(CC) -c $(CC_SWITCHES) @DEPARG@ $(CC_OBJNAME) - -# The following objects should be built using the stub interfaces - -tclWinReg.${OBJEXT} : tclWinReg.c - $(CC) -c $(CC_SWITCHES) -DUSE_TCL_STUBS @DEPARG@ $(CC_OBJNAME) - -tclWinDde.${OBJEXT} : tclWinDde.c - $(CC) -c $(CC_SWITCHES) -DUSE_TCL_STUBS @DEPARG@ $(CC_OBJNAME) - -# TIP #59, embedding of configuration information into the binary library. -# -# Part of Tcl's configuration information are the paths where it was -# installed and where it will look for its libraries (which can be -# different). We derive this information from the variables which can -# be overridden by the user. As every path can be configured -# separately we do not remember one general prefix/exec_prefix but all -# the different paths individually. - -tclPkgConfig.${OBJEXT}: tclPkgConfig.c - $(CC) -c $(CC_SWITCHES) \ - -DCFG_INSTALL_LIBDIR=\"$(LIB_INSTALL_DIR)\" \ - -DCFG_INSTALL_BINDIR=\"$(BIN_INSTALL_DIR)\" \ - -DCFG_INSTALL_SCRDIR=\"$(SCRIPT_INSTALL_DIR)\" \ - -DCFG_INSTALL_INCDIR=\"$(INCLUDE_INSTALL_DIR)\" \ - -DCFG_INSTALL_DOCDIR=\"$(MAN_INSTALL_DIR)\" \ - \ - -DCFG_RUNTIME_LIBDIR=\"$(libdir)\" \ - -DCFG_RUNTIME_BINDIR=\"$(bindir)\" \ - -DCFG_RUNTIME_SCRDIR=\"$(TCL_LIBRARY)\" \ - -DCFG_RUNTIME_INCDIR=\"$(includedir)\" \ - -DCFG_RUNTIME_DOCDIR=\"$(mandir)\" \ - -DBUILD_tcl \ - @DEPARG@ $(CC_OBJNAME) - -# The following objects are part of the stub library and should not -# be built as DLL objects but none of the symbols should be exported - -tclStubLib.${OBJEXT}: tclStubLib.c - $(CC) -c $(CC_SWITCHES) -DSTATIC_BUILD @DEPARG@ $(CC_OBJNAME) - - -# Implicit rule for all object files that will end up in the Tcl library - -.c.${OBJEXT}: - $(CC) -c $(CC_SWITCHES) -DBUILD_tcl @DEPARG@ $(CC_OBJNAME) - -.rc.$(RES): - $(RC) @RC_OUT@ $@ @RC_TYPE@ @RC_DEFINES@ @RC_INCLUDE@ "$(GENERIC_DIR_NATIVE)" @RC_INCLUDE@ "$(WIN_DIR_NATIVE)" @DEPARG@ - -# The following target generates the file generic/tclDate.c -# from the yacc grammar found in generic/tclGetDate.y. This is -# only run by hand as yacc is not available in all environments. -# The name of the .c file is different than the name of the .y file -# so that make doesn't try to automatically regenerate the .c file. - -gendate: - bison --output-file=$(GENERIC_DIR)/tclDate.c \ - --name-prefix=TclDate \ - --no-lines \ - $(GENERIC_DIR)/tclGetDate.y - -# The following target generates the file generic/tclTomMath.h. -# It needs to be run (and the results checked) after updating -# to a new release of libtommath. - -gentommath_h: - $(TCL_EXE) "$(ROOT_DIR_NATIVE)\tools\fix_tommath_h.tcl" \ - "$(TOMMATH_DIR_NATIVE)\tommath.h" \ - > "$(GENERIC_DIR_NATIVE)\tclTomMath.h" - -install: all install-binaries install-libraries install-doc - -install-binaries: binaries - @for i in "$(LIB_INSTALL_DIR)" "$(BIN_INSTALL_DIR)" ; \ - do \ - if [ ! -d $$i ] ; then \ - echo "Making directory $$i"; \ - $(MKDIR) $$i; \ - chmod 755 $$i; \ - else true; \ - fi; \ - done; - @for i in dde1.3 reg1.1; \ - do \ - if [ ! -d $(LIB_INSTALL_DIR)/$$i ] ; then \ - echo "Making directory $(LIB_INSTALL_DIR)/$$i"; \ - $(MKDIR) $(LIB_INSTALL_DIR)/$$i; \ - else true; \ - fi; \ - done; - @for i in $(TCL_DLL_FILE) $(TCLSH) $(PIPE_DLL_FILE); \ - do \ - if [ -f $$i ]; then \ - echo "Installing $$i to $(BIN_INSTALL_DIR)/"; \ - $(COPY) $$i "$(BIN_INSTALL_DIR)"; \ - fi; \ - done - @for i in tclConfig.sh $(TCL_LIB_FILE) $(TCL_STUB_LIB_FILE); \ - do \ - if [ -f $$i ]; then \ - echo "Installing $$i to $(LIB_INSTALL_DIR)/"; \ - $(COPY) $$i "$(LIB_INSTALL_DIR)"; \ - fi; \ - done - @if [ -f $(DDE_DLL_FILE) ]; then \ - echo installing $(DDE_DLL_FILE); \ - $(COPY) $(DDE_DLL_FILE) $(LIB_INSTALL_DIR)/dde1.3; \ - $(COPY) $(ROOT_DIR)/library/dde/pkgIndex.tcl \ - $(LIB_INSTALL_DIR)/dde1.3; \ - fi - @if [ -f $(DDE_LIB_FILE) ]; then \ - echo installing $(DDE_LIB_FILE); \ - $(COPY) $(DDE_LIB_FILE) $(LIB_INSTALL_DIR)/dde1.3; \ - fi - @if [ -f $(REG_DLL_FILE) ]; then \ - echo installing $(REG_DLL_FILE); \ - $(COPY) $(REG_DLL_FILE) $(LIB_INSTALL_DIR)/reg1.1; \ - $(COPY) $(ROOT_DIR)/library/reg/pkgIndex.tcl \ - $(LIB_INSTALL_DIR)/reg1.1; \ - fi - @if [ -f $(REG_LIB_FILE) ]; then \ - echo installing $(REG_LIB_FILE); \ - $(COPY) $(REG_LIB_FILE) $(LIB_INSTALL_DIR)/reg1.1; \ - fi - -install-libraries: libraries install-tzdata install-msgs - @for i in $(prefix)/lib $(INCLUDE_INSTALL_DIR) \ - $(SCRIPT_INSTALL_DIR); \ - do \ - if [ ! -d $$i ] ; then \ - echo "Making directory $$i"; \ - $(MKDIR) $$i; \ - else true; \ - fi; \ - done; - @for i in http1.0 opt0.4 encoding ../tcl8 ../tcl8/8.2 ../tcl8/8.3 ../tcl8/8.5; \ - do \ - if [ ! -d $(SCRIPT_INSTALL_DIR)/$$i ] ; then \ - echo "Making directory $(SCRIPT_INSTALL_DIR)/$$i"; \ - $(MKDIR) $(SCRIPT_INSTALL_DIR)/$$i; \ - else true; \ - fi; \ - done; - @echo "Installing header files"; - @for i in "$(GENERIC_DIR)/tcl.h" "$(GENERIC_DIR)/tclDecls.h" \ - "$(GENERIC_DIR)/tclPlatDecls.h" \ - "$(GENERIC_DIR)/tclTomMath.h" \ - "$(GENERIC_DIR)/tclTomMathDecls.h" \ - "$(TOMMATH_DIR)/tommath_class.h" \ - "$(TOMMATH_DIR)/tommath_superclass.h" ; \ - do \ - $(COPY) "$$i" "$(INCLUDE_INSTALL_DIR)"; \ - done; - @echo "Installing library files to $(SCRIPT_INSTALL_DIR)"; - @for i in $(ROOT_DIR)/library/*.tcl $(ROOT_DIR)/library/tclIndex; \ - do \ - $(COPY) "$$i" "$(SCRIPT_INSTALL_DIR)"; \ - done; - @echo "Installing library http1.0 directory"; - @for j in $(ROOT_DIR)/library/http1.0/*.tcl; \ - do \ - $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/http1.0"; \ - done; - @echo "Installing package http 2.5.2 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/http/http.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.2/http-2.5.2.tm; - @echo "Installing library opt0.4 directory"; - @for j in $(ROOT_DIR)/library/opt/*.tcl; \ - do \ - $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/opt0.4"; \ - done; - @echo "Installing package msgcat 1.4.1 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/msgcat-1.4.1.tm; - @echo "Installing package tcltest 2.2.8 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.3/tcltest-2.2.8.tm; - @echo "Installing encodings"; - @for i in $(ROOT_DIR)/library/encoding/*.enc ; do \ - $(COPY) "$$i" "$(SCRIPT_INSTALL_DIR)/encoding"; \ - done; - -install-tzdata: - @echo "Installing time zone data" - @TCL_LIBRARY="${LIBRARY_DIR}"; export TCL_LIBRARY; \ - ./$(TCLSH) "$(ROOT_DIR)/tools/installData.tcl" \ - "$(ROOT_DIR)/library/tzdata" "$(SCRIPT_INSTALL_DIR)/tzdata" - -install-msgs: - @echo "Installing message catalogs" - @TCL_LIBRARY="${LIBRARY_DIR}"; export TCL_LIBRARY; \ - ./$(TCLSH) "$(ROOT_DIR)/tools/installData.tcl" \ - "$(ROOT_DIR)/library/msgs" "$(SCRIPT_INSTALL_DIR)/msgs" - -install-doc: doc - -# Optional target to install private headers -install-private-headers: libraries - @for i in $(PRIVATE_INCLUDE_INSTALL_DIR); \ - do \ - if [ ! -d $$i ] ; then \ - echo "Making directory $$i"; \ - $(MKDIR) $$i; \ - else true; \ - fi; \ - done; - @echo "Installing private header files"; - @for i in "$(GENERIC_DIR)/tclInt.h" "$(GENERIC_DIR)/tclIntDecls.h" \ - "$(GENERIC_DIR)/tclIntPlatDecls.h" "$(GENERIC_DIR)/tclPort.h" \ - "$(WIN_DIR)/tclWinPort.h" ; \ - do \ - $(COPY) "$$i" "$(PRIVATE_INCLUDE_INSTALL_DIR)"; \ - done; - -# Specifying TESTFLAGS on the command line is the standard way to pass -# args to tcltest, ie: -# % make test TESTFLAGS="-verbose bps -file fileName.test" - -test: binaries $(TCLTEST) - TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \ - ./$(TCLTEST) "$(ROOT_DIR_NATIVE)/tests/all.tcl" $(TESTFLAGS) \ - -load "set ::ddelib [file normalize ${DDE_DLL_FILE}]; \ - set ::reglib [file normalize ${REG_DLL_FILE}]" | ./$(CAT32) - -# Useful target to launch a built tcltest with the proper path,... -runtest: binaries $(TCLTEST) - @TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \ - ./$(TCLTEST) $(TESTFLAGS) -load "set ::ddelib [file normalize ${DDE_DLL_FILE}]; \ - set ::reglib [file normalize ${REG_DLL_FILE}]" $(SCRIPT) - -# This target can be used to run tclsh from the build directory -# via `make shell SCRIPT=foo.tcl` -shell: binaries - @TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \ - ./$(TCLSH) $(SCRIPT) - -# This target can be used to run tclsh inside either gdb or insight -gdb: binaries - @echo "set env TCL_LIBRARY=$(LIBRARY_DIR)" > gdb.run - gdb ./tclsh --command=gdb.run - rm gdb.run - -depend: - -Makefile: $(SRC_DIR)/Makefile.in - ./config.status - -cleanhelp: - $(RM) *.hlp *.cnt *.GID *.rtf man2tcl.exe - -clean: cleanhelp - $(RM) *.lib *.a *.exp *.dll *.$(RES) *.${OBJEXT} *~ \#* TAGS a.out - $(RM) $(TCLSH) $(TCLTEST) $(CAT32) - $(RM) *.pch *.ilk *.pdb - -distclean: clean - $(RM) Makefile config.status config.cache config.log tclConfig.sh \ - tcl.hpj config.status.lineno - -# -# Regenerate the stubs files. -# - -$(GENERIC_DIR)/tclStubInit.c: $(GENERIC_DIR)/tcl.decls \ - $(GENERIC_DIR)/tclInt.decls - @echo "Warning: tclStubInit.c may be out of date." - @echo "Developers may want to run \"make genstubs\" to regenerate." - @echo "This warning can be safely ignored, do not report as a bug!" - -genstubs: - $(TCL_EXE) "$(ROOT_DIR_NATIVE)\tools\genStubs.tcl" \ - "$(GENERIC_DIR_NATIVE)" \ - "$(GENERIC_DIR_NATIVE)\tcl.decls" \ - "$(GENERIC_DIR_NATIVE)\tclInt.decls" \ - "$(GENERIC_DIR_NATIVE)\tclTomMath.decls" +# +# This file is a Makefile for Tcl. If it has the name "Makefile.in" +# then it is a template for a Makefile; to generate the actual Makefile, +# run "./configure", which is a configuration script generated by the +# "autoconf" program (constructs like "@foo@" will get replaced in the +# actual Makefile. +# +# RCS: @(#) $Id: Makefile.in,v 1.96.2.7 2006/10/08 17:14:33 dkf Exp $ + +VERSION = @TCL_VERSION@ + +#---------------------------------------------------------------- +# Things you can change to personalize the Makefile for your own +# site (you can make these changes in either Makefile.in or +# Makefile, but changes to Makefile will get lost if you re-run +# the configuration script). +#---------------------------------------------------------------- + +# Default top-level directories in which to install architecture- +# specific files (exec_prefix) and machine-independent files such +# as scripts (prefix). The values specified here may be overridden +# at configure-time with the --exec-prefix and --prefix options +# to the "configure" script. + +prefix = @prefix@ +exec_prefix = @exec_prefix@ +bindir = @bindir@ +libdir = @libdir@ +includedir = @includedir@ +mandir = @mandir@ + +# The following definition can be set to non-null for special systems +# like AFS with replication. It allows the pathnames used for installation +# to be different than those used for actually reference files at +# run-time. INSTALL_ROOT is prepended to $prefix and $exec_prefix +# when installing files. +INSTALL_ROOT = + +# Directory from which applications will reference the library of Tcl +# scripts (note: you can set the TCL_LIBRARY environment variable at +# run-time to override this value): +TCL_LIBRARY = $(prefix)/lib/tcl$(VERSION) + +# Path to use at runtime to refer to LIB_INSTALL_DIR: +LIB_RUNTIME_DIR = $(libdir) + +# Directory in which to install the program tclsh: +BIN_INSTALL_DIR = $(INSTALL_ROOT)$(bindir) + +# Directory in which to install the .a or .so binary for the Tcl library: +LIB_INSTALL_DIR = $(INSTALL_ROOT)$(libdir) + +# Path name to use when installing library scripts. +SCRIPT_INSTALL_DIR = $(INSTALL_ROOT)$(TCL_LIBRARY) + +# Directory in which to install the include file tcl.h: +INCLUDE_INSTALL_DIR = $(INSTALL_ROOT)$(includedir) + +# Directory in which to (optionally) install the private tcl headers: +PRIVATE_INCLUDE_INSTALL_DIR = $(INSTALL_ROOT)$(includedir) + +# Top-level directory in which to install manual entries: +MAN_INSTALL_DIR = $(INSTALL_ROOT)$(mandir) + +# Directory in which to install manual entry for tclsh: +MAN1_INSTALL_DIR = $(MAN_INSTALL_DIR)/man1 + +# Directory in which to install manual entries for Tcl's C library +# procedures: +MAN3_INSTALL_DIR = $(MAN_INSTALL_DIR)/man3 + +# Directory in which to install manual entries for the built-in +# Tcl commands: +MANN_INSTALL_DIR = $(MAN_INSTALL_DIR)/mann + +# Libraries built with optimization switches have this additional extension +TCL_DBGX = @TCL_DBGX@ + +# warning flags +CFLAGS_WARNING = @CFLAGS_WARNING@ + +# The default switches for optimization or debugging +CFLAGS_DEBUG = @CFLAGS_DEBUG@ +CFLAGS_OPTIMIZE = @CFLAGS_OPTIMIZE@ + +# To change the compiler switches, for example to change from optimization to +# debugging symbols, change the following line: +#CFLAGS = $(CFLAGS_DEBUG) +#CFLAGS = $(CFLAGS_OPTIMIZE) +#CFLAGS = $(CFLAGS_DEBUG) $(CFLAGS_OPTIMIZE) +CFLAGS = @CFLAGS@ @CFLAGS_DEFAULT@ + +# To enable compilation debugging reverse the comment characters on +# one of the following lines. +COMPILE_DEBUG_FLAGS = +#COMPILE_DEBUG_FLAGS = -DTCL_COMPILE_DEBUG +#COMPILE_DEBUG_FLAGS = -DTCL_COMPILE_DEBUG -DTCL_COMPILE_STATS + +# Special compiler flags to use when building man2tcl on Windows. +MAN2TCLFLAGS = @MAN2TCLFLAGS@ + +SRC_DIR = @srcdir@ +ROOT_DIR = @srcdir@/.. +GENERIC_DIR = @srcdir@/../generic +TOMMATH_DIR = @srcdir@/../libtommath +WIN_DIR = @srcdir@ +COMPAT_DIR = @srcdir@/../compat + +# Converts a POSIX path to a Windows native path. +CYGPATH = @CYGPATH@ + +GENERIC_DIR_NATIVE = $(shell $(CYGPATH) '$(GENERIC_DIR)') +TOMMATH_DIR_NATIVE = $(shell $(CYGPATH) '$(TOMMATH_DIR)') +WIN_DIR_NATIVE = $(shell $(CYGPATH) '$(WIN_DIR)') +ROOT_DIR_NATIVE = $(shell $(CYGPATH) '$(ROOT_DIR)' | sed 's/\\*$$//' ) + +LIBRARY_DIR = $(shell echo '$(ROOT_DIR_NATIVE)/library' | sed 's/\\/\//g' ) + +DLLSUFFIX = @DLLSUFFIX@ +LIBSUFFIX = @LIBSUFFIX@ +EXESUFFIX = @EXESUFFIX@ + +VER = @TCL_MAJOR_VERSION@@TCL_MINOR_VERSION@ +DOTVER = @TCL_MAJOR_VERSION@.@TCL_MINOR_VERSION@ +DDEVER = @TCL_DDE_MAJOR_VERSION@@TCL_DDE_MINOR_VERSION@ +DDEDOTVER = @TCL_DDE_MAJOR_VERSION@.@TCL_DDE_MINOR_VERSION@ +REGVER = @TCL_REG_MAJOR_VERSION@@TCL_REG_MINOR_VERSION@ +REGDOTVER = @TCL_REG_MAJOR_VERSION@.@TCL_REG_MINOR_VERSION@ + +TCL_STUB_LIB_FILE = @TCL_STUB_LIB_FILE@ +TCL_DLL_FILE = @TCL_DLL_FILE@ +TCL_LIB_FILE = @TCL_LIB_FILE@ +DDE_DLL_FILE = tcldde$(DDEVER)${DLLSUFFIX} +DDE_LIB_FILE = tcldde$(DDEVER)${LIBSUFFIX} +REG_DLL_FILE = tclreg$(REGVER)${DLLSUFFIX} +REG_LIB_FILE = tclreg$(REGVER)${LIBSUFFIX} +PIPE_DLL_FILE = tclpip$(VER)${DLLSUFFIX} + +SHARED_LIBRARIES = $(TCL_DLL_FILE) $(TCL_STUB_LIB_FILE) \ + $(DDE_DLL_FILE) $(REG_DLL_FILE) $(PIPE_DLL_FILE) +STATIC_LIBRARIES = $(TCL_LIB_FILE) $(REG_LIB_FILE) $(DDE_LIB_FILE) + +# TCL_EXE is the name of a tclsh executable that is available *BEFORE* +# running make for the first time. Certain build targets (make genstubs) +# need it to be available on the PATH. This executable should *NOT* be +# required just to do a normal build although it can be required to run +# make dist. +TCL_EXE = tclsh + +TCLSH = tclsh$(VER)${EXESUFFIX} +TCLTEST = tcltest${EXEEXT} +CAT32 = cat32$(EXEEXT) +MAN2TCL = man2tcl$(EXEEXT) + +@SET_MAKE@ + +# Setting the VPATH variable to a list of paths will cause the +# makefile to look into these paths when resolving .c to .obj +# dependencies. + +VPATH = $(GENERIC_DIR):$(TOMMATH_DIR):$(WIN_DIR):$(COMPAT_DIR) + +AR = @AR@ +RANLIB = @RANLIB@ +CC = @CC@ +RC = @RC@ +RES = @RES@ +AC_FLAGS = @EXTRA_CFLAGS@ @DEFS@ +CPPFLAGS = @CPPFLAGS@ +LDFLAGS_DEBUG = @LDFLAGS_DEBUG@ +LDFLAGS_OPTIMIZE = @LDFLAGS_OPTIMIZE@ +LDFLAGS = @LDFLAGS@ @LDFLAGS_DEFAULT@ +LDFLAGS_CONSOLE = @LDFLAGS_CONSOLE@ +LDFLAGS_WINDOW = @LDFLAGS_WINDOW@ +EXEEXT = @EXEEXT@ +OBJEXT = @OBJEXT@ +STLIB_LD = @STLIB_LD@ +SHLIB_LD = @SHLIB_LD@ +SHLIB_LD_LIBS = @SHLIB_LD_LIBS@ $(LIBS) +SHLIB_CFLAGS = @SHLIB_CFLAGS@ +SHLIB_SUFFIX = @SHLIB_SUFFIX@ +LIBS = @LIBS@ + +RMDIR = rm -rf +MKDIR = mkdir -p +SHELL = @SHELL@ +RM = rm -f +COPY = cp + +CC_SWITCHES = ${CFLAGS} ${CFLAGS_WARNING} ${TCL_SHLIB_CFLAGS} \ +-I"${GENERIC_DIR_NATIVE}" -DTCL_TOMMATH -DMP_PREC=4 -I"${TOMMATH_DIR_NATIVE}" \ +-I"${WIN_DIR_NATIVE}" ${AC_FLAGS} \ +${COMPILE_DEBUG_FLAGS} + +CC_OBJNAME = @CC_OBJNAME@ +CC_EXENAME = @CC_EXENAME@ + +STUB_CC_SWITCHES = ${CFLAGS} ${CFLAGS_WARNING} ${SHLIB_CFLAGS} \ +-I"${GENERIC_DIR_NATIVE}" -DTCL_TOMMATH -DMP_PREC=4 -I"${TOMMATH_DIR_NATIVE}" \ +-I"${WIN_DIR_NATIVE}" ${AC_FLAGS} \ +${COMPILE_DEBUG_FLAGS} + +TCLTEST_OBJS = \ + tclTest.$(OBJEXT) \ + tclTestObj.$(OBJEXT) \ + tclTestProcBodyObj.$(OBJEXT) \ + tclThreadTest.$(OBJEXT) \ + tclWinTest.$(OBJEXT) \ + testMain.$(OBJEXT) + +GENERIC_OBJS = \ + regcomp.$(OBJEXT) \ + regexec.$(OBJEXT) \ + regfree.$(OBJEXT) \ + regerror.$(OBJEXT) \ + tclAlloc.$(OBJEXT) \ + tclAsync.$(OBJEXT) \ + tclBasic.$(OBJEXT) \ + tclBinary.$(OBJEXT) \ + tclCkalloc.$(OBJEXT) \ + tclClock.$(OBJEXT) \ + tclCmdAH.$(OBJEXT) \ + tclCmdIL.$(OBJEXT) \ + tclCmdMZ.$(OBJEXT) \ + tclCompCmds.$(OBJEXT) \ + tclCompExpr.$(OBJEXT) \ + tclCompile.$(OBJEXT) \ + tclConfig.$(OBJEXT) \ + tclDate.$(OBJEXT) \ + tclDictObj.$(OBJEXT) \ + tclEncoding.$(OBJEXT) \ + tclEnv.$(OBJEXT) \ + tclEvent.$(OBJEXT) \ + tclExecute.$(OBJEXT) \ + tclFCmd.$(OBJEXT) \ + tclFileName.$(OBJEXT) \ + tclGet.$(OBJEXT) \ + tclHash.$(OBJEXT) \ + tclHistory.$(OBJEXT) \ + tclIndexObj.$(OBJEXT) \ + tclInterp.$(OBJEXT) \ + tclIO.$(OBJEXT) \ + tclIOCmd.$(OBJEXT) \ + tclIOGT.$(OBJEXT) \ + tclIORChan.$(OBJEXT) \ + tclIOSock.$(OBJEXT) \ + tclIOUtil.$(OBJEXT) \ + tclLink.$(OBJEXT) \ + tclLiteral.$(OBJEXT) \ + tclListObj.$(OBJEXT) \ + tclLoad.$(OBJEXT) \ + tclMain.$(OBJEXT) \ + tclNamesp.$(OBJEXT) \ + tclNotify.$(OBJEXT) \ + tclObj.$(OBJEXT) \ + tclOO.$(OBJEXT) \ + tclOOCall.$(OBJEXT) \ + tclOODefineCmds.$(OBJEXT) \ + tclOOInfo.$(OBJEXT) \ + tclPanic.$(OBJEXT) \ + tclParse.$(OBJEXT) \ + tclParseExpr.$(OBJEXT) \ + tclPathObj.$(OBJEXT) \ + tclPipe.$(OBJEXT) \ + tclPkg.$(OBJEXT) \ + tclPkgConfig.$(OBJEXT) \ + tclPosixStr.$(OBJEXT) \ + tclPreserve.$(OBJEXT) \ + tclProc.$(OBJEXT) \ + tclRegexp.$(OBJEXT) \ + tclResolve.$(OBJEXT) \ + tclResult.$(OBJEXT) \ + tclScan.$(OBJEXT) \ + tclStringObj.$(OBJEXT) \ + tclStrToD.$(OBJEXT) \ + tclStubInit.$(OBJEXT) \ + tclStubLib.$(OBJEXT) \ + tclThread.$(OBJEXT) \ + tclThreadAlloc.$(OBJEXT) \ + tclThreadJoin.$(OBJEXT) \ + tclThreadStorage.$(OBJEXT) \ + tclTimer.$(OBJEXT) \ + tclTomMathInterface.$(OBJEXT) \ + tclTrace.$(OBJEXT) \ + tclUtf.$(OBJEXT) \ + tclUtil.$(OBJEXT) \ + tclVar.$(OBJEXT) + +TOMMATH_OBJS = \ + bncore.${OBJEXT} \ + bn_reverse.${OBJEXT} \ + bn_fast_s_mp_mul_digs.${OBJEXT} \ + bn_fast_s_mp_sqr.${OBJEXT} \ + bn_mp_add.${OBJEXT} \ + bn_mp_add_d.${OBJEXT} \ + bn_mp_and.${OBJEXT} \ + bn_mp_clamp.${OBJEXT} \ + bn_mp_clear.${OBJEXT} \ + bn_mp_clear_multi.${OBJEXT} \ + bn_mp_cmp.${OBJEXT} \ + bn_mp_cmp_d.${OBJEXT} \ + bn_mp_cmp_mag.${OBJEXT} \ + bn_mp_copy.${OBJEXT} \ + bn_mp_count_bits.${OBJEXT} \ + bn_mp_div.${OBJEXT} \ + bn_mp_div_d.${OBJEXT} \ + bn_mp_div_2.${OBJEXT} \ + bn_mp_div_2d.${OBJEXT} \ + bn_mp_div_3.${OBJEXT} \ + bn_mp_exch.${OBJEXT} \ + bn_mp_expt_d.${OBJEXT} \ + bn_mp_grow.${OBJEXT} \ + bn_mp_init.${OBJEXT} \ + bn_mp_init_copy.${OBJEXT} \ + bn_mp_init_multi.${OBJEXT} \ + bn_mp_init_set.${OBJEXT} \ + bn_mp_init_size.${OBJEXT} \ + bn_mp_karatsuba_mul.${OBJEXT} \ + bn_mp_karatsuba_sqr.$(OBJEXT) \ + bn_mp_lshd.${OBJEXT} \ + bn_mp_mod.${OBJEXT} \ + bn_mp_mod_2d.${OBJEXT} \ + bn_mp_mul.${OBJEXT} \ + bn_mp_mul_2.${OBJEXT} \ + bn_mp_mul_2d.${OBJEXT} \ + bn_mp_mul_d.${OBJEXT} \ + bn_mp_neg.${OBJEXT} \ + bn_mp_or.${OBJEXT} \ + bn_mp_radix_size.${OBJEXT} \ + bn_mp_radix_smap.${OBJEXT} \ + bn_mp_read_radix.${OBJEXT} \ + bn_mp_rshd.${OBJEXT} \ + bn_mp_set.${OBJEXT} \ + bn_mp_shrink.${OBJEXT} \ + bn_mp_sqr.${OBJEXT} \ + bn_mp_sqrt.${OBJEXT} \ + bn_mp_sub.${OBJEXT} \ + bn_mp_sub_d.${OBJEXT} \ + bn_mp_to_unsigned_bin.${OBJEXT} \ + bn_mp_to_unsigned_bin_n.${OBJEXT} \ + bn_mp_toom_mul.${OBJEXT} \ + bn_mp_toom_sqr.${OBJEXT} \ + bn_mp_toradix_n.${OBJEXT} \ + bn_mp_unsigned_bin_size.${OBJEXT} \ + bn_mp_xor.${OBJEXT} \ + bn_mp_zero.${OBJEXT} \ + bn_s_mp_add.${OBJEXT} \ + bn_s_mp_mul_digs.${OBJEXT} \ + bn_s_mp_sqr.${OBJEXT} \ + bn_s_mp_sub.${OBJEXT} + + +WIN_OBJS = \ + tclWin32Dll.$(OBJEXT) \ + tclWinChan.$(OBJEXT) \ + tclWinConsole.$(OBJEXT) \ + tclWinSerial.$(OBJEXT) \ + tclWinError.$(OBJEXT) \ + tclWinFCmd.$(OBJEXT) \ + tclWinFile.$(OBJEXT) \ + tclWinInit.$(OBJEXT) \ + tclWinLoad.$(OBJEXT) \ + tclWinNotify.$(OBJEXT) \ + tclWinPipe.$(OBJEXT) \ + tclWinSock.$(OBJEXT) \ + tclWinThrd.$(OBJEXT) \ + tclWinTime.$(OBJEXT) + +COMPAT_OBJS = \ + strtoll.$(OBJEXT) strtoull.$(OBJEXT) + +PIPE_OBJS = stub16.$(OBJEXT) + +DDE_OBJS = tclWinDde.$(OBJEXT) + +REG_OBJS = tclWinReg.$(OBJEXT) + +STUB_OBJS = tclStubLib.$(OBJEXT) + +TCLSH_OBJS = tclAppInit.$(OBJEXT) + +TCL_OBJS = ${GENERIC_OBJS} $(TOMMATH_OBJS) ${WIN_OBJS} ${COMPAT_OBJS} + +TCL_DOCS = "$(ROOT_DIR_NATIVE)"/doc/*.[13n] + +all: binaries libraries doc + +tcltest: $(TCLTEST) + +binaries: @LIBRARIES@ $(TCLSH) + +# Special dependencies to make development easier +tclOO.$(OBJEXT) tclOOCall.$(OBJEXT) tclOODefineCmds.$(OBJEXT) tclOOInfo.$(OBJEXT) tclProc.$(OBJEXT): \ + $(GENERIC_DIR)/tclOO.h + +libraries: + +doc: + +winhelp: $(ROOT_DIR)/tools/man2help.tcl $(MAN2TCL) + TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \ + ./$(TCLSH) "$(ROOT_DIR_NATIVE)"/tools/man2help.tcl tcl "$(VER)" $(TCL_DOCS) + hcw /c /e tcl.hpj + +$(MAN2TCL): $(ROOT_DIR)/tools/man2tcl.c + $(CC) $(CFLAGS_OPTIMIZE) $(MAN2TCLFLAGS) -o $(MAN2TCL) "$(ROOT_DIR_NATIVE)"/tools/man2tcl.c + +$(TCLSH): $(TCL_LIB_FILE) $(TCL_STUB_LIB_FILE) $(TCLSH_OBJS) tclsh.$(RES) + $(CC) $(CFLAGS) $(TCLSH_OBJS) $(TCL_LIB_FILE) $(LIBS) \ + tclsh.$(RES) $(CC_EXENAME) $(LDFLAGS_CONSOLE) + +$(TCLTEST): $(TCL_LIB_FILE) $(TCLTEST_OBJS) $(CAT32) tclsh.$(RES) + $(CC) $(CFLAGS) $(TCLTEST_OBJS) $(TCL_LIB_FILE) $(LIBS) \ + tclsh.$(RES) $(CC_EXENAME) $(LDFLAGS_CONSOLE) + +cat32.$(OBJEXT): cat.c + $(CC) -c $(CC_SWITCHES) @DEPARG@ $(CC_OBJNAME) + +$(CAT32): cat32.$(OBJEXT) + $(CC) $(CFLAGS) cat32.$(OBJEXT) $(CC_EXENAME) $(LIBS) $(LDFLAGS_CONSOLE) + +# The following targets are configured by autoconf to generate either +# a shared library or static library + +${TCL_STUB_LIB_FILE}: ${STUB_OBJS} + @$(RM) ${TCL_STUB_LIB_FILE} + @MAKE_LIB@ ${STUB_OBJS} + @POST_MAKE_LIB@ + +${TCL_DLL_FILE}: ${TCL_OBJS} tcl.$(RES) + @$(RM) ${TCL_DLL_FILE} + @MAKE_DLL@ ${TCL_OBJS} tcl.$(RES) $(SHLIB_LD_LIBS) + +${TCL_LIB_FILE}: ${TCL_OBJS} + @$(RM) ${TCL_LIB_FILE} + @MAKE_LIB@ ${TCL_OBJS} + @POST_MAKE_LIB@ + +${DDE_DLL_FILE}: ${DDE_OBJS} ${TCL_STUB_LIB_FILE} + @$(RM) ${DDE_DLL_FILE} + @MAKE_DLL@ ${DDE_OBJS} $(TCL_STUB_LIB_FILE) $(SHLIB_LD_LIBS) + +${DDE_LIB_FILE}: ${DDE_OBJS} ${TCL_LIB_FILE} + @$(RM) ${DDE_LIB_FILE} + @MAKE_LIB@ ${DDE_OBJS} ${TCL_LIB_FILE} + +${REG_DLL_FILE}: ${REG_OBJS} ${TCL_STUB_LIB_FILE} + @$(RM) ${REG_DLL_FILE} + @MAKE_DLL@ ${REG_OBJS} $(TCL_STUB_LIB_FILE) $(SHLIB_LD_LIBS) + +${REG_LIB_FILE}: ${REG_OBJS} ${TCL_LIB_FILE} + @$(RM) ${REG_LIB_FILE} + @MAKE_LIB@ ${REG_OBJS} ${TCL_LIB_FILE} + +# PIPE_DLL_FILE is actually an executable, don't build it +# like a DLL. + +${PIPE_DLL_FILE}: ${PIPE_OBJS} + @$(RM) ${PIPE_DLL_FILE} + @MAKE_EXE@ $(CFLAGS) ${PIPE_OBJS} $(LIBS) $(LDFLAGS_CONSOLE) + +# Add the object extension to the implicit rules. By default .obj is not +# automatically added. + +.SUFFIXES: .${OBJEXT} +.SUFFIXES: .$(RES) +.SUFFIXES: .rc + +# Special case object targets + +tclWinInit.${OBJEXT}: tclWinInit.c + $(CC) -c $(CC_SWITCHES) -DBUILD_tcl $(EXTFLAGS) @DEPARG@ $(CC_OBJNAME) + +tclWinPipe.${OBJEXT}: tclWinPipe.c + $(CC) -c $(CC_SWITCHES) -DBUILD_tcl -DTCL_PIPE_DLL=\"$(PIPE_DLL_FILE)\" \ + $(EXTFLAGS) @DEPARG@ $(CC_OBJNAME) + +testMain.${OBJEXT}: tclAppInit.c + $(CC) -c $(CC_SWITCHES) -DTCL_TEST @DEPARG@ $(CC_OBJNAME) + +tclTest.${OBJEXT}: tclTest.c + $(CC) -c $(CC_SWITCHES) @DEPARG@ $(CC_OBJNAME) + +tclTestObj.${OBJEXT}: tclTestObj.c + $(CC) -c $(CC_SWITCHES) @DEPARG@ $(CC_OBJNAME) + +tclWinTest.${OBJEXT}: tclWinTest.c + $(CC) -c $(CC_SWITCHES) @DEPARG@ $(CC_OBJNAME) + +tclAppInit.${OBJEXT} : tclAppInit.c + $(CC) -c $(CC_SWITCHES) @DEPARG@ $(CC_OBJNAME) + +# The following objects should be built using the stub interfaces + +tclWinReg.${OBJEXT} : tclWinReg.c + $(CC) -c $(CC_SWITCHES) -DUSE_TCL_STUBS @DEPARG@ $(CC_OBJNAME) + +tclWinDde.${OBJEXT} : tclWinDde.c + $(CC) -c $(CC_SWITCHES) -DUSE_TCL_STUBS @DEPARG@ $(CC_OBJNAME) + +# TIP #59, embedding of configuration information into the binary library. +# +# Part of Tcl's configuration information are the paths where it was +# installed and where it will look for its libraries (which can be +# different). We derive this information from the variables which can +# be overridden by the user. As every path can be configured +# separately we do not remember one general prefix/exec_prefix but all +# the different paths individually. + +tclPkgConfig.${OBJEXT}: tclPkgConfig.c + $(CC) -c $(CC_SWITCHES) \ + -DCFG_INSTALL_LIBDIR=\"$(LIB_INSTALL_DIR)\" \ + -DCFG_INSTALL_BINDIR=\"$(BIN_INSTALL_DIR)\" \ + -DCFG_INSTALL_SCRDIR=\"$(SCRIPT_INSTALL_DIR)\" \ + -DCFG_INSTALL_INCDIR=\"$(INCLUDE_INSTALL_DIR)\" \ + -DCFG_INSTALL_DOCDIR=\"$(MAN_INSTALL_DIR)\" \ + \ + -DCFG_RUNTIME_LIBDIR=\"$(libdir)\" \ + -DCFG_RUNTIME_BINDIR=\"$(bindir)\" \ + -DCFG_RUNTIME_SCRDIR=\"$(TCL_LIBRARY)\" \ + -DCFG_RUNTIME_INCDIR=\"$(includedir)\" \ + -DCFG_RUNTIME_DOCDIR=\"$(mandir)\" \ + -DBUILD_tcl \ + @DEPARG@ $(CC_OBJNAME) + +# The following objects are part of the stub library and should not +# be built as DLL objects but none of the symbols should be exported + +tclStubLib.${OBJEXT}: tclStubLib.c + $(CC) -c $(CC_SWITCHES) -DSTATIC_BUILD @DEPARG@ $(CC_OBJNAME) + + +# Implicit rule for all object files that will end up in the Tcl library + +.c.${OBJEXT}: + $(CC) -c $(CC_SWITCHES) -DBUILD_tcl @DEPARG@ $(CC_OBJNAME) + +.rc.$(RES): + $(RC) @RC_OUT@ $@ @RC_TYPE@ @RC_DEFINES@ @RC_INCLUDE@ "$(GENERIC_DIR_NATIVE)" @RC_INCLUDE@ "$(WIN_DIR_NATIVE)" @DEPARG@ + +# The following target generates the file generic/tclDate.c +# from the yacc grammar found in generic/tclGetDate.y. This is +# only run by hand as yacc is not available in all environments. +# The name of the .c file is different than the name of the .y file +# so that make doesn't try to automatically regenerate the .c file. + +gendate: + bison --output-file=$(GENERIC_DIR)/tclDate.c \ + --name-prefix=TclDate \ + --no-lines \ + $(GENERIC_DIR)/tclGetDate.y + +# The following target generates the file generic/tclTomMath.h. +# It needs to be run (and the results checked) after updating +# to a new release of libtommath. + +gentommath_h: + $(TCL_EXE) "$(ROOT_DIR_NATIVE)\tools\fix_tommath_h.tcl" \ + "$(TOMMATH_DIR_NATIVE)\tommath.h" \ + > "$(GENERIC_DIR_NATIVE)\tclTomMath.h" + +install: all install-binaries install-libraries install-doc + +install-binaries: binaries + @for i in "$(LIB_INSTALL_DIR)" "$(BIN_INSTALL_DIR)" ; \ + do \ + if [ ! -d $$i ] ; then \ + echo "Making directory $$i"; \ + $(MKDIR) $$i; \ + chmod 755 $$i; \ + else true; \ + fi; \ + done; + @for i in dde1.3 reg1.1; \ + do \ + if [ ! -d $(LIB_INSTALL_DIR)/$$i ] ; then \ + echo "Making directory $(LIB_INSTALL_DIR)/$$i"; \ + $(MKDIR) $(LIB_INSTALL_DIR)/$$i; \ + else true; \ + fi; \ + done; + @for i in $(TCL_DLL_FILE) $(TCLSH) $(PIPE_DLL_FILE); \ + do \ + if [ -f $$i ]; then \ + echo "Installing $$i to $(BIN_INSTALL_DIR)/"; \ + $(COPY) $$i "$(BIN_INSTALL_DIR)"; \ + fi; \ + done + @for i in tclConfig.sh $(TCL_LIB_FILE) $(TCL_STUB_LIB_FILE); \ + do \ + if [ -f $$i ]; then \ + echo "Installing $$i to $(LIB_INSTALL_DIR)/"; \ + $(COPY) $$i "$(LIB_INSTALL_DIR)"; \ + fi; \ + done + @if [ -f $(DDE_DLL_FILE) ]; then \ + echo installing $(DDE_DLL_FILE); \ + $(COPY) $(DDE_DLL_FILE) $(LIB_INSTALL_DIR)/dde1.3; \ + $(COPY) $(ROOT_DIR)/library/dde/pkgIndex.tcl \ + $(LIB_INSTALL_DIR)/dde1.3; \ + fi + @if [ -f $(DDE_LIB_FILE) ]; then \ + echo installing $(DDE_LIB_FILE); \ + $(COPY) $(DDE_LIB_FILE) $(LIB_INSTALL_DIR)/dde1.3; \ + fi + @if [ -f $(REG_DLL_FILE) ]; then \ + echo installing $(REG_DLL_FILE); \ + $(COPY) $(REG_DLL_FILE) $(LIB_INSTALL_DIR)/reg1.1; \ + $(COPY) $(ROOT_DIR)/library/reg/pkgIndex.tcl \ + $(LIB_INSTALL_DIR)/reg1.1; \ + fi + @if [ -f $(REG_LIB_FILE) ]; then \ + echo installing $(REG_LIB_FILE); \ + $(COPY) $(REG_LIB_FILE) $(LIB_INSTALL_DIR)/reg1.1; \ + fi + +install-libraries: libraries install-tzdata install-msgs + @for i in $(prefix)/lib $(INCLUDE_INSTALL_DIR) \ + $(SCRIPT_INSTALL_DIR); \ + do \ + if [ ! -d $$i ] ; then \ + echo "Making directory $$i"; \ + $(MKDIR) $$i; \ + else true; \ + fi; \ + done; + @for i in http1.0 opt0.4 encoding ../tcl8 ../tcl8/8.2 ../tcl8/8.3 ../tcl8/8.5; \ + do \ + if [ ! -d $(SCRIPT_INSTALL_DIR)/$$i ] ; then \ + echo "Making directory $(SCRIPT_INSTALL_DIR)/$$i"; \ + $(MKDIR) $(SCRIPT_INSTALL_DIR)/$$i; \ + else true; \ + fi; \ + done; + @echo "Installing header files"; + @for i in "$(GENERIC_DIR)/tcl.h" "$(GENERIC_DIR)/tclDecls.h" \ + "$(GENERIC_DIR)/tclPlatDecls.h" \ + "$(GENERIC_DIR)/tclTomMath.h" \ + "$(GENERIC_DIR)/tclTomMathDecls.h" \ + "$(TOMMATH_DIR)/tommath_class.h" \ + "$(TOMMATH_DIR)/tommath_superclass.h" ; \ + do \ + $(COPY) "$$i" "$(INCLUDE_INSTALL_DIR)"; \ + done; + @echo "Installing library files to $(SCRIPT_INSTALL_DIR)"; + @for i in $(ROOT_DIR)/library/*.tcl $(ROOT_DIR)/library/tclIndex; \ + do \ + $(COPY) "$$i" "$(SCRIPT_INSTALL_DIR)"; \ + done; + @echo "Installing library http1.0 directory"; + @for j in $(ROOT_DIR)/library/http1.0/*.tcl; \ + do \ + $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/http1.0"; \ + done; + @echo "Installing package http 2.5.2 as a Tcl Module"; + @$(COPY) $(ROOT_DIR)/library/http/http.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.2/http-2.5.2.tm; + @echo "Installing library opt0.4 directory"; + @for j in $(ROOT_DIR)/library/opt/*.tcl; \ + do \ + $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/opt0.4"; \ + done; + @echo "Installing package msgcat 1.4.1 as a Tcl Module"; + @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/msgcat-1.4.1.tm; + @echo "Installing package tcltest 2.2.8 as a Tcl Module"; + @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.3/tcltest-2.2.8.tm; + @echo "Installing encodings"; + @for i in $(ROOT_DIR)/library/encoding/*.enc ; do \ + $(COPY) "$$i" "$(SCRIPT_INSTALL_DIR)/encoding"; \ + done; + +install-tzdata: + @echo "Installing time zone data" + @TCL_LIBRARY="${LIBRARY_DIR}"; export TCL_LIBRARY; \ + ./$(TCLSH) "$(ROOT_DIR)/tools/installData.tcl" \ + "$(ROOT_DIR)/library/tzdata" "$(SCRIPT_INSTALL_DIR)/tzdata" + +install-msgs: + @echo "Installing message catalogs" + @TCL_LIBRARY="${LIBRARY_DIR}"; export TCL_LIBRARY; \ + ./$(TCLSH) "$(ROOT_DIR)/tools/installData.tcl" \ + "$(ROOT_DIR)/library/msgs" "$(SCRIPT_INSTALL_DIR)/msgs" + +install-doc: doc + +# Optional target to install private headers +install-private-headers: libraries + @for i in $(PRIVATE_INCLUDE_INSTALL_DIR); \ + do \ + if [ ! -d $$i ] ; then \ + echo "Making directory $$i"; \ + $(MKDIR) $$i; \ + else true; \ + fi; \ + done; + @echo "Installing private header files"; + @for i in "$(GENERIC_DIR)/tclInt.h" "$(GENERIC_DIR)/tclIntDecls.h" \ + "$(GENERIC_DIR)/tclIntPlatDecls.h" "$(GENERIC_DIR)/tclPort.h" \ + "$(WIN_DIR)/tclWinPort.h" ; \ + do \ + $(COPY) "$$i" "$(PRIVATE_INCLUDE_INSTALL_DIR)"; \ + done; + +# Specifying TESTFLAGS on the command line is the standard way to pass +# args to tcltest, ie: +# % make test TESTFLAGS="-verbose bps -file fileName.test" + +test: binaries $(TCLTEST) + TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \ + ./$(TCLTEST) "$(ROOT_DIR_NATIVE)/tests/all.tcl" $(TESTFLAGS) \ + -load "set ::ddelib [file normalize ${DDE_DLL_FILE}]; \ + set ::reglib [file normalize ${REG_DLL_FILE}]" | ./$(CAT32) + +# Useful target to launch a built tcltest with the proper path,... +runtest: binaries $(TCLTEST) + @TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \ + ./$(TCLTEST) $(TESTFLAGS) -load "set ::ddelib [file normalize ${DDE_DLL_FILE}]; \ + set ::reglib [file normalize ${REG_DLL_FILE}]" $(SCRIPT) + +# This target can be used to run tclsh from the build directory +# via `make shell SCRIPT=foo.tcl` +shell: binaries + @TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \ + ./$(TCLSH) $(SCRIPT) + +# This target can be used to run tclsh inside either gdb or insight +gdb: binaries + @echo "set env TCL_LIBRARY=$(LIBRARY_DIR)" > gdb.run + gdb ./$(TCLSH) --command=gdb.run + rm gdb.run + +depend: + +Makefile: $(SRC_DIR)/Makefile.in + ./config.status + +cleanhelp: + $(RM) *.hlp *.cnt *.GID *.rtf man2tcl.exe + +clean: cleanhelp + $(RM) *.lib *.a *.exp *.dll *.$(RES) *.${OBJEXT} *~ \#* TAGS a.out + $(RM) $(TCLSH) $(TCLTEST) $(CAT32) + $(RM) *.pch *.ilk *.pdb + +distclean: clean + $(RM) Makefile config.status config.cache config.log tclConfig.sh \ + tcl.hpj config.status.lineno + +# +# Regenerate the stubs files. +# + +$(GENERIC_DIR)/tclStubInit.c: $(GENERIC_DIR)/tcl.decls \ + $(GENERIC_DIR)/tclInt.decls + @echo "Warning: tclStubInit.c may be out of date." + @echo "Developers may want to run \"make genstubs\" to regenerate." + @echo "This warning can be safely ignored, do not report as a bug!" + +genstubs: + $(TCL_EXE) "$(ROOT_DIR_NATIVE)\tools\genStubs.tcl" \ + "$(GENERIC_DIR_NATIVE)" \ + "$(GENERIC_DIR_NATIVE)\tcl.decls" \ + "$(GENERIC_DIR_NATIVE)\tclInt.decls" \ + "$(GENERIC_DIR_NATIVE)\tclTomMath.decls" Index: win/makefile.bc ================================================================== --- win/makefile.bc +++ win/makefile.bc @@ -232,10 +232,14 @@ $(TMPDIR)\tclLoad.obj \ $(TMPDIR)\tclMain.obj \ $(TMPDIR)\tclNamesp.obj \ $(TMPDIR)\tclNotify.obj \ $(TMPDIR)\tclObj.obj \ + $(TMPDIR)\tclOO.obj \ + $(TMPDIR)\tclOOCall.obj \ + $(TMPDIR)\tclOODefineCmds.obj \ + $(TMPDIR)\tclOOInfo.obj \ $(TMPDIR)\tclPanic.obj \ $(TMPDIR)\tclParse.obj \ $(TMPDIR)\tclParseExpr.obj \ $(TMPDIR)\tclPipe.obj \ $(TMPDIR)\tclPkg.obj \ Index: win/makefile.vc ================================================================== --- win/makefile.vc +++ win/makefile.vc @@ -10,11 +10,11 @@ # Copyright (c) 1998-2000 Ajuba Solutions. # Copyright (c) 2001-2005 ActiveState Corporation. # Copyright (c) 2001-2004 David Gravereaux. # #------------------------------------------------------------------------------ -# RCS: @(#) $Id: makefile.vc,v 1.143 2005/12/13 22:43:18 kennykb Exp $ +# RCS: @(#) $Id: makefile.vc,v 1.143.2.4 2006/10/08 17:14:33 dkf Exp $ #------------------------------------------------------------------------------ # Check to see we are configured to build with MSVC (MSDEVDIR or MSVCDIR) # or with the MS Platform SDK (MSSDK). Visual Studio .NET 2003 and 2005 define # VCINSTALLDIR instead. @@ -292,10 +292,14 @@ $(TMP_DIR)\tclLoad.obj \ $(TMP_DIR)\tclMain.obj \ $(TMP_DIR)\tclNamesp.obj \ $(TMP_DIR)\tclNotify.obj \ $(TMP_DIR)\tclObj.obj \ + $(TMP_DIR)\tclOO.obj \ + $(TMP_DIR)\tclOOCall.obj \ + $(TMP_DIR)\tclOODefineCmds.obj \ + $(TMP_DIR)\tclOOInfo.obj \ $(TMP_DIR)\tclPanic.obj \ $(TMP_DIR)\tclParse.obj \ $(TMP_DIR)\tclParseExpr.obj \ $(TMP_DIR)\tclPathObj.obj \ $(TMP_DIR)\tclPipe.obj \