summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
Diffstat (limited to 'generic')
-rw-r--r--generic/tcl.decls21
-rw-r--r--generic/tcl.h7
-rw-r--r--generic/tclBasic.c147
-rw-r--r--generic/tclCompCmdsSZ.c2
-rw-r--r--generic/tclConfig.c2
-rw-r--r--generic/tclDecls.h37
-rw-r--r--generic/tclExecute.c6
-rw-r--r--generic/tclOO.c16
-rw-r--r--generic/tclOO.decls14
-rw-r--r--generic/tclOO.h29
-rw-r--r--generic/tclOOCall.c6
-rw-r--r--generic/tclOODecls.h23
-rw-r--r--generic/tclOODefineCmds.c6
-rw-r--r--generic/tclOOInt.h21
-rw-r--r--generic/tclOOMethod.c140
-rw-r--r--generic/tclOOStubInit.c3
-rw-r--r--generic/tclStubInit.c6
-rw-r--r--generic/tclTrace.c50
18 files changed, 499 insertions, 37 deletions
diff --git a/generic/tcl.decls b/generic/tcl.decls
index 99c0e25..d08ba0a 100644
--- a/generic/tcl.decls
+++ b/generic/tcl.decls
@@ -2502,6 +2502,27 @@ declare 673 {
int TclGetUniChar(Tcl_Obj *objPtr, int index)
}
+declare 676 {
+ Tcl_Command Tcl_CreateObjCommand2(Tcl_Interp *interp,
+ const char *cmdName,
+ Tcl_ObjCmdProc2 *proc2, void *clientData,
+ Tcl_CmdDeleteProc *deleteProc)
+}
+declare 677 {
+ Tcl_Trace Tcl_CreateObjTrace2(Tcl_Interp *interp, int level, int flags,
+ Tcl_CmdObjTraceProc2 *objProc2, void *clientData,
+ Tcl_CmdObjTraceDeleteProc *delProc)
+}
+declare 678 {
+ Tcl_Command Tcl_NRCreateCommand2(Tcl_Interp *interp,
+ const char *cmdName, Tcl_ObjCmdProc2 *proc,
+ Tcl_ObjCmdProc2 *nreProc2, void *clientData,
+ Tcl_CmdDeleteProc *deleteProc)
+}
+declare 679 {
+ int Tcl_NRCallObjProc2(Tcl_Interp *interp, Tcl_ObjCmdProc2 *objProc2,
+ void *clientData, size_t objc, Tcl_Obj *const objv[])
+}
# ----- BASELINE -- FOR -- 8.7.0 ----- #
diff --git a/generic/tcl.h b/generic/tcl.h
index ca68eaa..101ae0b 100644
--- a/generic/tcl.h
+++ b/generic/tcl.h
@@ -678,6 +678,9 @@ typedef void (Tcl_CmdTraceProc) (ClientData clientData, Tcl_Interp *interp,
typedef int (Tcl_CmdObjTraceProc) (ClientData clientData, Tcl_Interp *interp,
int level, const char *command, Tcl_Command commandInfo, int objc,
struct Tcl_Obj *const *objv);
+typedef int (Tcl_CmdObjTraceProc2) (void *clientData, Tcl_Interp *interp,
+ int level, const char *command, Tcl_Command commandInfo, size_t objc,
+ struct Tcl_Obj *const objv[]);
typedef void (Tcl_CmdObjTraceDeleteProc) (ClientData clientData);
typedef void (Tcl_DupInternalRepProc) (struct Tcl_Obj *srcPtr,
struct Tcl_Obj *dupPtr);
@@ -702,6 +705,8 @@ typedef int (Tcl_MathProc) (ClientData clientData, Tcl_Interp *interp,
typedef void (Tcl_NamespaceDeleteProc) (ClientData clientData);
typedef int (Tcl_ObjCmdProc) (ClientData clientData, Tcl_Interp *interp,
int objc, struct Tcl_Obj *const *objv);
+typedef int (Tcl_ObjCmdProc2) (void *clientData, Tcl_Interp *interp,
+ size_t objc, struct Tcl_Obj *const *objv);
typedef int (Tcl_LibraryInitProc) (Tcl_Interp *interp);
typedef int (Tcl_LibraryUnloadProc) (Tcl_Interp *interp, int flags);
typedef void (Tcl_PanicProc) (const char *format, ...);
@@ -921,6 +926,8 @@ typedef struct Tcl_CmdInfo {
* change a command's namespace; use
* TclRenameCommand or Tcl_Eval (of 'rename')
* to do that. */
+ Tcl_ObjCmdProc2 *objProc2; /* Not used in Tcl 8.7. */
+ void *objClientData2; /* Not used in Tcl 8.7. */
} Tcl_CmdInfo;
/*
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 6727118..7a955ec 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -2690,6 +2690,61 @@ Tcl_CreateCommand(
*----------------------------------------------------------------------
*/
+typedef struct {
+ void *clientData; /* Arbitrary value to pass to object function. */
+ Tcl_ObjCmdProc2 *proc;
+ Tcl_ObjCmdProc2 *nreProc;
+ Tcl_CmdDeleteProc *deleteProc;
+} CmdWrapperInfo;
+
+
+static int cmdWrapperProc(void *clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj * const *objv)
+{
+ CmdWrapperInfo *info = (CmdWrapperInfo *)clientData;
+ return info->proc(info->clientData, interp, objc, objv);
+}
+
+static void cmdWrapperDeleteProc(void *clientData) {
+ CmdWrapperInfo *info = (CmdWrapperInfo *)clientData;
+
+ clientData = info->clientData;
+ Tcl_CmdDeleteProc *deleteProc = info->deleteProc;
+ ckfree(info);
+ if (deleteProc != NULL) {
+ deleteProc(clientData);
+ }
+}
+
+Tcl_Command
+Tcl_CreateObjCommand2(
+ Tcl_Interp *interp, /* Token for command interpreter (returned by
+ * previous call to Tcl_CreateInterp). */
+ const char *cmdName, /* Name of command. If it contains namespace
+ * qualifiers, the new command is put in the
+ * specified namespace; otherwise it is put in
+ * the global namespace. */
+ Tcl_ObjCmdProc2 *proc, /* Object-based function to associate with
+ * name. */
+ void *clientData, /* Arbitrary value to pass to object
+ * function. */
+ Tcl_CmdDeleteProc *deleteProc
+ /* If not NULL, gives a function to call when
+ * this command is deleted. */
+)
+{
+ CmdWrapperInfo *info = (CmdWrapperInfo *)ckalloc(sizeof(CmdWrapperInfo));
+ info->proc = proc;
+ info->deleteProc = deleteProc;
+ info->clientData = clientData;
+
+ return Tcl_CreateObjCommand(interp, cmdName,
+ (proc ? cmdWrapperProc : NULL),
+ info, cmdWrapperDeleteProc);
+}
+
Tcl_Command
Tcl_CreateObjCommand(
Tcl_Interp *interp, /* Token for command interpreter (returned by
@@ -3323,8 +3378,14 @@ Tcl_SetCommandInfoFromToken(
}
cmdPtr->objClientData = infoPtr->objClientData;
}
- cmdPtr->deleteProc = infoPtr->deleteProc;
- cmdPtr->deleteData = infoPtr->deleteData;
+ if (cmdPtr->deleteProc == cmdWrapperDeleteProc) {
+ CmdWrapperInfo *info = (CmdWrapperInfo *)cmdPtr->deleteData;
+ info->deleteProc = infoPtr->deleteProc;
+ info->clientData = infoPtr->deleteData;
+ } else {
+ cmdPtr->deleteProc = infoPtr->deleteProc;
+ cmdPtr->deleteData = infoPtr->deleteData;
+ }
return 1;
}
@@ -3401,10 +3462,15 @@ Tcl_GetCommandInfoFromToken(
infoPtr->objClientData = cmdPtr->objClientData;
infoPtr->proc = cmdPtr->proc;
infoPtr->clientData = cmdPtr->clientData;
- infoPtr->deleteProc = cmdPtr->deleteProc;
- infoPtr->deleteData = cmdPtr->deleteData;
+ if (cmdPtr->deleteProc == cmdWrapperDeleteProc) {
+ CmdWrapperInfo *info = (CmdWrapperInfo *)cmdPtr->deleteData;
+ infoPtr->deleteProc = info->deleteProc;
+ infoPtr->deleteData = info->clientData;
+ } else {
+ infoPtr->deleteProc = cmdPtr->deleteProc;
+ infoPtr->deleteData = cmdPtr->deleteData;
+ }
infoPtr->namespacePtr = (Tcl_Namespace *) cmdPtr->nsPtr;
-
return 1;
}
@@ -9101,6 +9167,37 @@ Tcl_NRCallObjProc(
return TclNRRunCallbacks(interp, TCL_OK, rootPtr);
}
+int wrapperNRObjProc(
+ void *clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ CmdWrapperInfo *info = (CmdWrapperInfo *)clientData;
+ clientData = info->clientData;
+ Tcl_ObjCmdProc2 *proc = info->proc;
+ ckfree(info);
+ return proc(clientData, interp, objc, objv);
+}
+
+int
+Tcl_NRCallObjProc2(
+ Tcl_Interp *interp,
+ Tcl_ObjCmdProc2 *objProc,
+ void *clientData,
+ size_t objc,
+ Tcl_Obj *const objv[])
+{
+ NRE_callback *rootPtr = TOP_CB(interp);
+ CmdWrapperInfo *info = (CmdWrapperInfo *)ckalloc(sizeof(CmdWrapperInfo));
+ info->clientData = clientData;
+ info->proc = objProc;
+
+ TclNRAddCallback(interp, Dispatch, wrapperNRObjProc, info,
+ INT2PTR(objc), objv);
+ return TclNRRunCallbacks(interp, TCL_OK, rootPtr);
+}
+
/*
*----------------------------------------------------------------------
*
@@ -9129,6 +9226,46 @@ Tcl_NRCallObjProc(
*----------------------------------------------------------------------
*/
+static int cmdWrapperNreProc(
+ void *clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ CmdWrapperInfo *info = (CmdWrapperInfo *)clientData;
+ return info->nreProc(info->clientData, interp, objc, objv);
+}
+
+Tcl_Command
+Tcl_NRCreateCommand2(
+ Tcl_Interp *interp, /* Token for command interpreter (returned by
+ * previous call to Tcl_CreateInterp). */
+ const char *cmdName, /* Name of command. If it contains namespace
+ * qualifiers, the new command is put in the
+ * specified namespace; otherwise it is put in
+ * the global namespace. */
+ Tcl_ObjCmdProc2 *proc, /* Object-based function to associate with
+ * name, provides direct access for direct
+ * calls. */
+ Tcl_ObjCmdProc2 *nreProc, /* Object-based function to associate with
+ * name, provides NR implementation */
+ void *clientData, /* Arbitrary value to pass to object
+ * function. */
+ Tcl_CmdDeleteProc *deleteProc)
+ /* If not NULL, gives a function to call when
+ * this command is deleted. */
+{
+ CmdWrapperInfo *info = (CmdWrapperInfo *)ckalloc(sizeof(CmdWrapperInfo));
+ info->proc = proc;
+ info->nreProc = nreProc;
+ info->deleteProc = deleteProc;
+ info->clientData = clientData;
+ return Tcl_NRCreateCommand(interp, cmdName,
+ (proc ? cmdWrapperProc : NULL),
+ (nreProc ? cmdWrapperNreProc : NULL),
+ info, cmdWrapperDeleteProc);
+}
+
Tcl_Command
Tcl_NRCreateCommand(
Tcl_Interp *interp, /* Token for command interpreter (returned by
diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c
index 29e48eb..7804bf9 100644
--- a/generic/tclCompCmdsSZ.c
+++ b/generic/tclCompCmdsSZ.c
@@ -2427,7 +2427,7 @@ IssueSwitchJumpTable(
* point to here.
*/
- Tcl_SetHashValue(hPtr, CurrentOffset(envPtr) - jumpLocation);
+ Tcl_SetHashValue(hPtr, INT2PTR(CurrentOffset(envPtr) - jumpLocation));
}
Tcl_DStringFree(&buffer);
} else {
diff --git a/generic/tclConfig.c b/generic/tclConfig.c
index a145bac..5bffbcb 100644
--- a/generic/tclConfig.c
+++ b/generic/tclConfig.c
@@ -194,7 +194,7 @@ QueryConfigObjCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
- struct Tcl_Obj *const *objv)
+ Tcl_Obj *const *objv)
{
QCCD *cdPtr = (QCCD *)clientData;
Tcl_Obj *pkgName = cdPtr->pkg;
diff --git a/generic/tclDecls.h b/generic/tclDecls.h
index b869c97..3917d0f 100644
--- a/generic/tclDecls.h
+++ b/generic/tclDecls.h
@@ -1975,6 +1975,27 @@ EXTERN const char * TclUtfAtIndex(const char *src, int index);
EXTERN Tcl_Obj * TclGetRange(Tcl_Obj *objPtr, int first, int last);
/* 673 */
EXTERN int TclGetUniChar(Tcl_Obj *objPtr, int index);
+/* Slot 674 is reserved */
+/* Slot 675 is reserved */
+/* 676 */
+EXTERN Tcl_Command Tcl_CreateObjCommand2(Tcl_Interp *interp,
+ const char *cmdName, Tcl_ObjCmdProc2 *proc2,
+ void *clientData,
+ Tcl_CmdDeleteProc *deleteProc);
+/* 677 */
+EXTERN Tcl_Trace Tcl_CreateObjTrace2(Tcl_Interp *interp, int level,
+ int flags, Tcl_CmdObjTraceProc2 *objProc2,
+ void *clientData,
+ Tcl_CmdObjTraceDeleteProc *delProc);
+/* 678 */
+EXTERN Tcl_Command Tcl_NRCreateCommand2(Tcl_Interp *interp,
+ const char *cmdName, Tcl_ObjCmdProc2 *proc,
+ Tcl_ObjCmdProc2 *nreProc2, void *clientData,
+ Tcl_CmdDeleteProc *deleteProc);
+/* 679 */
+EXTERN int Tcl_NRCallObjProc2(Tcl_Interp *interp,
+ Tcl_ObjCmdProc2 *objProc2, void *clientData,
+ size_t objc, Tcl_Obj *const objv[]);
typedef struct {
const struct TclPlatStubs *tclPlatStubs;
@@ -2684,6 +2705,12 @@ typedef struct TclStubs {
const char * (*tclUtfAtIndex) (const char *src, int index); /* 671 */
Tcl_Obj * (*tclGetRange) (Tcl_Obj *objPtr, int first, int last); /* 672 */
int (*tclGetUniChar) (Tcl_Obj *objPtr, int index); /* 673 */
+ void (*reserved674)(void);
+ void (*reserved675)(void);
+ Tcl_Command (*tcl_CreateObjCommand2) (Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc2 *proc2, void *clientData, Tcl_CmdDeleteProc *deleteProc); /* 676 */
+ Tcl_Trace (*tcl_CreateObjTrace2) (Tcl_Interp *interp, int level, int flags, Tcl_CmdObjTraceProc2 *objProc2, void *clientData, Tcl_CmdObjTraceDeleteProc *delProc); /* 677 */
+ Tcl_Command (*tcl_NRCreateCommand2) (Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc2 *proc, Tcl_ObjCmdProc2 *nreProc2, void *clientData, Tcl_CmdDeleteProc *deleteProc); /* 678 */
+ int (*tcl_NRCallObjProc2) (Tcl_Interp *interp, Tcl_ObjCmdProc2 *objProc2, void *clientData, size_t objc, Tcl_Obj *const objv[]); /* 679 */
} TclStubs;
extern const TclStubs *tclStubsPtr;
@@ -4062,6 +4089,16 @@ extern const TclStubs *tclStubsPtr;
(tclStubsPtr->tclGetRange) /* 672 */
#define TclGetUniChar \
(tclStubsPtr->tclGetUniChar) /* 673 */
+/* Slot 674 is reserved */
+/* Slot 675 is reserved */
+#define Tcl_CreateObjCommand2 \
+ (tclStubsPtr->tcl_CreateObjCommand2) /* 676 */
+#define Tcl_CreateObjTrace2 \
+ (tclStubsPtr->tcl_CreateObjTrace2) /* 677 */
+#define Tcl_NRCreateCommand2 \
+ (tclStubsPtr->tcl_NRCreateCommand2) /* 678 */
+#define Tcl_NRCallObjProc2 \
+ (tclStubsPtr->tcl_NRCallObjProc2) /* 679 */
#endif /* defined(USE_TCL_STUBS) */
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 407b4ed..d4bba5e 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -4789,7 +4789,11 @@ TEBCresume(
Method *const mPtr =
contextPtr->callPtr->chain[newDepth].mPtr;
- return mPtr->typePtr->callProc(mPtr->clientData, interp,
+ if (mPtr->typePtr->version < TCL_OO_METHOD_VERSION_2) {
+ return mPtr->typePtr->callProc(mPtr->clientData, interp,
+ (Tcl_ObjectContext) contextPtr, opnd, objv);
+ }
+ return ((Tcl_MethodCallProc2 *)(void *)(mPtr->typePtr->callProc))(mPtr->clientData, interp,
(Tcl_ObjectContext) contextPtr, opnd, objv);
}
diff --git a/generic/tclOO.c b/generic/tclOO.c
index 0cd08d2..5bd687a 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -391,9 +391,9 @@ InitFoundation(
*/
TclNewLiteralStringObj(namePtr, "new");
- Tcl_NewInstanceMethod(interp, (Tcl_Object) fPtr->classCls->thisPtr,
+ TclNewInstanceMethod(interp, (Tcl_Object) fPtr->classCls->thisPtr,
namePtr /* keeps ref */, 0 /* private */, NULL, NULL);
- fPtr->classCls->constructorPtr = (Method *) Tcl_NewMethod(interp,
+ fPtr->classCls->constructorPtr = (Method *) TclNewMethod(interp,
(Tcl_Class) fPtr->classCls, NULL, 0, &classConstructor, NULL);
/*
@@ -2246,7 +2246,7 @@ CloneObjectMethod(
Tcl_Obj *namePtr)
{
if (mPtr->typePtr == NULL) {
- Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr, namePtr,
+ TclNewInstanceMethod(interp, (Tcl_Object) oPtr, namePtr,
mPtr->flags & PUBLIC_METHOD, NULL, NULL);
} else if (mPtr->typePtr->cloneProc) {
ClientData newClientData;
@@ -2255,10 +2255,10 @@ CloneObjectMethod(
&newClientData) != TCL_OK) {
return TCL_ERROR;
}
- Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr, namePtr,
+ TclNewInstanceMethod(interp, (Tcl_Object) oPtr, namePtr,
mPtr->flags & PUBLIC_METHOD, mPtr->typePtr, newClientData);
} else {
- Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr, namePtr,
+ TclNewInstanceMethod(interp, (Tcl_Object) oPtr, namePtr,
mPtr->flags & PUBLIC_METHOD, mPtr->typePtr, mPtr->clientData);
}
return TCL_OK;
@@ -2275,7 +2275,7 @@ CloneClassMethod(
Method *m2Ptr;
if (mPtr->typePtr == NULL) {
- m2Ptr = (Method *) Tcl_NewMethod(interp, (Tcl_Class) clsPtr,
+ m2Ptr = (Method *) TclNewMethod(interp, (Tcl_Class) clsPtr,
namePtr, mPtr->flags & PUBLIC_METHOD, NULL, NULL);
} else if (mPtr->typePtr->cloneProc) {
ClientData newClientData;
@@ -2284,11 +2284,11 @@ CloneClassMethod(
&newClientData) != TCL_OK) {
return TCL_ERROR;
}
- m2Ptr = (Method *) Tcl_NewMethod(interp, (Tcl_Class) clsPtr,
+ m2Ptr = (Method *) TclNewMethod(interp, (Tcl_Class) clsPtr,
namePtr, mPtr->flags & PUBLIC_METHOD, mPtr->typePtr,
newClientData);
} else {
- m2Ptr = (Method *) Tcl_NewMethod(interp, (Tcl_Class) clsPtr,
+ m2Ptr = (Method *) TclNewMethod(interp, (Tcl_Class) clsPtr,
namePtr, mPtr->flags & PUBLIC_METHOD, mPtr->typePtr,
mPtr->clientData);
}
diff --git a/generic/tclOO.decls b/generic/tclOO.decls
index c6ffccd..c933872 100644
--- a/generic/tclOO.decls
+++ b/generic/tclOO.decls
@@ -135,6 +135,20 @@ declare 30 {
declare 31 {
Tcl_Obj *Tcl_GetObjectClassName(Tcl_Interp *interp, Tcl_Object object)
}
+declare 32 {
+ int Tcl_MethodIsType2(Tcl_Method method, const Tcl_MethodType2 *typePtr,
+ void **clientDataPtr)
+}
+declare 33 {
+ Tcl_Method Tcl_NewInstanceMethod2(Tcl_Interp *interp, Tcl_Object object,
+ Tcl_Obj *nameObj, int flags, const Tcl_MethodType2 *typePtr,
+ void *clientData)
+}
+declare 34 {
+ Tcl_Method Tcl_NewMethod2(Tcl_Interp *interp, Tcl_Class cls,
+ Tcl_Obj *nameObj, int flags, const Tcl_MethodType2 *typePtr,
+ void *clientData)
+}
######################################################################
# Private API, exposed to support advanced OO systems that plug in on top of
diff --git a/generic/tclOO.h b/generic/tclOO.h
index 4a3398f..6f18491 100644
--- a/generic/tclOO.h
+++ b/generic/tclOO.h
@@ -24,8 +24,8 @@
* win/tclooConfig.sh
*/
-#define TCLOO_VERSION "1.2.0"
-#define TCLOO_PATCHLEVEL TCLOO_VERSION
+#define TCLOO_VERSION "1.3"
+#define TCLOO_PATCHLEVEL TCLOO_VERSION ".0"
#include "tcl.h"
@@ -40,7 +40,7 @@ extern "C" {
extern const char *TclOOInitializeStubs(
Tcl_Interp *, const char *version);
#define Tcl_OOInitStubs(interp) \
- TclOOInitializeStubs((interp), TCLOO_VERSION)
+ TclOOInitializeStubs((interp), TCLOO_PATCHLEVEL)
#ifndef USE_TCL_STUBS
# define TclOOInitializeStubs(interp, version) (TCLOO_PATCHLEVEL)
#endif
@@ -62,6 +62,8 @@ typedef struct Tcl_ObjectContext_ *Tcl_ObjectContext;
typedef int (Tcl_MethodCallProc)(void *clientData, Tcl_Interp *interp,
Tcl_ObjectContext objectContext, int objc, Tcl_Obj *const *objv);
+typedef int (Tcl_MethodCallProc2)(void *clientData, Tcl_Interp *interp,
+ Tcl_ObjectContext objectContext, size_t objc, Tcl_Obj *const *objv);
typedef void (Tcl_MethodDeleteProc)(void *clientData);
typedef int (Tcl_CloneProc)(Tcl_Interp *interp, void *oldClientData,
void **newClientData);
@@ -77,7 +79,7 @@ typedef int (Tcl_ObjectMapMethodNameProc)(Tcl_Interp *interp,
typedef struct {
int version; /* Structure version field. Always to be equal
- * to TCL_OO_METHOD_VERSION_CURRENT in
+ * to TCL_OO_METHOD_VERSION_(1|CURRENT) in
* declarations. */
const char *name; /* Name of this type of method, mostly for
* debugging purposes. */
@@ -92,12 +94,31 @@ typedef struct {
* be copied directly. */
} Tcl_MethodType;
+typedef struct {
+ int version; /* Structure version field. Always to be equal
+ * to TCL_OO_METHOD_VERSION_2 in
+ * declarations. */
+ const char *name; /* Name of this type of method, mostly for
+ * debugging purposes. */
+ Tcl_MethodCallProc2 *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_CloneProc *cloneProc; /* How to copy this method's type-specific
+ * data, or NULL if the type-specific data can
+ * be copied directly. */
+} Tcl_MethodType2;
+
/*
* 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 compatibility.
*/
+#define TCL_OO_METHOD_VERSION_1 1
+#define TCL_OO_METHOD_VERSION_2 2
#define TCL_OO_METHOD_VERSION_CURRENT 1
/*
diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c
index d265c1a..a9ed6bf 100644
--- a/generic/tclOOCall.c
+++ b/generic/tclOOCall.c
@@ -369,7 +369,11 @@ TclOOInvokeContext(
* Run the method implementation.
*/
- return mPtr->typePtr->callProc(mPtr->clientData, interp,
+ if (mPtr->typePtr->version < TCL_OO_METHOD_VERSION_2) {
+ return (mPtr->typePtr->callProc)(mPtr->clientData, interp,
+ (Tcl_ObjectContext) contextPtr, objc, objv);
+ }
+ return ((Tcl_MethodCallProc2 *)(void *)(mPtr->typePtr->callProc))(mPtr->clientData, interp,
(Tcl_ObjectContext) contextPtr, objc, objv);
}
diff --git a/generic/tclOODecls.h b/generic/tclOODecls.h
index 6ba5d14..13e07ec 100644
--- a/generic/tclOODecls.h
+++ b/generic/tclOODecls.h
@@ -123,6 +123,20 @@ TCLAPI Tcl_Class Tcl_GetClassOfObject(Tcl_Object object);
/* 31 */
TCLAPI Tcl_Obj * Tcl_GetObjectClassName(Tcl_Interp *interp,
Tcl_Object object);
+/* 32 */
+TCLAPI int Tcl_MethodIsType2(Tcl_Method method,
+ const Tcl_MethodType2 *typePtr,
+ void **clientDataPtr);
+/* 33 */
+TCLAPI Tcl_Method Tcl_NewInstanceMethod2(Tcl_Interp *interp,
+ Tcl_Object object, Tcl_Obj *nameObj,
+ int flags, const Tcl_MethodType2 *typePtr,
+ void *clientData);
+/* 34 */
+TCLAPI Tcl_Method Tcl_NewMethod2(Tcl_Interp *interp, Tcl_Class cls,
+ Tcl_Obj *nameObj, int flags,
+ const Tcl_MethodType2 *typePtr,
+ void *clientData);
typedef struct {
const struct TclOOIntStubs *tclOOIntStubs;
@@ -164,6 +178,9 @@ typedef struct TclOOStubs {
int (*tcl_MethodIsPrivate) (Tcl_Method method); /* 29 */
Tcl_Class (*tcl_GetClassOfObject) (Tcl_Object object); /* 30 */
Tcl_Obj * (*tcl_GetObjectClassName) (Tcl_Interp *interp, Tcl_Object object); /* 31 */
+ int (*tcl_MethodIsType2) (Tcl_Method method, const Tcl_MethodType2 *typePtr, void **clientDataPtr); /* 32 */
+ Tcl_Method (*tcl_NewInstanceMethod2) (Tcl_Interp *interp, Tcl_Object object, Tcl_Obj *nameObj, int flags, const Tcl_MethodType2 *typePtr, void *clientData); /* 33 */
+ Tcl_Method (*tcl_NewMethod2) (Tcl_Interp *interp, Tcl_Class cls, Tcl_Obj *nameObj, int flags, const Tcl_MethodType2 *typePtr, void *clientData); /* 34 */
} TclOOStubs;
extern const TclOOStubs *tclOOStubsPtr;
@@ -242,6 +259,12 @@ extern const TclOOStubs *tclOOStubsPtr;
(tclOOStubsPtr->tcl_GetClassOfObject) /* 30 */
#define Tcl_GetObjectClassName \
(tclOOStubsPtr->tcl_GetObjectClassName) /* 31 */
+#define Tcl_MethodIsType2 \
+ (tclOOStubsPtr->tcl_MethodIsType2) /* 32 */
+#define Tcl_NewInstanceMethod2 \
+ (tclOOStubsPtr->tcl_NewInstanceMethod2) /* 33 */
+#define Tcl_NewMethod2 \
+ (tclOOStubsPtr->tcl_NewMethod2) /* 34 */
#endif /* defined(USE_TCLOO_STUBS) */
diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c
index 42c6637..686fd00 100644
--- a/generic/tclOODefineCmds.c
+++ b/generic/tclOODefineCmds.c
@@ -2286,12 +2286,12 @@ TclOODefineSlots(
if (slotObject == NULL) {
continue;
}
- Tcl_NewInstanceMethod(fPtr->interp, slotObject, getName, 0,
+ TclNewInstanceMethod(fPtr->interp, slotObject, getName, 0,
&slotInfoPtr->getterType, NULL);
- Tcl_NewInstanceMethod(fPtr->interp, slotObject, setName, 0,
+ TclNewInstanceMethod(fPtr->interp, slotObject, setName, 0,
&slotInfoPtr->setterType, NULL);
if (slotInfoPtr->resolverType.callProc) {
- Tcl_NewInstanceMethod(fPtr->interp, slotObject, resolveName, 0,
+ TclNewInstanceMethod(fPtr->interp, slotObject, resolveName, 0,
&slotInfoPtr->resolverType, NULL);
}
}
diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h
index 9488271..725c4ce 100644
--- a/generic/tclOOInt.h
+++ b/generic/tclOOInt.h
@@ -235,14 +235,14 @@ typedef struct Object {
* other spots). */
#define FORCE_UNKNOWN 0x10000 /* States that we are *really* looking up the
* unknown method handler at that point. */
-#define HAS_PRIVATE_METHODS 0x20000
- /* Object/class has (or had) private methods,
- * and so shouldn't be cached so
- * aggressively. */
-#define DONT_DELETE 0x40000 /* Inhibit deletion of this object. Used
+#define DONT_DELETE 0x20000 /* Inhibit deletion of this object. Used
* during fundamental object type mutation to
* make sure that the object actually survives
* to the end of the operation. */
+#define HAS_PRIVATE_METHODS 0x40000
+ /* Object/class has (or had) private methods,
+ * and so shouldn't be cached so
+ * aggressively. */
/*
* And the definition of a class. Note that every class also has an associated
@@ -492,6 +492,17 @@ MODULE_SCOPE void TclOOAddToMixinSubs(Class *subPtr, Class *mixinPtr);
MODULE_SCOPE void TclOOAddToSubclasses(Class *subPtr, Class *superPtr);
MODULE_SCOPE Class * TclOOAllocClass(Tcl_Interp *interp,
Object *useThisObj);
+MODULE_SCOPE int TclMethodIsType(Tcl_Method method,
+ const Tcl_MethodType *typePtr,
+ void **clientDataPtr);
+MODULE_SCOPE Tcl_Method TclNewInstanceMethod(Tcl_Interp *interp,
+ Tcl_Object object, Tcl_Obj *nameObj,
+ int flags, const Tcl_MethodType *typePtr,
+ void *clientData);
+MODULE_SCOPE Tcl_Method TclNewMethod(Tcl_Interp *interp, Tcl_Class cls,
+ Tcl_Obj *nameObj, int flags,
+ const Tcl_MethodType *typePtr,
+ void *clientData);
MODULE_SCOPE int TclNRNewObjectInstance(Tcl_Interp *interp,
Tcl_Class cls, const char *nameStr,
const char *nsNameStr, int objc,
diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c
index ae1f3bd..73368e4 100644
--- a/generic/tclOOMethod.c
+++ b/generic/tclOOMethod.c
@@ -126,7 +126,7 @@ static const Tcl_MethodType fwdMethodType = {
*/
Tcl_Method
-Tcl_NewInstanceMethod(
+TclNewInstanceMethod(
TCL_UNUSED(Tcl_Interp *),
Tcl_Object object, /* The object that has the method attached to
* it. */
@@ -187,6 +187,50 @@ Tcl_NewInstanceMethod(
oPtr->epoch++;
return (Tcl_Method) mPtr;
}
+Tcl_Method
+Tcl_NewInstanceMethod(
+ TCL_UNUSED(Tcl_Interp *),
+ 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. */
+ void *clientData) /* Some data associated with the particular
+ * method to be created. */
+{
+ if (typePtr->version > TCL_OO_METHOD_VERSION_1) {
+ Tcl_Panic("%s: Wrong version in typePtr->version, should be TCL_OO_METHOD_VERSION_1", "Tcl_NewInstanceMethod");
+ }
+ return TclNewInstanceMethod(NULL, object, nameObj, flags,
+ (const Tcl_MethodType *)typePtr, clientData);
+}
+Tcl_Method
+Tcl_NewInstanceMethod2(
+ TCL_UNUSED(Tcl_Interp *),
+ 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_MethodType2 *typePtr,
+ /* The type of method this is, which defines
+ * how to invoke, delete and clone the
+ * method. */
+ void *clientData) /* Some data associated with the particular
+ * method to be created. */
+{
+ if (typePtr->version < TCL_OO_METHOD_VERSION_2) {
+ Tcl_Panic("%s: Wrong version in typePtr->version, should be TCL_OO_METHOD_VERSION_2", "Tcl_NewInstanceMethod2");
+ }
+ return TclNewInstanceMethod(NULL, object, nameObj, flags,
+ (const Tcl_MethodType *)typePtr, clientData);
+}
/*
* ----------------------------------------------------------------------
@@ -199,7 +243,7 @@ Tcl_NewInstanceMethod(
*/
Tcl_Method
-Tcl_NewMethod(
+TclNewMethod(
TCL_UNUSED(Tcl_Interp *),
Tcl_Class cls, /* The class to attach the method to. */
Tcl_Obj *nameObj, /* The name of the object. May be NULL (e.g.,
@@ -255,6 +299,48 @@ Tcl_NewMethod(
return (Tcl_Method) mPtr;
}
+
+Tcl_Method
+Tcl_NewMethod(
+ TCL_UNUSED(Tcl_Interp *),
+ 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. */
+ void *clientData) /* Some data associated with the particular
+ * method to be created. */
+{
+ if (typePtr->version > TCL_OO_METHOD_VERSION_1) {
+ Tcl_Panic("%s: Wrong version in typePtr->version, should be TCL_OO_METHOD_VERSION_1", "Tcl_NewMethod");
+ }
+ return TclNewMethod(NULL, cls, nameObj, flags, typePtr, clientData);
+}
+
+Tcl_Method
+Tcl_NewMethod2(
+ TCL_UNUSED(Tcl_Interp *),
+ 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_MethodType2 *typePtr,
+ /* The type of method this is, which defines
+ * how to invoke, delete and clone the
+ * method. */
+ void *clientData) /* Some data associated with the particular
+ * method to be created. */
+{
+ if (typePtr->version < TCL_OO_METHOD_VERSION_2) {
+ Tcl_Panic("%s: Wrong version in typePtr->version, should be TCL_OO_METHOD_VERSION_2", "Tcl_NewMethod2");
+ }
+ return TclNewMethod(NULL, cls, nameObj, flags, (const Tcl_MethodType *)typePtr, clientData);
+}
/*
* ----------------------------------------------------------------------
@@ -304,7 +390,7 @@ TclOONewBasicMethod(
Tcl_Obj *namePtr = Tcl_NewStringObj(dcm->name, -1);
Tcl_IncrRefCount(namePtr);
- Tcl_NewMethod(interp, (Tcl_Class) clsPtr, namePtr,
+ TclNewMethod(interp, (Tcl_Class) clsPtr, namePtr,
(dcm->isPublic ? PUBLIC_METHOD : 0), &dcm->definition, NULL);
Tcl_DecrRefCount(namePtr);
}
@@ -529,7 +615,7 @@ TclOOMakeProcInstanceMethod(
}
}
- return Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr, nameObj, flags,
+ return TclNewInstanceMethod(interp, (Tcl_Object) oPtr, nameObj, flags,
typePtr, clientData);
}
@@ -642,7 +728,7 @@ TclOOMakeProcMethod(
}
}
- return Tcl_NewMethod(interp, (Tcl_Class) clsPtr, nameObj, flags, typePtr,
+ return TclNewMethod(interp, (Tcl_Class) clsPtr, nameObj, flags, typePtr,
clientData);
}
@@ -1402,7 +1488,7 @@ TclOONewForwardInstanceMethod(
fmPtr = (ForwardMethod *)ckalloc(sizeof(ForwardMethod));
fmPtr->prefixObj = prefixObj;
Tcl_IncrRefCount(prefixObj);
- return (Method *) Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr,
+ return (Method *) TclNewInstanceMethod(interp, (Tcl_Object) oPtr,
nameObj, flags, &fwdMethodType, fmPtr);
}
@@ -1441,7 +1527,7 @@ TclOONewForwardMethod(
fmPtr = (ForwardMethod *)ckalloc(sizeof(ForwardMethod));
fmPtr->prefixObj = prefixObj;
Tcl_IncrRefCount(prefixObj);
- return (Method *) Tcl_NewMethod(interp, (Tcl_Class) clsPtr, nameObj,
+ return (Method *) TclNewMethod(interp, (Tcl_Class) clsPtr, nameObj,
flags, &fwdMethodType, fmPtr);
}
@@ -1672,6 +1758,23 @@ Tcl_MethodName(
}
int
+TclMethodIsType(
+ Tcl_Method method,
+ const Tcl_MethodType *typePtr,
+ void **clientDataPtr)
+{
+ Method *mPtr = (Method *) method;
+
+ if (mPtr->typePtr == typePtr) {
+ if (clientDataPtr != NULL) {
+ *clientDataPtr = mPtr->clientData;
+ }
+ return 1;
+ }
+ return 0;
+}
+
+int
Tcl_MethodIsType(
Tcl_Method method,
const Tcl_MethodType *typePtr,
@@ -1679,6 +1782,9 @@ Tcl_MethodIsType(
{
Method *mPtr = (Method *) method;
+ if (typePtr->version > TCL_OO_METHOD_VERSION_1) {
+ Tcl_Panic("%s: Wrong version in typePtr->version, should be TCL_OO_METHOD_VERSION_1", "Tcl_MethodIsType");
+ }
if (mPtr->typePtr == typePtr) {
if (clientDataPtr != NULL) {
*clientDataPtr = mPtr->clientData;
@@ -1689,6 +1795,26 @@ Tcl_MethodIsType(
}
int
+Tcl_MethodIsType2(
+ Tcl_Method method,
+ const Tcl_MethodType2 *typePtr,
+ void **clientDataPtr)
+{
+ Method *mPtr = (Method *) method;
+
+ if (typePtr->version < TCL_OO_METHOD_VERSION_2) {
+ Tcl_Panic("%s: Wrong version in typePtr->version, should be TCL_OO_METHOD_VERSION_2", "Tcl_MethodIsType2");
+ }
+ if (mPtr->typePtr == (const Tcl_MethodType *)typePtr) {
+ if (clientDataPtr != NULL) {
+ *clientDataPtr = mPtr->clientData;
+ }
+ return 1;
+ }
+ return 0;
+}
+
+int
Tcl_MethodIsPublic(
Tcl_Method method)
{
diff --git a/generic/tclOOStubInit.c b/generic/tclOOStubInit.c
index b9034f0..7b653cb 100644
--- a/generic/tclOOStubInit.c
+++ b/generic/tclOOStubInit.c
@@ -76,6 +76,9 @@ const TclOOStubs tclOOStubs = {
Tcl_MethodIsPrivate, /* 29 */
Tcl_GetClassOfObject, /* 30 */
Tcl_GetObjectClassName, /* 31 */
+ Tcl_MethodIsType2, /* 32 */
+ Tcl_NewInstanceMethod2, /* 33 */
+ Tcl_NewMethod2, /* 34 */
};
/* !END!: Do not edit above this line. */
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index 2b7952d..4941348 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -2034,6 +2034,12 @@ const TclStubs tclStubs = {
TclUtfAtIndex, /* 671 */
TclGetRange, /* 672 */
TclGetUniChar, /* 673 */
+ 0, /* 674 */
+ 0, /* 675 */
+ Tcl_CreateObjCommand2, /* 676 */
+ Tcl_CreateObjTrace2, /* 677 */
+ Tcl_NRCreateCommand2, /* 678 */
+ Tcl_NRCallObjProc2, /* 679 */
};
/* !END!: Do not edit above this line. */
diff --git a/generic/tclTrace.c b/generic/tclTrace.c
index c8f10e3..0c243a6 100644
--- a/generic/tclTrace.c
+++ b/generic/tclTrace.c
@@ -1759,7 +1759,7 @@ TraceExecutionProc(
const char *command,
TCL_UNUSED(Tcl_Command),
int objc,
- struct Tcl_Obj *const objv[])
+ Tcl_Obj *const objv[])
{
int call = 0;
Interp *iPtr = (Interp *) interp;
@@ -2121,6 +2121,54 @@ TraceVarProc(
*----------------------------------------------------------------------
*/
+typedef struct {
+ Tcl_CmdObjTraceProc2 *proc;
+ Tcl_CmdObjTraceDeleteProc *delProc;
+ void *clientData;
+} TraceWrapperInfo;
+
+static int traceWrapperProc(
+ void *clientData,
+ Tcl_Interp *interp,
+ int level,
+ const char *command,
+ Tcl_Command commandInfo,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ TraceWrapperInfo *info = (TraceWrapperInfo *)clientData;
+ return info->proc(info->clientData, interp, level, command, commandInfo, objc, objv);
+}
+
+static void traceWrapperDelProc(void *clientData)
+{
+ TraceWrapperInfo *info = (TraceWrapperInfo *)clientData;
+ clientData = info->clientData;
+ if (info->delProc) {
+ info->delProc(clientData);
+ }
+ ckfree(info);
+}
+
+Tcl_Trace
+Tcl_CreateObjTrace2(
+ Tcl_Interp *interp, /* Tcl interpreter */
+ int level, /* Maximum nesting level */
+ int flags, /* Flags, see above */
+ Tcl_CmdObjTraceProc2 *proc, /* Trace callback */
+ void *clientData, /* Client data for the callback */
+ Tcl_CmdObjTraceDeleteProc *delProc)
+ /* Function to call when trace is deleted */
+{
+ TraceWrapperInfo *info = (TraceWrapperInfo *)ckalloc(sizeof(TraceWrapperInfo));
+ info->proc = proc;
+ info->delProc = delProc;
+ info->clientData = clientData;
+ return Tcl_CreateObjTrace(interp, level, flags,
+ (proc ? traceWrapperProc : NULL),
+ info, traceWrapperDelProc);
+}
+
Tcl_Trace
Tcl_CreateObjTrace(
Tcl_Interp *interp, /* Tcl interpreter */
generated by cgit v0.12 at 2024-11-16 12:30:27 (GMT)