[flang] Refine checks for pointer initialization targets

[klausler]

Summary

f18 was emitting a bogus error message about the lack of a TARGET
attribute when a pointer was initialized with a component of a
variable that was a legitimate TARGET.

[PeteSteinfeld]

All builds, tests, and looks good.

flang/lib/Evaluate/check-expression.cpp

264

Should this call to GetUltimate() be to GetAssociationRoot()?

614

Should this be a call to GetAssociationRoot()?

[klausler]

flang/lib/Evaluate/check-expression.cpp

264

Construct associations are handled explicitly in the one caller (above) where they matter (ca. line 185).

614

Construct associations are handled in the base class (invoked below, lines 625-626).

flang/include/flang/Evaluate/tools.h

return WrapperHelper<TypeCategory::Logical, WRAPPER, WRAPPED>(
         dyType.kind(), std::move(x));
   case TypeCategory::Derived:
     return AsGenericExpr(Expr<SomeDerived>{WRAPPER<SomeDerived>{std::move(x)}});
   }
 }
 
 // GetLastSymbol() returns the rightmost symbol in an object or procedure
 // designator (which has perhaps been wrapped in an Expr<>), or a null pointer
-// when none is found.
+// when none is found.  It will return an ASSOCIATE construct entity's symbol
+// rather than descending into its expression.
 struct GetLastSymbolHelper
     : public AnyTraverse<GetLastSymbolHelper, std::optional<const Symbol *>> {
   using Result = std::optional<const Symbol *>;
   using Base = AnyTraverse<GetLastSymbolHelper, Result>;
   GetLastSymbolHelper() : Base{*this} {}
   using Base::operator();
   Result operator()(const Symbol &x) const { return &x; }
   Result operator()(const Component &x) const { return &x.GetLastSymbol(); }

flang/include/flang/Evaluate/traverse.h

 // See CheckSpecificationExpr() in check-expression.cpp for an example client.
 //
 // How this works:
 // - The operator() overloads in Traverse<> invoke the visitor's Default() for
 //   expression leaf nodes.  They invoke the visitor's operator() for the
 //   subtrees of interior nodes, and the visitor's Combine() to merge their
 //   results together.
 // - Overloads of operator() in each visitor handle the cases of interest.
+//
+// The default handler for semantics::Symbol will descend into the associated
+// expression of an ASSOCIATE (or related) construct entity.
 
 #include "expression.h"
 #include "flang/Semantics/symbol.h"
 #include "flang/Semantics/type.h"
 #include <set>
 #include <type_traits>
 
 namespace Fortran::evaluate {
if constexpr (T::category == TypeCategory::Derived) {
               : std::move(value);
         }
       }
       return result ? *result : visitor_.Default();
     } else {
       return visitor_.Default();
     }
   }
-  Result operator()(const Symbol &) const { return visitor_.Default(); }
+  Result operator()(const Symbol &symbol) const {
+    const Symbol &ultimate{symbol.GetUltimate()};
+    if (const auto *assoc{
+            ultimate.detailsIf<semantics::AssocEntityDetails>()}) {
+      return visitor_(assoc->expr());
+    } else {
+      return visitor_.Default();
+    }
+  }
   Result operator()(const StaticDataObject &) const {
     return visitor_.Default();
   }
   Result operator()(const ImpliedDoIndex &) const { return visitor_.Default(); }
 
   // Variables
   Result operator()(const BaseObject &x) const { return visitor_(x.u); }
   Result operator()(const Component &x) const {

flang/lib/Evaluate/check-expression.cpp

public:
   template <typename A> bool operator()(const std::optional<A> &x) const {
     return x && (*this)(*x);
   }
 
   bool operator()(const TypeParamInquiry &inq) const {
     return semantics::IsKindTypeParameter(inq.parameter());
   }
   bool operator()(const semantics::Symbol &symbol) const {
-    const auto &ultimate{symbol.GetUltimate()};
+    const auto &ultimate{GetAssociationRoot(symbol)};
     return IsNamedConstant(ultimate) || IsImpliedDoIndex(ultimate) ||
         IsInitialProcedureTarget(ultimate);
   }
   bool operator()(const CoarrayRef &) const { return false; }
   bool operator()(const semantics::ParamValue &param) const {
     return param.isExplicit() && (*this)(param.GetExplicit());
   }
   bool operator()(const ProcedureRef &) const;
public:
   bool emittedMessage() const { return emittedMessage_; }
 
   bool operator()(const BOZLiteralConstant &) const { return false; }
   bool operator()(const NullPointer &) const { return true; }
   template <typename T> bool operator()(const Constant<T> &) const {
     return false;
   }
   bool operator()(const semantics::Symbol &symbol) {
+    // This function checks only base symbols, not components.
     const Symbol &ultimate{symbol.GetUltimate()};
-    if (IsAllocatable(ultimate)) {
-      if (messages_) {
+    if (const auto *assoc{
+            ultimate.detailsIf<semantics::AssocEntityDetails>()}) {
+      if (const auto &expr{assoc->expr()}) {
+        if (IsVariable(*expr)) {
+          return (*this)(*expr);
+        } else if (messages_) {
           messages_->Say(
-            "An initial data target may not be a reference to an ALLOCATABLE '%s'"_err_en_US,
+              "An initial data target may not be an associated expression ('%s')"_err_en_US,
               ultimate.name());
           emittedMessage_ = true;
         }
-      return false;
-    } else if (ultimate.Corank() > 0) {
-      if (messages_) {
-        messages_->Say(
-            "An initial data target may not be a reference to a coarray '%s'"_err_en_US,
-            ultimate.name());
-        emittedMessage_ = true;
       }
       return false;
     } else if (!ultimate.attrs().test(semantics::Attr::TARGET)) {
       if (messages_) {
         messages_->Say(
             "An initial data target may not be a reference to an object '%s' that lacks the TARGET attribute"_err_en_US,
             ultimate.name());
         emittedMessage_ = true;
       }
       return false;
     } else if (!IsSaved(ultimate)) {
       if (messages_) {
         messages_->Say(
             "An initial data target may not be a reference to an object '%s' that lacks the SAVE attribute"_err_en_US,
             ultimate.name());
         emittedMessage_ = true;
       }
       return false;
+    } else {
+      return CheckVarOrComponent(ultimate);
     }
-    return true;
   }
   bool operator()(const StaticDataObject &) const { return false; }
   bool operator()(const TypeParamInquiry &) const { return false; }
   bool operator()(const Triplet &x) const {
     return IsConstantExpr(x.lower()) && IsConstantExpr(x.upper()) &&
         IsConstantExpr(x.stride());
   }
   bool operator()(const Subscript &x) const {
     return std::visit(common::visitors{
                           [&](const Triplet &t) { return (*this)(t); },
                           [&](const auto &y) {
                             return y.value().Rank() == 0 &&
                                 IsConstantExpr(y.value());
                           },
                       },
         x.u);
   }
   bool operator()(const CoarrayRef &) const { return false; }
+  bool operator()(const Component &x) {
+    return CheckVarOrComponent(x.GetLastSymbol()) && (*this)(x.base());
+  }
   bool operator()(const Substring &x) const {
     return IsConstantExpr(x.lower()) && IsConstantExpr(x.upper()) &&
         (*this)(x.parent());
   }
   bool operator()(const DescriptorInquiry &) const { return false; }
   template <typename T> bool operator()(const ArrayConstructor<T> &) const {
     return false;
   }
template <typename T> bool operator()(const Parentheses<T> &x) const {
     return (*this)(x.left());
   }
   template <typename T> bool operator()(const FunctionRef<T> &x) const {
     return false;
   }
   bool operator()(const Relational<SomeType> &) const { return false; }
 
 private:
+  bool CheckVarOrComponent(const semantics::Symbol &symbol) {
+    const Symbol &ultimate{symbol.GetUltimate()};
+    if (IsAllocatable(ultimate)) {
+      if (messages_) {
+        messages_->Say(
+            "An initial data target may not be a reference to an ALLOCATABLE '%s'"_err_en_US,
+            ultimate.name());
+        emittedMessage_ = true;
+      }
+      return false;
+    } else if (ultimate.Corank() > 0) {
+      if (messages_) {
+        messages_->Say(
+            "An initial data target may not be a reference to a coarray '%s'"_err_en_US,
+            ultimate.name());
+        emittedMessage_ = true;
+      }
+      return false;
+    }
+    return true;
+  }
+
   parser::ContextualMessages *messages_;
   bool emittedMessage_{false};
 };
 
 bool IsInitialDataTarget(
     const Expr<SomeType> &x, parser::ContextualMessages *messages) {
   IsInitialDataTargetHelper helper{messages};
   bool result{helper(x)};
public:
 
   Result operator()(const ProcedureDesignator &) const {
     return "dummy procedure argument";
   }
   Result operator()(const CoarrayRef &) const { return "coindexed reference"; }
 
   Result operator()(const semantics::Symbol &symbol) const {
     const auto &ultimate{symbol.GetUltimate()};
-    if (semantics::IsNamedConstant(ultimate) || ultimate.owner().IsModule() ||
-        ultimate.owner().IsSubmodule()) {
+    if (const auto *assoc{
+            ultimate.detailsIf<semantics::AssocEntityDetails>()}) {
+      return (*this)(assoc->expr());
+    } else if (semantics::IsNamedConstant(ultimate) ||
+        ultimate.owner().IsModule() || ultimate.owner().IsSubmodule()) {
       return std::nullopt;
     } else if (scope_.IsDerivedType() &&
         IsVariableName(ultimate)) { // C750, C754
       return "derived type component or type parameter value not allowed to "
              "reference variable '"s +
           ultimate.name().ToString() + "'";
     } else if (IsDummy(ultimate)) {
       if (ultimate.attrs().test(semantics::Attr::OPTIONAL)) {

 public:
   using Result = std::optional<bool>; // tri-state
   using Base = AnyTraverse<IsSimplyContiguousHelper, Result>;
   explicit IsSimplyContiguousHelper(FoldingContext &c)
       : Base{*this}, context_{c} {}
   using Base::operator();
 
   Result operator()(const semantics::Symbol &symbol) const {
-    if (symbol.attrs().test(semantics::Attr::CONTIGUOUS) ||
-        symbol.Rank() == 0) {
+    const auto &ultimate{symbol.GetUltimate()};
+    if (ultimate.attrs().test(semantics::Attr::CONTIGUOUS) ||
+        ultimate.Rank() == 0) {
       return true;
-    } else if (semantics::IsPointer(symbol)) {
+    } else if (semantics::IsPointer(ultimate)) {
       return false;
     } else if (const auto *details{
-                   symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
+                   ultimate.detailsIf<semantics::ObjectEntityDetails>()}) {
       // N.B. ALLOCATABLEs are deferred shape, not assumed, and
       // are obviously contiguous.
       return !details->IsAssumedShape() && !details->IsAssumedRank();
+    } else if (auto assoc{Base::operator()(ultimate)}) {
+      return assoc;
     } else {
       return false;
     }
   }
 
   Result operator()(const ArrayRef &x) const {
     const auto &symbol{x.GetLastSymbol()};
     if (!(*this)(symbol)) {

flang/lib/Semantics/check-data.cpp

bool operator()(const Symbol &symbol) { // C876
     if (const char *whyNot{IsAutomatic(symbol) ? "Automatic variable"
                 : IsDummy(symbol)              ? "Dummy argument"
                 : IsFunctionResult(symbol)     ? "Function result"
                 : IsAllocatable(symbol)        ? "Allocatable"
                 : IsInitialized(symbol, true)  ? "Default-initialized"
                 : IsInBlankCommon(symbol)      ? "Blank COMMON object"
                 : IsProcedure(symbol) && !IsPointer(symbol) ? "Procedure"
                 // remaining checks don't apply to components
-                : !isFirstSymbol                  ? nullptr
-                : IsHostAssociated(symbol, scope) ? "Host-associated object"
-                : IsUseAssociated(symbol, scope)  ? "USE-associated object"
+                : !isFirstSymbol                   ? nullptr
+                : IsHostAssociated(symbol, scope)  ? "Host-associated object"
+                : IsUseAssociated(symbol, scope)   ? "USE-associated object"
+                : symbol.has<AssocEntityDetails>() ? "Construct association"
                                                    : nullptr}) {
       context_.Say(source_,
           "%s '%s' must not be initialized in a DATA statement"_err_en_US,
           whyNot, symbol.name());
       return false;
     } else if (IsProcedurePointer(symbol)) {
       context_.Say(source_,
           "Procedure pointer '%s' in a DATA statement is not standard"_en_US,
           symbol.name());

flang/test/Semantics/init01.f90

 !ERROR: Pointer has rank 0 but target has rank 1
     real, pointer :: p4 => a1
 !ERROR: Pointer has rank 1 but target has rank 0
 !ERROR: Pointer has rank 1 but target has rank 0
     real, pointer :: p5(:) => a4
   end type
   type(t2(3,3)) :: o1
   type(t2(2,2)) :: o2
+  type :: t3
+    real :: x
+  end type
+  type(t3), save, target :: o3
+  real, pointer :: p10 => o3%x
+  associate (a1 => o3, a2 => o3%x)
+    block
+      real, pointer :: p11 => a1
+      real, pointer :: p12 => a2
+    end block
+  end associate
 end subroutine