From e18619f8e98dd48417c66e66c7446da3c75fd8ae Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 2 Jul 2010 20:58:07 +0000 Subject: * generic/tclExecute.c (IllegalExprOperandType): [Bug 3024379]: Made sure that errors caused by an argument to an operator being outside the domain of the operator all result in ::errorCode being ARITH DOMAIN and not NONE. --- ChangeLog | 11 +++++++++-- generic/tclExecute.c | 3 ++- tests/mathop.test | 34 +++++++++++++++++++--------------- 3 files changed, 30 insertions(+), 18 deletions(-) diff --git a/ChangeLog b/ChangeLog index d0387f8..cad83dc 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,7 +1,14 @@ +2010-07-02 Donal K. Fellows + + * generic/tclExecute.c (IllegalExprOperandType): [Bug 3024379]: Made + sure that errors caused by an argument to an operator being outside + the domain of the operator all result in ::errorCode being ARITH + DOMAIN and not NONE. + 2010-07-02 Jan Nijtmans - * generic/tclIntDecls.h [Bug #803489] Tcl_FindNamespace problem in the - Stubs table + * generic/tclIntDecls.h: [Bug 803489]: Tcl_FindNamespace problem in + the Stubs table. 2010-07-01 Donal K. Fellows diff --git a/generic/tclExecute.c b/generic/tclExecute.c index cf26e87..41ea4f9 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.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: tclExecute.c,v 1.369.2.13 2010/02/02 20:51:47 andreas_kupries Exp $ + * RCS: @(#) $Id: tclExecute.c,v 1.369.2.14 2010/07/02 20:58:07 dkf Exp $ */ #include "tclInt.h" @@ -7701,6 +7701,7 @@ IllegalExprOperandType( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't use %s as operand of \"%s\"", description, operator)); + Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", description, NULL); } /* diff --git a/tests/mathop.test b/tests/mathop.test index b60b29d..e0d5920 100644 --- a/tests/mathop.test +++ b/tests/mathop.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: mathop.test,v 1.11.2.1 2008/03/31 17:21:15 dgp Exp $ +# RCS: @(#) $Id: mathop.test,v 1.11.2.2 2010/07/02 20:58:08 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2.1 @@ -777,9 +777,13 @@ test mathop-20.6 { one arg, error } { # skipping - for now, knownbug... foreach op {+ * / & | ^ **} { lappend res [TestOp $op {*}$vals] - lappend exp "can't use non-numeric string as operand of \"$op\" NONE" + lappend exp "can't use non-numeric string as operand of \"$op\" ARITH DOMAIN {non-numeric string}" } } + foreach op {+ * / & | ^ **} { + lappend res [TestOp $op NaN 1] + lappend exp "can't use non-numeric floating-point value as operand of \"$op\" ARITH DOMAIN {non-numeric floating-point value}" + } expr {$res eq $exp ? 0 : $res} } 0 test mathop-20.7 { multi arg } { @@ -846,15 +850,15 @@ test mathop-21.5 { unary ops, bad values } { set res {} set exp {} lappend res [TestOp / x] - lappend exp "can't use non-numeric string as operand of \"/\" NONE" + lappend exp "can't use non-numeric string as operand of \"/\" ARITH DOMAIN {non-numeric string}" lappend res [TestOp - x] - lappend exp "can't use non-numeric string as operand of \"-\" NONE" + lappend exp "can't use non-numeric string as operand of \"-\" ARITH DOMAIN {non-numeric string}" lappend res [TestOp ~ x] - lappend exp "can't use non-numeric string as operand of \"~\" NONE" + lappend exp "can't use non-numeric string as operand of \"~\" ARITH DOMAIN {non-numeric string}" lappend res [TestOp ! x] - lappend exp "can't use non-numeric string as operand of \"!\" NONE" + lappend exp "can't use non-numeric string as operand of \"!\" ARITH DOMAIN {non-numeric string}" lappend res [TestOp ~ 5.0] - lappend exp "can't use floating-point value as operand of \"~\" NONE" + lappend exp "can't use floating-point value as operand of \"~\" ARITH DOMAIN {floating-point value}" expr {$res eq $exp ? 0 : $res} } 0 test mathop-21.6 { unary ops, too many } { @@ -961,9 +965,9 @@ test mathop-22.4 { unary ops, bad values } { set exp {} foreach op {& | ^} { lappend res [TestOp $op x 5] - lappend exp "can't use non-numeric string as operand of \"$op\" NONE" + lappend exp "can't use non-numeric string as operand of \"$op\" ARITH DOMAIN {non-numeric string}" lappend res [TestOp $op 5 x] - lappend exp "can't use non-numeric string as operand of \"$op\" NONE" + lappend exp "can't use non-numeric string as operand of \"$op\" ARITH DOMAIN {non-numeric string}" } expr {$res eq $exp ? 0 : $res} } 0 @@ -1076,15 +1080,15 @@ test mathop-24.3 { binary ops, bad values } { set exp {} foreach op {% << >>} { lappend res [TestOp $op x 1] - lappend exp "can't use non-numeric string as operand of \"$op\" NONE" + lappend exp "can't use non-numeric string as operand of \"$op\" ARITH DOMAIN {non-numeric string}" lappend res [TestOp $op 1 x] - lappend exp "can't use non-numeric string as operand of \"$op\" NONE" + lappend exp "can't use non-numeric string as operand of \"$op\" ARITH DOMAIN {non-numeric string}" } foreach op {% << >>} { lappend res [TestOp $op 5.0 1] - lappend exp "can't use floating-point value as operand of \"$op\" NONE" + lappend exp "can't use floating-point value as operand of \"$op\" ARITH DOMAIN {floating-point value}" lappend res [TestOp $op 1 5.0] - lappend exp "can't use floating-point value as operand of \"$op\" NONE" + lappend exp "can't use floating-point value as operand of \"$op\" ARITH DOMAIN {floating-point value}" } foreach op {in ni} { lappend res [TestOp $op 5 "a b \{ c"] @@ -1236,9 +1240,9 @@ test mathop-25.23 { exp operator errors } { lappend res [TestOp ** $huge 2.1] lappend exp "Inf" lappend res [TestOp ** 2 foo] - lappend exp "can't use non-numeric string as operand of \"**\" NONE" + lappend exp "can't use non-numeric string as operand of \"**\" ARITH DOMAIN {non-numeric string}" lappend res [TestOp ** foo 2] - lappend exp "can't use non-numeric string as operand of \"**\" NONE" + lappend exp "can't use non-numeric string as operand of \"**\" ARITH DOMAIN {non-numeric string}" expr {$res eq $exp ? 0 : $res} } 0 -- cgit v0.12