flang/test/Semantics/collectives05.f90

   1 ! RUN: %python %S/test_errors.py %s %flang_fc1
   2 ! XFAIL: *
   3 ! This test checks for semantic errors in co_reduce subroutine calls based on
   4 ! the co_reduce interface defined in section 16.9.49 of the Fortran 2018 standard.
   5 ! To Do: add co_reduce to the list of intrinsics
   6
   7 module foo_m
   8   implicit none
   9
  10   type foo_t
  11     integer :: n=0
  12   contains
  13     procedure :: derived_type_op
  14     generic :: operator(+) => derived_type_op
  15   end type
  16
  17 contains
  18
  19   pure function derived_type_op(lhs, rhs) result(lhs_op_rhs)
  20     class(foo_t), intent(in) :: lhs, rhs
  21     type(foo_t) lhs_op_rhs
  22     lhs_op_rhs%n = lhs%n + rhs%n
  23   end function
  24
  25 end module foo_m
  26
  27 program main
  28   use foo_m, only : foo_t
  29   implicit none
  30
  31   type(foo_t) foo
  32   class(foo_t), allocatable :: polymorphic
  33   integer i, status, integer_array(1)
  34   real x
  35   real vector(1)
  36   real array(1,1,1, 1,1,1, 1,1,1, 1,1,1, 1,1,1)
  37   character(len=1) string, message, character_array(1)
  38   integer coindexed[*]
  39   logical bool
  40
  41   ! correct calls, should produce no errors
  42   call co_reduce(i,      int_op)
  43   call co_reduce(i,      int_op,                            status)
  44   call co_reduce(i,      int_op,                            stat=status)
  45   call co_reduce(i,      int_op,                                         errmsg=message)
  46   call co_reduce(i,      int_op,                            stat=status, errmsg=message)
  47   call co_reduce(i,      int_op,            result_image=1, stat=status, errmsg=message)
  48   call co_reduce(i,      operation=int_op,  result_image=1, stat=status, errmsg=message)
  49   call co_reduce(a=i,    operation=int_op,  result_image=1, stat=status, errmsg=message)
  50   call co_reduce(array,  operation=real_op, result_image=1, stat=status, errmsg=message)
  51   call co_reduce(vector, operation=real_op, result_image=1, stat=status, errmsg=message)
  52   call co_reduce(string, operation=char_op, result_image=1, stat=status, errmsg=message)
  53   call co_reduce(foo,    operation=left,    result_image=1, stat=status, errmsg=message)
  54
  55   call co_reduce(result_image=1, operation=left,     a=foo, errmsg=message, stat=status)
  56
  57   allocate(foo_t :: polymorphic)
  58
  59   ! Test all statically verifiable semantic requirements on co_reduce arguments
  60   ! Note: We cannot check requirements that relate to "corresponding references."
  61   ! References can correspond only if they execute on differing images.  A code that
  62   ! executes in a single image might be standard-conforming even if the same code
  63   ! executing in multiple images is not.
  64
  65   ! argument 'a' cannot be polymorphic
  66   !ERROR: to be determined
  67   call co_reduce(polymorphic, derived_type_op)
  68
  69   ! argument 'a' cannot be coindexed
  70   !ERROR: (message to be determined)
  71   call co_reduce(coindexed[1], int_op)
  72
  73   ! argument 'a' is intent(inout)
  74   !ERROR: (message to be determined)
  75   call co_reduce(i + 1, int_op)
  76
  77   ! operation must be a pure function
  78   !ERROR: (message to be determined)
  79   call co_reduce(i, operation=not_pure)
  80
  81   ! operation must have exactly two arguments
  82   !ERROR: (message to be determined)
  83   call co_reduce(i, too_many_args)
  84
  85   ! operation result must be a scalar
  86   !ERROR: (message to be determined)
  87   call co_reduce(i, array_result)
  88
  89   ! operation result must be non-allocatable
  90   !ERROR: (message to be determined)
  91   call co_reduce(i, allocatable_result)
  92
  93   ! operation result must be non-pointer
  94   !ERROR: (message to be determined)
  95   call co_reduce(i, pointer_result)
  96
  97   ! operation's arguments must be scalars
  98   !ERROR: (message to be determined)
  99   call co_reduce(i, array_args)
 100
 101   ! operation arguments must be non-allocatable
 102   !ERROR: (message to be determined)
 103   call co_reduce(i, allocatable_args)
 104
 105   ! operation arguments must be non-pointer
 106   !ERROR: (message to be determined)
 107   call co_reduce(i, pointer_args)
 108
 109   ! operation arguments must be non-polymorphic
 110   !ERROR: (message to be determined)
 111   call co_reduce(i, polymorphic_args)
 112
 113   ! operation: type of 'operation' result and arguments must match type of argument 'a'
 114   !ERROR: (message to be determined)
 115   call co_reduce(i, real_op)
 116
 117   ! operation: kind type parameter of 'operation' result and arguments must match kind type parameter of argument 'a'
 118   !ERROR: (message to be determined)
 119   call co_reduce(x, double_precision_op)
 120
 121   ! arguments must be non-optional
 122   !ERROR: (message to be determined)
 123   call co_reduce(i, optional_args)
 124
 125   ! if one argument is asynchronous, the other must be also
 126   !ERROR: (message to be determined)
 127   call co_reduce(i, asynchronous_mismatch)
 128
 129   ! if one argument is a target, the other must be also
 130   !ERROR: (message to be determined)
 131   call co_reduce(i, target_mismatch)
 132
 133   ! if one argument has the value attribute, the other must have it also
 134   !ERROR: (message to be determined)
 135   call co_reduce(i, value_mismatch)
 136
 137   ! result_image argument must be an integer scalar
 138   !ERROR: to be determined
 139   call co_reduce(i, int_op, result_image=integer_array)
 140
 141   ! result_image argument must be an integer
 142   !ERROR: to be determined
 143   call co_reduce(i, int_op, result_image=bool)
 144
 145   ! stat not allowed to be coindexed
 146   !ERROR: to be determined
 147   call co_reduce(i, int_op, stat=coindexed[1])
 148
 149   ! stat argument must be an integer scalar
 150   !ERROR: to be determined
 151   call co_reduce(i, int_op, result_image=1, stat=integer_array)
 152
 153   ! stat argument has incorrect type
 154   !ERROR: Actual argument for 'stat=' has bad type 'CHARACTER(KIND=1,LEN=1_8)'
 155   call co_reduce(i, int_op, result_image=1, string)
 156
 157   ! stat argument is intent(out)
 158   !ERROR: to be determined
 159   call co_reduce(i, int_op, result_image=1, stat=1+1)
 160
 161   ! errmsg argument must not be coindexed
 162   !ERROR: to be determined
 163   call co_reduce(i, int_op, result_image=1, stat=status, errmsg=conindexed_string[1])
 164
 165   ! errmsg argument must be a character scalar
 166   !ERROR: to be determined
 167   call co_reduce(i, int_op, result_image=1, stat=status, errmsg=character_array)
 168
 169   ! errmsg argument must be a character
 170   !ERROR: to be determined
 171   call co_reduce(i, int_op, result_image=1, stat=status, errmsg=i)
 172
 173   ! errmsg argument is intent(inout)
 174   !ERROR: to be determined
 175   call co_reduce(i, int_op, result_image=1, stat=status, errmsg="literal constant")
 176
 177   ! too many arguments to the co_reduce() call
 178   !ERROR: too many actual arguments for intrinsic 'co_reduce'
 179   call co_reduce(i, int_op, result_image=1, stat=status, errmsg=message, 3.4)
 180
 181   ! non-existent keyword argument
 182   !ERROR: unknown keyword argument to intrinsic 'co_reduce'
 183   call co_reduce(fake=3.4)
 184
 185 contains
 186
 187   pure function left(lhs, rhs) result(lhs_op_rhs)
 188     type(foo_t), intent(in)  :: lhs, rhs
 189     type(foo_t) :: lhs_op_rhs
 190     lhs_op_rhs = lhs
 191   end function
 192
 193   pure function char_op(lhs, rhs) result(lhs_op_rhs)
 194     character(len=1), intent(in)  :: lhs, rhs
 195     character(len=1) :: lhs_op_rhs
 196     lhs_op_rhs = min(lhs, rhs)
 197   end function
 198
 199   pure function real_op(lhs, rhs) result(lhs_op_rhs)
 200     real, intent(in) :: lhs, rhs
 201     real :: lhs_op_rhs
 202     lhs_op_rhs = lhs + rhs
 203   end function
 204
 205   pure function double_precision_op(lhs, rhs) result(lhs_op_rhs)
 206     integer, parameter :: double = kind(1.0D0)
 207     real(double), intent(in) :: lhs, rhs
 208     real(double) lhs_op_rhs
 209     lhs_op_rhs = lhs + rhs
 210   end function
 211
 212   pure function int_op(lhs, rhs) result(lhs_op_rhs)
 213     integer, intent(in) :: lhs, rhs
 214     integer :: lhs_op_rhs
 215     lhs_op_rhs = lhs + rhs
 216   end function
 217
 218   function not_pure(lhs, rhs) result(lhs_op_rhs)
 219     integer, intent(in) :: lhs, rhs
 220     integer :: lhs_op_rhs
 221     lhs_op_rhs = lhs + rhs
 222   end function
 223
 224   pure function too_many_args(lhs, rhs, foo) result(lhs_op_rhs)
 225     integer, intent(in) :: lhs, rhs, foo
 226     integer lhs_op_rhs
 227     lhs_op_rhs = lhs + rhs
 228   end function
 229
 230   pure function array_result(lhs, rhs)
 231     integer, intent(in) :: lhs, rhs
 232     integer array_result(1)
 233     array_result = lhs + rhs
 234   end function
 235
 236   pure function allocatable_result(lhs, rhs)
 237     integer, intent(in) :: lhs, rhs
 238     integer, allocatable :: allocatable_result
 239     allocatable_result = lhs + rhs
 240   end function
 241
 242   pure function pointer_result(lhs, rhs)
 243     integer, intent(in) :: lhs, rhs
 244     integer, pointer :: pointer_result
 245     allocate(pointer_result, source=lhs + rhs )
 246   end function
 247
 248   pure function array_args(lhs, rhs)
 249     integer, intent(in) :: lhs(1), rhs(1)
 250     integer array_args
 251     array_args = lhs(1) + rhs(1)
 252   end function
 253
 254   pure function allocatable_args(lhs, rhs) result(lhs_op_rhs)
 255     integer, intent(in), allocatable :: lhs, rhs
 256     integer lhs_op_rhs
 257     lhs_op_rhs = lhs + rhs
 258   end function
 259
 260   pure function pointer_args(lhs, rhs) result(lhs_op_rhs)
 261     integer, intent(in), pointer :: lhs, rhs
 262     integer lhs_op_rhs
 263     lhs_op_rhs = lhs + rhs
 264   end function
 265
 266   pure function polymorphic_args(lhs, rhs) result(lhs_op_rhs)
 267     class(foo_t), intent(in) :: lhs, rhs
 268     type(foo_t) lhs_op_rhs
 269     lhs_op_rhs%n = lhs%n + rhs%n
 270   end function
 271
 272   pure function optional_args(lhs, rhs) result(lhs_op_rhs)
 273     integer, intent(in), optional :: lhs, rhs
 274     integer lhs_op_rhs
 275     if (present(lhs) .and. present(rhs)) then
 276       lhs_op_rhs = lhs + rhs
 277     else
 278       lhs_op_rhs = 0
 279     end if
 280   end function
 281
 282   pure function target_mismatch(lhs, rhs) result(lhs_op_rhs)
 283     integer, intent(in), target  :: lhs
 284     integer, intent(in) :: rhs
 285     integer lhs_op_rhs
 286     lhs_op_rhs = lhs + rhs
 287   end function
 288
 289   pure function value_mismatch(lhs, rhs) result(lhs_op_rhs)
 290     integer, intent(in), value:: lhs
 291     integer, intent(in) :: rhs
 292     integer lhs_op_rhs
 293     lhs_op_rhs = lhs + rhs
 294   end function
 295
 296   pure function asynchronous_mismatch(lhs, rhs) result(lhs_op_rhs)
 297     integer, intent(in), asynchronous:: lhs
 298     integer, intent(in) :: rhs
 299     integer lhs_op_rhs
 300     lhs_op_rhs = lhs + rhs
 301   end function
 302
 303 end program