Re: [Patch, fortran] PR77296 - [F03] Compiler Error with allocatable string and associate

Re: [Patch, fortran] PR77296 - [F03] Compiler Error with allocatable string and associate

[Dominique d'Humières]

Dear Paul,

> The attached patch fixes the PR and most of the remaining, if not all,
> problems associated with deferred string length targets in the
> associate construct.

The patch works as expected. It also fixes pr60458 and its duplicate pr65187.

Thanks for working on this issue,

Dominique

Re: [Patch, fortran] PR77296 - [F03] Compiler Error with allocatable string and associate

[Paul Richard Thomas]

Committed as revision 253400.

Thanks for the review and the test.

Paul

On 1 October 2017 at 14:24, Thomas Koenig <tkoenig@netcologne.de> wrote:
> Hi Paul,
>
>> The attached patch fixes the PR and most of the remaining, if not all,
>> problems associated with deferred string length targets in the
>> associate construct.
>>
>> Bootstraps and regtests on FC23/x86_64 - OK for trunk?
>
>
> Yes.
>
> Thanks a lot for working on this!
>
> Regards
>
>         Thomas



-- 
"If you can't explain it simply, you don't understand it well enough"
- Albert Einstein

Re: [Patch, fortran] PR77296 - [F03] Compiler Error with allocatable string and associate

[Thomas Koenig]

Hi Paul,

> The attached patch fixes the PR and most of the remaining, if not all,
> problems associated with deferred string length targets in the
> associate construct.
> 
> Bootstraps and regtests on FC23/x86_64 - OK for trunk?

Yes.

Thanks a lot for working on this!

Regards

	Thomas

[Patch, fortran] PR77296 - [F03] Compiler Error with allocatable string and associate

[Paul Richard Thomas]

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

The attached patch fixes the PR and most of the remaining, if not all,
problems associated with deferred string length targets in the
associate construct.

Bootstraps and regtests on FC23/x86_64 - OK for trunk?

Paul

2017-09-29  Paul Thomas  <pault@gcc.gnu.org>

    PR fortran/77296
    * resolve.c (resolve_assoc_var): Deferred character type
    associate names must not receive an integer conatant length.
    * symbol.c (gfc_is_associate_pointer): Deferred character
    length functions also require an associate pointer.
    * trans-decl.c (gfc_get_symbol_decl): Deferred character
    length functions or derived type components require the assoc
    name to have variable string length.
    * trans-stmt.c (trans_associate_var): Set the string length of
    deferred string length associate names. The address expression
    is not needed for allocatable, pointer or dummy targets. Change
    the comment about defered string length targets.

2017-09-29  Paul Thomas  <pault@gcc.gnu.org>

    PR fortran/77296
    * gfortran.dg/associate_32.f03 : New test.

[-- Attachment #2: check2709.diff --]
[-- Type: text/plain, Size: 8092 bytes --]

Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c	(revision 253101)
--- gcc/fortran/resolve.c	(working copy)
*************** resolve_assoc_var (gfc_symbol* sym, bool
*** 8530,8536 ****
        if (!sym->ts.u.cl)
  	sym->ts.u.cl = target->ts.u.cl;

!       if (!sym->ts.u.cl->length)
  	sym->ts.u.cl->length
  	  = gfc_get_int_expr (gfc_default_integer_kind,
  			      NULL, target->value.character.length);
--- 8530,8536 ----
        if (!sym->ts.u.cl)
  	sym->ts.u.cl = target->ts.u.cl;

!       if (!sym->ts.u.cl->length && !sym->ts.deferred)
  	sym->ts.u.cl->length
  	  = gfc_get_int_expr (gfc_default_integer_kind,
  			      NULL, target->value.character.length);
Index: gcc/fortran/symbol.c
===================================================================
*** gcc/fortran/symbol.c	(revision 253101)
--- gcc/fortran/symbol.c	(working copy)
*************** gfc_is_associate_pointer (gfc_symbol* sy
*** 5054,5059 ****
--- 5054,5065 ----
    if (sym->ts.type == BT_CLASS)
      return true;

+   if (sym->ts.type == BT_CHARACTER
+       && sym->ts.deferred
+       && sym->assoc->target
+       && sym->assoc->target->expr_type == EXPR_FUNCTION)
+     return true;
+
    if (!sym->assoc->variable)
      return false;

Index: gcc/fortran/trans-decl.c
===================================================================
*** gcc/fortran/trans-decl.c	(revision 253101)
--- gcc/fortran/trans-decl.c	(working copy)
*************** gfc_get_symbol_decl (gfc_symbol * sym)
*** 1695,1700 ****
--- 1695,1708 ----
    if (sym->ts.type == BT_CHARACTER)
      {
        if (sym->attr.associate_var
+ 	  && sym->ts.deferred
+ 	  && sym->assoc && sym->assoc->target
+ 	  && ((sym->assoc->target->expr_type == EXPR_VARIABLE
+ 	       && sym->assoc->target->symtree->n.sym->ts.type != BT_CHARACTER)
+ 	      || sym->assoc->target->expr_type == EXPR_FUNCTION))
+ 	sym->ts.u.cl->backend_decl = NULL_TREE;
+
+       if (sym->attr.associate_var
  	  && sym->ts.u.cl->backend_decl
  	  && VAR_P (sym->ts.u.cl->backend_decl))
  	length = gfc_index_zero_node;
Index: gcc/fortran/trans-stmt.c
===================================================================
*** gcc/fortran/trans-stmt.c	(revision 253101)
--- gcc/fortran/trans-stmt.c	(working copy)
*************** trans_associate_var (gfc_symbol *sym, gf
*** 1533,1538 ****
--- 1533,1539 ----
    bool need_len_assign;
    bool whole_array = true;
    gfc_ref *ref;
+   symbol_attribute attr;

    gcc_assert (sym->assoc);
    e = sym->assoc->target;
*************** trans_associate_var (gfc_symbol *sym, gf
*** 1592,1597 ****
--- 1593,1609 ----

        gfc_conv_expr_descriptor (&se, e);

+       if (sym->ts.type == BT_CHARACTER
+ 	  && sym->ts.deferred
+ 	  && !sym->attr.select_type_temporary
+ 	  && VAR_P (sym->ts.u.cl->backend_decl)
+ 	  && se.string_length != sym->ts.u.cl->backend_decl)
+ 	{
+ 	  gfc_add_modify (&se.pre, sym->ts.u.cl->backend_decl,
+ 			  fold_convert (gfc_charlen_type_node,
+ 					se.string_length));
+ 	}
+
        /* If we didn't already do the pointer assignment, set associate-name
  	 descriptor to the one generated for the temporary.  */
        if ((!sym->assoc->variable && !cst_array_ctor)
*************** trans_associate_var (gfc_symbol *sym, gf
*** 1758,1765 ****
  	  need_len_assign = need_len_assign && sym->ts.type == BT_CHARACTER;
  	}

!       tmp = TREE_TYPE (sym->backend_decl);
!       tmp = gfc_build_addr_expr (tmp, se.expr);
        gfc_add_modify (&se.pre, sym->backend_decl, tmp);

        gfc_add_init_cleanup (block, gfc_finish_block( &se.pre),
--- 1770,1804 ----
  	  need_len_assign = need_len_assign && sym->ts.type == BT_CHARACTER;
  	}

!       if (sym->ts.type == BT_CHARACTER
! 	  && sym->ts.deferred
! 	  && !sym->attr.select_type_temporary
! 	  && VAR_P (sym->ts.u.cl->backend_decl)
! 	  && se.string_length != sym->ts.u.cl->backend_decl)
! 	{
! 	  gfc_add_modify (&se.pre, sym->ts.u.cl->backend_decl,
! 			  fold_convert (gfc_charlen_type_node,
! 					se.string_length));
! 	  if (e->expr_type == EXPR_FUNCTION)
! 	    {
! 	      tmp = gfc_call_free (sym->backend_decl);
! 	      gfc_add_expr_to_block (&se.post, tmp);
! 	    }
! 	}
!
!       attr = gfc_expr_attr (e);
!       if (sym->ts.type == BT_CHARACTER && e->ts.type == BT_CHARACTER
! 	  && (attr.allocatable || attr.pointer || attr.dummy))
! 	{
! 	  /* These are pointer types already.  */
! 	  tmp = fold_convert (TREE_TYPE (sym->backend_decl), se.expr);
! 	}
!       else
! 	{
!           tmp = TREE_TYPE (sym->backend_decl);
!           tmp = gfc_build_addr_expr (tmp, se.expr);
! 	}
!
        gfc_add_modify (&se.pre, sym->backend_decl, tmp);

        gfc_add_init_cleanup (block, gfc_finish_block( &se.pre),
*************** trans_associate_var (gfc_symbol *sym, gf
*** 1784,1790 ****
        gfc_init_se (&se, NULL);
        if (e->symtree->n.sym->ts.type == BT_CHARACTER)
  	{
! 	  /* What about deferred strings?  */
  	  gcc_assert (!e->symtree->n.sym->ts.deferred);
  	  tmp = e->symtree->n.sym->ts.u.cl->backend_decl;
  	}
--- 1823,1829 ----
        gfc_init_se (&se, NULL);
        if (e->symtree->n.sym->ts.type == BT_CHARACTER)
  	{
! 	  /* Deferred strings are dealt with in the preceeding.  */
  	  gcc_assert (!e->symtree->n.sym->ts.deferred);
  	  tmp = e->symtree->n.sym->ts.u.cl->backend_decl;
  	}
Index: gcc/testsuite/gfortran.dg/associate_32.f03
===================================================================
*** gcc/testsuite/gfortran.dg/associate_32.f03	(nonexistent)
--- gcc/testsuite/gfortran.dg/associate_32.f03	(working copy)
***************
*** 0 ****
--- 1,93 ----
+ ! { dg-do run }
+ !
+ ! Tests fix for PR77296 and other bugs found on the way.
+ !
+ ! Contributed by Matt Thompson  <matthew.thompson@nasa.gov>
+ !
+ program test
+
+    implicit none
+    type :: str_type
+      character(len=:), allocatable :: str
+    end type
+
+    character(len=:), allocatable :: s, sd(:)
+    character(len=2), allocatable :: sf, sfd(:)
+    character(len=6) :: str
+    type(str_type) :: string
+
+    s = 'ab'
+    associate(ss => s)
+      if (ss .ne. 'ab') call abort ! This is the original bug.
+      ss = 'c'
+    end associate
+    if (s .ne. 'c ') call abort ! No reallocation within ASSOCIATE block!
+
+    sf = 'c'
+    associate(ss => sf)
+      if (ss .ne. 'c ') call abort ! This the bug in comment #2 of the PR.
+      ss = 'cd'
+    end associate
+
+    sd = [s, sf]
+    associate(ss => sd)
+      if (any (ss .ne. ['c ','cd'])) call abort
+    end associate
+
+    sfd = [sd,'ef']
+    associate(ss => sfd)
+      if (any (ss .ne. ['c ','cd','ef'])) call abort
+      ss = ['gh']
+    end associate
+      if (any (sfd .ne. ['gh','cd','ef'])) call abort ! No reallocation!
+
+    string%str = 'xyz'
+    associate(ss => string%str)
+      if (ss .ne. 'xyz') call abort
+      ss = 'c'
+    end associate
+    if (string%str .ne. 'c  ') call abort ! No reallocation!
+
+    str = "foobar"
+    call test_char (5 , str)
+    IF (str /= "abcder") call abort
+
+    associate(ss => foo())
+      if (ss .ne. 'pqrst') call abort
+    end associate
+
+    associate(ss => bar())
+      if (ss(2) .ne. 'uvwxy') call abort
+    end associate
+
+ ! The deallocation is not strictly necessary but it does allow
+ ! other memory leakage to be tested for.
+    deallocate (s, sd, sf, sfd, string%str)
+ contains
+
+ ! This is a modified version of the subroutine in associate_1.f03.
+ ! 'str' is now a dummy.
+   SUBROUTINE test_char (n, str)
+     INTEGER, INTENT(IN) :: n
+
+     CHARACTER(LEN=n) :: str
+
+     ASSOCIATE (my => str)
+       IF (LEN (my) /= n) call abort
+       IF (my /= "fooba") call abort
+       my = "abcde"
+     END ASSOCIATE
+     IF (str /= "abcde") call abort
+   END SUBROUTINE test_char
+
+    function foo() result(res)
+      character (len=:), pointer :: res
+      allocate (res, source = 'pqrst')
+    end function
+
+    function bar() result(res)
+      character (len=:), allocatable :: res(:)
+      allocate (res, source = ['pqrst','uvwxy'])
+    end function
+
+ end program test