Fixing the different variants of this PR was somewhat like drawing teeth.
Fixing the scalar problem with derived type and class formal arguments was
straightforward. However, the need to strip NOPS for scalar unlimited
polymorphic arguments was less than obvious. Even less obvious was the
problem with unlimited polymorphic arrays, which required the use of the
'derived_array' argument of gfc_conv_derived_to_class because the code
looked just fine. Evidently, the convoluted casting in expressions like:
(integer(kind=4)[0:] * restrict) (*(void *[0:] *)
D.4413->_data.data)[S.61]->t.data
is the cause. I have seen this kind of problem with unlimited polymorphic
expressions previously. The fix re-renders them as:
(integer(kind=4)[0:] * restrict) (*(struct tuple[1] * restrict)
array.46.data)[S.47].t.data
Regtests on FC33/x86_64
OK for master (and maybe for 10-branch?)
Paul
Fortran: Fix memory problems with assumed rank formal args [PR98342].
2021-01-29 Paul Thomas <pa...@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_20.f90 : New test.
! { dg-do run }
!
! Test the fix for PR98342.
!
! Contributed by Martin Stein <ms...@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(1)
x = [1,2,3]
! 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([get_tuple(x)]) ! 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([get_tuple(x)]) ! 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([get_tuple(x)]) ! runtime: segmentation fault
if (output .ne. '31') stop 6
deallocate(output)
end program alloc_rank
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index b0c8d577ca5..2e804566786 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)
@@ -6593,6 +6609,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
@@ -6608,9 +6630,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);
