flang/test/Semantics/doconcurrent01.f90

   1 ! RUN: %python %S/test_errors.py %s %flang_fc1
   2 ! C1141
   3 ! A reference to the procedure IEEE_SET_HALTING_MODE ! from the intrinsic
   4 ! module IEEE_EXCEPTIONS, shall not ! appear within a DO CONCURRENT construct.
   5 !
   6 ! C1137
   7 ! An image control statement shall not appear within a DO CONCURRENT construct.
   8 !
   9 ! C1136
  10 ! A RETURN statement shall not appear within a DO CONCURRENT construct.
  11 !
  12 ! (11.1.7.5), paragraph 4
  13 ! In a DO CONCURRENT, can't have an i/o statement with an ADVANCE= specifier
  14
  15 subroutine do_concurrent_test1(i,n)
  16   implicit none
  17   integer :: i, n
  18   do 10 concurrent (i = 1:n)
  19 !ERROR: An image control statement is not allowed in DO CONCURRENT
  20      SYNC ALL
  21 !ERROR: An image control statement is not allowed in DO CONCURRENT
  22      SYNC IMAGES (*)
  23 !ERROR: An image control statement is not allowed in DO CONCURRENT
  24      SYNC MEMORY
  25 !ERROR: An image control statement is not allowed in DO CONCURRENT
  26      stop
  27 !ERROR: An image control statement is not allowed in DO CONCURRENT
  28      if (.false.) stop
  29      error stop ! ok
  30 !ERROR: RETURN is not allowed in DO CONCURRENT
  31      return
  32 10 continue
  33 end subroutine do_concurrent_test1
  34
  35 subroutine do_concurrent_test2(i,j,n,flag)
  36   use ieee_exceptions
  37   use iso_fortran_env, only: team_type
  38   implicit none
  39   integer :: i, n
  40   type(ieee_flag_type) :: flag
  41   logical :: flagValue, halting
  42   type(team_type) :: j
  43   type(ieee_status_type) :: status
  44   do concurrent (i = 1:n)
  45 !ERROR: An image control statement is not allowed in DO CONCURRENT
  46     sync team (j)
  47 !ERROR: An image control statement is not allowed in DO CONCURRENT
  48     change team (j)
  49 !ERROR: An image control statement is not allowed in DO CONCURRENT
  50       critical
  51       end critical
  52     end team
  53 !ERROR: ADVANCE specifier is not allowed in DO CONCURRENT
  54     write(*,'(a35)',advance='no')
  55 !ERROR: 'ieee_get_status' may not be called in DO CONCURRENT
  56     call ieee_get_status(status)
  57 !ERROR: 'ieee_set_status' may not be called in DO CONCURRENT
  58     call ieee_set_status(status)
  59 !ERROR: 'ieee_get_halting_mode' may not be called in DO CONCURRENT
  60     call ieee_get_halting_mode(flag, halting)
  61 !ERROR: 'ieee_set_halting_mode' may not be called in DO CONCURRENT
  62     call ieee_set_halting_mode(flag, halting)
  63 !ERROR: 'ieee_get_flag' may not be called in DO CONCURRENT
  64     call ieee_get_flag(flag, flagValue)
  65 !ERROR: 'ieee_set_flag' may not be called in DO CONCURRENT
  66     call ieee_set_flag(flag, flagValue)
  67   end do
  68 end subroutine do_concurrent_test2
  69
  70 subroutine s1()
  71   use iso_fortran_env
  72   type(event_type) :: x[*]
  73   do concurrent (i = 1:n)
  74 !ERROR: An image control statement is not allowed in DO CONCURRENT
  75     event post (x)
  76   end do
  77 end subroutine s1
  78
  79 subroutine s2()
  80   use iso_fortran_env
  81   type(event_type) :: x[*]
  82   do concurrent (i = 1:n)
  83 !ERROR: An image control statement is not allowed in DO CONCURRENT
  84     event wait (x)
  85   end do
  86 end subroutine s2
  87
  88 subroutine s3()
  89   use iso_fortran_env
  90   type(team_type) :: t
  91
  92   do concurrent (i = 1:n)
  93 !ERROR: An image control statement is not allowed in DO CONCURRENT
  94     form team(1, t)
  95   end do
  96 end subroutine s3
  97
  98 subroutine s4()
  99   use iso_fortran_env
 100   type(lock_type) :: l
 101
 102   do concurrent (i = 1:n)
 103 !ERROR: An image control statement is not allowed in DO CONCURRENT
 104     lock(l)
 105 !ERROR: An image control statement is not allowed in DO CONCURRENT
 106     unlock(l)
 107   end do
 108 end subroutine s4
 109
 110 subroutine s5()
 111   do concurrent (i = 1:n)
 112 !ERROR: An image control statement is not allowed in DO CONCURRENT
 113     stop
 114   end do
 115 end subroutine s5
 116
 117 subroutine s6()
 118   type :: type0
 119     integer, allocatable, dimension(:) :: type0_field
 120     integer, allocatable, dimension(:), codimension[:] :: coarray_type0_field
 121   end type
 122
 123   type :: type1
 124     type(type0) :: type1_field
 125   end type
 126
 127   type(type1) :: pvar;
 128   type(type1) :: qvar;
 129   integer, allocatable, dimension(:) :: array1
 130   integer, allocatable, dimension(:) :: array2
 131   integer, allocatable, codimension[:] :: ca, cb
 132   integer, allocatable :: aa, ab
 133
 134   ! All of the following are allowable outside a DO CONCURRENT
 135   allocate(array1(3), pvar%type1_field%type0_field(3), array2(9))
 136   allocate(pvar%type1_field%coarray_type0_field(3)[*])
 137   allocate(ca[*])
 138   allocate(ca[*], pvar%type1_field%coarray_type0_field(3)[*])
 139
 140   do concurrent (i = 1:10)
 141     allocate(pvar%type1_field%type0_field(3))
 142   end do
 143
 144   do concurrent (i = 1:10)
 145 !ERROR: An image control statement is not allowed in DO CONCURRENT
 146     allocate(ca[*])
 147   end do
 148
 149   do concurrent (i = 1:10)
 150 !ERROR: An image control statement is not allowed in DO CONCURRENT
 151     deallocate(ca)
 152   end do
 153
 154   do concurrent (i = 1:10)
 155 !ERROR: An image control statement is not allowed in DO CONCURRENT
 156     allocate(pvar%type1_field%coarray_type0_field(3)[*])
 157   end do
 158
 159   do concurrent (i = 1:10)
 160 !ERROR: An image control statement is not allowed in DO CONCURRENT
 161     deallocate(pvar%type1_field%coarray_type0_field)
 162   end do
 163
 164   do concurrent (i = 1:10)
 165 !ERROR: An image control statement is not allowed in DO CONCURRENT
 166     allocate(ca[*], pvar%type1_field%coarray_type0_field(3)[*])
 167   end do
 168
 169   do concurrent (i = 1:10)
 170 !ERROR: An image control statement is not allowed in DO CONCURRENT
 171     deallocate(ca, pvar%type1_field%coarray_type0_field)
 172   end do
 173
 174 ! Call to MOVE_ALLOC of a coarray outside a DO CONCURRENT.  This is OK.
 175   call move_alloc(ca, cb)
 176
 177 ! Call to MOVE_ALLOC with non-coarray arguments in a DO CONCURRENT.  This is OK.
 178   allocate(aa)
 179   do concurrent (i = 1:10)
 180     call move_alloc(aa, ab)
 181   end do
 182
 183   do concurrent (i = 1:10)
 184 !ERROR: An image control statement is not allowed in DO CONCURRENT
 185     call move_alloc(ca, cb)
 186   end do
 187
 188   do concurrent (i = 1:10)
 189 !ERROR: An image control statement is not allowed in DO CONCURRENT
 190     call move_alloc(pvar%type1_field%coarray_type0_field, qvar%type1_field%coarray_type0_field)
 191   end do
 192 end subroutine s6
 193
 194 subroutine s7()
 195   interface
 196     pure integer function pf()
 197     end function pf
 198   end interface
 199   interface generic
 200     impure integer function ipf()
 201     end function ipf
 202   end interface
 203
 204   type :: procTypeNotPure
 205     procedure(notPureFunc), pointer, nopass :: notPureProcComponent
 206   end type procTypeNotPure
 207
 208   type :: procTypePure
 209     procedure(pf), pointer, nopass :: pureProcComponent
 210   end type procTypePure
 211
 212   type(procTypeNotPure) :: procVarNotPure
 213   type(procTypePure) :: procVarPure
 214   integer :: ivar
 215
 216   procVarPure%pureProcComponent => pureFunc
 217
 218   do concurrent (i = 1:10)
 219     print *, "hello"
 220   end do
 221
 222   do concurrent (i = 1:10)
 223     ivar = pureFunc()
 224   end do
 225
 226   ! This should not generate errors
 227   do concurrent (i = 1:10)
 228     ivar = procVarPure%pureProcComponent()
 229   end do
 230
 231   ! This should generate an error
 232   do concurrent (i = 1:10)
 233 !ERROR: Impure procedure 'notpureproccomponent' may not be referenced in DO CONCURRENT
 234     ivar = procVarNotPure%notPureProcComponent()
 235   end do
 236
 237   ! This should generate an error
 238   do concurrent (i = 1:10)
 239 !ERROR: Impure procedure 'ipf' may not be referenced in DO CONCURRENT
 240     ivar = generic()
 241   end do
 242
 243   contains
 244     integer function notPureFunc()
 245       notPureFunc = 2
 246     end function notPureFunc
 247
 248     pure integer function pureFunc()
 249       pureFunc = 3
 250     end function pureFunc
 251
 252 end subroutine s7
 253
 254 module m8
 255   type t
 256    contains
 257     procedure tbpAssign
 258     generic :: assignment(=) => tbpAssign
 259   end type
 260   interface assignment(=)
 261     module procedure nonTbpAssign
 262   end interface
 263  contains
 264   impure elemental subroutine tbpAssign(to, from)
 265     class(t), intent(out) :: to
 266     class(t), intent(in) :: from
 267     print *, 'impure due to I/O'
 268   end
 269   impure elemental subroutine nonTbpAssign(to, from)
 270     type(t), intent(out) :: to
 271     integer, intent(in) :: from
 272     print *, 'impure due to I/O'
 273   end
 274   subroutine test
 275     type(t) x, y
 276     do concurrent (j=1:1)
 277       !ERROR: The defined assignment subroutine 'tbpassign' is not pure
 278       x = y
 279       !ERROR: The defined assignment subroutine 'nontbpassign' is not pure
 280       x = 666
 281     end do
 282   end
 283 end