[m-rev.] for post-commit review: using error_util in parse_tree
Zoltan Somogyi
zs at csse.unimelb.edu.au
Wed Jul 16 13:29:09 AEST 2008
For post-commit review by anyone. I am committing this now because I have
some changes in the works that build on this; I will address any review
comments next week.
Zoltan.
Switch to using error_util to generate error message during the process of
converting terms to prog_items.
In many predicates, we used to return error messages as a string/term pair,
with the string being the error message and a term, which both provided
the context and was printed after the message. We now return error indications
as lists of error_specs. These include a printout of the relevant term only
if this helps users understand the nature or the location of the error.
To make the printouts easier to understand we print variable names in them
using the applicable varsets. (The old version of the compiler used to print
each error term long after it lost track of the right varset, and thus used
a dummy varset that yielded error messages referring to _1, _2 etc instead
of the variable names used by the programmer.)
Sometimes the callers of some parse predicates prepended other strings
indicating the context of the error in front of the error string.
This diff changes things so that now the caller instead passes a list
of format components describing the context to the predicates that construct
the error_specs.
In some places, simplify the code, e.g. by factoring out common code, and by
inlining some auxiliary predicates (we used to need these auxiliary predicates
for indexing when we executed the compiler using Prolog, but those days are
long past).
Mark with XXXs places where I think the error messages or their contexts
could be improved, and places where the structure of the code could be
improved.
compiler/prog_io_util.m:
Change the representation of the maybeN types to use error_spec lists.
compiler/prog_io.m:
compiler/prog_io_dcg.m:
compiler/prog_io_goal.m:
compiler/prog_io_pragma.m:
compiler/prog_io_typeclass.m:
compiler/prog_io_util.m:
Change the way we generate error messages along the lines described
at the top.
In several cases, this required adding extra arguments (varsets,
context descriptions) to predicates for use in error messages.
Some of these predicates were also used in contexts where the caller
was interested only in success, and would ignore any error messages.
In these cases, add a version of the predicate that does not require
the extra arguments, and which is semidet (to allow the caller to
avoid a test for ok).
compiler/error_util.m:
Add a mechanism for changing the case of the next format_component,
to allow an error message to be appended to a list of format_components
providing the context that generates good-looking output whether or not
that context is empty.
Replace some bools with purpose-specific types.
Make sort_error_specs internal to the module, since outside modules
should never need to use it.
Use cords instead of reversed lists to simplify some parts of the
internal implementation.
compiler/mercury_to_mercury.m:
Provide a mechanism to print out terms only if they aren't too big,
for use in our error messages.
compiler/prog_item.m:
Delete the message_list type, and note a future improvement.
compiler/prog_out.m:
Delete the predicates for printing message_lists.
compiler/intermod.m:
compiler/modules.m:
Change the way we print out error messages along the lines described
at the top.
compiler/add_clause.m:
compiler/field_access.m:
compiler/recompilation.check.m:
compiler/recompilation.version.m:
compiler/superhomogeneous.m:
Conform to the changes above by modifying how we generate error
messages.
compiler/add_class.m:
compiler/add_pragma.m:
compiler/check_typeclass.m:
compiler/common.m:
compiler/make.module_dep_file.m:
compiler/make_hlds_error.m:
compiler/make_hlds_passes.m:
compiler/mercury_compile.m:
compiler/mode_errors.m:
compiler/modes.m:
compiler/options_file.m:
compiler/prog_ctgc.m:
compiler/prog_event.m:
compiler/purity.m:
compiler/trans_opt.m:
compiler/typecheck.m:
Trivial updates to conform to the changes above.
compiler/prog_data.m:
Add some field names and access functions for use in the modules above.
library/list.m:
Add list.contains, which is list.member with the arguments reversed
to make it possibly to partially apply it.
tests/invalid/bad_finalise_decl.err_exp:
tests/invalid/bad_initialise_decl.err_exp:
tests/invalid/bad_mutable.err_exp:
tests/invalid/bigtest.err_exp:
tests/invalid/conflicting_fs.err_exp:
tests/invalid/constrained_poly_insts.err_exp:
tests/invalid/errors.err_exp:
tests/invalid/func_errors.err_exp:
tests/invalid/fundeps_unbound_in_ctor.err_exp:
tests/invalid/fundeps_vars.err_exp:
tests/invalid/impl_def_literal_syntax.err_exp:
tests/invalid/inst_list_dup.err_exp:
tests/invalid/invalid_typeclass.err_exp:
tests/invalid/kind.err_exp:
tests/invalid/null_char.err_exp:
tests/invalid/pragma_source_file.err_exp:
tests/invalid/predmode.err_exp:
tests/invalid/reserve_tag.err_exp:
tests/invalid/some.err_exp:
tests/invalid/specified.err_exp:
tests/invalid/trace_goal_env.err_exp:
tests/invalid/type_vars.err_exp:
tests/invalid/typeclass_test_1.err_exp:
tests/invalid/typeclass_test_11.err_exp:
tests/invalid/typeclass_test_2.err_exp:
tests/invalid/unbound_type_vars.err_exp:
tests/invalid/unicode1.err_exp:
tests/invalid/unicode2.err_exp:
tests/invalid/uu_type.err_exp:
tests/invalid/vars_in_wrong_places.err_exp:
tests/invalid/with_type.err_exp:
tests/invalid/purity/purity_nonsense2.err_exp:
Update the expected error messages.
cvs diff: Diffing .
cvs diff: Diffing analysis
cvs diff: Diffing bindist
cvs diff: Diffing boehm_gc
cvs diff: Diffing boehm_gc/Mac_files
cvs diff: Diffing boehm_gc/cord
cvs diff: Diffing boehm_gc/cord/private
cvs diff: Diffing boehm_gc/doc
cvs diff: Diffing boehm_gc/include
cvs diff: Diffing boehm_gc/include/private
cvs diff: Diffing boehm_gc/libatomic_ops-1.2
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/doc
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops/sysdeps
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops/sysdeps/gcc
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops/sysdeps/hpc
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops/sysdeps/ibmc
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops/sysdeps/icc
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops/sysdeps/msftc
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops/sysdeps/sunc
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/tests
cvs diff: Diffing boehm_gc/tests
cvs diff: Diffing boehm_gc/windows-untested
cvs diff: Diffing boehm_gc/windows-untested/vc60
cvs diff: Diffing boehm_gc/windows-untested/vc70
cvs diff: Diffing boehm_gc/windows-untested/vc71
cvs diff: Diffing browser
cvs diff: Diffing bytecode
cvs diff: Diffing compiler
Index: compiler/add_class.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/add_class.m,v
retrieving revision 1.29
diff -u -b -r1.29 add_class.m
--- compiler/add_class.m 15 Feb 2008 02:26:53 -0000 1.29
+++ compiler/add_class.m 13 Jul 2008 10:24:11 -0000
@@ -509,7 +509,7 @@
suffix("."), nl],
Pieces2 = [words("Previous instance declaration was here.")],
Msg1 = simple_msg(Context, [always(Pieces1)]),
- Msg2 = error_msg(yes(OtherContext), yes, 0, [always(Pieces2)]),
+ Msg2 = error_msg(yes(OtherContext), treat_as_first, 0, [always(Pieces2)]),
Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg1, Msg2]),
!:Specs = [Spec | !.Specs].
Index: compiler/add_clause.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/add_clause.m,v
retrieving revision 1.49
diff -u -b -r1.49 add_clause.m
--- compiler/add_clause.m 27 Feb 2008 07:23:02 -0000 1.49
+++ compiler/add_clause.m 13 Jul 2008 10:11:32 -0000
@@ -1119,7 +1119,9 @@
FieldValueTerm = RHSTerm
)
->
- parse_field_list(FieldNameTerm, MaybeFieldNames),
+ ContextPieces = dcg_field_error_context_pieces(AccessType),
+ parse_field_list(FieldNameTerm, !.VarSet, ContextPieces,
+ MaybeFieldNames),
(
MaybeFieldNames = ok1(FieldNames),
ArgTerms = [FieldValueTerm, TermInputTerm, TermOutputTerm],
@@ -1127,13 +1129,12 @@
Context, Goal, NumAdded, !VarSet, !ModuleInfo, !QualInfo,
!SInfo, !Specs)
;
- MaybeFieldNames = error1(Errors),
+ MaybeFieldNames = error1(FieldNamesSpecs),
+ !:Specs = FieldNamesSpecs ++ !.Specs,
invalid_goal("^", ArgTerms0, GoalInfo, Goal, !VarSet,
!SInfo, !Specs),
NumAdded = 0,
- qual_info_set_found_syntax_error(yes, !QualInfo),
- list.foldl(report_dcg_field_error(Context, AccessType, !.VarSet),
- Errors, !Specs)
+ qual_info_set_found_syntax_error(yes, !QualInfo)
)
;
invalid_goal("^", ArgTerms0, GoalInfo, Goal, !VarSet, !SInfo, !Specs),
@@ -1147,12 +1148,10 @@
!:Specs = [Spec | !.Specs]
).
-:- pred report_dcg_field_error(term.context::in, field_access_type::in,
- prog_varset::in, pair(string, term(prog_var_type))::in,
- list(error_spec)::in, list(error_spec)::out) is det.
+:- func dcg_field_error_context_pieces(field_access_type) =
+ list(format_component).
-report_dcg_field_error(Context, AccessType, VarSet, Error, !Specs) :-
- Error = ErrorMsg - ErrorTerm,
+dcg_field_error_context_pieces(AccessType) = ContextPieces :-
(
AccessType = set,
Action = "update"
@@ -1160,14 +1159,7 @@
AccessType = get,
Action = "extraction"
),
- GenericVarSet = varset.coerce(VarSet),
- TermStr = mercury_term_to_string(GenericVarSet, no, ErrorTerm),
- Pieces = [words("In DCG field"), words(Action), words("goal:"), nl,
- words("error:"), words(ErrorMsg), words("at term"),
- quote(TermStr), suffix("."), nl],
- Msg = simple_msg(Context, [always(Pieces)]),
- Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
- !:Specs = [Spec | !.Specs].
+ ContextPieces = [words("In DCG field"), words(Action), words("goal:"), nl].
% Produce an invalid goal.
%
Index: compiler/add_pragma.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/add_pragma.m,v
retrieving revision 1.82
diff -u -b -r1.82 add_pragma.m
--- compiler/add_pragma.m 27 Feb 2008 09:46:06 -0000 1.82
+++ compiler/add_pragma.m 13 Jul 2008 10:24:23 -0000
@@ -3509,7 +3509,7 @@
words("The first occurrence was here.")
],
MsgA = simple_msg(NewContext, [always(PiecesA)]),
- MsgB = error_msg(yes(ClauseContext), yes, 0,
+ MsgB = error_msg(yes(ClauseContext), treat_as_first, 0,
[always(PiecesB)]),
Spec = error_spec(severity_error,
phase_parse_tree_to_hlds, [MsgA, MsgB]),
Index: compiler/check_typeclass.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/check_typeclass.m,v
retrieving revision 1.120
diff -u -b -r1.120 check_typeclass.m
--- compiler/check_typeclass.m 7 Apr 2008 02:32:50 -0000 1.120
+++ compiler/check_typeclass.m 14 Jul 2008 15:37:18 -0000
@@ -1969,7 +1969,7 @@
PiecesB = [words("Here is the conflicting instance.")],
MsgA = simple_msg(ContextA, [always(PiecesA)]),
- MsgB = error_msg(yes(ContextB), yes, 0, [always(PiecesB)]),
+ MsgB = error_msg(yes(ContextB), treat_as_first, 0, [always(PiecesB)]),
Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [MsgA, MsgB]).
%---------------------------------------------------------------------------%
@@ -2024,8 +2024,7 @@
Pieces = Pieces0 ++ [words("function's argument or result types."), nl]
),
Msg = simple_msg(Context,
- [always(Pieces),
- verbose_only(report_unbound_tvars_explanation)]),
+ [always(Pieces), verbose_only(report_unbound_tvars_explanation)]),
Spec = error_spec(severity_error, phase_type_check, [Msg]).
:- func report_unbound_tvars_in_ctor_context(list(tvar), type_ctor,
Index: compiler/common.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/common.m,v
retrieving revision 1.107
diff -u -b -r1.107 common.m
--- compiler/common.m 26 May 2008 03:44:08 -0000 1.107
+++ compiler/common.m 13 Jul 2008 10:23:09 -0000
@@ -584,7 +584,7 @@
Msg = simple_msg(Context,
[option_is_set(warn_duplicate_calls, yes,
[always(CurPieces)])]),
- PrevMsg = error_msg(yes(PrevContext), yes, 0,
+ PrevMsg = error_msg(yes(PrevContext), treat_as_first, 0,
[option_is_set(warn_duplicate_calls, yes,
[always(PrevPieces)])]),
Spec = error_spec(Severity, phase_simplify(report_in_any_mode),
Index: compiler/error_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/error_util.m,v
retrieving revision 1.67
diff -u -b -r1.67 error_util.m
--- compiler/error_util.m 27 Feb 2008 07:23:05 -0000 1.67
+++ compiler/error_util.m 15 Jul 2008 01:52:49 -0000
@@ -132,12 +132,17 @@
% we separate it from the context by one space, whereas following lines
% are separate by three spaces. You can request that the first line of
% a message be treated as it were the first by setting the error_treat_as_first
-% field to "yes". You can also request that the pieces in a message be given
-% extra indentation by setting the error_extra_indent field to a nonzero value.
+% field to "treat_as_first". You can also request that the pieces in a message
+% be given extra indentation by setting the error_extra_indent field
+% to a nonzero value.
%
% The term simple_msg(Context, Components) is a shorthand for (and equivalent
% in every respect to) the term error_msg(yes(Context), no, 0, Components).
+:- type maybe_treat_as_first
+ ---> treat_as_first
+ ; do_not_treat_as_first.
+
:- type error_msg
---> simple_msg(
simple_context :: prog_context,
@@ -145,7 +150,7 @@
)
; error_msg(
error_context :: maybe(prog_context),
- error_treat_as_first :: bool,
+ error_treat_as_first :: maybe_treat_as_first,
error_extra_indent :: int,
error_components :: list(error_msg_component)
).
@@ -212,8 +217,6 @@
%-----------------------------------------------------------------------------%
-:- pred sort_error_specs(list(error_spec)::in, list(error_spec)::out) is det.
-
:- pred sort_error_msgs(list(error_msg)::in, list(error_msg)::out) is det.
%-----------------------------------------------------------------------------%
@@ -275,6 +278,14 @@
% then treat as fixed.
%
+ ; lower_case_next_if_not_first
+ % If this is the first component, ignore it.
+ % If this is not the first component, lower case
+ % the initial letter of the next component.
+ % There is no effect if the next component
+ % starts does not exist or does not start with
+ % an upper case letter.
+
; prefix(string) % This string should appear in the output
% in one piece, as it is, inserted directly
% before the next format_component, without
@@ -402,11 +413,12 @@
:- pred write_error_pieces_not_first_line(prog_context::in, int::in,
list(format_component)::in, io::di, io::uo) is det.
- % Display the given error message. The bool is true iff
- % this is the first line.
+ % Display the given error message. The first argument tells us whether
+ % to treat this as the first line.
%
-:- pred write_error_pieces_maybe_first_line(bool::in, prog_context::in,
- int::in, list(format_component)::in, io::di, io::uo) is det.
+:- pred write_error_pieces_maybe_first_line(maybe_treat_as_first::in,
+ prog_context::in, int::in, list(format_component)::in, io::di, io::uo)
+ is det.
:- pred write_error_pieces_maybe_with_context(maybe(prog_context)::in, int::in,
list(format_component)::in, io::di, io::uo) is det.
@@ -453,6 +465,7 @@
:- import_module libs.compiler_util.
:- import_module char.
+:- import_module cord.
:- import_module int.
:- import_module list.
:- import_module pair.
@@ -570,27 +583,9 @@
%-----------------------------------------------------------------------------%
-sort_error_specs(Specs0, Specs) :-
- list.sort_and_remove_dups(compare_error_specs, Specs0, Specs).
-
sort_error_msgs(Msgs0, Msgs) :-
list.sort_and_remove_dups(compare_error_msgs, Msgs0, Msgs).
-:- pred compare_error_specs(error_spec::in, error_spec::in,
- comparison_result::out) is det.
-
-compare_error_specs(SpecA, SpecB, Result) :-
- SpecA = error_spec(_, _, MsgsA),
- SpecB = error_spec(_, _, MsgsB),
- ContextsA = project_msgs_contexts(MsgsA),
- ContextsB = project_msgs_contexts(MsgsB),
- compare(ContextResult, ContextsA, ContextsB),
- ( ContextResult = (=) ->
- compare(Result, SpecA, SpecB)
- ;
- Result = ContextResult
- ).
-
:- func project_msgs_contexts(list(error_msg)) = list(prog_context).
project_msgs_contexts([]) = [].
@@ -683,6 +678,28 @@
%-----------------------------------------------------------------------------%
+:- pred sort_error_specs(list(error_spec)::in, list(error_spec)::out) is det.
+
+sort_error_specs(Specs0, Specs) :-
+ list.sort_and_remove_dups(compare_error_specs, Specs0, Specs).
+
+:- pred compare_error_specs(error_spec::in, error_spec::in,
+ comparison_result::out) is det.
+
+compare_error_specs(SpecA, SpecB, Result) :-
+ SpecA = error_spec(_, _, MsgsA),
+ SpecB = error_spec(_, _, MsgsB),
+ ContextsA = project_msgs_contexts(MsgsA),
+ ContextsB = project_msgs_contexts(MsgsB),
+ compare(ContextResult, ContextsA, ContextsB),
+ ( ContextResult = (=) ->
+ compare(Result, SpecA, SpecB)
+ ;
+ Result = ContextResult
+ ).
+
+%-----------------------------------------------------------------------------%
+
write_error_spec(Spec, Globals, !NumWarnings, !NumErrors, !IO) :-
write_error_specs([Spec], Globals, !NumWarnings, !NumErrors, !IO).
@@ -698,21 +715,21 @@
do_write_error_spec(Globals, OrigExitStatus, Spec, !NumWarnings, !NumErrors,
!IO) :-
Spec = error_spec(Severity, _, Msgs),
- do_write_error_msgs(Msgs, Globals, OrigExitStatus, yes, no, PrintedSome,
- !IO),
+ do_write_error_msgs(Msgs, Globals, OrigExitStatus, treat_as_first,
+ have_not_printed_anything, PrintedSome, !IO),
MaybeActual = actual_error_severity(Globals, Severity),
(
- PrintedSome = no
- % XXX the following assertion is commented out because the compiler
+ PrintedSome = have_not_printed_anything
+ % XXX The following assertion is commented out because the compiler
% can generate error specs that consist only of conditional error
% messages whose conditions can all be false (in which case nothing
- % will be printed.) Such specs will cause the assertion to fail if
+ % will be printed). Such specs will cause the assertion to fail if
% they have a severity that means something *should* have been
% printed out. Error specs like this are generated by --debug-modes.
- %expect(unify(MaybeActual, no), this_file,
+ % expect(unify(MaybeActual, no), this_file,
% "do_write_error_spec: MaybeActual isn't no")
;
- PrintedSome = yes,
+ PrintedSome = printed_something,
(
MaybeActual = yes(Actual),
(
@@ -732,8 +749,18 @@
)
).
+:- type maybe_printed_something
+ ---> printed_something
+ ; have_not_printed_anything.
+
+:- type maybe_lower_next_initial
+ ---> lower_next_initial
+ ; do_not_lower_next_initial.
+
:- pred do_write_error_msgs(list(error_msg)::in, globals::in, int::in,
- bool::in, bool::in, bool::out, io::di, io::uo) is det.
+ maybe_treat_as_first::in,
+ maybe_printed_something::in, maybe_printed_something::out,
+ io::di, io::uo) is det.
do_write_error_msgs([], _Globals, _OrigExitStatus, _First, !PrintedSome, !IO).
do_write_error_msgs([Msg | Msgs], Globals, OrigExitStatus, !.First,
@@ -741,17 +768,18 @@
(
Msg = simple_msg(SimpleContext, Components),
MaybeContext = yes(SimpleContext),
- TreatAsFirst = no,
+ TreatAsFirst = do_not_treat_as_first,
ExtraIndentLevel = 0
;
Msg = error_msg(MaybeContext, TreatAsFirst, ExtraIndentLevel,
Components)
),
(
- TreatAsFirst = yes,
- !:First = yes
+ TreatAsFirst = treat_as_first,
+ !:First = treat_as_first
;
- TreatAsFirst = no
+ TreatAsFirst = do_not_treat_as_first
+ % Leave !:First as it is, even if it is treat_as_first.
),
Indent = ExtraIndentLevel * indent_increment,
write_msg_components(Components, MaybeContext, Indent, Globals,
@@ -761,7 +789,9 @@
:- pred write_msg_components(list(error_msg_component)::in,
maybe(prog_context)::in, int::in, globals::in, int::in,
- bool::in, bool::out, bool::in, bool::out, io::di, io::uo) is det.
+ maybe_treat_as_first::in, maybe_treat_as_first::out,
+ maybe_printed_something::in, maybe_printed_something::out,
+ io::di, io::uo) is det.
write_msg_components([], _, _, _, _, !First, !PrintedSome, !IO).
write_msg_components([Component | Components], MaybeContext, Indent, Globals,
@@ -770,8 +800,8 @@
Component = always(ComponentPieces),
do_write_error_pieces(!.First, MaybeContext, Indent,
ComponentPieces, !IO),
- !:First = no,
- !:PrintedSome = yes
+ !:First = do_not_treat_as_first,
+ !:PrintedSome = printed_something
;
Component = option_is_set(Option, RequiredValue, EmbeddedComponents),
globals.lookup_bool_option(Globals, Option, OptionValue),
@@ -788,8 +818,8 @@
VerboseErrors = yes,
do_write_error_pieces(!.First, MaybeContext, Indent,
ComponentPieces, !IO),
- !:First = no,
- !:PrintedSome = yes
+ !:First = do_not_treat_as_first,
+ !:PrintedSome = printed_something
;
VerboseErrors = no,
globals.io_set_extra_error_info(yes, !IO)
@@ -807,13 +837,13 @@
NonVerbosePieces, !IO),
globals.io_set_extra_error_info(yes, !IO)
),
- !:First = no,
- !:PrintedSome = yes
+ !:First = do_not_treat_as_first,
+ !:PrintedSome = printed_something
;
Component = print_anything(Anything),
print_anything(Anything, !IO),
- !:First = no,
- !:PrintedSome = yes
+ !:First = do_not_treat_as_first,
+ !:PrintedSome = printed_something
),
write_msg_components(Components, MaybeContext, Indent, Globals,
OrigExitStatus, !First, !PrintedSome, !IO).
@@ -833,6 +863,10 @@
%-----------------------------------------------------------------------------%
+:- type maybe_first_in_msg
+ ---> first_in_msg
+ ; not_first_in_msg.
+
string_to_words_piece(Str) = words(Str).
list_to_pieces([]) = [].
@@ -866,36 +900,39 @@
choose_number([_], Singular, _Plural) = Singular.
choose_number([_, _ | _], _Singular, Plural) = Plural.
-
is_or_are([]) = "" :-
unexpected(this_file, "error_util.is_or_are").
is_or_are([_]) = "is".
is_or_are([_, _ | _]) = "are".
write_error_pieces_plain(Components, !IO) :-
- do_write_error_pieces(yes, no, 0, Components, !IO).
+ do_write_error_pieces(treat_as_first, no, 0, Components, !IO).
write_error_plain_with_progname(ProgName, Msg, !IO) :-
write_error_pieces_plain([fixed(ProgName ++ ":"), words(Msg)], !IO).
write_error_pieces(Context, Indent, Components, !IO) :-
- do_write_error_pieces(yes, yes(Context), Indent, Components, !IO).
+ do_write_error_pieces(treat_as_first, yes(Context), Indent,
+ Components, !IO).
write_error_pieces_not_first_line(Context, Indent, Components, !IO) :-
- do_write_error_pieces(no, yes(Context), Indent, Components, !IO).
+ do_write_error_pieces(do_not_treat_as_first, yes(Context), Indent,
+ Components, !IO).
-write_error_pieces_maybe_first_line(IsFirst, Context, Indent, Components,
+write_error_pieces_maybe_first_line(TreatAsFirst, Context, Indent, Components,
!IO) :-
- do_write_error_pieces(IsFirst, yes(Context), Indent, Components, !IO).
+ do_write_error_pieces(TreatAsFirst, yes(Context), Indent, Components, !IO).
write_error_pieces_maybe_with_context(MaybeContext, Indent, Components, !IO) :-
- do_write_error_pieces(yes, MaybeContext, Indent, Components, !IO).
+ do_write_error_pieces(treat_as_first, MaybeContext, Indent,
+ Components, !IO).
-:- pred do_write_error_pieces(bool::in, maybe(prog_context)::in, int::in,
- list(format_component)::in, io::di, io::uo) is det.
+:- pred do_write_error_pieces(maybe_treat_as_first::in,
+ maybe(prog_context)::in, int::in, list(format_component)::in,
+ io::di, io::uo) is det.
-do_write_error_pieces(IsFirst, MaybeContext, FixedIndent, Components, !IO) :-
- (
+do_write_error_pieces(TreatAsFirst, MaybeContext, FixedIndent,
+ Components, !IO) :-
% The fixed characters at the start of the line are:
% filename
% :
@@ -921,10 +958,9 @@
ContextLength = 0
),
convert_components_to_paragraphs(Components, Paragraphs),
- FirstIndent = (IsFirst = yes -> 0 ; 1),
+ FirstIndent = (TreatAsFirst = treat_as_first -> 0 ; 1),
Remain = 79 - (ContextLength + FixedIndent),
- group_words(IsFirst, FirstIndent, Paragraphs, Remain, Lines)
- ),
+ group_words(TreatAsFirst, FirstIndent, Paragraphs, Remain, Lines),
write_lines(Lines, MaybeContext, FixedIndent, !IO).
:- func indent_increment = int.
@@ -966,9 +1002,15 @@
io.write_string(Word, !IO),
write_line_rest(Words, !IO).
-error_pieces_to_string([]) = "".
-error_pieces_to_string([Component | Components]) = Str :-
- TailStr = error_pieces_to_string(Components),
+error_pieces_to_string(Components) =
+ error_pieces_to_string_2(first_in_msg, Components).
+
+:- func error_pieces_to_string_2(maybe_first_in_msg, list(format_component))
+ = string.
+
+error_pieces_to_string_2(_, []) = "".
+error_pieces_to_string_2(FirstInMsg, [Component | Components]) = Str :-
+ TailStr = error_pieces_to_string_2(not_first_in_msg, Components),
(
Component = fixed(Word),
Str = join_string_and_tail(Word, Components, TailStr)
@@ -982,11 +1024,20 @@
Component = nth_fixed(Int),
Str = join_string_and_tail(nth_fixed_str(Int), Components, TailStr)
;
- Component = prefix(Word),
- Str = Word ++ TailStr
+ Component = lower_case_next_if_not_first,
+ (
+ FirstInMsg = first_in_msg,
+ Str = TailStr
;
- Component = suffix(Word),
- Str = join_string_and_tail(Word, Components, TailStr)
+ FirstInMsg = not_first_in_msg,
+ Str = lower_initial(TailStr)
+ )
+ ;
+ Component = prefix(Prefix),
+ Str = Prefix ++ TailStr
+ ;
+ Component = suffix(Suffix),
+ Str = join_string_and_tail(Suffix, Components, TailStr)
;
Component = words(Words),
Str = join_string_and_tail(Words, Components, TailStr)
@@ -1068,21 +1119,25 @@
list(paragraph)::out) is det.
convert_components_to_paragraphs(Components, Paras) :-
- convert_components_to_paragraphs_acc(Components, [], [], Paras).
+ convert_components_to_paragraphs_acc(first_in_msg, Components,
+ [], cord.empty, ParasCord),
+ Paras = cord.list(ParasCord).
:- type word
---> plain_word(string)
; prefix_word(string)
- ; suffix_word(string).
+ ; suffix_word(string)
+ ; lower_next_word.
-:- pred convert_components_to_paragraphs_acc(list(format_component)::in,
- list(word)::in, list(paragraph)::in, list(paragraph)::out) is det.
+:- pred convert_components_to_paragraphs_acc(maybe_first_in_msg::in,
+ list(format_component)::in, list(word)::in,
+ cord(paragraph)::in, cord(paragraph)::out) is det.
-convert_components_to_paragraphs_acc([], RevWords0, !Paras) :-
+convert_components_to_paragraphs_acc(_, [], RevWords0, !Paras) :-
Strings = rev_words_to_strings(RevWords0),
- list.reverse([paragraph(Strings, 0, 0) | !.Paras], !:Paras).
-convert_components_to_paragraphs_acc([Component | Components], RevWords0,
- !Paras) :-
+ !:Paras = snoc(!.Paras, paragraph(Strings, 0, 0)).
+convert_components_to_paragraphs_acc(FirstInMsg, [Component | Components],
+ RevWords0, !Paras) :-
(
Component = fixed(Word),
RevWords1 = [plain_word(Word) | RevWords0]
@@ -1096,6 +1151,15 @@
Component = nth_fixed(Int),
RevWords1 = [plain_word(nth_fixed_str(Int)) | RevWords0]
;
+ Component = lower_case_next_if_not_first,
+ (
+ FirstInMsg = first_in_msg,
+ RevWords1 = RevWords0
+ ;
+ FirstInMsg = not_first_in_msg,
+ RevWords1 = [lower_next_word | RevWords0]
+ )
+ ;
Component = prefix(Word),
RevWords1 = [prefix_word(Word) | RevWords0]
;
@@ -1116,8 +1180,8 @@
( type_to_ctor_and_args(Type, TypeCtor, _) ->
TypeCtor = type_ctor(TypeCtorName, TypeCtorArity),
SymName = TypeCtorName / TypeCtorArity,
- RevWords1 = [plain_word(sym_name_and_arity_to_word(SymName))
- | RevWords0]
+ NewWord = plain_word(sym_name_and_arity_to_word(SymName)),
+ RevWords1 = [NewWord | RevWords0]
;
error("convert_components_to_paragraphs_acc: type is variable")
)
@@ -1132,24 +1196,26 @@
;
Component = nl,
Strings = rev_words_to_strings(RevWords0),
- list.cons(paragraph(Strings, 0, 0), !Paras),
+ !:Paras = snoc(!.Paras, paragraph(Strings, 0, 0)),
RevWords1 = []
;
Component = nl_indent_delta(IndentDelta),
Strings = rev_words_to_strings(RevWords0),
- list.cons(paragraph(Strings, 0, IndentDelta), !Paras),
+ !:Paras = snoc(!.Paras, paragraph(Strings, 0, IndentDelta)),
RevWords1 = []
;
Component = blank_line,
Strings = rev_words_to_strings(RevWords0),
- list.cons(paragraph(Strings, 1, 0), !Paras),
+ !:Paras = snoc(!.Paras, paragraph(Strings, 1, 0)),
RevWords1 = []
),
- convert_components_to_paragraphs_acc(Components, RevWords1, !Paras).
+ convert_components_to_paragraphs_acc(not_first_in_msg, Components,
+ RevWords1, !Paras).
:- type plain_or_prefix
---> plain(string)
- ; prefix(string).
+ ; prefix(string)
+ ; lower_next.
:- func rev_words_to_strings(list(word)) = list(string).
@@ -1165,6 +1231,9 @@
Word = plain_word(String),
PorPs = [plain(String) | rev_words_to_rev_plain_or_prefix(Words)]
;
+ Word = lower_next_word,
+ PorPs = [lower_next | rev_words_to_rev_plain_or_prefix(Words)]
+ ;
Word = prefix_word(Prefix),
PorPs = [prefix(Prefix) | rev_words_to_rev_plain_or_prefix(Words)]
;
@@ -1177,6 +1246,14 @@
PorPs = [plain(String ++ Suffix)
| rev_words_to_rev_plain_or_prefix(Tail)]
;
+ Words = [lower_next_word | Tail],
+ % Convert the lower_next_word/suffix combination into just the
+ % suffix after lowercasing the suffix (which will probably have
+ % no effect, since the initial character of a suffix is usually
+ % not a letter).
+ NewWords = [suffix_word(lower_initial(Suffix)) | Tail],
+ PorPs = rev_words_to_rev_plain_or_prefix(NewWords)
+ ;
Words = [prefix_word(Prefix) | Tail],
% Convert the prefix/suffix combination into a plain word.
% We could convert it into a prefix, but since prefix/suffix
@@ -1208,6 +1285,28 @@
TailStrings = [],
Strings = [Prefix | TailStrings]
)
+ ;
+ Head = lower_next,
+ (
+ TailStrings = [],
+ Strings = TailStrings
+ ;
+ TailStrings = [FirstTailString | LaterTailStrings],
+ Strings = [lower_initial(FirstTailString) | LaterTailStrings]
+ )
+ ).
+
+:- func lower_initial(string) = string.
+
+lower_initial(Str0) = Str :-
+ (
+ string.first_char(Str0, First, Rest),
+ char.is_upper(First)
+ ->
+ char.to_lower(First, LoweredFirst),
+ string.first_char(Str, LoweredFirst, Rest)
+ ;
+ Str = Str0
).
:- func sym_name_to_word(sym_name) = string.
@@ -1279,10 +1378,10 @@
% The given list of paragraphs must be nonempty, since we always return
% at least one line.
%
-:- pred group_words(bool::in, int::in, list(paragraph)::in, int::in,
- list(error_line)::out) is det.
+:- pred group_words(maybe_treat_as_first::in, int::in, list(paragraph)::in,
+ int::in, list(error_line)::out) is det.
-group_words(IsFirst, CurIndent, Paras, Max, Lines) :-
+group_words(TreatAsFirst, CurIndent, Paras, Max, Lines) :-
(
Paras = [],
Lines = []
@@ -1290,10 +1389,10 @@
Paras = [FirstPara | LaterParas],
FirstPara = paragraph(FirstParaWords, NumBlankLines, FirstIndentDelta),
(
- IsFirst = yes,
+ TreatAsFirst = treat_as_first,
RestIndent = CurIndent + 1
;
- IsFirst = no,
+ TreatAsFirst = do_not_treat_as_first,
RestIndent = CurIndent
),
NextIndent = RestIndent + FirstIndentDelta,
@@ -1302,7 +1401,7 @@
list.duplicate(NumBlankLines, BlankLine, BlankLines),
(
FirstParaWords = [],
- group_words(IsFirst, NextIndent, LaterParas, Max, RestLines),
+ group_words(TreatAsFirst, NextIndent, LaterParas, Max, RestLines),
Lines = BlankLines ++ RestLines
;
FirstParaWords = [FirstWord | LaterWords],
@@ -1314,7 +1413,8 @@
ParaRestLines),
ParaLines = [CurLine | ParaRestLines],
- group_words(no, NextIndent, LaterParas, Max, RestLines),
+ group_words(do_not_treat_as_first, NextIndent, LaterParas,
+ Max, RestLines),
Lines = ParaLines ++ BlankLines ++ RestLines
)
).
Index: compiler/field_access.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/field_access.m,v
retrieving revision 1.12
diff -u -b -r1.12 field_access.m
--- compiler/field_access.m 10 Sep 2006 23:38:59 -0000 1.12
+++ compiler/field_access.m 15 Jul 2008 03:26:02 -0000
@@ -91,8 +91,11 @@
svar_info::in, svar_info::out,
list(error_spec)::in, list(error_spec)::out) is det.
-:- pred parse_field_list(prog_term::in,
- maybe1(field_list, prog_var_type)::out) is det.
+:- pred maybe_parse_field_list(prog_term::in, prog_varset::in,
+ field_list::out) is semidet.
+
+:- pred parse_field_list(prog_term::in, prog_varset::in,
+ list(format_component)::in, maybe1(field_list)::out) is det.
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -103,6 +106,7 @@
:- import_module hlds.hlds_pred.
:- import_module hlds.make_hlds.superhomogeneous.
:- import_module libs.compiler_util.
+:- import_module parse_tree.mercury_to_mercury.
:- import_module parse_tree.prog_io.
:- import_module bool.
@@ -284,38 +288,58 @@
make_atomic_unification(RetArg, rhs_functor(Functor, no, Args),
Context, MainContext, SubContext, Purity, Goal, !QualInfo).
-parse_field_list(Term, MaybeFieldNames) :-
+maybe_parse_field_list(Term, VarSet, FieldNames) :-
+ % The value of ContextPieces does not matter, since we succeed
+ % only if it is not used.
+ %
+ % We could construct a dummy VarSet as well, if needed.
+ ContextPieces = [],
+ parse_field_list(Term, VarSet, ContextPieces, MaybeFieldNames),
+ MaybeFieldNames = ok1(FieldNames).
+
+parse_field_list(Term, VarSet, ContextPieces, MaybeFieldNames) :-
(
Term = term.functor(term.atom("^"),
[FieldNameTerm, OtherFieldNamesTerm], _)
->
(
- parse_qualified_term(FieldNameTerm, FieldNameTerm,
- "field name", Result),
- Result = ok2(FieldName, Args)
+ sym_name_and_args(FieldNameTerm, FieldName, Args)
->
- parse_field_list(OtherFieldNamesTerm, MaybeFieldNames1),
+ parse_field_list(OtherFieldNamesTerm, VarSet, ContextPieces,
+ MaybeFieldNamesTail),
(
- MaybeFieldNames1 = error1(_),
- MaybeFieldNames = MaybeFieldNames1
+ MaybeFieldNamesTail = error1(_),
+ MaybeFieldNames = MaybeFieldNamesTail
;
- MaybeFieldNames1 = ok1(FieldNames1),
- MaybeFieldNames = ok1([FieldName - Args | FieldNames1])
+ MaybeFieldNamesTail = ok1(FieldNamesTail),
+ MaybeFieldNames = ok1([FieldName - Args | FieldNamesTail])
)
;
- MaybeFieldNames = error1(["expected field name" - FieldNameTerm])
+ Spec = make_field_list_error(VarSet,
+ get_term_context(FieldNameTerm), Term, ContextPieces),
+ MaybeFieldNames = error1([Spec])
)
;
- (
- parse_qualified_term(Term, Term, "field name", Result),
- Result = ok2(FieldName, Args)
- ->
+ ( sym_name_and_args(Term, FieldName, Args) ->
MaybeFieldNames = ok1([FieldName - Args])
;
- MaybeFieldNames = error1(["expected field name" - Term])
+ Spec = make_field_list_error(VarSet, get_term_context(Term), Term,
+ ContextPieces),
+ MaybeFieldNames = error1([Spec])
)
).
+:- func make_field_list_error(prog_varset, term.context, prog_term,
+ list(format_component)) = error_spec.
+
+make_field_list_error(VarSet, Context, Term, ContextPieces) = Spec :-
+ TermStr = mercury_term_to_string(VarSet, no, Term),
+ Pieces = ContextPieces ++ [lower_case_next_if_not_first,
+ words("Error: expected field name at term"),
+ quote(TermStr), suffix("."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(Context, [always(Pieces)])]).
+
%-----------------------------------------------------------------------------%
:- func this_file = string.
Index: compiler/intermod.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/intermod.m,v
retrieving revision 1.231
diff -u -b -r1.231 intermod.m
--- compiler/intermod.m 17 Apr 2008 04:21:50 -0000 1.231
+++ compiler/intermod.m 13 Jul 2008 01:52:32 -0000
@@ -39,12 +39,13 @@
:- interface.
:- import_module hlds.hlds_module.
+:- import_module parse_tree.error_util.
:- import_module parse_tree.modules.
-:- import_module parse_tree.prog_item.
:- import_module parse_tree.prog_io.
:- import_module bool.
:- import_module io.
+:- import_module list.
%-----------------------------------------------------------------------------%
@@ -73,7 +74,7 @@
---> opt_file
; trans_opt_file.
- % update_error_status(OptFileType, FileName, Error, Messages, !Status):
+ % update_error_status(OptFileType, FileName, Error, Specs, !Status):
%
% Work out whether any fatal errors have occurred while reading
% `.opt' files, updating Status0 if there were fatal errors.
@@ -86,7 +87,7 @@
% This is also used by trans_opt.m for reading `.trans_opt' files.
%
:- pred update_error_status(opt_file_type::in, string::in, module_error::in,
- message_list::in, bool::in, bool::out, io::di, io::uo) is det.
+ list(error_spec)::in, bool::in, bool::out, io::di, io::uo) is det.
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -113,6 +114,7 @@
:- import_module parse_tree.modules.
:- import_module parse_tree.prog_data.
:- import_module parse_tree.prog_io.
+:- import_module parse_tree.prog_item.
:- import_module parse_tree.prog_out.
:- import_module parse_tree.prog_type.
:- import_module parse_tree.prog_util.
@@ -121,7 +123,6 @@
:- import_module assoc_list.
:- import_module getopt_io.
:- import_module int.
-:- import_module list.
:- import_module map.
:- import_module maybe.
:- import_module multi_map.
@@ -2379,10 +2380,9 @@
maybe_flush_output(VeryVerbose, !IO),
module_name_to_search_file_name(ModuleToRead, ".opt", FileName, !IO),
- prog_io.read_opt_file(FileName, ModuleToRead,
- ModuleError, Messages, OptItems, !IO),
- update_error_status(opt_file, FileName, ModuleError, Messages, !Error,
+ prog_io.read_opt_file(FileName, ModuleToRead, OptItems, Specs, ModuleError,
!IO),
+ update_error_status(opt_file, FileName, ModuleError, Specs, !Error, !IO),
!:Items = !.Items ++ OptItems,
maybe_write_string(VeryVerbose, "% done.\n", !IO),
@@ -2406,13 +2406,15 @@
read_optimization_interfaces(Transitive, ModuleName,
NewDeps ++ ModulesToRead, ModulesProcessed, !Items, !Error, !IO).
-update_error_status(FileType, FileName, ModuleError, Messages,
+update_error_status(FileType, FileName, ModuleError, Specs,
!Error, !IO) :-
(
ModuleError = no_module_errors
;
ModuleError = some_module_errors,
- prog_out.write_messages(Messages, !IO),
+ globals.io_get_globals(Globals, !IO),
+ % XXX _NumWarnings _NumErrors
+ write_error_specs(Specs, Globals, 0, _NumWarnings, 0, _NumErrors, !IO),
!:Error = yes
;
ModuleError = fatal_module_errors,
Index: compiler/make.module_dep_file.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/make.module_dep_file.m,v
retrieving revision 1.33
diff -u -b -r1.33 make.module_dep_file.m
--- compiler/make.module_dep_file.m 18 Feb 2008 23:57:44 -0000 1.33
+++ compiler/make.module_dep_file.m 10 Jul 2008 13:25:34 -0000
@@ -570,10 +570,9 @@
io.set_exit_status(0, !IO),
io.set_output_stream(ErrorStream, _, !IO),
split_into_submodules(ModuleName, Items, SubModuleList, [], Specs),
- sort_error_specs(Specs, SortedSpecs),
globals.io_get_globals(Globals, !IO),
- write_error_specs(SortedSpecs, Globals, 0, _NumWarnings,
- 0, _NumErrors, !IO),
+ write_error_specs(Specs, Globals, 0, _NumWarnings, 0, _NumErrors,
+ !IO),
io.set_output_stream(OldOutputStream, _, !IO),
assoc_list.keys(SubModuleList, SubModuleNames),
@@ -587,11 +586,9 @@
:= yes(ModuleImports)
), ModuleImportList, !Info),
- %
% If there were no errors, write out the `.int3' file
% while we have the contents of the module. The `int3'
% file doesn't depend on anything else.
- %
(
Error = no_module_errors,
Target = target_file(ModuleName,
Index: compiler/make_hlds_error.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/make_hlds_error.m,v
retrieving revision 1.13
diff -u -b -r1.13 make_hlds_error.m
--- compiler/make_hlds_error.m 1 Dec 2006 15:04:05 -0000 1.13
+++ compiler/make_hlds_error.m 13 Jul 2008 10:19:23 -0000
@@ -88,7 +88,8 @@
Pieces2 = [words("Here is the previous definition of"),
fixed(DefType), sym_name_and_arity(Name / Arity), suffix("."), nl],
Msg1 = simple_msg(Context, [always(Pieces1)]),
- Msg2 = error_msg(yes(OrigContext), yes, 0, [always(Pieces2)]),
+ Msg2 = error_msg(yes(OrigContext), treat_as_first, 0,
+ [always(Pieces2)]),
(
ExtraPieces = [],
ExtraMsgs = []
Index: compiler/make_hlds_passes.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/make_hlds_passes.m,v
retrieving revision 1.78
diff -u -b -r1.78 make_hlds_passes.m
--- compiler/make_hlds_passes.m 27 Mar 2008 12:41:22 -0000 1.78
+++ compiler/make_hlds_passes.m 10 Jul 2008 13:25:57 -0000
@@ -202,10 +202,9 @@
mq_info_get_mode_error_flag(MQInfo, InvalidModes1),
InvalidModes = InvalidModes0 `or` InvalidModes1,
- sort_error_specs(!.Specs, SortedSpecs),
module_info_get_globals(!.ModuleInfo, CurGlobals),
- write_error_specs(SortedSpecs, CurGlobals, 0, _NumWarnings,
- 0, NumErrors, !IO),
+ write_error_specs(!.Specs, CurGlobals, 0, _NumWarnings, 0, NumErrors,
+ !IO),
module_info_incr_num_errors(NumErrors, !ModuleInfo),
ModuleInfo = !.ModuleInfo
Index: compiler/mercury_compile.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mercury_compile.m,v
retrieving revision 1.474
diff -u -b -r1.474 mercury_compile.m
--- compiler/mercury_compile.m 16 Jun 2008 04:52:30 -0000 1.474
+++ compiler/mercury_compile.m 13 Jul 2008 10:26:19 -0000
@@ -1977,7 +1977,8 @@
Pieces = [words("Warning: cannot read trans-opt dependencies"),
words("for module"), sym_name(ModuleName), suffix("."), nl,
words("You need to remake the dependencies."), nl],
- Msg = error_msg(no, no, 0, [always(Pieces)]),
+ Msg = error_msg(no, do_not_treat_as_first, 0,
+ [always(Pieces)]),
Spec = error_spec(severity_warning, phase_read_files, [Msg]),
% XXX _NumErrors
write_error_spec(Spec, Globals, 0, _NumWarnings, 0, _NumErrors,
Index: compiler/mercury_to_mercury.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mercury_to_mercury.m,v
retrieving revision 1.330
diff -u -b -r1.330 mercury_to_mercury.m
--- compiler/mercury_to_mercury.m 3 Apr 2008 05:26:44 -0000 1.330
+++ compiler/mercury_to_mercury.m 15 Jul 2008 12:38:34 -0000
@@ -265,6 +265,15 @@
:- func mercury_term_nq_to_string(varset(T), bool, needs_quotes, term(T))
= string.
+:- pred mercury_output_limited_term(varset(T)::in, bool::in, int::in,
+ term(T)::in, io::di, io::uo) is det.
+:- func mercury_limited_term_to_string(varset(T), bool, int, term(T)) = string.
+
+:- pred mercury_output_limited_term_nq(varset(T)::in, bool::in,
+ needs_quotes::in, int::in, term(T)::in, io::di, io::uo) is det.
+:- func mercury_limited_term_nq_to_string(varset(T), bool, needs_quotes, int,
+ term(T)) = string.
+
:- pred mercury_output_type(tvarset::in, bool::in, mer_type::in,
io::di, io::uo) is det.
:- func mercury_type_to_string(tvarset, bool, mer_type) = string.
@@ -347,6 +356,8 @@
maybe(solver_type_details)::in, maybe(unify_compare)::in, io::di, io::uo)
is det.
+:- func describe_error_term(varset(T), term(T)) = string.
+
%-----------------------------------------------------------------------------%
% This is the typeclass mentioned in the long comment at the top of the module.
@@ -4251,8 +4262,6 @@
%-----------------------------------------------------------------------------%
- % Write a term to standard output.
- %
mercury_output_term(VarSet, AppendVarnums, Term, !IO) :-
mercury_output_term_nq(VarSet, AppendVarnums, not_next_to_graphic_token,
Term, !IO).
@@ -4270,6 +4279,51 @@
mercury_format_term_nq(VarSet, AppendVarnums, NextToGraphicToken, Term,
"", String).
+mercury_output_limited_term(VarSet, AppendVarnums, Limit, Term, !IO) :-
+ mercury_output_limited_term_nq(VarSet, AppendVarnums,
+ not_next_to_graphic_token, Limit, Term, !IO).
+
+mercury_limited_term_to_string(VarSet, AppendVarnums, Limit, Term) =
+ mercury_limited_term_nq_to_string(VarSet, AppendVarnums,
+ not_next_to_graphic_token, Limit, Term).
+
+mercury_output_limited_term_nq(VarSet, AppendVarnums, NextToGraphicToken,
+ Limit, Term, !IO) :-
+ io.write_string(mercury_limited_term_nq_to_string(VarSet, AppendVarnums,
+ NextToGraphicToken, Limit, Term), !IO).
+
+mercury_limited_term_nq_to_string(VarSet, AppendVarnums, NextToGraphicToken,
+ Limit, Term) = String :-
+ mercury_format_term_nq(VarSet, AppendVarnums, NextToGraphicToken, Term,
+ "", FullString),
+ FullLen = string.length(FullString),
+ ( FullLen =< Limit ->
+ String = FullString
+ ;
+ (
+ Term = term.variable(_, _),
+ % We cannot reduce the length of the string.
+ String = FullString
+ ;
+ Term = term.functor(Functor, Args, Context),
+ NoArgTerm = term.functor(Functor, [], Context),
+ mercury_format_term_nq(VarSet, AppendVarnums, NextToGraphicToken,
+ NoArgTerm, "", FunctorString),
+ (
+ Functor = term.atom(_),
+ ArityStr = int_to_string(list.length(Args)),
+ String = FunctorString ++ "/" ++ ArityStr
+ ;
+ ( Functor = term.integer(_)
+ ; Functor = term.float(_)
+ ; Functor = term.string(_)
+ ; Functor = term.implementation_defined(_)
+ ),
+ String = FunctorString
+ )
+ )
+ ).
+
:- pred mercury_format_term(varset(T)::in, bool::in, term(T)::in,
U::di, U::uo) is det <= output(U).
@@ -5193,6 +5247,22 @@
%---------------------------------------------------------------------------%
+describe_error_term(VarSet, Term) =
+ % We should consider using the algorithms of term_io.write_term instead of
+ % the ones now in mercury_limited_term_to_string to print terms; it adds
+ % fewer redundant parentheses.
+ mercury_limited_term_to_string(VarSet, no,
+ max_term_string_size_in_syntax_error, Term).
+
+ % The maximum size of the string representation of a term to print
+ % at syntax errors.
+ %
+:- func max_term_string_size_in_syntax_error = int.
+
+max_term_string_size_in_syntax_error = 80.
+
+%---------------------------------------------------------------------------%
+
:- func this_file = string.
this_file = "mercury_to_mercury.m".
Index: compiler/mode_errors.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mode_errors.m,v
retrieving revision 1.126
diff -u -b -r1.126 mode_errors.m
--- compiler/mode_errors.m 28 Apr 2008 00:50:54 -0000 1.126
+++ compiler/mode_errors.m 13 Jul 2008 10:20:54 -0000
@@ -494,7 +494,7 @@
Msg1 = simple_msg(Context,
[option_is_set(debug_modes, yes, [always(Pieces1)])]),
mode_info_get_module_info(!.ModeInfo, ModuleInfo),
- Msg2 = error_msg(no, no, 0,
+ Msg2 = error_msg(no, do_not_treat_as_first, 0,
[option_is_set(very_verbose, yes,
[always([nl]),
'new print_anything'(
@@ -711,12 +711,13 @@
LaterMsgs0 = [LaterHead0 | LaterTail],
(
LaterHead0 = simple_msg(LaterContext, Components),
- LaterHead = error_msg(yes(LaterContext), yes, 0, Components)
+ LaterHead = error_msg(yes(LaterContext), treat_as_first,
+ 0, Components)
;
LaterHead0 = error_msg(MaybeLaterContext, _, Indent,
Components),
- LaterHead = error_msg(MaybeLaterContext, yes, Indent,
- Components)
+ LaterHead = error_msg(MaybeLaterContext, treat_as_first,
+ Indent, Components)
),
LaterMsgs = [LaterHead | LaterTail]
),
Index: compiler/modes.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/modes.m,v
retrieving revision 1.367
diff -u -b -r1.367 modes.m
--- compiler/modes.m 27 Feb 2008 07:23:10 -0000 1.367
+++ compiler/modes.m 13 Jul 2008 10:19:33 -0000
@@ -533,7 +533,7 @@
words("to increase the limit."),
words("(The current limit is"), int_fixed(MaxIterations),
words("iterations.)"), nl],
- Msg = error_msg(no, no, 0, [always(Pieces)]),
+ Msg = error_msg(no, do_not_treat_as_first, 0, [always(Pieces)]),
Spec = error_spec(severity_error, phase_mode_check(report_in_any_mode),
[Msg]),
% XXX _NumErrors
Index: compiler/modules.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/modules.m,v
retrieving revision 1.447
diff -u -b -r1.447 modules.m
--- compiler/modules.m 25 Jun 2008 04:44:27 -0000 1.447
+++ compiler/modules.m 13 Jul 2008 01:54:17 -0000
@@ -1317,9 +1317,8 @@
yes(FileName), "", _, _, _, [], Specs),
(
Specs = [_ | _],
- sort_error_specs(Specs, SortedSpecs),
- write_error_specs(SortedSpecs, Globals, 0, _NumWarnings,
- 0, _NumErrors, !IO),
+ write_error_specs(Specs, Globals, 0, _NumWarnings, 0, _NumErrors,
+ !IO),
io.write_strings(["`", FileName, "' not written.\n"], !IO)
;
Specs = [],
@@ -2801,9 +2800,8 @@
IntImportedModules ++ IntUsedModules ++
ImpImportedModules ++ ImpUsedModules, Items, !Specs),
- sort_error_specs(!.Specs, SortedSpecs),
- write_error_specs(SortedSpecs, Globals, 0, _NumWarnings,
- 0, _NumErrors, !IO),
+ write_error_specs(!.Specs, Globals, 0, _NumWarnings, 0, _NumErrors,
+ !IO),
module_imports_get_error(!.Module, Error)
).
@@ -2900,8 +2898,7 @@
IntImportDeps ++ IntUseDeps ++ ImpImportDeps ++ ImpUseDeps,
Items, !Specs),
- sort_error_specs(!.Specs, SortedSpecs),
- write_error_specs(SortedSpecs, Globals, 0, _NumWarnings, 0, _NumErrors,
+ write_error_specs(!.Specs, Globals, 0, _NumWarnings, 0, _NumErrors,
!IO),
module_imports_get_error(!.Module, Error)
@@ -4326,10 +4323,8 @@
ModuleName, _, !IO),
string.append(FileName, ".m", SourceFileName),
split_into_submodules(ModuleName, Items, SubModuleList, [], Specs),
- sort_error_specs(Specs, SortedSpecs),
globals.io_get_globals(Globals, !IO),
- write_error_specs(SortedSpecs, Globals, 0, _NumWarnings, 0, _NumErrors,
- !IO),
+ write_error_specs(Specs, Globals, 0, _NumWarnings, 0, _NumErrors, !IO),
assoc_list.keys(SubModuleList, SubModuleNames),
list.map(init_dependencies(SourceFileName, ModuleName, SubModuleNames,
Error, Globals), SubModuleList, ModuleImportsList),
@@ -4338,8 +4333,7 @@
:- type generate_dependencies_mode
---> output_d_file_only
- ; output_all_dependencies
- .
+ ; output_all_dependencies.
:- pred generate_dependencies(generate_dependencies_mode::in, bool::in,
module_name::in, deps_map::in,
@@ -6585,9 +6579,7 @@
FileName = FileName0,
Items = Items0,
split_into_submodules(ModuleName, Items, SubModuleList, [], Specs),
- sort_error_specs(Specs, SortedSpecs),
- write_error_specs(SortedSpecs, Globals, 0, _NumWarnings, 0, _NumErrors,
- !IO)
+ write_error_specs(Specs, Globals, 0, _NumWarnings, 0, _NumErrors, !IO)
),
assoc_list.keys(SubModuleList, SubModuleNames),
list.map(init_dependencies(FileName, ModuleName, SubModuleNames,
@@ -6758,14 +6750,14 @@
),
(
MaybeOldTimestamp = yes(OldTimestamp),
- prog_io.read_module_if_changed(OpenFile, ModuleName,
- OldTimestamp, Error, MaybeFileName, ActualModuleName,
- Messages, Items, MaybeTimestamp0, !IO)
+ prog_io.read_module_if_changed(OpenFile, ModuleName, OldTimestamp,
+ MaybeFileName, ActualModuleName, Items, Specs, Error,
+ MaybeTimestamp0, !IO)
;
MaybeOldTimestamp = no,
- prog_io.read_module(OpenFile, ModuleName,
- ReturnTimestamp, Error, MaybeFileName,
- ActualModuleName, Messages, Items, MaybeTimestamp0, !IO)
+ prog_io.read_module(OpenFile, ModuleName, ReturnTimestamp,
+ MaybeFileName, ActualModuleName, Items, Specs, Error,
+ MaybeTimestamp0, !IO)
),
(
@@ -6802,7 +6794,9 @@
Error = no_module_errors,
maybe_write_string(VeryVerbose, "successful parse.\n", !IO)
),
- prog_out.write_messages(Messages, !IO)
+ globals.io_get_globals(Globals, !IO),
+ % XXX _NumWarnings _NumErrors
+ write_error_specs(Specs, Globals, 0, _NumWarnings, 0, _NumErrors, !IO)
).
read_mod_from_file(FileName, Extension, Descr, Search, ReturnTimestamp,
@@ -6830,8 +6824,8 @@
SearchDirs = [dir.this_directory]
),
OpenFile = search_for_file(SearchDirs, FullFileName),
- prog_io.read_module(OpenFile, DefaultModuleName, ReturnTimestamp, Error,
- _, ModuleName, Messages, Items, MaybeTimestamp0, !IO),
+ prog_io.read_module(OpenFile, DefaultModuleName, ReturnTimestamp,
+ _, ModuleName, Items, Specs, Error, MaybeTimestamp0, !IO),
check_timestamp(FullFileName, MaybeTimestamp0, MaybeTimestamp, !IO),
(
Error = fatal_module_errors,
@@ -6845,7 +6839,9 @@
Error = no_module_errors,
maybe_write_string(VeryVerbose, "successful parse.\n", !IO)
),
- prog_out.write_messages(Messages, !IO).
+ globals.io_get_globals(Globals, !IO),
+ % XXX _NumWarnings _NumErrors
+ write_error_specs(Specs, Globals, 0, _NumWarnings, 0, _NumErrors, !IO).
:- pred check_timestamp(file_name::in, maybe(io.res(timestamp))::in,
maybe(timestamp)::out, io::di, io::uo) is det.
Index: compiler/options_file.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/options_file.m,v
retrieving revision 1.48
diff -u -b -r1.48 options_file.m
--- compiler/options_file.m 23 Nov 2007 07:35:18 -0000 1.48
+++ compiler/options_file.m 13 Jul 2008 10:22:21 -0000
@@ -276,7 +276,7 @@
ErrorFile = FileToFind
),
ErrorSpec = error_spec(severity_error, phase_read_files,
- [error_msg(no, no, 0,
+ [error_msg(no, do_not_treat_as_first, 0,
[always([words("Error reading options file"),
quote(ErrorFile), suffix(".")])
])
@@ -1101,7 +1101,8 @@
list.map(func(Lib) = add_quotes(Lib), BadLibs))]
++ [suffix(".")],
ErrorSpec = error_spec(severity_error, phase_read_files,
- [error_msg(no, no, 0, [always(Pieces)])]),
+ [error_msg(no, do_not_treat_as_first, 0,
+ [always(Pieces)])]),
globals.io_get_globals(Globals, !IO),
write_error_spec(ErrorSpec, Globals, 0, _, 0, _, !IO),
Result = var_result_error(ErrorSpec)
@@ -1167,24 +1168,22 @@
Result = var_result_set(EnvWords)
;
SplitResult = error(Msg),
-
ErrorSpec = error_spec(severity_error, phase_read_files,
- [error_msg(no, no, 0,
+ [error_msg(no, do_not_treat_as_first, 0,
[always([words("Error: in environment variable"),
- quote(VarName), suffix(":"), words(Msg)
- ])]
+ quote(VarName), suffix(":"), words(Msg), nl])]
)]),
Result = var_result_error(ErrorSpec)
-)
-;
-MaybeEnvValue = no,
-( map.search(Vars, VarName, MapValue) ->
+ )
+ ;
+ MaybeEnvValue = no,
+ ( map.search(Vars, VarName, MapValue) ->
MapValue = options_variable_value(_, Words, _),
Result = var_result_set(Words)
-;
+ ;
Result = var_result_unset
-)
-).
+ )
+ ).
:- pred lookup_variable_chars(options_variables::in, string::in,
list(char)::out, list(string)::in, list(string)::out,
Index: compiler/prog_ctgc.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_ctgc.m,v
retrieving revision 1.20
diff -u -b -r1.20 prog_ctgc.m
--- compiler/prog_ctgc.m 30 Jun 2008 07:44:27 -0000 1.20
+++ compiler/prog_ctgc.m 14 Jul 2008 14:20:05 -0000
@@ -229,20 +229,11 @@
Cons = "typesel",
Args = [TypeSelectorTerm]
->
- parse_type(term.coerce(TypeSelectorTerm), MaybeTypeSelector),
- (
- MaybeTypeSelector = ok1(TypeSelector),
+ ( maybe_parse_type(term.coerce(TypeSelectorTerm), TypeSelector) ->
UnitSelector = typesel(TypeSelector)
;
- MaybeTypeSelector = error1(Errors),
- (
- Errors = [],
- unexpected(this_file, "parse_unit_selector: empty Errors")
- ;
- Errors = [Msg - _ | _],
- unexpected(this_file, "parse_unit_selector: " ++
- "error parsing type selector (" ++ Msg ++ ").")
- )
+ unexpected(this_file,
+ "parse_unit_selector: error in parsing type selector")
)
;
unexpected(this_file, "parse_unit_selector: " ++
@@ -445,7 +436,7 @@
[TypesTerm, UserSharingTerm], _),
(
TypesTerm = term.functor(term.atom("yes"), ListTypeTerms, _),
- parse_types(ListTypeTerms, ok1(Types)),
+ maybe_parse_types(ListTypeTerms, Types),
term.vars_list(ListTypeTerms, TypeVars),
varset.select(Varset, set.list_to_set(TypeVars), Varset0),
MaybeUserTypes = yes(user_type_info(Types,
@@ -504,7 +495,7 @@
VarTerm = term.variable(GenericVar, _),
term.coerce_var(GenericVar, ProgVar),
get_list_term_arguments(TypesTerm, TypeTermsList),
- parse_types(TypeTermsList, ok1(Types)),
+ maybe_parse_types(TypeTermsList, Types),
list.map(mer_type_to_typesel, Types, Selector),
Datastruct = selected_cel(ProgVar, Selector).
Index: compiler/prog_data.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_data.m,v
retrieving revision 1.213
diff -u -b -r1.213 prog_data.m
--- compiler/prog_data.m 30 Jun 2008 07:44:27 -0000 1.213
+++ compiler/prog_data.m 15 Jul 2008 08:35:57 -0000
@@ -674,18 +674,16 @@
%
:- type prog_constraint
---> constraint(
- class_name,
- list(mer_type)
+ constraint_class :: class_name,
+ constraint_arg_types :: list(mer_type)
).
:- type prog_constraints
---> constraints(
univ_constraints :: list(prog_constraint),
- % universally quantified
- % constraints
+ % Universally quantified constraints.
exist_constraints :: list(prog_constraint)
- % existentially quantified
- % constraints
+ % Existentially quantified constraints.
).
% A functional dependency on the variables in the head of a class
@@ -734,11 +732,21 @@
:- type instance_methods == list(instance_method).
+:- func prog_constraint_get_class(prog_constraint) = class_name.
+:- func prog_constraint_get_arg_types(prog_constraint) = list(mer_type).
+
+:- implementation.
+
+prog_constraint_get_class(Constraint) = Constraint ^ constraint_class.
+prog_constraint_get_arg_types(Constraint) = Constraint ^ constraint_arg_types.
+
%-----------------------------------------------------------------------------%
%
% Some more stuff for the foreign language interface
%
+:- interface.
+
% An abstract type for representing a set of
% `pragma_foreign_proc_attribute's.
%
Index: compiler/prog_event.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_event.m,v
retrieving revision 1.14
diff -u -b -r1.14 prog_event.m
--- compiler/prog_event.m 30 Oct 2007 00:46:20 -0000 1.14
+++ compiler/prog_event.m 13 Jul 2008 10:25:09 -0000
@@ -113,7 +113,8 @@
Pieces = [words("eof in term specification file"), nl],
ErrorSpec = error_spec(severity_error,
phase_term_to_parse_tree,
- [error_msg(no, no, 0, [always(Pieces)])]),
+ [error_msg(no, do_not_treat_as_first, 0,
+ [always(Pieces)])]),
ErrorSpecs = [ErrorSpec]
;
TermReadRes = error(TermReadMsg, LineNumber),
@@ -133,7 +134,7 @@
EventSpecMap = map.init,
Pieces = [words(io.error_message(TermOpenError)), nl],
ErrorSpec = error_spec(severity_error, phase_term_to_parse_tree,
- [error_msg(no, no, 0, [always(Pieces)])]),
+ [error_msg(no, do_not_treat_as_first, 0, [always(Pieces)])]),
ErrorSpecs = [ErrorSpec]
)
;
@@ -141,7 +142,7 @@
EventSpecMap = map.init,
Pieces = [words(Problem), nl],
ErrorSpec = error_spec(severity_error, phase_term_to_parse_tree,
- [error_msg(no, no, 0, [always(Pieces)])]),
+ [error_msg(no, do_not_treat_as_first, 0, [always(Pieces)])]),
ErrorSpecs = [ErrorSpec]
),
io.remove_file(TermFileName, _RemoveRes, !IO).
Index: compiler/prog_io.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_io.m,v
retrieving revision 1.290
diff -u -b -r1.290 prog_io.m
--- compiler/prog_io.m 15 Feb 2008 08:32:00 -0000 1.290
+++ compiler/prog_io.m 15 Jul 2008 12:59:17 -0000
@@ -1,4 +1,3 @@
-%-----------------------------------------------------------------------------e
% vim: ft=mercury ts=4 sw=4 et
%-----------------------------------------------------------------------------e
% Copyright (C) 1993-2008 The University of Melbourne.
@@ -59,6 +58,7 @@
:- import_module libs.timestamp.
:- import_module mdbcomp.prim_data.
+:- import_module parse_tree.error_util.
:- import_module parse_tree.prog_data.
:- import_module parse_tree.prog_item.
:- import_module parse_tree.prog_io_util.
@@ -89,7 +89,7 @@
; fatal_module_errors. % couldn't open the file
% read_module(OpenFile, FileName, DefaultModuleName, ReturnTimestamp,
- % Error, MaybeFileInfo, ActualModuleName, Messages, Program,
+ % MaybeFileInfo, ActualModuleName, Program, Specs, Error,
% MaybeModuleTimestamp, !IO):
%
% Reads and parses the file opened by OpenFile using the default module
@@ -101,25 +101,25 @@
% directory name) returned by OpenFile. ActualModuleName is the module name
% specified in the `:- module' declaration, if any, or the
% DefaultModuleName if there is no `:- module' declaration.
- % Messages is a list of warning/error messages. Program is the parse tree.
+ % Specs is a list of warning/error messages. Program is the parse tree.
%
:- pred read_module(open_file(FileInfo)::in(open_file),
- module_name::in, bool::in, module_error::out, maybe(FileInfo)::out,
- module_name::out, message_list::out, list(item)::out,
+ module_name::in, bool::in, maybe(FileInfo)::out, module_name::out,
+ list(item)::out, list(error_spec)::out, module_error::out,
maybe(io.res(timestamp))::out, io::di, io::uo) is det.
:- pred read_module_if_changed(open_file(FileInfo)::in(open_file),
- module_name::in, timestamp::in, module_error::out,
- maybe(FileInfo)::out, module_name::out, message_list::out,
- list(item)::out, maybe(io.res(timestamp))::out, io::di, io::uo) is det.
+ module_name::in, timestamp::in, maybe(FileInfo)::out, module_name::out,
+ list(item)::out, list(error_spec)::out, module_error::out,
+ maybe(io.res(timestamp))::out, io::di, io::uo) is det.
% Same as read_module, but use intermod_directories instead of
% search_directories when searching for the file.
% Also report an error if the actual module name doesn't match
% the expected module name.
%
-:- pred read_opt_file(file_name::in, module_name::in, module_error::out,
- message_list::out, list(item)::out, io::di, io::uo) is det.
+:- pred read_opt_file(file_name::in, module_name::in, list(item)::out,
+ list(error_spec)::out, module_error::out, io::di, io::uo) is det.
% check_module_has_expected_name(FileName, ExpectedName, ActualName):
%
@@ -181,11 +181,11 @@
:- pred parse_decl(module_name::in, varset::in, term::in, maybe1(item)::out)
is det.
- % parse_type_defn_head(ModuleName, Head, HeadResult):
+ % parse_type_defn_head(ModuleName, VarSet, Head, HeadResult):
%
% Check the head of a type definition for errors.
%
-:- pred parse_type_defn_head(module_name::in, term::in,
+:- pred parse_type_defn_head(module_name::in, varset::in, term::in,
maybe2(sym_name, list(type_param))::out) is det.
% parse_type_decl_where_part_if_present(TypeSymName, Arity,
@@ -196,7 +196,7 @@
% in Result. If not, returns Term = Term0 and Result = no.
%
:- pred parse_type_decl_where_part_if_present(is_solver_type::in,
- module_name::in, term::in, term::out,
+ module_name::in, varset::in, term::in, term::out,
maybe2(maybe(solver_type_details), maybe(unify_compare))::out) is det.
%-----------------------------------------------------------------------------%
@@ -210,41 +210,52 @@
% where Module is a SymName. For backwards compatibility, we allow `__'
% as an alternative to `.'.
- % Sym_name_and_args takes a term and returns a sym_name and a list of
- % argument terms. It fails if the input is not valid syntax for a
- % QualifiedTerm.
+ % Sym_name_and_args takes a term and returns a sym_name that is its
+ % top function symbol, and a list of its argument terms. It fails
+ % if the input is not valid syntax for a QualifiedTerm.
%
:- pred sym_name_and_args(term(T)::in, sym_name::out, list(term(T))::out)
is semidet.
- % parse_qualified_term/4 takes a term (and also the containing term,
- % and a string describing the context from which it was called
- % [e.g. "clause head"]) and returns a sym_name and a list of argument
- % terms. Returns an error on ill-formed input. See also
- % parse_implicitly_qualified_term/5 (below).
- %
-:- pred parse_qualified_term(term(T)::in, term(T)::in, string::in,
- maybe_functor(T)::out) is det.
-
- % parse_implicitly_qualified_term(DefaultModName, Term,
- % ContainingTerm, Msg, Result):
- %
- % parse_implicitly_qualified_term/5 takes a default module name and a term,
- % and also the containing term, and a string describing the context from
- % which it was called (e.g. "clause head"), and returns a sym_name and
- % a list of argument terms. Returns an error on ill-formed input or
- % a module qualifier that doesn't match the DefaultModName.
- %
- % Note: parse_qualified_term/4 is used for places where a symbol is _used_,
- % in which case no default module name exists, whereas
- % parse_implicitly_qualified_term/5 is used for places where a symbol
- % is _defined_; in that case, there is a default module name (the name
- % of the current module) -- specifying a module qualifier explicitly
- % is redundant, but it is allowed, so long as the module qualifier
- % specified matches the default.
+ % parse_qualified_term(Term, _ContainingTerm, VarSet, ContextPieces,
+ % Result):
+ %
+ % Parse Term into a sym_name that is its top function symbol and a
+ % list of its argument terms, and if successful return them in Result.
+ % (parse_qualified_term thus does the same job as sym_name_and_args
+ % if it succeeds.) However, in case it does not succced,
+ % parse_qualified_term also takes as input Varset (from which the variables
+ % in Term are taken), the term containing Term, and a format_component
+ % list describing the context from which it was called, e.g.
+ % "In clause head:". XXX Currently, _ContainingTerm isn't used;
+ % maybe it should be deleted.
+ %
+ % Note: parse_qualified_term is used for places where a symbol is _used_,
+ % where no default module name exists for the sym_name. For places
+ % where a symbol is _defined_, use parse_implicitly_qualified_term.
+ %
+ % If you care only about the case where Result = ok2(SymName, Args),
+ % use sym_name_and_args.
+ %
+:- pred parse_qualified_term(term(T)::in, term(T)::in, varset::in,
+ list(format_component)::in, maybe_functor(T)::out) is det.
+
+ % parse_implicitly_qualified_term(ModuleName, Term, _ContainingTerm,
+ % VarSet, ContextPieces, Result):
+ %
+ % Parse Term into a sym_name that is its top function symbol and a
+ % list of its argument terms, and if successful return them in Result.
+ % This predicate thus does almost the same job as the predicate
+ % parse_implicitly_qualified_term above, the difference being that
+ % that if the sym_name is qualified, then we check whether it is qualified
+ % with ModuleName, and if it isn't qualified, then we qualify it with
+ % Modulename (unless ModuleName is root_module_name). This is the
+ % right thing to do for clause heads, which is the intended job of
+ % parse_implicitly_qualified_term.
%
:- pred parse_implicitly_qualified_term(module_name::in, term(T)::in,
- term(T)::in, string::in, maybe_functor(T)::out) is det.
+ term(T)::in, varset::in, list(format_component)::in, maybe_functor(T)::out)
+ is det.
%-----------------------------------------------------------------------------%
@@ -277,8 +288,7 @@
:- import_module libs.globals.
:- import_module libs.options.
:- import_module parse_tree.modules.
-:- import_module parse_tree.modules.
-:- import_module parse_tree.error_util.
+:- import_module parse_tree.mercury_to_mercury.
:- import_module parse_tree.prog_io_dcg.
:- import_module parse_tree.prog_io_goal.
:- import_module parse_tree.prog_io_pragma.
@@ -304,20 +314,19 @@
%-----------------------------------------------------------------------------%
-read_module(OpenFile, DefaultModuleName, ReturnTimestamp, Error,
- FileData, ModuleName, Messages, Items, MaybeModuleTimestamp, !IO) :-
- read_module_2(OpenFile, DefaultModuleName, no, ReturnTimestamp, Error,
- FileData, ModuleName, Messages, Items, MaybeModuleTimestamp, !IO).
-
-read_module_if_changed(OpenFile, DefaultModuleName, OldTimestamp, Error,
- FileData, ModuleName, Messages, Items, MaybeModuleTimestamp, !IO) :-
- read_module_2(OpenFile, DefaultModuleName, yes(OldTimestamp), yes, Error,
- FileData, ModuleName, Messages, Items, MaybeModuleTimestamp, !IO).
+read_module(OpenFile, DefaultModuleName, ReturnTimestamp, FileData, ModuleName,
+ Items, Specs, Error, MaybeModuleTimestamp, !IO) :-
+ read_module_2(OpenFile, DefaultModuleName, no, ReturnTimestamp,
+ FileData, ModuleName, Items, Specs, Error, MaybeModuleTimestamp, !IO).
+
+read_module_if_changed(OpenFile, DefaultModuleName, OldTimestamp, FileData, ModuleName, Items, Specs, Error, MaybeModuleTimestamp, !IO) :-
+ read_module_2(OpenFile, DefaultModuleName, yes(OldTimestamp), yes,
+ FileData, ModuleName, Items, Specs, Error,MaybeModuleTimestamp, !IO).
-read_opt_file(FileName, DefaultModuleName, Error, Messages, Items, !IO) :-
+read_opt_file(FileName, DefaultModuleName, Items, Specs, Error, !IO) :-
globals.io_lookup_accumulating_option(intermod_directories, Dirs, !IO),
read_module_2(search_for_file(Dirs, FileName), DefaultModuleName, no, no,
- Error, _, ModuleName, Messages, Items, _, !IO),
+ _, ModuleName, Items, Specs, Error, _, !IO),
check_module_has_expected_name(FileName, DefaultModuleName, ModuleName,
!IO).
@@ -341,12 +350,12 @@
% late-input modes.)
%
:- pred read_module_2(open_file(T)::in(open_file), module_name::in,
- maybe(timestamp)::in, bool::in, module_error::out, maybe(T)::out,
- module_name::out, message_list::out, list(item)::out,
+ maybe(timestamp)::in, bool::in, maybe(T)::out, module_name::out,
+ list(item)::out, list(error_spec)::out, module_error::out,
maybe(io.res(timestamp))::out, io::di, io::uo) is det.
read_module_2(OpenFile, DefaultModuleName, MaybeOldTimestamp, ReturnTimestamp,
- Error, MaybeFileData, ModuleName, Messages, Items,
+ MaybeFileData, ModuleName, Items, Specs, Error,
MaybeModuleTimestamp, !IO) :-
io.input_stream(OldInputStream, !IO),
OpenFile(OpenResult, !IO),
@@ -379,25 +388,27 @@
ModuleName = DefaultModuleName,
Items = [],
- Error = no_module_errors,
- Messages = []
+ Specs = [],
+ Error = no_module_errors
;
- read_all_items(DefaultModuleName, ModuleName, Messages, Items,
- Error, !IO)
+ read_all_items(DefaultModuleName, ModuleName, Items,
+ Specs, Error, !IO)
),
io.set_input_stream(OldInputStream, ModuleInputStream, !IO),
io.close_input(ModuleInputStream, !IO)
;
- OpenResult = error(Message0),
- io.progname_base("mercury_compile", Progname, !IO),
- Message = Progname ++ ": " ++ Message0,
- dummy_term(Term),
- Messages = [Message - Term],
- Error = fatal_module_errors,
- Items = [],
- ModuleName = DefaultModuleName,
+ OpenResult = error(ErrorMsg),
MaybeFileData = no,
- MaybeModuleTimestamp = no
+ ModuleName = DefaultModuleName,
+ Items = [],
+ MaybeModuleTimestamp = no,
+
+ io.progname_base("mercury_compile", Progname, !IO),
+ Pieces = [fixed(Progname), suffix(":"), words(ErrorMsg), nl],
+ Spec = error_spec(severity_error, phase_read_files,
+ [error_msg(no, treat_as_first, 0, [always(Pieces)])]),
+ Specs = [Spec],
+ Error = fatal_module_errors
).
search_for_file(Dirs, FileName, Result, !IO) :-
@@ -603,11 +614,11 @@
% and that the end_module declaration (if any) is correct,
% and construct the final parsing result.
%
-:- pred check_end_module(module_end::in, message_list::in, message_list::out,
- list(item)::in, list(item)::out, module_error::in, module_error::out)
- is det.
+:- pred check_end_module(module_end::in, list(item)::in, list(item)::out,
+ list(error_spec)::in, list(error_spec)::out,
+ module_error::in, module_error::out) is det.
-check_end_module(EndModule, !Messages, !Items, !Error) :-
+check_end_module(EndModule, !Items, !Specs, !Error) :-
% Double-check that the first item is a `:- module ModuleName' declaration,
% and remove it from the front of the item list.
(
@@ -618,13 +629,16 @@
% Check that the end module declaration (if any) matches
% the begin module declaration.
(
- EndModule = module_end_yes(ModuleName2, Context2),
- ModuleName1 \= ModuleName2
+ EndModule = module_end_yes(EndModuleName, EndModuleContext),
+ ModuleName1 \= EndModuleName
->
- dummy_term_with_context(Context2, Term),
- Msg = "`:- end_module' declaration doesn't match " ++
- "`:- module' declaration",
- add_error(Msg - Term, !Messages),
+ Pieces = [words("Error:"),
+ quote(":- end_module"), words("declaration"),
+ words("does not match"),
+ quote(":- module"), words("declaration."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(EndModuleContext, [always(Pieces)])]),
+ !:Specs = [Spec | !.Specs],
!:Error = some_module_errors
;
true
@@ -676,20 +690,24 @@
),
file_name_to_module_name(BaseName, DefaultModuleName),
read_first_item(DefaultModuleName, FileName, _,
- ModuleName, RevMessages, _, _, _, !IO),
+ ModuleName, _, _, Specs, _, !IO),
MaybeModuleName = yes(ModuleName),
- prog_out.write_messages(list.reverse(RevMessages), !IO),
+ % XXX _NumErrors
+ globals.io_get_globals(Globals, !IO),
+ write_error_specs(Specs, Globals, 0, _NumWarnings, 0, _NumErrors, !IO),
io.set_input_stream(OldInputStream, _, !IO),
io.close_input(InputStream, !IO)
;
OpenRes = error(Error),
+ ErrorMsg = io.error_message(Error),
io.progname_base("mercury_compile", Progname, !IO),
- io.write_string(Progname, !IO),
- io.write_string(": error opening `", !IO),
- io.write_string(FileName, !IO),
- io.write_string("': ", !IO),
- io.write_string(io.error_message(Error), !IO),
- io.write_string(".\n", !IO),
+ Pieces = [fixed(Progname), suffix(":"), words("error opening"),
+ quote(FileName), suffix(":"), words(ErrorMsg), suffix("."), nl],
+ Spec = error_spec(severity_error, phase_read_files,
+ [error_msg(no, treat_as_first, 0, [always(Pieces)])]),
+ globals.io_get_globals(Globals, !IO),
+ % XXX _NumErrors
+ write_error_spec(Spec, Globals, 0, _NumWarnings, 0, _NumErrors, !IO),
MaybeModuleName = no
).
@@ -706,36 +724,35 @@
%
% We use a continuation-passing style here.
%
-:- pred read_all_items(module_name::in, module_name::out, message_list::out,
- list(item)::out, module_error::out, io::di, io::uo) is det.
+:- pred read_all_items(module_name::in, module_name::out,
+ list(item)::out, list(error_spec)::out, module_error::out,
+ io::di, io::uo) is det.
-read_all_items(DefaultModuleName, ModuleName, Messages, Items, Error, !IO) :-
+read_all_items(DefaultModuleName, ModuleName, Items, Specs, Error, !IO) :-
% Read all the items (the first one is handled specially).
io.input_stream(Stream, !IO),
io.input_stream_name(Stream, SourceFileName0, !IO),
read_first_item(DefaultModuleName, SourceFileName0, SourceFileName,
- ModuleName, RevMessages0, RevItems0, MaybeSecondTerm, Error0, !IO),
+ ModuleName, RevItems0, MaybeSecondTerm, Specs0, Error0, !IO),
(
MaybeSecondTerm = yes(SecondTerm),
- process_read_term(ModuleName, SecondTerm, MaybeSecondItem),
+ % XXX Should this be SourceFileName instead of SourceFileName0?
+ read_term_to_item_result(ModuleName, SourceFileName0, SecondTerm,
+ MaybeSecondItem),
read_items_loop_2(MaybeSecondItem, ModuleName, SourceFileName,
- RevMessages0, RevMessages1, RevItems0, RevItems1,
- Error0, Error1, !IO)
+ RevItems0, RevItems1, Specs0, Specs1, Error0, Error1, !IO)
;
MaybeSecondTerm = no,
read_items_loop(ModuleName, SourceFileName,
- RevMessages0, RevMessages1, RevItems0, RevItems1,
- Error0, Error1, !IO)
+ RevItems0, RevItems1, Specs0, Specs1, Error0, Error1, !IO)
),
% Get the end_module declaration (if any), check that it matches
% the initial module declaration (if any), and remove both of them
% from the final item list.
get_end_module(ModuleName, RevItems1, RevItems, EndModule),
- check_end_module(EndModule, RevMessages1, RevMessages, Items0, Items,
- Error1, Error),
- list.reverse(RevMessages, Messages),
+ check_end_module(EndModule, Items0, Items, Specs1, Specs, Error1, Error),
list.reverse(RevItems, Items0).
% We need to jump through a few hoops when reading the first item,
@@ -751,20 +768,18 @@
% we reparse it in the default module scope. Blecchh.
%
:- pred read_first_item(module_name::in, file_name::in, file_name::out,
- module_name::out, message_list::out, list(item)::out,
- maybe(read_term)::out, module_error::out, io::di, io::uo) is det.
+ module_name::out, list(item)::out, maybe(read_term)::out,
+ list(error_spec)::out, module_error::out, io::di, io::uo) is det.
read_first_item(DefaultModuleName, !SourceFileName, ModuleName,
- Messages, Items, MaybeSecondTerm, Error, !IO) :-
- globals.io_lookup_bool_option(warn_missing_module_name, WarnMissing, !IO),
- globals.io_lookup_bool_option(warn_wrong_module_name, WarnWrong, !IO),
-
+ Items, MaybeSecondTerm, Specs, Error, !IO) :-
% Parse the first term, treating it as occurring within the scope
% of the special "root" module (so that any `:- module' declaration
% is taken to be a non-nested module unless explicitly qualified).
parser.read_term_filename(!.SourceFileName, MaybeFirstTerm, !IO),
root_module_name(RootModuleName),
- process_read_term(RootModuleName, MaybeFirstTerm, MaybeFirstItem),
+ read_term_to_item_result(RootModuleName, !.SourceFileName, MaybeFirstTerm,
+ MaybeFirstItem),
(
% Apply and then skip `pragma source_file' decls, by calling ourselves
% recursively with the new source file name.
@@ -774,7 +789,7 @@
pragma_source_file(!:SourceFileName), _)
->
read_first_item(DefaultModuleName, !SourceFileName,
- ModuleName, Messages, Items, MaybeSecondTerm, Error, !IO)
+ ModuleName, Items, MaybeSecondTerm, Specs, Error, !IO)
;
% Check if the first term was a `:- module' decl.
MaybeFirstItem = read_item_ok(FirstItem),
@@ -786,16 +801,22 @@
% and if not, report a warning.
( match_sym_name(StartModuleName, DefaultModuleName) ->
ModuleName = DefaultModuleName,
- Messages = []
+ Specs = []
; match_sym_name(DefaultModuleName, StartModuleName) ->
ModuleName = StartModuleName,
- Messages = []
+ Specs = []
;
- StartModuleNameString = sym_name_to_string(StartModuleName),
- WrongModuleWarning = "source file `" ++ !.SourceFileName ++
- "' contains module named `" ++ StartModuleNameString ++ "'",
- maybe_add_warning(WarnWrong, MaybeFirstTerm, FirstContext,
- WrongModuleWarning, [], Messages),
+ % XXX I think this should be an error, not a warning. -zs
+ Pieces = [words("Warning: source file"), quote(!.SourceFileName),
+ words("contains module named"), sym_name(StartModuleName),
+ suffix("."), nl],
+ Severity = severity_conditional(warn_wrong_module_name, yes,
+ severity_warning, no),
+ Msgs = [option_is_set(warn_wrong_module_name, yes,
+ [always(Pieces)])],
+ Spec = error_spec(Severity, phase_term_to_parse_tree,
+ [simple_msg(FirstContext, Msgs)]),
+ Specs = [Spec],
% Which one should we use here? We used to use the default module
% name (computed from the filename) but now we use the declared
@@ -815,15 +836,17 @@
;
term.context_init(!.SourceFileName, 1, FirstContext)
),
- (
- WarnMissing = yes,
- dummy_term_with_context(FirstContext, FirstTerm),
- add_warning("module should start with a `:- module' declaration",
- FirstTerm, [], Messages)
- ;
- WarnMissing = no,
- Messages = []
- ),
+ % XXX I think this should be an error, not a warning. -zs
+ Pieces = [words("Warning: module should start with a"),
+ quote(":- module"), words("declaration."), nl],
+ Severity = severity_conditional(warn_missing_module_name, yes,
+ severity_warning, no),
+ Msgs = [option_is_set(warn_missing_module_name, yes,
+ [always(Pieces)])],
+ Spec = error_spec(Severity, phase_term_to_parse_tree,
+ [simple_msg(FirstContext, Msgs)]),
+ Specs = [Spec],
+
ModuleName = DefaultModuleName,
make_module_decl(ModuleName, FirstContext, FixedFirstItem),
@@ -835,30 +858,13 @@
Error = no_module_errors
).
-:- pred make_module_decl(module_name::in, term.context::in,
- item::out) is det.
+:- pred make_module_decl(module_name::in, term.context::in, item::out) is det.
make_module_decl(ModuleName, Context, Item) :-
ModuleDefn = md_module(ModuleName),
ItemInfo = item_module_defn_info(ModuleDefn, Context),
Item = item_module_defn(ItemInfo).
-:- pred maybe_add_warning(bool::in, read_term::in, term.context::in,
- string::in, message_list::in, message_list::out) is det.
-
-maybe_add_warning(DoWarn, MaybeTerm, Context, Warning, !Messages) :-
- (
- DoWarn = yes,
- ( MaybeTerm = term(_VarSet, Term) ->
- WarningTerm = Term
- ;
- dummy_term_with_context(Context, WarningTerm)
- ),
- add_warning(Warning, WarningTerm, !Messages)
- ;
- DoWarn = no
- ).
-
%-----------------------------------------------------------------------------%
% The code below was carefully optimized to run efficiently in NU-Prolog.
@@ -867,60 +873,51 @@
% garbage collection. But optimizing for NU-Prolog is no longer a concern.
:- pred read_items_loop(module_name::in, file_name::in,
- message_list::in, message_list::out, list(item)::in, list(item)::out,
+ list(item)::in, list(item)::out,
+ list(error_spec)::in, list(error_spec)::out,
module_error::in, module_error::out, io::di, io::uo) is det.
-read_items_loop(ModuleName, SourceFileName, !Msgs, !Items, !Error, !IO) :-
+read_items_loop(ModuleName, SourceFileName, !Items, !Specs, !Error, !IO) :-
read_item(ModuleName, SourceFileName, MaybeItem, !IO),
- read_items_loop_2(MaybeItem, ModuleName, SourceFileName, !Msgs,
- !Items, !Error, !IO).
+ read_items_loop_2(MaybeItem, ModuleName, SourceFileName, !Items,
+ !Specs, !Error, !IO).
%-----------------------------------------------------------------------------%
:- pred read_items_loop_2(read_item_result::in, module_name::in,
- file_name::in, message_list::in, message_list::out,
- list(item)::in, list(item)::out, module_error::in, module_error::out,
- io::di, io::uo) is det.
+ file_name::in, list(item)::in, list(item)::out,
+ list(error_spec)::in, list(error_spec)::out,
+ module_error::in, module_error::out, io::di, io::uo) is det.
-read_items_loop_2(MaybeItemOrEOF, !.ModuleName, !.SourceFileName, !Msgs,
- !Items, !Error, !IO) :-
+read_items_loop_2(MaybeItemOrEOF, !.ModuleName, !.SourceFileName, !Items,
+ !Specs, !Error, !IO) :-
(
MaybeItemOrEOF = read_item_eof
% If the next item was end-of-file, then we're done.
;
- MaybeItemOrEOF = read_item_syntax_error(ErrorMsg, LineNumber),
- % If the next item was a syntax error, then insert it in the list
- % of messages and continue looping.
- term.context_init(!.SourceFileName, LineNumber, Context),
- dummy_term_with_context(Context, Term),
- ThisError = ErrorMsg - Term,
- !:Msgs = [ThisError | !.Msgs],
- !:Error = some_module_errors,
- read_items_loop(!.ModuleName, !.SourceFileName, !Msgs,
- !Items, !Error, !IO)
- ;
- MaybeItemOrEOF = read_item_errors(Errors),
- % If the next item was a semantic error, then insert it in the list
- % of messages and continue looping.
- list.foldl(add_error, Errors, !Msgs),
+ % If the next item had some errors, then insert them
+ % in the list of errors and continue looping.
+
+ MaybeItemOrEOF = read_item_errors(ItemSpecs),
+ !:Specs = ItemSpecs ++ !.Specs,
!:Error = some_module_errors,
- read_items_loop(!.ModuleName, !.SourceFileName, !Msgs,
- !Items, !Error, !IO)
+ read_items_loop(!.ModuleName, !.SourceFileName, !Items,
+ !Specs, !Error, !IO)
;
MaybeItemOrEOF = read_item_ok(Item),
- read_items_loop_ok(Item, !ModuleName, !SourceFileName,
- !Msgs, !Items, !Error, !IO),
- read_items_loop(!.ModuleName, !.SourceFileName, !Msgs,
- !Items, !Error, !IO)
+ read_items_loop_ok(Item, !ModuleName, !SourceFileName, !Items,
+ !Specs, !Error, !IO),
+ read_items_loop(!.ModuleName, !.SourceFileName, !Items,
+ !Specs, !Error, !IO)
).
:- pred read_items_loop_ok(item::in, module_name::in, module_name::out,
- file_name::in, file_name::out, message_list::in, message_list::out,
- list(item)::in, list(item)::out, module_error::in, module_error::out,
- io::di, io::uo) is det.
+ file_name::in, file_name::out, list(item)::in, list(item)::out,
+ list(error_spec)::in, list(error_spec)::out,
+ module_error::in, module_error::out, io::di, io::uo) is det.
-read_items_loop_ok(Item0, !ModuleName, !SourceFileName, !Msgs, !Items,
- !Error, !IO) :-
+read_items_loop_ok(Item0, !ModuleName, !SourceFileName, !Items,
+ !Specs, !Error, !IO) :-
(
Item0 = item_nothing(ItemNothing0),
ItemNothing0 = item_nothing_info(yes(Warning), Context0)
@@ -935,7 +932,10 @@
),
(
Warn = yes,
- add_warning(Msg, Term, !Msgs),
+ Pieces = [words("Warning: "), words(Msg), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(Term), [always(Pieces)])]),
+ !:Specs = [Spec | !.Specs],
globals.io_lookup_bool_option(halt_at_warn, Halt, !IO),
(
@@ -997,6 +997,8 @@
!:Items = [Item | !.Items]
).
+%-----------------------------------------------------------------------------%
+
:- func make_pseudo_import_module_decl(prog_context, module_specifier) = item.
make_pseudo_import_module_decl(Context, ModuleSpecifier) = Item :-
@@ -1022,8 +1024,7 @@
:- type read_item_result
---> read_item_eof
- ; read_item_syntax_error(file_name, int)
- ; read_item_errors(assoc_list(string, term))
+ ; read_item_errors(list(error_spec))
; read_item_ok(item).
% Read_item/1 reads a single item, and if it is a valid term parses it.
@@ -1033,22 +1034,34 @@
read_item(ModuleName, SourceFileName, MaybeItem, !IO) :-
parser.read_term_filename(SourceFileName, MaybeTerm, !IO),
- process_read_term(ModuleName, MaybeTerm, MaybeItem).
+ read_term_to_item_result(ModuleName, SourceFileName, MaybeTerm, MaybeItem).
-:- pred process_read_term(module_name::in, read_term::in,
+:- pred read_term_to_item_result(module_name::in, string::in, read_term::in,
read_item_result::out) is det.
-process_read_term(_ModuleName, eof, read_item_eof).
-process_read_term(_ModuleName, error(ErrorMsg, LineNumber),
- read_item_syntax_error(ErrorMsg, LineNumber)).
-process_read_term(ModuleName, term(VarSet, Term), MaybeItemOrEof) :-
+read_term_to_item_result(ModuleName, FileName, ReadTermResult,
+ ReadItemResult) :-
+ (
+ ReadTermResult = eof,
+ ReadItemResult = read_item_eof
+ ;
+ ReadTermResult = error(ErrorMsg, LineNumber),
+ % XXX Do we need to add an "Error:" prefix?
+ Pieces = [words(ErrorMsg), suffix("."), nl],
+ Context = term.context_init(FileName, LineNumber),
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(Context, [always(Pieces)])]),
+ ReadItemResult = read_item_errors([Spec])
+ ;
+ ReadTermResult = term(VarSet, Term),
parse_item(ModuleName, VarSet, Term, MaybeItem),
- convert_item(MaybeItem, MaybeItemOrEof).
+ convert_item(MaybeItem, ReadItemResult)
+ ).
:- pred convert_item(maybe1(item)::in, read_item_result::out) is det.
convert_item(ok1(Item), read_item_ok(Item)).
-convert_item(error1(Errors), read_item_errors(Errors)).
+convert_item(error1(Specs), read_item_errors(Specs)).
parse_item(ModuleName, VarSet, Term, Result) :-
( Term = term.functor(term.atom(":-"), [Decl], _DeclContext) ->
@@ -1079,26 +1092,30 @@
prog_varset::in, term.context::in, maybe1(item)::out) is det.
process_clause(ModuleName, Term, Head, Body0, ProgVarSet0, Context, Result) :-
- parse_goal(Body0, MaybeBody, ProgVarSet0, ProgVarSet),
+ GoalContextPieces = [],
+ parse_goal(Body0, GoalContextPieces, MaybeBody, ProgVarSet0, ProgVarSet),
(
MaybeBody = ok1(Body),
+ varset.coerce(ProgVarSet, VarSet),
(
Head = term.functor(term.atom("="), [FuncHead0, FuncResult], _),
FuncHead = desugar_field_access(FuncHead0)
->
+ HeadContextPieces = [words("In equation head:")],
parse_implicitly_qualified_term(ModuleName, FuncHead, Head,
- "equation head", MaybeFunctor),
+ VarSet, HeadContextPieces, MaybeFunctor),
process_func_clause(MaybeFunctor, FuncResult, ProgVarSet, Body,
Context, Result)
;
+ HeadContextPieces = [words("In clause head:")],
parse_implicitly_qualified_term(ModuleName, Head, Term,
- "clause head", MaybeFunctor),
+ VarSet, HeadContextPieces, MaybeFunctor),
process_pred_clause(MaybeFunctor, ProgVarSet, Body, Context,
Result)
)
;
- MaybeBody = error1(Errors),
- Result = error1(Errors)
+ MaybeBody = error1(Specs),
+ Result = error1(Specs)
).
:- pred process_pred_clause(maybe_functor::in, prog_varset::in, goal::in,
@@ -1113,9 +1130,8 @@
Item = item_clause(ItemClause),
MaybeItem = ok1(Item)
;
- MaybeFunctor = error2(Errors0),
- Errors = assoc_list.map_values_only(term.coerce, Errors0),
- MaybeItem = error1(Errors)
+ MaybeFunctor = error2(Specs),
+ MaybeItem = error1(Specs)
).
:- pred process_func_clause(maybe_functor::in, term::in, prog_varset::in,
@@ -1131,9 +1147,8 @@
Item = item_clause(ItemClause),
MaybeItem = ok1(Item)
;
- MaybeFunctor = error2(Errors0),
- Errors = assoc_list.map_values_only(term.coerce, Errors0),
- MaybeItem = error1(Errors)
+ MaybeFunctor = error2(Specs),
+ MaybeItem = error1(Specs)
).
%-----------------------------------------------------------------------------%
@@ -1153,10 +1168,10 @@
% both the attribute and the declaration that that attribute modifies;
% this term is used when printing out error messages for cases when
% attributes are used on declarations where they are not allowed.
-:- type decl_attrs == assoc_list(decl_attribute, term).
+:- type decl_attrs == assoc_list(decl_attribute, term.context).
-parse_decl(ModuleName, VarSet, F, Result) :-
- parse_decl_2(ModuleName, VarSet, F, [], Result).
+parse_decl(ModuleName, VarSet, Term, Result) :-
+ parse_decl_2(ModuleName, VarSet, Term, [], Result).
% parse_decl_2(ModuleName, VarSet, Term, Attributes, Result):
%
@@ -1167,12 +1182,12 @@
:- pred parse_decl_2(module_name::in, varset::in, term::in, decl_attrs::in,
maybe1(item)::out) is det.
-parse_decl_2(ModuleName, VarSet, F, Attributes, Result) :-
- ( F = term.functor(term.atom(Atom), Args, Context) ->
+parse_decl_2(ModuleName, VarSet, Term, Attributes, Result) :-
+ ( Term = term.functor(term.atom(Atom), Args, Context) ->
(
parse_decl_attribute(Atom, Args, Attribute, SubTerm)
->
- NewAttributes = [Attribute - F | Attributes],
+ NewAttributes = [Attribute - Context | Attributes],
parse_decl_2(ModuleName, VarSet, SubTerm, NewAttributes, Result)
;
process_decl(ModuleName, VarSet, Atom, Args, Attributes, Context,
@@ -1180,10 +1195,19 @@
->
ResultPrime = Result
;
- Result = error1(["unrecognized declaration" - F])
+ TermStr = mercury_term_to_string(VarSet, no, Term),
+ Pieces = [words("Error: unrecognized declaration:"), nl,
+ words(TermStr), suffix("."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(Context, [always(Pieces)])]),
+ Result = error1([Spec])
)
;
- Result = error1(["atom expected after `:-'" - F])
+ Context = get_term_context(Term),
+ Pieces = [words("Error: atom expected after `:-'."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(Context, [always(Pieces)])]),
+ Result = error1([Spec])
).
% process_decl(ModuleName, VarSet, Attributes, Atom, Args, Result):
@@ -1195,6 +1219,8 @@
:- pred process_decl(module_name::in, varset::in, string::in, list(term)::in,
decl_attrs::in, prog_context::in, maybe1(item)::out) is semidet.
+% XXX Break this up into one predicate per declaration,
+% with this predicate doing nothing except switching between them.
process_decl(ModuleName, VarSet, "type", [TypeDecl], Attributes, Context,
Result) :-
parse_type_decl(ModuleName, VarSet, TypeDecl, Attributes, Context, Result).
@@ -1218,19 +1244,19 @@
parse_inst_decl(ModuleName, VarSet, InstDecl, Context, Result0),
check_no_attributes(Result0, Attributes, Result).
-process_decl(_ModuleName, _VarSet, "import_module", [ModuleSpec], Attributes,
+process_decl(_ModuleName, VarSet, "import_module", [ModuleSpec], Attributes,
Context, Result) :-
- parse_symlist_decl(parse_module_specifier, make_import,
+ parse_symlist_decl(parse_module_specifier(VarSet), make_import,
ModuleSpec, Attributes, Context, Result).
-process_decl(_ModuleName, _VarSet, "use_module", [ModuleSpec], Attributes,
+process_decl(_ModuleName, VarSet, "use_module", [ModuleSpec], Attributes,
Context, Result) :-
- parse_symlist_decl(parse_module_specifier, make_use,
+ parse_symlist_decl(parse_module_specifier(VarSet), make_use,
ModuleSpec, Attributes, Context, Result).
-process_decl(_ModuleName, _VarSet, "export_module", [ModuleSpec], Attributes,
+process_decl(_ModuleName, VarSet, "export_module", [ModuleSpec], Attributes,
Context, Result) :-
- parse_symlist_decl(parse_module_specifier, make_export,
+ parse_symlist_decl(parse_module_specifier(VarSet), make_export,
ModuleSpec, Attributes, Context, Result).
process_decl(_ModuleName, _VarSet, "interface", [], Attributes, Context,
@@ -1247,7 +1273,7 @@
Result0 = ok1(Item),
check_no_attributes(Result0, Attributes, Result).
-process_decl(ModuleName, _VarSet, "external", Args, Attributes, Context,
+process_decl(ModuleName, VarSet, "external", Args, Attributes, Context,
Result) :-
(
Args = [PredSpec],
@@ -1264,14 +1290,14 @@
),
MaybeBackend = yes(Backend)
),
- parse_implicitly_qualified_symbol_name_specifier(ModuleName, PredSpec,
- Result0),
+ parse_implicitly_qualified_symbol_name_specifier(ModuleName, VarSet,
+ PredSpec, Result0),
process_maybe1(make_external(MaybeBackend, Context), Result0, Result1),
check_no_attributes(Result1, Attributes, Result).
-process_decl(DefaultModuleName, _VarSet, "module", [ModuleName], Attributes,
+process_decl(DefaultModuleName, VarSet, "module", [ModuleName], Attributes,
Context, Result) :-
- parse_module_name(DefaultModuleName, ModuleName, Result0),
+ parse_module_name(DefaultModuleName, VarSet, ModuleName, Result0),
(
Result0 = ok1(ModuleNameSym),
ModuleDefn = md_module(ModuleNameSym),
@@ -1279,14 +1305,15 @@
Item = item_module_defn(ItemModuleDefn),
Result1 = ok1(Item)
;
- Result0 = error1(Errors),
- Result1 = error1(Errors)
+ Result0 = error1(Specs),
+ Result1 = error1(Specs)
),
check_no_attributes(Result1, Attributes, Result).
-process_decl(DefaultModuleName, _VarSet, "include_module", [ModuleNames],
+process_decl(DefaultModuleName, VarSet, "include_module", [ModuleNames],
Attributes, Context, Result) :-
- parse_list(parse_module_name(DefaultModuleName), ModuleNames, Result0),
+ parse_list(parse_module_name(DefaultModuleName, VarSet), ModuleNames,
+ Result0),
(
Result0 = ok1(ModuleNameSyms),
ModuleDefn = md_include_module(ModuleNameSyms),
@@ -1294,12 +1321,12 @@
Item = item_module_defn(ItemModuleDefn),
Result1 = ok1(Item)
;
- Result0 = error1(Errors),
- Result1 = error1(Errors)
+ Result0 = error1(Specs),
+ Result1 = error1(Specs)
),
check_no_attributes(Result1, Attributes, Result).
-process_decl(DefaultModuleName, _VarSet, "end_module", [ModuleName],
+process_decl(DefaultModuleName, VarSet, "end_module", [ModuleName],
Attributes, Context, Result) :-
% The name in an `end_module' declaration not inside the scope of the
% module being ended, so the default module name here is the parent
@@ -1308,7 +1335,7 @@
root_module_name(RootModuleName),
sym_name_get_module_name(DefaultModuleName, RootModuleName,
ParentOfDefaultModuleName),
- parse_module_name(ParentOfDefaultModuleName, ModuleName, Result0),
+ parse_module_name(ParentOfDefaultModuleName, VarSet, ModuleName, Result0),
(
Result0 = ok1(ModuleNameSym),
ModuleDefn = md_end_module(ModuleNameSym),
@@ -1316,8 +1343,8 @@
Item = item_module_defn(ItemModuleDefn),
Result1 = ok1(Item)
;
- Result0 = error1(Errors),
- Result1 = error1(Errors)
+ Result0 = error1(Specs),
+ Result1 = error1(Specs)
),
check_no_attributes(Result1, Attributes, Result).
@@ -1354,8 +1381,8 @@
Result0 = ok1(ItemTypeClass),
Result1 = ok1(item_typeclass(ItemTypeClass))
;
- Result0 = error1(Errors),
- Result1 = error1(Errors)
+ Result0 = error1(Specs),
+ Result1 = error1(Specs)
),
check_no_attributes(Result1, Attributes, Result).
@@ -1366,22 +1393,21 @@
Result0 = ok1(ItemInstance),
Result1 = ok1(item_instance(ItemInstance))
;
- Result0 = error1(Errors),
- Result1 = error1(Errors)
+ Result0 = error1(Specs),
+ Result1 = error1(Specs)
),
check_no_attributes(Result1, Attributes, Result).
-process_decl(ModuleName, _VarSet, "version_numbers",
+process_decl(ModuleName, VarSet, "version_numbers",
[VersionNumberTerm, ModuleNameTerm, VersionNumbersTerm],
Attributes, Context, Result) :-
- parse_module_specifier(ModuleNameTerm, ModuleNameResult),
+ parse_module_specifier(VarSet, ModuleNameTerm, ModuleNameResult),
(
VersionNumberTerm = term.functor(term.integer(VersionNumber), [], _),
VersionNumber = version_numbers_version_number
->
(
- ModuleNameResult = ok1(ModuleName)
- ->
+ ModuleNameResult = ok1(ModuleName),
recompilation.version.parse_version_numbers(VersionNumbersTerm,
Result0),
(
@@ -1392,15 +1418,22 @@
Result1 = ok1(Item),
check_no_attributes(Result1, Attributes, Result)
;
- Result0 = error1(Errors),
- Result = error1(Errors)
+ Result0 = error1(Specs),
+ Result = error1(Specs)
)
;
- Msg = "invalid module name in `:- version_numbers'",
- Result = error1([Msg - ModuleNameTerm])
+ % XXX _Spec
+ ModuleNameResult = error1(_Spec),
+ Pieces = [words("Error: invalid module name in"),
+ quote(":- version_numbers"), suffix("."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(ModuleNameTerm),
+ [always(Pieces)])]),
+ Result = error1([Spec])
)
;
- ( VersionNumberTerm = term.functor(_, _, Context) ->
+ (
+ VersionNumberTerm = term.functor(_, _, _VersionNumberContext),
Msg = "interface file needs to be recreated, " ++
"the version numbers are out of date",
dummy_term_with_context(Context, DummyTerm),
@@ -1410,8 +1443,12 @@
Item = item_nothing(ItemNothing),
Result = ok1(Item)
;
- Msg = "invalid version number in `:- version_numbers'",
- Result = error1([Msg - VersionNumberTerm])
+ VersionNumberTerm = term.variable(_, VersionNumberContext),
+ Pieces = [words("Error: invalid version number in"),
+ quote(":- version_numbers"), suffix("."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(VersionNumberContext, [always(Pieces)])]),
+ Result = error1([Spec])
)
).
@@ -1457,10 +1494,14 @@
check_no_attributes(Result0, Attributes, Result) :-
(
Result0 = ok1(_),
- Attributes = [Attr - Term | _]
+ Attributes = [Attr - Context | _]
->
- Message = attribute_description(Attr) ++ " not allowed here",
- Result = error1([Message - Term])
+ % XXX Shouldn't we mention EVERY element of Attributes?
+ Pieces = [words("Error:"), words(attribute_description(Attr)),
+ words("not allowed here."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(Context, [always(Pieces)])]),
+ Result = error1([Spec])
;
Result = Result0
).
@@ -1487,7 +1528,8 @@
parse_promise(ModuleName, PromiseType, VarSet, [Term], Attributes, Context,
Result) :-
varset.coerce(VarSet, ProgVarSet0),
- parse_goal(Term, MaybeGoal0, ProgVarSet0, ProgVarSet),
+ ContextPieces = [],
+ parse_goal(Term, ContextPieces, MaybeGoal0, ProgVarSet0, ProgVarSet),
(
MaybeGoal0 = ok1(Goal0),
% Get universally quantified variables.
@@ -1515,8 +1557,8 @@
Item = item_promise(ItemPromise),
Result = ok1(Item)
;
- MaybeGoal0 = error1(Errors),
- Result = error1(Errors)
+ MaybeGoal0 = error1(Specs),
+ Result = error1(Specs)
).
%-----------------------------------------------------------------------------%
@@ -1527,17 +1569,20 @@
parse_type_decl(ModuleName, VarSet, TypeDecl, Attributes, Context, Result) :-
(
TypeDecl = term.functor(term.atom(Name), Args, _),
- parse_type_decl_type(ModuleName, Name, Args, Attributes, Cond, R)
+ parse_type_decl_type(ModuleName, VarSet, Name, Args, Attributes, Cond,
+ TypeDeclResultPrime)
->
- R1 = R,
+ TypeDeclResult = TypeDeclResultPrime,
Cond1 = Cond
;
- process_abstract_type(ModuleName, TypeDecl, Attributes, R1),
+ process_abstract_type(ModuleName, VarSet, TypeDecl, Attributes,
+ TypeDeclResult),
Cond1 = cond_true
),
% We should check the condition for errors (don't bother at the moment,
% since we ignore conditions anyhow :-).
- process_maybe1(make_type_defn(VarSet, Cond1, Context), R1, Result).
+ process_maybe1(make_type_defn(VarSet, Cond1, Context), TypeDeclResult,
+ Result).
:- pred make_type_defn(varset::in, condition::in, prog_context::in,
processed_type_body::in, item::out) is det.
@@ -1569,96 +1614,85 @@
%-----------------------------------------------------------------------------%
- % Add a warning message to the list of messages.
- %
-:- pred add_warning(string::in, term::in, message_list::in, message_list::out)
- is det.
-
-add_warning(Warning, Term, Msgs, [Msg - Term | Msgs]) :-
- string.append("Warning: ", Warning, Msg).
-
- % Add an error message to the list of messages.
- %
-:- pred add_error(pair(string, term)::in, message_list::in, message_list::out)
- is det.
-
-add_error(BaseMsg - Term, Msgs, [Msg - Term | Msgs]) :-
- string.append("Error: ", BaseMsg, Msg).
-
-%-----------------------------------------------------------------------------%
-
% parse_type_decl_type(Term, Condition, Result) succeeds if Term is
% a "type" type declaration, and binds Condition to the condition for
% that declaration (if any), and Result to a representation of the
% declaration.
%
-:- pred parse_type_decl_type(module_name::in, string::in, list(term)::in,
- decl_attrs::in, condition::out, maybe1(processed_type_body)::out)
- is semidet.
+:- pred parse_type_decl_type(module_name::in, varset::in, string::in,
+ list(term)::in, decl_attrs::in, condition::out,
+ maybe1(processed_type_body)::out) is semidet.
-parse_type_decl_type(ModuleName, "--->", [HeadTerm, BodyTerm], Attributes0,
- Condition, Result) :-
+parse_type_decl_type(ModuleName, VarSet, Connective, [HeadTerm, BodyTerm],
+ Attributes0, Condition, Result) :-
+ (
+ Connective = "--->",
get_condition(BodyTerm, Body, Condition),
get_is_solver_type(IsSolverType, Attributes0, Attributes),
(
IsSolverType = solver_type,
- Msg = "a solver type cannot have data constructors",
- Result = error1([Msg - HeadTerm])
+ Pieces = [words("Error: a solver type:"),
+ words("cannot have data constructors."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(HeadTerm), [always(Pieces)])]),
+ Result = error1([Spec])
;
IsSolverType = non_solver_type,
du_type_rhs_ctors_and_where_terms(Body, CtorsTerm, MaybeWhereTerm),
- CtorsResult = convert_constructors(ModuleName, CtorsTerm),
+ CtorsResult = convert_constructors(ModuleName, VarSet, CtorsTerm),
(
- CtorsResult = error1(Errors),
- Result = error1(Errors)
+ CtorsResult = error1(Specs),
+ Result = error1(Specs)
;
CtorsResult = ok1(Ctors),
WhereResult = parse_type_decl_where_term(non_solver_type,
- ModuleName, MaybeWhereTerm),
+ ModuleName, VarSet, MaybeWhereTerm),
(
- WhereResult = error2(Errors),
- Result = error1(Errors)
+ WhereResult = error2(Specs),
+ Result = error1(Specs)
;
- % The code to process `where' attributes will return an error
- % result if solver attributes are given for a non-solver type.
- % Because this is a du type, if the unification with
- % WhereResult succeeds then _NoSolverTypeDetails is
- % guaranteed to be `no'.
+ % The code to process `where' attributes will return
+ % an error result if solver attributes are given for
+ % a non-solver type. Because this is a du type, if the
+ % unification with WhereResult succeeds then
+ % _NoSolverTypeDetails is guaranteed to be `no'.
WhereResult = ok2(_NoSolverTypeDetails, MaybeUserEqComp),
- process_du_type(ModuleName, HeadTerm, Body, Ctors,
- MaybeUserEqComp, Result0),
+ process_du_type(ModuleName, VarSet, HeadTerm, BodyTerm,
+ Ctors, MaybeUserEqComp, Result0),
check_no_attributes(Result0, Attributes, Result)
)
)
- ).
-
-parse_type_decl_type(ModuleName, "==", [HeadTerm, BodyTerm], Attributes,
- Condition, Result) :-
+ )
+ ;
+ Connective = "==",
get_condition(BodyTerm, Body, Condition),
- process_eqv_type(ModuleName, HeadTerm, Body, Result0),
- check_no_attributes(Result0, Attributes, Result).
-
-parse_type_decl_type(ModuleName, "where", [HeadTerm, BodyTerm], Attributes0,
- Condition, Result) :-
+ process_eqv_type(ModuleName, VarSet, HeadTerm, Body, Result0),
+ check_no_attributes(Result0, Attributes0, Result)
+ ;
+ Connective = "where",
get_condition(BodyTerm, Body, Condition),
get_is_solver_type(IsSolverType, Attributes0, Attributes),
(
IsSolverType = non_solver_type,
- Msg = "only solver types can be defined by a `where' block alone",
- Result = error1([Msg - HeadTerm])
+ Pieces = [words("Error: only solver types can be defined"),
+ words("by a `where' block alone."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(HeadTerm), [always(Pieces)])]),
+ Result = error1([Spec])
;
IsSolverType = solver_type,
Result0 = parse_type_decl_where_term(solver_type, ModuleName,
- yes(Body)),
+ VarSet, yes(Body)),
(
- Result0 = error2(Errors),
- Result = error1(Errors)
+ Result0 = error2(Specs),
+ Result = error1(Specs)
;
Result0 = ok2(MaybeSolverTypeDetails, MaybeUserEqComp),
- process_solver_type(ModuleName, HeadTerm,
+ process_solver_type(ModuleName, VarSet, HeadTerm,
MaybeSolverTypeDetails, MaybeUserEqComp, Result1),
check_no_attributes(Result1, Attributes, Result)
)
+ )
).
:- pred du_type_rhs_ctors_and_where_terms(term::in,
@@ -1687,16 +1721,16 @@
parse_type_decl_pred(ModuleName, VarSet, Pred, Attributes, Context, Result) :-
get_condition(Pred, Body, Condition),
- get_determinism(Body, Body2, MaybeDeterminism),
+ get_determinism(VarSet, Body, Body2, MaybeDeterminism),
get_with_inst(Body2, Body3, WithInst),
- get_with_type(Body3, Body4, WithTypeResult),
+ get_with_type(VarSet, Body3, Body4, WithTypeResult),
( WithTypeResult = ok1(WithType),
process_type_decl_pred_or_func(pf_predicate, ModuleName, WithType,
WithInst, MaybeDeterminism, VarSet, Body4, Condition, Attributes,
Context, Result)
;
- WithTypeResult = error1(Errors),
- Result = error1(Errors)
+ WithTypeResult = error1(Specs),
+ Result = error1(Specs)
).
:- pred process_type_decl_pred_or_func(pred_or_func::in, module_name::in,
@@ -1712,11 +1746,18 @@
(
WithInst0 = ok1(WithInst),
( MaybeDeterminism = yes(_), WithInst = yes(_) ->
- Msg = "`with_inst` and determinism both specified",
- Result = error1([Msg - Body])
+ Pieces = [words("Error:"), quote("with_inst"),
+ words("and determinism both specified."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(Body), [always(Pieces)])]),
+ Result = error1([Spec])
; WithInst = yes(_), WithType = no ->
- Msg = "`with_inst` specified without `with_type`",
- Result = error1([Msg - Body])
+ Pieces = [words("Error:"), quote("with_inst"),
+ words("specified without"), quote("with_type"),
+ suffix("."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(Body), [always(Pieces)])]),
+ Result = error1([Spec])
;
(
% Function declarations with `with_type` annotations
@@ -1733,17 +1774,17 @@
)
)
;
- WithInst0 = error1(Errors),
- Result = error1(Errors)
+ WithInst0 = error1(Specs),
+ Result = error1(Specs)
)
;
- MaybeDeterminism0 = error1(Errors),
- Result = error1(Errors)
+ MaybeDeterminism0 = error1(Specs),
+ Result = error1(Specs)
).
%-----------------------------------------------------------------------------%
- % parse_type_decl_func(ModuleName, Varset, Func, Attributes, Result)
+ % parse_type_decl_func(ModuleName, VarSet, Func, Attributes, Result)
% succeeds if Func is a function type declaration, and binds Result to
% a representation of the declaration.
%
@@ -1752,17 +1793,17 @@
parse_type_decl_func(ModuleName, VarSet, Func, Attributes, Context, Result) :-
get_condition(Func, Body, Condition),
- get_determinism(Body, Body2, MaybeDeterminism),
+ get_determinism(VarSet, Body, Body2, MaybeDeterminism),
get_with_inst(Body2, Body3, WithInst),
- get_with_type(Body3, Body4, WithTypeResult),
+ get_with_type(VarSet, Body3, Body4, WithTypeResult),
(
WithTypeResult = ok1(WithType),
process_type_decl_pred_or_func(pf_function, ModuleName,
WithType, WithInst, MaybeDeterminism, VarSet, Body4,
Condition, Attributes, Context, Result)
;
- WithTypeResult = error1(Errors),
- Result = error1(Errors)
+ WithTypeResult = error1(Specs),
+ Result = error1(Specs)
).
%-----------------------------------------------------------------------------%
@@ -1777,7 +1818,7 @@
parse_mode_decl_pred(ModuleName, VarSet, Pred, Attributes, Context, Result) :-
get_condition(Pred, Body, Condition),
- get_determinism(Body, Body2, MaybeDeterminism0),
+ get_determinism(VarSet, Body, Body2, MaybeDeterminism0),
get_with_inst(Body2, Body3, WithInst0),
(
MaybeDeterminism0 = ok1(MaybeDeterminism),
@@ -1787,19 +1828,23 @@
MaybeDeterminism = yes(_),
WithInst = yes(_)
->
- Msg = "`with_inst` and determinism both specified",
- Result = error1([Msg - Body])
+ Pieces = [words("Error:"), quote("with_inst"),
+ words("and determinism both specified."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(Body), [always(Pieces)])]),
+ Result = error1([Spec])
+
;
process_mode(ModuleName, VarSet, Body3, Condition, Attributes,
WithInst, MaybeDeterminism, Context, Result)
)
;
- WithInst0 = error1(Errors),
- Result = error1(Errors)
+ WithInst0 = error1(Specs),
+ Result = error1(Specs)
)
;
- MaybeDeterminism0 = error1(Errors),
- Result = error1(Errors)
+ MaybeDeterminism0 = error1(Specs),
+ Result = error1(Specs)
).
%-----------------------------------------------------------------------------%
@@ -1807,16 +1852,22 @@
:- pred parse_initialise_decl(module_name::in, varset::in, list(term)::in,
prog_context::in, maybe1(item)::out) is semidet.
-parse_initialise_decl(_ModuleName, _VarSet, [Term], Context, Result) :-
- parse_symbol_name_specifier(Term, MaybeSymNameSpecifier),
+parse_initialise_decl(_ModuleName, VarSet, [Term], Context, Result) :-
+ parse_symbol_name_specifier(VarSet, Term, MaybeSymNameSpecifier),
(
- MaybeSymNameSpecifier = error1(Errors),
- Result = error1(Errors)
+ MaybeSymNameSpecifier = error1(Specs),
+ Result = error1(Specs)
;
MaybeSymNameSpecifier = ok1(SymNameSpecifier),
(
SymNameSpecifier = name(_),
- Result = error1(["`initialise' declaration requires arity" - Term])
+ TermStr = describe_error_term(VarSet, Term),
+ Pieces = [words("Error:"), quote("initialise"),
+ words("declaration"), words("requires arity, found"),
+ words(TermStr), suffix("."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(Term), [always(Pieces)])]),
+ Result = error1([Spec])
;
SymNameSpecifier = name_arity(SymName, Arity),
(
@@ -1827,9 +1878,14 @@
Item = item_initialise(ItemInitialise),
Result = ok1(Item)
;
- Msg = "`initialise' declaration specifies a predicate " ++
- "whose arity is not zero or two",
- Result = error1([Msg - Term])
+ TermStr = describe_error_term(VarSet, Term),
+ Pieces = [words("Error:"), quote("initialise"),
+ words("declaration specifies a predicate"),
+ words("whose arity is not zero or two:"),
+ words(TermStr), suffix("."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(Term), [always(Pieces)])]),
+ Result = error1([Spec])
)
)
).
@@ -1839,16 +1895,22 @@
:- pred parse_finalise_decl(module_name::in, varset::in, list(term)::in,
prog_context::in, maybe1(item)::out) is semidet.
-parse_finalise_decl(_ModuleName, _VarSet, [Term], Context, Result) :-
- parse_symbol_name_specifier(Term, MaybeSymNameSpecifier),
+parse_finalise_decl(_ModuleName, VarSet, [Term], Context, Result) :-
+ parse_symbol_name_specifier(VarSet, Term, MaybeSymNameSpecifier),
(
- MaybeSymNameSpecifier = error1(Errors),
- Result = error1(Errors)
+ MaybeSymNameSpecifier = error1(Specs),
+ Result = error1(Specs)
;
MaybeSymNameSpecifier = ok1(SymNameSpecifier),
(
SymNameSpecifier = name(_),
- Result = error1(["`finalise' declaration requires arity" - Term])
+ TermStr = describe_error_term(VarSet, Term),
+ Pieces = [words("Error:"), quote("finalise"),
+ words("declaration"), words("requires arity, found"),
+ words(TermStr), suffix("."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(Term), [always(Pieces)])]),
+ Result = error1([Spec])
;
SymNameSpecifier = name_arity(SymName, Arity),
(
@@ -1859,9 +1921,14 @@
Item = item_finalise(ItemFinalise),
Result = ok1(Item)
;
- Msg = "`finalise' declaration specifies a predicate " ++
- "whose arity is not zero or two",
- Result = error1([Msg - Term])
+ TermStr = describe_error_term(VarSet, Term),
+ Pieces = [words("Error:"), quote("finalise"),
+ words("declaration specifies a predicate"),
+ words("whose arity is not zero or two:"),
+ words(TermStr), suffix("."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(Term), [always(Pieces)])]),
+ Result = error1([Spec])
)
)
).
@@ -1876,13 +1943,13 @@
:- pred parse_mutable_decl(module_name::in, varset::in, list(term)::in,
prog_context::in, maybe1(item)::out) is semidet.
-parse_mutable_decl(_ModuleName, Varset, Terms, Context, Result) :-
+parse_mutable_decl(_ModuleName, VarSet, Terms, Context, Result) :-
Terms = [NameTerm, TypeTerm, ValueTerm, InstTerm | OptMutAttrsTerm],
parse_mutable_name(NameTerm, NameResult),
- parse_mutable_type(TypeTerm, TypeResult),
+ parse_mutable_type(VarSet, TypeTerm, TypeResult),
term.coerce(ValueTerm, Value),
- varset.coerce(Varset, ProgVarset),
- parse_mutable_inst(InstTerm, InstResult),
+ varset.coerce(VarSet, ProgVarSet),
+ parse_mutable_inst(VarSet, InstTerm, InstResult),
% The list of attributes is optional.
(
@@ -1890,7 +1957,7 @@
MutAttrsResult = ok1(default_mutable_attributes)
;
OptMutAttrsTerm = [MutAttrsTerm],
- parse_mutable_attrs(MutAttrsTerm, MutAttrsResult)
+ parse_mutable_attrs(VarSet, MutAttrsTerm, MutAttrsResult)
),
(
NameResult = ok1(Name),
@@ -1905,13 +1972,13 @@
% passes attempting to reuse this variable when fresh variables are
% allocated.
ItemMutable = item_mutable_info(Name, Type, Value, Inst, MutAttrs,
- ProgVarset, Context),
+ ProgVarSet, Context),
Item = item_mutable(ItemMutable),
Result = ok1(Item)
;
- Errors = get_any_errors1(NameResult) ++ get_any_errors1(TypeResult) ++
+ Specs = get_any_errors1(NameResult) ++ get_any_errors1(TypeResult) ++
get_any_errors1(InstResult) ++ get_any_errors1(MutAttrsResult),
- Result = error1(Errors)
+ Result = error1(Specs)
).
:- pred parse_mutable_name(term::in, maybe1(string)::out) is det.
@@ -1920,29 +1987,46 @@
( NameTerm = term.functor(atom(Name), [], _) ->
NameResult = ok1(Name)
;
- NameResult = error1(["invalid mutable name" - NameTerm])
+ Pieces = [words("Error: invalid mutable name."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(NameTerm), [always(Pieces)])]),
+ NameResult = error1([Spec])
).
-:- pred parse_mutable_type(term::in, maybe1(mer_type)::out) is det.
+:- pred parse_mutable_type(varset::in, term::in, maybe1(mer_type)::out) is det.
-parse_mutable_type(TypeTerm, TypeResult) :-
+parse_mutable_type(VarSet, TypeTerm, TypeResult) :-
( term.contains_var(TypeTerm, _) ->
- Msg = "the type in a mutable declaration cannot contain variables",
- TypeResult = error1([Msg - TypeTerm])
+ TypeTermStr = describe_error_term(VarSet, TypeTerm),
+ Pieces = [words("Error: the type in a mutable declaration"),
+ words("cannot contain variables:"),
+ words(TypeTermStr), suffix("."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(TypeTerm), [always(Pieces)])]),
+ TypeResult = error1([Spec])
;
- parse_type(TypeTerm, TypeResult)
+ ContextPieces = [],
+ parse_type(TypeTerm, VarSet, ContextPieces, TypeResult)
).
-:- pred parse_mutable_inst(term::in, maybe1(mer_inst)::out) is det.
+:- pred parse_mutable_inst(varset::in, term::in, maybe1(mer_inst)::out) is det.
-parse_mutable_inst(InstTerm, InstResult) :-
+parse_mutable_inst(VarSet, InstTerm, InstResult) :-
( term.contains_var(InstTerm, _) ->
- Msg = "the inst in a mutable declaration cannot contain variables",
- InstResult = error1([Msg - InstTerm])
+ InstTermStr = describe_error_term(VarSet, InstTerm),
+ Pieces = [words("Error: the inst in a mutable declaration"),
+ words("cannot contain variables:"),
+ words(InstTermStr), suffix("."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(InstTerm), [always(Pieces)])]),
+ InstResult = error1([Spec])
; convert_inst(no_allow_constrained_inst_var, InstTerm, Inst) ->
InstResult = ok1(Inst)
;
- InstResult = error1(["invalid inst in mutable declaration" - InstTerm])
+ Pieces = [words("Error: invalid inst in mutable declaration."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(InstTerm), [always(Pieces)])]),
+ InstResult = error1([Spec])
).
:- type collected_mutable_attribute
@@ -1952,10 +2036,10 @@
; mutable_attr_constant(bool)
; mutable_attr_thread_local(mutable_thread_local).
-:- pred parse_mutable_attrs(term::in,
+:- pred parse_mutable_attrs(varset::in, term::in,
maybe1(mutable_var_attributes)::out) is det.
-parse_mutable_attrs(MutAttrsTerm, MutAttrsResult) :-
+parse_mutable_attrs(VarSet, MutAttrsTerm, MutAttrsResult) :-
Attributes0 = default_mutable_attributes,
ConflictingAttributes = [
mutable_attr_trailed(mutable_trailed) -
@@ -1981,16 +2065,28 @@
list.member(Conflict1, CollectedMutAttrs),
list.member(Conflict2, CollectedMutAttrs)
->
- Msg = "conflicting attributes in attribute list",
- MutAttrsResult = error1([Msg - MutAttrsTerm])
+ % XXX Should generate more specific error message.
+ MutAttrsStr = mercury_term_to_string(VarSet, no, MutAttrsTerm),
+ Pieces = [words("Error: conflicting attributes"),
+ words("in attribute list:"), nl,
+ words(MutAttrsStr), suffix("."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(MutAttrsTerm),
+ [always(Pieces)])]),
+ MutAttrsResult = error1([Spec])
;
list.foldl(process_mutable_attribute, CollectedMutAttrs,
Attributes0, Attributes),
MutAttrsResult = ok1(Attributes)
)
;
- Msg = "malformed attribute list in mutable declaration",
- MutAttrsResult = error1([Msg - MutAttrsTerm])
+ MutAttrsStr = mercury_term_to_string(VarSet, no, MutAttrsTerm),
+ Pieces = [words("Error: malformed attribute list"),
+ words("in mutable declaration:"),
+ words(MutAttrsStr), suffix("."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(MutAttrsTerm), [always(Pieces)])]),
+ MutAttrsResult = error1([Spec])
).
:- pred process_mutable_attribute(collected_mutable_attribute::in,
@@ -2049,8 +2145,11 @@
MutAttr = mutable_attr_foreign_name(foreign_name(Lang, ForeignName)),
MutAttrResult = ok1(MutAttr)
;
- Msg = "unrecognised attribute in mutable declaration",
- MutAttrResult = error1([Msg - MutAttrTerm])
+ Pieces = [words("Error: unrecognised attribute"),
+ words("in mutable declaration."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(MutAttrTerm), [always(Pieces)])]),
+ MutAttrResult = error1([Spec])
).
%-----------------------------------------------------------------------------%
@@ -2071,15 +2170,15 @@
% - `equality is <<pred name>>' (optional)
% - `comparison is <<pred name>>' (optional).
%
-parse_type_decl_where_part_if_present(IsSolverType, ModuleName, Term0, Term,
- Result) :-
+parse_type_decl_where_part_if_present(IsSolverType, ModuleName, VarSet,
+ Term0, Term, Result) :-
(
Term0 = term.functor(term.atom("where"), Args0, _Context),
Args0 = [Term1, WhereTerm]
->
Term = Term1,
Result = parse_type_decl_where_term(IsSolverType, ModuleName,
- yes(WhereTerm))
+ VarSet, yes(WhereTerm))
;
Term = Term0,
Result = ok2(no, no)
@@ -2089,10 +2188,10 @@
% of results. Either result half may be empty, hence the maybe
% wrapper around each of those.
%
-:- func parse_type_decl_where_term(is_solver_type, module_name, maybe(term)) =
- maybe2(maybe(solver_type_details), maybe(unify_compare)).
+:- func parse_type_decl_where_term(is_solver_type, module_name, varset,
+ maybe(term)) = maybe2(maybe(solver_type_details), maybe(unify_compare)).
-parse_type_decl_where_term(IsSolverType, ModuleName, MaybeTerm0) =
+parse_type_decl_where_term(IsSolverType, ModuleName, VarSet, MaybeTerm0) =
MaybeWhereDetails :-
(
MaybeTerm0 = no,
@@ -2104,9 +2203,10 @@
parse_where_attribute(parse_where_type_is_abstract_noncanonical,
TypeIsAbstractNoncanonicalResult, !MaybeTerm),
parse_where_attribute(parse_where_is("representation",
- parse_where_type_is(ModuleName)),
+ parse_where_type_is(ModuleName, VarSet)),
RepresentationIsResult, !MaybeTerm),
- parse_where_attribute(parse_where_initialisation_is(ModuleName),
+ parse_where_attribute(parse_where_initialisation_is(ModuleName,
+ VarSet),
InitialisationIsResult, !MaybeTerm),
parse_where_attribute(parse_where_is("ground",
parse_where_inst_is(ModuleName)),
@@ -2118,10 +2218,10 @@
parse_where_mutable_is(ModuleName)),
CStoreIsResult, !MaybeTerm),
parse_where_attribute(parse_where_is("equality",
- parse_where_pred_is(ModuleName)),
+ parse_where_pred_is(ModuleName, VarSet)),
EqualityIsResult, !MaybeTerm),
parse_where_attribute(parse_where_is("comparison",
- parse_where_pred_is(ModuleName)),
+ parse_where_pred_is(ModuleName, VarSet)),
ComparisonIsResult, !MaybeTerm),
parse_where_end(!.MaybeTerm, WhereEndResult)
),
@@ -2187,21 +2287,24 @@
maybe1(maybe(T)).
parse_where_is(Name, Parser, Term) = Result :-
- ( Term = term.functor(term.atom("is"), [LHS, RHS], _Context1) ->
- ( LHS = term.functor(term.atom(Name), [], _Context2) ->
+ ( Term = term.functor(term.atom("is"), [LHS, RHS], _) ->
+ ( LHS = term.functor(term.atom(Name), [], _) ->
RHSResult = Parser(RHS),
(
RHSResult = ok1(ParsedRHS),
Result = ok1(yes(ParsedRHS))
;
- RHSResult = error1(Errors),
- Result = error1(Errors)
+ RHSResult = error1(Specs),
+ Result = error1(Specs)
)
;
Result = ok1(no)
)
;
- Result = error1(["expected is/2" - Term])
+ Pieces = [words("Error: expected"), quote("is"), suffix("."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(Term), [always(Pieces)])]),
+ Result = error1([Spec])
).
:- func parse_where_type_is_abstract_noncanonical(term) = maybe1(maybe(unit)).
@@ -2216,17 +2319,18 @@
ok1(no)
).
-:- func parse_where_initialisation_is(module_name, term) =
+:- func parse_where_initialisation_is(module_name, varset, term) =
maybe1(maybe(sym_name)).
-parse_where_initialisation_is(ModuleName, Term) = Result :-
- Result0 = parse_where_is("initialisation", parse_where_pred_is(ModuleName),
+parse_where_initialisation_is(ModuleName, VarSet, Term) = Result :-
+ Result0 = parse_where_is("initialisation",
+ parse_where_pred_is(ModuleName, VarSet),
Term),
(
Result0 = ok1(no)
->
Result1 = parse_where_is("initialization",
- parse_where_pred_is(ModuleName), Term)
+ parse_where_pred_is(ModuleName, VarSet), Term)
;
Result1 = Result0
),
@@ -2240,8 +2344,11 @@
Result = Result1
;
AutoInitSupported = no,
- Msg = "unknown attribute in solver type definition",
- Result = error1([Msg - Term])
+ Pieces = [words("Error: unknown attribute"),
+ words("in solver type definition."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(Term), [always(Pieces)])]),
+ Result = error1([Spec])
)
;
( Result1 = ok1(no)
@@ -2251,27 +2358,32 @@
)
).
-:- func parse_where_pred_is(module_name, term) = maybe1(sym_name).
+:- func parse_where_pred_is(module_name, varset, term) = maybe1(sym_name).
-parse_where_pred_is(ModuleName, Term) = Result :-
- parse_implicitly_qualified_symbol_name(ModuleName, Term, Result).
+parse_where_pred_is(ModuleName, VarSet, Term) = Result :-
+ parse_implicitly_qualified_symbol_name(ModuleName, VarSet, Term, Result).
:- func parse_where_inst_is(module_name, term) = maybe1(mer_inst).
-parse_where_inst_is(_ModuleName, Term) =
+parse_where_inst_is(_ModuleName, Term) = Result :-
(
prog_io_util.convert_inst(no_allow_constrained_inst_var, Term, Inst),
not prog_mode.inst_contains_unconstrained_var(Inst)
->
- ok1(Inst)
+ Result = ok1(Inst)
;
- error1(["expected a ground, unconstrained inst" - Term])
+ Pieces = [words("Error: expected a ground, unconstrained inst."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(Term), [always(Pieces)])]),
+ Result = error1([Spec])
).
-:- func parse_where_type_is(module_name, term) = maybe1(mer_type).
+:- func parse_where_type_is(module_name, varset, term) = maybe1(mer_type).
-parse_where_type_is(_ModuleName, Term) = Result :-
- prog_io_util.parse_type(Term, Result).
+parse_where_type_is(_ModuleName, VarSet, Term) = Result :-
+ % XXX We should pass meaningful ContextPieces.
+ ContextPieces = [],
+ parse_type(Term, VarSet, ContextPieces, Result).
:- func parse_where_mutable_is(module_name, term) = maybe1(list(item)).
@@ -2282,15 +2394,17 @@
Result0 = ok1(Mutable),
Result = ok1([Mutable])
;
- Result0 = error1(Errors),
- Result = error1(Errors)
+ Result0 = error1(Specs),
+ Result = error1(Specs)
)
; list_term_to_term_list(Term, Terms) ->
map_parser(parse_mutable_decl_term(ModuleName), Terms, Result)
;
- Msg = "expected a mutable declaration or a list of " ++
- "mutable declarations",
- Result = error1([Msg - Term])
+ Pieces = [words("Error: expected a mutable declaration"),
+ words("or a list of mutable declarations."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(Term), [always(Pieces)])]),
+ Result = error1([Spec])
).
:- pred parse_mutable_decl_term(module_name::in, term::in, maybe1(item)::out)
@@ -2304,15 +2418,21 @@
->
Result = Result0
;
- Result = error1(["expected a mutable declaration" - Term])
+ Pieces = [words("Error: expected a mutable declaration."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(Term), [always(Pieces)])]),
+ Result = error1([Spec])
+
).
:- pred parse_where_end(maybe(term)::in, maybe1(maybe(unit))::out) is det.
parse_where_end(no, ok1(yes(unit))).
-parse_where_end(yes(Term), error1([Msg - Term])) :-
- Msg = "attributes are either badly ordered or " ++
- "contain an unrecognised attribute".
+parse_where_end(yes(Term), error1([Spec])) :-
+ Pieces = [words("Error: attributes are either badly ordered"),
+ words("or contain an unrecognised attribute."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(Term), [always(Pieces)])]).
:- func make_maybe_where_details(is_solver_type, maybe1(maybe(unit)),
maybe1(maybe(mer_type)), maybe1(maybe(init_pred)),
@@ -2343,21 +2463,21 @@
GroundIs, AnyIs, CStoreIs, EqualityIs, ComparisonIs,
WhereEnd, WhereTerm)
;
- TypeIsAbstractNoncanonicalErrors =
+ TypeIsAbstractNoncanonicalSpecs =
get_any_errors1(TypeIsAbstractNoncanonicalResult),
- RepresentationIsErrors = get_any_errors1(RepresentationIsResult),
- InitialisationIsErrors = get_any_errors1(InitialisationIsResult),
- GroundIsErrors = get_any_errors1(GroundIsResult),
- AnyIsErrors = get_any_errors1(AnyIsResult),
- CStoreIsErrors = get_any_errors1(CStoreIsResult),
- EqualityIsErrors = get_any_errors1(EqualityIsResult),
- ComparisonIsErrors = get_any_errors1(ComparisonIsResult),
- WhereEndErrors = get_any_errors1(WhereEndResult),
- Errors = TypeIsAbstractNoncanonicalErrors ++ RepresentationIsErrors ++
- InitialisationIsErrors ++ GroundIsErrors ++ AnyIsErrors ++
- CStoreIsErrors ++ EqualityIsErrors ++ ComparisonIsErrors ++
- WhereEndErrors,
- Result = error2(Errors)
+ RepresentationIsSpecs = get_any_errors1(RepresentationIsResult),
+ InitialisationIsSpecs = get_any_errors1(InitialisationIsResult),
+ GroundIsSpecs = get_any_errors1(GroundIsResult),
+ AnyIsSpecs = get_any_errors1(AnyIsResult),
+ CStoreIsSpecs = get_any_errors1(CStoreIsResult),
+ EqualityIsSpecs = get_any_errors1(EqualityIsResult),
+ ComparisonIsSpecs = get_any_errors1(ComparisonIsResult),
+ WhereEndSpecs = get_any_errors1(WhereEndResult),
+ Specs = TypeIsAbstractNoncanonicalSpecs ++ RepresentationIsSpecs ++
+ InitialisationIsSpecs ++ GroundIsSpecs ++ AnyIsSpecs ++
+ CStoreIsSpecs ++ EqualityIsSpecs ++ ComparisonIsSpecs ++
+ WhereEndSpecs,
+ Result = error2(Specs)
).
:- func make_maybe_where_details_2(is_solver_type, maybe(unit),
@@ -2384,9 +2504,13 @@
->
Result = ok2(no, yes(abstract_noncanonical_type(IsSolverType)))
;
- Msg = "`where type_is_abstract_noncanonical' "
- ++ " excludes other `where ...' attributes",
- Result = error2([Msg - WhereTerm])
+ Pieces = [words("Error:"),
+ quote("where type_is_abstract_noncanonical"),
+ words("excludes other"), quote("where ..."),
+ words("attributes."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(WhereTerm), [always(Pieces)])]),
+ Result = error2([Spec])
)
;
TypeIsAbstractNoncanonical = maybe.no,
@@ -2442,9 +2566,12 @@
;
RepresentationIs = no
->
- Msg = "solver type definitions must have a" ++
- "`representation' attribute",
- Result = error2([Msg - WhereTerm])
+ Pieces = [words("Error: solver type definitions must have a"),
+ quote("representation"), words("attribute."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(WhereTerm),
+ [always(Pieces)])]),
+ Result = error2([Spec])
;
unexpected(this_file, "make_maybe_where_details_2: " ++
"shouldn't have reached this point! (1)")
@@ -2459,8 +2586,12 @@
; CStoreIs = yes(_)
)
->
- Msg = "solver type attribute given for non-solver type",
- Result = error2([Msg - WhereTerm])
+ Pieces = [words("Error: solver type attribute given"),
+ words("for non-solver type."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(WhereTerm),
+ [always(Pieces)])]),
+ Result = error2([Spec])
;
EqualityIs = MaybeEqPred,
ComparisonIs = MaybeCmpPred,
@@ -2469,32 +2600,39 @@
)
).
- % get_determinism(Term0, Term, Determinism) binds Determinism
- % to a representation of the determinism condition of Term0, if any,
- % and binds Term to the other part of Term0. If Term0 does not
- % contain a determinism, then Determinism is bound to `unspecified'.
+ % get_determinism(VarSet, BodyTerm0, BodyTerm, MaybeMaybeDeterminism) binds
+ % MaybeMaybeDeterminism to ok1(yes()) wrapped around the determinism
+ % of BodyTerm0, if any, and binds BodyTerm to the other part of BodyTerm0.
+ % If BodyTerm0 does not contain a determinism, then MaybeMaybeDeterminism
+ % is bound to ok1(no).
%
-:- pred get_determinism(term::in, term::out, maybe1(maybe(determinism))::out)
- is det.
+:- pred get_determinism(varset::in, term::in, term::out,
+ maybe1(maybe(determinism))::out) is det.
-get_determinism(Body0, Body, Determinism) :-
+get_determinism(VarSet, BodyTerm0, BodyTerm, MaybeMaybeDeterminism) :-
(
- Body0 = term.functor(term.atom("is"), Args, _Context1),
- Args = [Body1, Determinism1]
+ BodyTerm0 = term.functor(term.atom("is"), Args, _),
+ Args = [BodyTerm1, DeterminismTerm]
->
- Body = Body1,
+ BodyTerm = BodyTerm1,
(
- Determinism1 = term.functor(term.atom(Determinism2), [],
- _Context2),
- standard_det(Determinism2, Determinism3)
+ DeterminismTerm = term.functor(term.atom(DeterminismFunctor),
+ [], _),
+ standard_det(DeterminismFunctor, Determinism)
->
- Determinism = ok1(yes(Determinism3))
+ MaybeMaybeDeterminism = ok1(yes(Determinism))
;
- Determinism = error1(["invalid category" - Determinism1])
+ BodyTermStr = describe_error_term(VarSet, BodyTerm),
+ Pieces = [words("Error: invalid determinism category"),
+ words(BodyTermStr), suffix("."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(DeterminismTerm),
+ [always(Pieces)])]),
+ MaybeMaybeDeterminism = error1([Spec])
)
;
- Body = Body0,
- Determinism = ok1(no)
+ BodyTerm = BodyTerm0,
+ MaybeMaybeDeterminism = ok1(no)
).
% Process the `with_inst` part of a declaration of the form:
@@ -2503,44 +2641,51 @@
:- pred get_with_inst(term::in, term::out, maybe1(maybe(mer_inst))::out)
is det.
-get_with_inst(Body0, Body, WithInst) :-
+get_with_inst(BodyTerm0, BodyTerm, WithInst) :-
(
- Body0 = term.functor(term.atom("with_inst"), [Body1, Inst1], _)
+ BodyTerm0 = term.functor(term.atom("with_inst"),
+ [BodyTerm1, InstTerm], _)
->
- ( convert_inst(allow_constrained_inst_var, Inst1, Inst) ->
+ ( convert_inst(allow_constrained_inst_var, InstTerm, Inst) ->
WithInst = ok1(yes(Inst))
;
- WithInst = error1(["invalid inst in `with_inst`" - Body0])
+ Pieces = [words("Error: invalid inst in"), quote("with_inst"),
+ suffix("."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(BodyTerm0), [always(Pieces)])]),
+ WithInst = error1([Spec])
),
- Body = Body1
+ BodyTerm = BodyTerm1
;
- Body = Body0,
+ BodyTerm = BodyTerm0,
WithInst = ok1(no)
).
-:- pred get_with_type(term::in, term::out, maybe1(maybe(mer_type))::out)
- is det.
+:- pred get_with_type(varset::in, term::in, term::out,
+ maybe1(maybe(mer_type))::out) is det.
-get_with_type(Body0, Body, Result) :-
+get_with_type(VarSet, BodyTerm0, BodyTerm, Result) :-
(
- Body0 = term.functor(TypeQualifier, [Body1, Type1], _),
+ BodyTerm0 = term.functor(TypeQualifier, [BodyTerm1, TypeTerm1], _),
(
TypeQualifier = term.atom("with_type")
;
TypeQualifier = term.atom(":")
)
->
- Body = Body1,
- parse_type(Type1, Result0),
+ BodyTerm = BodyTerm1,
+ % XXX Should supply more correct ContextPieces.
+ ContextPieces = [],
+ parse_type(TypeTerm1, VarSet, ContextPieces, Result0),
(
Result0 = ok1(Type),
Result = ok1(yes(Type))
;
- Result0 = error1(Errors),
- Result = error1(Errors)
+ Result0 = error1(Specs),
+ Result = error1(Specs)
)
;
- Body = Body0,
+ BodyTerm = BodyTerm0,
Result = ok1(no)
).
@@ -2588,18 +2733,18 @@
%-----------------------------------------------------------------------------%
-:- pred process_solver_type(module_name::in, term::in,
+:- pred process_solver_type(module_name::in, varset::in, term::in,
maybe(solver_type_details)::in, maybe(unify_compare)::in,
maybe1(processed_type_body)::out) is det.
-process_solver_type(ModuleName, Head, MaybeSolverTypeDetails, MaybeUserEqComp,
- Result) :-
+process_solver_type(ModuleName, VarSet, HeadTerm,
+ MaybeSolverTypeDetails, MaybeUserEqComp, Result) :-
(
MaybeSolverTypeDetails = yes(SolverTypeDetails),
- parse_type_defn_head(ModuleName, Head, Result0),
+ parse_type_defn_head(ModuleName, VarSet, HeadTerm, Result0),
(
- Result0 = error2(Errors),
- Result = error1(Errors)
+ Result0 = error2(Specs),
+ Result = error1(Specs)
;
Result0 = ok2(Name, Params),
(
@@ -2607,8 +2752,14 @@
type_contains_var(RepnType, Var),
not list.member(Var, Params)
->
- Msg = "free type variable in representation type",
- Result = error1([Msg - Head])
+ HeadTermStr = describe_error_term(VarSet, HeadTerm),
+ Pieces = [words("Error: free type variable"),
+ words("in representation type:"),
+ words(HeadTermStr), suffix("."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(HeadTerm),
+ [always(Pieces)])]),
+ Result = error1([Spec])
;
Result = ok1(processed_type_body(Name, Params,
parse_tree_solver_type(SolverTypeDetails,
@@ -2617,48 +2768,58 @@
)
;
MaybeSolverTypeDetails = no,
- Result = error1(["solver type with no solver_type_details" - Head])
+ Pieces = [words("Solver type with no solver_type_details."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(HeadTerm), [always(Pieces)])]),
+ Result = error1([Spec])
).
%-----------------------------------------------------------------------------%
% This is for "Head == Body" (equivalence) definitions.
%
-:- pred process_eqv_type(module_name::in, term::in, term::in,
+:- pred process_eqv_type(module_name::in, varset::in, term::in, term::in,
maybe1(processed_type_body)::out) is det.
-process_eqv_type(ModuleName, Head, Body, Result) :-
- parse_type_defn_head(ModuleName, Head, Result0),
- process_eqv_type_2(Result0, Body, Result).
+process_eqv_type(ModuleName, VarSet, HeadTerm, BodyTerm, Result) :-
+ parse_type_defn_head(ModuleName, VarSet, HeadTerm, Result0),
+ process_eqv_type_2(Result0, VarSet, BodyTerm, Result).
-:- pred process_eqv_type_2(maybe2(sym_name, list(type_param))::in, term::in,
- maybe1(processed_type_body)::out) is det.
+:- pred process_eqv_type_2(maybe2(sym_name, list(type_param))::in,
+ varset::in, term::in, maybe1(processed_type_body)::out) is det.
-process_eqv_type_2(error2(Errors), _, error1(Errors)).
-process_eqv_type_2(ok2(Name, Params), Body0, Result) :-
+process_eqv_type_2(error2(Specs), _, _, error1(Specs)).
+process_eqv_type_2(ok2(Name, Params), VarSet, BodyTerm0, Result) :-
% Check that all the variables in the body occur in the head.
(
- term.contains_var(Body0, Var),
+ term.contains_var(BodyTerm0, Var),
term.coerce_var(Var, TVar),
\+ list.member(TVar, Params)
->
- Msg = "free type parameter in RHS of type definition",
- Result = error1([Msg - Body0])
- ;
- parse_type(Body0, BodyResult),
+ BodyTerm0Str = describe_error_term(VarSet, BodyTerm0),
+ Pieces = [words("Error: free type parameter"),
+ words("in RHS of type definition:"),
+ words(BodyTerm0Str), suffix("."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(BodyTerm0), [always(Pieces)])]),
+ Result = error1([Spec])
+ ;
+ % XXX Should pass more correct ContextPieces.
+ ContextPieces = [],
+ parse_type(BodyTerm0, VarSet, ContextPieces, BodyResult),
(
- BodyResult = ok1(Body),
+ BodyResult = ok1(BodyTerm),
Result = ok1(processed_type_body(Name, Params,
- parse_tree_eqv_type(Body)))
+ parse_tree_eqv_type(BodyTerm)))
;
- BodyResult = error1(Errors),
- Result = error1(Errors)
+ BodyResult = error1(Specs),
+ Result = error1(Specs)
)
).
%-----------------------------------------------------------------------------%
- % process_du_type(ModuleName, TypeHead, TypeBody,
+ % process_du_type(ModuleName, HeadTerm, BodyTerm, Ctors,
% MaybeUserEqComp, Result):
%
% Checks that its arguments are well formed, and if they are,
@@ -2666,90 +2827,144 @@
% TypeHead.
% This is for "Head ---> Body [where ...]" (constructor) definitions.
%
-:- pred process_du_type(module_name::in, term::in, term::in,
+:- pred process_du_type(module_name::in, varset::in, term::in, term::in,
list(constructor)::in, maybe(unify_compare)::in,
maybe1(processed_type_body)::out) is det.
-process_du_type(ModuleName, Head, Body, Ctors, MaybeUserEqComp, Result) :-
- parse_type_defn_head(ModuleName, Head, Result0),
+process_du_type(ModuleName, VarSet, HeadTerm, BodyTerm, Ctors, MaybeUserEqComp,
+ Result) :-
+ parse_type_defn_head(ModuleName, VarSet, HeadTerm, Result0),
(
- Result0 = error2(Errors),
- Result = error1(Errors)
+ Result0 = error2(Specs),
+ Result = error1(Specs)
;
Result0 = ok2(Functor, Params),
- process_du_type_2(Functor, Params, Body, Ctors, MaybeUserEqComp,
- Result)
- ).
-
-:- pred process_du_type_2(sym_name::in, list(type_param)::in, term::in,
- list(constructor)::in, maybe(unify_compare)::in,
- maybe1(processed_type_body)::out) is det.
-
-process_du_type_2(Functor, Params, Body, Ctors, MaybeUserEqComp, Result) :-
- process_du_ctors(Params, Ctors, CtorsResult),
+ process_du_ctors(Params, VarSet, BodyTerm, Ctors, [], Specs),
(
- CtorsResult = ok,
+ Specs = [],
TypeDefn = parse_tree_du_type(Ctors, MaybeUserEqComp),
ProcessedTypeBody = processed_type_body(Functor, Params, TypeDefn),
Result = ok1(ProcessedTypeBody)
;
- CtorsResult = error(Msg),
- Result = error1([Msg - Body])
+ Specs = [_ | _],
+ Result = error1(Specs)
+ )
).
-:- pred process_du_ctors(list(type_param)::in, list(constructor)::in,
- maybe_error::out) is det.
+:- pred process_du_ctors(list(type_param)::in, varset::in, term::in,
+ list(constructor)::in, list(error_spec)::in, list(error_spec)::out) is det.
-process_du_ctors(_Params, [], ok).
-process_du_ctors(Params, [Ctor | Ctors], Result) :-
- Ctor = ctor(ExistQVars, Constraints, _CtorName, CtorArgs, _Conetxt),
+process_du_ctors(_Params, _, _, [], !Specs).
+process_du_ctors(Params, VarSet, BodyTerm, [Ctor | Ctors], !Specs) :-
+ Ctor = ctor(ExistQVars, Constraints, _CtorName, CtorArgs, _Context),
(
% Check that all type variables in the ctor are either explicitly
% existentially quantified or occur in the head of the type.
- %
+
CtorArgTypes = list.map(func(C) = C ^ arg_type, CtorArgs),
- type_list_contains_var(CtorArgTypes, Var),
- \+ list.member(Var, ExistQVars),
- \+ list.member(Var, Params)
- ->
- Result = error("free type parameter in RHS of type definition")
+ type_vars_list(CtorArgTypes, VarsInCtorArgTypes0),
+ list.sort_and_remove_dups(VarsInCtorArgTypes0, VarsInCtorArgTypes),
+ list.filter(list.contains(ExistQVars ++ Params), VarsInCtorArgTypes,
+ _ExistQOrParamVars, NotExistQOrParamVars),
+ NotExistQOrParamVars = [_ | _]
+ ->
+ % There should be no duplicate names to remove.
+ varset.coerce(VarSet, GenericVarSet),
+ NotExistQOrParamVarsStr =
+ mercury_vars_to_string(GenericVarSet, no, NotExistQOrParamVars),
+ Pieces = [words("Error: free type"),
+ words(choose_number(NotExistQOrParamVars,
+ "parameter", "parameters")),
+ words(NotExistQOrParamVarsStr),
+ words("in RHS of type definition."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(BodyTerm), [always(Pieces)])]),
+ !:Specs = [Spec | !.Specs]
;
% Check that all type variables in existential quantifiers do not
% occur in the head (maybe this should just be a warning, not an error?
% If we were to allow it, we would need to rename them apart.)
- list.member(Var, ExistQVars),
- list.member(Var, Params)
- ->
- Result = error("type variable has overlapping scopes " ++
- "(explicit type quantifier shadows argument type)")
+ set.list_to_set(ExistQVars, ExistQVarsSet),
+ set.list_to_set(Params, ParamsSet),
+ set.intersect(ExistQVarsSet, ParamsSet, ExistQParamsSet),
+ set.non_empty(ExistQParamsSet)
+ ->
+ % There should be no duplicate names to remove.
+ set.to_sorted_list(ExistQParamsSet, ExistQParams),
+ varset.coerce(VarSet, GenericVarSet),
+ ExistQParamVarsStr =
+ mercury_vars_to_string(GenericVarSet, no, ExistQParams),
+ Pieces = [words("Error:"),
+ words(choose_number(ExistQParams,
+ "type variable", "type variables")),
+ words(ExistQParamVarsStr),
+ words(choose_number(ExistQParams, "has", "have")),
+ words("overlapping scopes"),
+ words("(explicit type quantifier shadows argument type)."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(BodyTerm), [always(Pieces)])]),
+ !:Specs = [Spec | !.Specs]
;
% Check that all type variables in existential quantifiers occur
% somewhere in the constructor argument types or constraints.
- list.member(Var, ExistQVars),
CtorArgTypes = list.map(func(C) = C ^ arg_type, CtorArgs),
- \+ type_list_contains_var(CtorArgTypes, Var),
+ type_vars_list(CtorArgTypes, VarsInCtorArgTypes0),
+ list.sort_and_remove_dups(VarsInCtorArgTypes0, VarsInCtorArgTypes),
constraint_list_get_tvars(Constraints, ConstraintTVars),
- \+ list.member(Var, ConstraintTVars)
- ->
- Result = error("type variable in existential quantifier " ++
- "does not occur in arguments or constraints of constructor")
+ list.filter(list.contains(VarsInCtorArgTypes ++ ConstraintTVars),
+ ExistQVars, _OccursExistQVars, NotOccursExistQVars),
+ NotOccursExistQVars = [_ | _]
+ ->
+ % There should be no duplicate names to remove.
+ varset.coerce(VarSet, GenericVarSet),
+ NotOccursExistQVarsStr =
+ mercury_vars_to_string(GenericVarSet, no, NotOccursExistQVars),
+ Pieces = [words("Error:"),
+ words(choose_number(NotOccursExistQVars,
+ "type variable", "type variables")),
+ words(NotOccursExistQVarsStr),
+ words("in existential quantifier"),
+ words(choose_number(NotOccursExistQVars,
+ "does not occur", "do not occur")),
+ words("in arguments or constraints of constructor."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(BodyTerm), [always(Pieces)])]),
+ !:Specs = [Spec | !.Specs]
;
% Check that all type variables in existential constraints occur in
% the existential quantifiers.
- list.member(Constraint, Constraints),
- Constraint = constraint(_Name, ConstraintArgs),
- type_list_contains_var(ConstraintArgs, Var),
- \+ list.member(Var, ExistQVars)
- ->
- Result = error("type variables in class constraints introduced" ++
- " with `=>' must be explicitly existentially quantified" ++
- " using `some'")
+ ConstraintArgTypeLists =
+ list.map(prog_constraint_get_arg_types, Constraints),
+ list.condense(ConstraintArgTypeLists, ConstraintArgTypes),
+ type_vars_list(ConstraintArgTypes, VarsInCtorArgTypes0),
+ list.sort_and_remove_dups(VarsInCtorArgTypes0, VarsInCtorArgTypes),
+ list.filter(list.contains(ExistQVars), VarsInCtorArgTypes,
+ _ExistQArgTypes, NotExistQArgTypes),
+ NotExistQArgTypes = [_ | _]
+ ->
+ varset.coerce(VarSet, GenericVarSet),
+ NotExistQArgTypesStr =
+ mercury_vars_to_string(GenericVarSet, no, NotExistQArgTypes),
+ Pieces = [words("Error:"),
+ words(choose_number(NotExistQArgTypes,
+ "type variable", "type variables")),
+ words(NotExistQArgTypesStr),
+ words("in class constraints,"),
+ words(choose_number(NotExistQArgTypes,
+ "which was", "which were")),
+ words("introduced with"), quote("=>"),
+ words("must be explicitly existentially quantified"),
+ words("using"), quote("some"), suffix("."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(BodyTerm), [always(Pieces)])]),
+ !:Specs = [Spec | !.Specs]
;
- process_du_ctors(Params, Ctors, Result)
- ).
+ true
+ ),
+ process_du_ctors(Params, VarSet, BodyTerm, Ctors, !Specs).
%-----------------------------------------------------------------------------%
@@ -2758,11 +2973,11 @@
% Checks that its argument is well formed, and if it is, binds Result
% to a representation of the type information about the TypeHead.
%
-:- pred process_abstract_type(module_name::in, term::in, decl_attrs::in,
- maybe1(processed_type_body)::out) is det.
+:- pred process_abstract_type(module_name::in, varset::in, term::in,
+ decl_attrs::in, maybe1(processed_type_body)::out) is det.
-process_abstract_type(ModuleName, Head, Attributes0, Result) :-
- parse_type_defn_head(ModuleName, Head, Result0),
+process_abstract_type(ModuleName, VarSet, HeadTerm, Attributes0, Result) :-
+ parse_type_defn_head(ModuleName, VarSet, HeadTerm, Result0),
get_is_solver_type(IsSolverType, Attributes0, Attributes),
process_abstract_type_2(Result0, IsSolverType, Result1),
check_no_attributes(Result1, Attributes, Result).
@@ -2770,36 +2985,39 @@
:- pred process_abstract_type_2(maybe2(sym_name, list(type_param))::in,
is_solver_type::in, maybe1(processed_type_body)::out) is det.
-process_abstract_type_2(error2(Errors), _, error1(Errors)).
+process_abstract_type_2(error2(Specs), _, error1(Specs)).
process_abstract_type_2(ok2(Functor, Params), IsSolverType, Result) :-
Result = ok1(processed_type_body(Functor, Params,
parse_tree_abstract_type(IsSolverType))).
%-----------------------------------------------------------------------------%
-parse_type_defn_head(ModuleName, Head, Result) :-
+parse_type_defn_head(ModuleName, VarSet, HeadTerm, Result) :-
(
- Head = term.variable(_, Context),
- dummy_term_with_context(Context, ErrorTerm),
- Result = error2(["variable on LHS of type definition" - ErrorTerm])
- ;
- Head = term.functor(_, _, _),
- parse_implicitly_qualified_term(ModuleName, Head, Head,
- "type definition", Headresult),
- parse_type_defn_head_2(Headresult, Head, Result)
+ HeadTerm = term.variable(_, Context),
+ Pieces = [words("Error: variable on LHS of type definition."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(Context, [always(Pieces)])]),
+ Result = error2([Spec])
+ ;
+ HeadTerm = term.functor(_, _, _),
+ ContextPieces = [words("In type definition:")],
+ parse_implicitly_qualified_term(ModuleName, HeadTerm, HeadTerm,
+ VarSet, ContextPieces, Headresult),
+ parse_type_defn_head_2(Headresult, VarSet, HeadTerm, Result)
).
-:- pred parse_type_defn_head_2(maybe_functor::in, term::in,
+:- pred parse_type_defn_head_2(maybe_functor::in, varset::in, term::in,
maybe2(sym_name, list(tvar))::out) is det.
-parse_type_defn_head_2(error2(Errors), _, error2(Errors)).
-parse_type_defn_head_2(ok2(Name, Args), Head, Result) :-
- parse_type_defn_head_3(Name, Args, Head, Result).
+parse_type_defn_head_2(error2(Specs), _, _, error2(Specs)).
+parse_type_defn_head_2(ok2(Name, Args), VarSet, HeadTerm, Result) :-
+ parse_type_defn_head_3(Name, Args, VarSet, HeadTerm, Result).
-:- pred parse_type_defn_head_3(sym_name::in, list(term)::in, term::in,
- maybe2(sym_name, list(tvar))::out) is det.
+:- pred parse_type_defn_head_3(sym_name::in, list(term)::in, varset::in,
+ term::in, maybe2(sym_name, list(tvar))::out) is det.
-parse_type_defn_head_3(Name, Args, Head, Result) :-
+parse_type_defn_head_3(Name, Args, VarSet, HeadTerm, Result) :-
% Check that all the head args are variables.
( term_list_to_var_list(Args, Params0) ->
% Check that all the head arg variables are distinct.
@@ -2807,14 +3025,22 @@
list.member(_, Params0, [Param | OtherParams]),
list.member(Param, OtherParams)
->
- Msg = "repeated type parameters in LHS of type defn",
- Result = error2([Msg - Head])
+ Pieces = [words("Error: repeated type parameters"),
+ words("in LHS of type definition."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(HeadTerm), [always(Pieces)])]),
+ Result = error2([Spec])
;
list.map(term.coerce_var, Params0, Params),
Result = ok2(Name, Params)
)
;
- Result = error2(["type parameters must be variables" - Head])
+ HeadTermStr = describe_error_term(VarSet, HeadTerm),
+ Pieces = [words("Error: type parameters must be variables:"),
+ words(HeadTermStr), suffix(".") ,nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(HeadTerm), [always(Pieces)])]),
+ Result = error2([Spec])
).
%-----------------------------------------------------------------------------%
@@ -2823,59 +3049,67 @@
% "disjunction", even thought the terms aren't goals in this case)
% into a list of constructors.
%
-:- func convert_constructors(module_name, term) = maybe1(list(constructor)).
+:- func convert_constructors(module_name, varset, term) =
+ maybe1(list(constructor)).
-convert_constructors(ModuleName, Body) = Result :-
- disjunction_to_list(Body, List),
- Result = convert_constructors_2(ModuleName, List).
+convert_constructors(ModuleName, VarSet, BodyTerm) = Result :-
+ disjunction_to_list(BodyTerm, BodyTermList),
+ Result = convert_constructors_2(ModuleName, VarSet, BodyTermList).
% True if input argument is a valid list of constructors.
%
-:- func convert_constructors_2(module_name, list(term)) =
+:- func convert_constructors_2(module_name, varset, list(term)) =
maybe1(list(constructor)).
-convert_constructors_2(_ModuleName, []) = ok1([]).
-convert_constructors_2( ModuleName, [Term | Terms]) = Result :-
- Result0 = convert_constructor(ModuleName, Term),
+convert_constructors_2(_ModuleName, _, []) = ok1([]).
+convert_constructors_2(ModuleName, VarSet, [Term | Terms]) = Result :-
+ Result0 = convert_constructor(ModuleName, VarSet, Term),
(
- Result0 = error1(Errors),
- Result = error1(Errors)
+ Result0 = error1(Specs),
+ Result = error1(Specs)
;
Result0 = ok1(Constructor),
- Result1 = convert_constructors_2(ModuleName, Terms),
+ Result1 = convert_constructors_2(ModuleName, VarSet, Terms),
(
- Result1 = error1(Errors),
- Result = error1(Errors)
+ Result1 = error1(Specs),
+ Result = error1(Specs)
;
Result1 = ok1(Constructors),
Result = ok1([Constructor | Constructors])
)
).
-:- func convert_constructor(module_name, term) = maybe1(constructor).
+:- func convert_constructor(module_name, varset, term) = maybe1(constructor).
-convert_constructor(ModuleName, Term0) = Result :-
+convert_constructor(ModuleName, VarSet, Term0) = Result :-
( Term0 = term.functor(term.atom("some"), [Vars, Term1], _Context) ->
( parse_list_of_vars(Vars, ExistQVars0) ->
list.map(term.coerce_var, ExistQVars0, ExistQVars),
- Result = convert_constructor_2(ModuleName, ExistQVars,
+ Result = convert_constructor_2(ModuleName, VarSet, ExistQVars,
Term0, Term1)
;
- Result = error1(["syntax error in variable list" - Term0])
+ Term0Str = describe_error_term(VarSet, Term0),
+ Pieces = [words("Error: syntax error in variable list at"),
+ words(Term0Str), suffix("."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(Term0), [always(Pieces)])]),
+ Result = error1([Spec])
)
;
ExistQVars = [],
- Result = convert_constructor_2(ModuleName, ExistQVars, Term0, Term0)
+ Result = convert_constructor_2(ModuleName, VarSet, ExistQVars,
+ Term0, Term0)
).
-:- func convert_constructor_2(module_name, list(tvar), term, term) =
+:- func convert_constructor_2(module_name, varset, list(tvar), term, term) =
maybe1(constructor).
-convert_constructor_2(ModuleName, ExistQVars, Term0, Term1) = Result :-
- get_existential_constraints_from_term(ModuleName, Term1, Term2, Result0),
+convert_constructor_2(ModuleName, VarSet, ExistQVars, Term0, Term1) = Result :-
+ get_existential_constraints_from_term(ModuleName, VarSet, Term1, Term2,
+ Result0),
(
- Result0 = error1(Errors),
- Result = error1(Errors)
+ Result0 = error1(Specs),
+ Result = error1(Specs)
;
Result0 = ok1(Constraints),
(
@@ -2888,38 +3122,34 @@
;
Term4 = Term2
),
- Result = convert_constructor_3(ModuleName, ExistQVars, Constraints,
- Term0, Term4)
+ Result = convert_constructor_3(ModuleName, VarSet, ExistQVars,
+ Constraints, Term0, Term4)
).
-:- func convert_constructor_3(module_name, list(tvar), list(prog_constraint),
- term, term) = maybe1(constructor).
+:- func convert_constructor_3(module_name, varset, list(tvar),
+ list(prog_constraint), term, term) = maybe1(constructor).
-convert_constructor_3(ModuleName, ExistQVars, Constraints, Term0, Term1) =
- Result :-
- parse_implicitly_qualified_term(ModuleName, Term1, Term0,
- "constructor definition", Result0),
+convert_constructor_3(ModuleName, VarSet, ExistQVars, Constraints,
+ Term0, Term1) = Result :-
+ ContextPieces = [words("In constructor definition:")],
+ parse_implicitly_qualified_term(ModuleName, Term1, Term0, VarSet,
+ ContextPieces, Result0),
(
- Result0 = error2(Errors),
- Result = error1(Errors)
+ Result0 = error2(Specs),
+ Result = error1(Specs)
;
- Result0 = ok2(F, As),
- Result1 = convert_constructor_arg_list(ModuleName, As),
+ Result0 = ok2(Functor, ArgTerms),
+ Result1 = convert_constructor_arg_list(ModuleName, VarSet, ArgTerms),
(
- Result1 = error1(Errors),
- Result = error1(Errors)
+ Result1 = error1(Specs),
+ Result = error1(Specs)
;
Result1 = ok1(Args),
- Ctxt = term_context(Term1),
- Result = ok1(ctor(ExistQVars, Constraints, F, Args, Ctxt))
+ Ctxt = get_term_context(Term1),
+ Result = ok1(ctor(ExistQVars, Constraints, Functor, Args, Ctxt))
)
).
-:- func term_context(term(T)) = prog_context.
-
-term_context(functor(_, _, C)) = C.
-term_context(variable(_, C)) = C.
-
%-----------------------------------------------------------------------------%
% parse a `:- pred p(...)' declaration or a
@@ -2932,18 +3162,20 @@
process_pred_decl(PredOrFunc, ModuleName, VarSet, PredType, Cond, WithType,
WithInst, MaybeDet, Attributes0, Context, Result) :-
- get_class_context_and_inst_constraints(ModuleName, Attributes0,
- Attributes, MaybeClassContext),
+ get_class_context_and_inst_constraints(ModuleName, VarSet,
+ Attributes0, Attributes, MaybeClassContext),
(
MaybeClassContext = ok3(ExistQVars, Constraints, InstConstraints),
+ ContextPieces = [words("In")] ++ pred_or_func_decl_pieces(PredOrFunc)
+ ++ [suffix(":")],
parse_implicitly_qualified_term(ModuleName, PredType, PredType,
- pred_or_func_decl_string(PredOrFunc), R),
- process_pred_decl_2(PredOrFunc, R, PredType, VarSet,
+ VarSet, ContextPieces, PredTypeResult),
+ process_pred_decl_2(PredOrFunc, PredTypeResult, PredType, VarSet,
WithType, WithInst, MaybeDet, Cond, ExistQVars,
Constraints, InstConstraints, Attributes, Context, Result)
;
- MaybeClassContext = error3(Errors),
- Result = error1(Errors)
+ MaybeClassContext = error3(Specs),
+ Result = error1(Specs)
).
:- pred process_pred_decl_2(pred_or_func::in, maybe_functor::in, term::in,
@@ -2952,9 +3184,9 @@
prog_constraints::in, inst_var_sub::in, decl_attrs::in, prog_context::in,
maybe1(item)::out) is det.
-process_pred_decl_2(_, error2(Errors), _, _, _, _, _, _, _, _, _, _, _,
- error1(Errors)).
-process_pred_decl_2(PredOrFunc, ok2(F, As0), PredType, VarSet0,
+process_pred_decl_2(_, error2(Specs), _, _, _, _, _, _, _, _, _, _, _,
+ error1(Specs)).
+process_pred_decl_2(PredOrFunc, ok2(F, As0), PredTypeTerm, VarSet,
WithType, WithInst, MaybeDet, Cond, ExistQVars,
ClassContext, InstConstraints, Attributes0, Context, Result) :-
( convert_type_and_mode_list(InstConstraints, As0, As) ->
@@ -2963,25 +3195,39 @@
WithInst = yes(_),
As = [type_only(_) | _]
->
- Msg = "`with_inst` specified without argument modes",
- Result = error1([Msg - PredType])
+ Pieces = [words("Error:"), quote("with_inst"),
+ words("specified without argument modes."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(PredTypeTerm),
+ [always(Pieces)])]),
+ Result = error1([Spec])
;
WithInst = no,
WithType = yes(_),
As = [type_and_mode(_, _) | _]
->
- Msg = "arguments have modes but `with_inst` not specified",
- Result = error1([Msg - PredType])
+ Pieces = [words("Error: arguments have modes but"),
+ quote("with_inst"), words("not specified."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(PredTypeTerm),
+ [always(Pieces)])]),
+ Result = error1([Spec])
;
\+ inst_var_constraints_are_consistent_in_type_and_modes(As)
->
- Msg = "inconsistent constraints on inst variables in " ++
- pred_or_func_decl_string(PredOrFunc),
- Result = error1([Msg - PredType])
+ PredTypeTermStr = describe_error_term(VarSet, PredTypeTerm),
+ Pieces = [words("Error: inconsistent constraints on"),
+ words("inst variables in")] ++
+ pred_or_func_decl_pieces(PredOrFunc) ++
+ [suffix(":"), nl, words(PredTypeTermStr), suffix("."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(PredTypeTerm),
+ [always(Pieces)])]),
+ Result = error1([Spec])
;
get_purity(Purity, Attributes0, Attributes),
- varset.coerce(VarSet0, TVarSet),
- varset.coerce(VarSet0, IVarSet),
+ varset.coerce(VarSet, TVarSet),
+ varset.coerce(VarSet, IVarSet),
Origin = user,
ItemPredDecl = item_pred_decl_info(Origin, TVarSet, IVarSet,
ExistQVars, PredOrFunc, F, As, WithType, WithInst,
@@ -2991,12 +3237,21 @@
check_no_attributes(Result0, Attributes, Result)
)
;
- Msg = "some but not all arguments have modes",
- Result = error1([Msg - PredType])
+ Pieces = [words("Error: some but not all arguments have modes."),
+ nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(PredTypeTerm),
+ [always(Pieces)])]),
+ Result = error1([Spec])
)
;
- Msg = "syntax error in " ++ pred_or_func_decl_string(PredOrFunc),
- Result = error1([Msg - PredType])
+ PredTypeTermStr = describe_error_term(VarSet, PredTypeTerm),
+ Pieces = [words("Error: syntax error in")] ++
+ pred_or_func_decl_pieces(PredOrFunc) ++
+ [words("at"), words(PredTypeTermStr), suffix("."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(PredTypeTerm), [always(Pieces)])]),
+ Result = error1([Spec])
).
:- pred get_purity(purity::out, decl_attrs::in, decl_attrs::out) is det.
@@ -3008,10 +3263,12 @@
Purity = purity_pure
).
-:- func pred_or_func_decl_string(pred_or_func) = string.
+:- func pred_or_func_decl_pieces(pred_or_func) = list(format_component).
-pred_or_func_decl_string(pf_function) = "`:- func' declaration".
-pred_or_func_decl_string(pf_predicate) = "`:- pred' declaration".
+pred_or_func_decl_pieces(pf_function) =
+ [quote(":- func"), words("declaration")].
+pred_or_func_decl_pieces(pf_predicate) =
+ [quote(":- pred"), words("declaration")].
%-----------------------------------------------------------------------------%
@@ -3030,11 +3287,11 @@
% error).
% Attributes is bound to the remaining attributes.
%
-:- pred get_class_context_and_inst_constraints(module_name::in,
+:- pred get_class_context_and_inst_constraints(module_name::in, varset::in,
decl_attrs::in, decl_attrs::out,
maybe3(existq_tvars, prog_constraints, inst_var_sub)::out) is det.
-get_class_context_and_inst_constraints(ModuleName, RevAttributes0,
+get_class_context_and_inst_constraints(ModuleName, VarSet, RevAttributes0,
RevAttributes, MaybeContext) :-
% Constraints and quantifiers should occur in the following order
% (outermost to innermost):
@@ -3074,9 +3331,9 @@
get_quant_vars(quant_type_exist, ModuleName, Attributes1, Attributes2,
[], ExistQVars0),
list.map(term.coerce_var, ExistQVars0, ExistQVars),
- get_constraints(quant_type_univ, ModuleName, Attributes2,
+ get_constraints(quant_type_univ, ModuleName, VarSet, Attributes2,
Attributes3, MaybeUnivConstraints),
- get_constraints(quant_type_exist, ModuleName, Attributes3,
+ get_constraints(quant_type_exist, ModuleName, VarSet, Attributes3,
Attributes, MaybeExistConstraints),
list.reverse(Attributes, RevAttributes),
@@ -3087,10 +3344,10 @@
maybe_class_and_inst_constraints::in, existq_tvars::in,
maybe3(existq_tvars, prog_constraints, inst_var_sub)::out) is det.
-combine_quantifier_results(error2(Errors1), error2(Errors2), _,
- error3(Errors1 ++ Errors2)).
-combine_quantifier_results(error2(Errors), ok2(_, _), _, error3(Errors)).
-combine_quantifier_results(ok2(_, _), error2(Errors), _, error3(Errors)).
+combine_quantifier_results(error2(Specs1), error2(Specs2), _,
+ error3(Specs1 ++ Specs2)).
+combine_quantifier_results(error2(Specs), ok2(_, _), _, error3(Specs)).
+combine_quantifier_results(ok2(_, _), error2(Specs), _, error3(Specs)).
combine_quantifier_results(ok2(UnivConstraints, InstConstraints0),
ok2(ExistConstraints, InstConstraints1), ExistQVars,
ok3(ExistQVars, constraints(UnivConstraints, ExistConstraints),
@@ -3110,20 +3367,23 @@
true
).
-:- pred get_constraints(quantifier_type::in, module_name::in, decl_attrs::in,
- decl_attrs::out, maybe_class_and_inst_constraints::out) is det.
+:- pred get_constraints(quantifier_type::in, module_name::in, varset::in,
+ decl_attrs::in, decl_attrs::out, maybe_class_and_inst_constraints::out)
+ is det.
-get_constraints(QuantType, ModuleName, !Attributes, MaybeConstraints) :-
+get_constraints(QuantType, ModuleName, VarSet, !Attributes,
+ MaybeConstraints) :-
(
!.Attributes = [
decl_attr_constraints(QuantType, ConstraintsTerm) - _Term
| !:Attributes]
->
- parse_class_and_inst_constraints(ModuleName, ConstraintsTerm,
+ parse_class_and_inst_constraints(ModuleName, VarSet, ConstraintsTerm,
MaybeConstraints0),
% there may be more constraints of the same type --
% collect them all and combine them
- get_constraints(QuantType, ModuleName, !Attributes, MaybeConstraints1),
+ get_constraints(QuantType, ModuleName, VarSet, !Attributes,
+ MaybeConstraints1),
combine_constraint_list_results(MaybeConstraints1,
MaybeConstraints0, MaybeConstraints)
;
@@ -3134,23 +3394,23 @@
maybe_class_and_inst_constraints::in,
maybe_class_and_inst_constraints::out) is det.
-combine_constraint_list_results(error2(Errors1), error2(Errors2),
- error2(Errors1 ++ Errors2)).
-combine_constraint_list_results(error2(Errors), ok2(_, _), error2(Errors)).
-combine_constraint_list_results(ok2(_, _), error2(Errors), error2(Errors)).
+combine_constraint_list_results(error2(Specs1), error2(Specs2),
+ error2(Specs1 ++ Specs2)).
+combine_constraint_list_results(error2(Specs), ok2(_, _), error2(Specs)).
+combine_constraint_list_results(ok2(_, _), error2(Specs), error2(Specs)).
combine_constraint_list_results(ok2(CC0, IC0), ok2(CC1, IC1),
ok2(CC0 ++ CC1, IC0 `map.old_merge` IC1)).
-:- pred get_existential_constraints_from_term(module_name::in,
+:- pred get_existential_constraints_from_term(module_name::in, varset::in,
term::in, term::out, maybe1(list(prog_constraint))::out) is det.
-get_existential_constraints_from_term(ModuleName, !PredType,
+get_existential_constraints_from_term(ModuleName, VarSet, !PredTypeTerm,
MaybeExistentialConstraints) :-
(
- !.PredType = term.functor(term.atom("=>"),
- [!:PredType, ExistentialConstraints], _)
+ !.PredTypeTerm = term.functor(term.atom("=>"),
+ [!:PredTypeTerm, ExistentialConstraints], _)
->
- parse_class_constraints(ModuleName, ExistentialConstraints,
+ parse_class_constraints(ModuleName, VarSet, ExistentialConstraints,
MaybeExistentialConstraints)
;
MaybeExistentialConstraints = ok1([])
@@ -3191,15 +3451,15 @@
process_func(ModuleName, VarSet, Term, Cond, MaybeDet, Attributes0,
Context, Result) :-
- get_class_context_and_inst_constraints(ModuleName, Attributes0,
- Attributes, MaybeContext),
+ get_class_context_and_inst_constraints(ModuleName, VarSet,
+ Attributes0, Attributes, MaybeContext),
(
MaybeContext = ok3(ExistQVars, Constraints, InstConstraints),
process_func_2(ModuleName, VarSet, Term, Cond, MaybeDet, ExistQVars,
Constraints, InstConstraints, Attributes, Context, Result)
;
- MaybeContext = error3(Errors),
- Result = error1(Errors)
+ MaybeContext = error3(Specs),
+ Result = error1(Specs)
).
:- pred process_func_2(module_name::in, varset::in, term::in, condition::in,
@@ -3214,13 +3474,18 @@
[FuncTerm0, ReturnTypeTerm], _Context),
FuncTerm = desugar_field_access(FuncTerm0)
->
+ ContextPieces = [words("In"), quote(":- func"), words("declaration")],
parse_implicitly_qualified_term(ModuleName, FuncTerm, Term,
- "`:- func' declaration", R),
- process_func_3(R, FuncTerm, ReturnTypeTerm, Term, VarSet, MaybeDet,
- Cond, ExistQVars, Constraints, InstConstraints, Attributes,
- Context, Result)
+ VarSet, ContextPieces, FuncTermResult),
+ process_func_3(FuncTermResult, FuncTerm, ReturnTypeTerm, Term, VarSet,
+ MaybeDet, Cond, ExistQVars, Constraints, InstConstraints,
+ Attributes, Context, Result)
;
- Result = error1(["`=' expected in `:- func' declaration" - Term])
+ Pieces = [words("Error:"), quote("="), words("expected in"),
+ quote(":- func"), words("declaration."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(Term), [always(Pieces)])]),
+ Result = error1([Spec])
).
:- pred process_func_3(maybe_functor::in, term::in, term::in, term::in,
@@ -3228,17 +3493,20 @@
prog_constraints::in, inst_var_sub::in, decl_attrs::in,
prog_context::in, maybe1(item)::out) is det.
-process_func_3(error2(Errors), _, _, _, _, _, _, _, _, _, _, _,
- error1(Errors)).
-process_func_3(ok2(F, As0), FuncTerm, ReturnTypeTerm, FullTerm, VarSet0,
+process_func_3(error2(Specs), _, _, _, _, _, _, _, _, _, _, _,
+ error1(Specs)).
+process_func_3(ok2(F, As0), FuncTerm, ReturnTypeTerm, FullTerm, VarSet,
MaybeDet, Cond, ExistQVars, ClassContext, InstConstraints,
Attributes0, Context, Result) :-
( convert_type_and_mode_list(InstConstraints, As0, As) ->
(
\+ verify_type_and_mode_list(As)
->
- Msg = "some but not all arguments have modes",
- Result = error1([Msg - FuncTerm])
+ Pieces = [words("Error: some but not all arguments have modes."),
+ nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(FuncTerm), [always(Pieces)])]),
+ Result = error1([Spec])
;
convert_type_and_mode(InstConstraints, ReturnTypeTerm, ReturnType)
->
@@ -3246,19 +3514,25 @@
As = [type_and_mode(_, _) | _],
ReturnType = type_only(_)
->
- Msg = "function arguments have modes, " ++
- "but function result doesn't",
- Result = error1([Msg - FuncTerm])
+ Pieces = [words("Error: function arguments have modes,"),
+ words("but function result does not."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(FuncTerm), [always(Pieces)])]),
+ Result = error1([Spec])
+
;
As = [type_only(_) | _],
ReturnType = type_and_mode(_, _)
->
- Msg = "function result has mode, but function arguments don't",
- Result = error1([Msg - FuncTerm])
+ Pieces = [words("Error: function result has mode,"),
+ words("but function arguments do not."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(FuncTerm), [always(Pieces)])]),
+ Result = error1([Spec])
;
get_purity(Purity, Attributes0, Attributes),
- varset.coerce(VarSet0, TVarSet),
- varset.coerce(VarSet0, IVarSet),
+ varset.coerce(VarSet, TVarSet),
+ varset.coerce(VarSet, IVarSet),
list.append(As, [ReturnType], Args),
(
inst_var_constraints_are_consistent_in_type_and_modes(Args)
@@ -3271,18 +3545,32 @@
Cond, Purity, ClassContext, Context),
check_no_attributes(Result0, Attributes, Result)
;
- Msg = "inconsistent constraints on inst variables " ++
- "in function declaration",
- Result = error1([Msg - FullTerm])
+ FullTermStr = describe_error_term(VarSet, FullTerm),
+ Pieces = [words("Error: inconsistent constraints"),
+ words("on inst variables in function declaration:"),
+ nl, words(FullTermStr), suffix("."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(FullTerm),
+ [always(Pieces)])]),
+ Result = error1([Spec])
)
)
;
- Msg = "syntax error in return type of `:- func' declaration",
- Result = error1([Msg - ReturnTypeTerm])
- )
- ;
- Msg = "syntax error in arguments of `:- func' declaration",
- Result = error1([Msg - FuncTerm])
+ Pieces = [words("Error: syntax error in return type of"),
+ quote(":- func"), words("declaration."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(ReturnTypeTerm),
+ [always(Pieces)])]),
+ Result = error1([Spec])
+ )
+ ;
+ FuncTermStr = describe_error_term(VarSet, FuncTerm),
+ Pieces = [words("Error: syntax error in arguments of"),
+ quote(":- func"), words("declaration at"),
+ words(FuncTermStr), suffix("."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(FuncTerm), [always(Pieces)])]),
+ Result = error1([Spec])
).
%-----------------------------------------------------------------------------%
@@ -3326,13 +3614,16 @@
_Context),
FuncTerm = desugar_field_access(FuncTerm0)
->
+ ContextPieces = [words("In function"), quote(":- mode"),
+ words("declaration")],
parse_implicitly_qualified_term(ModuleName, FuncTerm, Term,
- "function `:- mode' declaration", R),
+ VarSet, ContextPieces, R),
process_func_mode(R, ModuleName, FuncTerm, ReturnTypeTerm,
Term, VarSet, MaybeDet, Cond, Attributes, Context, Result)
;
+ ContextPieces = [words("In"), quote(":- mode"), words("declaration")],
parse_implicitly_qualified_term(ModuleName, Term, Term,
- "`:- mode' declaration", R),
+ VarSet, ContextPieces, R),
process_mode_decl(R, ModuleName, Term, VarSet,
WithInst, MaybeDet, Cond, Attributes, Context, Result)
).
@@ -3341,16 +3632,16 @@
varset::in, maybe(mer_inst)::in, maybe(determinism)::in, condition::in,
decl_attrs::in, prog_context::in, maybe1(item)::out) is det.
-process_mode_decl(error2(Errors), _, _, _, _, _, _, _, _, error1(Errors)).
-process_mode_decl(ok2(F, As0), ModuleName, PredMode, VarSet0, WithInst,
+process_mode_decl(error2(Specs), _, _, _, _, _, _, _, _, error1(Specs)).
+process_mode_decl(ok2(F, As0), ModuleName, PredModeTerm, VarSet, WithInst,
MaybeDet, Cond, Attributes0, Context, Result) :-
( convert_mode_list(allow_constrained_inst_var, As0, As1) ->
- get_class_context_and_inst_constraints(ModuleName, Attributes0,
- Attributes, MaybeConstraints),
+ get_class_context_and_inst_constraints(ModuleName, VarSet,
+ Attributes0, Attributes, MaybeConstraints),
(
MaybeConstraints = ok3(_, _, InstConstraints),
list.map(constrain_inst_vars_in_mode(InstConstraints), As1, As),
- varset.coerce(VarSet0, VarSet),
+ varset.coerce(VarSet, ProgVarSet),
( inst_var_constraints_are_consistent_in_modes(As) ->
(
WithInst = no,
@@ -3361,36 +3652,47 @@
% until we expand out the inst.
PredOrFunc = no
),
- ItemModeDecl = item_mode_decl_info(VarSet, PredOrFunc, F, As,
- WithInst, MaybeDet, Cond, Context),
+ ItemModeDecl = item_mode_decl_info(ProgVarSet, PredOrFunc,
+ F, As, WithInst, MaybeDet, Cond, Context),
Item = item_mode_decl(ItemModeDecl),
Result0 = ok1(Item)
;
- Msg = "inconsistent constraints on inst variables " ++
- "in predicate mode declaration",
- Result0 = error1([Msg - PredMode])
+ PredModeTermStr = describe_error_term(VarSet, PredModeTerm),
+ Pieces = [words("Error: inconsistent constraints"),
+ words("on inst variables"),
+ words("in predicate mode declaration:"), nl,
+ words(PredModeTermStr), suffix("."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(PredModeTerm),
+ [always(Pieces)])]),
+ Result0 = error1([Spec])
)
;
- MaybeConstraints = error3(Errors),
- Result0 = error1(Errors)
+ MaybeConstraints = error3(Specs),
+ Result0 = error1(Specs)
),
check_no_attributes(Result0, Attributes, Result)
;
- Result = error1(["syntax error in mode declaration" - PredMode])
+ PredModeTermStr = describe_error_term(VarSet, PredModeTerm),
+ Pieces = [words("Error: syntax error in mode declaration at"),
+ words(PredModeTermStr), suffix("."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(PredModeTerm), [always(Pieces)])]),
+ Result = error1([Spec])
).
:- pred process_func_mode(maybe_functor::in, module_name::in, term::in,
term::in, term::in, varset::in, maybe(determinism)::in, condition::in,
decl_attrs::in, prog_context::in, maybe1(item)::out) is det.
-process_func_mode(error2(Errors), _, _, _, _, _, _, _, _, _, error1(Errors)).
+process_func_mode(error2(Specs), _, _, _, _, _, _, _, _, _, error1(Specs)).
process_func_mode(ok2(F, As0), ModuleName, FuncMode, RetMode0, FullTerm,
- VarSet0, MaybeDet, Cond, Attributes0, Context, Result) :-
+ VarSet, MaybeDet, Cond, Attributes0, Context, Result) :-
(
convert_mode_list(allow_constrained_inst_var, As0, As1)
->
- get_class_context_and_inst_constraints(ModuleName, Attributes0,
- Attributes, MaybeConstraints),
+ get_class_context_and_inst_constraints(ModuleName, VarSet,
+ Attributes0, Attributes, MaybeConstraints),
(
MaybeConstraints = ok3(_, _, InstConstraints),
list.map(constrain_inst_vars_in_mode(InstConstraints), As1, As),
@@ -3399,32 +3701,47 @@
->
constrain_inst_vars_in_mode(InstConstraints,
RetMode1, RetMode),
- varset.coerce(VarSet0, VarSet),
+ varset.coerce(VarSet, InstVarSet),
list.append(As, [RetMode], ArgModes),
( inst_var_constraints_are_consistent_in_modes(ArgModes) ->
- ItemModeDecl = item_mode_decl_info(VarSet,
+ ItemModeDecl = item_mode_decl_info(InstVarSet,
yes(pf_function), F, ArgModes, no, MaybeDet, Cond,
Context),
Item = item_mode_decl(ItemModeDecl),
Result0 = ok1(Item)
;
- Msg = "inconsistent constraints on inst variables " ++
- "in function mode declaration",
- Result0 = error1([Msg - FullTerm])
+ FullTermStr = describe_error_term(VarSet, FullTerm),
+ Pieces = [words("Error: inconsistent constraints"),
+ words("on inst variables"),
+ words("in function mode declaration:"), nl,
+ words(FullTermStr), suffix("."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(FullTerm),
+ [always(Pieces)])]),
+ Result0 = error1([Spec])
+ )
+ ;
+ Pieces = [words("Error: syntax error in return mode"),
+ words("of function mode declaration."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(RetMode0),
+ [always(Pieces)])]),
+ Result0 = error1([Spec])
)
;
- Msg = "syntax error in return mode " ++
- "of function mode declaration",
- Result0 = error1([Msg - RetMode0])
- )
- ;
- MaybeConstraints = error3(Errors),
- Result0 = error1(Errors)
+ MaybeConstraints = error3(Specs),
+ Result0 = error1(Specs)
),
check_no_attributes(Result0, Attributes, Result)
;
- Msg = "syntax error in arguments of function mode declaration",
- Result = error1([Msg - FuncMode])
+ % XXX Should say which argument.
+ FuncModeStr = describe_error_term(VarSet, FuncMode),
+ Pieces = [words("Error: syntax error in arguments of"),
+ words("function mode declaration at"),
+ words(FuncModeStr), suffix("."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(FuncMode), [always(Pieces)])]),
+ Result = error1([Spec])
).
%-----------------------------------------------------------------------------%
@@ -3522,8 +3839,10 @@
inst_var_constraints_are_consistent_in_type_and_modes(TypeAndModes) :-
list.foldl((pred(TypeAndMode::in, in, out) is semidet -->
- ( { TypeAndMode = type_only(_) }
- ; { TypeAndMode = type_and_mode(_, Mode) },
+ (
+ { TypeAndMode = type_only(_) }
+ ;
+ { TypeAndMode = type_and_mode(_, Mode) },
inst_var_constraints_are_consistent_in_mode(Mode)
)), TypeAndModes, map.init, _).
@@ -3604,7 +3923,7 @@
InstDefn = term.functor(term.atom("=="), [H, B], _Context)
->
get_condition(B, Body, Condition),
- convert_inst_defn(ModuleName, H, Body, R),
+ convert_inst_defn(ModuleName, VarSet, H, Body, R),
process_maybe1(make_inst_defn(VarSet, Condition, Context), R, Result)
;
% XXX This is for `abstract inst' declarations,
@@ -3613,36 +3932,41 @@
Args = [Head, term.functor(term.atom("private"), [], _)]
->
Condition = cond_true,
- convert_abstract_inst_defn(ModuleName, Head, R),
+ convert_abstract_inst_defn(ModuleName, VarSet, Head, R),
process_maybe1(make_inst_defn(VarSet, Condition, Context), R, Result)
;
InstDefn = term.functor(term.atom("--->"), [H, B], _Context)
->
get_condition(B, Body, Condition),
Body1 = term.functor(term.atom("bound"), [Body], Context),
- convert_inst_defn(ModuleName, H, Body1, R),
+ convert_inst_defn(ModuleName, VarSet, H, Body1, R),
% We should check the condition for errors. We don't bother
% at the moment, since we ignore conditions anyhow :-)
process_maybe1(make_inst_defn(VarSet, Condition, Context), R, Result)
;
- Result = error1(["`==' expected in `:- inst' definition" - InstDefn])
+ Pieces = [words("Error:"), quote("=="), words("expected in"),
+ quote(":- inst"), words("definition."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(InstDefn), [always(Pieces)])]),
+ Result = error1([Spec])
).
% Parse a `:- inst <Head> ---> <Body>.' definition.
%
-:- pred convert_inst_defn(module_name::in, term::in, term::in,
+:- pred convert_inst_defn(module_name::in, varset::in, term::in, term::in,
maybe1(processed_inst_body)::out) is det.
-convert_inst_defn(ModuleName, Head, Body, Result) :-
- parse_implicitly_qualified_term(ModuleName, Head, Body,
- "inst definition", R),
- convert_inst_defn_2(R, Head, Body, Result).
+convert_inst_defn(ModuleName, VarSet, HeadTerm, BodyTerm, Result) :-
+ ContextPieces = [words("In inst definition:")],
+ parse_implicitly_qualified_term(ModuleName, HeadTerm, BodyTerm,
+ VarSet, ContextPieces, QualResult),
+ convert_inst_defn_2(QualResult, VarSet, HeadTerm, BodyTerm, Result).
-:- pred convert_inst_defn_2(maybe_functor::in, term::in, term::in,
+:- pred convert_inst_defn_2(maybe_functor::in, varset::in, term::in, term::in,
maybe1(processed_inst_body)::out) is det.
-convert_inst_defn_2(error2(Errors), _, _, error1(Errors)).
-convert_inst_defn_2(ok2(Name, ArgTerms), Head, Body, Result) :-
+convert_inst_defn_2(error2(Specs), _, _, _, error1(Specs)).
+convert_inst_defn_2(ok2(Name, ArgTerms), VarSet, HeadTerm, BodyTerm, Result) :-
(
% Check that all the head args are variables.
term.term_list_to_var_list(ArgTerms, Args)
@@ -3652,39 +3976,62 @@
list.member(Arg2, Args, [Arg2 | OtherArgs]),
list.member(Arg2, OtherArgs)
->
- Msg = "repeated inst parameters in LHS of inst defn",
- Result = error1([Msg - Head])
+ % XXX Should improve the error message here.
+ Pieces = [words("Error: repeated inst parameters"),
+ words("in LHS of inst definition."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(HeadTerm), [always(Pieces)])]),
+ Result = error1([Spec])
;
% Check that all the variables in the body occur in the head.
- term.contains_var(Body, Var2),
+ term.contains_var(BodyTerm, Var2),
\+ list.member(Var2, Args)
->
- Msg = "free inst parameter in RHS of inst definition",
- Result = error1([Msg - Body])
+ Pieces = [words("Error: free inst parameter"),
+ words("in RHS of inst definition."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(BodyTerm), [always(Pieces)])]),
+ Result = error1([Spec])
;
% Check that the inst is a valid user-defined inst, i.e. that it
% does not have the form of one of the builtin insts.
\+ (
- convert_inst(no_allow_constrained_inst_var, Head, UserInst),
+ convert_inst(no_allow_constrained_inst_var, HeadTerm,
+ UserInst),
UserInst = defined_inst(user_inst(_, _))
)
->
- Result = error1(["attempt to redefine builtin inst" - Head])
+ % XXX Name the builtin inst.
+ Pieces = [words("Error: attempt to redefine builtin inst."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(HeadTerm), [always(Pieces)])]),
+ Result = error1([Spec])
;
% Should improve the error message here.
(
- convert_inst(no_allow_constrained_inst_var, Body,
+ convert_inst(no_allow_constrained_inst_var, BodyTerm,
ConvertedBody)
->
list.map(term.coerce_var, Args, InstArgs),
Result = ok1(processed_inst_body(Name, InstArgs,
eqv_inst(ConvertedBody)))
;
- Result = error1(["syntax error in inst body" - Body])
+ BodyTermStr = describe_error_term(VarSet, BodyTerm),
+ Pieces = [words("Error: syntax error in inst body at"),
+ words(BodyTermStr), suffix("."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(BodyTerm),
+ [always(Pieces)])]),
+ Result = error1([Spec])
)
)
;
- Result = error1(["inst parameters must be variables" - Head])
+ % XXX If term_list_to_var_list returned the non-var's term or context,
+ % we could use it here.
+ Pieces = [words("Error: inst parameters must be variables."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(HeadTerm), [always(Pieces)])]),
+ Result = error1([Spec])
).
:- type processed_inst_body
@@ -3694,18 +4041,19 @@
inst_defn
).
-:- pred convert_abstract_inst_defn(module_name::in, term::in,
+:- pred convert_abstract_inst_defn(module_name::in, varset::in, term::in,
maybe1(processed_inst_body)::out) is det.
-convert_abstract_inst_defn(ModuleName, Head, Result) :-
- parse_implicitly_qualified_term(ModuleName, Head, Head,
- "inst definition", R),
- convert_abstract_inst_defn_2(R, Head, Result).
+convert_abstract_inst_defn(ModuleName, VarSet, HeadTerm, Result) :-
+ ContextPieces = [words("In inst definition:")],
+ parse_implicitly_qualified_term(ModuleName, HeadTerm, HeadTerm,
+ VarSet, ContextPieces, HeadResult),
+ convert_abstract_inst_defn_2(HeadResult, HeadTerm, Result).
:- pred convert_abstract_inst_defn_2(maybe_functor::in, term::in,
maybe1(processed_inst_body)::out) is det.
-convert_abstract_inst_defn_2(error2(Errors), _, error1(Errors)).
+convert_abstract_inst_defn_2(error2(Specs), _, error1(Specs)).
convert_abstract_inst_defn_2(ok2(Name, ArgTerms), Head, Result) :-
(
% Check that all the head args are variables.
@@ -3716,14 +4064,23 @@
list.member(Arg2, Args, [Arg2 | OtherArgs]),
list.member(Arg2, OtherArgs)
->
- Msg = "repeated inst parameters in abstract inst definition",
- Result = error1([Msg - Head])
+ % XXX We should we list the repeated parameters?
+ Pieces = [words("Error: repeated inst parameters"),
+ words("in abstract inst definition."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(Head), [always(Pieces)])]),
+ Result = error1([Spec])
;
list.map(term.coerce_var, Args, InstArgs),
Result = ok1(processed_inst_body(Name, InstArgs, abstract_inst))
)
;
- Result = error1(["inst parameters must be variables" - Head])
+ % XXX If term_list_to_var_list returned the non-var's term or context,
+ % we could use it here.
+ Pieces = [words("Error: inst parameters must be variables."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(Head), [always(Pieces)])]),
+ Result = error1([Spec])
).
:- pred make_inst_defn(varset::in, condition::in, prog_context::in,
@@ -3746,7 +4103,7 @@
parse_mode_decl(ModuleName, VarSet, ModeDefn, Attributes, Context, Result) :-
( mode_op(ModeDefn, H, B) ->
get_condition(B, Body, Condition),
- convert_mode_defn(ModuleName, H, Body, R),
+ convert_mode_defn(ModuleName, VarSet, H, Body, R),
process_maybe1(make_mode_defn(VarSet, Condition, Context), R, Result)
;
parse_mode_decl_pred(ModuleName, VarSet, ModeDefn, Attributes,
@@ -3765,18 +4122,19 @@
mode_defn
).
-:- pred convert_mode_defn(module_name::in, term::in, term::in,
+:- pred convert_mode_defn(module_name::in, varset::in, term::in, term::in,
maybe1(processed_mode_body)::out) is det.
-convert_mode_defn(ModuleName, Head, Body, Result) :-
- parse_implicitly_qualified_term(ModuleName, Head, Head,
- "mode definition", R),
- convert_mode_defn_2(R, Head, Body, Result).
+convert_mode_defn(ModuleName, VarSet, HeadTerm, BodyTerm, Result) :-
+ ContextPieces = [words("In mode definition:")],
+ parse_implicitly_qualified_term(ModuleName, HeadTerm, HeadTerm,
+ VarSet, ContextPieces, HeadResult),
+ convert_mode_defn_2(HeadResult, HeadTerm, BodyTerm, Result).
:- pred convert_mode_defn_2(maybe_functor::in, term::in, term::in,
maybe1(processed_mode_body)::out) is det.
-convert_mode_defn_2(error2(Errors), _, _, error1(Errors)).
+convert_mode_defn_2(error2(Specs), _, _, error1(Specs)).
convert_mode_defn_2(ok2(Name, ArgTerms), Head, Body, Result) :-
(
% Check that all the head args are variables.
@@ -3787,17 +4145,26 @@
list.member(Arg2, Args, [Arg2 | OtherArgs]),
list.member(Arg2, OtherArgs)
->
- Msg = "repeated parameters in LHS of mode defn",
- Result = error1([Msg - Head])
+ % Check that all the head arg variables are distinct.
+ % XXX We should list the duplicated head arg variables.
+ Pieces = [words("Error: repeated parameters"),
+ words("in LHS of mode definition."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(Head), [always(Pieces)])]),
+ Result = error1([Spec])
;
% Check that all the variables in the body occur in the head.
term.contains_var(Body, Var2),
\+ list.member(Var2, Args)
->
- Msg = "free inst parameter in RHS of mode definition",
- Result = error1([Msg - Head])
+ % XXX Shouldn't we be using the Body's context?
+ % XXX We should list the Var2s for which the condition holds.
+ Pieces = [words("Error: free inst parameter"),
+ words("in RHS of mode definition."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(Head), [always(Pieces)])]),
+ Result = error1([Spec])
;
- % Should improve the error message here.
(
convert_mode(no_allow_constrained_inst_var, Body,
ConvertedBody)
@@ -3806,13 +4173,21 @@
Result = ok1(processed_mode_body(Name, InstArgs,
eqv_mode(ConvertedBody)))
;
- % Catch-all error message - we should do better than this.
- Msg = "syntax error in mode definition body",
- Result = error1([Msg - Body])
+ % XXX We should improve the error message here.
+ Pieces = [words("Error: syntax error"),
+ words("in mode definition body."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(Body), [always(Pieces)])]),
+ Result = error1([Spec])
)
)
;
- Result = error1(["mode parameters must be variables" - Head])
+ % XXX If term_list_to_var_list returned the non-var's term or context,
+ % we could use it here.
+ Pieces = [words("Error: mode parameters must be variables."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(Head), [always(Pieces)])]),
+ Result = error1([Spec])
).
:- pred convert_type_and_mode_list(inst_var_sub::in, list(term)::in,
@@ -3828,12 +4203,12 @@
convert_type_and_mode(InstConstraints, Term, Result) :-
( Term = term.functor(term.atom("::"), [TypeTerm, ModeTerm], _Context) ->
- parse_type(TypeTerm, ok1(Type)),
+ maybe_parse_type(TypeTerm, Type),
convert_mode(allow_constrained_inst_var, ModeTerm, Mode0),
constrain_inst_vars_in_mode(InstConstraints, Mode0, Mode),
Result = type_and_mode(Type, Mode)
;
- parse_type(Term, ok1(Type)),
+ maybe_parse_type(Term, Type),
Result = type_only(Type)
).
@@ -3878,40 +4253,46 @@
process_maybe1(Maker, ok1(X), ok1(Y)) :-
call(Maker, X, Y).
-process_maybe1(_, error1(Errors), error1(Errors)).
+process_maybe1(_, error1(Specs), error1(Specs)).
:- pred process_maybe1_to_t(maker(T1, maybe1(T2))::maker,
maybe1(T1)::in, maybe1(T2)::out) is det.
process_maybe1_to_t(Maker, ok1(X), Y) :-
call(Maker, X, Y).
-process_maybe1_to_t(_, error1(Errors), error1(Errors)).
+process_maybe1_to_t(_, error1(Specs), error1(Specs)).
%-----------------------------------------------------------------------------%
% A ModuleSpecifier is just an sym_name.
%
-:- pred parse_module_specifier(term::in, maybe1(module_specifier)::out) is det.
+:- pred parse_module_specifier(varset::in, term::in,
+ maybe1(module_specifier)::out) is det.
-parse_module_specifier(Term, Result) :-
- parse_symbol_name(Term, Result).
+parse_module_specifier(VarSet, Term, Result) :-
+ parse_symbol_name(VarSet, Term, Result).
% A ModuleName is an implicitly-quantified sym_name.
%
% We check for module names starting with capital letters as a special
% case, so that we can report a better error message for that case.
%
-:- pred parse_module_name(module_name::in, term::in,
+:- pred parse_module_name(module_name::in, varset::in, term::in,
maybe1(module_name)::out) is det.
-parse_module_name(DefaultModuleName, Term, Result) :-
- ( Term = term.variable(_, _) ->
- dummy_term(ErrorContext),
- Msg = "module names starting with capital letters " ++
- "must be quoted using single quotes (e.g. "":- module 'Foo'."")",
- Result = error1([Msg - ErrorContext])
- ;
- parse_implicitly_qualified_symbol_name(DefaultModuleName, Term, Result)
+parse_module_name(DefaultModuleName, VarSet, Term, Result) :-
+ (
+ Term = term.variable(_, Context),
+ Pieces = [words("Error: module names starting with capital letters"),
+ words("must be quoted using single quotes"),
+ words("(e.g. "":- module 'Foo'."")."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(Context, [always(Pieces)])]),
+ Result = error1([Spec])
+ ;
+ Term = term.functor(_, _, _),
+ parse_implicitly_qualified_symbol_name(DefaultModuleName, VarSet,
+ Term, Result)
).
%-----------------------------------------------------------------------------%
@@ -3921,37 +4302,42 @@
% SymbolName/Arity
% Matches only symbols of the specified arity.
%
-:- pred parse_symbol_name_specifier(term::in, maybe1(sym_name_specifier)::out)
- is det.
+:- pred parse_symbol_name_specifier(varset::in, term::in,
+ maybe1(sym_name_specifier)::out) is det.
-parse_symbol_name_specifier(Term, Result) :-
+parse_symbol_name_specifier(VarSet, Term, Result) :-
root_module_name(DefaultModule),
- parse_implicitly_qualified_symbol_name_specifier(DefaultModule, Term,
- Result).
+ parse_implicitly_qualified_symbol_name_specifier(DefaultModule, VarSet,
+ Term, Result).
:- pred parse_implicitly_qualified_symbol_name_specifier(module_name::in,
- term::in, maybe1(sym_name_specifier)::out) is det.
+ varset::in, term::in, maybe1(sym_name_specifier)::out) is det.
-parse_implicitly_qualified_symbol_name_specifier(DefaultModule, Term,
+parse_implicitly_qualified_symbol_name_specifier(DefaultModule, VarSet, Term,
Result) :-
( Term = term.functor(term.atom("/"), [NameTerm, ArityTerm], _Context) ->
( ArityTerm = term.functor(term.integer(Arity), [], _Context2) ->
( Arity >= 0 ->
- parse_implicitly_qualified_symbol_name(DefaultModule, NameTerm,
- NameResult),
+ parse_implicitly_qualified_symbol_name(DefaultModule, VarSet,
+ NameTerm, NameResult),
process_maybe1(make_name_arity_specifier(Arity),
NameResult, Result)
;
- Msg = "arity in symbol name specifier " ++
- "must be a non-negative integer",
- Result = error1([Msg - Term])
+ Pieces = [words("Error: arity in symbol name specifier"),
+ words("must be a non-negative integer."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(Term), [always(Pieces)])]),
+ Result = error1([Spec])
)
;
- Msg = "arity in symbol name specifier must be an integer",
- Result = error1([Msg - Term])
+ Pieces = [words("Error: arity in symbol name specifier"),
+ words("must be an integer."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(Term), [always(Pieces)])]),
+ Result = error1([Spec])
)
;
- parse_implicitly_qualified_symbol_name(DefaultModule, Term,
+ parse_implicitly_qualified_symbol_name(DefaultModule, VarSet, Term,
SymbolNameResult),
process_maybe1(make_name_specifier, SymbolNameResult, Result)
).
@@ -3978,49 +4364,59 @@
% We also allow the syntax `Module__Name' as an alternative
% for `Module.Name'.
%
-:- pred parse_symbol_name(term(T)::in, maybe1(sym_name)::out) is det.
+:- pred parse_symbol_name(varset(T)::in, term(T)::in, maybe1(sym_name)::out)
+ is det.
-parse_symbol_name(Term, Result) :-
+parse_symbol_name(VarSet, Term, Result) :-
(
Term = term.functor(term.atom(FunctorName), [ModuleTerm, NameTerm],
- _Context),
+ TermContext),
( FunctorName = ":"
; FunctorName = "."
)
->
( NameTerm = term.functor(term.atom(Name), [], _Context1) ->
- parse_symbol_name(ModuleTerm, ModuleResult),
+ parse_symbol_name(VarSet, ModuleTerm, ModuleResult),
(
ModuleResult = ok1(Module),
Result = ok1(qualified(Module, Name))
;
- ModuleResult = error1(_),
- term.coerce(Term, ErrorTerm),
- Msg = "module name identifier expected before" ++
- "'" ++ FunctorName ++ "' " ++ "in qualified symbol name",
- Result = error1([Msg - ErrorTerm])
- )
- ;
- term.coerce(Term, ErrorTerm),
- Msg = "identifier expected after '" ++ FunctorName ++ "' " ++
- "in qualified symbol name",
- Result = error1([Msg - ErrorTerm])
+ ModuleResult = error1(_ModuleResultSpecs),
+ % XXX We should say "module name" OR "identifier", not both.
+ Pieces = [words("Error: module name identifier"),
+ words("expected before"), quote(FunctorName),
+ words("in qualified symbol name."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(TermContext, [always(Pieces)])]),
+ % XXX Should we include _ModuleResultSpecs?
+ Result = error1([Spec])
+ )
+ ;
+ Pieces = [words("Error: identifier expected after"),
+ quote(FunctorName), words("in qualified symbol name."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(TermContext, [always(Pieces)])]),
+ Result = error1([Spec])
)
;
- ( Term = term.functor(term.atom(Name), [], _Context3) ->
+ ( Term = term.functor(term.atom(Name), [], _) ->
SymName = string_to_sym_name_sep(Name, "__"),
Result = ok1(SymName)
;
- term.coerce(Term, ErrorTerm),
- Result = error1(["symbol name expected" - ErrorTerm])
+ TermStr = describe_error_term(VarSet, Term),
+ Pieces = [words("Error: symbol name expected at"),
+ words(TermStr), suffix("."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(Term), [always(Pieces)])]),
+ Result = error1([Spec])
)
).
-:- pred parse_implicitly_qualified_symbol_name(module_name::in, term::in,
- maybe1(sym_name)::out) is det.
+:- pred parse_implicitly_qualified_symbol_name(module_name::in, varset::in,
+ term::in, maybe1(sym_name)::out) is det.
-parse_implicitly_qualified_symbol_name(DefaultModName, Term, Result) :-
- parse_symbol_name(Term, Result0),
+parse_implicitly_qualified_symbol_name(DefaultModName, VarSet, Term, Result) :-
+ parse_symbol_name(VarSet, Term, Result0),
(
Result0 = ok1(SymName),
(
@@ -4031,9 +4427,13 @@
SymName = qualified(ModName, _),
\+ match_sym_name(ModName, DefaultModName)
->
- Msg = "module qualifier in definition " ++
- "does not match preceding `:- module' declaration",
- Result = error1([Msg - Term])
+ Pieces = [words("Error: module qualifier in definition"),
+ words("does not match preceding"), quote(":- module"),
+ words("declaration."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(Term), [always(Pieces)])]),
+ Result = error1([Spec])
+
;
UnqualName = unqualify_name(SymName),
Result = ok1(qualified(DefaultModName, UnqualName))
@@ -4045,73 +4445,89 @@
%-----------------------------------------------------------------------------%
-sym_name_and_args(Term, SymName, Args) :-
- parse_qualified_term(Term, Term, "", ok2(SymName, Args)).
-
-parse_implicitly_qualified_term(DefaultModName, Term, ContainingTerm, Msg,
- Result) :-
- parse_qualified_term(Term, ContainingTerm, Msg, Result0),
+parse_implicitly_qualified_term(DefaultModuleName, Term, ContainingTerm,
+ VarSet, ContextPieces, Result) :-
+ parse_qualified_term(Term, ContainingTerm, VarSet, ContextPieces, Result0),
( Result0 = ok2(SymName, Args) ->
(
- root_module_name(DefaultModName)
+ root_module_name(DefaultModuleName)
->
Result = Result0
;
- SymName = qualified(ModName, _),
- \+ match_sym_name(ModName, DefaultModName)
+ SymName = qualified(ModuleName, _),
+ \+ match_sym_name(ModuleName, DefaultModuleName)
->
- term.coerce(Term, ErrorTerm),
- ErrorMsg = "module qualifier in definition does not match " ++
- "preceding `:- module' declaration",
- Result = error2([ErrorMsg - ErrorTerm])
+ Pieces = [words("Error: module qualifier in definition"),
+ words("does not match preceding"), quote(":- module"),
+ words("declaration."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(Term), [always(Pieces)])]),
+ Result = error2([Spec])
;
UnqualName = unqualify_name(SymName),
- Result = ok2(qualified(DefaultModName, UnqualName), Args)
+ Result = ok2(qualified(DefaultModuleName, UnqualName), Args)
)
;
Result = Result0
).
-parse_qualified_term(Term, ContainingTerm, Msg, Result) :-
- (
- Term = term.functor(term.atom(FunctorName),
- [ModuleTerm, NameArgsTerm], _),
- FunctorName = "."
+sym_name_and_args(Term, SymName, Args) :-
+ % The values of VarSet and ContextPieces do not matter here, since
+ % we succeed only if they aren't used.
+ VarSet = varset.init,
+ ContextPieces = [],
+ parse_qualified_term(Term, Term, VarSet, ContextPieces,
+ ok2(SymName, Args)).
+
+parse_qualified_term(Term, _ContainingTerm, VarSet, ContextPieces, Result) :-
+ % XXX We should delete the _ContainingTerm argument.
+ (
+ Term = term.functor(Functor, FunctorArgs, TermContext),
+ Functor = term.atom("."),
+ FunctorArgs = [ModuleTerm, NameArgsTerm]
->
( NameArgsTerm = term.functor(term.atom(Name), Args, _) ->
- parse_symbol_name(ModuleTerm, ModuleResult),
+ varset.coerce(VarSet, GenericVarSet),
+ parse_symbol_name(GenericVarSet, ModuleTerm, ModuleResult),
(
ModuleResult = ok1(Module),
Result = ok2(qualified(Module, Name), Args)
;
ModuleResult = error1(_),
- term.coerce(Term, ErrorTerm),
- ErrorMsg = "module name identifier expected before '.' " ++
- "in qualified symbol name",
- Result = error2([ErrorMsg - ErrorTerm])
- )
- ;
- term.coerce(Term, ErrorTerm),
- ErrorMsg = "identifier expected after '.' " ++
- "in qualified symbol name",
- Result = error2([ErrorMsg - ErrorTerm])
+ ModuleTermStr = describe_error_term(GenericVarSet, ModuleTerm),
+ % XXX We should say "module name" OR "identifier", not both.
+ Pieces = ContextPieces ++ [lower_case_next_if_not_first,
+ words("Error: module name identifier expected before '.'"),
+ words("in qualified symbol name, not"),
+ words(ModuleTermStr), suffix("."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(TermContext, [always(Pieces)])]),
+ Result = error2([Spec])
+ )
+ ;
+ varset.coerce(VarSet, GenericVarSet),
+ TermStr = describe_error_term(GenericVarSet, Term),
+ Pieces = ContextPieces ++ [lower_case_next_if_not_first,
+ words("Error: identifier expected after '.'"),
+ words("in qualified symbol name, not"),
+ words(TermStr), suffix("."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(TermContext, [always(Pieces)])]),
+ Result = error2([Spec])
)
;
+ varset.coerce(VarSet, GenericVarSet),
( Term = term.functor(term.atom(Name), Args, _) ->
SymName = string_to_sym_name_sep(Name, "__"),
Result = ok2(SymName, Args)
;
- string.append("atom expected in ", Msg, ErrorMsg),
- % Since variables don't have any term.context, if Term is
- % a variable, we use ContainingTerm instead (hopefully that
- % _will_ have a term.context).
- ( Term = term.variable(_, _) ->
- ErrorTerm0 = ContainingTerm
- ;
- ErrorTerm0 = Term
- ),
- term.coerce(ErrorTerm0, ErrorTerm),
- Result = error2([ErrorMsg - ErrorTerm])
+ TermStr = describe_error_term(GenericVarSet, Term),
+ Pieces = ContextPieces ++ [lower_case_next_if_not_first,
+ words("Error: atom expected at"),
+ words(TermStr), suffix("."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(Term), [always(Pieces)])]),
+ Result = error2([Spec])
)
).
@@ -4133,57 +4549,64 @@
%-----------------------------------------------------------------------------%
-:- func convert_constructor_arg_list(module_name, list(term)) =
+:- func convert_constructor_arg_list(module_name, varset, list(term)) =
maybe1(list(constructor_arg)).
-convert_constructor_arg_list(_ModuleName, []) = ok1([]).
-convert_constructor_arg_list( ModuleName, [Term | Terms]) = Result :-
+convert_constructor_arg_list(_, _, []) = ok1([]).
+convert_constructor_arg_list(ModuleName, VarSet, [Term | Terms]) = Result :-
( Term = term.functor(term.atom("::"), [NameTerm, TypeTerm], _) ->
+ ContextPieces = [words("In field name:")],
parse_implicitly_qualified_term(ModuleName, NameTerm, Term,
- "field name", NameResult),
+ VarSet, ContextPieces, NameResult),
(
- NameResult = error2(Errors),
- Result = error1(Errors)
+ NameResult = error2(Specs),
+ Result = error1(Specs)
;
NameResult = ok2(SymName, SymNameArgs),
(
SymNameArgs = [_ | _],
- Result = error1(["syntax error in constructor name" - Term])
+ % XXX Should we add "... at function symbol ..."?
+ Pieces = [words("Error: syntax error in constructor name."),
+ nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(Term), [always(Pieces)])]),
+ Result = error1([Spec])
;
SymNameArgs = [],
MaybeFieldName = yes(SymName),
- Result = convert_constructor_arg_list_2(ModuleName,
+ Result = convert_constructor_arg_list_2(ModuleName, VarSet,
MaybeFieldName, TypeTerm, Terms)
)
)
;
MaybeFieldName = no,
TypeTerm = Term,
- Result = convert_constructor_arg_list_2(ModuleName, MaybeFieldName,
- TypeTerm, Terms)
+ Result = convert_constructor_arg_list_2(ModuleName, VarSet,
+ MaybeFieldName, TypeTerm, Terms)
).
-:- func convert_constructor_arg_list_2(module_name, maybe(sym_name), term,
- list(term)) = maybe1(list(constructor_arg)).
+:- func convert_constructor_arg_list_2(module_name, varset, maybe(sym_name),
+ term, list(term)) = maybe1(list(constructor_arg)).
-convert_constructor_arg_list_2(ModuleName, MaybeFieldName, TypeTerm, Terms) =
- Result :-
- parse_type(TypeTerm, TypeResult),
+convert_constructor_arg_list_2(ModuleName, VarSet, MaybeFieldName,
+ TypeTerm, Terms) = Result :-
+ ContextPieces = [words("In type definition:")],
+ parse_type(TypeTerm, VarSet, ContextPieces, TypeResult),
(
TypeResult = ok1(Type),
- Context = term_context(TypeTerm),
+ Context = get_term_context(TypeTerm),
Arg = ctor_arg(MaybeFieldName, Type, Context),
- Result0 = convert_constructor_arg_list(ModuleName, Terms),
+ Result0 = convert_constructor_arg_list(ModuleName, VarSet, Terms),
(
- Result0 = error1(Errors),
- Result = error1(Errors)
+ Result0 = error1(Specs),
+ Result = error1(Specs)
;
Result0 = ok1(Args),
Result = ok1([Arg | Args])
)
;
- TypeResult = error1(Errors),
- Result = error1(Errors)
+ TypeResult = error1(Specs),
+ Result = error1(Specs)
).
%-----------------------------------------------------------------------------%
Index: compiler/prog_io_dcg.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_io_dcg.m,v
retrieving revision 1.43
diff -u -b -r1.43 prog_io_dcg.m
--- compiler/prog_io_dcg.m 15 Feb 2008 02:26:57 -0000 1.43
+++ compiler/prog_io_dcg.m 15 Jul 2008 11:15:10 -0000
@@ -23,10 +23,12 @@
:- interface.
:- import_module mdbcomp.prim_data.
+:- import_module parse_tree.error_util.
:- import_module parse_tree.prog_data.
:- import_module parse_tree.prog_item.
:- import_module parse_tree.prog_io_util.
+:- import_module list.
:- import_module term.
:- import_module varset.
@@ -42,8 +44,9 @@
% `DCGVarInitial' is the first DCG variable,
% and `DCGVarFinal' is the final DCG variable.
%
-:- pred parse_dcg_pred_goal(term::in, maybe1(goal)::out,
- prog_var::out, prog_var::out, prog_varset::in, prog_varset::out) is det.
+:- pred parse_dcg_pred_goal(term::in, list(format_component)::in,
+ maybe1(goal)::out, prog_var::out, prog_var::out,
+ prog_varset::in, prog_varset::out) is det.
:- implementation.
@@ -53,7 +56,6 @@
:- import_module parse_tree.prog_out.
:- import_module counter.
-:- import_module list.
:- import_module pair.
:- import_module string.
@@ -64,25 +66,29 @@
varset.coerce(VarSet0, ProgVarSet0),
new_dcg_var(ProgVarSet0, ProgVarSet1, counter.init(0), Counter0,
DCG_0_Var),
- parse_dcg_goal(DCG_Body, MaybeBody, ProgVarSet1, ProgVarSet,
- Counter0, _Counter, DCG_0_Var, DCG_Var),
+ % XXX Should this be [words("In DCG clause body:")]?
+ BodyContextPieces = [],
+ parse_dcg_goal(DCG_Body, BodyContextPieces, MaybeBody,
+ ProgVarSet1, ProgVarSet, Counter0, _Counter, DCG_0_Var, DCG_Var),
(
MaybeBody = ok1(Body),
+ HeadContextPieces = [words("In DCG clause head:")],
parse_implicitly_qualified_term(ModuleName, DCG_Head, DCG_Body,
- "DCG clause head", HeadResult),
+ VarSet0, HeadContextPieces, HeadResult),
process_dcg_clause(HeadResult, ProgVarSet, DCG_0_Var, DCG_Var, Body,
DCG_Context, Result)
;
- MaybeBody = error1(Errors),
- Result = error1(Errors)
+ MaybeBody = error1(Specs),
+ Result = error1(Specs)
).
%-----------------------------------------------------------------------------%
-parse_dcg_pred_goal(GoalTerm, MaybeGoal, DCGVar0, DCGVar, !VarSet) :-
+parse_dcg_pred_goal(GoalTerm, ContextPieces, MaybeGoal,
+ DCGVar0, DCGVar, !VarSet) :-
new_dcg_var(!VarSet, counter.init(0), Counter0, DCGVar0),
- parse_dcg_goal(GoalTerm, MaybeGoal, !VarSet, Counter0, _Counter,
- DCGVar0, DCGVar).
+ parse_dcg_goal(GoalTerm, ContextPieces, MaybeGoal, !VarSet,
+ Counter0, _Counter, DCGVar0, DCGVar).
%-----------------------------------------------------------------------------%
@@ -102,11 +108,11 @@
% Expand a DCG goal.
%
-:- pred parse_dcg_goal(term::in, maybe1(goal)::out,
+:- pred parse_dcg_goal(term::in, list(format_component)::in, maybe1(goal)::out,
prog_varset::in, prog_varset::out, counter::in, counter::out,
prog_var::in, prog_var::out) is det.
-parse_dcg_goal(Term, MaybeGoal, !VarSet, !Counter, !Var) :-
+parse_dcg_goal(Term, ContextPieces, MaybeGoal, !VarSet, !Counter, !Var) :-
% First, figure out the context for the goal.
(
Term = term.functor(_, _, Context)
@@ -122,8 +128,8 @@
(
SymName = unqualified(Functor),
list.map(term.coerce, Args0, Args1),
- parse_dcg_goal_2(Functor, Args1, Context, MaybeGoalPrime,
- !VarSet, !Counter, !Var)
+ parse_dcg_goal_2(Functor, Args1, Context, ContextPieces,
+ MaybeGoalPrime, !VarSet, !Counter, !Var)
->
MaybeGoal = MaybeGoalPrime
;
@@ -150,9 +156,10 @@
!:Var = Var
).
- % parse_dcg_goal_2(Functor, Args, Context, Goal, !VarSet, !Counter, !Var):
+ % parse_dcg_goal_2(Functor, Args, Context, ContextPieces, Goal,
+ % !VarSet, !Counter, !Var):
%
- % We use !VarSet to allocate fresh DCG variables; We use !Counter
+ % We use !VarSet to allocate fresh DCG variables. We use !Counter
% to keep track of the number to give to the next DCG variable
% (so that we can give it a semi-meaningful name "DCG_<N>" for use
% in error messages, debugging, etc.). We use !Var to keep track of
@@ -163,102 +170,107 @@
% for the moment we'll just disallow it.
%
:- pred parse_dcg_goal_2(string::in, list(term)::in, prog_context::in,
- maybe1(goal)::out, prog_varset::in, prog_varset::out,
- counter::in, counter::out, prog_var::in, prog_var::out) is semidet.
+ list(format_component)::in, maybe1(goal)::out,
+ prog_varset::in, prog_varset::out, counter::in, counter::out,
+ prog_var::in, prog_var::out) is semidet.
-parse_dcg_goal_2("{}", [G0 | Gs], Context, MaybeGoal, !VarSet, !Counter,
- !Var) :-
+ % XXX We should update ContextPieces as we recurse.
+parse_dcg_goal_2("{}", [G0 | Gs], Context, ContextPieces, MaybeGoal,
+ !VarSet, !Counter, !Var) :-
% Ordinary goal inside { curly braces }.
% The parser treats '{}/N' terms as tuples, so we need
% to undo the parsing of the argument conjunction here.
list_to_conjunction(Context, G0, Gs, G),
- parse_goal(G, MaybeGoal, !VarSet).
-parse_dcg_goal_2("impure", [G], _, MaybeGoal, !VarSet, !Counter, !Var) :-
- parse_dcg_goal_with_purity(G, purity_impure, MaybeGoal, !VarSet,
- !Counter, !Var).
-parse_dcg_goal_2("semipure", [G], _, MaybeGoal, !VarSet, !Counter, !Var) :-
- parse_dcg_goal_with_purity(G, purity_semipure, MaybeGoal, !VarSet,
- !Counter, !Var).
-parse_dcg_goal_2("promise_pure", [G], Context, MaybeGoal,
+ parse_goal(G, ContextPieces, MaybeGoal, !VarSet).
+parse_dcg_goal_2("impure", [G], _, ContextPieces, MaybeGoal,
+ !VarSet, !Counter, !Var) :-
+ parse_dcg_goal_with_purity(G, purity_impure, ContextPieces, MaybeGoal,
+ !VarSet, !Counter, !Var).
+parse_dcg_goal_2("semipure", [G], _, ContextPieces, MaybeGoal,
!VarSet, !Counter, !Var) :-
- parse_dcg_goal(G, MaybeGoal0, !VarSet, !Counter, !Var),
+ parse_dcg_goal_with_purity(G, purity_semipure, ContextPieces, MaybeGoal,
+ !VarSet, !Counter, !Var).
+parse_dcg_goal_2("promise_pure", [G], Context, ContextPieces, MaybeGoal,
+ !VarSet, !Counter, !Var) :-
+ parse_dcg_goal(G, ContextPieces, MaybeGoal0, !VarSet, !Counter, !Var),
(
MaybeGoal0 = ok1(Goal0),
Goal = promise_purity_expr(dont_make_implicit_promises, purity_pure,
Goal0) - Context,
MaybeGoal = ok1(Goal)
;
- MaybeGoal0 = error1(Errors),
- MaybeGoal = error1(Errors)
+ MaybeGoal0 = error1(Specs),
+ MaybeGoal = error1(Specs)
).
-parse_dcg_goal_2("promise_semipure", [G], Context, MaybeGoal,
+parse_dcg_goal_2("promise_semipure", [G], Context, ContextPieces, MaybeGoal,
!VarSet, !Counter, !Var) :-
- parse_dcg_goal(G, MaybeGoal0, !VarSet, !Counter, !Var),
+ parse_dcg_goal(G, ContextPieces, MaybeGoal0, !VarSet, !Counter, !Var),
(
MaybeGoal0 = ok1(Goal0),
Goal = promise_purity_expr(dont_make_implicit_promises, purity_semipure,
Goal0) - Context,
MaybeGoal = ok1(Goal)
;
- MaybeGoal0 = error1(Errors),
- MaybeGoal = error1(Errors)
+ MaybeGoal0 = error1(Specs),
+ MaybeGoal = error1(Specs)
).
-parse_dcg_goal_2("promise_impure", [G], Context, MaybeGoal,
+parse_dcg_goal_2("promise_impure", [G], Context, ContextPieces, MaybeGoal,
!VarSet, !Counter, !Var) :-
- parse_dcg_goal(G, MaybeGoal0, !VarSet, !Counter, !Var),
+ parse_dcg_goal(G, ContextPieces, MaybeGoal0, !VarSet, !Counter, !Var),
(
MaybeGoal0 = ok1(Goal0),
Goal = promise_purity_expr(dont_make_implicit_promises, purity_impure,
Goal0) - Context,
MaybeGoal = ok1(Goal)
;
- MaybeGoal0 = error1(Errors),
- MaybeGoal = error1(Errors)
+ MaybeGoal0 = error1(Specs),
+ MaybeGoal = error1(Specs)
).
-parse_dcg_goal_2("promise_pure_implicit", [G], Context, MaybeGoal,
+parse_dcg_goal_2("promise_pure_implicit", [G], Context, ContextPieces, MaybeGoal,
!VarSet, !Counter, !Var) :-
- parse_dcg_goal(G, MaybeGoal0, !VarSet, !Counter, !Var),
+ parse_dcg_goal(G, ContextPieces, MaybeGoal0, !VarSet, !Counter, !Var),
(
MaybeGoal0 = ok1(Goal0),
Goal = promise_purity_expr(make_implicit_promises, purity_pure, Goal0)
- Context,
MaybeGoal = ok1(Goal)
;
- MaybeGoal0 = error1(Errors),
- MaybeGoal = error1(Errors)
+ MaybeGoal0 = error1(Specs),
+ MaybeGoal = error1(Specs)
).
-parse_dcg_goal_2("promise_semipure_implicit", [G], Context, MaybeGoal,
- !VarSet, !Counter, !Var) :-
- parse_dcg_goal(G, MaybeGoal0, !VarSet, !Counter, !Var),
+parse_dcg_goal_2("promise_semipure_implicit", [G], Context, ContextPieces,
+ MaybeGoal, !VarSet, !Counter, !Var) :-
+ parse_dcg_goal(G, ContextPieces, MaybeGoal0, !VarSet, !Counter, !Var),
(
MaybeGoal0 = ok1(Goal0),
Goal = promise_purity_expr(make_implicit_promises, purity_semipure,
Goal0) - Context,
MaybeGoal = ok1(Goal)
;
- MaybeGoal0 = error1(Errors),
- MaybeGoal = error1(Errors)
+ MaybeGoal0 = error1(Specs),
+ MaybeGoal = error1(Specs)
).
-parse_dcg_goal_2("promise_impure_implicit", [G], Context, MaybeGoal,
- !VarSet, !Counter, !Var) :-
- parse_dcg_goal(G, MaybeGoal0, !VarSet, !Counter, !Var),
+parse_dcg_goal_2("promise_impure_implicit", [G], Context, ContextPieces,
+ MaybeGoal, !VarSet, !Counter, !Var) :-
+ parse_dcg_goal(G, ContextPieces, MaybeGoal0, !VarSet, !Counter, !Var),
(
MaybeGoal0 = ok1(Goal0),
Goal = promise_purity_expr(make_implicit_promises, purity_impure,
Goal0) - Context,
MaybeGoal = ok1(Goal)
;
- MaybeGoal0 = error1(Errors),
- MaybeGoal = error1(Errors)
+ MaybeGoal0 = error1(Specs),
+ MaybeGoal = error1(Specs)
).
-parse_dcg_goal_2("[]", [], Context, MaybeGoal, !VarSet, !Counter, Var0, Var) :-
+parse_dcg_goal_2("[]", [], Context, _CP, MaybeGoal, !VarSet, !Counter,
+ Var0, Var) :-
% Empty list - just unify the input and output DCG args.
new_dcg_var(!VarSet, !Counter, Var),
Goal = unify_expr(
term.variable(Var0, Context), term.variable(Var, Context), purity_pure)
- Context,
MaybeGoal = ok1(Goal).
-parse_dcg_goal_2("[|]", [X, Xs], Context, MaybeGoal, !VarSet, !Counter,
+parse_dcg_goal_2("[|]", [X, Xs], Context, _CP, MaybeGoal, !VarSet, !Counter,
Var0, Var) :-
% Non-empty list of terminals. Append the DCG output arg as the new tail
% of the list, and unify the result with the DCG input arg.
@@ -268,24 +280,25 @@
term_list_append_term(ConsTerm, term.variable(Var, Context), Term),
Goal = unify_expr(variable(Var0, Context), Term, purity_pure) - Context,
MaybeGoal = ok1(Goal).
-parse_dcg_goal_2("=", [A0], Context, MaybeGoal, !VarSet, !Counter, Var, Var) :-
+parse_dcg_goal_2("=", [A0], Context, _CP, MaybeGoal, !VarSet, !Counter,
+ Var, Var) :-
% Call to '='/1 - unify argument with DCG input arg.
term.coerce(A0, A),
Goal = unify_expr(A, variable(Var, Context), purity_pure) - Context,
MaybeGoal = ok1(Goal).
-parse_dcg_goal_2(":=", [A0], Context, MaybeGoal, !VarSet, !Counter,
+parse_dcg_goal_2(":=", [A0], Context, _CP, MaybeGoal, !VarSet, !Counter,
_Var0, Var) :-
% Call to ':='/1 - unify argument with DCG output arg.
new_dcg_var(!VarSet, !Counter, Var),
term.coerce(A0, A),
Goal = unify_expr(A, variable(Var, Context), purity_pure) - Context,
MaybeGoal = ok1(Goal).
-parse_dcg_goal_2("if",
- [term.functor(term.atom("then"), [CondTerm, ThenTerm], _)],
- Context, MaybeGoal, !VarSet, !Counter, Var0, Var) :-
+parse_dcg_goal_2("if", Args, Context, ContextPieces, MaybeGoal,
+ !VarSet, !Counter, Var0, Var) :-
+ Args = [term.functor(term.atom("then"), [CondTerm, ThenTerm], _)],
% If-then (NU-Prolog syntax).
- parse_dcg_if_then(CondTerm, ThenTerm, Context, MaybeVarsCond, MaybeThen,
- !VarSet, !Counter, Var0, Var),
+ parse_dcg_if_then(CondTerm, ThenTerm, Context, ContextPieces,
+ MaybeVarsCond, MaybeThen, !VarSet, !Counter, Var0, Var),
(
MaybeVarsCond = ok3(Vars, StateVars, Cond),
MaybeThen = ok1(Then)
@@ -300,15 +313,15 @@
Goal = if_then_else_expr(Vars, StateVars, Cond, Then, Else) - Context,
MaybeGoal = ok1(Goal)
;
- CondErrors = get_any_errors3(MaybeVarsCond),
- ThenErrors = get_any_errors1(MaybeThen),
- MaybeGoal = error1(CondErrors ++ ThenErrors)
+ CondSpecs = get_any_errors3(MaybeVarsCond),
+ ThenSpecs = get_any_errors1(MaybeThen),
+ MaybeGoal = error1(CondSpecs ++ ThenSpecs)
).
-parse_dcg_goal_2(",", [ATerm, BTerm], Context, MaybeGoal, !VarSet, !Counter,
- !Var) :-
+parse_dcg_goal_2(",", [ATerm, BTerm], Context, ContextPieces, MaybeGoal,
+ !VarSet, !Counter, !Var) :-
% Conjunction.
- parse_dcg_goal(ATerm, MaybeAGoal, !VarSet, !Counter, !Var),
- parse_dcg_goal(BTerm, MaybeBGoal, !VarSet, !Counter, !Var),
+ parse_dcg_goal(ATerm, ContextPieces, MaybeAGoal, !VarSet, !Counter, !Var),
+ parse_dcg_goal(BTerm, ContextPieces, MaybeBGoal, !VarSet, !Counter, !Var),
(
MaybeAGoal = ok1(AGoal),
MaybeBGoal = ok1(BGoal)
@@ -316,14 +329,14 @@
Goal = conj_expr(AGoal, BGoal) - Context,
MaybeGoal = ok1(Goal)
;
- AErrors = get_any_errors1(MaybeAGoal),
- BErrors = get_any_errors1(MaybeBGoal),
- MaybeGoal = error1(AErrors ++ BErrors)
- ).
-parse_dcg_goal_2("&", [ATerm, BTerm], Context, MaybeGoal, !VarSet, !Counter,
- !Var) :-
- parse_dcg_goal(ATerm, MaybeAGoal, !VarSet, !Counter, !Var),
- parse_dcg_goal(BTerm, MaybeBGoal, !VarSet, !Counter, !Var),
+ ASpecs = get_any_errors1(MaybeAGoal),
+ BSpecs = get_any_errors1(MaybeBGoal),
+ MaybeGoal = error1(ASpecs ++ BSpecs)
+ ).
+parse_dcg_goal_2("&", [ATerm, BTerm], Context, ContextPieces, MaybeGoal,
+ !VarSet, !Counter, !Var) :-
+ parse_dcg_goal(ATerm, ContextPieces, MaybeAGoal, !VarSet, !Counter, !Var),
+ parse_dcg_goal(BTerm, ContextPieces, MaybeBGoal, !VarSet, !Counter, !Var),
(
MaybeAGoal = ok1(AGoal),
MaybeBGoal = ok1(BGoal)
@@ -331,19 +344,21 @@
Goal = par_conj_expr(AGoal, BGoal) - Context,
MaybeGoal = ok1(Goal)
;
- AErrors = get_any_errors1(MaybeAGoal),
- BErrors = get_any_errors1(MaybeBGoal),
- MaybeGoal = error1(AErrors ++ BErrors)
+ ASpecs = get_any_errors1(MaybeAGoal),
+ BSpecs = get_any_errors1(MaybeBGoal),
+ MaybeGoal = error1(ASpecs ++ BSpecs)
).
-parse_dcg_goal_2(";", [ATerm, BTerm], Context, MaybeGoal, !VarSet, !Counter,
- Var0, Var) :-
+parse_dcg_goal_2(";", [ATerm, BTerm], Context, ContextPieces, MaybeGoal,
+ !VarSet, !Counter, Var0, Var) :-
% Disjunction or if-then-else (Prolog syntax).
( ATerm = term.functor(term.atom("->"), [CondTerm, ThenTerm], _Context) ->
- parse_dcg_if_then_else(CondTerm, ThenTerm, BTerm, Context, MaybeGoal,
- !VarSet, !Counter, Var0, Var)
+ parse_dcg_if_then_else(CondTerm, ThenTerm, BTerm, Context,
+ ContextPieces, MaybeGoal, !VarSet, !Counter, Var0, Var)
;
- parse_dcg_goal(ATerm, MaybeAGoal0, !VarSet, !Counter, Var0, VarA),
- parse_dcg_goal(BTerm, MaybeBGoal0, !VarSet, !Counter, Var0, VarB),
+ parse_dcg_goal(ATerm, ContextPieces, MaybeAGoal0,
+ !VarSet, !Counter, Var0, VarA),
+ parse_dcg_goal(BTerm, ContextPieces, MaybeBGoal0,
+ !VarSet, !Counter, Var0, VarB),
(
MaybeAGoal0 = ok1(AGoal0),
MaybeBGoal0 = ok1(BGoal0)
@@ -373,48 +388,53 @@
MaybeGoal = ok1(Goal)
;
Var = VarA, % Dummy; the value shouldn't matter.
- AErrors = get_any_errors1(MaybeAGoal0),
- BErrors = get_any_errors1(MaybeBGoal0),
- MaybeGoal = error1(AErrors ++ BErrors)
+ ASpecs = get_any_errors1(MaybeAGoal0),
+ BSpecs = get_any_errors1(MaybeBGoal0),
+ MaybeGoal = error1(ASpecs ++ BSpecs)
)
).
-parse_dcg_goal_2("else", [IfTerm, ElseTerm], _, MaybeGoal, !VarSet, !Counter,
- !Var) :-
+parse_dcg_goal_2("else", [IfTerm, ElseTerm], _, ContextPieces, MaybeGoal,
+ !VarSet, !Counter, !Var) :-
% If-then-else (NU-Prolog syntax).
IfTerm = term.functor(term.atom("if"),
[term.functor(term.atom("then"), [CondTerm, ThenTerm], _)], Context),
- parse_dcg_if_then_else(CondTerm, ThenTerm, ElseTerm, Context, MaybeGoal,
- !VarSet, !Counter, !Var).
-parse_dcg_goal_2("not", [ATerm], Context, MaybeGoal, !VarSet, !Counter,
- Var0, Var0) :-
+ parse_dcg_if_then_else(CondTerm, ThenTerm, ElseTerm, Context,
+ ContextPieces, MaybeGoal, !VarSet, !Counter, !Var).
+parse_dcg_goal_2("not", [ATerm], Context, ContextPieces, MaybeGoal,
+ !VarSet, !Counter, Var0, Var0) :-
% Negation (NU-Prolog syntax).
- parse_dcg_goal(ATerm, MaybeAGoal, !VarSet, !Counter, Var0, _),
+ parse_dcg_goal(ATerm, ContextPieces, MaybeAGoal, !VarSet, !Counter,
+ Var0, _),
(
MaybeAGoal = ok1(AGoal),
Goal = not_expr(AGoal) - Context,
MaybeGoal = ok1(Goal)
;
- MaybeAGoal = error1(Errors),
- MaybeGoal = error1(Errors)
+ MaybeAGoal = error1(Specs),
+ MaybeGoal = error1(Specs)
).
-parse_dcg_goal_2("\\+", [ATerm], Context, MaybeGoal, !VarSet, !Counter,
- Var0, Var0) :-
+parse_dcg_goal_2("\\+", [ATerm], Context, ContextPieces, MaybeGoal,
+ !VarSet, !Counter, Var0, Var0) :-
% Negation (Prolog syntax).
- parse_dcg_goal(ATerm, MaybeAGoal, !VarSet, !Counter, Var0, _),
+ parse_dcg_goal(ATerm, ContextPieces, MaybeAGoal, !VarSet, !Counter,
+ Var0, _),
(
MaybeAGoal = ok1(AGoal),
Goal = not_expr(AGoal) - Context,
MaybeGoal = ok1(Goal)
;
- MaybeAGoal = error1(Errors),
- MaybeGoal = error1(Errors)
+ MaybeAGoal = error1(Specs),
+ MaybeGoal = error1(Specs)
).
-parse_dcg_goal_2("all", [QVarsTerm, SubTerm], Context, MaybeGoal, !VarSet,
- !Counter, !Var) :-
+parse_dcg_goal_2("all", [QVarsTerm, SubTerm], Context, ContextPieces,
+ MaybeGoal, !VarSet, !Counter, !Var) :-
% Universal quantification.
% Extract any state variables in the quantifier.
- parse_quantifier_vars(QVarsTerm, MaybeStateVarsAndVars),
- parse_dcg_goal(SubTerm, MaybeSubGoal, !VarSet, !Counter, !Var),
+ varset.coerce(!.VarSet, GenericVarSet),
+ parse_quantifier_vars(QVarsTerm, GenericVarSet, ContextPieces,
+ MaybeStateVarsAndVars),
+ parse_dcg_goal(SubTerm, ContextPieces, MaybeSubGoal,
+ !VarSet, !Counter, !Var),
(
MaybeStateVarsAndVars = ok2(Vars0, StateVars0),
MaybeSubGoal = ok1(SubGoal)
@@ -443,16 +463,19 @@
Goal = GoalExpr - Context,
MaybeGoal = ok1(Goal)
;
- VarsErrors = get_any_errors2(MaybeStateVarsAndVars),
- SubGoalErrors = get_any_errors1(MaybeSubGoal),
- MaybeGoal = error1(VarsErrors ++ SubGoalErrors)
+ VarsSpecs = get_any_errors2(MaybeStateVarsAndVars),
+ SubGoalSpecs = get_any_errors1(MaybeSubGoal),
+ MaybeGoal = error1(VarsSpecs ++ SubGoalSpecs)
).
-parse_dcg_goal_2("some", [QVarsTerm, SubTerm], Context, MaybeGoal,
- !VarSet, !Counter, !Var) :-
+parse_dcg_goal_2("some", [QVarsTerm, SubTerm], Context, ContextPieces,
+ MaybeGoal, !VarSet, !Counter, !Var) :-
% Existential quantification.
% Extract any state variables in the quantifier.
- parse_quantifier_vars(QVarsTerm, MaybeStateVarsAndVars),
- parse_dcg_goal(SubTerm, MaybeSubGoal, !VarSet, !Counter, !Var),
+ varset.coerce(!.VarSet, GenericVarSet),
+ parse_quantifier_vars(QVarsTerm, GenericVarSet, ContextPieces,
+ MaybeStateVarsAndVars),
+ parse_dcg_goal(SubTerm, ContextPieces, MaybeSubGoal,
+ !VarSet, !Counter, !Var),
(
MaybeStateVarsAndVars = ok2(Vars0, StateVars0),
MaybeSubGoal = ok1(SubGoal)
@@ -481,17 +504,19 @@
Goal = GoalExpr - Context,
MaybeGoal = ok1(Goal)
;
- VarsErrors = get_any_errors2(MaybeStateVarsAndVars),
- SubGoalErrors = get_any_errors1(MaybeSubGoal),
- MaybeGoal = error1(VarsErrors ++ SubGoalErrors)
+ VarsSpecs = get_any_errors2(MaybeStateVarsAndVars),
+ SubGoalSpecs = get_any_errors1(MaybeSubGoal),
+ MaybeGoal = error1(VarsSpecs ++ SubGoalSpecs)
).
-:- pred parse_dcg_goal_with_purity(term::in, purity::in, maybe1(goal)::out,
+:- pred parse_dcg_goal_with_purity(term::in, purity::in,
+ list(format_component)::in, maybe1(goal)::out,
prog_varset::in, prog_varset::out, counter::in, counter::out,
prog_var::in, prog_var::out) is det.
-parse_dcg_goal_with_purity(G, Purity, MaybeGoal, !VarSet, !Counter, !Var) :-
- parse_dcg_goal(G, MaybeGoal1, !VarSet, !Counter, !Var),
+parse_dcg_goal_with_purity(G, Purity, ContextPieces, MaybeGoal,
+ !VarSet, !Counter, !Var) :-
+ parse_dcg_goal(G, ContextPieces, MaybeGoal1, !VarSet, !Counter, !Var),
(
MaybeGoal1 = ok1(Goal1),
( Goal1 = call_expr(Pred, Args, purity_pure) - Context ->
@@ -510,8 +535,8 @@
),
MaybeGoal = ok1(Goal)
;
- MaybeGoal1 = error1(Errors),
- MaybeGoal = error1(Errors)
+ MaybeGoal1 = error1(Specs),
+ MaybeGoal = error1(Specs)
).
:- pred append_to_disjunct(goal::in, goal_expr::in, prog_context::in,
@@ -526,20 +551,25 @@
Disjunct = conj_expr(Disjunct0, Goal - Context) - Context
).
-:- pred parse_some_vars_dcg_goal(term::in,
+:- pred parse_some_vars_dcg_goal(term::in, list(format_component)::in,
maybe3(list(prog_var), list(prog_var), goal)::out,
prog_varset::in, prog_varset::out, counter::in, counter::out,
prog_var::in, prog_var::out) is det.
-parse_some_vars_dcg_goal(Term, MaybeVarsGoal, !VarSet, !Counter, !Var) :-
+parse_some_vars_dcg_goal(Term, ContextPieces, MaybeVarsGoal,
+ !VarSet, !Counter, !Var) :-
( Term = term.functor(term.atom("some"), [VarsTerm, SubTerm], _Context) ->
- parse_quantifier_vars(VarsTerm, MaybeVars),
+ % XXX We should update ContextPieces.
+ varset.coerce(!.VarSet, GenericVarSet),
+ parse_quantifier_vars(VarsTerm, GenericVarSet, ContextPieces,
+ MaybeVars),
GoalTerm = SubTerm
;
MaybeVars = ok2([], []),
GoalTerm = Term
),
- parse_dcg_goal(GoalTerm, MaybeGoal, !VarSet, !Counter, !Var),
+ parse_dcg_goal(GoalTerm, ContextPieces, MaybeGoal, !VarSet, !Counter,
+ !Var),
(
MaybeVars = ok2(Vars0, StateVars0),
MaybeGoal = ok1(Goal)
@@ -548,9 +578,9 @@
list.map(term.coerce_var, StateVars0, StateVars),
MaybeVarsGoal = ok3(Vars, StateVars, Goal)
;
- VarsErrors = get_any_errors2(MaybeVars),
- GoalErrors = get_any_errors1(MaybeGoal),
- MaybeVarsGoal = error3(VarsErrors ++ GoalErrors)
+ VarsSpecs = get_any_errors2(MaybeVars),
+ GoalSpecs = get_any_errors1(MaybeGoal),
+ MaybeVarsGoal = error3(VarsSpecs ++ GoalSpecs)
).
% Parse the "if" and the "then" part of an if-then or an if-then-else.
@@ -573,15 +603,17 @@
% so that the implicit quantification of DCG_2 is correct.
%
:- pred parse_dcg_if_then(term::in, term::in, prog_context::in,
+ list(format_component)::in,
maybe3(list(prog_var), list(prog_var), goal)::out,
maybe1(goal)::out, prog_varset::in, prog_varset::out,
counter::in, counter::out, prog_var::in, prog_var::out) is det.
-parse_dcg_if_then(CondTerm, ThenTerm, Context, MaybeVarsCond, MaybeThen,
- !VarSet, !Counter, Var0, Var) :-
- parse_some_vars_dcg_goal(CondTerm, MaybeVarsCond, !VarSet, !Counter,
- Var0, Var1),
- parse_dcg_goal(ThenTerm, MaybeThen1, !VarSet, !Counter, Var1, Var2),
+parse_dcg_if_then(CondTerm, ThenTerm, Context, ContextPieces,
+ MaybeVarsCond, MaybeThen, !VarSet, !Counter, Var0, Var) :-
+ parse_some_vars_dcg_goal(CondTerm, ContextPieces, MaybeVarsCond,
+ !VarSet, !Counter, Var0, Var1),
+ parse_dcg_goal(ThenTerm, ContextPieces, MaybeThen1,
+ !VarSet, !Counter, Var1, Var2),
(
Var0 \= Var1,
Var1 = Var2
@@ -605,14 +637,16 @@
).
:- pred parse_dcg_if_then_else(term::in, term::in, term::in, prog_context::in,
- maybe1(goal)::out, prog_varset::in, prog_varset::out,
- counter::in, counter::out, prog_var::in, prog_var::out) is det.
+ list(format_component)::in, maybe1(goal)::out,
+ prog_varset::in, prog_varset::out, counter::in, counter::out,
+ prog_var::in, prog_var::out) is det.
-parse_dcg_if_then_else(CondTerm, ThenTerm, ElseTerm, Context, MaybeGoal,
- !VarSet, !Counter, Var0, Var) :-
- parse_dcg_if_then(CondTerm, ThenTerm, Context, MaybeVarsCond, MaybeThen1,
- !VarSet, !Counter, Var0, VarThen),
- parse_dcg_goal(ElseTerm, MaybeElse1, !VarSet, !Counter, Var0, VarElse),
+parse_dcg_if_then_else(CondTerm, ThenTerm, ElseTerm, Context, ContextPieces,
+ MaybeGoal, !VarSet, !Counter, Var0, Var) :-
+ parse_dcg_if_then(CondTerm, ThenTerm, Context, ContextPieces,
+ MaybeVarsCond, MaybeThen1, !VarSet, !Counter, Var0, VarThen),
+ parse_dcg_goal(ElseTerm, ContextPieces, MaybeElse1,
+ !VarSet, !Counter, Var0, VarElse),
(
MaybeVarsCond = ok3(Vars, StateVars, Cond),
MaybeThen1 = ok1(Then1),
@@ -654,10 +688,10 @@
- Context,
MaybeGoal = ok1(Goal)
;
- CondErrors = get_any_errors3(MaybeVarsCond),
- ThenErrors = get_any_errors1(MaybeThen1),
- ElseErrors = get_any_errors1(MaybeElse1),
- MaybeGoal = error1(CondErrors ++ ThenErrors ++ ElseErrors),
+ CondSpecs = get_any_errors3(MaybeVarsCond),
+ ThenSpecs = get_any_errors1(MaybeThen1),
+ ElseSpecs = get_any_errors1(MaybeElse1),
+ MaybeGoal = error1(CondSpecs ++ ThenSpecs ++ ElseSpecs),
Var = Var0 % Dummy; the value shouldn't matter.
).
@@ -673,9 +707,9 @@
( List0 = term.functor(term.atom("[]"), [], _Context) ->
List = Term
;
- List0 = term.functor(term.atom("[|]"), [Head, Tail0], Context2),
- List = term.functor(term.atom("[|]"), [Head, Tail], Context2),
- term_list_append_term(Tail0, Term, Tail)
+ List0 = term.functor(term.atom("[|]"), [Head, Tail0], Context),
+ term_list_append_term(Tail0, Term, Tail),
+ List = term.functor(term.atom("[|]"), [Head, Tail], Context)
).
:- pred process_dcg_clause(maybe_functor::in, prog_varset::in, prog_var::in,
@@ -692,6 +726,6 @@
Item = item_clause(ItemClause),
MaybeItem = ok1(Item)
;
- MaybeFunctor = error2(Errors),
- MaybeItem = error1(Errors)
+ MaybeFunctor = error2(Specs),
+ MaybeItem = error1(Specs)
).
Index: compiler/prog_io_goal.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_io_goal.m,v
retrieving revision 1.54
diff -u -b -r1.54 prog_io_goal.m
--- compiler/prog_io_goal.m 27 Feb 2008 07:23:13 -0000 1.54
+++ compiler/prog_io_goal.m 15 Jul 2008 13:00:19 -0000
@@ -16,6 +16,7 @@
:- module parse_tree.prog_io_goal.
:- interface.
+:- import_module parse_tree.error_util.
:- import_module parse_tree.prog_data.
:- import_module parse_tree.prog_item.
:- import_module parse_tree.prog_io_util.
@@ -27,7 +28,7 @@
% Convert a single term into a goal.
%
-:- pred parse_goal(term::in, maybe1(goal)::out,
+:- pred parse_goal(term::in, list(format_component)::in, maybe1(goal)::out,
prog_varset::in, prog_varset::out) is det.
% Convert a term, possibly starting with `some [Vars]', into
@@ -35,7 +36,7 @@
% state variables, and a goal. (If the term doesn't start
% with `some [Vars]', we return empty lists of variables.)
%
-:- pred parse_some_vars_goal(term::in,
+:- pred parse_some_vars_goal(term::in, list(format_component)::in,
maybe3(list(prog_var), list(prog_var), goal)::out,
prog_varset::in, prog_varset::out) is det.
@@ -90,6 +91,7 @@
:- implementation.
:- import_module mdbcomp.prim_data.
+:- import_module parse_tree.mercury_to_mercury.
:- import_module parse_tree.prog_io.
:- import_module parse_tree.prog_io_util.
:- import_module parse_tree.prog_mode.
@@ -101,10 +103,11 @@
:- import_module pair.
:- import_module string.
:- import_module term.
+:- import_module varset.
%-----------------------------------------------------------------------------%
-parse_goal(Term, MaybeGoal, !VarSet) :-
+parse_goal(Term, ContextPieces, MaybeGoal, !VarSet) :-
% We could do some error-checking here, but all errors are picked up
% in either the type-checker or parser anyway.
@@ -120,7 +123,8 @@
(
% Check for builtins...
Term = term.functor(term.atom(Name), Args, Context),
- parse_goal_2(Name, Args, Context, MaybeGoalPrime, !VarSet)
+ parse_goal_2(Name, Args, Context, ContextPieces, MaybeGoalPrime,
+ !VarSet)
->
MaybeGoal = MaybeGoalPrime
;
@@ -142,50 +146,55 @@
%-----------------------------------------------------------------------------%
:- pred parse_goal_2(string::in, list(term)::in, term.context::in,
- maybe1(goal)::out, prog_varset::in, prog_varset::out) is semidet.
+ list(format_component)::in, maybe1(goal)::out,
+ prog_varset::in, prog_varset::out) is semidet.
% Since (A -> B) has different semantics in standard Prolog
% (A -> B ; fail) than it does in NU-Prolog or Mercury (A -> B ; true),
% for the moment we'll just disallow it.
% For consistency we also disallow if-then without the else.
-parse_goal_2("true", [], Context, ok1(true_expr - Context), !VarSet).
-parse_goal_2("fail", [], Context, ok1(fail_expr - Context), !VarSet).
-parse_goal_2("=", [ATerm0, BTerm0], Context, MaybeGoal, !VarSet) :-
+ % XXX We should update ContextPieces as we recurse down.
+parse_goal_2("true", [], Context, _CP, ok1(true_expr - Context), !VarSet).
+parse_goal_2("fail", [], Context, _CP, ok1(fail_expr - Context), !VarSet).
+parse_goal_2("=", [ATerm0, BTerm0], Context, _CP, MaybeGoal, !VarSet) :-
term.coerce(ATerm0, ATerm),
term.coerce(BTerm0, BTerm),
MaybeGoal = ok1(unify_expr(ATerm, BTerm, purity_pure) - Context).
-parse_goal_2(",", [ATerm, BTerm], Context, MaybeGoal, !VarSet) :-
- parse_goal(ATerm, MaybeAGoal, !VarSet),
- parse_goal(BTerm, MaybeBGoal, !VarSet),
+parse_goal_2(",", [ATerm, BTerm], Context, ContextPieces, MaybeGoal,
+ !VarSet) :-
+ parse_goal(ATerm, ContextPieces, MaybeAGoal, !VarSet),
+ parse_goal(BTerm, ContextPieces, MaybeBGoal, !VarSet),
(
MaybeAGoal = ok1(AGoal),
MaybeBGoal = ok1(BGoal)
->
MaybeGoal = ok1(conj_expr(AGoal, BGoal) - Context)
;
- AErrors = get_any_errors1(MaybeAGoal),
- BErrors = get_any_errors1(MaybeBGoal),
- MaybeGoal = error1(AErrors ++ BErrors)
- ).
-parse_goal_2("&", [ATerm, BTerm], Context, MaybeGoal, !VarSet) :-
- parse_goal(ATerm, MaybeAGoal, !VarSet),
- parse_goal(BTerm, MaybeBGoal, !VarSet),
+ ASpecs = get_any_errors1(MaybeAGoal),
+ BSpecs = get_any_errors1(MaybeBGoal),
+ MaybeGoal = error1(ASpecs ++ BSpecs)
+ ).
+parse_goal_2("&", [ATerm, BTerm], Context, ContextPieces, MaybeGoal,
+ !VarSet) :-
+ parse_goal(ATerm, ContextPieces, MaybeAGoal, !VarSet),
+ parse_goal(BTerm, ContextPieces, MaybeBGoal, !VarSet),
(
MaybeAGoal = ok1(AGoal),
MaybeBGoal = ok1(BGoal)
->
MaybeGoal = ok1(par_conj_expr(AGoal, BGoal) - Context)
;
- AErrors = get_any_errors1(MaybeAGoal),
- BErrors = get_any_errors1(MaybeBGoal),
- MaybeGoal = error1(AErrors ++ BErrors)
+ ASpecs = get_any_errors1(MaybeAGoal),
+ BSpecs = get_any_errors1(MaybeBGoal),
+ MaybeGoal = error1(ASpecs ++ BSpecs)
).
-parse_goal_2(";", [ATerm, BTerm], Context, MaybeGoal, !VarSet) :-
+parse_goal_2(";", [ATerm, BTerm], Context, ContextPieces, MaybeGoal,
+ !VarSet) :-
( ATerm = term.functor(term.atom("->"), [XTerm, YTerm], _Context) ->
- parse_some_vars_goal(XTerm, MaybeXGoal, !VarSet),
- parse_goal(YTerm, MaybeYGoal, !VarSet),
- parse_goal(BTerm, MaybeBGoal, !VarSet),
+ parse_some_vars_goal(XTerm, ContextPieces, MaybeXGoal, !VarSet),
+ parse_goal(YTerm, ContextPieces, MaybeYGoal, !VarSet),
+ parse_goal(BTerm, ContextPieces, MaybeBGoal, !VarSet),
(
MaybeXGoal = ok3(Vars, StateVars, XGoal),
MaybeYGoal = ok1(YGoal),
@@ -195,31 +204,32 @@
- Context,
MaybeGoal = ok1(Goal)
;
- XErrors = get_any_errors3(MaybeXGoal),
- YErrors = get_any_errors1(MaybeYGoal),
- BErrors = get_any_errors1(MaybeBGoal),
- MaybeGoal = error1(XErrors ++ YErrors ++ BErrors)
+ XSpecs = get_any_errors3(MaybeXGoal),
+ YSpecs = get_any_errors1(MaybeYGoal),
+ BSpecs = get_any_errors1(MaybeBGoal),
+ MaybeGoal = error1(XSpecs ++ YSpecs ++ BSpecs)
)
;
- parse_goal(ATerm, MaybeAGoal, !VarSet),
- parse_goal(BTerm, MaybeBGoal, !VarSet),
+ parse_goal(ATerm, ContextPieces, MaybeAGoal, !VarSet),
+ parse_goal(BTerm, ContextPieces, MaybeBGoal, !VarSet),
(
MaybeAGoal = ok1(AGoal),
MaybeBGoal = ok1(BGoal)
->
MaybeGoal = ok1(disj_expr(AGoal, BGoal) - Context)
;
- AErrors = get_any_errors1(MaybeAGoal),
- BErrors = get_any_errors1(MaybeBGoal),
- MaybeGoal = error1(AErrors ++ BErrors)
+ ASpecs = get_any_errors1(MaybeAGoal),
+ BSpecs = get_any_errors1(MaybeBGoal),
+ MaybeGoal = error1(ASpecs ++ BSpecs)
)
).
-parse_goal_2("else", [IfTerm, CTerm], Context, MaybeGoal, !VarSet) :-
+parse_goal_2("else", [IfTerm, CTerm], Context, ContextPieces, MaybeGoal,
+ !VarSet) :-
IfTerm = term.functor(term.atom("if"),
[term.functor(term.atom("then"), [ATerm, BTerm], _)], _),
- parse_some_vars_goal(ATerm, MaybeAGoal, !VarSet),
- parse_goal(BTerm, MaybeBGoal, !VarSet),
- parse_goal(CTerm, MaybeCGoal, !VarSet),
+ parse_some_vars_goal(ATerm, ContextPieces, MaybeAGoal, !VarSet),
+ parse_goal(BTerm, ContextPieces, MaybeBGoal, !VarSet),
+ parse_goal(CTerm, ContextPieces, MaybeCGoal, !VarSet),
(
MaybeAGoal = ok3(Vars, StateVars, AGoal),
MaybeBGoal = ok1(BGoal),
@@ -229,13 +239,13 @@
- Context,
MaybeGoal = ok1(Goal)
;
- AErrors = get_any_errors3(MaybeAGoal),
- BErrors = get_any_errors1(MaybeBGoal),
- CErrors = get_any_errors1(MaybeCGoal),
- MaybeGoal = error1(AErrors ++ BErrors ++ CErrors)
+ ASpecs = get_any_errors3(MaybeAGoal),
+ BSpecs = get_any_errors1(MaybeBGoal),
+ CSpecs = get_any_errors1(MaybeCGoal),
+ MaybeGoal = error1(ASpecs ++ BSpecs ++ CSpecs)
).
-parse_goal_2("not", [ATerm], Context, MaybeGoal, !VarSet) :-
- parse_goal(ATerm, MaybeAGoal, !VarSet),
+parse_goal_2("not", [ATerm], Context, ContextPieces, MaybeGoal, !VarSet) :-
+ parse_goal(ATerm, ContextPieces, MaybeAGoal, !VarSet),
(
MaybeAGoal = ok1(AGoal),
MaybeGoal = ok1(not_expr(AGoal) - Context)
@@ -243,8 +253,8 @@
MaybeAGoal = error1(_),
MaybeGoal = MaybeAGoal
).
-parse_goal_2("\\+", [ATerm], Context, MaybeGoal, !VarSet) :-
- parse_goal(ATerm, MaybeAGoal, !VarSet),
+parse_goal_2("\\+", [ATerm], Context, ContextPieces, MaybeGoal, !VarSet) :-
+ parse_goal(ATerm, ContextPieces, MaybeAGoal, !VarSet),
(
MaybeAGoal = ok1(AGoal),
MaybeGoal = ok1(not_expr(AGoal) - Context)
@@ -252,10 +262,14 @@
MaybeAGoal = error1(_),
MaybeGoal = MaybeAGoal
).
-parse_goal_2("all", [QVarsTerm, SubTerm], Context, MaybeGoal, !VarSet) :-
+parse_goal_2("all", [QVarsTerm, SubTerm], Context, ContextPieces, MaybeGoal,
+ !VarSet) :-
% Extract any state variables in the quantifier.
- parse_quantifier_vars(QVarsTerm, MaybeStateVarsAndVars),
- parse_goal(SubTerm, MaybeSubGoal, !VarSet),
+ varset.coerce(!.VarSet, GenericVarSet),
+ parse_quantifier_vars(QVarsTerm, GenericVarSet, ContextPieces,
+ MaybeStateVarsAndVars),
+ % XXX We should update ContextPieces, instead of supplying [].
+ parse_goal(SubTerm, [], MaybeSubGoal, !VarSet),
(
MaybeStateVarsAndVars = ok2(Vars0, StateVars0),
MaybeSubGoal = ok1(SubGoal)
@@ -283,53 +297,61 @@
Goal = GoalExpr - Context,
MaybeGoal = ok1(Goal)
;
- VarsErrors = get_any_errors2(MaybeStateVarsAndVars),
- SubGoalErrors = get_any_errors1(MaybeSubGoal),
- MaybeGoal = error1(VarsErrors ++ SubGoalErrors)
- ).
-parse_goal_2("<=", [ATerm, BTerm], Context, MaybeGoal, !VarSet) :-
- parse_goal(ATerm, MaybeAGoal, !VarSet),
- parse_goal(BTerm, MaybeBGoal, !VarSet),
+ VarsSpecs = get_any_errors2(MaybeStateVarsAndVars),
+ SubGoalSpecs = get_any_errors1(MaybeSubGoal),
+ MaybeGoal = error1(VarsSpecs ++ SubGoalSpecs)
+ ).
+parse_goal_2("<=", [ATerm, BTerm], Context, ContextPieces, MaybeGoal,
+ !VarSet) :-
+ parse_goal(ATerm, ContextPieces, MaybeAGoal, !VarSet),
+ parse_goal(BTerm, ContextPieces, MaybeBGoal, !VarSet),
(
MaybeAGoal = ok1(AGoal),
MaybeBGoal = ok1(BGoal)
->
MaybeGoal = ok1(implies_expr(BGoal, AGoal) - Context)
;
- AErrors = get_any_errors1(MaybeAGoal),
- BErrors = get_any_errors1(MaybeBGoal),
- MaybeGoal = error1(AErrors ++ BErrors)
- ).
-parse_goal_2("=>", [ATerm, BTerm], Context, MaybeGoal, !VarSet) :-
- parse_goal(ATerm, MaybeAGoal, !VarSet),
- parse_goal(BTerm, MaybeBGoal, !VarSet),
+ ASpecs = get_any_errors1(MaybeAGoal),
+ BSpecs = get_any_errors1(MaybeBGoal),
+ MaybeGoal = error1(ASpecs ++ BSpecs)
+ ).
+parse_goal_2("=>", [ATerm, BTerm], Context, ContextPieces, MaybeGoal,
+ !VarSet) :-
+ parse_goal(ATerm, ContextPieces, MaybeAGoal, !VarSet),
+ parse_goal(BTerm, ContextPieces, MaybeBGoal, !VarSet),
(
MaybeAGoal = ok1(AGoal),
MaybeBGoal = ok1(BGoal)
->
MaybeGoal = ok1(implies_expr(AGoal, BGoal) - Context)
;
- AErrors = get_any_errors1(MaybeAGoal),
- BErrors = get_any_errors1(MaybeBGoal),
- MaybeGoal = error1(AErrors ++ BErrors)
- ).
-parse_goal_2("<=>", [ATerm, BTerm], Context, MaybeGoal, !VarSet) :-
- parse_goal(ATerm, MaybeAGoal, !VarSet),
- parse_goal(BTerm, MaybeBGoal, !VarSet),
+ ASpecs = get_any_errors1(MaybeAGoal),
+ BSpecs = get_any_errors1(MaybeBGoal),
+ MaybeGoal = error1(ASpecs ++ BSpecs)
+ ).
+parse_goal_2("<=>", [ATerm, BTerm], Context, ContextPieces, MaybeGoal,
+ !VarSet) :-
+ parse_goal(ATerm, ContextPieces, MaybeAGoal, !VarSet),
+ parse_goal(BTerm, ContextPieces, MaybeBGoal, !VarSet),
(
MaybeAGoal = ok1(AGoal),
MaybeBGoal = ok1(BGoal)
->
MaybeGoal = ok1(equivalent_expr(AGoal, BGoal) - Context)
;
- AErrors = get_any_errors1(MaybeAGoal),
- BErrors = get_any_errors1(MaybeBGoal),
- MaybeGoal = error1(AErrors ++ BErrors)
+ ASpecs = get_any_errors1(MaybeAGoal),
+ BSpecs = get_any_errors1(MaybeBGoal),
+ MaybeGoal = error1(ASpecs ++ BSpecs)
).
-parse_goal_2("some", [QVarsTerm, SubTerm], Context, MaybeGoal, !VarSet) :-
+parse_goal_2("some", [QVarsTerm, SubTerm], Context, ContextPieces, MaybeGoal,
+ !VarSet) :-
% Extract any state variables in the quantifier.
- parse_quantifier_vars(QVarsTerm, MaybeStateVarsAndVars),
- parse_goal(SubTerm, MaybeSubGoal, !VarSet),
+ UpdatedContextPieces = ContextPieces ++ [lower_case_next_if_not_first,
+ words("In first argument of"), quote("some"), suffix(":")],
+ varset.coerce(!.VarSet, GenericVarSet),
+ parse_quantifier_vars(QVarsTerm, GenericVarSet, UpdatedContextPieces,
+ MaybeStateVarsAndVars),
+ parse_goal(SubTerm, ContextPieces, MaybeSubGoal, !VarSet),
(
MaybeStateVarsAndVars = ok2(Vars0, StateVars0),
MaybeSubGoal = ok1(SubGoal)
@@ -358,15 +380,15 @@
Goal = GoalExpr - Context,
MaybeGoal = ok1(Goal)
;
- VarsErrors0 = get_any_errors2(MaybeStateVarsAndVars),
- VarsErrors = assoc_list.map_keys_only(
- string.append("in first argument of some: "), VarsErrors0),
- SubGoalErrors = get_any_errors1(MaybeSubGoal),
- MaybeGoal = error1(VarsErrors ++ SubGoalErrors)
- ).
-parse_goal_2("trace", [ParamsTerm, SubTerm], Context, MaybeGoal, !VarSet) :-
- parse_trace_params(Context, ParamsTerm, MaybeParams),
- parse_goal(SubTerm, MaybeSubGoal, !VarSet),
+ VarsSpecs = get_any_errors2(MaybeStateVarsAndVars),
+ SubGoalSpecs = get_any_errors1(MaybeSubGoal),
+ MaybeGoal = error1(VarsSpecs ++ SubGoalSpecs)
+ ).
+parse_goal_2("trace", [ParamsTerm, SubTerm], Context, ContextPieces, MaybeGoal,
+ !VarSet) :-
+ varset.coerce(!.VarSet, GenericVarSet),
+ parse_trace_params(GenericVarSet, Context, ParamsTerm, MaybeParams),
+ parse_goal(SubTerm, ContextPieces, MaybeSubGoal, !VarSet),
(
MaybeParams = ok1(Params),
MaybeSubGoal = ok1(SubGoal)
@@ -378,16 +400,18 @@
SubGoal),
MaybeGoal = ok1(GoalExpr - Context)
;
- MaybeComponents = error4(Errors),
- MaybeGoal = error1(Errors)
+ MaybeComponents = error4(Specs),
+ MaybeGoal = error1(Specs)
)
;
- ParamsErrors = get_any_errors1(MaybeParams),
- SubGoalErrors = get_any_errors1(MaybeSubGoal),
- MaybeGoal = error1(ParamsErrors ++ SubGoalErrors)
+ ParamsSpecs = get_any_errors1(MaybeParams),
+ SubGoalSpecs = get_any_errors1(MaybeSubGoal),
+ MaybeGoal = error1(ParamsSpecs ++ SubGoalSpecs)
).
-parse_goal_2("atomic", [ParamsTerm, SubTerm], Context, MaybeGoal, !VarSet) :-
- parse_atomic_params(Context, ParamsTerm, MaybeParams),
+parse_goal_2("atomic", [ParamsTerm, SubTerm], Context, _CP, MaybeGoal,
+ !VarSet) :-
+ varset.coerce(!.VarSet, GenericVarSet),
+ parse_atomic_params(Context, ParamsTerm, GenericVarSet, MaybeParams),
parse_atomic_subexpr(SubTerm, MaybeSubGoals, !VarSet),
(
MaybeParams = ok1(Params),
@@ -400,18 +424,20 @@
OrElseGoals),
MaybeGoal = ok1(GoalExpr - Context)
;
- MaybeComponents = error3(Errors),
- MaybeGoal = error1(Errors)
+ MaybeComponents = error3(Specs),
+ MaybeGoal = error1(Specs)
)
;
- ParamsErrors = get_any_errors1(MaybeParams),
- SubGoalErrors = get_any_errors2(MaybeSubGoals),
- MaybeGoal = error1(ParamsErrors ++ SubGoalErrors)
+ ParamsSpecs = get_any_errors1(MaybeParams),
+ SubGoalSpecs = get_any_errors2(MaybeSubGoals),
+ MaybeGoal = error1(ParamsSpecs ++ SubGoalSpecs)
).
parse_goal_2("promise_equivalent_solutions", [VarsTerm, SubTerm], Context,
- MaybeGoal, !VarSet) :-
- parse_vars_and_state_vars(VarsTerm, MaybeVars),
- parse_goal(SubTerm, MaybeSubGoal, !VarSet),
+ ContextPieces, MaybeGoal, !VarSet) :-
+ varset.coerce(!.VarSet, GenericVarSet),
+ parse_vars_and_state_vars(VarsTerm, GenericVarSet, ContextPieces,
+ MaybeVars),
+ parse_goal(SubTerm, ContextPieces, MaybeSubGoal, !VarSet),
(
MaybeVars = ok3(Vars0, DotSVars0, ColonSVars0),
MaybeSubGoal = ok1(SubGoal)
@@ -422,14 +448,16 @@
MaybeGoal = ok1(promise_equivalent_solutions_expr(Vars,
DotSVars, ColonSVars, SubGoal) - Context)
;
- VarsErrors = get_any_errors3(MaybeVars),
- SubGoalErrors = get_any_errors1(MaybeSubGoal),
- MaybeGoal = error1(VarsErrors ++ SubGoalErrors)
+ VarsSpecs = get_any_errors3(MaybeVars),
+ SubGoalSpecs = get_any_errors1(MaybeSubGoal),
+ MaybeGoal = error1(VarsSpecs ++ SubGoalSpecs)
).
parse_goal_2("promise_equivalent_solution_sets", [VarsTerm, SubTerm], Context,
- MaybeGoal, !VarSet) :-
- parse_vars_and_state_vars(VarsTerm, MaybeVars),
- parse_goal(SubTerm, MaybeSubGoal, !VarSet),
+ ContextPieces, MaybeGoal, !VarSet) :-
+ varset.coerce(!.VarSet, GenericVarSet),
+ parse_vars_and_state_vars(VarsTerm, GenericVarSet, ContextPieces,
+ MaybeVars),
+ parse_goal(SubTerm, ContextPieces, MaybeSubGoal, !VarSet),
(
MaybeVars = ok3(Vars0, DotSVars0, ColonSVars0),
MaybeSubGoal = ok1(SubGoal)
@@ -440,13 +468,16 @@
MaybeGoal = ok1(promise_equivalent_solution_sets_expr(Vars,
DotSVars, ColonSVars, SubGoal) - Context)
;
- VarsErrors = get_any_errors3(MaybeVars),
- SubGoalErrors = get_any_errors1(MaybeSubGoal),
- MaybeGoal = error1(VarsErrors ++ SubGoalErrors)
- ).
-parse_goal_2("arbitrary", [VarsTerm, SubTerm], Context, MaybeGoal, !VarSet) :-
- parse_vars_and_state_vars(VarsTerm, MaybeVars),
- parse_goal(SubTerm, MaybeSubGoal, !VarSet),
+ VarsSpecs = get_any_errors3(MaybeVars),
+ SubGoalSpecs = get_any_errors1(MaybeSubGoal),
+ MaybeGoal = error1(VarsSpecs ++ SubGoalSpecs)
+ ).
+parse_goal_2("arbitrary", [VarsTerm, SubTerm], Context,
+ ContextPieces, MaybeGoal, !VarSet) :-
+ varset.coerce(!.VarSet, GenericVarSet),
+ parse_vars_and_state_vars(VarsTerm, GenericVarSet, ContextPieces,
+ MaybeVars),
+ parse_goal(SubTerm, ContextPieces, MaybeSubGoal, !VarSet),
(
MaybeVars = ok3(Vars0, DotSVars0, ColonSVars0),
MaybeSubGoal = ok1(SubGoal)
@@ -457,90 +488,95 @@
MaybeGoal = ok1(promise_equivalent_solution_arbitrary_expr(Vars,
DotSVars, ColonSVars, SubGoal) - Context)
;
- VarsErrors = get_any_errors3(MaybeVars),
- SubGoalErrors = get_any_errors1(MaybeSubGoal),
- MaybeGoal = error1(VarsErrors ++ SubGoalErrors)
+ VarsSpecs = get_any_errors3(MaybeVars),
+ SubGoalSpecs = get_any_errors1(MaybeSubGoal),
+ MaybeGoal = error1(VarsSpecs ++ SubGoalSpecs)
).
-parse_goal_2("promise_pure", [SubTerm], Context, MaybeGoal, !VarSet) :-
- parse_goal(SubTerm, MaybeSubGoal, !VarSet),
+parse_goal_2("promise_pure", [SubTerm], Context, ContextPieces, MaybeGoal,
+ !VarSet) :-
+ parse_goal(SubTerm, ContextPieces, MaybeSubGoal, !VarSet),
(
MaybeSubGoal = ok1(SubGoal),
Goal = promise_purity_expr(dont_make_implicit_promises,
purity_pure, SubGoal) - Context,
MaybeGoal = ok1(Goal)
;
- MaybeSubGoal = error1(Errors),
- MaybeGoal = error1(Errors)
+ MaybeSubGoal = error1(Specs),
+ MaybeGoal = error1(Specs)
).
-parse_goal_2("promise_semipure", [SubTerm], Context, MaybeGoal, !VarSet) :-
- parse_goal(SubTerm, MaybeSubGoal, !VarSet),
+parse_goal_2("promise_semipure", [SubTerm], Context, ContextPieces, MaybeGoal,
+ !VarSet) :-
+ parse_goal(SubTerm, ContextPieces, MaybeSubGoal, !VarSet),
(
MaybeSubGoal = ok1(SubGoal),
Goal = promise_purity_expr(dont_make_implicit_promises,
purity_semipure, SubGoal) - Context,
MaybeGoal = ok1(Goal)
;
- MaybeSubGoal = error1(Errors),
- MaybeGoal = error1(Errors)
+ MaybeSubGoal = error1(Specs),
+ MaybeGoal = error1(Specs)
).
-parse_goal_2("promise_impure", [SubTerm], Context, MaybeGoal, !VarSet) :-
- parse_goal(SubTerm, MaybeSubGoal, !VarSet),
+parse_goal_2("promise_impure", [SubTerm], Context, ContextPieces, MaybeGoal,
+ !VarSet) :-
+ parse_goal(SubTerm, ContextPieces, MaybeSubGoal, !VarSet),
(
MaybeSubGoal = ok1(SubGoal),
Goal = promise_purity_expr(dont_make_implicit_promises,
purity_impure, SubGoal) - Context,
MaybeGoal = ok1(Goal)
;
- MaybeSubGoal = error1(Errors),
- MaybeGoal = error1(Errors)
+ MaybeSubGoal = error1(Specs),
+ MaybeGoal = error1(Specs)
).
-parse_goal_2("promise_pure_implicit", [SubTerm], Context, MaybeGoal,
- !VarSet) :-
- parse_goal(SubTerm, MaybeSubGoal, !VarSet),
+parse_goal_2("promise_pure_implicit", [SubTerm], Context, ContextPieces,
+ MaybeGoal, !VarSet) :-
+ parse_goal(SubTerm, ContextPieces, MaybeSubGoal, !VarSet),
(
MaybeSubGoal = ok1(SubGoal),
Goal = promise_purity_expr(make_implicit_promises,
purity_pure, SubGoal) - Context,
MaybeGoal = ok1(Goal)
;
- MaybeSubGoal = error1(Errors),
- MaybeGoal = error1(Errors)
+ MaybeSubGoal = error1(Specs),
+ MaybeGoal = error1(Specs)
).
-parse_goal_2("promise_semipure_implicit", [SubTerm], Context, MaybeGoal,
- !VarSet) :-
- parse_goal(SubTerm, MaybeSubGoal, !VarSet),
+parse_goal_2("promise_semipure_implicit", [SubTerm], Context, ContextPieces,
+ MaybeGoal, !VarSet) :-
+ parse_goal(SubTerm, ContextPieces, MaybeSubGoal, !VarSet),
(
MaybeSubGoal = ok1(SubGoal),
Goal = promise_purity_expr(make_implicit_promises,
purity_semipure, SubGoal) - Context,
MaybeGoal = ok1(Goal)
;
- MaybeSubGoal = error1(Errors),
- MaybeGoal = error1(Errors)
+ MaybeSubGoal = error1(Specs),
+ MaybeGoal = error1(Specs)
).
-parse_goal_2("promise_impure_implicit", [SubTerm], Context, MaybeGoal,
- !VarSet) :-
- parse_goal(SubTerm, MaybeSubGoal, !VarSet),
+parse_goal_2("promise_impure_implicit", [SubTerm], Context, ContextPieces,
+ MaybeGoal, !VarSet) :-
+ parse_goal(SubTerm, ContextPieces, MaybeSubGoal, !VarSet),
(
MaybeSubGoal = ok1(SubGoal),
Goal = promise_purity_expr(make_implicit_promises,
purity_impure, SubGoal) - Context,
MaybeGoal = ok1(Goal)
;
- MaybeSubGoal = error1(Errors),
- MaybeGoal = error1(Errors)
+ MaybeSubGoal = error1(Specs),
+ MaybeGoal = error1(Specs)
).
-parse_goal_2("impure", [SubTerm], Context, MaybeGoal, !VarSet) :-
- parse_goal_with_purity(SubTerm, purity_impure, Context, MaybeGoal,
- !VarSet).
-parse_goal_2("semipure", [SubTerm], Context, MaybeGoal, !VarSet) :-
- parse_goal_with_purity(SubTerm, purity_semipure, Context, MaybeGoal,
- !VarSet).
-parse_goal_2("event", [SubTerm], Context, MaybeGoal, !VarSet) :-
- parse_goal(SubTerm, MaybeSubGoal, !VarSet),
+parse_goal_2("impure", [SubTerm], Context, ContextPieces,
+ MaybeGoal, !VarSet) :-
+ parse_goal_with_purity(SubTerm, purity_impure, Context, ContextPieces,
+ MaybeGoal, !VarSet).
+parse_goal_2("semipure", [SubTerm], Context, ContextPieces,
+ MaybeGoal, !VarSet) :-
+ parse_goal_with_purity(SubTerm, purity_semipure, Context, ContextPieces,
+ MaybeGoal, !VarSet).
+parse_goal_2("event", [SubTerm], Context, ContextPieces, MaybeGoal, !VarSet) :-
+ parse_goal(SubTerm, ContextPieces, MaybeSubGoal, !VarSet),
(
MaybeSubGoal = ok1(SubGoal),
- ( SubGoal = call_expr(SymName, Args, Purity) - _SubContext ->
+ ( SubGoal = call_expr(SymName, Args, Purity) - SubContext ->
(
SymName = unqualified(EventName),
Purity = purity_pure
@@ -548,35 +584,52 @@
Goal = event_expr(EventName, Args) - Context,
MaybeGoal = ok1(Goal)
;
- some [!Errors] (
- !:Errors = [],
- ( SymName = unqualified(_) ->
- true
- ;
- SymNameMsg = "event name must not be qualified",
- SymNameError = SymNameMsg - SubTerm,
- !:Errors = [SymNameError | !.Errors]
+ some [!Specs] (
+ !:Specs = [],
+ (
+ SymName = unqualified(_)
+ ;
+ SymName = qualified(_, _),
+ QualPieces = ContextPieces ++
+ [lower_case_next_if_not_first,
+ words("Error: event name must not be qualified."),
+ nl],
+ QualSpec = error_spec(severity_error,
+ phase_term_to_parse_tree,
+ [simple_msg(SubContext, [always(QualPieces)])]),
+ !:Specs = [QualSpec | !.Specs]
),
- ( Purity = purity_pure ->
- true
+ (
+ Purity = purity_pure
;
- PurityMsg = "event cannot be impure or semipure",
- PurityError = PurityMsg - SubTerm,
- !:Errors = [PurityError | !.Errors]
+ ( Purity = purity_semipure
+ ; Purity = purity_impure
),
- MaybeGoal = error1(!.Errors)
+ PurityPieces = ContextPieces ++
+ [lower_case_next_if_not_first,
+ words("Error: event cannot be"),
+ words("impure or semipure."), nl],
+ PuritySpec = error_spec(severity_error,
+ phase_term_to_parse_tree,
+ [simple_msg(SubContext, [always(PurityPieces)])]),
+ !:Specs = [PuritySpec | !.Specs]
+ ),
+ MaybeGoal = error1(!.Specs)
)
)
;
- Msg = "event prefix must not precede anything other than a call",
- Error = Msg - SubTerm,
- MaybeGoal = error1([Error])
+ Pieces = ContextPieces ++ [lower_case_next_if_not_first,
+ words("Error: event prefix must not precede anything"),
+ words("other than a call."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(SubTerm), [always(Pieces)])]),
+ MaybeGoal = error1([Spec])
)
;
- MaybeSubGoal = error1(Errors),
- MaybeGoal = error1(Errors)
+ MaybeSubGoal = error1(Specs),
+ MaybeGoal = error1(Specs)
).
-parse_goal_2("is", [ATerm0, BTerm0], Context, MaybeGoal, !VarSet) :-
+parse_goal_2("is", [ATerm0, BTerm0], Context, _CP, MaybeGoal, !VarSet) :-
% The following is a temporary hack to handle `is' in the parser -
% we ought to handle it in the code generation - but then `is/2' itself
% is a bit of a hack.
@@ -585,10 +638,12 @@
MaybeGoal = ok1(unify_expr(ATerm, BTerm, purity_pure) - Context).
:- pred parse_goal_with_purity(term::in, purity::in, context::in,
- maybe1(goal)::out, prog_varset::in, prog_varset::out) is det.
+ list(format_component)::in, maybe1(goal)::out,
+ prog_varset::in, prog_varset::out) is det.
-parse_goal_with_purity(Term, Purity, Context, MaybeGoal, !VarSet) :-
- parse_goal(Term, MaybeSubGoal, !VarSet),
+parse_goal_with_purity(Term, Purity, Context, ContextPieces, MaybeGoal,
+ !VarSet) :-
+ parse_goal(Term, ContextPieces, MaybeSubGoal, !VarSet),
(
MaybeSubGoal = ok1(SubGoal),
SubGoal = SubGoalExpr - _SubContext,
@@ -615,15 +670,19 @@
%-----------------------------------------------------------------------------%
-parse_some_vars_goal(Term, MaybeVarsAndGoal, !VarSet) :-
+parse_some_vars_goal(Term, ContextPieces, MaybeVarsAndGoal, !VarSet) :-
( Term = term.functor(term.atom("some"), [QVarsTerm, SubTerm], _Context) ->
- parse_quantifier_vars(QVarsTerm, MaybeVars),
+ UpdatedContextPieces = ContextPieces ++ [lower_case_next_if_not_first,
+ words("In first argument of"), quote("some"), suffix(":")],
+ varset.coerce(!.VarSet, GenericVarSet),
+ parse_quantifier_vars(QVarsTerm, GenericVarSet, UpdatedContextPieces,
+ MaybeVars),
GoalTerm = SubTerm
;
MaybeVars = ok2([], []),
GoalTerm = Term
),
- parse_goal(GoalTerm, MaybeGoal, !VarSet),
+ parse_goal(GoalTerm, ContextPieces, MaybeGoal, !VarSet),
(
MaybeVars = ok2(Vars0, StateVars0),
MaybeGoal = ok1(Goal)
@@ -632,11 +691,9 @@
list.map(term.coerce_var, StateVars0, StateVars),
MaybeVarsAndGoal = ok3(Vars, StateVars, Goal)
;
- VarsErrors0 = get_any_errors2(MaybeVars),
- VarsErrors = assoc_list.map_keys_only(
- string.append("in first argument of some: "), VarsErrors0),
- GoalErrors = get_any_errors1(MaybeGoal),
- MaybeVarsAndGoal = error3(VarsErrors ++ GoalErrors)
+ VarsSpecs = get_any_errors2(MaybeVars),
+ GoalSpecs = get_any_errors1(MaybeGoal),
+ MaybeVarsAndGoal = error3(VarsSpecs ++ GoalSpecs)
).
%-----------------------------------------------------------------------------%
@@ -647,66 +704,69 @@
; trace_component_maybe_io(prog_var)
; trace_component_mutable_var(trace_mutable_var).
-:- pred parse_trace_params(context::in, term::in,
- maybe1(assoc_list(trace_component, term))::out) is det.
+:- pred parse_trace_params(varset::in, context::in, term::in,
+ maybe1(assoc_list(trace_component, term.context))::out) is det.
-parse_trace_params(Context, Term, MaybeComponentsTerms) :-
+parse_trace_params(VarSet, Context, Term, MaybeComponentsContexts) :-
( Term = term.functor(term.atom("[]"), [], _) ->
- MaybeComponentsTerms = ok1([])
+ MaybeComponentsContexts = ok1([])
; Term = term.functor(term.atom("[|]"), [HeadTerm, TailTerm], _) ->
- parse_trace_component(Term, HeadTerm, MaybeHeadComponent),
- parse_trace_params(Context, TailTerm, MaybeTailComponentsTerms),
+ parse_trace_component(VarSet, Term, HeadTerm,
+ MaybeHeadComponentContext),
+ parse_trace_params(VarSet, Context, TailTerm,
+ MaybeTailComponentsContexts),
(
- MaybeHeadComponent = ok1(HeadComponent),
- MaybeTailComponentsTerms = ok1(TailComponentsTerms)
+ MaybeHeadComponentContext = ok1(HeadComponentContext),
+ MaybeTailComponentsContexts = ok1(TailComponentsContexts)
->
- MaybeComponentsTerms = ok1([HeadComponent | TailComponentsTerms])
+ MaybeComponentsContexts =
+ ok1([HeadComponentContext | TailComponentsContexts])
;
- HeadErrors = get_any_errors1(MaybeHeadComponent),
- TailErrors = get_any_errors1(MaybeTailComponentsTerms),
- MaybeComponentsTerms = error1(HeadErrors ++ TailErrors)
+ HeadSpecs = get_any_errors1(MaybeHeadComponentContext),
+ TailSpecs = get_any_errors1(MaybeTailComponentsContexts),
+ MaybeComponentsContexts = error1(HeadSpecs ++ TailSpecs)
)
;
- (
- Term = term.functor(_, _, _),
- Msg = "invalid trace goal parameter",
- MaybeComponentsTerms = error1([Msg - Term])
- ;
- Term = term.variable(_, _),
- Msg = "expected trace goal parameter, found variable",
- ErrorTerm = term.functor(term.atom(""), [], Context),
- MaybeComponentsTerms = error1([Msg - ErrorTerm])
- )
+ TermStr = describe_error_term(VarSet, Term),
+ Pieces = [words("Error: invalid trace goal paramater"),
+ quote(TermStr), suffix("."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(Term), [always(Pieces)])]),
+ MaybeComponentsContexts = error1([Spec])
).
-:- pred parse_trace_component(term::in, term::in,
- maybe1(pair(trace_component, term))::out) is det.
+:- pred parse_trace_component(varset::in, term::in, term::in,
+ maybe1(pair(trace_component, term.context))::out) is det.
-parse_trace_component(ErrorTerm, Term, MaybeComponentTerm) :-
+parse_trace_component(VarSet, _ErrorTerm, Term, MaybeComponentContext) :-
(
- Term = term.functor(Functor, SubTerms, _),
- ( Functor = term.atom(Atom) ->
+ Term = term.functor(Functor, SubTerms, Context),
+ Functor = term.atom(Atom)
+ ->
(
( Atom = "compiletime"
; Atom = "compile_time"
)
->
( SubTerms = [SubTerm] ->
- parse_trace_tree(parse_trace_compiletime(Term), SubTerm,
+ parse_trace_tree(parse_trace_compiletime(VarSet), SubTerm,
MaybeCompileTime),
(
MaybeCompileTime = ok1(CompileTime),
Component = trace_component_compiletime(CompileTime),
- MaybeComponentTerm = ok1(Component - Term)
+ MaybeComponentContext = ok1(Component - Context)
;
- MaybeCompileTime = error1(Errors),
- MaybeComponentTerm = error1(Errors)
+ MaybeCompileTime = error1(Specs),
+ MaybeComponentContext = error1(Specs)
)
;
- Msg = Atom ++ " takes exactly one argument, " ++
- "which should be a boolean expression " ++
- "of compile-time tests",
- MaybeComponentTerm = error1([Msg - Term])
+ Pieces = [words("Error:"), fixed(Atom),
+ words("takes exactly one argument,"),
+ words("which should be a boolean expression"),
+ words("of compile-time tests."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(Context, [always(Pieces)])]),
+ MaybeComponentContext = error1([Spec])
)
;
( Atom = "runtime"
@@ -714,21 +774,24 @@
)
->
( SubTerms = [SubTerm] ->
- parse_trace_tree(parse_trace_runtime(Term), SubTerm,
+ parse_trace_tree(parse_trace_runtime(VarSet), SubTerm,
MaybeRunTime),
(
MaybeRunTime = ok1(RunTime),
Component = trace_component_runtime(RunTime),
- MaybeComponentTerm = ok1(Component - Term)
+ MaybeComponentContext = ok1(Component - Context)
;
- MaybeRunTime = error1(Errors),
- MaybeComponentTerm = error1(Errors)
+ MaybeRunTime = error1(Specs),
+ MaybeComponentContext = error1(Specs)
)
;
- Msg = Atom ++ " takes exactly one argument, " ++
- "which should be a boolean expression " ++
- "of run-time tests",
- MaybeComponentTerm = error1([Msg - Term])
+ Pieces = [words("Error:"), fixed(Atom),
+ words("takes exactly one argument,"),
+ words("which should be a boolean expression"),
+ words("of run-time tests."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(Context, [always(Pieces)])]),
+ MaybeComponentContext = error1([Spec])
)
;
Atom = "io"
@@ -740,16 +803,23 @@
->
term.coerce_var(Var, ProgVar),
Component = trace_component_maybe_io(ProgVar),
- MaybeComponentTerm = ok1(Component - Term)
+ MaybeComponentContext = ok1(Component - Context)
;
- Msg = "the argument of " ++ Atom ++ " should be" ++
- " a state variable",
- MaybeComponentTerm = error1([Msg - SubTerm])
- )
- ;
- Msg = Atom ++ " takes exactly one argument, " ++
- "which should be a state variable name",
- MaybeComponentTerm = error1([Msg - Term])
+ Pieces = [words("Error: the argument of"), fixed(Atom),
+ words("should be a state variable."), nl],
+ Spec = error_spec(severity_error,
+ phase_term_to_parse_tree,
+ [simple_msg(get_term_context(SubTerm),
+ [always(Pieces)])]),
+ MaybeComponentContext = error1([Spec])
+ )
+ ;
+ Pieces = [words("Error:"), fixed(Atom),
+ words("takes exactly one argument,"),
+ words("which should be a state variable name."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(Context, [always(Pieces)])]),
+ MaybeComponentContext = error1([Spec])
)
;
Atom = "state"
@@ -758,16 +828,14 @@
( SubTermA = term.functor(term.atom(MutableName), [], _) ->
MaybeMutable = ok1(MutableName)
;
- (
- SubTermA = term.functor(_, _, _),
- MutableErrorTerm = SubTermA
- ;
- SubTermA = term.variable(_, _),
- MutableErrorTerm = Term
- ),
- MutableMsg = "the first argument of " ++ Atom ++
- " should be the name of a mutable variable",
- MaybeMutable = error1([MutableMsg - MutableErrorTerm])
+ MutablePieces = [words("Error: the first argument of"),
+ fixed(Atom), words("should be"),
+ words("the name of a mutable variable."), nl],
+ MutableSpec = error_spec(severity_error,
+ phase_term_to_parse_tree,
+ [simple_msg(get_term_context(SubTermA),
+ [always(MutablePieces)])]),
+ MaybeMutable = error1([MutableSpec])
),
(
SubTermB = term.functor(term.atom("!"),
@@ -775,16 +843,14 @@
->
MaybeVar = ok1(Var)
;
- (
- SubTermB = term.functor(_, _, _),
- VarErrorTerm = SubTermB
- ;
- SubTermB = term.variable(_, _),
- VarErrorTerm = Term
- ),
- VarMsg = "the second argument of " ++ Atom ++
- " should be a state variable",
- MaybeVar = error1([VarMsg - VarErrorTerm])
+ VarPieces = [words("Error: the second argument of"),
+ fixed(Atom), words("should be"),
+ words("a state variable name."), nl],
+ VarSpec = error_spec(severity_error,
+ phase_term_to_parse_tree,
+ [simple_msg(get_term_context(SubTermB),
+ [always(VarPieces)])]),
+ MaybeVar = error1([VarSpec])
),
(
MaybeMutable = ok1(FinalMutable),
@@ -793,30 +859,38 @@
term.coerce_var(FinalVar, ProgVar),
MutableVar = trace_mutable_var(FinalMutable, ProgVar),
Component = trace_component_mutable_var(MutableVar),
- MaybeComponentTerm = ok1(Component - Term)
- ;
- VarErrors = get_any_errors1(MaybeVar),
- MutableErrors = get_any_errors1(MaybeMutable),
- MaybeComponentTerm = error1(VarErrors ++ MutableErrors)
- )
- ;
- Msg = Atom ++ " takes exactly two arguments, " ++
- "which should be the name of a mutable variable " ++
- "and a state variable name",
- MaybeComponentTerm = error1([Msg - Term])
- )
- ;
- Msg = "invalid trace goal parameter",
- MaybeComponentTerm = error1([Msg - Term])
- )
- ;
- Msg = "invalid trace goal parameter",
- MaybeComponentTerm = error1([Msg - Term])
- )
+ MaybeComponentContext = ok1(Component - Context)
;
- Term = term.variable(_, _),
- Msg = "expected trace goal parameter, found variable",
- MaybeComponentTerm = error1([Msg - ErrorTerm])
+ VarSpecs = get_any_errors1(MaybeVar),
+ MutableSpecs = get_any_errors1(MaybeMutable),
+ MaybeComponentContext =
+ error1(VarSpecs ++ MutableSpecs)
+ )
+ ;
+ Pieces = [words("Error:"), fixed(Atom),
+ words("takes exactly two arguments,"),
+ words("which should be"),
+ words("the name of a mutable variable"),
+ words("and a state variable name."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(Context, [always(Pieces)])]),
+ MaybeComponentContext = error1([Spec])
+ )
+ ;
+ TermStr = describe_error_term(VarSet, Term),
+ Pieces = [words("Error: invalid trace goal paramater"),
+ quote(TermStr), suffix("."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(Context, [always(Pieces)])]),
+ MaybeComponentContext = error1([Spec])
+ )
+ ;
+ TermStr = describe_error_term(VarSet, Term),
+ Pieces = [words("Error: invalid trace goal paramater"),
+ quote(TermStr), suffix("."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(Term), [always(Pieces)])]),
+ MaybeComponentContext = error1([Spec])
).
:- pred parse_trace_tree(pred(term, maybe1(T))::in(pred(in, out) is det),
@@ -841,9 +915,9 @@
->
MaybeTree = ok1(trace_op(Op, LExpr, RExpr))
;
- LErrors = get_any_errors1(MaybeLExpr),
- RErrors = get_any_errors1(MaybeRExpr),
- MaybeTree = error1(LErrors ++ RErrors)
+ LSpecs = get_any_errors1(MaybeLExpr),
+ RSpecs = get_any_errors1(MaybeRExpr),
+ MaybeTree = error1(LSpecs ++ RSpecs)
)
;
Term = term.functor(term.atom("not"), [SubTerm], _)
@@ -854,8 +928,8 @@
->
MaybeTree = ok1(trace_not(SubExpr))
;
- SubErrors = get_any_errors1(MaybeSubExpr),
- MaybeTree = error1(SubErrors)
+ SubSpecs = get_any_errors1(MaybeSubExpr),
+ MaybeTree = error1(SubSpecs)
)
;
BaseParser(Term, MaybeBase),
@@ -863,32 +937,39 @@
MaybeBase = ok1(Base),
MaybeTree = ok1(trace_base(Base))
;
- MaybeBase = error1(Errors),
- MaybeTree = error1(Errors)
+ MaybeBase = error1(Specs),
+ MaybeTree = error1(Specs)
)
).
-:- pred parse_trace_compiletime(term::in, term::in,
+:- pred parse_trace_compiletime(varset::in, term::in,
maybe1(trace_compiletime)::out) is det.
-parse_trace_compiletime(ErrorTerm, Term, MaybeCompiletime) :-
+parse_trace_compiletime(VarSet, Term, MaybeCompiletime) :-
(
- Term = term.functor(Functor, SubTerms, _),
- ( Functor = term.atom(Atom) ->
+ Term = term.functor(Functor, SubTerms, TermContext),
+ Functor = term.atom(Atom)
+ ->
( Atom = "flag" ->
( SubTerms = [SubTerm] ->
( SubTerm = term.functor(term.string(FlagName), [], _) ->
Compiletime = trace_flag(FlagName),
MaybeCompiletime = ok1(Compiletime)
;
- Msg = "compile_time parameter `flag'" ++
- "takes a string as argument",
- MaybeCompiletime = error1([Msg - Term])
+ Pieces = [words("Error: compile_time paramater"),
+ quote("flag"),
+ words("takes a string as argument."), nl],
+ Spec = error_spec(severity_error,
+ phase_term_to_parse_tree,
+ [simple_msg(TermContext, [always(Pieces)])]),
+ MaybeCompiletime = error1([Spec])
)
;
- Msg = "compile_time parameter `flag'" ++
- "takes just one argument",
- MaybeCompiletime = error1([Msg - Term])
+ Pieces = [words("Error: compile_time paramater"),
+ quote("flag"), words("takes just one argument."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(TermContext, [always(Pieces)])]),
+ MaybeCompiletime = error1([Spec])
)
; Atom = "grade" ->
( SubTerms = [SubTerm] ->
@@ -899,14 +980,21 @@
Compiletime = trace_grade(trace_grade_debug),
MaybeCompiletime = ok1(Compiletime)
;
- Msg = "compile_time parameter `grade' " ++
- "takes just `debug' as argument (for now)",
- MaybeCompiletime = error1([Msg - Term])
+ Pieces = [words("compile_time paramater"),
+ quote("grade"), words("takes just"),
+ quote("debug"), words("as argument (for now)."),
+ nl],
+ Spec = error_spec(severity_error,
+ phase_term_to_parse_tree,
+ [simple_msg(TermContext, [always(Pieces)])]),
+ MaybeCompiletime = error1([Spec])
)
;
- Msg = "compile_time parameter `grade'" ++
- "takes just one argument",
- MaybeCompiletime = error1([Msg - Term])
+ Pieces = [words("Error: compile_time paramater"),
+ quote("grade"), words("takes just one argument."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(TermContext, [always(Pieces)])]),
+ MaybeCompiletime = error1([Spec])
)
; Atom = "tracelevel" ->
( SubTerms = [SubTerm] ->
@@ -923,79 +1011,92 @@
Compiletime = trace_trace_level(Level),
MaybeCompiletime = ok1(Compiletime)
;
- Msg = "compile_time parameter `tracelevel' " ++
- "takes just `shallow' or `deep' as argument",
- MaybeCompiletime = error1([Msg - Term])
- )
- ;
- Msg = "compile_time parameter `tracelevel'" ++
- "takes just one argument",
- MaybeCompiletime = error1([Msg - Term])
- )
- ;
- Msg = "invalid compile_time parameter",
- MaybeCompiletime = error1([Msg - Term])
- )
- ;
- Msg = "invalid compile_time parameter",
- MaybeCompiletime = error1([Msg - Term])
- )
- ;
- Term = term.variable(_, _),
- Msg = "expected compile_time parameter, found variable",
- MaybeCompiletime = error1([Msg - ErrorTerm])
+ Pieces = [words("Error: compile_time paramater"),
+ quote("tracelevel"), words("takes just"),
+ quote("shallow"), words("or"), quote("deep"),
+ words("as argument."), nl],
+ Spec = error_spec(severity_error,
+ phase_term_to_parse_tree,
+ [simple_msg(TermContext, [always(Pieces)])]),
+ MaybeCompiletime = error1([Spec])
+ )
+ ;
+ Pieces = [words("Error: compile_time paramater"),
+ quote("tracelevel"),
+ words("takes just one argument."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(TermContext, [always(Pieces)])]),
+ MaybeCompiletime = error1([Spec])
+ )
+ ;
+ TermStr = describe_error_term(VarSet, Term),
+ Pieces = [words("Error: invalid compile_time paramater"),
+ quote(TermStr), suffix("."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(TermContext, [always(Pieces)])]),
+ MaybeCompiletime = error1([Spec])
+ )
+ ;
+ TermStr = describe_error_term(VarSet, Term),
+ Pieces = [words("Error: invalid compile_time paramater"),
+ quote(TermStr), suffix("."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(Term), [always(Pieces)])]),
+ MaybeCompiletime = error1([Spec])
).
-:- pred parse_trace_runtime(term::in, term::in,
+:- pred parse_trace_runtime(varset::in, term::in,
maybe1(trace_runtime)::out) is det.
-parse_trace_runtime(ErrorTerm, Term, MaybeRuntime) :-
+parse_trace_runtime(VarSet, Term, MaybeRuntime) :-
(
- Term = term.functor(Functor, SubTerms, _),
- ( Functor = term.atom(Atom) ->
+ Term = term.functor(Functor, SubTerms, TermContext),
+ Functor = term.atom(Atom)
+ ->
( Atom = "env" ->
( SubTerms = [SubTerm] ->
(
SubTerm = term.functor(SubFunctor, [], _),
( SubFunctor = term.string(EnvVarName)
; SubFunctor = term.atom(EnvVarName)
- )
- ->
+ ),
EnvVarChars = string.to_char_list(EnvVarName),
- (
list.filter(env_var_is_acceptable_char,
EnvVarChars, _, [])
->
Runtime = trace_envvar(EnvVarName),
MaybeRuntime = ok1(Runtime)
;
- Msg = "run_time parameter `env'" ++
- "takes an identifier as argument",
- MaybeRuntime = error1([Msg - SubTerm])
- )
- ;
- Msg = "run_time parameter `env'" ++
- "takes an identifier as argument",
- MaybeRuntime = error1([Msg - Term])
- )
- ;
- Msg = "run_time parameter `env' takes just one argument",
- MaybeRuntime = error1([Msg - Term])
- )
- ;
- Term = term.functor(_, _, _),
- Msg = "invalid run_time parameter; expected env(\"ENVVAR\")",
- MaybeRuntime = error1([Msg - Term])
- )
- ;
- Term = term.functor(_, _, _),
- Msg = "invalid run_time parameter; expected env(\"ENVVAR\")",
- MaybeRuntime = error1([Msg - Term])
- )
- ;
- Term = term.variable(_, _),
- Msg = "expected run_time parameter, found variable",
- MaybeRuntime = error1([Msg - ErrorTerm])
+ Pieces = [words("Error: run_time paramater"), quote("env"),
+ words("takes an identifier as argument."), nl],
+ Spec = error_spec(severity_error,
+ phase_term_to_parse_tree,
+ [simple_msg(get_term_context(SubTerm),
+ [always(Pieces)])]),
+ MaybeRuntime = error1([Spec])
+ )
+ ;
+ Pieces = [words("Error: run_time paramater"), quote("env"),
+ words("takes just one argument."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(TermContext, [always(Pieces)])]),
+ MaybeRuntime = error1([Spec])
+ )
+ ;
+ TermStr = describe_error_term(VarSet, Term),
+ Pieces = [words("Error: invalid run_time paramater"),
+ quote(TermStr), suffix("."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(TermContext, [always(Pieces)])]),
+ MaybeRuntime = error1([Spec])
+ )
+ ;
+ TermStr = describe_error_term(VarSet, Term),
+ Pieces = [words("Error: invalid run_time paramater"),
+ quote(TermStr), suffix("."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(Term), [always(Pieces)])]),
+ MaybeRuntime = error1([Spec])
).
:- pred env_var_is_acceptable_char(char::in) is semidet.
@@ -1009,7 +1110,7 @@
Char = '_'
).
-:- pred convert_trace_params(assoc_list(trace_component, term)::in,
+:- pred convert_trace_params(assoc_list(trace_component, term.context)::in,
maybe4(maybe(trace_expr(trace_compiletime)),
maybe(trace_expr(trace_runtime)), maybe(prog_var),
list(trace_mutable_var))::out) is det.
@@ -1017,27 +1118,27 @@
convert_trace_params(Components, MaybeParams) :-
convert_trace_params_2(Components, no, no, no, [], [], MaybeParams).
-:- pred convert_trace_params_2(assoc_list(trace_component, term)::in,
+:- pred convert_trace_params_2(assoc_list(trace_component, term.context)::in,
maybe(trace_expr(trace_compiletime))::in,
maybe(trace_expr(trace_runtime))::in,
maybe(prog_var)::in, list(trace_mutable_var)::in,
- assoc_list(string, term)::in,
+ list(error_spec)::in,
maybe4(maybe(trace_expr(trace_compiletime)),
maybe(trace_expr(trace_runtime)), maybe(prog_var),
list(trace_mutable_var))::out) is det.
convert_trace_params_2([], MaybeCompileTime, MaybeRunTime, MaybeIO,
- MutableVars, Errors, MaybeParams) :-
+ MutableVars, Specs, MaybeParams) :-
(
- Errors = [],
+ Specs = [],
MaybeParams = ok4(MaybeCompileTime, MaybeRunTime, MaybeIO, MutableVars)
;
- Errors = [_ | _],
- MaybeParams = error4(Errors)
+ Specs = [_ | _],
+ MaybeParams = error4(Specs)
).
-convert_trace_params_2([Component - Term | ComponentsTerms],
+convert_trace_params_2([Component - Context | ComponentsContexts],
!.MaybeCompileTime, !.MaybeRunTime, !.MaybeIO, !.MutableVars,
- !.Errors, MaybeParams) :-
+ !.Specs, MaybeParams) :-
(
Component = trace_component_compiletime(CompileTime),
(
@@ -1045,8 +1146,10 @@
!:MaybeCompileTime = yes(CompileTime)
;
!.MaybeCompileTime = yes(_),
- Msg = "duplicate compile_time trace parameter",
- !:Errors = !.Errors ++ [Msg - Term]
+ Pieces = [words("Duplicate compile_time trace parameter."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(Context, [always(Pieces)])]),
+ !:Specs = [Spec | !.Specs]
)
;
Component = trace_component_runtime(RunTime),
@@ -1055,8 +1158,10 @@
!:MaybeRunTime = yes(RunTime)
;
!.MaybeRunTime = yes(_),
- Msg = "duplicate run_time trace parameter",
- !:Errors = !.Errors ++ [Msg - Term]
+ Pieces = [words("Duplicate run_time trace parameter."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(Context, [always(Pieces)])]),
+ !:Specs = [Spec | !.Specs]
)
;
Component = trace_component_maybe_io(IOStateVar),
@@ -1065,15 +1170,17 @@
!:MaybeIO = yes(IOStateVar)
;
!.MaybeIO = yes(_),
- Msg = "duplicate io trace parameter",
- !:Errors = !.Errors ++ [Msg - Term]
+ Pieces = [words("Duplicate io trace parameter."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(Context, [always(Pieces)])]),
+ !:Specs = [Spec | !.Specs]
)
;
Component = trace_component_mutable_var(MutableVar),
!:MutableVars = !.MutableVars ++ [MutableVar]
),
- convert_trace_params_2(ComponentsTerms, !.MaybeCompileTime,
- !.MaybeRunTime, !.MaybeIO, !.MutableVars, !.Errors, MaybeParams).
+ convert_trace_params_2(ComponentsContexts, !.MaybeCompileTime,
+ !.MaybeRunTime, !.MaybeIO, !.MutableVars, !.Specs, MaybeParams).
%-----------------------------------------------------------------------------%
@@ -1082,92 +1189,88 @@
; atomic_component_outer(atomic_component_state)
; atomic_component_vars(list(prog_var)).
-:- pred parse_atomic_params(context::in, term::in,
- maybe1(assoc_list(atomic_component, term))::out) is det.
+:- pred parse_atomic_params(context::in, term::in, varset::in,
+ maybe1(assoc_list(atomic_component, term.context))::out) is det.
-parse_atomic_params(Context, Term, MaybeComponentsTerms) :-
+parse_atomic_params(Context, Term, VarSet, MaybeComponentsContexts) :-
( Term = term.functor(term.atom("[]"), [], _) ->
- MaybeComponentsTerms = ok1([])
+ MaybeComponentsContexts = ok1([])
; Term = term.functor(term.atom("[|]"), [HeadTerm, TailTerm], _) ->
- parse_atomic_component(Term, HeadTerm, MaybeHeadComponent),
- parse_atomic_params(Context, TailTerm, MaybeTailComponentsTerms),
+ parse_atomic_component(Term, HeadTerm, VarSet, MaybeHeadComponent),
+ parse_atomic_params(Context, TailTerm, VarSet,
+ MaybeTailComponentsContexts),
(
MaybeHeadComponent = ok1(HeadComponent),
- MaybeTailComponentsTerms = ok1(TailComponentsTerms)
+ MaybeTailComponentsContexts = ok1(TailComponentsContexts)
->
- MaybeComponentsTerms = ok1([HeadComponent | TailComponentsTerms])
+ MaybeComponentsContexts =
+ ok1([HeadComponent | TailComponentsContexts])
;
- HeadErrors = get_any_errors1(MaybeHeadComponent),
- TailErrors = get_any_errors1(MaybeTailComponentsTerms),
- MaybeComponentsTerms = error1(HeadErrors ++ TailErrors)
+ HeadSpecs = get_any_errors1(MaybeHeadComponent),
+ TailSpecs = get_any_errors1(MaybeTailComponentsContexts),
+ MaybeComponentsContexts = error1(HeadSpecs ++ TailSpecs)
)
;
(
- Term = term.functor(_, _, _),
- Msg = "invalid atomic goal parameter",
- MaybeComponentsTerms = error1([Msg - Term])
+ Term = term.functor(_, _, TermContext),
+ Pieces = [words("Invalid atomic goal parameter."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(TermContext, [always(Pieces)])]),
+ MaybeComponentsContexts = error1([Spec])
;
- Term = term.variable(_, _),
- Msg = "expected atomic goal parameter, found variable",
- ErrorTerm = term.functor(term.atom(""), [], Context),
- MaybeComponentsTerms = error1([Msg - ErrorTerm])
+ Term = term.variable(_, TermContext),
+ Pieces = [words("Expected atomic goal parameter, found variable."),
+ nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(TermContext, [always(Pieces)])]),
+ MaybeComponentsContexts = error1([Spec])
)
).
:- pred parse_atomic_subterm(string::in, term::in, term::in,
maybe1(atomic_component_state)::out) is det.
-parse_atomic_subterm(Name, ErrorTerm, Term, MaybeComponentTerm) :-
+parse_atomic_subterm(Name, ErrorTerm, Term, MaybeComponentState) :-
(
- Term = term.functor(_, SubTerms, _),
- ( SubTerms = [SubTerm] ->
- parse_atomic_component_state(Name, SubTerm, MaybeCompState),
- (
- MaybeCompState = ok1(Component),
- MaybeComponentTerm = ok1(Component)
- ;
- MaybeCompState = error1(Errors),
- MaybeComponentTerm = error1(Errors)
- )
- ; SubTerms = [SubTermA, SubTermB] ->
- parse_atomic_component_pair(Name, SubTermA, SubTermB,
- MaybeCompState),
- (
- MaybeCompState = ok1(Component),
- MaybeComponentTerm = ok1(Component)
+ Term = term.functor(_, SubTerms, TermContext),
+ ( parse_atomic_component_state_or_pair(SubTerms, ComponentState) ->
+ MaybeComponentState = ok1(ComponentState)
;
- MaybeCompState = error1(Errors),
- MaybeComponentTerm = error1(Errors)
+ Pieces = [words("Error:"), words(Name),
+ words("takes exactly one argument,"),
+ words("which should be a state variable"),
+ words("or a pair of variables."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(TermContext, [always(Pieces)])]),
+ MaybeComponentState = error1([Spec])
)
;
- Msg = Name ++ " takes exactly one argument, " ++
- "which should be a state variable " ++
- "or a pair of variables",
- MaybeComponentTerm = error1([Msg - Term])
- )
- ;
- Term = term.variable(_, _),
- Msg = "expected atomic goal parameter, found variable",
- MaybeComponentTerm = error1([Msg - ErrorTerm])
+ Term = term.variable(_, _TermContext),
+ Pieces = [words("Error: expected atomic goal parameter,"),
+ words("found variable."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
+ MaybeComponentState = error1([Spec])
).
-:- pred parse_atomic_component(term::in, term::in,
- maybe1(pair(atomic_component, term))::out) is det.
+:- pred parse_atomic_component(term::in, term::in, varset::in,
+ maybe1(pair(atomic_component, term.context))::out) is det.
-parse_atomic_component(ErrorTerm, Term, MaybeComponentTerm) :-
+parse_atomic_component(ErrorTerm, Term, VarSet, MaybeComponentContext) :-
(
- Term = term.functor(Functor, SubTerms, _),
+ Term = term.functor(Functor, SubTerms, Context),
( Functor = term.atom(Atom) ->
+ % XXX Make parse_atomic_subterm do the postprocessing done here.
( Atom = "outer" ->
parse_atomic_subterm(Atom, ErrorTerm, Term,
MaybeComponentSubTerm),
(
MaybeComponentSubTerm = ok1(CompTerm),
Component = atomic_component_outer(CompTerm),
- MaybeComponentTerm = ok1(Component - Term)
+ MaybeComponentContext = ok1(Component - Context)
;
- MaybeComponentSubTerm = error1(Errors),
- MaybeComponentTerm = error1(Errors)
+ MaybeComponentSubTerm = error1(Specs),
+ MaybeComponentContext = error1(Specs)
)
; Atom = "inner" ->
parse_atomic_subterm(Atom, ErrorTerm, Term,
@@ -1175,100 +1278,99 @@
(
MaybeComponentSubTerm = ok1(CompTerm),
Component = atomic_component_inner(CompTerm),
- MaybeComponentTerm = ok1(Component - Term)
+ MaybeComponentContext = ok1(Component - Context)
;
- MaybeComponentSubTerm = error1(Errors),
- MaybeComponentTerm = error1(Errors)
+ MaybeComponentSubTerm = error1(Specs),
+ MaybeComponentContext = error1(Specs)
)
; Atom = "vars" ->
( SubTerms = [SubTerm] ->
- parse_vars(SubTerm, MaybeVars),
+ ContextPieces = [words("In"), quote("vars"),
+ words("specifier of atomic scope:")],
+ parse_vars(SubTerm, VarSet, ContextPieces, MaybeVars),
(
MaybeVars = ok1(Vars),
list.map(term.coerce_var, Vars, ProgVars),
Component = atomic_component_vars(ProgVars),
- MaybeComponentTerm = ok1(Component - Term)
+ MaybeComponentContext = ok1(Component - Context)
;
- MaybeVars = error1(Errors),
- MaybeComponentTerm = error1(Errors)
+ MaybeVars = error1(Specs),
+ MaybeComponentContext = error1(Specs)
)
;
- Msg = Atom ++ " takes exactly one argument, " ++
- "which should be a list of variable names",
- MaybeComponentTerm = error1([Msg - Term])
+ Pieces = [words(Atom), words("takes exact one argument,"),
+ words("which should be a list of variable names."),
+ nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(Context, [always(Pieces)])]),
+ MaybeComponentContext = error1([Spec])
)
;
- Msg = "invalid atomic goal parameter",
- MaybeComponentTerm = error1([Msg - Term])
+ Pieces = [words("Invalid atomic goal parameter."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(Context, [always(Pieces)])]),
+ MaybeComponentContext = error1([Spec])
)
;
- Msg = "invalid atomic goal parameter",
- MaybeComponentTerm = error1([Msg - Term])
+ Pieces = [words("Invalid atomic goal parameter."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(Context, [always(Pieces)])]),
+ MaybeComponentContext = error1([Spec])
)
;
- Term = term.variable(_, _),
- Msg = "expected atomic goal parameter, found variable",
- MaybeComponentTerm = error1([Msg - ErrorTerm])
+ Term = term.variable(_, _Context),
+ Pieces = [words("Expected atomic goal parameter, found variable."),
+ nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
+ MaybeComponentContext = error1([Spec])
).
-:- pred parse_atomic_component_state(string::in, term::in,
- maybe1(atomic_component_state)::out) is det.
+:- pred parse_atomic_component_state_or_pair(list(term)::in,
+ atomic_component_state::out) is semidet.
-parse_atomic_component_state(Scope, Term, MaybeState) :-
+parse_atomic_component_state_or_pair(SubTerms, State) :-
(
+ SubTerms = [Term],
Term = term.functor(term.atom("!"), [term.variable(Var, _)], _)
->
term.coerce_var(Var, ProgVar),
- MaybeState = ok1(atomic_state_var(ProgVar))
+ State = atomic_state_var(ProgVar)
;
- Msg = atomic_component_state_error(Scope),
- MaybeState = error1([Msg - Term])
- ).
-
-:- pred parse_atomic_component_pair(string::in, term::in,
- term::in, maybe1(atomic_component_state)::out) is det.
-
-parse_atomic_component_pair(Scope, TermA, TermB, MaybeState) :-
- (
+ SubTerms = [TermA, TermB],
TermA = term.variable(VarA, _),
TermB = term.variable(VarB, _)
->
term.coerce_var(VarA, ProgVarA),
term.coerce_var(VarB, ProgVarB),
- MaybeState = ok1(atomic_var_pair(ProgVarA, ProgVarB))
+ State = atomic_var_pair(ProgVarA, ProgVarB)
;
- Msg = atomic_component_state_error(Scope),
- MaybeState = error1([Msg - TermA])
+ fail
).
-:- func atomic_component_state_error(string) = string.
-
-atomic_component_state_error(Scope) =
- "The argument of " ++ Scope ++ " should contain " ++
- "either a state variable or a pair of variables".
+% XXX reorder the predicates above
:- pred convert_atomic_params(term::in,
- assoc_list(atomic_component, term)::in,
+ assoc_list(atomic_component, term.context)::in,
maybe3(atomic_component_state, atomic_component_state,
maybe(list(prog_var)))::out) is det.
-convert_atomic_params(ErrorTerm, Components, MaybeParams) :-
- convert_atomic_params_2(ErrorTerm, Components, no, no, no, [],
- MaybeParams).
+convert_atomic_params(ErrorTerm, ComponentsContexts, MaybeParams) :-
+ convert_atomic_params_2(get_term_context(ErrorTerm), ComponentsContexts,
+ no, no, no, [], MaybeParams).
-:- pred convert_atomic_params_2(term::in,
- assoc_list(atomic_component, term)::in,
+:- pred convert_atomic_params_2(term.context::in,
+ assoc_list(atomic_component, term.context)::in,
maybe(atomic_component_state)::in,
maybe(atomic_component_state)::in,
- maybe(list(prog_var))::in,
- assoc_list(string, term)::in,
+ maybe(list(prog_var))::in, list(error_spec)::in,
maybe3(atomic_component_state, atomic_component_state,
maybe(list(prog_var)))::out) is det.
-convert_atomic_params_2(ErrorTerm, [], MaybeOuter, MaybeInner, MaybeVars,
- Errors, MaybeParams) :-
+convert_atomic_params_2(Context, [], MaybeOuter, MaybeInner, MaybeVars,
+ Specs, MaybeParams) :-
(
- Errors = [],
+ Specs = [],
(
MaybeOuter = yes(Outer),
MaybeInner = yes(Inner),
@@ -1276,28 +1378,36 @@
;
MaybeOuter = yes(_),
MaybeInner = no,
- Msg = "atomic goal is missing " ++
- "a specification of the inner STM state",
- MaybeParams = error3([Msg - ErrorTerm])
+ Pieces = [words("Atomic goal is missing"),
+ words("a specification of the inner STM state."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(Context, [always(Pieces)])]),
+ MaybeParams = error3([Spec])
;
MaybeOuter = no,
MaybeInner = yes(_),
- Msg = "atomic goal is missing " ++
- "a specification of the outer STM state",
- MaybeParams = error3([Msg - ErrorTerm])
+ Pieces = [words("Atomic goal is missing"),
+ words("a specification of the outer STM state."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(Context, [always(Pieces)])]),
+ MaybeParams = error3([Spec])
;
MaybeOuter = no,
MaybeInner = no,
- Msg = "atomic goal is missing " ++
- "a specification of both the outer and inner STM state",
- MaybeParams = error3([Msg - ErrorTerm])
+ Pieces = [words("Atomic goal is missing"),
+ words("a specification of both"),
+ words("the outer and inner STM states."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(Context, [always(Pieces)])]),
+ MaybeParams = error3([Spec])
)
;
- Errors = [_ | _],
- MaybeParams = error3(Errors)
- ).
-convert_atomic_params_2(ErrorTerm, [Component - Term | ComponentsTerms],
- !.MaybeOuter, !.MaybeInner, !.MaybeVars, !.Errors, MaybeParams) :-
+ Specs = [_ | _],
+ MaybeParams = error3(Specs)
+ ).
+convert_atomic_params_2(Context,
+ [Component - CompContext | ComponentsContexts],
+ !.MaybeOuter, !.MaybeInner, !.MaybeVars, !.Specs, MaybeParams) :-
(
Component = atomic_component_outer(Outer),
(
@@ -1305,8 +1415,11 @@
!:MaybeOuter = yes(Outer)
;
!.MaybeOuter = yes(_),
- Msg = "duplicate outer atomic parameter",
- !:Errors = !.Errors ++ [Msg - Term]
+ % XXX We should specify the duplicate parameter.
+ Pieces = [words("Duplicate outer atomic parameter."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(CompContext, [always(Pieces)])]),
+ !:Specs = !.Specs ++ [Spec]
)
;
Component = atomic_component_inner(Inner),
@@ -1315,8 +1428,11 @@
!:MaybeInner = yes(Inner)
;
!.MaybeInner = yes(_),
- Msg = "duplicate inner atomic parameter",
- !:Errors = !.Errors ++ [Msg - Term]
+ % XXX We should specify the duplicate parameter.
+ Pieces = [words("Duplicate inner atomic parameter."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(CompContext, [always(Pieces)])]),
+ !:Specs = !.Specs ++ [Spec]
)
;
Component = atomic_component_vars(Vars),
@@ -1325,30 +1441,37 @@
!:MaybeVars = yes(Vars)
;
!.MaybeVars = yes(_),
- Msg = "duplicate io trace parameter",
- !:Errors = !.Errors ++ [Msg - Term]
+ % XXX We should specify the duplicate parameter.
+ Pieces = [words("Duplicate atomic vars parameter."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(CompContext, [always(Pieces)])]),
+ !:Specs = !.Specs ++ [Spec]
)
),
- convert_atomic_params_2(ErrorTerm, ComponentsTerms,
- !.MaybeOuter, !.MaybeInner, !.MaybeVars, !.Errors, MaybeParams).
+ convert_atomic_params_2(Context, ComponentsContexts,
+ !.MaybeOuter, !.MaybeInner, !.MaybeVars, !.Specs, MaybeParams).
:- pred parse_atomic_subexpr(term::in, maybe2(goal, goals)::out,
prog_varset::in, prog_varset::out) is det.
parse_atomic_subexpr(Term, MaybeSubExpr, !VarSet) :-
parse_atomic_subgoals_as_list(Term, MaybeGoalList, !VarSet),
- ( MaybeGoalList = ok1(GoalList) ->
+ (
+ MaybeGoalList = ok1(GoalList),
(
GoalList = [],
- Msg = "atomic goal must have a subgoal",
- MaybeSubExpr = error2([Msg - Term])
+ Pieces = [words("Error: atomic scope must have a goal."), nl],
+ Context = get_term_context(Term),
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(Context, [always(Pieces)])]),
+ MaybeSubExpr = error2([Spec])
;
GoalList = [MainSubGoalExpr | OrElseAlternativeSubExpr],
MaybeSubExpr = ok2(MainSubGoalExpr, OrElseAlternativeSubExpr)
)
;
- GoalListErrors = get_any_errors1(MaybeGoalList),
- MaybeSubExpr = error2(GoalListErrors)
+ MaybeGoalList = error1(Specs),
+ MaybeSubExpr = error2(Specs)
).
:- pred parse_atomic_subgoals_as_list(term::in, maybe1(list(goal))::out,
@@ -1366,19 +1489,20 @@
->
MaybeGoals = ok1(LeftGoalList ++ RightGoalList)
;
- LeftErrors = get_any_errors1(MaybeLeftGoalList),
- RightErrors = get_any_errors1(MaybeRightGoalList),
- MaybeGoals = error1(LeftErrors ++ RightErrors)
+ LeftSpecs = get_any_errors1(MaybeLeftGoalList),
+ RightSpecs = get_any_errors1(MaybeRightGoalList),
+ MaybeGoals = error1(LeftSpecs ++ RightSpecs)
)
;
- parse_goal(Term, MaybeSubGoal, !VarSet),
+ % XXX Provide better ContextPieces.
+ ContextPieces = [],
+ parse_goal(Term, ContextPieces, MaybeSubGoal, !VarSet),
(
- MaybeSubGoal = ok1(SubGoal)
- ->
+ MaybeSubGoal = ok1(SubGoal),
MaybeGoals = ok1([SubGoal])
;
- SubGoalErrors = get_any_errors1(MaybeSubGoal),
- MaybeGoals = error1(SubGoalErrors)
+ MaybeSubGoal = error1(Specs),
+ MaybeGoals = error1(Specs)
)
).
Index: compiler/prog_io_pragma.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_io_pragma.m,v
retrieving revision 1.134
diff -u -b -r1.134 prog_io_pragma.m
--- compiler/prog_io_pragma.m 27 Feb 2008 09:46:07 -0000 1.134
+++ compiler/prog_io_pragma.m 15 Jul 2008 13:01:02 -0000
@@ -45,6 +45,8 @@
:- import_module libs.compiler_util.
:- import_module libs.rat.
+:- import_module parse_tree.error_util.
+:- import_module parse_tree.mercury_to_mercury.
:- import_module parse_tree.prog_ctgc.
:- import_module parse_tree.prog_io.
:- import_module parse_tree.prog_out.
@@ -65,10 +67,10 @@
(
PragmaTerms = [SinglePragmaTerm0],
parse_type_decl_where_part_if_present(non_solver_type, ModuleName,
- SinglePragmaTerm0, SinglePragmaTerm, WherePartResult),
- SinglePragmaTerm = term.functor(term.atom(PragmaType), PragmaArgs,
+ VarSet, SinglePragmaTerm0, SinglePragmaTerm, WherePartResult),
+ SinglePragmaTerm = term.functor(term.atom(PragmaName), PragmaArgs,
_Context),
- parse_pragma_type(ModuleName, PragmaType, PragmaArgs, SinglePragmaTerm,
+ parse_pragma_type(ModuleName, PragmaName, PragmaArgs, SinglePragmaTerm,
VarSet, Context, Result0)
->
(
@@ -93,15 +95,20 @@
Item = item_type_defn(ItemTypeDefn),
Result = ok1(Item)
;
- Msg = "unexpected `where equality/comparison is'",
- Result = error1([Msg - SinglePragmaTerm0])
+ Pieces = [words("Error: unexpected"),
+ quote("where equality/comparison is"),
+ suffix("."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(SinglePragmaTerm0),
+ [always(Pieces)])]),
+ Result = error1([Spec])
)
;
Result = Result0
)
;
- WherePartResult = error2(Errors),
- Result = error1(Errors)
+ WherePartResult = error2(Specs),
+ Result = error1(Specs)
)
;
fail
@@ -139,14 +146,16 @@
PragmaTerms, ErrorTerm, VarSet, Context, Result)
;
PragmaName = "foreign_export_enum",
- parse_pragma_foreign_export_enum(PragmaTerms, ErrorTerm,
+ parse_pragma_foreign_export_enum(PragmaTerms, ErrorTerm, VarSet,
Context, Result)
;
PragmaName = "foreign_enum",
- parse_pragma_foreign_enum(PragmaTerms, ErrorTerm, Context, Result)
+ parse_pragma_foreign_enum(PragmaTerms, ErrorTerm, VarSet,
+ Context, Result)
;
PragmaName = "foreign_export",
- parse_pragma_foreign_export(PragmaTerms, ErrorTerm, Context, Result)
+ parse_pragma_foreign_export(PragmaTerms, ErrorTerm, VarSet,
+ Context, Result)
;
PragmaName = "c_code",
parse_pragma_c_code(ModuleName, PragmaTerms, ErrorTerm, VarSet,
@@ -164,7 +173,7 @@
Context, Result)
;
PragmaName = "export",
- parse_pragma_export(PragmaTerms, ErrorTerm, Context, Result)
+ parse_pragma_export(PragmaTerms, ErrorTerm, VarSet, Context, Result)
;
(
PragmaName = "inline",
@@ -208,13 +217,13 @@
Pragma = pragma_mode_check_clauses(Name, Arity))
),
parse_simple_pragma(ModuleName, PragmaName, MakePragma,
- PragmaTerms, ErrorTerm, Context, Result)
+ PragmaTerms, ErrorTerm, VarSet, Context, Result)
;
PragmaName = "reserve_tag",
MakePragma = (pred(Name::in, Arity::in, Pragma::out) is det :-
Pragma = pragma_reserve_tag(Name, Arity)),
parse_simple_type_pragma(ModuleName, PragmaName, MakePragma,
- PragmaTerms, ErrorTerm, Context, Result)
+ PragmaTerms, ErrorTerm, VarSet, Context, Result)
;
(
PragmaName = "memo",
@@ -231,10 +240,10 @@
EvalMethod = eval_minimal(stack_copy)
),
parse_tabling_pragma(ModuleName, PragmaName, EvalMethod,
- PragmaTerms, ErrorTerm, Context, Result)
+ PragmaTerms, ErrorTerm, VarSet, Context, Result)
;
PragmaName = "unused_args",
- parse_pragma_unused_args(ModuleName, PragmaTerms, ErrorTerm,
+ parse_pragma_unused_args(ModuleName, PragmaTerms, ErrorTerm, VarSet,
Context, Result)
;
PragmaName = "type_spec",
@@ -243,38 +252,38 @@
;
PragmaName = "fact_table",
parse_pragma_fact_table(ModuleName, PragmaTerms, ErrorTerm,
- Context, Result)
+ VarSet, Context, Result)
;
PragmaName = "termination_info",
parse_pragma_termination_info(ModuleName, PragmaTerms, ErrorTerm,
- Context, Result)
+ VarSet, Context, Result)
;
PragmaName = "termination2_info",
parse_pragma_termination2_info(ModuleName, PragmaTerms, ErrorTerm,
- Context, Result)
+ VarSet, Context, Result)
;
PragmaName = "structure_sharing",
parse_pragma_structure_sharing(ModuleName, PragmaTerms, ErrorTerm,
- Context, Result)
+ VarSet, Context, Result)
;
PragmaName = "structure_reuse",
parse_pragma_structure_reuse(ModuleName, PragmaTerms, ErrorTerm,
- Context, Result)
+ VarSet, Context, Result)
;
PragmaName = "exceptions",
- parse_pragma_exceptions(ModuleName, PragmaTerms, ErrorTerm,
+ parse_pragma_exceptions(ModuleName, PragmaTerms, ErrorTerm, VarSet,
Context, Result)
;
PragmaName = "trailing_info",
- parse_pragma_trailing_info(ModuleName, PragmaTerms, ErrorTerm,
+ parse_pragma_trailing_info(ModuleName, PragmaTerms, ErrorTerm, VarSet,
Context, Result)
;
PragmaName = "mm_tabling_info",
parse_pragma_mm_tabling_info(ModuleName, PragmaTerms, ErrorTerm,
- Context, Result)
+ VarSet, Context, Result)
;
PragmaName = "require_feature_set",
- parse_pragma_require_feature_set(PragmaTerms, ErrorTerm,
+ parse_pragma_require_feature_set(PragmaTerms, VarSet, ErrorTerm,
Context, Result)
).
@@ -296,13 +305,20 @@
Item = item_pragma(ItemPragma),
Result = ok1(Item)
;
- Msg = "string expected in `:- pragma source_file' declaration",
- Result = error1([Msg - SourceFileTerm])
+ Pieces = [words("Error: the argument of a"),
+ quote(":- pragma source_file"),
+ words("declaration should be a string."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(SourceFileTerm),
+ [always(Pieces)])]),
+ Result = error1([Spec])
)
;
- Msg = "wrong number of arguments in " ++
- "`:- pragma source_file' declaration",
- Result = error1([Msg - ErrorTerm])
+ Pieces = [words("Error: wrong number of arguments in"),
+ quote(":- pragma source_file"), words("declaration."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
+ Result = error1([Spec])
).
:- pred parse_pragma_foreign_type(module_name::in, list(term)::in, term::in,
@@ -323,11 +339,11 @@
(
parse_foreign_language(LangTerm, Language)
->
- parse_foreign_language_type(ForeignTypeTerm, Language,
+ parse_foreign_language_type(ForeignTypeTerm, VarSet, Language,
MaybeForeignType),
(
MaybeForeignType = ok1(ForeignType),
- parse_type_defn_head(ModuleName, MercuryTypeTerm,
+ parse_type_defn_head(ModuleName, VarSet, MercuryTypeTerm,
MaybeTypeDefnHead),
(
MaybeTypeDefnHead = ok2(MercuryTypeSymName, MercuryParams),
@@ -348,31 +364,40 @@
;
MaybeAssertionTerm = yes(ErrorAssertionTerm)
->
- Msg = "invalid assertion in " ++
- "`:- pragma foreign_type' declaration",
- Result = error1([Msg - ErrorAssertionTerm])
+ Pieces = [words("Error: invalid assertion in"),
+ quote(":- pragma foreign_type"),
+ words("declaration."), nl],
+ Spec = error_spec(severity_error,
+ phase_term_to_parse_tree,
+ [simple_msg(get_term_context(ErrorAssertionTerm),
+ [always(Pieces)])]),
+ Result = error1([Spec])
;
unexpected(this_file,
"parse_pragma_type: unexpected failure of " ++
"parse_maybe_foreign_type_assertion")
)
;
- MaybeTypeDefnHead = error2(Errors),
- Result = error1(Errors)
+ MaybeTypeDefnHead = error2(Specs),
+ Result = error1(Specs)
)
;
- MaybeForeignType = error1(Errors),
- Result = error1(Errors)
+ MaybeForeignType = error1(Specs),
+ Result = error1(Specs)
)
;
- Msg = "invalid foreign language in " ++
- "`:- pragma foreign_type' declaration",
- Result = error1([Msg - LangTerm])
+ Pieces = [words("Error: invalid foreign language in"),
+ quote(":- pragma foreign_type"), words("declaration."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(LangTerm), [always(Pieces)])]),
+ Result = error1([Spec])
)
;
- Msg = "wrong number of arguments in " ++
- "`:- pragma foreign_type' declaration",
- Result = error1([Msg - ErrorTerm])
+ Pieces = [words("Error: wrong number of arguments in"),
+ quote(":- pragma foreign_type"), words("declaration."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
+ Result = error1([Spec])
).
:- pred parse_pragma_c_header_code(module_name::in, list(term)::in, term::in,
@@ -385,9 +410,11 @@
parse_pragma_foreign_decl_pragma(ModuleName, "c_header_code",
[LangC | PragmaTerms], ErrorTerm, VarSet, Context, Result)
;
- Msg = "wrong number of arguments or unexpected variable " ++
- "in `:- pragma c_header_code' declaration",
- Result = error1([Msg - ErrorTerm])
+ Pieces = [words("Error: wrong number or unexpected variable in"),
+ quote(":- pragma c_header_code"), words("declaration."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
+ Result = error1([Spec])
).
%----------------------------------------------------------------------------%
@@ -396,9 +423,10 @@
%
:- pred parse_pragma_foreign_export_enum(list(term)::in, term::in,
- prog_context::in, maybe1(item)::out) is det.
+ varset::in, prog_context::in, maybe1(item)::out) is det.
-parse_pragma_foreign_export_enum(PragmaTerms, ErrorTerm, Context, Result) :-
+parse_pragma_foreign_export_enum(PragmaTerms, ErrorTerm, VarSet, Context,
+ Result) :-
(
(
PragmaTerms = [LangTerm, MercuryTypeTerm],
@@ -408,7 +436,6 @@
PragmaTerms = [LangTerm, MercuryTypeTerm, AttributesTerm],
MaybeAttributesTerm = yes(AttributesTerm),
MaybeOverridesTerm = no
-
;
PragmaTerms = [LangTerm, MercuryTypeTerm, AttributesTerm,
OverridesTerm],
@@ -420,12 +447,12 @@
parse_export_enum_type(MercuryTypeTerm, MaybeType),
(
MaybeType = ok2(Name, Arity),
- maybe_parse_export_enum_attributes(MaybeAttributesTerm,
+ maybe_parse_export_enum_attributes(VarSet, MaybeAttributesTerm,
MaybeAttributes),
(
MaybeAttributes = ok1(Attributes),
- maybe_parse_export_enum_overrides(MaybeOverridesTerm,
- MaybeOverrides),
+ maybe_parse_export_enum_overrides(VarSet,
+ MaybeOverridesTerm, MaybeOverrides),
(
MaybeOverrides = ok1(Overrides),
PragmaExportEnum = pragma_foreign_export_enum(
@@ -437,26 +464,32 @@
Item = item_pragma(ItemPragma),
Result = ok1(Item)
;
- MaybeOverrides = error1(Errors),
- Result = error1(Errors)
+ MaybeOverrides = error1(Specs),
+ Result = error1(Specs)
)
;
- MaybeAttributes = error1(Errors),
- Result = error1(Errors)
+ MaybeAttributes = error1(Specs),
+ Result = error1(Specs)
)
;
- MaybeType = error2(Errors),
- Result = error1(Errors)
+ MaybeType = error2(Specs),
+ Result = error1(Specs)
)
;
- Msg = "invalid foreign langauge in " ++
- "`:- pragma foreign_export_enum' declaration",
- Result = error1([Msg - ErrorTerm])
+ Pieces = [words("Error: invalid foreign language in"),
+ quote(":- pragma foreign_export_enum"), words("declaration."),
+ nl],
+ % XXX Get_term_context(LangTerm) would be better.
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
+ Result = error1([Spec])
)
;
- Msg = "wrong number of arguments in " ++
- "`:- pragma foreign_export_enum' declaration",
- Result = error1([Msg - ErrorTerm])
+ Pieces = [words("Error: wrong number of arguments in"),
+ quote(":- pragma foreign_export_enum"), words("declaration."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
+ Result = error1([Spec])
).
:- pred parse_export_enum_type(term::in, maybe2(sym_name, arity)::out) is det.
@@ -465,59 +498,66 @@
( parse_name_and_arity(TypeTerm, Name, Arity) ->
Result = ok2(Name, Arity)
;
- Msg = "expected name/arity for type in " ++
- "`pragma foreign_export_enum' declaration",
- Result = error2([Msg - TypeTerm])
+ Pieces = [words("Error: expected name/arity for type in"),
+ quote(":- pragma foreign_export_enum"), words("declaration."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(TypeTerm), [always(Pieces)])]),
+ Result = error2([Spec])
).
-:- pred maybe_parse_export_enum_overrides(maybe(term)::in,
+:- pred maybe_parse_export_enum_overrides(varset::in, maybe(term)::in,
maybe1(assoc_list(sym_name, string))::out) is det.
-maybe_parse_export_enum_overrides(no, ok1([])).
-maybe_parse_export_enum_overrides(yes(OverridesTerm), MaybeOverrides) :-
- ListMsg = "not a valid mapping element",
- PairMsg = "exported enumeration override constructor",
- convert_maybe_list(OverridesTerm, parse_sym_name_string_pair(PairMsg),
- ListMsg, MaybeOverrides).
+maybe_parse_export_enum_overrides(_, no, ok1([])).
+maybe_parse_export_enum_overrides(VarSet, yes(OverridesTerm),
+ MaybeOverrides) :-
+ UnrecognizedPieces =
+ [words("Error: expected a valid mapping element."), nl],
+ PairPieces = [words("In exported enumeration override constructor:")],
+ convert_maybe_list("mapping elements", yes(VarSet), OverridesTerm,
+ parse_sym_name_string_pair(VarSet, PairPieces),
+ UnrecognizedPieces, MaybeOverrides).
-:- pred parse_sym_name_string_pair(string::in, term::in,
- maybe1(pair(sym_name, string))::out) is semidet.
+:- pred parse_sym_name_string_pair(varset::in, list(format_component)::in,
+ term::in, maybe1(pair(sym_name, string))::out) is semidet.
-parse_sym_name_string_pair(Msg, PairTerm, MaybePair) :-
+parse_sym_name_string_pair(VarSet, ContextPieces, PairTerm, MaybePair) :-
PairTerm = functor(Functor, Args, _),
Functor = term.atom("-"),
Args = [SymNameTerm, StringTerm],
StringTerm = functor(term.string(String), _, _),
- parse_qualified_term(SymNameTerm, SymNameTerm, Msg,
+ parse_qualified_term(SymNameTerm, SymNameTerm, VarSet, ContextPieces,
MaybeSymNameResult),
(
MaybeSymNameResult = ok2(SymName, []),
MaybePair = ok1(SymName - String)
;
- MaybeSymNameResult = error2(Errs),
- MaybePair = error1(Errs)
+ MaybeSymNameResult = error2(Specs),
+ MaybePair = error1(Specs)
).
-:- pred maybe_parse_export_enum_attributes(maybe(term)::in,
+:- pred maybe_parse_export_enum_attributes(varset::in, maybe(term)::in,
maybe1(export_enum_attributes)::out) is det.
-maybe_parse_export_enum_attributes(no, ok1(default_export_enum_attributes)).
-maybe_parse_export_enum_attributes(yes(AttributesTerm), MaybeAttributes) :-
- parse_export_enum_attributes(AttributesTerm, MaybeAttributes).
+maybe_parse_export_enum_attributes(_, no, ok1(default_export_enum_attributes)).
+maybe_parse_export_enum_attributes(VarSet, yes(AttributesTerm),
+ MaybeAttributes) :-
+ parse_export_enum_attributes(VarSet, AttributesTerm, MaybeAttributes).
:- type collected_export_enum_attribute
---> ee_attr_prefix(maybe(string))
; ee_attr_upper(uppercase_export_enum).
-:- pred parse_export_enum_attributes(term::in,
+:- pred parse_export_enum_attributes(varset::in, term::in,
maybe1(export_enum_attributes)::out) is det.
-parse_export_enum_attributes(AttributesTerm, AttributesResult) :-
+parse_export_enum_attributes(VarSet, AttributesTerm, AttributesResult) :-
Attributes0 = default_export_enum_attributes,
ConflictingAttributes = [],
(
list_term_to_term_list(AttributesTerm, AttributesTerms),
- map_parser(parse_export_enum_attr, AttributesTerms, MaybeAttrList),
+ map_parser(parse_export_enum_attr(VarSet), AttributesTerms,
+ MaybeAttrList),
MaybeAttrList = ok1(CollectedAttributes)
->
(
@@ -525,8 +565,14 @@
list.member(ConflictA, CollectedAttributes),
list.member(ConflictB, CollectedAttributes)
->
- Msg = "conflicting attributes in attribute list",
- AttributesResult = error1([Msg - AttributesTerm])
+ % XXX Print the conflicting attributes themselves.
+ Pieces = [words("Error: conflicting attributes in"),
+ quote(":- pragma foreign_export_enum"), words("declaration."),
+ nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(AttributesTerm),
+ [always(Pieces)])]),
+ AttributesResult = error1([Spec])
;
% Check that the prefix attribute is specified at most once.
IsPrefixAttr = (pred(A::in) is semidet :-
@@ -542,14 +588,23 @@
AttributesResult = ok1(Attributes)
;
PrefixAttributes = [_, _ | _],
- Msg = "prefix attribute occurs multiple times in " ++
- "foreign_export_enum pragma",
- AttributesResult = error1([Msg - AttributesTerm])
+ % XXX Print the multiply-occurring attribute.
+ Pieces = [words("Error: prefix attribute"),
+ words("occurs multiple times in"),
+ quote(":- pragma foreign_export_enum"),
+ words("declaration."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(AttributesTerm),
+ [always(Pieces)])]),
+ AttributesResult = error1([Spec])
)
)
;
- Msg = "malformed attributes list in foreign_export_enum pragma",
- AttributesResult = error1([Msg - AttributesTerm])
+ Pieces = [words("Error: malformed attributes list in"),
+ quote(":- pragma foreign_export_enum"), words("declaration."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(AttributesTerm), [always(Pieces)])]),
+ AttributesResult = error1([Spec])
).
:- pred process_export_enum_attribute(collected_export_enum_attribute::in,
@@ -557,7 +612,7 @@
process_export_enum_attribute(ee_attr_prefix(MaybePrefix), !Attributes) :-
% We haved alredy checked that the prefix attribute is not specified
- % mulitple times in parse_export_enum_attributes/2 so it is safe to
+ % multiple times in parse_export_enum_attributes so it is safe to
% ignore it in the input here.
!.Attributes = export_enum_attributes(_, MakeUpperCase),
!:Attributes = export_enum_attributes(MaybePrefix, MakeUpperCase).
@@ -565,10 +620,10 @@
!.Attributes = export_enum_attributes(MaybePrefix, _),
!:Attributes = export_enum_attributes(MaybePrefix, MakeUpperCase).
-:- pred parse_export_enum_attr(term::in,
+:- pred parse_export_enum_attr(varset::in, term::in,
maybe1(collected_export_enum_attribute)::out) is det.
-parse_export_enum_attr(Term, Result) :-
+parse_export_enum_attr(VarSet, Term, Result) :-
(
Term = functor(atom("prefix"), Args, _),
Args = [ ForeignNameTerm ],
@@ -580,8 +635,13 @@
->
Result = ok1(ee_attr_upper(uppercase_export_enum))
;
- Msg = "unrecognised attribute in foreign_export_enum pragma",
- Result = error1([Msg - Term])
+ TermStr = describe_error_term(VarSet, Term),
+ Pieces = [words("Error: unrecognised attribute in"),
+ quote(":- pragma foreign_export_enum"), words("declaration:"),
+ words(TermStr), suffix("."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(Term), [always(Pieces)])]),
+ Result = error1([Spec])
).
%----------------------------------------------------------------------------%
@@ -589,20 +649,21 @@
% Code for parsing foreign_enum pragmas
%
-:- pred parse_pragma_foreign_enum(list(term)::in, term::in, prog_context::in,
- maybe1(item)::out) is det.
+:- pred parse_pragma_foreign_enum(list(term)::in, term::in, varset::in,
+ prog_context::in, maybe1(item)::out) is det.
-parse_pragma_foreign_enum(PragmaTerms, ErrorTerm, Context, Result) :-
+parse_pragma_foreign_enum(PragmaTerms, ErrorTerm, VarSet, Context, Result) :-
( PragmaTerms = [LangTerm, MercuryTypeTerm, ValuesTerm] ->
( parse_foreign_language(LangTerm, ForeignLanguage) ->
parse_export_enum_type(MercuryTypeTerm, MaybeType),
(
MaybeType = ok2(TypeName, TypeArity),
- ListErrMsg = "not a valid mapping element",
- PairErrMsg = "foreign_enum constructor name",
- convert_maybe_list(ValuesTerm,
- parse_sym_name_string_pair(PairErrMsg),
- ListErrMsg, MaybeValues),
+ UnrecognizedPieces =
+ [words("Error: expected a valid mapping element."), nl],
+ PairPieces = [words("In foreign_enum constructor name:")],
+ convert_maybe_list("mapping elements", yes(VarSet), ValuesTerm,
+ parse_sym_name_string_pair(VarSet, PairPieces),
+ UnrecognizedPieces, MaybeValues),
(
MaybeValues = ok1(Values),
PragmaForeignImportEnum = pragma_foreign_enum(
@@ -612,22 +673,28 @@
Item = item_pragma(ItemPragma),
Result = ok1(Item)
;
- MaybeValues = error1(Errors),
- Result = error1(Errors)
+ MaybeValues = error1(Specs),
+ Result = error1(Specs)
)
;
- MaybeType = error2(Errors),
- Result = error1(Errors)
+ MaybeType = error2(Specs),
+ Result = error1(Specs)
)
;
- Msg = "invalid foreign langauge in " ++
- "`:- pragma foreign_enum' declaration",
- Result = error1([Msg - ErrorTerm])
+ Pieces = [words("Error: invalid foreign language in"),
+ quote(":- pragma foreign_export_enum"), words("declaration."),
+ nl],
+ % XXX We should use the context of LangTerm.
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
+ Result = error1([Spec])
)
;
- Msg = "wrong number of arguments in " ++
- "`:- pragma foreign_enum' declaration",
- Result = error1([Msg - ErrorTerm])
+ Pieces = [words("Error: wrong number of arguments in"),
+ quote(":- pragma foreign_export_enum"), words("declaration."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
+ Result = error1([Spec])
).
%----------------------------------------------------------------------------%
@@ -635,15 +702,16 @@
% Code for parsing foreign_export pragmas
%
-:- pred parse_pragma_foreign_export(list(term)::in, term::in, prog_context::in,
- maybe1(item)::out) is det.
+:- pred parse_pragma_foreign_export(list(term)::in, term::in, varset::in,
+ prog_context::in, maybe1(item)::out) is det.
-parse_pragma_foreign_export(PragmaTerms, ErrorTerm, Context, Result) :-
+parse_pragma_foreign_export(PragmaTerms, ErrorTerm, VarSet, Context, Result) :-
( PragmaTerms = [LangTerm, PredAndModesTerm, FunctionTerm] ->
( FunctionTerm = term.functor(term.string(Function), [], _) ->
+ ContextPieces = [words("In"),
+ quote(":- pragma foreign_export"), words("declaration")],
parse_pred_or_func_and_arg_modes(no, PredAndModesTerm,
- ErrorTerm, "`:- pragma foreign_export' declaration",
- PredAndModesResult),
+ ErrorTerm, VarSet, ContextPieces, PredAndModesResult),
(
PredAndModesResult = ok2(PredName - PredOrFunc, Modes),
( parse_foreign_language(LangTerm, ForeignLanguage) ->
@@ -653,23 +721,35 @@
Item = item_pragma(ItemPragma),
Result = ok1(Item)
;
- Msg = "invalid foreign language in " ++
- "`:- pragma foreign_export declaration",
- Result = error1([Msg - LangTerm])
- )
- ;
- PredAndModesResult = error2(Errors),
- Result = error1(Errors)
- )
- ;
- Msg = "expected pragma " ++
- "foreign_export(Lang, PredName(ModeList), Function)",
- Result = error1([Msg - PredAndModesTerm])
- )
- ;
- Msg = "wrong number of arguments in " ++
- "`:- pragma foreign_export' declaration",
- Result = error1([Msg - ErrorTerm])
+ Pieces = [words("Error: invalid foreign language in"),
+ quote(":- pragma foreign_export"),
+ words("declaration."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(LangTerm),
+ [always(Pieces)])]),
+ Result = error1([Spec])
+ )
+ ;
+ PredAndModesResult = error2(Specs),
+ Result = error1(Specs)
+ )
+ ;
+ % XXX Why this wording?
+ Pieces = [words("Error: expected pragma"),
+ words("foreign_export(Lang, PredName(ModeList), Function)."),
+ nl],
+ % XXX Should we use the context of FunctionTerm?
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(PredAndModesTerm),
+ [always(Pieces)])]),
+ Result = error1([Spec])
+ )
+ ;
+ Pieces = [words("Error: wrong number of arguments in"),
+ quote(":- pragma foreign_export"), words("declaration."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
+ Result = error1([Spec])
).
%----------------------------------------------------------------------------%
@@ -699,9 +779,12 @@
parse_pragma_foreign_proc_pragma(ModuleName, "c_code",
[LangC | PragmaTerms], ErrorTerm, VarSet, Context, Result)
;
- Msg = "wrong number of arguments or unexpected variable" ++
- "in `:- pragma c_code' declaration",
- Result = error1([Msg - ErrorTerm])
+ Pieces = [words("Error: wrong number of arguments"),
+ words("or unexpected variable in"),
+ quote(":- pragma c_code"), words("declaration."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
+ Result = error1([Spec])
).
:- pred parse_pragma_c_import_module(list(term)::in, term::in,
@@ -717,9 +800,12 @@
Item = item_pragma(ItemPragma),
Result = ok1(Item)
;
- Msg = "wrong number of arguments or invalid module name " ++
- "in `:- pragma c_import_module' declaration",
- Result = error1([Msg - ErrorTerm])
+ Pieces = [words("Error: wrong number of arguments"),
+ words("or invalid module name in"),
+ quote(":- pragma c_import_module"), words("declaration."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
+ Result = error1([Spec])
).
:- pred parse_pragma_foreign_import_module(list(term)::in, term::in,
@@ -736,14 +822,21 @@
Item = item_pragma(ItemPragma),
Result = ok1(Item)
;
- Msg = "invalid foreign language in " ++
- "`:- pragma foreign_import_module' declaration",
- Result = error1([Msg - LangTerm])
+ Pieces = [words("Error: invalid foreign language in"),
+ quote(":- pragma foreign_import_module"),
+ words("declaration."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(LangTerm), [always(Pieces)])]),
+ Result = error1([Spec])
)
;
- Msg = "wrong number of arguments or invalid module name " ++
- "in `:- pragma foreign_import_module' declaration",
- Result = error1([Msg - ErrorTerm])
+ Pieces = [words("Error: wrong number of arguments"),
+ words("or invalid module name in"),
+ quote(":- pragma foreign_import_module"),
+ words("declaration."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
+ Result = error1([Spec])
).
:- pred parse_pragma_import(module_name::in, list(term)::in, term::in,
@@ -756,18 +849,10 @@
(
(
PragmaTerms = [PredAndModesTerm, FlagsTerm, FunctionTerm],
+ FlagsContextPieces = [words("In second argument of"),
+ quote(":- pragma import/3"), words("declaration:")],
parse_pragma_foreign_proc_attributes_term(ForeignLanguage,
- "import", VarSet, FlagsTerm, MaybeFlags),
- (
- MaybeFlags = error1(FlagsErrors0),
- FlagsErrors = assoc_list.map_keys_only(
- string.append("invalid second argument in " ++
- "`:- pragma import/3' declaration : "), FlagsErrors0),
- FlagsResult = error1(FlagsErrors)
- ;
- MaybeFlags = ok1(Flags),
- FlagsResult = ok1(Flags)
- )
+ "import", VarSet, FlagsTerm, FlagsContextPieces, FlagsResult)
;
PragmaTerms = [PredAndModesTerm, FunctionTerm],
Flags0 = default_attributes(ForeignLanguage),
@@ -777,8 +862,10 @@
)
->
( FunctionTerm = term.functor(term.string(Function), [], _) ->
- parse_pred_or_func_and_arg_modes(yes(ModuleName),
- PredAndModesTerm, ErrorTerm, "`:- pragma import' declaration",
+ PredAndModesContextPieces = [words("In"),
+ quote(":- pragma import"), words("declaration:")],
+ parse_pred_or_func_and_arg_modes(yes(ModuleName), PredAndModesTerm,
+ ErrorTerm, VarSet, PredAndModesContextPieces,
PredAndArgModesResult),
(
PredAndArgModesResult = ok2(PredName - PredOrFunc, ArgModes),
@@ -790,30 +877,40 @@
Item = item_pragma(ItemPragma),
Result = ok1(Item)
;
- FlagsResult = error1(FlagsErrors2),
- Result = error1(FlagsErrors2)
+ FlagsResult = error1(FlagsSpecs),
+ Result = error1(FlagsSpecs)
)
;
- PredAndArgModesResult = error2(PredAndArgModesErrors),
- Result = error1(PredAndArgModesErrors)
+ PredAndArgModesResult = error2(Specs),
+ Result = error1(Specs)
)
;
- Msg = "expected pragma import(PredName(ModeList), Function)",
- Result = error1([Msg - PredAndModesTerm])
+ Pieces = [words("Error: expected pragma"),
+ words("import(PredName(ModeList), Function)."), nl],
+ % XXX Should we use FunctionTerm's context?
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(PredAndModesTerm),
+ [always(Pieces)])]),
+ Result = error1([Spec])
)
;
- Msg = "wrong number of arguments in `:- pragma import' declaration",
- Result = error1([Msg - ErrorTerm])
+ Pieces = [words("Error: wrong number of arguments in"),
+ quote(":- pragma import"), words("declaration."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
+ Result = error1([Spec])
).
-:- pred parse_pragma_export(list(term)::in, term::in,
+:- pred parse_pragma_export(list(term)::in, term::in, varset::in,
prog_context::in, maybe1(item)::out) is det.
-parse_pragma_export(PragmaTerms, ErrorTerm, Context, Result) :-
+parse_pragma_export(PragmaTerms, ErrorTerm, VarSet, Context, Result) :-
( PragmaTerms = [PredAndModesTerm, FunctionTerm] ->
( FunctionTerm = term.functor(term.string(Function), [], _) ->
+ ContextPieces = [words("In"),
+ quote(":- pragma export"), words("declaration:")],
parse_pred_or_func_and_arg_modes(no, PredAndModesTerm, ErrorTerm,
- "`:- pragma export' declaration", PredAndModesResult),
+ VarSet, ContextPieces, PredAndModesResult),
(
PredAndModesResult = ok2(PredName - PredOrFunc, Modes),
Pragma = pragma_foreign_export(lang_c, PredName, PredOrFunc,
@@ -822,45 +919,47 @@
Item = item_pragma(ItemPragma),
Result = ok1(Item)
;
- PredAndModesResult = error2(PredAndModesErrors),
- Result = error1(PredAndModesErrors)
+ PredAndModesResult = error2(Specs),
+ Result = error1(Specs)
)
;
- Result = error1(
- ["expected pragma export(PredName(ModeList), Function)" -
- PredAndModesTerm])
- )
- ;
- Msg = "wrong number of arguments in `:- pragma export' declaration",
- Result = error1([Msg - ErrorTerm])
+ % XXX Why this wording?
+ Pieces = [words("Error: expected pragma"),
+ words("export(PredName(ModeList), Function)."), nl],
+ % Should we use FunctionTerm's context?
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(PredAndModesTerm),
+ [always(Pieces)])]),
+ Result = error1([Spec])
+ )
+ ;
+ Pieces = [words("Error: wrong number of arguments in"),
+ quote(":- pragma export"), words("declaration."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
+ Result = error1([Spec])
).
:- pred parse_pragma_unused_args(module_name::in, list(term)::in, term::in,
- prog_context::in, maybe1(item)::out) is det.
+ varset::in, prog_context::in, maybe1(item)::out) is det.
-parse_pragma_unused_args(ModuleName, PragmaTerms, ErrorTerm, Context,
+parse_pragma_unused_args(ModuleName, PragmaTerms, ErrorTerm, VarSet, Context,
Result) :-
% pragma unused_args should never appear in user programs,
% only in .opt files.
(
- PragmaTerms = [
- PredOrFuncTerm,
- PredNameTerm,
+ PragmaTerms = [PredOrFuncTerm, PredNameTerm,
term.functor(term.integer(Arity), [], _),
term.functor(term.integer(ModeNum), [], _),
UnusedArgsTerm
],
- (
- PredOrFuncTerm = term.functor(term.atom("predicate"), [], _),
- PredOrFunc = pf_predicate
- ;
- PredOrFuncTerm = term.functor(term.atom("function"), [], _),
- PredOrFunc = pf_function
- ),
+ parse_predicate_or_function(PredOrFuncTerm, PredOrFunc),
+ ContextPieces = [words("In"), quote(":- pragma unused_args"),
+ words("declaration:")],
parse_implicitly_qualified_term(ModuleName, PredNameTerm, ErrorTerm,
- "`:- pragma unused_args' declaration", PredNameResult),
+ VarSet, ContextPieces, PredNameResult),
PredNameResult = ok2(PredName, []),
- convert_int_list(UnusedArgsTerm, UnusedArgsResult),
+ convert_int_list(VarSet, UnusedArgsTerm, UnusedArgsResult),
UnusedArgsResult = ok1(UnusedArgs)
->
Pragma = pragma_unused_args(PredOrFunc, PredName, Arity, ModeNum,
@@ -869,7 +968,12 @@
Item = item_pragma(ItemPragma),
Result = ok1(Item)
;
- Result = error1(["error in `:- pragma unused_args'" - ErrorTerm])
+ % XXX Improve this message.
+ Pieces = [words("Error in"), quote(":- pragma unused_args"),
+ suffix("."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
+ Result = error1([Spec])
).
:- pred parse_pragma_type_spec(module_name::in, list(term)::in, term::in,
@@ -889,14 +993,19 @@
term.context_file(SpecContext, FileName),
\+ string.remove_suffix(FileName, ".m", _),
+ % The value of ContextPieces does not matter here since we succeed
+ % only if it isn't used.
+ NameContextPieces = [],
parse_implicitly_qualified_term(ModuleName, SpecNameTerm,
- ErrorTerm, "", NameResult),
+ ErrorTerm, VarSet0, NameContextPieces, NameResult),
NameResult = ok2(SpecName, []),
MaybeName = yes(SpecName)
)
->
+ ArityOrModesContextPieces = [words("In"), quote(":- pragma type_spec"),
+ words("declaration:")],
parse_arity_or_modes(ModuleName, PredAndModesTerm, ErrorTerm,
- "`:- pragma type_spec' declaration", ArityOrModesResult),
+ VarSet0, ArityOrModesContextPieces, ArityOrModesResult),
(
ArityOrModesResult = ok1(arity_or_modes(PredName, Arity,
MaybePredOrFunc, MaybeModes)),
@@ -921,27 +1030,33 @@
Item = item_pragma(ItemPragma),
Result = ok1(Item)
;
- Msg = "expected type substitution in " ++
- "`:- pragma type_spec' declaration",
- Result = error1([Msg - TypeSubnTerm])
- )
- ;
- ArityOrModesResult = error1(Errors),
- Result = error1(Errors)
- )
- ;
- Msg = "wrong number of arguments in `:- pragma type_spec' declaration",
- Result = error1([Msg - ErrorTerm])
+ Pieces = [words("Error: expected type substitution in"),
+ quote(":- pragma type_spec"), words("declaration."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(TypeSubnTerm),
+ [always(Pieces)])]),
+ Result = error1([Spec])
+ )
+ ;
+ ArityOrModesResult = error1(Specs),
+ Result = error1(Specs)
+ )
+ ;
+ Pieces = [words("Error: wrong number of arguments in"),
+ quote(":- pragma type_spec"), words("declaration."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
+ Result = error1([Spec])
).
:- pred parse_pragma_fact_table(module_name::in, list(term)::in, term::in,
- prog_context::in, maybe1(item)::out) is det.
+ varset::in, prog_context::in, maybe1(item)::out) is det.
parse_pragma_fact_table(ModuleName, PragmaTerms, ErrorTerm,
- Context, Result) :-
+ VarSet, Context, Result) :-
( PragmaTerms = [PredAndArityTerm, FileNameTerm] ->
parse_pred_name_and_arity(ModuleName, "fact_table",
- PredAndArityTerm, ErrorTerm, NameArityResult),
+ PredAndArityTerm, ErrorTerm, VarSet, NameArityResult),
(
NameArityResult = ok2(PredName, Arity),
( FileNameTerm = term.functor(term.string(FileName), [], _) ->
@@ -950,126 +1065,133 @@
Item = item_pragma(ItemPragma),
Result = ok1(Item)
;
- Result = error1(["expected string for fact table filename" -
- FileNameTerm])
+ Pieces = [words("Error: expected string"),
+ words("for fact table filename."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(FileNameTerm),
+ [always(Pieces)])]),
+ Result = error1([Spec])
)
;
- NameArityResult = error2(Errors),
- Result = error1(Errors)
+ NameArityResult = error2(Specs),
+ Result = error1(Specs)
)
;
- Msg = "wrong number of arguments " ++
- "in `:- pragma fact_table' declaration",
- Result = error1([Msg - ErrorTerm])
+ Pieces = [words("Error: wrong number of arguments in"),
+ quote(":- pragma fact_table"), words("declaration."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
+ Result = error1([Spec])
).
-:- pred parse_pragma_termination_info(module_name::in, list(term)::in, term::in,
- prog_context::in, maybe1(item)::out) is det.
+:- pred parse_pragma_termination_info(module_name::in, list(term)::in,
+ term::in, varset::in, prog_context::in, maybe1(item)::out) is det.
-parse_pragma_termination_info(ModuleName, PragmaTerms, ErrorTerm, Context,
- Result) :-
+parse_pragma_termination_info(ModuleName, PragmaTerms, ErrorTerm, VarSet,
+ Context, Result) :-
(
- PragmaTerms = [
- PredAndModesTerm0,
- ArgSizeTerm,
- TerminationTerm
- ],
+ PragmaTerms = [PredAndModesTerm0, ArgSizeTerm, TerminationTerm],
+ ContextPieces = [words("In"),
+ quote(":- pragma termination_info"), words("declaration:")],
parse_pred_or_func_and_arg_modes(yes(ModuleName), PredAndModesTerm0,
- ErrorTerm, "`:- pragma termination_info' declaration",
- NameAndModesResult),
+ ErrorTerm, VarSet, ContextPieces, NameAndModesResult),
NameAndModesResult = ok2(PredName - PredOrFunc, ModeList),
+ ArgSizeTerm = term.functor(term.atom(ArgSizeFunctor),
+ ArgSizeArgTerms, _),
(
- ArgSizeTerm = term.functor(term.atom("not_set"), [], _),
+ ArgSizeFunctor = "not_set",
+ ArgSizeArgTerms = [],
MaybeArgSizeInfo = no
;
- ArgSizeTerm = term.functor(term.atom("infinite"), [], _),
+ ArgSizeFunctor = "infinite",
+ ArgSizeArgTerms = [],
MaybeArgSizeInfo = yes(infinite(unit))
;
- ArgSizeTerm = term.functor(term.atom("finite"),
- [IntTerm, UsedArgsTerm], _),
+ ArgSizeFunctor = "finite",
+ ArgSizeArgTerms = [IntTerm, UsedArgsTerm],
IntTerm = term.functor(term.integer(Int), [], _),
- convert_bool_list(UsedArgsTerm, UsedArgs),
+ convert_bool_list(VarSet, UsedArgsTerm, UsedArgs),
MaybeArgSizeInfo = yes(finite(Int, UsedArgs))
),
+ TerminationTerm = term.functor(term.atom(TerminationFunctor), [], _),
(
- TerminationTerm = term.functor(term.atom("not_set"), [], _),
+ TerminationFunctor = "not_set",
MaybeTerminationInfo = no
;
- TerminationTerm = term.functor(term.atom("can_loop"), [], _),
+ TerminationFunctor = "can_loop",
MaybeTerminationInfo = yes(can_loop(unit))
;
- TerminationTerm = term.functor(term.atom("cannot_loop"), [], _),
+ TerminationFunctor = "cannot_loop",
MaybeTerminationInfo = yes(cannot_loop(unit))
- ),
+ )
+ ->
Pragma = pragma_termination_info(PredOrFunc, PredName, ModeList,
MaybeArgSizeInfo, MaybeTerminationInfo),
ItemPragma = item_pragma_info(user, Pragma, Context),
Item = item_pragma(ItemPragma),
- Result0 = ok1(Item)
- ->
- Result = Result0
+ Result = ok1(Item)
;
- Msg = "syntax error in `:- pragma termination_info' declaration",
- Result = error1([Msg - ErrorTerm])
+ Pieces = [words("Syntax error in"),
+ quote(":- pragma termination_info"), words("declaration."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
+ Result = error1([Spec])
).
-:- pred parse_pragma_termination2_info(module_name::in,
- list(term)::in, term::in, prog_context::in, maybe1(item)::out) is det.
+:- pred parse_pragma_termination2_info(module_name::in, list(term)::in,
+ term::in, varset::in, prog_context::in, maybe1(item)::out) is det.
-parse_pragma_termination2_info(ModuleName, PragmaTerms, ErrorTerm, Context,
- Result) :-
+parse_pragma_termination2_info(ModuleName, PragmaTerms, ErrorTerm, VarSet,
+ Context, Result) :-
(
- PragmaTerms = [
- PredAndModesTerm0,
- SuccessArgSizeTerm,
- FailureArgSizeTerm,
- TerminationTerm
- ],
+ PragmaTerms = [PredAndModesTerm0, SuccessArgSizeTerm,
+ FailureArgSizeTerm, TerminationTerm],
+ ContextPieces = [words("In"), quote(":- pragma termination2_info"),
+ words("declaration:")],
parse_pred_or_func_and_arg_modes(yes(ModuleName), PredAndModesTerm0,
- ErrorTerm, "`:- pragma termination2_info' declaration",
- NameAndModesResult),
+ ErrorTerm, VarSet, ContextPieces, NameAndModesResult),
NameAndModesResult = ok2(PredName - PredOrFunc, ModeList),
parse_arg_size_constraints(SuccessArgSizeTerm, SuccessArgSizeResult),
SuccessArgSizeResult = ok1(SuccessArgSizeInfo),
parse_arg_size_constraints(FailureArgSizeTerm, FailureArgSizeResult),
FailureArgSizeResult = ok1(FailureArgSizeInfo),
+ TerminationTerm = term.functor(term.atom(TerminationFunctor), [], _),
(
- TerminationTerm = term.functor(term.atom("not_set"), [], _),
+ TerminationFunctor = "not_set",
MaybeTerminationInfo = no
;
- TerminationTerm = term.functor(term.atom("can_loop"), [], _),
+ TerminationFunctor = "can_loop",
MaybeTerminationInfo = yes(can_loop(unit))
;
- TerminationTerm = term.functor(term.atom("cannot_loop"), [], _),
+ TerminationFunctor = "cannot_loop",
MaybeTerminationInfo = yes(cannot_loop(unit))
- ),
+ )
+ ->
Pragma = pragma_termination2_info(PredOrFunc, PredName, ModeList,
SuccessArgSizeInfo, FailureArgSizeInfo, MaybeTerminationInfo),
ItemPragma = item_pragma_info(user, Pragma, Context),
Item = item_pragma(ItemPragma),
- Result0 = ok1(Item)
- ->
- Result = Result0
+ Result = ok1(Item)
;
- Msg = "syntax error in `:- pragma termination2_info' declaration",
- Result = error1([Msg - ErrorTerm])
+ Pieces = [words("Syntax error in"),
+ quote(":- pragma termination2_info"), words("declaration."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
+ Result = error1([Spec])
).
-:- pred parse_pragma_structure_sharing(module_name::in,
- list(term)::in, term::in, prog_context::in, maybe1(item)::out) is det.
+:- pred parse_pragma_structure_sharing(module_name::in, list(term)::in,
+ term::in, varset::in, prog_context::in, maybe1(item)::out) is det.
-parse_pragma_structure_sharing(ModuleName, PragmaTerms, ErrorTerm, Context,
- Result) :-
+parse_pragma_structure_sharing(ModuleName, PragmaTerms, ErrorTerm, VarSet,
+ Context, Result) :-
(
- PragmaTerms = [
- PredAndModesTerm0,
- HeadVarsTerm,
- HeadVarTypesTerm,
- SharingInformationTerm
- ],
+ PragmaTerms = [PredAndModesTerm0, HeadVarsTerm,
+ HeadVarTypesTerm, SharingInformationTerm],
+ ModesContextPieces = [words("In"),
+ quote(":- pragma structure_sharing"), words("declaration:")],
parse_pred_or_func_and_arg_modes(yes(ModuleName), PredAndModesTerm0,
- ErrorTerm, "`:- pragma structure_sharing' declaration",
- NameAndModesResult),
+ ErrorTerm, VarSet, ModesContextPieces, NameAndModesResult),
NameAndModesResult = ok2(PredName - PredOrFunc, ModeList),
% Parse the head variables:
@@ -1079,18 +1201,19 @@
% Parse the types:
HeadVarTypesTerm = term.functor(term.atom("types"), ListTypeTerms, _),
- parse_types(ListTypeTerms, ok1(Types)),
+ maybe_parse_types(ListTypeTerms, Types),
% Parse the actual structure sharing information.
+ SharingInformationTerm = term.functor(term.atom(SharingFunctor),
+ SharingArgTerms, _),
(
- SharingInformationTerm = term.functor(term.atom("not_available"),
- _, _),
+ SharingFunctor = "not_available",
+ % XXX Why don't we test SharingArgTerms?
MaybeSharingAs = no
;
- SharingInformationTerm = term.functor(term.atom("yes"),
- SharingTerm, _),
- SharingTerm = [SharingAsTerm],
+ SharingFunctor = "yes",
+ SharingArgTerms = [SharingAsTerm],
MaybeSharingAs = yes(parse_structure_sharing_domain(SharingAsTerm))
)
->
@@ -1100,25 +1223,25 @@
Item = item_pragma(ItemPragma),
Result = ok1(Item)
;
- Msg = "syntax error in `:- pragma structure_sharing' declaration",
- Result = error1([Msg - ErrorTerm])
+ Pieces = [words("Syntax error in"),
+ quote(":- pragma structure_sharing"), words("declaration."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
+ Result = error1([Spec])
).
-:- pred parse_pragma_structure_reuse(module_name::in,
- list(term)::in, term::in, prog_context::in, maybe1(item)::out) is det.
+:- pred parse_pragma_structure_reuse(module_name::in, list(term)::in,
+ term::in, varset::in, prog_context::in, maybe1(item)::out) is det.
-parse_pragma_structure_reuse(ModuleName, PragmaTerms, ErrorTerm, Context,
- Result) :-
+parse_pragma_structure_reuse(ModuleName, PragmaTerms, ErrorTerm, VarSet,
+ Context, Result) :-
(
- PragmaTerms = [
- PredAndModesTerm0,
- HeadVarsTerm,
- HeadVarTypesTerm,
- MaybeStructureReuseTerm
- ],
+ PragmaTerms = [PredAndModesTerm0, HeadVarsTerm,
+ HeadVarTypesTerm, MaybeStructureReuseTerm],
+ ReuseContextPieces = [words("In"), quote(":- pragma structure_reuse"),
+ words("declaration:")],
parse_pred_or_func_and_arg_modes(yes(ModuleName), PredAndModesTerm0,
- ErrorTerm, "`:- pragma structure_reuse' declaration",
- NameAndModesResult),
+ ErrorTerm, VarSet, ReuseContextPieces, NameAndModesResult),
NameAndModesResult = ok2(PredName - PredOrFunc, ModeList),
% Parse the head variables:
@@ -1128,17 +1251,18 @@
% Parse the types:
HeadVarTypesTerm = term.functor(term.atom("types"), ListTypeTerms, _),
- parse_types(ListTypeTerms, ok1(Types)),
+ maybe_parse_types(ListTypeTerms, Types),
% Parse the actual structure reuse information.
+ MaybeStructureReuseTerm = term.functor(term.atom(ReuseFunctor),
+ ReuseArgTerms, _),
(
- MaybeStructureReuseTerm = term.functor(term.atom("not_available"),
- _, _),
+ ReuseFunctor = "not_available",
+ % XXX Why don't we test ReusegArgTerms?
MaybeStructureReuse = no
;
- MaybeStructureReuseTerm = term.functor(term.atom("yes"),
- MaybeStructureReuseTermArgs, _),
- MaybeStructureReuseTermArgs = [ StructureReuseTerm ],
+ ReuseFunctor = "yes",
+ ReuseArgTerms = [StructureReuseTerm],
StructureReuse = parse_structure_reuse_domain(StructureReuseTerm),
MaybeStructureReuse = yes(StructureReuse)
)
@@ -1149,50 +1273,51 @@
Item = item_pragma(ItemPragma),
Result = ok1(Item)
;
- Msg = "syntax error in `:- pragma structure_reuse' declaration",
- Result = error1([Msg - ErrorTerm])
+ Pieces = [words("Syntax error in"),
+ quote(":- pragma structure_reuse"), words("declaration."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
+ Result = error1([Spec])
).
-:- pred parse_pragma_exceptions(module_name::in,
- list(term)::in, term::in, prog_context::in, maybe1(item)::out) is det.
+:- pred parse_pragma_exceptions(module_name::in, list(term)::in, term::in,
+ varset::in, prog_context::in, maybe1(item)::out) is det.
-parse_pragma_exceptions(ModuleName, PragmaTerms, ErrorTerm, Context, Result) :-
- (
- PragmaTerms = [
- PredOrFuncTerm,
- PredNameTerm,
- term.functor(term.integer(Arity), [], _),
- term.functor(term.integer(ModeNum), [], _),
- ThrowStatusTerm
- ],
+parse_pragma_exceptions(ModuleName, PragmaTerms, ErrorTerm, VarSet, Context,
+ Result) :-
(
- PredOrFuncTerm = term.functor(term.atom("predicate"), [], _),
- PredOrFunc = pf_predicate
- ;
- PredOrFuncTerm = term.functor(term.atom("function"), [], _),
- PredOrFunc = pf_function
- ),
+ PragmaTerms = [PredOrFuncTerm, PredNameTerm, ArityTerm, ModeNumTerm,
+ ThrowStatusTerm],
+ parse_predicate_or_function(PredOrFuncTerm, PredOrFunc),
+ ArityTerm = term.functor(term.integer(Arity), [], _),
+ ModeNumTerm = term.functor(term.integer(ModeNum), [], _),
+ ContextPieces = [words("In"), quote(":- pragma exceptions"),
+ words("declaration:")],
parse_implicitly_qualified_term(ModuleName, PredNameTerm, ErrorTerm,
- "`:- pragma exceptions' declaration", PredNameResult),
+ VarSet, ContextPieces, PredNameResult),
PredNameResult = ok2(PredName, []),
+ ThrowStatusTerm = term.functor(term.atom(ThrowStatusFunctor),
+ ThrowStatusArgTerms, _),
(
- ThrowStatusTerm = term.functor(term.atom("will_not_throw"), [], _),
+ ThrowStatusFunctor = "will_not_throw",
+ ThrowStatusArgTerms = [],
ThrowStatus = will_not_throw
;
- ThrowStatusTerm = term.functor(term.atom("may_throw"),
- [ExceptionTypeTerm], _),
+ ThrowStatusFunctor = "may_throw",
+ ThrowStatusArgTerms = [ExceptionTypeTerm],
+ ExceptionTypeTerm = term.functor(term.atom(ExceptionFunctor),
+ [], _),
(
- ExceptionTypeTerm = term.functor(
- term.atom("user_exception"), [], _),
+ ExceptionFunctor = "user_exception",
ExceptionType = user_exception
;
- ExceptionTypeTerm = term.functor(
- term.atom("type_exception"), [], _),
+ ExceptionFunctor = "type_exception",
ExceptionType = type_exception
),
ThrowStatus = may_throw(ExceptionType)
;
- ThrowStatusTerm = term.functor( term.atom("conditional"), [], _),
+ ThrowStatusFunctor = "conditional",
+ ThrowStatusArgTerms = [],
ThrowStatus = throw_conditional
)
->
@@ -1202,43 +1327,39 @@
Item = item_pragma(ItemPragma),
Result = ok1(Item)
;
- Result = error1(["error in `:- pragma exceptions'" - ErrorTerm])
+ Pieces = [words("Error in"),
+ quote(":- pragma exceptions"), suffix("."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
+ Result = error1([Spec])
).
-:- pred parse_pragma_trailing_info(module_name::in,
- list(term)::in, term::in, prog_context::in, maybe1(item)::out) is det.
+:- pred parse_pragma_trailing_info(module_name::in, list(term)::in, term::in,
+ varset::in, prog_context::in, maybe1(item)::out) is det.
-parse_pragma_trailing_info(ModuleName, PragmaTerms, ErrorTerm, Context,
+parse_pragma_trailing_info(ModuleName, PragmaTerms, ErrorTerm, VarSet, Context,
Result) :-
(
- PragmaTerms = [
- PredOrFuncTerm,
- PredNameTerm,
- term.functor(term.integer(Arity), [], _),
- term.functor(term.integer(ModeNum), [], _),
- TrailingStatusTerm
- ],
- (
- PredOrFuncTerm = term.functor(term.atom("predicate"), [], _),
- PredOrFunc = pf_predicate
- ;
- PredOrFuncTerm = term.functor(term.atom("function"), [], _),
- PredOrFunc = pf_function
- ),
+ PragmaTerms = [PredOrFuncTerm, PredNameTerm, ArityTerm, ModeNumTerm,
+ TrailingStatusTerm],
+ parse_predicate_or_function(PredOrFuncTerm, PredOrFunc),
+ ArityTerm = term.functor(term.integer(Arity), [], _),
+ ModeNumTerm = term.functor(term.integer(ModeNum), [], _),
+ ContextPieces = [words("In"), quote(":- pragma trailing_info"),
+ words("declaration:")],
parse_implicitly_qualified_term(ModuleName, PredNameTerm, ErrorTerm,
- "`:- pragma trailing_info' declaration", PredNameResult),
+ VarSet, ContextPieces, PredNameResult),
PredNameResult = ok2(PredName, []),
+ TrailingStatusTerm = term.functor(term.atom(TrailingStatusFunctor),
+ [], _),
(
- TrailingStatusTerm = term.functor(
- term.atom("will_not_modify_trail"), [], _),
+ TrailingStatusFunctor = "will_not_modify_trail",
TrailingStatus = trail_will_not_modify
;
- TrailingStatusTerm = term.functor(
- term.atom("may_modify_trail"), [], _),
+ TrailingStatusFunctor = "may_modify_trail",
TrailingStatus = trail_may_modify
;
- TrailingStatusTerm = term.functor(
- term.atom("conditional"), [], _),
+ TrailingStatusFunctor = "conditional",
TrailingStatus = trail_conditional
)
->
@@ -1248,44 +1369,39 @@
Item = item_pragma(ItemPragma),
Result = ok1(Item)
;
- Result = error1(["error in `:- pragma trailing_info'" - ErrorTerm])
+ Pieces = [words("Error in"), quote(":- pragma trailing_info"),
+ suffix("."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
+ Result = error1([Spec])
).
-:- pred parse_pragma_mm_tabling_info(module_name::in,
- list(term)::in, term::in, prog_context::in, maybe1(item)::out) is det.
+:- pred parse_pragma_mm_tabling_info(module_name::in, list(term)::in, term::in,
+ varset::in, prog_context::in, maybe1(item)::out) is det.
-parse_pragma_mm_tabling_info(ModuleName, PragmaTerms, ErrorTerm, Context,
- Result) :-
- (
- PragmaTerms = [
- PredOrFuncTerm,
- PredNameTerm,
- term.functor(term.integer(Arity), [], _),
- term.functor(term.integer(ModeNum), [], _),
- MM_TablingStatusTerm
- ],
+parse_pragma_mm_tabling_info(ModuleName, PragmaTerms, ErrorTerm, VarSet,
+ Context, Result) :-
(
- PredOrFuncTerm = term.functor(term.atom("predicate"), [], _),
- PredOrFunc = pf_predicate
- ;
- PredOrFuncTerm = term.functor(term.atom("function"), [], _),
- PredOrFunc = pf_function
- ),
- parse_implicitly_qualified_term(ModuleName, PredNameTerm,
- ErrorTerm, "`:- pragma mm_tabling_info' declaration",
- PredNameResult),
+ PragmaTerms = [PredOrFuncTerm, PredNameTerm, ArityTerm, ModeNumTerm,
+ MM_TablingStatusTerm],
+ parse_predicate_or_function(PredOrFuncTerm, PredOrFunc),
+ ArityTerm = term.functor(term.integer(Arity), [], _),
+ ModeNumTerm = term.functor(term.integer(ModeNum), [], _),
+ ContextPieces = [words("In"), quote(":- pragma mm_tabling_info"),
+ words("declaration:")],
+ parse_implicitly_qualified_term(ModuleName, PredNameTerm, ErrorTerm,
+ VarSet, ContextPieces, PredNameResult),
PredNameResult = ok2(PredName, []),
+ MM_TablingStatusTerm = term.functor(term.atom(MM_TablingStatusFunctor),
+ [], _),
(
- MM_TablingStatusTerm = term.functor(
- term.atom("mm_tabled_will_not_call"), [], _),
+ MM_TablingStatusFunctor = "mm_tabled_will_not_call",
MM_TablingStatus = mm_tabled_will_not_call
;
- MM_TablingStatusTerm = term.functor(
- term.atom("mm_tabled_may_call"), [], _),
+ MM_TablingStatusFunctor = "mm_tabled_may_call",
MM_TablingStatus = mm_tabled_may_call
;
- MM_TablingStatusTerm = term.functor(
- term.atom("mm_tabled_conditional"), [], _),
+ MM_TablingStatusFunctor = "mm_tabled_conditional",
MM_TablingStatus = mm_tabled_conditional
)
->
@@ -1295,16 +1411,22 @@
Item = item_pragma(ItemPragma),
Result = ok1(Item)
;
- Result = error1(["error in `:- pragma mm_tabling_info'" - ErrorTerm])
+ Pieces = [words("Error in"), quote(":- pragma mm_tabling_info"),
+ suffix("."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
+ Result = error1([Spec])
).
-:- pred parse_pragma_require_feature_set(list(term)::in, term::in,
+:- pred parse_pragma_require_feature_set(list(term)::in, varset::in, term::in,
prog_context::in, maybe1(item)::out) is det.
-parse_pragma_require_feature_set(PragmaTerms, ErrorTerm, Context, Result) :-
+parse_pragma_require_feature_set(PragmaTerms, VarSet, ErrorTerm, Context,
+ Result) :-
( PragmaTerms = [FeatureListTerm] ->
- convert_maybe_list(FeatureListTerm, parse_required_feature,
- "not a feature", MaybeFeatureList),
+ UnrecognizedPieces = [words("Error: expected a feature"), nl],
+ convert_maybe_list("features", yes(VarSet), FeatureListTerm,
+ parse_required_feature, UnrecognizedPieces, MaybeFeatureList),
(
MaybeFeatureList = ok1(FeatureList),
ConflictingFeatures = [
@@ -1316,8 +1438,13 @@
list.member(ConflictA, FeatureList),
list.member(ConflictB, FeatureList)
->
- Msg = "conflicting features in feature set",
- Result = error1([Msg - FeatureListTerm])
+ FeatureListStr = describe_error_term(VarSet, FeatureListTerm),
+ Pieces = [words("Error: conflicting features in feature set:"),
+ nl, words(FeatureListStr), suffix("."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(FeatureListTerm),
+ [always(Pieces)])]),
+ Result = error1([Spec])
;
(
FeatureList = [],
@@ -1333,12 +1460,15 @@
Result = ok1(Item)
)
;
- MaybeFeatureList = error1(Errors),
- Result = error1(Errors)
+ MaybeFeatureList = error1(Specs),
+ Result = error1(Specs)
)
;
- Msg = "syntax error in `:- pragma require_feature_set' declaration",
- Result = error1([Msg - ErrorTerm])
+ Pieces = [words("Syntax error in"),
+ quote(":- pragma require_feature_set"), words("declaration."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
+ Result = error1([Spec])
).
%----------------------------------------------------------------------------%
@@ -1365,30 +1495,45 @@
parse_foreign_language(term.functor(term.atom(String), _, _), Lang) :-
globals.convert_foreign_language(String, Lang).
-:- pred parse_foreign_language_type(term::in, foreign_language::in,
+:- pred parse_foreign_language_type(term::in, varset::in, foreign_language::in,
maybe1(foreign_language_type)::out) is det.
-parse_foreign_language_type(InputTerm, Language, Result) :-
+parse_foreign_language_type(InputTerm, VarSet, Language, Result) :-
(
Language = lang_il,
( InputTerm = term.functor(term.string(ILTypeName), [], _) ->
- parse_il_type_name(ILTypeName, InputTerm, Result)
+ parse_il_type_name(ILTypeName, InputTerm, VarSet, Result)
;
- Result = error1(["invalid backend specification term" - InputTerm])
+ InputTermStr = describe_error_term(VarSet, InputTerm),
+ Pieces = [words("Error: invalid backend specification"),
+ quote(InputTermStr), suffix("."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(InputTerm), [always(Pieces)])]),
+ Result = error1([Spec])
)
;
Language = lang_c,
( InputTerm = term.functor(term.string(CTypeName), [], _) ->
Result = ok1(c(c_type(CTypeName)))
;
- Result = error1(["invalid backend specification term" - InputTerm])
+ InputTermStr = describe_error_term(VarSet, InputTerm),
+ Pieces = [words("Error: invalid backend specification"),
+ quote(InputTermStr), suffix("."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(InputTerm), [always(Pieces)])]),
+ Result = error1([Spec])
)
;
Language = lang_java,
( InputTerm = term.functor(term.string(JavaTypeName), [], _) ->
Result = ok1(java(java_type(JavaTypeName)))
;
- Result = error1(["invalid backend specification term" - InputTerm])
+ InputTermStr = describe_error_term(VarSet, InputTerm),
+ Pieces = [words("Error: invalid backend specification"),
+ quote(InputTermStr), suffix("."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(InputTerm), [always(Pieces)])]),
+ Result = error1([Spec])
)
;
Language = lang_erlang,
@@ -1396,18 +1541,26 @@
% XXX should we check if the type is blank?
Result = ok1(erlang(erlang_type))
;
- Result = error1(["invalid backend specification term" - InputTerm])
+ InputTermStr = describe_error_term(VarSet, InputTerm),
+ Pieces = [words("Error: invalid backend specification"),
+ quote(InputTermStr), suffix("."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(InputTerm), [always(Pieces)])]),
+ Result = error1([Spec])
)
;
Language = lang_csharp,
- Msg = "unsupported language specified, unable to parse backend type",
- Result = error1([Msg - InputTerm])
+ Pieces = [words("Error: unsupported language specified,"),
+ words("unable to parse backend type."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(InputTerm), [always(Pieces)])]),
+ Result = error1([Spec])
).
-:- pred parse_il_type_name(string::in, term::in,
+:- pred parse_il_type_name(string::in, term::in, varset::in,
maybe1(foreign_language_type)::out) is det.
-parse_il_type_name(String0, ErrorTerm, ForeignType) :-
+parse_il_type_name(String0, ErrorTerm, VarSet, ForeignType) :-
(
parse_special_il_type_name(String0, ForeignTypeResult)
->
@@ -1429,8 +1582,12 @@
TypeSymName = string_to_sym_name(TypeNameStr),
ForeignType = ok1(il(il_type(value, AssemblyName, TypeSymName)))
;
- ForeignType = error1(["invalid foreign language type description" -
- ErrorTerm])
+ TermStr = describe_error_term(VarSet, ErrorTerm),
+ Pieces = [words("Error: invalid foreign language type description"),
+ quote(TermStr), suffix("."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
+ ForeignType = error1([Spec])
).
% Parse all the special assembler names for all the builtin types.
@@ -1520,9 +1677,9 @@
maybe1(item)::out) is det.
parse_pragma_foreign_decl_pragma(_ModuleName, PragmaName, PragmaTerms,
- ErrorTerm, _VarSet, Context, Result) :-
- string.format("invalid `:- pragma %s' declaration ", [s(PragmaName)],
- InvalidDeclStr),
+ ErrorTerm, VarSet, Context, Result) :-
+ InvalidDeclPieces = [words("Error: invalid"),
+ quote(":- pragma " ++ PragmaName), words("declaration:")],
(
(
PragmaTerms = [LangTerm, HeaderTerm],
@@ -1540,18 +1697,29 @@
Item = item_pragma(ItemPragma),
Result = ok1(Item)
;
- ErrMsg = "-- expected string for foreign declaration code",
- Result = error1([string.append(InvalidDeclStr, ErrMsg) -
- HeaderTerm])
- )
- ;
- ErrMsg = "-- invalid language parameter",
- Result = error1([(InvalidDeclStr ++ ErrMsg) - LangTerm])
- )
- ;
- string.format("invalid `:- pragma %s' declaration ",
- [s(PragmaName)], ErrorStr),
- Result = error1([ErrorStr - ErrorTerm])
+ Pieces = InvalidDeclPieces ++
+ [words("expected string for foreign declaration code."),
+ nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(HeaderTerm),
+ [always(Pieces)])]),
+ Result = error1([Spec])
+ )
+ ;
+ Pieces = InvalidDeclPieces ++
+ [words("invalid language parameter."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(LangTerm),
+ [always(Pieces)])]),
+ Result = error1([Spec])
+ )
+ ;
+ TermStr = describe_error_term(VarSet, ErrorTerm),
+ Pieces = [words("Error: invalid"), quote(":- pragma " ++ PragmaName),
+ words("declaration:"), words(TermStr), suffix("."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
+ Result = error1([Spec])
).
% This predicate parses both c_code and foreign_code pragmas.
@@ -1564,39 +1732,50 @@
parse_pragma_foreign_code_pragma(_ModuleName, PragmaName, PragmaTerms,
ErrorTerm, _VarSet, Context, Result) :-
- string.format("invalid `:- pragma %s' declaration ", [s(PragmaName)],
- InvalidDeclStr),
+ InvalidDeclPrefix = [words("Error: invalid"),
+ quote(":- pragma " ++ PragmaName), words("declaration:")],
( PragmaTerms = [LangTerm, CodeTerm] ->
( parse_foreign_language(LangTerm, ForeignLanguagePrime) ->
ForeignLanguage = ForeignLanguagePrime,
- LangErrs = []
+ LangSpecs = []
;
- LangMsg = InvalidDeclStr ++ "-- invalid language parameter",
- LangErrs = [LangMsg - LangTerm],
- ForeignLanguage = lang_c % Dummy, ignored when LangErrs \= []
+ ForeignLanguage = lang_c, % Dummy, ignored when LangSpecs \= []
+ LangPieces = InvalidDeclPrefix ++
+ [words("invalid language parameter."), nl],
+ LangSpec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(LangTerm),
+ [always(LangPieces)])]),
+ LangSpecs = [LangSpec]
),
( CodeTerm = term.functor(term.string(CodePrime), [], _) ->
Code = CodePrime,
- CodeErrs = []
+ CodeSpecs = []
;
- Code = "", % Dummy, ignored when CodeErrs \= []
- CodeMsg = InvalidDeclStr ++ "-- expected string for foreign code",
- CodeErrs = [CodeMsg - CodeTerm]
+ Code = "", % Dummy, ignored when CodeSpecs \= []
+ CodePieces = InvalidDeclPrefix ++
+ [words("expected string for foreign code."), nl],
+ CodeSpec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(CodeTerm),
+ [always(CodePieces)])]),
+ CodeSpecs = [CodeSpec]
),
- Errs = LangErrs ++ CodeErrs,
+ Specs = LangSpecs ++ CodeSpecs,
(
- Errs = [],
+ Specs = [],
Pragma = pragma_foreign_code(ForeignLanguage, Code),
ItemPragma = item_pragma_info(user, Pragma, Context),
Item = item_pragma(ItemPragma),
Result = ok1(Item)
;
- Errs = [_ | _],
- Result = error1(Errs)
+ Specs = [_ | _],
+ Result = error1(Specs)
)
;
- Msg = InvalidDeclStr ++ "-- wrong number of arguments",
- Result = error1([Msg - ErrorTerm])
+ Pieces = InvalidDeclPrefix ++
+ [words("wrong number of arguments."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
+ Result = error1([Spec])
).
% This predicate parses both c_code and foreign_proc pragmas.
@@ -1607,29 +1786,33 @@
parse_pragma_foreign_proc_pragma(ModuleName, PragmaName, PragmaTerms,
ErrorTerm, VarSet, Context, Result) :-
- string.format("invalid `:- pragma %s' declaration ", [s(PragmaName)],
- InvalidDeclStr),
+ InvalidDeclPrefix = [words("Error: invalid"),
+ quote(":- pragma " ++ PragmaName), words("declaration:")],
(
PragmaTerms = [LangTerm | RestTerms],
( parse_foreign_language(LangTerm, ForeignLanguagePrime) ->
ForeignLanguage = ForeignLanguagePrime,
- LangErrs = []
+ LangSpecs = []
;
- ForeignLanguage = lang_c, % Dummy, ignored when LangErrs \= []
- LangMsg = "-- invalid language parameter",
- LangErrs = [(InvalidDeclStr ++ LangMsg) - LangTerm]
+ ForeignLanguage = lang_c, % Dummy, ignored when LangSpecs \= []
+ LangPieces = InvalidDeclPrefix ++
+ [words("invalid language parameter."), nl],
+ LangSpec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(LangTerm),
+ [always(LangPieces)])]),
+ LangSpecs = [LangSpec]
),
(
(
RestTerms = [PredAndVarsTerm, CodeTerm],
parse_pragma_ordinary_foreign_proc_pragma_old(ModuleName,
PragmaName, VarSet, PredAndVarsTerm, CodeTerm, ErrorTerm,
- ForeignLanguage, InvalidDeclStr, Context, RestResult)
+ ForeignLanguage, InvalidDeclPrefix, Context, RestResult)
;
RestTerms = [PredAndVarsTerm, FlagsTerm, CodeTerm],
parse_pragma_ordinary_foreign_proc_pragma(ModuleName,
PragmaName, VarSet, PredAndVarsTerm, FlagsTerm, CodeTerm,
- ForeignLanguage, InvalidDeclStr, Context, RestResult)
+ ForeignLanguage, InvalidDeclPrefix, Context, RestResult)
;
RestTerms = [PredAndVarsTerm, FlagsTerm, FieldsTerm,
FirstTerm, LaterTerm],
@@ -1640,46 +1823,53 @@
parse_pragma_model_non_foreign_proc_pragma(ModuleName,
PragmaName, VarSet, PredAndVarsTerm, FlagsTerm,
FieldsTerm, FirstTerm, LaterTerm, SharedTerm,
- ForeignLanguage, InvalidDeclStr, Context, RestResult)
+ ForeignLanguage, InvalidDeclPrefix, Context, RestResult)
;
RestTerms = [PredAndVarsTerm, FlagsTerm, FieldsTerm,
FirstTerm, LaterTerm, SharedTerm],
parse_pragma_model_non_foreign_proc_pragma(ModuleName,
PragmaName, VarSet, PredAndVarsTerm, FlagsTerm,
FieldsTerm, FirstTerm, LaterTerm, SharedTerm,
- ForeignLanguage, InvalidDeclStr, Context, RestResult)
+ ForeignLanguage, InvalidDeclPrefix, Context, RestResult)
)
->
(
RestResult = ok1(Item),
(
- LangErrs = [],
+ LangSpecs = [],
Result = ok1(Item)
;
- LangErrs = [_ | _],
- Result = error1(LangErrs)
+ LangSpecs = [_ | _],
+ Result = error1(LangSpecs)
)
;
- RestResult = error1(RestErrs),
- Result = error1(LangErrs ++ RestErrs)
+ RestResult = error1(RestSpecs),
+ Result = error1(LangSpecs ++ RestSpecs)
)
;
- ErrMsg = "-- wrong number of arguments",
- Result = error1([(InvalidDeclStr ++ ErrMsg) - ErrorTerm])
+ Pieces = InvalidDeclPrefix ++
+ [words("wrong number of arguments."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
+ Result = error1([Spec])
)
;
PragmaTerms = [],
- ErrMsg = "-- wrong number of arguments",
- Result = error1([(InvalidDeclStr ++ ErrMsg) - ErrorTerm])
+ PragmaTerms = [],
+ Pieces = InvalidDeclPrefix ++
+ [words("wrong number of arguments."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
+ Result = error1([Spec])
).
:- pred parse_pragma_ordinary_foreign_proc_pragma_old(module_name::in,
string::in, varset::in, term::in, term::in, term::in, foreign_language::in,
- string::in, prog_context::in, maybe1(item)::out) is det.
+ list(format_component)::in, prog_context::in, maybe1(item)::out) is det.
parse_pragma_ordinary_foreign_proc_pragma_old(ModuleName, PragmaName, VarSet,
- PredAndVarsTerm, CodeTerm, ErrorTerm, ForeignLanguage, InvalidDeclStr,
- Context, Result) :-
+ PredAndVarsTerm, CodeTerm, ErrorTerm, ForeignLanguage,
+ InvalidDeclPrefix, Context, Result) :-
% XXX We should issue a warning; this syntax is deprecated. We will
% continue to accept this if c_code is used, but not with foreign_code.
( PragmaName = "c_code" ->
@@ -1690,43 +1880,57 @@
parse_pragma_foreign_code(ModuleName, Attributes,
PredAndVarsTerm, Impl, VarSet, Context, Result)
;
- ErrMsg = "-- expecting either `may_call_mercury' or "
- ++ "`will_not_call_mercury', and a string for foreign code",
- Result = error1([(InvalidDeclStr ++ ErrMsg) - CodeTerm])
+ Pieces = InvalidDeclPrefix ++
+ [words("expecting either"), quote("may_call_mercury"),
+ words("or"), quote("will_not_call_mercury"), suffix(","),
+ words("and a string for foreign code."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(CodeTerm), [always(Pieces)])]),
+ Result = error1([Spec])
)
;
- ErrMsg = "-- doesn't say whether it can call mercury",
- Result = error1([(InvalidDeclStr ++ ErrMsg) - ErrorTerm])
+ Pieces = InvalidDeclPrefix ++
+ [words("does not say whether it can call Mercury."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
+ Result = error1([Spec])
).
:- pred parse_pragma_ordinary_foreign_proc_pragma(module_name::in, string::in,
varset::in, term::in, term::in, term::in, foreign_language::in,
- string::in, prog_context::in, maybe1(item)::out) is det.
+ list(format_component)::in, prog_context::in, maybe1(item)::out) is det.
parse_pragma_ordinary_foreign_proc_pragma(ModuleName, PragmaName, VarSet,
- SecondTerm, ThirdTerm, CodeTerm, ForeignLanguage, InvalidDeclStr,
+ SecondTerm, ThirdTerm, CodeTerm, ForeignLanguage, InvalidDeclPrefix,
Context, Result) :-
- ( CodeTerm = term.functor(term.string(CodePrime), [], CodeContextPrime) ->
+ CodeContext = get_term_context(CodeTerm),
+ ( CodeTerm = term.functor(term.string(CodePrime), [], _) ->
Code = CodePrime,
- CodeContext = CodeContextPrime,
- CodeErrs = []
+ CodeSpecs = []
;
Code = "", % Dummy
- CodeContext = term.context_init, % Dummy
- CodeMsg = "-- invalid fourth argument, "
- ++ "expecting string containing foreign code",
- CodeErrs = [(InvalidDeclStr ++ CodeMsg) - CodeTerm]
+ CodePieces = InvalidDeclPrefix ++
+ [words("invalid fourth argument,"),
+ words("expecting string containing foreign code."), nl],
+ CodeSpec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(CodeContext, [always(CodePieces)])]),
+ CodeSpecs = [CodeSpec]
),
+ ThirdContextPieces =
+ InvalidDeclPrefix ++ [words("invalid third argument:")],
parse_pragma_foreign_proc_attributes_term(ForeignLanguage, PragmaName,
- VarSet, ThirdTerm, MaybeFlagsThird),
+ VarSet, ThirdTerm, ThirdContextPieces, MaybeFlagsThird),
(
MaybeFlagsThird = ok1(Flags),
- FlagsErrs = [],
+ FlagsSpecs = [],
PredAndVarsTerm = SecondTerm
;
- MaybeFlagsThird = error1(FlagsThirdErrors),
+ MaybeFlagsThird = error1(_FlagsThirdSpecs),
+ % We report any errors as appropriate to the preferred syntax.
+ SecondContextPieces = InvalidDeclPrefix ++
+ [lower_case_next_if_not_first, words("Invalid second argument:")],
parse_pragma_foreign_proc_attributes_term(ForeignLanguage, PragmaName,
- VarSet, SecondTerm, MaybeFlagsSecond),
+ VarSet, SecondTerm, SecondContextPieces, MaybeFlagsSecond),
(
MaybeFlagsSecond = ok1(Flags),
% XXX We should issue a warning; this syntax is deprecated.
@@ -1734,52 +1938,53 @@
% but not with foreign_code.
( PragmaName = "c_code" ->
PredAndVarsTerm = ThirdTerm,
- FlagsErrs = []
+ FlagsSpecs = []
;
PredAndVarsTerm = ThirdTerm, % Dummy
- FlagsMsg = "-- invalid second argument, "
- ++ "expecting predicate or function mode",
- FlagsErrs = [(InvalidDeclStr ++ FlagsMsg) - SecondTerm]
+ FlagsPieces = InvalidDeclPrefix ++
+ [words("invalid second argument,"),
+ words("expecting predicate or function mode."), nl],
+ FlagsSpec = error_spec(severity_error,
+ phase_term_to_parse_tree,
+ [simple_msg(get_term_context(SecondTerm),
+ [always(FlagsPieces)])]),
+ FlagsSpecs = [FlagsSpec]
)
;
- MaybeFlagsSecond = error1(_),
+ MaybeFlagsSecond = error1(FlagsSpecs),
Flags = default_attributes(ForeignLanguage), % Dummy
- PredAndVarsTerm = SecondTerm, % Dummy
- % We report the error appropriate to the preferred syntax.
- FlagsErrs = assoc_list.map_keys_only(string.append(
- InvalidDeclStr ++ "-- invalid third argument: "),
- FlagsThirdErrors)
+ PredAndVarsTerm = SecondTerm % Dummy
)
),
- Errs = CodeErrs ++ FlagsErrs,
+ Specs = CodeSpecs ++ FlagsSpecs,
(
- Errs = [],
+ Specs = [],
Impl = fc_impl_ordinary(Code, yes(CodeContext)),
parse_pragma_foreign_code(ModuleName, Flags, PredAndVarsTerm,
Impl, VarSet, Context, Result)
;
- Errs = [_ | _],
- Result = error1(Errs)
+ Specs = [_ | _],
+ Result = error1(Specs)
).
:- pred parse_pragma_model_non_foreign_proc_pragma(module_name::in, string::in,
varset::in, term::in, term::in, term::in, term::in, term::in,
- term::in, foreign_language::in, string::in, prog_context::in,
- maybe1(item)::out) is det.
+ term::in, foreign_language::in, list(format_component)::in,
+ prog_context::in, maybe1(item)::out) is det.
parse_pragma_model_non_foreign_proc_pragma(ModuleName, PragmaName, VarSet,
PredAndVarsTerm, FlagsTerm, FieldsTerm, FirstTerm, LaterTerm,
- SharedTerm, ForeignLanguage, InvalidDeclStr, Context, Result) :-
+ SharedTerm, ForeignLanguage, InvalidDeclPrefix, Context, Result) :-
+ FlagsContextPieces = InvalidDeclPrefix ++
+ [lower_case_next_if_not_first, words("Invalid third argument:")],
parse_pragma_foreign_proc_attributes_term(ForeignLanguage, PragmaName,
- VarSet, FlagsTerm, MaybeFlags),
+ VarSet, FlagsTerm, FlagsContextPieces, MaybeFlags),
(
MaybeFlags = ok1(Flags),
- FlagsErrs = []
+ FlagsSpecs = []
;
- MaybeFlags = error1(FlagErrs0),
- Flags = default_attributes(ForeignLanguage), % Dummy
- FlagsErrs = assoc_list.map_keys_only(string.append(
- InvalidDeclStr ++ "-- invalid third argument: "), FlagErrs0)
+ MaybeFlags = error1(FlagsSpecs),
+ Flags = default_attributes(ForeignLanguage) % Dummy
),
(
parse_pragma_keyword("local_vars", FieldsTerm,
@@ -1787,13 +1992,16 @@
->
Fields = FieldsPrime,
FieldsContext = FieldsContextPrime,
- LocalErrs = []
+ LocalSpecs = []
;
Fields = "", % Dummy
- FieldsContext = term.context_init, % Dummy
- LocalMsg = "-- invalid fourth argument, "
- ++ "expecting `local_vars(<fields>)'",
- LocalErrs = [(InvalidDeclStr ++ LocalMsg) - FieldsTerm]
+ FieldsContext = get_term_context(FieldsTerm),
+ LocalPieces = InvalidDeclPrefix ++
+ [words("invalid fourth argument, expecting"),
+ quote("local_vars(<fields>)"), suffix("."), nl],
+ LocalSpec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(FieldsContext, [always(LocalPieces)])]),
+ LocalSpecs = [LocalSpec]
),
(
parse_pragma_keyword("first_code", FirstTerm,
@@ -1801,12 +2009,16 @@
->
First = FirstPrime,
FirstContext = FirstContextPrime,
- FirstErrs = []
+ FirstSpecs = []
;
First = "", % Dummy
- FirstContext = term.context_init, % Dummy
- FirstMsg = "-- invalid fifth argument, expecting `first_code(<code>)'",
- FirstErrs = [(InvalidDeclStr ++ FirstMsg) - FirstTerm]
+ FirstContext = get_term_context(FirstTerm),
+ FirstPieces = InvalidDeclPrefix ++
+ [words("invalid fifth argument, expecting"),
+ quote("first_code(<code>)"), suffix("."), nl],
+ FirstSpec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(FirstContext, [always(FirstPieces)])]),
+ FirstSpecs = [FirstSpec]
),
(
parse_pragma_keyword("retry_code", LaterTerm,
@@ -1814,12 +2026,16 @@
->
Later = LaterPrime,
LaterContext = LaterContextPrime,
- LaterErrs = []
+ LaterSpecs = []
;
Later = "", % Dummy
- LaterContext = term.context_init, % Dummy
- LaterMsg = "-- invalid sixth argument, expecting `retry_code(<code>)'",
- LaterErrs = [(InvalidDeclStr ++ LaterMsg) - LaterTerm]
+ LaterContext = get_term_context(LaterTerm),
+ LaterPieces = InvalidDeclPrefix ++
+ [words("invalid sixth argument, expecting"),
+ quote("retry_code(<code>)"), suffix("."), nl],
+ LaterSpec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(LaterTerm), [always(LaterPieces)])]),
+ LaterSpecs = [LaterSpec]
),
(
parse_pragma_keyword("shared_code", SharedTerm,
@@ -1828,7 +2044,7 @@
Shared = SharedPrime,
SharedContext = SharedContextPrime,
Treatment = shared_code_share,
- SharedErrs = []
+ SharedSpecs = []
;
parse_pragma_keyword("duplicated_code", SharedTerm,
SharedPrime, SharedContextPrime)
@@ -1836,7 +2052,7 @@
Shared = SharedPrime,
SharedContext = SharedContextPrime,
Treatment = shared_code_duplicate,
- SharedErrs = []
+ SharedSpecs = []
;
parse_pragma_keyword("common_code", SharedTerm,
SharedPrime, SharedContextPrime)
@@ -1844,61 +2060,69 @@
Shared = SharedPrime,
SharedContext = SharedContextPrime,
Treatment = shared_code_automatic,
- SharedErrs = []
+ SharedSpecs = []
;
Shared = "", % Dummy
SharedContext = term.context_init, % Dummy
Treatment = shared_code_automatic, % Dummy
- SharedMsg = "-- invalid seventh argument, "
- ++ "expecting `common_code(<code>)'",
- SharedErrs = [(InvalidDeclStr ++ SharedMsg) - SharedTerm]
+ SharedPieces = InvalidDeclPrefix ++
+ [words("invalid seventh argument, expecting"),
+ quote("common_code(<code>)"), suffix("."), nl],
+ SharedSpec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(SharedTerm),
+ [always(SharedPieces)])]),
+ SharedSpecs = [SharedSpec]
),
- Errs = FlagsErrs ++ LocalErrs ++ FirstErrs ++ LaterErrs ++ SharedErrs,
+ Specs =
+ FlagsSpecs ++ LocalSpecs ++ FirstSpecs ++ LaterSpecs ++ SharedSpecs,
(
- Errs = [],
+ Specs = [],
Impl = fc_impl_model_non(Fields, yes(FieldsContext),
First, yes(FirstContext), Later, yes(LaterContext),
Treatment, Shared, yes(SharedContext)),
parse_pragma_foreign_code(ModuleName, Flags, PredAndVarsTerm,
Impl, VarSet, Context, Result)
;
- Errs = [_ | _],
- Result = error1(Errs)
+ Specs = [_ | _],
+ Result = error1(Specs)
).
% This parses a pragma that refers to a predicate or function.
%
:- pred parse_simple_pragma(module_name::in, string::in,
pred(sym_name, int, pragma_type)::(pred(in, in, out) is det),
- list(term)::in, term::in, prog_context::in, maybe1(item)::out) is det.
+ list(term)::in, term::in, varset::in, prog_context::in, maybe1(item)::out)
+ is det.
-parse_simple_pragma(ModuleName, PragmaType, MakePragma, PragmaTerms, ErrorTerm,
- Context, Result) :-
- parse_simple_pragma_base(ModuleName, PragmaType, "predicate or function",
- MakePragma, PragmaTerms, ErrorTerm, Context, Result).
+parse_simple_pragma(ModuleName, PragmaName, MakePragma, PragmaTerms, ErrorTerm,
+ VarSet, Context, Result) :-
+ parse_simple_pragma_base(ModuleName, PragmaName, "predicate or function",
+ MakePragma, PragmaTerms, ErrorTerm, VarSet, Context, Result).
% This parses a pragma that refers to type.
%
:- pred parse_simple_type_pragma(module_name::in, string::in,
pred(sym_name, int, pragma_type)::(pred(in, in, out) is det),
- list(term)::in, term::in, prog_context::in, maybe1(item)::out) is det.
+ list(term)::in, term::in, varset::in, prog_context::in, maybe1(item)::out)
+ is det.
-parse_simple_type_pragma(ModuleName, PragmaType, MakePragma,
- PragmaTerms, ErrorTerm, Context, Result) :-
- parse_simple_pragma_base(ModuleName, PragmaType, "type", MakePragma,
- PragmaTerms, ErrorTerm, Context, Result).
+parse_simple_type_pragma(ModuleName, PragmaName, MakePragma,
+ PragmaTerms, ErrorTerm, VarSet, Context, Result) :-
+ parse_simple_pragma_base(ModuleName, PragmaName, "type", MakePragma,
+ PragmaTerms, ErrorTerm, VarSet, Context, Result).
% This parses a pragma that refers to symbol name / arity.
%
:- pred parse_simple_pragma_base(module_name::in, string::in, string::in,
pred(sym_name, int, pragma_type)::(pred(in, in, out) is det),
- list(term)::in, term::in, prog_context::in, maybe1(item)::out) is det.
+ list(term)::in, term::in, varset::in, prog_context::in, maybe1(item)::out)
+ is det.
-parse_simple_pragma_base(ModuleName, PragmaType, NameKind, MakePragma,
- PragmaTerms, ErrorTerm, Context, Result) :-
+parse_simple_pragma_base(ModuleName, PragmaName, NameKind, MakePragma,
+ PragmaTerms, ErrorTerm, VarSet, Context, Result) :-
( PragmaTerms = [PredAndArityTerm] ->
- parse_simple_name_and_arity(ModuleName, PragmaType, NameKind,
- PredAndArityTerm, PredAndArityTerm, NameArityResult),
+ parse_simple_name_and_arity(ModuleName, PragmaName, NameKind,
+ PredAndArityTerm, PredAndArityTerm, VarSet, NameArityResult),
(
NameArityResult = ok2(PredName, Arity),
MakePragma(PredName, Arity, Pragma),
@@ -1906,34 +2130,41 @@
Item = item_pragma(ItemPragma),
Result = ok1(Item)
;
- NameArityResult = error2(Errors),
- Result = error1(Errors)
+ NameArityResult = error2(Specs),
+ Result = error1(Specs)
)
;
- ErrorMsg = "wrong number of arguments in `:- pragma " ++
- PragmaType ++ "' declaration",
- Result = error1([ErrorMsg - ErrorTerm])
+ Pieces = [words("Error: wrong number of arguments in"),
+ quote(":- pragma " ++ PragmaName), words("declaration."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
+ Result = error1([Spec])
).
:- pred parse_pred_name_and_arity(module_name::in, string::in, term::in,
- term::in, maybe2(sym_name, arity)::out) is det.
+ term::in, varset::in, maybe2(sym_name, arity)::out) is det.
-parse_pred_name_and_arity(ModuleName, PragmaType, NameAndArityTerm, ErrorTerm,
- Result) :-
- parse_simple_name_and_arity(ModuleName, PragmaType,
- "predicate or function", NameAndArityTerm, ErrorTerm, Result).
+parse_pred_name_and_arity(ModuleName, PragmaName, NameAndArityTerm, ErrorTerm,
+ VarSet, Result) :-
+ parse_simple_name_and_arity(ModuleName, PragmaName,
+ "predicate or function", NameAndArityTerm, ErrorTerm, VarSet, Result).
:- pred parse_simple_name_and_arity(module_name::in, string::in, string::in,
- term::in, term::in, maybe2(sym_name, arity)::out) is det.
+ term::in, term::in, varset::in, maybe2(sym_name, arity)::out) is det.
-parse_simple_name_and_arity(ModuleName, PragmaType, NameKind,
- NameAndArityTerm, ErrorTerm, Result) :-
+parse_simple_name_and_arity(ModuleName, PragmaName, NameKind,
+ NameAndArityTerm, ErrorTerm, VarSet, Result) :-
( parse_name_and_arity(ModuleName, NameAndArityTerm, Name, Arity) ->
Result = ok2(Name, Arity)
;
- ErrorMsg = "expected " ++ NameKind ++ " name/arity for `pragma " ++
- PragmaType ++ "' declaration",
- Result = error2([ErrorMsg - ErrorTerm])
+ NameAndArityTermStr = describe_error_term(VarSet, NameAndArityTerm),
+ Pieces = [words("Error: expected"), words(NameKind),
+ words("name/arity for"), quote(":- pragma " ++ PragmaName),
+ words("declaration, not"), quote(NameAndArityTermStr),
+ suffix("."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
+ Result = error2([Spec])
).
%-----------------------------------------------------------------------------%
@@ -1967,11 +2198,11 @@
; coll_may_duplicate(proc_may_duplicate).
:- pred parse_pragma_foreign_proc_attributes_term(foreign_language::in,
- string::in, varset::in, term::in,
+ string::in, varset::in, term::in, list(format_component)::in,
maybe1(pragma_foreign_proc_attributes)::out) is det.
parse_pragma_foreign_proc_attributes_term(ForeignLanguage, PragmaName, Varset,
- Term, MaybeAttributes) :-
+ Term, ContextPieces, MaybeAttributes) :-
Attributes0 = default_attributes(ForeignLanguage),
( ( PragmaName = "c_code" ; PragmaName = "import" ) ->
set_legacy_purity_behaviour(yes, Attributes0, Attributes1),
@@ -2037,16 +2268,24 @@
->
% We could include Conflict1 and Conflict2 in the message,
% but the conflict is usually very obvious even without this.
- Msg = "conflicting attributes in attribute list",
- MaybeAttributes = error1([Msg - Term])
+ Pieces = ContextPieces ++ [lower_case_next_if_not_first,
+ words("Conflicting attributes in attribute list."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(Term), [always(Pieces)])]),
+ MaybeAttributes = error1([Spec])
;
list.foldl(process_attribute, AttrList, Attributes2, Attributes),
MaybeAttributes = check_required_attributes(ForeignLanguage,
- Attributes, Term)
+ Attributes, ContextPieces, Term)
)
;
- ErrMsg = "expecting a foreign proc attribute or list of attributes",
- MaybeAttributes = error1([ErrMsg - Term])
+ % XXX We should say we are expecting just a list.
+ Pieces = ContextPieces ++ [lower_case_next_if_not_first,
+ words("Expecting a foreign proc attribute"),
+ words("or list of attributes."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(Term), [always(Pieces)])]),
+ MaybeAttributes = error1([Spec])
).
% Update the pragma_foreign_proc_attributes according to the given
@@ -2095,25 +2334,30 @@
% a particular language
%
:- func check_required_attributes(foreign_language,
- pragma_foreign_proc_attributes, term)
+ pragma_foreign_proc_attributes, list(format_component), term)
= maybe1(pragma_foreign_proc_attributes).
-check_required_attributes(lang_c, Attrs, _Term) = ok1(Attrs).
-check_required_attributes(lang_csharp, Attrs, _Term) = ok1(Attrs).
-check_required_attributes(lang_il, Attrs, Term) = Res :-
+check_required_attributes(lang_c, Attrs, _CP, _Term) = ok1(Attrs).
+check_required_attributes(lang_csharp, Attrs, _CP, _Term) = ok1(Attrs).
+check_required_attributes(lang_il, Attrs, ContextPieces, Term) = Result :-
MaxStackAttrs = list.filter_map(
(func(X) = X is semidet :-
X = max_stack_size(_)),
get_extra_attributes(Attrs)),
(
MaxStackAttrs = [],
- Res = error1(["expecting max_stack_size attribute for IL code" - Term])
+ Pieces = ContextPieces ++ [lower_case_next_if_not_first,
+ words("Error: expecting max_stack_size attribute for IL code."),
+ nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(Term), [always(Pieces)])]),
+ Result = error1([Spec])
;
MaxStackAttrs = [_ | _],
- Res = ok1(Attrs)
+ Result = ok1(Attrs)
).
-check_required_attributes(lang_java, Attrs, _Term) = ok1(Attrs).
-check_required_attributes(lang_erlang, Attrs, _Term) = ok1(Attrs).
+check_required_attributes(lang_java, Attrs, _CP, _Term) = ok1(Attrs).
+check_required_attributes(lang_erlang, Attrs, _CP, _Term) = ok1(Attrs).
:- pred parse_pragma_foreign_proc_attributes_term0(varset::in, term::in,
list(collected_pragma_foreign_proc_attribute)::out) is semidet.
@@ -2347,8 +2591,10 @@
parse_pragma_foreign_code(ModuleName, Flags, PredAndVarsTerm0,
PragmaImpl, VarSet0, Context, Result) :-
- parse_pred_or_func_and_args(yes(ModuleName), PredAndVarsTerm0,
- PredAndVarsTerm0, "`:- pragma c_code' declaration", PredAndArgsResult),
+ ContextPieces = [words("In"), quote(":- pragma c_code"),
+ words("declaration:")],
+ parse_pred_or_func_and_args_general(yes(ModuleName), PredAndVarsTerm0,
+ PredAndVarsTerm0, VarSet0, ContextPieces, PredAndArgsResult),
(
PredAndArgsResult = ok2(PredName, VarList0 - MaybeRetTerm),
(
@@ -2361,9 +2607,9 @@
PredOrFunc = pf_predicate,
VarList = VarList0
),
- parse_pragma_c_code_varlist(VarSet0, VarList, PragmaVars, Error),
+ parse_pragma_c_code_varlist(VarSet0, VarList, VarsResult),
(
- Error = no,
+ VarsResult = ok1(PragmaVars),
varset.coerce(VarSet0, ProgVarSet),
varset.coerce(VarSet0, InstVarSet),
Pragma = pragma_foreign_proc(Flags, PredName, PredOrFunc,
@@ -2372,55 +2618,70 @@
Item = item_pragma(ItemPragma),
Result = ok1(Item)
;
- Error = yes(ErrorMessage),
- Result = error1([ErrorMessage - PredAndVarsTerm0])
+ VarsResult = error1(Specs),
+ Result = error1(Specs)
)
;
- PredAndArgsResult = error2(Errors),
- Result = error1(Errors)
+ PredAndArgsResult = error2(Specs),
+ Result = error1(Specs)
).
% Parse the variable list in the pragma c code declaration.
% The final argument is 'no' for no error, or 'yes(ErrorMessage)'.
%
:- pred parse_pragma_c_code_varlist(varset::in, list(term)::in,
- list(pragma_var)::out, maybe(string)::out) is det.
+ maybe1(list(pragma_var))::out) is det.
-parse_pragma_c_code_varlist(_, [], [], no).
-parse_pragma_c_code_varlist(VarSet, [V|Vars], PragmaVars, Error):-
+parse_pragma_c_code_varlist(_, [], ok1([])).
+parse_pragma_c_code_varlist(VarSet, [HeadTerm | TailTerm], Result):-
(
- V = term.functor(term.atom("::"), [VarTerm, ModeTerm], _),
- VarTerm = term.variable(Var, _)
+ HeadTerm = term.functor(term.atom("::"), [VarTerm, ModeTerm], _),
+ VarTerm = term.variable(Var, VarContext)
->
( varset.search_name(VarSet, Var, VarName) ->
( convert_mode(allow_constrained_inst_var, ModeTerm, Mode0) ->
constrain_inst_vars_in_mode(Mode0, Mode),
term.coerce_var(Var, ProgVar),
- PragmaVar = pragma_var(ProgVar, VarName, Mode,
+ HeadVar = pragma_var(ProgVar, VarName, Mode,
native_if_possible),
- parse_pragma_c_code_varlist(VarSet, Vars, PragmaVars0, Error),
- PragmaVars = [PragmaVar | PragmaVars0]
+ parse_pragma_c_code_varlist(VarSet, TailTerm, TailResult),
+ (
+ TailResult = ok1(TailVars),
+ Result = ok1([HeadVar | TailVars])
;
- PragmaVars = [],
- Error = yes("unknown mode in pragma c_code")
+ TailResult = error1(_),
+ Result = TailResult
+ )
+ ;
+ Pieces = [words("Error: unknown mode in pragma c_code."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(ModeTerm),
+ [always(Pieces)])]),
+ Result = error1([Spec])
)
;
% If the variable wasn't in the varset it must be an
% underscore variable.
- PragmaVars = [], % return any old junk for that.
- Error = yes("sorry, not implemented: anonymous " ++
- "`_' variable in pragma c_code")
+ Pieces = [words("Sorry, not implemented: "),
+ words("anonymous `_' variable in pragma c_code."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(VarContext, [always(Pieces)])]),
+ Result = error1([Spec])
)
;
- PragmaVars = [], % Return any old junk in PragmaVars.
- Error = yes("arguments not in form 'Var :: mode'")
+ Pieces = [words("Error: arguments are not in the form"),
+ quote("Var :: mode"), suffix("."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(HeadTerm), [always(Pieces)])]),
+ Result = error1([Spec])
).
:- pred parse_tabling_pragma(module_name::in, string::in, eval_method::in,
- list(term)::in, term::in, prog_context::in, maybe1(item)::out) is det.
+ list(term)::in, term::in, varset::in, prog_context::in, maybe1(item)::out)
+ is det.
parse_tabling_pragma(ModuleName, PragmaName, TablingType, PragmaTerms,
- ErrorTerm, Context, Result) :-
+ ErrorTerm, VarSet, Context, Result) :-
(
(
PragmaTerms = [PredAndModesTerm0],
@@ -2430,9 +2691,10 @@
MaybeAttrs = yes(AttrListTerm0)
)
->
- ParseMsg = "`:- pragma " ++ PragmaName ++ "' declaration",
+ ContextPieces = [words("In"), quote(":- pragma " ++ PragmaName),
+ words("declaration:")],
parse_arity_or_modes(ModuleName, PredAndModesTerm0, ErrorTerm,
- ParseMsg, ArityModesResult),
+ VarSet, ContextPieces, ArityModesResult),
(
ArityModesResult = ok1(arity_or_modes(PredName, Arity,
MaybePredOrFunc, MaybeModes)),
@@ -2445,9 +2707,12 @@
Result = ok1(Item)
;
MaybeAttrs = yes(AttrsListTerm),
- convert_maybe_list(AttrsListTerm,
- parse_tabling_attribute(TablingType),
- "expected tabling attribute", MaybeAttributeList),
+ UnrecognizedPieces =
+ [words("Error: expected tabling attribute."), nl],
+ convert_maybe_list("tabling attributes", yes(VarSet),
+ AttrsListTerm,
+ parse_tabling_attribute(VarSet, TablingType),
+ UnrecognizedPieces, MaybeAttributeList),
(
MaybeAttributeList = ok1(AttributeList),
update_tabling_attributes(AttributeList,
@@ -2461,22 +2726,24 @@
Item = item_pragma(ItemPragma),
Result = ok1(Item)
;
- MaybeAttributes = error1(Errors),
- Result = error1(Errors)
+ MaybeAttributes = error1(Specs),
+ Result = error1(Specs)
)
;
- MaybeAttributeList = error1(Errors),
- Result = error1(Errors)
+ MaybeAttributeList = error1(Specs),
+ Result = error1(Specs)
)
)
;
- ArityModesResult = error1(Errors),
- Result = error1(Errors)
+ ArityModesResult = error1(Specs),
+ Result = error1(Specs)
)
;
- ErrorMsg = "wrong number of arguments in `:- pragma " ++
- PragmaName ++ "' declaration",
- Result = error1([ErrorMsg - ErrorTerm])
+ Pieces = [words("Error: wrong number of arguments in"),
+ quote(":- pragma " ++ PragmaName), words("declaration."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
+ Result = error1([Spec])
).
:- type single_tabling_attribute
@@ -2486,12 +2753,12 @@
; attr_allow_reset.
:- pred update_tabling_attributes(
- assoc_list(term, single_tabling_attribute)::in,
+ assoc_list(term.context, single_tabling_attribute)::in,
table_attributes::in, maybe1(table_attributes)::out) is det.
update_tabling_attributes([], Attributes, ok1(Attributes)).
-update_tabling_attributes([Term - SingleAttr | TermSingleAttrs], !.Attributes,
- MaybeAttributes) :-
+update_tabling_attributes([Context - SingleAttr | TermSingleAttrs],
+ !.Attributes, MaybeAttributes) :-
(
SingleAttr = attr_strictness(Strictness),
( !.Attributes ^ table_attr_strictness = all_strict ->
@@ -2499,9 +2766,12 @@
update_tabling_attributes(TermSingleAttrs, !.Attributes,
MaybeAttributes)
;
- Msg = "duplicate argument tabling methods attribute"
- ++ " in `:- pragma memo' declaration",
- MaybeAttributes = error1([Msg - Term])
+ Pieces = [words("Error: duplicate argument tabling methods"),
+ words("attribute in"), quote(":- pragma memo"),
+ words("declaration."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(Context, [always(Pieces)])]),
+ MaybeAttributes = error1([Spec])
)
;
SingleAttr = attr_size_limit(Limit),
@@ -2510,24 +2780,27 @@
update_tabling_attributes(TermSingleAttrs, !.Attributes,
MaybeAttributes)
;
- Msg = "duplicate size limits attribute"
- ++ " in `:- pragma memo' declaration",
- MaybeAttributes = error1([Msg - Term])
+ Pieces = [words("Error: duplicate size limits attribute in"),
+ quote(":- pragma memo"), words("declaration."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(Context, [always(Pieces)])]),
+ MaybeAttributes = error1([Spec])
)
;
SingleAttr = attr_statistics,
(
- !.Attributes ^ table_attr_statistics
- = table_dont_gather_statistics
+ !.Attributes ^ table_attr_statistics = table_dont_gather_statistics
->
!:Attributes = !.Attributes ^ table_attr_statistics
:= table_gather_statistics,
update_tabling_attributes(TermSingleAttrs, !.Attributes,
MaybeAttributes)
;
- Msg = "duplicate statistics attribute"
- ++ " in `:- pragma memo' declaration",
- MaybeAttributes = error1([Msg - Term])
+ Pieces = [words("Error: duplicate statistics attribute in"),
+ quote(":- pragma memo"), words("declaration."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(Context, [always(Pieces)])]),
+ MaybeAttributes = error1([Spec])
)
;
SingleAttr = attr_allow_reset,
@@ -2537,41 +2810,51 @@
update_tabling_attributes(TermSingleAttrs, !.Attributes,
MaybeAttributes)
;
- Msg = "duplicate allow_reset attribute"
- ++ " in `:- pragma memo' declaration",
- MaybeAttributes = error1([Msg - Term])
+ Pieces = [words("Error: duplicate allow_reset attribute in"),
+ quote(":- pragma memo"), words("declaration."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(Context, [always(Pieces)])]),
+ MaybeAttributes = error1([Spec])
)
).
-:- pred parse_tabling_attribute(eval_method::in, term::in,
- maybe1(pair(term, single_tabling_attribute))::out) is semidet.
+:- pred parse_tabling_attribute(varset::in, eval_method::in, term::in,
+ maybe1(pair(term.context, single_tabling_attribute))::out) is semidet.
-parse_tabling_attribute(EvalMethod, Term, MaybeTermAttribute) :-
- Term = term.functor(term.atom(Functor), Args, _),
+parse_tabling_attribute(VarSet, EvalMethod, Term, MaybeContextAttribute) :-
+ Term = term.functor(term.atom(Functor), Args, Context),
(
Functor = "fast_loose",
Args = [],
( eval_method_allows_fast_loose(EvalMethod) = yes ->
Attribute = attr_strictness(all_fast_loose),
- MaybeTermAttribute = ok1(Term - Attribute)
+ MaybeContextAttribute = ok1(Context - Attribute)
;
- Msg = "evaluation method " ++ eval_method_to_string(EvalMethod) ++
- " doesn't allow fast_loose tabling",
- MaybeTermAttribute = error1([Msg - Term])
+ Pieces = [words("Error: evaluation method"),
+ fixed(eval_method_to_string(EvalMethod)),
+ words("does not allow fast_loose tabling."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(Context, [always(Pieces)])]),
+ MaybeContextAttribute = error1([Spec])
)
;
Functor = "specified",
Args = [Arg1 | MoreArgs],
- convert_list(Arg1, parse_arg_tabling_method,
- "expected argument tabling method", MaybeMaybeArgMethods),
+ UnrecognizedPieces =
+ [words("Error: expected argument tabling method")],
+ convert_list("argument tabling methods", yes(VarSet), Arg1,
+ parse_arg_tabling_method, UnrecognizedPieces,
+ MaybeMaybeArgMethods),
(
MaybeMaybeArgMethods = ok1(MaybeArgMethods),
- ( eval_method_allows_fast_loose(EvalMethod) = yes ->
+ AllowsFastLoose = eval_method_allows_fast_loose(EvalMethod),
+ (
+ AllowsFastLoose = yes,
(
MoreArgs = [],
Attribute = attr_strictness(
specified(MaybeArgMethods, hidden_arg_value)),
- MaybeTermAttribute = ok1(Term - Attribute)
+ MaybeContextAttribute = ok1(Context - Attribute)
;
MoreArgs = [Arg2],
(
@@ -2580,55 +2863,75 @@
->
Attribute = attr_strictness(
specified(MaybeArgMethods, hidden_arg_value)),
- MaybeTermAttribute = ok1(Term - Attribute)
+ MaybeContextAttribute = ok1(Context - Attribute)
;
Arg2 = term.functor(
term.atom("hidden_arg_addr"), [], _)
->
Attribute = attr_strictness(
specified(MaybeArgMethods, hidden_arg_addr)),
- MaybeTermAttribute = ok1(Term - Attribute)
+ MaybeContextAttribute = ok1(Context - Attribute)
;
- Msg = "expected hidden argument tabling method",
- MaybeTermAttribute = error1([Msg - Arg2])
+ Arg2Str = describe_error_term(VarSet, Arg2),
+ Pieces = [words("Error: expected hidden argument"),
+ words("tabling method, not"),
+ quote(Arg2Str), suffix("."), nl],
+ Spec = error_spec(severity_error,
+ phase_term_to_parse_tree,
+ [simple_msg(get_term_context(Arg2),
+ [always(Pieces)])]),
+ MaybeContextAttribute = error1([Spec])
)
;
MoreArgs = [_, _ | _],
- Msg = "expected one or two arguments",
- MaybeTermAttribute = error1([Msg - Term])
+ Pieces = [words("Error: expected one or two arguments"),
+ words("for"), quote("specified"), suffix("."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(Context, [always(Pieces)])]),
+ MaybeContextAttribute = error1([Spec])
+ )
+ ;
+ AllowsFastLoose = no,
+ Pieces = [words("Error: evaluation method"),
+ fixed(eval_method_to_string(EvalMethod)),
+ words("does not allow specified tabling methods."), nl],
+ % XXX Should we use the context from Arg1?
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(Context, [always(Pieces)])]),
+ MaybeContextAttribute = error1([Spec])
)
;
- Msg = "evaluation method " ++
- eval_method_to_string(EvalMethod) ++
- " doesn't allow specified tabling methods",
- MaybeTermAttribute = error1([Msg - Term])
- )
- ;
- MaybeMaybeArgMethods = error1(Errors),
- MaybeTermAttribute = error1(Errors)
+ MaybeMaybeArgMethods = error1(Specs),
+ MaybeContextAttribute = error1(Specs)
)
;
Functor = "size_limit",
Args = [Arg],
Arg = term.functor(term.integer(Limit), [], _),
- ( eval_method_allows_size_limit(EvalMethod) = yes ->
+ AllowsSizeLimit = eval_method_allows_size_limit(EvalMethod),
+ (
+ AllowsSizeLimit = yes,
Attribute = attr_size_limit(Limit),
- MaybeTermAttribute = ok1(Term - Attribute)
+ MaybeContextAttribute = ok1(Context - Attribute)
;
- Msg = "evaluation method " ++ eval_method_to_string(EvalMethod) ++
- " doesn't allow size limits",
- MaybeTermAttribute = error1([Msg - Term])
+ AllowsSizeLimit = no,
+ Pieces = [words("Error: evaluation method"),
+ fixed(eval_method_to_string(EvalMethod)),
+ words("does not allow size limits."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(Context, [always(Pieces)])]),
+ MaybeContextAttribute = error1([Spec])
)
;
Functor = "statistics",
Args = [],
Attribute = attr_statistics,
- MaybeTermAttribute = ok1(Term - Attribute)
+ MaybeContextAttribute = ok1(Context - Attribute)
;
Functor = "allow_reset",
Args = [],
Attribute = attr_allow_reset,
- MaybeTermAttribute = ok1(Term - Attribute)
+ MaybeContextAttribute = ok1(Context - Attribute)
).
:- func eval_method_allows_fast_loose(eval_method) = bool.
@@ -2666,29 +2969,36 @@
maybe(list(mer_mode))
).
-:- pred parse_arity_or_modes(module_name::in, term::in, term::in,
- string::in, maybe1(arity_or_modes)::out) is det.
+:- pred parse_arity_or_modes(module_name::in, term::in, term::in, varset::in,
+ list(format_component)::in, maybe1(arity_or_modes)::out) is det.
-parse_arity_or_modes(ModuleName, PredAndModesTerm0,
- ErrorTerm, ErrorMsg, Result) :-
+parse_arity_or_modes(ModuleName, PredAndModesTerm0, ErrorTerm, VarSet,
+ ContextPieces, Result) :-
(
% Is this a simple pred/arity pragma.
PredAndModesTerm0 = term.functor(term.atom("/"),
[PredNameTerm, ArityTerm], _)
->
(
+ % The value of ContextPieces does not matter here since we succeed
+ % only if it isn't used.
+ PredNameContextPieces = [],
parse_implicitly_qualified_term(ModuleName, PredNameTerm,
- PredAndModesTerm0, "", ok2(PredName, [])),
+ PredAndModesTerm0, VarSet, PredNameContextPieces,
+ ok2(PredName, [])),
ArityTerm = term.functor(term.integer(Arity), [], _)
->
Result = ok1(arity_or_modes(PredName, Arity, no, no))
;
- Msg = "expected predname/arity for" ++ ErrorMsg,
- Result = error1([Msg - ErrorTerm])
+ Pieces = ContextPieces ++ [lower_case_next_if_not_first,
+ words("Error: expected predname/arity."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
+ Result = error1([Spec])
)
;
parse_pred_or_func_and_arg_modes(yes(ModuleName), PredAndModesTerm0,
- PredAndModesTerm0, ErrorMsg, PredAndModesResult),
+ PredAndModesTerm0, VarSet, ContextPieces, PredAndModesResult),
(
PredAndModesResult = ok2(PredName - PredOrFunc, Modes),
list.length(Modes, Arity0),
@@ -2702,21 +3012,23 @@
Result = ok1(arity_or_modes(PredName, Arity, yes(PredOrFunc),
yes(Modes)))
;
- PredAndModesResult = error2(Errors),
- Result = error1(Errors)
+ PredAndModesResult = error2(Specs),
+ Result = error1(Specs)
)
).
+% XXX why not maybe3?
:- type maybe_pred_or_func_modes ==
maybe2(pair(sym_name, pred_or_func), list(mer_mode)).
:- pred parse_pred_or_func_and_arg_modes(maybe(module_name)::in, term::in,
- term::in, string::in, maybe_pred_or_func_modes::out) is det.
+ term::in, varset::in, list(format_component)::in,
+ maybe_pred_or_func_modes::out) is det.
parse_pred_or_func_and_arg_modes(MaybeModuleName, PredAndModesTerm,
- ErrorTerm, Msg, Result) :-
- parse_pred_or_func_and_args(MaybeModuleName, PredAndModesTerm,
- ErrorTerm, Msg, PredAndArgsResult),
+ ErrorTerm, VarSet, ContextPieces, Result) :-
+ parse_pred_or_func_and_args_general(MaybeModuleName, PredAndModesTerm,
+ ErrorTerm, VarSet, ContextPieces, PredAndArgsResult),
(
PredAndArgsResult = ok2(PredName, ArgModeTerms - MaybeRetModeTerm),
(
@@ -2729,24 +3041,31 @@
convert_mode(allow_constrained_inst_var, RetModeTerm,
RetMode)
->
- list.append(ArgModes0, [RetMode], ArgModes1),
+ ArgModes1 = ArgModes0 ++ [RetMode],
list.map(constrain_inst_vars_in_mode, ArgModes1, ArgModes),
Result = ok2(PredName - pf_function, ArgModes)
;
- ErrorMsg = "error in return mode in " ++ Msg,
- Result = error2([ErrorMsg - ErrorTerm])
+ Pieces = [words("Error in return mode in")] ++
+ ContextPieces ++ [suffix("."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(ErrorTerm),
+ [always(Pieces)])]),
+ Result = error2([Spec])
)
;
MaybeRetModeTerm = no,
Result = ok2(PredName - pf_predicate, ArgModes0)
)
;
- ErrorMsg = "error in argument modes in " ++ Msg,
- Result = error2([ErrorMsg - ErrorTerm])
+ Pieces = [words("Error in arguments modes in")] ++
+ ContextPieces ++ [suffix("."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
+ Result = error2([Spec])
)
;
- PredAndArgsResult = error2(Errors),
- Result = error2(Errors)
+ PredAndArgsResult = error2(Specs),
+ Result = error2(Specs)
).
:- pred convert_bool(term::in, bool::out) is semidet.
@@ -2757,49 +3076,81 @@
; Name = "no", Bool = no
).
-:- pred convert_bool_list(term::in, list(bool)::out) is semidet.
+% XXX Why does convert_bool_list insist on ok when convert_int_list doesn't?
+:- pred convert_bool_list(varset::in, term::in, list(bool)::out) is semidet.
-convert_bool_list(ListTerm, Bools) :-
- convert_list(ListTerm, convert_bool, "expected boolean", ok1(Bools)).
+convert_bool_list(VarSet, ListTerm, Bools) :-
+ convert_list("booleans", yes(VarSet), ListTerm, convert_bool,
+ [words("Error: expected boolean")], ok1(Bools)).
:- pred convert_int(term::in, int::out) is semidet.
convert_int(Term, Int) :-
Term = term.functor(term.integer(Int), [], _).
-:- pred convert_int_list(term::in, maybe1(list(int))::out) is det.
+:- pred convert_int_list(varset::in, term::in, maybe1(list(int))::out) is det.
-convert_int_list(ListTerm, Result) :-
- convert_list(ListTerm, convert_int, "expected integer", Result).
+convert_int_list(VarSet, ListTerm, Result) :-
+ convert_list("integers", yes(VarSet), ListTerm, convert_int,
+ [words("Error: expected integer")], Result).
- % convert_list(T, P, M) will convert a term T into a list of
- % type X where P is a predicate that converts each element of
- % the list into the correct type. M will hold the list if the
- % conversion succeded for each element of M, otherwise it will
- % hold the error.
+ % convert_list(What, MaybeVarSet, Term, Pred, UnrecognizedPieces, Result):
%
-:- pred convert_list(term::in, pred(term, T)::(pred(in, out) is semidet),
- string::in, maybe1(list(T))::out) is det.
+ % Convert Term into a list of elements where Pred converts each element
+ % of the list into the correct type. Result will hold the list if the
+ % conversion succeded for each element of M, otherwise it will hold
+ % the error. What should be a plural noun or noun phrase describing
+ % the expected list. If MaybeVarSet is yes, it should specify the varset
+ % for use in describing any unrecognized list elements.
+ %
+:- pred convert_list(string::in, maybe(varset)::in, term::in,
+ pred(term, T)::(pred(in, out) is semidet),
+ list(format_component)::in, maybe1(list(T))::out) is det.
-convert_list(term.variable(V, C), _, UnrecognizedMsg,
- error1([UnrecognizedMsg - term.variable(V, C)])).
-convert_list(term.functor(Functor, Args, Context), Pred, UnrecognizedMsg,
- Result) :-
+convert_list(What, MaybeVarSet, Term, Pred, UnrecognizedPieces, Result) :-
+ (
+ Term = term.variable(_, Context),
+ (
+ MaybeVarSet = yes(VarSet),
+ TermStr = describe_error_term(VarSet, Term),
+ Pieces = UnrecognizedPieces ++ [suffix(","), words("not"),
+ quote(TermStr), suffix("."), nl]
+ ;
+ MaybeVarSet = no,
+ Pieces = UnrecognizedPieces ++ [suffix("."), nl]
+ ),
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(Context, [always(Pieces)])]),
+ Result = error1([Spec])
+ ;
+ Term = term.functor(Functor, Args, Context),
(
Functor = term.atom("[|]"),
- Args = [Term, RestTerm]
+ Args = [FirstTerm, RestTerm]
->
- ( Pred(Term, Element) ->
- convert_list(RestTerm, Pred, UnrecognizedMsg, RestResult),
+ ( Pred(FirstTerm, FirstElement) ->
+ convert_list(What, MaybeVarSet, RestTerm, Pred,
+ UnrecognizedPieces, RestResult),
(
- RestResult = ok1(List0),
- Result = ok1([Element | List0])
+ RestResult = ok1(LaterElements),
+ Result = ok1([FirstElement | LaterElements])
;
RestResult = error1(_),
Result = RestResult
)
;
- Result = error1([UnrecognizedMsg - Term])
+ (
+ MaybeVarSet = yes(VarSet),
+ FirstTermStr = describe_error_term(VarSet, FirstTerm),
+ Pieces = UnrecognizedPieces ++ [suffix(","), words("not"),
+ quote(FirstTermStr), suffix("."), nl]
+ ;
+ MaybeVarSet = no,
+ Pieces = UnrecognizedPieces ++ [suffix("."), nl]
+ ),
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(Term), [always(Pieces)])]),
+ Result = error1([Spec])
)
;
Functor = term.atom("[]"),
@@ -2807,46 +3158,80 @@
->
Result = ok1([])
;
- Result = error1(["error in list" -
- term.functor(Functor, Args, Context)])
+ (
+ MaybeVarSet = yes(VarSet),
+ TermStr = describe_error_term(VarSet, Term),
+ Pieces = [words("Error: expected list of"), words(What),
+ suffix(","), words("not"), quote(TermStr), suffix("."), nl]
+ ;
+ MaybeVarSet = no,
+ Pieces = [words("Error: expected list of"), words(What),
+ suffix("."), nl]
+ ),
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(Context, [always(Pieces)])]),
+ Result = error1([Spec])
+ )
).
- % convert_list(T, P, M) will convert a term T into a list of
- % type X where P is a predicate that converts each element of
- % the list into the correct type. M will hold the list if the
- % conversion succeded for each element of M, otherwise it will
- % hold the error.
+ % This predicate does the same job as convert_list, but with a different
+ % type of supplied Pred, which returns a maybe(item_type), not item_type.
%
-:- pred convert_maybe_list(term::in,
+:- pred convert_maybe_list(string::in, maybe(varset)::in, term::in,
pred(term, maybe1(T))::(pred(in, out) is semidet),
- string::in, maybe1(list(T))::out) is det.
+ list(format_component)::in, maybe1(list(T))::out) is det.
-convert_maybe_list(term.variable(V, C), _, UnrecognizedMsg,
- error1([UnrecognizedMsg - term.variable(V, C)])).
-convert_maybe_list(term.functor(Functor, Args, Context), Pred, UnrecognizedMsg,
+convert_maybe_list(What, MaybeVarSet, Term, Pred, UnrecognizedPieces,
Result) :-
(
+ Term = term.variable(_, Context),
+ (
+ MaybeVarSet = yes(VarSet),
+ TermStr = describe_error_term(VarSet, Term),
+ Pieces = UnrecognizedPieces ++ [suffix(","), words("not"),
+ quote(TermStr), suffix("."), nl]
+ ;
+ MaybeVarSet = no,
+ Pieces = UnrecognizedPieces ++ [suffix("."), nl]
+ ),
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(Context, [always(Pieces)])]),
+ Result = error1([Spec])
+ ;
+ Term = term.functor(Functor, Args, Context),
+ (
Functor = term.atom("[|]"),
- Args = [Term, RestTerm]
+ Args = [FirstTerm, RestTerm]
->
- ( Pred(Term, ElementResult) ->
+ ( Pred(FirstTerm, ElementResult) ->
(
- ElementResult = ok1(Element),
- convert_maybe_list(RestTerm, Pred, UnrecognizedMsg,
- RestResult),
+ ElementResult = ok1(FirstElement),
+ convert_maybe_list(What, MaybeVarSet, RestTerm, Pred,
+ UnrecognizedPieces, RestResult),
(
- RestResult = ok1(List0),
- Result = ok1([Element | List0])
+ RestResult = ok1(LaterElements),
+ Result = ok1([FirstElement | LaterElements])
;
RestResult = error1(_),
Result = RestResult
)
;
- ElementResult = error1(Errors),
- Result = error1(Errors)
+ ElementResult = error1(Specs),
+ Result = error1(Specs)
)
;
- Result = error1([UnrecognizedMsg - Term])
+ (
+ MaybeVarSet = yes(VarSet),
+ FirstTermStr = describe_error_term(VarSet, FirstTerm),
+ Pieces = UnrecognizedPieces ++ [suffix(","), words("not"),
+ quote(FirstTermStr), suffix("."), nl]
+ ;
+ MaybeVarSet = no,
+ Pieces = UnrecognizedPieces ++ [suffix("."), nl]
+ ),
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(Term), [always(Pieces)])]),
+ Result = error1([Spec])
)
;
Functor = term.atom("[]"),
@@ -2854,8 +3239,20 @@
->
Result = ok1([])
;
- Result = error1(["error in list" -
- term.functor(Functor, Args, Context)])
+ (
+ MaybeVarSet = yes(VarSet),
+ TermStr = describe_error_term(VarSet, Term),
+ Pieces = [words("Error: expected list of"), words(What),
+ suffix(","), words("not"), quote(TermStr), suffix("."), nl]
+ ;
+ MaybeVarSet = no,
+ Pieces = [words("Error: expected list of"), words(What),
+ suffix("."), nl]
+ ),
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(Context, [always(Pieces)])]),
+ Result = error1([Spec])
+ )
).
:- pred convert_type_spec_pair(term::in, pair(tvar, mer_type)::out) is semidet.
@@ -2864,7 +3261,7 @@
Term = term.functor(term.atom("="), [TypeVarTerm, SpecTypeTerm0], _),
TypeVarTerm = term.variable(TypeVar0, _),
term.coerce_var(TypeVar0, TypeVar),
- parse_type(SpecTypeTerm0, ok1(SpecType)),
+ maybe_parse_type(SpecTypeTerm0, SpecType),
TypeSpec = TypeVar - SpecType.
%-----------------------------------------------------------------------------%
@@ -2882,8 +3279,9 @@
;
ArgSizeTerm = term.functor(term.atom("constraints"),
[Constraints0], _),
- convert_list(Constraints0, parse_arg_size_constraint,
- "expected constraint", ConstraintsResult),
+ UnrecognizedPieces = [words("Error: expected constraint."), nl],
+ convert_list("arg size constraints", no, Constraints0,
+ parse_arg_size_constraint, UnrecognizedPieces, ConstraintsResult),
ConstraintsResult = ok1(Constraints),
Result = ok1(yes(Constraints))
).
@@ -2893,16 +3291,17 @@
parse_arg_size_constraint(Term, Constr) :-
(
Term = term.functor(term.atom("le"), [Terms, ConstantTerm], _),
- convert_list(Terms, parse_lp_term, "expected linear term",
- TermsResult),
+ UnrecognizedPieces = [words("Error: expected linear term."), nl],
+ convert_list("linear terms", no, Terms, parse_lp_term,
+ UnrecognizedPieces, TermsResult),
TermsResult = ok1(LPTerms),
parse_rational(ConstantTerm, Constant),
Constr = le(LPTerms, Constant)
-
;
Term = term.functor(term.atom("eq"), [Terms, ConstantTerm], _),
- convert_list(Terms, parse_lp_term, "expected linear term",
- TermsResult),
+ UnrecognizedPieces = [words("Error: expected linear term."), nl],
+ convert_list("linear terms", no, Terms, parse_lp_term,
+ UnrecognizedPieces, TermsResult),
TermsResult = ok1(LPTerms),
parse_rational(ConstantTerm, Constant),
Constr = eq(LPTerms, Constant)
@@ -2948,6 +3347,20 @@
%-----------------------------------------------------------------------------%
+:- pred parse_predicate_or_function(term::in, pred_or_func::out) is semidet.
+
+parse_predicate_or_function(PredOrFuncTerm, PredOrFunc) :-
+ PredOrFuncTerm = term.functor(term.atom(Functor), [], _),
+ (
+ Functor = "predicate",
+ PredOrFunc = pf_predicate
+ ;
+ Functor = "function",
+ PredOrFunc = pf_function
+ ).
+
+%-----------------------------------------------------------------------------%
+
:- func this_file = string.
this_file = "prog_io_pragma.m".
Index: compiler/prog_io_typeclass.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_io_typeclass.m,v
retrieving revision 1.61
diff -u -b -r1.61 prog_io_typeclass.m
--- compiler/prog_io_typeclass.m 15 Feb 2008 02:26:58 -0000 1.61
+++ compiler/prog_io_typeclass.m 15 Jul 2008 11:11:05 -0000
@@ -38,14 +38,16 @@
:- pred parse_instance(module_name::in, varset::in, list(term)::in,
prog_context::in, maybe1(item_instance_info)::out) is semidet.
- % Parse a list of class constraints.
+ % Parse constraints on a pred or func declaration, or on an existentially
+ % quantified type definition. Currently all such constraints must be
+ % simple.
%
-:- pred parse_class_constraints(module_name::in, term::in,
+:- pred parse_class_constraints(module_name::in, varset::in, term::in,
maybe1(list(prog_constraint))::out) is det.
% Parse a list of class and inst constraints.
%
-:- pred parse_class_and_inst_constraints(module_name::in, term::in,
+:- pred parse_class_and_inst_constraints(module_name::in, varset::in, term::in,
maybe_class_and_inst_constraints::out) is det.
:- type maybe_class_and_inst_constraints ==
@@ -57,11 +59,15 @@
:- implementation.
:- import_module libs.compiler_util.
+:- import_module parse_tree.error_util.
+:- import_module parse_tree.mercury_to_mercury.
:- import_module parse_tree.prog_io.
-:- import_module parse_tree.prog_util.
+:- import_module parse_tree.prog_out.
:- import_module parse_tree.prog_type.
+:- import_module parse_tree.prog_util.
:- import_module assoc_list.
+:- import_module bool.
:- import_module map.
:- import_module maybe.
:- import_module pair.
@@ -94,8 +100,8 @@
parse_class_head(ModuleName, Name, VarSet, Context,
MaybeParsedNameAndVars),
(
- MaybeParsedNameAndVars = error1(Errors),
- Result = error1(Errors)
+ MaybeParsedNameAndVars = error1(Specs),
+ Result = error1(Specs)
;
MaybeParsedNameAndVars = ok1(ParsedNameAndVars),
Result = ok1((ParsedNameAndVars
@@ -103,8 +109,8 @@
^ tc_varset := TVarSet)
)
;
- MaybeParsedMethods = error1(Errors),
- Result = error1(Errors)
+ MaybeParsedMethods = error1(Specs),
+ Result = error1(Specs)
).
:- pred parse_class_head(module_name::in, term::in, varset::in,
@@ -122,10 +128,10 @@
:- pred parse_constrained_class(module_name::in, term::in, term::in,
varset::in, prog_context::in, maybe1(item_typeclass_info)::out) is det.
-parse_constrained_class(ModuleName, Decl, Constraints, VarSet, Context,
+parse_constrained_class(ModuleName, Decl, ConstraintsTerm, VarSet, Context,
Result) :-
varset.coerce(VarSet, TVarSet),
- parse_superclass_constraints(ModuleName, Constraints,
+ parse_superclass_constraints(ModuleName, VarSet, ConstraintsTerm,
MaybeParsedConstraints),
(
MaybeParsedConstraints = ok2(ConstraintList, FunDeps),
@@ -134,47 +140,120 @@
Result0 = error1(_),
Result = Result0
;
- Result0 = ok1(ItemTypeClass),
- (
+ Result0 = ok1(ItemTypeClass0),
% Check for type variables in the constraints which do not
% occur in the type class parameters.
- prog_type.constraint_list_get_tvars(ConstraintList,
- ConstrainedVars),
- list.member(Var, ConstrainedVars),
- \+ list.member(Var, ItemTypeClass ^ tc_class_params)
- ->
- Msg = "type variable in superclass constraint " ++
- "is not a parameter of this type class",
- Result = error1([Msg - Constraints])
+
+ constraint_list_get_tvars(ConstraintList, ConstraintVars),
+ list.sort_and_remove_dups(ConstraintVars, SortedConstraintVars),
+ FunDepVars = tvars_in_fundeps(FunDeps),
+ list.sort_and_remove_dups(FunDepVars, SortedFunDepVars),
+
+ Params = ItemTypeClass0 ^ tc_class_params,
+ list.filter(is_in_list(Params), SortedConstraintVars,
+ _ConstraintInParams, ConstraintNotInParams),
+ list.filter(is_in_list(Params), SortedFunDepVars,
+ _FunDepInParams, FunDepNotInParams),
+ (
+ ConstraintNotInParams = [_ | _],
+ ( list.length(ConstraintList) = 1 ->
+ ConstraintErrorContext =
+ [words("in the superclass constraint")]
;
- % Check for type variables in the fundeps which do not
- % occur in the type class parameters.
- list.member(FunDep, FunDeps),
- FunDep = fundep(Domain, Range),
- ( list.member(Var, Domain)
- ; list.member(Var, Range)
+ ConstraintErrorContext =
+ [words("in superclass constraints")]
+ )
+ ;
+ ConstraintNotInParams = [],
+ ConstraintErrorContext = []
),
- \+ list.member(Var, ItemTypeClass ^ tc_class_params)
- ->
- Msg = "type variable in functional dependency " ++
- "is not a parameter of this type class",
- Result = error1([Msg - Constraints])
+ (
+ FunDepNotInParams = [_ | _],
+ ( list.length(FunDeps) = 1 ->
+ FunDepErrorContext =
+ [words("in the functional dependency")]
+ ;
+ FunDepErrorContext =
+ [words("in functional dependencies")]
+ )
;
- Result = ok1((ItemTypeClass
+ FunDepNotInParams = [],
+ FunDepErrorContext = []
+ ),
+ NotInParams = ConstraintNotInParams ++ FunDepNotInParams,
+ (
+ NotInParams = [],
+ ItemTypeClass = ((ItemTypeClass0
^ tc_constraints := ConstraintList)
- ^ tc_fundeps := FunDeps)
+ ^ tc_fundeps := FunDeps),
+ Result = ok1(ItemTypeClass)
+ ;
+ NotInParams = [_ | _],
+ ClassTVarSet = ItemTypeClass0 ^ tc_varset,
+ ConstraintNotInParamsStrs =
+ list.map(mercury_var_to_string(ClassTVarSet, no),
+ ConstraintNotInParams),
+ FunDepNotInParamsStrs =
+ list.map(mercury_var_to_string(ClassTVarSet, no),
+ FunDepNotInParams),
+ ConstraintNotInParamsPieces =
+ list_to_pieces(ConstraintNotInParamsStrs),
+ FunDepNotInParamsPieces =
+ list_to_pieces(FunDepNotInParamsStrs),
+ ( list.length(NotInParams) = 1 ->
+ Prefix = [words("Error: type variable")],
+ Suffix = [words("is not a parameter of this type class.")]
+ ;
+ Prefix = [words("Error: type variables")],
+ Suffix = [words("are not parameters of this type class.")]
+ ),
+ (
+ ConstraintNotInParams = [],
+ FunDepNotInParams = [],
+ unexpected(this_file,
+ "parse_constrained_class: no NotInParams")
+ ;
+ ConstraintNotInParams = [],
+ FunDepNotInParams = [_ | _],
+ Middle =
+ FunDepNotInParamsPieces ++ FunDepErrorContext
+ ;
+ ConstraintNotInParams = [_ | _],
+ FunDepNotInParams = [],
+ Middle =
+ ConstraintNotInParamsPieces ++ ConstraintErrorContext
+ ;
+ ConstraintNotInParams = [_ | _],
+ FunDepNotInParams = [_ | _],
+ Middle =
+ ConstraintNotInParamsPieces ++ ConstraintErrorContext
+ ++ [words("and")] ++
+ FunDepNotInParamsPieces ++ FunDepErrorContext
+ ),
+ Pieces = Prefix ++ Middle ++ Suffix ++ [nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(Context, [always(Pieces)])]),
+ Result = error1([Spec])
)
)
;
- MaybeParsedConstraints = error2(Errors),
- Result = error1(Errors)
+ MaybeParsedConstraints = error2(Specs),
+ Result = error1(Specs)
).
-:- pred parse_superclass_constraints(module_name::in, term::in,
+:- func tvars_in_fundeps(list(prog_fundep)) = list(tvar).
+
+tvars_in_fundeps(FunDeps) = list.condense(list.map(tvars_in_fundep, FunDeps)).
+
+:- func tvars_in_fundep(prog_fundep) = list(tvar).
+
+tvars_in_fundep(fundep(Domain, Range)) = Domain ++ Range.
+
+:- pred parse_superclass_constraints(module_name::in, varset::in, term::in,
maybe2(list(prog_constraint), list(prog_fundep))::out) is det.
-parse_superclass_constraints(_ModuleName, ConstraintsTerm, Result) :-
- parse_arbitrary_constraints(ConstraintsTerm, Result0),
+parse_superclass_constraints(_ModuleName, VarSet, ConstraintsTerm, Result) :-
+ parse_arbitrary_constraints(VarSet, ConstraintsTerm, Result0),
(
Result0 = ok1(ArbitraryConstraints),
(
@@ -183,13 +262,17 @@
->
Result = ok2(Constraints, FunDeps)
;
- Msg = "constraints on class declarations" ++
- " may only constrain type variables and ground types",
- Result = error2([Msg - ConstraintsTerm])
+ Pieces = [words("Error: constraints on class declarations"),
+ words("may only constrain type variables and ground types."),
+ nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(ConstraintsTerm),
+ [always(Pieces)])]),
+ Result = error2([Spec])
)
;
- Result0 = error1(Errors),
- Result = error2(Errors)
+ Result0 = error1(Specs),
+ Result = error2(Specs)
).
:- pred collect_simple_and_fundep_constraints(list(arbitrary_constraint)::in,
@@ -213,9 +296,11 @@
:- pred parse_unconstrained_class(module_name::in, term::in, tvarset::in,
prog_context::in, maybe1(item_typeclass_info)::out) is det.
-parse_unconstrained_class(ModuleName, Name, TVarSet, Context, Result) :-
- parse_implicitly_qualified_term(ModuleName,
- Name, Name, "typeclass declaration", MaybeClassName),
+parse_unconstrained_class(ModuleName, NameTerm, TVarSet, Context, Result) :-
+ ContextPieces = [words("In typeclass declaration:")],
+ varset.coerce(TVarSet, VarSet),
+ parse_implicitly_qualified_term(ModuleName, NameTerm, NameTerm,
+ VarSet, ContextPieces, MaybeClassName),
(
MaybeClassName = ok2(ClassName, TermVars0),
list.map(term.coerce, TermVars0, TermVars),
@@ -225,25 +310,29 @@
list.length(SortedTermVars) = list.length(TermVars) : int
->
% XXX Would this be a better context?
- % Context = get_term_context(Name),
+ % Context = get_term_context(NameTerm),
Result = ok1(item_typeclass_info([], [], ClassName, Vars,
class_interface_abstract, TVarSet, Context))
;
- Msg = "expected distinct variables as class parameters",
- Result = error1([Msg - Name])
+ Pieces = [words("Error: expected distinct variables"),
+ words("as class parameters."), nl],
+ % XXX Would Context be better than get_term_context(NameTerm)?
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(NameTerm), [always(Pieces)])]),
+ Result = error1([Spec])
)
;
- MaybeClassName = error2(Errors),
- Result = error1(Errors)
+ MaybeClassName = error2(Specs),
+ Result = error1(Specs)
).
:- pred parse_class_methods(module_name::in, term::in, varset::in,
maybe1(class_methods)::out) is det.
-parse_class_methods(ModuleName, Methods, VarSet, Result) :-
+parse_class_methods(ModuleName, MethodsTerm, VarSet, Result) :-
(
% Convert the list of terms into a list of maybe1(class_method)s.
- list_term_to_term_list(Methods, MethodList)
+ list_term_to_term_list(MethodsTerm, MethodList)
->
list.map(
(pred(MethodTerm::in, Method::out) is det :-
@@ -254,13 +343,16 @@
), MethodList, Interface),
find_errors(Interface, Result)
;
- Result = error1(["expected list of class methods" - Methods])
+ Pieces = [words("Error: expected list of class methods."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(MethodsTerm), [always(Pieces)])]),
+ Result = error1([Spec])
).
:- pred item_to_class_method(maybe1(item)::in, term::in,
maybe1(class_method)::out) is det.
-item_to_class_method(error1(Errors), _, error1(Errors)).
+item_to_class_method(error1(Specs), _, error1(Specs)).
item_to_class_method(ok1(Item), Term, Result) :-
( Item = item_pred_decl(ItemPredDecl) ->
ItemPredDecl = item_pred_decl_info(_Origin, A, B, C, D, E, F, G, H, I,
@@ -273,9 +365,11 @@
ClassMethod = method_pred_or_func_mode(A, B, C, D, E, F, G, Context),
Result = ok1(ClassMethod)
;
- Msg = "Only pred, func and mode declarations " ++
- "allowed in class interface",
- Result = error1([Msg - Term])
+ Pieces = [words("Error: only pred, func and mode declarations"),
+ words("are allowed in class interfaces."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(Term), [always(Pieces)])]),
+ Result = error1([Spec])
).
% From a list of maybe1s, search through until you find an error.
@@ -285,27 +379,27 @@
:- pred find_errors(list(maybe1(T))::in, maybe1(list(T))::out) is det.
find_errors(Xs, Result) :-
- find_errors_2(Xs, [], Methods, [], Errors),
+ find_errors_2(Xs, [], Methods, [], Specs),
(
- Errors = [],
+ Specs = [],
Result = ok1(Methods)
;
- Errors = [_ | _],
- Result = error1(Errors)
+ Specs = [_ | _],
+ Result = error1(Specs)
).
:- pred find_errors_2(list(maybe1(T))::in, list(T)::in, list(T)::out,
- assoc_list(string, term)::in, assoc_list(string, term)::out) is det.
+ list(error_spec)::in, list(error_spec)::out) is det.
-find_errors_2([], !Methods, !Errors).
-find_errors_2([X | Xs], !Methods, !Errors) :-
- find_errors_2(Xs, !Methods, !Errors),
+find_errors_2([], !Methods, !Specs).
+find_errors_2([X | Xs], !Methods, !Specs) :-
+ find_errors_2(Xs, !Methods, !Specs),
(
X = ok1(CurMethod),
!:Methods = [CurMethod | !.Methods]
;
- X = error1(CurErrors),
- !:Errors = CurErrors ++ !.Errors
+ X = error1(CurSpecs),
+ !:Specs = CurSpecs ++ !.Specs
).
%-----------------------------------------------------------------------------%
@@ -313,23 +407,19 @@
% Predicates for parsing various kinds of constraints.
%
- % Parse constraints on a pred or func declaration, or on an existentially
- % quantified type definition. Currently all such constraints must be
- % simple.
- %
-parse_class_constraints(ModuleName, ConstraintsTerm, Result) :-
- ErrorMessage = "sorry, not implemented:" ++
- " constraints may only constrain type variables" ++
- " and ground types",
- parse_simple_class_constraints(ModuleName, ConstraintsTerm,
- ErrorMessage, Result).
+parse_class_constraints(ModuleName, VarSet, ConstraintsTerm, Result) :-
+ Pieces = [words("Sorry, not implemented:"),
+ words("constraints may only constrain type variables"),
+ words("and ground types"), nl],
+ parse_simple_class_constraints(ModuleName, VarSet, ConstraintsTerm, Pieces,
+ Result).
-:- pred parse_simple_class_constraints(module_name::in, term::in, string::in,
- maybe1(list(prog_constraint))::out) is det.
+:- pred parse_simple_class_constraints(module_name::in, varset::in, term::in,
+ list(format_component)::in, maybe1(list(prog_constraint))::out) is det.
-parse_simple_class_constraints(_ModuleName, ConstraintsTerm, ErrorMessage,
+parse_simple_class_constraints(_ModuleName, VarSet, ConstraintsTerm, Pieces,
Result) :-
- parse_arbitrary_constraints(ConstraintsTerm, Result0),
+ parse_arbitrary_constraints(VarSet, ConstraintsTerm, Result0),
(
Result0 = ok1(ArbitraryConstraints),
(
@@ -338,11 +428,14 @@
->
Result = ok1(Constraints)
;
- Result = error1([ErrorMessage - ConstraintsTerm])
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(ConstraintsTerm),
+ [always(Pieces)])]),
+ Result = error1([Spec])
)
;
- Result0 = error1(Errors),
- Result = error1(Errors)
+ Result0 = error1(Specs),
+ Result = error1(Specs)
).
:- pred get_simple_constraint(arbitrary_constraint::in, prog_constraint::out)
@@ -350,8 +443,9 @@
get_simple_constraint(simple(Constraint), Constraint).
-parse_class_and_inst_constraints(_ModuleName, ConstraintsTerm, Result) :-
- parse_arbitrary_constraints(ConstraintsTerm, Result0),
+parse_class_and_inst_constraints(_ModuleName, VarSet, ConstraintsTerm,
+ Result) :-
+ parse_arbitrary_constraints(VarSet, ConstraintsTerm, Result0),
(
Result0 = ok1(ArbitraryConstraints),
(
@@ -360,13 +454,16 @@
->
Result = ok2(ProgConstraints, InstVarSub)
;
- ErrorMessage = "functional dependencies are only allowed " ++
- "in typeclass declarations",
- Result = error2([ErrorMessage - ConstraintsTerm])
+ Pieces = [words("Error: functional dependencies are only allowed"),
+ words("in typeclass declarations."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(ConstraintsTerm),
+ [always(Pieces)])]),
+ Result = error2([Spec])
)
;
- Result0 = error1(Errors),
- Result = error2(Errors)
+ Result0 = error1(Specs),
+ Result = error2(Specs)
).
:- pred collect_class_and_inst_constraints(list(arbitrary_constraint)::in,
@@ -410,36 +507,36 @@
:- type arbitrary_constraints == list(arbitrary_constraint).
-:- pred parse_arbitrary_constraints(term::in,
+:- pred parse_arbitrary_constraints(varset::in, term::in,
maybe1(arbitrary_constraints)::out) is det.
-parse_arbitrary_constraints(ConstraintsTerm, Result) :-
+parse_arbitrary_constraints(VarSet, ConstraintsTerm, Result) :-
conjunction_to_list(ConstraintsTerm, ConstraintList),
- parse_arbitrary_constraint_list(ConstraintList, Result).
+ parse_arbitrary_constraint_list(VarSet, ConstraintList, Result).
-:- pred parse_arbitrary_constraint_list(list(term)::in,
+:- pred parse_arbitrary_constraint_list(varset::in, list(term)::in,
maybe1(arbitrary_constraints)::out) is det.
-parse_arbitrary_constraint_list([], ok1([])).
-parse_arbitrary_constraint_list([Term | Terms], Result) :-
- parse_arbitrary_constraint(Term, Result0),
- parse_arbitrary_constraint_list(Terms, Result1),
+parse_arbitrary_constraint_list(_, [], ok1([])).
+parse_arbitrary_constraint_list(VarSet, [Term | Terms], Result) :-
+ parse_arbitrary_constraint(VarSet, Term, Result0),
+ parse_arbitrary_constraint_list(VarSet, Terms, Result1),
Result = combine_parse_results(Result0, Result1).
:- func combine_parse_results(maybe1(arbitrary_constraint),
maybe1(arbitrary_constraints)) = maybe1(arbitrary_constraints).
-combine_parse_results(error1(Errors1), error1(Errors2)) =
- error1(Errors1 ++ Errors2).
-combine_parse_results(error1(Errors), ok1(_)) = error1(Errors).
-combine_parse_results(ok1(_), error1(Errors)) = error1(Errors).
+combine_parse_results(error1(HeadSpecs), error1(TailSpecs)) =
+ error1(HeadSpecs ++ TailSpecs).
+combine_parse_results(error1(Specs), ok1(_)) = error1(Specs).
+combine_parse_results(ok1(_), error1(Specs)) = error1(Specs).
combine_parse_results(ok1(Constraint), ok1(Constraints)) =
ok1([Constraint | Constraints]).
-:- pred parse_arbitrary_constraint(term::in, maybe1(arbitrary_constraint)::out)
- is det.
+:- pred parse_arbitrary_constraint(varset::in, term::in,
+ maybe1(arbitrary_constraint)::out) is det.
-parse_arbitrary_constraint(ConstraintTerm, Result) :-
+parse_arbitrary_constraint(VarSet, ConstraintTerm, Result) :-
(
parse_inst_constraint(ConstraintTerm, InstVar, Inst)
->
@@ -449,10 +546,11 @@
->
Result = Result0
;
- parse_qualified_term(ConstraintTerm, ConstraintTerm,
- "class constraint", ok2(ClassName, Args0))
+ sym_name_and_args(ConstraintTerm, ClassName, Args0)
->
- parse_types(Args0, ArgsResult),
+ % XXX ArgsResultContextPieces = [words("In typeclass constraint:")]
+ ArgsResultContextPieces = [],
+ parse_types(Args0, VarSet, ArgsResultContextPieces, ArgsResult),
(
ArgsResult = ok1(Args),
Constraint = constraint(ClassName, Args),
@@ -462,12 +560,15 @@
Result = ok1(simple(Constraint))
)
;
- ArgsResult = error1(Errors),
- Result = error1(Errors)
+ ArgsResult = error1(Specs),
+ Result = error1(Specs)
)
;
- Msg = "expected atom as class name or inst constraint",
- Result = error1([Msg - ConstraintTerm])
+ Pieces = [words("Error: expected atom"),
+ words("as class name or inst constraint."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(ConstraintTerm), [always(Pieces)])]),
+ Result = error1([Spec])
).
:- pred parse_inst_constraint(term::in, inst_var::out, mer_inst::out)
@@ -489,9 +590,12 @@
->
Result = ok1(fundep(fundep(Domain, Range)))
;
- ErrorMessage = "domain and range of functional dependency " ++
- "must be comma-separated lists of variables",
- Result = error1([ErrorMessage - Term])
+ Pieces = [words("Error: the domain and range"),
+ words("of a functional dependency"),
+ words("must be comma-separated lists of variables."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(Term), [always(Pieces)])]),
+ Result = error1([Spec])
).
:- pred parse_fundep_2(term::in, list(tvar)::out) is semidet.
@@ -540,7 +644,8 @@
parse_derived_instance(ModuleName, Decl, Constraints, TVarSet, Context,
Result) :-
- parse_instance_constraints(ModuleName, Constraints,
+ varset.coerce(TVarSet, VarSet),
+ parse_instance_constraints(ModuleName, VarSet, Constraints,
MaybeParsedConstraints),
(
MaybeParsedConstraints = ok1(ConstraintList),
@@ -551,53 +656,55 @@
;
Result0 = ok1(ItemInstance0),
ItemInstance0 = item_instance_info(_ConstraintList0, Name, Types,
- Body, VarSet, ModName, InstanceContext),
+ Body, InstanceVarSet, ModName, InstanceContext),
% XXX Should we keep InstanceContext, or should we replace it
% with Context? Or will they always be the same?
ItemInstance = item_instance_info(ConstraintList, Name, Types,
- Body, VarSet, ModName, InstanceContext),
+ Body, InstanceVarSet, ModName, InstanceContext),
Result = ok1(ItemInstance)
)
;
- MaybeParsedConstraints = error1(Errors),
- Result = error1(Errors)
+ MaybeParsedConstraints = error1(Specs),
+ Result = error1(Specs)
).
-:- pred parse_instance_constraints(module_name::in, term::in,
+:- pred parse_instance_constraints(module_name::in, varset::in, term::in,
maybe1(list(prog_constraint))::out) is det.
-parse_instance_constraints(ModuleName, Constraints, Result) :-
- parse_simple_class_constraints(ModuleName, Constraints,
- "constraints on instance declarations may only constrain " ++
- "type variables and ground types", Result).
+parse_instance_constraints(ModuleName, VarSet, ConstraintsTerm, Result) :-
+ Pieces = [words("Error: constraints on instance declarations"),
+ words("may only constrain type variables and ground types."), nl],
+ parse_simple_class_constraints(ModuleName, VarSet, ConstraintsTerm, Pieces,
+ Result).
:- pred parse_underived_instance(module_name::in, term::in, tvarset::in,
prog_context::in, maybe1(item_instance_info)::out) is det.
-parse_underived_instance(ModuleName, Name, TVarSet, Context, Result) :-
+parse_underived_instance(ModuleName, NameTerm, TVarSet, Context, Result) :-
% We don't give a default module name here since the instance declaration
% could well be for a typeclass defined in another module.
- parse_qualified_term(Name, Name, "instance declaration", MaybeClassName),
+ NameContextPieces = [words("In instance declaration:")],
+ varset.coerce(TVarSet, VarSet),
+ parse_qualified_term(NameTerm, NameTerm, VarSet, NameContextPieces,
+ MaybeClassName),
(
MaybeClassName = ok2(ClassName, TermTypes),
- parse_types(TermTypes, TypesResult),
- parse_underived_instance_2(Name, ClassName, TypesResult, TVarSet,
- ModuleName, Context, Result)
- ;
- MaybeClassName = error2(Errors),
- Result = error1(Errors)
- ).
-
-:- pred parse_underived_instance_2(term::in, class_name::in,
- maybe1(list(mer_type))::in, tvarset::in, module_name::in, prog_context::in,
- maybe1(item_instance_info)::out) is det.
-
-parse_underived_instance_2(_, _, error1(Errors), _, _, _, error1(Errors)).
-parse_underived_instance_2(_, ClassName, ok1(Types), TVarSet, ModuleName,
- Context, Result) :-
+ % XXX Give better TypesContextPieces.
+ TypesContextPieces = [],
+ parse_types(TermTypes, VarSet, TypesContextPieces, TypesResult),
+ (
+ TypesResult = ok1(Types),
ItemInstance = item_instance_info([], ClassName, Types,
instance_body_abstract, TVarSet, ModuleName, Context),
- Result = ok1(ItemInstance).
+ Result = ok1(ItemInstance)
+ ;
+ TypesResult = error1(Specs),
+ Result = error1(Specs)
+ )
+ ;
+ MaybeClassName = error2(Specs),
+ Result = error1(Specs)
+ ).
:- pred parse_non_empty_instance(module_name::in, term::in, term::in,
varset::in, tvarset::in, prog_context::in,
@@ -611,8 +718,8 @@
parse_instance_name(ModuleName, Name, TVarSet, Context,
MaybeParsedNameAndTypes),
(
- MaybeParsedNameAndTypes = error1(Errors),
- Result = error1(Errors)
+ MaybeParsedNameAndTypes = error1(Specs),
+ Result = error1(Specs)
;
MaybeParsedNameAndTypes = ok1(ParsedNameAndTypes),
% XXX Should we keep InstanceContext, or should we replace it
@@ -626,29 +733,41 @@
check_tvars_in_instance_constraint(Result0, Name, Result)
)
;
- MaybeParsedMethods = error1(Errors),
- Result = error1(Errors)
+ MaybeParsedMethods = error1(Specs),
+ Result = error1(Specs)
).
:- pred check_tvars_in_instance_constraint(maybe1(item_instance_info)::in,
term::in, maybe1(item_instance_info)::out) is det.
-check_tvars_in_instance_constraint(error1(Errors), _, error1(Errors)).
+check_tvars_in_instance_constraint(error1(Specs), _, error1(Specs)).
check_tvars_in_instance_constraint(ok1(ItemInstance), InstanceTerm, Result) :-
% XXX
ItemInstance = item_instance_info(Constraints, _Name, Types, _Methods,
- _TVarSet, _ModName, _Context),
- % Check that all of the type variables in the constraints
- % on the instance declaration also occur in the type class
- % argument types in the instance declaration.
+ TVarSet, _ModName, _Context),
+ % Check that all of the type variables in the constraints on the instance
+ % declaration also occur in the type class argument types in the instance
+ % declaration.
(
prog_type.constraint_list_get_tvars(Constraints, TVars),
- list.member(TVar, TVars),
- \+ type_list_contains_var(Types, TVar)
- ->
- Msg = "unbound type variable(s) " ++
- "in constraints on instance declaration",
- Result = error1([Msg - InstanceTerm])
+ type_vars_list(Types, TypesVars),
+ list.filter(is_in_list(TypesVars), TVars, _BoundTVars, UnboundTVars),
+ UnboundTVars = [_ | _]
+ ->
+ UnboundTVarStrs =
+ list.map(mercury_var_to_string(TVarSet, no), UnboundTVars),
+ UnboundTVarPieces = list_to_pieces(UnboundTVarStrs),
+ ( list.length(UnboundTVars) = 1 ->
+ Prefix = [words("Error: unbound type variable")]
+ ;
+ Prefix = [words("Error: unbound type variables")]
+ ),
+ Pieces = Prefix ++ UnboundTVarPieces ++
+ [words("in constraints on instance declaration."), nl],
+ % XXX Would _Context be better than get_term_context(InstanceTerm)?
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(InstanceTerm), [always(Pieces)])]),
+ Result = error1([Spec])
;
Result = ok1(ItemInstance)
).
@@ -656,14 +775,17 @@
:- pred parse_instance_methods(module_name::in, term::in, varset::in,
maybe1(instance_methods)::out) is det.
-parse_instance_methods(ModuleName, Methods, VarSet, Result) :-
- ( list_term_to_term_list(Methods, MethodList) ->
+parse_instance_methods(ModuleName, MethodsTerm, VarSet, Result) :-
+ ( list_term_to_term_list(MethodsTerm, MethodList) ->
% Convert the list of terms into a list of maybe1(class_method)s.
list.map(term_to_instance_method(ModuleName, VarSet), MethodList,
Interface),
find_errors(Interface, Result)
;
- Result = error1(["expected list of instance methods" - Methods])
+ Pieces = [words("Error: expected list of instance methods."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(MethodsTerm), [always(Pieces)])]),
+ Result = error1([Spec])
).
% Turn the term into a method instance.
@@ -681,40 +803,58 @@
[term.functor(term.atom("/"), [ClassMethod, Arity], _)], _)
->
(
- parse_qualified_term(ClassMethod, ClassMethod,
- "instance method", ok2(ClassMethodName, [])),
+ sym_name_and_args(ClassMethod, ClassMethodName, []),
Arity = term.functor(term.integer(ArityInt), [], _),
- parse_qualified_term(InstanceMethod, InstanceMethod,
- "instance method", ok2(InstanceMethodName, []))
+ sym_name_and_args(InstanceMethod, InstanceMethodName, [])
->
Result = ok1(instance_method(pf_predicate, ClassMethodName,
instance_proc_def_name(InstanceMethodName), ArityInt,
TermContext))
;
- Msg = "expected `pred(<Name> / <Arity>) is <InstanceMethod>'",
- Result = error1([Msg - MethodTerm])
+ MethodTermStr = describe_error_term(VarSet, MethodTerm),
+ Pieces = [words("Error: expected"),
+ quote("pred(<Name> / <Arity>) is <InstanceMethod>"),
+ suffix(","),
+ words("not"), words(MethodTermStr), suffix("."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(MethodTerm),
+ [always(Pieces)])]),
+ Result = error1([Spec])
)
;
ClassMethodTerm = term.functor(term.atom("func"),
[term.functor(term.atom("/"), [ClassMethod, Arity], _)], _)
->
(
- parse_qualified_term(ClassMethod, ClassMethod,
- "instance method", ok2(ClassMethodName, [])),
+ sym_name_and_args(ClassMethod, ClassMethodName, []),
Arity = term.functor(term.integer(ArityInt), [], _),
- parse_qualified_term(InstanceMethod, InstanceMethod,
- "instance method", ok2(InstanceMethodName, []))
+ sym_name_and_args(InstanceMethod, InstanceMethodName, [])
->
Result = ok1(instance_method(pf_function, ClassMethodName,
instance_proc_def_name(InstanceMethodName), ArityInt,
TermContext))
;
- Msg = "expected `func(<Name> / <Arity>) is <InstanceMethod>'",
- Result = error1([Msg - MethodTerm])
- )
- ;
- Msg = "expected `pred(<Name> / <Arity>) is <InstanceName>'",
- Result = error1([Msg - MethodTerm])
+ MethodTermStr = describe_error_term(VarSet, MethodTerm),
+ Pieces = [words("Error: expected"),
+ quote("func(<Name> / <Arity>) is <InstanceMethod>"),
+ suffix(","),
+ words("not"), words(MethodTermStr), suffix("."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(MethodTerm),
+ [always(Pieces)])]),
+ Result = error1([Spec])
+ )
+ ;
+ MethodTermStr = describe_error_term(VarSet, MethodTerm),
+ Pieces = [words("Error: expected"),
+ quote("pred(<Name> / <Arity>) is <InstanceName>"),
+ words("or"),
+ quote("func(<Name> / <Arity>) is <InstanceName>"),
+ suffix(","),
+ words("not"), words(MethodTermStr), suffix("."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(MethodTerm), [always(Pieces)])]),
+ Result = error1([Spec])
)
;
% For the clauses in an instance declaration, the default module name
@@ -725,11 +865,12 @@
% default, which means that there is no default. (If the module
% qualifiers in the clauses don't match the module name of the class,
% we will pick that up later, in check_typeclass.m.)
+
DefaultModuleName = unqualified(""),
parse_item(DefaultModuleName, VarSet, MethodTerm, Result0),
(
- Result0 = error1(Errors),
- Result = error1(Errors)
+ Result0 = error1(Specs),
+ Result = error1(Specs)
;
Result0 = ok1(Item),
( Item = item_clause(ItemClause) ->
@@ -741,16 +882,30 @@
Context),
Result = ok1(InstanceMethod)
;
- Msg = "expected clause or " ++
- "`pred(<Name> / <Arity>) is <InstanceName>' or " ++
- "`func(<Name> / <Arity>) is <InstanceName>')",
- Result = error1([Msg - MethodTerm])
+ MethodTermStr = describe_error_term(VarSet, MethodTerm),
+ Pieces = [words("Error: expected clause or"),
+ quote("pred(<Name> / <Arity>) is <InstanceName>"),
+ words("or"),
+ quote("func(<Name> / <Arity>) is <InstanceName>"),
+ suffix(","),
+ words("not"), words(MethodTermStr), suffix("."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(MethodTerm),
+ [always(Pieces)])]),
+ Result = error1([Spec])
)
)
).
%----------------------------------------------------------------------------%
+:- pred is_in_list(list(T)::in, T::in) is semidet.
+
+is_in_list(List, Element) :-
+ list.member(Element, List).
+
+%----------------------------------------------------------------------------%
+
:- func this_file = string.
this_file = "prog_io_typeclass.m".
Index: compiler/prog_io_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_io_util.m,v
retrieving revision 1.60
diff -u -b -r1.60 prog_io_util.m
--- compiler/prog_io_util.m 3 Apr 2008 05:26:45 -0000 1.60
+++ compiler/prog_io_util.m 15 Jul 2008 13:01:55 -0000
@@ -28,42 +28,39 @@
:- interface.
:- import_module mdbcomp.prim_data.
+:- import_module mdbcomp.prim_data.
+:- import_module parse_tree.error_util.
:- import_module parse_tree.prog_data.
-:- import_module assoc_list.
:- import_module list.
:- import_module map.
:- import_module maybe.
:- import_module pair.
:- import_module term.
+:- import_module varset.
%-----------------------------------------------------------------------------%
-:- type maybe1(T1) == maybe1(T1, generic).
-:- type maybe1(T1, U)
- ---> error1(assoc_list(string, term(U)))
+:- type maybe1(T1)
+ ---> error1(list(error_spec))
; ok1(T1).
-:- type maybe2(T1, T2) == maybe2(T1, T2, generic).
-:- type maybe2(T1, T2, U)
- ---> error2(assoc_list(string, term(U)))
+:- type maybe2(T1, T2)
+ ---> error2(list(error_spec))
; ok2(T1, T2).
-:- type maybe3(T1, T2, T3) == maybe3(T1, T2, T3, generic).
-:- type maybe3(T1, T2, T3, U)
- ---> error3(assoc_list(string, term(U)))
+:- type maybe3(T1, T2, T3)
+ ---> error3(list(error_spec))
; ok3(T1, T2, T3).
-:- type maybe4(T1, T2, T3, T4) == maybe4(T1, T2, T3, T4, generic).
-:- type maybe4(T1, T2, T3, T4, U)
- ---> error4(assoc_list(string, term(U)))
+:- type maybe4(T1, T2, T3, T4)
+ ---> error4(list(error_spec))
; ok4(T1, T2, T3, T4).
-:- func get_any_errors1(maybe1(T1, U)) = assoc_list(string, term(U)).
-:- func get_any_errors2(maybe2(T1, T2, U)) = assoc_list(string, term(U)).
-:- func get_any_errors3(maybe3(T1, T2, T3, U)) = assoc_list(string, term(U)).
-:- func get_any_errors4(maybe4(T1, T2, T3, T4, U))
- = assoc_list(string, term(U)).
+:- func get_any_errors1(maybe1(T1)) = list(error_spec).
+:- func get_any_errors2(maybe2(T1, T2)) = list(error_spec).
+:- func get_any_errors3(maybe3(T1, T2, T3)) = list(error_spec).
+:- func get_any_errors4(maybe4(T1, T2, T3, T4)) = list(error_spec).
:- type maybe_functor == maybe_functor(generic).
:- type maybe_functor(T) == maybe2(sym_name, list(term(T))).
@@ -84,47 +81,53 @@
:- pred parse_list_of_vars(term(T)::in, list(var(T))::out) is semidet.
% Parse a list of quantified variables.
+ % The other input argument is a prefix for any error messages.
%
-:- pred parse_vars(term(T)::in, maybe1(list(var(T)), T)::out) is det.
+:- pred parse_vars(term(T)::in, varset(T)::in, list(format_component)::in,
+ maybe1(list(var(T)))::out) is det.
% Parse a list of quantified variables, splitting it into
% ordinary logic variables and state variables respectively.
+ % The other input argument is a prefix for any error messages.
%
-:- pred parse_quantifier_vars(term(T)::in,
- maybe2(list(var(T)), list(var(T)), T)::out) is det.
+:- pred parse_quantifier_vars(term(T)::in, varset(T)::in,
+ list(format_component)::in, maybe2(list(var(T)), list(var(T)))::out)
+ is det.
- % parse_vars_and_state_vars(Term, OrdinaryVars, DotStateVars,
- % ColonStateVars):
- %
% Similar to parse_vars, but also allow state variables to appear
% in the list. The outputs separate the parsed variables into ordinary
% variables, state variables listed as !.X, and state variables
% listed as !:X.
%
-:- pred parse_vars_and_state_vars(term(T)::in,
- maybe3(list(var(T)), list(var(T)), list(var(T)), T)::out) is det.
+:- pred parse_vars_and_state_vars(term(T)::in, varset(T)::in,
+ list(format_component)::in,
+ maybe3(list(var(T)), list(var(T)), list(var(T)))::out) is det.
-:- pred parse_name_and_arity(module_name::in, term(_T)::in,
+:- pred parse_name_and_arity(module_name::in, term(T)::in,
sym_name::out, arity::out) is semidet.
-:- pred parse_name_and_arity(term(_T)::in, sym_name::out, arity::out)
+:- pred parse_name_and_arity(term(T)::in, sym_name::out, arity::out)
is semidet.
-:- pred parse_pred_or_func_name_and_arity(module_name::in,
- term(_T)::in, pred_or_func::out, sym_name::out, arity::out) is semidet.
+:- pred parse_pred_or_func_name_and_arity(term(T)::in,
+ pred_or_func::out, sym_name::out, arity::out) is semidet.
-:- pred parse_pred_or_func_name_and_arity(term(_T)::in, pred_or_func::out,
- sym_name::out, arity::out) is semidet.
+:- pred parse_pred_or_func_and_args(term(_T)::in,
+ pred_or_func::out, sym_name::out, list(term(_T))::out) is semidet.
-:- pred parse_pred_or_func_and_args(maybe(module_name)::in, term(_T)::in,
- term(_T)::in, string::in, maybe_pred_or_func(term(_T))::out) is det.
+:- pred parse_pred_or_func_and_args_general(maybe(module_name)::in,
+ term(_T)::in, term(_T)::in, varset(_T)::in, list(format_component)::in,
+ maybe_pred_or_func(term(_T))::out) is det.
-:- pred parse_pred_or_func_and_args(term(_T)::in, pred_or_func::out,
- sym_name::out, list(term(_T))::out) is semidet.
+:- pred maybe_parse_type(term::in, mer_type::out) is semidet.
-:- pred parse_type(term::in, maybe1(mer_type)::out) is det.
+:- pred parse_type(term::in, varset::in, list(format_component)::in,
+ maybe1(mer_type)::out) is det.
-:- pred parse_types(list(term)::in, maybe1(list(mer_type))::out) is det.
+:- pred maybe_parse_types(list(term)::in, list(mer_type)::out) is semidet.
+
+:- pred parse_types(list(term)::in, varset::in, list(format_component)::in,
+ maybe1(list(mer_type))::out) is det.
:- pred unparse_type(mer_type::in, term::out) is det.
@@ -182,6 +185,7 @@
:- implementation.
:- import_module libs.compiler_util.
+:- import_module parse_tree.mercury_to_mercury.
:- import_module parse_tree.prog_io.
:- import_module parse_tree.prog_out.
:- import_module parse_tree.prog_util.
@@ -192,57 +196,57 @@
%-----------------------------------------------------------------------------%
get_any_errors1(ok1(_)) = [].
-get_any_errors1(error1(Errors)) = Errors.
+get_any_errors1(error1(Specs)) = Specs.
get_any_errors2(ok2(_, _)) = [].
-get_any_errors2(error2(Errors)) = Errors.
+get_any_errors2(error2(Specs)) = Specs.
get_any_errors3(ok3(_, _, _)) = [].
-get_any_errors3(error3(Errors)) = Errors.
+get_any_errors3(error3(Specs)) = Specs.
get_any_errors4(ok4(_, _, _, _)) = [].
-get_any_errors4(error4(Errors)) = Errors.
+get_any_errors4(error4(Specs)) = Specs.
parse_name_and_arity(ModuleName, PredAndArityTerm, SymName, Arity) :-
PredAndArityTerm = term.functor(term.atom("/"),
[PredNameTerm, ArityTerm], _),
- parse_implicitly_qualified_term(ModuleName,
- PredNameTerm, PredNameTerm, "", ok2(SymName, [])),
+ % The values of VarSet and ContextPieces do not matter here since
+ % we succeed only if they aren't needed.
+ VarSet = varset.init,
+ ContextPieces = [],
+ parse_implicitly_qualified_term(ModuleName, PredNameTerm, PredNameTerm,
+ VarSet, ContextPieces, ok2(SymName, [])),
ArityTerm = term.functor(term.integer(Arity), [], _).
parse_name_and_arity(PredAndArityTerm, SymName, Arity) :-
parse_name_and_arity(unqualified(""),
PredAndArityTerm, SymName, Arity).
-parse_pred_or_func_name_and_arity(ModuleName, PorFPredAndArityTerm,
+parse_pred_or_func_name_and_arity(PorFPredAndArityTerm,
PredOrFunc, SymName, Arity) :-
PorFPredAndArityTerm = term.functor(term.atom(PredOrFuncStr), Args, _),
( PredOrFuncStr = "pred", PredOrFunc = pf_predicate
; PredOrFuncStr = "func", PredOrFunc = pf_function
),
Args = [Arg],
+ ModuleName = unqualified(""),
parse_name_and_arity(ModuleName, Arg, SymName, Arity).
-parse_pred_or_func_name_and_arity(PorFPredAndArityTerm,
- PredOrFunc, SymName, Arity) :-
- parse_pred_or_func_name_and_arity(unqualified(""),
- PorFPredAndArityTerm, PredOrFunc, SymName, Arity).
-
-parse_pred_or_func_and_args(Term, PredOrFunc, SymName, ArgTerms) :-
- parse_pred_or_func_and_args(no, Term, Term, "",
- ok2(SymName, ArgTerms0 - MaybeRetTerm)),
+parse_pred_or_func_and_args(PredAndArgsTerm, PredOrFunc, SymName, ArgTerms) :-
(
- MaybeRetTerm = yes(RetTerm),
+ PredAndArgsTerm = term.functor(term.atom("="),
+ [FuncAndArgsTerm, FuncResultTerm], _)
+ ->
+ sym_name_and_args(FuncAndArgsTerm, SymName, ArgTerms0),
PredOrFunc = pf_function,
- list.append(ArgTerms0, [RetTerm], ArgTerms)
+ ArgTerms = ArgTerms0 ++ [FuncResultTerm]
;
- MaybeRetTerm = no,
- PredOrFunc = pf_predicate,
- ArgTerms = ArgTerms0
+ sym_name_and_args(PredAndArgsTerm, SymName, ArgTerms),
+ PredOrFunc = pf_predicate
).
-parse_pred_or_func_and_args(MaybeModuleName, PredAndArgsTerm, ErrorTerm,
- Msg, PredAndArgsResult) :-
+parse_pred_or_func_and_args_general(MaybeModuleName, PredAndArgsTerm,
+ ErrorTerm, VarSet, ContextPieces, PredAndArgsResult) :-
(
PredAndArgsTerm = term.functor(term.atom("="),
[FuncAndArgsTerm, FuncResultTerm], _)
@@ -253,26 +257,35 @@
FunctorTerm = PredAndArgsTerm,
MaybeFuncResult = no
),
+ varset.coerce(VarSet, GenericVarSet),
(
MaybeModuleName = yes(ModuleName),
parse_implicitly_qualified_term(ModuleName, FunctorTerm,
- ErrorTerm, Msg, Result)
+ ErrorTerm, GenericVarSet, ContextPieces, Result)
;
MaybeModuleName = no,
- parse_qualified_term(FunctorTerm, ErrorTerm, Msg, Result)
+ parse_qualified_term(FunctorTerm,
+ ErrorTerm, GenericVarSet, ContextPieces, Result)
),
(
Result = ok2(SymName, Args),
PredAndArgsResult = ok2(SymName, Args - MaybeFuncResult)
;
- Result = error2(Errors),
- PredAndArgsResult = error2(Errors)
+ Result = error2(Specs),
+ PredAndArgsResult = error2(Specs)
).
+maybe_parse_type(Term, Type) :-
+ % The values of VarSet and ContextPieces do not matter since we succeed
+ % only if they aren't used.
+ VarSet = varset.init,
+ ContextPieces = [],
+ parse_type(Term, VarSet, ContextPieces, ok1(Type)).
+
+parse_type(Term, VarSet, ContextPieces, Result) :-
% XXX kind inference: We currently give all types kind `star'.
% This will be different when we have a kind system.
- %
-parse_type(Term, Result) :-
+
(
Term = term.variable(Var0, _)
->
@@ -289,56 +302,68 @@
;
Term = term.functor(term.atom("{}"), Args, _)
->
- parse_types(Args, ArgsResult),
+ parse_types(Args, VarSet, ContextPieces, ArgsResult),
(
ArgsResult = ok1(ArgTypes),
Result = ok1(tuple_type(ArgTypes, kind_star))
;
- ArgsResult = error1(Errors),
- Result = error1(Errors)
+ ArgsResult = error1(Specs),
+ Result = error1(Specs)
)
;
% We don't support apply/N types yet, so we just detect them
% and report an error message.
- Term = term.functor(term.atom(""), _, _)
+ Term = term.functor(term.atom(""), _, Context)
->
- Result = error1(["ill-formed type" - Term])
+ TermStr = describe_error_term(VarSet, Term),
+ Pieces = ContextPieces ++ [lower_case_next_if_not_first,
+ words("Error: ill-formed type"), words(TermStr), suffix("."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(Context, [always(Pieces)])]),
+ Result = error1([Spec])
;
% We don't support kind annotations yet, and we don't report
% an error either. Perhaps we should?
- parse_qualified_term(Term, Term, "type", NameResult),
+ parse_qualified_term(Term, Term, VarSet, ContextPieces, NameResult),
(
NameResult = ok2(SymName, ArgTerms),
- parse_types(ArgTerms, ArgsResult),
+ parse_types(ArgTerms, VarSet, ContextPieces, ArgsResult),
(
ArgsResult = ok1(ArgTypes),
Result = ok1(defined_type(SymName, ArgTypes, kind_star))
;
- ArgsResult = error1(Errors),
- Result = error1(Errors)
+ ArgsResult = error1(Specs),
+ Result = error1(Specs)
)
;
- NameResult = error2(Errors),
- Result = error1(Errors)
+ NameResult = error2(Specs),
+ Result = error1(Specs)
)
).
-parse_types(Terms, Result) :-
- parse_types_2(Terms, [], Result).
+maybe_parse_types(Term, Types) :-
+ % The values of VarSet and ContextPieces do not matter since we succeed
+ % only if they aren't used.
+ VarSet = varset.init,
+ ContextPieces = [],
+ parse_types(Term, VarSet, ContextPieces, ok1(Types)).
-:- pred parse_types_2(list(term)::in, list(mer_type)::in,
- maybe1(list(mer_type))::out) is det.
+parse_types(Terms, VarSet, ContextPieces, Result) :-
+ parse_types_2(Terms, VarSet, ContextPieces, [], Result).
-parse_types_2([], RevTypes, ok1(Types)) :-
+:- pred parse_types_2(list(term)::in, varset::in, list(format_component)::in,
+ list(mer_type)::in, maybe1(list(mer_type))::out) is det.
+
+parse_types_2([], _, _, RevTypes, ok1(Types)) :-
list.reverse(RevTypes, Types).
-parse_types_2([Term | Terms], RevTypes, Result) :-
- parse_type(Term, Result0),
+parse_types_2([Term | Terms], VarSet, ContextPieces, RevTypes, Result) :-
+ parse_type(Term, VarSet, ContextPieces, Result0),
(
Result0 = ok1(Type),
- parse_types_2(Terms, [Type | RevTypes], Result)
+ parse_types_2(Terms, VarSet, ContextPieces, [Type | RevTypes], Result)
;
- Result0 = error1(Errors),
- Result = error1(Errors)
+ Result0 = error1(Specs),
+ Result = error1(Specs)
).
:- pred parse_builtin_type(term::in, builtin_type::out) is semidet.
@@ -358,13 +383,13 @@
parse_purity_annotation(Term0, Purity, Term1),
( Term1 = term.functor(term.atom("="), [FuncAndArgs, Ret], _) ->
FuncAndArgs = term.functor(term.atom("func"), Args, _),
- parse_type(Ret, ok1(RetType)),
+ maybe_parse_type(Ret, RetType),
MaybeRet = yes(RetType)
;
Term1 = term.functor(term.atom("pred"), Args, _),
MaybeRet = no
),
- parse_types(Args, ok1(ArgTypes)).
+ maybe_parse_types(Args, ArgTypes).
parse_purity_annotation(Term0, Purity, Term) :-
(
@@ -537,8 +562,9 @@
Inst = any(shared, higher_order(FuncInstInfo)),
Mode = (Inst -> Inst)
;
- parse_qualified_term(Term, Term, "mode definition", R),
- R = ok2(Name, Args), % should improve error reporting
+ % If the sym_name_and_args fails, we should report the error
+ % (we would need to call parse_qualified_term instead).
+ sym_name_and_args(Term, Name, Args),
convert_inst_list(AllowConstrainedInstVar, Args, ConvertedArgs),
Mode = user_defined_mode(Name, ConvertedArgs)
).
@@ -647,7 +673,7 @@
term.coerce_var(Var)), Inst)
;
% Anything else must be a user-defined inst.
- parse_qualified_term(Term, Term, "inst", ok2(QualifiedName, Args1)),
+ sym_name_and_args(Term, QualifiedName, Args1),
(
BuiltinModule = mercury_public_builtin_module,
sym_name_get_module_name(QualifiedName, unqualified(""),
@@ -744,7 +770,7 @@
bound_functor(ConsId, Args)) :-
InstTerm = term.functor(Functor, Args0, _),
( Functor = term.atom(_) ->
- parse_qualified_term(InstTerm, InstTerm, "inst", ok2(SymName, Args1)),
+ sym_name_and_args(InstTerm, SymName, Args1),
list.length(Args1, Arity),
ConsId = cons(SymName, Arity)
; Functor = term.implementation_defined(_) ->
@@ -801,111 +827,134 @@
map_parser(Parser, Xs, Xs_Result),
combine_list_results(X_Result, Xs_Result, Result).
- % If a list of things contains multiple errors, then we only
- % report the first one.
+ % If several items in a list contain errors, then we report them all.
%
:- pred combine_list_results(maybe1(T)::in, maybe1(list(T))::in,
maybe1(list(T))::out) is det.
-combine_list_results(error1(ErrorsA), error1(ErrorsB),
- error1(ErrorsA ++ ErrorsB)).
-combine_list_results(error1(Errors), ok1(_), error1(Errors)).
-combine_list_results(ok1(_), error1(Errors), error1(Errors)).
+combine_list_results(error1(HeadSpecs), error1(TailSpecs),
+ error1(HeadSpecs ++ TailSpecs)).
+combine_list_results(error1(Specs), ok1(_), error1(Specs)).
+combine_list_results(ok1(_), error1(Specs), error1(Specs)).
combine_list_results(ok1(X), ok1(Xs), ok1([X | Xs])).
%-----------------------------------------------------------------------------%
parse_list_of_vars(term.functor(term.atom("[]"), [], _), []).
parse_list_of_vars(term.functor(term.atom("[|]"), [Head, Tail], _),
- [V | Vs]) :-
- Head = term.variable(V, _),
- parse_list_of_vars(Tail, Vs).
+ [Var | Vars]) :-
+ Head = term.variable(Var, _),
+ parse_list_of_vars(Tail, Vars).
-parse_vars(Term, MaybeVars) :-
+parse_vars(Term, VarSet, ContextPieces, MaybeVars) :-
( Term = functor(atom("[]"), [], _) ->
MaybeVars = ok1([])
- ; Term = functor(atom("[|]"), [Head, Tail], _) ->
- ( Head = variable(V, _) ->
- parse_vars(Tail, MaybeVarsTail),
+ ; Term = functor(atom("[|]"), [HeadTerm, TailTerm], _) ->
+ (
+ HeadTerm = variable(HeadVar, _),
+ parse_vars(TailTerm, VarSet, ContextPieces, MaybeVarsTail),
(
MaybeVarsTail = ok1(TailVars),
- Vars = [V] ++ TailVars,
+ Vars = [HeadVar] ++ TailVars,
MaybeVars = ok1(Vars)
;
MaybeVarsTail = error1(_),
MaybeVars = MaybeVarsTail
)
;
- Msg = "expected variable",
- MaybeVars = error1([Msg - Head])
- )
- ;
- Msg = "expected list of variables",
- MaybeVars = error1([Msg - Term])
+ HeadTerm = functor(_, _, _),
+ TermStr = describe_error_term(VarSet, Term),
+ Pieces = ContextPieces ++ [lower_case_next_if_not_first,
+ words("Expected variable, not"),
+ words(TermStr), suffix("."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(HeadTerm), [always(Pieces)])]),
+ MaybeVars = error1([Spec])
+ )
+ ;
+ TermStr = describe_error_term(VarSet, Term),
+ Pieces = ContextPieces ++ [lower_case_next_if_not_first,
+ words("Expected list of variables, not"),
+ words(TermStr), suffix("."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(Term), [always(Pieces)])]),
+ MaybeVars = error1([Spec])
).
-parse_quantifier_vars(Term, MaybeQVars) :-
+parse_quantifier_vars(Term, VarSet, ContextPieces, MaybeVars) :-
( Term = functor(atom("[]"), [], _) ->
- MaybeQVars = ok2([], [])
- ; Term = functor(atom("[|]"), [Head, Tail], _) ->
+ MaybeVars = ok2([], [])
+ ; Term = functor(atom("[|]"), [HeadTerm, TailTerm], _) ->
(
(
- Head = functor(atom("!"), [variable(SV, _)], _),
+ HeadTerm = functor(atom("!"), [variable(SV, _)], _),
HeadVars = [],
HeadStateVars = [SV]
;
- Head = variable(V, _),
+ HeadTerm = variable(V, _),
HeadVars = [V],
HeadStateVars = []
)
->
- parse_quantifier_vars(Tail, MaybeQVarsTail),
+ parse_quantifier_vars(TailTerm, VarSet, ContextPieces,
+ MaybeVarsTail),
(
- MaybeQVarsTail = ok2(TailVars, TailStateVars),
+ MaybeVarsTail = ok2(TailVars, TailStateVars),
Vars = HeadVars ++ TailVars,
StateVars = HeadStateVars ++ TailStateVars,
- MaybeQVars = ok2(Vars, StateVars)
- ;
- MaybeQVarsTail = error2(_),
- MaybeQVars = MaybeQVarsTail
- )
+ MaybeVars = ok2(Vars, StateVars)
;
- Msg = "expected variable or state variable",
- MaybeQVars = error2([Msg - Head])
+ MaybeVarsTail = error2(_),
+ MaybeVars = MaybeVarsTail
)
;
- Msg = "expected list of variables and/or state variables",
- MaybeQVars = error2([Msg - Term])
+ TermStr = describe_error_term(VarSet, Term),
+ Pieces = ContextPieces ++ [lower_case_next_if_not_first,
+ words("Expected variable or state variable, not"),
+ words(TermStr), suffix("."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(HeadTerm), [always(Pieces)])]),
+ MaybeVars = error2([Spec])
+ )
+ ;
+ TermStr = describe_error_term(VarSet, Term),
+ Pieces = ContextPieces ++ [lower_case_next_if_not_first,
+ words("Expected list of variables and/or state variables, not"),
+ words(TermStr), suffix("."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(Term), [always(Pieces)])]),
+ MaybeVars = error2([Spec])
).
-parse_vars_and_state_vars(Term, MaybeVars) :-
+parse_vars_and_state_vars(Term, VarSet, ContextPieces, MaybeVars) :-
( Term = functor(atom("[]"), [], _) ->
MaybeVars = ok3([], [], [])
- ; Term = functor(atom("[|]"), [Head, Tail], _) ->
+ ; Term = functor(atom("[|]"), [HeadTerm, Tail], _) ->
(
(
- Head = functor(atom("!"), [variable(SV, _)], _),
+ HeadTerm = functor(atom("!"), [variable(SV, _)], _),
HeadVars = [],
HeadDotVars = [SV],
HeadColonVars = [SV]
;
- Head = functor(atom("!."), [variable(SV, _)], _),
+ HeadTerm = functor(atom("!."), [variable(SV, _)], _),
HeadVars = [],
HeadDotVars = [SV],
HeadColonVars = []
;
- Head = functor(atom("!:"), [variable(SV, _)], _),
+ HeadTerm = functor(atom("!:"), [variable(SV, _)], _),
HeadVars = [],
HeadDotVars = [],
HeadColonVars = [SV]
;
- Head = variable(V, _),
+ HeadTerm = variable(V, _),
HeadVars = [V],
HeadDotVars = [],
HeadColonVars = []
)
->
- parse_vars_and_state_vars(Tail, MaybeVarsTail),
+ parse_vars_and_state_vars(Tail, VarSet, ContextPieces,
+ MaybeVarsTail),
(
MaybeVarsTail = ok3(TailVars, TailDotVars, TailColonVars),
Vars = HeadVars ++ TailVars,
@@ -917,24 +966,34 @@
MaybeVars = MaybeVarsTail
)
;
- Msg = "expected variable or state variable",
- MaybeVars = error3([Msg - Head])
- )
- ;
- Msg = "expected list of variables and/or state variables",
- MaybeVars = error3([Msg - Term])
+ TermStr = describe_error_term(VarSet, Term),
+ Pieces = ContextPieces ++ [lower_case_next_if_not_first,
+ words("Expected variable or state variable, not"),
+ words(TermStr), suffix("."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(HeadTerm), [always(Pieces)])]),
+ MaybeVars = error3([Spec])
+ )
+ ;
+ TermStr = describe_error_term(VarSet, Term),
+ Pieces = ContextPieces ++ [lower_case_next_if_not_first,
+ words("Expected list of variables and/or state variables, not"),
+ words(TermStr), suffix("."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(Term), [always(Pieces)])]),
+ MaybeVars = error3([Spec])
).
%-----------------------------------------------------------------------------%
-list_term_to_term_list(Methods, MethodList) :-
+list_term_to_term_list(Term, Terms) :-
(
- Methods = term.functor(term.atom("[|]"), [Head, Tail0], _),
- list_term_to_term_list(Tail0, Tail),
- MethodList = [Head|Tail]
+ Term = term.functor(term.atom("[|]"), [HeadTerm, TailTerm], _),
+ list_term_to_term_list(TailTerm, TailTerms),
+ Terms = [HeadTerm | TailTerms]
;
- Methods = term.functor(term.atom("[]"), [], _),
- MethodList = []
+ Term = term.functor(term.atom("[]"), [], _),
+ Terms = []
).
%-----------------------------------------------------------------------------%
Index: compiler/prog_item.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_item.m,v
retrieving revision 1.33
diff -u -b -r1.33 prog_item.m
--- compiler/prog_item.m 27 Feb 2008 07:23:13 -0000 1.33
+++ compiler/prog_item.m 15 Jul 2008 11:19:36 -0000
@@ -42,10 +42,6 @@
% This is how programs (and parse errors) are represented
%
- % An error/warning message, and the term to which it relates.
- %
-:- type message_list == assoc_list(string, term).
-
:- type compilation_unit
---> unit_module(
module_name,
@@ -272,6 +268,8 @@
---> item_nothing_info(
% Used for items that should be ignored (for purposes of
% backwards compatibility etc).
+ % XXX Instead of maybe(item_warning), this should be
+ % maybe(error_spec).
nothing_maybe_warning :: maybe(item_warning),
nothing_context :: prog_context
).
Index: compiler/prog_out.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_out.m,v
retrieving revision 1.83
diff -u -b -r1.83 prog_out.m
--- compiler/prog_out.m 23 Nov 2007 07:35:21 -0000 1.83
+++ compiler/prog_out.m 15 Jul 2008 12:38:33 -0000
@@ -22,7 +22,6 @@
:- import_module mdbcomp.prim_data.
:- import_module parse_tree.prog_data.
-:- import_module parse_tree.prog_item.
:- import_module bool.
:- import_module io.
@@ -36,11 +35,6 @@
:- pred report_error(string::in, io::di, io::uo) is det.
:- pred report_error(io.output_stream::in, string::in, io::di, io::uo) is det.
- % Write out the list of error/warning messages which is returned
- % when a module is parsed.
- %
-:- pred write_messages(message_list::in, io::di, io::uo) is det.
-
% Write out the information in term context (at the moment, just
% the line number) in a form suitable for the beginning of an
% error message.
@@ -194,28 +188,6 @@
report_error(ErrorMessage, !IO),
io.set_output_stream(OldStream, _, !IO).
-write_messages([], !IO).
-write_messages([Message | Messages], !IO) :-
- write_message(Message, !IO),
- write_messages(Messages, !IO).
-
-:- pred write_message(pair(string, term)::in, io::di, io::uo) is det.
-
-write_message(Msg - Term, !IO) :-
- ( Term = term.functor(_Functor, _Args, Context)
- ; Term = term.variable(_Var, Context)
- ),
- write_context(Context, !IO),
- io.write_string(Msg, !IO),
- ( Term = term.functor(term.atom(""), [], _Context2) ->
- io.write_string(".\n", !IO)
- ;
- io.write_string(": ", !IO),
- varset.init(VarSet),
- % XXX variable names in error messages
- term_io.write_term_nl(VarSet, Term, !IO)
- ).
-
%-----------------------------------------------------------------------------%
write_context(Context, !IO) :-
Index: compiler/purity.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/purity.m,v
retrieving revision 1.119
diff -u -b -r1.119 purity.m
--- compiler/purity.m 27 Feb 2008 07:23:13 -0000 1.119
+++ compiler/purity.m 13 Jul 2008 10:23:56 -0000
@@ -871,7 +871,8 @@
list_to_pieces(PresentOuterVarNames) ++
[words(choose_number(PresentOuterVarNames, "is", "are")),
words("present in the atomic goal.")],
- Msg1 = error_msg(yes(Context), no, 0, [always(Pieces1)]),
+ Msg1 = error_msg(yes(Context), do_not_treat_as_first, 0,
+ [always(Pieces1)]),
Spec1 = error_spec(severity_error, phase_type_check, [Msg1]),
purity_info_add_message(Spec1, !Info)
),
@@ -887,7 +888,8 @@
list_to_pieces(PresentInnerVarNames) ++
[words(choose_number(PresentInnerVarNames, "is", "are")),
words("present outside the atomic goal.")],
- Msg2 = error_msg(yes(Context), no, 0, [always(Pieces2)]),
+ Msg2 = error_msg(yes(Context), do_not_treat_as_first, 0,
+ [always(Pieces2)]),
Spec2 = error_spec(severity_error, phase_type_check, [Msg2]),
purity_info_add_message(Spec2, !Info)
),
Index: compiler/recompilation.check.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/recompilation.check.m,v
retrieving revision 1.42
diff -u -b -r1.42 recompilation.check.m
--- compiler/recompilation.check.m 15 Feb 2008 08:32:00 -0000 1.42
+++ compiler/recompilation.check.m 13 Jul 2008 09:44:08 -0000
@@ -187,7 +187,7 @@
write_not_found_reasons_message(UsageFileName, ModuleName, !IO) :-
Reason = recompile_for_file_error(UsageFileName,
- "file `" ++ UsageFileName ++ "' not found."),
+ [words("file"), quote(UsageFileName), words("not found."), nl]),
write_recompile_reason(ModuleName, Reason, !IO).
:- pred should_recompile_3_try(bool::in,
@@ -226,11 +226,10 @@
true
;
io.input_stream_name(UsageFileName, !IO),
- throw_syntax_error(
- recompile_for_file_error(UsageFileName,
- "invalid usage file version number in file `"
- ++ UsageFileName ++ "'."),
- !.Info)
+ Reason = recompile_for_file_error(UsageFileName,
+ [words("invalid usage file version number in file"),
+ quote(UsageFileName), suffix("."), nl]),
+ throw_syntax_error(Reason, !.Info)
),
% Find the timestamp of the module the last time it was compiled.
@@ -264,10 +263,10 @@
; MaybeNewTimestamp = no
)
->
- throw_syntax_error(
- recompile_for_file_error(FileName,
- "error reading file `" ++ FileName ++ "'."),
- !.Info)
+ Reason = recompile_for_file_error(FileName,
+ [words("error reading file"), quote(FileName), suffix("."),
+ nl]),
+ throw_syntax_error(Reason, !.Info)
;
true
)
@@ -711,7 +710,8 @@
->
throw_syntax_error(
recompile_for_file_error(FileName,
- "error reading file `" ++ FileName ++ "'."),
+ [words("error reading file"), quote(FileName), suffix("."),
+ nl]),
!.Info)
;
true
@@ -727,16 +727,13 @@
(
UsedItemsResult = ok1(UsedVersionNumbers)
;
- UsedItemsResult = error1(Errors),
+ UsedItemsResult = error1(Specs),
(
- Errors = [],
+ Specs = [],
unexpected(this_file, "check_module_used_items: error1([])")
;
- Errors = [Msg - ErrorTerm | _],
- % XXX Can Errors contain more than oner error? If so, we should
- % not ignore the tail of the list.
- Reason = recompile_for_syntax_error(get_term_context(ErrorTerm),
- Msg),
+ Specs = [_ | _],
+ Reason = recompile_for_unreadable_used_items(Specs),
throw_syntax_error(Reason, !.Info)
)
),
@@ -1307,7 +1304,7 @@
:- type recompile_reason
---> recompile_for_file_error(
file_name,
- string
+ list(format_component)
)
; recompile_for_output_file_not_up_to_date(
@@ -1319,6 +1316,10 @@
string
)
+ ; recompile_for_unreadable_used_items(
+ list(error_spec)
+ )
+
; recompile_for_module_changed(
file_name
)
@@ -1394,64 +1395,90 @@
io::di, io::uo) is det.
write_recompile_reason(ModuleName, Reason, !IO) :-
- recompile_reason_message(Reason, MaybeContext, ErrorPieces0),
- ErrorPieces = [words("Recompiling module"), sym_name(ModuleName),
- suffix(":"), nl | ErrorPieces0],
- write_error_pieces_maybe_with_context(MaybeContext, 0, ErrorPieces, !IO).
-
-:- pred recompile_reason_message(recompile_reason::in, maybe(context)::out,
- list(format_component)::out) is det.
-
-recompile_reason_message(recompile_for_file_error(_FileName, Msg), no,
- [words(Msg)]).
-recompile_reason_message(recompile_for_output_file_not_up_to_date(FileName),
- no,
- [words("output file"), words(FileName), words("is not up to date.")]).
-recompile_reason_message(recompile_for_syntax_error(Context, Msg),
- yes(Context), [words(Msg)]).
-recompile_reason_message(recompile_for_module_changed(FileName), no,
- [words("file"), words("`" ++ FileName ++ "'"), words("has changed.")]).
-recompile_reason_message(recompile_for_item_ambiguity(Item, AmbiguousItems),
- no, Pieces) :-
+ PrefixPieces = [words("Recompiling module"), sym_name(ModuleName),
+ suffix(":"), nl],
+ recompile_reason_message(PrefixPieces, Reason, Spec),
+ globals.io_get_globals(Globals, !IO),
+ % Since these messages are informational, there should be no warnings
+ % or errors.
+ write_error_spec(Spec, Globals, 0, _NumWarnings, 0, _NumErrors, !IO).
+
+:- pred recompile_reason_message(list(format_component)::in,
+ recompile_reason::in, error_spec::out) is det.
+
+recompile_reason_message(PrefixPieces, Reason, Spec) :-
+ (
+ (
+ Reason = recompile_for_file_error(_FileName, Pieces)
+ % Pieces should mention FileName.
+ ;
+ Reason = recompile_for_output_file_not_up_to_date(FileName),
+ Pieces = [words("output file"), quote(FileName),
+ words("is not up to date.")]
+ ;
+ Reason = recompile_for_module_changed(FileName),
+ Pieces = [words("file"), quote(FileName), words("has changed.")]
+ ;
+ Reason = recompile_for_item_ambiguity(Item, AmbiguousItems),
+ ItemPieces = describe_item(Item),
AmbiguousItemPieces = component_lists_to_pieces(
list.map(describe_item, AmbiguousItems)),
- Pieces = [words("addition of ") | describe_item(Item)]
+ Pieces = [words("addition of") | ItemPieces]
++ [words("could cause an ambiguity with")]
- ++ AmbiguousItemPieces ++ [suffix(".")].
-recompile_reason_message(recompile_for_functor_ambiguity(SymName, Arity,
- Functor, AmbiguousFunctors), no, Pieces) :-
- FunctorPieces = describe_functor(SymName, Arity, Functor),
+ ++ AmbiguousItemPieces ++ [suffix(".")]
+ ;
+ Reason = recompile_for_functor_ambiguity(SymName, Arity,
+ Functor, AmbiguousFunctors),
+ FunctorPieces = describe_resolved_functor(SymName, Arity, Functor),
AmbiguousFunctorPieces = component_lists_to_pieces(
- list.map(describe_functor(SymName, Arity), AmbiguousFunctors)),
- Pieces = [words("addition of ") | FunctorPieces]
+ list.map(describe_resolved_functor(SymName, Arity),
+ AmbiguousFunctors)),
+ Pieces = [words("addition of") | FunctorPieces]
++ [words("could cause an ambiguity with")]
- ++ AmbiguousFunctorPieces ++ [suffix(".")].
-recompile_reason_message(recompile_for_changed_item(Item), no,
- list.append(describe_item(Item), [words("was modified.")])).
-recompile_reason_message(recompile_for_removed_item(Item), no,
- list.append(describe_item(Item), [words("was removed.")])).
-recompile_reason_message(
- recompile_for_changed_or_added_instance(ModuleName,
+ ++ AmbiguousFunctorPieces ++ [suffix(".")]
+ ;
+ Reason = recompile_for_changed_item(Item),
+ Pieces = describe_item(Item) ++ [words("was modified.")]
+ ;
+ Reason = recompile_for_removed_item(Item),
+ Pieces = describe_item(Item) ++ [words("was removed.")]
+ ;
+ Reason = recompile_for_changed_or_added_instance(ModuleName,
item_name(ClassName, ClassArity)),
- no,
- [
- words("an instance for class"),
+ Pieces = [words("an instance for class"),
sym_name_and_arity(ClassName / ClassArity),
- words("in module"),
- sym_name(ModuleName),
- words("was added or modified.")
- ]).
-recompile_reason_message(
- recompile_for_removed_instance(ModuleName,
+ words("in module"), sym_name(ModuleName),
+ words("was added or modified.")]
+ ;
+ Reason = recompile_for_removed_instance(ModuleName,
item_name(ClassName, ClassArity)),
- no,
- [
- words("an instance for class "),
+ Pieces = [words("an instance for class "),
sym_name_and_arity(ClassName / ClassArity),
- words("in module"),
- sym_name(ModuleName),
- words("was removed.")
- ]).
+ words("in module"), sym_name(ModuleName),
+ words("was removed.")]
+ ),
+ MaybeContext = no,
+ AllPieces = PrefixPieces ++ Pieces,
+ Spec = error_spec(severity_informational, phase_read_files,
+ [error_msg(MaybeContext, treat_as_first, 0, [always(AllPieces)])])
+ ;
+ Reason = recompile_for_syntax_error(Context, Msg),
+ MaybeContext = yes(Context),
+ AllPieces = PrefixPieces ++ [words(Msg), suffix("."), nl],
+ Spec = error_spec(severity_informational, phase_read_files,
+ [error_msg(MaybeContext, treat_as_first, 0, [always(AllPieces)])])
+ ;
+ Reason = recompile_for_unreadable_used_items(Specs),
+ MsgsList = list.map(project_spec_to_msgs, Specs),
+ list.condense(MsgsList, Msgs),
+ % MaybeContext = find_first_context_in_msgs(Msgs),
+ Spec = error_spec(severity_informational, phase_read_files, Msgs)
+ ).
+
+:- func project_spec_to_msgs(error_spec) = list(error_msg).
+
+project_spec_to_msgs(Spec) = Msgs :-
+ Spec = error_spec(_Severity, _Phase, Msgs).
:- func describe_item(item_id) = list(format_component).
@@ -1469,10 +1496,10 @@
body_item(type_body_item, type_abstract_item).
-:- func describe_functor(sym_name, arity, resolved_functor) =
+:- func describe_resolved_functor(sym_name, arity, resolved_functor) =
list(format_component).
-describe_functor(SymName, _Arity, ResolvedFunctor) = Pieces :-
+describe_resolved_functor(SymName, _Arity, ResolvedFunctor) = Pieces :-
ResolvedFunctor = resolved_functor_pred_or_func(_, ModuleName, PredOrFunc,
PredArity),
string_to_item_type(ItemTypeStr, pred_or_func_to_item_type(PredOrFunc)),
@@ -1480,26 +1507,18 @@
SymNameAndArityPiece =
sym_name_and_arity(qualified(ModuleName, UnqualName) / PredArity),
Pieces = [words(ItemTypeStr), SymNameAndArityPiece].
-describe_functor(SymName, Arity, ResolvedFunctor) = Pieces :-
+describe_resolved_functor(SymName, Arity, ResolvedFunctor) = Pieces :-
ResolvedFunctor = resolved_functor_constructor(
item_name(TypeName, TypeArity)),
- Pieces = [
- words("constructor"),
- sym_name_and_arity(SymName / Arity),
- words("of type"),
- sym_name_and_arity(TypeName / TypeArity)
- ].
-describe_functor(SymName, Arity, ResolvedFunctor) = Pieces :-
+ Pieces = [words("constructor"), sym_name_and_arity(SymName / Arity),
+ words("of type"), sym_name_and_arity(TypeName / TypeArity)].
+describe_resolved_functor(SymName, Arity, ResolvedFunctor) = Pieces :-
ResolvedFunctor = resolved_functor_field(item_name(TypeName, TypeArity),
item_name(ConsName, ConsArity)),
- Pieces = [
- words("field access function"),
+ Pieces = [words("field access function"),
sym_name_and_arity(SymName / Arity),
- words("for constructor"),
- sym_name_and_arity(ConsName / ConsArity),
- words("of type"),
- sym_name_and_arity(TypeName / TypeArity)
- ].
+ words("for constructor"), sym_name_and_arity(ConsName / ConsArity),
+ words("of type"), sym_name_and_arity(TypeName / TypeArity)].
%-----------------------------------------------------------------------------%
Index: compiler/recompilation.version.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/recompilation.version.m,v
retrieving revision 1.63
diff -u -b -r1.63 recompilation.version.m
--- compiler/recompilation.version.m 15 Feb 2008 08:32:00 -0000 1.63
+++ compiler/recompilation.version.m 13 Jul 2008 08:55:18 -0000
@@ -48,6 +48,7 @@
:- import_module hlds.hlds_out.
:- import_module libs.compiler_util.
+:- import_module parse_tree.error_util.
:- import_module parse_tree.mercury_to_mercury.
:- import_module parse_tree.prog_io.
:- import_module parse_tree.prog_type.
@@ -1259,12 +1260,11 @@
map.from_assoc_list(VNsAL, VNsMap),
Result = ok1(items(ItemType, VNsMap))
;
- Result0 = error1(Errors),
- Result = error1(Errors)
+ Result0 = error1(Specs),
+ Result = error1(Specs)
)
;
- Term = term.functor(term.atom("instance"),
- InstanceVNsTerms, _)
+ Term = term.functor(term.atom("instance"), InstanceVNsTerms, _)
->
ParseName =
(pred(NameTerm::in, Name::out) is semidet :-
@@ -1277,11 +1277,15 @@
map.from_assoc_list(VNsAL, VNsMap),
Result = ok1(instances(VNsMap))
;
- Result1 = error1(Errors),
- Result = error1(Errors)
+ Result1 = error1(Specs),
+ Result = error1(Specs)
)
;
- Result = error1(["invalid item type version numbers" - Term])
+ % XXX This is an uninformative error message.
+ Pieces = [words("Invalid item type version numbers."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(Term), [always(Pieces)])]),
+ Result = error1([Spec])
).
:- pred parse_key_version_number(
@@ -1300,7 +1304,10 @@
->
Result = ok1((Name - Arity) - VersionNumber)
;
- Result = error1(["error in item version number" - Term])
+ Pieces = [words("Error in item version number."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(Term), [always(Pieces)])]),
+ Result = error1([Spec])
).
:- pred parse_item_version_number(
@@ -1319,7 +1326,10 @@
->
Result = ok1(item_name(SymName, Arity) - VersionNumber)
;
- Result = error1(["error in item version number" - Term])
+ Pieces = [words("Error in item version number."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(Term), [always(Pieces)])]),
+ Result = error1([Spec])
).
%-----------------------------------------------------------------------------%
Index: compiler/superhomogeneous.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/superhomogeneous.m,v
retrieving revision 1.29
diff -u -b -r1.29 superhomogeneous.m
--- compiler/superhomogeneous.m 27 Feb 2008 07:23:15 -0000 1.29
+++ compiler/superhomogeneous.m 15 Jul 2008 11:16:54 -0000
@@ -512,20 +512,19 @@
% DeclType0 is a prog_term, but it is really a type so we coerce it
% to a generic term before parsing it.
term.coerce(DeclType0, DeclType1),
- parse_type(DeclType1, DeclTypeResult),
+ ContextPieces = [words("In explicit type qualification:")],
+ varset.coerce(!.VarSet, GenericVarSet),
+ parse_type(DeclType1, GenericVarSet, ContextPieces, DeclTypeResult),
(
DeclTypeResult = ok1(DeclType),
varset.coerce(!.VarSet, DeclVarSet),
process_type_qualification(X, DeclType, DeclVarSet, Context,
!ModuleInfo, !QualInfo, !Specs)
;
- DeclTypeResult = error1(Errors),
+ DeclTypeResult = error1(DeclTypeSpecs),
% The varset is a prog_varset even though it contains the names
% of type variables in ErrorTerm, which is a generic term.
- GenericVarSet = varset.coerce(!.VarSet),
- list.foldl(
- report_error_in_type_qualification(GenericVarSet, Context),
- Errors, !Specs)
+ !:Specs = DeclTypeSpecs ++ !.Specs
),
do_unravel_unification(term.variable(X, Context), RVal,
Context, MainContext, SubContext, Purity, Goal, no, NumAdded,
@@ -574,7 +573,8 @@
!QualInfo, !Specs),
Det = Det1,
term.coerce(GoalTerm1, GoalTerm),
- parse_goal(GoalTerm, MaybeParsedGoal, !VarSet),
+ ContextPieces = [words("Error:")],
+ parse_goal(GoalTerm, ContextPieces, MaybeParsedGoal, !VarSet),
(
MaybeParsedGoal = ok1(ParsedGoal),
build_lambda_expression(X, Purity, LambdaPurity, Groundness,
@@ -582,10 +582,8 @@
Context, MainContext, SubContext, Goal, NumAdded,
!VarSet, !ModuleInfo, !QualInfo, !.SInfo, !Specs)
;
- MaybeParsedGoal = error1(Errors),
- varset.coerce(!.VarSet, ProgVarSet),
- list.foldl(report_string_term_error(Context, ProgVarSet), Errors,
- !Specs),
+ MaybeParsedGoal = error1(ParsedGoalSpecs),
+ !:Specs = ParsedGoalSpecs ++ !.Specs,
NumAdded = 0,
Goal = true_goal
)
@@ -603,7 +601,9 @@
qualify_lambda_mode_list_if_not_opt_imported(Modes0, Modes, Context,
!QualInfo, !Specs),
term.coerce(GoalTerm0, GoalTerm),
- parse_dcg_pred_goal(GoalTerm, MaybeParsedGoal, DCG0, DCGn, !VarSet),
+ ContextPieces = [words("Error:")],
+ parse_dcg_pred_goal(GoalTerm, ContextPieces, MaybeParsedGoal,
+ DCG0, DCGn, !VarSet),
(
MaybeParsedGoal = ok1(ParsedGoal),
Vars1 = Vars0 ++
@@ -616,10 +616,8 @@
goal_info_set_purity(Purity, GoalInfo0, GoalInfo),
Goal = hlds_goal(GoalExpr, GoalInfo)
;
- MaybeParsedGoal = error1(Errors),
- varset.coerce(!.VarSet, ProgVarSet),
- list.foldl(report_string_term_error(Context, ProgVarSet), Errors,
- !Specs),
+ MaybeParsedGoal = error1(ParsedGoalSpecs),
+ !:Specs = ParsedGoalSpecs ++ !.Specs,
NumAdded = 0,
Goal = true_goal
)
@@ -635,10 +633,11 @@
Args = [CondThenTerm, ElseTerm],
CondThenTerm = term.functor(term.atom("->"),
[CondTerm0, ThenTerm], _)
- ),
- term.coerce(CondTerm0, CondTerm),
- parse_some_vars_goal(CondTerm, MaybeVarsCond, !VarSet)
+ )
->
+ term.coerce(CondTerm0, CondTerm),
+ ContextPieces = [words("Error:")],
+ parse_some_vars_goal(CondTerm, ContextPieces, MaybeVarsCond, !VarSet),
(
MaybeVarsCond = ok3(Vars, StateVars, CondParseTree),
BeforeSInfo = !.SInfo,
@@ -667,10 +666,8 @@
goal_info_init(Context, GoalInfo),
Goal = hlds_goal(GoalExpr, GoalInfo)
;
- MaybeVarsCond = error3(Errors),
- varset.coerce(!.VarSet, ProgVarSet),
- list.foldl(report_string_term_error(Context, ProgVarSet), Errors,
- !Specs),
+ MaybeVarsCond = error3(VarsCondSpecs),
+ !:Specs = VarsCondSpecs ++ !.Specs,
NumAdded = 0,
Goal = true_goal
)
@@ -678,8 +675,7 @@
% Handle field extraction expressions.
F = term.atom("^"),
Args = [InputTerm, FieldNameTerm],
- parse_field_list(FieldNameTerm, FieldNameResult),
- FieldNameResult = ok1(FieldNames)
+ maybe_parse_field_list(FieldNameTerm, !.VarSet, FieldNames)
->
make_fresh_arg_var(InputTerm, InputTermVar, [], !VarSet, !SInfo,
!Specs),
@@ -698,8 +694,7 @@
Args = [FieldDescrTerm, FieldValueTerm],
FieldDescrTerm = term.functor(term.atom("^"),
[InputTerm, FieldNameTerm], _),
- parse_field_list(FieldNameTerm, FieldNameResult),
- FieldNameResult = ok1(FieldNames)
+ maybe_parse_field_list(FieldNameTerm, !.VarSet, FieldNames)
->
make_fresh_arg_var(InputTerm, InputTermVar, [], !VarSet, !SInfo,
!Specs),
@@ -727,15 +722,13 @@
% Handle the usual case.
% XXX Why do we use Arg1 instead of Args here?
RHS = term.functor(F, Args1, FunctorContext),
- parse_qualified_term(RHS, RHS, "", MaybeFunctor),
- (
- MaybeFunctor = ok2(FunctorName, FunctorArgs),
+ ( sym_name_and_args(RHS, FunctorName, FunctorArgsPrime) ->
+ FunctorArgs = FunctorArgsPrime,
list.length(FunctorArgs, Arity),
ConsId = cons(FunctorName, Arity)
;
% float, int or string constant
% - any errors will be caught by typechecking
- MaybeFunctor = error2(_),
list.length(Args, Arity),
ConsId = make_functor_cons_id(F, Arity),
FunctorArgs = Args
@@ -799,19 +792,6 @@
Modes = Modes0
).
-:- pred report_error_in_type_qualification(varset::in, term.context::in,
- pair(string, term)::in, list(error_spec)::in, list(error_spec)::out)
- is det.
-
-report_error_in_type_qualification(GenericVarSet, Context, Error, !Specs) :-
- Error = ErrorMsg - ErrorTerm,
- TermStr = mercury_term_to_string(GenericVarSet, no, ErrorTerm),
- Pieces = [words("In explicit type qualification:"),
- words(ErrorMsg), suffix(":"), quote(TermStr), suffix("."), nl],
- Msg = simple_msg(Context, [always(Pieces)]),
- Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
- !:Specs = [Spec | !.Specs].
-
%-----------------------------------------------------------------------------%
%
% Code for building lambda expressions
@@ -1075,20 +1055,6 @@
%-----------------------------------------------------------------------------%
-:- pred report_string_term_error(term.context::in, varset(U)::in,
- pair(string, term(U))::in,
- list(error_spec)::in, list(error_spec)::out) is det.
-
-report_string_term_error(Context, VarSet, ErrorMsg - ErrorTerm, !Specs) :-
- TermStr = mercury_term_to_string(VarSet, no, ErrorTerm),
- Pieces = [words("Error:"), words(ErrorMsg), suffix(":"),
- quote(TermStr), suffix("."), nl],
- Msg = simple_msg(Context, [always(Pieces)]),
- Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
- !:Specs = [Spec | !.Specs].
-
-%-----------------------------------------------------------------------------%
-
:- func this_file = string.
this_file = "superhomogeneous.m".
Index: compiler/trans_opt.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/trans_opt.m,v
retrieving revision 1.49
diff -u -b -r1.49 trans_opt.m
--- compiler/trans_opt.m 28 May 2008 00:52:29 -0000 1.49
+++ compiler/trans_opt.m 9 Jul 2008 13:01:33 -0000
@@ -223,12 +223,12 @@
module_name_to_search_file_name(Import, ".trans_opt", FileName, !IO),
prog_io.read_opt_file(FileName, Import,
- ModuleError, Messages, NewItems, !IO),
+ NewItems, Specs, ModuleError, !IO),
maybe_write_string(VeryVerbose, " done.\n", !IO),
intermod.update_error_status(trans_opt_file, FileName, ModuleError,
- Messages, !Error, !IO),
+ Specs, !Error, !IO),
list.append(!.Items, NewItems, !:Items),
read_trans_opt_files(Imports, !Items, !Error, !IO).
Index: compiler/typecheck.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/typecheck.m,v
retrieving revision 1.431
diff -u -b -r1.431 typecheck.m
--- compiler/typecheck.m 7 Apr 2008 02:32:51 -0000 1.431
+++ compiler/typecheck.m 13 Jul 2008 10:20:15 -0000
@@ -264,7 +264,7 @@
words("iterations."),
words("You can use the `--type-inference-iteration-limit' option"),
words("to increase the limit).")],
- Msg = error_msg(no, no, 0, [always(Pieces)]),
+ Msg = error_msg(no, do_not_treat_as_first, 0, [always(Pieces)]),
Spec = error_spec(severity_error, phase_type_check, [Msg]).
%-----------------------------------------------------------------------------%
cvs diff: Diffing compiler/notes
cvs diff: Diffing debian
cvs diff: Diffing debian/patches
cvs diff: Diffing deep_profiler
cvs diff: Diffing deep_profiler/notes
cvs diff: Diffing doc
cvs diff: Diffing extras
cvs diff: Diffing extras/base64
cvs diff: Diffing extras/cgi
cvs diff: Diffing extras/complex_numbers
cvs diff: Diffing extras/complex_numbers/samples
cvs diff: Diffing extras/complex_numbers/tests
cvs diff: Diffing extras/concurrency
cvs diff: Diffing extras/curs
cvs diff: Diffing extras/curs/samples
cvs diff: Diffing extras/curses
cvs diff: Diffing extras/curses/sample
cvs diff: Diffing extras/dynamic_linking
cvs diff: Diffing extras/error
cvs diff: Diffing extras/fixed
cvs diff: Diffing extras/gator
cvs diff: Diffing extras/gator/generations
cvs diff: Diffing extras/gator/generations/1
cvs diff: Diffing extras/graphics
cvs diff: Diffing extras/graphics/easyx
cvs diff: Diffing extras/graphics/easyx/samples
cvs diff: Diffing extras/graphics/mercury_allegro
cvs diff: Diffing extras/graphics/mercury_allegro/examples
cvs diff: Diffing extras/graphics/mercury_allegro/samples
cvs diff: Diffing extras/graphics/mercury_allegro/samples/demo
cvs diff: Diffing extras/graphics/mercury_allegro/samples/mandel
cvs diff: Diffing extras/graphics/mercury_allegro/samples/pendulum2
cvs diff: Diffing extras/graphics/mercury_allegro/samples/speed
cvs diff: Diffing extras/graphics/mercury_glut
cvs diff: Diffing extras/graphics/mercury_opengl
cvs diff: Diffing extras/graphics/mercury_tcltk
cvs diff: Diffing extras/graphics/samples
cvs diff: Diffing extras/graphics/samples/calc
cvs diff: Diffing extras/graphics/samples/gears
cvs diff: Diffing extras/graphics/samples/maze
cvs diff: Diffing extras/graphics/samples/pent
cvs diff: Diffing extras/lazy_evaluation
cvs diff: Diffing extras/lex
cvs diff: Diffing extras/lex/samples
cvs diff: Diffing extras/lex/tests
cvs diff: Diffing extras/log4m
cvs diff: Diffing extras/logged_output
cvs diff: Diffing extras/moose
cvs diff: Diffing extras/moose/samples
cvs diff: Diffing extras/moose/tests
cvs diff: Diffing extras/mopenssl
cvs diff: Diffing extras/morphine
cvs diff: Diffing extras/morphine/non-regression-tests
cvs diff: Diffing extras/morphine/scripts
cvs diff: Diffing extras/morphine/source
cvs diff: Diffing extras/net
cvs diff: Diffing extras/odbc
cvs diff: Diffing extras/posix
cvs diff: Diffing extras/posix/samples
cvs diff: Diffing extras/quickcheck
cvs diff: Diffing extras/quickcheck/tutes
cvs diff: Diffing extras/references
cvs diff: Diffing extras/references/samples
cvs diff: Diffing extras/references/tests
cvs diff: Diffing extras/solver_types
cvs diff: Diffing extras/solver_types/library
cvs diff: Diffing extras/trailed_update
cvs diff: Diffing extras/trailed_update/samples
cvs diff: Diffing extras/trailed_update/tests
cvs diff: Diffing extras/windows_installer_generator
cvs diff: Diffing extras/windows_installer_generator/sample
cvs diff: Diffing extras/windows_installer_generator/sample/images
cvs diff: Diffing extras/xml
cvs diff: Diffing extras/xml/samples
cvs diff: Diffing extras/xml_stylesheets
cvs diff: Diffing java
cvs diff: Diffing java/runtime
cvs diff: Diffing library
Index: library/list.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/library/list.m,v
retrieving revision 1.171
diff -u -b -r1.171 list.m
--- library/list.m 29 May 2008 06:41:51 -0000 1.171
+++ library/list.m 15 Jul 2008 08:19:01 -0000
@@ -162,6 +162,12 @@
%
:- pred list.member(T::out, list(T)::in, list(T)::out) is nondet.
+ % list.contains(List, Elem) iff list.member(Elem, List).
+ % Sometimes you need the arguments in this order, because you want to
+ % construct a closure with only the list.
+ %
+:- pred list.contains(list(T)::in, T::in) is semidet.
+
% list.length(List, Length):
%
% True iff `Length' is the length of `List', i.e. if `List' contains
@@ -1564,6 +1570,9 @@
SubList = [Element | _],
list.append(_, SubList, List).
+list.contains(List, Elem) :-
+ list.member(Elem, List).
+
%-----------------------------------------------------------------------------%
list.merge([], [], []).
Index: library/parser.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/library/parser.m,v
retrieving revision 1.60
diff -u -b -r1.60 parser.m
cvs diff: Diffing mdbcomp
cvs diff: Diffing profiler
cvs diff: Diffing robdd
cvs diff: Diffing runtime
cvs diff: Diffing runtime/GETOPT
cvs diff: Diffing runtime/machdeps
cvs diff: Diffing samples
cvs diff: Diffing samples/c_interface
cvs diff: Diffing samples/c_interface/c_calls_mercury
cvs diff: Diffing samples/c_interface/cplusplus_calls_mercury
cvs diff: Diffing samples/c_interface/mercury_calls_c
cvs diff: Diffing samples/c_interface/mercury_calls_cplusplus
cvs diff: Diffing samples/c_interface/mercury_calls_fortran
cvs diff: Diffing samples/c_interface/simpler_c_calls_mercury
cvs diff: Diffing samples/c_interface/simpler_cplusplus_calls_mercury
cvs diff: Diffing samples/c_interface/standalone_c
cvs diff: Diffing samples/diff
cvs diff: Diffing samples/muz
cvs diff: Diffing samples/rot13
cvs diff: Diffing samples/solutions
cvs diff: Diffing samples/solver_types
cvs diff: Diffing samples/tests
cvs diff: Diffing samples/tests/c_interface
cvs diff: Diffing samples/tests/c_interface/c_calls_mercury
cvs diff: Diffing samples/tests/c_interface/cplusplus_calls_mercury
cvs diff: Diffing samples/tests/c_interface/mercury_calls_c
cvs diff: Diffing samples/tests/c_interface/mercury_calls_cplusplus
cvs diff: Diffing samples/tests/c_interface/mercury_calls_fortran
cvs diff: Diffing samples/tests/c_interface/simpler_c_calls_mercury
cvs diff: Diffing samples/tests/c_interface/simpler_cplusplus_calls_mercury
cvs diff: Diffing samples/tests/diff
cvs diff: Diffing samples/tests/muz
cvs diff: Diffing samples/tests/rot13
cvs diff: Diffing samples/tests/solutions
cvs diff: Diffing samples/tests/toplevel
cvs diff: Diffing scripts
cvs diff: Diffing slice
cvs diff: Diffing ssdb
cvs diff: Diffing tests
cvs diff: Diffing tests/analysis
cvs diff: Diffing tests/analysis/ctgc
cvs diff: Diffing tests/analysis/excp
cvs diff: Diffing tests/analysis/ext
cvs diff: Diffing tests/analysis/sharing
cvs diff: Diffing tests/analysis/table
cvs diff: Diffing tests/analysis/trail
cvs diff: Diffing tests/analysis/unused_args
cvs diff: Diffing tests/benchmarks
cvs diff: Diffing tests/debugger
cvs diff: Diffing tests/debugger/declarative
cvs diff: Diffing tests/dppd
cvs diff: Diffing tests/general
cvs diff: Diffing tests/general/accumulator
cvs diff: Diffing tests/general/string_format
cvs diff: Diffing tests/general/structure_reuse
cvs diff: Diffing tests/grade_subdirs
cvs diff: Diffing tests/hard_coded
cvs diff: Diffing tests/hard_coded/exceptions
cvs diff: Diffing tests/hard_coded/purity
cvs diff: Diffing tests/hard_coded/sub-modules
cvs diff: Diffing tests/hard_coded/typeclasses
cvs diff: Diffing tests/invalid
Index: tests/invalid/bad_finalise_decl.err_exp
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/invalid/bad_finalise_decl.err_exp,v
retrieving revision 1.2
diff -u -b -r1.2 bad_finalise_decl.err_exp
--- tests/invalid/bad_finalise_decl.err_exp 4 Oct 2005 07:20:23 -0000 1.2
+++ tests/invalid/bad_finalise_decl.err_exp 14 Jul 2008 08:57:07 -0000
@@ -1,5 +1,7 @@
-bad_finalise_decl.m:025: Error: `finalise' declaration requires arity: i4.
-bad_finalise_decl.m:026: Error: `finalise' declaration specifies a predicate whose arity is not zero or two: i5 / 6.
+bad_finalise_decl.m:025: Error: `finalise' declaration requires arity, found
+bad_finalise_decl.m:025: i4.
+bad_finalise_decl.m:026: Error: `finalise' declaration specifies a predicate
+bad_finalise_decl.m:026: whose arity is not zero or two: (i5 / 6).
bad_finalise_decl.m:016: Error: `finalise' declaration in module interface.
bad_finalise_decl.m:016: Error: `i2'/2 used in finalise declaration has invalid
bad_finalise_decl.m:016: signature.
Index: tests/invalid/bad_initialise_decl.err_exp
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/invalid/bad_initialise_decl.err_exp,v
retrieving revision 1.4
diff -u -b -r1.4 bad_initialise_decl.err_exp
--- tests/invalid/bad_initialise_decl.err_exp 4 Oct 2005 07:20:23 -0000 1.4
+++ tests/invalid/bad_initialise_decl.err_exp 14 Jul 2008 08:56:35 -0000
@@ -1,5 +1,8 @@
-bad_initialise_decl.m:028: Error: `initialise' declaration requires arity: i4.
-bad_initialise_decl.m:029: Error: `initialise' declaration specifies a predicate whose arity is not zero or two: i5 / 6.
+bad_initialise_decl.m:028: Error: `initialise' declaration requires arity,
+bad_initialise_decl.m:028: found i4.
+bad_initialise_decl.m:029: Error: `initialise' declaration specifies a
+bad_initialise_decl.m:029: predicate whose arity is not zero or two: (i5 /
+bad_initialise_decl.m:029: 6).
bad_initialise_decl.m:019: Error: `initialise' declaration in module interface.
bad_initialise_decl.m:019: Error: `i2'/2 used in initialise declaration has
bad_initialise_decl.m:019: invalid signature.
Index: tests/invalid/bad_mutable.err_exp
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/invalid/bad_mutable.err_exp,v
retrieving revision 1.8
diff -u -b -r1.8 bad_mutable.err_exp
--- tests/invalid/bad_mutable.err_exp 15 Jan 2007 02:24:28 -0000 1.8
+++ tests/invalid/bad_mutable.err_exp 14 Jul 2008 08:58:44 -0000
@@ -1,8 +1,13 @@
-bad_mutable.m:015: Error: malformed attribute list in mutable declaration: [untrailed, bad_attrib].
-bad_mutable.m:017: Error: the type in a mutable declaration cannot contain variables: list(_1).
-bad_mutable.m:019: Error: conflicting attributes in attribute list: [untrailed, trailed].
-bad_mutable.m:024: Error: conflicting attributes in attribute list: [thread_local, trailed].
-bad_mutable.m:026: Error: conflicting attributes in attribute list: [thread_local, constant].
+bad_mutable.m:015: Error: malformed attribute list in mutable declaration:
+bad_mutable.m:015: [untrailed, bad_attrib].
+bad_mutable.m:017: Error: the type in a mutable declaration cannot contain
+bad_mutable.m:017: variables: list(T).
+bad_mutable.m:019: Error: conflicting attributes in attribute list:
+bad_mutable.m:019: [untrailed, trailed].
+bad_mutable.m:024: Error: conflicting attributes in attribute list:
+bad_mutable.m:024: [thread_local, trailed].
+bad_mutable.m:026: Error: conflicting attributes in attribute list:
+bad_mutable.m:026: [thread_local, constant].
bad_mutable.m:011: In declaration for mutable `not_a_type':
bad_mutable.m:011: error: undefined type `no_type'/0.
bad_mutable.m:013: In declaration for mutable `not_an_inst':
Index: tests/invalid/bigtest.err_exp
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/invalid/bigtest.err_exp,v
retrieving revision 1.14
diff -u -b -r1.14 bigtest.err_exp
--- tests/invalid/bigtest.err_exp 15 Feb 2008 08:32:04 -0000 1.14
+++ tests/invalid/bigtest.err_exp 14 Jul 2008 08:52:54 -0000
@@ -1,10 +1,14 @@
+bigtest.m:001: Error: unrecognized declaration:
+bigtest.m:001: export_sym(((list / 1) , ((append / 3) , member))).
bigtest.m:001: Warning: module should start with a `:- module' declaration.
-bigtest.m:001: Error: unrecognized declaration: export_sym((list / 1, append / 3, member)).
-bigtest.m:002: Error: unrecognized declaration: export_pred((append / 3, member)).
-bigtest.m:003: Error: unrecognized declaration: export_type((list / 1, bag)).
+bigtest.m:002: Error: unrecognized declaration:
+bigtest.m:002: export_pred(((append / 3) , member)).
+bigtest.m:003: Error: unrecognized declaration:
+bigtest.m:003: export_type(((list / 1) , bag)).
bigtest.m:006: Syntax error at token ':-': operator precedence error.
-bigtest.m:008: Error: unrecognized declaration: incorrect_declaration.
-bigtest.m:016: Error: type parameters must be variables: t3 = t1 + t2.
+bigtest.m:008: Error: unrecognized declaration:
+bigtest.m:008: incorrect_declaration.
+bigtest.m:016: Error: type parameters must be variables: (t3 = (t1 + t2)).
bigtest.m:001: Warning: interface for module `bigtest' does not export
bigtest.m:001: anything.
bigtest.m:001: To be useful, a module should export something. A file should
Index: tests/invalid/conflicting_fs.err_exp
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/invalid/conflicting_fs.err_exp,v
retrieving revision 1.1
diff -u -b -r1.1 conflicting_fs.err_exp
--- tests/invalid/conflicting_fs.err_exp 5 Dec 2007 05:07:44 -0000 1.1
+++ tests/invalid/conflicting_fs.err_exp 14 Jul 2008 09:30:56 -0000
@@ -1,2 +1,4 @@
-conflicting_fs.m:008: Error: conflicting features in feature set: [single_prec_float, double_prec_float].
-conflicting_fs.m:009: Error: conflicting features in feature set: [trailing, parallel_conj].
+conflicting_fs.m:008: Error: conflicting features in feature set:
+conflicting_fs.m:008: [single_prec_float, double_prec_float].
+conflicting_fs.m:009: Error: conflicting features in feature set:
+conflicting_fs.m:009: [trailing, parallel_conj].
Index: tests/invalid/constrained_poly_insts.err_exp
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/invalid/constrained_poly_insts.err_exp,v
retrieving revision 1.10
diff -u -b -r1.10 constrained_poly_insts.err_exp
--- tests/invalid/constrained_poly_insts.err_exp 7 Sep 2006 05:51:26 -0000 1.10
+++ tests/invalid/constrained_poly_insts.err_exp 14 Jul 2008 09:38:33 -0000
@@ -1,7 +1,17 @@
-constrained_poly_insts.m:007: Error: inconsistent constraints on inst variables in predicate mode declaration: p(in(_1), out(_1 =< any)).
-constrained_poly_insts.m:009: Error: inconsistent constraints on inst variables in `:- pred' declaration: q((_1 :: in(_2 =< free)), (_1 :: out(_2 =< bound(c)))).
-constrained_poly_insts.m:012: Error: inconsistent constraints on inst variables in function mode declaration: r(in(_1)) = out(_1 =< free).
-constrained_poly_insts.m:014: Error: inconsistent constraints on inst variables in function declaration: s((_1 :: in(_2 =< ground))) = (_1 :: out(_2 =< unique)).
+constrained_poly_insts.m:007: Error: inconsistent constraints on inst variables
+constrained_poly_insts.m:007: in predicate mode declaration:
+constrained_poly_insts.m:007: p(in(I), out((I =< any))).
+constrained_poly_insts.m:009: Error: inconsistent constraints on inst variables
+constrained_poly_insts.m:009: in `:- pred' declaration:
+constrained_poly_insts.m:009: q((T :: in((I =< free))), (T :: out((I =<
+constrained_poly_insts.m:009: bound(c))))).
+constrained_poly_insts.m:012: Error: inconsistent constraints on inst variables
+constrained_poly_insts.m:012: in function mode declaration:
+constrained_poly_insts.m:012: (r(in(I)) = out((I =< free))).
+constrained_poly_insts.m:014: Error: inconsistent constraints on inst variables
+constrained_poly_insts.m:014: in function declaration:
+constrained_poly_insts.m:014: (s((T :: in((I =< ground)))) = (T :: out((I =<
+constrained_poly_insts.m:014: unique)))).
constrained_poly_insts.m:023: Error: clause for predicate
constrained_poly_insts.m:023: `constrained_poly_insts.q'/2
constrained_poly_insts.m:023: without preceding `pred' declaration.
Index: tests/invalid/errors.err_exp
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/invalid/errors.err_exp,v
retrieving revision 1.17
diff -u -b -r1.17 errors.err_exp
--- tests/invalid/errors.err_exp 10 Sep 2006 23:39:15 -0000 1.17
+++ tests/invalid/errors.err_exp 15 Jul 2008 10:44:35 -0000
@@ -1,6 +1,6 @@
errors.m:010: Warning: module should start with a `:- module' declaration.
-errors.m:060: Error: free type parameter in RHS of type definition: f(_1).
-errors.m:061: Error: free type parameter in RHS of type definition: f(_1).
+errors.m:060: Error: free type parameter T in RHS of type definition.
+errors.m:061: Error: free type parameter in RHS of type definition: f(T).
errors.m:001: Warning: interface for module `errors' does not export anything.
errors.m:001: Warning: module `int' is imported using both `:- import_module'
errors.m:001: `:- use_module' declarations.
Index: tests/invalid/func_errors.err_exp
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/invalid/func_errors.err_exp,v
retrieving revision 1.6
diff -u -b -r1.6 func_errors.err_exp
--- tests/invalid/func_errors.err_exp 7 Mar 2006 01:03:46 -0000 1.6
+++ tests/invalid/func_errors.err_exp 14 Jul 2008 09:50:13 -0000
@@ -1,4 +1,6 @@
-func_errors.m:010: Error: some but not all arguments have modes: bar((int :: in), int).
-func_errors.m:011: Error: function arguments have modes, but function result doesn't: baz((int :: in), (int :: in)).
-func_errors.m:012: Error: function result has mode, but function arguments don't: quux(int, int).
-func_errors.m:018: Error: some but not all arguments have modes: q((int :: in), int).
+func_errors.m:010: Error: some but not all arguments have modes.
+func_errors.m:011: Error: function arguments have modes, but function result
+func_errors.m:011: does not.
+func_errors.m:012: Error: function result has mode, but function arguments do
+func_errors.m:012: not.
+func_errors.m:018: Error: some but not all arguments have modes.
Index: tests/invalid/fundeps_unbound_in_ctor.err_exp
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/invalid/fundeps_unbound_in_ctor.err_exp,v
retrieving revision 1.3
diff -u -b -r1.3 fundeps_unbound_in_ctor.err_exp
--- tests/invalid/fundeps_unbound_in_ctor.err_exp 14 Jun 2006 08:14:53 -0000 1.3
+++ tests/invalid/fundeps_unbound_in_ctor.err_exp 15 Jul 2008 10:44:46 -0000
@@ -1,4 +1,7 @@
-fundeps_unbound_in_ctor.m:012: Error: type variables in class constraints introduced with `=>' must be explicitly existentially quantified using `some': some [_2, _3] baz(_2, _3, _1) => foo(_2, _3, _1).
+fundeps_unbound_in_ctor.m:012: Error: type variable C in class constraints,
+fundeps_unbound_in_ctor.m:012: which was introduced with `=>' must be
+fundeps_unbound_in_ctor.m:012: explicitly existentially quantified using
+fundeps_unbound_in_ctor.m:012: `some'.
fundeps_unbound_in_ctor.m:008: In declaration for type
fundeps_unbound_in_ctor.m:008: `fundeps_unbound_in_ctor.bar'/0:
fundeps_unbound_in_ctor.m:008: error in type class constraints: type variable
Index: tests/invalid/fundeps_vars.err_exp
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/invalid/fundeps_vars.err_exp,v
retrieving revision 1.2
diff -u -b -r1.2 fundeps_vars.err_exp
--- tests/invalid/fundeps_vars.err_exp 14 Sep 2005 05:26:46 -0000 1.2
+++ tests/invalid/fundeps_vars.err_exp 14 Jul 2008 13:03:51 -0000
@@ -1,5 +1,7 @@
-fundeps_vars.m:020: Error: domain and range of functional dependency must be comma-separated lists of variables: c -> e.
-fundeps_vars.m:027: Error: type variable in functional dependency is not a parameter of this type class: (_1 -> _2, _3), foo(_2).
+fundeps_vars.m:020: Error: the domain and range of a functional dependency must
+fundeps_vars.m:020: be comma-separated lists of variables.
+fundeps_vars.m:027: Error: type variable F in the functional dependency is not
+fundeps_vars.m:027: a parameter of this type class.
fundeps_vars.m:035: In declaration of instance of typeclass `coll'/2:
fundeps_vars.m:035: error: undefined typeclass `coll'/2.
fundeps_vars.m:042: In definition of predicate `fundeps_vars.test'/2:
Index: tests/invalid/impl_def_literal_syntax.err_exp
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/invalid/impl_def_literal_syntax.err_exp,v
retrieving revision 1.1
diff -u -b -r1.1 impl_def_literal_syntax.err_exp
--- tests/invalid/impl_def_literal_syntax.err_exp 3 Apr 2008 05:26:48 -0000 1.1
+++ tests/invalid/impl_def_literal_syntax.err_exp 14 Jul 2008 15:05:08 -0000
@@ -1,16 +1,27 @@
-impl_def_literal_syntax.m:010: Error: syntax error in `:- pred' declaration: w($file).
-impl_def_literal_syntax.m:011: Error: atom expected in `:- pred' declaration: $pred.
-impl_def_literal_syntax.m:012: Syntax error at token 'u': operator or `.' expected.
-impl_def_literal_syntax.m:013: Error: syntax error in `:- pred' declaration: v((string :: in($file))).
-impl_def_literal_syntax.m:018: Error: symbol name expected: $file.
-impl_def_literal_syntax.m:020: Error: atom expected in clause head: $line.
-impl_def_literal_syntax.m:022: Error: syntax error in inst body: bound($file).
-impl_def_literal_syntax.m:025: Error: syntax error in inst body: bound(a($file)).
-impl_def_literal_syntax.m:028: Error: inst parameters must be variables: myinst3($file).
-impl_def_literal_syntax.m:030: Error: atom expected in inst definition: $file.
-impl_def_literal_syntax.m:037: Syntax error at token 'file': expected `,', `)', or operator.
-impl_def_literal_syntax.m:040: Syntax error at token 'file': expected `,', `)', or operator.
-impl_def_literal_syntax.m:042: Syntax error at variable `ME_GRIMLOCK': expected `,', `)', or operator.
-impl_def_literal_syntax.m:043: Syntax error at integer `123': expected `,', `)', or operator.
+impl_def_literal_syntax.m:010: Error: syntax error in `:- pred' declaration at
+impl_def_literal_syntax.m:010: w($file).
+impl_def_literal_syntax.m:011: In `:- pred' declaration: error: atom expected
+impl_def_literal_syntax.m:011: at $pred.
+impl_def_literal_syntax.m:012: Syntax error at token 'u': operator or `.'
+impl_def_literal_syntax.m:012: expected.
+impl_def_literal_syntax.m:013: Error: syntax error in `:- pred' declaration at
+impl_def_literal_syntax.m:013: v((string :: in($file))).
+impl_def_literal_syntax.m:018: Error: symbol name expected at $file.
+impl_def_literal_syntax.m:020: In clause head: error: atom expected at $line.
+impl_def_literal_syntax.m:022: Error: syntax error in inst body at
+impl_def_literal_syntax.m:022: bound($file).
+impl_def_literal_syntax.m:025: Error: syntax error in inst body at
+impl_def_literal_syntax.m:025: bound(a($file)).
+impl_def_literal_syntax.m:028: Error: inst parameters must be variables.
+impl_def_literal_syntax.m:030: In inst definition: error: atom expected at
+impl_def_literal_syntax.m:030: $file.
+impl_def_literal_syntax.m:037: Syntax error at token 'file': expected `,', `)',
+impl_def_literal_syntax.m:037: or operator.
+impl_def_literal_syntax.m:040: Syntax error at token 'file': expected `,', `)',
+impl_def_literal_syntax.m:040: or operator.
+impl_def_literal_syntax.m:042: Syntax error at variable `ME_GRIMLOCK': expected
+impl_def_literal_syntax.m:042: `,', `)', or operator.
+impl_def_literal_syntax.m:043: Syntax error at integer `123': expected `,',
+impl_def_literal_syntax.m:043: `)', or operator.
impl_def_literal_syntax.m:007: Error: no clauses for predicate `g'/2.
impl_def_literal_syntax.m:008: Error: no clauses for predicate `h'/2.
Index: tests/invalid/inst_list_dup.err_exp
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/invalid/inst_list_dup.err_exp,v
retrieving revision 1.7
diff -u -b -r1.7 inst_list_dup.err_exp
--- tests/invalid/inst_list_dup.err_exp 14 Jun 2006 08:14:53 -0000 1.7
+++ tests/invalid/inst_list_dup.err_exp 14 Jul 2008 11:27:51 -0000
@@ -1,4 +1,5 @@
-inst_list_dup.m:003: Error: syntax error in inst body: bound((ground - unique ; ground - ground)).
+inst_list_dup.m:003: Error: syntax error in inst body at bound(((ground -
+inst_list_dup.m:003: unique) ; (ground - ground))).
inst_list_dup.m:001: Warning: interface for module `inst_list_dup' does not
inst_list_dup.m:001: export anything.
For more information, recompile with `-E'.
Index: tests/invalid/invalid_typeclass.err_exp
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/invalid/invalid_typeclass.err_exp,v
retrieving revision 1.6
diff -u -b -r1.6 invalid_typeclass.err_exp
--- tests/invalid/invalid_typeclass.err_exp 14 Sep 2005 05:26:47 -0000 1.6
+++ tests/invalid/invalid_typeclass.err_exp 14 Jul 2008 11:27:57 -0000
@@ -1,4 +1,5 @@
-invalid_typeclass.m:011: Error: expected distinct variables as class parameters: class3(_1, _1).
+invalid_typeclass.m:011: Error: expected distinct variables as class
+invalid_typeclass.m:011: parameters.
invalid_typeclass.m:017: Error: typeclass `invalid_typeclass.class2'/1 multiply
invalid_typeclass.m:017: defined.
invalid_typeclass.m:009: Here is the previous definition of typeclass
Index: tests/invalid/kind.err_exp
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/invalid/kind.err_exp,v
retrieving revision 1.3
diff -u -b -r1.3 kind.err_exp
--- tests/invalid/kind.err_exp 14 Sep 2005 05:26:47 -0000 1.3
+++ tests/invalid/kind.err_exp 14 Jul 2008 15:11:20 -0000
@@ -1,5 +1,6 @@
-kind.m:004: Error: ill-formed type: _1(int).
-kind.m:007: Error: syntax error in arguments of `:- func' declaration: f(_1(string)).
+kind.m:004: In type definition: error: ill-formed type K1(int).
+kind.m:007: Error: syntax error in arguments of `:- func' declaration at
+kind.m:007: f(K2(string)).
kind.m:011: In definition of inst `kind.i'/1:
kind.m:011: error: variable used as inst constructor.
kind.m:012: In definition of mode `kind.m'/1:
Index: tests/invalid/null_char.err_exp
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/invalid/null_char.err_exp,v
retrieving revision 1.1
diff -u -b -r1.1 null_char.err_exp
--- tests/invalid/null_char.err_exp 18 Mar 2007 23:35:03 -0000 1.1
+++ tests/invalid/null_char.err_exp 14 Jul 2008 15:12:39 -0000
@@ -1,16 +1,21 @@
null_char.m:012: Syntax error: null character is illegal in strings and names.
+null_char.m:014: In clause head: error: atom expected at 1.
null_char.m:014: Syntax error: null character is illegal in strings and names.
-null_char.m:014: Error: atom expected in clause head: 1.
+null_char.m:018: Syntax error at token `)': unexpected token at start of
+null_char.m:018: (sub)term.
null_char.m:018: Syntax error: null character is illegal in strings and names.
-null_char.m:018: Syntax error at token `)': unexpected token at start of (sub)term.
+null_char.m:022: Syntax error at token `. ': unexpected token at start of
+null_char.m:022: (sub)term.
null_char.m:022: Syntax error: null character is illegal in strings and names.
-null_char.m:022: Syntax error at token `. ': unexpected token at start of (sub)term.
+null_char.m:026: Syntax error at token `)': unexpected token at start of
+null_char.m:026: (sub)term.
null_char.m:026: Syntax error: null character is illegal in strings and names.
-null_char.m:026: Syntax error at token `)': unexpected token at start of (sub)term.
+null_char.m:028: Syntax error at token `. ': unexpected token at start of
+null_char.m:028: (sub)term.
null_char.m:028: Syntax error: null character is illegal in strings and names.
-null_char.m:028: Syntax error at token `. ': unexpected token at start of (sub)term.
+null_char.m:030: Syntax error at token `. ': unexpected token at start of
+null_char.m:030: (sub)term.
null_char.m:030: Syntax error: null character is illegal in strings and names.
-null_char.m:030: Syntax error at token `. ': unexpected token at start of (sub)term.
null_char.m:032: Syntax error: invalid character in quoted name.
null_char.m:034: Syntax error: Illegal character 0x0 (0) in input.
null_char.m:012: Error: clause for predicate `null_char.int'/0
Index: tests/invalid/pragma_source_file.err_exp
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/invalid/pragma_source_file.err_exp,v
retrieving revision 1.1
diff -u -b -r1.1 pragma_source_file.err_exp
--- tests/invalid/pragma_source_file.err_exp 31 Jul 2007 05:02:13 -0000 1.1
+++ tests/invalid/pragma_source_file.err_exp 14 Jul 2008 11:28:15 -0000
@@ -1 +1,2 @@
-x.m:008: Error: unrecognized declaration: an_error.
+x.m:008: Error: unrecognized declaration:
+x.m:008: an_error.
Index: tests/invalid/predmode.err_exp
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/invalid/predmode.err_exp,v
retrieving revision 1.10
diff -u -b -r1.10 predmode.err_exp
--- tests/invalid/predmode.err_exp 1 Oct 2006 04:24:12 -0000 1.10
+++ tests/invalid/predmode.err_exp 14 Jul 2008 11:28:16 -0000
@@ -1,4 +1,4 @@
-predmode.m:005: Error: some but not all arguments have modes: p((int :: in), int).
+predmode.m:005: Error: some but not all arguments have modes.
predmode.m:001: Warning: interface for module `predmode' does not export
predmode.m:001: anything.
predmode.m:001: To be useful, a module should export something. A file should
Index: tests/invalid/reserve_tag.err_exp
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/invalid/reserve_tag.err_exp,v
retrieving revision 1.5
diff -u -b -r1.5 reserve_tag.err_exp
--- tests/invalid/reserve_tag.err_exp 23 Nov 2007 07:36:01 -0000 1.5
+++ tests/invalid/reserve_tag.err_exp 15 Jul 2008 05:22:14 -0000
@@ -1,4 +1,5 @@
-reserve_tag.m:023: Error: expected type name/arity for `pragma reserve_tag' declaration: list__list / 1.
+reserve_tag.m:023: Error: expected type name/arity for `:- pragma reserve_tag'
+reserve_tag.m:023: declaration, not `(list__list / 1)'.
reserve_tag.m:021: In `pragma reserve_tag' declaration for
reserve_tag.m:021: `reserve_tag.undefined_type'/1:
reserve_tag.m:021: error: undefined type `reserve_tag.undefined_type'/1.
Index: tests/invalid/some.err_exp
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/invalid/some.err_exp,v
retrieving revision 1.8
diff -u -b -r1.8 some.err_exp
--- tests/invalid/some.err_exp 7 Sep 2006 05:51:32 -0000 1.8
+++ tests/invalid/some.err_exp 15 Jul 2008 04:08:57 -0000
@@ -1,5 +1,8 @@
-some.m:006: Error: unrecognized declaration: some junk pred p2((int :: in)) is semidet.
-some.m:012: Error: in first argument of some: expected list of variables and/or state variables: junk.
-some.m:013: Error: in first argument of some: expected list of variables and/or state variables: junk.
+some.m:006: Error: unrecognized declaration:
+some.m:006: (some junk (pred (p2((int :: in)) is semidet))).
+some.m:012: In first argument of `some': expected list of variables and/or
+some.m:012: state variables, not junk.
+some.m:013: In first argument of `some': expected list of variables and/or
+some.m:013: state variables, not junk.
some.m:005: Error: no clauses for predicate `p1'/1.
some.m:007: Error: no clauses for predicate `p3'/1.
Index: tests/invalid/specified.err_exp
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/invalid/specified.err_exp,v
retrieving revision 1.5
diff -u -b -r1.5 specified.err_exp
--- tests/invalid/specified.err_exp 16 Nov 2007 03:44:53 -0000 1.5
+++ tests/invalid/specified.err_exp 15 Jul 2008 04:39:55 -0000
@@ -1,6 +1,6 @@
-specified.m:155: Error: expected argument tabling method: implied.
-specified.m:274: Error: expected one or two arguments: specified([addr, output], hidden_arg_addr, hidden_arg_addr).
-specified.m:282: Error: expected hidden argument tabling method: voodoo.
+specified.m:155: Error: expected argument tabling method, not `implied'.
+specified.m:274: Error: expected one or two arguments for `specified'.
+specified.m:282: Error: expected hidden argument tabling method, not `voodoo'.
specified.m:138: Error in `pragma memo' declaration for predicate
specified.m:138: `specified.ap_lp_fib'/3:
specified.m:138: argument 3: argument tabling method `addr' is not compatible
Index: tests/invalid/trace_goal_env.err_exp
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/invalid/trace_goal_env.err_exp,v
retrieving revision 1.2
diff -u -b -r1.2 trace_goal_env.err_exp
--- tests/invalid/trace_goal_env.err_exp 30 May 2007 03:49:50 -0000 1.2
+++ tests/invalid/trace_goal_env.err_exp 15 Jul 2008 05:08:11 -0000
@@ -1,3 +1,5 @@
-trace_goal_env.m:023: Error: runtime takes exactly one argument, which should be a boolean expression of run-time tests: runtime(env("TRACE_ABC"), not env("TRACE_NEITHER_AB") or env("TRACE_NOR_BC")).
-trace_goal_env.m:030: Error: invalid trace goal parameter: not runtime(env("TRACE_ABC")).
+trace_goal_env.m:023: Error: runtime takes exactly one argument, which should
+trace_goal_env.m:023: be a boolean expression of run-time tests.
+trace_goal_env.m:030: Error: invalid trace goal paramater
+trace_goal_env.m:030: `(not runtime(env("TRACE_ABC")))'.
trace_goal_env.m:020: Error: no clauses for predicate `p'/2.
Index: tests/invalid/type_vars.err_exp
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/invalid/type_vars.err_exp,v
retrieving revision 1.5
diff -u -b -r1.5 type_vars.err_exp
--- tests/invalid/type_vars.err_exp 14 Jun 2006 08:14:55 -0000 1.5
+++ tests/invalid/type_vars.err_exp 15 Jul 2008 08:54:12 -0000
@@ -1,6 +1,10 @@
-type_vars.m:007: Error: type variable in existential quantifier does not occur in arguments or constraints of constructor: some [_1, _2] bar(_1).
-type_vars.m:008: Error: type variable has overlapping scopes (explicit type quantifier shadows argument type): some [_1] bar(_1).
-type_vars.m:009: Error: type variables in class constraints introduced with `=>' must be explicitly existentially quantified using `some': some [_1] bar(_1) => c(_2).
+type_vars.m:007: Error: type variable T2 in existential quantifier does not
+type_vars.m:007: occur in arguments or constraints of constructor.
+type_vars.m:008: Error: type variable T1 has overlapping scopes (explicit type
+type_vars.m:008: quantifier shadows argument type).
+type_vars.m:009: Error: type variable T2 in class constraints, which was
+type_vars.m:009: introduced with `=>' must be explicitly existentially
+type_vars.m:009: quantified using `some'.
type_vars.m:006: In declaration for type `type_vars.t1'/0:
type_vars.m:006: error in type class constraints: type variable T2 occurs in
type_vars.m:006: the constraints, but is not determined by the constructor's
Index: tests/invalid/typeclass_test_1.err_exp
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/invalid/typeclass_test_1.err_exp,v
retrieving revision 1.8
diff -u -b -r1.8 typeclass_test_1.err_exp
--- tests/invalid/typeclass_test_1.err_exp 7 Sep 2006 05:51:34 -0000 1.8
+++ tests/invalid/typeclass_test_1.err_exp 15 Jul 2008 10:45:41 -0000
@@ -1,5 +1,9 @@
-typeclass_test_1.m:001: Warning: module should start with a `:- module' declaration.
-typeclass_test_1.m:014: Error: expected `pred(<Name> / <Arity>) is <InstanceName>': type_num is foo_type_num.
+typeclass_test_1.m:001: Warning: module should start with a `:- module'
+typeclass_test_1.m:001: declaration.
+typeclass_test_1.m:014: Error: expected
+typeclass_test_1.m:014: `pred(<Name> / <Arity>) is <InstanceName>' or
+typeclass_test_1.m:014: `func(<Name> / <Arity>) is <InstanceName>', not
+typeclass_test_1.m:014: (type_num is foo_type_num).
typeclass_test_1.m:017: Syntax error at variable `_': operator or `.' expected.
typeclass_test_1.m:007: In clause for predicate `main'/2:
typeclass_test_1.m:007: unsatisfiable typeclass constraint:
Index: tests/invalid/typeclass_test_11.err_exp
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/invalid/typeclass_test_11.err_exp,v
retrieving revision 1.4
diff -u -b -r1.4 typeclass_test_11.err_exp
--- tests/invalid/typeclass_test_11.err_exp 1 Oct 2006 04:24:12 -0000 1.4
+++ tests/invalid/typeclass_test_11.err_exp 15 Jul 2008 05:23:36 -0000
@@ -1,4 +1,5 @@
-typeclass_test_11.m:004: Error: constraints on class declarations may only constrain type variables and ground types: _1 =< blah(_2).
+typeclass_test_11.m:004: Error: constraints on class declarations may only
+typeclass_test_11.m:004: constrain type variables and ground types.
typeclass_test_11.m:001: Warning: interface for module `typeclass_test_11' does
typeclass_test_11.m:001: not export anything.
typeclass_test_11.m:001: To be useful, a module should export something. A
Index: tests/invalid/typeclass_test_2.err_exp
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/invalid/typeclass_test_2.err_exp,v
retrieving revision 1.14
diff -u -b -r1.14 typeclass_test_2.err_exp
--- tests/invalid/typeclass_test_2.err_exp 14 Sep 2006 06:01:16 -0000 1.14
+++ tests/invalid/typeclass_test_2.err_exp 15 Jul 2008 08:59:14 -0000
@@ -1,4 +1,7 @@
-typeclass_test_2.m:020: Error: expected `pred(<Name> / <Arity>) is <InstanceName>': type_num / 0 is foo_type_num.
+typeclass_test_2.m:020: Error: expected
+typeclass_test_2.m:020: `pred(<Name> / <Arity>) is <InstanceName>' or
+typeclass_test_2.m:020: `func(<Name> / <Arity>) is <InstanceName>', not
+typeclass_test_2.m:020: ((type_num / 0) is foo_type_num).
typeclass_test_2.m:023: Error: clause for function
typeclass_test_2.m:023: `typeclass_test_2.foo_type_num'/1
typeclass_test_2.m:023: without preceding `func' declaration.
Index: tests/invalid/unbound_type_vars.err_exp
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/invalid/unbound_type_vars.err_exp,v
retrieving revision 1.8
diff -u -b -r1.8 unbound_type_vars.err_exp
--- tests/invalid/unbound_type_vars.err_exp 7 Sep 2006 05:51:34 -0000 1.8
+++ tests/invalid/unbound_type_vars.err_exp 15 Jul 2008 03:23:45 -0000
@@ -1,5 +1,7 @@
-unbound_type_vars.m:014: Error: type variable in superclass constraint is not a parameter of this type class: c1(_1, _2).
-unbound_type_vars.m:018: Error: unbound type variable(s) in constraints on instance declaration: c1(int, float) <= c3(_1).
+unbound_type_vars.m:014: Error: type variable T2 in the superclass constraint
+unbound_type_vars.m:014: is not a parameter of this type class.
+unbound_type_vars.m:018: Error: unbound type variable T1 in constraints on
+unbound_type_vars.m:018: instance declaration.
unbound_type_vars.m:021: In declaration for predicate `unbound_type_vars.p1'/1:
unbound_type_vars.m:021: error in type class constraints: type variable T2
unbound_type_vars.m:021: occurs in the constraints, but is not determined by
Index: tests/invalid/unicode1.err_exp
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/invalid/unicode1.err_exp,v
retrieving revision 1.2
diff -u -b -r1.2 unicode1.err_exp
--- tests/invalid/unicode1.err_exp 18 Mar 2007 23:35:04 -0000 1.2
+++ tests/invalid/unicode1.err_exp 15 Jul 2008 03:23:50 -0000
@@ -1,5 +1,5 @@
-unicode1.m:005: Syntax error: invalid hex character in Unicode escape.
unicode1.m:005: Syntax error at token 'int': operator or `.' expected.
+unicode1.m:005: Syntax error: invalid hex character in Unicode escape.
unicode1.m:001: Warning: interface for module `unicode1' does not export
unicode1.m:001: anything.
For more information, recompile with `-E'.
Index: tests/invalid/unicode2.err_exp
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/invalid/unicode2.err_exp,v
retrieving revision 1.2
diff -u -b -r1.2 unicode2.err_exp
--- tests/invalid/unicode2.err_exp 18 Mar 2007 23:35:04 -0000 1.2
+++ tests/invalid/unicode2.err_exp 15 Jul 2008 03:23:50 -0000
@@ -1,5 +1,5 @@
-unicode2.m:005: Syntax error: invalid Unicode character code.
unicode2.m:005: Syntax error at token 'int': operator or `.' expected.
+unicode2.m:005: Syntax error: invalid Unicode character code.
unicode2.m:001: Warning: interface for module `unicode2' does not export
unicode2.m:001: anything.
For more information, recompile with `-E'.
Index: tests/invalid/uu_type.err_exp
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/invalid/uu_type.err_exp,v
retrieving revision 1.5
diff -u -b -r1.5 uu_type.err_exp
--- tests/invalid/uu_type.err_exp 14 Sep 2005 05:26:55 -0000 1.5
+++ tests/invalid/uu_type.err_exp 15 Jul 2008 03:23:55 -0000
@@ -1,3 +1,4 @@
-uu_type.m:022: Error: type parameters must be variables: hiddenrenamedtype = hiddentype.
+uu_type.m:022: Error: type parameters must be variables: (hiddenrenamedtype =
+uu_type.m:022: hiddentype).
uu_type.m:012: Error: abstract declaration for type
uu_type.m:012: `uu_type.hiddenrenamedtype'/0 has no corresponding definition.
Index: tests/invalid/vars_in_wrong_places.err_exp
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/invalid/vars_in_wrong_places.err_exp,v
retrieving revision 1.9
diff -u -b -r1.9 vars_in_wrong_places.err_exp
--- tests/invalid/vars_in_wrong_places.err_exp 9 Aug 2007 03:45:54 -0000 1.9
+++ tests/invalid/vars_in_wrong_places.err_exp 15 Jul 2008 03:23:55 -0000
@@ -1,10 +1,14 @@
-vars_in_wrong_places.m:002: Error: atom expected in clause head: _1 :- blah.
-vars_in_wrong_places.m:003: Error: atom expected in equation head: _1 = 42.
-vars_in_wrong_places.m:004: Error: atom expected in equation head: _1 = 42.
-vars_in_wrong_places.m:005: Error: atom expected in `:- pred' declaration: _1.
-vars_in_wrong_places.m:006: Error: atom expected in `:- func' declaration: _1 = int.
-vars_in_wrong_places.m:007: Error: atom expected in `:- mode' declaration: _1.
-vars_in_wrong_places.m:008: Error: atom expected in function `:- mode' declaration: _1 = int.
+vars_in_wrong_places.m:002: In clause head: error: atom expected at Oops1.
+vars_in_wrong_places.m:003: In equation head: error: atom expected at Oops2.
+vars_in_wrong_places.m:004: In equation head: error: atom expected at Oops3.
+vars_in_wrong_places.m:005: In `:- pred' declaration: error: atom expected at
+vars_in_wrong_places.m:005: Oops4.
+vars_in_wrong_places.m:006: In `:- func' declaration error: atom expected at
+vars_in_wrong_places.m:006: Oops5.
+vars_in_wrong_places.m:007: In `:- mode' declaration error: atom expected at
+vars_in_wrong_places.m:007: Oops6.
+vars_in_wrong_places.m:008: In function `:- mode' declaration error: atom
+vars_in_wrong_places.m:008: expected at Oops7.
vars_in_wrong_places.m:001: Warning: interface for module
vars_in_wrong_places.m:001: `vars_in_wrong_places' does not export anything.
vars_in_wrong_places.m:001: To be useful, a module should export something. A
Index: tests/invalid/with_type.err_exp
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/invalid/with_type.err_exp,v
retrieving revision 1.5
diff -u -b -r1.5 with_type.err_exp
--- tests/invalid/with_type.err_exp 7 Sep 2006 05:51:35 -0000 1.5
+++ tests/invalid/with_type.err_exp 15 Jul 2008 03:23:55 -0000
@@ -1,7 +1,7 @@
-with_type.m:024: Error: `with_inst` and determinism both specified: with_type_4((_1 :: in), (list(_2) :: in)).
-with_type.m:027: Error: `with_inst` specified without `with_type`: with_type_5((_1 :: in), (list(_2) :: in)).
-with_type.m:030: Error: invalid inst in `with_inst`: with_inst(with_type(with_type_6((_1 :: in), (list(_2) :: in)), map_pred(string, string)), pred(in, in, out) is foo).
-with_type.m:032: Error: `with_inst` specified without argument modes: with_type_7(_1, list(_2)).
+with_type.m:024: Error: `with_inst' and determinism both specified.
+with_type.m:027: Error: `with_inst' specified without `with_type'.
+with_type.m:030: Error: invalid inst in `with_inst'.
+with_type.m:032: Error: `with_inst' specified without argument modes.
with_type.m:012: In type declaration for predicate `with_type.with_type_1':
with_type.m:012: error: expected higher order predicate type after
with_type.m:012: `with_type`.
cvs diff: Diffing tests/invalid/purity
Index: tests/invalid/purity/purity_nonsense2.err_exp
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/invalid/purity/purity_nonsense2.err_exp,v
retrieving revision 1.5
diff -u -b -r1.5 purity_nonsense2.err_exp
--- tests/invalid/purity/purity_nonsense2.err_exp 7 Sep 2006 05:51:42 -0000 1.5
+++ tests/invalid/purity/purity_nonsense2.err_exp 15 Jul 2008 06:57:35 -0000
@@ -1,5 +1,7 @@
-purity_nonsense2.m:005: Syntax error at token 'type': unexpected token at start of (sub)term.
-purity_nonsense2.m:006: Syntax error at token 'mode': unexpected token at start of (sub)term.
+purity_nonsense2.m:005: Syntax error at token 'type': unexpected token at start
+purity_nonsense2.m:005: of (sub)term.
+purity_nonsense2.m:006: Syntax error at token 'mode': unexpected token at start
+purity_nonsense2.m:006: of (sub)term.
purity_nonsense2.m:010: Error: `:- pragma promise_pure' declaration for
purity_nonsense2.m:010: `purity_nonsense2.undefined2'/0 without corresponding
purity_nonsense2.m:010: `pred' or `func' declaration.
cvs diff: Diffing tests/misc_tests
cvs diff: Diffing tests/mmc_make
cvs diff: Diffing tests/mmc_make/lib
cvs diff: Diffing tests/par_conj
cvs diff: Diffing tests/recompilation
cvs diff: Diffing tests/tabling
cvs diff: Diffing tests/term
cvs diff: Diffing tests/trailing
cvs diff: Diffing tests/valid
cvs diff: Diffing tests/warnings
cvs diff: Diffing tools
cvs diff: Diffing trace
cvs diff: Diffing util
cvs diff: Diffing vim
cvs diff: Diffing vim/after
cvs diff: Diffing vim/ftplugin
cvs diff: Diffing vim/syntax
--------------------------------------------------------------------------
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
--------------------------------------------------------------------------
More information about the reviews
mailing list