https://gcc.gnu.org/g:465827c5081a4abe42820829fcd3ad840ef6898c
commit 465827c5081a4abe42820829fcd3ad840ef6898c
Author: Mikael Morin <mik...@gcc.gnu.org>
Date: Fri Dec 6 22:05:58 2024 +0100
Utilisation méthode initialisation descripteur gfc_trans_deferred_array
Diff:
---
gcc/fortran/gfortran.h | 1 +
gcc/fortran/primary.cc | 87 +++++++++++++++--------
gcc/fortran/trans-array.cc | 169 ++++++++++++++++++++++++++++++++-------------
3 files changed, 179 insertions(+), 78 deletions(-)
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index d08439019a38..79d768a8d285 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -4023,6 +4023,7 @@ const char *gfc_dt_lower_string (const char *);
const char *gfc_dt_upper_string (const char *);
/* primary.cc */
+symbol_attribute gfc_symbol_attr (gfc_symbol *);
symbol_attribute gfc_variable_attr (gfc_expr *, gfc_typespec *);
symbol_attribute gfc_expr_attr (gfc_expr *);
symbol_attribute gfc_caf_attr (gfc_expr *, bool i = false, bool *r = NULL);
diff --git a/gcc/fortran/primary.cc b/gcc/fortran/primary.cc
index 1db27929eebd..cbc1eafdf768 100644
--- a/gcc/fortran/primary.cc
+++ b/gcc/fortran/primary.cc
@@ -2866,42 +2866,14 @@ check_substring:
}
-/* Given an expression that is a variable, figure out what the
- ultimate variable's type and attribute is, traversing the reference
- structures if necessary.
-
- This subroutine is trickier than it looks. We start at the base
- symbol and store the attribute. Component references load a
- completely new attribute.
-
- A couple of rules come into play. Subobjects of targets are always
- targets themselves. If we see a component that goes through a
- pointer, then the expression must also be a target, since the
- pointer is associated with something (if it isn't core will soon be
- dumped). If we see a full part or section of an array, the
- expression is also an array.
-
- We can have at most one full array reference. */
-
symbol_attribute
-gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
+gfc_symbol_attr (gfc_symbol *sym)
{
- int dimension, codimension, pointer, allocatable, target, optional;
+ int dimension, codimension, pointer, allocatable, target;
symbol_attribute attr;
- gfc_ref *ref;
- gfc_symbol *sym;
- gfc_component *comp;
- bool has_inquiry_part;
-
- if (expr->expr_type != EXPR_VARIABLE
- && expr->expr_type != EXPR_FUNCTION
- && !(expr->expr_type == EXPR_NULL && expr->ts.type != BT_UNKNOWN))
- gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
- sym = expr->symtree->n.sym;
attr = sym->attr;
- optional = attr.optional;
if (sym->ts.type == BT_CLASS && sym->attr.class_ok && sym->ts.u.derived)
{
dimension = CLASS_DATA (sym)->attr.dimension;
@@ -2937,6 +2909,61 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
target = 0;
}
+ attr.dimension = dimension;
+ attr.codimension = codimension;
+ attr.pointer = pointer;
+ attr.allocatable = allocatable;
+ attr.target = target;
+ attr.save = sym->attr.save;
+
+ return attr;
+}
+
+
+/* Given an expression that is a variable, figure out what the
+ ultimate variable's type and attribute is, traversing the reference
+ structures if necessary.
+
+ This subroutine is trickier than it looks. We start at the base
+ symbol and store the attribute. Component references load a
+ completely new attribute.
+
+ A couple of rules come into play. Subobjects of targets are always
+ targets themselves. If we see a component that goes through a
+ pointer, then the expression must also be a target, since the
+ pointer is associated with something (if it isn't core will soon be
+ dumped). If we see a full part or section of an array, the
+ expression is also an array.
+
+ We can have at most one full array reference. */
+
+symbol_attribute
+gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
+{
+ int dimension, codimension, pointer, allocatable, target, optional;
+ symbol_attribute attr;
+ gfc_ref *ref;
+ gfc_symbol *sym;
+ gfc_component *comp;
+ bool has_inquiry_part;
+
+ if (expr->expr_type != EXPR_VARIABLE
+ && expr->expr_type != EXPR_FUNCTION
+ && !(expr->expr_type == EXPR_NULL && expr->ts.type != BT_UNKNOWN))
+ gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
+
+ sym = expr->symtree->n.sym;
+ attr = gfc_symbol_attr (sym);
+
+ attr = sym->attr;
+
+ optional = attr.optional;
+ dimension = attr.dimension;
+ codimension = attr.codimension;
+ pointer = attr.pointer;
+ allocatable = attr.allocatable;
+ target = attr.target;
+
if (ts != NULL && expr->ts.type == BT_UNKNOWN)
*ts = sym->ts;
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 60c922bb871d..67da66268816 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -614,52 +614,122 @@ get_size_info (gfc_typespec &ts)
static tree
-build_dtype (gfc_typespec &ts, int rank, const symbol_attribute &)
+build_dtype (gfc_typespec &ts, int rank, const symbol_attribute &attr)
{
+ vec<constructor_elt, va_gc> *v = nullptr;
+
tree type = get_dtype_type_node ();
tree fields = TYPE_FIELDS (type);
- tree elem_len_field = gfc_advance_chain (fields, GFC_DTYPE_ELEM_LEN);
- tree elem_len_val = get_size_info (ts);
+ if (ts.type != BT_CLASS)
+ {
+ tree elem_len_field = gfc_advance_chain (fields, GFC_DTYPE_ELEM_LEN);
+ tree elem_len_val = get_size_info (ts);
+ CONSTRUCTOR_APPEND_ELT (v, elem_len_field, elem_len_val);
+ }
tree version_field = gfc_advance_chain (fields, GFC_DTYPE_VERSION);
tree version_val = build_int_cst (TREE_TYPE (version_field), 0);
+ CONSTRUCTOR_APPEND_ELT (v, version_field, version_val);
- tree rank_field = gfc_advance_chain (fields, GFC_DTYPE_RANK);
- tree rank_val = build_int_cst (TREE_TYPE (rank_field), rank);
+ if (rank != -1)
+ {
+ tree rank_field = gfc_advance_chain (fields, GFC_DTYPE_RANK);
+ tree rank_val = build_int_cst (TREE_TYPE (rank_field), rank);
+ CONSTRUCTOR_APPEND_ELT (v, rank_field, rank_val);
+ }
- 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));
+ if (ts.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));
+ CONSTRUCTOR_APPEND_ELT (v, type_info_field, type_info_val);
+ }
- return build_constructor_va (type, 4,
- elem_len_field, elem_len_val,
- version_field, version_val,
- rank_field, rank_val,
- type_info_field, type_info_val);
+ return build_constructor (type, v);
}
/* Build a null array descriptor constructor. */
-tree
-gfc_build_null_descriptor (tree type, gfc_typespec &ts, int rank,
- const symbol_attribute &attr)
+vec<constructor_elt, va_gc> *
+get_default_descriptor_init (tree type, gfc_typespec &ts, int rank,
+ const symbol_attribute &attr)
{
+ vec<constructor_elt, va_gc> *v = nullptr;
+
gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
gcc_assert (DATA_FIELD == 0);
tree fields = TYPE_FIELDS (type);
- tree data_field = gfc_advance_chain (fields, DATA_FIELD);
- tree data_value = fold_convert (TREE_TYPE (data_field), null_pointer_node);
+ /* Don't init pointers by default. */
+ if (!attr.pointer)
+ {
+ 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);
+ }
tree dtype_field = gfc_advance_chain (fields, DTYPE_FIELD);
tree dtype_value = build_dtype (ts, rank, attr);
+ CONSTRUCTOR_APPEND_ELT (v, dtype_field, dtype_value);
+
+ if (flag_coarray == GFC_FCOARRAY_LIB && attr.codimension)
+ {
+ /* Declare the variable static so its array descriptor stays present
+ after leaving the scope. It may still be accessed through another
+ image. This may happen, for example, with the caf_mpi
+ implementation. */
+ tree token_field = gfc_advance_chain (fields, CAF_TOKEN_FIELD);
+ tree token_value = fold_convert (TREE_TYPE (token_field),
+ null_pointer_node);
+ CONSTRUCTOR_APPEND_ELT (v, token_field, token_value);
+ }
+
+ return v;
+}
+
+
+vec<constructor_elt, va_gc> *
+get_null_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);
+}
+
+
+tree
+gfc_build_default_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));
+}
+
- return build_constructor_va (type, 2,
- data_field, data_value,
- dtype_field, dtype_value);
+tree
+gfc_build_null_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));
+}
+
+
+tree
+gfc_build_null_descriptor (tree type, gfc_typespec &ts,
+ const symbol_attribute &attr)
+{
+ return gfc_build_null_descriptor (type, ts, -1, attr);
}
@@ -679,6 +749,24 @@ gfc_clear_descriptor (gfc_expr *var_ref, gfc_se &var)
}
+void
+gfc_clear_descriptor (stmtblock_t *block, gfc_symbol *sym, tree descriptor)
+{
+ symbol_attribute attr;
+
+ gfc_array_spec *as = sym->ts.type == BT_CLASS
+ ? CLASS_DATA (sym)->as
+ : sym->as;
+ int rank = as != nullptr ? as->rank : 0;
+
+ attr = gfc_symbol_attr (sym);
+
+ gfc_add_modify (block, descriptor,
+ gfc_build_null_descriptor (TREE_TYPE (descriptor), sym->ts,
+ rank, attr));
+}
+
+
/* Build a null array descriptor constructor. */
tree
@@ -12145,36 +12233,21 @@ gfc_trans_deferred_array (gfc_symbol * sym,
gfc_wrapped_block * block)
}
/* NULLIFY the data pointer, for non-saved allocatables. */
- if (GFC_DESCRIPTOR_TYPE_P (type) && !sym->attr.save && sym->attr.allocatable)
+ if (GFC_DESCRIPTOR_TYPE_P (type) && !sym->attr.save
+ && (sym->attr.allocatable || sym->attr.pointer))
{
- gfc_conv_descriptor_data_set (&init, descriptor, null_pointer_node);
- if (flag_coarray == GFC_FCOARRAY_LIB && sym->attr.codimension)
- {
- /* Declare the variable static so its array descriptor stays present
- after leaving the scope. It may still be accessed through another
- image. This may happen, for example, with the caf_mpi
- implementation. */
- TREE_STATIC (descriptor) = 1;
- tmp = gfc_conv_descriptor_token (descriptor);
- gfc_add_modify (&init, tmp, fold_convert (TREE_TYPE (tmp),
- null_pointer_node));
- }
- }
-
- /* Set initial TKR for pointers and allocatables */
- if (GFC_DESCRIPTOR_TYPE_P (type)
- && (sym->attr.pointer || sym->attr.allocatable))
- {
- tree etype;
+ gfc_clear_descriptor (&init, sym, descriptor);
- gcc_assert (sym->as && sym->as->rank>=0);
- tmp = gfc_conv_descriptor_dtype (descriptor);
- etype = gfc_get_element_type (type);
- tmp = fold_build2_loc (input_location, MODIFY_EXPR,
- TREE_TYPE (tmp), tmp,
- gfc_get_dtype_rank_type (sym->as->rank, etype));
- gfc_add_expr_to_block (&init, tmp);
+ /* Declare the variable static so its array descriptor stays present
+ after leaving the scope. It may still be accessed through another
+ image. This may happen, for example, with the caf_mpi
+ implementation. */
+ if (flag_coarray == GFC_FCOARRAY_LIB
+ && sym->attr.codimension
+ && sym->attr.allocatable)
+ TREE_STATIC (descriptor) = 1;
}
+
input_location = loc;
gfc_init_block (&cleanup);
