From 2ddf71d5d424c34dfbcc0b9f55cf9baeabbe9e4b Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 25 Oct 2004 20:24:06 +0000 Subject: * generic/tclExecute.c (IllegalExprOperandType,TclExecuteByteCode): Removed several DECACHE_INFO/CACHE_INFO pairs that are no longer needed for protection because routines like Tcl_SetErrorCode() and Tcl_AddErrorInfo() can no longer re-enter bytecode execution. * generic/tclResult.c (TclProcessReturn): Bug fix. Be sure that a missing -errorinfo option when code == TCL_ERROR causes the errorInfo field to get reset. * tests/thread.test (thread-4.4): Test depended on a ::errorInfo value initialized to "". Added code to test to setup that requirement. --- ChangeLog | 12 ++++++++++++ generic/tclExecute.c | 39 ++------------------------------------- generic/tclResult.c | 9 +++++---- tests/thread.test | 4 ++-- 4 files changed, 21 insertions(+), 43 deletions(-) diff --git a/ChangeLog b/ChangeLog index 0d25fa5..98494f5 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,5 +1,17 @@ 2004-10-25 Don Porter + * generic/tclExecute.c (IllegalExprOperandType,TclExecuteByteCode): + Removed several DECACHE_INFO/CACHE_INFO pairs that are no longer + needed for protection because routines like Tcl_SetErrorCode() and + Tcl_AddErrorInfo() can no longer re-enter bytecode execution. + + * generic/tclResult.c (TclProcessReturn): Bug fix. Be sure that + a missing -errorinfo option when code == TCL_ERROR causes the + errorInfo field to get reset. + + * tests/thread.test (thread-4.4): Test depended on a ::errorInfo + value initialized to "". Added code to test to setup that requirement. + * library/auto.tcl Purged Tcl's script library of all * library/clock.tcl remaining references to global vars * library/init.tcl ::errorInfo and ::errorCode. diff --git a/generic/tclExecute.c b/generic/tclExecute.c index da280c5..4c5c7d9 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.161 2004/10/25 01:06:49 msofer Exp $ + * RCS: @(#) $Id: tclExecute.c,v 1.162 2004/10/25 20:24:12 dgp Exp $ */ #ifdef STDC_HEADERS @@ -1237,10 +1237,7 @@ TclExecuteByteCode(interp, codePtr) int level = TclGetUInt4AtPtr(pc+5); Tcl_Obj *returnOpts = POP_OBJECT(); - DECACHE_STACK_INFO(); - Tcl_ResetResult(interp); result = TclProcessReturn(interp, code, level, returnOpts); - CACHE_STACK_INFO(); Tcl_DecrRefCount(returnOpts); if (result != TCL_OK) { Tcl_SetObjResult(interp, *tosPtr); @@ -2186,9 +2183,7 @@ TclExecuteByteCode(interp, codePtr) if (result != TCL_OK) { TRACE_WITH_OBJ(("%u (by %s) => ERROR converting increment amount to int: ", opnd, O2S(objPtr)), Tcl_GetObjResult(interp)); - DECACHE_STACK_INFO(); Tcl_AddErrorInfo(interp, "\n (reading increment)"); - CACHE_STACK_INFO(); goto checkForCatch; } isWide = (objPtr->typePtr == &tclWideIntType); @@ -2231,10 +2226,8 @@ TclExecuteByteCode(interp, codePtr) varPtr = TclObjLookupVar(interp, objPtr, part2, TCL_LEAVE_ERR_MSG, "read", 0, 1, &arrayPtr); if (varPtr == NULL) { - DECACHE_STACK_INFO(); Tcl_AddObjErrorInfo(interp, "\n (reading value of variable to increment)", -1); - CACHE_STACK_INFO(); TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); result = TCL_ERROR; goto checkForCatch; @@ -2516,9 +2509,7 @@ TclExecuteByteCode(interp, codePtr) if (result != TCL_OK) { TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr), (t1Ptr? t1Ptr->name : "null"))); - DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, valuePtr); - CACHE_STACK_INFO(); goto checkForCatch; } } @@ -2547,9 +2538,7 @@ TclExecuteByteCode(interp, codePtr) if (result != TCL_OK) { TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(value2Ptr), (t2Ptr? t2Ptr->name : "null"))); - DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, value2Ptr); - CACHE_STACK_INFO(); goto checkForCatch; } } @@ -3491,9 +3480,7 @@ TclExecuteByteCode(interp, codePtr) O2S(valuePtr), O2S(value2Ptr), (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); - DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, valuePtr); - CACHE_STACK_INFO(); goto checkForCatch; } } @@ -3508,9 +3495,7 @@ TclExecuteByteCode(interp, codePtr) O2S(valuePtr), O2S(value2Ptr), (value2Ptr->typePtr? value2Ptr->typePtr->name : "null"))); - DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, value2Ptr); - CACHE_STACK_INFO(); goto checkForCatch; } } @@ -3825,9 +3810,7 @@ TclExecuteByteCode(interp, codePtr) s, O2S(valuePtr), (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); - DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, valuePtr); - CACHE_STACK_INFO(); goto checkForCatch; } t1Ptr = valuePtr->typePtr; @@ -3859,9 +3842,7 @@ TclExecuteByteCode(interp, codePtr) O2S(value2Ptr), s, (value2Ptr->typePtr? value2Ptr->typePtr->name : "null"))); - DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, value2Ptr); - CACHE_STACK_INFO(); goto checkForCatch; } t2Ptr = value2Ptr->typePtr; @@ -3914,9 +3895,7 @@ TclExecuteByteCode(interp, codePtr) if (IS_NAN(dResult) || IS_INF(dResult)) { TRACE(("%.20s %.20s => IEEE FLOATING PT ERROR\n", O2S(valuePtr), O2S(value2Ptr))); - DECACHE_STACK_INFO(); TclExprFloatError(interp, dResult); - CACHE_STACK_INFO(); result = TCL_ERROR; goto checkForCatch; } @@ -4092,9 +4071,7 @@ TclExecuteByteCode(interp, codePtr) if (result != TCL_OK) { TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", s, (tPtr? tPtr->name : "null"))); - DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, valuePtr); - CACHE_STACK_INFO(); goto checkForCatch; } tPtr = valuePtr->typePtr; @@ -4182,9 +4159,7 @@ TclExecuteByteCode(interp, codePtr) if (result != TCL_OK) { TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n", s, (tPtr? tPtr->name : "null"))); - DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, valuePtr); - CACHE_STACK_INFO(); goto checkForCatch; } } @@ -4277,9 +4252,7 @@ TclExecuteByteCode(interp, codePtr) if (result != TCL_OK) { /* try to convert to double */ TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n", O2S(valuePtr), (tPtr? tPtr->name : "null"))); - DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, valuePtr); - CACHE_STACK_INFO(); goto checkForCatch; } } @@ -4459,9 +4432,7 @@ TclExecuteByteCode(interp, codePtr) if (IS_NAN(d) || IS_INF(d)) { TRACE(("\"%.20s\" => IEEE FLOATING PT ERROR\n", O2S(objResultPtr))); - DECACHE_STACK_INFO(); TclExprFloatError(interp, d); - CACHE_STACK_INFO(); result = TCL_ERROR; goto checkForCatch; } @@ -4730,11 +4701,9 @@ TclExecuteByteCode(interp, codePtr) */ divideByZero: - DECACHE_STACK_INFO(); Tcl_SetObjResult(interp, Tcl_NewStringObj("divide by zero", -1)); Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero", (char *) NULL); - CACHE_STACK_INFO(); result = TCL_ERROR; goto checkForCatch; @@ -4745,12 +4714,10 @@ TclExecuteByteCode(interp, codePtr) */ exponOfZero: - DECACHE_STACK_INFO(); Tcl_SetObjResult(interp, Tcl_NewStringObj( "exponentiation of zero by negative power", -1)); Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", "exponentiation of zero by negative power", (char *) NULL); - CACHE_STACK_INFO(); result = TCL_ERROR; goto checkForCatch; @@ -4862,9 +4829,7 @@ TclExecuteByteCode(interp, codePtr) if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { bytes = GetSrcInfoForPc(pc, codePtr, &length); if (bytes != NULL) { - DECACHE_STACK_INFO(); Tcl_LogCommandInfo(interp, codePtr->source, bytes, length); - CACHE_STACK_INFO(); } } iPtr->flags &= ~ERR_ALREADY_LOGGED; @@ -5146,7 +5111,7 @@ IllegalExprOperandType(interp, pc, opndPtr) operator = "**"; } - Tcl_ResetResult(interp); + Tcl_SetObjResult(interp, Tcl_NewObj()); if ((opndPtr->bytes == NULL) || (opndPtr->length == 0)) { Tcl_AppendResult(interp, "can't use empty string as operand of \"", operator, "\"", (char *) NULL); diff --git a/generic/tclResult.c b/generic/tclResult.c index 226af65..196f634 100644 --- a/generic/tclResult.c +++ b/generic/tclResult.c @@ -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: tclResult.c,v 1.20 2004/10/24 22:25:13 dgp Exp $ + * RCS: @(#) $Id: tclResult.c,v 1.21 2004/10/25 20:24:13 dgp Exp $ */ #include "tclInt.h" @@ -1186,14 +1186,15 @@ TclProcessReturn(interp, code, level, returnOpts) } if (code == TCL_ERROR) { + if (iPtr->errorInfo) { + Tcl_DecrRefCount(iPtr->errorInfo); + iPtr->errorInfo = NULL; + } Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORINFO], &valuePtr); if (valuePtr != NULL) { int infoLen; (void) Tcl_GetStringFromObj(valuePtr, &infoLen); if (infoLen) { - if (iPtr->errorInfo) { - Tcl_DecrRefCount(iPtr->errorInfo); - } iPtr->errorInfo = valuePtr; Tcl_IncrRefCount(iPtr->errorInfo); iPtr->flags |= ERR_ALREADY_LOGGED; diff --git a/tests/thread.test b/tests/thread.test index 8e7c471..50c3360 100644 --- a/tests/thread.test +++ b/tests/thread.test @@ -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: thread.test,v 1.13 2004/06/18 15:06:43 dkf Exp $ +# RCS: @(#) $Id: thread.test,v 1.14 2004/10/25 20:24:14 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -195,7 +195,7 @@ test thread-4.4 {TclThreadSend preserve code} {testthread} { threadReap set len [llength [testthread names]] set serverthread [testthread create] - set x [catch {testthread send $serverthread {break}} msg] + set x [catch {testthread send $serverthread {set errorInfo {}; break}} msg] threadReap list $len $x $msg $errorInfo } {1 3 {} {}} -- cgit v0.12