https://gcc.gnu.org/g:b5d3675a8fc6d44fa52b7ed1c966c6815de5a9dc
commit r16-6494-gb5d3675a8fc6d44fa52b7ed1c966c6815de5a9dc Author: Paul Thomas <[email protected]> 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 <[email protected]> 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 <[email protected]> +! +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" } }
