https://gcc.gnu.org/g:9b35083d58c92a70a47c16be0d1d84d09f7a6e23
commit 9b35083d58c92a70a47c16be0d1d84d09f7a6e23
Author: Mikael Morin <mik...@gcc.gnu.org>
Date: Fri May 30 15:33:58 2025 +0200
Correction régression char_length_23
Diff:
---
gcc/fortran/Make-lang.in | 2 +-
gcc/fortran/trans-descriptor.cc | 123 +++++++++++++++-
gcc/fortran/trans-types.cc | 307 +++++++++++++++++++++++-----------------
3 files changed, 299 insertions(+), 133 deletions(-)
diff --git a/gcc/fortran/Make-lang.in b/gcc/fortran/Make-lang.in
index 2ddb0366e9dc..2914855eb225 100644
--- a/gcc/fortran/Make-lang.in
+++ b/gcc/fortran/Make-lang.in
@@ -45,7 +45,7 @@ GFORTRAN_TARGET_INSTALL_NAME :=
$(target_noncanonical)-$(shell echo gfortran|sed
#^L
# Use strict warnings for this front end.
-fortran-warn = $(STRICT_WARN)
+fortran-warn = $(STRICT_WARN) -Wno-error=infinite-recursion
# These are the groups of object files we have. The F95_PARSER_OBJS are
# all the front end files, the F95_OBJS are the files for the translation
diff --git a/gcc/fortran/trans-descriptor.cc b/gcc/fortran/trans-descriptor.cc
index 3fdc2f4c5d72..d2f882d7076c 100644
--- a/gcc/fortran/trans-descriptor.cc
+++ b/gcc/fortran/trans-descriptor.cc
@@ -174,6 +174,85 @@ gfc_get_cfi_dim_sm (tree desc, tree idx)
#define UBOUND_SUBFIELD 2
+static tree
+substitute_placeholder_in_type (tree type, tree root_struct)
+{
+ tree type_size = TYPE_SIZE (type);
+ tree modified_type_size = SUBSTITUTE_PLACEHOLDER_IN_EXPR (type_size,
+ root_struct);
+ tree type_size_unit = TYPE_SIZE_UNIT (type);
+ tree modified_type_size_unit = SUBSTITUTE_PLACEHOLDER_IN_EXPR
(type_size_unit,
+ root_struct);
+
+ switch (TREE_CODE (type))
+ {
+ case POINTER_TYPE:
+ {
+ tree subtype = TREE_TYPE (type);
+ tree modified_subtype = substitute_placeholder_in_type (subtype,
+ root_struct);
+ if (modified_subtype == subtype
+ && modified_type_size == type_size
+ && modified_type_size_unit == type_size_unit)
+ return type;
+ else
+ return build_pointer_type (modified_subtype);
+ }
+ break;
+
+ case ARRAY_TYPE:
+ {
+ tree elt_type = TREE_TYPE (type);
+ tree modified_elt_type = substitute_placeholder_in_type (elt_type,
+ root_struct);
+ tree idx_type = TYPE_DOMAIN (type);
+ tree modified_idx_type = substitute_placeholder_in_type (idx_type,
+ root_struct);
+ if (modified_elt_type == elt_type
+ && modified_idx_type == idx_type
+ && modified_type_size == type_size
+ && modified_type_size_unit == type_size_unit)
+ return type;
+ else
+ {
+ tree new_type = build_array_type (modified_elt_type,
+ modified_idx_type);
+ TYPE_STRING_FLAG (new_type) = TYPE_STRING_FLAG (type);
+ return new_type;
+ }
+ }
+ break;
+
+ case INTEGER_TYPE:
+ {
+ tree min_val = TYPE_MIN_VALUE (type);
+ tree modified_min_val = SUBSTITUTE_PLACEHOLDER_IN_EXPR (min_val,
+ root_struct);
+ tree max_val = TYPE_MAX_VALUE (type);
+ tree modified_max_val = SUBSTITUTE_PLACEHOLDER_IN_EXPR (max_val,
+ root_struct);
+ if (modified_min_val == min_val
+ && modified_max_val == max_val
+ && modified_type_size == type_size
+ && modified_type_size_unit == type_size_unit)
+ return type;
+ else
+ {
+ tree new_type = build_range_type (type, modified_min_val,
+ modified_max_val);
+ TYPE_SIZE (new_type) = modified_type_size;
+ TYPE_SIZE_UNIT (new_type) = modified_type_size_unit;
+ return new_type;
+ }
+ }
+ break;
+
+ default:
+ gcc_unreachable ();
+ }
+}
+
+
namespace gfc_descriptor
{
@@ -223,7 +302,11 @@ conv_data_get (tree desc)
gcc_assert (TREE_CODE (type) != REFERENCE_TYPE);
tree field = get_data (desc);
- tree t = fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type), field);
+ tree target_type = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
+ gcc_assert (TREE_CODE (target_type) == POINTER_TYPE);
+ if (type_contains_placeholder_p (TREE_TYPE (target_type)))
+ target_type = substitute_placeholder_in_type (target_type, desc);
+ tree t = fold_convert (target_type, field);
return non_lvalue_loc (input_location, t);
}
@@ -3025,6 +3108,42 @@ gfc_conv_descriptor_cosize (tree desc, int rank, int
corank)
}
+static bool
+placeholder_free_element_type (tree type)
+{
+ if (!GFC_DESCRIPTOR_TYPE_P (type))
+ return true;
+
+ tree data_ptr_type = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
+ gcc_assert (TREE_CODE (data_ptr_type) == POINTER_TYPE);
+
+ return !type_contains_placeholder_p (TREE_TYPE (data_ptr_type));
+}
+
+
+static tree
+get_descriptor_dtype (tree desc, int * prank)
+{
+ tree type = TREE_TYPE (desc);
+
+ if (placeholder_free_element_type (type))
+ return gfc_get_dtype (type, prank);
+ else
+ {
+ tree data_ptr_type = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
+ data_ptr_type = substitute_placeholder_in_type (data_ptr_type, desc);
+
+ gcc_assert (TREE_CODE (data_ptr_type) == POINTER_TYPE);
+ tree etype = TREE_TYPE (data_ptr_type);
+ if (TREE_CODE (etype) == ARRAY_TYPE && ! TYPE_STRING_FLAG (etype))
+ etype = TREE_TYPE (etype);
+
+ int rank = prank ? *prank : GFC_TYPE_ARRAY_RANK (type);
+ return gfc_get_dtype_rank_type (rank, etype);
+ }
+}
+
+
void
gfc_set_descriptor (stmtblock_t *block, tree dest, tree src, gfc_expr
*src_expr,
int rank, int corank, gfc_ss *ss, gfc_array_info *info,
@@ -3064,7 +3183,7 @@ gfc_set_descriptor (stmtblock_t *block, tree dest, tree
src, gfc_expr *src_expr,
dtype = gfc_conv_descriptor_dtype_get (tmp2);
}
else
- dtype = gfc_get_dtype (TREE_TYPE (src), &rank);
+ dtype = get_descriptor_dtype (src, &rank);
gfc_conv_descriptor_dtype_set (block, dest, dtype);
/* The 1st element in the section. */
diff --git a/gcc/fortran/trans-types.cc b/gcc/fortran/trans-types.cc
index ff19922638c8..cec5869603f5 100644
--- a/gcc/fortran/trans-types.cc
+++ b/gcc/fortran/trans-types.cc
@@ -2992,7 +2992,6 @@ gfc_get_derived_type (gfc_symbol * derived, int codimen)
{
tree typenode = NULL, field = NULL, field_type = NULL;
tree canonical = NULL_TREE, class_canonical = NULL_TREE;
- tree *chain = NULL;
bool got_canonical = false;
bool self_is_canonical = false;
bool unlimited_entity = false;
@@ -3216,142 +3215,190 @@ gfc_get_derived_type (gfc_symbol * derived, int
codimen)
through only the top-level linked list of components so we correctly
build UNION_TYPE nodes for BT_UNION components. MAPs and other nested
types are built as part of gfc_get_union_type. */
- for (c = derived->components; c; c = c->next)
- {
- bool same_alloc_type = c->attr.allocatable
- && derived == c->ts.u.derived;
- /* Prevent infinite recursion, when the procedure pointer type is
- the same as derived, by forcing the procedure pointer component to
- be built as if the explicit interface does not exist. */
- if (c->attr.proc_pointer
- && (c->ts.type != BT_DERIVED || (c->ts.u.derived
- && !gfc_compare_derived_types (derived, c->ts.u.derived)))
- && (c->ts.type != BT_CLASS || (CLASS_DATA (c)->ts.u.derived
- && !gfc_compare_derived_types (derived, CLASS_DATA
(c)->ts.u.derived))))
- field_type = gfc_get_ppc_type (c);
- else if (c->attr.proc_pointer && derived->backend_decl)
- {
- tmp = build_function_type (derived->backend_decl, NULL_TREE);
- field_type = build_pointer_type (tmp);
- }
- else if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
- field_type = c->ts.u.derived->backend_decl;
- else if (c->attr.caf_token)
- field_type = pvoid_type_node;
- else
- {
- if (c->ts.type == BT_CHARACTER
- && !c->ts.deferred && !c->attr.pdt_string)
- {
- /* Evaluate the string length. */
- gfc_conv_const_charlen (c->ts.u.cl);
- gcc_assert (c->ts.u.cl->backend_decl);
- }
+ {
+ auto_vec <tree> fields;
- field_type = gfc_typenode_for_spec (&c->ts, codimen);
- }
+ unsigned i;
+ bool do_loop = true;
+ while (do_loop)
+ {
+ do_loop = false;
+ for (c = derived->components, i = 0; c; c = c->next, i++)
+ {
+ if (c->backend_decl)
+ continue;
- /* This returns an array descriptor type. Initialization may be
- required. */
- if ((c->attr.dimension || c->attr.codimension) && !c->attr.proc_pointer )
- {
- if (c->attr.pointer || c->attr.allocatable || c->attr.pdt_array)
- {
- enum gfc_array_kind akind;
- bool is_ptr = ((c == derived->components
- && derived->components->ts.type == BT_DERIVED
- && startswith (derived->name, "__class")
- && (strcmp (derived->components->name, "_data")
- == 0))
- ? c->attr.class_pointer : c->attr.pointer);
- if (is_ptr)
- akind = c->attr.contiguous ? GFC_ARRAY_POINTER_CONT
- : GFC_ARRAY_POINTER;
- else if (c->attr.allocatable)
- akind = GFC_ARRAY_ALLOCATABLE;
- else if (c->as->type == AS_ASSUMED_RANK)
- akind = GFC_ARRAY_ASSUMED_RANK;
- else
- /* FIXME – see PR fortran/104651. Additionally, the following
- gfc_build_array_type should use !is_ptr instead of
- c->attr.pointer and codim unconditionally without '? :'. */
- akind = GFC_ARRAY_ASSUMED_SHAPE;
-
- /* Use char as array element type for unlimited_polymorphic
- entities. */
- if (c->ts.type == BT_DERIVED
- && c->ts.u.derived->attr.unlimited_polymorphic
- && field_type == ptr_type_node)
- field_type = char_type_node;
-
- bt type_type = derived->attr.is_class
- && strcmp (c->name, "_data") == 0
- ? BT_CLASS : c->ts.type;
-
- /* Pointers to arrays aren't actually pointer types. The
- descriptors are separate, but the data is common. Every
- array pointer in a coarray derived type needs to provide space
- for the coarray management, too. Therefore treat coarrays
- and pointers to coarrays in derived types the same. */
- field_type = gfc_build_array_type
- (
- field_type, c->as, akind, !c->attr.target && !c->attr.pointer,
- c->attr.contiguous,
- c->attr.codimension || c->attr.pointer ? codimen : 0,
- type_type
- );
- }
- else
- field_type = gfc_get_nodesc_array_type (field_type, c->as,
- PACKED_STATIC,
- !c->attr.target,
- c->ts.type);
- }
- else if ((c->attr.pointer || c->attr.allocatable || c->attr.pdt_string)
- && !c->attr.proc_pointer
- && !(unlimited_entity && c == derived->components))
- field_type = build_pointer_type (field_type);
-
- if (c->attr.pointer || same_alloc_type)
- field_type = gfc_nonrestricted_type (field_type);
-
- /* vtype fields can point to different types to the base type. */
- if (c->ts.type == BT_DERIVED
- && c->ts.u.derived && c->ts.u.derived->attr.vtype)
- field_type = build_pointer_type_for_mode (TREE_TYPE (field_type),
- ptr_mode, true);
-
- /* Ensure that the CLASS language specific flag is set. */
- if (c->ts.type == BT_CLASS)
- {
- if (POINTER_TYPE_P (field_type))
- GFC_CLASS_TYPE_P (TREE_TYPE (field_type)) = 1;
- else
- GFC_CLASS_TYPE_P (field_type) = 1;
- }
+ bool same_alloc_type = c->attr.allocatable
+ && derived == c->ts.u.derived;
+ /* Prevent infinite recursion, when the procedure pointer type is
+ the same as derived, by forcing the procedure pointer component
to
+ be built as if the explicit interface does not exist. */
+ if (c->attr.proc_pointer
+ && (c->ts.type != BT_DERIVED || (c->ts.u.derived
+ && !gfc_compare_derived_types (derived,
c->ts.u.derived)))
+ && (c->ts.type != BT_CLASS || (CLASS_DATA (c)->ts.u.derived
+ && !gfc_compare_derived_types (derived, CLASS_DATA
(c)->ts.u.derived))))
+ field_type = gfc_get_ppc_type (c);
+ else if (c->attr.proc_pointer && derived->backend_decl)
+ {
+ tmp = build_function_type (derived->backend_decl, NULL_TREE);
+ field_type = build_pointer_type (tmp);
+ }
+ else if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
+ field_type = c->ts.u.derived->backend_decl;
+ else if (c->attr.caf_token)
+ field_type = pvoid_type_node;
+ else
+ {
+ if (c->ts.type == BT_CHARACTER
+ && !c->ts.deferred && !c->attr.pdt_string)
+ {
+ /* Evaluate the string length. */
+ gfc_conv_const_charlen (c->ts.u.cl);
+ gcc_assert (c->ts.u.cl->backend_decl);
+ }
- field = gfc_add_field_to_struct (typenode,
- get_identifier (c->name),
- field_type, &chain);
- if (GFC_LOCUS_IS_SET (c->loc))
- gfc_set_decl_location (field, &c->loc);
- else if (GFC_LOCUS_IS_SET (derived->declared_at))
- gfc_set_decl_location (field, &derived->declared_at);
+ field_type = gfc_typenode_for_spec (&c->ts, codimen);
+ tree strlen_field;
+ if (gfc_deferred_strlen (c, &strlen_field))
+ {
+ if (strlen_field == nullptr)
+ {
+ do_loop = true;
+ continue;
+ }
+
+ gcc_assert (TREE_CODE (field_type) == ARRAY_TYPE);
+ if (TYPE_MAX_VALUE (TYPE_DOMAIN (field_type)) == NULL_TREE)
+ {
+ tree domain_type = TYPE_DOMAIN (field_type);
+ domain_type = build_distinct_type_copy (domain_type);
+ field_type = build_distinct_type_copy (field_type);
+ TYPE_DOMAIN (field_type) = domain_type;
+ tree max = build3 (COMPONENT_REF, TREE_TYPE
(strlen_field),
+ build0 (PLACEHOLDER_EXPR, typenode),
+ strlen_field, NULL_TREE);
+ TYPE_MAX_VALUE (domain_type) = max;
+ }
+ }
+ }
- gfc_finish_decl_attrs (field, &c->attr);
+ /* This returns an array descriptor type. Initialization may be
+ required. */
+ if ((c->attr.dimension || c->attr.codimension) &&
!c->attr.proc_pointer )
+ {
+ if (c->attr.pointer || c->attr.allocatable || c->attr.pdt_array)
+ {
+ enum gfc_array_kind akind;
+ bool is_ptr = ((c == derived->components
+ && derived->components->ts.type ==
BT_DERIVED
+ && startswith (derived->name, "__class")
+ && (strcmp (derived->components->name,
"_data")
+ == 0))
+ ? c->attr.class_pointer : c->attr.pointer);
+ if (is_ptr)
+ akind = c->attr.contiguous ? GFC_ARRAY_POINTER_CONT
+ : GFC_ARRAY_POINTER;
+ else if (c->attr.allocatable)
+ akind = GFC_ARRAY_ALLOCATABLE;
+ else if (c->as->type == AS_ASSUMED_RANK)
+ akind = GFC_ARRAY_ASSUMED_RANK;
+ else
+ /* FIXME – see PR fortran/104651. Additionally, the
following
+ gfc_build_array_type should use !is_ptr instead of
+ c->attr.pointer and codim unconditionally without '?
:'. */
+ akind = GFC_ARRAY_ASSUMED_SHAPE;
+
+ /* Use char as array element type for unlimited_polymorphic
+ entities. */
+ if (c->ts.type == BT_DERIVED
+ && c->ts.u.derived->attr.unlimited_polymorphic
+ && field_type == ptr_type_node)
+ field_type = char_type_node;
+
+ bt type_type = derived->attr.is_class
+ && strcmp (c->name, "_data") == 0
+ ? BT_CLASS : c->ts.type;
+
+ /* Pointers to arrays aren't actually pointer types. The
+ descriptors are separate, but the data is common. Every
+ array pointer in a coarray derived type needs to provide
space
+ for the coarray management, too. Therefore treat
coarrays
+ and pointers to coarrays in derived types the same. */
+ field_type = gfc_build_array_type
+ (
+ field_type, c->as, akind, !c->attr.target &&
!c->attr.pointer,
+ c->attr.contiguous,
+ c->attr.codimension || c->attr.pointer ? codimen : 0,
+ type_type
+ );
+ }
+ else
+ field_type = gfc_get_nodesc_array_type (field_type, c->as,
+ PACKED_STATIC,
+ !c->attr.target,
+ c->ts.type);
+ }
+ else if ((c->attr.pointer || c->attr.allocatable ||
c->attr.pdt_string)
+ && !c->attr.proc_pointer
+ && !(unlimited_entity && c == derived->components))
+ field_type = build_pointer_type (field_type);
+
+ if (c->attr.pointer || same_alloc_type)
+ field_type = gfc_nonrestricted_type (field_type);
+
+ /* vtype fields can point to different types to the base type. */
+ if (c->ts.type == BT_DERIVED
+ && c->ts.u.derived && c->ts.u.derived->attr.vtype)
+ field_type = build_pointer_type_for_mode (TREE_TYPE
(field_type),
+ ptr_mode, true);
+
+ /* Ensure that the CLASS language specific flag is set. */
+ if (c->ts.type == BT_CLASS)
+ {
+ if (POINTER_TYPE_P (field_type))
+ GFC_CLASS_TYPE_P (TREE_TYPE (field_type)) = 1;
+ else
+ GFC_CLASS_TYPE_P (field_type) = 1;
+ }
- DECL_PACKED (field) |= TYPE_PACKED (typenode);
+ field = gfc_add_field_to_struct (typenode,
+ get_identifier (c->name),
+ field_type, nullptr);
+ if (i >= fields.length ())
+ fields.safe_grow_cleared (i + 1);
- gcc_assert (field);
- /* Overwrite for class array to supply different bounds for different
- types. */
- if (class_coarray_flag || !c->backend_decl || c->attr.caf_token)
- c->backend_decl = field;
+ fields[i] = field;
- if (c->attr.pointer && (c->attr.dimension || c->attr.codimension)
- && !(c->ts.type == BT_DERIVED && strcmp (c->name, "_data") == 0))
- GFC_DECL_PTR_ARRAY_P (c->backend_decl) = 1;
- }
+ if (GFC_LOCUS_IS_SET (c->loc))
+ gfc_set_decl_location (field, &c->loc);
+ else if (GFC_LOCUS_IS_SET (derived->declared_at))
+ gfc_set_decl_location (field, &derived->declared_at);
+
+ gfc_finish_decl_attrs (field, &c->attr);
+
+ DECL_PACKED (field) |= TYPE_PACKED (typenode);
+
+ gcc_assert (field);
+ /* Overwrite for class array to supply different bounds for
different
+ types. */
+ if (class_coarray_flag || !c->backend_decl || c->attr.caf_token)
+ c->backend_decl = field;
+
+ if (c->attr.pointer && (c->attr.dimension || c->attr.codimension)
+ && !(c->ts.type == BT_DERIVED && strcmp (c->name, "_data") ==
0))
+ GFC_DECL_PTR_ARRAY_P (c->backend_decl) = 1;
+ }
+ }
+
+ tree* ptr = &TYPE_FIELDS (typenode);
+ for (c = derived->components, i = 0; c; c = c->next, i++)
+ {
+ tree field = fields[i];
+ *ptr = field;
+ ptr = &DECL_CHAIN (field);
+ }
+ }
if (derived->attr.is_class)
GFC_CLASS_TYPE_P (typenode) = 1;
