diff --git a/flang/docs/Intrinsics.md b/flang/docs/Intrinsics.md index 5ade257403297..66ed2d05f2332 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 da6d597008988..20addc9cae363 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 c924a817ec7e1..a94c5df67408f 100644 --- a/flang/lib/Semantics/check-call.cpp +++ b/flang/lib/Semantics/check-call.cpp @@ -1433,6 +1433,27 @@ 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 (const auto subArrShape{ + evaluate::GetShape(arguments[1]->UnwrapExpr())}) { + if (const auto *coarrayArgSymbol{UnwrapWholeSymbolOrComponentDataRef( + arguments[0]->UnwrapExpr())}) { + const auto coarrayArgCorank = coarrayArgSymbol->Corank(); + if (const auto subArrSize = evaluate::ToInt64(*subArrShape->front())) { + if (subArrSize != coarrayArgCorank) { + messages.Say(arguments[1]->sourceLocation(), + "The size of 'SUB=' (%jd) for intrinsic 'image_index' must be equal to the corank of 'COARRAY=' (%d)"_err_en_US, + static_cast(*subArrSize), coarrayArgCorank); + } + } + } + } + } +} + // MOVE_ALLOC (F'2023 16.9.147) static void CheckMove_Alloc(evaluate::ActualArguments &arguments, parser::ContextualMessages &messages) { @@ -1678,6 +1699,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 0000000000000..1ed6779c69bdb --- /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 0000000000000..1f296df2433c5 --- /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 'SUB=' (1) for intrinsic 'image_index' must be equal to the corank of 'COARRAY=' (3) + n = image_index(coarray_corank3, subscripts_corank1, league(1)) + + !ERROR: The size of 'SUB=' (1) for intrinsic 'image_index' must be equal to the corank of 'COARRAY=' (3) + n = image_index(coarray_corank3, const_subscripts_corank1, league(1)) + + !ERROR: The size of 'SUB=' (1) for intrinsic 'image_index' must be equal to the corank of 'COARRAY=' (3) + n = image_index(coarray_corank3, [1], league(1)) + + !ERROR: The size of 'SUB=' (6) for intrinsic 'image_index' must be equal to the corank of 'COARRAY=' (3) + 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