Fortran: Fix assumed-size to assumed-rank passing [PR94070]

This code inlines the size0 and size1 libgfortran calls, the former is still
used by libgfortan itself (and by old code). Besides permitting more
optimizations, it also permits to handle assumed-rank dummies better: If the
dummy argument is a nonpointer/nonallocatable, an assumed-size actual arg is
repesented by having ubound == -1 for the last dimension. However, for
allocatable/pointers, this value can also exist. Hence, the dummy arg attr
has to be honored.

For that reason, when calling an assumed-rank procedure with nonpointer,
nonallocatable dummy arguments, the bounds have to be updated to avoid
the case ubound == -1 for the last dimension.

	PR fortran/94070

gcc/fortran/ChangeLog:

	* trans-array.c (gfc_tree_array_size): New function to
	find size inline (whole array or one dimension).
	(array_parameter_size): Use it, take stmt_block as arg.
	(gfc_conv_array_parameter): Update call.
	* trans-array.h (gfc_tree_array_size): Add prototype.
	* trans-decl.c (gfor_fndecl_size0, gfor_fndecl_size1): Remove
	these global vars.
	(gfc_build_intrinsic_function_decls): Remove their initialization.
	* trans-expr.c (gfc_conv_procedure_call): Update
	bounds of pointer/allocatable actual args to nonallocatable/nonpointer
	dummies to be one based.
	* trans-intrinsic.c (gfc_conv_intrinsic_shape): Fix case for
	assumed rank with allocatable/pointer dummy.
	(gfc_conv_intrinsic_size): Update to use inline function.
	* trans.h (gfor_fndecl_size0, gfor_fndecl_size1): Remove var decl.

libgfortran/ChangeLog:

	* intrinsics/size.c (size0, size1): Comment that now not
	used by newer compiler code.

libgomp/ChangeLog:

	* testsuite/libgomp.oacc-fortran/privatized-ref-2.f90: Update
	expected dg-note output.

gcc/testsuite/ChangeLog:

	* gfortran.dg/c-interop/cf-out-descriptor-6.f90: Remove xfail.
	* gfortran.dg/c-interop/size.f90: Remove xfail.
	* gfortran.dg/intrinsic_size_3.f90: Update scan-tree-dump-times.
	* gfortran.dg/transpose_optimization_2.f90: Likewise.
	* gfortran.dg/size_optional_dim_1.f90: Add scan-tree-dump-not.
	* gfortran.dg/assumed_rank_22.f90: New test.
	* gfortran.dg/assumed_rank_22_aux.c: New test.

1 files changed, 139 insertions, 26 deletions

diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 0d013de..b8061f3 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -7901,31 +7901,143 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
   gfc_cleanup_loop (&loop);
 }
 
+
+/* Calculate the array size (number of elements); if dim != NULL_TREE,
+   return size for that dim (dim=0..rank-1; only for GFC_DESCRIPTOR_TYPE_P).  */
+tree
+gfc_tree_array_size (stmtblock_t *block, tree desc, gfc_expr *expr, tree dim)
+{
+  if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
+    {
+      gcc_assert (dim == NULL_TREE);
+      return GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc));
+    }
+  tree size, tmp, rank = NULL_TREE, cond = NULL_TREE;
+  symbol_attribute attr = gfc_expr_attr (expr);
+  gfc_array_spec *as = gfc_get_full_arrayspec_from_expr (expr);
+  gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)));
+  if ((!attr.pointer && !attr.allocatable && as && as->type == AS_ASSUMED_RANK)
+       || !dim)
+    {
+      if (expr->rank < 0)
+	rank = fold_convert (signed_char_type_node,
+			     gfc_conv_descriptor_rank (desc));
+      else
+	rank = build_int_cst (signed_char_type_node, expr->rank);
+    }
+
+  if (dim || expr->rank == 1)
+    {
+      if (!dim)
+	dim = gfc_index_zero_node;
+      tree ubound = gfc_conv_descriptor_ubound_get (desc, dim);
+      tree lbound = gfc_conv_descriptor_lbound_get (desc, dim);
+
+      size = fold_build2_loc (input_location, MINUS_EXPR,
+			      gfc_array_index_type, ubound, lbound);
+      size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+			      size, gfc_index_one_node);
+      /* if (!allocatable && !pointer && assumed rank)
+	   size = (idx == rank && ubound[rank-1] == -1 ? -1 : size;
+	 else
+	   size = max (0, size);  */
+      size = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
+			      size, gfc_index_zero_node);
+      if (!attr.pointer && !attr.allocatable
+	  && as && as->type == AS_ASSUMED_RANK)
+	{
+	  tmp = fold_build2_loc (input_location, MINUS_EXPR, signed_char_type_node,
+				 rank, build_int_cst (signed_char_type_node, 1));
+	  cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+				  fold_convert (signed_char_type_node, dim),
+				  tmp);
+	  tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+				 gfc_conv_descriptor_ubound_get (desc, dim),
+				 build_int_cst (gfc_array_index_type, -1));
+	  cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, boolean_type_node,
+				  cond, tmp);
+	  tmp = build_int_cst (gfc_array_index_type, -1);
+	  size = build3_loc (input_location, COND_EXPR, gfc_array_index_type,
+			     cond, tmp, size);
+	}
+      return size;
+    }
+
+  /* size = 1. */
+  size = gfc_create_var (gfc_array_index_type, "size");
+  gfc_add_modify (block, size, build_int_cst (TREE_TYPE (size), 1));
+  tree extent = gfc_create_var (gfc_array_index_type, "extent");
+
+  stmtblock_t cond_block, loop_body;
+  gfc_init_block (&cond_block);
+  gfc_init_block (&loop_body);
+
+  /* Loop: for (i = 0; i < rank; ++i).  */
+  tree idx = gfc_create_var (signed_char_type_node, "idx");
+  /* Loop body.  */
+  /* #if (assumed-rank + !allocatable && !pointer)
+       if (idx == rank - 1 && dim[idx].ubound == -1)
+	 extent = -1;
+       else
+     #endif
+	 extent = gfc->dim[i].ubound - gfc->dim[i].lbound + 1
+	 if (extent < 0)
+	   extent = 0
+      size *= extent.  */
+  cond = NULL_TREE;
+  if (!attr.pointer && !attr.allocatable && as && as->type == AS_ASSUMED_RANK)
+    {
+      tmp = fold_build2_loc (input_location, MINUS_EXPR, signed_char_type_node,
+			     rank, build_int_cst (signed_char_type_node, 1));
+      cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+				  idx, tmp);
+      tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+			     gfc_conv_descriptor_ubound_get (desc, idx),
+			     build_int_cst (gfc_array_index_type, -1));
+      cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, boolean_type_node,
+			      cond, tmp);
+    }
+  tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+			 gfc_conv_descriptor_ubound_get (desc, idx),
+			 gfc_conv_descriptor_lbound_get (desc, idx));
+  tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+			 tmp, gfc_index_one_node);
+  gfc_add_modify (&cond_block, extent, tmp);
+  tmp = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
+			 extent, gfc_index_zero_node);
+  tmp = build3_v (COND_EXPR, tmp,
+		  fold_build2_loc (input_location, MODIFY_EXPR,
+				   gfc_array_index_type,
+				   extent, gfc_index_zero_node),
+		  build_empty_stmt (input_location));
+  gfc_add_expr_to_block (&cond_block, tmp);
+  tmp = gfc_finish_block (&cond_block);
+  if (cond)
+    tmp = build3_v (COND_EXPR, cond,
+		    fold_build2_loc (input_location, MODIFY_EXPR,
+				     gfc_array_index_type, extent,
+				     build_int_cst (gfc_array_index_type, -1)),
+		    tmp);
+   gfc_add_expr_to_block (&loop_body, tmp);
+   /* size *= extent.  */
+   gfc_add_modify (&loop_body, size,
+		   fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+				    size, extent));
+  /* Generate loop. */
+  gfc_simple_for_loop (block, idx, build_int_cst (TREE_TYPE (idx), 0), rank, LT_EXPR,
+		       build_int_cst (TREE_TYPE (idx), 1),
+		       gfc_finish_block (&loop_body));
+  return size;
+}
+
 /* Helper function for gfc_conv_array_parameter if array size needs to be
    computed.  */
 
 static void
-array_parameter_size (tree desc, gfc_expr *expr, tree *size)
+array_parameter_size (stmtblock_t *block, tree desc, gfc_expr *expr, tree *size)
 {
   tree elem;
-  if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
-    *size = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc));
-  else if (expr->rank > 1)
-    *size = build_call_expr_loc (input_location,
-			     gfor_fndecl_size0, 1,
-			     gfc_build_addr_expr (NULL, desc));
-  else
-    {
-      tree ubound = gfc_conv_descriptor_ubound_get (desc, gfc_index_zero_node);
-      tree lbound = gfc_conv_descriptor_lbound_get (desc, gfc_index_zero_node);
-
-      *size = fold_build2_loc (input_location, MINUS_EXPR,
-			       gfc_array_index_type, ubound, lbound);
-      *size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
-			       *size, gfc_index_one_node);
-      *size = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
-			       *size, gfc_index_zero_node);
-    }
+  *size = gfc_tree_array_size (block, desc, expr, NULL);
   elem = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
   *size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
 			   *size, fold_convert (gfc_array_index_type, elem));
@@ -8035,7 +8147,7 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77,
           else
 	    se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
 	  if (size)
-	    array_parameter_size (tmp, expr, size);
+	    array_parameter_size (&se->pre, tmp, expr, size);
 	  return;
         }
 
@@ -8047,7 +8159,7 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77,
 	      tmp = se->expr;
 	    }
 	  if (size)
-	    array_parameter_size (tmp, expr, size);
+	    array_parameter_size (&se->pre, tmp, expr, size);
 	  se->expr = gfc_conv_array_data (tmp);
           return;
         }
@@ -8122,7 +8234,7 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77,
       if (expr->ts.type == BT_CHARACTER && expr->expr_type != EXPR_FUNCTION)
 	se->string_length = expr->ts.u.cl->backend_decl;
       if (size)
-	array_parameter_size (se->expr, expr, size);
+	array_parameter_size (&se->pre, se->expr, expr, size);
       se->expr = gfc_conv_array_data (se->expr);
       return;
     }
@@ -8132,7 +8244,7 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77,
       /* Result of the enclosing function.  */
       gfc_conv_expr_descriptor (se, expr);
       if (size)
-	array_parameter_size (se->expr, expr, size);
+	array_parameter_size (&se->pre, se->expr, expr, size);
       se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
 
       if (g77 && TREE_TYPE (TREE_TYPE (se->expr)) != NULL_TREE
@@ -8149,9 +8261,10 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77,
       gfc_conv_expr_descriptor (se, expr);
 
       if (size)
-	array_parameter_size (build_fold_indirect_ref_loc (input_location,
-						       se->expr),
-				  expr, size);
+	array_parameter_size (&se->pre,
+			      build_fold_indirect_ref_loc (input_location,
+							    se->expr),
+			      expr, size);
     }
 
   /* Deallocate the allocatable components of structures that are