[m-dev.] diff: MLDS back-end: fix float no_tag bug

[Fergus Henderson]

Estimated hours taken: 0.5

compiler/ml_call_gen.m:
	Fix a bug with boxing/unboxing of float no_tag types.
	The MLDS code generator was generating a `cast' where it
	should have been generating a `box' or `unbox' plus a `cast'.

tests/hard_coded/Mmakefile:
tests/hard_coded/float_field.m:
tests/hard_coded/float_field.exp:
	A regression test.

Workspace: /home/pgrad/fjh/ws/hg
Index: compiler/ml_call_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_call_gen.m,v
retrieving revision 1.13
diff -u -d -r1.13 ml_call_gen.m
--- compiler/ml_call_gen.m	2000/06/05 00:27:21	1.13
+++ compiler/ml_call_gen.m	2000/06/05 02:35:37
@@ -543,6 +543,28 @@
 		{ ArgRval = unop(box(MLDS_SourceType), VarRval) }
 	;
 		%
+		% if converting to float, cast to mlds__generic_type
+		% and then unbox
+		%
+		{ DestType = term__functor(term__atom("float"), [], _) },
+		{ SourceType \= term__functor(term__atom("float"), [], _) }
+	->
+		ml_gen_type(DestType, MLDS_DestType),
+		{ ArgRval = unop(unbox(MLDS_DestType),
+			unop(cast(mlds__generic_type), VarRval)) }
+	;
+		%
+		% if converting from float, box and then cast the result
+		%
+		{ SourceType = term__functor(term__atom("float"), [], _) },
+		{ DestType \= term__functor(term__atom("float"), [], _) }
+	->
+		ml_gen_type(SourceType, MLDS_SourceType),
+		ml_gen_type(DestType, MLDS_DestType),
+		{ ArgRval = unop(cast(MLDS_DestType),
+			unop(box(MLDS_SourceType), VarRval)) }
+	;
+		%
 		% if converting from one concrete type to a different
 		% one, then cast
 		%
Index: tests/hard_coded/float_field.exp
===================================================================
RCS file: float_field.exp
diff -N float_field.exp
--- /dev/null	Thu Mar 30 14:06:13 2000
+++ float_field.exp	Mon Jun  5 12:02:26 2000
@@ -0,0 +1,12 @@
+foo(1.00000000000000)
+1.00000000000000
+bar(2, 3.00000000000000, 4)
+3.00000000000000
+5.00000000000000
+5.00000000000000
+foo2(1.00000000000000)
+1.00000000000000
+bar2(2, 3.00000000000000, 4)
+3.00000000000000
+5.00000000000000
+5.00000000000000
Index: tests/hard_coded/float_field.m
===================================================================
RCS file: float_field.m
diff -N float_field.m
--- /dev/null	Thu Mar 30 14:06:13 2000
+++ float_field.m	Mon Jun  5 11:58:11 2000
@@ -0,0 +1,61 @@
+% A test of types with floating point fields.
+
+:- module float_field.
+:- interface.
+:- import_module io.
+
+:- pred main(io__state, io__state).
+:- mode main(di, uo) is det.
+
+:- type foo.
+:- type bar.
+:- type baz.
+
+:- type foo2 ---> foo2(float). % no_tag type
+:- type bar2 ---> bar2(int, float, int). % ordinary d.u. type
+:- type baz2 == float. % equivalence type
+
+:- func foo_val(foo) = float.
+:- func bar_val(bar) = float.
+:- func baz_val(baz) = float.
+
+:- func foo2_val(foo2) = float.
+:- func bar2_val(bar2) = float.
+:- func baz2_val(baz2) = float.
+
+:- implementation.
+:- import_module float, math, string, list.
+
+:- type foo ---> foo(float). % no_tag type
+:- type bar ---> bar(int, float, int). % ordinary d.u. type
+:- type baz == float. % equivalence type
+
+foo_val(foo(X)) = X.
+bar_val(bar(_, X, _)) = X.
+baz_val(X) = X.
+
+foo2_val(foo2(X)) = X.
+bar2_val(bar2(_, X, _)) = X.
+baz2_val(X) = X.
+
+main -->
+	{ Foo = foo(1.0) },
+	print(Foo), nl,
+	print(foo_val(Foo)), nl,
+	{ Bar = bar(2, 3.0, 4) },
+	print(Bar), nl,
+	print(bar_val(Bar)), nl,
+	{ Baz = 5.0 },
+	print(Baz), nl,
+	print(baz_val(Baz)), nl,
+
+	{ Foo2 = foo2(1.0) },
+	print(Foo2), nl,
+	print(foo2_val(Foo2)), nl,
+	{ Bar2 = bar2(2, 3.0, 4) },
+	print(Bar2), nl,
+	print(bar2_val(Bar2)), nl,
+	{ Baz2 = 5.0 },
+	print(Baz2), nl,
+	print(baz2_val(Baz2)), nl.
+
Index: tests/hard_coded/Mmakefile
===================================================================
RCS file: /home/mercury1/repository/tests/hard_coded/Mmakefile,v
retrieving revision 1.86
diff -u -d -r1.86 Mmakefile
--- tests/hard_coded/Mmakefile	2000/05/17 18:02:24	1.86
+++ tests/hard_coded/Mmakefile	2000/06/05 02:02:10
@@ -45,6 +45,7 @@
 	export_test \
 	factt \
 	factt_non \
+	float_field \
 	float_map \
 	float_reg \
 	float_rounding_bug \

-- 
Fergus Henderson <fjh at cs.mu.oz.au>  |  "I have always known that the pursuit
WWW: <http://www.cs.mu.oz.au/~fjh>  |  of excellence is a lethal habit"
PGP: finger fjh at 128.250.37.3        |     -- the last words of T. S. Garp.
--------------------------------------------------------------------------
mercury-developers mailing list
Post messages to:       mercury-developers at cs.mu.oz.au
Administrative Queries: owner-mercury-developers at cs.mu.oz.au
Subscriptions:          mercury-developers-request at cs.mu.oz.au
--------------------------------------------------------------------------