mirror of
https://github.com/Mercury-Language/mercury.git
synced 2026-04-16 18:03:36 +00:00
ffb963b30f
Traditionally, we always wrote out parse trees (of .intN files, for example)
to a file. However, we have also supported being able to write out *parts*
of parse trees to strings, because that ability is useful e.g.
- in error messages, printing the code that the error message is about,
- when debugging.
We are considering a use case which requires the ability to write out
the *whole* parse tree of a .intN file to a string. That use case is
comparing whether the old and new versions of a .intN file are identical
or not, because we want to update the actual .intN file only if they
differ. (Updating the .intN file if they are identical could trigger
the unnecessary recompilation of an unbounded number of other modules.)
Previously, we have done this comparison by writing out the new parse tree
to an .intN.tmp file, and compared it to the .intN file. It should be simpler
and quite possibly faster to
- read in the old .intN file as a string
- convert the new parse tree to a string
- compare the two strings
- write out the new string if and only if it differs from the old string.
This should be especially so if we can open the .intN file in read-write mode,
so the file would need to be opened just once, in step one, even if we do
need to write out the new parse tree in step four.
compiler/parse_tree_out.m:
Add functions to convert parse_tree_int[0123]s to strings.
To avoid having to reimplement all the code that currently writes
out those parse trees, convert the current predicates that always do I/O
into predicates that use the methods of the existing pt_output type class,
which, depending on the selected instance, can either do I/O or can build
up a string. This conversion has already been done for the constructs
that make up some parts of those parse trees; this diff extends the
conversion to every construct that is part of parse trees listed above.
As part of our existing conventions, predicates that have been
generalized in this way have the "output" or "write" in their names
replaced with "format".
We also perform this generalization for the predicates that write out
parse_tree_srcs and parse_tree_module_srcs, because doing so requires
almost no extra code.
compiler/parse_item.m:
compiler/parse_tree_out_clause.m:
compiler/parse_tree_out_info.m:
compiler/parse_tree_out_inst.m:
compiler/parse_tree_out_misc.m:
compiler/parse_tree_out_pragma.m:
compiler/parse_tree_out_pred_decl.m:
compiler/parse_tree_out_type_repn.m:
compiler/prog_ctgc.m:
Perform the generalization discussed above, both on predicates
that write out Mercury constructs, and on some auxiliary predicates.
In a few cases, the generalized versions already existed but were private,
in which case this diff just exports them.
In a few cases, rename predicates to avoid ambiguities.
compiler/add_clause.m:
compiler/hlds_out_goal.m:
compiler/hlds_out_pred.m:
compiler/hlds_out_type_table.m:
compiler/hlds_out_typeclass_table.m:
compiler/intermod.m:
compiler/intermod_analysis.m:
Conform to the changes above.
895 lines
40 KiB
Mathematica
895 lines
40 KiB
Mathematica
%-----------------------------------------------------------------------------%
|
|
% vim: ft=mercury ts=4 sw=4 et
|
|
%-----------------------------------------------------------------------------%
|
|
% Copyright (C) 1993-2012,2014 The University of Melbourne.
|
|
% This file may only be copied under the terms of the GNU General
|
|
% Public License - see the file COPYING in the Mercury distribution.
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- module hlds.make_hlds.add_clause.
|
|
:- interface.
|
|
|
|
:- import_module hlds.hlds_clauses.
|
|
:- import_module hlds.hlds_module.
|
|
:- import_module hlds.hlds_pred.
|
|
:- import_module hlds.make_hlds.qual_info.
|
|
:- import_module hlds.status.
|
|
:- import_module mdbcomp.
|
|
:- import_module mdbcomp.prim_data.
|
|
:- import_module mdbcomp.sym_name.
|
|
:- import_module parse_tree.
|
|
:- import_module parse_tree.error_spec.
|
|
:- import_module parse_tree.prog_data.
|
|
:- import_module parse_tree.prog_item.
|
|
|
|
:- import_module io.
|
|
:- import_module list.
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- type clause_type
|
|
---> clause_not_for_promise
|
|
; clause_for_promise(promise_type).
|
|
|
|
:- pred module_add_clause(io.text_output_stream::in, pred_status::in,
|
|
clause_type::in, item_clause_info::in,
|
|
module_info::in, module_info::out, qual_info::in, qual_info::out,
|
|
list(error_spec)::in, list(error_spec)::out) is det.
|
|
|
|
:- pred clauses_info_add_clause(clause_applicable_modes::in, list(proc_id)::in,
|
|
pred_status::in, clause_type::in,
|
|
pred_or_func::in, sym_name::in, list(prog_term)::in,
|
|
prog_context::in, item_seq_num::in, goal::in, prog_varset::in,
|
|
tvarset::in, tvarset::out, clauses_info::in, clauses_info::out,
|
|
module_info::in, module_info::out, qual_info::in, qual_info::out,
|
|
list(error_spec)::in, list(error_spec)::out) is det.
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- implementation.
|
|
|
|
:- import_module hlds.add_pred.
|
|
:- import_module hlds.default_func_mode.
|
|
:- import_module hlds.goal_util.
|
|
:- import_module hlds.hlds_args.
|
|
:- import_module hlds.hlds_code_util.
|
|
:- import_module hlds.hlds_error_util.
|
|
:- import_module hlds.hlds_goal.
|
|
:- import_module hlds.hlds_out.
|
|
:- import_module hlds.hlds_out.hlds_out_goal.
|
|
:- import_module hlds.hlds_out.hlds_out_util.
|
|
:- import_module hlds.hlds_rtti.
|
|
:- import_module hlds.make_goal.
|
|
:- import_module hlds.make_hlds.goal_expr_to_goal.
|
|
:- import_module hlds.make_hlds.make_hlds_warn.
|
|
:- import_module hlds.make_hlds.state_var.
|
|
:- import_module hlds.make_hlds.superhomogeneous.
|
|
:- import_module hlds.make_hlds_error.
|
|
:- import_module hlds.pre_quantification.
|
|
:- import_module hlds.pred_name.
|
|
:- import_module hlds.pred_table.
|
|
:- import_module hlds.quantification.
|
|
:- import_module libs.
|
|
:- import_module libs.globals.
|
|
:- import_module libs.options.
|
|
:- import_module parse_tree.maybe_error.
|
|
:- import_module parse_tree.module_qual.
|
|
:- import_module parse_tree.parse_inst_mode_name.
|
|
:- import_module parse_tree.parse_tree_out_clause.
|
|
:- import_module parse_tree.parse_tree_out_misc.
|
|
:- import_module parse_tree.parse_tree_out_sym_name.
|
|
:- import_module parse_tree.prog_rename.
|
|
:- import_module parse_tree.prog_util.
|
|
:- import_module parse_tree.var_db.
|
|
:- import_module parse_tree.var_table.
|
|
|
|
:- import_module bool.
|
|
:- import_module cord.
|
|
:- import_module int.
|
|
:- import_module map.
|
|
:- import_module maybe.
|
|
:- import_module require.
|
|
:- import_module string.
|
|
:- import_module term.
|
|
:- import_module varset.
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
module_add_clause(ProgressStream, PredStatus, ClauseType, ClauseInfo,
|
|
!ModuleInfo, !QualInfo, !Specs) :-
|
|
ClauseInfo = item_clause_info(PredOrFunc, PredSymName, ArgTerms0,
|
|
ClauseVarSet, MaybeBodyGoal, Context, SeqNum),
|
|
(
|
|
PredSymName = qualified(PredModuleName, PredName)
|
|
;
|
|
PredSymName = unqualified(_),
|
|
% XXX The item_clause_info should encode this invariant, either
|
|
% by recording PredModuleName and PredName separately, or by using
|
|
% a qualified-only subtype of SymName.
|
|
unexpected($pred, "PredSymName is unqualified")
|
|
),
|
|
( if
|
|
illegal_state_var_func_result(PredOrFunc, ArgTerms0, SVar, SVarCtxt)
|
|
then
|
|
IllegalSVarResult = yes({SVar, SVarCtxt})
|
|
else
|
|
IllegalSVarResult = no
|
|
),
|
|
expand_bang_state_pairs_in_terms(ArgTerms0, ArgTerms),
|
|
|
|
% Lookup the pred declaration in the predicate table.
|
|
% (If it is not there, call maybe_undefined_pred_error and insert
|
|
% an implicit declaration for the predicate.)
|
|
list.length(ArgTerms, Arity0),
|
|
( IllegalSVarResult = yes(_), Arity = Arity0 - 1
|
|
; IllegalSVarResult = no, Arity = Arity0
|
|
),
|
|
PredFormArity = pred_form_arity(Arity),
|
|
some [!PredInfo] (
|
|
module_info_get_predicate_table(!.ModuleInfo, PredicateTable),
|
|
predicate_table_lookup_pf_sym_arity(PredicateTable, is_fully_qualified,
|
|
PredOrFunc, PredSymName, PredFormArity, PredIds),
|
|
( if PredIds = [PredId] then
|
|
module_add_clause_2(ProgressStream, PredStatus, ClauseType, PredId,
|
|
PredOrFunc, PredSymName, ArgTerms, PredFormArity,
|
|
ClauseVarSet, MaybeBodyGoal, Context, SeqNum,
|
|
IllegalSVarResult, !ModuleInfo, !QualInfo, !Specs)
|
|
else if PredName = ",", Arity = 2 then
|
|
SNA = sym_name_arity(unqualified(","), 2),
|
|
Pieces = [words("Attempt to define a clause for"),
|
|
unqual_sym_name_arity(SNA), suffix("."),
|
|
words("This is usually caused by"),
|
|
words("inadvertently writing a period instead of a comma"),
|
|
words("at the end of the preceding line."), nl],
|
|
Spec = simplest_spec($pred, severity_error,
|
|
phase_parse_tree_to_hlds, Context, Pieces),
|
|
!:Specs = [Spec | !.Specs]
|
|
else
|
|
% A promise will not have a corresponding pred declaration.
|
|
(
|
|
ClauseType = clause_for_promise(_PromiseType),
|
|
% add_promise in make_hlds_passes.m should have declared
|
|
% this predicate before calling us to add this clause.
|
|
unexpected($pred, "clause for undeclared promise")
|
|
;
|
|
ClauseType = clause_not_for_promise,
|
|
user_arity_pred_form_arity(PredOrFunc, UserArity,
|
|
PredFormArity),
|
|
Origin = origin_user(user_made_pred(PredOrFunc,
|
|
PredSymName, UserArity)),
|
|
add_implicit_pred_decl_report_error(PredOrFunc,
|
|
PredModuleName, PredName, PredFormArity, PredStatus,
|
|
is_not_a_class_method, Context, Origin,
|
|
[words("clause")], PredId, !ModuleInfo, !Specs)
|
|
),
|
|
module_add_clause_2(ProgressStream, PredStatus, ClauseType, PredId,
|
|
PredOrFunc, PredSymName, ArgTerms, PredFormArity,
|
|
ClauseVarSet, MaybeBodyGoal, Context, SeqNum,
|
|
IllegalSVarResult, !ModuleInfo, !QualInfo, !Specs)
|
|
)
|
|
).
|
|
|
|
:- pred module_add_clause_2(io.text_output_stream::in,
|
|
pred_status::in, clause_type::in, pred_id::in,
|
|
pred_or_func::in, sym_name::in, list(prog_term)::in, pred_form_arity::in,
|
|
prog_varset::in, maybe2(goal, list(warning_spec))::in, prog_context::in,
|
|
item_seq_num::in, maybe({prog_var, 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.
|
|
|
|
module_add_clause_2(ProgressStream, PredStatus, ClauseType, PredId,
|
|
PredOrFunc, PredSymName, MaybeAnnotatedArgTerms, PredFormArity,
|
|
ClauseVarSet, MaybeBodyGoal, Context, SeqNum, IllegalSVarResult,
|
|
!ModuleInfo, !QualInfo, !Specs) :-
|
|
some [!PredInfo, !PredSpecs] (
|
|
% 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.
|
|
module_info_pred_info(!.ModuleInfo, PredId, !:PredInfo),
|
|
|
|
trace [io(!IO)] (
|
|
add_clause_progress_msg(ProgressStream, !.ModuleInfo, !.PredInfo,
|
|
PredOrFunc, PredSymName, PredFormArity, !IO)
|
|
),
|
|
|
|
% Opt_imported preds are initially tagged as imported, and are tagged
|
|
% as opt_imported only if/when we see a clause for them.
|
|
( if PredStatus = pred_status(status_opt_imported) then
|
|
pred_info_set_status(pred_status(status_opt_imported), !PredInfo),
|
|
pred_info_get_markers(!.PredInfo, Markers0),
|
|
add_marker(marker_calls_are_fully_qualified, Markers0, Markers),
|
|
pred_info_set_markers(Markers, !PredInfo)
|
|
else
|
|
true
|
|
),
|
|
|
|
!:PredSpecs = [],
|
|
(
|
|
IllegalSVarResult = yes({StateVar, StateVarContext}),
|
|
report_illegal_func_svar_result(StateVarContext, ClauseVarSet,
|
|
StateVar, !PredSpecs)
|
|
;
|
|
IllegalSVarResult = no
|
|
),
|
|
maybe_add_error_for_field_access_function(!.ModuleInfo, PredStatus,
|
|
PredOrFunc, PredSymName, PredFormArity, Context, !PredSpecs),
|
|
maybe_add_error_for_builtin(!.ModuleInfo, !.PredInfo,
|
|
Context, !PredSpecs),
|
|
maybe_add_default_func_mode(!.ModuleInfo, !PredInfo, _),
|
|
(
|
|
!.PredSpecs = [_ | _ ],
|
|
!:Specs = !.PredSpecs ++
|
|
get_any_errors_warnings2(MaybeBodyGoal) ++ !.Specs
|
|
;
|
|
!.PredSpecs = [],
|
|
(
|
|
MaybeBodyGoal = error2(BodyGoalSpecs),
|
|
!:Specs = BodyGoalSpecs ++ !.Specs,
|
|
pred_info_get_clauses_info(!.PredInfo, Clauses0),
|
|
Clauses = Clauses0 ^ cli_had_syntax_errors :=
|
|
some_clause_syntax_errors,
|
|
pred_info_set_clauses_info(Clauses, !PredInfo)
|
|
;
|
|
MaybeBodyGoal = ok2(BodyGoal, BodyGoalWarningSpecs),
|
|
!:Specs = BodyGoalWarningSpecs ++ !.Specs,
|
|
pred_info_get_clauses_info(!.PredInfo, ClausesInfo0),
|
|
pred_info_get_typevarset(!.PredInfo, TVarSet0),
|
|
select_applicable_modes(MaybeAnnotatedArgTerms, ClauseVarSet,
|
|
PredStatus, Context, PredId, !.PredInfo, ArgTerms,
|
|
ProcIdsForThisClause, AllProcIds,
|
|
!ModuleInfo, !QualInfo, !Specs),
|
|
clauses_info_add_clause(ProcIdsForThisClause, AllProcIds,
|
|
PredStatus, ClauseType, PredOrFunc, PredSymName,
|
|
ArgTerms, Context, SeqNum, BodyGoal, ClauseVarSet,
|
|
TVarSet0, TVarSet, ClausesInfo0, ClausesInfo,
|
|
!ModuleInfo, !QualInfo, !Specs),
|
|
pred_info_set_clauses_info(ClausesInfo, !PredInfo),
|
|
(
|
|
ClauseType = clause_for_promise(_PromiseType)
|
|
% We have already set the goal type.
|
|
;
|
|
ClauseType = clause_not_for_promise,
|
|
% We normally add all Mercury clauses before we add
|
|
% any foreign_procs, but just in case that changes
|
|
% in the future ...
|
|
pred_info_update_goal_type(np_goal_type_clause, !PredInfo)
|
|
),
|
|
pred_info_set_typevarset(TVarSet, !PredInfo),
|
|
pred_info_get_arg_types(!.PredInfo, _ArgTVarSet, ExistQVars,
|
|
ArgTypes),
|
|
pred_info_set_arg_types(TVarSet, ExistQVars, ArgTypes,
|
|
!PredInfo),
|
|
|
|
% Check if there are still no modes for the predicate, and
|
|
% if so, set the `infer_modes' marker for that predicate.
|
|
% Predicates representing promises do not need mode inference.
|
|
|
|
ProcIds = pred_info_all_procids(!.PredInfo),
|
|
( if
|
|
ProcIds = [],
|
|
ClauseType = clause_not_for_promise
|
|
then
|
|
pred_info_get_markers(!.PredInfo, EndMarkers0),
|
|
add_marker(marker_infer_modes, EndMarkers0, EndMarkers),
|
|
pred_info_set_markers(EndMarkers, !PredInfo)
|
|
else
|
|
true
|
|
)
|
|
),
|
|
module_info_set_pred_info(PredId, !.PredInfo, !ModuleInfo)
|
|
)
|
|
).
|
|
|
|
%-----------------%
|
|
|
|
:- pred add_clause_progress_msg(io.text_output_stream::in, module_info::in,
|
|
pred_info::in, pred_or_func::in, sym_name::in, pred_form_arity::in,
|
|
io::di, io::uo) is det.
|
|
|
|
add_clause_progress_msg(ProgressStream, ModuleInfo, PredInfo,
|
|
PredOrFunc, PredName, PredFormArity, !IO) :-
|
|
module_info_get_globals(ModuleInfo, Globals),
|
|
globals.lookup_bool_option(Globals, very_verbose, VeryVerbose),
|
|
(
|
|
VeryVerbose = yes,
|
|
pred_info_get_clauses_info(PredInfo, MsgClauses),
|
|
NumClauses = num_clauses_in_clauses_rep(MsgClauses ^ cli_rep),
|
|
PredOrFuncStr = pred_or_func_to_full_str(PredOrFunc),
|
|
user_arity_pred_form_arity(PredOrFunc, user_arity(Arity),
|
|
PredFormArity),
|
|
SNA = sym_name_arity(PredName, Arity),
|
|
SNAStr = unescaped_sym_name_arity_to_string(SNA),
|
|
io.format(ProgressStream, "%% Processing clause %d for %s `%s'...\n",
|
|
[i(NumClauses + 1), s(PredOrFuncStr), s(SNAStr)], !IO)
|
|
;
|
|
VeryVerbose = no
|
|
).
|
|
|
|
%-----------------%
|
|
|
|
:- pred maybe_add_error_for_field_access_function(module_info::in,
|
|
pred_status::in, pred_or_func::in, sym_name::in, pred_form_arity::in,
|
|
prog_context::in, list(error_spec)::in, list(error_spec)::out) is det.
|
|
|
|
maybe_add_error_for_field_access_function(ModuleInfo, PredStatus,
|
|
PredOrFunc, PredSymName, PredFormArity, Context, !Specs) :-
|
|
( if
|
|
% User-supplied clauses for field access functions are not
|
|
% allowed -- the clauses are always generated by the compiler.
|
|
PredOrFunc = pf_function,
|
|
user_arity_pred_form_arity(PredOrFunc, user_arity(UserArityInt),
|
|
PredFormArity),
|
|
is_field_access_function_name(ModuleInfo, PredSymName,
|
|
UserArityInt, _, _),
|
|
% Don't report errors for clauses for field access function clauses
|
|
% in `.opt' files.
|
|
PredStatus \= pred_status(status_opt_imported)
|
|
then
|
|
FieldPFSymNameArity =
|
|
pf_sym_name_arity(PredOrFunc, PredSymName, PredFormArity),
|
|
FieldAccessMainPieces =
|
|
[words("Error: clause for"),
|
|
words("automatically generated field access"),
|
|
unqual_pf_sym_name_pred_form_arity(FieldPFSymNameArity),
|
|
suffix("."), nl],
|
|
FieldAccessVerbosePieces =
|
|
[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."), nl],
|
|
FieldAccessMsg = simple_msg(Context,
|
|
[always(FieldAccessMainPieces),
|
|
verbose_only(verbose_always, FieldAccessVerbosePieces)]),
|
|
FieldAccessSpec = error_spec($pred, severity_error,
|
|
phase_parse_tree_to_hlds, [FieldAccessMsg]),
|
|
!:Specs = [FieldAccessSpec | !.Specs]
|
|
else
|
|
true
|
|
).
|
|
|
|
:- pred maybe_add_error_for_builtin(module_info::in, pred_info::in,
|
|
prog_context::in, list(error_spec)::in, list(error_spec)::out) is det.
|
|
|
|
maybe_add_error_for_builtin(ModuleInfo, PredInfo, Context, !Specs) :-
|
|
( if pred_info_is_builtin(PredInfo) then
|
|
% When bootstrapping a change that defines a builtin using
|
|
% normal Mercury code, we need to disable the generation
|
|
% of the error message, and just ignore the definition.
|
|
some [Globals] (
|
|
module_info_get_globals(ModuleInfo, Globals),
|
|
globals.lookup_bool_option(Globals, allow_defn_of_builtins,
|
|
AllowDefnOfBuiltin)
|
|
),
|
|
(
|
|
AllowDefnOfBuiltin = no,
|
|
BuiltinSpec = simplest_spec($pred, severity_error,
|
|
phase_parse_tree_to_hlds, Context,
|
|
[words("Error: clause for builtin.")]),
|
|
!:Specs = [BuiltinSpec | !.Specs]
|
|
;
|
|
AllowDefnOfBuiltin = yes
|
|
)
|
|
else
|
|
true
|
|
).
|
|
|
|
%-----------------%
|
|
|
|
% Extract the mode annotations (if any) from the clause arguments,
|
|
% and determine which mode(s) this clause should apply to.
|
|
%
|
|
:- pred select_applicable_modes(list(prog_term)::in, prog_varset::in,
|
|
pred_status::in, prog_context::in, pred_id::in, pred_info::in,
|
|
list(prog_term)::out, clause_applicable_modes::out, list(proc_id)::out,
|
|
module_info::in, module_info::out, qual_info::in, qual_info::out,
|
|
list(error_spec)::in, list(error_spec)::out) is det.
|
|
|
|
select_applicable_modes(MaybeAnnotatedArgTerms, VarSet, PredStatus, Context,
|
|
PredId, PredInfo, ArgTerms, ApplProcIds, AllProcIds,
|
|
!ModuleInfo, !QualInfo, !Specs) :-
|
|
AllProcIds = pred_info_all_procids(PredInfo),
|
|
PredIdStr = pred_id_to_user_string(!.ModuleInfo, PredId),
|
|
ContextPieces = cord.from_list([words("In the head of a clause for"),
|
|
fixed(PredIdStr), suffix(":"), nl]),
|
|
get_mode_annotations(VarSet, ContextPieces, 1, MaybeAnnotatedArgTerms,
|
|
ArgTerms, ma_empty, ModeAnnotations, [], ModeAnnotationSpecs),
|
|
(
|
|
ModeAnnotationSpecs = [_ | _],
|
|
!:Specs = ModeAnnotationSpecs ++ !.Specs,
|
|
% Apply the clause to all modes.
|
|
% XXX Would it be better to apply it to none?
|
|
ApplProcIds = selected_modes(AllProcIds)
|
|
;
|
|
ModeAnnotationSpecs = [],
|
|
(
|
|
ModeAnnotations = ma_modes(ArgModes0),
|
|
|
|
% 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 qualified.
|
|
|
|
( if PredStatus = pred_status(status_opt_imported) then
|
|
ArgModes = ArgModes0
|
|
else
|
|
Exported =
|
|
pred_status_is_exported_to_non_submodules(PredStatus),
|
|
(
|
|
Exported = yes,
|
|
InInt = mq_used_in_interface
|
|
;
|
|
Exported = no,
|
|
InInt = mq_not_used_in_interface
|
|
),
|
|
qual_info_get_mq_info(!.QualInfo, MQInfo0),
|
|
qualify_clause_mode_list(InInt, Context,
|
|
ArgModes0, ArgModes, MQInfo0, MQInfo, !Specs),
|
|
qual_info_set_mq_info(MQInfo, !QualInfo)
|
|
),
|
|
|
|
% Now find the procedure which matches these mode annotations.
|
|
pred_info_get_proc_table(PredInfo, Procs),
|
|
map.to_assoc_list(Procs, ExistingProcs),
|
|
( if
|
|
get_procedure_matching_declmodes_with_renaming(!.ModuleInfo,
|
|
ExistingProcs, ArgModes, ProcId)
|
|
then
|
|
ApplProcIds = selected_modes([ProcId]),
|
|
(
|
|
ExistingProcs = []
|
|
% A mode-specific clause for a predicate/function
|
|
% that has no modes is a bug (in the usual case where
|
|
% mode inference is not turned on), but it is a bug that
|
|
% should be reported elsewhere.
|
|
;
|
|
ExistingProcs = [_],
|
|
module_info_get_globals(!.ModuleInfo, Globals),
|
|
globals.lookup_bool_option(Globals,
|
|
warn_unneeded_mode_specific_clause, Warn),
|
|
(
|
|
Warn = yes,
|
|
PredDescPieces = describe_one_pred_info_name(
|
|
should_not_module_qualify, PredInfo),
|
|
Pieces = [words("Warning: the")] ++ PredDescPieces ++
|
|
[words("has only one mode,"),
|
|
words("so there is no need to restrict"),
|
|
words("a clause for it to that mode."), nl],
|
|
Spec = simplest_spec($pred, severity_warning,
|
|
phase_parse_tree_to_hlds, Context, Pieces),
|
|
!:Specs = [Spec | !.Specs]
|
|
;
|
|
Warn = no
|
|
)
|
|
;
|
|
ExistingProcs = [_, _ | _]
|
|
)
|
|
else
|
|
report_undeclared_mode_error(!.ModuleInfo, PredId, PredInfo,
|
|
VarSet, ArgModes, [words("clause")], Context, !Specs),
|
|
% Apply the clause to all modes.
|
|
% XXX Would it be better to apply it to none?
|
|
ApplProcIds = selected_modes(AllProcIds)
|
|
)
|
|
;
|
|
( ModeAnnotations = ma_empty
|
|
; ModeAnnotations = ma_none
|
|
),
|
|
( if pred_info_defn_has_foreign_proc(PredInfo) then
|
|
% We are only allowed to mix foreign procs and
|
|
% mode specific clauses, so make this clause
|
|
% mode specific but apply to all modes.
|
|
ApplProcIds = selected_modes(AllProcIds)
|
|
else
|
|
ApplProcIds = all_modes
|
|
)
|
|
;
|
|
ModeAnnotations = ma_mixed,
|
|
Pieces = [words("In the head of a clause for"),
|
|
fixed(PredIdStr), suffix(":"), nl,
|
|
words("syntax error: some but not all arguments"),
|
|
words("have mode annotations."), nl],
|
|
Spec = simplest_spec($pred, severity_error,
|
|
phase_parse_tree_to_hlds, Context, Pieces),
|
|
!:Specs = [Spec | !.Specs],
|
|
|
|
% Apply the clause to all modes.
|
|
% XXX Would it be better to apply it to none?
|
|
ApplProcIds = selected_modes(AllProcIds)
|
|
)
|
|
).
|
|
|
|
%-----------------%
|
|
|
|
% 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.
|
|
:- type mode_annotations
|
|
---> ma_empty
|
|
% No arguments.
|
|
|
|
; ma_none
|
|
% One or more arguments, each without any mode annotations.
|
|
|
|
; ma_modes(list(mer_mode))
|
|
% One or more arguments, each with a mode annotation.
|
|
|
|
; ma_mixed.
|
|
% Two or more arguments, including some with mode annotations
|
|
% and some without. (This is not allowed.)
|
|
|
|
% Extract the mode annotations (if any) from a list of arguments.
|
|
%
|
|
:- pred get_mode_annotations(prog_varset::in, cord(format_piece)::in,
|
|
int::in, list(prog_term)::in, list(prog_term)::out,
|
|
mode_annotations::in, mode_annotations::out,
|
|
list(error_spec)::in, list(error_spec)::out) is det.
|
|
|
|
get_mode_annotations(_, _, _, [], [], !Annotations, !Specs).
|
|
get_mode_annotations(VarSet, ContextPieces, ArgNum, [MAArgTerm | MAArgTerms],
|
|
[ArgTerm | ArgTerms], !Annotations, !Specs) :-
|
|
get_mode_annotation(VarSet, ContextPieces, ArgNum, MAArgTerm, ArgTerm,
|
|
MaybeMaybeMode),
|
|
(
|
|
MaybeMaybeMode = ok1(MaybeMode),
|
|
add_annotation(MaybeMode, !Annotations)
|
|
;
|
|
MaybeMaybeMode = error1(MaybeModeSpecs),
|
|
!:Specs = !.Specs ++ MaybeModeSpecs
|
|
),
|
|
get_mode_annotations(VarSet, ContextPieces, ArgNum + 1, MAArgTerms,
|
|
ArgTerms, !Annotations, !Specs).
|
|
|
|
% Extract the mode annotations (if any) from a single argument.
|
|
%
|
|
:- pred get_mode_annotation(prog_varset::in, cord(format_piece)::in,
|
|
int::in, prog_term::in, prog_term::out, maybe1(maybe(mer_mode))::out)
|
|
is det.
|
|
|
|
get_mode_annotation(VarSet, ContextPieces, ArgNum, MaybeAnnotatedArgTerm,
|
|
ArgTerm, MaybeMaybeAnnotation) :-
|
|
( if
|
|
MaybeAnnotatedArgTerm = term.functor(term.atom("::"),
|
|
[ArgTermPrime, ModeTerm], _)
|
|
then
|
|
ArgTerm = ArgTermPrime,
|
|
|
|
ArgContextPieces = ContextPieces ++
|
|
cord.from_list([words("in the"), nth_fixed(ArgNum),
|
|
words("argument:"), nl]),
|
|
varset.coerce(VarSet, GenVarSet),
|
|
term.coerce(ModeTerm, GenModeTerm),
|
|
parse_mode(allow_constrained_inst_var, GenVarSet, ArgContextPieces,
|
|
GenModeTerm, MaybeMode),
|
|
(
|
|
MaybeMode = ok1(Mode),
|
|
MaybeMaybeAnnotation = ok1(yes(Mode))
|
|
;
|
|
MaybeMode = error1(Specs),
|
|
MaybeMaybeAnnotation = error1(Specs)
|
|
)
|
|
else
|
|
ArgTerm = MaybeAnnotatedArgTerm,
|
|
MaybeMaybeAnnotation = ok1(no)
|
|
).
|
|
|
|
:- pred add_annotation(maybe(mer_mode)::in,
|
|
mode_annotations::in, mode_annotations::out) is det.
|
|
|
|
add_annotation(no, ma_empty, ma_none).
|
|
add_annotation(yes(Mode), ma_empty, ma_modes([Mode])).
|
|
add_annotation(no, ma_modes(_), ma_mixed).
|
|
add_annotation(yes(Mode), ma_modes(Modes), ma_modes(Modes ++ [Mode])).
|
|
add_annotation(no, ma_none, ma_none).
|
|
add_annotation(yes(_), ma_none, ma_mixed).
|
|
add_annotation(_, ma_mixed, ma_mixed).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
clauses_info_add_clause(ApplModeIds0, AllModeIds, PredStatus, ClauseType,
|
|
PredOrFunc, PredSymName, ArgTerms, Context, SeqNum, BodyGoal,
|
|
ClauseVarSet, TVarSet0, TVarSet,
|
|
!ClausesInfo, !ModuleInfo, !QualInfo, !Specs) :-
|
|
!.ClausesInfo = clauses_info(VarSet0, ExplicitVarTypes0,
|
|
VarTable0, RttiVarMaps0, TVarNameMap0, ArgVector, ClausesRep0,
|
|
ItemNumbers0, HasForeignClauses0, HadSyntaxError0),
|
|
HeadVars = proc_arg_vector_to_list(ArgVector),
|
|
IsEmpty = clause_list_is_empty(ClausesRep0),
|
|
(
|
|
IsEmpty = yes,
|
|
% Create the mapping from type variable name, used to rename
|
|
% type variables occurring in explicit type qualifications.
|
|
% The version of this mapping stored in the clauses_info should
|
|
% only contain type variables which occur in the argument types
|
|
% of the predicate. Type variables which only occur in explicit type
|
|
% qualifications are local to the clause in which they appear.
|
|
varset.create_name_var_map(TVarSet0, TVarNameMap)
|
|
;
|
|
IsEmpty = no,
|
|
TVarNameMap = TVarNameMap0
|
|
),
|
|
( if PredStatus = pred_status(status_opt_imported) then
|
|
MaybeOptImported = is_opt_imported
|
|
else
|
|
MaybeOptImported = is_not_opt_imported
|
|
),
|
|
update_qual_info(TVarNameMap, TVarSet0, ExplicitVarTypes0,
|
|
MaybeOptImported, !QualInfo),
|
|
varset.merge_renaming(VarSet0, ClauseVarSet, VarSet1, Renaming),
|
|
can_we_do_singleton_and_quant_warnings(PredStatus, !.ClausesInfo, CanWarn),
|
|
% We need to keep quantified variables temporarily for use by the code
|
|
% that warns about singletons, and then we want to delete those quantified
|
|
% variables. If we cannot generate any singleton variable warnings,
|
|
% then there is no point in keeping those quantified variables.
|
|
( CanWarn = cannot_warn, KeepQuantVars = do_not_keep_quant_vars
|
|
; CanWarn = can_warn, KeepQuantVars = keep_quant_vars
|
|
),
|
|
add_clause_transform(KeepQuantVars, Renaming, PredOrFunc, PredSymName,
|
|
HeadVars, ArgTerms, Context, ClauseType, BodyGoal, Goal0,
|
|
VarSet1, VarSet2, QuantWarnings, StateVarWarnings, StateVarErrors,
|
|
!ModuleInfo, !QualInfo, !Specs),
|
|
qual_info_get_tvarset(!.QualInfo, TVarSet),
|
|
qual_info_get_found_syntax_error(!.QualInfo, FoundError),
|
|
qual_info_set_found_syntax_error(no, !QualInfo),
|
|
( if
|
|
( FoundError = yes
|
|
; StateVarErrors = [_ | _]
|
|
)
|
|
then
|
|
% Don't insert clauses containing syntax errors into the
|
|
% clauses_info, because doing that would cause typecheck.m
|
|
% to report spurious type errors. Don't report singleton variable
|
|
% warnings if there were syntax errors.
|
|
!:Specs = StateVarErrors ++ !.Specs,
|
|
!ClausesInfo ^ cli_had_syntax_errors := some_clause_syntax_errors
|
|
else
|
|
(
|
|
CanWarn = cannot_warn,
|
|
VarSet = VarSet2,
|
|
Goal = Goal0
|
|
;
|
|
CanWarn = can_warn,
|
|
PredFormArity = arg_list_arity(HeadVars),
|
|
WarnPFSymNameArity = pf_sym_name_arity(PredOrFunc, PredSymName,
|
|
PredFormArity),
|
|
warn_singletons(!.ModuleInfo, WarnPFSymNameArity, VarSet2, Goal0,
|
|
SeenQuant, !Specs),
|
|
% Warn about variables with overlapping scopes.
|
|
add_quant_warnings(WarnPFSymNameArity, VarSet, QuantWarnings,
|
|
!Specs),
|
|
(
|
|
SeenQuant = have_not_seen_quant,
|
|
% Even though we told the call to add_clause_transform above
|
|
% to tell quantification.m to keep any quantified variables,
|
|
% there were none to keep, so there is no point in trying
|
|
% to delete them.
|
|
VarSet = VarSet2,
|
|
Goal = Goal0
|
|
;
|
|
SeenQuant = have_seen_quant,
|
|
% There *were* some to keep, so delete them.
|
|
qual_info_get_explicit_var_types(!.QualInfo, QuantVarTypes0),
|
|
rtti_varmaps_init(EmptyRttiVarmaps),
|
|
implicitly_quantify_clause_body_general_vs(ord_nl_maybe_lambda,
|
|
do_not_keep_quant_vars, HeadVars, _QuantWarnings,
|
|
Goal0, Goal, VarSet2, VarSet,
|
|
QuantVarTypes0, QuantVarTypes, EmptyRttiVarmaps, _),
|
|
qual_info_set_explicit_var_types(QuantVarTypes, !QualInfo)
|
|
)
|
|
),
|
|
% If we have foreign clauses, we should only add this clause
|
|
% for modes *not* covered by the foreign clauses.
|
|
(
|
|
HasForeignClauses0 = some_foreign_lang_clauses,
|
|
get_clause_list(Clauses0, ClausesRep0, ClausesRep1),
|
|
ForeignModeIds = list.condense(list.filter_map(
|
|
( func(C) = ProcIds is semidet :-
|
|
C ^ clause_lang = impl_lang_foreign(_),
|
|
ApplProcIds = C ^ clause_applicable_procs,
|
|
(
|
|
ApplProcIds = all_modes,
|
|
unexpected($pred, "all_modes foreign_proc")
|
|
;
|
|
ApplProcIds = selected_modes(ProcIds)
|
|
;
|
|
( ApplProcIds = unify_in_in_modes
|
|
; ApplProcIds = unify_non_in_in_modes
|
|
),
|
|
unexpected($pred, "unify modes for foreign_proc")
|
|
)
|
|
),
|
|
Clauses0)),
|
|
(
|
|
ApplModeIds0 = all_modes,
|
|
ModeIds0 = AllModeIds
|
|
;
|
|
ApplModeIds0 = selected_modes(ModeIds0)
|
|
;
|
|
( ApplModeIds0 = unify_in_in_modes
|
|
; ApplModeIds0 = unify_non_in_in_modes
|
|
),
|
|
unexpected($pred, "unify modes for user defined predicate")
|
|
),
|
|
ModeIds = list.delete_elems(ModeIds0, ForeignModeIds),
|
|
(
|
|
ModeIds = [],
|
|
ClausesRep = ClausesRep1
|
|
;
|
|
ModeIds = [_ | _],
|
|
ApplicableModeIds = selected_modes(ModeIds),
|
|
Clause = clause(ApplicableModeIds, Goal, impl_lang_mercury,
|
|
Context, StateVarWarnings),
|
|
add_clause(Clause, ClausesRep1, ClausesRep)
|
|
)
|
|
;
|
|
HasForeignClauses0 = no_foreign_lang_clauses,
|
|
Clause = clause(ApplModeIds0, Goal, impl_lang_mercury, Context,
|
|
StateVarWarnings),
|
|
add_clause(Clause, ClausesRep0, ClausesRep)
|
|
),
|
|
qual_info_get_explicit_var_types(!.QualInfo, ExplicitVarTypes),
|
|
add_clause_item_number(SeqNum, Context, item_is_clause,
|
|
ItemNumbers0, ItemNumbers),
|
|
!:ClausesInfo = clauses_info(VarSet, ExplicitVarTypes,
|
|
VarTable0, RttiVarMaps0, TVarNameMap, ArgVector, ClausesRep,
|
|
ItemNumbers, HasForeignClauses0, HadSyntaxError0)
|
|
).
|
|
|
|
%-----------------%
|
|
|
|
:- type maybe_can_warn
|
|
---> cannot_warn
|
|
; can_warn.
|
|
|
|
:- pred can_we_do_singleton_and_quant_warnings(pred_status::in,
|
|
clauses_info::in, maybe_can_warn::out) is det.
|
|
|
|
can_we_do_singleton_and_quant_warnings(PredStatus, ClausesInfo, CanWarn) :-
|
|
( if
|
|
(
|
|
% Any singleton warnings should be generated for the original code,
|
|
% not for the copy in a .opt or .trans_opt file.
|
|
PredStatus = pred_status(status_opt_imported)
|
|
;
|
|
% Part of the parser's recovery from syntax errors (e.g. when
|
|
% they occur in lambda expressions' clause heads) may have
|
|
% included not translating parts of the original term
|
|
% into the parsed clause body, so any singleton warnings
|
|
% we generate for such "truncated" clauses could be misleading.
|
|
%
|
|
% We could try to record the set of variables in the parts
|
|
% of the original goal term that we don't include in the clause,
|
|
% but (a) this is not trivial to do, and (b) the payoff is
|
|
% questionable, because some of those variables could have been
|
|
% the result of typos affecting a word that the programmer meant
|
|
% to be something else.
|
|
ClausesInfo ^ cli_had_syntax_errors = some_clause_syntax_errors
|
|
)
|
|
then
|
|
CanWarn = cannot_warn
|
|
else
|
|
CanWarn = can_warn
|
|
).
|
|
|
|
%-----------------%
|
|
|
|
% ArgTerms0 has already had !S arguments replaced by
|
|
% !.S, !:S argument pairs.
|
|
%
|
|
:- pred add_clause_transform(maybe_keep_quant_vars::in, prog_var_renaming::in,
|
|
pred_or_func::in, sym_name::in, list(prog_var)::in,
|
|
list(prog_term)::in, prog_context::in, clause_type::in,
|
|
goal::in, hlds_goal::out, prog_varset::in, prog_varset::out,
|
|
list(quant_warning)::out, list(error_spec)::out, list(error_spec)::out,
|
|
module_info::in, module_info::out, qual_info::in, qual_info::out,
|
|
list(error_spec)::in, list(error_spec)::out) is det.
|
|
|
|
add_clause_transform(KeepQuantVars, Renaming, PredOrFunc, PredSymName,
|
|
HeadVars, ArgTerms0, Context, ClauseType, ParseTreeBodyGoal, Goal,
|
|
!VarSet, QuantWarnings, StateVarWarnings, StateVarErrors,
|
|
!ModuleInfo, !QualInfo, !Specs) :-
|
|
some [!SInfo, !SVarState, !SVarStore] (
|
|
rename_vars_in_term_list(need_not_rename, Renaming,
|
|
ArgTerms0, ArgTerms1),
|
|
svar_prepare_for_clause_head(ArgTerms1, ArgTerms, !VarSet,
|
|
FinalSVarMap, !:SVarState, !:SVarStore, !Specs),
|
|
InitialSVarState = !.SVarState,
|
|
(
|
|
ClauseType = clause_for_promise(_),
|
|
HeadGoal = true_goal
|
|
;
|
|
ClauseType = clause_not_for_promise,
|
|
PredFormArity = arg_list_arity(ArgTerms0),
|
|
ArgContext = ac_head(PredOrFunc, PredFormArity),
|
|
HeadGoal0 = true_goal,
|
|
pair_vars_with_terms(HeadVars, ArgTerms, HeadVarsArgTerms),
|
|
insert_arg_unifications(HeadVarsArgTerms, Context, ArgContext,
|
|
HeadGoal0, HeadGoal1, !SVarState, !SVarStore, !VarSet,
|
|
!ModuleInfo, !QualInfo, !Specs),
|
|
% The only pass that pays attention to the from_head feature,
|
|
% switch_detection, only does so on kinds of hlds_goal_exprs
|
|
% that do not occur in from_ground_term scopes, which we have
|
|
% just marked as from_ground_term_initial. Those scopes will be
|
|
% converted to one of from_ground_term_{construct,deconstruct,
|
|
% other} by mode analysis, if type analysis hasn't done it first.
|
|
% Type analysis will do this if it finds that some of the
|
|
% "unifications" inside these scopes are actually calls.
|
|
% Switch detection *does* care about from_head features on calls,
|
|
% and it looks inside all scopes except those of the
|
|
% from_ground_term_construct kind. Therefore any code that can be
|
|
% executed between now and switch detection that converts a
|
|
% from_ground_term_initial or from_ground_term_construct scope
|
|
% to another kind of scope should attach any from_head feature
|
|
% present on the scope to all its subgoals.
|
|
attach_features_to_all_goals([feature_from_head],
|
|
do_not_attach_in_from_ground_term, HeadGoal1, HeadGoal)
|
|
),
|
|
transform_parse_tree_goal_to_hlds(loc_whole_goal, ParseTreeBodyGoal,
|
|
Renaming, BodyGoal, !SVarState, !SVarStore, !VarSet,
|
|
!ModuleInfo, !QualInfo, !Specs),
|
|
FinalSVarState = !.SVarState,
|
|
svar_finish_clause_body(Globals, ModuleName, Context, FinalSVarMap,
|
|
HeadGoal, BodyGoal, Goal0, InitialSVarState, FinalSVarState,
|
|
!.SVarStore, StateVarWarnings, StateVarErrors),
|
|
|
|
module_info_get_globals(!.ModuleInfo, Globals),
|
|
module_info_get_name(!.ModuleInfo, ModuleName),
|
|
trace [compiletime(flag("debug-statevar-lambda")), io(!IO)] (
|
|
globals.lookup_string_option(Globals, experiment, Experiment),
|
|
PredName = unqualify_name(PredSymName),
|
|
( if PredName = Experiment then
|
|
VarNameSrc = vns_varset(!.VarSet),
|
|
varset.init(TVarSet),
|
|
varset.init(InstVarSet),
|
|
get_debug_output_stream(Globals, ModuleName, DebugStream, !IO),
|
|
io.write_string(DebugStream, "\nCLAUSE HEAD\n", !IO),
|
|
io.write_string(DebugStream, "\narg terms before:\n", !IO),
|
|
list.foldl(io.write_line(DebugStream), ArgTerms0, !IO),
|
|
io.write_string(DebugStream, "\narg terms renamed:\n", !IO),
|
|
list.foldl(io.write_line(DebugStream), ArgTerms1, !IO),
|
|
io.write_string(DebugStream, "\narg terms after:\n", !IO),
|
|
list.foldl(io.write_line(DebugStream), ArgTerms, !IO),
|
|
io.write_string(DebugStream, "\nhead vars:\n", !IO),
|
|
io.write_line(DebugStream, HeadVars, !IO),
|
|
io.write_string(DebugStream, "\narg unifies:\n", !IO),
|
|
dump_goal_nl(DebugStream, !.ModuleInfo, VarNameSrc,
|
|
TVarSet, InstVarSet, HeadGoal, !IO),
|
|
io.write_string(DebugStream, "\nparse tree goal body:\n", !IO),
|
|
mercury_format_goal(DebugStream, !.VarSet, 0,
|
|
ParseTreeBodyGoal, !IO),
|
|
io.write_string(DebugStream, "\nclause body:\n", !IO),
|
|
dump_goal_nl(DebugStream, !.ModuleInfo, VarNameSrc,
|
|
TVarSet, InstVarSet, BodyGoal, !IO),
|
|
map.to_assoc_list(FinalSVarMap, FinalSVarList),
|
|
io.write_string(DebugStream, "\nFinalSVarMap:\n", !IO),
|
|
io.write_line(DebugStream, FinalSVarList, !IO)
|
|
else
|
|
true
|
|
)
|
|
),
|
|
|
|
qual_info_get_found_trace_goal(!.QualInfo, FoundTraceGoal),
|
|
(
|
|
FoundTraceGoal = no,
|
|
Goal1 = Goal0
|
|
;
|
|
FoundTraceGoal = yes,
|
|
separate_trace_goal_only_locals(Goal0, Goal1)
|
|
),
|
|
qual_info_get_explicit_var_types(!.QualInfo, VarTypes0),
|
|
% The RTTI varmaps here are just a dummy value, because the real ones
|
|
% are not introduced until polymorphism.
|
|
rtti_varmaps_init(EmptyRttiVarmaps),
|
|
% XXX It should be possible to exploit the fact that lambda expressions
|
|
% are not yet recognized as such inside from_ground_term scopes.
|
|
implicitly_quantify_clause_body_general_vs(ord_nl_maybe_lambda,
|
|
KeepQuantVars, HeadVars, QuantWarnings, Goal1, Goal,
|
|
!VarSet, VarTypes0, VarTypes, EmptyRttiVarmaps, _),
|
|
qual_info_set_explicit_var_types(VarTypes, !QualInfo)
|
|
).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
:- end_module hlds.make_hlds.add_clause.
|
|
%-----------------------------------------------------------------------------%
|