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