[gcc r12-3033] Fortran - simplify length of substring with constant bounds

[gcc r12-3033] Fortran - simplify length of substring with constant bounds

[Harald Anlauf]

https://gcc.gnu.org/g:d881460deb1f0bdfc3e8fa2d391a03a9763cbff4

commit r12-3033-gd881460deb1f0bdfc3e8fa2d391a03a9763cbff4
Author: Harald Anlauf <anlauf@gmx.de>
Date:   Thu Aug 19 21:00:45 2021 +0200

    Fortran - simplify length of substring with constant bounds
    
    gcc/fortran/ChangeLog:
    
            PR fortran/100950
            * simplify.c (substring_has_constant_len): New.
            (gfc_simplify_len): Handle case of substrings with constant
            bounds.
    
    gcc/testsuite/ChangeLog:
    
            PR fortran/100950
            * gfortran.dg/pr100950.f90: New test.

Diff:
---
 gcc/fortran/simplify.c                 | 75 +++++++++++++++++++++++++++++++++-
 gcc/testsuite/gfortran.dg/pr100950.f90 | 53 ++++++++++++++++++++++++
 2 files changed, 127 insertions(+), 1 deletion(-)

diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c
index c27b47aa98f..492867e12cb 100644
--- a/gcc/fortran/simplify.c
+++ b/gcc/fortran/simplify.c
@@ -4512,6 +4512,78 @@ gfc_simplify_leadz (gfc_expr *e)
 }
 
 
+/* Check for constant length of a substring.  */
+
+static bool
+substring_has_constant_len (gfc_expr *e)
+{
+  gfc_ref *ref;
+  HOST_WIDE_INT istart, iend, length;
+  bool equal_length = false;
+
+  if (e->ts.type != BT_CHARACTER)
+    return false;
+
+  for (ref = e->ref; ref; ref = ref->next)
+    if (ref->type != REF_COMPONENT && ref->type != REF_ARRAY)
+      break;
+
+  if (!ref
+      || ref->type != REF_SUBSTRING
+      || !ref->u.ss.start
+      || ref->u.ss.start->expr_type != EXPR_CONSTANT
+      || !ref->u.ss.end
+      || ref->u.ss.end->expr_type != EXPR_CONSTANT
+      || !ref->u.ss.length)
+    return false;
+
+  /* For non-deferred strings the given length shall be constant.  */
+  if (!e->ts.deferred
+      && (!ref->u.ss.length->length
+	  || ref->u.ss.length->length->expr_type != EXPR_CONSTANT))
+    return false;
+
+  /* Basic checks on substring starting and ending indices.  */
+  if (!gfc_resolve_substring (ref, &equal_length))
+    return false;
+
+  istart = gfc_mpz_get_hwi (ref->u.ss.start->value.integer);
+  iend = gfc_mpz_get_hwi (ref->u.ss.end->value.integer);
+
+  if (istart <= iend)
+    {
+      if (istart < 1)
+	{
+	  gfc_error ("Substring start index (" HOST_WIDE_INT_PRINT_DEC
+		     ") at %L below 1",
+		     istart, &ref->u.ss.start->where);
+	  return false;
+	}
+
+      /* For deferred strings use end index as proxy for length.  */
+      if (e->ts.deferred)
+	length = iend;
+      else
+	length = gfc_mpz_get_hwi (ref->u.ss.length->length->value.integer);
+      if (iend > length)
+	{
+	  gfc_error ("Substring end index (" HOST_WIDE_INT_PRINT_DEC
+		     ") at %L exceeds string length",
+		     iend, &ref->u.ss.end->where);
+	  return false;
+	}
+      length = iend - istart + 1;
+    }
+  else
+    length = 0;
+
+  /* Fix substring length.  */
+  e->value.character.length = length;
+
+  return true;
+}
+
+
 gfc_expr *
 gfc_simplify_len (gfc_expr *e, gfc_expr *kind)
 {
@@ -4521,7 +4593,8 @@ gfc_simplify_len (gfc_expr *e, gfc_expr *kind)
   if (k == -1)
     return &gfc_bad_expr;
 
-  if (e->expr_type == EXPR_CONSTANT)
+  if (e->expr_type == EXPR_CONSTANT
+      || substring_has_constant_len (e))
     {
       result = gfc_get_constant_expr (BT_INTEGER, k, &e->where);
       mpz_set_si (result->value.integer, e->value.character.length);
diff --git a/gcc/testsuite/gfortran.dg/pr100950.f90 b/gcc/testsuite/gfortran.dg/pr100950.f90
new file mode 100644
index 00000000000..cb9d126bc18
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr100950.f90
@@ -0,0 +1,53 @@
+! { dg-do run }
+! { dg-additional-options "-fdump-tree-original" }
+! PR fortran/100950 - ICE in output_constructor_regular_field, at varasm.c:5514
+
+program p
+  character(8), parameter :: u = "123"
+  character(8)            :: x = "", s
+  character(2)            :: w(2) = [character(len(x(3:4))) :: 'a','b' ]
+  character(*), parameter :: y(*) = [character(len(u(3:4))) :: 'a','b' ]
+  character(*), parameter :: z(*) = [character(len(x(3:4))) :: 'a','b' ]
+  character(*), parameter :: t(*) = [character(len(x( :2))) :: 'a','b' ]
+  character(*), parameter :: v(*) = [character(len(x(7: ))) :: 'a','b' ]
+  type t_
+     character(len=5)              :: s
+     character(len=8)              :: t(4)
+     character(len=8), pointer     :: u(:)
+     character(len=:), allocatable :: str
+     character(len=:), allocatable :: str2(:)
+  end type t_
+  type(t_)                :: q, r(1)
+  integer,      parameter :: lq = len (q%s(3:4)), lr = len (r%s(3:4))
+  integer,      parameter :: l1 = len (q   %t(1)(3:4))
+  integer,      parameter :: l2 = len (q   %t(:)(3:4))
+  integer,      parameter :: l3 = len (q   %str (3:4))
+  integer,      parameter :: l4 = len (r(:)%t(1)(3:4))
+  integer,      parameter :: l5 = len (r(1)%t(:)(3:4))
+  integer,      parameter :: l6 = len (r(1)%str (3:4))
+  integer,      parameter :: l7 = len (r(1)%str2(1)(3:4))
+  integer,      parameter :: l8 = len (r(1)%str2(:)(3:4))
+
+  if (len (y) /= 2) stop 1
+  if (len (z) /= 2) stop 2
+  if (any (w /= y)) stop 3
+  if (len ([character(len(u(3:4))) :: 'a','b' ]) /= 2)  stop 4
+  if (len ([character(len(x(3:4))) :: 'a','b' ]) /= 2)  stop 5
+  if (any ([character(len(x(3:4))) :: 'a','b' ]  /= y)) stop 6
+  write(s,*) [character(len(x(3:4))) :: 'a','b' ]
+  if (s /= " a b    ") stop 7
+  if (len (t) /= 2) stop 8
+  if (len (v) /= 2) stop 9
+  if (lq /= 2 .or. lr /= 2) stop 10
+  if (l1 /= 2 .or. l2 /= 2 .or. l4 /= 2 .or. l5 /= 2) stop 11
+  if (l3 /= 2 .or. l6 /= 2 .or. l7 /= 2 .or. l8 /= 2) stop 12
+
+  block
+    integer, parameter :: l9 = len (r(1)%u(:)(3:4))
+    if (l9 /= 2) stop 13
+  end block
+end
+
+! { dg-final { scan-tree-dump-times "_gfortran_stop_numeric" 2 "original" } }
+! { dg-final { scan-tree-dump "_gfortran_stop_numeric \\(3, 0\\);" "original" } }
+! { dg-final { scan-tree-dump "_gfortran_stop_numeric \\(7, 0\\);" "original" } }