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) call abort
  if (infant0%foo2%i .ne. 21) call abort
  if (any (infant0%parent%foo1%j .ne. [99,199])) call abort
  if (any (infant0%foo2%j .ne. [199,299])) call abort
  if (infant0%foo2%i .ne. 21) call abort
  if (any (infant0%l .ne. [299,399])) call abort

! 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) call abort
  if (any (infant0%parent%foo1%j .ne. [99,199,198,398])) call abort
  if (any (infant0%foo2%j .ne. [199,299,398,598])) call abort
  if (infant0%foo2%i .ne. 42) call abort
  if (any (infant0%l .ne. [299,399])) call abort

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