https://gcc.gnu.org/g:4d301e3013accc13aa8eaeb1e2ac819c57bb6a79
commit 4d301e3013accc13aa8eaeb1e2ac819c57bb6a79
Author: Mikael Morin <mik...@gcc.gnu.org>
Date: Sun Aug 10 11:03:57 2025 +0200
Suppression set_dtype_if_unallocated
Extraction gfc_descriptor_set_dtype_if_unallocated
Sauvegarde
Revert partiel
Sauvegarde
Correction indentation
Diff:
---
gcc/fortran/trans-array.cc | 2 +-
gcc/fortran/trans-descriptor.cc | 33 +++++++++++--
gcc/fortran/trans-descriptor.h | 2 +-
gcc/fortran/trans-expr.cc | 104 ++++++++++------------------------------
4 files changed, 58 insertions(+), 83 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index a559562057d3..6ccb73a1ff9f 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -547,7 +547,7 @@ void
gfc_trans_static_array_pointer (gfc_symbol * sym)
{
gcc_assert (TREE_STATIC (sym->backend_decl));
- gfc_init_static_descriptor (sym->backend_decl);
+ gfc_init_static_descriptor (sym);
}
diff --git a/gcc/fortran/trans-descriptor.cc b/gcc/fortran/trans-descriptor.cc
index 048184afb76b..ad07726d52bc 100644
--- a/gcc/fortran/trans-descriptor.cc
+++ b/gcc/fortran/trans-descriptor.cc
@@ -848,10 +848,38 @@ gfc_init_absent_descriptor (stmtblock_t *block, tree
descr)
void
-gfc_init_static_descriptor (tree descr)
+gfc_init_static_descriptor (gfc_symbol *sym)
{
+ vec<constructor_elt, va_gc> *v = NULL;
+
+ tree descr = sym->backend_decl;
tree type = TREE_TYPE (descr);
- DECL_INITIAL (descr) = gfc_build_null_descriptor (type);
+
+ gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
+ tree fields = TYPE_FIELDS (type);
+
+ tree data_field = gfc_advance_chain (fields, DATA_FIELD);
+ CONSTRUCTOR_APPEND_ELT (v, data_field,
+ fold_convert (TREE_TYPE (data_field),
+ null_pointer_node));
+
+ gfc_array_spec *as;
+ if (sym->ts.type == BT_CLASS)
+ as = CLASS_DATA (sym)->as;
+ else
+ as = sym->as;
+
+ int rank = as ? as->rank : 0;
+ tree dtype_field = gfc_advance_chain (fields, DTYPE_FIELD);
+ tree dtype_value = gfc_get_dtype_rank_type (rank,
+ gfc_get_element_type (type));
+ CONSTRUCTOR_APPEND_ELT (v, dtype_field,
+ fold_convert (TREE_TYPE (dtype_field), dtype_value));
+
+ tree constr = build_constructor (type, v);
+ TREE_CONSTANT (constr) = 1;
+
+ DECL_INITIAL (descr) = constr;
}
@@ -2806,4 +2834,3 @@ gfc_set_empty_descriptor_bounds (stmtblock_t *block, tree
descr, int rank)
gfc_conv_descriptor_offset_set (block, descr, gfc_index_zero_node);
}
-
diff --git a/gcc/fortran/trans-descriptor.h b/gcc/fortran/trans-descriptor.h
index 6ca550fe8de2..40e1586ce5f7 100644
--- a/gcc/fortran/trans-descriptor.h
+++ b/gcc/fortran/trans-descriptor.h
@@ -86,7 +86,7 @@ gfc_get_descriptor_offsets_for_info (const_tree desc_type,
tree *data_off,
void gfc_nullify_descriptor (stmtblock_t *block, tree);
void gfc_init_descriptor_result (stmtblock_t *block, tree descr);
void gfc_init_absent_descriptor (stmtblock_t *block, tree descr);
-void gfc_init_static_descriptor (tree descr);
+void gfc_init_static_descriptor (gfc_symbol *);
tree gfc_create_null_actual_descriptor (stmtblock_t *, gfc_typespec *,
symbol_attribute, int);
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 64ac831ce836..6a16fdf40976 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -5840,50 +5840,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. */
@@ -7607,40 +7563,32 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
&& (fsym->ts.type == BT_CLASS
? (CLASS_DATA (fsym)->as
&& 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)))
- {
- /* Assumed-size actual to assumed-rank dummy requires
- dim[rank-1].ubound = -1. */
- tree minus_one;
- tmp = build_fold_indirect_ref_loc (input_location, parmse.expr);
- if (fsym->ts.type == BT_CLASS)
- tmp = gfc_class_data_get (tmp);
- minus_one = build_int_cst (gfc_array_index_type, -1);
- gfc_conv_descriptor_ubound_set (&parmse.pre, tmp,
- gfc_rank_cst[e->rank - 1],
- minus_one);
- }
+ : (fsym->as && fsym->as->type == AS_ASSUMED_RANK))
+ && !(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. */
+ tree minus_one;
+ tmp = build_fold_indirect_ref_loc (input_location, parmse.expr);
+ if (fsym->ts.type == BT_CLASS)
+ tmp = gfc_class_data_get (tmp);
+ minus_one = build_int_cst (gfc_array_index_type, -1);
+ gfc_conv_descriptor_ubound_set (&parmse.pre, tmp,
+ gfc_rank_cst[e->rank - 1],
+ minus_one);
}
/* The case with fsym->attr.optional is that of a user subroutine
