From: Paul Thomas Date: Wed, 24 Feb 2021 16:00:51 +0000 (+0000) Subject: Fortran: Fix memory problems with assumed rank formal args [PR98342]. X-Git-Tag: basepoints/gcc-12~895 X-Git-Url: http://git.ipfire.org/?a=commitdiff_plain;h=5159b88ef1a1774ec8851c6b92794ae2bf6e0b74;p=thirdparty%2Fgcc.git Fortran: Fix memory problems with assumed rank formal args [PR98342]. 2021-02-24 Paul Thomas gcc/fortran PR fortran/98342 * trans-expr.c (gfc_conv_derived_to_class): Add optional arg. 'derived_array' to hold the fixed, parmse expr in the case of assumed rank formal arguments. Deal with optional arguments. (gfc_conv_procedure_call): Null 'derived' array for each actual argument. Add its address to the call to gfc_conv_derived_to_ class. Access the 'data' field of scalar descriptors before deallocating allocatable components. Also strip NOPs before the calls to gfc_deallocate_alloc_comp. Use 'derived' array as the input to gfc_deallocate_alloc_comp if it is available. * trans.h : Include the optional argument 'derived_array' to the prototype of gfc_conv_derived_to_class. The default value is NULL_TREE. gcc/testsuite/ PR fortran/98342 * gfortran.dg/assumed_rank_21.f90 : New test. --- diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index e61492485b82..85c16d7f4c3d 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -613,11 +613,15 @@ class_array_data_assign (stmtblock_t *block, tree lhs_desc, tree rhs_desc, class object of the 'declared' type. If vptr is not NULL, this is used for the temporary class object. optional_alloc_ptr is false when the dummy is neither allocatable - nor a pointer; that's only relevant for the optional handling. */ + nor a pointer; that's only relevant for the optional handling. + The optional argument 'derived_array' is used to preserve the parmse + expression for deallocation of allocatable components. Assumed rank + formal arguments made this necessary. */ void gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts, tree vptr, bool optional, - bool optional_alloc_ptr) + bool optional_alloc_ptr, + tree *derived_array) { gfc_symbol *vtab; tree cond_optional = NULL_TREE; @@ -747,6 +751,13 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, { gcc_assert (class_ts.u.derived->components->as->type == AS_ASSUMED_RANK); + if (derived_array + && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (parmse->expr))) + { + *derived_array = gfc_create_var (TREE_TYPE (parmse->expr), + "array"); + gfc_add_modify (&block, *derived_array , parmse->expr); + } class_array_data_assign (&block, ctree, parmse->expr, false); } else @@ -765,6 +776,9 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, gfc_init_block (&block); gfc_conv_descriptor_data_set (&block, ctree, null_pointer_node); + if (derived_array && *derived_array != NULL_TREE) + gfc_conv_descriptor_data_set (&block, *derived_array, + null_pointer_node); tmp = build3_v (COND_EXPR, cond_optional, tmp, gfc_finish_block (&block)); @@ -5665,6 +5679,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, { bool finalized = false; bool non_unity_length_string = false; + tree derived_array = NULL_TREE; e = arg->expr; fsym = formal ? formal->sym : NULL; @@ -5770,7 +5785,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, && e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional, CLASS_DATA (fsym)->attr.class_pointer - || CLASS_DATA (fsym)->attr.allocatable); + || CLASS_DATA (fsym)->attr.allocatable, + &derived_array); } else if (UNLIMITED_POLY (fsym) && e->ts.type != BT_CLASS && gfc_expr_attr (e).flavor != FL_PROCEDURE) @@ -6595,6 +6611,12 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, && parm_rank == 0 && parmse.loop; + /* Scalars passed to an assumed rank argument are converted to + a descriptor. Obtain the data field before deallocating any + allocatable components. */ + if (parm_rank == 0 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp))) + tmp = gfc_conv_descriptor_data_get (tmp); + if (scalar_res_outside_loop) { /* Go through the ss chain to find the argument and use @@ -6610,9 +6632,15 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, } } - if ((e->ts.type == BT_CLASS - && GFC_CLASS_TYPE_P (TREE_TYPE (tmp))) - || e->ts.type == BT_DERIVED) + STRIP_NOPS (tmp); + + if (derived_array != NULL_TREE) + tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, + derived_array, + parm_rank); + else if ((e->ts.type == BT_CLASS + && GFC_CLASS_TYPE_P (TREE_TYPE (tmp))) + || e->ts.type == BT_DERIVED) tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp, parm_rank); else if (e->ts.type == BT_CLASS) diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 1e4ab39cb89d..44cbfb63f392 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -452,7 +452,7 @@ bool gfc_add_finalizer_call (stmtblock_t *, gfc_expr *); bool gfc_add_comp_finalizer_call (stmtblock_t *, tree, gfc_component *, bool); void gfc_conv_derived_to_class (gfc_se *, gfc_expr *, gfc_typespec, tree, bool, - bool); + bool, tree *derived_array = NULL); void gfc_conv_class_to_class (gfc_se *, gfc_expr *, gfc_typespec, bool, bool, bool, bool); diff --git a/gcc/testsuite/gfortran.dg/assumed_rank_21.f90 b/gcc/testsuite/gfortran.dg/assumed_rank_21.f90 new file mode 100644 index 000000000000..ef5edbfb6ed1 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/assumed_rank_21.f90 @@ -0,0 +1,96 @@ +! { dg-do run } +! +! Test the fix for PR98342. +! +! Contributed by Martin Stein +! +module mod + implicit none + private + public get_tuple, sel_rank1, sel_rank2, sel_rank3 + + type, public :: tuple + integer, dimension(:), allocatable :: t +end type tuple + +contains + +function sel_rank1(x) result(s) + character(len=:), allocatable :: s + type(tuple), dimension(..), intent(in) :: x + select rank (x) + rank (0) + s = '10' + rank (1) + s = '11' + rank default + s = '?' + end select +end function sel_rank1 + +function sel_rank2(x) result(s) + character(len=:), allocatable :: s + class(tuple), dimension(..), intent(in) :: x + select rank (x) + rank (0) + s = '20' + rank (1) + s = '21' + rank default + s = '?' + end select +end function sel_rank2 + +function sel_rank3(x) result(s) + character(len=:), allocatable :: s + class(*), dimension(..), intent(in) :: x + select rank (x) + rank (0) + s = '30' + rank (1) + s = '31' + rank default + s = '?' + end select +end function sel_rank3 + +function get_tuple(t) result(a) + type(tuple) :: a + integer, dimension(:), intent(in) :: t + allocate(a%t, source=t) +end function get_tuple + +end module mod + + +program alloc_rank + use mod + implicit none + + integer, dimension(1:3) :: x + character(len=:), allocatable :: output + type(tuple) :: z + + x = [1,2,3] + z = get_tuple (x) + ! Derived type formal arg + output = sel_rank1(get_tuple (x)) ! runtime: Error in `./alloc_rank.x': + if (output .ne. '10') stop 1 + output = sel_rank1([z]) ! This worked OK + if (output .ne. '11') stop 2 + + ! Class formal arg + output = sel_rank2(get_tuple (x)) ! runtime: Error in `./alloc_rank.x': + if (output .ne. '20') stop 3 + output = sel_rank2([z]) ! This worked OK + if (output .ne. '21') stop 4 + + ! Unlimited polymorphic formal arg + output = sel_rank3(get_tuple (x)) ! runtime: Error in `./alloc_rank.x': + if (output .ne. '30') stop 5 + output = sel_rank3([z]) ! runtime: segmentation fault + if (output .ne. '31') stop 6 + + deallocate (output) + deallocate (z%t) +end program alloc_rank