[gcc r16-6494] Fortran: ICE in type-bound function with PDT result [PR 123071]
Paul Thomas
pault@gcc.gnu.org
Mon Jan 5 07:05:55 GMT 2026
https://gcc.gnu.org/g:b5d3675a8fc6d44fa52b7ed1c966c6815de5a9dc
commit r16-6494-gb5d3675a8fc6d44fa52b7ed1c966c6815de5a9dc
Author: Paul Thomas <pault@gcc.gnu.org>
Date: Mon Jan 5 07:05:36 2026 +0000
Fortran: ICE in type-bound function with PDT result [PR 123071]
2026-01-05 Paul Thomas <pault@gcc.gnu.org>
gcc/fortran
PR fortran/123071
* resolve.cc (resolve_typebound_function): Make sure that the
class declared type is resolved.
(resolve_allocate_deallocate): Any kind of expr3 array ref will
need resolution not just constant size refs.
* trans-decl.cc (gfc_trans_deferred_vars): Exclude vtabs from
initialization.
(emit_not_set_warning): New function using code extracted from
gfc_generate_function_code.
(gfc_generate_function_code): PDT module procedures results
that have not been referenced must have the fake_result_decl
added to the symbol and emit_not_set_warning called. Likewise
replace explicit code with call to emit_not_set_warning.
gcc/testsuite
PR fortran/123071
* gfortran.dg/pdt_79.f03: New test.
Diff:
---
gcc/fortran/resolve.cc | 6 ++--
gcc/fortran/trans-decl.cc | 41 ++++++++++++++++++------
gcc/testsuite/gfortran.dg/pdt_79.f03 | 61 ++++++++++++++++++++++++++++++++++++
3 files changed, 96 insertions(+), 12 deletions(-)
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 33a183e74146..e8a7fcd68570 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -7743,6 +7743,9 @@ resolve_typebound_function (gfc_expr* e)
is present. */
ts = expr->ts;
declared = ts.u.derived;
+ if (!resolve_fl_derived (declared))
+ return false;
+
c = gfc_find_component (declared, "_vptr", true, true, NULL);
if (c->ts.u.derived == NULL)
c->ts.u.derived = gfc_find_derived_vtab (declared);
@@ -9799,10 +9802,9 @@ done_errmsg:
/* Resolving the expr3 in the loop over all objects to allocate would
execute loop invariant code for each loop item. Therefore do it just
once here. */
- mpz_t nelem;
if (code->expr3 && code->expr3->mold
&& code->expr3->ts.type == BT_DERIVED
- && !(code->expr3->ref && gfc_array_size (code->expr3, &nelem)))
+ && !(code->expr3->ref && code->expr3->ref->type == REF_ARRAY))
{
/* Default initialization via MOLD (non-polymorphic). */
gfc_expr *rhs = gfc_default_initializer (&code->expr3->ts);
diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc
index 726bd7889203..d7189f48c6bb 100644
--- a/gcc/fortran/trans-decl.cc
+++ b/gcc/fortran/trans-decl.cc
@@ -4966,7 +4966,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
&& (sym->ts.u.derived->attr.alloc_comp
|| gfc_is_finalizable (sym->ts.u.derived,
NULL));
- if (sym->assoc)
+ if (sym->assoc || sym->attr.vtab)
continue;
/* Set the vptr of unlimited polymorphic pointer variables so that
@@ -7982,6 +7982,19 @@ done_finally:
gfc_add_block_to_block (finally, &block);
}
+
+static void
+emit_not_set_warning (gfc_symbol *sym)
+{
+ if (warn_return_type > 0 && sym == sym->result)
+ gfc_warning (OPT_Wreturn_type,
+ "Return value of function %qs at %L not set",
+ sym->name, &sym->declared_at);
+ if (warn_return_type > 0)
+ suppress_warning (sym->backend_decl);
+}
+
+
/* Generate code for a function. */
void
@@ -8203,6 +8216,20 @@ gfc_generate_function_code (gfc_namespace * ns)
tmp = gfc_trans_code (ns->code);
gfc_add_expr_to_block (&body, tmp);
+ /* This permits the return value to be correctly initialized, even when the
+ function result was not referenced. */
+ if (sym->abr_modproc_decl
+ && sym->ts.type == BT_DERIVED
+ && sym->ts.u.derived->attr.pdt_type
+ && !sym->attr.allocatable
+ && sym->result == sym
+ && get_proc_result (sym) == NULL_TREE)
+ {
+ gfc_get_fake_result_decl (sym->result, 0);
+ /* TODO: move to the appropriate place in resolve.cc. */
+ emit_not_set_warning (sym);
+ }
+
if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
|| (sym->result && sym->result != sym
&& sym->result->ts.type == BT_DERIVED
@@ -8275,15 +8302,9 @@ gfc_generate_function_code (gfc_namespace * ns)
}
if (result == NULL_TREE || artificial_result_decl)
- {
- /* TODO: move to the appropriate place in resolve.cc. */
- if (warn_return_type > 0 && sym == sym->result)
- gfc_warning (OPT_Wreturn_type,
- "Return value of function %qs at %L not set",
- sym->name, &sym->declared_at);
- if (warn_return_type > 0)
- suppress_warning (sym->backend_decl);
- }
+ /* TODO: move to the appropriate place in resolve.cc. */
+ emit_not_set_warning (sym);
+
if (result != NULL_TREE)
gfc_add_expr_to_block (&body, gfc_generate_return ());
}
diff --git a/gcc/testsuite/gfortran.dg/pdt_79.f03 b/gcc/testsuite/gfortran.dg/pdt_79.f03
new file mode 100644
index 000000000000..84d74f8eae59
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pdt_79.f03
@@ -0,0 +1,61 @@
+! { dg-do compile }
+! { dg-options "-Wall -fdump-tree-original" }
+!
+! Test the fix for PR123071, which caused an ICE.
+!
+! Contributed by Damian Rouson <damian@archaeologic.codes>
+!
+module neural_network_m
+ implicit none
+
+ type tensor_t(k)
+ integer, kind :: k = kind(1.)
+ integer :: j = 42
+ end type
+
+ type neural_network_t
+ integer :: i = 42
+ contains
+ procedure map_tensor
+ end type
+
+ interface
+ module function map_tensor(self)
+ implicit none
+ class(neural_network_t) self
+ type(tensor_t) map_tensor
+ end function
+ end interface
+end module
+
+submodule(neural_network_m) neural_network_s
+contains
+ module procedure map_tensor ! { dg-warning "Return value of function .map_tensor. at .1. not set" }
+! map_tensor%j = 42 ! Uncommenting this makes the warning disappear of course.
+ end procedure
+end submodule
+
+ use neural_network_m
+ implicit none
+ type, extends(neural_network_t) :: trainable_network_t
+ end type
+ type (trainable_network_t) x
+ call foo (x)
+
+contains
+
+ subroutine foo(self)
+ class(trainable_network_t) self
+ type(tensor_t) mapped_tensor
+ mapped_tensor = self%map_tensor()
+ if (mapped_tensor%k /= 4) stop 1
+ if (mapped_tensor%j /= 42) stop 2
+ associate (mt => self%map_tensor())
+ if (mt%k /= 4) stop 3
+ if (mt%j /= 42) stop 4
+ end associate
+ end subroutine
+
+end
+! { dg-final { scan-tree-dump-times "mapped_tensor.j = 42" 1 "original" } }
+! { dg-final { scan-tree-dump-times "struct Pdttensor_t_4 mt" 1 "original" } }
More information about the Gcc-cvs
mailing list