gcc/testsuite/gfortran.dg/defined_assignment_2.f90

! { dg-do run }
! Test the fix for PR46897. defined_assignment_1.f90 checks that the PR
! testcases run correctly, this checks that other requirements of the
! standard are satisfied.
!
module m0
  implicit none
  type component
    integer :: i = 0
    integer, allocatable :: j(:)
  contains
    procedure :: assign0
    generic :: assignment(=)=>assign0
  end type
  type parent
    type(component) :: foo1
  end type
  type, extends(parent) :: child
    integer :: k = 1000
    integer, allocatable :: l(:)
    type(component) :: foo2
  end type
contains
  subroutine assign0(lhs,rhs)
    class(component), intent(inout) :: lhs
    class(component), intent(in) :: rhs
    if (lhs%i .eq. 0) then
      lhs%i = rhs%i
      lhs%j = rhs%j
    else
      lhs%i = rhs%i*2
      lhs%j = [rhs%j, rhs%j*2]
    end if
  end subroutine
  type(child) function new_child()
    new_child%parent%foo1%i = 20
    new_child%foo2%i = 21
    new_child%parent%foo1%j = [99,199]
    new_child%foo2%j = [199,299]
    new_child%l = [299,399]
    new_child%k = 1001
  end function
end module

program main
  use m0
  implicit none
  type(child) :: infant0

! Check that the INTENT(INOUT) of assign0 is respected and that the
! correct thing is done with allocatable components.
  infant0 = new_child()
  if (infant0%parent%foo1%i .ne. 20) STOP 1
  if (infant0%foo2%i .ne. 21) STOP 2
  if (any (infant0%parent%foo1%j .ne. [99,199])) STOP 3
  if (any (infant0%foo2%j .ne. [199,299])) STOP 4
  if (infant0%foo2%i .ne. 21) STOP 5
  if (any (infant0%l .ne. [299,399])) STOP 6

! Now, since the defined assignment depends on whether or not the 'i'
! component is the default initialization value, the result will be
! different.
  infant0 = new_child()
  if (infant0%parent%foo1%i .ne. 40) STOP 7
  if (any (infant0%parent%foo1%j .ne. [99,199,198,398])) STOP 8
  if (any (infant0%foo2%j .ne. [199,299,398,598])) STOP 9
  if (infant0%foo2%i .ne. 42) STOP 10
  if (any (infant0%l .ne. [299,399])) STOP 11

! Finally, make sure that normal components of the declared type survive.
  if (infant0%k .ne. 1001) STOP 12
end