FreeChainXenon/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

re PR fortran/84546 (Bad sourced allocation of CLASS(*) with source with CLASS(*) component)

Browse source 
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.

From-SVN: r258438
This commit is contained in:
Paul Thomas 2018-03-11 22:25:11 +00:00
parent 1813c97a6f
commit 26219cee84
6 changed files with 154 additions and 12 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

10
gcc/fortran/ChangeLog
View file

@ -1,3 +1,13 @@
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 Steven G. Kargl <kargl@gcc.gnu.org>

25
gcc/fortran/trans-array.c
View file

@ -8883,6 +8883,31 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
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

38
gcc/fortran/trans-expr.c
View file

@ -1185,15 +1185,32 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
of the referenced element. */
tree
gfc_get_class_array_ref (tree index, tree class_decl, tree data_comp)
gfc_get_class_array_ref (tree index, tree class_decl, tree data_comp,
bool unlimited)
{
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;
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);
@ -1295,14 +1312,15 @@ gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited)
if (is_from_desc)
{
from_ref = gfc_get_class_array_ref (index, from, from_data);
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);
to_ref = gfc_get_class_array_ref (index, to, to_data, unlimited);
else
{
tmp = gfc_conv_array_data (to);

2
gcc/fortran/trans.h
View file

@ -431,7 +431,7 @@ tree gfc_vptr_deallocate_get (tree);
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_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);

5
gcc/testsuite/ChangeLog
View file

@ -1,3 +1,8 @@
2018-03-11 Paul Thomas <pault@gcc.gnu.org>
PR fortran/84546
* gfortran.dg/unlimited_polymorphic_29.f90 : New test.
2018-03-11 Steven G. Kargl <kargl@gcc.gnu.org>
PR fortran/83939

84
gcc/testsuite/gfortran.dg/unlimited_polymorphic_29.f90 Normal file
View file

@ -0,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