From 554fd8c5195424bdbcabf5de30fdc183aba391bd Mon Sep 17 00:00:00 2001
From: upstream source tree <ports@midipix.org>
Date: Sun, 15 Mar 2015 20:14:05 -0400
Subject: obtained gcc-4.6.4.tar.bz2 from upstream website; 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.
---
 .../gfortran.dg/where_operator_assign_3.f90        | 81 ++++++++++++++++++++++
 1 file changed, 81 insertions(+)
 create mode 100644 gcc/testsuite/gfortran.dg/where_operator_assign_3.f90

(limited to 'gcc/testsuite/gfortran.dg/where_operator_assign_3.f90')

diff --git a/gcc/testsuite/gfortran.dg/where_operator_assign_3.f90 b/gcc/testsuite/gfortran.dg/where_operator_assign_3.f90
new file mode 100644
index 000000000..eddbdfc00
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/where_operator_assign_3.f90
@@ -0,0 +1,81 @@
+! { dg-do compile }
+! Tests the fix for PR30407, in which operator assignments did not work
+! in WHERE blocks or simple WHERE statements. This tests that the character
+! lengths are transmitted OK.
+!
+! Contributed by Paul Thomas <pault@gcc.gnu.org>
+!******************************************************************************
+module global
+  type :: a
+    integer :: b
+    character(8):: c
+  end type a
+  interface assignment(=)
+    module procedure a_to_a, c_to_a, a_to_c
+  end interface
+  interface operator(.ne.)
+    module procedure a_ne_a
+  end interface
+
+  type(a) :: x(4), y(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 = len ( trim(n%c))
+    m%c = n%c
+  end subroutine a_to_a
+  elemental subroutine c_to_a (m, n)
+    character(8), intent(in) :: n
+    type(a), intent(out) :: m
+    m%b = m%b + 1
+    m%c = n
+  end subroutine c_to_a
+  elemental subroutine a_to_c (m, n)
+    type(a), intent(in) :: n
+    character(8), intent(out) :: m
+    m = n%c
+  end subroutine a_to_c
+!******************************************************************************
+  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, "one"),a (0, "two"),a (0, "three"),a (0, "four")/)
+  y = x
+  l1 = (/t,f,f,t/)
+
+  call test_where_char1
+  call test_where_char2
+  if (any(y .ne. &
+    (/a(4, "null"), a(8, "non-null"), a(8, "non-null"), a(4, "null")/))) call abort ()
+contains
+  subroutine test_where_char1   ! Test a WHERE blocks
+    where (l1)
+      y = a (0, "null")
+    elsewhere
+      y = x
+    end where
+  end subroutine test_where_char1
+  subroutine test_where_char2   ! Test a WHERE blocks
+    where (y%c .ne. "null")
+      y = a (99, "non-null")
+    endwhere
+  end subroutine test_where_char2
+end program test 
+! { dg-final { cleanup-modules "global" } }
+
-- 
cgit v1.2.3