Index: flang/lib/Evaluate/intrinsics.cpp =================================================================== --- flang/lib/Evaluate/intrinsics.cpp +++ flang/lib/Evaluate/intrinsics.cpp @@ -90,6 +90,7 @@ 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 ) struct TypePattern { @@ -173,6 +174,8 @@ static constexpr TypePattern KINDChar{CharType, KindCode::effectiveKind}; static constexpr TypePattern KINDLogical{LogicalType, KindCode::effectiveKind}; +static constexpr TypePattern AtomicInt{IntType, KindCode::atomicIntKind}; + // The default rank pattern for dummy arguments and function results is // "elemental". ENUM_CLASS(Rank, @@ -183,6 +186,7 @@ matrix, array, // not scalar, rank is known and greater than zero coarray, // rank is known and can be scalar; has nonzero corank + atom, // is scalar and has nonzero corank or is coindexed known, // rank is known and can be scalar anyOrAssumedRank, // rank can be unknown; assumed-type TYPE(*) allowed conformable, // scalar, or array of same rank & shape as "array" argument @@ -1084,6 +1088,16 @@ static const IntrinsicInterface intrinsicSubroutine[]{ {"abort", {}, {}, Rank::elemental, IntrinsicClass::impureSubroutine}, + {"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}, {"co_sum", {{"a", AnyNumeric, Rank::anyOrAssumedRank, Optionality::required, common::Intent::InOut}, @@ -1219,6 +1233,33 @@ return DynamicType{derived}; } +static std::int64_t GetBuiltinKind( + const semantics::Scope *builtinsScope, const char *which) { + if (!builtinsScope) { + common::die("INTERNAL: The __fortran_builtins module was not found, and " + "the kind '%s' was required", + which); + } + auto iter{ + builtinsScope->find(semantics::SourceName{which, std::strlen(which)})}; + if (iter == builtinsScope->cend()) { + common::die( + "INTERNAL: The __fortran_builtins module does not define the kind '%s'", + which); + } + const semantics::Symbol &symbol{*iter->second}; + const auto &details{ + DEREF(symbol.detailsIf())}; + if (const auto kind{ToInt64(details.init())}) { + return *kind; + } else { + common::die( + "INTERNAL: The __fortran_builtins module does not define the kind '%s'", + which); + return -1; + } +} + // Ensure that the keywords of arguments to MAX/MIN and their variants // are of the form A123 with no duplicates or leading zeroes. static bool CheckMaxMinArgument(std::optional keyword, @@ -1490,6 +1531,16 @@ case KindCode::exactKind: argOk = type->kind() == d.typePattern.exactKindValue; 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; + } + break; default: CRASH_NO_CASE; } @@ -1573,6 +1624,19 @@ return std::nullopt; } break; + case Rank::atom: + if (rank == 0) { + argOk = IsCoarray(*arg) || ExtractCoarrayRef(*arg); + } else { + argOk = false; + } + if (!argOk) { + messages.Say(arg->sourceLocation(), + "'%s=' argument must be a scalar coarray or coindexed object for intrinsic '%s'"_err_en_US, + d.keyword, name); + return std::nullopt; + } + break; case Rank::known: if (!knownArg) { knownArg = arg; @@ -1825,6 +1889,7 @@ case Rank::shape: case Rank::array: case Rank::coarray: + case Rank::atom: case Rank::known: case Rank::anyOrAssumedRank: case Rank::reduceOperation: Index: flang/module/__fortran_builtins.f90 =================================================================== --- flang/module/__fortran_builtins.f90 +++ flang/module/__fortran_builtins.f90 @@ -39,6 +39,9 @@ integer(kind=int64) :: __id end type + integer, parameter :: __builtin_atomic_int_kind = selected_int_kind(18) + integer, parameter :: __builtin_atomic_logical_kind = __builtin_atomic_int_kind + procedure(type(__builtin_c_ptr)) :: __builtin_c_loc intrinsic :: __builtin_ieee_is_nan, __builtin_ieee_is_negative, & Index: flang/module/iso_fortran_env.f90 =================================================================== --- flang/module/iso_fortran_env.f90 +++ flang/module/iso_fortran_env.f90 @@ -16,12 +16,14 @@ use __Fortran_builtins, only: & event_type => __builtin_event_type, & lock_type => __builtin_lock_type, & - team_type => __builtin_team_type + team_type => __builtin_team_type, & + __builtin_atomic_int_kind, & + __builtin_atomic_logical_kind implicit none - integer, parameter :: atomic_int_kind = selected_int_kind(18) - integer, parameter :: atomic_logical_kind = atomic_int_kind + integer, parameter :: atomic_int_kind = __builtin_atomic_int_kind + integer, parameter :: atomic_logical_kind = __builtin_atomic_logical_kind ! TODO: Use PACK([x],test) in place of the array constructor idiom ! [(x, integer::j=1,COUNT([test]))] below once PACK() can be folded. Index: flang/test/Semantics/atomic07.f90 =================================================================== --- flang/test/Semantics/atomic07.f90 +++ flang/test/Semantics/atomic07.f90 @@ -1,5 +1,4 @@ ! RUN: %python %S/test_errors.py %s %flang_fc1 -! XFAIL: * ! This test checks for semantic errors in atomic_fetch_or subroutine calls based on ! the interface defined in section 16.9.26 of the Fortran 2018 standard. @@ -24,15 +23,18 @@ !___ non-standard-conforming calls ___ - !ERROR: 'atom=' argument must be a scalar coarray for intrinsic 'atomic_fetch_or' + !ERROR: 'atom=' argument must be a scalar coarray or coindexed object for intrinsic 'atomic_fetch_or' call atomic_fetch_or(non_scalar_coarray, val, old_val) - !ERROR: 'atom=' argument must be a coarray or a coindexed object for intrinsic 'atomic_fetch_or' + !ERROR: 'atom=' argument must be a scalar coarray or coindexed object for intrinsic 'atomic_fetch_or' call atomic_fetch_or(non_coarray, val, old_val) - !ERROR: 'atom=' argument must be a coarray or a coindexed object for intrinsic 'atomic_fetch_or' + !ERROR: 'atom=' argument must be a scalar coarray or coindexed object for intrinsic 'atomic_fetch_or' call atomic_fetch_or(array, val, old_val) + !ERROR: 'atom=' argument must be a scalar coarray or coindexed object for intrinsic 'atomic_fetch_or' + call atomic_fetch_or(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_or(default_kind_coarray, val, old_val) @@ -120,7 +122,7 @@ call atomic_fetch_or(scalar_coarray, val, old_val, atom=repeated_atom) !ERROR: keyword argument to intrinsic 'atomic_fetch_or' was supplied positionally by an earlier actual argument - call atomic_fetch_or(scalar_coarray, val, old_val, val=repeated_val) + call atomic_fetch_or(scalar_coarray, val, old_val, value=repeated_val) !ERROR: keyword argument to intrinsic 'atomic_fetch_or' was supplied positionally by an earlier actual argument call atomic_fetch_or(scalar_coarray, val, old_val, status, stat=repeated_status)