Patchwork [Ada] Inheritance of private null interface primitive

login
register
mail settings
Submitter Arnaud Charlet
Date Oct. 5, 2010, 9:38 a.m.
Message ID <20101005093816.GA6029@adacore.com>
Download mbox | patch
Permalink /patch/66778/
State New
Headers show

Comments

Arnaud Charlet - Oct. 5, 2010, 9:38 a.m.
A derived type does not inherit a private operation from a parent type,
but can dispatch to it. That is, its dispatch table includes a full
copy of the dispatch table of the parent, even if some of its entries
can never be named. After this patch the following test compiles
and executes silently.

package R is
   type I1 is interface;
   procedure Oper (Obj : I1'Class);
private
   procedure Proc (Obj : I1) is null;
end R;

package body R is
   procedure Oper (Obj : I1'Class) is
   begin
      Obj.Proc; -- Dispatching
   end Oper;
end;

with R;
package P1 is
   type Root is tagged private;
private
   type Root is tagged null record;
end;

with P1; with R;
package Q1 is
   type Child is new P1.Root and R.I1 with null record;
end Q1;

with P1, Q1, R;
procedure Main1 is
   X : Q1.Child;
begin
   R.Oper (X);
end Main1;

Tested on x86_64-pc-linux-gnu, committed on trunk

2010-10-05  Javier Miranda  <miranda@adacore.com>

	* sem_ch3.adb (Add_Internal_Interface_Entities): Code reorganization:
	move code that searches in the list of primitives of a tagged type for
	the entity that will be overridden by user-defined routines.
	* sem_disp.adb (Find_Primitive_Covering_Interface): Move here code
	previously located in routine Add_Internal_Interface_Entities.
	* sem_disp.ads (Find_Primitive_Covering_Interface): Update documentation
	* sem_ch6.adb (New_Overloaded_Entity): Add missing check on
	availability of attribute Alias.

Patch

Index: sem_ch3.adb
===================================================================
--- sem_ch3.adb	(revision 164906)
+++ sem_ch3.adb	(working copy)
@@ -1567,41 +1567,9 @@  package body Sem_Ch3 is
                   if Is_Null_Interface_Primitive (Iface_Prim) then
                      goto Continue;
 
-                  --  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.
-
-                  elsif Is_Library_Level_Tagged_Type (Tagged_Type) then
-                     Check_Abstract_Overriding (Tagged_Type);
-                     pragma Assert (Serious_Errors_Detected > 0);
-                     return;
-
-                  --  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.
-
                   else
-                     declare
-                        El : Elmt_Id;
-
-                     begin
-                        El := First_Elmt (Primitive_Operations (Tagged_Type));
-                        while Present (El)
-                          and then Alias (Node (El)) /= Iface_Prim
-                        loop
-                           Next_Elmt (El);
-                        end loop;
-
-                        pragma Assert (Present (El));
-                        Prim := Node (El);
-                     end;
+                     pragma Assert (False);
+                     raise Program_Error;
                   end if;
                end if;
 
Index: sem_ch6.adb
===================================================================
--- sem_ch6.adb	(revision 164933)
+++ sem_ch6.adb	(working copy)
@@ -7625,6 +7625,7 @@  package body Sem_Ch6 is
 
          if Ada_Version >= Ada_05
            and then Present (Derived_Type)
+           and then Present (Alias (S))
            and then Is_Dispatching_Operation (Alias (S))
            and then Present (Find_Dispatching_Type (Alias (S)))
            and then Is_Interface (Find_Dispatching_Type (Alias (S)))
Index: sem_disp.adb
===================================================================
--- sem_disp.adb	(revision 164939)
+++ sem_disp.adb	(working copy)
@@ -1651,7 +1651,8 @@  package body Sem_Disp is
      (Tagged_Type : Entity_Id;
       Iface_Prim  : Entity_Id) return Entity_Id
    is
-      E : Entity_Id;
+      E  : Entity_Id;
+      El : Elmt_Id;
 
    begin
       pragma Assert (Is_Interface (Find_Dispatching_Type (Iface_Prim))
@@ -1660,6 +1661,8 @@  package body Sem_Disp is
                      Is_Interface
                        (Find_Dispatching_Type (Ultimate_Alias (Iface_Prim)))));
 
+      --  Search in the homonym chain
+
       E := Current_Entity (Iface_Prim);
       while Present (E) loop
          if Is_Subprogram (E)
@@ -1672,6 +1675,23 @@  package body Sem_Disp is
          E := Homonym (E);
       end loop;
 
+      --  Search in the list of primitives of the type
+
+      El := First_Elmt (Primitive_Operations (Tagged_Type));
+      while Present (El) loop
+         E := Node (El);
+
+         if No (Interface_Alias (E))
+           and then Alias (E) = Iface_Prim
+         then
+            return Node (El);
+         end if;
+
+         Next_Elmt (El);
+      end loop;
+
+      --  Not found
+
       return Empty;
    end Find_Primitive_Covering_Interface;
 
Index: sem_disp.ads
===================================================================
--- sem_disp.ads	(revision 164906)
+++ sem_disp.ads	(working copy)
@@ -82,10 +82,12 @@  package Sem_Disp is
    function Find_Primitive_Covering_Interface
      (Tagged_Type : Entity_Id;
       Iface_Prim  : Entity_Id) return Entity_Id;
-   --  Search in the homonym chain for the primitive of Tagged_Type that
-   --  covers Iface_Prim. The homonym chain traversal is required to catch
-   --  primitives associated with the partial view of private types when
-   --  processing the corresponding full view.
+   --  Search in the homonym chain for the primitive of Tagged_Type that covers
+   --  Iface_Prim. The homonym chain traversal is required to catch primitives
+   --  associated with the partial view of private types when processing the
+   --  corresponding full view. If the entity is not found then search for it
+   --  in the list of primitives of Tagged_Type. This latter search is needed
+   --  when the interface primitive is covered by a private subprogram.
 
    function Is_Dynamically_Tagged (N : Node_Id) return Boolean;
    --  Used to determine whether a call is dispatching, i.e. if is an