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
@@ -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);
}
@@ -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" }
new file mode 100644
@@ -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