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 @@ -66,6 +66,7 @@ static constexpr CategorySet LogicalType{TypeCategory::Logical}; static constexpr CategorySet IntOrRealType{IntType | RealType}; static constexpr CategorySet IntOrRealOrCharType{IntType | RealType | CharType}; +static constexpr CategorySet IntOrLogicalType{IntType | LogicalType}; static constexpr CategorySet FloatingType{RealType | ComplexType}; static constexpr CategorySet NumericType{IntType | RealType | ComplexType}; static constexpr CategorySet RelatableType{IntType | RealType | CharType}; @@ -96,6 +97,7 @@ nullPointerType, // for ASSOCIATED(NULL()) exactKind, // a single explicit exactKindValue atomicIntKind, // atomic_int_kind from iso_fortran_env + atomicIntOrLogicalKind, // atomic_int_kind or atomic_logical_kind sameAtom, // same type and kind as atom ) @@ -130,6 +132,7 @@ static constexpr TypePattern AnyIntOrReal{IntOrRealType, KindCode::any}; static constexpr TypePattern AnyIntOrRealOrChar{ IntOrRealOrCharType, KindCode::any}; +static constexpr TypePattern AnyIntOrLogical{IntOrLogicalType, KindCode::any}; static constexpr TypePattern AnyComplex{ComplexType, KindCode::any}; static constexpr TypePattern AnyFloating{FloatingType, KindCode::any}; static constexpr TypePattern AnyNumeric{NumericType, KindCode::any}; @@ -185,8 +188,9 @@ static constexpr TypePattern KINDLogical{LogicalType, KindCode::effectiveKind}; static constexpr TypePattern AtomicInt{IntType, KindCode::atomicIntKind}; -static constexpr TypePattern SameAtom{ - IntType | LogicalType, KindCode::sameAtom}; +static constexpr TypePattern AtomicIntOrLogical{ + IntOrLogicalType, KindCode::atomicIntOrLogicalKind}; +static constexpr TypePattern SameAtom{IntOrLogicalType, KindCode::sameAtom}; // The default rank pattern for dummy arguments and function results is // "elemental". @@ -1112,6 +1116,14 @@ {"stat", AnyInt, Rank::scalar, Optionality::optional, common::Intent::Out}}, {}, Rank::elemental, IntrinsicClass::atomicSubroutine}, + {"atomic_define", + {{"atom", AtomicIntOrLogical, Rank::atom, Optionality::required, + common::Intent::Out}, + {"value", AnyIntOrLogical, Rank::scalar, Optionality::required, + common::Intent::In}, + {"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}, @@ -1122,6 +1134,14 @@ {"stat", AnyInt, Rank::scalar, Optionality::optional, common::Intent::Out}}, {}, Rank::elemental, IntrinsicClass::atomicSubroutine}, + {"atomic_ref", + {{"value", AnyIntOrLogical, Rank::scalar, Optionality::required, + common::Intent::Out}, + {"atom", AtomicIntOrLogical, Rank::atom, Optionality::required, + common::Intent::In}, + {"stat", AnyInt, Rank::scalar, Optionality::optional, + common::Intent::Out}}, + {}, Rank::elemental, IntrinsicClass::atomicSubroutine}, {"co_broadcast", {{"a", AnyData, Rank::anyOrAssumedRank, Optionality::required, common::Intent::InOut}, @@ -1635,6 +1655,11 @@ return std::nullopt; } break; + case KindCode::atomicIntOrLogicalKind: + argOk = CheckAtomicKind(DEREF(arg), builtinsScope, messages); + if (!argOk) + return std::nullopt; + break; default: CRASH_NO_CASE; } @@ -2592,6 +2617,26 @@ return ok; } +static bool CheckAtomicDefineAndRef(FoldingContext &context, + const std::optional &atomArg, + const std::optional &valueArg, + const std::optional &statArg, const std::string &procName) { + bool sameType{true}; + if (valueArg && atomArg) { + // for atomic_define and atomic_ref, 'value' arg must be the same type as + // 'atom', but it doesn't have to be the same kind + if (valueArg->GetType()->category() != atomArg->GetType()->category()) { + sameType = false; + context.messages().Say(valueArg->sourceLocation(), + "'value=' argument to '%s' must have same type as 'atom=', but is '%s'"_err_en_US, + procName, valueArg->GetType()->AsFortran()); + } + } + + return sameType && + CheckForCoindexedObject(context, statArg, procName, "stat"); +} + // Applies any semantic checks peculiar to an intrinsic. static bool ApplySpecificChecks(SpecificCall &call, FoldingContext &context) { bool ok{true}; @@ -2612,8 +2657,14 @@ return CheckAssociated(call, context); } else if (name == "atomic_cas") { return CheckForCoindexedObject(context, call.arguments[4], name, "stat"); + } else if (name == "atomic_define") { + return CheckAtomicDefineAndRef( + context, call.arguments[0], call.arguments[1], call.arguments[2], name); } else if (name == "atomic_fetch_or") { return CheckForCoindexedObject(context, call.arguments[3], name, "stat"); + } else if (name == "atomic_ref") { + return CheckAtomicDefineAndRef( + context, call.arguments[1], call.arguments[0], call.arguments[2], name); } 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/test/Semantics/atomic04.f90 b/flang/test/Semantics/atomic04.f90 --- a/flang/test/Semantics/atomic04.f90 +++ b/flang/test/Semantics/atomic04.f90 @@ -1,5 +1,4 @@ ! RUN: %python %S/test_errors.py %s %flang_fc1 -! XFAIL: * ! This test checks for semantic errors in atomic_define subroutine calls based on ! the interface defined in section 16.9.23 of the Fortran 2018 standard. @@ -44,37 +43,43 @@ !___ non-standard-conforming calls ___ - !ERROR: 'atom=' argument must be a scalar coarray for intrinsic 'atomic_define' + !ERROR: 'atom=' argument must be a scalar coarray or coindexed object for intrinsic 'atomic_define' call atomic_define(non_scalar_coarray, val) - !ERROR: 'atom=' argument must be a scalar coarray for intrinsic 'atomic_define' + !ERROR: 'atom=' argument must be a scalar coarray or coindexed object for intrinsic 'atomic_define' + call atomic_define(non_scalar_coarray[1], val) + + !ERROR: 'atom=' argument must be a scalar coarray or coindexed object for intrinsic 'atomic_define' call atomic_define(non_scalar_logical_coarray, val_logical) - !ERROR: 'atom=' argument must be a coarray or a coindexed object for intrinsic 'atomic_define' + !ERROR: 'atom=' argument must be a scalar coarray or coindexed object for intrinsic 'atomic_define' + call atomic_define(non_scalar_logical_coarray[1], val_logical) + + !ERROR: 'atom=' argument must be a scalar coarray or coindexed object for intrinsic 'atomic_define' call atomic_define(non_coarray, val) - !ERROR: 'atom=' argument must be a coarray or a coindexed object for intrinsic 'atomic_define' + !ERROR: 'atom=' argument must be a scalar coarray or coindexed object for intrinsic 'atomic_define' call atomic_define(non_coarray_logical, val_logical) - !ERROR: 'atom=' argument must be a coarray or a coindexed object for intrinsic 'atomic_define' + !ERROR: 'atom=' argument must be a scalar coarray or coindexed object for intrinsic 'atomic_define' call atomic_define(array, val) - ! 'atom=' argument not of 'atomic_int_kind' or 'atomic_logical_kind' + !ERROR: Actual argument for 'atom=' must have kind=atomic_int_kind or atomic_logical_kind, but is 'INTEGER(4)' call atomic_define(default_kind_coarray, val) - ! 'atom=' argument not of 'atomic_int_kind' or 'atomic_logical_kind' + !ERROR: Actual argument for 'atom=' must have kind=atomic_int_kind or atomic_logical_kind, but is 'INTEGER(1)' call atomic_define(kind1_coarray, val) - ! 'atom=' argument not of 'atomic_int_kind' or 'atomic_logical_kind' + !ERROR: Actual argument for 'atom=' must have kind=atomic_int_kind or atomic_logical_kind, but is 'LOGICAL(4)' call atomic_define(default_kind_logical_coarray, val_logical) - ! 'atom=' argument not of 'atomic_int_kind' or 'atomic_logical_kind' + !ERROR: Actual argument for 'atom=' must have kind=atomic_int_kind or atomic_logical_kind, but is 'LOGICAL(1)' call atomic_define(kind1_logical_coarray, val_logical) - ! 'value=' argument not same type as 'atom=' argument + !ERROR: 'value=' argument to 'atomic_define' must have same type as 'atom=', but is 'LOGICAL(8)' call atomic_define(scalar_coarray, val_logical) - ! 'value=' argument not same type as 'atom=' argument + !ERROR: 'value=' argument to 'atomic_define' must have same type as 'atom=', but is 'INTEGER(8)' call atomic_define(atom_logical, val) !ERROR: Actual argument for 'atom=' has bad type 'REAL(4)' @@ -95,7 +100,7 @@ !ERROR: 'stat=' argument has unacceptable rank 1 call atomic_define(scalar_coarray, val, status_array) - ! status shall not be coindexed + !ERROR: 'stat' argument to 'atomic_define' may not be a coindexed object call atomic_define(scalar_coarray, val, coindexed_status[1]) !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'stat=' must be definable diff --git a/flang/test/Semantics/atomic10.f90 b/flang/test/Semantics/atomic10.f90 --- a/flang/test/Semantics/atomic10.f90 +++ b/flang/test/Semantics/atomic10.f90 @@ -1,5 +1,4 @@ ! RUN: %python %S/test_errors.py %s %flang_fc1 -! XFAIL: * ! This test checks for semantic errors in atomic_ref subroutine calls based on ! the interface defined in section 16.9.29 of the Fortran 2018 standard. @@ -47,9 +46,15 @@ !ERROR: 'atom=' argument must be a scalar coarray or coindexed object for intrinsic 'atomic_ref' call atomic_ref(val, non_scalar_coarray) + !ERROR: 'atom=' argument must be a scalar coarray or coindexed object for intrinsic 'atomic_ref' + call atomic_ref(val, non_scalar_coarray[1]) + !ERROR: 'atom=' argument must be a scalar coarray or coindexed object for intrinsic 'atomic_ref' call atomic_ref(val_logical, non_scalar_logical_coarray) + !ERROR: 'atom=' argument must be a scalar coarray or coindexed object for intrinsic 'atomic_ref' + call atomic_ref(val_logical, non_scalar_logical_coarray[1]) + !ERROR: 'atom=' argument must be a scalar coarray or coindexed object for intrinsic 'atomic_ref' call atomic_ref(val, non_coarray) @@ -71,10 +76,10 @@ !ERROR: Actual argument for 'atom=' must have kind=atomic_int_kind or atomic_logical_kind, but is 'LOGICAL(1)' call atomic_ref(val_logical, kind1_logical_coarray) - !ERROR: Actual argument for 'value=' must have same type as 'atom=', but is 'LOGICAL(8)' + !ERROR: 'value=' argument to 'atomic_ref' must have same type as 'atom=', but is 'LOGICAL(8)' call atomic_ref(val_logical, scalar_coarray) - !ERROR: Actual argument for 'value=' must have same type as 'atom=', but is 'INTEGER(8)' + !ERROR: 'value=' argument to 'atomic_ref' must have same type as 'atom=', but is 'INTEGER(8)' call atomic_ref(val, atom_logical) !ERROR: Actual argument for 'atom=' has bad type 'REAL(4)'