mercurylang/mercury
1
0
Fork 0
mirror of https://github.com/Mercury-Language/mercury.git synced 2025-12-16 22:35:41 +00:00
Code Issues Projects Releases Wiki Activity
Files
d69ba1a1f0596e7f740b1a788350b5dcb343c276
mercury/compiler/prog_io_pragma.m
Zoltan Somogyi 056fd7d26c Hopefully finish the breakup of the monster module prog_io.m. 
Estimated hours taken: 2
Branches: main

Hopefully finish the breakup of the monster module prog_io.m. It is now way
out of the list of the ten biggest modules. More important, it now has much
more coherence: it consists mainly of

- the top level loop for reading in items, and
- the code for parsing predicate, function and mode declarations.

There are still some other misc things that don't fit here (e.g. checking insts
for consistency), but they don't fit that well in other modules either.

compiler/prog_io.m:
compiler/prog_io_mode_defn.m:
compiler/prog_io_type_defn.m:
	Move the code in prog_io.m for dealing with definitions of insts, modes
	and types into two new modules.

	Delete some obsolete comments at the top of prog_io.m..

compiler/prog_io_util.m:
	Move some generic stuff for dealing with declaration attributes and
	(nonsupported) conditions here from prog_io.m, since the module
	prog_io_type_defn.m also needs them.

compiler/parse_tree.m:
compiler/notes/compiler_design.html:
	Add the new modules.

compiler/*.m:
	Import the new modules where needed.
2008-12-03 05:01:45 +00:00

3405 lines
143 KiB
Mathematica
Raw Blame History

%-----------------------------------------------------------------------------%
% vim: ft=mercury ts=4 sw=4 expandtab
%-----------------------------------------------------------------------------%
% Copyright (C) 1996-2008 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: prog_io_pragma.m.
% Main authors: fjh, dgj, zs.
%
% This module handles the parsing of pragma directives.
%
%-----------------------------------------------------------------------------%
:- module parse_tree.prog_io_pragma.
:- interface.
:- import_module libs.globals.
:- import_module mdbcomp.prim_data.
:- import_module parse_tree.prog_data.
:- import_module parse_tree.prog_io_util.
:- import_module parse_tree.prog_item.
:- import_module list.
:- import_module term.
:- import_module varset.
%-----------------------------------------------------------------------------%
% Parse the pragma declaration. The item (if any) it returns is not
% necessarily a pragma item.
%
:- pred parse_pragma(module_name::in, varset::in, list(term)::in,
prog_context::in, int::in, maybe1(item)::out) is semidet.
% Parse a term that represents a foreign language.
%
:- pred parse_foreign_language(term::in, foreign_language::out) is semidet.
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
:- implementation.
:- import_module libs.compiler_util.
:- import_module libs.rat.
:- import_module parse_tree.error_util.
:- import_module parse_tree.mercury_to_mercury.
:- import_module parse_tree.prog_ctgc.
:- import_module parse_tree.prog_io.
:- import_module parse_tree.prog_io_type_defn.
:- import_module parse_tree.prog_io_sym_name.
:- import_module parse_tree.prog_out.
:- import_module parse_tree.prog_util.
:- import_module assoc_list.
:- import_module bool.
:- 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, MaybeItem) :-
(
PragmaTerms = [SinglePragmaTerm0],
parse_type_decl_where_part_if_present(non_solver_type, ModuleName,
VarSet, SinglePragmaTerm0, SinglePragmaTerm, MaybeWherePart),
SinglePragmaTerm = term.functor(term.atom(PragmaName), PragmaArgs,
_Context),
parse_pragma_type(ModuleName, PragmaName, PragmaArgs, SinglePragmaTerm,
VarSet, Context, SeqNum, MaybeItem0)
->
(
% The code to process `where' attributes will return an error
% result if solver attributes are given for a non-solver type.
% Because this is a non-solver type, if the unification with
% MaybeWherePart succeeds then _SolverTypeDetails is guaranteed
% to be `no'.
MaybeWherePart = ok2(_SolverTypeDetails, MaybeUserEqComp),
(
MaybeUserEqComp = yes(_),
MaybeItem0 = ok1(Item0)
->
(
Item0 = item_type_defn(ItemTypeDefn0),
ItemTypeDefn0 ^ td_ctor_defn =
parse_tree_foreign_type(Type, _, Assertions)
->
ItemTypeDefn = ItemTypeDefn0 ^ td_ctor_defn :=
parse_tree_foreign_type(Type, MaybeUserEqComp,
Assertions),
Item = item_type_defn(ItemTypeDefn),
MaybeItem = ok1(Item)
;
Pieces = [words("Error: unexpected"),
quote("where equality/comparison is"),
suffix("."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(SinglePragmaTerm0),
[always(Pieces)])]),
MaybeItem = error1([Spec])
)
;
MaybeItem = MaybeItem0
)
;
MaybeWherePart = error2(Specs),
MaybeItem = error1(Specs)
)
;
fail
).
%----------------------------------------------------------------------------%
:- pred parse_pragma_type(module_name::in, string::in, list(term)::in,
term::in, varset::in, prog_context::in, int::in, maybe1(item)::out)
is semidet.
parse_pragma_type(ModuleName, PragmaName, PragmaTerms, ErrorTerm, VarSet,
Context, SeqNum, MaybeItem) :-
(
PragmaName = "source_file",
parse_pragma_source_file(PragmaTerms, ErrorTerm,
Context, SeqNum, MaybeItem)
;
PragmaName = "foreign_type",
parse_pragma_foreign_type(ModuleName, PragmaTerms, ErrorTerm, VarSet,
Context, SeqNum, MaybeItem)
;
PragmaName = "foreign_decl",
parse_pragma_foreign_decl_pragma(ModuleName, PragmaName,
PragmaTerms, ErrorTerm, VarSet, Context, SeqNum, MaybeItem)
;
PragmaName = "c_header_code",
parse_pragma_c_header_code(ModuleName, PragmaTerms, ErrorTerm, VarSet,
Context, SeqNum, MaybeItem)
;
PragmaName = "foreign_code",
parse_pragma_foreign_code_pragma(ModuleName, PragmaName,
PragmaTerms, ErrorTerm, VarSet, Context, SeqNum, MaybeItem)
;
PragmaName = "foreign_proc",
parse_pragma_foreign_proc_pragma(ModuleName, PragmaName,
PragmaTerms, ErrorTerm, VarSet, Context, SeqNum, MaybeItem)
;
PragmaName = "foreign_export_enum",
parse_pragma_foreign_export_enum(PragmaTerms, ErrorTerm, VarSet,
Context, SeqNum, MaybeItem)
;
PragmaName = "foreign_enum",
parse_pragma_foreign_enum(PragmaTerms, ErrorTerm, VarSet,
Context, SeqNum, MaybeItem)
;
PragmaName = "foreign_export",
parse_pragma_foreign_export(PragmaTerms, ErrorTerm, VarSet,
Context, SeqNum, MaybeItem)
;
PragmaName = "c_code",
parse_pragma_c_code(ModuleName, PragmaTerms, ErrorTerm, VarSet,
Context, SeqNum, MaybeItem)
;
PragmaName = "c_import_module",
parse_pragma_c_import_module(PragmaTerms, ErrorTerm,
Context, SeqNum, MaybeItem)
;
PragmaName = "foreign_import_module",
parse_pragma_foreign_import_module(PragmaTerms, ErrorTerm,
Context, SeqNum, MaybeItem)
;
PragmaName = "import",
parse_pragma_import(ModuleName, PragmaTerms, ErrorTerm, VarSet,
Context, SeqNum, MaybeItem)
;
PragmaName = "export",
parse_pragma_export(PragmaTerms, ErrorTerm, VarSet,
Context, SeqNum, MaybeItem)
;
(
PragmaName = "inline",
MakePragma = (pred(Name::in, Arity::in, Pragma::out) is det :-
Pragma = pragma_inline(Name, Arity))
;
PragmaName = "no_inline",
MakePragma = (pred(Name::in, Arity::in, Pragma::out) is det :-
Pragma = pragma_no_inline(Name, Arity))
;
PragmaName = "obsolete",
MakePragma = (pred(Name::in, Arity::in, Pragma::out) is det :-
Pragma = pragma_obsolete(Name, Arity))
;
PragmaName = "promise_equivalent_clauses",
MakePragma = (pred(Name::in, Arity::in, Pragma::out) is det :-
Pragma = pragma_promise_equivalent_clauses(Name, Arity))
;
PragmaName = "promise_pure",
MakePragma = (pred(Name::in, Arity::in, Pragma::out) is det :-
Pragma = pragma_promise_pure(Name, Arity))
;
PragmaName = "promise_semipure",
MakePragma = (pred(Name::in, Arity::in, Pragma::out) is det :-
Pragma = pragma_promise_semipure(Name, Arity))
;
PragmaName = "terminates",
MakePragma = (pred(Name::in, Arity::in, Pragma::out) is det :-
Pragma = pragma_terminates(Name, Arity))
;
PragmaName = "does_not_terminate",
MakePragma = (pred(Name::in, Arity::in, Pragma::out) is det :-
Pragma = pragma_does_not_terminate(Name, Arity))
;
PragmaName = "check_termination",
MakePragma = (pred(Name::in, Arity::in, Pragma::out) is det :-
Pragma = pragma_check_termination(Name, Arity))
;
PragmaName = "mode_check_clauses",
MakePragma = (pred(Name::in, Arity::in, Pragma::out) is det :-
Pragma = pragma_mode_check_clauses(Name, Arity))
),
parse_simple_pragma(ModuleName, PragmaName, MakePragma,
PragmaTerms, ErrorTerm, VarSet, Context, SeqNum, MaybeItem)
;
PragmaName = "reserve_tag",
MakePragma = (pred(Name::in, Arity::in, Pragma::out) is det :-
Pragma = pragma_reserve_tag(Name, Arity)),
parse_simple_type_pragma(ModuleName, PragmaName, MakePragma,
PragmaTerms, ErrorTerm, VarSet, Context, SeqNum, MaybeItem)
;
(
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, PragmaName, EvalMethod,
PragmaTerms, ErrorTerm, VarSet, Context, SeqNum, MaybeItem)
;
PragmaName = "unused_args",
parse_pragma_unused_args(ModuleName, PragmaTerms, ErrorTerm, VarSet,
Context, SeqNum, MaybeItem)
;
PragmaName = "type_spec",
parse_pragma_type_spec(ModuleName, PragmaTerms, ErrorTerm, VarSet,
Context, SeqNum, MaybeItem)
;
PragmaName = "fact_table",
parse_pragma_fact_table(ModuleName, PragmaTerms, ErrorTerm, VarSet,
Context, SeqNum, MaybeItem)
;
PragmaName = "termination_info",
parse_pragma_termination_info(ModuleName, PragmaTerms, ErrorTerm,
VarSet, Context, SeqNum, MaybeItem)
;
PragmaName = "termination2_info",
parse_pragma_termination2_info(ModuleName, PragmaTerms, ErrorTerm,
VarSet, Context, SeqNum, MaybeItem)
;
PragmaName = "structure_sharing",
parse_pragma_structure_sharing(ModuleName, PragmaTerms, ErrorTerm,
VarSet, Context, SeqNum, MaybeItem)
;
PragmaName = "structure_reuse",
parse_pragma_structure_reuse(ModuleName, PragmaTerms, ErrorTerm,
VarSet, Context, SeqNum, MaybeItem)
;
PragmaName = "exceptions",
parse_pragma_exceptions(ModuleName, PragmaTerms, ErrorTerm, VarSet,
Context, SeqNum, MaybeItem)
;
PragmaName = "trailing_info",
parse_pragma_trailing_info(ModuleName, PragmaTerms, ErrorTerm, VarSet,
Context, SeqNum, MaybeItem)
;
PragmaName = "mm_tabling_info",
parse_pragma_mm_tabling_info(ModuleName, PragmaTerms, ErrorTerm,
VarSet, Context, SeqNum, MaybeItem)
;
PragmaName = "require_feature_set",
parse_pragma_require_feature_set(PragmaTerms, VarSet, ErrorTerm,
Context, SeqNum, MaybeItem)
).
%----------------------------------------------------------------------------%
% 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_source_file(list(term)::in, term::in, prog_context::in,
int::in, maybe1(item)::out) is det.
parse_pragma_source_file(PragmaTerms, ErrorTerm, Context, SeqNum, MaybeItem) :-
( PragmaTerms = [SourceFileTerm] ->
( SourceFileTerm = term.functor(term.string(SourceFile), [], _) ->
Pragma = pragma_source_file(SourceFile),
ItemPragma = item_pragma_info(user, Pragma, Context, SeqNum),
Item = item_pragma(ItemPragma),
MaybeItem = ok1(Item)
;
Pieces = [words("Error: the argument of a"),
quote(":- pragma source_file"),
words("declaration should be a string."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(SourceFileTerm),
[always(Pieces)])]),
MaybeItem = error1([Spec])
)
;
Pieces = [words("Error: wrong number of arguments in"),
quote(":- pragma source_file"), words("declaration."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
MaybeItem = error1([Spec])
).
:- pred parse_pragma_foreign_type(module_name::in, list(term)::in, term::in,
varset::in, prog_context::in, int::in, maybe1(item)::out) is det.
parse_pragma_foreign_type(ModuleName, PragmaTerms, ErrorTerm, VarSet, Context,
SeqNum, MaybeItem) :-
(
(
PragmaTerms = [LangTerm, MercuryTypeTerm, ForeignTypeTerm],
MaybeAssertionTerm = no
;
PragmaTerms = [LangTerm, MercuryTypeTerm, ForeignTypeTerm,
AssertionTerm],
MaybeAssertionTerm = yes(AssertionTerm)
)
->
(
parse_foreign_language(LangTerm, Language)
->
parse_foreign_language_type(ForeignTypeTerm, VarSet, Language,
MaybeForeignType),
(
MaybeForeignType = ok1(ForeignType),
parse_type_defn_head(ModuleName, VarSet, MercuryTypeTerm,
MaybeTypeDefnHead),
(
MaybeTypeDefnHead = ok2(MercuryTypeSymName, MercuryParams),
varset.coerce(VarSet, TVarSet),
(
parse_maybe_foreign_type_assertions(MaybeAssertionTerm,
Assertions)
->
% rafe: XXX I'm not sure that `no' here is right
% - we might need some more parsing...
ItemTypeDefn = item_type_defn_info(TVarSet,
MercuryTypeSymName, MercuryParams,
parse_tree_foreign_type(ForeignType, no,
Assertions),
cond_true, Context, SeqNum),
Item = item_type_defn(ItemTypeDefn),
MaybeItem = ok1(Item)
;
MaybeAssertionTerm = yes(ErrorAssertionTerm)
->
Pieces = [words("Error: invalid assertion in"),
quote(":- pragma foreign_type"),
words("declaration."), nl],
Spec = error_spec(severity_error,
phase_term_to_parse_tree,
[simple_msg(get_term_context(ErrorAssertionTerm),
[always(Pieces)])]),
MaybeItem = error1([Spec])
;
unexpected(this_file,
"parse_pragma_type: unexpected failure of " ++
"parse_maybe_foreign_type_assertion")
)
;
MaybeTypeDefnHead = error2(Specs),
MaybeItem = error1(Specs)
)
;
MaybeForeignType = error1(Specs),
MaybeItem = error1(Specs)
)
;
Pieces = [words("Error: invalid foreign language in"),
quote(":- pragma foreign_type"), words("declaration."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(LangTerm), [always(Pieces)])]),
MaybeItem = error1([Spec])
)
;
Pieces = [words("Error: wrong number of arguments in"),
quote(":- pragma foreign_type"), words("declaration."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
MaybeItem = error1([Spec])
).
:- pred parse_pragma_c_header_code(module_name::in, list(term)::in, term::in,
varset::in, prog_context::in, int::in, maybe1(item)::out) is det.
parse_pragma_c_header_code(ModuleName, PragmaTerms, ErrorTerm, VarSet, Context,
SeqNum, MaybeItem) :-
( PragmaTerms = [term.functor(_, _, Context) | _] ->
LangC = term.functor(term.string("C"), [], Context),
parse_pragma_foreign_decl_pragma(ModuleName, "c_header_code",
[LangC | PragmaTerms], ErrorTerm, VarSet, Context, SeqNum,
MaybeItem)
;
Pieces = [words("Error: wrong number or unexpected variable in"),
quote(":- pragma c_header_code"), words("declaration."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
MaybeItem = error1([Spec])
).
%----------------------------------------------------------------------------%
%
% Code for parsing foreign_export_enum pragmas
%
:- pred parse_pragma_foreign_export_enum(list(term)::in, term::in,
varset::in, prog_context::in, int::in, maybe1(item)::out) is det.
parse_pragma_foreign_export_enum(PragmaTerms, ErrorTerm, VarSet, Context,
SeqNum, MaybeItem) :-
(
(
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)
)
->
( parse_foreign_language(LangTerm, ForeignLanguage) ->
parse_export_enum_type(MercuryTypeTerm, MaybeType),
(
MaybeType = ok2(Name, Arity),
maybe_parse_export_enum_attributes(VarSet, MaybeAttributesTerm,
MaybeAttributes),
(
MaybeAttributes = ok1(Attributes),
maybe_parse_export_enum_overrides(VarSet,
MaybeOverridesTerm, MaybeOverrides),
(
MaybeOverrides = ok1(Overrides),
PragmaExportEnum = pragma_foreign_export_enum(
ForeignLanguage, Name, Arity, Attributes,
Overrides
),
ItemPragma = item_pragma_info(user, PragmaExportEnum,
Context, SeqNum),
Item = item_pragma(ItemPragma),
MaybeItem = ok1(Item)
;
MaybeOverrides = error1(Specs),
MaybeItem = error1(Specs)
)
;
MaybeAttributes = error1(Specs),
MaybeItem = error1(Specs)
)
;
MaybeType = error2(Specs),
MaybeItem = error1(Specs)
)
;
Pieces = [words("Error: invalid foreign language in"),
quote(":- pragma foreign_export_enum"), words("declaration."),
nl],
% XXX Get_term_context(LangTerm) would be better.
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
MaybeItem = error1([Spec])
)
;
Pieces = [words("Error: wrong number of arguments in"),
quote(":- pragma foreign_export_enum"), words("declaration."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
MaybeItem = error1([Spec])
).
:- pred parse_export_enum_type(term::in, maybe2(sym_name, arity)::out) is det.
parse_export_enum_type(TypeTerm, MaybeNameAndArity) :-
( parse_name_and_arity(TypeTerm, Name, Arity) ->
MaybeNameAndArity = ok2(Name, Arity)
;
Pieces = [words("Error: expected name/arity for type in"),
quote(":- pragma foreign_export_enum"), words("declaration."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(TypeTerm), [always(Pieces)])]),
MaybeNameAndArity = error2([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],
PairPieces = [words("In exported enumeration override constructor:")],
convert_maybe_list("mapping elements", yes(VarSet), OverridesTerm,
parse_sym_name_string_pair(VarSet, PairPieces),
UnrecognizedPieces, MaybeOverrides).
:- pred parse_sym_name_string_pair(varset::in, list(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_qualified_term(SymNameTerm, SymNameTerm, VarSet, ContextPieces,
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,
ConflictingAttributes = [],
(
list_term_to_term_list(AttributesTerm, AttributesTerms),
map_parser(parse_export_enum_attr(VarSet), AttributesTerms,
MaybeAttrList),
MaybeAttrList = ok1(CollectedAttributes)
->
(
list.member(ConflictA - ConflictB, ConflictingAttributes),
list.member(ConflictA, CollectedAttributes),
list.member(ConflictB, CollectedAttributes)
->
% XXX Print the conflicting attributes themselves.
Pieces = [words("Error: conflicting attributes in"),
quote(":- pragma 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])
;
% 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"),
quote(":- pragma 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])
)
)
;
Pieces = [words("Error: malformed attributes list in"),
quote(":- pragma 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])
).
:- 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 haved alredy 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) :-
(
Term = functor(atom("prefix"), Args, _),
Args = [ ForeignNameTerm ],
ForeignNameTerm = functor(string(Prefix), [], _)
->
MaybeAttribute = ok1(ee_attr_prefix(yes(Prefix)))
;
Term = functor(atom("uppercase"), [], _)
->
MaybeAttribute = ok1(ee_attr_upper(uppercase_export_enum))
;
TermStr = describe_error_term(VarSet, Term),
Pieces = [words("Error: unrecognised attribute in"),
quote(":- pragma foreign_export_enum"), words("declaration:"),
words(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(list(term)::in, term::in, varset::in,
prog_context::in, int::in, maybe1(item)::out) is det.
parse_pragma_foreign_enum(PragmaTerms, ErrorTerm, VarSet, Context, SeqNum,
MaybeItem) :-
( PragmaTerms = [LangTerm, MercuryTypeTerm, ValuesTerm] ->
( parse_foreign_language(LangTerm, ForeignLanguage) ->
parse_export_enum_type(MercuryTypeTerm, MaybeType),
(
MaybeType = ok2(TypeName, TypeArity),
UnrecognizedPieces =
[words("Error: expected a valid mapping element."), nl],
PairPieces = [words("In foreign_enum constructor name:")],
convert_maybe_list("mapping elements", yes(VarSet), ValuesTerm,
parse_sym_name_string_pair(VarSet, PairPieces),
UnrecognizedPieces, MaybeValues),
(
MaybeValues = ok1(Values),
PragmaForeignImportEnum = pragma_foreign_enum(
ForeignLanguage, TypeName, TypeArity, Values),
ItemPragma = item_pragma_info(user,
PragmaForeignImportEnum, Context, SeqNum),
Item = item_pragma(ItemPragma),
MaybeItem = ok1(Item)
;
MaybeValues = error1(Specs),
MaybeItem = error1(Specs)
)
;
MaybeType = error2(Specs),
MaybeItem = error1(Specs)
)
;
Pieces = [words("Error: invalid foreign language in"),
quote(":- pragma foreign_export_enum"), words("declaration."),
nl],
% XXX We should use the context of LangTerm.
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
MaybeItem = error1([Spec])
)
;
Pieces = [words("Error: wrong number of arguments in"),
quote(":- pragma foreign_export_enum"), words("declaration."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
MaybeItem = error1([Spec])
).
%----------------------------------------------------------------------------%
%
% Code for parsing foreign_export pragmas
%
:- pred parse_pragma_foreign_export(list(term)::in, term::in, varset::in,
prog_context::in, int::in, maybe1(item)::out) is det.
parse_pragma_foreign_export(PragmaTerms, ErrorTerm, VarSet, Context, SeqNum,
MaybeItem) :-
( PragmaTerms = [LangTerm, PredAndModesTerm, FunctionTerm] ->
( FunctionTerm = term.functor(term.string(Function), [], _) ->
ContextPieces = [words("In"),
quote(":- pragma foreign_export"), words("declaration")],
parse_pred_or_func_and_arg_modes(no, PredAndModesTerm,
ErrorTerm, VarSet, ContextPieces, MaybePredAndModes),
(
MaybePredAndModes = ok2(PredName - PredOrFunc, Modes),
( parse_foreign_language(LangTerm, ForeignLanguage) ->
Pragma = pragma_foreign_export(ForeignLanguage, PredName,
PredOrFunc, Modes, Function),
ItemPragma = item_pragma_info(user, Pragma, Context,
SeqNum),
Item = item_pragma(ItemPragma),
MaybeItem = ok1(Item)
;
Pieces = [words("Error: invalid foreign language in"),
quote(":- pragma foreign_export"),
words("declaration."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(LangTerm),
[always(Pieces)])]),
MaybeItem = error1([Spec])
)
;
MaybePredAndModes = error2(Specs),
MaybeItem = error1(Specs)
)
;
% XXX Why this wording?
Pieces = [words("Error: expected pragma"),
words("foreign_export(Lang, PredName(ModeList), Function)."),
nl],
% XXX Should we use the context of FunctionTerm?
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(PredAndModesTerm),
[always(Pieces)])]),
MaybeItem = error1([Spec])
)
;
Pieces = [words("Error: wrong number of arguments in"),
quote(":- pragma foreign_export"), words("declaration."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
MaybeItem = error1([Spec])
).
%----------------------------------------------------------------------------%
:- pred parse_pragma_c_code(module_name::in, list(term)::in, term::in,
varset::in, prog_context::in, int::in, maybe1(item)::out) is det.
parse_pragma_c_code(ModuleName, PragmaTerms, ErrorTerm, VarSet, Context,
SeqNum, MaybeItem) :-
% pragma c_code is almost as if we have written foreign_code
% or foreign_proc with the language set to "C".
% There are a few differences (error messages, some deprecated
% syntax is still supported for c_code) so we pass the original
% pragma name to parse_pragma_foreign_code_pragma.
(
% arity = 1 (same as foreign_code)
PragmaTerms = [term.functor(_, _, FirstContext)]
->
LangC = term.functor(term.string("C"), [], FirstContext),
parse_pragma_foreign_code_pragma(ModuleName, "c_code",
[LangC | PragmaTerms], ErrorTerm, VarSet, Context, SeqNum,
MaybeItem)
;
% arity > 1 (same as foreign_proc)
PragmaTerms = [term.functor(_, _, FirstContext) | _]
->
LangC = term.functor(term.string("C"), [], FirstContext),
parse_pragma_foreign_proc_pragma(ModuleName, "c_code",
[LangC | PragmaTerms], ErrorTerm, VarSet, Context, SeqNum,
MaybeItem)
;
Pieces = [words("Error: wrong number of arguments"),
words("or unexpected variable in"),
quote(":- pragma c_code"), words("declaration."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
MaybeItem = error1([Spec])
).
:- pred parse_pragma_c_import_module(list(term)::in, term::in,
prog_context::in, int::in, maybe1(item)::out) is det.
parse_pragma_c_import_module(PragmaTerms, ErrorTerm, Context, SeqNum,
MaybeItem) :-
(
PragmaTerms = [ImportTerm],
sym_name_and_args(ImportTerm, Import, [])
->
Pragma = pragma_foreign_import_module(lang_c, Import),
ItemPragma = item_pragma_info(user, Pragma, Context, SeqNum),
Item = item_pragma(ItemPragma),
MaybeItem = ok1(Item)
;
Pieces = [words("Error: wrong number of arguments"),
words("or invalid module name in"),
quote(":- pragma c_import_module"), words("declaration."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
MaybeItem = error1([Spec])
).
:- pred parse_pragma_foreign_import_module(list(term)::in, term::in,
prog_context::in, int::in, maybe1(item)::out) is det.
parse_pragma_foreign_import_module(PragmaTerms, ErrorTerm, Context, SeqNum,
MaybeItem) :-
(
PragmaTerms = [LangTerm, ImportTerm],
sym_name_and_args(ImportTerm, Import, [])
->
( parse_foreign_language(LangTerm, Language) ->
Pragma = pragma_foreign_import_module(Language, Import),
ItemPragma = item_pragma_info(user, Pragma, Context, SeqNum),
Item = item_pragma(ItemPragma),
MaybeItem = ok1(Item)
;
Pieces = [words("Error: invalid foreign language in"),
quote(":- pragma foreign_import_module"),
words("declaration."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(LangTerm), [always(Pieces)])]),
MaybeItem = error1([Spec])
)
;
Pieces = [words("Error: wrong number of arguments"),
words("or invalid module name in"),
quote(":- pragma foreign_import_module"),
words("declaration."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
MaybeItem = error1([Spec])
).
:- pred parse_pragma_import(module_name::in, list(term)::in, term::in,
varset::in, prog_context::in, int::in, maybe1(item)::out) is det.
parse_pragma_import(ModuleName, PragmaTerms, ErrorTerm, VarSet, Context,
SeqNum, MaybeItem) :-
% XXX We assume all imports are C.
ForeignLanguage = lang_c,
(
(
PragmaTerms = [PredAndModesTerm, FlagsTerm, FunctionTerm],
FlagsContextPieces = [words("In second argument of"),
quote(":- pragma import/3"), words("declaration:")],
parse_pragma_foreign_proc_attributes_term(ForeignLanguage,
"import", VarSet, FlagsTerm, FlagsContextPieces,
MaybeAttributes)
;
PragmaTerms = [PredAndModesTerm, FunctionTerm],
Flags0 = default_attributes(ForeignLanguage),
% Pragma import uses legacy purity behaviour.
set_legacy_purity_behaviour(yes, Flags0, Flags),
MaybeAttributes = ok1(Flags)
)
->
( FunctionTerm = term.functor(term.string(Function), [], _) ->
PredAndModesContextPieces = [words("In"),
quote(":- pragma import"), words("declaration:")],
parse_pred_or_func_and_arg_modes(yes(ModuleName), PredAndModesTerm,
ErrorTerm, VarSet, PredAndModesContextPieces,
MaybePredAndArgModes),
(
MaybePredAndArgModes = ok2(PredName - PredOrFunc, ArgModes),
(
MaybeAttributes = ok1(Attributes),
Pragma = pragma_import(PredName, PredOrFunc, ArgModes,
Attributes, Function),
ItemPragma = item_pragma_info(user, Pragma, Context,
SeqNum),
Item = item_pragma(ItemPragma),
MaybeItem = ok1(Item)
;
MaybeAttributes = error1(FlagsSpecs),
MaybeItem = error1(FlagsSpecs)
)
;
MaybePredAndArgModes = error2(Specs),
MaybeItem = error1(Specs)
)
;
Pieces = [words("Error: expected pragma"),
words("import(PredName(ModeList), Function)."), nl],
% XXX Should we use FunctionTerm's context?
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(PredAndModesTerm),
[always(Pieces)])]),
MaybeItem = error1([Spec])
)
;
Pieces = [words("Error: wrong number of arguments in"),
quote(":- pragma import"), words("declaration."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
MaybeItem = error1([Spec])
).
:- pred parse_pragma_export(list(term)::in, term::in, varset::in,
prog_context::in, int::in, maybe1(item)::out) is det.
parse_pragma_export(PragmaTerms, ErrorTerm, VarSet, Context, SeqNum,
MaybeItem) :-
( PragmaTerms = [PredAndModesTerm, FunctionTerm] ->
( FunctionTerm = term.functor(term.string(Function), [], _) ->
ContextPieces = [words("In"), quote(":- pragma export"),
words("declaration:")],
parse_pred_or_func_and_arg_modes(no, PredAndModesTerm, ErrorTerm,
VarSet, ContextPieces, MaybePredAndModes),
(
MaybePredAndModes = ok2(PredName - PredOrFunc, Modes),
Pragma = pragma_foreign_export(lang_c, PredName, PredOrFunc,
Modes, Function),
ItemPragma = item_pragma_info(user, Pragma, Context, SeqNum),
Item = item_pragma(ItemPragma),
MaybeItem = ok1(Item)
;
MaybePredAndModes = error2(Specs),
MaybeItem = error1(Specs)
)
;
% XXX Why this wording?
Pieces = [words("Error: expected pragma"),
words("export(PredName(ModeList), Function)."), nl],
% Should we use FunctionTerm's context?
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(PredAndModesTerm),
[always(Pieces)])]),
MaybeItem = error1([Spec])
)
;
Pieces = [words("Error: wrong number of arguments in"),
quote(":- pragma export"), words("declaration."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
MaybeItem = error1([Spec])
).
:- pred parse_pragma_unused_args(module_name::in, list(term)::in, term::in,
varset::in, prog_context::in, int::in, maybe1(item)::out) is det.
parse_pragma_unused_args(ModuleName, PragmaTerms, ErrorTerm, VarSet, Context,
SeqNum, MaybeItem) :-
% pragma unused_args should never appear in user programs,
% only in .opt files.
(
PragmaTerms = [PredOrFuncTerm, PredNameTerm, ArityTerm, ModeNumTerm,
UnusedArgsTerm],
ArityTerm = term.functor(term.integer(Arity), [], _),
ModeNumTerm = term.functor(term.integer(ModeNum), [], _),
parse_predicate_or_function(PredOrFuncTerm, PredOrFunc),
ContextPieces = [words("In"), quote(":- pragma unused_args"),
words("declaration:")],
parse_implicitly_qualified_term(ModuleName, PredNameTerm, ErrorTerm,
VarSet, ContextPieces, MaybePredName),
MaybePredName = ok2(PredName, []),
convert_int_list(VarSet, UnusedArgsTerm, MaybeUnusedArgs),
MaybeUnusedArgs = ok1(UnusedArgs)
->
Pragma = pragma_unused_args(PredOrFunc, PredName, Arity, ModeNum,
UnusedArgs),
ItemPragma = item_pragma_info(user, Pragma, Context, SeqNum),
Item = item_pragma(ItemPragma),
MaybeItem = ok1(Item)
;
% XXX Improve this message.
Pieces = [words("Error in"), quote(":- pragma unused_args"),
suffix("."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
MaybeItem = error1([Spec])
).
:- pred parse_pragma_type_spec(module_name::in, list(term)::in, term::in,
varset::in, prog_context::in, int::in, maybe1(item)::out) is det.
parse_pragma_type_spec(ModuleName, PragmaTerms, ErrorTerm, VarSet, Context,
SeqNum, MaybeItem) :-
(
(
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),
\+ string.remove_suffix(FileName, ".m", _),
% The value of ContextPieces does not matter here since we succeed
% only if it isn't used.
NameContextPieces = [],
parse_implicitly_qualified_term(ModuleName, SpecNameTerm,
ErrorTerm, VarSet, NameContextPieces, NameResult),
NameResult = ok2(SpecName, []),
MaybeName = yes(SpecName)
)
->
ArityOrModesContextPieces = [words("In"), quote(":- pragma type_spec"),
words("declaration:")],
parse_arity_or_modes(ModuleName, PredAndModesTerm, ErrorTerm,
VarSet, ArityOrModesContextPieces, MaybeArityOrModes),
(
MaybeArityOrModes = ok1(ArityOrModes),
ArityOrModes = arity_or_modes(PredName, Arity, MaybePredOrFunc,
MaybeModes),
conjunction_to_list(TypeSubnTerm, TypeSubnList),
% The varset is actually a tvarset.
varset.coerce(VarSet, TVarSet),
( list.map(convert_type_spec_pair, TypeSubnList, TypeSubn) ->
(
MaybeName = yes(SpecializedName0),
SpecializedName = SpecializedName0
;
MaybeName = no,
UnqualName = unqualify_name(PredName),
make_pred_name(ModuleName, "TypeSpecOf", MaybePredOrFunc,
UnqualName, newpred_type_subst(TVarSet, TypeSubn),
SpecializedName)
),
Pragma = pragma_type_spec(PredName, SpecializedName, Arity,
MaybePredOrFunc, MaybeModes, TypeSubn, TVarSet, set.init),
ItemPragma = item_pragma_info(user, Pragma, Context, SeqNum),
Item = item_pragma(ItemPragma),
MaybeItem = ok1(Item)
;
Pieces = [words("Error: expected type substitution in"),
quote(":- pragma type_spec"), words("declaration."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(TypeSubnTerm),
[always(Pieces)])]),
MaybeItem = error1([Spec])
)
;
MaybeArityOrModes = error1(Specs),
MaybeItem = error1(Specs)
)
;
Pieces = [words("Error: wrong number of arguments in"),
quote(":- pragma type_spec"), words("declaration."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
MaybeItem = error1([Spec])
).
:- pred parse_pragma_fact_table(module_name::in, list(term)::in, term::in,
varset::in, prog_context::in, int::in, maybe1(item)::out) is det.
parse_pragma_fact_table(ModuleName, PragmaTerms, ErrorTerm,
VarSet, Context, SeqNum, MaybeItem) :-
( PragmaTerms = [PredAndArityTerm, FileNameTerm] ->
parse_pred_name_and_arity(ModuleName, "fact_table",
PredAndArityTerm, ErrorTerm, VarSet, MaybeNameAndArity),
(
MaybeNameAndArity = ok2(PredName, Arity),
( FileNameTerm = term.functor(term.string(FileName), [], _) ->
Pragma = pragma_fact_table(PredName, Arity, FileName),
ItemPragma = item_pragma_info(user, Pragma, Context, SeqNum),
Item = item_pragma(ItemPragma),
MaybeItem = ok1(Item)
;
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)])]),
MaybeItem = error1([Spec])
)
;
MaybeNameAndArity = error2(Specs),
MaybeItem = error1(Specs)
)
;
Pieces = [words("Error: wrong number of arguments in"),
quote(":- pragma fact_table"), words("declaration."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
MaybeItem = error1([Spec])
).
:- pred parse_pragma_termination_info(module_name::in, list(term)::in,
term::in, varset::in, prog_context::in, int::in, maybe1(item)::out) is det.
parse_pragma_termination_info(ModuleName, PragmaTerms, ErrorTerm, VarSet,
Context, SeqNum, MaybeItem) :-
(
PragmaTerms = [PredAndModesTerm0, ArgSizeTerm, TerminationTerm],
ContextPieces = [words("In"),
quote(":- pragma termination_info"), words("declaration:")],
parse_pred_or_func_and_arg_modes(yes(ModuleName), PredAndModesTerm0,
ErrorTerm, VarSet, ContextPieces, MaybeNameAndModes),
MaybeNameAndModes = ok2(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],
IntTerm = term.functor(term.integer(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))
)
->
Pragma = pragma_termination_info(PredOrFunc, PredName, ModeList,
MaybeArgSizeInfo, MaybeTerminationInfo),
ItemPragma = item_pragma_info(user, Pragma, Context, SeqNum),
Item = item_pragma(ItemPragma),
MaybeItem = ok1(Item)
;
Pieces = [words("Syntax error in"),
quote(":- pragma termination_info"), words("declaration."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
MaybeItem = error1([Spec])
).
:- pred parse_pragma_termination2_info(module_name::in, list(term)::in,
term::in, varset::in, prog_context::in, int::in, maybe1(item)::out) is det.
parse_pragma_termination2_info(ModuleName, PragmaTerms, ErrorTerm, VarSet,
Context, SeqNum, MaybeItem) :-
(
PragmaTerms = [PredAndModesTerm0, SuccessArgSizeTerm,
FailureArgSizeTerm, TerminationTerm],
ContextPieces = [words("In"), quote(":- pragma termination2_info"),
words("declaration:")],
parse_pred_or_func_and_arg_modes(yes(ModuleName), PredAndModesTerm0,
ErrorTerm, VarSet, ContextPieces, NameAndModesResult),
NameAndModesResult = ok2(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))
)
->
Pragma = pragma_termination2_info(PredOrFunc, PredName, ModeList,
SuccessArgSizeInfo, FailureArgSizeInfo, MaybeTerminationInfo),
ItemPragma = item_pragma_info(user, Pragma, Context, SeqNum),
Item = item_pragma(ItemPragma),
MaybeItem = ok1(Item)
;
Pieces = [words("Syntax error in"),
quote(":- pragma termination2_info"), words("declaration."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
MaybeItem = error1([Spec])
).
:- pred parse_pragma_structure_sharing(module_name::in, list(term)::in,
term::in, varset::in, prog_context::in, int::in, maybe1(item)::out) is det.
parse_pragma_structure_sharing(ModuleName, PragmaTerms, ErrorTerm, VarSet,
Context, SeqNum, MaybeItem) :-
(
PragmaTerms = [PredAndModesTerm0, HeadVarsTerm,
HeadVarTypesTerm, SharingInformationTerm],
ModesContextPieces = [words("In"),
quote(":- pragma structure_sharing"), words("declaration:")],
parse_pred_or_func_and_arg_modes(yes(ModuleName), PredAndModesTerm0,
ErrorTerm, VarSet, ModesContextPieces, MaybeNameAndModes),
MaybeNameAndModes = ok2(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(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))
)
->
Pragma = pragma_structure_sharing(PredOrFunc, PredName, ModeList,
HeadVars, Types, MaybeSharingAs),
ItemPragma = item_pragma_info(user, Pragma, Context, SeqNum),
Item = item_pragma(ItemPragma),
MaybeItem = ok1(Item)
;
Pieces = [words("Syntax error in"),
quote(":- pragma structure_sharing"), words("declaration."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
MaybeItem = error1([Spec])
).
:- pred parse_pragma_structure_reuse(module_name::in, list(term)::in,
term::in, varset::in, prog_context::in, int::in, maybe1(item)::out) is det.
parse_pragma_structure_reuse(ModuleName, PragmaTerms, ErrorTerm, VarSet,
Context, SeqNum, MaybeItem) :-
(
PragmaTerms = [PredAndModesTerm0, HeadVarsTerm,
HeadVarTypesTerm, MaybeStructureReuseTerm],
ReuseContextPieces = [words("In"), quote(":- pragma structure_reuse"),
words("declaration:")],
parse_pred_or_func_and_arg_modes(yes(ModuleName), PredAndModesTerm0,
ErrorTerm, VarSet, ReuseContextPieces, MaybeNameAndModes),
MaybeNameAndModes = ok2(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(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)
)
->
Pragma = pragma_structure_reuse(PredOrFunc, PredName, ModeList,
HeadVars, Types, MaybeStructureReuse),
ItemPragma = item_pragma_info(user, Pragma, Context, SeqNum),
Item = item_pragma(ItemPragma),
MaybeItem = ok1(Item)
;
Pieces = [words("Syntax error in"),
quote(":- pragma structure_reuse"), words("declaration."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
MaybeItem = error1([Spec])
).
:- pred parse_pragma_exceptions(module_name::in, list(term)::in, term::in,
varset::in, prog_context::in, int::in, maybe1(item)::out) is det.
parse_pragma_exceptions(ModuleName, PragmaTerms, ErrorTerm, VarSet, Context,
SeqNum, MaybeItem) :-
(
PragmaTerms = [PredOrFuncTerm, PredNameTerm, ArityTerm, ModeNumTerm,
ThrowStatusTerm],
parse_predicate_or_function(PredOrFuncTerm, PredOrFunc),
ArityTerm = term.functor(term.integer(Arity), [], _),
ModeNumTerm = term.functor(term.integer(ModeNum), [], _),
ContextPieces = [words("In"), quote(":- pragma exceptions"),
words("declaration:")],
parse_implicitly_qualified_term(ModuleName, PredNameTerm, ErrorTerm,
VarSet, ContextPieces, MaybePredNameAndArgs),
MaybePredNameAndArgs = ok2(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
)
->
Pragma = pragma_exceptions(PredOrFunc, PredName, Arity, ModeNum,
ThrowStatus),
ItemPragma = item_pragma_info(user, Pragma, Context, SeqNum),
Item = item_pragma(ItemPragma),
MaybeItem = ok1(Item)
;
Pieces = [words("Error in"),
quote(":- pragma exceptions"), suffix("."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
MaybeItem = error1([Spec])
).
:- pred parse_pragma_trailing_info(module_name::in, list(term)::in, term::in,
varset::in, prog_context::in, int::in, maybe1(item)::out) is det.
parse_pragma_trailing_info(ModuleName, PragmaTerms, ErrorTerm, VarSet, Context,
SeqNum, MaybeItem) :-
(
PragmaTerms = [PredOrFuncTerm, PredNameTerm, ArityTerm, ModeNumTerm,
TrailingStatusTerm],
parse_predicate_or_function(PredOrFuncTerm, PredOrFunc),
ArityTerm = term.functor(term.integer(Arity), [], _),
ModeNumTerm = term.functor(term.integer(ModeNum), [], _),
ContextPieces = [words("In"), quote(":- pragma trailing_info"),
words("declaration:")],
parse_implicitly_qualified_term(ModuleName, PredNameTerm, ErrorTerm,
VarSet, ContextPieces, MaybePredNameAndArgs),
MaybePredNameAndArgs = ok2(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
)
->
Pragma = pragma_trailing_info(PredOrFunc, PredName, Arity, ModeNum,
TrailingStatus),
ItemPragma = item_pragma_info(user, Pragma, Context, SeqNum),
Item = item_pragma(ItemPragma),
MaybeItem = ok1(Item)
;
Pieces = [words("Error in"), quote(":- pragma trailing_info"),
suffix("."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
MaybeItem = error1([Spec])
).
:- pred parse_pragma_mm_tabling_info(module_name::in, list(term)::in, term::in,
varset::in, prog_context::in, int::in, maybe1(item)::out) is det.
parse_pragma_mm_tabling_info(ModuleName, PragmaTerms, ErrorTerm, VarSet,
Context, SeqNum, MaybeItem) :-
(
PragmaTerms = [PredOrFuncTerm, PredNameTerm, ArityTerm, ModeNumTerm,
MM_TablingStatusTerm],
parse_predicate_or_function(PredOrFuncTerm, PredOrFunc),
ArityTerm = term.functor(term.integer(Arity), [], _),
ModeNumTerm = term.functor(term.integer(ModeNum), [], _),
ContextPieces = [words("In"), quote(":- pragma mm_tabling_info"),
words("declaration:")],
parse_implicitly_qualified_term(ModuleName, PredNameTerm, ErrorTerm,
VarSet, ContextPieces, MaybePredNameAndArgs),
MaybePredNameAndArgs = ok2(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
)
->
Pragma = pragma_mm_tabling_info(PredOrFunc, PredName, Arity, ModeNum,
MM_TablingStatus),
ItemPragma = item_pragma_info(user, Pragma, Context, SeqNum),
Item = item_pragma(ItemPragma),
MaybeItem = ok1(Item)
;
Pieces = [words("Error in"), quote(":- pragma mm_tabling_info"),
suffix("."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
MaybeItem = error1([Spec])
).
:- pred parse_pragma_require_feature_set(list(term)::in, varset::in, term::in,
prog_context::in, int::in, maybe1(item)::out) is det.
parse_pragma_require_feature_set(PragmaTerms, VarSet, ErrorTerm, Context,
SeqNum, MaybeItem) :-
( PragmaTerms = [FeatureListTerm] ->
UnrecognizedPieces = [words("Error: expected a feature"), nl],
convert_maybe_list("features", yes(VarSet), FeatureListTerm,
parse_required_feature, UnrecognizedPieces, MaybeFeatureList),
(
MaybeFeatureList = ok1(FeatureList),
ConflictingFeatures = [
reqf_single_prec_float - reqf_double_prec_float,
reqf_parallel_conj - reqf_trailing
],
(
list.member(ConflictA - ConflictB, ConflictingFeatures),
list.member(ConflictA, FeatureList),
list.member(ConflictB, FeatureList)
->
FeatureListStr = describe_error_term(VarSet, FeatureListTerm),
Pieces = [words("Error: conflicting features in feature set:"),
nl, words(FeatureListStr), suffix("."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(FeatureListTerm),
[always(Pieces)])]),
MaybeItem = error1([Spec])
;
(
FeatureList = [],
ItemNothing = item_nothing_info(no, Context, SeqNum),
Item = item_nothing(ItemNothing)
;
FeatureList = [_ | _],
FeatureSet = set.from_list(FeatureList),
Pragma = pragma_require_feature_set(FeatureSet),
ItemPragma = item_pragma_info(user, Pragma, Context,
SeqNum),
Item = item_pragma(ItemPragma)
),
MaybeItem = ok1(Item)
)
;
MaybeFeatureList = error1(Specs),
MaybeItem = error1(Specs)
)
;
Pieces = [words("Syntax error in"),
quote(":- pragma require_feature_set"), words("declaration."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
MaybeItem = 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
).
parse_foreign_language(term.functor(term.string(String), _, _), Lang) :-
globals.convert_foreign_language(String, Lang).
parse_foreign_language(term.functor(term.atom(String), _, _), Lang) :-
globals.convert_foreign_language(String, Lang).
:- pred parse_foreign_language_type(term::in, varset::in, foreign_language::in,
maybe1(foreign_language_type)::out) is det.
parse_foreign_language_type(InputTerm, VarSet, Language,
MaybeForeignLangType) :-
(
Language = lang_il,
( InputTerm = term.functor(term.string(ILTypeName), [], _) ->
parse_il_type_name(ILTypeName, InputTerm, VarSet,
MaybeForeignLangType)
;
InputTermStr = describe_error_term(VarSet, InputTerm),
Pieces = [words("Error: invalid backend specification"),
quote(InputTermStr), suffix("."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(InputTerm), [always(Pieces)])]),
MaybeForeignLangType = error1([Spec])
)
;
Language = lang_c,
( InputTerm = term.functor(term.string(CTypeName), [], _) ->
MaybeForeignLangType = ok1(c(c_type(CTypeName)))
;
InputTermStr = describe_error_term(VarSet, InputTerm),
Pieces = [words("Error: invalid backend specification"),
quote(InputTermStr), suffix("."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(InputTerm), [always(Pieces)])]),
MaybeForeignLangType = error1([Spec])
)
;
Language = lang_java,
( InputTerm = term.functor(term.string(JavaTypeName), [], _) ->
MaybeForeignLangType = ok1(java(java_type(JavaTypeName)))
;
InputTermStr = describe_error_term(VarSet, InputTerm),
Pieces = [words("Error: invalid backend specification"),
quote(InputTermStr), suffix("."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(InputTerm), [always(Pieces)])]),
MaybeForeignLangType = error1([Spec])
)
;
Language = lang_erlang,
( InputTerm = term.functor(term.string(_ErlangTypeName), [], _) ->
% XXX should we check if the type is blank?
MaybeForeignLangType = ok1(erlang(erlang_type))
;
InputTermStr = describe_error_term(VarSet, InputTerm),
Pieces = [words("Error: invalid backend specification"),
quote(InputTermStr), suffix("."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(InputTerm), [always(Pieces)])]),
MaybeForeignLangType = error1([Spec])
)
;
Language = lang_csharp,
Pieces = [words("Error: unsupported language specified,"),
words("unable to parse backend type."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(InputTerm), [always(Pieces)])]),
MaybeForeignLangType = error1([Spec])
).
:- pred parse_il_type_name(string::in, term::in, varset::in,
maybe1(foreign_language_type)::out) is det.
parse_il_type_name(String0, ErrorTerm, VarSet, ForeignType) :-
(
parse_special_il_type_name(String0, ForeignTypeResult)
->
ForeignType = ok1(il(ForeignTypeResult))
;
string.append("class [", String1, String0),
string.sub_string_search(String1, "]", Index)
->
string.left(String1, Index, AssemblyName),
string.split(String1, Index + 1, _, TypeNameStr),
TypeSymName = string_to_sym_name(TypeNameStr),
ForeignType = ok1(il(il_type(reference, AssemblyName, TypeSymName)))
;
string.append("valuetype [", String1, String0),
string.sub_string_search(String1, "]", Index)
->
string.left(String1, Index, AssemblyName),
string.split(String1, Index + 1, _, TypeNameStr),
TypeSymName = string_to_sym_name(TypeNameStr),
ForeignType = ok1(il(il_type(value, AssemblyName, TypeSymName)))
;
TermStr = describe_error_term(VarSet, ErrorTerm),
Pieces = [words("Error: invalid foreign language type description"),
quote(TermStr), suffix("."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
ForeignType = error1([Spec])
).
% Parse all the special assembler names for all the builtin types.
% See Partition I 'Built-In Types' (Section 8.2.2) for the list
% of all builtin types.
%
:- pred parse_special_il_type_name(string::in, il_foreign_type::out)
is semidet.
parse_special_il_type_name("bool", il_type(value, "mscorlib",
qualified(unqualified("System"), "Boolean"))).
parse_special_il_type_name("char", il_type(value, "mscorlib",
qualified(unqualified("System"), "Char"))).
parse_special_il_type_name("object", il_type(reference, "mscorlib",
qualified(unqualified("System"), "Object"))).
parse_special_il_type_name("string", il_type(reference, "mscorlib",
qualified(unqualified("System"), "String"))).
parse_special_il_type_name("float32", il_type(value, "mscorlib",
qualified(unqualified("System"), "Single"))).
parse_special_il_type_name("float64", il_type(value, "mscorlib",
qualified(unqualified("System"), "Double"))).
parse_special_il_type_name("int8", il_type(value, "mscorlib",
qualified(unqualified("System"), "SByte"))).
parse_special_il_type_name("int16", il_type(value, "mscorlib",
qualified(unqualified("System"), "Int16"))).
parse_special_il_type_name("int32", il_type(value, "mscorlib",
qualified(unqualified("System"), "Int32"))).
parse_special_il_type_name("int64", il_type(value, "mscorlib",
qualified(unqualified("System"), "Int64"))).
parse_special_il_type_name("natural int", il_type(value, "mscorlib",
qualified(unqualified("System"), "IntPtr"))).
parse_special_il_type_name("native int", il_type(value, "mscorlib",
qualified(unqualified("System"), "IntPtr"))).
parse_special_il_type_name("natural unsigned int", il_type(value, "mscorlib",
qualified(unqualified("System"), "UIntPtr"))).
parse_special_il_type_name("native unsigned int", il_type(value, "mscorlib",
qualified(unqualified("System"), "UIntPtr"))).
parse_special_il_type_name("refany", il_type(value, "mscorlib",
qualified(unqualified("System"), "TypedReference"))).
parse_special_il_type_name("typedref", il_type(value, "mscorlib",
qualified(unqualified("System"), "TypedReference"))).
parse_special_il_type_name("unsigned int8", il_type(value, "mscorlib",
qualified(unqualified("System"), "Byte"))).
parse_special_il_type_name("unsigned int16", il_type(value, "mscorlib",
qualified(unqualified("System"), "UInt16"))).
parse_special_il_type_name("unsigned int32", il_type(value, "mscorlib",
qualified(unqualified("System"), "UInt32"))).
parse_special_il_type_name("unsigned int64", il_type(value, "mscorlib",
qualified(unqualified("System"), "UInt64"))).
:- pred parse_maybe_foreign_type_assertions(maybe(term)::in,
list(foreign_type_assertion)::out) is semidet.
parse_maybe_foreign_type_assertions(no, []).
parse_maybe_foreign_type_assertions(yes(Term), Assertions) :-
parse_foreign_type_assertions(Term, Assertions).
:- pred parse_foreign_type_assertions(term::in,
list(foreign_type_assertion)::out) is semidet.
parse_foreign_type_assertions(Term, Assertions) :-
( Term = term.functor(term.atom("[]"), [], _) ->
Assertions = []
;
Term = term.functor(term.atom("[|]"), [Head, Tail], _),
parse_foreign_type_assertion(Head, HeadAssertion),
parse_foreign_type_assertions(Tail, TailAssertions),
Assertions = [HeadAssertion | TailAssertions]
).
:- 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.
parse_foreign_type_assertion(Term, Assertion) :-
Term = term.functor(term.atom(Constant), [], _),
Constant = "stable",
Assertion = foreign_type_stable.
% This predicate parses both c_header_code and foreign_decl pragmas.
%
:- pred parse_pragma_foreign_decl_pragma(module_name::in, string::in,
list(term)::in, term::in, varset::in, prog_context::in, int::in,
maybe1(item)::out) is det.
parse_pragma_foreign_decl_pragma(_ModuleName, PragmaName, PragmaTerms,
ErrorTerm, VarSet, Context, SeqNum, MaybeItem) :-
InvalidDeclPieces = [words("Error: invalid"),
quote(":- pragma " ++ PragmaName), words("declaration:")],
(
(
PragmaTerms = [LangTerm, HeaderTerm],
IsLocal = foreign_decl_is_exported
;
PragmaTerms = [LangTerm, IsLocalTerm, HeaderTerm],
parse_foreign_decl_is_local(IsLocalTerm, IsLocal)
)
->
( parse_foreign_language(LangTerm, ForeignLanguage) ->
( HeaderTerm = term.functor(term.string(HeaderCode), [], _) ->
Pragma = pragma_foreign_decl(ForeignLanguage, IsLocal,
HeaderCode),
ItemPragma = item_pragma_info(user, Pragma, Context, SeqNum),
Item = item_pragma(ItemPragma),
MaybeItem = ok1(Item)
;
Pieces = InvalidDeclPieces ++
[words("expected string for foreign declaration code."),
nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(HeaderTerm),
[always(Pieces)])]),
MaybeItem = error1([Spec])
)
;
Pieces = InvalidDeclPieces ++
[words("invalid language parameter."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(LangTerm),
[always(Pieces)])]),
MaybeItem = error1([Spec])
)
;
TermStr = describe_error_term(VarSet, ErrorTerm),
Pieces = [words("Error: invalid"), quote(":- pragma " ++ PragmaName),
words("declaration:"), words(TermStr), suffix("."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
MaybeItem = error1([Spec])
).
% This predicate parses both c_code and foreign_code pragmas.
% Processing of foreign_proc (or c_code that defines a procedure)
% is handled in parse_pragma_foreign_proc_pragma below.
%
:- pred parse_pragma_foreign_code_pragma(module_name::in, string::in,
list(term)::in, term::in, varset::in, prog_context::in, int::in,
maybe1(item)::out) is det.
parse_pragma_foreign_code_pragma(_ModuleName, PragmaName, PragmaTerms,
ErrorTerm, _VarSet, Context, SeqNum, MaybeItem) :-
InvalidDeclPrefix = [words("Error: invalid"),
quote(":- pragma " ++ PragmaName), words("declaration:")],
( PragmaTerms = [LangTerm, CodeTerm] ->
( parse_foreign_language(LangTerm, ForeignLanguagePrime) ->
ForeignLanguage = ForeignLanguagePrime,
LangSpecs = []
;
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]
),
( CodeTerm = term.functor(term.string(CodePrime), [], _) ->
Code = CodePrime,
CodeSpecs = []
;
Code = "", % 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 = [],
Pragma = pragma_foreign_code(ForeignLanguage, Code),
ItemPragma = item_pragma_info(user, Pragma, Context, SeqNum),
Item = item_pragma(ItemPragma),
MaybeItem = ok1(Item)
;
Specs = [_ | _],
MaybeItem = error1(Specs)
)
;
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)])]),
MaybeItem = error1([Spec])
).
% This predicate parses both c_code and foreign_proc pragmas.
%
:- pred parse_pragma_foreign_proc_pragma(module_name::in, string::in,
list(term)::in, term::in, varset::in, prog_context::in, int::in,
maybe1(item)::out) is det.
parse_pragma_foreign_proc_pragma(ModuleName, PragmaName, PragmaTerms,
ErrorTerm, VarSet, Context, SeqNum, MaybeItem) :-
InvalidDeclPrefix = [words("Error: invalid"),
quote(":- pragma " ++ PragmaName), words("declaration:")],
(
PragmaTerms = [LangTerm | RestTerms],
( parse_foreign_language(LangTerm, ForeignLanguagePrime) ->
ForeignLanguage = ForeignLanguagePrime,
LangSpecs = []
;
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]
),
(
(
RestTerms = [PredAndVarsTerm, CodeTerm],
parse_pragma_ordinary_foreign_proc_pragma_old(ModuleName,
PragmaName, VarSet, PredAndVarsTerm, CodeTerm, ErrorTerm,
ForeignLanguage, InvalidDeclPrefix, Context, SeqNum,
MaybeRestItem)
;
RestTerms = [PredAndVarsTerm, FlagsTerm, CodeTerm],
parse_pragma_ordinary_foreign_proc_pragma(ModuleName,
PragmaName, VarSet, PredAndVarsTerm, FlagsTerm, CodeTerm,
ForeignLanguage, InvalidDeclPrefix, Context, SeqNum,
MaybeRestItem)
;
RestTerms = [PredAndVarsTerm, FlagsTerm, FieldsTerm,
FirstTerm, LaterTerm],
term.context_init(DummyContext),
SharedTerm = term.functor(term.atom("common_code"),
[term.functor(term.string(""), [], DummyContext)],
DummyContext),
parse_pragma_model_non_foreign_proc_pragma(ModuleName,
PragmaName, VarSet, PredAndVarsTerm, FlagsTerm,
FieldsTerm, FirstTerm, LaterTerm, SharedTerm,
ForeignLanguage, InvalidDeclPrefix, Context, SeqNum,
MaybeRestItem)
;
RestTerms = [PredAndVarsTerm, FlagsTerm, FieldsTerm,
FirstTerm, LaterTerm, SharedTerm],
parse_pragma_model_non_foreign_proc_pragma(ModuleName,
PragmaName, VarSet, PredAndVarsTerm, FlagsTerm,
FieldsTerm, FirstTerm, LaterTerm, SharedTerm,
ForeignLanguage, InvalidDeclPrefix, Context, SeqNum,
MaybeRestItem)
)
->
(
MaybeRestItem = ok1(Item),
(
LangSpecs = [],
MaybeItem = ok1(Item)
;
LangSpecs = [_ | _],
MaybeItem = error1(LangSpecs)
)
;
MaybeRestItem = error1(RestSpecs),
MaybeItem = error1(LangSpecs ++ RestSpecs)
)
;
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)])]),
MaybeItem = error1([Spec])
)
;
PragmaTerms = [],
PragmaTerms = [],
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)])]),
MaybeItem = error1([Spec])
).
:- pred parse_pragma_ordinary_foreign_proc_pragma_old(module_name::in,
string::in, varset::in, term::in, term::in, term::in, foreign_language::in,
list(format_component)::in, prog_context::in, int::in, maybe1(item)::out)
is det.
parse_pragma_ordinary_foreign_proc_pragma_old(ModuleName, PragmaName, VarSet,
PredAndVarsTerm, CodeTerm, ErrorTerm, ForeignLanguage,
InvalidDeclPrefix, Context, SeqNum, MaybeItem) :-
% XXX We should issue a warning; this syntax is deprecated. We will
% continue to accept this if c_code is used, but not with foreign_code.
( PragmaName = "c_code" ->
Attributes0 = default_attributes(ForeignLanguage),
set_legacy_purity_behaviour(yes, Attributes0, Attributes),
( CodeTerm = term.functor(term.string(Code), [], CodeContext) ->
Impl = fc_impl_ordinary(Code, yes(CodeContext)),
parse_pragma_foreign_code(ModuleName, Attributes,
PredAndVarsTerm, Impl, VarSet, Context, SeqNum, MaybeItem)
;
Pieces = InvalidDeclPrefix ++
[words("expecting either"), quote("may_call_mercury"),
words("or"), quote("will_not_call_mercury"), suffix(","),
words("and a string for foreign code."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(CodeTerm), [always(Pieces)])]),
MaybeItem = error1([Spec])
)
;
Pieces = InvalidDeclPrefix ++
[words("does not say whether it can call Mercury."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
MaybeItem = error1([Spec])
).
:- pred parse_pragma_ordinary_foreign_proc_pragma(module_name::in, string::in,
varset::in, term::in, term::in, term::in, foreign_language::in,
list(format_component)::in, prog_context::in, int::in, maybe1(item)::out)
is det.
parse_pragma_ordinary_foreign_proc_pragma(ModuleName, PragmaName, VarSet,
SecondTerm, ThirdTerm, CodeTerm, ForeignLanguage, InvalidDeclPrefix,
Context, SeqNum, MaybeItem) :-
CodeContext = get_term_context(CodeTerm),
( CodeTerm = term.functor(term.string(CodePrime), [], _) ->
Code = CodePrime,
CodeSpecs = []
;
Code = "", % Dummy
CodePieces = InvalidDeclPrefix ++
[words("invalid fourth argument,"),
words("expecting string containing foreign code."), nl],
CodeSpec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(CodeContext, [always(CodePieces)])]),
CodeSpecs = [CodeSpec]
),
ThirdContextPieces =
InvalidDeclPrefix ++ [words("invalid third argument:")],
parse_pragma_foreign_proc_attributes_term(ForeignLanguage, PragmaName,
VarSet, ThirdTerm, ThirdContextPieces, MaybeFlagsThird),
(
MaybeFlagsThird = ok1(Flags),
FlagsSpecs = [],
PredAndVarsTerm = SecondTerm
;
MaybeFlagsThird = error1(_FlagsThirdSpecs),
% We report any errors as appropriate to the preferred syntax.
SecondContextPieces = InvalidDeclPrefix ++
[lower_case_next_if_not_first, words("Invalid second argument:")],
parse_pragma_foreign_proc_attributes_term(ForeignLanguage, PragmaName,
VarSet, SecondTerm, SecondContextPieces, MaybeFlagsSecond),
(
MaybeFlagsSecond = ok1(Flags),
% XXX We should issue a warning; this syntax is deprecated.
% We will continue to accept this if c_code is used,
% but not with foreign_code.
( PragmaName = "c_code" ->
PredAndVarsTerm = ThirdTerm,
FlagsSpecs = []
;
PredAndVarsTerm = ThirdTerm, % Dummy
FlagsPieces = InvalidDeclPrefix ++
[words("invalid second argument,"),
words("expecting predicate or function mode."), nl],
FlagsSpec = error_spec(severity_error,
phase_term_to_parse_tree,
[simple_msg(get_term_context(SecondTerm),
[always(FlagsPieces)])]),
FlagsSpecs = [FlagsSpec]
)
;
MaybeFlagsSecond = error1(FlagsSpecs),
Flags = default_attributes(ForeignLanguage), % Dummy
PredAndVarsTerm = SecondTerm % Dummy
)
),
Specs = CodeSpecs ++ FlagsSpecs,
(
Specs = [],
Impl = fc_impl_ordinary(Code, yes(CodeContext)),
parse_pragma_foreign_code(ModuleName, Flags, PredAndVarsTerm,
Impl, VarSet, Context, SeqNum, MaybeItem)
;
Specs = [_ | _],
MaybeItem = error1(Specs)
).
:- pred parse_pragma_model_non_foreign_proc_pragma(module_name::in, string::in,
varset::in, term::in, term::in, term::in, term::in, term::in,
term::in, foreign_language::in, list(format_component)::in,
prog_context::in, int::in, maybe1(item)::out) is det.
parse_pragma_model_non_foreign_proc_pragma(ModuleName, PragmaName, VarSet,
PredAndVarsTerm, FlagsTerm, FieldsTerm, FirstTerm, LaterTerm,
SharedTerm, ForeignLanguage, InvalidDeclPrefix, Context, SeqNum,
MaybeItem) :-
FlagsContextPieces = InvalidDeclPrefix ++
[lower_case_next_if_not_first, words("Invalid third argument:")],
parse_pragma_foreign_proc_attributes_term(ForeignLanguage, PragmaName,
VarSet, FlagsTerm, FlagsContextPieces, MaybeFlags),
(
MaybeFlags = ok1(Flags),
FlagsSpecs = []
;
MaybeFlags = error1(FlagsSpecs),
Flags = default_attributes(ForeignLanguage) % Dummy
),
(
parse_pragma_keyword("local_vars", FieldsTerm,
FieldsPrime, FieldsContextPrime)
->
Fields = FieldsPrime,
FieldsContext = FieldsContextPrime,
LocalSpecs = []
;
Fields = "", % Dummy
FieldsContext = get_term_context(FieldsTerm),
LocalPieces = InvalidDeclPrefix ++
[words("invalid fourth argument, expecting"),
quote("local_vars(<fields>)"), suffix("."), nl],
LocalSpec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(FieldsContext, [always(LocalPieces)])]),
LocalSpecs = [LocalSpec]
),
(
parse_pragma_keyword("first_code", FirstTerm,
FirstPrime, FirstContextPrime)
->
First = FirstPrime,
FirstContext = FirstContextPrime,
FirstSpecs = []
;
First = "", % Dummy
FirstContext = get_term_context(FirstTerm),
FirstPieces = InvalidDeclPrefix ++
[words("invalid fifth argument, expecting"),
quote("first_code(<code>)"), suffix("."), nl],
FirstSpec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(FirstContext, [always(FirstPieces)])]),
FirstSpecs = [FirstSpec]
),
(
parse_pragma_keyword("retry_code", LaterTerm,
LaterPrime, LaterContextPrime)
->
Later = LaterPrime,
LaterContext = LaterContextPrime,
LaterSpecs = []
;
Later = "", % Dummy
LaterContext = get_term_context(LaterTerm),
LaterPieces = InvalidDeclPrefix ++
[words("invalid sixth argument, expecting"),
quote("retry_code(<code>)"), suffix("."), nl],
LaterSpec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(LaterTerm), [always(LaterPieces)])]),
LaterSpecs = [LaterSpec]
),
(
parse_pragma_keyword("shared_code", SharedTerm,
SharedPrime, SharedContextPrime)
->
Shared = SharedPrime,
SharedContext = SharedContextPrime,
Treatment = shared_code_share,
SharedSpecs = []
;
parse_pragma_keyword("duplicated_code", SharedTerm,
SharedPrime, SharedContextPrime)
->
Shared = SharedPrime,
SharedContext = SharedContextPrime,
Treatment = shared_code_duplicate,
SharedSpecs = []
;
parse_pragma_keyword("common_code", SharedTerm,
SharedPrime, SharedContextPrime)
->
Shared = SharedPrime,
SharedContext = SharedContextPrime,
Treatment = shared_code_automatic,
SharedSpecs = []
;
Shared = "", % Dummy
SharedContext = term.context_init, % Dummy
Treatment = shared_code_automatic, % Dummy
SharedPieces = InvalidDeclPrefix ++
[words("invalid seventh argument, expecting"),
quote("common_code(<code>)"), suffix("."), nl],
SharedSpec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(SharedTerm),
[always(SharedPieces)])]),
SharedSpecs = [SharedSpec]
),
Specs =
FlagsSpecs ++ LocalSpecs ++ FirstSpecs ++ LaterSpecs ++ SharedSpecs,
(
Specs = [],
Impl = fc_impl_model_non(Fields, yes(FieldsContext),
First, yes(FirstContext), Later, yes(LaterContext),
Treatment, Shared, yes(SharedContext)),
parse_pragma_foreign_code(ModuleName, Flags, PredAndVarsTerm,
Impl, VarSet, Context, SeqNum, MaybeItem)
;
Specs = [_ | _],
MaybeItem = error1(Specs)
).
% This parses a pragma that refers to a predicate or function.
%
:- pred parse_simple_pragma(module_name::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)::out) is det.
parse_simple_pragma(ModuleName, PragmaName, MakePragma, PragmaTerms, ErrorTerm,
VarSet, Context, SeqNum, MaybeItem) :-
parse_simple_pragma_base(ModuleName, PragmaName, "predicate or function",
MakePragma, PragmaTerms, ErrorTerm, VarSet, Context, SeqNum,
MaybeItem).
% This parses a pragma that refers to type.
%
:- pred parse_simple_type_pragma(module_name::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)::out) is det.
parse_simple_type_pragma(ModuleName, PragmaName, MakePragma,
PragmaTerms, ErrorTerm, VarSet, Context, SeqNum, MaybeItem) :-
parse_simple_pragma_base(ModuleName, PragmaName, "type", MakePragma,
PragmaTerms, ErrorTerm, VarSet, Context, SeqNum, MaybeItem).
% This parses a pragma that refers to symbol name / arity.
%
:- pred parse_simple_pragma_base(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)::out) is det.
parse_simple_pragma_base(ModuleName, PragmaName, NameKind, MakePragma,
PragmaTerms, ErrorTerm, VarSet, Context, SeqNum, MaybeItem) :-
( PragmaTerms = [PredAndArityTerm] ->
parse_simple_name_and_arity(ModuleName, PragmaName, NameKind,
PredAndArityTerm, PredAndArityTerm, VarSet, MaybeNameAndArity),
(
MaybeNameAndArity = ok2(PredName, Arity),
MakePragma(PredName, Arity, Pragma),
ItemPragma = item_pragma_info(user, Pragma, Context, SeqNum),
Item = item_pragma(ItemPragma),
MaybeItem = ok1(Item)
;
MaybeNameAndArity = error2(Specs),
MaybeItem = error1(Specs)
)
;
Pieces = [words("Error: wrong number of arguments in"),
quote(":- pragma " ++ PragmaName), words("declaration."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
MaybeItem = 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) :-
( parse_name_and_arity(ModuleName, NameAndArityTerm, Name, Arity) ->
MaybeNameAndArity = ok2(Name, Arity)
;
NameAndArityTermStr = describe_error_term(VarSet, NameAndArityTerm),
Pieces = [words("Error: expected"), words(NameKind),
words("name/arity for"), quote(":- pragma " ++ 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])
).
%-----------------------------------------------------------------------------%
:- pred parse_pragma_keyword(string::in, term::in, string::out,
term.context::out) is semidet.
parse_pragma_keyword(ExpectedKeyword, Term, StringArg, StartContext) :-
Term = term.functor(term.atom(ExpectedKeyword), [Arg], _),
Arg = term.functor(term.string(StringArg), [], StartContext).
%-----------------------------------------------------------------------------%
:- 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_max_stack_size(int)
; 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(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_pragma_foreign_proc_attributes_term(foreign_language::in,
string::in, varset::in, term::in, list(format_component)::in,
maybe1(pragma_foreign_proc_attributes)::out) is det.
parse_pragma_foreign_proc_attributes_term(ForeignLanguage, PragmaName, Varset,
Term, ContextPieces, MaybeAttributes) :-
Attributes0 = default_attributes(ForeignLanguage),
( ( PragmaName = "c_code" ; PragmaName = "import" ) ->
set_legacy_purity_behaviour(yes, Attributes0, Attributes1),
set_purity(purity_pure, Attributes1, Attributes2)
;
Attributes2 = Attributes0
),
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(may_call_mm_tabled),
coll_box_policy(native_if_possible) - coll_box_policy(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_term0(Varset, Term, AttrList) ->
(
some [Conflict1, Conflict2] (
list.member(Conflict1 - Conflict2, ConflictingAttributes),
list.member(Conflict1, AttrList),
list.member(Conflict2, AttrList)
)
->
% We could include Conflict1 and Conflict2 in the message,
% but the conflict is usually very obvious even without this.
Pieces = ContextPieces ++ [lower_case_next_if_not_first,
words("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])
;
list.foldl(process_attribute, AttrList, Attributes2, Attributes),
MaybeAttributes = check_required_attributes(ForeignLanguage,
Attributes, ContextPieces, Term)
)
;
% XXX We should say we are expecting just a list.
Pieces = ContextPieces ++ [lower_case_next_if_not_first,
words("Expecting a foreign proc attribute"),
words("or list of attributes."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(Term), [always(Pieces)])]),
MaybeAttributes = error1([Spec])
).
% 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_max_stack_size(Size), !Attrs) :-
add_extra_attribute(max_stack_size(Size), !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, list(format_component), term)
= maybe1(pragma_foreign_proc_attributes).
check_required_attributes(lang_c, Attrs, _CP, _Term) = ok1(Attrs).
check_required_attributes(lang_csharp, Attrs, _CP, _Term) = ok1(Attrs).
check_required_attributes(lang_il, Attrs, ContextPieces, Term) =
MaybeAttributes :-
MaxStackAttrs = list.filter_map(
(func(X) = X is semidet :-
X = max_stack_size(_)),
get_extra_attributes(Attrs)),
(
MaxStackAttrs = [],
Pieces = ContextPieces ++ [lower_case_next_if_not_first,
words("Error: expecting max_stack_size attribute for IL code."),
nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(Term), [always(Pieces)])]),
MaybeAttributes = error1([Spec])
;
MaxStackAttrs = [_ | _],
MaybeAttributes = ok1(Attrs)
).
check_required_attributes(lang_java, Attrs, _CP, _Term) = ok1(Attrs).
check_required_attributes(lang_erlang, Attrs, _CP, _Term) = ok1(Attrs).
:- pred parse_pragma_foreign_proc_attributes_term0(varset::in, term::in,
list(collected_pragma_foreign_proc_attribute)::out) is semidet.
parse_pragma_foreign_proc_attributes_term0(Varset, Term, Flags) :-
( parse_single_pragma_foreign_proc_attribute(Varset, Term, Flag) ->
Flags = [Flag]
;
(
Term = term.functor(term.atom("[]"), [], _),
Flags = []
;
Term = term.functor(term.atom("[|]"), [Head, Tail], _),
parse_single_pragma_foreign_proc_attribute(Varset, Head, HeadFlag),
parse_pragma_foreign_proc_attributes_term0(Varset, Tail,
TailFlags),
Flags = [HeadFlag | TailFlags]
)
).
:- 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) :-
( parse_may_call_mercury(Term, MayCallMercury) ->
Flag = coll_may_call_mercury(MayCallMercury)
; parse_threadsafe(Term, ThreadSafe) ->
Flag = coll_thread_safe(ThreadSafe)
; parse_tabled_for_io(Term, TabledForIo) ->
Flag = coll_tabled_for_io(TabledForIo)
; parse_user_annotated_sharing(Varset, Term, UserSharing) ->
Flag = coll_user_annotated_sharing(UserSharing)
; parse_max_stack_size(Term, Size) ->
Flag = coll_max_stack_size(Size)
; parse_backend(Term, Backend) ->
Flag = coll_backend(Backend)
; parse_purity_promise(Term, Purity) ->
Flag = coll_purity(Purity)
; parse_terminates(Term, Terminates) ->
Flag = coll_terminates(Terminates)
; parse_no_exception_promise(Term) ->
Flag = coll_will_not_throw_exception
; parse_ordinary_despite_detism(Term) ->
Flag = coll_ordinary_despite_detism
; parse_may_modify_trail(Term, TrailMod) ->
Flag = coll_may_modify_trail(TrailMod)
; parse_may_call_mm_tabled(Term, CallsTabled) ->
Flag = coll_may_call_mm_tabled(CallsTabled)
; parse_box_policy(Term, BoxPolicy) ->
Flag = coll_box_policy(BoxPolicy)
; parse_affects_liveness(Term, AffectsLiveness) ->
Flag = coll_affects_liveness(AffectsLiveness)
; parse_allocates_memory(Term, AllocatesMemory) ->
Flag = coll_allocates_memory(AllocatesMemory)
; parse_registers_roots(Term, RegistersRoots) ->
Flag = coll_registers_roots(RegistersRoots)
; parse_may_duplicate(Term, MayDuplicate) ->
Flag = coll_may_duplicate(MayDuplicate)
;
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, may_call_mm_tabled::out) is semidet.
parse_may_call_mm_tabled(Term, may_call_mm_tabled) :-
Term = term.functor(term.atom("may_call_mm_tabled"), [], _).
parse_may_call_mm_tabled(Term, 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.functor(term.atom("native_if_possible"), [], _),
native_if_possible).
parse_box_policy(term.functor(term.atom("always_boxed"), [], _),
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_max_stack_size(term::in, int::out) is semidet.
parse_max_stack_size(term.functor(
term.atom("max_stack_size"), [SizeTerm], _), Size) :-
SizeTerm = term.functor(term.integer(Size), [], _).
:- 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 a pragma foreign_code declaration.
%
:- pred parse_pragma_foreign_code(module_name::in,
pragma_foreign_proc_attributes::in, term::in, pragma_foreign_code_impl::in,
varset::in, prog_context::in, int::in, maybe1(item)::out) is det.
parse_pragma_foreign_code(ModuleName, Flags, PredAndVarsTerm0,
PragmaImpl, VarSet, Context, SeqNum, MaybeItem) :-
ContextPieces = [words("In"), quote(":- pragma c_code"),
words("declaration:")],
parse_pred_or_func_and_args_general(yes(ModuleName), PredAndVarsTerm0,
PredAndVarsTerm0, VarSet, ContextPieces, MaybePredAndArgs),
(
MaybePredAndArgs = ok2(PredName, VarList0 - MaybeRetTerm),
% Is this a function or a predicate?
(
MaybeRetTerm = yes(FuncResultTerm0),
PredOrFunc = pf_function,
VarList = VarList0 ++ [FuncResultTerm0]
;
MaybeRetTerm = no,
PredOrFunc = pf_predicate,
VarList = VarList0
),
parse_pragma_c_code_varlist(VarSet, VarList, MaybePragmaVars),
(
MaybePragmaVars = ok1(PragmaVars),
varset.coerce(VarSet, ProgVarSet),
varset.coerce(VarSet, InstVarSet),
Pragma = pragma_foreign_proc(Flags, PredName, PredOrFunc,
PragmaVars, ProgVarSet, InstVarSet, PragmaImpl),
ItemPragma = item_pragma_info(user, Pragma, Context, SeqNum),
Item = item_pragma(ItemPragma),
MaybeItem = ok1(Item)
;
MaybePragmaVars = error1(Specs),
MaybeItem = error1(Specs)
)
;
MaybePredAndArgs = error2(Specs),
MaybeItem = error1(Specs)
).
% Parse the variable list in the pragma c code declaration.
% The final argument is 'no' for no error, or 'yes(ErrorMessage)'.
%
:- pred parse_pragma_c_code_varlist(varset::in, list(term)::in,
maybe1(list(pragma_var))::out) is det.
parse_pragma_c_code_varlist(_, [], ok1([])).
parse_pragma_c_code_varlist(VarSet, [HeadTerm | TailTerm], MaybePragmaVars):-
(
HeadTerm = term.functor(term.atom("::"), [VarTerm, ModeTerm], _),
VarTerm = term.variable(Var, VarContext)
->
( varset.search_name(VarSet, Var, VarName) ->
( convert_mode(allow_constrained_inst_var, ModeTerm, Mode0) ->
constrain_inst_vars_in_mode(Mode0, Mode),
term.coerce_var(Var, ProgVar),
HeadPragmaVar = pragma_var(ProgVar, VarName, Mode,
native_if_possible),
parse_pragma_c_code_varlist(VarSet, TailTerm,
MaybeTailPragmaVars),
(
MaybeTailPragmaVars = ok1(TailPragmaVars),
MaybePragmaVars = ok1([HeadPragmaVar | TailPragmaVars])
;
MaybeTailPragmaVars = error1(_),
MaybePragmaVars = MaybeTailPragmaVars
)
;
Pieces = [words("Error: unknown mode in pragma c_code."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(ModeTerm),
[always(Pieces)])]),
MaybePragmaVars = error1([Spec])
)
;
% If the variable wasn't in the varset it must be an
% underscore variable.
Pieces = [words("Sorry, not implemented: "),
words("anonymous `_' variable in pragma c_code."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(VarContext, [always(Pieces)])]),
MaybePragmaVars = error1([Spec])
)
;
Pieces = [words("Error: arguments are 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])
).
:- pred parse_tabling_pragma(module_name::in, string::in, eval_method::in,
list(term)::in, term::in, varset::in, prog_context::in, int::in,
maybe1(item)::out) is det.
parse_tabling_pragma(ModuleName, PragmaName, TablingType, PragmaTerms,
ErrorTerm, VarSet, Context, SeqNum, MaybeItem) :-
(
(
PragmaTerms = [PredAndModesTerm0],
MaybeAttrs = no
;
PragmaTerms = [PredAndModesTerm0, AttrListTerm0],
MaybeAttrs = yes(AttrListTerm0)
)
->
ContextPieces = [words("In"), quote(":- pragma " ++ PragmaName),
words("declaration:")],
parse_arity_or_modes(ModuleName, PredAndModesTerm0, ErrorTerm,
VarSet, ContextPieces, MaybeArityOrModes),
(
MaybeArityOrModes = ok1(ArityOrModes),
ArityOrModes = arity_or_modes(PredName, Arity, MaybePredOrFunc,
MaybeModes),
(
MaybeAttrs = no,
Pragma = pragma_tabled(TablingType, PredName, Arity,
MaybePredOrFunc, MaybeModes, no),
ItemPragma = item_pragma_info(user, Pragma, Context, SeqNum),
Item = item_pragma(ItemPragma),
MaybeItem = ok1(Item)
;
MaybeAttrs = yes(AttrsListTerm),
UnrecognizedPieces =
[words("Error: expected tabling attribute."), nl],
convert_maybe_list("tabling attributes", yes(VarSet),
AttrsListTerm,
parse_tabling_attribute(VarSet, TablingType),
UnrecognizedPieces, MaybeAttributeList),
(
MaybeAttributeList = ok1(AttributeList),
update_tabling_attributes(AttributeList,
default_memo_table_attributes, MaybeAttributes),
(
MaybeAttributes = ok1(Attributes),
Pragma = pragma_tabled(TablingType, PredName,
Arity, MaybePredOrFunc, MaybeModes,
yes(Attributes)),
ItemPragma = item_pragma_info(user, Pragma, Context,
SeqNum),
Item = item_pragma(ItemPragma),
MaybeItem = ok1(Item)
;
MaybeAttributes = error1(Specs),
MaybeItem = error1(Specs)
)
;
MaybeAttributeList = error1(Specs),
MaybeItem = error1(Specs)
)
)
;
MaybeArityOrModes = error1(Specs),
MaybeItem = error1(Specs)
)
;
Pieces = [words("Error: wrong number of arguments in"),
quote(":- pragma " ++ PragmaName), words("declaration."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
MaybeItem = 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),
( !.Attributes ^ table_attr_strictness = all_strict ->
!:Attributes = !.Attributes ^ table_attr_strictness := Strictness,
update_tabling_attributes(TermSingleAttrs, !.Attributes,
MaybeAttributes)
;
Pieces = [words("Error: duplicate argument tabling methods"),
words("attribute in"), quote(":- pragma 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),
( !.Attributes ^ table_attr_size_limit = no ->
!:Attributes = !.Attributes ^ table_attr_size_limit := yes(Limit),
update_tabling_attributes(TermSingleAttrs, !.Attributes,
MaybeAttributes)
;
Pieces = [words("Error: duplicate size limits attribute in"),
quote(":- pragma 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,
(
!.Attributes ^ table_attr_statistics = table_dont_gather_statistics
->
!:Attributes = !.Attributes ^ table_attr_statistics
:= table_gather_statistics,
update_tabling_attributes(TermSingleAttrs, !.Attributes,
MaybeAttributes)
;
Pieces = [words("Error: duplicate statistics attribute in"),
quote(":- pragma 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,
( !.Attributes ^ table_attr_allow_reset = table_dont_allow_reset ->
!:Attributes = !.Attributes ^ table_attr_allow_reset
:= table_allow_reset,
update_tabling_attributes(TermSingleAttrs, !.Attributes,
MaybeAttributes)
;
Pieces = [words("Error: duplicate allow_reset attribute in"),
quote(":- pragma 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 = [],
( eval_method_allows_fast_loose(EvalMethod) = yes ->
Attribute = attr_strictness(all_fast_loose),
MaybeContextAttribute = ok1(Context - Attribute)
;
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(
specified(MaybeArgMethods, hidden_arg_value)),
MaybeContextAttribute = ok1(Context - Attribute)
;
MoreArgs = [Arg2],
(
Arg2 = term.functor(
term.atom("hidden_arg_value"), [], _)
->
Attribute = attr_strictness(
specified(MaybeArgMethods, hidden_arg_value)),
MaybeContextAttribute = ok1(Context - Attribute)
;
Arg2 = term.functor(
term.atom("hidden_arg_addr"), [], _)
->
Attribute = attr_strictness(
specified(MaybeArgMethods, hidden_arg_addr)),
MaybeContextAttribute = ok1(Context - Attribute)
;
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 = [Arg],
Arg = term.functor(term.integer(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).
:- type arity_or_modes
---> arity_or_modes(
sym_name,
arity,
maybe(pred_or_func),
maybe(list(mer_mode))
).
:- pred parse_arity_or_modes(module_name::in, term::in, term::in, varset::in,
list(format_component)::in, maybe1(arity_or_modes)::out) is det.
parse_arity_or_modes(ModuleName, PredAndModesTerm0, ErrorTerm, VarSet,
ContextPieces, MaybeArityOrModes) :-
(
% Is this a simple pred/arity pragma.
PredAndModesTerm0 = term.functor(term.atom("/"),
[PredNameTerm, ArityTerm], _)
->
(
% The value of ContextPieces does not matter here since we succeed
% only if it isn't used.
PredNameContextPieces = [],
parse_implicitly_qualified_term(ModuleName, PredNameTerm,
PredAndModesTerm0, VarSet, PredNameContextPieces,
ok2(PredName, [])),
ArityTerm = term.functor(term.integer(Arity), [], _)
->
MaybeArityOrModes = ok1(arity_or_modes(PredName, Arity, no, no))
;
Pieces = 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])
)
;
parse_pred_or_func_and_arg_modes(yes(ModuleName), PredAndModesTerm0,
PredAndModesTerm0, VarSet, ContextPieces, MaybePredAndModes),
(
MaybePredAndModes = ok2(PredName - PredOrFunc, Modes),
list.length(Modes, Arity0),
(
PredOrFunc = pf_function,
Arity = Arity0 - 1
;
PredOrFunc = pf_predicate,
Arity = Arity0
),
ArityOrModes = arity_or_modes(PredName, Arity, yes(PredOrFunc),
yes(Modes)),
MaybeArityOrModes = ok1(ArityOrModes)
;
MaybePredAndModes = error2(Specs),
MaybeArityOrModes = error1(Specs)
)
).
% XXX why not maybe3?
:- type maybe_pred_or_func_modes ==
maybe2(pair(sym_name, pred_or_func), list(mer_mode)).
:- pred parse_pred_or_func_and_arg_modes(maybe(module_name)::in, term::in,
term::in, varset::in, list(format_component)::in,
maybe_pred_or_func_modes::out) is det.
parse_pred_or_func_and_arg_modes(MaybeModuleName, PredAndModesTerm,
ErrorTerm, VarSet, ContextPieces, MaybeNameAndModes) :-
parse_pred_or_func_and_args_general(MaybeModuleName, PredAndModesTerm,
ErrorTerm, VarSet, ContextPieces, MaybePredAndArgs),
(
MaybePredAndArgs = ok2(PredName, ArgModeTerms - MaybeRetModeTerm),
(
convert_mode_list(allow_constrained_inst_var, ArgModeTerms,
ArgModes0)
->
(
MaybeRetModeTerm = yes(RetModeTerm),
(
convert_mode(allow_constrained_inst_var, RetModeTerm,
RetMode)
->
ArgModes1 = ArgModes0 ++ [RetMode],
list.map(constrain_inst_vars_in_mode, ArgModes1, ArgModes),
MaybeNameAndModes = ok2(PredName - pf_function, ArgModes)
;
Pieces = [words("Error in return mode in")] ++
ContextPieces ++ [suffix("."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(ErrorTerm),
[always(Pieces)])]),
MaybeNameAndModes = error2([Spec])
)
;
MaybeRetModeTerm = no,
MaybeNameAndModes = ok2(PredName - pf_predicate, ArgModes0)
)
;
Pieces = [words("Error in arguments modes in")] ++
ContextPieces ++ [suffix("."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
MaybeNameAndModes = error2([Spec])
)
;
MaybePredAndArgs = error2(Specs),
MaybeNameAndModes = error2(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(term::in, int::out) is semidet.
convert_int(Term, Int) :-
Term = term.functor(term.integer(Int), [], _).
:- 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, convert_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 succeded 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),
(
Functor = term.atom("[|]"),
Args = [FirstTerm, RestTerm]
->
( Pred(FirstTerm, FirstElement) ->
convert_list(What, MaybeVarSet, RestTerm, Pred,
UnrecognizedPieces, RestResult),
(
RestResult = ok1(LaterElements),
Result = ok1([FirstElement | LaterElements])
;
RestResult = error1(_),
Result = RestResult
)
;
(
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])
)
;
Functor = term.atom("[]"),
Args = []
->
Result = ok1([])
;
(
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("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),
(
Functor = term.atom("[|]"),
Args = [FirstTerm, RestTerm]
->
( Pred(FirstTerm, ElementResult) ->
(
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)
)
;
(
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])
)
;
Functor = term.atom("[]"),
Args = []
->
Result = ok1([])
;
(
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),
maybe_parse_type(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], _),
VarIdTerm = term.functor(term.integer(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], _),
NumerTerm = term.functor(term.integer(Numer), [], _),
DenomTerm = term.functor(term.integer(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
).
%-----------------------------------------------------------------------------%
:- func this_file = string.
this_file = "prog_io_pragma.m".
%-----------------------------------------------------------------------------%
:- end_module prog_io_pragma.
%-----------------------------------------------------------------------------%
Reference in New Issue View Git Blame Copy Permalink