[Ada] Work around issue with overaligned derived types

[Eric Botcazou <ebotcazou at adacore dot com>]

This is a regression present on the mainline and 4.7 branch and visible on 
SPARC/Solaris, although it is latent everywhere.  When a derived type is more 
aligned than its base type, things can go wrong when an object of the class-
wide type is initialized with a value whose type is the derived type and is 
later used for dispatching, because the primitive operations (methods) of the 
derived type expect the larger alignment.

Tested on x86_64-suse-linux, applied on the mainline and 4.7 branch.


2012-07-19  Eric Botcazou  <ebotcazou@adacore.com>

	* gcc-interface/decl.c (gnat_to_gnu_entity) <object>: Try to ensure
	that an object of CW type initialized to a value is sufficiently
	aligned for this value.


2012-07-19  Eric Botcazou  <ebotcazou@adacore.com>

	* gnat.dg/derived_type3.adb: New test.
	* gnat.dg/derived_type3_pkg.ad[sb]: New helper.


-- 
Eric Botcazou

Index: ada/gcc-interface/decl.c
===================================================================
--- ada/gcc-interface/decl.c	(revision 189666)
+++ ada/gcc-interface/decl.c	(working copy)
@@ -895,6 +895,16 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
 						debug_info_p);
 	  }
 
+	/* ??? If this is an object of CW type initialized to a value, try to
+	   ensure that the object is sufficient aligned for this value, but
+	   without pessimizing the allocation.  This is a kludge necessary
+	   because we don't support dynamic alignment.  */
+	if (align == 0
+	    && Ekind (Etype (gnat_entity)) == E_Class_Wide_Subtype
+	    && No (Renamed_Object (gnat_entity))
+	    && No (Address_Clause (gnat_entity)))
+	  align = get_target_system_allocator_alignment () * BITS_PER_UNIT;
+
 #ifdef MINIMUM_ATOMIC_ALIGNMENT
 	/* If the size is a constant and no alignment is specified, force
 	   the alignment to be the minimum valid atomic alignment.  The
@@ -904,7 +914,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
 	   necessary and can interfere with constant replacement.  Finally,
 	   do not do it for Out parameters since that creates an
 	   size inconsistency with In parameters.  */
-	if (align == 0 && MINIMUM_ATOMIC_ALIGNMENT > TYPE_ALIGN (gnu_type)
+	if (align == 0
+	    && MINIMUM_ATOMIC_ALIGNMENT > TYPE_ALIGN (gnu_type)
 	    && !FLOAT_TYPE_P (gnu_type)
 	    && !const_flag && No (Renamed_Object (gnat_entity))
 	    && !imported_p && No (Address_Clause (gnat_entity))

-- { dg-do run }

with Derived_Type3_Pkg; use Derived_Type3_Pkg;

procedure Derived_Type3 is
begin
   Proc1;
   Proc2;
end;

with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
with Ada.Text_IO; use Ada.Text_IO;

package body Derived_Type3_Pkg is

   type Parent is tagged null record;

   type Child is new Parent with
      record
         Image : Ada.Strings.Unbounded.Unbounded_String;
      end record;

   function Set_Image return Child'class is
      Local_Data : Child;
   begin
      Local_Data.Image := To_Unbounded_String ("Hello");
      return Local_Data;
   end Set_Image;

   procedure Proc1 is
      The_Data : Parent'class := Set_Image;
   begin
      Put_Line ("Child'Alignment =" & Child'Alignment'Img);
      Put_Line ("The_Data'Alignment =" & The_Data'Alignment'Img);
   end;

   procedure Proc2 is

      procedure Nested (X : Parent'Class) is
        The_Data : Parent'Class := X;
      begin
        Put_Line ("Child'Alignment =" & Child'Alignment'Img);
        Put_Line ("The_Data'Alignment =" & The_Data'Alignment'Img);
      end;

      The_Data : Parent'Class := Set_Image;

   begin
      Nested (The_Data);
   end;

end Derived_Type3_Pkg;

package Derived_Type3_Pkg is

   procedure Proc1;
   procedure Proc2;

end Derived_Type3_Pkg;