[m-rev.] diff: fix output precision of deconstruct

Peter Ross pro at missioncriticalit.com
Sat Nov 30 00:25:12 AEDT 2002


Hi,

This is one of many changes which fix problems with outputting floats.
None of these changes are on the release branch, do we want to add all
the changes to the release branch as well?

===================================================================


Estimated hours taken: 1
Branches: main

Fix a bug where we weren't outputting floats to enough precision when
deconstructing them.

runtime/mercury_ml_expand_body.h:
	Use MR_sprintf_float to determine the representation of the
	deconstructed float.

library/string.m:
library/io.m:
runtime/mercury_float.c:
runtime/mercury_float.h:
	Move ML_sprintf_float to mercury_float.h.

tests/hard_coded/deconstruct_arg.exp:
tests/hard_coded/deconstruct_arg.exp2:
tests/hard_coded/deconstruct_arg.m:
	Adapt the test case to test floats which require 17 digits of
	precision.

Index: il/library/io.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/io.m,v
retrieving revision 1.278
diff -u -r1.278 io.m
--- il/library/io.m	28 Nov 2002 11:21:42 -0000	1.278
+++ il/library/io.m	29 Nov 2002 13:16:31 -0000
@@ -4410,8 +4410,8 @@
 	io__write_float(Val::in, IO0::di, IO::uo),
 		[may_call_mercury, promise_pure, tabled_for_io, thread_safe],
 "
-	char buf[ML_SPRINTF_FLOAT_BUF_SIZE];
-	ML_sprintf_float(buf, Val);
+	char buf[MR_SPRINTF_FLOAT_BUF_SIZE];
+	MR_sprintf_float(buf, Val);
 	if (ML_fprintf(mercury_current_text_output, ""%s"", buf) < 0) {
 		mercury_output_error(mercury_current_text_output);
 	}
@@ -4677,8 +4677,8 @@
 		[may_call_mercury, promise_pure, tabled_for_io, thread_safe],
 "{
 	MercuryFile *stream = (MercuryFile *) Stream;
-	char buf[ML_SPRINTF_FLOAT_BUF_SIZE];
-	ML_sprintf_float(buf, Val);
+	char buf[MR_SPRINTF_FLOAT_BUF_SIZE];
+	MR_sprintf_float(buf, Val);
 	if (ML_fprintf(stream, ""%s"", buf) < 0) {
 		mercury_output_error(stream);
 	}
Index: il/library/string.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/string.m,v
retrieving revision 1.189
diff -u -r1.189 string.m
--- il/library/string.m	27 Nov 2002 08:45:03 -0000	1.189
+++ il/library/string.m	29 Nov 2002 13:16:33 -0000
@@ -2771,9 +2771,7 @@
 	** For efficiency reasons we duplicate the C implementation
 	** of string__lowlevel_float_to_string
 	*/
-	char buf[ML_SPRINTF_FLOAT_BUF_SIZE];
-	ML_sprintf_float(buf, Flt);
-	MR_make_aligned_string_copy(Str, buf);
+	MR_float_to_string(Flt, Str);
 }").
 
 	% XXX The unsafe_promise_unique is needed because in
@@ -2833,9 +2831,7 @@
 	** Note any changes here will require the same changes in
 	** string__float_to_string.
 	*/
-	char buf[ML_SPRINTF_FLOAT_BUF_SIZE];
-	ML_sprintf_float(buf, Flt);
-	MR_make_aligned_string_copy(Str, buf);
+	MR_float_to_string(Flt, Str);
 }").
 
 :- pragma foreign_proc("C#",
@@ -2855,67 +2851,6 @@
 	% matching foreign_proc version.
 	private_builtin__sorry("string__lowlevel_float_to_string").
 
-:- pragma foreign_decl(c, "
-#ifdef MR_USE_SINGLE_PREC_FLOAT
-  #define ML_MIN_PRECISION	7
-  #define ML_FMT		""%f""
-#else
-  #define ML_MIN_PRECISION	15
-  #define ML_FMT		""%lf""
-#endif
-#define ML_MAX_PRECISION	(ML_MIN_PRECISION + 2)
-
-/*
-** The size of the buffer to pass to ML_sprintf_float.
-**
-** Longest possible string for %#.*g format is `-n.nnnnnnE-mmmm', which
-** has size  PRECISION + MAX_EXPONENT_DIGITS + 5 (for the `-', `.', `E',
-** '-', and '\\0').  PRECISION is at most 20, and MAX_EXPONENT_DIGITS is
-** at most 5, so we need at most 30 chars.  80 is way more than enough.
-*/
-#define ML_SPRINTF_FLOAT_BUF_SIZE	80
-
-void ML_sprintf_float(char *buf, MR_Float f);
-").
-
-:- pragma foreign_code(c, "
-/*
-** ML_sprintf_float(buf, f)
-**
-** fills buff with the string representation of the float, f, such that
-** the string representation has enough precision to represent the
-** float, f.
-**
-** Note that buf must have size at least ML_SPRINTF_FLOAT_BUF_SIZE.
-*/
-void
-ML_sprintf_float(char *buf, MR_Float f)
-{
-	MR_Float round = 0.0;
-	int 	 i = ML_MIN_PRECISION;
-
-	/*
-	** Print the float at increasing precisions until the float
-	** is round-trippable.
-	*/
-	do {
-		sprintf(buf, ""%#.*g"", i, f);
-		if (i >= ML_MAX_PRECISION) {
-			/*
-			** This should be sufficient precision to
-			** round-trip any value.  Don't bother checking
-			** whether it can actually be round-tripped,
-			** since if it can't, this is a bug in the C
-			** implementation.
-			*/
-			break;
-		}
-		sscanf(buf, ML_FMT, &round);
-		i++;
-	} while (round != f);
-}
-").
-
 :- pragma export(string__to_float(in, out), "ML_string_to_float").
 :- pragma foreign_proc("C",
 	string__to_float(FloatString::in, FloatVal::out),
@@ -2928,7 +2863,7 @@
 	char   	tmpc;
 	SUCCESS_INDICATOR =
 		(!MR_isspace(FloatString[0])) &&
-		(sscanf(FloatString, ML_FMT ""%c"", &FloatVal, &tmpc) == 1);
+		(sscanf(FloatString, MR_FLT_FMT ""%c"", &FloatVal, &tmpc) == 1);
 		/* MR_TRUE if sscanf succeeds, MR_FALSE otherwise */
 }").
 
Index: il/runtime/mercury_float.c
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_float.c,v
retrieving revision 1.5
diff -u -r1.5 mercury_float.c
--- il/runtime/mercury_float.c	23 Nov 2000 02:00:28 -0000	1.5
+++ il/runtime/mercury_float.c	29 Nov 2002 13:16:33 -0000
@@ -46,3 +46,41 @@
 	}
 }
+
+/*
+** MR_sprintf_float(buf, f)
+**
+** fills buff with the string representation of the float, f, such that
+** the string representation has enough precision to represent the
+** float, f.
+**
+** Note that buf must have size at least ML_SPRINTF_FLOAT_BUF_SIZE.
+*/
+void
+MR_sprintf_float(char *buf, MR_Float f)
+{
+	MR_Float round = 0.0;
+	int 	 i = MR_FLT_MIN_PRECISION;
+
+	/*
+	** Print the float at increasing precisions until the float
+	** is round-trippable.
+	*/
+	do {
+		sprintf(buf, "%#.*g", i, f);
+		if (i >= MR_FLT_MAX_PRECISION) {
+			/*
+			** This should be sufficient precision to
+			** round-trip any value.  Don't bother checking
+			** whether it can actually be round-tripped,
+			** since if it can't, this is a bug in the C
+			** implementation.
+			*/
+			break;
+		}
+		sscanf(buf, MR_FLT_FMT, &round);
+		i++;
+	} while (round != f);
+
+    return;
+}
Index: il/runtime/mercury_float.h
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_float.h,v
retrieving revision 1.15
diff -u -r1.15 mercury_float.h
--- il/runtime/mercury_float.h	26 Aug 2002 04:06:37 -0000	1.15
+++ il/runtime/mercury_float.h	29 Nov 2002 13:16:33 -0000
@@ -14,15 +14,20 @@
 
 #ifdef MR_USE_SINGLE_PREC_FLOAT
   typedef float MR_Float;
+  #define MR_FLT_MIN_PRECISION	7
+  #define MR_FLT_FMT		"%f"
 #else
   typedef double MR_Float;
+  #define MR_FLT_MIN_PRECISION	15
+  #define MR_FLT_FMT		"%lf"
 #endif
+#define MR_FLT_MAX_PRECISION	(MR_FLT_MIN_PRECISION + 2)
 
 #ifdef MR_BOXED_FLOAT 
 
-#define MR_word_to_float(w) 	(* (MR_Float *) (w))
+#define MR_word_to_float(w)	(* (MR_Float *) (w))
 
-#define MR_FLOAT_WORDS 		((sizeof(MR_Float) + sizeof(MR_Word) - 1) \
+#define MR_FLOAT_WORDS		((sizeof(MR_Float) + sizeof(MR_Word) - 1) \
 					/ sizeof(MR_Word))
 
 #ifdef MR_CONSERVATIVE_GC
@@ -89,6 +94,25 @@
   #endif /* not __GNUC__ */
 
 #endif /* not MR_BOXED_FLOAT */
+
+/*
+** The size of the buffer to pass to MR_sprintf_float.
+**
+** Longest possible string for %#.*g format is `-n.nnnnnnE-mmmm', which
+** has size  PRECISION + MAX_EXPONENT_DIGITS + 5 (for the `-', `.', `E',
+** '-', and '\\0').  PRECISION is at most 20, and MAX_EXPONENT_DIGITS is
+** at most 5, so we need at most 30 chars.  80 is way more than enough.
+*/
+#define MR_SPRINTF_FLOAT_BUF_SIZE   80
+
+#define MR_float_to_string(Float, String)			\
+	do {							\
+		char buf[MR_SPRINTF_FLOAT_BUF_SIZE];		\
+		MR_sprintf_float(buf, Float);			\
+		MR_make_aligned_string_copy(Str, buf);		\
+	} while (0)
+
+void MR_sprintf_float(char *buf, MR_Float f);
 
 MR_Integer MR_hash_float(MR_Float);
 
Index: il/runtime/mercury_ml_expand_body.h
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_ml_expand_body.h,v
retrieving revision 1.22
diff -u -r1.22 mercury_ml_expand_body.h
--- il/runtime/mercury_ml_expand_body.h	1 Aug 2002 11:52:27 -0000	1.22
+++ il/runtime/mercury_ml_expand_body.h	29 Nov 2002 13:16:36 -0000
@@ -676,13 +676,13 @@
 #ifdef  EXPAND_FUNCTOR_FIELD
             {
                 MR_Word     data_word;
-                char        buf[500];
+                char        buf[MR_SPRINTF_FLOAT_BUF_SIZE];
                 MR_Float    f;
                 char        *str;
 
                 data_word = *data_word_ptr;
                 f = MR_word_to_float(data_word);
-                sprintf(buf, "%#.15g", f);
+                MR_sprintf_float(buf, f);
                 MR_incr_saved_hp_atomic(MR_LVALUE_CAST(MR_Word, str),
                     (strlen(buf) + sizeof(MR_Word)) / sizeof(MR_Word));
                 strcpy(str, buf);
Index: tests/hard_coded/deconstruct_arg.exp
===================================================================
RCS file: /home/mercury1/repository/tests/hard_coded/deconstruct_arg.exp,v
retrieving revision 1.3
diff -u -r1.3 deconstruct_arg.exp
--- tests/hard_coded/deconstruct_arg.exp	24 Feb 2002 11:53:41 -0000	1.3
+++ tests/hard_coded/deconstruct_arg.exp	29 Nov 2002 13:16:37 -0000
@@ -134,22 +134,22 @@
 deconstruct limited deconstruct 3 of a
 functor 'a' arity 0 []
 
-std_util    functor: 3.14159000000000/0
-deconstruct functor: 3.14159000000000/0
-std_util    argument 0 of 3.14159000000000 doesn't exist
-deconstruct argument 0 of 3.14159000000000 doesn't exist
-std_util    argument 1 of 3.14159000000000 doesn't exist
-deconstruct argument 1 of 3.14159000000000 doesn't exist
-std_util    argument 2 of 3.14159000000000 doesn't exist
-deconstruct argument 2 of 3.14159000000000 doesn't exist
-std_util    deconstruct: functor 3.14159000000000 arity 0
+std_util    functor: 0.12345678901234566/0
+deconstruct functor: 0.12345678901234566/0
+std_util    argument 0 of 0.12345678901234566 doesn't exist
+deconstruct argument 0 of 0.12345678901234566 doesn't exist
+std_util    argument 1 of 0.12345678901234566 doesn't exist
+deconstruct argument 1 of 0.12345678901234566 doesn't exist
+std_util    argument 2 of 0.12345678901234566 doesn't exist
+deconstruct argument 2 of 0.12345678901234566 doesn't exist
+std_util    deconstruct: functor 0.12345678901234566 arity 0
 []
-deconstruct deconstruct: functor 3.14159000000000 arity 0
+deconstruct deconstruct: functor 0.12345678901234566 arity 0
 []
-std_util    limited deconstruct 3 of 3.14159000000000
-functor 3.14159000000000 arity 0 []
-deconstruct limited deconstruct 3 of 3.14159000000000
-functor 3.14159000000000 arity 0 []
+std_util    limited deconstruct 3 of 0.12345678901234566
+functor 0.12345678901234566 arity 0 []
+deconstruct limited deconstruct 3 of 0.12345678901234566
+functor 0.12345678901234566 arity 0 []
 
 std_util    functor: 4/0
 deconstruct functor: 4/0
Index: tests/hard_coded/deconstruct_arg.exp2
===================================================================
RCS file: /home/mercury1/repository/tests/hard_coded/deconstruct_arg.exp2,v
retrieving revision 1.1
diff -u -r1.1 deconstruct_arg.exp2
--- tests/hard_coded/deconstruct_arg.exp2	26 Feb 2002 02:36:49 -0000	1.1
+++ tests/hard_coded/deconstruct_arg.exp2	29 Nov 2002 13:16:37 -0000
@@ -134,22 +134,22 @@
 deconstruct limited deconstruct 3 of a
 functor 'a' arity 0 []
 
-std_util    functor: 3.14159000000000/0
-deconstruct functor: 3.14159000000000/0
-std_util    argument 0 of 3.14159000000000 doesn't exist
-deconstruct argument 0 of 3.14159000000000 doesn't exist
-std_util    argument 1 of 3.14159000000000 doesn't exist
-deconstruct argument 1 of 3.14159000000000 doesn't exist
-std_util    argument 2 of 3.14159000000000 doesn't exist
-deconstruct argument 2 of 3.14159000000000 doesn't exist
-std_util    deconstruct: functor 3.14159000000000 arity 0
+std_util    functor: 0.12345678901234566/0
+deconstruct functor: 0.12345678901234566/0
+std_util    argument 0 of 0.12345678901234566 doesn't exist
+deconstruct argument 0 of 0.12345678901234566 doesn't exist
+std_util    argument 1 of 0.12345678901234566 doesn't exist
+deconstruct argument 1 of 0.12345678901234566 doesn't exist
+std_util    argument 2 of 0.12345678901234566 doesn't exist
+deconstruct argument 2 of 0.12345678901234566 doesn't exist
+std_util    deconstruct: functor 0.12345678901234566 arity 0
 []
-deconstruct deconstruct: functor 3.14159000000000 arity 0
+deconstruct deconstruct: functor 0.12345678901234566 arity 0
 []
-std_util    limited deconstruct 3 of 3.14159000000000
-functor 3.14159000000000 arity 0 []
-deconstruct limited deconstruct 3 of 3.14159000000000
-functor 3.14159000000000 arity 0 []
+std_util    limited deconstruct 3 of 0.12345678901234566
+functor 0.12345678901234566 arity 0 []
+deconstruct limited deconstruct 3 of 0.12345678901234566
+functor 0.12345678901234566 arity 0 []
 
 std_util    functor: 4/0
 deconstruct functor: 4/0
Index: tests/hard_coded/deconstruct_arg.m
===================================================================
RCS file: /home/mercury1/repository/tests/hard_coded/deconstruct_arg.m,v
retrieving revision 1.3
diff -u -r1.3 deconstruct_arg.m
--- tests/hard_coded/deconstruct_arg.m	24 Feb 2002 11:53:41 -0000	1.3
+++ tests/hard_coded/deconstruct_arg.m	29 Nov 2002 13:16:37 -0000
@@ -71,8 +71,8 @@
 	test_all(qwerty(5)), newline,
 		% test characters
 	test_all('a'), newline,
-		% test floats
-	test_all(3.14159), newline,
+		% test a float which requires 17 digits of precision
+	test_all(0.12345678901234566), newline,
 		% test integers
 	test_all(4), newline,
 		% test univ.

--------------------------------------------------------------------------
mercury-reviews mailing list
post:  mercury-reviews at cs.mu.oz.au
administrative address: owner-mercury-reviews at cs.mu.oz.au
unsubscribe: Address: mercury-reviews-request at cs.mu.oz.au Message: unsubscribe
subscribe:   Address: mercury-reviews-request at cs.mu.oz.au Message: subscribe
--------------------------------------------------------------------------



More information about the reviews mailing list