[m-rev.] for review: fix typeclass bug

[David Overton]

Estimated hours taken: 5
Branches: main

compiler/typecheck.m:
	In `eliminate_constraint_by_class_rules', if `type_unify_list'
	fails for a subclass, remove that subclass from the list of
	constraints being examined rather than aborting.
	`type_unify_list' may fail if one of the arguments to the
	superclass constraint is not a type variable and does not unify
	with the corresponding argument of the subclass.
	In such cases, this particular superclass-subclass relationship
	is not relevant to the constraint we are trying to prove so it is safe
	to remove it.

tests/valid/Mmakefile:
tests/valid/typeclass_constraint_nonvar_bug.m:
	Test case.

Index: compiler/typecheck.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/typecheck.m,v
retrieving revision 1.331
diff -u -r1.331 typecheck.m
--- compiler/typecheck.m	28 Feb 2003 06:40:43 -0000	1.331
+++ compiler/typecheck.m	12 Mar 2003 03:50:54 -0000
@@ -4629,7 +4629,8 @@
 		% Convert all the subclass_details into class_constraints by
 		% doing the appropriate variable renaming and applying the
 		% type variable bindings.
-	list__map(subclass_details_to_constraint(TVarSet, SuperClassTypes),
+	list__filter_map(subclass_details_to_constraint(TVarSet,
+			SuperClassTypes),
 		SubClasses, SubClassConstraints),
 
 	(
@@ -4720,7 +4721,7 @@
 	).
 
 :- pred subclass_details_to_constraint(tvarset::in, list(type)::in,
-		subclass_details::in, class_constraint::out) is det.
+		subclass_details::in, class_constraint::out) is semidet.
 
 subclass_details_to_constraint(TVarSet, SuperClassTypes,
 			SubClassDetails, SubC) :-
@@ -4740,17 +4741,11 @@
 		% Work out what the (renamed) vars from the
 		% typeclass declaration are bound to here
 	map__init(Empty),
-	(
-		type_unify_list(SuperVars, SuperClassTypes, [],
-			Empty, Bindings)
-	->
-		SubID = class_id(SubName, _SubArity),
-		term__apply_substitution_to_list(SubVars, Bindings,
-			SubClassTypes),
-		SubC = constraint(SubName, SubClassTypes)
-	;
-		error("subclass_details_to_constraint: type_unify_list failed")
-	).
+	type_unify_list(SuperVars, SuperClassTypes, [], Empty, Bindings),
+	SubID = class_id(SubName, _SubArity),
+	term__apply_substitution_to_list(SubVars, Bindings,
+		SubClassTypes),
+	SubC = constraint(SubName, SubClassTypes).
 
 	%
 	% check_satisfiability(Constraints, HeadTypeParams):
Index: tests/valid/Mmakefile
===================================================================
RCS file: /home/mercury1/repository/tests/valid/Mmakefile,v
retrieving revision 1.126
diff -u -r1.126 Mmakefile
--- tests/valid/Mmakefile	22 Feb 2003 13:18:33 -0000	1.126
+++ tests/valid/Mmakefile	12 Mar 2003 03:50:54 -0000
@@ -25,6 +25,7 @@
 	instance_unconstrained_tvar \
 	repeated_class_constraint \
 	typeclass_constraint_no_var \
+	typeclass_constraint_nonvar_bug \
 	typeclass_det_warning
 
 ADITI_PROGS= \
Index: tests/valid/typeclass_constraint_nonvar_bug.m
===================================================================
RCS file: tests/valid/typeclass_constraint_nonvar_bug.m
diff -N tests/valid/typeclass_constraint_nonvar_bug.m
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ tests/valid/typeclass_constraint_nonvar_bug.m	12 Mar 2003 03:50:54 -0000
@@ -0,0 +1,77 @@
+:- module typeclass_constraint_nonvar_bug.
+
+:- interface.
+
+:- typeclass eq(T) where [
+	pred unify_oo(T::in, T::in) is semidet
+].
+
+:- typeclass add(T) <= eq(T) where [].
+:- typeclass neq(T) <= eq(T) where [].
+:- typeclass ord(T) <= eq(T) where [].
+:- typeclass mult(T) <= add(T) where [].
+:- typeclass sord(T) <= ord(T) where [].
+:- typeclass strict(T) <= (neq(T),sord(T)) where [].
+:- typeclass arith(T) <= (mult(T),strict(T)) where [].
+
+:- typeclass solver(T) <= eq(T) where [].
+
+:- typeclass solver_for(B, S) <= solver(S) where [].
+:- typeclass lin_mult(B, S) <= arith(B) where [].
+:- typeclass lin_arith_solver(B, S) <=
+	(add(S), ord(S), solver(S), lin_mult(B, S), solver_for(B, S)) where [].
+:- typeclass arith_solver(B, S) <= (arith(S), lin_arith_solver(B, S)) where [].
+
+:- typeclass lin_int_solver(T) <= lin_arith_solver(int, T) where [].
+:- typeclass int_solver(T) <= (arith(T), lin_int_solver(T)) where [].
+
+:- instance eq(int) where [
+	pred(unify_oo/2) is int_unify_oo
+].
+
+:- instance add(int) where [].
+:- instance neq(int) where [].
+:- instance ord(int) where [].
+:- instance mult(int) where [].
+:- instance sord(int) where [].
+:- instance strict(int) where [].
+:- instance arith(int) where [].
+
+:- type cint ---> a ; b.
+
+:- instance eq(cint) where [
+	pred(unify_oo/2) is cint_unify_oo
+].
+
+:- instance add(cint) where [].
+:- instance neq(cint) where [].
+:- instance ord(cint) where [].
+:- instance mult(cint) where [].
+:- instance sord(cint) where [].
+:- instance strict(cint) where [].
+:- instance arith(cint) where [].
+
+:- instance solver(cint) where [].
+
+:- instance solver_for(int, cint) where [].
+:- instance lin_mult(int, cint) where [].
+:- instance lin_arith_solver(int, cint) where [].
+:- instance arith_solver(int, cint) where [].
+
+:- instance lin_int_solver(cint) where [].
+:- instance int_solver(cint) where [].
+
+:- pred int_unify_oo(int::in, int::in) is semidet.
+
+:- pred cint_unify_oo(cint::in, cint::in) is semidet.
+
+:- pred do_unify_oo(int::in, int::in) is semidet.
+
+:- implementation.
+
+int_unify_oo(X, X).
+
+cint_unify_oo(X, X).
+
+do_unify_oo(X, Y) :-
+	unify_oo(X, Y).
-- 
David Overton                  Uni of Melbourne     +61 3 8344 1354
dmo at cs.mu.oz.au                Monash Uni (Clayton) +61 3 9905 5779
http://www.cs.mu.oz.au/~dmo    Mobile Phone         +61 4 0337 4393
--------------------------------------------------------------------------
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
--------------------------------------------------------------------------