mercury/compiler/add_type.m

%-----------------------------------------------------------------------------%
% 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 pair.
:- import_module string.
:- import_module svmap.
:- import_module svmulti_map.
:- 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
    ;
        !.FoundError = no,
        (
            % 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 = 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,
        map.to_assoc_list(CtorTagMap, CtorTagList),
        CtorTagList = [ConsIdA - ConsTagA, ConsIdB - ConsTagB],
        ConsIdA = cons(_, ArityA),
        ConsIdB = cons(_, ArityB)
    ->
        (
            ArityB = 0,
            ArityA > 0
        ->
            CheaperTagTest = cheaper_tag_test(ConsIdA, ConsTagA,
                ConsIdB, ConsTagB)
        ;
            ArityA = 0,
            ArityB > 0
        ->
            CheaperTagTest = cheaper_tag_test(ConsIdB, ConsTagB,
                ConsIdA, ConsTagA)
        ;
            CheaperTagTest = no_cheaper_tag_test
        )
    ;
        CheaperTagTest = no_cheaper_tag_test
    ),
    HLDSBody = hlds_du_type(Body, CtorTagMap, CheaperTagTest, IsEnum,
        MaybeUserEqComp, 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(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),
            svmulti_map.set(UnqualifiedConsId, ConsDefn, !Ctors)
        ;
            NeedQual = must_be_qualified 
        ),

        % 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
    ;
        FieldName = unqualified(_),
        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,
            svmulti_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) :-
    svmulti_map.set(qualified(ModuleName, FieldName), FieldNameDefn,
        !FieldNameTable).

%----------------------------------------------------------------------------%

:- func this_file = string.

this_file = "add_type.m".

%----------------------------------------------------------------------------%