[flang] Add co_broadcast to the list of intrinsics

[ktras]

Summary

Add the collective subroutine, co_broadcast, to the list
of intrinsic subroutines. Add co_broadcast to the check
for coindexed-objects for the first, third, and fourth dummy
arguments. Update the co_broadcast semantics test.

[jeanPerier]

Thanks, LGTM

flang/docs/Intrinsics.md

 | Intrinsic Category | Intrinsic Procedures Lacking Support |
 | --- | --- |
 | Coarray intrinsic functions | IMAGE_INDEX, COSHAPE |
 | Object characteristic inquiry functions | ALLOCATED, ASSOCIATED, EXTENDS_TYPE_OF, IS_CONTIGUOUS, PRESENT, RANK, SAME_TYPE, STORAGE_SIZE |
 | Type inquiry intrinsic functions | BIT_SIZE, DIGITS, EPSILON, HUGE, KIND, MAXEXPONENT, MINEXPONENT, NEW_LINE, PRECISION, RADIX, RANGE, TINY|
 | Non-standard intrinsic functions | AND, OR, XOR, LSHIFT, RSHIFT, SHIFT, ZEXT, IZEXT, COSD, SIND, TAND, ACOSD, ASIND, ATAND, ATAN2D, COMPL, DCMPLX, EQV, NEQV, INT8, JINT, JNINT, KNINT, LOC, QCMPLX, DREAL, DFLOAT, QEXT, QFLOAT, QREAL, DNUM, NUM, JNUM, KNUM, QNUM, RNUM, RAN, RANF, ILEN, SIZEOF, MCLOCK, SECNDS, COTAN, IBCHNG, ISHA, ISHC, ISHL, IXOR, IARG, IARGC, NARGS, NUMARG, BADDRESS, IADDR, CACHESIZE, EOF, FP_CLASS, INT_PTR_KIND, ISNAN, MALLOC |
 | Intrinsic subroutines |MVBITS (elemental), CPU_TIME, DATE_AND_TIME, EVENT_QUERY, EXECUTE_COMMAND_LINE, GET_COMMAND, GET_COMMAND_ARGUMENT, GET_ENVIRONMENT_VARIABLE, MOVE_ALLOC, RANDOM_INIT, RANDOM_NUMBER, RANDOM_SEED, SYSTEM_CLOCK |
 | Atomic intrinsic subroutines | ATOMIC_ADD &al. |
-| Collective intrinsic subroutines | CO_BROADCAST &al. |
+| Collective intrinsic subroutines | CO_REDUCE |
 
 
 ### Intrinsic Function Folding
 Fortran Constant Expressions can contain references to a certain number of
 intrinsic functions (see Fortran 2018 standard section 10.1.12 for more details).
 Constant Expressions may be used to define kind arguments. Therefore, the semantic
 expression analysis phase must be able to fold references to intrinsic functions
 listed in section 10.1.12.

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_broadcast",
+        {{"a", AnyData, Rank::anyOrAssumedRank, Optionality::required,
+             common::Intent::InOut},
+            {"source_image", AnyInt, Rank::scalar, Optionality::required,
+                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},
     {"co_max",
         {{"a", AnyIntOrRealOrChar, 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,
static const IntrinsicInterface intrinsicSubroutine[]{
                 common::Intent::Out},
             {"count_max", AnyInt, Rank::scalar, Optionality::optional,
                 common::Intent::Out}},
         {}, Rank::elemental, IntrinsicClass::impureSubroutine},
 };
 
 // TODO: Intrinsic subroutine EVENT_QUERY
 // TODO: Atomic intrinsic subroutines: ATOMIC_ADD &al.
-// TODO: Collective intrinsic subroutines: CO_BROADCAST &al.
+// TODO: Collective intrinsic subroutines: co_reduce
 
 // Finds a built-in derived type and returns it as a DynamicType.
 static DynamicType GetBuiltinDerivedType(
     const semantics::Scope *builtinsScope, const char *which) {
   if (!builtinsScope) {
     common::die("INTERNAL: The __fortran_builtins module was not found, and "
                 "the type '%s' was required",
         which);
if (name == "allocated") {
     }
     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_max" || name == "co_min" || name == "co_sum") {
+  } else if (name == "co_broadcast" || name == "co_max" || name == "co_min" ||
+      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]}) {

flang/test/Semantics/collectives04.f90

 ! RUN: %python %S/test_errors.py %s %flang_fc1
-! XFAIL: *
 ! This test checks for semantic errors in co_broadcast subroutine calls based on
 ! the co_broadcast interface defined in section 16.9.46 of the Fortran 2018 standard.
 ! To Do: add co_broadcast to the list of intrinsics
 
 program test_co_broadcast
   implicit none
 
   type foo_t
   end type
 
-  integer          i, integer_array(1), coindexed_integer[*], status
-  character(len=1) c, character_array(1), coindexed_character[*], message
+  integer          i, integer_array(1), coindexed_integer[*], status, coindexed_source_image[*], repeated_status
+  character(len=1) c, character_array(1), coindexed_character[*], message, repeated_message
   double precision d, double_precision_array(1)
   type(foo_t)      f
   real             r, real_array(1), coindexed_real[*]
   complex          z, complex_array
   logical bool
 
   !___ standard-conforming calls with no keyword arguments ___
   call co_broadcast(i, 1)
   call co_broadcast(c, 1)
   call co_broadcast(d, 1)
   call co_broadcast(f, 1)
   call co_broadcast(r, 1)
   call co_broadcast(z, 1)
   call co_broadcast(i, 1, status)
   call co_broadcast(i, 1, status, message)
 
   !___ standard-conforming calls with keyword arguments ___
 
   ! all arguments present
-  call co_broadcast(a=i, source_image=1, stat=status, errmsg=message) 
-  call co_broadcast(source_image=1, a=i, errmsg=message, stat=status) 
+  call co_broadcast(a=i, source_image=1, stat=status, errmsg=message)
+  call co_broadcast(source_image=1, a=i, errmsg=message, stat=status)
 
   ! one optional argument not present
   call co_broadcast(a=d, source_image=1,              errmsg=message)
   call co_broadcast(a=f, source_image=1, stat=status                )
 
   ! two optional arguments not present
-  call co_broadcast(a=r, source_image=1                             ) 
+  call co_broadcast(a=r, source_image=1                             )
+  call co_broadcast(a=r, source_image=coindexed_source_image        )
 
   !___ non-standard-conforming calls ___
 
   !ERROR: missing mandatory 'a=' argument
+  call co_broadcast()
+
+  !ERROR: repeated keyword argument to intrinsic 'co_broadcast'
+  call co_broadcast(a=i, a=c)
+
+  !ERROR: repeated keyword argument to intrinsic 'co_broadcast'
+  call co_broadcast(d, source_image=1, source_image=3)
+
+  !ERROR: repeated keyword argument to intrinsic 'co_broadcast'
+  call co_broadcast(d, 1, stat=status, stat=repeated_status)
+
+  !ERROR: repeated keyword argument to intrinsic 'co_broadcast'
+  call co_broadcast(d, 1, status, errmsg=message, errmsg=repeated_message)
+
+  !ERROR: keyword argument to intrinsic 'co_broadcast' was supplied positionally by an earlier actual argument
+  call co_broadcast(i, 1, a=c)
+
+  !ERROR: keyword argument to intrinsic 'co_broadcast' was supplied positionally by an earlier actual argument
+  call co_broadcast(i, 1, status, source_image=1)
+
+  !ERROR: keyword argument to intrinsic 'co_broadcast' was supplied positionally by an earlier actual argument
+  call co_broadcast(i, 1, status, stat=repeated_status)
+
+  !ERROR: keyword argument to intrinsic 'co_broadcast' was supplied positionally by an earlier actual argument
+  call co_broadcast(i, 1, status, message, errmsg=repeated_message)
+
+  !ERROR: missing mandatory 'a=' argument
   call co_broadcast(source_image=1, stat=status, errmsg=message)
 
   !ERROR: missing mandatory 'source_image=' argument
-  call co_broadcast(a=c, stat=status, errmsg=message) 
+  call co_broadcast(c)
+
+  !ERROR: missing mandatory 'source_image=' argument
+  call co_broadcast(a=c, stat=status, errmsg=message)
 
-  ! argument 'a' is intent(inout)
   !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'a=' must be definable
   call co_broadcast(a=1+1, source_image=1)
-  
-  ! argument 'a' shall not be a coindexed object
-  !ERROR: to be determined
+  !ERROR: 'a' argument to 'co_broadcast' may not be a coindexed object
   call co_broadcast(a=coindexed_real[1], source_image=1)
-  
   ! 'source_image' argument shall be an integer
   !ERROR: Actual argument for 'source_image=' has bad type 'LOGICAL(4)'
   call co_broadcast(i, source_image=bool)
-  
   ! 'source_image' argument shall be an integer scalar
   !ERROR: 'source_image=' argument has unacceptable rank 1
   call co_broadcast(c, source_image=integer_array)
-  
-  ! 'stat' argument shall be intent(out)
   !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'stat=' must be definable
   call co_broadcast(a=i, source_image=1, stat=1+1, errmsg=message)
 
-  ! 'stat' argument shall be noncoindexed
-  !ERROR: to be determined
+  !ERROR: 'stat' argument to 'co_broadcast' may not be a coindexed object
   call co_broadcast(d, stat=coindexed_integer[1], source_image=1)
- 
   ! 'stat' argument shall be an integer
   !ERROR: Actual argument for 'stat=' has bad type 'CHARACTER(KIND=1,LEN=1_8)'
   call co_broadcast(r, stat=message, source_image=1)
- 
-  ! 'stat' argument shall be an integer scalar
   !ERROR: 'stat=' argument has unacceptable rank 1
   call co_broadcast(i, stat=integer_array, source_image=1)
- 
-  ! 'errmsg' argument shall be intent(inout)
   !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'errmsg=' must be definable
   call co_broadcast(a=i, source_image=1, stat=status, errmsg='c')
 
-  ! 'errmsg' argument shall be noncoindexed
-  !ERROR: to be determined
+  !ERROR: 'errmsg' argument to 'co_broadcast' may not be a coindexed object
   call co_broadcast(c, errmsg=coindexed_character[1], source_image=1)
 
   ! 'errmsg' argument shall be a character
-  !ERROR: to be determined
+  !ERROR: Actual argument for 'errmsg=' has bad type 'INTEGER(4)'
   call co_broadcast(c, 1, status, i)
 
   ! 'errmsg' argument shall be a character
-  !ERROR: to be determined
+  !ERROR: Actual argument for 'errmsg=' has bad type 'INTEGER(4)'
   call co_broadcast(c, errmsg=i, source_image=1)
 
-  ! 'errmsg' argument shall be character scalar
   !ERROR: 'errmsg=' argument has unacceptable rank 1
   call co_broadcast(d, errmsg=character_array, source_image=1)
- 
-  ! the error is seen as too many arguments to the co_broadcast() call
   !ERROR: too many actual arguments for intrinsic 'co_broadcast'
   call co_broadcast(r, source_image=1, stat=status, errmsg=message, 3.4)
-  
-  ! keyword argument with incorrect name
   !ERROR: unknown keyword argument to intrinsic 'co_broadcast'
   call co_broadcast(fake=3.4)
-  
+  !ERROR: unknown keyword argument to intrinsic 'co_broadcast'
+  call co_broadcast(a=i, result_image=1, stat=status, errmsg=message)
+
+  !ERROR: 'a' argument to 'co_broadcast' may not be a coindexed object
+  !ERROR: 'errmsg' argument to 'co_broadcast' may not be a coindexed object
+  !ERROR: 'stat' argument to 'co_broadcast' may not be a coindexed object
+  call co_broadcast(source_image=coindexed_source_image[1], a=coindexed_real[1], errmsg=coindexed_character[1], stat=coindexed_integer[1])
+
 end program test_co_broadcast