Index: sem_ch3.adb =================================================================== --- sem_ch3.adb (revision 161247) +++ sem_ch3.adb (working copy) @@ -1517,13 +1517,14 @@ package body Sem_Ch3 is ------------------------------------- procedure Add_Internal_Interface_Entities (Tagged_Type : Entity_Id) is - Elmt : Elmt_Id; - Iface : Entity_Id; - Iface_Elmt : Elmt_Id; - Iface_Prim : Entity_Id; - Ifaces_List : Elist_Id; - New_Subp : Entity_Id := Empty; - Prim : Entity_Id; + Elmt : Elmt_Id; + Iface : Entity_Id; + Iface_Elmt : Elmt_Id; + Iface_Prim : Entity_Id; + Ifaces_List : Elist_Id; + New_Subp : Entity_Id := Empty; + Prim : Entity_Id; + Restore_Scope : Boolean := False; begin pragma Assert (Ada_Version >= Ada_05 @@ -1532,6 +1533,13 @@ package body Sem_Ch3 is and then Has_Interfaces (Tagged_Type) and then not Is_Interface (Tagged_Type)); + -- Ensure that the internal entities are added to the scope of the type + + if Scope (Tagged_Type) /= Current_Scope then + Push_Scope (Scope (Tagged_Type)); + Restore_Scope := True; + end if; + Collect_Interfaces (Tagged_Type, Ifaces_List); Iface_Elmt := First_Elmt (Ifaces_List); @@ -1556,32 +1564,47 @@ package body Sem_Ch3 is (Tagged_Type => Tagged_Type, Iface_Prim => Iface_Prim); + -- Handle cases where the type has no primitive covering this + -- interface primitive. + if No (Prim) then - -- In some rare cases, a name conflict may have kept the - -- operation completely hidden. Look for it in the list - -- of primitive operations of the type. + -- if the tagged type is defined at library level then we + -- invoke Check_Abstract_Overriding to report the error + -- and thus avoid generating the dispatch tables. + + if Is_Library_Level_Tagged_Type (Tagged_Type) then + Check_Abstract_Overriding (Tagged_Type); + pragma Assert (Serious_Errors_Detected > 0); + return; - declare - El : Elmt_Id; + -- For tagged types defined in nested scopes it is still + -- possible to cover this interface primitive by means of + -- late overriding (see Override_Dispatching_Operation). + + -- Search in the list of primitives of the type for the + -- entity that will be overridden in such case to reference + -- it in the internal entity that we build here. If the + -- primitive is not overridden then the error will be + -- reported later as part of the analysis of entities + -- defined in the enclosing scope. - begin - El := First_Elmt (Primitive_Operations (Tagged_Type)); - while Present (El) loop - Prim := Node (El); - exit when Is_Subprogram (Prim) - and then Alias (Prim) = Iface_Prim; - Next_Elmt (El); - end loop; + else + declare + El : Elmt_Id; - -- If the operation was not explicitly overridden, it - -- should have been inherited as an abstract operation - -- so Prim can not be Empty at this stage. + begin + El := First_Elmt (Primitive_Operations (Tagged_Type)); + while Present (El) + and then Alias (Node (El)) /= Iface_Prim + loop + Next_Elmt (El); + end loop; - if No (El) then - raise Program_Error; - end if; - end; + pragma Assert (Present (El)); + Prim := Node (El); + end; + end if; end if; Derive_Subprogram @@ -1627,6 +1650,10 @@ package body Sem_Ch3 is Next_Elmt (Iface_Elmt); end loop; + + if Restore_Scope then + Pop_Scope; + end if; end Add_Internal_Interface_Entities; ----------------------------------- @@ -12827,13 +12854,13 @@ package body Sem_Ch3 is Subp := Node (Elmt); Alias_Subp := Ultimate_Alias (Subp); - -- At this early stage Derived_Type has no entities with attribute - -- Interface_Alias. In addition, such primitives are always - -- located at the end of the list of primitives of Parent_Type. - -- Therefore, if found we can safely stop processing pending - -- entities. + -- Do not derive internal entities of the parent that link + -- interface primitives and its covering primitive. These + -- entities will be added to this type when frozen. - exit when Present (Interface_Alias (Subp)); + if Present (Interface_Alias (Subp)) then + goto Continue; + end if; -- If the generic actual is present find the corresponding -- operation in the generic actual. If the parent type is a @@ -13008,6 +13035,7 @@ package body Sem_Ch3 is Act_Subp := Node (Act_Elmt); end if; + <> Next_Elmt (Elmt); end loop; Index: einfo.ads =================================================================== --- einfo.ads (revision 161205) +++ einfo.ads (working copy) @@ -3152,7 +3152,9 @@ package Einfo is -- types. Points to an element list of entities for primitive operations -- for the tagged type. Not present (and not set) in untagged types (it -- is an error to reference the primitive operations field of a type --- that is not tagged). +-- that is not tagged). In order to fulfill the C++ ABI, entities of +-- primitives that come from source must be stored in this list following +-- their order of occurrence in the sources. -- Prival (Node17) -- Present in private components of protected types. Refers to the entity Index: exp_disp.adb =================================================================== --- exp_disp.adb (revision 161247) +++ exp_disp.adb (working copy) @@ -7127,7 +7127,7 @@ package body Exp_Disp is Next_Elmt (Prim_Elmt); end loop; - -- Third stage: Fix the position of all the new primitives + -- Third stage: Fix the position of all the new primitives. -- Entries associated with primitives covering interfaces -- are handled in a latter round. @@ -7515,6 +7515,17 @@ package body Exp_Disp is Write_Str ("(predefined) "); end if; + -- Prefix the name of the primitive with its corresponding tagged + -- type to facilitate seeing inherited primitives. + + if Present (Alias (Prim)) then + Write_Name + (Chars (Find_Dispatching_Type (Ultimate_Alias (Prim)))); + else + Write_Name (Chars (Typ)); + end if; + + Write_Str ("."); Write_Name (Chars (Prim)); -- Indicate if this primitive has an aliased primitive Index: sem_disp.adb =================================================================== --- sem_disp.adb (revision 161203) +++ sem_disp.adb (working copy) @@ -784,7 +784,7 @@ package body Sem_Disp is and then not Comes_From_Source (Subp) and then not Has_Dispatching_Parent then - -- Complete decoration if internally built subprograms that override + -- Complete decoration of internally built subprograms that override -- a dispatching primitive. These entities correspond with the -- following cases: @@ -1709,7 +1709,28 @@ package body Sem_Disp is return; end if; - Replace_Elmt (Elmt, New_Op); + -- The location of entities that come from source in the list of + -- primitives of the tagged type must follow their order of occurrence + -- in the sources to fulfill the C++ ABI. If the overriden entity is a + -- primitive of an interface that is not an ancestor of this tagged + -- type (that is, it is an entity added to the list of primitives by + -- Derive_Interface_Progenitors), then we must append the new entity + -- at the end of the list of primitives. + + if Present (Alias (Prev_Op)) + and then Is_Interface (Find_Dispatching_Type (Alias (Prev_Op))) + and then not Is_Ancestor (Find_Dispatching_Type (Alias (Prev_Op)), + Tagged_Type) + then + Remove_Elmt (Primitive_Operations (Tagged_Type), Elmt); + Append_Elmt (New_Op, Primitive_Operations (Tagged_Type)); + + -- The new primitive replaces the overriden entity. Required to ensure + -- that overriding primitive is assigned the same dispatch table slot. + + else + Replace_Elmt (Elmt, New_Op); + end if; if Ada_Version >= Ada_05 and then Has_Interfaces (Tagged_Type)