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/Common/default-kinds.h =================================================================== --- flang/include/flang/Common/default-kinds.h +++ flang/include/flang/Common/default-kinds.h @@ -56,6 +56,7 @@ int quadPrecisionKind_{2 * doublePrecisionKind_}; int defaultCharacterKind_{1}; int defaultLogicalKind_{defaultIntegerKind_}; + int derivedKind_{4}; }; } // namespace Fortran::common #endif // FORTRAN_COMMON_DEFAULT_KINDS_H_ Index: flang/include/flang/Evaluate/type.h =================================================================== --- flang/include/flang/Evaluate/type.h +++ flang/include/flang/Evaluate/type.h @@ -70,8 +70,8 @@ return kind == 1 || kind == 2 || kind == 4; case TypeCategory::Logical: return kind == 1 || kind == 2 || kind == 4 || kind == 8; - default: - return false; + case TypeCategory::Derived: + return true; } } Index: flang/lib/Common/default-kinds.cpp =================================================================== --- flang/lib/Common/default-kinds.cpp +++ flang/lib/Common/default-kinds.cpp @@ -76,9 +76,8 @@ return defaultCharacterKind_; case TypeCategory::Logical: return defaultLogicalKind_; - default: - CRASH_NO_CASE; - return 0; + case TypeCategory::Derived: + return derivedKind_; } } } // namespace Fortran::common 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, @@ -1283,9 +1288,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; 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 %f18 +! 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 + // using Team = Type; TestCall{defaults, table, "bad"} .Push(Const(Scalar{})) @@ -292,6 +294,35 @@ .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).