[flang] Add atomic_define and atomic_ref to list of intrinsics

[ktras]

Summary

Add the atomic subroutines, atomic_define and atomic_ref, to the
list of intrinsic subroutines. Add a new function CheckAtomicDefineAndRef
to check that for each of these procedures, that their value arguments are
the same type as their atom arguments, and that their 3rd argument is not
coindexed.

[PeteSteinfeld]

All builds and tests correctly and looks good.

Thanks for implementing these intrinsics!

flang/lib/Evaluate/intrinsics.cpp

 using CategorySet = common::EnumSet<TypeCategory, 8>;
 static constexpr CategorySet IntType{TypeCategory::Integer};
 static constexpr CategorySet RealType{TypeCategory::Real};
 static constexpr CategorySet ComplexType{TypeCategory::Complex};
 static constexpr CategorySet CharType{TypeCategory::Character};
 static constexpr CategorySet LogicalType{TypeCategory::Logical};
 static constexpr CategorySet IntOrRealType{IntType | RealType};
 static constexpr CategorySet IntOrRealOrCharType{IntType | RealType | CharType};
+static constexpr CategorySet IntOrLogicalType{IntType | LogicalType};
 static constexpr CategorySet FloatingType{RealType | ComplexType};
 static constexpr CategorySet NumericType{IntType | RealType | ComplexType};
 static constexpr CategorySet RelatableType{IntType | RealType | CharType};
 static constexpr CategorySet DerivedType{TypeCategory::Derived};
 static constexpr CategorySet IntrinsicType{
     IntType | RealType | ComplexType | CharType | LogicalType};
 static constexpr CategorySet AnyType{IntrinsicType | DerivedType};
 
ENUM_CLASS(KindCode, none, defaultIntegerKind,
     dimArg, // this argument is DIM=
     likeMultiply, // for DOT_PRODUCT and MATMUL
     subscript, // address-sized integer
     size, // default KIND= for SIZE(), UBOUND, &c.
     addressable, // for PRESENT(), &c.; anything (incl. procedure) but BOZ
     nullPointerType, // for ASSOCIATED(NULL())
     exactKind, // a single explicit exactKindValue
     atomicIntKind, // atomic_int_kind from iso_fortran_env
+    atomicIntOrLogicalKind, // atomic_int_kind or atomic_logical_kind
     sameAtom, // same type and kind as atom
 )
 
 struct TypePattern {
   CategorySet categorySet;
   KindCode kindCode{KindCode::none};
   int exactKindValue{0}; // for KindCode::exactBind
   llvm::raw_ostream &Dump(llvm::raw_ostream &) const;

 static constexpr TypePattern SubscriptInt{IntType, KindCode::subscript};
 
 // Match any kind of some intrinsic or derived types
 static constexpr TypePattern AnyInt{IntType, KindCode::any};
 static constexpr TypePattern AnyReal{RealType, KindCode::any};
 static constexpr TypePattern AnyIntOrReal{IntOrRealType, KindCode::any};
 static constexpr TypePattern AnyIntOrRealOrChar{
     IntOrRealOrCharType, KindCode::any};
+static constexpr TypePattern AnyIntOrLogical{IntOrLogicalType, KindCode::any};
 static constexpr TypePattern AnyComplex{ComplexType, KindCode::any};
 static constexpr TypePattern AnyFloating{FloatingType, KindCode::any};
 static constexpr TypePattern AnyNumeric{NumericType, KindCode::any};
 static constexpr TypePattern AnyChar{CharType, KindCode::any};
 static constexpr TypePattern AnyLogical{LogicalType, KindCode::any};
 static constexpr TypePattern AnyRelatable{RelatableType, KindCode::any};
 static constexpr TypePattern AnyIntrinsic{IntrinsicType, KindCode::any};
 static constexpr TypePattern ExtensibleDerived{DerivedType, KindCode::any};

 // Result types with known category and KIND=
 static constexpr TypePattern KINDInt{IntType, KindCode::effectiveKind};
 static constexpr TypePattern KINDReal{RealType, KindCode::effectiveKind};
 static constexpr TypePattern KINDComplex{ComplexType, KindCode::effectiveKind};
 static constexpr TypePattern KINDChar{CharType, KindCode::effectiveKind};
 static constexpr TypePattern KINDLogical{LogicalType, KindCode::effectiveKind};
 
 static constexpr TypePattern AtomicInt{IntType, KindCode::atomicIntKind};
-static constexpr TypePattern SameAtom{
-    IntType | LogicalType, KindCode::sameAtom};
+static constexpr TypePattern AtomicIntOrLogical{
+    IntOrLogicalType, KindCode::atomicIntOrLogicalKind};
+static constexpr TypePattern SameAtom{IntOrLogicalType, KindCode::sameAtom};
 
 // The default rank pattern for dummy arguments and function results is
 // "elemental".
 ENUM_CLASS(Rank,
     elemental, // scalar, or array that conforms with other array arguments
     elementalOrBOZ, // elemental, or typeless BOZ literal scalar
     scalar, vector,
     shape, // INTEGER vector of known length and no negative element
static const IntrinsicInterface intrinsicSubroutine[]{
                 common::Intent::Out},
             {"compare", SameAtom, Rank::scalar, Optionality::required,
                 common::Intent::In},
             {"new", SameAtom, Rank::scalar, Optionality::required,
                 common::Intent::In},
             {"stat", AnyInt, Rank::scalar, Optionality::optional,
                 common::Intent::Out}},
         {}, Rank::elemental, IntrinsicClass::atomicSubroutine},
+    {"atomic_define",
+        {{"atom", AtomicIntOrLogical, Rank::atom, Optionality::required,
+             common::Intent::Out},
+            {"value", AnyIntOrLogical, Rank::scalar, Optionality::required,
+                common::Intent::In},
+            {"stat", AnyInt, Rank::scalar, Optionality::optional,
+                common::Intent::Out}},
+        {}, Rank::elemental, IntrinsicClass::atomicSubroutine},
     {"atomic_fetch_or",
         {{"atom", AtomicInt, Rank::atom, Optionality::required,
              common::Intent::InOut},
             {"value", AnyInt, Rank::scalar, Optionality::required,
                 common::Intent::In},
             {"old", AtomicInt, Rank::scalar, Optionality::required,
                 common::Intent::Out},
             {"stat", AnyInt, Rank::scalar, Optionality::optional,
                 common::Intent::Out}},
         {}, Rank::elemental, IntrinsicClass::atomicSubroutine},
+    {"atomic_ref",
+        {{"value", AnyIntOrLogical, Rank::scalar, Optionality::required,
+             common::Intent::Out},
+            {"atom", AtomicIntOrLogical, Rank::atom, Optionality::required,
+                common::Intent::In},
+            {"stat", AnyInt, Rank::scalar, Optionality::optional,
+                common::Intent::Out}},
+        {}, Rank::elemental, IntrinsicClass::atomicSubroutine},
     {"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,
case KindCode::atomicIntKind:
           GetBuiltinKind(builtinsScope, "__builtin_atomic_int_kind");
       if (!argOk) {
         messages.Say(arg->sourceLocation(),
             "Actual argument for '%s=' must have kind=atomic_int_kind, but is '%s'"_err_en_US,
             d.keyword, type->AsFortran());
         return std::nullopt;
       }
       break;
+    case KindCode::atomicIntOrLogicalKind:
+      argOk = CheckAtomicKind(DEREF(arg), builtinsScope, messages);
+      if (!argOk)
+        return std::nullopt;
+      break;
     default:
       CRASH_NO_CASE;
     }
     if (!argOk) {
       messages.Say(arg->sourceLocation(),
           "Actual argument for '%s=' has bad type or kind '%s'"_err_en_US,
           d.keyword, type->AsFortran());
       return std::nullopt;
if (ExtractCoarrayRef(arg->UnwrapExpr())) {
       context.messages().Say(arg->sourceLocation(),
           "'%s' argument to '%s' may not be a coindexed object"_err_en_US,
           argName, procName);
     }
   }
   return ok;
 }
 
+static bool CheckAtomicDefineAndRef(FoldingContext &context,
+    const std::optional<ActualArgument> &atomArg,
+    const std::optional<ActualArgument> &valueArg,
+    const std::optional<ActualArgument> &statArg, const std::string &procName) {
+  bool sameType{true};
+  if (valueArg && atomArg) {
+    // for atomic_define and atomic_ref, 'value' arg must be the same type as
+    // 'atom', but it doesn't have to be the same kind
+    if (valueArg->GetType()->category() != atomArg->GetType()->category()) {
+      sameType = false;
+      context.messages().Say(valueArg->sourceLocation(),
+          "'value=' argument to '%s' must have same type as 'atom=', but is '%s'"_err_en_US,
+          procName, valueArg->GetType()->AsFortran());
+    }
+  }
+
+  return sameType &&
+      CheckForCoindexedObject(context, statArg, procName, "stat");
+}
+
 // 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 == "atomic_cas") {
     return CheckForCoindexedObject(context, call.arguments[4], name, "stat");
+  } else if (name == "atomic_define") {
+    return CheckAtomicDefineAndRef(
+        context, call.arguments[0], call.arguments[1], call.arguments[2], name);
   } else if (name == "atomic_fetch_or") {
     return CheckForCoindexedObject(context, call.arguments[3], name, "stat");
+  } else if (name == "atomic_ref") {
+    return CheckAtomicDefineAndRef(
+        context, call.arguments[1], call.arguments[0], call.arguments[2], name);
   } 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;

flang/test/Semantics/atomic04.f90

 ! RUN: %python %S/test_errors.py %s %flang_fc1
-! XFAIL: *
 ! This test checks for semantic errors in atomic_define subroutine calls based on
 ! the interface defined in section 16.9.23 of the Fortran 2018 standard.
 
 program test_atomic_define
   use iso_fortran_env, only: atomic_int_kind, atomic_logical_kind
   implicit none
 
   integer(kind=atomic_int_kind) :: scalar_coarray[*], non_scalar_coarray(10)[*], val, non_coarray
program test_atomic_define
   call atomic_define(atom_logical, val_logical, stat=status)
   call atomic_define(atom_logical, value=val_logical, stat=status)
   call atomic_define(atom=atom_logical, value=val_logical)
   call atomic_define(atom=atom_logical, value=val_logical, stat=status)
   call atomic_define(stat=status, value=val_logical, atom=atom_logical)
 
   !___ non-standard-conforming calls ___
 
-  !ERROR: 'atom=' argument must be a scalar coarray for intrinsic 'atomic_define'
+  !ERROR: 'atom=' argument must be a scalar coarray or coindexed object for intrinsic 'atomic_define'
   call atomic_define(non_scalar_coarray, val)
 
-  !ERROR: 'atom=' argument must be a scalar coarray for intrinsic 'atomic_define'
+  !ERROR: 'atom=' argument must be a scalar coarray or coindexed object for intrinsic 'atomic_define'
+  call atomic_define(non_scalar_coarray[1], val)
+
+  !ERROR: 'atom=' argument must be a scalar coarray or coindexed object for intrinsic 'atomic_define'
   call atomic_define(non_scalar_logical_coarray, val_logical)
 
-  !ERROR: 'atom=' argument must be a coarray or a coindexed object for intrinsic 'atomic_define'
+  !ERROR: 'atom=' argument must be a scalar coarray or coindexed object for intrinsic 'atomic_define'
+  call atomic_define(non_scalar_logical_coarray[1], val_logical)
+
+  !ERROR: 'atom=' argument must be a scalar coarray or coindexed object for intrinsic 'atomic_define'
   call atomic_define(non_coarray, val)
 
-  !ERROR: 'atom=' argument must be a coarray or a coindexed object for intrinsic 'atomic_define'
+  !ERROR: 'atom=' argument must be a scalar coarray or coindexed object for intrinsic 'atomic_define'
   call atomic_define(non_coarray_logical, val_logical)
 
-  !ERROR: 'atom=' argument must be a coarray or a coindexed object for intrinsic 'atomic_define'
+  !ERROR: 'atom=' argument must be a scalar coarray or coindexed object for intrinsic 'atomic_define'
   call atomic_define(array, val)
 
-  ! 'atom=' argument not of 'atomic_int_kind' or 'atomic_logical_kind'
+  !ERROR: Actual argument for 'atom=' must have kind=atomic_int_kind or atomic_logical_kind, but is 'INTEGER(4)'
   call atomic_define(default_kind_coarray, val)
 
-  ! 'atom=' argument not of 'atomic_int_kind' or 'atomic_logical_kind'
+  !ERROR: Actual argument for 'atom=' must have kind=atomic_int_kind or atomic_logical_kind, but is 'INTEGER(1)'
   call atomic_define(kind1_coarray, val)
 
-  ! 'atom=' argument not of 'atomic_int_kind' or 'atomic_logical_kind'
+  !ERROR: Actual argument for 'atom=' must have kind=atomic_int_kind or atomic_logical_kind, but is 'LOGICAL(4)'
   call atomic_define(default_kind_logical_coarray, val_logical)
 
-  ! 'atom=' argument not of 'atomic_int_kind' or 'atomic_logical_kind'
+  !ERROR: Actual argument for 'atom=' must have kind=atomic_int_kind or atomic_logical_kind, but is 'LOGICAL(1)'
   call atomic_define(kind1_logical_coarray, val_logical)
 
-  ! 'value=' argument not same type as 'atom=' argument
+  !ERROR: 'value=' argument to 'atomic_define' must have same type as 'atom=', but is 'LOGICAL(8)'
   call atomic_define(scalar_coarray, val_logical)
 
-  ! 'value=' argument not same type as 'atom=' argument
+  !ERROR: 'value=' argument to 'atomic_define' must have same type as 'atom=', but is 'INTEGER(8)'
   call atomic_define(atom_logical, val)
 
   !ERROR: Actual argument for 'atom=' has bad type 'REAL(4)'
   call atomic_define(non_integer_coarray, val)
 
   !ERROR: 'value=' argument has unacceptable rank 1
   call atomic_define(scalar_coarray, array)
 
   !ERROR: Actual argument for 'value=' has bad type 'REAL(4)'
   call atomic_define(scalar_coarray, non_int_or_logical)
 
   !ERROR: Actual argument for 'value=' has bad type 'REAL(4)'
   call atomic_define(atom_logical, non_int_or_logical)
 
   !ERROR: Actual argument for 'stat=' has bad type 'LOGICAL(4)'
   call atomic_define(scalar_coarray, val, non_integer)
 
   !ERROR: 'stat=' argument has unacceptable rank 1
   call atomic_define(scalar_coarray, val, status_array)
 
-  ! status shall not be coindexed
+  !ERROR: 'stat' argument to 'atomic_define' may not be a coindexed object
   call atomic_define(scalar_coarray, val, coindexed_status[1])
 
   !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'stat=' must be definable
   call atomic_define(scalar_coarray, val, 1)
 
   !ERROR: missing mandatory 'atom=' argument
   call atomic_define()
 

flang/test/Semantics/atomic10.f90

 ! RUN: %python %S/test_errors.py %s %flang_fc1
-! XFAIL: *
 ! This test checks for semantic errors in atomic_ref subroutine calls based on
 ! the interface defined in section 16.9.29 of the Fortran 2018 standard.
 
 program test_atomic_ref
   use iso_fortran_env, only: atomic_int_kind, atomic_logical_kind
   implicit none
 
   integer(kind=atomic_int_kind) :: scalar_coarray[*], non_scalar_coarray(10)[*], val, non_coarray
program test_atomic_ref
   call atomic_ref(stat=status, atom=atom_logical, value=val_logical)
 
   !___ non-standard-conforming calls ___
 
   !ERROR: 'atom=' argument must be a scalar coarray or coindexed object for intrinsic 'atomic_ref'
   call atomic_ref(val, non_scalar_coarray)
 
   !ERROR: 'atom=' argument must be a scalar coarray or coindexed object for intrinsic 'atomic_ref'
+  call atomic_ref(val, non_scalar_coarray[1])
+
+  !ERROR: 'atom=' argument must be a scalar coarray or coindexed object for intrinsic 'atomic_ref'
   call atomic_ref(val_logical, non_scalar_logical_coarray)
 
   !ERROR: 'atom=' argument must be a scalar coarray or coindexed object for intrinsic 'atomic_ref'
+  call atomic_ref(val_logical, non_scalar_logical_coarray[1])
+
+  !ERROR: 'atom=' argument must be a scalar coarray or coindexed object for intrinsic 'atomic_ref'
   call atomic_ref(val, non_coarray)
 
   !ERROR: 'atom=' argument must be a scalar coarray or coindexed object for intrinsic 'atomic_ref'
   call atomic_ref(val_logical, non_coarray_logical)
 
   !ERROR: 'atom=' argument must be a scalar coarray or coindexed object for intrinsic 'atomic_ref'
   call atomic_ref(val, array)
 
   !ERROR: Actual argument for 'atom=' must have kind=atomic_int_kind or atomic_logical_kind, but is 'INTEGER(4)'
   call atomic_ref(val, default_kind_coarray)
 
   !ERROR: Actual argument for 'atom=' must have kind=atomic_int_kind or atomic_logical_kind, but is 'INTEGER(1)'
   call atomic_ref(val, kind1_coarray)
 
   !ERROR: Actual argument for 'atom=' must have kind=atomic_int_kind or atomic_logical_kind, but is 'LOGICAL(4)'
   call atomic_ref(val_logical, default_kind_logical_coarray)
 
   !ERROR: Actual argument for 'atom=' must have kind=atomic_int_kind or atomic_logical_kind, but is 'LOGICAL(1)'
   call atomic_ref(val_logical, kind1_logical_coarray)
 
-  !ERROR: Actual argument for 'value=' must have same type as 'atom=', but is 'LOGICAL(8)'
+  !ERROR: 'value=' argument to 'atomic_ref' must have same type as 'atom=', but is 'LOGICAL(8)'
   call atomic_ref(val_logical, scalar_coarray)
 
-  !ERROR: Actual argument for 'value=' must have same type as 'atom=', but is 'INTEGER(8)'
+  !ERROR: 'value=' argument to 'atomic_ref' must have same type as 'atom=', but is 'INTEGER(8)'
   call atomic_ref(val, atom_logical)
 
   !ERROR: Actual argument for 'atom=' has bad type 'REAL(4)'
   call atomic_ref(val, non_integer_coarray)
 
   !ERROR: 'value=' argument has unacceptable rank 1
   call atomic_ref(array, scalar_coarray)