[flang] Define ATOMIC_ADD as an intrinsic procedure

flang/lib/Evaluate/intrinsics.cpp

@@ -1311,6 +1311,14 @@ static const SpecificIntrinsicInterface specificIntrinsicFunction[]{
 
 static const IntrinsicInterface intrinsicSubroutine[]{
     {"abort", {}, {}, Rank::elemental, IntrinsicClass::impureSubroutine},
+    {"atomic_add",
+        {{"atom", AtomicInt, Rank::atom, Optionality::required,
+             common::Intent::InOut},
+            {"value", AnyInt, Rank::scalar, Optionality::required,
+                common::Intent::In},
+            {"stat", AnyInt, Rank::scalar, Optionality::optional,
+                common::Intent::Out}},
+        {}, Rank::elemental, IntrinsicClass::atomicSubroutine},
     {"atomic_and",
         {{"atom", AtomicInt, Rank::atom, Optionality::required,
              common::Intent::InOut},
@@ -1585,7 +1593,6 @@ static const IntrinsicInterface intrinsicSubroutine[]{
 };
 
 // TODO: Intrinsic subroutine EVENT_QUERY
-// TODO: Atomic intrinsic subroutines: ATOMIC_ADD
 // TODO: Collective intrinsic subroutines: co_reduce
 
 // Finds a built-in derived type and returns it as a DynamicType.
@@ -1713,8 +1720,8 @@ static bool CheckAndPushMinMaxArgument(ActualArgument &arg,
 }
 
 static bool CheckAtomicKind(const ActualArgument &arg,
-    const semantics::Scope *builtinsScope,
-    parser::ContextualMessages &messages) {
+    const semantics::Scope *builtinsScope, parser::ContextualMessages &messages,
+    const char *keyword) {
   std::string atomicKindStr;
   std::optional<DynamicType> type{arg.GetType()};
 
@@ -1727,11 +1734,12 @@ static bool CheckAtomicKind(const ActualArgument &arg,
                 "must be used with IntType or LogicalType");
   }
 
-  bool argOk = type->kind() ==
-      GetBuiltinKind(builtinsScope, ("__builtin_" + atomicKindStr).c_str());
+  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,
+        "Actual argument for '%s=' must have kind=atomic_%s_kind, but is '%s'"_err_en_US,
+        keyword, type->category() == TypeCategory::Integer ? "int" : "logical",
         type->AsFortran());
   }
   return argOk;
@@ -2052,7 +2060,7 @@ std::optional<SpecificCall> IntrinsicInterface::Match(
     case KindCode::sameAtom:
       if (!sameArg) {
         sameArg = arg;
-        argOk = CheckAtomicKind(DEREF(arg), builtinsScope, messages);
+        argOk = CheckAtomicKind(DEREF(arg), builtinsScope, messages, d.keyword);
       } else {
         argOk = type->IsTkCompatibleWith(sameArg->GetType().value());
         if (!argOk) {
@@ -2061,23 +2069,21 @@ std::optional<SpecificCall> IntrinsicInterface::Match(
               d.keyword, type->AsFortran());
         }
       }
-      if (!argOk)
+      if (!argOk) {
         return std::nullopt;
+      }
       break;
     case KindCode::atomicIntKind:
-      argOk = type->kind() ==
-          GetBuiltinKind(builtinsScope, "__builtin_atomic_int_kind");
+      argOk = CheckAtomicKind(DEREF(arg), builtinsScope, messages, d.keyword);
       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)
+      argOk = CheckAtomicKind(DEREF(arg), builtinsScope, messages, d.keyword);
+      if (!argOk) {
         return std::nullopt;
+      }
       break;
     default:
       CRASH_NO_CASE;
@@ -3232,8 +3238,8 @@ static bool ApplySpecificChecks(SpecificCall &call, FoldingContext &context) {
           arg ? arg->sourceLocation() : context.messages().at(),
           "Argument of ALLOCATED() must be an ALLOCATABLE object or component"_err_en_US);
     }
-  } else if (name == "atomic_and" || name == "atomic_or" ||
-      name == "atomic_xor") {
+  } else if (name == "atomic_add" || name == "atomic_and" ||
+      name == "atomic_or" || name == "atomic_xor") {
     return CheckForCoindexedObject(
         context.messages(), call.arguments[2], name, "stat");
   } else if (name == "atomic_cas") {

flang/test/Semantics/atomic01.f90

@@ -1,14 +1,13 @@
 ! RUN: %python %S/test_errors.py %s %flang_fc1
-! XFAIL: *
 ! This test checks for semantic errors in atomic_add() subroutine based on the
 ! statement specification in section 16.9.20 of the Fortran 2018 standard.
 
 program test_atomic_add
   use iso_fortran_env, only : atomic_int_kind
-  implicit none
+  implicit none(external, type)
 
   integer(kind=atomic_int_kind) atom_object[*], atom_array(2)[*], quantity, array(1), coarray[*], non_coarray
-  integer non_atom_object[*], non_atom, non_scalar(1), status, stat_array(1), coindexed[*]
+  integer non_atom_object[*], non_scalar(1), status, stat_array(1), coindexed[*]
   logical non_integer
 
   !___ standard-conforming calls with required arguments _______
@@ -31,63 +30,80 @@ program test_atomic_add
   !___ non-standard-conforming calls _______
 
   ! atom must be of kind atomic_int_kind
+  ! ERROR: Actual argument for 'atom=' must have kind=atomic_int_kind, but is 'INTEGER(4)'
   call atomic_add(non_atom_object, quantity)
 
   ! atom must be a coarray
+  ! ERROR: 'atom=' argument must be a scalar coarray or coindexed object for intrinsic 'atomic_add'
   call atomic_add(non_coarray, quantity)
 
   ! atom must be a scalar variable
+  ! ERROR: 'atom=' argument must be a scalar coarray or coindexed object for intrinsic 'atomic_add'
   call atomic_add(atom_array, quantity)
 
   ! atom has an unknown keyword argument
+  ! ERROR: unknown keyword argument to intrinsic 'atomic_add'
   call atomic_add(atoms=atom_object, value=quantity)
 
   ! atom has an argument mismatch
+  ! ERROR: Actual argument for 'atom=' must have kind=atomic_int_kind, but is 'INTEGER(4)'
   call atomic_add(atom=non_atom_object, value=quantity)
 
   ! value must be an integer
+  ! ERROR: Actual argument for 'value=' has bad type 'LOGICAL(4)'
   call atomic_add(atom_object, non_integer)
 
   ! value must be an integer scalar
+  ! ERROR: 'value=' argument has unacceptable rank 1
   call atomic_add(atom_object, array)
 
-  ! value must be of kind atomic_int_kind
-  call atomic_add(atom_object, non_atom)
-
   ! value has an unknown keyword argument
+  ! ERROR: unknown keyword argument to intrinsic 'atomic_add'
   call atomic_add(atom_object, values=quantity)
 
   ! value has an argument mismatch
+  ! ERROR: Actual argument for 'value=' has bad type 'LOGICAL(4)'
   call atomic_add(atom_object, value=non_integer)
 
   ! stat must be an integer
+  ! ERROR: Actual argument for 'stat=' has bad type 'LOGICAL(4)'
   call atomic_add(atom_object, quantity, non_integer)
 
   ! stat must be an integer scalar
+  ! ERROR: 'stat=' argument has unacceptable rank 1
   call atomic_add(atom_object, quantity, non_scalar)
 
   ! stat is an intent(out) argument
+  ! ERROR: Actual argument associated with INTENT(OUT) dummy argument 'stat=' is not definable
+  ! ERROR: '8_4' is not a variable or pointer
   call atomic_add(atom_object, quantity, 8)
 
   ! stat has an unknown keyword argument
+  ! ERROR: unknown keyword argument to intrinsic 'atomic_add'
   call atomic_add(atom_object, quantity, statuses=status)
 
   ! stat has an argument mismatch
+  ! ERROR: Actual argument for 'stat=' has bad type 'LOGICAL(4)'
   call atomic_add(atom_object, quantity, stat=non_integer)
 
   ! stat must not be coindexed
+  ! ERROR: 'stat' argument to 'atomic_add' may not be a coindexed object
   call atomic_add(atom_object, quantity, coindexed[1])
 
   ! Too many arguments
+  ! ERROR: too many actual arguments for intrinsic 'atomic_add'
   call atomic_add(atom_object, quantity, status, stat_array(1))
 
   ! Repeated atom keyword
+  ! ERROR: repeated keyword argument to intrinsic 'atomic_add'
   call atomic_add(atom=atom_object, atom=atom_array(1), value=quantity)
 
   ! Repeated value keyword
+  ! ERROR: repeated keyword argument to intrinsic 'atomic_add'
   call atomic_add(atom=atom_object, value=quantity, value=array(1))
 
   ! Repeated stat keyword
+  ! ERROR: repeated keyword argument to intrinsic 'atomic_add'
   call atomic_add(atom=atom_object, value=quantity, stat=status, stat=stat_array(1))
 
 end program test_atomic_add

flang/test/Semantics/atomic02.f90

@@ -4,7 +4,7 @@
 
 program test_atomic_and
   use iso_fortran_env, only: atomic_int_kind, atomic_logical_kind
-  implicit none
+  implicit none(external, type)
 
   integer(kind=atomic_int_kind) :: scalar_coarray[*], non_scalar_coarray(10)[*], val, non_coarray
   integer(kind=atomic_int_kind) :: repeated_atom[*], repeated_val, array(10)

flang/test/Semantics/atomic03.f90

@@ -4,7 +4,7 @@
 
 program test_atomic_cas
   use iso_fortran_env, only: atomic_int_kind, atomic_logical_kind
-  implicit none
+  implicit none(external, type)
 
   integer(kind=atomic_int_kind) :: int_scalar_coarray[*], non_scalar_coarray(10)[*], non_coarray
   integer(kind=atomic_int_kind) :: repeated_atom[*], array(10)
@@ -70,16 +70,16 @@ program test_atomic_cas
 
 ! mismatches where 'atom' has wrong kind
 
-  !ERROR: Actual argument for 'atom=' must have kind=atomic_int_kind or atomic_logical_kind, but is 'INTEGER(4)'
+  !ERROR: Actual argument for 'atom=' must have kind=atomic_int_kind, but is 'INTEGER(4)'
   call atomic_cas(default_kind_coarray, old_int, compare_int, new_int)
 
-  !ERROR: Actual argument for 'atom=' must have kind=atomic_int_kind or atomic_logical_kind, but is 'INTEGER(1)'
+  !ERROR: Actual argument for 'atom=' must have kind=atomic_int_kind, but is 'INTEGER(1)'
   call atomic_cas(kind1_coarray, old_int, compare_int, new_int)
 
-  !ERROR: Actual argument for 'atom=' must have kind=atomic_int_kind or atomic_logical_kind, but is 'LOGICAL(4)'
+  !ERROR: Actual argument for 'atom=' must have kind=atomic_logical_kind, but is 'LOGICAL(4)'
   call atomic_cas(default_kind_logical_coarray, old_logical, compare_logical, new_logical)
 
-  !ERROR: Actual argument for 'atom=' must have kind=atomic_int_kind or atomic_logical_kind, but is 'LOGICAL(1)'
+  !ERROR: Actual argument for 'atom=' must have kind=atomic_logical_kind, but is 'LOGICAL(1)'
   call atomic_cas(kind1_logical_coarray, old_logical, compare_logical, new_logical)
 
 ! mismatch where 'atom' has wrong type

flang/test/Semantics/atomic04.f90

@@ -4,7 +4,7 @@
 
 program test_atomic_define
   use iso_fortran_env, only: atomic_int_kind, atomic_logical_kind
-  implicit none
+  implicit none(external, type)
 
   integer(kind=atomic_int_kind) :: scalar_coarray[*], non_scalar_coarray(10)[*], val, non_coarray
   integer(kind=atomic_int_kind) :: repeated_atom[*], repeated_val, array(10)
@@ -64,16 +64,16 @@ program test_atomic_define
   !ERROR: 'atom=' argument must be a scalar coarray or coindexed object for intrinsic 'atomic_define'
   call atomic_define(array, val)
 
-  !ERROR: Actual argument for 'atom=' must have kind=atomic_int_kind or atomic_logical_kind, but is 'INTEGER(4)'
+  !ERROR: Actual argument for 'atom=' must have kind=atomic_int_kind, but is 'INTEGER(4)'
   call atomic_define(default_kind_coarray, val)
 
-  !ERROR: Actual argument for 'atom=' must have kind=atomic_int_kind or atomic_logical_kind, but is 'INTEGER(1)'
+  !ERROR: Actual argument for 'atom=' must have kind=atomic_int_kind, but is 'INTEGER(1)'
   call atomic_define(kind1_coarray, val)
 
-  !ERROR: Actual argument for 'atom=' must have kind=atomic_int_kind or atomic_logical_kind, but is 'LOGICAL(4)'
+  !ERROR: Actual argument for 'atom=' must have kind=atomic_logical_kind, but is 'LOGICAL(4)'
   call atomic_define(default_kind_logical_coarray, val_logical)
 
-  !ERROR: Actual argument for 'atom=' must have kind=atomic_int_kind or atomic_logical_kind, but is 'LOGICAL(1)'
+  !ERROR: Actual argument for 'atom=' must have kind=atomic_logical_kind, but is 'LOGICAL(1)'
   call atomic_define(kind1_logical_coarray, val_logical)
 
   !ERROR: 'value=' argument to 'atomic_define' must have same type as 'atom=', but is 'LOGICAL(8)'

flang/test/Semantics/atomic05.f90

@@ -4,7 +4,7 @@
 
 program test_atomic_fetch_add
   use iso_fortran_env, only: atomic_int_kind, atomic_logical_kind
-  implicit none
+  implicit none(external, type)
 
   integer(kind=atomic_int_kind) :: scalar_coarray[*], non_scalar_coarray(10)[*], val, old_val, non_coarray
   integer(kind=atomic_int_kind) :: repeated_atom[*], repeated_old, repeated_val, array(10)

flang/test/Semantics/atomic06.f90

@@ -4,7 +4,7 @@
 
 program test_atomic_fetch_and
   use iso_fortran_env, only: atomic_int_kind, atomic_logical_kind
-  implicit none
+  implicit none(external, type)
 
   integer(kind=atomic_int_kind) :: scalar_coarray[*], non_scalar_coarray(10)[*], val, old_val, non_coarray
   integer(kind=atomic_int_kind) :: repeated_atom[*], repeated_old, repeated_val, array(10)

flang/test/Semantics/atomic07.f90

@@ -4,7 +4,7 @@
 
 program test_atomic_fetch_or
   use iso_fortran_env, only: atomic_int_kind
-  implicit none
+  implicit none(external, type)
 
   integer(kind=atomic_int_kind) :: scalar_coarray[*], non_scalar_coarray(10)[*], val, old_val, non_coarray
   integer(kind=atomic_int_kind) :: repeated_atom[*], repeated_old, repeated_val, array(10), val_coarray[*], old_val_coarray[*]

flang/test/Semantics/atomic08.f90

@@ -4,7 +4,7 @@
 
 program test_atomic_fetch_xor
   use iso_fortran_env, only: atomic_int_kind, atomic_logical_kind
-  implicit none
+  implicit none(external, type)
 
   integer(kind=atomic_int_kind) :: scalar_coarray[*], non_scalar_coarray(10)[*], val, old_val, non_coarray
   integer(kind=atomic_int_kind) :: repeated_atom[*], repeated_old, repeated_val, array(10)

flang/test/Semantics/atomic09.f90

@@ -4,7 +4,7 @@
 
 program test_atomic_or
   use iso_fortran_env, only: atomic_int_kind, atomic_logical_kind
-  implicit none
+  implicit none(external, type)
 
   integer(kind=atomic_int_kind) :: scalar_coarray[*], non_scalar_coarray(10)[*], val, non_coarray
   integer(kind=atomic_int_kind) :: repeated_atom[*], repeated_val, array(10)

flang/test/Semantics/atomic10.f90

@@ -4,7 +4,7 @@
 
 program test_atomic_ref
   use iso_fortran_env, only: atomic_int_kind, atomic_logical_kind
-  implicit none
+  implicit none(external, type)
 
   integer(kind=atomic_int_kind) :: scalar_coarray[*], non_scalar_coarray(10)[*], val, non_coarray
   integer(kind=atomic_int_kind) :: repeated_atom[*], repeated_val, array(10)
@@ -64,16 +64,16 @@ program test_atomic_ref
   !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)'
+  !ERROR: Actual argument for 'atom=' must have kind=atomic_int_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)'
+  !ERROR: Actual argument for 'atom=' must have kind=atomic_int_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)'
+  !ERROR: Actual argument for 'atom=' must have kind=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)'
+  !ERROR: Actual argument for 'atom=' must have kind=atomic_logical_kind, but is 'LOGICAL(1)'
   call atomic_ref(val_logical, kind1_logical_coarray)
 
   !ERROR: 'value=' argument to 'atomic_ref' must have same type as 'atom=', but is 'LOGICAL(8)'

flang/test/Semantics/atomic11.f90

@@ -4,7 +4,7 @@
 
 program test_atomic_xor
   use iso_fortran_env, only: atomic_int_kind, atomic_logical_kind
-  implicit none
+  implicit none(external, type)
 
   integer(kind=atomic_int_kind) :: scalar_coarray[*], non_scalar_coarray(10)[*], val, non_coarray
   integer(kind=atomic_int_kind) :: repeated_atom[*], repeated_val, array(10)