From: Paul Thomas <pault@gcc.gnu.org>
Date: Wed, 29 Oct 2025 09:20:24 +0000 (+0000)
Subject: Fortran: Fix recursive PDT function invocation [PR122433, PR122434]
X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=46dcc8e575c7043aa5cd7ff02ac83e390a70c50f;p=thirdparty%2Fgcc.git

Fortran: Fix recursive PDT function invocation [PR122433, PR122434]

2025-10-29  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran
	PR fortran/122433
	* decl.cc (gfc_get_pdt_instance): Prevent a PDT component of
	the same type as the template from being converted into an
	instance.

	PR fortran/122434
	* resolve.cc (gfc_impure_variable): The result of a pure
	function is a valid allocate object since it is pure.

gcc/testsuite/
	PR fortran/122433
	* gfortran.dg/pdt_62.f03: New test.

	PR fortran/122434
	* gfortran.dg/pdt_63.f03: New test.
---

diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc
index 569786abe99..5b222cd0ce5 100644
--- a/gcc/fortran/decl.cc
+++ b/gcc/fortran/decl.cc
@@ -3938,6 +3938,20 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym,
   actual_param = param_list;
   sprintf (name, "Pdt%s", 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
+     lost.  */
+  if (gfc_current_state () == COMP_DERIVED
+      && !(gfc_state_stack->previous
+	   && gfc_state_stack->previous->state == COMP_DERIVED)
+      && gfc_current_block ()->attr.pdt_template
+      && !strcmp (gfc_current_block ()->name, (*sym)->name))
+    {
+      if (ext_param_list)
+	*ext_param_list = gfc_copy_actual_arglist (param_list);
+      return MATCH_YES;
+    }
+
   /* Run through the parameter name list and pick up the actual
      parameter values or use the default values in the PDT declaration.  */
   for (; type_param_name_list;
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 117a51c7e9a..ecd2ada36a3 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -18956,7 +18956,8 @@ gfc_impure_variable (gfc_symbol *sym)
     {
       if (ns == sym->ns)
 	break;
-      if (ns->proc_name->attr.flavor == FL_PROCEDURE && !sym->attr.function)
+      if (ns->proc_name->attr.flavor == FL_PROCEDURE
+	  && !(sym->attr.function || sym->attr.result))
 	return 1;
     }
 
diff --git a/gcc/testsuite/gfortran.dg/pdt_62.f03 b/gcc/testsuite/gfortran.dg/pdt_62.f03
new file mode 100644
index 00000000000..efbcdad3ae7
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pdt_62.f03
@@ -0,0 +1,78 @@
+! { dg-do run }
+!
+! Test fix for PR122433
+!
+! Contributed by Damian Rouson  <damian@archaeologic.codes>
+!
+module neuron_m
+  implicit none
+
+  type string_t
+    character(len=:), allocatable :: string_
+  end type
+
+  type neuron_t(k)
+    integer, kind :: k = kind(1.)
+    real(k) bias_
+    type(neuron_t(k)), allocatable :: next
+  end type
+
+contains
+  recursive function from_json(neuron_lines, start) result(neuron)
+    type(string_t) neuron_lines(:)
+    integer start
+    type(neuron_t) neuron
+    character(len=:), allocatable :: line
+    line = neuron_lines(start+1)%string_
+    read(line(index(line, ":")+1:), fmt=*) neuron%bias_
+    line = adjustr(neuron_lines(start+3)%string_)
+! Used to give "Error: Syntax error in IF-clause" for next line.
+    if (line(len(line):) == ",") neuron%next = from_json(neuron_lines, start+4)
+  end function
+  recursive function from_json_8(neuron_lines, start) result(neuron)
+    type(string_t) neuron_lines(:)
+    integer start
+    type(neuron_t(kind(1d0))) neuron
+    character(len=:), allocatable :: line
+    line = neuron_lines(start+1)%string_
+    read(line(index(line, ":")+1:), fmt=*) neuron%bias_
+    line = adjustr(neuron_lines(start+3)%string_)
+    if (line(len(line):) == ",") neuron%next = from_json_8(neuron_lines, start+4)
+  end function
+end module
+
+  use neuron_m
+  call foo
+  call bar
+contains
+  subroutine foo
+    type(neuron_t) neuron
+    type(string_t) :: neuron_lines(8)
+    neuron_lines(2)%string_ = "real : 4.0 "
+    neuron_lines(4)%string_ = " ,"
+    neuron_lines(6)%string_ = "real : 8.0 "
+    neuron_lines(8)%string_ = " "
+    neuron = from_json(neuron_lines, 1)
+    if (int (neuron%bias_) /= 4) stop 1
+    if (allocated (neuron%next)) then
+      if (int (neuron%next%bias_) /= 8) stop 2
+    else
+      stop 3
+    endif
+  end subroutine
+  subroutine bar
+    type(neuron_t(kind(1d0))) neuron
+    type(string_t) :: neuron_lines(8)
+    neuron_lines(2)%string_ = "real : 4.0d0 "
+    neuron_lines(4)%string_ = " ,"
+    neuron_lines(6)%string_ = "real : 8.0d0 "
+    neuron_lines(8)%string_ = " "
+    neuron = from_json_8(neuron_lines, 1)
+    if (int (neuron%bias_) /= 4) stop 1
+    if (allocated (neuron%next)) then
+      if (int (neuron%next%bias_) /= 8) stop 2
+    else
+      stop 3
+    endif
+  end subroutine
+end
diff --git a/gcc/testsuite/gfortran.dg/pdt_63.f03 b/gcc/testsuite/gfortran.dg/pdt_63.f03
new file mode 100644
index 00000000000..127e5fe8eb8
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pdt_63.f03
@@ -0,0 +1,26 @@
+! { dg-do compile }
+!
+! Test fix for PR122434
+!
+! Contributed by Damian Rouson  <damian@archaeologic.codes>
+!
+module neuron_m
+  implicit none
+
+  type neuron_t
+    real, allocatable :: weight_
+  end type
+
+  interface
+    type(neuron_t) pure module function from_json() result(neuron)
+    end function
+  end interface
+
+contains
+  module procedure from_json
+    associate(num_inputs => 1)
+! Gave "Error: Bad allocate-object at (1) for a PURE procedure" in next line.
+      allocate(neuron%weight_, source=0.)
+    end associate
+  end procedure
+end module