[m-rev.] trivial diff: merge r1.486 and r1.487 of make_hlds.m correctly

[Julien Fischer]

Estimated hours taken: 0.1
Branches: main

The solver type stuff Ralph committed recently
clobbered the changes made in the previous version of make_hlds.m.
This caused invalid/conflicting_tabling_pragmas to fail.

compiler/make_hlds.m:
	Merge r1.486 and r1.487 correctly.

Index: compiler/make_hlds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/make_hlds.m,v
retrieving revision 1.487
diff -u -r1.487 make_hlds.m
--- compiler/make_hlds.m	23 Dec 2004 04:52:21 -0000	1.487
+++ compiler/make_hlds.m	24 Dec 2004 03:43:22 -0000
@@ -5390,12 +5390,15 @@
 	pred_info_get_markers(PredInfo0, Markers),
 	globals.io_lookup_bool_option(warn_table_with_inline, WarnInline, !IO),
 	( check_marker(Markers, inline), WarnInline = yes ->
-		PredNameStr = hlds_out.simple_call_id_to_string(PredOrFunc, PredName/Arity),
-		TablePragmaStr = string.format("`:- pragma %s'", [s(EvalMethodS)]),
+		PredNameStr = hlds_out.simple_call_id_to_string(PredOrFunc,
+			PredName/Arity),
+		TablePragmaStr = string.format("`:- pragma %s'",
+			[s(EvalMethodS)]),
 		InlineWarning = [
 			words("Warning: "), fixed(PredNameStr),
 			words("has a"), nl, fixed(TablePragmaStr),
-			words("declaration but also has a"), fixed("`:- pragma inline'"),
+			words("declaration but also has a"),
+			fixed("`:- pragma inline'"),
 			words("declaration."), nl,
 			words("This inline pragma will be ignored"),
 			words("since tabled predicates cannot be inlined."), nl,
@@ -5469,8 +5472,9 @@
 				PredName/Arity, !IO),
 			io__write_string(" with no declared modes.\n", !IO)
 		;
-			set_eval_method_list(ExistingProcs, EvalMethod,
-				Procs0, Procs),
+			set_eval_method_list(ExistingProcs, Context,
+				PredOrFunc, PredName/Arity, EvalMethod,
+				Procs0, Procs, !ModuleInfo, !IO),
 			pred_info_set_procedures(Procs,
 				PredInfo0, PredInfo),
 			module_info_set_pred_info(PredId, PredInfo,
@@ -5479,13 +5483,46 @@
 	).

 :- pred set_eval_method_list(assoc_list(proc_id, proc_info)::in,
-	eval_method::in, proc_table::in, proc_table::out) is det.
+	prog_context::in, pred_or_func::in, sym_name_and_arity::in,
+	eval_method::in, proc_table::in, proc_table::out,
+	module_info::in, module_info::out, io::di, io::uo) is det.

-set_eval_method_list([], _, !Procs).
-set_eval_method_list([ProcId - ProcInfo0|Rest], EvalMethod, !Procs) :-
-	proc_info_set_eval_method(EvalMethod, ProcInfo0, ProcInfo),
-	map__det_update(!.Procs, ProcId, ProcInfo, !:Procs),
-	set_eval_method_list(Rest, EvalMethod, !Procs).
+set_eval_method_list([], _, _, _, _, !Procs, !ModuleInfo, !IO).
+set_eval_method_list([ProcId - ProcInfo0 | Rest], Context, PredOrFunc,
+		PredNameAndArity, EvalMethod, !Procs, !ModuleInfo, !IO) :-
+	proc_info_eval_method(ProcInfo0, OldEvalMethod),
+	% NOTE: We don't bother detecting multiple tabling pragmas
+	% of the same type here.
+	(
+		OldEvalMethod \= eval_normal,
+		OldEvalMethod \= EvalMethod
+	->
+		% If there are conflicting tabling pragmas then
+		% emit an error message and do not bother changing
+		% the evaluation method.
+		OldEvalMethodStr = eval_method_to_string(OldEvalMethod),
+		EvalMethodStr = eval_method_to_string(EvalMethod),
+		Name = hlds_out.simple_call_id_to_string(PredOrFunc,
+			PredNameAndArity),
+		ErrorMsg = [
+			words("Error:"),
+			fixed(Name),
+			words("has both"),
+			fixed(OldEvalMethodStr),
+			words("and"),
+			fixed(EvalMethodStr),
+			words("pragmas specified."),
+			words("Only one kind of"),
+			words("tabling pragma may be applied to it.")
+		],
+		module_info_incr_errors(!ModuleInfo),
+		error_util.write_error_pieces(Context, 0, ErrorMsg, !IO)
+	;
+		proc_info_set_eval_method(EvalMethod, ProcInfo0, ProcInfo),
+		map__det_update(!.Procs, ProcId, ProcInfo, !:Procs)
+	),
+	set_eval_method_list(Rest, Context, PredOrFunc, PredNameAndArity,
+		EvalMethod, !Procs, !ModuleInfo, !IO).

 %-----------------------------------------------------------------------------%


--------------------------------------------------------------------------
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
--------------------------------------------------------------------------