Skip to content

R
riscv-gcc-1
Commit da46c08e by Paul Thomas
Options

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
parent 6bb45a6b
Showing with 58 additions and 39 deletions
gcc/fortran/ChangeLog
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
* expr.c (is_subref_array): Move the check for class pointer
dummy arrays to after the reference check. If we haven't seen
......
gcc/fortran/trans-array.c
......@@ -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);
{
gfc_conv_descriptor_offset_set (&set_descriptor_block, se->expr, offset);
tmp = fold_convert (gfc_array_index_type, element_size);
gfc_conv_descriptor_span_set (&set_descriptor_block, se->expr, tmp);
}
......
gcc/testsuite/ChangeLog
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
* gfortran.dg/pointer_array_component_3.f90 : New test.
......
gcc/testsuite/gfortran.dg/realloc_on_assign_32.f90 0 → 100644
! { 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
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment