gcc/testsuite/gfortran.dg/defined_assignment_2.f90

   1 ! { dg-do run }
   2 ! Test the fix for PR46897. defined_assignment_1.f90 checks that the PR
   3 ! testcases run correctly, this checks that other requirements of the
   4 ! standard are satisfied.
   5 !
   6 module m0
   7   implicit none
   8   type component
   9     integer :: i = 0
  10     integer, allocatable :: j(:)
  11   contains
  12     procedure :: assign0
  13     generic :: assignment(=)=>assign0
  14   end type
  15   type parent
  16     type(component) :: foo1
  17   end type
  18   type, extends(parent) :: child
  19     integer :: k = 1000
  20     integer, allocatable :: l(:)
  21     type(component) :: foo2
  22   end type
  23 contains
  24   subroutine assign0(lhs,rhs)
  25     class(component), intent(inout) :: lhs
  26     class(component), intent(in) :: rhs
  27     if (lhs%i .eq. 0) then
  28       lhs%i = rhs%i
  29       lhs%j = rhs%j
  30     else
  31       lhs%i = rhs%i*2
  32       lhs%j = [rhs%j, rhs%j*2]
  33     end if
  34   end subroutine
  35   type(child) function new_child()
  36     new_child%parent%foo1%i = 20
  37     new_child%foo2%i = 21
  38     new_child%parent%foo1%j = [99,199]
  39     new_child%foo2%j = [199,299]
  40     new_child%l = [299,399]
  41     new_child%k = 1001
  42   end function
  43 end module
  44
  45 program main
  46   use m0
  47   implicit none
  48   type(child) :: infant0
  49
  50 ! Check that the INTENT(INOUT) of assign0 is respected and that the
  51 ! correct thing is done with allocatable components.
  52   infant0 = new_child()
  53   if (infant0%parent%foo1%i .ne. 20) STOP 1
  54   if (infant0%foo2%i .ne. 21) STOP 2
  55   if (any (infant0%parent%foo1%j .ne. [99,199])) STOP 3
  56   if (any (infant0%foo2%j .ne. [199,299])) STOP 4
  57   if (infant0%foo2%i .ne. 21) STOP 5
  58   if (any (infant0%l .ne. [299,399])) STOP 6
  59
  60 ! Now, since the defined assignment depends on whether or not the 'i'
  61 ! component is the default initialization value, the result will be
  62 ! different.
  63   infant0 = new_child()
  64   if (infant0%parent%foo1%i .ne. 40) STOP 7
  65   if (any (infant0%parent%foo1%j .ne. [99,199,198,398])) STOP 8
  66   if (any (infant0%foo2%j .ne. [199,299,398,598])) STOP 9
  67   if (infant0%foo2%i .ne. 42) STOP 10
  68   if (any (infant0%l .ne. [299,399])) STOP 11
  69
  70 ! Finally, make sure that normal components of the declared type survive.
  71   if (infant0%k .ne. 1001) STOP 12
  72 end
  73
  74