diff options
author | upstream source tree <ports@midipix.org> | 2015-03-15 20:14:05 -0400 |
---|---|---|
committer | upstream source tree <ports@midipix.org> | 2015-03-15 20:14:05 -0400 |
commit | 554fd8c5195424bdbcabf5de30fdc183aba391bd (patch) | |
tree | 976dc5ab7fddf506dadce60ae936f43f58787092 /gcc/testsuite/gfortran.dg/where_operator_assign_2.f90 | |
download | cbb-gcc-4.6.4-554fd8c5195424bdbcabf5de30fdc183aba391bd.tar.bz2 cbb-gcc-4.6.4-554fd8c5195424bdbcabf5de30fdc183aba391bd.tar.xz |
obtained gcc-4.6.4.tar.bz2 from upstream website;upstream
verified gcc-4.6.4.tar.bz2.sig;
imported gcc-4.6.4 source tree from verified upstream tarball.
downloading a git-generated archive based on the 'upstream' tag
should provide you with a source tree that is binary identical
to the one extracted from the above tarball.
if you have obtained the source via the command 'git clone',
however, do note that line-endings of files in your working
directory might differ from line-endings of the respective
files in the upstream repository.
Diffstat (limited to 'gcc/testsuite/gfortran.dg/where_operator_assign_2.f90')
-rw-r--r-- | gcc/testsuite/gfortran.dg/where_operator_assign_2.f90 | 106 |
1 files changed, 106 insertions, 0 deletions
diff --git a/gcc/testsuite/gfortran.dg/where_operator_assign_2.f90 b/gcc/testsuite/gfortran.dg/where_operator_assign_2.f90 new file mode 100644 index 000000000..420103f19 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/where_operator_assign_2.f90 @@ -0,0 +1,106 @@ +! { dg-do compile } +! Tests the fix for PR30407, in which operator assignments did not work +! in WHERE blocks or simple WHERE statements. +! +! Contributed by Paul Thomas <pault@gcc.gnu.org> +!****************************************************************************** +module global + type :: a + integer :: b + integer :: c + end type a + interface assignment(=) + module procedure a_to_a + end interface + interface operator(.ne.) + module procedure a_ne_a + end interface + + type(a) :: x(4), y(4), z(4), u(4, 4) + logical :: l1(4), t = .true., f= .false. +contains +!****************************************************************************** + elemental subroutine a_to_a (m, n) + type(a), intent(in) :: n + type(a), intent(out) :: m + m%b = n%b + 1 + m%c = n%c + end subroutine a_to_a +!****************************************************************************** + elemental logical function a_ne_a (m, n) + type(a), intent(in) :: n + type(a), intent(in) :: m + a_ne_a = (m%b .ne. n%b) .or. (m%c .ne. n%c) + end function a_ne_a +!****************************************************************************** + elemental function foo (m) + type(a) :: foo + type(a), intent(in) :: m + foo%b = 0 + foo%c = m%c + end function foo +end module global +!****************************************************************************** +program test + use global + x = (/a (0, 1),a (0, 2),a (0, 3),a (0, 4)/) + y = x + z = x + l1 = (/t, f, f, t/) + + call test_where_1 + if (any (y .ne. (/a (2, 1),a (2, 2),a (2, 3),a (2, 4)/))) call abort () + + call test_where_2 + if (any (y .ne. (/a (1, 0),a (2, 2),a (2, 3),a (1, 0)/))) call abort () + if (any (z .ne. (/a (3, 4),a (1, 0),a (1, 0),a (3, 1)/))) call abort () + + call test_where_3 + if (any (y .ne. (/a (1, 0),a (1, 2),a (1, 3),a (1, 0)/))) call abort () + + y = x + call test_where_forall_1 + if (any (u(4, :) .ne. (/a (1, 4),a (2, 2),a (2, 3),a (1, 4)/))) call abort () + + l1 = (/t, f, t, f/) + call test_where_4 + if (any (x .ne. (/a (1, 1),a (2, 1),a (1, 3),a (2, 3)/))) call abort () + +contains +!****************************************************************************** + subroutine test_where_1 ! Test a simple WHERE + where (l1) y = x + end subroutine test_where_1 +!****************************************************************************** + subroutine test_where_2 ! Test a WHERE blocks + where (l1) + y = a (0, 0) + z = z(4:1:-1) + elsewhere + y = x + z = a (0, 0) + end where + end subroutine test_where_2 +!****************************************************************************** + subroutine test_where_3 ! Test a simple WHERE with a function assignment + where (.not. l1) y = foo (x) + end subroutine test_where_3 +!****************************************************************************** + subroutine test_where_forall_1 ! Test a WHERE in a FORALL block + forall (i = 1:4) + where (.not. l1) + u(i, :) = x + elsewhere + u(i, :) = a(0, i) + endwhere + end forall + end subroutine test_where_forall_1 +!****************************************************************************** + subroutine test_where_4 ! Test a WHERE assignment with dependencies + where (l1(1:3)) + x(2:4) = x(1:3) + endwhere + end subroutine test_where_4 +end program test +! { dg-final { cleanup-modules "global" } } + |