Attachment "levels2.patch" to
ticket [480896ffff]
added by
msofer
2001-11-13 03:13:54.
Index: generic/tclBasic.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclBasic.c,v
retrieving revision 1.35
diff -u -r1.35 tclBasic.c
--- generic/tclBasic.c 2001/09/01 00:51:31 1.35
+++ generic/tclBasic.c 2001/11/12 20:07:40
@@ -2826,7 +2826,7 @@
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;
}
@@ -2839,7 +2839,7 @@
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;
}
Index: generic/tclCompile.h
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclCompile.h,v
retrieving revision 1.17
diff -u -r1.17 tclCompile.h
--- generic/tclCompile.h 2001/10/15 20:26:57 1.17
+++ generic/tclCompile.h 2001/11/12 20:07:41
@@ -775,6 +775,9 @@
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_((
Index: generic/tclExecute.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclExecute.c,v
retrieving revision 1.34
diff -u -r1.34 tclExecute.c
--- generic/tclExecute.c 2001/09/21 19:09:03 1.34
+++ generic/tclExecute.c 2001/11/12 20:07:44
@@ -220,10 +220,6 @@
* 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,
@@ -535,7 +531,7 @@
*
*----------------------------------------------------------------------
*/
-
+
int
TclExecuteByteCode(interp, codePtr)
Tcl_Interp *interp; /* Token for command interpreter. */
@@ -743,63 +739,64 @@
{
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;
+ 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;
+ }
}
-#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];
- }
- objc++;
- objv[0] = Tcl_NewStringObj("unknown", -1);
- Tcl_IncrRefCount(objv[0]);
- }
+ }
/*
* A reference to part of the stack vector itself
@@ -813,64 +810,12 @@
Tcl_Preserve((ClientData)stackPtr);
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();
/*
@@ -878,20 +823,8 @@
* safe to do so now, since no references to objv are
* 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
@@ -3689,74 +3622,6 @@
msg, " as operand of \"", operatorStrings[opCode - INST_LOR],
"\"", (char *) NULL);
}
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * 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);
}
/*
Index: generic/tclParse.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclParse.c,v
retrieving revision 1.16
diff -u -r1.16 tclParse.c
--- generic/tclParse.c 2001/09/13 11:56:20 1.16
+++ generic/tclParse.c 2001/11/12 20:07:45
@@ -179,9 +179,6 @@
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 @@
/*
*----------------------------------------------------------------------
*
- * 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 @@
*----------------------------------------------------------------------
*/
-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 @@
* 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 @@
(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);
@@ -879,45 +877,47 @@
/*
* 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 (argv == NULL) {
- argv = (char **) ckalloc((unsigned) (objc + 1) * sizeof(char *));
- for (i = 0; i < objc; i++) {
- argv[i] = Tcl_GetString(objv[i]);
+ if (command != NULL) {
+ argv = NULL;
+ commandCopy = command;
+
+ 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 @@
*/
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 @@
* 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;
}
Index: generic/tclProc.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclProc.c,v
retrieving revision 1.31
diff -u -r1.31 tclProc.c
--- generic/tclProc.c 2001/10/15 22:25:45 1.31
+++ generic/tclProc.c 2001/11/12 20:07:46
@@ -1069,9 +1069,18 @@
}
#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);
Index: tests/stack.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/stack.test,v
retrieving revision 1.11
diff -u -r1.11 stack.test
--- tests/stack.test 2001/09/11 18:26:27 1.11
+++ tests/stack.test 2001/11/12 20:07:46
@@ -43,7 +43,7 @@
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
