@@ -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;
}
@@ -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);
@@ -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,
new file mode 100644
@@ -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 <dcb314@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
new file mode 100644
@@ -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 <dcb314@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
new file mode 100644
@@ -0,0 +1,168 @@
+! { dg-do run }
+! Test the fix for PR110987
+! Segfaulted in runtime, as shown below.
+! Contributed by Kirill Chankin <chilikin.k@gmail.com>
+! and John Haiducek <jhaiduce@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
new file mode 100644
@@ -0,0 +1,70 @@
+! { 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)
+ 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
new file mode 100644
@@ -0,0 +1,56 @@
+! { dg-do compile }
+! 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
+ 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