[flang] Make 'this_image()' an intrinsic function
Added 'this_image()' to the list of functions that are evaluated as intrinsic.
Added IsCoarray functions to determine if an expression is a coarray (corank > 1).
Added save attribute to coarray variables in test file, this_image.f90.
reviewers: klausler, PeteSteinfeld
Differential Revision: https://reviews.llvm.org/D108059
GitOrigin-RevId: ed921282e551f2252ccfcbddd7a85ad8a006ed3f
diff --git a/docs/Intrinsics.md b/docs/Intrinsics.md
index 5b353e8..f8f335f 100644
--- a/docs/Intrinsics.md
+++ b/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 |
diff --git a/include/flang/Evaluate/tools.h b/include/flang/Evaluate/tools.h
index a70f5f2..50a9e26 100644
--- a/include/flang/Evaluate/tools.h
+++ b/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 <typename A> bool IsCoarray(const A &) { return false; }
+template <typename A> bool IsCoarray(const Designator<A> &designator) {
+ if (const auto *symbol{std::get_if<SymbolRef>(&designator.u)}) {
+ return symbol->get().Corank() > 0;
+ }
+ return false;
+}
+template <typename T> bool IsCoarray(const Expr<T> &expr) {
+ return std::visit([](const auto &x) { return IsCoarray(x); }, expr.u);
+}
+template <typename A> bool IsCoarray(const std::optional<A> &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.
diff --git a/lib/Evaluate/intrinsics.cpp b/lib/Evaluate/intrinsics.cpp
index 15421a2..59d6517 100644
--- a/lib/Evaluate/intrinsics.cpp
+++ b/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 <algorithm>
#include <map>
@@ -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:
diff --git a/lib/Evaluate/tools.cpp b/lib/Evaluate/tools.cpp
index 88d4c97..fde6089 100644
--- a/lib/Evaluate/tools.cpp
+++ b/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<SomeType> &expr) {
return std::holds_alternative<ProcedureDesignator>(expr.u);
}
diff --git a/test/Semantics/call10.f90 b/test/Semantics/call10.f90
index deb6e37..fabadad 100644
--- a/test/Semantics/call10.f90
+++ b/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
diff --git a/test/Semantics/this_image.f90 b/test/Semantics/this_image.f90
new file mode 100644
index 0000000..089ab15
--- /dev/null
+++ b/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
