gcc/testsuite/gfortran.dg/where_operator_assign_3.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. This tests that the character
   4 ! lengths are transmitted OK.
   5 !
   6 ! Contributed by Paul Thomas <pault@gcc.gnu.org>
   7 !******************************************************************************
   8 module global
   9   type :: a
  10     integer :: b
  11     character(8):: c
  12   end type a
  13   interface assignment(=)
  14     module procedure a_to_a, c_to_a, a_to_c
  15   end interface
  16   interface operator(.ne.)
  17     module procedure a_ne_a
  18   end interface
  19
  20   type(a) :: x(4), y(4)
  21   logical :: l1(4), t = .true., f= .false.
  22 contains
  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))
  28     m%c = n%c
  29   end subroutine a_to_a
  30   elemental subroutine c_to_a (m, n)
  31     character(8), intent(in) :: n
  32     type(a), intent(out) :: m
  33     m%b = m%b + 1
  34     m%c = n
  35   end subroutine c_to_a
  36   elemental subroutine a_to_c (m, n)
  37     type(a), intent(in) :: n
  38     character(8), intent(out) :: m
  39     m = n%c
  40   end subroutine a_to_c
  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)
  46   end function a_ne_a
  47 !******************************************************************************
  48   elemental function foo (m)
  49     type(a) :: foo
  50     type(a), intent(in) :: m
  51     foo%b = 0
  52     foo%c = m%c
  53   end function foo
  54 end module global
  55 !******************************************************************************
  56 program test
  57   use global
  58   x = (/a (0, "one"),a (0, "two"),a (0, "three"),a (0, "four")/)
  59   y = x
  60   l1 = (/t,f,f,t/)
  61
  62   call test_where_char1
  63   call test_where_char2
  64   if (any(y .ne. &
  65     (/a(4, "null"), a(8, "non-null"), a(8, "non-null"), a(4, "null")/))) call abort ()
  66 contains
  67   subroutine test_where_char1   ! Test a WHERE blocks
  68     where (l1)
  69       y = a (0, "null")
  70     elsewhere
  71       y = x
  72     end where
  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")
  77     endwhere
  78   end subroutine test_where_char2
  79 end program test