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. This tests that the character 4! lengths are transmitted OK. 5! 6! Contributed by Paul Thomas <pault@gcc.gnu.org> 7!****************************************************************************** 8module global 9 type :: a 10 integer :: b 11 character(8):: c 12 end type a 13 interface assignment(=) 14 module procedure a_to_a, c_to_a, a_to_c 15 end interface 16 interface operator(.ne.) 17 module procedure a_ne_a 18 end interface 19 20 type(a) :: x(4), y(4) 21 logical :: l1(4), t = .true., f= .false. 22contains 23!****************************************************************************** 24 elemental subroutine a_to_a (m, n) 25 type(a), intent(in) :: n 26 type(a), intent(out) :: m 27 m%b = len ( trim(n%c)) 28 m%c = n%c 29 end subroutine a_to_a 30 elemental subroutine c_to_a (m, n) 31 character(8), intent(in) :: n 32 type(a), intent(out) :: m 33 m%b = m%b + 1 34 m%c = n 35 end subroutine c_to_a 36 elemental subroutine a_to_c (m, n) 37 type(a), intent(in) :: n 38 character(8), intent(out) :: m 39 m = n%c 40 end subroutine a_to_c 41!****************************************************************************** 42 elemental logical function a_ne_a (m, n) 43 type(a), intent(in) :: n 44 type(a), intent(in) :: m 45 a_ne_a = (m%b .ne. n%b) .or. (m%c .ne. n%c) 46 end function a_ne_a 47!****************************************************************************** 48 elemental function foo (m) 49 type(a) :: foo 50 type(a), intent(in) :: m 51 foo%b = 0 52 foo%c = m%c 53 end function foo 54end module global 55!****************************************************************************** 56program test 57 use global 58 x = (/a (0, "one"),a (0, "two"),a (0, "three"),a (0, "four")/) 59 y = x 60 l1 = (/t,f,f,t/) 61 62 call test_where_char1 63 call test_where_char2 64 if (any(y .ne. & 65 (/a(4, "null"), a(8, "non-null"), a(8, "non-null"), a(4, "null")/))) call abort () 66contains 67 subroutine test_where_char1 ! Test a WHERE blocks 68 where (l1) 69 y = a (0, "null") 70 elsewhere 71 y = x 72 end where 73 end subroutine test_where_char1 74 subroutine test_where_char2 ! Test a WHERE blocks 75 where (y%c .ne. "null") 76 y = a (99, "non-null") 77 endwhere 78 end subroutine test_where_char2 79end program test 80