Fortran: Handle PDTs correctly with unlimited selector [PR87669]

2025-09-02  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran
	PR fortran/87669
	* expr.cc (gfc_spec_list_type): If no LEN components are seen,
	unconditionally return 'SPEC_ASSUMED'. This suppresses an
	invalid error in match.cc(gfc_match_type_is).

gcc/testsuite/
	PR fortran/87669
	* gfortran.dg/pdt_42.f03: New test.

libgfortran/
	PR fortran/87669
	* intrinsics/extends_type_of.c (is_extension_of): Use the vptr
	rather than the hash value to identify the types.

diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc
index b8d04ff6f365af4cd163245275f8de4ae1e513bd..97f931a3792dd0a821cf83066d55f0e33cb23847 100644 (file)
--- a/gcc/fortran/expr.cc
+++ b/gcc/fortran/expr.cc
@@ -5911,6 +5911,7 @@ gfc_spec_list_type (gfc_actual_arglist *param_list, gfc_symbol *derived)
   gfc_component *c;
   bool seen_assumed = false;
   bool seen_deferred = false;
+  bool seen_len = false;
 
   if (derived == NULL)
     {
@@ -5932,10 +5933,12 @@ gfc_spec_list_type (gfc_actual_arglist *param_list, gfc_symbol *derived)
            return SPEC_EXPLICIT;
          seen_assumed = param_list->spec_type == SPEC_ASSUMED;
          seen_deferred = param_list->spec_type == SPEC_DEFERRED;
+         if (c->attr.pdt_len)
+           seen_len = true;
          if (seen_assumed && seen_deferred)
            return SPEC_EXPLICIT;
        }
-      res = seen_assumed ? SPEC_ASSUMED : SPEC_DEFERRED;
+      res = (seen_assumed || !seen_len) ? SPEC_ASSUMED : SPEC_DEFERRED;
     }
   return res;
 }

diff --git a/gcc/testsuite/gfortran.dg/pdt_42.f03 b/gcc/testsuite/gfortran.dg/pdt_42.f03
new file mode 100644 (file)
index 0000000..47743d1
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pdt_42.f03
@@ -0,0 +1,46 @@
+! { dg-do run )
+!
+! Test the fix for PR87669 in which SELECT TYPE was not identifying the difference
+! between derived types with different type kind parameters, when the selector
+! is unlimited polymorphic.
+!
+! Contributed by Etienne Descamps  <etdescdev@gmail.com>
+!
+Program Devtest
+  Type dvtype(k)
+    Integer, Kind :: k
+    Real(k) :: a, b, c
+  End Type dvtype
+  type(dvtype(8)) :: dv
+  type(dvtype(4)) :: fv
+  integer :: ctr = 0
+
+  dv%a = 1; dv%b = 2; dv%c = 3
+  call dvtype_print(dv)
+  if (ctr /= 2) stop 1
+
+  fv%a = 1; fv%b = 2; fv%c = 3
+  call dvtype_print(fv)
+  if (ctr /= 0) stop 2
+
+Contains
+  Subroutine dvtype_print(p)
+    class(*), intent(in) :: p
+    Select Type(p)
+    class is (dvtype(4))
+      ctr = ctr - 1
+    End Select
+    Select Type(p)
+    class is (dvtype(8))
+      ctr = ctr + 1
+    End Select
+    Select Type(p)
+    type is (dvtype(4))
+      ctr = ctr - 1
+    End Select
+    Select Type(p)
+    type is (dvtype(8))
+      ctr = ctr + 1
+    End Select
+  End Subroutine dvtype_print
+End

diff --git a/libgfortran/intrinsics/extends_type_of.c b/libgfortran/intrinsics/extends_type_of.c
index 8768b2d52c39e4c476a979114fbb96c4f7f96b80..dab14ee140fb82997a895b52b6846f284b0dc353 100644 (file)
--- a/libgfortran/intrinsics/extends_type_of.c
+++ b/libgfortran/intrinsics/extends_type_of.c
@@ -58,7 +58,7 @@ is_extension_of (struct vtype *v1, struct vtype *v2)
 
   while (v1)
     {
-      if (v1->hash == v2->hash) return 1;
+      if (v1 == v2) return 1;
       v1 = v1->extends;
     }
   return 0;