mirror of
https://github.com/Mercury-Language/mercury.git
synced 2026-04-16 18:03:36 +00:00
75fd145a0a
compiler/parse_inst_mode_name.m:
When --no-allow-ho-insts-as-modes is used, report an error if a
higher-order function inst is used as a mode, in addition to
higher-order predicate insts.
1019 lines
40 KiB
Mathematica
1019 lines
40 KiB
Mathematica
%---------------------------------------------------------------------------%
|
|
% vim: ft=mercury ts=4 sw=4 et
|
|
%---------------------------------------------------------------------------%
|
|
% Copyright (C) 2016 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.
|
|
%---------------------------------------------------------------------------%
|
|
%
|
|
% This module defines predicates that parse the names of modes, insts
|
|
% and determinisms.
|
|
%
|
|
%---------------------------------------------------------------------------%
|
|
%---------------------------------------------------------------------------%
|
|
|
|
:- module parse_tree.parse_inst_mode_name.
|
|
:- interface.
|
|
|
|
:- import_module parse_tree.error_spec.
|
|
:- import_module parse_tree.maybe_error.
|
|
:- import_module parse_tree.prog_data.
|
|
|
|
:- import_module cord.
|
|
:- import_module list.
|
|
:- import_module term.
|
|
:- import_module varset.
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
:- type allow_constrained_inst_var
|
|
---> allow_constrained_inst_var
|
|
; no_allow_constrained_inst_var(why_no_constrained_inst_var).
|
|
|
|
:- type why_no_constrained_inst_var
|
|
---> wnciv_constraint_rhs
|
|
; wnciv_inst_defn_lhs
|
|
; wnciv_eqv_inst_defn_rhs
|
|
; wnciv_mode_defn_rhs
|
|
; wnciv_type_and_mode
|
|
; wnciv_solver_type_inst
|
|
; wnciv_mutable_inst.
|
|
|
|
:- pred parse_modes(allow_constrained_inst_var::in, varset::in,
|
|
cord(format_piece)::in, list(term)::in, maybe1(list(mer_mode))::out)
|
|
is det.
|
|
:- pred parse_mode(allow_constrained_inst_var::in, varset::in,
|
|
cord(format_piece)::in, term::in, maybe1(mer_mode)::out) is det.
|
|
|
|
:- pred is_known_mode_name(string::in) is semidet.
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
:- pred parse_insts(allow_constrained_inst_var::in, varset::in,
|
|
cord(format_piece)::in, list(term)::in, maybe1(list(mer_inst))::out)
|
|
is det.
|
|
:- pred parse_inst(allow_constrained_inst_var::in, varset::in,
|
|
cord(format_piece)::in, term::in, maybe1(mer_inst)::out) is det.
|
|
|
|
:- pred is_known_inst_name(string::in) is semidet.
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
:- pred parse_determinism(varset::in, term::in,
|
|
maybe1(determinism)::out) is det.
|
|
|
|
:- pred standard_det(string::in, determinism::out) is semidet.
|
|
|
|
%---------------------------------------------------------------------------%
|
|
%---------------------------------------------------------------------------%
|
|
|
|
:- implementation.
|
|
|
|
:- import_module libs.
|
|
:- import_module libs.globals.
|
|
:- import_module mdbcomp.
|
|
:- import_module mdbcomp.builtin_modules.
|
|
:- import_module mdbcomp.prim_data.
|
|
:- import_module mdbcomp.sym_name.
|
|
:- import_module parse_tree.parse_sym_name.
|
|
:- import_module parse_tree.parse_tree_out_term.
|
|
:- import_module parse_tree.parse_util.
|
|
|
|
:- import_module bool.
|
|
:- import_module set.
|
|
:- import_module string.
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
parse_modes(_, _, _, [], ok1([])).
|
|
parse_modes(AllowConstrainedInstVar, VarSet, ContextPieces, [Term | Terms],
|
|
MaybeModes) :-
|
|
% XXX We should pass a ContextPieces updated as the "nth mode in ...".
|
|
parse_mode(AllowConstrainedInstVar, VarSet, ContextPieces,
|
|
Term, MaybeHeadMode),
|
|
parse_modes(AllowConstrainedInstVar, VarSet, ContextPieces,
|
|
Terms, MaybeTailModes),
|
|
( if
|
|
MaybeHeadMode = ok1(HeadMode),
|
|
MaybeTailModes = ok1(TailModes)
|
|
then
|
|
MaybeModes = ok1([HeadMode | TailModes])
|
|
else
|
|
Specs = get_any_errors1(MaybeHeadMode)
|
|
++ get_any_errors1(MaybeTailModes),
|
|
MaybeModes = error1(Specs)
|
|
).
|
|
|
|
parse_mode(AllowConstrainedInstVar, VarSet, ContextPieces, Term, MaybeMode) :-
|
|
(
|
|
Term = term.variable(_, Context),
|
|
TermStr = describe_error_term(VarSet, Term),
|
|
Pieces = cord.list(ContextPieces) ++ [lower_case_next_if_not_first,
|
|
words("Error: a variable such as"), quote(TermStr),
|
|
words("is not a valid mode."), nl],
|
|
Spec = simplest_spec($pred, severity_error, phase_term_to_parse_tree,
|
|
Context, Pieces),
|
|
MaybeMode = error1([Spec])
|
|
;
|
|
Term = term.functor(TermFunctor, ArgTerms0, Context),
|
|
(
|
|
(
|
|
TermFunctor = term.integer(_, _, _, _),
|
|
Name = "an integer"
|
|
;
|
|
TermFunctor = term.float(_),
|
|
Name = "a floating point number"
|
|
;
|
|
TermFunctor = term.string(_),
|
|
Name = "a string"
|
|
;
|
|
TermFunctor = term.implementation_defined(_),
|
|
Name = "an implementation defined literal"
|
|
),
|
|
TermStr = describe_error_term(VarSet, Term),
|
|
Pieces = cord.list(ContextPieces) ++ [lower_case_next_if_not_first,
|
|
words("Error:"), words(Name), words("such as"), quote(TermStr),
|
|
words("cannot be a valid mode."), nl],
|
|
Spec = simplest_spec($pred, severity_error,
|
|
phase_term_to_parse_tree, Context, Pieces),
|
|
MaybeMode = error1([Spec])
|
|
;
|
|
TermFunctor = term.atom(FunctorName),
|
|
% The is_known_mode_name predicate should succeed for exactly
|
|
% the set of functor atoms recognized here.
|
|
( if
|
|
FunctorName = ">>",
|
|
ArgTerms0 = [InstTermA, InstTermB]
|
|
then
|
|
% XXX Should update ContextPieces.
|
|
parse_inst(AllowConstrainedInstVar, VarSet, ContextPieces,
|
|
InstTermA, MaybeInstA),
|
|
parse_inst(AllowConstrainedInstVar, VarSet, ContextPieces,
|
|
InstTermB, MaybeInstB),
|
|
( if
|
|
MaybeInstA = ok1(InstA),
|
|
MaybeInstB = ok1(InstB)
|
|
then
|
|
MaybeMode = ok1(from_to_mode(InstA, InstB))
|
|
else
|
|
Specs = get_any_errors1(MaybeInstA)
|
|
++ get_any_errors1(MaybeInstB),
|
|
MaybeMode = error1(Specs)
|
|
)
|
|
else if
|
|
FunctorName = "is",
|
|
ArgTerms0 = [BeforeIsTerm, DetTerm]
|
|
then
|
|
% XXX Should update ContextPieces.
|
|
parse_higher_order_mode(AllowConstrainedInstVar, VarSet,
|
|
ContextPieces, BeforeIsTerm, DetTerm, MaybeMode)
|
|
else
|
|
parse_sym_name_and_args(VarSet, ContextPieces,
|
|
Term, MaybeFunctor),
|
|
(
|
|
MaybeFunctor = ok2(SymName, ArgTerms),
|
|
% XXX Should update ContextPieces.
|
|
parse_insts(AllowConstrainedInstVar, VarSet, ContextPieces,
|
|
ArgTerms, MaybeArgInsts),
|
|
(
|
|
MaybeArgInsts = ok1(ArgInsts),
|
|
MaybeMode = ok1(user_defined_mode(SymName, ArgInsts))
|
|
;
|
|
MaybeArgInsts = error1(Specs),
|
|
MaybeMode = error1(Specs)
|
|
)
|
|
;
|
|
MaybeFunctor = error2(Specs),
|
|
MaybeMode = error1(Specs)
|
|
)
|
|
)
|
|
)
|
|
).
|
|
|
|
is_known_mode_name(">>").
|
|
is_known_mode_name("is").
|
|
|
|
:- pred parse_higher_order_mode(allow_constrained_inst_var::in, varset::in,
|
|
cord(format_piece)::in, term::in, term::in, maybe1(mer_mode)::out)
|
|
is det.
|
|
|
|
parse_higher_order_mode(AllowConstrainedInstVar, VarSet, ContextPieces,
|
|
BeforeIsTerm, DetTerm, MaybeMode) :-
|
|
( if
|
|
BeforeIsTerm =
|
|
term.functor(term.atom(BeforeIsFunctor), BeforeIsArgTerms, _),
|
|
(
|
|
BeforeIsFunctor = "pred",
|
|
% Handle higher-order predicate modes:
|
|
% a mode of the form
|
|
% pred(<Mode1>, <Mode2>, ...) is <Det>
|
|
% is an abbreviation for the inst mapping
|
|
% ( pred(<Mode1>, <Mode2>, ...) is <Det>
|
|
% -> pred(<Mode1>, <Mode2>, ...) is <Det>
|
|
% )
|
|
IsAny = no
|
|
;
|
|
BeforeIsFunctor = "any_pred",
|
|
% Handle higher-order predicate modes:
|
|
% a mode of the form
|
|
% any_pred(<Mode1>, <Mode2>, ...) is <Det>
|
|
% is an abbreviation for the inst mapping
|
|
% ( any_pred(<Mode1>, <Mode2>, ...) is <Det>
|
|
% -> any_pred(<Mode1>, <Mode2>, ...) is <Det>
|
|
% )
|
|
IsAny = yes
|
|
)
|
|
then
|
|
AllowInstsAsModes = globals.get_allow_ho_insts_as_modes,
|
|
(
|
|
AllowInstsAsModes = no,
|
|
Pieces = cord.list(ContextPieces) ++ [lower_case_next_if_not_first,
|
|
words("Error: higher order inst is used as a mode."), nl],
|
|
Spec = simplest_spec($pred, severity_error,
|
|
phase_term_to_parse_tree, get_term_context(BeforeIsTerm),
|
|
Pieces),
|
|
MaybeMode = error1([Spec])
|
|
;
|
|
AllowInstsAsModes = yes,
|
|
% XXX Should update ContextPieces.
|
|
parse_modes(AllowConstrainedInstVar, VarSet, ContextPieces,
|
|
BeforeIsArgTerms, MaybeArgModes),
|
|
parse_determinism(VarSet, DetTerm, MaybeDetism),
|
|
( if
|
|
MaybeArgModes = ok1(ArgModes),
|
|
MaybeDetism = ok1(Detism)
|
|
then
|
|
PredInstInfo = pred_inst_info(pf_predicate, ArgModes,
|
|
arg_reg_types_unset, Detism),
|
|
(
|
|
IsAny = no,
|
|
Inst = ground(shared, higher_order(PredInstInfo))
|
|
;
|
|
IsAny = yes,
|
|
Inst = any(shared, higher_order(PredInstInfo))
|
|
),
|
|
Mode = from_to_mode(Inst, Inst),
|
|
MaybeMode = ok1(Mode)
|
|
else
|
|
Specs = get_any_errors1(MaybeArgModes)
|
|
++ get_any_errors1(MaybeDetism),
|
|
MaybeMode = error1(Specs)
|
|
)
|
|
)
|
|
else if
|
|
BeforeIsTerm =
|
|
term.functor(term.atom(BeforeIsFunctor), BeforeIsArgTerms, _),
|
|
BeforeIsFunctor = "=",
|
|
BeforeIsArgTerms = [FuncTerm, RetModeTerm],
|
|
FuncTerm = term.functor(term.atom(FuncTermFunctor), ArgModesTerms, _),
|
|
(
|
|
FuncTermFunctor = "func",
|
|
% Handle higher-order function modes:
|
|
% a mode of the form
|
|
% func(<Mode1>, <Mode2>, ...) = <RetMode> is <Det>
|
|
% is an abbreviation for the inst mapping
|
|
% ( func(<Mode1>, <Mode2>, ...) = <RetMode> is <Det>
|
|
% -> func(<Mode1>, <Mode2>, ...) = <RetMode> is <Det>
|
|
% )
|
|
IsAny = no
|
|
;
|
|
FuncTermFunctor = "any_func",
|
|
% Handle higher-order function modes:
|
|
% a mode of the form
|
|
% any_func(<Mode1>, <Mode2>, ...) = <RetMode> is <Det>
|
|
% is an abbreviation for the inst mapping
|
|
% ( any_func(<Mode1>, <Mode2>, ...) = <RetMode> is <Det>
|
|
% -> any_func(<Mode1>, <Mode2>, ...) = <RetMode> is <Det>
|
|
% )
|
|
IsAny = yes
|
|
)
|
|
then
|
|
AllowInstsAsModes = globals.get_allow_ho_insts_as_modes,
|
|
(
|
|
AllowInstsAsModes = no,
|
|
Pieces = cord.list(ContextPieces) ++ [lower_case_next_if_not_first,
|
|
words("Error: higher order inst is used as a mode."), nl],
|
|
Spec = simplest_spec($pred, severity_error,
|
|
phase_term_to_parse_tree, get_term_context(BeforeIsTerm),
|
|
Pieces),
|
|
MaybeMode = error1([Spec])
|
|
;
|
|
AllowInstsAsModes = yes,
|
|
% XXX Should update ContextPieces.
|
|
parse_modes(AllowConstrainedInstVar, VarSet, ContextPieces,
|
|
ArgModesTerms, MaybeArgModes0),
|
|
parse_mode(AllowConstrainedInstVar, VarSet, ContextPieces,
|
|
RetModeTerm, MaybeRetMode),
|
|
parse_determinism(VarSet, DetTerm, MaybeDetism),
|
|
( if
|
|
MaybeArgModes0 = ok1(ArgModes0),
|
|
MaybeRetMode = ok1(RetMode),
|
|
MaybeDetism = ok1(Detism)
|
|
then
|
|
ArgModes = ArgModes0 ++ [RetMode],
|
|
FuncInstInfo = pred_inst_info(pf_function, ArgModes,
|
|
arg_reg_types_unset, Detism),
|
|
(
|
|
IsAny = no,
|
|
Inst = ground(shared, higher_order(FuncInstInfo))
|
|
;
|
|
IsAny = yes,
|
|
Inst = any(shared, higher_order(FuncInstInfo))
|
|
),
|
|
Mode = from_to_mode(Inst, Inst),
|
|
MaybeMode = ok1(Mode)
|
|
else
|
|
Specs = get_any_errors1(MaybeArgModes0)
|
|
++ get_any_errors1(MaybeRetMode)
|
|
++ get_any_errors1(MaybeDetism),
|
|
MaybeMode = error1(Specs)
|
|
)
|
|
)
|
|
else
|
|
Pieces = cord.list(ContextPieces) ++ [lower_case_next_if_not_first,
|
|
words("Error: a higher-order mode should have"),
|
|
words("one of the following forms:"), nl,
|
|
quote("pred(<mode1>, ...) is <detism>"), nl,
|
|
quote("any_pred(<mode1>, ...) is <detism>"), nl,
|
|
quote("func(<mode1>, ...) = <return_mode> is <detism>"), nl,
|
|
quote("any_func(<mode1>, ...) = <return_mode> is <detism>"), nl,
|
|
suffix("."), nl],
|
|
Spec = simplest_spec($pred, severity_error, phase_term_to_parse_tree,
|
|
get_term_context(BeforeIsTerm), Pieces),
|
|
MaybeMode = error1([Spec])
|
|
).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
parse_insts(_, _, _, [], ok1([])).
|
|
parse_insts(AllowConstrainedInstVar, VarSet, ContextPieces, [Term | Terms],
|
|
MaybeInsts) :-
|
|
% XXX We should pass a ContextPieces updated as the "nth inst in ...".
|
|
parse_inst(AllowConstrainedInstVar, VarSet, ContextPieces,
|
|
Term, MaybeHeadInst),
|
|
parse_insts(AllowConstrainedInstVar, VarSet, ContextPieces,
|
|
Terms, MaybeTailInsts),
|
|
( if
|
|
MaybeHeadInst = ok1(HeadInst),
|
|
MaybeTailInsts = ok1(TailInsts)
|
|
then
|
|
MaybeInsts = ok1([HeadInst | TailInsts])
|
|
else
|
|
Specs = get_any_errors1(MaybeHeadInst)
|
|
++ get_any_errors1(MaybeTailInsts),
|
|
MaybeInsts = error1(Specs)
|
|
).
|
|
|
|
parse_inst(AllowConstrainedInstVar, VarSet, ContextPieces, Term, MaybeInst) :-
|
|
(
|
|
Term = term.variable(Var, _),
|
|
term.coerce_var(Var, InstVar),
|
|
MaybeInst = ok1(inst_var(InstVar))
|
|
;
|
|
Term = term.functor(Functor, ArgTerms, Context),
|
|
(
|
|
( Functor = term.integer(_, _, _, _)
|
|
; Functor = term.string(_)
|
|
; Functor = term.float(_)
|
|
; Functor = term.implementation_defined(_)
|
|
),
|
|
TermStr = describe_error_term(VarSet, Term),
|
|
Pieces = cord.list(ContextPieces) ++ [lower_case_next_if_not_first,
|
|
words("Error:"), quote(TermStr),
|
|
words("is not a valid inst."), nl],
|
|
Spec = simplest_spec($pred, severity_error,
|
|
phase_term_to_parse_tree, Context, Pieces),
|
|
MaybeInst = error1([Spec])
|
|
;
|
|
Functor = term.atom(Name),
|
|
parse_inst_atom_functor(AllowConstrainedInstVar, VarSet,
|
|
ContextPieces, Name, ArgTerms, Context, MaybeInst)
|
|
)
|
|
).
|
|
|
|
:- pred parse_inst_atom_functor(allow_constrained_inst_var::in, varset::in,
|
|
cord(format_piece)::in, string::in, list(term)::in, term.context::in,
|
|
maybe1(mer_inst)::out) is det.
|
|
|
|
parse_inst_atom_functor(AllowConstrainedInstVar, VarSet, ContextPieces,
|
|
Name, ArgTerms0, Context, MaybeInst) :-
|
|
% XXX It would be nice if we could merge the switch on Name inside
|
|
% is_simple_builtin_inst with the explicit switch below, *without*
|
|
% duplicating the code of is_simple_builtin_inst.
|
|
( if is_known_inst_name_args(Name, ArgTerms0, KnownInstKind) then
|
|
(
|
|
KnownInstKind = known_inst_bad_arity(ExpectedArityStr),
|
|
Pieces = cord.list(ContextPieces) ++ [lower_case_next_if_not_first,
|
|
words("Error: the builtin inst"), quote(Name),
|
|
words("should only be used with arity"),
|
|
words(ExpectedArityStr), suffix("."), nl],
|
|
Spec = simplest_spec($pred, severity_error,
|
|
phase_term_to_parse_tree, Context, Pieces),
|
|
MaybeInst = error1([Spec])
|
|
;
|
|
KnownInstKind = known_inst_simple(Inst),
|
|
MaybeInst = ok1(Inst)
|
|
;
|
|
KnownInstKind = known_inst_compound(CompoundInstKind),
|
|
(
|
|
CompoundInstKind = kcik_is(BeforeIsTerm, DetTerm),
|
|
% XXX Should update ContextPieces.
|
|
parse_higher_order_inst(AllowConstrainedInstVar, VarSet,
|
|
ContextPieces, BeforeIsTerm, DetTerm, MaybeInst)
|
|
;
|
|
CompoundInstKind = kcik_bound(DisjTerm),
|
|
% XXX Should update ContextPieces.
|
|
parse_bound_inst_list(AllowConstrainedInstVar, VarSet,
|
|
ContextPieces, DisjTerm, shared, MaybeInst)
|
|
;
|
|
CompoundInstKind = kcik_unique(DisjTerm),
|
|
% XXX Should update ContextPieces.
|
|
parse_bound_inst_list(AllowConstrainedInstVar, VarSet,
|
|
ContextPieces, DisjTerm, unique, MaybeInst)
|
|
;
|
|
CompoundInstKind = kcik_mostly_unique(DisjTerm),
|
|
% XXX Should update ContextPieces.
|
|
parse_bound_inst_list(AllowConstrainedInstVar, VarSet,
|
|
ContextPieces, DisjTerm, mostly_unique, MaybeInst)
|
|
;
|
|
CompoundInstKind = kcik_constrained(VarTerm, SubInstTerm),
|
|
(
|
|
VarTerm = term.variable(Var, _),
|
|
% Do not allow nested constrained_inst_vars.
|
|
% XXX Should update ContextPieces.
|
|
parse_inst(
|
|
no_allow_constrained_inst_var(wnciv_constraint_rhs),
|
|
VarSet, ContextPieces, SubInstTerm, MaybeSubInst),
|
|
(
|
|
MaybeSubInst = ok1(SubInst),
|
|
(
|
|
AllowConstrainedInstVar =
|
|
allow_constrained_inst_var,
|
|
Inst = constrained_inst_vars(
|
|
set.make_singleton_set(term.coerce_var(Var)),
|
|
SubInst),
|
|
MaybeInst = ok1(Inst)
|
|
;
|
|
AllowConstrainedInstVar =
|
|
no_allow_constrained_inst_var(Why),
|
|
BadTerm = term.functor(term.atom(Name),
|
|
ArgTerms0, Context),
|
|
MaybeInst = no_allow_constrained_inst_var_result(
|
|
ContextPieces, Why, VarSet, BadTerm)
|
|
)
|
|
;
|
|
MaybeSubInst = error1(Specs),
|
|
MaybeInst = error1(Specs)
|
|
)
|
|
;
|
|
VarTerm = term.functor(_, _, _),
|
|
VarTermStr = describe_error_term(VarSet, VarTerm),
|
|
Pieces = cord.list(ContextPieces) ++
|
|
[lower_case_next_if_not_first,
|
|
words("Error: inst constraints can be applied"),
|
|
words("only to inst variables,"),
|
|
words("not to terms such as"), quote(VarTermStr),
|
|
suffix("."), nl],
|
|
Spec = simplest_spec($pred, severity_error,
|
|
phase_term_to_parse_tree,
|
|
get_term_context(VarTerm), Pieces),
|
|
MaybeInst = error1([Spec])
|
|
)
|
|
)
|
|
)
|
|
else
|
|
% Anything else must be a user-defined inst.
|
|
UserDefnInstTerm = term.functor(term.atom(Name), ArgTerms0, Context),
|
|
parse_sym_name_and_args(VarSet, ContextPieces, UserDefnInstTerm,
|
|
MaybeFunctor),
|
|
(
|
|
MaybeFunctor = ok2(QualifiedName, ArgTerms1),
|
|
( if
|
|
BuiltinModule = mercury_public_builtin_module,
|
|
sym_name_get_module_name_default(QualifiedName,
|
|
unqualified(""), BuiltinModule),
|
|
% If the term is qualified with the `builtin' module,
|
|
% then it may be one of the simple builtin insts.
|
|
UnqualifiedName = unqualify_name(QualifiedName),
|
|
is_known_inst_name_args(UnqualifiedName, ArgTerms1,
|
|
KnownInstKind),
|
|
KnownInstKind = known_inst_simple(Inst),
|
|
|
|
% However, if the inst is a user_inst defined inside
|
|
% the `builtin' module, then we need to make sure it is
|
|
% properly module-qualified.
|
|
Inst \= defined_inst(user_inst(_, _))
|
|
then
|
|
MaybeInst = ok1(Inst)
|
|
else
|
|
% XXX Should update ContextPieces.
|
|
parse_insts(AllowConstrainedInstVar, VarSet, ContextPieces,
|
|
ArgTerms1, MaybeArgInsts),
|
|
(
|
|
MaybeArgInsts = ok1(ArgInsts),
|
|
Inst = defined_inst(user_inst(QualifiedName, ArgInsts)),
|
|
MaybeInst = ok1(Inst)
|
|
;
|
|
MaybeArgInsts = error1(Specs),
|
|
MaybeInst = error1(Specs)
|
|
)
|
|
)
|
|
;
|
|
MaybeFunctor = error2(Specs),
|
|
MaybeInst = error1(Specs)
|
|
)
|
|
).
|
|
|
|
:- func no_allow_constrained_inst_var_result(cord(format_piece),
|
|
why_no_constrained_inst_var, varset, term) = maybe1(mer_inst).
|
|
|
|
no_allow_constrained_inst_var_result(ContextPieces, Why, VarSet, Term)
|
|
= MaybeInst :-
|
|
TermStr = describe_error_term(VarSet, Term),
|
|
(
|
|
Why = wnciv_constraint_rhs,
|
|
Place = "on the right hand side of an inst constraint"
|
|
;
|
|
Why = wnciv_inst_defn_lhs,
|
|
Place = "on the left hand side of the definition of a named inst"
|
|
;
|
|
Why = wnciv_eqv_inst_defn_rhs,
|
|
Place = "on the right hand side of the definition"
|
|
++ " of a named inst equivalence"
|
|
;
|
|
Why = wnciv_mode_defn_rhs,
|
|
Place = "on the right hand side of the definition of a named mode"
|
|
;
|
|
Why = wnciv_type_and_mode,
|
|
% XXX This *is* allowed in *some* cases.
|
|
% XXX Add an argument to dont_constrain_inst_vars.
|
|
Place = "in a mode annotation on a type"
|
|
;
|
|
Why = wnciv_solver_type_inst,
|
|
Place = "as the ground or any inst of a solver type definition"
|
|
;
|
|
Why = wnciv_mutable_inst,
|
|
Place = "as the inst of a mutable"
|
|
),
|
|
Pieces = cord.list(ContextPieces) ++ [lower_case_next_if_not_first,
|
|
words("Error: a constrained inst variable"),
|
|
words("such as"), quote(TermStr),
|
|
words("may not appear"), words(Place), suffix("."), nl],
|
|
Spec = simplest_spec($pred, severity_error, phase_term_to_parse_tree,
|
|
get_term_context(Term), Pieces),
|
|
MaybeInst = error1([Spec]).
|
|
|
|
:- type known_compound_inst_kind(T)
|
|
---> kcik_is(T, T)
|
|
; kcik_constrained(T, T)
|
|
; kcik_bound(T)
|
|
; kcik_unique(T)
|
|
; kcik_mostly_unique(T).
|
|
|
|
:- type known_inst_kind(T)
|
|
---> known_inst_simple(mer_inst)
|
|
; known_inst_compound(known_compound_inst_kind(T))
|
|
; known_inst_bad_arity(string). % The expected arity or arities.
|
|
|
|
is_known_inst_name(Name) :-
|
|
is_known_inst_name_args(Name, [] : list(mer_inst), _).
|
|
|
|
% is_known_inst_name_args(InstName, InstArgs, KnownInstKind):
|
|
%
|
|
% If Name is a known inst name and Name(InstArgs) is a valid inst
|
|
% structure, then return its kind in KnownInstKind.
|
|
%
|
|
% If Name is a known inst name but Name(InstArgs) is NOT a valid inst
|
|
% structure, then return known_inst_bad_arity in KnownInstKind.
|
|
%
|
|
% If Name is not a known inst name, fail.
|
|
%
|
|
:- pred is_known_inst_name_args(string::in, list(T)::in,
|
|
known_inst_kind(T)::out) is semidet.
|
|
|
|
is_known_inst_name_args(Name, Args, KnownInst) :-
|
|
(
|
|
% Known insts which are always simple.
|
|
(
|
|
Name = "free",
|
|
SimpleInst = free
|
|
;
|
|
Name = "ground",
|
|
SimpleInst = ground(shared, none_or_default_func)
|
|
;
|
|
Name = "clobbered",
|
|
SimpleInst = ground(clobbered, none_or_default_func)
|
|
;
|
|
Name = "mostly_clobbered",
|
|
SimpleInst = ground(mostly_clobbered, none_or_default_func)
|
|
;
|
|
Name = "any",
|
|
SimpleInst = any(shared, none_or_default_func)
|
|
;
|
|
Name = "unique_any",
|
|
SimpleInst = any(unique, none_or_default_func)
|
|
;
|
|
Name = "mostly_unique_any",
|
|
SimpleInst = any(mostly_unique, none_or_default_func)
|
|
;
|
|
Name = "clobbered_any",
|
|
SimpleInst = any(clobbered, none_or_default_func)
|
|
;
|
|
Name = "mostly_clobbered_any",
|
|
SimpleInst = any(mostly_clobbered, none_or_default_func)
|
|
;
|
|
Name = "not_reached",
|
|
SimpleInst = not_reached
|
|
),
|
|
(
|
|
Args = [],
|
|
KnownInst = known_inst_simple(SimpleInst)
|
|
;
|
|
Args = [_ | _],
|
|
KnownInst = known_inst_bad_arity("zero")
|
|
)
|
|
;
|
|
Name = "unique",
|
|
(
|
|
Args = [],
|
|
KnownInst = known_inst_simple(ground(unique, none_or_default_func))
|
|
;
|
|
Args = [Arg1],
|
|
KnownInst = known_inst_compound(kcik_unique(Arg1))
|
|
;
|
|
Args = [_, _ | _],
|
|
KnownInst = known_inst_bad_arity("zero or one")
|
|
)
|
|
;
|
|
Name = "mostly_unique",
|
|
(
|
|
Args = [],
|
|
KnownInst = known_inst_simple(
|
|
ground(mostly_unique, none_or_default_func))
|
|
;
|
|
Args = [Arg1],
|
|
KnownInst = known_inst_compound(kcik_mostly_unique(Arg1))
|
|
;
|
|
Args = [_, _ | _],
|
|
KnownInst = known_inst_bad_arity("zero or one")
|
|
)
|
|
;
|
|
Name = "is",
|
|
(
|
|
( Args = []
|
|
; Args = [_]
|
|
; Args = [_, _, _ | _]
|
|
),
|
|
KnownInst = known_inst_bad_arity("two")
|
|
;
|
|
Args = [Arg1, Arg2],
|
|
KnownInst = known_inst_compound(kcik_is(Arg1, Arg2))
|
|
)
|
|
;
|
|
Name = "=<",
|
|
(
|
|
( Args = []
|
|
; Args = [_]
|
|
; Args = [_, _, _ | _]
|
|
),
|
|
KnownInst = known_inst_bad_arity("two")
|
|
;
|
|
Args = [Arg1, Arg2],
|
|
KnownInst = known_inst_compound(kcik_constrained(Arg1, Arg2))
|
|
)
|
|
;
|
|
Name = "bound",
|
|
(
|
|
( Args = []
|
|
; Args = [_, _ | _]
|
|
),
|
|
KnownInst = known_inst_bad_arity("one")
|
|
;
|
|
Args = [Arg1],
|
|
KnownInst = known_inst_compound(kcik_bound(Arg1))
|
|
)
|
|
;
|
|
Name = "bound_unique",
|
|
% `bound_unique' is for backwards compatibility - use `unique'
|
|
% instead.
|
|
(
|
|
( Args = []
|
|
; Args = [_, _ | _]
|
|
),
|
|
KnownInst = known_inst_bad_arity("one")
|
|
;
|
|
Args = [Arg1],
|
|
KnownInst = known_inst_compound(kcik_unique(Arg1))
|
|
)
|
|
).
|
|
|
|
:- pred parse_higher_order_inst(allow_constrained_inst_var::in,
|
|
varset::in, cord(format_piece)::in, term::in, term::in,
|
|
maybe1(mer_inst)::out) is det.
|
|
|
|
parse_higher_order_inst(AllowConstrainedInstVar, VarSet, ContextPieces,
|
|
BeforeIsTerm, DetTerm, MaybeInst) :-
|
|
( if
|
|
BeforeIsTerm =
|
|
term.functor(term.atom(BeforeIsFunctor), BeforeIsArgTerms, _),
|
|
(
|
|
BeforeIsFunctor = "pred",
|
|
% The syntax for a ground higher-order pred inst is
|
|
%
|
|
% pred(<Mode1>, <Mode2>, ...) is <Detism>
|
|
%
|
|
% where <Mode1>, <Mode2>, ... are a list of modes,
|
|
% and <Detism> is a determinism.
|
|
IsAny = no
|
|
;
|
|
BeforeIsFunctor = "any_pred",
|
|
% The syntax for an `any' higher-order pred inst is
|
|
%
|
|
% any_pred(<Mode1>, <Mode2>, ...) is <Detism>
|
|
%
|
|
% where <Mode1>, <Mode2>, ... are a list of modes,
|
|
% and <Detism> is a determinism.
|
|
IsAny = yes
|
|
)
|
|
then
|
|
% XXX Should update ContextPieces.
|
|
parse_modes(AllowConstrainedInstVar, VarSet, ContextPieces,
|
|
BeforeIsArgTerms, MaybeArgModes),
|
|
parse_determinism(VarSet, DetTerm, MaybeDetism),
|
|
( if
|
|
MaybeArgModes = ok1(ArgModes),
|
|
MaybeDetism = ok1(Detism)
|
|
then
|
|
PredInst = pred_inst_info(pf_predicate, ArgModes,
|
|
arg_reg_types_unset, Detism),
|
|
(
|
|
IsAny = no,
|
|
Inst = ground(shared, higher_order(PredInst))
|
|
;
|
|
IsAny = yes,
|
|
Inst = any(shared, higher_order(PredInst))
|
|
),
|
|
MaybeInst = ok1(Inst)
|
|
else
|
|
Specs = get_any_errors1(MaybeArgModes)
|
|
++ get_any_errors1(MaybeDetism),
|
|
MaybeInst = error1(Specs)
|
|
)
|
|
else if
|
|
BeforeIsTerm =
|
|
term.functor(term.atom(BeforeIsFunctor), BeforeIsArgTerms, _),
|
|
BeforeIsFunctor = "=",
|
|
BeforeIsArgTerms = [FuncTerm, RetModeTerm],
|
|
FuncTerm = term.functor(term.atom(FuncTermFunctor), ArgModesTerms, _),
|
|
(
|
|
FuncTermFunctor = "func",
|
|
% The syntax for a ground higher-order func inst is
|
|
%
|
|
% func(<Mode1>, <Mode2>, ...) = <RetMode> is <Detism>
|
|
%
|
|
% where <Mode1>, <Mode2>, ... are a list of modes,
|
|
% <RetMode> is a mode, and <Detism> is a determinism.
|
|
IsAny = no
|
|
;
|
|
FuncTermFunctor = "any_func",
|
|
% The syntax for an `any' higher-order func inst is
|
|
%
|
|
% any_func(<Mode1>, <Mode2>, ...) = <RetMode> is <Detism>
|
|
%
|
|
% where <Mode1>, <Mode2>, ... are a list of modes,
|
|
% <RetMode> is a mode, and <Detism> is a determinism.
|
|
IsAny = yes
|
|
)
|
|
then
|
|
% XXX Should update ContextPieces.
|
|
parse_modes(AllowConstrainedInstVar, VarSet, ContextPieces,
|
|
ArgModesTerms, MaybeArgModes0),
|
|
parse_mode(AllowConstrainedInstVar, VarSet, ContextPieces,
|
|
RetModeTerm, MaybeRetMode),
|
|
parse_determinism(VarSet, DetTerm, MaybeDetism),
|
|
( if
|
|
MaybeArgModes0 = ok1(ArgModes0),
|
|
MaybeRetMode = ok1(RetMode),
|
|
MaybeDetism = ok1(Detism)
|
|
then
|
|
ArgModes = ArgModes0 ++ [RetMode],
|
|
FuncInst = pred_inst_info(pf_function, ArgModes,
|
|
arg_reg_types_unset, Detism),
|
|
(
|
|
IsAny = no,
|
|
Inst = ground(shared, higher_order(FuncInst))
|
|
;
|
|
IsAny = yes,
|
|
Inst = any(shared, higher_order(FuncInst))
|
|
),
|
|
MaybeInst = ok1(Inst)
|
|
else
|
|
Specs = get_any_errors1(MaybeArgModes0)
|
|
++ get_any_errors1(MaybeRetMode)
|
|
++ get_any_errors1(MaybeDetism),
|
|
MaybeInst = error1(Specs)
|
|
)
|
|
else
|
|
Pieces = cord.list(ContextPieces) ++ [lower_case_next_if_not_first,
|
|
words("Error: a higher-order insts should have"),
|
|
words("one of the following forms:"), nl,
|
|
quote("pred(<inst1>, ...) is <detism>"), nl,
|
|
quote("any_pred(<inst1>, ...) is <detism>"), nl,
|
|
quote("func(<inst1>, ...) = <return_inst> is <detism>"), nl,
|
|
quote("any_func(<inst1>, ...) = <return_inst> is <detism>"), nl,
|
|
suffix("."), nl],
|
|
Spec = simplest_spec($pred, severity_error, phase_term_to_parse_tree,
|
|
get_term_context(BeforeIsTerm), Pieces),
|
|
MaybeInst = error1([Spec])
|
|
).
|
|
|
|
:- pred parse_bound_inst_list(allow_constrained_inst_var::in, varset::in,
|
|
cord(format_piece)::in, term::in, uniqueness::in,
|
|
maybe1(mer_inst)::out) is det.
|
|
|
|
parse_bound_inst_list(AllowConstrainedInstVar, VarSet, ContextPieces,
|
|
DisjunctionTerm, Uniqueness, MaybeInst) :-
|
|
disjunction_to_list(DisjunctionTerm, DisjunctTerms),
|
|
parse_bound_insts(AllowConstrainedInstVar, VarSet, ContextPieces,
|
|
DisjunctTerms, MaybeBoundInsts),
|
|
(
|
|
MaybeBoundInsts = error1(Specs),
|
|
MaybeInst = error1(Specs)
|
|
;
|
|
MaybeBoundInsts = ok1(BoundInsts),
|
|
list.sort(BoundInsts, SortedBoundInsts),
|
|
( if
|
|
% Does the list specify the same functor twice?
|
|
SortedBoundInsts = [FirstBoundInst | LaterBoundInsts],
|
|
find_duplicate_cons_id_bound_insts(FirstBoundInst, LaterBoundInsts,
|
|
Duplicates0),
|
|
list.sort_and_remove_dups(Duplicates0, Duplicates),
|
|
Duplicates = [_ | _]
|
|
then
|
|
Pieces = cord.list(ContextPieces) ++ [lower_case_next_if_not_first,
|
|
words("Error: this bound inst lists") |
|
|
component_list_to_pieces("and", Duplicates)]
|
|
++ [words("more than once."), nl],
|
|
Spec = simplest_spec($pred, severity_error,
|
|
phase_term_to_parse_tree,
|
|
get_term_context(DisjunctionTerm), Pieces),
|
|
MaybeInst = error1([Spec])
|
|
else
|
|
Inst = bound(Uniqueness, inst_test_no_results, SortedBoundInsts),
|
|
MaybeInst = ok1(Inst)
|
|
)
|
|
).
|
|
|
|
:- pred find_duplicate_cons_id_bound_insts(bound_inst::in,
|
|
list(bound_inst)::in, list(format_piece)::out) is det.
|
|
|
|
find_duplicate_cons_id_bound_insts(_Prev, [], []).
|
|
find_duplicate_cons_id_bound_insts(Prev, [Cur | Next], Duplicates) :-
|
|
find_duplicate_cons_id_bound_insts(Cur, Next, DuplicatesTail),
|
|
Prev = bound_functor(PrevConsId, _),
|
|
Cur = bound_functor(CurConsId, _),
|
|
( if PrevConsId = CurConsId then
|
|
Duplicates =
|
|
[unqual_cons_id_and_maybe_arity(CurConsId) | DuplicatesTail]
|
|
else
|
|
Duplicates = DuplicatesTail
|
|
).
|
|
|
|
:- pred parse_bound_insts(allow_constrained_inst_var::in, varset::in,
|
|
cord(format_piece)::in, list(term)::in,
|
|
maybe1(list(bound_inst))::out) is det.
|
|
|
|
parse_bound_insts(_, _, _, [], ok1([])).
|
|
parse_bound_insts(AllowConstrainedInstVar, VarSet, ContextPieces,
|
|
[Term | Terms], MaybeBoundInsts) :-
|
|
% XXX Should update ContextPieces.
|
|
parse_bound_inst(AllowConstrainedInstVar, VarSet, ContextPieces,
|
|
Term, MaybeHeadBoundInst),
|
|
parse_bound_insts(AllowConstrainedInstVar, VarSet, ContextPieces,
|
|
Terms, MaybeTailBoundInsts),
|
|
( if
|
|
MaybeHeadBoundInst = ok1(HeadBoundInst),
|
|
MaybeTailBoundInsts = ok1(TailBoundInsts)
|
|
then
|
|
MaybeBoundInsts = ok1([HeadBoundInst | TailBoundInsts])
|
|
else
|
|
Specs = get_any_errors1(MaybeHeadBoundInst)
|
|
++ get_any_errors1(MaybeTailBoundInsts),
|
|
MaybeBoundInsts = error1(Specs)
|
|
).
|
|
|
|
:- pred parse_bound_inst(allow_constrained_inst_var::in, varset::in,
|
|
cord(format_piece)::in, term::in, maybe1(bound_inst)::out) is det.
|
|
|
|
parse_bound_inst(AllowConstrainedInstVar, VarSet, ContextPieces, Term,
|
|
MaybeBoundInst) :-
|
|
(
|
|
Term = term.variable(_, Context),
|
|
TermStr = describe_error_term(VarSet, Term),
|
|
Pieces = cord.list(ContextPieces) ++ [lower_case_next_if_not_first,
|
|
words("Error:"), quote(TermStr),
|
|
words("is not a bound inst."), nl],
|
|
Spec = simplest_spec($pred, severity_error, phase_term_to_parse_tree,
|
|
Context, Pieces),
|
|
MaybeBoundInst = error1([Spec])
|
|
;
|
|
Term = term.functor(Functor, _ArgTerms0, Context),
|
|
require_complete_switch [Functor]
|
|
(
|
|
Functor = term.atom(_),
|
|
parse_sym_name_and_args(VarSet, cord.init, Term, MaybeFunctor),
|
|
(
|
|
MaybeFunctor = ok2(SymName, ArgTerms1),
|
|
% XXX Should update ContextPieces.
|
|
parse_insts(AllowConstrainedInstVar, VarSet, ContextPieces,
|
|
ArgTerms1, MaybeArgInsts),
|
|
(
|
|
MaybeArgInsts = ok1(ArgInsts),
|
|
list.length(ArgTerms1, Arity),
|
|
ConsId = cons(SymName, Arity, cons_id_dummy_type_ctor),
|
|
MaybeBoundInst = ok1(bound_functor(ConsId, ArgInsts))
|
|
;
|
|
MaybeArgInsts = error1(Specs),
|
|
MaybeBoundInst = error1(Specs)
|
|
)
|
|
;
|
|
MaybeFunctor = error2(Specs),
|
|
MaybeBoundInst = error1(Specs)
|
|
)
|
|
;
|
|
Functor = term.implementation_defined(_),
|
|
% expect(unify(ArgTerms0, []), $pred,
|
|
% "parse_simple_term has given " ++
|
|
% "an implementation_defined arguments"),
|
|
% Implementation-defined literals should not appear in inst
|
|
% definitions.
|
|
TermStr = describe_error_term(VarSet, Term),
|
|
Pieces = cord.list(ContextPieces) ++ [lower_case_next_if_not_first,
|
|
words("Error: an implementation defined literal"),
|
|
words("such as"), quote(TermStr),
|
|
words("may not be a used as a bound inst."), nl],
|
|
Spec = simplest_spec($pred, severity_error,
|
|
phase_term_to_parse_tree, Context, Pieces),
|
|
MaybeBoundInst = error1([Spec])
|
|
;
|
|
Functor = term.integer(Base, Integer, Signedness, Size),
|
|
% expect(unify(ArgTerms0, []), $pred,
|
|
% "parse_simple_term has given an integer arguments"),
|
|
parse_integer_cons_id(Base, Integer, Signedness, Size, Context,
|
|
MaybeConsId),
|
|
(
|
|
MaybeConsId = ok1(ConsId),
|
|
BoundInst = bound_functor(ConsId, []),
|
|
MaybeBoundInst = ok1(BoundInst)
|
|
;
|
|
MaybeConsId = error1(Specs),
|
|
MaybeBoundInst = error1(Specs)
|
|
)
|
|
;
|
|
(
|
|
Functor = term.float(Float),
|
|
% expect(unify(ArgTerms0, []), $pred,
|
|
% "parse_simple_term has given a float arguments"),
|
|
ConsId = float_const(Float)
|
|
;
|
|
Functor = term.string(Str),
|
|
% expect(unify(ArgTerms0, []), $pred,
|
|
% "parse_simple_term has given a string arguments"),
|
|
ConsId = string_const(Str)
|
|
),
|
|
BoundInst = bound_functor(ConsId, []),
|
|
MaybeBoundInst = ok1(BoundInst)
|
|
)
|
|
).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
parse_determinism(VarSet, Term, MaybeDetism) :-
|
|
( if
|
|
Term = term.functor(term.atom(DetString), [], _),
|
|
standard_det(DetString, Detism)
|
|
then
|
|
MaybeDetism = ok1(Detism)
|
|
else
|
|
TermStr = describe_error_term(VarSet, Term),
|
|
DetismPieces = [words("Error:"), quote(TermStr),
|
|
words("is not a valid determinism."), nl],
|
|
DetismSpec = simplest_spec($pred, severity_error,
|
|
phase_term_to_parse_tree, get_term_context(Term), DetismPieces),
|
|
MaybeDetism = error1([DetismSpec])
|
|
).
|
|
|
|
standard_det("det", detism_det).
|
|
standard_det("cc_nondet", detism_cc_non).
|
|
standard_det("cc_multi", detism_cc_multi).
|
|
standard_det("nondet", detism_non).
|
|
standard_det("multi", detism_multi).
|
|
standard_det("multidet", detism_multi).
|
|
standard_det("semidet", detism_semi).
|
|
standard_det("erroneous", detism_erroneous).
|
|
standard_det("failure", detism_failure).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
:- end_module parse_tree.parse_inst_mode_name.
|
|
%---------------------------------------------------------------------------%
|