Hi all,
attached patch fixes an addressing issue for coarrays *in* derived types.
Before the patch the caf runtime reference chain was generated from the start
of the symbol to the last reference *and* the reference chain upto the coarray
in the derived type was used to call the caf_*_by_ref () functions. The patch
fixes this by skipping the generation of unnecessary caf runtime references.
The second part fixes finding the token for coarrayed arrays. The new semantic
is, that each allocatable array has the coarray token in its .token member,
which the allocate_array now makes use of.
Bootstrapped and regtested ok on x86_64-linux/F23. Ok for trunk?
Regards,
Andre
--
Andre Vehreschild * Email: vehre ad gmx dot de
gcc/fortran/ChangeLog:
2016-09-29 Andre Vehreschild <ve...@gcc.gnu.org>
* trans-array.c (gfc_array_allocate): Use the token from coarray's
.token member.
* trans-intrinsic.c (conv_expr_ref_to_caf_ref): Only generate
caf-reference chains from the first coarray references on.
* trans-types.c (gfc_get_derived_type): Switch on mandatory .token
member generation for allocatable arrays in coarrays in derived types.
gcc/testsuite/ChangeLog:
2016-09-29 Andre Vehreschild <ve...@gcc.gnu.org>
* gfortran.dg/coarray_allocate_10.f08: New test.
* gfortran.dg/coindexed_1.f90: Above fixes allow execution.
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 0b97760..50312fe 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -5406,7 +5406,6 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
gfc_expr **lower;
gfc_expr **upper;
gfc_ref *ref, *prev_ref = NULL, *coref;
- gfc_se caf_se;
bool allocatable, coarray, dimension, alloc_w_e3_arr_spec = false;
ref = expr->ref;
@@ -5531,7 +5530,6 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
}
}
- gfc_init_se (&caf_se, NULL);
gfc_start_block (&elseblock);
/* Allocate memory to store the data. */
@@ -5543,9 +5541,7 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
if (coarray && flag_coarray == GFC_FCOARRAY_LIB)
{
- tmp = gfc_get_tree_for_caf_expr (expr);
- gfc_get_caf_token_offset (&caf_se, &token, NULL, tmp, NULL_TREE, expr);
- gfc_add_block_to_block (&elseblock, &caf_se.pre);
+ token = gfc_conv_descriptor_token (se->expr);
token = gfc_build_addr_expr (NULL_TREE, token);
}
@@ -5557,7 +5553,6 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
else
gfc_allocate_using_malloc (&elseblock, pointer, size, status);
- gfc_add_block_to_block (&elseblock, &caf_se.post);
if (dimension)
{
cond = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR,
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 954f7b3..a499c32 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -1110,7 +1110,7 @@ compute_component_offset (tree field, tree type)
static tree
conv_expr_ref_to_caf_ref (stmtblock_t *block, gfc_expr *expr)
{
- gfc_ref *ref = expr->ref;
+ gfc_ref *ref = expr->ref, *last_comp_ref;
tree caf_ref = NULL_TREE, prev_caf_ref = NULL_TREE, reference_type, tmp, tmp2,
field, last_type, inner_struct, mode, mode_rhs, dim_array, dim, dim_type,
start, end, stride, vector, nvec;
@@ -1127,8 +1127,29 @@ conv_expr_ref_to_caf_ref (stmtblock_t *block, gfc_expr *expr)
/* Prevent uninit-warning. */
reference_type = NULL_TREE;
- last_type = gfc_typenode_for_spec (&expr->symtree->n.sym->ts);
- last_type_n = expr->symtree->n.sym->ts.type;
+
+ /* Skip refs upto the first coarray-ref. */
+ last_comp_ref = NULL;
+ while (ref && (ref->type != REF_ARRAY || ref->u.ar.codimen == 0))
+ {
+ /* Remember the type of components skipped. */
+ if (ref->type == REF_COMPONENT)
+ last_comp_ref = ref;
+ ref = ref->next;
+ }
+ /* When a component was skipped, get the type information of the last
+ component ref, else get the type from the symbol. */
+ if (last_comp_ref)
+ {
+ last_type = gfc_typenode_for_spec (&last_comp_ref->u.c.component->ts);
+ last_type_n = last_comp_ref->u.c.component->ts.type;
+ }
+ else
+ {
+ last_type = gfc_typenode_for_spec (&expr->symtree->n.sym->ts);
+ last_type_n = expr->symtree->n.sym->ts.type;
+ }
+
while (ref)
{
if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0
diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c
index 27a6bab..05122d9 100644
--- a/gcc/fortran/trans-types.c
+++ b/gcc/fortran/trans-types.c
@@ -2565,7 +2565,8 @@ gfc_get_derived_type (gfc_symbol * derived, bool in_coarray)
if ((!c->attr.pointer && !c->attr.proc_pointer)
|| c->ts.u.derived->backend_decl == NULL)
c->ts.u.derived->backend_decl = gfc_get_derived_type (c->ts.u.derived,
- in_coarray);
+ in_coarray
+ || c->attr.codimension);
if (c->ts.u.derived->attr.is_iso_c)
{
diff --git a/gcc/testsuite/gfortran.dg/coarray_allocate_10.f08 b/gcc/testsuite/gfortran.dg/coarray_allocate_10.f08
new file mode 100644
index 0000000..30ee216
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray_allocate_10.f08
@@ -0,0 +1,39 @@
+! { dg-do run }
+! { dg-options "-fcoarray=lib -lcaf_single" }
+
+program alloc_comp
+ implicit none
+
+ type coords
+ integer,allocatable :: x(:)
+ end type
+
+ type outerT
+ type(coords),allocatable :: coo[:]
+ end type
+ integer :: me,np,n,i
+ type(outerT) :: o
+
+ ! with caf_single num_images is always == 1
+ me = this_image(); np = num_images()
+ n = 100
+
+ allocate(o%coo[*])
+ allocate(o%coo%x(n))
+
+ o%coo%x = me
+
+ do i=1, n
+ o%coo%x(i) = o%coo%x(i) + i
+ end do
+
+ sync all
+
+ if(me == 1 .and. o%coo[np]%x(10) /= 11 ) call abort()
+
+ ! Check the whole array is correct.
+ if (me == 1 .and. any( o%coo[np]%x /= [(i, i=2, 101)] ) ) call abort()
+
+ deallocate(o%coo%x)
+
+end program
diff --git a/gcc/testsuite/gfortran.dg/coindexed_1.f90 b/gcc/testsuite/gfortran.dg/coindexed_1.f90
index b25f2f8..932442c 100644
--- a/gcc/testsuite/gfortran.dg/coindexed_1.f90
+++ b/gcc/testsuite/gfortran.dg/coindexed_1.f90
@@ -1,5 +1,5 @@
-! { dg-do compile }
-! { dg-options "-fcoarray=lib" }
+! { dg-do run }
+! { dg-options "-fcoarray=lib -lcaf_single" }
!
! Contributed by Reinhold Bader
!
@@ -14,7 +14,7 @@ program pmup
integer :: ii
!! --- ONE ---
- allocate(real :: a(3)[*]) ! { dg-error "Sorry, coindexed access to an unlimited polymorphic object at" }
+ allocate(real :: a(3)[*])
IF (this_image() == num_images()) THEN
SELECT TYPE (a)
TYPE IS (real)
@@ -43,7 +43,7 @@ program pmup
!! --- TWO ---
deallocate(a)
- allocate(t :: a(3)[*]) ! { dg-error "Sorry, coindexed access to an unlimited polymorphic object at" }
+ allocate(t :: a(3)[*])
IF (this_image() == num_images()) THEN
SELECT TYPE (a)
TYPE IS (t)
