mercurylang/mercury
1
0
Fork 0
mirror of https://github.com/Mercury-Language/mercury.git synced 2025-12-12 12:26:29 +00:00
Code Issues Projects Releases Wiki Activity
Files
4ee7e744b715b7adf665a267de3814131839a617
mercury/compiler/parse_pragma.m
Zoltan Somogyi de658e431c Improve error messages for some pragmas. 
compiler/parse_pragma.m:
    As above. Instead of generating a "malform xyz" message, generate
    more specific error messages for each possible problem with xyz,
    for several of the xyzs parsed by this module.

    Put offending terms in quotes *consistently*.

compiler/parse_util.m:
    Add a mechanism for automatically detecting not just the fact that
    *some* features conflict, but also *which ones*, and generating
    a bespoke error message for possible conflict. This is used in
    new code in parse_pragma.m.

tests/invalid/bad_foreign_decl.err_exp:
tests/invalid/bad_foreign_export_enum.err_exp:
tests/invalid/conflicting_fs.err_exp:
    Expect the new, improved error messages.
2018-02-02 05:54:55 +11:00

3726 lines
153 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 libs.
:- import_module libs.globals.
:- 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, int::in, maybe1(item_or_marker)::out) is det.
% Parse a term that represents a foreign language.
%
:- pred term_to_foreign_language(term::in, foreign_language::out) is semidet.
%---------------------------------------------------------------------------%
%---------------------------------------------------------------------------%
:- implementation.
:- import_module libs.compiler_util.
:- import_module libs.rat.
:- import_module mdbcomp.prim_data.
:- import_module parse_tree.error_util.
:- import_module parse_tree.parse_inst_mode_name.
:- 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_ctgc.
:- import_module parse_tree.prog_data_foreign.
:- import_module parse_tree.prog_data_pragma.
:- import_module parse_tree.prog_item.
:- import_module parse_tree.prog_mode.
:- import_module parse_tree.prog_out.
:- import_module parse_tree.prog_util.
:- import_module assoc_list.
:- import_module bool.
:- import_module cord.
:- import_module int.
:- import_module maybe.
:- import_module pair.
:- import_module set.
:- import_module string.
:- import_module unit.
%---------------------------------------------------------------------------%
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 = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(Context, [always(Pieces)])]),
MaybeIOM = error1([Spec])
)
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 = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(Context, [always(Pieces)])]).
%---------------------------------------------------------------------------%
:- pred parse_pragma_type(module_name::in, varset::in, term::in,
string::in, list(term)::in, prog_context::in, int::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_pragma(VarSet, ErrorTerm,
PragmaTerms, Context, SeqNum, MaybeIOM)
;
PragmaName = "foreign_code",
parse_pragma_foreign_code_pragma(ErrorTerm,
PragmaTerms, Context, SeqNum, MaybeIOM)
;
PragmaName = "foreign_proc",
parse_pragma_foreign_proc_pragma(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(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_proc(ModuleName, VarSet, ErrorTerm,
PragmaName, PragmaTerms, Context, SeqNum, PorF, MaybeIOM)
;
(
PragmaName = "inline",
MakePragma = (pred(Name::in, Arity::in, Pragma::out) is det :-
PredNameArity = pred_name_arity(Name, Arity),
Pragma = pragma_inline(PredNameArity)
)
;
PragmaName = "no_inline",
MakePragma = (pred(Name::in, Arity::in, Pragma::out) is det :-
PredNameArity = pred_name_arity(Name, Arity),
Pragma = pragma_no_inline(PredNameArity)
)
;
PragmaName = "consider_used",
MakePragma = (pred(Name::in, Arity::in, Pragma::out) is det :-
PredNameArity = pred_name_arity(Name, Arity),
Pragma = pragma_consider_used(PredNameArity)
)
;
PragmaName = "obsolete",
MakePragma = (pred(Name::in, Arity::in, Pragma::out) is det :-
PredNameArity = pred_name_arity(Name, Arity),
Pragma = pragma_obsolete(PredNameArity)
)
;
PragmaName = "no_determinism_warning",
MakePragma = (pred(Name::in, Arity::in, Pragma::out) is det :-
PredNameArity = pred_name_arity(Name, Arity),
Pragma = pragma_no_detism_warning(PredNameArity)
)
;
PragmaName = "promise_equivalent_clauses",
MakePragma = (pred(Name::in, Arity::in, Pragma::out) is det :-
PredNameArity = pred_name_arity(Name, Arity),
Pragma = pragma_promise_eqv_clauses(PredNameArity)
)
;
PragmaName = "promise_pure",
MakePragma = (pred(Name::in, Arity::in, Pragma::out) is det :-
PredNameArity = pred_name_arity(Name, Arity),
Pragma = pragma_promise_pure(PredNameArity)
)
;
PragmaName = "promise_semipure",
MakePragma = (pred(Name::in, Arity::in, Pragma::out) is det :-
PredNameArity = pred_name_arity(Name, Arity),
Pragma = pragma_promise_semipure(PredNameArity)
)
;
PragmaName = "terminates",
MakePragma = (pred(Name::in, Arity::in, Pragma::out) is det :-
PredNameArity = pred_name_arity(Name, Arity),
Pragma = pragma_terminates(PredNameArity)
)
;
PragmaName = "does_not_terminate",
MakePragma = (pred(Name::in, Arity::in, Pragma::out) is det :-
PredNameArity = pred_name_arity(Name, Arity),
Pragma = pragma_does_not_terminate(PredNameArity)
)
;
PragmaName = "check_termination",
MakePragma = (pred(Name::in, Arity::in, Pragma::out) is det :-
PredNameArity = pred_name_arity(Name, Arity),
Pragma = pragma_check_termination(PredNameArity)
)
;
PragmaName = "mode_check_clauses",
MakePragma = (pred(Name::in, Arity::in, Pragma::out) is det :-
PredNameArity = pred_name_arity(Name, Arity),
Pragma = pragma_mode_check_clauses(PredNameArity)
)
),
parse_name_arity_pragma(ModuleName, PragmaName,
"predicate or function", MakePragma, PragmaTerms, ErrorTerm,
VarSet, Context, SeqNum, MaybeIOM)
;
PragmaName = "require_tail_recursion",
parse_pragma_require_tail_recursion(ModuleName, PragmaTerms,
ErrorTerm, VarSet, Context, SeqNum, MaybeIOM)
;
PragmaName = "oisu",
parse_oisu_pragma(ModuleName, VarSet, ErrorTerm,
PragmaTerms, Context, SeqNum, MaybeIOM)
;
(
PragmaName = "memo",
EvalMethod = eval_memo
;
PragmaName = "loop_check",
EvalMethod = eval_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.
EvalMethod = eval_minimal(stack_copy)
),
parse_tabling_pragma(ModuleName, VarSet, ErrorTerm,
PragmaName, PragmaTerms, Context, SeqNum, EvalMethod, 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, ErrorTerm,
PragmaTerms, Context, SeqNum, MaybeIOM)
;
PragmaName = "trailing_info",
parse_pragma_trailing_info(ModuleName, ErrorTerm,
PragmaTerms, Context, SeqNum, MaybeIOM)
;
PragmaName = "mm_tabling_info",
parse_pragma_mm_tabling_info(ModuleName, 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])
)
).
%---------------------------------------------------------------------------%
:- 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 = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(Context, [always(Pieces)])]),
MaybeIOM = error1([Spec])
)
else
Pieces = [words("Error: a"), pragma_decl("source_file"),
words("declaration must have exactly one argument."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(Context, [always(Pieces)])]),
MaybeIOM = error1([Spec])
).
%---------------------------------------------------------------------------%
% XXX The predicates in the rest of this module ought to be clustered together
% into groups of related predicates, grouping both parse_pragma_xxx predicates
% together with their helper predicates, and grouping parse_pragma_xxx
% predicates for related xxxs together.
:- pred parse_pragma_foreign_type(module_name::in, varset::in, term::in,
list(term)::in, prog_context::in, int::in,
maybe1(maybe_canonical)::in, maybe1(item_or_marker)::out) is det.
parse_pragma_foreign_type(ModuleName, VarSet, ErrorTerm, PragmaTerms,
Context, SeqNum, MaybeMaybeCanonical, MaybeIOM) :-
( if
(
PragmaTerms = [LangTerm, MercuryTypeTerm, ForeignTypeTerm],
MaybeAssertionTerm = no
;
PragmaTerms = [LangTerm, MercuryTypeTerm, ForeignTypeTerm,
AssertionTerm0],
MaybeAssertionTerm = yes(AssertionTerm0)
)
then
LangContextPieces = cord.from_list([
words("In first argument of"), pragma_decl("foreign_type"),
words("declaration:")
]),
parse_foreign_language(LangContextPieces, VarSet, LangTerm,
MaybeForeignLang),
TypeDefnHeadContextPieces = cord.from_list([
words("In second argument of"), pragma_decl("foreign_type"),
words("declaration:")
]),
parse_type_defn_head(TypeDefnHeadContextPieces,
ModuleName, VarSet, MercuryTypeTerm, MaybeTypeDefnHead),
ForeignTypeContextPieces = cord.from_list([
words("In third argument of"), pragma_decl("foreign_type"),
words("declaration:")
]),
parse_foreign_language_type(ForeignTypeContextPieces, ForeignTypeTerm,
VarSet, MaybeForeignLang, MaybeForeignType),
(
MaybeAssertionTerm = no,
AssertionsSet = set.init,
AssertionSpecs = []
;
MaybeAssertionTerm = yes(AssertionTerm),
AssertionContextPieces = cord.from_list([
words("In fourth argument of"), pragma_decl("foreign_type"),
words("declaration:")
]),
parse_foreign_type_assertions(AssertionContextPieces, VarSet,
AssertionTerm, set.init, AssertionsSet,
[], AssertionSpecs)
),
Assertions = foreign_type_assertions(AssertionsSet),
( if
MaybeForeignLang = ok1(_),
MaybeTypeDefnHead = ok2(MercuryTypeSymName, MercuryParams),
MaybeForeignType = ok1(ForeignType),
AssertionSpecs = [],
MaybeMaybeCanonical = ok1(MaybeCanonical)
then
varset.coerce(VarSet, TVarSet),
TypeDetailsForeign =
type_details_foreign(ForeignType, MaybeCanonical, Assertions),
ItemTypeDefn = item_type_defn_info(MercuryTypeSymName,
MercuryParams, parse_tree_foreign_type(TypeDetailsForeign),
TVarSet, Context, SeqNum),
Item = item_type_defn(ItemTypeDefn),
MaybeIOM = ok1(iom_item(Item))
else
Specs = get_any_errors1(MaybeForeignLang) ++
get_any_errors2(MaybeTypeDefnHead) ++
get_any_errors1(MaybeForeignType) ++
AssertionSpecs ++
get_any_errors1(MaybeMaybeCanonical),
MaybeIOM = error1(Specs)
)
else
Pieces = [words("Error: a"), pragma_decl("foreign_type"),
words("declaration must have three or four arguments."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
MaybeIOM = error1([Spec])
).
:- pred parse_foreign_type_assertions(cord(format_component)::in,
varset::in, term::in,
set(foreign_type_assertion)::in, set(foreign_type_assertion)::out,
list(error_spec)::in, list(error_spec)::out) is det.
parse_foreign_type_assertions(ContextPieces, VarSet, Term, !Assertions,
!Specs) :-
( if Term = term.functor(term.atom("[]"), [], _) then
true
else if Term = term.functor(term.atom("[|]"), [HeadTerm, TailTerm], _) then
( if
parse_foreign_type_assertion(HeadTerm, HeadAssertion)
then
( if
set.insert_new(HeadAssertion, !Assertions)
then
true
else
HeadTermStr = mercury_term_to_string(VarSet, print_name_only,
HeadTerm),
Pieces = cord.list(ContextPieces) ++ [
lower_case_next_if_not_first,
words("Error:"), words("foreign type assertion"),
quote(HeadTermStr), words("is repeated.")
],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(HeadTerm),
[always(Pieces)])]),
!:Specs = [Spec | !.Specs]
)
else
TermStr = mercury_term_to_string(VarSet, print_name_only, Term),
Pieces = cord.list(ContextPieces) ++ [
lower_case_next_if_not_first,
words("Error: expected a foreign type assertion,"),
words("got"), quote(TermStr), suffix(".")
],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(HeadTerm), [always(Pieces)])]),
!:Specs = [Spec | !.Specs]
),
parse_foreign_type_assertions(ContextPieces, VarSet, TailTerm,
!Assertions, !Specs)
else
TermStr = mercury_term_to_string(VarSet, print_name_only, Term),
Pieces = cord.list(ContextPieces) ++ [
lower_case_next_if_not_first,
words("Error: expected a list of foreign type assertions,"),
words("got"), quote(TermStr), suffix(".")
],
Spec = error_spec(severity_error,
phase_term_to_parse_tree,
[simple_msg(get_term_context(Term), [always(Pieces)])]),
!:Specs = [Spec | !.Specs]
).
:- pred parse_foreign_type_assertion(term::in,
foreign_type_assertion::out) is semidet.
parse_foreign_type_assertion(Term, Assertion) :-
Term = term.functor(term.atom(Constant), [], _),
(
Constant = "can_pass_as_mercury_type",
Assertion = foreign_type_can_pass_as_mercury_type
;
Constant = "stable",
Assertion = foreign_type_stable
;
Constant = "word_aligned_pointer",
Assertion = foreign_type_word_aligned_pointer
).
%---------------------------------------------------------------------------%
%
% Code for parsing foreign_export_enum pragmas.
%
:- pred parse_pragma_foreign_export_enum(varset::in, term::in, list(term)::in,
prog_context::in, int::in, maybe1(item_or_marker)::out) is det.
parse_pragma_foreign_export_enum(VarSet, ErrorTerm, PragmaTerms,
Context, SeqNum, MaybeIOM) :-
( if
(
PragmaTerms = [LangTerm, MercuryTypeTerm],
MaybeAttributesTerm = no,
MaybeOverridesTerm = no
;
PragmaTerms = [LangTerm, MercuryTypeTerm, AttributesTerm],
MaybeAttributesTerm = yes(AttributesTerm),
MaybeOverridesTerm = no
;
PragmaTerms = [LangTerm, MercuryTypeTerm, AttributesTerm,
OverridesTerm],
MaybeAttributesTerm = yes(AttributesTerm),
MaybeOverridesTerm = yes(OverridesTerm)
)
then
LangContextPieces = cord.from_list([
words("In first argument of"),
pragma_decl("foreign_export_enum"), words("declaration:")
]),
parse_foreign_language(LangContextPieces, VarSet, LangTerm,
MaybeForeignLang),
TypeContextPieces = cord.from_list([
words("In second argument of"),
pragma_decl("foreign_export_enum"), words("declaration:")
]),
parse_type_ctor_name_arity(TypeContextPieces, VarSet, MercuryTypeTerm,
MaybeTypeCtor),
maybe_parse_export_enum_attributes(VarSet, MaybeAttributesTerm,
MaybeAttributes),
maybe_parse_export_enum_overrides(VarSet, MaybeOverridesTerm,
MaybeOverrides),
( if
MaybeForeignLang = ok1(ForeignLang),
MaybeTypeCtor = ok1(TypeCtor),
MaybeAttributes = ok1(Attributes),
MaybeOverrides = ok1(Overrides)
then
FEEInfo = pragma_info_foreign_export_enum(ForeignLang, TypeCtor,
Attributes, Overrides),
Pragma = pragma_foreign_export_enum(FEEInfo),
ItemPragma = item_pragma_info(Pragma, item_origin_user, Context,
SeqNum),
Item = item_pragma(ItemPragma),
MaybeIOM = ok1(iom_item(Item))
else
Specs = get_any_errors1(MaybeForeignLang) ++
get_any_errors1(MaybeTypeCtor) ++
get_any_errors1(MaybeAttributes) ++
get_any_errors1(MaybeOverrides),
MaybeIOM = error1(Specs)
)
else
Pieces = [words("Error: a"), pragma_decl("foreign_export_enum"),
words("declaration must have two, three or four arguments."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
MaybeIOM = error1([Spec])
).
:- pred maybe_parse_export_enum_overrides(varset::in, maybe(term)::in,
maybe1(assoc_list(sym_name, string))::out) is det.
maybe_parse_export_enum_overrides(_, no, ok1([])).
maybe_parse_export_enum_overrides(VarSet, yes(OverridesTerm),
MaybeOverrides) :-
UnrecognizedPieces =
[words("Error: expected a valid mapping element."), nl],
PairContextPieces =
cord.singleton(words("In exported enumeration override constructor:")),
convert_maybe_list("mapping elements", yes(VarSet), OverridesTerm,
parse_sym_name_string_pair(VarSet, PairContextPieces),
UnrecognizedPieces, MaybeOverrides).
:- pred parse_sym_name_string_pair(varset::in, cord(format_component)::in,
term::in, maybe1(pair(sym_name, string))::out) is semidet.
parse_sym_name_string_pair(VarSet, ContextPieces, PairTerm, MaybePair) :-
PairTerm = functor(Functor, Args, _),
Functor = term.atom("-"),
Args = [SymNameTerm, StringTerm],
StringTerm = functor(term.string(String), _, _),
parse_sym_name_and_args(VarSet, ContextPieces, SymNameTerm,
MaybeSymNameResult),
(
MaybeSymNameResult = ok2(SymName, []),
MaybePair = ok1(SymName - String)
;
MaybeSymNameResult = error2(Specs),
MaybePair = error1(Specs)
).
:- pred maybe_parse_export_enum_attributes(varset::in, maybe(term)::in,
maybe1(export_enum_attributes)::out) is det.
maybe_parse_export_enum_attributes(_, no, ok1(default_export_enum_attributes)).
maybe_parse_export_enum_attributes(VarSet, yes(AttributesTerm),
MaybeAttributes) :-
parse_export_enum_attributes(VarSet, AttributesTerm, MaybeAttributes).
:- type collected_export_enum_attribute
---> ee_attr_prefix(maybe(string))
; ee_attr_upper(uppercase_export_enum).
:- pred parse_export_enum_attributes(varset::in, term::in,
maybe1(export_enum_attributes)::out) is det.
parse_export_enum_attributes(VarSet, AttributesTerm, AttributesResult) :-
Attributes0 = default_export_enum_attributes,
( if list_term_to_term_list(AttributesTerm, AttributesTerms) then
map_parser(parse_export_enum_attr(VarSet), AttributesTerms,
MaybeAttrList),
(
MaybeAttrList = ok1(CollectedAttributes),
% Check that the prefix attribute is specified at most once.
IsPrefixAttr =
( pred(A::in) is semidet :-
A = ee_attr_prefix(_)
),
list.filter(IsPrefixAttr, CollectedAttributes, PrefixAttributes),
(
( PrefixAttributes = []
; PrefixAttributes = [_]
),
list.foldl(process_export_enum_attribute,
CollectedAttributes, Attributes0, Attributes),
AttributesResult = ok1(Attributes)
;
PrefixAttributes = [_, _ | _],
% XXX Print the multiply-occurring attribute.
Pieces = [words("Error: prefix attribute"),
words("occurs multiple times in"),
pragma_decl("foreign_export_enum"),
words("declaration."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(AttributesTerm),
[always(Pieces)])]),
AttributesResult = error1([Spec])
)
;
MaybeAttrList = error1(AttrSpecs),
AttributesResult = error1(AttrSpecs)
)
else
AttributesStr = describe_error_term(VarSet, AttributesTerm),
Pieces = [words("Error: expected a list of attributes"),
words("in the third argument of a"),
pragma_decl("foreign_export_enum"), words("declaration,"),
words("got"), quote(AttributesStr), suffix("."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(AttributesTerm), [always(Pieces)])]),
AttributesResult = error1([Spec])
).
:- pred process_export_enum_attribute(collected_export_enum_attribute::in,
export_enum_attributes::in, export_enum_attributes::out) is det.
process_export_enum_attribute(ee_attr_prefix(MaybePrefix), !Attributes) :-
% We have already checked that the prefix attribute is not specified
% multiple times in parse_export_enum_attributes so it is safe to
% ignore it in the input here.
!.Attributes = export_enum_attributes(_, MakeUpperCase),
!:Attributes = export_enum_attributes(MaybePrefix, MakeUpperCase).
process_export_enum_attribute(ee_attr_upper(MakeUpperCase), !Attributes) :-
!.Attributes = export_enum_attributes(MaybePrefix, _),
!:Attributes = export_enum_attributes(MaybePrefix, MakeUpperCase).
:- pred parse_export_enum_attr(varset::in, term::in,
maybe1(collected_export_enum_attribute)::out) is det.
parse_export_enum_attr(VarSet, Term, MaybeAttribute) :-
( if
Term = functor(atom("prefix"), Args, _),
Args = [ForeignNameTerm],
ForeignNameTerm = functor(string(Prefix), [], _)
then
MaybeAttribute = ok1(ee_attr_prefix(yes(Prefix)))
else if
Term = functor(atom("uppercase"), [], _)
then
MaybeAttribute = ok1(ee_attr_upper(uppercase_export_enum))
else
TermStr = describe_error_term(VarSet, Term),
Pieces = [words("Error: unrecognised attribute in"),
pragma_decl("foreign_export_enum"), words("declaration:"),
quote(TermStr), suffix("."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(Term), [always(Pieces)])]),
MaybeAttribute = error1([Spec])
).
%---------------------------------------------------------------------------%
%
% Code for parsing foreign_enum pragmas.
%
:- pred parse_pragma_foreign_enum(varset::in, term::in, list(term)::in,
prog_context::in, int::in, maybe1(item_or_marker)::out) is det.
parse_pragma_foreign_enum(VarSet, ErrorTerm, PragmaTerms, Context, SeqNum,
MaybeIOM) :-
( if PragmaTerms = [LangTerm, MercuryTypeTerm, ValuesTerm] then
LangContextPieces = cord.from_list([
words("In first argument of"), pragma_decl("foreign_enum"),
words("declaration:")
]),
parse_foreign_language(LangContextPieces, VarSet, LangTerm,
MaybeForeignLang),
TypeContextPieces = cord.from_list([
words("In second argument of"), pragma_decl("foreign_enum"),
words("declaration:")
]),
parse_type_ctor_name_arity(TypeContextPieces, VarSet, MercuryTypeTerm,
MaybeTypeCtor),
UnrecognizedPieces =
[words("Error: expected a valid mapping element")],
PairContextPieces = cord.from_list([
words("In"), pragma_decl("foreign_enum"),
words("mapping constructor name:")
]),
% XXX the following doesn't check that foreign values are sensible
% (e.g. it should reject the empty string).
convert_maybe_list("mapping elements", yes(VarSet), ValuesTerm,
parse_sym_name_string_pair(VarSet, PairContextPieces),
UnrecognizedPieces, MaybeValues0),
(
MaybeValues0 = ok1(Values0),
(
Values0 = [],
NoValuesPieces = [
words("Error: expected a non-empty list"),
words("mapping constructors to foreign values in"),
pragma_decl("foreign_enum"), words("declaration."), nl
],
NoValuesSpec = error_spec(severity_error,
phase_term_to_parse_tree,
[simple_msg(get_term_context(ValuesTerm),
[always(NoValuesPieces)])]),
MaybeValues = error1([NoValuesSpec])
;
Values0 = [_ | _],
MaybeValues = MaybeValues0
)
;
MaybeValues0 = error1(_),
MaybeValues = MaybeValues0
),
( if
MaybeForeignLang = ok1(ForeignLang),
MaybeTypeCtor = ok1(TypeCtor),
MaybeValues = ok1(Values)
then
FEInfo = pragma_info_foreign_enum(ForeignLang, TypeCtor, Values),
Pragma = pragma_foreign_enum(FEInfo),
ItemPragma = item_pragma_info(Pragma, item_origin_user, Context,
SeqNum),
Item = item_pragma(ItemPragma),
MaybeIOM = ok1(iom_item(Item))
else
Specs = get_any_errors1(MaybeForeignLang) ++
get_any_errors1(MaybeTypeCtor) ++
get_any_errors1(MaybeValues),
MaybeIOM = error1(Specs)
)
else
Pieces = [words("Error: wrong number of arguments in"),
pragma_decl("foreign_enum"), words("declaration."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
MaybeIOM = error1([Spec])
).
%---------------------------------------------------------------------------%
%
% Common code for parsing foreign language interface pragmas.
%
:- pred parse_foreign_language(cord(format_component)::in, varset::in,
term::in, maybe1(foreign_language)::out) is det.
parse_foreign_language(ContextPieces, VarSet, LangTerm, MaybeForeignLang) :-
( if term_to_foreign_language(LangTerm, ForeignLang) then
MaybeForeignLang = ok1(ForeignLang)
else
LangPieces = cord.list(ContextPieces) ++ [
lower_case_next_if_not_first,
words("Error: invalid foreign language"),
quote(describe_error_term(VarSet, LangTerm)), suffix(".")
],
LangSpec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(LangTerm), [always(LangPieces)])]),
MaybeForeignLang = error1([LangSpec])
).
:- pred parse_type_ctor_name_arity(cord(format_component)::in, varset::in,
term::in, maybe1(type_ctor)::out) is det.
parse_type_ctor_name_arity(ContextPieces, VarSet, TypeTerm, MaybeTypeCtor) :-
( if parse_name_and_arity_unqualified(TypeTerm, Name, Arity) then
MaybeTypeCtor = ok1(type_ctor(Name, Arity))
else
TypeTermStr = describe_error_term(VarSet, TypeTerm),
Pieces = cord.list(ContextPieces) ++ [
lower_case_next_if_not_first,
words("Error: expected name/arity for type,"),
words("got"), quote(TypeTermStr), suffix(".")
],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(TypeTerm), [always(Pieces)])]),
MaybeTypeCtor = error1([Spec])
).
%---------------------------------------------------------------------------%
%
% Code for parsing foreign_export pragmas.
%
:- pred parse_pragma_foreign_export(varset::in, term::in, list(term)::in,
prog_context::in, int::in, maybe1(item_or_marker)::out) is det.
parse_pragma_foreign_export(VarSet, ErrorTerm, PragmaTerms, Context, SeqNum,
MaybeIOM) :-
( if PragmaTerms = [LangTerm, PredAndModesTerm, FunctionTerm] then
LangContextPieces = cord.from_list([
words("In first argument of"), pragma_decl("foreign_export"),
words("declaration:")
]),
parse_foreign_language(LangContextPieces, VarSet, LangTerm,
MaybeForeignLang),
PredAndModesContextPieces = cord.from_list([
words("In second argument of"), pragma_decl("foreign_export"),
words("declaration:")
]),
parse_pred_or_func_and_arg_modes(no, VarSet, PredAndModesContextPieces,
PredAndModesTerm, MaybePredAndModes),
ForeignFunctionContextPieces = cord.from_list([
words("In third argument of"), pragma_decl("foreign_export"),
words("declaration:")
]),
parse_foreign_function_name(VarSet, ForeignFunctionContextPieces,
FunctionTerm, MaybeFunction),
( if
MaybeForeignLang = ok1(ForeignLang),
MaybePredAndModes = ok3(PredName, PredOrFunc, Modes),
MaybeFunction = ok1(Function)
then
PredNameModesPF = pred_name_modes_pf(PredName, Modes, PredOrFunc),
FPEInfo = pragma_info_foreign_proc_export(ForeignLang,
PredNameModesPF, Function),
Pragma = pragma_foreign_proc_export(FPEInfo),
ItemPragma = item_pragma_info(Pragma, item_origin_user, Context,
SeqNum),
Item = item_pragma(ItemPragma),
MaybeIOM = ok1(iom_item(Item))
else
Specs = get_any_errors1(MaybeForeignLang) ++
get_any_errors3(MaybePredAndModes) ++
get_any_errors1(MaybeFunction),
MaybeIOM = error1(Specs)
)
else
Pieces = [words("Error: wrong number of arguments in"),
pragma_decl("foreign_export"), words("declaration."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
MaybeIOM = error1([Spec])
).
:- pred parse_foreign_function_name(varset::in, cord(format_component)::in,
term::in, maybe1(string)::out) is det.
parse_foreign_function_name(VarSet, ContextPieces, FunctionTerm,
MaybeFunction) :-
( if FunctionTerm = term.functor(term.string(Function), [], _) then
( if Function = "" then
EmptyNamePieces = cord.list(ContextPieces) ++ [
lower_case_next_if_not_first,
words("Error: expected a non-empty string for the"),
words("foreign language name of the exported procedure,"),
words("got empty string.")
],
FunctionSpec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(FunctionTerm),
[always(EmptyNamePieces)])]),
MaybeFunction = error1([FunctionSpec])
else
% XXX TODO: if we have a valid foreign language, check that
% Function is a valid identifier in that language.
MaybeFunction = ok1(Function)
)
else
FunctionPieces = cord.list(ContextPieces) ++ [
lower_case_next_if_not_first,
words("Error: expected a non-empty string for the foreign"),
words("language name of the exported procedure, got"),
quote(describe_error_term(VarSet, FunctionTerm)),
suffix("."), nl
],
FunctionSpec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(FunctionTerm),
[always(FunctionPieces)])]),
MaybeFunction = error1([FunctionSpec])
).
%---------------------------------------------------------------------------%
:- pred parse_pragma_foreign_import_module(varset::in, term::in,
list(term)::in, prog_context::in, int::in, maybe1(item_or_marker)::out)
is det.
parse_pragma_foreign_import_module(VarSet, ErrorTerm, PragmaTerms, Context,
SeqNum, MaybeIOM) :-
( if
PragmaTerms = [LangTerm, ImportTerm]
then
LangContextPieces = cord.from_list([
words("In first argument of"),
pragma_decl("foreign_import_module"), words("declaration:")
]),
parse_foreign_language(LangContextPieces, VarSet, LangTerm,
MaybeForeignLang),
( if try_parse_sym_name_and_no_args(ImportTerm, Import0) then
MaybeImportModule = ok1(Import0)
else
ImportModulePieces = [
words("Error: invalid module name"),
quote(describe_error_term(VarSet, ImportTerm)),
words("in"), pragma_decl("foreign_import_module"),
words("declaration."), nl],
ImportModuleSpec = error_spec(severity_error,
phase_term_to_parse_tree,
[simple_msg(get_term_context(ImportTerm),
[always(ImportModulePieces)])]),
MaybeImportModule = error1([ImportModuleSpec])
),
( if
MaybeForeignLang = ok1(Language),
MaybeImportModule = ok1(Import)
then
FIM = foreign_import_module_info(Language, Import),
FIMInfo = pragma_info_foreign_import_module(FIM),
Pragma = pragma_foreign_import_module(FIMInfo),
ItemPragma = item_pragma_info(Pragma, item_origin_user, Context,
SeqNum),
Item = item_pragma(ItemPragma),
MaybeIOM = ok1(iom_item(Item))
else
Specs = get_any_errors1(MaybeForeignLang) ++
get_any_errors1(MaybeImportModule),
MaybeIOM = error1(Specs)
)
else
Pieces = [words("Error: a"), pragma_decl("foreign_import_module"),
words("declaration must have two arguments."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
MaybeIOM = error1([Spec])
).
%---------------------------------------------------------------------------%
:- pred parse_pragma_external_proc(module_name::in, varset::in, term::in,
string::in, list(term)::in, prog_context::in, int::in,
pred_or_func::in, maybe1(item_or_marker)::out) is det.
parse_pragma_external_proc(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
ExternalInfo = pragma_info_external_proc(FullSymName, Arity,
PorF, MaybeBackend),
Pragma = pragma_external_proc(ExternalInfo),
PragmaInfo = item_pragma_info(Pragma, item_origin_user,
Context, SeqNum),
Item = item_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 = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(ErrorTerm),
[always(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 = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
MaybeIOM = error1([Spec])
).
:- pred parse_symname_arity(varset::in, term::in, cord(format_component)::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 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 = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(ArityTerm),
[always(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 = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(PredTerm), [always(Pieces)])]),
MaybeSymNameArity = error2([Spec])
).
:- pred parse_pragma_external_options(varset::in, maybe(term)::in,
cord(format_component)::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 a singleton list containing either"),
quote("low_level_backend"), words("or"),
quote("high_level_backend"), suffix(","),
words("got"), words(OptionsTermStr), suffix("."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(OptionsTerm), [always(Pieces)])]),
MaybeMaybeBackend = error1([Spec])
)
).
%---------------------------------------------------------------------------%
:- pred parse_pragma_require_tail_recursion(module_name::in, list(term)::in,
term::in, varset::in, prog_context::in, int::in,
maybe1(item_or_marker)::out) is det.
parse_pragma_require_tail_recursion(ModuleName, PragmaTerms, _ErrorTerm,
VarSet, Context, SeqNum, MaybeIOM) :-
PragmaName = "require_tail_recursion",
( if
(
PragmaTerms = [PredAndModesTerm, OptionsTermPrime],
MaybeOptionsTerm = yes(OptionsTermPrime)
;
PragmaTerms = [PredAndModesTerm],
MaybeOptionsTerm = no
)
then
% Parse the procedure name.
ContextPieces = cord.from_list([words("In"),
pragma_decl(PragmaName), words("declaration:")]),
parse_arity_or_modes(ModuleName, PredAndModesTerm,
PredAndModesTerm, VarSet, ContextPieces, MaybeProc),
% 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),
Pieces1 = [words("Error: expected attribute list for"),
pragma_decl("require_tail_recursion"),
words("declaration, got"),
quote(describe_error_term(VarSet, OptionsTerm)),
suffix("."), nl],
Message1 = simple_msg(OptionsContext, [always(Pieces1)]),
MaybeOptions = error1([error_spec(severity_error,
phase_term_to_parse_tree, [Message1])])
)
;
MaybeOptionsTerm = no,
MaybeOptions = ok1(enable_tailrec_warnings(we_warning,
both_self_and_mutual_recursion_must_be_tail, Context))
),
% Put them together.
(
MaybeProc = ok1(Proc),
(
MaybeOptions = ok1(RequireTailrecInfo),
PragmaType = pragma_require_tail_recursion(
pragma_info_require_tail_recursion(Proc,
RequireTailrecInfo)),
MaybeIOM = ok1(iom_item(item_pragma(
item_pragma_info(PragmaType, item_origin_user, Context,
SeqNum))))
;
MaybeOptions = error1(Errors),
MaybeIOM = error1(Errors)
)
;
MaybeProc = error1(ProcErrors),
(
MaybeOptions = ok1(_),
MaybeIOM = error1(ProcErrors)
;
MaybeOptions = error1(OptionsErrors),
MaybeIOM = error1(ProcErrors ++ OptionsErrors)
)
)
else
Pieces = [words("Error: a"), pragma_decl(PragmaName),
words("declaration must have one or two arguments."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(Context, [always(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
),
MaybeRTR = ok1(enable_tailrec_warnings(WarnOrError, Type,
Context))
)
).
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) = ErrorSpec :-
Pieces = [words("Error: Conflicting "),
pragma_decl("require_tail_recursion"), words("attributes: "),
quote(ThisName), words("conflicts with earlier attribute"),
quote(EarlierName), suffix("."), nl],
Message = simple_msg(Context, [always(Pieces)]),
ErrorSpec = error_spec(severity_error,
phase_term_to_parse_tree, [Message]).
:- func pragma_require_tailrec_unknown_term_error(term, prog_context) =
error_spec.
pragma_require_tailrec_unknown_term_error(Term, Context) = ErrorSpec :-
varset.init(VarSet),
Pieces = [words("Error: unrecognised "),
pragma_decl("require_tail_recursion"), words("attribute: "),
quote(describe_error_term(VarSet, Term)), suffix("."), nl],
Message = simple_msg(Context, [always(Pieces)]),
ErrorSpec = error_spec(severity_error,
phase_term_to_parse_tree, [Message]).
%---------------------------------------------------------------------------%
:- pred parse_pragma_unused_args(module_name::in, varset::in, term::in,
list(term)::in, prog_context::in, int::in,
maybe1(item_or_marker)::out) is det.
parse_pragma_unused_args(ModuleName, VarSet, ErrorTerm, PragmaTerms,
Context, SeqNum, MaybeIOM) :-
% pragma unused_args should never appear in user programs,
% only in .opt files.
( if
PragmaTerms = [PredOrFuncTerm, PredNameTerm, ArityTerm, ModeNumTerm,
UnusedArgsTerm],
decimal_term_to_int(ArityTerm, Arity),
decimal_term_to_int(ModeNumTerm, ModeNum),
parse_predicate_or_function(PredOrFuncTerm, PredOrFunc),
try_parse_implicitly_qualified_sym_name_and_no_args(ModuleName,
PredNameTerm, PredName),
convert_int_list(VarSet, UnusedArgsTerm, MaybeUnusedArgs),
MaybeUnusedArgs = ok1(UnusedArgs)
then
PredNameArityPFMn = pred_name_arity_pf_mn(PredName, Arity, PredOrFunc,
ModeNum),
UnusedArgsInfo = pragma_info_unused_args(PredNameArityPFMn,
UnusedArgs),
Pragma = pragma_unused_args(UnusedArgsInfo),
ItemPragma = item_pragma_info(Pragma, item_origin_user,
Context, SeqNum),
Item = item_pragma(ItemPragma),
MaybeIOM = ok1(iom_item(Item))
else
% XXX Improve this message.
Pieces = [words("Error in"), pragma_decl("unused_args"),
suffix("."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
MaybeIOM = error1([Spec])
).
%---------------------------------------------------------------------------%
:- pred parse_pragma_type_spec(module_name::in, varset::in, term::in,
list(term)::in, prog_context::in, int::in,
maybe1(item_or_marker)::out) is det.
parse_pragma_type_spec(ModuleName, VarSet, ErrorTerm, PragmaTerms,
Context, SeqNum, MaybeIOM) :-
( if
(
PragmaTerms = [PredAndModesTerm, TypeSubnTerm],
MaybeName = no
;
PragmaTerms = [PredAndModesTerm, TypeSubnTerm, SpecNameTerm],
SpecNameTerm = term.functor(_, _, SpecContext),
% This form of the pragma should not appear in source files.
term.context_file(SpecContext, FileName),
not string.remove_suffix(FileName, ".m", _),
try_parse_implicitly_qualified_sym_name_and_no_args(ModuleName,
SpecNameTerm, SpecName),
MaybeName = yes(SpecName)
)
then
ArityOrModesContextPieces = cord.from_list([words("In"),
pragma_decl("type_spec"), words("declaration:")]),
parse_arity_or_modes(ModuleName, PredAndModesTerm, ErrorTerm,
VarSet, ArityOrModesContextPieces, MaybeArityOrModes),
(
MaybeArityOrModes = ok1(ArityOrModes),
ArityOrModes = pred_name_arity_mpf_mmode(PredName, Arity,
MaybePredOrFunc, MaybeModes),
conjunction_to_list(TypeSubnTerm, TypeSubnTerms),
% The varset is actually a tvarset.
varset.coerce(VarSet, TVarSet),
( if
list.map(convert_type_spec_pair, TypeSubnTerms, TypeSubns)
then
(
MaybeName = yes(SpecializedName0),
SpecializedName = SpecializedName0
;
MaybeName = no,
UnqualName = unqualify_name(PredName),
make_pred_name(ModuleName, "TypeSpecOf", MaybePredOrFunc,
UnqualName, newpred_type_subst(TVarSet, TypeSubns),
SpecializedName)
),
TypeSpecInfo = pragma_info_type_spec(PredName, SpecializedName,
Arity, MaybePredOrFunc, MaybeModes, TypeSubns, TVarSet,
set.init),
Pragma = pragma_type_spec(TypeSpecInfo),
ItemPragma = item_pragma_info(Pragma, item_origin_user,
Context, SeqNum),
Item = item_pragma(ItemPragma),
MaybeIOM = ok1(iom_item(Item))
else
Pieces = [words("Error: expected type substitution in"),
pragma_decl("type_spec"), words("declaration."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(TypeSubnTerm),
[always(Pieces)])]),
MaybeIOM = error1([Spec])
)
;
MaybeArityOrModes = error1(Specs),
MaybeIOM = error1(Specs)
)
else
Pieces = [words("Error: a"), pragma_decl("type_spec"),
words("declaration must have two or three arguments."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
MaybeIOM = error1([Spec])
).
%---------------------------------------------------------------------------%
:- pred parse_pragma_fact_table(module_name::in, varset::in, term::in,
list(term)::in, prog_context::in, int::in,
maybe1(item_or_marker)::out) is det.
parse_pragma_fact_table(ModuleName, VarSet, ErrorTerm, PragmaTerms,
Context, SeqNum, MaybeIOM) :-
( if PragmaTerms = [PredAndArityTerm, FileNameTerm] then
parse_pred_name_and_arity(ModuleName, "fact_table",
PredAndArityTerm, ErrorTerm, VarSet, MaybeNameAndArity),
(
MaybeNameAndArity = ok2(PredName, Arity),
( if FileNameTerm = term.functor(term.string(FileName), [], _) then
PredNameArity = pred_name_arity(PredName, Arity),
FactTableInfo = pragma_info_fact_table(PredNameArity,
FileName),
Pragma = pragma_fact_table(FactTableInfo),
ItemPragma = item_pragma_info(Pragma, item_origin_user,
Context, SeqNum),
Item = item_pragma(ItemPragma),
MaybeIOM = ok1(iom_item(Item))
else
Pieces = [words("Error: expected string"),
words("for fact table filename."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(FileNameTerm),
[always(Pieces)])]),
MaybeIOM = error1([Spec])
)
;
MaybeNameAndArity = error2(Specs),
MaybeIOM = error1(Specs)
)
else
Pieces = [words("Error: a"), pragma_decl("fact_table"),
words("declaration must have two arguments."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
MaybeIOM = error1([Spec])
).
%---------------------------------------------------------------------------%
:- pred parse_pragma_termination_info(module_name::in, varset::in, term::in,
list(term)::in, prog_context::in, int::in,
maybe1(item_or_marker)::out) is det.
parse_pragma_termination_info(ModuleName, VarSet, ErrorTerm, PragmaTerms,
Context, SeqNum, MaybeIOM) :-
( if
PragmaTerms = [PredAndModesTerm0, ArgSizeTerm, TerminationTerm],
ContextPieces = cord.from_list([words("In"),
pragma_decl("termination_info"), words("declaration:")]),
parse_pred_or_func_and_arg_modes(yes(ModuleName), VarSet,
ContextPieces, PredAndModesTerm0, MaybeNameAndModes),
MaybeNameAndModes = ok3(PredName, PredOrFunc, ModeList),
ArgSizeTerm = term.functor(term.atom(ArgSizeFunctor),
ArgSizeArgTerms, _),
(
ArgSizeFunctor = "not_set",
ArgSizeArgTerms = [],
MaybeArgSizeInfo = no
;
ArgSizeFunctor = "infinite",
ArgSizeArgTerms = [],
MaybeArgSizeInfo = yes(infinite(unit))
;
ArgSizeFunctor = "finite",
ArgSizeArgTerms = [IntTerm, UsedArgsTerm],
decimal_term_to_int(IntTerm, Int),
convert_bool_list(VarSet, UsedArgsTerm, UsedArgs),
MaybeArgSizeInfo = yes(finite(Int, UsedArgs))
),
TerminationTerm = term.functor(term.atom(TerminationFunctor), [], _),
(
TerminationFunctor = "not_set",
MaybeTerminationInfo = no
;
TerminationFunctor = "can_loop",
MaybeTerminationInfo = yes(can_loop(unit))
;
TerminationFunctor = "cannot_loop",
MaybeTerminationInfo = yes(cannot_loop(unit))
)
then
PredNameModesPF = pred_name_modes_pf(PredName, ModeList, PredOrFunc),
TermInfo = pragma_info_termination_info(PredNameModesPF,
MaybeArgSizeInfo, MaybeTerminationInfo),
Pragma = pragma_termination_info(TermInfo),
ItemPragma = item_pragma_info(Pragma, item_origin_user,
Context, SeqNum),
Item = item_pragma(ItemPragma),
MaybeIOM = ok1(iom_item(Item))
else
Pieces = [words("Syntax error in"),
pragma_decl("termination_info"), words("declaration."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
MaybeIOM = error1([Spec])
).
%---------------------------------------------------------------------------%
:- pred parse_pragma_termination2_info(module_name::in, varset::in, term::in,
list(term)::in, prog_context::in, int::in,
maybe1(item_or_marker)::out) is det.
parse_pragma_termination2_info(ModuleName, VarSet, ErrorTerm, PragmaTerms,
Context, SeqNum, MaybeIOM) :-
( if
PragmaTerms = [PredAndModesTerm0, SuccessArgSizeTerm,
FailureArgSizeTerm, TerminationTerm],
ContextPieces = cord.from_list([words("In"),
pragma_decl("termination2_info"), words("declaration:")]),
parse_pred_or_func_and_arg_modes(yes(ModuleName), VarSet,
ContextPieces, PredAndModesTerm0, NameAndModesResult),
NameAndModesResult = ok3(PredName, PredOrFunc, ModeList),
parse_arg_size_constraints(SuccessArgSizeTerm, SuccessArgSizeResult),
SuccessArgSizeResult = ok1(SuccessArgSizeInfo),
parse_arg_size_constraints(FailureArgSizeTerm, FailureArgSizeResult),
FailureArgSizeResult = ok1(FailureArgSizeInfo),
TerminationTerm = term.functor(term.atom(TerminationFunctor), [], _),
(
TerminationFunctor = "not_set",
MaybeTerminationInfo = no
;
TerminationFunctor = "can_loop",
MaybeTerminationInfo = yes(can_loop(unit))
;
TerminationFunctor = "cannot_loop",
MaybeTerminationInfo = yes(cannot_loop(unit))
)
then
PredNameModesPF = pred_name_modes_pf(PredName, ModeList, PredOrFunc),
Term2Info = pragma_info_termination2_info(PredNameModesPF,
SuccessArgSizeInfo, FailureArgSizeInfo, MaybeTerminationInfo),
Pragma = pragma_termination2_info(Term2Info),
ItemPragma = item_pragma_info(Pragma, item_origin_user,
Context, SeqNum),
Item = item_pragma(ItemPragma),
MaybeIOM = ok1(iom_item(Item))
else
Pieces = [words("Syntax error in"),
pragma_decl("termination2_info"), words("declaration."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
MaybeIOM = error1([Spec])
).
%---------------------------------------------------------------------------%
:- pred parse_pragma_structure_sharing(module_name::in, varset::in, term::in,
list(term)::in, prog_context::in, int::in,
maybe1(item_or_marker)::out) is det.
parse_pragma_structure_sharing(ModuleName, VarSet, ErrorTerm, PragmaTerms,
Context, SeqNum, MaybeIOM) :-
( if
PragmaTerms = [PredAndModesTerm0, HeadVarsTerm,
HeadVarTypesTerm, SharingInformationTerm],
ModesContextPieces = cord.from_list([words("In"),
pragma_decl("structure_sharing"), words("declaration:")]),
parse_pred_or_func_and_arg_modes(yes(ModuleName), VarSet,
ModesContextPieces, PredAndModesTerm0, MaybeNameAndModes),
MaybeNameAndModes = ok3(PredName, PredOrFunc, ModeList),
% Parse the head variables:
HeadVarsTerm = term.functor(term.atom("vars"), ListHVTerm, _),
term.vars_list(ListHVTerm, HeadVarsGeneric),
list.map(term.coerce_var, HeadVarsGeneric, HeadVars),
% Parse the types:
HeadVarTypesTerm = term.functor(term.atom("types"), ListTypeTerms, _),
maybe_parse_types(no_allow_ho_inst_info(wnhii_pragma_struct_sharing),
ListTypeTerms, Types),
% Parse the actual structure sharing information.
SharingInformationTerm = term.functor(term.atom(SharingFunctor),
SharingArgTerms, _),
(
SharingFunctor = "not_available",
% XXX Why don't we test SharingArgTerms?
MaybeSharingAs = no
;
SharingFunctor = "yes",
SharingArgTerms = [SharingAsTerm],
MaybeSharingAs = yes(parse_structure_sharing_domain(SharingAsTerm))
)
then
PredNameModesPF = pred_name_modes_pf(PredName, ModeList, PredOrFunc),
SharingInfo = pragma_info_structure_sharing(PredNameModesPF,
HeadVars, Types, MaybeSharingAs),
Pragma = pragma_structure_sharing(SharingInfo),
ItemPragma = item_pragma_info(Pragma, item_origin_user,
Context, SeqNum),
Item = item_pragma(ItemPragma),
MaybeIOM = ok1(iom_item(Item))
else
Pieces = [words("Syntax error in"),
pragma_decl("structure_sharing"), words("declaration."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
MaybeIOM = error1([Spec])
).
%---------------------------------------------------------------------------%
:- pred parse_pragma_structure_reuse(module_name::in, varset::in, term::in,
list(term)::in, prog_context::in, int::in,
maybe1(item_or_marker)::out) is det.
parse_pragma_structure_reuse(ModuleName, VarSet, ErrorTerm, PragmaTerms,
Context, SeqNum, MaybeIOM) :-
( if
PragmaTerms = [PredAndModesTerm0, HeadVarsTerm,
HeadVarTypesTerm, MaybeStructureReuseTerm],
ReuseContextPieces = cord.from_list([words("In"),
pragma_decl("structure_reuse"), words("declaration:")]),
parse_pred_or_func_and_arg_modes(yes(ModuleName), VarSet,
ReuseContextPieces, PredAndModesTerm0, MaybeNameAndModes),
MaybeNameAndModes = ok3(PredName, PredOrFunc, ModeList),
% Parse the head variables:
HeadVarsTerm = term.functor(term.atom("vars"), ListHVTerm, _),
term.vars_list(ListHVTerm, HeadVarsGeneric),
list.map(term.coerce_var, HeadVarsGeneric, HeadVars),
% Parse the types:
HeadVarTypesTerm = term.functor(term.atom("types"), ListTypeTerms, _),
maybe_parse_types(no_allow_ho_inst_info(wnhii_pragma_struct_reuse),
ListTypeTerms, Types),
% Parse the actual structure reuse information.
MaybeStructureReuseTerm = term.functor(term.atom(ReuseFunctor),
ReuseArgTerms, _),
(
ReuseFunctor = "not_available",
% XXX Why don't we test ReuseArgTerms?
MaybeStructureReuse = no
;
ReuseFunctor = "yes",
ReuseArgTerms = [StructureReuseTerm],
StructureReuse = parse_structure_reuse_domain(StructureReuseTerm),
MaybeStructureReuse = yes(StructureReuse)
)
then
PredNameModesPF = pred_name_modes_pf(PredName, ModeList, PredOrFunc),
ReuseInfo = pragma_info_structure_reuse(PredNameModesPF,
HeadVars, Types, MaybeStructureReuse),
Pragma = pragma_structure_reuse(ReuseInfo),
ItemPragma = item_pragma_info(Pragma, item_origin_user,
Context, SeqNum),
Item = item_pragma(ItemPragma),
MaybeIOM = ok1(iom_item(Item))
else
Pieces = [words("Syntax error in"),
pragma_decl("structure_reuse"), words("declaration."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
MaybeIOM = error1([Spec])
).
%---------------------------------------------------------------------------%
:- pred parse_pragma_exceptions(module_name::in, term::in, list(term)::in,
prog_context::in, int::in, maybe1(item_or_marker)::out) is det.
parse_pragma_exceptions(ModuleName, ErrorTerm, PragmaTerms, Context, SeqNum,
MaybeIOM) :-
( if
PragmaTerms = [PredOrFuncTerm, PredNameTerm, ArityTerm, ModeNumTerm,
ThrowStatusTerm],
parse_predicate_or_function(PredOrFuncTerm, PredOrFunc),
decimal_term_to_int(ArityTerm, Arity),
decimal_term_to_int(ModeNumTerm, ModeNum),
try_parse_implicitly_qualified_sym_name_and_no_args(ModuleName,
PredNameTerm, PredName),
ThrowStatusTerm = term.functor(term.atom(ThrowStatusFunctor),
ThrowStatusArgTerms, _),
(
ThrowStatusFunctor = "will_not_throw",
ThrowStatusArgTerms = [],
ThrowStatus = will_not_throw
;
ThrowStatusFunctor = "may_throw",
ThrowStatusArgTerms = [ExceptionTypeTerm],
ExceptionTypeTerm = term.functor(term.atom(ExceptionFunctor),
[], _),
(
ExceptionFunctor = "user_exception",
ExceptionType = user_exception
;
ExceptionFunctor = "type_exception",
ExceptionType = type_exception
),
ThrowStatus = may_throw(ExceptionType)
;
ThrowStatusFunctor = "conditional",
ThrowStatusArgTerms = [],
ThrowStatus = throw_conditional
)
then
PredNameArityPFMn = pred_name_arity_pf_mn(PredName, Arity, PredOrFunc,
ModeNum),
ExceptionsInfo = pragma_info_exceptions(PredNameArityPFMn,
ThrowStatus),
Pragma = pragma_exceptions(ExceptionsInfo),
ItemPragma = item_pragma_info(Pragma, item_origin_user,
Context, SeqNum),
Item = item_pragma(ItemPragma),
MaybeIOM = ok1(iom_item(Item))
else
Pieces = [words("Error in"),
pragma_decl("exceptions"), suffix("."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
MaybeIOM = error1([Spec])
).
%---------------------------------------------------------------------------%
:- pred parse_pragma_trailing_info(module_name::in, term::in, list(term)::in,
prog_context::in, int::in, maybe1(item_or_marker)::out) is det.
parse_pragma_trailing_info(ModuleName, ErrorTerm, PragmaTerms,
Context, SeqNum, MaybeIOM) :-
( if
PragmaTerms = [PredOrFuncTerm, PredNameTerm, ArityTerm, ModeNumTerm,
TrailingStatusTerm],
parse_predicate_or_function(PredOrFuncTerm, PredOrFunc),
decimal_term_to_int(ArityTerm, Arity),
decimal_term_to_int(ModeNumTerm, ModeNum),
try_parse_implicitly_qualified_sym_name_and_no_args(ModuleName,
PredNameTerm, PredName),
TrailingStatusTerm = term.functor(term.atom(TrailingStatusFunctor),
[], _),
(
TrailingStatusFunctor = "will_not_modify_trail",
TrailingStatus = trail_will_not_modify
;
TrailingStatusFunctor = "may_modify_trail",
TrailingStatus = trail_may_modify
;
TrailingStatusFunctor = "conditional",
TrailingStatus = trail_conditional
)
then
PredNameArityPFMn = pred_name_arity_pf_mn(PredName, Arity, PredOrFunc,
ModeNum),
TrailingInfo = pragma_info_trailing_info(PredNameArityPFMn,
TrailingStatus),
Pragma = pragma_trailing_info(TrailingInfo),
ItemPragma = item_pragma_info(Pragma, item_origin_user,
Context, SeqNum),
Item = item_pragma(ItemPragma),
MaybeIOM = ok1(iom_item(Item))
else
Pieces = [words("Error in"), pragma_decl("trailing_info"),
suffix("."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
MaybeIOM = error1([Spec])
).
%---------------------------------------------------------------------------%
:- pred parse_pragma_mm_tabling_info(module_name::in, term::in, list(term)::in,
prog_context::in, int::in, maybe1(item_or_marker)::out) is det.
parse_pragma_mm_tabling_info(ModuleName, ErrorTerm, PragmaTerms,
Context, SeqNum, MaybeIOM) :-
( if
PragmaTerms = [PredOrFuncTerm, PredNameTerm, ArityTerm, ModeNumTerm,
MM_TablingStatusTerm],
parse_predicate_or_function(PredOrFuncTerm, PredOrFunc),
decimal_term_to_int(ArityTerm, Arity),
decimal_term_to_int(ModeNumTerm, ModeNum),
try_parse_implicitly_qualified_sym_name_and_no_args(ModuleName,
PredNameTerm, PredName),
MM_TablingStatusTerm = term.functor(term.atom(MM_TablingStatusFunctor),
[], _),
(
MM_TablingStatusFunctor = "mm_tabled_will_not_call",
MM_TablingStatus = mm_tabled_will_not_call
;
MM_TablingStatusFunctor = "mm_tabled_may_call",
MM_TablingStatus = mm_tabled_may_call
;
MM_TablingStatusFunctor = "mm_tabled_conditional",
MM_TablingStatus = mm_tabled_conditional
)
then
PredNameArityPFMn = pred_name_arity_pf_mn(PredName, Arity, PredOrFunc,
ModeNum),
TablingInfo = pragma_info_mm_tabling_info(PredNameArityPFMn,
MM_TablingStatus),
Pragma = pragma_mm_tabling_info(TablingInfo),
ItemPragma = item_pragma_info(Pragma, item_origin_user,
Context, SeqNum),
Item = item_pragma(ItemPragma),
MaybeIOM = ok1(iom_item(Item))
else
Pieces = [words("Error in"), pragma_decl("mm_tabling_info"),
suffix("."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
MaybeIOM = error1([Spec])
).
%---------------------------------------------------------------------------%
:- pred parse_pragma_require_feature_set(varset::in, term::in, list(term)::in,
prog_context::in, int::in, maybe1(item_or_marker)::out) is det.
parse_pragma_require_feature_set(VarSet, ErrorTerm, PragmaTerms,
Context, SeqNum, MaybeIOM) :-
( if PragmaTerms = [FeatureListTerm] then
UnrecognizedPieces = [words("Error: expected a feature"), nl],
convert_maybe_list("features", yes(VarSet), FeatureListTerm,
parse_required_feature, UnrecognizedPieces, 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 = [],
ItemNothing = item_nothing_info(no, Context, SeqNum),
Item = item_nothing(ItemNothing)
;
FeatureList = [_ | _],
FeatureSet = set.from_list(FeatureList),
RFSInfo = pragma_info_require_feature_set(FeatureSet),
Pragma = pragma_require_feature_set(RFSInfo),
ItemPragma = item_pragma_info(Pragma, item_origin_user,
Context, SeqNum),
Item = item_pragma(ItemPragma)
),
MaybeIOM = ok1(iom_item(Item))
)
;
MaybeFeatureList = error1(Specs),
MaybeIOM = error1(Specs)
)
else
Pieces = [words("Error: a"), pragma_decl("require_feature_set"),
words("declaration must have exactly one argument."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
MaybeIOM = error1([Spec])
).
%---------------------------------------------------------------------------%
:- pred parse_foreign_decl_is_local(term::in, foreign_decl_is_local::out)
is semidet.
parse_foreign_decl_is_local(term.functor(Functor, [], _), IsLocal) :-
(
Functor = term.string(String)
;
Functor = term.atom(String)
),
(
String = "local",
IsLocal = foreign_decl_is_local
;
String = "exported",
IsLocal = foreign_decl_is_exported
).
:- pred parse_foreign_literal_or_include(term::in,
foreign_literal_or_include::out) is semidet.
parse_foreign_literal_or_include(Term, LiteralOrInclude) :-
Term = term.functor(Functor, Args, _),
(
Functor = term.string(Code),
Args = [],
LiteralOrInclude = floi_literal(Code)
;
Functor = term.atom("include_file"),
Args = [term.functor(term.string(FileName), [], _)],
LiteralOrInclude = floi_include_file(FileName)
).
term_to_foreign_language(term.functor(term.string(String), _, _), Lang) :-
globals.convert_foreign_language(String, Lang).
term_to_foreign_language(term.functor(term.atom(String), _, _), Lang) :-
globals.convert_foreign_language(String, Lang).
:- pred parse_foreign_language_type(cord(format_component)::in, term::in,
varset::in, maybe1(foreign_language)::in,
maybe1(foreign_language_type)::out) is det.
parse_foreign_language_type(ContextPieces, InputTerm, VarSet, MaybeLanguage,
MaybeForeignLangType) :-
( if InputTerm = term.functor(term.string(ForeignTypeName), [], _) then
(
MaybeLanguage = ok1(Language),
(
(
Language = lang_c,
ForeignLangType = c(c_type(ForeignTypeName))
;
Language = lang_java,
ForeignLangType = java(java_type(ForeignTypeName))
;
Language = lang_csharp,
ForeignLangType = csharp(csharp_type(ForeignTypeName))
),
( if ForeignTypeName = "" then
Pieces = cord.list(ContextPieces) ++ [
lower_case_next_if_not_first,
words("Error: foreign type descriptor for language"),
quote(foreign_language_string(Language)),
words("must be a non-empty string.")
],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(InputTerm),
[always(Pieces)])]),
MaybeForeignLangType = error1([Spec])
else
MaybeForeignLangType = ok1(ForeignLangType)
)
;
Language = lang_erlang,
( if ForeignTypeName = "" then
MaybeForeignLangType = ok1(erlang(erlang_type))
else
Pieces = cord.list(ContextPieces) ++ [
lower_case_next_if_not_first,
words("Error: foreign type descriptor for language"),
quote(foreign_language_string(Language)),
words("must be an empty string.")
],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(InputTerm),
[always(Pieces)])]),
MaybeForeignLangType = error1([Spec])
)
)
;
% NOTE: if we get here then MaybeFooreignLang will be an error and
% will give the user the required error message.
MaybeLanguage = error1(_),
MaybeForeignLangType = error1([]) % Dummy value.
)
else
InputTermStr = describe_error_term(VarSet, InputTerm),
Pieces = cord.list(ContextPieces) ++ [
lower_case_next_if_not_first,
words("Error: expected a string specifying the"),
words("foreign type descriptor, got"), quote(InputTermStr),
suffix(".")
],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(InputTerm), [always(Pieces)])]),
MaybeForeignLangType = error1([Spec])
).
% This predicate parses foreign_decl pragmas.
%
:- pred parse_pragma_foreign_decl_pragma(varset::in, term::in, list(term)::in,
prog_context::in, int::in, maybe1(item_or_marker)::out) is det.
parse_pragma_foreign_decl_pragma(VarSet, ErrorTerm, PragmaTerms,
Context, SeqNum, MaybeIOM) :-
InvalidDeclPieces = [words("Error: invalid"),
pragma_decl("foreign_decl"), words("declaration:")],
(
(
PragmaTerms = []
;
PragmaTerms = [_]
),
Pieces = [words("Error: a"), pragma_decl("foreign_decl"),
words("declaration requires at least two arguments"),
words("(a language specification and"),
words("the foreign language declaration itself)."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
MaybeIOM = error1([Spec])
;
(
PragmaTerms = [LangTerm, HeaderTerm],
IsLocal = foreign_decl_is_exported,
IsLocalSpecs = []
;
PragmaTerms = [LangTerm, IsLocalTerm, HeaderTerm],
( if parse_foreign_decl_is_local(IsLocalTerm, IsLocalPrime) then
IsLocal = IsLocalPrime,
IsLocalSpecs = []
else
IsLocal = foreign_decl_is_exported, % Dummy, won't be used.
IsLocalStr = describe_error_term(VarSet, IsLocalTerm),
IsLocalPieces = [words("Error: the second argument"),
words("of a"), pragma_decl("foreign_decl"),
words("declaration must be either"), quote("local"),
words("or"), quote("exported"), suffix(":"),
words("got"), quote(IsLocalStr), suffix("."), nl],
IsLocalSpec = error_spec(severity_error,
phase_term_to_parse_tree,
[simple_msg(get_term_context(IsLocalTerm),
[always(IsLocalPieces)])]),
IsLocalSpecs = [IsLocalSpec]
)
),
( if term_to_foreign_language(LangTerm, ForeignLanguagePrime) then
ForeignLanguage = ForeignLanguagePrime,
LangSpecs = []
else
ForeignLanguage = lang_c, % Dummy, won't be used.
LangStr = describe_error_term(VarSet, LangTerm),
LangPieces = InvalidDeclPieces ++
[words("invalid language parameter"),
quote(LangStr), suffix("."), nl],
LangSpec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(LangTerm),
[always(LangPieces)])]),
LangSpecs = [LangSpec]
),
( if parse_foreign_literal_or_include(HeaderTerm, LitOrInclPrime) then
LiteralOrInclude = LitOrInclPrime,
LitInclSpecs = []
else
LiteralOrInclude = floi_literal(""), % Dummy, won't be used.
LitInclStr = describe_error_term(VarSet, HeaderTerm),
LitInclPieces = InvalidDeclPieces ++
[words("expected string or include_file for"),
words("foreign declaration code, got"),
quote(LitInclStr), suffix("."), nl],
LitInclSpec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(HeaderTerm),
[always(LitInclPieces)])]),
LitInclSpecs = [LitInclSpec]
),
( if
IsLocalSpecs = [],
LangSpecs = [],
LitInclSpecs = []
then
FDInfo = pragma_info_foreign_decl(ForeignLanguage, IsLocal,
LiteralOrInclude),
Pragma = pragma_foreign_decl(FDInfo),
ItemPragma = item_pragma_info(Pragma, item_origin_user,
Context, SeqNum),
Item = item_pragma(ItemPragma),
MaybeIOM = ok1(iom_item(Item))
else
MaybeIOM = error1(IsLocalSpecs ++ LangSpecs ++ LitInclSpecs)
)
;
PragmaTerms = [_, _, _, _ | _],
Pieces = [words("Error: a"), pragma_decl("foreign_decl"),
words("declaration may have at most three arguments"),
words("(a language specification,"),
words("a local/exported indication, and"),
words("the foreign language declaration itself)."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
MaybeIOM = error1([Spec])
).
% This predicate parses foreign_code pragmas.
% Processing of foreign_proc pragmas is handled in
% parse_pragma_foreign_proc_pragma below.
%
:- pred parse_pragma_foreign_code_pragma(term::in, list(term)::in,
prog_context::in, int::in, maybe1(item_or_marker)::out) is det.
parse_pragma_foreign_code_pragma(ErrorTerm,
PragmaTerms, Context, SeqNum, MaybeIOM) :-
InvalidDeclPrefix = [words("Error: invalid"),
pragma_decl("foreign_code"), words("declaration:")],
( if PragmaTerms = [LangTerm, CodeTerm] then
( if term_to_foreign_language(LangTerm, ForeignLanguagePrime) then
ForeignLanguage = ForeignLanguagePrime,
LangSpecs = []
else
ForeignLanguage = lang_c, % Dummy, ignored when LangSpecs \= []
LangPieces = InvalidDeclPrefix ++
[words("invalid language parameter."), nl],
LangSpec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(LangTerm),
[always(LangPieces)])]),
LangSpecs = [LangSpec]
),
( if parse_foreign_literal_or_include(CodeTerm, CodePrime) then
Code = CodePrime,
CodeSpecs = []
else
Code = floi_literal(""), % Dummy, ignored when CodeSpecs \= []
CodePieces = InvalidDeclPrefix ++
[words("expected string for foreign code."), nl],
CodeSpec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(CodeTerm),
[always(CodePieces)])]),
CodeSpecs = [CodeSpec]
),
Specs = LangSpecs ++ CodeSpecs,
(
Specs = [],
FCInfo = pragma_info_foreign_code(ForeignLanguage, Code),
Pragma = pragma_foreign_code(FCInfo),
ItemPragma = item_pragma_info(Pragma, item_origin_user,
Context, SeqNum),
Item = item_pragma(ItemPragma),
MaybeIOM = ok1(iom_item(Item))
;
Specs = [_ | _],
MaybeIOM = error1(Specs)
)
else
Pieces = InvalidDeclPrefix ++
[words("wrong number of arguments."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
MaybeIOM = error1([Spec])
).
% This predicate parses foreign_proc pragmas.
%
:- pred parse_pragma_foreign_proc_pragma(module_name::in, varset::in, term::in,
list(term)::in, prog_context::in, int::in,
maybe1(item_or_marker)::out) is det.
parse_pragma_foreign_proc_pragma(ModuleName, VarSet, ErrorTerm,
PragmaTerms, Context, SeqNum, MaybeIOM) :-
(
PragmaTerms = [LangTerm | RestTerms],
LangContextPieces = cord.from_list([
words("In first argument of"), pragma_decl("foreign_proc"),
words("declaration:")
]),
parse_foreign_language(LangContextPieces, VarSet, LangTerm,
MaybeForeignLanguage),
(
MaybeForeignLanguage = ok1(ForeignLanguage),
LangSpecs = []
;
MaybeForeignLanguage = error1(LangSpecs),
ForeignLanguage = lang_c % Dummy, ignored when LangSpecs \= []
),
( if
RestTerms = [PredAndVarsTerm, FlagsTerm, CodeTerm],
parse_pragma_ordinary_foreign_proc_pragma(ModuleName,
VarSet, ForeignLanguage, PredAndVarsTerm, FlagsTerm, CodeTerm,
Context, SeqNum, MaybeRestIOM)
then
(
MaybeRestIOM = ok1(IOM),
(
LangSpecs = [],
MaybeIOM = ok1(IOM)
;
LangSpecs = [_ | _],
MaybeIOM = error1(LangSpecs)
)
;
MaybeRestIOM = error1(RestSpecs),
MaybeIOM = error1(LangSpecs ++ RestSpecs)
)
else
Pieces = [
words("Error: a "), pragma_decl("foreign_proc"),
words("declaration must have four arguments.")
],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
MaybeIOM = error1([Spec])
)
;
PragmaTerms = [],
Pieces = [
words("Error: a "), pragma_decl("foreign_proc"),
words("declaration must have four arguments.")
],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
MaybeIOM = error1([Spec])
).
:- pred parse_pragma_ordinary_foreign_proc_pragma(module_name::in,
varset::in, foreign_language::in, term::in, term::in, term::in,
prog_context::in, int::in, maybe1(item_or_marker)::out) is det.
parse_pragma_ordinary_foreign_proc_pragma(ModuleName, VarSet,
ForeignLanguage, PredAndVarsTerm, FlagsTerm, CodeTerm,
Context, SeqNum, MaybeIOM) :-
PredAndVarsContextPieces =
cord.from_list([words("In the second argument of"),
pragma_decl("foreign_proc"), words("declaration:")]),
parse_pred_or_func_and_args_general(yes(ModuleName), PredAndVarsTerm,
VarSet, PredAndVarsContextPieces, MaybePredAndArgs),
(
MaybePredAndArgs =
ok2(PredName0, NonFuncArgTerms - MaybeFuncResultTerm),
% Is this a function or a predicate?
(
MaybeFuncResultTerm = yes(FuncResultTerm),
PredOrFunc0 = pf_function,
ArgTerms = NonFuncArgTerms ++ [FuncResultTerm]
;
MaybeFuncResultTerm = no,
PredOrFunc0 = pf_predicate,
ArgTerms = NonFuncArgTerms
),
parse_pragma_foreign_proc_varlist(VarSet, PredAndVarsContextPieces,
ArgTerms, 1, MaybePragmaVars),
(
MaybePragmaVars = ok1(PragmaVars0),
MaybeNamePFPragmaVars = ok3(PredName0, PredOrFunc0, PragmaVars0)
;
MaybePragmaVars = error1(PragmaVarsSpecs),
MaybeNamePFPragmaVars = error3(PragmaVarsSpecs)
)
;
MaybePredAndArgs = error2(PredAndArgsSpecs),
MaybeNamePFPragmaVars = error3(PredAndArgsSpecs)
),
FlagsContextPieces = cord.from_list([words("In the third argument of"),
pragma_decl("foreign_proc"), words("declaration:")]),
parse_and_check_pragma_foreign_proc_attributes_term(ForeignLanguage,
VarSet, FlagsTerm, FlagsContextPieces, MaybeFlags),
CodeContext = get_term_context(CodeTerm),
( if CodeTerm = term.functor(term.string(Code), [], _) then
Impl0 = fp_impl_ordinary(Code, yes(CodeContext)),
MaybeImpl = ok1(Impl0)
else
CodeTermStr = describe_error_term(VarSet, CodeTerm),
ImplPieces = [words("In the fourth argument of"),
pragma_decl("foreign_proc"), words("declaration:"),
words("error: expected a string containing foreign code, got"),
quote(CodeTermStr), suffix("."), nl],
ImplSpec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(CodeContext, [always(ImplPieces)])]),
MaybeImpl = error1([ImplSpec])
),
( if
MaybeNamePFPragmaVars = ok3(PredName, PredOrFunc, PragmaVars),
MaybeFlags = ok1(Flags),
MaybeImpl = ok1(Impl)
then
varset.coerce(VarSet, ProgVarSet),
varset.coerce(VarSet, InstVarSet),
FPInfo = pragma_info_foreign_proc(Flags, PredName, PredOrFunc,
PragmaVars, ProgVarSet, InstVarSet, Impl),
Pragma = pragma_foreign_proc(FPInfo),
ItemPragma = item_pragma_info(Pragma, item_origin_user,
Context, SeqNum),
Item = item_pragma(ItemPragma),
MaybeIOM = ok1(iom_item(Item))
else
AllSpecs = get_any_errors1(MaybeImpl) ++
get_any_errors3(MaybeNamePFPragmaVars) ++
get_any_errors1(MaybeFlags),
MaybeIOM = error1(AllSpecs)
).
% Parse the sole argument of a pragma that should contain
% a symbol name / arity pair.
%
:- pred parse_name_arity_pragma(module_name::in, string::in, string::in,
pred(sym_name, int, pragma_type)::(pred(in, in, out) is det),
list(term)::in, term::in, varset::in, prog_context::in, int::in,
maybe1(item_or_marker)::out) is det.
parse_name_arity_pragma(ModuleName, PragmaName, NameKind, MakePragma,
PragmaTerms, ErrorTerm, VarSet, Context, SeqNum, MaybeIOM) :-
( if PragmaTerms = [NameAndArityTerm] then
parse_simple_name_and_arity(ModuleName, PragmaName, NameKind,
NameAndArityTerm, NameAndArityTerm, VarSet, MaybeNameAndArity),
(
MaybeNameAndArity = ok2(Name, Arity),
MakePragma(Name, Arity, Pragma),
ItemPragma = item_pragma_info(Pragma, item_origin_user,
Context, SeqNum),
Item = item_pragma(ItemPragma),
MaybeIOM = ok1(iom_item(Item))
;
MaybeNameAndArity = error2(Specs),
MaybeIOM = error1(Specs)
)
else
Pieces = [words("Error: wrong number of arguments in"),
pragma_decl(PragmaName), words("declaration."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
MaybeIOM = error1([Spec])
).
:- pred parse_pred_name_and_arity(module_name::in, string::in, term::in,
term::in, varset::in, maybe2(sym_name, arity)::out) is det.
parse_pred_name_and_arity(ModuleName, PragmaName, NameAndArityTerm, ErrorTerm,
VarSet, MaybeNameAndArity) :-
parse_simple_name_and_arity(ModuleName, PragmaName,
"predicate or function", NameAndArityTerm, ErrorTerm, VarSet,
MaybeNameAndArity).
:- pred parse_simple_name_and_arity(module_name::in, string::in, string::in,
term::in, term::in, varset::in, maybe2(sym_name, arity)::out) is det.
parse_simple_name_and_arity(ModuleName, PragmaName, NameKind,
NameAndArityTerm, ErrorTerm, VarSet, MaybeNameAndArity) :-
( if parse_name_and_arity(ModuleName, NameAndArityTerm, Name, Arity) then
MaybeNameAndArity = ok2(Name, Arity)
else
NameAndArityTermStr = describe_error_term(VarSet, NameAndArityTerm),
Pieces = [words("Error: expected"), words(NameKind),
words("name/arity for"), pragma_decl(PragmaName),
words("declaration, not"), quote(NameAndArityTermStr),
suffix("."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
MaybeNameAndArity = error2([Spec])
).
%---------------------------------------------------------------------------%
:- type collected_pragma_foreign_proc_attribute
---> coll_may_call_mercury(proc_may_call_mercury)
; coll_thread_safe(proc_thread_safe)
; coll_tabled_for_io(proc_tabled_for_io)
; coll_purity(purity)
; coll_user_annotated_sharing(user_annotated_sharing)
; coll_backend(backend)
; coll_terminates(proc_terminates)
; coll_will_not_throw_exception
; coll_ordinary_despite_detism
; coll_may_modify_trail(proc_may_modify_trail)
; coll_may_call_mm_tabled(proc_may_call_mm_tabled)
; coll_box_policy(box_policy)
; coll_affects_liveness(proc_affects_liveness)
; coll_allocates_memory(proc_allocates_memory)
; coll_registers_roots(proc_registers_roots)
; coll_may_duplicate(proc_may_duplicate).
:- pred parse_and_check_pragma_foreign_proc_attributes_term(
foreign_language::in, varset::in, term::in, cord(format_component)::in,
maybe1(pragma_foreign_proc_attributes)::out) is det.
parse_and_check_pragma_foreign_proc_attributes_term(ForeignLanguage, VarSet,
Term, ContextPieces, MaybeAttributes) :-
Attributes0 = default_attributes(ForeignLanguage),
ConflictingAttributes = [
coll_may_call_mercury(proc_will_not_call_mercury) -
coll_may_call_mercury(proc_may_call_mercury),
coll_thread_safe(proc_thread_safe) -
coll_thread_safe(proc_not_thread_safe),
coll_tabled_for_io(proc_tabled_for_io) -
coll_tabled_for_io(proc_tabled_for_io_unitize),
coll_tabled_for_io(proc_tabled_for_io) -
coll_tabled_for_io(proc_tabled_for_descendant_io),
coll_tabled_for_io(proc_tabled_for_io) -
coll_tabled_for_io(proc_not_tabled_for_io),
coll_tabled_for_io(proc_tabled_for_io_unitize) -
coll_tabled_for_io(proc_tabled_for_descendant_io),
coll_tabled_for_io(proc_tabled_for_io_unitize) -
coll_tabled_for_io(proc_not_tabled_for_io),
coll_tabled_for_io(proc_tabled_for_descendant_io) -
coll_tabled_for_io(proc_not_tabled_for_io),
coll_purity(purity_pure) - coll_purity(purity_impure),
coll_purity(purity_pure) - coll_purity(purity_semipure),
coll_purity(purity_semipure) - coll_purity(purity_impure),
coll_terminates(proc_terminates) -
coll_terminates(proc_does_not_terminate),
coll_terminates(depends_on_mercury_calls) -
coll_terminates(proc_terminates),
coll_terminates(depends_on_mercury_calls) -
coll_terminates(proc_does_not_terminate),
coll_may_modify_trail(proc_may_modify_trail) -
coll_may_modify_trail(proc_will_not_modify_trail),
coll_may_call_mercury(proc_will_not_call_mercury) -
coll_may_call_mm_tabled(proc_may_call_mm_tabled),
coll_box_policy(bp_native_if_possible) -
coll_box_policy(bp_always_boxed),
coll_affects_liveness(proc_affects_liveness) -
coll_affects_liveness(proc_does_not_affect_liveness),
coll_allocates_memory(proc_does_not_allocate_memory) -
coll_allocates_memory(proc_allocates_bounded_memory),
coll_allocates_memory(proc_does_not_allocate_memory) -
coll_allocates_memory(proc_allocates_unbounded_memory),
coll_allocates_memory(proc_allocates_bounded_memory) -
coll_allocates_memory(proc_allocates_unbounded_memory),
coll_registers_roots(proc_does_not_register_roots) -
coll_registers_roots(proc_registers_roots),
coll_registers_roots(proc_does_not_register_roots) -
coll_registers_roots(proc_does_not_have_roots),
coll_registers_roots(proc_registers_roots) -
coll_registers_roots(proc_does_not_have_roots),
coll_may_duplicate(proc_may_duplicate) -
coll_may_duplicate(proc_may_not_duplicate)
],
parse_pragma_foreign_proc_attributes_term(ContextPieces, VarSet, Term,
MaybeAttrList),
(
MaybeAttrList = ok1(AttrList),
( if
% XXX Consider using report_any_conflicts instead.
some [Conflict1, Conflict2] (
list.member(Conflict1 - Conflict2, ConflictingAttributes),
list.member(Conflict1, AttrList),
list.member(Conflict2, AttrList)
)
then
% We could include Conflict1 and Conflict2 in the message,
% but the conflict is usually very obvious even without this.
Pieces = cord.list(ContextPieces) ++ [lower_case_next_if_not_first,
words("Error: conflicting attributes in attribute list."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(Term), [always(Pieces)])]),
MaybeAttributes = error1([Spec])
else
list.foldl(process_attribute, AttrList, Attributes0, Attributes),
MaybeAttributes = check_required_attributes(ForeignLanguage,
Attributes, get_term_context(Term))
)
;
MaybeAttrList = error1(Specs),
MaybeAttributes = error1(Specs)
).
% Update the pragma_foreign_proc_attributes according to the given
% collected_pragma_foreign_proc_attribute.
%
:- pred process_attribute(collected_pragma_foreign_proc_attribute::in,
pragma_foreign_proc_attributes::in,
pragma_foreign_proc_attributes::out) is det.
process_attribute(coll_may_call_mercury(MayCallMercury), !Attrs) :-
set_may_call_mercury(MayCallMercury, !Attrs).
process_attribute(coll_thread_safe(ThreadSafe), !Attrs) :-
set_thread_safe(ThreadSafe, !Attrs).
process_attribute(coll_tabled_for_io(TabledForIO), !Attrs) :-
set_tabled_for_io(TabledForIO, !Attrs).
process_attribute(coll_purity(Pure), !Attrs) :-
set_purity(Pure, !Attrs).
process_attribute(coll_terminates(Terminates), !Attrs) :-
set_terminates(Terminates, !Attrs).
process_attribute(coll_user_annotated_sharing(UserSharing), !Attrs) :-
set_user_annotated_sharing(UserSharing, !Attrs).
process_attribute(coll_will_not_throw_exception, !Attrs) :-
set_may_throw_exception(proc_will_not_throw_exception, !Attrs).
process_attribute(coll_backend(Backend), !Attrs) :-
add_extra_attribute(backend(Backend), !Attrs).
process_attribute(coll_ordinary_despite_detism, !Attrs) :-
set_ordinary_despite_detism(yes, !Attrs).
process_attribute(coll_may_modify_trail(TrailMod), !Attrs) :-
set_may_modify_trail(TrailMod, !Attrs).
process_attribute(coll_may_call_mm_tabled(MayCallTabled), !Attrs) :-
set_may_call_mm_tabled(MayCallTabled, !Attrs).
process_attribute(coll_box_policy(BoxPolicy), !Attrs) :-
set_box_policy(BoxPolicy, !Attrs).
process_attribute(coll_affects_liveness(AffectsLiveness), !Attrs) :-
set_affects_liveness(AffectsLiveness, !Attrs).
process_attribute(coll_allocates_memory(AllocatesMemory), !Attrs) :-
set_allocates_memory(AllocatesMemory, !Attrs).
process_attribute(coll_registers_roots(RegistersRoots), !Attrs) :-
set_registers_roots(RegistersRoots, !Attrs).
process_attribute(coll_may_duplicate(MayDuplicate), !Attrs) :-
set_may_duplicate(yes(MayDuplicate), !Attrs).
% Check whether all the required attributes have been set for
% a particular language
%
:- func check_required_attributes(foreign_language,
pragma_foreign_proc_attributes, term.context)
= maybe1(pragma_foreign_proc_attributes).
check_required_attributes(Lang, Attrs, _Context) = MaybeAttrs :-
(
( Lang = lang_c
; Lang = lang_csharp
; Lang = lang_java
; Lang = lang_erlang
),
MaybeAttrs = ok1(Attrs)
).
:- pred parse_pragma_foreign_proc_attributes_term(cord(format_component)::in,
varset::in, term::in,
maybe1(list(collected_pragma_foreign_proc_attribute))::out) is det.
parse_pragma_foreign_proc_attributes_term(ContextPieces, VarSet, Term,
MaybeAttrs) :-
( if parse_single_pragma_foreign_proc_attribute(VarSet, Term, Attr) then
MaybeAttrs = ok1([Attr])
else
parse_pragma_foreign_proc_attributes_list(ContextPieces, VarSet,
Term, 1, MaybeAttrs)
).
:- pred parse_pragma_foreign_proc_attributes_list(cord(format_component)::in,
varset::in, term::in, int::in,
maybe1(list(collected_pragma_foreign_proc_attribute))::out) is det.
parse_pragma_foreign_proc_attributes_list(ContextPieces, VarSet,
Term, HeadAttrNum, MaybeAttrs) :-
( if
Term = term.functor(term.atom("[]"), [], _)
then
MaybeAttrs = ok1([])
else if
Term = term.functor(term.atom("[|]"), [HeadTerm, TailTerm], _)
then
parse_pragma_foreign_proc_attributes_list(ContextPieces, VarSet,
TailTerm, HeadAttrNum + 1, MaybeTailAttrs),
( if
parse_single_pragma_foreign_proc_attribute(VarSet, HeadTerm,
HeadAttr)
then
(
MaybeTailAttrs = ok1(TailAttrs),
MaybeAttrs = ok1([HeadAttr | TailAttrs])
;
MaybeTailAttrs = error1(TailSpecs),
MaybeAttrs = error1(TailSpecs)
)
else
HeadTermStr = mercury_limited_term_to_string(VarSet,
print_name_only, 80, HeadTerm),
HeadPieces = cord.list(ContextPieces) ++
[lower_case_next_if_not_first,
words("Error: the"), nth_fixed(HeadAttrNum),
words("element of the attribute list,"),
quote(HeadTermStr), suffix(","),
words("is not a valid foreign_proc attribute."), nl],
HeadSpec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(HeadTerm),
[always(HeadPieces)])]),
MaybeAttrs = error1([HeadSpec | get_any_errors1(MaybeTailAttrs)])
)
else
TermStr = mercury_limited_term_to_string(VarSet, print_name_only,
80, Term),
TermPieces = cord.list(ContextPieces) ++
[lower_case_next_if_not_first,
words("Error: expected an attribute list, found"),
words(TermStr), suffix("."), nl],
TermSpec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(Term), [always(TermPieces)])]),
MaybeAttrs = error1([TermSpec])
).
:- pred parse_single_pragma_foreign_proc_attribute(varset::in, term::in,
collected_pragma_foreign_proc_attribute::out) is semidet.
parse_single_pragma_foreign_proc_attribute(VarSet, Term, Flag) :-
( if parse_may_call_mercury(Term, MayCallMercury) then
Flag = coll_may_call_mercury(MayCallMercury)
else if parse_threadsafe(Term, ThreadSafe) then
Flag = coll_thread_safe(ThreadSafe)
else if parse_tabled_for_io(Term, TabledForIo) then
Flag = coll_tabled_for_io(TabledForIo)
else if parse_user_annotated_sharing(VarSet, Term, UserSharing) then
Flag = coll_user_annotated_sharing(UserSharing)
else if parse_backend(Term, Backend) then
Flag = coll_backend(Backend)
else if parse_purity_promise(Term, Purity) then
Flag = coll_purity(Purity)
else if parse_terminates(Term, Terminates) then
Flag = coll_terminates(Terminates)
else if parse_no_exception_promise(Term) then
Flag = coll_will_not_throw_exception
else if parse_ordinary_despite_detism(Term) then
Flag = coll_ordinary_despite_detism
else if parse_may_modify_trail(Term, TrailMod) then
Flag = coll_may_modify_trail(TrailMod)
else if parse_may_call_mm_tabled(Term, CallsTabled) then
Flag = coll_may_call_mm_tabled(CallsTabled)
else if parse_box_policy(Term, BoxPolicy) then
Flag = coll_box_policy(BoxPolicy)
else if parse_affects_liveness(Term, AffectsLiveness) then
Flag = coll_affects_liveness(AffectsLiveness)
else if parse_allocates_memory(Term, AllocatesMemory) then
Flag = coll_allocates_memory(AllocatesMemory)
else if parse_registers_roots(Term, RegistersRoots) then
Flag = coll_registers_roots(RegistersRoots)
else if parse_may_duplicate(Term, MayDuplicate) then
Flag = coll_may_duplicate(MayDuplicate)
else
fail
).
:- pred parse_may_call_mercury(term::in, proc_may_call_mercury::out)
is semidet.
parse_may_call_mercury(term.functor(term.atom("recursive"), [], _),
proc_may_call_mercury).
parse_may_call_mercury(term.functor(term.atom("non_recursive"), [], _),
proc_will_not_call_mercury).
parse_may_call_mercury(term.functor(term.atom("may_call_mercury"), [], _),
proc_may_call_mercury).
parse_may_call_mercury(term.functor(term.atom("will_not_call_mercury"), [], _),
proc_will_not_call_mercury).
:- pred parse_threadsafe(term::in, proc_thread_safe::out) is semidet.
parse_threadsafe(term.functor(term.atom("thread_safe"), [], _),
proc_thread_safe).
parse_threadsafe(term.functor(term.atom("not_thread_safe"), [], _),
proc_not_thread_safe).
parse_threadsafe(term.functor(term.atom("maybe_thread_safe"), [], _),
proc_maybe_thread_safe).
:- pred parse_may_modify_trail(term::in, proc_may_modify_trail::out)
is semidet.
parse_may_modify_trail(term.functor(term.atom("may_modify_trail"), [], _),
proc_may_modify_trail).
parse_may_modify_trail(term.functor(term.atom("will_not_modify_trail"), [], _),
proc_will_not_modify_trail).
:- pred parse_may_call_mm_tabled(term::in, proc_may_call_mm_tabled::out)
is semidet.
parse_may_call_mm_tabled(Term, proc_may_call_mm_tabled) :-
Term = term.functor(term.atom("may_call_mm_tabled"), [], _).
parse_may_call_mm_tabled(Term, proc_will_not_call_mm_tabled) :-
Term = term.functor(term.atom("will_not_call_mm_tabled"), [], _).
:- pred parse_box_policy(term::in, box_policy::out) is semidet.
parse_box_policy(Term, bp_native_if_possible) :-
Term = term.functor(term.atom("native_if_possible"), [], _).
parse_box_policy(Term, bp_always_boxed) :-
Term = term.functor(term.atom("always_boxed"), [], _).
:- pred parse_affects_liveness(term::in, proc_affects_liveness::out)
is semidet.
parse_affects_liveness(Term, AffectsLiveness) :-
Term = term.functor(term.atom(Functor), [], _),
(
Functor = "affects_liveness",
AffectsLiveness = proc_affects_liveness
;
( Functor = "doesnt_affect_liveness"
; Functor = "does_not_affect_liveness"
),
AffectsLiveness = proc_does_not_affect_liveness
).
:- pred parse_allocates_memory(term::in, proc_allocates_memory::out)
is semidet.
parse_allocates_memory(Term, AllocatesMemory) :-
Term = term.functor(term.atom(Functor), [], _),
(
( Functor = "doesnt_allocate_memory"
; Functor = "does_not_allocate_memory"
),
AllocatesMemory = proc_does_not_allocate_memory
;
Functor = "allocates_bounded_memory",
AllocatesMemory = proc_allocates_bounded_memory
;
Functor = "allocates_unbounded_memory",
AllocatesMemory = proc_allocates_unbounded_memory
).
:- pred parse_registers_roots(term::in, proc_registers_roots::out) is semidet.
parse_registers_roots(Term, RegistersRoots) :-
Term = term.functor(term.atom(Functor), [], _),
(
Functor = "registers_roots",
RegistersRoots = proc_registers_roots
;
( Functor = "doesnt_register_roots"
; Functor = "does_not_register_roots"
),
RegistersRoots = proc_does_not_register_roots
;
( Functor = "doesnt_have_roots"
; Functor = "does_not_have_roots"
),
RegistersRoots = proc_does_not_have_roots
).
:- pred parse_may_duplicate(term::in, proc_may_duplicate::out) is semidet.
parse_may_duplicate(Term, RegistersRoots) :-
Term = term.functor(term.atom(Functor), [], _),
(
Functor = "may_duplicate",
RegistersRoots = proc_may_duplicate
;
Functor = "may_not_duplicate",
RegistersRoots = proc_may_not_duplicate
).
:- pred parse_tabled_for_io(term::in, proc_tabled_for_io::out) is semidet.
parse_tabled_for_io(term.functor(term.atom(Str), [], _), TabledForIo) :-
(
Str = "tabled_for_io",
TabledForIo = proc_tabled_for_io
;
Str = "tabled_for_io_unitize",
TabledForIo = proc_tabled_for_io_unitize
;
Str = "tabled_for_descendant_io",
TabledForIo = proc_tabled_for_descendant_io
;
Str = "not_tabled_for_io",
TabledForIo = proc_not_tabled_for_io
).
:- pred parse_backend(term::in, backend::out) is semidet.
parse_backend(term.functor(term.atom(Functor), [], _), Backend) :-
(
Functor = "high_level_backend",
Backend = high_level_backend
;
Functor = "low_level_backend",
Backend = low_level_backend
).
:- pred parse_purity_promise(term::in, purity::out) is semidet.
parse_purity_promise(term.functor(term.atom("promise_pure"), [], _),
purity_pure).
parse_purity_promise(term.functor(term.atom("promise_semipure"), [], _),
purity_semipure).
:- pred parse_terminates(term::in, proc_terminates::out) is semidet.
parse_terminates(term.functor(term.atom("terminates"), [], _),
proc_terminates).
parse_terminates(term.functor(term.atom("does_not_terminate"), [], _),
proc_does_not_terminate).
:- pred parse_no_exception_promise(term::in) is semidet.
parse_no_exception_promise(term.functor(
term.atom("will_not_throw_exception"), [], _)).
:- pred parse_ordinary_despite_detism(term::in) is semidet.
parse_ordinary_despite_detism(
term.functor(term.atom("ordinary_despite_detism"), [], _)).
% Parse the variable list in the pragma foreign_proc declaration.
% The final argument is 'no' for no error, or 'yes(ErrorMessage)'.
%
:- pred parse_pragma_foreign_proc_varlist(varset::in,
cord(format_component)::in,list(term)::in, int::in,
maybe1(list(pragma_var))::out) is det.
parse_pragma_foreign_proc_varlist(_, _, [], _, ok1([])).
parse_pragma_foreign_proc_varlist(VarSet, ContextPieces,
[HeadTerm | TailTerm], ArgNum, MaybePragmaVars):-
parse_pragma_foreign_proc_varlist(VarSet, ContextPieces,
TailTerm, ArgNum + 1, MaybeTailPragmaVars),
( if
HeadTerm = term.functor(term.atom("::"), [VarTerm, ModeTerm], _),
VarTerm = term.variable(Var, VarContext)
then
( if varset.search_name(VarSet, Var, VarName0) then
MaybeVarName = ok1(VarName0)
else
% If the variable wasn't in the varset it must be an
% underscore variable.
UnnamedPieces = [words("Sorry, not implemented: "),
words("anonymous"), quote("_"),
words("variable in pragma foreign_proc."), nl],
UnnamedSpec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(VarContext, [always(UnnamedPieces)])]),
MaybeVarName = error1([UnnamedSpec])
),
ArgContextPieces = ContextPieces ++ cord.from_list(
[words("in the"), nth_fixed(ArgNum), words("argument:")]),
parse_mode(allow_constrained_inst_var, VarSet, ArgContextPieces,
ModeTerm, MaybeMode0),
( if
MaybeMode0 = ok1(Mode0),
MaybeVarName = ok1(VarName),
MaybeTailPragmaVars = ok1(TailPragmaVars)
then
constrain_inst_vars_in_mode(Mode0, Mode),
term.coerce_var(Var, ProgVar),
HeadPragmaVar = pragma_var(ProgVar, VarName, Mode,
bp_native_if_possible),
MaybePragmaVars = ok1([HeadPragmaVar | TailPragmaVars])
else
Specs = get_any_errors1(MaybeTailPragmaVars)
++ get_any_errors1(MaybeVarName)
++ get_any_errors1(MaybeTailPragmaVars),
MaybePragmaVars = error1(Specs)
)
else
Pieces = [words("Error: the"), nth_fixed(ArgNum), words("argument is"),
words("not in the form"), quote("Var :: mode"), suffix("."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(HeadTerm), [always(Pieces)])]),
MaybePragmaVars = error1([Spec | get_any_errors1(MaybeTailPragmaVars)])
).
:- pred parse_oisu_pragma(module_name::in, varset::in, term::in,
list(term)::in, prog_context::in, int::in,
maybe1(item_or_marker)::out) is det.
parse_oisu_pragma(ModuleName, VarSet, ErrorTerm, PragmaTerms, Context, SeqNum,
MaybeIOM) :-
( if
PragmaTerms = [TypeCtorTerm, CreatorsTerm, MutatorsTerm | OtherTerms],
(
OtherTerms = [],
MaybeDestructorsTerm = no
;
OtherTerms = [DestructorsTerm],
MaybeDestructorsTerm = yes(DestructorsTerm)
)
then
( if parse_name_and_arity(ModuleName, TypeCtorTerm, Name, Arity) then
MaybeTypeCtor = ok1(type_ctor(Name, Arity))
else
TypeCtorTermStr = describe_error_term(VarSet, TypeCtorTerm),
Pieces = [words("Error: expected"),
words("predicate name/arity for first argument of"),
pragma_decl("oisu"), words("declaration, not"),
quote(TypeCtorTermStr), suffix("."), nl],
TypeCtorSpec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(ErrorTerm), [always(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 = pragma_oisu(OISUInfo),
ItemPragma = item_pragma_info(Pragma, item_origin_user,
Context, SeqNum),
Item = item_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)
)
else
Pieces = [words("Error: wrong number of arguments in"),
pragma_decl("oisu"), words("declaration."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
MaybeIOM = error1([Spec])
).
:- pred parse_oisu_preds_term(module_name::in, varset::in, string::in,
string::in, term::in, maybe1(list(pred_name_arity))::out) is det.
parse_oisu_preds_term(ModuleName, VarSet, ArgNum, ExpectedFunctor, Term,
MaybeNamesArities) :-
( if
Term = term.functor(term.atom(Functor), Args, _),
Functor = ExpectedFunctor,
Args = [Arg]
then
parse_name_and_arity_list(ModuleName, VarSet, ExpectedFunctor,
Arg, MaybeNamesArities)
else
Pieces = [words("Error:"), words(ArgNum), words("argument of"),
pragma_decl("oisu"), words("declaration"),
words("should have the form"),
quote(ExpectedFunctor ++ "([pred1/arity1, ..., predn/arityn])"),
suffix("."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(Term), [always(Pieces)])]),
MaybeNamesArities = error1([Spec])
).
:- pred parse_name_and_arity_list(module_name::in, varset::in, string::in,
term::in, maybe1(list(pred_name_arity))::out) is det.
parse_name_and_arity_list(ModuleName, VarSet, Wrapper, Term,
MaybeNamesArities) :-
(
Term = term.functor(Functor, Args, _),
( if
Functor = term.atom("[]"),
Args = []
then
MaybeNamesArities = ok1([])
else if
Functor = term.atom("[|]"),
Args = [Arg1, Arg2]
then
( if
parse_name_and_arity(ModuleName, Arg1, Arg1Name, Arg1Arity)
then
MaybeHeadNameArity = ok1(pred_name_arity(Arg1Name, Arg1Arity))
else
Arg1Str = describe_error_term(VarSet, Arg1),
Pieces = [words("Error: expected predname/arity,"),
words("not"), quote(Arg1Str), suffix("."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(Arg1), [always(Pieces)])]),
MaybeHeadNameArity = error1([Spec])
),
parse_name_and_arity_list(ModuleName, VarSet, Wrapper, Arg2,
MaybeTailNamesArities),
( if
MaybeHeadNameArity = ok1(HeadNameArity),
MaybeTailNamesArities = ok1(TailNamesArities)
then
MaybeNamesArities = ok1([HeadNameArity | TailNamesArities])
else
HeadSpecs = get_any_errors1(MaybeHeadNameArity),
TailSpecs = get_any_errors1(MaybeTailNamesArities),
MaybeNamesArities = error1(HeadSpecs ++ TailSpecs)
)
else
TermStr = describe_error_term(VarSet, Term),
Pieces = [words("Error: expected a list as the argument of"),
words(Wrapper), suffix(","),
words("not"), quote(TermStr), suffix("."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(Term), [always(Pieces)])]),
MaybeNamesArities = error1([Spec])
)
;
Term = term.variable(_, _),
TermStr = describe_error_term(VarSet, Term),
Pieces = [words("Error: expected a list as the argument of"),
words(Wrapper), suffix(","),
words("not"), quote(TermStr), suffix("."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(Term), [always(Pieces)])]),
MaybeNamesArities = error1([Spec])
).
:- pred parse_tabling_pragma(module_name::in, varset::in, term::in,
string::in, list(term)::in, prog_context::in, int::in,
eval_method::in, maybe1(item_or_marker)::out) is det.
parse_tabling_pragma(ModuleName, VarSet, ErrorTerm, PragmaName, PragmaTerms,
Context, SeqNum, EvalMethod, MaybeIOM) :-
( if
(
PragmaTerms = [PredAndModesTerm0],
MaybeAttrs = no
;
PragmaTerms = [PredAndModesTerm0, AttrListTerm0],
MaybeAttrs = yes(AttrListTerm0)
)
then
ContextPieces = cord.from_list([words("In"),
pragma_decl(PragmaName), words("declaration:")]),
parse_arity_or_modes(ModuleName, PredAndModesTerm0, ErrorTerm,
VarSet, ContextPieces, MaybeArityOrModes),
(
MaybeArityOrModes = ok1(ArityOrModes),
ArityOrModes = pred_name_arity_mpf_mmode(PredName, Arity,
MaybePredOrFunc, MaybeModes),
(
MaybeAttrs = no,
PredNameArityMPF = pred_name_arity_mpf(PredName, Arity,
MaybePredOrFunc),
TabledInfo = pragma_info_tabled(EvalMethod, PredNameArityMPF,
MaybeModes, no),
Pragma = pragma_tabled(TabledInfo),
ItemPragma = item_pragma_info(Pragma, item_origin_user,
Context, SeqNum),
Item = item_pragma(ItemPragma),
MaybeIOM = ok1(iom_item(Item))
;
MaybeAttrs = yes(AttrsListTerm),
UnrecognizedPieces =
[words("Error: expected tabling attribute."), nl],
convert_maybe_list("tabling attributes", yes(VarSet),
AttrsListTerm, parse_tabling_attribute(VarSet, EvalMethod),
UnrecognizedPieces, MaybeAttributeList),
(
MaybeAttributeList = ok1(AttributeList),
update_tabling_attributes(AttributeList,
default_memo_table_attributes, MaybeAttributes),
(
MaybeAttributes = ok1(Attributes),
PredNameArityMPF = pred_name_arity_mpf(PredName,
Arity, MaybePredOrFunc),
TabledInfo = pragma_info_tabled(EvalMethod,
PredNameArityMPF, MaybeModes, yes(Attributes)),
Pragma = pragma_tabled(TabledInfo),
ItemPragma = item_pragma_info(Pragma, item_origin_user,
Context, SeqNum),
Item = item_pragma(ItemPragma),
MaybeIOM = ok1(iom_item(Item))
;
MaybeAttributes = error1(Specs),
MaybeIOM = error1(Specs)
)
;
MaybeAttributeList = error1(Specs),
MaybeIOM = error1(Specs)
)
)
;
MaybeArityOrModes = error1(Specs),
MaybeIOM = error1(Specs)
)
else
Pieces = [words("Error: wrong number of arguments in"),
pragma_decl(PragmaName), words("declaration."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
MaybeIOM = error1([Spec])
).
:- type single_tabling_attribute
---> attr_strictness(call_table_strictness)
; attr_size_limit(int)
; attr_statistics
; attr_allow_reset.
:- pred update_tabling_attributes(
assoc_list(term.context, single_tabling_attribute)::in,
table_attributes::in, maybe1(table_attributes)::out) is det.
update_tabling_attributes([], Attributes, ok1(Attributes)).
update_tabling_attributes([Context - SingleAttr | TermSingleAttrs],
!.Attributes, MaybeAttributes) :-
(
SingleAttr = attr_strictness(Strictness),
( if !.Attributes ^ table_attr_strictness = cts_all_strict then
!Attributes ^ table_attr_strictness := Strictness,
update_tabling_attributes(TermSingleAttrs, !.Attributes,
MaybeAttributes)
else
Pieces = [words("Error: duplicate argument tabling methods"),
words("attribute in"), pragma_decl("memo"),
words("declaration."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(Context, [always(Pieces)])]),
MaybeAttributes = error1([Spec])
)
;
SingleAttr = attr_size_limit(Limit),
( if !.Attributes ^ table_attr_size_limit = no then
!Attributes ^ table_attr_size_limit := yes(Limit),
update_tabling_attributes(TermSingleAttrs, !.Attributes,
MaybeAttributes)
else
Pieces = [words("Error: duplicate size limits attribute in"),
pragma_decl("memo"), words("declaration."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(Context, [always(Pieces)])]),
MaybeAttributes = error1([Spec])
)
;
SingleAttr = attr_statistics,
( if
!.Attributes ^ table_attr_statistics = table_dont_gather_statistics
then
!Attributes ^ table_attr_statistics := table_gather_statistics,
update_tabling_attributes(TermSingleAttrs, !.Attributes,
MaybeAttributes)
else
Pieces = [words("Error: duplicate statistics attribute in"),
pragma_decl("memo"), words("declaration."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(Context, [always(Pieces)])]),
MaybeAttributes = error1([Spec])
)
;
SingleAttr = attr_allow_reset,
( if
!.Attributes ^ table_attr_allow_reset = table_dont_allow_reset
then
!Attributes ^ table_attr_allow_reset := table_allow_reset,
update_tabling_attributes(TermSingleAttrs, !.Attributes,
MaybeAttributes)
else
Pieces = [words("Error: duplicate allow_reset attribute in"),
pragma_decl("memo"), words("declaration."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(Context, [always(Pieces)])]),
MaybeAttributes = error1([Spec])
)
).
:- pred parse_tabling_attribute(varset::in, eval_method::in, term::in,
maybe1(pair(term.context, single_tabling_attribute))::out) is semidet.
parse_tabling_attribute(VarSet, EvalMethod, Term, MaybeContextAttribute) :-
Term = term.functor(term.atom(Functor), Args, Context),
(
Functor = "fast_loose",
Args = [],
( if eval_method_allows_fast_loose(EvalMethod) = yes then
Attribute = attr_strictness(cts_all_fast_loose),
MaybeContextAttribute = ok1(Context - Attribute)
else
Pieces = [words("Error: evaluation method"),
fixed(eval_method_to_string(EvalMethod)),
words("does not allow fast_loose tabling."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(Context, [always(Pieces)])]),
MaybeContextAttribute = error1([Spec])
)
;
Functor = "specified",
Args = [Arg1 | MoreArgs],
UnrecognizedPieces =
[words("Error: expected argument tabling method")],
convert_list("argument tabling methods", yes(VarSet), Arg1,
parse_arg_tabling_method, UnrecognizedPieces,
MaybeMaybeArgMethods),
(
MaybeMaybeArgMethods = ok1(MaybeArgMethods),
AllowsFastLoose = eval_method_allows_fast_loose(EvalMethod),
(
AllowsFastLoose = yes,
(
MoreArgs = [],
Attribute = attr_strictness(
cts_specified(MaybeArgMethods,
table_hidden_arg_value)),
MaybeContextAttribute = ok1(Context - Attribute)
;
MoreArgs = [Arg2],
( if
Arg2 = term.functor(
term.atom("hidden_arg_value"), [], _)
then
Attribute = attr_strictness(
cts_specified(MaybeArgMethods,
table_hidden_arg_value)),
MaybeContextAttribute = ok1(Context - Attribute)
else if
Arg2 = term.functor(
term.atom("hidden_arg_addr"), [], _)
then
Attribute = attr_strictness(
cts_specified(MaybeArgMethods,
table_hidden_arg_addr)),
MaybeContextAttribute = ok1(Context - Attribute)
else
Arg2Str = describe_error_term(VarSet, Arg2),
Pieces = [words("Error: expected hidden argument"),
words("tabling method, not"),
quote(Arg2Str), suffix("."), nl],
Spec = error_spec(severity_error,
phase_term_to_parse_tree,
[simple_msg(get_term_context(Arg2),
[always(Pieces)])]),
MaybeContextAttribute = error1([Spec])
)
;
MoreArgs = [_, _ | _],
Pieces = [words("Error: expected one or two arguments"),
words("for"), quote("specified"), suffix("."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(Context, [always(Pieces)])]),
MaybeContextAttribute = error1([Spec])
)
;
AllowsFastLoose = no,
Pieces = [words("Error: evaluation method"),
fixed(eval_method_to_string(EvalMethod)),
words("does not allow specified tabling methods."), nl],
% XXX Should we use the context from Arg1?
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(Context, [always(Pieces)])]),
MaybeContextAttribute = error1([Spec])
)
;
MaybeMaybeArgMethods = error1(Specs),
MaybeContextAttribute = error1(Specs)
)
;
Functor = "size_limit",
Args = [LimitTerm],
decimal_term_to_int(LimitTerm, Limit),
AllowsSizeLimit = eval_method_allows_size_limit(EvalMethod),
(
AllowsSizeLimit = yes,
Attribute = attr_size_limit(Limit),
MaybeContextAttribute = ok1(Context - Attribute)
;
AllowsSizeLimit = no,
Pieces = [words("Error: evaluation method"),
fixed(eval_method_to_string(EvalMethod)),
words("does not allow size limits."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(Context, [always(Pieces)])]),
MaybeContextAttribute = error1([Spec])
)
;
Functor = "statistics",
Args = [],
Attribute = attr_statistics,
MaybeContextAttribute = ok1(Context - Attribute)
;
Functor = "allow_reset",
Args = [],
Attribute = attr_allow_reset,
MaybeContextAttribute = ok1(Context - Attribute)
).
:- func eval_method_allows_fast_loose(eval_method) = bool.
eval_method_allows_fast_loose(eval_normal) = no.
eval_method_allows_fast_loose(eval_loop_check) = yes.
eval_method_allows_fast_loose(eval_memo) = yes.
eval_method_allows_fast_loose(eval_table_io(_, _)) = no.
eval_method_allows_fast_loose(eval_minimal(_)) = no.
:- func eval_method_allows_size_limit(eval_method) = bool.
eval_method_allows_size_limit(eval_normal) = no.
eval_method_allows_size_limit(eval_loop_check) = yes.
eval_method_allows_size_limit(eval_memo) = yes.
eval_method_allows_size_limit(eval_table_io(_, _)) = no.
eval_method_allows_size_limit(eval_minimal(_)) = no.
:- pred parse_arg_tabling_method(term::in, maybe(arg_tabling_method)::out)
is semidet.
parse_arg_tabling_method(term.functor(term.atom("value"), [], _),
yes(arg_value)).
parse_arg_tabling_method(term.functor(term.atom("addr"), [], _),
yes(arg_addr)).
parse_arg_tabling_method(term.functor(term.atom("promise_implied"), [], _),
yes(arg_promise_implied)).
parse_arg_tabling_method(term.functor(term.atom("output"), [], _), no).
:- pred parse_arity_or_modes(module_name::in, term::in, term::in, varset::in,
cord(format_component)::in, maybe1(pred_name_arity_mpf_mmode)::out) is det.
parse_arity_or_modes(ModuleName, PredAndModesTerm0, ErrorTerm, VarSet,
ContextPieces, MaybeArityOrModes) :-
( if
% Is this a simple pred/arity pragma.
PredAndModesTerm0 = term.functor(term.atom("/"),
[PredNameTerm, ArityTerm], _)
then
( if
try_parse_implicitly_qualified_sym_name_and_no_args(ModuleName,
PredNameTerm, PredName),
decimal_term_to_int(ArityTerm, Arity)
then
MaybeArityOrModes = ok1(pred_name_arity_mpf_mmode(PredName,
Arity, no, no))
else
Pieces = cord.list(ContextPieces) ++ [lower_case_next_if_not_first,
words("Error: expected predname/arity."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
MaybeArityOrModes = error1([Spec])
)
else
parse_pred_or_func_and_arg_modes(yes(ModuleName), VarSet,
ContextPieces, PredAndModesTerm0, MaybePredAndModes),
(
MaybePredAndModes = ok3(PredName, PredOrFunc, Modes),
list.length(Modes, Arity0),
(
PredOrFunc = pf_function,
Arity = Arity0 - 1
;
PredOrFunc = pf_predicate,
Arity = Arity0
),
ArityOrModes = pred_name_arity_mpf_mmode(PredName, Arity,
yes(PredOrFunc), yes(Modes)),
MaybeArityOrModes = ok1(ArityOrModes)
;
MaybePredAndModes = error3(Specs),
MaybeArityOrModes = error1(Specs)
)
).
:- type maybe_pred_or_func_modes ==
maybe3(sym_name, pred_or_func, list(mer_mode)).
:- pred parse_pred_or_func_and_arg_modes(maybe(module_name)::in,
varset::in, cord(format_component)::in, term::in,
maybe_pred_or_func_modes::out) is det.
parse_pred_or_func_and_arg_modes(MaybeModuleName, VarSet, ContextPieces,
PredAndModesTerm, MaybeNameAndModes) :-
parse_pred_or_func_and_args_general(MaybeModuleName, PredAndModesTerm,
VarSet, ContextPieces, MaybePredAndArgs),
(
MaybePredAndArgs = ok2(PredName, ArgModeTerms - MaybeRetModeTerm),
(
MaybeRetModeTerm = no,
parse_modes(allow_constrained_inst_var, VarSet, ContextPieces,
ArgModeTerms, MaybeArgModes),
(
MaybeArgModes = ok1(ArgModes),
% For predicates, we don't call constrain_inst_vars_in_mode
% on ArgModes. XXX Why precisely?
MaybeNameAndModes = ok3(PredName, pf_predicate, ArgModes)
;
MaybeArgModes = error1(Specs),
MaybeNameAndModes = error3(Specs)
)
;
MaybeRetModeTerm = yes(RetModeTerm),
parse_modes(allow_constrained_inst_var, VarSet, ContextPieces,
ArgModeTerms, MaybeArgModes0),
RetContextPieces = ContextPieces ++
cord.singleton(words("in the return value:")),
parse_mode(allow_constrained_inst_var, VarSet, RetContextPieces,
RetModeTerm, MaybeRetMode),
( if
MaybeArgModes0 = ok1(ArgModes0),
MaybeRetMode = ok1(RetMode)
then
ArgModes1 = ArgModes0 ++ [RetMode],
list.map(constrain_inst_vars_in_mode, ArgModes1, ArgModes),
MaybeNameAndModes = ok3(PredName, pf_function, ArgModes)
else
Specs = get_any_errors1(MaybeArgModes0)
++ get_any_errors1(MaybeRetMode),
MaybeNameAndModes = error3(Specs)
)
)
;
MaybePredAndArgs = error2(Specs),
MaybeNameAndModes = error3(Specs)
).
:- pred convert_bool(term::in, bool::out) is semidet.
convert_bool(Term, Bool) :-
Term = term.functor(term.atom(Name), [], _),
( Name = "yes", Bool = yes
; Name = "no", Bool = no
).
% XXX Why does convert_bool_list insist on ok when convert_int_list doesn't?
:- pred convert_bool_list(varset::in, term::in, list(bool)::out) is semidet.
convert_bool_list(VarSet, ListTerm, Bools) :-
convert_list("booleans", yes(VarSet), ListTerm, convert_bool,
[words("Error: expected boolean")], ok1(Bools)).
:- pred convert_int_list(varset::in, term::in, maybe1(list(int))::out) is det.
convert_int_list(VarSet, ListTerm, Result) :-
convert_list("integers", yes(VarSet), ListTerm, decimal_term_to_int,
[words("Error: expected integer")], Result).
% convert_list(What, MaybeVarSet, Term, Pred, UnrecognizedPieces, Result):
%
% Convert Term into a list of elements where Pred converts each element
% of the list into the correct type. Result will hold the list if the
% conversion succeeded for each element of M, otherwise it will hold
% the error. What should be a plural noun or noun phrase describing
% the expected list. If MaybeVarSet is yes, it should specify the varset
% for use in describing any unrecognized list elements.
%
:- pred convert_list(string::in, maybe(varset)::in, term::in,
pred(term, T)::(pred(in, out) is semidet),
list(format_component)::in, maybe1(list(T))::out) is det.
convert_list(What, MaybeVarSet, Term, Pred, UnrecognizedPieces, Result) :-
(
Term = term.variable(_, Context),
(
MaybeVarSet = yes(VarSet),
TermStr = describe_error_term(VarSet, Term),
Pieces = UnrecognizedPieces ++ [suffix(","), words("not"),
quote(TermStr), suffix("."), nl]
;
MaybeVarSet = no,
Pieces = UnrecognizedPieces ++ [suffix("."), nl]
),
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(Context, [always(Pieces)])]),
Result = error1([Spec])
;
Term = term.functor(Functor, Args, Context),
( if
Functor = term.atom("[|]"),
Args = [FirstTerm, RestTerm]
then
( if Pred(FirstTerm, FirstElement) then
convert_list(What, MaybeVarSet, RestTerm, Pred,
UnrecognizedPieces, RestResult),
(
RestResult = ok1(LaterElements),
Result = ok1([FirstElement | LaterElements])
;
RestResult = error1(_),
Result = RestResult
)
else
(
MaybeVarSet = yes(VarSet),
FirstTermStr = describe_error_term(VarSet, FirstTerm),
Pieces = UnrecognizedPieces ++ [suffix(","), words("not"),
quote(FirstTermStr), suffix("."), nl]
;
MaybeVarSet = no,
Pieces = UnrecognizedPieces ++ [suffix("."), nl]
),
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(Term), [always(Pieces)])]),
Result = error1([Spec])
)
else if
Functor = term.atom("[]"),
Args = []
then
Result = ok1([])
else
(
MaybeVarSet = yes(VarSet),
TermStr = describe_error_term(VarSet, Term),
Pieces = [words("Error: expected list of"), words(What),
suffix(","), words("not"), quote(TermStr), suffix("."), nl]
;
MaybeVarSet = no,
Pieces = [words("Error: expected list of"), words(What),
suffix("."), nl]
),
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(Context, [always(Pieces)])]),
Result = error1([Spec])
)
).
% This predicate does the same job as convert_list, but with a different
% type of supplied Pred, which returns a maybe(item_type), not item_type.
%
:- pred convert_maybe_list(string::in, maybe(varset)::in, term::in,
pred(term, maybe1(T))::(pred(in, out) is semidet),
list(format_component)::in, maybe1(list(T))::out) is det.
convert_maybe_list(What, MaybeVarSet, Term, Pred, UnrecognizedPieces,
Result) :-
(
Term = term.variable(_, Context),
(
MaybeVarSet = yes(VarSet),
TermStr = describe_error_term(VarSet, Term),
Pieces = UnrecognizedPieces ++ [suffix(","), words("got"),
quote(TermStr), suffix("."), nl]
;
MaybeVarSet = no,
Pieces = UnrecognizedPieces ++ [suffix("."), nl]
),
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(Context, [always(Pieces)])]),
Result = error1([Spec])
;
Term = term.functor(Functor, Args, Context),
( if
Functor = term.atom("[|]"),
Args = [FirstTerm, RestTerm]
then
( if Pred(FirstTerm, ElementResult) then
(
ElementResult = ok1(FirstElement),
convert_maybe_list(What, MaybeVarSet, RestTerm, Pred,
UnrecognizedPieces, RestResult),
(
RestResult = ok1(LaterElements),
Result = ok1([FirstElement | LaterElements])
;
RestResult = error1(_),
Result = RestResult
)
;
ElementResult = error1(Specs),
Result = error1(Specs)
)
else
(
MaybeVarSet = yes(VarSet),
FirstTermStr = describe_error_term(VarSet, FirstTerm),
Pieces = UnrecognizedPieces ++ [suffix(","), words("not"),
quote(FirstTermStr), suffix("."), nl]
;
MaybeVarSet = no,
Pieces = UnrecognizedPieces ++ [suffix("."), nl]
),
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(Term), [always(Pieces)])]),
Result = error1([Spec])
)
else if
Functor = term.atom("[]"),
Args = []
then
Result = ok1([])
else
(
MaybeVarSet = yes(VarSet),
TermStr = describe_error_term(VarSet, Term),
Pieces = [words("Error: expected list of"), words(What),
suffix(","), words("not"), quote(TermStr), suffix("."), nl]
;
MaybeVarSet = no,
Pieces = [words("Error: expected list of"), words(What),
suffix("."), nl]
),
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(Context, [always(Pieces)])]),
Result = error1([Spec])
)
).
:- pred convert_type_spec_pair(term::in, pair(tvar, mer_type)::out) is semidet.
convert_type_spec_pair(Term, TypeSpec) :-
Term = term.functor(term.atom("="), [TypeVarTerm, SpecTypeTerm0], _),
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),
SpecTypeTerm0, SpecType),
TypeSpec = TypeVar - SpecType.
%---------------------------------------------------------------------------%
%
% Parsing termination2_info pragmas.
%
:- pred parse_arg_size_constraints(term::in,
maybe1(maybe(list(arg_size_constr)))::out) is semidet.
parse_arg_size_constraints(ArgSizeTerm, MaybeMaybeArgSizeConstraints) :-
(
ArgSizeTerm = term.functor(term.atom("not_set"), [], _),
MaybeMaybeArgSizeConstraints = ok1(no)
;
ArgSizeTerm = term.functor(term.atom("constraints"),
[Constraints0], _),
UnrecognizedPieces = [words("Error: expected constraint."), nl],
convert_list("arg size constraints", no, Constraints0,
parse_arg_size_constraint, UnrecognizedPieces, MaybeConstraints),
MaybeConstraints = ok1(Constraints),
MaybeMaybeArgSizeConstraints = ok1(yes(Constraints))
).
:- pred parse_arg_size_constraint(term::in, arg_size_constr::out) is semidet.
parse_arg_size_constraint(Term, Constr) :-
(
Term = term.functor(term.atom("le"), [Terms, ConstantTerm], _),
UnrecognizedPieces = [words("Error: expected linear term."), nl],
convert_list("linear terms", no, Terms, parse_lp_term,
UnrecognizedPieces, TermsResult),
TermsResult = ok1(LPTerms),
parse_rational(ConstantTerm, Constant),
Constr = le(LPTerms, Constant)
;
Term = term.functor(term.atom("eq"), [Terms, ConstantTerm], _),
UnrecognizedPieces = [words("Error: expected linear term."), nl],
convert_list("linear terms", no, Terms, parse_lp_term,
UnrecognizedPieces, TermsResult),
TermsResult = ok1(LPTerms),
parse_rational(ConstantTerm, Constant),
Constr = eq(LPTerms, Constant)
).
:- pred parse_lp_term(term::in, arg_size_term::out) is semidet.
parse_lp_term(Term, LpTerm) :-
Term = term.functor(term.atom("term"), [VarIdTerm, CoeffTerm], _),
decimal_term_to_int(VarIdTerm, VarId),
parse_rational(CoeffTerm, Coeff),
LpTerm = arg_size_term(VarId, Coeff).
:- pred parse_rational(term::in, rat::out) is semidet.
parse_rational(Term, Rational) :-
Term = term.functor(term.atom("r"), [NumerTerm, DenomTerm], _),
decimal_term_to_int(NumerTerm, Numer),
decimal_term_to_int(DenomTerm, Denom),
Rational = rat.rat(Numer, Denom).
%---------------------------------------------------------------------------%
:- pred parse_required_feature(term::in,
maybe1(required_feature)::out) is semidet.
parse_required_feature(ReqFeatureTerm, MaybeReqFeature) :-
ReqFeatureTerm = term.functor(term.atom(Functor), [], _),
string_to_required_feature(Functor, ReqFeature),
MaybeReqFeature = ok1(ReqFeature).
:- 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).
%---------------------------------------------------------------------------%
:- pred parse_predicate_or_function(term::in, pred_or_func::out) is semidet.
parse_predicate_or_function(PredOrFuncTerm, PredOrFunc) :-
PredOrFuncTerm = term.functor(term.atom(Functor), [], _),
(
Functor = "predicate",
PredOrFunc = pf_predicate
;
Functor = "function",
PredOrFunc = pf_function
).
%---------------------------------------------------------------------------%
:- end_module parse_tree.parse_pragma.
%---------------------------------------------------------------------------%
Reference in New Issue View Git Blame Copy Permalink