+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>
PR fortran/66128
* simplify.c (is_size_zero_array): New function to check for size
zero array.
- (gfc_simplify_all, gfc_simplify_any, gfc_simplify_count,
+ (gfc_simplify_all, gfc_simplify_any, gfc_simplify_count,
gfc_simplify_iall, gfc_simplify_iany, gfc_simplify_iparity,
gfc_simplify_minval, gfc_simplify_maxval, gfc_simplify_norm2,
gfc_simplify_product, gfc_simplify_sum): Use it, and implement
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
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);
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);
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);
+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
--- /dev/null
+! { 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
projects / platform / upstream / gcc.git / commitdiff