[gcc r10-9001] fortran: Fix up gfc_typename CHARACTER length handling [PR97768]

[gcc r10-9001] fortran: Fix up gfc_typename CHARACTER length handling [PR97768]

[Jakub Jelinek]

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

commit r10-9001-gf7c2be50afa7935d3a05e3c7761e69d8b539da5b
Author: Jakub Jelinek <jakub@redhat.com>
Date:   Wed Nov 11 08:27:38 2020 +0100

    fortran: Fix up gfc_typename CHARACTER length handling [PR97768]
    
    The first testcase below ICEs when f951 is 32-bit (or 64-bit big-endian).
    The problem is that ex->ts.u.cl && ex->ts.u.cl->length are both non-NULL,
    but ex->ts.u.cl->length->expr_type is not EXPR_CONSTANT, but EXPR_FUNCTION.
    value.function.actual and value.function.name are in that case pointers,
    but value._mp_alloc and value._mp_size are 4 byte integers no matter what.
    So, in 64-bit little-endian the function returns most of the time incorrect
    CHARACTER(0) because the most significant 32 bits of the
    value.function.actual pointer are likely 0.
    Anyway, the following patch is an attempt to get all the cases right.
    Uses ex->value.character.length only for ex->expr_type == EXPR_CONSTANT
    (i.e. CHARACTER literals), handles the deferred lengths, assumed lengths,
    known constant lengths and finally if the length is something other,
    just doesn't print it, i.e. prints just CHARACTER (for default kind)
    or CHARACTER(KIND=4) (for e.g. kind 4).
    
    2020-11-11  Jakub Jelinek  <jakub@redhat.com>
    
            PR fortran/97768
    gcc/fortran/
            * misc.c (gfc_typename): Use ex->value.character.length only if
            ex->expr_type == EXPR_CONSTANT.  If ex->ts.deferred, print : instead
            of length.  If ex->ts.u.cl && ex->ts.u.cl->length == NULL, print *
            instead of length.  Otherwise if character length is non-constant,
            print just CHARACTER or CHARACTER(KIND=N).
    gcc/testsuite/
            * gfortran.dg/pr97768_1.f90: New test.
            * gfortran.dg/pr97768_2.f90: New test.
    
    (cherry picked from commit 81372618277bfae682434fcdc80b311ee6007476)

Diff:
---
 gcc/fortran/misc.c                      | 28 +++++++++++++++--
 gcc/testsuite/gfortran.dg/pr97768_1.f90 | 25 ++++++++++++++++
 gcc/testsuite/gfortran.dg/pr97768_2.f90 | 53 +++++++++++++++++++++++++++++++++
 3 files changed, 103 insertions(+), 3 deletions(-)

diff --git a/gcc/fortran/misc.c b/gcc/fortran/misc.c
index caf32dfd095..e68831ef907 100644
--- a/gcc/fortran/misc.c
+++ b/gcc/fortran/misc.c
@@ -224,10 +224,32 @@ gfc_typename (gfc_expr *ex)
 
   if (ex->ts.type == BT_CHARACTER)
     {
-      if (ex->ts.u.cl && ex->ts.u.cl->length)
-	length = gfc_mpz_get_hwi (ex->ts.u.cl->length->value.integer);
-      else
+      if (ex->expr_type == EXPR_CONSTANT)
 	length = ex->value.character.length;
+      else if (ex->ts.deferred)
+	{
+	  if (ex->ts.kind == gfc_default_character_kind)
+	    return "CHARACTER(:)";
+	  sprintf (buffer, "CHARACTER(:,%d)", ex->ts.kind);
+	  return buffer;
+	}
+      else if (ex->ts.u.cl && ex->ts.u.cl->length == NULL)
+	{
+	  if (ex->ts.kind == gfc_default_character_kind)
+	    return "CHARACTER(*)";
+	  sprintf (buffer, "CHARACTER(*,%d)", ex->ts.kind);
+	  return buffer;
+	}
+      else if (ex->ts.u.cl == NULL
+	       || ex->ts.u.cl->length->expr_type != EXPR_CONSTANT)
+	{
+	  if (ex->ts.kind == gfc_default_character_kind)
+	    return "CHARACTER";
+	  sprintf (buffer, "CHARACTER(KIND=%d)", ex->ts.kind);
+	  return buffer;
+	}
+      else
+	length = gfc_mpz_get_hwi (ex->ts.u.cl->length->value.integer);
       if (ex->ts.kind == gfc_default_character_kind)
 	sprintf (buffer, "CHARACTER(" HOST_WIDE_INT_PRINT_DEC ")", length);
       else
diff --git a/gcc/testsuite/gfortran.dg/pr97768_1.f90 b/gcc/testsuite/gfortran.dg/pr97768_1.f90
new file mode 100644
index 00000000000..fce01e36a70
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr97768_1.f90
@@ -0,0 +1,25 @@
+! PR fortran/97768
+! { dg-do compile }
+
+module pr97768_1
+  interface operator(.in.)
+    module procedure substr_in_str
+  end interface
+contains
+  pure function to_upper (in_str) result (string)
+    character(len=*), intent(in) :: in_str
+    character(len=len(in_str)) :: string
+    string = in_str
+  end function to_upper
+  logical pure function substr_in_str (substring, string)
+    character(len=*), intent(in) :: string, substring
+    substr_in_str=.false.
+  end function
+end module
+function foo ()
+  use pr97768_1, only : to_upper, operator(.in.)
+  logical :: foo
+  character(len=8) :: str
+  str = 'abcde'
+  foo = 'b' .in. to_upper (str)
+end function foo
diff --git a/gcc/testsuite/gfortran.dg/pr97768_2.f90 b/gcc/testsuite/gfortran.dg/pr97768_2.f90
new file mode 100644
index 00000000000..5dc198720b6
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr97768_2.f90
@@ -0,0 +1,53 @@
+! PR fortran/97768
+! { dg-do compile }
+
+module pr97768_2
+  interface operator(.in.)
+    module procedure substr_in_str
+  end interface
+contains
+  pure function to_upper (in_str) result (string)
+    character(len=*), intent(in) :: in_str
+    character(len=len(in_str)) :: string
+    string = in_str
+  end function to_upper
+  logical pure function substr_in_str (substring, string)
+    character(len=*), intent(in) :: string, substring
+    substr_in_str=.false.
+  end function
+end module
+function foo ()
+  use pr97768_2, only : to_upper, operator(.in.)
+  logical :: foo
+  character(len=8) :: str
+  str = 'abcde'
+  foo = to_upper (str) .in. 32    ! { dg-error "are CHARACTER/INTEGER" }
+end function foo
+function bar (str)
+  use pr97768_2, only : operator(.in.)
+  logical :: bar
+  character(len=*) :: str
+  foo = str .in. 32               ! { dg-error "are CHARACTER\\(\\*\\)/INTEGER" }
+end function bar
+function baz (lenstr)
+  use pr97768_2, only : operator(.in.)
+  logical :: baz
+  integer :: lenstr
+  character(len=lenstr) :: str
+  str = 'abc'
+  foo = str .in. 32               ! { dg-error "are CHARACTER/INTEGER" }
+end function baz
+function qux ()
+  use pr97768_2, only : operator(.in.)
+  logical :: qux
+  character(len=8) :: str
+  str = 'def'
+  foo = str .in. 32               ! { dg-error "are CHARACTER\\(8\\)/INTEGER" }
+end function qux
+function corge ()
+  use pr97768_2, only : operator(.in.)
+  logical :: corge
+  character(len=:), allocatable :: str
+  str = 'ghijk'
+  foo = str .in. 32               ! { dg-error "are CHARACTER\\(:\\)/INTEGER" }
+end function corge