mercurylang/mercury
1
0
Fork 0
mirror of https://github.com/Mercury-Language/mercury.git synced 2026-04-17 10:23:46 +00:00
Code Issues Projects Releases Wiki Activity
Files
083d376e6598628362ee91c2da170febd83590f4
mercury/compiler/parse_pragma.m
Zoltan Somogyi 307b1dc148 Split up error_util.m into five modules. 
compiler/error_spec.m:
    This new module contains the part of the old error_util.m that defines
    the error_spec type, and some functions that can help construct pieces
    of error_specs. Most modules of the compiler that deal with errors
    will need to import only this part of the old error_util.m.

    This change also renames the format_component type to format_piece,
    which matches our long-standing naming convention for variables containing
    (lists of) values of this type.

compiler/write_error_spec.m:
    This new module contains the part of the old error_util.m that
    writes out error specs, and converts them to strings.

    This diff marks as obsolete the versions of predicates that
    write out error specs to the current output stream, without
    *explicitly* specifying the intended stream.

compiler/error_sort.m:
    This new module contains the part of the old error_util.m that
    sorts lists of error specs and error msgs.

compiler/error_type_util.m:
    This new module contains the part of the old error_util.m that
    convert types to format_pieces that generate readable output.

compiler/parse_tree.m:
compiler/notes/compiler_design.html:
    Include and document the new modules.

compiler/error_util.m:
    The code remaining in the original error_util.m consists of
    general utility predicates and functions that don't fit into
    any of the modules above.

    Delete an unneeded pair of I/O states from the argument list
    of a predicate.

compiler/file_util.m:
    Move the unable_to_open_file predicate here from error_util.m,
    since it belongs here. Mark another predicate that writes
    to the current output stream as obsolete.

compiler/hlds_error_util.m:
    Mark two predicates that wrote out error_spec to the current output
    stream as obsolete, and add versions that take an explicit output stream.

compiler/Mercury.options:
    Compile the modules that call the newly obsoleted predicates
    with --no-warn-obsolete, for the time being.

compiler/*.m:
    Conform to the changes above, mostly by updating import_module
    declarations, and renaming format_component to format_piece.
2022-10-12 20:50:16 +11:00

1558 lines
62 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",
MakePragma =
(func(PredSpec) = decl_pragma_terminates(PredSpec))
;
PragmaName = "does_not_terminate",
MakePragma =
(func(PredSpec) = decl_pragma_does_not_terminate(PredSpec))
;
PragmaName = "check_termination",
MakePragma =
(func(PredSpec) = decl_pragma_check_termination(PredSpec))
),
parse_name_arity_decl_pragma(ModuleName, PragmaName, MakePragma,
VarSet, ErrorTerm, PragmaTerms, Context, SeqNum, MaybeIOM)
;
(
PragmaName = "inline",
MakePragma =
(func(PredSpec) = impl_pragma_inline(PredSpec))
;
PragmaName = "no_inline",
MakePragma =
(func(PredSpec) = impl_pragma_no_inline(PredSpec))
;
PragmaName = "consider_used",
MakePragma =
(func(PredSpec) = impl_pragma_consider_used(PredSpec))
;
PragmaName = "no_determinism_warning",
MakePragma =
(func(PredSpec) = impl_pragma_no_detism_warning(PredSpec))
;
PragmaName = "mode_check_clauses",
MakePragma =
(func(PredSpec) = impl_pragma_mode_check_clauses(PredSpec))
;
PragmaName = "promise_pure",
MakePragma =
(func(PredSpec) = impl_pragma_promise_pure(PredSpec))
;
PragmaName = "promise_semipure",
MakePragma =
(func(PredSpec) = impl_pragma_promise_semipure(PredSpec))
;
PragmaName = "promise_equivalent_clauses",
MakePragma =
(func(PredSpec) = impl_pragma_promise_eqv_clauses(PredSpec))
),
parse_name_arity_impl_pragma(ModuleName, PragmaName, MakePragma,
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,
(func(pred_pfu_name_arity) = decl_pragma)::in(func(in) = out is det),
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, MakePragma,
VarSet, ErrorTerm, PragmaTerms, Context, SeqNum, MaybeIOM) :-
(
PragmaTerms = [PragmaTerm],
parse_pred_pfu_name_arity(ModuleName, PragmaName, VarSet,
PragmaTerm, MaybePredSpec),
(
MaybePredSpec = ok1(PredSpec),
Pragma = MakePragma(PredSpec),
ItemPragma = item_pragma_info(Pragma, Context, SeqNum),
Item = item_decl_pragma(ItemPragma),
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,
(func(pred_pfu_name_arity) = impl_pragma)::in(func(in) = out is det),
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, MakePragma,
VarSet, ErrorTerm, PragmaTerms, Context, SeqNum, MaybeIOM) :-
(
PragmaTerms = [PragmaTerm],
parse_pred_pfu_name_arity(ModuleName, PragmaName, VarSet,
PragmaTerm, MaybePredSpec),
(
MaybePredSpec = ok1(PredSpec),
Pragma = MakePragma(PredSpec),
ItemPragma = item_pragma_info(Pragma, Context, SeqNum),
Item = item_impl_pragma(ItemPragma),
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)),
ExternalInfo =
pragma_info_external_proc(PFNameArity, MaybeBackend),
Pragma = impl_pragma_external_proc(ExternalInfo),
PragmaInfo = item_pragma_info(Pragma, Context, SeqNum),
Item = item_impl_pragma(PragmaInfo),
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
ObsoletePragma =
pragma_info_obsolete_pred(PredSpec, ObsoleteInFavourOf),
Pragma = decl_pragma_obsolete_pred(ObsoletePragma),
ItemPragma = item_pragma_info(Pragma, Context, SeqNum),
Item = item_decl_pragma(ItemPragma),
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),
ObsoletePragma =
pragma_info_obsolete_proc(PredNameModesPF, ObsoleteInFavourOf),
Pragma = decl_pragma_obsolete_proc(ObsoletePragma),
ItemPragma = item_pragma_info(Pragma, Context, SeqNum),
Item = item_decl_pragma(ItemPragma),
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 = pragma_info_format_call(PredSpec, FormatCall),
Pragma = decl_pragma_format_call(FormatCallPragma),
ItemPragma = item_pragma_info(Pragma, Context, SeqNum),
Item = item_decl_pragma(ItemPragma),
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
PragmaType = impl_pragma_require_tail_rec(
pragma_info_require_tail_rec(PredOrProcSpec, Options)),
PragmaInfo = item_pragma_info(PragmaType, Context, SeqNum),
MaybeIOM = ok1(iom_item(item_impl_pragma(PragmaInfo)))
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
OISUInfo = pragma_info_oisu(TypeCtor, CreatorsNamesArities,
MutatorsNamesArities, DestructorsNamesArities),
Pragma = decl_pragma_oisu(OISUInfo),
ItemPragma = item_pragma_info(Pragma, Context, SeqNum),
Item = item_decl_pragma(ItemPragma),
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),
TypeSpecInfo = pragma_info_type_spec(PFUMM, PredName,
ModuleName, TypeSubns, TVarSet, set.init),
Pragma = decl_pragma_type_spec(TypeSpecInfo),
ItemPragma = item_pragma_info(Pragma, Context, SeqNum),
Item = item_decl_pragma(ItemPragma),
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
FactTableInfo = pragma_info_fact_table(PredSpec, FileName),
Pragma = impl_pragma_fact_table(FactTableInfo),
ItemPragma = item_pragma_info(Pragma, Context, SeqNum),
Item = item_impl_pragma(ItemPragma),
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 = pragma_info_require_feature_set(FeatureSet),
Pragma = impl_pragma_require_feature_set(RFSInfo),
ItemPragma = item_pragma_info(Pragma, Context, SeqNum),
Item = item_impl_pragma(ItemPragma),
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