gcc/testsuite/gfortran.dg/defined_assignment_1.f90

   1 ! { dg-do run }
   2 ! Test the fix for PR46897.
   3 !
   4 ! Contributed by Rouson Damian <rouson@sandia.gov>
   5 !
   6 module m0
   7   implicit none
   8   type component
   9     integer :: i = 0
  10   contains
  11     procedure :: assign0
  12     generic :: assignment(=)=>assign0
  13   end type
  14   type parent
  15     type(component) :: foo
  16   end type
  17   type, extends(parent) :: child
  18     integer :: j
  19   end type
  20 contains
  21   subroutine assign0(lhs,rhs)
  22     class(component), intent(out) :: lhs
  23     class(component), intent(in) :: rhs
  24     lhs%i = 20
  25   end subroutine
  26   type(child) function new_child()
  27   end function
  28 end module
  29
  30 module m1
  31   implicit none
  32   type component1
  33     integer :: i = 1
  34   contains
  35     procedure :: assign1
  36     generic :: assignment(=)=>assign1
  37   end type
  38   type t
  39     type(component1) :: foo
  40   end type
  41 contains
  42   subroutine assign1(lhs,rhs)
  43     class(component1), intent(out) :: lhs
  44     class(component1), intent(in) :: rhs
  45     lhs%i = 21
  46   end subroutine
  47 end module
  48
  49 module m2
  50   implicit none
  51   type component2
  52     integer :: i = 2
  53   end type
  54   interface assignment(=)
  55     module procedure assign2
  56   end interface
  57   type t2
  58     type(component2) :: foo
  59   end type
  60 contains
  61   subroutine assign2(lhs,rhs)
  62     type(component2), intent(out) :: lhs
  63     type(component2), intent(in) :: rhs
  64     lhs%i = 22
  65   end subroutine
  66 end module
  67
  68 program main
  69   use m0
  70   use m1
  71   use m2
  72   implicit none
  73   type(child) :: infant0
  74   type(t) :: infant1, newchild1
  75   type(t2) :: infant2, newchild2
  76
  77 ! Test the reported problem.
  78   infant0 = new_child()
  79   if (infant0%parent%foo%i .ne. 20) call abort
  80
  81 ! Test the case of comment #1 of the PR.
  82   infant1 = newchild1
  83   if (infant1%foo%i .ne. 21) call abort
  84
  85 ! Test the case of comment #2 of the PR.
  86   infant2 = newchild2
  87   if (infant2%foo%i .ne. 2) call abort
  88 end
  89
  90