mercurylang/mercury
1
0
Fork 0
mirror of https://github.com/Mercury-Language/mercury.git synced 2026-04-20 20:03:44 +00:00
Code Issues Projects Releases Wiki Activity
Files
bdabaf5dc94de3b405d11e2db71d34932224b6ff
mercury/compiler/parse_pragma.m
Zoltan Somogyi 9d38b252bf Separate marker pragmas from other decl/impl pragmas. 
compiler/prog_item.m:
    Previously, both decl and impl pragmas contained some pragma kinds
    that contained only the specification of a predicate or function.
    These served only to specify a marker to be applied to the named
    predicate or function.

    This diff separates out those kinds of pragmas from the types of
    both the decl pragmas and the impl pragmas (the difference is that
    decl pragmas may appear in module interfaces, while impl pragmas may not),
    and gives them two new representations: decl markers and impl markers.

    While in the old representation, each kind of marker had its own wrapper
    around the predicate/function specification, in the new representation,
    they are side-by-side, which allows simpler construction techniques
    and smaller code.

    Update the definition of parse_tree_module_src, parse_tree_plain_opt,
    parse_tree_int0 and parse_tree_int1 to include markers alongside
    pragmas of each kind. Use subtypes to restrict the kinds of markers
    that can appear in parse_tree_plain_opts to the set that we actually
    can put into them. (Source files of course can contain any markers,
    and .intN files either get put into them either all of the markers
    that occur in the source file in a given section, or none of them.)

    Delete the item_pragma_info type, which was a wrapper around
    the specific info of each pragma, and stored a context and an item
    sequence number alongside it. Move the context and the item sequence
    number into the representation of each pragma. This should reduce
    visual clutter in the source code at places that construct or deconstruct
    pragmas, and at runtime (with direct args) it should reduce both
    the number of memory cells we need to allocate, and the number
    of pointers we need to follow.

    Include decl vs impl in the names of some function symbols.

    Partly to counteract that, shorten some names to avoid excessive
    line lengths.

compiler/add_pragma.m:
    Add predicates to add decl and impl markers.

    Move the predicates looping over lists of pragma next to the
    predicates handling those pragmas.

compiler/make_hlds_passes.m:
    Add both decl and impl markers before adding foreign_procs.
    The ability to do this was the original motivation for this diff.
    Update the comments both about this issue, and about why we delay
    adding tabling pragmas to the HLDS.

compiler/check_module_interface.m:
    Conform to the changes above.

    Add an XXX about something fishy.

compiler/item_util.m:
    Delete aux functions that are no longer needed.

compiler/add_mutable_aux_preds.m:
compiler/add_pragma_tabling.m:
compiler/add_pragma_type_spec.m:
compiler/comp_unit_interface.m:
compiler/convert_parse_tree.m:
compiler/equiv_type.m:
compiler/get_dependencies.m:
compiler/grab_modules.m:
compiler/hlds_module.m:
compiler/intermod.m:
compiler/intermod_analysis.m:
compiler/make_hlds_separate_items.m:
compiler/mercury_compile_middle_passes.m:
compiler/module_qual.collect_mq_info.m:
compiler/module_qual.qual_errors.m:
compiler/module_qual.qualify_items.m:
compiler/parse_pragma.m:
compiler/parse_pragma_analysis.m:
compiler/parse_pragma_foreign.m:
compiler/parse_pragma_tabling.m:
compiler/parse_tree_out.m:
compiler/parse_tree_out_pragma.m:
compiler/prog_item_stats.m:
compiler/prog_mutable.m:
compiler/recompilation.check.m:
compiler/recompilation.usage.m:
compiler/recompilation.version.m:
compiler/unused_args.m:
    Conform to the changes above.
2023-08-06 12:33:55 +02:00

1536 lines
60 KiB
Mathematica
Raw Blame History

%---------------------------------------------------------------------------%
% vim: ft=mercury ts=4 sw=4 expandtab
%---------------------------------------------------------------------------%
% Copyright (C) 1996-2011 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.
%---------------------------------------------------------------------------%
%
% File: parse_pragma.m.
% Main authors: fjh, dgj, zs.
%
% This module handles the parsing of pragma directives.
%
%---------------------------------------------------------------------------%
:- module parse_tree.parse_pragma.
:- interface.
:- import_module mdbcomp.
:- import_module mdbcomp.sym_name.
:- import_module parse_tree.maybe_error.
:- import_module parse_tree.parse_types.
:- import_module parse_tree.prog_data.
:- import_module list.
:- import_module term.
:- import_module varset.
%---------------------------------------------------------------------------%
% Parse the pragma declaration. What it returns is not necessarily
% a pragma item, and it may not even be an item.
%
:- pred parse_pragma(module_name::in, varset::in, list(term)::in,
prog_context::in, item_seq_num::in, maybe1(item_or_marker)::out) is det.
%---------------------------------------------------------------------------%
%---------------------------------------------------------------------------%
:- implementation.
:- import_module libs.
:- import_module libs.compiler_util.
:- import_module libs.globals.
:- import_module mdbcomp.prim_data.
:- import_module parse_tree.error_spec.
:- import_module parse_tree.parse_pragma_analysis.
:- import_module parse_tree.parse_pragma_foreign.
:- import_module parse_tree.parse_pragma_tabling.
:- import_module parse_tree.parse_sym_name.
:- import_module parse_tree.parse_tree_out_term.
:- import_module parse_tree.parse_type_defn.
:- import_module parse_tree.parse_type_name.
:- import_module parse_tree.parse_util.
:- import_module parse_tree.prog_data_pragma.
:- import_module parse_tree.prog_item.
:- import_module cord.
:- import_module counter.
:- import_module int.
:- import_module maybe.
:- import_module one_or_more.
:- import_module pair.
:- import_module set.
:- import_module string.
:- import_module term_int.
%---------------------------------------------------------------------------%
parse_pragma(ModuleName, VarSet, PragmaTerms, Context, SeqNum, MaybeIOM) :-
( if
PragmaTerms = [PragmaTerm],
PragmaTerm = term.functor(term.atom(PragmaName), PragmaArgTerms,
PragmaContext)
then
( if
parse_pragma_type(ModuleName, VarSet, PragmaTerm,
PragmaName, PragmaArgTerms, PragmaContext, SeqNum,
MaybeIOMPrime)
then
MaybeIOM = MaybeIOMPrime
else
Pieces = [words("Error:"), quote(PragmaName),
words("is not a recognized pragma name."), nl],
Spec = simplest_spec($pred, severity_error,
phase_term_to_parse_tree, Context, Pieces),
MaybeIOM = error1([Spec])
)
else
Spec = report_unrecognized_pragma(Context),
MaybeIOM = error1([Spec])
).
:- pred parse_pragma_type(module_name::in, varset::in, term::in,
string::in, list(term)::in, prog_context::in, item_seq_num::in,
maybe1(item_or_marker)::out) is semidet.
parse_pragma_type(ModuleName, VarSet, ErrorTerm, PragmaName, PragmaTerms,
Context, SeqNum, MaybeIOM) :-
require_switch_arms_det [PragmaName]
(
PragmaName = "source_file",
parse_pragma_source_file(PragmaTerms, Context, MaybeIOM)
;
PragmaName = "foreign_type",
parse_pragma_foreign_type(ModuleName, VarSet, ErrorTerm,
PragmaTerms, Context, SeqNum, ok1(canon), MaybeIOM)
;
PragmaName = "foreign_decl",
parse_pragma_foreign_decl(VarSet, ErrorTerm,
PragmaTerms, Context, SeqNum, MaybeIOM)
;
PragmaName = "foreign_code",
parse_pragma_foreign_code(VarSet, ErrorTerm,
PragmaTerms, Context, SeqNum, MaybeIOM)
;
PragmaName = "foreign_proc",
parse_pragma_foreign_proc(ModuleName, VarSet, ErrorTerm,
PragmaTerms, Context, SeqNum, MaybeIOM)
;
PragmaName = "foreign_export_enum",
parse_pragma_foreign_export_enum(VarSet, ErrorTerm,
PragmaTerms, Context, SeqNum, MaybeIOM)
;
PragmaName = "foreign_enum",
parse_pragma_foreign_enum(ModuleName, VarSet, ErrorTerm,
PragmaTerms, Context, SeqNum, MaybeIOM)
;
PragmaName = "foreign_export",
parse_pragma_foreign_export(VarSet, ErrorTerm,
PragmaTerms, Context, SeqNum, MaybeIOM)
;
PragmaName = "foreign_import_module",
parse_pragma_foreign_import_module(VarSet, ErrorTerm,
PragmaTerms, Context, SeqNum, MaybeIOM)
;
(
PragmaName = "external_pred",
PorF = pf_predicate
;
PragmaName = "external_func",
PorF = pf_function
),
parse_pragma_external(ModuleName, VarSet, ErrorTerm,
PragmaName, PragmaTerms, Context, SeqNum, PorF, MaybeIOM)
;
PragmaName = "obsolete",
parse_pragma_obsolete(ModuleName, PragmaTerms, ErrorTerm, VarSet,
Context, SeqNum, MaybeIOM)
;
PragmaName = "obsolete_proc",
parse_pragma_obsolete_proc(ModuleName, PragmaTerms, ErrorTerm, VarSet,
Context, SeqNum, MaybeIOM)
;
PragmaName = "format_call",
parse_pragma_format_call(ModuleName, PragmaTerms, ErrorTerm, VarSet,
Context, SeqNum, MaybeIOM)
;
(
PragmaName = "terminates",
MarkerKind = dpmk_terminates
;
PragmaName = "does_not_terminate",
MarkerKind = dpmk_does_not_terminate
;
PragmaName = "check_termination",
MarkerKind = dpmk_check_termination
),
parse_name_arity_decl_pragma(ModuleName, PragmaName, MarkerKind,
VarSet, ErrorTerm, PragmaTerms, Context, SeqNum, MaybeIOM)
;
(
PragmaName = "inline",
MarkerKind = ipmk_inline
;
PragmaName = "no_inline",
MarkerKind = ipmk_no_inline
;
PragmaName = "consider_used",
MarkerKind = ipmk_consider_used
;
PragmaName = "mode_check_clauses",
MarkerKind = ipmk_mode_check_clauses
;
PragmaName = "no_determinism_warning",
MarkerKind = ipmk_no_detism_warning
;
PragmaName = "promise_pure",
MarkerKind = ipmk_promise_pure
;
PragmaName = "promise_semipure",
MarkerKind = ipmk_promise_semipure
;
PragmaName = "promise_equivalent_clauses",
MarkerKind = ipmk_promise_eqv_clauses
),
parse_name_arity_impl_pragma(ModuleName, PragmaName, MarkerKind,
VarSet, ErrorTerm, PragmaTerms, Context, SeqNum, MaybeIOM)
;
PragmaName = "require_tail_recursion",
parse_pragma_require_tail_recursion(ModuleName, PragmaName,
PragmaTerms, ErrorTerm, VarSet, Context, SeqNum, MaybeIOM)
;
PragmaName = "oisu",
parse_oisu_pragma(ModuleName, VarSet, ErrorTerm,
PragmaTerms, Context, SeqNum, MaybeIOM)
;
(
PragmaName = "memo",
% We don't know yet whether the pragma has a
% disable_warning_if_ignored attribute, but if it does,
% parse_tabling_pragma will override this placeholder argument.
TabledMethod = tabled_memo(table_attr_ignore_with_warning)
;
PragmaName = "loop_check",
TabledMethod = tabled_loop_check
;
PragmaName = "minimal_model",
% We don't yet know whether we will use the stack_copy or the
% own_stacks technique for computing minimal models. The decision
% depends on the grade, and is made in make_hlds.m; the
% "stack_copy" here is just a placeholder.
TabledMethod = tabled_minimal(stack_copy)
),
parse_tabling_pragma(ModuleName, VarSet, ErrorTerm,
PragmaName, PragmaTerms, Context, SeqNum, TabledMethod, MaybeIOM)
;
PragmaName = "unused_args",
parse_pragma_unused_args(ModuleName, VarSet, ErrorTerm,
PragmaTerms, Context, SeqNum, MaybeIOM)
;
PragmaName = "type_spec",
parse_pragma_type_spec(ModuleName, VarSet, ErrorTerm,
PragmaTerms, Context, SeqNum, MaybeIOM)
;
PragmaName = "fact_table",
parse_pragma_fact_table(ModuleName, VarSet, ErrorTerm,
PragmaTerms, Context, SeqNum, MaybeIOM)
;
PragmaName = "termination_info",
parse_pragma_termination_info(ModuleName, VarSet, ErrorTerm,
PragmaTerms, Context, SeqNum, MaybeIOM)
;
PragmaName = "termination2_info",
parse_pragma_termination2_info(ModuleName, VarSet, ErrorTerm,
PragmaTerms, Context, SeqNum, MaybeIOM)
;
PragmaName = "structure_sharing",
parse_pragma_structure_sharing(ModuleName, VarSet, ErrorTerm,
PragmaTerms, Context, SeqNum, MaybeIOM)
;
PragmaName = "structure_reuse",
parse_pragma_structure_reuse(ModuleName, VarSet, ErrorTerm,
PragmaTerms, Context, SeqNum, MaybeIOM)
;
PragmaName = "exceptions",
parse_pragma_exceptions(ModuleName, VarSet, ErrorTerm,
PragmaTerms, Context, SeqNum, MaybeIOM)
;
PragmaName = "trailing_info",
parse_pragma_trailing_info(ModuleName, VarSet, ErrorTerm,
PragmaTerms, Context, SeqNum, MaybeIOM)
;
PragmaName = "mm_tabling_info",
parse_pragma_mm_tabling_info(ModuleName, VarSet, ErrorTerm,
PragmaTerms, Context, SeqNum, MaybeIOM)
;
PragmaName = "require_feature_set",
parse_pragma_require_feature_set(VarSet, ErrorTerm,
PragmaTerms, Context, SeqNum, MaybeIOM)
;
PragmaName = "where",
( if
PragmaTerms = [BeforeWhereTerm, WhereTerm],
BeforeWhereTerm = term.functor(term.atom("foreign_type"),
BeforeWherePragmaTerms, BeforeWhereContext)
then
parse_where_unify_compare(ModuleName, VarSet, WhereTerm,
MaybeMaybeUC),
parse_pragma_foreign_type(ModuleName, VarSet, ErrorTerm,
BeforeWherePragmaTerms, BeforeWhereContext, SeqNum,
MaybeMaybeUC, MaybeIOM)
else
Spec = report_unrecognized_pragma(Context),
MaybeIOM = error1([Spec])
)
).
:- func report_unrecognized_pragma(prog_context) = error_spec.
report_unrecognized_pragma(Context) = Spec :-
Pieces = [words("Error: a"), decl("pragma"), words("declaration"),
words("should have the form"),
quote(":- pragma pragma_name(pragma_arguments)."), nl],
Spec = simplest_spec($pred, severity_error, phase_term_to_parse_tree,
Context, Pieces).
%---------------------------------------------------------------------------%
%
% Parse the sole argument of a (decl or impl) pragma that should contain
% a symbol name / arity pair.
%
:- pred parse_name_arity_decl_pragma(module_name::in, string::in,
decl_pragma_marker_kind::in,
varset::in, term::in, list(term)::in, prog_context::in, item_seq_num::in,
maybe1(item_or_marker)::out) is det.
parse_name_arity_decl_pragma(ModuleName, PragmaName, MarkerKind,
VarSet, ErrorTerm, PragmaTerms, Context, SeqNum, MaybeIOM) :-
(
PragmaTerms = [PragmaTerm],
parse_pred_pfu_name_arity(ModuleName, PragmaName, VarSet,
PragmaTerm, MaybePredSpec),
(
MaybePredSpec = ok1(PredSpec),
Marker = item_decl_marker_info(MarkerKind, PredSpec,
Context, SeqNum),
Item = item_decl_marker(Marker),
MaybeIOM = ok1(iom_item(Item))
;
MaybePredSpec = error1(Specs),
MaybeIOM = error1(Specs)
)
;
( PragmaTerms = []
; PragmaTerms = [_, _ | _]
),
Pieces = [words("Error: a"), pragma_decl(PragmaName),
words("declaration must have exactly one argument."), nl],
Spec = simplest_spec($pred, severity_error, phase_term_to_parse_tree,
get_term_context(ErrorTerm), Pieces),
MaybeIOM = error1([Spec])
).
:- pred parse_name_arity_impl_pragma(module_name::in, string::in,
impl_pragma_marker_kind::in,
varset::in, term::in, list(term)::in, prog_context::in, item_seq_num::in,
maybe1(item_or_marker)::out) is det.
parse_name_arity_impl_pragma(ModuleName, PragmaName, MarkerKind,
VarSet, ErrorTerm, PragmaTerms, Context, SeqNum, MaybeIOM) :-
(
PragmaTerms = [PragmaTerm],
parse_pred_pfu_name_arity(ModuleName, PragmaName, VarSet,
PragmaTerm, MaybePredSpec),
(
MaybePredSpec = ok1(PredSpec),
Marker = item_impl_marker_info(MarkerKind, PredSpec,
Context, SeqNum),
Item = item_impl_marker(Marker),
MaybeIOM = ok1(iom_item(Item))
;
MaybePredSpec = error1(Specs),
MaybeIOM = error1(Specs)
)
;
( PragmaTerms = []
; PragmaTerms = [_, _ | _]
),
Pieces = [words("Error: a"), pragma_decl(PragmaName),
words("declaration must have exactly one argument."), nl],
Spec = simplest_spec($pred, severity_error, phase_term_to_parse_tree,
get_term_context(ErrorTerm), Pieces),
MaybeIOM = error1([Spec])
).
%---------------------------------------------------------------------------%
% The predicates in the rest of this module are to be clustered together
% into groups of related predicates. All groups but the last contain
% the main predicate for parsing one kind of pragma, followed by its
% dedicated helper predicates.
%---------------------------------------------------------------------------%
%
% Parse source_file pragmas.
%
:- pred parse_pragma_source_file(list(term)::in, prog_context::in,
maybe1(item_or_marker)::out) is det.
parse_pragma_source_file(PragmaTerms, Context, MaybeIOM) :-
( if PragmaTerms = [SourceFileTerm] then
( if SourceFileTerm = term.functor(term.string(SourceFile), [], _) then
Marker = iom_marker_src_file(SourceFile),
MaybeIOM = ok1(Marker)
else
Pieces = [words("Error: the argument of a"),
pragma_decl("source_file"),
words("declaration should be a string."), nl],
Spec = simplest_spec($pred, severity_error,
phase_term_to_parse_tree, Context, Pieces),
MaybeIOM = error1([Spec])
)
else
Pieces = [words("Error: a"), pragma_decl("source_file"),
words("declaration must have exactly one argument."), nl],
Spec = simplest_spec($pred, severity_error, phase_term_to_parse_tree,
Context, Pieces),
MaybeIOM = error1([Spec])
).
%---------------------------------------------------------------------------%
%
% Parse external_pred and external_proc pragmas.
%
:- pred parse_pragma_external(module_name::in, varset::in, term::in,
string::in, list(term)::in, prog_context::in, item_seq_num::in,
pred_or_func::in, maybe1(item_or_marker)::out) is det.
parse_pragma_external(ModuleName, VarSet, ErrorTerm, PragmaName, PragmaTerms,
Context, SeqNum, PorF, MaybeIOM) :-
( if
(
PragmaTerms = [PredTerm],
MaybeOptionsTerm = no
;
PragmaTerms = [PredTerm, OptionsTerm],
MaybeOptionsTerm = yes(OptionsTerm)
)
then
ContextPieces1 = cord.from_list([words("first argument of"),
pragma_decl(PragmaName), words("declaration")]),
parse_symname_arity(VarSet, PredTerm, ContextPieces1,
MaybeSymNameArity),
ContextPieces2 = cord.from_list([words("second argument of"),
pragma_decl(PragmaName), words("declaration")]),
parse_pragma_external_options(VarSet, MaybeOptionsTerm, ContextPieces2,
MaybeMaybeBackend),
( if
MaybeSymNameArity = ok2(SymName, Arity),
MaybeMaybeBackend = ok1(MaybeBackend)
then
BaseName = unqualify_name(SymName),
FullSymName = qualified(ModuleName, BaseName),
( if partial_sym_name_is_part_of_full(SymName, FullSymName) then
PFNameArity = pred_pf_name_arity(PorF, FullSymName,
user_arity(Arity)),
External = impl_pragma_external_proc_info(PFNameArity,
MaybeBackend, Context, SeqNum),
Item = item_impl_pragma(impl_pragma_external_proc(External)),
MaybeIOM = ok1(iom_item(Item))
else
Pieces = [words("Error: the predicate name in the")] ++
cord.list(ContextPieces1) ++
[words("is not for the expected module, which is"),
qual_sym_name(ModuleName), suffix("."), nl],
Spec = simplest_spec($pred, severity_error,
phase_term_to_parse_tree,
get_term_context(ErrorTerm), Pieces),
MaybeIOM = error1([Spec])
)
else
Specs = get_any_errors2(MaybeSymNameArity)
++ get_any_errors1(MaybeMaybeBackend),
MaybeIOM = error1(Specs)
)
else
Pieces = [words("Error: a"), pragma_decl(PragmaName),
words("declaration must have one or two arguments."), nl],
Spec = simplest_spec($pred, severity_error, phase_term_to_parse_tree,
get_term_context(ErrorTerm), Pieces),
MaybeIOM = error1([Spec])
).
:- pred parse_symname_arity(varset::in, term::in, cord(format_piece)::in,
maybe2(sym_name, arity)::out) is det.
parse_symname_arity(VarSet, PredTerm, ContextPieces, MaybeSymNameArity) :-
( if PredTerm = term.functor(term.atom("/"), [NameTerm, ArityTerm], _) then
parse_symbol_name(VarSet, NameTerm, MaybeSymName),
( if term_int.decimal_term_to_int(ArityTerm, ArityPrime) then
MaybeArity = ok1(ArityPrime)
else
ArityPieces = [words("Error: in")] ++ cord.list(ContextPieces) ++
[suffix(":"), words("the arity must be an integer."), nl],
AritySpec = simplest_spec($pred, severity_error,
phase_term_to_parse_tree,
get_term_context(ArityTerm), ArityPieces),
MaybeArity = error1([AritySpec])
),
( if
MaybeSymName = ok1(SymName),
MaybeArity = ok1(Arity)
then
MaybeSymNameArity = ok2(SymName, Arity)
else
Specs = get_any_errors1(MaybeSymName)
++ get_any_errors1(MaybeArity),
MaybeSymNameArity = error2(Specs)
)
else
Pieces = [words("Error:") | cord.list(ContextPieces)] ++
[words("should be Name/Arity."), nl],
Spec = simplest_spec($pred, severity_error, phase_term_to_parse_tree,
get_term_context(PredTerm), Pieces),
MaybeSymNameArity = error2([Spec])
).
:- pred parse_pragma_external_options(varset::in, maybe(term)::in,
cord(format_piece)::in, maybe1(maybe(backend))::out) is det.
parse_pragma_external_options(VarSet, MaybeOptionsTerm, ContextPieces,
MaybeMaybeBackend) :-
(
MaybeOptionsTerm = no,
MaybeMaybeBackend = ok1(no)
;
MaybeOptionsTerm = yes(OptionsTerm),
( if
OptionsTerm = term.functor(term.atom("[]"), [], _)
then
MaybeMaybeBackend = ok1(no)
else if
OptionsTerm = term.functor(term.atom("[|]"),
[OptionsTermHead, OptionsTermTail], _),
(
OptionsTermHead =
term.functor(term.atom("low_level_backend"), [], _),
Backend = low_level_backend
;
OptionsTermHead =
term.functor(term.atom("high_level_backend"), [], _),
Backend = high_level_backend
),
OptionsTermTail = term.functor(term.atom("[]"), [], _)
then
MaybeMaybeBackend = ok1(yes(Backend))
else
OptionsTermStr = describe_error_term(VarSet, OptionsTerm),
Pieces = cord.list(ContextPieces) ++
[lower_case_next_if_not_first, words("Error:"),
words("expected either an empty list,"),
words("or a singleton list containing either"),
quote("low_level_backend"), words("or"),
quote("high_level_backend"), suffix(","),
words("got"), words(OptionsTermStr), suffix("."), nl],
Spec = simplest_spec($pred, severity_error,
phase_term_to_parse_tree,
get_term_context(OptionsTerm), Pieces),
MaybeMaybeBackend = error1([Spec])
)
).
%---------------------------------------------------------------------------%
%
% Parse obsolete and obsolete_proc pragmas.
%
:- pred parse_pragma_obsolete(module_name::in, list(term)::in, term::in,
varset::in, prog_context::in, item_seq_num::in,
maybe1(item_or_marker)::out) is det.
parse_pragma_obsolete(ModuleName, PragmaTerms, ErrorTerm, VarSet,
Context, SeqNum, MaybeIOM) :-
(
(
PragmaTerms = [PredSpecTerm],
MaybeObsoleteInFavourOf = ok1([])
;
PragmaTerms = [PredSpecTerm, ObsoleteInFavourOfTerm],
parse_pragma_obsolete_in_favour_of(ObsoleteInFavourOfTerm,
VarSet, MaybeObsoleteInFavourOf)
),
parse_pred_pfu_name_arity(ModuleName, "obsolete",
VarSet, PredSpecTerm, MaybePredSpec),
( if
MaybePredSpec = ok1(PredSpec),
MaybeObsoleteInFavourOf = ok1(ObsoleteInFavourOf)
then
Obsolete = decl_pragma_obsolete_pred_info(PredSpec,
ObsoleteInFavourOf, Context, SeqNum),
Item = item_decl_pragma(decl_pragma_obsolete_pred(Obsolete)),
MaybeIOM = ok1(iom_item(Item))
else
Specs =
get_any_errors1(MaybePredSpec) ++
get_any_errors1(MaybeObsoleteInFavourOf),
MaybeIOM = error1(Specs)
)
;
( PragmaTerms = []
; PragmaTerms = [_, _, _ | _]
),
Pieces = [words("Error: an"), pragma_decl("obsolete"),
words("declaration must have one or two arguments."), nl],
Spec = simplest_spec($pred, severity_error, phase_term_to_parse_tree,
get_term_context(ErrorTerm), Pieces),
MaybeIOM = error1([Spec])
).
:- pred parse_pragma_obsolete_proc(module_name::in, list(term)::in, term::in,
varset::in, prog_context::in, item_seq_num::in,
maybe1(item_or_marker)::out) is det.
parse_pragma_obsolete_proc(ModuleName, PragmaTerms, ErrorTerm, VarSet,
Context, SeqNum, MaybeIOM) :-
(
(
PragmaTerms = [PredAndModesTerm],
MaybeObsoleteInFavourOf = ok1([])
;
PragmaTerms = [PredAndModesTerm, ObsoleteInFavourOfTerm],
parse_pragma_obsolete_in_favour_of(ObsoleteInFavourOfTerm,
VarSet, MaybeObsoleteInFavourOf)
),
PredAndModesContextPieces = cord.from_list(
[words("In the first argument of"), pragma_decl("obsolete_proc"),
words("declaration:"), nl]),
parse_pred_or_func_and_arg_modes(yes(ModuleName),
PredAndModesContextPieces, VarSet, PredAndModesTerm,
MaybePredAndModes),
( if
MaybePredAndModes = ok3(PredName, PredOrFunc, Modes),
MaybeObsoleteInFavourOf = ok1(ObsoleteInFavourOf)
then
PredNameModesPF = proc_pf_name_modes(PredOrFunc, PredName, Modes),
Obsolete = decl_pragma_obsolete_proc_info(PredNameModesPF,
ObsoleteInFavourOf, Context, SeqNum),
Item = item_decl_pragma(decl_pragma_obsolete_proc(Obsolete)),
MaybeIOM = ok1(iom_item(Item))
else
Specs =
get_any_errors3(MaybePredAndModes) ++
get_any_errors1(MaybeObsoleteInFavourOf),
MaybeIOM = error1(Specs)
)
;
( PragmaTerms = []
; PragmaTerms = [_, _, _ | _]
),
Pieces = [words("Error: an"), pragma_decl("obsolete_proc"),
words("declaration must have one or two arguments."), nl],
Spec = simplest_spec($pred, severity_error, phase_term_to_parse_tree,
get_term_context(ErrorTerm), Pieces),
MaybeIOM = error1([Spec])
).
:- pred parse_pragma_obsolete_in_favour_of(term::in, varset::in,
maybe1(list(sym_name_arity))::out) is det.
parse_pragma_obsolete_in_favour_of(Term, VarSet, MaybeObsoleteInFavourOf) :-
( if list_term_to_term_list(Term, Terms) then
parse_pragma_obsolete_in_favour_of_snas(1, Terms, VarSet,
MaybeObsoleteInFavourOf)
else
Pieces = [words("Error: the second argument of a"),
pragma_decl("obsolete"), words("declaration"),
words("should be a list of the names and arities of the"),
words("suggested replacement predicates and/or functions."), nl],
Spec = simplest_spec($pred, severity_error, phase_term_to_parse_tree,
get_term_context(Term), Pieces),
MaybeObsoleteInFavourOf = error1([Spec])
).
:- pred parse_pragma_obsolete_in_favour_of_snas(int::in, list(term)::in,
varset::in, maybe1(list(sym_name_arity))::out) is det.
parse_pragma_obsolete_in_favour_of_snas(_ArgNum, [], _VarSet, ok1([])).
parse_pragma_obsolete_in_favour_of_snas(ArgNum, [Term | Terms], VarSet,
MaybeSNAs) :-
( if parse_sym_name_and_arity(Term, SymName, Arity) then
MaybeHeadSNA = ok1(sym_name_arity(SymName, Arity))
else
Pieces = [words("In the"), nth_fixed(ArgNum),
words("element in the second argument of"),
pragma_decl("obsolete"), words("declaration:"), nl,
words("error: expected a name/arity pair, got"),
quote(describe_error_term(VarSet, Term)), suffix("."), nl],
Spec = simplest_spec($pred, severity_error, phase_term_to_parse_tree,
get_term_context(Term), Pieces),
MaybeHeadSNA = error1([Spec])
),
parse_pragma_obsolete_in_favour_of_snas(ArgNum + 1, Terms, VarSet,
MaybeTailSNAs),
( if
MaybeHeadSNA = ok1(HeadSNA),
MaybeTailSNAs = ok1(TailSNAs)
then
MaybeSNAs = ok1([HeadSNA | TailSNAs])
else
Specs =
get_any_errors1(MaybeHeadSNA) ++
get_any_errors1(MaybeTailSNAs),
MaybeSNAs = error1(Specs)
).
%---------------------------------------------------------------------------%
%
% Parse format_call pragmas.
%
:- pred parse_pragma_format_call(module_name::in, list(term)::in, term::in,
varset::in, prog_context::in, item_seq_num::in,
maybe1(item_or_marker)::out) is det.
parse_pragma_format_call(ModuleName, PragmaTerms, ErrorTerm, VarSet,
Context, SeqNum, MaybeIOM) :-
(
PragmaTerms = [PredSpecTerm, FormatCallTerm],
parse_pred_pf_name_arity(ModuleName, "format_call",
VarSet, PredSpecTerm, MaybePredSpec),
( if
maybe_parse_format_string_values(FormatCallTerm,
MaybeFormatCallPrime)
then
MaybeFormatCall = MaybeFormatCallPrime
else if
list_term_to_term_list(FormatCallTerm, FormatCallTerms),
FormatCallTerms = [HeadFormatCallTerm | TailFormatCallTerms]
then
parse_format_string_values_terms(VarSet, 1, HeadFormatCallTerm,
TailFormatCallTerms, MaybeFormatCall)
else
FormatCallPieces = [words("Error: the second argument of a"),
pragma_decl("format_call"), words("declaration"),
words("either must be a term of the form"),
quote("format_string_values(N, M)"),
words("where N and M are strictly positive integers"),
words("or a nonempty list of such terms."), nl],
FormatCallSpec = simplest_spec($pred, severity_error,
phase_term_to_parse_tree, get_term_context(FormatCallTerm),
FormatCallPieces),
MaybeFormatCall = error1([FormatCallSpec])
),
( if
MaybePredSpec = ok1(PredSpec),
MaybeFormatCall = ok1(FormatCall)
then
FormatCallPragma = decl_pragma_format_call_info(PredSpec,
FormatCall, Context, SeqNum),
Item = item_decl_pragma(decl_pragma_format_call(FormatCallPragma)),
MaybeIOM = ok1(iom_item(Item))
else
IOMSpecs =
get_any_errors1(MaybePredSpec) ++
get_any_errors1(MaybeFormatCall),
MaybeIOM = error1(IOMSpecs)
)
;
( PragmaTerms = []
; PragmaTerms = [_]
; PragmaTerms = [_, _, _ | _]
),
Pieces = [words("Error: a"), pragma_decl("format_call"),
words("declaration must have two arguments."), nl],
Spec = simplest_spec($pred, severity_error, phase_term_to_parse_tree,
get_term_context(ErrorTerm), Pieces),
MaybeIOM = error1([Spec])
).
:- pred maybe_parse_format_string_values(term::in,
maybe1(one_or_more(format_string_values))::out) is semidet.
maybe_parse_format_string_values(Term, MaybeOoMFormatStringValues) :-
Term = term.functor(Functor, ArgTerms, _Context),
Functor = term.atom("format_string_values"),
require_det (
parse_format_string_values_args(no, Term, ArgTerms,
MaybeFormatStringValues),
(
MaybeFormatStringValues = ok1(FormatStringValues),
MaybeOoMFormatStringValues =
ok1(one_or_more(FormatStringValues, []))
;
MaybeFormatStringValues = error1(Specs),
MaybeOoMFormatStringValues = error1(Specs)
)
).
:- pred parse_format_string_values_terms(varset::in, int::in,
term::in, list(term)::in,
maybe1(one_or_more(format_string_values))::out) is det.
parse_format_string_values_terms(VarSet, ListPos, HeadTerm, TailTerms,
MaybeOoMFormatStringValues) :-
(
TailTerms = [],
TailFormatStringValues = [],
TailSpecs = []
;
TailTerms = [HeadTailTerm | TailTailTerms],
parse_format_string_values_terms(VarSet, ListPos + 1,
HeadTailTerm, TailTailTerms, MaybeOoMTailFormatStringValues),
(
MaybeOoMTailFormatStringValues = ok1(OoMTailFormatStringValues),
TailFormatStringValues =
one_or_more_to_list(OoMTailFormatStringValues),
TailSpecs = []
;
MaybeOoMTailFormatStringValues = error1(TailSpecs),
TailFormatStringValues = []
)
),
( if
HeadTerm = term.functor(HeadFunctor, HeadArgTerms, _Context),
HeadFunctor = term.atom("format_string_values")
then
parse_format_string_values_args(yes(ListPos), HeadTerm, HeadArgTerms,
MaybeHeadFormatStringValues),
( if
MaybeHeadFormatStringValues = ok1(HeadFormatStringValues),
TailSpecs = []
then
OoMFormatStringValues =
one_or_more(HeadFormatStringValues, TailFormatStringValues),
MaybeOoMFormatStringValues = ok1(OoMFormatStringValues)
else
Specs = get_any_errors1(MaybeHeadFormatStringValues) ++ TailSpecs,
MaybeOoMFormatStringValues = error1(Specs)
)
else
ErrorTermStr = describe_error_term(VarSet, HeadTerm),
HeadPieces = format_string_values_context(yes(ListPos)) ++
[words("expected a term of the form"),
quote("format_string_values(N, M)"),
words("where N and M are strictly positive integers,"),
words("got"), quote(ErrorTermStr), suffix("."), nl],
HeadSpec = simplest_spec($pred, severity_error,
phase_term_to_parse_tree, get_term_context(HeadTerm), HeadPieces),
Specs = [HeadSpec | TailSpecs],
MaybeOoMFormatStringValues = error1(Specs)
).
:- pred parse_format_string_values_args(maybe(int)::in, term::in,
list(term)::in, maybe1(format_string_values)::out) is det.
parse_format_string_values_args(MaybeListPos, ErrorTerm, ArgTerms,
MaybeFormatStringValues) :-
(
ArgTerms = [TermFS, TermVL],
parse_arg_num(MaybeListPos, fs, TermFS, MaybeArgNumFS),
parse_arg_num(MaybeListPos, vl, TermVL, MaybeArgNumVL),
( if
MaybeArgNumFS = ok1(ArgNumFS),
MaybeArgNumVL = ok1(ArgNumVL)
then
FormatStringValues = format_string_values(ArgNumFS, ArgNumVL,
ArgNumFS, ArgNumVL),
MaybeFormatStringValues = ok1(FormatStringValues)
else
Specs =
get_any_errors1(MaybeArgNumFS) ++
get_any_errors1(MaybeArgNumVL),
MaybeFormatStringValues = error1(Specs)
)
;
( ArgTerms = []
; ArgTerms = [_]
; ArgTerms = [_, _, _ | _]
),
Pieces = format_string_values_context(MaybeListPos) ++
[words("format_string_values must have two arguments."), nl],
Spec = simplest_spec($pred, severity_error,
phase_term_to_parse_tree, get_term_context(ErrorTerm), Pieces),
MaybeFormatStringValues = error1([Spec])
).
:- pred parse_arg_num(maybe(int)::in, fs_vl::in, term::in,
maybe1(int)::out) is det.
parse_arg_num(MaybeListPos, FS_VL, Term, MaybeArgNum) :-
% The wording of the error messages is a bit strained,
% because we are talking at an *argument* of the format_string_values
% function symbol that is itself an *argument number*.
( if term_int.decimal_term_to_int(Term, Int) then
% We could check that Int > 0 here, but we won't know the upper bound
% we want to check against until later. It is simpler to have code
% in check_pragma_format_call_preds.m to check the argument number
% against both the lower and upper bounds.
MaybeArgNum = ok1(Int)
else
Pieces = arg_num_context(MaybeListPos, FS_VL) ++
[words("the argument number must be an integer."), nl],
Spec = simplest_spec($pred, severity_error,
phase_term_to_parse_tree, get_term_context(Term), Pieces),
MaybeArgNum = error1([Spec])
).
:- func format_string_values_context(maybe(int)) = list(format_piece).
format_string_values_context(MaybeListPos) = Pieces :-
Pieces0 = [words("Error: in the second argument of a"),
pragma_decl("format_call"), words("declaration:")],
(
MaybeListPos = no,
Pieces = Pieces0
;
MaybeListPos = yes(ListPos),
Pieces = [words("in the"), nth_fixed(ListPos),
words("element of the list:") | Pieces0]
).
:- type fs_vl
---> fs % The format string argument of format_string_values.
; vl. % The value list argument of format_string_values.
:- func arg_num_context(maybe(int), fs_vl) = list(format_piece).
arg_num_context(MaybeListPos, FS_VL) = Pieces :-
Pieces0 = format_string_values_context(MaybeListPos),
(
FS_VL = fs,
FS_VL_Str = "first"
;
FS_VL = vl,
FS_VL_Str = "second"
),
Pieces = [words("in the"), words(FS_VL_Str), words("argument"),
words("of format_string_values:") | Pieces0].
%---------------------------------------------------------------------------%
%
% Parse require_tail_recursion pragmas.
%
:- pred parse_pragma_require_tail_recursion(module_name::in, string::in,
list(term)::in, term::in, varset::in, prog_context::in, item_seq_num::in,
maybe1(item_or_marker)::out) is det.
parse_pragma_require_tail_recursion(ModuleName, PragmaName, PragmaTerms,
_ErrorTerm, VarSet, Context, SeqNum, MaybeIOM) :-
(
(
PragmaTerms = [PredOrProcSpecTerm],
MaybeOptionsTerm = no
;
PragmaTerms = [PredOrProcSpecTerm, OptionsTermPrime],
MaybeOptionsTerm = yes(OptionsTermPrime)
),
% Parse the procedure name.
ContextPieces = cord.from_list([words("In the first argument of"),
pragma_decl(PragmaName), words("declaration:"), nl]),
parse_pred_pfu_name_arity_maybe_modes(ModuleName, ContextPieces,
VarSet, PredOrProcSpecTerm, MaybePredOrProcSpec),
% Parse the options.
(
MaybeOptionsTerm = yes(OptionsTerm),
( if list_term_to_term_list(OptionsTerm, OptionsTerms) then
parse_pragma_require_tail_recursion_options(OptionsTerms,
have_not_seen_none, no, no, [], Context, MaybeOptions)
else
OptionsContext = get_term_context(OptionsTerm),
OptionsTermStr = describe_error_term(VarSet, OptionsTerm),
Pieces = [words("In the second argument of"),
pragma_decl("require_tail_recursion"),
words("declaration:"), nl,
words("error: expected attribute list, got"),
quote(OptionsTermStr), suffix("."), nl],
Spec = simplest_spec($pred, severity_error,
phase_term_to_parse_tree, OptionsContext, Pieces),
MaybeOptions = error1([Spec])
)
;
MaybeOptionsTerm = no,
MaybeOptions = ok1(enable_tailrec_warnings(we_warning,
both_self_and_mutual_recursion_must_be_tail, Context))
),
( if
MaybePredOrProcSpec = ok1(PredOrProcSpec),
MaybeOptions = ok1(Options)
then
TailRec = impl_pragma_req_tail_rec_info(PredOrProcSpec, Options,
Context, SeqNum),
Item = item_impl_pragma(impl_pragma_req_tail_rec(TailRec)),
MaybeIOM = ok1(iom_item(Item))
else
Specs = get_any_errors1(MaybePredOrProcSpec) ++
get_any_errors1(MaybeOptions),
MaybeIOM = error1(Specs)
)
;
( PragmaTerms = []
; PragmaTerms = [_, _, _ | _]
),
Pieces = [words("Error: a"), pragma_decl(PragmaName),
words("declaration must have one or two arguments."), nl],
Spec = simplest_spec($pred, severity_error, phase_term_to_parse_tree,
Context, Pieces),
MaybeIOM = error1([Spec])
).
:- type seen_none
---> seen_none
; have_not_seen_none.
:- pred parse_pragma_require_tail_recursion_options(list(term)::in,
seen_none::in, maybe(warning_or_error)::in,
maybe(require_tail_recursion_type)::in, list(error_spec)::in,
prog_context::in, maybe1(require_tail_recursion)::out) is det.
parse_pragma_require_tail_recursion_options([], SeenNone, MaybeWarnOrError,
MaybeType, !.Specs, Context, MaybeRTR) :-
(
SeenNone = seen_none,
% Check for conflicts with "none" option.
(
MaybeWarnOrError = yes(WarnOrError0),
warning_or_error_string(WarnOrError0, WarnOrErrorString),
SpecA = conflicting_attributes_error("none", WarnOrErrorString,
Context),
!:Specs = [SpecA | !.Specs]
;
MaybeWarnOrError = no
),
(
MaybeType = yes(Type0),
require_tailrec_type_string(Type0, TypeString),
SpecB = conflicting_attributes_error("none", TypeString,
Context),
!:Specs = [SpecB | !.Specs]
;
MaybeType = no
)
;
SeenNone = have_not_seen_none
),
(
!.Specs = [_ | _],
MaybeRTR = error1(!.Specs)
;
!.Specs = [],
(
SeenNone = seen_none,
MaybeRTR = ok1(suppress_tailrec_warnings(Context))
;
SeenNone = have_not_seen_none,
% If these values were not set then use the defaults.
(
MaybeWarnOrError = yes(WarnOrError)
;
MaybeWarnOrError = no,
WarnOrError = we_warning
),
(
MaybeType = yes(Type)
;
MaybeType = no,
Type = both_self_and_mutual_recursion_must_be_tail
),
RTR = enable_tailrec_warnings(WarnOrError, Type, Context),
MaybeRTR = ok1(RTR)
)
).
parse_pragma_require_tail_recursion_options([Term | Terms], SeenNone0,
MaybeWarnOrError0, MaybeType0, !.Specs, PragmaContext, MaybeRTR) :-
(
Term = functor(Functor, _Args, Context),
( if
Functor = atom(Name),
warning_or_error_string(WarnOrError, Name)
then
(
MaybeWarnOrError0 = no,
MaybeWarnOrError = yes(WarnOrError)
;
MaybeWarnOrError0 = yes(WarnOrErrorFirst),
warning_or_error_string(WarnOrErrorFirst,
WarnOrErrorFirstString),
Spec = conflicting_attributes_error(Name,
WarnOrErrorFirstString, Context),
MaybeWarnOrError = MaybeWarnOrError0,
!:Specs = [Spec | !.Specs]
),
MaybeType = MaybeType0,
SeenNone = SeenNone0
else if
Functor = atom(Name),
require_tailrec_type_string(Type, Name)
then
(
MaybeType0 = no,
MaybeType = yes(Type)
;
MaybeType0 = yes(TypeFirst),
require_tailrec_type_string(TypeFirst, TypeFirstString),
Spec = conflicting_attributes_error(Name,
TypeFirstString, Context),
MaybeType = MaybeType0,
!:Specs = [Spec | !.Specs]
),
MaybeWarnOrError = MaybeWarnOrError0,
SeenNone = SeenNone0
else if
Functor = atom("none")
then
SeenNone = seen_none,
MaybeWarnOrError = MaybeWarnOrError0,
MaybeType = MaybeType0
else
Spec = pragma_require_tailrec_unknown_term_error(Term, Context),
!:Specs = [Spec | !.Specs],
SeenNone = SeenNone0,
MaybeType = MaybeType0,
MaybeWarnOrError = MaybeWarnOrError0
)
;
Term = variable(_, Context),
Spec = pragma_require_tailrec_unknown_term_error(Term, Context),
!:Specs = [Spec | !.Specs],
SeenNone = SeenNone0,
MaybeType = MaybeType0,
MaybeWarnOrError = MaybeWarnOrError0
),
parse_pragma_require_tail_recursion_options(Terms, SeenNone,
MaybeWarnOrError, MaybeType, !.Specs, PragmaContext, MaybeRTR).
:- func conflicting_attributes_error(string, string, prog_context) =
error_spec.
conflicting_attributes_error(ThisName, EarlierName, Context) = Spec :-
Pieces = [words("Error: conflicting "),
pragma_decl("require_tail_recursion"), words("attributes: "),
quote(ThisName), words("conflicts with earlier attribute"),
quote(EarlierName), suffix("."), nl],
Spec = simplest_spec($pred, severity_error, phase_term_to_parse_tree,
Context, Pieces).
:- func pragma_require_tailrec_unknown_term_error(term, prog_context) =
error_spec.
pragma_require_tailrec_unknown_term_error(Term, Context) = Spec :-
varset.init(VarSet),
Pieces = [words("Error: unrecognised "),
pragma_decl("require_tail_recursion"), words("attribute: "),
quote(describe_error_term(VarSet, Term)), suffix("."), nl],
Spec = simplest_spec($pred, severity_error, phase_term_to_parse_tree,
Context, Pieces).
%---------------------------------------------------------------------------%
%
% Parse oisu (order-independent state update) pragmas.
%
:- pred parse_oisu_pragma(module_name::in, varset::in, term::in,
list(term)::in, prog_context::in, item_seq_num::in,
maybe1(item_or_marker)::out) is det.
parse_oisu_pragma(ModuleName, VarSet, ErrorTerm, PragmaTerms, Context, SeqNum,
MaybeIOM) :-
(
PragmaTerms = [TypeCtorTerm, CreatorsTerm, MutatorsTerm | OtherTerms],
(
OtherTerms = [],
MaybeDestructorsTerm = no
;
OtherTerms = [DestructorsTerm],
MaybeDestructorsTerm = yes(DestructorsTerm)
),
( if parse_sym_name_and_arity(TypeCtorTerm, SymName0, Arity) then
implicitly_qualify_sym_name(ModuleName, TypeCtorTerm,
SymName0, MaybeSymName),
(
MaybeSymName = ok1(SymName),
MaybeTypeCtor = ok1(type_ctor(SymName, Arity))
;
MaybeSymName = error1(SymNameSpecs),
MaybeTypeCtor = error1(SymNameSpecs)
)
else
TypeCtorTermStr = describe_error_term(VarSet, TypeCtorTerm),
Pieces = [words("In the first argument of"),
pragma_decl("oisu"), words("declaration:"), nl,
words("error: expected predicate name/arity, got"),
quote(TypeCtorTermStr), suffix("."), nl],
TypeCtorSpec = simplest_spec($pred, severity_error,
phase_term_to_parse_tree, get_term_context(ErrorTerm), Pieces),
MaybeTypeCtor = error1([TypeCtorSpec])
),
parse_oisu_preds_term(ModuleName, VarSet, "second", "creators",
CreatorsTerm, MaybeCreatorsNamesArities),
parse_oisu_preds_term(ModuleName, VarSet, "third", "mutators",
MutatorsTerm, MaybeMutatorsNamesArities),
(
MaybeDestructorsTerm = yes(DestructorsTerm2),
parse_oisu_preds_term(ModuleName, VarSet, "fourth", "destructors",
DestructorsTerm2, MaybeDestructorsNamesArities)
;
MaybeDestructorsTerm = no,
MaybeDestructorsNamesArities = ok1([])
),
( if
MaybeTypeCtor = ok1(TypeCtor),
MaybeCreatorsNamesArities = ok1(CreatorsNamesArities),
MaybeMutatorsNamesArities = ok1(MutatorsNamesArities),
MaybeDestructorsNamesArities = ok1(DestructorsNamesArities)
then
OISU = decl_pragma_oisu_info(TypeCtor, CreatorsNamesArities,
MutatorsNamesArities, DestructorsNamesArities,
Context, SeqNum),
Item = item_decl_pragma(decl_pragma_oisu(OISU)),
MaybeIOM = ok1(iom_item(Item))
else
Specs = get_any_errors1(MaybeTypeCtor) ++
get_any_errors1(MaybeCreatorsNamesArities) ++
get_any_errors1(MaybeMutatorsNamesArities) ++
get_any_errors1(MaybeDestructorsNamesArities),
MaybeIOM = error1(Specs)
)
;
( PragmaTerms = []
; PragmaTerms = [_]
; PragmaTerms = [_, _]
; PragmaTerms = [_, _, _, _, _ | _]
),
Pieces = [words("Error: a"), pragma_decl("oisu"),
words("declaration must have three or four arguments."), nl],
Spec = simplest_spec($pred, severity_error, phase_term_to_parse_tree,
get_term_context(ErrorTerm), Pieces),
MaybeIOM = error1([Spec])
).
:- pred parse_oisu_preds_term(module_name::in, varset::in, string::in,
string::in, term::in, maybe1(list(pred_pf_name_arity))::out) is det.
parse_oisu_preds_term(ModuleName, VarSet, ArgNum, ExpectedFunctor, Term,
MaybePredSpecs) :-
( if
Term = term.functor(term.atom(Functor), ArgTerms, _),
Functor = ExpectedFunctor,
ArgTerms = [ArgTerm]
then
parse_list_elements("a list of predicate or function names/arities",
parse_pred_pf_name_arity(ModuleName, "oisu"), VarSet,
ArgTerm, MaybePredSpecs)
else
Pieces = [words("Error:"), words(ArgNum), words("argument of"),
pragma_decl("oisu"), words("declaration"),
words("should have the form"),
quote(ExpectedFunctor ++
"([pred(name1/arity1), ..., pred(namen/arityn)])"),
suffix("."), nl],
Spec = simplest_spec($pred, severity_error, phase_term_to_parse_tree,
get_term_context(Term), Pieces),
MaybePredSpecs = error1([Spec])
).
%---------------------------------------------------------------------------%
%
% Parse type_spec pragmas.
%
:- pred parse_pragma_type_spec(module_name::in, varset::in, term::in,
list(term)::in, prog_context::in, item_seq_num::in,
maybe1(item_or_marker)::out) is det.
parse_pragma_type_spec(ModuleName, VarSet0, ErrorTerm, PragmaTerms,
Context, SeqNum, MaybeIOM) :-
( if
( PragmaTerms = [PredAndModesTerm, TypeSubnTerm]
; PragmaTerms = [PredAndModesTerm, TypeSubnTerm, _]
)
then
ArityOrModesContextPieces = cord.from_list(
[words("In the first argument"), pragma_decl("type_spec"),
words("declaration:"), nl]),
parse_pred_pfu_name_arity_maybe_modes(ModuleName,
ArityOrModesContextPieces, VarSet0, PredAndModesTerm,
MaybePredOrProcSpec),
(
MaybePredOrProcSpec = ok1(PredOrProcSpec),
PredOrProcSpec = pred_or_proc_pfumm_name(PFUMM, PredName),
% Give any anonymous variables in TypeSubnTerm names that
% do not conflict with the names of any named variables,
% nor, due to the use of sequence numbers, with each other.
acc_var_names_in_term(VarSet0, TypeSubnTerm,
set.init, NamedVarNames),
name_unnamed_vars_in_term(NamedVarNames, TypeSubnTerm,
counter.init(1), _, VarSet0, VarSet),
conjunction_to_one_or_more(TypeSubnTerm, TypeSubnTerms),
TypeSubnTerms = one_or_more(HeadSubnTerm, TailSubnTerms),
( if
parse_type_spec_pair(HeadSubnTerm, HeadTypeSubn),
list.map(parse_type_spec_pair, TailSubnTerms, TailTypeSubns)
then
% The varset is actually a tvarset.
varset.coerce(VarSet, TVarSet),
TypeSubns = one_or_more(HeadTypeSubn, TailTypeSubns),
TypeSpec = decl_pragma_type_spec_info(PFUMM, PredName,
ModuleName, TypeSubns, TVarSet, set.init, Context, SeqNum),
Item = item_decl_pragma(decl_pragma_type_spec(TypeSpec)),
MaybeIOM = ok1(iom_item(Item))
else
TypeSubnTermStr = describe_error_term(VarSet0, TypeSubnTerm),
Pieces = [words("In the second argument of"),
pragma_decl("type_spec"), words("declaration:"), nl,
words("error: expected a type substitution, got"),
quote(TypeSubnTermStr), suffix("."), nl],
TypeSubnContext = get_term_context(TypeSubnTerm),
Spec = simplest_spec($pred, severity_error,
phase_term_to_parse_tree, TypeSubnContext, Pieces),
MaybeIOM = error1([Spec])
)
;
MaybePredOrProcSpec = error1(Specs),
MaybeIOM = error1(Specs)
)
else
% XXX We allow three as a bootstrapping measure.
Pieces = [words("Error: a"), pragma_decl("type_spec"),
words("declaration must have two arguments."), nl],
Spec = simplest_spec($pred, severity_error, phase_term_to_parse_tree,
get_term_context(ErrorTerm), Pieces),
MaybeIOM = error1([Spec])
).
:- pred parse_type_spec_pair(term::in, pair(tvar, mer_type)::out) is semidet.
parse_type_spec_pair(Term, TypeSpec) :-
Term = term.functor(term.atom("="), [TypeVarTerm, SpecTypeTerm], _),
TypeVarTerm = term.variable(TypeVar0, _),
term.coerce_var(TypeVar0, TypeVar),
% XXX We should call parse_type instead.
maybe_parse_type(no_allow_ho_inst_info(wnhii_pragma_type_spec),
SpecTypeTerm, SpecType),
TypeSpec = TypeVar - SpecType.
%---------------------%
:- pred acc_var_names_in_term(varset::in, term::in,
set(string)::in, set(string)::out) is det.
acc_var_names_in_term(VarSet, Term, !VarNames) :-
(
Term = term.variable(Var, _Context),
( if varset.search_name(VarSet, Var, VarName) then
set.insert(VarName, !VarNames)
else
true
)
;
Term = term.functor(_Functor, ArgTerms, _Context),
acc_var_names_in_terms(VarSet, ArgTerms, !VarNames)
).
:- pred acc_var_names_in_terms(varset::in, list(term)::in,
set(string)::in, set(string)::out) is det.
acc_var_names_in_terms(_, [], !VarNames).
acc_var_names_in_terms(VarSet, [Term | Terms], !VarNames) :-
acc_var_names_in_term(VarSet, Term, !VarNames),
acc_var_names_in_terms(VarSet, Terms, !VarNames).
%---------------------%
:- pred name_unnamed_vars_in_term(set(string)::in, term::in,
counter::in, counter::out, varset::in, varset::out) is det.
name_unnamed_vars_in_term(NamedVarNames, Term, !Counter, !VarSet) :-
(
Term = term.variable(Var, _Context),
( if varset.search_name(!.VarSet, Var, _VarName) then
true
else
name_anonymous_variable(NamedVarNames, Var, !Counter, !VarSet)
)
;
Term = term.functor(_Functor, ArgTerms, _Context),
name_unnamed_vars_in_terms(NamedVarNames, ArgTerms, !Counter, !VarSet)
).
:- pred name_unnamed_vars_in_terms(set(string)::in, list(term)::in,
counter::in, counter::out, varset::in, varset::out) is det.
name_unnamed_vars_in_terms(_, [], !Counter, !VarSet).
name_unnamed_vars_in_terms(NamedVarNames, [Term | Terms], !Counter, !VarSet) :-
name_unnamed_vars_in_term(NamedVarNames, Term, !Counter, !VarSet),
name_unnamed_vars_in_terms(NamedVarNames, Terms, !Counter, !VarSet).
:- pred name_anonymous_variable(set(string)::in, var::in,
counter::in, counter::out, varset::in, varset::out) is det.
name_anonymous_variable(NamedVarNames, AnonVar, !Counter, !VarSet) :-
counter.allocate(SeqNum, !Counter),
VarName = "Anon" ++ int_to_string(SeqNum),
( if set.contains(NamedVarNames, VarName) then
% VarName is in use; try again with the updated counter.
name_anonymous_variable(NamedVarNames, AnonVar, !Counter, !VarSet)
else
varset.name_var(AnonVar, VarName, !VarSet)
).
%---------------------------------------------------------------------------%
%
% Parse fact_table pragmas.
%
:- pred parse_pragma_fact_table(module_name::in, varset::in, term::in,
list(term)::in, prog_context::in, item_seq_num::in,
maybe1(item_or_marker)::out) is det.
parse_pragma_fact_table(ModuleName, VarSet, ErrorTerm, PragmaTerms,
Context, SeqNum, MaybeIOM) :-
(
PragmaTerms = [PredAndArityTerm, FileNameTerm],
parse_pred_pfu_name_arity(ModuleName, "fact_table",
VarSet, PredAndArityTerm, MaybePredSpec),
(
MaybePredSpec = ok1(PredSpec),
( if FileNameTerm = term.functor(term.string(FileName), [], _) then
FactTable = impl_pragma_fact_table_info(PredSpec, FileName,
Context, SeqNum),
Item = item_impl_pragma(impl_pragma_fact_table(FactTable)),
MaybeIOM = ok1(iom_item(Item))
else
FileNameTermStr = describe_error_term(VarSet, FileNameTerm),
Pieces = [words("In the second argument of"),
pragma_decl("fact_table"), words("declaration:"), nl,
words("error: expected a string specifying a filename,"),
words("got"), quote(FileNameTermStr), suffix("."), nl],
Spec = simplest_spec($pred, severity_error,
phase_term_to_parse_tree,
get_term_context(FileNameTerm), Pieces),
MaybeIOM = error1([Spec])
)
;
MaybePredSpec = error1(Specs),
MaybeIOM = error1(Specs)
)
;
( PragmaTerms = []
; PragmaTerms = [_]
; PragmaTerms = [_, _, _ | _]
),
Pieces = [words("Error: a"), pragma_decl("fact_table"),
words("declaration must have two arguments."), nl],
Spec = simplest_spec($pred, severity_error, phase_term_to_parse_tree,
get_term_context(ErrorTerm), Pieces),
MaybeIOM = error1([Spec])
).
%---------------------------------------------------------------------------%
%
% Parse require_feature_set pragmas.
%
:- pred parse_pragma_require_feature_set(varset::in, term::in, list(term)::in,
prog_context::in, item_seq_num::in, maybe1(item_or_marker)::out) is det.
parse_pragma_require_feature_set(VarSet, ErrorTerm, PragmaTerms,
Context, SeqNum, MaybeIOM) :-
(
PragmaTerms = [FeatureListTerm],
parse_list_elements("a list of features", parse_required_feature,
VarSet, FeatureListTerm, MaybeFeatureList),
(
MaybeFeatureList = ok1(FeatureList),
ConflictingFeatures = [
conflict(reqf_single_prec_float, reqf_double_prec_float,
"floats cannot be both single- and double-precision"),
conflict(reqf_parallel_conj, reqf_trailing,
"trailing works only with sequential conjunctions")
],
FeatureListContext = get_term_context(FeatureListTerm),
report_any_conflicts(FeatureListContext,
"conflicting features in feature set",
ConflictingFeatures, FeatureList, ConflictSpecs),
(
ConflictSpecs = [_ | _],
MaybeIOM = error1(ConflictSpecs)
;
ConflictSpecs = [],
(
FeatureList = [],
MaybeIOM = ok1(iom_handled_no_error)
;
FeatureList = [_ | _],
FeatureSet = set.list_to_set(FeatureList),
RFSInfo = impl_pragma_req_feature_set_info(FeatureSet,
Context, SeqNum),
Pragma = impl_pragma_req_feature_set(RFSInfo),
Item = item_impl_pragma(Pragma),
MaybeIOM = ok1(iom_item(Item))
)
)
;
MaybeFeatureList = error1(Specs),
MaybeIOM = error1(Specs)
)
;
( PragmaTerms = []
; PragmaTerms = [_, _ | _]
),
Pieces = [words("Error: a"), pragma_decl("require_feature_set"),
words("declaration must have exactly one argument."), nl],
Spec = simplest_spec($pred, severity_error, phase_term_to_parse_tree,
get_term_context(ErrorTerm), Pieces),
MaybeIOM = error1([Spec])
).
:- pred parse_required_feature(varset::in, term::in,
maybe1(required_feature)::out) is det.
parse_required_feature(VarSet, Term, MaybeReqFeature) :-
( if
Term = term.functor(term.atom(Functor), [], _),
string_to_required_feature(Functor, ReqFeature)
then
MaybeReqFeature = ok1(ReqFeature)
else
TermStr = describe_error_term(VarSet, Term),
Pieces = [words("Error: expected the name of a required feature,"),
words("which must be one of"),
quote("concurrency"), suffix(","),
quote("single_prec_float"), suffix(","),
quote("double_prec_float"), suffix(","),
quote("memo"), suffix(","),
quote("parallel_conj"), suffix(","),
quote("trailing"), suffix(","),
quote("strict_sequential"), suffix(","), words("and"),
quote("conservative_gc"), suffix(","),
words("got"), quote(TermStr), suffix("."), nl],
Spec = simplest_spec($pred, severity_error, phase_term_to_parse_tree,
get_term_context(Term), Pieces),
MaybeReqFeature = error1([Spec])
).
:- pred string_to_required_feature(string::in, required_feature::out)
is semidet.
string_to_required_feature("concurrency", reqf_concurrency).
string_to_required_feature("single_prec_float", reqf_single_prec_float).
string_to_required_feature("double_prec_float", reqf_double_prec_float).
string_to_required_feature("memo", reqf_memo).
string_to_required_feature("parallel_conj", reqf_parallel_conj).
string_to_required_feature("trailing", reqf_trailing).
string_to_required_feature("strict_sequential", reqf_strict_sequential).
string_to_required_feature("conservative_gc", reqf_conservative_gc).
%---------------------------------------------------------------------------%
:- end_module parse_tree.parse_pragma.
%---------------------------------------------------------------------------%
Reference in New Issue View Git Blame Copy Permalink