https://gcc.gnu.org/g:fd1a2f63bcac14cbedb8c8b1790525b9642567d9
commit r15-4329-gfd1a2f63bcac14cbedb8c8b1790525b9642567d9
Author: Andre Vehreschild <ve...@gcc.gnu.org>
Date: Thu Aug 15 13:49:49 2024 +0200
Allow for class type coarray parameters. [PR77871]
gcc/fortran/ChangeLog:
PR fortran/77871
* trans-expr.cc (gfc_conv_derived_to_class): Assign token when
converting a coarray to class.
(gfc_get_tree_for_caf_expr): For classes get the caf decl from
the saved descriptor.
(gfc_get_caf_token_offset):Assert that coarray=lib is set and
cover more cases where the tree having the coarray token can be.
* trans-intrinsic.cc (gfc_conv_intrinsic_caf_get): Use unified
test for pointers.
gcc/testsuite/ChangeLog:
* gfortran.dg/coarray/dummy_3.f90: New test.
Diff:
---
gcc/fortran/trans-expr.cc | 36 ++++++++++++++++++---------
gcc/fortran/trans-intrinsic.cc | 2 +-
gcc/testsuite/gfortran.dg/coarray/dummy_3.f90 | 33 ++++++++++++++++++++++++
3 files changed, 58 insertions(+), 13 deletions(-)
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 8094171eb275..b9f585d0d2f1 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -810,6 +810,16 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
gfc_symbol *fsym,
/* Now set the data field. */
ctree = gfc_class_data_get (var);
+ if (flag_coarray == GFC_FCOARRAY_LIB && CLASS_DATA (fsym)->attr.codimension)
+ {
+ tree token;
+ tmp = gfc_get_tree_for_caf_expr (e);
+ if (POINTER_TYPE_P (TREE_TYPE (tmp)))
+ tmp = build_fold_indirect_ref (tmp);
+ gfc_get_caf_token_offset (parmse, &token, nullptr, tmp, NULL_TREE, e);
+ gfc_add_modify (&parmse->pre, gfc_conv_descriptor_token (ctree), token);
+ }
+
if (optional)
cond_optional = gfc_conv_expr_present (e->symtree->n.sym);
@@ -2344,6 +2354,10 @@ gfc_get_tree_for_caf_expr (gfc_expr *expr)
if (expr->symtree->n.sym->ts.type == BT_CLASS)
{
+ if (DECL_P (caf_decl) && DECL_LANG_SPECIFIC (caf_decl)
+ && GFC_DECL_SAVED_DESCRIPTOR (caf_decl))
+ caf_decl = GFC_DECL_SAVED_DESCRIPTOR (caf_decl);
+
if (expr->ref && expr->ref->type == REF_ARRAY)
{
caf_decl = gfc_class_data_get (caf_decl);
@@ -2408,16 +2422,12 @@ gfc_get_caf_token_offset (gfc_se *se, tree *token, tree
*offset, tree caf_decl,
{
tree tmp;
+ gcc_assert (flag_coarray == GFC_FCOARRAY_LIB);
+
/* Coarray token. */
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl)))
- {
- gcc_assert (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl))
- == GFC_ARRAY_ALLOCATABLE
- || expr->symtree->n.sym->attr.select_type_temporary
- || expr->symtree->n.sym->assoc);
*token = gfc_conv_descriptor_token (caf_decl);
- }
- else if (DECL_LANG_SPECIFIC (caf_decl)
+ else if (DECL_P (caf_decl) && DECL_LANG_SPECIFIC (caf_decl)
&& GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
*token = GFC_DECL_TOKEN (caf_decl);
else
@@ -2435,7 +2445,7 @@ gfc_get_caf_token_offset (gfc_se *se, tree *token, tree
*offset, tree caf_decl,
&& (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)
+ else if (DECL_P (caf_decl) && DECL_LANG_SPECIFIC (caf_decl)
&& GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE)
*offset = GFC_DECL_CAF_OFFSET (caf_decl);
else if (GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl)) != NULL_TREE)
@@ -2502,11 +2512,13 @@ gfc_get_caf_token_offset (gfc_se *se, tree *token, tree
*offset, tree caf_decl,
}
else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl)))
tmp = gfc_conv_descriptor_data_get (caf_decl);
+ else if (INDIRECT_REF_P (caf_decl))
+ tmp = TREE_OPERAND (caf_decl, 0);
else
- {
- gcc_assert (POINTER_TYPE_P (TREE_TYPE (caf_decl)));
- tmp = caf_decl;
- }
+ {
+ gcc_assert (POINTER_TYPE_P (TREE_TYPE (caf_decl)));
+ tmp = caf_decl;
+ }
*offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
fold_convert (gfc_array_index_type, *offset),
diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc
index a282ae1c0903..80d75f26b095 100644
--- a/gcc/fortran/trans-intrinsic.cc
+++ b/gcc/fortran/trans-intrinsic.cc
@@ -1900,7 +1900,7 @@ gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr,
tree lhs, tree lhs_kind,
gfc_add_block_to_block (&se->post, &argse.post);
caf_decl = gfc_get_tree_for_caf_expr (array_expr);
- if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
+ if (POINTER_TYPE_P (TREE_TYPE (caf_decl)))
caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
image_index = gfc_caf_get_image_index (&se->pre, array_expr, caf_decl);
gfc_get_caf_token_offset (se, &token, &offset, caf_decl, argse.expr,
diff --git a/gcc/testsuite/gfortran.dg/coarray/dummy_3.f90
b/gcc/testsuite/gfortran.dg/coarray/dummy_3.f90
new file mode 100644
index 000000000000..4b45daab6493
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray/dummy_3.f90
@@ -0,0 +1,33 @@
+!{ dg-do run }
+
+! Check that PR77871 is fixed.
+
+! Contributed by Gerhard Steinmetz <gerhard.steinmetz.fort...@t-online.de>
+
+program pr77871
+ type t
+ integer :: i
+ end type
+
+ type(t) :: p[*]
+ type(t), allocatable :: p2(:)[:]
+
+ p%i = 42
+ allocate (p2(5)[*])
+ p2(:)%i = (/(i, i=0, 4)/)
+ call s(p, 1)
+ call s2(p2, 1)
+contains
+ subroutine s(x, n)
+ class(t) :: x[*]
+ integer :: n
+ if (x[n]%i /= 42) stop 1
+ end
+
+ subroutine s2(x, n)
+ class(t) :: x(:)[*]
+ integer :: n
+ if (any(x(:)[n]%i /= (/(i, i= 0, 4)/) )) stop 2
+ end
+end
+
