From e187285dfd83da2f69cfd50854c701744dc8acc5 Mon Sep 17 00:00:00 2001
From: Harald Anlauf <anlauf@gmx.de>
Date: Mon, 13 May 2024 22:06:33 +0200
Subject: [PATCH] Fortran: fix bounds check for assignment, class component
 [PR86100]

gcc/fortran/ChangeLog:

	PR fortran/86100
	* trans-array.cc (gfc_conv_ss_startstride): Use abridged_ref_name
	to generate a more user-friendly name for bounds-check messages.
	* trans-expr.cc (gfc_copy_class_to_class): Fix bounds check for
	rank>1 by looping over the dimensions.

gcc/testsuite/ChangeLog:

	PR fortran/86100
	* gfortran.dg/bounds_check_25.f90: New test.
---
 gcc/fortran/trans-array.cc                    |  7 +++-
 gcc/fortran/trans-expr.cc                     | 40 ++++++++++---------
 gcc/testsuite/gfortran.dg/bounds_check_25.f90 | 32 +++++++++++++++
 3 files changed, 60 insertions(+), 19 deletions(-)
 create mode 100644 gcc/testsuite/gfortran.dg/bounds_check_25.f90

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index c5b56f4e273..eec62c296ff 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -4911,6 +4911,7 @@ done:
 	  gfc_expr *expr;
 	  locus *expr_loc;
 	  const char *expr_name;
+	  char *ref_name = NULL;

 	  ss_info = ss->info;
 	  if (ss_info->type != GFC_SS_SECTION)
@@ -4922,7 +4923,10 @@ done:

 	  expr = ss_info->expr;
 	  expr_loc = &expr->where;
-	  expr_name = expr->symtree->name;
+	  if (expr->ref)
+	    expr_name = ref_name = abridged_ref_name (expr, NULL);
+	  else
+	    expr_name = expr->symtree->name;

 	  gfc_start_block (&inner);

@@ -5134,6 +5138,7 @@ done:

 	  gfc_add_expr_to_block (&block, tmp);

+	  free (ref_name);
 	}

       tmp = gfc_finish_block (&block);
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index e315e2d3370..dfc5b8e9b4a 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -1520,7 +1520,6 @@ gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited)
       stmtblock_t body;
       stmtblock_t ifbody;
       gfc_loopinfo loop;
-      tree orig_nelems = nelems; /* Needed for bounds check.  */

       gfc_init_block (&body);
       tmp = fold_build2_loc (input_location, MINUS_EXPR,
@@ -1552,27 +1551,32 @@ gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited)
       /* Add bounds check.  */
       if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) > 0 && is_from_desc)
 	{
-	  char *msg;
 	  const char *name = "<<unknown>>";
-	  tree from_len;
+	  int dim, rank;

 	  if (DECL_P (to))
-	    name = (const char *)(DECL_NAME (to)->identifier.id.str);
-
-	  from_len = gfc_conv_descriptor_size (from_data, 1);
-	  from_len = fold_convert (TREE_TYPE (orig_nelems), from_len);
-	  tmp = fold_build2_loc (input_location, NE_EXPR,
-				  logical_type_node, from_len, orig_nelems);
-	  msg = xasprintf ("Array bound mismatch for dimension %d "
-			   "of array '%s' (%%ld/%%ld)",
-			   1, name);
-
-	  gfc_trans_runtime_check (true, false, tmp, &body,
-				   &gfc_current_locus, msg,
-			     fold_convert (long_integer_type_node, orig_nelems),
-			       fold_convert (long_integer_type_node, from_len));
+	    name = IDENTIFIER_POINTER (DECL_NAME (to));

-	  free (msg);
+	  rank = GFC_TYPE_ARRAY_RANK (TREE_TYPE (from_data));
+	  for (dim = 1; dim <= rank; dim++)
+	    {
+	      tree from_len, to_len, cond;
+	      char *msg;
+
+	      from_len = gfc_conv_descriptor_size (from_data, dim);
+	      from_len = fold_convert (long_integer_type_node, from_len);
+	      to_len = gfc_conv_descriptor_size (to_data, dim);
+	      to_len = fold_convert (long_integer_type_node, to_len);
+	      msg = xasprintf ("Array bound mismatch for dimension %d "
+			       "of array '%s' (%%ld/%%ld)",
+			       dim, name);
+	      cond = fold_build2_loc (input_location, NE_EXPR,
+				      logical_type_node, from_len, to_len);
+	      gfc_trans_runtime_check (true, false, cond, &body,
+				       &gfc_current_locus, msg,
+				       to_len, from_len);
+	      free (msg);
+	    }
 	}

       tmp = build_call_vec (fcn_type, fcn, args);
diff --git a/gcc/testsuite/gfortran.dg/bounds_check_25.f90 b/gcc/testsuite/gfortran.dg/bounds_check_25.f90
new file mode 100644
index 00000000000..cc2247597f9
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/bounds_check_25.f90
@@ -0,0 +1,32 @@
+! { dg-do run }
+! { dg-additional-options "-fcheck=bounds -fdump-tree-original" }
+!
+! PR fortran/86100 - bogus bounds check with assignment, class component
+
+program p
+  implicit none
+  type any_matrix
+     class(*), allocatable :: m(:,:)
+  end type any_matrix
+  type(any_matrix) :: a, b
+  allocate (a%m, source=reshape([3,5],shape=[1,2]))
+
+  ! The following assignment did create a bogus bounds violation:
+  b = a ! Line 15
+  if (any (shape (b%m) /= shape (a%m))) stop 1
+
+contains
+
+  ! Verify improved array name in array name
+  subroutine bla ()
+    type(any_matrix) :: c, d
+    allocate (real :: c%m(3,5))
+    allocate (d%m(7,9),source=c%m) ! Line 24
+  end subroutine bla
+end
+
+! { dg-final { scan-tree-dump-times "line 15 .* bound mismatch for dimension 1 of array .'.*.'" 1 "original" } }
+! { dg-final { scan-tree-dump-times "line 15 .* bound mismatch for dimension 2 of array .'.*.'" 1 "original" } }
+
+! { dg-final { scan-tree-dump-times "line 24 .* bound mismatch for dimension 1 of array .'d%%m.'" 1 "original" } }
+! { dg-final { scan-tree-dump-times "line 24 .* bound mismatch for dimension 2 of array .'d%%m.'" 1 "original" } }
--
2.35.3