diff: bug fix for default mode decls on funcs

[David Glen JEFFERY]

Hi,

Could you please review this, Fergus? This diff fixes the bug you mailed me
the other day. (The test case you sent has been included at the end of the 
diff).

Estimated hours taken: 3.5

Bug fix. When adding a default mode for a class method function, also add the
pred-proc-id to the class-interface.

clause_to_proc.m:
	Add the new proc_id as an extra return value from
	maybe_add_default_mode.
make_hlds.m:
	After adding the class interface, go through and find all the func
	declarations and maybe_add_default_mode to each of them, collecting
	the new proc-ids to go in the class interface.
*.m:
	Ignore the extra return value from maybe_add_default_mode.


Index: compiler/clause_to_proc.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/clause_to_proc.m,v
retrieving revision 1.18
diff -u -r1.18 clause_to_proc.m
--- clause_to_proc.m	1998/01/23 12:56:19	1.18
+++ clause_to_proc.m	1998/02/02 23:51:31
@@ -40,8 +40,8 @@
 :- pred maybe_add_default_modes(list(pred_id), pred_table, pred_table).
 :- mode maybe_add_default_modes(in, in, out) is det.
 
-:- pred maybe_add_default_mode(pred_info, pred_info).
-:- mode maybe_add_default_mode(in, out) is det.
+:- pred maybe_add_default_mode(pred_info, pred_info, maybe(proc_id)).
+:- mode maybe_add_default_mode(in, out, out) is det.
 
 %-----------------------------------------------------------------------------%
 
@@ -53,11 +53,11 @@
 maybe_add_default_modes([], Preds, Preds).
 maybe_add_default_modes([PredId | PredIds], Preds0, Preds) :-
 	map__lookup(Preds0, PredId, PredInfo0),
-	maybe_add_default_mode(PredInfo0, PredInfo),
+	maybe_add_default_mode(PredInfo0, PredInfo, _),
 	map__det_update(Preds0, PredId, PredInfo, Preds1),
 	maybe_add_default_modes(PredIds, Preds1, Preds).
 
-maybe_add_default_mode(PredInfo0, PredInfo) :-
+maybe_add_default_mode(PredInfo0, PredInfo, MaybeProcId) :-
 	pred_info_procedures(PredInfo0, Procs0),
 	pred_info_get_is_pred_or_func(PredInfo0, PredOrFunc),
 	( 
@@ -89,9 +89,11 @@
 		MaybePredArgLives = no,
 		add_new_proc(PredInfo0, PredArity, PredArgModes, 
 			yes(PredArgModes), MaybePredArgLives, yes(Determinism),
-			Context, PredInfo, _ProcId)
+			Context, PredInfo, ProcId),
+		MaybeProcId = yes(ProcId)
 	;
-		PredInfo = PredInfo0
+		PredInfo = PredInfo0,
+		MaybeProcId = no
 	).
 
 copy_module_clauses_to_procs(PredIds, ModuleInfo0, ModuleInfo) :-
Index: compiler/make_hlds.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/make_hlds.m,v
retrieving revision 1.258
diff -u -r1.258 make_hlds.m
--- make_hlds.m	1998/02/02 05:17:43	1.258
+++ make_hlds.m	1998/02/03 00:06:23
@@ -1311,11 +1311,25 @@
 	module_info, io__state, io__state).
 :- mode module_add_class_interface(in, in, in, in, in, out, out, di, uo) is det.
 
-module_add_class_interface(Module, _, _, [], _, [], Module) --> [].
-module_add_class_interface(Module0, Name, Vars, [M|Ms], Status, [P|Ps], 
+module_add_class_interface(Module0, Name, Vars, Methods, Status, PredProcIds, 
+		Module) -->
+	module_add_class_interface_2(Module0, Name, Vars, Methods, Status,
+		PredProcIds0, Module1),
+	{ add_default_class_method_func_modes(Methods, PredProcIds0,
+		PredProcIds, Module1, Module) }.
+
+:- pred module_add_class_interface_2(module_info, sym_name, list(var),
+	class_interface, item_status, list(maybe(pair(pred_id, proc_id))), 
+	module_info, io__state, io__state).
+:- mode module_add_class_interface_2(in, in, in, in, in, out, out, 
+	di, uo) is det.
+
+module_add_class_interface_2(Module, _, _, [], _, [], Module) --> [].
+module_add_class_interface_2(Module0, Name, Vars, [M|Ms], Status, [P|Ps], 
 		Module) -->
 	module_add_class_method(M, Name, Vars, Status, P, Module0, Module1),
-	module_add_class_interface(Module1, Name, Vars, Ms, Status, Ps, Module).
+	module_add_class_interface_2(Module1, Name, Vars, Ms, Status, Ps,
+		Module).
 
 :- pred module_add_class_method(class_method, sym_name, list(var), 
 	item_status, maybe(pair(pred_id, proc_id)), module_info, module_info,
@@ -1360,6 +1374,52 @@
 		{ MaybePredIdProcId = yes(PredIdProcId) }
 	).
 
+	% Go through the list of class methods, looking for functions without
+	% mode declarations.
+:- pred add_default_class_method_func_modes(class_interface, 
+	list(maybe(pair(pred_id, proc_id))), 
+	list(maybe(pair(pred_id, proc_id))), module_info, module_info).
+:- mode add_default_class_method_func_modes(in, in, out, in, out) is det.
+
+add_default_class_method_func_modes([], PredProcIds, PredProcIds,
+		Module, Module).
+add_default_class_method_func_modes([M|Ms], PredProcIds0, PredProcIds,
+		Module0, Module) :-
+	(
+		M = func(_, FuncName, TypesAndModes, _, _, _, _, _)
+	->
+		module_info_name(Module0, ModuleName0),
+		sym_name_get_module_name(FuncName, ModuleName0, ModuleName),
+		unqualify_name(FuncName, Func),
+		list__length(TypesAndModes, FuncArity),
+		module_info_get_predicate_table(Module0, PredTable),
+		(
+			predicate_table_search_func_m_n_a(PredTable, ModuleName,
+				Func, FuncArity, [PredId])
+		->
+			module_info_pred_info(Module0, PredId, PredInfo0),
+			maybe_add_default_mode(PredInfo0, PredInfo, MaybeProc),
+			(
+				MaybeProc = no,
+				PredProcIds1 = PredProcIds0,
+				Module1 = Module0
+			;
+				MaybeProc = yes(ProcId),
+				NewPredProc = yes(PredId - ProcId),
+				PredProcIds1 = [NewPredProc | PredProcIds0],
+				module_info_set_pred_info(Module0, PredId,
+					PredInfo, Module1)
+			)
+		;
+			error("add_default_class_method_func_modes")
+		)
+	;
+		PredProcIds1 = PredProcIds0,
+		Module1 = Module0
+	),
+	add_default_class_method_func_modes(Ms, PredProcIds1, PredProcIds,
+		Module1, Module).
+
 :- pred module_add_instance_defn(module_info, list(class_constraint), sym_name,
 	list(type), instance_interface, varset, import_status, term__context, 
 	module_info, io__state, io__state).
@@ -1902,7 +1962,7 @@
 		{
 		pred_info_clauses_info(PredInfo1, Clauses0),
 		pred_info_typevarset(PredInfo1, TVarSet0),
-		maybe_add_default_mode(PredInfo1, PredInfo2),
+		maybe_add_default_mode(PredInfo1, PredInfo2, _),
 		pred_info_procedures(PredInfo2, Procs),
 		map__keys(Procs, ModeIds)
 		},
Index: compiler/modecheck_call.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/modecheck_call.m,v
retrieving revision 1.21
diff -u -r1.21 modecheck_call.m
--- modecheck_call.m	1998/01/16 06:44:38	1.21
+++ modecheck_call.m	1998/02/02 22:55:15
@@ -173,7 +173,7 @@
 	mode_info_get_preds(ModeInfo0, Preds),
 	mode_info_get_module_info(ModeInfo0, ModuleInfo),
 	map__lookup(Preds, PredId, PredInfo0),
-	maybe_add_default_mode(PredInfo0, PredInfo),
+	maybe_add_default_mode(PredInfo0, PredInfo, _),
 	pred_info_procedures(PredInfo, Procs),
 	map__keys(Procs, ProcIds),
 	pred_info_get_markers(PredInfo, Markers),
Index: compiler/typecheck.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/typecheck.m,v
retrieving revision 1.228
diff -u -r1.228 typecheck.m
--- typecheck.m	1998/01/27 10:59:05	1.228
+++ typecheck.m	1998/02/02 22:55:31
@@ -333,7 +333,7 @@
 			% declarations are module qualified, unless undefined
 			% modes were found by an earlier pass.
 			% 
-			maybe_add_default_mode(PredInfo1, PredInfo2),
+			maybe_add_default_mode(PredInfo1, PredInfo2, _),
 			copy_clauses_to_procs(PredInfo2, PredInfo3),
 			pred_info_arg_types(PredInfo3, _, ArgTypes),
 			pred_info_procedures(PredInfo3, Procs1),
@@ -2825,8 +2825,9 @@
 	% XXX reduction, and that is the class context of the pred.
 typecheck_constraints(yes, TypeCheckInfo, TypeCheckInfo).
 typecheck_constraints(no, TypeCheckInfo0, TypeCheckInfo) :-
-		%get the declared constraints
+		% get the declared constraints
 	typecheck_info_get_constraints(TypeCheckInfo0, DeclaredConstraints0),
+		% put them in the canonical order
 	list__sort_and_remove_dups(DeclaredConstraints0, DeclaredConstraints),
 
 

:- module test_default_func_mode.
:- interface.
:- import_module io.
:- pred main(io__state::di, io__state::uo) is det.

:- implementation.

main --> io__write_int(type_num(42)), io__nl.

:- typeclass numbered_type(T) where [
        func type_num(T) = int
].

:- instance numbered_type(int) where [
        func(type_num/1) is foo_type_num
].

:- func foo_type_num(int) = int.
foo_type_num(_) = 42.


love and cuddles,
dgj
-- 
David Jeffery (dgj at cs.mu.oz.au) |  Marge: Did you just call everyone "chicken"?
MEngSc student,                 |  Homer: Noooo.  I swear on this Bible!
Department of Computer Science  |  Marge: That's not a Bible; that's a book of
University of Melbourne         |         carpet samples!
Australia                       |  Homer: Ooooh... Fuzzy.