https://gcc.gnu.org/g:c7cdf4adf4da35194d460805953e62ef70384a43
commit c7cdf4adf4da35194d460805953e62ef70384a43
Author: Mikael Morin <mik...@gcc.gnu.org>
Date: Thu Dec 12 20:44:58 2024 +0100
Sauvegarde compilation OK
Diff:
---
gcc/fortran/trans-array.cc | 247 +++++++++++++++++++++++++++++++++++++++------
gcc/fortran/trans-array.h | 1 +
gcc/fortran/trans-expr.cc | 38 ++++++-
3 files changed, 250 insertions(+), 36 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 4a686e8bf20b..a9b2d19b355a 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -656,8 +656,8 @@ build_dtype (gfc_typespec &ts, int rank, const
symbol_attribute &)
/* Build a null array descriptor constructor. */
vec<constructor_elt, va_gc> *
-get_default_descriptor_init (tree type, gfc_typespec &ts, int rank,
- const symbol_attribute &attr)
+get_descriptor_init (tree type, gfc_typespec &ts, int rank,
+ const symbol_attribute &attr, tree data_value)
{
vec<constructor_elt, va_gc> *v = nullptr;
@@ -666,10 +666,9 @@ get_default_descriptor_init (tree type, gfc_typespec &ts,
int rank,
tree fields = TYPE_FIELDS (type);
/* Don't init pointers by default. */
- if (!attr.pointer)
+ if (data_value)
{
tree data_field = gfc_advance_chain (fields, DATA_FIELD);
- tree data_value = fold_convert (TREE_TYPE (data_field),
null_pointer_node);
CONSTRUCTOR_APPEND_ELT (v, data_field, data_value);
}
@@ -694,43 +693,73 @@ get_default_descriptor_init (tree type, gfc_typespec &ts,
int rank,
vec<constructor_elt, va_gc> *
-get_null_descriptor_init (tree type, gfc_typespec &ts, int rank,
- const symbol_attribute &attr)
+get_default_array_descriptor_init (tree type, gfc_typespec &ts, int rank,
+ const symbol_attribute &attr)
+{
+ 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)
+ {
+ 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);
+}
+
+
+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_descriptor_init (type, ts, rank, attr2);
+ return get_default_array_descriptor_init (type, ts, rank, attr2);
}
tree
-gfc_build_default_descriptor (tree type, gfc_typespec &ts, int rank,
- const symbol_attribute &attr)
+gfc_build_default_array_descriptor (tree type, gfc_typespec &ts, int rank,
+ const symbol_attribute &attr)
{
gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
return build_constructor (type,
- get_default_descriptor_init (type, ts, rank, attr));
+ get_default_array_descriptor_init (type, ts, rank,
+ attr));
}
tree
-gfc_build_null_descriptor (tree type, gfc_typespec &ts, int rank,
- const symbol_attribute &attr)
+gfc_build_null_array_descriptor (tree type, gfc_typespec &ts, int rank,
+ const symbol_attribute &attr)
{
gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
return build_constructor (type,
- get_null_descriptor_init (type, ts, rank, attr));
+ get_null_array_descriptor_init (type, ts, rank,
+ attr));
}
tree
-gfc_build_null_descriptor (tree type, gfc_typespec &ts,
- const symbol_attribute &attr)
+gfc_build_null_array_descriptor (tree type, gfc_typespec &ts,
+ const symbol_attribute &attr)
{
- return gfc_build_null_descriptor (type, ts, -1, attr);
+ return gfc_build_null_array_descriptor (type, ts, -1, attr);
}
@@ -754,10 +783,10 @@ gfc_build_default_class_descriptor (tree type,
gfc_typespec &ts)
&& flag_coarray != GFC_FCOARRAY_LIB))
{
gcc_assert (GFC_DESCRIPTOR_TYPE_P (data_type));
- data_value = gfc_build_null_descriptor (data_type,
- ts,
-
ts.u.derived->components->as->rank,
- ts.u.derived->components->attr);
+ gfc_component *data_comp = ts.u.derived->components;
+ data_value = gfc_build_null_array_descriptor (data_type, ts,
+ data_comp->as->rank,
+ data_comp->attr);
}
else
{
@@ -797,12 +826,159 @@ gfc_clear_descriptor (gfc_expr *var_ref, gfc_se &var)
attr = gfc_expr_attr (var_ref);
gfc_add_modify (&var.pre, var.expr,
- gfc_build_null_descriptor (TREE_TYPE (var.expr), var_ref->ts,
- rank, attr));
+ gfc_build_null_array_descriptor (TREE_TYPE (var.expr),
+ var_ref->ts,
+ rank, attr));
}
-void
+static int
+field_count (tree type)
+{
+ gcc_assert (TREE_CODE (type) == RECORD_TYPE);
+
+ int count = 0;
+ tree field = TYPE_FIELDS (type);
+ while (field != NULL_TREE)
+ {
+ count++;
+ field = DECL_CHAIN (field);
+ }
+
+ return count;
+}
+
+
+bool
+complete_init_p (tree type, vec<constructor_elt, va_gc> *init_values)
+{
+ return (unsigned) field_count (type) == vec_safe_length (init_values);
+}
+
+
+static bool
+modifiable_p (tree data_ref)
+{
+ switch (TREE_CODE (data_ref))
+ {
+ case CONST_DECL:
+ return false;
+
+ case VAR_DECL:
+ case PARM_DECL:
+ case RESULT_DECL:
+ return !TREE_CONSTANT (data_ref) && !TREE_READONLY (data_ref);
+
+ case COMPONENT_REF:
+ {
+ tree field_decl = TREE_OPERAND (data_ref, 1);
+
+ if (TREE_CONSTANT (field_decl) || TREE_READONLY (field_decl))
+ return false;
+ }
+
+ /* fallthrough */
+ case ARRAY_REF:
+ case ARRAY_RANGE_REF:
+ case REALPART_EXPR:
+ case IMAGPART_EXPR:
+ case VIEW_CONVERT_EXPR:
+ case NOP_EXPR:
+ {
+ tree parent_ref = TREE_OPERAND (data_ref, 0);
+ return modifiable_p (parent_ref);
+ }
+
+ default:
+ gcc_unreachable ();
+ }
+}
+
+
+typedef enum
+{
+ SINGLE,
+ MULTIPLE
+} init_kind;
+
+typedef union
+{
+ tree single;
+ vec<constructor_elt, va_gc> *multiple;
+} init_values;
+
+static void
+init_struct (stmtblock_t *block, tree data_ref, tree value);
+
+static void
+init_struct (stmtblock_t *block, tree data_ref, init_kind kind,
+ init_values values)
+{
+ tree type = TREE_TYPE (data_ref);
+ gcc_assert (TREE_CODE (type) == RECORD_TYPE);
+
+ if (kind == SINGLE)
+ {
+ tree value = values.single;
+ if (TREE_STATIC (data_ref)
+ || !modifiable_p (data_ref))
+ DECL_INITIAL (data_ref) = value;
+ else if (TREE_CODE (value) == CONSTRUCTOR)
+ {
+ unsigned i;
+ tree field, field_init;
+ FOR_EACH_CONSTRUCTOR_ELT (CONSTRUCTOR_ELTS (value), i, field,
field_init)
+ {
+ tree ref = fold_build3_loc (input_location, COMPONENT_REF,
+ TREE_TYPE (field), data_ref,
+ field, NULL_TREE);
+ init_struct (block, ref, field_init);
+ }
+ }
+ else
+ gfc_add_modify (block, data_ref, value);
+ }
+ else if (TREE_STATIC (data_ref))
+ return init_struct (block, data_ref,
+ build_constructor (type, values.multiple));
+ else
+ {
+ unsigned i;
+ constructor_elt *ce;
+ FOR_EACH_VEC_ELT (*values.multiple, i, ce)
+ {
+ tree field_decl = ce->index;
+ tree ref = fold_build3_loc (input_location, COMPONENT_REF,
+ TREE_TYPE (field_decl), data_ref,
+ field_decl, NULL_TREE);
+ init_struct (block, ref, ce->value);
+ }
+ }
+}
+
+
+static void
+init_struct (stmtblock_t *block, tree data_ref, tree value)
+{
+ init_values wrapped_values;
+ wrapped_values.single = value;
+
+ return init_struct (block, data_ref, SINGLE, wrapped_values);
+}
+
+
+static void
+init_struct (stmtblock_t *block, tree data_ref,
+ vec<constructor_elt, va_gc> *values)
+{
+ init_values wrapped_values;
+ wrapped_values.multiple = values;
+
+ return init_struct (block, data_ref, MULTIPLE, wrapped_values);
+}
+
+
+static void
set_from_constructor_elts (stmtblock_t *block, tree data_ref,
vec<constructor_elt, va_gc> *constructor_values)
{
@@ -831,14 +1007,23 @@ gfc_clear_descriptor (stmtblock_t *block, gfc_symbol
*sym, tree descriptor)
attr = gfc_symbol_attr (sym);
- if (TREE_STATIC (descriptor))
- gfc_add_modify (block, descriptor,
- gfc_build_null_descriptor (TREE_TYPE (descriptor), sym->ts,
- rank, attr));
- else
- set_from_constructor_elts (block, descriptor,
- get_null_descriptor_init (TREE_TYPE (descriptor),
- sym->ts, rank, attr));
+ init_struct (block, descriptor,
+ get_null_array_descriptor_init (TREE_TYPE (descriptor),
+ sym->ts, rank, attr));
+}
+
+
+void
+gfc_clear_scalar_descriptor (stmtblock_t *block, tree descriptor,
+ gfc_symbol *sym, tree value)
+{
+ symbol_attribute attr;
+
+ attr = gfc_symbol_attr (sym);
+
+ init_struct (block, descriptor,
+ get_descriptor_init (TREE_TYPE (descriptor), sym->ts, 0,
+ attr, value));
}
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 58b7a6aec336..c6e4b2c63a5d 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -142,6 +142,7 @@ void gfc_conv_resolve_dependencies (gfc_loopinfo *, gfc_ss
*, gfc_ss *);
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);
/* 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 dcbc75844fda..ce8392b7547b 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -104,6 +104,38 @@ get_scalar_to_descriptor_type (tree scalar,
symbol_attribute attr)
akind, !(attr.pointer || attr.target));
}
+
+tree
+gfc_conv_scalar_null_to_descriptor (gfc_se *se, gfc_symbol *sym, tree scalar)
+{
+ symbol_attribute attr = sym->attr;
+
+ tree type = get_scalar_to_descriptor_type (scalar, attr);
+ tree desc = gfc_create_var (type, "desc");
+ DECL_ARTIFICIAL (desc) = 1;
+
+ if (CONSTANT_CLASS_P (scalar))
+ {
+ tree tmp;
+ tmp = gfc_create_var (TREE_TYPE (scalar), "scalar");
+ gfc_add_modify (&se->pre, tmp, scalar);
+ scalar = tmp;
+ }
+ if (!POINTER_TYPE_P (TREE_TYPE (scalar)))
+ scalar = gfc_build_addr_expr (NULL_TREE, scalar);
+
+ gfc_clear_scalar_descriptor (&se->pre, desc, sym, 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(). */
+ 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)));
+ return desc;
+}
+
+
tree
gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr)
{
@@ -6398,12 +6430,8 @@ conv_null_actual (gfc_se * parmse, gfc_expr * e,
gfc_symbol * fsym)
correct rank. */
if (fsym->as && fsym->as->type == AS_ASSUMED_RANK)
{
- tree rank;
tree tmp = parmse->expr;
- tmp = gfc_conv_scalar_to_descriptor (parmse, tmp, fsym->attr);
- rank = gfc_conv_descriptor_rank (tmp);
- gfc_add_modify (&parmse->pre, rank,
- build_int_cst (TREE_TYPE (rank), e->rank));
+ tmp = gfc_conv_scalar_null_to_descriptor (parmse, fsym, tmp);
parmse->expr = gfc_build_addr_expr (NULL_TREE, tmp);
}
else
