[flang-commits] [PATCH] D155498: [flang] Accept an assumed-rank array as operand of ASSOCIATED()

[Peter Klausler via Phabricator via flang-commits]

klausler created this revision.
klausler added a reviewer: tarunprabhu.
klausler added a project: Flang.
Herald added subscribers: sunshaoce, jdoerfert.
Herald added a project: All.
klausler requested review of this revision.

The ASSOCIATED() intrinsic was mistakenly defined in the intrinsic
function table as requiring operands of known rank, which unintentionally
prevented assumed-rank dummy arguments from being tested.

Fixes llvm-test-suite/Fortran/gfortran/regression/pr88932.f90.


https://reviews.llvm.org/D155498

Files:
  flang/lib/Evaluate/intrinsics.cpp
  flang/test/Semantics/associated.f90


Index: flang/test/Semantics/associated.f90
===================================================================
--- flang/test/Semantics/associated.f90
+++ flang/test/Semantics/associated.f90
@@ -48,11 +48,13 @@
     integer :: i(:)
   end subroutine subrCannotBeCalledfromImplicit
 
-  subroutine test()
+  subroutine test(assumedRank)
+    real, pointer, intent(in out) :: assumedRank(..)
     integer :: intVar
     integer, target :: targetIntVar1
     integer(kind=2), target :: targetIntVar2
-    real, target :: targetRealVar
+    real, target :: targetRealVar, targetRealMat(2,2)
+    real, pointer :: realScalarPtr, realVecPtr(:), realMatPtr(:,:)
     integer, pointer :: intPointerVar1
     integer, pointer :: intPointerVar2
     integer, allocatable :: intAllocVar
@@ -77,6 +79,20 @@
     integer, target :: targetIntCoarray[*]
     integer, pointer :: intPointerArr(:)
 
+    !ERROR: Assumed-rank array cannot be forwarded to 'target=' argument
+    lvar = associated(assumedRank, assumedRank)
+    lvar = associated(assumedRank, targetRealVar) ! ok
+    lvar = associated(assumedRank, targetRealMat) ! ok
+    lvar = associated(realScalarPtr, targetRealVar) ! ok
+    !ERROR: 'target=' argument has unacceptable rank 0
+    lvar = associated(realVecPtr, targetRealVar)
+    !ERROR: 'target=' argument has unacceptable rank 0
+    lvar = associated(realMatPtr, targetRealVar)
+    !ERROR: 'target=' argument has unacceptable rank 2
+    lvar = associated(realScalarPtr, targetRealMat)
+    !ERROR: 'target=' argument has unacceptable rank 2
+    lvar = associated(realVecPtr, targetRealMat)
+    lvar = associated(realMatPtr, targetRealMat) ! ok
     !ERROR: missing mandatory 'pointer=' argument
     lVar = associated()
     !ERROR: MOLD= argument to NULL() must be a pointer or allocatable
Index: flang/lib/Evaluate/intrinsics.cpp
===================================================================
--- flang/lib/Evaluate/intrinsics.cpp
+++ flang/lib/Evaluate/intrinsics.cpp
@@ -326,7 +326,7 @@
     {"asind", {{"x", SameFloating}}, SameFloating},
     {"asinh", {{"x", SameFloating}}, SameFloating},
     {"associated",
-        {{"pointer", AnyPointer, Rank::known, Optionality::required,
+        {{"pointer", AnyPointer, Rank::anyOrAssumedRank, Optionality::required,
              common::Intent::In, {ArgFlag::canBeNull}},
             {"target", Addressable, Rank::known, Optionality::optional,
                 common::Intent::In, {ArgFlag::canBeNull}}},
@@ -1966,15 +1966,22 @@
         if (!knownArg) {
           knownArg = arg;
         }
-        argOk = rank == knownArg->Rank();
+        argOk = !isAssumedRank && rank == knownArg->Rank();
         break;
       case Rank::anyOrAssumedRank:
       case Rank::arrayOrAssumedRank:
+        if (isAssumedRank) {
+          argOk = true;
+          break;
+        }
         if (d.rank == Rank::arrayOrAssumedRank && rank == 0) {
           argOk = false;
           break;
         }
-        if (!dimArg && rank > 0 && !isAssumedRank &&
+        if (!knownArg) {
+          knownArg = arg;
+        }
+        if (!dimArg && rank > 0 &&
             (std::strcmp(name, "shape") == 0 ||
                 std::strcmp(name, "size") == 0 ||
                 std::strcmp(name, "ubound") == 0)) {


-------------- next part --------------
A non-text attachment was scrubbed...
Name: D155498.541127.patch
Type: text/x-patch
Size: 3271 bytes
Desc: not available
URL: <http://lists.llvm.org/pipermail/flang-commits/attachments/20230717/77cf6e1e/attachment-0001.bin>