[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.".

Author: jeanPerier

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},

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());
+            }
+          }
         }
       }
     }

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