mirror of
https://github.com/Mercury-Language/mercury.git
synced 2025-12-16 06:14:59 +00:00
f6bdd99a80
As discussed in the recent Mercury meeting, remove support for the GCC backend.
It was very much out of date and supporting it proprerly would means having to
track changes to GCC's internals. Furthermore, its presence complicates
building the compiler.
The main thing this change does not address is the fact that we invoke
the compiler through C code, e.g. main.c in the top-level of the source
tree. This was required by the GCC backend and can now be removed, but
I will do that as a separate change.
configure.ac:
Mmake.common.in:
scripts/Mmake.rules:
compiler/Mercury.options:
compiler/Mmakefile:
compiler/gcc.m:
compiler/maybe_mlds_to_gcc.pp:
compiler/mlds_to_gcc.m:
Delete the files containing the GCC backend.
compiler/options.m:
compiler/handle_options.m:
Delete support for `--target asm' and `--pic'.
(The latter was only used by the GCC backend.)
compiler/*.m:
doc/user_guide.texi:
compiler/notes/comiler_design.html:
compiler/notes/work_in_progress.m:
Conform to the above change.
README.gcc-backend.m:
Delete this file.
873 lines
35 KiB
Mathematica
873 lines
35 KiB
Mathematica
%-----------------------------------------------------------------------------%
|
|
% vim: ft=mercury ts=4 sw=4 et
|
|
%-----------------------------------------------------------------------------%
|
|
% Copyright (C) 1993-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: add_type.m.
|
|
%
|
|
% 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.error_util.
|
|
:- import_module parse_tree.prog_data.
|
|
|
|
:- import_module bool.
|
|
:- 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,
|
|
list(error_spec)::in, list(error_spec)::out) 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,
|
|
list(error_spec)::in, list(error_spec)::out) 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 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_out.
|
|
:- import_module hlds.hlds_out.hlds_out_util.
|
|
:- import_module libs.globals.
|
|
:- import_module libs.options.
|
|
:- import_module parse_tree.module_qual.
|
|
:- import_module parse_tree.prog_type.
|
|
|
|
:- import_module int.
|
|
:- import_module map.
|
|
:- import_module multi_map.
|
|
:- import_module pair.
|
|
:- import_module require.
|
|
:- import_module string.
|
|
:- import_module term.
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
module_add_type_defn(TVarSet, Name, Args, TypeDefn, _Cond, Context,
|
|
item_status(Status0, NeedQual), !ModuleInfo, !Specs) :-
|
|
module_info_get_globals(!.ModuleInfo, Globals),
|
|
list.length(Args, Arity),
|
|
TypeCtor = type_ctor(Name, Arity),
|
|
convert_type_defn(TypeDefn, TypeCtor, Globals, Body0),
|
|
(
|
|
(
|
|
Body0 = hlds_abstract_type(_)
|
|
;
|
|
Body0 = hlds_du_type(_, _, _, _, _, _, _, _, _),
|
|
string.suffix(term.context_file(Context), ".int2")
|
|
% If the type definition comes from a .int2 file then we must
|
|
% 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
|
|
),
|
|
(
|
|
% Discriminated unions whose definition consists of a single
|
|
% zero-arity constructor are dummy types. Dummy types are not allowed
|
|
% to have user-defined equality or comparison.
|
|
|
|
TypeDefn = parse_tree_du_type(Ctors, MaybeUserUC, _MaybeDirectArg),
|
|
Ctors = [Constructor],
|
|
list.length(Constructor ^ cons_args, 0),
|
|
MaybeUserUC = yes(_),
|
|
% Only report errors for types defined in this module.
|
|
status_defined_in_this_module(Status0) = yes
|
|
->
|
|
DummyMainPieces = [words("Error: the type"),
|
|
sym_name_and_arity(Name / Arity),
|
|
words("is not allowed to have user-defined equality"),
|
|
words("or comparison.")],
|
|
DummyVerbosePieces = [words("Discriminated unions whose body"),
|
|
words("consists of a single zero-arity constructor"),
|
|
words("cannot have user-defined equality or comparison.")],
|
|
DummyMsg = simple_msg(Context,
|
|
[always(DummyMainPieces), verbose_only(DummyVerbosePieces)]),
|
|
DummySpec = error_spec(severity_error, phase_parse_tree_to_hlds,
|
|
[DummyMsg]),
|
|
!:Specs = [DummySpec | !.Specs]
|
|
;
|
|
true
|
|
),
|
|
module_info_get_type_table(!.ModuleInfo, TypeTable0),
|
|
(
|
|
% The type is exported if *any* occurrence is exported,
|
|
% even a previous abstract occurrence.
|
|
search_type_ctor_defn(TypeTable0, 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.
|
|
SolverPieces = [words("In definition of type"),
|
|
sym_name_and_arity(Name / Arity), suffix(":"), nl,
|
|
words("error: all definitions of a type must have"),
|
|
words("consistent `solver' annotations")],
|
|
SolverMsg = simple_msg(Context, [always(SolverPieces)]),
|
|
SolverSpec = error_spec(severity_error, phase_parse_tree_to_hlds,
|
|
[SolverMsg]),
|
|
!:Specs = [SolverSpec | !.Specs],
|
|
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, TypeDefn1),
|
|
(
|
|
MaybeOldDefn = no,
|
|
Body = hlds_foreign_type(_)
|
|
->
|
|
ForeignDeclPieces = [words("Error: type "),
|
|
sym_name_and_arity(Name / Arity),
|
|
words("defined as foreign_type without being declared.")],
|
|
ForeignDeclMsg = simple_msg(Context, [always(ForeignDeclPieces)]),
|
|
ForeignDeclSpec = error_spec(severity_error, phase_parse_tree_to_hlds,
|
|
[ForeignDeclMsg]),
|
|
!:Specs = [ForeignDeclSpec | !.Specs]
|
|
;
|
|
MaybeOldDefn = yes(OldDefn1),
|
|
Body = hlds_foreign_type(_),
|
|
hlds_data.get_type_defn_status(OldDefn1, OldStatus1),
|
|
hlds_data.get_type_defn_body(OldDefn1, OldBody1),
|
|
OldBody1 = hlds_abstract_type(_),
|
|
status_is_exported_to_non_submodules(OldStatus1) = no,
|
|
status_is_exported_to_non_submodules(Status0) = yes
|
|
->
|
|
ForeignVisPieces = [words("Error: pragma foreign_type "),
|
|
sym_name_and_arity(Name / Arity),
|
|
words("must have the same visibility as the type declaration.")],
|
|
ForeignVisMsg = simple_msg(Context, [always(ForeignVisPieces)]),
|
|
ForeignVisSpec = error_spec(severity_error, phase_parse_tree_to_hlds,
|
|
[ForeignVisMsg]),
|
|
!:Specs = [ForeignVisSpec | !.Specs]
|
|
;
|
|
% If there was an existing non-abstract definition for the type, ...
|
|
MaybeOldDefn = yes(OldDefn2),
|
|
hlds_data.get_type_defn_tvarset(OldDefn2, TVarSet_2),
|
|
hlds_data.get_type_defn_tparams(OldDefn2, Params_2),
|
|
hlds_data.get_type_defn_kind_map(OldDefn2, KindMap_2),
|
|
hlds_data.get_type_defn_body(OldDefn2, Body_2),
|
|
hlds_data.get_type_defn_context(OldDefn2, OrigContext),
|
|
hlds_data.get_type_defn_status(OldDefn2, OrigStatus),
|
|
hlds_data.get_type_defn_in_exported_eqv(OldDefn2, OrigInExportedEqv),
|
|
hlds_data.get_type_defn_need_qualifier(OldDefn2, OrigNeedQual),
|
|
Body_2 \= hlds_abstract_type(_)
|
|
->
|
|
globals.get_target(Globals, Target),
|
|
globals.lookup_bool_option(Globals, make_optimization_interface,
|
|
MakeOptInt),
|
|
( Body = hlds_foreign_type(_) ->
|
|
module_info_set_contains_foreign_type(!ModuleInfo)
|
|
;
|
|
true
|
|
),
|
|
(
|
|
% ... then if this definition was abstract, ignore it
|
|
% (but update the status of the old defn if necessary).
|
|
Body = hlds_abstract_type(_)
|
|
->
|
|
( Status = OrigStatus ->
|
|
true
|
|
;
|
|
hlds_data.set_type_defn(TVarSet_2, Params_2, KindMap_2,
|
|
Body_2, Status, OrigInExportedEqv, OrigNeedQual,
|
|
OrigContext, TypeDefn3),
|
|
replace_type_ctor_defn(TypeCtor, TypeDefn3,
|
|
TypeTable0, TypeTable),
|
|
module_info_set_type_table(TypeTable, !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,
|
|
TypeDefn3),
|
|
replace_type_ctor_defn(TypeCtor, TypeDefn3,
|
|
TypeTable0, TypeTable),
|
|
module_info_set_type_table(TypeTable, !ModuleInfo)
|
|
;
|
|
module_info_incr_errors(!ModuleInfo),
|
|
DiffVisPieces = [words("In definition of type"),
|
|
sym_name_and_arity(Name / Arity), suffix(":"), nl,
|
|
words("error: all definitions of a type"),
|
|
words("must have the same visibility")],
|
|
DiffVisMsg = simple_msg(Context, [always(DiffVisPieces)]),
|
|
DiffVisSpec = error_spec(severity_error,
|
|
phase_parse_tree_to_hlds, [DiffVisMsg]),
|
|
!:Specs = [DiffVisSpec | !.Specs]
|
|
)
|
|
;
|
|
% ..., otherwise issue an error message if the second
|
|
% definition wasn't read while reading .opt files.
|
|
Status = status_opt_imported
|
|
->
|
|
true
|
|
;
|
|
module_info_incr_errors(!ModuleInfo),
|
|
multiple_def_error(Status, Name, Arity, "type", Context,
|
|
OrigContext, [], !Specs)
|
|
)
|
|
;
|
|
add_or_replace_type_ctor_defn(TypeCtor, TypeDefn1,
|
|
TypeTable0, TypeTable),
|
|
module_info_set_type_table(TypeTable, !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 = hlds_eqv_type(EqvType),
|
|
Status = status_abstract_exported,
|
|
list.member(Var, Args),
|
|
\+ type_contains_var(EqvType, Var)
|
|
->
|
|
PolyEqvPieces = [words("Sorry, not implemented:"),
|
|
words("polymorphic equivalence type,"),
|
|
words("with monomorphic definition,"),
|
|
words("exported as abstract type.")],
|
|
PolyEqvMsg = simple_msg(Context,
|
|
[always(PolyEqvPieces),
|
|
verbose_only(abstract_monotype_workaround)]),
|
|
PolyEqvSpec = error_spec(severity_error, phase_parse_tree_to_hlds,
|
|
[PolyEqvMsg]),
|
|
!:Specs = [PolyEqvSpec | !.Specs]
|
|
;
|
|
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(hlds_solver_type(_, _), solver_type).
|
|
maybe_get_body_is_solver_type(hlds_abstract_type(Details), IsSolverType) :-
|
|
(
|
|
Details = abstract_type_general,
|
|
IsSolverType = non_solver_type
|
|
;
|
|
Details = abstract_enum_type(_),
|
|
IsSolverType = non_solver_type
|
|
;
|
|
Details = abstract_solver_type,
|
|
IsSolverType = 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 = status_abstract_exported ->
|
|
% If OldStatus is abstract_exported, the previous
|
|
% definitions were local.
|
|
status_is_exported_to_non_submodules(NewDefnStatus) = no
|
|
; OldStatus = status_exported ->
|
|
NewDefnStatus = status_exported
|
|
;
|
|
status_is_exported_to_non_submodules(OldStatus) = no,
|
|
status_is_exported_to_non_submodules(NewDefnStatus) = no
|
|
).
|
|
|
|
process_type_defn(TypeCtor, TypeDefn, !FoundError, !ModuleInfo, !Specs) :-
|
|
get_type_defn_context(TypeDefn, Context),
|
|
get_type_defn_tvarset(TypeDefn, TVarSet),
|
|
get_type_defn_tparams(TypeDefn, Args),
|
|
get_type_defn_kind_map(TypeDefn, KindMap),
|
|
get_type_defn_body(TypeDefn, Body),
|
|
get_type_defn_status(TypeDefn, Status),
|
|
get_type_defn_need_qualifier(TypeDefn, NeedQual),
|
|
module_info_get_globals(!.ModuleInfo, Globals),
|
|
(
|
|
Body = hlds_du_type(ConsList, _, _, _, UserEqCmp, _DirectArgCtors,
|
|
ReservedTag, _, _),
|
|
module_info_get_cons_table(!.ModuleInfo, Ctors0),
|
|
module_info_get_partial_qualifier_info(!.ModuleInfo, PQInfo),
|
|
module_info_get_ctor_field_table(!.ModuleInfo, CtorFields0),
|
|
TypeCtor = type_ctor(TypeCtorSymName, _),
|
|
(
|
|
TypeCtorSymName = unqualified(_),
|
|
unexpected($module, $pred, "unqualified TypeCtorSymName")
|
|
;
|
|
TypeCtorSymName = qualified(TypeCtorModuleName, _)
|
|
),
|
|
ctors_add(ConsList, TypeCtor, TypeCtorModuleName, TVarSet, Args,
|
|
KindMap, NeedQual, PQInfo, Context, Status,
|
|
CtorFields0, CtorFields, Ctors0, Ctors, [], CtorAddSpecs),
|
|
module_info_set_cons_table(Ctors, !ModuleInfo),
|
|
module_info_set_ctor_field_table(CtorFields, !ModuleInfo),
|
|
|
|
(
|
|
CtorAddSpecs = [],
|
|
NewFoundError = no
|
|
;
|
|
CtorAddSpecs = [_ | _],
|
|
NewFoundError = yes,
|
|
!:Specs = CtorAddSpecs ++ !.Specs
|
|
),
|
|
|
|
% XXX Why is this being done now, rather than *after* all the types
|
|
% have been added into the HLDS?
|
|
(
|
|
type_ctor_should_be_notag(Globals, TypeCtor,
|
|
ReservedTag, ConsList, UserEqCmp, CtorName, CtorArgType, _)
|
|
->
|
|
NoTagType = no_tag_type(Args, CtorName, CtorArgType),
|
|
module_info_get_no_tag_types(!.ModuleInfo, NoTagTypes0),
|
|
map.set(TypeCtor, NoTagType, NoTagTypes0, NoTagTypes),
|
|
module_info_set_no_tag_types(NoTagTypes, !ModuleInfo)
|
|
;
|
|
true
|
|
)
|
|
;
|
|
( Body = hlds_abstract_type(_)
|
|
; Body = hlds_solver_type(_, _)
|
|
; Body = hlds_eqv_type(_)
|
|
),
|
|
NewFoundError = no
|
|
;
|
|
Body = hlds_foreign_type(ForeignTypeBody),
|
|
check_foreign_type(TypeCtor, ForeignTypeBody, Context,
|
|
NewFoundError, !ModuleInfo, !Specs)
|
|
),
|
|
!:FoundError = !.FoundError `or` NewFoundError,
|
|
(
|
|
!.FoundError = yes
|
|
;
|
|
!.FoundError = no,
|
|
% 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,
|
|
list(error_spec)::in, list(error_spec)::out) is det.
|
|
|
|
check_foreign_type(TypeCtor, ForeignTypeBody, Context, FoundError, !ModuleInfo,
|
|
!Specs) :-
|
|
TypeCtor = type_ctor(Name, Arity),
|
|
module_info_get_globals(!.ModuleInfo, Globals),
|
|
globals.get_target(Globals, Target),
|
|
( have_foreign_type_for_backend(Target, ForeignTypeBody, yes) ->
|
|
FoundError = no
|
|
;
|
|
( Target = target_c, LangStr = "C"
|
|
; Target = target_il, LangStr = "IL"
|
|
; Target = target_csharp, LangStr = "C#"
|
|
; Target = target_java, LangStr = "Java"
|
|
; Target = target_x86_64, LangStr = "C"
|
|
; Target = target_erlang, LangStr = "Erlang"
|
|
),
|
|
MainPieces = [words("Error: no"), fixed(LangStr),
|
|
fixed("`pragma foreign_type'"), words("declaration for"),
|
|
sym_name_and_arity(Name/Arity), nl],
|
|
VerbosePieces = [words("There are representations for this type"),
|
|
words("on other back-ends, but none for this back-end."), nl],
|
|
Msg = simple_msg(Context,
|
|
[always(MainPieces),
|
|
option_is_set(very_verbose, yes, [always(VerbosePieces)])]),
|
|
Spec = error_spec(severity_error, phase_parse_tree_to_hlds,
|
|
[Msg]),
|
|
!:Specs = [Spec | !.Specs],
|
|
FoundError = yes
|
|
).
|
|
|
|
% 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.
|
|
%
|
|
:- pred merge_foreign_type_bodies(compilation_target::in, bool::in,
|
|
hlds_type_body::in, hlds_type_body::in, hlds_type_body::out)
|
|
is semidet.
|
|
|
|
merge_foreign_type_bodies(Target, MakeOptInterface,
|
|
hlds_foreign_type(ForeignTypeBody0), Body1, Body) :-
|
|
MaybeForeignTypeBody1 = Body1 ^ du_type_is_foreign_type,
|
|
(
|
|
MaybeForeignTypeBody1 = yes(ForeignTypeBody1)
|
|
;
|
|
MaybeForeignTypeBody1 = no,
|
|
ForeignTypeBody1 = foreign_type_body(no, no, no, no, no)
|
|
),
|
|
merge_foreign_type_bodies_2(ForeignTypeBody0, ForeignTypeBody1,
|
|
ForeignTypeBody),
|
|
(
|
|
have_foreign_type_for_backend(Target, ForeignTypeBody, yes),
|
|
MakeOptInterface = no
|
|
->
|
|
Body = hlds_foreign_type(ForeignTypeBody)
|
|
;
|
|
Body = Body1 ^ du_type_is_foreign_type := yes(ForeignTypeBody)
|
|
).
|
|
merge_foreign_type_bodies(Target, MakeOptInterface,
|
|
Body0 @ hlds_du_type(_, _, _, _, _, _, _, _, _),
|
|
Body1 @ hlds_foreign_type(_), Body) :-
|
|
merge_foreign_type_bodies(Target, MakeOptInterface, Body1, Body0, Body).
|
|
merge_foreign_type_bodies(_, _, hlds_foreign_type(Body0),
|
|
hlds_foreign_type(Body1), hlds_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(TypeBodyA, TypeBodyB, TypeBody) :-
|
|
TypeBodyA = foreign_type_body(MaybeILA, MaybeCA, MaybeJavaA, MaybeCSharpA,
|
|
MaybeErlangA),
|
|
TypeBodyB = foreign_type_body(MaybeILB, MaybeCB, MaybeJavaB, MaybeCSharpB,
|
|
MaybeErlangB),
|
|
merge_maybe(MaybeILA, MaybeILB, MaybeIL),
|
|
merge_maybe(MaybeCA, MaybeCB, MaybeC),
|
|
merge_maybe(MaybeJavaA, MaybeJavaB, MaybeJava),
|
|
merge_maybe(MaybeCSharpA, MaybeCSharpB, MaybeCSharp),
|
|
merge_maybe(MaybeErlangA, MaybeErlangB, MaybeErlang),
|
|
TypeBody = foreign_type_body(MaybeIL, MaybeC, MaybeJava, MaybeCSharp,
|
|
MaybeErlang).
|
|
|
|
:- 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 = status_exported ->
|
|
AbstractStatus = status_abstract_exported
|
|
; Status = status_imported(_) ->
|
|
AbstractStatus = status_abstract_imported
|
|
;
|
|
AbstractStatus = Status
|
|
).
|
|
|
|
combine_status(StatusA, StatusB, Status) :-
|
|
( combine_status_2(StatusA, StatusB, CombinedStatus) ->
|
|
Status = CombinedStatus
|
|
;
|
|
unexpected($module, $pred, "unexpected status for type definition")
|
|
).
|
|
|
|
:- pred combine_status_2(import_status::in, import_status::in,
|
|
import_status::out) is semidet.
|
|
|
|
combine_status_2(status_imported(ImportLocn), Status2, Status) :-
|
|
require_complete_switch [ImportLocn]
|
|
(
|
|
( ImportLocn = import_locn_implementation
|
|
; ImportLocn = import_locn_interface
|
|
; ImportLocn = import_locn_ancestor
|
|
),
|
|
combine_status_imported_non_private(Status2, Status)
|
|
;
|
|
ImportLocn = import_locn_ancestor_private_interface_proper,
|
|
% If it's private, it's private.
|
|
Status = status_imported(import_locn_ancestor_private_interface_proper)
|
|
).
|
|
combine_status_2(status_local, Status2, Status) :-
|
|
combine_status_local(Status2, Status).
|
|
combine_status_2(status_exported, _Status2, status_exported).
|
|
combine_status_2(status_exported_to_submodules, Status2, Status) :-
|
|
combine_status_local(Status2, Status3),
|
|
( Status3 = status_local ->
|
|
Status = status_exported_to_submodules
|
|
;
|
|
Status = Status3
|
|
).
|
|
combine_status_2(status_opt_imported, _Status2, status_opt_imported).
|
|
combine_status_2(status_abstract_imported, Status2, Status) :-
|
|
combine_status_abstract_imported(Status2, Status).
|
|
combine_status_2(status_abstract_exported, Status2, Status) :-
|
|
combine_status_abstract_exported(Status2, Status).
|
|
|
|
:- pred combine_status_imported_non_private(import_status::in,
|
|
import_status::out) is semidet.
|
|
|
|
combine_status_imported_non_private(Status2, Status) :-
|
|
(
|
|
Status2 = status_imported(Section),
|
|
Status = status_imported(Section)
|
|
;
|
|
Status2 = status_local,
|
|
Status = status_imported(import_locn_implementation)
|
|
;
|
|
Status2 = status_exported,
|
|
Status = status_exported
|
|
;
|
|
Status2 = status_opt_imported,
|
|
Status = status_opt_imported
|
|
;
|
|
Status2 = status_abstract_imported,
|
|
Status = status_imported(import_locn_interface)
|
|
;
|
|
Status2 = status_abstract_exported,
|
|
Status = status_abstract_exported
|
|
).
|
|
|
|
:- pred combine_status_local(import_status::in, import_status::out) is semidet.
|
|
|
|
combine_status_local(status_exported_to_submodules,
|
|
status_exported_to_submodules).
|
|
combine_status_local(status_imported(_), status_local).
|
|
combine_status_local(status_local, status_local).
|
|
combine_status_local(status_exported, status_exported).
|
|
combine_status_local(status_opt_imported, status_local).
|
|
combine_status_local(status_abstract_imported, status_local).
|
|
combine_status_local(status_abstract_exported, status_abstract_exported).
|
|
|
|
:- pred combine_status_abstract_exported(import_status::in, import_status::out)
|
|
is det.
|
|
|
|
combine_status_abstract_exported(Status2, Status) :-
|
|
( Status2 = status_exported ->
|
|
Status = status_exported
|
|
;
|
|
Status = status_abstract_exported
|
|
).
|
|
|
|
:- pred combine_status_abstract_imported(import_status::in, import_status::out)
|
|
is det.
|
|
|
|
combine_status_abstract_imported(Status2, Status) :-
|
|
( Status2 = status_imported(Section) ->
|
|
Status = status_imported(Section)
|
|
;
|
|
Status = status_abstract_imported
|
|
).
|
|
|
|
:- pred convert_type_defn(type_defn::in, type_ctor::in, globals::in,
|
|
hlds_type_body::out) is det.
|
|
|
|
convert_type_defn(parse_tree_du_type(Body, MaybeUserEqComp,
|
|
MaybeDirectArgCtors), 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 = uses_reserved_tag, when processing the pragma.)
|
|
ReservedTagPragma = does_not_use_reserved_tag,
|
|
assign_constructor_tags(Body, MaybeUserEqComp, TypeCtor, ReservedTagPragma,
|
|
Globals, CtorTagMap, ReservedAddr, IsEnum),
|
|
IsForeign = no,
|
|
( ReservedAddr = does_not_use_reserved_address ->
|
|
compute_cheaper_tag_test(CtorTagMap, CheaperTagTest)
|
|
;
|
|
CheaperTagTest = no_cheaper_tag_test
|
|
),
|
|
HLDSBody = hlds_du_type(Body, CtorTagMap, CheaperTagTest, IsEnum,
|
|
MaybeUserEqComp, MaybeDirectArgCtors, ReservedTagPragma, ReservedAddr,
|
|
IsForeign).
|
|
convert_type_defn(parse_tree_eqv_type(Body), _, _, hlds_eqv_type(Body)).
|
|
convert_type_defn(parse_tree_solver_type(SolverTypeDetails, MaybeUserEqComp),
|
|
_, _, hlds_solver_type(SolverTypeDetails, MaybeUserEqComp)).
|
|
convert_type_defn(parse_tree_abstract_type(Details), _, _,
|
|
hlds_abstract_type(Details)).
|
|
convert_type_defn(parse_tree_foreign_type(ForeignType, MaybeUserEqComp,
|
|
Assertions), _, _, hlds_foreign_type(Body)) :-
|
|
(
|
|
ForeignType = il(ILForeignType),
|
|
Data = foreign_type_lang_data(ILForeignType, MaybeUserEqComp,
|
|
Assertions),
|
|
Body = foreign_type_body(yes(Data), no, no, no, no)
|
|
;
|
|
ForeignType = c(CForeignType),
|
|
Data = foreign_type_lang_data(CForeignType, MaybeUserEqComp,
|
|
Assertions),
|
|
Body = foreign_type_body(no, yes(Data), no, no, no)
|
|
;
|
|
ForeignType = java(JavaForeignType),
|
|
Data = foreign_type_lang_data(JavaForeignType, MaybeUserEqComp,
|
|
Assertions),
|
|
Body = foreign_type_body(no, no, yes(Data), no, no)
|
|
;
|
|
ForeignType = csharp(CSharpForeignType),
|
|
Data = foreign_type_lang_data(CSharpForeignType, MaybeUserEqComp,
|
|
Assertions),
|
|
Body = foreign_type_body(no, no, no, yes(Data), no)
|
|
;
|
|
ForeignType = erlang(ErlangForeignType),
|
|
Data = foreign_type_lang_data(ErlangForeignType, MaybeUserEqComp,
|
|
Assertions),
|
|
Body = foreign_type_body(no, no, no, no, yes(Data))
|
|
).
|
|
|
|
:- pred ctors_add(list(constructor)::in, type_ctor::in, module_name::in,
|
|
tvarset::in, list(type_param)::in, tvar_kind_map::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,
|
|
list(error_spec)::in, list(error_spec)::out) is det.
|
|
|
|
ctors_add([], _, _, _, _, _, _, _, _, _, !FieldNameTable, !Ctors, !Specs).
|
|
ctors_add([Ctor | Rest], TypeCtor, TypeCtorModuleName, TVarSet, TypeParams,
|
|
KindMap, NeedQual, PQInfo, _Context, ImportStatus, !FieldNameTable,
|
|
!Ctors, !Specs) :-
|
|
Ctor = ctor(ExistQVars, Constraints, Name, Args, Context),
|
|
list.length(Args, Arity),
|
|
BaseName = unqualify_name(Name),
|
|
QualifiedName = qualified(TypeCtorModuleName, BaseName),
|
|
UnqualifiedName = unqualified(BaseName),
|
|
QualifiedConsIdA = cons(QualifiedName, Arity, TypeCtor),
|
|
QualifiedConsIdB = cons(QualifiedName, Arity, cons_id_dummy_type_ctor),
|
|
UnqualifiedConsIdA = cons(UnqualifiedName, Arity, TypeCtor),
|
|
UnqualifiedConsIdB = cons(UnqualifiedName, Arity, cons_id_dummy_type_ctor),
|
|
|
|
ConsDefn = hlds_cons_defn(TypeCtor, TVarSet, TypeParams, KindMap,
|
|
ExistQVars, Constraints, Args, Context),
|
|
get_partial_qualifiers(TypeCtorModuleName, PQInfo, PartialQuals),
|
|
|
|
% Check that there is at most one definition of a given cons_id
|
|
% in each type.
|
|
(
|
|
search_cons_table(!.Ctors, QualifiedConsIdA, QualifiedConsDefnsA),
|
|
some [OtherConsDefn] (
|
|
list.member(OtherConsDefn, QualifiedConsDefnsA),
|
|
OtherConsDefn ^ cons_type_ctor = TypeCtor
|
|
)
|
|
->
|
|
QualifiedConsIdStr = cons_id_and_arity_to_string(QualifiedConsIdA),
|
|
TypeCtorStr = type_ctor_to_string(TypeCtor),
|
|
Pieces = [words("Error: constructor"), quote(QualifiedConsIdStr),
|
|
words("for type"), quote(TypeCtorStr),
|
|
words("multiply defined."), nl],
|
|
Msg = simple_msg(Context, [always(Pieces)]),
|
|
Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
|
|
!:Specs = [Spec | !.Specs]
|
|
;
|
|
some [!OtherConsIds] (
|
|
% Schedule the addition of the fully-qualified cons_id
|
|
% into the cons_table.
|
|
MainConsId = QualifiedConsIdA,
|
|
!:OtherConsIds = [QualifiedConsIdB],
|
|
|
|
% Schedule the addition of the unqualified version of the cons_id
|
|
% to the cons_table, if appropriate.
|
|
(
|
|
NeedQual = may_be_unqualified,
|
|
!:OtherConsIds =
|
|
[UnqualifiedConsIdA, UnqualifiedConsIdB | !.OtherConsIds]
|
|
;
|
|
NeedQual = must_be_qualified
|
|
),
|
|
|
|
% Schedule the partially qualified versions of the cons_id.
|
|
list.foldl(add_ctor_to_list(TypeCtor, BaseName, Arity),
|
|
PartialQuals, !OtherConsIds),
|
|
|
|
% Do the scheduled additions.
|
|
insert_into_cons_table(MainConsId, !.OtherConsIds, ConsDefn,
|
|
!Ctors)
|
|
)
|
|
),
|
|
|
|
FieldNames = list.map(func(C) = C ^ arg_field_name, Args),
|
|
FirstField = 1,
|
|
add_ctor_field_names(FieldNames, NeedQual, PartialQuals, TypeCtor,
|
|
QualifiedConsIdA, Context, ImportStatus, FirstField,
|
|
!FieldNameTable, !Specs),
|
|
|
|
ctors_add(Rest, TypeCtor, TypeCtorModuleName, TVarSet, TypeParams,
|
|
KindMap, NeedQual, PQInfo, Context, ImportStatus, !FieldNameTable,
|
|
!Ctors, !Specs).
|
|
|
|
:- pred add_ctor_to_list(type_ctor::in, string::in, int::in, module_name::in,
|
|
list(cons_id)::in, list(cons_id)::out) is det.
|
|
|
|
add_ctor_to_list(TypeCtor, ConsName, Arity, ModuleQual, !ConsIds) :-
|
|
ConsIdA = cons(qualified(ModuleQual, ConsName), Arity, TypeCtor),
|
|
ConsIdB = cons(qualified(ModuleQual, ConsName), Arity,
|
|
cons_id_dummy_type_ctor),
|
|
!:ConsIds = [ConsIdA, ConsIdB | !.ConsIds].
|
|
|
|
:- 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,
|
|
list(error_spec)::in, list(error_spec)::out) is det.
|
|
|
|
add_ctor_field_names([], _, _, _, _, _, _, _, !FieldNameTable, !Specs).
|
|
add_ctor_field_names([MaybeFieldName | FieldNames], NeedQual,
|
|
PartialQuals, TypeCtor, ConsId, Context, ImportStatus,
|
|
FieldNumber, !FieldNameTable, !Specs) :-
|
|
(
|
|
MaybeFieldName = yes(FieldName),
|
|
FieldDefn = hlds_ctor_field_defn(Context, ImportStatus, TypeCtor,
|
|
ConsId, FieldNumber),
|
|
add_ctor_field_name(FieldName, FieldDefn, NeedQual, PartialQuals,
|
|
!FieldNameTable, !Specs)
|
|
;
|
|
MaybeFieldName = no
|
|
),
|
|
add_ctor_field_names(FieldNames, NeedQual, PartialQuals, TypeCtor,
|
|
ConsId, Context, ImportStatus, FieldNumber + 1,
|
|
!FieldNameTable, !Specs).
|
|
|
|
:- 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,
|
|
list(error_spec)::in, list(error_spec)::out) is det.
|
|
|
|
add_ctor_field_name(FieldName, FieldDefn, NeedQual, PartialQuals,
|
|
!FieldNameTable, !Specs) :-
|
|
(
|
|
FieldName = qualified(FieldModule0, _),
|
|
FieldModule = FieldModule0
|
|
;
|
|
FieldName = unqualified(_),
|
|
unexpected($module, $pred, "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, _, _, _, _)
|
|
;
|
|
unexpected($module, $pred, "multiple conflicting fields")
|
|
),
|
|
|
|
% XXX We should record each error.
|
|
% using module_info_incr_errors
|
|
FieldDefn = hlds_ctor_field_defn(Context, _, _, _, _),
|
|
FieldString = sym_name_to_string(FieldName),
|
|
Pieces = [words("Error: field"), quote(FieldString),
|
|
words("multiply defined.")],
|
|
Msg1 = simple_msg(Context, [always(Pieces)]),
|
|
PrevPieces = [words("Here is the previous definition of field"),
|
|
quote(FieldString), suffix(".")],
|
|
Msg2 = simple_msg(OrigContext, [always(PrevPieces)]),
|
|
Spec = error_spec(severity_error, phase_parse_tree_to_hlds,
|
|
[Msg1, Msg2]),
|
|
!:Specs = [Spec | !.Specs]
|
|
;
|
|
UnqualFieldName = unqualify_name(FieldName),
|
|
|
|
% Add an unqualified version of the field name to the table,
|
|
% if appropriate.
|
|
(
|
|
NeedQual = may_be_unqualified,
|
|
multi_map.set(unqualified(UnqualFieldName), FieldDefn,
|
|
!FieldNameTable)
|
|
;
|
|
NeedQual = must_be_qualified
|
|
),
|
|
|
|
% 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(qualified(ModuleName, FieldName), FieldNameDefn,
|
|
!FieldNameTable).
|
|
|
|
%----------------------------------------------------------------------------%
|
|
:- end_module hlds.make_hlds.add_type.
|
|
%----------------------------------------------------------------------------%
|