diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp --- a/flang/lib/Evaluate/intrinsics.cpp +++ b/flang/lib/Evaluate/intrinsics.cpp @@ -1134,6 +1134,16 @@ {"stat", AnyInt, Rank::scalar, Optionality::optional, common::Intent::Out}}, {}, Rank::elemental, IntrinsicClass::atomicSubroutine}, + {"atomic_fetch_and", + {{"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_fetch_or", {{"atom", AtomicInt, Rank::atom, Optionality::required, common::Intent::InOut}, @@ -2670,7 +2680,8 @@ } else if (name == "atomic_define") { return CheckAtomicDefineAndRef( context, call.arguments[0], call.arguments[1], call.arguments[2], name); - } else if (name == "atomic_fetch_add" || name == "atomic_fetch_or") { + } else if (name == "atomic_fetch_add" || name == "atomic_fetch_and" || + name == "atomic_fetch_or") { return CheckForCoindexedObject(context, call.arguments[3], name, "stat"); } else if (name == "atomic_ref") { return CheckAtomicDefineAndRef( diff --git a/flang/test/Semantics/atomic06.f90 b/flang/test/Semantics/atomic06.f90 --- a/flang/test/Semantics/atomic06.f90 +++ b/flang/test/Semantics/atomic06.f90 @@ -1,18 +1,19 @@ ! RUN: %python %S/test_errors.py %s %flang_fc1 -! XFAIL: * ! This test checks for semantic errors in atomic_fetch_and subroutine calls based on ! the interface defined in section 16.9.25 of the Fortran 2018 standard. program test_atomic_fetch_and - use iso_fortran_env, only: atomic_int_kind + 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, old_val, non_coarray integer(kind=atomic_int_kind) :: repeated_atom[*], repeated_old, repeated_val, array(10) - integer :: status, default_kind_coarray[*], not_same_kind_as_atom, coindexed_status[*], extra_arg, repeated_status, status_array(10) + integer :: status, default_kind_coarray[*], not_same_kind_as_atom, coindexed_status[*] + integer :: extra_arg, repeated_status, status_array(10) integer(kind=1) :: kind1_coarray[*] real :: non_integer_coarray[*], not_same_type_as_atom logical :: non_integer + logical(kind=atomic_logical_kind) :: atomic_logical[*], old_logical !___ standard-conforming calls ___ call atomic_fetch_and(scalar_coarray, val, old_val) @@ -24,15 +25,24 @@ !___ non-standard-conforming calls ___ - !ERROR: 'atom=' argument must be a scalar coarray for intrinsic 'atomic_fetch_and' + !ERROR: Actual argument for 'atom=' has bad type 'LOGICAL(8)' + call atomic_fetch_and(atomic_logical, val, old_logical) + + !ERROR: Actual argument for 'old=' has bad type 'LOGICAL(8)' + call atomic_fetch_and(scalar_coarray, val, old_logical) + + !ERROR: 'atom=' argument must be a scalar coarray or coindexed object for intrinsic 'atomic_fetch_and' call atomic_fetch_and(non_scalar_coarray, val, old_val) - !ERROR: 'atom=' argument must be a coarray or a coindexed object for intrinsic 'atomic_fetch_and' + !ERROR: 'atom=' argument must be a scalar coarray or coindexed object for intrinsic 'atomic_fetch_and' call atomic_fetch_and(non_coarray, val, old_val) - !ERROR: 'atom=' argument must be a coarray or a coindexed object for intrinsic 'atomic_fetch_and' + !ERROR: 'atom=' argument must be a scalar coarray or coindexed object for intrinsic 'atomic_fetch_and' call atomic_fetch_and(array, val, old_val) + !ERROR: 'atom=' argument must be a scalar coarray or coindexed object for intrinsic 'atomic_fetch_and' + call atomic_fetch_and(non_scalar_coarray[1], val, old_val) + !ERROR: Actual argument for 'atom=' must have kind=atomic_int_kind, but is 'INTEGER(4)' call atomic_fetch_and(default_kind_coarray, val, old_val) @@ -66,6 +76,7 @@ !ERROR: 'stat=' argument has unacceptable rank 1 call atomic_fetch_and(scalar_coarray, val, old_val, status_array) + !ERROR: 'stat' argument to 'atomic_fetch_and' may not be a coindexed object call atomic_fetch_and(scalar_coarray, val, old_val, coindexed_status[1]) !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'stat=' must be definable