Commit da46c08e by Paul Thomas

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
2019-02-02 Paul Thomas <pault@gcc.gnu.org> 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 PR fortran/88685
* expr.c (is_subref_array): Move the check for class pointer * expr.c (is_subref_array): Move the check for class pointer
dummy arrays to after the reference check. If we haven't seen dummy arrays to after the reference check. If we haven't seen
......
...@@ -5370,14 +5370,14 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, ...@@ -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, gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock,
stmtblock_t * descriptor_block, tree * overflow, stmtblock_t * descriptor_block, tree * overflow,
tree expr3_elem_size, tree *nelems, gfc_expr *expr3, 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 type;
tree tmp; tree tmp;
tree size; tree size;
tree offset; tree offset;
tree stride; tree stride;
tree element_size;
tree or_expr; tree or_expr;
tree thencase; tree thencase;
tree elsecase; tree elsecase;
...@@ -5628,10 +5628,10 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, ...@@ -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)); tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
/* Convert to size_t. */ /* Convert to size_t. */
element_size = fold_convert (size_type_node, tmp); *element_size = fold_convert (size_type_node, tmp);
if (rank == 0) if (rank == 0)
return element_size; return *element_size;
*nelems = gfc_evaluate_now (stride, pblock); *nelems = gfc_evaluate_now (stride, pblock);
stride = fold_convert (size_type_node, stride); stride = fold_convert (size_type_node, stride);
...@@ -5641,14 +5641,14 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, ...@@ -5641,14 +5641,14 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
dividing. */ dividing. */
tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
size_type_node, 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, cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR,
logical_type_node, tmp, stride), logical_type_node, tmp, stride),
PRED_FORTRAN_OVERFLOW); PRED_FORTRAN_OVERFLOW);
tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond, tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
integer_one_node, integer_zero_node); integer_one_node, integer_zero_node);
cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR, 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)), build_int_cst (size_type_node, 0)),
PRED_FORTRAN_SIZE_ZERO); PRED_FORTRAN_SIZE_ZERO);
tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond, 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, ...@@ -5658,7 +5658,7 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
*overflow = gfc_evaluate_now (tmp, pblock); *overflow = gfc_evaluate_now (tmp, pblock);
size = fold_build2_loc (input_location, MULT_EXPR, size_type_node, size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
stride, element_size); stride, *element_size);
if (poffset != NULL) if (poffset != NULL)
{ {
...@@ -5736,6 +5736,7 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, ...@@ -5736,6 +5736,7 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
tree var_overflow = NULL_TREE; tree var_overflow = NULL_TREE;
tree cond; tree cond;
tree set_descriptor; tree set_descriptor;
tree element_size = NULL_TREE;
stmtblock_t set_descriptor_block; stmtblock_t set_descriptor_block;
stmtblock_t elseblock; stmtblock_t elseblock;
gfc_expr **lower; gfc_expr **lower;
...@@ -5852,7 +5853,7 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, ...@@ -5852,7 +5853,7 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
&offset, lower, upper, &offset, lower, upper,
&se->pre, &set_descriptor_block, &overflow, &se->pre, &set_descriptor_block, &overflow,
expr3_elem_size, nelems, expr3, e3_arr_desc, expr3_elem_size, nelems, expr3, e3_arr_desc,
e3_has_nodescriptor, expr); e3_has_nodescriptor, expr, &element_size);
if (dimension) if (dimension)
{ {
...@@ -5924,38 +5925,11 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, ...@@ -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); gfc_add_expr_to_block (&se->pre, tmp);
/* Update the array descriptors. */ /* Update the array descriptor with the offset and the span. */
if (dimension) if (dimension)
gfc_conv_descriptor_offset_set (&set_descriptor_block, se->expr, offset); {
gfc_conv_descriptor_offset_set (&set_descriptor_block, se->expr, offset);
/* Set the span field for pointer and deferred length character arrays. */ tmp = fold_convert (gfc_array_index_type, element_size);
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_span_set (&set_descriptor_block, se->expr, tmp); gfc_conv_descriptor_span_set (&set_descriptor_block, se->expr, tmp);
} }
......
2019-02-02 Paul Thomas <pault@gcc.gnu.org> 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 PR fortran/88685
* gfortran.dg/pointer_array_component_3.f90 : New test. * gfortran.dg/pointer_array_component_3.f90 : New test.
......
! { 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