summaryrefslogtreecommitdiff
path: root/gcc/testsuite/gfortran.dg/where_operator_assign_1.f90
blob: c2b4abf851892c85f2996e31853be6492c62ba54 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
! { dg-do compile }
! Tests the fix for PR30407, in which operator assignments did not work
! in WHERE blocks or simple WHERE statements.  This is the test provided
! by the reporter.
!
! Contributed by Dominique d'Humieres <dominiq@lps.ens.fr>
!==============================================================================

MODULE kind_mod

   IMPLICIT NONE

   PRIVATE

   INTEGER, PUBLIC, PARAMETER :: I4=SELECTED_INT_KIND(9)
   INTEGER, PUBLIC, PARAMETER :: TF=KIND(.TRUE._I4)

END MODULE kind_mod

!==============================================================================

MODULE pointer_mod

   USE kind_mod, ONLY : I4

   IMPLICIT NONE

   PRIVATE

   TYPE, PUBLIC :: pvt
      INTEGER(I4), POINTER, DIMENSION(:) :: vect
   END TYPE pvt

   INTERFACE ASSIGNMENT(=)
      MODULE PROCEDURE p_to_p
   END INTERFACE

   PUBLIC :: ASSIGNMENT(=)

CONTAINS

   !---------------------------------------------------------------------------

   PURE ELEMENTAL SUBROUTINE p_to_p(a1, a2)
      IMPLICIT NONE
      TYPE(pvt), INTENT(OUT) :: a1
      TYPE(pvt), INTENT(IN) :: a2
      a1%vect = a2%vect
   END SUBROUTINE p_to_p

   !---------------------------------------------------------------------------

END MODULE pointer_mod

!==============================================================================

PROGRAM test_prog

   USE pointer_mod, ONLY : pvt, ASSIGNMENT(=)

   USE kind_mod, ONLY : I4, TF

   IMPLICIT NONE

   INTEGER(I4), DIMENSION(12_I4), TARGET :: ia
   LOGICAL(TF), DIMENSION(2_I4,3_I4) :: la
   TYPE(pvt), DIMENSION(6_I4) :: pv
   INTEGER(I4) :: i

   ! Initialisation...
   la(:,1_I4:3_I4:2_I4)=.TRUE._TF
   la(:,2_I4)=.FALSE._TF

   DO i=1_I4,6_I4
      pv(i)%vect => ia((2_I4*i-1_I4):(2_I4*i))
   END DO

   ia=0_I4

   DO i=1_I4,3_I4
      WHERE(la((/1_I4,2_I4/),i))
         pv((2_I4*i-1_I4):(2_I4*i))= iaef((/(2_I4*i-1_I4),(2_I4*i)/))
      ELSEWHERE
         pv((2_I4*i-1_I4):(2_I4*i))= iaef((/0_I4,0_I4/))
      END WHERE
   END DO

   if (any (ia .ne. (/1,-1,2,-2,0,0,0,0,5,-5,6,-6/))) call abort ()

CONTAINS

   TYPE(pvt) ELEMENTAL FUNCTION iaef(index) RESULT(ans)

      USE kind_mod, ONLY :  I4
      USE pointer_mod, ONLY : pvt, ASSIGNMENT(=)

      IMPLICIT NONE

      INTEGER(I4), INTENT(IN) :: index

      ALLOCATE(ans%vect(2_I4))
      ans%vect=(/index,-index/)

   END FUNCTION iaef

END PROGRAM test_prog

! { dg-final { cleanup-modules "kind_mod pointer_mod" } }