Re: [Patch, fortran] PR87151 - allocating array of character

Re: [Patch, fortran] PR87151 - allocating array of character

[Dominique d'Humières]

Hi Paul,

Your patch works as expected. It also fixes the ICEs for the tests in pr80931 
(and the test accidentally attached to pr83196).

Thanks for the patch.

Dominique

Re: [Patch, fortran] PR87151 - allocating array of character

[Paul Richard Thomas]

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

Hi Dominique,

Thanks for the testing. Although the tests for PR80931 and PR83196,
comment #4, compiled OK, when I attempted to use the modules both
segfaulted for the same reason ('span' not being set on the array
descriptor) and these required a slightly different version of the
same tweak.

The attached regtests fine on FC28/x86_64 - OK for trunk and later for 8-branch?

Cheers

Paul

2018-10-07  Paul Thomas  <pault@gcc.gnu.org>

    PR fortran/87151
    * trans-array.c (gfc_get_array_span): Deal with deferred char
    array components having a TYPE_MAX_VALUE of zero.
    (gfc_array_init_size): Use the hidden string length component
    to build the descriptor dtype.
    (gfc_array_allocate): Remove the erroneous replacement of the
    charlen backend decl with a temporary.
    (gfc_conv_expr_descriptor): Use the ss_info string length in
    the case of deferred character components.
    (gfc_alloc_allocatable_for_assignment): Actually compare the
    string lengths for deferred characters. Make sure that kind > 1
    is handled correctly. Set the span field of the descriptor.
    * trans-intrinsic.c (gfc_conv_intrinsic_len): Remove the stupid
    comment.

    PR fortran/80931
    * trans-array.c (gfc_array_allocate): Set the span field for
    variable length character arrays.


2018-10-07  Paul Thomas  <pault@gcc.gnu.org>

    PR fortran/87151
    * gfortran.dg/deferred_type_component_3.f90: New test.

    PR fortran/80931
    * gfortran.dg/deferred_character_28.f90: New test.
    * gfortran.dg/deferred_character_29.f90: New test (note that
    this test appears in PR83196 comment #4 by mistake).

On Mon, 8 Oct 2018 at 10:08, Dominique d'Humières <dominiq@lps.ens.fr> wrote:
>
> Hi Paul,
>
> Your patch works as expected. It also fixes the ICEs for the tests in pr80931
> (and the test accidentally attached to pr83196).
>
> Thanks for the patch.
>
> Dominique
>


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

[-- Attachment #2: submit.diff --]
[-- Type: text/x-patch, Size: 19949 bytes --]

Index: gcc/fortran/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c	(revision 264918)
--- gcc/fortran/trans-array.c	(working copy)
*************** gfc_get_array_span (tree desc, gfc_expr
*** 853,859 ****
  	 types if possible. Otherwise, return NULL_TREE.  */
        tmp = gfc_get_element_type (TREE_TYPE (desc));
        if (tmp && TREE_CODE (tmp) == ARRAY_TYPE
! 	  && TYPE_MAX_VALUE (TYPE_DOMAIN (tmp)) == NULL_TREE)
  	{
  	  if (expr->expr_type == EXPR_VARIABLE
  	      && expr->ts.type == BT_CHARACTER)
--- 853,860 ----
  	 types if possible. Otherwise, return NULL_TREE.  */
        tmp = gfc_get_element_type (TREE_TYPE (desc));
        if (tmp && TREE_CODE (tmp) == ARRAY_TYPE
! 	  && (TYPE_MAX_VALUE (TYPE_DOMAIN (tmp)) == NULL_TREE
! 	      || integer_zerop (TYPE_MAX_VALUE (TYPE_DOMAIN (tmp)))))
  	{
  	  if (expr->expr_type == EXPR_VARIABLE
  	      && expr->ts.type == BT_CHARACTER)
*************** gfc_array_init_size (tree descriptor, in
*** 5366,5371 ****
--- 5367,5394 ----
        tmp = gfc_conv_descriptor_dtype (descriptor);
        gfc_add_modify (pblock, tmp, gfc_get_dtype_rank_type (rank, type));
      }
+   else if (expr->ts.type == BT_CHARACTER
+ 	   && expr->ts.deferred
+ 	   && TREE_CODE (descriptor) == COMPONENT_REF)
+     {
+       /* Deferred character components have their string length tucked away
+ 	 in a hidden field of the derived type. Obtain that and use it to
+ 	 set the dtype. The charlen backend decl is zero because the field
+ 	 type is zero length.  */
+       gfc_ref *ref;
+       tmp = NULL_TREE;
+       for (ref = expr->ref; ref; ref = ref->next)
+ 	if (ref->type == REF_COMPONENT
+ 	    && gfc_deferred_strlen (ref->u.c.component, &tmp))
+ 	  break;
+       gcc_assert (tmp != NULL_TREE);
+       tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
+ 			     TREE_OPERAND (descriptor, 0), tmp, NULL_TREE);
+       tmp = fold_convert (gfc_charlen_type_node, tmp);
+       type = gfc_get_character_type_len (expr->ts.kind, tmp);
+       tmp = gfc_conv_descriptor_dtype (descriptor);
+       gfc_add_modify (pblock, tmp, gfc_get_dtype_rank_type (rank, type));
+     }
    else
      {
        tmp = gfc_conv_descriptor_dtype (descriptor);
*************** gfc_array_allocate (gfc_se * se, gfc_exp
*** 5774,5789 ****
  
    if (expr->ts.type == BT_CHARACTER
        && TREE_CODE (se->string_length) == COMPONENT_REF
!       && expr->ts.u.cl->backend_decl != se->string_length)
!     {
!       if (VAR_P (expr->ts.u.cl->backend_decl))
! 	gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
! 			fold_convert (TREE_TYPE (expr->ts.u.cl->backend_decl),
! 				      se->string_length));
!       else
! 	expr->ts.u.cl->backend_decl = gfc_evaluate_now (se->string_length,
! 							&se->pre);
!     }
  
    gfc_init_block (&set_descriptor_block);
    /* Take the corank only from the actual ref and not from the coref.  The
--- 5797,5807 ----
  
    if (expr->ts.type == BT_CHARACTER
        && TREE_CODE (se->string_length) == COMPONENT_REF
!       && expr->ts.u.cl->backend_decl != se->string_length
!       && VAR_P (expr->ts.u.cl->backend_decl))
!     gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
! 		    fold_convert (TREE_TYPE (expr->ts.u.cl->backend_decl),
! 				  se->string_length));
  
    gfc_init_block (&set_descriptor_block);
    /* Take the corank only from the actual ref and not from the coref.  The
*************** gfc_array_allocate (gfc_se * se, gfc_exp
*** 5871,5887 ****
    if (dimension)
      gfc_conv_descriptor_offset_set (&set_descriptor_block, se->expr, offset);
  
!   /* Pointer arrays need the span field to be set.  */
!   if (is_pointer_array (se->expr)
!       || (expr->ts.type == BT_CLASS
! 	  && CLASS_DATA (expr)->attr.class_pointer)
        || (expr->ts.type == BT_CHARACTER
! 	  && TREE_CODE (se->string_length) == COMPONENT_REF))
      {
        if (expr3 && expr3_elem_size != NULL_TREE)
  	tmp = expr3_elem_size;
        else if (se->string_length
! 	       && TREE_CODE (se->string_length) == COMPONENT_REF)
  	{
  	  if (expr->ts.kind != 1)
  	    {
--- 5889,5907 ----
    if (dimension)
      gfc_conv_descriptor_offset_set (&set_descriptor_block, se->expr, offset);
  
!   /* Set the span field for pointer and deferred length character arrays.  */
!   if ((is_pointer_array (se->expr)
!        || (expr->ts.type == BT_CLASS && CLASS_DATA (expr)->attr.class_pointer)
!        || (expr->ts.type == BT_CHARACTER && TREE_CODE (se->string_length)
! 							== COMPONENT_REF))
        || (expr->ts.type == BT_CHARACTER
! 	  && (expr->ts.deferred || VAR_P (expr->ts.u.cl->backend_decl))))
      {
        if (expr3 && expr3_elem_size != NULL_TREE)
  	tmp = expr3_elem_size;
        else if (se->string_length
! 	       && (TREE_CODE (se->string_length) == COMPONENT_REF
! 		   || (expr->ts.type == BT_CHARACTER && expr->ts.deferred)))
  	{
  	  if (expr->ts.kind != 1)
  	    {
*************** gfc_conv_expr_descriptor (gfc_se *se, gf
*** 7053,7058 ****
--- 7073,7079 ----
    tree offset;
    int full;
    bool subref_array_target = false;
+   bool deferred_array_component = false;
    gfc_expr *arg, *ss_expr;
  
    if (se->want_coarray)
*************** gfc_conv_expr_descriptor (gfc_se *se, gf
*** 7092,7097 ****
--- 7113,7126 ----
        gfc_conv_ss_descriptor (&se->pre, ss, 0);
        desc = info->descriptor;
  
+       /* The charlen backend decl for deferred character components cannot
+ 	 be used because it is fixed at zero.  Instead, the hidden string
+ 	 length component is used.  */
+       if (expr->ts.type == BT_CHARACTER
+ 	  && expr->ts.deferred
+ 	  && TREE_CODE (desc) == COMPONENT_REF)
+ 	deferred_array_component = true;
+ 
        subref_array_target = se->direct_byref && is_subref_array (expr);
        need_tmp = gfc_ref_needs_temporary_p (expr->ref)
  			&& !subref_array_target;
*************** gfc_conv_expr_descriptor (gfc_se *se, gf
*** 7140,7147 ****
  	      se->expr = desc;
  	    }
  
! 	  if (expr->ts.type == BT_CHARACTER)
  	    se->string_length = gfc_get_expr_charlen (expr);
  
  	  gfc_free_ss_chain (ss);
  	  return;
--- 7169,7180 ----
  	      se->expr = desc;
  	    }
  
! 	  if (expr->ts.type == BT_CHARACTER && !deferred_array_component)
  	    se->string_length = gfc_get_expr_charlen (expr);
+ 	  /* The ss_info string length is returned set to the value of the
+ 	     hidden string length component.  */
+ 	  else if (deferred_array_component)
+ 	    se->string_length = ss_info->string_length;
  
  	  gfc_free_ss_chain (ss);
  	  return;
*************** gfc_alloc_allocatable_for_assignment (gf
*** 9797,9804 ****
    cond_null = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
  			 array1, build_int_cst (TREE_TYPE (array1), 0));
  
!   if (expr1->ts.deferred)
!     cond_null = gfc_evaluate_now (logical_true_node, &fblock);
    else
      cond_null= gfc_evaluate_now (cond_null, &fblock);
  
--- 9830,9844 ----
    cond_null = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
  			 array1, build_int_cst (TREE_TYPE (array1), 0));
  
!   if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
!     {
!       tmp = fold_build2_loc (input_location, NE_EXPR,
! 			     logical_type_node,
! 			     lss->info->string_length,
! 			     rss->info->string_length);
!       cond_null = fold_build2_loc (input_location, TRUTH_OR_EXPR,
! 				   logical_type_node, tmp, cond_null);
!     }
    else
      cond_null= gfc_evaluate_now (cond_null, &fblock);
  
*************** gfc_alloc_allocatable_for_assignment (gf
*** 10024,10029 ****
--- 10064,10075 ----
  	gfc_add_modify (&fblock, expr1->ts.u.cl->backend_decl, tmp);
        else
  	gfc_add_modify (&fblock, lss->info->string_length, tmp);
+ 
+       if (expr1->ts.kind > 1)
+ 	tmp = fold_build2_loc (input_location, MULT_EXPR,
+ 			       TREE_TYPE (tmp),
+ 			       tmp, build_int_cst (TREE_TYPE (tmp),
+ 						   expr1->ts.kind));
      }
    else if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->backend_decl)
      {
*************** gfc_alloc_allocatable_for_assignment (gf
*** 10037,10042 ****
--- 10083,10092 ----
    else
      tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
    tmp = fold_convert (gfc_array_index_type, tmp);
+ 
+   if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
+     gfc_conv_descriptor_span_set (&fblock, desc, tmp);
+ 
    size2 = fold_build2_loc (input_location, MULT_EXPR,
  			   gfc_array_index_type,
  			   tmp, size2);
Index: gcc/fortran/trans-intrinsic.c
===================================================================
*** gcc/fortran/trans-intrinsic.c	(revision 264918)
--- gcc/fortran/trans-intrinsic.c	(working copy)
*************** gfc_conv_intrinsic_len (gfc_se * se, gfc
*** 6404,6410 ****
        /* Fall through.  */
  
      default:
-       /* Anybody stupid enough to do this deserves inefficient code.  */
        gfc_init_se (&argse, se);
        if (arg->rank == 0)
  	gfc_conv_expr (&argse, arg);
--- 6404,6409 ----
Index: gcc/testsuite/gfortran.dg/deferred_character_28.f90
===================================================================
*** gcc/testsuite/gfortran.dg/deferred_character_28.f90	(nonexistent)
--- gcc/testsuite/gfortran.dg/deferred_character_28.f90	(working copy)
***************
*** 0 ****
--- 1,60 ----
+ ! { dg-do run }
+ !
+ ! Test the fix for PR80931, which was nearly fix by the patch for PR87151.
+ ! However, the 'span' for 'temp' was not being set and so a segfault
+ ! occurred in the assignment at line 39.
+ !
+ ! Contributed by Tiziano Mueller  <dev-zero@gentoo.org>
+ !
+ module input_section_types
+    type :: section
+       character(len=:), allocatable :: keywords_(:)
+ 
+       contains
+          procedure, pass :: add_keyword
+    end type
+ 
+    interface section
+       procedure constructor
+    end interface
+ 
+ contains
+ 
+    type(section) function constructor ()
+       allocate (character(len=255) :: constructor%keywords_(0))
+    end function
+ 
+    subroutine add_keyword (this, name)
+       class(section), intent(inout) :: this
+       character(*), intent(in)      :: name
+       character(len=:), allocatable :: temp(:)
+ 
+       integer :: n_elements
+ 
+       n_elements = size (this%keywords_)
+       allocate (character(len=255) :: temp(n_elements+1))
+       temp(:n_elements) = this%keywords_
+       call move_alloc (temp, this%keywords_)
+ 
+       this%keywords_(n_elements+1) = name
+    end subroutine
+ end module
+ 
+    use input_section_types
+    type(section) :: s
+    character(*), parameter :: hello = "Hello World"
+    character(*), parameter :: bye = "Goodbye World"
+ 
+    s = constructor ()
+ 
+    call s%add_keyword (hello)
+    if (len (s%keywords_) .ne. 255) stop 1
+    if (size (s%keywords_, 1) .ne. 1) stop 2
+    if (trim (s%keywords_(1)) .ne. hello) stop 3
+ 
+    call s%add_keyword (bye)
+    if (len (s%keywords_) .ne. 255) stop 4
+    if (size (s%keywords_, 1) .ne. 2) stop 5
+    if (trim (s%keywords_(1)) .ne. hello) stop 6
+    if (trim (s%keywords_(2)) .ne. bye) stop 7
+ end
Index: gcc/testsuite/gfortran.dg/deferred_character_29.f90
===================================================================
*** gcc/testsuite/gfortran.dg/deferred_character_29.f90	(nonexistent)
--- gcc/testsuite/gfortran.dg/deferred_character_29.f90	(working copy)
***************
*** 0 ****
--- 1,197 ----
+ ! { dg-do compile }
+ !
+ ! Test the fix for PR83196 comment #4 (there by mistake)
+ !
+ ! Contributed by Arjen Markus  <arjen.markus895@gmail.com>
+ !____________________________________________________________
+ ! keyindex.f90 --
+ !     Class implementing a straightforward keyword/index list
+ !     The idea is to have a very simple implementation to
+ !     store keywords (strings) and return the position in the
+ !     list or vice versa.
+ !____________________________________________________________
+ module keyindices
+     implicit none
+ 
+     private
+ 
+     integer, parameter                              :: default_keylength = 40
+ 
+     type keyindex
+         integer                                     :: keylength
+         integer                                     :: lastindex = 0
+         character(len=:), dimension(:), allocatable :: keyword
+     contains
+         procedure                                   :: init      => init_keyindex
+         procedure                                   :: get_index => get_index_from_list
+         procedure                                   :: get_key   => get_keyword_from_list
+         procedure                                   :: has_key   => has_keyword_in_list
+     end type keyindex
+ 
+     public :: keyindex
+ contains
+ 
+ ! init_keyindex --
+ !     Initialise the object
+ !
+ ! Arguments:
+ !     this                     Keyindex object
+ !     initial_size             Initial size of the list (optimisation)
+ !     keylength                Maximum length of a keyword (optional)
+ !
+ subroutine init_keyindex( this, initial_size, keylength )
+     class(keyindex), intent(inout) :: this
+     integer, intent(in)           :: initial_size
+     integer, intent(in), optional :: keylength
+ 
+     integer                       :: keylength_
+ 
+     if ( present(keylength) ) then
+         keylength_ = keylength
+     else
+         keylength_ = default_keylength
+     endif
+ 
+     !
+     ! Allocate the list of keywords
+     !
+     if ( allocated(this%keyword) ) then
+         deallocate( this%keyword )
+     endif
+ 
+ 
+     allocate( character(len=keylength_):: this%keyword(initial_size) )
+ 
+     this%lastindex = 0
+     this%keylength = keylength_
+ end subroutine init_keyindex
+ 
+ ! get_index_from_list --
+ !     Look up the keyword in the list and return its index
+ !
+ ! Arguments:
+ !     this                     Keyindex object
+ !     keyword                  Keyword to be looked up
+ !
+ ! Returns:
+ !     Index in the list
+ !
+ ! Note:
+ !     If the keyword does not yet exist, add it to the list
+ !
+ integer function get_index_from_list( this, keyword )
+     class(keyindex), intent(inout) :: this
+     character(len=*), intent(in)  :: keyword
+ 
+     integer                       :: i
+     character(len=this%keylength), dimension(:), allocatable :: newlist
+ 
+     if ( .not. allocated(this%keyword) ) then
+         call this%init( 50 )
+     endif
+ 
+     get_index_from_list = 0
+ 
+     do i = 1,this%lastindex
+         if ( this%keyword(i) == keyword ) then
+             get_index_from_list = i
+             exit
+         endif
+     enddo
+ 
+     !
+     ! Do we need to add it?
+     !
+     if ( get_index_from_list == 0 ) then
+         if ( size(this%keyword) <= this%lastindex ) then
+             !
+             ! Allocate a larger list
+             !
+             allocate( character(len=this%keylength):: newlist(2*size(this%keyword)) )
+ 
+             newlist(1:size(this%keyword)) = this%keyword
+             call move_alloc( newlist, this%keyword )
+         endif
+ 
+         get_index_from_list = this%lastindex + 1
+         this%lastindex      = get_index_from_list
+         this%keyword(get_index_from_list) = keyword
+     endif
+ end function get_index_from_list
+ 
+ ! get_keyword_from_list --
+ !     Look up the keyword in the list by the given index
+ !
+ ! Arguments:
+ !     this                     Keyindex object
+ !     idx                      Index of the keyword
+ !
+ ! Returns:
+ !     Keyword as stored in the list
+ !
+ ! Note:
+ !     If the index does not exist, an empty string is returned
+ !
+ function get_keyword_from_list( this, idx )
+     class(keyindex), intent(inout) :: this
+     integer, intent(in)            :: idx
+ 
+     character(len=this%keylength)  :: get_keyword_from_list
+ 
+     get_keyword_from_list = ' '
+ 
+     if ( idx >= 1 .and. idx <= this%lastindex ) then
+         get_keyword_from_list = this%keyword(idx)
+     endif
+ end function get_keyword_from_list
+ 
+ ! has_keyword_in_list --
+ !     Look up whether the keyword is stored in the list or not
+ !
+ ! Arguments:
+ !     this                     Keyindex object
+ !     keyword                  Keyword to be looked up
+ !
+ ! Returns:
+ !     True if the keyword is in the list or false if not
+ !
+ logical function has_keyword_in_list( this, keyword )
+     class(keyindex), intent(inout) :: this
+     character(len=*), intent(in)  :: keyword
+ 
+     integer                       :: i
+ 
+     has_keyword_in_list = .false.
+ 
+     do i = 1,this%lastindex
+         if ( this%keyword(i) == keyword ) then
+             has_keyword_in_list = .true.
+             exit
+         endif
+     enddo
+ end function has_keyword_in_list
+ 
+ end module keyindices
+ 
+     use keyindices
+     type(keyindex) :: idx
+ 
+     call idx%init (3, 8)
+ 
+     if (idx%get_index ("one") .ne. 1) stop 1
+     if (idx%get_index ("two") .ne. 2) stop 2
+     if (idx%get_index ("three") .ne. 3) stop 3
+ 
+ ! Check that new span is generated as list is extended.
+     if (idx%get_index ("four") .ne. 4) stop 4
+     if (idx%get_index ("five") .ne. 5) stop 5
+     if (idx%get_index ("six") .ne. 6) stop 6
+ 
+ ! Search by keyword
+     if (.not.idx%has_key ("four")) stop 7
+     if (idx%has_key ("seven")) stop 8
+ 
+ ! Search by index
+     if (idx%get_key (4) .ne. "four") stop 9
+     if (idx%get_key (10) .ne. "") stop 10
+ end
\ No newline at end of file
Index: gcc/testsuite/gfortran.dg/deferred_type_component_3.f90
===================================================================
*** gcc/testsuite/gfortran.dg/deferred_type_component_3.f90	(nonexistent)
--- gcc/testsuite/gfortran.dg/deferred_type_component_3.f90	(working copy)
***************
*** 0 ****
--- 1,71 ----
+ ! { dg-do run }
+ !
+ ! Test the fix for PR87151 by exercising deferred length character
+ ! array components.
+ !
+ ! Based on the contribution by Valery Weber <valeryweber@hotmail.com>
+ !
+ module bvec
+     type, public :: bvec_t
+      private
+      character(:), dimension(:), allocatable :: vc
+    contains
+      PROCEDURE, PASS :: create
+      PROCEDURE, PASS :: test_bvec
+      PROCEDURE, PASS :: delete
+   end type bvec_t
+ contains
+   subroutine create (this, switch)
+     class(bvec_t), intent(inout) :: this
+     logical :: switch
+     if (switch) then
+       allocate (character(2)::this%vc(3))
+       if (len (this%vc) .ne. 2) stop 1     ! The orignal problem. Gave 0.
+ 
+ ! Check that reallocation on assign does what it should do as required by
+ ! F2003 7.4.1.3. ie. reallocation occurs because LEN has changed.
+       this%vc = ['abcd','efgh','ijkl']
+     else
+       allocate (this%vc, source = ['abcd','efgh','ijkl'])
+     endif
+   end subroutine create
+ 
+   subroutine test_bvec (this)
+     class(bvec_t), intent(inout) :: this
+     character(20) :: buffer
+     if (allocated (this%vc)) then
+       if (len (this%vc) .ne. 4) stop 2
+       if (size (this%vc) .ne. 3) stop 3
+ ! Check array referencing and scalarized array referencing
+       if (this%vc(2) .ne. 'efgh') stop 4
+       if (any (this%vc .ne. ['abcd','efgh','ijkl'])) stop 5
+ ! Check full array io
+       write (buffer, *) this%vc
+       if (trim (buffer(2:)) .ne. 'abcdefghijkl') stop 6
+ ! Make sure that substrings work correctly
+       write (buffer, *) this%vc(:)(2:3)
+       if (trim (buffer(2:)) .ne. 'bcfgjk') stop 7
+       write (buffer, *) this%vc(2:)(2:3)
+       if (trim (buffer(2:)) .ne. 'fgjk') stop 8
+     endif
+   end subroutine test_bvec
+ 
+   subroutine delete (this)
+     class(bvec_t), intent(inout) :: this
+     if (allocated (this%vc)) then
+       deallocate (this%vc)
+     endif
+   end subroutine delete
+ end module bvec
+ 
+ program test
+   use bvec
+   type(bvec_t) :: a
+   call a%create (.false.)
+   call a%test_bvec
+   call a%delete
+ 
+   call a%create (.true.)
+   call a%test_bvec
+   call a%delete
+ end program test

Re: [Patch, fortran] PR87151 - allocating array of character

[Thomas Koenig]

Hi Paul,

> Bootstraps and regtests on FC28/x86_64 - OK for trunk and later for 8-branch?

OK.

Thanks for the patch!

Regards

	Thomas

[Patch, fortran] PR87151 - allocating array of character

[Paul Richard Thomas]

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

This turned out to be rather more than the allocation... The ChangeLog
and the patch tell the story well enough.

Bootstraps and regtests on FC28/x86_64 - OK for trunk and later for 8-branch?

Cheers

Paul

2018-10-07  Paul Thomas  <pault@gcc.gnu.org>

    PR fortran/87151
    * trans-array.c (gfc_get_array_span): Deal with deferred char
    array components having a TYPE_MAX_VALUE of zero.
    (gfc_array_init_size): Use the hidden string length component
    to build the descriptor dtype.
    (gfc_array_allocate): Remove the erroneous replacement of the
    charlen backend decl with a temporary.
    (gfc_conv_expr_descriptor): Use the ss_info string length in
    the case of deferred character components.
    (gfc_alloc_allocatable_for_assignment): Actually compare the
    string lengths for deferred characters. Make sure that kind > 1
    is handled correctly. Set the span field of the descriptor.
    * trans-intrinsic.c (gfc_conv_intrinsic_len): Remove the stupid
    comment.

2018-10-07  Paul Thomas  <pault@gcc.gnu.org>

    PR fortran/87151
    * gfortran.dg/deferred_type_component_3.f90: New test.

[-- Attachment #2: submit.diff --]
[-- Type: text/x-patch, Size: 9974 bytes --]

Index: gcc/fortran/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c	(revision 264906)
--- gcc/fortran/trans-array.c	(working copy)
*************** gfc_get_array_span (tree desc, gfc_expr
*** 853,859 ****
  	 types if possible. Otherwise, return NULL_TREE.  */
        tmp = gfc_get_element_type (TREE_TYPE (desc));
        if (tmp && TREE_CODE (tmp) == ARRAY_TYPE
! 	  && TYPE_MAX_VALUE (TYPE_DOMAIN (tmp)) == NULL_TREE)
  	{
  	  if (expr->expr_type == EXPR_VARIABLE
  	      && expr->ts.type == BT_CHARACTER)
--- 853,860 ----
  	 types if possible. Otherwise, return NULL_TREE.  */
        tmp = gfc_get_element_type (TREE_TYPE (desc));
        if (tmp && TREE_CODE (tmp) == ARRAY_TYPE
! 	  && (TYPE_MAX_VALUE (TYPE_DOMAIN (tmp)) == NULL_TREE
! 	      || integer_zerop (TYPE_MAX_VALUE (TYPE_DOMAIN (tmp)))))
  	{
  	  if (expr->expr_type == EXPR_VARIABLE
  	      && expr->ts.type == BT_CHARACTER)
*************** gfc_array_init_size (tree descriptor, in
*** 5366,5371 ****
--- 5367,5394 ----
        tmp = gfc_conv_descriptor_dtype (descriptor);
        gfc_add_modify (pblock, tmp, gfc_get_dtype_rank_type (rank, type));
      }
+   else if (expr->ts.type == BT_CHARACTER
+ 	   && expr->ts.deferred
+ 	   && TREE_CODE (descriptor) == COMPONENT_REF)
+     {
+       /* Deferred character components have their string length tucked away
+ 	 in a hidden field of the derived type. Obtain that and use it to
+ 	 set the dtype. The charlen backend decl is zero because the field
+ 	 type is zero length.  */
+       gfc_ref *ref;
+       tmp = NULL_TREE;
+       for (ref = expr->ref; ref; ref = ref->next)
+ 	if (ref->type == REF_COMPONENT
+ 	    && gfc_deferred_strlen (ref->u.c.component, &tmp))
+ 	  break;
+       gcc_assert (tmp != NULL_TREE);
+       tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
+ 			     TREE_OPERAND (descriptor, 0), tmp, NULL_TREE);
+       tmp = fold_convert (gfc_charlen_type_node, tmp);
+       type = gfc_get_character_type_len (expr->ts.kind, tmp);
+       tmp = gfc_conv_descriptor_dtype (descriptor);
+       gfc_add_modify (pblock, tmp, gfc_get_dtype_rank_type (rank, type));
+     }
    else
      {
        tmp = gfc_conv_descriptor_dtype (descriptor);
*************** gfc_array_allocate (gfc_se * se, gfc_exp
*** 5774,5789 ****

    if (expr->ts.type == BT_CHARACTER
        && TREE_CODE (se->string_length) == COMPONENT_REF
!       && expr->ts.u.cl->backend_decl != se->string_length)
!     {
!       if (VAR_P (expr->ts.u.cl->backend_decl))
! 	gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
! 			fold_convert (TREE_TYPE (expr->ts.u.cl->backend_decl),
! 				      se->string_length));
!       else
! 	expr->ts.u.cl->backend_decl = gfc_evaluate_now (se->string_length,
! 							&se->pre);
!     }

    gfc_init_block (&set_descriptor_block);
    /* Take the corank only from the actual ref and not from the coref.  The
--- 5797,5807 ----

    if (expr->ts.type == BT_CHARACTER
        && TREE_CODE (se->string_length) == COMPONENT_REF
!       && expr->ts.u.cl->backend_decl != se->string_length
!       && VAR_P (expr->ts.u.cl->backend_decl))
!     gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
! 		    fold_convert (TREE_TYPE (expr->ts.u.cl->backend_decl),
! 				  se->string_length));

    gfc_init_block (&set_descriptor_block);
    /* Take the corank only from the actual ref and not from the coref.  The
*************** gfc_conv_expr_descriptor (gfc_se *se, gf
*** 7053,7058 ****
--- 7071,7077 ----
    tree offset;
    int full;
    bool subref_array_target = false;
+   bool deferred_array_component = false;
    gfc_expr *arg, *ss_expr;

    if (se->want_coarray)
*************** gfc_conv_expr_descriptor (gfc_se *se, gf
*** 7092,7097 ****
--- 7111,7124 ----
        gfc_conv_ss_descriptor (&se->pre, ss, 0);
        desc = info->descriptor;

+       /* The charlen backend decl for deferred character components cannot
+ 	 be used because it is fixed at zero.  Instead, the hidden string
+ 	 length component is used.  */
+       if (expr->ts.type == BT_CHARACTER
+ 	  && expr->ts.deferred
+ 	  && TREE_CODE (desc) == COMPONENT_REF)
+ 	deferred_array_component = true;
+
        subref_array_target = se->direct_byref && is_subref_array (expr);
        need_tmp = gfc_ref_needs_temporary_p (expr->ref)
  			&& !subref_array_target;
*************** gfc_conv_expr_descriptor (gfc_se *se, gf
*** 7140,7147 ****
  	      se->expr = desc;
  	    }

! 	  if (expr->ts.type == BT_CHARACTER)
  	    se->string_length = gfc_get_expr_charlen (expr);

  	  gfc_free_ss_chain (ss);
  	  return;
--- 7167,7178 ----
  	      se->expr = desc;
  	    }

! 	  if (expr->ts.type == BT_CHARACTER && !deferred_array_component)
  	    se->string_length = gfc_get_expr_charlen (expr);
+ 	  /* The ss_info string length is returned set to the value of the
+ 	     hidden string length component.  */
+ 	  else if (deferred_array_component)
+ 	    se->string_length = ss_info->string_length;

  	  gfc_free_ss_chain (ss);
  	  return;
*************** gfc_alloc_allocatable_for_assignment (gf
*** 9797,9804 ****
    cond_null = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
  			 array1, build_int_cst (TREE_TYPE (array1), 0));

!   if (expr1->ts.deferred)
!     cond_null = gfc_evaluate_now (logical_true_node, &fblock);
    else
      cond_null= gfc_evaluate_now (cond_null, &fblock);

--- 9828,9842 ----
    cond_null = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
  			 array1, build_int_cst (TREE_TYPE (array1), 0));

!   if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
!     {
!       tmp = fold_build2_loc (input_location, NE_EXPR,
! 			     logical_type_node,
! 			     lss->info->string_length,
! 			     rss->info->string_length);
!       cond_null = fold_build2_loc (input_location, TRUTH_OR_EXPR,
! 				   logical_type_node, tmp, cond_null);
!     }
    else
      cond_null= gfc_evaluate_now (cond_null, &fblock);

*************** gfc_alloc_allocatable_for_assignment (gf
*** 10024,10029 ****
--- 10062,10073 ----
  	gfc_add_modify (&fblock, expr1->ts.u.cl->backend_decl, tmp);
        else
  	gfc_add_modify (&fblock, lss->info->string_length, tmp);
+
+       if (expr1->ts.kind > 1)
+ 	tmp = fold_build2_loc (input_location, MULT_EXPR,
+ 			       TREE_TYPE (tmp),
+ 			       tmp, build_int_cst (TREE_TYPE (tmp),
+ 						   expr1->ts.kind));
      }
    else if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->backend_decl)
      {
*************** gfc_alloc_allocatable_for_assignment (gf
*** 10037,10042 ****
--- 10081,10090 ----
    else
      tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
    tmp = fold_convert (gfc_array_index_type, tmp);
+
+   if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
+     gfc_conv_descriptor_span_set (&fblock, desc, tmp);
+
    size2 = fold_build2_loc (input_location, MULT_EXPR,
  			   gfc_array_index_type,
  			   tmp, size2);
Index: gcc/fortran/trans-intrinsic.c
===================================================================
*** gcc/fortran/trans-intrinsic.c	(revision 264906)
--- gcc/fortran/trans-intrinsic.c	(working copy)
*************** gfc_conv_intrinsic_len (gfc_se * se, gfc
*** 6404,6410 ****
        /* Fall through.  */

      default:
-       /* Anybody stupid enough to do this deserves inefficient code.  */
        gfc_init_se (&argse, se);
        if (arg->rank == 0)
  	gfc_conv_expr (&argse, arg);
--- 6404,6409 ----
Index: gcc/testsuite/gfortran.dg/deferred_type_component_3.f90
===================================================================
*** gcc/testsuite/gfortran.dg/deferred_type_component_3.f90	(nonexistent)
--- gcc/testsuite/gfortran.dg/deferred_type_component_3.f90	(working copy)
***************
*** 0 ****
--- 1,71 ----
+ ! { dg-do run }
+ !
+ ! Test the fix for PR87151 by exercising deferred length character
+ ! array components.
+ !
+ ! Based on the contribution by Valery Weber <valeryweber@hotmail.com>
+ !
+ module bvec
+     type, public :: bvec_t
+      private
+      character(:), dimension(:), allocatable :: vc
+    contains
+      PROCEDURE, PASS :: create
+      PROCEDURE, PASS :: test_bvec
+      PROCEDURE, PASS :: delete
+   end type bvec_t
+ contains
+   subroutine create (this, switch)
+     class(bvec_t), intent(inout) :: this
+     logical :: switch
+     if (switch) then
+       allocate (character(2)::this%vc(3))
+       if (len (this%vc) .ne. 2) stop 1     ! The orignal problem. Gave 0.
+
+ ! Check that reallocation on assign does what it should do as required by
+ ! F2003 7.4.1.3. ie. reallocation occurs because LEN has changed.
+       this%vc = ['abcd','efgh','ijkl']
+     else
+       allocate (this%vc, source = ['abcd','efgh','ijkl'])
+     endif
+   end subroutine create
+
+   subroutine test_bvec (this)
+     class(bvec_t), intent(inout) :: this
+     character(20) :: buffer
+     if (allocated (this%vc)) then
+       if (len (this%vc) .ne. 4) stop 2
+       if (size (this%vc) .ne. 3) stop 3
+ ! Check array referencing and scalarized array referencing
+       if (this%vc(2) .ne. 'efgh') stop 4
+       if (any (this%vc .ne. ['abcd','efgh','ijkl'])) stop 5
+ ! Check full array io
+       write (buffer, *) this%vc
+       if (trim (buffer(2:)) .ne. 'abcdefghijkl') stop 6
+ ! Make sure that substrings work correctly
+       write (buffer, *) this%vc(:)(2:3)
+       if (trim (buffer(2:)) .ne. 'bcfgjk') stop 7
+       write (buffer, *) this%vc(2:)(2:3)
+       if (trim (buffer(2:)) .ne. 'fgjk') stop 8
+     endif
+   end subroutine test_bvec
+
+   subroutine delete (this)
+     class(bvec_t), intent(inout) :: this
+     if (allocated (this%vc)) then
+       deallocate (this%vc)
+     endif
+   end subroutine delete
+ end module bvec
+
+ program test
+   use bvec
+   type(bvec_t) :: a
+   call a%create (.false.)
+   call a%test_bvec
+   call a%delete
+
+   call a%create (.true.)
+   call a%test_bvec
+   call a%delete
+ end program test