diff mbox

[Ada] Wrong dispatching on private type that covers interface

Message ID 20110801161020.GA429@adacore.com
State New
Headers show

Commit Message

Arnaud Charlet Aug. 1, 2011, 4:10 p.m. UTC 
If the parent of a private type is an interface type, the parent of its
full type declaration is an abstract type that covers such interface,
and the order of declaration of the tagged type primitives differs from
their order of declaration in the parent (or if not explicitly declared
in the parent, their declaration differs from their order of declaration
in the interface type) then the compiler assigns erroneous slots in the
dispatch table to its primitives. After this patch the following
test compiles and executes without errors.

package Pkg1 is
   type I1 is interface;
   function F1 (Self : I1) return Natural is abstract;
   function F2 (Self : I1) return Natural is abstract;
   function F3 (Self : I1) return Natural is abstract;
end;

with Pkg1; use Pkg1;
package Pkg2 is
   type A_Root is abstract tagged null record;
   type A_DT1  is abstract new A_Root and I1 with null record;
end;

with Pkg1; use Pkg1;
with Pkg2; use Pkg2;
package Pkg3 is
   type A_DT2 is new I1 with private;
private
   type A_DT2 is new A_DT1 with null record;    -- Test
   function F3 (Self : A_DT2) return Natural;
   function F1 (Self : A_DT2) return Natural;
   function F2 (Self : A_DT2) return Natural;
end;

with Pkg1; use Pkg1;
with Pkg2; use Pkg2;
with Pkg3; use Pkg3;
procedure Main is
   M : A_DT2;
begin
   pragma Assert (A_DT2'Class (M).F1 = 1);
   pragma Assert (A_DT1'Class (I1'Class (M)).F1 = 1);

   pragma Assert (A_DT2'Class (M).F2 = 2);
   pragma Assert (A_DT1'Class (I1'Class (M)).F2 = 2);

   pragma Assert (A_DT2'Class (M).F3 = 3);
   pragma Assert (A_DT1'Class (I1'Class (M)).F3 = 3);
   null;
end Main;

with Text_IO; use Text_IO;
package body Pkg3 is
   function F3 (Self : A_DT2) return Natural is begin return 3; end;
   function F1 (Self : A_DT2) return Natural is begin return 1; end;
   function F2 (Self : A_DT2) return Natural is begin return 2; end;
end;

Command: gnatmake -gnat05 -gnata main; ./main

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

2011-08-01  Javier Miranda  <miranda@adacore.com>

	* sem_disp.adb (Override_Dispatching_Operation): Enforce strictness of
	condition that detects if the overridden operation must replace an
	existing entity.
diff mbox

Patch

Index: sem_disp.adb
===================================================================
--- sem_disp.adb	(revision 176998)
+++ sem_disp.adb	(working copy)
@@ -2078,15 +2078,19 @@ 
       --  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 overridden 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.
+      --  primitive of an interface that is not implemented by the parents of
+      --  this tagged type (that is, it is an alias of an interface primitive
+      --  generated 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 Etype (Tagged_Type) /= Tagged_Type
         and then Is_Interface (Find_Dispatching_Type (Alias (Prev_Op)))
         and then not Is_Ancestor (Find_Dispatching_Type (Alias (Prev_Op)),
                                   Tagged_Type)
+        and then not Implements_Interface
+                       (Etype (Tagged_Type),
+                        Find_Dispatching_Type (Alias (Prev_Op)))
       then
          Remove_Elmt (Primitive_Operations (Tagged_Type), Elmt);
          Append_Elmt (New_Op, Primitive_Operations (Tagged_Type));