[Ada] Wrong management of private types covering interfaces

[Arnaud Charlet]

The frontend does not handle well conversions of access types
whose designated type is a private type covering interfaces.
In such case, after an interface conversion, a dispatching
call may call a wrong primitive or generate constraint error.
After this patch the following test compiles without errors
and generates the correct output:

package Pkg_1 is
   type I1 is interface;

   type I2 is interface and I1;
   procedure Wrong_Prim (Self : access I2) is abstract;

   type I3 is interface and I2;
   procedure Do_Test (Self : access I3) is abstract;

   type DT_1 is new I1 with null record;
   procedure Dummy (Self : DT_1) is null;

   type DT_2 is new DT_1 and I2 with null record;
   procedure Wrong_Prim (Self : access DT_2);

   type I3_Access is access all I3'Class;
end;

with Pkg_1;
package Pkg_2 is
   type DT_3 is new Pkg_1.I3 with private;
   procedure Do_Test (Self : access DT_3);

   type DT_3_Access is access all DT_3'Class;
   function Create return DT_3_Access;
private
   type DT_3 is new Pkg_1.DT_2 and Pkg_1.I3 with null record;
end;

with Ada.Text_IO;
package body Pkg_1 is
   procedure Wrong_Prim (Self : access DT_2) is
   begin
      Ada.Text_IO.Put_Line ("FAILED");
   end;
end;

with Ada.Text_IO;
package body Pkg_2 is
   function Create return DT_3_Access is
   begin
      return new DT_3;
   end;

   procedure Do_Test (Self : access DT_3) is
   begin
      Ada.Text_IO.Put_Line ("PASSED");
   end;
end;

with Pkg_1, Pkg_2;
procedure Main is
   Ptr : Pkg_1.I3_Access;
begin
   Ptr := Pkg_1.I3_Access (Pkg_2.Create); --  test

   Ptr.Do_Test;
   Ptr.all.Do_Test;
   Pkg_1.I3_Access (Ptr).Do_Test;
   Pkg_2.DT_3_Access (Ptr).Do_Test;
end;

Command: gnatmake -gnat05 main.adb
Output:
PASSED
PASSED
PASSED
PASSED

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

2009-07-10  Javier Miranda  <miranda@adacore.com>

	* exp_util.adb (Find_Interface_Tag): Reorder processing of incoming
	Typ argument to ensure proper management of access types.

-------------- next part --------------
Index: exp_util.adb
===================================================================
--- exp_util.adb	(revision 149458)
+++ exp_util.adb	(working copy)
@@ -1600,28 +1600,24 @@
    begin
       pragma Assert (Is_Interface (Iface));
 
-      --  Handle private types
-
-      if Has_Private_Declaration (Typ)
-        and then Present (Full_View (Typ))
-      then
-         Typ := Full_View (Typ);
-      end if;
-
       --  Handle access types
 
       if Is_Access_Type (Typ) then
          Typ := Directly_Designated_Type (Typ);
       end if;
 
-      --  Handle task and protected types implementing interfaces
+      --  Handle class-wide types
 
-      if Is_Concurrent_Type (Typ) then
-         Typ := Corresponding_Record_Type (Typ);
+      if Is_Class_Wide_Type (Typ) then
+         Typ := Root_Type (Typ);
       end if;
 
-      if Is_Class_Wide_Type (Typ) then
-         Typ := Etype (Typ);
+      --  Handle private types
+
+      if Has_Private_Declaration (Typ)
+        and then Present (Full_View (Typ))
+      then
+         Typ := Full_View (Typ);
       end if;
 
       --  Handle entities from the limited view
@@ -1631,6 +1627,12 @@
          Typ := Non_Limited_View (Typ);
       end if;
 
+      --  Handle task and protected types implementing interfaces
+
+      if Is_Concurrent_Type (Typ) then
+         Typ := Corresponding_Record_Type (Typ);
+      end if;
+
       Find_Tag (Typ);
       pragma Assert (Found);
       return AI_Tag;