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!
8module 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
18contains
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
29end module
30
31  use m
32  call test_t  ! Check original problem
33  call test_ti ! Default initializers were treated wrongly
34contains
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])) STOP 1
53
54    a = p%i           ! Ordinary assignment was wrong too.
55    if (any (a%j .ne. [101, 102, 103])) STOP 2
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)) STOP 3
76
77    a = p%i
78    if (any (a%j .ne. 99)) STOP 4
79  end subroutine
80end
81