From 30d7cef086d440262b206bc39bcbcac89491b792 Mon Sep 17 00:00:00 2001 From: Harald Anlauf 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