Added Tcl_CreateObjTrace, Tcl_GetCommandInfoFromToken and

Tcl_SetCommandInfoFromToken. (TIPs #32 and #79.)

7 files changed, 517 insertions, 93 deletions

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 flags, Tcl_CmdObjTraceProc* objProc, ClientData clientData, Tcl_CmdObjTraceDeleteProc* delProc)); /* 483 */
+    int (*tcl_GetCommandInfoFromToken) _ANSI_ARGS_((Tcl_Command token, Tcl_CmdInfo* infoPtr)); /* 484 */
+    int (*tcl_SetCommandInfoFromToken) _ANSI_ARGS_((Tcl_Command token, CONST Tcl_CmdInfo* infoPtr)); /* 485 */
 } TclStubs;
 
 #ifdef __cplusplus
@@ -4033,6 +4050,18 @@ extern TclStubs *tclStubsPtr;
 #define Tcl_GetTime \
 	(tclStubsPtr->tcl_GetTime) /* 482 */
 #endif
+#ifndef Tcl_CreateObjTrace
+#define Tcl_CreateObjTrace \
+	(tclStubsPtr->tcl_CreateObjTrace) /* 483 */
+#endif
+#ifndef Tcl_GetCommandInfoFromToken
+#define Tcl_GetCommandInfoFromToken \
+	(tclStubsPtr->tcl_GetCommandInfoFromToken) /* 484 */
+#endif
+#ifndef Tcl_SetCommandInfoFromToken
+#define Tcl_SetCommandInfoFromToken \
+	(tclStubsPtr->tcl_SetCommandInfoFromToken) /* 485 */
+#endif
 
 #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */
 
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 4b59e9f..dcb573c 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -7,12 +7,12 @@
  * Copyright (c) 1993-1997 Lucent Technologies.
  * Copyright (c) 1994-1998 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: tclInt.h,v 1.78 2002/01/31 04:39:43 dgp Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.79 2002/02/10 20:36:34 kennykb Exp $
  */
 
 #ifndef _TCLINT
@@ -646,9 +646,13 @@ typedef struct Proc {
 typedef struct Trace {
     int level;			/* Only trace commands at nesting level
 				 * less than or equal to this. */
-    Tcl_CmdTraceProc *proc;	/* Procedure to call to trace command. */
+    Tcl_CmdObjTraceProc *proc;	/* Procedure to call to trace command. */
     ClientData clientData;	/* Arbitrary value to pass to proc. */
     struct Trace *nextPtr;	/* Next in list of traces for this interp. */
+    int flags;			/* Flags governing the trace - see
+				 * Tcl_CreateObjTrace for details */
+    Tcl_CmdObjTraceDeleteProc* delProc;
+				/* Procedure to call when trace is deleted */
 } Trace;
 
 /*
@@ -1301,6 +1305,10 @@ typedef struct Interp {
     ActiveCommandTrace *activeCmdTracePtr;
 				/* First in list of active command traces for
 				 * interp, or NULL if no active traces. */
+
+    int tracesForbiddingInline; /* Count of traces (in the list headed by
+				 * tracePtr) that forbid inline bytecode
+				 * compilation */
     /*
      * Statistical information about the bytecode compiler and interpreter's
      * operation.
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index 9f739bd..7285dac 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -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: tclStubInit.c,v 1.66 2002/01/05 22:55:52 dgp Exp $
+ * RCS: @(#) $Id: tclStubInit.c,v 1.67 2002/02/10 20:36:34 kennykb Exp $
  */
 
 #include "tclInt.h"
@@ -885,6 +885,9 @@ TclStubs tclStubs = {
     Tcl_FSMountsChanged, /* 480 */
     Tcl_EvalTokensStandard, /* 481 */
     Tcl_GetTime, /* 482 */
+    Tcl_CreateObjTrace, /* 483 */
+    Tcl_GetCommandInfoFromToken, /* 484 */
+    Tcl_SetCommandInfoFromToken, /* 485 */
 };
 
 /* !END!: Do not edit above this line. */
diff --git a/generic/tclTest.c b/generic/tclTest.c
index d220a9f..a8635bd 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -13,7 +13,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclTest.c,v 1.42 2002/02/01 17:17:59 vincentdarley Exp $
+ * RCS: @(#) $Id: tclTest.c,v 1.43 2002/02/10 20:36:34 kennykb Exp $
  */
 
 #define TCL_TEST
@@ -168,8 +168,16 @@ static int              NoopCmd _ANSI_ARGS_((ClientData clientData,
 static int              NoopObjCmd _ANSI_ARGS_((ClientData clientData,
                             Tcl_Interp *interp, int objc,
 			    Tcl_Obj *CONST objv[]));
+static int		ObjTraceProc _ANSI_ARGS_(( ClientData clientData,
+						   Tcl_Interp* interp,
+						   int level,
+						   CONST char* command,
+						   Tcl_Command commandToken,
+						   int objc,
+						   Tcl_Obj *CONST objv[] ));
+static void		ObjTraceDeleteProc _ANSI_ARGS_(( ClientData ));
 static void		PrintParse _ANSI_ARGS_((Tcl_Interp *interp,
-			    Tcl_Parse *parsePtr));
+						Tcl_Parse *parsePtr));
 static void		SpecialFree _ANSI_ARGS_((char *blockPtr));
 static int		StaticInitProc _ANSI_ARGS_((Tcl_Interp *interp));
 static int		TestaccessprocCmd _ANSI_ARGS_((ClientData dummy,
@@ -1031,9 +1039,30 @@ TestcmdtraceCmd(dummy, interp, argc, argv)
 	cmdTrace = Tcl_CreateTrace(interp, 50000,
 	        (Tcl_CmdTraceProc *) CmdTraceDeleteProc, (ClientData) NULL);
 	Tcl_Eval(interp, argv[2]);
+    } else if ( strcmp(argv[1], "resulttest" ) == 0 ) {
+	/* Create an object-based trace, then eval a script. This is used
+	 * to test return codes other than TCL_OK from the trace engine.
+	 */
+	static int deleteCalled;
+	deleteCalled = 0;
+	cmdTrace = Tcl_CreateObjTrace( interp, 50000,
+				       TCL_ALLOW_INLINE_COMPILATION,
+				       ObjTraceProc,
+				       (ClientData) &deleteCalled,
+				       ObjTraceDeleteProc );
+	result = Tcl_Eval( interp, argv[ 2 ] );
+	Tcl_DeleteTrace( interp, cmdTrace );
+	if ( !deleteCalled ) {
+	    Tcl_SetResult( interp, "Delete wasn't called", TCL_STATIC );
+	    return TCL_ERROR;
+	} else {
+	    return result;
+	}
+	
     } else {
 	Tcl_AppendResult(interp, "bad option \"", argv[1],
-		"\": must be tracetest or deletetest", (char *) NULL);
+			 "\": must be tracetest, deletetest or resulttest",
+			 (char *) NULL);
 	return TCL_ERROR;
     }
     return TCL_OK;
@@ -1090,6 +1119,41 @@ CmdTraceDeleteProc(clientData, interp, level, command, cmdProc,
     Tcl_DeleteTrace(interp, cmdTrace);
 }
 
+static int
+ObjTraceProc( clientData, interp, level, command, token, objc, objv )
+    ClientData clientData;	/* unused */
+    Tcl_Interp* interp;		/* Tcl interpreter */
+    int level;			/* Execution level */
+    CONST char* command;	/* Command being executed */
+    Tcl_Command token;		/* Command information */
+    int objc;			/* Parameter count */
+    Tcl_Obj *CONST objv[];	/* Parameter list */
+{
+    CONST char* word = Tcl_GetString( objv[ 0 ] );
+    if ( !strcmp( word, "Error" ) ) {
+	Tcl_SetObjResult( interp, Tcl_NewStringObj( command, -1 ) );
+	return TCL_ERROR;
+    } else if ( !strcmp( word, "Break" ) ) {
+	return TCL_BREAK;
+    } else if ( !strcmp( word, "Continue" ) ) {
+	return TCL_CONTINUE;
+    } else if ( !strcmp( word, "Return" ) ) {
+	return TCL_RETURN;
+    } else if ( !strcmp( word, "OtherStatus" ) ) {
+	return 6;
+    } else {
+	return TCL_OK;
+    }
+}
+
+static void
+ObjTraceDeleteProc( clientData )
+    ClientData clientData;
+{
+    int * intPtr = (int *) clientData;
+    *intPtr = 1;		/* Record that the trace was deleted */
+}
+
 /*
  *----------------------------------------------------------------------
  *