mirror of
https://github.com/Mercury-Language/mercury.git
synced 2025-12-14 05:12:33 +00:00
637c76926d
Estimated hours take: 4
Branches: main
Add some preliminary infrastructure for an HLDS->Erlang code generator.
compiler/globals.m:
compiler/options.m:
Recognise "erlang" as a valid compilation target.
Add new options: `--erlang' and `--erlang-only' as synonyms
for `--target erlang' and `--target erlang --target-code-only'.
XXX the new options are currently undocumented.
compiler/hlds_data.m:
compiler/prog_data.m:
compiler/prog_io_pragma.m:
Recognise "Erlang" as a valid language for foreign code.
compiler/handle_options.m:
For erlang targets, set the gc_method to automatic and disable
optimize_constructor_last_call.
compiler/add_pragma.m:
compiler/add_type.m:
compiler/code_gen.m:
compiler/compile_target_code.m:
compiler/export.m:
compiler/foreign.m:
compiler/granularity.m:
compiler/intermod.m:
compiler/llds_out.m:
compiler/make.module_target.m:
compiler/make.program_target.m:
compiler/make_hlds_passes.m:
compiler/mercury_compile.m:
compiler/mercury_to_mercury.m:
compiler/ml_code_gen.m:
compiler/ml_optimize.m:
compiler/ml_switch_gen.m:
compiler/ml_type_gen.m:
compiler/ml_unify_gen.m:
compiler/mlds.m:
compiler/mlds_to_c.m:
compiler/mlds_to_il.m:
compiler/mlds_to_ilasm.m:
compiler/mlds_to_java.m:
compiler/modules.m:
compiler/pragma_c_gen.m:
compiler/prog_foreign.m:
compiler/simplify.m:
Conform to the above changes.
817 lines
33 KiB
Mathematica
817 lines
33 KiB
Mathematica
%-----------------------------------------------------------------------------%
|
|
% vim: ft=mercury ts=4 sw=4 et
|
|
%-----------------------------------------------------------------------------%
|
|
% Copyright (C) 1993-2007 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_code_util.
|
|
:- import_module hlds.hlds_out.
|
|
:- import_module libs.compiler_util.
|
|
:- import_module libs.globals.
|
|
:- import_module libs.options.
|
|
:- import_module parse_tree.module_qual.
|
|
:- import_module parse_tree.prog_type.
|
|
:- import_module parse_tree.prog_util.
|
|
|
|
:- import_module int.
|
|
:- import_module map.
|
|
:- import_module multi_map.
|
|
:- import_module string.
|
|
:- import_module svmap.
|
|
:- 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),
|
|
module_info_get_type_table(!.ModuleInfo, Types0),
|
|
(
|
|
(
|
|
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 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
|
|
),
|
|
(
|
|
% 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),
|
|
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 consists of a single"),
|
|
words("zero-arity constructor cannot have user-defined"),
|
|
words("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
|
|
),
|
|
(
|
|
% 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.
|
|
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, T),
|
|
(
|
|
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(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 \= 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, 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),
|
|
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)
|
|
)
|
|
;
|
|
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 = 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_abstract_type(IsSolverType), IsSolverType).
|
|
maybe_get_body_is_solver_type(hlds_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 = 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_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, ReservedTag, _),
|
|
module_info_get_cons_table(!.ModuleInfo, Ctors0),
|
|
module_info_get_partial_qualifier_info(!.ModuleInfo, PQInfo),
|
|
module_info_get_ctor_field_table(!.ModuleInfo, CtorFields0),
|
|
ctors_add(ConsList, TypeCtor, TVarSet, 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
|
|
),
|
|
|
|
(
|
|
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 = 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
|
|
->
|
|
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 = hlds_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,
|
|
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_java, LangStr = "Java"
|
|
; Target = target_asm, LangStr = "C"
|
|
; 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
|
|
).
|
|
|
|
:- 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,
|
|
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)
|
|
),
|
|
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(
|
|
foreign_type_body(MaybeILA, MaybeCA, MaybeJavaA, MaybeErlangA),
|
|
foreign_type_body(MaybeILB, MaybeCB, MaybeJavaB, MaybeErlangB),
|
|
foreign_type_body(MaybeIL, MaybeC, MaybeJava, MaybeErlang)) :-
|
|
merge_maybe(MaybeILA, MaybeILB, MaybeIL),
|
|
merge_maybe(MaybeCA, MaybeCB, MaybeC),
|
|
merge_maybe(MaybeJavaA, MaybeJavaB, MaybeJava),
|
|
merge_maybe(MaybeErlangA, MaybeErlangB, 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(this_file, "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(_), Status2, Status) :-
|
|
combine_status_imported(Status2, Status).
|
|
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(import_status::in, import_status::out)
|
|
is semidet.
|
|
|
|
combine_status_imported(status_imported(Section), status_imported(Section)).
|
|
combine_status_imported(status_local,
|
|
status_imported(import_locn_implementation)).
|
|
combine_status_imported(status_exported, status_exported).
|
|
combine_status_imported(status_opt_imported, status_opt_imported).
|
|
combine_status_imported(status_abstract_imported,
|
|
status_imported(import_locn_interface)).
|
|
combine_status_imported(status_abstract_exported, 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), 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 = hlds_du_type(Body, CtorTags, IsEnum, MaybeUserEqComp,
|
|
ReservedTagPragma, 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(IsSolverType), _, _,
|
|
hlds_abstract_type(IsSolverType)).
|
|
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)
|
|
;
|
|
ForeignType = c(CForeignType),
|
|
Data = foreign_type_lang_data(CForeignType, MaybeUserEqComp,
|
|
Assertions),
|
|
Body = foreign_type_body(no, yes(Data), no, no)
|
|
;
|
|
ForeignType = java(JavaForeignType),
|
|
Data = foreign_type_lang_data(JavaForeignType, MaybeUserEqComp,
|
|
Assertions),
|
|
Body = foreign_type_body(no, no, yes(Data), no)
|
|
;
|
|
ForeignType = erlang(ErlangForeignType),
|
|
Data = foreign_type_lang_data(ErlangForeignType, MaybeUserEqComp,
|
|
Assertions),
|
|
Body = foreign_type_body(no, 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,
|
|
list(error_spec)::in, list(error_spec)::out) is det.
|
|
|
|
ctors_add([], _, _, _, _, _, _, !FieldNameTable, !Ctors, !Specs).
|
|
ctors_add([Ctor | Rest], TypeCtor, TVarSet, NeedQual, PQInfo, _Context,
|
|
ImportStatus, !FieldNameTable, !Ctors, !Specs) :-
|
|
Ctor = ctor(ExistQVars, Constraints, Name, Args, Context),
|
|
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, _)
|
|
->
|
|
QualifiedConsIdStr = cons_id_to_string(QualifiedConsId),
|
|
TypeCtorStr = type_ctor_to_string(TypeCtor),
|
|
Pieces = [words("Error: constructor"), quote(QualifiedConsIdStr),
|
|
words("for type"), quote(TypeCtorStr), words("multiply defined.")],
|
|
Msg = simple_msg(Context, [always(Pieces)]),
|
|
Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
|
|
!:Specs = [Spec | !.Specs],
|
|
QualifiedConsDefns = QualifiedConsDefns1
|
|
;
|
|
QualifiedConsDefns = [ConsDefn | QualifiedConsDefns1]
|
|
),
|
|
svmap.set(QualifiedConsId, QualifiedConsDefns, !Ctors),
|
|
|
|
( QualifiedConsId = cons(qualified(Module, ConsName), Arity) ->
|
|
% Add the 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),
|
|
|
|
FieldNames = list.map(func(C) = C ^ arg_field_name, Args),
|
|
|
|
FirstField = 1,
|
|
|
|
add_ctor_field_names(FieldNames, NeedQual, PartialQuals, TypeCtor,
|
|
QualifiedConsId, Context, ImportStatus, FirstField,
|
|
!FieldNameTable, !Specs)
|
|
;
|
|
unexpected(this_file, "ctors_add: cons_id not qualified")
|
|
),
|
|
ctors_add(Rest, TypeCtor, TVarSet, NeedQual, PQInfo, Context,
|
|
ImportStatus, !FieldNameTable, !Ctors, !Specs).
|
|
|
|
:- 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,
|
|
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
|
|
;
|
|
unexpected(this_file, "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, _, _, _, _)
|
|
;
|
|
unexpected(this_file,
|
|
"add_ctor_field_name: 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(!.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).
|
|
|
|
%----------------------------------------------------------------------------%
|
|
|
|
:- func this_file = string.
|
|
|
|
this_file = "add_type.m".
|
|
|
|
%----------------------------------------------------------------------------%
|