}
+/* This function tells whether the middle-end representation of the expression
+ E given as input may point to data otherwise accessible through a variable
+ (sub-)reference.
+ It is assumed that the only expressions that may alias are variables,
+ and array constructors if ARRAY_MAY_ALIAS is true and some of its elements
+ may alias.
+ This function is used to decide whether freeing an expression's allocatable
+ components is safe or should be avoided.
+
+ If ARRAY_MAY_ALIAS is true, an array constructor may alias if some of
+ its elements are copied from a variable. This ARRAY_MAY_ALIAS trick
+ is necessary because for array constructors, aliasing depends on how
+ the array is used:
+ - If E is an array constructor used as argument to an elemental procedure,
+ the array, which is generated through shallow copy by the scalarizer,
+ is used directly and can alias the expressions it was copied from.
+ - If E is an array constructor used as argument to a non-elemental
+ procedure,the scalarizer is used in gfc_conv_expr_descriptor to generate
+ the array as in the previous case, but then that array is used
+ to initialize a new descriptor through deep copy. There is no alias
+ possible in that case.
+ Thus, the ARRAY_MAY_ALIAS flag is necessary to distinguish the two cases
+ above. */
+
+static bool
+expr_may_alias_variables (gfc_expr *e, bool array_may_alias)
+{
+ gfc_constructor *c;
+
+ if (e->expr_type == EXPR_VARIABLE)
+ return true;
+ else if (e->expr_type == EXPR_FUNCTION)
+ {
+ gfc_symbol *proc_ifc = gfc_get_proc_ifc_for_expr (e);
+
+ if ((proc_ifc->result->ts.type == BT_CLASS
+ && proc_ifc->result->ts.u.derived->attr.is_class
+ && CLASS_DATA (proc_ifc->result)->attr.class_pointer)
+ || proc_ifc->result->attr.pointer)
+ return true;
+ else
+ return false;
+ }
+ else if (e->expr_type != EXPR_ARRAY || !array_may_alias)
+ return false;
+
+ for (c = gfc_constructor_first (e->value.constructor);
+ c; c = gfc_constructor_next (c))
+ if (c->expr
+ && expr_may_alias_variables (c->expr, array_may_alias))
+ return true;
+
+ return false;
+}
+
+
/* Generate code for a procedure call. Note can return se->post != NULL.
If se->direct_byref is set then se->expr contains the return parameter.
Return nonzero, if the call has alternate specifiers.
comp = gfc_get_proc_ptr_comp (expr);
+ bool elemental_proc = (comp
+ && comp->ts.interface
+ && comp->ts.interface->attr.elemental)
+ || (comp && comp->attr.elemental)
+ || sym->attr.elemental;
+
if (se->ss != NULL)
{
- if (!sym->attr.elemental && !(comp && comp->attr.elemental))
+ if (!elemental_proc)
{
gcc_assert (se->ss->info->type == GFC_SS_FUNCTION);
if (se->ss->info->useflags)
fsym = formal ? formal->sym : NULL;
parm_kind = MISSING;
+ /* If the procedure requires an explicit interface, the actual
+ argument is passed according to the corresponding formal
+ argument. If the corresponding formal argument is a POINTER,
+ ALLOCATABLE or assumed shape, we do not use g77's calling
+ convention, and pass the address of the array descriptor
+ instead. Otherwise we use g77's calling convention, in other words
+ pass the array data pointer without descriptor. */
+ bool nodesc_arg = fsym != NULL
+ && !(fsym->attr.pointer || fsym->attr.allocatable)
+ && fsym->as
+ && fsym->as->type != AS_ASSUMED_SHAPE
+ && fsym->as->type != AS_ASSUMED_RANK;
+ if (comp)
+ nodesc_arg = nodesc_arg || !comp->attr.always_explicit;
+ else
+ nodesc_arg = nodesc_arg || !sym->attr.always_explicit;
+
/* Class array expressions are sometimes coming completely unadorned
with either arrayspec or _data component. Correct that here.
OOP-TODO: Move this to the frontend. */
}
else
{
- /* If the procedure requires an explicit interface, the actual
- argument is passed according to the corresponding formal
- argument. If the corresponding formal argument is a POINTER,
- ALLOCATABLE or assumed shape, we do not use g77's calling
- convention, and pass the address of the array descriptor
- instead. Otherwise we use g77's calling convention. */
- bool f;
- f = (fsym != NULL)
- && !(fsym->attr.pointer || fsym->attr.allocatable)
- && fsym->as && fsym->as->type != AS_ASSUMED_SHAPE
- && fsym->as->type != AS_ASSUMED_RANK;
- if (comp)
- f = f || !comp->attr.always_explicit;
- else
- f = f || !sym->attr.always_explicit;
-
/* If the argument is a function call that may not create
a temporary for the result, we have to check that we
can do it, i.e. that there is no alias between this
array of derived types. In this case, the argument
is converted to a temporary, which is passed and then
written back after the procedure call. */
- gfc_conv_subref_array_arg (&parmse, e, f,
+ gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
fsym ? fsym->attr.intent : INTENT_INOUT,
fsym && fsym->attr.pointer);
else if (gfc_is_class_array_ref (e, NULL)
OOP-TODO: Insert code so that if the dynamic type is
the same as the declared type, copy-in/copy-out does
not occur. */
- gfc_conv_subref_array_arg (&parmse, e, f,
+ gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
fsym ? fsym->attr.intent : INTENT_INOUT,
fsym && fsym->attr.pointer);
intent in. */
{
e->must_finalize = 1;
- gfc_conv_subref_array_arg (&parmse, e, f,
+ gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
INTENT_IN,
fsym && fsym->attr.pointer);
}
else
- gfc_conv_array_parameter (&parmse, e, f, fsym, sym->name, NULL);
+ gfc_conv_array_parameter (&parmse, e, nodesc_arg, fsym,
+ sym->name, NULL);
/* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
allocated on entry, it must be deallocated. */
but do not always set fsym. */
if (e->expr_type == EXPR_VARIABLE
&& e->symtree->n.sym->attr.optional
- && ((e->rank != 0 && sym->attr.elemental)
+ && ((e->rank != 0 && elemental_proc)
|| e->representation.length || e->ts.type == BT_CHARACTER
|| (e->rank != 0
&& (fsym == NULL
gfc_add_block_to_block (&post, &parmse.post);
/* Allocated allocatable components of derived types must be
- deallocated for non-variable scalars. Non-variable arrays are
- dealt with in trans-array.c(gfc_conv_array_parameter). */
+ deallocated for non-variable scalars, array arguments to elemental
+ procedures, and array arguments with descriptor to non-elemental
+ procedures. As bounds information for descriptorless arrays is no
+ longer available here, they are dealt with in trans-array.c
+ (gfc_conv_array_parameter). */
if (e && (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS)
&& e->ts.u.derived->attr.alloc_comp
- && !(e->symtree && e->symtree->n.sym->attr.pointer)
- && e->expr_type != EXPR_VARIABLE && !e->rank)
- {
+ && (e->rank == 0 || elemental_proc || !nodesc_arg)
+ && !expr_may_alias_variables (e, elemental_proc))
+ {
int parm_rank;
/* It is known the e returns a structure type with at least one
allocatable component. When e is a function, ensure that the
gfc_conv_expr (&rse, expr);
- tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false, true);
+ tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, true, true);
gfc_add_expr_to_block (&body, tmp);
gcc_assert (rse.ss == gfc_ss_terminator);
/* Take the address of that value. */
se->expr = gfc_build_addr_expr (NULL_TREE, var);
- if (expr->ts.type == BT_DERIVED && expr->rank
- && !gfc_is_finalizable (expr->ts.u.derived, NULL)
- && expr->ts.u.derived->attr.alloc_comp
- && expr->expr_type != EXPR_VARIABLE)
- {
- tree tmp;
-
- tmp = build_fold_indirect_ref_loc (input_location, se->expr);
- tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, tmp, expr->rank);
-
- /* The components shall be deallocated before
- their containing entity. */
- gfc_prepend_expr_to_block (&se->post, tmp);
- }
}
--- /dev/null
+! { dg-do run }
+! { dg-additional-options "-fsanitize=address -fdump-tree-original"
+!
+! PR fortran/61831
+! The deallocation of components of array constructor elements
+! used to have the side effect of also deallocating some other
+! variable's components from which they were copied.
+
+program main
+ implicit none
+
+ integer, parameter :: n = 2
+
+ type :: string_t
+ character(LEN=1), dimension(:), allocatable :: chars
+ end type string_t
+
+ type :: string_container_t
+ type(string_t) :: comp
+ end type string_container_t
+
+ type :: string_array_container_t
+ type(string_t) :: comp(n)
+ end type string_array_container_t
+
+ type(string_t) :: prt_in, tmp, tmpa(n)
+ type(string_container_t) :: tmpc, tmpca(n)
+ type(string_array_container_t) :: tmpac, tmpaca(n)
+ integer :: i, j, k
+
+ do i=1,16
+
+ ! Test without intermediary function
+ prt_in = string_t(["A"])
+ if (.not. allocated(prt_in%chars)) call abort
+ if (any(prt_in%chars .ne. "A")) call abort
+ deallocate (prt_in%chars)
+
+ ! scalar elemental function
+ prt_in = string_t(["B"])
+ if (.not. allocated(prt_in%chars)) call abort
+ if (any(prt_in%chars .ne. "B")) call abort
+ tmp = new_prt_spec (prt_in)
+ if (.not. allocated(prt_in%chars)) call abort
+ if (any(prt_in%chars .ne. "B")) call abort
+ deallocate (prt_in%chars)
+ deallocate (tmp%chars)
+
+ ! array elemental function with array constructor
+ prt_in = string_t(["C"])
+ if (.not. allocated(prt_in%chars)) call abort
+ if (any(prt_in%chars .ne. "C")) call abort
+ tmpa = new_prt_spec ([(prt_in, i=1,2)])
+ if (.not. allocated(prt_in%chars)) call abort
+ if (any(prt_in%chars .ne. "C")) call abort
+ deallocate (prt_in%chars)
+ do j=1,n
+ deallocate (tmpa(j)%chars)
+ end do
+
+ ! scalar elemental function with structure constructor
+ prt_in = string_t(["D"])
+ if (.not. allocated(prt_in%chars)) call abort
+ if (any(prt_in%chars .ne. "D")) call abort
+ tmpc = new_prt_spec2 (string_container_t(prt_in))
+ if (.not. allocated(prt_in%chars)) call abort
+ if (any(prt_in%chars .ne. "D")) call abort
+ deallocate (prt_in%chars)
+ deallocate(tmpc%comp%chars)
+
+ ! array elemental function of an array constructor of structure constructors
+ prt_in = string_t(["E"])
+ if (.not. allocated(prt_in%chars)) call abort
+ if (any(prt_in%chars .ne. "E")) call abort
+ tmpca = new_prt_spec2 ([ (string_container_t(prt_in), i=1,2) ])
+ if (.not. allocated(prt_in%chars)) call abort
+ if (any(prt_in%chars .ne. "E")) call abort
+ deallocate (prt_in%chars)
+ do j=1,n
+ deallocate (tmpca(j)%comp%chars)
+ end do
+
+ ! scalar elemental function with a structure constructor and a nested array constructor
+ prt_in = string_t(["F"])
+ if (.not. allocated(prt_in%chars)) call abort
+ if (any(prt_in%chars .ne. "F")) call abort
+ tmpac = new_prt_spec3 (string_array_container_t([ (prt_in, i=1,2) ]))
+ if (.not. allocated(prt_in%chars)) call abort
+ if (any(prt_in%chars .ne. "F")) call abort
+ deallocate (prt_in%chars)
+ do j=1,n
+ deallocate (tmpac%comp(j)%chars)
+ end do
+
+ ! array elemental function with an array constructor nested inside
+ ! a structure constructor nested inside an array constructor
+ prt_in = string_t(["G"])
+ if (.not. allocated(prt_in%chars)) call abort
+ if (any(prt_in%chars .ne. "G")) call abort
+ tmpaca = new_prt_spec3 ([ (string_array_container_t([ (prt_in, i=1,2) ]), j=1,2) ])
+ if (.not. allocated(prt_in%chars)) call abort
+ if (any(prt_in%chars .ne. "G")) call abort
+ deallocate (prt_in%chars)
+ do j=1,n
+ do k=1,n
+ deallocate (tmpaca(j)%comp(k)%chars)
+ end do
+ end do
+
+ end do
+
+contains
+
+ elemental function new_prt_spec (name) result (prt_spec)
+ type(string_t), intent(in) :: name
+ type(string_t) :: prt_spec
+ prt_spec = name
+ end function new_prt_spec
+
+ elemental function new_prt_spec2 (name) result (prt_spec)
+ type(string_container_t), intent(in) :: name
+ type(string_container_t) :: prt_spec
+ prt_spec = name
+ end function new_prt_spec2
+
+ elemental function new_prt_spec3 (name) result (prt_spec)
+ type(string_array_container_t), intent(in) :: name
+ type(string_array_container_t) :: prt_spec
+ prt_spec = name
+ end function new_prt_spec3
+end program main
+! { dg-final { scan-tree-dump-times "__builtin_malloc" 15 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_free" 33 "original" } }
git://gcc.gnu.org / gcc.git / commitdiff