summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2004-11-02 15:46:34 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2004-11-02 15:46:34 (GMT)
commit22950832b701d9cbc8f109de3cf39f70fe4745b3 (patch)
tree229d3ffdede731051c5cd946a2846daae9122c7e
parent70638824c45321f58b781d0cd062c035a9656ee3 (diff)
downloadtcl-22950832b701d9cbc8f109de3cf39f70fe4745b3.zip
tcl-22950832b701d9cbc8f109de3cf39f70fe4745b3.tar.gz
tcl-22950832b701d9cbc8f109de3cf39f70fe4745b3.tar.bz2
Final fix for NaN != NaN bug. Thanks to Miguel Sofer for his improved patch.
[Bug 761471]
-rw-r--r--ChangeLog3
-rw-r--r--generic/tclExecute.c67
-rw-r--r--tests/expr.test7
3 files changed, 63 insertions, 14 deletions
diff --git a/ChangeLog b/ChangeLog
index 66a2f7f..66d9c63 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,8 @@
2004-11-02 Donal K. Fellows <donal.k.fellows@man.ac.uk>
+ * generic/tclExecute.c (TclExecuteByteCode): NaN-equality fix from
+ Miguel Sofer. [Bug 761471]
+
* doc/CrtChannel.3 (Tcl_GetChannelMode): Add synopsis. [Bug 1058446]
2004-10-31 Donal K. Fellows <donal.k.fellows@man.ac.uk>
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index ef4f379..04862e4 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.94.2.9 2004/09/18 19:17:12 dkf Exp $
+ * RCS: @(#) $Id: tclExecute.c,v 1.94.2.10 2004/11/02 15:46:35 dkf Exp $
*/
#include "tclInt.h"
@@ -2719,26 +2719,67 @@ TclExecuteByteCode(interp, codePtr)
value2Ptr = stackPtr[stackTop];
valuePtr = stackPtr[stackTop - 1];
+ /*
+ * Be careful in the equal-object case; 'NaN' isn't supposed
+ * to be equal to even itself. [Bug 761471]
+ */
+
+ t1Ptr = valuePtr->typePtr;
if (valuePtr == value2Ptr) {
/*
- * Optimize the equal object case.
+ * If we are numeric already, we can proceed to the main
+ * equality check right now. Otherwise, we need to try to
+ * coerce to a numeric type so we can see if we've got a
+ * NaN but haven't parsed it as numeric.
*/
+ if (!IS_NUMERIC_TYPE(t1Ptr)) {
+ if (t1Ptr == &tclListType) {
+ int length;
+ /*
+ * Only a list of length 1 can be NaN or such
+ * things.
+ */
+ (void) Tcl_ListObjLength(NULL, valuePtr, &length);
+ if (length == 1) {
+ goto mustConvertForNaNCheck;
+ }
+ } else {
+ /*
+ * Too bad, we'll have to compute the string and
+ * try the conversion
+ */
+
+ mustConvertForNaNCheck:
+ s1 = Tcl_GetStringFromObj(valuePtr, &length);
+ if (TclLooksLikeInt(s1, length)) {
+ GET_WIDE_OR_INT(iResult, valuePtr, i, w);
+ } else {
+ (void) Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
+ valuePtr, &d1);
+ }
+ t1Ptr = valuePtr->typePtr;
+ }
+ }
+
switch (*pc) {
- case INST_EQ:
- case INST_LE:
- case INST_GE:
- iResult = 1;
- break;
- case INST_NEQ:
- case INST_LT:
- case INST_GT:
- iResult = 0;
- break;
+ case INST_EQ:
+ case INST_LE:
+ case INST_GE:
+ iResult = !((t1Ptr == &tclDoubleType)
+ && IS_NAN(valuePtr->internalRep.doubleValue));
+ break;
+ case INST_LT:
+ case INST_GT:
+ iResult = 0;
+ break;
+ case INST_NEQ:
+ iResult = ((t1Ptr == &tclDoubleType)
+ && IS_NAN(valuePtr->internalRep.doubleValue));
+ break;
}
goto foundResult;
}
- t1Ptr = valuePtr->typePtr;
t2Ptr = value2Ptr->typePtr;
/*
diff --git a/tests/expr.test b/tests/expr.test
index 9ba169a..6ba6732 100644
--- a/tests/expr.test
+++ b/tests/expr.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: expr.test,v 1.17.2.3 2004/09/19 15:02:36 dkf Exp $
+# RCS: @(#) $Id: expr.test,v 1.17.2.4 2004/11/02 15:46:35 dkf Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
@@ -805,6 +805,11 @@ test expr-22.7 {non-numeric floats} nonPortable {
test expr-22.8 {non-numeric floats} nonPortable {
list [catch {expr {1 / Inf}} msg] $msg
} {1 {can't use infinite floating-point value as operand of "/"}}
+# Make sure [Bug 761471] stays fixed.
+test expr-22.9 {non-numeric floats: shared object equality and NaN} {
+ set x NaN
+ expr {$x == $x}
+} 0
# Some compilers get this wrong; ensure that we work around it correctly
test expr-24.1 {expr edge cases; shifting} {expr int(5)>>31} 0