1! { dg-do compile }
2! Tests the fix for PR30407, in which operator assignments did not work
3! in WHERE blocks or simple WHERE statements.
4!
5! Contributed by Paul Thomas <pault@gcc.gnu.org>
6!******************************************************************************
7module global
8  type :: a
9    integer :: b
10    integer :: c
11  end type a
12  interface assignment(=)
13    module procedure a_to_a
14  end interface
15  interface operator(.ne.)
16    module procedure a_ne_a
17  end interface
18
19  type(a) :: x(4), y(4), z(4), u(4, 4)
20  logical :: l1(4), t = .true., f= .false.
21contains
22!******************************************************************************
23  elemental subroutine a_to_a (m, n)
24    type(a), intent(in) :: n
25    type(a), intent(out) :: m
26    m%b = n%b + 1
27    m%c = n%c
28  end subroutine a_to_a
29!******************************************************************************
30  elemental logical function a_ne_a (m, n)
31    type(a), intent(in) :: n
32    type(a), intent(in) :: m
33    a_ne_a = (m%b .ne. n%b) .or. (m%c .ne. n%c)
34  end function a_ne_a
35!******************************************************************************
36  elemental function foo (m)
37    type(a) :: foo
38    type(a), intent(in) :: m
39    foo%b = 0
40    foo%c = m%c
41  end function foo
42end module global
43!******************************************************************************
44program test
45  use global
46  x = (/a (0, 1),a (0, 2),a (0, 3),a (0, 4)/)
47  y = x
48  z = x
49  l1 = (/t, f, f, t/)
50
51  call test_where_1
52  if (any (y .ne. (/a (2, 1),a (2, 2),a (2, 3),a (2, 4)/))) call abort ()
53
54  call test_where_2
55  if (any (y .ne. (/a (1, 0),a (2, 2),a (2, 3),a (1, 0)/))) call abort ()
56  if (any (z .ne. (/a (3, 4),a (1, 0),a (1, 0),a (3, 1)/))) call abort ()
57
58  call test_where_3
59  if (any (y .ne. (/a (1, 0),a (1, 2),a (1, 3),a (1, 0)/))) call abort ()
60
61  y = x
62  call test_where_forall_1
63  if (any (u(4, :) .ne. (/a (1, 4),a (2, 2),a (2, 3),a (1, 4)/))) call abort ()
64
65  l1 = (/t, f, t, f/)
66  call test_where_4
67  if (any (x .ne. (/a (1, 1),a (2, 1),a (1, 3),a (2, 3)/))) call abort ()
68
69contains
70!******************************************************************************
71  subroutine test_where_1        ! Test a simple WHERE
72    where (l1) y = x
73  end subroutine test_where_1
74!******************************************************************************
75  subroutine test_where_2        ! Test a WHERE blocks
76    where (l1)
77      y = a (0, 0)
78      z = z(4:1:-1)
79    elsewhere
80      y = x
81      z = a (0, 0)
82    end where
83  end subroutine test_where_2
84!******************************************************************************
85  subroutine test_where_3        ! Test a simple WHERE with a function assignment
86    where (.not. l1) y = foo (x)
87  end subroutine test_where_3
88!******************************************************************************
89  subroutine test_where_forall_1 ! Test a WHERE in a FORALL block
90    forall (i = 1:4)
91      where (.not. l1)
92        u(i, :) = x
93      elsewhere
94        u(i, :) = a(0, i)
95      endwhere
96    end forall
97  end subroutine test_where_forall_1
98!******************************************************************************
99  subroutine test_where_4       ! Test a WHERE assignment with dependencies
100    where (l1(1:3))
101      x(2:4) = x(1:3)
102    endwhere
103  end subroutine test_where_4
104end program test
105