summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--ChangeLog13
-rw-r--r--generic/tclBasic.c6
-rw-r--r--generic/tclCompile.h5
-rw-r--r--generic/tclExecute.c237
-rw-r--r--generic/tclParse.c88
-rw-r--r--generic/tclProc.c11
-rw-r--r--tests/stack.test4
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