On 10.11.20 10:58, Jakub Jelinek via Gcc-patches wrote:
The earlier version of the patch has been successfully bootstrapped
and regtested (only with a few regressions) on x86_64-linux and i686-linux,
this version passed all the new and earlier problematic tests, ok for trunk
if it passes another bootstrap/regtest?
LGTM. Thanks!
Tobias
2020-11-10 Jakub Jelinek <ja...@redhat.com>
PR fortran/97768
* 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).
* gfortran.dg/pr97768_1.f90: New test.
* gfortran.dg/pr97768_2.f90: New test.
--- gcc/fortran/misc.c.jj 2020-11-09 23:01:02.978826528 +0100
+++ gcc/fortran/misc.c 2020-11-10 10:41:22.087850720 +0100
@@ -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
--- gcc/testsuite/gfortran.dg/pr97768_1.f90.jj 2020-11-10
10:22:26.053445061 +0100
+++ gcc/testsuite/gfortran.dg/pr97768_1.f90 2020-11-10 10:22:26.053445061
+0100
@@ -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
--- gcc/testsuite/gfortran.dg/pr97768_2.f90.jj 2020-11-10
10:22:26.053445061 +0100
+++ gcc/testsuite/gfortran.dg/pr97768_2.f90 2020-11-10 10:46:15.104602757
+0100
@@ -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
Jakub
-----------------
Mentor Graphics (Deutschland) GmbH, Arnulfstraße 201, 80634 München / Germany
Registergericht München HRB 106955, Geschäftsführer: Thomas Heurung, Alexander
Walter
