diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp index d9a7084c52098..eb8cdd1d962f9 100644 --- a/flang/lib/Evaluate/intrinsics.cpp +++ b/flang/lib/Evaluate/intrinsics.cpp @@ -1073,6 +1073,16 @@ static const SpecificIntrinsicInterface specificIntrinsicFunction[]{ 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}}, @@ -2364,6 +2374,26 @@ static bool CheckForNonPositiveValues(FoldingContext &context, return ok; } +static bool CheckForCoindexedObjects(SpecificCall &call, + FoldingContext &context, const std::vector &dummyNames) { + bool ok{true}; + CHECK(call.arguments.size() == dummyNames.size()); + for (std::size_t j{0}; j < call.arguments.size(); ++j) { + if (dummyNames[j] != "result_image") { + const auto &arg{call.arguments[j]}; + if (const auto *expr{arg->UnwrapExpr()}) { + if (ExtractCoarrayRef(*expr)) { + ok = false; + context.messages().Say(arg->sourceLocation(), + "'%s' argument to '%s' may not be a coindexed object"_err_en_US, + dummyNames[j], call.specificIntrinsic.name); + } + } + } + } + return ok; +} + // Applies any semantic checks peculiar to an intrinsic. static bool ApplySpecificChecks(SpecificCall &call, FoldingContext &context) { bool ok{true}; @@ -2382,6 +2412,9 @@ static bool ApplySpecificChecks(SpecificCall &call, FoldingContext &context) { } } else if (name == "associated") { return CheckAssociated(call, context); + } else if (name == "co_sum") { + return CheckForCoindexedObjects(call, context, + std::vector{"a", "result_image", "stat", "errmsg"}); } else if (name == "image_status") { if (const auto &arg{call.arguments[0]}) { ok = CheckForNonPositiveValues(context, *arg, name, "image"); @@ -2413,6 +2446,9 @@ static bool ApplySpecificChecks(SpecificCall &call, FoldingContext &context) { arg ? arg->sourceLocation() : context.messages().at(), "Argument of LOC() must be an object or procedure"_err_en_US); } + } else if (name == "move_alloc") { + return CheckForCoindexedObjects(call, context, + std::vector{"from", "to", "stat", "errmsg"}); } else if (name == "present") { const auto &arg{call.arguments[0]}; if (arg) { @@ -2560,6 +2596,7 @@ std::optional IntrinsicProcTable::Implementation::Probe( 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; } } diff --git a/flang/test/Semantics/collectives01.f90 b/flang/test/Semantics/collectives01.f90 index e07a93fd3e964..3eb9aa92ea5da 100644 --- a/flang/test/Semantics/collectives01.f90 +++ b/flang/test/Semantics/collectives01.f90 @@ -1,13 +1,11 @@ ! 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[*] + integer i, status, integer_array(1), coindexed_integer[*], coindexed_result_image[*] 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[*] @@ -44,15 +42,22 @@ program test_co_sum 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, result_image=coindexed_result_image[1]) ! no optional arguments present 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) + ! argument 'a' shall be of numeric type !ERROR: Actual argument for 'a=' has bad type 'LOGICAL(4)' call co_sum(bool) @@ -61,8 +66,7 @@ program test_co_sum !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 @@ -77,9 +81,11 @@ program test_co_sum !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)' @@ -93,24 +99,27 @@ program test_co_sum !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 diff --git a/flang/test/Semantics/move_alloc.f90 b/flang/test/Semantics/move_alloc.f90 new file mode 100644 index 0000000000000..41e38c6761294 --- /dev/null +++ b/flang/test/Semantics/move_alloc.f90 @@ -0,0 +1,46 @@ +! 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]) + +end program main