+! { dg-do run }
+! { dg-options "-std=f2008" }
+!
+! Test finalization on intrinsic assignment (F2018 (7.5.6.3))
+! With -std=f2008, structure and array constructors are finalized.
+! See finalize_38.f90 for the result with -std=gnu.
+! Tests fix for PR64290 as well.
+!
+module testmode
+ implicit none
+
+ type :: simple
+ integer :: ind
+ contains
+ final :: destructor1, destructor2
+ end type simple
+
+ type, extends(simple) :: complicated
+ real :: rind
+ contains
+ final :: destructor3, destructor4
+ end type complicated
+
+ integer :: check_scalar
+ integer :: check_array(4)
+ real :: check_real
+ real :: check_rarray(4)
+ integer :: final_count = 0
+ integer :: fails = 0
+
+contains
+
+ subroutine destructor1(self)
+ type(simple), intent(inout) :: self
+ check_scalar = self%ind
+ check_array = 0
+ final_count = final_count + 1
+ end subroutine destructor1
+
+ subroutine destructor2(self)
+ type(simple), intent(inout) :: self(:)
+ check_scalar = 0
+ check_array(1:size(self, 1)) = self%ind
+ final_count = final_count + 1
+ end subroutine destructor2
+
+ subroutine destructor3(self)
+ type(complicated), intent(inout) :: self
+ check_real = self%rind
+ check_array = 0.0
+ final_count = final_count + 1
+ end subroutine destructor3
+
+ subroutine destructor4(self)
+ type(complicated), intent(inout) :: self(:)
+ check_real = 0.0
+ check_rarray(1:size(self, 1)) = self%rind
+ final_count = final_count + 1
+ end subroutine destructor4
+
+ function constructor1(ind) result(res)
+ class(simple), allocatable :: res
+ integer, intent(in) :: ind
+ allocate (res, source = simple (ind))
+ end function constructor1
+
+ function constructor2(ind, rind) result(res)
+ class(simple), allocatable :: res(:)
+ integer, intent(in) :: ind(:)
+ real, intent(in), optional :: rind(:)
+ type(complicated), allocatable :: src(:)
+ integer :: sz
+ integer :: i
+ if (present (rind)) then
+ sz = min (size (ind, 1), size (rind, 1))
+ src = [(complicated (ind(i), rind(i)), i = 1, sz)] ! { dg-warning "has been finalized" }
+ allocate (res, source = src)
+ else
+ sz = size (ind, 1)
+ allocate (res, source = [(simple (ind(i)), i = 1, sz)])
+ end if
+ end function constructor2
+
+ subroutine test (cnt, scalar, array, off, rind, rarray)
+ integer :: cnt
+ integer :: scalar
+ integer :: array(:)
+ integer :: off
+ real, optional :: rind
+ real, optional :: rarray(:)
+ if (final_count .ne. cnt) then
+ print *, 1 + off, final_count, '(', cnt, ')'
+ fails = fails + 1
+ endif
+ if (check_scalar .ne. scalar) then
+ print *, 2 + off, check_scalar, '(', scalar, ')'
+ fails = fails + 1
+ endif
+ if (any (check_array(1:size (array, 1)) .ne. array)) then
+ print *, 3 + off, check_array(1:size (array, 1)) , '(', array, ')'
+ fails = fails + 1
+ endif
+ if (present (rind)) then
+ if (check_real .ne. rind) then
+ print *, 4 + off, check_real,'(', rind, ')'
+ fails = fails + 1
+ endif
+ end if
+ if (present (rarray)) then
+ if (any (check_rarray(1:size (rarray, 1)) .ne. rarray)) then
+ print *, 5 + off, check_rarray(1:size (rarray, 1)), '(', rarray, ')'
+ fails = fails + 1
+ endif
+ end if
+ final_count = 0
+ end subroutine test
+end module testmode
+
+program test_final
+ use testmode
+ implicit none
+
+ type(simple), allocatable :: MyType, MyType2
+ type(simple), allocatable :: MyTypeArray(:)
+ type(simple) :: ThyType = simple(21), ThyType2 = simple(22)
+ class(simple), allocatable :: MyClass
+ class(simple), allocatable :: MyClassArray(:)
+
+! ************************
+! Derived type assignments
+! ************************
+
+! The original PR - no finalization of 'var' before (re)allocation
+! because it is deallocated on scope entry (para 1 of F2018 7.5.6.3.)
+ MyType = ThyType
+ call test(0, 0, [0,0], 0)
+
+ if (.not. allocated(MyType)) allocate(MyType)
+ allocate(MyType2)
+ MyType%ind = 1
+ MyType2%ind = 2
+
+! This should result in a final call with self = simple(1) (para 1 of F2018 7.5.6.3.).
+ MyType = MyType2
+ call test(1, 1, [0,0], 10)
+
+ allocate(MyTypeArray(2))
+ MyTypeArray%ind = [42, 43]
+! This should result in a final call with self = [simple(42),simple(43)],
+! followed by the finalization of the array constructor = self = [simple(21),simple(22)].
+ MyTypeArray = [ThyType, ThyType2] ! { dg-warning "has been finalized" }
+ call test(2, 0, [21,22], 20)
+
+! This should result in a final call 'var' = initialization = simple(22),
+! followed by one with for the structure constructor.
+ ThyType2 = simple(99) ! { dg-warning "has been finalized" }
+ call test(2, 99, [0,0], 30)
+
+! This should result in a final call for 'var' with self = simple(21).
+ ThyType = ThyType2
+ call test(1, 21, [0,0], 40)
+
+! This should result in two final calls; the last is for Mytype2 = simple(2).
+ deallocate (MyType, MyType2)
+ call test(2, 2, [0,0], 50)
+
+! This should result in one final call; MyTypeArray = [simple(21),simple(22)].
+ deallocate (MyTypeArray)
+ call test(1, 0, [21,22], 60)
+
+! The lhs is finalized before assignment.
+! The function result is finalized after the assignment.
+ allocate (MyType, source = simple (11))
+ MyType = constructor1 (99)
+ call test(2, 99, [0,0], 70)
+ deallocate (MyType)
+! *****************
+! Class assignments
+! *****************
+
+ final_count = 0
+
+! This should result in a final call for MyClass, which is simple(3) and then
+! the structure constructor with value simple(4)).
+ allocate (MyClass, source = simple (3))
+ MyClass = simple (4) ! { dg-warning "has been finalized" }
+ call test(2, 4, [0,0], 100)
+
+! This should result in a final call with the assigned value of simple(4).
+ deallocate (MyClass)
+ call test(1, 4, [0,0], 110)
+
+
+ allocate (MyClassArray, source = [simple (5), simple (6)])
+! Make sure that there is no final call since MyClassArray is not allocated.
+ call test(0, 4, [0,0], 120)
+
+ MyClassArray = [simple (7), simple (8)] ! { dg-warning "has been finalized" }
+! The first final call should finalize MyClassArray and the second should return
+! the value of the array constructor.
+ call test(2, 0, [7,8], 130)
+
+! This should result in a final call with the assigned value.
+ deallocate (MyClassArray)
+ call test(1, 0, [7,8], 140)
+
+! This should produce no final calls since MyClassArray was deallocated.
+ allocate (MyClassArray, source = [complicated(1, 2.0),complicated(3, 4.0)])
+
+! This should produce calls to destructor4 then destructor2.
+ deallocate (MyClassArray)
+
+! F2018 7.5.6.3: "If the entity is of extended type and the parent type is
+! finalizable, the parent component is finalized.
+ call test(2, 0, [1, 3], 150, rarray = [2.0, 4.0])
+
+! This produces 2 final calls in turn for 'src' as it goes out of scope, for
+! MyClassArray before it is assigned to and the result of 'constructor2' after
+! the assignment, for which the result should be should be [10,20] & [10.0,20.0].
+ MyClassArray = constructor2 ([10,20], [10.0,20.0])
+ call test(6, 0, [10,20], 160, rarray = [10.0,20.0])
+
+! This produces two final calls with the contents of 'MyClassArray. and its
+! parent component.
+ deallocate (MyClassArray)
+ call test(2, 0, [10, 20], 170, rarray = [10.0,20.0])
+
+! Clean up for valgrind testing
+ if (allocated (MyType)) deallocate (MyType)
+ if (allocated (MyType2)) deallocate (MyType2)
+ if (allocated (MyTypeArray)) deallocate (MyTypeArray)
+ if (allocated (MyClass)) deallocate (MyClass)
+ if (allocated (MyClassArray)) deallocate (MyClassArray)
+
+! Error messages printed out by 'test'.
+ if (fails .ne. 0) then
+ Print *, fails, " Errors"
+ error stop
+ endif
+end program test_final