[flang] Add image_index to list of intrinsics and add tests

[ktras]

Add image_index to the list of intrinsic functions and add additional check on its args in check-call.cpp. Add two semantics tests for image_index.

[llvmbot]

@llvm/pr-subscribers-flang-semantics

Author: Katherine Rasmussen (ktras)

Changes

Add image_index to the list of intrinsic functions and add additional check on its args in check-call.cpp. Add two semantics tests for image_index.

---

Full diff: https://github.com/llvm/llvm-project/pull/79519.diff

5 Files Affected:

• (modified) flang/docs/Intrinsics.md (+1-1)
• (modified) flang/lib/Evaluate/intrinsics.cpp (+12-1)
• (modified) flang/lib/Semantics/check-call.cpp (+19)
• (added) flang/test/Semantics/image_index01.f90 (+41)
• (added) flang/test/Semantics/image_index02.f90 (+109)

diff --git a/flang/docs/Intrinsics.md b/flang/docs/Intrinsics.md
index 5ade2574032977..66ed2d05f2332b 100644
--- a/flang/docs/Intrinsics.md
+++ b/flang/docs/Intrinsics.md
@@ -753,7 +753,7 @@ This phase currently supports all the intrinsic procedures listed above but the
 
 | Intrinsic Category | Intrinsic Procedures Lacking Support |
 | --- | --- |
-| Coarray intrinsic functions | IMAGE_INDEX, COSHAPE |
+| Coarray intrinsic functions | 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, SHIFT, ZEXT, IZEXT, COSD, SIND, TAND, ACOSD, ASIND, ATAND, ATAN2D, COMPL, EQV, NEQV, INT8, JINT, JNINT, KNINT, 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, GETPID, NUMARG, BADDRESS, IADDR, CACHESIZE, EOF, FP_CLASS, INT_PTR_KIND, ISNAN, MALLOC |
diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp
index da6d5970089884..20addc9cae3632 100644
--- a/flang/lib/Evaluate/intrinsics.cpp
+++ b/flang/lib/Evaluate/intrinsics.cpp
@@ -529,6 +529,17 @@ static const IntrinsicInterface genericIntrinsicFunction[]{
     {"ieor", {{"i", OperandInt}, {"j", OperandInt, Rank::elementalOrBOZ}},
         OperandInt},
     {"ieor", {{"i", BOZ}, {"j", SameInt}}, SameInt},
+    {"image_index",
+        {{"coarray", AnyData, Rank::coarray}, {"sub", AnyInt, Rank::vector}},
+        DefaultInt, Rank::scalar, IntrinsicClass::transformationalFunction},
+    {"image_index",
+        {{"coarray", AnyData, Rank::coarray}, {"sub", AnyInt, Rank::vector},
+            {"team", TeamType, Rank::scalar}},
+        DefaultInt, Rank::scalar, IntrinsicClass::transformationalFunction},
+    {"image_index",
+        {{"coarray", AnyData, Rank::coarray}, {"sub", AnyInt, Rank::vector},
+            {"team_number", AnyInt, Rank::scalar}},
+        DefaultInt, Rank::scalar, IntrinsicClass::transformationalFunction},
     {"image_status", {{"image", SameInt}, OptionalTEAM}, DefaultInt},
     {"index",
         {{"string", SameCharNoLen}, {"substring", SameCharNoLen},
@@ -930,7 +941,7 @@ static const IntrinsicInterface genericIntrinsicFunction[]{
 };
 
 // TODO: Coarray intrinsic functions
-//  IMAGE_INDEX, COSHAPE
+//  COSHAPE
 // TODO: Non-standard intrinsic functions
 //  SHIFT,
 //  COMPL, EQV, NEQV, INT8, JINT, JNINT, KNINT,
diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp
index c924a817ec7e19..99b9c0426ffbc8 100644
--- a/flang/lib/Semantics/check-call.cpp
+++ b/flang/lib/Semantics/check-call.cpp
@@ -1433,6 +1433,23 @@ static void CheckAssociated(evaluate::ActualArguments &arguments,
   }
 }
 
+// IMAGE_INDEX (F'2023 16.9.107)
+static void CheckImage_Index(evaluate::ActualArguments &arguments,
+    parser::ContextualMessages &messages) {
+  if (arguments[1] && arguments[0]) {
+    if (auto subArrShape{evaluate::GetShape(arguments[1]->UnwrapExpr())}) {
+      if (const auto *coarrayArgSymbol{UnwrapWholeSymbolOrComponentDataRef(
+              arguments[0]->UnwrapExpr())}) {
+        if (evaluate::ToInt64(*subArrShape->front()) !=
+            coarrayArgSymbol->Corank()) {
+          messages.Say(arguments[1]->sourceLocation(),
+              "The size of the 'sub=' argument for intrinsic 'image_index' must be equal to the corank of the 'coarray=' argument"_err_en_US);
+        }
+      }
+    }
+  }
+}
+
 // MOVE_ALLOC (F'2023 16.9.147)
 static void CheckMove_Alloc(evaluate::ActualArguments &arguments,
     parser::ContextualMessages &messages) {
@@ -1678,6 +1695,8 @@ static void CheckSpecificIntrinsic(evaluate::ActualArguments &arguments,
     const evaluate::SpecificIntrinsic &intrinsic) {
   if (intrinsic.name == "associated") {
     CheckAssociated(arguments, context, scope);
+  } else if (intrinsic.name == "image_index") {
+    CheckImage_Index(arguments, context.foldingContext().messages());
   } else if (intrinsic.name == "move_alloc") {
     CheckMove_Alloc(arguments, context.foldingContext().messages());
   } else if (intrinsic.name == "reduce") {
diff --git a/flang/test/Semantics/image_index01.f90 b/flang/test/Semantics/image_index01.f90
new file mode 100644
index 00000000000000..1ed6779c69bdb7
--- /dev/null
+++ b/flang/test/Semantics/image_index01.f90
@@ -0,0 +1,41 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+! Ensure standard-conforming image_index function references are
+! accepted, based on the 16.9.107 section of the Fortran 2023 standard
+
+program image_index_test
+  use iso_fortran_env, only: team_type
+  implicit none
+
+  integer n, array(1), team_num
+  integer scalar_coarray[*], array_coarray(1)[*], coarray_corank3[10, 0:9, 0:*]
+  integer subscripts_corank1(1), subscripts_corank3(3)
+  type(team_type) :: home, league(2)
+
+  !___ standard-conforming statements - IMAGE_INDEX(COARRAY, SUB) ___
+  n = image_index(scalar_coarray, [1])
+  n = image_index(scalar_coarray, subscripts_corank1)
+  n = image_index(array_coarray, [1])
+  n = image_index(array_coarray, subscripts_corank1)
+  n = image_index(coarray=scalar_coarray, sub=subscripts_corank1)
+  n = image_index(coarray_corank3, subscripts_corank3)
+  n = image_index(sub=subscripts_corank1, coarray=scalar_coarray)
+
+  !___ standard-conforming statements - IMAGE_INDEX(COARRAY, SUB, TEAM) ___
+  n = image_index(scalar_coarray, [1], home)
+  n = image_index(scalar_coarray, subscripts_corank1, league(1))
+  n = image_index(array_coarray, [1], home)
+  n = image_index(array_coarray, subscripts_corank1, league(1))
+  n = image_index(coarray_corank3, subscripts_corank3, league(1))
+  n = image_index(coarray=scalar_coarray, sub=subscripts_corank1, team=home)
+  n = image_index(team=home, sub=[1], coarray=scalar_coarray)
+
+  !___ standard-conforming statements - IMAGE_INDEX(COARRAY, SUB, TEAM_NUMBER) ___
+  n = image_index(scalar_coarray, [1], team_num)
+  n = image_index(scalar_coarray, subscripts_corank1, team_number=team_num)
+  n = image_index(array_coarray, [1], team_num)
+  n = image_index(array_coarray, subscripts_corank1, array(1))
+  n = image_index(coarray_corank3, subscripts_corank3, team_num)
+  n = image_index(coarray=scalar_coarray, sub=subscripts_corank1, team_number=team_num)
+  n = image_index(team_number=team_num, sub=[1], coarray=scalar_coarray)
+
+end program image_index_test
diff --git a/flang/test/Semantics/image_index02.f90 b/flang/test/Semantics/image_index02.f90
new file mode 100644
index 00000000000000..4a927e39c630dc
--- /dev/null
+++ b/flang/test/Semantics/image_index02.f90
@@ -0,0 +1,109 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+! Check for semantic errors in image_index() function references
+! based on the 16.9.107 section of the Fortran 2023 standard
+
+program image_index_test
+  use iso_c_binding, only: c_int32_t
+  use iso_fortran_env, only: team_type
+  implicit none
+
+  integer n, array(1), non_coarray, scalar, team_num
+  integer scalar_coarray[*], array_coarray(1)[*], coarray_corank3[10, 0:9, 0:*], repeated_coarray[*]
+  integer subscripts_corank1(1), subscripts_corank3(3), repeated_sub(1), multi_rank_array(3,3)
+  integer, parameter :: const_subscripts_corank1(1) = [1]
+  logical non_integer_array(1)
+  type(team_type) :: home, league(2), wrong_result_type
+
+  !___ non-conforming statements ___
+
+  !ERROR: missing mandatory 'coarray=' argument
+  n = image_index()
+
+  !ERROR: missing mandatory 'sub=' argument
+  n = image_index(scalar_coarray)
+
+  !ERROR: 'sub=' argument has unacceptable rank 2
+  n = image_index(scalar_coarray, multi_rank_array)
+
+  !ERROR: The size of the 'sub=' argument for intrinsic 'image_index' must be equal to the corank of the 'coarray=' argument
+  n = image_index(coarray_corank3, subscripts_corank1, league(1))
+
+  !ERROR: The size of the 'sub=' argument for intrinsic 'image_index' must be equal to the corank of the 'coarray=' argument
+  n = image_index(coarray_corank3, const_subscripts_corank1, league(1))
+
+  !ERROR: The size of the 'sub=' argument for intrinsic 'image_index' must be equal to the corank of the 'coarray=' argument
+  n = image_index(coarray_corank3, [1], league(1))
+
+  !ERROR: The size of the 'sub=' argument for intrinsic 'image_index' must be equal to the corank of the 'coarray=' argument
+  n = image_index(coarray_corank3, [1,2,3,4,5,6])
+
+  !ERROR: missing mandatory 'coarray=' argument
+  n = image_index(sub=[1])
+
+  !ERROR: unknown keyword argument to intrinsic 'image_index'
+  n = image_index(team=home)
+
+  !ERROR: 'coarray=' argument must have corank > 0 for intrinsic 'image_index'
+  n = image_index(non_coarray, [1])
+
+  !ERROR: Actual argument for 'sub=' has bad type 'LOGICAL(4)'
+  n = image_index(array_coarray, [.true.])
+
+  !ERROR: Actual argument for 'sub=' has bad type 'LOGICAL(4)'
+  n = image_index(array_coarray, non_integer_array)
+
+  !ERROR: 'sub=' argument has unacceptable rank 0
+  n = image_index(array_coarray, scalar)
+
+  !ERROR: unknown keyword argument to intrinsic 'image_index'
+  n = image_index(scalar_coarray, subscripts_corank1, team=league)
+
+  !ERROR: unknown keyword argument to intrinsic 'image_index'
+  n = image_index(scalar_coarray, [1], team=team_num)
+
+  !ERROR: too many actual arguments for intrinsic 'image_index'
+  n = image_index(array_coarray, [1], home, team_num)
+
+  !ERROR: too many actual arguments for intrinsic 'image_index'
+  n = image_index(array_coarray, [1], home, team_num)
+
+  !ERROR: unknown keyword argument to intrinsic 'image_index'
+  n = image_index(array_coarray, [1], team=home, team=league(1))
+
+  !ERROR: repeated keyword argument to intrinsic 'image_index'
+  n = image_index(coarray=scalar_coarray, sub=[1], coarray=repeated_coarray)
+
+  !ERROR: keyword argument to intrinsic 'image_index' was supplied positionally by an earlier actual argument
+  n = image_index(scalar_coarray, [1], coarray=repeated_coarray)
+
+  !ERROR: repeated keyword argument to intrinsic 'image_index'
+  n = image_index(scalar_coarray, sub=subscripts_corank1, sub=repeated_sub)
+
+  !ERROR: keyword argument to intrinsic 'image_index' was supplied positionally by an earlier actual argument
+  n = image_index(scalar_coarray, subscripts_corank1, sub=repeated_sub)
+
+  !ERROR: unknown keyword argument to intrinsic 'image_index'
+  n = image_index(scalar_coarray, [1], team_number=array)
+
+  !ERROR: unknown keyword argument to intrinsic 'image_index'
+  n = image_index(scalar_coarray, [1], team_number=home)
+
+  !ERROR: unknown keyword argument to intrinsic 'image_index'
+  n = image_index(array_coarray, [1], team=home, team_number=team_num)
+
+  !ERROR: unknown keyword argument to intrinsic 'image_index'
+  n = image_index(c=scalar_coarray, [1])
+
+  !ERROR: unknown keyword argument to intrinsic 'image_index'
+  n = image_index(scalar_coarray, subscripts=[1])
+
+  !ERROR: unknown keyword argument to intrinsic 'image_index'
+  n = image_index(scalar_coarray, [1], team_num=team_num)
+
+  !ERROR: unknown keyword argument to intrinsic 'image_index'
+  n = image_index(scalar_coarray, [1], teams=home)
+
+  !ERROR: No intrinsic or user-defined ASSIGNMENT(=) matches operand types TYPE(team_type) and INTEGER(4)
+  wrong_result_type = image_index(scalar_coarray, subscripts_corank1)
+
+end program image_index_test