[flang] Catch more bad TARGET= arguments to ASSOCIATED()

[klausler]

Summary

The TARGET= argument to the intrinsic function ASSOCIATED() must be
a valid target for the POINTER= argument, but we are missing some
cases, such as parenthesized expressions. Add more checking, and
restructure the logic a bit to make the case analysis structure
more clear.

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

flang/lib/Semantics/check-call.cpp

if (const auto *pointerExpr{pointerArg->UnwrapExpr()}) {
                   DefinabilityFlags{DefinabilityFlag::PointerDefinition},
                   *pointerExpr)}) {
             if (auto *msg{context.messages().Say(pointerArg->sourceLocation(),
                     "POINTER= argument of ASSOCIATED() would not be a valid left-hand side of a pointer assignment statement"_port_en_US)}) {
               msg->Attach(std::move(*whyNot));
             }
           }
         }
-        const auto *targetExpr{targetArg->UnwrapExpr()};
-        if (targetExpr && pointerSymbol) {
-          std::optional<characteristics::Procedure> pointerProc, targetProc;
+        if (const auto *targetExpr{targetArg->UnwrapExpr()};
+            targetExpr && pointerSymbol) {
+          if (IsProcedure(*pointerSymbol)) {
+            if (auto pointerProc{characteristics::Procedure::Characterize(
+                    *pointerSymbol, context)}) {
+              // Characterize the target procedure
+              std::optional<characteristics::Procedure> targetProc;
               const auto *targetProcDesignator{
-              evaluate::UnwrapExpr<evaluate::ProcedureDesignator>(*targetExpr)};
-          const Symbol *targetSymbol{GetLastSymbol(*targetExpr)};
+                  evaluate::UnwrapExpr<evaluate::ProcedureDesignator>(
+                      *targetExpr)};
               bool isCall{false};
               std::string targetName;
-          if (const auto *targetProcRef{// target is a function call
+              if (IsProcedure(*targetExpr) ||
+                  IsNullProcedurePointer(*targetExpr)) {
+                if (const auto *targetProcRef{
                         std::get_if<evaluate::ProcedureRef>(&targetExpr->u)}) {
-            if (auto targetRefedChars{characteristics::Procedure::Characterize(
-                    *targetProcRef, context)}) {
-              targetProc = *targetRefedChars;
-              targetName = targetProcRef->proc().GetName() + "()";
+                  // target is a function call returning a procedure pointer
+                  targetProc = characteristics::Procedure::Characterize(
+                      *targetProcRef, context);
                   isCall = true;
-            }
+                  targetName = targetProcRef->proc().GetName() + "()";
                 } else if (targetProcDesignator) {
                   targetProc = characteristics::Procedure::Characterize(
                       *targetProcDesignator, context);
                   targetName = targetProcDesignator->GetName();
-          } else if (targetSymbol) {
-            if (IsProcedure(*targetSymbol)) {
-              // proc that's not a call
+                } else if (const Symbol * targSym{GetLastSymbol(*targetExpr)}) {
                   targetProc = characteristics::Procedure::Characterize(
-                  *targetSymbol, context);
+                      *targSym, context);
+                  targetName = targSym->name().ToString();
                 }
-            targetName = targetSymbol->name().ToString();
               }
-          if (pointerSymbol && IsProcedure(*pointerSymbol)) {
-            pointerProc = characteristics::Procedure::Characterize(
-                *pointerSymbol, context);
-          }
-          if (pointerProc) {
               if (targetProc) {
-              // procedure pointer and procedure target
                 std::string whyNot;
-              const evaluate::SpecificIntrinsic *specificIntrinsic{nullptr};
-              if (targetProcDesignator) {
-                specificIntrinsic =
-                    targetProcDesignator->GetSpecificIntrinsic();
-              }
+                const evaluate::SpecificIntrinsic *specificIntrinsic{
+                    targetProcDesignator
+                        ? targetProcDesignator->GetSpecificIntrinsic()
+                        : nullptr};
                 if (std::optional<parser::MessageFixedText> msg{
-                      CheckProcCompatibility(isCall, pointerProc, &*targetProc,
-                          specificIntrinsic, whyNot)}) {
+                        CheckProcCompatibility(isCall, pointerProc,
+                            &*targetProc, specificIntrinsic, whyNot)}) {
                   msg->set_severity(parser::Severity::Warning);
                   evaluate::AttachDeclaration(
                       context.messages().Say(std::move(*msg),
                           "pointer '" + pointerSymbol->name().ToString() + "'",
                           targetName, whyNot),
                       *pointerSymbol);
                 }
               } else if (!IsNullProcedurePointer(*targetExpr)) {
-              // procedure pointer and object target
                 evaluate::AttachDeclaration(
                     context.messages().Say(
                         "POINTER= argument '%s' is a procedure pointer but the TARGET= argument '%s' is not a procedure or procedure pointer"_err_en_US,
-                      pointerSymbol->name(), targetName),
+                        pointerSymbol->name(), targetExpr->AsFortran()),
                     *pointerSymbol);
               }
-          } else if (targetProc) {
-            // object pointer and procedure target
-            evaluate::AttachDeclaration(
-                context.messages().Say(
-                    "POINTER= argument '%s' is an object pointer but the TARGET= argument '%s' is a procedure designator"_err_en_US,
-                    pointerSymbol->name(), targetName),
-                *pointerSymbol);
-          } else if (targetSymbol) {
-            // object pointer and target
-            SymbolVector symbols{GetSymbolVector(*targetExpr)};
-            CHECK(!symbols.empty());
-            if (!evaluate::GetLastTarget(symbols)) {
+            }
+          } else if (IsVariable(*targetExpr) || IsNullPointer(*targetExpr)) {
+            // Object pointer and target
+            if (ExtractDataRef(*targetExpr)) {
+              if (SymbolVector symbols{GetSymbolVector(*targetExpr)};
+                  !evaluate::GetLastTarget(symbols)) {
                 parser::Message *msg{context.messages().Say(
                     targetArg->sourceLocation(),
                     "TARGET= argument '%s' must have either the POINTER or the TARGET attribute"_err_en_US,
                     targetExpr->AsFortran())};
                 for (SymbolRef ref : symbols) {
                   msg = evaluate::AttachDeclaration(msg, *ref);
                 }
               } else if (HasVectorSubscript(*targetExpr) ||
                   ExtractCoarrayRef(*targetExpr)) {
                 context.messages().Say(targetArg->sourceLocation(),
                     "TARGET= argument '%s' may not have a vector subscript or coindexing"_err_en_US,
                     targetExpr->AsFortran());
               }
+            }
             if (const auto pointerType{pointerArg->GetType()}) {
               if (const auto targetType{targetArg->GetType()}) {
                 ok = pointerType->IsTkCompatibleWith(*targetType);
               }
             }
+          } else {
+            evaluate::AttachDeclaration(
+                context.messages().Say(
+                    "POINTER= argument '%s' is an object pointer but the TARGET= argument '%s' is not a variable"_err_en_US,
+                    pointerSymbol->name(), targetExpr->AsFortran()),
+                *pointerSymbol);
           }
         }
       }
     }
   } else {
     // No arguments to ASSOCIATED()
     ok = false;
   }

flang/test/Semantics/associated.f90

subroutine test(assumedRank)
     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: POINTER= argument 'intprocpointer1' is a procedure pointer but the TARGET= argument '(targetintvar1)' is not a procedure or procedure pointer
+    lvar = associated(intprocPointer1, (targetIntVar1))
+    !ERROR: POINTER= argument 'intpointervar1' is an object pointer but the TARGET= argument '(targetintvar1)' is not a variable
+    lvar = associated(intPointerVar1, (targetIntVar1))
     !ERROR: MOLD= argument to NULL() must be a pointer or allocatable
     lVar = associated(null(intVar))
     lVar = associated(null(intAllocVar)) !OK
     lVar = associated(null()) !OK
     lVar = associated(null(intPointerVar1)) !OK
     !PORTABILITY: POINTER= argument of ASSOCIATED() would not be a valid left-hand side of a pointer assignment statement
     !BECAUSE: 'NULL()' is a null pointer
     lVar = associated(null(), null()) !OK
subroutine test(assumedRank)
     intprocPointer1 => intVar
     !ERROR: POINTER= argument 'intprocpointer1' is a procedure pointer but the TARGET= argument 'intvar' is not a procedure or procedure pointer
     lVar = associated(intprocPointer1, intVar)
     !ERROR: Procedure pointer 'intprocpointer1' associated with incompatible procedure designator 'elementalproc': incompatible procedure attributes: Elemental
     intProcPointer1 => elementalProc
     !WARNING: Procedure pointer 'intprocpointer1' associated with incompatible procedure designator 'elementalproc': incompatible procedure attributes: Elemental
     !ERROR: Non-intrinsic ELEMENTAL procedure 'elementalproc' may not be passed as an actual argument
     lvar = associated(intProcPointer1, elementalProc)
-    !ERROR: POINTER= argument 'intpointervar1' is an object pointer but the TARGET= argument 'intfunc' is a procedure designator
+    !ERROR: POINTER= argument 'intpointervar1' is an object pointer but the TARGET= argument 'intfunc' is not a variable
     lvar = associated (intPointerVar1, intFunc)
     !ERROR: In assignment to object pointer 'intpointervar1', the target 'intfunc' is a procedure designator
     intPointerVar1 => intFunc
     !ERROR: In assignment to procedure pointer 'intprocpointer1', the target is not a procedure or procedure pointer
     intProcPointer1 => targetIntVar1
     !ERROR: POINTER= argument 'intprocpointer1' is a procedure pointer but the TARGET= argument 'targetintvar1' is not a procedure or procedure pointer
     lvar = associated (intProcPointer1, targetIntVar1)
     !ERROR: Procedure pointer 'intprocpointer1' associated with result of reference to function 'null' that is an incompatible procedure pointer: function results have distinct types: INTEGER(4) vs REAL(4)