Fortran: Prevent direct references to PDT instances [PR108663]

2026-02-15  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran
	PR fortran/108663
	* decl.cc (gfc_get_pdt_instance): Use PDT_PREFIX and
	PDT_PREFIX_LEN.
	* gfortran.h : Define PDT_PREFIX and PDT_PREFIX_LEN. Note that
	PDT_PREFIX must have at least two upper case letters.
	* module.cc (read_module): Use PDT_PREFIX and PDT_PREFIX_LEN.
	* resolve.cc (resolve_typebound_procedure): Both pdt_template
	and pdt_type resolve_bindings_derived dummies should be tested
	for LEN type parameters being assumed.
	* symbol.cc (gfc_pdt_is_instance_of): Update preceding comment
	and use PDT_PREFIX_LEN.

gcc/testsuite
	PR fortran/108663
	* gfortran.dg/pdt_15.f03: Modify tree dump test for new prefix.
	* gfortran.dg/pdt_71.f03: Ditto.
	* gfortran.dg/pdt_79.f03: Ditto.
	* gfortran.dg/pdt_84.f03: New test.

diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc
index 2908007d75c66bf44fda2d1b658b03669a730a78..cb6bd6f8cc05eb2b8c6b8df2026e844d15ead34a 100644 (file)
--- a/gcc/fortran/decl.cc
+++ b/gcc/fortran/decl.cc
@@ -3960,10 +3960,9 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym,
   /* Pointers to the parameter specification being used.  */
   gfc_actual_arglist *actual_param;
   gfc_actual_arglist *tail = NULL;
-  /* Used to build up the name of the PDT instance. The prefix uses 4
+  /* Used to build up the name of the PDT instance. The prefix uses 3
      characters and each KIND parameter 2 more.  Allow 8 of the latter. */
-  char name[GFC_MAX_SYMBOL_LEN + 21];
-
+  char name[GFC_MAX_SYMBOL_LEN + PDT_PREFIX_LEN + 16];
   bool name_seen = (param_list == NULL);
   bool assumed_seen = false;
   bool deferred_seen = false;
@@ -3980,7 +3979,7 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym,
 
   type_param_name_list = pdt->formal;
   actual_param = param_list;
-  sprintf (name, "Pdt%s", pdt->name);
+  sprintf (name, "%s%s", PDT_PREFIX, pdt->name);
 
   /* Prevent a PDT component of the same type as the template from being
      converted into an instance. Doing this results in the component being

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 109bf6a5c294c0493e85adee6a8bad688bb576b8..c9242a3adccb98e46de6c21a996394bc8397a836 100644 (file)
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -4310,6 +4310,8 @@ bool gfc_may_be_finalized (gfc_typespec);
        (expr && expr->expr_type == EXPR_VARIABLE \
         && expr->symtree->n.sym->assoc \
         && expr->symtree->n.sym->assoc->inferred_type)
+#define PDT_PREFIX "PDT"
+#define PDT_PREFIX_LEN 3
 #define IS_PDT(sym) \
        (sym != NULL && sym->ts.type == BT_DERIVED \
         && sym->ts.u.derived \

diff --git a/gcc/fortran/module.cc b/gcc/fortran/module.cc
index 47b1c9431323045430caf0109ce736d85c7a051d..04ddf6b4476b17bd388c3fbe34fc84921f80d8d9 100644 (file)
--- a/gcc/fortran/module.cc
+++ b/gcc/fortran/module.cc
@@ -5843,13 +5843,14 @@ read_module (void)
          /* Include pdt_types if their associated pdt_template is in a
             USE, ONLY list.  */
          if (p == NULL && name[0] == 'P'
-             && startswith (name, "Pdt")
+             && startswith (name, PDT_PREFIX)
              && module_list)
            {
              gfc_use_list *ml = module_list;
              for (; ml; ml = ml->next)
                if (ml->rename
-                   && !strncmp (&name[3], ml->rename->use_name,
+                   && !strncmp (&name[PDT_PREFIX_LEN],
+                                ml->rename->use_name,
                                 strlen (ml->rename->use_name)))
                  p = name;
            }

diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index d98c2d65476402b8d906a1edfed0fd206b233bc7..655db8a1c9cf87e7d04930efb526d4245de07e67 100644 (file)
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -16701,9 +16701,10 @@ resolve_typebound_procedure (gfc_symtree* stree)
          goto error;
        }
 
-      if (resolve_bindings_derived->attr.pdt_template
-         && gfc_pdt_is_instance_of (resolve_bindings_derived,
-                                    CLASS_DATA (me_arg)->ts.u.derived)
+      if (((resolve_bindings_derived->attr.pdt_template
+           && gfc_pdt_is_instance_of (resolve_bindings_derived,
+                                      CLASS_DATA (me_arg)->ts.u.derived))
+          || resolve_bindings_derived->attr.pdt_type)
           && (me_arg->param_list != NULL)
           && (gfc_spec_list_type (me_arg->param_list,
                                  CLASS_DATA(me_arg)->ts.u.derived)

diff --git a/gcc/fortran/symbol.cc b/gcc/fortran/symbol.cc
index d521bf1012b6eaad5bc2793b82ba87441bf399d2..5a68f44ca635969ca541e4be823c632820527f91 100644 (file)
--- a/gcc/fortran/symbol.cc
+++ b/gcc/fortran/symbol.cc
@@ -5467,14 +5467,14 @@ gfc_type_is_extension_of (gfc_symbol *t1, gfc_symbol *t2)
    gfc_symbol *t2 -> pdt instance to be verified.
 
    In decl.cc, gfc_get_pdt_instance, a pdt instance is given a 3 character
-   prefix "Pdt", followed by an underscore list of the kind parameters,
+   prefix PDT_PREFIX, followed by an underscore list of the kind parameters,
    up to a maximum of 8 kind parameters.  To verify if a PDT Type corresponds
    to the template, this functions extracts t2's derive_type name,
    and compares it to the derive_type name of t1 for compatibility.
 
    For example:
 
-   t2->name = Pdtf_2_2; extract out the 'f' and compare with t1->name.  */
+   t2->name = PDT_PREFIXf_2_2; extract the 'f' and compare with t1->name.  */
 
 bool
 gfc_pdt_is_instance_of (gfc_symbol *t1, gfc_symbol *t2)
@@ -5483,7 +5483,8 @@ gfc_pdt_is_instance_of (gfc_symbol *t1, gfc_symbol *t2)
     return false;
 
   /* Limit comparison to length of t1->name to ignore new kind params.  */
-  if ( !(strncmp (&(t2->name[3]), t1->name, strlen (t1->name)) == 0) )
+  if ( !(strncmp (&(t2->name[PDT_PREFIX_LEN]), t1->name,
+                 strlen (t1->name)) == 0) )
     return false;
 
   return true;

diff --git a/gcc/testsuite/gfortran.dg/pdt_15.f03 b/gcc/testsuite/gfortran.dg/pdt_15.f03
index 17d4d37d3fa188b252b2706ab092203c3e34b092..f7ee691cfce6512026640be3b0517ce8427ffa02 100644 (file)
--- a/gcc/testsuite/gfortran.dg/pdt_15.f03
+++ b/gcc/testsuite/gfortran.dg/pdt_15.f03
@@ -101,6 +101,6 @@ contains
     if (int (pop_8 (root)) .ne. 0) STOP 4
   end subroutine
 end program ch2701
-! { dg-final { scan-tree-dump-times "Pdtlink_8._deallocate " 5 "original" } }
+! { dg-final { scan-tree-dump-times "PDTlink_8._deallocate " 5 "original" } }
 ! { dg-final { scan-tree-dump-times ".n.data = 0B" 9 "original" } }
 ! { dg-final { scan-tree-dump-times "__builtin_free" 15 "original" } }

diff --git a/gcc/testsuite/gfortran.dg/pdt_71.f03 b/gcc/testsuite/gfortran.dg/pdt_71.f03
index ec9cde067315fb0bd3cc2a70a8967ce4d366001c..06deed6ae15cffbdc2b88b7375befb02c80c62af 100644 (file)
--- a/gcc/testsuite/gfortran.dg/pdt_71.f03
+++ b/gcc/testsuite/gfortran.dg/pdt_71.f03
@@ -40,5 +40,5 @@ contains
     print *, kind (z%x%n), z%x%n
   end subroutine
 end
-! { dg-final { scan-tree-dump-times "Pdtt2_4.1.x.n = 8" 1 "original" } }
-! { dg-final { scan-tree-dump-times "z = Pdtt2_4.1" 1 "original" } }
+! { dg-final { scan-tree-dump-times "PDTt2_4.1.x.n = 8" 1 "original" } }
+! { dg-final { scan-tree-dump-times "z = PDTt2_4.1" 1 "original" } }

diff --git a/gcc/testsuite/gfortran.dg/pdt_79.f03 b/gcc/testsuite/gfortran.dg/pdt_79.f03
index 16b40fe6576cf100efe7d5db1bf0aaaa06870c67..68c1810918b11e0faa0dd3e50f231927bcd19331 100644 (file)
--- a/gcc/testsuite/gfortran.dg/pdt_79.f03
+++ b/gcc/testsuite/gfortran.dg/pdt_79.f03
@@ -57,5 +57,5 @@ contains
   end subroutine                ! { dg-warning ".mapped_tensor. is used uninitialized" }
 
 end
-! { dg-final { scan-tree-dump-times "Pdttensor_t_4.2.j = 42" 1 "original" } }
-! { dg-final { scan-tree-dump-times "struct Pdttensor_t_4 mt" 1 "original" } }
+! { dg-final { scan-tree-dump-times "PDTtensor_t_4.2.j = 42" 1 "original" } }
+! { dg-final { scan-tree-dump-times "struct PDTtensor_t_4 mt" 1 "original" } }

diff --git a/gcc/testsuite/gfortran.dg/pdt_84.f03 b/gcc/testsuite/gfortran.dg/pdt_84.f03
new file mode 100644 (file)
index 0000000..a473cb8
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pdt_84.f03
@@ -0,0 +1,28 @@
+! { dg-do compile }
+!
+! Test the fix for PR108663
+!
+! Contributed by
+!
+module m
+   type t(n)
+      integer, len :: n
+      integer :: a(n)
+   end type
+contains
+   subroutine s(x, arr)
+      type(t(2)) :: x
+      integer :: arr(2)
+      if (any (x%a /= arr)) stop 1
+   end
+end
+program p
+   use m, only: t, pdtt, s       ! { dg-error "not found in module" }
+
+   type(t(2)) :: y = t(2)([1,2])
+   type (pdtt)  :: z             ! { dg-error "being used before it is defined" }
+
+   call s(y, [1,2])
+   y = t(2)([3,4])
+   call s(y, [3,4])
+end