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

Mikael Morin via Gcc-cvs <[email protected]>
Newsgroups gmane.comp.gcc.cvs
Message-ID <[email protected]> 
https://gcc.gnu.org/g:879c3f21e61475a61b795df12d560bf68b6489f5

commit 879c3f21e61475a61b795df12d560bf68b6489f5
Author: Mikael Morin <[email protected]>
Date:   Wed Jul 23 17:07:24 2025 +0200

    Extraction gfc_conv_remap_descriptor

Diff:
---
 gcc/fortran/trans-descriptor.cc | 134 +++++++++++++++++++++++++++++++++++++++-
 gcc/fortran/trans-descriptor.h  |   6 +-
 gcc/fortran/trans-expr.cc       | 125 ++-----------------------------------
 3 files changed, 142 insertions(+), 123 deletions(-)

diff --git a/gcc/fortran/trans-descriptor.cc b/gcc/fortran/trans-descriptor.cc
index 5771788c517c..3b7803314ee8 100644
--- a/gcc/fortran/trans-descriptor.cc
+++ b/gcc/fortran/trans-descriptor.cc
@@ -1199,10 +1199,24 @@ array_ref_to_array_spec (const gfc_array_ref &ref, gfc_array_spec &spec)
 
 void
 gfc_conv_shift_descriptor (stmtblock_t *block, tree desc,
-			   const gfc_array_ref &ar)
+			   const gfc_array_ref &ar, gfc_expr *src_expr,
+			   bool unlimited_poly_dest)
 {
-  gfc_array_spec as;
+  /* Always set dtype.  */
+  gfc_conv_descriptor_dtype_set (block, desc,
+				 gfc_get_dtype (TREE_TYPE (desc)));
+
+  /* For unlimited polymorphic LHS use elem_len from RHS.  */
+  if (unlimited_poly_dest && src_expr->ts.type != BT_CLASS)
+    {
+      tree elem_len;
+      tree tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&src_expr->ts));
+      elem_len = fold_convert (gfc_array_index_type, tmp);
+      elem_len = gfc_evaluate_now (elem_len, block);
+      gfc_conv_descriptor_elem_len_set (block, desc, elem_len);
+    }
 
+  gfc_array_spec as;
   array_ref_to_array_spec (ar, as);
 
   conv_shift_descriptor (block, desc, as);
@@ -1544,3 +1558,119 @@ gfc_copy_descriptor (stmtblock_t *block, tree dest, tree src, tree ptr,
 
   gfc_conv_descriptor_data_set (block, dest, ptr);
 }
+
+
+void
+gfc_conv_remap_descriptor (stmtblock_t *block, tree dest, int dest_rank,
+			   tree src, gfc_expr *src_expr, gfc_array_ref *ar,
+			   bool unlimited_poly_dest)
+{
+  /* Set dtype.  */
+  gfc_conv_descriptor_dtype_set (block, dest,
+				 gfc_get_dtype (TREE_TYPE (dest)));
+
+  /* For unlimited polymorphic LHS use elem_len from RHS.  */
+  if (unlimited_poly_dest && src_expr->ts.type != BT_CLASS)
+    {
+      tree elem_len;
+      tree tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&src_expr->ts));
+      elem_len = fold_convert (gfc_array_index_type, tmp);
+      elem_len = gfc_evaluate_now (elem_len, block);
+      gfc_conv_descriptor_elem_len_set (block, dest, elem_len);
+    }
+
+  /* Copy data pointer.  */
+  gfc_conv_descriptor_data_set (block, dest,
+				gfc_conv_descriptor_data_get (src));
+
+  /* Copy the span.  */
+  tree span;
+  if (VAR_P (src)
+      && GFC_DECL_PTR_ARRAY_P (src))
+    span = gfc_conv_descriptor_span_get (src);
+  else
+    {
+      tree tmp = TREE_TYPE (src);
+      tmp = TYPE_SIZE_UNIT (gfc_get_element_type (tmp));
+      span = fold_convert (gfc_array_index_type, tmp);
+    }
+  gfc_conv_descriptor_span_set (block, dest, span);
+
+  /* Copy offset but adjust it such that it would correspond
+     to a lbound of zero.  */
+  if (src_expr->rank == -1)
+    gfc_conv_descriptor_offset_set (block, dest,
+				    gfc_index_zero_node);
+  else
+    {
+      tree offs = gfc_conv_descriptor_offset_get (src);
+      for (int dim = 0; dim < src_expr->rank; ++dim)
+	{
+	  tree stride = gfc_conv_descriptor_stride_get (src, gfc_rank_cst[dim]);
+	  tree lbound = gfc_conv_descriptor_lbound_get (src, gfc_rank_cst[dim]);
+	  tree tmp = fold_build2_loc (input_location, MULT_EXPR,
+				      gfc_array_index_type, stride, lbound);
+	  offs = fold_build2_loc (input_location, PLUS_EXPR,
+				  gfc_array_index_type, offs, tmp);
+	}
+      gfc_conv_descriptor_offset_set (block, dest, offs);
+    }
+
+  /* Set the bounds as declared for the LHS and calculate strides as
+     well as another offset update accordingly.  */
+  tree stride = gfc_conv_descriptor_stride_get (src, gfc_rank_cst[0]);
+  for (int dim = 0; dim < dest_rank; ++dim)
+    {
+      gfc_se lower_se;
+      gfc_se upper_se;
+
+      gcc_assert (ar->start[dim] && ar->end[dim]);
+
+      if (ar->start[dim]->expr_type != EXPR_CONSTANT
+	  || ar->start[dim]->expr_type != EXPR_VARIABLE)
+	gfc_resolve_expr (ar->start[dim]);
+      if (ar->end[dim]->expr_type != EXPR_CONSTANT
+	  || ar->end[dim]->expr_type != EXPR_VARIABLE)
+	gfc_resolve_expr (ar->end[dim]);
+
+      /* Convert declared bounds.  */
+      gfc_init_se (&lower_se, NULL);
+      gfc_init_se (&upper_se, NULL);
+      gfc_conv_expr (&lower_se, ar->start[dim]);
+      gfc_conv_expr (&upper_se, ar->end[dim]);
+
+      gfc_add_block_to_block (block, &lower_se.pre);
+      gfc_add_block_to_block (block, &upper_se.pre);
+
+      tree lbound = fold_convert (gfc_array_index_type, lower_se.expr);
+      tree ubound = fold_convert (gfc_array_index_type, upper_se.expr);
+
+      lbound = gfc_evaluate_now (lbound, block);
+      ubound = gfc_evaluate_now (ubound, block);
+
+      gfc_add_block_to_block (block, &lower_se.post);
+      gfc_add_block_to_block (block, &upper_se.post);
+
+      /* Set bounds in descriptor.  */
+      gfc_conv_descriptor_lbound_set (block, dest, gfc_rank_cst[dim], lbound);
+      gfc_conv_descriptor_ubound_set (block, dest, gfc_rank_cst[dim], ubound);
+
+      /* Set stride.  */
+      stride = gfc_evaluate_now (stride, block);
+      gfc_conv_descriptor_stride_set (block, dest, gfc_rank_cst[dim], stride);
+
+      /* Update offset.  */
+      tree offs = gfc_conv_descriptor_offset_get (dest);
+      tree tmp = fold_build2_loc (input_location, MULT_EXPR,
+				  gfc_array_index_type, lbound, stride);
+      offs = fold_build2_loc (input_location, MINUS_EXPR,
+			      gfc_array_index_type, offs, tmp);
+      offs = gfc_evaluate_now (offs, block);
+      gfc_conv_descriptor_offset_set (block, dest, offs);
+
+      /* Update stride.  */
+      tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
+      stride = fold_build2_loc (input_location, MULT_EXPR,
+				gfc_array_index_type, stride, tmp);
+    }
+}
diff --git a/gcc/fortran/trans-descriptor.h b/gcc/fortran/trans-descriptor.h
index f13ef56f264e..789c9d60d7f7 100644
--- a/gcc/fortran/trans-descriptor.h
+++ b/gcc/fortran/trans-descriptor.h
@@ -88,7 +88,8 @@ void gfc_init_descriptor_variable (stmtblock_t *block, gfc_symbol *sym, tree des
 void gfc_copy_coarray_desc_part (stmtblock_t *, tree, tree);
 
 void gfc_conv_shift_descriptor (stmtblock_t *, tree, int);
-void gfc_conv_shift_descriptor (stmtblock_t *, tree, const gfc_array_ref &);
+void gfc_conv_shift_descriptor (stmtblock_t *, tree, const gfc_array_ref &,
+				gfc_expr *, bool);
 void gfc_conv_shift_descriptor (stmtblock_t *, tree, tree, int, tree);
 void gfc_set_subarray_descriptor (stmtblock_t *, tree, tree, gfc_expr *, gfc_expr *);
 void gfc_shift_descriptor (stmtblock_t *, tree, int, tree [GFC_MAX_DIMENSIONS],
@@ -99,6 +100,9 @@ void gfc_copy_descriptor (stmtblock_t *, tree, tree, gfc_expr *, bool);
 void gfc_copy_descriptor (stmtblock_t *, tree, tree, tree, int);
 void gfc_copy_descriptor (stmtblock_t *, tree, tree, bool);
 
+void gfc_conv_remap_descriptor (stmtblock_t *, tree, int, tree, gfc_expr *,
+				gfc_array_ref *, bool);
+
 void gfc_set_descriptor_from_scalar_class (stmtblock_t *, tree, tree, gfc_expr *);
 void gfc_set_descriptor_from_scalar (stmtblock_t *, tree, tree, symbol_attribute,
 				     tree = NULL_TREE, tree = NULL_TREE);
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index b16b9970cf2c..89de7d50251a 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -11283,136 +11283,21 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
       /* If we do bounds remapping, update LHS descriptor accordingly.  */
       if (remap)
 	{
-	  int dim;
 	  gcc_assert (remap->u.ar.dimen == expr1->rank);
 
-	  /* Always set dtype.  */
-	  gfc_conv_descriptor_dtype_set (&block, desc,
-					 gfc_get_dtype (TREE_TYPE (desc)));
-
-	  /* For unlimited polymorphic LHS use elem_len from RHS.  */
-	  if (UNLIMITED_POLY (expr1) && expr2->ts.type != BT_CLASS)
-	    {
-	      tree elem_len;
-	      tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2->ts));
-	      elem_len = fold_convert (gfc_array_index_type, tmp);
-	      elem_len = gfc_evaluate_now (elem_len, &block);
-	      gfc_conv_descriptor_elem_len_set (&block, desc, elem_len);
-	    }
-
 	  if (rank_remap)
 	    {
 	      /* Do rank remapping.  We already have the RHS's descriptor
 		 converted in rse and now have to build the correct LHS
 		 descriptor for it.  */
-
-	      tree data, span;
-	      tree offs, stride;
-	      tree lbound, ubound;
-
-	      /* Copy data pointer.  */
-	      data = gfc_conv_descriptor_data_get (rse.expr);
-	      gfc_conv_descriptor_data_set (&block, desc, data);
-
-	      /* Copy the span.  */
-	      if (VAR_P (rse.expr)
-		  && GFC_DECL_PTR_ARRAY_P (rse.expr))
-		span = gfc_conv_descriptor_span_get (rse.expr);
-	      else
-		{
-		  tmp = TREE_TYPE (rse.expr);
-		  tmp = TYPE_SIZE_UNIT (gfc_get_element_type (tmp));
-		  span = fold_convert (gfc_array_index_type, tmp);
-		}
-	      gfc_conv_descriptor_span_set (&block, desc, span);
-
-	      /* Copy offset but adjust it such that it would correspond
-		 to a lbound of zero.  */
-	      if (expr2->rank == -1)
-		gfc_conv_descriptor_offset_set (&block, desc,
-						gfc_index_zero_node);
-	      else
-		{
-		  offs = gfc_conv_descriptor_offset_get (rse.expr);
-		  for (dim = 0; dim < expr2->rank; ++dim)
-		    {
-		      stride = gfc_conv_descriptor_stride_get (rse.expr,
-							gfc_rank_cst[dim]);
-		      lbound = gfc_conv_descriptor_lbound_get (rse.expr,
-							gfc_rank_cst[dim]);
-		      tmp = fold_build2_loc (input_location, MULT_EXPR,
-					     gfc_array_index_type, stride,
-					     lbound);
-		      offs = fold_build2_loc (input_location, PLUS_EXPR,
-					      gfc_array_index_type, offs, tmp);
-		    }
-		  gfc_conv_descriptor_offset_set (&block, desc, offs);
-		}
-	      /* Set the bounds as declared for the LHS and calculate strides as
-		 well as another offset update accordingly.  */
-	      stride = gfc_conv_descriptor_stride_get (rse.expr,
-						       gfc_rank_cst[0]);
-	      for (dim = 0; dim < expr1->rank; ++dim)
-		{
-		  gfc_se lower_se;
-		  gfc_se upper_se;
-
-		  gcc_assert (remap->u.ar.start[dim] && remap->u.ar.end[dim]);
-
-		  if (remap->u.ar.start[dim]->expr_type != EXPR_CONSTANT
-		      || remap->u.ar.start[dim]->expr_type != EXPR_VARIABLE)
-		    gfc_resolve_expr (remap->u.ar.start[dim]);
-		  if (remap->u.ar.end[dim]->expr_type != EXPR_CONSTANT
-		      || remap->u.ar.end[dim]->expr_type != EXPR_VARIABLE)
-		    gfc_resolve_expr (remap->u.ar.end[dim]);
-
-		  /* Convert declared bounds.  */
-		  gfc_init_se (&lower_se, NULL);
-		  gfc_init_se (&upper_se, NULL);
-		  gfc_conv_expr (&lower_se, remap->u.ar.start[dim]);
-		  gfc_conv_expr (&upper_se, remap->u.ar.end[dim]);
-
-		  gfc_add_block_to_block (&block, &lower_se.pre);
-		  gfc_add_block_to_block (&block, &upper_se.pre);
-
-		  lbound = fold_convert (gfc_array_index_type, lower_se.expr);
-		  ubound = fold_convert (gfc_array_index_type, upper_se.expr);
-
-		  lbound = gfc_evaluate_now (lbound, &block);
-		  ubound = gfc_evaluate_now (ubound, &block);
-
-		  gfc_add_block_to_block (&block, &lower_se.post);
-		  gfc_add_block_to_block (&block, &upper_se.post);
-
-		  /* Set bounds in descriptor.  */
-		  gfc_conv_descriptor_lbound_set (&block, desc,
-						  gfc_rank_cst[dim], lbound);
-		  gfc_conv_descriptor_ubound_set (&block, desc,
-						  gfc_rank_cst[dim], ubound);
-
-		  /* Set stride.  */
-		  stride = gfc_evaluate_now (stride, &block);
-		  gfc_conv_descriptor_stride_set (&block, desc,
-						  gfc_rank_cst[dim], stride);
-
-		  /* Update offset.  */
-		  offs = gfc_conv_descriptor_offset_get (desc);
-		  tmp = fold_build2_loc (input_location, MULT_EXPR,
-					 gfc_array_index_type, lbound, stride);
-		  offs = fold_build2_loc (input_location, MINUS_EXPR,
-					  gfc_array_index_type, offs, tmp);
-		  offs = gfc_evaluate_now (offs, &block);
-		  gfc_conv_descriptor_offset_set (&block, desc, offs);
-
-		  /* Update stride.  */
-		  tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
-		  stride = fold_build2_loc (input_location, MULT_EXPR,
-					    gfc_array_index_type, stride, tmp);
-		}
+	      gfc_conv_remap_descriptor (&block, desc, expr1->rank, rse.expr,
+					 expr2, &remap->u.ar,
+					 UNLIMITED_POLY (expr1));
 	    }
 	  else
 	    /* Bounds remapping.  Just shift the lower bounds.  */
-	    gfc_conv_shift_descriptor (&block, desc, remap->u.ar);
+	    gfc_conv_shift_descriptor (&block, desc, remap->u.ar, expr2,
+				       UNLIMITED_POLY (expr1));
 	}
 
       /* If rank remapping was done, check with -fcheck=bounds that
lmpx.com only provides a reader for public news (NNTP) servers. It is not affiliated with the servers or forums shown here and is not responsible for the content of articles, which is written by their respective authors.