https://gcc.gnu.org/g:e1d862cbdaa4c3f4c9e16ba4728be03ca7d532de
commit e1d862cbdaa4c3f4c9e16ba4728be03ca7d532de
Author: Mikael Morin <mik...@gcc.gnu.org>
Date: Mon Mar 10 22:42:35 2025 +0100
Correction régression typebound_generic_6.f03
Diff:
---
gcc/alias.cc | 11 ++++++++++-
gcc/alias.h | 1 +
gcc/fortran/f95-lang.cc | 28 +++++++++++++++++++++++++++
gcc/fortran/trans-types.cc | 48 +++++++++++++++++++++++++++++++++++-----------
gcc/fortran/trans.h | 4 +++-
5 files changed, 79 insertions(+), 13 deletions(-)
diff --git a/gcc/alias.cc b/gcc/alias.cc
index 4f17664c15b3..b249588a9c59 100644
--- a/gcc/alias.cc
+++ b/gcc/alias.cc
@@ -972,11 +972,20 @@ get_alias_set (tree t)
set = lang_hooks.get_alias_set (t);
if (set != -1)
return set;
+ else
+ return get_default_alias_set (t);
+}
+
+alias_set_type
+get_default_alias_set (tree t)
+{
+ alias_set_type set;
+
/* There are no objects of FUNCTION_TYPE, so there's no point in
using up an alias set for them. (There are, of course, pointers
and references to functions, but that's different.) */
- else if (TREE_CODE (t) == FUNCTION_TYPE || TREE_CODE (t) == METHOD_TYPE)
+ if (TREE_CODE (t) == FUNCTION_TYPE || TREE_CODE (t) == METHOD_TYPE)
set = 0;
/* Unless the language specifies otherwise, let vector types alias
diff --git a/gcc/alias.h b/gcc/alias.h
index 7c2e33eaa73e..6271dcc7089a 100644
--- a/gcc/alias.h
+++ b/gcc/alias.h
@@ -42,6 +42,7 @@ int compare_base_decls (tree, tree);
bool refs_same_for_tbaa_p (tree, tree);
bool mems_same_for_tbaa_p (rtx, rtx);
bool view_converted_memref_p (tree);
+alias_set_type get_default_alias_set (tree);
/* This alias set can be used to force a memory to conflict with all
other memories, creating a barrier across which no memory reference
diff --git a/gcc/fortran/f95-lang.cc b/gcc/fortran/f95-lang.cc
index 124d62f45295..c5098a24102a 100644
--- a/gcc/fortran/f95-lang.cc
+++ b/gcc/fortran/f95-lang.cc
@@ -40,6 +40,7 @@ along with GCC; see the file COPYING3. If not see
#include "trans-types.h"
#include "trans-const.h"
#include "attribs.h"
+#include "alias.h"
/* Language-dependent contents of an identifier. */
@@ -78,6 +79,8 @@ static void gfc_finish (void);
static void gfc_be_parse_file (void);
static void gfc_init_ts (void);
static tree gfc_builtin_function (tree);
+static alias_set_type gfc_get_alias_set (tree t);
+
/* Handle an "omp declare target" attribute; arguments as in
struct attribute_spec.handler. */
@@ -134,6 +137,7 @@ gfc_get_sarif_source_language (const char *)
#undef LANG_HOOKS_TYPE_FOR_MODE
#undef LANG_HOOKS_TYPE_FOR_SIZE
#undef LANG_HOOKS_INIT_TS
+#undef LANG_HOOKS_GET_ALIAS_SET
#undef LANG_HOOKS_OMP_ARRAY_DATA
#undef LANG_HOOKS_OMP_ARRAY_SIZE
#undef LANG_HOOKS_OMP_IS_ALLOCATABLE_OR_PTR
@@ -174,6 +178,7 @@ gfc_get_sarif_source_language (const char *)
#define LANG_HOOKS_TYPE_FOR_MODE gfc_type_for_mode
#define LANG_HOOKS_TYPE_FOR_SIZE gfc_type_for_size
#define LANG_HOOKS_INIT_TS gfc_init_ts
+#define LANG_HOOKS_GET_ALIAS_SET gfc_get_alias_set
#define LANG_HOOKS_OMP_ARRAY_DATA gfc_omp_array_data
#define LANG_HOOKS_OMP_ARRAY_SIZE gfc_omp_array_size
#define LANG_HOOKS_OMP_IS_ALLOCATABLE_OR_PTR gfc_omp_is_allocatable_or_ptr
@@ -303,6 +308,29 @@ gfc_finish (void)
return;
}
+
+static alias_set_type
+gfc_get_alias_set (tree t)
+{
+ if (!TYPE_P (t))
+ return -1;
+
+ if (!GFC_CLASS_TYPE_P (t))
+ return -1;
+
+ if (!(TYPE_LANG_SPECIFIC (t) && GFC_TYPE_PARENT_CLASS_TYPE (t)))
+ return -1;
+
+ alias_set_type new_set = get_default_alias_set (t);
+ TYPE_ALIAS_SET (t) = new_set;
+ tree parent_wrapper_type = GFC_TYPE_PARENT_CLASS_TYPE (t);
+ alias_set_type parent_set = get_alias_set (parent_wrapper_type);
+
+ record_alias_subset (parent_set, new_set);
+ return new_set;
+}
+
+
/* These functions and variables deal with binding contours. We only
need these functions for the list of PARM_DECLs, but we leave the
functions more general; these are a simplified version of the
diff --git a/gcc/fortran/trans-types.cc b/gcc/fortran/trans-types.cc
index 046239f4dabb..7bdc9902cae8 100644
--- a/gcc/fortran/trans-types.cc
+++ b/gcc/fortran/trans-types.cc
@@ -2833,15 +2833,8 @@ cobounds_match_decl (const gfc_symbol *derived)
gfc_symbol *
-get_class_canonical_type (gfc_symbol *cls)
+get_class_canonical_type (gfc_symbol *derived, int rank, int corank)
{
- 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);
@@ -2865,12 +2858,12 @@ get_class_canonical_type (gfc_symbol *cls)
gfc_array_spec as;
gfc_array_spec *pas;
- if (data_comp->as)
+ if (rank != 0 || corank != 0)
{
memset (&as, 0, sizeof (as));
as.type = AS_DEFERRED;
- as.rank = data_comp->as->rank;
- as.corank = data_comp->as->corank;
+ as.rank = rank;
+ as.corank = corank;
pas = &as;
}
@@ -2885,6 +2878,21 @@ get_class_canonical_type (gfc_symbol *cls)
}
+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;
+
+ return get_class_canonical_type (derived, rank, corank);
+}
+
+
/* 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
@@ -3238,6 +3246,24 @@ gfc_get_derived_type (gfc_symbol * derived, int codimen)
gfc_symbol * canonical_sym = get_class_canonical_type (derived);
if (canonical_sym != nullptr)
TYPE_CANONICAL (typenode) = gfc_get_derived_type (canonical_sym,
codimen);
+ gfc_component * data_comp = derived->components;
+ gfc_symbol *orig_type = data_comp->ts.u.derived;
+ if (orig_type->attr.extension)
+ {
+ int rank = data_comp->as ? data_comp->as->rank : 0;
+ int corank = data_comp->as ? data_comp->as->corank : 0;
+
+ gfc_symbol * parent_type = orig_type->components->ts.u.derived;
+ gfc_symbol * parent_wrapper = get_class_canonical_type (parent_type,
+ rank, corank);
+ if (parent_wrapper != nullptr)
+ {
+ tree wrapper_decl = gfc_get_derived_type (parent_wrapper,
codimen);
+ if (!TYPE_LANG_SPECIFIC (typenode))
+ TYPE_LANG_SPECIFIC (typenode) = ggc_cleared_alloc<struct
lang_type> ();
+ GFC_TYPE_PARENT_CLASS_TYPE (typenode) = wrapper_decl;
+ }
+ }
}
gfc_finish_type (typenode);
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 17a882d16dd2..9144acce7342 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -1035,6 +1035,7 @@ struct GTY(()) lang_type {
tree nonrestricted_type;
tree caf_token;
tree caf_offset;
+ tree parent_class_wrapper_type;
};
struct GTY(()) lang_decl {
@@ -1113,7 +1114,8 @@ struct GTY(()) lang_decl {
(TYPE_LANG_SPECIFIC(node)->dataptr_type)
#define GFC_TYPE_ARRAY_BASE_DECL(node, internal) \
(TYPE_LANG_SPECIFIC(node)->base_decl[(internal)])
-
+#define GFC_TYPE_PARENT_CLASS_TYPE(node) \
+ (TYPE_LANG_SPECIFIC(node)->parent_class_wrapper_type)
/* Build an expression with void type. */
#define build1_v(code, arg) \
