Patchwork [Ada] AI05-0197: Dispatching with multiple inherited operations

login
register
mail settings
Submitter Arnaud Charlet
Date Oct. 26, 2010, 12:45 p.m.
Message ID <20101026124558.GA11605@adacore.com>
Download mbox | patch
Permalink /patch/69242/
State New
Headers show

Comments

Arnaud Charlet - Oct. 26, 2010, 12:45 p.m.
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.

Patch

Index: sem_ch3.adb
===================================================================
--- sem_ch3.adb	(revision 165946)
+++ sem_ch3.adb	(working copy)
@@ -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
 
Index: sem_ch7.adb
===================================================================
--- sem_ch7.adb	(revision 165946)
+++ sem_ch7.adb	(working copy)
@@ -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
Index: sem_ch4.adb
===================================================================
--- sem_ch4.adb	(revision 165944)
+++ sem_ch4.adb	(working copy)
@@ -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
Index: sem_ch6.ads
===================================================================
--- sem_ch6.ads	(revision 165935)
+++ sem_ch6.ads	(working copy)
@@ -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
Index: sem_disp.adb
===================================================================
--- sem_disp.adb	(revision 165945)
+++ sem_disp.adb	(working copy)
@@ -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