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 7module 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 17contains 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 25end module foo_m 26 27program 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 185contains 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 303end program 304