Files
mercury/compiler/parse_pragma_analysis.m
Julien Fischer ba31ed494b Update and fix copyright notices.
compiler/*.m:
    As above.
2024-12-30 22:16:59 +11:00

973 lines
42 KiB
Mathematica

%---------------------------------------------------------------------------%
% vim: ft=mercury ts=4 sw=4 expandtab
%---------------------------------------------------------------------------%
% Copyright (C) 1996-2011 The University of Melbourne.
% Copyright (C) 2020-2024 The Mercury team.
% This file may only be copied under the terms of the GNU General
% Public License - see the file COPYING in the Mercury distribution.
%---------------------------------------------------------------------------%
%
% File: parse_pragma_analysis.m.
%
% This parses pragmas that record the results of some program analysis,
% though some of them may also be written by hand.
%
%---------------------------------------------------------------------------%
:- module parse_tree.parse_pragma_analysis.
:- interface.
:- import_module mdbcomp.
:- import_module mdbcomp.sym_name.
:- import_module parse_tree.maybe_error.
:- import_module parse_tree.parse_types.
:- import_module parse_tree.prog_data.
:- import_module list.
:- import_module term.
:- import_module varset.
%---------------------------------------------------------------------------%
:- pred parse_pragma_unused_args(module_name::in, varset::in, term::in,
list(term)::in, prog_context::in, item_seq_num::in,
maybe1(item_or_marker)::out) is det.
:- pred parse_pragma_termination_info(module_name::in, varset::in, term::in,
list(term)::in, prog_context::in, item_seq_num::in,
maybe1(item_or_marker)::out) is det.
:- pred parse_pragma_termination2_info(module_name::in, varset::in, term::in,
list(term)::in, prog_context::in, item_seq_num::in,
maybe1(item_or_marker)::out) is det.
:- pred parse_pragma_structure_sharing(module_name::in, varset::in, term::in,
list(term)::in, prog_context::in, item_seq_num::in,
maybe1(item_or_marker)::out) is det.
:- pred parse_pragma_structure_reuse(module_name::in, varset::in, term::in,
list(term)::in, prog_context::in, item_seq_num::in,
maybe1(item_or_marker)::out) is det.
:- pred parse_pragma_exceptions(module_name::in, varset::in, term::in,
list(term)::in, prog_context::in, item_seq_num::in,
maybe1(item_or_marker)::out) is det.
:- pred parse_pragma_trailing_info(module_name::in, varset::in, term::in,
list(term)::in, prog_context::in, item_seq_num::in,
maybe1(item_or_marker)::out) is det.
:- pred parse_pragma_mm_tabling_info(module_name::in, varset::in, term::in,
list(term)::in, prog_context::in, item_seq_num::in,
maybe1(item_or_marker)::out) is det.
%---------------------------------------------------------------------------%
%---------------------------------------------------------------------------%
:- implementation.
:- import_module libs.
:- import_module libs.rat.
:- import_module mdbcomp.prim_data.
:- import_module parse_tree.error_spec.
:- import_module parse_tree.parse_sym_name.
:- import_module parse_tree.parse_tree_out_term.
:- import_module parse_tree.parse_type_name.
:- import_module parse_tree.parse_util.
:- import_module parse_tree.prog_ctgc.
:- import_module parse_tree.prog_data_pragma.
:- import_module parse_tree.prog_item.
:- import_module bool.
:- import_module cord.
:- import_module maybe.
:- import_module term_int.
:- import_module term_vars.
:- import_module unit.
%---------------------------------------------------------------------------%
parse_pragma_unused_args(ModuleName, VarSet, ErrorTerm, PragmaTerms,
Context, SeqNum, MaybeIOM) :-
% pragma unused_args should never appear in user programs,
% only in .opt files.
(
PragmaTerms = [PredOrFuncTerm, PredNameTerm, ArityTerm, ModeNumTerm,
UnusedArgsTerm],
PredNameContextPieces = cord.from_list(
[words("In the second argument of"),
pragma_decl("unused_args"), words("declaration:"), nl]),
parse_predicate_or_function(VarSet, PredOrFuncTerm, MaybePredOrFunc),
parse_implicitly_qualified_sym_name_and_no_args(ModuleName,
VarSet, PredNameContextPieces, PredNameTerm, MaybePredName),
ArityContextPieces = cord.from_list(
[words("In the third argument of"),
pragma_decl("unused_args"), words("declaration:"), nl]),
parse_decimal_int(ArityContextPieces, VarSet, ArityTerm, MaybeArity),
ModeNumContextPieces = cord.from_list(
[words("In the fourth argument of"),
pragma_decl("unused_args"), words("declaration:"), nl]),
parse_decimal_int(ModeNumContextPieces, VarSet, ModeNumTerm,
MaybeModeNum),
UnusedArgsContextPieces = cord.from_list(
[words("In the fifth argument of"),
pragma_decl("unused_args"), words("declaration:"), nl]),
parse_list_elements(cord.init, "list of integers",
parse_decimal_int(UnusedArgsContextPieces),
VarSet, UnusedArgsTerm, MaybeUnusedArgs),
( if
MaybePredOrFunc = ok1(PredOrFunc),
MaybePredName = ok1(PredName),
MaybeArity = ok1(Arity),
MaybeModeNum = ok1(ModeNum),
MaybeUnusedArgs = ok1(UnusedArgs)
then
PredNameArityPFMn = proc_pf_name_arity_mn(PredOrFunc,
PredName, user_arity(Arity), ModeNum),
Pragma = gen_pragma_unused_args_info(PredNameArityPFMn,
UnusedArgs, Context, SeqNum),
Item = item_generated_pragma( gen_pragma_unused_args(Pragma)),
MaybeIOM = ok1(iom_item(Item))
else
Specs =
get_any_errors1(MaybePredOrFunc) ++
get_any_errors1(MaybePredName) ++
get_any_errors1(MaybeArity) ++
get_any_errors1(MaybeModeNum) ++
get_any_errors1(MaybeUnusedArgs),
MaybeIOM = error1(Specs)
)
;
( PragmaTerms = []
; PragmaTerms = [_]
; PragmaTerms = [_, _]
; PragmaTerms = [_, _, _]
; PragmaTerms = [_, _, _, _]
; PragmaTerms = [_, _, _, _, _, _ | _]
),
Pieces = [words("Error: an"), pragma_decl("unused_args"),
words("declaration must have five arguments."), nl],
Spec = spec($pred, severity_error, phase_t2pt,
get_term_context(ErrorTerm), Pieces),
MaybeIOM = error1([Spec])
).
%---------------------------------------------------------------------------%
parse_pragma_termination_info(ModuleName, VarSet, ErrorTerm, PragmaTerms,
Context, SeqNum, MaybeIOM) :-
(
PragmaTerms = [PredAndModesTerm0, ArgSizeTerm, TerminationTerm],
PAMContextPieces = cord.from_list([words("In the first argument of"),
pragma_decl("termination_info"), words("declaration:"), nl]),
parse_pred_or_func_and_arg_modes(yes(ModuleName), PAMContextPieces,
VarSet, PredAndModesTerm0, MaybeNameAndModes),
( if
ArgSizeTerm = term.functor(term.atom(ArgSizeFunctor),
ArgSizeArgTerms, _),
( ArgSizeFunctor = "not_set"
; ArgSizeFunctor = "infinite"
; ArgSizeFunctor = "finite"
)
then
ArgSizeContextPieces = cord.from_list(
[words("In the second argument of"),
pragma_decl("termination_info"), words("declaration:"), nl]),
(
ArgSizeFunctor = "not_set",
(
ArgSizeArgTerms = [],
MaybeArgSizeInfo0 = no,
MaybeMaybeArgSizeInfo = ok1(MaybeArgSizeInfo0)
;
ArgSizeArgTerms = [_ | _],
NotSetPieces = cord.list(ArgSizeContextPieces) ++
[words("error:"), quote("not_set"),
words("must have no arguments."), nl],
NotSetSpec = spec($pred, severity_error, phase_t2pt,
get_term_context(ArgSizeTerm), NotSetPieces),
MaybeMaybeArgSizeInfo = error1([NotSetSpec])
)
;
ArgSizeFunctor = "infinite",
(
ArgSizeArgTerms = [],
MaybeArgSizeInfo0 = yes(infinite(unit)),
MaybeMaybeArgSizeInfo = ok1(MaybeArgSizeInfo0)
;
ArgSizeArgTerms = [_ | _],
InfinitePieces = cord.list(ArgSizeContextPieces) ++
[words("error:"), quote("infinite"),
words("must have no arguments."), nl],
InfiniteSpec = spec($pred, severity_error, phase_t2pt,
get_term_context(ArgSizeTerm), InfinitePieces),
MaybeMaybeArgSizeInfo = error1([InfiniteSpec])
)
;
ArgSizeFunctor = "finite",
(
ArgSizeArgTerms = [IntTerm, UsedArgsTerm],
IntContextPieces = ArgSizeContextPieces ++
cord.from_list([words("in the first argument:"), nl]),
parse_decimal_int(IntContextPieces, VarSet, IntTerm,
MaybeInt),
BoolContextPieces = ArgSizeContextPieces ++
cord.from_list([words("in the second argument:"), nl]),
parse_list_elements(cord.init, "list of booleans",
parse_bool(BoolContextPieces),
VarSet, UsedArgsTerm, MaybeUsedArgs),
( if
MaybeInt = ok1(Int),
MaybeUsedArgs = ok1(UsedArgs)
then
MaybeArgSizeInfo0 = yes(finite(Int, UsedArgs)),
MaybeMaybeArgSizeInfo = ok1(MaybeArgSizeInfo0)
else
FiniteSpecs = get_any_errors1(MaybeInt) ++
get_any_errors1(MaybeUsedArgs),
MaybeMaybeArgSizeInfo = error1(FiniteSpecs)
)
;
( ArgSizeArgTerms = []
; ArgSizeArgTerms = [_]
; ArgSizeArgTerms = [_, _, _ | _]
),
FinitePieces =
[words("Error: in the second argument of"),
pragma_decl("termination_info"),
words("declaration:"), nl,
quote("finite"),
words("must have two arguments."), nl],
FiniteSpec = spec($pred, severity_error, phase_t2pt,
get_term_context(ArgSizeTerm), FinitePieces),
MaybeMaybeArgSizeInfo = error1([FiniteSpec])
)
)
else
ArgSizeTermStr = describe_error_term(VarSet, ArgSizeTerm),
ArgSizePieces = [words("In the second argument of"),
pragma_decl("termination_info"), words("declaration:"), nl,
words("error: expected one of"),
quote("not_set"), suffix(","),
quote("infinite"), suffix(","), words("and"),
quote("finite(N, <used_args>)"), suffix(","),
words("got"), quote(ArgSizeTermStr), suffix("."), nl],
ArgSizeSpec = spec($pred, severity_error, phase_t2pt,
get_term_context(ArgSizeTerm), ArgSizePieces),
MaybeMaybeArgSizeInfo = error1([ArgSizeSpec])
),
TIContextPieces = [words("In the third argument of"),
pragma_decl("termination_info"), words("declaration:"), nl],
parse_termination_info(TIContextPieces, VarSet, TerminationTerm,
MaybeMaybeTerminationInfo),
( if
MaybeNameAndModes = ok3(PredName, PredOrFunc, Modes),
MaybeMaybeArgSizeInfo = ok1(MaybeArgSizeInfo),
MaybeMaybeTerminationInfo = ok1(MaybeTerminationInfo)
then
PredNameModesPF = proc_pf_name_modes(PredOrFunc, PredName, Modes),
Term = decl_pragma_termination_info(PredNameModesPF,
MaybeArgSizeInfo, MaybeTerminationInfo, Context, SeqNum),
Item = item_decl_pragma(decl_pragma_termination(Term)),
MaybeIOM = ok1(iom_item(Item))
else
Specs = get_any_errors3(MaybeNameAndModes) ++
get_any_errors1(MaybeMaybeArgSizeInfo) ++
get_any_errors1(MaybeMaybeTerminationInfo),
MaybeIOM = error1(Specs)
)
;
( PragmaTerms = []
; PragmaTerms = [_]
; PragmaTerms = [_, _]
; PragmaTerms = [_, _, _, _ | _]
),
Pieces = [words("Error: a"), pragma_decl("termination_info"),
words("declaration must have three arguments."), nl],
Spec = spec($pred, severity_error, phase_t2pt,
get_term_context(ErrorTerm), Pieces),
MaybeIOM = error1([Spec])
).
:- pred parse_bool(cord(format_piece)::in, varset::in, term::in,
maybe1(bool)::out) is det.
parse_bool(ContextPieces, VarSet, Term, MaybeBool) :-
( if
Term = term.functor(term.atom(Name), [], _),
( Name = "yes", Bool = yes
; Name = "no", Bool = no
)
then
MaybeBool = ok1(Bool)
else
TermStr = describe_error_term(VarSet, Term),
Pieces = cord.list(ContextPieces) ++ [lower_case_next_if_not_first,
words("Error: expected a boolean (yes or no),"),
words("got"), quote(TermStr), suffix("."), nl],
Spec = spec($pred, severity_error, phase_t2pt,
get_term_context(Term), Pieces),
MaybeBool = error1([Spec])
).
%---------------------------------------------------------------------------%
parse_pragma_termination2_info(ModuleName, VarSet, ErrorTerm, PragmaTerms,
Context, SeqNum, MaybeIOM) :-
(
PragmaTerms = [PredAndModesTerm0, SuccessArgSizeTerm,
FailureArgSizeTerm, TerminationTerm],
PAMContextPieces = cord.from_list([words("In the first argument of"),
pragma_decl("termination2_info"), words("declaration:"), nl]),
parse_pred_or_func_and_arg_modes(yes(ModuleName), PAMContextPieces,
VarSet, PredAndModesTerm0, MaybeNameAndModes),
parse_arg_size_constraints(VarSet, SuccessArgSizeTerm,
MaybeSuccessArgSize),
parse_arg_size_constraints(VarSet, FailureArgSizeTerm,
MaybeFailureArgSize),
TIContextPieces = [words("In the fourth argument of"),
pragma_decl("termination2_info"), words("declaration:"), nl],
parse_termination_info(TIContextPieces, VarSet, TerminationTerm,
MaybeMaybeTerminationInfo),
( if
MaybeNameAndModes = ok3(PredName, PredOrFunc, Modes),
MaybeSuccessArgSize = ok1(SuccessArgSizeInfo),
MaybeFailureArgSize = ok1(FailureArgSizeInfo),
MaybeMaybeTerminationInfo = ok1(MaybeTerminationInfo)
then
PredNameModesPF = proc_pf_name_modes(PredOrFunc, PredName, Modes),
Term2 = decl_pragma_termination2_info(PredNameModesPF,
SuccessArgSizeInfo, FailureArgSizeInfo, MaybeTerminationInfo,
Context, SeqNum),
Item = item_decl_pragma(decl_pragma_termination2(Term2)),
MaybeIOM = ok1(iom_item(Item))
else
Specs = get_any_errors3(MaybeNameAndModes) ++
get_any_errors1(MaybeSuccessArgSize) ++
get_any_errors1(MaybeFailureArgSize) ++
get_any_errors1(MaybeMaybeTerminationInfo),
MaybeIOM = error1(Specs)
)
;
( PragmaTerms = []
; PragmaTerms = [_]
; PragmaTerms = [_, _]
; PragmaTerms = [_, _, _]
; PragmaTerms = [_, _, _, _, _ | _]
),
Pieces = [words("Error: a"), pragma_decl("termination2_info"),
words("declaration must have four arguments."), nl],
Spec = spec($pred, severity_error, phase_t2pt,
get_term_context(ErrorTerm), Pieces),
MaybeIOM = error1([Spec])
).
:- pred parse_termination_info(list(format_piece)::in, varset::in,
term::in, maybe1(maybe(pragma_termination_info))::out) is det.
parse_termination_info(ContextPieces, VarSet, Term,
MaybeMaybeTerminationInfo) :-
( if
Term = term.functor(term.atom(Functor), [], _),
(
Functor = "not_set",
MaybeTerminationInfo = no
;
Functor = "can_loop",
MaybeTerminationInfo = yes(can_loop(unit))
;
Functor = "cannot_loop",
MaybeTerminationInfo = yes(cannot_loop(unit))
)
then
MaybeMaybeTerminationInfo = ok1(MaybeTerminationInfo)
else
TermStr = describe_error_term(VarSet, Term),
Pieces = ContextPieces ++
[lower_case_next_if_not_first, words("Error: expected one of"),
quote("not_set"), suffix(","),
quote("can_loop"), suffix(","), words("and"),
quote("cannot_loop"), suffix(","),
words("got"), quote(TermStr), suffix("."), nl],
Spec = spec($pred, severity_error, phase_t2pt,
get_term_context(Term), Pieces),
MaybeMaybeTerminationInfo = error1([Spec])
).
:- pred parse_arg_size_constraints(varset::in, term::in,
maybe1(maybe(list(arg_size_constr)))::out) is det.
parse_arg_size_constraints(VarSet, Term, MaybeMaybeArgSizeConstraints) :-
( if
Term = term.functor(term.atom("not_set"), [], _)
then
MaybeMaybeArgSizeConstraints = ok1(no)
else if
Term = term.functor(term.atom("constraints"), [ConstraintsTerm], _)
then
parse_list_elements(cord.init, "list of argument size constraints",
parse_arg_size_constraint, VarSet, ConstraintsTerm,
MaybeConstraints),
(
MaybeConstraints = ok1(Constraints),
MaybeMaybeArgSizeConstraints = ok1(yes(Constraints))
;
MaybeConstraints = error1(Specs),
MaybeMaybeArgSizeConstraints = error1(Specs)
)
else
TermStr = describe_error_term(VarSet, Term),
Pieces = [words("Error: expected a description of"),
words("argument size constraints,"),
words("got"), quote(TermStr), suffix("."), nl],
Spec = spec($pred, severity_error, phase_t2pt,
get_term_context(Term), Pieces),
MaybeMaybeArgSizeConstraints = error1([Spec])
).
:- pred parse_arg_size_constraint(varset::in, term::in,
maybe1(arg_size_constr)::out) is det.
parse_arg_size_constraint(VarSet, Term, MaybeConstr) :-
( if
Term = term.functor(term.atom(Functor), [Terms, ConstantTerm], _),
( Functor = "le"
; Functor = "eq"
)
then
parse_list_elements(cord.init, "list of linear terms", parse_lp_term,
VarSet, Terms, LPTermsResult),
parse_rational(VarSet, ConstantTerm, ConstantResult),
( if
LPTermsResult = ok1(LPTerms),
ConstantResult = ok1(Constant)
then
(
Functor = "le",
Constr = le(LPTerms, Constant)
;
Functor = "eq",
Constr = eq(LPTerms, Constant)
),
MaybeConstr = ok1(Constr)
else
Specs = get_any_errors1(LPTermsResult) ++
get_any_errors1(ConstantResult),
MaybeConstr = error1(Specs)
)
else
TermStr = describe_error_term(VarSet, Term),
Pieces = [words("Error: expected an argument size constraint,"),
words("got"), quote(TermStr), suffix("."), nl],
Spec = spec($pred, severity_error, phase_t2pt,
get_term_context(Term), Pieces),
MaybeConstr = error1([Spec])
).
:- pred parse_lp_term(varset::in, term::in, maybe1(arg_size_term)::out) is det.
parse_lp_term(VarSet, Term, MaybeLpTerm) :-
( if
Term = term.functor(term.atom("term"), [VarIdTerm, CoeffTerm], _)
then
( if term_int.decimal_term_to_int(VarIdTerm, VarId0) then
MaybeVarId = ok1(VarId0)
else
VarIdTermStr = describe_error_term(VarSet, VarIdTerm),
Pieces = [words("Error: expected an integer,"),
words("got"), quote(VarIdTermStr), suffix("."), nl],
Spec = spec($pred, severity_error, phase_t2pt,
get_term_context(VarIdTerm), Pieces),
MaybeVarId = error1([Spec])
),
parse_rational(VarSet, CoeffTerm, MaybeCoeff),
( if
MaybeVarId = ok1(VarId),
MaybeCoeff = ok1(Coeff)
then
LpTerm = arg_size_term(VarId, Coeff),
MaybeLpTerm = ok1(LpTerm)
else
Specs = get_any_errors1(MaybeVarId) ++
get_any_errors1(MaybeCoeff),
MaybeLpTerm = error1(Specs)
)
else
TermStr = describe_error_term(VarSet, Term),
Pieces = [words("Error: expected a linear term of the form"),
quote("term(<varnum>, <rational_coeff>)"), suffix(","),
words("got"), quote(TermStr), suffix("."), nl],
Spec = spec($pred, severity_error, phase_t2pt,
get_term_context(Term), Pieces),
MaybeLpTerm = error1([Spec])
).
:- pred parse_rational(varset::in, term::in, maybe1(rat)::out) is det.
parse_rational(VarSet, Term, MaybeRational) :-
( if
Term = term.functor(term.atom("r"), [NumerTerm, DenomTerm], _),
term_int.decimal_term_to_int(NumerTerm, Numer),
term_int.decimal_term_to_int(DenomTerm, Denom)
then
Rational = rat.rat(Numer, Denom),
MaybeRational = ok1(Rational)
else
TermStr = describe_error_term(VarSet, Term),
Pieces = [words("Error: expected a rational number of the form"),
quote("r(N, M)"), suffix(","),
words("got"), quote(TermStr), suffix("."), nl],
Spec = spec($pred, severity_error, phase_t2pt,
get_term_context(Term), Pieces),
MaybeRational = error1([Spec])
).
%---------------------------------------------------------------------------%
parse_pragma_structure_sharing(ModuleName, VarSet, ErrorTerm, PragmaTerms,
Context, SeqNum, MaybeIOM) :-
( if
PragmaTerms = [PredAndModesTerm0, HeadVarsTerm,
HeadVarTypesTerm, SharingInformationTerm],
ModesContextPieces = cord.from_list([words("In"),
pragma_decl("structure_sharing"), words("declaration:"), nl]),
parse_pred_or_func_and_arg_modes(yes(ModuleName), ModesContextPieces,
VarSet, PredAndModesTerm0, MaybeNameAndModes),
MaybeNameAndModes = ok3(PredName, PredOrFunc, Modes),
% Parse the head variables:
HeadVarsTerm = term.functor(term.atom("vars"), ListHVTerms, _),
term_vars.vars_in_terms(ListHVTerms, HeadVarsGeneric),
list.map(term.coerce_var, HeadVarsGeneric, HeadVars),
% Parse the types:
HeadVarTypesTerm = term.functor(term.atom("types"), ListTypeTerms, _),
maybe_parse_types(no_allow_ho_inst_info(wnhii_pragma_struct_sharing),
ListTypeTerms, Types),
% Parse the actual structure sharing information.
SharingInformationTerm = term.functor(term.atom(SharingFunctor),
SharingArgTerms, _),
(
SharingFunctor = "not_available",
% XXX Why don't we test SharingArgTerms?
MaybeSharingAs = no
;
SharingFunctor = "yes",
SharingArgTerms = [SharingAsTerm],
MaybeSharingAs = yes(parse_structure_sharing_domain(SharingAsTerm))
)
then
PredNameModesPF = proc_pf_name_modes(PredOrFunc, PredName, Modes),
varset.coerce(VarSet, ProgVarSet),
varset.coerce(VarSet, TVarSet),
Sharing = decl_pragma_struct_sharing_info(PredNameModesPF, HeadVars,
Types, ProgVarSet, TVarSet, MaybeSharingAs, Context, SeqNum),
Item = item_decl_pragma(decl_pragma_struct_sharing(Sharing)),
MaybeIOM = ok1(iom_item(Item))
else
Pieces = [words("Syntax error in"),
pragma_decl("structure_sharing"), words("declaration."), nl],
Spec = spec($pred, severity_error, phase_t2pt,
get_term_context(ErrorTerm), Pieces),
MaybeIOM = error1([Spec])
).
%---------------------------------------------------------------------------%
parse_pragma_structure_reuse(ModuleName, VarSet, ErrorTerm, PragmaTerms,
Context, SeqNum, MaybeIOM) :-
( if
PragmaTerms = [PredAndModesTerm0, HeadVarsTerm,
HeadVarTypesTerm, MaybeStructureReuseTerm],
ReuseContextPieces = cord.from_list([words("In"),
pragma_decl("structure_reuse"), words("declaration:"), nl]),
parse_pred_or_func_and_arg_modes(yes(ModuleName), ReuseContextPieces,
VarSet, PredAndModesTerm0, MaybeNameAndModes),
MaybeNameAndModes = ok3(PredName, PredOrFunc, Modes),
% Parse the head variables:
HeadVarsTerm = term.functor(term.atom("vars"), ListHVTerms, _),
term_vars.vars_in_terms(ListHVTerms, HeadVarsGeneric),
list.map(term.coerce_var, HeadVarsGeneric, HeadVars),
% Parse the types:
HeadVarTypesTerm = term.functor(term.atom("types"), ListTypeTerms, _),
maybe_parse_types(no_allow_ho_inst_info(wnhii_pragma_struct_reuse),
ListTypeTerms, Types),
% Parse the actual structure reuse information.
MaybeStructureReuseTerm = term.functor(term.atom(ReuseFunctor),
ReuseArgTerms, _),
(
ReuseFunctor = "not_available",
% XXX Why don't we test ReuseArgTerms?
MaybeStructureReuse = no
;
ReuseFunctor = "yes",
ReuseArgTerms = [StructureReuseTerm],
StructureReuse = parse_structure_reuse_domain(StructureReuseTerm),
MaybeStructureReuse = yes(StructureReuse)
)
then
PredNameModesPF = proc_pf_name_modes(PredOrFunc, PredName, Modes),
varset.coerce(VarSet, ProgVarSet),
varset.coerce(VarSet, TVarSet),
Reuse = decl_pragma_struct_reuse_info(PredNameModesPF, HeadVars, Types,
ProgVarSet, TVarSet, MaybeStructureReuse, Context, SeqNum),
Item = item_decl_pragma(decl_pragma_struct_reuse(Reuse)),
MaybeIOM = ok1(iom_item(Item))
else
Pieces = [words("Syntax error in"),
pragma_decl("structure_reuse"), words("declaration."), nl],
Spec = spec($pred, severity_error, phase_t2pt,
get_term_context(ErrorTerm), Pieces),
MaybeIOM = error1([Spec])
).
%---------------------------------------------------------------------------%
parse_pragma_exceptions(ModuleName, VarSet, ErrorTerm, PragmaTerms,
Context, SeqNum, MaybeIOM) :-
(
PragmaTerms = [PredOrFuncTerm, PredNameTerm, ArityTerm, ModeNumTerm,
ThrowStatusTerm],
parse_predicate_or_function(VarSet, PredOrFuncTerm, MaybePredOrFunc),
PNContextPieces = cord.from_list(
[words("In the second argument of"), pragma_decl("exceptions"),
words("declaration:"), nl]),
parse_implicitly_qualified_sym_name_and_no_args(ModuleName,
VarSet, PNContextPieces, PredNameTerm, MaybePredName),
ArityContextPieces = cord.from_list(
[words("In the third argument of an"),
pragma_decl("unused_args"), words("declaration:"), nl]),
parse_decimal_int(ArityContextPieces, VarSet, ArityTerm, MaybeArity),
ModeNumContextPieces = cord.from_list(
[words("In the fourth argument of an"),
pragma_decl("unused_args"), words("declaration:"), nl]),
parse_decimal_int(ModeNumContextPieces, VarSet, ModeNumTerm,
MaybeModeNum),
( if
ThrowStatusTerm = term.functor(term.atom(ThrowStatusFunctor),
ThrowStatusArgTerms, _),
( ThrowStatusFunctor = "will_not_throw"
; ThrowStatusFunctor = "may_throw"
; ThrowStatusFunctor = "conditional"
)
then
(
ThrowStatusFunctor = "will_not_throw",
(
ThrowStatusArgTerms = [],
MaybeThrowStatus = ok1(will_not_throw)
;
ThrowStatusArgTerms = [_ | _],
WillNotThrowPieces =
[words("In the fifth argument of"),
pragma_decl("exceptions"), words("declaration:"), nl,
words("error:"), quote("will_not_throw"),
words("must have no arguments."), nl],
WillNotThrowSpec = spec($pred, severity_error, phase_t2pt,
get_term_context(ThrowStatusTerm), WillNotThrowPieces),
MaybeThrowStatus = error1([WillNotThrowSpec])
)
;
ThrowStatusFunctor = "may_throw",
( if
ThrowStatusArgTerms = [ExceptionTypeTerm],
ExceptionTypeTerm = term.functor(
term.atom(ExceptionFunctor), [], _),
(
ExceptionFunctor = "user_exception",
ExceptionType = user_exception
;
ExceptionFunctor = "type_exception",
ExceptionType = type_exception
)
then
MaybeThrowStatus = ok1(may_throw(ExceptionType))
else
MayThrowPieces =
[words("In the fifth argument of"),
pragma_decl("exceptions"), words("declaration:"), nl,
words("error:"), quote("may_throw"),
words("must have one argument,"),
words("which must be either"),
quote("user_exception"), words("or"),
quote("type_exception"), suffix("."), nl],
MayThrowSpec = spec($pred, severity_error, phase_t2pt,
get_term_context(ThrowStatusTerm), MayThrowPieces),
MaybeThrowStatus = error1([MayThrowSpec])
)
;
ThrowStatusFunctor = "conditional",
(
ThrowStatusArgTerms = [],
MaybeThrowStatus = ok1(throw_conditional)
;
ThrowStatusArgTerms = [_ | _],
ConditionalPieces =
[words("In the fifth argument of"),
pragma_decl("exceptions"), words("declaration:"), nl,
words("error:"), quote("conditional"),
words("must have no arguments."), nl],
ConditionalSpec = spec($pred, severity_error, phase_t2pt,
get_term_context(ThrowStatusTerm), ConditionalPieces),
MaybeThrowStatus = error1([ConditionalSpec])
)
)
else
ThrowStatusTermStr = describe_error_term(VarSet, ThrowStatusTerm),
ThrowStatusPieces = [words("In the fifth argument of"),
pragma_decl("exceptions"), words("declaration:"), nl,
words("error: expected one of"),
quote("will_not_throw"), suffix(","),
quote("may_throw"), suffix(","), words("and"),
quote("conditional"), suffix(","),
words("got"), quote(ThrowStatusTermStr), suffix("."), nl],
ThrowStatusSpec = spec($pred, severity_error, phase_t2pt,
get_term_context(ThrowStatusTerm), ThrowStatusPieces),
MaybeThrowStatus = error1([ThrowStatusSpec])
),
( if
MaybePredOrFunc = ok1(PredOrFunc),
MaybePredName = ok1(PredName),
MaybeArity = ok1(Arity),
MaybeModeNum = ok1(ModeNum),
MaybeThrowStatus = ok1(ThrowStatus)
then
PredNameArityPFMn = proc_pf_name_arity_mn(PredOrFunc,
PredName, user_arity(Arity), ModeNum),
Exceptions = gen_pragma_exceptions_info(PredNameArityPFMn,
ThrowStatus, Context, SeqNum),
Item = item_generated_pragma(gen_pragma_exceptions(Exceptions)),
MaybeIOM = ok1(iom_item(Item))
else
Specs = get_any_errors1(MaybePredOrFunc) ++
get_any_errors1(MaybePredName) ++
get_any_errors1(MaybeArity) ++
get_any_errors1(MaybeModeNum) ++
get_any_errors1(MaybeThrowStatus),
MaybeIOM = error1(Specs)
)
;
( PragmaTerms = []
; PragmaTerms = [_]
; PragmaTerms = [_, _]
; PragmaTerms = [_, _, _]
; PragmaTerms = [_, _, _, _]
; PragmaTerms = [_, _, _, _, _, _ | _]
),
Pieces = [words("Error: an"), pragma_decl("exceptions"),
words("declaration must have five arguments."), nl],
Spec = spec($pred, severity_error, phase_t2pt,
get_term_context(ErrorTerm), Pieces),
MaybeIOM = error1([Spec])
).
%---------------------------------------------------------------------------%
parse_pragma_trailing_info(ModuleName, VarSet, ErrorTerm, PragmaTerms,
Context, SeqNum, MaybeIOM) :-
(
PragmaTerms = [PredOrFuncTerm, PredNameTerm, ArityTerm, ModeNumTerm,
TrailingStatusTerm],
parse_predicate_or_function(VarSet, PredOrFuncTerm, MaybePredOrFunc),
PNContextPieces = cord.from_list(
[words("In the second argument of"), pragma_decl("traling_info"),
words("declaration:"), nl]),
parse_implicitly_qualified_sym_name_and_no_args(ModuleName,
VarSet, PNContextPieces, PredNameTerm, MaybePredName),
ArityContextPieces = cord.from_list(
[words("In the third argument of an"),
pragma_decl("unused_args"), words("declaration:"), nl]),
parse_decimal_int(ArityContextPieces, VarSet, ArityTerm, MaybeArity),
ModeNumContextPieces = cord.from_list(
[words("In the fourth argument of an"),
pragma_decl("unused_args"), words("declaration:"), nl]),
parse_decimal_int(ModeNumContextPieces, VarSet, ModeNumTerm,
MaybeModeNum),
( if
TrailingStatusTerm = term.functor(term.atom(TrailingStatusFunctor),
[], _),
(
TrailingStatusFunctor = "will_not_modify_trail",
TrailingStatus0 = trail_will_not_modify
;
TrailingStatusFunctor = "may_modify_trail",
TrailingStatus0 = trail_may_modify
;
TrailingStatusFunctor = "conditional",
TrailingStatus0 = trail_conditional
)
then
MaybeTrailingStatus = ok1(TrailingStatus0)
else
TrailingStatusTermStr =
describe_error_term(VarSet, TrailingStatusTerm),
TrailingStatusPieces = [words("In the fifth argument of"),
pragma_decl("trailing_info"), words("declaration:"), nl,
words("error: expected one of"),
quote("will_not_modify_trail"), suffix(","),
quote("may_modify_trail"), suffix(","), words("and"),
quote("conditional"), suffix(","),
words("got"), quote(TrailingStatusTermStr), suffix("."), nl],
TrailingStatusSpec = spec($pred, severity_error, phase_t2pt,
get_term_context(TrailingStatusTerm), TrailingStatusPieces),
MaybeTrailingStatus = error1([TrailingStatusSpec])
),
( if
MaybePredOrFunc = ok1(PredOrFunc),
MaybePredName = ok1(PredName),
MaybeArity = ok1(Arity),
MaybeModeNum = ok1(ModeNum),
MaybeTrailingStatus = ok1(TrailingStatus)
then
PredNameArityPFMn = proc_pf_name_arity_mn(PredOrFunc,
PredName, user_arity(Arity), ModeNum),
Trailing = gen_pragma_trailing_info(PredNameArityPFMn,
TrailingStatus, Context, SeqNum),
Item = item_generated_pragma(gen_pragma_trailing(Trailing)),
MaybeIOM = ok1(iom_item(Item))
else
Specs = get_any_errors1(MaybePredOrFunc) ++
get_any_errors1(MaybePredName) ++
get_any_errors1(MaybeArity) ++
get_any_errors1(MaybeModeNum) ++
get_any_errors1(MaybeTrailingStatus),
MaybeIOM = error1(Specs)
)
;
( PragmaTerms = []
; PragmaTerms = [_]
; PragmaTerms = [_, _]
; PragmaTerms = [_, _, _]
; PragmaTerms = [_, _, _, _]
; PragmaTerms = [_, _, _, _, _, _ | _]
),
Pieces = [words("Error:"), pragma_decl("trailing_info"),
words("declaration must have five arguments."), nl],
Spec = spec($pred, severity_error, phase_t2pt,
get_term_context(ErrorTerm), Pieces),
MaybeIOM = error1([Spec])
).
%---------------------------------------------------------------------------%
parse_pragma_mm_tabling_info(ModuleName, VarSet, ErrorTerm, PragmaTerms,
Context, SeqNum, MaybeIOM) :-
(
PragmaTerms = [PredOrFuncTerm, PredNameTerm, ArityTerm, ModeNumTerm,
MMTablingStatusTerm],
parse_predicate_or_function(VarSet, PredOrFuncTerm, MaybePredOrFunc),
PNContextPieces = cord.from_list(
[words("In the second argument of"),
pragma_decl("mm_tabling_info"), words("declaration:"), nl]),
parse_implicitly_qualified_sym_name_and_no_args(ModuleName,
VarSet, PNContextPieces, PredNameTerm, MaybePredName),
ArityContextPieces = cord.from_list(
[words("In the third argument of an"),
pragma_decl("mm_tabling_info"), words("declaration:"), nl]),
parse_decimal_int(ArityContextPieces, VarSet, ArityTerm, MaybeArity),
ModeNumContextPieces = cord.from_list(
[words("In the fourth argument of an"),
pragma_decl("mm_tabling_info"), words("declaration:"), nl]),
parse_decimal_int(ModeNumContextPieces, VarSet, ModeNumTerm,
MaybeModeNum),
( if
MMTablingStatusTerm = term.functor(
term.atom(MMTablingStatusFunctor), [], _),
(
MMTablingStatusFunctor = "mm_tabled_will_not_call",
MMTablingStatus0 = mm_tabled_will_not_call
;
MMTablingStatusFunctor = "mm_tabled_may_call",
MMTablingStatus0 = mm_tabled_may_call
;
MMTablingStatusFunctor = "mm_tabled_conditional",
MMTablingStatus0 = mm_tabled_conditional
)
then
MaybeMMTablingStatus = ok1(MMTablingStatus0)
else
MMTablingStatusTermStr =
describe_error_term(VarSet, MMTablingStatusTerm),
MMTablingStatusPieces = [words("In the fifth argument of"),
pragma_decl("mm_tabling_info"), words("declaration:"), nl,
words("error: expected one of"),
quote("will_not_modify_trail"), suffix(","),
quote("may_modify_trail"), suffix(","), words("and"),
quote("conditional"), suffix(","),
words("got"), quote(MMTablingStatusTermStr), suffix("."), nl],
MMTablingStatusSpec = spec($pred, severity_error, phase_t2pt,
get_term_context(MMTablingStatusTerm), MMTablingStatusPieces),
MaybeMMTablingStatus = error1([MMTablingStatusSpec])
),
( if
MaybePredOrFunc = ok1(PredOrFunc),
MaybePredName = ok1(PredName),
MaybeArity = ok1(Arity),
MaybeModeNum = ok1(ModeNum),
MaybeMMTablingStatus = ok1(MMTablingStatus)
then
PredNameArityPFMn = proc_pf_name_arity_mn(PredOrFunc,
PredName, user_arity(Arity), ModeNum),
Tabling = gen_pragma_mm_tabling_info(PredNameArityPFMn,
MMTablingStatus, Context, SeqNum),
Item = item_generated_pragma(gen_pragma_mm_tabling(Tabling)),
MaybeIOM = ok1(iom_item(Item))
else
Specs = get_any_errors1(MaybePredOrFunc) ++
get_any_errors1(MaybePredName) ++
get_any_errors1(MaybeArity) ++
get_any_errors1(MaybeModeNum) ++
get_any_errors1(MaybeMMTablingStatus),
MaybeIOM = error1(Specs)
)
;
( PragmaTerms = []
; PragmaTerms = [_]
; PragmaTerms = [_, _]
; PragmaTerms = [_, _, _]
; PragmaTerms = [_, _, _, _]
; PragmaTerms = [_, _, _, _, _, _ | _]
),
Pieces = [words("Error: an"), pragma_decl("mm_tabling_info"),
words("declaration must have five arguments."), nl],
Spec = spec($pred, severity_error, phase_t2pt,
get_term_context(ErrorTerm), Pieces),
MaybeIOM = error1([Spec])
).
%---------------------------------------------------------------------------%
:- pred parse_predicate_or_function(varset::in, term::in,
maybe1(pred_or_func)::out) is det.
parse_predicate_or_function(VarSet, Term, MaybePredOrFunc) :-
( if
Term = term.functor(term.atom(Functor), [], _),
(
Functor = "predicate",
PredOrFunc = pf_predicate
;
Functor = "function",
PredOrFunc = pf_function
)
then
MaybePredOrFunc = ok1(PredOrFunc)
else
TermStr = describe_error_term(VarSet, Term),
Pieces = [words("Error: expected either"),
quote("predicate"), words("or"), quote("function"), suffix(","),
words("got"), quote(TermStr), suffix("."), nl],
Spec = spec($pred, severity_error, phase_t2pt,
get_term_context(Term), Pieces),
MaybePredOrFunc = error1([Spec])
).
%---------------------------------------------------------------------------%
:- end_module parse_tree.parse_pragma_analysis.
%---------------------------------------------------------------------------%