https://gcc.gnu.org/g:f598a1c8a77e678ca009b433fd849b4834594926
commit r13-8691-gf598a1c8a77e678ca009b433fd849b4834594926
Author: Paul Thomas <pa...@gcc.gnu.org>
Date: Tue Apr 2 14:19:09 2024 +0100
Fortran: Fix wrong recursive errors and class initialization [PR112407]
2024-04-02 Paul Thomas <pa...@gcc.gnu.org>
gcc/fortran
PR fortran/112407
* resolve.cc (resolve_procedure_expression): Change the test for
for recursion in the case of hidden procedures from modules.
(resolve_typebound_static): Add warning for possible recursive
calls to typebound procedures.
* trans-expr.cc (gfc_trans_class_init_assign): Do not apply
default initializer to class dummy where component initializers
are all null.
gcc/testsuite/
PR fortran/112407
* gfortran.dg/pr112407a.f90: New test.
* gfortran.dg/pr112407b.f90: New test.
(cherry picked from commit 35408b3669fac104cd380582b32e32c64a603d8b)
Diff:
---
gcc/fortran/resolve.cc | 23 +++++++++--
gcc/fortran/trans-expr.cc | 16 ++++++++
gcc/testsuite/gfortran.dg/pr112407a.f90 | 71 +++++++++++++++++++++++++++++++++
gcc/testsuite/gfortran.dg/pr112407b.f90 | 58 +++++++++++++++++++++++++++
4 files changed, 164 insertions(+), 4 deletions(-)
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index e12997bc4a0..388209d2832 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -1950,12 +1950,20 @@ resolve_procedure_expression (gfc_expr* expr)
|| (sym->attr.function && sym->result == sym))
return true;
- /* A non-RECURSIVE procedure that is used as procedure expression within its
+ /* A non-RECURSIVE procedure that is used as procedure expression within its
own body is in danger of being called recursively. */
if (is_illegal_recursion (sym, gfc_current_ns))
- gfc_warning (0, "Non-RECURSIVE procedure %qs at %L is possibly calling"
- " itself recursively. Declare it RECURSIVE or use"
- " %<-frecursive%>", sym->name, &expr->where);
+ {
+ if (sym->attr.use_assoc && expr->symtree->name[0] == '@')
+ gfc_warning (0, "Non-RECURSIVE procedure %qs from module %qs is "
+ " possibly calling itself recursively in procedure %qs. "
+ " Declare it RECURSIVE or use %<-frecursive%>",
+ sym->name, sym->module, gfc_current_ns->proc_name->name);
+ else
+ gfc_warning (0, "Non-RECURSIVE procedure %qs at %L is possibly calling"
+ " itself recursively. Declare it RECURSIVE or use"
+ " %<-frecursive%>", sym->name, &expr->where);
+ }
return true;
}
@@ -6624,6 +6632,13 @@ resolve_typebound_static (gfc_expr* e, gfc_symtree**
target,
if (st)
*target = st;
}
+
+ if (is_illegal_recursion ((*target)->n.sym, gfc_current_ns)
+ && !e->value.compcall.tbp->deferred)
+ gfc_warning (0, "Non-RECURSIVE procedure %qs at %L is possibly calling"
+ " itself recursively. Declare it RECURSIVE or use"
+ " %<-frecursive%>", (*target)->n.sym->name, &e->where);
+
return true;
}
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 5e4d04483ec..c7ec591e279 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -1692,6 +1692,7 @@ gfc_trans_class_init_assign (gfc_code *code)
tree tmp;
gfc_se dst,src,memsz;
gfc_expr *lhs, *rhs, *sz;
+ gfc_component *cmp;
gfc_start_block (&block);
@@ -1708,6 +1709,21 @@ gfc_trans_class_init_assign (gfc_code *code)
/* The _def_init is always scalar. */
rhs->rank = 0;
+ /* Check def_init for initializers. If this is a dummy with all default
+ initializer components NULL, return NULL_TREE and use the passed value as
+ required by F2018(8.5.10). */
+ if (!lhs->ref && lhs->symtree->n.sym->attr.dummy)
+ {
+ cmp = rhs->ref->next->u.c.component->ts.u.derived->components;
+ for (; cmp; cmp = cmp->next)
+ {
+ if (cmp->initializer)
+ break;
+ else if (!cmp->next)
+ return build_empty_stmt (input_location);
+ }
+ }
+
if (code->expr1->ts.type == BT_CLASS
&& CLASS_DATA (code->expr1)->attr.dimension)
{
diff --git a/gcc/testsuite/gfortran.dg/pr112407a.f90
b/gcc/testsuite/gfortran.dg/pr112407a.f90
new file mode 100644
index 00000000000..470f4191611
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr112407a.f90
@@ -0,0 +1,71 @@
+! { dg-do run }
+! Test of an issue found in the investigation of PR112407
+! Contributed by Tomas Trnka <tr...@scm.com>
+!
+module m
+ private new_t
+
+ type s
+ procedure(),pointer,nopass :: op
+ end type
+
+ type :: t
+ integer :: i
+ type (s) :: s
+ contains
+ procedure :: new_t
+ procedure :: bar
+ procedure :: add_t
+ generic :: new => new_t, bar
+ generic, public :: assignment(=) => add_t
+ final :: final_t
+ end type
+
+ integer :: i = 0, finals = 0
+
+contains
+ recursive subroutine new_t (arg1, arg2)
+ class(t), intent(out) :: arg1
+ type(t), intent(in) :: arg2
+ i = i + 1
+
+ print "(a,2i4)", "new_t", arg1%i, arg2%i
+ if (i .ge. 10) return
+
+! According to F2018(8.5.10), arg1 should be undefined on invocation, unless
+! any sub-components are default initialised. gfc used to set arg1%i = 0.
+ if (arg1%i .ne. arg2%i) then
+ arg1%i = arg2%i
+ call arg1%new(arg2)
+ endif
+ end
+
+ subroutine bar(arg)
+ class(t), intent(out) :: arg
+ call arg%new(t(42, s(new_t)))
+ end
+
+ subroutine add_t (arg1, arg2)
+ class(t), intent(out) :: arg1
+ type(t), intent(in) :: arg2
+ call arg1%new (arg2)
+ end
+
+ impure elemental subroutine final_t (arg1)
+ type(t), intent(in) :: arg1
+ finals = finals + 1
+ end
+end
+
+ use m
+ class(t), allocatable :: x
+ allocate(x)
+ x%i = 0
+ call x%new() ! gfortran used to output 10*'new_t'
+ print "(3i4)", x%i, i, finals ! -||- 0 10 11
+!
+! The other brands output 2*'new_t' + 42 2 3 and now so does gfc :-)
+ if (x%i .ne. 42) stop 1
+ if (i .ne. 2) stop 2
+ if (finals .ne. 3) stop 3
+end
diff --git a/gcc/testsuite/gfortran.dg/pr112407b.f90
b/gcc/testsuite/gfortran.dg/pr112407b.f90
new file mode 100644
index 00000000000..b4653f80882
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr112407b.f90
@@ -0,0 +1,58 @@
+! { dg-do compile }
+! { dg-options "-std=f2008" }
+! Test of an issue found in the investigation of PR112407. The dg-option is
+! set to avoid regression once the F2018 RECURSIVE by default in implemented.
+! Contributed by Tomas Trnka <tr...@scm.com>
+!
+module m
+ private new_t
+
+ type s
+ procedure(),pointer,nopass :: op
+ end type
+
+ type :: t
+ integer :: i
+ type (s) :: s
+ contains
+ procedure :: new_t
+ procedure :: bar
+ procedure :: add_t
+ generic :: new => new_t, bar
+ generic, public :: assignment(=) => add_t
+ final :: final_t
+ end type
+
+ integer :: i = 0, finals = 0
+
+contains
+ subroutine new_t (arg1, arg2) ! gfortran didn't detect the
recursion
+ class(t), intent(out) :: arg1
+ type(t), intent(in) :: arg2
+ i = i + 1
+
+ print *, "new_t", arg1%i, arg2%i
+ if (i .ge. 10) return
+
+ if (arg1%i .ne. arg2%i) then
+ arg1%i = arg2%i
+ call arg1%new(arg2) ! { dg-warning "possibly calling itself
recursively" }
+ endif
+ end
+
+ subroutine bar(arg)
+ class(t), intent(out) :: arg
+ call arg%new(t(42, s(new_t)))
+ end
+
+ subroutine add_t (arg1, arg2)
+ class(t), intent(out) :: arg1
+ type(t), intent(in) :: arg2
+ call arg1%new (arg2)
+ end
+
+ impure elemental subroutine final_t (arg1)
+ type(t), intent(in) :: arg1
+ finals = finals + 1
+ end
+end
