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 @@ -91,6 +91,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 { @@ -176,6 +177,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, @@ -186,6 +189,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 @@ -1087,6 +1091,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_broadcast", {{"a", AnyData, Rank::anyOrAssumedRank, Optionality::required, common::Intent::InOut}, @@ -1252,6 +1266,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, @@ -1523,6 +1564,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; } @@ -1606,6 +1657,15 @@ return std::nullopt; } break; + case Rank::atom: + argOk = rank == 0 && (IsCoarray(*arg) || ExtractCoarrayRef(*arg)); + 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; @@ -1858,6 +1918,7 @@ case Rank::shape: case Rank::array: case Rank::coarray: + case Rank::atom: case Rank::known: case Rank::anyOrAssumedRank: case Rank::reduceOperation: @@ -2482,6 +2543,8 @@ } } else if (name == "associated") { return CheckAssociated(call, context); + } 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")}; diff --git a/flang/module/__fortran_builtins.f90 b/flang/module/__fortran_builtins.f90 --- a/flang/module/__fortran_builtins.f90 +++ b/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, & diff --git a/flang/module/iso_fortran_env.f90 b/flang/module/iso_fortran_env.f90 --- a/flang/module/iso_fortran_env.f90 +++ b/flang/module/iso_fortran_env.f90 @@ -16,13 +16,12 @@ use __Fortran_builtins, only: & event_type => __builtin_event_type, & lock_type => __builtin_lock_type, & - team_type => __builtin_team_type + team_type => __builtin_team_type, & + atomic_int_kind => __builtin_atomic_int_kind, & + atomic_logical_kind => __builtin_atomic_logical_kind implicit none - integer, parameter :: atomic_int_kind = selected_int_kind(18) - integer, parameter :: atomic_logical_kind = atomic_int_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. diff --git a/flang/test/Semantics/atomic07.f90 b/flang/test/Semantics/atomic07.f90 --- a/flang/test/Semantics/atomic07.f90 +++ b/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. @@ -8,8 +7,9 @@ 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(kind=atomic_int_kind) :: repeated_atom[*], repeated_old, repeated_val, array(10), val_coarray[*], old_val_coarray[*] + 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 @@ -24,15 +24,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) @@ -66,8 +69,12 @@ !ERROR: 'stat=' argument has unacceptable rank 1 call atomic_fetch_or(scalar_coarray, val, old_val, status_array) + !ERROR: 'stat' argument to 'atomic_fetch_or' may not be a coindexed object call atomic_fetch_or(scalar_coarray, val, old_val, coindexed_status[1]) + !ERROR: 'stat' argument to 'atomic_fetch_or' may not be a coindexed object + call atomic_fetch_or(scalar_coarray[1], val_coarray[1], old_val_coarray[1], coindexed_status[1]) + !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'stat=' must be definable call atomic_fetch_or(scalar_coarray, val, old_val, 1) @@ -120,7 +127,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)