mirror of
https://github.com/Mercury-Language/mercury.git
synced 2025-12-12 20:34:19 +00:00
431 lines
18 KiB
Mathematica
431 lines
18 KiB
Mathematica
%---------------------------------------------------------------------------%
|
|
% vim: ft=mercury ts=4 sw=4 et
|
|
%---------------------------------------------------------------------------%
|
|
% Copyright (C) 2008, 2011 The University of Melbourne.
|
|
% This file may only be copied under the terms of the GNU General
|
|
% Public License - see the file COPYING in the Mercury distribution.
|
|
%---------------------------------------------------------------------------%
|
|
%
|
|
% File: parse_mutable.m.
|
|
%
|
|
% This module defines predicates for parsing the parts of Mercury programs
|
|
% relating to initialise, finalise and mutable declarations.
|
|
|
|
:- module parse_tree.parse_mutable.
|
|
|
|
:- interface.
|
|
|
|
:- 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 parse_tree.prog_item.
|
|
|
|
:- import_module list.
|
|
:- import_module term.
|
|
:- import_module varset.
|
|
|
|
:- pred parse_initialise_item(module_name::in, varset::in, list(term)::in,
|
|
prog_context::in, int::in, maybe1(item_or_marker)::out) is det.
|
|
|
|
:- pred parse_finalise_item(module_name::in, varset::in, list(term)::in,
|
|
prog_context::in, int::in, maybe1(item_or_marker)::out) is det.
|
|
|
|
:- pred parse_mutable_item(module_name::in, varset::in, list(term)::in,
|
|
prog_context::in, int::in, maybe1(item_or_marker)::out) is det.
|
|
|
|
:- type mutable_locn
|
|
---> mutable_locn_item
|
|
% The mutable is an item of its own.
|
|
; mutable_locn_in_solver_type.
|
|
% The mutable is part of an item that defines a solver type.
|
|
|
|
:- pred parse_mutable_decl_info(module_name::in, varset::in, list(term)::in,
|
|
prog_context::in, int::in, mutable_locn::in,
|
|
maybe1(item_mutable_info)::out) is det.
|
|
|
|
%-----------------------------------------------------------------------------e
|
|
|
|
:- implementation.
|
|
|
|
:- import_module parse_tree.error_util.
|
|
:- import_module parse_tree.parse_inst_mode_name.
|
|
:- import_module parse_tree.parse_pragma.
|
|
:- 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 cord.
|
|
:- import_module maybe.
|
|
:- import_module pair.
|
|
:- import_module string.
|
|
|
|
%-----------------------------------------------------------------------------e
|
|
|
|
parse_initialise_item(_ModuleName, VarSet, ArgTerms, Context, SeqNum,
|
|
MaybeIOM) :-
|
|
( if ArgTerms = [Term] then
|
|
parse_symbol_name_specifier(VarSet, Term, MaybeSymNameSpecifier),
|
|
(
|
|
MaybeSymNameSpecifier = error1(Specs),
|
|
MaybeIOM = error1(Specs)
|
|
;
|
|
MaybeSymNameSpecifier = ok1(SymNameSpecifier),
|
|
(
|
|
SymNameSpecifier = sym_name_specifier_name(_),
|
|
TermStr = describe_error_term(VarSet, Term),
|
|
Pieces = [words("Error: the predicate specification in an"),
|
|
decl("initialise"), words("declaration"),
|
|
words("must specify the predicate's arity;"),
|
|
quote(TermStr), words("doesn't."), nl],
|
|
Spec = error_spec(severity_error, phase_term_to_parse_tree,
|
|
[simple_msg(get_term_context(Term), [always(Pieces)])]),
|
|
MaybeIOM = error1([Spec])
|
|
;
|
|
SymNameSpecifier =
|
|
sym_name_specifier_name_arity(SymName, Arity),
|
|
( if ( Arity = 0 ; Arity = 2 ) then
|
|
ItemInitialise = item_initialise_info(SymName, Arity,
|
|
item_origin_user, Context, SeqNum),
|
|
Item = item_initialise(ItemInitialise),
|
|
MaybeIOM = ok1(iom_item(Item))
|
|
else
|
|
TermStr = describe_error_term(VarSet, Term),
|
|
Pieces = [words("Error:"), decl("initialise"),
|
|
words("declaration specifies a predicate,"),
|
|
quote(TermStr), suffix(","), words("whose arity"),
|
|
words("is not zero or two."), nl],
|
|
Spec = error_spec(severity_error, phase_term_to_parse_tree,
|
|
[simple_msg(get_term_context(Term),
|
|
[always(Pieces)])]),
|
|
MaybeIOM = error1([Spec])
|
|
)
|
|
)
|
|
)
|
|
else
|
|
Pieces = [words("Error: an"), decl("initialise"), words("declaration"),
|
|
words("should have the form"),
|
|
quote(":- initialise pred_name/pred_arity."), nl],
|
|
Spec = error_spec(severity_error, phase_term_to_parse_tree,
|
|
[simple_msg(Context, [always(Pieces)])]),
|
|
MaybeIOM = error1([Spec])
|
|
).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
parse_finalise_item(_ModuleName, VarSet, ArgTerms, Context, SeqNum,
|
|
MaybeIOM) :-
|
|
( if ArgTerms = [Term] then
|
|
parse_symbol_name_specifier(VarSet, Term, MaybeSymNameSpecifier),
|
|
(
|
|
MaybeSymNameSpecifier = error1(Specs),
|
|
MaybeIOM = error1(Specs)
|
|
;
|
|
MaybeSymNameSpecifier = ok1(SymNameSpecifier),
|
|
(
|
|
SymNameSpecifier = sym_name_specifier_name(_),
|
|
TermStr = describe_error_term(VarSet, Term),
|
|
Pieces = [words("Error:"), decl("finalise"),
|
|
words("declaration"), words("requires arity, found"),
|
|
fixed(TermStr), suffix("."), nl],
|
|
Spec = error_spec(severity_error, phase_term_to_parse_tree,
|
|
[simple_msg(get_term_context(Term), [always(Pieces)])]),
|
|
MaybeIOM = error1([Spec])
|
|
;
|
|
SymNameSpecifier =
|
|
sym_name_specifier_name_arity(SymName, Arity),
|
|
( if ( Arity = 0 ; Arity = 2 ) then
|
|
ItemFinalise = item_finalise_info(SymName, Arity,
|
|
item_origin_user, Context, SeqNum),
|
|
Item = item_finalise(ItemFinalise),
|
|
MaybeIOM = ok1(iom_item(Item))
|
|
else
|
|
TermStr = describe_error_term(VarSet, Term),
|
|
Pieces = [words("Error:"), decl("finalise"),
|
|
words("declaration specifies a predicate"),
|
|
words("whose arity is not zero or two:"),
|
|
words(TermStr), suffix("."), nl],
|
|
Spec = error_spec(severity_error, phase_term_to_parse_tree,
|
|
[simple_msg(get_term_context(Term),
|
|
[always(Pieces)])]),
|
|
MaybeIOM = error1([Spec])
|
|
)
|
|
)
|
|
)
|
|
else
|
|
Pieces = [words("Error: a"), decl("finalise"), words("declaration"),
|
|
words("should have the form"),
|
|
quote(":- finalise pred_name/pred_arity."), nl],
|
|
Spec = error_spec(severity_error, phase_term_to_parse_tree,
|
|
[simple_msg(Context, [always(Pieces)])]),
|
|
MaybeIOM = error1([Spec])
|
|
).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
parse_mutable_item(ModuleName, VarSet, ArgTerms, Context, SeqNum, MaybeIOM) :-
|
|
parse_mutable_decl_info(ModuleName, VarSet, ArgTerms, Context, SeqNum,
|
|
mutable_locn_item, MaybeItemMutableInfo),
|
|
(
|
|
MaybeItemMutableInfo = ok1(ItemMutableInfo),
|
|
MaybeIOM = ok1(iom_item(item_mutable(ItemMutableInfo)))
|
|
;
|
|
MaybeItemMutableInfo = error1(Specs),
|
|
MaybeIOM = error1(Specs)
|
|
).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
parse_mutable_decl_info(_ModuleName, VarSet, ArgTerms, Context, SeqNum,
|
|
MutableLocn, MaybeItemMutableInfo) :-
|
|
( if
|
|
ArgTerms = [NameTerm, TypeTerm, ValueTerm, InstTerm | OptMutAttrsTerm],
|
|
% The list of attributes is optional.
|
|
(
|
|
OptMutAttrsTerm = [],
|
|
MaybeAttrsTerm = no
|
|
;
|
|
OptMutAttrsTerm = [MutAttrsTerm0],
|
|
MaybeAttrsTerm = yes(MutAttrsTerm0)
|
|
)
|
|
then
|
|
parse_mutable_name(NameTerm, MaybeName),
|
|
parse_mutable_type(VarSet, TypeTerm, MaybeType),
|
|
term.coerce(ValueTerm, Value),
|
|
varset.coerce(VarSet, ProgVarSet),
|
|
parse_mutable_inst(VarSet, InstTerm, MaybeInst),
|
|
|
|
(
|
|
MaybeAttrsTerm = no,
|
|
MaybeMutAttrs = ok1(default_mutable_attributes)
|
|
;
|
|
MaybeAttrsTerm = yes(MutAttrsTerm),
|
|
parse_mutable_attrs(VarSet, MutAttrsTerm, MaybeMutAttrs)
|
|
),
|
|
( if
|
|
MaybeName = ok1(Name),
|
|
MaybeType = ok1(Type),
|
|
MaybeInst = ok1(Inst),
|
|
MaybeMutAttrs = ok1(MutAttrs)
|
|
then
|
|
% We *must* attach the varset to the mutable item because if the
|
|
% initial value is non-ground, then the initial value will be a
|
|
% variable and the mutable initialisation predicate will contain
|
|
% references to it. Ignoring the varset may lead to later compiler
|
|
% passes attempting to reuse this variable when fresh variables are
|
|
% allocated.
|
|
ItemMutableInfo = item_mutable_info(Name, Type, Type, Inst, Inst,
|
|
Value, ProgVarSet, MutAttrs, Context, SeqNum),
|
|
MaybeItemMutableInfo = ok1(ItemMutableInfo)
|
|
else
|
|
Specs = get_any_errors1(MaybeName) ++ get_any_errors1(MaybeType) ++
|
|
get_any_errors1(MaybeInst) ++ get_any_errors1(MaybeMutAttrs),
|
|
MaybeItemMutableInfo = error1(Specs)
|
|
)
|
|
else
|
|
Form1 = "mutable(name, type, init_value, inst)",
|
|
Form2 = "mutable(name, type, init_value, inst, [attr1, ...])",
|
|
(
|
|
MutableLocn = mutable_locn_item,
|
|
WhatPieces = [words("a"), decl("mutable"), words("declaration")],
|
|
Prefix = ":- ",
|
|
Suffix1 = "."
|
|
;
|
|
MutableLocn = mutable_locn_in_solver_type,
|
|
WhatPieces = [words("a"), decl("mutable"),
|
|
words("representing part of the constraint store")],
|
|
Prefix = "",
|
|
Suffix1 = ""
|
|
),
|
|
Pieces = [words("Error:") | WhatPieces] ++
|
|
[words("should have the form"), quote(Prefix ++ Form1 ++ Suffix1),
|
|
words("or the form"), quote(Prefix ++ Form2 ++ "."), nl],
|
|
Spec = error_spec(severity_error, phase_term_to_parse_tree,
|
|
[simple_msg(Context, [always(Pieces)])]),
|
|
MaybeItemMutableInfo = error1([Spec])
|
|
).
|
|
|
|
:- pred parse_mutable_name(term::in, maybe1(string)::out) is det.
|
|
|
|
parse_mutable_name(NameTerm, MaybeName) :-
|
|
( if NameTerm = term.functor(atom(Name), [], _) then
|
|
MaybeName = ok1(Name)
|
|
else
|
|
Pieces = [words("Error: invalid mutable name."), nl],
|
|
Spec = error_spec(severity_error, phase_term_to_parse_tree,
|
|
[simple_msg(get_term_context(NameTerm), [always(Pieces)])]),
|
|
MaybeName = error1([Spec])
|
|
).
|
|
|
|
:- pred parse_mutable_type(varset::in, term::in, maybe1(mer_type)::out) is det.
|
|
|
|
parse_mutable_type(VarSet, TypeTerm, MaybeType) :-
|
|
( if term.contains_var(TypeTerm, _) then
|
|
TypeTermStr = describe_error_term(VarSet, TypeTerm),
|
|
Pieces = [words("Error: the type in a"), decl("mutable"),
|
|
words("declaration cannot contain variables:"),
|
|
words(TypeTermStr), suffix("."), nl],
|
|
Spec = error_spec(severity_error, phase_term_to_parse_tree,
|
|
[simple_msg(get_term_context(TypeTerm), [always(Pieces)])]),
|
|
MaybeType = error1([Spec])
|
|
else
|
|
ContextPieces = cord.init,
|
|
parse_type(no_allow_ho_inst_info(wnhii_mutable_decl),
|
|
VarSet, ContextPieces, TypeTerm, MaybeType)
|
|
).
|
|
|
|
:- pred parse_mutable_inst(varset::in, term::in, maybe1(mer_inst)::out) is det.
|
|
|
|
parse_mutable_inst(VarSet, InstTerm, MaybeInst) :-
|
|
% XXX We should check whether the *inst* contains variables, not whether
|
|
% the *term* does, but (a) inst_contains_inst_var is in inst_match.m,
|
|
% not in inst_util.m, and (b) it is not exported.
|
|
( if term.contains_var(InstTerm, _) then
|
|
InstTermStr = describe_error_term(VarSet, InstTerm),
|
|
Pieces = [words("Error: the inst in a"), decl("mutable"),
|
|
words("declaration cannot contain variables:"),
|
|
words(InstTermStr), suffix("."), nl],
|
|
Spec = error_spec(severity_error, phase_term_to_parse_tree,
|
|
[simple_msg(get_term_context(InstTerm), [always(Pieces)])]),
|
|
MaybeInst = error1([Spec])
|
|
else
|
|
ContextPieces = cord.from_list([words("In a"), decl("mutable"),
|
|
words("declaration:")]),
|
|
parse_inst(no_allow_constrained_inst_var(wnciv_mutable_inst),
|
|
VarSet, ContextPieces, InstTerm, MaybeInst)
|
|
).
|
|
|
|
:- type collected_mutable_attribute
|
|
---> mutable_attr_trailed(mutable_trailed)
|
|
; mutable_attr_foreign_name(foreign_name)
|
|
; mutable_attr_attach_to_io_state(mutable_attach_to_io_state)
|
|
; mutable_attr_constant(mutable_constant)
|
|
; mutable_attr_thread_local(mutable_thread_local).
|
|
|
|
:- pred parse_mutable_attrs(varset::in, term::in,
|
|
maybe1(mutable_var_attributes)::out) is det.
|
|
|
|
parse_mutable_attrs(VarSet, MutAttrsTerm, MaybeMutAttrs) :-
|
|
Attributes0 = default_mutable_attributes,
|
|
ConflictingAttributes = [
|
|
mutable_attr_trailed(mutable_trailed) -
|
|
mutable_attr_trailed(mutable_untrailed),
|
|
mutable_attr_trailed(mutable_trailed) -
|
|
mutable_attr_thread_local(mutable_thread_local),
|
|
mutable_attr_constant(mutable_constant) -
|
|
mutable_attr_trailed(mutable_trailed),
|
|
mutable_attr_constant(mutable_constant) -
|
|
mutable_attr_attach_to_io_state(mutable_attach_to_io_state),
|
|
mutable_attr_constant(mutable_constant) -
|
|
mutable_attr_thread_local(mutable_thread_local)
|
|
],
|
|
( if
|
|
list_term_to_term_list(MutAttrsTerm, MutAttrTerms),
|
|
map_parser(parse_mutable_attr, MutAttrTerms, MaybeAttrList),
|
|
MaybeAttrList = ok1(CollectedMutAttrs)
|
|
then
|
|
% We check for trailed/untrailed, constant/trailed,
|
|
% trailed/thread_local, constant/attach_to_io_state,
|
|
% constant/thread_local conflicts here and deal with conflicting
|
|
% foreign_name attributes in make_hlds_passes.m.
|
|
( if
|
|
list.member(Conflict1 - Conflict2, ConflictingAttributes),
|
|
list.member(Conflict1, CollectedMutAttrs),
|
|
list.member(Conflict2, CollectedMutAttrs)
|
|
then
|
|
% XXX Should generate more specific error message.
|
|
MutAttrsStr = mercury_term_to_string(VarSet, print_name_only,
|
|
MutAttrsTerm),
|
|
Pieces = [words("Error: conflicting attributes"),
|
|
words("in attribute list:"), nl,
|
|
words(MutAttrsStr), suffix("."), nl],
|
|
Spec = error_spec(severity_error, phase_term_to_parse_tree,
|
|
[simple_msg(get_term_context(MutAttrsTerm),
|
|
[always(Pieces)])]),
|
|
MaybeMutAttrs = error1([Spec])
|
|
else
|
|
list.foldl(process_mutable_attribute, CollectedMutAttrs,
|
|
Attributes0, Attributes),
|
|
MaybeMutAttrs = ok1(Attributes)
|
|
)
|
|
else
|
|
MutAttrsStr = mercury_term_to_string(VarSet, print_name_only,
|
|
MutAttrsTerm),
|
|
Pieces = [words("Error: malformed attribute list"),
|
|
words("in"), decl("mutable"), words("declaration:"),
|
|
words(MutAttrsStr), suffix("."), nl],
|
|
Spec = error_spec(severity_error, phase_term_to_parse_tree,
|
|
[simple_msg(get_term_context(MutAttrsTerm), [always(Pieces)])]),
|
|
MaybeMutAttrs = error1([Spec])
|
|
).
|
|
|
|
:- pred process_mutable_attribute(collected_mutable_attribute::in,
|
|
mutable_var_attributes::in, mutable_var_attributes::out) is det.
|
|
|
|
process_mutable_attribute(mutable_attr_trailed(Trailed), !Attributes) :-
|
|
set_mutable_var_trailed(Trailed, !Attributes).
|
|
process_mutable_attribute(mutable_attr_foreign_name(ForeignName),
|
|
!Attributes) :-
|
|
set_mutable_add_foreign_name(ForeignName, !Attributes).
|
|
process_mutable_attribute(mutable_attr_attach_to_io_state(AttachToIOState),
|
|
!Attributes) :-
|
|
set_mutable_var_attach_to_io_state(AttachToIOState, !Attributes).
|
|
process_mutable_attribute(mutable_attr_constant(Constant), !Attributes) :-
|
|
set_mutable_var_constant(Constant, !Attributes),
|
|
(
|
|
Constant = mutable_constant,
|
|
set_mutable_var_trailed(mutable_untrailed, !Attributes),
|
|
set_mutable_var_attach_to_io_state(mutable_dont_attach_to_io_state,
|
|
!Attributes)
|
|
;
|
|
Constant = mutable_not_constant
|
|
).
|
|
process_mutable_attribute(mutable_attr_thread_local(ThrLocal), !Attributes) :-
|
|
set_mutable_var_thread_local(ThrLocal, !Attributes).
|
|
|
|
:- pred parse_mutable_attr(term::in,
|
|
maybe1(collected_mutable_attribute)::out) is det.
|
|
|
|
parse_mutable_attr(MutAttrTerm, MutAttrResult) :-
|
|
( if
|
|
MutAttrTerm = term.functor(term.atom(String), [], _),
|
|
(
|
|
String = "untrailed",
|
|
MutAttr = mutable_attr_trailed(mutable_untrailed)
|
|
;
|
|
String = "trailed",
|
|
MutAttr = mutable_attr_trailed(mutable_trailed)
|
|
;
|
|
String = "attach_to_io_state",
|
|
MutAttr = mutable_attr_attach_to_io_state(
|
|
mutable_attach_to_io_state)
|
|
;
|
|
String = "constant",
|
|
MutAttr = mutable_attr_constant(mutable_constant)
|
|
;
|
|
String = "thread_local",
|
|
MutAttr = mutable_attr_thread_local(mutable_thread_local)
|
|
)
|
|
then
|
|
MutAttrResult = ok1(MutAttr)
|
|
else if
|
|
MutAttrTerm = term.functor(term.atom("foreign_name"), Args, _),
|
|
Args = [LangTerm, ForeignNameTerm],
|
|
term_to_foreign_language(LangTerm, Lang),
|
|
ForeignNameTerm = term.functor(term.string(ForeignName), [], _)
|
|
then
|
|
MutAttr = mutable_attr_foreign_name(foreign_name(Lang, ForeignName)),
|
|
MutAttrResult = ok1(MutAttr)
|
|
else
|
|
Pieces = [words("Error: unrecognised attribute"),
|
|
words("in"), decl("mutable"), words("declaration."), nl],
|
|
Spec = error_spec(severity_error, phase_term_to_parse_tree,
|
|
[simple_msg(get_term_context(MutAttrTerm), [always(Pieces)])]),
|
|
MutAttrResult = error1([Spec])
|
|
).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
:- end_module parse_tree.parse_mutable.
|
|
%---------------------------------------------------------------------------%
|