[gcc r11-7362] Fortran: Fix memory problems with assumed rank formal args [PR98342].
Paul Thomas
pault@gcc.gnu.org
Wed Feb 24 16:01:22 GMT 2021
https://gcc.gnu.org/g:5159b88ef1a1774ec8851c6b92794ae2bf6e0b74
commit r11-7362-g5159b88ef1a1774ec8851c6b92794ae2bf6e0b74
Author: Paul Thomas <pault@gcc.gnu.org>
Date: Wed Feb 24 16:00:51 2021 +0000
Fortran: Fix memory problems with assumed rank formal args [PR98342].
2021-02-24 Paul Thomas <pault@gcc.gnu.org>
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:
---
gcc/fortran/trans-expr.c | 40 +++++++++--
gcc/fortran/trans.h | 2 +-
gcc/testsuite/gfortran.dg/assumed_rank_21.f90 | 96 +++++++++++++++++++++++++++
3 files changed, 131 insertions(+), 7 deletions(-)
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index e61492485b8..85c16d7f4c3 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 1e4ab39cb89..44cbfb63f39 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 00000000000..ef5edbfb6ed
--- /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 <mscfd@gmx.net>
+!
+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
More information about the Gcc-cvs
mailing list