Fortran: Allow PDT parameterized procedure pointer components [PR89707]

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

gcc/fortran
	PR fortran/89707
	* decl.cc (gfc_get_pdt_instance): Copy the typebound procedure
	field from the PDT template. If the template interface has
	kind=0, provide the new instance with an interface with a type
	spec that points to that of the parameterized component.
	(match_ppc_decl): When 'saved_kind_expr' this is a PDT and the
	expression should be copied to the component kind_expr.
	* gfortran.h: Define gfc_get_tbp.

gcc/testsuite/
	PR fortran/89707
	* gfortran.dg/pdt_43.f03: New test.

diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc
index 1e91b57aa96d915a50824630a885f65201678f98..fcbbc2f8c6e253096f16eac0345e9400d341df25 100644 (file)
--- a/gcc/fortran/decl.cc
+++ b/gcc/fortran/decl.cc
@@ -4076,6 +4076,11 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym,
 
       c2->ts = c1->ts;
       c2->attr = c1->attr;
+      if (c1->tb)
+       {
+         c2->tb = gfc_get_tbp ();
+         c2->tb = c1->tb;
+       }
 
       /* The order of declaration of the type_specs might not be the
         same as that of the components.  */
@@ -4163,6 +4168,17 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym,
                         c2->ts.kind, gfc_basic_typename (c2->ts.type));
              goto error_return;
            }
+         if (c2->attr.proc_pointer && c2->attr.function
+             && c1->ts.interface && c1->ts.interface->ts.kind == 0)
+           {
+             c2->ts.interface = gfc_new_symbol ("", gfc_current_ns);
+             c2->ts.interface->result = c2->ts.interface;
+             c2->ts.interface->ts = c2->ts;
+             c2->ts.interface->attr.flavor = FL_PROCEDURE;
+             c2->ts.interface->attr.function = 1;
+             c2->attr.function = 1;
+             c2->attr.if_source = IFSRC_UNKNOWN;
+           }
        }
 
       /* Similarly, set the string length if parameterized.  */
@@ -7573,6 +7589,9 @@ match_ppc_decl (void)
          *c->tb = *tb;
        }
 
+      if (saved_kind_expr)
+       c->kind_expr = gfc_copy_expr (saved_kind_expr);
+
       /* Set interface.  */
       if (proc_if != NULL)
        {

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 2644cd8221087f288510013adbac1c9c9e3517df..482031d2600560c7cfb05f900188d029345aed42 100644 (file)
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -1916,6 +1916,7 @@ typedef struct gfc_typebound_proc
 }
 gfc_typebound_proc;
 
+#define gfc_get_tbp() XCNEW (gfc_typebound_proc)
 
 /* Symbol nodes.  These are important things.  They are what the
    standard refers to as "entities".  The possibly multiple names that

diff --git a/gcc/testsuite/gfortran.dg/pdt_43.f03 b/gcc/testsuite/gfortran.dg/pdt_43.f03
new file mode 100644 (file)
index 0000000..c9f2502
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pdt_43.f03
@@ -0,0 +1,28 @@
+! { dg-do run )
+!
+! Test the fix for PR89707 in which the procedure pointer component
+! with a parameterized KIND expression caused an ICE in resolution.
+!
+! Contributed by Janus Weil  <janus@gcc.gnu.org>
+!
+program pdt_with_ppc
+  integer, parameter :: kt = kind (0d0)
+  type :: q(k)
+     integer, kind :: k = 4
+     procedure (real(kind=kt)), pointer, nopass :: p
+  end type
+  type (q(kt)) :: x
+  x%p => foo
+  if (int (x%p(2d0)) /= 4) stop 1
+  x%p => bar
+  if (int (x%p(2d0, 4d0)) /= 16) stop 2
+contains
+  real(kind=kt) function foo (x)
+    real(kind = kt) :: x
+    foo = 2.0 * x
+  end
+  real(kind=kt) function bar (x, y)
+    real(kind = kt) :: x, y
+    bar = x ** y
+  end
+end