[Ada] Allocation of controlled private type with unknown discriminants

[Arnaud Charlet]

This patch ensures that the finalization machinery properly locates primitive
Finalize_Address when the designated type is private, has unknown discriminants
and is controlled.

------------
-- Source --
------------

--  types.ads

with Ada.Finalization; use Ada.Finalization;
package Types is
   type Root is abstract new Controlled with private;
   overriding procedure Finalize (Obj : in out Root);
   type Child (<>) is new Root with private;
   type Child_Ptr is access all Child;
   function Make_Child return Child_Ptr;
private
   type Root is abstract new Controlled with record
      Id : Natural := 123;
   end record;
   type Child (Discr : Natural) is new Root with null record;
end Types;

--  types.adb

with Ada.Text_IO; use Ada.Text_IO;
package body Types is
   overriding procedure Finalize (Obj : in out Root) is
   begin
      Put_Line (Obj.Id'Img);
   end Finalize;
   function Make_Child return Child_Ptr is
   begin
      return new Child'(Root with Discr => 456);
   end Make_Child;
end Types;

-- main.adb

with Types; use Types;
procedure Main is
   Obj : Child_Ptr := Make_Child;
begin
   null;
end Main;

----------------------------
-- Compilation and output --
----------------------------

$ gnatmake -q -gnat05 main.adb
$ ./main
$  123

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

2012-02-17  Hristian Kirtchev  <kirtc...@adacore.com>

        * exp_util.adb (Find_Finalize_Address): When dealing with an
        internally built full view for a type with unknown discriminants,
        use the original record type.


Index: exp_util.adb
===================================================================
--- exp_util.adb        (revision 184330)
+++ exp_util.adb        (working copy)
@@ -483,6 +483,13 @@
             Utyp := Base_Type (Utyp);
          end if;
 
+         --  When dealing with an internally built full view for a type with
+         --  unknown discriminants, use the original record type.
+
+         if Is_Underlying_Record_View (Utyp) then
+            Utyp := Etype (Utyp);
+         end if;
+
          return TSS (Utyp, TSS_Finalize_Address);
       end Find_Finalize_Address;