[m-rev.] diff: fix ill-typed comparison abort

[Simon Taylor]

Estimated hours taken: 5
Branches: main

Fix a bug reported by Fergus, which caused an abort when a
user-defined unification or comparison predicate was ill-typed.

compiler/intermod.m:
	Don't attempt to module qualify the unification
	and comparison routines for type declarations that
	won't be used on the current back-end -- they won't
	have been typechecked. They will be ignored when read
	back in, but we put them in the `.opt' file because
	it is sometimes useful to test compiling a module
	against a workspace using a grade different to that
	used to build the workspace.

compiler/type_util.m:
	Choose the correct unification/comparison predicates for
	the current back-end where there are both Mercury and
	foreign definitions for a type.

compiler/make_hlds.m:
compiler/foreign.m:
	Move have_foreign_type_for_backend to foreign.m, for
	use by intermod.m. 

doc/reference_manual.texi:
	Clarify the documentation about user-defined unification and
	comparison predicates for foreign types.

tests/invalid/Mmakefile:
tests/invalid/illtyped_compare.{m,err_exp}:
	Add a test case.
	
tests/invalid/make_opt_error.{m,err_exp}:
	This change caused the error in this test case to not
	be reported any more (it occurred in code not used
	on the back-end being compiled for). Fix the test 
	so an error is reported.

Index: compiler/foreign.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/foreign.m,v
retrieving revision 1.29
diff -u -u -r1.29 foreign.m
--- compiler/foreign.m	25 Jul 2003 02:27:19 -0000	1.29
+++ compiler/foreign.m	20 Aug 2003 07:13:20 -0000
@@ -77,6 +77,11 @@
 	% exported_type representation of that type.
 :- func foreign__non_foreign_type((type)) = exported_type.
 
+	% Does the foreign_type_body contain a definition usable
+	% when compiling to the given target.
+:- pred have_foreign_type_for_backend(compilation_target::in,
+		foreign_type_body::in, bool::out) is det.
+
 	% Given an arbitary mercury type, get the exported_type representation
 	% of that type on the current backend.
 :- func foreign__to_exported_type(module_info, (type)) = exported_type.
@@ -655,6 +660,15 @@
 	).
 
 %-----------------------------------------------------------------------------%
+
+have_foreign_type_for_backend(c, ForeignTypeBody,
+		( ForeignTypeBody ^ c = yes(_) -> yes ; no )).
+have_foreign_type_for_backend(il, ForeignTypeBody,
+		( ForeignTypeBody ^ il = yes(_) -> yes ; no )).
+have_foreign_type_for_backend(java, ForeignTypeBody, 
+		( ForeignTypeBody ^ java = yes(_) -> yes ; no )).
+have_foreign_type_for_backend(asm, ForeignTypeBody, Result) :-
+	have_foreign_type_for_backend(c, ForeignTypeBody, Result).
 
 :- type exported_type
 	--->	foreign(sym_name)	% A type defined by a
Index: compiler/intermod.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/intermod.m,v
retrieving revision 1.144
diff -u -u -r1.144 intermod.m
--- compiler/intermod.m	25 Jul 2003 02:27:20 -0000	1.144
+++ compiler/intermod.m	20 Aug 2003 07:20:22 -0000
@@ -1036,19 +1036,34 @@
 		TypeBody0 = du_type(Ctors, Tags, Enum, MaybeUserEqComp0,
 			ReservedTag, IsSolverType, MaybeForeign0)
 	    ->
-		intermod__resolve_unify_compare_overloading(ModuleInfo,
-			TypeCtor, MaybeUserEqComp0, MaybeUserEqComp,
-			Info1, Info2),
+		module_info_globals(ModuleInfo, Globals),
+		globals__get_target(Globals, Target),
+
+		%
+		% Note that we don't resolve overloading for the definitions
+		% which won't be used on this back-end, because their
+		% unification and comparison predicates have not been
+		% typechecked. They are only written to the `.opt' it
+		% can be handy when building against a workspace for
+		% the other definitions to be present (e.g. when testing
+		% compiling a module to IL when the workspace was compiled
+		% to C).
+		%
 		(
-			MaybeForeign0 = yes(Foreign0),
+			MaybeForeign0 = yes(ForeignTypeBody0),
+			have_foreign_type_for_backend(Target,
+				ForeignTypeBody0, yes)
+		->
 			intermod__resolve_foreign_type_body_overloading(
-				ModuleInfo, TypeCtor, Foreign0, Foreign,
-				Info2, Info3),
-			MaybeForeign = yes(Foreign)
+				ModuleInfo, TypeCtor, ForeignTypeBody0,
+				ForeignTypeBody, Info1, Info3),
+			MaybeForeign = yes(ForeignTypeBody),
+			MaybeUserEqComp = MaybeUserEqComp0	
 		;
-			MaybeForeign0 = no,
-			MaybeForeign = no,
-			Info3 = Info2
+			intermod__resolve_unify_compare_overloading(ModuleInfo,
+				TypeCtor, MaybeUserEqComp0, MaybeUserEqComp,
+				Info1, Info3),
+			MaybeForeign = MaybeForeign0
 		),
 		TypeBody = du_type(Ctors, Tags, Enum, MaybeUserEqComp,
 				ReservedTag, IsSolverType, MaybeForeign),
@@ -1078,13 +1093,38 @@
 
 intermod__resolve_foreign_type_body_overloading(ModuleInfo,
 		TypeCtor, foreign_type_body(MaybeIL0, MaybeC0, MaybeJava0),
-		foreign_type_body(MaybeIL, MaybeC, MaybeJava), Info0, Info) :-
-	intermod__resolve_foreign_type_body_overloading_2(ModuleInfo, TypeCtor,
-		MaybeC0, MaybeC, Info0, Info1),
-	intermod__resolve_foreign_type_body_overloading_2(ModuleInfo, TypeCtor,
-		MaybeIL0, MaybeIL, Info1, Info2),
-	intermod__resolve_foreign_type_body_overloading_2(ModuleInfo, TypeCtor,
-		MaybeJava0, MaybeJava, Info2, Info).
+		foreign_type_body(MaybeIL, MaybeC, MaybeJava)) -->
+	{ module_info_globals(ModuleInfo, Globals) },
+	{ globals__get_target(Globals, Target) },
+
+	%
+	% Note that we don't resolve overloading for the foreign
+	% definitions which won't be used on this back-end, because
+	% their unification and comparison predicates have not been
+	% typechecked.
+	% They are only written to the `.opt' it can be handy when
+	% building against a workspace for the other definitions to
+	% be present (e.g. when testing compiling a module to IL when
+	% the workspace was compiled to C).
+	%
+	( { Target = c ; Target = asm } ->
+		intermod__resolve_foreign_type_body_overloading_2(ModuleInfo,
+			TypeCtor, MaybeC0, MaybeC)
+	;
+		{ MaybeC = MaybeC0 }
+	),
+	( { Target = il } ->
+		intermod__resolve_foreign_type_body_overloading_2(ModuleInfo,
+			TypeCtor, MaybeIL0, MaybeIL)
+	;
+		{ MaybeIL = MaybeIL0 }
+	),
+	( { Target = java } ->
+		intermod__resolve_foreign_type_body_overloading_2(ModuleInfo,
+			TypeCtor, MaybeJava0, MaybeJava)
+	;
+		{ MaybeJava = MaybeJava0 }
+	).
 
 :- pred intermod__resolve_foreign_type_body_overloading_2(module_info::in,
 		type_ctor::in, foreign_type_lang_body(T)::in,
Index: compiler/make_hlds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/make_hlds.m,v
retrieving revision 1.444
diff -u -u -r1.444 make_hlds.m
--- compiler/make_hlds.m	25 Jul 2003 02:27:20 -0000	1.444
+++ compiler/make_hlds.m	20 Aug 2003 07:07:39 -0000
@@ -2588,18 +2588,6 @@
 		{ Module = Module0 }
 	).
 
-:- pred have_foreign_type_for_backend(compilation_target::in,
-		foreign_type_body::in, bool::out) is det.
-
-have_foreign_type_for_backend(c, ForeignTypeBody,
-		( ForeignTypeBody ^ c = yes(_) -> yes ; no )).
-have_foreign_type_for_backend(il, ForeignTypeBody,
-		( ForeignTypeBody ^ il = yes(_) -> yes ; no )).
-have_foreign_type_for_backend(java, ForeignTypeBody, 
-		( ForeignTypeBody ^ java = yes(_) -> yes ; no )).
-have_foreign_type_for_backend(asm, ForeignTypeBody, Result) :-
-	have_foreign_type_for_backend(c, ForeignTypeBody, Result).
-
 	% Do the options imply that we will generate code for a specific
 	% back-end?
 :- pred generating_code(bool::out, io::di, io::uo) is det.
Index: compiler/type_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/type_util.m,v
retrieving revision 1.123
diff -u -u -r1.123 type_util.m
--- compiler/type_util.m	25 Jul 2003 02:27:26 -0000	1.123
+++ compiler/type_util.m	20 Aug 2003 13:58:52 -0000
@@ -738,13 +738,24 @@
 		UserEqComp).
 
 type_body_has_user_defined_equality_pred(ModuleInfo, TypeBody, UserEqComp) :-
-	(
-		TypeBody ^ du_type_usereq = yes(UserEqComp)
-	;
-		TypeBody = foreign_type(ForeignTypeBody, _),
-		UserEqComp = foreign_type_body_has_user_defined_equality_pred(
-				ModuleInfo, ForeignTypeBody)
-	).
+    module_info_globals(ModuleInfo, Globals),
+    globals__get_target(Globals, Target),
+    (
+	TypeBody = du_type(_, _, _, _, _, _, _),
+        (
+	    TypeBody ^ du_type_is_foreign_type = yes(ForeignTypeBody),
+            have_foreign_type_for_backend(Target, ForeignTypeBody, yes)
+	->
+            UserEqComp = foreign_type_body_has_user_defined_equality_pred(
+                                ModuleInfo, ForeignTypeBody)
+        ;
+            TypeBody ^ du_type_usereq = yes(UserEqComp)
+        )
+    ;
+        TypeBody = foreign_type(ForeignTypeBody, _),
+        UserEqComp = foreign_type_body_has_user_defined_equality_pred(
+                        ModuleInfo, ForeignTypeBody)
+    ).
 
 type_util__is_solver_type(ModuleInfo, Type) :-
 	module_info_types(ModuleInfo, TypeTable),
Index: doc/reference_manual.texi
===================================================================
RCS file: /home/mercury1/repository/mercury/doc/reference_manual.texi,v
retrieving revision 1.278
diff -u -u -r1.278 reference_manual.texi
--- doc/reference_manual.texi	1 Aug 2003 04:29:24 -0000	1.278
+++ doc/reference_manual.texi	20 Aug 2003 04:24:01 -0000
@@ -5672,7 +5672,7 @@
 are @samp{foreign_type} declarations for the type. 
 
 As with discriminated union types, programmers can specify the unification
-and comparison predicates to use for values of the type using the following
+and/or comparison predicates to use for values of the type using the following
 syntax (@pxref{User-defined equality and comparison}):
 
 @example
Index: tests/invalid/Mmakefile
===================================================================
RCS file: /home/mercury1/repository/tests/invalid/Mmakefile,v
retrieving revision 1.140
diff -u -u -r1.140 Mmakefile
--- tests/invalid/Mmakefile	3 Aug 2003 13:33:23 -0000	1.140
+++ tests/invalid/Mmakefile	20 Aug 2003 03:40:43 -0000
@@ -74,6 +74,7 @@
 	ho_default_func_3 \
 	ho_type_mode_bug \
 	ho_unique_error \
+	illtyped_compare \
 	impure_method_impl \
 	inline_conflict \
 	inst_list_dup \
@@ -251,6 +252,14 @@
 # This test case tests that we set the error status correctly
 # when building the `.opt' files.
 make_opt_error.err: make_opt_error.m
+	if $(MC) $(ALL_GRADEFLAGS) $(ALL_MCFLAGS) \
+			--make-optimization-interface $* > $*.err 2>&1; \
+	then false; \
+	else true; \
+	fi
+
+# This test case tests that we don't abort when building the `.opt' files.
+illtyped_compare.err: illtyped_compare.m
 	if $(MC) $(ALL_GRADEFLAGS) $(ALL_MCFLAGS) \
 			--make-optimization-interface $* > $*.err 2>&1; \
 	then false; \
Index: tests/invalid/illtyped_compare.err_exp
===================================================================
RCS file: tests/invalid/illtyped_compare.err_exp
diff -N tests/invalid/illtyped_compare.err_exp
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ tests/invalid/illtyped_compare.err_exp	20 Aug 2003 03:41:05 -0000
@@ -0,0 +1,17 @@
+illtyped_compare.m:015: In clause for unification predicate for type illtyped_compare.bar_rep:
+illtyped_compare.m:015:   in argument 2 of call to predicate `illtyped_compare.compare_bar/3':
+illtyped_compare.m:015:   type error: variable `HeadVar__1' has type `(illtyped_compare.bar_rep)',
+illtyped_compare.m:015:   expected type was `(illtyped_compare.bar)'.
+illtyped_compare.m:015: In clause for unification predicate for type illtyped_compare.bar_rep:
+illtyped_compare.m:015:   in argument 3 of call to predicate `illtyped_compare.compare_bar/3':
+illtyped_compare.m:015:   type error: variable `HeadVar__2' has type `(illtyped_compare.bar_rep)',
+illtyped_compare.m:015:   expected type was `(illtyped_compare.bar)'.
+illtyped_compare.m:015: In clause for comparison predicate for type illtyped_compare.bar_rep:
+illtyped_compare.m:015:   in argument 2 of call to predicate `illtyped_compare.compare_bar/3':
+illtyped_compare.m:015:   type error: variable `HeadVar__2' has type `(illtyped_compare.bar_rep)',
+illtyped_compare.m:015:   expected type was `(illtyped_compare.bar)'.
+illtyped_compare.m:015: In clause for comparison predicate for type illtyped_compare.bar_rep:
+illtyped_compare.m:015:   in argument 3 of call to predicate `illtyped_compare.compare_bar/3':
+illtyped_compare.m:015:   type error: variable `HeadVar__3' has type `(illtyped_compare.bar_rep)',
+illtyped_compare.m:015:   expected type was `(illtyped_compare.bar)'.
+For more information, try recompiling with `-E'.
Index: tests/invalid/illtyped_compare.m
===================================================================
RCS file: tests/invalid/illtyped_compare.m
diff -N tests/invalid/illtyped_compare.m
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ tests/invalid/illtyped_compare.m	20 Aug 2003 04:28:20 -0000
@@ -0,0 +1,25 @@
+:- module illtyped_compare.
+
+:- interface.
+
+:- type bar.
+
+:- implementation.
+:- type bar ---> bar(bar_rep).
+
+% This comparison predicate is ill-typed.
+:- type bar_rep ---> bar_rep(int)
+		where comparison is compare_bar_rep.
+:- pragma foreign_type("C", bar_rep, "long") 
+		where comparison is compare_bar.
+:- pragma foreign_type("IL", bar_rep, "valuetype [mscorlib]System.Double")
+		where comparison is compare_bar.
+
+:- pred compare_bar(comparison_result::uo, bar::in, bar::in) is det.
+
+compare_bar((=), _, _).
+
+:- pred compare_bar_rep(comparison_result::uo,
+		bar_rep::in, bar_rep::in) is det.
+
+compare_bar_rep((=), _, _).
Index: tests/invalid/make_opt_error.err_exp
===================================================================
RCS file: /home/mercury1/repository/tests/invalid/make_opt_error.err_exp,v
retrieving revision 1.1
diff -u -u -r1.1 make_opt_error.err_exp
--- tests/invalid/make_opt_error.err_exp	17 Feb 2003 06:02:23 -0000	1.1
+++ tests/invalid/make_opt_error.err_exp	19 Aug 2003 15:56:42 -0000
@@ -1,5 +1,5 @@
-make_opt_error.m:101: Error: clause for automatically generated field access
-make_opt_error.m:101:   function `make_opt_error.x/1'.
-make_opt_error.m:102: Error: clause for automatically generated field access
-make_opt_error.m:102:   function `make_opt_error.y/1'.
+make_opt_error.m:014: Error: clause for automatically generated field access
+make_opt_error.m:014:   function `make_opt_error.x/1'.
+make_opt_error.m:015: Error: clause for automatically generated field access
+make_opt_error.m:015:   function `make_opt_error.y/1'.
 For more information, try recompiling with `-E'.
Index: tests/invalid/make_opt_error.m
===================================================================
RCS file: /home/mercury1/repository/tests/invalid/make_opt_error.m,v
retrieving revision 1.1
diff -u -u -r1.1 make_opt_error.m
--- tests/invalid/make_opt_error.m	17 Feb 2003 06:02:23 -0000	1.1
+++ tests/invalid/make_opt_error.m	19 Aug 2003 15:56:36 -0000
@@ -2,104 +2,14 @@
 
 :- interface.
 
-:- import_module io.
-
-:- pred main(io__state::di, io__state::uo) is det.
-
-:- implementation.
-
 :- type coord.
 
-:- func new(int, int) = coord.
-:- pragma export(new(in, in) = out, "exported_new").
-
 :- func x(coord) = int.
 :- func y(coord) = int.
 
-main -->
-	{ C = new(4, 5) },
-	io__write_string("X:"),
-	io__write_int(x(C)),
-	io__nl,
-	io__write_string("Y:"),
-	io__write_int(y(C)),
-	io__nl.
-
-%----------------------------------------------------------------------------%
-%----------------------------------------------------------------------------%
-%----------------------------------------------------------------------------%
-
-% IL implementation
-:- pragma foreign_type(il, coord,
-	"class [foreign_type__csharp_code]coord").
-
-:- pragma foreign_decl("C#", "
-public class coord {
-	public int x;
-	public int y;
-}
-").
-
-:- pragma foreign_proc("C#", new(X::in, Y::in) = (C::out),
-	[will_not_call_mercury, promise_pure],
-"
-	C = new coord();
-	C.x = X;
-	C.y = Y;
-").
-
-:- pragma foreign_proc("C#", x(C::in) = (X::out),
-	[will_not_call_mercury, promise_pure],
-"
-	X = C.x;
-").
-
-:- pragma foreign_proc("C#", y(C::in) = (Y::out),
-	[will_not_call_mercury, promise_pure],
-"
-	Y = C.y;
-").
-
-%----------------------------------------------------------------------------%
-%----------------------------------------------------------------------------%
-
-% C implementation
-:- pragma foreign_type(c, coord, "coord *").
-
-:- pragma foreign_decl(c, "
-typedef struct {
-	int x, y;
-} coord;
-").
-
-:- pragma foreign_proc(c, new(X::in, Y::in) = (C::out),
-	[will_not_call_mercury, promise_pure],
-"
-	C = MR_GC_NEW(coord);
-	C->x = X;
-	C->y = Y;
-").
-
-:- pragma foreign_proc(c, x(C::in) = (X::out),
-	[will_not_call_mercury, promise_pure],
-"
-	X = C->x;
-").
-
-:- pragma foreign_proc(c, y(C::in) = (Y::out),
-	[will_not_call_mercury, promise_pure],
-"
-	Y = C->y;
-").
-
-%----------------------------------------------------------------------------%
+:- implementation.
 
-% Mercury implementation
 :- type coord ---> coord(x :: int, y :: int).
 
-new(X, Y) = coord(X, Y).
 x(C) = C ^ x.
 y(C) = C ^ y.
-
-%----------------------------------------------------------------------------%
-%----------------------------------------------------------------------------%
--------------------------------------------------------------------------
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
--------------------------------------------------------------------------