[gcc(refs/users/mikael/heads/refactor_descriptor_v03)] Correction dynamic_dispatch_4.f03.

[Mikael Morin via Gcc-cvs]

https://gcc.gnu.org/g:8aff8a58d16fb6d5771f6889eb880b00d780f0fe

commit 8aff8a58d16fb6d5771f6889eb880b00d780f0fe
Author: Mikael Morin <mik...@gcc.gnu.org>
Date:   Tue Mar 11 21:43:38 2025 +0100

    Correction dynamic_dispatch_4.f03.

Diff:
---
 gcc/fortran/f95-lang.cc | 46 +++++++++++++++++++++++++++++++++++++++++-----
 1 file changed, 41 insertions(+), 5 deletions(-)

diff --git a/gcc/fortran/f95-lang.cc b/gcc/fortran/f95-lang.cc
index c5098a24102a..dec2485168b3 100644
--- a/gcc/fortran/f95-lang.cc
+++ b/gcc/fortran/f95-lang.cc
@@ -309,24 +309,60 @@ gfc_finish (void)
 }
 
 
+static bool
+is_non_root_class_wrapper_type (tree t)
+{
+  if (!TYPE_P (t))
+    return false;
+
+  if (!GFC_CLASS_TYPE_P (t))
+    return false;
+
+  if (!(TYPE_LANG_SPECIFIC (t) && GFC_TYPE_PARENT_CLASS_TYPE (t)))
+    return false;
+
+  return true;
+}
+
+
 static alias_set_type
 gfc_get_alias_set (tree t)
 {
   if (!TYPE_P (t))
     return -1;
 
-  if (!GFC_CLASS_TYPE_P (t))
-    return -1;
+  tree parent_type = NULL_TREE;
+  if (POINTER_TYPE_P (t))
+    {
+      tree pointee_type = TREE_TYPE (t);
+      if (!is_non_root_class_wrapper_type (pointee_type))
+       return -1;
 
-  if (!(TYPE_LANG_SPECIFIC (t) && GFC_TYPE_PARENT_CLASS_TYPE (t)))
+      tree parent_wrapper_type = GFC_TYPE_PARENT_CLASS_TYPE (pointee_type);
+      if (TREE_CODE (t) == REFERENCE_TYPE)
+       parent_type = build_reference_type (parent_wrapper_type);
+      else
+       parent_type = build_pointer_type (parent_wrapper_type);
+    }
+  else if (!is_non_root_class_wrapper_type (t))
     return -1;
+  else
+    parent_type = GFC_TYPE_PARENT_CLASS_TYPE (t);
 
   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);
+  alias_set_type parent_set = get_alias_set (parent_type);
 
   record_alias_subset (parent_set, new_set);
+  
+  if (!POINTER_TYPE_P (t))
+    {
+      alias_set_type parent_base_set = get_alias_set (TREE_TYPE (TYPE_FIELDS 
(parent_type)));
+      alias_set_type child_base_set = get_alias_set (TREE_TYPE (TYPE_FIELDS 
(t)));
+
+      record_alias_subset (parent_base_set, child_base_set);
+    }
+
   return new_set;
 }