[m-rev.] for review: conflicting tabling pragmas

[Julien Fischer]

Estimated hours taken: 2.5
Branches: main

Emit an error message when a procedure has two or more
different kinds of tabling pragma applied to it.  Presently,
the compiler just silently ignores this and applies the last
tabling pragma listed.

compiler/error_util.m:
	Make the documentation of write_error_pieces/5 more
	detailed.

compiler/make_hlds.m:
	Emit an error message if two different tabling pragmas
	are applied to the same procedure.

	Fix some lines that are > 80 chars in length.

tests/invalid/Mmakefile:
tests/invalid/conflicting_tabling_pragmas.m:
tests/invalid/conflicting_tabling_pragmas.err_exp:
	Test case for the above.

Julien.

Workspace: /home/earth/juliensf/ws49
Index: compiler/error_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/error_util.m,v
retrieving revision 1.28
diff -u -r1.28 error_util.m
--- compiler/error_util.m	20 Jul 2004 04:40:58 -0000	1.28
+++ compiler/error_util.m	3 Dec 2004 07:37:26 -0000
@@ -78,7 +78,10 @@
 :- pred write_error_plain_with_progname(string::in, string::in,
 	io::di, io::uo) is det.

-	% Display the given error message.
+	% write_error_pieces(Context, Indent, Components).
+	% Display `Components' as the error message, with
+	% `Context' as a context and indent by `Indent'.
+	%
 :- pred write_error_pieces(prog_context::in, int::in,
 	list(format_component)::in, io::di, io::uo) is det.

Index: compiler/make_hlds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/make_hlds.m,v
retrieving revision 1.485
diff -u -r1.485 make_hlds.m
--- compiler/make_hlds.m	5 Nov 2004 05:39:05 -0000	1.485
+++ compiler/make_hlds.m	7 Dec 2004 07:32:24 -0000
@@ -5381,12 +5381,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,
@@ -5460,8 +5463,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,
@@ -5470,13 +5474,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).

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

Index: tests/invalid/Mmakefile
===================================================================
RCS file: /home/mercury1/repository/tests/invalid/Mmakefile,v
retrieving revision 1.153
diff -u -r1.153 Mmakefile
--- tests/invalid/Mmakefile	27 Oct 2004 07:41:50 -0000	1.153
+++ tests/invalid/Mmakefile	7 Dec 2004 07:31:26 -0000
@@ -53,6 +53,7 @@
 	circ_type2 \
 	circ_type3 \
 	circ_type5 \
+	conflicting_tabling_pragmas \
 	constrained_poly_insts \
 	constructor_warning \
 	det_errors \
Index: tests/invalid/conflicting_tabling_pragmas.err_exp
===================================================================
RCS file: tests/invalid/conflicting_tabling_pragmas.err_exp
diff -N tests/invalid/conflicting_tabling_pragmas.err_exp
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ tests/invalid/conflicting_tabling_pragmas.err_exp	7 Dec 2004 07:31:07 -0000
@@ -0,0 +1,6 @@
+conflicting_tabling_pragmas.m:012: Error:
+conflicting_tabling_pragmas.m:012:   function `conflicting_tabling_pragmas.fac/1'
+conflicting_tabling_pragmas.m:012:   has both memo and loop_check pragmas
+conflicting_tabling_pragmas.m:012:   specified. Only one kind of tabling pragma
+conflicting_tabling_pragmas.m:012:   may be applied to it.
+For more information, try recompiling with `-E'.
Index: tests/invalid/conflicting_tabling_pragmas.m
===================================================================
RCS file: tests/invalid/conflicting_tabling_pragmas.m
diff -N tests/invalid/conflicting_tabling_pragmas.m
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ tests/invalid/conflicting_tabling_pragmas.m	7 Dec 2004 07:31:07 -0000
@@ -0,0 +1,19 @@
+:- module conflicting_tabling_pragmas.
+
+:- interface.
+
+:- import_module int.
+
+:- func fac(int) = int.
+
+:- implementation.
+
+:- pragma memo(fac/1).
+:- pragma loop_check(fac/1).
+
+fac(X) = Y :-
+	( X =< 0 ->
+		Y = 0
+	;
+		Y = X * fac(X - 1)
+	).

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