[m-rev.] for post-commit review: make make_hlds use batches of error_specs
Zoltan Somogyi
zs at csse.unimelb.edu.au
Mon Sep 11 09:38:17 AEST 2006
Convert the make_hlds stage of the compiler from printing out error messages
one at a time to gathering them all up and printing them all at once after
sorting and deleting duplicates. This approach makes it much easier to be
consistent about updating the exit status in the I/O state and the error count
in the module info, and indeed this diff fixes some bugs in this area.
This approach also means that instead of threading a pair of I/O states
through these modules, we now mostly thread through a list of error
specifications. In a couple of places, we create the I/O states we need
for printing progress messages using trace goals.
configure.in:
Check that the installed compiler supports trace goals (perhaps with
warnings), since the compiler now uses them.
compiler/Mercury.options:
Temporarily compensate for a bug in the handling of trace goals.
compiler/add_class.m:
compiler/add_clause.m:
compiler/add_mode.m:
compiler/add_pragma.m:
compiler/add_pred.m:
compiler/add_solver.m:
compiler/add_type.m:
compiler/field_access.m:
compiler/foreign.m:
compiler/make_hlds_error.m:
compiler/make_hlds_passes.m:
compiler/make_hlds_warn.m:
compiler/module_qual.m:
compiler/modules.m:
compiler/qual_info.m:
compiler/state_var.m:
compiler/superhomogeneous.m:
Make the change described at the top. In many cases, this required
changing code to error util instead of io.write_strings to create the
error messages.
In some cases, move a predicate used in one module but defined in
another module to the first module.
Delete some predicates whose job used to be to test options to see
whether a message should be generated, since we can now embed the
option value that a message depends on in the error message itself.
In module_qual.m, remove unnecessary module qualifications.
In modules.m, give explicit names to a bunch of lambda expressions.
Reformat comments to exploit the available columns.
compiler/check_typeclass.m:
Conform to the changes above. Mark with XXX the places where we are
ignoring the proper update of the error count in module_infos.
compiler/modes.m:
compiler/post_typecheck.m:
compiler/stratify.m:
compiler/table_gen.m:
compiler/unused_args.m:
Use error_specs instead of plain pieces to print error messages.
compiler/options.m:
Rename an option that conflicts with a language keyword.
compiler/handle_options.m:
Conform to the change to options.m.
compiler/prog_data.m:
Rename some function symbols that conflict with language keywords.
compiler/prog_out.m:
compiler/prog_io_util.m:
Conform the change above, and delete some predicates that have
now become unused.
compiler/mercury_compile.m:
Rename a predicate to avoid an ambiguity.
Conform to the changes above.
compiler/hlds_out.m:
compiler/make.module_dep_file.m:
compiler/make_hlds.m:
compiler/mercury_to_mercury.m:
compiler/mode_errors.m:
compiler/prog_io.m:
Conform to the changes above. In some cases, delete predicates
that aren't needed anymore.
tests/invalid/errors.err_exp:
tests/invalid/errors1.err_exp:
tests/invalid/state_vars_test3.err_exp:
tests/invalid/undef_inst.err_exp:
Update this expected output to reflect the fact that we now sort
the error messages.
tests/invalid/missing_interface_import2.err_exp:
tests/warnings/double_underscore.exp:
Update this expected output to reflect the fact that we no longer
print the same error message twice.
tests/invalid/missing_det_decls.err_exp:
Update this expected output to reflect the fact that we now indent
an error messages correctly.
tests/invalid/multimode_syntax.err_exp:
Update this expected output to reflect the fact that we now use
error_util instead of plain io.writes to create an error message.
tests/invalid/typeclass_test.err_exp:
tests/invalid/unsatisfiable_constraint.err_exp:
Update this expected output to reflect minor improvements in the
formatting of an error message.
Zoltan.
cvs diff: Diffing .
Index: configure.in
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/configure.in,v
retrieving revision 1.470
diff -u -b -r1.470 configure.in
--- configure.in 22 Aug 2006 09:25:40 -0000 1.470
+++ configure.in 9 Sep 2006 01:11:57 -0000
@@ -233,7 +233,9 @@
(1 .. 2) = [[1, 2]],
Global = 561
->
- io.print("Hello, world\n", !IO)
+ trace [[io(!S)]] (
+ io.print("Hello, world\n", !S)
+ )
;
io.print("Nope.\n", !IO)
).
@@ -303,10 +305,11 @@
EOF
if
echo $BOOTSTRAP_MC conftest >&AC_FD_CC 2>&1 &&
+ # XXX We should reenable --halt-at-warn as soon as we can.
$BOOTSTRAP_MC \
--verbose \
--trace-io-builtins-2006-08-14 \
- --halt-at-warn $link_static_opt conftest \
+ $link_static_opt conftest \
</dev/null >&AC_FD_CC 2>&1 &&
test "`./conftest 2>&1 | tr -d '\015'`" = "Hello, world" &&
# Test for the --record-term-sizes-as-words option.
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/Mercury.options
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/Mercury.options,v
retrieving revision 1.22
diff -u -b -r1.22 Mercury.options
--- compiler/Mercury.options 29 Mar 2006 00:57:20 -0000 1.22
+++ compiler/Mercury.options 8 Sep 2006 10:23:43 -0000
@@ -52,3 +52,6 @@
# Likewise for mlds_to_gcc.m
CFLAGS-mlds_to_gcc = $(CFLAGS-gcc)
+# XXX temporary bug workaround
+MCFLAGS-hlds.make_hlds.add_clause = --no-halt-at-warn
+MCFLAGS-hlds.make_hlds.add_pragma = --no-halt-at-warn
Index: compiler/add_class.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/add_class.m,v
retrieving revision 1.20
diff -u -b -r1.20 add_class.m
--- compiler/add_class.m 7 Sep 2006 05:50:51 -0000 1.20
+++ compiler/add_class.m 8 Sep 2006 09:03:14 -0000
@@ -14,9 +14,9 @@
:- import_module hlds.make_hlds.make_hlds_passes.
:- import_module hlds.make_hlds.qual_info.
:- import_module mdbcomp.prim_data.
+:- import_module parse_tree.error_util.
:- import_module parse_tree.prog_data.
-:- import_module io.
:- import_module list.
:- import_module term.
@@ -25,12 +25,14 @@
:- pred module_add_class_defn(list(prog_constraint)::in,
list(prog_fundep)::in, sym_name::in, list(tvar)::in, class_interface::in,
tvarset::in, prog_context::in, item_status::in,
- module_info::in, module_info::out, io::di, io::uo) is det.
+ module_info::in, module_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
:- pred module_add_instance_defn(module_name::in, list(prog_constraint)::in,
sym_name::in, list(mer_type)::in, instance_body::in, tvarset::in,
import_status::in, prog_context::in,
- module_info::in, module_info::out, io::di, io::uo) is det.
+ module_info::in, module_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
% Given the definition for a predicate or function from a
% type class instance declaration, produce the clauses_info
@@ -40,7 +42,7 @@
pred_or_func::in, arity::in, list(mer_type)::in, pred_markers::in,
term.context::in, import_status::in, clauses_info::out,
module_info::in, module_info::out, qual_info::in, qual_info::out,
- io::di, io::uo) is det.
+ list(error_spec)::in, list(error_spec)::out) is det.
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -59,7 +61,6 @@
:- import_module hlds.make_hlds.state_var.
:- import_module hlds.pred_table.
:- import_module libs.compiler_util.
-:- import_module parse_tree.error_util.
:- import_module parse_tree.prog_out.
:- import_module parse_tree.prog_type.
:- import_module parse_tree.prog_type_subst.
@@ -76,7 +77,7 @@
:- import_module varset.
module_add_class_defn(Constraints, FunDeps, Name, Vars, Interface, VarSet,
- Context, Status, !ModuleInfo, !IO) :-
+ Context, Status, !ModuleInfo, !Specs) :-
module_info_get_class_table(!.ModuleInfo, Classes0),
module_info_get_superclass_table(!.ModuleInfo, SuperClasses0),
list.length(Vars, ClassArity),
@@ -112,31 +113,25 @@
->
% Always report the error, even in `.opt' files.
DummyStatus = status_local,
+ Extras = [words("The superclass constraints do not match."), nl],
multiple_def_error(DummyStatus, Name, ClassArity, "typeclass",
- Context, OldContext, _, !IO),
- prog_out.write_context(Context, !IO),
- io.write_string(" The superclass constraints do not match.\n",
- !IO),
- io.set_exit_status(1, !IO),
+ Context, OldContext, Extras, !Specs),
ErrorOrPrevDef = yes
;
\+ class_fundeps_are_identical(OldFunDeps, HLDSFunDeps)
->
% Always report the error, even in `.opt' files.
DummyStatus = status_local,
+ Extras = [words("The functional dependencies do not match."), nl],
multiple_def_error(DummyStatus, Name, ClassArity, "typeclass",
- Context, OldContext, _, !IO),
- prog_out.write_context(Context, !IO),
- io.write_string(" The functional dependencies do not match.\n",
- !IO),
- io.set_exit_status(1, !IO),
+ Context, OldContext, Extras, !Specs),
ErrorOrPrevDef = yes
;
Interface = concrete(_),
OldInterface = concrete(_)
->
multiple_def_error(ImportStatus, Name, ClassArity,
- "typeclass", Context, OldContext, _, !IO),
+ "typeclass", Context, OldContext, [], !Specs),
ErrorOrPrevDef = yes
;
ErrorOrPrevDef = no
@@ -155,7 +150,7 @@
(
Interface = concrete(Methods),
module_add_class_interface(Name, Vars, Methods,
- Status, PredProcIds0, !ModuleInfo, !IO),
+ Status, PredProcIds0, !ModuleInfo, !Specs),
% Get rid of the `no's from the list of maybes
IsYes = (pred(Maybe::in, PredProcId::out) is semidet :-
Maybe = yes(Pred - Proc),
@@ -163,12 +158,9 @@
),
list.filter_map(IsYes, PredProcIds0, PredProcIds1),
- %
- % The list must be sorted on pred_id and then
- % proc_id -- check_typeclass.m assumes this
- % when it is generating the corresponding list
- % of pred_proc_ids for instance definitions.
- %
+ % The list must be sorted on pred_id and then proc_id --
+ % check_typeclass.m assumes this when it is generating the
+ % corresponding list of pred_proc_ids for instance definitions.
list.sort(PredProcIds1, ClassMethods)
;
Interface = abstract,
@@ -260,24 +252,24 @@
:- pred module_add_class_interface(sym_name::in, list(tvar)::in,
class_methods::in, item_status::in,
list(maybe(pair(pred_id, proc_id)))::out,
- module_info::in, module_info::out, io::di, io::uo) is det.
+ module_info::in, module_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
module_add_class_interface(Name, Vars, Methods, Status, PredProcIds,
- !ModuleInfo, !IO) :-
+ !ModuleInfo, !Specs) :-
list.filter(is_class_method_mode_item, Methods, ModeMethods,
PredOrFuncMethods),
some [!PPIds] (
add_class_pred_or_func_methods(Name, Vars, PredOrFuncMethods, Status,
- !:PPIds, !ModuleInfo, !IO),
- %
+ !:PPIds, !ModuleInfo, !Specs),
+
% Add the pred_or_func_mode decls. Since we have already added the
% predicate/function method decls there should already be an entry in
% the predicate table corresponding to the mode item we are about to
% add. If not, report an error.
- %
list.foldl3(add_class_pred_or_func_mode_method(Name, Vars, Status),
- ModeMethods, !PPIds, !ModuleInfo, !IO),
- check_method_modes(Methods, !.PPIds, PredProcIds, !ModuleInfo, !IO)
+ ModeMethods, !PPIds, !ModuleInfo, !Specs),
+ check_method_modes(Methods, !.PPIds, PredProcIds, !ModuleInfo, !Specs)
).
:- pred is_class_method_mode_item(class_method::in) is semidet.
@@ -289,14 +281,15 @@
list(tvar)::in, item_status::in, class_method::in,
list(maybe(pair(pred_id, proc_id)))::in,
list(maybe(pair(pred_id, proc_id)))::out,
- module_info::in, module_info::out, io::di, io::uo) is det.
+ module_info::in, module_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
add_class_pred_or_func_mode_method(Name, Vars, Status, Method,
- !PredProcIds, !ModuleInfo, !IO) :-
+ !PredProcIds, !ModuleInfo, !Specs) :-
(
Method = method_pred_or_func(_, _, _, _, _, _, _, _, _, _, _, _, _),
- unexpected(this_file, "add_class_pred_or_func_mode_method: " ++
- "pred_or_func method item")
+ unexpected(this_file,
+ "add_class_pred_or_func_mode_method: pred_or_func method item")
;
Method = method_pred_or_func_mode(_VarSet, MaybePredOrFunc, PredName,
Modes, _WithInst, _MaybeDet, _Cond, Context)
@@ -306,7 +299,6 @@
(
% The only way this could have happened now is if a `with_inst`
% annotation was not expanded.
- %
MaybePredOrFunc = no,
unexpected(this_file, "add_class_pred_or_func_mode_method: " ++
"unexpanded `with_inst` annotation")
@@ -316,26 +308,22 @@
(
predicate_table_search_pf_sym_arity(PredTable, is_fully_qualified,
PredOrFunc, PredName, PredArity, Preds),
- Preds \= []
+ Preds = [_ | _]
->
(
- % This case should have been caught above.
- Preds = [],
- unexpected(this_file, "empty list")
- ;
Preds = [PredId],
module_info_pred_info(!.ModuleInfo, PredId, PredInfo),
pred_info_get_markers(PredInfo, PredMarkers),
( check_marker(PredMarkers, marker_class_method) ->
module_add_class_method(Method, Name, Vars, Status,
- PredProcId, !ModuleInfo, !IO),
+ PredProcId, !ModuleInfo, !Specs),
list.cons(PredProcId, !PredProcIds)
;
% XXX It may also be worth reporting that although there
% wasn't a matching class method, there was a matching
% predicate/function.
missing_pred_or_func_method_error(PredName, PredArity,
- PredOrFunc, Context, !ModuleInfo, !IO)
+ PredOrFunc, Context, !Specs)
)
;
% This shouldn't happen.
@@ -343,28 +331,30 @@
unexpected(this_file, "multiple preds matching method mode")
)
;
- missing_pred_or_func_method_error(PredName, PredArity,
- PredOrFunc, Context, !ModuleInfo, !IO)
+ missing_pred_or_func_method_error(PredName, PredArity, PredOrFunc,
+ Context, !Specs)
).
:- pred add_class_pred_or_func_methods(sym_name::in, list(tvar)::in,
class_methods::in, item_status::in,
list(maybe(pair(pred_id, proc_id)))::out,
- module_info::in, module_info::out, io::di, io::uo) is det.
+ module_info::in, module_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
-add_class_pred_or_func_methods(_, _, [], _, [], !ModuleInfo, !IO).
+add_class_pred_or_func_methods(_, _, [], _, [], !ModuleInfo, !Specs).
add_class_pred_or_func_methods(Name, Vars, [M | Ms], Status, [P | Ps],
- !ModuleInfo, !IO) :-
- module_add_class_method(M, Name, Vars, Status, P, !ModuleInfo, !IO),
+ !ModuleInfo, !Specs) :-
+ module_add_class_method(M, Name, Vars, Status, P, !ModuleInfo, !Specs),
add_class_pred_or_func_methods(Name, Vars, Ms, Status, Ps, !ModuleInfo,
- !IO).
+ !Specs).
:- pred module_add_class_method(class_method::in, sym_name::in, list(tvar)::in,
item_status::in, maybe(pair(pred_id, proc_id))::out,
- module_info::in, module_info::out, io::di, io::uo) is det.
+ module_info::in, module_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
module_add_class_method(Method, Name, Vars, Status, MaybePredIdProcId,
- !ModuleInfo, !IO) :-
+ !ModuleInfo, !Specs) :-
(
Method = method_pred_or_func(TypeVarSet, InstVarSet, ExistQVars,
PredOrFunc, PredName, TypesAndModes, _WithType, _WithInst,
@@ -380,7 +370,7 @@
add_marker(marker_class_method, Markers0, Markers),
module_add_pred_or_func(TypeVarSet, InstVarSet, ExistQVars, PredOrFunc,
PredName, TypesAndModes, MaybeDet, Purity, NewClassContext,
- Markers, Context, Status, MaybePredIdProcId, !ModuleInfo, !IO)
+ Markers, Context, Status, MaybePredIdProcId, !ModuleInfo, !Specs)
;
Method = method_pred_or_func_mode(VarSet, MaybePredOrFunc, PredName,
Modes, _WithInst, MaybeDet, _Cond, Context),
@@ -390,7 +380,7 @@
IsClassMethod = yes,
module_add_mode(VarSet, PredName, Modes, MaybeDet, ImportStatus,
Context, PredOrFunc, IsClassMethod, PredIdProcId, !ModuleInfo,
- !IO),
+ !Specs),
MaybePredIdProcId = yes(PredIdProcId)
;
MaybePredOrFunc = no,
@@ -430,10 +420,11 @@
:- pred check_method_modes(class_methods::in,
list(maybe(pair(pred_id, proc_id)))::in,
list(maybe(pair(pred_id, proc_id)))::out,
- module_info::in, module_info::out, io::di, io::uo) is det.
+ module_info::in, module_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
-check_method_modes([], !PredProcIds, !ModuleInfo, !IO).
-check_method_modes([Method | Methods], !PredProcIds, !ModuleInfo, !IO) :-
+check_method_modes([], !PredProcIds, !ModuleInfo, !Specs).
+check_method_modes([Method | Methods], !PredProcIds, !ModuleInfo, !Specs) :-
(
Method = method_pred_or_func(_, _, _, PorF, QualName, TypesAndModes,
_WithType, _WithInst, _, _, _, _, _),
@@ -470,7 +461,7 @@
PorF = predicate,
pred_info_get_procedures(PredInfo0, Procs),
( map.is_empty(Procs) ->
- pred_method_with_no_modes_error(PredInfo0, !IO)
+ pred_method_with_no_modes_error(PredInfo0, !Specs)
;
true
)
@@ -481,10 +472,10 @@
;
Method = method_pred_or_func_mode(_, _, _, _, _, _, _, _)
),
- check_method_modes(Methods, !PredProcIds, !ModuleInfo, !IO).
+ check_method_modes(Methods, !PredProcIds, !ModuleInfo, !Specs).
module_add_instance_defn(InstanceModuleName, Constraints, ClassName,
- Types, Body0, VarSet, Status, Context, !ModuleInfo, !IO) :-
+ Types, Body0, VarSet, Status, Context, !ModuleInfo, !Specs) :-
module_info_get_class_table(!.ModuleInfo, Classes),
module_info_get_instance_table(!.ModuleInfo, Instances0),
list.length(Types, ClassArity),
@@ -496,20 +487,21 @@
Context, Constraints, Types, Body, no, VarSet, Empty),
map.lookup(Instances0, ClassId, InstanceDefns),
check_for_overlapping_instances(NewInstanceDefn, InstanceDefns,
- ClassId, !IO),
+ ClassId, !Specs),
map.det_update(Instances0, ClassId,
[NewInstanceDefn | InstanceDefns], Instances),
module_info_set_instance_table(Instances, !ModuleInfo)
;
undefined_type_class_error(ClassName, ClassArity, Context,
- "instance declaration", !IO)
+ "instance declaration", !Specs)
).
:- pred check_for_overlapping_instances(hlds_instance_defn::in,
- list(hlds_instance_defn)::in, class_id::in, io::di, io::uo) is det.
+ list(hlds_instance_defn)::in, class_id::in,
+ list(error_spec)::in, list(error_spec)::out) is det.
check_for_overlapping_instances(NewInstanceDefn, InstanceDefns, ClassId,
- !IO) :-
+ !Specs) :-
IsOverlapping = (pred((Context - OtherContext)::out) is nondet :-
NewInstanceDefn = hlds_instance_defn(_, _Status, Context,
_, Types, Body, _, VarSet, _),
@@ -524,25 +516,27 @@
type_list_subsumes(Types, NewOtherTypes, _)
),
solutions.aggregate(IsOverlapping,
- report_overlapping_instance_declaration(ClassId), !IO).
+ report_overlapping_instance_declaration(ClassId), !Specs).
:- pred report_overlapping_instance_declaration(class_id::in,
- pair(prog_context)::in, io::di, io::uo) is det.
+ pair(prog_context)::in,
+ list(error_spec)::in, list(error_spec)::out) is det.
report_overlapping_instance_declaration(class_id(ClassName, ClassArity),
- Context - OtherContext, !IO) :-
- io.set_exit_status(1, !IO),
+ Context - OtherContext, !Specs) :-
Pieces1 = [words("Error: multiply defined (or overlapping)"),
words("instance declarations for class"),
sym_name_and_arity(ClassName / ClassArity),
suffix("."), nl],
Pieces2 = [words("Previous instance declaration was here.")],
- write_error_pieces(Context, 0, Pieces1, !IO),
- write_error_pieces(OtherContext, 0, Pieces2, !IO).
+ Msg1 = simple_msg(Context, [always(Pieces1)]),
+ Msg2 = error_msg(yes(OtherContext), yes, 0, [always(Pieces2)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg1, Msg2]),
+ !:Specs = [Spec | !.Specs].
do_produce_instance_method_clauses(InstanceProcDefn, PredOrFunc, PredArity,
ArgTypes, Markers, Context, Status, ClausesInfo, !ModuleInfo,
- !QualInfo, !IO) :-
+ !QualInfo, !Specs) :-
(
% Handle the `pred(<MethodName>/<Arity>) is <ImplName>' syntax.
InstanceProcDefn = name(InstancePredName),
@@ -581,22 +575,23 @@
list.foldl4(
produce_instance_method_clause(PredOrFunc, Context, Status),
InstanceClauses, !ModuleInfo, !QualInfo,
- ClausesInfo0, ClausesInfo, !IO)
+ ClausesInfo0, ClausesInfo, !Specs)
).
:- pred produce_instance_method_clause(pred_or_func::in,
prog_context::in, import_status::in, item::in,
module_info::in, module_info::out, qual_info::in, qual_info::out,
- clauses_info::in, clauses_info::out, io::di, io::uo) is det.
+ clauses_info::in, clauses_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
produce_instance_method_clause(PredOrFunc, Context, Status, InstanceClause,
- !ModuleInfo, !QualInfo, !ClausesInfo, !IO) :-
+ !ModuleInfo, !QualInfo, !ClausesInfo, !Specs) :-
(
InstanceClause = item_clause(_Origin, CVarSet, PredOrFunc, PredName,
HeadTerms0, Body)
->
( illegal_state_var_func_result(PredOrFunc, HeadTerms0, StateVar) ->
- report_illegal_func_svar_result(Context, CVarSet, StateVar, !IO)
+ report_illegal_func_svar_result(Context, CVarSet, StateVar, !Specs)
;
HeadTerms = expand_bang_state_var_args(HeadTerms0),
PredArity = list.length(HeadTerms),
@@ -612,61 +607,58 @@
clauses_info_add_clause(ProcIds, CVarSet, TVarSet0, HeadTerms,
Body, Context, Status, PredOrFunc, Arity, GoalType, Goal,
VarSet, _TVarSet, !ClausesInfo, Warnings, !ModuleInfo,
- !QualInfo, !IO),
+ !QualInfo, !Specs),
SimpleCallId = simple_call_id(PredOrFunc, PredName, Arity),
% Warn about singleton variables.
- maybe_warn_singletons(VarSet, SimpleCallId, !.ModuleInfo, Goal,
- !IO),
+ warn_singletons(VarSet, SimpleCallId, !.ModuleInfo, Goal, !Specs),
% Warn about variables with overlapping scopes.
- maybe_warn_overlap(Warnings, VarSet, SimpleCallId, !IO)
+ warn_overlap(Warnings, VarSet, SimpleCallId, !Specs)
)
;
unexpected(this_file, "produce_clause: invalid instance item")
).
-:- pred pred_method_with_no_modes_error(pred_info::in, io::di, io::uo) is det.
+:- pred pred_method_with_no_modes_error(pred_info::in,
+ list(error_spec)::in, list(error_spec)::out) is det.
-pred_method_with_no_modes_error(PredInfo, !IO) :-
+pred_method_with_no_modes_error(PredInfo, !Specs) :-
pred_info_context(PredInfo, Context),
Module = pred_info_module(PredInfo),
Name = pred_info_name(PredInfo),
Arity = pred_info_orig_arity(PredInfo),
- Pieces = [words("Error: no mode declaration for type class method"),
- words("predicate"),
- sym_name_and_arity(qualified(Module, Name) / Arity), suffix(".")],
- write_error_pieces(Context, 0, Pieces, !IO),
- io.set_exit_status(1, !IO).
+ Pieces = [words("Error: no mode declaration"),
+ words("for type class method predicate"),
+ sym_name_and_arity(qualified(Module, Name) / Arity), suffix("."), nl],
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
+ !:Specs = [Spec | !.Specs].
:- pred undefined_type_class_error(sym_name::in, arity::in, prog_context::in,
- string::in, io::di, io::uo) is det.
+ string::in, list(error_spec)::in, list(error_spec)::out) is det.
-undefined_type_class_error(ClassName, Arity, Context, Description, !IO) :-
+undefined_type_class_error(ClassName, Arity, Context, Description, !Specs) :-
Pieces = [words("Error:"), words(Description), words("for"),
sym_name_and_arity(ClassName / Arity),
- words("without preceding typeclass declaration.")],
- write_error_pieces(Context, 0, Pieces, !IO),
- io.set_exit_status(1, !IO).
+ words("without preceding typeclass declaration."), nl],
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
+ !:Specs = [Spec | !.Specs].
:- pred missing_pred_or_func_method_error(sym_name::in, arity::in,
- pred_or_func::in, prog_context::in, module_info::in, module_info::out,
- io::di, io::uo) is det.
+ pred_or_func::in, prog_context::in,
+ list(error_spec)::in, list(error_spec)::out) is det.
-missing_pred_or_func_method_error(Name, Arity, PredOrFunc, Context,
- !ModuleInfo, !IO) :-
- NoPredOrFuncMsg = [
- words("Error: mode declaration for type class method"),
- sym_name_and_arity(Name / Arity),
- words("without corresponding"),
- p_or_f(PredOrFunc),
- words("method declaration.")
- ],
- write_error_pieces(Context, 0, NoPredOrFuncMsg, !IO),
- io.set_exit_status(1, !IO),
- module_info_incr_errors(!ModuleInfo).
+missing_pred_or_func_method_error(Name, Arity, PredOrFunc, Context, !Specs) :-
+ Pieces = [words("Error: mode declaration for type class method"),
+ sym_name_and_arity(Name / Arity), words("without corresponding"),
+ p_or_f(PredOrFunc), words("method declaration."), nl],
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
+ !:Specs = [Spec | !.Specs].
%-----------------------------------------------------------------------------%
Index: compiler/add_clause.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/add_clause.m,v
retrieving revision 1.32
diff -u -b -r1.32 add_clause.m
--- compiler/add_clause.m 7 Sep 2006 05:50:51 -0000 1.32
+++ compiler/add_clause.m 8 Sep 2006 16:37:41 -0000
@@ -16,9 +16,9 @@
:- import_module hlds.make_hlds.state_var.
:- import_module hlds.quantification.
:- import_module mdbcomp.prim_data.
+:- import_module parse_tree.error_util.
:- import_module parse_tree.prog_data.
-:- import_module io.
:- import_module list.
%-----------------------------------------------------------------------------%
@@ -26,7 +26,8 @@
:- pred module_add_clause(prog_varset::in, pred_or_func::in, sym_name::in,
list(prog_term)::in, goal::in, import_status::in, prog_context::in,
goal_type::in, module_info::in, module_info::out,
- qual_info::in, qual_info::out, io::di, io::uo) is det.
+ qual_info::in, qual_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
:- pred clauses_info_add_clause(list(proc_id)::in,
prog_varset::in, tvarset::in, list(prog_term)::in, goal::in,
@@ -34,7 +35,7 @@
goal_type::in, hlds_goal::out, prog_varset::out, tvarset::out,
clauses_info::in, clauses_info::out, list(quant_warning)::out,
module_info::in, module_info::out, qual_info::in, qual_info::out,
- io::di, io::uo) is det.
+ list(error_spec)::in, list(error_spec)::out) is det.
% Convert goals from the prog_data `goal' structure into the HLDS
% `hlds_goal' structure. At the same time, convert it to super-homogeneous
@@ -46,11 +47,8 @@
:- pred transform_goal(goal::in, prog_substitution::in, hlds_goal::out,
int::out, prog_varset::in, prog_varset::out,
module_info::in, module_info::out, qual_info::in, qual_info::out,
- svar_info::in, svar_info::out, io::di, io::uo) is det.
-
-:- pred qualify_lambda_mode_list_if_not_opt_imported(
- list(mer_mode)::in, list(mer_mode)::out, prog_context::in,
- qual_info::in, qual_info::out, io::di, io::uo) is det.
+ svar_info::in, svar_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -58,8 +56,10 @@
:- implementation.
:- import_module check_hlds.clause_to_proc.
+:- import_module check_hlds.mode_errors.
:- import_module hlds.goal_util.
:- import_module hlds.hlds_data.
+:- import_module hlds.hlds_error_util.
:- import_module hlds.hlds_out.
:- import_module hlds.hlds_pred.
:- import_module hlds.hlds_rtti.
@@ -73,7 +73,6 @@
:- import_module libs.compiler_util.
:- import_module libs.globals.
:- import_module libs.options.
-:- import_module parse_tree.error_util.
:- import_module parse_tree.mercury_to_mercury.
:- import_module parse_tree.module_qual.
:- import_module parse_tree.prog_data.
@@ -95,7 +94,7 @@
%-----------------------------------------------------------------------------%
module_add_clause(ClauseVarSet, PredOrFunc, PredName, Args0, Body, Status,
- Context, GoalType, !ModuleInfo, !QualInfo, !IO) :-
+ Context, GoalType, !ModuleInfo, !QualInfo, !Specs) :-
( illegal_state_var_func_result(PredOrFunc, Args0, SVar) ->
IllegalSVarResult = yes(SVar)
;
@@ -105,8 +104,8 @@
Args = expand_bang_state_var_args(Args0),
% Lookup the pred declaration in the predicate table.
- % (If it's not there, call maybe_undefined_pred_error
- % and insert an implicit declaration for the predicate.)
+ % (If it's not there, call maybe_undefined_pred_error and insert
+ % an implicit declaration for the predicate.)
module_info_get_name(!.ModuleInfo, ModuleName),
list.length(Args, Arity0),
Arity = Arity0 + ArityAdjustment,
@@ -141,21 +140,24 @@
;
preds_add_implicit_report_error(ModuleName, PredOrFunc,
PredName, Arity, Status, no, Context,
- origin_user(PredName), "clause", PredId, !ModuleInfo, !IO)
+ origin_user(PredName), "clause", PredId, !ModuleInfo,
+ !Specs)
)
),
% Lookup the pred_info for this pred, add the clause to the
- % clauses_info in the pred_info, if there are no modes
- % add an `infer_modes' marker, and then save the pred_info.
+ % clauses_info in the pred_info, if there are no modes add an
+ % `infer_modes' marker, and then save the pred_info.
module_info_get_predicate_table(!.ModuleInfo, !:PredicateTable),
predicate_table_get_preds(!.PredicateTable, Preds0),
map.lookup(Preds0, PredId, !:PredInfo),
+ trace [io(!IO)] (
globals.io_lookup_bool_option(very_verbose, VeryVerbose, !IO),
(
VeryVerbose = yes,
pred_info_clauses_info(!.PredInfo, MsgClauses),
- NumClauses = num_clauses_in_clauses_rep(MsgClauses ^ clauses_rep),
+ NumClauses =
+ num_clauses_in_clauses_rep(MsgClauses ^ clauses_rep),
io.format("%% Processing clause %d for ", [i(NumClauses + 1)],
!IO),
write_pred_or_func(PredOrFunc, !IO),
@@ -167,10 +169,11 @@
io.write_string("'...\n", !IO)
;
VeryVerbose = no
+ )
),
- % opt_imported preds are initially tagged as imported and are
- % tagged as opt_imported only if/when we see a clause for them
+ % Opt_imported preds are initially tagged as imported, and are tagged
+ % as opt_imported only if/when we see a clause for them.
( Status = status_opt_imported ->
pred_info_set_import_status(status_opt_imported, !PredInfo),
pred_info_get_markers(!.PredInfo, InitMarkers0),
@@ -184,12 +187,10 @@
IllegalSVarResult = yes(StateVar)
->
report_illegal_func_svar_result(Context, ClauseVarSet, StateVar,
- !IO)
+ !Specs)
;
- %
- % User-supplied clauses for field access functions are
- % not allowed -- the clauses are always generated by the
- % compiler.
+ % User-supplied clauses for field access functions are not allowed
+ % -- the clauses are always generated by the compiler.
%
PredOrFunc = function,
adjust_func_arity(function, FuncArity, Arity),
@@ -200,50 +201,39 @@
% function clauses in `.opt' files.
Status \= status_opt_imported
->
- module_info_incr_errors(!ModuleInfo),
CallId = simple_call_id(PredOrFunc, PredName, Arity),
- ErrorPieces0 = [
- words("Error: clause for automatically generated"),
- words("field access"), simple_call(CallId), suffix("."), nl
- ],
- globals.io_lookup_bool_option(verbose_errors, Verbose, !IO),
- (
- Verbose = yes,
- ErrorPieces1 = [
- words("Clauses for field access functions"),
- words("are automatically generated by the"),
- words("compiler. To supply your own"),
- words("definition for a field access"),
- words("function, for example to check"),
- words("the input to a field update,"),
- words("give the field of the constructor a"),
- words("different name.")
- ],
- list.append(ErrorPieces0, ErrorPieces1, ErrorPieces)
+ MainPieces = [words("Error: clause for automatically generated"),
+ words("field access"), simple_call(CallId), suffix("."), nl],
+ VerbosePieces = [words("Clauses for field access functions"),
+ words("are automatically generated by the compiler."),
+ words("To supply your own definition for a field access"),
+ words("function, for example to check the input"),
+ words("to a field update, give the field"),
+ words("of the constructor a different name.")],
+ Msg = simple_msg(Context,
+ [always(MainPieces), verbose_only(VerbosePieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
+ !:Specs = [Spec | !.Specs]
;
- Verbose = no,
- globals.io_set_extra_error_info(yes, !IO),
- ErrorPieces = ErrorPieces0
- ),
- write_error_pieces(Context, 0, ErrorPieces, !IO)
- ;
- % Ignore clauses for builtins. This makes bootstrapping
- % easier when redefining builtins to use normal Mercury code.
pred_info_is_builtin(!.PredInfo)
->
- report_warning(Context, 0,
- [words("Warning: clause for builtin.")], !IO)
+ % When bootstrapping a change that redefines a builtin as
+ % normal Mercury code, you may need to disable this action.
+ Msg = simple_msg(Context,
+ [always([words("Error: clause for builtin.")])]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
+ !:Specs = [Spec | !.Specs]
;
pred_info_clauses_info(!.PredInfo, Clauses0),
pred_info_get_typevarset(!.PredInfo, TVarSet0),
maybe_add_default_func_mode(!PredInfo, _),
select_applicable_modes(Args, ClauseVarSet, Status, Context,
PredId, !.PredInfo, ArgTerms, ProcIdsForThisClause,
- !ModuleInfo, !QualInfo, !IO),
+ !ModuleInfo, !QualInfo, !Specs),
clauses_info_add_clause(ProcIdsForThisClause, ClauseVarSet,
TVarSet0, ArgTerms, Body, Context, Status, PredOrFunc, Arity,
GoalType, Goal, VarSet, TVarSet, Clauses0, Clauses, Warnings,
- !ModuleInfo, !QualInfo, !IO),
+ !ModuleInfo, !QualInfo, !Specs),
pred_info_set_clauses_info(Clauses, !PredInfo),
( GoalType = goal_type_promise(PromiseType) ->
pred_info_set_goal_type(goal_type_promise(PromiseType),
@@ -277,10 +267,10 @@
;
% Warn about singleton variables.
SimpleCallId = simple_call_id(PredOrFunc, PredName, Arity),
- maybe_warn_singletons(VarSet, SimpleCallId, !.ModuleInfo,
- Goal, !IO),
+ warn_singletons(VarSet, SimpleCallId, !.ModuleInfo, Goal,
+ !Specs),
% Warn about variables with overlapping scopes.
- maybe_warn_overlap(Warnings, VarSet, SimpleCallId, !IO)
+ warn_overlap(Warnings, VarSet, SimpleCallId, !Specs)
)
)
).
@@ -292,15 +282,14 @@
import_status::in, prog_context::in, pred_id::in, pred_info::in,
list(prog_term)::out, list(proc_id)::out,
module_info::in, module_info::out, qual_info::in, qual_info::out,
- io::di, io::uo) is det.
+ list(error_spec)::in, list(error_spec)::out) is det.
select_applicable_modes(Args0, VarSet, Status, Context, PredId, PredInfo,
- Args, ProcIds, !ModuleInfo, !QualInfo, !IO) :-
+ Args, ProcIds, !ModuleInfo, !QualInfo, !Specs) :-
get_mode_annotations(Args0, Args, empty, ModeAnnotations),
(
ModeAnnotations = modes(ModeList0),
- %
% The user specified some mode annotations on this clause.
% First module-qualify the mode annotations. The annotations
% on clauses from `.opt' files will already be fully module
@@ -311,13 +300,11 @@
;
qual_info_get_mq_info(!.QualInfo, MQInfo0),
qualify_clause_mode_list(ModeList0, ModeList, Context,
- MQInfo0, MQInfo, !IO),
+ MQInfo0, MQInfo, !Specs),
qual_info_set_mq_info(MQInfo, !QualInfo)
),
- %
% Now find the procedure which matches these mode annotations.
- %
pred_info_get_procedures(PredInfo, Procs),
map.to_assoc_list(Procs, ExistingProcs),
(
@@ -326,9 +313,8 @@
->
ProcIds = [ProcId]
;
- module_info_incr_errors(!ModuleInfo),
undeclared_mode_error(ModeList, VarSet, PredId, PredInfo,
- !.ModuleInfo, Context, !IO),
+ !.ModuleInfo, Context, !Specs),
% apply the clause to all modes
% XXX would it be better to apply it to none?
ProcIds = pred_info_all_procids(PredInfo)
@@ -357,20 +343,76 @@
)
;
ModeAnnotations = mixed,
- module_info_incr_errors(!ModuleInfo),
- io.set_exit_status(1, !IO),
PredIdStr = pred_id_to_string(!.ModuleInfo, PredId),
- ModeAnnotationErrMsg = [
- words("In clause for"), fixed(PredIdStr), suffix(":"), nl,
+ Pieces = [words("In clause for"), fixed(PredIdStr), suffix(":"), nl,
words("syntax error: some but not all arguments"),
- words("have mode annotations.")
- ],
- write_error_pieces(Context, 0, ModeAnnotationErrMsg, !IO),
- % apply the clause to all modes
- % XXX would it be better to apply it to none?
+ words("have mode annotations."), nl],
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
+ !:Specs = [Spec | !.Specs],
+
+ % Apply the clause to all modes.
+ % XXX Would it be better to apply it to none?
ProcIds = pred_info_all_procids(PredInfo)
).
+:- pred undeclared_mode_error(list(mer_mode)::in, prog_varset::in,
+ pred_id::in, pred_info::in, module_info::in, prog_context::in,
+ list(error_spec)::in, list(error_spec)::out) is det.
+
+undeclared_mode_error(ModeList, VarSet, PredId, PredInfo, ModuleInfo, Context,
+ !Specs) :-
+ PredIdPieces = describe_one_pred_name(ModuleInfo,
+ should_not_module_qualify, PredId),
+ strip_builtin_qualifiers_from_mode_list(ModeList, StrippedModeList),
+ PredOrFunc = pred_info_is_pred_or_func(PredInfo),
+ Name = pred_info_name(PredInfo),
+ MaybeDet = no,
+ SubDeclStr = mercury_mode_subdecl_to_string(PredOrFunc,
+ varset.coerce(VarSet), unqualified(Name), StrippedModeList,
+ MaybeDet, Context),
+
+ MainPieces = [words("In clause for")] ++ PredIdPieces ++ [suffix(":"), nl,
+ words("error: mode annotation specifies undeclared mode"),
+ quote(SubDeclStr), suffix("."), nl],
+ ProcIds = pred_info_all_procids(PredInfo),
+ (
+ ProcIds = [],
+ VerbosePieces = [words("(There are no declared modes for this"),
+ p_or_f(PredOrFunc), suffix(".)"), nl]
+ ;
+ ProcIds = [ProcIdsHead | ProcIdsTail],
+ (
+ ProcIdsTail = [],
+ VerbosePieces = [words("The declared mode for this"),
+ p_or_f(PredOrFunc), words("is:"),
+ nl_indent_delta(1)] ++
+ mode_decl_for_pred_info_to_pieces(PredInfo, ProcIdsHead) ++
+ [nl_indent_delta(-1)]
+ ;
+ ProcIdsTail = [_ | _],
+ VerbosePieces = [words("The declared modes for this"),
+ p_or_f(PredOrFunc), words("are the following:"),
+ nl_indent_delta(1)] ++
+ component_list_to_line_pieces(
+ list.map(mode_decl_for_pred_info_to_pieces(PredInfo),
+ ProcIds),
+ []) ++
+ [nl_indent_delta(-1)]
+ )
+ ),
+ Msg = simple_msg(Context,
+ [always(MainPieces), verbose_only(VerbosePieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
+ !:Specs = [Spec | !.Specs].
+
+:- func mode_decl_for_pred_info_to_pieces(pred_info, proc_id)
+ = list(format_component).
+
+mode_decl_for_pred_info_to_pieces(PredInfo, ProcId) =
+ [words(":- mode"), words(mode_decl_to_string(ProcId, PredInfo)),
+ suffix(".")].
+
% Clauses can have mode annotations on them, to indicate that the
% clause should only be used for particular modes of a predicate.
% This type specifies the mode annotations on a clause.
@@ -427,7 +469,7 @@
clauses_info_add_clause(ModeIds0, CVarSet, TVarSet0, Args, Body, Context,
Status, PredOrFunc, Arity, GoalType, Goal, VarSet, TVarSet,
- !ClausesInfo, Warnings, !ModuleInfo, !QualInfo, !IO) :-
+ !ClausesInfo, Warnings, !ModuleInfo, !QualInfo, !Specs) :-
!.ClausesInfo = clauses_info(VarSet0, ExplicitVarTypes0,
TVarNameMap0, InferredVarTypes, HeadVars, ClausesRep0,
RttiVarMaps, HasForeignClauses),
@@ -451,7 +493,7 @@
varset.merge_subst(VarSet0, CVarSet, VarSet1, Subst),
add_clause_transform(Subst, HeadVars, Args, Body, Context, PredOrFunc,
Arity, GoalType, Goal0, VarSet1, VarSet, Warnings, !ModuleInfo,
- !QualInfo, !IO),
+ !QualInfo, !Specs),
qual_info_get_tvarset(!.QualInfo, TVarSet),
qual_info_get_found_syntax_error(!.QualInfo, FoundError),
qual_info_set_found_syntax_error(no, !QualInfo),
@@ -502,15 +544,15 @@
arity::in, goal_type::in, hlds_goal::out,
prog_varset::in, prog_varset::out, list(quant_warning)::out,
module_info::in, module_info::out, qual_info::in, qual_info::out,
- io::di, io::uo) is det.
+ list(error_spec)::in, list(error_spec)::out) is det.
add_clause_transform(Subst, HeadVars, Args0, ParseBody, Context, PredOrFunc,
Arity, GoalType, Goal, !VarSet, Warnings, !ModuleInfo,
- !QualInfo, !IO) :-
+ !QualInfo, !Specs) :-
some [!SInfo] (
prepare_for_head(!:SInfo),
term.apply_substitution_to_list(Args0, Subst, Args1),
- substitute_state_var_mappings(Args1, Args, !VarSet, !SInfo, !IO),
+ substitute_state_var_mappings(Args1, Args, !VarSet, !SInfo, !Specs),
HeadGoal0 = true_goal,
( GoalType = goal_type_promise(_) ->
HeadGoal = HeadGoal0
@@ -518,13 +560,13 @@
ArgContext = ac_head(PredOrFunc, Arity),
insert_arg_unifications(HeadVars, Args, Context, ArgContext,
HeadGoal0, HeadGoal1, _, !VarSet, !ModuleInfo, !QualInfo,
- !SInfo, !IO),
+ !SInfo, !Specs),
attach_features_to_all_goals([feature_from_head],
HeadGoal1, HeadGoal)
),
prepare_for_body(FinalSVarMap, !VarSet, !SInfo),
transform_goal(ParseBody, Subst, BodyGoal, _, !VarSet, !ModuleInfo,
- !QualInfo, !SInfo, !IO),
+ !QualInfo, !SInfo, !Specs),
finish_goals(Context, FinalSVarMap, [HeadGoal, BodyGoal], Goal0,
!.SInfo),
qual_info_get_var_types(!.QualInfo, VarTypes0),
@@ -541,95 +583,96 @@
%-----------------------------------------------------------------------------%
transform_goal(Goal0 - Context, Subst, Goal - GoalInfo, NumAdded, !VarSet,
- !ModuleInfo, !QualInfo, !SInfo, !IO) :-
+ !ModuleInfo, !QualInfo, !SInfo, !Specs) :-
transform_goal_2(Goal0, Context, Subst, Goal - GoalInfo1, NumAdded,
- !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
+ !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs),
goal_info_set_context(Context, GoalInfo1, GoalInfo).
:- pred transform_goal_2(goal_expr::in, prog_context::in,
prog_substitution::in, hlds_goal::out, num_added_goals::out,
prog_varset::in, prog_varset::out,
module_info::in, module_info::out, qual_info::in, qual_info::out,
- svar_info::in, svar_info::out, io::di, io::uo) is det.
+ svar_info::in, svar_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
transform_goal_2(fail_expr, _, _, disj([]) - GoalInfo, 0,
- !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO) :-
+ !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs) :-
goal_info_init(GoalInfo),
prepare_for_next_conjunct(set.init, !VarSet, !SInfo).
transform_goal_2(true_expr, _, _, conj(plain_conj, []) - GoalInfo, 0,
- !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO) :-
+ !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs) :-
goal_info_init(GoalInfo),
prepare_for_next_conjunct(set.init, !VarSet, !SInfo).
transform_goal_2(all_expr(Vars0, Goal0), Context, Subst, Goal, NumAdded,
- !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO) :-
+ !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs) :-
% Convert `all [Vars] Goal' into `not some [Vars] not Goal'.
TransformedGoal = not_expr(some_expr(Vars0, not_expr(Goal0) - Context)
- Context),
transform_goal_2(TransformedGoal, Context, Subst, Goal, NumAdded,
- !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO).
+ !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs).
transform_goal_2(all_state_vars_expr(StateVars, Goal0), Context, Subst,
- Goal, NumAdded, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO) :-
+ Goal, NumAdded, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs) :-
transform_goal_2(
not_expr(some_state_vars_expr(StateVars,
not_expr(Goal0) - Context) - Context),
Context, Subst, Goal, NumAdded, !VarSet, !ModuleInfo, !QualInfo,
- !SInfo, !IO).
+ !SInfo, !Specs).
transform_goal_2(some_expr(Vars0, Goal0), _, Subst,
scope(exist_quant(Vars), Goal) - GoalInfo, NumAdded,
- !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO) :-
+ !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs) :-
substitute_vars(Vars0, Subst, Vars),
transform_goal(Goal0, Subst, Goal, NumAdded, !VarSet, !ModuleInfo,
- !QualInfo, !SInfo, !IO),
+ !QualInfo, !SInfo, !Specs),
goal_info_init(GoalInfo).
transform_goal_2(some_state_vars_expr(StateVars0, Goal0), _, Subst,
scope(exist_quant(Vars), Goal) - GoalInfo, NumAdded,
- !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO) :-
+ !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs) :-
BeforeSInfo = !.SInfo,
substitute_vars(StateVars0, Subst, StateVars),
prepare_for_local_state_vars(StateVars, !VarSet, !SInfo),
transform_goal(Goal0, Subst, Goal, NumAdded, !VarSet, !ModuleInfo,
- !QualInfo, !SInfo, !IO),
+ !QualInfo, !SInfo, !Specs),
finish_local_state_vars(StateVars, Vars, BeforeSInfo, !SInfo),
goal_info_init(GoalInfo).
transform_goal_2(promise_purity_expr(Implicit, Purity, Goal0), _, Subst,
scope(promise_purity(Implicit, Purity), Goal) - GoalInfo, NumAdded,
- !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO) :-
+ !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs) :-
transform_goal(Goal0, Subst, Goal, NumAdded, !VarSet, !ModuleInfo,
- !QualInfo, !SInfo, !IO),
+ !QualInfo, !SInfo, !Specs),
goal_info_init(GoalInfo).
transform_goal_2(
promise_equivalent_solutions_expr(Vars0, DotSVars0, ColonSVars0,
Goal0),
Context, Subst,
scope(promise_solutions(Vars, equivalent_solutions), Goal) - GoalInfo,
- NumAdded, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO) :-
+ NumAdded, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs) :-
transform_promise_eqv_goal(Vars0, DotSVars0, ColonSVars0, Subst, Context,
Vars, Goal0, Goal, GoalInfo, NumAdded, !VarSet, !ModuleInfo,
- !QualInfo, !SInfo, !IO).
+ !QualInfo, !SInfo, !Specs).
transform_goal_2(
promise_equivalent_solution_sets_expr(Vars0, DotSVars0, ColonSVars0,
Goal0),
Context, Subst,
scope(promise_solutions(Vars, equivalent_solution_sets), Goal)
- GoalInfo,
- NumAdded, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO) :-
+ NumAdded, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs) :-
transform_promise_eqv_goal(Vars0, DotSVars0, ColonSVars0, Subst, Context,
Vars, Goal0, Goal, GoalInfo, NumAdded, !VarSet, !ModuleInfo,
- !QualInfo, !SInfo, !IO).
+ !QualInfo, !SInfo, !Specs).
transform_goal_2(
promise_equivalent_solution_arbitrary_expr(Vars0,
DotSVars0, ColonSVars0, Goal0),
Context, Subst,
scope(promise_solutions(Vars, equivalent_solution_sets_arbitrary),
Goal) - GoalInfo,
- NumAdded, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO) :-
+ NumAdded, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs) :-
transform_promise_eqv_goal(Vars0, DotSVars0, ColonSVars0, Subst, Context,
Vars, Goal0, Goal, GoalInfo, NumAdded, !VarSet, !ModuleInfo,
- !QualInfo, !SInfo, !IO).
+ !QualInfo, !SInfo, !Specs).
transform_goal_2(
trace_expr(MaybeCompileTime, MaybeRunTime, MaybeIO, Mutables, Goal0),
Context, Subst, scope(Reason, Goal) - GoalInfo, NumAdded,
- !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO) :-
+ !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs) :-
list.map4(extract_trace_mutable_var(Context, !.VarSet), Mutables,
MutableHLDSs, MutableStateVars, MutableGetGoals, MutableSetGoals),
(
@@ -654,73 +697,73 @@
substitute_vars(StateVars0, Subst, StateVars),
prepare_for_local_state_vars(StateVars, !VarSet, !SInfo),
transform_goal(Goal1, Subst, Goal, NumAdded1, !VarSet, !ModuleInfo,
- !QualInfo, !SInfo, !IO),
+ !QualInfo, !SInfo, !Specs),
NumAdded = list.length(GetGoals) + NumAdded1 + list.length(SetGoals),
finish_local_state_vars(StateVars, _Vars, BeforeSInfo, !SInfo),
goal_info_init(GoalInfo).
transform_goal_2(if_then_else_expr(Vars0, StateVars0, Cond0, Then0, Else0),
Context, Subst, if_then_else(Vars, Cond, Then, Else) - GoalInfo,
- NumAdded, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO) :-
+ NumAdded, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs) :-
BeforeSInfo = !.SInfo,
substitute_vars(Vars0, Subst, Vars),
substitute_vars(StateVars0, Subst, StateVars),
prepare_for_if_then_else_goal(StateVars, !VarSet, !SInfo),
transform_goal(Cond0, Subst, Cond, CondAdded, !VarSet, !ModuleInfo,
- !QualInfo, !SInfo, !IO),
+ !QualInfo, !SInfo, !Specs),
finish_if_then_else_goal_condition(StateVars,
BeforeSInfo, !.SInfo, AfterCondSInfo, !:SInfo),
transform_goal(Then0, Subst, Then1, ThenAdded, !VarSet, !ModuleInfo,
- !QualInfo, !SInfo, !IO),
+ !QualInfo, !SInfo, !Specs),
finish_if_then_else_goal_then_goal(StateVars, BeforeSInfo, !SInfo),
AfterThenSInfo = !.SInfo,
transform_goal(Else0, Subst, Else1, ElseAdded, !VarSet, !ModuleInfo,
- !QualInfo, BeforeSInfo, !:SInfo, !IO),
+ !QualInfo, BeforeSInfo, !:SInfo, !Specs),
NumAdded = CondAdded + ThenAdded + ElseAdded,
goal_info_init(Context, GoalInfo),
finish_if_then_else(Context, Then1, Then, Else1, Else,
BeforeSInfo, AfterCondSInfo, AfterThenSInfo, !SInfo, !VarSet).
transform_goal_2(not_expr(SubGoal0), _, Subst, negation(SubGoal) - GoalInfo,
- NumAdded, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO) :-
+ NumAdded, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs) :-
BeforeSInfo = !.SInfo,
transform_goal(SubGoal0, Subst, SubGoal, NumAdded, !VarSet, !ModuleInfo,
- !QualInfo, !SInfo, !IO),
+ !QualInfo, !SInfo, !Specs),
goal_info_init(GoalInfo),
finish_negation(BeforeSInfo, !SInfo).
transform_goal_2(conj_expr(A0, B0), _, Subst, Goal, NumAdded, !VarSet,
- !ModuleInfo, !QualInfo, !SInfo, !IO) :-
+ !ModuleInfo, !QualInfo, !SInfo, !Specs) :-
get_rev_conj(A0, Subst, [], R0, 0, NumAddedA,
- !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
+ !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs),
get_rev_conj(B0, Subst, R0, R, NumAddedA, NumAdded,
- !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
+ !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs),
L = list.reverse(R),
goal_info_init(GoalInfo),
conj_list_to_goal(L, GoalInfo, Goal).
transform_goal_2(par_conj_expr(A0, B0), _, Subst, Goal, NumAdded, !VarSet,
- !ModuleInfo, !QualInfo, !SInfo, !IO) :-
+ !ModuleInfo, !QualInfo, !SInfo, !Specs) :-
get_rev_par_conj(A0, Subst, [], R0, 0, NumAddedA,
- !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
+ !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs),
get_rev_par_conj(B0, Subst, R0, R, NumAddedA, NumAdded,
- !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
+ !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs),
L = list.reverse(R),
goal_info_init(GoalInfo),
par_conj_list_to_goal(L, GoalInfo, Goal).
transform_goal_2(disj_expr(A0, B0), Context, Subst, Goal, NumAdded, !VarSet,
- !ModuleInfo, !QualInfo, !SInfo, !IO) :-
+ !ModuleInfo, !QualInfo, !SInfo, !Specs) :-
get_disj(B0, Subst, [], L0, 0, NumAddedB,
- !VarSet, !ModuleInfo, !QualInfo, !.SInfo, !IO),
+ !VarSet, !ModuleInfo, !QualInfo, !.SInfo, !Specs),
get_disj(A0, Subst, L0, L1, NumAddedB, NumAdded,
- !VarSet, !ModuleInfo, !QualInfo, !.SInfo, !IO),
+ !VarSet, !ModuleInfo, !QualInfo, !.SInfo, !Specs),
finish_disjunction(Context, !.VarSet, L1, L, !:SInfo),
goal_info_init(Context, GoalInfo),
disj_list_to_goal(L, GoalInfo, Goal).
transform_goal_2(implies_expr(P, Q), Context, Subst, Goal, NumAdded, !VarSet,
- !ModuleInfo, !QualInfo, !SInfo, !IO) :-
+ !ModuleInfo, !QualInfo, !SInfo, !Specs) :-
% `P => Q' is defined as `not (P, not Q)'
TransformedGoal = not_expr(conj_expr(P, not_expr(Q) - Context) - Context),
transform_goal_2(TransformedGoal, Context, Subst, Goal, NumAdded, !VarSet,
- !ModuleInfo, !QualInfo, !SInfo, !IO).
+ !ModuleInfo, !QualInfo, !SInfo, !Specs).
transform_goal_2(equivalent_expr(P0, Q0), _, Subst, Goal, NumAdded, !VarSet,
- !ModuleInfo, !QualInfo, !SInfo, !IO) :-
+ !ModuleInfo, !QualInfo, !SInfo, !Specs) :-
%
% `P <=> Q' is defined as `(P => Q), (Q => P)',
% but that transformation must not be done until
@@ -731,19 +774,18 @@
BeforeSInfo = !.SInfo,
goal_info_init(GoalInfo),
transform_goal(P0, Subst, P, NumAddedP, !VarSet, !ModuleInfo, !QualInfo,
- !SInfo, !IO),
+ !SInfo, !Specs),
transform_goal(Q0, Subst, Q, NumAddedQ, !VarSet, !ModuleInfo, !QualInfo,
- !SInfo, !IO),
+ !SInfo, !Specs),
NumAdded = NumAddedP + NumAddedQ,
Goal = shorthand(bi_implication(P, Q)) - GoalInfo,
finish_equivalence(BeforeSInfo, !SInfo).
-transform_goal_2(event_expr(EventName, Args0), Context, Subst,
- Goal,
- NumAdded, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO) :-
+transform_goal_2(event_expr(EventName, Args0), Context, Subst, Goal,
+ NumAdded, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs) :-
Args1 = expand_bang_state_var_args(Args0),
prepare_for_call(!SInfo),
term.apply_substitution_to_list(Args1, Subst, Args),
- make_fresh_arg_vars(Args, HeadVars, !VarSet, !SInfo, !IO),
+ make_fresh_arg_vars(Args, HeadVars, !VarSet, !SInfo, !Specs),
list.length(HeadVars, Arity),
list.duplicate(Arity, in_mode, Modes),
goal_info_init(Context, GoalInfo),
@@ -751,10 +793,11 @@
Goal0 = generic_call(Details, HeadVars, Modes, detism_det) - GoalInfo,
CallId = generic_call_id(gcid_event_call(EventName)),
insert_arg_unifications(HeadVars, Args, Context, ac_call(CallId),
- Goal0, Goal, NumAdded, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
+ Goal0, Goal, NumAdded, !VarSet, !ModuleInfo, !QualInfo,
+ !SInfo, !Specs),
finish_call(!VarSet, !SInfo).
transform_goal_2(call_expr(Name, Args0, Purity), Context, Subst, Goal,
- NumAdded, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO) :-
+ NumAdded, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs) :-
Args1 = expand_bang_state_var_args(Args0),
(
Name = unqualified("\\="),
@@ -764,7 +807,7 @@
% `LHS \= RHS' is defined as `not (LHS = RHS)'
transform_goal_2(not_expr(unify_expr(LHS, RHS, Purity) - Context),
Context, Subst, Goal, NumAdded, !VarSet, !ModuleInfo, !QualInfo,
- !SInfo, !IO),
+ !SInfo, !Specs),
finish_call(!VarSet, !SInfo)
;
% check for a DCG field access goal:
@@ -778,12 +821,12 @@
prepare_for_call(!SInfo),
term.apply_substitution_to_list(Args1, Subst, Args2),
transform_dcg_record_syntax(Operator, Args2, Context, Goal, NumAdded,
- !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
+ !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs),
finish_call(!VarSet, !SInfo)
;
prepare_for_call(!SInfo),
term.apply_substitution_to_list(Args1, Subst, Args),
- make_fresh_arg_vars(Args, HeadVars, !VarSet, !SInfo, !IO),
+ make_fresh_arg_vars(Args, HeadVars, !VarSet, !SInfo, !Specs),
list.length(Args, Arity),
(
% Check for a higher-order call,
@@ -818,19 +861,19 @@
record_called_pred_or_func(predicate, Name, Arity, !QualInfo),
insert_arg_unifications(HeadVars, Args, Context, ac_call(CallId),
Goal0, Goal, NumAdded, !VarSet, !ModuleInfo, !QualInfo,
- !SInfo, !IO),
+ !SInfo, !Specs),
finish_call(!VarSet, !SInfo)
).
transform_goal_2(unify_expr(A0, B0, Purity), Context, Subst, Goal,
- NumAdded, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO) :-
+ NumAdded, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs) :-
% It is an error for the left or right hand side of a
% unification to be !X (it may be !.X or !:X, however).
( A0 = functor(atom("!"), [variable(StateVarA)], _) ->
- report_svar_unify_error(Context, !.VarSet, StateVarA, !IO),
+ report_svar_unify_error(Context, !.VarSet, StateVarA, !Specs),
Goal = true_goal,
NumAdded = 0
; B0 = functor(atom("!"), [variable(StateVarB)], _) ->
- report_svar_unify_error(Context, !.VarSet, StateVarB, !IO),
+ report_svar_unify_error(Context, !.VarSet, StateVarB, !Specs),
Goal = true_goal,
NumAdded = 0
;
@@ -838,7 +881,7 @@
term.apply_substitution(A0, Subst, A),
term.apply_substitution(B0, Subst, B),
unravel_unification(A, B, Context, umc_explicit, [], Purity, Goal,
- NumAdded, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
+ NumAdded, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs),
finish_call(!VarSet, !SInfo)
).
@@ -878,52 +921,57 @@
goal::in, hlds_goal::out, hlds_goal_info::out, int::out,
prog_varset::in, prog_varset::out, module_info::in, module_info::out,
qual_info::in, qual_info::out, svar_info::in, svar_info::out,
- io::di, io::uo) is det.
+ list(error_spec)::in, list(error_spec)::out) is det.
transform_promise_eqv_goal(Vars0, DotSVars0, ColonSVars0, Subst, Context, Vars,
Goal0, Goal, GoalInfo, NumAdded, !VarSet, !ModuleInfo, !QualInfo,
- !SInfo, !IO) :-
+ !SInfo, !Specs) :-
substitute_vars(Vars0, Subst, Vars1),
substitute_vars(DotSVars0, Subst, DotSVars1),
- convert_dot_state_vars(Context, DotSVars1, DotSVars, !VarSet, !SInfo, !IO),
+ convert_dot_state_vars(Context, DotSVars1, DotSVars, !VarSet,
+ !SInfo, !Specs),
transform_goal(Goal0, Subst, Goal, NumAdded, !VarSet, !ModuleInfo,
- !QualInfo, !SInfo, !IO),
+ !QualInfo, !SInfo, !Specs),
goal_info_init(GoalInfo),
substitute_vars(ColonSVars0, Subst, ColonSVars1),
convert_dot_state_vars(Context, ColonSVars1, ColonSVars, !VarSet,
- !SInfo, !IO),
+ !SInfo, !Specs),
Vars = Vars1 ++ DotSVars ++ ColonSVars.
:- pred convert_dot_state_vars(prog_context::in, prog_vars::in, prog_vars::out,
prog_varset::in, prog_varset::out, svar_info::in, svar_info::out,
- io::di, io::uo) is det.
+ list(error_spec)::in, list(error_spec)::out) is det.
-convert_dot_state_vars(_Context, [], [], !VarSet, !SInfo, !IO).
+convert_dot_state_vars(_Context, [], [], !VarSet, !SInfo, !Specs).
convert_dot_state_vars(Context, [Dot0 | Dots0], [Dot | Dots],
- !VarSet, !SInfo, !IO) :-
- dot(Context, Dot0, Dot, !VarSet, !SInfo, !IO),
- convert_dot_state_vars(Context, Dots0, Dots, !VarSet, !SInfo, !IO).
+ !VarSet, !SInfo, !Specs) :-
+ dot(Context, Dot0, Dot, !VarSet, !SInfo, !Specs),
+ convert_dot_state_vars(Context, Dots0, Dots, !VarSet, !SInfo, !Specs).
:- pred convert_colon_state_vars(prog_context::in,
prog_vars::in, prog_vars::out, prog_varset::in, prog_varset::out,
- svar_info::in, svar_info::out, io::di, io::uo) is det.
+ svar_info::in, svar_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
-convert_colon_state_vars(_Context, [], [], !VarSet, !SInfo, !IO).
+convert_colon_state_vars(_Context, [], [], !VarSet, !SInfo, !Specs).
convert_colon_state_vars(Context, [Colon0 | Colons0], [Colon | Colons],
- !VarSet, !SInfo, !IO) :-
- colon(Context, Colon0, Colon, !VarSet, !SInfo, !IO),
- convert_colon_state_vars(Context, Colons0, Colons, !VarSet, !SInfo, !IO).
+ !VarSet, !SInfo, !Specs) :-
+ colon(Context, Colon0, Colon, !VarSet, !SInfo, !Specs),
+ convert_colon_state_vars(Context, Colons0, Colons, !VarSet,
+ !SInfo, !Specs).
:- pred report_svar_unify_error(prog_context::in, prog_varset::in, svar::in,
- io::di, io::uo) is det.
+ list(error_spec)::in, list(error_spec)::out) is det.
-report_svar_unify_error(Context, VarSet, StateVar, !IO) :-
+report_svar_unify_error(Context, VarSet, StateVar, !Specs) :-
Name = varset.lookup_name(VarSet, StateVar),
Pieces = [nl, words("Error:"), fixed("!" ++ Name),
words("cannot appear as a unification argument."), nl,
words("You probably meant"), fixed("!." ++ Name),
words("or"), fixed("!:" ++ Name), suffix(".")],
- write_error_pieces(Context, 0, Pieces, !IO).
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
+ !:Specs = [Spec | !.Specs].
:- inst dcg_record_syntax_op == bound("=^"; ":=").
@@ -931,10 +979,11 @@
list(prog_term)::in, prog_context::in, hlds_goal::out, int::out,
prog_varset::in, prog_varset::out,
module_info::in, module_info::out, qual_info::in, qual_info::out,
- svar_info::in, svar_info::out, io::di, io::uo) is det.
+ svar_info::in, svar_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
transform_dcg_record_syntax(Operator, ArgTerms0, Context, Goal, NumAdded,
- !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO) :-
+ !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs) :-
goal_info_init(Context, GoalInfo),
(
ArgTerms0 = [LHSTerm, RHSTerm, TermInputTerm, TermOutputTerm],
@@ -957,33 +1006,34 @@
ArgTerms = [FieldValueTerm, TermInputTerm, TermOutputTerm],
transform_dcg_record_syntax_2(AccessType, FieldNames, ArgTerms,
Context, Goal, NumAdded, !VarSet, !ModuleInfo, !QualInfo,
- !SInfo, !IO)
+ !SInfo, !Specs)
;
MaybeFieldNames = error1(Errors),
- % Msg, ErrorTerm),
- invalid_goal("^", ArgTerms0, GoalInfo, Goal, !VarSet, !SInfo, !IO),
+ 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, !IO)
+ Errors, !Specs)
)
;
- invalid_goal("^", ArgTerms0, GoalInfo, Goal, !VarSet, !SInfo, !IO),
+ invalid_goal("^", ArgTerms0, GoalInfo, Goal, !VarSet, !SInfo, !Specs),
NumAdded = 0,
qual_info_set_found_syntax_error(yes, !QualInfo),
Pieces = [words("Error: expected `Field =^ field1 ^ ... ^ fieldN'"),
words("or `^ field1 ^ ... ^ fieldN := Field'"),
words("in DCG field access goal."), nl],
- write_error_pieces(Context, 0, Pieces, !IO),
- io.set_exit_status(1, !IO)
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
+ !: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, io::di, io::uo)
- is det.
+ prog_varset::in, pair(string, term(prog_var_type))::in,
+ list(error_spec)::in, list(error_spec)::out) is det.
-report_dcg_field_error(Context, AccessType, VarSet, Error, !IO) :-
- Error = Msg - ErrorTerm,
+report_dcg_field_error(Context, AccessType, VarSet, Error, !Specs) :-
+ Error = ErrorMsg - ErrorTerm,
(
AccessType = set,
Action = "update"
@@ -994,19 +1044,21 @@
GenericVarSet = varset.coerce(VarSet),
TermStr = mercury_term_to_string(ErrorTerm, GenericVarSet, no),
Pieces = [words("In DCG field"), words(Action), words("goal:"), nl,
- words("error:"), words(Msg), words("at term"),
- fixed("`" ++ TermStr ++ "'."), nl],
- write_error_pieces(Context, 0, Pieces, !IO),
- io.set_exit_status(1, !IO).
+ 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].
% Produce an invalid goal.
%
:- pred invalid_goal(string::in, list(prog_term)::in, hlds_goal_info::in,
hlds_goal::out, prog_varset::in, prog_varset::out,
- svar_info::in, svar_info::out, io::di, io::uo) is det.
+ svar_info::in, svar_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
-invalid_goal(UpdateStr, Args0, GoalInfo, Goal, !VarSet, !SInfo, !IO) :-
- make_fresh_arg_vars(Args0, HeadVars, !VarSet, !SInfo, !IO),
+invalid_goal(UpdateStr, Args0, GoalInfo, Goal, !VarSet, !SInfo, !Specs) :-
+ make_fresh_arg_vars(Args0, HeadVars, !VarSet, !SInfo, !Specs),
MaybeUnifyContext = no,
Goal = plain_call(invalid_pred_id, invalid_proc_id, HeadVars, not_builtin,
MaybeUnifyContext, unqualified(UpdateStr)) - GoalInfo.
@@ -1015,18 +1067,19 @@
list(prog_term)::in, prog_context::in, hlds_goal::out,
num_added_goals::out, prog_varset::in, prog_varset::out,
module_info::in, module_info::out, qual_info::in, qual_info::out,
- svar_info::in, svar_info::out, io::di, io::uo) is det.
+ svar_info::in, svar_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
transform_dcg_record_syntax_2(AccessType, FieldNames, ArgTerms, Context, Goal,
- NumAdded, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO) :-
- make_fresh_arg_vars(ArgTerms, ArgVars, !VarSet, !SInfo, !IO),
+ NumAdded, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs) :-
+ make_fresh_arg_vars(ArgTerms, ArgVars, !VarSet, !SInfo, !Specs),
( ArgVars = [FieldValueVar, TermInputVar, TermOutputVar] ->
(
AccessType = set,
expand_set_field_function_call(Context, umc_explicit, [],
FieldNames, FieldValueVar, TermInputVar, TermOutputVar,
Functor, InnermostFunctor - InnermostSubContext, Goal0,
- SetAdded, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
+ SetAdded, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs),
FieldArgNumber = 2,
FieldArgContext = ac_functor(InnermostFunctor, umc_explicit,
@@ -1052,14 +1105,14 @@
],
insert_arg_unifications_with_supplied_contexts(ArgVars, ArgTerms,
ArgContexts, Context, Goal0, Goal, ArgAdded, !VarSet,
- !ModuleInfo, !QualInfo, !SInfo, !IO),
+ !ModuleInfo, !QualInfo, !SInfo, !Specs),
NumAdded = SetAdded + ArgAdded
;
AccessType = get,
expand_dcg_field_extraction_goal(Context, umc_explicit, [],
FieldNames, FieldValueVar, TermInputVar, TermOutputVar,
Functor, InnermostFunctor - _InnerSubContext, Goal0,
- ExtractAdded, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
+ ExtractAdded, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs),
InputTermArgNumber = 1,
InputTermArgContext = ac_functor(Functor, umc_explicit, []),
@@ -1084,25 +1137,13 @@
],
insert_arg_unifications_with_supplied_contexts(ArgVars, ArgTerms,
ArgContexts, Context, Goal0, Goal, ArgAdded, !VarSet,
- !ModuleInfo, !QualInfo, !SInfo, !IO),
+ !ModuleInfo, !QualInfo, !SInfo, !Specs),
NumAdded = ExtractAdded + ArgAdded
)
;
unexpected(this_file, "do_transform_dcg_record_syntax")
).
-qualify_lambda_mode_list_if_not_opt_imported(Modes0, Modes, Context,
- !QualInfo, !IO) :-
- % The modes in `.opt' files are already fully module qualified.
- qual_info_get_import_status(!.QualInfo, ImportStatus),
- ( ImportStatus \= status_opt_imported ->
- qual_info_get_mq_info(!.QualInfo, MQInfo0),
- qualify_lambda_mode_list(Modes0, Modes, Context, MQInfo0, MQInfo, !IO),
- qual_info_set_mq_info(MQInfo, !QualInfo)
- ;
- Modes = Modes0
- ).
-
% get_rev_conj(Goal, Subst, RevConj0, RevConj) :
%
% Goal is a tree of conjuncts. Flatten it into a list (applying Subst),
@@ -1112,18 +1153,18 @@
list(hlds_goal)::in, list(hlds_goal)::out, int::in, int::out,
prog_varset::in, prog_varset::out, module_info::in, module_info::out,
qual_info::in, qual_info::out, svar_info::in, svar_info::out,
- io::di, io::uo) is det.
+ list(error_spec)::in, list(error_spec)::out) is det.
get_rev_conj(Goal, Subst, RevConj0, RevConj, !NumAdded, !VarSet, !ModuleInfo,
- !QualInfo, !SInfo, !IO) :-
+ !QualInfo, !SInfo, !Specs) :-
( Goal = conj_expr(A, B) - _Context ->
get_rev_conj(A, Subst, RevConj0, RevConj1, !NumAdded,
- !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
+ !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs),
get_rev_conj(B, Subst, RevConj1, RevConj, !NumAdded,
- !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO)
+ !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs)
;
transform_goal(Goal, Subst, Goal1, GoalAdded, !VarSet, !ModuleInfo,
- !QualInfo, !SInfo, !IO),
+ !QualInfo, !SInfo, !Specs),
!:NumAdded = !.NumAdded + GoalAdded,
goal_to_conj_list(Goal1, ConjList),
RevConj = list.reverse(ConjList) ++ RevConj0
@@ -1138,18 +1179,18 @@
list(hlds_goal)::in, list(hlds_goal)::out, int::in, int::out,
prog_varset::in, prog_varset::out, module_info::in, module_info::out,
qual_info::in, qual_info::out, svar_info::in, svar_info::out,
- io::di, io::uo) is det.
+ list(error_spec)::in, list(error_spec)::out) is det.
get_rev_par_conj(Goal, Subst, RevParConj0, RevParConj, !NumAdded, !VarSet,
- !ModuleInfo, !QualInfo, !SInfo, !IO) :-
+ !ModuleInfo, !QualInfo, !SInfo, !Specs) :-
( Goal = par_conj_expr(A, B) - _Context ->
get_rev_par_conj(A, Subst, RevParConj0, RevParConj1, !NumAdded,
- !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
+ !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs),
get_rev_par_conj(B, Subst, RevParConj1, RevParConj, !NumAdded,
- !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO)
+ !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs)
;
transform_goal(Goal, Subst, Goal1, GoalAdded, !VarSet, !ModuleInfo,
- !QualInfo, !SInfo, !IO),
+ !QualInfo, !SInfo, !Specs),
!:NumAdded = !.NumAdded + GoalAdded,
goal_to_par_conj_list(Goal1, ParConjList),
RevParConj = list.reverse(ParConjList) ++ RevParConj0
@@ -1163,18 +1204,19 @@
:- pred get_disj(goal::in, prog_substitution::in,
hlds_goal_svar_infos::in, hlds_goal_svar_infos::out, int::in, int::out,
prog_varset::in, prog_varset::out, module_info::in, module_info::out,
- qual_info::in, qual_info::out, svar_info::in, io::di, io::uo) is det.
+ qual_info::in, qual_info::out, svar_info::in,
+ list(error_spec)::in, list(error_spec)::out) is det.
get_disj(Goal, Subst, Disj0, Disj, !NumAdded, !VarSet, !ModuleInfo, !QualInfo,
- SInfo, !IO) :-
+ SInfo, !Specs) :-
( Goal = disj_expr(A, B) - _Context ->
get_disj(B, Subst, Disj0, Disj1, !NumAdded, !VarSet, !ModuleInfo,
- !QualInfo, SInfo, !IO),
+ !QualInfo, SInfo, !Specs),
get_disj(A, Subst, Disj1, Disj, !NumAdded, !VarSet, !ModuleInfo,
- !QualInfo, SInfo, !IO)
+ !QualInfo, SInfo, !Specs)
;
transform_goal(Goal, Subst, Goal1, GoalAdded, !VarSet, !ModuleInfo,
- !QualInfo, SInfo, SInfo1, !IO),
+ !QualInfo, SInfo, SInfo1, !Specs),
!:NumAdded = !.NumAdded + GoalAdded,
Disj = [{Goal1, SInfo1} | Disj0]
).
Index: compiler/add_mode.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/add_mode.m,v
retrieving revision 1.11
diff -u -b -r1.11 add_mode.m
--- compiler/add_mode.m 31 Jul 2006 08:31:26 -0000 1.11
+++ compiler/add_mode.m 8 Sep 2006 09:13:00 -0000
@@ -18,19 +18,21 @@
:- import_module hlds.hlds_module.
:- import_module hlds.make_hlds.make_hlds_passes.
:- import_module mdbcomp.prim_data.
+:- import_module parse_tree.error_util.
:- import_module parse_tree.prog_data.
:- import_module bool.
-:- import_module io.
:- import_module list.
:- pred module_add_inst_defn(inst_varset::in, sym_name::in, list(inst_var)::in,
inst_defn::in, condition::in, prog_context::in, item_status::in,
- module_info::in, module_info::out, bool::out, io::di, io::uo) is det.
+ module_info::in, module_info::out, bool::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
:- pred module_add_mode_defn(inst_varset::in, sym_name::in, list(inst_var)::in,
mode_defn::in, condition::in, prog_context::in, item_status::in,
- module_info::in, module_info::out, bool::out, io::di, io::uo) is det.
+ module_info::in, module_info::out, bool::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
%----------------------------------------------------------------------------%
%----------------------------------------------------------------------------%
@@ -41,7 +43,6 @@
:- import_module hlds.hlds_pred.
:- import_module hlds.make_hlds.make_hlds_error.
:- import_module libs.compiler_util.
-:- import_module parse_tree.error_util.
:- import_module parse_tree.prog_mode.
:- import_module map.
@@ -51,35 +52,32 @@
%----------------------------------------------------------------------------%
module_add_inst_defn(VarSet, Name, Args, InstDefn, Cond, Context,
- item_status(Status, _NeedQual), !ModuleInfo, InvalidMode, !IO) :-
- %
+ item_status(Status, _NeedQual), !ModuleInfo, InvalidMode, !Specs) :-
% Add the definition of this inst to the HLDS inst table.
- %
module_info_get_inst_table(!.ModuleInfo, InstTable0),
inst_table_get_user_insts(InstTable0, Insts0),
insts_add(VarSet, Name, Args, InstDefn, Cond, Context, Status,
- Insts0, Insts, !IO),
+ Insts0, Insts, !Specs),
inst_table_set_user_insts(Insts, InstTable0, InstTable),
module_info_set_inst_table(InstTable, !ModuleInfo),
- %
- % check if the inst is infinitely recursive (at the top level)
- %
+
+ % Check if the inst is infinitely recursive (at the top level).
Arity = list.length(Args),
InstId = inst_id(Name, Arity),
TestArgs = list.duplicate(Arity, not_reached),
check_for_cyclic_inst(Insts, InstId, InstId, TestArgs, [], Context,
- InvalidMode, !IO).
+ InvalidMode, !Specs).
:- pred insts_add(inst_varset::in, sym_name::in,
list(inst_var)::in, inst_defn::in, condition::in, prog_context::in,
import_status::in, user_inst_table::in, user_inst_table::out,
- io::di, io::uo) is det.
+ list(error_spec)::in, list(error_spec)::out) is det.
-insts_add(_, _, _, abstract_inst, _, _, _, !Insts, !IO) :-
+insts_add(_, _, _, abstract_inst, _, _, _, !Insts, !Specs) :-
% XXX handle abstract insts
sorry(this_file, "abstract insts not implemented").
insts_add(VarSet, Name, Args, eqv_inst(Body), _Cond, Context, Status, !Insts,
- !IO) :-
+ !Specs) :-
list.length(Args, Arity),
InstId = inst_id(Name, Arity),
(
@@ -97,20 +95,20 @@
map.lookup(InstDefns, InstId, OrigI),
OrigI = hlds_inst_defn(_, _, _, OrigContext, _),
multiple_def_error(Status, Name, Arity, "inst", Context, OrigContext,
- _, !IO)
+ [], !Specs)
).
% Check if the inst is infinitely recursive (at the top level).
%
:- pred check_for_cyclic_inst(user_inst_table::in, inst_id::in, inst_id::in,
list(mer_inst)::in, list(inst_id)::in, prog_context::in, bool::out,
- io::di, io::uo) is det.
+ list(error_spec)::in, list(error_spec)::out) is det.
check_for_cyclic_inst(UserInstTable, OrigInstId, InstId0, Args0, Expansions0,
- Context, InvalidMode, !IO) :-
+ Context, InvalidMode, !Specs) :-
( list.member(InstId0, Expansions0) ->
report_circular_inst_equiv_error(OrigInstId, InstId0, Expansions0,
- Context, !IO),
+ Context, !Specs),
InvalidMode = yes
;
user_inst_table_get_inst_defns(UserInstTable, InstDefns),
@@ -125,7 +123,7 @@
InstId = inst_id(Name, Arity),
Expansions = [InstId0 | Expansions0],
check_for_cyclic_inst(UserInstTable, OrigInstId, InstId, Args,
- Expansions, Context, InvalidMode, !IO)
+ Expansions, Context, InvalidMode, !Specs)
;
InvalidMode = no
)
@@ -134,18 +132,19 @@
%-----------------------------------------------------------------------------%
module_add_mode_defn(VarSet, Name, Params, ModeDefn, Cond, Context,
- item_status(Status, _NeedQual), !ModuleInfo, InvalidMode, !IO) :-
+ item_status(Status, _NeedQual), !ModuleInfo, InvalidMode, !Specs) :-
module_info_get_mode_table(!.ModuleInfo, Modes0),
modes_add(VarSet, Name, Params, ModeDefn, Cond, Context, Status,
- Modes0, Modes, InvalidMode, !IO),
+ Modes0, Modes, InvalidMode, !Specs),
module_info_set_mode_table(Modes, !ModuleInfo).
:- pred modes_add(inst_varset::in, sym_name::in, list(inst_var)::in,
mode_defn::in, condition::in, prog_context::in, import_status::in,
- mode_table::in, mode_table::out, bool::out, io::di, io::uo) is det.
+ mode_table::in, mode_table::out, bool::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
modes_add(VarSet, Name, Args, eqv_mode(Body), _Cond, Context, Status,
- !Modes, InvalidMode, !IO) :-
+ !Modes, InvalidMode, !Specs) :-
list.length(Args, Arity),
ModeId = mode_id(Name, Arity),
(
@@ -159,21 +158,22 @@
OrigI = hlds_mode_defn(_, _, _, OrigContext, _),
% XXX We should record each error using module_info_incr_errors.
multiple_def_error(Status, Name, Arity, "mode", Context, OrigContext,
- _, !IO)
+ [], !Specs)
),
check_for_cyclic_mode(!.Modes, ModeId, ModeId, [], Context, InvalidMode,
- !IO).
+ !Specs).
% Check if the mode is infinitely recursive at the top level.
%
:- pred check_for_cyclic_mode(mode_table::in, mode_id::in, mode_id::in,
- list(mode_id)::in, prog_context::in, bool::out, io::di, io::uo) is det.
+ list(mode_id)::in, prog_context::in, bool::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
check_for_cyclic_mode(ModeTable, OrigModeId, ModeId0, Expansions0, Context,
- InvalidMode, !IO) :-
+ InvalidMode, !Specs) :-
( list.member(ModeId0, Expansions0) ->
report_circular_mode_equiv_error(OrigModeId, ModeId0, Expansions0,
- Context, !IO),
+ Context, !Specs),
InvalidMode = yes
;
mode_table_get_mode_defns(ModeTable, ModeDefns),
@@ -187,31 +187,33 @@
ModeId = mode_id(Name, Arity),
Expansions = [ModeId0 | Expansions0],
check_for_cyclic_mode(ModeTable, OrigModeId, ModeId, Expansions,
- Context, InvalidMode, !IO)
+ Context, InvalidMode, !Specs)
;
InvalidMode = no
)
).
:- pred report_circular_inst_equiv_error(inst_id::in, inst_id::in,
- list(inst_id)::in, prog_context::in, io::di, io::uo) is det.
+ list(inst_id)::in, prog_context::in,
+ list(error_spec)::in, list(error_spec)::out) is det.
-report_circular_inst_equiv_error(OrigInstId, InstId, Expansions,
- Context, !IO) :-
+report_circular_inst_equiv_error(OrigInstId, InstId, Expansions, Context,
+ !Specs) :-
report_circular_equiv_error("inst", "insts",
inst_id_to_circ_id(OrigInstId), inst_id_to_circ_id(InstId),
list.map(inst_id_to_circ_id, Expansions),
- Context, !IO).
+ Context, !Specs).
:- pred report_circular_mode_equiv_error(mode_id::in, mode_id::in,
- list(mode_id)::in, prog_context::in, io::di, io::uo) is det.
+ list(mode_id)::in, prog_context::in,
+ list(error_spec)::in, list(error_spec)::out) is det.
-report_circular_mode_equiv_error(OrigModeId, ModeId, Expansions,
- Context, !IO) :-
+report_circular_mode_equiv_error(OrigModeId, ModeId, Expansions, Context,
+ !Specs) :-
report_circular_equiv_error("mode", "modes",
mode_id_to_circ_id(OrigModeId), mode_id_to_circ_id(ModeId),
list.map(mode_id_to_circ_id, Expansions),
- Context, !IO).
+ Context, !Specs).
:- type circ_id
---> circ_id(sym_name, arity).
@@ -224,12 +226,11 @@
:- pred report_circular_equiv_error(string::in, string::in,
circ_id::in, circ_id::in, list(circ_id)::in, prog_context::in,
- io::di, io::uo) is det.
+ list(error_spec)::in, list(error_spec)::out) is det.
report_circular_equiv_error(One, Several, OrigId, Id, Expansions, Context,
- !IO) :-
+ !Specs) :-
( Id = OrigId ->
- %
% Report an error message of the form
% Error: circular equivalence <kind> foo/0.
% or
@@ -238,7 +239,7 @@
% Error: circular equivalence <kind>s foo/0, bar/1,
% and baz/2.
% where <kind> is either "inst" or "mode".
- %
+
Kinds = choose_number(Expansions, One, Several),
ExpansionPieces = list.map(
(func(circ_id(SymName, Arity)) =
@@ -246,8 +247,9 @@
Expansions),
Pieces = [words("Error: circular equivalence"), fixed(Kinds)]
++ component_list_to_pieces(ExpansionPieces) ++ [suffix(".")],
- write_error_pieces(Context, 0, Pieces, !IO),
- io.set_exit_status(1, !IO)
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
+ !:Specs = [Spec | !.Specs]
;
% We have an inst `OrigId' which is not itself circular,
% but which is defined in terms of `Id' which is circular.
@@ -260,6 +262,6 @@
:- func this_file = string.
-this_file = "add_mode".
+this_file = "add_mode.m".
%----------------------------------------------------------------------------%
Index: compiler/add_pragma.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/add_pragma.m,v
retrieving revision 1.47
diff -u -b -r1.47 add_pragma.m
--- compiler/add_pragma.m 7 Sep 2006 05:50:51 -0000 1.47
+++ compiler/add_pragma.m 9 Sep 2006 07:04:46 -0000
@@ -15,10 +15,10 @@
:- import_module hlds.make_hlds.qual_info.
:- import_module libs.globals.
:- import_module mdbcomp.prim_data.
+:- import_module parse_tree.error_util.
:- import_module parse_tree.prog_data.
:- import_module assoc_list.
-:- import_module io.
:- import_module list.
:- import_module term.
@@ -26,41 +26,46 @@
:- pred add_pragma(item_origin::in, pragma_type::in, prog_context::in,
item_status::in, item_status::out, module_info::in, module_info::out,
- io::di, io::uo) is det.
+ list(error_spec)::in, list(error_spec)::out) is det.
:- pred add_pragma_foreign_export(item_origin::in, foreign_language::in,
sym_name::in, pred_or_func::in, list(mer_mode)::in, string::in,
- prog_context::in, module_info::in, module_info::out, io::di, io::uo)
- is det.
+ prog_context::in, module_info::in, module_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
:- pred add_pragma_reserve_tag(sym_name::in, arity::in, import_status::in,
prog_context::in, module_info::in, module_info::out,
- io::di, io::uo) is det.
+ list(error_spec)::in, list(error_spec)::out) is det.
:- pred add_pragma_type_spec(pragma_type::in(pragma_type_spec),
term.context::in, module_info::in, module_info::out,
- qual_info::in, qual_info::out, io::di, io::uo) is det.
+ qual_info::in, qual_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
:- pred add_pragma_termination2_info(pred_or_func::in, sym_name::in,
list(mer_mode)::in, maybe(pragma_constr_arg_size_info)::in,
maybe(pragma_constr_arg_size_info)::in,
- maybe(pragma_termination_info)::in, prog_context::in, module_info::in,
- module_info::out, io::di, io::uo) is det.
+ maybe(pragma_termination_info)::in, prog_context::in,
+ module_info::in, module_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
:- pred add_pragma_termination_info(pred_or_func::in, sym_name::in,
list(mer_mode)::in, maybe(pragma_arg_size_info)::in,
maybe(pragma_termination_info)::in, prog_context::in,
- module_info::in, module_info::out, io::di, io::uo) is det.
+ module_info::in, module_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
:- pred add_pragma_structure_sharing(pred_or_func::in, sym_name::in,
list(mer_mode)::in, list(prog_var)::in, list(mer_type)::in,
maybe(structure_sharing_domain)::in, prog_context::in,
- module_info::in, module_info::out, io::di, io::uo) is det.
+ module_info::in, module_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
:- pred add_pragma_structure_reuse(pred_or_func::in, sym_name::in,
list(mer_mode)::in, list(prog_var)::in, list(mer_type)::in,
maybe(structure_reuse_domain)::in, prog_context::in,
- module_info::in, module_info::out, io::di, io::uo) is det.
+ module_info::in, module_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
% module_add_pragma_import:
%
@@ -75,19 +80,21 @@
list(mer_mode)::in, pragma_foreign_proc_attributes::in, string::in,
import_status::in, prog_context::in,
module_info::in, module_info::out, qual_info::in, qual_info::out,
- io::di, io::uo) is det.
+ list(error_spec)::in, list(error_spec)::out) is det.
:- pred module_add_pragma_foreign_proc(pragma_foreign_proc_attributes::in,
sym_name::in, pred_or_func::in, list(pragma_var)::in, prog_varset::in,
inst_varset::in, pragma_foreign_code_impl::in, import_status::in,
prog_context::in, module_info::in, module_info::out,
- qual_info::in, qual_info::out, io::di, io::uo) is det.
+ qual_info::in, qual_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
:- pred module_add_pragma_tabled(eval_method::in, sym_name::in, int::in,
maybe(pred_or_func)::in, maybe(list(mer_mode))::in,
maybe(table_attributes)::in, import_status::in, import_status::out,
prog_context::in, module_info::in, module_info::out,
- qual_info::in, qual_info::out, io::di, io::uo) is det.
+ qual_info::in, qual_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
% module_add_pragma_fact_table(PredName, Arity, FileName,
% Status, Context, Module0, Module, !Info):
@@ -100,9 +107,10 @@
%
:- pred module_add_pragma_fact_table(sym_name::in, arity::in, string::in,
import_status::in, prog_context::in, module_info::in, module_info::out,
- qual_info::in, qual_info::out, io::di, io::uo) is det.
+ qual_info::in, qual_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
-:- pred lookup_current_backend(backend::out, io::di, io::uo) is det.
+:- func lookup_current_backend(globals) = backend.
% Find the procedure with declared argmodes which match the ones we want.
% If there was no mode declaration, then use the inferred argmodes.
@@ -142,7 +150,6 @@
:- import_module ml_backend.
:- import_module ml_backend.mlds.
:- import_module ml_backend.mlds_to_c.
-:- import_module parse_tree.error_util.
:- import_module parse_tree.mercury_to_mercury.
:- import_module parse_tree.modules.
:- import_module parse_tree.prog_ctgc.
@@ -173,7 +180,7 @@
%-----------------------------------------------------------------------------%
-add_pragma(Origin, Pragma, Context, !Status, !ModuleInfo, !IO) :-
+add_pragma(Origin, Pragma, Context, !Status, !ModuleInfo, !Specs) :-
% Check for invalid pragmas in the `interface' section.
!.Status = item_status(ImportStatus, _),
pragma_allowed_in_interface(Pragma, Allowed),
@@ -182,7 +189,7 @@
(
Origin = user,
error_if_exported(ImportStatus, Context, "`pragma' declaration",
- !IO)
+ !Specs)
;
% We don't report this as an error as it just clutters up
% the compiler output - the *real* error is whatever caused
@@ -215,16 +222,16 @@
Pragma = pragma_inline(Name, Arity),
add_pred_marker("inline", Name, Arity, ImportStatus, Context,
marker_user_marked_inline, [marker_user_marked_no_inline],
- !ModuleInfo, !IO)
+ !ModuleInfo, !Specs)
;
Pragma = pragma_no_inline(Name, Arity),
add_pred_marker("no_inline", Name, Arity, ImportStatus, Context,
marker_user_marked_no_inline, [marker_user_marked_inline],
- !ModuleInfo, !IO)
+ !ModuleInfo, !Specs)
;
Pragma = pragma_obsolete(Name, Arity),
add_pred_marker("obsolete", Name, Arity, ImportStatus,
- Context, marker_obsolete, [], !ModuleInfo, !IO)
+ Context, marker_obsolete, [], !ModuleInfo, !Specs)
;
% Handle pragma import decls later on (when we process
% clauses and pragma c_code).
@@ -239,46 +246,50 @@
Pragma = pragma_unused_args(PredOrFunc, SymName, Arity, ModeNum,
UnusedArgs),
( ImportStatus \= status_opt_imported ->
- module_info_incr_errors(!ModuleInfo),
Pieces = [words("Error: illegal use of pragma `unused_args'.")],
- write_error_pieces(Context, 0, Pieces, !IO)
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
+ !:Specs = [Spec | !.Specs]
;
add_pragma_unused_args(PredOrFunc, SymName, Arity, ModeNum,
- UnusedArgs, Context, !ModuleInfo, !IO)
+ UnusedArgs, Context, !ModuleInfo, !Specs)
)
;
Pragma = pragma_exceptions(PredOrFunc, SymName, Arity, ModeNum,
ThrowStatus),
( ImportStatus \= status_opt_imported ->
- module_info_incr_errors(!ModuleInfo),
Pieces = [words("Error: illegal use of pragma `exceptions'.")],
- write_error_pieces(Context, 0, Pieces, !IO)
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
+ !:Specs = [Spec | !.Specs]
;
add_pragma_exceptions(PredOrFunc, SymName, Arity, ModeNum,
- ThrowStatus, Context, !ModuleInfo, !IO)
+ ThrowStatus, Context, !ModuleInfo, !Specs)
)
;
Pragma = pragma_trailing_info(PredOrFunc, SymName, Arity, ModeNum,
TrailingStatus),
( ImportStatus \= status_opt_imported ->
- module_info_incr_errors(!ModuleInfo),
Pieces = [words("Error: illegal use of pragma `trailing_info'.")],
- write_error_pieces(Context, 0, Pieces, !IO)
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
+ !:Specs = [Spec | !.Specs]
;
add_pragma_trailing_info(PredOrFunc, SymName, Arity, ModeNum,
- TrailingStatus, Context, !ModuleInfo, !IO)
+ TrailingStatus, Context, !ModuleInfo, !Specs)
)
;
Pragma = pragma_mm_tabling_info(PredOrFunc, SymName, Arity, ModeNum,
MM_TablingStatus),
( ImportStatus \= status_opt_imported ->
- module_info_incr_errors(!ModuleInfo),
Pieces =
[words("Error: illegal use of pragma `mm_tabling_info',")],
- write_error_pieces(Context, 0, Pieces, !IO)
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
+ !:Specs = [Spec | !.Specs]
;
add_pragma_mm_tabling_info(PredOrFunc, SymName, Arity, ModeNum,
- MM_TablingStatus, Context, !ModuleInfo, !IO)
+ MM_TablingStatus, Context, !ModuleInfo, !Specs)
)
;
% Handle pragma type_spec decls later on (when we process clauses).
@@ -295,16 +306,16 @@
;
Pragma = pragma_promise_pure(Name, Arity),
add_pred_marker("promise_pure", Name, Arity, ImportStatus,
- Context, marker_promised_pure, [], !ModuleInfo, !IO)
+ Context, marker_promised_pure, [], !ModuleInfo, !Specs)
;
Pragma = pragma_promise_semipure(Name, Arity),
add_pred_marker("promise_semipure", Name, Arity, ImportStatus,
- Context, marker_promised_semipure, [], !ModuleInfo, !IO)
+ Context, marker_promised_semipure, [], !ModuleInfo, !Specs)
;
Pragma = pragma_promise_equivalent_clauses(Name, Arity),
add_pred_marker("promise_equivalent_clauses", Name, Arity,
ImportStatus, Context, marker_promised_equivalent_clauses, [],
- !ModuleInfo, !IO)
+ !ModuleInfo, !Specs)
;
% Handle pragma termination_info decls later on, in pass 3 --
% we need to add function default modes before handling
@@ -318,17 +329,18 @@
add_pred_marker("terminates", Name, Arity, ImportStatus, Context,
marker_terminates,
[marker_check_termination, marker_does_not_terminate],
- !ModuleInfo, !IO)
+ !ModuleInfo, !Specs)
;
Pragma = pragma_does_not_terminate(Name, Arity),
add_pred_marker("does_not_terminate", Name, Arity, ImportStatus,
Context, marker_does_not_terminate,
- [marker_check_termination, marker_terminates], !ModuleInfo, !IO)
+ [marker_check_termination, marker_terminates], !ModuleInfo, !Specs)
;
Pragma = pragma_check_termination(Name, Arity),
add_pred_marker("check_termination", Name, Arity, ImportStatus,
Context, marker_check_termination,
- [marker_terminates, marker_does_not_terminate], !ModuleInfo, !IO)
+ [marker_terminates, marker_does_not_terminate],
+ !ModuleInfo, !Specs)
;
Pragma = pragma_structure_sharing(_, _, _, _, _, _)
;
@@ -336,7 +348,7 @@
;
Pragma = pragma_mode_check_clauses(Name, Arity),
add_pred_marker("mode_check_clauses", Name, Arity, ImportStatus,
- Context, marker_mode_check_clauses, [], !ModuleInfo, !IO),
+ Context, marker_mode_check_clauses, [], !ModuleInfo, !Specs),
% Allowing the predicate to be inlined could lead to code generator
% aborts. This is because the caller that inlines this predicate may
@@ -345,11 +357,11 @@
% feature prevents the recomputation of.
add_pred_marker("mode_check_clauses", Name, Arity, ImportStatus,
Context, marker_user_marked_no_inline, [marker_user_marked_inline],
- !ModuleInfo, !IO)
+ !ModuleInfo, !Specs)
).
add_pragma_foreign_export(Origin, Lang, Name, PredOrFunc, Modes,
- ExportedName, Context, !ModuleInfo, !IO) :-
+ ExportedName, Context, !ModuleInfo, !Specs) :-
module_info_get_predicate_table(!.ModuleInfo, PredTable),
list.length(Modes, Arity),
(
@@ -383,8 +395,7 @@
Msg = simple_msg(Context, [always(Pieces)]),
Spec = error_spec(severity_error, phase_parse_tree_to_hlds,
[Msg]),
- write_error_spec(Spec, 0, _NumWarnings, 0, NumErrors, !IO),
- module_info_incr_num_errors(NumErrors, !ModuleInfo)
+ !:Specs = [Spec | !.Specs]
;
% Emit a warning about using pragma foreign_export with
% a foreign language that is not supported.
@@ -395,37 +406,35 @@
; Lang = lang_il
; Lang = lang_managed_cplusplus
),
- Pieces = [
- words("Warning:"),
- fixed("`:- pragma foreign_export'"),
- words("declarations are not yet implemented"),
- words("for language"),
- words(foreign_language_string(Lang)),
- suffix(".")
- ],
+ Pieces = [words("Warning:"),
+ fixed("`:- pragma foreign_export' declarations"),
+ words("are not yet implemented for language"),
+ words(foreign_language_string(Lang)), suffix("."), nl],
Msg = simple_msg(Context, [always(Pieces)]),
Spec = error_spec(severity_warning,
phase_parse_tree_to_hlds, [Msg]),
- write_error_spec(Spec, 0, _NumWarnings, 0, _NumErrors, !IO)
+ !:Specs = [Spec | !.Specs]
;
Lang = lang_c
),
% Only add the foreign export if the specified language matches
% one of the foreign languages available for this backend.
- io_get_backend_foreign_languages(ForeignLanguages, !IO),
+ module_info_get_globals(!.ModuleInfo, Globals),
+ globals.get_backend_foreign_languages(Globals,
+ ForeignLanguages),
(
% XXX C# and Managed C++ exports currently cause an
% assertion failure in the MLDS->IL code generator.
- %
+
Lang \= lang_csharp,
Lang \= lang_managed_cplusplus,
list.member(Lang, ForeignLanguages)
->
module_info_get_pragma_exported_procs(!.ModuleInfo,
PragmaExportedProcs0),
- NewExportedProc = pragma_exported_proc(Lang, PredId, ProcId,
- ExportedName, Context),
+ NewExportedProc = pragma_exported_proc(Lang,
+ PredId, ProcId, ExportedName, Context),
PragmaExportedProcs =
[NewExportedProc | PragmaExportedProcs0],
module_info_set_pragma_exported_procs(PragmaExportedProcs,
@@ -440,8 +449,7 @@
(
Origin = user,
undefined_mode_error(Name, Arity, Context,
- "`:- pragma foreign_export' declaration", !IO),
- module_info_incr_errors(!ModuleInfo)
+ "`:- pragma foreign_export' declaration", !Specs)
;
Origin = compiler(Details),
(
@@ -464,8 +472,7 @@
(
Origin = user,
undefined_pred_or_func_error(Name, Arity, Context,
- "`:- pragma foreign_export' declaration", !IO),
- module_info_incr_errors(!ModuleInfo)
+ "`:- pragma foreign_export' declaration", !Specs)
;
Origin = compiler(Details),
(
@@ -487,7 +494,7 @@
%-----------------------------------------------------------------------------%
add_pragma_reserve_tag(TypeName, TypeArity, PragmaStatus, Context, !ModuleInfo,
- !IO) :-
+ !Specs) :-
TypeCtor = type_ctor(TypeName, TypeArity),
module_info_get_type_table(!.ModuleInfo, Types0),
ContextPieces = [
@@ -569,18 +576,18 @@
),
Msg = simple_msg(Context, [always(ContextPieces ++ ErrorPieces)]),
Spec = error_spec(Severity, phase_parse_tree_to_hlds, [Msg]),
- write_error_spec(Spec, 0, _NumWarnings, 0, NumErrors, !IO),
- module_info_incr_num_errors(NumErrors, !ModuleInfo)
+ !:Specs = [Spec | !.Specs]
).
%-----------------------------------------------------------------------------%
:- pred add_pragma_unused_args(pred_or_func::in, sym_name::in, arity::in,
mode_num::in, list(int)::in, prog_context::in,
- module_info::in, module_info::out, io::di, io::uo) is det.
+ module_info::in, module_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
add_pragma_unused_args(PredOrFunc, SymName, Arity, ModeNum, UnusedArgs,
- Context, !ModuleInfo, !IO) :-
+ Context, !ModuleInfo, !Specs) :-
module_info_get_predicate_table(!.ModuleInfo, Preds),
(
predicate_table_search_pf_sym_arity(Preds, is_fully_qualified,
@@ -597,18 +604,18 @@
words("unknown predicate in `pragma unused_args'.")],
Msg = simple_msg(Context, [always(Pieces)]),
Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
- write_error_spec(Spec, 0, _NumWarnings, 0, NumErrors, !IO),
- module_info_incr_num_errors(NumErrors, !ModuleInfo)
+ !:Specs = [Spec | !.Specs]
).
%-----------------------------------------------------------------------------%
:- pred add_pragma_exceptions(pred_or_func::in, sym_name::in, arity::in,
mode_num::in, exception_status::in, prog_context::in,
- module_info::in, module_info::out, io::di, io::uo) is det.
+ module_info::in, module_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
add_pragma_exceptions(PredOrFunc, SymName, Arity, ModeNum, ThrowStatus,
- _Context, !ModuleInfo, !IO) :-
+ _Context, !ModuleInfo, !Specs) :-
module_info_get_predicate_table(!.ModuleInfo, Preds),
(
predicate_table_search_pf_sym_arity(Preds, is_fully_qualified,
@@ -626,10 +633,8 @@
;
% XXX We'll just ignore this for the time being -
% it causes errors with transitive-intermodule optimization.
- % prog_out.write_context(Context, !IO),
% io.write_string("Internal compiler error: " ++
- % "unknown predicate in `pragma exceptions'.\n", !IO),
- % module_info_incr_errors(!ModuleInfo)
+ % "unknown predicate in `pragma exceptions'.\n")
true
).
@@ -637,10 +642,11 @@
:- pred add_pragma_trailing_info(pred_or_func::in, sym_name::in, arity::in,
mode_num::in, trailing_status::in, prog_context::in,
- module_info::in, module_info::out, io::di, io::uo) is det.
+ module_info::in, module_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
add_pragma_trailing_info(PredOrFunc, SymName, Arity, ModeNum, TrailingStatus,
- _Context, !ModuleInfo, !IO) :-
+ _Context, !ModuleInfo, !Specs) :-
module_info_get_predicate_table(!.ModuleInfo, Preds),
(
predicate_table_search_pf_sym_arity(Preds, is_fully_qualified,
@@ -655,10 +661,8 @@
;
% XXX We'll just ignore this for the time being -
% it causes errors with transitive-intermodule optimization.
- % prog_out.write_context(Context, !IO),
% io.write_string("Internal compiler error: " ++
- % "unknown predicate in `pragma trailing_info'.\n", !IO),
- % module_info_incr_errors(!ModuleInfo)
+ % "unknown predicate in `pragma trailing_info'.\n"),
true
).
@@ -666,10 +670,11 @@
:- pred add_pragma_mm_tabling_info(pred_or_func::in, sym_name::in, arity::in,
mode_num::in, mm_tabling_status::in, prog_context::in,
- module_info::in, module_info::out, io::di, io::uo) is det.
+ module_info::in, module_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
add_pragma_mm_tabling_info(PredOrFunc, SymName, Arity, ModeNum,
- TablingStatus, _Context, !ModuleInfo, !IO) :-
+ TablingStatus, _Context, !ModuleInfo, !Specs) :-
module_info_get_predicate_table(!.ModuleInfo, Preds),
(
predicate_table_search_pf_sym_arity(Preds, is_fully_qualified,
@@ -685,16 +690,14 @@
;
% XXX We'll just ignore this for the time being -
% it causes errors with transitive-intermodule optimization.
- %prog_out__write_context(Context, !IO),
- %io__write_string("Internal compiler error: " ++
- % "unknown predicate in `pragma trailing_info'.\n", !IO),
- %module_info_incr_errors(!ModuleInfo)
+ % io.write_string("Internal compiler error: " ++
+ % "unknown predicate in `pragma trailing_info'.\n"),
true
).
%-----------------------------------------------------------------------------%
-add_pragma_type_spec(Pragma, Context, !ModuleInfo, !QualInfo, !IO) :-
+add_pragma_type_spec(Pragma, Context, !ModuleInfo, !QualInfo, !Specs) :-
Pragma = pragma_type_spec(SymName, _, Arity, MaybePredOrFunc, _, _, _, _),
module_info_get_predicate_table(!.ModuleInfo, Preds),
(
@@ -711,33 +714,34 @@
PredIds = [_ | _]
->
list.foldl3(add_pragma_type_spec_2(Pragma, Context), PredIds,
- !ModuleInfo, !QualInfo, !IO)
+ !ModuleInfo, !QualInfo, !Specs)
;
undefined_pred_or_func_error(SymName, Arity, Context,
- "`:- pragma type_spec' declaration", !IO),
- module_info_incr_errors(!ModuleInfo)
+ "`:- pragma type_spec' declaration", !Specs)
).
:- pred add_pragma_type_spec_2(pragma_type::in(pragma_type_spec),
prog_context::in, pred_id::in, module_info::in, module_info::out,
- qual_info::in, qual_info::out, io::di, io::uo) is det.
+ qual_info::in, qual_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
add_pragma_type_spec_2(Pragma0, Context, PredId, !ModuleInfo, !QualInfo,
- !IO) :-
+ !Specs) :-
Pragma0 = pragma_type_spec(SymName, SpecName, Arity, _, MaybeModes, Subst,
TVarSet0, ExpandedItems),
module_info_pred_info(!.ModuleInfo, PredId, PredInfo0),
handle_pragma_type_spec_subst(Context, Subst, PredInfo0,
TVarSet0, TVarSet, Types, ExistQVars, ClassContext, SubstOk,
- !ModuleInfo, !IO),
+ !ModuleInfo, !Specs),
(
SubstOk = yes(RenamedSubst),
pred_info_get_procedures(PredInfo0, Procs0),
handle_pragma_type_spec_modes(SymName, Arity, Context, MaybeModes,
- ProcIds, Procs0, Procs, ModesOk, !ModuleInfo, !IO),
- globals.io_lookup_bool_option(user_guided_type_specialization,
- DoTypeSpec, !IO),
- globals.io_lookup_bool_option(smart_recompilation, Smart, !IO),
+ ProcIds, Procs0, Procs, ModesOk, !ModuleInfo, !Specs),
+ module_info_get_globals(!.ModuleInfo, Globals),
+ globals.lookup_bool_option(Globals, user_guided_type_specialization,
+ DoTypeSpec),
+ globals.lookup_bool_option(Globals, smart_recompilation, Smart),
(
ModesOk = yes,
% Even if we aren't doing type specialization, we need to create
@@ -748,7 +752,7 @@
% even if we aren't doing type specialization to avoid problems
% with differing output for the recompilation tests in debugging
% grades.
- %
+
( DoTypeSpec = yes
; \+ pred_info_is_imported(PredInfo0)
; Smart = yes
@@ -878,10 +882,10 @@
assoc_list(tvar, mer_type)::in, pred_info::in, tvarset::in, tvarset::out,
list(mer_type)::out, existq_tvars::out, prog_constraints::out,
maybe(tsubst)::out, module_info::in, module_info::out,
- io::di, io::uo) is det.
+ list(error_spec)::in, list(error_spec)::out) is det.
handle_pragma_type_spec_subst(Context, Subst, PredInfo0, TVarSet0, TVarSet,
- Types, ExistQVars, ClassContext, SubstOk, !ModuleInfo, !IO) :-
+ Types, ExistQVars, ClassContext, SubstOk, !ModuleInfo, !Specs) :-
assoc_list.keys(Subst, VarsToSub),
(
Subst = []
@@ -894,9 +898,7 @@
->
list.sort_and_remove_dups(MultiSubstVars0, MultiSubstVars),
report_multiple_subst_vars(PredInfo0, Context, TVarSet0,
- MultiSubstVars, !IO),
- module_info_incr_errors(!ModuleInfo),
- io.set_exit_status(1, !IO),
+ MultiSubstVars, !Specs),
ExistQVars = [],
Types = [],
ClassContext = constraints([], []),
@@ -956,9 +958,7 @@
;
SubExistQVars = [_ | _],
report_subst_existq_tvars(PredInfo0, Context,
- SubExistQVars, !IO),
- io.set_exit_status(1, !IO),
- module_info_incr_errors(!ModuleInfo),
+ SubExistQVars, !Specs),
Types = [],
ClassContext = constraints([], []),
SubstOk = no
@@ -966,9 +966,7 @@
;
RecSubstTVars = [_ | _],
report_recursive_subst(PredInfo0, Context, TVarSet0,
- RecSubstTVars, !IO),
- io.set_exit_status(1, !IO),
- module_info_incr_errors(!ModuleInfo),
+ RecSubstTVars, !Specs),
ExistQVars = [],
Types = [],
ClassContext = constraints([], []),
@@ -978,9 +976,7 @@
;
UnknownVarsToSub = [_ | _],
report_unknown_vars_to_subst(PredInfo0, Context, TVarSet0,
- UnknownVarsToSub, !IO),
- module_info_incr_errors(!ModuleInfo),
- io.set_exit_status(1, !IO),
+ UnknownVarsToSub, !Specs),
ExistQVars = [],
Types = [],
ClassContext = constraints([], []),
@@ -1007,54 +1003,51 @@
).
:- pred report_subst_existq_tvars(pred_info::in, prog_context::in,
- list(tvar)::in, io::di, io::uo) is det.
+ list(tvar)::in, list(error_spec)::in, list(error_spec)::out) is det.
-report_subst_existq_tvars(PredInfo, Context, SubExistQVars, !IO) :-
+report_subst_existq_tvars(PredInfo, Context, SubExistQVars, !Specs) :-
pred_info_get_typevarset(PredInfo, TVarSet),
- Pieces = report_pragma_type_spec(PredInfo) ++
+ Pieces = pragma_type_spec_to_pieces(PredInfo) ++
[words("error: the substitution includes"),
- words("the existentially quantified type"),
- words(report_variables(SubExistQVars, TVarSet)), suffix(".")],
- write_error_pieces(Context, 0, Pieces, !IO).
+ words("the existentially quantified type")] ++
+ report_variables(SubExistQVars, TVarSet) ++ [suffix(".")],
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
+ !:Specs = [Spec | !.Specs].
:- pred report_recursive_subst(pred_info::in, prog_context::in, tvarset::in,
- list(tvar)::in, io::di, io::uo) is det.
+ list(tvar)::in, list(error_spec)::in, list(error_spec)::out) is det.
-report_recursive_subst(PredInfo, Context, TVarSet, RecursiveVars, !IO) :-
- ( RecursiveVars = [_] ->
- Occurs = "occurs"
- ;
- Occurs = "occur"
- ),
- Pieces = report_pragma_type_spec(PredInfo) ++
- [words("error:"), words(report_variables(RecursiveVars, TVarSet)),
- words(Occurs), words("on both sides of the substitution.")],
- write_error_pieces(Context, 0, Pieces, !IO).
+report_recursive_subst(PredInfo, Context, TVarSet, RecursiveVars, !Specs) :-
+ Pieces = pragma_type_spec_to_pieces(PredInfo) ++
+ [words("error:")] ++ report_variables(RecursiveVars, TVarSet) ++
+ [words(choose_number(RecursiveVars, "occurs", "occur")),
+ words("on both sides of the substitution.")],
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
+ !:Specs = [Spec | !.Specs].
:- pred report_multiple_subst_vars(pred_info::in, prog_context::in,
- tvarset::in, list(tvar)::in, io::di, io::uo) is det.
+ tvarset::in, list(tvar)::in,
+ list(error_spec)::in, list(error_spec)::out) is det.
-report_multiple_subst_vars(PredInfo, Context, TVarSet, MultiSubstVars, !IO) :-
- ( MultiSubstVars = [_] ->
- Has = "has"
- ;
- Has = "have"
- ),
- Pieces = report_pragma_type_spec(PredInfo) ++
- [words("error:"), words(report_variables(MultiSubstVars, TVarSet)),
- words(Has), words("multiple replacement types.")],
- write_error_pieces(Context, 0, Pieces, !IO).
+report_multiple_subst_vars(PredInfo, Context, TVarSet, MultiSubstVars,
+ !Specs) :-
+ Pieces = pragma_type_spec_to_pieces(PredInfo) ++
+ [words("error:")] ++ report_variables(MultiSubstVars, TVarSet) ++
+ [words(choose_number(MultiSubstVars, "has", "have")),
+ words("multiple replacement types.")],
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
+ !:Specs = [Spec | !.Specs].
:- pred report_unknown_vars_to_subst(pred_info::in, prog_context::in,
- tvarset::in, list(tvar)::in, io::di, io::uo) is det.
+ tvarset::in, list(tvar)::in,
+ list(error_spec)::in, list(error_spec)::out) is det.
-report_unknown_vars_to_subst(PredInfo, Context, TVarSet, UnknownVars, !IO) :-
+report_unknown_vars_to_subst(PredInfo, Context, TVarSet, UnknownVars,
+ !Specs) :-
PredOrFunc = pred_info_is_pred_or_func(PredInfo),
- ( UnknownVars = [_] ->
- DoesNot = "does not"
- ;
- DoesNot = "do not"
- ),
(
PredOrFunc = predicate,
Decl = "`:- pred'"
@@ -1062,15 +1055,17 @@
PredOrFunc = function,
Decl = "`:- func'"
),
- Pieces = report_pragma_type_spec(PredInfo) ++
- [words("error:"), words(report_variables(UnknownVars, TVarSet)),
- words(DoesNot), words("occur in the"), fixed(Decl),
- words("declaration.")],
- write_error_pieces(Context, 0, Pieces, !IO).
+ Pieces = pragma_type_spec_to_pieces(PredInfo) ++
+ [words("error:")] ++ report_variables(UnknownVars, TVarSet) ++
+ [words(choose_number(UnknownVars, "does not", "do not")),
+ words("occur in the"), fixed(Decl), words("declaration.")],
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
+ !:Specs = [Spec | !.Specs].
-:- func report_pragma_type_spec(pred_info) = list(format_component).
+:- func pragma_type_spec_to_pieces(pred_info) = list(format_component).
-report_pragma_type_spec(PredInfo) = Pieces :-
+pragma_type_spec_to_pieces(PredInfo) = Pieces :-
Module = pred_info_module(PredInfo),
Name = pred_info_name(PredInfo),
Arity = pred_info_orig_arity(PredInfo),
@@ -1079,15 +1074,11 @@
Pieces = [words("In `:- pragma type_spec' declaration for"),
simple_call(SimpleCallId), suffix(":"), nl].
-:- func report_variables(list(tvar), tvarset) = string.
+:- func report_variables(list(tvar), tvarset) = list(format_component).
-report_variables(SubExistQVars, VarSet) = Str :-
- VarsStr = mercury_vars_to_string(SubExistQVars, VarSet, no),
- ( SubExistQVars = [_] ->
- Str = "variable `" ++ VarsStr ++ "'"
- ;
- Str = "variables `" ++ VarsStr ++ "'"
- ).
+report_variables(SubExistQVars, VarSet) =
+ [words(choose_number(SubExistQVars, "variable", "variables")),
+ quote(mercury_vars_to_string(SubExistQVars, VarSet, no))].
% Check that the mode list for a `:- pragma type_spec' declaration
% specifies a known procedure.
@@ -1095,10 +1086,11 @@
:- pred handle_pragma_type_spec_modes(sym_name::in, arity::in,
prog_context::in, maybe(list(mer_mode))::in, list(proc_id)::out,
proc_table::in, proc_table::out, bool::out,
- module_info::in, module_info::out, io::di, io::uo) is det.
+ module_info::in, module_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
handle_pragma_type_spec_modes(SymName, Arity, Context, MaybeModes, ProcIds,
- !Procs, ModesOk, !ModuleInfo, !IO) :-
+ !Procs, ModesOk, !ModuleInfo, !Specs) :-
(
MaybeModes = yes(Modes),
map.to_assoc_list(!.Procs, ExistingProcs),
@@ -1114,7 +1106,7 @@
ProcIds = [],
module_info_incr_errors(!ModuleInfo),
undefined_mode_error(SymName, Arity, Context,
- "`:- pragma type_spec' declaration", !IO),
+ "`:- pragma type_spec' declaration", !Specs),
ModesOk = no
)
;
@@ -1127,7 +1119,7 @@
add_pragma_termination2_info(PredOrFunc, SymName, ModeList,
MaybePragmaSuccessArgSizeInfo, MaybePragmaFailureArgSizeInfo,
- MaybePragmaTerminationInfo, Context, !ModuleInfo, !IO) :-
+ MaybePragmaTerminationInfo, Context, !ModuleInfo, !Specs) :-
module_info_get_predicate_table(!.ModuleInfo, Preds),
list.length(ModeList, Arity),
(
@@ -1141,13 +1133,12 @@
pred_info_get_procedures(PredInfo0, ProcTable0),
map.to_assoc_list(ProcTable0, ProcList),
(
- get_procedure_matching_declmodes(ProcList,
- ModeList, !.ModuleInfo, ProcId)
+ get_procedure_matching_declmodes(ProcList, ModeList,
+ !.ModuleInfo, ProcId)
->
map.lookup(ProcTable0, ProcId, ProcInfo0),
add_context_to_constr_termination_info(
- MaybePragmaTerminationInfo, Context,
- MaybeTerminationInfo),
+ MaybePragmaTerminationInfo, Context, MaybeTerminationInfo),
some [!TermInfo] (
proc_info_get_termination2_info(ProcInfo0, !:TermInfo),
@@ -1162,27 +1153,28 @@
proc_info_set_termination2_info(!.TermInfo,
ProcInfo0, ProcInfo)
),
- map.det_update(ProcTable0, ProcId, ProcInfo,
- ProcTable),
- pred_info_set_procedures(ProcTable, PredInfo0,
- PredInfo),
- map.det_update(PredTable0, PredId, PredInfo,
- PredTable),
+ map.det_update(ProcTable0, ProcId, ProcInfo, ProcTable),
+ pred_info_set_procedures(ProcTable, PredInfo0, PredInfo),
+ map.det_update(PredTable0, PredId, PredInfo, PredTable),
module_info_set_preds(PredTable, !ModuleInfo)
;
- module_info_incr_errors(!ModuleInfo),
Pieces = [words("Error: `:- pragma termination2_info'"),
words("declaration for undeclared mode of"),
simple_call(simple_call_id(PredOrFunc, SymName, Arity)),
- suffix(".")],
- write_error_pieces(Context, 0, Pieces, !IO)
+ suffix("."), nl],
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds,
+ [Msg]),
+ !:Specs = [Spec | !.Specs]
)
;
- module_info_incr_errors(!ModuleInfo),
Pieces = [words("Error: ambiguous predicate name"),
simple_call(simple_call_id(PredOrFunc, SymName, Arity)),
- words("in"), fixed("`pragma termination2_info'.")],
- write_error_pieces(Context, 0, Pieces, !IO)
+ words("in"), fixed("`pragma termination2_info'."), nl],
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds,
+ [Msg]),
+ !:Specs = [Spec | !.Specs]
)
;
% XXX This happens in `.trans_opt' files sometimes --
@@ -1190,16 +1182,15 @@
true
% undefined_pred_or_func_error(
% SymName, Arity, Context,
- % "`:- pragma termination2_info' declaration", !IO),
- % module_info_incr_errors(!ModuleInfo)
+ % "`:- pragma termination2_info' declaration", !Specs)
).
%-----------------------------------------------------------------------------%
add_pragma_structure_sharing(_PredOrFunc, _SymName, _ModeList, _HeadVars,
- _Types, no, _Context, !ModuleInfo, !IO).
+ _Types, no, _Context, !ModuleInfo, !Specs).
add_pragma_structure_sharing(PredOrFunc, SymName, ModeList, HeadVars,
- Types, yes(SharingDomain), Context, !ModuleInfo, !IO):-
+ Types, yes(SharingDomain), Context, !ModuleInfo, !Specs):-
module_info_get_predicate_table(!.ModuleInfo, Preds),
list.length(ModeList, Arity),
(
@@ -1224,19 +1215,23 @@
map.det_update(PredTable0, PredId, PredInfo, PredTable),
module_info_set_preds(PredTable, !ModuleInfo)
;
- module_info_incr_errors(!ModuleInfo),
Pieces = [words("Error: `:- pragma structure_sharing'"),
words("declaration for undeclared mode of"),
simple_call(simple_call_id(PredOrFunc, SymName, Arity)),
- suffix(".")],
- write_error_pieces(Context, 0, Pieces, !IO)
+ suffix("."), nl],
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds,
+ [Msg]),
+ !:Specs = [Spec | !.Specs]
)
;
- module_info_incr_errors(!ModuleInfo),
Pieces = [words("Error: ambiguous predicate name"),
simple_call(simple_call_id(PredOrFunc, SymName, Arity)),
- words("in"), fixed("`pragma structure_sharing'.")],
- write_error_pieces(Context, 0, Pieces, !IO)
+ words("in"), quote("pragma structure_sharing."),
+ suffix("."), nl],
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
+ !:Specs = [Spec | !.Specs]
)
;
% XXX This happens in `.trans_opt' files sometimes --
@@ -1244,14 +1239,13 @@
true
% undefined_pred_or_func_error(SymName, Arity, Context,
% "`:- pragma structure_sharing' declaration",
- % !IO),
- % module_info_incr_errors(!ModuleInfo)
+ % !Specs)
).
add_pragma_structure_reuse(_PredOrFunc, _SymName, _ModeList, _HeadVars,
- _Types, no, _Context, !ModuleInfo, !IO).
+ _Types, no, _Context, !ModuleInfo, !Specs).
add_pragma_structure_reuse(PredOrFunc, SymName, ModeList, HeadVars,
- Types, yes(ReuseDomain), Context, !ModuleInfo, !IO):-
+ Types, yes(ReuseDomain), Context, !ModuleInfo, !Specs):-
module_info_get_predicate_table(!.ModuleInfo, Preds),
list.length(ModeList, Arity),
(
@@ -1275,21 +1269,23 @@
pred_info_set_procedures(ProcTable, PredInfo0, PredInfo),
map.det_update(PredTable0, PredId, PredInfo, PredTable),
module_info_set_preds(PredTable, !ModuleInfo)
-
;
- module_info_incr_errors(!ModuleInfo),
Pieces = [words("Error: `:- pragma structure_reuse'"),
words("declaration for undeclared mode of"),
simple_call(simple_call_id(PredOrFunc, SymName, Arity)),
- suffix(".")],
- write_error_pieces(Context, 0, Pieces, !IO)
+ suffix("."), nl],
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds,
+ [Msg]),
+ !:Specs = [Spec | !.Specs]
)
;
- module_info_incr_errors(!ModuleInfo),
Pieces = [words("Error: ambiguous predicate name"),
simple_call(simple_call_id(PredOrFunc, SymName, Arity)),
- words("in"), fixed("`pragma structure_reuse'.")],
- write_error_pieces(Context, 0, Pieces, !IO)
+ words("in"), quote("pragma structure_reuse"), suffix("."), nl],
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
+ !:Specs = [Spec | !.Specs]
)
;
% XXX This happens in `.trans_opt' files sometimes --
@@ -1297,14 +1293,13 @@
true
% undefined_pred_or_func_error(SymName, Arity, Context,
% "`:- pragma structure_sharing' declaration",
- % !IO),
- % module_info_incr_errors(!ModuleInfo)
+ % !Specs)
).
%-----------------------------------------------------------------------------%
add_pragma_termination_info(PredOrFunc, SymName, ModeList,
MaybePragmaArgSizeInfo, MaybePragmaTerminationInfo,
- Context, !ModuleInfo, !IO) :-
+ Context, !ModuleInfo, !Specs) :-
module_info_get_predicate_table(!.ModuleInfo, Preds),
list.length(ModeList, Arity),
(
@@ -1339,15 +1334,19 @@
Pieces = [words("Error: `:- pragma termination_info'"),
words("declaration for undeclared mode of"),
simple_call(simple_call_id(PredOrFunc, SymName, Arity)),
- suffix(".")],
- write_error_pieces(Context, 0, Pieces, !IO)
+ suffix("."), nl],
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds,
+ [Msg]),
+ !:Specs = [Spec | !.Specs]
)
;
- module_info_incr_errors(!ModuleInfo),
Pieces = [words("Error: ambiguous predicate name"),
simple_call(simple_call_id(PredOrFunc, SymName, Arity)),
- words("in"), fixed("`pragma termination_info'.")],
- write_error_pieces(Context, 0, Pieces, !IO)
+ words("in"), fixed("`pragma termination_info'."), nl],
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
+ !:Specs = [Spec | !.Specs]
)
;
% XXX This happens in `.trans_opt' files sometimes --
@@ -1355,21 +1354,23 @@
true
% undefined_pred_or_func_error(SymName, Arity, Context,
% "`:- pragma termination_info' declaration",
- % !IO),
- % module_info_incr_errors(!ModuleInfo)
+ % !Specs
).
module_add_pragma_import(PredName, PredOrFunc, Modes, Attributes, C_Function,
- Status, Context, !ModuleInfo, !QualInfo, !IO) :-
+ Status, Context, !ModuleInfo, !QualInfo, !Specs) :-
module_info_get_name(!.ModuleInfo, ModuleName),
list.length(Modes, Arity),
- globals.io_lookup_bool_option(very_verbose, VeryVerbose, !IO),
+ module_info_get_globals(!.ModuleInfo, Globals),
+ globals.lookup_bool_option(Globals, very_verbose, VeryVerbose),
(
VeryVerbose = yes,
+ trace [io(!IO)] (
io.write_string("% Processing `:- pragma import' for ", !IO),
write_simple_call_id(PredOrFunc, PredName/Arity, !IO),
io.write_string("...\n", !IO)
+ )
;
VeryVerbose = no
),
@@ -1385,7 +1386,7 @@
;
preds_add_implicit_report_error(ModuleName, PredOrFunc,
PredName, Arity, Status, no, Context, origin_user(PredName),
- "`:- pragma import' declaration", PredId, !ModuleInfo, !IO)
+ "`:- pragma import' declaration", PredId, !ModuleInfo, !Specs)
),
% Lookup the pred_info for this pred, and check that it is valid.
module_info_get_predicate_table(!.ModuleInfo, PredicateTable2),
@@ -1400,17 +1401,20 @@
PredInfo1 = PredInfo0
),
( pred_info_is_imported(PredInfo1) ->
- module_info_incr_errors(!ModuleInfo),
Pieces = [words("Error: `:- pragma import' declaration for imported"),
simple_call(simple_call_id(PredOrFunc, PredName, Arity)),
- suffix(".")],
- write_error_pieces(Context, 0, Pieces, !IO)
+ suffix("."), nl],
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
+ !:Specs = [Spec | !.Specs]
; pred_info_clause_goal_type(PredInfo1) ->
module_info_incr_errors(!ModuleInfo),
Pieces = [words("Error: `:- pragma import' declaration for"),
simple_call(simple_call_id(PredOrFunc, PredName, Arity)),
- words("with preceding clauses.")],
- write_error_pieces(Context, 0, Pieces, !IO)
+ words("with preceding clauses."), nl],
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
+ !:Specs = [Spec | !.Specs]
;
pred_info_update_goal_type(goal_type_foreign, PredInfo1, PredInfo2),
% Add the pragma declaration to the proc_info for this procedure.
@@ -1421,18 +1425,19 @@
!.ModuleInfo, ProcId)
->
pred_add_pragma_import(PredId, ProcId, Attributes, C_Function,
- Context, PredInfo2, PredInfo, !ModuleInfo, !QualInfo, !IO),
+ Context, PredInfo2, PredInfo, !ModuleInfo, !QualInfo, !Specs),
map.det_update(Preds0, PredId, PredInfo, Preds),
predicate_table_set_preds(Preds,
PredicateTable2, PredicateTable),
module_info_set_predicate_table(PredicateTable, !ModuleInfo)
;
- module_info_incr_errors(!ModuleInfo),
Pieces = [words("Error: `:- pragma import' declaration"),
words("for undeclared mode of"),
simple_call(simple_call_id(PredOrFunc, PredName, Arity)),
- suffix(".")],
- write_error_pieces(Context, 0, Pieces, !IO)
+ suffix("."), nl],
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
+ !:Specs = [Spec | !.Specs]
)
).
@@ -1442,15 +1447,16 @@
:- pred pred_add_pragma_import(pred_id::in, proc_id::in,
pragma_foreign_proc_attributes::in, string::in, prog_context::in,
pred_info::in, pred_info::out, module_info::in, module_info::out,
- qual_info::in, qual_info::out, io::di, io::uo) is det.
+ qual_info::in, qual_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
pred_add_pragma_import(PredId, ProcId, Attributes, C_Function, Context,
- !PredInfo, !ModuleInfo, !QualInfo, !IO) :-
+ !PredInfo, !ModuleInfo, !QualInfo, !Specs) :-
pred_info_get_procedures(!.PredInfo, Procs),
map.lookup(Procs, ProcId, ProcInfo),
foreign.make_pragma_import(!.PredInfo, ProcInfo, C_Function, Context,
PragmaImpl, VarSet, PragmaVars, ArgTypes, Arity, PredOrFunc,
- !ModuleInfo, !IO),
+ !ModuleInfo, !Specs),
% Lookup some information we need from the pred_info and proc_info.
PredName = pred_info_name(!.PredInfo),
@@ -1464,7 +1470,7 @@
Purity, Attributes, PredId, ProcId,
VarSet, PragmaVars, ArgTypes, PragmaImpl, Context, PredOrFunc,
qualified(PredModule, PredName), Arity, Markers, Clauses0, Clauses,
- !ModuleInfo, !IO),
+ !ModuleInfo, !Specs),
% Store the clauses_info etc. back into the pred_info.
pred_info_set_clauses_info(Clauses, !PredInfo).
@@ -1473,13 +1479,12 @@
module_add_pragma_foreign_proc(Attributes0, PredName, PredOrFunc, PVars,
ProgVarSet, _InstVarset, PragmaImpl, Status, Context, !ModuleInfo,
- !QualInfo, !IO) :-
- %
+ !QualInfo, !Specs) :-
% Begin by replacing any maybe_thread_safe foreign_proc attributes
% with the actual thread safety attributes which we get from the
% `--maybe-thread-safe' option.
- %
- globals.io_get_globals(Globals, !IO),
+
+ module_info_get_globals(!.ModuleInfo, Globals),
globals.get_maybe_thread_safe(Globals, MaybeThreadSafe),
ThreadSafe = get_thread_safe(Attributes0),
(
@@ -1500,17 +1505,19 @@
module_info_get_name(!.ModuleInfo, ModuleName),
PragmaForeignLanguage = get_foreign_language(Attributes),
list.length(PVars, Arity),
- globals.io_lookup_bool_option(very_verbose, VeryVerbose, !IO),
+ globals.lookup_bool_option(Globals, very_verbose, VeryVerbose),
(
VeryVerbose = yes,
+ trace [io(!IO)] (
io.write_string("% Processing `:- pragma foreign_proc' for ", !IO),
write_simple_call_id(PredOrFunc, PredName/Arity, !IO),
io.write_string("...\n", !IO)
+ )
;
VeryVerbose = no
),
- globals.io_get_backend_foreign_languages(BackendForeignLangs, !IO),
+ globals.get_backend_foreign_languages(Globals, BackendForeignLangs),
% Lookup the pred declaration in the predicate table.
% (If it's not there, print an error message and insert
@@ -1525,7 +1532,7 @@
preds_add_implicit_report_error(ModuleName, PredOrFunc,
PredName, Arity, Status, no, Context, origin_user(PredName),
"`:- pragma foreign_proc' declaration",
- PredId, !ModuleInfo, !IO)
+ PredId, !ModuleInfo, !Specs)
),
% Lookup the pred_info for this pred, add the pragma to the proc_info
@@ -1566,7 +1573,7 @@
;
true
),
- lookup_current_backend(CurrentBackend, !IO),
+ CurrentBackend = lookup_current_backend(Globals),
(
ExtraAttrs = get_extra_attributes(Attributes),
is_applicable_for_current_backend(CurrentBackend, ExtraAttrs) = no
@@ -1576,13 +1583,14 @@
;
pred_info_is_imported(!.PredInfo)
->
- module_info_incr_errors(!ModuleInfo),
Pieces = [words("Error: `:- pragma foreign_proc'"),
words("(or `pragma c_code')"),
words("declaration for imported"),
simple_call(simple_call_id(PredOrFunc, PredName, Arity)),
- suffix(".")],
- write_error_pieces(Context, 0, Pieces, !IO)
+ suffix("."), nl],
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
+ !:Specs = [Spec | !.Specs]
;
% Don't add clauses for foreign languages other than the ones
% we can generate code for.
@@ -1618,7 +1626,7 @@
clauses_info_add_pragma_foreign_proc(standard_foreign_proc,
Purity, Attributes, PredId, ProcId, ProgVarSet, PVars,
ArgTypes, PragmaImpl, Context, PredOrFunc, PredName,
- Arity, Markers, Clauses0, Clauses, !ModuleInfo, !IO),
+ Arity, Markers, Clauses0, Clauses, !ModuleInfo, !Specs),
pred_info_set_clauses_info(Clauses, !PredInfo),
pred_info_update_goal_type(goal_type_foreign, !PredInfo),
map.det_update(Preds0, PredId, !.PredInfo, Preds),
@@ -1626,14 +1634,17 @@
module_info_set_predicate_table(PredTable, !ModuleInfo),
pragma_get_var_infos(PVars, ArgInfoBox),
assoc_list.keys(ArgInfoBox, ArgInfo),
- maybe_warn_pragma_singletons(PragmaImpl, PragmaForeignLanguage,
- ArgInfo, Context, SimpleCallId, !.ModuleInfo, !IO)
+ warn_singletons_in_pragma_foreign_proc(PragmaImpl,
+ PragmaForeignLanguage, ArgInfo, Context, SimpleCallId,
+ !.ModuleInfo, !Specs)
;
- module_info_incr_errors(!ModuleInfo),
Pieces = [words("Error: `:- pragma foreign_proc' declaration"),
words("for undeclared mode of"),
- simple_call(SimpleCallId), suffix(".")],
- write_error_pieces(Context, 0, Pieces, !IO)
+ simple_call(SimpleCallId), suffix("."), nl],
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds,
+ [Msg]),
+ !:Specs = [Spec | !.Specs]
)
)
).
@@ -1642,7 +1653,7 @@
module_add_pragma_tabled(EvalMethod, PredName, Arity, MaybePredOrFunc,
MaybeModes, MaybeAttributes, !Status, Context, !ModuleInfo,
- !QualInfo, !IO) :-
+ !QualInfo, !Specs) :-
module_info_get_predicate_table(!.ModuleInfo, PredicateTable0),
EvalMethodStr = eval_method_to_string(EvalMethod),
(
@@ -1663,7 +1674,7 @@
Message1),
preds_add_implicit_report_error(ModuleName, PredOrFunc, PredName,
Arity, !.Status, no, Context, origin_user(PredName), Message1,
- PredId, !ModuleInfo, !IO),
+ PredId, !ModuleInfo, !Specs),
PredIds = [PredId]
)
;
@@ -1679,7 +1690,7 @@
Message1),
preds_add_implicit_report_error(ModuleName, predicate, PredName,
Arity, !.Status, no, Context, origin_user(PredName), Message1,
- PredId, !ModuleInfo, !IO),
+ PredId, !ModuleInfo, !Specs),
PredIds = [PredId]
)
),
@@ -1694,9 +1705,11 @@
words("for the ambiguous name"),
sym_name_and_arity(PredName / Arity), suffix(","),
words("since the compiler-generated statistics predicate"),
- words("would have an ambiguous name too.")],
- write_error_pieces(Context, 0, StatsPieces, !IO),
- io.set_exit_status(1, !IO)
+ words("would have an ambiguous name too."), nl],
+ StatsMsg = simple_msg(Context, [always(StatsPieces)]),
+ StatsSpec = error_spec(severity_error,
+ phase_parse_tree_to_hlds, [StatsMsg]),
+ !:Specs = [StatsSpec | !.Specs]
;
Statistics = table_dont_gather_statistics
),
@@ -1706,9 +1719,11 @@
words("for the ambiguous name"),
sym_name_and_arity(PredName / Arity), suffix(","),
words("since the compiler-generated reset predicate"),
- words("would have an ambiguous name too.")],
- write_error_pieces(Context, 0, ResetPieces, !IO),
- io.set_exit_status(1, !IO)
+ words("would have an ambiguous name too."), nl],
+ ResetMsg = simple_msg(Context, [always(ResetPieces)]),
+ ResetSpec = error_spec(severity_error,
+ phase_parse_tree_to_hlds, [ResetMsg]),
+ !:Specs = [ResetSpec | !.Specs]
;
AllowReset = table_dont_allow_reset
)
@@ -1721,20 +1736,22 @@
list.foldl4(
module_add_pragma_tabled_2(EvalMethod, PredName, Arity,
MaybePredOrFunc, MaybeModes, MaybeAttributes, Context),
- PredIds, !Status, !ModuleInfo, !QualInfo, !IO).
+ PredIds, !Status, !ModuleInfo, !QualInfo, !Specs).
:- pred module_add_pragma_tabled_2(eval_method::in, sym_name::in, int::in,
maybe(pred_or_func)::in, maybe(list(mer_mode))::in,
maybe(table_attributes)::in, prog_context::in, pred_id::in,
import_status::in, import_status::out, module_info::in, module_info::out,
- qual_info::in, qual_info::out, io::di, io::uo) is det.
+ qual_info::in, qual_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
module_add_pragma_tabled_2(EvalMethod0, PredName, Arity0, MaybePredOrFunc,
MaybeModes, MaybeAttributes, Context, PredId,
- !Status, !ModuleInfo, !QualInfo, !IO) :-
+ !Status, !ModuleInfo, !QualInfo, !Specs) :-
+ module_info_get_globals(!.ModuleInfo, Globals),
( EvalMethod0 = eval_minimal(_) ->
- globals.io_lookup_bool_option(use_minimal_model_own_stacks,
- OwnStacks, !IO),
+ globals.lookup_bool_option(Globals, use_minimal_model_own_stacks,
+ OwnStacks),
(
OwnStacks = yes,
EvalMethod = eval_minimal(own_stacks)
@@ -1759,14 +1776,16 @@
adjust_func_arity(PredOrFunc, Arity0, Arity),
EvalMethodStr = eval_method_to_string(EvalMethod),
- globals.io_lookup_bool_option(very_verbose, VeryVerbose, !IO),
+ globals.lookup_bool_option(Globals, very_verbose, VeryVerbose),
(
VeryVerbose = yes,
+ trace [io(!IO)] (
io.write_string("% Processing `:- pragma ", !IO),
io.write_string(EvalMethodStr, !IO),
io.write_string("' for ", !IO),
write_simple_call_id(PredOrFunc, PredName/Arity, !IO),
io.write_string("...\n", !IO)
+ )
;
VeryVerbose = no
),
@@ -1774,34 +1793,35 @@
% Issue a warning if this predicate/function has a pragma inline
% declaration. Tabled procedures cannot be inlined.
pred_info_get_markers(PredInfo0, Markers),
- globals.io_lookup_bool_option(warn_table_with_inline, WarnInline, !IO),
+ globals.lookup_bool_option(Globals, warn_table_with_inline, WarnInline),
SimpleCallId = simple_call_id(PredOrFunc, PredName, Arity),
(
check_marker(Markers, marker_user_marked_inline),
WarnInline = yes
->
TablePragmaStr = string.format("`:- pragma %s'", [s(EvalMethodStr)]),
- InlineWarning = [
- words("Warning: "), simple_call(SimpleCallId),
+ InlineWarningPieces = [words("Warning: "), simple_call(SimpleCallId),
words("has a"), fixed(TablePragmaStr),
words("declaration but also has a"),
- fixed("`:- pragma inline'"), words("declaration."), nl,
+ quote(":- pragma inline"), words("declaration."), nl,
words("This inline pragma will be ignored"),
words("since tabled predicates cannot be inlined."), nl,
words("You can use the"), fixed("`--no-warn-table-with-inline'"),
- words("option to suppress this warning.")
- ],
- error_util.report_warning(Context, 0, InlineWarning, !IO)
+ words("option to suppress this warning."), nl],
+ InlineWarningMsg = simple_msg(Context, [always(InlineWarningPieces)]),
+ InlineWarningSpec = error_spec(severity_warning,
+ phase_parse_tree_to_hlds, [InlineWarningMsg]),
+ !:Specs = [InlineWarningSpec | !.Specs]
;
true
),
( pred_info_is_imported(PredInfo0) ->
- module_info_incr_errors(!ModuleInfo),
- Pieces1 = [words("Error: "),
- fixed("`:- pragma " ++ EvalMethodStr ++ "'"),
- words("declaration for imported"),
- simple_call(SimpleCallId), suffix(".")],
- write_error_pieces(Context, 0, Pieces1, !IO)
+ Pieces = [words("Error: "), quote(":- pragma " ++ EvalMethodStr),
+ words("declaration for imported"), simple_call(SimpleCallId),
+ suffix("."), nl],
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
+ !:Specs = [Spec | !.Specs]
;
% Do we have to make sure the tabled preds are stratified?
( eval_method_needs_stratification(EvalMethod) = yes ->
@@ -1824,28 +1844,32 @@
map.lookup(ProcTable0, ProcId, ProcInfo0),
set_eval_method_create_aux_preds(ProcId, ProcInfo0, Context,
SimpleCallId, yes, EvalMethod, MaybeAttributes,
- ProcTable0, ProcTable,
- !Status, !ModuleInfo, !QualInfo, !IO),
+ ProcTable0, ProcTable, !Status, !ModuleInfo, !QualInfo,
+ !Specs),
pred_info_set_procedures(ProcTable, PredInfo0, PredInfo),
module_info_set_pred_info(PredId, PredInfo, !ModuleInfo)
;
- module_info_incr_errors(!ModuleInfo),
- Pieces2 = [words("Error:"),
+ Pieces = [words("Error:"),
fixed("`:- pragma " ++ EvalMethodStr ++ "'"),
words("declaration for undeclared mode of"),
simple_call(SimpleCallId), suffix(".")],
- write_error_pieces(Context, 0, Pieces2, !IO)
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds,
+ [Msg]),
+ !:Specs = [Spec | !.Specs]
)
;
MaybeModes = no,
(
ExistingProcs = [],
- module_info_incr_errors(!ModuleInfo),
- Pieces3 = [words("Error: "),
- fixed("`:- pragma " ++ EvalMethodStr ++ "'"),
+ Pieces = [words("Error: "),
+ quote(":- pragma " ++ EvalMethodStr),
words("declaration for"), simple_call(SimpleCallId),
- words("with no declared modes.")],
- write_error_pieces(Context, 0, Pieces3, !IO)
+ words("with no declared modes."), nl],
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds,
+ [Msg]),
+ !:Specs = [Spec | !.Specs]
;
ExistingProcs = [_ | ExistingProcsTail],
(
@@ -1857,8 +1881,8 @@
),
set_eval_method_create_aux_preds_list(ExistingProcs, Context,
SimpleCallId, SingleProc, EvalMethod, MaybeAttributes,
- ProcTable0, ProcTable,
- !Status, !ModuleInfo, !QualInfo, !IO),
+ ProcTable0, ProcTable, !Status, !ModuleInfo, !QualInfo,
+ !Specs),
pred_info_set_procedures(ProcTable, PredInfo0, PredInfo),
module_info_set_pred_info(PredId, PredInfo, !ModuleInfo)
)
@@ -1870,29 +1894,30 @@
bool::in, eval_method::in, maybe(table_attributes)::in,
proc_table::in, proc_table::out, import_status::in, import_status::out,
module_info::in, module_info::out, qual_info::in, qual_info::out,
- io::di, io::uo) is det.
+ list(error_spec)::in, list(error_spec)::out) is det.
set_eval_method_create_aux_preds_list([], _, _, _, _, _, !ProcTable,
- !Status, !ModuleInfo, !QualInfo, !IO).
+ !Status, !ModuleInfo, !QualInfo, !Specs).
set_eval_method_create_aux_preds_list([ProcId - ProcInfo0 | Rest], Context,
SimpleCallId, SingleProc, EvalMethod, MaybeAttributes, !ProcTable,
- !Status, !ModuleInfo, !QualInfo, !IO) :-
+ !Status, !ModuleInfo, !QualInfo, !Specs) :-
set_eval_method_create_aux_preds(ProcId, ProcInfo0, Context, SimpleCallId,
SingleProc, EvalMethod, MaybeAttributes, !ProcTable,
- !Status, !ModuleInfo, !QualInfo, !IO),
+ !Status, !ModuleInfo, !QualInfo, !Specs),
set_eval_method_create_aux_preds_list(Rest, Context, SimpleCallId,
SingleProc, EvalMethod, MaybeAttributes, !ProcTable,
- !Status, !ModuleInfo, !QualInfo, !IO).
+ !Status, !ModuleInfo, !QualInfo, !Specs).
:- pred set_eval_method_create_aux_preds(proc_id::in, proc_info::in,
prog_context::in, simple_call_id::in, bool::in, eval_method::in,
maybe(table_attributes)::in, proc_table::in, proc_table::out,
import_status::in, import_status::out, module_info::in, module_info::out,
- qual_info::in, qual_info::out, io::di, io::uo) is det.
+ qual_info::in, qual_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
set_eval_method_create_aux_preds(ProcId, ProcInfo0, Context, SimpleCallId,
SingleProc, EvalMethod, MaybeAttributes, !ProcTable,
- !Status, !ModuleInfo, !QualInfo, !IO) :-
+ !Status, !ModuleInfo, !QualInfo, !Specs) :-
proc_info_get_eval_method(ProcInfo0, OldEvalMethod),
% NOTE: We don't bother detecting multiple tabling pragmas
% of the same type here.
@@ -1903,31 +1928,30 @@
( OldEvalMethod = EvalMethod ->
Pieces = [words("Error:"), simple_call(SimpleCallId),
words("has duplicate"), fixed(EvalMethodStr),
- words("pragmas specified.")
- ]
+ words("pragmas specified."), nl]
;
OldEvalMethodStr = eval_method_to_string(OldEvalMethod),
Pieces = [words("Error:"), simple_call(SimpleCallId),
words("has both"), fixed(OldEvalMethodStr), words("and"),
fixed(EvalMethodStr), words("pragmas specified."),
- words("Only one kind of tabling pragma may be applied to it.")
- ]
+ words("Only one kind of tabling pragma may be applied to it."),
+ nl]
),
- module_info_incr_errors(!ModuleInfo),
- write_error_pieces(Context, 0, Pieces, !IO)
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
+ !:Specs = [Spec | !.Specs]
;
proc_info_get_maybe_declared_argmodes(ProcInfo0,
MaybeDeclaredArgModes),
(
MaybeDeclaredArgModes = no,
EvalMethodStr = eval_method_to_string(EvalMethod),
- Pieces = [words("Error:"),
- fixed("`pragma" ++ EvalMethodStr ++ "'"),
+ Pieces = [words("Error:"), quote("pragma " ++ EvalMethodStr),
words("declaration for"), simple_call(SimpleCallId),
- suffix(","), words("which has no declared modes.")
- ],
- module_info_incr_errors(!ModuleInfo),
- write_error_pieces(Context, 0, Pieces, !IO)
+ suffix(","), words("which has no declared modes."), nl],
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
+ !:Specs = [Spec | !.Specs]
;
MaybeDeclaredArgModes = yes(DeclaredArgModes),
(
@@ -1954,10 +1978,11 @@
Pieces = [words("Error in"),
fixed("`pragma " ++ EvalMethodStr ++ "'"),
words("declaration for"), simple_call(SimpleCallId),
- suffix(":"), nl, fixed(ArgMsg), words(ErrorMsg)
- ],
- module_info_incr_errors(!ModuleInfo),
- write_error_pieces(Context, 0, Pieces, !IO)
+ suffix(":"), nl, fixed(ArgMsg), words(ErrorMsg), nl],
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds,
+ [Msg]),
+ !:Specs = [Spec | !.Specs]
;
MaybeError = no
),
@@ -1973,7 +1998,7 @@
Statistics = table_gather_statistics,
create_tabling_statistics_pred(ProcId, Context,
SimpleCallId, SingleProc, !ProcTable,
- !Status, !ModuleInfo, !QualInfo, !IO)
+ !Status, !ModuleInfo, !QualInfo, !Specs)
;
Statistics = table_dont_gather_statistics
),
@@ -1981,7 +2006,7 @@
AllowReset = table_allow_reset,
create_tabling_reset_pred(ProcId, Context,
SimpleCallId, SingleProc, !ProcTable,
- !Status, !ModuleInfo, !QualInfo, !IO)
+ !Status, !ModuleInfo, !QualInfo, !Specs)
;
AllowReset = table_dont_allow_reset
)
@@ -1991,10 +2016,11 @@
:- pred create_tabling_statistics_pred(proc_id::in, prog_context::in,
simple_call_id::in, bool::in, proc_table::in, proc_table::out,
import_status::in, import_status::out, module_info::in, module_info::out,
- qual_info::in, qual_info::out, io::di, io::uo) is det.
+ qual_info::in, qual_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
create_tabling_statistics_pred(ProcId, Context, SimpleCallId, SingleProc,
- !ProcTable, !Status, !ModuleInfo, !QualInfo, !IO) :-
+ !ProcTable, !Status, !ModuleInfo, !QualInfo, !Specs) :-
mercury_table_builtin_module(TableBuiltinModule),
StatsTypeName = qualified(TableBuiltinModule, "proc_table_statistics"),
StatsType = defined_type(StatsTypeName, [], kind_star),
@@ -2018,7 +2044,7 @@
yes(detism_det), Condition, purity_pure, Constraints),
ItemStatus0 = item_status(!.Status, may_be_unqualified),
add_item_decl_pass_1(StatsPredDecl, Context, ItemStatus0, _,
- !ModuleInfo, _, !IO),
+ !ModuleInfo, _, !Specs),
some [!Attrs, !VarSet] (
!:Attrs = default_attributes(lang_c),
@@ -2046,15 +2072,16 @@
yes(Context))))
),
add_item_clause(StatsPredClause, !Status, Context, !ModuleInfo,
- !QualInfo, !IO).
+ !QualInfo, !Specs).
:- pred create_tabling_reset_pred(proc_id::in, prog_context::in,
simple_call_id::in, bool::in, proc_table::in, proc_table::out,
import_status::in, import_status::out, module_info::in, module_info::out,
- qual_info::in, qual_info::out, io::di, io::uo) is det.
+ qual_info::in, qual_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
create_tabling_reset_pred(ProcId, Context, SimpleCallId, SingleProc,
- !ProcTable, !Status, !ModuleInfo, !QualInfo, !IO) :-
+ !ProcTable, !Status, !ModuleInfo, !QualInfo, !Specs) :-
ArgDecl1 = type_and_mode(io_state_type, di_mode),
ArgDecl2 = type_and_mode(io_state_type, uo_mode),
ArgDecls = [ArgDecl1, ArgDecl2],
@@ -2074,7 +2101,7 @@
yes(detism_det), Condition, purity_pure, Constraints),
ItemStatus0 = item_status(!.Status, may_be_unqualified),
add_item_decl_pass_1(ResetPredDecl, Context, ItemStatus0, _,
- !ModuleInfo, _, !IO),
+ !ModuleInfo, _, !Specs),
some [!Attrs, !VarSet] (
!:Attrs = default_attributes(lang_c),
@@ -2097,7 +2124,7 @@
yes(Context))))
),
add_item_clause(ResetPredClause, !Status, Context, !ModuleInfo,
- !QualInfo, !IO).
+ !QualInfo, !Specs).
:- func tabling_stats_pred_name(simple_call_id, proc_id, bool) = sym_name.
@@ -2271,7 +2298,7 @@
pragma_get_var_infos(PragmaVars, Infos).
module_add_pragma_fact_table(Pred, Arity, FileName, Status, Context,
- !ModuleInfo, !QualInfo, !IO) :-
+ !ModuleInfo, !QualInfo, !Specs) :-
module_info_get_predicate_table(!.ModuleInfo, PredicateTable),
(
predicate_table_search_sym_arity(PredicateTable, is_fully_qualified,
@@ -2283,9 +2310,18 @@
module_info_pred_info(!.ModuleInfo, PredID, PredInfo0),
% Compile the fact table into a separate .o file.
+ % We should be able to dispense with the impure shenanigans
+ % when we replace fact tables with fast code for large
+ % disjunctions.
+ some [!IO] (
+ promise_pure (
+ semipure private_builtin.trace_get_io_state(!:IO),
fact_table_compile_facts(Pred, Arity, FileName,
PredInfo0, PredInfo, Context, !.ModuleInfo,
C_HeaderCode, PrimaryProcID, !IO),
+ impure private_builtin.trace_set_io_state(!.IO)
+ )
+ ),
module_info_set_pred_info(PredID, PredInfo, !ModuleInfo),
pred_info_get_procedures(PredInfo, ProcTable),
@@ -2300,27 +2336,22 @@
module_add_fact_table_file(FileName, !ModuleInfo),
- io.get_exit_status(ExitStatus, !IO),
- ( ExitStatus = 1 ->
- true
- ;
% Create foreign_procs to access the table in each mode.
- module_add_fact_table_procedures(ProcIDs,
- PrimaryProcID, ProcTable, Pred,
- PredOrFunc, NumArgs, ArgTypes, Status,
- Context, !ModuleInfo, !QualInfo, !IO)
- )
+ module_add_fact_table_procedures(ProcIDs, PrimaryProcID,
+ ProcTable, Pred, PredOrFunc, NumArgs, ArgTypes, Status,
+ Context, !ModuleInfo, !QualInfo, !Specs)
;
PredIDs1 = [_ | _], % >1 predicate found
- io.set_exit_status(1, !IO),
Pieces = [words("In pragma fact_table for"),
sym_name_and_arity(Pred/Arity), suffix(":"), nl,
- words("error: ambiguous predicate/function name.")],
- write_error_pieces(Context, 0, Pieces, !IO)
+ words("error: ambiguous predicate/function name."), nl],
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
+ !:Specs = [Spec | !.Specs]
)
;
undefined_pred_or_func_error(Pred, Arity, Context,
- "`:- pragma fact_table' declaration", !IO)
+ "`:- pragma fact_table' declaration", !Specs)
).
% Add a `pragma c_code' for each mode of the fact table lookup to the
@@ -2332,36 +2363,47 @@
proc_table::in, sym_name::in, pred_or_func::in, arity::in,
list(mer_type)::in, import_status::in, prog_context::in,
module_info::in, module_info::out, qual_info::in, qual_info::out,
- io::di, io::uo) is det.
+ list(error_spec)::in, list(error_spec)::out) is det.
module_add_fact_table_procedures([],_,_,_,_,_,_,_,_, !ModuleInfo, !QualInfo,
- !IO).
+ !Specs).
module_add_fact_table_procedures([ProcID | ProcIDs], PrimaryProcID, ProcTable,
SymName, PredOrFunc, Arity, ArgTypes, Status, Context,
- !ModuleInfo, !QualInfo, !IO) :-
+ !ModuleInfo, !QualInfo, !Specs) :-
module_add_fact_table_proc(ProcID, PrimaryProcID, ProcTable, SymName,
PredOrFunc, Arity, ArgTypes, Status, Context,
- !ModuleInfo, !QualInfo, !IO),
+ !ModuleInfo, !QualInfo, !Specs),
module_add_fact_table_procedures(ProcIDs, PrimaryProcID, ProcTable,
SymName, PredOrFunc, Arity, ArgTypes, Status, Context,
- !ModuleInfo, !QualInfo, !IO).
+ !ModuleInfo, !QualInfo, !Specs).
:- pred module_add_fact_table_proc(proc_id::in, proc_id::in, proc_table::in,
sym_name::in, pred_or_func::in, arity::in, list(mer_type)::in,
import_status::in, prog_context::in, module_info::in, module_info::out,
- qual_info::in, qual_info::out, io::di, io::uo) is det.
+ qual_info::in, qual_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
module_add_fact_table_proc(ProcID, PrimaryProcID, ProcTable, SymName,
PredOrFunc, Arity, ArgTypes, Status, Context, !ModuleInfo, !QualInfo,
- !IO) :-
+ !Specs) :-
map.lookup(ProcTable, ProcID, ProcInfo),
varset.init(ProgVarSet0),
varset.new_vars(ProgVarSet0, Arity, Vars, ProgVarSet),
proc_info_get_argmodes(ProcInfo, Modes),
proc_info_get_inst_varset(ProcInfo, InstVarSet),
fact_table_pragma_vars(Vars, Modes, ProgVarSet, PragmaVars),
- fact_table_generate_c_code(SymName, PragmaVars, ProcID, PrimaryProcID,
- ProcInfo, ArgTypes, !.ModuleInfo, C_ProcCode, C_ExtraCode, !IO),
+
+ % We should be able to dispense with the impure shenanigans
+ % when we replace fact tables with fast code for large disjunctions.
+ some [!IO] (
+ promise_pure (
+ semipure private_builtin.trace_get_io_state(!:IO),
+ fact_table_generate_c_code(SymName, PragmaVars, ProcID,
+ PrimaryProcID, ProcInfo, ArgTypes, !.ModuleInfo,
+ C_ProcCode, C_ExtraCode, !IO),
+ impure private_builtin.trace_set_io_state(!.IO)
+ )
+ ),
Attrs0 = default_attributes(lang_c),
set_may_call_mercury(proc_will_not_call_mercury, Attrs0, Attrs1),
@@ -2371,20 +2413,18 @@
add_extra_attribute(refers_to_llds_stack, Attrs3, Attrs),
module_add_pragma_foreign_proc(Attrs, SymName, PredOrFunc, PragmaVars,
ProgVarSet, InstVarSet, fc_impl_ordinary(C_ProcCode, no), Status,
- Context, !ModuleInfo, !QualInfo, !IO),
+ Context, !ModuleInfo, !QualInfo, !Specs),
( C_ExtraCode = "" ->
true
;
module_add_foreign_body_code(lang_c, C_ExtraCode, Context, !ModuleInfo)
),
- %
- % The C code for fact tables includes C labels;
- % we cannot inline this code, because if we try,
- % the result may be duplicate labels in the generated code.
- % So we must disable inlining for fact_table procedures.
- %
+
+ % The C code for fact tables includes C labels; we cannot inline this code,
+ % because if we try, the result may be duplicate labels in the generated
+ % code. So we must disable inlining for fact_table procedures.
add_pred_marker("fact_table", SymName, Arity, Status, Context,
- marker_user_marked_no_inline, [], !ModuleInfo, !IO).
+ marker_user_marked_no_inline, [], !ModuleInfo, !Specs).
% Create a list(pragma_var) that looks like the ones that are created
% for foreign_proc in prog_io.m.
@@ -2426,42 +2466,38 @@
pragma_foreign_code_impl::in, prog_context::in, pred_or_func::in,
sym_name::in, arity::in, pred_markers::in,
clauses_info::in, clauses_info::out, module_info::in, module_info::out,
- io::di, io::uo) is det.
+ list(error_spec)::in, list(error_spec)::out) is det.
clauses_info_add_pragma_foreign_proc(Origin, Purity, Attributes0,
PredId, ProcId, PVarSet, PVars, OrigArgTypes, PragmaImpl0,
Context, PredOrFunc, PredName, Arity, Markers, !ClausesInfo,
- !ModuleInfo, !IO) :-
+ !ModuleInfo, !Specs) :-
!.ClausesInfo = clauses_info(VarSet0, ExplicitVarTypes, TVarNameMap,
InferredVarTypes, HeadVars, ClauseRep, RttiVarMaps,
_HasForeignClauses),
get_clause_list(ClauseRep, ClauseList),
- % Find all the existing clauses for this mode, and
- % extract their implementation language and clause number
- % (that is, their index in the list).
- globals.io_get_globals(Globals, !IO),
- globals.io_get_target(Target, !IO),
+ % Find all the existing clauses for this mode, and extract their
+ % implementation language and clause number (that is, their index
+ % in the list).
+ module_info_get_globals(!.ModuleInfo, Globals),
+ globals.get_target(Globals, Target),
NewLang = get_foreign_language(Attributes0),
list.foldl2(decide_action(Globals, Target, NewLang, ProcId), ClauseList,
add, FinalAction, 1, _),
- globals.io_get_backend_foreign_languages(BackendForeignLanguages, !IO),
+ globals.get_backend_foreign_languages(Globals, BackendForeignLanguages),
pragma_get_vars(PVars, Args0),
pragma_get_var_infos(PVars, ArgInfo),
- %
% If the foreign language not one of the backend languages, we will
% have to generate an interface to it in a backend language.
- %
foreign.extrude_pragma_implementation(BackendForeignLanguages,
PVars, PredName, PredOrFunc, Context, !ModuleInfo,
Attributes0, Attributes1, PragmaImpl0, PragmaImpl),
- %
% Check for arguments occurring multiple times.
- %
bag.init(ArgBag0),
bag.insert_list(ArgBag0, Args0, ArgBag),
bag.to_assoc_list(ArgBag, ArgBagAL0),
@@ -2474,29 +2510,30 @@
(
MultipleArgs = [_ | _],
- io.set_exit_status(1, !IO),
adjust_func_arity(PredOrFunc, OrigArity, Arity),
SimpleCallId = simple_call_id(PredOrFunc, PredName, OrigArity),
Pieces1 = [words("In `:- pragma foreign_proc' declaration for"),
simple_call(SimpleCallId), suffix(":"), nl],
(
MultipleArgs = [MultipleArg],
- Pieces2 = [words("error: variable `" ++
- mercury_var_to_string(MultipleArg, PVarSet, no) ++
- "' occurs multiple times in the argument list.")]
+ Pieces2 = [words("error: variable"),
+ quote(mercury_var_to_string(MultipleArg, PVarSet, no)),
+ words("occurs multiple times in the argument list.")]
;
MultipleArgs = [_, _ | _],
- Pieces2 = [words("error: variables `" ++
- mercury_vars_to_string(MultipleArgs, PVarSet, no) ++
- "' occur multiple times in the argument list.")]
+ Pieces2 = [words("error: variables"),
+ quote(mercury_vars_to_string(MultipleArgs, PVarSet, no)),
+ words("occur multiple times in the argument list.")]
),
- write_error_pieces(Context, 0, Pieces1 ++ Pieces2, !IO)
+ Msg = simple_msg(Context, [always(Pieces1 ++ Pieces2)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
+ !:Specs = [Spec | !.Specs]
;
MultipleArgs = [],
% Build the foreign_proc.
goal_info_init(GoalInfo0),
goal_info_set_context(Context, GoalInfo0, GoalInfo1),
- %
+
% Check that the purity of a predicate/function declaration agrees with
% the (promised) purity of the foreign proc. We do not perform this
% check there is a promise_{pure,semipure} pragma for the
@@ -2506,7 +2543,6 @@
% in spurious error messages about non-existent foreign_procs. For
% that case we assume that the code that constructs the foreign_procs
% from the import pragmas sets the purity attributes correctly.
- %
(
( Origin = pragma_import_foreign_proc
; check_marker(Markers, marker_promised_pure)
@@ -2521,16 +2557,16 @@
->
purity_name(ForeignAttributePurity, ForeignAttributePurityStr),
purity_name(Purity, PurityStr),
- ErrorMsg = [
- words("Error: foreign clause for"),
- p_or_f(PredOrFunc),
- sym_name_and_arity(PredName / Arity),
- words("has purity " ++ ForeignAttributePurityStr),
+ Pieces = [words("Error: foreign clause for"),
+ p_or_f(PredOrFunc), sym_name_and_arity(PredName / Arity),
+ words("has purity"), words(ForeignAttributePurityStr),
words("but that"), p_or_f(PredOrFunc),
- words("has been declared " ++ PurityStr), suffix(".")
- ],
- write_error_pieces(Context, 0, ErrorMsg, !IO),
- io.set_exit_status(1, !IO)
+ words("has been declared"), words(PurityStr),
+ suffix("."), nl],
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds,
+ [Msg]),
+ !:Specs = [Spec | !.Specs]
;
true
)
@@ -2539,8 +2575,8 @@
goal_info_set_purity(Purity, GoalInfo1, GoalInfo),
make_foreign_args(HeadVars, ArgInfo, OrigArgTypes, ForeignArgs),
% Perform some renaming in any user annotated sharing information.
- maybe_rename_user_annotated_sharing_information(Args0, HeadVars,
- OrigArgTypes, Attributes1, Attributes, !IO),
+ maybe_rename_user_annotated_sharing_information(Globals,
+ Args0, HeadVars, OrigArgTypes, Attributes1, Attributes),
ExtraArgs = [],
MaybeTraceRuntimeCond = no,
HldsGoal0 = call_foreign_proc(Attributes, PredId, ProcId, ForeignArgs,
@@ -2578,15 +2614,15 @@
% is expressed, to the formal variables in terms of which the clause
% is expressed.
%
-:- pred maybe_rename_user_annotated_sharing_information(list(prog_var)::in,
- list(prog_var)::in, list(mer_type)::in,
- pragma_foreign_proc_attributes::in, pragma_foreign_proc_attributes::out,
- io::di, io::uo) is det.
-
-maybe_rename_user_annotated_sharing_information(ActualHeadVars, FormalHeadVars,
- FormalTypes, !Attributes, !IO):-
- globals.io_lookup_bool_option(structure_sharing_analysis, SharingAnalysis,
- !IO),
+:- pred maybe_rename_user_annotated_sharing_information(globals::in,
+ list(prog_var)::in, list(prog_var)::in, list(mer_type)::in,
+ pragma_foreign_proc_attributes::in, pragma_foreign_proc_attributes::out)
+ is det.
+
+maybe_rename_user_annotated_sharing_information(Globals,
+ ActualHeadVars, FormalHeadVars, FormalTypes, !Attributes):-
+ globals.lookup_bool_option(Globals, structure_sharing_analysis,
+ SharingAnalysis),
(
SharingAnalysis = no
;
@@ -2616,8 +2652,8 @@
)
).
-lookup_current_backend(CurrentBackend, !IO) :-
- globals.io_lookup_bool_option(highlevel_code, HighLevel, !IO),
+lookup_current_backend(Globals) = CurrentBackend :-
+ globals.lookup_bool_option(Globals, highlevel_code, HighLevel),
(
HighLevel = yes,
CurrentBackend = high_level_backend
Index: compiler/add_pred.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/add_pred.m,v
retrieving revision 1.23
diff -u -b -r1.23 add_pred.m
--- compiler/add_pred.m 7 Sep 2006 05:50:51 -0000 1.23
+++ compiler/add_pred.m 9 Sep 2006 07:06:18 -0000
@@ -21,10 +21,10 @@
:- import_module hlds.pred_table.
:- import_module mdbcomp.prim_data.
:- import_module hlds.make_hlds.make_hlds_passes.
+:- import_module parse_tree.error_util.
:- import_module parse_tree.prog_data.
:- import_module bool.
-:- import_module io.
:- import_module list.
:- import_module maybe.
:- import_module pair.
@@ -36,7 +36,8 @@
maybe(determinism)::in, purity::in,
prog_constraints::in, pred_markers::in, prog_context::in,
item_status::in, maybe(pair(pred_id, proc_id))::out,
- module_info::in, module_info::out, io::di, io::uo) is det.
+ module_info::in, module_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
:- pred do_add_new_proc(inst_varset::in, arity::in, list(mer_mode)::in,
maybe(list(mer_mode))::in, maybe(list(is_live))::in,
@@ -48,7 +49,8 @@
:- pred module_add_mode(inst_varset::in, sym_name::in, list(mer_mode)::in,
maybe(determinism)::in, import_status::in, prog_context::in,
pred_or_func::in, bool::in, pair(pred_id, proc_id)::out,
- module_info::in, module_info::out, io::di, io::uo) is det.
+ module_info::in, module_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
% Whenever there is a clause or mode declaration for an undeclared
% predicate, we add an implicit declaration
@@ -58,7 +60,8 @@
:- pred preds_add_implicit_report_error(module_name::in, pred_or_func::in,
sym_name::in, arity::in, import_status::in, bool::in, prog_context::in,
pred_origin::in, string::in, pred_id::out,
- module_info::in, module_info::out, io::di, io::uo) is det.
+ module_info::in, module_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
:- pred preds_add_implicit_for_assertion(prog_vars::in, module_info::in,
module_name::in, sym_name::in, arity::in, import_status::in,
@@ -79,7 +82,6 @@
:- import_module libs.compiler_util.
:- import_module libs.globals.
:- import_module libs.options.
-:- import_module parse_tree.error_util.
:- import_module parse_tree.prog_mode.
:- import_module parse_tree.prog_out.
:- import_module parse_tree.prog_type.
@@ -93,10 +95,10 @@
module_add_pred_or_func(TypeVarSet, InstVarSet, ExistQVars,
PredOrFunc, PredName, TypesAndModes, MaybeDet, Purity,
ClassContext, Markers, Context, item_status(Status, NeedQual),
- MaybePredProcId, !ModuleInfo, !IO) :-
+ MaybePredProcId, !ModuleInfo, !Specs) :-
split_types_and_modes(TypesAndModes, Types, MaybeModes0),
add_new_pred(TypeVarSet, ExistQVars, PredName, Types, Purity, ClassContext,
- Markers, Context, Status, NeedQual, PredOrFunc, !ModuleInfo, !IO),
+ Markers, Context, Status, NeedQual, PredOrFunc, !ModuleInfo, !Specs),
(
PredOrFunc = predicate,
MaybeModes0 = yes(Modes0),
@@ -133,7 +135,7 @@
IsClassMethod = no
),
module_add_mode(InstVarSet, PredName, Modes, MaybeDet, Status, Context,
- PredOrFunc, IsClassMethod, PredProcId, !ModuleInfo, !IO),
+ PredOrFunc, IsClassMethod, PredProcId, !ModuleInfo, !Specs),
MaybePredProcId = yes(PredProcId)
;
MaybeModes = no,
@@ -148,11 +150,12 @@
list(mer_type)::in, purity::in, prog_constraints::in,
pred_markers::in, prog_context::in, import_status::in,
need_qualifier::in, pred_or_func::in,
- module_info::in, module_info::out, io::di, io::uo) is det.
+ module_info::in, module_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
add_new_pred(TVarSet, ExistQVars, PredName, Types, Purity, ClassContext,
Markers0, Context, ItemStatus, NeedQual, PredOrFunc, !ModuleInfo,
- !IO) :-
+ !Specs) :-
% Only preds with opt_imported clauses are tagged as opt_imported, so
% that the compiler doesn't look for clauses for other preds read in
% from optimization interfaces.
@@ -166,7 +169,7 @@
(
PredName = unqualified(_PName),
module_info_incr_errors(!ModuleInfo),
- unqualified_pred_error(PredName, Arity, Context, !IO)
+ unqualified_pred_error(PredName, Arity, Context, !Specs)
% All predicate names passed into this predicate should have
% been qualified by prog_io.m, when they were first read.
;
@@ -183,22 +186,15 @@
TVarSet, ExistQVars, ClassContext, Proofs, ConstraintMap,
ClausesInfo, PredInfo0),
(
- predicate_table_search_pf_m_n_a(PredTable0,
- is_fully_qualified, PredOrFunc, MNameOfPred,
- PName, Arity, [OrigPred|_])
+ predicate_table_search_pf_m_n_a(PredTable0, is_fully_qualified,
+ PredOrFunc, MNameOfPred, PName, Arity, [OrigPred | _])
->
module_info_pred_info(!.ModuleInfo, OrigPred, OrigPredInfo),
pred_info_context(OrigPredInfo, OrigContext),
DeclString = pred_or_func_to_str(PredOrFunc),
adjust_func_arity(PredOrFunc, OrigArity, Arity),
multiple_def_error(ItemStatus, PredName, OrigArity, DeclString,
- Context, OrigContext, FoundError, !IO),
- (
- FoundError = yes,
- module_info_incr_errors(!ModuleInfo)
- ;
- FoundError = no
- )
+ Context, OrigContext, [], !Specs)
;
module_info_get_partial_qualifier_info(!.ModuleInfo, PQInfo),
predicate_table_insert_qual(PredInfo0, NeedQual, PQInfo, PredId,
@@ -351,7 +347,7 @@
% - at the moment we just ignore those two arguments.
%
module_add_mode(InstVarSet, PredName, Modes, MaybeDet, Status, MContext,
- PredOrFunc, IsClassMethod, PredProcId, !ModuleInfo, !IO) :-
+ PredOrFunc, IsClassMethod, PredProcId, !ModuleInfo, !Specs) :-
% Lookup the pred or func declaration in the predicate table.
% If it's not there (or if it is ambiguous), optionally print a
% warning message and insert an implicit definition for the
@@ -370,14 +366,14 @@
;
preds_add_implicit_report_error(ModuleName, PredOrFunc, PredName,
Arity, Status, IsClassMethod, MContext, origin_user(PredName),
- "mode declaration", PredId, !ModuleInfo, !IO)
+ "mode declaration", PredId, !ModuleInfo, !Specs)
),
module_info_get_predicate_table(!.ModuleInfo, PredicateTable1),
predicate_table_get_preds(PredicateTable1, Preds0),
map.lookup(Preds0, PredId, PredInfo0),
module_do_add_mode(InstVarSet, Arity, Modes, MaybeDet, IsClassMethod,
- MContext, PredInfo0, PredInfo, ProcId, !IO),
+ MContext, PredInfo0, PredInfo, ProcId, !Specs),
map.det_update(Preds0, PredId, PredInfo, Preds),
predicate_table_set_preds(Preds, PredicateTable1, PredicateTable),
module_info_set_predicate_table(PredicateTable, !ModuleInfo),
@@ -385,11 +381,12 @@
:- pred module_do_add_mode(inst_varset::in, arity::in, list(mer_mode)::in,
maybe(determinism)::in, bool::in, prog_context::in,
- pred_info::in, pred_info::out, proc_id::out, io::di, io::uo) is det.
+ pred_info::in, pred_info::out, proc_id::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
module_do_add_mode(InstVarSet, Arity, Modes, MaybeDet, IsClassMethod, MContext,
- !PredInfo, ProcId, !IO) :-
- % check that the determinism was specified
+ !PredInfo, ProcId, !Specs) :-
+ % Check that the determinism was specified.
(
MaybeDet = no,
pred_info_get_import_status(!.PredInfo, ImportStatus),
@@ -399,19 +396,13 @@
PredSymName = qualified(PredModule, PredName),
( IsClassMethod = yes ->
unspecified_det_for_method(PredSymName, Arity, PredOrFunc,
- MContext, !IO)
+ MContext, !Specs)
; status_is_exported(ImportStatus) = yes ->
unspecified_det_for_exported(PredSymName, Arity, PredOrFunc,
- MContext, !IO)
+ MContext, !Specs)
;
- globals.io_lookup_bool_option(infer_det, InferDet, !IO),
- (
- InferDet = no,
unspecified_det_for_local(PredSymName, Arity, PredOrFunc,
- MContext, !IO)
- ;
- InferDet = yes
- )
+ MContext, !Specs)
)
;
MaybeDet = yes(_)
@@ -423,14 +414,15 @@
preds_add_implicit_report_error(ModuleName, PredOrFunc, PredName, Arity,
Status, IsClassMethod, Context, Origin, Description, PredId,
- !ModuleInfo, !IO) :-
- maybe_undefined_pred_error(PredName, Arity, PredOrFunc, Status,
- IsClassMethod, Context, Description, !IO),
+ !ModuleInfo, !Specs) :-
+ module_info_get_globals(!.ModuleInfo, Globals),
+ maybe_undefined_pred_error(Globals, PredName, Arity, PredOrFunc,
+ Status, IsClassMethod, Context, Description, !Specs),
(
PredOrFunc = function,
adjust_func_arity(function, FuncArity, Arity),
maybe_check_field_access_function(PredName, FuncArity, Status, Context,
- !.ModuleInfo, !IO)
+ !.ModuleInfo, !Specs)
;
PredOrFunc = predicate
),
@@ -497,55 +489,53 @@
%-----------------------------------------------------------------------------%
:- pred unspecified_det_for_local(sym_name::in, arity::in, pred_or_func::in,
- prog_context::in, io::di, io::uo) is det.
+ prog_context::in, list(error_spec)::in, list(error_spec)::out) is det.
-unspecified_det_for_local(Name, Arity, PredOrFunc, Context, !IO) :-
- Pieces = [words("Error: no determinism declaration for local"),
+unspecified_det_for_local(Name, Arity, PredOrFunc, Context, !Specs) :-
+ MainPieces = [words("Error: no determinism declaration for local"),
simple_call(simple_call_id(PredOrFunc, Name, Arity)), suffix(".")],
- write_error_pieces(Context, 0, Pieces, !IO),
- record_warning(!IO),
- globals.io_lookup_bool_option(verbose_errors, VerboseErrors, !IO),
- (
- VerboseErrors = yes,
VerbosePieces = [words("(This is an error because"),
words("you specified the `--no-infer-det' options."),
words("Use the `--infer-det' option if you want the compiler"),
words("to automatically infer the determinism"),
words("of local predicates.)")],
- write_error_pieces(Context, 0, VerbosePieces, !IO)
- ;
- VerboseErrors = no,
- globals.io_set_extra_error_info(yes, !IO)
- ).
+ InnerComponents = [always(MainPieces), verbose_only(VerbosePieces)],
+ Msg = simple_msg(Context,
+ [option_is_set(infer_det, no, InnerComponents)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
+ !:Specs = [Spec | !.Specs].
:- pred unspecified_det_for_method(sym_name::in, arity::in, pred_or_func::in,
- prog_context::in, io::di, io::uo) is det.
+ prog_context::in, list(error_spec)::in, list(error_spec)::out) is det.
-unspecified_det_for_method(Name, Arity, PredOrFunc, Context, !IO) :-
+unspecified_det_for_method(Name, Arity, PredOrFunc, Context, !Specs) :-
Pieces = [words("Error: no determinism declaration"),
words("for type class method"), p_or_f(PredOrFunc),
sym_name_and_arity(Name / Arity), suffix(".")],
- write_error_pieces(Context, 0, Pieces, !IO),
- io.set_exit_status(1, !IO).
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
+ !:Specs = [Spec | !.Specs].
:- pred unspecified_det_for_exported(sym_name::in, arity::in, pred_or_func::in,
- prog_context::in, io::di, io::uo) is det.
+ prog_context::in, list(error_spec)::in, list(error_spec)::out) is det.
-unspecified_det_for_exported(Name, Arity, PredOrFunc, Context, !IO) :-
+unspecified_det_for_exported(Name, Arity, PredOrFunc, Context, !Specs) :-
Pieces = [words("Error: no determinism declaration for exported"),
p_or_f(PredOrFunc), sym_name_and_arity(Name / Arity), suffix(".")],
- write_error_pieces(Context, 0, Pieces, !IO),
- io.set_exit_status(1, !IO).
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
+ !:Specs = [Spec | !.Specs].
:- pred unqualified_pred_error(sym_name::in, int::in, prog_context::in,
- io::di, io::uo) is det.
+ list(error_spec)::in, list(error_spec)::out) is det.
-unqualified_pred_error(PredName, Arity, Context, !IO) :-
+unqualified_pred_error(PredName, Arity, Context, !Specs) :-
Pieces = [words("Internal error: the unqualified predicate name"),
sym_name_and_arity(PredName / Arity),
words("should have been qualified by prog_io.m.")],
- write_error_pieces(Context, 0, Pieces, !IO),
- io.set_exit_status(1, !IO).
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
+ !:Specs = [Spec | !.Specs].
%-----------------------------------------------------------------------------%
Index: compiler/add_solver.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/add_solver.m,v
retrieving revision 1.17
diff -u -b -r1.17 add_solver.m
--- compiler/add_solver.m 22 Aug 2006 05:03:37 -0000 1.17
+++ compiler/add_solver.m 8 Sep 2006 09:15:02 -0000
@@ -14,9 +14,9 @@
:- import_module hlds.make_hlds.make_hlds_passes.
:- import_module hlds.make_hlds.qual_info.
:- import_module mdbcomp.prim_data.
+:- import_module parse_tree.error_util.
:- import_module parse_tree.prog_data.
-:- import_module io.
:- import_module list.
%-----------------------------------------------------------------------------%
@@ -44,12 +44,13 @@
:- pred add_solver_type_decl_items(tvarset::in, sym_name::in,
list(type_param)::in, solver_type_details::in, prog_context::in,
item_status::in, item_status::out, module_info::in, module_info::out,
- io::di, io::uo) is det.
+ list(error_spec)::in, list(error_spec)::out) is det.
:- pred add_solver_type_clause_items(sym_name::in, list(type_param)::in,
solver_type_details::in, import_status::in, import_status::out,
prog_context::in, module_info::in, module_info::out,
- qual_info::in, qual_info::out, io::di, io::uo) is det.
+ qual_info::in, qual_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -70,7 +71,7 @@
%-----------------------------------------------------------------------------%
add_solver_type_decl_items(TVarSet, TypeSymName, TypeParams,
- SolverTypeDetails, Context, !Status, !ModuleInfo, !IO) :-
+ SolverTypeDetails, Context, !Status, !ModuleInfo, !Specs) :-
% XXX kind inference:
% We set the kinds to `star'. This will be different when we have a
@@ -107,7 +108,7 @@
module_add_pred_or_func(TVarSet, InstVarSet, ExistQTVars, function,
ToGroundRepnSymName, ToGroundRepnArgTypes, yes(detism_det),
purity_impure, constraints([], []), NoMarkers, Context, !.Status, _,
- !ModuleInfo, !IO),
+ !ModuleInfo, !Specs),
% The `:- impure
% func 'representation of any st'(st::in(ai)) =
@@ -120,7 +121,7 @@
module_add_pred_or_func(TVarSet, InstVarSet, ExistQTVars, function,
ToAnyRepnSymName, ToAnyRepnArgTypes, yes(detism_det),
purity_impure, constraints([], []), NoMarkers, Context, !.Status, _,
- !ModuleInfo, !IO),
+ !ModuleInfo, !Specs),
% The `:- impure
% func 'representation to ground st'(rt::in(gi)) =
@@ -133,7 +134,7 @@
module_add_pred_or_func(TVarSet, InstVarSet, ExistQTVars, function,
FromGroundRepnSymName, FromGroundRepnArgTypes, yes(detism_det),
purity_impure, constraints([], []), NoMarkers, Context, !.Status, _,
- !ModuleInfo, !IO),
+ !ModuleInfo, !Specs),
% The `:- impure
% func 'representation to any st'(rt::in(ai)) =
@@ -146,7 +147,7 @@
module_add_pred_or_func(TVarSet, InstVarSet, ExistQTVars, function,
FromAnyRepnSymName, FromAnyRepnArgTypes, yes(detism_det),
purity_impure, constraints([], []), NoMarkers, Context, !.Status, _,
- !ModuleInfo, !IO).
+ !ModuleInfo, !Specs).
%-----------------------------------------------------------------------------%
@@ -154,29 +155,34 @@
% the solver type sym_name.
%
:- func solver_to_ground_repn_symname(sym_name, arity) = sym_name.
+
solver_to_ground_repn_symname(SymName, Arity) =
solver_conversion_fn_symname("representation of ground ", SymName, Arity).
:- func solver_to_any_repn_symname(sym_name, arity) = sym_name.
+
solver_to_any_repn_symname(SymName, Arity) =
solver_conversion_fn_symname("representation of any ", SymName, Arity).
:- func repn_to_ground_solver_symname(sym_name, arity) = sym_name.
+
repn_to_ground_solver_symname(SymName, Arity) =
solver_conversion_fn_symname("representation to ground ", SymName, Arity).
:- func repn_to_any_solver_symname(sym_name, arity) = sym_name.
+
repn_to_any_solver_symname(SymName, Arity) =
solver_conversion_fn_symname("representation to any ", SymName, Arity).
:- func solver_conversion_fn_symname(string, sym_name, arity) = sym_name.
+
solver_conversion_fn_symname(Prefix, unqualified(Name), Arity) =
unqualified(Prefix ++ Name ++ "/" ++ int_to_string(Arity)).
solver_conversion_fn_symname(Prefix, qualified(ModuleNames, Name), Arity) =
qualified(ModuleNames, Prefix ++ Name ++ "/" ++ int_to_string(Arity)).
add_solver_type_clause_items(TypeSymName, TypeParams, SolverTypeDetails,
- !Status, Context, !ModuleInfo, !QualInfo, !IO) :-
+ !Status, Context, !ModuleInfo, !QualInfo, !Specs) :-
Arity = length(TypeParams),
AnyInst = SolverTypeDetails ^ any_inst,
@@ -224,7 +230,7 @@
ToGroundRepnItem = item_pragma(compiler(solver_type),
ToGroundRepnForeignProc),
add_item_clause(ToGroundRepnItem, !Status, Context, !ModuleInfo, !QualInfo,
- !IO),
+ !Specs),
% The `func(in(any)) = out(<i_any>) is det' mode.
%
@@ -244,7 +250,7 @@
),
ToAnyRepnItem = item_pragma(compiler(solver_type), ToAnyRepnForeignProc),
add_item_clause(ToAnyRepnItem, !Status, Context, !ModuleInfo, !QualInfo,
- !IO),
+ !Specs),
% The `func(in(<i_ground>)) = out is det' mode.
%
@@ -265,7 +271,7 @@
FromGroundRepnItem = item_pragma(compiler(solver_type),
FromGroundRepnForeignProc),
add_item_clause(FromGroundRepnItem, !Status, Context, !ModuleInfo,
- !QualInfo, !IO),
+ !QualInfo, !Specs),
% The `func(in(<i_any>)) = out(any) is det' mode.
%
@@ -286,7 +292,7 @@
FromAnyRepnItem = item_pragma(compiler(solver_type),
FromAnyRepnForeignProc),
add_item_clause(FromAnyRepnItem, !Status, Context, !ModuleInfo, !QualInfo,
- !IO).
+ !Specs).
%-----------------------------------------------------------------------------%
:- end_module add_solver.
Index: compiler/add_type.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/add_type.m,v
retrieving revision 1.19
diff -u -b -r1.19 add_type.m
--- compiler/add_type.m 7 Sep 2006 05:50:51 -0000 1.19
+++ compiler/add_type.m 9 Sep 2006 07:02:39 -0000
@@ -20,10 +20,10 @@
:- import_module hlds.hlds_module.
:- import_module hlds.make_hlds.make_hlds_passes.
:- import_module mdbcomp.prim_data.
+:- import_module parse_tree.error_util.
:- import_module parse_tree.prog_data.
:- import_module bool.
-:- import_module io.
:- import_module list.
%-----------------------------------------------------------------------------%
@@ -35,13 +35,14 @@
%
:- pred module_add_type_defn(tvarset::in, sym_name::in, list(type_param)::in,
type_defn::in, condition::in, prog_context::in, item_status::in,
- module_info::in, module_info::out, io::di, io::uo) is det.
+ module_info::in, module_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
% Add the constructors and special preds for a type to the HLDS.
%
:- pred process_type_defn(type_ctor::in, hlds_type_defn::in,
bool::in, bool::out, module_info::in, module_info::out,
- io::di, io::uo) is det.
+ list(error_spec)::in, list(error_spec)::out) is det.
:- pred make_status_abstract(import_status::in, import_status::out) is det.
@@ -65,7 +66,6 @@
:- import_module libs.compiler_util.
:- import_module libs.globals.
:- import_module libs.options.
-:- import_module parse_tree.error_util.
:- import_module parse_tree.module_qual.
:- import_module parse_tree.prog_type.
:- import_module parse_tree.prog_out.
@@ -83,8 +83,8 @@
%-----------------------------------------------------------------------------%
module_add_type_defn(TVarSet, Name, Args, TypeDefn, _Cond, Context,
- item_status(Status0, NeedQual), !ModuleInfo, !IO) :-
- globals.io_get_globals(Globals, !IO),
+ item_status(Status0, NeedQual), !ModuleInfo, !Specs) :-
+ module_info_get_globals(!.ModuleInfo, Globals),
list.length(Args, Arity),
TypeCtor = type_ctor(Name, Arity),
convert_type_defn(TypeDefn, TypeCtor, Globals, Body0),
@@ -132,9 +132,7 @@
[always(DummyMainPieces), verbose_only(DummyVerbosePieces)]),
DummySpec = error_spec(severity_error, phase_parse_tree_to_hlds,
[DummyMsg]),
- write_error_spec(DummySpec, 0, _DummyNumWarnings, 0, DummyNumErrors,
- !IO),
- module_info_incr_num_errors(DummyNumErrors, !ModuleInfo)
+ !:Specs = [DummySpec | !.Specs]
;
true
),
@@ -157,9 +155,7 @@
SolverMsg = simple_msg(Context, [always(SolverPieces)]),
SolverSpec = error_spec(severity_error, phase_parse_tree_to_hlds,
[SolverMsg]),
- write_error_spec(SolverSpec, 0, _SolverNumWarnings,
- 0, SolverNumErrors, !IO),
- module_info_incr_num_errors(SolverNumErrors, !ModuleInfo),
+ !:Specs = [SolverSpec | !.Specs],
MaybeOldDefn = no
;
hlds_data.set_type_defn_body(OldBody, OldDefn0, OldDefn),
@@ -187,9 +183,7 @@
ForeignDeclMsg = simple_msg(Context, [always(ForeignDeclPieces)]),
ForeignDeclSpec = error_spec(severity_error, phase_parse_tree_to_hlds,
[ForeignDeclMsg]),
- write_error_spec(ForeignDeclSpec, 0, _ForeignDeclNumWarnings,
- 0, ForeignDeclNumErrors, !IO),
- module_info_incr_num_errors(ForeignDeclNumErrors, !ModuleInfo)
+ !:Specs = [ForeignDeclSpec | !.Specs]
;
MaybeOldDefn = yes(OldDefn1),
Body = hlds_foreign_type(_),
@@ -207,9 +201,7 @@
ForeignVisMsg = simple_msg(Context, [always(ForeignVisPieces)]),
ForeignVisSpec = error_spec(severity_error, phase_parse_tree_to_hlds,
[ForeignVisMsg]),
- write_error_spec(ForeignVisSpec, 0, _ForeignVisNumWarnings,
- 0, ForeignVisNumErrors, !IO),
- module_info_incr_num_errors(ForeignVisNumErrors, !ModuleInfo)
+ !:Specs = [ForeignVisSpec | !.Specs]
;
% If there was an existing non-abstract definition for the type, ...
MaybeOldDefn = yes(T2),
@@ -223,9 +215,9 @@
hlds_data.get_type_defn_need_qualifier(T2, OrigNeedQual),
Body_2 \= hlds_abstract_type(_)
->
- globals.io_get_target(Target, !IO),
- globals.io_lookup_bool_option(make_optimization_interface,
- MakeOptInt, !IO),
+ globals.get_target(Globals, Target),
+ globals.lookup_bool_option(Globals, make_optimization_interface,
+ MakeOptInt),
( Body = hlds_foreign_type(_) ->
module_info_contains_foreign_type(!ModuleInfo)
;
@@ -263,9 +255,7 @@
DiffVisMsg = simple_msg(Context, [always(DiffVisPieces)]),
DiffVisSpec = error_spec(severity_error,
phase_parse_tree_to_hlds, [DiffVisMsg]),
- write_error_spec(DiffVisSpec, 0, _DiffVisNumWarnings,
- 0, DiffVisNumErrors, !IO),
- module_info_incr_num_errors(DiffVisNumErrors, !ModuleInfo)
+ !:Specs = [DiffVisSpec | !.Specs]
)
;
% ..., otherwise issue an error message if the second
@@ -276,7 +266,7 @@
;
module_info_incr_errors(!ModuleInfo),
multiple_def_error(Status, Name, Arity, "type", Context,
- OrigContext, _, !IO)
+ OrigContext, [], !Specs)
)
;
map.set(Types0, TypeCtor, T, Types),
@@ -300,9 +290,7 @@
verbose_only(abstract_monotype_workaround)]),
PolyEqvSpec = error_spec(severity_error, phase_parse_tree_to_hlds,
[PolyEqvMsg]),
- write_error_spec(PolyEqvSpec, 0, _PolyEqvNumWarnings,
- 0, PolyEqvNumErrors, !IO),
- module_info_incr_num_errors(PolyEqvNumErrors, !ModuleInfo)
+ !:Specs = [PolyEqvSpec | !.Specs]
;
true
)
@@ -371,28 +359,34 @@
status_is_exported_to_non_submodules(NewDefnStatus) = no
).
-process_type_defn(TypeCtor, TypeDefn, !FoundError, !ModuleInfo, !IO) :-
- hlds_data.get_type_defn_context(TypeDefn, Context),
- hlds_data.get_type_defn_tvarset(TypeDefn, TVarSet),
- hlds_data.get_type_defn_tparams(TypeDefn, Args),
- hlds_data.get_type_defn_body(TypeDefn, Body),
- hlds_data.get_type_defn_status(TypeDefn, Status),
- hlds_data.get_type_defn_need_qualifier(TypeDefn, NeedQual),
+process_type_defn(TypeCtor, TypeDefn, !FoundError, !ModuleInfo, !Specs) :-
+ get_type_defn_context(TypeDefn, Context),
+ get_type_defn_tvarset(TypeDefn, TVarSet),
+ get_type_defn_tparams(TypeDefn, Args),
+ get_type_defn_body(TypeDefn, Body),
+ get_type_defn_status(TypeDefn, Status),
+ get_type_defn_need_qualifier(TypeDefn, NeedQual),
+ module_info_get_globals(!.ModuleInfo, Globals),
(
Body = hlds_du_type(ConsList, _, _, UserEqCmp, ReservedTag, _),
module_info_get_cons_table(!.ModuleInfo, Ctors0),
module_info_get_partial_qualifier_info(!.ModuleInfo, PQInfo),
- check_for_errors(
- (pred(M0::in, M::out, IO0::di, IO::uo) is det :-
- module_info_get_ctor_field_table(M0, CtorFields0),
+ module_info_get_ctor_field_table(!.ModuleInfo, CtorFields0),
ctors_add(ConsList, TypeCtor, TVarSet, NeedQual, PQInfo,
Context, Status, CtorFields0, CtorFields, Ctors0, Ctors,
- IO0, IO),
- module_info_set_cons_table(Ctors, M0, M1),
- module_info_set_ctor_field_table(CtorFields, M1, M)
- ), NewFoundError, !ModuleInfo, !IO),
+ [], CtorAddSpecs),
+ module_info_set_cons_table(Ctors, !ModuleInfo),
+ module_info_set_ctor_field_table(CtorFields, !ModuleInfo),
+
+ (
+ CtorAddSpecs = [],
+ NewFoundError = no
+ ;
+ CtorAddSpecs = [_ | _],
+ NewFoundError = yes,
+ !:Specs = CtorAddSpecs ++ !.Specs
+ ),
- globals.io_get_globals(Globals, !IO),
(
type_with_constructors_should_be_no_tag(Globals, TypeCtor,
ReservedTag, ConsList, UserEqCmp, Name, CtorArgType, _)
@@ -405,18 +399,15 @@
true
)
;
- Body = hlds_abstract_type(_),
- NewFoundError = no
- ;
- Body = hlds_solver_type(_, _),
- NewFoundError = no
- ;
- Body = hlds_eqv_type(_),
+ ( Body = hlds_abstract_type(_)
+ ; Body = hlds_solver_type(_, _)
+ ; Body = hlds_eqv_type(_)
+ ),
NewFoundError = no
;
Body = hlds_foreign_type(ForeignTypeBody),
check_foreign_type(TypeCtor, ForeignTypeBody, Context,
- NewFoundError, !ModuleInfo, !IO)
+ NewFoundError, !ModuleInfo, !Specs)
),
!:FoundError = !.FoundError `and` NewFoundError,
(
@@ -424,8 +415,8 @@
->
true
;
- % Equivalence types are fully expanded on the IL and Java
- % backends, so the special predicates aren't required.
+ % Equivalence types are fully expanded on the IL and Java backends,
+ % so the special predicates aren't required.
are_equivalence_types_expanded(!.ModuleInfo),
Body = hlds_eqv_type(_)
->
@@ -440,23 +431,22 @@
!ModuleInfo)
).
- % Check_foreign_type ensures that if we are generating code for
- % a specific backend that the foreign type has a representation
- % on that backend.
+ % Check_foreign_type ensures that if we are generating code for a specific
+ % backend that the foreign type has a representation on that backend.
%
:- pred check_foreign_type(type_ctor::in, foreign_type_body::in,
prog_context::in, bool::out, module_info::in, module_info::out,
- io::di, io::uo) is det.
+ list(error_spec)::in, list(error_spec)::out) is det.
check_foreign_type(TypeCtor, ForeignTypeBody, Context, FoundError, !ModuleInfo,
- !IO) :-
+ !Specs) :-
TypeCtor = type_ctor(Name, Arity),
module_info_get_globals(!.ModuleInfo, Globals),
- generating_code(GeneratingCode, !IO),
globals.get_target(Globals, Target),
( have_foreign_type_for_backend(Target, ForeignTypeBody, yes) ->
FoundError = no
;
+ GeneratingCode = generating_code(Globals),
(
GeneratingCode = yes,
( Target = target_c, LangStr = "C"
@@ -474,8 +464,7 @@
option_is_set(very_verbose, yes, [always(VerbosePieces)])]),
Spec = error_spec(severity_error, phase_parse_tree_to_hlds,
[Msg]),
- write_error_spec(Spec, 0, _NumWarnings, 0, NumErrors, !IO),
- module_info_incr_num_errors(NumErrors, !ModuleInfo)
+ !:Specs = [Spec | !.Specs]
;
GeneratingCode = no
% If we're not generating code the error may only have occurred
@@ -484,25 +473,24 @@
FoundError = yes
).
- % Do the options imply that we will generate code for a specific
- % back-end?
+ % Do the options imply that we will generate code for a specific back-end?
%
-:- pred generating_code(bool::out, io::di, io::uo) is det.
+:- func generating_code(globals) = bool.
-generating_code(bool.not(NotGeneratingCode), !IO) :-
- io_lookup_bool_option(make_short_interface, MakeShortInterface, !IO),
- io_lookup_bool_option(make_interface, MakeInterface, !IO),
- io_lookup_bool_option(make_private_interface, MakePrivateInterface, !IO),
- io_lookup_bool_option(make_transitive_opt_interface,
- MakeTransOptInterface, !IO),
- io_lookup_bool_option(generate_source_file_mapping, GenSrcFileMapping,
- !IO),
- io_lookup_bool_option(generate_dependencies, GenDepends, !IO),
- io_lookup_bool_option(generate_dependency_file, GenDependFile, !IO),
- io_lookup_bool_option(convert_to_mercury, ConvertToMercury, !IO),
- io_lookup_bool_option(typecheck_only, TypeCheckOnly, !IO),
- io_lookup_bool_option(errorcheck_only, ErrorCheckOnly, !IO),
- io_lookup_bool_option(output_grade_string, OutputGradeString, !IO),
+generating_code(Globals) = bool.not(NotGeneratingCode) :-
+ lookup_bool_option(Globals, make_short_interface, MakeShortInterface),
+ lookup_bool_option(Globals, make_interface, MakeInterface),
+ lookup_bool_option(Globals, make_private_interface, MakePrivateInterface),
+ lookup_bool_option(Globals, make_transitive_opt_interface,
+ MakeTransOptInterface),
+ lookup_bool_option(Globals, generate_source_file_mapping,
+ GenSrcFileMapping),
+ lookup_bool_option(Globals, generate_dependencies, GenDepends),
+ lookup_bool_option(Globals, generate_dependency_file, GenDependFile),
+ lookup_bool_option(Globals, convert_to_mercury, ConvertToMercury),
+ lookup_bool_option(Globals, typecheck_only, TypeCheckOnly),
+ lookup_bool_option(Globals, errorcheck_only, ErrorCheckOnly),
+ lookup_bool_option(Globals, output_grade_string, OutputGradeString),
bool.or_list([MakeShortInterface, MakeInterface,
MakePrivateInterface, MakeTransOptInterface,
GenSrcFileMapping, GenDepends, GenDependFile, ConvertToMercury,
@@ -686,11 +674,12 @@
:- pred ctors_add(list(constructor)::in, type_ctor::in, tvarset::in,
need_qualifier::in, partial_qualifier_info::in, prog_context::in,
import_status::in, ctor_field_table::in, ctor_field_table::out,
- cons_table::in, cons_table::out, io::di, io::uo) is det.
+ cons_table::in, cons_table::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
-ctors_add([], _, _, _, _, _, _, !FieldNameTable, !Ctors, !IO).
+ctors_add([], _, _, _, _, _, _, !FieldNameTable, !Ctors, !Specs).
ctors_add([Ctor | Rest], TypeCtor, TVarSet, NeedQual, PQInfo, Context,
- ImportStatus, !FieldNameTable, !Ctors, !IO) :-
+ ImportStatus, !FieldNameTable, !Ctors, !Specs) :-
Ctor = ctor(ExistQVars, Constraints, Name, Args),
QualifiedConsId = make_cons_id(Name, Args, TypeCtor),
ConsDefn = hlds_cons_defn(ExistQVars, Constraints, Args, TypeCtor,
@@ -716,8 +705,7 @@
words("for type"), quote(TypeCtorStr), words("multiply defined.")],
Msg = simple_msg(Context, [always(Pieces)]),
Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
- write_error_spec(Spec, 0, _NumWarnings, 0, _NumErrors, !IO),
- % XXX module_info_incr_errors(_NumErrors, !ModuleInfo)
+ !:Specs = [Spec | !.Specs],
QualifiedConsDefns = QualifiedConsDefns1
;
QualifiedConsDefns = [ConsDefn | QualifiedConsDefns1]
@@ -744,12 +732,12 @@
add_ctor_field_names(FieldNames, NeedQual, PartialQuals, TypeCtor,
QualifiedConsId, Context, ImportStatus, FirstField,
- !FieldNameTable, !IO)
+ !FieldNameTable, !Specs)
;
unexpected(this_file, "ctors_add: cons_id not qualified")
),
ctors_add(Rest, TypeCtor, TVarSet, NeedQual, PQInfo, Context,
- ImportStatus, !FieldNameTable, !Ctors, !IO).
+ ImportStatus, !FieldNameTable, !Ctors, !Specs).
:- pred add_ctor(string::in, int::in, hlds_cons_defn::in, module_name::in,
cons_id::out, cons_table::in, cons_table::out) is det.
@@ -761,31 +749,33 @@
:- pred add_ctor_field_names(list(maybe(ctor_field_name))::in,
need_qualifier::in, list(module_name)::in, type_ctor::in, cons_id::in,
prog_context::in, import_status::in, int::in,
- ctor_field_table::in, ctor_field_table::out, io::di, io::uo) is det.
+ ctor_field_table::in, ctor_field_table::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
-add_ctor_field_names([], _, _, _, _, _, _, _, !FieldNameTable, !IO).
+add_ctor_field_names([], _, _, _, _, _, _, _, !FieldNameTable, !Specs).
add_ctor_field_names([MaybeFieldName | FieldNames], NeedQual,
PartialQuals, TypeCtor, ConsId, Context, ImportStatus,
- FieldNumber, !FieldNameTable, !IO) :-
+ FieldNumber, !FieldNameTable, !Specs) :-
(
MaybeFieldName = yes(FieldName),
FieldDefn = hlds_ctor_field_defn(Context, ImportStatus, TypeCtor,
ConsId, FieldNumber),
add_ctor_field_name(FieldName, FieldDefn, NeedQual, PartialQuals,
- !FieldNameTable, !IO)
+ !FieldNameTable, !Specs)
;
MaybeFieldName = no
),
add_ctor_field_names(FieldNames, NeedQual, PartialQuals, TypeCtor,
ConsId, Context, ImportStatus, FieldNumber + 1,
- !FieldNameTable, !IO).
+ !FieldNameTable, !Specs).
:- pred add_ctor_field_name(ctor_field_name::in, hlds_ctor_field_defn::in,
need_qualifier::in, list(module_name)::in,
- ctor_field_table::in, ctor_field_table::out, io::di, io::uo) is det.
+ ctor_field_table::in, ctor_field_table::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
add_ctor_field_name(FieldName, FieldDefn, NeedQual, PartialQuals,
- !FieldNameTable, !IO) :-
+ !FieldNameTable, !Specs) :-
( FieldName = qualified(FieldModule0, _) ->
FieldModule = FieldModule0
;
@@ -818,8 +808,7 @@
Msg2 = simple_msg(OrigContext, [always(PrevPieces)]),
Spec = error_spec(severity_error, phase_parse_tree_to_hlds,
[Msg1, Msg2]),
- write_error_spec(Spec, 0, _NumWarnings, 0, _NumErrors, !IO)
- % XXX module_info_incr_errors(_NumErrors, !ModuleInfo)
+ !:Specs = [Spec | !.Specs]
;
UnqualFieldName = unqualify_name(FieldName),
Index: compiler/check_typeclass.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/check_typeclass.m,v
retrieving revision 1.98
diff -u -b -r1.98 check_typeclass.m
--- compiler/check_typeclass.m 7 Sep 2006 05:50:52 -0000 1.98
+++ compiler/check_typeclass.m 9 Sep 2006 07:07:52 -0000
@@ -520,7 +520,9 @@
InstanceTypes, InstanceConstraints,
InstanceVarSet, InstanceModuleName,
InstancePredDefn, Context,
- InstancePredId, InstanceProcIds, Info0, Info, !IO),
+ InstancePredId, InstanceProcIds, Info0, Info, [], Specs),
+ % XXX _NumErrors
+ write_error_specs(Specs, 0, _NumWarnings, 0, _NumErrors, !IO),
MakeClassProc = (pred(TheProcId::in, PredProcId::out) is det :-
PredProcId = hlds_class_proc(InstancePredId, TheProcId)
@@ -641,12 +643,12 @@
module_name::in, instance_proc_def::in, prog_context::in,
pred_id::out, list(proc_id)::out,
instance_method_info::in, instance_method_info::out,
- io::di, io::uo) is det.
+ list(error_spec)::in, list(error_spec)::out) is det.
produce_auxiliary_procs(ClassId, ClassVars, Markers0,
InstanceTypes0, InstanceConstraints0, InstanceVarSet,
InstanceModuleName, InstancePredDefn, Context, PredId,
- InstanceProcIds, Info0, Info, !IO) :-
+ InstanceProcIds, Info0, Info, !Specs) :-
Info0 = instance_method_info(ModuleInfo0, QualInfo0, PredName,
Arity, ExistQVars0, ArgTypes0, ClassMethodClassContext0,
@@ -722,7 +724,7 @@
adjust_func_arity(PredOrFunc, Arity, PredArity),
produce_instance_method_clauses(InstancePredDefn, PredOrFunc,
PredArity, ArgTypes, Markers, Context, Status, ClausesInfo,
- ModuleInfo0, ModuleInfo1, QualInfo0, QualInfo, !IO),
+ ModuleInfo0, ModuleInfo1, QualInfo0, QualInfo, !Specs),
% Fill in some information in the pred_info which is used by polymorphism
% to make sure the type-infos and typeclass-infos are added in the correct
@@ -998,23 +1000,24 @@
),
(
MissingConcreteError = yes,
+ !:FoundError = yes,
ClassId = class_id(ClassName, _),
sym_name_to_string(ClassName, ClassNameString),
AbstractTypesString = mercury_type_list_to_string(
AbstractInstance ^ instance_tvarset, AbstractTypes),
- AbstractInstanceName = "`" ++ ClassNameString ++
- "(" ++ AbstractTypesString ++ ")'",
+ AbstractInstanceName = ClassNameString ++
+ "(" ++ AbstractTypesString ++ ")",
% XXX Should we mention any constraints on the instance
% declaration here?
- ErrorPieces = [words("Error: abstract instance declaration"),
- words("for"), fixed(AbstractInstanceName),
+ Pieces = [words("Error: abstract instance declaration"),
+ words("for"), quote(AbstractInstanceName),
words("has no corresponding concrete"),
- words("instance in the implementation.")
- ],
+ words("instance in the implementation."), nl],
AbstractInstanceContext = AbstractInstance ^ instance_context,
- write_error_pieces(AbstractInstanceContext, 0, ErrorPieces, !IO),
- !:FoundError = yes,
- io.set_exit_status(1, !IO)
+ Msg = simple_msg(AbstractInstanceContext, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_type_check, [Msg]),
+ % XXX _NumErrors
+ write_error_spec(Spec, 0, _NumWarnings, 0, _NumErrors, !IO)
;
MissingConcreteError = no
).
@@ -1157,13 +1160,14 @@
ClassPath = [ClassId | Tail],
Context = map.lookup(ClassTable, ClassId) ^ class_context,
ClassId = class_id(Name, Arity),
- RevPieces0 = [
- sym_name_and_arity(Name/Arity),
- words("Error: cyclic superclass relation detected:")
- ],
- RevPieces1 = foldl(add_path_element, Tail, RevPieces0),
- Pieces = list.reverse(RevPieces1),
- write_error_pieces(Context, 0, Pieces, !IO)
+ RevPieces0 = [sym_name_and_arity(Name/Arity),
+ words("Error: cyclic superclass relation detected:")],
+ RevPieces = foldl(add_path_element, Tail, RevPieces0),
+ Pieces = list.reverse(RevPieces),
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
+ % XXX _NumErrors
+ write_error_spec(Spec, 0, _NumWarnings, 0, _NumErrors, !IO)
).
:- func add_path_element(class_id, list(format_component))
@@ -1268,18 +1272,19 @@
VarsStrs = list.map((func(Var) = mercury_var_to_string(Var, TVarSet, no)),
Vars),
- Msg = [ words("In instance for typeclass"),
- sym_name_and_arity(SymName / Arity),
- suffix(":"), nl,
+ Pieces = [words("In instance for typeclass"),
+ sym_name_and_arity(SymName / Arity), suffix(":"), nl,
words("functional dependency not satisfied:"),
words(choose_number(Vars, "type variable", "type variables"))]
++ list_to_pieces(VarsStrs) ++
[words(choose_number(Vars, "occurs", "occur")),
words("in the range of the functional dependency, but"),
words(choose_number(Vars, "is", "are")),
- words("not in the domain.")],
- write_error_pieces(Context, 0, Msg, !IO),
- io.set_exit_status(1, !IO).
+ words("not in the domain."), nl],
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_type_check, [Msg]),
+ % XXX _NumErrors
+ write_error_spec(Spec, 0, _NumWarnings, 0, _NumErrors, !IO).
% Check the consistency of each (unordered) pair of instances.
%
@@ -1362,20 +1367,17 @@
RangeList = mercury_vars_to_string(RangeParams, TVarSet, no),
FunDepStr = "`(" ++ DomainList ++ " -> " ++ RangeList ++ ")'",
- ErrorPiecesA = [
- words("Inconsistent instance declaration for typeclass"),
+ PiecesA = [words("Inconsistent instance declaration for typeclass"),
sym_name_and_arity(SymName / Arity),
- words("with functional dependency"),
- fixed(FunDepStr),
- suffix(".")
- ],
- ErrorPiecesB = [
- words("Here is the conflicting instance.")
- ],
-
- write_error_pieces(ContextA, 0, ErrorPiecesA, !IO),
- write_error_pieces(ContextB, 0, ErrorPiecesB, !IO),
- io.set_exit_status(1, !IO).
+ words("with functional dependency"), fixed(FunDepStr),
+ suffix("."), nl],
+ PiecesB = [words("Here is the conflicting instance.")],
+
+ MsgA = simple_msg(ContextA, [always(PiecesA)]),
+ MsgB = error_msg(yes(ContextB), yes, 0, [always(PiecesB)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [MsgA, MsgB]),
+ % XXX _NumErrors
+ write_error_spec(Spec, 0, _NumWarnings, 0, _NumErrors, !IO).
%---------------------------------------------------------------------------%
@@ -1648,7 +1650,7 @@
VarsStrs = list.map((func(Var) = mercury_var_to_string(Var, TVarSet, no)),
Vars),
- Msg0 = [words("In declaration for"),
+ Pieces0 = [words("In declaration for"),
simple_call(simple_call_id(PredOrFunc, SymName, Arity)),
suffix(":"), nl,
words("error in type class constraints:"),
@@ -1660,14 +1662,17 @@
words("not determined by the")],
(
PredOrFunc = predicate,
- Msg = Msg0 ++ [words("predicate's argument types.")]
+ Pieces = Pieces0 ++ [words("predicate's argument types."), nl]
;
PredOrFunc = function,
- Msg = Msg0 ++ [words("function's argument or result types.")]
+ Pieces = Pieces0 ++ [words("function's argument or result types."), nl]
),
- write_error_pieces(Context, 0, Msg, !IO),
- maybe_report_unbound_tvars_explanation(Context, !IO),
- io.set_exit_status(1, !IO).
+ Msg = simple_msg(Context,
+ [always(Pieces),
+ verbose_only(report_unbound_tvars_explanation)]),
+ Spec = error_spec(severity_error, phase_type_check, [Msg]),
+ % XXX _NumErrors
+ write_error_spec(Spec, 0, _NumWarnings, 0, _NumErrors, !IO).
:- pred report_unbound_tvars_in_ctor_context(list(tvar)::in, type_ctor::in,
hlds_type_defn::in, io::di, io::uo) is det.
@@ -1680,28 +1685,26 @@
VarsStrs = list.map((func(Var) = mercury_var_to_string(Var, TVarSet, no)),
Vars),
- Msg = [words("In declaration for type"),
- sym_name_and_arity(SymName / Arity),
- suffix(":"), nl,
+ Pieces = [words("In declaration for type"),
+ sym_name_and_arity(SymName / Arity), suffix(":"), nl,
words("error in type class constraints:"),
words(choose_number(Vars, "type variable", "type variables"))]
++ list_to_pieces(VarsStrs) ++
[words(choose_number(Vars, "occurs", "occur")),
words("in the constraints, but"),
words(choose_number(Vars, "is", "are")),
- words("not determined by the constructor's argument types.")],
- write_error_pieces(Context, 0, Msg, !IO),
- maybe_report_unbound_tvars_explanation(Context, !IO),
- io.set_exit_status(1, !IO).
+ words("not determined by the constructor's argument types."), nl],
+ Msg = simple_msg(Context,
+ [always(Pieces),
+ verbose_only(report_unbound_tvars_explanation)]),
+ Spec = error_spec(severity_error, phase_type_check, [Msg]),
+ % XXX _NumErrors
+ write_error_spec(Spec, 0, _NumWarnings, 0, _NumErrors, !IO).
-:- pred maybe_report_unbound_tvars_explanation(prog_context::in,
- io::di, io::uo) is det.
+:- func report_unbound_tvars_explanation = list(format_component).
-maybe_report_unbound_tvars_explanation(Context, !IO) :-
- globals.io_lookup_bool_option(verbose_errors, VerboseErrors, !IO),
- (
- VerboseErrors = yes,
- Msg = [words("All types occurring in typeclass constraints"),
+report_unbound_tvars_explanation =
+ [words("All types occurring in typeclass constraints"),
words("must be fully determined."),
words("A type is fully determined if one of the"),
words("following holds:"),
@@ -1727,13 +1730,7 @@
words("is fully determined."),
nl,
words("See the ""Functional dependencies"" section"),
- words("of the reference manual for details.")
- ],
- write_error_pieces_not_first_line(Context, 0, Msg, !IO)
- ;
- VerboseErrors = no,
- globals.io_set_extra_error_info(yes, !IO)
- ).
+ words("of the reference manual for details."), nl].
%---------------------------------------------------------------------------%
@@ -1807,8 +1804,11 @@
),
Pieces = InDeclaration ++ TypeVariables ++ TVarsPart ++
[Are, BlahConstrained, suffix(","), words("but"), Are,
- BlahQuantified, suffix(".")],
- write_error_pieces(Context, 0, Pieces, !IO).
+ BlahQuantified, suffix("."), nl],
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_type_check, [Msg]),
+ % XXX _NumErrors
+ write_error_spec(Spec, 0, _NumWarnings, 0, _NumErrors, !IO).
%---------------------------------------------------------------------------%
Index: compiler/field_access.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/field_access.m,v
retrieving revision 1.11
diff -u -b -r1.11 field_access.m
--- compiler/field_access.m 20 Aug 2006 08:21:00 -0000 1.11
+++ compiler/field_access.m 8 Sep 2006 07:30:18 -0000
@@ -20,11 +20,11 @@
:- import_module hlds.make_hlds.qual_info.
:- import_module hlds.make_hlds.state_var.
:- import_module hlds.make_hlds.superhomogeneous.
+:- import_module parse_tree.error_util.
:- import_module parse_tree.prog_data.
:- import_module parse_tree.prog_io_util.
:- import_module assoc_list.
-:- import_module io.
:- import_module list.
:- import_module pair.
@@ -48,7 +48,8 @@
pair(cons_id, unify_sub_contexts)::out, hlds_goal::out,
num_added_goals::out, prog_varset::in, prog_varset::out,
module_info::in, module_info::out, qual_info::in, qual_info::out,
- svar_info::in, svar_info::out, io::di, io::uo) is det.
+ svar_info::in, svar_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
% Expand a field extraction goal into a list of goals which each get one
% level of the structure.
@@ -68,7 +69,8 @@
pair(cons_id, unify_sub_contexts)::out, hlds_goal::out,
num_added_goals::out, prog_varset::in, prog_varset::out,
module_info::in, module_info::out, qual_info::in, qual_info::out,
- svar_info::in, svar_info::out, io::di, io::uo) is det.
+ svar_info::in, svar_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
% Expand a field extraction function call into a list of goals which
% each get one level of the structure.
@@ -86,7 +88,8 @@
pair(cons_id, unify_sub_contexts)::out,
hlds_goal::out, num_added_goals::out, prog_varset::in, prog_varset::out,
module_info::in, module_info::out, qual_info::in, qual_info::out,
- svar_info::in, svar_info::out, io::di, io::uo) is det.
+ 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.
@@ -111,11 +114,11 @@
expand_set_field_function_call(Context, MainContext, SubContext0, FieldNames,
FieldValueVar, TermInputVar, TermOutputVar, Functor, FieldSubContext,
- Goal, NumAdded, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO) :-
+ Goal, NumAdded, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs) :-
expand_set_field_function_call_2(Context, MainContext, SubContext0,
FieldNames, FieldValueVar, TermInputVar, TermOutputVar, Functor,
FieldSubContext, Goals, NumAdded,
- !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
+ !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs),
goal_info_init(Context, GoalInfo),
conj_list_to_goal(Goals, GoalInfo, Goal).
@@ -125,17 +128,18 @@
pair(cons_id, unify_sub_contexts)::out, list(hlds_goal)::out,
num_added_goals::out, prog_varset::in, prog_varset::out,
module_info::in, module_info::out, qual_info::in, qual_info::out,
- svar_info::in, svar_info::out, io::di, io::uo) is det.
+ svar_info::in, svar_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
expand_set_field_function_call_2(_, _, _, [], _, _, _, _, _, _, _,
- !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO) :-
+ !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs) :-
unexpected(this_file,
"expand_set_field_function_call_2: empty list of field names").
expand_set_field_function_call_2(Context, MainContext, SubContext0,
[FieldName - FieldArgs | FieldNames], FieldValueVar,
TermInputVar, TermOutputVar, Functor, FieldSubContext, Goals, NumAdded,
- !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO) :-
- make_fresh_arg_vars(FieldArgs, FieldArgVars, !VarSet, !SInfo, !IO),
+ !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs) :-
+ make_fresh_arg_vars(FieldArgs, FieldArgVars, !VarSet, !SInfo, !Specs),
(
FieldNames = [_ | _],
varset.new_var(!.VarSet, SubTermInputVar, !:VarSet),
@@ -160,7 +164,7 @@
expand_set_field_function_call_2(Context, MainContext,
SubContext, FieldNames, FieldValueVar, SubTermInputVar,
SubTermOutputVar, _, FieldSubContext, Goals0, SetAdded,
- !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
+ !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs),
FieldAdded = GetSubFieldAdded + SetAdded + UpdateAdded,
Goals1 = [GetSubFieldGoal | Goals0] ++ [UpdateGoal]
@@ -178,13 +182,14 @@
goal_info_init(Context, GoalInfo),
conj_list_to_goal(Goals1, GoalInfo, Conj0),
insert_arg_unifications(FieldArgVars, FieldArgs, Context, ArgContext,
- Conj0, Conj, ArgAdded, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
+ Conj0, Conj, ArgAdded, !VarSet, !ModuleInfo, !QualInfo,
+ !SInfo, !Specs),
NumAdded = FieldAdded + ArgAdded,
goal_to_conj_list(Conj, Goals).
expand_dcg_field_extraction_goal(Context, MainContext, SubContext, FieldNames,
FieldValueVar, TermInputVar, TermOutputVar, Functor, FieldSubContext,
- Goal, NumAdded, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO) :-
+ Goal, NumAdded, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs) :-
% Unify the DCG input and output variables.
make_atomic_unification(TermOutputVar, rhs_var(TermInputVar), Context,
MainContext, SubContext, UnifyDCG, !QualInfo),
@@ -194,7 +199,7 @@
expand_get_field_function_call_2(Context, MainContext, SubContext,
FieldNames, FieldValueVar, TermOutputVar, purity_pure,
Functor, FieldSubContext, Goals1, GetAdded,
- !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
+ !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs),
NumAdded = UnifyAdded + GetAdded,
Goals = [UnifyDCG | Goals1],
goal_info_init(Context, GoalInfo),
@@ -202,11 +207,11 @@
expand_get_field_function_call(Context, MainContext, SubContext0, FieldNames,
FieldValueVar, TermInputVar, Purity, Functor, FieldSubContext,
- Goal, NumAdded, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO) :-
+ Goal, NumAdded, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs) :-
expand_get_field_function_call_2(Context, MainContext, SubContext0,
FieldNames, FieldValueVar, TermInputVar, Purity, Functor,
FieldSubContext, Goals, NumAdded, !VarSet, !ModuleInfo, !QualInfo,
- !SInfo, !IO),
+ !SInfo, !Specs),
goal_info_init(Context, GoalInfo),
conj_list_to_goal(Goals, GoalInfo, Goal).
@@ -216,17 +221,18 @@
pair(cons_id, unify_sub_contexts)::out, list(hlds_goal)::out,
num_added_goals::out, prog_varset::in, prog_varset::out,
module_info::in, module_info::out, qual_info::in, qual_info::out,
- svar_info::in, svar_info::out, io::di, io::uo) is det.
+ svar_info::in, svar_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
expand_get_field_function_call_2(_, _, _, [], _, _, _, _, _, _, _,
- !VarSet, !ModuleInfo, !QualInfo, !Sinfo, !IO) :-
+ !VarSet, !ModuleInfo, !QualInfo, !Sinfo, !Specs) :-
unexpected(this_file,
"expand_get_field_function_call_2: empty list of field names").
expand_get_field_function_call_2(Context, MainContext, SubContext0,
[FieldName - FieldArgs | FieldNames], FieldValueVar, TermInputVar,
Purity, Functor, FieldSubContext, Goals, NumAdded,
- !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO) :-
- make_fresh_arg_vars(FieldArgs, FieldArgVars, !VarSet, !SInfo, !IO),
+ !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs) :-
+ make_fresh_arg_vars(FieldArgs, FieldArgVars, !VarSet, !SInfo, !Specs),
GetArgVars = FieldArgVars ++ [TermInputVar],
(
FieldNames = [_ | _],
@@ -236,14 +242,14 @@
Functor, Goal, !QualInfo),
CallAdded = 1,
- % Recursively extract until we run out of field names
+ % Recursively extract until we run out of field names.
TermInputArgNumber = 1 + list.length(FieldArgVars),
TermInputContext = Functor - TermInputArgNumber,
SubContext = [TermInputContext | SubContext0],
expand_get_field_function_call_2(Context, MainContext,
SubContext, FieldNames, FieldValueVar, SubTermInputVar, Purity,
_, FieldSubContext, Goals1, ExtractAdded, !VarSet, !ModuleInfo,
- !QualInfo, !SInfo, !IO),
+ !QualInfo, !SInfo, !Specs),
Goals2 = [Goal | Goals1],
FieldAdded = CallAdded + ExtractAdded
;
@@ -259,7 +265,8 @@
goal_info_init(Context, GoalInfo),
conj_list_to_goal(Goals2, GoalInfo, Conj0),
insert_arg_unifications(FieldArgVars, FieldArgs, Context, ArgContext,
- Conj0, Conj, ArgAdded, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
+ Conj0, Conj, ArgAdded, !VarSet, !ModuleInfo, !QualInfo,
+ !SInfo, !Specs),
NumAdded = FieldAdded + ArgAdded,
goal_to_conj_list(Conj, Goals).
Index: compiler/foreign.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/foreign.m,v
retrieving revision 1.64
diff -u -b -r1.64 foreign.m
--- compiler/foreign.m 22 Aug 2006 05:03:44 -0000 1.64
+++ compiler/foreign.m 8 Sep 2006 10:35:39 -0000
@@ -26,11 +26,11 @@
:- import_module hlds.hlds_pred.
:- import_module libs.globals.
:- import_module mdbcomp.prim_data.
+:- import_module parse_tree.error_util.
:- import_module parse_tree.prog_data.
:- import_module parse_tree.prog_foreign.
:- import_module bool.
-:- import_module io.
:- import_module list.
:- import_module maybe.
:- import_module string.
@@ -139,8 +139,8 @@
:- pred make_pragma_import(pred_info::in, proc_info::in, string::in,
prog_context::in, pragma_foreign_code_impl::out,
prog_varset::out, list(pragma_var)::out, list(mer_type)::out, arity::out,
- pred_or_func::out, module_info::in, module_info::out, io::di, io::uo)
- is det.
+ pred_or_func::out, module_info::in, module_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
% The name of the #define which can be used to guard declarations with
% to prevent entities being declared twice.
@@ -162,7 +162,6 @@
:- import_module hlds.hlds_pred.
:- import_module libs.compiler_util.
:- import_module libs.globals.
-:- import_module parse_tree.error_util.
:- import_module parse_tree.modules.
:- import_module parse_tree.prog_out.
:- import_module parse_tree.prog_type.
@@ -333,7 +332,7 @@
make_pred_name_rest(lang_java, _SymName) = "some_java_name".
make_pragma_import(PredInfo, ProcInfo, C_Function, Context, PragmaImpl, VarSet,
- PragmaVars, ArgTypes, Arity, PredOrFunc, !ModuleInfo, !IO) :-
+ PragmaVars, ArgTypes, Arity, PredOrFunc, !ModuleInfo, !Specs) :-
% Lookup some information we need from the pred_info and proc_info.
PredOrFunc = pred_info_is_pred_or_func(PredInfo),
@@ -361,7 +360,8 @@
proc_info_get_declared_determinism(ProcInfo, MaybeDeclaredDetism),
handle_return_value(Context, MaybeDeclaredDetism, CodeModel, PredOrFunc,
- PragmaVarsAndTypes, ArgPragmaVarsAndTypes, Return, !ModuleInfo, !IO),
+ PragmaVarsAndTypes, ArgPragmaVarsAndTypes, Return, !ModuleInfo,
+ !Specs),
assoc_list.keys(ArgPragmaVarsAndTypes, ArgPragmaVars),
create_pragma_import_c_code(ArgPragmaVars, !.ModuleInfo, "", Variables),
@@ -387,10 +387,11 @@
code_model::in, pred_or_func::in,
assoc_list(pragma_var, mer_type)::in,
assoc_list(pragma_var, mer_type)::out,
- string::out, module_info::in, module_info::out, io::di, io::uo) is det.
+ string::out, module_info::in, module_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
handle_return_value(Context, MaybeDeclaredDetism, CodeModel, PredOrFunc,
- !Args, C_Code0, !ModuleInfo, !IO) :-
+ !Args, C_Code0, !ModuleInfo, !Specs) :-
(
CodeModel = model_det,
(
@@ -421,16 +422,14 @@
MaybeDeclaredDetism = no,
DetismStr = "multi or nondet"
),
- ErrorPieces = [
- words("Error: `pragma_import' declaration for"),
+ Pieces = [words("Error: `pragma_import' declaration for"),
words("a procedure that has a determinism of"),
- fixed(DetismStr), suffix(".")
- ],
- write_error_pieces(Context, 0, ErrorPieces, !IO),
- module_info_incr_errors(!ModuleInfo),
+ fixed(DetismStr), suffix("."), nl],
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
+ !:Specs = [Spec | !.Specs],
- % The following are just dummy values - they will never actually
- % be used.
+ % This is just a dummy - it will never actually be used.
C_Code0 = "\n#error ""cannot import nondet procedure""\n"
),
list.filter(include_import_arg(!.ModuleInfo), !Args).
Index: compiler/handle_options.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/handle_options.m,v
retrieving revision 1.272
diff -u -b -r1.272 handle_options.m
--- compiler/handle_options.m 4 Sep 2006 01:47:29 -0000 1.272
+++ compiler/handle_options.m 8 Sep 2006 12:44:35 -0000
@@ -97,6 +97,7 @@
:- import_module solutions.
:- import_module std_util.
:- import_module string.
+:- import_module svmap.
%-----------------------------------------------------------------------------%
@@ -204,10 +205,10 @@
trace_suppress_items::out, may_be_thread_safe::out,
list(string)::in, list(string)::out) is det.
-check_option_values(OptionTable0, OptionTable, Target, GC_Method, TagsMethod,
+check_option_values(!OptionTable, Target, GC_Method, TagsMethod,
TermNorm, Term2Norm, TraceLevel, TraceSuppress, MaybeThreadSafe,
!Errors) :-
- map.lookup(OptionTable0, target, Target0),
+ map.lookup(!.OptionTable, target, Target0),
(
Target0 = string(TargetStr),
convert_target(TargetStr, TargetPrime)
@@ -218,7 +219,7 @@
add_error("Invalid target option " ++
"(must be `c', `asm', `il', or `java')", !Errors)
),
- map.lookup(OptionTable0, gc, GC_Method0),
+ map.lookup(!.OptionTable, gc, GC_Method0),
(
GC_Method0 = string(GC_MethodStr),
convert_gc_method(GC_MethodStr, GC_MethodPrime)
@@ -230,7 +231,7 @@
"`conservative', `boehm', `mps', `accurate', or `automatic')",
!Errors)
),
- map.lookup(OptionTable0, tags, TagsMethod0),
+ map.lookup(!.OptionTable, tags, TagsMethod0),
(
TagsMethod0 = string(TagsMethodStr),
convert_tags_method(TagsMethodStr, TagsMethodPrime)
@@ -241,7 +242,7 @@
add_error("Invalid tags option " ++
"(must be `none', `low' or `high')", !Errors)
),
- map.lookup(OptionTable0, fact_table_hash_percent_full, PercentFull),
+ map.lookup(!.OptionTable, fact_table_hash_percent_full, PercentFull),
(
PercentFull = int(Percent),
Percent >= 1,
@@ -253,7 +254,7 @@
"`--fact-table-hash-percent-full'\n\t" ++
"(must be an integer between 1 and 100)", !Errors)
),
- map.lookup(OptionTable0, termination_norm, TermNorm0),
+ map.lookup(!.OptionTable, termination_norm, TermNorm0),
(
TermNorm0 = string(TermNormStr),
convert_termination_norm(TermNormStr, TermNormPrime)
@@ -265,7 +266,7 @@
"`--termination-norm'\n\t(must be " ++
"`simple', `total' or `num-data-elems').", !Errors)
),
- map.lookup(OptionTable0, termination2_norm, Term2Norm0),
+ map.lookup(!.OptionTable, termination2_norm, Term2Norm0),
(
Term2Norm0 = string(Term2NormStr),
convert_termination_norm(Term2NormStr, Term2NormPrime)
@@ -277,13 +278,13 @@
"`--termination2-norm'\n\t(must be" ++
"`simple', `total' or `num-data-elems').", !Errors)
),
- map.lookup(OptionTable0, force_disable_tracing, ForceDisableTracing),
+ map.lookup(!.OptionTable, force_disable_tracing, ForceDisableTracing),
( ForceDisableTracing = bool(yes) ->
TraceLevel = trace_level_none
;
- map.lookup(OptionTable0, trace_level, Trace),
- map.lookup(OptionTable0, exec_trace, ExecTraceOpt),
- map.lookup(OptionTable0, decl_debug, DeclDebugOpt),
+ map.lookup(!.OptionTable, trace_level, Trace),
+ map.lookup(!.OptionTable, exec_trace, ExecTraceOpt),
+ map.lookup(!.OptionTable, decl_debug, DeclDebugOpt),
(
Trace = string(TraceStr),
ExecTraceOpt = bool(ExecTrace),
@@ -306,7 +307,7 @@
"`decl', `rep' or `default').", !Errors)
)
),
- map.lookup(OptionTable0, suppress_trace, Suppress),
+ map.lookup(!.OptionTable, suppress_trace, Suppress),
(
Suppress = string(SuppressStr),
convert_trace_suppress(SuppressStr, TraceSuppressPrime)
@@ -316,7 +317,7 @@
TraceSuppress = default_trace_suppress, % dummy
add_error("Invalid argument to option `--suppress-trace'.", !Errors)
),
- map.lookup(OptionTable0, maybe_thread_safe, MaybeThreadSafeOption),
+ map.lookup(!.OptionTable, maybe_thread_safe_opt, MaybeThreadSafeOption),
(
MaybeThreadSafeOption = string(MaybeThreadSafeString),
convert_maybe_thread_safe(MaybeThreadSafeString, MaybeThreadSafe0)
@@ -326,20 +327,18 @@
MaybeThreadSafe = no, % dummy
add_error("Invalid argument to option `--maybe-thread-safe'.", !Errors)
),
- map.lookup(OptionTable0, dump_hlds_alias, DumpAliasOption),
+ map.lookup(!.OptionTable, dump_hlds_alias, DumpAliasOption),
(
DumpAliasOption = string(DumpAlias),
DumpAlias = ""
->
- OptionTable = OptionTable0
+ true
;
DumpAliasOption = string(DumpAlias),
convert_dump_alias(DumpAlias, DumpOptions)
->
- map.set(OptionTable0, dump_hlds_options, string(DumpOptions),
- OptionTable)
+ svmap.set(dump_hlds_options, string(DumpOptions), !OptionTable)
;
- OptionTable = OptionTable0, % dummy
add_error("Invalid argument to option `--hlds-dump-alias'.", !Errors)
).
Index: compiler/hlds_out.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/hlds_out.m,v
retrieving revision 1.402
diff -u -b -r1.402 hlds_out.m
--- compiler/hlds_out.m 7 Sep 2006 05:50:54 -0000 1.402
+++ compiler/hlds_out.m 8 Sep 2006 12:33:45 -0000
@@ -1037,7 +1037,7 @@
write_indent(Indent, !IO),
% Print initial formatting differently for assertions.
- ( PromiseType = true ->
+ ( PromiseType = promise_type_true ->
io.write_string(":- promise all [", !IO),
io.write_list(HeadVars, ", ", PrintVar, !IO),
io.write_string("] (\n", !IO)
Index: compiler/make.module_dep_file.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/make.module_dep_file.m,v
retrieving revision 1.21
diff -u -b -r1.21 make.module_dep_file.m
--- compiler/make.module_dep_file.m 20 Aug 2006 08:21:14 -0000 1.21
+++ compiler/make.module_dep_file.m 9 Sep 2006 03:42:11 -0000
@@ -529,7 +529,10 @@
;
io.set_exit_status(0, !IO),
io.set_output_stream(ErrorStream, _, !IO),
- split_into_submodules(ModuleName, Items, SubModuleList, !IO),
+ split_into_submodules(ModuleName, Items, SubModuleList, [], Specs),
+ sort_error_specs(Specs, SortedSpecs),
+ write_error_specs(SortedSpecs, 0, _NumWarnings, 0, _NumErrors,
+ !IO),
io.set_output_stream(OldOutputStream, _, !IO),
globals.io_get_globals(Globals, !IO),
Index: compiler/make_hlds.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/make_hlds.m,v
retrieving revision 1.525
diff -u -b -r1.525 make_hlds.m
--- compiler/make_hlds.m 31 Jul 2006 08:31:47 -0000 1.525
+++ compiler/make_hlds.m 8 Sep 2006 12:30:14 -0000
@@ -32,6 +32,7 @@
:- import_module hlds.hlds_pred.
:- import_module mdbcomp.prim_data.
:- import_module parse_tree.equiv_type.
+:- import_module parse_tree.error_util.
:- import_module parse_tree.module_qual.
:- import_module parse_tree.prog_data.
:- import_module parse_tree.prog_item.
@@ -97,7 +98,8 @@
pred_or_func::in, arity::in, list(mer_type)::in, pred_markers::in,
term.context::in, import_status::in, clauses_info::out,
module_info::in, module_info::out,
- make_hlds_qual_info::in, make_hlds_qual_info::out, io::di, io::uo) is det.
+ make_hlds_qual_info::in, make_hlds_qual_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
% Move the recompilation_info from the qual_info to the module_info
% after make_hlds is finished with it and the qual_info is dead.
@@ -160,10 +162,10 @@
produce_instance_method_clauses(InstanceProcDefn,
PredOrFunc, PredArity, ArgTypes, Markers, Context, Status,
- ClausesInfo, !ModuleInfo, !QualInfo, !IO) :-
+ ClausesInfo, !ModuleInfo, !QualInfo, !Specs) :-
do_produce_instance_method_clauses(InstanceProcDefn, PredOrFunc,
PredArity, ArgTypes, Markers, Context, Status, ClausesInfo,
- !ModuleInfo, !QualInfo, !IO).
+ !ModuleInfo, !QualInfo, !Specs).
set_module_recomp_info(QualInfo, !ModuleInfo) :-
set_module_recompilation_info(QualInfo, !ModuleInfo).
Index: compiler/make_hlds_error.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/make_hlds_error.m,v
retrieving revision 1.11
diff -u -b -r1.11 make_hlds_error.m
--- compiler/make_hlds_error.m 7 Sep 2006 05:50:56 -0000 1.11
+++ compiler/make_hlds_error.m 8 Sep 2006 16:29:29 -0000
@@ -18,53 +18,46 @@
:- module hlds.make_hlds.make_hlds_error.
:- interface.
-:- import_module hlds.hlds_module.
:- import_module hlds.hlds_pred.
+:- import_module libs.globals.
:- import_module mdbcomp.prim_data.
+:- import_module parse_tree.error_util.
:- import_module parse_tree.prog_data.
:- import_module bool.
-:- import_module io.
:- import_module list.
%-----------------------------------------------------------------------------%
:- pred multiple_def_error(import_status::in, sym_name::in, int::in,
- string::in, prog_context::in, prog_context::in, bool::out,
- io::di, io::uo) is det.
+ string::in, prog_context::in, prog_context::in, list(format_component)::in,
+ list(error_spec)::in, list(error_spec)::out) is det.
:- pred undefined_pred_or_func_error(sym_name::in, int::in, prog_context::in,
- string::in, io::di, io::uo) is det.
+ string::in, list(error_spec)::in, list(error_spec)::out) is det.
% Similar to undeclared_mode_error, but gives less information.
% XXX perhaps we should get rid of this, and change the callers to
% instead call undeclared_mode_error.
%
:- pred undefined_mode_error(sym_name::in, int::in, prog_context::in,
- string::in, io::di, io::uo) is det.
+ string::in, list(error_spec)::in, list(error_spec)::out) is det.
- % Similar to undefined_mode_error, but gives more information.
- % XXX the documentation here should be somewhat less circular.
- %
-:- pred undeclared_mode_error(list(mer_mode)::in, prog_varset::in,
- pred_id::in, pred_info::in, module_info::in, prog_context::in,
- io::di, io::uo) is det.
-
-:- pred maybe_undefined_pred_error(sym_name::in, int::in, pred_or_func::in,
- import_status::in, bool::in, prog_context::in, string::in,
- io::di, io::uo) is det.
+:- pred maybe_undefined_pred_error(globals::in, sym_name::in, int::in,
+ pred_or_func::in, import_status::in, bool::in, prog_context::in,
+ string::in, list(error_spec)::in, list(error_spec)::out) is det.
% Emit an error if something is exported. (Used to check for
% when things shouldn't be exported.)
%
:- pred error_if_exported(import_status::in, prog_context::in, string::in,
- io::di, io::uo) is det.
+ list(error_spec)::in, list(error_spec)::out) is det.
% Emit an error reporting that something should not have occurred in
% a module interface.
%
-:- pred error_is_exported(prog_context::in, string::in, io::di, io::uo)
- is det.
+:- pred error_is_exported(prog_context::in, string::in,
+ list(error_spec)::in, list(error_spec)::out) is det.
%----------------------------------------------------------------------------%
%----------------------------------------------------------------------------%
@@ -72,10 +65,9 @@
:- implementation.
:- import_module check_hlds.mode_errors.
+:- import_module hlds.hlds_error_util.
:- import_module hlds.hlds_out.
-:- import_module libs.globals.
:- import_module libs.options.
-:- import_module parse_tree.error_util.
:- import_module parse_tree.mercury_to_mercury.
:- import_module parse_tree.prog_mode.
:- import_module parse_tree.prog_out.
@@ -86,92 +78,95 @@
%-----------------------------------------------------------------------------%
multiple_def_error(Status, Name, Arity, DefType, Context, OrigContext,
- FoundError, !IO) :-
+ ExtraPieces, !Specs) :-
( Status = status_opt_imported ->
% We don't take care not to read the same declaration from multiple
% sources with inter-module optimization, so ignore multiple definition
% errors in the items read for inter-module optimization.
- FoundError = no
+ true
+ ;
+ Pieces1 = [words("Error:"), fixed(DefType),
+ sym_name_and_arity(Name / Arity), words("multiply defined."), nl],
+ 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)]),
+ (
+ ExtraPieces = [],
+ ExtraMsgs = []
;
- Pieces = [words("Error:"),
- fixed(DefType), sym_name_and_arity(Name / Arity),
- words("multiply defined.")],
- write_error_pieces(Context, 0, Pieces, !IO),
- OrigPieces = [words("Here is the previous definition of"),
- fixed(DefType), sym_name_and_arity(Name / Arity),
- suffix(".")],
- write_error_pieces(OrigContext, 0, OrigPieces, !IO),
- io.set_exit_status(1, !IO),
- FoundError = yes
+ ExtraPieces = [_ | _],
+ ExtraMsgs = [simple_msg(Context, [always(ExtraPieces)])]
+ ),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds,
+ [Msg1, Msg2] ++ ExtraMsgs),
+ !:Specs = [Spec | !.Specs]
).
-undefined_pred_or_func_error(Name, Arity, Context, Description, !IO) :-
+undefined_pred_or_func_error(Name, Arity, Context, Description, !Specs) :-
% This used to say `preceding' instead of `corresponding.'
% Which is more correct?
Pieces = [words("Error:"), words(Description), words("for"),
sym_name_and_arity(Name / Arity),
words("without corresponding `pred' or `func' declaration.")],
- write_error_pieces(Context, 0, Pieces, !IO),
- io.set_exit_status(1, !IO).
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
+ !:Specs = [Spec | !.Specs].
-undefined_mode_error(Name, Arity, Context, Description, !IO) :-
+undefined_mode_error(Name, Arity, Context, Description, !Specs) :-
Pieces = [words("Error:"), words(Description), words("for"),
sym_name_and_arity(Name / Arity),
words("specifies non-existent mode.")],
- write_error_pieces(Context, 0, Pieces, !IO),
- io.set_exit_status(1, !IO).
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
+ !:Specs = [Spec | !.Specs].
-undeclared_mode_error(ModeList, VarSet, PredId, PredInfo, ModuleInfo,
- Context, !IO) :-
- prog_out.write_context(Context, !IO),
- io.write_string("In clause for ", !IO),
- hlds_out.write_pred_id(ModuleInfo, PredId, !IO),
- io.write_string(":\n", !IO),
- prog_out.write_context(Context, !IO),
- io.write_string(
- " error: mode annotation specifies undeclared mode\n", !IO),
- prog_out.write_context(Context, !IO),
- io.write_string(" `", !IO),
+ % Similar to undefined_mode_error, but gives more information.
+ % XXX the documentation here should be somewhat less circular.
+ %
+:- func undeclared_mode_error(list(mer_mode), prog_varset,
+ pred_id, pred_info, module_info, prog_context) = error_spec.
+
+undeclared_mode_error(ModeList, VarSet, PredId, PredInfo, ModuleInfo, Context)
+ = Spec :-
+ PredIdPieces = describe_one_pred_name(ModuleInfo,
+ should_not_module_qualify, PredId),
strip_builtin_qualifiers_from_mode_list(ModeList, StrippedModeList),
PredOrFunc = pred_info_is_pred_or_func(PredInfo),
Name = pred_info_name(PredInfo),
MaybeDet = no,
- mercury_output_mode_subdecl(PredOrFunc, varset.coerce(VarSet),
- unqualified(Name), StrippedModeList, MaybeDet, Context, !IO),
- io.write_string("'\n", !IO),
- prog_out.write_context(Context, !IO),
- io.write_string(" of ", !IO),
- hlds_out.write_pred_id(ModuleInfo, PredId, !IO),
- io.write_string(".\n", !IO),
- globals.io_lookup_bool_option(verbose_errors, VerboseErrors, !IO),
+ SubDeclStr = mercury_mode_subdecl_to_string(PredOrFunc,
+ varset.coerce(VarSet), unqualified(Name), StrippedModeList,
+ MaybeDet, Context),
+
+ MainPieces = [words("In clause for")] ++ PredIdPieces ++ [suffix(":"), nl,
+ words("error: mode annotation specifies undeclared mode"),
+ quote(SubDeclStr), suffix("."), nl],
ProcIds = pred_info_all_procids(PredInfo),
(
ProcIds = [],
- prog_out.write_context(Context, !IO),
- io.write_string(" (There are no declared modes for this ", !IO),
- write_pred_or_func(PredOrFunc, !IO),
- io.write_string(".)\n", !IO)
+ VerbosePieces = [words("(There are no declared modes for this"),
+ p_or_f(PredOrFunc), suffix(".)"), nl]
;
ProcIds = [_ | _],
- (
- VerboseErrors = yes,
- io.write_string("\tThe declared modes for this ", !IO),
- write_pred_or_func(PredOrFunc, !IO),
- io.write_string(" are the following:\n", !IO),
- list.foldl(output_mode_decl_for_pred_info(PredInfo), ProcIds, !IO)
- ;
- VerboseErrors = no,
- globals.io_set_extra_error_info(yes, !IO)
- )
- ).
-
-:- pred output_mode_decl_for_pred_info(pred_info::in, proc_id::in,
- io::di, io::uo) is det.
-
-output_mode_decl_for_pred_info(PredInfo, ProcId, !IO) :-
- io.write_string("\t\t:- mode ", !IO),
- output_mode_decl(ProcId, PredInfo, !IO),
- io.write_string(".\n", !IO).
+ VerbosePieces = [words("The declared modes for this"),
+ p_or_f(PredOrFunc), words("are the following:"),
+ nl_indent_delta(1)] ++
+ component_list_to_line_pieces(
+ list.map(mode_decl_for_pred_info_to_pieces(PredInfo), ProcIds),
+ []) ++
+ [nl_indent_delta(-1)]
+ ),
+ Msg = simple_msg(Context,
+ [always(MainPieces), verbose_only(VerbosePieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]).
+
+:- func mode_decl_for_pred_info_to_pieces(pred_info, proc_id)
+ = list(format_component).
+
+mode_decl_for_pred_info_to_pieces(PredInfo, ProcId) =
+ [words(":- mode"), words(mode_decl_to_string(ProcId, PredInfo)),
+ suffix(".")].
% This is not considered an unconditional error anymore:
% if there is no `:- pred' or `:- func' declaration,
@@ -180,11 +175,11 @@
% then we just add an implicit declaration for that predicate or
% function, marking it as one whose type will be inferred.
%
-maybe_undefined_pred_error(Name, Arity, PredOrFunc, Status, IsClassMethod,
- Context, Description, !IO) :-
+maybe_undefined_pred_error(Globals, Name, Arity, PredOrFunc, Status,
+ IsClassMethod, Context, Description, !Specs) :-
DefinedInThisModule = status_defined_in_this_module(Status),
IsExported = status_is_exported(Status),
- globals.io_lookup_bool_option(infer_types, InferTypes, !IO),
+ globals.lookup_bool_option(Globals, infer_types, InferTypes),
(
DefinedInThisModule = yes,
IsExported = no,
@@ -195,34 +190,22 @@
;
Pieces = [words("Error:"), words(Description), words("for"),
simple_call(simple_call_id(PredOrFunc, Name, Arity)), nl,
- words("without preceding"),
- quote(pred_or_func_to_str(PredOrFunc)),
- words("declaration.")],
- write_error_pieces(Context, 0, Pieces, !IO),
- io.set_exit_status(1, !IO)
+ words("without preceding"), quote(pred_or_func_to_str(PredOrFunc)),
+ words("declaration."), nl],
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
+ !:Specs = [Spec | !.Specs]
).
-% % This predicate is currently unused.
-%
-% :- pred clause_for_imported_pred_error(sym_name::in, arity::in,
-% pred_or_func::in, prog_context::in, io::di, io::uo) is det.
-%
-% clause_for_imported_pred_error(Name, Arity, PredOrFunc, Context, !IO) :-
-% Pieces = [words("Error: clause for imported"),
-% pred_or_func(PredOrFunc),
-% sym_name_and_arity(Name / Arity),
-% suffix(".")],
-% write_error_pieces(Context, 0, Pieces, !IO),
-% io.set_exit_status(1, !IO).
-
-error_is_exported(Context, Message, !IO) :-
- Error = [words("Error:"), fixed(Message), words("in module interface.")],
- write_error_pieces(Context, 0, Error, !IO),
- io.set_exit_status(1, !IO).
+error_is_exported(Context, Item, !Specs) :-
+ Pieces = [words("Error:"), fixed(Item), words("in module interface."), nl],
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
+ !:Specs = [Spec | !.Specs].
-error_if_exported(Status, Context, Message, !IO) :-
+error_if_exported(Status, Context, Item, !Specs) :-
( Status = status_exported ->
- error_is_exported(Context, Message, !IO)
+ error_is_exported(Context, Item, !Specs)
;
true
).
Index: compiler/make_hlds_passes.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/make_hlds_passes.m,v
retrieving revision 1.52
diff -u -b -r1.52 make_hlds_passes.m
--- compiler/make_hlds_passes.m 7 Sep 2006 05:50:56 -0000 1.52
+++ compiler/make_hlds_passes.m 10 Sep 2006 23:27:50 -0000
@@ -14,6 +14,7 @@
:- import_module hlds.make_hlds.qual_info.
:- import_module mdbcomp.prim_data.
:- import_module parse_tree.equiv_type.
+:- import_module parse_tree.error_util.
:- import_module parse_tree.module_qual.
:- import_module parse_tree.prog_data.
@@ -48,18 +49,19 @@
%
:- pred add_item_decl_pass_1(item::in, prog_context::in,
item_status::in, item_status::out, module_info::in, module_info::out,
- bool::out, io::di, io::uo) is det.
+ bool::out, list(error_spec)::in, list(error_spec)::out) is det.
:- pred add_item_clause(item::in, import_status::in, import_status::out,
prog_context::in, module_info::in, module_info::out,
- qual_info::in, qual_info::out, io::di, io::uo) is det.
+ qual_info::in, qual_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
:- pred add_stratified_pred(string::in, sym_name::in, arity::in,
- term.context::in, module_info::in, module_info::out, io::di, io::uo)
- is det.
+ term.context::in, module_info::in, module_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
% add_pred_marker(PragmaName, Name, Arity, Status,
- % Context, Marker, ConflictMarkers, !ModuleInfo, !IO):
+ % Context, Marker, ConflictMarkers, !ModuleInfo, !Specs):
%
% Adds Marker to the marker list of the pred(s) with give Name and Arity,
% updating the ModuleInfo. If the named pred does not exist, or the pred
@@ -67,7 +69,8 @@
%
:- pred add_pred_marker(string::in, sym_name::in, arity::in, import_status::in,
prog_context::in, marker::in, list(marker)::in,
- module_info::in, module_info::out, io::di, io::uo) is det.
+ module_info::in, module_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
:- type add_marker_pred_info == pred(pred_info, pred_info).
:- inst add_marker_pred_info == (pred(in, out) is det).
@@ -76,18 +79,15 @@
import_status::in, bool::in, term.context::in,
add_marker_pred_info::in(add_marker_pred_info),
module_info::in, module_info::out, list(pred_id)::out,
- io::di, io::uo) is det.
+ list(error_spec)::in, list(error_spec)::out) is det.
:- pred module_mark_as_external(sym_name::in, int::in, prog_context::in,
- module_info::in, module_info::out, io::di, io::uo) is det.
-
-:- pred check_for_errors(pred(module_info, module_info, io, io)
- ::pred(in, out, di, uo) is det, bool::out,
- module_info::in, module_info::out, io::di, io::uo) is det.
+ module_info::in, module_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
:- pred maybe_check_field_access_function(sym_name::in, arity::in,
import_status::in, prog_context::in, module_info::in,
- io::di, io::uo) is det.
+ list(error_spec)::in, list(error_spec)::out) is det.
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -115,7 +115,6 @@
:- import_module libs.compiler_util.
:- import_module libs.globals.
:- import_module libs.options.
-:- import_module parse_tree.error_util.
:- import_module parse_tree.prog_data.
:- import_module parse_tree.prog_mode.
:- import_module parse_tree.prog_mutable.
@@ -136,22 +135,30 @@
do_parse_tree_to_hlds(unit_module(Name, Items), MQInfo0, EqvMap, ModuleInfo,
QualInfo, InvalidTypes, InvalidModes, !IO) :-
- some [!Module] (
+ some [!Module, !Specs] (
globals.io_get_globals(Globals, !IO),
mq_info_get_partial_qualifier_info(MQInfo0, PQInfo),
module_info_init(Name, Items, Globals, PQInfo, no, !:Module),
+ !:Specs = [],
add_item_list_decls_pass_1(Items,
item_status(status_local, may_be_unqualified), !Module,
- no, InvalidModes0, !IO),
+ no, InvalidModes0, !Specs),
globals.io_lookup_bool_option(statistics, Statistics, !IO),
maybe_write_string(Statistics, "% Processed all items in pass 1\n",
!IO),
maybe_report_stats(Statistics, !IO),
- check_for_errors(
add_item_list_decls_pass_2(Items,
- item_status(status_local, may_be_unqualified)),
- InvalidTypes1, !Module, !IO),
+ item_status(status_local, may_be_unqualified),
+ !Module, [], Pass2Specs),
+ (
+ Pass2Specs = [],
+ InvalidTypes1 = no
+ ;
+ Pass2Specs = [_ | _],
+ InvalidTypes1 = yes
+ ),
+ !:Specs = Pass2Specs ++ !.Specs,
% Add constructors and special preds to the HLDS. This must be done
% after adding all type and `:- pragma foreign_type' declarations.
@@ -161,7 +168,7 @@
InvalidTypes1 = no,
module_info_get_type_table(!.Module, Types),
map.foldl3(process_type_defn, Types, no, InvalidTypes2, !Module,
- !IO)
+ !Specs)
;
InvalidTypes1 = yes,
InvalidTypes2 = yes
@@ -186,21 +193,22 @@
maybe_report_stats(Statistics, !IO),
init_qual_info(MQInfo0, EqvMap, QualInfo0),
add_item_list_clauses(Items, status_local, !Module,
- QualInfo0, QualInfo, !IO),
+ QualInfo0, QualInfo, !Specs),
qual_info_get_mq_info(QualInfo, MQInfo),
mq_info_get_type_error_flag(MQInfo, InvalidTypes3),
InvalidTypes = InvalidTypes1 `or` InvalidTypes2 `or` InvalidTypes3,
mq_info_get_mode_error_flag(MQInfo, InvalidModes1),
InvalidModes = InvalidModes0 `or` InvalidModes1,
- mq_info_get_num_errors(MQInfo, MQ_NumErrors),
- module_info_get_num_errors(!.Module, ModuleNumErrors),
- NumErrors = ModuleNumErrors + MQ_NumErrors,
- module_info_set_num_errors(NumErrors, !Module),
% The predid list is constructed in reverse order, for efficiency,
% so we return it to the correct order here.
module_info_reverse_predids(!Module),
+
+ sort_error_specs(!.Specs, SortedSpecs),
+ write_error_specs(SortedSpecs, 0, _NumWarnings, 0, NumErrors, !IO),
+ module_info_incr_num_errors(NumErrors, !Module),
+
ModuleInfo = !.Module
).
@@ -216,27 +224,6 @@
add_special_preds(TVarSet, Type, TypeCtor, Body, Context, Status,
!ModuleInfo).
-check_for_errors(P, FoundError, !ModuleInfo, !IO) :-
- io.get_exit_status(BeforeStatus, !IO),
- io.set_exit_status(0, !IO),
- module_info_get_num_errors(!.ModuleInfo, BeforeNumErrors),
- P(!ModuleInfo, !IO),
- module_info_get_num_errors(!.ModuleInfo, AfterNumErrors),
- io.get_exit_status(AfterStatus, !IO),
- (
- AfterStatus = 0,
- BeforeNumErrors = AfterNumErrors
- ->
- FoundError = no
- ;
- FoundError = yes
- ),
- ( BeforeStatus \= 0 ->
- io.set_exit_status(BeforeStatus, !IO)
- ;
- true
- ).
-
%-----------------------------------------------------------------------------%
% pass 1:
@@ -248,16 +235,16 @@
%
:- pred add_item_list_decls_pass_1(item_list::in, item_status::in,
module_info::in, module_info::out, bool::in, bool::out,
- io::di, io::uo) is det.
+ list(error_spec)::in, list(error_spec)::out) is det.
-add_item_list_decls_pass_1([], _, !ModuleInfo, !InvalidModes, !IO).
+add_item_list_decls_pass_1([], _, !ModuleInfo, !InvalidModes, !Specs).
add_item_list_decls_pass_1([Item - Context | Items], !.Status, !ModuleInfo,
- !InvalidModes, !IO) :-
+ !InvalidModes, !Specs) :-
add_item_decl_pass_1(Item, Context, !Status, !ModuleInfo,
- NewInvalidModes, !IO),
+ NewInvalidModes, !Specs),
!:InvalidModes = bool.or(!.InvalidModes, NewInvalidModes),
add_item_list_decls_pass_1(Items, !.Status, !ModuleInfo, !InvalidModes,
- !IO).
+ !Specs).
% pass 2:
% Add the type definitions and pragmas one by one to the module,
@@ -277,13 +264,14 @@
% sure that there isn't a mode declaration for the function.
%
:- pred add_item_list_decls_pass_2(item_list::in, item_status::in,
- module_info::in, module_info::out, io::di, io::uo) is det.
+ module_info::in, module_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
-add_item_list_decls_pass_2([], _, !ModuleInfo, !IO).
+add_item_list_decls_pass_2([], _, !ModuleInfo, !Specs).
add_item_list_decls_pass_2([Item - Context | Items], !.Status, !ModuleInfo,
- !IO) :-
- add_item_decl_pass_2(Item, Context, !Status, !ModuleInfo, !IO),
- add_item_list_decls_pass_2(Items, !.Status, !ModuleInfo, !IO).
+ !Specs) :-
+ add_item_decl_pass_2(Item, Context, !Status, !ModuleInfo, !Specs),
+ add_item_list_decls_pass_2(Items, !.Status, !ModuleInfo, !Specs).
% pass 3:
% Add the clauses one by one to the module.
@@ -299,21 +287,21 @@
%
:- pred add_item_list_clauses(item_list::in, import_status::in,
module_info::in, module_info::out, qual_info::in, qual_info::out,
- io::di, io::uo) is det.
+ list(error_spec)::in, list(error_spec)::out) is det.
-add_item_list_clauses([], _Status, !ModuleInfo, !QualInfo, !IO).
+add_item_list_clauses([], _Status, !ModuleInfo, !QualInfo, !Specs).
add_item_list_clauses([Item - Context | Items], Status0,
- !ModuleInfo, !QualInfo, !IO) :-
+ !ModuleInfo, !QualInfo, !Specs) :-
add_item_clause(Item, Status0, Status1, Context, !ModuleInfo, !QualInfo,
- !IO),
- add_item_list_clauses(Items, Status1, !ModuleInfo, !QualInfo, !IO).
+ !Specs),
+ add_item_list_clauses(Items, Status1, !ModuleInfo, !QualInfo, !Specs).
%-----------------------------------------------------------------------------%
add_item_decl_pass_1(item_clause(_, _, _, _, _, _), _, !Status, !ModuleInfo,
- no, !IO).
+ no, !Specs).
% Skip clauses.
-add_item_decl_pass_1(Item, Context, !Status, !ModuleInfo, no, !IO) :-
+add_item_decl_pass_1(Item, Context, !Status, !ModuleInfo, no, !Specs) :-
% If this is a solver type then we need to also add the declarations
% for the compiler generated construction function and deconstruction
% predicate for the special constrained data constructor.
@@ -326,21 +314,22 @@
Item = item_type_defn(TVarSet, SymName, TypeParams, TypeDefn, _Cond),
( TypeDefn = parse_tree_solver_type(SolverTypeDetails, _MaybeUserEqComp) ->
add_solver_type_decl_items(TVarSet, SymName, TypeParams,
- SolverTypeDetails, Context, !Status, !ModuleInfo, !IO),
+ SolverTypeDetails, Context, !Status, !ModuleInfo, !Specs),
add_solver_type_mutable_items_pass_1(SolverTypeDetails ^ mutable_items,
- Context, !Status, !ModuleInfo, !IO)
+ Context, !Status, !ModuleInfo, !Specs)
;
true
).
-add_item_decl_pass_1(Item, Context, !Status, !ModuleInfo, InvalidMode, !IO) :-
+add_item_decl_pass_1(Item, Context, !Status, !ModuleInfo, InvalidMode,
+ !Specs) :-
Item = item_inst_defn(VarSet, Name, Params, InstDefn, Cond),
module_add_inst_defn(VarSet, Name, Params, InstDefn, Cond, Context,
- !.Status, !ModuleInfo, InvalidMode, !IO).
-add_item_decl_pass_1(Item, Context, !Status, !ModuleInfo, InvalidMode, !IO) :-
+ !.Status, !ModuleInfo, InvalidMode, !Specs).
+add_item_decl_pass_1(Item, Context, !Status, !ModuleInfo, InvalidMode, !Specs) :-
Item = item_mode_defn(VarSet, Name, Params, ModeDefn, Cond),
module_add_mode_defn(VarSet, Name, Params, ModeDefn,
- Cond, Context, !.Status, !ModuleInfo, InvalidMode, !IO).
-add_item_decl_pass_1(Item, Context, !Status, !ModuleInfo, no, !IO) :-
+ Cond, Context, !.Status, !ModuleInfo, InvalidMode, !Specs).
+add_item_decl_pass_1(Item, Context, !Status, !ModuleInfo, no, !Specs) :-
Item = item_pred_or_func(Origin, TypeVarSet, InstVarSet, ExistQVars,
PredOrFunc, PredName, TypesAndModes, _WithType, _WithInst, MaybeDet,
_Cond, Purity, ClassContext),
@@ -371,8 +360,8 @@
),
module_add_pred_or_func(TypeVarSet, InstVarSet, ExistQVars,
PredOrFunc, PredName, TypesAndModes, MaybeDet, Purity, ClassContext,
- Markers, Context, !.Status, _, !ModuleInfo, !IO).
-add_item_decl_pass_1(Item, Context, !Status, !ModuleInfo, no, !IO) :-
+ Markers, Context, !.Status, _, !ModuleInfo, !Specs).
+add_item_decl_pass_1(Item, Context, !Status, !ModuleInfo, no, !Specs) :-
Item = item_pred_or_func_mode(VarSet, MaybePredOrFunc, PredName, Modes,
_WithInst, MaybeDet, _Cond),
(
@@ -380,7 +369,7 @@
!.Status = item_status(ImportStatus, _),
IsClassMethod = no,
module_add_mode(VarSet, PredName, Modes, MaybeDet, ImportStatus,
- Context, PredOrFunc, IsClassMethod, _, !ModuleInfo, !IO)
+ Context, PredOrFunc, IsClassMethod, _, !ModuleInfo, !Specs)
;
MaybePredOrFunc = no,
% equiv_type.m should have either set the pred_or_func
@@ -388,11 +377,11 @@
unexpected(this_file, "add_item_decl_pass_1: " ++
"no pred_or_func on mode declaration")
).
-add_item_decl_pass_1(Item, _, !Status, !ModuleInfo, no, !IO) :-
+add_item_decl_pass_1(Item, _, !Status, !ModuleInfo, no, !Specs) :-
Item = item_pragma(_, _).
-add_item_decl_pass_1(Item, _, !Status, !ModuleInfo, no, !IO) :-
+add_item_decl_pass_1(Item, _, !Status, !ModuleInfo, no, !Specs) :-
Item = item_promise(_, _, _, _).
-add_item_decl_pass_1(Item, Context, !Status, !ModuleInfo, no, !IO) :-
+add_item_decl_pass_1(Item, Context, !Status, !ModuleInfo, no, !Specs) :-
Item = item_module_defn(_VarSet, ModuleDefn),
( module_defn_update_import_status(ModuleDefn, StatusPrime) ->
!:Status = StatusPrime
@@ -424,7 +413,8 @@
true
; ModuleDefn = md_external(MaybeBackend, External) ->
( External = name_arity(Name, Arity) ->
- lookup_current_backend(CurrentBackend, !IO),
+ module_info_get_globals(!.ModuleInfo, Globals),
+ CurrentBackend = lookup_current_backend(Globals),
(
(
MaybeBackend = no
@@ -433,46 +423,49 @@
Backend = CurrentBackend
)
->
- module_mark_as_external(Name, Arity, Context, !ModuleInfo, !IO)
+ module_mark_as_external(Name, Arity, Context, !ModuleInfo,
+ !Specs)
;
true
)
;
- ExternalArityWarnMsg = [
- words("Warning:"), quote("external"),
- words("declaration requires arity.")
- ],
- report_warning(Context, 0, ExternalArityWarnMsg, !IO)
+ Pieces = [words("Warning:"), quote("external"),
+ words("declaration requires arity."), nl],
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
+ !:Specs = [Spec | !.Specs]
)
; ModuleDefn = md_module(_ModuleName) ->
- report_unexpected_decl("module", Context, !IO)
+ report_unexpected_decl("module", Context, !Specs)
; ModuleDefn = md_end_module(_ModuleName) ->
- report_unexpected_decl("end_module", Context, !IO)
+ report_unexpected_decl("end_module", Context, !Specs)
; ModuleDefn = md_version_numbers(_, _) ->
true
; ModuleDefn = md_transitively_imported ->
true
;
- prog_out.write_context(Context, !IO),
- report_warning("Warning: declaration not yet implemented.\n", !IO)
+ Pieces = [words("Warning: declaration not yet implemented."), nl],
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_warning, phase_parse_tree_to_hlds, [Msg]),
+ !:Specs = [Spec | !.Specs]
).
-add_item_decl_pass_1(Item, _, !Status, !ModuleInfo, no, !IO) :-
+add_item_decl_pass_1(Item, _, !Status, !ModuleInfo, no, !Specs) :-
Item = item_nothing(_).
-add_item_decl_pass_1(Item, Context, !Status, !ModuleInfo, no, !IO) :-
+add_item_decl_pass_1(Item, Context, !Status, !ModuleInfo, no, !Specs) :-
Item = item_typeclass(Constraints, FunDeps, Name, Vars, Interface, VarSet),
module_add_class_defn(Constraints, FunDeps, Name, Vars, Interface,
- VarSet, Context, !.Status, !ModuleInfo, !IO).
-add_item_decl_pass_1(Item, _, !Status, !ModuleInfo, no, !IO) :-
+ VarSet, Context, !.Status, !ModuleInfo, !Specs).
+add_item_decl_pass_1(Item, _, !Status, !ModuleInfo, no, !Specs) :-
% We add instance declarations on the second pass so that we don't add
% an instance declaration before its class declaration.
Item = item_instance(_, _, _, _, _,_).
-add_item_decl_pass_1(Item, _, !Status, !ModuleInfo, no, !IO) :-
+add_item_decl_pass_1(Item, _, !Status, !ModuleInfo, no, !Specs) :-
% We add initialise declarations on the third pass.
Item = item_initialise(_, _, _).
-add_item_decl_pass_1(Item, _, !Status, !ModuleInfo, no, !IO) :-
+add_item_decl_pass_1(Item, _, !Status, !ModuleInfo, no, !Specs) :-
% We add finalise declarations on the third pass.
Item = item_finalise(_, _, _).
-add_item_decl_pass_1(Item, Context, !Status, !ModuleInfo, no, !IO) :-
+add_item_decl_pass_1(Item, Context, !Status, !ModuleInfo, no, !Specs) :-
% We add the initialise decl and the foreign_decl on the second pass and
% the foreign_proc clauses on the third pass.
Item = item_mutable(Name, Type, _InitValue, Inst, MutAttrs, _MutVarset),
@@ -487,76 +480,71 @@
%
InitPredDecl = mutable_init_pred_decl(ModuleName, Name),
add_item_decl_pass_1(InitPredDecl, Context, !Status, !ModuleInfo, _,
- !IO),
+ !Specs),
IsConstant = mutable_var_constant(MutAttrs),
(
IsConstant = no,
- %
+
% Create the mutex initialisation predicate. This is called
% by the mutable initialisation predicate.
- %
InitMutexPredDecl = mutable_init_mutex_pred_decl(ModuleName, Name),
add_item_decl_pass_1(InitMutexPredDecl, Context, !Status,
- !ModuleInfo, _, !IO),
- %
+ !ModuleInfo, _, !Specs),
+
% Create the primitive access and locking predicates.
- %
LockPredDecl = lock_pred_decl(ModuleName, Name),
add_item_decl_pass_1(LockPredDecl, Context, !Status,
- !ModuleInfo, _, !IO),
+ !ModuleInfo, _, !Specs),
UnlockPredDecl = unlock_pred_decl(ModuleName, Name),
add_item_decl_pass_1(UnlockPredDecl, Context, !Status,
- !ModuleInfo, _, !IO),
+ !ModuleInfo, _, !Specs),
UnsafeGetPredDecl = unsafe_get_pred_decl(ModuleName, Name,
Type, Inst),
add_item_decl_pass_1(UnsafeGetPredDecl, Context, !Status,
- !ModuleInfo, _, !IO),
+ !ModuleInfo, _, !Specs),
UnsafeSetPredDecl = unsafe_set_pred_decl(ModuleName, Name,
Type, Inst),
add_item_decl_pass_1(UnsafeSetPredDecl, Context, !Status,
- !ModuleInfo, _, !IO),
- %
+ !ModuleInfo, _, !Specs),
+
% Create the standard, non-pure access predicates. These are
% always created for non-constant mutables, even if the
% `attach_to_io_state' attribute has been specified.
- %
StdGetPredDecl = std_get_pred_decl(ModuleName, Name, Type, Inst),
add_item_decl_pass_1(StdGetPredDecl, Context, !Status,
- !ModuleInfo, _, !IO),
+ !ModuleInfo, _, !Specs),
StdSetPredDecl = std_set_pred_decl(ModuleName, Name, Type, Inst),
add_item_decl_pass_1(StdSetPredDecl, Context, !Status,
- !ModuleInfo, _, !IO),
- %
+ !ModuleInfo, _, !Specs),
+
% If requested, create the pure access predicates using
% the I/O state as well.
- %
CreateIOInterface = mutable_var_attach_to_io_state(MutAttrs),
(
CreateIOInterface = yes,
IOGetPredDecl = io_get_pred_decl(ModuleName, Name, Type, Inst),
add_item_decl_pass_1(IOGetPredDecl, Context, !Status,
- !ModuleInfo, _, !IO),
+ !ModuleInfo, _, !Specs),
IOSetPredDecl = io_set_pred_decl(ModuleName, Name, Type, Inst),
add_item_decl_pass_1(IOSetPredDecl, Context, !Status,
- !ModuleInfo, _, !IO)
+ !ModuleInfo, _, !Specs)
;
CreateIOInterface = no
)
;
IsConstant = yes,
- %
+
% We create the "get" access predicate, which is pure since
% it always returns the same value, but we must also create
% a secret "set" predicate for use by the initialization code.
- %
ConstantGetPredDecl = constant_get_pred_decl(ModuleName, Name,
Type, Inst),
add_item_decl_pass_1(ConstantGetPredDecl, Context, !Status,
- !ModuleInfo, _, !IO),
+ !ModuleInfo, _, !Specs),
ConstantSetPredDecl = constant_set_pred_decl(ModuleName, Name,
Type, Inst),
add_item_decl_pass_1(ConstantSetPredDecl, Context, !Status,
- !ModuleInfo, _, !IO)
+ !ModuleInfo, _, !Specs)
)
;
DefinedThisModule = no
@@ -564,43 +552,43 @@
:- pred add_solver_type_mutable_items_pass_1(list(item)::in, prog_context::in,
item_status::in, item_status::out, module_info::in, module_info::out,
- io::di, io::uo) is det.
+ list(error_spec)::in, list(error_spec)::out) is det.
-add_solver_type_mutable_items_pass_1([], _Context, !Status, !ModuleInfo, !IO).
+add_solver_type_mutable_items_pass_1([], _Context, !Status, !ModuleInfo, !Specs).
add_solver_type_mutable_items_pass_1([Item | Items], Context, !Status,
- !ModuleInfo, !IO) :-
- add_item_decl_pass_1(Item, Context, !Status, !ModuleInfo, _, !IO),
+ !ModuleInfo, !Specs) :-
+ add_item_decl_pass_1(Item, Context, !Status, !ModuleInfo, _, !Specs),
add_solver_type_mutable_items_pass_1(Items, Context, !Status, !ModuleInfo,
- !IO).
+ !Specs).
%-----------------------------------------------------------------------------%
:- pred add_item_decl_pass_2(item::in, prog_context::in, item_status::in,
item_status::out, module_info::in, module_info::out,
- io::di, io::uo) is det.
+ list(error_spec)::in, list(error_spec)::out) is det.
-add_item_decl_pass_2(Item, _Context, !Status, !ModuleInfo, !IO) :-
+add_item_decl_pass_2(Item, _Context, !Status, !ModuleInfo, !Specs) :-
Item = item_module_defn(_VarSet, ModuleDefn),
( module_defn_update_import_status(ModuleDefn, StatusPrime) ->
!:Status = StatusPrime
;
true
).
-add_item_decl_pass_2(Item, Context, !Status, !ModuleInfo, !IO) :-
+add_item_decl_pass_2(Item, Context, !Status, !ModuleInfo, !Specs) :-
Item = item_type_defn(VarSet, Name, Args, TypeDefn, Cond),
module_add_type_defn(VarSet, Name, Args, TypeDefn, Cond, Context,
- !.Status, !ModuleInfo, !IO),
+ !.Status, !ModuleInfo, !Specs),
( TypeDefn = parse_tree_solver_type(SolverTypeDetails, _MaybeUserEqComp) ->
add_solver_type_mutable_items_pass_2(SolverTypeDetails ^ mutable_items,
- Context, !Status, !ModuleInfo, !IO)
+ Context, !Status, !ModuleInfo, !Specs)
;
true
).
-add_item_decl_pass_2(Item, Context, !Status, !ModuleInfo, !IO) :-
+add_item_decl_pass_2(Item, Context, !Status, !ModuleInfo, !Specs) :-
Item = item_pragma(Origin, Pragma),
- add_pragma(Origin, Pragma, Context, !Status, !ModuleInfo, !IO).
-add_item_decl_pass_2(Item, _Context, !Status, !ModuleInfo, !IO) :-
+ add_pragma(Origin, Pragma, Context, !Status, !ModuleInfo, !Specs).
+add_item_decl_pass_2(Item, _Context, !Status, !ModuleInfo, !Specs) :-
Item = item_pred_or_func(_Origin, _TypeVarSet, _InstVarSet, _ExistQVars,
PredOrFunc, SymName, TypesAndModes, _WithType, _WithInst,
_MaybeDet, _Cond, _Purity, _ClassContext),
@@ -626,21 +614,21 @@
unexpected(this_file, "can't find func declaration")
)
).
-add_item_decl_pass_2(Item, _, !Status, !ModuleInfo, !IO) :-
+add_item_decl_pass_2(Item, _, !Status, !ModuleInfo, !Specs) :-
Item = item_promise(_, _, _, _).
-add_item_decl_pass_2(Item, _, !Status, !ModuleInfo, !IO) :-
+add_item_decl_pass_2(Item, _, !Status, !ModuleInfo, !Specs) :-
Item = item_clause(_, _, _, _, _, _).
-add_item_decl_pass_2(Item, _, !Status, !ModuleInfo, !IO) :-
+add_item_decl_pass_2(Item, _, !Status, !ModuleInfo, !Specs) :-
Item = item_inst_defn(_, _, _, _, _).
-add_item_decl_pass_2(Item, _, !Status, !ModuleInfo, !IO) :-
+add_item_decl_pass_2(Item, _, !Status, !ModuleInfo, !Specs) :-
Item = item_mode_defn(_, _, _, _, _).
-add_item_decl_pass_2(Item, _, !Status, !ModuleInfo, !IO) :-
+add_item_decl_pass_2(Item, _, !Status, !ModuleInfo, !Specs) :-
Item = item_pred_or_func_mode(_, _, _, _, _, _, _).
-add_item_decl_pass_2(Item, _, !Status, !ModuleInfo, !IO) :-
+add_item_decl_pass_2(Item, _, !Status, !ModuleInfo, !Specs) :-
Item = item_nothing(_).
-add_item_decl_pass_2(Item, _, !Status, !ModuleInfo, !IO) :-
+add_item_decl_pass_2(Item, _, !Status, !ModuleInfo, !Specs) :-
Item = item_typeclass(_, _, _, _, _, _).
-add_item_decl_pass_2(Item, Context, !Status, !ModuleInfo, !IO) :-
+add_item_decl_pass_2(Item, Context, !Status, !ModuleInfo, !Specs) :-
Item = item_instance(Constraints, Name, Types, Body, VarSet,
InstanceModuleName),
!.Status = item_status(ImportStatus, _),
@@ -650,8 +638,8 @@
BodyStatus = ImportStatus
),
module_add_instance_defn(InstanceModuleName, Constraints, Name, Types,
- Body, VarSet, BodyStatus, Context, !ModuleInfo, !IO).
-add_item_decl_pass_2(Item, Context, !Status, !ModuleInfo, !IO) :-
+ Body, VarSet, BodyStatus, Context, !ModuleInfo, !Specs).
+add_item_decl_pass_2(Item, Context, !Status, !ModuleInfo, !Specs) :-
% These are processed properly during pass 3, we just do some
% error checking at this point.
Item = item_initialise(Origin, _, _),
@@ -659,8 +647,7 @@
( ImportStatus = status_exported ->
(
Origin = user,
- error_is_exported(Context, "`initialise' declaration", !IO),
- module_info_incr_errors(!ModuleInfo)
+ error_is_exported(Context, "`initialise' declaration", !Specs)
;
Origin = compiler(Details),
(
@@ -680,7 +667,7 @@
;
true
).
-add_item_decl_pass_2(Item, Context, !Status, !ModuleInfo, !IO) :-
+add_item_decl_pass_2(Item, Context, !Status, !ModuleInfo, !Specs) :-
% There are processed properly during pass 3, we just do some error
% checking at this point.
Item = item_finalise(Origin, _, _),
@@ -688,8 +675,7 @@
( ImportStatus = status_exported ->
(
Origin = user,
- error_is_exported(Context, "`finalise' declaration", !IO),
- module_info_incr_errors(!ModuleInfo)
+ error_is_exported(Context, "`finalise' declaration", !Specs)
;
% There are no source-to-source transformations that introduce
% finalise declarations.
@@ -699,12 +685,11 @@
;
true
).
-add_item_decl_pass_2(Item, Context, !Status, !ModuleInfo, !IO) :-
+add_item_decl_pass_2(Item, Context, !Status, !ModuleInfo, !Specs) :-
Item = item_mutable(Name, _Type, _InitTerm, _Inst, MutAttrs, _MutVarset),
!.Status = item_status(ImportStatus, _),
( ImportStatus = status_exported ->
- error_is_exported(Context, "`mutable' declaration", !IO),
- module_info_incr_errors(!ModuleInfo)
+ error_is_exported(Context, "`mutable' declaration", !Specs)
;
true
),
@@ -716,11 +701,11 @@
DefinedThisModule = status_defined_in_this_module(ImportStatus),
(
DefinedThisModule = yes,
- globals.io_get_target(CompilationTarget, !IO),
- %
+ module_info_get_globals(!.ModuleInfo, Globals),
+ globals.get_target(Globals, CompilationTarget),
+
% XXX We don't currently support the foreign_name attribute
% for languages other than C.
- %
( CompilationTarget = target_c ->
mutable_var_maybe_foreign_names(MutAttrs) = MaybeForeignNames,
module_info_get_name(!.ModuleInfo, ModuleName),
@@ -728,38 +713,38 @@
MaybeForeignNames = no
;
MaybeForeignNames = yes(ForeignNames),
- %
+
% Report any errors with the foreign_name attributes
% during this pass.
- %
ReportErrors = yes,
- get_global_name_from_foreign_names(ReportErrors, Context,
- ModuleName, Name, ForeignNames, _TargetMutableName, !IO)
+ get_global_name_from_foreign_names(!.ModuleInfo, ReportErrors,
+ Context, ModuleName, Name, ForeignNames,
+ _TargetMutableName, !Specs)
),
- %
+
% If we are creating the I/O version of the set predicate then we
% need to add a promise_pure pragma for it. This needs to be done
% here (in stage 2) rather than in stage 3 where the rest of the
% mutable transformation is.
- %
+
IOStateInterface = mutable_var_attach_to_io_state(MutAttrs),
(
IOStateInterface = yes,
SetPredName = mutable_set_pred_sym_name(ModuleName, Name),
IOSetPromisePurePragma = pragma_promise_pure(SetPredName, 3),
add_pragma(compiler(mutable_decl), IOSetPromisePurePragma,
- Context, !Status, !ModuleInfo, !IO)
+ Context, !Status, !ModuleInfo, !Specs)
;
IOStateInterface = no
)
;
- NYIError = [
- words("Error: foreign_name mutable attribute not yet"),
+ Pieces = [words("Error: foreign_name mutable attribute not yet"),
words("implemented for the"),
fixed(compilation_target_string(CompilationTarget)),
- words("backend.")
- ],
- write_error_pieces(Context, 0, NYIError, !IO)
+ words("backend."), nl],
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
+ !:Specs = [Spec | !.Specs]
)
;
DefinedThisModule = no
@@ -767,26 +752,28 @@
:- pred add_solver_type_mutable_items_pass_2(list(item)::in, prog_context::in,
item_status::in, item_status::out, module_info::in, module_info::out,
- io::di, io::uo) is det.
+ list(error_spec)::in, list(error_spec)::out) is det.
-add_solver_type_mutable_items_pass_2([], _Context, !Status, !ModuleInfo, !IO).
+add_solver_type_mutable_items_pass_2([], _Context, !Status,
+ !ModuleInfo, !Specs).
add_solver_type_mutable_items_pass_2([Item | Items], Context, !Status,
- !ModuleInfo, !IO) :-
- add_item_decl_pass_2(Item, Context, !Status, !ModuleInfo, !IO),
- add_solver_type_mutable_items_pass_2(Items, Context, !Status, !ModuleInfo,
- !IO).
-
- % Check to see if there is a valid foreign_name attribute for this
- % backend. If so, use it as the name of the global variable in
- % the target code, otherwise take the Mercury name for the mutable
- % and mangle it into an appropriate variable name.
- %
- :- pred get_global_name_from_foreign_names(bool::in, prog_context::in,
- module_name::in, string::in, list(foreign_name)::in, string::out,
- io::di, io::uo) is det.
-
-get_global_name_from_foreign_names(ReportErrors, Context, ModuleName,
- MercuryMutableName, ForeignNames, TargetMutableName, !IO) :-
+ !ModuleInfo, !Specs) :-
+ add_item_decl_pass_2(Item, Context, !Status, !ModuleInfo, !Specs),
+ add_solver_type_mutable_items_pass_2(Items, Context, !Status,
+ !ModuleInfo, !Specs).
+
+ % Check to see if there is a valid foreign_name attribute for this backend.
+ % If so, use it as the name of the global variable in the target code,
+ % otherwise take the Mercury name for the mutable and mangle it into
+ % an appropriate variable name.
+ %
+ :- pred get_global_name_from_foreign_names(module_info::in, bool::in,
+ prog_context::in, module_name::in, string::in, list(foreign_name)::in,
+ string::out, list(error_spec)::in, list(error_spec)::out) is det.
+
+get_global_name_from_foreign_names(ModuleInfo, ReportErrors, Context,
+ ModuleName, MercuryMutableName, ForeignNames, TargetMutableName,
+ !Specs) :-
solutions(get_matching_foreign_name(ForeignNames, lang_c),
TargetMutableNames),
(
@@ -800,14 +787,15 @@
TargetMutableNames = [_, _ | _],
(
ReportErrors = yes,
- globals.io_get_target(CompilationTarget, !IO),
- MultipleNamesError = [
- words("Error: multiple foreign_name attributes specified"),
- words("for the"),
+ module_info_get_globals(ModuleInfo, Globals),
+ globals.get_target(Globals, CompilationTarget),
+ Pieces = [words("Error: multiple foreign_name attributes"),
+ words("specified for the"),
fixed(compilation_target_string(CompilationTarget)),
- words("backend.")
- ],
- write_error_pieces(Context, 0, MultipleNamesError, !IO)
+ words("backend."), nl],
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
+ !:Specs = [Spec | !.Specs]
;
ReportErrors = no
),
@@ -823,7 +811,7 @@
%-----------------------------------------------------------------------------%
-add_item_clause(Item, !Status, Context, !ModuleInfo, !QualInfo, !IO) :-
+add_item_clause(Item, !Status, Context, !ModuleInfo, !QualInfo, !Specs) :-
Item = item_clause(Origin, VarSet, PredOrFunc, PredName, Args, Body),
( !.Status = status_exported ->
(
@@ -835,8 +823,7 @@
UnqualifiedPredName = unqualify_name(PredName),
ClauseId = simple_call_id_to_string(PredOrFunc,
unqualified(UnqualifiedPredName) / Arity),
- error_is_exported(Context, "clause for " ++ ClauseId, !IO),
- module_info_incr_errors(!ModuleInfo)
+ error_is_exported(Context, "clause for " ++ ClauseId, !Specs)
;
Origin = compiler(Details),
(
@@ -860,8 +847,8 @@
),
% At this stage we only need know that it's not a promise declaration.
module_add_clause(VarSet, PredOrFunc, PredName, Args, Body, !.Status,
- Context, goal_type_none, !ModuleInfo, !QualInfo, !IO).
-add_item_clause(Item, !Status, Context, !ModuleInfo, !QualInfo, !IO) :-
+ Context, goal_type_none, !ModuleInfo, !QualInfo, !Specs).
+add_item_clause(Item, !Status, Context, !ModuleInfo, !QualInfo, !Specs) :-
Item = item_type_defn(_TVarSet, SymName, TypeParams, TypeDefn, _Cond),
% If this is a solver type then we need to also add clauses
% the compiler generated inst cast predicate (the declaration
@@ -872,18 +859,18 @@
status_defined_in_this_module(!.Status) = yes
->
add_solver_type_clause_items(SymName, TypeParams, SolverTypeDetails,
- !Status, Context, !ModuleInfo, !QualInfo, !IO),
+ !Status, Context, !ModuleInfo, !QualInfo, !Specs),
MutableItems = SolverTypeDetails ^ mutable_items,
add_solver_type_mutable_items_clauses(MutableItems,
- !Status, Context, !ModuleInfo, !QualInfo, !IO)
+ !Status, Context, !ModuleInfo, !QualInfo, !Specs)
;
true
).
-add_item_clause(Item, !Status, _, !ModuleInfo, !QualInfo, !IO) :-
+add_item_clause(Item, !Status, _, !ModuleInfo, !QualInfo, !Specs) :-
Item = item_inst_defn(_, _, _, _, _).
-add_item_clause(Item, !Status, _, !ModuleInfo, !QualInfo, !IO) :-
+add_item_clause(Item, !Status, _, !ModuleInfo, !QualInfo, !Specs) :-
Item = item_mode_defn(_, _, _, _, _).
-add_item_clause(Item, !Status, Context, !ModuleInfo, !QualInfo, !IO) :-
+add_item_clause(Item, !Status, Context, !ModuleInfo, !QualInfo, !Specs) :-
Item = item_pred_or_func(_, _, _, _, PredOrFunc, SymName, TypesAndModes,
_WithType, _WithInst, _, _, _, _),
(
@@ -893,23 +880,20 @@
list.length(TypesAndModes, PredArity),
adjust_func_arity(function, FuncArity, PredArity),
maybe_check_field_access_function(SymName, FuncArity, !.Status,
- Context, !.ModuleInfo, !IO)
+ Context, !.ModuleInfo, !Specs)
).
-add_item_clause(Item, !Status, _, !ModuleInfo, !QualInfo, !IO) :-
+add_item_clause(Item, !Status, _, !ModuleInfo, !QualInfo, !Specs) :-
Item = item_pred_or_func_mode(_, _, _, _, _, _, _).
-add_item_clause(Item, !Status, _, !ModuleInfo, !QualInfo, !IO) :-
+add_item_clause(Item, !Status, _, !ModuleInfo, !QualInfo, !Specs) :-
Item = item_module_defn(_, Defn),
( Defn = md_version_numbers(ModuleName, ModuleVersionNumbers) ->
- %
% Record the version numbers for each imported module
% if smart recompilation is enabled.
- %
- apply_to_recompilation_info(
- (pred(RecompInfo0::in, RecompInfo::out) is det :-
+ RecordPred = (pred(RecompInfo0::in, RecompInfo::out) is det :-
RecompInfo = RecompInfo0 ^ version_numbers ^
map.elem(ModuleName) := ModuleVersionNumbers
),
- !QualInfo)
+ apply_to_recompilation_info(RecordPred, !QualInfo)
; module_defn_update_import_status(Defn, ItemStatus1) ->
ItemStatus1 = item_status(!:Status, NeedQual),
qual_info_get_mq_info(!.QualInfo, MQInfo0),
@@ -918,87 +902,89 @@
;
true
).
-add_item_clause(Item, !Status, Context, !ModuleInfo, !QualInfo, !IO) :-
+add_item_clause(Item, !Status, Context, !ModuleInfo, !QualInfo, !Specs) :-
Item = item_pragma(Origin, Pragma),
(
Pragma = pragma_foreign_proc(Attributes, Pred, PredOrFunc,
Vars, ProgVarSet, InstVarSet, PragmaImpl),
module_add_pragma_foreign_proc(Attributes, Pred, PredOrFunc,
Vars, ProgVarSet, InstVarSet, PragmaImpl, !.Status, Context,
- !ModuleInfo, !QualInfo, !IO)
+ !ModuleInfo, !QualInfo, !Specs)
;
Pragma = pragma_import(Name, PredOrFunc, Modes, Attributes,
C_Function),
module_add_pragma_import(Name, PredOrFunc, Modes, Attributes,
- C_Function, !.Status, Context, !ModuleInfo, !QualInfo, !IO)
+ C_Function, !.Status, Context, !ModuleInfo, !QualInfo, !Specs)
;
Pragma = pragma_fact_table(Pred, Arity, File),
module_add_pragma_fact_table(Pred, Arity, File, !.Status,
- Context, !ModuleInfo, !QualInfo, !IO)
+ Context, !ModuleInfo, !QualInfo, !Specs)
;
Pragma = pragma_tabled(Type, Name, Arity, PredOrFunc, MaybeModes,
MaybeAttributes),
- globals.io_lookup_bool_option(type_layout, TypeLayout, !IO),
+ module_info_get_globals(!.ModuleInfo, Globals),
+ globals.lookup_bool_option(Globals, type_layout, TypeLayout),
(
TypeLayout = yes,
module_add_pragma_tabled(Type, Name, Arity, PredOrFunc, MaybeModes,
- MaybeAttributes, !Status, Context, !ModuleInfo, !QualInfo, !IO)
+ MaybeAttributes, !Status, Context, !ModuleInfo, !QualInfo,
+ !Specs)
;
TypeLayout = no,
- module_info_incr_errors(!ModuleInfo),
- prog_out.write_context(Context, !IO),
- io.write_string("Error: `:- pragma ", !IO),
- EvalMethodS = eval_method_to_string(Type),
- io.write_string(EvalMethodS, !IO),
- io.write_string("' declaration requires the type_ctor_layout\n",
- !IO),
- prog_out.write_context(Context, !IO),
- io.write_string(" structures. Use " ++
- "the --type-layout flag to enable them.\n", !IO)
+ Pieces = [words("Error:"),
+ quote(":- pragma " ++ eval_method_to_string(Type)),
+ words("declaration requires type_ctor_layout structures."),
+ words("Don't use --no-type-layout to disable them."),
+ nl],
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
+ !:Specs = [Spec | !.Specs]
)
;
Pragma = pragma_type_spec(_, _, _, _, _, _, _, _),
% XXX For the Java back-end, `pragma type_spec' can result in
% class names that exceed the limits on file name length.
% So we ignore these pragmas for the Java back-end.
- globals.io_get_target(Target, !IO),
+ module_info_get_globals(!.ModuleInfo, Globals),
+ globals.get_target(Globals, Target),
( Target = target_java ->
true
;
- add_pragma_type_spec(Pragma, Context, !ModuleInfo, !QualInfo, !IO)
+ add_pragma_type_spec(Pragma, Context, !ModuleInfo, !QualInfo,
+ !Specs)
)
;
Pragma = pragma_termination_info(PredOrFunc, SymName, ModeList,
MaybeArgSizeInfo, MaybeTerminationInfo),
add_pragma_termination_info(PredOrFunc, SymName, ModeList,
MaybeArgSizeInfo, MaybeTerminationInfo, Context,
- !ModuleInfo, !IO)
+ !ModuleInfo, !Specs)
;
Pragma = pragma_termination2_info(PredOrFunc, SymName, ModeList,
MaybeSuccessArgSizeInfo, MaybeFailureArgSizeInfo,
MaybeTerminationInfo),
add_pragma_termination2_info(PredOrFunc, SymName, ModeList,
MaybeSuccessArgSizeInfo, MaybeFailureArgSizeInfo,
- MaybeTerminationInfo, Context, !ModuleInfo, !IO)
+ MaybeTerminationInfo, Context, !ModuleInfo, !Specs)
;
Pragma = pragma_structure_sharing(PredOrFunc, SymName, ModeList,
HeadVars, Types, SharingDomain),
add_pragma_structure_sharing(PredOrFunc, SymName, ModeList,
- HeadVars, Types, SharingDomain, Context, !ModuleInfo, !IO)
+ HeadVars, Types, SharingDomain, Context, !ModuleInfo, !Specs)
;
Pragma = pragma_structure_reuse(PredOrFunc, SymName, ModeList,
HeadVars, Types, MaybeReuseDomain),
add_pragma_structure_reuse(PredOrFunc, SymName, ModeList,
- HeadVars, Types, MaybeReuseDomain, Context, !ModuleInfo, !IO)
+ HeadVars, Types, MaybeReuseDomain, Context, !ModuleInfo, !Specs)
;
Pragma = pragma_reserve_tag(TypeName, TypeArity),
add_pragma_reserve_tag(TypeName, TypeArity, !.Status, Context,
- !ModuleInfo, !IO)
+ !ModuleInfo, !Specs)
;
Pragma = pragma_foreign_export(Lang, Name, PredOrFunc, Modes,
C_Function),
add_pragma_foreign_export(Origin, Lang, Name, PredOrFunc, Modes,
- C_Function, Context, !ModuleInfo, !IO)
+ C_Function, Context, !ModuleInfo, !Specs)
;
% Don't worry about any pragma declarations other than the
% clause-like pragmas (c_code, tabling and fact_table),
@@ -1025,47 +1011,42 @@
)
).
add_item_clause(item_promise(PromiseType, Goal, VarSet, UnivVars),
- !Status, Context, !ModuleInfo, !QualInfo, !IO) :-
- %
- % If the outermost universally quantified variables
- % are placed in the head of the dummy predicate, the
- % typechecker will avoid warning about unbound
- % type variables as this implicity adds a universal
- % quantification of the typevariables needed.
- %
+ !Status, Context, !ModuleInfo, !QualInfo, !Specs) :-
+ % If the outermost universally quantified variables are placed in the head
+ % of the dummy predicate, the typechecker will avoid warning about unbound
+ % type variables as this implicity adds a universal quantification of the
+ % typevariables needed.
+
term.var_list_to_term_list(UnivVars, HeadVars),
% extra error checking for promise ex declarations
- ( PromiseType \= true ->
- check_promise_ex_decl(UnivVars, PromiseType, Goal, Context, !IO)
+ ( PromiseType \= promise_type_true ->
+ check_promise_ex_decl(UnivVars, PromiseType, Goal, Context, !Specs)
;
true
),
- % add as dummy predicate
+ % Add as dummy predicate.
add_promise_clause(PromiseType, HeadVars, VarSet, Goal, Context,
- !.Status, !ModuleInfo, !QualInfo, !IO).
-add_item_clause(item_nothing(_), !Status, _, !ModuleInfo, !QualInfo, !IO).
+ !.Status, !ModuleInfo, !QualInfo, !Specs).
+add_item_clause(item_nothing(_), !Status, _, !ModuleInfo, !QualInfo, !Specs).
add_item_clause(item_typeclass(_, _, _, _, _, _), !Status, _, !ModuleInfo,
- !QualInfo, !IO).
+ !QualInfo, !Specs).
add_item_clause(item_instance(_, _, _, _, _, _), !Status, _, !ModuleInfo,
- !QualInfo, !IO).
+ !QualInfo, !Specs).
add_item_clause(item_initialise(user, SymName, Arity), !Status, Context,
- !ModuleInfo, !QualInfo, !IO) :-
- %
+ !ModuleInfo, !QualInfo, !Specs) :-
% To handle a `:- initialise initpred.' declaration we need to:
% (1) construct a new C function name, CName, to use to export initpred,
% (2) add the export pragma that does this
% (3) record the initpred/cname pair in the ModuleInfo so that
% code generation can ensure cname is called during module initialisation.
- %
+
module_info_get_predicate_table(!.ModuleInfo, PredTable),
(
predicate_table_search_pred_sym_arity(PredTable,
may_be_partially_qualified, SymName, Arity, PredIds)
->
- (
- PredIds = [PredId]
- ->
+ ( PredIds = [PredId] ->
module_info_pred_info(!.ModuleInfo, PredId, PredInfo),
pred_info_get_arg_types(PredInfo, ArgTypes),
pred_info_get_procedures(PredInfo, ProcTable),
@@ -1091,7 +1072,7 @@
pragma_foreign_export(ExportLang, SymName, predicate,
[di_mode, uo_mode], CName)),
add_item_clause(PragmaExportItem, !Status, Context,
- !ModuleInfo, !QualInfo, !IO)
+ !ModuleInfo, !QualInfo, !Specs)
;
ArgTypes = [],
list.member(ProcInfo, ProcInfos),
@@ -1110,42 +1091,40 @@
pragma_foreign_export(ExportLang, SymName, predicate,
[], CName)),
add_item_clause(PragmaExportedItem, !Status, Context,
- !ModuleInfo, !QualInfo, !IO)
+ !ModuleInfo, !QualInfo, !Specs)
;
- write_error_pieces(Context, 0,
- [
- words("Error:"),
- sym_name_and_arity(SymName/Arity),
+ Pieces = [words("Error:"), sym_name_and_arity(SymName/Arity),
words("used in initialise declaration has"),
- words("invalid signature.")
- ], !IO),
- %
+ words("invalid signature."), nl],
% TODO: provide verbose error information here.
- %
- module_info_incr_errors(!ModuleInfo)
- )
- ;
- write_error_pieces(Context, 0, [words("Error:"),
- sym_name_and_arity(SymName/Arity),
- words(" used in initialise declaration has " ++
- "multiple pred declarations.")], !IO),
- module_info_incr_errors(!ModuleInfo)
- )
- ;
- write_error_pieces(Context, 0, [words("Error:"),
- sym_name_and_arity(SymName/Arity),
- words(" used in initialise declaration does " ++
- "not have a corresponding pred declaration.")], !IO),
- module_info_incr_errors(!ModuleInfo)
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds,
+ [Msg]),
+ !:Specs = [Spec | !.Specs]
+ )
+ ;
+ Pieces = [words("Error:"), sym_name_and_arity(SymName/Arity),
+ words("used in initialise declaration"),
+ words("multiple pred declarations."), nl],
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
+ !:Specs = [Spec | !.Specs]
+ )
+ ;
+ Pieces = [words("Error:"), sym_name_and_arity(SymName/Arity),
+ words("used in initialise declaration"),
+ words("does not have a corresponding pred declaration."), nl],
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
+ !:Specs = [Spec | !.Specs]
).
add_item_clause(item_initialise(compiler(Details), SymName, _Arity),
- !Status, Context, !ModuleInfo, !QualInfo, !IO) :-
- %
+ !Status, Context, !ModuleInfo, !QualInfo, !Specs) :-
% The compiler introduces initialise declarations that call impure
% predicates as part of the source-to-source transformation for mutable
% variables. These predicates *must* be impure in order to prevent the
% compiler optimizing them away.
- %
+
( Details = mutable_decl ->
module_info_new_user_init_pred(SymName, CName, !ModuleInfo),
ExportLang = lang_c, % XXX Implement for other backends.
@@ -1154,19 +1133,18 @@
pragma_foreign_export(ExportLang, SymName, predicate, [],
CName)),
add_item_clause(PragmaExportItem, !Status, Context,
- !ModuleInfo, !QualInfo, !IO)
+ !ModuleInfo, !QualInfo, !Specs)
;
unexpected(this_file, "Bad introduced initialise declaration.")
).
add_item_clause(item_finalise(Origin, SymName, Arity),
- !Status, Context, !ModuleInfo, !QualInfo, !IO) :-
- %
+ !Status, Context, !ModuleInfo, !QualInfo, !Specs) :-
% To handle a `:- finalise finalpred.' declaration we need to:
% (1) construct a new C function name, CName, to use to export finalpred,
% (2) add `:- pragma foreign_export("C", finalpred(di, uo), CName).',
% (3) record the finalpred/cname pair in the ModuleInfo so that
% code generation can ensure cname is called during module finalisation.
- %
+
( Origin \= user ->
unexpected(this_file, "Bad introduced finalise declaration.")
;
@@ -1206,7 +1184,7 @@
pragma_foreign_export(ExportLang, SymName, predicate,
[di_mode, uo_mode], CName)),
add_item_clause(PragmaExportItem, !Status, Context,
- !ModuleInfo, !QualInfo, !IO)
+ !ModuleInfo, !QualInfo, !Specs)
;
ArgTypes = [],
list.member(ProcInfo, ProcInfos),
@@ -1225,71 +1203,71 @@
pragma_foreign_export(ExportLang, SymName, predicate,
[], CName)),
add_item_clause(PragmaExportItem, !Status, Context,
- !ModuleInfo, !QualInfo, !IO)
+ !ModuleInfo, !QualInfo, !Specs)
;
- write_error_pieces(Context, 0,
- [
- words("Error:"),
- sym_name_and_arity(SymName/Arity),
- words("used in finalise declaration has"),
- words("invalid signature.")
- ], !IO),
- module_info_incr_errors(!ModuleInfo)
+ Pieces = [words("Error:"), sym_name_and_arity(SymName/Arity),
+ words("used in finalise declaration"),
+ words("has invalid signature."), nl],
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds,
+ [Msg]),
+ !:Specs = [Spec | !.Specs]
)
;
PredIds = [],
- write_error_pieces(Context, 0, [words("Error:"),
- sym_name_and_arity(SymName/Arity),
- words(" used in finalise declaration has " ++
- "no pred declarations.")], !IO),
- module_info_incr_errors(!ModuleInfo)
+ Pieces = [words("Error:"), sym_name_and_arity(SymName/Arity),
+ words("used in finalise declaration"),
+ words("has no pred declarations."), nl],
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
+ !:Specs = [Spec | !.Specs]
;
PredIds = [_, _ | _],
- write_error_pieces(Context, 0, [words("Error:"),
- sym_name_and_arity(SymName/Arity),
- words(" used in finalise declaration has " ++
- "multiple pred declarations.")], !IO),
- module_info_incr_errors(!ModuleInfo)
- )
- ;
- write_error_pieces(Context, 0, [words("Error:"),
- sym_name_and_arity(SymName/Arity),
- words(" used in finalise declaration does " ++
- "not have a corresponding pred declaration.")], !IO),
- module_info_incr_errors(!ModuleInfo)
+ Pieces = [words("Error:"), sym_name_and_arity(SymName/Arity),
+ words("used in finalise declaration"),
+ words("has multiple pred declarations."), nl],
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
+ !:Specs = [Spec | !.Specs]
+ )
+ ;
+ Pieces = [words("Error:"), sym_name_and_arity(SymName/Arity),
+ words("used in finalise declaration"),
+ words("does not have a corresponding pred declaration."), nl],
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
+ !:Specs = [Spec | !.Specs]
).
-add_item_clause(Item, !Status, Context, !ModuleInfo, !QualInfo, !IO) :-
+add_item_clause(Item, !Status, Context, !ModuleInfo, !QualInfo, !Specs) :-
Item = item_mutable(MercuryMutableName, Type, InitTerm, Inst,
MutAttrs, MutVarset),
- %
+
% The transformation here is documented in the comments at the
% beginning of prog_mutable.m.
- %
+
DefinedThisModule = status_defined_in_this_module(!.Status),
(
DefinedThisModule = yes,
module_info_get_name(!.ModuleInfo, ModuleName),
IsConstant = mutable_var_constant(MutAttrs),
- %
+
% Work out what name to give the global in the target language.
- %
- decide_mutable_target_var_name(MutAttrs, ModuleName,
- MercuryMutableName, Context, TargetMutableName, !IO),
- %
+ decide_mutable_target_var_name(!.ModuleInfo, MutAttrs, ModuleName,
+ MercuryMutableName, Context, TargetMutableName, !Specs),
+
% Add foreign_decl and foreign_code items that declare/define the
% global variable used to implement the mutable. If the mutable is
% not constant then add a mutex to synchronize access to it as well.
- %
add_mutable_defn_and_decl(TargetMutableName, Type, IsConstant,
- Context, !QualInfo, !ModuleInfo, !IO),
- %
+ Context, !QualInfo, !ModuleInfo, !Specs),
+
% Set up the default attributes for the foreign_procs used for the
% access predicates.
% XXX Handle target languages other than C here.
- %
Attrs0 = default_attributes(lang_c),
- globals.io_lookup_bool_option(mutable_always_boxed, AlwaysBoxed, !IO),
+ module_info_get_globals(!.ModuleInfo, Globals),
+ globals.lookup_bool_option(Globals, mutable_always_boxed, AlwaysBoxed),
(
AlwaysBoxed = yes,
BoxPolicy = always_boxed
@@ -1306,20 +1284,20 @@
MercuryMutableName),
add_constant_mutable_access_preds(TargetMutableName,
ModuleName, MercuryMutableName, Attrs, Inst, BoxPolicy,
- Context, !Status, !QualInfo, !ModuleInfo, !IO)
+ Context, !Status, !QualInfo, !ModuleInfo, !Specs)
;
IsConstant = no,
InitSetPredName = mutable_set_pred_sym_name(ModuleName,
MercuryMutableName),
add_mutable_primitive_preds(TargetMutableName, ModuleName,
MercuryMutableName, MutAttrs, Attrs, Inst, BoxPolicy, Context,
- !Status, !QualInfo, !ModuleInfo, !IO),
+ !Status, !QualInfo, !ModuleInfo, !Specs),
add_mutable_user_access_preds(ModuleName, MercuryMutableName,
- MutAttrs, Context, !Status, !QualInfo, !ModuleInfo, !IO)
+ MutAttrs, Context, !Status, !QualInfo, !ModuleInfo, !Specs)
),
add_mutable_initialisation(IsConstant, TargetMutableName, ModuleName,
MercuryMutableName, MutVarset, InitSetPredName, InitTerm, Attrs,
- !Status, Context, !ModuleInfo, !QualInfo, !IO)
+ !Status, Context, !ModuleInfo, !QualInfo, !Specs)
;
DefinedThisModule = no
).
@@ -1328,12 +1306,12 @@
% mutable should be. If there is a foreign_name attribute then use that
% otherwise construct one based on the Mercury name for the mutable
%
-:- pred decide_mutable_target_var_name(mutable_var_attributes::in,
- module_name::in, string::in, prog_context::in, string::out,
- io::di, io::uo) is det.
+:- pred decide_mutable_target_var_name(module_info::in,
+ mutable_var_attributes::in, module_name::in, string::in, prog_context::in,
+ string::out, list(error_spec)::in, list(error_spec)::out) is det.
-decide_mutable_target_var_name(MutAttrs, ModuleName, Name, Context,
- TargetMutableName, !IO) :-
+decide_mutable_target_var_name(ModuleInfo, MutAttrs, ModuleName, Name, Context,
+ TargetMutableName, !Specs) :-
mutable_var_maybe_foreign_names(MutAttrs) = MaybeForeignNames,
(
MaybeForeignNames = no,
@@ -1341,8 +1319,8 @@
;
MaybeForeignNames = yes(ForeignNames),
ReportErrors = no, % We've already reported them during pass 2.
- get_global_name_from_foreign_names(ReportErrors, Context,
- ModuleName, Name, ForeignNames, TargetMutableName, !IO)
+ get_global_name_from_foreign_names(ModuleInfo, ReportErrors, Context,
+ ModuleName, Name, ForeignNames, TargetMutableName, !Specs)
).
% Add the foreign_decl and foreign_code items that declare/define
@@ -1350,25 +1328,26 @@
%
:- pred add_mutable_defn_and_decl(string::in, mer_type::in, bool::in,
prog_context::in, qual_info::in, qual_info::out,
- module_info::in, module_info::out, io::di, io::uo) is det.
+ module_info::in, module_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
add_mutable_defn_and_decl(TargetMutableName, Type, IsConstant, Context,
- !QualInfo, !ModuleInfo, !IO) :-
- globals.io_get_target(CompilationTarget, !IO),
- %
+ !QualInfo, !ModuleInfo, !Specs) :-
+ module_info_get_globals(!.ModuleInfo, Globals),
+ globals.get_target(Globals, CompilationTarget),
+
% We add the foreign code declaration and definition here rather than
% in pass 2 because the target-language-specific type name depends on
% whether there are any foreign_type declarations for Type.
- %
(
CompilationTarget = target_c,
get_mutable_global_foreign_decl_defn(!.ModuleInfo, Type,
TargetMutableName, IsConstant, ForeignDecl, ForeignDefn),
ItemStatus0 = item_status(status_local, may_be_unqualified),
add_item_decl_pass_2(ForeignDecl, Context, ItemStatus0, _,
- !ModuleInfo, !IO),
+ !ModuleInfo, !Specs),
add_item_decl_pass_2(ForeignDefn, Context, ItemStatus0, _,
- !ModuleInfo, !IO)
+ !ModuleInfo, !Specs)
;
% The error message was printed in pass 2.
( CompilationTarget = target_il
@@ -1384,11 +1363,11 @@
string::in, pragma_foreign_proc_attributes::in, mer_inst::in,
box_policy::in, prog_context::in, import_status::in, import_status::out,
qual_info::in, qual_info::out, module_info::in, module_info::out,
- io::di, io::uo) is det.
+ list(error_spec)::in, list(error_spec)::out) is det.
add_constant_mutable_access_preds(TargetMutableName, ModuleName, Name,
Attrs, Inst, BoxPolicy, Context, !Status, !QualInfo, !ModuleInfo,
- !IO) :-
+ !Specs) :-
varset.new_named_var(varset.init, "X", X, ProgVarSet),
InstVarSet = varset.init,
set_purity(purity_pure, Attrs, ConstantGetAttrs0),
@@ -1405,11 +1384,11 @@
ConstantGetClause = item_pragma(compiler(mutable_decl),
ConstantGetForeignProc),
add_item_clause(ConstantGetClause, !Status, Context, !ModuleInfo,
- !QualInfo, !IO),
- %
+ !QualInfo, !Specs),
+
% NOTE: we don't need to trail the set action, since it is executed
% only once at initialization time.
- %
+
ConstantSetForeignProc = pragma_foreign_proc(Attrs,
mutable_secret_set_pred_sym_name(ModuleName, Name),
predicate,
@@ -1421,7 +1400,7 @@
ConstantSetClause = item_pragma(compiler(mutable_decl),
ConstantSetForeignProc),
add_item_clause(ConstantSetClause, !Status, Context, !ModuleInfo,
- !QualInfo, !IO).
+ !QualInfo, !Specs).
% Add the foreign clauses for the mutable's primitive access and
% locking predicates.
@@ -1430,15 +1409,16 @@
mutable_var_attributes::in, pragma_foreign_proc_attributes::in,
mer_inst::in, box_policy::in, prog_context::in,
import_status::in, import_status::out, qual_info::in, qual_info::out,
- module_info::in, module_info::out, io::di, io::uo) is det.
+ module_info::in, module_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
add_mutable_primitive_preds(TargetMutableName, ModuleName, Name,
MutAttrs, Attrs, Inst, BoxPolicy, Context, !Status, !QualInfo,
- !ModuleInfo, !IO) :-
+ !ModuleInfo, !Specs) :-
set_thread_safe(proc_thread_safe, Attrs, LockAndUnlockAttrs),
- %
+
% Construct the lock predicate.
- %
+
MutableMutexVarName = mutable_mutex_var_name(TargetMutableName),
% XXX the second argument should be the name of the mercury predicate,
% with chars escaped as appropriate.
@@ -1458,11 +1438,11 @@
),
LockClause = item_pragma(compiler(mutable_decl), LockForeignProc),
add_item_clause(LockClause, !Status, Context, !ModuleInfo, !QualInfo,
- !IO),
- %
+ !Specs),
+
% Construct the unlock predicate.
- %
% XXX as above regarding the second argument to MR_UNLOCK.
+
UnlockForeignProcBody = string.append_list([
"#ifdef MR_THREAD_SAFE\n",
" MR_UNLOCK(&" ++ MutableMutexVarName ++ ",
@@ -1479,10 +1459,10 @@
),
UnlockClause = item_pragma(compiler(mutable_decl), UnlockForeignProc),
add_item_clause(UnlockClause, !Status, Context, !ModuleInfo, !QualInfo,
- !IO),
- %
+ !Specs),
+
% Construct the semipure unsafe_get_predicate.
- %
+
set_purity(purity_semipure, Attrs, UnsafeGetAttrs0),
set_thread_safe(proc_thread_safe, UnsafeGetAttrs0, UnsafeGetAttrs),
varset.new_named_var(varset.init, "X", X, ProgVarSet),
@@ -1497,10 +1477,10 @@
UnsafeGetClause = item_pragma(compiler(mutable_decl),
UnsafeGetForeignProc),
add_item_clause(UnsafeGetClause, !Status, Context, !ModuleInfo, !QualInfo,
- !IO),
- %
+ !Specs),
+
% Construct the impure unsafe_set_predicate.
- %
+
set_thread_safe(proc_thread_safe, Attrs, UnsafeSetAttrs),
TrailMutableUpdates = mutable_var_trailed(MutAttrs),
(
@@ -1508,25 +1488,24 @@
TrailCode = ""
;
TrailMutableUpdates = mutable_trailed,
- %
- % If we require that the mutable to be trailed then
- % we need to be compiling in a trailing grade.
- %
- globals.io_lookup_bool_option(use_trail, UseTrail, !IO),
+
+ % If we require that the mutable to be trailed then we need to be
+ % compiling in a trailing grade.
+ module_info_get_globals(!.ModuleInfo, Globals),
+ globals.lookup_bool_option(Globals, use_trail, UseTrail),
(
UseTrail = yes,
TrailCode = "MR_trail_current_value(&" ++
TargetMutableName ++ ");\n"
;
UseTrail = no,
- NonTrailingError = [
- words("Error: trailed mutable in non-trailing grade.")
- ],
- write_error_pieces(Context, 0, NonTrailingError, !IO),
- io.set_exit_status(1, !IO),
- %
+ Pieces =
+ [words("Error: trailed mutable in non-trailing grade."), nl],
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
+ !:Specs = [Spec | !.Specs],
+
% This is just a dummy value.
- %
TrailCode = ""
)
),
@@ -1542,7 +1521,7 @@
UnsafeSetClause = item_pragma(compiler(mutable_decl),
UnsafeSetForeignProc),
add_item_clause(UnsafeSetClause, !Status, Context, !ModuleInfo, !QualInfo,
- !IO).
+ !Specs).
% Add the access predicates for a non-constant mutable.
% If the mutable has the `attach_to_io_state' attribute then add the
@@ -1551,10 +1530,11 @@
:- pred add_mutable_user_access_preds(module_name::in, string::in,
mutable_var_attributes::in, prog_context::in,
import_status::in, import_status::out, qual_info::in, qual_info::out,
- module_info::in, module_info::out, io::di, io::uo) is det.
+ module_info::in, module_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
add_mutable_user_access_preds(ModuleName, Name, MutAttrs, Context,
- !Status, !QualInfo, !ModuleInfo, !IO) :-
+ !Status, !QualInfo, !ModuleInfo, !Specs) :-
varset.new_named_var(varset.init, "X", X, ProgVarSet0),
LockPredName = mutable_lock_pred_sym_name(ModuleName, Name),
UnlockPredName = mutable_unlock_pred_sym_name(ModuleName, Name),
@@ -1585,7 +1565,7 @@
),
add_item_clause(StdGetClause, !Status, Context, !ModuleInfo, !QualInfo,
- !IO),
+ !Specs),
%
% Construct the impure set predicate.
%
@@ -1607,7 +1587,7 @@
),
add_item_clause(StdSetClause, !Status, Context, !ModuleInfo, !QualInfo,
- !IO),
+ !Specs),
IOStateInterface = mutable_var_attach_to_io_state(MutAttrs),
(
@@ -1629,7 +1609,7 @@
),
add_item_clause(IOGetClause, !Status, Context, !ModuleInfo, !QualInfo,
- !IO),
+ !Specs),
% Construct the pure set predicate.
%
@@ -1649,7 +1629,7 @@
),
add_item_clause(IOSetClause, !Status, Context, !ModuleInfo, !QualInfo,
- !IO)
+ !Specs)
;
IOStateInterface = no
).
@@ -1659,19 +1639,20 @@
:- pred add_mutable_initialisation(bool::in, string::in, module_name::in,
string::in, prog_varset::in, sym_name::in, prog_term::in,
pragma_foreign_proc_attributes::in, import_status::in, import_status::out,
- prog_context::in, module_info::in, module_info::out, qual_info::in,
- qual_info::out, io::di, io::uo) is det.
+ prog_context::in, module_info::in, module_info::out,
+ qual_info::in, qual_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
add_mutable_initialisation(IsConstant, TargetMutableName, ModuleName, Name,
MutVarset, InitSetPredName, InitTerm, Attrs, !Status, Context,
- !ModuleInfo, !QualInfo, !IO) :-
+ !ModuleInfo, !QualInfo, !Specs) :-
%
% Add the `:- initialise' declaration and clause for the
% mutable initialise predicate.
%
add_item_clause(item_initialise(compiler(mutable_decl),
mutable_init_pred_sym_name(ModuleName, Name), 0 /* Arity */),
- !Status, Context, !ModuleInfo, !QualInfo, !IO),
+ !Status, Context, !ModuleInfo, !QualInfo, !Specs),
(
IsConstant = yes,
%
@@ -1707,7 +1688,7 @@
InitMutexClause = item_pragma(compiler(mutable_decl),
InitMutexForeignProc),
add_item_clause(InitMutexClause, !Status, Context, !ModuleInfo,
- !QualInfo, !IO),
+ !QualInfo, !Specs),
CallInitMutexExpr =
call_expr(InitMutexPredName, [], purity_impure) - Context,
@@ -1729,7 +1710,7 @@
)
),
add_item_clause(InitClause, !Status, Context, !ModuleInfo, !QualInfo,
- !IO).
+ !Specs).
% Create the foreign_decl for the mutable.
% The bool argument says whether the mutable is a constant mutable
@@ -1801,16 +1782,16 @@
:- pred add_solver_type_mutable_items_clauses(list(item)::in,
import_status::in, import_status::out, prog_context::in,
- module_info::in, module_info::out,
- qual_info::in, qual_info::out, io::di, io::uo) is det.
+ module_info::in, module_info::out, qual_info::in, qual_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
add_solver_type_mutable_items_clauses([], !Status, _Context,
- !ModuleInfo, !QualInfo, !IO).
+ !ModuleInfo, !QualInfo, !Specs).
add_solver_type_mutable_items_clauses([Item | Items], !Status, Context,
- !ModuleInfo, !QualInfo, !IO) :-
- add_item_clause(Item, !Status, Context, !ModuleInfo, !QualInfo, !IO),
+ !ModuleInfo, !QualInfo, !Specs) :-
+ add_item_clause(Item, !Status, Context, !ModuleInfo, !QualInfo, !Specs),
add_solver_type_mutable_items_clauses(Items, !Status, Context,
- !ModuleInfo, !QualInfo, !IO).
+ !ModuleInfo, !QualInfo, !Specs).
% If a module_defn updates the import_status, return the new status
% and whether uses of the following items must be module qualified,
@@ -1839,10 +1820,10 @@
:- pred add_promise_clause(promise_type::in, list(term(prog_var_type))::in,
prog_varset::in, goal::in, prog_context::in, import_status::in,
module_info::in, module_info::out, qual_info::in, qual_info::out,
- io::di, io::uo) is det.
+ list(error_spec)::in, list(error_spec)::out) is det.
add_promise_clause(PromiseType, HeadVars, VarSet, Goal, Context, Status,
- !ModuleInfo, !QualInfo, !IO) :-
+ !ModuleInfo, !QualInfo, !Specs) :-
term.context_line(Context, Line),
term.context_file(Context, File),
string.format(prog_out.promise_to_string(PromiseType) ++
@@ -1863,9 +1844,9 @@
module_info_get_name(!.ModuleInfo, ModuleName),
module_add_clause(VarSet, predicate, qualified(ModuleName, Name), HeadVars,
Goal, Status, Context, goal_type_promise(PromiseType),
- !ModuleInfo, !QualInfo, !IO).
+ !ModuleInfo, !QualInfo, !Specs).
-add_stratified_pred(PragmaName, Name, Arity, Context, !ModuleInfo, !IO) :-
+add_stratified_pred(PragmaName, Name, Arity, Context, !ModuleInfo, !Specs) :-
module_info_get_predicate_table(!.ModuleInfo, PredTable0),
(
predicate_table_search_sym_arity(PredTable0, is_fully_qualified,
@@ -1877,33 +1858,32 @@
;
string.append_list(["`:- pragma ", PragmaName, "' declaration"],
Description),
- undefined_pred_or_func_error(Name, Arity, Context, Description, !IO),
- module_info_incr_errors(!ModuleInfo)
+ undefined_pred_or_func_error(Name, Arity, Context, Description,
+ !Specs)
).
%-----------------------------------------------------------------------------%
add_pred_marker(PragmaName, Name, Arity, Status, Context, Marker,
- ConflictMarkers, !ModuleInfo, !IO) :-
+ ConflictMarkers, !ModuleInfo, !Specs) :-
( marker_must_be_exported(Marker) ->
MustBeExported = yes
;
MustBeExported = no
),
do_add_pred_marker(PragmaName, Name, Arity, Status, MustBeExported,
- Context, add_marker_pred_info(Marker), !ModuleInfo, PredIds, !IO),
+ Context, add_marker_pred_info(Marker), !ModuleInfo, PredIds, !Specs),
module_info_preds(!.ModuleInfo, Preds),
pragma_check_markers(Preds, PredIds, ConflictMarkers, Conflict),
(
Conflict = yes,
- pragma_conflict_error(Name, Arity, Context, PragmaName, !IO),
- module_info_incr_errors(!ModuleInfo)
+ pragma_conflict_error(Name, Arity, Context, PragmaName, !Specs)
;
Conflict = no
).
do_add_pred_marker(PragmaName, Name, Arity, Status, MustBeExported, Context,
- UpdatePredInfo, !ModuleInfo, PredIds, !IO) :-
+ UpdatePredInfo, !ModuleInfo, PredIds, !Specs) :-
( get_matching_pred_ids(!.ModuleInfo, Name, Arity, PredIds0) ->
PredIds = PredIds0,
module_info_get_predicate_table(!.ModuleInfo, PredTable0),
@@ -1913,8 +1893,7 @@
MustBeExported, Preds0, Preds, WrongStatus),
(
WrongStatus = yes,
- pragma_status_error(Name, Arity, Context, PragmaName, !IO),
- module_info_incr_errors(!ModuleInfo)
+ pragma_status_error(Name, Arity, Context, PragmaName, !Specs)
;
WrongStatus = no
),
@@ -1925,8 +1904,7 @@
PredIds = [],
string.append_list(["`:- pragma ", PragmaName, "' declaration"],
Description),
- undefined_pred_or_func_error(Name, Arity, Context, Description, !IO),
- module_info_incr_errors(!ModuleInfo)
+ undefined_pred_or_func_error(Name, Arity, Context, Description, !Specs)
).
:- pred get_matching_pred_ids(module_info::in, sym_name::in, arity::in,
@@ -1944,9 +1922,9 @@
Name, Arity, PredIds)
).
-module_mark_as_external(PredName, Arity, Context, !ModuleInfo, !IO) :-
- % `external' declarations can only apply to things defined
- % in this module, since everything else is already external.
+module_mark_as_external(PredName, Arity, Context, !ModuleInfo, !Specs) :-
+ % `external' declarations can only apply to things defined in this module,
+ % since everything else is already external.
module_info_get_predicate_table(!.ModuleInfo, PredicateTable0),
(
predicate_table_search_sym_arity(PredicateTable0, is_fully_qualified,
@@ -1955,8 +1933,7 @@
module_mark_preds_as_external(PredIdList, !ModuleInfo)
;
undefined_pred_or_func_error(PredName, Arity, Context,
- "`:- external' declaration", !IO),
- module_info_incr_errors(!ModuleInfo)
+ "`:- external' declaration", !Specs)
).
:- pred module_mark_preds_as_external(list(pred_id)::in,
@@ -2033,30 +2010,27 @@
semidet_fail.
maybe_check_field_access_function(FuncName, FuncArity, Status, Context,
- Module, !IO) :-
+ Module, !Specs) :-
(
is_field_access_function_name(Module, FuncName, FuncArity,
AccessType, FieldName)
->
check_field_access_function(AccessType, FieldName, FuncName,
- FuncArity, Status, Context, Module, !IO)
+ FuncArity, Status, Context, Module, !Specs)
;
true
).
:- pred check_field_access_function(field_access_type::in, ctor_field_name::in,
sym_name::in, arity::in, import_status::in, prog_context::in,
- module_info::in, io::di, io::uo) is det.
+ module_info::in, list(error_spec)::in, list(error_spec)::out) is det.
check_field_access_function(_AccessType, FieldName, FuncName, FuncArity,
- FuncStatus, Context, Module, !IO) :-
+ FuncStatus, Context, Module, !Specs) :-
adjust_func_arity(function, FuncArity, PredArity),
FuncCallId = simple_call_id(function, FuncName, PredArity),
- %
- % Check that a function applied to an exported type
- % is also exported.
- %
+ % Check that a function applied to an exported type is also exported.
module_info_get_ctor_field_table(Module, CtorFieldTable),
(
% Abstract types have status `abstract_exported', so errors won't be
@@ -2066,7 +2040,7 @@
DefnStatus = status_exported,
FuncStatus \= status_exported
->
- report_field_status_mismatch(Context, FuncCallId, !IO)
+ report_field_status_mismatch(Context, FuncCallId, !Specs)
;
true
).
@@ -2074,46 +2048,50 @@
%-----------------------------------------------------------------------------%
:- pred report_field_status_mismatch(prog_context::in, simple_call_id::in,
- io::di, io::uo) is det.
+ list(error_spec)::in, list(error_spec)::out) is det.
-report_field_status_mismatch(Context, CallId, !IO) :-
- ErrorPieces = [
- words("In declaration of"), simple_call(CallId), suffix(":"), nl,
- words("error: a field access function for an"),
- words("exported field must also be exported.")
- ],
- write_error_pieces(Context, 0, ErrorPieces, !IO),
- io.set_exit_status(1, !IO).
+report_field_status_mismatch(Context, CallId, !Specs) :-
+ Pieces = [words("In declaration of"), simple_call(CallId), suffix(":"), nl,
+ words("error: a field access function for an exported field"),
+ words("must also be exported."), nl],
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
+ !:Specs = [Spec | !.Specs].
:- pred report_unexpected_decl(string::in, prog_context::in,
- io::di, io::uo) is det.
+ list(error_spec)::in, list(error_spec)::out) is det.
-report_unexpected_decl(Descr, Context, !IO) :-
+report_unexpected_decl(Descr, Context, !Specs) :-
Pieces = [words("Error: unexpected or incorrect"),
- words("`" ++ Descr ++ "' declaration.")],
- write_error_pieces(Context, 0, Pieces, !IO),
- io.set_exit_status(1, !IO).
+ quote(Descr), words("declaration."), nl],
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
+ !:Specs = [Spec | !.Specs].
:- pred pragma_status_error(sym_name::in, int::in, prog_context::in,
- string::in, io::di, io::uo) is det.
+ string::in, list(error_spec)::in, list(error_spec)::out) is det.
-pragma_status_error(Name, Arity, Context, PragmaName, !IO) :-
+pragma_status_error(Name, Arity, Context, PragmaName, !Specs) :-
Pieces = [words("Error: `:- pragma " ++ PragmaName ++ "'"),
words("declaration for exported predicate or function"),
sym_name_and_arity(Name / Arity),
- words("must also be exported.")],
- write_error_pieces(Context, 0, Pieces, !IO),
- io.set_exit_status(1, !IO).
+ words("must also be exported."), nl],
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
+ !:Specs = [Spec | !.Specs].
:- pred pragma_conflict_error(sym_name::in, int::in, prog_context::in,
- string::in, io::di, io::uo) is det.
+ string::in, list(error_spec)::in, list(error_spec)::out) is det.
-pragma_conflict_error(Name, Arity, Context, PragmaName, !IO) :-
+pragma_conflict_error(Name, Arity, Context, PragmaName, !Specs) :-
Pieces = [words("Error: `:- pragma " ++ PragmaName ++ "'"),
words("declaration conflicts with previous pragma for"),
- sym_name_and_arity(Name / Arity), suffix(".")],
- write_error_pieces(Context, 0, Pieces, !IO),
- io.set_exit_status(1, !IO).
+ sym_name_and_arity(Name / Arity), 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.
Index: compiler/make_hlds_warn.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/make_hlds_warn.m,v
retrieving revision 1.17
diff -u -b -r1.17 make_hlds_warn.m
--- compiler/make_hlds_warn.m 7 Sep 2006 05:50:56 -0000 1.17
+++ compiler/make_hlds_warn.m 8 Sep 2006 06:13:19 -0000
@@ -19,38 +19,51 @@
:- import_module hlds.hlds_module.
:- import_module hlds.quantification.
:- import_module libs.globals.
+:- import_module parse_tree.error_util.
:- import_module parse_tree.prog_data.
-:- import_module io.
:- import_module list.
:- import_module pair.
%-----------------------------------------------------------------------------%
- % Warn about variables which occur only once but don't start with
- % an underscore, or about variables which do start with an underscore
- % but occur more than once.
+ % Warn about variables with overlapping scopes.
%
-:- pred maybe_warn_overlap(list(quant_warning)::in, prog_varset::in,
- simple_call_id::in, io::di, io::uo) is det.
+:- pred warn_overlap(list(quant_warning)::in, prog_varset::in,
+ simple_call_id::in, list(error_spec)::in, list(error_spec)::out) is det.
% Warn about variables which occur only once but don't start with
% an underscore, or about variables which do start with an underscore
% but occur more than once, or about variables that do not occur in
% C code strings when they should.
%
-:- pred maybe_warn_singletons(prog_varset::in, simple_call_id::in,
- module_info::in, hlds_goal::in, io::di, io::uo) is det.
+:- pred warn_singletons(prog_varset::in, simple_call_id::in, module_info::in,
+ hlds_goal::in, list(error_spec)::in, list(error_spec)::out) is det.
-:- pred maybe_warn_pragma_singletons(pragma_foreign_code_impl::in,
+ % warn_singletons_in_pragma_foreign_proc checks to see if each variable
+ % is mentioned at least once in the foreign code fragments that ought to
+ % mention it. If not, it gives a warning.
+ %
+ % (Note that for some foreign languages it might not be appropriate
+ % to do this check, or you may need to add a transformation to map
+ % Mercury variable names into identifiers for that foreign language).
+ %
+:- pred warn_singletons_in_pragma_foreign_proc(pragma_foreign_code_impl::in,
foreign_language::in, list(maybe(pair(string, mer_mode)))::in,
prog_context::in, simple_call_id::in, module_info::in,
- io::di, io::uo) is det.
+ list(error_spec)::in, list(error_spec)::out) is det.
- % Perform above checks on a promise ex declaration.
+ % This predicate performs the following checks on promise ex declarations
+ % (see notes/promise_ex.html).
+ %
+ % - check for universally quantified variables
+ % - check if universal quantification is placed in the wrong position
+ % (i.e. after the `promise_exclusive' rather than before it)
+ % - check that its goal is a disjunction and that each arm of the
+ % disjunction has at most one call, and otherwise has only unifications.
%
:- pred check_promise_ex_decl(prog_vars::in, promise_type::in, goal::in,
- prog_context::in, io::di, io::uo) is det.
+ prog_context::in, list(error_spec)::in, list(error_spec)::out) is det.
%----------------------------------------------------------------------------%
%----------------------------------------------------------------------------%
@@ -62,7 +75,6 @@
:- import_module hlds.hlds_out.
:- import_module libs.compiler_util.
:- import_module libs.options.
-:- import_module parse_tree.error_util.
:- import_module parse_tree.mercury_to_mercury.
:- import_module parse_tree.prog_out.
@@ -75,84 +87,62 @@
%----------------------------------------------------------------------------%
-maybe_warn_overlap(Warnings, VarSet, PredCallId, !IO) :-
- globals.io_lookup_bool_option(warn_overlapping_scopes,
- WarnOverlappingScopes, !IO),
- (
- WarnOverlappingScopes = yes,
- warn_overlap(Warnings, VarSet, PredCallId, !IO)
- ;
- WarnOverlappingScopes = no
- ).
+warn_overlap(Warnings, VarSet, PredCallId, !Specs) :-
+ !:Specs =
+ list.map(warn_overlap_to_spec(VarSet, PredCallId), Warnings)
+ ++ !.Specs.
-:- pred warn_overlap(list(quant_warning)::in, prog_varset::in,
- simple_call_id::in, io::di, io::uo) is det.
+:- func warn_overlap_to_spec(prog_varset, simple_call_id, quant_warning)
+ = error_spec.
-warn_overlap([], _, _, !IO).
-warn_overlap([Warn | Warns], VarSet, PredCallId, !IO) :-
+warn_overlap_to_spec(VarSet, PredCallId, Warn) = Spec :-
Warn = warn_overlap(Vars, Context),
- Part1 = [words("In clause for"),
- words(simple_call_id_to_string(PredCallId)), suffix(":"), nl],
+ Pieces1 =
+ [words("In clause for"), simple_call(PredCallId), suffix(":"), nl],
( Vars = [Var] ->
- Part2 = [words("warning: variable"),
- words("`" ++ mercury_var_to_string(Var, VarSet, no) ++ "'"),
+ Pieces2 = [words("warning: variable"),
+ quote(mercury_var_to_string(Var, VarSet, no)),
words("has overlapping scopes.")]
;
- Part2 = [words("warning: variables"),
- words("`" ++ mercury_vars_to_string(Vars, VarSet, no) ++ "'"),
+ Pieces2 = [words("warning: variables"),
+ quote(mercury_vars_to_string(Vars, VarSet, no)),
words("each have overlapping scopes.")]
),
- write_error_pieces(Context, 0, Part1 ++ Part2, !IO),
- record_warning(!IO),
- warn_overlap(Warns, VarSet, PredCallId, !IO).
+ Msg = simple_msg(Context,
+ [option_is_set(warn_overlapping_scopes, yes,
+ [always(Pieces1 ++ Pieces2)])]),
+ Spec = error_spec(severity_warning, phase_parse_tree_to_hlds, [Msg]).
%-----------------------------------------------------------------------------%
-maybe_warn_singletons(VarSet, PredCallId, ModuleInfo, Body, !IO) :-
- globals.io_lookup_bool_option(warn_singleton_vars, WarnSingletonVars,
- !IO),
- (
- WarnSingletonVars = yes,
+warn_singletons(VarSet, PredCallId, ModuleInfo, Body, !Specs) :-
set.init(QuantVars),
warn_singletons_in_goal(Body, QuantVars, VarSet, PredCallId,
- ModuleInfo, !IO)
- ;
- WarnSingletonVars = no
- ).
+ ModuleInfo, !Specs).
:- pred warn_singletons_in_goal(hlds_goal::in, set(prog_var)::in,
prog_varset::in, simple_call_id::in, module_info::in,
- io::di, io::uo) is det.
+ list(error_spec)::in, list(error_spec)::out) is det.
-warn_singletons_in_goal(Goal - GoalInfo, QuantVars, VarSet, PredCallId, MI,
- !IO) :-
- warn_singletons_in_goal_2(Goal, GoalInfo, QuantVars, VarSet,
- PredCallId, MI, !IO).
-
-:- pred warn_singletons_in_goal_2(hlds_goal_expr::in, hlds_goal_info::in,
- set(prog_var)::in, prog_varset::in, simple_call_id::in,
- module_info::in, io::di, io::uo) is det.
-
-warn_singletons_in_goal_2(Goal, _GoalInfo, QuantVars, VarSet, PredCallId,
- MI, !IO) :-
+warn_singletons_in_goal(Goal - GoalInfo, QuantVars, VarSet, PredCallId,
+ ModuleInfo, !Specs) :-
+ (
Goal = conj(_ConjType, Goals),
- warn_singletons_in_goal_list(Goals, QuantVars, VarSet, PredCallId, MI,
- !IO).
-warn_singletons_in_goal_2(Goal, _GoalInfo, QuantVars, VarSet, PredCallId,
- MI, !IO) :-
+ warn_singletons_in_goal_list(Goals, QuantVars, VarSet, PredCallId,
+ ModuleInfo, !Specs)
+ ;
Goal = disj(Goals),
- warn_singletons_in_goal_list(Goals, QuantVars, VarSet, PredCallId, MI,
- !IO).
-warn_singletons_in_goal_2(Goal, _GoalInfo, QuantVars, VarSet, PredCallId,
- MI, !IO) :-
+ warn_singletons_in_goal_list(Goals, QuantVars, VarSet, PredCallId,
+ ModuleInfo, !Specs)
+ ;
Goal = switch(_Var, _CanFail, Cases),
- warn_singletons_in_cases(Cases, QuantVars, VarSet, PredCallId, MI, !IO).
-warn_singletons_in_goal_2(Goal, _GoalInfo, QuantVars, VarSet, PredCallId,
- MI, !IO) :-
+ warn_singletons_in_cases(Cases, QuantVars, VarSet, PredCallId,
+ ModuleInfo, !Specs)
+ ;
Goal = negation(SubGoal),
- warn_singletons_in_goal(SubGoal, QuantVars, VarSet, PredCallId, MI, !IO).
-warn_singletons_in_goal_2(Goal, GoalInfo, QuantVars, VarSet, PredCallId,
- MI, !IO) :-
+ warn_singletons_in_goal(SubGoal, QuantVars, VarSet, PredCallId,
+ ModuleInfo, !Specs)
+ ;
Goal = scope(Reason, SubGoal),
% Warn if any quantified variables occur only in the quantifier.
(
@@ -164,21 +154,19 @@
SubGoalVars = free_goal_vars(SubGoal),
goal_info_get_context(GoalInfo, Context),
set.init(EmptySet),
- warn_singletons(Vars, GoalInfo, EmptySet, SubGoalVars, VarSet,
- Context, PredCallId, !IO),
+ warn_singletons_goal_vars(Vars, GoalInfo, EmptySet, SubGoalVars,
+ VarSet, Context, PredCallId, !Specs),
set.insert_list(QuantVars, Vars, SubQuantVars)
;
SubQuantVars = QuantVars
),
- warn_singletons_in_goal(SubGoal, SubQuantVars, VarSet, PredCallId, MI,
- !IO).
-warn_singletons_in_goal_2(Goal, GoalInfo, QuantVars, VarSet, PredCallId,
- MI, !IO) :-
+ warn_singletons_in_goal(SubGoal, SubQuantVars, VarSet, PredCallId,
+ ModuleInfo, !Specs)
+ ;
Goal = if_then_else(Vars, Cond, Then, Else),
- %
- % warn if any quantified variables do not occur in the condition
- % or the "then" part of the if-then-else
- %
+
+ % Warn if any quantified variables do not occur in the condition
+ % or the "then" part of the if-then-else.
(
Vars = [_ | _],
CondVars = free_goal_vars(Cond),
@@ -186,145 +174,207 @@
set.union(CondVars, ThenVars, CondThenVars),
goal_info_get_context(GoalInfo, Context),
set.init(EmptySet),
- warn_singletons(Vars, GoalInfo, EmptySet, CondThenVars, VarSet,
- Context, PredCallId, !IO)
+ warn_singletons_goal_vars(Vars, GoalInfo, EmptySet, CondThenVars,
+ VarSet, Context, PredCallId, !Specs)
;
Vars = []
),
- set.insert_list(QuantVars, Vars, QuantVars1),
- warn_singletons_in_goal(Cond, QuantVars1, VarSet, PredCallId, MI, !IO),
- warn_singletons_in_goal(Then, QuantVars1, VarSet, PredCallId, MI, !IO),
- warn_singletons_in_goal(Else, QuantVars, VarSet, PredCallId, MI, !IO).
-warn_singletons_in_goal_2(Goal, GoalInfo, QuantVars, VarSet, PredCallId,
- _, !IO) :-
+ set.insert_list(QuantVars, Vars, CondThenQuantVars),
+ warn_singletons_in_goal(Cond, CondThenQuantVars, VarSet, PredCallId,
+ ModuleInfo, !Specs),
+ warn_singletons_in_goal(Then, CondThenQuantVars, VarSet, PredCallId,
+ ModuleInfo, !Specs),
+ warn_singletons_in_goal(Else, QuantVars, VarSet, PredCallId,
+ ModuleInfo, !Specs)
+ ;
Goal = plain_call(_, _, Args, _, _, _),
goal_info_get_nonlocals(GoalInfo, NonLocals),
goal_info_get_context(GoalInfo, Context),
- warn_singletons(Args, GoalInfo, NonLocals, QuantVars, VarSet, Context,
- PredCallId, !IO).
-warn_singletons_in_goal_2(Goal, GoalInfo, QuantVars, VarSet, PredCallId,
- _, !IO) :-
+ warn_singletons_goal_vars(Args, GoalInfo, NonLocals, QuantVars, VarSet,
+ Context, PredCallId, !Specs)
+ ;
Goal = generic_call(GenericCall, Args0, _, _),
goal_util.generic_call_vars(GenericCall, Args1),
list.append(Args0, Args1, Args),
goal_info_get_nonlocals(GoalInfo, NonLocals),
goal_info_get_context(GoalInfo, Context),
- warn_singletons(Args, GoalInfo, NonLocals, QuantVars, VarSet, Context,
- PredCallId, !IO).
-warn_singletons_in_goal_2(Goal, GoalInfo, QuantVars, VarSet, PredCallId,
- MI, !IO) :-
+ warn_singletons_goal_vars(Args, GoalInfo, NonLocals, QuantVars, VarSet,
+ Context, PredCallId, !Specs)
+ ;
Goal = unify(Var, RHS, _, _, _),
warn_singletons_in_unify(Var, RHS, GoalInfo, QuantVars, VarSet,
- PredCallId, MI, !IO).
-warn_singletons_in_goal_2(Goal, GoalInfo, _QuantVars, _VarSet, PredCallId,
- MI, !IO) :-
+ PredCallId, ModuleInfo, !Specs)
+ ;
Goal = call_foreign_proc(Attrs, _, _, Args, _, _, PragmaImpl),
goal_info_get_context(GoalInfo, Context),
Lang = get_foreign_language(Attrs),
NamesModes = list.map(foreign_arg_maybe_name_mode, Args),
warn_singletons_in_pragma_foreign_proc(PragmaImpl, Lang,
- NamesModes, Context, PredCallId, MI, !IO).
-warn_singletons_in_goal_2(Goal, GoalInfo, QuantVars, VarSet, PredCallId,
- MI, !IO) :-
+ NamesModes, Context, PredCallId, ModuleInfo, !Specs)
+ ;
Goal = shorthand(ShorthandGoal),
warn_singletons_in_goal_2_shorthand(ShorthandGoal, GoalInfo,
- QuantVars, VarSet, PredCallId, MI, !IO).
+ QuantVars, VarSet, PredCallId, ModuleInfo, !Specs)
+ ).
:- pred warn_singletons_in_goal_2_shorthand(shorthand_goal_expr::in,
hlds_goal_info::in, set(prog_var)::in, prog_varset::in,
- simple_call_id::in, module_info::in, io::di, io::uo) is det.
+ simple_call_id::in, module_info::in,
+ list(error_spec)::in, list(error_spec)::out) is det.
warn_singletons_in_goal_2_shorthand(bi_implication(LHS, RHS), _GoalInfo,
- QuantVars, VarSet, PredCallId, MI, !IO) :-
- warn_singletons_in_goal_list([LHS, RHS], QuantVars, VarSet,
- PredCallId, MI, !IO).
+ QuantVars, VarSet, PredCallId, ModuleInfo, !Specs) :-
+ warn_singletons_in_goal_list([LHS, RHS], QuantVars, VarSet, PredCallId,
+ ModuleInfo, !Specs).
:- pred warn_singletons_in_goal_list(list(hlds_goal)::in, set(prog_var)::in,
prog_varset::in, simple_call_id::in, module_info::in,
- io::di, io::uo) is det.
+ list(error_spec)::in, list(error_spec)::out) is det.
-warn_singletons_in_goal_list([], _, _, _, _, !IO).
+warn_singletons_in_goal_list([], _, _, _, _, !Specs).
warn_singletons_in_goal_list([Goal | Goals], QuantVars, VarSet, CallPredId,
- MI, !IO) :-
- warn_singletons_in_goal(Goal, QuantVars, VarSet, CallPredId, MI, !IO),
- warn_singletons_in_goal_list(Goals, QuantVars, VarSet, CallPredId, MI,
- !IO).
+ ModuleInfo, !Specs) :-
+ warn_singletons_in_goal(Goal, QuantVars, VarSet, CallPredId,
+ ModuleInfo, !Specs),
+ warn_singletons_in_goal_list(Goals, QuantVars, VarSet, CallPredId,
+ ModuleInfo, !Specs).
:- pred warn_singletons_in_cases(list(case)::in, set(prog_var)::in,
prog_varset::in, simple_call_id::in, module_info::in,
- io::di, io::uo) is det.
+ list(error_spec)::in, list(error_spec)::out) is det.
warn_singletons_in_cases([], _, _, _, _, !IO).
-warn_singletons_in_cases([Case | Cases], QuantVars, VarSet, CallPredId, MI,
- !IO) :-
+warn_singletons_in_cases([Case | Cases], QuantVars, VarSet, CallPredId,
+ ModuleInfo, !Specs) :-
Case = case(_ConsId, Goal),
- warn_singletons_in_goal(Goal, QuantVars, VarSet, CallPredId, MI, !IO),
- warn_singletons_in_cases(Cases, QuantVars, VarSet, CallPredId, MI, !IO).
+ warn_singletons_in_goal(Goal, QuantVars, VarSet, CallPredId,
+ ModuleInfo, !Specs),
+ warn_singletons_in_cases(Cases, QuantVars, VarSet, CallPredId,
+ ModuleInfo, !Specs).
:- pred warn_singletons_in_unify(prog_var::in, unify_rhs::in,
hlds_goal_info::in, set(prog_var)::in, prog_varset::in,
- simple_call_id::in, module_info::in, io::di, io::uo) is det.
+ simple_call_id::in, module_info::in,
+ list(error_spec)::in, list(error_spec)::out) is det.
warn_singletons_in_unify(X, rhs_var(Y), GoalInfo, QuantVars, VarSet,
- CallPredId, _, !IO) :-
+ CallPredId, _, !Specs) :-
goal_info_get_nonlocals(GoalInfo, NonLocals),
goal_info_get_context(GoalInfo, Context),
- warn_singletons([X, Y], GoalInfo, NonLocals, QuantVars, VarSet,
- Context, CallPredId, !IO).
+ warn_singletons_goal_vars([X, Y], GoalInfo, NonLocals, QuantVars,
+ VarSet, Context, CallPredId, !Specs).
warn_singletons_in_unify(X, rhs_functor(_ConsId, _, Vars), GoalInfo,
- QuantVars, VarSet, CallPredId, _, !IO) :-
+ QuantVars, VarSet, CallPredId, _, !Specs) :-
goal_info_get_nonlocals(GoalInfo, NonLocals),
goal_info_get_context(GoalInfo, Context),
- warn_singletons([X | Vars], GoalInfo, NonLocals, QuantVars, VarSet,
- Context, CallPredId, !IO).
+ warn_singletons_goal_vars([X | Vars], GoalInfo, NonLocals, QuantVars,
+ VarSet, Context, CallPredId, !Specs).
warn_singletons_in_unify(X, rhs_lambda_goal(_Purity, _PredOrFunc, _Eval,
_NonLocals, LambdaVars, _Modes, _Det, LambdaGoal),
- GoalInfo, QuantVars, VarSet, CallPredId, MI, !IO) :-
+ GoalInfo, QuantVars, VarSet, CallPredId, ModuleInfo, !Specs) :-
% Warn if any lambda-quantified variables occur only in the quantifier.
LambdaGoal = _ - LambdaGoalInfo,
goal_info_get_nonlocals(LambdaGoalInfo, LambdaNonLocals),
goal_info_get_context(GoalInfo, Context),
- warn_singletons(LambdaVars, GoalInfo, LambdaNonLocals, QuantVars,
- VarSet, Context, CallPredId, !IO),
+ warn_singletons_goal_vars(LambdaVars, GoalInfo, LambdaNonLocals, QuantVars,
+ VarSet, Context, CallPredId, !Specs),
% Warn if X (the variable we're unifying the lambda expression with)
% is singleton.
goal_info_get_nonlocals(GoalInfo, NonLocals),
- warn_singletons([X], GoalInfo, NonLocals, QuantVars, VarSet, Context,
- CallPredId, !IO),
+ warn_singletons_goal_vars([X], GoalInfo, NonLocals, QuantVars,
+ VarSet, Context, CallPredId, !Specs),
% Warn if the lambda-goal contains singletons.
- warn_singletons_in_goal(LambdaGoal, QuantVars, VarSet, CallPredId, MI,
- !IO).
+ warn_singletons_in_goal(LambdaGoal, QuantVars, VarSet, CallPredId,
+ ModuleInfo, !Specs).
%-----------------------------------------------------------------------------%
-maybe_warn_pragma_singletons(PragmaImpl, Lang, ArgInfo, Context, CallId, MI,
- !IO) :-
- globals.io_lookup_bool_option(warn_singleton_vars, WarnSingletonVars, !IO),
+ % warn_singletons_goal_vars(Vars, GoalInfo, NonLocals, QuantVars, ...):
+ %
+ % Warn if any of the non-underscore variables in Vars don't occur in
+ % NonLocals and don't have the same name as any variable in QuantVars,
+ % or if any of the underscore variables in Vars do occur in NonLocals.
+ % Omit the warning if GoalInfo says we should.
+ %
+:- pred warn_singletons_goal_vars(list(prog_var)::in, hlds_goal_info::in,
+ set(prog_var)::in, set(prog_var)::in, prog_varset::in,
+ prog_context::in, simple_call_id::in,
+ list(error_spec)::in, list(error_spec)::out) is det.
+
+warn_singletons_goal_vars(GoalVars, GoalInfo, NonLocals, QuantVars, VarSet,
+ Context, PredOrFuncCallId, !Specs) :-
+ % Find all the variables in the goal that don't occur outside the goal
+ % (i.e. are singleton), have a variable name that doesn't start with "_"
+ % or "DCG_", and don't have the same name as any variable in QuantVars
+ % (i.e. weren't explicitly quantified).
+
+ solutions.solutions(
+ generate_singleton_vars(GoalVars, NonLocals, QuantVars, VarSet),
+ SingletonVars),
+
+ % If there were any such variables, issue a warning.
(
- WarnSingletonVars = yes,
- warn_singletons_in_pragma_foreign_proc(PragmaImpl, Lang,
- ArgInfo, Context, CallId, MI, !IO)
+ (
+ SingletonVars = []
+ ;
+ goal_info_has_feature(GoalInfo, feature_dont_warn_singleton)
+ )
+ ->
+ true
+ ;
+ SinglesPreamble = [words("In clause for"),
+ simple_call(PredOrFuncCallId), suffix(":"), nl],
+ SingleVarsPiece =
+ quote(mercury_vars_to_string(SingletonVars, VarSet, no)),
+ ( SingletonVars = [_] ->
+ SinglesPieces = [words("warning: variable"), SingleVarsPiece,
+ words("occurs only once in this scope."), nl]
+ ;
+ SinglesPieces = [words("warning: variables"), SingleVarsPiece,
+ words("occur only once in this scope."), nl]
+ ),
+ SinglesMsg = simple_msg(Context,
+ [option_is_set(warn_singleton_vars, yes,
+ [always(SinglesPreamble ++ SinglesPieces)])]),
+ SinglesSpec = error_spec(severity_warning, phase_parse_tree_to_hlds,
+ [SinglesMsg]),
+ !:Specs = [SinglesSpec | !.Specs]
+ ),
+
+ % Find all the variables in the goal that do occur outside the goal
+ % (i.e. are not singleton) and have a variable name that starts
+ % with "_". If there were any such variables, issue a warning.
+
+ solutions.solutions(generate_multi_vars(GoalVars, NonLocals, VarSet),
+ MultiVars),
+ (
+ MultiVars = []
+ ;
+ MultiVars = [_ | _],
+ MultiPreamble = [words("In clause for"),
+ simple_call(PredOrFuncCallId), suffix(":"), nl],
+ MultiVarsPiece = quote(mercury_vars_to_string(MultiVars, VarSet, no)),
+ ( MultiVars = [_] ->
+ MultiPieces = [words("warning: variable"), MultiVarsPiece,
+ words("occurs more than once in this scope."), nl]
;
- WarnSingletonVars = no
+ MultiPieces = [words("warning: variables"), MultiVarsPiece,
+ words("ccur more than once in this scope."), nl]
+ ),
+ MultiMsg = simple_msg(Context,
+ [option_is_set(warn_singleton_vars, yes,
+ [always(MultiPreamble ++ MultiPieces)])]),
+ MultiSpec = error_spec(severity_warning, phase_parse_tree_to_hlds,
+ [MultiMsg]),
+ !:Specs = [MultiSpec | !.Specs]
).
- % warn_singletons_in_pragma_foreign_proc checks to see if each variable
- % is mentioned at least once in the foreign code fragments that ought to
- % mention it. If not, it gives a warning.
- %
- % (Note that for some foreign languages it might not be appropriate
- % to do this check, or you may need to add a transformation to map
- % Mercury variable names into identifiers for that foreign language).
- %
-:- pred warn_singletons_in_pragma_foreign_proc(pragma_foreign_code_impl::in,
- foreign_language::in, list(maybe(pair(string, mer_mode)))::in,
- prog_context::in, simple_call_id::in, module_info::in,
- io::di, io::uo) is det.
+%-----------------------------------------------------------------------------%
warn_singletons_in_pragma_foreign_proc(PragmaImpl, Lang, Args, Context,
- PredOrFuncCallId, ModuleInfo, !IO) :-
+ PredOrFuncCallId, ModuleInfo, !Specs) :-
LangStr = foreign_language_string(Lang),
(
PragmaImpl = fc_impl_ordinary(C_Code, _),
@@ -339,11 +389,15 @@
UnmentionedVars = []
;
UnmentionedVars = [_ | _],
- Pieces = [words("In the " ++ LangStr ++ " code for"),
+ Pieces1 = [words("In the"), words(LangStr), words("code for"),
simple_call(PredOrFuncCallId), suffix(":"), nl,
words(variable_warning_start(UnmentionedVars)),
- words("not occur in the " ++ LangStr ++ " code.")],
- write_error_pieces(Context, 0, Pieces, !IO)
+ words("not occur in the"), words(LangStr), words("code."), nl],
+ Msg1 = simple_msg(Context,
+ [option_is_set(warn_singleton_vars, yes, [always(Pieces1)])]),
+ Spec1 = error_spec(severity_warning, phase_parse_tree_to_hlds,
+ [Msg1]),
+ !:Specs = [Spec1 | !.Specs]
)
;
PragmaImpl = fc_impl_model_non(_, _, FirstCode, _, LaterCode,
@@ -362,11 +416,16 @@
UnmentionedInputVars = []
;
UnmentionedInputVars = [_ | _],
- Pieces1 = [words("In the " ++ LangStr ++ " code for"),
+ Pieces2 = [words("In the"), words(LangStr), words("code for"),
simple_call(PredOrFuncCallId), suffix(":"), nl,
words(variable_warning_start(UnmentionedInputVars)),
- words("not occur in the first " ++ LangStr ++ " code.")],
- write_error_pieces(Context, 0, Pieces1, !IO)
+ words("not occur in the first"), words(LangStr),
+ words("code."), nl],
+ Msg2 = simple_msg(Context,
+ [option_is_set(warn_singleton_vars, yes, [always(Pieces2)])]),
+ Spec2 = error_spec(severity_warning, phase_parse_tree_to_hlds,
+ [Msg2]),
+ !:Specs = [Spec2 | !.Specs]
),
FirstOutputFilter = (pred(Name::out) is nondet :-
list.member(yes(Name - Mode), Args),
@@ -380,12 +439,17 @@
UnmentionedFirstOutputVars = []
;
UnmentionedFirstOutputVars = [_ | _],
- Pieces2 = [words("In the " ++ LangStr ++ " code for"),
+ Pieces3 = [words("In the"), words(LangStr), words("code for"),
simple_call(PredOrFuncCallId), suffix(":"), nl,
words(variable_warning_start(UnmentionedFirstOutputVars)),
- words("not occur in the first " ++ LangStr ++
- " code or the shared " ++ LangStr ++ " code.")],
- write_error_pieces(Context, 0, Pieces2, !IO)
+ words("not occur in the first"), words(LangStr),
+ words("code or the shared"), words(LangStr), words("code."),
+ nl],
+ Msg3 = simple_msg(Context,
+ [option_is_set(warn_singleton_vars, yes, [always(Pieces3)])]),
+ Spec3 = error_spec(severity_warning, phase_parse_tree_to_hlds,
+ [Msg3]),
+ !:Specs = [Spec3 | !.Specs]
),
LaterOutputFilter = (pred(Name::out) is nondet :-
list.member(yes(Name - Mode), Args),
@@ -399,12 +463,17 @@
UnmentionedLaterOutputVars = []
;
UnmentionedLaterOutputVars = [_ | _],
- Pieces3 = [words("In the " ++ LangStr ++ " code for"),
+ Pieces4 = [words("In the"), words(LangStr), words("code for"),
simple_call(PredOrFuncCallId), suffix(":"), nl,
words(variable_warning_start(UnmentionedLaterOutputVars)),
- words("not occur in the retry " ++ LangStr ++
- " code or the shared " ++ LangStr ++ " code.")],
- write_error_pieces(Context, 0, Pieces3, !IO)
+ words("not occur in the retry"), words(LangStr),
+ words("code or the shared"), words(LangStr), words("code."),
+ nl],
+ Msg4 = simple_msg(Context,
+ [option_is_set(warn_singleton_vars, yes, [always(Pieces4)])]),
+ Spec4 = error_spec(severity_warning, phase_parse_tree_to_hlds,
+ [Msg4]),
+ !:Specs = [Spec4 | !.Specs]
)
;
PragmaImpl = fc_impl_import(_, _, _, _)
@@ -496,123 +565,42 @@
varset.search_name(VarSet, Var, Name),
string.prefix(Name, "_").
- % warn_singletons(Vars, GoalInfo, NonLocals, QuantVars, ...):
- %
- % Warn if any of the non-underscore variables in Vars don't occur in
- % NonLocals and don't have the same name as any variable in QuantVars,
- % or if any of the underscore variables in Vars do occur in NonLocals.
- % Omit the warning if GoalInfo says we should.
- %
-:- pred warn_singletons(list(prog_var)::in, hlds_goal_info::in,
- set(prog_var)::in, set(prog_var)::in, prog_varset::in,
- prog_context::in, simple_call_id::in, io::di, io::uo) is det.
-
-warn_singletons(GoalVars, GoalInfo, NonLocals, QuantVars, VarSet, Context,
- PredOrFuncCallId, !IO) :-
- % Find all the variables in the goal that don't occur outside the goal
- % (i.e. are singleton), have a variable name that doesn't start with "_"
- % or "DCG_", and don't have the same name as any variable in QuantVars
- % (i.e. weren't explicitly quantified).
-
- solutions.solutions(
- generate_singleton_vars(GoalVars, NonLocals, QuantVars, VarSet),
- SingletonVars),
-
- % if there were any such variables, issue a warning
-
- (
- (
- SingletonVars = []
- ;
- goal_info_has_feature(GoalInfo, feature_dont_warn_singleton)
- )
- ->
- true
- ;
- SingletonVarsStr = mercury_vars_to_string(SingletonVars, VarSet, no),
- ( SingletonVars = [_] ->
- SingletonWarn = "warning: variable `" ++ SingletonVarsStr ++
- "' occurs only once in this scope."
- ;
- SingletonWarn = "warning: variables `" ++ SingletonVarsStr ++
- "' occur only once in this scope."
- ),
- Pieces1 = [words("In clause for"),
- simple_call(PredOrFuncCallId), suffix(":"), nl,
- words(SingletonWarn)],
- report_warning(Context, 0, Pieces1, !IO)
- ),
-
- % Find all the variables in the goal that do occur outside the goal
- % (i.e. are not singleton) and have a variable name that starts
- % with "_". If there were any such variables, issue a warning.
-
- solutions.solutions(generate_multi_vars(GoalVars, NonLocals, VarSet),
- MultiVars),
- (
- MultiVars = []
- ;
- MultiVars = [_ | _],
- MultiVarsStr = mercury_vars_to_string(MultiVars, VarSet, no),
- ( MultiVars = [_] ->
- MultiWarn = "warning: variable `" ++ MultiVarsStr ++
- "' occurs more than once in this scope."
- ;
- MultiWarn = "warning: variables `" ++ MultiVarsStr ++
- "' occur more than once in this scope."
- ),
- Pieces2 = [words("In clause for"),
- simple_call(PredOrFuncCallId), suffix(":"), nl,
- words(MultiWarn)],
- report_warning(Context, 0, Pieces2, !IO)
- ).
-
%-----------------------------------------------------------------------------%
%
% Promise_ex error checking.
-%
-% The following predicates are used to perform extra error checking specific
-% to promise ex declarations (see notes/promise_ex.html). Currently, the
-% following checks are performed:
-%
-% - check for universally quantified variables
-% - check if universal quantification is placed in the wrong position
-% (i.e. after the `promise_exclusive' rather than before it)
-% - check that its goal is a disjunction and that each arm of the
-% disjunction has at most one call, and otherwise has only unifications.
-check_promise_ex_decl(UnivVars, PromiseType, Goal, Context, !IO) :-
- % are universally quantified variables present?
+check_promise_ex_decl(UnivVars, PromiseType, Goal, Context, !Specs) :-
+ % Are universally quantified variables present?
(
UnivVars = [],
promise_ex_error(PromiseType, Context,
- "declaration has no universally quantified variables", !IO)
+ "declaration has no universally quantified variables", !Specs)
;
UnivVars = [_ | _]
),
- check_promise_ex_goal(PromiseType, Goal, !IO).
+ check_promise_ex_goal(PromiseType, Goal, !Specs).
% Check for misplaced universal quantification, otherwise find the
% disjunction, flatten it out into list form and perform further checks.
%
-:- pred check_promise_ex_goal(promise_type::in, goal::in, io::di, io::uo)
- is det.
+:- pred check_promise_ex_goal(promise_type::in, goal::in,
+ list(error_spec)::in, list(error_spec)::out) is det.
-check_promise_ex_goal(PromiseType, GoalExpr - Context, !IO) :-
+check_promise_ex_goal(PromiseType, GoalExpr - Context, !Specs) :-
( GoalExpr = some_expr(_, Goal) ->
- check_promise_ex_goal(PromiseType, Goal, !IO)
+ check_promise_ex_goal(PromiseType, Goal, !Specs)
; GoalExpr = disj_expr(_, _) ->
flatten_to_disj_list(GoalExpr - Context, DisjList),
list.map(flatten_to_conj_list, DisjList, DisjConjList),
- check_disjunction(PromiseType, DisjConjList, !IO)
+ check_disjunction(PromiseType, DisjConjList, !Specs)
; GoalExpr = all_expr(_UnivVars, Goal) ->
promise_ex_error(PromiseType, Context,
"universal quantification should come before " ++
- "the declaration name", !IO),
- check_promise_ex_goal(PromiseType, Goal, !IO)
+ "the declaration name", !Specs),
+ check_promise_ex_goal(PromiseType, Goal, !Specs)
;
promise_ex_error(PromiseType, Context,
- "goal in declaration is not a disjunction", !IO)
+ "goal in declaration is not a disjunction", !Specs)
).
% Turns the goal of a promise_ex declaration into a list of goals,
@@ -645,64 +633,61 @@
% Taking a list of arms of the disjunction, check each arm individually.
%
-:- pred check_disjunction(promise_type::in, list(goals)::in, io::di, io::uo)
- is det.
+:- pred check_disjunction(promise_type::in, list(goals)::in,
+ list(error_spec)::in, list(error_spec)::out) is det.
-check_disjunction(PromiseType, DisjConjList, !IO) :-
+check_disjunction(PromiseType, DisjConjList, !Specs) :-
(
DisjConjList = []
;
DisjConjList = [ConjList | Rest],
- check_disj_arm(PromiseType, ConjList, no, !IO),
- check_disjunction(PromiseType, Rest, !IO)
+ check_disj_arm(PromiseType, ConjList, no, !Specs),
+ check_disjunction(PromiseType, Rest, !Specs)
).
% Only one goal in an arm is allowed to be a call, the rest must be
% unifications.
%
:- pred check_disj_arm(promise_type::in, goals::in, bool::in,
- io::di, io::uo) is det.
+ list(error_spec)::in, list(error_spec)::out) is det.
-check_disj_arm(PromiseType, Goals, CallUsed, !IO) :-
+check_disj_arm(PromiseType, Goals, CallUsed, !Specs) :-
(
Goals = []
;
Goals = [GoalExpr - Context | Rest],
( GoalExpr = unify_expr(_, _, _) ->
- check_disj_arm(PromiseType, Rest, CallUsed, !IO)
+ check_disj_arm(PromiseType, Rest, CallUsed, !Specs)
; GoalExpr = some_expr(_, Goal) ->
- check_disj_arm(PromiseType, [Goal | Rest], CallUsed, !IO)
+ check_disj_arm(PromiseType, [Goal | Rest], CallUsed, !Specs)
; GoalExpr = call_expr(_, _, _) ->
(
CallUsed = no
;
CallUsed = yes,
promise_ex_error(PromiseType, Context,
- "disjunct contains more than one call", !IO)
+ "disjunct contains more than one call", !Specs)
),
- check_disj_arm(PromiseType, Rest, yes, !IO)
+ check_disj_arm(PromiseType, Rest, yes, !Specs)
;
promise_ex_error(PromiseType, Context,
- "disjunct is not a call or unification", !IO),
- check_disj_arm(PromiseType, Rest, CallUsed, !IO)
+ "disjunct is not a call or unification", !Specs),
+ check_disj_arm(PromiseType, Rest, CallUsed, !Specs)
)
).
% Called for any error in the above checks.
%
:- pred promise_ex_error(promise_type::in, prog_context::in, string::in,
- io::di, io::uo) is det.
+ list(error_spec)::in, list(error_spec)::out) is det.
-promise_ex_error(PromiseType, Context, Message, !IO) :-
- ErrorPieces = [
- words("In"),
- quote(prog_out.promise_to_string(PromiseType)),
- words("declaration:"),
- nl,
- words("error:"),
- words(Message)
- ],
- write_error_pieces(Context, 0, ErrorPieces, !IO).
+promise_ex_error(PromiseType, Context, Message, !Specs) :-
+ Pieces = [words("In"), quote(prog_out.promise_to_string(PromiseType)),
+ words("declaration:"), nl,
+ words("error:"), words(Message), nl],
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
+ !:Specs = [Spec | !.Specs].
%-----------------------------------------------------------------------------%
:- end_module make_hlds_warn.
Index: compiler/mercury_compile.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mercury_compile.m,v
retrieving revision 1.400
diff -u -b -r1.400 mercury_compile.m
--- compiler/mercury_compile.m 7 Sep 2006 05:50:56 -0000 1.400
+++ compiler/mercury_compile.m 9 Sep 2006 03:44:42 -0000
@@ -1026,7 +1026,10 @@
( halt_at_module_error(HaltSyntax, Error) ->
true
;
- split_into_submodules(ModuleName, Items, SubModuleList, !IO),
+ split_into_submodules(ModuleName, Items, SubModuleList, [], Specs),
+ sort_error_specs(Specs, SortedSpecs),
+ write_error_specs(SortedSpecs, 0, _NumWarnings, 0, _NumErrors,
+ !IO),
list.foldl(apply_process_module(ProcessModule,
FileName, ModuleName, MaybeTimestamp), SubModuleList, !IO)
),
@@ -1151,7 +1154,9 @@
ModulesToLink = [],
FactTableObjFiles = []
;
- split_into_submodules(ModuleName, Items, SubModuleList0, !IO),
+ split_into_submodules(ModuleName, Items, SubModuleList0, [], Specs),
+ sort_error_specs(Specs, SortedSpecs),
+ write_error_specs(SortedSpecs, 0, _NumWarnings, 0, _NumErrors, !IO),
( MaybeModulesToRecompile = some_modules(ModulesToRecompile) ->
ToRecompile = (pred((SubModule - _)::in) is semidet :-
list.member(SubModule, ModulesToRecompile)
@@ -1708,8 +1713,8 @@
module_imports_get_items(ModuleImports1, Items1),
MaybeTimestamps = ModuleImports1 ^ maybe_timestamps,
- module_qualify_items(Items1, Items2, Module, Verbose, Stats, MQInfo0, _,
- UndefTypes0, UndefModes0, !IO),
+ invoke_module_qualify_items(Items1, Items2, Module, Verbose, Stats,
+ MQInfo0, UndefTypes0, UndefModes0, !IO),
mq_info_get_recompilation_info(MQInfo0, RecompInfo0),
expand_equiv_types(Module, Items2, Verbose, Stats, Items, CircularTypes,
@@ -1752,16 +1757,20 @@
HLDS1 = HLDS0
).
-:- pred module_qualify_items(item_list::in, item_list::out, module_name::in,
- bool::in, bool::in, mq_info::out, int::out, bool::out, bool::out,
- io::di, io::uo) is det.
+:- pred invoke_module_qualify_items(item_list::in, item_list::out,
+ module_name::in, bool::in, bool::in, mq_info::out,
+ bool::out, bool::out, io::di, io::uo) is det.
-module_qualify_items(Items0, Items, ModuleName, Verbose, Stats, MQInfo,
- NumErrors, UndefTypes, UndefModes, !IO) :-
+invoke_module_qualify_items(Items0, Items, ModuleName, Verbose, Stats, MQInfo,
+ UndefTypes, UndefModes, !IO) :-
maybe_write_string(Verbose, "% Module qualifying items...\n", !IO),
maybe_flush_output(Verbose, !IO),
- module_qual.module_qualify_items(Items0, Items, ModuleName, yes,
- MQInfo, NumErrors, UndefTypes, UndefModes, !IO),
+ globals.io_get_globals(Globals, !IO),
+ module_name_to_file_name(ModuleName, ".m", no, FileName, !IO),
+ module_qualify_items(Items0, Items, Globals, ModuleName, yes(FileName),
+ MQInfo, UndefTypes, UndefModes, [], Specs),
+ sort_error_specs(Specs, SortedSpecs),
+ write_error_specs(SortedSpecs, 0, _NumWarnings, 0, _NumErrors, !IO),
maybe_write_string(Verbose, "% done.\n", !IO),
maybe_report_stats(Stats, !IO).
@@ -4411,17 +4420,14 @@
),
maybe_report_stats(Stats, !IO),
- % run the ml_optimize pass before ml_elim_nested,
- % so that we eliminate as many local variables as possible
- % before the ml_elim_nested transformations.
- % We also want to do tail recursion optimization before
- % ml_elim_nested, since this means that the stack-handling
- % code for accurate GC will go outside the loop rather than
- % inside the loop.
- %
- % However, we need to disable optimize_initializations,
- % because ml_elim_nested doesn't correctly handle
- % code containing initializations.
+ % Run the ml_optimize pass before ml_elim_nested, so that we eliminate
+ % as many local variables as possible before the ml_elim_nested
+ % transformations. We also want to do tail recursion optimization before
+ % ml_elim_nested, since this means that the stack-handling code for
+ % accurate GC will go outside the loop rather than inside the loop.
+ %
+ % However, we need to disable optimize_initializations, because
+ % ml_elim_nested doesn't correctly handle code containing initializations.
globals.io_lookup_bool_option(optimize, Optimize, !IO),
(
Optimize = yes,
@@ -4441,17 +4447,12 @@
maybe_report_stats(Stats, !IO),
maybe_dump_mlds(MLDS25, 25, "optimize1", !IO),
- %
- % Note that we call ml_elim_nested twice --
- % the first time to chain the stack frames together, for accurate GC,
- % and the second time to flatten nested functions.
- % These two passes are quite similar,
- % but must be done separately.
- % Currently chaining the stack frames together for accurate GC
- % needs to be done first, because the code for doing that
- % can't handle the env_ptr references that the other pass
- % generates.
- %
+ % Note that we call ml_elim_nested twice -- the first time to chain
+ % the stack frames together, for accurate GC, and the second time to
+ % flatten nested functions. These two passes are quite similar, but
+ % must be done separately. Currently chaining the stack frames together
+ % for accurate GC needs to be done first, because the code for doing that
+ % can't handle the env_ptr references that the other pass generates.
globals.io_get_gc_method(GC, !IO),
( GC = gc_accurate ->
Index: compiler/mercury_to_mercury.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mercury_to_mercury.m,v
retrieving revision 1.301
diff -u -b -r1.301 mercury_to_mercury.m
--- compiler/mercury_to_mercury.m 7 Sep 2006 05:50:57 -0000 1.301
+++ compiler/mercury_to_mercury.m 8 Sep 2006 12:46:01 -0000
@@ -754,7 +754,8 @@
mercury_output_item(_, item_promise(PromiseType, Goal0, VarSet, UnivVars), _,
!IO) :-
Indent = 1,
- ( PromiseType = true ->
+ (
+ PromiseType = promise_type_true,
% For an assertion, we put back any universally quantified variables
% that were stripped off during parsing so that the clause will
% output correctly.
@@ -768,6 +769,10 @@
Goal = Goal0
)
;
+ ( PromiseType = promise_type_exclusive
+ ; PromiseType = promise_type_exhaustive
+ ; PromiseType = promise_type_exclusive_exhaustive
+ ),
% A promise ex declaration has a slightly different standard formatting
% from an assertion; the universal quantification comes before the rest
% of the declaration
@@ -863,14 +868,6 @@
io.print(Attrs, !IO),
io.write_string(").\n", !IO).
-:- func mercury_to_string_promise_type(promise_type) = string.
-
-mercury_to_string_promise_type(exclusive) = "promise_exclusive".
-mercury_to_string_promise_type(exhaustive) = "promise_exhaustive".
-mercury_to_string_promise_type(exclusive_exhaustive) =
- "promise_exclusive_exhaustive".
-mercury_to_string_promise_type(true) = "promise".
-
%-----------------------------------------------------------------------------%
:- pred output_class_methods(class_methods::in, io::di, io::uo) is det.
Index: compiler/mode_errors.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mode_errors.m,v
retrieving revision 1.107
diff -u -b -r1.107 mode_errors.m
--- compiler/mode_errors.m 7 Sep 2006 05:50:59 -0000 1.107
+++ compiler/mode_errors.m 8 Sep 2006 08:05:01 -0000
@@ -224,7 +224,6 @@
:- pred write_mode_inference_messages(list(pred_id)::in, bool::in,
module_info::in, io::di, io::uo) is det.
-:- pred output_mode_decl(proc_id::in, pred_info::in, io::di, io::uo) is det.
:- func mode_decl_to_string(proc_id, pred_info) = string.
%-----------------------------------------------------------------------------%
@@ -1245,7 +1244,7 @@
ModuleInfo, !IO).
% Write out the inferred `mode' declaration for a single function
- % or predicate..
+ % or predicate.
%
:- pred write_mode_inference_message(pred_info::in, proc_info::in, bool::in,
module_info::in, io::di, io::uo) is det.
@@ -1281,9 +1280,9 @@
!:MaybeDet = no
),
( proc_info_is_valid_mode(ProcInfo) ->
- Msg = "Inferred"
+ Verb = "Inferred"
;
- Msg = "REJECTED",
+ Verb = "REJECTED",
% Replace the final insts with dummy insts '...',
% since they won't be valid anyway -- they are just
% the results of whatever partial inference we did
@@ -1307,8 +1306,10 @@
Detail = mercury_func_mode_decl_to_string(VarSet, Name,
FuncArgModes, RetMode, !.MaybeDet, Context)
),
- Pieces = [words(Msg), words(Detail), nl],
- write_error_pieces(Context, 0, Pieces, !IO)
+ Pieces = [words(Verb), words(Detail), nl],
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_informational, phase_mode_check, [Msg]),
+ write_error_spec(Spec, 0, _NumWarnings, 0, _NumErrors, !IO)
).
%-----------------------------------------------------------------------------%
@@ -1339,9 +1340,6 @@
%-----------------------------------------------------------------------------%
-output_mode_decl(ProcId, PredInfo, !IO) :-
- io.write_string(mode_decl_to_string(ProcId, PredInfo), !IO).
-
mode_decl_to_string(ProcId, PredInfo) = String :-
PredOrFunc = pred_info_is_pred_or_func(PredInfo),
Name0 = pred_info_name(PredInfo),
Index: compiler/modes.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/modes.m,v
retrieving revision 1.343
diff -u -b -r1.343 modes.m
--- compiler/modes.m 7 Sep 2006 05:51:00 -0000 1.343
+++ compiler/modes.m 8 Sep 2006 03:10:33 -0000
@@ -511,16 +511,18 @@
:- pred report_max_iterations_exceeded(io::di, io::uo) is det.
report_max_iterations_exceeded(!IO) :-
- io.set_exit_status(1, !IO),
- io.write_strings([
- "Mode analysis iteration limit exceeded.\n",
- "You may need to declare the modes explicitly, or use the\n",
- "`--mode-inference-iteration-limit' option to increase the limit.\n"
- ], !IO),
globals.io_lookup_int_option(mode_inference_iteration_limit,
MaxIterations, !IO),
- io.format("(The current limit is %d iterations.)\n",
- [i(MaxIterations)], !IO).
+ Pieces = [words("Mode analysis iteration limit exceeded."), nl,
+ words("You may need to declare the modes explicitly"),
+ words("or use the `--mode-inference-iteration-limit' option"),
+ words("to increase the limit."),
+ words("(The current limit is"), int_fixed(MaxIterations),
+ words("iterations.)"), nl],
+ Msg = error_msg(no, no, 0, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_mode_check, [Msg]),
+ % XXX _NumErrors
+ write_error_spec(Spec, 0, _NumWarnings, 0, _NumErrors, !IO).
% copy_pred_bodies(OldPredTable, ProcId, ModuleInfo0, ModuleInfo):
%
@@ -3378,23 +3380,18 @@
proc_info_get_eval_method(ProcInfo, EvalMethod),
proc_info_get_context(ProcInfo, Context),
EvalMethodS = eval_method_to_string(EvalMethod),
- globals.io_lookup_bool_option(verbose_errors, VerboseErrors, !IO),
- Pieces1 = [words("Sorry, not implemented:"),
+ MainPieces = [words("Sorry, not implemented:"),
fixed("`pragma " ++ EvalMethodS ++ "'"),
words("declaration not allowed for procedure"),
- words("with partially instantiated modes.")],
- (
- VerboseErrors = yes,
- Pieces2 = [words("Tabling of predicates/functions"),
+ words("with partially instantiated modes."), nl],
+ VerbosePieces = [words("Tabling of predicates/functions"),
words("with partially instantiated modes"),
- words("is not currently implemented.")]
- ;
- VerboseErrors = no,
- globals.io_set_extra_error_info(yes, !IO),
- Pieces2 = []
- ),
- write_error_pieces(Context, 0, Pieces1 ++ Pieces2, !IO),
- module_info_incr_errors(!ModuleInfo).
+ words("is not currently implemented."), nl],
+ Msg = simple_msg(Context,
+ [always(MainPieces), verbose_only(VerbosePieces)]),
+ Spec = error_spec(severity_error, phase_mode_check, [Msg]),
+ write_error_spec(Spec, 0, _NumWarnings, 0, NumErrors, !IO),
+ module_info_incr_num_errors(NumErrors, !ModuleInfo).
:- pred report_eval_method_destroys_uniqueness(proc_info::in,
module_info::in, module_info::out, io::di, io::uo) is det.
@@ -3403,32 +3400,31 @@
proc_info_get_eval_method(ProcInfo, EvalMethod),
proc_info_get_context(ProcInfo, Context),
EvalMethodS = eval_method_to_string(EvalMethod),
- globals.io_lookup_bool_option(verbose_errors, VerboseErrors, !IO),
- Pieces1 = [words("Error:"),
+ MainPieces = [words("Error:"),
fixed("`pragma " ++ EvalMethodS ++ "'"),
words("declaration not allowed for procedure"),
- words("with unique modes.")],
- (
- VerboseErrors = yes,
- Pieces2 = [words("Tabling of predicates/functions with unique modes"),
+ words("with unique modes."), nl],
+ VerbosePieces =
+ [words("Tabling of predicates/functions with unique modes"),
words("is not allowed as this would lead to a copying"),
words("of the unique arguments which would result"),
- words("in them no longer being unique.")]
- ;
- VerboseErrors = no,
- Pieces2 = []
- ),
- write_error_pieces(Context, 0, Pieces1 ++ Pieces2, !IO),
- module_info_incr_errors(!ModuleInfo).
+ words("in them no longer being unique."), nl],
+ Msg = simple_msg(Context,
+ [always(MainPieces), verbose_only(VerbosePieces)]),
+ Spec = error_spec(severity_error, phase_mode_check, [Msg]),
+ write_error_spec(Spec, 0, _NumWarnings, 0, NumErrors, !IO),
+ module_info_incr_num_errors(NumErrors, !ModuleInfo).
:- pred report_wrong_mode_for_main(proc_info::in,
module_info::in, module_info::out, io::di, io::uo) is det.
report_wrong_mode_for_main(ProcInfo, !ModuleInfo, !IO) :-
proc_info_get_context(ProcInfo, Context),
- Pieces = [words("Error: main/2 must have mode `(di, uo)'.")],
- write_error_pieces(Context, 0, Pieces, !IO),
- module_info_incr_errors(!ModuleInfo).
+ Pieces = [words("Error: main/2 must have mode `(di, uo)'."), nl],
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_mode_check, [Msg]),
+ write_error_spec(Spec, 0, _NumWarnings, 0, NumErrors, !IO),
+ module_info_incr_num_errors(NumErrors, !ModuleInfo).
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
Index: compiler/module_qual.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/module_qual.m,v
retrieving revision 1.146
diff -u -b -r1.146 module_qual.m
--- compiler/module_qual.m 7 Sep 2006 05:51:00 -0000 1.146
+++ compiler/module_qual.m 8 Sep 2006 13:49:07 -0000
@@ -24,56 +24,54 @@
:- module parse_tree.module_qual.
:- interface.
+:- import_module libs.globals.
:- 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 recompilation.
:- import_module bool.
-:- import_module io.
:- import_module list.
:- import_module maybe.
%-----------------------------------------------------------------------------%
- % module_qualify_items(Items0, Items, ModuleName, ReportUndefErrors,
- % MQ_Info, NumErrors, UndefTypes, UndefModes):
+ % module_qualify_items(Items0, Items, Globals, ModuleName,
+ % MaybeFileName, MQ_Info, UndefTypes, UndefModes, !Specs, !IO):
+ %
+ % Items is Items0 with all items module qualified as much as possible.
+ % If MaybeFileName is `yes(FileName)', then report undefined types, insts
+ % and modes. MaybeFileName should be `no' when module qualifying the short
+ % interface.
%
- % Items is Items0 with all items module qualified as much as
- % possible. If ReportUndefErrors is yes, then report undefined
- % types, insts and modes. ReportUndefErrors should be no when
- % module qualifying the short interface.
- %
-:- pred module_qual.module_qualify_items(item_list::in, item_list::out,
- module_name::in, bool::in, mq_info::out, int::out, bool::out,
- bool::out, io::di, io::uo) is det.
+:- pred module_qualify_items(item_list::in, item_list::out, globals::in,
+ module_name::in, maybe(string)::in, mq_info::out, bool::out, bool::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
- % This is called from make_hlds.m to qualify the mode of a lambda
- % expression.
+ % This is called from make_hlds to qualify the mode of a lambda expression.
%
-:- pred module_qual.qualify_lambda_mode_list(list(mer_mode)::in,
+:- pred qualify_lambda_mode_list(list(mer_mode)::in,
list(mer_mode)::out, prog_context::in, mq_info::in, mq_info::out,
- io::di, io::uo) is det.
+ list(error_spec)::in, list(error_spec)::out) is det.
% This is called from make_hlds.m to qualify the modes in a
% clause mode annotation.
%
-:- pred module_qual.qualify_clause_mode_list(list(mer_mode)::in,
+:- pred qualify_clause_mode_list(list(mer_mode)::in,
list(mer_mode)::out, prog_context::in, mq_info::in, mq_info::out,
- io::di, io::uo) is det.
+ list(error_spec)::in, list(error_spec)::out) is det.
- % This is called from make_hlds.m to qualify an
- % explicit type qualification.
+ % This is called from make_hlds to qualify an explicit type qualification.
%
-:- pred module_qual.qualify_type_qualification(mer_type::in, mer_type::out,
- prog_context::in, mq_info::in, mq_info::out, io::di, io::uo) is det.
+:- pred qualify_type_qualification(mer_type::in, mer_type::out,
+ prog_context::in, mq_info::in, mq_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
- % The type mq_info holds information needed for doing module
- % qualification.
+ % The type mq_info holds information needed for doing module qualification.
%
:- type mq_info.
-:- pred mq_info_get_num_errors(mq_info::in, int::out) is det.
:- pred mq_info_get_type_error_flag(mq_info::in, bool::out) is det.
:- pred mq_info_get_mode_error_flag(mq_info::in, bool::out) is det.
:- pred mq_info_get_need_qual_flag(mq_info::in, need_qualifier::out) is det.
@@ -111,8 +109,8 @@
% partial qualifiers for which we need to insert definitions,
% i.e. all the ones which are visible. For example,
% given as input `foo.bar.baz', it returns a list containing
- % (1) `baz', iff `foo.bar' is imported
- % and (2) `bar.baz', iff `foo' is imported.
+ % (1) `baz', iff `foo.bar' is imported, and
+ % (2) `bar.baz', iff `foo' is imported.
% Note that the caller will still need to handle the fully-qualified
% and fully-unqualified versions separately.
%
@@ -125,9 +123,7 @@
:- implementation.
:- import_module libs.compiler_util.
-:- import_module libs.globals.
:- import_module libs.options.
-:- import_module parse_tree.error_util.
:- import_module parse_tree.mercury_to_mercury.
:- import_module parse_tree.modules.
:- import_module parse_tree.prog_io.
@@ -148,36 +144,41 @@
%-----------------------------------------------------------------------------%
-module_qual.module_qualify_items(Items0, Items, ModuleName, ReportErrors,
- Info, NumErrors, UndefTypes, UndefModes, !IO) :-
- globals.io_get_globals(Globals, !IO),
+module_qualify_items(Items0, Items, Globals, ModuleName, MaybeFileName, Info,
+ UndefTypes, UndefModes, !Specs) :-
+ (
+ MaybeFileName = yes(_),
+ ReportErrors = yes
+ ;
+ MaybeFileName = no,
+ ReportErrors = no
+ ),
init_mq_info(Items0, Globals, ReportErrors, ModuleName, Info0),
collect_mq_info(Items0, Info0, Info1),
- do_module_qualify_items(Items0, Items, Info1, Info, !IO),
+ do_module_qualify_items(Items0, Items, Info1, Info, !Specs),
mq_info_get_type_error_flag(Info, UndefTypes),
mq_info_get_mode_error_flag(Info, UndefModes),
(
- ReportErrors = yes,
+ MaybeFileName = yes(FileName),
mq_info_get_unused_interface_modules(Info, UnusedImports0),
set.to_sorted_list(UnusedImports0, UnusedImports),
- maybe_warn_unused_interface_imports(ModuleName, UnusedImports,
- !IO)
+ maybe_warn_unused_interface_imports(ModuleName, FileName,
+ UnusedImports, !Specs)
;
- ReportErrors = no
- ),
- mq_info_get_num_errors(Info, NumErrors).
+ MaybeFileName = no
+ ).
-module_qual.qualify_lambda_mode_list(Modes0, Modes, Context, !Info, !IO) :-
+qualify_lambda_mode_list(Modes0, Modes, Context, !Info, !Specs) :-
mq_info_set_error_context(mqec_lambda_expr - Context, !Info),
- qualify_mode_list(Modes0, Modes, !Info, !IO).
+ qualify_mode_list(Modes0, Modes, !Info, !Specs).
-module_qual.qualify_clause_mode_list(Modes0, Modes, Context, !Info, !IO) :-
+qualify_clause_mode_list(Modes0, Modes, Context, !Info, !Specs) :-
mq_info_set_error_context(mqec_clause_mode_annotation - Context, !Info),
- qualify_mode_list(Modes0, Modes, !Info, !IO).
+ qualify_mode_list(Modes0, Modes, !Info, !Specs).
-module_qual.qualify_type_qualification(Type0, Type, Context, !Info, !IO) :-
+qualify_type_qualification(Type0, Type, Context, !Info, !Specs) :-
mq_info_set_error_context(mqec_type_qual - Context, !Info),
- qualify_type(Type0, Type, !Info, !IO).
+ qualify_type(Type0, Type, !Info, !Specs).
:- type mq_info
---> mq_info(
@@ -616,14 +617,15 @@
% module qualified.
%
:- pred do_module_qualify_items(item_list::in, item_list::out,
- mq_info::in, mq_info::out, io::di, io::uo) is det.
+ mq_info::in, mq_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
-do_module_qualify_items([], [], !Info, !IO).
-do_module_qualify_items([Item0 | Items0], [Item | Items], !Info, !IO) :-
- module_qualify_item(Item0, Item, !Info, Continue, !IO),
+do_module_qualify_items([], [], !Info, !Specs).
+do_module_qualify_items([Item0 | Items0], [Item | Items], !Info, !Specs) :-
+ module_qualify_item(Item0, Item, !Info, Continue, !Specs),
(
Continue = yes,
- do_module_qualify_items(Items0, Items, !Info, !IO)
+ do_module_qualify_items(Items0, Items, !Info, !Specs)
;
Continue = no,
Items = Items0
@@ -632,38 +634,39 @@
% Call predicates to qualify a single item.
%
:- pred module_qualify_item(item_and_context::in, item_and_context::out,
- mq_info::in, mq_info::out, bool::out, io::di, io::uo) is det.
+ mq_info::in, mq_info::out, bool::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
module_qualify_item(Clause @ (item_clause(_,_,_,_,_,_) - _), Clause, !Info,
- yes, !IO).
+ yes, !Specs).
module_qualify_item(
item_type_defn(TVarSet, SymName, Params, TypeDefn0, C) - Context,
item_type_defn(TVarSet, SymName, Params, TypeDefn, C) - Context,
- !Info, yes, !IO) :-
+ !Info, yes, !Specs) :-
list.length(Params, Arity),
mq_info_set_error_context(mqec_type(mq_id(SymName, Arity)) - Context,
!Info),
- qualify_type_defn(TypeDefn0, TypeDefn, !Info, !IO).
+ qualify_type_defn(TypeDefn0, TypeDefn, !Info, !Specs).
module_qualify_item(item_inst_defn(A, SymName, Params, InstDefn0, C) - Context,
item_inst_defn(A, SymName, Params, InstDefn, C) - Context,
- !Info, yes, !IO) :-
+ !Info, yes, !Specs) :-
list.length(Params, Arity),
mq_info_set_error_context(mqec_inst(mq_id(SymName, Arity)) - Context,
!Info),
- qualify_inst_defn(InstDefn0, InstDefn, !Info, !IO).
+ qualify_inst_defn(InstDefn0, InstDefn, !Info, !Specs).
module_qualify_item(item_mode_defn(A, SymName, Params, ModeDefn0, C) - Context,
item_mode_defn(A, SymName, Params, ModeDefn, C) - Context,
- !Info, yes, !IO) :-
+ !Info, yes, !Specs) :-
list.length(Params, Arity),
mq_info_set_error_context(mqec_mode(mq_id(SymName, Arity)) - Context,
!Info),
- qualify_mode_defn(ModeDefn0, ModeDefn, !Info, !IO).
+ qualify_mode_defn(ModeDefn0, ModeDefn, !Info, !Specs).
module_qualify_item(item_module_defn(A, ModuleDefn) - Context,
- item_module_defn(A, ModuleDefn) - Context, !Info, Continue, !IO) :-
+ item_module_defn(A, ModuleDefn) - Context, !Info, Continue, !Specs) :-
update_import_status(ModuleDefn, !Info, Continue).
module_qualify_item(
@@ -672,51 +675,51 @@
- Context,
item_pred_or_func(Origin, A, IVs, B, PredOrFunc, SymName,
TypesAndModes, WithType, WithInst, C, D, E, Constraints) - Context,
- !Info, yes, !IO) :-
+ !Info, yes, !Specs) :-
list.length(TypesAndModes0, Arity),
mq_info_set_error_context(
mqec_pred_or_func(PredOrFunc, mq_id(SymName, Arity)) - Context, !Info),
- qualify_types_and_modes(TypesAndModes0, TypesAndModes, !Info, !IO),
- qualify_prog_constraints(Constraints0, Constraints, !Info, !IO),
- map_fold2_maybe(qualify_type, WithType0, WithType, !Info, !IO),
- map_fold2_maybe(qualify_inst, WithInst0, WithInst, !Info, !IO).
+ qualify_types_and_modes(TypesAndModes0, TypesAndModes, !Info, !Specs),
+ qualify_prog_constraints(Constraints0, Constraints, !Info, !Specs),
+ map_fold2_maybe(qualify_type, WithType0, WithType, !Info, !Specs),
+ map_fold2_maybe(qualify_inst, WithInst0, WithInst, !Info, !Specs).
module_qualify_item(
item_pred_or_func_mode(A, PredOrFunc, SymName, Modes0,
WithInst0, C, D) - Context,
item_pred_or_func_mode(A, PredOrFunc, SymName, Modes,
WithInst, C, D) - Context,
- !Info, yes, !IO) :-
+ !Info, yes, !Specs) :-
list.length(Modes0, Arity),
mq_info_set_error_context(
mqec_pred_or_func_mode(PredOrFunc, mq_id(SymName, Arity)) - Context,
!Info),
- qualify_mode_list(Modes0, Modes, !Info, !IO),
- map_fold2_maybe(qualify_inst, WithInst0, WithInst, !Info, !IO).
-module_qualify_item(Item0, Item, !Info, yes, !IO) :-
+ qualify_mode_list(Modes0, Modes, !Info, !Specs),
+ map_fold2_maybe(qualify_inst, WithInst0, WithInst, !Info, !Specs).
+module_qualify_item(Item0, Item, !Info, yes, !Specs) :-
Item0 = item_pragma(Origin, Pragma0) - Context,
mq_info_set_error_context(mqec_pragma - Context, !Info),
- qualify_pragma(Pragma0, Pragma, !Info, !IO),
+ qualify_pragma(Pragma0, Pragma, !Info, !Specs),
Item = item_pragma(Origin, Pragma) - Context.
module_qualify_item(item_promise(T, G, V, U) - Context,
- item_promise(T, G, V, U) - Context, !Info, yes, !IO).
+ item_promise(T, G, V, U) - Context, !Info, yes, !Specs).
module_qualify_item(item_nothing(A) - Context, item_nothing(A) - Context,
- !Info, yes, !IO).
+ !Info, yes, !Specs).
module_qualify_item(
item_typeclass(Constraints0, FunDeps, Name, Vars, Interface0, VarSet)
- Context,
item_typeclass(Constraints, FunDeps, Name, Vars, Interface, VarSet)
- Context,
- !Info, yes, !IO) :-
+ !Info, yes, !Specs) :-
list.length(Vars, Arity),
mq_info_set_error_context(mqec_class(mq_id(Name, Arity)) - Context, !Info),
- qualify_prog_constraint_list(Constraints0, Constraints, !Info, !IO),
+ qualify_prog_constraint_list(Constraints0, Constraints, !Info, !Specs),
(
Interface0 = abstract,
Interface = abstract
;
Interface0 = concrete(Methods0),
- qualify_class_interface(Methods0, Methods, !Info, !IO),
+ qualify_class_interface(Methods0, Methods, !Info, !Specs),
Interface = concrete(Methods)
).
@@ -725,35 +728,35 @@
ModName) - Context,
item_instance(Constraints, Name, Types, Body, VarSet,
ModName) - Context,
- !Info, yes, !IO) :-
+ !Info, yes, !Specs) :-
list.length(Types0, Arity),
Id = mq_id(Name0, Arity),
mq_info_set_error_context(mqec_instance(Id) - Context, !Info),
% We don't qualify the implementation yet, since that requires
% us to resolve overloading.
- qualify_prog_constraint_list(Constraints0, Constraints, !Info, !IO),
- qualify_class_name(Id, mq_id(Name, _), !Info, !IO),
- qualify_type_list(Types0, Types, !Info, !IO),
+ qualify_prog_constraint_list(Constraints0, Constraints, !Info, !Specs),
+ qualify_class_name(Id, mq_id(Name, _), !Info, !Specs),
+ qualify_type_list(Types0, Types, !Info, !Specs),
qualify_instance_body(Name, Body0, Body).
module_qualify_item(
item_initialise(Origin, PredSymName, Arity) - Context,
item_initialise(Origin, PredSymName, Arity) - Context,
- !Info, yes, !IO).
+ !Info, yes, !Specs).
module_qualify_item(
item_finalise(Origin, PredSymName, Arity) - Context,
item_finalise(Origin, PredSymName, Arity) - Context,
- !Info, yes, !IO).
+ !Info, yes, !Specs).
module_qualify_item(
item_mutable(Name, Type0, InitTerm, Inst0, Attrs, Varset) - Context,
item_mutable(Name, Type, InitTerm, Inst, Attrs, Varset) - Context,
- !Info, yes, !IO) :-
+ !Info, yes, !Specs) :-
mq_info_set_error_context(mqec_mutable(Name) - Context, !Info),
- qualify_type(Type0, Type, !Info, !IO),
- qualify_inst(Inst0, Inst, !Info, !IO).
+ qualify_type(Type0, Type, !Info, !Specs),
+ qualify_inst(Inst0, Inst, !Info, !Specs).
:- pred update_import_status(module_defn::in, mq_info::in, mq_info::out,
bool::out) is det.
@@ -787,199 +790,207 @@
% Qualify the constructors or other types in a type definition.
%
:- pred qualify_type_defn(type_defn::in, type_defn::out,
- mq_info::in, mq_info::out, io::di, io::uo) is det.
+ mq_info::in, mq_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
qualify_type_defn(parse_tree_du_type(Ctors0, MaybeUserEqComp0),
parse_tree_du_type(Ctors, MaybeUserEqComp),
- !Info, !IO) :-
- qualify_constructors(Ctors0, Ctors, !Info, !IO),
- %
- % User-defined equality pred names will be converted into
- % predicate calls and then module-qualified after type analysis
- % (during mode analysis). That way they get full type overloading
- % resolution, etc. Thus we don't module-qualify them here.
- %
+ !Info, !Specs) :-
+ qualify_constructors(Ctors0, Ctors, !Info, !Specs),
+ % User-defined equality pred names will be converted into predicate calls
+ % and then module-qualified after type analysis (during mode analysis).
+ % That way they get full type overloading resolution, etc. Thus we don't
+ % module-qualify them here.
MaybeUserEqComp = MaybeUserEqComp0.
qualify_type_defn(parse_tree_eqv_type(Type0), parse_tree_eqv_type(Type),
- !Info, !IO) :-
- qualify_type(Type0, Type, !Info, !IO).
-qualify_type_defn(parse_tree_abstract_type(_) @ Defn, Defn, !Info, !IO).
-qualify_type_defn(parse_tree_foreign_type(_, _, _) @ Defn, Defn, !Info, !IO).
+ !Info, !Specs) :-
+ qualify_type(Type0, Type, !Info, !Specs).
+qualify_type_defn(parse_tree_abstract_type(_) @ Defn, Defn, !Info, !Specs).
+qualify_type_defn(parse_tree_foreign_type(_, _, _) @ Defn, Defn, !Info,
+ !Specs).
qualify_type_defn(parse_tree_solver_type(SolverTypeDetails0, MaybeUserEqComp),
parse_tree_solver_type(SolverTypeDetails, MaybeUserEqComp),
- !Info, !IO) :-
+ !Info, !Specs) :-
SolverTypeDetails0 = solver_type_details(RepnType0, InitPred,
GroundInst0, AnyInst0, MutableItems),
- qualify_type(RepnType0, RepnType, !Info, !IO),
- qualify_inst(GroundInst0, GroundInst, !Info, !IO),
- qualify_inst(AnyInst0, AnyInst, !Info, !IO),
+ qualify_type(RepnType0, RepnType, !Info, !Specs),
+ qualify_inst(GroundInst0, GroundInst, !Info, !Specs),
+ qualify_inst(AnyInst0, AnyInst, !Info, !Specs),
SolverTypeDetails = solver_type_details(RepnType, InitPred,
GroundInst, AnyInst, MutableItems).
:- pred qualify_constructors(list(constructor)::in, list(constructor)::out,
- mq_info::in, mq_info::out, io::di, io::uo) is det.
+ mq_info::in, mq_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
-qualify_constructors([], [], !Info, !IO).
-qualify_constructors([Ctor0 | Ctors0], [Ctor | Ctors], !Info, !IO) :-
+qualify_constructors([], [], !Info, !Specs).
+qualify_constructors([Ctor0 | Ctors0], [Ctor | Ctors], !Info, !Specs) :-
Ctor0 = ctor(ExistQVars, Constraints0, SymName, Args0),
- qualify_constructor_arg_list(Args0, Args, !Info, !IO),
- qualify_constructors(Ctors0, Ctors, !Info, !IO),
- qualify_prog_constraint_list(Constraints0, Constraints, !Info, !IO),
+ qualify_constructor_arg_list(Args0, Args, !Info, !Specs),
+ qualify_constructors(Ctors0, Ctors, !Info, !Specs),
+ qualify_prog_constraint_list(Constraints0, Constraints, !Info, !Specs),
Ctor = ctor(ExistQVars, Constraints, SymName, Args).
% Qualify the inst parameters of an inst definition.
%
:- pred qualify_inst_defn(inst_defn::in, inst_defn::out,
- mq_info::in, mq_info::out, io::di, io::uo) is det.
+ mq_info::in, mq_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
-qualify_inst_defn(eqv_inst(Inst0), eqv_inst(Inst), !Info, !IO) :-
- qualify_inst(Inst0, Inst, !Info, !IO).
-qualify_inst_defn(abstract_inst, abstract_inst, !Info, !IO).
+qualify_inst_defn(eqv_inst(Inst0), eqv_inst(Inst), !Info, !Specs) :-
+ qualify_inst(Inst0, Inst, !Info, !Specs).
+qualify_inst_defn(abstract_inst, abstract_inst, !Info, !Specs).
% Qualify the mode parameter of an equivalence mode definition.
%
:- pred qualify_mode_defn(mode_defn::in, mode_defn::out,
- mq_info::in, mq_info::out, io::di, io::uo) is det.
+ mq_info::in, mq_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
-qualify_mode_defn(eqv_mode(Mode0), eqv_mode(Mode), !Info, !IO) :-
- qualify_mode(Mode0, Mode, !Info, !IO).
+qualify_mode_defn(eqv_mode(Mode0), eqv_mode(Mode), !Info, !Specs) :-
+ qualify_mode(Mode0, Mode, !Info, !Specs).
% Qualify a list of items of the form Type::Mode, as in a
% predicate declaration.
%
:- pred qualify_types_and_modes(list(type_and_mode)::in,
list(type_and_mode)::out, mq_info::in, mq_info::out,
- io::di, io::uo) is det.
+ list(error_spec)::in, list(error_spec)::out) is det.
-qualify_types_and_modes([], [], !Info, !IO).
+qualify_types_and_modes([], [], !Info, !Specs).
qualify_types_and_modes([TypeAndMode0 | TypesAndModes0],
- [TypeAndMode | TypesAndModes], !Info, !IO) :-
- qualify_type_and_mode(TypeAndMode0, TypeAndMode, !Info, !IO),
- qualify_types_and_modes(TypesAndModes0, TypesAndModes, !Info, !IO).
+ [TypeAndMode | TypesAndModes], !Info, !Specs) :-
+ qualify_type_and_mode(TypeAndMode0, TypeAndMode, !Info, !Specs),
+ qualify_types_and_modes(TypesAndModes0, TypesAndModes, !Info, !Specs).
:- pred qualify_type_and_mode(type_and_mode::in, type_and_mode::out,
- mq_info::in, mq_info::out, io::di, io::uo) is det.
+ mq_info::in, mq_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
-qualify_type_and_mode(type_only(Type0), type_only(Type), !Info, !IO) :-
- qualify_type(Type0, Type, !Info, !IO).
+qualify_type_and_mode(type_only(Type0), type_only(Type), !Info, !Specs) :-
+ qualify_type(Type0, Type, !Info, !Specs).
qualify_type_and_mode(type_and_mode(Type0, Mode0), type_and_mode(Type, Mode),
- !Info, !IO) :-
- qualify_type(Type0, Type, !Info, !IO),
- qualify_mode(Mode0, Mode, !Info, !IO).
+ !Info, !Specs) :-
+ qualify_type(Type0, Type, !Info, !Specs),
+ qualify_mode(Mode0, Mode, !Info, !Specs).
:- pred qualify_mode_list(list(mer_mode)::in, list(mer_mode)::out,
- mq_info::in, mq_info::out, io::di, io::uo) is det.
+ mq_info::in, mq_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
-qualify_mode_list([], [], !Info, !IO).
-qualify_mode_list([Mode0 | Modes0], [Mode | Modes], !Info, !IO) :-
- qualify_mode(Mode0, Mode, !Info, !IO),
- qualify_mode_list(Modes0, Modes, !Info, !IO).
+qualify_mode_list([], [], !Info, !Specs).
+qualify_mode_list([Mode0 | Modes0], [Mode | Modes], !Info, !Specs) :-
+ qualify_mode(Mode0, Mode, !Info, !Specs),
+ qualify_mode_list(Modes0, Modes, !Info, !Specs).
:- pred qualify_mode(mer_mode::in, mer_mode::out, mq_info::in, mq_info::out,
- io::di, io::uo) is det.
+ list(error_spec)::in, list(error_spec)::out) is det.
-qualify_mode((InstA0 -> InstB0), (InstA -> InstB), !Info, !IO) :-
- qualify_inst(InstA0, InstA, !Info, !IO),
- qualify_inst(InstB0, InstB, !Info, !IO).
+qualify_mode((InstA0 -> InstB0), (InstA -> InstB), !Info, !Specs) :-
+ qualify_inst(InstA0, InstA, !Info, !Specs),
+ qualify_inst(InstB0, InstB, !Info, !Specs).
qualify_mode(user_defined_mode(SymName0, Insts0),
- user_defined_mode(SymName, Insts), !Info, !IO) :-
- qualify_inst_list(Insts0, Insts, !Info, !IO),
+ user_defined_mode(SymName, Insts), !Info, !Specs) :-
+ qualify_inst_list(Insts0, Insts, !Info, !Specs),
list.length(Insts, Arity),
mq_info_get_modes(!.Info, Modes),
find_unique_match(mq_id(SymName0, Arity), mq_id(SymName, _),
- Modes, mode_id, !Info, !IO).
+ Modes, mode_id, !Info, !Specs).
:- pred qualify_inst_list(list(mer_inst)::in, list(mer_inst)::out,
- mq_info::in, mq_info::out, io::di, io::uo) is det.
+ mq_info::in, mq_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
-qualify_inst_list([], [], !Info, !IO).
-qualify_inst_list([Inst0 | Insts0], [Inst | Insts], !Info, !IO) :-
- qualify_inst(Inst0, Inst, !Info, !IO),
- qualify_inst_list(Insts0, Insts, !Info, !IO).
+qualify_inst_list([], [], !Info, !Specs).
+qualify_inst_list([Inst0 | Insts0], [Inst | Insts], !Info, !Specs) :-
+ qualify_inst(Inst0, Inst, !Info, !Specs),
+ qualify_inst_list(Insts0, Insts, !Info, !Specs).
% Qualify a single inst.
%
:- pred qualify_inst(mer_inst::in, mer_inst::out, mq_info::in, mq_info::out,
- io::di, io::uo) is det.
+ list(error_spec)::in, list(error_spec)::out) is det.
-qualify_inst(any(A), any(A), !Info, !IO).
-qualify_inst(free, free, !Info, !IO).
-qualify_inst(not_reached, not_reached, !Info, !IO).
-qualify_inst(free(_), _, !Info, !IO) :-
+qualify_inst(any(A), any(A), !Info, !Specs).
+qualify_inst(free, free, !Info, !Specs).
+qualify_inst(not_reached, not_reached, !Info, !Specs).
+qualify_inst(free(_), _, !Info, !Specs) :-
unexpected(this_file, "compiler generated inst not expected").
-qualify_inst(bound(Uniq, BoundInsts0), bound(Uniq, BoundInsts), !Info, !IO) :-
- qualify_bound_inst_list(BoundInsts0, BoundInsts, !Info, !IO).
+qualify_inst(bound(Uniq, BoundInsts0), bound(Uniq, BoundInsts), !Info,
+ !Specs) :-
+ qualify_bound_inst_list(BoundInsts0, BoundInsts, !Info, !Specs).
qualify_inst(ground(Uniq, GroundInstInfo0), ground(Uniq, GroundInstInfo),
- !Info, !IO) :-
+ !Info, !Specs) :-
(
GroundInstInfo0 = higher_order(pred_inst_info(A, Modes0, Det)),
- qualify_mode_list(Modes0, Modes, !Info, !IO),
+ qualify_mode_list(Modes0, Modes, !Info, !Specs),
GroundInstInfo = higher_order(pred_inst_info(A, Modes, Det))
;
GroundInstInfo0 = none,
GroundInstInfo = none
).
-qualify_inst(inst_var(Var), inst_var(Var), !Info, !IO).
+qualify_inst(inst_var(Var), inst_var(Var), !Info, !Specs).
qualify_inst(constrained_inst_vars(Vars, Inst0),
- constrained_inst_vars(Vars, Inst), !Info, !IO) :-
- qualify_inst(Inst0, Inst, !Info, !IO).
-qualify_inst(defined_inst(InstName0), defined_inst(InstName), !Info, !IO) :-
- qualify_inst_name(InstName0, InstName, !Info, !IO).
+ constrained_inst_vars(Vars, Inst), !Info, !Specs) :-
+ qualify_inst(Inst0, Inst, !Info, !Specs).
+qualify_inst(defined_inst(InstName0), defined_inst(InstName), !Info, !Specs) :-
+ qualify_inst_name(InstName0, InstName, !Info, !Specs).
qualify_inst(abstract_inst(Name, Args0), abstract_inst(Name, Args), !Info,
- !IO) :-
- qualify_inst_list(Args0, Args, !Info, !IO).
+ !Specs) :-
+ qualify_inst_list(Args0, Args, !Info, !Specs).
% Find the unique inst_id that matches this inst, and qualify
% the argument insts.
%
:- pred qualify_inst_name(inst_name::in, inst_name::out,
- mq_info::in, mq_info::out, io::di, io::uo) is det.
+ mq_info::in, mq_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
qualify_inst_name(user_inst(SymName0, Insts0), user_inst(SymName, Insts),
- !Info, !IO) :-
- qualify_inst_list(Insts0, Insts, !Info, !IO),
+ !Info, !Specs) :-
+ qualify_inst_list(Insts0, Insts, !Info, !Specs),
(
% Check for a variable inst constructor.
SymName0 = unqualified("")
->
mq_info_get_error_context(!.Info, ErrorContext),
- report_invalid_user_inst(SymName0, Insts, ErrorContext, !IO),
+ report_invalid_user_inst(SymName0, Insts, ErrorContext, !Specs),
mq_info_set_error_flag(inst_id, !Info),
- mq_info_incr_errors(!Info),
SymName = SymName0
;
list.length(Insts0, Arity),
mq_info_get_insts(!.Info, InstIds),
find_unique_match(mq_id(SymName0, Arity), mq_id(SymName, _),
- InstIds, inst_id, !Info, !IO)
+ InstIds, inst_id, !Info, !Specs)
).
-qualify_inst_name(merge_inst(_, _), _, !Info, !IO) :-
+qualify_inst_name(merge_inst(_, _), _, !Info, !Specs) :-
unexpected(this_file, "compiler generated inst unexpected").
-qualify_inst_name(unify_inst(_, _, _, _), _, !Info, !IO) :-
+qualify_inst_name(unify_inst(_, _, _, _), _, !Info, !Specs) :-
unexpected(this_file, "compiler generated inst unexpected").
-qualify_inst_name(ground_inst(_, _, _, _), _, !Info, !IO) :-
+qualify_inst_name(ground_inst(_, _, _, _), _, !Info, !Specs) :-
unexpected(this_file, "compiler generated inst unexpected").
-qualify_inst_name(any_inst(_, _, _, _), _, !Info, !IO) :-
+qualify_inst_name(any_inst(_, _, _, _), _, !Info, !Specs) :-
unexpected(this_file, "compiler generated inst unexpected").
-qualify_inst_name(shared_inst(_), _, !Info, !IO) :-
+qualify_inst_name(shared_inst(_), _, !Info, !Specs) :-
unexpected(this_file, "compiler generated inst unexpected").
-qualify_inst_name(mostly_uniq_inst(_), _, !Info, !IO) :-
+qualify_inst_name(mostly_uniq_inst(_), _, !Info, !Specs) :-
unexpected(this_file, "compiler generated inst unexpected").
-qualify_inst_name(typed_ground(_, _), _, !Info, !IO) :-
+qualify_inst_name(typed_ground(_, _), _, !Info, !Specs) :-
unexpected(this_file, "compiler generated inst unexpected").
-qualify_inst_name(typed_inst(_, _), _, !Info, !IO) :-
+qualify_inst_name(typed_inst(_, _), _, !Info, !Specs) :-
unexpected(this_file, "compiler generated inst unexpected").
% Qualify an inst of the form bound(functor(...)).
%
:- pred qualify_bound_inst_list(list(bound_inst)::in, list(bound_inst)::out,
- mq_info::in, mq_info::out, io::di, io::uo) is det.
+ mq_info::in, mq_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
-qualify_bound_inst_list([], [], !Info, !IO).
+qualify_bound_inst_list([], [], !Info, !Specs).
qualify_bound_inst_list([bound_functor(ConsId, Insts0) | BoundInsts0],
- [bound_functor(ConsId, Insts) | BoundInsts], !Info, !IO) :-
+ [bound_functor(ConsId, Insts) | BoundInsts], !Info, !Specs) :-
( ConsId = cons(Name, Arity) ->
Id = item_name(Name, Arity),
update_recompilation_info(
@@ -987,51 +998,53 @@
;
true
),
- qualify_inst_list(Insts0, Insts, !Info, !IO),
- qualify_bound_inst_list(BoundInsts0, BoundInsts, !Info, !IO).
+ qualify_inst_list(Insts0, Insts, !Info, !Specs),
+ qualify_bound_inst_list(BoundInsts0, BoundInsts, !Info, !Specs).
:- pred qualify_constructor_arg_list(list(constructor_arg)::in,
list(constructor_arg)::out, mq_info::in, mq_info::out,
- io::di, io::uo) is det.
+ list(error_spec)::in, list(error_spec)::out) is det.
-qualify_constructor_arg_list([], [], !Info, !IO).
+qualify_constructor_arg_list([], [], !Info, !Specs).
qualify_constructor_arg_list([Name - Type0 | Args0], [Name - Type | Args],
- !Info, !IO) :-
- qualify_type(Type0, Type, !Info, !IO),
- qualify_constructor_arg_list(Args0, Args, !Info, !IO).
+ !Info, !Specs) :-
+ qualify_type(Type0, Type, !Info, !Specs),
+ qualify_constructor_arg_list(Args0, Args, !Info, !Specs).
:- pred qualify_type_list(list(mer_type)::in, list(mer_type)::out,
- mq_info::in, mq_info::out, io::di, io::uo) is det.
+ mq_info::in, mq_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
-qualify_type_list([], [], !Info, !IO).
-qualify_type_list([Type0 | Types0], [Type | Types], !Info, !IO) :-
- qualify_type(Type0, Type, !Info, !IO),
- qualify_type_list(Types0, Types, !Info, !IO).
+qualify_type_list([], [], !Info, !Specs).
+qualify_type_list([Type0 | Types0], [Type | Types], !Info, !Specs) :-
+ qualify_type(Type0, Type, !Info, !Specs),
+ qualify_type_list(Types0, Types, !Info, !Specs).
:- pred qualify_maybe_type(maybe(mer_type)::in, maybe(mer_type)::out,
- mq_info::in, mq_info::out, io::di, io::uo) is det.
+ mq_info::in, mq_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
-qualify_maybe_type(no, no, !Info, !IO).
-qualify_maybe_type(yes(Type0), yes(Type), !Info, !IO) :-
- qualify_type(Type0, Type, !Info, !IO).
+qualify_maybe_type(no, no, !Info, !Specs).
+qualify_maybe_type(yes(Type0), yes(Type), !Info, !Specs) :-
+ qualify_type(Type0, Type, !Info, !Specs).
% Qualify a type and its argument types.
%
:- pred qualify_type(mer_type::in, mer_type::out, mq_info::in, mq_info::out,
- io::di, io::uo) is det.
+ list(error_spec)::in, list(error_spec)::out) is det.
-qualify_type(type_variable(Var, Kind), type_variable(Var, Kind), !Info, !IO).
+qualify_type(type_variable(Var, Kind), type_variable(Var, Kind), !Info,
+ !Specs).
qualify_type(defined_type(SymName0, Args0, Kind),
- defined_type(SymName, Args, Kind), !Info, !IO) :-
+ defined_type(SymName, Args, Kind), !Info, !Specs) :-
Arity = list.length(Args0),
TypeCtorId0 = mq_id(SymName0, Arity),
mq_info_get_types(!.Info, Types),
- find_unique_match(TypeCtorId0, TypeCtorId, Types, type_id, !Info, !IO),
+ find_unique_match(TypeCtorId0, TypeCtorId, Types, type_id, !Info, !Specs),
TypeCtorId = mq_id(SymName, _),
- qualify_type_list(Args0, Args, !Info, !IO).
+ qualify_type_list(Args0, Args, !Info, !Specs).
qualify_type(builtin_type(BuiltinType), builtin_type(BuiltinType), !Info,
- !IO) :-
- %
+ !Specs) :-
% The types `int', `float', and `string' are builtin types, defined by
% the compiler, but arguably they ought to be defined in int.m, float.m,
% and string.m, and so if someone uses the type `int' in the interface,
@@ -1039,7 +1052,6 @@
% We don't do the same for `character', since the corresponding library
% module `char' will be flagged as used in the interface if the type
% `char' is used.
- %
(
BuiltinType = builtin_type_int,
mq_info_set_module_used(unqualified("int"), !Info)
@@ -1053,173 +1065,176 @@
BuiltinType = builtin_type_character
).
qualify_type(higher_order_type(Args0, MaybeRet0, Purity, EvalMethod),
- higher_order_type(Args, MaybeRet, Purity, EvalMethod), !Info, !IO) :-
- qualify_type_list(Args0, Args, !Info, !IO),
- qualify_maybe_type(MaybeRet0, MaybeRet, !Info, !IO).
-qualify_type(tuple_type(Args0, Kind), tuple_type(Args, Kind), !Info, !IO) :-
- qualify_type_list(Args0, Args, !Info, !IO).
+ higher_order_type(Args, MaybeRet, Purity, EvalMethod),
+ !Info, !Specs) :-
+ qualify_type_list(Args0, Args, !Info, !Specs),
+ qualify_maybe_type(MaybeRet0, MaybeRet, !Info, !Specs).
+qualify_type(tuple_type(Args0, Kind), tuple_type(Args, Kind), !Info, !Specs) :-
+ qualify_type_list(Args0, Args, !Info, !Specs).
qualify_type(apply_n_type(Var, Args0, Kind), apply_n_type(Var, Args, Kind),
- !Info, !IO) :-
- qualify_type_list(Args0, Args, !Info, !IO).
-qualify_type(kinded_type(Type0, Kind), kinded_type(Type, Kind), !Info, !IO) :-
- qualify_type(Type0, Type, !Info, !IO).
+ !Info, !Specs) :-
+ qualify_type_list(Args0, Args, !Info, !Specs).
+qualify_type(kinded_type(Type0, Kind), kinded_type(Type, Kind),
+ !Info, !Specs) :-
+ qualify_type(Type0, Type, !Info, !Specs).
% Qualify the modes in a pragma c_code(...) decl.
%
:- pred qualify_pragma((pragma_type)::in, (pragma_type)::out,
- mq_info::in, mq_info::out, io::di, io::uo) is det.
+ mq_info::in, mq_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
-qualify_pragma(X @ pragma_source_file(_), X, !Info, !IO).
-qualify_pragma(X @ pragma_foreign_decl(_, _, _), X, !Info, !IO).
-qualify_pragma(X @ pragma_foreign_code(_, _), X, !Info, !IO).
-qualify_pragma(X @ pragma_foreign_import_module(_, _), X, !Info, !IO).
-qualify_pragma(X, Y, !Info, !IO) :-
+qualify_pragma(X @ pragma_source_file(_), X, !Info, !Specs).
+qualify_pragma(X @ pragma_foreign_decl(_, _, _), X, !Info, !Specs).
+qualify_pragma(X @ pragma_foreign_code(_, _), X, !Info, !Specs).
+qualify_pragma(X @ pragma_foreign_import_module(_, _), X, !Info, !Specs).
+qualify_pragma(X, Y, !Info, !Specs) :-
X = pragma_foreign_proc(Attrs0, Name, PredOrFunc, Vars0, Varset,
InstVarset, Impl),
- qualify_pragma_vars(Vars0, Vars, !Info, !IO),
+ qualify_pragma_vars(Vars0, Vars, !Info, !Specs),
UserSharing0 = get_user_annotated_sharing(Attrs0),
- qualify_user_sharing(UserSharing0, UserSharing, !Info, !IO),
+ qualify_user_sharing(UserSharing0, UserSharing, !Info, !Specs),
set_user_annotated_sharing(UserSharing, Attrs0, Attrs),
Y = pragma_foreign_proc(Attrs, Name, PredOrFunc, Vars, Varset,
InstVarset, Impl).
-% qualify_pragma(X, Y, !Info, !IO) :-
- % PragmaVars0 = X ^ proc_vars,
- % qualify_pragma_vars(PragmaVars0, PragmaVars, !Info, !IO),
- % Y = X ^ proc_vars := PragmaVars.
-qualify_pragma(X, Y, !Info, !IO) :-
+qualify_pragma(X, Y, !Info, !Specs) :-
X = pragma_tabled(EvalMethod, Name, Arity, PredOrFunc, MModes0, Attrs),
(
MModes0 = yes(Modes0),
- qualify_mode_list(Modes0, Modes, !Info, !IO),
+ qualify_mode_list(Modes0, Modes, !Info, !Specs),
MModes = yes(Modes)
;
MModes0 = no,
MModes = no
),
Y = pragma_tabled(EvalMethod, Name, Arity, PredOrFunc, MModes, Attrs).
-qualify_pragma(X @ pragma_inline(_, _), X, !Info, !IO).
-qualify_pragma(X @ pragma_no_inline(_, _), X, !Info, !IO).
-qualify_pragma(X @ pragma_obsolete(_, _), X, !Info, !IO).
-qualify_pragma(X, Y, !Info, !IO) :-
+qualify_pragma(X @ pragma_inline(_, _), X, !Info, !Specs).
+qualify_pragma(X @ pragma_no_inline(_, _), X, !Info, !Specs).
+qualify_pragma(X @ pragma_obsolete(_, _), X, !Info, !Specs).
+qualify_pragma(X, Y, !Info, !Specs) :-
X = pragma_import(Name, PredOrFunc, Modes0, Attributes, CFunc),
- qualify_mode_list(Modes0, Modes, !Info, !IO),
+ qualify_mode_list(Modes0, Modes, !Info, !Specs),
Y = pragma_import(Name, PredOrFunc, Modes, Attributes, CFunc).
-qualify_pragma(X, Y, !Info, !IO) :-
+qualify_pragma(X, Y, !Info, !Specs) :-
X = pragma_foreign_export(Lang, Name, PredOrFunc, Modes0, CFunc),
- qualify_mode_list(Modes0, Modes, !Info, !IO),
+ qualify_mode_list(Modes0, Modes, !Info, !Specs),
Y = pragma_foreign_export(Lang, Name, PredOrFunc, Modes, CFunc).
-qualify_pragma(X @ pragma_unused_args(_, _, _, _, _), X, !Info, !IO).
-qualify_pragma(X @ pragma_exceptions(_, _, _, _, _), X, !Info, !IO).
-qualify_pragma(X @ pragma_trailing_info(_, _, _, _, _), X, !Info, !IO).
-qualify_pragma(X @ pragma_mm_tabling_info(_, _, _, _, _), X, !Info, !IO).
-qualify_pragma(X, Y, !Info, !IO) :-
+qualify_pragma(X @ pragma_unused_args(_, _, _, _, _), X, !Info, !Specs).
+qualify_pragma(X @ pragma_exceptions(_, _, _, _, _), X, !Info, !Specs).
+qualify_pragma(X @ pragma_trailing_info(_, _, _, _, _), X, !Info, !Specs).
+qualify_pragma(X @ pragma_mm_tabling_info(_, _, _, _, _), X, !Info, !Specs).
+qualify_pragma(X, Y, !Info, !Specs) :-
X = pragma_type_spec(A, B, C, D, MaybeModes0, Subst0, G, H),
(
MaybeModes0 = yes(Modes0),
- qualify_mode_list(Modes0, Modes, !Info, !IO),
+ qualify_mode_list(Modes0, Modes, !Info, !Specs),
MaybeModes = yes(Modes)
;
MaybeModes0 = no,
MaybeModes = no
),
- qualify_type_spec_subst(Subst0, Subst, !Info, !IO),
+ qualify_type_spec_subst(Subst0, Subst, !Info, !Specs),
Y = pragma_type_spec(A, B, C, D, MaybeModes, Subst, G, H).
-qualify_pragma(X @ pragma_fact_table(_, _, _), X, !Info, !IO).
-qualify_pragma(X @ pragma_reserve_tag(_, _), X, !Info, !IO).
-qualify_pragma(X @ pragma_promise_pure(_, _), X, !Info, !IO).
-qualify_pragma(X @ pragma_promise_semipure(_, _), X, !Info, !IO).
-qualify_pragma(X @ pragma_promise_equivalent_clauses(_, _), X, !Info, !IO).
-qualify_pragma(X, Y, !Info, !IO) :-
+qualify_pragma(X @ pragma_fact_table(_, _, _), X, !Info, !Specs).
+qualify_pragma(X @ pragma_reserve_tag(_, _), X, !Info, !Specs).
+qualify_pragma(X @ pragma_promise_pure(_, _), X, !Info, !Specs).
+qualify_pragma(X @ pragma_promise_semipure(_, _), X, !Info, !Specs).
+qualify_pragma(X @ pragma_promise_equivalent_clauses(_, _), X, !Info, !Specs).
+qualify_pragma(X, Y, !Info, !Specs) :-
X = pragma_termination_info(PredOrFunc, SymName, ModeList0, Args, Term),
- qualify_mode_list(ModeList0, ModeList, !Info, !IO),
+ qualify_mode_list(ModeList0, ModeList, !Info, !Specs),
Y = pragma_termination_info(PredOrFunc, SymName, ModeList, Args, Term).
-qualify_pragma(X, Y, !Info, !IO) :-
+qualify_pragma(X, Y, !Info, !Specs) :-
X = pragma_structure_sharing(PredOrFunc, SymName, ModeList0, Vars, Types,
Sharing),
- qualify_mode_list(ModeList0, ModeList, !Info, !IO),
+ qualify_mode_list(ModeList0, ModeList, !Info, !Specs),
Y = pragma_structure_sharing(PredOrFunc, SymName, ModeList, Vars, Types,
Sharing).
-qualify_pragma(X, Y, !Info, !IO) :-
+qualify_pragma(X, Y, !Info, !Specs) :-
X = pragma_structure_reuse(PredOrFunc, SymName, ModeList0, Vars, Types,
ReuseTuples),
- qualify_mode_list(ModeList0, ModeList, !Info, !IO),
+ qualify_mode_list(ModeList0, ModeList, !Info, !Specs),
Y = pragma_structure_reuse(PredOrFunc, SymName, ModeList, Vars, Types,
ReuseTuples).
-qualify_pragma(X, Y, !Info, !IO) :-
+qualify_pragma(X, Y, !Info, !Specs) :-
X = pragma_termination2_info(PredOrFunc, SymName, ModeList0,
SuccessArgs, FailureArgs, Term),
- qualify_mode_list(ModeList0, ModeList, !Info, !IO),
+ qualify_mode_list(ModeList0, ModeList, !Info, !Specs),
Y = pragma_termination2_info(PredOrFunc, SymName, ModeList,
SuccessArgs, FailureArgs, Term).
-qualify_pragma(X @ pragma_terminates(_, _), X, !Info, !IO).
-qualify_pragma(X @ pragma_does_not_terminate(_, _), X, !Info, !IO).
-qualify_pragma(X @ pragma_check_termination(_, _), X, !Info, !IO).
-qualify_pragma(X @ pragma_mode_check_clauses(_, _), X, !Info, !IO).
+qualify_pragma(X @ pragma_terminates(_, _), X, !Info, !Specs).
+qualify_pragma(X @ pragma_does_not_terminate(_, _), X, !Info, !Specs).
+qualify_pragma(X @ pragma_check_termination(_, _), X, !Info, !Specs).
+qualify_pragma(X @ pragma_mode_check_clauses(_, _), X, !Info, !Specs).
:- pred qualify_pragma_vars(list(pragma_var)::in, list(pragma_var)::out,
- mq_info::in, mq_info::out, io::di, io::uo) is det.
+ mq_info::in, mq_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
-qualify_pragma_vars([], [], !Info, !IO).
+qualify_pragma_vars([], [], !Info, !Specs).
qualify_pragma_vars([pragma_var(Var, Name, Mode0, Box) | PragmaVars0],
- [pragma_var(Var, Name, Mode, Box) | PragmaVars], !Info, !IO) :-
- qualify_mode(Mode0, Mode, !Info, !IO),
- qualify_pragma_vars(PragmaVars0, PragmaVars, !Info, !IO).
+ [pragma_var(Var, Name, Mode, Box) | PragmaVars], !Info, !Specs) :-
+ qualify_mode(Mode0, Mode, !Info, !Specs),
+ qualify_pragma_vars(PragmaVars0, PragmaVars, !Info, !Specs).
:- pred qualify_type_spec_subst(assoc_list(tvar, mer_type)::in,
assoc_list(tvar, mer_type)::out, mq_info::in, mq_info::out,
- io::di, io::uo) is det.
+ list(error_spec)::in, list(error_spec)::out) is det.
-qualify_type_spec_subst([], [], !Info, !IO).
+qualify_type_spec_subst([], [], !Info, !Specs).
qualify_type_spec_subst([Var - Type0 | Subst0], [Var - Type | Subst],
- !Info, !IO) :-
- qualify_type(Type0, Type, !Info, !IO),
- qualify_type_spec_subst(Subst0, Subst, !Info, !IO).
+ !Info, !Specs) :-
+ qualify_type(Type0, Type, !Info, !Specs),
+ qualify_type_spec_subst(Subst0, Subst, !Info, !Specs).
:- pred qualify_prog_constraints(prog_constraints::in,
prog_constraints::out, mq_info::in, mq_info::out,
- io::di, io::uo) is det.
+ list(error_spec)::in, list(error_spec)::out) is det.
qualify_prog_constraints(constraints(UnivCs0, ExistCs0),
- constraints(UnivCs, ExistCs), !Info, !IO) :-
- qualify_prog_constraint_list(UnivCs0, UnivCs, !Info, !IO),
- qualify_prog_constraint_list(ExistCs0, ExistCs, !Info, !IO).
+ constraints(UnivCs, ExistCs), !Info, !Specs) :-
+ qualify_prog_constraint_list(UnivCs0, UnivCs, !Info, !Specs),
+ qualify_prog_constraint_list(ExistCs0, ExistCs, !Info, !Specs).
:- pred qualify_prog_constraint_list(list(prog_constraint)::in,
list(prog_constraint)::out, mq_info::in, mq_info::out,
- io::di, io::uo) is det.
+ list(error_spec)::in, list(error_spec)::out) is det.
-qualify_prog_constraint_list([], [], !Info, !IO).
-qualify_prog_constraint_list([C0 | C0s], [C | Cs], !Info, !IO) :-
- qualify_prog_constraint(C0, C, !Info, !IO),
- qualify_prog_constraint_list(C0s, Cs, !Info, !IO).
+qualify_prog_constraint_list([], [], !Info, !Specs).
+qualify_prog_constraint_list([C0 | C0s], [C | Cs], !Info, !Specs) :-
+ qualify_prog_constraint(C0, C, !Info, !Specs),
+ qualify_prog_constraint_list(C0s, Cs, !Info, !Specs).
:- pred qualify_prog_constraint(prog_constraint::in, prog_constraint::out,
- mq_info::in, mq_info::out, io::di, io::uo) is det.
+ mq_info::in, mq_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
qualify_prog_constraint(constraint(ClassName0, Types0),
- constraint(ClassName, Types), !Info, !IO) :-
+ constraint(ClassName, Types), !Info, !Specs) :-
list.length(Types0, Arity),
qualify_class_name(mq_id(ClassName0, Arity), mq_id(ClassName, _),
- !Info, !IO),
- qualify_type_list(Types0, Types, !Info, !IO).
+ !Info, !Specs),
+ qualify_type_list(Types0, Types, !Info, !Specs).
:- pred qualify_class_name(mq_id::in, mq_id::out, mq_info::in, mq_info::out,
- io::di, io::uo) is det.
+ list(error_spec)::in, list(error_spec)::out) is det.
-qualify_class_name(Class0, Class, !Info, !IO) :-
+qualify_class_name(Class0, Class, !Info, !Specs) :-
mq_info_get_classes(!.Info, ClassIdSet),
- find_unique_match(Class0, Class, ClassIdSet, class_id, !Info, !IO).
+ find_unique_match(Class0, Class, ClassIdSet, class_id, !Info, !Specs).
:- pred qualify_class_interface(class_methods::in, class_methods::out,
- mq_info::in, mq_info::out, io::di, io::uo) is det.
+ mq_info::in, mq_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
-qualify_class_interface([], [], !Info, !IO).
-qualify_class_interface([M0 | M0s], [M | Ms], !Info, !IO) :-
- qualify_class_method(M0, M, !Info, !IO),
- qualify_class_interface(M0s, Ms, !Info, !IO).
+qualify_class_interface([], [], !Info, !Specs).
+qualify_class_interface([M0 | M0s], [M | Ms], !Info, !Specs) :-
+ qualify_class_method(M0, M, !Info, !Specs),
+ qualify_class_interface(M0s, Ms, !Info, !Specs).
:- pred qualify_class_method(class_method::in, class_method::out,
- mq_info::in, mq_info::out, io::di, io::uo) is det.
+ mq_info::in, mq_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
% There is no need to qualify the method name, since that is
% done when the item is parsed.
@@ -1230,19 +1245,19 @@
method_pred_or_func(TypeVarset, InstVarset, ExistQVars, PredOrFunc,
Name, TypesAndModes, WithType, WithInst, MaybeDet,
Cond, Purity, ClassContext, Context),
- !Info, !IO) :-
- qualify_types_and_modes(TypesAndModes0, TypesAndModes, !Info, !IO),
- qualify_prog_constraints(ClassContext0, ClassContext, !Info, !IO),
- map_fold2_maybe(qualify_type, WithType0, WithType, !Info, !IO),
- map_fold2_maybe(qualify_inst, WithInst0, WithInst, !Info, !IO).
+ !Info, !Specs) :-
+ qualify_types_and_modes(TypesAndModes0, TypesAndModes, !Info, !Specs),
+ qualify_prog_constraints(ClassContext0, ClassContext, !Info, !Specs),
+ map_fold2_maybe(qualify_type, WithType0, WithType, !Info, !Specs),
+ map_fold2_maybe(qualify_inst, WithInst0, WithInst, !Info, !Specs).
qualify_class_method(
method_pred_or_func_mode(Varset, PredOrFunc, Name, Modes0,
WithInst0, MaybeDet, Cond, Context),
method_pred_or_func_mode(Varset, PredOrFunc, Name, Modes,
WithInst, MaybeDet, Cond, Context),
- !Info, !IO) :-
- qualify_mode_list(Modes0, Modes, !Info, !IO),
- map_fold2_maybe(qualify_inst, WithInst0, WithInst, !Info, !IO).
+ !Info, !Specs) :-
+ qualify_mode_list(Modes0, Modes, !Info, !Specs),
+ map_fold2_maybe(qualify_inst, WithInst0, WithInst, !Info, !Specs).
:- pred qualify_instance_body(sym_name::in, instance_body::in,
instance_body::out) is det.
@@ -1292,10 +1307,10 @@
% class_ids have the same representation.
%
:- pred find_unique_match(mq_id::in, mq_id::out, id_set::in, id_type::in,
- mq_info::in, mq_info::out, io::di, io::uo) is det.
-
-find_unique_match(Id0, Id, Ids, TypeOfId, !Info, !IO) :-
+ mq_info::in, mq_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
+find_unique_match(Id0, Id, Ids, TypeOfId, !Info, !Specs) :-
% Find all IDs which match the current id.
Id0 = mq_id(SymName0, Arity),
mq_info_get_modules(!.Info, Modules),
@@ -1316,9 +1331,8 @@
% No matches for this id.
Id = Id0,
( mq_info_get_report_error_flag(!.Info, yes) ->
- report_undefined(MatchingModules0, !.Info, Id0, TypeOfId, !IO),
- mq_info_set_error_flag(TypeOfId, !Info),
- mq_info_incr_errors(!Info)
+ report_undefined(MatchingModules0, !.Info, Id0, TypeOfId, !Specs),
+ mq_info_set_error_flag(TypeOfId, !Info)
;
true
)
@@ -1341,9 +1355,8 @@
( mq_info_get_report_error_flag(!.Info, yes) ->
mq_info_get_error_context(!.Info, ErrorContext),
report_ambiguous_match(ErrorContext, Id0, TypeOfId,
- MatchingModules, !IO),
- mq_info_set_error_flag(TypeOfId, !Info),
- mq_info_incr_errors(!Info)
+ MatchingModules, !Specs),
+ mq_info_set_error_flag(TypeOfId, !Info)
;
true
)
@@ -1372,22 +1385,23 @@
:- pred qualify_user_sharing(user_annotated_sharing::in,
user_annotated_sharing::out, mq_info::in, mq_info::out,
- io::di, io::uo) is det.
+ list(error_spec)::in, list(error_spec)::out) is det.
-qualify_user_sharing(!UserSharing, !Info, !IO) :-
+qualify_user_sharing(!UserSharing, !Info, !Specs) :-
(
!.UserSharing = no_user_annotated_sharing
;
!.UserSharing = user_sharing(Sharing, MaybeTypes0),
(
MaybeTypes0 = yes(user_type_info(Types0, TVarset)),
- qualify_type_list(Types0, Types, !Info, !IO),
+ qualify_type_list(Types0, Types, !Info, !Specs),
MaybeTypes = yes(user_type_info(Types, TVarset)),
!:UserSharing = user_sharing(Sharing, MaybeTypes)
;
MaybeTypes0 = no
)
).
+
%-----------------------------------------------------------------------------%
:- type id_type
@@ -1421,14 +1435,12 @@
% Report an undefined type, inst or mode.
%
-:- pred report_undefined(list(module_name)::in, mq_info::in,
- mq_id::in, id_type::in, io::di, io::uo) is det.
+:- pred report_undefined(list(module_name)::in, mq_info::in, mq_id::in,
+ id_type::in, list(error_spec)::in, list(error_spec)::out) is det.
-report_undefined(MatchingModules, Info, Id, IdType, !IO) :-
+report_undefined(MatchingModules, Info, Id, IdType, !Specs) :-
mq_info_get_error_context(Info, ErrorContext - Context),
id_type_to_string(IdType, IdStr),
- io.set_exit_status(1, !IO),
-
Pieces1 = [words("In")] ++ mq_error_context_to_pieces(ErrorContext) ++
[suffix(":"), nl, words("error: undefined"), fixed(IdStr),
sym_name_and_arity(id_to_sym_name_and_arity(Id)),
@@ -1460,38 +1472,34 @@
MatchingSymNames = list.map(wrap_module_name, MatchingModules),
Pieces2 = [words("(The"), fixed(ModuleWord)] ++
component_list_to_pieces(MatchingSymNames) ++
- [fixed(HasWord), words("not been imported in the interface.)")]
+ [fixed(HasWord), words("not been imported in the interface.)"), nl]
;
Pieces2 = []
),
- write_error_pieces(Context, 0, Pieces1 ++ Pieces2, !IO).
+ Msg = simple_msg(Context, [always(Pieces1 ++ Pieces2)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
+ !:Specs = [Spec | !.Specs].
% Report an error where a type, inst, mode or typeclass had
% multiple possible matches.
%
:- pred report_ambiguous_match(error_context::in, mq_id::in, id_type::in,
- list(module_name)::in, io::di, io::uo) is det.
+ list(module_name)::in, list(error_spec)::in, list(error_spec)::out) is det.
-report_ambiguous_match(ErrorContext - Context, Id, IdType, Modules, !IO) :-
+report_ambiguous_match(ErrorContext - Context, Id, IdType, Modules, !Specs) :-
id_type_to_string(IdType, IdStr),
ModuleNames = list.map(wrap_module_name, Modules),
- Pieces1 = [words("In")] ++ mq_error_context_to_pieces(ErrorContext) ++
+ MainPieces = [words("In")] ++ mq_error_context_to_pieces(ErrorContext) ++
[words("ambiguity error: multiple possible matches for"),
fixed(IdStr), wrap_id(Id), suffix("."), nl,
words("The possible matches are in modules")] ++ ModuleNames ++
[suffix("."), nl],
- globals.io_lookup_bool_option(verbose_errors, Verbose, !IO),
- (
- Verbose = yes,
- Pieces2 = [words("An explicit module qualifier"),
- words("may be necessary."), nl]
- ;
- Verbose = no,
- globals.io_set_extra_error_info(yes, !IO),
- Pieces2 = []
- ),
- write_error_pieces(Context, 0, Pieces1 ++ Pieces2, !IO),
- io.set_exit_status(1, !IO).
+ VerbosePieces = [words("An explicit module qualifier"),
+ words("may be necessary."), nl],
+ Msg = simple_msg(Context,
+ [always(MainPieces), verbose_only(VerbosePieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
+ !:Specs = [Spec | !.Specs].
% Give a context for the current error message.
%
@@ -1550,38 +1558,31 @@
id_type_to_string(inst_id, "inst").
id_type_to_string(class_id, "typeclass").
- % Warn about modules imported in the interface when they do not
- % need to be.
-:- pred maybe_warn_unused_interface_imports(module_name::in,
- list(module_name)::in, io::di, io::uo) is det.
+ % Warn about modules imported in the interface when they do not need to be.
+ %
+:- pred maybe_warn_unused_interface_imports(module_name::in, string::in,
+ list(module_name)::in, list(error_spec)::in, list(error_spec)::out) is det.
-maybe_warn_unused_interface_imports(ModuleName, UnusedImports, !IO) :-
- globals.io_lookup_bool_option(warn_interface_imports, Warn, !IO),
+maybe_warn_unused_interface_imports(ModuleName, FileName, UnusedImports,
+ !Specs) :-
(
- ( UnusedImports = []
- ; Warn = no
- )
- ->
- true
+ UnusedImports = []
;
- module_name_to_file_name(ModuleName, ".m", no, FileName, !IO),
+ UnusedImports = [_ | _],
term.context_init(FileName, 1, Context),
- ( UnusedImports = [_] ->
- ModuleWord = "module"
- ;
- ModuleWord = "modules"
- ),
UnusedSymNames = list.map(wrap_module_name, UnusedImports),
- is_or_are(UnusedImports, IsOrAre),
- Pieces = [words("In module"), sym_name(ModuleName),
- suffix(":"), nl,
- words("warning:"), words(ModuleWord)] ++
+ Pieces = [words("In module"), sym_name(ModuleName), suffix(":"), nl,
+ words("warning:"),
+ words(choose_number(UnusedImports, "module", "modules"))] ++
component_list_to_pieces(UnusedSymNames) ++
- [fixed(IsOrAre), words("imported in the interface,"),
- words("but"), fixed(IsOrAre),
+ [words(choose_number(UnusedImports, "is", "are")),
+ words("imported in the interface,"),
+ words("but"), words(choose_number(UnusedImports, "is", "are")),
words("not used in the interface.")],
- write_error_pieces(Context, 0, Pieces, !IO),
- record_warning(!IO)
+ Msg = simple_msg(Context,
+ [option_is_set(warn_interface_imports, yes, [always(Pieces)])]),
+ Spec = error_spec(severity_warning, phase_parse_tree_to_hlds, [Msg]),
+ !:Specs = [Spec | !.Specs]
).
:- func wrap_module_name(module_name) = format_component.
@@ -1592,28 +1593,24 @@
wrap_id(mq_id(Name, Arity)) = sym_name_and_arity(Name / Arity).
-:- pred is_or_are(list(T)::in, string::out) is det.
-
-is_or_are([], "") :- unexpected(this_file, "module_qual:is_or_are").
-is_or_are([_], "is").
-is_or_are([_, _ | _], "are").
-
% Output an error message about an ill-formed user_inst.
%
:- pred report_invalid_user_inst(sym_name::in, list(mer_inst)::in,
- error_context::in, io::di, io::uo) is det.
+ error_context::in, list(error_spec)::in, list(error_spec)::out) is det.
-report_invalid_user_inst(_SymName, _Insts, ErrorContext - Context, !IO) :-
+report_invalid_user_inst(_SymName, _Insts, ErrorContext - Context, !Specs) :-
ContextPieces = mq_error_context_to_pieces(ErrorContext),
Pieces = [words("In")] ++ ContextPieces ++ [suffix(":"), nl,
- words("error: variable used as inst constructor.")],
- write_error_pieces(Context, 0, Pieces, !IO),
- io.set_exit_status(1, !IO).
+ words("error: variable used as inst constructor."), nl],
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
+ !:Specs = [Spec | !.Specs].
%-----------------------------------------------------------------------------%
- % is_builtin_atomic_type(TypeCtor)
- % is true iff 'TypeCtor' is the type_ctor of a builtin atomic type
+ % is_builtin_atomic_type(TypeCtor):
+ %
+ % Succeeds iff 'TypeCtor' is the type_ctor of a builtin atomic type.
%
:- pred is_builtin_atomic_type(type_ctor::in) is semidet.
@@ -1670,7 +1667,6 @@
:- pred mq_info_get_unused_interface_modules(mq_info::in,
set(module_name)::out) is det.
:- pred mq_info_get_import_status(mq_info::in, mq_import_status::out) is det.
-% :- pred mq_info_get_num_errors(mq_info::in, int::out) is det.
% :- pred mq_info_get_type_error_flag(mq_info::in, bool::out) is det.
% :- pred mq_info_get_mode_error_flag(mq_info::in, bool::out) is det.
:- pred mq_info_get_report_error_flag(mq_info::in, bool::out) is det.
@@ -1686,7 +1682,6 @@
mq_info_get_classes(Info, Info ^ classes).
mq_info_get_unused_interface_modules(Info, Info ^ unused_interface_modules).
mq_info_get_import_status(Info, Info ^ import_status).
-mq_info_get_num_errors(Info, Info ^ num_errors).
mq_info_get_type_error_flag(Info, Info ^ type_error_flag).
mq_info_get_mode_error_flag(Info, Info ^ mode_error_flag).
mq_info_get_report_error_flag(Info, Info ^ report_error_flag).
@@ -1739,10 +1734,6 @@
mq_info_set_recompilation_info(RecompInfo, Info,
Info ^ maybe_recompilation_info := RecompInfo).
-:- pred mq_info_incr_errors(mq_info::in, mq_info::out) is det.
-
-mq_info_incr_errors(Info, Info ^ num_errors := (Info ^ num_errors +1)).
-
:- pred mq_info_set_error_flag(id_type::in, mq_info::in, mq_info::out) is det.
mq_info_set_error_flag(IdType, !Info) :-
Index: compiler/modules.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/modules.m,v
retrieving revision 1.401
diff -u -b -r1.401 modules.m
--- compiler/modules.m 7 Sep 2006 05:51:01 -0000 1.401
+++ compiler/modules.m 9 Sep 2006 03:39:19 -0000
@@ -44,6 +44,7 @@
:- import_module libs.globals.
:- 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.
@@ -439,7 +440,7 @@
% interfaces.
%
:- pred split_into_submodules(module_name::in, item_list::in, module_list::out,
- io::di, io::uo) is det.
+ list(error_spec)::in, list(error_spec)::out) is det.
%-----------------------------------------------------------------------------%
@@ -788,7 +789,6 @@
:- import_module libs.handle_options.
:- import_module libs.options.
:- import_module make. % XXX undesirable dependency
-:- import_module parse_tree.error_util.
:- import_module parse_tree.mercury_to_mercury.
:- import_module parse_tree.module_qual.
:- import_module parse_tree.prog_foreign.
@@ -804,6 +804,7 @@
:- import_module char.
:- import_module dir.
:- import_module getopt_io.
+:- import_module int.
:- import_module library.
:- import_module multi_map.
:- import_module solutions.
@@ -1250,42 +1251,42 @@
MaybeTimestamp, Items0, !IO) :-
grab_unqual_imported_modules(SourceFileName, SourceFileModuleName,
ModuleName, Items0, Module, Error, !IO),
- %
- % Check whether we succeeded
- %
+
+ % Check whether we succeeded.
% XXX zs: why does this code not check for fatal_module_errors?
( Error = some_module_errors ->
module_name_to_file_name(ModuleName, ".int0", no, FileName, !IO),
io.write_strings(["Error reading interface files.\n",
"`", FileName, "' not written.\n"], !IO)
;
- %
% Module-qualify all items.
- %
module_imports_get_items(Module, Items1),
- module_qual.module_qualify_items(Items1, Items2, ModuleName, yes,
- _, _, _, _, !IO),
- io.get_exit_status(Status, !IO),
- ( Status \= 0 ->
- module_name_to_file_name(ModuleName, ".int0", no, FileName, !IO),
+ globals.io_get_globals(Globals, !IO),
+ module_name_to_file_name(ModuleName, ".m", no, FileName, !IO),
+ module_qualify_items(Items1, Items2, Globals, ModuleName,
+ yes(FileName), _, _, _, [], Specs),
+ (
+ Specs = [_ | _],
+ sort_error_specs(Specs, SortedSpecs),
+ write_error_specs(SortedSpecs, 0, _NumWarnings, 0, _NumErrors,
+ !IO),
io.write_strings(["`", FileName, "' not written.\n"], !IO)
;
- %
+ Specs = [],
+
% Write out the `.int0' file.
%
- % XXX The following sequence of operations relies
- % on the fact that any reversals done while processing
- % it are undone by subsequent operations. Also, we
- % should sort the contents of the .int0 file as we
- % do for the other types of interface file. We don't
- % do that at the moment because the code for doing
- % that cannot handle the structure of lists of items
- % that represent private interfaces.
- %
+ % XXX The following sequence of operations relies on the fact that
+ % any reversals done while processing it are undone by subsequent
+ % operations. Also, we should sort the contents of the .int0 file
+ % as we do for the other types of interface file. We don't do that
+ % at the moment because the code for doing that cannot handle
+ % the structure of lists of items that represent private
+ % interfaces.
+
strip_imported_items(Items2, [], Items3),
strip_clauses_from_interface(Items3, Items4),
- handle_mutables_in_private_interface(ModuleName,
- Items4, Items5),
+ handle_mutables_in_private_interface(ModuleName, Items4, Items5),
MakeAbs = (pred(Item0::in, Item::out) is det :-
Item0 = Item1 - Context,
( make_abstract_instance(Item1, Item2) ->
@@ -1355,23 +1356,20 @@
%-----------------------------------------------------------------------------%
- % Read in the .int3 files that the current module depends on,
- % and use these to qualify all items in the interface as much as
- % possible. Then write out the .int and .int2 files.
+ % Read in the .int3 files that the current module depends on, and use these
+ % to qualify all items in the interface as much as possible. Then write out
+ % the .int and .int2 files.
%
make_interface(SourceFileName, SourceFileModuleName, ModuleName,
MaybeTimestamp, Items0, !IO) :-
some [!InterfaceItems] (
get_interface(ModuleName, yes, Items0, !:InterfaceItems),
- %
- % Get the .int3 files for imported modules
- %
+
+ % Get the .int3 files for imported modules.
grab_unqual_imported_modules(SourceFileName, SourceFileModuleName,
ModuleName, !.InterfaceItems, Module0, Error, !IO),
- %
- % Check whether we succeeded
- %
+ % Check whether we succeeded.
module_imports_get_items(Module0, !:InterfaceItems),
% XXX zs: why does this code not check for fatal_module_errors?
( Error = some_module_errors ->
@@ -1382,26 +1380,29 @@
"`", IntFileName, "' and ",
"`", Int2FileName, "' not written.\n"], !IO)
;
- %
% Module-qualify all items.
- %
- module_qual.module_qualify_items(!InterfaceItems, ModuleName, yes,
- _, _, _, _, !IO),
- io.get_exit_status(Status, !IO),
- ( Status \= 0 ->
+ globals.io_get_globals(Globals, !IO),
+ module_name_to_file_name(ModuleName, ".m", no, FileName, !IO),
+ module_qualify_items(!InterfaceItems, Globals, ModuleName,
+ yes(FileName), _, _, _, [], Specs),
+
+ % We want to finish writing the interface file (and keep
+ % the exit status at zero) if we found some warnings.
+ globals.io_set_option(halt_at_warn, bool(no), !IO),
+ sort_error_specs(Specs, SortedSpecs),
+ write_error_specs(SortedSpecs, 0, _NumWarnings, 0, NumErrors,
+ !IO),
+ ( NumErrors > 0 ->
module_name_to_file_name(ModuleName, ".int", no, IntFileName,
!IO),
io.write_strings(["`", IntFileName, "' ", "not written.\n"],
!IO)
;
- %
- % Strip out the imported interfaces,
- % assertions are also stripped since they should
- % only be written to .opt files,
- % check for some warnings, and then
- % write out the `.int' and `int2' files
- % and touch the `.date' file.
- %
+ % Strip out the imported interfaces, assertions are also
+ % stripped since they should only be written to .opt files,
+ % check for some warnings, and then write out the `.int'
+ % and `int2' files and touch the `.date' file.
+
strip_imported_items(!.InterfaceItems, [], !:InterfaceItems),
strip_assertions(!InterfaceItems),
strip_unnecessary_impl_defns(!InterfaceItems),
@@ -1418,17 +1419,23 @@
)
).
- % This qualifies everything as much as it can given the
- % information in the current module and writes out the .int3 file.
make_short_interface(SourceFileName, ModuleName, Items0, !IO) :-
+ % This qualifies everything as much as it can given the information
+ % in the current module and writes out the .int3 file.
+
get_interface(ModuleName, no, Items0, InterfaceItems0),
- % assertions are also stripped since they should
- % only be written to .opt files,
+ % Assertions are also stripped since they should only be written
+ % to .opt files,
strip_assertions(InterfaceItems0, InterfaceItems1),
check_for_clauses_in_interface(InterfaceItems1, InterfaceItems, !IO),
get_short_interface(InterfaceItems, int3, ShortInterfaceItems0),
- module_qual.module_qualify_items(ShortInterfaceItems0,
- ShortInterfaceItems, ModuleName, no, _, _, _, _, !IO),
+ globals.io_get_globals(Globals, !IO),
+ module_qualify_items(ShortInterfaceItems0, ShortInterfaceItems,
+ Globals, ModuleName, no, _, _, _, [], Specs),
+ sort_error_specs(Specs, SortedSpecs),
+ write_error_specs(SortedSpecs, 0, _NumWarnings, 0, _NumErrors,
+ !IO),
+ % XXX why do we do this even if there are some errors?
write_interface_file(SourceFileName, ModuleName, ".int3",
no, ShortInterfaceItems, !IO),
touch_interface_datestamp(ModuleName, ".date3", !IO).
@@ -1458,7 +1465,7 @@
strip_assertions([], []).
strip_assertions([Item - Context | Rest], Items) :-
- ( Item = item_promise(true, _, _, _) ->
+ ( Item = item_promise(promise_type_true, _, _, _) ->
strip_assertions(Rest, Items)
;
strip_assertions(Rest, Items0),
@@ -1470,17 +1477,6 @@
:- pred strip_unnecessary_impl_defns(item_list::in, item_list::out) is det.
strip_unnecessary_impl_defns(Items0, Items) :-
- % strip_unnecessary_impl_defns_2 is cc_multi because of the call
- % to std_util.unsorted_aggregate. The order in which items are deleted
- % from a multi_map does not matter.
- promise_equivalent_solutions [Items] (
- strip_unnecessary_impl_defns_2(Items0, Items)
- ).
-
-:- pred strip_unnecessary_impl_defns_2(item_list::in, item_list::out)
- is cc_multi.
-
-strip_unnecessary_impl_defns_2(Items0, Items) :-
some [!IntTypesMap, !ImplTypesMap, !ImplItems] (
gather_type_defns(no, Items0, [], IntItems0, [], !:ImplItems,
map.init, !:IntTypesMap, map.init, !:ImplTypesMap),
@@ -1499,7 +1495,8 @@
% If there is an exported type declaration for a type with an abstract
% declaration in the implementation (usually it will originally
% have been a d.u. type), remove the declaration in the implementation.
- solutions.unsorted_aggregate(
+
+ FindAbstractExportedTypes =
(pred(TypeCtor::out) is nondet :-
map.member(!.ImplTypesMap, TypeCtor, Defns),
\+ (
@@ -1508,21 +1505,26 @@
),
multi_map.contains(!.IntTypesMap, TypeCtor)
),
+ solutions(FindAbstractExportedTypes, AbstractExportedTypes),
+ RemoveFromImplTypesMap =
(pred(TypeCtor::in, !.ImplTypesMap::in, !:ImplTypesMap::out)
is det :-
multi_map.delete(!.ImplTypesMap, TypeCtor, !:ImplTypesMap)
),
+ list.foldl(RemoveFromImplTypesMap, AbstractExportedTypes,
!ImplTypesMap),
- map.foldl(
- (pred(_::in, Defns::in, !.ImplItems::in, !:ImplItems::out)
- is det :-
- list.foldl(
+ AddProjectedItem =
(pred((_ - Item)::in, !.ImplItems::in, !:ImplItems::out)
is det :-
!:ImplItems = [Item | !.ImplItems]
- ), Defns, !ImplItems)
- ), !.ImplTypesMap, !ImplItems),
+ ),
+ AddProjectedItems =
+ (pred(_::in, Defns::in, !.ImplItems::in, !:ImplItems::out)
+ is det :-
+ list.foldl(AddProjectedItem, Defns, !ImplItems)
+ ),
+ map.foldl(AddProjectedItems, !.ImplTypesMap, !ImplItems),
IntItems = [make_pseudo_decl(md_interface) | IntItems0],
@@ -1600,47 +1602,24 @@
"non-singleton-module use")
)
;
- ModuleDefn = md_module(_),
- !:Unexpected = yes
- ;
- ModuleDefn = md_end_module(_),
- !:Unexpected = yes
- ;
- ModuleDefn = md_imported(_),
- !:Unexpected = yes
- ;
- ModuleDefn = md_used(_),
- !:Unexpected = yes
- ;
- ModuleDefn = md_abstract_imported,
- !:Unexpected = yes
- ;
- ModuleDefn = md_opt_imported,
- !:Unexpected = yes
- ;
- ModuleDefn = md_transitively_imported,
- !:Unexpected = yes
- ;
- ModuleDefn = md_external(_, _),
- !:Unexpected = yes
- ;
- ModuleDefn = md_export(_),
+ ( ModuleDefn = md_module(_)
+ ; ModuleDefn = md_end_module(_)
+ ; ModuleDefn = md_imported(_)
+ ; ModuleDefn = md_used(_)
+ ; ModuleDefn = md_abstract_imported
+ ; ModuleDefn = md_opt_imported
+ ; ModuleDefn = md_transitively_imported
+ ; ModuleDefn = md_external(_, _)
+ ; ModuleDefn = md_export(_)
+ ; ModuleDefn = md_interface
+ ; ModuleDefn = md_implementation
+ ; ModuleDefn = md_private_interface
+ ; ModuleDefn = md_version_numbers(_, _)
+ ),
!:Unexpected = yes
;
ModuleDefn = md_include_module(_),
!:RevRemainderItems = [ItemAndContext | !.RevRemainderItems]
- ;
- ModuleDefn = md_interface,
- !:Unexpected = yes
- ;
- ModuleDefn = md_implementation,
- !:Unexpected = yes
- ;
- ModuleDefn = md_private_interface,
- !:Unexpected = yes
- ;
- ModuleDefn = md_version_numbers(_, _),
- !:Unexpected = yes
)
; Item = item_type_defn(_, _, _, _, _) ->
insert_type_defn(Context, Item, !TypeDefnItems)
@@ -2427,17 +2406,21 @@
get_dependencies(Items0, IntImportedModules0, IntUsedModules0,
ImpImportedModules0, ImpUsedModules0),
- list.append(IntImportedModules0, ImpImportedModules0, ImportedModules0),
- list.append(IntUsedModules0, ImpUsedModules0, UsedModules0),
+ ImportedModules0 = IntImportedModules0 ++ ImpImportedModules0,
+ UsedModules0 = IntUsedModules0 ++ ImpUsedModules0,
+
+ some [!Specs] (
+ !:Specs = [],
- warn_if_import_self_or_ancestor(ModuleName, AncestorModules,
- ImportedModules0, UsedModules0, !IO),
+ module_name_to_file_name(ModuleName, ".m", no, FileName, !IO),
+ warn_if_import_self_or_ancestor(ModuleName, FileName, AncestorModules,
+ ImportedModules0, UsedModules0, !Specs),
- warn_if_duplicate_use_import_decls(ModuleName,
+ warn_if_duplicate_use_import_decls(ModuleName, FileName,
IntImportedModules0, IntImportedModules1,
IntUsedModules0, IntUsedModules1,
ImpImportedModules0, ImpImportedModules,
- ImpUsedModules0, ImpUsedModules, !IO),
+ ImpUsedModules0, ImpUsedModules, !Specs),
get_fact_table_dependencies(Items0, FactDeps),
get_interface_and_implementation(ModuleName, no, Items0,
@@ -2458,9 +2441,9 @@
% If this module has any separately-compiled sub-modules, then
% we need to make everything in the implementation of this module
- % exported_to_submodules. We do that by splitting out the implementation
- % declarations and putting them in a special `:- private_interface'
- % section.
+ % exported_to_submodules. We do that by splitting out the
+ % implementation declarations and putting them in a special
+ % `:- private_interface' section.
%
get_children(Items0, Children),
(
@@ -2488,7 +2471,8 @@
% module qualifiers. Modules imported by ancestors are considered
% to be visible in the current module.
process_module_private_interfaces(ReadModules, AncestorModules,
- make_pseudo_decl(md_imported(import_locn_ancestor_private_interface)),
+ make_pseudo_decl(
+ md_imported(import_locn_ancestor_private_interface)),
make_pseudo_decl(md_abstract_imported),
IntImportedModules2, IntImportedModules,
IntUsedModules2, IntUsedModules, !Module, !IO),
@@ -2546,10 +2530,10 @@
make_pseudo_decl(md_abstract_imported),
ImpImpIndirectImports2, ImpImpIndirectImports, !Module, !IO),
- % Process the short interfaces for modules imported in the implementation
- % of indirectly imported modules. The items in these modules shouldn't be
- % visible to typechecking -- they are used for fully expanding equivalence
- % types after the semantic checking passes.
+ % Process the short interfaces for modules imported in the
+ % implementation of indirectly imported modules. The items in these
+ % modules shouldn't be visible to typechecking -- they are used for
+ % fully expanding equivalence types after the semantic checking passes.
process_module_short_interfaces_and_impls_transitively(
ReadModules, IntImpIndirectImports, ".int2",
make_pseudo_decl(md_abstract_imported),
@@ -2564,9 +2548,13 @@
module_imports_get_items(!.Module, Items),
check_imports_accessibility(ModuleName,
IntImportedModules ++ IntUsedModules ++
- ImpImportedModules ++ ImpUsedModules, Items, !IO),
+ ImpImportedModules ++ ImpUsedModules, Items, !Specs),
- module_imports_get_error(!.Module, Error).
+ sort_error_specs(!.Specs, SortedSpecs),
+ write_error_specs(SortedSpecs, 0, _NumWarnings, 0, _NumErrors, !IO),
+
+ module_imports_get_error(!.Module, Error)
+ ).
% grab_unqual_imported_modules:
%
@@ -2652,12 +2640,19 @@
make_pseudo_decl(md_abstract_imported),
[], _, !Module, !IO),
+ some [!Specs] (
+ !:Specs = [],
+
module_imports_get_items(!.Module, Items),
check_imports_accessibility(ModuleName,
IntImportDeps ++ IntUseDeps ++ ImpImportDeps ++ ImpUseDeps,
- Items, !IO),
+ Items, !Specs),
- module_imports_get_error(!.Module, Error).
+ sort_error_specs(!.Specs, SortedSpecs),
+ write_error_specs(SortedSpecs, 0, _NumWarnings, 0, _NumErrors, !IO),
+
+ module_imports_get_error(!.Module, Error)
+ ).
%-----------------------------------------------------------------------------%
@@ -2791,31 +2786,12 @@
% Warn if a module imports itself, or an ancestor.
%
-:- pred warn_if_import_self_or_ancestor(module_name::in, list(module_name)::in,
- list(module_name)::in, list(module_name)::in,
- io::di, io::uo) is det.
+:- pred warn_if_import_self_or_ancestor(module_name::in, string::in,
+ list(module_name)::in, list(module_name)::in, list(module_name)::in,
+ list(error_spec)::in, list(error_spec)::out) is det.
-warn_if_import_self_or_ancestor(ModuleName, AncestorModules,
- ImportedModules, UsedModules, !IO) :-
- globals.io_lookup_bool_option(warn_simple_code, Warn, !IO),
- (
- Warn = yes,
- (
- ( list.member(ModuleName, ImportedModules)
- ; list.member(ModuleName, UsedModules)
- )
- ->
- module_name_to_file_name(ModuleName, ".m", no, FileName, !IO),
- term.context_init(FileName, 1, Context),
- SelfImportWarning = [
- words("Warning: module"),
- sym_name(ModuleName),
- words("imports itself!")
- ],
- report_warning(Context, 0, SelfImportWarning, !IO)
- ;
- true
- ),
+warn_if_import_self_or_ancestor(ModuleName, FileName, AncestorModules,
+ ImportedModules, UsedModules, !Specs) :-
IsImportedAncestor = (pred(Import::out) is nondet :-
list.member(Import, AncestorModules),
( list.member(Import, ImportedModules)
@@ -2823,75 +2799,81 @@
)
),
solutions.aggregate(IsImportedAncestor,
- warn_imported_ancestor(ModuleName), !IO)
+ warn_imported_ancestor(ModuleName, FileName), !Specs),
+ (
+ ( list.member(ModuleName, ImportedModules)
+ ; list.member(ModuleName, UsedModules)
+ )
+ ->
+ term.context_init(FileName, 1, Context),
+ SelfPieces = [words("Warning: module"),
+ sym_name(ModuleName), words("imports itself!")],
+ SelfMsg = simple_msg(Context,
+ [option_is_set(warn_simple_code, yes, [always(SelfPieces)])]),
+ SelfSpec = error_spec(severity_warning, phase_parse_tree_to_hlds,
+ [SelfMsg]),
+ !:Specs = [SelfSpec | !.Specs]
;
- Warn = no
+ true
).
-:- pred warn_imported_ancestor(module_name::in, module_name::in,
- io::di, io::uo) is det.
+:- pred warn_imported_ancestor(module_name::in, string::in, module_name::in,
+ list(error_spec)::in, list(error_spec)::out) is det.
-warn_imported_ancestor(ModuleName, AncestorName, !IO) :-
- module_name_to_file_name(ModuleName, ".m", no, FileName, !IO),
+warn_imported_ancestor(ModuleName, FileName, AncestorName, !Specs) :-
term.context_init(FileName, 1, Context),
- record_warning(!IO),
- report_warning(Context, 0,
- [words("module"), sym_name(ModuleName),
+ MainPieces = [words("Module"), sym_name(ModuleName),
words("imports its own ancestor, module"),
- sym_name(AncestorName), words(".")], !IO),
- globals.io_lookup_bool_option(verbose_errors, VerboseErrors, !IO),
- (
- VerboseErrors = yes,
- report_warning(Context, 0,
- [words("Every sub-module implicitly imports"),
- words("its ancestors."),
+ sym_name(AncestorName), words(".")],
+ VerbosePieces = [words("Every sub-module"),
+ words("implicitly imports its ancestors."),
words("There is no need to explicitly import them.")],
- !IO)
- ;
- VerboseErrors = no,
- globals.io_set_extra_error_info(yes, !IO)
- ).
+ Msg = simple_msg(Context,
+ [option_is_set(warn_simple_code, yes,
+ [always(MainPieces), verbose_only(VerbosePieces)])]),
+ Spec = error_spec(severity_warning, phase_parse_tree_to_hlds, [Msg]),
+ !:Specs = [Spec | !.Specs].
% This predicate ensures that all every import_module declaration is
% checked against every use_module declaration, except for the case
% where the interface has `:- use_module foo.' and the implementation
% `:- import_module foo.'.
- % warn_if_duplicate_use_import_decls/7 is called to generate the actual
- % warnings.
-
-:- pred warn_if_duplicate_use_import_decls(module_name::in,
+ %
+:- pred warn_if_duplicate_use_import_decls(module_name::in, string::in,
list(module_name)::in, list(module_name)::out,
list(module_name)::in, list(module_name)::out,
list(module_name)::in, list(module_name)::out,
- list(module_name)::in, list(module_name)::out, io::di, io::uo) is det.
+ list(module_name)::in, list(module_name)::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
-warn_if_duplicate_use_import_decls(ModuleName,
+warn_if_duplicate_use_import_decls(ModuleName, FileName,
IntImportedModules0, IntImportedModules,
IntUsedModules0, IntUsedModules,
ImpImportedModules0, ImpImportedModules,
- ImpUsedModules0, ImpUsedModules, !IO) :-
+ ImpUsedModules0, ImpUsedModules, !Specs) :-
- warn_if_duplicate_use_import_decls(ModuleName,
+ do_warn_if_duplicate_use_import_decls(ModuleName, FileName,
IntImportedModules0, IntImportedModules1,
- IntUsedModules0, IntUsedModules, !IO),
- warn_if_duplicate_use_import_decls(ModuleName,
+ IntUsedModules0, IntUsedModules, !Specs),
+ do_warn_if_duplicate_use_import_decls(ModuleName, FileName,
IntImportedModules1, IntImportedModules,
- ImpUsedModules0, ImpUsedModules1, !IO),
+ ImpUsedModules0, ImpUsedModules1, !Specs),
- warn_if_duplicate_use_import_decls(ModuleName,
+ do_warn_if_duplicate_use_import_decls(ModuleName, FileName,
ImpImportedModules0, ImpImportedModules,
- ImpUsedModules1, ImpUsedModules, !IO).
+ ImpUsedModules1, ImpUsedModules, !Specs).
% Report warnings for modules imported using both `:- use_module'
% and `:- import_module'. Remove the unnecessary `:- use_module'
% declarations.
-
-:- pred warn_if_duplicate_use_import_decls(module_name::in,
+ %
+:- pred do_warn_if_duplicate_use_import_decls(module_name::in, string::in,
+ list(module_name)::in, list(module_name)::out,
list(module_name)::in, list(module_name)::out,
- list(module_name)::in, list(module_name)::out, io::di, io::uo) is det.
+ list(error_spec)::in, list(error_spec)::out) is det.
-warn_if_duplicate_use_import_decls(ModuleName, !ImportedModules, !UsedModules,
- !IO) :-
+do_warn_if_duplicate_use_import_decls(_ModuleName, FileName,
+ !ImportedModules, !UsedModules, !Specs) :-
set.list_to_set(!.ImportedModules, ImportedSet),
set.list_to_set(!.UsedModules, UsedSet),
set.intersect(ImportedSet, UsedSet, BothSet),
@@ -2899,43 +2881,28 @@
true
;
set.to_sorted_list(BothSet, BothList),
- globals.io_lookup_bool_option(warn_simple_code, WarnSimple, !IO),
- (
- WarnSimple = yes,
- module_name_to_file_name(ModuleName, ".m", no, FileName, !IO),
- term.context_init(FileName, 1, Context),
- prog_out.write_context(Context, !IO),
- io.write_string("Warning:", !IO),
- ( BothList = [_] ->
- io.write_string(" module ", !IO),
- prog_out.write_module_list(BothList, !IO),
- io.write_string(" is ", !IO)
- ;
- io.write_string(" modules ", !IO),
- prog_out.write_module_list(BothList, !IO),
- io.write_string(" are ", !IO)
- ),
- io.write_string("imported using both\n", !IO),
- prog_out.write_context(Context, !IO),
- io.write_string(" `:- import_module' and ", !IO),
- io.write_string("`:- use_module' declarations.\n", !IO),
- globals.io_lookup_bool_option(halt_at_warn, Halt, !IO),
- (
- Halt = yes,
- io.set_exit_status(1, !IO)
- ;
- Halt = no
- )
- ;
- WarnSimple = no
- ),
+ term.context_init(FileName, 1, Context),
+ Pieces = [words("Warning:"),
+ words(choose_number(BothList, "module", "modules"))] ++
+ component_list_to_pieces(list.map(wrap_symname, BothList)) ++
+ [words(choose_number(BothList, "is", "are")),
+ words("imported using both `:- import_module'"),
+ words("`:- use_module' declarations."), nl],
+ Msg = simple_msg(Context,
+ [option_is_set(warn_simple_code, yes, [always(Pieces)])]),
+ Spec = error_spec(severity_warning, phase_parse_tree_to_hlds, [Msg]),
+ !:Specs = [Spec | !.Specs],
% Treat the modules with both types of import as if they
% were imported using `:- import_module.'
list.delete_elems(!.UsedModules, BothList, !:UsedModules)
).
+:- func wrap_symname(module_name) = format_component.
+
+wrap_symname(ModuleName) = sym_name(ModuleName).
+
%-----------------------------------------------------------------------------%
write_dependency_file(Module, AllDepsSet, MaybeTransOptDeps, !IO) :-
@@ -3266,20 +3233,18 @@
"endif"
], !IO),
- % The .date and .date0 files depend on the .int0 files
- % for the parent modules, and the .int3 files for the
- % directly and indirectly imported modules.
- %
- % For nested sub-modules, the `.date' files for the
- % parent modules also depend on the same things as the
- % `.date' files for this module, since all the `.date'
- % files will get produced by a single mmc command.
- % Similarly for `.date0' files, except these don't
- % depend on the `.int0' files, because when doing the
- % `--make-private-interface' for nested modules, mmc
- % will process the modules in outermost to innermost
- % order so as to produce each `.int0' file before it is
- % needed.
+ % The .date and .date0 files depend on the .int0 files for the parent
+ % modules, and the .int3 files for the directly and indirectly imported
+ % modules.
+ %
+ % For nested sub-modules, the `.date' files for the parent modules
+ % also depend on the same things as the `.date' files for this module,
+ % since all the `.date' files will get produced by a single mmc
+ % command. Similarly for `.date0' files, except these don't depend
+ % on the `.int0' files, because when doing the
+ % `--make-private-interface' for nested modules, mmc will process
+ % the modules in outermost to innermost order so as to produce each
+ % `.int0' file before it is needed.
module_name_to_file_name(ModuleName, ".date", no, DateFileName, !IO),
module_name_to_file_name(ModuleName, ".date0", no, Date0FileName, !IO),
@@ -3300,9 +3265,9 @@
write_dependencies_list(ShortDeps, ".int3", DepStream, !IO),
io.write_string(DepStream, "\n\n", !IO),
- % If we can pass the module name rather than the file name,
- % then do so. `--smart-recompilation' doesn't work if the file name
- % is passed and the module name doesn't match the file name.
+ % If we can pass the module name rather than the file name, then do so.
+ % `--smart-recompilation' doesn't work if the file name is passed
+ % and the module name doesn't match the file name.
have_source_file_map(HaveMap, !IO),
(
@@ -3924,7 +3889,9 @@
read_mod_from_file(FileName, ".m", "Reading file", no, no, Items, Error,
ModuleName, _, !IO),
string.append(FileName, ".m", SourceFileName),
- split_into_submodules(ModuleName, Items, SubModuleList, !IO),
+ split_into_submodules(ModuleName, Items, SubModuleList, [], Specs),
+ sort_error_specs(Specs, SortedSpecs),
+ write_error_specs(SortedSpecs, 0, _NumWarnings, 0, _NumErrors, !IO),
globals.io_get_globals(Globals, !IO),
assoc_list.keys(SubModuleList, SubModuleNames),
list.map(init_dependencies(SourceFileName, ModuleName, SubModuleNames,
@@ -6084,7 +6051,9 @@
;
FileName = FileName0,
Items = Items0,
- split_into_submodules(ModuleName, Items, SubModuleList, !IO)
+ split_into_submodules(ModuleName, Items, SubModuleList, [], Specs),
+ sort_error_specs(Specs, SortedSpecs),
+ write_error_specs(SortedSpecs, 0, _NumWarnings, 0, _NumErrors, !IO)
),
globals.io_get_globals(Globals, !IO),
assoc_list.keys(SubModuleList, SubModuleNames),
@@ -6485,7 +6454,7 @@
).
:- pred check_imports_accessibility(module_name::in, list(module_name)::in,
- item_list::in, io::di, io::uo) is det.
+ item_list::in, list(error_spec)::in, list(error_spec)::out) is det.
%
% At this point, we've read in all the appropriate interface files,
@@ -6498,16 +6467,17 @@
% We then go through all of the imported/used modules,
% checking that each one is accessible.
%
-check_imports_accessibility(ModuleName, Imports, Items, !IO) :-
+check_imports_accessibility(ModuleName, Imports, Items, !Specs) :-
get_accessible_children(Items, AccessibleSubModules),
list.foldl(check_module_accessibility(ModuleName,
- AccessibleSubModules, Items), Imports, !IO).
+ AccessibleSubModules, Items), Imports, !Specs).
:- pred check_module_accessibility(module_name::in, list(module_name)::in,
- item_list::in, module_name::in, io::di, io::uo) is det.
+ item_list::in, module_name::in,
+ list(error_spec)::in, list(error_spec)::out) is det.
check_module_accessibility(ModuleName, AccessibleSubModules, Items,
- ImportedModule, !IO) :-
+ ImportedModule, !Specs) :-
( ImportedModule = qualified(ParentModule, SubModule) ->
( list.member(ImportedModule, AccessibleSubModules) ->
true
@@ -6535,14 +6505,15 @@
list.foldl(
report_inaccessible_module_error(
ModuleName, ParentModule, SubModule),
- ImportItems, !IO)
+ ImportItems, !Specs)
)
;
true
).
:- pred report_inaccessible_module_error(module_name::in, module_name::in,
- string::in, item_and_context::in, io::di, io::uo) is det.
+ string::in, item_and_context::in,
+ list(error_spec)::in, list(error_spec)::out) is det.
% The error message should come out like this
% (the second sentence is included only with --verbose-errors):
@@ -6556,7 +6527,7 @@
% very_long_name.m:123: declaration for module `sub_module'.
report_inaccessible_module_error(ModuleName, ParentModule, SubModule,
- Item - Context, !IO) :-
+ Item - Context, !Specs) :-
( Item = item_module_defn(_, md_import(list_module(_))) ->
DeclName = "import_module"
; Item = item_module_defn(_, md_use(list_module(_))) ->
@@ -6565,32 +6536,22 @@
unexpected(this_file,
"report_inaccessible_parent_error: invalid item")
),
- ErrMsg0 = [
- words("In module"), sym_name(ModuleName), suffix(":"), nl,
+ MainPieces = [words("In module"), sym_name(ModuleName), suffix(":"), nl,
words("error in"), quote(DeclName), words("declaration:"), nl,
words("module"), sym_name(qualified(ParentModule, SubModule)),
- words("is inaccessible."), nl
- ],
- globals.io_lookup_bool_option(verbose_errors, VerboseErrors, !IO),
- (
-
- VerboseErrors = yes,
- ErrMsg = ErrMsg0 ++ [
- words("Either there was no prior"), quote("import_module"),
+ words("is inaccessible."), nl],
+ VerbosePieces = [words("Either there was no prior"),
+ quote("import_module"),
words("or"), quote("use_module"),
words("declaration to import module"), sym_name(ParentModule),
suffix(","), words("or the interface for module"),
sym_name(ParentModule), words("does not contain an"),
quote("include_module"), words("declaration for module"),
- quote(SubModule), suffix(".")
- ]
- ;
- VerboseErrors = no,
- ErrMsg = ErrMsg0,
- globals.io_set_extra_error_info(yes, !IO)
- ),
- write_error_pieces(Context, 0, ErrMsg, !IO),
- io.set_exit_status(1, !IO).
+ quote(SubModule), suffix("."), nl],
+ Msg = simple_msg(Context,
+ [always(MainPieces), verbose_only(VerbosePieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
+ !:Specs = [Spec | !.Specs].
%-----------------------------------------------------------------------------%
@@ -6892,14 +6853,14 @@
% Given a module (well, a list of items), split it into
% its constituent sub-modules, in top-down order.
%
-split_into_submodules(ModuleName, Items0, ModuleList, !IO) :-
+split_into_submodules(ModuleName, Items0, ModuleList, !Specs) :-
InParentInterface = no,
split_into_submodules_2(ModuleName, Items0, InParentInterface,
- Items, ModuleList, !IO),
+ Items, ModuleList, !Specs),
% Check that there are no items after the end_module declaration.
( Items = [_ - Context | _] ->
- report_items_after_end_module(Context, !IO)
+ report_items_after_end_module(Context, !Specs)
;
true
),
@@ -6913,30 +6874,32 @@
( set.empty(Duplicates) ->
true
;
- report_duplicate_modules(Duplicates, Items0, !IO)
+ report_duplicate_modules(Duplicates, Items0, !Specs)
).
:- pred split_into_submodules_2(module_name::in, item_list::in, bool::in,
- item_list::out, module_list::out, io::di, io::uo) is det.
+ item_list::out, module_list::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
split_into_submodules_2(ModuleName, Items0, InParentInterface, Items,
- ModuleList, !IO) :-
+ ModuleList, !Specs) :-
InInterface0 = no,
split_into_submodules_3(ModuleName, Items0,
InParentInterface, InInterface0,
- ThisModuleItems, Items, SubModules, !IO),
+ ThisModuleItems, Items, SubModules, !Specs),
map.to_assoc_list(SubModules, SubModuleList),
ModuleList = [ModuleName - ThisModuleItems | SubModuleList].
:- pred split_into_submodules_3(module_name::in, item_list::in, bool::in,
bool::in, item_list::out, item_list::out,
- map(module_name, item_list)::out, io::di, io::uo) is det.
+ map(module_name, item_list)::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
-split_into_submodules_3(_ModuleName, [], _, _, [], [], SubModules, !IO) :-
+split_into_submodules_3(_ModuleName, [], _, _, [], [], SubModules, !Specs) :-
map.init(SubModules).
split_into_submodules_3(ModuleName, [Item | Items1],
InParentInterface, InInterface0,
- ThisModuleItems, OtherItems, SubModules, !IO) :-
+ ThisModuleItems, OtherItems, SubModules, !Specs) :-
(
% Check for a `module' declaration, which signals the start
% of a nested module.
@@ -6944,11 +6907,11 @@
->
% Parse in the items for the nested submodule.
split_into_submodules_2(SubModuleName, Items1, InInterface0,
- Items2, SubModules0, !IO),
+ Items2, SubModules0, !Specs),
% Parse in the remaining items for this module.
split_into_submodules_3(ModuleName, Items2, InParentInterface,
- InInterface0, ThisModuleItems0, Items3, SubModules1, !IO),
+ InInterface0, ThisModuleItems0, Items3, SubModules1, !Specs),
% Combine the sub-module declarations from the previous two steps.
list.foldl(add_submodule, SubModules0, SubModules1, SubModules),
@@ -6978,7 +6941,7 @@
(
InParentInterface = yes,
report_error_implementation_in_interface(ModuleName,
- ImplContext, !IO)
+ ImplContext, !Specs)
;
InParentInterface = no
),
@@ -6994,7 +6957,7 @@
Item = item_instance(_, _, _, Body, _, _) - InstanceContext,
Body \= abstract
->
- report_non_abstract_instance_in_interface(InstanceContext, !IO)
+ report_non_abstract_instance_in_interface(InstanceContext, !Specs)
;
true
),
@@ -7002,7 +6965,7 @@
% Parse the remaining items for this module.
split_into_submodules_3(ModuleName, Items1,
InParentInterface, InInterface1,
- ThisModuleItems0, Items2, SubModules, !IO),
+ ThisModuleItems0, Items2, SubModules, !Specs),
% Put the current item back onto the front of the item list
% for this module.
@@ -7029,9 +6992,9 @@
).
:- pred report_error_implementation_in_interface(module_name::in,
- prog_context::in, io::di, io::uo) is det.
+ prog_context::in, list(error_spec)::in, list(error_spec)::out) is det.
-report_error_implementation_in_interface(ModuleName, Context, !IO) :-
+report_error_implementation_in_interface(ModuleName, Context, !Specs) :-
( ModuleName = qualified(ParentModule0, ChildModule0) ->
ParentModule = ParentModule0,
ChildModule = ChildModule0
@@ -7043,13 +7006,14 @@
words("in definition of sub-module `" ++ ChildModule ++ "':"), nl,
words("error: `:- implementation.' declaration for sub-module\n"),
words("occurs in interface section of parent module.")],
- write_error_pieces(Context, 0, Pieces, !IO),
- io.set_exit_status(1, !IO).
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
+ !:Specs = [Spec | !.Specs].
:- pred report_duplicate_modules(set(module_name)::in, item_list::in,
- io::di, io::uo) is det.
+ list(error_spec)::in, list(error_spec)::out) is det.
-report_duplicate_modules(Duplicates, Items, !IO) :-
+report_duplicate_modules(Duplicates, Items, !Specs) :-
IsDuplicateError =
(pred(SubModuleName - Context::out) is nondet :-
list.member(Item, Items),
@@ -7063,12 +7027,12 @@
set.member(SubModuleName, Duplicates)
),
solutions.solutions(IsDuplicateError, DuplicateErrors),
- list.foldl(report_error_duplicate_module_decl, DuplicateErrors, !IO).
+ list.foldl(report_error_duplicate_module_decl, DuplicateErrors, !Specs).
:- pred report_error_duplicate_module_decl(pair(module_name, prog_context)::in,
- io::di, io::uo) is det.
+ list(error_spec)::in, list(error_spec)::out) is det.
-report_error_duplicate_module_decl(ModuleName - Context, !IO) :-
+report_error_duplicate_module_decl(ModuleName - Context, !Specs) :-
( ModuleName = qualified(ParentModule0, ChildModule0) ->
ParentModule = ParentModule0,
ChildModule = ChildModule0
@@ -7078,24 +7042,28 @@
Pieces = [words("In module"), sym_name(ParentModule), suffix(":"), nl,
words("error: sub-module `" ++ ChildModule ++ "' declared"),
words("as both a separate sub-module and a nested sub-module.")],
- write_error_pieces(Context, 0, Pieces, !IO),
- io.set_exit_status(1, !IO).
-
-:- pred report_items_after_end_module(prog_context::in, io::di, io::uo) is det.
-
-report_items_after_end_module(Context, !IO) :-
- ErrorPieces = [words("Error: item(s) after end_module declaration.")],
- write_error_pieces(Context, 0, ErrorPieces, !IO),
- io.set_exit_status(1, !IO).
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
+ !:Specs = [Spec | !.Specs].
+
+:- pred report_items_after_end_module(prog_context::in,
+ list(error_spec)::in, list(error_spec)::out) is det.
+
+report_items_after_end_module(Context, !Specs) :-
+ Pieces = [words("Error: item(s) after end_module declaration.")],
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
+ !:Specs = [Spec | !.Specs].
:- pred report_non_abstract_instance_in_interface(prog_context::in,
- io::di, io::uo) is det.
+ list(error_spec)::in, list(error_spec)::out) is det.
-report_non_abstract_instance_in_interface(Context, !IO) :-
- ErrorPieces = [words("Error: non-abstract instance declaration"),
+report_non_abstract_instance_in_interface(Context, !Specs) :-
+ Pieces = [words("Error: non-abstract instance declaration"),
words("in module interface.")],
- write_error_pieces(Context, 0, ErrorPieces, !IO),
- io.set_exit_status(1, !IO).
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
+ !:Specs = [Spec | !.Specs].
% Given a module (well, a list of items), extract the interface
% part of that module, i.e. all the items between `:- interface'
Index: compiler/options.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/options.m,v
retrieving revision 1.525
diff -u -b -r1.525 options.m
--- compiler/options.m 4 Sep 2006 01:47:33 -0000 1.525
+++ compiler/options.m 8 Sep 2006 10:04:22 -0000
@@ -284,7 +284,7 @@
; use_minimal_model_own_stacks
; minimal_model_debug
; type_layout
- ; maybe_thread_safe
+ ; maybe_thread_safe_opt
; extend_stacks_when_needed
% Data representation compilation model options
@@ -1020,7 +1020,7 @@
gc - string("boehm"),
parallel - bool(no),
use_trail - bool(no),
- maybe_thread_safe - string("no"),
+ maybe_thread_safe_opt - string("no"),
extend_stacks_when_needed - bool(no),
use_minimal_model_stack_copy - bool(no),
use_minimal_model_own_stacks - bool(no),
@@ -1751,7 +1751,7 @@
long_option("parallel", parallel).
long_option("use-trail", use_trail).
long_option("type-layout", type_layout).
-long_option("maybe-thread-safe", maybe_thread_safe).
+long_option("maybe-thread-safe", maybe_thread_safe_opt).
long_option("extend-stacks-when-needed", extend_stacks_when_needed).
% Data representation options
long_option("reserve-tag", reserve_tag).
Index: compiler/post_typecheck.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/post_typecheck.m,v
retrieving revision 1.106
diff -u -b -r1.106 post_typecheck.m
--- compiler/post_typecheck.m 7 Sep 2006 05:51:02 -0000 1.106
+++ compiler/post_typecheck.m 8 Sep 2006 12:44:09 -0000
@@ -304,37 +304,29 @@
report_unsatisfied_constraints(Constraints, PredId, PredInfo, ModuleInfo,
!IO) :-
- io.set_exit_status(1, !IO),
-
pred_info_get_typevarset(PredInfo, TVarSet),
pred_info_context(PredInfo, Context),
- Pieces0 = constraints_to_error_pieces(TVarSet, Constraints),
-
- PredIdStr = pred_id_to_string(ModuleInfo, PredId),
+ PredIdPieces = describe_one_pred_name(ModuleInfo,
+ should_not_module_qualify, PredId),
- Pieces = [
- words("In"), fixed(PredIdStr), suffix(":"), nl,
+ Pieces = [words("In")] ++ PredIdPieces ++ [suffix(":"), nl,
fixed("type error: unsatisfied typeclass " ++
choose_number(Constraints, "constraint:", "constraints:")),
- nl_indent_delta(2) | Pieces0 ],
-
- write_error_pieces(Context, 0, Pieces, !IO).
-
-:- func constraints_to_error_pieces(tvarset, list(prog_constraint))
- = format_components.
+ nl_indent_delta(1)] ++
+ component_list_to_line_pieces(
+ list.map(constraint_to_error_piece(TVarSet), Constraints), []) ++
+ [nl_indent_delta(-1)],
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_type_check, [Msg]),
+ % XXX _NumErrors
+ write_error_spec(Spec, 0, _NumWarnings, 0, _NumErrors, !IO).
-constraints_to_error_pieces(_, []) = [].
-constraints_to_error_pieces(TVarset, [C]) =
- [constraint_to_error_piece(TVarset, C)].
-constraints_to_error_pieces(TVarset, [ C0, C1 | Cs]) = Components :-
- Format0 = [ constraint_to_error_piece(TVarset, C0), nl ],
- Components = Format0 ++ constraints_to_error_pieces(TVarset, [C1 | Cs]).
-
-:- func constraint_to_error_piece(tvarset, prog_constraint) = format_component.
+:- func constraint_to_error_piece(tvarset, prog_constraint)
+ = list(format_component).
constraint_to_error_piece(TVarset, Constraint) =
- fixed("`" ++ mercury_constraint_to_string(TVarset, Constraint) ++ "'").
+ [quote(mercury_constraint_to_string(TVarset, Constraint))].
%-----------------------------------------------------------------------------%
@@ -508,8 +500,7 @@
store_promise(PromiseType, PromiseId, !Module, Goal) :-
(
% Case for assertions.
- PromiseType = true
- ->
+ PromiseType = promise_type_true,
module_info_get_assertion_table(!.Module, AssertTable0),
assertion_table_add_assertion(PromiseId, AssertionId,
AssertTable0, AssertTable),
@@ -518,12 +509,9 @@
assertion.record_preds_used_in(Goal, AssertionId, !Module)
;
% Case for exclusivity.
- (
- PromiseType = exclusive
- ;
- PromiseType = exclusive_exhaustive
- )
- ->
+ ( PromiseType = promise_type_exclusive
+ ; PromiseType = promise_type_exclusive_exhaustive
+ ),
promise_ex_goal(PromiseId, !.Module, Goal),
predids_from_goal(Goal, PredIds),
module_info_get_exclusive_table(!.Module, Table0),
@@ -531,6 +519,7 @@
module_info_set_exclusive_table(Table, !Module)
;
% Case for exhaustiveness -- XXX not yet implemented.
+ PromiseType = promise_type_exhaustive,
promise_ex_goal(PromiseId, !.Module, Goal)
).
@@ -701,10 +690,12 @@
true
;
pred_info_context(PredInfo, Context),
- error_util.write_error_pieces(Context, 0,
- [words("Error: arguments of main/2"),
- words("must have type `io.state'.")], !IO),
- io.set_exit_status(1, !IO)
+ Pieces = [words("Error: arguments of main/2"),
+ words("must have type `io.state'."), nl],
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_type_check, [Msg]),
+ % XXX _NumErrors
+ write_error_spec(Spec, 0, _NumWarnings, 0, _NumErrors, !IO)
)
;
true
@@ -785,13 +776,15 @@
unbound_inst_var_error(PredId, ProcInfo, ModuleInfo, !IO) :-
proc_info_get_context(ProcInfo, Context),
- io.set_exit_status(1, !IO),
Pieces = [words("In mode declaration for")] ++
describe_one_pred_name(ModuleInfo, should_not_module_qualify, PredId)
++ [suffix(":"), nl,
words("error: unbound inst variable(s)."), nl,
words("(Sorry, polymorphic modes are not supported.)"), nl],
- write_error_pieces(Context, 0, Pieces, !IO).
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_type_check, [Msg]),
+ % XXX _NumErrors
+ write_error_spec(Spec, 0, _NumWarnings, 0, _NumErrors, !IO).
%-----------------------------------------------------------------------------%
@@ -1465,16 +1458,14 @@
not ModuleName = unqualified("type_desc"),
not list.member(TypeCtor, BuiltinTypeCtors)
->
- ErrorPieces = [
- words("Error: abstract"),
- words("declaration for type"),
- sym_name_and_arity(SymName / Arity),
- words("has no corresponding"),
- words("definition.")
- ],
get_type_defn_context(TypeDefn, TypeContext),
- write_error_pieces(TypeContext, 0, ErrorPieces, !IO),
- io.set_exit_status(1, !IO),
+ Pieces = [words("Error: abstract declaration for type"),
+ sym_name_and_arity(SymName / Arity),
+ words("has no corresponding definition."), nl],
+ Msg = simple_msg(TypeContext, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_type_check, [Msg]),
+ % XXX _NumErrors
+ write_error_spec(Spec, 0, _NumWarnings, 0, _NumErrors, !IO),
!:FoundTypeError = yes,
!:NumErrors = !.NumErrors + 1
;
Index: compiler/prog_data.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_data.m,v
retrieving revision 1.174
diff -u -b -r1.174 prog_data.m
--- compiler/prog_data.m 7 Sep 2006 05:51:03 -0000 1.174
+++ compiler/prog_data.m 8 Sep 2006 10:06:38 -0000
@@ -43,15 +43,21 @@
%-----------------------------------------------------------------------------%
% Indicates the type of information the compiler should get from the
- % declaration's clause.
+ % promise declaration's clause.
%
:- type promise_type
% promise ex declarations
- ---> exclusive % Each disjunct is mutually exclusive.
- ; exhaustive % Disjunction cannot fail.
- ; exclusive_exhaustive % Both of the above.
- % assertions
- ; true. % Promise goal is true.
+ ---> promise_type_exclusive
+ % Each disjunct is mutually exclusive.
+
+ ; promise_type_exhaustive
+ % Disjunction cannot fail.
+
+ ; promise_type_exclusive_exhaustive
+ % Both of the above assertions
+
+ ; promise_type_true.
+ % Promise goal is true.
:- type type_and_mode
---> type_only(mer_type)
Index: compiler/prog_io.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_io.m,v
retrieving revision 1.272
diff -u -b -r1.272 prog_io.m
--- compiler/prog_io.m 7 Sep 2006 05:51:03 -0000 1.272
+++ compiler/prog_io.m 8 Sep 2006 12:46:14 -0000
@@ -1287,23 +1287,24 @@
check_no_attributes(Result0, Attributes, Result).
process_decl(ModuleName, VarSet, "promise", Assertion, Attributes, Result):-
- parse_promise(ModuleName, true, VarSet, Assertion, Attributes, Result0),
+ parse_promise(ModuleName, promise_type_true, VarSet,
+ Assertion, Attributes, Result0),
check_no_attributes(Result0, Attributes, Result).
process_decl(ModuleName, VarSet, "promise_exclusive", PromiseGoal, Attributes,
Result):-
- parse_promise(ModuleName, exclusive, VarSet, PromiseGoal, Attributes,
- Result).
+ parse_promise(ModuleName, promise_type_exclusive, VarSet,
+ PromiseGoal, Attributes, Result).
process_decl(ModuleName, VarSet, "promise_exhaustive", PromiseGoal, Attributes,
Result):-
- parse_promise(ModuleName, exhaustive, VarSet, PromiseGoal, Attributes,
- Result).
+ parse_promise(ModuleName, promise_type_exhaustive, VarSet,
+ PromiseGoal, Attributes, Result).
process_decl(ModuleName, VarSet, "promise_exclusive_exhaustive", PromiseGoal,
Attributes, Result):-
- parse_promise(ModuleName, exclusive_exhaustive, VarSet, PromiseGoal,
- Attributes, Result).
+ parse_promise(ModuleName, promise_type_exclusive_exhaustive, VarSet,
+ PromiseGoal, Attributes, Result).
process_decl(ModuleName, VarSet, "typeclass", Args, Attributes, Result):-
parse_typeclass(ModuleName, VarSet, Args, Result0),
@@ -1421,7 +1422,8 @@
(
MaybeGoal0 = ok1(Goal0),
% Get universally quantified variables.
- ( PromiseType = true ->
+ (
+ PromiseType = promise_type_true,
( Goal0 = all_expr(UnivVars0, AllGoal) - _Context ->
UnivVars0 = UnivVars,
Goal = AllGoal
@@ -1430,6 +1432,10 @@
Goal = Goal0
)
;
+ ( PromiseType = promise_type_exclusive
+ ; PromiseType = promise_type_exhaustive
+ ; PromiseType = promise_type_exclusive_exhaustive
+ ),
get_quant_vars(univ, ModuleName, Attributes, _, [], UnivVars0),
list.map(term.coerce_var, UnivVars0, UnivVars),
Goal0 = Goal
Index: compiler/prog_io_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_io_util.m,v
retrieving revision 1.52
diff -u -b -r1.52 prog_io_util.m
--- compiler/prog_io_util.m 7 Sep 2006 05:51:04 -0000 1.52
+++ compiler/prog_io_util.m 8 Sep 2006 06:47:06 -0000
@@ -32,13 +32,11 @@
:- import_module parse_tree.prog_item.
:- import_module assoc_list.
-:- import_module io.
:- import_module list.
:- import_module map.
:- import_module maybe.
:- import_module pair.
:- import_module term.
-:- import_module varset.
%-----------------------------------------------------------------------------%
@@ -68,9 +66,6 @@
:- func get_any_errors4(maybe4(T1, T2, T3, T4, U))
= assoc_list(string, term(U)).
-:- pred report_string_term_error(term.context::in, varset(U)::in,
- pair(string, term(U))::in, io::di, io::uo) is det.
-
:- type maybe_functor == maybe_functor(generic).
:- type maybe_functor(T) == maybe2(sym_name, list(term(T))).
@@ -218,13 +213,6 @@
get_any_errors4(ok4(_, _, _, _)) = [].
get_any_errors4(error4(Errors)) = Errors.
-report_string_term_error(Context, VarSet, Msg - ErrorTerm, !IO) :-
- TermStr = mercury_term_to_string(ErrorTerm, VarSet, no),
- Pieces = [words("Error:"), words(Msg), suffix(":"),
- fixed("`" ++ TermStr ++ "'.")],
- write_error_pieces(Context, 0, Pieces, !IO),
- io.set_exit_status(1, !IO).
-
add_context(error1(Errs), _, error2(Errs)).
add_context(ok1(Item), Context, ok2(Item, Context)).
Index: compiler/prog_out.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_out.m,v
retrieving revision 1.76
diff -u -b -r1.76 prog_out.m
--- compiler/prog_out.m 7 Sep 2006 05:51:04 -0000 1.76
+++ compiler/prog_out.m 9 Sep 2006 03:58:01 -0000
@@ -98,11 +98,6 @@
:- pred write_module_spec(module_specifier::in, io::di, io::uo) is det.
:- func module_spec_to_escaped_string(module_specifier) = string.
-:- pred write_module_list(list(module_name)::in, io::di, io::uo) is det.
-
-:- pred write_list(list(T)::in, pred(T, io, io)::in(pred(in, di, uo) is det),
- io::di, io::uo) is det.
-
:- pred write_string_list(list(string)::in, io::di, io::uo) is det.
:- pred write_promise_type(promise_type::in, io::di, io::uo) is det.
@@ -294,29 +289,28 @@
Name = unqualify_name(SymName),
% Is it really a promise?
( string.prefix(Name, "promise__") ->
- MaybePromise = yes(true)
+ MaybePromise = yes(promise_type_true)
; string.prefix(Name, "promise_exclusive__") ->
- MaybePromise = yes(exclusive)
+ MaybePromise = yes(promise_type_exclusive)
; string.prefix(Name, "promise_exhaustive__") ->
- MaybePromise = yes(exhaustive)
+ MaybePromise = yes(promise_type_exhaustive)
; string.prefix(Name, "promise_exclusive_exhaustive__") ->
- MaybePromise = yes(exclusive_exhaustive)
+ MaybePromise = yes(promise_type_exclusive_exhaustive)
;
MaybePromise = no % No, it is really a pred or func.
),
(
MaybePromise = yes(PromiseType),
- PromiseStr = promise_to_string(PromiseType),
- Str = "`" ++ PromiseStr ++ "' declaration"
+ Pieces = [quote(promise_to_string(PromiseType)), words("declaration")]
;
MaybePromise = no,
SimpleCallId = simple_call_id(PredOrFunc, SymName, Arity),
simple_call_id_to_sym_name_and_arity(SimpleCallId,
AdjustedSymNameAndArity),
Pieces = [p_or_f(PredOrFunc),
- sym_name_and_arity(AdjustedSymNameAndArity)],
- Str = error_pieces_to_string(Pieces)
- ).
+ sym_name_and_arity(AdjustedSymNameAndArity)]
+ ),
+ Str = error_pieces_to_string(Pieces).
simple_call_id_to_sym_name_and_arity(SimpleCallId, SymName / OrigArity) :-
SimpleCallId = simple_call_id(PredOrFunc, SymName, Arity),
@@ -330,15 +324,8 @@
%-----------------------------------------------------------------------------%
-write_module_list(Modules, !IO) :-
- write_list(Modules, write_module, !IO).
-
-:- pred write_module(module_name::in, io::di, io::uo) is det.
-
-write_module(Module, !IO) :-
- io.write_string("`", !IO),
- write_sym_name(Module, !IO),
- io.write_string("'", !IO).
+:- pred write_list(list(T)::in, pred(T, io, io)::in(pred(in, di, uo) is det),
+ io::di, io::uo) is det.
write_list([Import1, Import2, Import3 | Imports], Writer, !IO) :-
call(Writer, Import1, !IO),
@@ -361,10 +348,10 @@
io.write_string(", ", !IO),
write_string_list([Name2 | Names], !IO).
-promise_to_string(true) = "promise".
-promise_to_string(exclusive) = "promise_exclusive".
-promise_to_string(exhaustive) = "promise_exhaustive".
-promise_to_string(exclusive_exhaustive) =
+promise_to_string(promise_type_true) = "promise".
+promise_to_string(promise_type_exclusive) = "promise_exclusive".
+promise_to_string(promise_type_exhaustive) = "promise_exhaustive".
+promise_to_string(promise_type_exclusive_exhaustive) =
"promise_exclusive_exhaustive".
builtin_type_to_string(builtin_type_int, "int").
Index: compiler/qual_info.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/qual_info.m,v
retrieving revision 1.15
diff -u -b -r1.15 qual_info.m
--- compiler/qual_info.m 20 Aug 2006 08:21:27 -0000 1.15
+++ compiler/qual_info.m 8 Sep 2006 07:19:53 -0000
@@ -19,12 +19,12 @@
:- import_module hlds.hlds_pred.
:- import_module mdbcomp.prim_data.
:- import_module parse_tree.equiv_type.
+:- import_module parse_tree.error_util.
:- import_module parse_tree.module_qual.
:- import_module parse_tree.prog_data.
:- import_module recompilation.
:- import_module bool.
-:- import_module io.
:- import_module list.
%-----------------------------------------------------------------------------%
@@ -65,7 +65,8 @@
%
:- pred process_type_qualification(prog_var::in, mer_type::in, tvarset::in,
prog_context::in, module_info::in, module_info::out,
- qual_info::in, qual_info::out, io::di, io::uo) is det.
+ qual_info::in, qual_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
:- pred make_atomic_unification(prog_var::in, unify_rhs::in, prog_context::in,
unify_main_context::in, unify_sub_contexts::in, purity::in, hlds_goal::out,
@@ -93,7 +94,6 @@
:- implementation.
:- import_module hlds.hlds_data.
-:- import_module parse_tree.error_util.
:- import_module parse_tree.prog_out.
:- import_module parse_tree.prog_type.
:- import_module parse_tree.prog_type_subst.
@@ -186,7 +186,7 @@
%-----------------------------------------------------------------------------%
process_type_qualification(Var, Type0, VarSet, Context, !ModuleInfo,
- !QualInfo, !IO) :-
+ !QualInfo, !Specs) :-
!.QualInfo = qual_info(EqvMap, TVarSet0, TVarRenaming0,
TVarNameMap0, VarTypes0, MQInfo0, Status, FoundError),
( Status = status_opt_imported ->
@@ -194,8 +194,8 @@
Type1 = Type0,
MQInfo = MQInfo0
;
- module_qual.qualify_type_qualification(Type0, Type1,
- Context, MQInfo0, MQInfo, !IO)
+ qualify_type_qualification(Type0, Type1, Context, MQInfo0, MQInfo,
+ !Specs)
),
% Find any new type variables introduced by this type, and
@@ -215,24 +215,24 @@
RecordExpanded = no,
equiv_type.replace_in_type(EqvMap, Type2, Type, _, TVarSet1, TVarSet,
RecordExpanded, _),
- update_var_types(Var, Type, Context, VarTypes0, VarTypes, !IO),
+ update_var_types(Var, Type, Context, VarTypes0, VarTypes, !Specs),
!:QualInfo = qual_info(EqvMap, TVarSet, TVarRenaming,
TVarNameMap, VarTypes, MQInfo, Status, FoundError).
:- pred update_var_types(prog_var::in, mer_type::in, prog_context::in,
- vartypes::in, vartypes::out, io::di, io::uo) is det.
+ vartypes::in, vartypes::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
-update_var_types(Var, Type, Context, !VarTypes, !IO) :-
+update_var_types(Var, Type, Context, !VarTypes, !Specs) :-
( map.search(!.VarTypes, Var, Type0) ->
( Type = Type0 ->
true
;
- ErrMsg = [
- words("Error: explicit type qualification does"),
- words("not match prior qualification.")
- ],
- write_error_pieces(Context, 0, ErrMsg, !IO),
- io.set_exit_status(1, !IO)
+ Pieces = [words("Error: explicit type qualification"),
+ words("does not match prior qualification."), nl],
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
+ !:Specs = [Spec | !.Specs]
)
;
svmap.det_insert(Var, Type, !VarTypes)
Index: compiler/state_var.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/state_var.m,v
retrieving revision 1.16
diff -u -b -r1.16 state_var.m
--- compiler/state_var.m 22 Aug 2006 05:04:08 -0000 1.16
+++ compiler/state_var.m 8 Sep 2006 06:26:58 -0000
@@ -16,9 +16,9 @@
:- import_module hlds.hlds_goal.
:- import_module mdbcomp.prim_data.
+:- import_module parse_tree.error_util.
:- import_module parse_tree.prog_data.
-:- import_module io.
:- import_module list.
:- import_module map.
:- import_module set.
@@ -95,35 +95,34 @@
% Obtain the mapping for a !.X state variable reference and
% update the svar_info.
%
- % If we are processing the head of a clause or lambda, we
- % incrementally accumulate the mappings.
+ % If we are processing the head of a clause or lambda, we incrementally
+ % accumulate the mappings.
%
- % Otherwise, the mapping must already be present for a local
- % or `external' state variable (i.e. one that may be visible,
- % but not updatable, in the current context.)
+ % Otherwise, the mapping must already be present for a local or `external'
+ % state variable (i.e. one that may be visible, but not updatable, in the
+ % current context.)
%
- % Note that if !.X does not appear in the head then !:X must
- % appear before !.X can be referenced.
+ % Note that if !.X does not appear in the head then !:X must appear
+ % before !.X can be referenced.
%
:- pred dot(prog_context::in, svar::in, prog_var::out,
prog_varset::in, prog_varset::out, svar_info::in, svar_info::out,
- io::di, io::uo) is det.
+ list(error_spec)::in, list(error_spec)::out) is det.
% Obtain the mapping for a !:X state variable reference.
%
- % If we are processing the head of a clause or lambda, we
- % incrementally accumulate the mappings.
+ % If we are processing the head of a clause or lambda, we incrementally
+ % accumulate the mappings.
%
- % Otherwise, the mapping must already be present for a local
- % state variable (`externally' visible state variables cannot
- % be updated.)
+ % Otherwise, the mapping must already be present for a local state variable
+ % (`externally' visible state variables cannot be updated.)
%
% We also keep track of which state variables have been updated
% in an atomic context.
%
:- pred colon(prog_context::in, svar::in, prog_var::out,
prog_varset::in, prog_varset::out, svar_info::in, svar_info::out,
- io::di, io::uo) is det.
+ list(error_spec)::in, list(error_spec)::out) is det.
% Prepare for the head of a new clause.
%
@@ -252,8 +251,7 @@
% p(X0, X1) and [!.X -> X1, !:X -> X2]
%
:- pred prepare_for_next_conjunct(svar_set::in,
- prog_varset::in, prog_varset::out, svar_info::in, svar_info::out)
- is det.
+ prog_varset::in, prog_varset::out, svar_info::in, svar_info::out) is det.
% Given a list of argument terms, substitute !.X and !:X with
% the corresponding state variable mappings. Any !X should
@@ -262,11 +260,12 @@
%
:- pred substitute_state_var_mappings(list(prog_term)::in,
list(prog_term)::out, prog_varset::in, prog_varset::out,
- svar_info::in, svar_info::out, io::di, io::uo) is det.
+ svar_info::in, svar_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
:- pred substitute_state_var_mapping(prog_term::in, prog_term::out,
prog_varset::in, prog_varset::out, svar_info::in, svar_info::out,
- io::di, io::uo) is det.
+ list(error_spec)::in, list(error_spec)::out) is det.
% Replace !X args with two args !.X, !:X in that order.
%
@@ -286,13 +285,13 @@
is semidet.
:- pred report_illegal_state_var_update(prog_context::in, prog_varset::in,
- svar::in, io::di, io::uo) is det.
+ svar::in, list(error_spec)::in, list(error_spec)::out) is det.
:- pred report_illegal_func_svar_result(prog_context::in, prog_varset::in,
- svar::in, io::di, io::uo) is det.
+ svar::in, list(error_spec)::in, list(error_spec)::out) is det.
:- pred report_illegal_bang_svar_lambda_arg(prog_context::in, prog_varset::in,
- svar::in, io::di, io::uo) is det.
+ svar::in, list(error_spec)::in, list(error_spec)::out) is det.
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -300,7 +299,6 @@
:- implementation.
:- import_module libs.compiler_util.
-:- import_module parse_tree.error_util.
:- import_module parse_tree.prog_util.
:- import_module char.
@@ -335,7 +333,7 @@
%-----------------------------------------------------------------------------%
-dot(Context, StateVar, Var, !VarSet, !SInfo, !IO) :-
+dot(Context, StateVar, Var, !VarSet, !SInfo, !Specs) :-
( !.SInfo ^ ctxt = in_head ->
( !.SInfo ^ dot ^ elem(StateVar) = Var0 ->
Var = Var0
@@ -349,16 +347,17 @@
Var = Var0
; !.SInfo `has_svar_colon_mapping_for` StateVar ->
new_dot_state_var(StateVar, Var, !VarSet, !SInfo),
- report_uninitialized_state_var(Context, !.VarSet, StateVar, !IO)
+ report_uninitialized_state_var(Context, !.VarSet, StateVar, !Specs)
;
Var = StateVar,
- report_non_visible_state_var(".", Context, !.VarSet, StateVar, !IO)
+ report_non_visible_state_var(".", Context, !.VarSet, StateVar,
+ !Specs)
)
).
%-----------------------------------------------------------------------------%
-colon(Context, StateVar, Var, !VarSet, !SInfo, !IO) :-
+colon(Context, StateVar, Var, !VarSet, !SInfo, !Specs) :-
( !.SInfo ^ ctxt = in_head ->
( !.SInfo ^ colon ^ elem(StateVar) = Var0 ->
Var = Var0
@@ -379,7 +378,7 @@
;
PError = report_non_visible_state_var(":")
),
- PError(Context, !.VarSet, StateVar, !IO)
+ PError(Context, !.VarSet, StateVar, !Specs)
)
).
@@ -1001,22 +1000,22 @@
%-----------------------------------------------------------------------------%
-substitute_state_var_mappings([], [], !VarSet, !SInfo, !IO).
-substitute_state_var_mappings([Arg0 | Args0], [Arg | Args],
- !VarSet, !SInfo, !IO) :-
- substitute_state_var_mapping(Arg0, Arg, !VarSet, !SInfo, !IO),
- substitute_state_var_mappings(Args0, Args, !VarSet, !SInfo, !IO).
+substitute_state_var_mappings([], [], !VarSet, !SInfo, !Specs).
+substitute_state_var_mappings([Arg0 | Args0], [Arg | Args], !VarSet, !SInfo,
+ !Specs) :-
+ substitute_state_var_mapping(Arg0, Arg, !VarSet, !SInfo, !Specs),
+ substitute_state_var_mappings(Args0, Args, !VarSet, !SInfo, !Specs).
-substitute_state_var_mapping(Arg0, Arg, !VarSet, !SInfo, !IO) :-
+substitute_state_var_mapping(Arg0, Arg, !VarSet, !SInfo, !Specs) :-
(
Arg0 = functor(atom("!."), [variable(StateVar)], Context)
->
- dot(Context, StateVar, Var, !VarSet, !SInfo, !IO),
+ dot(Context, StateVar, Var, !VarSet, !SInfo, !Specs),
Arg = variable(Var)
;
Arg0 = functor(atom("!:"), [variable(StateVar)], Context)
->
- colon(Context, StateVar, Var, !VarSet, !SInfo, !IO),
+ colon(Context, StateVar, Var, !VarSet, !SInfo, !Specs),
Arg = variable(Var)
;
Arg = Arg0
@@ -1038,59 +1037,65 @@
%-----------------------------------------------------------------------------%
-report_illegal_state_var_update(Context, VarSet, StateVar, !IO) :-
+report_illegal_state_var_update(Context, VarSet, StateVar, !Specs) :-
Name = varset.lookup_name(VarSet, StateVar),
Pieces = [words("Error: cannot use"), fixed("!:" ++ Name),
words("in this context;"), nl,
- words("however"), fixed("!." ++ Name), words("may be used here.")],
- write_error_pieces(Context, 0, Pieces, !IO),
- io.set_exit_status(1, !IO).
+ words("however"), fixed("!." ++ Name), words("may be used here."), nl],
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
+ !:Specs = [Spec | !.Specs].
%-----------------------------------------------------------------------------%
:- pred report_non_visible_state_var(string::in, prog_context::in,
- prog_varset::in, svar::in, io::di, io::uo) is det.
+ prog_varset::in, svar::in, list(error_spec)::in, list(error_spec)::out)
+ is det.
-report_non_visible_state_var(DorC, Context, VarSet, StateVar, !IO) :-
+report_non_visible_state_var(DorC, Context, VarSet, StateVar, !Specs) :-
Name = varset.lookup_name(VarSet, StateVar),
- Pieces = [words("Error: state variable"),
- fixed("!" ++ DorC ++ Name), words("is not visible in this context.")],
- write_error_pieces(Context, 0, Pieces, !IO),
- io.set_exit_status(1, !IO).
+ Pieces = [words("Error: state variable"), fixed("!" ++ DorC ++ Name),
+ words("is not visible in this context."), nl],
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
+ !:Specs = [Spec | !.Specs].
%-----------------------------------------------------------------------------%
:- pred report_uninitialized_state_var(prog_context::in, prog_varset::in,
- svar::in, io::di, io::uo) is det.
+ svar::in, list(error_spec)::in, list(error_spec)::out) is det.
-report_uninitialized_state_var(Context, VarSet, StateVar, !IO) :-
+report_uninitialized_state_var(Context, VarSet, StateVar, !Specs) :-
Name = varset.lookup_name(VarSet, StateVar),
Pieces = [words("Warning: reference to uninitialized state variable"),
fixed("!." ++ Name), suffix("."), nl],
- write_error_pieces(Context, 0, Pieces, !IO),
- record_warning(!IO).
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_warning, phase_parse_tree_to_hlds, [Msg]),
+ !:Specs = [Spec | !.Specs].
%-----------------------------------------------------------------------------%
-report_illegal_func_svar_result(Context, VarSet, StateVar, !IO) :-
+report_illegal_func_svar_result(Context, VarSet, StateVar, !Specs) :-
Name = varset.lookup_name(VarSet, StateVar),
Pieces = [words("Error:"), fixed("!" ++ Name),
words("cannot be a function result."), nl,
words("You probably meant"), fixed("!." ++ Name),
words("or"), fixed("!:" ++ Name), suffix("."), nl],
- write_error_pieces(Context, 0, Pieces, !IO),
- io.set_exit_status(1, !IO).
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
+ !:Specs = [Spec | !.Specs].
%-----------------------------------------------------------------------------%
-report_illegal_bang_svar_lambda_arg(Context, VarSet, StateVar, !IO) :-
+report_illegal_bang_svar_lambda_arg(Context, VarSet, StateVar, !Specs) :-
Name = varset.lookup_name(VarSet, StateVar),
Pieces = [words("Error:"), fixed("!" ++ Name),
words("cannot be a lambda argument."), nl,
words("Perhaps you meant"), fixed("!." ++ Name),
words("or"), fixed("!:" ++ Name), suffix("."), nl],
- write_error_pieces(Context, 0, Pieces, !IO),
- io.set_exit_status(1, !IO).
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
+ !:Specs = [Spec | !.Specs].
%-----------------------------------------------------------------------------%
Index: compiler/stratify.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/stratify.m,v
retrieving revision 1.54
diff -u -b -r1.54 stratify.m
--- compiler/stratify.m 20 Aug 2006 08:21:29 -0000 1.54
+++ compiler/stratify.m 8 Sep 2006 02:59:09 -0000
@@ -859,33 +859,27 @@
emit_message(PPId, Context, Message, Error, !ModuleInfo, !IO) :-
PPIdDescription = describe_one_proc_name_mode(!.ModuleInfo,
should_not_module_qualify, PPId),
- ErrMsgStart = [words("In")] ++ PPIdDescription ++ [suffix(":"), nl],
+ Preamble = [words("In")] ++ PPIdDescription ++ [suffix(":"), nl],
(
Error = no,
- ErrOrWarnMsg = words("warning:")
+ ErrOrWarnMsg = words("warning:"),
+ Severity = severity_warning
;
Error = yes,
- module_info_incr_errors(!ModuleInfo),
- io.set_exit_status(1, !IO),
- ErrOrWarnMsg = words("error:")
+ ErrOrWarnMsg = words("error:"),
+ Severity = severity_error
),
- ErrMsgMiddle = [ ErrOrWarnMsg, words(Message) ],
- globals.io_lookup_bool_option(verbose_errors, VerboseErrors, !IO),
- (
- VerboseErrors = yes,
- ErrMsgFinal = [ nl,
- words("A non-stratified loop is a loop in the call graph"),
+ MainPieces = [ErrOrWarnMsg, words(Message), nl],
+ VerbosePieces =
+ [words("A non-stratified loop is a loop in the call graph"),
words("of the given predicate/function that allows it to call"),
words("itself negatively. This can cause problems for"),
- words("bottom-up evaluation of the predicate/function.")
- ]
- ;
- VerboseErrors = no,
- ErrMsgFinal = [],
- globals.io_set_extra_error_info(yes, !IO)
- ),
- ErrMsg = ErrMsgStart ++ ErrMsgMiddle ++ ErrMsgFinal,
- write_error_pieces(Context, 0, ErrMsg, !IO).
+ words("bottom-up evaluation of the predicate/function."), nl],
+ Msg = simple_msg(Context,
+ [always(Preamble ++ MainPieces), verbose_only(VerbosePieces)]),
+ Spec = error_spec(Severity, phase_code_gen, [Msg]),
+ % XXX _NumErrors
+ write_error_spec(Spec, 0, _NumWarnings, 0, _NumErrors, !IO).
%-----------------------------------------------------------------------------%
Index: compiler/superhomogeneous.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/superhomogeneous.m,v
retrieving revision 1.20
diff -u -b -r1.20 superhomogeneous.m
--- compiler/superhomogeneous.m 5 Sep 2006 06:21:31 -0000 1.20
+++ compiler/superhomogeneous.m 8 Sep 2006 07:27:32 -0000
@@ -23,10 +23,10 @@
:- import_module hlds.make_hlds.qual_info.
:- import_module hlds.make_hlds.state_var.
:- import_module mdbcomp.prim_data.
+:- import_module parse_tree.error_util.
:- import_module parse_tree.prog_data.
:- import_module assoc_list.
-:- import_module io.
:- import_module list.
%-----------------------------------------------------------------------------%
@@ -62,14 +62,15 @@
prog_context::in, arg_context::in, hlds_goal::in, hlds_goal::out,
num_added_goals::out, prog_varset::in, prog_varset::out,
module_info::in, module_info::out, qual_info::in, qual_info::out,
- svar_info::in, svar_info::out, io::di, io::uo) is det.
+ svar_info::in, svar_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
:- pred insert_arg_unifications_with_supplied_contexts(list(prog_var)::in,
list(prog_term)::in, assoc_list(int, arg_context)::in, prog_context::in,
hlds_goal::in, hlds_goal::out, num_added_goals::out,
prog_varset::in, prog_varset::out, module_info::in, module_info::out,
qual_info::in, qual_info::out, svar_info::in, svar_info::out,
- io::di, io::uo) is det.
+ list(error_spec)::in, list(error_spec)::out) is det.
% append_arg_unifications is the same as insert_arg_unifications,
% except that the unifications are added after the goal rather
@@ -79,31 +80,33 @@
prog_context::in, arg_context::in, hlds_goal::in, hlds_goal::out,
num_added_goals::out, prog_varset::in, prog_varset::out,
module_info::in, module_info::out, qual_info::in, qual_info::out,
- svar_info::in, svar_info::out, io::di, io::uo) is det.
+ svar_info::in, svar_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
:- pred unravel_unification(prog_term::in, prog_term::in, prog_context::in,
unify_main_context::in, unify_sub_contexts::in, purity::in,
hlds_goal::out, num_added_goals::out, prog_varset::in, prog_varset::out,
module_info::in, module_info::out, qual_info::in, qual_info::out,
- svar_info::in, svar_info::out, io::di, io::uo) is det.
+ svar_info::in, svar_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
- % make_fresh_arg_vars(Args, VarSet0, Vars, VarSet, !SInfo, !IO):
+ % make_fresh_arg_vars(Args, VarSet0, Vars, VarSet, !SInfo, !Specs):
%
- % `Vars' is a list of distinct variables corresponding to the terms
- % in `Args'. For each term in `Args', if the term is a variable V
- % which is distinct from the variables already produced, then the
- % corresponding variable in `Vars' is just V, otherwise a fresh variable
- % is allocated from `VarSet0'. `VarSet' is the varset resulting after
- % all the necessary variables have been allocated. !SInfo and !IO
- % are required to handle state variables.
+ % Vars is a list of distinct variables corresponding to the terms in Args.
+ % For each term in Args, if the term is a variable V which is distinct
+ % from the variables already produced, then the corresponding variable
+ % in Vars is just V, otherwise a fresh variable is allocated from VarSet0.
+ % VarSet is the varset resulting after all the necessary variables
+ % have been allocated. !SInfo and !Specs are required to handle
+ % state variables.
%
:- pred make_fresh_arg_vars(list(prog_term)::in, list(prog_var)::out,
prog_varset::in, prog_varset::out, svar_info::in, svar_info::out,
- io::di, io::uo) is det.
+ list(error_spec)::in, list(error_spec)::out) is det.
:- pred make_fresh_arg_var(prog_term::in, prog_var::out, list(prog_var)::in,
prog_varset::in, prog_varset::out, svar_info::in, svar_info::out,
- io::di, io::uo) is det.
+ list(error_spec)::in, list(error_spec)::out) is det.
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -117,7 +120,6 @@
:- import_module hlds.make_hlds.field_access.
:- import_module hlds.make_hlds.qual_info.
:- import_module libs.compiler_util.
-:- import_module parse_tree.error_util.
:- import_module parse_tree.mercury_to_mercury.
:- import_module parse_tree.module_qual.
:- import_module parse_tree.prog_io.
@@ -145,30 +147,30 @@
from_ground_term_scope_threshold = 15.
insert_arg_unifications(HeadVars, Args0, Context, ArgContext, !Goal, NumAdded,
- !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO) :-
+ !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs) :-
do_insert_arg_unifications(HeadVars, Args0, Context, ArgContext, !Goal,
yes(from_ground_term_scope_threshold), NumAdded,
- !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO).
+ !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs).
insert_arg_unifications_with_supplied_contexts(ArgVars, ArgTerms0,
ArgContexts, Context, !Goal, NumAdded, !VarSet, !ModuleInfo, !QualInfo,
- !SInfo, !IO) :-
+ !SInfo, !Specs) :-
do_insert_arg_unifications_with_supplied_contexts(ArgVars, ArgTerms0,
ArgContexts, Context,
!Goal, yes(from_ground_term_scope_threshold), NumAdded,
- !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO).
+ !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs).
append_arg_unifications(HeadVars, Args0, Context, ArgContext,
- !Goal, NumAdded, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO) :-
+ !Goal, NumAdded, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs) :-
do_append_arg_unifications(HeadVars, Args0, Context, ArgContext, !Goal,
yes(from_ground_term_scope_threshold), NumAdded,
- !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO).
+ !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs).
unravel_unification(LHS0, RHS0, Context, MainContext, SubContext, Purity,
- Goal, NumAdded, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO) :-
+ Goal, NumAdded, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs) :-
do_unravel_unification(LHS0, RHS0, Context, MainContext, SubContext,
Purity, Goal, yes(from_ground_term_scope_threshold), NumAdded,
- !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO).
+ !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs).
%-----------------------------------------------------------------------------%
@@ -177,11 +179,11 @@
hlds_goal::in, hlds_goal::out, maybe(int)::in, num_added_goals::out,
prog_varset::in, prog_varset::out, module_info::in, module_info::out,
qual_info::in, qual_info::out, svar_info::in, svar_info::out,
- io::di, io::uo) is det.
+ list(error_spec)::in, list(error_spec)::out) is det.
do_insert_arg_unifications(HeadVars, Args0, Context, ArgContext,
!Goal, MaybeThreshold, NumAdded, !VarSet, !ModuleInfo, !QualInfo,
- !SInfo, !IO) :-
+ !SInfo, !Specs) :-
(
HeadVars = [],
NumAdded = 0
@@ -189,10 +191,10 @@
HeadVars = [_ | _],
!.Goal = _ - GoalInfo0,
goal_to_conj_list(!.Goal, Goals0),
- substitute_state_var_mappings(Args0, Args, !VarSet, !SInfo, !IO),
+ substitute_state_var_mappings(Args0, Args, !VarSet, !SInfo, !Specs),
do_insert_arg_unifications_2(HeadVars, Args, Context, ArgContext,
0, Goals0, Goals, MaybeThreshold, 0, NumAdded, !VarSet, !ModuleInfo,
- !QualInfo, !SInfo, !IO),
+ !QualInfo, !SInfo, !Specs),
goal_info_set_context(Context, GoalInfo0, GoalInfo),
conj_list_to_goal(Goals, GoalInfo, !:Goal)
).
@@ -203,35 +205,35 @@
maybe(int)::in, num_added_goals::in, num_added_goals::out,
prog_varset::in, prog_varset::out, module_info::in, module_info::out,
qual_info::in, qual_info::out, svar_info::in, svar_info::out,
- io::di, io::uo) is det.
+ list(error_spec)::in, list(error_spec)::out) is det.
do_insert_arg_unifications_2([], [_ | _], _, _, _, _, _, _, !NumAdded, !VarSet,
- !ModuleInfo, !QualInfo, !SInfo, !IO) :-
+ !ModuleInfo, !QualInfo, !SInfo, !Specs) :-
unexpected(this_file, "do_insert_arg_unifications_2: length mismatch").
do_insert_arg_unifications_2([_ | _], [], _, _, _, _, _, _, !NumAdded, !VarSet,
- !ModuleInfo, !QualInfo, !SInfo, !IO) :-
+ !ModuleInfo, !QualInfo, !SInfo, !Specs) :-
unexpected(this_file, "do_insert_arg_unifications_2: length mismatch").
do_insert_arg_unifications_2([], [], _, _, _, !Goals, _, !NumAdded, !VarSet,
- !ModuleInfo, !QualInfo, !SInfo, !IO).
+ !ModuleInfo, !QualInfo, !SInfo, !Specs).
do_insert_arg_unifications_2([Var | Vars], [Arg | Args], Context, ArgContext,
N0, !Goals, MaybeThreshold, !NumAdded, !VarSet, !ModuleInfo, !QualInfo,
- !SInfo, !IO) :-
+ !SInfo, !Specs) :-
N1 = N0 + 1,
do_insert_arg_unification(Var, Arg, Context, ArgContext, N1, ArgUnifyConj,
MaybeThreshold, ArgAdded, !VarSet, !ModuleInfo, !QualInfo,
- !SInfo, !IO),
+ !SInfo, !Specs),
!:NumAdded = !.NumAdded + ArgAdded,
(
ArgUnifyConj = [],
% Allow the recursive call to be tail recursive.
do_insert_arg_unifications_2(Vars, Args, Context, ArgContext, N1,
!Goals, MaybeThreshold, !NumAdded, !VarSet, !ModuleInfo,
- !QualInfo, !SInfo, !IO)
+ !QualInfo, !SInfo, !Specs)
;
ArgUnifyConj = [_ | _],
do_insert_arg_unifications_2(Vars, Args, Context, ArgContext, N1,
!Goals, MaybeThreshold, !NumAdded, !VarSet, !ModuleInfo,
- !QualInfo, !SInfo, !IO),
+ !QualInfo, !SInfo, !Specs),
list.append(ArgUnifyConj, !.Goals, !:Goals)
).
@@ -240,11 +242,11 @@
hlds_goal::in, hlds_goal::out, maybe(int)::in, num_added_goals::out,
prog_varset::in, prog_varset::out, module_info::in, module_info::out,
qual_info::in, qual_info::out, svar_info::in, svar_info::out,
- io::di, io::uo) is det.
+ list(error_spec)::in, list(error_spec)::out) is det.
do_insert_arg_unifications_with_supplied_contexts(ArgVars, ArgTerms0,
ArgContexts, Context, !Goal, MaybeThreshold, NumAdded,
- !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO) :-
+ !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs) :-
(
ArgVars = [],
NumAdded = 0
@@ -253,10 +255,10 @@
!.Goal = _ - GoalInfo0,
goal_to_conj_list(!.Goal, GoalList0),
substitute_state_var_mappings(ArgTerms0, ArgTerms, !VarSet, !SInfo,
- !IO),
+ !Specs),
do_insert_arg_unifications_with_supplied_contexts_2(ArgVars, ArgTerms,
ArgContexts, Context, GoalList0, GoalList, MaybeThreshold,
- 0, NumAdded, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
+ 0, NumAdded, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs),
goal_info_set_context(Context, GoalInfo0, GoalInfo),
conj_list_to_goal(GoalList, GoalInfo, !:Goal)
).
@@ -267,11 +269,11 @@
maybe(int)::in, num_added_goals::in, num_added_goals::out,
prog_varset::in, prog_varset::out, module_info::in, module_info::out,
qual_info::in, qual_info::out, svar_info::in, svar_info::out,
- io::di, io::uo) is det.
+ list(error_spec)::in, list(error_spec)::out) is det.
do_insert_arg_unifications_with_supplied_contexts_2(Vars, Terms, ArgContexts,
Context, !Goals, MaybeThreshold, !NumAdded, !VarSet, !ModuleInfo,
- !QualInfo, !SInfo, !IO) :-
+ !QualInfo, !SInfo, !Specs) :-
(
Vars = [],
Terms = [],
@@ -285,11 +287,11 @@
->
do_insert_arg_unification(Var, Term, Context, ArgContext, ArgNumber,
UnifyConj, MaybeThreshold, ArgAdded, !VarSet, !ModuleInfo,
- !QualInfo, !SInfo, !IO),
+ !QualInfo, !SInfo, !Specs),
!:NumAdded = !.NumAdded + ArgAdded,
do_insert_arg_unifications_with_supplied_contexts_2(VarsTail,
TermsTail, ArgContextsTail, Context, !Goals, MaybeThreshold,
- !NumAdded, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
+ !NumAdded, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs),
list.append(UnifyConj, !.Goals, !:Goals)
;
unexpected(this_file, "insert_arg_unifications_with_supplied_contexts")
@@ -299,11 +301,12 @@
arg_context::in, int::in, list(hlds_goal)::out, maybe(int)::in,
num_added_goals::out, prog_varset::in, prog_varset::out,
module_info::in, module_info::out, qual_info::in, qual_info::out,
- svar_info::in, svar_info::out, io::di, io::uo) is det.
+ svar_info::in, svar_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
do_insert_arg_unification(Var, Arg, Context, ArgContext, N1, ArgUnifyConj,
MaybeThreshold, NumAdded, !VarSet, !ModuleInfo, !QualInfo,
- !SInfo, !IO) :-
+ !SInfo, !Specs) :-
( Arg = term.variable(Var) ->
% Skip unifications of the form `X = X'
ArgUnifyConj = [],
@@ -314,7 +317,7 @@
do_unravel_unification(term.variable(Var), Arg, Context,
UnifyMainContext, UnifySubContext, purity_pure, Goal,
MaybeThreshold, NumAdded, !VarSet, !ModuleInfo, !QualInfo,
- !SInfo, !IO),
+ !SInfo, !Specs),
goal_to_conj_list(Goal, ArgUnifyConj)
).
@@ -323,11 +326,11 @@
hlds_goal::in, hlds_goal::out, maybe(int)::in, num_added_goals::out,
prog_varset::in, prog_varset::out, module_info::in, module_info::out,
qual_info::in, qual_info::out, svar_info::in, svar_info::out,
- io::di, io::uo) is det.
+ list(error_spec)::in, list(error_spec)::out) is det.
do_append_arg_unifications(HeadVars, Args0, Context, ArgContext, !Goal,
MaybeThreshold, NumAdded, !VarSet, !ModuleInfo, !QualInfo,
- !SInfo, !IO) :-
+ !SInfo, !Specs) :-
(
HeadVars = [],
NumAdded = 0
@@ -335,10 +338,10 @@
HeadVars = [_ | _],
!.Goal = _ - GoalInfo,
goal_to_conj_list(!.Goal, GoalList0),
- substitute_state_var_mappings(Args0, Args, !VarSet, !SInfo, !IO),
+ substitute_state_var_mappings(Args0, Args, !VarSet, !SInfo, !Specs),
do_append_arg_unifications_2(HeadVars, Args, Context, ArgContext,
0, GoalList0, GoalList, MaybeThreshold, 0, NumAdded,
- !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
+ !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs),
conj_list_to_goal(GoalList, GoalInfo, !:Goal)
).
@@ -348,39 +351,39 @@
maybe(int)::in, num_added_goals::in, num_added_goals::out,
prog_varset::in, prog_varset::out, module_info::in, module_info::out,
qual_info::in, qual_info::out, svar_info::in, svar_info::out,
- io::di, io::uo) is det.
+ list(error_spec)::in, list(error_spec)::out) is det.
do_append_arg_unifications_2([], [_ | _], _, _, _, _, _, _, !NumAdded,
- !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO) :-
+ !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs) :-
unexpected(this_file, "do_append_arg_unifications_2: length mismatch").
do_append_arg_unifications_2([_ | _], [], _, _, _, _, _, _, !NumAdded,
- !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO) :-
+ !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs) :-
unexpected(this_file, "do_append_arg_unifications_2: length mismatch").
do_append_arg_unifications_2([], [], _, _, _, !GoalList, _, !NumAdded,
- !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO).
+ !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs).
do_append_arg_unifications_2([Var | Vars], [Arg | Args], Context, ArgContext,
N0, !GoalList, MaybeThreshold, !NumAdded, !VarSet, !ModuleInfo,
- !QualInfo, !SInfo, !IO) :-
+ !QualInfo, !SInfo, !Specs) :-
N1 = N0 + 1,
do_append_arg_unification(Var, Arg, Context, ArgContext, N1, ConjList,
MaybeThreshold, ArgAdded, !VarSet, !ModuleInfo, !QualInfo,
- !SInfo, !IO),
+ !SInfo, !Specs),
!:NumAdded = !.NumAdded + ArgAdded,
list.append(!.GoalList, ConjList, !:GoalList),
do_append_arg_unifications_2(Vars, Args, Context, ArgContext, N1,
!GoalList, MaybeThreshold, !NumAdded, !VarSet, !ModuleInfo,
- !QualInfo, !SInfo, !IO).
+ !QualInfo, !SInfo, !Specs).
:- pred do_append_arg_unification(prog_var::in, prog_term::in,
prog_context::in, arg_context::in, int::in, list(hlds_goal)::out,
maybe(int)::in, num_added_goals::out,
prog_varset::in, prog_varset::out, module_info::in, module_info::out,
qual_info::in, qual_info::out, svar_info::in, svar_info::out,
- io::di, io::uo) is det.
+ list(error_spec)::in, list(error_spec)::out) is det.
do_append_arg_unification(Var, Arg, Context, ArgContext, N1, ConjList,
MaybeThreshold, NumAdded, !VarSet, !ModuleInfo, !QualInfo,
- !SInfo, !IO) :-
+ !SInfo, !Specs) :-
( Arg = term.variable(Var) ->
% Skip unifications of the form `X = X'.
ConjList = [],
@@ -391,7 +394,7 @@
do_unravel_unification(term.variable(Var), Arg, Context,
UnifyMainContext, UnifySubContext, purity_pure, Goal,
MaybeThreshold, NumAdded, !VarSet, !ModuleInfo, !QualInfo,
- !SInfo, !IO),
+ !SInfo, !Specs),
goal_to_conj_list(Goal, ConjList)
).
@@ -402,16 +405,16 @@
hlds_goal::out, maybe(int)::in, num_added_goals::out,
prog_varset::in, prog_varset::out, module_info::in, module_info::out,
qual_info::in, qual_info::out, svar_info::in, svar_info::out,
- io::di, io::uo) is det.
+ list(error_spec)::in, list(error_spec)::out) is det.
do_unravel_unification(LHS0, RHS0, Context, MainContext, SubContext, Purity,
Goal, MaybeThreshold, NumAdded, !VarSet, !ModuleInfo, !QualInfo,
- !SInfo, !IO) :-
- substitute_state_var_mapping(LHS0, LHS, !VarSet, !SInfo, !IO),
- substitute_state_var_mapping(RHS0, RHS, !VarSet, !SInfo, !IO),
+ !SInfo, !Specs) :-
+ substitute_state_var_mapping(LHS0, LHS, !VarSet, !SInfo, !Specs),
+ substitute_state_var_mapping(RHS0, RHS, !VarSet, !SInfo, !Specs),
classify_unravel_unification(LHS, RHS, Context, MainContext, SubContext,
Purity, Goal0, NumAdded, !VarSet, !ModuleInfo, !QualInfo,
- !SInfo, !IO),
+ !SInfo, !Specs),
(
MaybeThreshold = yes(Threshold),
NumAdded > Threshold,
@@ -429,11 +432,11 @@
purity::in, hlds_goal::out, num_added_goals::out,
prog_varset::in, prog_varset::out, module_info::in, module_info::out,
qual_info::in, qual_info::out, svar_info::in, svar_info::out,
- io::di, io::uo) is det.
+ list(error_spec)::in, list(error_spec)::out) is det.
classify_unravel_unification(TermX, TermY, Context, MainContext, SubContext,
Purity, Goal, NumAdded, !VarSet, !ModuleInfo, !QualInfo, !SInfo,
- !IO) :-
+ !Specs) :-
(
% `X = Y' needs no unravelling.
TermX = term.variable(X),
@@ -446,13 +449,13 @@
TermY = term.functor(F, Args, FunctorContext),
unravel_var_functor_unification(X, F, Args, FunctorContext,
Context, MainContext, SubContext, Purity, Goal, NumAdded,
- !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO)
+ !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs)
;
TermX = term.functor(F, Args, FunctorContext),
TermY = term.variable(Y),
unravel_var_functor_unification(Y, F, Args, FunctorContext,
Context, MainContext, SubContext, Purity, Goal, NumAdded,
- !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO)
+ !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs)
;
% If we find a unification of the form `f1(...) = f2(...)',
% then we replace it with `Tmp = f1(...), Tmp = f2(...)',
@@ -464,10 +467,10 @@
varset.new_var(!.VarSet, TmpVar, !:VarSet),
do_unravel_unification(term.variable(TmpVar), TermX,
Context, MainContext, SubContext, Purity, GoalX, no, NumAddedX,
- !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
+ !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs),
do_unravel_unification(term.variable(TmpVar), TermY,
Context, MainContext, SubContext, Purity, GoalY, no, NumAddedY,
- !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
+ !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs),
goal_to_conj_list(GoalX, ConjListX),
goal_to_conj_list(GoalY, ConjListY),
ConjList = ConjListX ++ ConjListY,
@@ -494,12 +497,12 @@
purity::in, hlds_goal::out, num_added_goals::out,
prog_varset::in, prog_varset::out, module_info::in, module_info::out,
qual_info::in, qual_info::out, svar_info::in, svar_info::out,
- io::di, io::uo) is det.
+ list(error_spec)::in, list(error_spec)::out) is det.
unravel_var_functor_unification(X, F, Args1, FunctorContext,
Context, MainContext, SubContext, Purity, Goal, NumAdded,
- !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO) :-
- substitute_state_var_mappings(Args1, Args, !VarSet, !SInfo, !IO),
+ !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs) :-
+ substitute_state_var_mappings(Args1, Args, !VarSet, !SInfo, !Specs),
(
% Handle explicit type qualification.
(
@@ -516,8 +519,8 @@
(
DeclTypeResult = ok1(DeclType),
varset.coerce(!.VarSet, DeclVarSet),
- process_type_qualification(X, DeclType, DeclVarSet,
- Context, !ModuleInfo, !QualInfo, !IO)
+ process_type_qualification(X, DeclType, DeclVarSet, Context,
+ !ModuleInfo, !QualInfo, !Specs)
;
DeclTypeResult = error1(Errors),
% The varset is a prog_varset even though it contains the names
@@ -525,11 +528,11 @@
GenericVarSet = varset.coerce(!.VarSet),
list.foldl(
report_error_in_type_qualification(GenericVarSet, Context),
- Errors, !IO)
+ Errors, !Specs)
),
do_unravel_unification(term.variable(X), RVal, Context, MainContext,
SubContext, Purity, Goal, no, NumAdded, !VarSet, !ModuleInfo,
- !QualInfo, !SInfo, !IO)
+ !QualInfo, !SInfo, !Specs)
;
% Handle unification expressions.
F = term.atom("@"),
@@ -537,10 +540,10 @@
->
do_unravel_unification(term.variable(X), LVal, Context,
MainContext, SubContext, Purity, Goal1, no, NumAdded1,
- !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
+ !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs),
do_unravel_unification(term.variable(X), RVal, Context,
MainContext, SubContext, Purity, Goal2, no, NumAdded2,
- !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
+ !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs),
NumAdded = NumAdded1 + NumAdded2,
goal_info_init(GoalInfo),
goal_to_conj_list(Goal1, ConjList1),
@@ -566,7 +569,7 @@
)
->
qualify_lambda_mode_list_if_not_opt_imported(Modes1, Modes, Context,
- !QualInfo, !IO),
+ !QualInfo, !Specs),
Det = Det1,
term.coerce(GoalTerm1, GoalTerm),
parse_goal(GoalTerm, MaybeParsedGoal, !VarSet),
@@ -575,12 +578,12 @@
build_lambda_expression(X, Purity, LambdaPurity, PredOrFunc,
EvalMethod, Vars1, Modes, Det, ParsedGoal,
Context, MainContext, SubContext, Goal, NumAdded,
- !VarSet, !ModuleInfo, !QualInfo, !.SInfo, !IO)
+ !VarSet, !ModuleInfo, !QualInfo, !.SInfo, !Specs)
;
MaybeParsedGoal = error1(Errors),
varset.coerce(!.VarSet, ProgVarSet),
list.foldl(report_string_term_error(Context, ProgVarSet), Errors,
- !IO),
+ !Specs),
NumAdded = 0,
Goal = true_goal
)
@@ -595,7 +598,7 @@
parse_dcg_pred_expression(PredTerm, EvalMethod, Vars0, Modes0, Det)
->
qualify_lambda_mode_list_if_not_opt_imported(Modes0, Modes, Context,
- !QualInfo, !IO),
+ !QualInfo, !Specs),
term.coerce(GoalTerm0, GoalTerm),
parse_dcg_pred_goal(GoalTerm, MaybeParsedGoal, DCG0, DCGn, !VarSet),
(
@@ -604,7 +607,7 @@
build_lambda_expression(X, Purity, DCGLambdaPurity, predicate,
EvalMethod, Vars1, Modes, Det, ParsedGoal, Context, MainContext,
SubContext, Goal0, NumAdded, !VarSet, !ModuleInfo, !QualInfo,
- !.SInfo, !IO),
+ !.SInfo, !Specs),
Goal0 = GoalExpr - GoalInfo0,
goal_info_set_purity(Purity, GoalInfo0, GoalInfo),
Goal = GoalExpr - GoalInfo
@@ -612,7 +615,7 @@
MaybeParsedGoal = error1(Errors),
varset.coerce(!.VarSet, ProgVarSet),
list.foldl(report_string_term_error(Context, ProgVarSet), Errors,
- !IO),
+ !Specs),
NumAdded = 0,
Goal = true_goal
)
@@ -639,19 +642,19 @@
map.init(EmptySubst),
transform_goal(CondParseTree, EmptySubst, CondGoal, CondAdded,
- !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
+ !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs),
finish_if_then_else_expr_condition(BeforeSInfo, !SInfo),
do_unravel_unification(term.variable(X), ThenTerm,
Context, MainContext, SubContext, Purity, ThenGoal, no,
- ThenAdded, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
+ ThenAdded, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs),
finish_if_then_else_expr_then_goal(StateVars, BeforeSInfo, !SInfo),
do_unravel_unification(term.variable(X), ElseTerm,
Context, MainContext, SubContext, Purity, ElseGoal, no,
- ElseAdded, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
+ ElseAdded, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs),
NumAdded = CondAdded + ThenAdded + ElseAdded,
GoalExpr = if_then_else(StateVars ++ Vars,
@@ -662,7 +665,7 @@
MaybeVarsCond = error3(Errors),
varset.coerce(!.VarSet, ProgVarSet),
list.foldl(report_string_term_error(Context, ProgVarSet), Errors,
- !IO),
+ !Specs),
NumAdded = 0,
Goal = true_goal
)
@@ -673,15 +676,16 @@
parse_field_list(FieldNameTerm, FieldNameResult),
FieldNameResult = ok1(FieldNames)
->
- make_fresh_arg_var(InputTerm, InputTermVar, [], !VarSet, !SInfo, !IO),
+ make_fresh_arg_var(InputTerm, InputTermVar, [], !VarSet, !SInfo,
+ !Specs),
expand_get_field_function_call(Context, MainContext, SubContext,
FieldNames, X, InputTermVar, Purity, Functor, _, Goal0, CallAdded,
- !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
+ !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs),
ArgContext = ac_functor(Functor, MainContext, SubContext),
do_insert_arg_unifications([InputTermVar], [InputTerm],
FunctorContext, ArgContext, Goal0, Goal, no, ArgAdded,
- !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
+ !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs),
NumAdded = CallAdded + ArgAdded
;
% Handle field update expressions.
@@ -692,14 +696,15 @@
parse_field_list(FieldNameTerm, FieldNameResult),
FieldNameResult = ok1(FieldNames)
->
- make_fresh_arg_var(InputTerm, InputTermVar, [], !VarSet, !SInfo, !IO),
+ make_fresh_arg_var(InputTerm, InputTermVar, [], !VarSet, !SInfo,
+ !Specs),
make_fresh_arg_var(FieldValueTerm, FieldValueVar, [InputTermVar],
- !VarSet, !SInfo, !IO),
+ !VarSet, !SInfo, !Specs),
expand_set_field_function_call(Context, MainContext, SubContext,
FieldNames, FieldValueVar, InputTermVar, X,
Functor, InnerFunctor - FieldSubContext, Goal0, CallAdded,
- !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
+ !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs),
TermArgContext = ac_functor(Functor, MainContext, SubContext),
TermArgNumber = 1,
@@ -711,7 +716,7 @@
do_insert_arg_unifications_with_supplied_contexts(
[InputTermVar, FieldValueVar], [InputTerm, FieldValueTerm],
ArgContexts, Context, Goal0, Goal, no, ArgAdded, !VarSet,
- !ModuleInfo, !QualInfo, !SInfo, !IO),
+ !ModuleInfo, !QualInfo, !SInfo, !Specs),
NumAdded = CallAdded + ArgAdded
;
% Handle the usual case.
@@ -744,7 +749,8 @@
Goal = GoalExpr - GoalInfo
;
FunctorArgs = [_ | _],
- make_fresh_arg_vars(FunctorArgs, HeadVars, !VarSet, !SInfo, !IO),
+ make_fresh_arg_vars(FunctorArgs, HeadVars, !VarSet, !SInfo,
+ !Specs),
make_atomic_unification(X, rhs_functor(ConsId, no, HeadVars),
Context, MainContext, SubContext, Purity, Goal0, !QualInfo),
MainFunctorAdded = 1,
@@ -757,29 +763,49 @@
( Purity = purity_pure ->
do_append_arg_unifications(HeadVars, FunctorArgs,
FunctorContext, ArgContext, Goal0, Goal, no, ArgAdded,
- !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO)
+ !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs)
;
Goal0 = GoalExpr0 - GoalInfo0,
goal_info_set_purity(Purity, GoalInfo0, GoalInfo1),
Goal1 = GoalExpr0 - GoalInfo1,
do_insert_arg_unifications(HeadVars, FunctorArgs,
FunctorContext, ArgContext, Goal1, Goal, no, ArgAdded,
- !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO)
+ !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs)
),
NumAdded = MainFunctorAdded + ArgAdded
)
).
+:- pred qualify_lambda_mode_list_if_not_opt_imported(
+ list(mer_mode)::in, list(mer_mode)::out, prog_context::in,
+ qual_info::in, qual_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
+
+qualify_lambda_mode_list_if_not_opt_imported(Modes0, Modes, Context,
+ !QualInfo, !Specs) :-
+ % The modes in `.opt' files are already fully module qualified.
+ qual_info_get_import_status(!.QualInfo, ImportStatus),
+ ( ImportStatus \= status_opt_imported ->
+ qual_info_get_mq_info(!.QualInfo, MQInfo0),
+ qualify_lambda_mode_list(Modes0, Modes, Context, MQInfo0, MQInfo,
+ !Specs),
+ qual_info_set_mq_info(MQInfo, !QualInfo)
+ ;
+ Modes = Modes0
+ ).
+
:- pred report_error_in_type_qualification(varset::in, term.context::in,
- pair(string, term)::in, io::di, io::uo) is det.
+ pair(string, term)::in, list(error_spec)::in, list(error_spec)::out)
+ is det.
-report_error_in_type_qualification(GenericVarSet, Context, Error, !IO) :-
- Error = Msg - ErrorTerm,
+report_error_in_type_qualification(GenericVarSet, Context, Error, !Specs) :-
+ Error = ErrorMsg - ErrorTerm,
TermStr = mercury_term_to_string(ErrorTerm, GenericVarSet, no),
Pieces = [words("In explicit type qualification:"),
- words(Msg), suffix(":"), fixed("`" ++ TermStr ++ "'.")],
- write_error_pieces(Context, 0, Pieces, !IO),
- io.set_exit_status(1, !IO).
+ 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].
%-----------------------------------------------------------------------------%
%
@@ -792,12 +818,12 @@
unify_main_context::in, unify_sub_contexts::in,
hlds_goal::out, num_added_goals::out, prog_varset::in, prog_varset::out,
module_info::in, module_info::out, qual_info::in, qual_info::out,
- svar_info::in, io::di, io::uo) is det.
+ svar_info::in, list(error_spec)::in, list(error_spec)::out) is det.
build_lambda_expression(X, UnificationPurity, LambdaPurity, PredOrFunc,
EvalMethod, Args0, Modes, Det, ParsedGoal,
Context, MainContext, SubContext, Goal, NumAdded,
- !VarSet, !ModuleInfo, !QualInfo, !.SInfo, !IO) :-
+ !VarSet, !ModuleInfo, !QualInfo, !.SInfo, !Specs) :-
% In the parse tree, the lambda arguments can be any terms, but in the HLDS
% they must be distinct variables. So we introduce fresh variables
% for the lambda arguments, and add appropriate unifications.
@@ -844,16 +870,17 @@
% to avoid the function result term becoming lambda-quantified.
( illegal_state_var_func_result(PredOrFunc, Args0, StateVar) ->
- report_illegal_func_svar_result(Context, !.VarSet, StateVar, !IO),
+ report_illegal_func_svar_result(Context, !.VarSet, StateVar, !Specs),
Goal = true_goal,
NumAdded = 0
; lambda_args_contain_bang_state_var(Args0, StateVar) ->
- report_illegal_bang_svar_lambda_arg(Context, !.VarSet, StateVar, !IO),
+ report_illegal_bang_svar_lambda_arg(Context, !.VarSet, StateVar,
+ !Specs),
Goal = true_goal,
NumAdded = 0
;
prepare_for_lambda(!SInfo),
- substitute_state_var_mappings(Args0, Args, !VarSet, !SInfo, !IO),
+ substitute_state_var_mappings(Args0, Args, !VarSet, !SInfo, !Specs),
list.length(Args, NumArgs),
svvarset.new_vars(NumArgs, LambdaVars, !VarSet),
@@ -886,7 +913,7 @@
HeadBefore0 = true_goal,
insert_arg_unifications(NonOutputLambdaVars, NonOutputArgs,
Context, ArgContext, HeadBefore0, HeadBefore, NonOutputAdded,
- !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
+ !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs),
%
% Create the unifications that need to come after the body of
% the lambda expression; those corresponding to args whose mode
@@ -895,12 +922,12 @@
HeadAfter0 = true_goal,
insert_arg_unifications(OutputLambdaVars, OutputArgs,
Context, ArgContext, HeadAfter0, HeadAfter, OutputAdded,
- !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
+ !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs),
prepare_for_body(FinalSVarMap, !VarSet, !SInfo),
transform_goal(ParsedGoal, Substitution, Body, BodyAdded,
- !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
+ !VarSet, !ModuleInfo, !QualInfo, !SInfo, !Specs),
NumAdded = NonOutputAdded + OutputAdded + BodyAdded,
%
@@ -1015,23 +1042,24 @@
%-----------------------------------------------------------------------------%
-make_fresh_arg_vars(Args, Vars, !VarSet, !SInfo, !IO) :-
+make_fresh_arg_vars(Args, Vars, !VarSet, !SInfo, !Specs) :-
% For efficiency, we construct `Vars' backwards and then reverse it
% to get the correct order.
- make_fresh_arg_vars_2(Args, [], Vars1, !VarSet, !SInfo, !IO),
+ make_fresh_arg_vars_2(Args, [], Vars1, !VarSet, !SInfo, !Specs),
list.reverse(Vars1, Vars).
:- pred make_fresh_arg_vars_2(list(prog_term)::in, list(prog_var)::in,
list(prog_var)::out, prog_varset::in,prog_varset::out,
- svar_info::in, svar_info::out, io::di, io::uo) is det.
+ svar_info::in, svar_info::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
-make_fresh_arg_vars_2([], Vars, Vars, !VarSet, !SInfo, !IO).
-make_fresh_arg_vars_2([Arg | Args], Vars0, Vars, !VarSet, !SInfo, !IO) :-
- make_fresh_arg_var(Arg, Var, Vars0, !VarSet, !SInfo, !IO),
- make_fresh_arg_vars_2(Args, [Var | Vars0], Vars, !VarSet, !SInfo, !IO).
+make_fresh_arg_vars_2([], Vars, Vars, !VarSet, !SInfo, !Specs).
+make_fresh_arg_vars_2([Arg | Args], Vars0, Vars, !VarSet, !SInfo, !Specs) :-
+ make_fresh_arg_var(Arg, Var, Vars0, !VarSet, !SInfo, !Specs),
+ make_fresh_arg_vars_2(Args, [Var | Vars0], Vars, !VarSet, !SInfo, !Specs).
-make_fresh_arg_var(Arg0, Var, Vars0, !VarSet, !SInfo, !IO) :-
- substitute_state_var_mapping(Arg0, Arg, !VarSet, !SInfo, !IO),
+make_fresh_arg_var(Arg0, Var, Vars0, !VarSet, !SInfo, !Specs) :-
+ substitute_state_var_mapping(Arg0, Arg, !VarSet, !SInfo, !Specs),
(
Arg = term.variable(ArgVar),
\+ list.member(ArgVar, Vars0)
@@ -1043,6 +1071,20 @@
%-----------------------------------------------------------------------------%
+:- 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(ErrorTerm, VarSet, no),
+ 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/table_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/table_gen.m,v
retrieving revision 1.119
diff -u -b -r1.119 table_gen.m
--- compiler/table_gen.m 30 Aug 2006 04:46:02 -0000 1.119
+++ compiler/table_gen.m 8 Sep 2006 02:30:52 -0000
@@ -185,9 +185,8 @@
PredModuleName, AnnotationIsMissing, TransformPrimitive),
(
AnnotationIsMissing = yes,
- report_missing_tabled_for_io(!.ModuleInfo, PredInfo0,
- PredId, ProcId, !IO),
- module_info_incr_errors(!ModuleInfo)
+ report_missing_tabled_for_io(PredInfo0, PredId, ProcId,
+ !ModuleInfo, !IO)
;
AnnotationIsMissing = no
),
@@ -308,45 +307,18 @@
\+ TabledForIoAttr = proc_not_tabled_for_io
).
-:- pred report_missing_tabled_for_io(module_info::in, pred_info::in,
- pred_id::in, proc_id::in, io::di, io::uo) is det.
+:- pred report_missing_tabled_for_io(pred_info::in, pred_id::in, proc_id::in,
+ module_info::in, module_info::out, io::di, io::uo) is det.
-report_missing_tabled_for_io(ModuleInfo, PredInfo, PredId, ProcId, !IO) :-
+report_missing_tabled_for_io(PredInfo, PredId, ProcId, !ModuleInfo, !IO) :-
pred_info_context(PredInfo, Context),
- ProcPieces = describe_one_proc_name(ModuleInfo, should_module_qualify,
- proc(PredId, ProcId)),
- Msg = ProcPieces ++ [words("contains untabled I/O primitive.")],
- error_util.write_error_pieces(Context, 0, Msg, !IO).
-
-:- pred report_bad_mode_for_tabling(module_info::in, pred_info::in,
- pred_id::in, proc_id::in, prog_varset::in, list(prog_var)::in,
- io::di, io::uo) is det.
-
-report_bad_mode_for_tabling(ModuleInfo, PredInfo, PredId, ProcId, VarSet, Vars,
- !IO) :-
- pred_info_context(PredInfo, Context),
- ProcPieces = describe_one_proc_name(ModuleInfo, should_module_qualify,
- proc(PredId, ProcId)),
- lookup_var_names(VarSet, Vars, VarNames),
- Msg = ProcPieces ++ [words("contains arguments"),
- words("whose mode is incompatible with tabling;"), nl,
- words("these arguments are"), words(VarNames)],
- error_util.write_error_pieces(Context, 0, Msg, !IO).
-
-:- pred lookup_var_names(prog_varset::in, list(prog_var)::in, string::out)
- is det.
-
-lookup_var_names(_, [], "").
-lookup_var_names(VarSet, [Var | Vars], Description) :-
- varset.lookup_name(VarSet, Var, Name),
- (
- Vars = [],
- Description = Name
- ;
- Vars = [_ | _],
- lookup_var_names(VarSet, Vars, Description0),
- Description = Name ++ ", " ++ Description0
- ).
+ ProcPieces = describe_one_proc_name(!.ModuleInfo,
+ should_not_module_qualify, proc(PredId, ProcId)),
+ Pieces = ProcPieces ++ [words("contains untabled I/O primitive."), nl],
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_code_gen, [Msg]),
+ write_error_spec(Spec, 0, _NumWarnings, 0, NumErrors, !IO),
+ module_info_incr_num_errors(NumErrors, !ModuleInfo).
%-----------------------------------------------------------------------------%
@@ -363,17 +335,18 @@
table_gen_transform_proc(EvalMethod, PredId, ProcId,
!ProcInfo, !PredInfo, !ModuleInfo, !GenMap, !IO)
;
- % We don't want to increment the error count, since that would combine
- % with --halt-at-warn to prevent the clean compilation of the library.
-
pred_info_context(!.PredInfo, Context),
ProcPieces = describe_one_proc_name(!.ModuleInfo,
should_module_qualify, proc(PredId, ProcId)),
EvalMethodStr = eval_method_to_string(EvalMethod),
- Msg = [words("Ignoring the pragma"), fixed(EvalMethodStr),
+ Pieces = [words("Ignoring the pragma"), fixed(EvalMethodStr),
words("for")] ++ ProcPieces ++
[words("due to lack of support on this back end."), nl],
- error_util.write_error_pieces(Context, 0, Msg, !IO),
+ Msg = simple_msg(Context, [always(Pieces)]),
+ % We don't want to increment the error count, since that would combine
+ % with --halt-at-warn to prevent the clean compilation of the library.
+ Spec = error_spec(severity_informational, phase_code_gen, [Msg]),
+ write_error_spec(Spec, 0, _NumWarnings, 0, _NumErrors, !IO),
% XXX We set the evaluation method to eval_normal here to prevent
% problems in the ml code generator if we are compiling in a grade
Index: compiler/unused_args.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/unused_args.m,v
retrieving revision 1.134
diff -u -b -r1.134 unused_args.m
--- compiler/unused_args.m 22 Aug 2006 05:04:14 -0000 1.134
+++ compiler/unused_args.m 8 Sep 2006 06:19:15 -0000
@@ -1851,7 +1851,10 @@
Pieces2 = [words("arguments") | format_arg_list(UnusedArgs)] ++
[words("are unused."), nl]
),
- write_error_pieces(Context, 0, Pieces1 ++ Pieces2, !IO).
+ Msg = simple_msg(Context, [always(Pieces1 ++ Pieces2)]),
+ Spec = error_spec(severity_warning, phase_code_gen, [Msg]),
+ % XXX _NumErrors
+ write_error_spec(Spec, 0, _NumWarnings, 0, _NumErrors, !IO).
:- func format_arg_list(list(int)) = list(format_component).
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/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/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_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/logged_output
cvs diff: Diffing extras/moose
cvs diff: Diffing extras/moose/samples
cvs diff: Diffing extras/moose/tests
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/odbc
cvs diff: Diffing extras/posix
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/stream
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
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/diff
cvs diff: Diffing samples/muz
cvs diff: Diffing samples/rot13
cvs diff: Diffing samples/solutions
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 tests
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/errors.err_exp
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/invalid/errors.err_exp,v
retrieving revision 1.16
diff -u -b -r1.16 errors.err_exp
--- tests/invalid/errors.err_exp 7 Sep 2006 05:51:26 -0000 1.16
+++ tests/invalid/errors.err_exp 9 Sep 2006 07:01:34 -0000
@@ -2,8 +2,8 @@
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:001: Warning: interface for module `errors' does not export anything.
-errors.m:001: Warning: module `int' is imported using both
-errors.m:001: `:- import_module' and `:- use_module' declarations.
+errors.m:001: Warning: module `int' is imported using both `:- import_module'
+errors.m:001: `:- use_module' declarations.
errors.m:051: In definition of type
errors.m:051: `errors.du_type_which_references_undefined_type'/0:
errors.m:051: error: undefined type `undefined_type'/0.
@@ -23,13 +23,13 @@
errors.m:032: Error: mode declaration for predicate
errors.m:032: `errors.missing_pred_declaration'/0
errors.m:032: without preceding `pred' declaration.
+errors.m:038: Error: clause for predicate
+errors.m:038: `errors.clause_without_pred_or_mode_declaration'/0
+errors.m:038: without preceding `pred' declaration.
errors.m:049: Error: constructor `errors.a/0' for type
errors.m:049: `errors.type_with_multiply_defined_ctors/0' multiply defined.
errors.m:049: Error: constructor `errors.f/1' for type
errors.m:049: `errors.type_with_multiply_defined_ctors/0' multiply defined.
-errors.m:038: Error: clause for predicate
-errors.m:038: `errors.clause_without_pred_or_mode_declaration'/0
-errors.m:038: without preceding `pred' declaration.
errors.m:075: In clause for predicate
errors.m:075: `errors.pred_with_unresolved_polymorphism'/0:
errors.m:075: warning: variable `Arg' occurs only once in this scope.
Index: tests/invalid/errors1.err_exp
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/invalid/errors1.err_exp,v
retrieving revision 1.13
diff -u -b -r1.13 errors1.err_exp
--- tests/invalid/errors1.err_exp 7 Sep 2006 05:51:26 -0000 1.13
+++ tests/invalid/errors1.err_exp 8 Sep 2006 17:44:22 -0000
@@ -17,13 +17,13 @@
errors1.m:032: Error: mode declaration for predicate
errors1.m:032: `errors1.missing_pred_declaration'/0
errors1.m:032: without preceding `pred' declaration.
+errors1.m:038: Error: clause for predicate
+errors1.m:038: `errors1.clause_without_pred_or_mode_declaration'/0
+errors1.m:038: without preceding `pred' declaration.
errors1.m:049: Error: constructor `errors1.a/0' for type
errors1.m:049: `errors1.type_with_multiply_defined_ctors/0' multiply defined.
errors1.m:049: Error: constructor `errors1.f/1' for type
errors1.m:049: `errors1.type_with_multiply_defined_ctors/0' multiply defined.
-errors1.m:038: Error: clause for predicate
-errors1.m:038: `errors1.clause_without_pred_or_mode_declaration'/0
-errors1.m:038: without preceding `pred' declaration.
errors1.m:072: In clause for predicate
errors1.m:072: `errors1.pred_with_unresolved_polymorphism'/0:
errors1.m:072: warning: variable `Arg' occurs only once in this scope.
Index: tests/invalid/missing_det_decls.err_exp
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/invalid/missing_det_decls.err_exp,v
retrieving revision 1.13
diff -u -b -r1.13 missing_det_decls.err_exp
Index: tests/invalid/missing_interface_import2.err_exp
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/invalid/missing_interface_import2.err_exp,v
retrieving revision 1.3
diff -u -b -r1.3 missing_interface_import2.err_exp
--- tests/invalid/missing_interface_import2.err_exp 14 Sep 2005 05:26:48 -0000 1.3
+++ tests/invalid/missing_interface_import2.err_exp 8 Sep 2006 17:43:57 -0000
@@ -9,8 +9,3 @@
missing_interface_import2.m:009: error: undefined type `io.state'/0.
missing_interface_import2.m:009: (The module `io' has not been imported in
missing_interface_import2.m:009: the interface.)
-missing_interface_import2.m:009: In definition of predicate
-missing_interface_import2.m:009: `missing_interface_import2.write_key'/3:
-missing_interface_import2.m:009: error: undefined type `io.state'/0.
-missing_interface_import2.m:009: (The module `io' has not been imported in
-missing_interface_import2.m:009: the interface.)
Index: tests/invalid/multimode_syntax.err_exp
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/invalid/multimode_syntax.err_exp,v
retrieving revision 1.8
diff -u -b -r1.8 multimode_syntax.err_exp
--- tests/invalid/multimode_syntax.err_exp 7 Sep 2006 05:51:30 -0000 1.8
+++ tests/invalid/multimode_syntax.err_exp 8 Sep 2006 17:44:41 -0000
@@ -6,34 +6,29 @@
multimode_syntax.m:019: In clause for function `multimode_syntax.func1'/1:
multimode_syntax.m:019: syntax error: some but not all arguments have mode
multimode_syntax.m:019: annotations.
-multimode_syntax.m:025: In clause for function `multimode_syntax.func2'/2:
+multimode_syntax.m:025: In clause for function `func2'/2:
multimode_syntax.m:025: error: mode annotation specifies undeclared mode
-multimode_syntax.m:025: `func2(in, out) = out'
-multimode_syntax.m:025: of function `multimode_syntax.func2'/2.
- The declared modes for this function are the following:
- :- mode func2(in, in) = out is det.
-multimode_syntax.m:027: In clause for function `multimode_syntax.func2'/2:
+multimode_syntax.m:025: `func2(in, out) = out'.
+multimode_syntax.m:025: The declared mode for this function is:
+multimode_syntax.m:025: :- mode func2(in, in) = out is det.
+multimode_syntax.m:027: In clause for function `func2'/2:
multimode_syntax.m:027: error: mode annotation specifies undeclared mode
-multimode_syntax.m:027: `func2(out, in) = out'
-multimode_syntax.m:027: of function `multimode_syntax.func2'/2.
- The declared modes for this function are the following:
- :- mode func2(in, in) = out is det.
-multimode_syntax.m:029: In clause for function `multimode_syntax.func2'/2:
+multimode_syntax.m:027: `func2(out, in) = out'.
+multimode_syntax.m:027: The declared mode for this function is:
+multimode_syntax.m:027: :- mode func2(in, in) = out is det.
+multimode_syntax.m:029: In clause for function `func2'/2:
multimode_syntax.m:029: error: mode annotation specifies undeclared mode
-multimode_syntax.m:029: `func2(out, out) = out'
-multimode_syntax.m:029: of function `multimode_syntax.func2'/2.
- The declared modes for this function are the following:
- :- mode func2(in, in) = out is det.
-multimode_syntax.m:033: In clause for function `multimode_syntax.func2b'/2:
+multimode_syntax.m:029: `func2(out, out) = out'.
+multimode_syntax.m:029: The declared mode for this function is:
+multimode_syntax.m:029: :- mode func2(in, in) = out is det.
+multimode_syntax.m:033: In clause for function `func2b'/2:
multimode_syntax.m:033: error: mode annotation specifies undeclared mode
-multimode_syntax.m:033: `func2b(in, out) = out'
-multimode_syntax.m:033: of function `multimode_syntax.func2b'/2.
- The declared modes for this function are the following:
- :- mode func2b(in, in) = out is det.
-multimode_syntax.m:037: In clause for predicate `multimode_syntax.pred2b'/2:
+multimode_syntax.m:033: `func2b(in, out) = out'.
+multimode_syntax.m:033: The declared mode for this function is:
+multimode_syntax.m:033: :- mode func2b(in, in) = out is det.
+multimode_syntax.m:037: In clause for predicate `pred2b'/2:
multimode_syntax.m:037: error: mode annotation specifies undeclared mode
-multimode_syntax.m:037: `pred2b(in, out)'
-multimode_syntax.m:037: of predicate `multimode_syntax.pred2b'/2.
+multimode_syntax.m:037: `pred2b(in, out)'.
multimode_syntax.m:037: (There are no declared modes for this predicate.)
multimode_syntax.m:045: In clause for predicate `multimode_syntax.test2'/2:
multimode_syntax.m:045: syntax error: some but not all arguments have mode
Index: tests/invalid/state_vars_test3.err_exp
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/invalid/state_vars_test3.err_exp,v
retrieving revision 1.10
diff -u -b -r1.10 state_vars_test3.err_exp
--- tests/invalid/state_vars_test3.err_exp 7 Sep 2006 05:51:32 -0000 1.10
+++ tests/invalid/state_vars_test3.err_exp 8 Sep 2006 17:44:52 -0000
@@ -1,6 +1,6 @@
-state_vars_test3.m:021: Error: clause for function `state_vars_test3.f'/2
-state_vars_test3.m:021: without preceding `func' declaration.
state_vars_test3.m:021: Error: !Y cannot be a function result.
state_vars_test3.m:021: You probably meant !.Y or !:Y.
+state_vars_test3.m:021: Error: clause for function `state_vars_test3.f'/2
+state_vars_test3.m:021: without preceding `func' declaration.
state_vars_test3.m:015: Error: no clauses for function `f'/1.
state_vars_test3.m:021: Error: no clauses for function `f'/2.
Index: tests/invalid/typeclass_test_8.err_exp
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/invalid/typeclass_test_8.err_exp,v
retrieving revision 1.9
diff -u -b -r1.9 typeclass_test_8.err_exp
--- tests/invalid/typeclass_test_8.err_exp 7 Sep 2006 05:51:34 -0000 1.9
+++ tests/invalid/typeclass_test_8.err_exp 8 Sep 2006 17:45:04 -0000
@@ -1,4 +1,4 @@
-typeclass_test_8.m:004: In predicate `typeclass_test_8.main'/2:
+typeclass_test_8.m:004: In predicate `main'/2:
typeclass_test_8.m:004: type error: unsatisfied typeclass constraint:
typeclass_test_8.m:004: `typeclass_test_8.fooable(T)'
typeclass_test_8.m:004: In predicate `typeclass_test_8.main'/2:
Index: tests/invalid/undef_inst.err_exp
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/invalid/undef_inst.err_exp,v
retrieving revision 1.6
diff -u -b -r1.6 undef_inst.err_exp
--- tests/invalid/undef_inst.err_exp 14 Jun 2006 08:14:56 -0000 1.6
+++ tests/invalid/undef_inst.err_exp 8 Sep 2006 17:45:06 -0000
@@ -1,7 +1,7 @@
undef_inst.m:001: Warning: interface for module `undef_inst' does not export
undef_inst.m:001: anything.
undef_inst.m:004: In mode declaration for predicate `undef_inst.x'/1:
-undef_inst.m:004: error: undefined inst `foo'/0.
-undef_inst.m:004: In mode declaration for predicate `undef_inst.x'/1:
undef_inst.m:004: error: undefined inst `bar'/0.
+undef_inst.m:004: In mode declaration for predicate `undef_inst.x'/1:
+undef_inst.m:004: error: undefined inst `foo'/0.
For more information, recompile with `-E'.
Index: tests/invalid/unsatisfiable_constraint.err_exp
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/invalid/unsatisfiable_constraint.err_exp,v
retrieving revision 1.6
diff -u -b -r1.6 unsatisfiable_constraint.err_exp
--- tests/invalid/unsatisfiable_constraint.err_exp 7 Sep 2006 05:51:35 -0000 1.6
+++ tests/invalid/unsatisfiable_constraint.err_exp 8 Sep 2006 17:45:10 -0000
@@ -1,7 +1,7 @@
-unsatisfiable_constraint.m:038: In predicate `unsatisfiable_constraint.test'/1:
+unsatisfiable_constraint.m:038: In predicate `test'/1:
unsatisfiable_constraint.m:038: type error: unsatisfied typeclass constraints:
-unsatisfiable_constraint.m:038: `unsatisfiable_constraint.a(A, B, A, V_8)'
-unsatisfiable_constraint.m:038: `unsatisfiable_constraint.a(A, B, C, V_14)'
+unsatisfiable_constraint.m:038: `unsatisfiable_constraint.a(A, B, A, V_8)',
+unsatisfiable_constraint.m:038: `unsatisfiable_constraint.a(A, B, C, V_14)',
unsatisfiable_constraint.m:038: `unsatisfiable_constraint.b(A, C)'
unsatisfiable_constraint.m:038: In predicate `unsatisfiable_constraint.test'/1:
unsatisfiable_constraint.m:038: warning: unresolved polymorphism.
cvs diff: Diffing tests/invalid/purity
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
Index: tests/warnings/double_underscore.exp
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/warnings/double_underscore.exp,v
retrieving revision 1.5
diff -u -b -r1.5 double_underscore.exp
--- tests/warnings/double_underscore.exp 7 Sep 2006 05:51:46 -0000 1.5
+++ tests/warnings/double_underscore.exp 9 Sep 2006 00:43:31 -0000
@@ -1,6 +1,3 @@
double_underscore.m:011: In clause for predicate `double_underscore.p'/2:
double_underscore.m:011: warning: variable `_X' occurs more than once in this
double_underscore.m:011: scope.
-double_underscore.m:011: In clause for predicate `double_underscore.p'/2:
-double_underscore.m:011: warning: variable `_X' occurs more than once in this
-double_underscore.m:011: scope.
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