diff options
| -rw-r--r-- | ChangeLog | 13 | ||||
| -rw-r--r-- | generic/tclBasic.c | 6 | ||||
| -rw-r--r-- | generic/tclCompile.h | 5 | ||||
| -rw-r--r-- | generic/tclExecute.c | 237 | ||||
| -rw-r--r-- | generic/tclParse.c | 88 | ||||
| -rw-r--r-- | generic/tclProc.c | 11 | ||||
| -rw-r--r-- | tests/stack.test | 4 |
7 files changed, 127 insertions, 237 deletions
@@ -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 |