gcc/testsuite/gfortran.dg/where_operator_assign_1.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 is the test provided
   4 ! by the reporter.
   5 !
   6 ! Contributed by Dominique d'Humieres <dominiq@lps.ens.fr>
   7 !==============================================================================
   8
   9 MODULE kind_mod
  10
  11    IMPLICIT NONE
  12
  13    PRIVATE
  14
  15    INTEGER, PUBLIC, PARAMETER :: I4=SELECTED_INT_KIND(9)
  16    INTEGER, PUBLIC, PARAMETER :: TF=KIND(.TRUE._I4)
  17
  18 END MODULE kind_mod
  19
  20 !==============================================================================
  21
  22 MODULE pointer_mod
  23
  24    USE kind_mod, ONLY : I4
  25
  26    IMPLICIT NONE
  27
  28    PRIVATE
  29
  30    TYPE, PUBLIC :: pvt
  31       INTEGER(I4), POINTER, DIMENSION(:) :: vect
  32    END TYPE pvt
  33
  34    INTERFACE ASSIGNMENT(=)
  35       MODULE PROCEDURE p_to_p
  36    END INTERFACE
  37
  38    PUBLIC :: ASSIGNMENT(=)
  39
  40 CONTAINS
  41
  42    !---------------------------------------------------------------------------
  43
  44    PURE ELEMENTAL SUBROUTINE p_to_p(a1, a2)
  45       IMPLICIT NONE
  46       TYPE(pvt), INTENT(OUT) :: a1
  47       TYPE(pvt), INTENT(IN) :: a2
  48       a1%vect = a2%vect
  49    END SUBROUTINE p_to_p
  50
  51    !---------------------------------------------------------------------------
  52
  53 END MODULE pointer_mod
  54
  55 !==============================================================================
  56
  57 PROGRAM test_prog
  58
  59    USE pointer_mod, ONLY : pvt, ASSIGNMENT(=)
  60
  61    USE kind_mod, ONLY : I4, TF
  62
  63    IMPLICIT NONE
  64
  65    INTEGER(I4), DIMENSION(12_I4), TARGET :: ia
  66    LOGICAL(TF), DIMENSION(2_I4,3_I4) :: la
  67    TYPE(pvt), DIMENSION(6_I4) :: pv
  68    INTEGER(I4) :: i
  69
  70    ! Initialisation...
  71    la(:,1_I4:3_I4:2_I4)=.TRUE._TF
  72    la(:,2_I4)=.FALSE._TF
  73
  74    DO i=1_I4,6_I4
  75       pv(i)%vect => ia((2_I4*i-1_I4):(2_I4*i))
  76    END DO
  77
  78    ia=0_I4
  79
  80    DO i=1_I4,3_I4
  81       WHERE(la((/1_I4,2_I4/),i))
  82          pv((2_I4*i-1_I4):(2_I4*i))= iaef((/(2_I4*i-1_I4),(2_I4*i)/))
  83       ELSEWHERE
  84          pv((2_I4*i-1_I4):(2_I4*i))= iaef((/0_I4,0_I4/))
  85       END WHERE
  86    END DO
  87
  88    if (any (ia .ne. (/1,-1,2,-2,0,0,0,0,5,-5,6,-6/))) call abort ()
  89
  90 CONTAINS
  91
  92    TYPE(pvt) ELEMENTAL FUNCTION iaef(index) RESULT(ans)
  93
  94       USE kind_mod, ONLY :  I4
  95       USE pointer_mod, ONLY : pvt, ASSIGNMENT(=)
  96
  97       IMPLICIT NONE
  98
  99       INTEGER(I4), INTENT(IN) :: index
 100
 101       ALLOCATE(ans%vect(2_I4))
 102       ans%vect=(/index,-index/)
 103
 104    END FUNCTION iaef
 105
 106 END PROGRAM test_prog
 107
 108 ! { dg-final { cleanup-modules "kind_mod pointer_mod" } }