@@ -12511,11 +12511,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