gcc/testsuite/gfortran.dg/coarray_collectives_14.f90

   1 ! { dg-do compile }
   2 ! { dg-options "-fcoarray=single -fmax-errors=80" }
   3 !
   4 !
   5 ! CO_REDUCE (plus CO_MIN/MAX/SUM/BROADCAST)
   6 !
   7 program test
   8   implicit none (external, type)
   9   intrinsic co_reduce
  10   intrinsic co_broadcast
  11   intrinsic co_min
  12   intrinsic co_max
  13   intrinsic co_sum
  14   intrinsic dprod
  15   external ext
  16
  17   type t
  18     procedure(), pointer, nopass :: ext
  19     procedure(valid), pointer, nopass :: valid
  20     procedure(sub), pointer, nopass :: sub
  21     procedure(nonpure), pointer, nopass :: nonpure
  22     procedure(arg1), pointer, nopass :: arg1
  23     procedure(arg3), pointer, nopass :: arg3
  24     procedure(elem), pointer, nopass :: elem
  25     procedure(realo), pointer, nopass :: realo
  26     procedure(int8), pointer, nopass :: int8
  27     procedure(arr), pointer, nopass :: arr
  28     procedure(ptr), pointer, nopass :: ptr
  29     procedure(alloc), pointer, nopass :: alloc
  30     procedure(opt), pointer, nopass :: opt
  31     procedure(val), pointer, nopass :: val
  32     procedure(async), pointer, nopass :: async
  33     procedure(tgt), pointer, nopass :: tgt
  34     procedure(char44), pointer, nopass :: char44
  35     procedure(char34), pointer, nopass :: char34
  36   end type t
  37
  38   type(t) :: dt
  39   integer :: caf[*]
  40   character(len=3) :: c3
  41   character(len=4) :: c4
  42
  43
  44
  45   call co_min(caf[1]) ! { dg-error "shall not be coindexed" }
  46   call co_max(caf[1]) ! { dg-error "shall not be coindexed" }
  47   call co_sum(caf[1]) ! { dg-error "shall not be coindexed" }
  48   call co_broadcast(caf[1], source_image=1) ! { dg-error "shall not be coindexed" }
  49   call co_reduce(caf[1], valid) ! { dg-error "shall not be coindexed" }
  50
  51   call co_reduce(caf, valid) ! OK
  52   call co_reduce(caf, dt%valid) ! OK
  53   call co_reduce(caf, dprod) ! { dg-error "is not permitted for CO_REDUCE" }
  54   call co_reduce(caf, ext) ! { dg-error "must be a PURE function" }
  55   call co_reduce(caf, dt%ext) ! { dg-error "must be a PURE function" }
  56   call co_reduce(caf, sub) ! { dg-error "must be a PURE function" }
  57   call co_reduce(caf, dt%sub) ! { dg-error "must be a PURE function" }
  58   call co_reduce(caf, nonpure) ! { dg-error "must be a PURE function" }
  59   call co_reduce(caf, dt%nonpure) ! { dg-error "must be a PURE function" }
  60   call co_reduce(caf, arg1) ! { dg-error "shall have two arguments" }
  61   call co_reduce(caf, dt%arg1) ! { dg-error "shall have two arguments" }
  62   call co_reduce(caf, arg3) ! { dg-error "shall have two arguments" }
  63   call co_reduce(caf, dt%arg3) ! { dg-error "shall have two arguments" }
  64   call co_reduce(caf, elem) ! { dg-error "ELEMENTAL non-INTRINSIC procedure 'elem' is not allowed as an actual argument" }
  65   call co_reduce(caf, dt%elem) ! { dg-error "ELEMENTAL procedure pointer component 'elem' is not allowed as an actual argument" }
  66   call co_reduce(caf, realo) ! { dg-error "A argument at .1. has type INTEGER.4. but the function passed as OPERATOR at .2. returns REAL.4." }
  67   call co_reduce(caf, dt%realo) ! { dg-error "A argument at .1. has type INTEGER.4. but the function passed as OPERATOR at .2. returns REAL.4." }
  68   call co_reduce(caf, int8) ! { dg-error "A argument at .1. has type INTEGER.4. but the function passed as OPERATOR at .2. returns INTEGER.8." }
  69   call co_reduce(caf, dt%int8) ! { dg-error "A argument at .1. has type INTEGER.4. but the function passed as OPERATOR at .2. returns INTEGER.8." }
  70   call co_reduce(caf, arr) ! { dg-error "scalar nonallocatable nonpointer arguments and return a nonallocatable nonpointer scalar" }
  71   call co_reduce(caf, dt%arr) ! { dg-error "scalar nonallocatable nonpointer arguments and return a nonallocatable nonpointer scalar" }
  72   call co_reduce(caf, ptr) ! { dg-error "scalar nonallocatable nonpointer arguments and return a nonallocatable nonpointer scalar" }
  73   call co_reduce(caf, dt%ptr) ! { dg-error "scalar nonallocatable nonpointer arguments and return a nonallocatable nonpointer scalar" }
  74   call co_reduce(caf, alloc) ! { dg-error "scalar nonallocatable nonpointer arguments and return a nonallocatable nonpointer scalar" }
  75   call co_reduce(caf, dt%alloc) ! { dg-error "scalar nonallocatable nonpointer arguments and return a nonallocatable nonpointer scalar" }
  76   call co_reduce(caf, opt) ! { dg-error "shall not have the OPTIONAL attribute for either of the arguments" }
  77   call co_reduce(caf, dt%opt) ! { dg-error "shall not have the OPTIONAL attribute for either of the arguments" }
  78   call co_reduce(caf, val) ! { dg-error "shall have the VALUE attribute either for none or both arguments" }
  79   call co_reduce(caf, dt%val) ! { dg-error "shall have the VALUE attribute either for none or both arguments" }
  80   call co_reduce(caf, async) ! { dg-error "shall have the ASYNCHRONOUS attribute either for none or both arguments" }
  81   call co_reduce(caf, dt%async) ! { dg-error "shall have the ASYNCHRONOUS attribute either for none or both arguments" }
  82   call co_reduce(caf, tgt) ! { dg-error "shall have the TARGET attribute either for none or both arguments" }
  83   call co_reduce(caf, dt%tgt) ! { dg-error "shall have the TARGET attribute either for none or both arguments" }
  84   call co_reduce(c4, char44) ! OK
  85   call co_reduce(c4, dt%char44) ! OK
  86   call co_reduce(c3, char34) ! { dg-error "character length of the A argument at .1. and of the arguments of the OPERATOR at .2. shall be the same" }
  87   call co_reduce(c3, dt%char34) ! { dg-error "character length of the A argument at .1. and of the arguments of the OPERATOR at .2. shall be the same" }
  88   call co_reduce(c4, char34) ! { dg-error "The character length of the A argument at .1. and of the function result of the OPERATOR at .2. shall be the same" }
  89   call co_reduce(c4, dt%char34) ! { dg-error "The character length of the A argument at .1. and of the function result of the OPERATOR at .2. shall be the same" }
  90
  91 contains
  92   pure integer function valid(x,y)
  93     integer, value :: x, y
  94   end function valid
  95   impure integer function nonpure(x,y)
  96     integer, value :: x, y
  97   end function nonpure
  98   pure subroutine sub()
  99   end subroutine sub
 100   pure integer function arg3(x, y, z)
 101     integer, value :: x, y, z
 102   end function arg3
 103   pure integer function arg1(x)
 104     integer, value :: x
 105   end function arg1
 106   pure elemental integer function elem(x,y)
 107     integer, value :: x, y
 108   end function elem
 109   pure real function realo(x,y)
 110     integer, value :: x, y
 111   end function realo
 112   pure integer(8) function int8(x,y)
 113     integer, value :: x, y
 114   end function int8
 115   pure integer function arr(x,y)
 116     integer, intent(in) :: x(:), y
 117   end function arr
 118   pure integer function ptr(x,y)
 119     integer, intent(in), pointer :: x, y
 120   end function ptr
 121   pure integer function alloc(x,y)
 122     integer, intent(in), allocatable :: x, y
 123   end function alloc
 124   pure integer function opt(x,y)
 125     integer, intent(in) :: x, y
 126     optional :: x, y
 127   end function opt
 128   pure integer function val(x,y)
 129     integer, value :: x
 130     integer, intent(in) :: y
 131   end function val
 132   pure integer function tgt(x,y)
 133     integer, intent(in) :: x, y
 134     target :: x
 135   end function tgt
 136   pure integer function async(x,y)
 137     integer, intent(in) :: x, y
 138     asynchronous :: y
 139   end function async
 140   pure character(4) function char44(x,y)
 141     character(len=4), value :: x, y
 142   end function char44
 143   pure character(3) function char34(x,y)
 144     character(len=4), value :: x, y
 145   end function char34
 146 end program test