diff: warning for unbound type variables

[Fergus Henderson]

Make the typechecker warn about unbound type variables.
(We might eventually upgrade this warning into an error.)

compiler/typecheck.m:
	Put back the old code to check for unbound type variables,
	as a warning rather than an error, after fixing some code
	rot and improving the message it prints out.

tests/warnings/singleton_test.m:
tests/warnings/singleton_test.exp:
tests/warnings/pragma_source_file.m:
tests/warnings/pragma_source_file.exp:
	Eliminate a few cases where deliberately incorrect code
	written to trigger singleton variable warnings also
	triggered the above-mentioned unresolved polymorphism
	warning.  I left one case in, to test the new warning.

Index: typecheck.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/typecheck.m,v
retrieving revision 1.199
diff -u -r1.199 typecheck.m
--- typecheck.m	1997/04/22 03:13:04	1.199
+++ typecheck.m	1997/04/26 11:14:41
@@ -169,7 +169,7 @@
 :- import_module mercury_to_mercury, mode_util, options, getopt, globals.
 :- import_module passes_aux, clause_to_proc.
 
-:- import_module int, list, map, string, require, std_util, tree234.
+:- import_module int, list, map, set, string, require, std_util, tree234.
 :- import_module varset, term, term_io.
 
 %-----------------------------------------------------------------------------%
@@ -482,7 +482,8 @@
 	% then we issue an error message here.
 
 	%
-	% If stuff-to-check = whole_pred, report an error for any ambiguity.
+	% If stuff-to-check = whole_pred, report an error for any ambiguity,
+	% and also check for unbound type variables.
 	% But if stuff-to-check = clause_only(HeadVars), then only report
 	% errors for type ambiguities that don't involve the head vars,
 	% because we may be able to resolve a type ambiguity for a head var
@@ -501,8 +502,17 @@
 
 typecheck_check_for_ambiguity(StuffToCheck, TypeCheckInfo0, TypeCheckInfo) :-
 	typecheck_info_get_type_assign_set(TypeCheckInfo0, TypeAssignSet),
-	( TypeAssignSet = [_TypeAssign] ->
-		TypeCheckInfo = TypeCheckInfo0
+	( TypeAssignSet = [TypeAssign] ->
+		typecheck_info_get_found_error(TypeCheckInfo0, FoundError),
+		(
+			StuffToCheck = whole_pred,
+			FoundError = no
+		->
+			check_type_bindings(TypeAssign,
+				TypeCheckInfo0, TypeCheckInfo)
+		;
+			TypeCheckInfo = TypeCheckInfo0
+		)
 	; TypeAssignSet = [TypeAssign1, TypeAssign2 | _] ->
 		%
 		% we only report an ambiguity error if
@@ -561,10 +571,6 @@
 		TypeCheckInfo = TypeCheckInfo0
 	).
 
-/************************ BEGIN JUNK
-This section is commented out, since the error which it attempts
-to detect is in fact not an error at all!
-
 	% Check that the all of the types which have been inferred
 	% for the variables in the clause do not contain any unbound type
 	% variables other than the HeadTypeParams.
@@ -575,91 +581,104 @@
 check_type_bindings(TypeAssign, TypeCheckInfo0, TypeCheckInfo) :-
 	typecheck_info_get_head_type_params(TypeCheckInfo0, HeadTypeParams),
 	type_assign_get_type_bindings(TypeAssign, TypeBindings),
-	type_assign_get_var_types(TypeAssign, VarTypes),
-	map__values(VarTypes, Types),
+	type_assign_get_var_types(TypeAssign, VarTypesMap),
+	map__to_assoc_list(VarTypesMap, VarTypesList),
 	set__init(Set0),
-	check_type_bindings_2(Types, TypeBindings, HeadTypeParams, Set0, Set),
-	set__to_sorted_list(Set, ErrorVars),
-	( ErrorVars = [] ->
+	check_type_bindings_2(VarTypesList, TypeBindings, HeadTypeParams,
+		[], Errs, Set0, _Set),
+	% ... we could at this point bind all the type variables in `Set'
+	% to `void' ...
+	( Errs = [] ->
 		TypeCheckInfo = TypeCheckInfo0
 	;
 		type_assign_get_typevarset(TypeAssign, TVarSet),
-		report_unresolved_type_error(ErrorVars, TVarSet, TypeCheckInfo0,
-			TypeCheckInfo)
+		report_unresolved_type_error(Errs, TVarSet, TypeCheckInfo0,
+				TypeCheckInfo)
 	).
 
-:- pred check_type_bindings_2(list(term), tsubst, headtypes, set(var),
-				set(var)).
-:- mode check_type_bindings_2(in, in, in, in, out) is det.
-
-check_type_bindings_2([], _, _, Set, Set).
-check_type_bindings_2([Type0 | Types], TypeBindings, HeadTypeParams, Set0,
-			Set) :-
+:- pred check_type_bindings_2(assoc_list(var, (type)), tsubst, headtypes,
+			assoc_list(var, (type)), assoc_list(var, (type)),
+			set(tvar), set(tvar)).
+:- mode check_type_bindings_2(in, in, in, in, out, in, out) is det.
+
+check_type_bindings_2([], _, _, Errs, Errs, Set, Set).
+check_type_bindings_2([Var - Type0 | VarTypes], TypeBindings, HeadTypeParams,
+			Errs0, Errs, Set0, Set) :-
 	term__apply_rec_substitution(Type0, TypeBindings, Type),
 	term__vars(Type, TVars),
 	set__list_to_set(TVars, TVarsSet0),
-	set__remove_list(TVarsSet0, HeadTypeParams, TVarsSet1),
-	set__union(Set0, TVarsSet1, Set1),
-	check_type_bindings_2(Types, TypeBindings, HeadTypeParams, Set1, Set).
+	set__delete_list(TVarsSet0, HeadTypeParams, TVarsSet1),
+	( \+ set__empty(TVarsSet1) ->
+		Errs1 = [Var - Type | Errs0],
+		set__union(Set0, TVarsSet1, Set1)
+	;
+		Errs1 = Errs0,
+		Set0 = Set1
+	),
+	check_type_bindings_2(VarTypes, TypeBindings, HeadTypeParams,
+		Errs1, Errs, Set1, Set).
 
 	% report an error: uninstantiated type parameter
 
-:- pred report_unresolved_type_error(list(var), tvarset, typecheck_info, 
-				typecheck_info).
+:- pred report_unresolved_type_error(assoc_list(var, (type)), tvarset,
+				typecheck_info, typecheck_info).
 :- mode report_unresolved_type_error(in, in, typecheck_info_di, 
 				typecheck_info_uo) is det.
 
-report_unresolved_type_error(TVars, TVarSet, TypeCheckInfo0, TypeCheckInfo) :-
+report_unresolved_type_error(Errs, TVarSet, TypeCheckInfo0, TypeCheckInfo) :-
 	typecheck_info_get_io_state(TypeCheckInfo0, IOState0),
-	report_unresolved_type_error_2(TypeCheckInfo0, TVars, TVarSet,
+	report_unresolved_type_error_2(TypeCheckInfo0, Errs, TVarSet,
 		IOState0, IOState),
-	typecheck_info_set_io_state(TypeCheckInfo0, IOState, TypeCheckInfo1),
-	typecheck_info_set_found_error(TypeCheckInfo1, yes, TypeCheckInfo).
+	typecheck_info_set_io_state(TypeCheckInfo0, IOState, TypeCheckInfo).
+	% Currently it is just a warning, not an error.
+	% typecheck_info_set_found_error(TypeCheckInfo1, yes, TypeCheckInfo).
 
-:- pred report_unresolved_type_error_2(typecheck_info, list(var), tvarset,
-					io__state, io__state).
+:- pred report_unresolved_type_error_2(typecheck_info, assoc_list(var, (type)),
+					tvarset, io__state, io__state).
 :- mode report_unresolved_type_error_2(typecheck_info_no_io, in, in, di, uo) 
 					is det.
 
-report_unresolved_type_error_2(TypeCheckInfo, TVars, TVarSet) -->
+report_unresolved_type_error_2(TypeCheckInfo, Errs, TVarSet) -->
 	write_typecheck_info_context(TypeCheckInfo),
+	{ typecheck_info_get_varset(TypeCheckInfo, VarSet) },
 	{ typecheck_info_get_context(TypeCheckInfo, Context) },
-	io__write_string("  type error: unresolved polymorphism.\n"),
+	io__write_string("  warning: unresolved polymorphism.\n"),
 	prog_out__write_context(Context),
-	io__write_string("  Unbound type vars were: "),
-	write_type_var_list(TVars, TVarSet),
-	io__write_string(".\n"),
-	globals__io_lookup_option(verbose_errors, bool(VerboseErrors)),
+	( { Errs = [_] } ->
+		io__write_string("  The variable with an unbound type was:\n")
+	;
+		io__write_string("  The variables with unbound types were:\n")
+	),
+	write_type_var_list(Errs, Context, VarSet, TVarSet),
+	prog_out__write_context(Context),
+	io__write_string("  The unbound type variable(s) will be implicitly\n"),
+	prog_out__write_context(Context),
+	io__write_string("  bound to the builtin type `void'.\n"),
+	globals__io_lookup_bool_option(verbose_errors, VerboseErrors),
 	( { VerboseErrors = yes } ->
 		io__write_string("\tThe body of the clause contains a call to a polymorphic predicate,\n"),
 		io__write_string("\tbut I can't determine which version should be called,\n"),
 		io__write_string("\tbecause the type variables listed above didn't get bound.\n"),
 			% XXX improve error message
-		io__write_string("\t(I ought to tell you which call caused the error, but I'm afraid\n"),
+		io__write_string("\t(I ought to tell you which call caused the problem, but I'm afraid\n"),
 		io__write_string("\tyou'll have to work it out yourself.  My apologies.)\n")
 	;
 		[]
 	).
 
-:- pred write_type_var_list(list(var), varset, io__state, io__state).
-:- mode write_type_var_list(in, in, di, uo) is det.
+:- pred write_type_var_list(assoc_list(var, (type)), term__context,
+			varset, tvarset, io__state, io__state).
+:- mode write_type_var_list(in, in, in, in, di, uo) is det.
 
-write_type_var_list([], _) -->
-	io__write_string("<none>").
-write_type_var_list([V|Vs], VarSet) -->
-	mercury_output_var(V, VarSet),
-	write_type_var_list_2(Vs, VarSet).
-
-:- pred write_type_var_list_2(list(var), varset, io__state, io__state).
-:- mode write_type_var_list_2(in, in, di, uo) is det.
-
-write_type_var_list_2([], _) --> [].
-write_type_var_list_2([V|Vs], VarSet) -->
-	io__write_string(", "),
-	mercury_output_var(V, VarSet),
-	write_type_var_list_2(Vs, VarSet).
-
-END JUNK ***************************/
+write_type_var_list([], _, _, _) --> [].
+write_type_var_list([Var - Type | Rest], Context, VarSet, TVarSet) -->
+	prog_out__write_context(Context),
+	io__write_string("      "),
+	mercury_output_var(Var, VarSet, no),
+	io__write_string(" :: "),
+	mercury_output_term(Type, TVarSet, no),
+	io__write_string("\n"),
+	write_type_var_list(Rest, Context, VarSet, TVarSet).
 
 %-----------------------------------------------------------------------------%
 

cvs diff: Diffing .
Index: pragma_source_file.exp
===================================================================
RCS file: /home/staff/zs/imp/tests/warnings/pragma_source_file.exp,v
retrieving revision 1.3
diff -u -r1.3 pragma_source_file.exp
--- pragma_source_file.exp	1997/04/21 07:09:19	1.3
+++ pragma_source_file.exp	1997/04/27 14:50:06
@@ -1,4 +1,4 @@
 foo.m:002: In clause for predicate `pragma_source_file:my_append/3':
-foo.m:002:   warning: variables `L1, L2' occur only once in this scope.
+foo.m:002:   warning: variable `L2' occurs only once in this scope.
 foo.m:011: In clause for predicate `pragma_source_file:my_append/3':
-foo.m:011:   warning: variables `X, Y' occur only once in this scope.
+foo.m:011:   warning: variable `X' occurs only once in this scope.
Index: pragma_source_file.m
===================================================================
RCS file: /home/staff/zs/imp/tests/warnings/pragma_source_file.m,v
retrieving revision 1.2
diff -u -r1.2 pragma_source_file.m
--- pragma_source_file.m	1997/02/23 06:12:22	1.2
+++ pragma_source_file.m	1997/04/27 14:49:28
@@ -12,8 +12,8 @@
 #1
 my_append([], L, L) :-
 #2
-	L1 = L2.
+	L = L2.
 #10
 my_append([H | T], L, [H | NT]) :-
-	X = Y,
+	X = L,
 	my_append(T, L, NT).
Index: singleton_test.exp
===================================================================
RCS file: /home/staff/zs/imp/tests/warnings/singleton_test.exp,v
retrieving revision 1.3
diff -u -r1.3 singleton_test.exp
--- singleton_test.exp	1997/04/21 07:09:20	1.3
+++ singleton_test.exp	1997/04/27 14:50:17
@@ -1,5 +1,5 @@
 singleton_test.m:022: In clause for predicate `singleton_test:my_append/3':
-singleton_test.m:022:   warning: variables `L1, L2' occur only once in this scope.
+singleton_test.m:022:   warning: variable `L2' occurs only once in this scope.
 singleton_test.m:026: In clause for function `singleton_test:my_append_func/2':
 singleton_test.m:026:   warning: variables `L1, L2' occur only once in this scope.
 singleton_test.m:027: In clause for function `singleton_test:my_append_func/2':
@@ -10,3 +10,10 @@
 singleton_test.m:033:   warning: variable `X' does not occur in the C code.
 singleton_test.m:039: In `:- pragma c_code' for predicate `singleton_test:c_hello_world/3':
 singleton_test.m:039:   warning: variable `Msg' does not occur in the C code.
+singleton_test.m:027: In clause for function `singleton_test:my_append_func/2':
+singleton_test.m:027:   warning: unresolved polymorphism.
+singleton_test.m:027:   The variables with unbound types were:
+singleton_test.m:027:       L2 :: V_2
+singleton_test.m:027:       L1 :: V_2
+singleton_test.m:027:   The unbound type variable(s) will be implicitly
+singleton_test.m:027:   bound to the builtin type `void'.
Index: singleton_test.m
===================================================================
RCS file: /home/staff/zs/imp/tests/warnings/singleton_test.m,v
retrieving revision 1.3
diff -u -r1.3 singleton_test.m
--- singleton_test.m	1997/04/21 07:09:21	1.3
+++ singleton_test.m	1997/04/27 14:47:42
@@ -19,7 +19,7 @@
 :- implementation.
 
 my_append([], L, L) :-
-	L1 = L2.
+	L = L2.
 my_append([H | T], L, [H | NT]) :-
 	my_append(T, L, NT).
 
-- 
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.