diff options
author | Paul Thomas <pault@gcc.gnu.org> | 2024-04-02 14:19:09 +0100 |
---|---|---|
committer | Paul Thomas <pault@gcc.gnu.org> | 2024-04-02 14:19:09 +0100 |
commit | 35408b3669fac104cd380582b32e32c64a603d8b (patch) | |
tree | 28a98e943fc5108c8b16c881ae1ff5fe18bd1d7f /gcc | |
parent | 9a5e4aade2b847c5262577a1490ce6f3df9a9841 (diff) | |
download | gcc-35408b3669fac104cd380582b32e32c64a603d8b.zip gcc-35408b3669fac104cd380582b32e32c64a603d8b.tar.gz gcc-35408b3669fac104cd380582b32e32c64a603d8b.tar.bz2 |
Fortran: Fix wrong recursive errors and class initialization [PR112407]
2024-04-02 Paul Thomas <pault@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.
Diffstat (limited to 'gcc')
-rw-r--r-- | gcc/fortran/resolve.cc | 23 | ||||
-rw-r--r-- | gcc/fortran/trans-expr.cc | 16 | ||||
-rw-r--r-- | gcc/testsuite/gfortran.dg/pr112407a.f90 | 71 | ||||
-rw-r--r-- | 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 50d51b0..43315a6 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -1963,12 +1963,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; } @@ -6820,6 +6828,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 d21e395..f4c4724 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -1719,6 +1719,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); @@ -1735,6 +1736,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 0000000..470f419 --- /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 <trnka@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 0000000..b4653f8 --- /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 <trnka@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 |