https://gcc.gnu.org/g:5731adaf8c102ff49bf672487d476fccdb10fcf3
commit 5731adaf8c102ff49bf672487d476fccdb10fcf3
Author: Mikael Morin <mik...@gcc.gnu.org>
Date: Sun Dec 15 17:55:45 2024 +0100
Sauvegarde correction null_actual_6
Diff:
---
gcc/fortran/trans-array.cc | 145 +++++++++++++++++++++++++++++++--------------
gcc/fortran/trans-array.h | 5 +-
gcc/fortran/trans-expr.cc | 45 +++++++++++++-
3 files changed, 146 insertions(+), 49 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index c02fbde0ceaf..00e4b086e843 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -592,10 +592,10 @@ get_size_info (gfc_typespec &ts)
if (POINTER_TYPE_P (type))
type = TREE_TYPE (type);
gcc_assert (TREE_CODE (type) == ARRAY_TYPE);
- tree elt_type = TREE_TYPE (type);
+ tree char_type = TREE_TYPE (type);
tree len = ts.u.cl->backend_decl;
return fold_build2_loc (input_location, MULT_EXPR, size_type_node,
- size_in_bytes (elt_type),
+ size_in_bytes (char_type),
fold_convert (size_type_node, len));
}
@@ -613,8 +613,61 @@ get_size_info (gfc_typespec &ts)
}
+class init_info
+{
+public:
+ virtual bool initialize_data () const { return false; }
+ virtual tree get_data_value () const { return NULL_TREE; }
+ virtual gfc_typespec *get_type () const { return nullptr; }
+};
+
+
+class default_init : public init_info
+{
+private:
+ const symbol_attribute &attr;
+
+public:
+ default_init (const symbol_attribute &arg_attr) : attr(arg_attr) { }
+ virtual bool initialize_data () const { return !attr.pointer; }
+ virtual tree get_data_value () const {
+ if (!initialize_data ())
+ return NULL_TREE;
+
+ return null_pointer_node;
+ }
+};
+
+class nullification : public init_info
+{
+private:
+ gfc_typespec &ts;
+
+public:
+ nullification(gfc_typespec &arg_ts) : ts(arg_ts) { }
+ virtual bool initialize_data () const { return true; }
+ virtual tree get_data_value () const { return null_pointer_node; }
+ virtual gfc_typespec *get_type () const { return &ts; }
+};
+
+class scalar_value : public init_info
+{
+private:
+ gfc_typespec &ts;
+ tree value;
+
+public:
+ scalar_value(gfc_typespec &arg_ts, tree arg_value)
+ : ts(arg_ts), value(arg_value) { }
+ virtual bool initialize_data () const { return true; }
+ virtual tree get_data_value () const { return value; }
+ virtual gfc_typespec *get_type () const { return &ts; }
+};
+
+
static tree
-build_dtype (gfc_typespec &ts, int rank, const symbol_attribute &)
+build_dtype (gfc_typespec &ts, int rank, const symbol_attribute &,
+ const init_info &init)
{
vec<constructor_elt, va_gc> *v = nullptr;
@@ -622,11 +675,17 @@ build_dtype (gfc_typespec &ts, int rank, const
symbol_attribute &)
tree fields = TYPE_FIELDS (type);
- if (ts.type != BT_CLASS)
+ gfc_typespec *type_info = init.get_type ();
+ if (type_info == nullptr)
+ type_info = &ts;
+
+ if (!(type_info->type == BT_CLASS
+ || (type_info->type == BT_CHARACTER
+ && type_info->deferred)))
{
tree elem_len_field = gfc_advance_chain (fields, GFC_DTYPE_ELEM_LEN);
tree elem_len_val = fold_convert (TREE_TYPE (elem_len_field),
- get_size_info (ts));
+ get_size_info (*type_info));
CONSTRUCTOR_APPEND_ELT (v, elem_len_field, elem_len_val);
}
@@ -641,11 +700,11 @@ build_dtype (gfc_typespec &ts, int rank, const
symbol_attribute &)
CONSTRUCTOR_APPEND_ELT (v, rank_field, rank_val);
}
- if (ts.type != BT_CLASS)
+ if (type_info->type != BT_CLASS)
{
tree type_info_field = gfc_advance_chain (fields, GFC_DTYPE_TYPE);
tree type_info_val = build_int_cst (TREE_TYPE (type_info_field),
- get_type_info (ts));
+ get_type_info (*type_info));
CONSTRUCTOR_APPEND_ELT (v, type_info_field, type_info_val);
}
@@ -657,7 +716,7 @@ build_dtype (gfc_typespec &ts, int rank, const
symbol_attribute &)
vec<constructor_elt, va_gc> *
get_descriptor_init (tree type, gfc_typespec &ts, int rank,
- const symbol_attribute &attr, tree data_value)
+ const symbol_attribute &attr, const init_info &init)
{
vec<constructor_elt, va_gc> *v = nullptr;
@@ -666,14 +725,15 @@ get_descriptor_init (tree type, gfc_typespec &ts, int
rank,
tree fields = TYPE_FIELDS (type);
/* Don't init pointers by default. */
- if (data_value)
+ if (init.initialize_data ())
{
tree data_field = gfc_advance_chain (fields, DATA_FIELD);
+ tree data_value = init.get_data_value ();
CONSTRUCTOR_APPEND_ELT (v, data_field, data_value);
}
tree dtype_field = gfc_advance_chain (fields, DTYPE_FIELD);
- tree dtype_value = build_dtype (ts, rank, attr);
+ tree dtype_value = build_dtype (ts, rank, attr, init);
CONSTRUCTOR_APPEND_ELT (v, dtype_field, dtype_value);
if (flag_coarray == GFC_FCOARRAY_LIB && attr.codimension)
@@ -698,27 +758,8 @@ get_default_array_descriptor_init (tree type, gfc_typespec
&ts, int rank,
{
gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
gcc_assert (DATA_FIELD == 0);
- tree fields = TYPE_FIELDS (type);
-
- /* Don't init pointers by default. */
- tree data_value;
- if (attr.pointer)
- data_value = NULL_TREE;
- else
- {
- tree data_field = gfc_advance_chain (fields, DATA_FIELD);
- data_value = fold_convert (TREE_TYPE (data_field), null_pointer_node);
- }
- return get_descriptor_init (type, ts, rank, attr, data_value);
-}
-
-
-vec<constructor_elt, va_gc> *
-get_default_scalar_descriptor_init (tree type, gfc_typespec &ts, int rank,
- const symbol_attribute &attr, tree value)
-{
- return get_descriptor_init (type, ts, rank, attr, value);
+ return get_descriptor_init (type, ts, rank, attr, default_init (attr));
}
@@ -726,10 +767,7 @@ vec<constructor_elt, va_gc> *
get_null_array_descriptor_init (tree type, gfc_typespec &ts, int rank,
const symbol_attribute &attr)
{
- symbol_attribute attr2 = attr;
- attr2.pointer = 0;
-
- return get_default_array_descriptor_init (type, ts, rank, attr2);
+ return get_descriptor_init (type, ts, rank, attr, nullification (ts));
}
@@ -740,8 +778,8 @@ gfc_build_default_array_descriptor (tree type, gfc_typespec
&ts, int rank,
gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
return build_constructor (type,
- get_default_array_descriptor_init (type, ts, rank,
- attr));
+ get_descriptor_init (type, ts, rank, attr,
+ default_init (attr)));
}
@@ -1017,8 +1055,31 @@ gfc_clear_descriptor (stmtblock_t *block, gfc_symbol
*sym, tree descriptor)
void
-gfc_clear_scalar_descriptor (stmtblock_t *block, tree descriptor,
- gfc_symbol *sym, tree value)
+gfc_clear_descriptor (stmtblock_t *block, gfc_symbol *sym,
+ gfc_expr *expr, tree descriptor)
+{
+ symbol_attribute attr;
+
+ gfc_array_spec *as = sym->ts.type == BT_CLASS
+ ? CLASS_DATA (sym)->as
+ : sym->as;
+ int rank = as == nullptr
+ ? 0
+ : as->type == AS_ASSUMED_RANK
+ ? expr->rank
+ : as->rank;
+
+ attr = gfc_symbol_attr (sym);
+
+ init_struct (block, descriptor,
+ get_null_array_descriptor_init (TREE_TYPE (descriptor),
+ expr->ts, rank, attr));
+}
+
+
+void
+gfc_set_scalar_descriptor (stmtblock_t *block, tree descriptor,
+ gfc_symbol *sym, gfc_expr *expr, tree value)
{
symbol_attribute attr;
@@ -1026,7 +1087,7 @@ gfc_clear_scalar_descriptor (stmtblock_t *block, tree
descriptor,
init_struct (block, descriptor,
get_descriptor_init (TREE_TYPE (descriptor), sym->ts, 0,
- attr, value));
+ attr, scalar_value (expr->ts, value)));
}
@@ -1553,12 +1614,8 @@ gfc_get_array_span (tree desc, gfc_expr *expr)
void
gfc_trans_static_array_pointer (gfc_symbol * sym)
{
- tree type;
-
gcc_assert (TREE_STATIC (sym->backend_decl));
- /* Just zero the data member. */
- type = TREE_TYPE (sym->backend_decl);
- DECL_INITIAL (sym->backend_decl) = gfc_build_null_descriptor (type);
+ gfc_clear_descriptor (nullptr, sym, sym->backend_decl);
}
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index c6e4b2c63a5d..4b3c4c644924 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -141,8 +141,9 @@ void gfc_conv_resolve_dependencies (gfc_loopinfo *, gfc_ss
*, gfc_ss *);
/* Build a null array descriptor constructor. */
tree gfc_build_null_descriptor (tree);
tree gfc_build_default_class_descriptor (tree, gfc_typespec &);
-void gfc_clear_descriptor (stmtblock_t *block, gfc_symbol *sym, tree
descriptor);
-void gfc_clear_scalar_descriptor (stmtblock_t *block, tree, gfc_symbol *,
tree);
+void gfc_clear_descriptor (stmtblock_t *block, gfc_symbol *, tree);
+void gfc_clear_descriptor (stmtblock_t *block, gfc_symbol *, gfc_expr *, tree);
+void gfc_set_scalar_descriptor (stmtblock_t *block, tree, gfc_symbol *,
gfc_expr *, tree);
/* Get a single array element. */
void gfc_conv_array_ref (gfc_se *, gfc_array_ref *, gfc_expr *, locus *);
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index ce8392b7547b..758c45b7d347 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -106,7 +106,7 @@ get_scalar_to_descriptor_type (tree scalar,
symbol_attribute attr)
tree
-gfc_conv_scalar_null_to_descriptor (gfc_se *se, gfc_symbol *sym, tree scalar)
+gfc_conv_scalar_null_to_descriptor (gfc_se *se, gfc_symbol *sym, gfc_expr
*expr, tree scalar)
{
symbol_attribute attr = sym->attr;
@@ -124,7 +124,7 @@ gfc_conv_scalar_null_to_descriptor (gfc_se *se, gfc_symbol
*sym, tree scalar)
if (!POINTER_TYPE_P (TREE_TYPE (scalar)))
scalar = gfc_build_addr_expr (NULL_TREE, scalar);
- gfc_clear_scalar_descriptor (&se->pre, desc, sym, scalar);
+ gfc_set_scalar_descriptor (&se->pre, desc, sym, expr, scalar);
/* Copy pointer address back - but only if it could have changed and
if the actual argument is a pointer and not, e.g., NULL(). */
@@ -136,6 +136,42 @@ gfc_conv_scalar_null_to_descriptor (gfc_se *se, gfc_symbol
*sym, tree scalar)
}
+tree
+gfc_conv_null_array_descriptor (gfc_se *se, gfc_symbol *sym, gfc_expr *expr)
+{
+#if 0
+ symbol_attribute attr = sym->attr;
+#endif
+ tree lower[GFC_MAX_DIMENSIONS], upper[GFC_MAX_DIMENSIONS];
+
+ for (int i = 0; i < expr->rank; i++)
+ {
+ lower[i] = gfc_index_zero_node;
+ upper[i] = gfc_index_one_node;
+ }
+
+ tree elt_type = gfc_typenode_for_spec (&sym->ts);
+ tree desc_type = gfc_get_array_type_bounds (elt_type, expr->rank, 0,
+ lower, upper, 0,
+ GFC_ARRAY_UNKNOWN, false);
+ tree desc = gfc_create_var (desc_type, "desc");
+ DECL_ARTIFICIAL (desc) = 1;
+
+ gfc_clear_descriptor (&se->pre, sym, expr, desc);
+
+#if 0
+ /* Copy pointer address back - but only if it could have changed and
+ if the actual argument is a pointer and not, e.g., NULL(). */
+ if ((attr.pointer || attr.allocatable) && attr.intent != INTENT_IN)
+ gfc_add_modify (&se->post, scalar,
+ fold_convert (TREE_TYPE (scalar),
+ gfc_conv_descriptor_data_get (desc)));
+#endif
+
+ return desc;
+}
+
+
tree
gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr)
{
@@ -6431,7 +6467,10 @@ conv_null_actual (gfc_se * parmse, gfc_expr * e,
gfc_symbol * fsym)
if (fsym->as && fsym->as->type == AS_ASSUMED_RANK)
{
tree tmp = parmse->expr;
- tmp = gfc_conv_scalar_null_to_descriptor (parmse, fsym, tmp);
+ if (e->rank == 0)
+ tmp = gfc_conv_scalar_null_to_descriptor (parmse, fsym, e, tmp);
+ else
+ tmp = gfc_conv_null_array_descriptor (parmse, fsym, e);
parmse->expr = gfc_build_addr_expr (NULL_TREE, tmp);
}
else
