[m-rev.] diff: event goal error checking

[Mark Brown]

Estimated hours taken: 1
Branches: main

Improved error checking for event goals.

compiler/typecheck.m:
	When checking that an event name matches an existing event, also
	check that the number of arguments matches the expected number.
	Otherwise typecheck_var_has_type_list will just throw an exception.

compiler/typecheck_errors.m:
	Report the argument length mismatch as an error.

	Fix the severity of unknown event call errors.  If allowed to get
	through then modes.m would throw an exception.

tests/invalid/Mercury.options:
tests/invalid/Mmakefile:
tests/invalid/invalid_event.err_exp:
tests/invalid/invalid_event.m:
tests/invalid/invalid_event_spec:
	Test the error checking.

Index: compiler/typecheck.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/typecheck.m,v
retrieving revision 1.411
diff -u -r1.411 typecheck.m
--- compiler/typecheck.m	24 Nov 2006 03:48:10 -0000	1.411
+++ compiler/typecheck.m	28 Nov 2006 05:30:00 -0000
@@ -1517,7 +1517,13 @@
     typecheck_info_get_module_info(!.Info, ModuleInfo),
     module_info_get_event_spec_map(ModuleInfo, EventSpecMap),
     ( event_arg_types(EventSpecMap, EventName, EventArgTypes) ->
-        typecheck_var_has_type_list(Args, EventArgTypes, 1, !Info)
+        ( list.same_length(Args, EventArgTypes) ->
+            typecheck_var_has_type_list(Args, EventArgTypes, 1, !Info)
+        ;
+            Spec = report_event_args_mismatch(!.Info, EventName, EventArgTypes,
+                Args),
+            typecheck_info_add_error(Spec, !Info)
+        )
     ;
         Spec = report_unknown_event_call_error(!.Info, EventName),
         typecheck_info_add_error(Spec, !Info)
Index: compiler/typecheck_errors.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/typecheck_errors.m,v
retrieving revision 1.33
diff -u -r1.33 typecheck_errors.m
--- compiler/typecheck_errors.m	6 Nov 2006 07:55:14 -0000	1.33
+++ compiler/typecheck_errors.m	28 Nov 2006 06:00:18 -0000
@@ -44,6 +44,9 @@
 
 :- func report_unknown_event_call_error(typecheck_info, string) = error_spec.
 
+:- func report_event_args_mismatch(typecheck_info, string, list(mer_type),
+    list(prog_var)) = error_spec.
+
 :- func report_no_clauses(module_info, pred_id, pred_info) = error_spec.
 
 :- func report_no_clauses_stub(module_info, pred_id, pred_info) = error_spec.
@@ -291,9 +294,19 @@
 
 report_unknown_event_call_error(Info, EventName) = Spec :-
     typecheck_info_get_context(Info, Context),
-    Pieces = [words("There is no event named"), quote(EventName), suffix(".")],
+    Pieces = [words("Error: there is no event named"),
+        quote(EventName), suffix(".")],
+    Msg = simple_msg(Context, [always(Pieces)]),
+    Spec = error_spec(severity_error, phase_type_check, [Msg]).
+
+report_event_args_mismatch(Info, EventName, EventArgTypes, Args) = Spec :-
+    typecheck_info_get_context(Info, Context),
+    Pieces = 
+        [words("Error:")] ++
+        error_num_args_to_pieces(no, length(Args), [length(EventArgTypes)]) ++
+        [words("in event"), quote(EventName), suffix(".")],
     Msg = simple_msg(Context, [always(Pieces)]),
-    Spec = error_spec(severity_warning, phase_type_check, [Msg]).
+    Spec = error_spec(severity_error, phase_type_check, [Msg]).
 
 %-----------------------------------------------------------------------------%
 
Index: tests/invalid/Mercury.options
===================================================================
RCS file: /home/mercury1/repository/tests/invalid/Mercury.options,v
retrieving revision 1.16
diff -u -r1.16 Mercury.options
--- tests/invalid/Mercury.options	15 Jun 2006 04:32:05 -0000	1.16
+++ tests/invalid/Mercury.options	28 Nov 2006 04:28:23 -0000
@@ -41,6 +41,7 @@
 MCFLAGS-impure_method_impl =	--no-intermodule-optimization \
 				--no-automatic-intermodule-optimization \
 				--verbose-error-messages
+MCFLAGS-invalid_event =		--event-spec-file-name invalid_event_spec
 MCFLAGS-loopcheck =		--warn-inferred-erroneous \
 				--verbose-error-messages
 MCFLAGS-method_impl =		--no-intermodule-optimization \
Index: tests/invalid/Mmakefile
===================================================================
RCS file: /home/mercury1/repository/tests/invalid/Mmakefile,v
retrieving revision 1.201
diff -u -r1.201 Mmakefile
--- tests/invalid/Mmakefile	21 Nov 2006 11:47:48 -0000	1.201
+++ tests/invalid/Mmakefile	28 Nov 2006 04:28:52 -0000
@@ -102,6 +102,7 @@
 	inst_list_dup \
 	instance_bug \
 	instance_dup_var \
+	invalid_event \
 	invalid_export_detism \
 	invalid_import_detism \
 	invalid_main \
Index: tests/invalid/invalid_event.err_exp
===================================================================
RCS file: tests/invalid/invalid_event.err_exp
diff -N tests/invalid/invalid_event.err_exp
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ tests/invalid/invalid_event.err_exp	28 Nov 2006 06:01:34 -0000
@@ -0,0 +1,3 @@
+invalid_event.m:032: Error: wrong number of arguments (2; should be 1) in event
+invalid_event.m:032:   `safe_test'.
+invalid_event.m:055: Error: there is no event named `nodiag_succeed'.
Index: tests/invalid/invalid_event.m
===================================================================
RCS file: tests/invalid/invalid_event.m
diff -N tests/invalid/invalid_event.m
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ tests/invalid/invalid_event.m	28 Nov 2006 05:58:06 -0000
@@ -0,0 +1,100 @@
+:- module invalid_event.
+
+:- interface.
+
+:- import_module io.
+
+:- pred main(io::di, io::uo) is cc_multi.
+
+:- implementation.
+
+:- import_module list.
+:- import_module int.
+
+:- type listint == list(int).
+
+main(!IO) :-
+	data(Data),
+	( queen(Data, Out) ->
+		print_list(Out, !IO)
+	;
+		io.write_string("No solution\n", !IO)
+	).
+
+:- pred data(list(int)::out) is det.
+
+data([1,2,3,4,5]).
+
+:- pred queen(list(int)::in, list(int)::out) is nondet.
+
+queen(Data, Out) :-
+	qperm(Data, Out),
+	event safe_test(Data, Out),
+	safe(Out).
+
+:- pred qperm(list(T)::in, list(T)::out) is nondet.
+
+qperm([], []).
+qperm(L, K) :-
+	L = [_ | _],
+	qdelete(U, L, Z),
+	K = [U | V],
+	qperm(Z, V).
+
+:- pred qdelete(T::out, list(T)::in, list(T)::out) is nondet.
+
+qdelete(A, [A | L], L).
+qdelete(X, [A | Z], [A | R]) :-
+	qdelete(X, Z, R).
+
+:- pred safe(list(int)::in) is semidet.
+
+safe([]).
+safe([N | L]) :-
+	nodiag(N, 1, L),
+	event nodiag_succeed(N, L),
+	safe(L).
+
+:- pred nodiag(int::in, int::in, list(int)::in) is semidet.
+
+nodiag(_, _, []).
+nodiag(B, D, [N | L]) :-
+	NmB = N - B,
+	BmN = B - N,
+	( D = NmB ->
+		event nodiag_fail("N - B", B, N, [N | L]),
+		fail
+	; D = BmN ->
+		event nodiag_fail("B - N", B, N, [N | L]),
+		fail
+	;
+		true
+	),
+	D1 = D + 1,
+	nodiag(B, D1, L).
+
+:- pred print_list(list(int)::in, io::di, io::uo) is det.
+
+print_list(Xs, !IO) :-
+	(
+		Xs = [],
+		io.write_string("[]\n", !IO)
+	;
+		Xs = [_ | _],
+		io.write_string("[", !IO),
+		print_list_2(Xs, !IO),
+		io.write_string("]\n", !IO)
+	).
+
+:- pred print_list_2(list(int)::in, io::di, io::uo) is det.
+
+print_list_2([], !IO).
+print_list_2([X | Xs], !IO) :-
+	io.write_int(X, !IO),
+	(
+		Xs = []
+	;
+		Xs = [_ | _],
+		io__write_string(", ", !IO),
+		print_list_2(Xs, !IO)
+	).
Index: tests/invalid/invalid_event_spec
===================================================================
RCS file: tests/invalid/invalid_event_spec
diff -N tests/invalid/invalid_event_spec
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ tests/invalid/invalid_event_spec	28 Nov 2006 04:29:23 -0000
@@ -0,0 +1,10 @@
+event nodiag_fail(
+	test_failed:	string,
+	arg_b:		int,
+	arg_d:		int,
+	arg_list:	list(int)
+)
+
+event safe_test(
+	test_list:	listint
+)
--------------------------------------------------------------------------
mercury-reviews mailing list
Post messages to:       mercury-reviews at csse.unimelb.edu.au
Administrative Queries: owner-mercury-reviews at csse.unimelb.edu.au
Subscriptions:          mercury-reviews-request at csse.unimelb.edu.au
--------------------------------------------------------------------------