! { dg-do compile }
|
! { dg-do compile }
|
! Tests the fix for PR30407, in which operator assignments did not work
|
! Tests the fix for PR30407, in which operator assignments did not work
|
! in WHERE blocks or simple WHERE statements. This tests that the character
|
! in WHERE blocks or simple WHERE statements. This tests that the character
|
! lengths are transmitted OK.
|
! lengths are transmitted OK.
|
!
|
!
|
! Contributed by Paul Thomas
|
! Contributed by Paul Thomas
|
!******************************************************************************
|
!******************************************************************************
|
module global
|
module global
|
type :: a
|
type :: a
|
integer :: b
|
integer :: b
|
character(8):: c
|
character(8):: c
|
end type a
|
end type a
|
interface assignment(=)
|
interface assignment(=)
|
module procedure a_to_a, c_to_a, a_to_c
|
module procedure a_to_a, c_to_a, a_to_c
|
end interface
|
end interface
|
interface operator(.ne.)
|
interface operator(.ne.)
|
module procedure a_ne_a
|
module procedure a_ne_a
|
end interface
|
end interface
|
|
|
type(a) :: x(4), y(4)
|
type(a) :: x(4), y(4)
|
logical :: l1(4), t = .true., f= .false.
|
logical :: l1(4), t = .true., f= .false.
|
contains
|
contains
|
!******************************************************************************
|
!******************************************************************************
|
elemental subroutine a_to_a (m, n)
|
elemental subroutine a_to_a (m, n)
|
type(a), intent(in) :: n
|
type(a), intent(in) :: n
|
type(a), intent(out) :: m
|
type(a), intent(out) :: m
|
m%b = len ( trim(n%c))
|
m%b = len ( trim(n%c))
|
m%c = n%c
|
m%c = n%c
|
end subroutine a_to_a
|
end subroutine a_to_a
|
elemental subroutine c_to_a (m, n)
|
elemental subroutine c_to_a (m, n)
|
character(8), intent(in) :: n
|
character(8), intent(in) :: n
|
type(a), intent(out) :: m
|
type(a), intent(out) :: m
|
m%b = m%b + 1
|
m%b = m%b + 1
|
m%c = n
|
m%c = n
|
end subroutine c_to_a
|
end subroutine c_to_a
|
elemental subroutine a_to_c (m, n)
|
elemental subroutine a_to_c (m, n)
|
type(a), intent(in) :: n
|
type(a), intent(in) :: n
|
character(8), intent(out) :: m
|
character(8), intent(out) :: m
|
m = n%c
|
m = n%c
|
end subroutine a_to_c
|
end subroutine a_to_c
|
!******************************************************************************
|
!******************************************************************************
|
elemental logical function a_ne_a (m, n)
|
elemental logical function a_ne_a (m, n)
|
type(a), intent(in) :: n
|
type(a), intent(in) :: n
|
type(a), intent(in) :: m
|
type(a), intent(in) :: m
|
a_ne_a = (m%b .ne. n%b) .or. (m%c .ne. n%c)
|
a_ne_a = (m%b .ne. n%b) .or. (m%c .ne. n%c)
|
end function a_ne_a
|
end function a_ne_a
|
!******************************************************************************
|
!******************************************************************************
|
elemental function foo (m)
|
elemental function foo (m)
|
type(a) :: foo
|
type(a) :: foo
|
type(a), intent(in) :: m
|
type(a), intent(in) :: m
|
foo%b = 0
|
foo%b = 0
|
foo%c = m%c
|
foo%c = m%c
|
end function foo
|
end function foo
|
end module global
|
end module global
|
!******************************************************************************
|
!******************************************************************************
|
program test
|
program test
|
use global
|
use global
|
x = (/a (0, "one"),a (0, "two"),a (0, "three"),a (0, "four")/)
|
x = (/a (0, "one"),a (0, "two"),a (0, "three"),a (0, "four")/)
|
y = x
|
y = x
|
l1 = (/t,f,f,t/)
|
l1 = (/t,f,f,t/)
|
|
|
call test_where_char1
|
call test_where_char1
|
call test_where_char2
|
call test_where_char2
|
if (any(y .ne. &
|
if (any(y .ne. &
|
(/a(4, "null"), a(8, "non-null"), a(8, "non-null"), a(4, "null")/))) call abort ()
|
(/a(4, "null"), a(8, "non-null"), a(8, "non-null"), a(4, "null")/))) call abort ()
|
contains
|
contains
|
subroutine test_where_char1 ! Test a WHERE blocks
|
subroutine test_where_char1 ! Test a WHERE blocks
|
where (l1)
|
where (l1)
|
y = a (0, "null")
|
y = a (0, "null")
|
elsewhere
|
elsewhere
|
y = x
|
y = x
|
end where
|
end where
|
end subroutine test_where_char1
|
end subroutine test_where_char1
|
subroutine test_where_char2 ! Test a WHERE blocks
|
subroutine test_where_char2 ! Test a WHERE blocks
|
where (y%c .ne. "null")
|
where (y%c .ne. "null")
|
y = a (99, "non-null")
|
y = a (99, "non-null")
|
endwhere
|
endwhere
|
end subroutine test_where_char2
|
end subroutine test_where_char2
|
end program test
|
end program test
|
! { dg-final { cleanup-modules "global" } }
|
! { dg-final { cleanup-modules "global" } }
|
|
|
|
|
