gcc/testsuite/gfortran.dg/dependency_24.f90

   1 ! { dg-do run }
   2 ! Check the fix for PR38863 comment #1, where defined assignment
   3 ! to derived types was not treating components correctly that were
   4 ! not set explicitly.
   5 !
   6 ! Contributed by Mikael Morin  <mikael@gcc.gnu.org>
   7 !
   8 module m
   9   type t
  10     integer :: i,j
  11   end type t
  12   type ti
  13     integer :: i,j = 99
  14   end type ti
  15   interface assignment (=)
  16     module procedure i_to_t, i_to_ti
  17   end interface
  18 contains
  19   elemental subroutine i_to_ti (p, q)
  20     type(ti), intent(out) :: p
  21     integer, intent(in)  :: q
  22     p%i = q
  23   end subroutine
  24   elemental subroutine i_to_t (p, q)
  25     type(t), intent(out) :: p
  26     integer, intent(in)  :: q
  27     p%i = q
  28   end subroutine
  29 end module
  30
  31   use m
  32   call test_t  ! Check original problem
  33   call test_ti ! Default initializers were treated wrongly
  34 contains
  35   subroutine test_t
  36     type(t), target :: a(3)
  37     type(t), target  :: b(3)
  38     type(t), dimension(:), pointer :: p
  39     logical :: l(3)
  40
  41     a%i = 1
  42     a%j = [101, 102, 103]
  43     b%i = 3
  44     b%j = 4
  45
  46     p => b
  47     l = .true.
  48
  49     where (l)
  50       a = p%i         ! Comment #1 of PR38863 concerned WHERE assignment
  51     end where
  52     if (any (a%j .ne. [101, 102, 103])) call abort
  53
  54     a = p%i           ! Ordinary assignment was wrong too.
  55     if (any (a%j .ne. [101, 102, 103])) call abort
  56   end subroutine
  57
  58   subroutine test_ti
  59     type(ti), target :: a(3)
  60     type(ti), target  :: b(3)
  61     type(ti), dimension(:), pointer :: p
  62     logical :: l(3)
  63
  64     a%i = 1
  65     a%j = [101, 102, 103]
  66     b%i = 3
  67     b%j = 4
  68
  69     p => b
  70     l = .true.
  71
  72     where (l)
  73       a = p%i
  74     end where
  75     if (any (a%j .ne. 99)) call abort
  76
  77     a = p%i
  78     if (any (a%j .ne. 99)) call abort
  79   end subroutine
  80 end