re PR ada/34173 (FAIL: gnat.dg/release_unc_maxalign.adb execution test)

2007-12-07  Olivier Hainque  <hainque@adacore.com>

	PR ada/34173
	* decl.c (gnat_to_gnu_entity) <case E_Array_Type>: When setting
	the alignment on the GCC XUA array type, set TYPE_USER_ALIGN if
	this is from an alignment clause on the GNAT entity.
	* utils.c (create_field_decl): Rewrite the computation of DECL_ALIGN
	to distinguish the case where we set it from the type's alignment.
	When so, propagate TYPE_USER_ALIGN into DECL_USER_ALIGN to indicate
	whether this alignment was set from an explicit alignment clause.

From-SVN: r130673

gcc/ada/ChangeLog

@@ -1,3 +1,14 @@
+2007-12-07  Olivier Hainque  <hainque@adacore.com>
+
+	PR ada/34173
+	* decl.c (gnat_to_gnu_entity) <case E_Array_Type>: When setting
+	the alignment on the GCC XUA array type, set TYPE_USER_ALIGN if
+	this is from an alignment clause on the GNAT entity.
+	* utils.c (create_field_decl): Rewrite the computation of DECL_ALIGN
+	to distinguish the case where we set it from the type's alignment.
+	When so, propagate TYPE_USER_ALIGN into DECL_USER_ALIGN to indicate
+	whether this alignment was set from an explicit alignment clause.
+
 2007-12-06  Eric Botcazou  <ebotcazou@adacore.com>
 
 	* decl.c (make_packable_type): Revert last change.

gcc/ada/decl.c

@@ -1795,7 +1795,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
 	  }
 
 	/* If an alignment is specified, use it if valid.  But ignore it for
-	   types that represent the unpacked base type for packed arrays.  */
+	   types that represent the unpacked base type for packed arrays.  If
+	   the alignment was requested with an explicit user alignment clause,
+	   state so.  */
 	if (No (Packed_Array_Type (gnat_entity))
 	    && Known_Alignment (gnat_entity))
 	  {
@@ -1803,6 +1805,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
 	    TYPE_ALIGN (tem)
 	      = validate_alignment (Alignment (gnat_entity), gnat_entity,
 				    TYPE_ALIGN (tem));
+	    if (Present (Alignment_Clause (gnat_entity)))
+	      TYPE_USER_ALIGN (tem) = 1;
 	  }
 
 	TYPE_CONVENTION_FORTRAN_P (tem)

gcc/ada/utils.c

@@ -1581,11 +1581,24 @@ create_field_decl (tree field_name, tree field_type, tree record_type,
     }
 
   DECL_PACKED (field_decl) = pos ? DECL_BIT_FIELD (field_decl) : packed;
-  DECL_ALIGN (field_decl)
-    = MAX (DECL_ALIGN (field_decl),
-	   DECL_BIT_FIELD (field_decl) ? 1
-	   : packed && TYPE_MODE (field_type) != BLKmode ? BITS_PER_UNIT
-	   : TYPE_ALIGN (field_type));
+
+  /* Bump the alignment if need be, either for bitfield/packing purposes or
+     to satisfy the type requirements if no such consideration applies.  When
+     we get the alignment from the type, indicate if this is from an explicit
+     user request, which prevents stor-layout from lowering it later on.  */
+  {
+    int bit_align
+      = (DECL_BIT_FIELD (field_decl) ? 1
+	 : packed && TYPE_MODE (field_type) != BLKmode ? BITS_PER_UNIT : 0);
+
+    if (bit_align > DECL_ALIGN (field_decl))
+      DECL_ALIGN (field_decl) = bit_align;
+    else if (!bit_align && TYPE_ALIGN (field_type) > DECL_ALIGN (field_decl))
+      {
+	DECL_ALIGN (field_decl) = TYPE_ALIGN (field_type);
+	DECL_USER_ALIGN (field_decl) = TYPE_USER_ALIGN (field_type);
+      }
+  }
 
   if (pos)
     {

gcc/testsuite/ChangeLog

@@ -1,3 +1,9 @@
+2007-12-07  Olivier Hainque  <hainque@adacore.com>
+
+	PR ada/34173
+	* gnat.dg/unc_memops.ad[sb]: Support for ...
+	* gnat.dg/unc_memfree.adb: New test.
+	
 2007-12-06  Sebastian Pop  <sebastian.pop@amd.com>
 
 	* gfortran.dg/ltrans-7.f90: New.

gcc/testsuite/gnat.dg/unc_memfree.adb

@@ -0,0 +1,34 @@
+--  { dg-do run }
+
+with Ada.Unchecked_Deallocation;
+with Unc_Memops;
+
+procedure Unc_Memfree is
+
+   type List is array (Natural range <>) of Integer;
+   for List'Alignment use Standard'Maximum_Alignment;
+
+   type Fat_List_Access is access all List;
+
+   type Thin_List_Access is access all List;
+   for Thin_List_Access'Size use Standard'Address_Size;
+
+   procedure Release_Fat is new Ada.Unchecked_Deallocation
+     (Object => List, Name => Fat_List_Access);
+
+   procedure Release_Thin is new Ada.Unchecked_Deallocation
+     (Object => List, Name => Thin_List_Access);
+
+   My_Fat_List : Fat_List_Access;
+   My_Thin_List : Thin_List_Access;
+begin
+   Unc_Memops.Expect_Symetry (True);
+
+   My_Fat_List := new List (1 .. 3);
+   Release_Fat (My_Fat_List);
+
+   My_Thin_List := new List (1 .. 3);
+   Release_Thin (My_Thin_List);
+
+   Unc_Memops.Expect_Symetry (False);
+end;

gcc/testsuite/gnat.dg/unc_memops.adb

@@ -0,0 +1,63 @@
+
+package body Unc_Memops is
+
+   use type System.Address;
+
+   type Addr_Array_T is array (1 .. 20) of Addr_T;
+
+   type Addr_Stack_T is record
+      Store : Addr_Array_T;
+      Size  : Integer := 0;
+   end record;
+
+   procedure Push (Addr : Addr_T; As : access addr_stack_t) is
+   begin
+      As.Size := As.Size + 1;
+      As.Store (As.Size) := Addr;
+   end;
+
+   function Pop (As : access Addr_Stack_T) return Addr_T is
+      Addr : Addr_T := As.Store (As.Size);
+   begin
+      As.Size := As.Size - 1;
+      return Addr;
+   end;
+
+   --
+
+   Addr_Stack : aliased Addr_Stack_T;
+   Symetry_Expected : Boolean := False;
+
+   procedure Expect_Symetry (Status : Boolean) is
+   begin
+      Symetry_Expected := Status;
+   end;
+
+   function  Alloc (Size : size_t) return Addr_T is
+      function malloc (Size : Size_T) return Addr_T;
+      pragma Import (C, Malloc, "malloc");
+
+      Ptr : Addr_T := malloc (Size);
+   begin
+      if Symetry_Expected then
+         Push (Ptr, Addr_Stack'Access);
+      end if;
+      return Ptr;
+   end;
+
+   procedure Free (Ptr : addr_t) is
+   begin
+      if Symetry_Expected
+        and then Ptr /= Pop (Addr_Stack'Access)
+      then
+         raise Program_Error;
+      end if;
+   end;
+
+   function  Realloc (Ptr  : addr_t; Size : size_t) return Addr_T is
+   begin
+      raise Program_Error;
+      return System.Null_Address;
+   end;
+
+end;

gcc/testsuite/gnat.dg/unc_memops.ads

@@ -0,0 +1,24 @@
+with System;
+
+package Unc_Memops is
+   pragma Elaborate_Body;
+
+   type size_t is mod 2 ** Standard'Address_Size;
+   subtype addr_t is System.Address;
+
+   function  Alloc (Size : size_t) return addr_t;
+   procedure Free (Ptr : addr_t);
+   function  Realloc (Ptr  : addr_t; Size : size_t) return addr_t;
+
+   procedure Expect_Symetry (Status : Boolean);
+   --  Whether we expect "free"s to match "alloc" return values in
+   --  reverse order, like alloc->X, alloc->Y should be followed by
+   --  free Y, free X.
+
+private
+
+   pragma Export (C, Alloc,   "__gnat_malloc");
+   pragma Export (C, Free,    "__gnat_free");
+   pragma Export (C, Realloc, "__gnat_realloc");
+
+end;