[flang] Define ATOMIC_ADD as an intrinsic procedure (#122993)

This one appears to have been omitted when other ATOMIC_xxx intrinsic
procedures were defined. There's already tests for it, but they
apparently work even when ATOMIC_ADD must be interpreted as an external
procedure with an implicit interface. Extend the tests with INTRINSIC
NONE(EXTERNAL, TYPE) statements to ensure that they require the
intrinsic interpretation.

12 files changed, 67 insertions, 45 deletions

diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp
index f234241..77d37d4 100644
--- a/flang/lib/Evaluate/intrinsics.cpp
+++ b/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") {
diff --git a/flang/test/Semantics/atomic01.f90 b/flang/test/Semantics/atomic01.f90
index 046692e..cf3804b 100644
--- a/flang/test/Semantics/atomic01.f90
+++ b/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
diff --git a/flang/test/Semantics/atomic02.f90 b/flang/test/Semantics/atomic02.f90
index 10a7c12..484239a 100644
--- a/flang/test/Semantics/atomic02.f90
+++ b/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)
diff --git a/flang/test/Semantics/atomic03.f90 b/flang/test/Semantics/atomic03.f90
index 9bb1d1c..495df5e 100644
--- a/flang/test/Semantics/atomic03.f90
+++ b/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
diff --git a/flang/test/Semantics/atomic04.f90 b/flang/test/Semantics/atomic04.f90
index f065bf6..9df0b56 100644
--- a/flang/test/Semantics/atomic04.f90
+++ b/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)'
diff --git a/flang/test/Semantics/atomic05.f90 b/flang/test/Semantics/atomic05.f90
index 04c29cd..98d6b19 100644
--- a/flang/test/Semantics/atomic05.f90
+++ b/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)
diff --git a/flang/test/Semantics/atomic06.f90 b/flang/test/Semantics/atomic06.f90
index e6307d1..c6a23dd 100644
--- a/flang/test/Semantics/atomic06.f90
+++ b/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)
diff --git a/flang/test/Semantics/atomic07.f90 b/flang/test/Semantics/atomic07.f90
index 0ac7ad1..2bc544b 100644
--- a/flang/test/Semantics/atomic07.f90
+++ b/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[*]
diff --git a/flang/test/Semantics/atomic08.f90 b/flang/test/Semantics/atomic08.f90
index a08512f..f519f97 100644
--- a/flang/test/Semantics/atomic08.f90
+++ b/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)
diff --git a/flang/test/Semantics/atomic09.f90 b/flang/test/Semantics/atomic09.f90
index fc09724..e4e0622 100644
--- a/flang/test/Semantics/atomic09.f90
+++ b/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)
diff --git a/flang/test/Semantics/atomic10.f90 b/flang/test/Semantics/atomic10.f90
index 46fcf53..04efbd6 100644
--- a/flang/test/Semantics/atomic10.f90
+++ b/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)'
diff --git a/flang/test/Semantics/atomic11.f90 b/flang/test/Semantics/atomic11.f90
index 1c50825..d4f951e 100644
--- a/flang/test/Semantics/atomic11.f90
+++ b/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)