2 ! Tests the fix for PR30407, in which operator assignments did not work
3 ! in WHERE blocks or simple WHERE statements.
5 ! Contributed by Paul Thomas <pault@gcc.gnu.org>
6 !******************************************************************************
12 interface assignment(=)
13 module procedure a_to_a
15 interface operator(.ne.)
16 module procedure a_ne_a
19 type(a) :: x(4), y(4), z(4), u(4, 4)
20 logical :: l1(4), t = .true., f= .false.
22 !******************************************************************************
23 elemental subroutine a_to_a (m, n)
24 type(a), intent(in) :: n
25 type(a), intent(out) :: m
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)
35 !******************************************************************************
36 elemental function foo (m)
38 type(a), intent(in) :: m
43 !******************************************************************************
46 x = (/a (0, 1),a (0, 2),a (0, 3),a (0, 4)/)
52 if (any (y .ne. (/a (2, 1),a (2, 2),a (2, 3),a (2, 4)/))) call abort ()
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 ()
59 if (any (y .ne. (/a (1, 0),a (1, 2),a (1, 3),a (1, 0)/))) call abort ()
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 ()
67 if (any (x .ne. (/a (1, 1),a (2, 1),a (1, 3),a (2, 3)/))) call abort ()
70 !******************************************************************************
71 subroutine test_where_1 ! Test a simple WHERE
73 end subroutine test_where_1
74 !******************************************************************************
75 subroutine test_where_2 ! Test a WHERE blocks
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
97 end subroutine test_where_forall_1
98 !******************************************************************************
99 subroutine test_where_4 ! Test a WHERE assignment with dependencies
103 end subroutine test_where_4
105 ! { dg-final { cleanup-modules "global" } }