[flang] Selectors whose expressions are pointers returned from functions are valid targets

[klausler]

Summary

An ASSOCIATE or SELECT TYPE statement's selector whose "right-hand side" is the result
of a reference to a function that returns a pointer must be usable as a valid target
(but not as a pointer).

flang/docs/Extensions.md

 
 * f18 supports designators with constant expressions, properly
   constrained, as initial data targets for data pointers in
   initializers of variable and component declarations and in
   `DATA` statements; e.g., `REAL, POINTER :: P => T(1:10:2)`.
   This Fortran 2008 feature might as well be viewed like an
   extension; no other compiler that we've tested can handle
   it yet.
+* According to 11.1.3.3p1, if a selector of an `ASSOCIATE` or
+  related construct is defined by a variable, it has the `TARGET`
+  attribute if the variable was a `POINTER` or `TARGET`.
+  We read this to include the case of the variable being a
+  pointer-valued function reference.
+  No other Fortran compiler seems to handle this correctly for
+  `ASSOCIATE`, though NAG gets it right for `SELECT TYPE`.
 
 ## Behavior in cases where the standard is ambiguous or indefinite
 
 * When an inner procedure of a subprogram uses the value or an attribute
   of an undeclared name in a specification expression and that name does
   not appear in the host, it is not clear in the standard whether that
   name is an implicitly typed local variable of the inner procedure or a
   host association with an implicitly typed local variable of the host.

flang/include/flang/Evaluate/tools.h

 template <typename A> const Symbol *GetLastSymbol(const A &x) {
   if (auto known{GetLastSymbolHelper{}(x)}) {
     return *known;
   } else {
     return nullptr;
   }
 }
 
-// Convenience: If GetLastSymbol() succeeds on the argument, return its
-// set of attributes, otherwise the empty set.
+// If a function reference constitutes an entire expression, return a pointer
+// to its PrcedureRef.
+const ProcedureRef *GetProcedureRef(const Expr<SomeType> &);
+
+// For everyday variables: if GetLastSymbol() succeeds on the argument, return
+// its set of attributes, otherwise the empty set.  Also works on variables that
+// are pointer results of functions.
 template <typename A> semantics::Attrs GetAttrs(const A &x) {
   if (const Symbol * symbol{GetLastSymbol(x)}) {
     return symbol->attrs();
   } else {
     return {};
   }
 }
 
+template <>
+inline semantics::Attrs GetAttrs<Expr<SomeType>>(const Expr<SomeType> &x) {
+  if (IsVariable(x)) {
+    if (const auto *procRef{GetProcedureRef(x)}) {
+      if (const Symbol * interface{procRef->proc().GetInterfaceSymbol()}) {
+        if (const auto *details{
+                interface->detailsIf<semantics::SubprogramDetails>()}) {
+          if (details->isFunction() &&
+              details->result().attrs().test(semantics::Attr::POINTER)) {
+            // N.B.: POINTER becomes TARGET in SetAttrsFromAssociation()
+            return details->result().attrs();
+          }
+        }
+      }
+    }
+  }
+  if (const Symbol * symbol{GetLastSymbol(x)}) {
+    return symbol->attrs();
+  } else {
+    return {};
+  }
+}
+
+template <typename A> semantics::Attrs GetAttrs(const std::optional<A> &x) {
+  if (x) {
+    return GetAttrs(*x);
+  } else {
+    return {};
+  }
+}
+
 // GetBaseObject()
 template <typename A> std::optional<BaseObject> GetBaseObject(const A &) {
   return std::nullopt;
 }
 template <typename T>
 std::optional<BaseObject> GetBaseObject(const Designator<T> &x) {
   return x.GetBaseObject();
 }
 template <typename T>
 std::optional<BaseObject> GetBaseObject(const Expr<T> &x) {
   return common::visit([](const auto &y) { return GetBaseObject(y); }, x.u);
 }
 template <typename A>
 std::optional<BaseObject> GetBaseObject(const std::optional<A> &x) {
   if (x) {
     return GetBaseObject(*x);
   } else {
     return std::nullopt;
   }
 }
 
-// Predicate: IsAllocatableOrPointer()
-template <typename A> bool IsAllocatableOrPointer(const A &x) {
-  return GetAttrs(x).HasAny(
-      semantics::Attrs{semantics::Attr::POINTER, semantics::Attr::ALLOCATABLE});
-}
-
 // Like IsAllocatableOrPointer, but accepts pointer function results as being
-// pointers.
+// pointers too.
 bool IsAllocatableOrPointerObject(const Expr<SomeType> &, FoldingContext &);
 
 bool IsAllocatableDesignator(const Expr<SomeType> &);
 
 // Procedure and pointer detection predicates
 bool IsProcedure(const Expr<SomeType> &);
 bool IsFunction(const Expr<SomeType> &);
 bool IsProcedurePointerTarget(const Expr<SomeType> &);
 bool IsBareNullPointer(const Expr<SomeType> *); // NULL() w/o MOLD= or type
 bool IsNullObjectPointer(const Expr<SomeType> &);
 bool IsNullProcedurePointer(const Expr<SomeType> &);
 bool IsNullPointer(const Expr<SomeType> &);
 bool IsObjectPointer(const Expr<SomeType> &, FoldingContext &);
 
-const ProcedureRef *GetProcedureRef(const Expr<SomeType> &);
-
 // Can Expr be passed as absent to an optional dummy argument.
 // See 15.5.2.12 point 1 for more details.
 bool MayBePassedAsAbsentOptional(const Expr<SomeType> &, FoldingContext &);
 
 // Extracts the chain of symbols from a designator, which has perhaps been
 // wrapped in an Expr<>, removing all of the (co)subscripts.  The
 // base object will be the first symbol in the result vector.
 struct GetSymbolVectorHelper

flang/lib/Evaluate/tools.cpp

 
 bool IsBareNullPointer(const Expr<SomeType> *expr) {
   return expr && std::holds_alternative<NullPointer>(expr->u);
 }
 
 // GetSymbolVector()
 auto GetSymbolVectorHelper::operator()(const Symbol &x) const -> Result {
   if (const auto *details{x.detailsIf<semantics::AssocEntityDetails>()}) {
+    if (IsVariable(details->expr()) && !GetProcedureRef(*details->expr())) {
+      // associate(x => variable that is not a pointer returned by a function)
       return (*this)(details->expr());
-  } else {
-    return {x.GetUltimate()};
     }
   }
+  return {x.GetUltimate()};
+}
 auto GetSymbolVectorHelper::operator()(const Component &x) const -> Result {
   Result result{(*this)(x.base())};
   result.emplace_back(x.GetLastSymbol());
   return result;
 }
 auto GetSymbolVectorHelper::operator()(const ArrayRef &x) const -> Result {
   return GetSymbolVector(x.base());
 }
return common::visit(
           [](const auto &) { return false; }},
       ResolveAssociations(symbol).details());
 }
 
 bool IsAssumedShape(const Symbol &symbol) {
   const Symbol &ultimate{ResolveAssociations(symbol)};
   const auto *object{ultimate.detailsIf<ObjectEntityDetails>()};
   return object && object->CanBeAssumedShape() &&
-      !evaluate::IsAllocatableOrPointer(ultimate);
+      !semantics::IsAllocatableOrPointer(ultimate);
 }
 
 bool IsDeferredShape(const Symbol &symbol) {
   const Symbol &ultimate{ResolveAssociations(symbol)};
   const auto *object{ultimate.detailsIf<ObjectEntityDetails>()};
   return object && object->CanBeDeferredShape() &&
-      evaluate::IsAllocatableOrPointer(ultimate);
+      semantics::IsAllocatableOrPointer(ultimate);
 }
 
 bool IsFunctionResult(const Symbol &original) {
   const Symbol &symbol{GetAssociationRoot(original)};
   return common::visit(
       common::visitors{
           [](const EntityDetails &x) { return x.isFuncResult(); },
           [](const ObjectEntityDetails &x) { return x.isFuncResult(); },

flang/lib/Lower/HostAssociations.cpp

if (isDerivedWithLenParameters(sym))
     TODO(converter.genLocation(sym.name()),
          "host associated derived type with length parameters");
   Fortran::lower::BoxAnalyzer ba;
   // Do not analyze procedures, they may be subroutines with no types that would
   // crash the analysis.
   if (Fortran::semantics::IsProcedure(sym))
     return CapturedProcedure::visit(visitor, converter, sym, ba);
   ba.analyze(sym);
-  if (Fortran::evaluate::IsAllocatableOrPointer(sym))
+  if (Fortran::semantics::IsAllocatableOrPointer(sym))
     return CapturedAllocatableAndPointer::visit(visitor, converter, sym, ba);
   if (ba.isArray())
     return CapturedArrays::visit(visitor, converter, sym, ba);
   if (ba.isChar())
     return CapturedCharacterScalars::visit(visitor, converter, sym, ba);
   assert(ba.isTrivial() && "must be trivial scalar");
   return CapturedSimpleScalars::visit(visitor, converter, sym, ba);
 }

flang/test/Semantics/associate01.f90

+! RUN: %python %S/test_errors.py %s %flang_fc1
+! Tests of selectors whose defining expressions are pointer-valued functions;
+! they must be valid targets, but not pointers.
+! (F'2018 11.1.3.3 p1) "The associating entity does not have the ALLOCATABLE or
+! POINTER attributes; it has the TARGET attribute if and only if the selector
+! is a variable and has either the TARGET or POINTER attribute."
+module m1
+  type t
+   contains
+    procedure, nopass :: iptr
+  end type
+ contains
+  function iptr(n)
+    integer, intent(in), target :: n
+    integer, pointer :: iptr
+    iptr => n
+  end function
+  subroutine test
+    type(t) tv
+    integer, target :: itarget
+    integer, pointer :: ip
+    associate (sel => iptr(itarget))
+      ip => sel
+      !ERROR: POINTER= argument of ASSOCIATED() must be a POINTER
+      if (.not. associated(sel)) stop
+    end associate
+    associate (sel => tv%iptr(itarget))
+      ip => sel
+      !ERROR: POINTER= argument of ASSOCIATED() must be a POINTER
+      if (.not. associated(sel)) stop
+    end associate
+    associate (sel => (iptr(itarget)))
+      !ERROR: In assignment to object pointer 'ip', the target 'sel' is not an object with POINTER or TARGET attributes
+      ip => sel
+      !ERROR: POINTER= argument of ASSOCIATED() must be a POINTER
+      if (.not. associated(sel)) stop
+    end associate
+    associate (sel => 0 + iptr(itarget))
+      !ERROR: In assignment to object pointer 'ip', the target 'sel' is not an object with POINTER or TARGET attributes
+      ip => sel
+      !ERROR: POINTER= argument of ASSOCIATED() must be a POINTER
+      if (.not. associated(sel)) stop
+    end associate
+  end subroutine
+end module