From 1c05acb41bff9b5827c3ba1f58cc349bc1c8d9a3 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Sun, 8 Sep 2013 14:59:41 +0000
Subject: *BACKPORT* [3600057]: Filled out missing parts of implementation of
 [string is double].

DGP - I'm pretty sure this patch is the Wrong Thing (TM) to do.
Push over to a branch until we can mutually examine it.
---
 ChangeLog          |  5 +++++
 generic/tclCmdMZ.c | 11 +++++------
 tests/string.test  | 56 ++++++++++++++++++++++++++++++++++++++++++++++++++++--
 3 files changed, 64 insertions(+), 8 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 02472fe..c938554 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,8 @@
+2013-09-08  Donal Fellows  <dkf@users.sf.net>
+
+	* generic/tclCmdMZ.c (StringIsCmd): [Bug 3600057]: Filled out missing
+	parts of implementation of [string is double].
+
 2013-08-01  Harald Oehlmann  <oehhar@users.sf.net>
 
 	* tclUnixNotify.c Tcl_InitNotifier: Bug [a0bc856dcd]
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index 6fd468c..5db4b5b 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -1512,14 +1512,14 @@ StringIsCmd(
     case STR_IS_DIGIT:
 	chcomp = Tcl_UniCharIsDigit;
 	break;
-    case STR_IS_DOUBLE: {
-	/* TODO */
+    case STR_IS_DOUBLE:
 	if ((objPtr->typePtr == &tclDoubleType) ||
-		(objPtr->typePtr == &tclIntType) ||
+		(objPtr->bytes == NULL &&
+		((objPtr->typePtr == &tclIntType) ||
 #ifndef NO_WIDE_TYPE
 		(objPtr->typePtr == &tclWideIntType) ||
 #endif
-		(objPtr->typePtr == &tclBignumType)) {
+		(objPtr->typePtr == &tclBignumType)))) {
 	    break;
 	}
 	string1 = TclGetStringFromObj(objPtr, &length1);
@@ -1531,7 +1531,7 @@ StringIsCmd(
 	}
 	end = string1 + length1;
 	if (TclParseNumber(NULL, objPtr, NULL, NULL, -1,
-		(const char **) &stop, 0) != TCL_OK) {
+		(const char **) &stop, TCL_PARSE_DECIMAL_ONLY) != TCL_OK) {
 	    result = 0;
 	    failat = 0;
 	} else {
@@ -1543,7 +1543,6 @@ StringIsCmd(
 	    }
 	}
 	break;
-    }
     case STR_IS_GRAPH:
 	chcomp = Tcl_UniCharIsGraph;
 	break;
diff --git a/tests/string.test b/tests/string.test
index 7a7a749..9fd6602 100644
--- a/tests/string.test
+++ b/tests/string.test
@@ -17,11 +17,28 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
     namespace import -force ::tcltest::*
 }
 
+proc testIEEE {} {
+    binary scan [binary format dd -1.0 1.0] c* c
+    switch -exact -- $c {
+	{0 0 0 0 0 0 -16 -65 0 0 0 0 0 0 -16 63} {
+	    return 1
+	}
+	{-65 -16 0 0 0 0 0 0 63 -16 0 0 0 0 0 0} {
+	    return 1
+	}
+	default {
+	    return 0
+	}
+    }
+}
+
 # Some tests require the testobj command
 
 testConstraint testobj [expr {[info commands testobj] != {}}]
 testConstraint testindexobj [expr {[info commands testindexobj] != {}}]
-
+# Some tests require full IEEE floating point value support
+testConstraint ieeeFloatingPoint [testIEEE]
+
 test string-1.1 {error conditions} {
     list [catch {string gorp a b} msg] $msg
 } {1 {unknown or ambiguous subcommand "gorp": must be bytelength, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}}
@@ -675,6 +692,41 @@ test string-6.108 {string is double, Bug 1382287} {
 test string-6.109 {string is double, Bug 1360532} {
     string is double 1\u00a0
 } 0
+test string-6.132 {string is double, false on hex} {
+    string is double [format "0%c5" [scan x %c]]
+} 0
+test string-6.133 {string is double, false on hex} -setup {
+    set var unset
+} -body {
+    list [string is double -fail var [format "0%c5" [scan x %c]]] $var
+} -result {0 1}
+test string-6.134 {string is double, false on hex} {
+    # Force the presence of an integer representation
+    set val 0x5; expr {$val + 1}
+    list [string is int $val] [string is double $val]
+} {1 0}
+test string-6.135 {string is double, false on new octal} {
+    string is double [format "0%c5" [scan o %c]]
+} 0
+test string-6.136 {string is double, false on new octal} -setup {
+    set var unset
+} -body {
+    list [string is double -fail var [format "0%c5" [scan o %c]]] $var
+} -result {0 1}
+test string-6.137 {string is double, false on hex} {
+    # Force the presence of an integer representation
+    set val 0o5; expr {$val + 1}
+    list [string is int $val] [string is double $val]
+} {1 0}
+test string-6.138 {string is double, true on inf} ieeeFloatingPoint {
+    string is double Inf
+} 1
+test string-6.139 {string is double, true on -inf} ieeeFloatingPoint {
+    string is double -Inf
+} 1
+test string-6.140 {string is double, true on NaN} ieeeFloatingPoint {
+    string is double NaN
+} 1
 
 catch {rename largest_int {}}
 
@@ -1664,7 +1716,7 @@ test string-25.14 {string is list} {
     set x {}
     list [string is list -failindex x "\uabcd {b c}d e"] $x
 } {0 2}
-
+
 # cleanup
 ::tcltest::cleanupTests
 return
-- 
cgit v0.12