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 --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 33a183e74146617dd689b1f8c096ad86bae8dd5f..e8a7fcd68570c3b313e0896bba60f4cf6970890e 100644 (file)
--- 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 726bd78892039153c983b35165ee239c43dfbaf2..d7189f48c6bb4439f8128494bccbd46ef12fd910 100644 (file)
--- 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 (file)
index 0000000..84d74f8
--- /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" } }