Added Tcl_CreateObjTrace, Tcl_GetCommandInfoFromToken and

Tcl_SetCommandInfoFromToken. (TIPs #32 and #79.)

1 files changed, 368 insertions, 80 deletions

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;
-    }
 }
 
 /*