Index: flang/lib/Evaluate/intrinsics.cpp =================================================================== --- flang/lib/Evaluate/intrinsics.cpp +++ flang/lib/Evaluate/intrinsics.cpp @@ -1077,6 +1077,16 @@ static const IntrinsicInterface intrinsicSubroutine[]{ {"abort", {}, {}, Rank::elemental, IntrinsicClass::impureSubroutine}, + {"co_sum", + {{"a", AnyNumeric, Rank::anyOrAssumedRank, Optionality::required, + common::Intent::InOut}, + {"result_image", AnyInt, Rank::scalar, Optionality::optional, + common::Intent::In}, + {"stat", AnyInt, Rank::scalar, Optionality::optional, + common::Intent::Out}, + {"errmsg", DefaultChar, Rank::scalar, Optionality::optional, + common::Intent::InOut}}, + {}, Rank::elemental, IntrinsicClass::collectiveSubroutine}, {"cpu_time", {{"time", AnyReal, Rank::scalar, Optionality::required, common::Intent::Out}}, @@ -2374,6 +2384,21 @@ return ok; } +static bool CheckForCoindexedObject(FoldingContext &context, + const std::optional &arg, const std::string &procName, + const std::string &argName) { + bool ok{true}; + if (arg) { + if (ExtractCoarrayRef(arg->UnwrapExpr())) { + ok = false; + context.messages().Say(arg->sourceLocation(), + "'%s' argument to '%s' may not be a coindexed object"_err_en_US, + argName, procName); + } + } + return ok; +} + // Applies any semantic checks peculiar to an intrinsic. static bool ApplySpecificChecks(SpecificCall &call, FoldingContext &context) { bool ok{true}; @@ -2392,6 +2417,13 @@ } } else if (name == "associated") { return CheckAssociated(call, context); + } else if (name == "co_sum") { + bool aOk{CheckForCoindexedObject(context, call.arguments[0], name, "a")}; + bool statOk{ + CheckForCoindexedObject(context, call.arguments[2], name, "stat")}; + bool errmsgOk{ + CheckForCoindexedObject(context, call.arguments[3], name, "errmsg")}; + ok = aOk && statOk && errmsgOk; } else if (name == "image_status") { if (const auto &arg{call.arguments[0]}) { ok = CheckForNonPositiveValues(context, *arg, name, "image"); @@ -2423,6 +2455,15 @@ arg ? arg->sourceLocation() : context.messages().at(), "Argument of LOC() must be an object or procedure"_err_en_US); } + } else if (name == "move_alloc") { + bool fromOk{ + CheckForCoindexedObject(context, call.arguments[0], name, "from")}; + bool toOk{CheckForCoindexedObject(context, call.arguments[1], name, "to")}; + bool statOk{ + CheckForCoindexedObject(context, call.arguments[2], name, "stat")}; + bool errmsgOk{ + CheckForCoindexedObject(context, call.arguments[3], name, "errmsg")}; + ok = fromOk && toOk && statOk && errmsgOk; } else if (name == "present") { const auto &arg{call.arguments[0]}; if (arg) { @@ -2577,6 +2618,7 @@ for (auto iter{subrRange.first}; iter != subrRange.second; ++iter) { if (auto specificCall{iter->second->Match( call, defaults_, arguments, context, builtinsScope_)}) { + ApplySpecificChecks(*specificCall, context); return specificCall; } } Index: flang/test/Semantics/collectives01.f90 =================================================================== --- flang/test/Semantics/collectives01.f90 +++ flang/test/Semantics/collectives01.f90 @@ -1,20 +1,18 @@ ! RUN: %python %S/test_errors.py %s %flang_fc1 -! XFAIL: * ! This test checks for semantic errors in co_sum subroutine calls based on ! the co_reduce interface defined in section 16.9.50 of the Fortran 2018 standard. -! To Do: add co_sum to the list of intrinsics program test_co_sum implicit none - integer i, status, integer_array(1), coindexed_integer[*] - complex c, complex_array(1,1,1, 1,1,1, 1,1,1, 1,1,1, 1,1,1) + integer i, status, integer_array(1), coindexed_integer[*], coindexed_result_image[*], repeated_status + complex c, complex_array(1,1,1, 1,1,1, 1,1,1, 1,1,1, 1,1,1) double precision d, double_precision_array(1) real r, real_array(1), coindexed_real[*] - character(len=1) message, coindexed_character[*], character_array(1) + character(len=1) message, coindexed_character[*], character_array(1), repeated_message logical bool - + !___ standard-conforming calls with no keyword arguments ___ call co_sum(i) call co_sum(c) @@ -32,43 +30,71 @@ !___ standard-conforming calls with keyword arguments ___ ! all arguments present - call co_sum(a=i, result_image=1, stat=status, errmsg=message) + call co_sum(a=i, result_image=1, stat=status, errmsg=message) + call co_sum(a = i, result_image = 1, stat = status, errmsg = message) call co_sum(result_image=1, a=i, errmsg=message, stat=status) ! one optional argument not present - call co_sum(a=i, stat=status, errmsg=message) + call co_sum(a=i, stat=status, errmsg=message) call co_sum(a=i, result_image=1, errmsg=message) call co_sum(a=i, result_image=1, stat=status ) ! two optional arguments not present - call co_sum(a=i, result_image=1 ) + call co_sum(a=i, result_image=1 ) call co_sum(a=i, stat=status ) - call co_sum(a=i, errmsg=message) + call co_sum(a=i, errmsg=message) + call co_sum(a=i, result_image=coindexed_result_image[1]) ! no optional arguments present - call co_sum(a=i ) + call co_sum(a=i ) !___ non-standard-conforming calls ___ + !ERROR: missing mandatory 'a=' argument + call co_sum() + !ERROR: missing mandatory 'a=' argument call co_sum(result_image=1, stat=status, errmsg=message) + !ERROR: repeated keyword argument to intrinsic 'co_sum' + call co_sum(a=i, a=c) + + !ERROR: repeated keyword argument to intrinsic 'co_sum' + call co_sum(a=i, result_image=1, result_image=2, stat=status, errmsg=message) + + !ERROR: repeated keyword argument to intrinsic 'co_sum' + call co_sum(a=i, result_image=1, stat=status, stat=repeated_status, errmsg=message) + + !ERROR: repeated keyword argument to intrinsic 'co_sum' + call co_sum(a=i, result_image=1, stat=status, errmsg=message, errmsg=repeated_message) + + !ERROR: keyword argument to intrinsic 'co_sum' was supplied positionally by an earlier actual argument + call co_sum(i, 1, a=c) + + !ERROR: keyword argument to intrinsic 'co_sum' was supplied positionally by an earlier actual argument + call co_sum(i, 1, result_image=2) + + !ERROR: keyword argument to intrinsic 'co_sum' was supplied positionally by an earlier actual argument + call co_sum(i, 1, status, stat=repeated_status) + + !ERROR: keyword argument to intrinsic 'co_sum' was supplied positionally by an earlier actual argument + call co_sum(i, 1, status, message, errmsg=repeated_message) + ! argument 'a' shall be of numeric type !ERROR: Actual argument for 'a=' has bad type 'LOGICAL(4)' call co_sum(bool) - + ! argument 'a' is intent(inout) !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'a=' must be definable call co_sum(a=1+1) - - ! argument 'a' shall not be a coindexed object - !ERROR: to be determined + + !ERROR: 'a' argument to 'co_sum' may not be a coindexed object call co_sum(a=coindexed_real[1]) - + ! 'result_image' argument shall be a integer !ERROR: Actual argument for 'result_image=' has bad type 'LOGICAL(4)' call co_sum(i, result_image=bool) - + ! 'result_image' argument shall be an integer scalar !ERROR: 'result_image=' argument has unacceptable rank 1 call co_sum(c, result_image=integer_array) @@ -77,40 +103,45 @@ !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'stat=' must be definable call co_sum(a=i, result_image=1, stat=1+1, errmsg=message) - ! 'stat' argument shall be noncoindexed - !ERROR: to be determined + !ERROR: 'stat' argument to 'co_sum' may not be a coindexed object call co_sum(d, stat=coindexed_integer[1]) - + + !ERROR: 'stat' argument to 'co_sum' may not be a coindexed object + call co_sum(stat=coindexed_integer[1], a=d) + ! 'stat' argument shall be an integer !ERROR: Actual argument for 'stat=' has bad type 'CHARACTER(KIND=1,LEN=1_8)' call co_sum(r, stat=message) - + ! 'stat' argument shall be an integer scalar !ERROR: 'stat=' argument has unacceptable rank 1 call co_sum(i, stat=integer_array) - + ! 'errmsg' argument shall be intent(inout) !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'errmsg=' must be definable call co_sum(a=i, result_image=1, stat=status, errmsg='c') - - ! 'errmsg' argument shall be noncoindexed - !ERROR: to be determined + + !ERROR: 'errmsg' argument to 'co_sum' may not be a coindexed object call co_sum(c, errmsg=coindexed_character[1]) ! 'errmsg' argument shall be a character - !ERROR: to be determined + !ERROR: Actual argument for 'errmsg=' has bad type 'INTEGER(4)' call co_sum(c, errmsg=i) - + ! 'errmsg' argument shall be character scalar !ERROR: 'errmsg=' argument has unacceptable rank 1 call co_sum(d, errmsg=character_array) - - ! the error is seen as too many arguments to the co_sum() call + !ERROR: too many actual arguments for intrinsic 'co_sum' call co_sum(r, result_image=1, stat=status, errmsg=message, 3.4) - + ! keyword argument with incorrect name !ERROR: unknown keyword argument to intrinsic 'co_sum' call co_sum(fake=3.4) - + + !ERROR: 'a' argument to 'co_sum' may not be a coindexed object + !ERROR: 'errmsg' argument to 'co_sum' may not be a coindexed object + !ERROR: 'stat' argument to 'co_sum' may not be a coindexed object + call co_sum(result_image=coindexed_result_image[1], a=coindexed_real[1], errmsg=coindexed_character[1], stat=coindexed_integer[1]) + end program test_co_sum Index: flang/test/Semantics/move_alloc.f90 =================================================================== --- /dev/null +++ flang/test/Semantics/move_alloc.f90 @@ -0,0 +1,52 @@ +! RUN: %python %S/test_errors.py %s %flang_fc1 +! Check for semantic errors in move_alloc() subroutine calls +program main + integer, allocatable :: a(:)[:], b(:)[:], c(:)[:], d(:)[:] + !ERROR: 'e' is an ALLOCATABLE coarray and must have a deferred coshape + integer, allocatable :: e(:)[*] + integer status, coindexed_status[*] + character(len=1) message, coindexed_message[*] + + ! standards conforming + allocate(a(3)[*]) + a = [ 1, 2, 3 ] + call move_alloc(a, b, status, message) + + allocate(c(3)[*]) + c = [ 1, 2, 3 ] + + !ERROR: too many actual arguments for intrinsic 'move_alloc' + call move_alloc(a, b, status, message, 1) + + ! standards non-conforming + !ERROR: 'from' argument to 'move_alloc' may not be a coindexed object + call move_alloc(c[1], d) + + !ERROR: 'to' argument to 'move_alloc' may not be a coindexed object + call move_alloc(c, d[1]) + + !ERROR: 'stat' argument to 'move_alloc' may not be a coindexed object + call move_alloc(c, d, coindexed_status[1]) + + !ERROR: 'errmsg' argument to 'move_alloc' may not be a coindexed object + call move_alloc(c, d, status, coindexed_message[1]) + + !ERROR: 'errmsg' argument to 'move_alloc' may not be a coindexed object + call move_alloc(c, d, errmsg=coindexed_message[1]) + + !ERROR: 'errmsg' argument to 'move_alloc' may not be a coindexed object + call move_alloc(c, d, errmsg=coindexed_message[1], stat=status) + + !ERROR: 'stat' argument to 'move_alloc' may not be a coindexed object + call move_alloc(c, d, stat=coindexed_status[1]) + + !ERROR: 'stat' argument to 'move_alloc' may not be a coindexed object + call move_alloc(c, d, errmsg=message, stat=coindexed_status[1]) + + !ERROR: 'from' argument to 'move_alloc' may not be a coindexed object + !ERROR: 'to' argument to 'move_alloc' may not be a coindexed object + !ERROR: 'stat' argument to 'move_alloc' may not be a coindexed object + !ERROR: 'errmsg' argument to 'move_alloc' may not be a coindexed object + call move_alloc(c[1], d[1], stat=coindexed_status[1], errmsg=coindexed_message[1]) + +end program main