utils2.c (build_call_alloc_dealloc_proc): New helper for build_call_alloc_dealloc with arguments to be interpreted...

        ada/
        * gcc-interface/utils2.c (build_call_alloc_dealloc_proc): New
        helper for build_call_alloc_dealloc with arguments to be interpreted
        identically.  Process the case where a GNAT_PROC to call is provided.
        (maybe_wrap_malloc): New helper for build_call_alloc_dealloc, to build
        and return an allocator for DATA_SIZE bytes aimed at containing a
        DATA_TYPE object, using the default __gnat_malloc allocator.  Honor
        DATA_TYPE alignments greater than what the latter offers.
        (maybe_wrap_free): New helper for build_call_alloc_dealloc, to
        release a DATA_TYPE object designated by DATA_PTR using the
        __gnat_free entry point.
        (build_call_alloc_dealloc): Expect object data type instead of naked
        alignment constraint. Use the new helpers.
        (build_allocator): Remove special processing for the super-aligned
        case, now handled by build_call_alloc_dealloc.  Pass data type instead
        of the former alignment argument, as expected by the new interface.
        * gcc-interface/gigi.h (build_call_alloc_dealloc): Adjust prototype
        and comment.
        * gcc-interface/trans.c (gnat_to_gnu) <case N_Free_Statement>:
        Remove special processing for the super-aligned case, now handled
        by build_call_alloc_dealloc.  Pass data type instead of the former
        alignment argument, as expected by the new interface.

        testsuite/
        * gnat.dg/align_max.adb: New test.

From-SVN: r148314

6 files changed, 385 insertions, 195 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index f6ca7d7..03b7de5 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,28 @@
+2009-06-09  Olivier Hainque  <hainque@adacore.com>
+
+	* gcc-interface/utils2.c (build_call_alloc_dealloc_proc): New
+	helper for build_call_alloc_dealloc with arguments to be interpreted
+	identically.  Process the case where a GNAT_PROC to call is provided.
+	(maybe_wrap_malloc): New helper for build_call_alloc_dealloc, to build
+	and return an allocator for DATA_SIZE bytes aimed at containing a
+	DATA_TYPE object, using the default __gnat_malloc allocator.  Honor
+	DATA_TYPE alignments greater than what the latter offers.
+	(maybe_wrap_free): New helper for build_call_alloc_dealloc, to
+	release a DATA_TYPE object designated by DATA_PTR using	the
+	__gnat_free entry point.
+	(build_call_alloc_dealloc): Expect object data type instead of naked
+	alignment constraint. Use the new helpers.
+	(build_allocator): Remove special processing for the super-aligned
+	case, now handled by build_call_alloc_dealloc.  Pass data
+	type instead of the former alignment argument, as expected by the new
+	interface.
+	* gcc-interface/gigi.h (build_call_alloc_dealloc): Adjust prototype
+	and comment.
+	* gcc-interface/trans.c (gnat_to_gnu) <case N_Free_Statement>:
+	Remove special processing for the super-aligned case, now handled
+	by build_call_alloc_dealloc.  Pass data type instead of	the former
+	alignment argument, as expected by the new interface.
+	
 2009-06-08  Alexandre Oliva  <aoliva@redhat.com>
 
 	* lib-writ.adb (flag_compare_debug): Import.
diff --git a/gcc/ada/gcc-interface/gigi.h b/gcc/ada/gcc-interface/gigi.h
index 4d19b42..7bc89ee 100644
--- a/gcc/ada/gcc-interface/gigi.h
+++ b/gcc/ada/gcc-interface/gigi.h
@@ -843,13 +843,13 @@ extern tree build_component_ref (tree record_variable, tree component,
    If GNU_OBJ is nonzero, it is an object to deallocate.  Otherwise,
    generate an allocator.
 
-   GNU_SIZE is the size of the object in bytes and ALIGN is the alignment
-   in bits.  GNAT_PROC, if present, is a procedure to call and GNAT_POOL
-   is the storage pool to use.  If not present, malloc and free are used.
-   GNAT_NODE is used to provide an error location for restriction violation
-   messages.  */
+   GNU_SIZE is the number of bytes to allocate and GNU_TYPE is the contained
+   object type, used to determine the to-be-honored address alignment.
+   GNAT_PROC, if present, is a procedure to call and GNAT_POOL is the storage
+   pool to use.  If not present, malloc and free are used.  GNAT_NODE is used
+   to provide an error location for restriction violation messages.  */
 extern tree build_call_alloc_dealloc (tree gnu_obj, tree gnu_size,
-                                      unsigned align, Entity_Id gnat_proc,
+                                      tree gnu_type, Entity_Id gnat_proc,
 				      Entity_Id gnat_pool, Node_Id gnat_node);
 
 /* Build a GCC tree to correspond to allocating an object of TYPE whose
diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c
index 2c471f1..d37e3c1 100644
--- a/gcc/ada/gcc-interface/trans.c
+++ b/gcc/ada/gcc-interface/trans.c
@@ -5101,9 +5101,6 @@ gnat_to_gnu (Node_Id gnat_node)
 	  tree gnu_obj_type;
 	  tree gnu_actual_obj_type = 0;
 	  tree gnu_obj_size;
-	  unsigned int align;
-	  unsigned int default_allocator_alignment
-	    = get_target_default_allocator_alignment () * BITS_PER_UNIT;
 
 	  /* If this is a thin pointer, we must dereference it to create
 	     a fat pointer, then go back below to a thin pointer.  The
@@ -5142,7 +5139,6 @@ gnat_to_gnu (Node_Id gnat_node)
 	    gnu_actual_obj_type = gnu_obj_type;
 
 	  gnu_obj_size = TYPE_SIZE_UNIT (gnu_actual_obj_type);
-	  align = TYPE_ALIGN (gnu_obj_type);
 
 	  if (TREE_CODE (gnu_obj_type) == RECORD_TYPE
 	      && TYPE_CONTAINS_TEMPLATE_P (gnu_obj_type))
@@ -5159,42 +5155,11 @@ gnat_to_gnu (Node_Id gnat_node)
 					 gnu_ptr, gnu_byte_offset);
 	    }
 
- 	  /* If the object was allocated from the default storage pool, the
- 	     alignment was greater than what the allocator provides, and this
- 	     is not a fat or thin pointer, what we have in gnu_ptr here is an
- 	     address dynamically adjusted to match the alignment requirement
- 	     (see build_allocator).  What we need to pass to free is the
- 	     initial allocator's return value, which has been stored just in
- 	     front of the block we have.  */
-
- 	  if (No (Procedure_To_Call (gnat_node))
- 	      && align > default_allocator_alignment
- 	      && ! TYPE_FAT_OR_THIN_POINTER_P (gnu_ptr_type))
- 	    {
- 	      /* We set GNU_PTR
- 		 as * (void **)((void *)GNU_PTR - (void *)sizeof(void *))
- 		 in two steps:  */
-
- 	      /* GNU_PTR (void *)
-		 = (void *)GNU_PTR - (void *)sizeof (void *))  */
- 	      gnu_ptr
- 		= build_binary_op
-		    (POINTER_PLUS_EXPR, ptr_void_type_node,
-		     convert (ptr_void_type_node, gnu_ptr),
-		     size_int (-POINTER_SIZE/BITS_PER_UNIT));
-
- 	      /* GNU_PTR (void *) = *(void **)GNU_PTR  */
- 	      gnu_ptr
- 		= build_unary_op
-		    (INDIRECT_REF, NULL_TREE,
-		     convert (build_pointer_type (ptr_void_type_node),
-			      gnu_ptr));
- 	    }
-
-	  gnu_result = build_call_alloc_dealloc (gnu_ptr, gnu_obj_size, align,
-						 Procedure_To_Call (gnat_node),
-						 Storage_Pool (gnat_node),
-						 gnat_node);
+	  gnu_result
+	      = build_call_alloc_dealloc (gnu_ptr, gnu_obj_size, gnu_obj_type,
+					  Procedure_To_Call (gnat_node),
+					  Storage_Pool (gnat_node),
+					  gnat_node);
 	}
       break;
 
diff --git a/gcc/ada/gcc-interface/utils2.c b/gcc/ada/gcc-interface/utils2.c
index ec72a27..aab01f9b 100644
--- a/gcc/ada/gcc-interface/utils2.c
+++ b/gcc/ada/gcc-interface/utils2.c
@@ -1830,95 +1830,99 @@ build_component_ref (tree record_variable, tree component,
 				   N_Raise_Constraint_Error));
 }
 
-/* Build a GCC tree to call an allocation or deallocation function.
-   If GNU_OBJ is nonzero, it is an object to deallocate.  Otherwise,
-   generate an allocator.
+/* Helper for build_call_alloc_dealloc, with arguments to be interpreted
+   identically.  Process the case where a GNAT_PROC to call is provided.  */
 
-   GNU_SIZE is the size of the object in bytes and ALIGN is the alignment
-   in bits.  GNAT_PROC, if present, is a procedure to call and GNAT_POOL
-   is the storage pool to use.  If not present, malloc and free are used.
-   GNAT_NODE is used to provide an error location for restriction violation
-   messages.  */
-
-tree
-build_call_alloc_dealloc (tree gnu_obj, tree gnu_size, unsigned align,
-                          Entity_Id gnat_proc, Entity_Id gnat_pool,
-                          Node_Id gnat_node)
+static inline tree
+build_call_alloc_dealloc_proc (tree gnu_obj, tree gnu_size, tree gnu_type,
+			       Entity_Id gnat_proc, Entity_Id gnat_pool)
 {
-  tree gnu_align = size_int (align / BITS_PER_UNIT);
+  tree gnu_proc = gnat_to_gnu (gnat_proc);
+  tree gnu_proc_addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_proc);
+  tree gnu_call;
 
-  gnu_size = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_size, gnu_obj);
-
-  if (Present (gnat_proc))
+  /* The storage pools are obviously always tagged types, but the
+     secondary stack uses the same mechanism and is not tagged.  */
+  if (Is_Tagged_Type (Etype (gnat_pool)))
     {
-      /* The storage pools are obviously always tagged types, but the
-	 secondary stack uses the same mechanism and is not tagged.  */
-      if (Is_Tagged_Type (Etype (gnat_pool)))
-	{
-	  /* The size is the third parameter; the alignment is the
-             same type.  */
-	  Entity_Id gnat_size_type
-	    = Etype (Next_Formal (Next_Formal (First_Formal (gnat_proc))));
-	  tree gnu_size_type = gnat_to_gnu_type (gnat_size_type);
-	  tree gnu_proc = gnat_to_gnu (gnat_proc);
-	  tree gnu_proc_addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_proc);
-	  tree gnu_pool = gnat_to_gnu (gnat_pool);
-	  tree gnu_pool_addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_pool);
-	  tree gnu_call;
-
-	  gnu_size = convert (gnu_size_type, gnu_size);
-	  gnu_align = convert (gnu_size_type, gnu_align);
-
-	  /* The first arg is always the address of the storage pool; next
-	     comes the address of the object, for a deallocator, then the
-	     size and alignment.  */
-	  if (gnu_obj)
-	    gnu_call = build_call_nary (TREE_TYPE (TREE_TYPE (gnu_proc)),
-					gnu_proc_addr, 4, gnu_pool_addr,
-					gnu_obj, gnu_size, gnu_align);
-	  else
-	    gnu_call = build_call_nary (TREE_TYPE (TREE_TYPE (gnu_proc)),
-					gnu_proc_addr, 3, gnu_pool_addr,
-					gnu_size, gnu_align);
-	  TREE_SIDE_EFFECTS (gnu_call) = 1;
-	  return gnu_call;
-	}
+      /* The size is the third parameter; the alignment is the
+	 same type.  */
+      Entity_Id gnat_size_type
+	= Etype (Next_Formal (Next_Formal (First_Formal (gnat_proc))));
+      tree gnu_size_type = gnat_to_gnu_type (gnat_size_type);
+
+      tree gnu_pool = gnat_to_gnu (gnat_pool);
+      tree gnu_pool_addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_pool);
+      tree gnu_align = size_int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT);
+
+      gnu_size = convert (gnu_size_type, gnu_size);
+      gnu_align = convert (gnu_size_type, gnu_align);
+
+      /* The first arg is always the address of the storage pool; next
+	 comes the address of the object, for a deallocator, then the
+	 size and alignment.  */
+      if (gnu_obj)
+	gnu_call = build_call_nary (TREE_TYPE (TREE_TYPE (gnu_proc)),
+				    gnu_proc_addr, 4, gnu_pool_addr,
+				    gnu_obj, gnu_size, gnu_align);
+      else
+	gnu_call = build_call_nary (TREE_TYPE (TREE_TYPE (gnu_proc)),
+				    gnu_proc_addr, 3, gnu_pool_addr,
+				    gnu_size, gnu_align);
+    }
 
-      /* Secondary stack case.  */
+  /* Secondary stack case.  */
+  else
+    {
+      /* The size is the second parameter.  */
+      Entity_Id gnat_size_type
+	= Etype (Next_Formal (First_Formal (gnat_proc)));
+      tree gnu_size_type = gnat_to_gnu_type (gnat_size_type);
+
+      gnu_size = convert (gnu_size_type, gnu_size);
+
+      /* The first arg is the address of the object, for a deallocator,
+	 then the size.  */
+      if (gnu_obj)
+	gnu_call = build_call_nary (TREE_TYPE (TREE_TYPE (gnu_proc)),
+				    gnu_proc_addr, 2, gnu_obj, gnu_size);
       else
-	{
-	  /* The size is the second parameter.  */
-	  Entity_Id gnat_size_type
-	    = Etype (Next_Formal (First_Formal (gnat_proc)));
-	  tree gnu_size_type = gnat_to_gnu_type (gnat_size_type);
-	  tree gnu_proc = gnat_to_gnu (gnat_proc);
-	  tree gnu_proc_addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_proc);
-	  tree gnu_call;
-
-	  gnu_size = convert (gnu_size_type, gnu_size);
-
-	  /* The first arg is the address of the object, for a deallocator,
-	     then the size.  */
-	  if (gnu_obj)
-	    gnu_call = build_call_nary (TREE_TYPE (TREE_TYPE (gnu_proc)),
-					gnu_proc_addr, 2, gnu_obj, gnu_size);
-	  else
-	    gnu_call = build_call_nary (TREE_TYPE (TREE_TYPE (gnu_proc)),
-					gnu_proc_addr, 1, gnu_size);
-	  TREE_SIDE_EFFECTS (gnu_call) = 1;
-	  return gnu_call;
-	}
+	gnu_call = build_call_nary (TREE_TYPE (TREE_TYPE (gnu_proc)),
+				    gnu_proc_addr, 1, gnu_size);
     }
 
-  if (gnu_obj)
-    return build_call_1_expr (free_decl, gnu_obj);
+  TREE_SIDE_EFFECTS (gnu_call) = 1;
+  return gnu_call;
+}
+
+/* Helper for build_call_alloc_dealloc, to build and return an allocator for
+   DATA_SIZE bytes aimed at containing a DATA_TYPE object, using the default
+   __gnat_malloc allocator.  Honor DATA_TYPE alignments greater than what the
+   latter offers.  */
+
+static inline tree
+maybe_wrap_malloc (tree data_size, tree data_type, Node_Id gnat_node)
+{
+  /* When the DATA_TYPE alignment is stricter than what malloc offers
+     (super-aligned case), we allocate an "aligning" wrapper type and return
+     the address of its single data field with the malloc's return value
+     stored just in front.  */
+
+  unsigned int data_align = TYPE_ALIGN (data_type);
+  unsigned int default_allocator_alignment
+      = get_target_default_allocator_alignment () * BITS_PER_UNIT;
+
+  tree aligning_type
+    = ((data_align > default_allocator_alignment)
+       ? make_aligning_type (data_type, data_align, data_size,
+			     default_allocator_alignment,
+			     POINTER_SIZE / BITS_PER_UNIT)
+       : NULL_TREE);
 
-  /* Assert that we no longer can be called with this special pool.  */
-  gcc_assert (gnat_pool != -1);
+  tree size_to_malloc
+    = aligning_type ? TYPE_SIZE_UNIT (aligning_type) : data_size;
 
-  /* Check that we aren't violating the associated restriction.  */
-  if (!(Nkind (gnat_node) == N_Allocator && Comes_From_Source (gnat_node)))
-    Check_No_Implicit_Heap_Alloc (gnat_node);
+  tree malloc_ptr;
 
   /* On VMS, if 64-bit memory is disabled or pointers are 64-bit and the
      allocator size is 32-bit or Convention C, allocate 32-bit memory.  */
@@ -1927,9 +1931,127 @@ build_call_alloc_dealloc (tree gnu_obj, tree gnu_size, unsigned align,
 	  || (POINTER_SIZE == 64
 	      && (UI_To_Int (Esize (Etype (gnat_node))) == 32
 		  || Convention (Etype (gnat_node)) == Convention_C))))
-    return build_call_1_expr (malloc32_decl, gnu_size);
+    malloc_ptr = build_call_1_expr (malloc32_decl, size_to_malloc);
+  else
+    malloc_ptr = build_call_1_expr (malloc_decl, size_to_malloc);
 
-  return build_call_1_expr (malloc_decl, gnu_size);
+  if (aligning_type)
+    {
+      /* Latch malloc's return value and get a pointer to the aligning field
+	 first.  */
+      tree storage_ptr = save_expr (malloc_ptr);
+
+      tree aligning_record_addr
+	= convert (build_pointer_type (aligning_type), storage_ptr);
+
+      tree aligning_record
+	= build_unary_op (INDIRECT_REF, NULL_TREE, aligning_record_addr);
+
+      tree aligning_field
+	= build_component_ref (aligning_record, NULL_TREE,
+			       TYPE_FIELDS (aligning_type), 0);
+
+      tree aligning_field_addr
+        = build_unary_op (ADDR_EXPR, NULL_TREE, aligning_field);
+
+      /* Then arrange to store the allocator's return value ahead
+	 and return.  */
+      tree storage_ptr_slot_addr
+	= build_binary_op (POINTER_PLUS_EXPR, ptr_void_type_node,
+			   convert (ptr_void_type_node, aligning_field_addr),
+			   size_int (-POINTER_SIZE/BITS_PER_UNIT));
+
+      tree storage_ptr_slot
+	= build_unary_op (INDIRECT_REF, NULL_TREE,
+			  convert (build_pointer_type (ptr_void_type_node),
+				   storage_ptr_slot_addr));
+
+      return
+	build2 (COMPOUND_EXPR, TREE_TYPE (aligning_field_addr),
+		build_binary_op (MODIFY_EXPR, NULL_TREE,
+				 storage_ptr_slot, storage_ptr),
+		aligning_field_addr);
+    }
+  else
+    return malloc_ptr;
+}
+
+/* Helper for build_call_alloc_dealloc, to release a DATA_TYPE object
+   designated by DATA_PTR using the __gnat_free entry point.  */
+
+static inline tree
+maybe_wrap_free (tree data_ptr, tree data_type)
+{
+  /* In the regular alignment case, we pass the data pointer straight to free.
+     In the superaligned case, we need to retrieve the initial allocator
+     return value, stored in front of the data block at allocation time.  */
+
+  unsigned int data_align = TYPE_ALIGN (data_type);
+  unsigned int default_allocator_alignment
+      = get_target_default_allocator_alignment () * BITS_PER_UNIT;
+
+  tree free_ptr;
+
+  if (data_align > default_allocator_alignment)
+    {
+      /* DATA_FRONT_PTR (void *)
+	 = (void *)DATA_PTR - (void *)sizeof (void *))  */
+      tree data_front_ptr
+	= build_binary_op
+	  (POINTER_PLUS_EXPR, ptr_void_type_node,
+	   convert (ptr_void_type_node, data_ptr),
+	   size_int (-POINTER_SIZE/BITS_PER_UNIT));
+
+      /* FREE_PTR (void *) = *(void **)DATA_FRONT_PTR  */
+      free_ptr
+	= build_unary_op
+	  (INDIRECT_REF, NULL_TREE,
+	   convert (build_pointer_type (ptr_void_type_node), data_front_ptr));
+    }
+  else
+    free_ptr = data_ptr;
+
+  return build_call_1_expr (free_decl, free_ptr);
+}
+
+/* Build a GCC tree to call an allocation or deallocation function.
+   If GNU_OBJ is nonzero, it is an object to deallocate.  Otherwise,
+   generate an allocator.
+
+   GNU_SIZE is the number of bytes to allocate and GNU_TYPE is the contained
+   object type, used to determine the to-be-honored address alignment.
+   GNAT_PROC, if present, is a procedure to call and GNAT_POOL is the storage
+   pool to use.  If not present, malloc and free are used.  GNAT_NODE is used
+   to provide an error location for restriction violation messages.  */
+
+tree
+build_call_alloc_dealloc (tree gnu_obj, tree gnu_size, tree gnu_type,
+                          Entity_Id gnat_proc, Entity_Id gnat_pool,
+                          Node_Id gnat_node)
+{
+  gnu_size = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_size, gnu_obj);
+
+  /* Explicit proc to call ?  This one is assumed to deal with the type
+     alignment constraints.  */
+  if (Present (gnat_proc))
+    return build_call_alloc_dealloc_proc (gnu_obj, gnu_size, gnu_type,
+					  gnat_proc, gnat_pool);
+
+  /* Otherwise, object to "free" or "malloc" with possible special processing
+     for alignments stricter than what the default allocator honors.  */
+  else if (gnu_obj)
+    return maybe_wrap_free (gnu_obj, gnu_type);
+  else
+    {
+      /* Assert that we no longer can be called with this special pool.  */
+      gcc_assert (gnat_pool != -1);
+
+      /* Check that we aren't violating the associated restriction.  */
+      if (!(Nkind (gnat_node) == N_Allocator && Comes_From_Source (gnat_node)))
+	Check_No_Implicit_Heap_Alloc (gnat_node);
+
+      return maybe_wrap_malloc (gnu_size, gnu_type, gnat_node);
+    }
 }
 
 /* Build a GCC tree to correspond to allocating an object of TYPE whose
@@ -1949,8 +2071,6 @@ build_allocator (tree type, tree init, tree result_type, Entity_Id gnat_proc,
 {
   tree size = TYPE_SIZE_UNIT (type);
   tree result;
-  unsigned int default_allocator_alignment
-    = get_target_default_allocator_alignment () * BITS_PER_UNIT;
 
   /* If the initializer, if present, is a NULL_EXPR, just return a new one.  */
   if (init && TREE_CODE (init) == NULL_EXPR)
@@ -1977,8 +2097,7 @@ build_allocator (tree type, tree init, tree result_type, Entity_Id gnat_proc,
       if (TREE_CODE (size) == INTEGER_CST && TREE_OVERFLOW (size))
 	size = ssize_int (-1);
 
-      storage = build_call_alloc_dealloc (NULL_TREE, size,
-					  TYPE_ALIGN (storage_type),
+      storage = build_call_alloc_dealloc (NULL_TREE, size, storage_type,
 					  gnat_proc, gnat_pool, gnat_node);
       storage = convert (storage_ptr_type, protect_multiple_eval (storage));
 
@@ -2050,70 +2169,10 @@ build_allocator (tree type, tree init, tree result_type, Entity_Id gnat_proc,
   if (TREE_CODE (size) == INTEGER_CST && TREE_OVERFLOW (size))
     size = ssize_int (-1);
 
-  /* If this is in the default storage pool and the type alignment is larger
-     than what the default allocator supports, make an "aligning" record type
-     with room to store a pointer before the field, allocate an object of that
-     type, store the system's allocator return value just in front of the
-     field and return the field's address.  */
-
-  if (No (gnat_proc) && TYPE_ALIGN (type) > default_allocator_alignment)
-    {
-      /* Construct the aligning type with enough room for a pointer ahead
-	 of the field, then allocate.  */
-      tree record_type
-	= make_aligning_type (type, TYPE_ALIGN (type), size,
-			      default_allocator_alignment,
-			      POINTER_SIZE / BITS_PER_UNIT);
-
-      tree record, record_addr;
-
-      record_addr
-	= build_call_alloc_dealloc (NULL_TREE, TYPE_SIZE_UNIT (record_type),
-				    default_allocator_alignment, Empty, Empty,
-				    gnat_node);
-
-      record_addr
-	= convert (build_pointer_type (record_type),
-		   save_expr (record_addr));
-
-      record = build_unary_op (INDIRECT_REF, NULL_TREE, record_addr);
-
-      /* Our RESULT (the Ada allocator's value) is the super-aligned address
-	 of the internal record field ... */
-      result
-	= build_unary_op (ADDR_EXPR, NULL_TREE,
-			  build_component_ref
-			  (record, NULL_TREE, TYPE_FIELDS (record_type), 0));
-      result = convert (result_type, result);
-
-      /* ... with the system allocator's return value stored just in
-	 front.  */
-      {
-	tree ptr_addr
-	  = build_binary_op (POINTER_PLUS_EXPR, ptr_void_type_node,
-			     convert (ptr_void_type_node, result),
-			     size_int (-POINTER_SIZE/BITS_PER_UNIT));
-
-	tree ptr_ref
-	  = convert (build_pointer_type (ptr_void_type_node), ptr_addr);
-
-	result
-	  = build2 (COMPOUND_EXPR, TREE_TYPE (result),
-		    build_binary_op (MODIFY_EXPR, NULL_TREE,
-				     build_unary_op (INDIRECT_REF, NULL_TREE,
-						     ptr_ref),
-				     convert (ptr_void_type_node,
-					      record_addr)),
-		    result);
-      }
-    }
-  else
-    result = convert (result_type,
-		      build_call_alloc_dealloc (NULL_TREE, size,
-						TYPE_ALIGN (type),
-						gnat_proc,
-						gnat_pool,
-						gnat_node));
+  result = convert (result_type,
+		    build_call_alloc_dealloc (NULL_TREE, size, type,
+					      gnat_proc, gnat_pool,
+					      gnat_node));
 
   /* If we have an initial value, put the new address into a SAVE_EXPR, assign
      the value, and return the address.  Do this with a COMPOUND_EXPR.  */
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index b08a0b9..cb9ec0c 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,7 @@
+2009-06-09  Olivier Hainque  <hainque@adacore.com>
+
+	* gnat.dg/align_max.adb: New test.
+
 2009-06-08  Jason Merrill  <jason@redhat.com>
 
 	* g++.dg/cpp0x/auto15.C: New.
diff --git a/gcc/testsuite/gnat.dg/align_max.adb b/gcc/testsuite/gnat.dg/align_max.adb
new file mode 100644
index 0000000..26597ea
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/align_max.adb
@@ -0,0 +1,137 @@
+--  { dg-do run }
+
+with System.Storage_Elements; use System.Storage_Elements;
+with Ada.Unchecked_Deallocation;
+
+procedure Align_MAX is
+
+   Align : constant := Standard'Maximum_Alignment;
+
+   generic
+      type Data_Type (<>) is private;
+      type Access_Type is access Data_Type;
+      with function Allocate return Access_Type;
+      with function Address (Ptr : Access_Type) return System.Address;
+   package Check is
+      --  The hooks below just force asm generation that helps associating
+      --  obscure nested function names with their package instance name.
+      Hook_Allocate : System.Address := Allocate'Address;
+      Hook_Address : System.Address := Address'Address;
+      pragma Volatile (Hook_Allocate);
+      pragma Volatile (Hook_Address);
+
+      procedure Run (Announce : String);
+   end;
+
+   package body Check is
+
+      procedure Free is new
+        Ada.Unchecked_Deallocation (Data_Type, Access_Type);
+
+      procedure Run (Announce : String) is
+         Addr : System.Address;
+         Blocks : array (1 .. 1024) of Access_Type;
+      begin
+         for J in Blocks'Range loop
+            Blocks (J) := Allocate;
+            Addr := Address (Blocks (J));
+            if Addr mod Data_Type'Alignment /= 0 then
+               raise Program_Error;
+            end if;
+         end loop;
+
+         for J in Blocks'Range loop
+            Free (Blocks (J));
+         end loop;
+      end;
+   end;
+
+begin
+   declare
+      type Array_Type is array (Integer range <>) of Integer;
+      for Array_Type'Alignment use Align;
+
+      type FAT_Array_Access is access all Array_Type;
+
+      function Allocate return FAT_Array_Access is
+      begin
+         return new Array_Type (1 .. 1);
+      end;
+
+      function Address (Ptr : FAT_Array_Access) return System.Address is
+      begin
+         return Ptr(1)'Address;
+      end;
+      package Check_FAT is new
+        Check (Array_Type, FAT_Array_Access, Allocate, Address);
+   begin
+      Check_FAT.Run ("Checking FAT pointer to UNC array");
+   end;
+
+   declare
+      type Array_Type is array (Integer range <>) of Integer;
+      for Array_Type'Alignment use Align;
+
+      type THIN_Array_Access is access all Array_Type;
+      for THIN_Array_Access'Size use Standard'Address_Size;
+
+      function Allocate return THIN_Array_Access is
+      begin
+         return new Array_Type (1 .. 1);
+      end;
+
+      function Address (Ptr : THIN_Array_Access) return System.Address is
+      begin
+         return Ptr(1)'Address;
+      end;
+      package Check_THIN is new
+        Check (Array_Type, THIN_Array_Access, Allocate, Address);
+   begin
+      Check_THIN.Run ("Checking THIN pointer to UNC array");
+   end;
+
+   declare
+      type Array_Type is array (Integer range 1 .. 1) of Integer;
+      for Array_Type'Alignment use Align;
+
+      type Array_Access is access all Array_Type;
+
+      function Allocate return Array_Access is
+      begin
+         return new Array_Type;
+      end;
+
+      function Address (Ptr : Array_Access) return System.Address is
+      begin
+         return Ptr(1)'Address;
+      end;
+      package Check_Array is new
+        Check (Array_Type, Array_Access, Allocate, Address);
+   begin
+      Check_Array.Run ("Checking pointer to constrained array");
+   end;
+
+   declare
+      type Record_Type is record
+         Value : Integer;
+      end record;
+      for Record_Type'Alignment use Align;
+
+      type Record_Access is access all Record_Type;
+
+      function Allocate return Record_Access is
+      begin
+         return new Record_Type;
+      end;
+
+      function Address (Ptr : Record_Access) return System.Address is
+      begin
+         return Ptr.all'Address;
+      end;
+      package Check_Record is new
+        Check (Record_Type, Record_Access, Allocate, Address);
+   begin
+      Check_Record.Run ("Checking pointer to record");
+   end;
+end;
+