MatCat.OpenSource/8sa1-gcc
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

trans-array.h (gfc_deallocate_alloc_comp_no_caf, [...]): New prototype.

Browse Source 
2013-07-15  Tobias Burnus  <burnus@net-b.de>

        * 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-07-15  Tobias Burnus  <burnus@net-b.de>

        * gfortran.dg/coarray_lib_realloc_1.f90: New.
        * gfortran.dg/coarray/lib_realloc_1.f90: New.
        * gfortran.dg/coarray_6.f90: Add dg-error.

From-SVN: r200955
This commit is contained in:
Tobias Burnus 2013-07-15 10:25:48 +02:00 committed by Tobias Burnus
parent 895a0c2df3
commit abc2d8074a
10 changed files with 193 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
gcc/fortran/ChangeLog
View File

@ -1,3 +1,18 @@
2013-07-15 Tobias Burnus <burnus@net-b.de>
* 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-07-15 Tobias Burnus <burnus@net-b.de>
PR fortran/37336

6
gcc/fortran/parse.c
View File

@ -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. */

4
gcc/fortran/resolve.c
View File

@ -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;
}

105
gcc/fortran/trans-array.c
View File

@ -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
@ -7586,19 +7588,22 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
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);
{
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, true);
= gfc_add_comp_finalizer_call (&tmpblock, comp, c,
purpose == DEALLOCATE_ALLOC_COMP);
}
else
comp = NULL_TREE;
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)))
{
if (comp == NULL_TREE)
comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
@ -7606,7 +7611,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
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. */
if (comp == NULL_TREE)
@ -7623,14 +7628,13 @@ 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. */
/* 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);
@ -7721,6 +7725,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;
@ -7752,18 +7778,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);
@ -7788,7 +7826,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);
}
@ -7834,6 +7875,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. */
@ -8267,8 +8328,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);
}

2
gcc/fortran/trans-array.h
View File

@ -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);

21
gcc/fortran/trans-expr.c
View File

@ -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);
}

6
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,9 @@
2013-07-15 Tobias Burnus <burnus@net-b.de>
* gfortran.dg/coarray_lib_realloc_1.f90: New.
* gfortran.dg/coarray/lib_realloc_1.f90: New.
* gfortran.dg/coarray_6.f90: Add dg-error.
2013-07-15 Tobias Burnus <burnus@net-b.de>
PR fortran/37336

30
gcc/testsuite/gfortran.dg/coarray/lib_realloc_1.f90 Normal file
View File

@ -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

2
gcc/testsuite/gfortran.dg/coarray_6.f90
View File

@ -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

35
gcc/testsuite/gfortran.dg/coarray_lib_realloc_1.f90 Normal file
View File

@ -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" } }