* [Patch, fortran] PR84546 - [7/8 Regression] Bad sourced allocation of CLASS(*) with source with CLASS(*) component
@ 2018-03-11 19:24 Paul Richard Thomas
2018-03-11 19:35 ` Jerry DeLisle
0 siblings, 1 reply; 2+ messages in thread
From: Paul Richard Thomas @ 2018-03-11 19:24 UTC (permalink / raw)
To: fortran, gcc-patches
[-- Attachment #1: Type: text/plain, Size: 974 bytes --]
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.
[-- Attachment #2: submit.diff --]
[-- Type: text/x-patch, Size: 7402 bytes --]
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
^ permalink raw reply [flat|nested] 2+ messages in thread
* Re: [Patch, fortran] PR84546 - [7/8 Regression] Bad sourced allocation of CLASS(*) with source with CLASS(*) component
2018-03-11 19:24 [Patch, fortran] PR84546 - [7/8 Regression] Bad sourced allocation of CLASS(*) with source with CLASS(*) component Paul Richard Thomas
@ 2018-03-11 19:35 ` Jerry DeLisle
0 siblings, 0 replies; 2+ messages in thread
From: Jerry DeLisle @ 2018-03-11 19:35 UTC (permalink / raw)
To: Paul Richard Thomas, fortran, gcc-patches
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.
>
^ permalink raw reply [flat|nested] 2+ messages in thread
end of thread, other threads:[~2018-03-11 19:35 UTC | newest]
Thread overview: 2+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2018-03-11 19:24 [Patch, fortran] PR84546 - [7/8 Regression] Bad sourced allocation of CLASS(*) with source with CLASS(*) component Paul Richard Thomas
2018-03-11 19:35 ` Jerry DeLisle
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).