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