From efeff077c8e790b9c651b1d5a5463ff60244bbae Mon Sep 17 00:00:00 2001 From: Peter Klausler Date: Tue, 14 Jan 2025 16:37:05 -0800 Subject: [PATCH] [flang] Define ATOMIC_ADD as an intrinsic procedure 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. --- flang/lib/Evaluate/intrinsics.cpp | 40 ++++++++++++++++++------------- flang/test/Semantics/atomic01.f90 | 28 +++++++++++++++++----- flang/test/Semantics/atomic02.f90 | 2 +- flang/test/Semantics/atomic03.f90 | 10 ++++---- flang/test/Semantics/atomic04.f90 | 10 ++++---- flang/test/Semantics/atomic05.f90 | 2 +- flang/test/Semantics/atomic06.f90 | 2 +- flang/test/Semantics/atomic07.f90 | 2 +- flang/test/Semantics/atomic08.f90 | 2 +- flang/test/Semantics/atomic09.f90 | 2 +- flang/test/Semantics/atomic10.f90 | 10 ++++---- flang/test/Semantics/atomic11.f90 | 2 +- 12 files changed, 67 insertions(+), 45 deletions(-) diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp index f234241cfe14a..77d37d40bbddc 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 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 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 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 046692e87c4ad..cf3804b0d605a 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 10a7c126dbb6d..484239a23ede2 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 9bb1d1c0df6b1..495df5eb97192 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 f065bf6404f1a..9df0b56d192a8 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 04c29cdd6046b..98d6b19b1f23d 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 e6307d129262e..c6a23dd0077ca 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 0ac7ad152e86b..2bc544b757864 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 a08512f1c7fe8..f519f9735e00e 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 fc09724d53bc0..e4e062252659a 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 46fcf537f1810..04efbd6e80fd2 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 1c50825e5541f..d4f951ea02c32 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)