[PATCH, v3] Fortran: improve array component description in runtime error message [PR30802]

[Harald Anlauf <anlauf@gmx.de>]

[-- Attachment #1: Type: text/plain, Size: 1338 bytes --]

Hi Mikael, all,

here's now the third version of the patch that implements the following
scheme:

On 3/15/24 20:29, Mikael Morin wrote:
> Le 15/03/2024 à 18:26, Harald Anlauf a écrit :
>> OK, that sounds interesting.  To clarify the options:
>>
>> - for ordinary array x it would stay 'x'
>>
>> - when z is a DT scalar, and z%x is the array in question, use 'z%x'
>>    (here z...%x would look strange to me)
>>
> Yes, the ellipsis would look strange to me as well.
>
>> - when z is a DT array, and x some component further down, 'z...%x'
>>
> This case also applies when z is a DT scalar and x is more than one
> level deep.
>
>> I would rather not make the error message text vary too much to avoid
>> to run into issues with translation.  Would it be fine with you to have
>>
>> ... dimension 1 of array 'z...%x' above array bound ...
>>
>> only?
>>
> OK, let's drop "component".
>
>> Anything else?
>>
> No, I think you covered everything.

I've created a new helper function that centralizes the generation of
the abbreviated name of the array (component) and use it to simplify
related code in multiple places.  If we change our mind how a bounds
violation error message should look like, it will be easier to adjust
in the future.

Is this OK for 14-mainline?

Thanks,
Harald



[-- Attachment #2: pr30802-part2-v3.diff --]
[-- Type: text/x-patch, Size: 10797 bytes --]

From 30d7cef086d440262b206bc39bcbcac89491b792 Mon Sep 17 00:00:00 2001
From: Harald Anlauf <anlauf@gmx.de>
Date: Wed, 20 Mar 2024 20:59:24 +0100
Subject: [PATCH] Fortran: improve array component description in runtime error
 message [PR30802]

Runtime error messages for array bounds violation shall use the following
scheme for a coherent, abridged description of arrays or array components
of derived types:
(1) If x is an ordinary array variable, use "x"
(2) if z is a DT scalar and x an array component at level 1, use "z%x"
(3) if z is a DT scalar and x an array component at level > 1, or
    if z is a DT array and x an array (at any level), use "z...%x"
Use a new helper function abridged_ref_name for construction of that name.

gcc/fortran/ChangeLog:

	PR fortran/30802
	* trans-array.cc (abridged_ref_name): New helper function.
	(trans_array_bound_check): Use it.
	(array_bound_check_elemental): Likewise.
	(gfc_conv_array_ref): Likewise.

gcc/testsuite/ChangeLog:

	PR fortran/30802
	* gfortran.dg/bounds_check_17.f90: Adjust pattern.
	* gfortran.dg/bounds_check_fail_8.f90: New test.
---
 gcc/fortran/trans-array.cc                    | 132 +++++++++++-------
 gcc/testsuite/gfortran.dg/bounds_check_17.f90 |   2 +-
 .../gfortran.dg/bounds_check_fail_8.f90       |  56 ++++++++
 3 files changed, 142 insertions(+), 48 deletions(-)
 create mode 100644 gcc/testsuite/gfortran.dg/bounds_check_fail_8.f90

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 0a453828bad..30b84762346 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -3485,6 +3485,78 @@ gfc_conv_array_ubound (tree descriptor, int dim)
 }
 
 
+/* Generate abridged name of a part-ref for use in bounds-check message.
+   Cases:
+   (1) for an ordinary array variable x return "x"
+   (2) for z a DT scalar and array component x (at level 1) return "z%%x"
+   (3) for z a DT scalar and array component x (at level > 1) or
+       for z a DT array and array x (at any number of levels): "z...%%x"
+ */
+
+static char *
+abridged_ref_name (gfc_expr * expr, gfc_array_ref * ar)
+{
+  gfc_ref *ref;
+  gfc_symbol *sym;
+  char *ref_name = NULL;
+  const char *comp_name = NULL;
+  int len_sym, last_len = 0, level = 0;
+  bool sym_is_array;
+
+  gcc_assert (expr->expr_type == EXPR_VARIABLE && expr->ref != NULL);
+
+  sym = expr->symtree->n.sym;
+  sym_is_array = (sym->ts.type != BT_CLASS
+		  ? sym->as != NULL
+		  : IS_CLASS_ARRAY (sym));
+  len_sym = strlen (sym->name);
+
+  /* Scan ref chain to get name of the array component (when ar != NULL) or
+     array section, determine depth and remember its component name.  */
+  for (ref = expr->ref; ref; ref = ref->next)
+    {
+      if (ref->type == REF_COMPONENT
+	  && strcmp (ref->u.c.component->name, "_data") != 0)
+	{
+	  level++;
+	  comp_name = ref->u.c.component->name;
+	  continue;
+	}
+
+      if (ref->type != REF_ARRAY)
+	continue;
+
+      if (ar)
+	{
+	  if (&ref->u.ar == ar)
+	    break;
+	}
+      else if (ref->u.ar.type == AR_SECTION)
+	break;
+    }
+
+  if (level > 0)
+    last_len = strlen (comp_name);
+
+  /* Provide a buffer sufficiently large to hold "x...%%z".  */
+  ref_name = XNEWVEC (char, len_sym + last_len + 6);
+  strcpy (ref_name, sym->name);
+
+  if (level == 1 && !sym_is_array)
+    {
+      strcat (ref_name, "%%");
+      strcat (ref_name, comp_name);
+    }
+  else if (level > 0)
+    {
+      strcat (ref_name, "...%%");
+      strcat (ref_name, comp_name);
+    }
+
+  return ref_name;
+}
+
+
 /* Generate code to perform an array index bound check.  */
 
 static tree
@@ -3496,7 +3568,9 @@ trans_array_bound_check (gfc_se * se, gfc_ss *ss, tree index, int n,
   tree tmp_lo, tmp_up;
   tree descriptor;
   char *msg;
+  char *ref_name = NULL;
   const char * name = NULL;
+  gfc_expr *expr;
 
   if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
     return index;
@@ -3509,6 +3583,12 @@ trans_array_bound_check (gfc_se * se, gfc_ss *ss, tree index, int n,
   name = ss->info->expr->symtree->n.sym->name;
   gcc_assert (name != NULL);
 
+  /* When we have a component ref, get name of the array section.
+     Note that there can only be one part ref.  */
+  expr = ss->info->expr;
+  if (expr->ref && !compname)
+    name = ref_name = abridged_ref_name (expr, NULL);
+
   if (VAR_P (descriptor))
     name = IDENTIFIER_POINTER (DECL_NAME (descriptor));
 
@@ -3562,6 +3642,7 @@ trans_array_bound_check (gfc_se * se, gfc_ss *ss, tree index, int n,
       free (msg);
     }
 
+  free (ref_name);
   return index;
 }
 
@@ -3573,36 +3654,17 @@ array_bound_check_elemental (gfc_se * se, gfc_ss * ss, gfc_expr * expr)
 {
   gfc_array_ref *ar;
   gfc_ref *ref;
-  gfc_symbol *sym;
   char *var_name = NULL;
-  size_t len;
   int dim;
 
   if (expr->expr_type == EXPR_VARIABLE)
     {
-      sym = expr->symtree->n.sym;
-      len = strlen (sym->name) + 1;
-
-      for (ref = expr->ref; ref; ref = ref->next)
-	if (ref->type == REF_COMPONENT)
-	  len += 2 + strlen (ref->u.c.component->name);
-
-      var_name = XALLOCAVEC (char, len);
-      strcpy (var_name, sym->name);
-
       for (ref = expr->ref; ref; ref = ref->next)
 	{
-	  /* Append component name.  */
-	  if (ref->type == REF_COMPONENT)
-	    {
-	      strcat (var_name, "%%");
-	      strcat (var_name, ref->u.c.component->name);
-	      continue;
-	    }
-
 	  if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
 	    {
 	      ar = &ref->u.ar;
+	      var_name = abridged_ref_name (expr, ar);
 	      for (dim = 0; dim < ar->dimen; dim++)
 		{
 		  if (ar->dimen_type[dim] == DIMEN_ELEMENT)
@@ -3618,6 +3680,7 @@ array_bound_check_elemental (gfc_se * se, gfc_ss * ss, gfc_expr * expr)
 					       var_name);
 		    }
 		}
+	      free (var_name);
 	    }
 	}
     }
@@ -4034,33 +4097,7 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr,
     }
 
   if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
-    {
-      size_t len;
-      gfc_ref *ref;
-
-      len = strlen (sym->name) + 1;
-      for (ref = expr->ref; ref; ref = ref->next)
-	{
-	  if (ref->type == REF_ARRAY && &ref->u.ar == ar)
-	    break;
-	  if (ref->type == REF_COMPONENT)
-	    len += 2 + strlen (ref->u.c.component->name);
-	}
-
-      var_name = XALLOCAVEC (char, len);
-      strcpy (var_name, sym->name);
-
-      for (ref = expr->ref; ref; ref = ref->next)
-	{
-	  if (ref->type == REF_ARRAY && &ref->u.ar == ar)
-	    break;
-	  if (ref->type == REF_COMPONENT)
-	    {
-	      strcat (var_name, "%%");
-	      strcat (var_name, ref->u.c.component->name);
-	    }
-	}
-    }
+    var_name = abridged_ref_name (expr, ar);
 
   decl = se->expr;
   if (UNLIMITED_POLY(sym)
@@ -4195,6 +4232,7 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr,
 	decl = NULL_TREE;
     }
 
+  free (var_name);
   se->expr = build_array_ref (se->expr, offset, decl, se->class_vptr);
 }
 
diff --git a/gcc/testsuite/gfortran.dg/bounds_check_17.f90 b/gcc/testsuite/gfortran.dg/bounds_check_17.f90
index 50d66c75a80..e970727d7d9 100644
--- a/gcc/testsuite/gfortran.dg/bounds_check_17.f90
+++ b/gcc/testsuite/gfortran.dg/bounds_check_17.f90
@@ -23,4 +23,4 @@ z(i)%y(j)%x(k)=0
 
 END
 
-! { dg-output "At line 22 of file .*bounds_check_17.f90.*Fortran runtime error: Index '11' of dimension 1 of array 'z%y%x' above upper bound of 10" }
+! { dg-output "At line 22 of file .*bounds_check_17.f90.*Fortran runtime error: Index '11' of dimension 1 of array 'z\.\.\.%x' above upper bound of 10" }
diff --git a/gcc/testsuite/gfortran.dg/bounds_check_fail_8.f90 b/gcc/testsuite/gfortran.dg/bounds_check_fail_8.f90
new file mode 100644
index 00000000000..7ee659f0c7e
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/bounds_check_fail_8.f90
@@ -0,0 +1,56 @@
+! { dg-do compile }
+! { dg-additional-options "-fcheck=bounds -g -fdump-tree-original" }
+!
+! PR fortran/30802 - improve bounds-checking for array references
+!
+! Use proper array component references in runtime error message.
+
+program test
+  implicit none
+  integer :: k = 0
+  type t
+     real, dimension(10,20,30) :: z = 23
+  end type t
+  type u
+     type(t) :: vv(4,5)
+     complex :: cc(6,7)
+  end type u
+  type vec
+     integer :: xx(3) = [2,4,6]
+  end type vec
+  type(t) :: uu,     ww(1)
+  type(u) :: x1, x2, y1(1), y2(1)
+
+  print *, uu   % z(1,k,:)           ! runtime check for dimension 2 of uu%z
+  print *, ww(1)% z(1,:,k)           ! runtime check for dimension 3 of ww...%z
+  print *, x1   % vv(2,3)% z(1,:,k)  ! runtime check for dimension 3 of x1...%z
+  print *, x2   % vv(k,:)% z(1,2,3)  ! runtime check for dimension 1 of x2%vv
+  print *, y1(k)% vv(2,3)% z(k,:,1)  ! runtime check for dimension 1 of y1
+                                     !           and for dimension 1 of y1...%z
+  print *, y2(1)% vv(:,k)% z(1,2,k)  ! runtime check for dimension 2 of y2...%vv
+                                     !           and for dimension 3 of y2...%z
+  print *, y1(1)% cc(k,:)% re        ! runtime check for dimension 1 of y1...%cc
+contains
+  subroutine sub (yy, k)
+    class(vec), intent(in) :: yy(:)
+    integer,    intent(in) :: k
+    print *, yy(1)%xx(k)             ! runtime checks for yy and yy...%xx
+  end
+end program test
+
+! { dg-final { scan-tree-dump-times "dimension 2 of array .'uu%%z.' outside of expected range" 2 "original" } }
+! { dg-final { scan-tree-dump-times "dimension 3 of array .'ww\.\.\.%%z.' outside of expected range" 2 "original" } }
+! { dg-final { scan-tree-dump-times "dimension 3 of array .'x1\.\.\.%%z.' outside of expected range" 2 "original" } }
+! { dg-final { scan-tree-dump-times "dimension 1 of array .'x2%%vv.' outside of expected range" 2 "original" } }
+! { dg-final { scan-tree-dump-times "dimension 1 of array .'y1\.\.\.%%z.' outside of expected range" 2 "original" } }
+! { dg-final { scan-tree-dump-times "dimension 2 of array .'y2\.\.\.%%vv.' outside of expected range" 2 "original" } }
+! { dg-final { scan-tree-dump-times "dimension 1 of array .'y1\.\.\.%%cc.' outside of expected range" 2 "original" } }
+
+! { dg-final { scan-tree-dump-times "dimension 1 of array .'y1.' above upper bound" 1 "original" } }
+! { dg-final { scan-tree-dump-times "dimension 1 of array .'y1.' below lower bound" 1 "original" } }
+! { dg-final { scan-tree-dump-times "dimension 3 of array .'y2\.\.\.%%z.' above upper bound" 1 "original" } }
+! { dg-final { scan-tree-dump-times "dimension 3 of array .'y2\.\.\.%%z.' below lower bound" 1 "original" } }
+
+! { dg-final { scan-tree-dump-times "dimension 1 of array .'yy.' above upper bound" 1 "original" } }
+! { dg-final { scan-tree-dump-times "dimension 1 of array .'yy\.\.\.%%xx.' above upper bound" 1 "original" } }
+! { dg-final { scan-tree-dump-times "dimension 1 of array .'yy\.\.\.%%xx.' below lower bound" 1 "original" } }
-- 
2.35.3