decl.c (gnat_to_gnu_entity): Try to ensure that an object of CW type initialized…

decl.c (gnat_to_gnu_entity): Try to ensure that an object of CW type initialized to a value is sufficiently...

	* 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.

From-SVN: r189682

gcc/ada/ChangeLog

 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>
+
 	* gcc-interface/decl.c (gnat_to_gnu_entity) <E_Record_Subtype>: Do not
 	look up the REP part of the base type in advance.  Deal with that of
 	the variant types.

gcc/ada/gcc-interface/decl.c

@@ -895,6 +895,16 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
 						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_entity, tree gnu_expr, int definition)
 	   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))

gcc/testsuite/ChangeLog

+2012-07-19  Eric Botcazou  <ebotcazou@adacore.com>
+
+	* gnat.dg/derived_type3.adb: New test.
+	* gnat.dg/derived_type3_pkg.ad[sb]: New helper.
+
 2012-07-19  Jakub Jelinek  <jakub@redhat.com>
 
 	PR rtl-optimization/53942

gcc/testsuite/gnat.dg/derived_type3.adb

+-- { dg-do run }
+
+with Derived_Type3_Pkg; use Derived_Type3_Pkg;
+
+procedure Derived_Type3 is
+begin
+   Proc1;
+   Proc2;
+end;

gcc/testsuite/gnat.dg/derived_type3_pkg.adb

+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;

gcc/testsuite/gnat.dg/derived_type3_pkg.ads

+package Derived_Type3_Pkg is
+
+   procedure Proc1;
+   procedure Proc2;
+
+end Derived_Type3_Pkg;