[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

diff --git a/flang/docs/Intrinsics.md b/flang/docs/Intrinsics.md
index 5b353e8..f8f335f 100644 (file)
--- a/flang/docs/Intrinsics.md
+++ b/flang/docs/Intrinsics.md
@@ -746,7 +746,7 @@ This phase currently supports all the intrinsic procedures listed above but the
 
 | 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/flang/include/flang/Evaluate/tools.h b/flang/include/flang/Evaluate/tools.h
index a70f5f2..50a9e26 100644 (file)
--- a/flang/include/flang/Evaluate/tools.h
+++ b/flang/include/flang/Evaluate/tools.h
@@ -89,6 +89,22 @@ template <typename A> bool IsAssumedRank(const std::optional<A> &x) {
   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/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp
index 15421a2..59d6517 100644 (file)
--- a/flang/lib/Evaluate/intrinsics.cpp
+++ b/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 <algorithm>
 #include <map>
@@ -176,6 +177,7 @@ ENUM_CLASS(Rank,
     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 @@ static const IntrinsicInterface genericIntrinsicFunction[]{
     {"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 @@ static const IntrinsicInterface genericIntrinsicFunction[]{
 
 // 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 @@ std::optional<SpecificCall> IntrinsicInterface::Match(
           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 @@ std::optional<SpecificCall> IntrinsicInterface::Match(
   case Rank::elementalOrBOZ:
   case Rank::shape:
   case Rank::array:
+  case Rank::coarray:
   case Rank::known:
   case Rank::anyOrAssumedRank:
   case Rank::reduceOperation:

diff --git a/flang/lib/Evaluate/tools.cpp b/flang/lib/Evaluate/tools.cpp
index 88d4c97..fde6089 100644 (file)
--- a/flang/lib/Evaluate/tools.cpp
+++ b/flang/lib/Evaluate/tools.cpp
@@ -683,6 +683,13 @@ bool IsAssumedRank(const ActualArgument &arg) {
   }
 }
 
+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/flang/test/Semantics/call10.f90 b/flang/test/Semantics/call10.f90
index deb6e37..fabadad 100644 (file)
--- a/flang/test/Semantics/call10.f90
+++ b/flang/test/Semantics/call10.f90
@@ -184,7 +184,6 @@ module m
   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/flang/test/Semantics/this_image.f90 b/flang/test/Semantics/this_image.f90
new file mode 100644 (file)
index 0000000..089ab15
--- /dev/null
+++ b/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