Attachment "snan.patch" to
ticket [3105247fff]
added by
nijtmans
2010-12-17 21:59:44.
Index: generic/tclBinary.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclBinary.c,v
retrieving revision 1.69
diff -u -r1.69 tclBinary.c
--- generic/tclBinary.c 10 Dec 2010 13:08:54 -0000 1.69
+++ generic/tclBinary.c 17 Dec 2010 14:40:03 -0000
@@ -1497,6 +1497,9 @@
}
valuePtr = ScanNumber(buffer+offset, cmd, flags,
&numberCachePtr);
+ if (valuePtr == NULL) {
+ goto domainError;
+ }
offset += size;
} else {
if (count == BINARY_ALL) {
@@ -1509,6 +1512,10 @@
src = buffer + offset;
for (i = 0; i < count; i++) {
elementPtr = ScanNumber(src, cmd, flags, &numberCachePtr);
+ if (elementPtr == NULL) {
+ goto domainError;
+ }
+
src += size;
Tcl_ListObjAppendElement(NULL, valuePtr, elementPtr);
}
@@ -1580,6 +1587,10 @@
errorString = "not enough arguments for all format specifiers";
goto error;
+ domainError:
+ errorString = "domain error";
+ goto error;
+
badField:
{
Tcl_UniChar ch;
@@ -2039,8 +2050,22 @@
* different numbers have been scanned. */
{
long value;
- float fvalue;
- double dvalue;
+ union {
+ float f;
+ int i;
+ } fvalue;
+ union {
+ double d;
+ struct {
+#ifdef WORDS_BIGENDIAN
+ int word0;
+ int word1;
+#else
+ int word1;
+ int word0;
+#endif
+ } w;
+ } dvalue;
Tcl_WideUInt uwvalue;
/*
@@ -2206,8 +2231,15 @@
case 'f':
case 'R':
case 'r':
- CopyNumber(buffer, &fvalue, sizeof(float), type);
- return Tcl_NewDoubleObj(fvalue);
+ CopyNumber(buffer, &fvalue.f, sizeof(float), type);
+#if !defined( __hppa)
+ if (TclIsNaN(fvalue.f)) {
+ if ((fvalue.i & (1 << 22)) == 0) {
+ return NULL;
+ }
+ }
+#endif
+ return Tcl_NewDoubleObj(fvalue.f);
/*
* 64-bit IEEE double-precision floating point.
@@ -2216,8 +2248,15 @@
case 'd':
case 'Q':
case 'q':
- CopyNumber(buffer, &dvalue, sizeof(double), type);
- return Tcl_NewDoubleObj(dvalue);
+ CopyNumber(buffer, &dvalue.d, sizeof(double), type);
+#if !defined( __hppa)
+ if (TclIsNaN(dvalue.d)) {
+ if ((dvalue.w.word0 & (1 << 19)) == 0) {
+ return NULL;
+ }
+ }
+#endif
+ return Tcl_NewDoubleObj(dvalue.d);
}
return NULL;
}
Index: tests/binary.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/binary.test,v
retrieving revision 1.43
diff -u -r1.43 binary.test
--- tests/binary.test 9 Nov 2010 14:20:19 -0000 1.43
+++ tests/binary.test 17 Dec 2010 14:40:03 -0000
@@ -1583,6 +1583,14 @@
unset -nocomplain arg1
list [binary scan \xff\xff\xff\xff\xff\xff\xff\xff d arg1] $arg1
} -match glob -result {1 -NaN*}
+test binary-40.5 {ScanNumber: sNaN} -body {
+ unset -nocomplain arg1
+ binary scan \xff\x9f\x9f\xff f1 arg1
+} -returnCodes 1 -result {domain error}
+test binary-40.6 {ScanNumber: sNaN} -body {
+ unset -nocomplain arg1
+ list [binary scan \xff\xf3\xff\xff\xff\xff\xf3\xff d arg1] $arg1
+} -returnCodes 1 -result {domain error}
test binary-41.1 {ScanNumber: word alignment} {
unset -nocomplain arg1; unset arg2
@@ -2388,7 +2396,7 @@
set d
} -match glob -result NaN*
test binary-64.2 {NaN} -constraints ieeeFloatingPoint -body {
- binary scan [binary format w 0x7ff0123456789aBc] q d
+ binary scan [binary format w 0x7ffc123456789aBc] q d
set d
} -match glob -result NaN(*123456789abc)
