[fortran] PR84546 - [7/8 Regression] Bad sourced allocation of CLASS(*) with source with CLASS(*) component

Message ID CAGkQGi+-Ch7H1p6D-iA+ZAx7N6BxMfJHYkvE0GAPmao-x9-0Gw@mail.gmail.com
State New
Headers show
Series
  • [fortran] PR84546 - [7/8 Regression] Bad sourced allocation of CLASS(*) with source with CLASS(*) component
Related show

Commit Message

Paul Richard Thomas March 11, 2018, 7:23 p.m.
This regression came about because the vtable deep copy for derived
types with unlimited polymorphic components was not making use of the
_len parameter to compute the memory to be allocated and the offsets
to array elements.

The ChangeLogs are reasonably self explanatory.

Bootstraps and regtests on FC27/x86_64 - OK for trunk and 7-branch?

Paul

2018-03-11  Paul Thomas  <pault@gcc.gnu.org>

    PR fortran/84546
    * trans-array.c (structure_alloc_comps): Make sure that the
    vptr is copied and that the unlimited polymorphic _len is used
    to compute the size to be allocated.
    * trans-expr.c (gfc_get_class_array_ref): If unlimited, use the
    unlimited polymorphic _len for the offset to the element.
    (gfc_copy_class_to_class): Set the new 'unlimited' argument.
    * trans.h : Add the boolean 'unlimited' to the prototype.

2018-03-11  Paul Thomas  <pault@gcc.gnu.org>

    PR fortran/84546
    * gfortran.dg/unlimited_polymorphic_29.f90 : New test.

Comments

Jerry March 11, 2018, 7:35 p.m. | #1
On 03/11/2018 12:23 PM, Paul Richard Thomas wrote:
> This regression came about because the vtable deep copy for derived

> types with unlimited polymorphic components was not making use of the

> _len parameter to compute the memory to be allocated and the offsets

> to array elements.

> 

> The ChangeLogs are reasonably self explanatory.

> 

> Bootstraps and regtests on FC27/x86_64 - OK for trunk and 7-branch?


Yes, OK and thanks for the work.

Jerry
> 

> Paul

> 

> 2018-03-11  Paul Thomas  <pault@gcc.gnu.org>

> 

>      PR fortran/84546

>      * trans-array.c (structure_alloc_comps): Make sure that the

>      vptr is copied and that the unlimited polymorphic _len is used

>      to compute the size to be allocated.

>      * trans-expr.c (gfc_get_class_array_ref): If unlimited, use the

>      unlimited polymorphic _len for the offset to the element.

>      (gfc_copy_class_to_class): Set the new 'unlimited' argument.

>      * trans.h : Add the boolean 'unlimited' to the prototype.

> 

> 2018-03-11  Paul Thomas  <pault@gcc.gnu.org>

> 

>      PR fortran/84546

>      * gfortran.dg/unlimited_polymorphic_29.f90 : New test.

>

Patch

Index: gcc/fortran/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c	(revision 258189)
--- gcc/fortran/trans-array.c	(working copy)
*************** structure_alloc_comps (gfc_symbol * der_
*** 8883,8888 ****
--- 8883,8913 ----
  
  	      gfc_init_block (&tmpblock);
  
+ 	      gfc_add_modify (&tmpblock, gfc_class_vptr_get (dcmp),
+ 			      gfc_class_vptr_get (comp));
+ 
+ 	      /* Copy the unlimited '_len' field. If it is greater than zero
+ 		 (ie. a character(_len)), multiply it by size and use this
+ 		 for the malloc call.  */
+ 	      if (UNLIMITED_POLY (c))
+ 		{
+ 		  tree ctmp;
+ 		  gfc_add_modify (&tmpblock, gfc_class_len_get (dcmp),
+ 				  gfc_class_len_get (comp));
+ 
+ 		  size = gfc_evaluate_now (size, &tmpblock);
+ 		  tmp = gfc_class_len_get (comp);
+ 		  ctmp = fold_build2_loc (input_location, MULT_EXPR,
+ 					  size_type_node, size,
+ 					  fold_convert (size_type_node, tmp));
+ 		  tmp = fold_build2_loc (input_location, GT_EXPR,
+ 					 logical_type_node, tmp,
+ 					 build_zero_cst (TREE_TYPE (tmp)));
+ 		  size = fold_build3_loc (input_location, COND_EXPR,
+ 					  size_type_node, tmp, ctmp, size);
+ 		  size = gfc_evaluate_now (size, &tmpblock);
+ 		}
+ 
  	      /* Coarray component have to have the same allocation status and
  		 shape/type-parameter/effective-type on the LHS and RHS of an
  		 intrinsic assignment. Hence, we did not deallocated them - and
Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c	(revision 258189)
--- gcc/fortran/trans-expr.c	(working copy)
*************** gfc_conv_class_to_class (gfc_se *parmse,
*** 1185,1199 ****
     of the referenced element.  */
  
  tree
! gfc_get_class_array_ref (tree index, tree class_decl, tree data_comp)
  {
!   tree data = data_comp != NULL_TREE ? data_comp :
! 				       gfc_class_data_get (class_decl);
!   tree size = gfc_class_vtab_size_get (class_decl);
!   tree offset = fold_build2_loc (input_location, MULT_EXPR,
! 				 gfc_array_index_type,
! 				 index, size);
!   tree ptr;
    data = gfc_conv_descriptor_data_get (data);
    ptr = fold_convert (pvoid_type_node, data);
    ptr = fold_build_pointer_plus_loc (input_location, ptr, offset);
--- 1185,1216 ----
     of the referenced element.  */
  
  tree
! gfc_get_class_array_ref (tree index, tree class_decl, tree data_comp,
! 			 bool unlimited)
  {
!   tree data, size, tmp, ctmp, offset, ptr;
! 
!   data = data_comp != NULL_TREE ? data_comp :
! 				  gfc_class_data_get (class_decl);
!   size = gfc_class_vtab_size_get (class_decl);
! 
!   if (unlimited)
!     {
!       tmp = fold_convert (gfc_array_index_type,
! 			  gfc_class_len_get (class_decl));
!       ctmp = fold_build2_loc (input_location, MULT_EXPR,
! 			      gfc_array_index_type, size, tmp);
!       tmp = fold_build2_loc (input_location, GT_EXPR,
! 			     logical_type_node, tmp,
! 			     build_zero_cst (TREE_TYPE (tmp)));
!       size = fold_build3_loc (input_location, COND_EXPR,
! 			      gfc_array_index_type, tmp, ctmp, size);
!     }
! 
!   offset = fold_build2_loc (input_location, MULT_EXPR,
! 			    gfc_array_index_type,
! 			    index, size);
! 
    data = gfc_conv_descriptor_data_get (data);
    ptr = fold_convert (pvoid_type_node, data);
    ptr = fold_build_pointer_plus_loc (input_location, ptr, offset);
*************** gfc_copy_class_to_class (tree from, tree
*** 1295,1308 ****
  
        if (is_from_desc)
  	{
! 	  from_ref = gfc_get_class_array_ref (index, from, from_data);
  	  vec_safe_push (args, from_ref);
  	}
        else
          vec_safe_push (args, from_data);
  
        if (is_to_class)
! 	to_ref = gfc_get_class_array_ref (index, to, to_data);
        else
  	{
  	  tmp = gfc_conv_array_data (to);
--- 1312,1326 ----
  
        if (is_from_desc)
  	{
! 	  from_ref = gfc_get_class_array_ref (index, from, from_data,
! 					      unlimited);
  	  vec_safe_push (args, from_ref);
  	}
        else
          vec_safe_push (args, from_data);
  
        if (is_to_class)
! 	to_ref = gfc_get_class_array_ref (index, to, to_data, unlimited);
        else
  	{
  	  tmp = gfc_conv_array_data (to);
Index: gcc/fortran/trans.h
===================================================================
*** gcc/fortran/trans.h	(revision 258189)
--- gcc/fortran/trans.h	(working copy)
*************** tree gfc_vptr_deallocate_get (tree);
*** 431,437 ****
  void gfc_reset_vptr (stmtblock_t *, gfc_expr *);
  void gfc_reset_len (stmtblock_t *, gfc_expr *);
  tree gfc_get_vptr_from_expr (tree);
! tree gfc_get_class_array_ref (tree, tree, tree);
  tree gfc_copy_class_to_class (tree, tree, tree, bool);
  bool gfc_add_finalizer_call (stmtblock_t *, gfc_expr *);
  bool gfc_add_comp_finalizer_call (stmtblock_t *, tree, gfc_component *, bool);
--- 431,437 ----
  void gfc_reset_vptr (stmtblock_t *, gfc_expr *);
  void gfc_reset_len (stmtblock_t *, gfc_expr *);
  tree gfc_get_vptr_from_expr (tree);
! tree gfc_get_class_array_ref (tree, tree, tree, bool);
  tree gfc_copy_class_to_class (tree, tree, tree, bool);
  bool gfc_add_finalizer_call (stmtblock_t *, gfc_expr *);
  bool gfc_add_comp_finalizer_call (stmtblock_t *, tree, gfc_component *, bool);
Index: gcc/testsuite/gfortran.dg/unlimited_polymorphic_29.f90
===================================================================
*** gcc/testsuite/gfortran.dg/unlimited_polymorphic_29.f90	(nonexistent)
--- gcc/testsuite/gfortran.dg/unlimited_polymorphic_29.f90	(working copy)
***************
*** 0 ****
--- 1,84 ----
+ ! { dg-do run }
+ !
+ ! Test the fix for PR84546 in which the failing cases would
+ ! have x%vec = ['foo','b   '].
+ !
+ ! Contributed by Neil Carlson  <neil.n.carlson@gmail.com>
+ !
+ module any_vector_type
+ 
+   type :: any_vector
+     class(*), allocatable :: vec(:)
+   end type
+ 
+   interface any_vector
+     procedure any_vector1
+   end interface
+ 
+ contains
+ 
+   function any_vector1(vec) result(this)
+     class(*), intent(in) :: vec(:)
+     type(any_vector) :: this
+     allocate(this%vec, source=vec)
+   end function
+ 
+ end module
+ 
+ program main
+ 
+   use any_vector_type
+   implicit none
+ 
+   class(*), allocatable :: x
+   character(*), parameter :: vec(2) = ['foo','bar']
+   integer :: vec1(3) = [7,8,9]
+ 
+   call foo1
+   call foo2
+   call foo3
+   call foo4
+ 
+ contains
+ 
+   subroutine foo1 ! This always worked
+     allocate (any_vector :: x)
+     select type (x)
+       type is (any_vector)
+         x = any_vector(vec)
+     end select
+     call bar(1)
+     deallocate (x)
+   end
+ 
+   subroutine foo2 ! Failure found during diagnosis
+     x = any_vector (vec)
+     call bar(2)
+     deallocate (x)
+   end
+ 
+   subroutine foo3 ! Original failure
+     allocate (x, source = any_vector (vec))
+     call bar(3)
+     deallocate (x)
+   end
+ 
+   subroutine foo4 ! This always worked
+     allocate (x, source = any_vector (vec1))
+     call bar(4)
+     deallocate (x)
+   end
+ 
+   subroutine bar (stop_flag)
+     integer :: stop_flag
+     select type (x)
+       type is (any_vector)
+         select type (xvec => x%vec)
+           type is (character(*))
+             if (any(xvec /= vec)) stop stop_flag
+           type is (integer)
+             if (any(xvec /= (vec1))) stop stop_flag
+         end select
+     end select
+   end
+ end program