%-----------------------------------------------------------------------------% % 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". %----------------------------------------------------------------------------%