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, TEAM_NUMBER, 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/tools.h =================================================================== --- flang/include/flang/Evaluate/tools.h +++ flang/include/flang/Evaluate/tools.h @@ -89,6 +89,22 @@ return x && IsAssumedRank(*x); } +// Predicate: true when an expression is a coarray (corank > 0) +bool IsCoarray(const ActualArgument &); +template bool IsCoarray(const A &) { return false; } +template bool IsCoarray(const Designator &designator) { + if (const auto *symbol{std::get_if(&designator.u)}) { + return symbol->get().Corank() > 0; + } + return false; +} +template bool IsCoarray(const Expr &expr) { + return std::visit([](const auto &x) { return IsCoarray(x); }, expr.u); +} +template bool IsCoarray(const std::optional &x) { + return x && IsCoarray(*x); +} + // Generalizing packagers: these take operations and expressions of more // specific types and wrap them in Expr<> containers of more abstract types. 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 @@ -176,6 +177,7 @@ shape, // INTEGER vector of known length and no negative element matrix, array, // not scalar, rank is known and greater than zero + coarray, // rank is known and can be scalar; has nonzero corank 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 @@ -741,6 +743,12 @@ {"tan", {{"x", SameFloating}}, SameFloating}, {"tand", {{"x", SameFloating}}, SameFloating}, {"tanh", {{"x", SameFloating}}, SameFloating}, + // optional team dummy arguments needed to complete the following + // this_image versions + {"this_image", {{"coarray", AnyData, Rank::coarray}, OptionalDIM}, + DefaultInt, Rank::scalar, IntrinsicClass::transformationalFunction}, + {"this_image", {}, DefaultInt, Rank::scalar, + IntrinsicClass::transformationalFunction}, {"tiny", {{"x", SameReal, Rank::anyOrAssumedRank}}, SameReal, Rank::scalar, IntrinsicClass::inquiryFunction}, {"trailz", {{"i", AnyInt}}, DefaultInt}, @@ -814,8 +822,7 @@ // TODO: Coarray intrinsic functions // LCOBOUND, UCOBOUND, FAILED_IMAGES, GET_TEAM, IMAGE_INDEX, -// STOPPED_IMAGES, TEAM_NUMBER, THIS_IMAGE, -// COSHAPE +// STOPPED_IMAGES, TEAM_NUMBER, COSHAPE // TODO: Non-standard intrinsic functions // AND, OR, XOR, LSHIFT, RSHIFT, SHIFT, ZEXT, IZEXT, // COMPL, EQV, NEQV, INT8, JINT, JNINT, KNINT, @@ -1420,6 +1427,15 @@ argOk &= rank == arrayArg->Rank(); } break; + case Rank::coarray: + argOk = IsCoarray(*arg); + if (!argOk) { + messages.Say( + "'coarray=' argument must have corank > 0 for intrinsic '%s'"_err_en_US, + name); + return std::nullopt; + } + break; case Rank::known: if (!knownArg) { knownArg = arg; @@ -1634,6 +1650,7 @@ case Rank::elementalOrBOZ: case Rank::shape: case Rank::array: + case Rank::coarray: case Rank::known: case Rank::anyOrAssumedRank: case Rank::reduceOperation: Index: flang/lib/Evaluate/tools.cpp =================================================================== --- flang/lib/Evaluate/tools.cpp +++ flang/lib/Evaluate/tools.cpp @@ -683,6 +683,13 @@ } } +bool IsCoarray(const ActualArgument &arg) { + if (const auto *expr{arg.UnwrapExpr()}) { + return IsCoarray(*expr); + } + return false; +} + bool IsProcedure(const Expr &expr) { return std::holds_alternative(expr.u); } Index: flang/test/Semantics/call10.f90 =================================================================== --- flang/test/Semantics/call10.f90 +++ flang/test/Semantics/call10.f90 @@ -184,7 +184,6 @@ pure subroutine s14 integer :: img, nimgs, i[*], tmp ! implicit sync all - !ERROR: Procedure 'this_image' referenced in pure subprogram 's14' must be pure too img = this_image() nimgs = num_images() i = img ! i is ready to use Index: flang/test/Semantics/this_image.f90 =================================================================== --- /dev/null +++ flang/test/Semantics/this_image.f90 @@ -0,0 +1,22 @@ +! RUN: %python %S/test_errors.py %s %flang_fc1 +! Check for semantic errors in this_image() function calls + +subroutine test + use, intrinsic :: iso_fortran_env, only: team_type + type(team_type) :: oregon, coteam[*] + integer :: coscalar[*], coarray(3)[*] + save :: coteam, coscalar, coarray + + ! correct calls, should produce no errors + print *, this_image() + print *, this_image(coarray) + print *, this_image(coscalar,1) + print *, this_image(coarray,1) + + !ERROR: 'coarray=' argument must have corank > 0 for intrinsic 'this_image' + print *, this_image(array,1) + + ! TODO: More complete testing requires implementation of team_type + ! actual arguments in flang/lib/Evaluate/intrinsics.cpp + +end subroutine