diff options
| -rw-r--r-- | ChangeLog | 11 | ||||
| -rw-r--r-- | generic/tclCmdAH.c | 10 | ||||
| -rw-r--r-- | generic/tclCmdIL.c | 22 | ||||
| -rw-r--r-- | generic/tclDictObj.c | 20 | ||||
| -rw-r--r-- | generic/tclScan.c | 8 | ||||
| -rw-r--r-- | generic/tclTest.c | 4 | ||||
| -rw-r--r-- | tests/error.test | 38 | ||||
| -rw-r--r-- | tests/info.test | 6 | ||||
| -rw-r--r-- | tests/scan.test | 14 |
9 files changed, 59 insertions, 74 deletions
@@ -1,3 +1,14 @@ +2011-04-04 Jan Nijtmans <nijtmans@users.sf.net> + + * generic/tclCmdAH.c: Better error-message in case of errors + * generic/tclCmdIL.c: related to setting a variable. This fixes + * generic/tclDictObj.c: a warning: "Why make your own error + * generic/tclScan.c: message? Why?" + * generic/tclTest.c: + * test/error.test: + * test/info.test: + * test/scan.test: + 2011-04-03 Donal K. Fellows <dkf@users.sf.net> * generic/tclNamesp.c, generic/tclObj.c, generic/tclPathObj.c: diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 3edfa54..8b5f13d 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -345,10 +345,7 @@ CatchObjCmdCallback( if (objc >= 3) { if (NULL == Tcl_ObjSetVar2(interp, varNamePtr, NULL, - Tcl_GetObjResult(interp), 0)) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, - "couldn't save command result in variable", NULL); + Tcl_GetObjResult(interp), TCL_LEAVE_ERR_MSG)) { return TCL_ERROR; } } @@ -356,11 +353,8 @@ CatchObjCmdCallback( Tcl_Obj *options = Tcl_GetReturnOptions(interp, result); if (NULL == Tcl_ObjSetVar2(interp, optionVarNamePtr, NULL, - options, 0)) { + options, TCL_LEAVE_ERR_MSG)) { Tcl_DecrRefCount(options); - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, - "couldn't save return options in variable", NULL); return TCL_ERROR; } } diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index b38ec9f..c42a54b 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -966,7 +966,7 @@ InfoDefaultCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { Interp *iPtr = (Interp *) interp; - const char *procName, *argName, *varName; + const char *procName, *argName; Proc *procPtr; CompiledLocal *localPtr; Tcl_Obj *valueObjPtr; @@ -993,18 +993,18 @@ InfoDefaultCmd( && (strcmp(argName, localPtr->name) == 0)) { if (localPtr->defValuePtr != NULL) { valueObjPtr = Tcl_ObjSetVar2(interp, objv[3], NULL, - localPtr->defValuePtr, 0); + localPtr->defValuePtr, TCL_LEAVE_ERR_MSG); if (valueObjPtr == NULL) { - goto defStoreError; + return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewIntObj(1)); } else { Tcl_Obj *nullObjPtr = Tcl_NewObj(); valueObjPtr = Tcl_ObjSetVar2(interp, objv[3], NULL, - nullObjPtr, 0); + nullObjPtr, TCL_LEAVE_ERR_MSG); if (valueObjPtr == NULL) { - goto defStoreError; + return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); } @@ -1016,12 +1016,6 @@ InfoDefaultCmd( "\" doesn't have an argument \"", argName, "\"", NULL); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARGUMENT", argName, NULL); return TCL_ERROR; - - defStoreError: - varName = TclGetString(objv[3]); - Tcl_AppendResult(interp, "couldn't store default value in variable \"", - varName, "\"", NULL); - return TCL_ERROR; } /* @@ -1058,7 +1052,7 @@ InfoErrorStackCmd( Tcl_WrongNumArgs(interp, 1, objv, "?interp?"); return TCL_ERROR; } - + target = interp; if (objc == 2) { target = Tcl_GetSlave(interp, Tcl_GetString(objv[1])); @@ -1069,7 +1063,7 @@ InfoErrorStackCmd( iPtr = (Interp *) target; Tcl_SetObjResult(interp, iPtr->errorStack); - + return TCL_OK; } @@ -1163,7 +1157,7 @@ InfoFrameCmd( CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; CmdFrame *runPtr = iPtr->cmdFramePtr; CmdFrame *lastPtr = NULL; - + topLevel += corPtr->caller.cmdFramePtr->level; while (runPtr && (runPtr != corPtr->caller.cmdFramePtr)) { lastPtr = runPtr; diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index 3da91a3..508c2af 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -2456,18 +2456,12 @@ DictForNRCmd( */ Tcl_IncrRefCount(valueObj); - if (Tcl_ObjSetVar2(interp, keyVarObj, NULL, keyObj, 0) == NULL) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "couldn't set key variable: \"", - TclGetString(keyVarObj), "\"", NULL); + if (Tcl_ObjSetVar2(interp, keyVarObj, NULL, keyObj, TCL_LEAVE_ERR_MSG) == NULL) { TclDecrRefCount(valueObj); goto error; } TclDecrRefCount(valueObj); - if (Tcl_ObjSetVar2(interp, valueVarObj, NULL, valueObj, 0) == NULL) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "couldn't set value variable: \"", - TclGetString(valueVarObj), "\"", NULL); + if (Tcl_ObjSetVar2(interp, valueVarObj, NULL, valueObj, TCL_LEAVE_ERR_MSG) == NULL) { goto error; } @@ -2540,19 +2534,13 @@ DictForLoopCallback( */ Tcl_IncrRefCount(valueObj); - if (Tcl_ObjSetVar2(interp, keyVarObj, NULL, keyObj, 0) == NULL) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "couldn't set key variable: \"", - TclGetString(keyVarObj), "\"", NULL); + if (Tcl_ObjSetVar2(interp, keyVarObj, NULL, keyObj, TCL_LEAVE_ERR_MSG) == NULL) { TclDecrRefCount(valueObj); result = TCL_ERROR; goto done; } TclDecrRefCount(valueObj); - if (Tcl_ObjSetVar2(interp, valueVarObj, NULL, valueObj, 0) == NULL) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "couldn't set value variable: \"", - TclGetString(valueVarObj), "\"", NULL); + if (Tcl_ObjSetVar2(interp, valueVarObj, NULL, valueObj, TCL_LEAVE_ERR_MSG) == NULL) { result = TCL_ERROR; goto done; } diff --git a/generic/tclScan.c b/generic/tclScan.c index 68b8d21..06e66e4 100644 --- a/generic/tclScan.c +++ b/generic/tclScan.c @@ -1001,10 +1001,10 @@ Tcl_ScanObjCmd( continue; } result++; -#warning Why make your own error message? Why? - if (Tcl_ObjSetVar2(interp, objv[i+3], NULL, objs[i], 0) == NULL) { - Tcl_AppendResult(interp, "couldn't set variable \"", - TclGetString(objv[i+3]), "\"", NULL); + /* In case of multiple errors in setting variables, just report + * the first one. */ + if (Tcl_ObjSetVar2(interp, objv[i+3], NULL, objs[i], + (code == TCL_OK) ? TCL_LEAVE_ERR_MSG : 0) == NULL) { code = TCL_ERROR; } Tcl_DecrRefCount(objs[i]); diff --git a/generic/tclTest.c b/generic/tclTest.c index b757185..bac0c7f 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -3939,10 +3939,8 @@ TestregexpObjCmd( info.matches[ii].end - 1); } } - valuePtr = Tcl_ObjSetVar2(interp, varPtr, NULL, newPtr, 0); + valuePtr = Tcl_ObjSetVar2(interp, varPtr, NULL, newPtr, TCL_LEAVE_ERR_MSG); if (valuePtr == NULL) { - Tcl_AppendResult(interp, "couldn't set variable \"", - Tcl_GetString(varPtr), "\"", NULL); return TCL_ERROR; } } diff --git a/tests/error.test b/tests/error.test index c34ccb0..97bcc0a 100644 --- a/tests/error.test +++ b/tests/error.test @@ -138,7 +138,7 @@ test error-3.3 {errors in catch command} { catch {unset a} set a(0) 22 list [catch {catch {format 44} a} msg] $msg -} {1 {couldn't save command result in variable}} +} {1 {can't set "a": variable is array}} catch {unset a} # More tests related to errorInfo and errorCode @@ -417,7 +417,7 @@ test error-12.4 {try with result/opts variable assignment in on handler} { } {bar,FOO} test error-12.5 {try with result/opts variable assignment in on handler, vars remain in scope} { try { throw FOO bar } on error {res opts} { list d e f } - set r "$res,[dict get $opts -errorcode]" + set r "$res,[dict get $opts -errorcode]" } {bar,FOO} test error-12.6 {try result is propagated if no matching handler} { try { list a b c } on error {} { list d e f } @@ -459,7 +459,7 @@ test error-13.8 {try with multiple handlers and finally (ok)} { try list on error {} {} trap {} {} {} finally {} } {} test error-13.9 {last handler body can't be a fallthrough #1} -body { - try list on error {} {} on break {} - + try list on error {} {} on break {} - } -returnCodes error -result {last non-finally clause must not have a body of "-"} test error-13.10 {last handler body can't be a fallthrough #2} -body { try list on error {} {} on break {} - finally { list d e f } @@ -471,7 +471,7 @@ test error-14.1 {try with multiple handlers (only one matches) #1} { try { throw FOO bar } on ok {} { list a b c } trap FOO {} { list d e f } } {d e f} test error-14.2 {try with multiple handlers (only one matches) #2} { - try { throw FOO bar } trap FOO {} { list d e f } on ok {} { list a b c } + try { throw FOO bar } trap FOO {} { list d e f } on ok {} { list a b c } } {d e f} test error-14.3 {try with multiple handlers (only one matches) #3} { try { @@ -482,7 +482,7 @@ test error-14.3 {try with multiple handlers (only one matches) #3} { list d e f } on ok {} { list a b c - } + } } {d e f} test error-14.4 {try with multiple matching handlers (only the first in left-to-right order runs) #1} { try { throw FOO bar } on error {} { list a b c } trap FOO {} { list d e f } @@ -593,16 +593,16 @@ test error-16.6 {try with variable assignment and propagation #1} { catch { try { throw FOO bar } trap FOO {em} { throw BAR baz } } - set em + set em } {bar} test error-16.7 {try with variable assignment and propagation #2} { catch { try { throw FOO bar } trap FOO {em opts} { throw BAR baz } } - list $em [dict get $opts -errorcode] + list $em [dict get $opts -errorcode] } {bar FOO} test error-16.8 {exception chaining (try=ok, handler=error)} { - #FIXME is the intent of this test correct? + #FIXME is the intent of this test correct? catch { try { list a b c } on ok {em opts} { throw BAR baz } } tryem tryopts @@ -686,7 +686,7 @@ test error-17.11 {successful finally doesn't affect variable assignment or propa catch { try { throw FOO bar } trap FOO {em opts} { throw BAR baz } finally { list d e f } } - list $em [dict get $opts -errorcode] + list $em [dict get $opts -errorcode] } {bar FOO} # try tests - propagation (exceptions in finally, exception chaining) @@ -707,11 +707,11 @@ test error-18.5 {exception in finally doesn't affect variable assignment} { catch { try { throw FOO bar } trap FOO {em opts} { throw BAR baz } finally { throw BAZ zing } } - list $em [dict get $opts -errorcode] + list $em [dict get $opts -errorcode] } {bar FOO} test error-18.6 {exception chaining in finally (try=ok)} { catch { - list a b c + list a b c } em expopts catch { try { list a b c } finally { throw BAR foo } @@ -782,14 +782,14 @@ test error-19.1 {try with fallthrough body #1} { } {1} test error-19.2 {try with fallthrough body #2} { set RES {} - try { - throw FOO bar + try { + throw FOO bar } trap BAR {} { } trap FOO {} - trap {} {} { set RES foo } on error {} { set RES err - } + } set RES } {foo} test error-19.3 {try with cascade fallthrough} { @@ -805,22 +805,22 @@ test error-19.4 {multiple unrelated fallthroughs #1} { set RES {} try { throw FOO bar - } trap FOO {} - trap BAR {} { + } trap FOO {} - trap BAR {} { set RES foo } trap {} {} - on error {} { set RES err - } + } set RES } {foo} test error-19.5 {multiple unrelated fallthroughs #2} { set RES {} try { throw BAZ zing - } trap FOO {} - trap BAR {} { + } trap FOO {} - trap BAR {} { set RES foo } trap {} {} - on error {} { set RES err - } + } set RES } {err} proc addmsg msg { @@ -1054,7 +1054,7 @@ namespace delete ::tcl::test::error # cleanup catch {rename p ""} ::tcltest::cleanupTests -return +return # Local Variables: # mode: tcl diff --git a/tests/info.test b/tests/info.test index 9977054..3323281 100644 --- a/tests/info.test +++ b/tests/info.test @@ -215,14 +215,14 @@ test info-6.9 {info default option} -returnCodes error -setup { set a(0) 88 proc t1 {a b} {} info default t1 a a -} -returnCodes error -result {couldn't store default value in variable "a"} +} -returnCodes error -result {can't set "a": variable is array} test info-6.10 {info default option} -setup { catch {unset a} } -cleanup {unset a} -body { set a(0) 88 proc t1 {{a 18} b} {} info default t1 a a -} -returnCodes error -result {couldn't store default value in variable "a"} +} -returnCodes error -result {can't set "a": variable is array} test info-6.11 {info default option} { catch {namespace delete test_ns_info2} namespace eval test_ns_info2 { @@ -1826,7 +1826,7 @@ test info-30.46 {TIP 280 for compiled [subst]} { } YES test info-30.47 {TIP 280 for compiled [subst]} { unset -nocomplain a - set a(\n1831) YES; set a(\n1830) 1830; set a(\n1832) 1832 + set a(\n1831) YES; set a(\n1830) 1830; set a(\n1832) 1832 subst {$a( [dict get [info frame 0] line])} ; # 1831 } YES diff --git a/tests/scan.test b/tests/scan.test index 6e1ccb0..84f22b4 100644 --- a/tests/scan.test +++ b/tests/scan.test @@ -328,7 +328,7 @@ test scan-4.60 {Tcl_ScanObjCmd, set errors} { $msg $x $y] unset z set result -} {1 {couldn't set variable "z"} abc ghi} +} {1 {can't set "z": variable is array} abc ghi} test scan-4.61 {Tcl_ScanObjCmd, set errors} { set x {} catch {unset y}; array set y {} @@ -338,7 +338,7 @@ test scan-4.61 {Tcl_ScanObjCmd, set errors} { unset y unset z set result -} {1 {couldn't set variable "z"couldn't set variable "y"} abc} +} {1 {can't set "z": variable is array} abc} # procedure that returns the range of integers @@ -545,27 +545,27 @@ test scan-8.12 {error conditions} { catch {unset a} set a(0) 44 list [catch {scan 44 %d a} msg] $msg -} {1 {couldn't set variable "a"}} +} {1 {can't set "a": variable is array}} test scan-8.13 {error conditions} { catch {unset a} set a(0) 44 list [catch {scan 44 %c a} msg] $msg -} {1 {couldn't set variable "a"}} +} {1 {can't set "a": variable is array}} test scan-8.14 {error conditions} { catch {unset a} set a(0) 44 list [catch {scan 44 %s a} msg] $msg -} {1 {couldn't set variable "a"}} +} {1 {can't set "a": variable is array}} test scan-8.15 {error conditions} { catch {unset a} set a(0) 44 list [catch {scan 44 %f a} msg] $msg -} {1 {couldn't set variable "a"}} +} {1 {can't set "a": variable is array}} test scan-8.16 {error conditions} { catch {unset a} set a(0) 44 list [catch {scan 44 %f a} msg] $msg -} {1 {couldn't set variable "a"}} +} {1 {can't set "a": variable is array}} catch {unset a} test scan-8.17 {error conditions} { list [catch {scan 44 %2c a} msg] $msg |