Hi All, The patch that is posted on the PR turned out to be far too elaborate. This version fixes the basic problem by resolving the class declared type before building the typebound function call.
The complication caused by the PDTs was dealt with by the chunks in trans-decl.cc, which permit the PDT result to be initialized when the result is not explicitly referenced. Regtests on FC43/x86_64. OK for mainline? Paul
Change.Logs
Description: Binary data
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 33a183e7414..e8a7fcd6857 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 726bd788920..d7189f48c6b 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 00000000000..84d74f8eae5
--- /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" } }
