Index: flang/docs/Intrinsics.md =================================================================== --- flang/docs/Intrinsics.md +++ flang/docs/Intrinsics.md @@ -746,7 +746,7 @@ | Intrinsic Category | Intrinsic Procedures Lacking Support | | --- | --- | -| Coarray intrinsic functions | LCOBOUND, UCOBOUND, FAILED_IMAGES, GET_TEAM, IMAGE_INDEX, STOPPED_IMAGES, TEAM_NUMBER, THIS_IMAGE, COSHAPE | +| Coarray intrinsic functions | LCOBOUND, UCOBOUND, FAILED_IMAGES, GET_TEAM, IMAGE_INDEX, STOPPED_IMAGES, THIS_IMAGE, COSHAPE | | Object characteristic inquiry functions | ALLOCATED, ASSOCIATED, EXTENDS_TYPE_OF, IS_CONTIGUOUS, PRESENT, RANK, SAME_TYPE, STORAGE_SIZE | | Type inquiry intrinsic functions | BIT_SIZE, DIGITS, EPSILON, HUGE, KIND, MAXEXPONENT, MINEXPONENT, NEW_LINE, PRECISION, RADIX, RANGE, TINY| | Non-standard intrinsic functions | AND, OR, XOR, LSHIFT, RSHIFT, SHIFT, ZEXT, IZEXT, COSD, SIND, TAND, ACOSD, ASIND, ATAND, ATAN2D, COMPL, DCMPLX, EQV, NEQV, INT8, JINT, JNINT, KNINT, LOC, QCMPLX, DREAL, DFLOAT, QEXT, QFLOAT, QREAL, DNUM, NUM, JNUM, KNUM, QNUM, RNUM, RAN, RANF, ILEN, SIZEOF, MCLOCK, SECNDS, COTAN, IBCHNG, ISHA, ISHC, ISHL, IXOR, IARG, IARGC, NARGS, NUMARG, BADDRESS, IADDR, CACHESIZE, EOF, FP_CLASS, INT_PTR_KIND, ISNAN, MALLOC | Index: flang/include/flang/Evaluate/type.h =================================================================== --- flang/include/flang/Evaluate/type.h +++ flang/include/flang/Evaluate/type.h @@ -129,6 +129,14 @@ return result; // TYPE(*) } + static constexpr DynamicType MissingDerivedType() { + DynamicType result; + result.category_ = TypeCategory::Derived; + result.kind_ = MissingDerivedKind; + result.derived_ = nullptr; + return result; // e.g., missing dummy team_type argument + } + // Comparison is deep -- type parameters are compared independently. bool operator==(const DynamicType &) const; bool operator!=(const DynamicType &that) const { return !(*this == that); } @@ -215,6 +223,9 @@ // argument to ASSOCIATED ClassKind = -2, // CLASS(T) or CLASS(*) AssumedTypeKind = -3, // TYPE(*) + MissingDerivedKind = -4, // kind for missing optional dummy arguments + // used to specify some intrinsic functions + // e.g., team_type in team_number }; constexpr DynamicType() {} Index: flang/lib/Evaluate/intrinsics.cpp =================================================================== --- flang/lib/Evaluate/intrinsics.cpp +++ flang/lib/Evaluate/intrinsics.cpp @@ -16,6 +16,7 @@ #include "flang/Evaluate/shape.h" #include "flang/Evaluate/tools.h" #include "flang/Evaluate/type.h" +#include "flang/Semantics/tools.h" #include "llvm/Support/raw_ostream.h" #include #include @@ -104,7 +105,7 @@ static constexpr TypePattern DefaultLogical{ LogicalType, KindCode::defaultLogicalKind}; static constexpr TypePattern BOZ{IntType, KindCode::typeless}; -static constexpr TypePattern TEAM_TYPE{IntType, KindCode::teamType}; +static constexpr TypePattern TEAM_TYPE{DerivedType, KindCode::teamType}; static constexpr TypePattern DoublePrecision{ RealType, KindCode::doublePrecision}; static constexpr TypePattern DoublePrecisionComplex{ @@ -233,6 +234,8 @@ common::Intent::In}; static constexpr IntrinsicDummyArgument OptionalMASK{"mask", AnyLogical, Rank::conformable, Optionality::optional, common::Intent::In}; +static constexpr IntrinsicDummyArgument OptionalTEAM{ + "team", TEAM_TYPE, Rank::scalar, Optionality::optional, common::Intent::In}; struct IntrinsicInterface { static constexpr int maxArguments{7}; // if not a MAX/MIN(...) @@ -739,6 +742,8 @@ {"tan", {{"x", SameFloating}}, SameFloating}, {"tand", {{"x", SameFloating}}, SameFloating}, {"tanh", {{"x", SameFloating}}, SameFloating}, + {"team_number", {OptionalTEAM}, DefaultInt, Rank::scalar, + IntrinsicClass::transformationalFunction}, {"tiny", {{"x", SameReal, Rank::anyOrAssumedRank}}, SameReal, Rank::scalar, IntrinsicClass::inquiryFunction}, {"trailz", {{"i", AnyInt}}, DefaultInt}, @@ -812,7 +817,7 @@ // TODO: Coarray intrinsic functions // LCOBOUND, UCOBOUND, FAILED_IMAGES, GET_TEAM, IMAGE_INDEX, -// STOPPED_IMAGES, TEAM_NUMBER, THIS_IMAGE, +// STOPPED_IMAGES, THIS_IMAGE, // COSHAPE // TODO: Non-standard intrinsic functions // AND, OR, XOR, LSHIFT, RSHIFT, SHIFT, ZEXT, IZEXT, @@ -1281,9 +1286,11 @@ switch (d.typePattern.kindCode) { case KindCode::none: case KindCode::typeless: - case KindCode::teamType: // TODO: TEAM_TYPE argOk = false; break; + case KindCode::teamType: + argOk = semantics::IsTeamType(GetDerivedTypeSpec(type)); + break; case KindCode::defaultIntegerKind: argOk = type->kind() == defaults.GetDefaultKind(TypeCategory::Integer); break; @@ -1678,6 +1685,11 @@ CHECK(d.optionality != Optionality::required); if (d.typePattern.kindCode == KindCode::same) { dummyArgs.emplace_back(dummyArgs[sameDummyArg.value()]); + } else if (d.typePattern.kindCode == KindCode::teamType) { + characteristics::TypeAndShape typeAndShape{ + DynamicType::MissingDerivedType()}; + dummyArgs.emplace_back(std::string{d.keyword}, + characteristics::DummyDataObject{std::move(typeAndShape)}); } else { auto category{d.typePattern.categorySet.LeastElement().value()}; characteristics::TypeAndShape typeAndShape{ Index: flang/test/Semantics/team_number.f90 =================================================================== --- /dev/null +++ flang/test/Semantics/team_number.f90 @@ -0,0 +1,21 @@ +! RUN: %S/test_errors.sh %s %t %flang_fc1 +! Check for semantic errors in team_number() function calls + +subroutine test + use, intrinsic :: iso_fortran_env, only: team_type + type(team_type) :: oregon + + ! correct calls, should produce no errors + print *, team_number() + print *, team_number(oregon) + print *, team_number(team=oregon) + + ! call with too many arguments + !ERROR: too many actual arguments for intrinsic 'team_number' + print *, team_number(1, 3) + + ! keyword argument with incorrect type + !ERROR: Actual argument for 'team=' has bad type 'REAL(4)' + print *, team_number(team=3.1415) + +end subroutine Index: flang/unittests/Evaluate/intrinsics.cpp =================================================================== --- flang/unittests/Evaluate/intrinsics.cpp +++ flang/unittests/Evaluate/intrinsics.cpp @@ -156,6 +156,8 @@ using Complex8 = Type; using Char = Type; using Log4 = Type; + // For testing team arguments (fails to compile) + // using Team = Type; TestCall{defaults, table, "bad"} .Push(Const(Scalar{})) @@ -292,6 +294,36 @@ .Push(Const(Scalar{})) .DoCall(); // bad type + TestCall{defaults, table, "team_number"} + .DoCall(Int4::GetType()); + TestCall{defaults, table, "team_number"} + .Push(Const(Scalar{})) + .Push(Const(Scalar{})) + .DoCall(); // too many args + TestCall{defaults, table, "team_number"} + .Push(Named("bad", Const(Scalar{}))) + .DoCall(); // bad keyword + TestCall{defaults, table, "team_number"} + .Push(Const(Scalar{})) + .DoCall(); // bad type + TestCall{defaults, table, "team_number"} + .Push(Const(Scalar{})) + .DoCall(); // bad type + TestCall{defaults, table, "team_number"} + .Push(Const(Scalar{})) + .DoCall(); // bad type + TestCall{defaults, table, "team_number"} + .Push(Const(Scalar{})) + .DoCall(); // bad type + TestCall{defaults, table, "team_number"} + .Push(Const(Scalar{})) + .DoCall(); // bad type + + // TODO: test TEAM argument + // TestCall{defaults, table, "team_number"} + // .Push(Const(Scalar{})) + // .DoCall(Int4::GetType()); + // TODO: test other intrinsics // Test unrestricted specific to generic name mapping (table 16.2).