diff options
| author | jan.nijtmans <nijtmans@users.sourceforge.net> | 2022-08-23 10:34:43 (GMT) |
|---|---|---|
| committer | jan.nijtmans <nijtmans@users.sourceforge.net> | 2022-08-23 10:34:43 (GMT) |
| commit | 8d919c0d03dbc5bdd562607697b0aed8be34c600 (patch) | |
| tree | 17e43a02d2875e243afc977324215c4dd0ea2c97 | |
| parent | fc14df8b55728fe31296e3135cb46e8b9a9c94fe (diff) | |
| parent | 7fd9e2f5fdd413114e252c3c3db7546551e309a9 (diff) | |
| download | tcl-8d919c0d03dbc5bdd562607697b0aed8be34c600.zip tcl-8d919c0d03dbc5bdd562607697b0aed8be34c600.tar.gz tcl-8d919c0d03dbc5bdd562607697b0aed8be34c600.tar.bz2 | |
TIP #627 implementation
| -rw-r--r-- | doc/CrtObjCmd.3 | 19 | ||||
| -rw-r--r-- | doc/CrtTrace.3 | 10 | ||||
| -rw-r--r-- | doc/NRE.3 | 19 | ||||
| -rw-r--r-- | generic/tcl.decls | 21 | ||||
| -rw-r--r-- | generic/tcl.h | 7 | ||||
| -rw-r--r-- | generic/tclBasic.c | 147 | ||||
| -rw-r--r-- | generic/tclConfig.c | 2 | ||||
| -rw-r--r-- | generic/tclDecls.h | 37 | ||||
| -rw-r--r-- | generic/tclStubInit.c | 6 | ||||
| -rw-r--r-- | generic/tclTrace.c | 50 |
10 files changed, 307 insertions, 11 deletions
diff --git a/doc/CrtObjCmd.3 b/doc/CrtObjCmd.3 index 8d10418..0490bd7 100644 --- a/doc/CrtObjCmd.3 +++ b/doc/CrtObjCmd.3 @@ -8,7 +8,7 @@ .so man.macros .BS .SH NAME -Tcl_CreateObjCommand, Tcl_DeleteCommand, Tcl_DeleteCommandFromToken, Tcl_GetCommandInfo, Tcl_GetCommandInfoFromToken, Tcl_SetCommandInfo, Tcl_SetCommandInfoFromToken, Tcl_GetCommandName, Tcl_GetCommandFullName, Tcl_GetCommandFromObj \- implement new commands in C +Tcl_CreateObjCommand, Tcl_CreateObjCommand2, Tcl_DeleteCommand, Tcl_DeleteCommandFromToken, Tcl_GetCommandInfo, Tcl_GetCommandInfoFromToken, Tcl_SetCommandInfo, Tcl_SetCommandInfoFromToken, Tcl_GetCommandName, Tcl_GetCommandFullName, Tcl_GetCommandFromObj \- implement new commands in C .SH SYNOPSIS .nf \fB#include <tcl.h>\fR @@ -16,6 +16,9 @@ Tcl_CreateObjCommand, Tcl_DeleteCommand, Tcl_DeleteCommandFromToken, Tcl_GetComm Tcl_Command \fBTcl_CreateObjCommand\fR(\fIinterp, cmdName, proc, clientData, deleteProc\fR) .sp +Tcl_Command +\fBTcl_CreateObjCommand2\fR(\fIinterp, cmdName, proc2, clientData, deleteProc\fR) +.sp int \fBTcl_DeleteCommand\fR(\fIinterp, cmdName\fR) .sp @@ -52,6 +55,9 @@ Name of command. .AP Tcl_ObjCmdProc *proc in Implementation of the new command: \fIproc\fR will be called whenever \fIcmdName\fR is invoked as a command. +.AP Tcl_ObjCmdProc2 *proc2 in +Implementation of the new command: \fIproc2\fR will be called whenever +\fIcmdName\fR is invoked as a command. .AP ClientData clientData in Arbitrary one-word value to pass to \fIproc\fR and \fIdeleteProc\fR. .AP Tcl_CmdDeleteProc *deleteProc in @@ -174,6 +180,17 @@ typedef void \fBTcl_CmdDeleteProc\fR( The \fIclientData\fR argument will be the same as the \fIclientData\fR argument passed to \fBTcl_CreateObjCommand\fR. .PP +\fBTcl_CreateObjCommand2\fR does the same as \fBTcl_CreateObjCommand\fR, +except its \fIproc2\fR argument is of type \fBTcl_ObjCmdProc2\fR. +.PP +.CS +typedef int \fBTcl_ObjCmdProc2\fR( + ClientData \fIclientData\fR, + Tcl_Interp *\fIinterp\fR, + size_t \fIobjc\fR, + Tcl_Obj *const \fIobjv\fR[]); +.CE +.PP \fBTcl_DeleteCommand\fR deletes a command from a command interpreter. Once the call completes, attempts to invoke \fIcmdName\fR in \fIinterp\fR will result in errors. diff --git a/doc/CrtTrace.3 b/doc/CrtTrace.3 index 620c081..417c892 100644 --- a/doc/CrtTrace.3 +++ b/doc/CrtTrace.3 @@ -10,7 +10,7 @@ .so man.macros .BS .SH NAME -Tcl_CreateTrace, Tcl_CreateObjTrace, Tcl_DeleteTrace \- arrange for command execution to be traced +Tcl_CreateTrace, Tcl_CreateObjTrace, Tcl_CreateObjTrace2, Tcl_DeleteTrace \- arrange for command execution to be traced .SH SYNOPSIS .nf \fB#include <tcl.h>\fR @@ -21,6 +21,9 @@ Tcl_Trace Tcl_Trace \fBTcl_CreateObjTrace\fR(\fIinterp, level, flags, objProc, clientData, deleteProc\fR) .sp +Tcl_Trace +\fBTcl_CreateObjTrace2\fR(\fIinterp, level, flags, objProc2, clientData, deleteProc\fR) +.sp \fBTcl_DeleteTrace\fR(\fIinterp, trace\fR) .SH ARGUMENTS .AS Tcl_CmdObjTraceDeleteProc *deleteProc @@ -38,11 +41,14 @@ Flags governing the trace execution. See below for details. .AP Tcl_CmdObjTraceProc *objProc in Procedure to call for each command that is executed. See below for details of the calling sequence. +.AP Tcl_CmdObjTraceProc2 *objProc2 in +Procedure to call for each command that is executed. See below for +details of the calling sequence. .AP Tcl_CmdTraceProc *proc in Procedure to call for each command that is executed. See below for details on the calling sequence. .AP ClientData clientData in -Arbitrary one-word value to pass to \fIobjProc\fR or \fIproc\fR. +Arbitrary one-word value to pass to \fIobjProc\fR, \fIobjProc2\fR or \fIproc\fR. .AP Tcl_CmdObjTraceDeleteProc *deleteProc in Procedure to call when the trace is deleted. See below for details of the calling sequence. A NULL pointer is permissible and results in no @@ -9,7 +9,7 @@ .so man.macros .BS .SH NAME -Tcl_NRCreateCommand, Tcl_NRCallObjProc, Tcl_NREvalObj, Tcl_NREvalObjv, Tcl_NRCmdSwap, Tcl_NRExprObj, Tcl_NRAddCallback \- Non-Recursive (stackless) evaluation of Tcl scripts. +Tcl_NRCreateCommand, Tcl_NRCreateCommand2, Tcl_NRCallObjProc, Tcl_NRCallObjProc2, Tcl_NREvalObj, Tcl_NREvalObjv, Tcl_NRCmdSwap, Tcl_NRExprObj, Tcl_NRAddCallback \- Non-Recursive (stackless) evaluation of Tcl scripts. .SH SYNOPSIS .nf \fB#include <tcl.h>\fR @@ -18,10 +18,17 @@ Tcl_Command \fBTcl_NRCreateCommand\fR(\fIinterp, cmdName, proc, nreProc, clientData, deleteProc\fR) .sp +Tcl_Command +\fBTcl_NRCreateCommand2\fR(\fIinterp, cmdName, proc2, nreProc2, clientData, + deleteProc\fR) +.sp int \fBTcl_NRCallObjProc\fR(\fIinterp, nreProc, clientData, objc, objv\fR) .sp int +\fBTcl_NRCallObjProc2\fR(\fIinterp, nreProc2, clientData, objc, objv\fR) +.sp +int \fBTcl_NREvalObj\fR(\fIinterp, objPtr, flags\fR) .sp int @@ -47,8 +54,15 @@ Called in order to evaluate a command. Is often just a small wrapper that uses \fBTcl_NRCallObjProc\fR to call \fInreProc\fR using a new trampoline. Behaves in the same way as the \fIproc\fR argument to \fBTcl_CreateObjCommand\fR(3) (\fIq.v.\fR). +.AP Tcl_ObjCmdProc2 *proc2 in +Called in order to evaluate a command. Is often just a small wrapper that uses +\fBTcl_NRCallObjProc2\fR to call \fInreProc2\fR using a new trampoline. Behaves +in the same way as the \fIproc2\fR argument to \fBTcl_CreateObjCommand2\fR(3) +(\fIq.v.\fR). .AP Tcl_ObjCmdProc *nreProc in Called instead of \fIproc\fR when a trampoline is already in use. +.AP Tcl_ObjCmdProc2 *nreProc2 in +Called instead of \fIproc2\fR when a trampoline is already in use. .AP ClientData clientData in Arbitrary one-word value passed to \fIproc\fR, \fInreProc\fR, \fIdeleteProc\fR and \fIobjProc\fR. @@ -104,6 +118,9 @@ first deleted. If \fIinterp\fR is in the process of being deleted \fBTcl_NRCreateCommand\fR does not create any command, does not delete any command, and returns NULL. .PP +\fBTcl_NRCreateCommand2\fR, is an alternative to \fBTcl_NRCreateCommand\fR +in the same way as \fBTcl_CreateObjCommand2\fR. +.PP \fBTcl_NREvalObj\fR pushes a function that is like \fBTcl_EvalObjEx\fR but consumes no space on the C stack. .PP 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 a0c5a91..645a581 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -2689,6 +2689,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 @@ -3322,8 +3377,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; } @@ -3400,10 +3461,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; } @@ -9100,6 +9166,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); +} + /* *---------------------------------------------------------------------- * @@ -9128,6 +9225,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/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/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 */ |
