diff mbox series

[v2,05/10] fortran: Outline array bound check generation code

Message ID 20240816102227.189290-6-morin-mikael@orange.fr
State New
Headers show
Series fortran: Inline MINLOC/MAXLOC without DIM argument [PR90608] | expand

Commit Message

Mikael Morin Aug. 16, 2024, 10:22 a.m. UTC
From: Mikael Morin <mikael@gcc.gnu.org>

The next patch will need reindenting of the array bound check generation
code.  This outlines it to its own function beforehand, reducing the churn
in the next patch.

Regression-tested on x86_64-pc-linux-gnu.
OK for master?

-- >8 --

gcc/fortran/ChangeLog:

	* trans-array.cc (gfc_conv_ss_startstride): Move array bound check
	generation code...
	(add_check_section_in_array_bounds): ... here as a new function.
---
 gcc/fortran/trans-array.cc | 297 ++++++++++++++++++-------------------
 1 file changed, 143 insertions(+), 154 deletions(-)
diff mbox series

Patch

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 46e2152d0f0..e578b676fcc 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -4816,6 +4816,146 @@  gfc_conv_section_startstride (stmtblock_t * block, gfc_ss * ss, int dim)
 }
 
 
+/* Generate in INNER the bounds checking code along the dimension DIM for
+   the array associated with SS_INFO.  */
+
+static void
+add_check_section_in_array_bounds (stmtblock_t *inner, gfc_ss_info *ss_info,
+				   int dim)
+{
+  gfc_expr *expr = ss_info->expr;
+  locus *expr_loc = &expr->where;
+  const char *expr_name = expr->symtree->name;
+
+  gfc_array_info *info = &ss_info->data.array;
+
+  bool check_upper;
+  if (dim == info->ref->u.ar.dimen - 1
+      && info->ref->u.ar.as->type == AS_ASSUMED_SIZE)
+    check_upper = false;
+  else
+    check_upper = true;
+
+  /* Zero stride is not allowed.  */
+  tree tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
+			      info->stride[dim], gfc_index_zero_node);
+  char * msg = xasprintf ("Zero stride is not allowed, for dimension %d "
+			  "of array '%s'", dim + 1, expr_name);
+  gfc_trans_runtime_check (true, false, tmp, inner, expr_loc, msg);
+  free (msg);
+
+  tree desc = info->descriptor;
+
+  /* This is the run-time equivalent of resolve.cc's
+     check_dimension.  The logical is more readable there
+     than it is here, with all the trees.  */
+  tree lbound = gfc_conv_array_lbound (desc, dim);
+  tree end = info->end[dim];
+  tree ubound = check_upper ? gfc_conv_array_ubound (desc, dim) : NULL_TREE;
+
+  /* non_zerosized is true when the selected range is not
+     empty.  */
+  tree stride_pos = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
+				     info->stride[dim], gfc_index_zero_node);
+  tmp = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
+			 info->start[dim], end);
+  stride_pos = fold_build2_loc (input_location, TRUTH_AND_EXPR,
+				logical_type_node, stride_pos, tmp);
+
+  tree stride_neg = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
+				     info->stride[dim], gfc_index_zero_node);
+  tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
+			 info->start[dim], end);
+  stride_neg = fold_build2_loc (input_location, TRUTH_AND_EXPR,
+				logical_type_node, stride_neg, tmp);
+  tree non_zerosized = fold_build2_loc (input_location, TRUTH_OR_EXPR,
+					logical_type_node, stride_pos,
+					stride_neg);
+
+  /* Check the start of the range against the lower and upper
+     bounds of the array, if the range is not empty.
+     If upper bound is present, include both bounds in the
+     error message.  */
+  if (check_upper)
+    {
+      tmp = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
+			     info->start[dim], lbound);
+      tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node,
+			     non_zerosized, tmp);
+      tree tmp2 = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
+				   info->start[dim], ubound);
+      tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node,
+			      non_zerosized, tmp2);
+      msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' outside of "
+		       "expected range (%%ld:%%ld)", dim + 1, expr_name);
+      gfc_trans_runtime_check (true, false, tmp, inner, expr_loc, msg,
+	  fold_convert (long_integer_type_node, info->start[dim]),
+	  fold_convert (long_integer_type_node, lbound),
+	  fold_convert (long_integer_type_node, ubound));
+      gfc_trans_runtime_check (true, false, tmp2, inner, expr_loc, msg,
+	  fold_convert (long_integer_type_node, info->start[dim]),
+	  fold_convert (long_integer_type_node, lbound),
+	  fold_convert (long_integer_type_node, ubound));
+      free (msg);
+    }
+  else
+    {
+      tmp = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
+			     info->start[dim], lbound);
+      tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node,
+			     non_zerosized, tmp);
+      msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' below "
+		       "lower bound of %%ld", dim + 1, expr_name);
+      gfc_trans_runtime_check (true, false, tmp, inner, expr_loc, msg,
+	  fold_convert (long_integer_type_node, info->start[dim]),
+	  fold_convert (long_integer_type_node, lbound));
+      free (msg);
+    }
+
+  /* Compute the last element of the range, which is not
+     necessarily "end" (think 0:5:3, which doesn't contain 5)
+     and check it against both lower and upper bounds.  */
+
+  tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+			 end, info->start[dim]);
+  tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR, gfc_array_index_type,
+			 tmp, info->stride[dim]);
+  tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+			 end, tmp);
+  tree tmp2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
+			       tmp, lbound);
+  tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node,
+			  non_zerosized, tmp2);
+  if (check_upper)
+    {
+      tree tmp3 = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
+				   tmp, ubound);
+      tmp3 = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node,
+			      non_zerosized, tmp3);
+      msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' outside of "
+		       "expected range (%%ld:%%ld)", dim + 1, expr_name);
+      gfc_trans_runtime_check (true, false, tmp2, inner, expr_loc, msg,
+	  fold_convert (long_integer_type_node, tmp),
+	  fold_convert (long_integer_type_node, ubound),
+	  fold_convert (long_integer_type_node, lbound));
+      gfc_trans_runtime_check (true, false, tmp3, inner, expr_loc, msg,
+	  fold_convert (long_integer_type_node, tmp),
+	  fold_convert (long_integer_type_node, ubound),
+	  fold_convert (long_integer_type_node, lbound));
+      free (msg);
+    }
+  else
+    {
+      msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' below "
+		       "lower bound of %%ld", dim + 1, expr_name);
+      gfc_trans_runtime_check (true, false, tmp2, inner, expr_loc, msg,
+	  fold_convert (long_integer_type_node, tmp),
+	  fold_convert (long_integer_type_node, lbound));
+      free (msg);
+    }
+}
+
+
 /* Calculates the range start and stride for a SS chain.  Also gets the
    descriptor and data pointer.  The range of vector subscripts is the size
    of the vector.  Array bounds are also checked.  */
@@ -4826,7 +4966,6 @@  gfc_conv_ss_startstride (gfc_loopinfo * loop)
   int n;
   tree tmp;
   gfc_ss *ss;
-  tree desc;
 
   gfc_loopinfo * const outer_loop = outermost_loop (loop);
 
@@ -4996,10 +5135,8 @@  done:
   if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
     {
       stmtblock_t block;
-      tree lbound, ubound;
-      tree end;
       tree size[GFC_MAX_DIMENSIONS];
-      tree stride_pos, stride_neg, non_zerosized, tmp2, tmp3;
+      tree tmp3;
       gfc_array_info *info;
       char *msg;
       int dim;
@@ -5065,163 +5202,15 @@  done:
 	     dimensions are checked later.  */
 	  for (n = 0; n < loop->dimen; n++)
 	    {
-	      bool check_upper;
-
 	      dim = ss->dim[n];
 	      if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
 		continue;
 
-	      if (dim == info->ref->u.ar.dimen - 1
-		  && info->ref->u.ar.as->type == AS_ASSUMED_SIZE)
-		check_upper = false;
-	      else
-		check_upper = true;
-
-	      /* Zero stride is not allowed.  */
-	      tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
-				     info->stride[dim], gfc_index_zero_node);
-	      msg = xasprintf ("Zero stride is not allowed, for dimension %d "
-			       "of array '%s'", dim + 1, expr_name);
-	      gfc_trans_runtime_check (true, false, tmp, &inner,
-				       expr_loc, msg);
-	      free (msg);
-
-	      desc = info->descriptor;
-
-	      /* This is the run-time equivalent of resolve.cc's
-		 check_dimension().  The logical is more readable there
-		 than it is here, with all the trees.  */
-	      lbound = gfc_conv_array_lbound (desc, dim);
-	      end = info->end[dim];
-	      if (check_upper)
-		ubound = gfc_conv_array_ubound (desc, dim);
-	      else
-		ubound = NULL;
-
-	      /* non_zerosized is true when the selected range is not
-		 empty.  */
-	      stride_pos = fold_build2_loc (input_location, GT_EXPR,
-					logical_type_node, info->stride[dim],
-					gfc_index_zero_node);
-	      tmp = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
-				     info->start[dim], end);
-	      stride_pos = fold_build2_loc (input_location, TRUTH_AND_EXPR,
-					    logical_type_node, stride_pos, tmp);
-
-	      stride_neg = fold_build2_loc (input_location, LT_EXPR,
-				     logical_type_node,
-				     info->stride[dim], gfc_index_zero_node);
-	      tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
-				     info->start[dim], end);
-	      stride_neg = fold_build2_loc (input_location, TRUTH_AND_EXPR,
-					    logical_type_node,
-					    stride_neg, tmp);
-	      non_zerosized = fold_build2_loc (input_location, TRUTH_OR_EXPR,
-					       logical_type_node,
-					       stride_pos, stride_neg);
-
-	      /* Check the start of the range against the lower and upper
-		 bounds of the array, if the range is not empty.
-	         If upper bound is present, include both bounds in the
-		 error message.  */
-	      if (check_upper)
-		{
-		  tmp = fold_build2_loc (input_location, LT_EXPR,
-					 logical_type_node,
-					 info->start[dim], lbound);
-		  tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
-					 logical_type_node,
-					 non_zerosized, tmp);
-		  tmp2 = fold_build2_loc (input_location, GT_EXPR,
-					  logical_type_node,
-					  info->start[dim], ubound);
-		  tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
-					  logical_type_node,
-					  non_zerosized, tmp2);
-		  msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
-				   "outside of expected range (%%ld:%%ld)",
-				   dim + 1, expr_name);
-		  gfc_trans_runtime_check (true, false, tmp, &inner,
-					   expr_loc, msg,
-		     fold_convert (long_integer_type_node, info->start[dim]),
-		     fold_convert (long_integer_type_node, lbound),
-		     fold_convert (long_integer_type_node, ubound));
-		  gfc_trans_runtime_check (true, false, tmp2, &inner,
-					   expr_loc, msg,
-		     fold_convert (long_integer_type_node, info->start[dim]),
-		     fold_convert (long_integer_type_node, lbound),
-		     fold_convert (long_integer_type_node, ubound));
-		  free (msg);
-		}
-	      else
-		{
-		  tmp = fold_build2_loc (input_location, LT_EXPR,
-					 logical_type_node,
-					 info->start[dim], lbound);
-		  tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
-					 logical_type_node, non_zerosized, tmp);
-		  msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
-				   "below lower bound of %%ld",
-				   dim + 1, expr_name);
-		  gfc_trans_runtime_check (true, false, tmp, &inner,
-					   expr_loc, msg,
-		     fold_convert (long_integer_type_node, info->start[dim]),
-		     fold_convert (long_integer_type_node, lbound));
-		  free (msg);
-		}
-
-	      /* Compute the last element of the range, which is not
-		 necessarily "end" (think 0:5:3, which doesn't contain 5)
-		 and check it against both lower and upper bounds.  */
-
-	      tmp = fold_build2_loc (input_location, MINUS_EXPR,
-				     gfc_array_index_type, end,
-				     info->start[dim]);
-	      tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR,
-				     gfc_array_index_type, tmp,
-				     info->stride[dim]);
-	      tmp = fold_build2_loc (input_location, MINUS_EXPR,
-				     gfc_array_index_type, end, tmp);
-	      tmp2 = fold_build2_loc (input_location, LT_EXPR,
-				      logical_type_node, tmp, lbound);
-	      tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
-				      logical_type_node, non_zerosized, tmp2);
-	      if (check_upper)
-		{
-		  tmp3 = fold_build2_loc (input_location, GT_EXPR,
-					  logical_type_node, tmp, ubound);
-		  tmp3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
-					  logical_type_node, non_zerosized, tmp3);
-		  msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
-				   "outside of expected range (%%ld:%%ld)",
-				   dim + 1, expr_name);
-		  gfc_trans_runtime_check (true, false, tmp2, &inner,
-					   expr_loc, msg,
-		     fold_convert (long_integer_type_node, tmp),
-		     fold_convert (long_integer_type_node, ubound),
-		     fold_convert (long_integer_type_node, lbound));
-		  gfc_trans_runtime_check (true, false, tmp3, &inner,
-					   expr_loc, msg,
-		     fold_convert (long_integer_type_node, tmp),
-		     fold_convert (long_integer_type_node, ubound),
-		     fold_convert (long_integer_type_node, lbound));
-		  free (msg);
-		}
-	      else
-		{
-		  msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
-				   "below lower bound of %%ld",
-				   dim + 1, expr_name);
-		  gfc_trans_runtime_check (true, false, tmp2, &inner,
-					   expr_loc, msg,
-		     fold_convert (long_integer_type_node, tmp),
-		     fold_convert (long_integer_type_node, lbound));
-		  free (msg);
-		}
+	      add_check_section_in_array_bounds (&inner, ss_info, dim);
 
 	      /* Check the section sizes match.  */
 	      tmp = fold_build2_loc (input_location, MINUS_EXPR,
-				     gfc_array_index_type, end,
+				     gfc_array_index_type, info->end[dim],
 				     info->start[dim]);
 	      tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR,
 				     gfc_array_index_type, tmp,