Possible patch for pr62242 -- follow-up

[Louis Krupp <louis.krupp@zoho.com>]

[-- Attachment #1: Type: text/plain, Size: 4211 bytes --]

Would anyone like me to spend some more time on this and perhaps clear up some of the TODO items?

(Unlike some of you, I'm retired.  I have time for this.)

Louis

 == == == == == == Forwarded message == == == == == == 
From : Louis Krupp<louis.krupp@zoho.com>
To : "gcc-patches"<gcc-patches@gcc.gnu.org>,"fortran"<fortran@gcc.gnu.org>
Date : Wed, 09 Sep 2015 00:25:45 -0700
Subject : Possible patch for pr62242
 == == == == == == Forwarded message == == == == == == 
This was ... interesting. There were a couple of problems that triggered ICEs.

This patch fixes the reported file (I made sure this time) and causes no regressions as far as I can tell.

Dominique ... merci de votre patience.

Louis

Index: gcc/fortran/ChangeLog
===================================================================
--- gcc/fortran/ChangeLog    (revision 227571)
+++ gcc/fortran/ChangeLog    (working copy)
@@ -1,3 +1,12 @@
+2015-09-08 Louis Krupp <louis.krupp@zoho.com>
+
+    PR fortran/62242
+    * trans-array.c (get_array_ctor_all_strlen): Don't store length
+    tree pointer unless we know it's necessary
+    (trans_array_constructor): Create new gfc_charlen instance so
+    context-specific length expression isn't shared
+    (gfc_add_loop_ss_code): Don't try to convert non-constant length
+
 2015-09-04 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
 
     * intrinsic.h (gfc_simplify_mvbits): Remove.
Index: gcc/fortran/trans-array.c
===================================================================
--- gcc/fortran/trans-array.c    (revision 227571)
+++ gcc/fortran/trans-array.c    (working copy)
@@ -1836,7 +1836,9 @@ get_array_ctor_all_strlen (stmtblock_t *block, gfc
 gfc_add_block_to_block (block, &se.pre);
 gfc_add_block_to_block (block, &se.post);
 
- e->ts.u.cl->backend_decl = *len;
+ /* TODO: No test cases failed when the "if (0)" was added.
+     Is there a reason to put this back the way it was? */
+ if (0) e->ts.u.cl->backend_decl = *len;
 }
 }
 
@@ -2226,6 +2228,7 @@ trans_array_constructor (gfc_ss * ss, locus * wher
 if (expr->ts.type == BT_CHARACTER)
 {
 bool const_string;
+ gfc_charlen *new_cl;
 
 /* get_array_ctor_strlen walks the elements of the constructor, if a
      typespec was given, we already know the string length and want the one
@@ -2251,8 +2254,36 @@ trans_array_constructor (gfc_ss * ss, locus * wher
      and not end up here. */
 gcc_assert (ss_info->string_length);
 
- expr->ts.u.cl->backend_decl = ss_info->string_length;
+ /* get_array_ctor_strlen can create a temporary variable in the
+     current context which will be part of string_length. If we share
+     the resulting gfc_charlen structure with a variable in a different
+     declaration context, we could trip the assertion in
+     expand_expr_real_1 when it sees that the temporary has been
+     created in one context and referenced in another:
 
+     if (exp)
+     context = decl_function_context (exp);
+     gcc_assert (!exp
+         || SCOPE_FILE_SCOPE_P (context)
+         || context == current_function_decl
+         || TREE_STATIC (exp)
+         || DECL_EXTERNAL (exp)
+         // ??? C++ creates functions that are not TREE_STATIC.
+         || TREE_CODE (exp) == FUNCTION_DECL);
+
+     So we create a new gfc_charlen structure and link it into what
+     looks like the current namespace.
+
+     TODO: Can we do this only when get_array_ctor_strlen has been
+     called? Does it matter? Are we using the right namespace (and
+     does it matter, as long as the gfc_charlen structure is cleaned
+     up)?
+ */
+
+ new_cl = gfc_new_charlen (gfc_current_ns, expr->ts.u.cl);
+ new_cl->backend_decl = ss_info->string_length;
+ expr->ts.u.cl = new_cl;
+
 type = gfc_get_character_type_len (expr->ts.kind, ss_info->string_length);
 if (const_string)
     type = build_pointer_type (type);
@@ -2589,7 +2620,8 @@ gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss
      if (expr->ts.type == BT_CHARACTER
      && ss_info->string_length == NULL
      && expr->ts.u.cl
-     && expr->ts.u.cl->length)
+     && expr->ts.u.cl->length
+     && expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
      {
      gfc_init_se (&se, NULL);
      gfc_conv_expr_type (&se, expr->ts.u.cl->length,


[-- Attachment #2: string_array_constructor_1.f90 --]
[-- Type: application/octet-stream, Size: 763 bytes --]

! { dg-do compile }
! PR 62242
! Array constructor with an array element whose value is a
! character function that is described in an interface block and which
! has an assumed-length result
module gfbug
    implicit none
    INTERFACE
      function UpperCase(string) result(upper) 
          character(*), intent(IN) :: string
          character(LEN(string)) :: upper
      end function
      function f2(string) result(upper) 
          character(*), intent(IN) :: string
          character(5) :: upper
      end function
    END INTERFACE
contains
    subroutine s1
        character(5) c
        character(5), dimension(1) :: ca
        ca = (/f2(c)/)  ! This compiles
        ca = (/Uppercase(c)/) ! This gets an ICE
    end subroutine
end module gfbug


[-- Attachment #3: string_array_constructor_2.f90 --]
[-- Type: application/octet-stream, Size: 1272 bytes --]

! { dg-do run }
! PR 62242
! Array constructor with an array element whose value is a
! character function that is described in an interface block and which
! has an assumed-length result
module gfbug
    implicit none
    INTERFACE
      function UpperCase(string) result(upper) 
          character(*), intent(IN) :: string
          character(LEN(string)) :: upper
      end function
      function f2(string) result(upper) 
          character(*), intent(IN) :: string
          character(5) :: upper
      end function
    END INTERFACE
contains
    subroutine s1
        character(5) c
        character(5), dimension(1) :: ca
        character(5), dimension(1) :: cb
        c = "12345"
        ca = (/f2(c)/) ! This works
        !print *, ca(1)
        cb = (/Uppercase(c)/) ! This gets an ICE
        if (ca(1) .ne. cb(1)) then
            call abort()
        end if
        !print *, ca(1)
    end subroutine
end module gfbug

function UpperCase(string) result(upper) 
    character(*), intent(IN) :: string
    character(LEN(string)) :: upper
    upper = string
end function
function f2(string) result(upper) 
    character(*), intent(IN) :: string
    character(5) :: upper
    upper = string
end function

program main
    use gfbug
    call s1
end program

[-- Attachment #4: string_array_constructor_3.f90 --]
[-- Type: application/octet-stream, Size: 614 bytes --]

! { dg-do compile }
! PR 62242
! A subprogram calling an array constructor with an array element whose
! value is the result of calling a character function with both an
! assumed-length argument and an assumed-length result
module gfbug
    implicit none
contains
    function inner(inner_str) result(upper)
        character(*), intent(IN) :: inner_str
        character(LEN(inner_str)) :: upper

        upper = '123'
    end function

    subroutine outer(outer_str)
        character(*), intent(IN) :: outer_str
        character(5) :: z(1)

        z = [inner(outer_str)]
    end subroutine
end module gfbug