Fortran: improve checking of substring bounds [PR119118]

After the fix for pr98490 no substring bounds check was generated if the
substring start was not a variable.  While the purpose of that fix was to
suppress a premature check before implied-do indices were substituted, this
prevented a check if the substring start was an expression or a constant.
A better solution is to defer the check until implied-do indices have been
substituted in the start and end expressions.

	PR fortran/119118

gcc/fortran/ChangeLog:

	* dependency.cc (gfc_contains_implied_index_p): Helper function to
	determine if an expression has a dependence on an implied-do index.
	* dependency.h (gfc_contains_implied_index_p): Add prototype.
	* trans-expr.cc (gfc_conv_substring): Adjust logic to not generate
	substring bounds checks before implied-do indices have been
	substituted.

gcc/testsuite/ChangeLog:

	* gfortran.dg/bounds_check_23.f90: Generalize test.
	* gfortran.dg/bounds_check_26.f90: New test.

5 files changed, 125 insertions, 3 deletions

diff --git a/gcc/fortran/dependency.cc b/gcc/fortran/dependency.cc
index 6b3affa..8354b18 100644
--- a/gcc/fortran/dependency.cc
+++ b/gcc/fortran/dependency.cc
@@ -1888,6 +1888,87 @@ contains_forall_index_p (gfc_expr *expr)
   return false;
 }
 
+
+/* Traverse expr, checking all EXPR_VARIABLE symbols for their
+   implied_index attribute.  Return true if any variable may be
+   used as an implied-do index.  It is safe to pessimistically
+   return true, and assume a dependency.  */
+
+bool
+gfc_contains_implied_index_p (gfc_expr *expr)
+{
+  gfc_actual_arglist *arg;
+  gfc_constructor *c;
+  gfc_ref *ref;
+  int i;
+
+  if (!expr)
+    return false;
+
+  switch (expr->expr_type)
+    {
+    case EXPR_VARIABLE:
+      if (expr->symtree->n.sym->attr.implied_index)
+	return true;
+      break;
+
+    case EXPR_OP:
+      if (gfc_contains_implied_index_p (expr->value.op.op1)
+	  || gfc_contains_implied_index_p (expr->value.op.op2))
+	return true;
+      break;
+
+    case EXPR_FUNCTION:
+      for (arg = expr->value.function.actual; arg; arg = arg->next)
+	if (gfc_contains_implied_index_p (arg->expr))
+	  return true;
+      break;
+
+    case EXPR_CONSTANT:
+    case EXPR_NULL:
+    case EXPR_SUBSTRING:
+      break;
+
+    case EXPR_STRUCTURE:
+    case EXPR_ARRAY:
+      for (c = gfc_constructor_first (expr->value.constructor);
+	   c; gfc_constructor_next (c))
+	if (gfc_contains_implied_index_p (c->expr))
+	  return true;
+      break;
+
+    default:
+      gcc_unreachable ();
+    }
+
+  for (ref = expr->ref; ref; ref = ref->next)
+    switch (ref->type)
+      {
+      case REF_ARRAY:
+	for (i = 0; i < ref->u.ar.dimen; i++)
+	  if (gfc_contains_implied_index_p (ref->u.ar.start[i])
+	      || gfc_contains_implied_index_p (ref->u.ar.end[i])
+	      || gfc_contains_implied_index_p (ref->u.ar.stride[i]))
+	    return true;
+	break;
+
+      case REF_COMPONENT:
+	break;
+
+      case REF_SUBSTRING:
+	if (gfc_contains_implied_index_p (ref->u.ss.start)
+	    || gfc_contains_implied_index_p (ref->u.ss.end))
+	  return true;
+	break;
+
+      default:
+	gcc_unreachable ();
+      }
+
+  return false;
+}
+
+
 /* Determines overlapping for two single element array references.  */
 
 static gfc_dependency
diff --git a/gcc/fortran/dependency.h b/gcc/fortran/dependency.h
index 3f81d40..2fc2e56 100644
--- a/gcc/fortran/dependency.h
+++ b/gcc/fortran/dependency.h
@@ -41,6 +41,7 @@ bool gfc_dep_resolver (gfc_ref *, gfc_ref *, gfc_reverse *,
 		      bool identical = false);
 bool gfc_are_equivalenced_arrays (gfc_expr *, gfc_expr *);
 bool gfc_omp_expr_prefix_same (gfc_expr *, gfc_expr *);
+bool gfc_contains_implied_index_p (gfc_expr *);
 
 gfc_expr * gfc_discard_nops (gfc_expr *);
 
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index fbe7333..d965539 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -2814,8 +2814,8 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
     end.expr = gfc_evaluate_now (end.expr, &se->pre);
 
   if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
-      && (ref->u.ss.start->symtree
-	  && !ref->u.ss.start->symtree->n.sym->attr.implied_index))
+      && !gfc_contains_implied_index_p (ref->u.ss.start)
+      && !gfc_contains_implied_index_p (ref->u.ss.end))
     {
       tree nonempty = fold_build2_loc (input_location, LE_EXPR,
 				       logical_type_node, start.expr,
diff --git a/gcc/testsuite/gfortran.dg/bounds_check_23.f90 b/gcc/testsuite/gfortran.dg/bounds_check_23.f90
index 8de90c7..4ef03a5 100644
--- a/gcc/testsuite/gfortran.dg/bounds_check_23.f90
+++ b/gcc/testsuite/gfortran.dg/bounds_check_23.f90
@@ -5,6 +5,8 @@
 program test
   implicit none
   call sub('Lorem ipsum')
+  call sub2('Lorem ipsum')
+  call sub3('Lorem ipsum')
 contains
   subroutine sub( text )
     character(len=*), intent(in)  :: text
@@ -13,6 +15,20 @@ contains
     c = [ ( text(i:i), i = 1, len(text) ) ]
     if (c(1) /= 'L') stop 1
   end subroutine sub
+  subroutine sub2 (txt2)
+    character(len=*), intent(in)  :: txt2
+    character(len=1), allocatable :: c(:)
+    integer :: i
+    c = [ ( txt2(i+0:i), i = 1, len(txt2) ) ]
+    if (c(1) /= 'L') stop 2
+  end subroutine sub2
+  subroutine sub3 (txt3)
+    character(len=*), intent(in)  :: txt3
+    character(len=1), allocatable :: c(:)
+    integer :: i
+    c = [ ( txt3(i:i+0), i = 1, len(txt3) ) ]
+    if (c(1) /= 'L') stop 3
+  end subroutine sub3
 end program test
 
-! { dg-final { scan-tree-dump-times "Substring out of bounds:" 2 "original" } }
+! { dg-final { scan-tree-dump-times "Substring out of bounds:" 6 "original" } }
diff --git a/gcc/testsuite/gfortran.dg/bounds_check_26.f90 b/gcc/testsuite/gfortran.dg/bounds_check_26.f90
new file mode 100644
index 0000000..69ac9fb
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/bounds_check_26.f90
@@ -0,0 +1,24 @@
+! { dg-do compile }
+! { dg-options "-fcheck=bounds -fdump-tree-original" }
+!
+! PR fortran/119118
+
+program main
+  implicit none
+  character(10) :: str = "1234567890"
+  integer       :: n   = 3
+
+  print *,      str(-1:-2)  ! zero-length substring: OK
+
+  print *,      str(-1:n)   ! 2 checked bounds
+  print *, len (str(-1:n))  ! 2 checked bounds
+
+  print *,      str(-n:1)   ! 1 checked bound / 1 eliminated
+  print *, len (str(-n:1))  ! 1 checked bound / 1 eliminated
+
+  print *,      str(-n:11)  ! 2 checked bounds
+  print *, len (str(-n:11)) ! 2 checked bounds
+
+end program main
+
+! { dg-final { scan-tree-dump-times "Substring out of bounds:" 10 "original" } }