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

[via flang-commits]

Author: jeanPerier
Date: 2024-06-04T16:25:02+02:00
New Revision: 858a79eb1896b957098746c82c956c74b482866d

URL: https://github.com/llvm/llvm-project/commit/858a79eb1896b957098746c82c956c74b482866d
DIFF: https://github.com/llvm/llvm-project/commit/858a79eb1896b957098746c82c956c74b482866d.diff

LOG: [flang] relax ASSOCIATED checks for assumed-ranks (#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.".

Added: 
    

Modified: 
    flang/lib/Evaluate/intrinsics.cpp
    flang/lib/Semantics/check-call.cpp
    flang/test/Semantics/associated.f90

Removed: 
    


################################################################################
diff  --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp
index 69771aaf97d7c..12d13422574b5 100644
--- a/flang/lib/Evaluate/intrinsics.cpp
+++ b/flang/lib/Evaluate/intrinsics.cpp
@@ -332,8 +332,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 97c685fa0b2c0..51369f4b55a65 100644
--- a/flang/lib/Semantics/check-call.cpp
+++ b/flang/lib/Semantics/check-call.cpp
@@ -1499,6 +1499,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