[flang] Add co_sum to the list of intrinsics and update test

[ktras]

Summary

Add the collective subroutine, co_sum, to the list of intrinsics.
In accordance with 16.9.50 and 16.9.137, add a check for and an
error if coindexed objects are being passed to certain arguments
in co_sum and in move_alloc. Add a semantics test to check that
this error is successfully caught in calls to move_alloc. Remove
the XFAIL directive, update the ERROR directives and add
standard-conforming and non-standard conforming calls in the
semantics test for co_sum.

[klausler]

flang/lib/Evaluate/intrinsics.cpp

1081

"A=", "STAT=", and "ERRMSG=" are not allowed to be coindexed objects (16.9.50); how will you enforce and test this restriction?

[ktras]

• Fix rank of the co_sum dummy argument a in flang/lib/Evaluate/intrinsics.cpp
• Add check for and error if a coindexed object is passed to dummy arguments a, stat, and errmsg in co_sum, and dummy arguments from, to, stat, and errmsg in move_alloc.
• Add semantics test to ensure that coindexed error is being caught in calls to move_alloc.
• Update semantics test for co_sum by fixing ERROR directives for the new error and adding one non-standard conforming call.

[ktras]

flang/lib/Evaluate/intrinsics.cpp

1081

Thanks for the feedback and sorry that it took me so long to respond.
I have now added a check for coindexed objects for these arguments.

[ktras]

Ping.

[jeanPerier]

flang/lib/Evaluate/intrinsics.cpp

1649

I think this custom check might better belong in ApplySpecificChecks that does custom checks that do not fit in the automated checks.

[ktras]

flang/lib/Evaluate/intrinsics.cpp

1649

Thanks for pointing that function out. I agree that moving this check to ApplySpecificChecks() seems like an appropriate change. I will work on doing that and updating the diff. Thanks for the feedback!

[ktras]

Move check for coindexed objects for certain arguments in co_sum and move_alloc to a new function CheckForCoindexedObjects, which is called from ApplySpecificChecks for the specific cases of co_sum and move_alloc. Add some calls to the semantics tests to better check this implementation.

[jeanPerier]

LGTM, thanks

[ktras]

@jeanPerier Thanks for the review!

[ktras]

I pushed this change today and had to revert the commit because it caused some unexpected test failures. The three tests that failed on the buildbots (though these tests didn't consistently fail across the different buildbots) were all flang semantics tests and are:

• flang/test/Semantics/collective01.f90 - the test that I removed the XFAIL directive from in this differential
• flang/test/Semantics/move_alloc.f90 - the new test from this differential
• flang/test/Semantics/doconcurrent01.f90 - a test with move_alloc calls

This reopens the revision.

[ktras]

Updated the new function CheckForCoindexedObjects (and renamed it CheckForCoindexedObject) to take one ActualArgument and to check just that argument for a coindexed object. This fixes the non-deterministic test failure I was finding with my previous implementation, plus it also is a better function for when I add the atomic subroutines and use it to check only one of their arguments.

[ktras]

Forgot to run git-clang-format after one last small change I made, so this updated diff fixes the one line changed by git-clang-format.

[ktras]

Remove unnecessary if-stmt in new function, CheckForCoindexedObject.

[ktras]

@jeanPerier I have updated this differential since you approved it, would you like to check the changes? My new function now just checks one ActualArgument to make sure it is not a coindexed-object, instead of a list of ActualArguments. This fixes some test failures I was getting, and also I think matches better the needs of the other subroutines that will need to call this function, like the atomic subroutines, which all have only one ActualArgument that shall not be coindexed.

flang/lib/Evaluate/intrinsics.cpp

static const SpecificIntrinsicInterface specificIntrinsicFunction[]{
     {{"tanh", {{"x", DefaultReal}}, DefaultReal}},
     {{"zabs", {{"a", TypePattern{ComplexType, KindCode::exactKind, 8}}},
          TypePattern{RealType, KindCode::exactKind, 8}},
         "abs"},
 };
 
 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}},
         {}, Rank::elemental, IntrinsicClass::impureSubroutine},
     {"date_and_time",
         {{"date", DefaultChar, Rank::scalar, Optionality::optional,
              common::Intent::Out},
             {"time", DefaultChar, Rank::scalar, Optionality::optional,
if (const ActualArgument * arg{actualForDummy[j]}) {
       }
     }
   }
 
   // Calculate the characteristics of the function result, if any
   std::optional<DynamicType> resultType;
   if (auto category{result.categorySet.LeastElement()}) {
     // The intrinsic is not a subroutine.
     if (call.isSubroutineCall) {
       return std::nullopt;
     }
     switch (result.kindCode) {
     case KindCode::defaultIntegerKind:
       CHECK(result.categorySet == IntType);
       CHECK(*category == TypeCategory::Integer);
       resultType = DynamicType{TypeCategory::Integer,
           defaults.GetDefaultKind(TypeCategory::Integer)};
if (auto val{ToInt64(arg.UnwrapExpr())}) {
             "'%s=' argument for intrinsic '%s' must be a positive value, but is %jd"_err_en_US,
             argName, procName, static_cast<std::intmax_t>(*val));
       }
     }
   }
   return ok;
 }
 
+static bool CheckForCoindexedObject(FoldingContext &context,
+    const std::optional<ActualArgument> &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};
   const std::string &name{call.specificIntrinsic.name};
   if (name == "allocated") {
     const auto &arg{call.arguments[0]};
     if (arg) {
       if (const auto *expr{arg->UnwrapExpr()}) {
         ok = evaluate::IsAllocatableDesignator(*expr);
       }
     }
     if (!ok) {
       context.messages().Say(
           arg ? arg->sourceLocation() : context.messages().at(),
           "Argument of ALLOCATED() must be an ALLOCATABLE object or component"_err_en_US);
     }
   } 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");
     }
   } else if (name == "ishftc") {
     if (const auto &sizeArg{call.arguments[2]}) {
       ok = CheckForNonPositiveValues(context, *sizeArg, name, "size");
       if (ok) {
if (name == "allocated") {
     const auto &arg{call.arguments[0]};
     ok =
         arg && (arg->GetAssumedTypeDummy() || GetLastSymbol(arg->UnwrapExpr()));
     if (!ok) {
       context.messages().Say(
           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) {
       if (const auto *expr{arg->UnwrapExpr()}) {
         if (const Symbol * symbol{UnwrapWholeSymbolDataRef(*expr)}) {
           ok = symbol->attrs().test(semantics::Attr::OPTIONAL);
         }
       }
if (call.isSubroutineCall) {
     return HandleNull(arguments, context);
   }
 
   if (call.isSubroutineCall) {
     auto subrRange{subroutines_.equal_range(call.name)};
     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;
       }
     }
     if (IsIntrinsicFunction(call.name)) {
       context.messages().Say(
           "Cannot use intrinsic function '%s' as a subroutine"_err_en_US,
           call.name);
     }

flang/test/Semantics/collectives01.f90

 ! 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)
   call co_sum(d)
   call co_sum(r)
   call co_sum(i, 1)
   call co_sum(c, 1, status)
   call co_sum(d, 1, status, message)
   call co_sum(r, 1, status, message)
   call co_sum(integer_array)
   call co_sum(complex_array, 1)
   call co_sum(double_precision_array, 1, status)
   call co_sum(real_array, 1, status, message)
 
   !___ 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)
 
   ! argument 'stat' shall be intent(out)
   !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

flang/test/Semantics/move_alloc.f90

+! 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