2013-06-26 Tobias Burnus * trans-array.h (gfc_deallocate_alloc_comp_no_caf, gfc_reassign_alloc_comp_caf): New prototype. * trans-array.c (enum): Add DEALLOCATE_ALLOC_COMP_NO_CAF and COPY_ALLOC_COMP_CAF. (structure_alloc_comps): Handle it. (gfc_reassign_alloc_comp_caf, 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. * parse.c (parse_derived): Correctly set coarray_comp. * resolve.c (resolve_symbol): Improve error wording. 2013-06-26 Tobias Burnus * gfortran.dg/coarray_lib_realloc_1.f90: New. * gfortran.dg/coarray/lib_realloc_1.f90: New. * gfortran.dg/coarray_6.f90: Add dg-error. diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index f98a213..737f3d6 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -2228,11 +2228,11 @@ endType: sym->attr.coarray_comp = 1; } - if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.coarray_comp) + if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.coarray_comp + && !c->attr.pointer) { coarray = true; - if (!pointer && !allocatable) - sym->attr.coarray_comp = 1; + sym->attr.coarray_comp = 1; } /* Looking for lock_type components. */ diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index ce68401..0c0804b 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -13125,8 +13125,8 @@ resolve_symbol (gfc_symbol *sym) && (class_attr.codimension || class_attr.pointer || class_attr.dimension || class_attr.allocatable)) { - gfc_error ("Variable '%s' at %L with coarray component " - "shall be a nonpointer, nonallocatable scalar", + gfc_error ("Variable '%s' at %L with coarray component shall be a " + "nonpointer, nonallocatable scalar, which is not a coarray", sym->name, &sym->declared_at); return; } diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 39bf0dd..452becf 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -7445,8 +7445,9 @@ 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, + COPY_ALLOC_COMP_CAF}; static tree structure_alloc_comps (gfc_symbol * der_type, tree decl, @@ -7577,6 +7578,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 @@ -7584,19 +7586,37 @@ 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->ts.type == BT_DERIVED && !c->attr.pointer) + || (c->ts.type == BT_CLASS && !CLASS_DATA (c)->attr.class_pointer)) { comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, decl, cdecl, NULL_TREE); + + /* The finalizer frees allocatable components. */ + called_dealloc_with_status + = gfc_add_comp_finalizer_call (&tmpblock, comp, c, + purpose == DEALLOCATE_ALLOC_COMP); + } + else + comp = NULL_TREE; + + if (c->attr.allocatable && !c->attr.proc_pointer + && (c->attr.dimension + || (c->attr.codimension + && purpose != DEALLOCATE_ALLOC_COMP_NO_CAF))) + { + if (comp == NULL_TREE) + 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, - decl, cdecl, NULL_TREE); + if (comp == NULL_TREE) + comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, + decl, cdecl, NULL_TREE); tmp = gfc_deallocate_scalar_with_status (comp, NULL, true, NULL, c->ts); @@ -7608,13 +7628,16 @@ 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, - decl, cdecl, NULL_TREE); /* Add reference to '_data' component. */ + if (comp == NULL_TREE) + comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, + decl, cdecl, NULL_TREE); tmp = CLASS_DATA (c)->backend_decl; comp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp), comp, tmp, NULL_TREE); @@ -7705,6 +7728,28 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, } break; + case COPY_ALLOC_COMP_CAF: + if (!c->attr.codimension + && (c->ts.type != BT_CLASS || CLASS_DATA (c)->attr.coarray_comp) + && (c->ts.type != BT_DERIVED + || !c->ts.u.derived->attr.coarray_comp)) + continue; + + comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, decl, + cdecl, NULL_TREE); + dcmp = fold_build3_loc (input_location, COMPONENT_REF, ctype, dest, + cdecl, NULL_TREE); + if (c->attr.codimension) + gfc_add_modify (&fnblock, dcmp, comp); + else + { + tmp = structure_alloc_comps (c->ts.u.derived, comp, dcmp, + rank, purpose); + gfc_add_expr_to_block (&fnblock, tmp); + + } + break; + case COPY_ALLOC_COMP: if (c->attr.pointer) continue; @@ -7736,18 +7781,30 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, size_type_node, size, fold_convert (size_type_node, nelems)); - src_data = gfc_conv_descriptor_data_get (src_data); - dst_data = gfc_conv_descriptor_data_get (dst_data); } else nelems = build_int_cst (size_type_node, 1); + if (CLASS_DATA (c)->attr.dimension + || CLASS_DATA (c)->attr.codimension) + { + src_data = gfc_conv_descriptor_data_get (src_data); + dst_data = gfc_conv_descriptor_data_get (dst_data); + } + 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); @@ -7772,7 +7829,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); } @@ -7819,6 +7879,26 @@ 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); +} + + +tree +gfc_reassign_alloc_comp_caf (gfc_symbol *der_type, tree decl, tree dest) +{ + return structure_alloc_comps (der_type, decl, dest, 0, COPY_ALLOC_COMP_CAF); +} + + +/* Recursively traverse an object of derived type, generating code to copy it and its allocatable components. */ tree @@ -8251,8 +8331,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); } diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h index 2d2b45d..e8f207e 100644 --- a/gcc/fortran/trans-array.h +++ b/gcc/fortran/trans-array.h @@ -51,6 +51,8 @@ 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_reassign_alloc_comp_caf (gfc_symbol *, tree, tree); tree gfc_copy_alloc_comp (gfc_symbol *, tree, tree, int); diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 0eef2b2..e1ed9d9 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -6824,6 +6824,7 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts, } else if (ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp) { + tree tmp_var = NULL_TREE; cond = NULL_TREE; /* Are the rhs and the lhs the same? */ @@ -6841,8 +6842,8 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts, expression. */ if (!l_is_temp && dealloc) { - tmp = gfc_evaluate_now (lse->expr, &lse->pre); - tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0); + tmp_var = gfc_evaluate_now (lse->expr, &lse->pre); + tmp = gfc_deallocate_alloc_comp_no_caf (ts.u.derived, tmp_var, 0); if (deep_copy) tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location), tmp); @@ -6855,6 +6856,16 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts, gfc_add_modify (&block, lse->expr, fold_convert (TREE_TYPE (lse->expr), rse->expr)); + /* Restore pointer address of coarray components. */ + if (ts.u.derived->attr.coarray_comp && deep_copy) + { + gcc_assert (tmp_var != NULL_TREE); + tmp = gfc_reassign_alloc_comp_caf (ts.u.derived, tmp_var, lse->expr); + tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location), + tmp); + gfc_add_expr_to_block (&block, tmp); + } + /* Do a deep copy if the rhs is a variable, if it is not the same as the lhs. */ if (deep_copy) @@ -7196,8 +7207,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 +7773,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); } --- /dev/null 2013-06-26 08:23:53.976189029 +0200 +++ gcc/gcc/testsuite/gfortran.dg/coarray_lib_realloc_1.f90 2013-06-26 19:28:32.786634679 +0200 @@ -0,0 +1,35 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original -fcoarray=lib" } +! +! PR fortran/52052 +! +! 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" } } --- /dev/null 2013-06-26 08:23:53.976189029 +0200 +++ gcc/gcc/testsuite/gfortran.dg/coarray/lib_realloc_1.f90 2013-06-26 19:57:48.418908565 +0200 @@ -0,0 +1,30 @@ +! { dg-do run } +! { dg-options "-O0" } +! +! 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[:] +end type t +end module m + +program main +use m +type(t), target :: x,y +integer, pointer :: ptr +allocate(x%caf[*], y%caf[*]) +ptr => y%caf +ptr = 6 +if (.not.allocated(x%caf)) call abort() +if (.not.allocated(y%caf)) call abort() +if (y%caf /= 6) call abort () +x = y +if (x%caf /= 6) call abort () +if (.not. associated (ptr,y%caf)) call abort() +if (associated (ptr,x%caf)) call abort() +ptr = 123 +if (y%caf /= 123) call abort () +if (x%caf /= 6) call abort () +end program main diff --git a/gcc/testsuite/gfortran.dg/coarray_6.f90 b/gcc/testsuite/gfortran.dg/coarray_6.f90 index 9fb06d4..f44ac01 100644 --- a/gcc/testsuite/gfortran.dg/coarray_6.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_6.f90 @@ -75,7 +75,7 @@ subroutine valid(a) type t2 type(t) :: b end type t2 - type(t2), save :: xt2[*] + type(t2), save :: xt2[*] ! { dg-error "nonpointer, nonallocatable scalar, which is not a coarray" } end subroutine valid program main