Attachment "snan_2.patch" to
ticket [3105247fff]
added by
nijtmans
2010-12-22 22:02:08.
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 22 Dec 2010 14:18:38 -0000
@@ -2039,7 +2039,12 @@
* different numbers have been scanned. */
{
long value;
- float fvalue;
+ union {
+ long l;
+ float f;
+ double d;
+ Tcl_WideUInt w;
+ } val;
double dvalue;
Tcl_WideUInt uwvalue;
@@ -2206,8 +2211,15 @@
case 'f':
case 'R':
case 'r':
- CopyNumber(buffer, &fvalue, sizeof(float), type);
- return Tcl_NewDoubleObj(fvalue);
+ CopyNumber(buffer, &val.f, sizeof(float), type);
+ if (TclIsNaN(val.f)) {
+ /* don't use type cast for NaN, because it might clear the signaling bit */
+ val.w = ((((Tcl_WideUInt) val.l & 0x80000000) | 0x7ff00000) << 32)
+ | ((((Tcl_WideUInt) val.l) & 0x7fffff) << 29);
+ } else {
+ val.d = (double)(val.f);
+ }
+ return Tcl_NewDoubleObj(val.d);
/*
* 64-bit IEEE double-precision floating point.
Index: generic/tclInt.h
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclInt.h,v
retrieving revision 1.490
diff -u -r1.490 tclInt.h
--- generic/tclInt.h 10 Dec 2010 21:59:23 -0000 1.490
+++ generic/tclInt.h 22 Dec 2010 14:18:39 -0000
@@ -4265,12 +4265,24 @@
} while (0)
#endif
-#define TclSetDoubleObj(objPtr, d) \
+#define TclSetDoubleObj(objPtr, dbl) \
do { \
TclInvalidateStringRep(objPtr); \
TclFreeIntRep(objPtr); \
- (objPtr)->internalRep.doubleValue = (double)(d); \
+ (objPtr)->internalRep.doubleValue = (double)(dbl); \
(objPtr)->typePtr = &tclDoubleType; \
+ if (TclIsNaN((objPtr)->internalRep.doubleValue)) { \
+ char buffer[TCL_INTEGER_SPACE]; \
+ char *bytes = buffer; \
+ if (!((objPtr)->internalRep.wideValue & (((Tcl_WideInt)1) << 51))) { \
+ if ((objPtr)->internalRep.wideValue & (((Tcl_WideInt)1) << 63)) { \
+ *bytes++ = '-'; \
+ } \
+ sprintf(bytes, "sNaN(%" TCL_LL_MODIFIER "x)", (objPtr)->internalRep.wideValue & ((((Tcl_WideInt)1) << 51) - 1)); \
+ TclInitStringRep(objPtr, buffer, strlen(buffer)); \
+ (objPtr)->typePtr = NULL; \
+ } \
+ } \
} while (0)
/*
@@ -4312,14 +4324,26 @@
#define TclNewBooleanObj(objPtr, b) \
TclNewIntObj((objPtr), ((b)? 1 : 0))
-#define TclNewDoubleObj(objPtr, d) \
+#define TclNewDoubleObj(objPtr, dbl) \
do { \
TclIncrObjsAllocated(); \
TclAllocObjStorage(objPtr); \
(objPtr)->refCount = 0; \
(objPtr)->bytes = NULL; \
- (objPtr)->internalRep.doubleValue = (double)(d); \
+ (objPtr)->internalRep.doubleValue = (double)(dbl); \
(objPtr)->typePtr = &tclDoubleType; \
+ if (TclIsNaN((objPtr)->internalRep.doubleValue)) { \
+ char buffer[TCL_INTEGER_SPACE]; \
+ char *bytes = buffer; \
+ if (!((objPtr)->internalRep.wideValue & (((Tcl_WideInt)1) << 51))) { \
+ if ((objPtr)->internalRep.wideValue & (((Tcl_WideInt)1) << 63)) { \
+ *bytes++ = '-'; \
+ } \
+ sprintf(bytes, "sNaN(%" TCL_LL_MODIFIER "x)", (objPtr)->internalRep.wideValue & ((((Tcl_WideInt)1) << 51) - 1)); \
+ TclInitStringRep(objPtr, buffer, strlen(buffer)); \
+ (objPtr)->typePtr = NULL; \
+ } \
+ } \
TCL_DTRACE_OBJ_CREATE(objPtr); \
} while (0)
Index: generic/tclObj.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclObj.c,v
retrieving revision 1.177
diff -u -r1.177 tclObj.c
--- generic/tclObj.c 2 Oct 2010 11:37:02 -0000 1.177
+++ generic/tclObj.c 22 Dec 2010 14:18:39 -0000
@@ -2186,6 +2186,17 @@
objPtr->internalRep.doubleValue = dblValue;
objPtr->typePtr = &tclDoubleType;
+ if (TclIsNaN((objPtr)->internalRep.doubleValue)) {
+ char buffer[TCL_INTEGER_SPACE];
+ char *bytes = buffer;
+ if (!((objPtr)->internalRep.wideValue & (((Tcl_WideInt)1) << 51))) {
+ if ((objPtr)->internalRep.wideValue & (((Tcl_WideInt)1) << 63)) {
+ *bytes++ = '-';
+ }
+ sprintf(bytes, "sNaN(%" TCL_LL_MODIFIER "x)", (objPtr)->internalRep.wideValue & ((((Tcl_WideInt)1) << 51) - 1));
+ TclInitStringRep(objPtr, buffer, strlen(buffer));
+ (objPtr)->typePtr = NULL;
+ }
return objPtr;
}
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 22 Dec 2010 14:18:39 -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
+ list [binary scan \xff\x9f\x9f\xff f arg1] $arg1
+} -result {1 -sNaN(3f3ffe0000000)}
+test binary-40.6 {ScanNumber: sNaN} -body {
+ unset -nocomplain arg1
+ list [binary scan \xff\xf3\xff\xff\xff\xff\xf3\xff d arg1] $arg1
+} -result {1 -sNaN(3fffffffff3ff)}
test binary-41.1 {ScanNumber: word alignment} {
unset -nocomplain arg1; unset arg2
@@ -2318,6 +2326,10 @@
v1 v2 v3 v4 v5 v6
list $v1 $v2 $v3 $v4 $v5 $v6
} -match regexp -result {NaN(\([[:xdigit:]]+\))? NaN(\([[:xdigit:]]+\))? NaN(\([[:xdigit:]]+\))? NaN(\([[:xdigit:]]+\))? NaN(\([[:xdigit:]]+\))? NaN(\([[:xdigit:]]+\))?}
+test binary-60.2 {[binary format] with sNaN} -body {
+ binary scan \x7f\xf3\xff\xff\xff\xff\xf3\x7f d d
+ binary format d $d
+} -returnCodes 1 -result {expected floating-point number but got "sNaN(3fffffffff37f)"}
# scan m
test binary-61.1 {Tcl_BinaryObjCmd: scan wide int} bigEndian {
@@ -2388,9 +2400,17 @@
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)
+test binary-64.3 {sNaN} -constraints ieeeFloatingPoint -body {
+ binary scan [binary format w 0x7ff0000000000001] q d
+ set d
+} -match glob -result sNaN(1)
+test binary-64.4 {NaN} -constraints ieeeFloatingPoint -body {
+ binary scan [binary format w 0x7ff0123456789aBc] q d
+ set d
+} -match glob -result sNaN(123456789abc)
test binary-65.1 {largest significand} ieeeFloatingPoint {
binary scan [binary format w 0x3fcfffffffffffff] q d
