gcc/testsuite/gfortran.dg/pr109948.f90

   1 ! { dg-do compile }
   2 !
   3 ! Tests the fix for PR109948
   4 !
   5 ! Contributed by Rimvydas Jasinskas <rimvydas.jas@gmail.com>
   6 !
   7 module mm
   8   implicit none
   9   interface operator(==)
  10     module procedure eq_1_2
  11   end interface operator(==)
  12   private :: eq_1_2
  13 contains
  14   logical function eq_1_2 (x, y)
  15     integer, intent(in) :: x(:)
  16     real,    intent(in) :: y(:,:)
  17     eq_1_2 = .true.
  18   end function eq_1_2
  19 end module mm
  20
  21 program pr109948
  22   use mm
  23   implicit none
  24   type tlap
  25     integer,    allocatable :: z(:)
  26   end type tlap
  27   type ulap
  28     type(tlap) :: u(2)
  29   end type ulap
  30   integer :: pid = 1
  31   call comment0         ! Original problem
  32   call comment1
  33   call comment3 ([5,4,3,2,1])
  34   call comment10
  35   call comment11 ([5,4,3,2,1])
  36 contains
  37   subroutine comment0
  38     type(tlap) :: y_in
  39     integer :: x_out(3) =[0.0,0.0,0.0]
  40     y_in%z = [1,-2,3]
  41     call foo(y_in, x_out)
  42     if (any (x_out .ne. [0, -2, 0])) stop 1
  43     call foo(y_in, x_out)
  44     if (any (x_out .ne. [1, -2, 3])) stop 2
  45   end subroutine comment0
  46
  47   subroutine foo(y, x)
  48     type(tlap) :: y
  49     integer :: x(:)
  50     associate(z=>y%z)
  51       if (pid == 1) then
  52         where ( z < 0 ) x(:) = z(:)
  53       else
  54         where ( z > 0 ) x(:) = z(:)
  55     endif
  56     pid = pid + 1
  57     end associate
  58   end subroutine foo
  59
  60   subroutine comment1
  61     type(tlap) :: grib
  62     integer :: i
  63     grib%z = [3,2,1]
  64     associate(k=>grib%z)
  65       i = k(1)
  66       if (any(k==1)) i = 1
  67     end associate
  68     if (i .eq. 3) stop 3
  69   end subroutine comment1
  70
  71   subroutine comment3(k_2d)
  72     implicit none
  73     integer :: k_2d(:)
  74     integer :: i
  75     associate(k=>k_2d)
  76       i = k(1)
  77       if (any(k==1)) i = 1
  78     end associate
  79     if (i .eq. 3) stop 4
  80   end subroutine comment3
  81
  82   subroutine comment11(k_2d)
  83     implicit none
  84     integer :: k_2d(:)
  85     integer :: m(1) = 42
  86     real    :: r(1,1) = 3.0
  87     if ((m == r) .neqv. .true.) stop 5
  88     associate (k=>k_2d)
  89       if ((k == r) .neqv. .true.) stop 6  ! failed to find user defined operator
  90     end associate
  91     associate (k=>k_2d(:))
  92       if ((k == r) .neqv. .true.) stop 7
  93     end associate
  94   end subroutine comment11
  95
  96   subroutine comment10
  97     implicit none
  98     type(ulap) :: z(2)
  99     integer :: i
 100     real    :: r(1,1) = 3.0
 101     z(1)%u = [tlap([1,2,3]),tlap([4,5,6])]
 102     z(2)%u = [tlap([7,8,9]),tlap([10,11,12])]
 103     associate (k=>z(2)%u(1)%z)
 104       i = k(1)
 105       if (any(k==8)) i = 1
 106     end associate
 107     if (i .ne. 1) stop 8
 108     associate (k=>z(1)%u(2)%z)
 109       if ((k == r) .neqv. .true.) stop 9
 110       if (any (k .ne. [4,5,6])) stop 10
 111     end associate
 112   end subroutine comment10
 113 end program pr109948
 114