This patch fixes some issues with polymorphic coarrays. I still have to
fix at least one issue.
Fixed by the patch:
a) The temporary pointer generated with SELECT TYPE has to be a coarray.
That's fixed with the resolve.c patch. The comment is also bogus: The
comment is correct – and gfortran correctly detects coindexed variables
as selector. However, in the code in question, the selector is not
coindexed but the variable in the coindexed section is.
b) It doesn't make sense to try to initialize the temporary pointer of
SELECT TYPE (or ASSOCIATE), thus we have to exclude it also in trans-decl.c
c) As the temporary variable is internally a pointer, the assert in
trans-array.c also has to accept a pointer – even though coarrays with
token in the descriptor can only be allocatable. But for code like
"a(1)[1])", "a(1)" is not longer a pointer – and one ends up having an
akind of unknown. Instead of adding all kind of values, I simply removed
the assert.
d) In trans-intrinsic.c, one has a similar issue. We now avoid an ICE by
checking whether the variable is set before accessing it.
e) For caf(:)[i]%a, we had the dtype of the descriptor of "caf" instead
of "...%a". That's now fixed.
Build and regtested on x86-64-gnu-linux.
OK for the trunk?
Tobias
PS: Still to be done for coarrays: Nonallocatable polymorphic coarray
dummies. For those, the offset and the token is passed as additional
argument – but that's not yet correctly handled with ASSOCIATE/SELECT TYPE.
Also to be done are more type-conversion checks (beyond those which are
implicitly checked by this patch) – and the handling of vector subscripts.
2014-06-29 Tobias Burnus <bur...@net-b.de>
* resolve.c (resolve_assoc_var): Fix corank setting.
* trans-array.c (gfc_conv_descriptor_token): Change assert.
for select-type temporaries.
* trans-decl.c (generate_coarray_sym_init): Skip for
attr.select_type_temporary.
* trans-expr.c (gfc_conv_procedure_call): Fix for
select-type temporaries.
* trans-intrinsic.c (get_caf_token_offset): Ditto.
(gfc_conv_intrinsic_caf_get, gfc_conv_intrinsic_caf_send): Set
the correct dtype.
* trans-types.h (gfc_get_dtype_rank_type): New.
* trans-types.c (gfc_get_dtype_rank_type): Ditto.
2014-06-29 Tobias Burnus <bur...@net-b.de>
* gfortran.dg/coarray/coindexed_3.f90: New.
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index ca20c29..15d8dab 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -7912,10 +7912,7 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
sym->as = gfc_get_array_spec ();
sym->as->rank = target->rank;
sym->as->type = AS_DEFERRED;
-
- /* Target must not be coindexed, thus the associate-variable
- has no corank. */
- sym->as->corank = 0;
+ sym->as->corank = gfc_get_corank (target);
}
/* Mark this as an associate variable. */
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 5558217..0e01899 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -298,7 +298,6 @@ gfc_conv_descriptor_token (tree desc)
type = TREE_TYPE (desc);
gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
- gcc_assert (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE);
gcc_assert (gfc_option.coarray == GFC_FCOARRAY_LIB);
field = gfc_advance_chain (TYPE_FIELDS (type), CAF_TOKEN_FIELD);
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index cbcd52d..93c59b1 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -4670,7 +4670,8 @@ generate_coarray_sym_init (gfc_symbol *sym)
tree tmp, size, decl, token;
if (sym->attr.dummy || sym->attr.allocatable || !sym->attr.codimension
- || sym->attr.use_assoc || !sym->attr.referenced)
+ || sym->attr.use_assoc || !sym->attr.referenced
+ || sym->attr.select_type_temporary)
return;
decl = sym->backend_decl;
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 7ee0206..dba51b0 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -4813,7 +4813,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
caf_type = TREE_TYPE (caf_decl);
if (GFC_DESCRIPTOR_TYPE_P (caf_type)
- && GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE)
+ && (GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE
+ || GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_POINTER))
tmp = gfc_conv_descriptor_token (caf_decl);
else if (DECL_LANG_SPECIFIC (caf_decl)
&& GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index a1dfdfb..5aa5683 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -1179,7 +1179,8 @@ get_caf_token_offset (tree *token, tree *offset, tree caf_decl, tree se_expr,
/* Offset between the coarray base address and the address wanted. */
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl))
- && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl)) == GFC_ARRAY_ALLOCATABLE)
+ && (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl)) == GFC_ARRAY_ALLOCATABLE
+ || GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl)) == GFC_ARRAY_POINTER))
*offset = build_int_cst (gfc_array_index_type, 0);
else if (DECL_LANG_SPECIFIC (caf_decl)
&& GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE)
@@ -1285,7 +1286,10 @@ gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs, tree lhs_kind)
ar->type = AR_FULL;
}
gfc_conv_expr_descriptor (&argse, array_expr);
-
+ /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
+ has the wrong type if component references are done. */
+ gfc_add_modify (&argse.pre, gfc_conv_descriptor_dtype (argse.expr),
+ gfc_get_dtype_rank_type (array_expr->rank, type));
if (has_vector)
{
vec = conv_caf_vector_subscript (&argse.pre, argse.expr, ar);
@@ -1387,7 +1391,12 @@ conv_caf_send (gfc_code *code) {
}
lhs_se.want_pointer = 1;
gfc_conv_expr_descriptor (&lhs_se, lhs_expr);
- lhs_type = gfc_get_element_type (TREE_TYPE (TREE_TYPE (lhs_se.expr)));
+ /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
+ has the wrong type if component references are done. */
+ lhs_type = gfc_typenode_for_spec (&lhs_expr->ts);
+ tmp = build_fold_indirect_ref_loc (input_location, lhs_se.expr);
+ gfc_add_modify (&lhs_se.pre, gfc_conv_descriptor_dtype (tmp),
+ gfc_get_dtype_rank_type (lhs_expr->rank, lhs_type));
if (has_vector)
{
vec = conv_caf_vector_subscript (&block, lhs_se.expr, ar);
@@ -1440,6 +1449,7 @@ conv_caf_send (gfc_code *code) {
vector bounds separately. */
gfc_array_ref *ar, ar2;
bool has_vector = false;
+ tree tmp2;
if (gfc_is_coindexed (rhs_expr) && gfc_has_vector_subscript (rhs_expr))
{
@@ -1452,6 +1462,12 @@ conv_caf_send (gfc_code *code) {
}
rhs_se.want_pointer = 1;
gfc_conv_expr_descriptor (&rhs_se, rhs_expr);
+ /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
+ has the wrong type if component references are done. */
+ tmp = build_fold_indirect_ref_loc (input_location, rhs_se.expr);
+ tmp2 = gfc_typenode_for_spec (&rhs_expr->ts);
+ gfc_add_modify (&rhs_se.pre, gfc_conv_descriptor_dtype (tmp),
+ gfc_get_dtype_rank_type (rhs_expr->rank, tmp2));
if (has_vector)
{
rhs_vec = conv_caf_vector_subscript (&block, rhs_se.expr, ar);
diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c
index bb930f9..e55e2d9 100644
--- a/gcc/fortran/trans-types.c
+++ b/gcc/fortran/trans-types.c
@@ -1395,23 +1395,13 @@ gfc_get_desc_dim_type (void)
unknown cases abort. */
tree
-gfc_get_dtype (tree type)
+gfc_get_dtype_rank_type (int rank, tree etype)
{
tree size;
int n;
HOST_WIDE_INT i;
tree tmp;
tree dtype;
- tree etype;
- int rank;
-
- gcc_assert (GFC_DESCRIPTOR_TYPE_P (type) || GFC_ARRAY_TYPE_P (type));
-
- if (GFC_TYPE_ARRAY_DTYPE (type))
- return GFC_TYPE_ARRAY_DTYPE (type);
-
- rank = GFC_TYPE_ARRAY_RANK (type);
- etype = gfc_get_element_type (type);
switch (TREE_CODE (etype))
{
@@ -1477,6 +1467,26 @@ gfc_get_dtype (tree type)
/* TODO: Check this is actually true, particularly when repacking
assumed size parameters. */
+ return dtype;
+}
+
+
+tree
+gfc_get_dtype (tree type)
+{
+ tree dtype;
+ tree etype;
+ int rank;
+
+ gcc_assert (GFC_DESCRIPTOR_TYPE_P (type) || GFC_ARRAY_TYPE_P (type));
+
+ if (GFC_TYPE_ARRAY_DTYPE (type))
+ return GFC_TYPE_ARRAY_DTYPE (type);
+
+ rank = GFC_TYPE_ARRAY_RANK (type);
+ etype = gfc_get_element_type (type);
+ dtype = gfc_get_dtype_rank_type (rank, etype);
+
GFC_TYPE_ARRAY_DTYPE (type) = dtype;
return dtype;
}
diff --git a/gcc/fortran/trans-types.h b/gcc/fortran/trans-types.h
index 5ed87c0..bd3e69c 100644
--- a/gcc/fortran/trans-types.h
+++ b/gcc/fortran/trans-types.h
@@ -97,6 +97,7 @@ int gfc_return_by_reference (gfc_symbol *);
int gfc_is_nodesc_array (gfc_symbol *);
/* Return the DTYPE for an array. */
+tree gfc_get_dtype_rank_type (int, tree);
tree gfc_get_dtype (tree);
tree gfc_get_ppc_type (gfc_component *);
diff --git a/gcc/testsuite/gfortran.dg/coarray/coindexed_3.f90 b/gcc/testsuite/gfortran.dg/coarray/coindexed_3.f90
new file mode 100644
index 0000000..46488f3
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray/coindexed_3.f90
@@ -0,0 +1,71 @@
+! { dg-do run }
+!
+! Contributed by Reinhold Bader
+!
+
+program pmup
+ implicit none
+ type t
+ integer :: b, a
+ end type t
+
+ CLASS(*), allocatable :: a(:)[:]
+ integer :: ii
+
+ !! --- ONE ---
+ allocate(real :: a(3)[*])
+ IF (this_image() == num_images()) THEN
+ SELECT TYPE (a)
+ TYPE IS (real)
+ a(:)[1] = 2.0
+ END SELECT
+ END IF
+ SYNC ALL
+
+ IF (this_image() == 1) THEN
+ SELECT TYPE (a)
+ TYPE IS (real)
+ IF (ALL(A(:)[1] == 2.0)) THEN
+ !WRITE(*,*) 'OK'
+ ELSE
+ WRITE(*,*) 'FAIL'
+ call abort()
+ END IF
+ TYPE IS (t)
+ ii = a(1)[1]%a
+ call abort()
+ CLASS IS (t)
+ ii = a(1)[1]%a
+ call abort()
+ END SELECT
+ END IF
+
+ !! --- TWO ---
+ deallocate(a)
+ allocate(t :: a(3)[*])
+ IF (this_image() == num_images()) THEN
+ SELECT TYPE (a)
+ TYPE IS (t)
+ a(:)[1]%a = 4.0
+ END SELECT
+ END IF
+ SYNC ALL
+
+ IF (this_image() == 1) THEN
+ SELECT TYPE (a)
+ TYPE IS (real)
+ ii = a(1)[1]
+ call abort()
+ TYPE IS (t)
+ IF (ALL(A(:)[1]%a == 4.0)) THEN
+ !WRITE(*,*) 'OK'
+ ELSE
+ WRITE(*,*) 'FAIL'
+ call abort()
+ END IF
+ CLASS IS (t)
+ ii = a(1)[1]%a
+ call abort()
+ END SELECT
+ END IF
+end program
