! { dg-do run }
!
! Test finalization on intrinsic assignment (F2018 (7.5.6.3))
!
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

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)
    type(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)]
      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)  print *, 1 + off, final_count, cnt
    if (check_scalar .ne. scalar) print *, 2 + off, check_scalar, scalar
    if (any (check_array(1:size (array, 1)) .ne. array)) print *,  3 + off, &
                                       check_array(1:size (array, 1)), "|", array
    if (present (rind)) then
      if (check_real .ne. rind)  print *,  4+off, check_real, rind
    end if
    if (present (rarray)) then
      if (any (check_rarray(1:size (rarray, 1)) .ne. rarray)) print *,  5 + off, &
                                       check_rarray(1:size (rarray, 1)), "|", rarray
    end if
  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 - one finalization of 'var' before (re)allocation.
  MyType = ThyType
  call test(1, 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).
  MyType = MyType2
  call test(2, 1, [0,0], 10)

  allocate(MyTypeArray(2))
  MyTypeArray%ind = [42, 43]
! This should result in a final call with self = [simple(42),simple(43)].
  MyTypeArray = [ThyType, ThyType2]
  call test(3, 0, [42,43], 20)

! This should result in a final call with self = initialization = simple(22).
  ThyType2 = simple(99)
  call test(4, 22, [0,0], 30)

! This should result in a final call with self = simple(22).
  ThyType = ThyType2
  call test(5, 21, [0,0], 40)

! This should result in two final calls; the last is for self2 = simple(2).
  deallocate (MyType, MyType2)
  call test(7, 2, [0,0], 50)

! This should result in one final call; MyTypeArray = [simple(21),simple(22)].
  deallocate (MyTypeArray)
  call test(8, 0, [21,22], 60)

! Check that rhs function expressions do not interfere with finalization.
! The lhs is finalized before assignment.
! The function result is finalized after the assignment.
  allocate (MyType, source = simple (11))
  MyType = constructor1 (99)
  call test(10, 99, [0,0], 70)

  deallocate (MyType)
! *****************
! Class assignments
! *****************

  final_count = 0

  allocate (MyClass, source = simple (3))
! This should result in a final call with the allocated value.
  MyClass = simple (4)
  call test(1, 3, [0,0], 100)

! This should result in a final call with the assigned value.
  deallocate (MyClass)
  call test(2, 4, [0,0], 110)

  allocate (MyClassArray, source = [simple (5), simple (6)])
! Make sure that there is no final call.
  call test(2, 4, [0,0], 120)

  MyClassArray = [simple (7), simple (8)]
! The final call should return the value before the assignment.
  call test(2, 4, [0,0], 130)

! This should result in a final call with the assigned value.
  deallocate (MyClassArray)
  call test(3, 0, [7,8], 140)

! This should produce no final calls.
  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(5, 0, [1, 3], 150, rarray = [2.0, 4.0])

! Since 'constructor2; must finalize 'src' after the finalization of
! 'MyClassArray', the result in 'check_array' should be [10,20].
  MyClassArray = constructor2 ([10,20], [10.0,20.0])
  call test(9, 0, [10,20], 160, rarray = [10.0,20.0])

  deallocate (MyClassArray)
  call test(11, 0, [10, 20], 170, rarray = [10.0,20.0])
end program test_final