[flang] Portability warnings for an ambiguous ASSOCIATED() case

The standard's specification for the ASSOCIATED() intrinsic function
describes its optional second argument (TARGET=) as being required
to be a valid target for a pointer assignment statement in which the
first argument (POINTER=) was the left-hand side.  Some Fortran compilers
apparently interpret this text as a requirement that the POINTER= argument
actually be a valid left-hand side to a pointer assignment statement,
and emit an error if it is not so.  This particularly affects the
use of an explicit NULL pointer as the first argument.

Such usage is well-defined, benign, useful, and supported by at least
two other compilers, so we should continue to accept it.  This patch
adds a portability warning and some documentation.

In order to implement the portability warning in the best way, the
special checks on calls to the ASSOCIATED() intrinsic function have
been moved from intrinsic processing to Semantics/check-calls.cpp,
whence they have access to semantics' toolchest.  Special checks for
other intrinsic functions might also migrate in the future in order
to keep them all in one place.

Differential Revision: https://reviews.llvm.org/D142768

Author: klausler

flang/docs/Extensions.md

@@ -527,6 +527,19 @@ end module
   scope, with a portability warning, since that global name is not actually
   capable of being "used" in its scope.
 
+* In the definition of the `ASSOCIATED` intrinsic function (16.9.16), its optional
+  second argument `TARGET=` is required to be "allowable as the data-target or
+  proc-target in a pointer assignment statement (10.2.2) in which POINTER is
+  data-pointer-object or proc-pointer-object."  Some Fortran compilers
+  interpret this to require that the first argument (`POINTER=`) be a valid
+  left-hand side for a pointer assignment statement -- in particular, it
+  cannot be `NULL()`, but also it is required to be modifiable.
+  As there is  no good reason to disallow (say) an `INTENT(IN)` pointer here,
+  or even `NULL()` as a well-defined case that is always `.FALSE.`,
+  this compiler doesn't require the `POINTER=` argument to be a valid
+  left-hand side for a pointer assignment statement, and we emit a
+  portability warning when it is not.
+
 ## De Facto Standard Features
 
 * `EXTENDS_TYPE_OF()` returns `.TRUE.` if both of its arguments have the

flang/include/flang/Evaluate/tools.h

@@ -970,6 +970,7 @@ bool IsAllocatableDesignator(const Expr<SomeType> &);
 // Procedure and pointer detection predicates
 bool IsProcedure(const Expr<SomeType> &);
 bool IsFunction(const Expr<SomeType> &);
+bool IsProcedurePointer(const Expr<SomeType> &);
 bool IsProcedurePointerTarget(const Expr<SomeType> &);
 bool IsBareNullPointer(const Expr<SomeType> *); // NULL() w/o MOLD= or type
 bool IsNullObjectPointer(const Expr<SomeType> &);

flang/lib/Evaluate/intrinsics.cpp

@@ -2656,129 +2656,6 @@ IntrinsicProcTable::Implementation::HandleC_F_Pointer(
   }
 }
 
-static bool CheckAssociated(SpecificCall &call, FoldingContext &context) {
-  bool ok{true};
-  if (const auto &pointerArg{call.arguments[0]}) {
-    if (const auto *pointerExpr{pointerArg->UnwrapExpr()}) {
-      if (const Symbol *pointerSymbol{GetLastSymbol(*pointerExpr)}) {
-        if (!pointerSymbol->attrs().test(semantics::Attr::POINTER)) {
-          AttachDeclaration(context.messages().Say(pointerArg->sourceLocation(),
-                                "POINTER= argument of ASSOCIATED() must be a "
-                                "POINTER"_err_en_US),
-              *pointerSymbol);
-        } else {
-          if (const auto &targetArg{call.arguments[1]}) {
-            if (const auto *targetExpr{targetArg->UnwrapExpr()}) {
-              std::optional<characteristics::Procedure> pointerProc, targetProc;
-              const auto *targetProcDesignator{
-                  UnwrapExpr<ProcedureDesignator>(*targetExpr)};
-              const Symbol *targetSymbol{GetLastSymbol(*targetExpr)};
-              bool isCall{false};
-              std::string targetName;
-              if (const auto *targetProcRef{// target is a function call
-                      std::get_if<ProcedureRef>(&targetExpr->u)}) {
-                if (auto targetRefedChars{
-                        characteristics::Procedure::Characterize(
-                            *targetProcRef, context)}) {
-                  targetProc = *targetRefedChars;
-                  targetName = targetProcRef->proc().GetName() + "()";
-                  isCall = true;
-                }
-              } else if (targetProcDesignator) {
-                targetProc = characteristics::Procedure::Characterize(
-                    *targetProcDesignator, context);
-                targetName = targetProcDesignator->GetName();
-              } else if (targetSymbol) {
-                if (IsProcedure(*targetSymbol)) {
-                  // proc that's not a call
-                  targetProc = characteristics::Procedure::Characterize(
-                      *targetSymbol, context);
-                }
-                targetName = targetSymbol->name().ToString();
-              }
-              if (IsProcedure(*pointerSymbol)) {
-                pointerProc = characteristics::Procedure::Characterize(
-                    *pointerSymbol, context);
-              }
-              if (pointerProc) {
-                if (targetProc) {
-                  // procedure pointer and procedure target
-                  std::string whyNot;
-                  const SpecificIntrinsic *specificIntrinsic{nullptr};
-                  if (targetProcDesignator) {
-                    specificIntrinsic =
-                        targetProcDesignator->GetSpecificIntrinsic();
-                  }
-                  if (std::optional<parser::MessageFixedText> msg{
-                          CheckProcCompatibility(isCall, pointerProc,
-                              &*targetProc, specificIntrinsic, whyNot)}) {
-                    msg->set_severity(parser::Severity::Warning);
-                    AttachDeclaration(
-                        context.messages().Say(std::move(*msg),
-                            "pointer '" + pointerSymbol->name().ToString() +
-                                "'",
-                            targetName, whyNot),
-                        *pointerSymbol);
-                  }
-                } else if (!IsNullProcedurePointer(*targetExpr)) {
-                  // procedure pointer and object target
-                  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);
-                }
-              } else if (targetProc) {
-                // object pointer and procedure target
-                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 (!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 = 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 {
-    // No arguments to ASSOCIATED()
-    ok = false;
-  }
-  if (!ok) {
-    context.messages().Say(
-        "Arguments of ASSOCIATED() must be a POINTER and an optional valid target"_err_en_US);
-  }
-  return ok;
-}
-
 static bool CheckForNonPositiveValues(FoldingContext &context,
     const ActualArgument &arg, const std::string &procName,
     const std::string &argName) {
@@ -2875,6 +2752,8 @@ static bool CheckAtomicDefineAndRef(FoldingContext &context,
 }
 
 // Applies any semantic checks peculiar to an intrinsic.
+// TODO: Move the rest of these checks to Semantics/check-call.cpp, which is
+// where ASSOCIATED() is now validated.
 static bool ApplySpecificChecks(SpecificCall &call, FoldingContext &context) {
   bool ok{true};
   const std::string &name{call.specificIntrinsic.name};
@@ -2891,7 +2770,7 @@ static bool ApplySpecificChecks(SpecificCall &call, FoldingContext &context) {
           "Argument of ALLOCATED() must be an ALLOCATABLE object or component"_err_en_US);
     }
   } else if (name == "associated") {
-    return CheckAssociated(call, context);
+    // Now handled in Semantics/check-call.cpp
   } else if (name == "atomic_and" || name == "atomic_or" ||
       name == "atomic_xor") {
     return CheckForCoindexedObject(context, call.arguments[2], name, "stat");

flang/lib/Evaluate/tools.cpp

@@ -737,6 +737,18 @@ bool IsFunction(const Expr<SomeType> &expr) {
   return designator && designator->GetType().has_value();
 }
 
+bool IsProcedurePointer(const Expr<SomeType> &expr) {
+  return common::visit(common::visitors{
+                           [](const NullPointer &) { return true; },
+                           [](const ProcedureRef &) { return false; },
+                           [&](const auto &) {
+                             const Symbol *last{GetLastSymbol(expr)};
+                             return last && IsProcedurePointer(*last);
+                           },
+                       },
+      expr.u);
+}
+
 bool IsProcedurePointerTarget(const Expr<SomeType> &expr) {
   return common::visit(common::visitors{
                            [](const NullPointer &) { return true; },