Comments
Patch
===================================================================
@@ -1572,6 +1572,26 @@ package body Sem_Ch3 is
pragma Assert (Present (Prim));
+ -- Ada 2012 (AI05-0197): If the name of the covering primitive
+ -- differs from the name of the interface primitive then it is
+ -- a private primitive inherited from a parent type. In such
+ -- case, given that Tagged_Type covers the interface, the
+ -- inherited private primitive becomes visible. For such
+ -- purpose we add a new entity that renames the inherited
+ -- private primitive.
+
+ if Chars (Prim) /= Chars (Iface_Prim) then
+ pragma Assert (Has_Suffix (Prim, 'P'));
+ Derive_Subprogram
+ (New_Subp => New_Subp,
+ Parent_Subp => Iface_Prim,
+ Derived_Type => Tagged_Type,
+ Parent_Type => Iface);
+ Set_Alias (New_Subp, Prim);
+ Set_Is_Abstract_Subprogram (New_Subp,
+ Is_Abstract_Subprogram (Prim));
+ end if;
+
Derive_Subprogram
(New_Subp => New_Subp,
Parent_Subp => Iface_Prim,
@@ -12416,6 +12436,22 @@ package body Sem_Ch3 is
Derive_Subprogram
(New_Subp, Iface_Subp, Tagged_Type, Iface);
+ -- Ada 2012 (AI05-0197): If the covering primitive's name
+ -- differs from the name of the interface primitive then it
+ -- is a private primitive inherited from a parent type. In
+ -- such case, given that Tagged_Type covers the interface,
+ -- the inherited private primitive becomes visible. For such
+ -- purpose we add a new entity that renames the inherited
+ -- private primitive.
+
+ elsif Chars (E) /= Chars (Iface_Subp) then
+ pragma Assert (Has_Suffix (E, 'P'));
+ Derive_Subprogram
+ (New_Subp, Iface_Subp, Tagged_Type, Iface);
+ Set_Alias (New_Subp, E);
+ Set_Is_Abstract_Subprogram (New_Subp,
+ Is_Abstract_Subprogram (E));
+
-- Propagate to the full view interface entities associated
-- with the partial view
===================================================================
@@ -1527,8 +1527,15 @@ package body Sem_Ch7 is
Op_Elmt_2 := Next_Elmt (Op_Elmt);
while Present (Op_Elmt_2) loop
+
+ -- Skip entities with attribute Interface_Alias since
+ -- they are not overriding primitives (these entities
+ -- link an interface primitive with their covering
+ -- primitive)
+
if Chars (Node (Op_Elmt_2)) = Chars (Parent_Subp)
and then Type_Conformant (Prim_Op, Node (Op_Elmt_2))
+ and then No (Interface_Alias (Node (Op_Elmt_2)))
then
-- The private inherited operation has been
-- overridden by an explicit subprogram: replace
===================================================================
@@ -2155,7 +2155,9 @@ package body Sem_Ch4 is
P_T := Base_Type (Etype (P));
- if Is_Entity_Name (P) then
+ if Is_Entity_Name (P)
+ and then Present (Entity (P))
+ then
U_N := Entity (P);
if Is_Type (U_N) then
===================================================================
@@ -186,9 +186,10 @@ package Sem_Ch6 is
(Tagged_Type : Entity_Id;
Iface_Prim : Entity_Id;
Prim : Entity_Id) return Boolean;
- -- Returns true if both primitives have a matching name, they are type
- -- conformant, and Prim is defined in the scope of Tagged_Type. Special
- -- management is done for functions returning interfaces.
+ -- Returns true if both primitives have a matching name (including support
+ -- for names of inherited private primitives --which have suffix 'P'), they
+ -- are type conformant, and Prim is defined in the scope of Tagged_Type.
+ -- Special management is done for functions returning interfaces.
procedure List_Inherited_Pre_Post_Aspects (E : Entity_Id);
-- E is the entity for a subprogram or generic subprogram spec. This call
===================================================================
@@ -1817,6 +1817,13 @@ package body Sem_Disp is
end if;
end if;
+ -- Check if E covers the interface primitive (includes case in
+ -- which E is an inherited private primitive)
+
+ if Is_Interface_Conformant (Tagged_Type, Iface_Prim, E) then
+ return E;
+ end if;
+
-- Use the internal entity that links the interface primitive with
-- the covering primitive to locate the entity
This AI resolves a conflict between an inherited null interface primitive and an inherited private primitive. In such case the inherited private primitive is the dispatching primitive. For further details read http://www.ada-auth.org/cgi-bin/cvsweb.cgi/ai05s/ai05-0197-1.txt After this patch the following test compiles and executes fine. package Pack1 is type Int1 is interface; procedure Op1 (X : Int1) is null; end Pack1; package Pack2 is type T2 is tagged null record; private procedure Op1 (X : T2); end Pack2; with Pack1, Pack2; package Pack2.Pack3 is type T3 is new Pack2.T2 and Pack1.Int1 with null record; end Pack2.Pack3; with Text_IO; use Text_IO; package body Pack2 is procedure Op1 (X : T2) is begin Put_Line ("OK"); end; end Pack2; with Pack2.Pack3; procedure Do_Test is X : Pack2.Pack3.T3; begin Pack2.Pack3.Op1 (X); end; Output: OK Tested on x86_64-pc-linux-gnu, committed on trunk 2010-10-26 Javier Miranda <miranda@adacore.com> * sem_ch3.adb (Add_Internal_Interface_Entities): Handle primitives inherited from the parent that cover interface primitives. (Derive_Progenitor_Subprograms): Handle primitives inherited from the parent that cover interface primitives. * sem_disp.adb (Find_Primitive_Covering_Interface): When searching in the list of primitives of the type extend the test to include inherited private primitives. * sem_ch6.ads (Is_Interface_Conformant): Add missing documentation. * sem_ch7.adb (Declare_Inherited_Private_Subprograms): Add missing barrier to the loop searching for explicit overriding primitives. * sem_ch4.adb (Analyze_Indexed_Component_Form): Add missing barrier before accessing attribute Entity.