Code reordering; execution levels made consistent [Bug 480896].

7 files changed, 127 insertions, 237 deletions

diff --git a/ChangeLog b/ChangeLog
index 2ed2ee4..efc2dc6 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,16 @@
+2001-11-16  Miguel Sofer  <msofer@users.sourceforge.net>
+
+	* generic/tclBasic.c:
+	* generic/tclCompile.h:
+	* generic/tclExecute.c:
+	* generic/tclParse.c:
+	* generic/tclProc.c:
+	* tests/stack.test: consolidation of duplicated code (in
+	TclExecuteByteCode and EvalObjv); renaming of EvalObjv to
+	TclEvalObjv i as itisnot static anymore; restored consistency of
+	level counts between compiled and directly evaled code.
+	[Bug 480896]
+
 2001-11-12  David Gravereaux <davygrvy@pobox.com>
 
 	* win/makefile.vc:
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index ce1381e..edb8bb6 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.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: tclBasic.c,v 1.36 2001/11/14 23:17:03 hobbs Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.37 2001/11/16 20:01:04 msofer Exp $
  */
 
 #include "tclInt.h"
@@ -2829,7 +2829,7 @@ Tcl_EvalObjEx(interp, objPtr, flags)
     iPtr->numLevels++;
     if (iPtr->numLevels > iPtr->maxNestingDepth) {
 	Tcl_AppendToObj(Tcl_GetObjResult(interp),
-		"too many nested calls to Tcl_EvalObj (infinite loop?)", -1); 
+		"too many nested calls to Tcl_Eval (infinite loop?)", -1); 
 	result = TCL_ERROR;
 	goto done;
     }
@@ -2842,7 +2842,7 @@ Tcl_EvalObjEx(interp, objPtr, flags)
     if (TclpCheckStackSpace() == 0) {
 	/*NOTREACHED*/
     	Tcl_AppendToObj(Tcl_GetObjResult(interp),
-		"too many nested calls to Tcl_EvalObj (infinite loop?)", -1);
+		"too many nested calls to Tcl_Eval (infinite loop?)", -1);
 	result = TCL_ERROR;
 	goto done;
     }
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index 23aa9a6..203bdeb 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.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: tclCompile.h,v 1.18 2001/11/14 23:17:03 hobbs Exp $
+ * RCS: @(#) $Id: tclCompile.h,v 1.19 2001/11/16 20:01:04 msofer Exp $
  */
 
 #ifndef _TCLCOMPILATION
@@ -789,6 +789,9 @@ EXTERN void		TclEmitForwardJump _ANSI_ARGS_((CompileEnv *envPtr,
 EXTERN ExceptionRange *	TclGetExceptionRangeForPc _ANSI_ARGS_((
 			    unsigned char *pc, int catchOnly,
 			    ByteCode* codePtr));
+EXTERN int		TclEvalObjvInternal _ANSI_ARGS_((Tcl_Interp *interp, int objc,
+			    Tcl_Obj *CONST objv[], char *command, int length,
+			    int flags));
 EXTERN int		TclExecuteByteCode _ANSI_ARGS_((Tcl_Interp *interp,
 			    ByteCode *codePtr));
 EXTERN void		TclExpandJumpFixupArray _ANSI_ARGS_((
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 5eec236..a138e0c 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -11,7 +11,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclExecute.c,v 1.35 2001/11/14 23:17:03 hobbs Exp $
+ * RCS: @(#) $Id: tclExecute.c,v 1.36 2001/11/16 20:01:04 msofer Exp $
  */
 
 #include "tclInt.h"
@@ -221,10 +221,6 @@ long		tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 };
  * Declarations for local procedures to this file:
  */
 
-static void		CallTraceProcedure _ANSI_ARGS_((Tcl_Interp *interp,
-			    Trace *tracePtr, Command *cmdPtr,
-			    char *command, int numChars,
-			    int objc, Tcl_Obj *objv[]));
 static void		DupCmdNameInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr,
 			    Tcl_Obj *copyPtr));
 static int		ExprAbsFunc _ANSI_ARGS_((Tcl_Interp *interp,
@@ -536,7 +532,7 @@ GrowEvaluationStack(eePtr)
  *
  *----------------------------------------------------------------------
  */
-
+ 
 int
 TclExecuteByteCode(interp, codePtr)
     Tcl_Interp *interp;		/* Token for command interpreter. */
@@ -751,63 +747,64 @@ TclExecuteByteCode(interp, codePtr)
 	    {
 		int objc = opnd; /* The number of arguments. */
 		Tcl_Obj **objv;	 /* The array of argument objects. */
-		Command *cmdPtr; /* Points to command's Command struct. */
 		int newPcOffset; /* New inst offset for break, continue. */
 		Tcl_Obj **preservedStack;
 				 /* Reference to memory block containing
 				  * objv array (must be kept live throughout
 				  * trace and command invokations.) */
-#ifdef TCL_COMPILE_DEBUG
-		int isUnknownCmd = 0;
-		char cmdNameBuf[21];
-#endif /* TCL_COMPILE_DEBUG */
 
-		/*
-		 * If the interpreter was deleted, return an error.
-		 */
+		objv = &(stackPtr[stackTop - (objc-1)]);
 
-		if (iPtr->flags & DELETED) {
-		    Tcl_ResetResult(interp);
-		    Tcl_AppendToObj(Tcl_GetObjResult(interp),
-		            "attempt to call eval in deleted interpreter", -1);
-		    Tcl_SetErrorCode(interp, "CORE", "IDELETE",
-			    "attempt to call eval in deleted interpreter",
-			    (char *) NULL);
-		    result = TCL_ERROR;
-		    goto checkForCatch;
+#ifdef TCL_COMPILE_DEBUG
+		if (tclTraceExec >= 2) {
+		    if (traceInstructions) {
+			strncpy(cmdNameBuf, Tcl_GetString(objv[0]), 20);
+			TRACE(("%u => call ", objc));
+		    } else {
+			fprintf(stdout, "%d: (%u) invoking ",
+			        iPtr->numLevels,
+				(unsigned int)(pc - codePtr->codeStart));
+		    }
+		    for (i = 0;  i < objc;  i++) {
+			TclPrintObject(stdout, objv[i], 15);
+			fprintf(stdout, " ");
+		    }
+		    fprintf(stdout, "\n");
+		    fflush(stdout);
 		}
+#endif /*TCL_COMPILE_DEBUG*/
 
-		/*
-		 * Find the procedure to execute this command. If the
-		 * command is not found, handle it with the "unknown" proc.
+		/* 
+		 * If trace procedures will be called, we need a
+		 * command string to pass to TclEvalObjvInternal; note 
+		 * that a copy of the string will be made there to 
+		 * include the ending \0.
 		 */
 
-		objv = &(stackPtr[stackTop - (objc-1)]);
-		cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]);
-		if (cmdPtr == NULL) {
-		    cmdPtr = (Command *) Tcl_FindCommand(interp, "unknown",
-                            (Tcl_Namespace *) NULL, TCL_GLOBAL_ONLY);
-                    if (cmdPtr == NULL) {
-			Tcl_ResetResult(interp);
-			Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
-			        "invalid command name \"",
-				Tcl_GetString(objv[0]), "\"",
-				(char *) NULL);
-			TRACE(("%u => unknown proc not found: ", objc));
-			result = TCL_ERROR;
-			goto checkForCatch;
-		    }
-#ifdef TCL_COMPILE_DEBUG
-		    isUnknownCmd = 1;
-#endif /*TCL_COMPILE_DEBUG*/			
-		    stackTop++; /* need room for new inserted objv[0] */
-		    for (i = objc-1;  i >= 0;  i--) {
-			objv[i+1] = objv[i];
+		bytes = NULL;
+		length = 0;
+		if (iPtr->tracePtr != NULL) {
+		    Trace *tracePtr, *nextTracePtr;
+		    
+		    for (tracePtr = iPtr->tracePtr;  tracePtr != NULL;
+		            tracePtr = nextTracePtr) {
+			nextTracePtr = tracePtr->nextPtr;
+
+			/*
+			 * TclEvalObjvInternal will increment numLevels 
+			 * so use "<" rather than "<="
+			 */
+
+			if (iPtr->numLevels < tracePtr->level) {
+			    /*
+			     * Traces will be called: get command string
+			     */
+
+			    bytes = GetSrcInfoForPc(pc, codePtr, &length);
+			    break;
+			}
 		    }
-		    objc++;
-		    objv[0] = Tcl_NewStringObj("unknown", -1);
-		    Tcl_IncrRefCount(objv[0]);
-		}
+		}		
 
 		/*
 		 * A reference to part of the stack vector itself
@@ -822,63 +819,11 @@ TclExecuteByteCode(interp, codePtr)
 		preservedStack = stackPtr;
 
 		/*
-		 * Call any trace procedures.
-		 */
-
-		if (iPtr->tracePtr != NULL) {
-		    Trace *tracePtr, *nextTracePtr;
-		    
-		    for (tracePtr = iPtr->tracePtr;  tracePtr != NULL;
-		            tracePtr = nextTracePtr) {
-			nextTracePtr = tracePtr->nextPtr;
-			if (iPtr->numLevels <= tracePtr->level) {
-			    int numChars;
-			    char *cmd = GetSrcInfoForPc(pc, codePtr,
-				    &numChars);
-			    if (cmd != NULL) {
-				DECACHE_STACK_INFO();
-				CallTraceProcedure(interp, tracePtr, cmdPtr,
-				        cmd, numChars, objc, objv);
-				CACHE_STACK_INFO();
-			    }
-			}
-		    }
-		}
-
-		/*
-		 * Finally, invoke the command's Tcl_ObjCmdProc. First reset
-		 * the interpreter's string and object results to their
-		 * default empty values since they could have gotten changed
-		 * by earlier invocations.
+		 * Finally, let TclEvalObjvInternal handle the command.
 		 */
 
-		Tcl_ResetResult(interp);
-#ifdef TCL_COMPILE_DEBUG
-		if (tclTraceExec >= 2) {
-		    if (traceInstructions) {
-			strncpy(cmdNameBuf, Tcl_GetString(objv[0]), 20);
-			TRACE(("%u => call ", (isUnknownCmd? objc-1:objc)));
-		    } else {
-			fprintf(stdout, "%d: (%u) invoking ",
-			        iPtr->numLevels,
-				(unsigned int)(pc - codePtr->codeStart));
-		    }
-		    for (i = 0;  i < objc;  i++) {
-			TclPrintObject(stdout, objv[i], 15);
-			fprintf(stdout, " ");
-		    }
-		    fprintf(stdout, "\n");
-		    fflush(stdout);
-		}
-#endif /*TCL_COMPILE_DEBUG*/
-
-		iPtr->cmdCount++;
 		DECACHE_STACK_INFO();
-		result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp,
-					    objc, objv);
-		if (Tcl_AsyncReady()) {
-		    result = Tcl_AsyncInvoke(interp, result);
-		}
+		result = TclEvalObjvInternal(interp, objc, objv, bytes, length, 0);
 		CACHE_STACK_INFO();
 
 		/*
@@ -887,19 +832,7 @@ TclExecuteByteCode(interp, codePtr)
 		 * going to be used from now on.
 		 */
 
-		Tcl_Release((ClientData)preservedStack);
-
-		/*
-		 * If the interpreter has a non-empty string result, the
-		 * result object is either empty or stale because some
-		 * procedure set interp->result directly. If so, move the
-		 * string result to the result object, then reset the
-		 * string result.
-		 */
-
-		if (*(iPtr->result) != 0) {
-		    (void) Tcl_GetObjResult(interp);
-		}
+		Tcl_Release((ClientData) preservedStack);
 		
 		/*
 		 * Pop the objc top stack elements and decrement their ref
@@ -3841,74 +3774,6 @@ IllegalExprOperandType(interp, pc, opndPtr)
 /*
  *----------------------------------------------------------------------
  *
- * CallTraceProcedure --
- *
- *	Invokes a trace procedure registered with an interpreter. These
- *	procedures trace command execution. Currently this trace procedure
- *	is called with the address of the string-based Tcl_CmdProc for the
- *	command, not the Tcl_ObjCmdProc.
- *
- * Results:
- *	None.
- *
- * Side effects:
- *	Those side effects made by the trace procedure.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-CallTraceProcedure(interp, tracePtr, cmdPtr, command, numChars, objc, objv)
-    Tcl_Interp *interp;		/* The current interpreter. */
-    register Trace *tracePtr;	/* Describes the trace procedure to call. */
-    Command *cmdPtr;		/* Points to command's Command struct. */
-    char *command;		/* Points to the first character of the
-				 * command's source before substitutions. */
-    int numChars;		/* The number of characters in the
-				 * command's source. */
-    register int objc;		/* Number of arguments for the command. */
-    Tcl_Obj *objv[];		/* Pointers to Tcl_Obj of each argument. */
-{
-    Interp *iPtr = (Interp *) interp;
-    register char **argv;
-    register int i;
-    int length;
-    char *p;
-
-    /*
-     * Get the string rep from the objv argument objects and place their
-     * pointers in argv. First make sure argv is large enough to hold the
-     * objc args plus 1 extra word for the zero end-of-argv word.
-     */
-    
-    argv = (char **) ckalloc((unsigned)(objc + 1) * sizeof(char *));
-    for (i = 0;  i < objc;  i++) {
-	argv[i] = Tcl_GetStringFromObj(objv[i], &length);
-    }
-    argv[objc] = 0;
-
-    /*
-     * Copy the command characters into a new string.
-     */
-
-    p = (char *) ckalloc((unsigned) (numChars + 1));
-    memcpy((VOID *) p, (VOID *) command, (size_t) numChars);
-    p[numChars] = '\0';
-    
-    /*
-     * Call the trace procedure then free allocated storage.
-     */
-    
-    (*tracePtr->proc)(tracePtr->clientData, interp, iPtr->numLevels,
-                      p, cmdPtr->proc, cmdPtr->clientData, objc, argv);
-
-    ckfree((char *) argv);
-    ckfree((char *) p);
-}
-
-/*
- *----------------------------------------------------------------------
- *
  * GetSrcInfoForPc --
  *
  *	Given a program counter value, finds the closest command in the
diff --git a/generic/tclParse.c b/generic/tclParse.c
index a6eaab3..f19e4e4 100644
--- a/generic/tclParse.c
+++ b/generic/tclParse.c
@@ -14,7 +14,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclParse.c,v 1.16 2001/09/13 11:56:20 msofer Exp $
+ * RCS: @(#) $Id: tclParse.c,v 1.17 2001/11/16 20:01:04 msofer Exp $
  */
 
 #include "tclInt.h"
@@ -179,9 +179,6 @@ static int		CommandComplete _ANSI_ARGS_((char *script,
 			    int length));
 static int		ParseTokens _ANSI_ARGS_((char *src, int mask,
 			    Tcl_Parse *parsePtr));
-static int		EvalObjv _ANSI_ARGS_((Tcl_Interp *interp, int objc,
-			    Tcl_Obj *CONST objv[], char *command, int length,
-			    int flags));
 
 /*
  *----------------------------------------------------------------------
@@ -755,7 +752,7 @@ TclExpandTokenArray(parsePtr)
 /*
  *----------------------------------------------------------------------
  *
- * EvalObjv --
+ * TclEvalObjvInternal --
  *
  *	This procedure evaluates a Tcl command that has already been
  *	parsed into words, with one Tcl_Obj holding each word.
@@ -772,8 +769,8 @@ TclExpandTokenArray(parsePtr)
  *----------------------------------------------------------------------
  */
 
-static int
-EvalObjv(interp, objc, objv, command, length, flags)
+int
+TclEvalObjvInternal(interp, objc, objv, command, length, flags)
     Tcl_Interp *interp;		/* Interpreter in which to evaluate the
 				 * command.  Also used for error
 				 * reporting. */
@@ -785,7 +782,8 @@ EvalObjv(interp, objc, objv, command, length, flags)
 				 * is used for traces.  If the string
 				 * representation of the command is
 				 * unknown, an empty string should be
-				 * supplied. */
+				 * supplied. If it is NULL, no traces will
+				 * be called. */
     int length;			/* Number of bytes in command; if -1, all
 				 * characters up to the first null byte are
 				 * used. */
@@ -869,7 +867,7 @@ EvalObjv(interp, objc, objv, command, length, flags)
 		    (char *) NULL);
 	    code = TCL_ERROR;
 	} else {
-	    code = EvalObjv(interp, objc+1, newObjv, command, length, 0);
+	    code = TclEvalObjvInternal(interp, objc+1, newObjv, command, length, 0);
 	}
 	Tcl_DecrRefCount(newObjv[0]);
 	ckfree((char *) newObjv);
@@ -880,44 +878,46 @@ EvalObjv(interp, objc, objv, command, length, flags)
      * Call trace procedures if needed.
      */
 
-    argv = NULL;
-    commandCopy = command;
-
-    for (tracePtr = iPtr->tracePtr; 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.
-	 */
+    if (command != NULL) {
+	argv = NULL;
+	commandCopy = command;
 
-	if (argv == NULL) {
-	    argv = (char **) ckalloc((unsigned) (objc + 1) * sizeof(char *));
-	    for (i = 0; i < objc; i++) {
-		argv[i] = Tcl_GetString(objv[i]);
+	for (tracePtr = iPtr->tracePtr; tracePtr != NULL; tracePtr = nextPtr) {
+	    nextPtr = tracePtr->nextPtr;
+	    if (iPtr->numLevels > tracePtr->level) {
+		continue;
 	    }
-	    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;
+
+	    /*
+	     * This is a bit messy because we have to emulate the old trace
+	     * interface, which uses strings for everything.
+	     */
+	    
+	    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,
+	    (*tracePtr->proc)(tracePtr->clientData, interp, iPtr->numLevels,
 			  commandCopy, cmdPtr->proc, cmdPtr->clientData,
 			  objc, argv);
-    }
-    if (argv != NULL) {
-	ckfree((char *) argv);
-    }
-    if (commandCopy != command) {
-	ckfree((char *) commandCopy);
+	}
+	if (argv != NULL) {
+	    ckfree((char *) argv);
+	}
+	if (commandCopy != command) {
+	    ckfree((char *) commandCopy);
+	}
     }
     
     /*
@@ -1016,7 +1016,7 @@ Tcl_EvalObjv(interp, objc, objv, flags)
      */
     switch (code) {
 	case TCL_OK:
-	    code = EvalObjv(interp, objc, objv, cmdString, cmdLen, flags);
+	    code = TclEvalObjvInternal(interp, objc, objv, cmdString, cmdLen, flags);
 	    if (code == TCL_ERROR && cmdLen == 0)
 		goto cmdtraced;
 	    break;
@@ -1447,7 +1447,7 @@ Tcl_EvalEx(interp, script, numBytes, flags)
 	     * Execute the command and free the objects for its words.
 	     */
     
-	    code = EvalObjv(interp, objectsUsed, objv, p, bytesLeft, 0);
+	    code = TclEvalObjvInternal(interp, objectsUsed, objv, p, bytesLeft, 0);
 	    if (code != TCL_OK) {
 		goto error;
 	    }
diff --git a/generic/tclProc.c b/generic/tclProc.c
index c20096e..7d269a6 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.c
@@ -10,7 +10,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclProc.c,v 1.31 2001/10/15 22:25:45 msofer Exp $
+ * RCS: @(#) $Id: tclProc.c,v 1.32 2001/11/16 20:01:04 msofer Exp $
  */
 
 #include "tclInt.h"
@@ -1069,9 +1069,18 @@ TclObjInterpProc(clientData, interp, objc, objv)
     }
 #endif /*TCL_COMPILE_DEBUG*/
 
+    /*
+     * Tcl_EvalObjEx will increase the level count again while evaluating
+     * the body, resulting in a total level increase of 2; correct this 
+     * behaviour before evaling the body, restore afterwards.
+     */
+
+    iPtr->numLevels--;
+
     iPtr->returnCode = TCL_OK;
     procPtr->refCount++;
     result = Tcl_EvalObjEx(interp, procPtr->bodyPtr, 0);
+    iPtr->numLevels++;
     procPtr->refCount--;
     if (procPtr->refCount <= 0) {
 	TclProcCleanupProc(procPtr);
diff --git a/tests/stack.test b/tests/stack.test
index fef667e..46bd420 100644
--- a/tests/stack.test
+++ b/tests/stack.test
@@ -9,7 +9,7 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: stack.test,v 1.11 2001/09/11 18:26:27 hobbs Exp $
+# RCS: @(#) $Id: stack.test,v 1.12 2001/11/16 20:01:04 msofer Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest
@@ -43,7 +43,7 @@ test stack-1.1 {maxNestingDepth reached on infinite recursion} {minStack2400} {
     catch {recurse} rv
     rename recurse {}
     set rv
-} {too many nested calls to Tcl_EvalObj (infinite loop?)}
+} {too many nested calls to Tcl_Eval (infinite loop?)}
 
 test stack-2.1 {maxNestingDepth reached on infinite recursion} {minStack2400} {
     # do this in a slave to not mess with parent