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.
6 ! Contributed by Paul Thomas <pault@gcc.gnu.org>
7 !******************************************************************************
13 interface assignment(=)
14 module procedure a_to_a, c_to_a, a_to_c
16 interface operator(.ne.)
17 module procedure a_ne_a
21 logical :: l1(4), t = .true., f= .false.
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))
30 elemental subroutine c_to_a (m, n)
31 character(8), intent(in) :: n
32 type(a), intent(out) :: m
36 elemental subroutine a_to_c (m, n)
37 type(a), intent(in) :: n
38 character(8), intent(out) :: m
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)
47 !******************************************************************************
48 elemental function foo (m)
50 type(a), intent(in) :: m
55 !******************************************************************************
58 x = (/a (0, "one"),a (0, "two"),a (0, "three"),a (0, "four")/)
65 (/a(4, "null"), a(8, "non-null"), a(8, "non-null"), a(4, "null")/))) call abort ()
67 subroutine test_where_char1 ! Test a WHERE blocks
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")
78 end subroutine test_where_char2
80 ! { dg-final { cleanup-modules "global" } }