https://gcc.gnu.org/g:ed1958ed286978288928eae14f0001b22fbf8309
commit ed1958ed286978288928eae14f0001b22fbf8309
Author: Mikael Morin <mik...@gcc.gnu.org>
Date: Mon Mar 10 10:08:37 2025 +0100
Renseignement type canonique pour descripteurs de classe.
Diff:
---
gcc/fortran/class.cc | 75 ++++++++++++++++++++++++++++++----------------
gcc/fortran/gfortran.h | 2 ++
gcc/fortran/trans-types.cc | 60 +++++++++++++++++++++++++++++++++++++
3 files changed, 112 insertions(+), 25 deletions(-)
diff --git a/gcc/fortran/class.cc b/gcc/fortran/class.cc
index df18601e45bd..41be63bf768f 100644
--- a/gcc/fortran/class.cc
+++ b/gcc/fortran/class.cc
@@ -632,6 +632,51 @@ gfc_get_len_component (gfc_expr *e, int k)
}
+gfc_namespace *
+gfc_class_namespace (gfc_symbol * derived)
+{
+ if (derived->attr.unlimited_polymorphic)
+ {
+ /* Find the top-level namespace. */
+ for (gfc_namespace * ns = gfc_current_ns; ns; ns = ns->parent)
+ if (!ns->parent)
+ return ns;
+
+ gcc_unreachable ();
+ }
+ else
+ return derived->ns;
+}
+
+
+char *
+gfc_class_name (gfc_symbol *derived, int rank, int corank,
+ bool allocatable, bool pointer)
+{
+ char tname[GFC_MAX_SYMBOL_LEN+1];
+ char * name;
+
+ get_unique_hashed_string (tname, derived);
+ if (rank == -1)
+ rank = GFC_MAX_DIMENSIONS;
+ bool array = rank != 0 || corank != 0;
+ if (array && allocatable)
+ name = xasprintf ("__class_%s_%d_%da", tname, rank, corank);
+ else if (array && pointer)
+ name = xasprintf ("__class_%s_%d_%dp", tname, rank, corank);
+ else if (array)
+ name = xasprintf ("__class_%s_%d_%dt", tname, rank, corank);
+ else if (pointer)
+ name = xasprintf ("__class_%s_p", tname);
+ else if (allocatable)
+ name = xasprintf ("__class_%s_a", tname);
+ else
+ name = xasprintf ("__class_%s_t", tname);
+
+ return name;
+}
+
+
/* Build a polymorphic CLASS entity, using the symbol that comes from
build_sym. A CLASS entity is represented by an encapsulating type,
which contains the declared type as '_data' component, plus a pointer
@@ -644,7 +689,6 @@ bool
gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
gfc_array_spec **as)
{
- char tname[GFC_MAX_SYMBOL_LEN+1];
char *name;
gfc_typespec *orig_ts = ts;
gfc_symbol *fclass;
@@ -683,34 +727,15 @@ gfc_build_class_symbol (gfc_typespec *ts,
symbol_attribute *attr,
return true;
/* Determine the name of the encapsulating type. */
- rank = !(*as) || (*as)->rank == -1 ? GFC_MAX_DIMENSIONS : (*as)->rank;
+ rank = !(*as) ? 0 : (*as)->rank == -1 ? GFC_MAX_DIMENSIONS : (*as)->rank;
if (!ts->u.derived)
return false;
- get_unique_hashed_string (tname, ts->u.derived);
- if ((*as) && attr->allocatable)
- name = xasprintf ("__class_%s_%d_%da", tname, rank, (*as)->corank);
- else if ((*as) && attr->pointer)
- name = xasprintf ("__class_%s_%d_%dp", tname, rank, (*as)->corank);
- else if ((*as))
- name = xasprintf ("__class_%s_%d_%dt", tname, rank, (*as)->corank);
- else if (attr->pointer)
- name = xasprintf ("__class_%s_p", tname);
- else if (attr->allocatable)
- name = xasprintf ("__class_%s_a", tname);
- else
- name = xasprintf ("__class_%s_t", tname);
-
- if (ts->u.derived->attr.unlimited_polymorphic)
- {
- /* Find the top-level namespace. */
- for (ns = gfc_current_ns; ns; ns = ns->parent)
- if (!ns->parent)
- break;
- }
- else
- ns = ts->u.derived->ns;
+ int corank = (*as) == nullptr ? 0 : (*as)->corank;
+ name = gfc_class_name (ts->u.derived, rank, corank,
+ attr->allocatable, attr->pointer);
+ ns = gfc_class_namespace (ts->u.derived);
/* Although this might seem to be counterintuitive, we can build separate
class types with different array specs because the TKR interface checks
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 6b9c11b44f3e..063687cf5c84 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -4165,6 +4165,8 @@ bool gfc_is_class_container_ref (gfc_expr *e);
gfc_expr *gfc_class_initializer (gfc_typespec *, gfc_expr *);
unsigned int gfc_hash_value (gfc_symbol *);
gfc_expr *gfc_get_len_component (gfc_expr *e, int);
+char * gfc_class_name (gfc_symbol *, int, int, bool, bool);
+gfc_namespace *gfc_class_namespace (gfc_symbol *derived);
bool gfc_build_class_symbol (gfc_typespec *, symbol_attribute *,
gfc_array_spec **);
void gfc_change_class (gfc_typespec *, symbol_attribute *,
diff --git a/gcc/fortran/trans-types.cc b/gcc/fortran/trans-types.cc
index c22d9bffd27a..046239f4dabb 100644
--- a/gcc/fortran/trans-types.cc
+++ b/gcc/fortran/trans-types.cc
@@ -2831,6 +2831,60 @@ cobounds_match_decl (const gfc_symbol *derived)
return true;
}
+
+gfc_symbol *
+get_class_canonical_type (gfc_symbol *cls)
+{
+ gcc_assert (cls->attr.is_class);
+
+ gfc_component * data_comp = cls->components;
+
+ gfc_symbol *derived = data_comp->ts.u.derived;
+ int rank = data_comp->as ? data_comp->as->rank : 0;
+ int corank = data_comp->as ? data_comp->as->corank : 0;
+ const char *class_name = gfc_class_name (derived, rank, corank, 0, 0);
+
+ gfc_namespace *ns = gfc_class_namespace (derived);
+
+ gfc_symbol *canonical_class = nullptr;
+ gfc_find_symbol (class_name, ns, 0, &canonical_class);
+
+ if (canonical_class != nullptr)
+ return canonical_class;
+
+ gfc_typespec ts;
+ memset (&ts, 0, sizeof (ts));
+ ts.type = BT_CLASS;
+ ts.u.derived = derived;
+
+ symbol_attribute attr;
+ memset (&attr, 0, sizeof (attr));
+ attr.dummy = 1;
+ attr.dimension = derived->attr.dimension;
+ attr.codimension = derived->attr.codimension;
+
+ gfc_array_spec as;
+ gfc_array_spec *pas;
+ if (data_comp->as)
+ {
+ memset (&as, 0, sizeof (as));
+ as.type = AS_DEFERRED;
+ as.rank = data_comp->as->rank;
+ as.corank = data_comp->as->corank;
+
+ pas = &as;
+ }
+ else
+ pas = nullptr;
+
+ gfc_build_class_symbol (&ts, &attr, &pas);
+
+ gfc_find_symbol (class_name, ns, 0, &canonical_class);
+
+ return canonical_class;
+}
+
+
/* Build a tree node for a derived type. If there are equal
derived types, with different local names, these are built
at the same time. If an equal derived type has been built
@@ -3179,6 +3233,12 @@ gfc_get_derived_type (gfc_symbol * derived, int codimen)
/* Now lay out the derived type, including the fields. */
if (canonical)
TYPE_CANONICAL (typenode) = canonical;
+ else if (derived->attr.is_class)
+ {
+ gfc_symbol * canonical_sym = get_class_canonical_type (derived);
+ if (canonical_sym != nullptr)
+ TYPE_CANONICAL (typenode) = gfc_get_derived_type (canonical_sym,
codimen);
+ }
gfc_finish_type (typenode);
gfc_set_decl_location (TYPE_STUB_DECL (typenode), &derived->declared_at);
