From da46c08e8b857d8ffc2332689e19c5277d25e7fd Mon Sep 17 00:00:00 2001 From: Paul Thomas Date: Sat, 2 Feb 2019 09:16:44 +0000 Subject: [PATCH] re PR fortran/88980 (segfault on allocatable string member assignment) 2019-02-02 Paul Thomas 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 PR fortran/88980 * gfortran.dg/realloc_on_assign_32.f90 : New test. From-SVN: r268473 --- gcc/fortran/ChangeLog | 9 ++++ gcc/fortran/trans-array.c | 52 +++++-------------- gcc/testsuite/ChangeLog | 5 ++ .../gfortran.dg/realloc_on_assign_32.f90 | 31 +++++++++++ 4 files changed, 58 insertions(+), 39 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/realloc_on_assign_32.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 1dc007d1a2e..6dba135459f 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,12 @@ +2019-02-02 Paul Thomas + + 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 PR fortran/88685 diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 6d7c3d22154..b885fe6187d 100644 --- a/gcc/fortran/trans-array.c +++ b/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); } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index bc9ca4c289c..d94a3be1746 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2019-02-02 Paul Thomas + + PR fortran/88980 + * gfortran.dg/realloc_on_assign_32.f90 : New test. + 2019-02-02 Paul Thomas PR fortran/88685 diff --git a/gcc/testsuite/gfortran.dg/realloc_on_assign_32.f90 b/gcc/testsuite/gfortran.dg/realloc_on_assign_32.f90 new file mode 100644 index 00000000000..31a0d767711 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/realloc_on_assign_32.f90 @@ -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 +! +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 -- 2.30.2