/Doc/lib/

mand token that identifies the command to be invoked. The token +may be passed to \fBTcl_GetCommandName\fR, +\fBTcl_GetCommandTokenInfo\fR, or \fBTcl_SetCommandTokenInfo\fR to +manipulate the definition of the command. The \fIobjc\fR and \fIobjv\fR +parameters designate the final parameter count and parameter vector +that will be passed to the command, and have had all substitutions +performed. +.PP +The \fIobjProc\fR callback is expected to return a standard Tcl status +return code. If this code is \fBTCL_OK\fR (the normal case), then +the Tcl interpreter will invoke the command. Any other return code +is treated as if the command returned that status, and the command is +\fInot\fR invoked. +.PP +The \fIobjProc\fR callback must not modify \fIobjv\fR in any way. It +is, however, permissible to change the command by calling +\fBTcl_SetCommandTokenInfo\fR prior to returning. Any such change +takes effect immediately, and the command is invoked with the new +information. .PP Tracing will only occur for commands at nesting level less than or equal to the \fIlevel\fR parameter (i.e. the \fIlevel\fR -parameter to \fIproc\fR will always be less than or equal to the +parameter to \fIobjProc\fR will always be less than or equal to the \fIlevel\fR parameter to \fBTcl_CreateTrace\fR). .PP -Calls to \fIproc\fR will be made by the Tcl parser immediately before +Tracing has a significant effect on runtime performance because it +causes the bytecode compiler to refrain from generating in-line code +for Tcl commands such as \fBif\fR and \fBwhile\fR in order that they +may be traced. If traces for the built-in commands are not required, +the \fIflags\fR parameter may be set to the constant value +\fBTCL_ALLOW_INLINE_COMPILATION\fR. In this case, traces on built-in +commands may or may not result in trace callbacks, depending on the +state of the interpreter, but run-time performance will be improved +significantly. (This functionality is desirable, for example, when +using \fBTcl_CreateObjTrace\fR to implement an execution time +profiler.) +.PP +Calls to \fIobjProc\fR will be made by the Tcl parser immediately before it calls the command procedure for the command (\fIcmdProc\fR). This occurs after argument parsing and substitution, so tracing for substituted commands occurs before tracing of the commands @@ -93,14 +128,59 @@ containing the substitutions. If there is a syntax error in a command, or if there is no command procedure associated with a command name, then no tracing will occur for that command. If a string passed to Tcl_Eval contains multiple commands (bracketed, or -on different lines) then multiple calls to \fIproc\fR will occur, -one for each command. The \fIcommand\fR string for each of these -trace calls will reflect only a single command, not the entire string -passed to Tcl_Eval. +on different lines) then multiple calls to \fIobjProc\fR will occur, +one for each command. .PP \fBTcl_DeleteTrace\fR removes a trace, so that no future calls will be made to the procedure associated with the trace. After \fBTcl_DeleteTrace\fR returns, the caller should never again use the \fItrace\fR token. - +.PP +When \fBTcl_DeleteTrace\fR is called, the interpreter invokes the +\fIdeleteProc\fR that was passed as a parameter to +\fBTcl_CreateObjTrace\fR. The \fIdeleteProc\fR must match the type, +\fBTcl_CmdObjTraceDeleteProc\fR: +.CS +typedef void \fBTcl_CmdObjTraceDeleteProc\fR( + \fBClientData\fR \fIclientData\fR +); +.CE +The \fIclientData\fR parameter will be the same as the +\fIclientData\fR parameter that was originally passed to +\fBTcl_CreateObjTrace\fR. +.PP +\fBTcl_CreateTrace\fR is an alternative interface for command tracing, +\fInot recommended for new applications\fR. It is provided for backward +compatibility with code that was developed for older versions of the +Tcl interpreter. It is similar to \fBTcl_CreateObjTrace\fR, except +that its \fIproc\fR parameter should have arguments and result that +match the type \fBTcl_CmdTraceProc\fR: +.CS +typedef void Tcl_CmdTraceProc( + ClientData \fIclientData\fR, + Tcl_Interp *\fIinterp\fR, + int \fIlevel\fR, + char *\fIcommand\fR, + Tcl_CmdProc *\fIcmdProc\fR, + ClientData \fIcmdClientData\fR, + int \fIargc\fR, + char *\fIargv\fR[]); +.CE +The parameters to the \fIproc\fR callback are similar to those of the +\fIobjProc\fR callback above. The \fIcommandToken\fR is +replaced with \fIcmdProc\fR, a pointer to the (string-based) command +procedure that will be invoked; and \fIcmdClientData\fR, the client +data that will be passed to the procedure. The \fIobjc\fR parameter +is replaced with an \fIargv\fR parameter, that gives the arguments to +the command as character strings. +\fIProc\fR must not modify the \fIcommand\fR or \fIargv\fR strings. +.PP +If a trace created with \fBTcl_CreateTrace\fR is in effect, inline +compilation of Tcl commands such as \fBif\fR and \fBwhile\fR is always +disabled. There is no notification when a trace created with +\fBTcl_CreateTrace\fR is deleted. +There is no way to be notified when the trace created by +\fBTcl_CreateTrace\fR is deleted. There is no way for the \fIproc\fR +associated with a call to \fBTcl_CreateTrace\fR to abort execution of +\fIcommand\fR. .SH KEYWORDS command, create, delete, interpreter, trace diff --git a/generic/tcl.decls b/generic/tcl.decls index c17195f..9e6e3b4 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -7,10 +7,11 @@ # # # Copyright (c) 1998-1999 by Scriptics Corporation. +# 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: tcl.decls,v 1.81 2002/02/08 02:52:54 dgp Exp $ +# RCS: @(#) $Id: tcl.decls,v 1.82 2002/02/10 20:36:33 kennykb Exp $ library tcl @@ -801,7 +802,7 @@ declare 225 generic { } declare 226 generic { int Tcl_SetCommandInfo(Tcl_Interp *interp, CONST char *cmdName, \ - Tcl_CmdInfo *infoPtr) + CONST Tcl_CmdInfo *infoPtr) } declare 227 generic { void Tcl_SetErrno(int err) @@ -1700,6 +1701,25 @@ declare 482 generic { void Tcl_GetTime( Tcl_Time* timeBuf ) } +# New exports due to TIP#32 + +declare 483 generic { + Tcl_Trace Tcl_CreateObjTrace( Tcl_Interp* interp, + int level, + int flags, + Tcl_CmdObjTraceProc* objProc, + ClientData clientData, + Tcl_CmdObjTraceDeleteProc* delProc ) +} +declare 484 generic { + int Tcl_GetCommandInfoFromToken( Tcl_Command token, + Tcl_CmdInfo* infoPtr ) +} +declare 485 generic { + int Tcl_SetCommandInfoFromToken( Tcl_Command token, + CONST Tcl_CmdInfo* infoPtr ) +} + ############################################################################## # Define the platform specific public Tcl interface. These functions are diff --git a/generic/tcl.h b/generic/tcl.h index b95e9a8..d9526b7 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -8,11 +8,12 @@ * Copyright (c) 1993-1996 Lucent Technologies. * Copyright (c) 1994-1998 Sun Microsystems, Inc. * Copyright (c) 1998-2000 by Scriptics Corporation. + * 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.113 2002/02/08 02:52:54 dgp Exp $ + * RCS: @(#) $Id: tcl.h,v 1.114 2002/02/10 20:36:34 kennykb Exp $ */ #ifndef _TCL @@ -580,6 +581,15 @@ typedef int (Tcl_CmdProc) _ANSI_ARGS_((ClientData clientData, typedef void (Tcl_CmdTraceProc) _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int level, char *command, Tcl_CmdProc *proc, ClientData cmdClientData, int argc, char *argv[])); +typedef int (Tcl_CmdObjTraceProc) _ANSI_ARGS_(( + ClientData clientData, + Tcl_Interp* interp, + int level, + CONST char* command, + Tcl_Command commandInfo, + int objc, + struct Tcl_Obj *CONST objv[] )); +typedef void (Tcl_CmdObjTraceDeleteProc) _ANSI_ARGS_((ClientData clientData)); typedef void (Tcl_DupInternalRepProc) _ANSI_ARGS_((struct Tcl_Obj *srcPtr, struct Tcl_Obj *dupPtr)); typedef int (Tcl_EncodingConvertProc)_ANSI_ARGS_((ClientData clientData, @@ -959,6 +969,8 @@ typedef struct Tcl_DString { #define TCL_TRACE_RENAME 0x2000 #define TCL_TRACE_DELETE 0x4000 +#define TCL_ALLOW_INLINE_COMPILATION 0x20000 + /* * The TCL_PARSE_PART1 flag is deprecated and has no effect. * The part1 is now always parsed whenever the part2 is NULL. diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 133228a..d9765a0 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -8,12 +8,12 @@ * Copyright (c) 1987-1994 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. * Copyright (c) 1998-1999 by Scriptics Corporation. - * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. + * 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.45 2002/01/29 02:40:49 hobbs Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.46 2002/02/10 20:36:34 kennykb Exp $ */ #include "tclInt.h" @@ -32,6 +32,14 @@ static char * CallCommandTraces _ANSI_ARGS_((Interp *iPtr, static void DeleteInterpProc _ANSI_ARGS_((Tcl_Interp *interp)); static void ProcessUnexpectedResult _ANSI_ARGS_(( Tcl_Interp *interp, int returnCode)); +static int StringTraceProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp* interp, + int level, + CONST char* command, + Tcl_Command commandInfo, + int objc, + Tcl_Obj *CONST objv[])); +static void StringTraceDeleteProc _ANSI_ARGS_((ClientData clientData)); extern TclStubs tclStubs; @@ -242,6 +250,15 @@ static CmdInfo builtInCmds[] = { (CompileProc *) NULL, 0} }; +/* + * The following structure holds the client data for string-based + * trace procs + */ + +typedef struct StringTraceData { + ClientData clientData; /* Client data from Tcl_CreateTrace */ + Tcl_CmdTraceProc* proc; /* Trace procedure from Tcl_CreateTrace */ +} StringTraceData; /* *---------------------------------------------------------------------- @@ -338,6 +355,7 @@ Tcl_CreateInterp() iPtr->scriptFile = NULL; iPtr->flags = 0; iPtr->tracePtr = NULL; + iPtr->tracesForbiddingInline = 0; iPtr->activeCmdTracePtr = NULL; iPtr->assocData = (Tcl_HashTable *) NULL; iPtr->execEnvPtr = NULL; /* set after namespaces initialized */ @@ -1053,10 +1071,7 @@ DeleteInterpProc(interp) } TclFreePackageInfo(iPtr); while (iPtr->tracePtr != NULL) { - Trace *nextPtr = iPtr->tracePtr->nextPtr; - - ckfree((char *) iPtr->tracePtr); - iPtr->tracePtr = nextPtr; + Tcl_DeleteTrace( (Tcl_Interp*) iPtr, (Tcl_Trace) iPtr->tracePtr ); } if (iPtr->execEnvPtr != NULL) { TclDeleteExecEnv(iPtr->execEnvPtr); @@ -2034,14 +2049,47 @@ Tcl_SetCommandInfo(interp, cmdName, infoPtr) Tcl_Interp *interp; /* Interpreter in which to look * for command. */ CONST char *cmdName; /* Name of desired command. */ - Tcl_CmdInfo *infoPtr; /* Where to find information + CONST Tcl_CmdInfo *infoPtr; /* Where to find information * to store in the command. */ { Tcl_Command cmd; - Command *cmdPtr; cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL, /*flags*/ 0); + + return Tcl_SetCommandInfoFromToken( cmd, infoPtr ); + +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetCommandInfoFromToken -- + * + * Modifies various information about a Tcl command. Note that + * this procedure will not change a command's namespace; use + * Tcl_RenameCommand to do that. Also, the isNativeObjectProc + * member of *infoPtr is ignored. + * + * Results: + * If cmdName exists in interp, then the information at *infoPtr + * is stored with the command in place of the current information + * and 1 is returned. If the command doesn't exist then 0 is + * returned. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_SetCommandInfoFromToken( cmd, infoPtr ) + Tcl_Command cmd; + CONST Tcl_CmdInfo* infoPtr; +{ + Command* cmdPtr; /* Internal representation of the command */ + if (cmd == (Tcl_Command) NULL) { return 0; } @@ -2093,11 +2141,41 @@ Tcl_GetCommandInfo(interp, cmdName, infoPtr) * command. */ { Tcl_Command cmd; - Command *cmdPtr; cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL, /*flags*/ 0); - if (cmd == (Tcl_Command) NULL) { + + return Tcl_GetCommandInfoFromToken( cmd, infoPtr ); + +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetCommandInfoFromToken -- + * + * Returns various information about a Tcl command. + * + * Results: + * Copies information from the command identified by 'cmd' into + * a caller-supplied structure and returns 1. If the 'cmd' is + * NULL, leaves the structure untouched and returns 0. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetCommandInfoFromToken( cmd, infoPtr ) + Tcl_Command cmd; + Tcl_CmdInfo* infoPtr; +{ + + Command* cmdPtr; /* Internal representation of the command */ + + if ( cmd == (Tcl_Command) NULL ) { return 0; } @@ -2116,7 +2194,9 @@ Tcl_GetCommandInfo(interp, cmdName, infoPtr) infoPtr->deleteProc = cmdPtr->deleteProc; infoPtr->deleteData = cmdPtr->deleteData; infoPtr->namespacePtr = (Tcl_Namespace *) cmdPtr->nsPtr; + return 1; + } /* @@ -2832,11 +2912,12 @@ TclEvalObjvInternal(interp, objc, objv, command, length, flags) Command *cmdPtr; Interp *iPtr = (Interp *) interp; Tcl_Obj **newObjv; - int i, code; + int i; Trace *tracePtr, *nextPtr; - char **argv, *commandCopy; + char *commandCopy; CallFrame *savedVarFramePtr; /* Saves old copy of iPtr->varFramePtr * in case TCL_EVAL_GLOBAL was set. */ + int code = TCL_OK; if (objc == 0) { return TCL_OK; @@ -2881,46 +2962,56 @@ TclEvalObjvInternal(interp, objc, objv, command, length, flags) * Call trace procedures if needed. */ - if (command != NULL) { - argv = NULL; + if ( command != NULL && iPtr->tracePtr != NULL ) { commandCopy = command; - for (tracePtr = iPtr->tracePtr; tracePtr != NULL; tracePtr = nextPtr) { + /* + * Make a copy of the command if necessary, so that trace + * procs will see it. + */ + + if (length < 0) { + length = strlen(command); + } else if ((size_t)length < strlen(command)) { + commandCopy = (char *) ckalloc((unsigned) (length + 1)); + strncpy(commandCopy, command, (size_t) length); + commandCopy[length] = 0; + } + + /* + * Walk through the trace procs + */ + + for ( tracePtr = iPtr->tracePtr; + (code == TCL_OK) && (tracePtr != NULL); + tracePtr = nextPtr) { nextPtr = tracePtr->nextPtr; if (iPtr->numLevels > tracePtr->level) { continue; } /* - * This is a bit messy because we have to emulate the old trace - * interface, which uses strings for everything. + * Invoke one trace proc */ - - if (argv == NULL) { - argv = (char **) ckalloc((unsigned) (objc + 1) * sizeof(char *)); - for (i = 0; i < objc; i++) { - argv[i] = Tcl_GetString(objv[i]); - } - argv[objc] = 0; - - if (length < 0) { - length = strlen(command); - } else if ((size_t)length < strlen(command)) { - commandCopy = (char *) ckalloc((unsigned) (length + 1)); - strncpy(commandCopy, command, (size_t) length); - commandCopy[length] = 0; - } - } - (*tracePtr->proc)(tracePtr->clientData, interp, iPtr->numLevels, - commandCopy, cmdPtr->proc, cmdPtr->clientData, - objc, argv); - } - if (argv != NULL) { - ckfree((char *) argv); + + code = (tracePtr->proc)( tracePtr->clientData, + (Tcl_Interp*) iPtr, + iPtr->numLevels, + commandCopy, + (Tcl_Command) cmdPtr, + objc, + objv ); } + + /* + * If we had to copy the command for the trace procs, free the + * copy. + */ + if (commandCopy != command) { ckfree((char *) commandCopy); } + } /* @@ -2928,12 +3019,14 @@ TclEvalObjvInternal(interp, objc, objv, command, length, flags) */ iPtr->cmdCount++; - savedVarFramePtr = iPtr->varFramePtr; - if (flags & TCL_EVAL_GLOBAL) { - iPtr->varFramePtr = NULL; + if ( code == TCL_OK ) { + savedVarFramePtr = iPtr->varFramePtr; + if (flags & TCL_EVAL_GLOBAL) { + iPtr->varFramePtr = NULL; + } + code = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, objc, objv); + iPtr->varFramePtr = savedVarFramePtr; } - code = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, objc, objv); - iPtr->varFramePtr = savedVarFramePtr; if (Tcl_AsyncReady()) { code = Tcl_AsyncInvoke(interp, code); } @@ -4517,6 +4610,114 @@ Tcl_ExprString(interp, string) /* *---------------------------------------------------------------------- * + * Tcl_CreateObjTrace -- + * + * Arrange for a procedure to be called to trace command execution. + * + * Results: + * The return value is a token for the trace, which may be passed + * to Tcl_DeleteTrace to eliminate the trace. + * + * Side effects: + * From now on, proc will be called just before a command procedure + * is called to execute a Tcl command. Calls to proc will have the + * following form: + * + * void proc( ClientData clientData, + * Tcl_Interp* interp, + * int level, + * CONST char* command, + * Tcl_Command commandInfo, + * int objc, + * Tcl_Obj *CONST objv[] ); + * + * The 'clientData' and 'interp' arguments to 'proc' will be the + * same as the arguments to Tcl_CreateObjTrace. The 'level' + * argument gives the nesting depth of command interpretation within + * the interpreter. The 'command' argument is the ASCII text of + * the command being evaluated -- before any substitutions are + * performed. The 'commandInfo' argument gives a handle to the + * command procedure that will be evaluated. The 'objc' and 'objv' + * parameters give the parameter vector that will be passed to the + * command procedure. proc does not return a value. + * + * It is permissible for 'proc' to call Tcl_SetCommandTokenInfo + * to change the command procedure or client data for the command + * being evaluated, and these changes will take effect with the + * current evaluation. + * + * The 'level' argument specifies the maximum nesting level of calls + * to be traced. If the execution depth of the interpreter exceeds + * 'level', the trace callback is not executed. + * + * The 'flags' argument is either zero or the value, + * TCL_ALLOW_INLINE_COMPILATION. If the TCL_ALLOW_INLINE_COMPILATION + * flag is not present, the bytecode compiler will not generate inline + * code for Tcl's built-in commands. This behavior will have a significant + * impact on performance, but will ensure that all command evaluations are + * traced. If the TCL_ALLOW_INLINE_COMPILATION flag is present, the + * bytecode compiler will have its normal behavior of compiling in-line + * code for some of Tcl's built-in commands. In this case, the tracing + * will be imprecise -- in-line code will not be traced -- but run-time + * performance will be improved. The latter behavior is desired for + * many applications such as profiling of run time. + * + * When the trace is deleted, the 'delProc' procedure will be invoked, + * passing it the original client data. + * + *---------------------------------------------------------------------- + */ + +Tcl_Trace +Tcl_CreateObjTrace( interp, level, flags, proc, clientData, delProc ) + Tcl_Interp* interp; /* Tcl interpreter */ + int level; /* Maximum nesting level */ + int flags; /* Flags, see above */ + Tcl_CmdObjTraceProc* proc; /* Trace callback */ + ClientData clientData; /* Client data for the callback */ + Tcl_CmdObjTraceDeleteProc* delProc; + /* Procedure to call when trace is deleted */ +{ + register Trace *tracePtr; + register Interp *iPtr = (Interp *) interp; + + /* Test if this trace allows inline compilation of commands */ + + if ( ! ( flags & TCL_ALLOW_INLINE_COMPILATION ) ) { + + if ( iPtr->tracesForbiddingInline == 0 ) { + + /* + * When the first trace forbidding inline compilation is + * created, invalidate existing compiled code for this + * interpreter and arrange (by setting the + * DONT_COMPILE_CMDS_INLINE flag) that when compiling new + * code, no commands will be compiled inline (i.e., into + * an inline sequence of instructions). We do this because + * commands that were compiled inline will never result in + * a command trace being called. + */ + + iPtr->compileEpoch++; + iPtr->flags |= DONT_COMPILE_CMDS_INLINE; + } + ++ iPtr->tracesForbiddingInline; + } + + tracePtr = (Trace *) ckalloc(sizeof(Trace)); + tracePtr->level = level; + tracePtr->proc = proc; + tracePtr->clientData = clientData; + tracePtr->delProc = delProc; + tracePtr->nextPtr = iPtr->tracePtr; + iPtr->tracePtr = tracePtr; + + return (Tcl_Trace) tracePtr; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_CreateTrace -- * * Arrange for a procedure to be called to trace command execution. @@ -4566,28 +4767,98 @@ Tcl_CreateTrace(interp, level, proc, clientData) * command. */ ClientData clientData; /* Arbitrary value word to pass to proc. */ { - register Trace *tracePtr; - register Interp *iPtr = (Interp *) interp; + + StringTraceData* data; + data = (StringTraceData*) ckalloc( sizeof( *data )); + data->clientData = clientData; + data->proc = proc; + return Tcl_CreateObjTrace( interp, level, 0, StringTraceProc, + (ClientData) data, StringTraceDeleteProc ); +} + +/* + *---------------------------------------------------------------------- + * + * StringTraceProc -- + * + * Invoke a string-based trace procedure from an object-based + * callback. + * + * Results: + * None. + * + * Side effects: + * Whatever the string-based trace procedure does. + * + *---------------------------------------------------------------------- + */ + +static int +StringTraceProc( clientData, interp, level, command, commandInfo, objc, objv ) + ClientData clientData; + Tcl_Interp* interp; + int level; + CONST char* command; + Tcl_Command commandInfo; + int objc; + Tcl_Obj *CONST *objv; +{ + StringTraceData* data = (StringTraceData*) clientData; + Command* cmdPtr = (Command*) commandInfo; + + CONST char** argv; /* Args to pass to string trace proc */ + + int i; + + /* + * This is a bit messy because we have to emulate the old trace + * interface, which uses strings for everything. + */ + + argv = (CONST char **) ckalloc((unsigned) ( (objc + 1) + * sizeof(CONST char *) )); + for (i = 0; i < objc; i++) { + argv[i] = Tcl_GetString(objv[i]); + } + argv[objc] = 0; /* - * Invalidate existing compiled code for this interpreter and arrange - * (by setting the DONT_COMPILE_CMDS_INLINE flag) that when compiling - * new code, no commands will be compiled inline (i.e., into an inline - * sequence of instructions). We do this because commands that were - * compiled inline will never result in a command trace being called. + * Invoke the command procedure. Note that we cast away const-ness + * on two parameters for compatibility with legacy code; the code + * MUST NOT modify either command or argv. */ + + ( data->proc )( data->clientData, interp, level, + (char*) command, cmdPtr->proc, cmdPtr->clientData, + objc, (char**) argv ); - iPtr->compileEpoch++; - iPtr->flags |= DONT_COMPILE_CMDS_INLINE; + ckfree( (char*) argv ); - tracePtr = (Trace *) ckalloc(sizeof(Trace)); - tracePtr->level = level; - tracePtr->proc = proc; - tracePtr->clientData = clientData; - tracePtr->nextPtr = iPtr->tracePtr; - iPtr->tracePtr = tracePtr; + return TCL_OK; - return (Tcl_Trace) tracePtr; +} + +/* + *---------------------------------------------------------------------- + * + * StringTraceDeleteProc -- + * + * Clean up memory when a string-based trace is deleted. + * + * Results: + * None. + * + * Side effects: + * Allocated memory is returned to the system. + * + *---------------------------------------------------------------------- + */ + +static void +StringTraceDeleteProc( clientData ) + ClientData clientData; +{ + ckfree( (char*) clientData ); } /* @@ -4613,31 +4884,48 @@ Tcl_DeleteTrace(interp, trace) Tcl_Trace trace; /* Token for trace (returned previously by * Tcl_CreateTrace). */ { - register Interp *iPtr = (Interp *) interp; - register Trace *tracePtr = (Trace *) trace; - register Trace *tracePtr2; + Interp *iPtr = (Interp *) interp; + Trace *tracePtr = (Trace *) trace; + register Trace **tracePtr2 = &( iPtr->tracePtr ); - if (iPtr->tracePtr == tracePtr) { - iPtr->tracePtr = tracePtr->nextPtr; - ckfree((char *) tracePtr); - } else { - for (tracePtr2 = iPtr->tracePtr; tracePtr2 != NULL; - tracePtr2 = tracePtr2->nextPtr) { - if (tracePtr2->nextPtr == tracePtr) { - tracePtr2->nextPtr = tracePtr->nextPtr; - ckfree((char *) tracePtr); - break; - } + /* + * Locate the trace entry in the interpreter's trace list, + * and remove it from the list. + */ + + while ( (*tracePtr2) != NULL && (*tracePtr2) != tracePtr ) { + tracePtr2 = &((*tracePtr2)->nextPtr); + } + if ( tracePtr2 == NULL ) { + return; + } + (*tracePtr2) = (*tracePtr2)->nextPtr; + + /* + * If the trace forbids bytecode compilation, change the interpreter's + * state. If bytecode compilation is now permitted, flag the fact and + * advance the compilation epoch so that procs will be recompiled to + * take advantage of it. + */ + + if ( ! (tracePtr->flags & TCL_ALLOW_INLINE_COMPILATION ) ) { + -- iPtr->tracesForbiddingInline; + if ( iPtr->tracesForbiddingInline == 0 ) { + iPtr->flags &= ~DONT_COMPILE_CMDS_INLINE; + ++ iPtr->compileEpoch; } } - if (iPtr->tracePtr == NULL) { - /* - * When compiling new code, allow commands to be compiled inline. - */ + /* + * Execute any delete callback. + */ + + ( tracePtr->delProc )( tracePtr->clientData ); + + /* Delete the trace object */ + + ckfree( (char*) tracePtr ); - iPtr->flags &= ~DONT_COMPILE_CMDS_INLINE; - } } /* diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 73790cb..563805d 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclDecls.h,v 1.81 2002/02/08 02:52:54 dgp Exp $ + * RCS: @(#) $Id: tclDecls.h,v 1.82 2002/02/10 20:36:34 kennykb Exp $ */ #ifndef _TCLDECLS @@ -738,7 +738,8 @@ EXTERN int Tcl_SetChannelOption _ANSI_ARGS_(( CONST char * newValue)); /* 226 */ EXTERN int Tcl_SetCommandInfo _ANSI_ARGS_((Tcl_Interp * interp, - CONST char * cmdName, Tcl_CmdInfo * infoPtr)); + CONST char * cmdName, + CONST Tcl_CmdInfo * infoPtr)); /* 227 */ EXTERN void Tcl_SetErrno _ANSI_ARGS_((int err)); /* 228 */ @@ -1519,6 +1520,19 @@ EXTERN int Tcl_EvalTokensStandard _ANSI_ARGS_(( int count)); /* 482 */ EXTERN void Tcl_GetTime _ANSI_ARGS_((Tcl_Time* timeBuf)); +/* 483 */ +EXTERN Tcl_Trace Tcl_CreateObjTrace _ANSI_ARGS_((Tcl_Interp* interp, + int level, int flags, + Tcl_CmdObjTraceProc* objProc, + ClientData clientData, + Tcl_CmdObjTraceDeleteProc* delProc)); +/* 484 */ +EXTERN int Tcl_GetCommandInfoFromToken _ANSI_ARGS_(( + Tcl_Command token, Tcl_CmdInfo* infoPtr)); +/* 485 */ +EXTERN int Tcl_SetCommandInfoFromToken _ANSI_ARGS_(( + Tcl_Command token, + CONST Tcl_CmdInfo* infoPtr)); typedef struct TclStubHooks { struct TclPlatStubs *tclPlatStubs; @@ -1804,7 +1818,7 @@ typedef struct TclStubs { void (*tcl_SetAssocData) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_InterpDeleteProc * proc, ClientData clientData)); /* 223 */ void (*tcl_SetChannelBufferSize) _ANSI_ARGS_((Tcl_Channel chan, int sz)); /* 224 */ int (*tcl_SetChannelOption) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan, CONST char * optionName, CONST char * newValue)); /* 225 */ - int (*tcl_SetCommandInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * cmdName, Tcl_CmdInfo * infoPtr)); /* 226 */ + int (*tcl_SetCommandInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * cmdName, CONST Tcl_CmdInfo * infoPtr)); /* 226 */ void (*tcl_SetErrno) _ANSI_ARGS_((int err)); /* 227 */ void (*tcl_SetErrorCode) _ANSI_ARGS_(TCL_VARARGS(Tcl_Interp *,interp)); /* 228 */ void (*tcl_SetMaxBlockTime) _ANSI_ARGS_((Tcl_Time * timePtr)); /* 229 */ @@ -2061,6 +2075,9 @@ typedef struct TclStubs { void (*tcl_FSMountsChanged) _ANSI_ARGS_((Tcl_Filesystem * fsPtr)); /* 480 */ int (*tcl_EvalTokensStandard) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Token * tokenPtr, int count)); /* 481 */ void (*tcl_GetTime) _ANSI_ARGS_((Tcl_Time* timeBuf)); /* 482 */ + Tcl_Trace (*tcl_CreateObjTrace) _ANSI_ARGS_((Tcl_Interp* interp, int level, int