[flang] Add atomic_cas to the list of intrinsics

[ktras]

Summary

Add the atomic subroutine, atomic_cas, to the list of intrinsic subroutines and check one of its arguments for a coindexed object. Create a new function, CheckAtomicKind, that will be used for the atomic subroutines that have arguments that can be either of type int and of kind atomic_int_kind or of type logical and of kind atomic_logical_kind. In this patch, this function is only called once, but it will be called in an upcoming planned patch, which is why it is an additional function, as opposed to using the code in place of the function call.

[jeanPerier]

flang/lib/Evaluate/intrinsics.cpp

1347

If arg must not be a nullptr, better use const ActualArgument &arg here and push the responsibility of passing something non null on the caller.

[ktras]

Update function signature of new function, CheckAtomicKind, based on reviewer feedback.

[ktras]

flang/lib/Evaluate/intrinsics.cpp

1347

Thanks, the changes have been made.

[jeanPerier]

Thanks, LGTM

flang/lib/Evaluate/intrinsics.cpp

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
+    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;
 };

 // 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};
 
 // 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 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},
+    {"atomic_cas",
+        {{"atom", SameAtom, Rank::atom, Optionality::required,
+             common::Intent::InOut},
+            {"old", SameAtom, Rank::scalar, Optionality::required,
+                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_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,
if (!wasInserted) {
           "Argument keyword '%s=' was repeated in call to '%s'"_err_en_US,
           *keyword, intrinsicName);
       return false;
     }
   }
   return true;
 }
 
+static bool CheckAtomicKind(const ActualArgument &arg,
+    const semantics::Scope *builtinsScope,
+    parser::ContextualMessages &messages) {
+  std::string atomicKindStr;
+  std::optional<DynamicType> type{arg.GetType()};
+
+  if (type->category() == TypeCategory::Integer) {
+    atomicKindStr = "atomic_int_kind";
+  } else if (type->category() == TypeCategory::Logical) {
+    atomicKindStr = "atomic_logical_kind";
+  } else {
+    common::die("atomic_int_kind or atomic_logical_kind from iso_fortran_env "
+                "must be used with IntType or LogicalType");
+  }
+
+  bool argOk = type->kind() ==
+      GetBuiltinKind(builtinsScope, ("__builtin_" + atomicKindStr).c_str());
+  if (!argOk) {
+    messages.Say(arg.sourceLocation(),
+        "Actual argument for 'atom=' must have kind=atomic_int_kind or atomic_logical_kind, but is '%s'"_err_en_US,
+        type->AsFortran());
+  }
+  return argOk;
+}
+
 // Intrinsic interface matching against the arguments of a particular
 // procedure reference.
 std::optional<SpecificCall> IntrinsicInterface::Match(
     const CallCharacteristics &call,
     const common::IntrinsicTypeDefaultKinds &defaults,
     ActualArguments &arguments, FoldingContext &context,
     const semantics::Scope *builtinsScope) const {
   auto &messages{context.messages()};
case KindCode::effectiveKind:
       break;
     case KindCode::addressable:
     case KindCode::nullPointerType:
       argOk = true;
       break;
     case KindCode::exactKind:
       argOk = type->kind() == d.typePattern.exactKindValue;
       break;
+    case KindCode::sameAtom:
+      if (!sameArg) {
+        sameArg = arg;
+        argOk = CheckAtomicKind(DEREF(arg), builtinsScope, messages);
+      } else {
+        argOk = type->IsTkCompatibleWith(sameArg->GetType().value());
+        if (!argOk) {
+          messages.Say(arg->sourceLocation(),
+              "Actual argument for '%s=' must have same type and kind as 'atom=', but is '%s'"_err_en_US,
+              d.keyword, type->AsFortran());
+        }
+      }
+      if (!argOk)
+        return std::nullopt;
+      break;
     case KindCode::atomicIntKind:
       argOk = type->kind() ==
           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;
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 == "atomic_cas") {
+    return CheckForCoindexedObject(context, call.arguments[4], name, "stat");
   } else if (name == "atomic_fetch_or") {
     return CheckForCoindexedObject(context, call.arguments[3], name, "stat");
   } 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{

flang/test/Semantics/atomic03.f90

 ! RUN: %python %S/test_errors.py %s %flang_fc1
-! XFAIL: *
 ! This test checks for semantic errors in atomic_cas subroutine calls based on
 ! the interface defined in section 16.9.22 of the Fortran 2018 standard.
 
 program test_atomic_cas
   use iso_fortran_env, only: atomic_int_kind, atomic_logical_kind
   implicit none
 
   integer(kind=atomic_int_kind) :: int_scalar_coarray[*], non_scalar_coarray(10)[*], non_coarray