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

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 both
standard-conforming and non-standard conforming calls to the
semantics test for co_sum.

Reviewed By: jeanPerier

Differential Revision: https://reviews.llvm.org/D114134

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<std::string> &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<std::string>{"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<std::string>{"from", "to", "stat", "errmsg"});
   } else if (name == "present") {
     const auto &arg{call.arguments[0]};
     if (arg) {
@@ -2560,6 +2596,7 @@ std::optional<SpecificCall> 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;
       }
     }

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

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