https://gcc.gnu.org/g:46dcc8e575c7043aa5cd7ff02ac83e390a70c50f
commit r16-4704-g46dcc8e575c7043aa5cd7ff02ac83e390a70c50f Author: Paul Thomas <[email protected]> Date: Wed Oct 29 09:20:24 2025 +0000 Fortran: Fix recursive PDT function invocation [PR122433, PR122434] 2025-10-29 Paul Thomas <[email protected]> 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: --- gcc/fortran/decl.cc | 14 +++++++ gcc/fortran/resolve.cc | 3 +- gcc/testsuite/gfortran.dg/pdt_62.f03 | 78 ++++++++++++++++++++++++++++++++++++ gcc/testsuite/gfortran.dg/pdt_63.f03 | 26 ++++++++++++ 4 files changed, 120 insertions(+), 1 deletion(-) diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc index 569786abe992..5b222cd0ce51 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 117a51c7e9a3..ecd2ada36a32 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 000000000000..efbcdad3ae7d --- /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 <[email protected]> +! +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 000000000000..127e5fe8eb8d --- /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 <[email protected]> +! +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
