306 lines · plain
1! RUN: %python %S/test_errors.py %s %flang_fc12! This test checks for semantic errors in co_reduce subroutine calls based on3! the co_reduce interface defined in section 16.9.49 of the Fortran 2018 standard.4! To Do: add co_reduce to the list of intrinsics5 6module foo_m7 implicit none8 9 type foo_t10 integer :: n=011 contains12 procedure :: derived_type_op13 generic :: operator(+) => derived_type_op14 end type15 16contains17 18 pure function derived_type_op(lhs, rhs) result(lhs_op_rhs)19 class(foo_t), intent(in) :: lhs, rhs20 type(foo_t) lhs_op_rhs21 lhs_op_rhs%n = lhs%n + rhs%n22 end function23 24end module foo_m25 26program main27 use foo_m, only : foo_t28 implicit none29 30 type(foo_t) foo31 class(foo_t), allocatable :: polymorphic32 integer i, status, integer_array(1)33 real x34 real vector(1)35 real array(1,1,1, 1,1,1, 1,1,1, 1,1,1, 1,1,1)36 character(len=1) string, message, character_array(1)37 integer coindexed[*]38 logical bool39 40 ! correct calls, should produce no errors41 call co_reduce(i, int_op)42 call co_reduce(i, int_op, status)43 call co_reduce(i, int_op, stat=status)44 call co_reduce(i, int_op, errmsg=message)45 call co_reduce(i, int_op, stat=status, errmsg=message)46 call co_reduce(i, int_op, result_image=1, stat=status, errmsg=message)47 call co_reduce(i, operation=int_op, result_image=1, stat=status, errmsg=message)48 call co_reduce(a=i, operation=int_op, result_image=1, stat=status, errmsg=message)49 call co_reduce(array, operation=real_op, result_image=1, stat=status, errmsg=message)50 call co_reduce(vector, operation=real_op, result_image=1, stat=status, errmsg=message)51 call co_reduce(string, operation=char_op, result_image=1, stat=status, errmsg=message)52 call co_reduce(foo, operation=left, result_image=1, stat=status, errmsg=message)53 54 call co_reduce(result_image=1, operation=left, a=foo, errmsg=message, stat=status)55 56 allocate(foo_t :: polymorphic)57 58 ! Test all statically verifiable semantic requirements on co_reduce arguments59 ! Note: We cannot check requirements that relate to "corresponding references." 60 ! References can correspond only if they execute on differing images. A code that61 ! executes in a single image might be standard-conforming even if the same code62 ! executing in multiple images is not.63 64 ! argument 'a' cannot be polymorphic65 !ERROR: No explicit type declared for 'derived_type_op'66 call co_reduce(polymorphic, derived_type_op)67 68 ! argument 'a' cannot be coindexed69 !ERROR: 'a' argument to 'co_reduce' may not be a coindexed object70 call co_reduce(coindexed[1], int_op)71 72 ! argument 'a' is intent(inout)73 !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'a=' is not definable74 !ERROR: 'i+1_4' is not a variable or pointer75 call co_reduce(i + 1, int_op)76 77 ! operation must be a pure function78 !ERROR: OPERATION= argument of CO_REDUCE() must be a pure function of two data arguments79 call co_reduce(i, operation=not_pure)80 81 ! operation must have exactly two arguments82 !ERROR: OPERATION= argument of CO_REDUCE() must be a pure function of two data arguments83 call co_reduce(i, too_many_args)84 85 ! operation result must be a scalar86 !ERROR: OPERATION= argument of CO_REDUCE() must be a scalar function87 call co_reduce(i, array_result)88 89 ! operation result must be non-allocatable90 !ERROR: Result of OPERATION= procedure of CO_REDUCE() must be scalar and neither allocatable, pointer, nor polymorphic91 call co_reduce(i, allocatable_result)92 93 ! operation result must be non-pointer94 !ERROR: Result of OPERATION= procedure of CO_REDUCE() must be scalar and neither allocatable, pointer, nor polymorphic95 call co_reduce(i, pointer_result)96 97 ! operation's arguments must be scalars98 !ERROR: Arguments of OPERATION= procedure of CO_REDUCE() must be both scalar of the same type as A=, and neither allocatable, pointer, polymorphic, nor optional99 call co_reduce(i, array_args)100 101 ! operation arguments must be non-allocatable102 !ERROR: Arguments of OPERATION= procedure of CO_REDUCE() must be both scalar of the same type as A=, and neither allocatable, pointer, polymorphic, nor optional103 call co_reduce(i, allocatable_args)104 105 ! operation arguments must be non-pointer106 !ERROR: Arguments of OPERATION= procedure of CO_REDUCE() must be both scalar of the same type as A=, and neither allocatable, pointer, polymorphic, nor optional107 call co_reduce(i, pointer_args)108 109 ! operation arguments must be non-polymorphic110 !ERROR: OPERATION= argument of CO_REDUCE() must have the same type as A=111 call co_reduce(i, polymorphic_args)112 113 ! operation: type of 'operation' result and arguments must match type of argument 'a'114 !ERROR: OPERATION= argument of CO_REDUCE() must have the same type as A=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: OPERATION= argument of CO_REDUCE() must have the same type as A=119 call co_reduce(x, double_precision_op)120 121 ! arguments must be non-optional122 !ERROR: Arguments of OPERATION= procedure of CO_REDUCE() must be both scalar of the same type as A=, and neither allocatable, pointer, polymorphic, nor optional123 call co_reduce(i, optional_args)124 125 ! if one argument is asynchronous, the other must be also126 !ERROR: If either argument of the OPERATION= procedure of CO_REDUCE() has the ASYNCHRONOUS, TARGET, or VALUE attribute, both must have that attribute127 call co_reduce(i, asynchronous_mismatch)128 129 ! if one argument is a target, the other must be also130 !ERROR: If either argument of the OPERATION= procedure of CO_REDUCE() has the ASYNCHRONOUS, TARGET, or VALUE attribute, both must have that attribute131 call co_reduce(i, target_mismatch)132 133 ! if one argument has the value attribute, the other must have it also134 !ERROR: If either argument of the OPERATION= procedure of CO_REDUCE() has the ASYNCHRONOUS, TARGET, or VALUE attribute, both must have that attribute135 call co_reduce(i, value_mismatch)136 137 ! result_image argument must be an integer scalar138 !ERROR: 'result_image=' argument has unacceptable rank 1139 call co_reduce(i, int_op, result_image=integer_array)140 141 ! result_image argument must be an integer142 !ERROR: Actual argument for 'result_image=' has bad type 'LOGICAL(4)'143 call co_reduce(i, int_op, result_image=bool)144 145 ! stat not allowed to be coindexed146 !ERROR: 'errmsg' argument to 'co_reduce' may not be a coindexed object147 call co_reduce(i, int_op, stat=coindexed[1])148 149 ! stat argument must be an integer scalar150 !ERROR: 'stat=' argument has unacceptable rank 1151 call co_reduce(i, int_op, result_image=1, stat=integer_array)152 153 ! stat argument has incorrect type154 !ERROR: Actual argument for 'stat=' has bad type 'CHARACTER(KIND=1,LEN=1_8)'155 call co_reduce(i, int_op, result_image=1, stat=string)156 157 ! stat argument is intent(out)158 !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'stat=' is not definable159 !ERROR: '2_4' is not a variable or pointer160 call co_reduce(i, int_op, result_image=1, stat=1+1)161 162 ! errmsg argument must not be coindexed163 !ERROR: No explicit type declared for 'conindexed_string'164 call co_reduce(i, int_op, result_image=1, stat=status, errmsg=conindexed_string[1])165 166 ! errmsg argument must be a character scalar167 !ERROR: 'errmsg=' argument has unacceptable rank 1168 call co_reduce(i, int_op, result_image=1, stat=status, errmsg=character_array)169 170 ! errmsg argument must be a character171 !ERROR: Actual argument for 'errmsg=' has bad type 'INTEGER(4)'172 call co_reduce(i, int_op, result_image=1, stat=status, errmsg=i)173 174 ! errmsg argument is intent(inout)175 !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'errmsg=' is not definable176 !ERROR: '"literal constant"' is not a variable or pointer177 call co_reduce(i, int_op, result_image=1, stat=status, errmsg="literal constant")178 179 ! too many arguments to the co_reduce() call180 !ERROR: actual argument #6 without a keyword may not follow an actual argument with a keyword181 call co_reduce(i, int_op, result_image=1, stat=status, errmsg=message, 3.4)182 183 ! non-existent keyword argument184 !ERROR: unknown keyword argument to intrinsic 'co_reduce'185 call co_reduce(fake=3.4)186 187contains188 189 pure function left(lhs, rhs) result(lhs_op_rhs)190 type(foo_t), intent(in) :: lhs, rhs191 type(foo_t) :: lhs_op_rhs192 lhs_op_rhs = lhs193 end function194 195 pure function char_op(lhs, rhs) result(lhs_op_rhs)196 character(len=1), intent(in) :: lhs, rhs197 character(len=1) :: lhs_op_rhs198 lhs_op_rhs = min(lhs, rhs)199 end function200 201 pure function real_op(lhs, rhs) result(lhs_op_rhs)202 real, intent(in) :: lhs, rhs203 real :: lhs_op_rhs204 lhs_op_rhs = lhs + rhs205 end function206 207 pure function double_precision_op(lhs, rhs) result(lhs_op_rhs)208 integer, parameter :: double = kind(1.0D0)209 real(double), intent(in) :: lhs, rhs210 real(double) lhs_op_rhs211 lhs_op_rhs = lhs + rhs212 end function213 214 pure function int_op(lhs, rhs) result(lhs_op_rhs)215 integer, intent(in) :: lhs, rhs216 integer :: lhs_op_rhs217 lhs_op_rhs = lhs + rhs218 end function219 220 function not_pure(lhs, rhs) result(lhs_op_rhs)221 integer, intent(in) :: lhs, rhs222 integer :: lhs_op_rhs223 lhs_op_rhs = lhs + rhs224 end function225 226 pure function too_many_args(lhs, rhs, foo) result(lhs_op_rhs)227 integer, intent(in) :: lhs, rhs, foo228 integer lhs_op_rhs229 lhs_op_rhs = lhs + rhs230 end function231 232 pure function array_result(lhs, rhs)233 integer, intent(in) :: lhs, rhs234 integer array_result(1)235 array_result = lhs + rhs236 end function237 238 pure function allocatable_result(lhs, rhs)239 integer, intent(in) :: lhs, rhs240 integer, allocatable :: allocatable_result241 allocatable_result = lhs + rhs242 end function243 244 pure function pointer_result(lhs, rhs)245 integer, intent(in) :: lhs, rhs246 integer, pointer :: pointer_result247 allocate(pointer_result, source=lhs + rhs )248 end function249 250 pure function array_args(lhs, rhs)251 integer, intent(in) :: lhs(1), rhs(1)252 integer array_args253 array_args = lhs(1) + rhs(1)254 end function255 256 pure function allocatable_args(lhs, rhs) result(lhs_op_rhs)257 integer, intent(in), allocatable :: lhs, rhs258 integer lhs_op_rhs259 lhs_op_rhs = lhs + rhs260 end function261 262 pure function pointer_args(lhs, rhs) result(lhs_op_rhs)263 integer, intent(in), pointer :: lhs, rhs264 integer lhs_op_rhs265 lhs_op_rhs = lhs + rhs266 end function267 268 pure function polymorphic_args(lhs, rhs) result(lhs_op_rhs)269 class(foo_t), intent(in) :: lhs, rhs270 type(foo_t) lhs_op_rhs271 lhs_op_rhs%n = lhs%n + rhs%n272 end function273 274 pure function optional_args(lhs, rhs) result(lhs_op_rhs)275 integer, intent(in), optional :: lhs, rhs276 integer lhs_op_rhs277 if (present(lhs) .and. present(rhs)) then278 lhs_op_rhs = lhs + rhs279 else280 lhs_op_rhs = 0281 end if282 end function283 284 pure function target_mismatch(lhs, rhs) result(lhs_op_rhs)285 integer, intent(in), target :: lhs286 integer, intent(in) :: rhs287 integer lhs_op_rhs288 lhs_op_rhs = lhs + rhs289 end function290 291 pure function value_mismatch(lhs, rhs) result(lhs_op_rhs)292 integer, intent(in), value:: lhs293 integer, intent(in) :: rhs294 integer lhs_op_rhs295 lhs_op_rhs = lhs + rhs296 end function297 298 pure function asynchronous_mismatch(lhs, rhs) result(lhs_op_rhs)299 integer, intent(in), asynchronous:: lhs300 integer, intent(in) :: rhs301 integer lhs_op_rhs302 lhs_op_rhs = lhs + rhs303 end function304 305end program306