[m-rev.] for review: fix float_to_string so that roundtripping works

[Peter Ross]

The interdiff of this is just as big as the original diff so here is
just the original diff.

This doesn't cause any test failures, and the change is bootchecking
now.  When it finishes bootchecking I will check it in.

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




Estimated hours taken: 8
Branches: main

Fix the I/O routines for floats so that can roundtrip.

library/string.m:
    Ensure that string__float_to_string returns a float that is
    round-trippable.  On the C backend we do that by starting at the min
    precision required and increasing it until the float roundtrips.  On
    the IL backend the R flag guarantees that a double will be
    round-trippable, so we just use that.
    Change string__to_float so that it uses the format string for the
    precision float that we are using, and export this predicate for use
    by the trace system.
    Delete the unused string__float_to_f_string.

library/io.m:
    Call string__float_to_string to determine the float to output so
    that the float output is round-trippable.

trace/mercury_trace_util.c:
    Rather than duplicating the code from the library, call the code in
    the library.

tests/general/Mmakefile:
tests/general/float_roundtrip.exp:
tests/general/float_roundtrip.m:
    Test that floats roundtrip for different required miniumum
    precisions.

Index: library/io.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/library/io.m,v
retrieving revision 1.276
diff -u -r1.276 io.m
--- library/io.m	6 Nov 2002 04:30:47 -0000	1.276
+++ library/io.m	20 Nov 2002 10:43:29 -0000
@@ -4405,16 +4405,6 @@
 ").
 
 :- pragma foreign_proc("C",
-	io__write_float(Val::in, IO0::di, IO::uo),
-		[may_call_mercury, promise_pure, tabled_for_io, thread_safe],
-"
-	if (ML_fprintf(mercury_current_text_output, ""%#.15g"", Val) < 0) {
-		mercury_output_error(mercury_current_text_output);
-	}
-	MR_update_io(IO0, IO);
-").
-
-:- pragma foreign_proc("C",
 	io__write_byte(Byte::in, IO0::di, IO::uo),
 		[may_call_mercury, promise_pure, tabled_for_io, thread_safe],
 "
@@ -4501,14 +4491,6 @@
 ").
 
 :- pragma foreign_proc("MC++",
-	io__write_float(Val::in, IO0::di, IO::uo),
-		[may_call_mercury, promise_pure, thread_safe, tabled_for_io],
-"
-	mercury_print_string(mercury_current_text_output, Val.ToString());
-	MR_update_io(IO0, IO);
-").
-
-:- pragma foreign_proc("MC++",
 	io__write_byte(Byte::in, IO0::di, IO::uo),
 		[may_call_mercury, promise_pure, thread_safe, tabled_for_io],
 "
@@ -4555,10 +4537,8 @@
 	% matching foreign_proc version.
 	{ private_builtin__sorry("io__write_int") }.
 
-io__write_float(_) -->
-	% This version is only used for back-ends for which there is no
-	% matching foreign_proc version.
-	{ private_builtin__sorry("io__write_float") }.
+io__write_float(Float) -->
+	io__write_string(string__float_to_string(Float)).
 
 io__write_byte(_) -->
 	% This version is only used for back-ends for which there is no
@@ -4679,17 +4659,6 @@
 }").
 
 :- pragma foreign_proc("C",
-	io__write_float(Stream::in, Val::in, IO0::di, IO::uo),
-		[may_call_mercury, promise_pure, tabled_for_io, thread_safe],
-"{
-	MercuryFile *stream = (MercuryFile *) Stream;
-	if (ML_fprintf(stream, ""%#.15g"", Val) < 0) {
-		mercury_output_error(stream);
-	}
-	MR_update_io(IO0, IO);
-}").
-
-:- pragma foreign_proc("C",
 	io__write_byte(Stream::in, Byte::in, IO0::di, IO::uo),
 		[may_call_mercury, promise_pure, tabled_for_io, thread_safe],
 "{
@@ -4782,16 +4751,6 @@
 }").
 
 :- pragma foreign_proc("MC++",
-	io__write_float(Stream::in, Val::in, IO0::di, IO::uo),
-		[may_call_mercury, promise_pure, thread_safe, tabled_for_io],
-"{
-	MR_MercuryFile stream = ML_DownCast(MR_MercuryFile, 
-		MR_word_to_c_pointer(Stream));
-	mercury_print_string(stream, Val.ToString());
-	MR_update_io(IO0, IO);
-}").
-
-:- pragma foreign_proc("MC++",
 	io__write_byte(Stream::in, Byte::in, IO0::di, IO::uo),
 		[may_call_mercury, promise_pure, thread_safe, tabled_for_io],
 "{
@@ -4846,10 +4805,8 @@
 	% matching foreign_proc version.
 	{ private_builtin__sorry("io__write_int") }.
 
-io__write_float(_, _) -->
-	% This version is only used for back-ends for which there is no
-	% matching foreign_proc version.
-	{ private_builtin__sorry("io__write_float") }.
+io__write_float(Stream, Float) -->
+	io__write_string(Stream, string__float_to_string(Float)).
 
 io__write_byte(_, _) -->
 	% This version is only used for back-ends for which there is no
Index: library/string.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/library/string.m,v
retrieving revision 1.184
diff -u -r1.184 string.m
--- library/string.m	15 Nov 2002 04:50:37 -0000	1.184
+++ library/string.m	20 Nov 2002 13:46:46 -0000
@@ -1824,76 +1824,70 @@
 %-----------------------------------------------------------------------------%
 
 :- pragma foreign_proc("C",
-	string__float_to_string(FloatVal::in, FloatString::uo),
+	string__float_to_string(Flt::in, Str::uo),
 		[will_not_call_mercury, promise_pure, thread_safe], "{
-	char buf[500];
-	sprintf(buf, ""%#.15g"", FloatVal);
-	MR_allocate_aligned_string_msg(FloatString, strlen(buf), MR_PROC_LABEL);
-	strcpy(FloatString, buf);
+#ifdef MR_USE_SINGLE_PREC_FLOAT
+	#define MIN_PRECISION	7
+	const char *format = ""%f"";
+#else
+	#define MIN_PRECISION	15
+	const char *format = ""%lf"";
+#endif
+	int i = MIN_PRECISION;
+	MR_Float round;
+
+		/*
+		 * Round-trip the float to ensure the precision was 
+		 * sufficient, and if not then try with the next precision.
+		*/
+	Str = MR_make_string(MR_PROC_LABEL, ""%#.*g"", i, Flt);
+	sscanf(Str, format, &round);
+
+	while (round != Flt) {
+		i++;
+		Str = MR_make_string(MR_PROC_LABEL, ""#%.*g"", i, Flt);
+		sscanf(Str, format, &round);
+	}
 }").
 
-:- pragma foreign_proc("MC++",
+:- pragma foreign_proc("il",
 	string__float_to_string(FloatVal::in, FloatString::uo),
-		[will_not_call_mercury, promise_pure, thread_safe], "{
-	FloatString = System::Convert::ToString(FloatVal);
-}").
+	[will_not_call_mercury, promise_pure, thread_safe, max_stack_size(1)], "
 
-string__float_to_string(_, _) :-
-	% This version is only used for back-ends for which there is no
-	% matching foreign_proc version.
-	private_builtin__sorry("string__float_to_string").
-
-
-	% Beware that the implementation of string__format depends
-	% on the details of what string__float_to_f_string/2 outputs.
+	ldloca	'FloatVal'
+	ldstr	""R""
 
-:- pred string__float_to_f_string(float::in, string::out) is det.
-
-:- pragma foreign_proc("C",
-	string__float_to_f_string(FloatVal::in, FloatString::out),
-		[will_not_call_mercury, promise_pure, thread_safe], "{
-	char buf[500];
-	sprintf(buf, ""%.15f"", FloatVal);
-	MR_allocate_aligned_string_msg(FloatString, strlen(buf), MR_PROC_LABEL);
-	strcpy(FloatString, buf);
-}").
+		// The R format string prints the double out such that it
+		// can be round-tripped.
+		// XXX According to the documentation it tries the 15 digits of
+		// precision, then 17 digits skipping 16 digits of precision.
+		// unlike what we do for the C backend.
+	call instance string [mscorlib]System.Double::ToString(string)
 
-:- pragma foreign_proc("MC++",
-	string__float_to_f_string(FloatVal::in, FloatString::out),
-		[will_not_call_mercury, promise_pure, thread_safe], "{
-	FloatString = System::Convert::ToString(FloatVal);
-}").
+	stloc	'FloatString'
+").
 
-string__float_to_f_string(_, _) :-
+string__float_to_string(_, _) :-
 	% This version is only used for back-ends for which there is no
 	% matching foreign_proc version.
-	private_builtin__sorry("string__float_to_f_string").
+	private_builtin__sorry("string__float_to_string").
 
+
+:- pragma export(string__to_float(in, out), "ML_string_to_float").
 :- pragma foreign_proc("C",
 	string__to_float(FloatString::in, FloatVal::out),
 		[will_not_call_mercury, promise_pure, thread_safe], "{
-	/*
-	** Use a temporary, since we can't don't know whether FloatVal is a
-	** double or float.  The %c checks for any erroneous characters
-	** appearing after the float; if there are then sscanf() will
-	** return 2 rather than 1.
-	**
-	** The logic used here is duplicated in the function MR_trace_is_float
-	** in trace/mercury_trace_util.c.
-	*/
-	double tmpf;
-	char   tmpc;
+#ifdef MR_USE_SINGLE_PREC_FLOAT
+  #define FMT    """"
+#else
+  #define FMT    ""l""
+#endif
+
+	char   	tmpc;
 	SUCCESS_INDICATOR =
 		(!MR_isspace(FloatString[0])) &&
-		(sscanf(FloatString, ""%lf%c"", &tmpf, &tmpc) == 1);
+		(sscanf(FloatString, ""%"" FMT ""f%c"", &FloatVal, &tmpc) == 1);
 		/* MR_TRUE if sscanf succeeds, MR_FALSE otherwise */
-	FloatVal = tmpf;
-}").
-
-:- pragma foreign_proc("MC++",
-	string__float_to_f_string(FloatVal::in, FloatString::out),
-		[will_not_call_mercury, promise_pure, thread_safe], "{
-	FloatString = System::Convert::ToString(FloatVal);
 }").
 
 :- pragma foreign_proc("MC++",
Index: tests/general/Mmakefile
===================================================================
RCS file: /home/staff/zs/imp/tests/general/Mmakefile,v
retrieving revision 1.46
diff -u -r1.46 Mmakefile
--- tests/general/Mmakefile	19 Nov 2002 09:42:14 -0000	1.46
+++ tests/general/Mmakefile	20 Nov 2002 10:43:30 -0000
@@ -21,6 +21,7 @@
 		duplicate_label \
 		environment \
 		fail_detism \
+		float_roundtrip \
 		float_test \
 		frameopt_mkframe_bug \
 		hello_again \
Index: tests/general/float_roundtrip.exp
===================================================================
RCS file: tests/general/float_roundtrip.exp
diff -N tests/general/float_roundtrip.exp
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ tests/general/float_roundtrip.exp	20 Nov 2002 10:43:30 -0000
@@ -0,0 +1,4 @@
+0.9092974           : success.
+0.123573124         : success.
+0.987654321012345   : success.
+0.12345678901234566 : success.
Index: tests/general/float_roundtrip.m
===================================================================
RCS file: tests/general/float_roundtrip.m
diff -N tests/general/float_roundtrip.m
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ tests/general/float_roundtrip.m	20 Nov 2002 10:43:30 -0000
@@ -0,0 +1,44 @@
+% Test that we roundtrip floats.
+:- module float_roundtrip.
+
+:- interface.
+
+:- import_module io.
+:- pred main(io::di, io::uo) is det.
+
+:- implementation.
+
+:- import_module int, list, string.
+
+main -->
+	test_float(7,  0.9092974),
+	test_float(9,  0.123573124),
+	test_float(15, 0.987654321012345),
+	test_float(17, 0.12345678901234566).
+
+:- pred test_float(int::in, float::in, io::di, io::uo) is det.
+
+test_float(ReqPrecision, Float) -->
+	{ FloatStr = string__format("%." ++ int_to_string(ReqPrecision) ++ "g",
+			[f(Float)]) },
+	{ Precision = string__length(FloatStr) - 2 },
+	io__format("%-20s: ", [s(FloatStr)]), 
+	( { Precision = ReqPrecision } ->
+		( { roundtrip_float(Float) } ->
+			io__write_string("success.\n")
+		;
+			io__write_string("failed.\n")
+		)
+	;
+		io__write_string("failed as only "),
+		io__write_int(Precision),
+		io__write_string(" digits of precision.\n")
+	).
+
+	% Test that when we round-trip the float that we get the same float
+	% back.
+:- pred roundtrip_float(float::in) is semidet.
+
+roundtrip_float(Float) :-
+	float_to_string(Float, String),
+	string__to_float(String, Float).
Index: trace/mercury_trace_util.c
===================================================================
RCS file: /home/staff/zs/imp/mercury/trace/mercury_trace_util.c,v
retrieving revision 1.9
diff -u -r1.9 mercury_trace_util.c
--- trace/mercury_trace_util.c	15 Nov 2002 04:50:49 -0000	1.9
+++ trace/mercury_trace_util.c	20 Nov 2002 10:43:30 -0000
@@ -15,6 +15,8 @@
 #include "mercury_trace_util.h"
 #include "mercury_file.h"
 
+#include "string.mh"
+
 #include <ctype.h>
 
 void
@@ -74,17 +76,7 @@
 MR_bool
 MR_trace_is_float(const char *word, MR_Float *value)
 {
-	double	tmpf;
-	char   	tmpc;
-	MR_bool	success;
-
-	/* this duplicates the logic of string__to_float */
-	success =
-		(!MR_isspace(word[0])) &&
-		(sscanf(word, "%lf%c", &tmpf, &tmpc) == 1);
-		/* MR_TRUE if sscanf succeeds, MR_FALSE otherwise */
-	*value = tmpf;
-	return success;
+	return ML_string_to_float((MR_String) word, value);
 }
 
 void

--------------------------------------------------------------------------
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
--------------------------------------------------------------------------