Hi all,
during testing and compiling some larger coarray codes, I found a few
deficiencies. One was with handling class types when splitting the coarray
expression and the other was that the backend_decl of a formal argument in a
function's symbol was not the same as the one the function was compiled to. So
looking at the function-decl's tree n-th formal argument is the way to go there.
Regtests ok on x86_64-pc-linux-gnu / F41. Ok for mainline?
Regards,
Andre
--
Andre Vehreschild * Email: vehre ad gmx dot de
From efc6ed615b36bb6b42a43f6f35bf81a1adce2941 Mon Sep 17 00:00:00 2001
From: Andre Vehreschild <[email protected]>
Date: Fri, 21 Feb 2025 14:06:28 +0100
Subject: [PATCH] Fortran: Fix detection of descriptor arrays in coarray
[PR107635]
Look at the formal arguments generated type in the function declaration
to figure if an argument is a descriptor arrays. Fix handling of class
types while splitting coarray expressions.
PR fortran/107635
gcc/fortran/ChangeLog:
* coarray.cc (fixup_comp_refs): For class types set correct
component (class) type.
(split_expr_at_caf_ref): Provide location.
* trans-intrinsic.cc (conv_caf_send_to_remote): Look at
generated formal argument and not declared one to detect
descriptor arrays.
(conv_caf_sendget): Same.
---
gcc/fortran/coarray.cc | 15 ++++++++++-----
gcc/fortran/trans-intrinsic.cc | 15 +++++++++------
2 files changed, 19 insertions(+), 11 deletions(-)
diff --git a/gcc/fortran/coarray.cc b/gcc/fortran/coarray.cc
index e5648e0d027..f53de0b20e3 100644
--- a/gcc/fortran/coarray.cc
+++ b/gcc/fortran/coarray.cc
@@ -295,11 +295,12 @@ move_coarray_ref (gfc_ref **from, gfc_expr *expr)
static void
fixup_comp_refs (gfc_expr *expr)
{
- gfc_symbol *type = expr->symtree->n.sym->ts.type == BT_DERIVED
- ? expr->symtree->n.sym->ts.u.derived
- : (expr->symtree->n.sym->ts.type == BT_CLASS
- ? CLASS_DATA (expr->symtree->n.sym)->ts.u.derived
- : nullptr);
+ bool class_ref = expr->symtree->n.sym->ts.type == BT_CLASS;
+ gfc_symbol *type
+ = expr->symtree->n.sym->ts.type == BT_DERIVED
+ ? expr->symtree->n.sym->ts.u.derived
+ : (class_ref ? CLASS_DATA (expr->symtree->n.sym)->ts.u.derived
+ : nullptr);
if (!type)
return;
gfc_ref **pref = &(expr->ref);
@@ -317,6 +318,9 @@ fixup_comp_refs (gfc_expr *expr)
ref = nullptr;
break;
}
+ if (class_ref)
+ /* Link to the class type to allow for derived type resolution. */
+ (*pref)->u.c.sym = ref->u.c.sym;
(*pref)->next = ref->next;
ref->next = NULL;
gfc_free_ref_list (ref);
@@ -372,6 +376,7 @@ split_expr_at_caf_ref (gfc_expr *expr, gfc_namespace *ns,
st->n.sym->attr.dummy = 1;
st->n.sym->attr.intent = INTENT_IN;
st->n.sym->ts = *caf_ts;
+ st->n.sym->declared_at = expr->where;
*post_caf_ref_expr = gfc_get_variable_expr (st);
(*post_caf_ref_expr)->where = expr->where;
diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc
index 80e98dc3c20..f48f39d7a82 100644
--- a/gcc/fortran/trans-intrinsic.cc
+++ b/gcc/fortran/trans-intrinsic.cc
@@ -1445,8 +1445,9 @@ conv_caf_send_to_remote (gfc_code *code)
NULL_TREE, gfc_trans_force_lval (&block, lhs_se.string_length));
else
opt_lhs_charlen = build_zero_cst (build_pointer_type (size_type_node));
- if (!TYPE_LANG_SPECIFIC (TREE_TYPE (caf_decl))->rank
- || GFC_ARRAY_TYPE_P (TREE_TYPE (caf_decl)))
+ tmp = TREE_VALUE (TREE_CHAIN (TREE_CHAIN (TYPE_ARG_TYPES (
+ TREE_TYPE (receiver_fn_expr->symtree->n.sym->backend_decl)))));
+ if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
opt_lhs_desc = null_pointer_node;
else
opt_lhs_desc
@@ -1635,8 +1636,9 @@ conv_caf_sendget (gfc_code *code)
NULL_TREE, gfc_trans_force_lval (&block, lhs_se.string_length));
else
opt_lhs_charlen = build_zero_cst (build_pointer_type (size_type_node));
- if (!TYPE_LANG_SPECIFIC (TREE_TYPE (lhs_caf_decl))->rank
- || GFC_ARRAY_TYPE_P (TREE_TYPE (lhs_caf_decl)))
+ tmp = TREE_VALUE (TREE_CHAIN (TREE_CHAIN (TYPE_ARG_TYPES (
+ TREE_TYPE (receiver_fn_expr->symtree->n.sym->backend_decl)))));
+ if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
opt_lhs_desc = null_pointer_node;
else
opt_lhs_desc
@@ -1677,8 +1679,9 @@ conv_caf_sendget (gfc_code *code)
rhs_size = gfc_typenode_for_spec (ts)->type_common.size_unit;
}
}
- else if (!TYPE_LANG_SPECIFIC (TREE_TYPE (rhs_caf_decl))->rank
- || GFC_ARRAY_TYPE_P (TREE_TYPE (rhs_caf_decl)))
+ else if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_VALUE (
+ TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TYPE_ARG_TYPES (
+ TREE_TYPE (sender_fn_expr->symtree->n.sym->backend_decl))))))))))
{
rhs_se.data_not_needed = 1;
gfc_conv_expr_descriptor (&rhs_se, rhs_expr);
--
2.48.1
