Hi All,
This bug emerged in a large code and involves possible recursion with a
"hidden" module procedure; ie. where the symtree name starts with '@'. This
throws the format decoder. As the last message in the PR shows, I have
vacillated between silently passing on the possible recursion or adding an
alternative warning message. In the end, as a conservative choice I went
for emitting the message.
In the course of trying to develop a compact test case, I found that type
bound procedures were not being tested for recursion and that class
dummies, with intent out, were being incorrectly initialized with an empty
default initializer. Both of these have been fixed.
Unfortunately, the most compact reproducer that Tomas was able to come up
with required more than 100kbytes of module files. I tried from the bottom
up but failed. Both the tests check the fixes for the other bugs.
Regtests on x86_64 - OK for mainline and, in a couple of weeks, 13-branch?
Paul
Fortran: Fix wrong recursive errors and class initialization [PR112407]
2024-03-30 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.
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 50d51b06c92..43315a6a550 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 76bed9830c4..3b54874cf1f 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)
{
@@ -12511,11 +12527,14 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
gfc_add_block_to_block (&body, &lse.pre);
gfc_add_expr_to_block (&body, tmp);
- /* Add the post blocks to the body. */
- if (!l_is_temp)
+ /* Add the post blocks to the body. Scalar finalization must appear before
+ the post block in case any dellocations are done. */
+ if (rse.finalblock.head
+ && (!l_is_temp || (expr2->expr_type == EXPR_FUNCTION
+ && gfc_expr_attr (expr2).elemental)))
{
- gfc_add_block_to_block (&rse.finalblock, &rse.post);
gfc_add_block_to_block (&body, &rse.finalblock);
+ gfc_add_block_to_block (&body, &rse.post);
}
else
gfc_add_block_to_block (&body, &rse.post);
diff --git a/gcc/fortran/trans.cc b/gcc/fortran/trans.cc
index 7f50b16aee9..badad6ae892 100644
--- a/gcc/fortran/trans.cc
+++ b/gcc/fortran/trans.cc
@@ -1624,7 +1624,7 @@ gfc_finalize_tree_expr (gfc_se *se, gfc_symbol *derived,
}
else if (derived && gfc_is_finalizable (derived, NULL))
{
- if (derived->attr.zero_comp && !rank)
+ if (!derived->components && (!rank || attr.elemental))
{
/* Any attempt to assign zero length entities, causes the gimplifier
all manner of problems. Instead, a variable is created to act as
@@ -1675,7 +1675,7 @@ gfc_finalize_tree_expr (gfc_se *se, gfc_symbol *derived,
final_fndecl);
if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
{
- if (is_class)
+ if (is_class || attr.elemental)
desc = gfc_conv_scalar_to_descriptor (se, desc, attr);
else
{
@@ -1685,7 +1685,7 @@ gfc_finalize_tree_expr (gfc_se *se, gfc_symbol *derived,
}
}
- if (derived && derived->attr.zero_comp)
+ if (derived && !derived->components)
{
/* All the conditions below break down for zero length derived types. */
tmp = build_call_expr_loc (input_location, final_fndecl, 3,
diff --git a/gcc/testsuite/gfortran.dg/finalize_54.f90 b/gcc/testsuite/gfortran.dg/finalize_54.f90
new file mode 100644
index 00000000000..73d32b1b333
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/finalize_54.f90
@@ -0,0 +1,47 @@
+! { dg-do compile }
+! Test the fix for PR113885, where not only was there a gimplifier ICE
+! for a derived type 't' with no components but, with a component, gfortran
+! gave wrong results.
+! Contributed by David Binderman <dcb...@hotmail.com>
+!
+module types
+ type t
+ contains
+ final :: finalize
+ end type t
+contains
+ pure subroutine finalize(x)
+ type(t), intent(inout) :: x
+ end subroutine finalize
+end module types
+
+subroutine test1(x)
+ use types
+ interface
+ elemental function elem(x)
+ use types
+ type(t), intent(in) :: x
+ type(t) :: elem
+ end function elem
+ end interface
+ type(t) :: x(:)
+ x = elem(x)
+end subroutine test1
+
+subroutine test2(x)
+ use types
+ interface
+ elemental function elem(x)
+ use types
+ type(t), intent(in) :: x
+ type(t) :: elem
+ end function elem
+ elemental function elem2(x, y)
+ use types
+ type(t), intent(in) :: x, y
+ type(t) :: elem2
+ end function elem2
+ end interface
+ type(t) :: x(:)
+ x = elem2(elem(x), elem(x))
+end subroutine test2
diff --git a/gcc/testsuite/gfortran.dg/finalize_55.f90 b/gcc/testsuite/gfortran.dg/finalize_55.f90
new file mode 100644
index 00000000000..fa7e552eea5
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/finalize_55.f90
@@ -0,0 +1,89 @@
+! { dg-do run }
+! Test the fix for PR113885, where not only was there a gimplifier ICE
+! for a derived type 't' with no components but this version gave wrong
+! results.
+! Contributed by David Binderman <dcb...@hotmail.com>
+!
+module types
+ type t
+ integer :: i
+ contains
+ final :: finalize
+ end type t
+ integer :: ctr = 0
+contains
+ impure elemental subroutine finalize(x)
+ type(t), intent(inout) :: x
+ ctr = ctr + 1
+ end subroutine finalize
+end module types
+
+impure elemental function elem(x)
+ use types
+ type(t), intent(in) :: x
+ type(t) :: elem
+ elem%i = x%i + 1
+end function elem
+
+impure elemental function elem2(x, y)
+ use types
+ type(t), intent(in) :: x, y
+ type(t) :: elem2
+ elem2%i = x%i + y%i
+end function elem2
+
+subroutine test1(x)
+ use types
+ interface
+ impure elemental function elem(x)
+ use types
+ type(t), intent(in) :: x
+ type(t) :: elem
+ end function elem
+ end interface
+ type(t) :: x(:)
+ type(t), allocatable :: y(:)
+ y = x
+ x = elem(y)
+end subroutine test1
+
+subroutine test2(x)
+ use types
+ interface
+ impure elemental function elem(x)
+ use types
+ type(t), intent(in) :: x
+ type(t) :: elem
+ end function elem
+ impure elemental function elem2(x, y)
+ use types
+ type(t), intent(in) :: x, y
+ type(t) :: elem2
+ end function elem2
+ end interface
+ type(t) :: x(:)
+ type(t), allocatable :: y(:)
+ y = x
+ x = elem2(elem(y), elem(y))
+end subroutine test2
+
+program test113885
+ use types
+ interface
+ subroutine test1(x)
+ use types
+ type(t) :: x(:)
+ end subroutine
+ subroutine test2(x)
+ use types
+ type(t) :: x(:)
+ end subroutine
+ end interface
+ type(t) :: x(2) = [t(1),t(2)]
+ call test1 (x)
+ if (any (x%i .ne. [2,3])) stop 1
+ if (ctr .ne. 6) stop 2
+ call test2 (x)
+ if (any (x%i .ne. [6,8])) stop 3
+ if (ctr .ne. 16) stop 4
+end
diff --git a/gcc/testsuite/gfortran.dg/finalize_56.f90 b/gcc/testsuite/gfortran.dg/finalize_56.f90
new file mode 100644
index 00000000000..bd350a3bc1c
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/finalize_56.f90
@@ -0,0 +1,168 @@
+! { dg-do run }
+! Test the fix for PR110987
+! Segfaulted in runtime, as shown below.
+! Contributed by Kirill Chankin <chiliki...@gmail.com>
+! and John Haiducek <jhaid...@gmail.com> (comment 5)
+!
+MODULE original_mod
+ IMPLICIT NONE
+
+ TYPE T1_POINTER
+ CLASS(T1), POINTER :: T1
+ END TYPE
+
+ TYPE T1
+ INTEGER N_NEXT
+ CLASS(T1_POINTER), ALLOCATABLE :: NEXT(:)
+ CONTAINS
+ FINAL :: T1_DESTRUCTOR
+ PROCEDURE :: SET_N_NEXT => T1_SET_N_NEXT
+ PROCEDURE :: GET_NEXT => T1_GET_NEXT
+ END TYPE
+
+ INTERFACE T1
+ PROCEDURE T1_CONSTRUCTOR
+ END INTERFACE
+
+ TYPE, EXTENDS(T1) :: T2
+ REAL X
+ CONTAINS
+ END TYPE
+
+ INTERFACE T2
+ PROCEDURE T2_CONSTRUCTOR
+ END INTERFACE
+
+ TYPE, EXTENDS(T1) :: T3
+ CONTAINS
+ FINAL :: T3_DESTRUCTOR
+ END TYPE
+
+ INTERFACE T3
+ PROCEDURE T3_CONSTRUCTOR
+ END INTERFACE
+
+ INTEGER :: COUNTS = 0
+
+CONTAINS
+
+ TYPE(T1) FUNCTION T1_CONSTRUCTOR() RESULT(L)
+ IMPLICIT NONE
+ L%N_NEXT = 0
+ END FUNCTION
+
+ SUBROUTINE T1_DESTRUCTOR(SELF)
+ IMPLICIT NONE
+ TYPE(T1), INTENT(INOUT) :: SELF
+ IF (ALLOCATED(SELF%NEXT)) THEN
+ DEALLOCATE(SELF%NEXT)
+ ENDIF
+ END SUBROUTINE
+
+ SUBROUTINE T3_DESTRUCTOR(SELF)
+ IMPLICIT NONE
+ TYPE(T3), INTENT(IN) :: SELF
+ if (.NOT.ALLOCATED (SELF%NEXT)) COUNTS = COUNTS + 1
+ END SUBROUTINE
+
+ SUBROUTINE T1_SET_N_NEXT(SELF, N_NEXT)
+ IMPLICIT NONE
+ CLASS(T1), INTENT(INOUT) :: SELF
+ INTEGER, INTENT(IN) :: N_NEXT
+ INTEGER I
+ SELF%N_NEXT = N_NEXT
+ ALLOCATE(SELF%NEXT(N_NEXT))
+ DO I = 1, N_NEXT
+ NULLIFY(SELF%NEXT(I)%T1)
+ ENDDO
+ END SUBROUTINE
+
+ FUNCTION T1_GET_NEXT(SELF) RESULT(NEXT)
+ IMPLICIT NONE
+ CLASS(T1), TARGET, INTENT(IN) :: SELF
+ CLASS(T1), POINTER :: NEXT
+ CLASS(T1), POINTER :: L
+ INTEGER I
+ IF (SELF%N_NEXT .GE. 1) THEN
+ NEXT => SELF%NEXT(1)%T1
+ RETURN
+ ENDIF
+ NULLIFY(NEXT)
+ END FUNCTION
+
+ TYPE(T2) FUNCTION T2_CONSTRUCTOR() RESULT(L)
+ IMPLICIT NONE
+ L%T1 = T1()
+ CALL L%T1%SET_N_NEXT(1)
+ END FUNCTION
+
+ TYPE(T3) FUNCTION T3_CONSTRUCTOR() RESULT(L)
+ IMPLICIT NONE
+ L%T1 = T1()
+ END FUNCTION
+
+END MODULE original_mod
+
+module comment5_mod
+ type::parent
+ character(:), allocatable::name
+ end type parent
+ type, extends(parent)::child
+ contains
+ final::child_finalize
+ end type child
+ interface child
+ module procedure new_child
+ end interface child
+ integer :: counts = 0
+
+contains
+
+ type(child) function new_child(name)
+ character(*)::name
+ new_child%name=name
+ end function new_child
+
+ subroutine child_finalize(this)
+ type(child), intent(in)::this
+ counts = counts + 1
+ end subroutine child_finalize
+end module comment5_mod
+
+PROGRAM TEST_PROGRAM
+ call original
+ call comment5
+contains
+ subroutine original
+ USE original_mod
+ IMPLICIT NONE
+ TYPE(T1), TARGET :: X1
+ TYPE(T2), TARGET :: X2
+ TYPE(T3), TARGET :: X3
+ CLASS(T1), POINTER :: L
+ X1 = T1()
+ X2 = T2()
+ X2%NEXT(1)%T1 => X1
+ X3 = T3()
+ CALL X3%SET_N_NEXT(1)
+ X3%NEXT(1)%T1 => X2
+ L => X3
+ DO WHILE (.TRUE.)
+ L => L%GET_NEXT() ! Used to segfault here in runtime
+ IF (.NOT. ASSOCIATED(L)) EXIT
+ COUNTS = COUNTS + 1
+ ENDDO
+! Two for T3 finalization and two for associated 'L's
+ IF (COUNTS .NE. 4) STOP 1
+ end subroutine original
+
+ subroutine comment5
+ use comment5_mod, only: child, counts
+ implicit none
+ type(child)::kid
+ kid = child("Name")
+ if (.not.allocated (kid%name)) stop 2
+ if (kid%name .ne. "Name") stop 3
+ if (counts .ne. 2) stop 4
+ end subroutine comment5
+END PROGRAM
diff --git a/gcc/testsuite/gfortran.dg/pr112407a.f90 b/gcc/testsuite/gfortran.dg/pr112407a.f90
new file mode 100644
index 00000000000..81ef8bd55a4
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr112407a.f90
@@ -0,0 +1,70 @@
+! { 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)
+ 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..e541825d616
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr112407b.f90
@@ -0,0 +1,56 @@
+! { dg-do compile }
+! 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
+ 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
