https://gcc.gnu.org/g:f7dee170ba6d37aba6a9e1fa73711e4e03e42990
commit r16-3529-gf7dee170ba6d37aba6a9e1fa73711e4e03e42990
Author: Paul Thomas <pa...@gcc.gnu.org>
Date: Tue Sep 2 21:51:33 2025 +0100
Fortran: Allow PDT parameterized procedure pointer components [PR89707]
2025-09-02 Paul Thomas <pa...@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:
---
gcc/fortran/decl.cc | 19 +++++++++++++++++++
gcc/fortran/gfortran.h | 1 +
gcc/testsuite/gfortran.dg/pdt_43.f03 | 28 ++++++++++++++++++++++++++++
3 files changed, 48 insertions(+)
diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc
index 1e91b57aa96d..fcbbc2f8c6e2 100644
--- 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 2644cd822108..482031d26005 100644
--- 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
index 000000000000..c9f25021ab90
--- /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 <ja...@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
