2013-06-22 Tobias Burnus <burnus@net-b.de>
* trans-array.h (gfc_deallocate_alloc_comp_no_caf): New
prototype.
* trans-array.c (enum): Add DEALLOCATE_ALLOC_COMP_NO_CAF.
(structure_alloc_comps): Handle it.
(gfc_deallocate_alloc_comp_no_caf): New function.
(gfc_alloc_allocatable_for_assignment): Call it.
* trans-expr.c (gfc_trans_scalar_assign,
gfc_trans_arrayfunc_assign, gfc_trans_assignment_1): Ditto.
2013-06-22 Tobias Burnus <burnus@net-b.de>
* gfortran.dg/coarray_lib_realloc_1.f90: New.
@@ -7414,8 +7414,8 @@ gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank)
deallocate, nullify or copy allocatable components. This is the work horse
function for the functions named in this enum. */
-enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP, COPY_ALLOC_COMP,
- COPY_ONLY_ALLOC_COMP};
+enum {DEALLOCATE_ALLOC_COMP = 1, DEALLOCATE_ALLOC_COMP_NO_CAF,
+ NULLIFY_ALLOC_COMP, COPY_ALLOC_COMP, COPY_ONLY_ALLOC_COMP};
static tree
structure_alloc_comps (gfc_symbol * der_type, tree decl,
@@ -7546,6 +7546,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
switch (purpose)
{
case DEALLOCATE_ALLOC_COMP:
+ case DEALLOCATE_ALLOC_COMP_NO_CAF:
/* gfc_deallocate_scalar_with_status calls gfc_deallocate_alloc_comp
(i.e. this function) so generate all the calls and suppress the
@@ -7553,15 +7554,17 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
called_dealloc_with_status = false;
gfc_init_block (&tmpblock);
- if (c->attr.allocatable && (c->attr.dimension || c->attr.codimension)
- && !c->attr.proc_pointer)
+ if (c->attr.allocatable && !c->attr.proc_pointer
+ && (c->attr.dimension
+ || (c->attr.codimension
+ && purpose != DEALLOCATE_ALLOC_COMP_NO_CAF)))
{
comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
decl, cdecl, NULL_TREE);
tmp = gfc_trans_dealloc_allocated (comp, c->attr.codimension, NULL);
gfc_add_expr_to_block (&tmpblock, tmp);
}
- else if (c->attr.allocatable)
+ else if (c->attr.allocatable && !c->attr.codimension)
{
/* Allocatable scalar components. */
comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
@@ -7577,7 +7580,9 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
build_int_cst (TREE_TYPE (comp), 0));
gfc_add_expr_to_block (&tmpblock, tmp);
}
- else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
+ else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable
+ && (!CLASS_DATA (c)->attr.codimension
+ || purpose != DEALLOCATE_ALLOC_COMP_NO_CAF))
{
/* Allocatable CLASS components. */
comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
@@ -7713,10 +7718,17 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
gfc_init_block (&tmpblock);
- ftn_tree = builtin_decl_explicit (BUILT_IN_MALLOC);
- tmp = build_call_expr_loc (input_location, ftn_tree, 1, size);
- gfc_add_modify (&tmpblock, dst_data,
- fold_convert (TREE_TYPE (dst_data), tmp));
+ /* Coarray component have to have the same allocation status and
+ shape/type-parameter/effective-type on the LHS and RHS of an
+ intrinsic assignment. Hence, we did not deallocated them - and
+ do not allocate them here. */
+ if (!CLASS_DATA (c)->attr.codimension)
+ {
+ ftn_tree = builtin_decl_explicit (BUILT_IN_MALLOC);
+ tmp = build_call_expr_loc (input_location, ftn_tree, 1, size);
+ gfc_add_modify (&tmpblock, dst_data,
+ fold_convert (TREE_TYPE (dst_data), tmp));
+ }
tmp = gfc_copy_class_to_class (comp, dcmp, nelems);
gfc_add_expr_to_block (&tmpblock, tmp);
@@ -7741,7 +7753,10 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
&& !cmp_has_alloc_comps)
{
rank = c->as ? c->as->rank : 0;
- tmp = gfc_duplicate_allocatable (dcmp, comp, ctype, rank);
+ if (c->attr.codimension)
+ tmp = gfc_copy_allocatable_data (dcmp, comp, ctype, rank);
+ else
+ tmp = gfc_duplicate_allocatable (dcmp, comp, ctype, rank);
gfc_add_expr_to_block (&fnblock, tmp);
}
@@ -7788,6 +7803,19 @@ gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
/* Recursively traverse an object of derived type, generating code to
+ deallocate allocatable components. But do not deallocate coarrays.
+ To be used for intrinsic assignment, which may not change the allocation
+ status of coarrays. */
+
+tree
+gfc_deallocate_alloc_comp_no_caf (gfc_symbol * der_type, tree decl, int rank)
+{
+ return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
+ DEALLOCATE_ALLOC_COMP_NO_CAF);
+}
+
+
+/* Recursively traverse an object of derived type, generating code to
copy it and its allocatable components. */
tree
@@ -8220,8 +8248,8 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
if ((expr1->ts.type == BT_DERIVED)
&& expr1->ts.u.derived->attr.alloc_comp)
{
- tmp = gfc_deallocate_alloc_comp (expr1->ts.u.derived, old_desc,
- expr1->rank);
+ tmp = gfc_deallocate_alloc_comp_no_caf (expr1->ts.u.derived, old_desc,
+ expr1->rank);
gfc_add_expr_to_block (&realloc_block, tmp);
}
@@ -51,6 +51,7 @@ tree gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank);
tree gfc_nullify_alloc_comp (gfc_symbol *, tree, int);
tree gfc_deallocate_alloc_comp (gfc_symbol *, tree, int);
+tree gfc_deallocate_alloc_comp_no_caf (gfc_symbol *, tree, int);
tree gfc_copy_alloc_comp (gfc_symbol *, tree, tree, int);
@@ -6842,7 +6842,7 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
if (!l_is_temp && dealloc)
{
tmp = gfc_evaluate_now (lse->expr, &lse->pre);
- tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0);
+ tmp = gfc_deallocate_alloc_comp_no_caf (ts.u.derived, tmp, 0);
if (deep_copy)
tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
tmp);
@@ -7196,8 +7196,8 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
&& expr1->ts.u.derived->attr.alloc_comp)
{
tree tmp;
- tmp = gfc_deallocate_alloc_comp (expr1->ts.u.derived, se.expr,
- expr1->rank);
+ tmp = gfc_deallocate_alloc_comp_no_caf (expr1->ts.u.derived, se.expr,
+ expr1->rank);
gfc_add_expr_to_block (&se.pre, tmp);
}
@@ -7762,7 +7762,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
&& expr1->rank && !expr2->rank);
if (scalar_to_array && dealloc)
{
- tmp = gfc_deallocate_alloc_comp (expr2->ts.u.derived, rse.expr, 0);
+ tmp = gfc_deallocate_alloc_comp_no_caf (expr2->ts.u.derived, rse.expr, 0);
gfc_add_expr_to_block (&loop.post, tmp);
}
@@ -0,0 +1,33 @@
+! { dg-do compile }
+! { dg-options "-fdump-tree-original -fcoarray=lib" }
+!
+! Test that for CAF components _gfortran_caf_deregister is called
+! Test that norealloc happens for CAF components during assignment
+!
+module m
+type t
+ integer, allocatable :: CAF[:]
+ integer, allocatable :: ii
+end type t
+end module m
+
+subroutine foo()
+use m
+type(t) :: x,y
+if (allocated(x%caf)) call abort()
+x = y
+end
+
+! For comp%ii: End of scope of x + y (2x) and for the LHS of the assignment (1x)
+! { dg-final { scan-tree-dump-times "__builtin_free" 3 "original" } }
+
+! For comp%CAF: End of scope of x + y (2x); no LHS freeing for the CAF in assignment
+! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister" 2 "original" } }
+
+! Only malloc "ii":
+! { dg-final { scan-tree-dump-times "__builtin_malloc" 1 "original" } }
+
+! But copy "ii" and "CAF":
+! { dg-final { scan-tree-dump-times "__builtin_memcpy" 2 "original" } }
+
+! { dg-final { cleanup-tree-dump "original" } }