mirror of
https://github.com/Mercury-Language/mercury.git
synced 2025-12-14 21:35:49 +00:00
b2012c0c0e
Estimated hours taken: 8 Branches: main compiler/*.m: Rename the types 'type', 'inst' and 'mode' to 'mer_type', 'mer_inst' and 'mer_mode'. This is to avoid the need to parenthesize these type names in some contexts, and to prepare for the possibility of a parser that considers those words to be reserved words. Rename some other uses of those names (e.g. as item types in recompilation.m). Delete some redundant synonyms (prog_type, mercury_type) for mer_type. Change some type names (e.g. mlds__type) and predicate names (e.g. deforest__goal) to make them unique even without module qualification. Rename the function symbols (e.g. pure, &) that need to be renamed to avoid the need to parenthesize them. Make their replacement names more expressive. Convert some more modules to four space indentation. Avoid excessively long lines, such as those resulting from the automatic substitution of 'mer_type' for 'type'.
811 lines
32 KiB
Mathematica
811 lines
32 KiB
Mathematica
%-----------------------------------------------------------------------------%
|
|
% vim: ft=mercury ts=4 sw=4 et
|
|
%-----------------------------------------------------------------------------%
|
|
% Copyright (C) 1993-2005 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.
|
|
%-----------------------------------------------------------------------------%
|
|
%
|
|
% This submodule of make_hlds handles the declarations of new types.
|
|
|
|
:- module hlds__make_hlds__add_type.
|
|
:- interface.
|
|
|
|
:- import_module hlds__hlds_data.
|
|
:- import_module hlds__hlds_pred.
|
|
:- import_module hlds__hlds_module.
|
|
:- import_module hlds__make_hlds__make_hlds_passes.
|
|
:- import_module mdbcomp__prim_data.
|
|
:- import_module parse_tree__prog_data.
|
|
|
|
:- import_module bool.
|
|
:- import_module io.
|
|
:- import_module list.
|
|
|
|
% We allow more than one "definition" for a given type so
|
|
% long all of them except one are actually just declarations,
|
|
% e.g. `:- type t.', which is parsed as an type definition for
|
|
% t which defines t as an abstract_type.
|
|
%
|
|
:- pred module_add_type_defn(tvarset::in, sym_name::in, list(type_param)::in,
|
|
type_defn::in, condition::in, prog_context::in, item_status::in,
|
|
module_info::in, module_info::out, io::di, io::uo) is det.
|
|
|
|
% Add the constructors and special preds for a type to the HLDS.
|
|
%
|
|
:- pred process_type_defn(type_ctor::in, hlds_type_defn::in,
|
|
bool::in, bool::out, module_info::in, module_info::out,
|
|
io::di, io::uo) is det.
|
|
|
|
:- pred make_status_abstract(import_status::in, import_status::out) is det.
|
|
|
|
:- pred combine_status(import_status::in, import_status::in,
|
|
import_status::out) is det.
|
|
|
|
:- implementation.
|
|
|
|
:- import_module backend_libs.
|
|
:- import_module backend_libs__foreign.
|
|
:- import_module check_hlds__type_util.
|
|
:- import_module hlds__make_hlds__add_special_pred.
|
|
:- import_module hlds__make_hlds__make_hlds_error.
|
|
:- import_module hlds__make_hlds__make_hlds_passes.
|
|
:- import_module hlds__make_tags.
|
|
:- import_module hlds__hlds_code_util.
|
|
:- import_module hlds__hlds_out.
|
|
:- import_module libs__globals.
|
|
:- import_module libs__options.
|
|
:- import_module parse_tree__error_util.
|
|
:- import_module parse_tree__module_qual.
|
|
:- import_module parse_tree__prog_type.
|
|
:- import_module parse_tree__prog_out.
|
|
:- import_module parse_tree__prog_util.
|
|
|
|
:- import_module assoc_list.
|
|
:- import_module int.
|
|
:- import_module map.
|
|
:- import_module multi_map.
|
|
:- import_module require.
|
|
:- import_module std_util.
|
|
:- import_module string.
|
|
:- import_module svmap.
|
|
:- import_module term.
|
|
|
|
module_add_type_defn(TVarSet, Name, Args, TypeDefn, _Cond, Context,
|
|
item_status(Status0, NeedQual), !ModuleInfo, !IO) :-
|
|
globals__io_get_globals(Globals, !IO),
|
|
list__length(Args, Arity),
|
|
TypeCtor = Name - Arity,
|
|
convert_type_defn(TypeDefn, TypeCtor, Globals, Body0),
|
|
module_info_get_type_table(!.ModuleInfo, Types0),
|
|
(
|
|
(
|
|
Body0 = abstract_type(_)
|
|
;
|
|
Body0 = du_type(_, _, _, _, _, _),
|
|
string__suffix(term__context_file(Context), ".int2")
|
|
% If the type definition comes from a .int2 file then
|
|
% we need to treat it as abstract. The constructors
|
|
% may only be used by the mode system for comparing
|
|
% `bound' insts to `ground'.
|
|
)
|
|
->
|
|
make_status_abstract(Status0, Status1)
|
|
;
|
|
Status1 = Status0
|
|
),
|
|
(
|
|
% the type is exported if *any* occurrence is exported,
|
|
% even a previous abstract occurrence
|
|
map__search(Types0, TypeCtor, OldDefn0)
|
|
->
|
|
hlds_data__get_type_defn_status(OldDefn0, OldStatus),
|
|
combine_status(Status1, OldStatus, Status),
|
|
hlds_data__get_type_defn_body(OldDefn0, OldBody0),
|
|
combine_is_solver_type(OldBody0, OldBody, Body0, Body),
|
|
( is_solver_type_is_inconsistent(OldBody, Body) ->
|
|
% The existing definition has an is_solver_type
|
|
% annotation which is different to the current
|
|
% definition.
|
|
module_info_incr_errors(!ModuleInfo),
|
|
Pieces0 = [words("In definition of type"),
|
|
fixed(describe_sym_name_and_arity(Name / Arity) ++ ":"), nl,
|
|
words("error: all definitions of a type must"),
|
|
words("have consistent `solver'"),
|
|
words("annotations")],
|
|
error_util__write_error_pieces(Context, 0, Pieces0,
|
|
!IO),
|
|
MaybeOldDefn = no
|
|
;
|
|
hlds_data__set_type_defn_body(OldBody, OldDefn0, OldDefn),
|
|
MaybeOldDefn = yes(OldDefn)
|
|
)
|
|
;
|
|
MaybeOldDefn = no,
|
|
Status = Status1,
|
|
Body = Body0
|
|
),
|
|
% XXX kind inference:
|
|
% We set the kinds to `star'. This will be different when we have a
|
|
% kind system.
|
|
map__init(KindMap),
|
|
hlds_data__set_type_defn(TVarSet, Args, KindMap, Body, Status, no,
|
|
NeedQual, Context, T),
|
|
(
|
|
MaybeOldDefn = no,
|
|
Body = foreign_type(_)
|
|
->
|
|
TypeStr = error_util__describe_sym_name_and_arity(Name / Arity),
|
|
ErrorPieces = [
|
|
words("Error: type "),
|
|
fixed(TypeStr),
|
|
words("defined as foreign_type without being declared.")
|
|
],
|
|
error_util__write_error_pieces(Context, 0, ErrorPieces, !IO),
|
|
module_info_incr_errors(!ModuleInfo)
|
|
;
|
|
MaybeOldDefn = yes(OldDefn1),
|
|
Body = foreign_type(_),
|
|
hlds_data__get_type_defn_status(OldDefn1, OldStatus1),
|
|
hlds_data__get_type_defn_body(OldDefn1, OldBody1),
|
|
OldBody1 = abstract_type(_),
|
|
status_is_exported_to_non_submodules(OldStatus1, no),
|
|
status_is_exported_to_non_submodules(Status0, yes)
|
|
->
|
|
TypeStr = error_util__describe_sym_name_and_arity(Name / Arity),
|
|
ErrorPieces = [
|
|
words("Error: pragma foreign_type "),
|
|
fixed(TypeStr),
|
|
words("must have the same visibility as the type declaration.")
|
|
],
|
|
error_util__write_error_pieces(Context, 0, ErrorPieces, !IO),
|
|
module_info_incr_errors(!ModuleInfo)
|
|
;
|
|
% if there was an existing non-abstract definition for the type
|
|
MaybeOldDefn = yes(T2),
|
|
hlds_data__get_type_defn_tvarset(T2, TVarSet_2),
|
|
hlds_data__get_type_defn_tparams(T2, Params_2),
|
|
hlds_data__get_type_defn_kind_map(T2, KindMap_2),
|
|
hlds_data__get_type_defn_body(T2, Body_2),
|
|
hlds_data__get_type_defn_context(T2, OrigContext),
|
|
hlds_data__get_type_defn_status(T2, OrigStatus),
|
|
hlds_data__get_type_defn_in_exported_eqv(T2, OrigInExportedEqv),
|
|
hlds_data__get_type_defn_need_qualifier(T2, OrigNeedQual),
|
|
Body_2 \= abstract_type(_)
|
|
->
|
|
globals__io_get_target(Target, !IO),
|
|
globals__io_lookup_bool_option(make_optimization_interface,
|
|
MakeOptInt, !IO),
|
|
( Body = foreign_type(_) ->
|
|
module_info_contains_foreign_type(!ModuleInfo)
|
|
;
|
|
true
|
|
),
|
|
(
|
|
% then if this definition was abstract, ignore it
|
|
% (but update the status of the old defn if necessary)
|
|
Body = abstract_type(_)
|
|
->
|
|
( Status = OrigStatus ->
|
|
true
|
|
;
|
|
hlds_data__set_type_defn(TVarSet_2, Params_2, KindMap_2,
|
|
Body_2, Status, OrigInExportedEqv, OrigNeedQual,
|
|
OrigContext, T3),
|
|
map__det_update(Types0, TypeCtor, T3, Types),
|
|
module_info_set_type_table(Types, !ModuleInfo)
|
|
)
|
|
;
|
|
merge_foreign_type_bodies(Target, MakeOptInt, Body, Body_2,
|
|
NewBody)
|
|
->
|
|
( check_foreign_type_visibility(OrigStatus, Status1) ->
|
|
hlds_data__set_type_defn(TVarSet_2, Params_2, KindMap_2,
|
|
NewBody, Status, OrigInExportedEqv, NeedQual, Context, T3),
|
|
map__det_update(Types0, TypeCtor, T3, Types),
|
|
module_info_set_type_table(Types, !ModuleInfo)
|
|
;
|
|
module_info_incr_errors(!ModuleInfo),
|
|
Pieces = [words("In definition of type"),
|
|
fixed(describe_sym_name_and_arity(Name / Arity) ++ ":"),
|
|
nl,
|
|
words("error: all definitions of a"),
|
|
words("type must have the same"),
|
|
words("visibility")],
|
|
error_util__write_error_pieces(Context, 0,
|
|
Pieces, !IO)
|
|
)
|
|
;
|
|
% otherwise issue an error message if the second
|
|
% definition wasn't read while reading .opt files.
|
|
Status = opt_imported
|
|
->
|
|
true
|
|
;
|
|
module_info_incr_errors(!ModuleInfo),
|
|
multiple_def_error(Status, Name, Arity, "type", Context,
|
|
OrigContext, _, !IO)
|
|
)
|
|
;
|
|
map__set(Types0, TypeCtor, T, Types),
|
|
module_info_set_type_table(Types, !ModuleInfo),
|
|
(
|
|
% XXX we can't handle abstract exported
|
|
% polymorphic equivalence types with monomorphic
|
|
% bodies, because the compiler stuffs up the
|
|
% type_info handling -- the caller passes type_infos,
|
|
% but the callee expects no type_infos
|
|
Body = eqv_type(EqvType),
|
|
Status = abstract_exported,
|
|
list__member(Var, Args),
|
|
\+ type_contains_var(EqvType, Var)
|
|
->
|
|
Pieces = [words("Sorry, not implemented:"),
|
|
words("polymorphic equivalence type,"),
|
|
words("with monomorphic definition,"),
|
|
words("exported as abstract type.")],
|
|
write_error_pieces(Context, 0, Pieces, !IO),
|
|
globals__io_lookup_bool_option(verbose_errors,
|
|
VerboseErrors, !IO),
|
|
(
|
|
VerboseErrors = yes,
|
|
write_error_pieces(Context, 0, abstract_monotype_workaround,
|
|
!IO)
|
|
;
|
|
VerboseErrors = no,
|
|
globals.io_set_extra_error_info(yes, !IO)
|
|
),
|
|
io__set_exit_status(1, !IO)
|
|
;
|
|
true
|
|
)
|
|
).
|
|
|
|
:- func abstract_monotype_workaround = list(format_component).
|
|
|
|
abstract_monotype_workaround = [
|
|
words("A quick work-around is to just export the type as a concrete,"),
|
|
words("type by putting the type definition in the interface section."),
|
|
words("A better work-around is to use a ""wrapper"" type, with just one"),
|
|
words("functor that has just one arg, instead of an equivalence type."),
|
|
words("(There's no performance penalty for this -- the compiler will"),
|
|
words("optimize the wrapper away.)")
|
|
].
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
% We do not have syntax for adding `solver' annotations to
|
|
% `:- pragma foreign_type' declarations, so foreign_type bodies
|
|
% default to having an is_solver_type field of `non_solver_type'.
|
|
% If another declaration for the type has a `solver' annotation then
|
|
% we must update the foreign_type body to reflect this.
|
|
%
|
|
% rafe: XXX think it should be an error for foreign types to
|
|
% be solver types.
|
|
%
|
|
:- pred combine_is_solver_type(hlds_type_body::in, hlds_type_body::out,
|
|
hlds_type_body::in, hlds_type_body::out) is det.
|
|
|
|
combine_is_solver_type(OldBody, OldBody, Body, Body).
|
|
|
|
% Succeed iff the two type bodies have inconsistent is_solver_type
|
|
% annotations.
|
|
:- pred is_solver_type_is_inconsistent(hlds_type_body::in, hlds_type_body::in)
|
|
is semidet.
|
|
|
|
is_solver_type_is_inconsistent(OldBody, Body) :-
|
|
maybe_get_body_is_solver_type(OldBody, OldIsSolverType),
|
|
maybe_get_body_is_solver_type(Body, IsSolverType),
|
|
OldIsSolverType \= IsSolverType.
|
|
|
|
:- pred maybe_get_body_is_solver_type(hlds_type_body::in, is_solver_type::out)
|
|
is semidet.
|
|
|
|
maybe_get_body_is_solver_type(abstract_type(IsSolverType), IsSolverType).
|
|
maybe_get_body_is_solver_type(solver_type(_, _), solver_type).
|
|
|
|
% check_foreign_type_visibility(OldStatus, NewDefnStatus).
|
|
%
|
|
% Check that the visibility of the new definition for
|
|
% a foreign type matches that of previous definitions.
|
|
%
|
|
:- pred check_foreign_type_visibility(import_status::in,
|
|
import_status::in) is semidet.
|
|
|
|
check_foreign_type_visibility(OldStatus, NewDefnStatus) :-
|
|
( OldStatus = abstract_exported ->
|
|
% If OldStatus is abstract_exported, the previous
|
|
% definitions were local.
|
|
status_is_exported_to_non_submodules(NewDefnStatus, no)
|
|
; OldStatus = exported ->
|
|
NewDefnStatus = exported
|
|
;
|
|
status_is_exported_to_non_submodules(OldStatus, no),
|
|
status_is_exported_to_non_submodules(NewDefnStatus, no)
|
|
).
|
|
|
|
process_type_defn(TypeCtor, TypeDefn, !FoundError, !ModuleInfo, !IO) :-
|
|
hlds_data__get_type_defn_context(TypeDefn, Context),
|
|
hlds_data__get_type_defn_tvarset(TypeDefn, TVarSet),
|
|
hlds_data__get_type_defn_tparams(TypeDefn, Args),
|
|
hlds_data__get_type_defn_body(TypeDefn, Body),
|
|
hlds_data__get_type_defn_status(TypeDefn, Status),
|
|
hlds_data__get_type_defn_need_qualifier(TypeDefn, NeedQual),
|
|
(
|
|
ConsList = Body ^ du_type_ctors,
|
|
UserEqCmp = Body ^ du_type_usereq,
|
|
ReservedTag = Body ^ du_type_reserved_tag,
|
|
module_info_get_cons_table(!.ModuleInfo, Ctors0),
|
|
module_info_get_partial_qualifier_info(!.ModuleInfo, PQInfo),
|
|
check_for_errors(
|
|
(pred(M0::in, M::out, IO0::di, IO::uo) is det :-
|
|
module_info_get_ctor_field_table(M0, CtorFields0),
|
|
ctors_add(ConsList, TypeCtor, TVarSet, NeedQual, PQInfo,
|
|
Context, Status, CtorFields0, CtorFields, Ctors0, Ctors,
|
|
IO0, IO),
|
|
module_info_set_cons_table(Ctors, M0, M1),
|
|
module_info_set_ctor_field_table(CtorFields, M1, M)
|
|
), NewFoundError, !ModuleInfo, !IO),
|
|
|
|
globals__io_get_globals(Globals, !IO),
|
|
(
|
|
type_with_constructors_should_be_no_tag(Globals, TypeCtor,
|
|
ReservedTag, ConsList, UserEqCmp, Name, CtorArgType, _)
|
|
->
|
|
NoTagType = no_tag_type(Args, Name, CtorArgType),
|
|
module_info_get_no_tag_types(!.ModuleInfo, NoTagTypes0),
|
|
map__set(NoTagTypes0, TypeCtor, NoTagType, NoTagTypes),
|
|
module_info_set_no_tag_types(NoTagTypes, !ModuleInfo)
|
|
;
|
|
true
|
|
)
|
|
;
|
|
Body = abstract_type(_),
|
|
NewFoundError = no
|
|
;
|
|
Body = solver_type(_, _),
|
|
NewFoundError = no
|
|
;
|
|
Body = eqv_type(_),
|
|
NewFoundError = no
|
|
;
|
|
Body = foreign_type(ForeignTypeBody),
|
|
check_foreign_type(TypeCtor, ForeignTypeBody, Context,
|
|
NewFoundError, !ModuleInfo, !IO)
|
|
),
|
|
!:FoundError = !.FoundError `and` NewFoundError,
|
|
(
|
|
!.FoundError = yes
|
|
->
|
|
true
|
|
;
|
|
% Equivalence types are fully expanded on the IL and Java
|
|
% backends, so the special predicates aren't required.
|
|
are_equivalence_types_expanded(!.ModuleInfo),
|
|
Body = eqv_type(_)
|
|
->
|
|
true
|
|
;
|
|
% XXX kind inference:
|
|
% We set the kinds to `star'. This will be different when we have
|
|
% a kind system.
|
|
prog_type.var_list_to_type_list(map__init, Args, ArgTypes),
|
|
construct_type(TypeCtor, ArgTypes, Type),
|
|
add_special_preds(TVarSet, Type, TypeCtor, Body, Context, Status,
|
|
!ModuleInfo)
|
|
).
|
|
|
|
% Check_foreign_type ensures that if we are generating code for
|
|
% a specific backend that the foreign type has a representation
|
|
% on that backend.
|
|
%
|
|
:- pred check_foreign_type(type_ctor::in, foreign_type_body::in,
|
|
prog_context::in, bool::out, module_info::in, module_info::out,
|
|
io::di, io::uo) is det.
|
|
|
|
check_foreign_type(TypeCtor, ForeignTypeBody, Context, FoundError, !ModuleInfo,
|
|
!IO) :-
|
|
TypeCtor = Name - Arity,
|
|
module_info_get_globals(!.ModuleInfo, Globals),
|
|
generating_code(GeneratingCode, !IO),
|
|
globals__get_target(Globals, Target),
|
|
( have_foreign_type_for_backend(Target, ForeignTypeBody, yes) ->
|
|
FoundError = no
|
|
; GeneratingCode = yes ->
|
|
%
|
|
% If we're not generating code the error may only have
|
|
% occurred because the grade options weren't passed.
|
|
%
|
|
io_lookup_bool_option(very_verbose, VeryVerbose, !IO),
|
|
(
|
|
VeryVerbose = yes,
|
|
VerboseErrorPieces = [
|
|
nl,
|
|
words("There are representations for"),
|
|
words("this type on other back-ends,"),
|
|
words("but none for this back-end.")
|
|
]
|
|
;
|
|
VeryVerbose = no,
|
|
VerboseErrorPieces = []
|
|
),
|
|
( Target = c, LangStr = "C"
|
|
; Target = il, LangStr = "IL"
|
|
; Target = java, LangStr = "Java"
|
|
; Target = asm, LangStr = "C"
|
|
),
|
|
TypeStr = error_util__describe_sym_name_and_arity(Name/Arity),
|
|
ErrorPieces = [
|
|
words("Error: no"), words(LangStr),
|
|
words("`pragma foreign_type' declaration for"),
|
|
fixed(TypeStr) | VerboseErrorPieces
|
|
],
|
|
error_util__write_error_pieces(Context, 0, ErrorPieces, !IO),
|
|
FoundError = yes,
|
|
module_info_incr_errors(!ModuleInfo)
|
|
;
|
|
FoundError = yes
|
|
).
|
|
|
|
% Do the options imply that we will generate code for a specific
|
|
% back-end?
|
|
%
|
|
:- pred generating_code(bool::out, io::di, io::uo) is det.
|
|
|
|
generating_code(bool__not(NotGeneratingCode), !IO) :-
|
|
io_lookup_bool_option(make_short_interface, MakeShortInterface, !IO),
|
|
io_lookup_bool_option(make_interface, MakeInterface, !IO),
|
|
io_lookup_bool_option(make_private_interface, MakePrivateInterface, !IO),
|
|
io_lookup_bool_option(make_transitive_opt_interface,
|
|
MakeTransOptInterface, !IO),
|
|
io_lookup_bool_option(generate_source_file_mapping, GenSrcFileMapping,
|
|
!IO),
|
|
io_lookup_bool_option(generate_dependencies, GenDepends, !IO),
|
|
io_lookup_bool_option(convert_to_mercury, ConvertToMercury, !IO),
|
|
io_lookup_bool_option(typecheck_only, TypeCheckOnly, !IO),
|
|
io_lookup_bool_option(errorcheck_only, ErrorCheckOnly, !IO),
|
|
io_lookup_bool_option(output_grade_string, OutputGradeString, !IO),
|
|
bool__or_list([MakeShortInterface, MakeInterface,
|
|
MakePrivateInterface, MakeTransOptInterface,
|
|
GenSrcFileMapping, GenDepends, ConvertToMercury,
|
|
TypeCheckOnly, ErrorCheckOnly, OutputGradeString],
|
|
NotGeneratingCode).
|
|
|
|
:- pred merge_foreign_type_bodies(compilation_target::in, bool::in,
|
|
hlds_type_body::in, hlds_type_body::in, hlds_type_body::out)
|
|
is semidet.
|
|
|
|
% Ignore Mercury definitions if we've got a foreign type
|
|
% declaration suitable for this back-end and we aren't making the
|
|
% optimization interface. We need to keep the Mercury definition
|
|
% if we are making the optimization interface so that it gets
|
|
% output in the .opt file.
|
|
%
|
|
merge_foreign_type_bodies(Target, MakeOptInterface,
|
|
foreign_type(ForeignTypeBody0), Body1, Body) :-
|
|
MaybeForeignTypeBody1 = Body1 ^ du_type_is_foreign_type,
|
|
(
|
|
MaybeForeignTypeBody1 = yes(ForeignTypeBody1)
|
|
;
|
|
MaybeForeignTypeBody1 = no,
|
|
ForeignTypeBody1 = foreign_type_body(no, no, no)
|
|
),
|
|
merge_foreign_type_bodies_2(ForeignTypeBody0, ForeignTypeBody1,
|
|
ForeignTypeBody),
|
|
(
|
|
have_foreign_type_for_backend(Target, ForeignTypeBody, yes),
|
|
MakeOptInterface = no
|
|
->
|
|
Body = foreign_type(ForeignTypeBody)
|
|
;
|
|
Body = Body1 ^ du_type_is_foreign_type := yes(ForeignTypeBody)
|
|
).
|
|
merge_foreign_type_bodies(Target, MakeOptInterface,
|
|
Body0 @ du_type(_, _, _, _, _, _),
|
|
Body1 @ foreign_type(_), Body) :-
|
|
merge_foreign_type_bodies(Target, MakeOptInterface, Body1, Body0, Body).
|
|
merge_foreign_type_bodies(_, _, foreign_type(Body0),
|
|
foreign_type(Body1),
|
|
foreign_type(Body)) :-
|
|
merge_foreign_type_bodies_2(Body0, Body1, Body).
|
|
|
|
:- pred merge_foreign_type_bodies_2(foreign_type_body::in,
|
|
foreign_type_body::in, foreign_type_body::out) is semidet.
|
|
|
|
merge_foreign_type_bodies_2(foreign_type_body(MaybeILA, MaybeCA, MaybeJavaA),
|
|
foreign_type_body(MaybeILB, MaybeCB, MaybeJavaB),
|
|
foreign_type_body(MaybeIL, MaybeC, MaybeJava)) :-
|
|
merge_maybe(MaybeILA, MaybeILB, MaybeIL),
|
|
merge_maybe(MaybeCA, MaybeCB, MaybeC),
|
|
merge_maybe(MaybeJavaA, MaybeJavaB, MaybeJava).
|
|
|
|
:- pred merge_maybe(maybe(T)::in, maybe(T)::in, maybe(T)::out) is semidet.
|
|
|
|
merge_maybe(no, no, no).
|
|
merge_maybe(yes(T), no, yes(T)).
|
|
merge_maybe(no, yes(T), yes(T)).
|
|
|
|
make_status_abstract(Status, AbstractStatus) :-
|
|
( Status = exported ->
|
|
AbstractStatus = abstract_exported
|
|
; Status = imported(_) ->
|
|
AbstractStatus = abstract_imported
|
|
;
|
|
AbstractStatus = Status
|
|
).
|
|
|
|
combine_status(StatusA, StatusB, Status) :-
|
|
( combine_status_2(StatusA, StatusB, CombinedStatus) ->
|
|
Status = CombinedStatus
|
|
;
|
|
error("unexpected status for type definition")
|
|
).
|
|
|
|
:- pred combine_status_2(import_status::in, import_status::in,
|
|
import_status::out) is semidet.
|
|
|
|
combine_status_2(imported(_), Status2, Status) :-
|
|
combine_status_imported(Status2, Status).
|
|
combine_status_2(local, Status2, Status) :-
|
|
combine_status_local(Status2, Status).
|
|
combine_status_2(exported, _Status2, exported).
|
|
combine_status_2(exported_to_submodules, Status2, Status) :-
|
|
combine_status_local(Status2, Status3),
|
|
( Status3 = local ->
|
|
Status = exported_to_submodules
|
|
;
|
|
Status = Status3
|
|
).
|
|
combine_status_2(opt_imported, _Status2, opt_imported).
|
|
combine_status_2(abstract_imported, Status2, Status) :-
|
|
combine_status_abstract_imported(Status2, Status).
|
|
combine_status_2(abstract_exported, Status2, Status) :-
|
|
combine_status_abstract_exported(Status2, Status).
|
|
|
|
:- pred combine_status_imported(import_status::in, import_status::out)
|
|
is semidet.
|
|
|
|
combine_status_imported(imported(Section), imported(Section)).
|
|
combine_status_imported(local, imported(implementation)).
|
|
combine_status_imported(exported, exported).
|
|
combine_status_imported(opt_imported, opt_imported).
|
|
combine_status_imported(abstract_imported, imported(interface)).
|
|
combine_status_imported(abstract_exported, abstract_exported).
|
|
|
|
:- pred combine_status_local(import_status::in, import_status::out) is semidet.
|
|
|
|
combine_status_local(exported_to_submodules, exported_to_submodules).
|
|
combine_status_local(imported(_), local).
|
|
combine_status_local(local, local).
|
|
combine_status_local(exported, exported).
|
|
combine_status_local(opt_imported, local).
|
|
combine_status_local(abstract_imported, local).
|
|
combine_status_local(abstract_exported, abstract_exported).
|
|
|
|
:- pred combine_status_abstract_exported(import_status::in, import_status::out)
|
|
is det.
|
|
|
|
combine_status_abstract_exported(Status2, Status) :-
|
|
( Status2 = exported ->
|
|
Status = exported
|
|
;
|
|
Status = abstract_exported
|
|
).
|
|
|
|
:- pred combine_status_abstract_imported(import_status::in, import_status::out)
|
|
is det.
|
|
|
|
combine_status_abstract_imported(Status2, Status) :-
|
|
( Status2 = imported(Section) ->
|
|
Status = imported(Section)
|
|
;
|
|
Status = abstract_imported
|
|
).
|
|
|
|
:- pred convert_type_defn(type_defn::in, type_ctor::in, globals::in,
|
|
hlds_type_body::out) is det.
|
|
|
|
convert_type_defn(du_type(Body, MaybeUserEqComp), TypeCtor, Globals,
|
|
HLDSBody) :-
|
|
% Initially, when we first see the `:- type' definition,
|
|
% we assign the constructor tags assuming that there is no
|
|
% `:- pragma reserve_tag' declaration for this type.
|
|
% (If it turns out that there was one, then we will recompute the
|
|
% constructor tags by calling assign_constructor_tags again,
|
|
% with ReservedTagPragma = yes, when processing the pragma.)
|
|
ReservedTagPragma = no,
|
|
assign_constructor_tags(Body, MaybeUserEqComp, TypeCtor, ReservedTagPragma,
|
|
Globals, CtorTags, IsEnum),
|
|
IsForeign = no,
|
|
HLDSBody = du_type(Body, CtorTags, IsEnum, MaybeUserEqComp,
|
|
ReservedTagPragma, IsForeign).
|
|
convert_type_defn(eqv_type(Body), _, _, eqv_type(Body)).
|
|
convert_type_defn(solver_type(SolverTypeDetails, MaybeUserEqComp), _, _,
|
|
solver_type(SolverTypeDetails, MaybeUserEqComp)).
|
|
convert_type_defn(abstract_type(IsSolverType), _, _,
|
|
abstract_type(IsSolverType)).
|
|
convert_type_defn(foreign_type(ForeignType, MaybeUserEqComp, Assertions),
|
|
_, _, foreign_type(Body)) :-
|
|
(
|
|
ForeignType = il(ILForeignType),
|
|
Data = foreign_type_lang_data(ILForeignType, MaybeUserEqComp,
|
|
Assertions),
|
|
Body = foreign_type_body(yes(Data), no, no)
|
|
;
|
|
ForeignType = c(CForeignType),
|
|
Data = foreign_type_lang_data(CForeignType, MaybeUserEqComp,
|
|
Assertions),
|
|
Body = foreign_type_body(no, yes(Data), no)
|
|
;
|
|
ForeignType = java(JavaForeignType),
|
|
Data = foreign_type_lang_data(JavaForeignType, MaybeUserEqComp,
|
|
Assertions),
|
|
Body = foreign_type_body(no, no, yes(Data))
|
|
).
|
|
|
|
:- pred ctors_add(list(constructor)::in, type_ctor::in, tvarset::in,
|
|
need_qualifier::in, partial_qualifier_info::in, prog_context::in,
|
|
import_status::in, ctor_field_table::in, ctor_field_table::out,
|
|
cons_table::in, cons_table::out, io::di, io::uo) is det.
|
|
|
|
ctors_add([], _, _, _, _, _, _, !FieldNameTable, !Ctors, !IO).
|
|
ctors_add([Ctor | Rest], TypeCtor, TVarSet, NeedQual, PQInfo, Context,
|
|
ImportStatus, !FieldNameTable, !Ctors, !IO) :-
|
|
Ctor = ctor(ExistQVars, Constraints, Name, Args),
|
|
QualifiedConsId = make_cons_id(Name, Args, TypeCtor),
|
|
ConsDefn = hlds_cons_defn(ExistQVars, Constraints, Args, TypeCtor,
|
|
Context),
|
|
%
|
|
% Insert the fully-qualified version of this cons_id into the
|
|
% cons_table.
|
|
% Also check that there is at most one definition of a given
|
|
% cons_id in each type.
|
|
%
|
|
( map__search(!.Ctors, QualifiedConsId, QualifiedConsDefns0) ->
|
|
QualifiedConsDefns1 = QualifiedConsDefns0
|
|
;
|
|
QualifiedConsDefns1 = []
|
|
),
|
|
(
|
|
list__member(OtherConsDefn, QualifiedConsDefns1),
|
|
OtherConsDefn = hlds_cons_defn(_, _, _, TypeCtor, _)
|
|
->
|
|
% XXX we should record each error using module_info_incr_errors
|
|
prog_out__write_context(Context, !IO),
|
|
io__write_string("Error: constructor `", !IO),
|
|
hlds_out__write_cons_id(QualifiedConsId, !IO),
|
|
io__write_string("' for type `", !IO),
|
|
hlds_out__write_type_ctor(TypeCtor, !IO),
|
|
io__write_string("' multiply defined.\n", !IO),
|
|
io__set_exit_status(1, !IO),
|
|
QualifiedConsDefns = QualifiedConsDefns1
|
|
;
|
|
QualifiedConsDefns = [ConsDefn | QualifiedConsDefns1]
|
|
),
|
|
svmap__set(QualifiedConsId, QualifiedConsDefns, !Ctors),
|
|
|
|
( QualifiedConsId = cons(qualified(Module, ConsName), Arity) ->
|
|
% Add unqualified version of the cons_id to the
|
|
% cons_table, if appropriate.
|
|
( NeedQual = may_be_unqualified ->
|
|
UnqualifiedConsId = cons(unqualified(ConsName), Arity),
|
|
multi_map__set(!.Ctors, UnqualifiedConsId, ConsDefn, !:Ctors)
|
|
;
|
|
true
|
|
),
|
|
|
|
% Add partially qualified versions of the cons_id
|
|
get_partial_qualifiers(Module, PQInfo, PartialQuals),
|
|
list__map_foldl(add_ctor(ConsName, Arity, ConsDefn),
|
|
PartialQuals, _PartiallyQualifiedConsIds, !Ctors),
|
|
|
|
assoc_list__keys(Args, FieldNames),
|
|
FirstField = 1,
|
|
|
|
add_ctor_field_names(FieldNames, NeedQual, PartialQuals, TypeCtor,
|
|
QualifiedConsId, Context, ImportStatus, FirstField,
|
|
!FieldNameTable, !IO)
|
|
;
|
|
error("ctors_add: cons_id not qualified")
|
|
),
|
|
ctors_add(Rest, TypeCtor, TVarSet, NeedQual, PQInfo, Context,
|
|
ImportStatus, !FieldNameTable, !Ctors, !IO).
|
|
|
|
:- pred add_ctor(string::in, int::in, hlds_cons_defn::in, module_name::in,
|
|
cons_id::out, cons_table::in, cons_table::out) is det.
|
|
|
|
add_ctor(ConsName, Arity, ConsDefn, ModuleQual, ConsId, CtorsIn, CtorsOut) :-
|
|
ConsId = cons(qualified(ModuleQual, ConsName), Arity),
|
|
multi_map__set(CtorsIn, ConsId, ConsDefn, CtorsOut).
|
|
|
|
:- pred add_ctor_field_names(list(maybe(ctor_field_name))::in,
|
|
need_qualifier::in, list(module_name)::in, type_ctor::in, cons_id::in,
|
|
prog_context::in, import_status::in, int::in,
|
|
ctor_field_table::in, ctor_field_table::out, io::di, io::uo) is det.
|
|
|
|
add_ctor_field_names([], _, _, _, _, _, _, _, !FieldNameTable, !IO).
|
|
add_ctor_field_names([MaybeFieldName | FieldNames], NeedQual,
|
|
PartialQuals, TypeCtor, ConsId, Context, ImportStatus,
|
|
FieldNumber, !FieldNameTable, !IO) :-
|
|
(
|
|
MaybeFieldName = yes(FieldName),
|
|
FieldDefn = hlds_ctor_field_defn(Context, ImportStatus, TypeCtor,
|
|
ConsId, FieldNumber),
|
|
add_ctor_field_name(FieldName, FieldDefn, NeedQual, PartialQuals,
|
|
!FieldNameTable, !IO)
|
|
;
|
|
MaybeFieldName = no
|
|
),
|
|
add_ctor_field_names(FieldNames, NeedQual, PartialQuals, TypeCtor,
|
|
ConsId, Context, ImportStatus, FieldNumber + 1,
|
|
!FieldNameTable, !IO).
|
|
|
|
:- pred add_ctor_field_name(ctor_field_name::in, hlds_ctor_field_defn::in,
|
|
need_qualifier::in, list(module_name)::in,
|
|
ctor_field_table::in, ctor_field_table::out, io::di, io::uo) is det.
|
|
|
|
add_ctor_field_name(FieldName, FieldDefn, NeedQual, PartialQuals,
|
|
!FieldNameTable, !IO) :-
|
|
( FieldName = qualified(FieldModule0, _) ->
|
|
FieldModule = FieldModule0
|
|
;
|
|
error("add_ctor_field_name: unqualified field name")
|
|
),
|
|
(
|
|
%
|
|
% Field names must be unique within a module, not
|
|
% just within a type because the function names for
|
|
% user-defined override functions for the builtin field
|
|
% access functions must be unique within a module.
|
|
%
|
|
map__search(!.FieldNameTable, FieldName, ConflictingDefns)
|
|
->
|
|
( ConflictingDefns = [ConflictingDefn] ->
|
|
ConflictingDefn = hlds_ctor_field_defn(OrigContext, _, _, _, _)
|
|
;
|
|
error("add_ctor_field_name: multiple conflicting fields")
|
|
),
|
|
|
|
% XXX we should record each error
|
|
% using module_info_incr_errors
|
|
FieldDefn = hlds_ctor_field_defn(Context, _, _, _, _),
|
|
mdbcomp__prim_data__sym_name_to_string(FieldName, FieldString),
|
|
ErrorPieces = [
|
|
words("Error: field"),
|
|
fixed(string__append_list(["`", FieldString, "'"])),
|
|
words("multiply defined.")
|
|
],
|
|
error_util__write_error_pieces(Context, 0, ErrorPieces, !IO),
|
|
|
|
% This type of error doesn't fit well with
|
|
% how error_util does things -- error_util.m
|
|
% wants to write everything with a single context.
|
|
prog_out__write_context(OrigContext, !IO),
|
|
io__write_string(" Here is the previous definition of field `", !IO),
|
|
io__write_string(FieldString, !IO),
|
|
io__write_string("'.\n", !IO),
|
|
io__set_exit_status(1, !IO)
|
|
;
|
|
unqualify_name(FieldName, UnqualFieldName),
|
|
|
|
% Add an unqualified version of the field name to the
|
|
% table, if appropriate.
|
|
( NeedQual = may_be_unqualified ->
|
|
multi_map__set(!.FieldNameTable, unqualified(UnqualFieldName),
|
|
FieldDefn, !:FieldNameTable)
|
|
;
|
|
true
|
|
),
|
|
|
|
% Add partially qualified versions of the cons_id
|
|
list__foldl(do_add_ctor_field(UnqualFieldName, FieldDefn),
|
|
[FieldModule | PartialQuals], !FieldNameTable)
|
|
).
|
|
|
|
:- pred do_add_ctor_field(string::in, hlds_ctor_field_defn::in,
|
|
module_name::in, ctor_field_table::in, ctor_field_table::out) is det.
|
|
|
|
do_add_ctor_field(FieldName, FieldNameDefn, ModuleName, !FieldNameTable) :-
|
|
multi_map__set(!.FieldNameTable, qualified(ModuleName, FieldName),
|
|
FieldNameDefn, !:FieldNameTable).
|