gcc/testsuite/gfortran.dg/where_operator_assign_2.f90

   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.
   4 !
   5 ! Contributed by Paul Thomas <pault@gcc.gnu.org>
   6 !******************************************************************************
   7 module global
   8   type :: a
   9     integer :: b
  10     integer :: c
  11   end type a
  12   interface assignment(=)
  13     module procedure a_to_a
  14   end interface
  15   interface operator(.ne.)
  16     module procedure a_ne_a
  17   end interface
  18
  19   type(a) :: x(4), y(4), z(4), u(4, 4)
  20   logical :: l1(4), t = .true., f= .false.
  21 contains
  22 !******************************************************************************
  23   elemental subroutine a_to_a (m, n)
  24     type(a), intent(in) :: n
  25     type(a), intent(out) :: m
  26     m%b = n%b + 1
  27     m%c = n%c
  28   end subroutine a_to_a
  29 !******************************************************************************
  30   elemental logical function a_ne_a (m, n)
  31     type(a), intent(in) :: n
  32     type(a), intent(in) :: m
  33     a_ne_a = (m%b .ne. n%b) .or. (m%c .ne. n%c)
  34   end function a_ne_a
  35 !******************************************************************************
  36   elemental function foo (m)
  37     type(a) :: foo
  38     type(a), intent(in) :: m
  39     foo%b = 0
  40     foo%c = m%c
  41   end function foo
  42 end module global
  43 !******************************************************************************
  44 program test
  45   use global
  46   x = (/a (0, 1),a (0, 2),a (0, 3),a (0, 4)/)
  47   y = x
  48   z = x
  49   l1 = (/t, f, f, t/)
  50
  51   call test_where_1
  52   if (any (y .ne. (/a (2, 1),a (2, 2),a (2, 3),a (2, 4)/))) call abort ()
  53
  54   call test_where_2
  55   if (any (y .ne. (/a (1, 0),a (2, 2),a (2, 3),a (1, 0)/))) call abort ()
  56   if (any (z .ne. (/a (3, 4),a (1, 0),a (1, 0),a (3, 1)/))) call abort ()
  57
  58   call test_where_3
  59   if (any (y .ne. (/a (1, 0),a (1, 2),a (1, 3),a (1, 0)/))) call abort ()
  60
  61   y = x
  62   call test_where_forall_1
  63   if (any (u(4, :) .ne. (/a (1, 4),a (2, 2),a (2, 3),a (1, 4)/))) call abort ()
  64
  65   l1 = (/t, f, t, f/)
  66   call test_where_4
  67   if (any (x .ne. (/a (1, 1),a (2, 1),a (1, 3),a (2, 3)/))) call abort ()
  68
  69 contains
  70 !******************************************************************************
  71   subroutine test_where_1        ! Test a simple WHERE
  72     where (l1) y = x
  73   end subroutine test_where_1
  74 !******************************************************************************
  75   subroutine test_where_2        ! Test a WHERE blocks
  76     where (l1)
  77       y = a (0, 0)
  78       z = z(4:1:-1)
  79     elsewhere
  80       y = x
  81       z = a (0, 0)
  82     end where
  83   end subroutine test_where_2
  84 !******************************************************************************
  85   subroutine test_where_3        ! Test a simple WHERE with a function assignment
  86     where (.not. l1) y = foo (x)
  87   end subroutine test_where_3
  88 !******************************************************************************
  89   subroutine test_where_forall_1 ! Test a WHERE in a FORALL block
  90     forall (i = 1:4)
  91       where (.not. l1)
  92         u(i, :) = x
  93       elsewhere
  94         u(i, :) = a(0, i)
  95       endwhere
  96     end forall
  97   end subroutine test_where_forall_1
  98 !******************************************************************************
  99   subroutine test_where_4       ! Test a WHERE assignment with dependencies
 100     where (l1(1:3))
 101       x(2:4) = x(1:3)
 102     endwhere
 103   end subroutine test_where_4
 104 end program test
 105 ! { dg-final { cleanup-modules "global" } }
 106