[gcc(refs/users/mikael/heads/refactor_descriptor_v291.01)] Extraction gfc_set_temporary_descriptor

https://gcc.gnu.org/g:794434a6d4eca8a3f85e9494799ce39f81252508

commit 794434a6d4eca8a3f85e9494799ce39f81252508
Author: Mikael Morin <[email protected]>
Date:   Wed Jul 23 12:12:01 2025 +0200

    Extraction gfc_set_temporary_descriptor

Diff:
---
 gcc/fortran/trans-array.cc      | 61 +++++++++++++----------------------------
 gcc/fortran/trans-descriptor.cc | 53 +++++++++++++++++++++++++++++++++++
 gcc/fortran/trans-descriptor.h  |  4 +++
 3 files changed, 76 insertions(+), 42 deletions(-)

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 876d866d533d..c1b4b9b0b71c 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -732,13 +732,14 @@ gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping,
    DYNAMIC is true if the caller may want to extend the array later
    using realloc.  This prevents us from putting the array on the stack.  */
 
-static void
+static tree
 gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
 				  gfc_array_info * info, tree size, tree nelem,
 				  tree initial, bool dynamic, bool dealloc)
 {
   tree tmp;
   tree desc;
+  tree ptr = NULL_TREE;
   bool onstack;
 
   desc = info->descriptor;
@@ -746,7 +747,7 @@ gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
   if (size == NULL_TREE || (dynamic && integer_zerop (size)))
     {
       /* A callee allocated array.  */
-      gfc_conv_descriptor_data_set (pre, desc, null_pointer_node);
+      ptr = null_pointer_node;
       onstack = false;
     }
   else
@@ -774,8 +775,7 @@ gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
 				   fold_build1_loc (input_location,
 						    DECL_EXPR, TREE_TYPE (tmp),
 						    tmp));
-	  tmp = gfc_build_addr_expr (NULL_TREE, tmp);
-	  gfc_conv_descriptor_data_set (pre, desc, tmp);
+	  ptr = gfc_build_addr_expr (NULL_TREE, tmp);
 	}
       else
 	{
@@ -783,7 +783,7 @@ gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
 	  if (initial == NULL_TREE)
 	    {
 	      tmp = gfc_call_malloc (pre, NULL, size);
-	      tmp = gfc_evaluate_now (tmp, pre);
+	      ptr = gfc_evaluate_now (tmp, pre);
 	    }
 	  else
 	    {
@@ -826,18 +826,12 @@ gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
 			      build_empty_stmt (input_location));
 	      gfc_add_expr_to_block (pre, tmp);
 
-	      tmp = fold_convert (pvoid_type_node, packed);
+	      ptr = fold_convert (pvoid_type_node, packed);
 	    }
-
-	  gfc_conv_descriptor_data_set (pre, desc, tmp);
 	}
     }
   info->data = gfc_conv_descriptor_data_get (desc);
 
-  /* The offset is zero because we create temporaries with a zero
-     lower bound.  */
-  gfc_conv_descriptor_offset_set (pre, desc, gfc_index_zero_node);
-
   if (dealloc && !onstack)
     {
       /* Free the temporary.  */
@@ -845,6 +839,8 @@ gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
       tmp = gfc_call_free (tmp);
       gfc_add_expr_to_block (post, tmp);
     }
+
+  return ptr;
 }
 
 
@@ -1078,6 +1074,7 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss,
   gfc_ss *s;
   gfc_array_info *info;
   tree from[GFC_MAX_DIMENSIONS], to[GFC_MAX_DIMENSIONS];
+  tree stride[GFC_MAX_DIMENSIONS];
   tree type;
   tree desc;
   tree tmp;
@@ -1213,13 +1210,12 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss,
       TREE_USED (desc) = 0;
     }
 
+  bool rank_changer = false;
   if (class_expr != NULL_TREE
       || (fcn_ss && fcn_ss->info && fcn_ss->info->class_container))
     {
       tree class_data;
-      tree dtype;
       gfc_expr *expr1 = fcn_ss ? fcn_ss->info->expr : NULL;
-      bool rank_changer;
 
       /* Pick out these transformational functions because they change the rank
 	 or shape of the first argument. This requires that the class type be
@@ -1273,16 +1269,7 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss,
       class_data = gfc_class_data_get (tmp);
 
       if (rank_changer)
-	{
-	  /* Take the dtype from the class expression.  */
-	  tree class_descr = gfc_class_data_get (class_expr);
-	  dtype = gfc_conv_descriptor_dtype_get (class_descr);
-	  gfc_conv_descriptor_dtype_set (pre, desc, dtype);
-
-	  /* These transformational functions change the rank.  */
-	  gfc_conv_descriptor_rank_set (pre, desc, ss->loop->dimen);
-	  fcn_ss->info->class_container = NULL_TREE;
-	}
+	fcn_ss->info->class_container = NULL_TREE;
 
       /* Assign the new descriptor to the _data field. This allows the
 	 vptr _copy to be used for scalarized assignment since the class
@@ -1294,12 +1281,6 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss,
       /* Point desc to the class _data field.  */
       desc = class_data;
     }
-  else
-    {
-      /* Fill in the array dtype.  */
-      gfc_conv_descriptor_dtype_set (pre, desc,
-				     gfc_get_dtype (TREE_TYPE (desc)));
-    }
 
   info->descriptor = desc;
   size = gfc_index_one_node;
@@ -1346,13 +1327,7 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss,
     {
       for (n = 0; n < total_dim; n++)
 	{
-	  /* Store the stride and bound components in the descriptor.  */
-	  gfc_conv_descriptor_stride_set (pre, desc, gfc_rank_cst[n], size);
-
-	  gfc_conv_descriptor_lbound_set (pre, desc, gfc_rank_cst[n],
-					  gfc_index_zero_node);
-
-	  gfc_conv_descriptor_ubound_set (pre, desc, gfc_rank_cst[n], to[n]);
+	  stride[n] = size;
 
 	  tmp = fold_build2_loc (input_location, PLUS_EXPR,
 				 gfc_array_index_type,
@@ -1393,12 +1368,14 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss,
       size = NULL_TREE;
     }
 
-  /* Set the span.  */
-  tmp = fold_convert (gfc_array_index_type, elemsize);
-  gfc_conv_descriptor_span_set (pre, desc, tmp);
+  tree data_ptr = gfc_trans_allocate_array_storage (pre, post, info, size,
+						    nelem, initial, dynamic,
+						    dealloc);
 
-  gfc_trans_allocate_array_storage (pre, post, info, size, nelem, initial,
-				    dynamic, dealloc);
+  gfc_set_temporary_descriptor (pre, desc, class_expr, elemsize, data_ptr,
+				to, stride, total_dim,
+				size == NULL_TREE || callee_alloc,
+				rank_changer);
 
   while (ss->parent)
     ss = ss->parent;
diff --git a/gcc/fortran/trans-descriptor.cc b/gcc/fortran/trans-descriptor.cc
index bdbbefba8bd9..35b1987b386d 100644
--- a/gcc/fortran/trans-descriptor.cc
+++ b/gcc/fortran/trans-descriptor.cc
@@ -2290,3 +2290,56 @@ gfc_set_gfc_from_cfi (stmtblock_t *block, stmtblock_t *block2, tree gfc_desc,
 
   gfc_conv_descriptor_offset_set (block2, gfc_desc, offset);
 }
+
+
+void
+gfc_set_temporary_descriptor (stmtblock_t *block, tree descr, tree class_src,
+			      tree elemsize, tree data_ptr,
+			      tree ubound[GFC_MAX_DIMENSIONS],
+			      tree stride[GFC_MAX_DIMENSIONS], int rank,
+			      bool callee_allocated, bool rank_changer)
+{
+  if (!class_src)
+    {
+      /* Fill in the array dtype.  */
+      gfc_conv_descriptor_dtype_set (block, descr,
+				     gfc_get_dtype (TREE_TYPE (descr)));
+    }
+  else if (rank_changer)
+    {
+      /* For classes, we copy the whole original class descriptor to the
+	 temporary one, so we don't need to set the individual dtype fields.
+	 Except for the case of rank altering intrinsics for which we
+	 generate descriptors of different rank.  */
+
+      /* Take the dtype from the class expression.  */
+      tree class_descr = gfc_class_data_get (class_src);
+      tree dtype = gfc_conv_descriptor_dtype_get (class_descr);
+      gfc_conv_descriptor_dtype_set (block, descr, dtype);
+
+      /* These transformational functions change the rank.  */
+      gfc_conv_descriptor_rank_set (block, descr, rank);
+    }
+
+  if (!callee_allocated)
+    for (int n = 0; n < rank; n++)
+      {
+	/* Store the stride and bound components in the descriptor.  */
+	gfc_conv_descriptor_stride_set (block, descr, gfc_rank_cst[n],
+					stride[n]);
+
+	gfc_conv_descriptor_lbound_set (block, descr, gfc_rank_cst[n],
+					gfc_index_zero_node);
+
+	gfc_conv_descriptor_ubound_set (block, descr, gfc_rank_cst[n],
+					ubound[n]);
+      }
+
+  gfc_conv_descriptor_span_set (block, descr, elemsize);
+
+  /* The offset is zero because we create temporaries with a zero
+     lower bound.  */
+  gfc_conv_descriptor_offset_set (block, descr, gfc_index_zero_node);
+
+  gfc_conv_descriptor_data_set (block, descr, data_ptr);
+}
diff --git a/gcc/fortran/trans-descriptor.h b/gcc/fortran/trans-descriptor.h
index 0386ebc4453f..092b9d99bc7d 100644
--- a/gcc/fortran/trans-descriptor.h
+++ b/gcc/fortran/trans-descriptor.h
@@ -124,4 +124,8 @@ void gfc_set_gfc_from_cfi (stmtblock_t *, tree, gfc_expr *, tree, tree,
 void gfc_set_gfc_from_cfi (stmtblock_t *, stmtblock_t *, tree, tree, tree,
 			   gfc_symbol *, bool);
 
+void gfc_set_temporary_descriptor (stmtblock_t *, tree, tree, tree, tree,
+				   tree [GFC_MAX_DIMENSIONS],
+				   tree [GFC_MAX_DIMENSIONS], int, bool, bool);
+
 #endif /* GFC_TRANS_DESCRIPTOR_H */