[flang-commits] [flang] [flang] relax ASSOCIATED checks for assumed-ranks (PR #94277)

[via flang-commits]

https://github.com/jeanPerier created https://github.com/llvm/llvm-project/pull/94277

Nothing in the standard actually prevents TARGET from being an assumed-rank if the POINTER is. The only rank related constraints says: _"POINTER is not assumed-rank, TARGET shall have the same rank as POINTER."_.

>From f76d0b8c92477ac760344388e883853fe55c4395 Mon Sep 17 00:00:00 2001
From: Jean Perier <jperier at nvidia.com>
Date: Mon, 3 Jun 2024 12:55:29 -0700
Subject: [PATCH] [flang] relax ASSOCIATED checks for assumed-ranks

---
 flang/lib/Evaluate/intrinsics.cpp   |  5 +++--
 flang/lib/Semantics/check-call.cpp  | 11 +++++++++++
 flang/test/Semantics/associated.f90 | 15 +++++++++------
 3 files changed, 23 insertions(+), 8 deletions(-)

diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp
index ded277877f49d..0ae4563758f32 100644
--- a/flang/lib/Evaluate/intrinsics.cpp
+++ b/flang/lib/Evaluate/intrinsics.cpp
@@ -331,8 +331,9 @@ static const IntrinsicInterface genericIntrinsicFunction[]{
     {"associated",
         {{"pointer", AnyPointer, Rank::anyOrAssumedRank, Optionality::required,
              common::Intent::In, {ArgFlag::canBeNull}},
-            {"target", Addressable, Rank::known, Optionality::optional,
-                common::Intent::In, {ArgFlag::canBeNull}}},
+            {"target", Addressable, Rank::anyOrAssumedRank,
+                Optionality::optional, common::Intent::In,
+                {ArgFlag::canBeNull}}},
         DefaultLogical, Rank::elemental, IntrinsicClass::inquiryFunction},
     {"atan", {{"x", SameFloating}}, SameFloating},
     {"atan", {{"y", OperandReal}, {"x", OperandReal}}, OperandReal},
diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp
index 48c888c0dfb26..64f10662b2ae7 100644
--- a/flang/lib/Semantics/check-call.cpp
+++ b/flang/lib/Semantics/check-call.cpp
@@ -1473,6 +1473,17 @@ static void CheckAssociated(evaluate::ActualArguments &arguments,
                 "POINTER= argument '%s' is an object pointer but the TARGET= argument '%s' is not a variable"_err_en_US,
                 pointerExpr->AsFortran(), targetExpr->AsFortran());
           }
+          if (!IsAssumedRank(*pointerExpr)) {
+            if (IsAssumedRank(*targetExpr)) {
+              messages.Say(
+                  "TARGET= argument '%s' may not be assumed-rank when POINTER= argument is not"_err_en_US,
+                  pointerExpr->AsFortran());
+            } else if (pointerExpr->Rank() != targetExpr->Rank()) {
+              messages.Say(
+                  "POINTER= argument and TARGET= argument have incompatible ranks %d and %d"_err_en_US,
+                  pointerExpr->Rank(), targetExpr->Rank());
+            }
+          }
         }
       }
     }
diff --git a/flang/test/Semantics/associated.f90 b/flang/test/Semantics/associated.f90
index 1da94d28ae6ba..1432744806599 100644
--- a/flang/test/Semantics/associated.f90
+++ b/flang/test/Semantics/associated.f90
@@ -94,18 +94,21 @@ subroutine test(assumedRank)
     integer, pointer :: intPointerArr(:)
     procedure(objPtrFunc), pointer :: objPtrFuncPointer
 
-    !ERROR: Assumed-rank array cannot be forwarded to 'target=' argument
-    lvar = associated(assumedRank, assumedRank)
+    lvar = associated(assumedRank, assumedRank) ! ok
+    !ERROR: TARGET= argument 'realscalarptr' may not be assumed-rank when POINTER= argument is not
+    lvar = associated(realScalarPtr, assumedRank)
+    !ERROR: TARGET= argument 'realvecptr' may not be assumed-rank when POINTER= argument is not
+    lvar = associated(realVecPtr, assumedRank)
     lvar = associated(assumedRank, targetRealVar) ! ok
     lvar = associated(assumedRank, targetRealMat) ! ok
     lvar = associated(realScalarPtr, targetRealVar) ! ok
-    !ERROR: 'target=' argument has unacceptable rank 0
+    !ERROR: POINTER= argument and TARGET= argument have incompatible ranks 1 and 0
     lvar = associated(realVecPtr, targetRealVar)
-    !ERROR: 'target=' argument has unacceptable rank 0
+    !ERROR: POINTER= argument and TARGET= argument have incompatible ranks 2 and 0
     lvar = associated(realMatPtr, targetRealVar)
-    !ERROR: 'target=' argument has unacceptable rank 2
+    !ERROR: POINTER= argument and TARGET= argument have incompatible ranks 0 and 2
     lvar = associated(realScalarPtr, targetRealMat)
-    !ERROR: 'target=' argument has unacceptable rank 2
+    !ERROR: POINTER= argument and TARGET= argument have incompatible ranks 1 and 2
     lvar = associated(realVecPtr, targetRealMat)
     lvar = associated(realMatPtr, targetRealMat) ! ok
     !ERROR: missing mandatory 'pointer=' argument