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 <ebotca...@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 <ebotca...@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;