https://gcc.gnu.org/g:d8ba7320cbc683b0baa3f82b03cf98f0b95584ff
commit d8ba7320cbc683b0baa3f82b03cf98f0b95584ff
Author: Mikael Morin <mik...@gcc.gnu.org>
Date: Wed Jul 16 12:40:12 2025 +0200
Suppression set_dtype_for_unallocated
Correction null_actual_6 et null_actual_7
Diff:
---
gcc/fortran/trans-descriptor.cc | 23 +++++++++++-
gcc/fortran/trans-expr.cc | 78 ++++++++---------------------------------
2 files changed, 36 insertions(+), 65 deletions(-)
diff --git a/gcc/fortran/trans-descriptor.cc b/gcc/fortran/trans-descriptor.cc
index 2d48a1834ba1..785e81757bd1 100644
--- a/gcc/fortran/trans-descriptor.cc
+++ b/gcc/fortran/trans-descriptor.cc
@@ -625,6 +625,27 @@ gfc_build_null_descriptor (tree type)
return tmp;
}
+tree
+build_static_descriptor_init (tree type)
+{
+ vec<constructor_elt, va_gc> *v = NULL;
+
+ gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
+ tree fields = TYPE_FIELDS (type);
+
+ /* Set a NULL data pointer. */
+ tree field = gfc_advance_chain (fields, DATA_FIELD);
+ CONSTRUCTOR_APPEND_ELT (v, field, null_pointer_node);
+
+ field = gfc_advance_chain (fields, DTYPE_FIELD);
+ CONSTRUCTOR_APPEND_ELT (v, field, gfc_get_dtype (type));
+
+ tree tmp = build_constructor (type, v);
+ TREE_CONSTANT (tmp) = 1;
+ /* All other fields are ignored. */
+
+ return tmp;
+}
/* Obtain offsets for trans-types.cc(gfc_get_array_descr_info). */
@@ -736,7 +757,7 @@ void
gfc_init_static_descriptor (tree descr)
{
tree type = TREE_TYPE (descr);
- DECL_INITIAL (descr) = gfc_build_null_descriptor (type);
+ DECL_INITIAL (descr) = build_static_descriptor_init (type);
}
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index e09447815877..ba7eabfca83d 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -6007,50 +6007,6 @@ expr_may_alias_variables (gfc_expr *e, bool
array_may_alias)
}
-/* A helper function to set the dtype for unallocated or unassociated
- entities. */
-
-static void
-set_dtype_for_unallocated (gfc_se *parmse, gfc_expr *e)
-{
- tree tmp;
- tree desc;
- tree cond;
- tree type;
- stmtblock_t block;
-
- /* TODO Figure out how to handle optional dummies. */
- if (e && e->expr_type == EXPR_VARIABLE
- && e->symtree->n.sym->attr.optional)
- return;
-
- desc = parmse->expr;
- if (desc == NULL_TREE)
- return;
-
- if (POINTER_TYPE_P (TREE_TYPE (desc)))
- desc = build_fold_indirect_ref_loc (input_location, desc);
- if (GFC_CLASS_TYPE_P (TREE_TYPE (desc)))
- desc = gfc_class_data_get (desc);
- if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
- return;
-
- gfc_init_block (&block);
- tmp = gfc_conv_descriptor_data_get (desc);
- cond = fold_build2_loc (input_location, EQ_EXPR,
- logical_type_node, tmp,
- build_int_cst (TREE_TYPE (tmp), 0));
- type = gfc_get_element_type (TREE_TYPE (desc));
- gfc_conv_descriptor_dtype_set (&block, desc,
- gfc_get_dtype_rank_type (e->rank, type));
- cond = build3_v (COND_EXPR, cond,
- gfc_finish_block (&block),
- build_empty_stmt (input_location));
- gfc_add_expr_to_block (&parmse->pre, cond);
-}
-
-
-
/* Provide an interface between gfortran array descriptors and the F2018:18.4
ISO_Fortran_binding array descriptors. */
@@ -7878,26 +7834,20 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
&& CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)
: (fsym->as && fsym->as->type == AS_ASSUMED_RANK)))
{
- if (fsym->ts.type == BT_CLASS
- ? (CLASS_DATA (fsym)->attr.class_pointer
- || CLASS_DATA (fsym)->attr.allocatable)
- : (fsym->attr.pointer || fsym->attr.allocatable))
- {
- /* Unallocated allocatable arrays and unassociated pointer
- arrays need their dtype setting if they are argument
- associated with assumed rank dummies to set the rank. */
- set_dtype_for_unallocated (&parmse, e);
- }
- else if (e->expr_type == EXPR_VARIABLE
- && e->symtree->n.sym->attr.dummy
- && (e->ts.type == BT_CLASS
- ? (e->ref && e->ref->next
- && e->ref->next->type == REF_ARRAY
- && e->ref->next->u.ar.type == AR_FULL
- && e->ref->next->u.ar.as->type == AS_ASSUMED_SIZE)
- : (e->ref && e->ref->type == REF_ARRAY
- && e->ref->u.ar.type == AR_FULL
- && e->ref->u.ar.as->type == AS_ASSUMED_SIZE)))
+ if (!(fsym->ts.type == BT_CLASS
+ ? (CLASS_DATA (fsym)->attr.class_pointer
+ || CLASS_DATA (fsym)->attr.allocatable)
+ : (fsym->attr.pointer || fsym->attr.allocatable))
+ && e->expr_type == EXPR_VARIABLE
+ && e->symtree->n.sym->attr.dummy
+ && (e->ts.type == BT_CLASS
+ ? (e->ref && e->ref->next
+ && e->ref->next->type == REF_ARRAY
+ && e->ref->next->u.ar.type == AR_FULL
+ && e->ref->next->u.ar.as->type == AS_ASSUMED_SIZE)
+ : (e->ref && e->ref->type == REF_ARRAY
+ && e->ref->u.ar.type == AR_FULL
+ && e->ref->u.ar.as->type == AS_ASSUMED_SIZE)))
{
/* Assumed-size actual to assumed-rank dummy requires
dim[rank-1].ubound = -1. */
