re PR fortran/88980 (segfault on allocatable string member assignment)
2019-02-02 Paul Thomas <pault@gcc.gnu.org> PR fortran/88980 * trans-array.c (gfc_array_init_size): Add element_size to the arguments. (gfc_array_allocate): Remove the recalculation of the size of the element and use element_size from the call to the above. Unconditionally set the span field of the descriptor. 2019-02-02 Paul Thomas <pault@gcc.gnu.org> PR fortran/88980 * gfortran.dg/realloc_on_assign_32.f90 : New test. From-SVN: r268473
This commit is contained in:
parent
6bb45a6b52
commit
da46c08e8b
|
@ -1,3 +1,12 @@
|
|||
2019-02-02 Paul Thomas <pault@gcc.gnu.org>
|
||||
|
||||
PR fortran/88980
|
||||
* trans-array.c (gfc_array_init_size): Add element_size to the
|
||||
arguments.
|
||||
(gfc_array_allocate): Remove the recalculation of the size of
|
||||
the element and use element_size from the call to the above.
|
||||
Unconditionally set the span field of the descriptor.
|
||||
|
||||
2019-02-02 Paul Thomas <pault@gcc.gnu.org>
|
||||
|
||||
PR fortran/88685
|
||||
|
|
|
@ -5370,14 +5370,14 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
|
|||
gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock,
|
||||
stmtblock_t * descriptor_block, tree * overflow,
|
||||
tree expr3_elem_size, tree *nelems, gfc_expr *expr3,
|
||||
tree expr3_desc, bool e3_has_nodescriptor, gfc_expr *expr)
|
||||
tree expr3_desc, bool e3_has_nodescriptor, gfc_expr *expr,
|
||||
tree *element_size)
|
||||
{
|
||||
tree type;
|
||||
tree tmp;
|
||||
tree size;
|
||||
tree offset;
|
||||
tree stride;
|
||||
tree element_size;
|
||||
tree or_expr;
|
||||
tree thencase;
|
||||
tree elsecase;
|
||||
|
@ -5628,10 +5628,10 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
|
|||
tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
|
||||
|
||||
/* Convert to size_t. */
|
||||
element_size = fold_convert (size_type_node, tmp);
|
||||
*element_size = fold_convert (size_type_node, tmp);
|
||||
|
||||
if (rank == 0)
|
||||
return element_size;
|
||||
return *element_size;
|
||||
|
||||
*nelems = gfc_evaluate_now (stride, pblock);
|
||||
stride = fold_convert (size_type_node, stride);
|
||||
|
@ -5641,14 +5641,14 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
|
|||
dividing. */
|
||||
tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
|
||||
size_type_node,
|
||||
TYPE_MAX_VALUE (size_type_node), element_size);
|
||||
TYPE_MAX_VALUE (size_type_node), *element_size);
|
||||
cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR,
|
||||
logical_type_node, tmp, stride),
|
||||
PRED_FORTRAN_OVERFLOW);
|
||||
tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
|
||||
integer_one_node, integer_zero_node);
|
||||
cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR,
|
||||
logical_type_node, element_size,
|
||||
logical_type_node, *element_size,
|
||||
build_int_cst (size_type_node, 0)),
|
||||
PRED_FORTRAN_SIZE_ZERO);
|
||||
tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
|
||||
|
@ -5658,7 +5658,7 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
|
|||
*overflow = gfc_evaluate_now (tmp, pblock);
|
||||
|
||||
size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
|
||||
stride, element_size);
|
||||
stride, *element_size);
|
||||
|
||||
if (poffset != NULL)
|
||||
{
|
||||
|
@ -5736,6 +5736,7 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
|
|||
tree var_overflow = NULL_TREE;
|
||||
tree cond;
|
||||
tree set_descriptor;
|
||||
tree element_size = NULL_TREE;
|
||||
stmtblock_t set_descriptor_block;
|
||||
stmtblock_t elseblock;
|
||||
gfc_expr **lower;
|
||||
|
@ -5852,7 +5853,7 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
|
|||
&offset, lower, upper,
|
||||
&se->pre, &set_descriptor_block, &overflow,
|
||||
expr3_elem_size, nelems, expr3, e3_arr_desc,
|
||||
e3_has_nodescriptor, expr);
|
||||
e3_has_nodescriptor, expr, &element_size);
|
||||
|
||||
if (dimension)
|
||||
{
|
||||
|
@ -5924,38 +5925,11 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
|
|||
|
||||
gfc_add_expr_to_block (&se->pre, tmp);
|
||||
|
||||
/* Update the array descriptors. */
|
||||
/* Update the array descriptor with the offset and the span. */
|
||||
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)
|
||||
{
|
||||
tmp = build_int_cst (gfc_array_index_type, expr->ts.kind);
|
||||
tmp = fold_build2_loc (input_location, MULT_EXPR,
|
||||
gfc_array_index_type, tmp,
|
||||
fold_convert (gfc_array_index_type,
|
||||
se->string_length));
|
||||
}
|
||||
else
|
||||
tmp = se->string_length;
|
||||
}
|
||||
else
|
||||
tmp = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (se->expr)));
|
||||
tmp = fold_convert (gfc_array_index_type, tmp);
|
||||
tmp = fold_convert (gfc_array_index_type, element_size);
|
||||
gfc_conv_descriptor_span_set (&set_descriptor_block, se->expr, tmp);
|
||||
}
|
||||
|
||||
|
|
|
@ -1,3 +1,8 @@
|
|||
2019-02-02 Paul Thomas <pault@gcc.gnu.org>
|
||||
|
||||
PR fortran/88980
|
||||
* gfortran.dg/realloc_on_assign_32.f90 : New test.
|
||||
|
||||
2019-02-02 Paul Thomas <pault@gcc.gnu.org>
|
||||
|
||||
PR fortran/88685
|
||||
|
|
|
@ -0,0 +1,31 @@
|
|||
! { dg-do run }
|
||||
!
|
||||
! Test the fix for PR88980 in which the 'span' field if the descriptor
|
||||
! for 'Items' was not set, causing the assignment to segfault.
|
||||
!
|
||||
! Contributed by Antony Lewis <antony@cosmologist.info>
|
||||
!
|
||||
program tester
|
||||
call gbug
|
||||
contains
|
||||
subroutine gbug
|
||||
type TNameValue
|
||||
character(LEN=:), allocatable :: Name
|
||||
end type TNameValue
|
||||
|
||||
type TNameValue_pointer
|
||||
Type(TNameValue), allocatable :: P
|
||||
end type TNameValue_pointer
|
||||
|
||||
Type TType
|
||||
type(TNameValue_pointer), dimension(:), allocatable :: Items
|
||||
end type TType
|
||||
Type(TType) T
|
||||
|
||||
allocate(T%Items(2))
|
||||
allocate(T%Items(2)%P)
|
||||
T%Items(2)%P%Name = 'test'
|
||||
if (T%Items(2)%P%Name .ne. 'test') stop 1
|
||||
|
||||
end subroutine gbug
|
||||
end program tester
|
Loading…
Reference in New Issue