[gcc r13-3800] ada: Fix oversight in implementation of allocators for storage models

[gcc r13-3800] ada: Fix oversight in implementation of allocators for storage models

[Marc Poulhi?s]

https://gcc.gnu.org/g:b2278f6b146595b3f80a072145a78877041cb8bc

commit r13-3800-gb2278f6b146595b3f80a072145a78877041cb8bc
Author: Eric Botcazou <ebotcazou@adacore.com>
Date:   Tue Oct 18 11:32:02 2022 +0200

    ada: Fix oversight in implementation of allocators for storage models
    
    When the allocator is of an unconstrained array type and has an initializing
    expression, the copy of the initializing expression must be done separately
    from that of the bounds.
    
    gcc/ada/
    
            * gcc-interface/utils2.cc (build_allocator): For unconstrained
            array types with a storage model and an initializing expression,
            copy the initialization expression separately from the bounds. In
            all cases with a storage model, pass the locally computed size for
            the store.

Diff:
---
 gcc/ada/gcc-interface/utils2.cc | 33 ++++++++++++++++++++++++++-------
 1 file changed, 26 insertions(+), 7 deletions(-)

diff --git a/gcc/ada/gcc-interface/utils2.cc b/gcc/ada/gcc-interface/utils2.cc
index ef81f8dd56a..80d550c91e1 100644
--- a/gcc/ada/gcc-interface/utils2.cc
+++ b/gcc/ada/gcc-interface/utils2.cc
@@ -2439,8 +2439,8 @@ build_allocator (tree type, tree init, tree result_type, Entity_Id gnat_proc,
       tree storage_ptr_type = build_pointer_type (storage_type);
       tree lhs, rhs;
 
-      size = SUBSTITUTE_PLACEHOLDER_IN_EXPR (TYPE_SIZE_UNIT (storage_type),
-					     init);
+      size = TYPE_SIZE_UNIT (storage_type);
+      size = SUBSTITUTE_PLACEHOLDER_IN_EXPR (size, init);
 
       /* If the size overflows, pass -1 so Storage_Error will be raised.  */
       if (TREE_CODE (size) == INTEGER_CST && !valid_constant_size_p (size))
@@ -2454,8 +2454,10 @@ build_allocator (tree type, tree init, tree result_type, Entity_Id gnat_proc,
 
       /* If there is an initializing expression, then make a constructor for
 	 the entire object including the bounds and copy it into the object.
-	 If there is no initializing expression, just set the bounds.  */
-      if (init)
+	 If there is no initializing expression, just set the bounds.  Note
+	 that, if we have a storage model, we need to copy the initializing
+	 expression separately from the bounds.  */
+      if (init && !pool_is_storage_model)
 	{
 	  vec<constructor_elt, va_gc> *v;
 	  vec_alloc (v, 2);
@@ -2472,11 +2474,28 @@ build_allocator (tree type, tree init, tree result_type, Entity_Id gnat_proc,
 	{
 	  lhs = build_component_ref (storage_deref, TYPE_FIELDS (storage_type),
 				     false);
-	  rhs = build_template (template_type, type, NULL_TREE);
+	  rhs = build_template (template_type, type, init);
 	}
 
       if (pool_is_storage_model)
-	storage_init = build_storage_model_store (gnat_pool, lhs, rhs);
+	{
+	  storage_init = build_storage_model_store (gnat_pool, lhs, rhs);
+	  if (init)
+	    {
+	      start_stmt_group ();
+	      add_stmt (storage_init);
+	      lhs
+		= build_component_ref (storage_deref,
+				       DECL_CHAIN (TYPE_FIELDS (storage_type)),
+				       false);
+	      rhs = init;
+	      size = TYPE_SIZE_UNIT (TREE_TYPE (lhs));
+	      size = SUBSTITUTE_PLACEHOLDER_IN_EXPR (size, init);
+	      tree t = build_storage_model_store (gnat_pool, lhs, rhs, size);
+	      add_stmt (t);
+	      storage_init = end_stmt_group ();
+	    }
+	}
       else
 	storage_init = build_binary_op (INIT_EXPR, NULL_TREE, lhs, rhs);
 
@@ -2520,7 +2539,7 @@ build_allocator (tree type, tree init, tree result_type, Entity_Id gnat_proc,
       TREE_THIS_NOTRAP (storage_deref) = 1;
       if (pool_is_storage_model)
 	storage_init
-	  = build_storage_model_store (gnat_pool, storage_deref, init);
+	  = build_storage_model_store (gnat_pool, storage_deref, init, size);
       else
 	storage_init
 	  = build_binary_op (INIT_EXPR, NULL_TREE, storage_deref, init);