[flang] Selectors whose expressions are pointers returned from functi…

…ons are valid targets

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).

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

flang/docs/Extensions.md

@@ -343,6 +343,13 @@ end
   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
 

flang/include/flang/Evaluate/tools.h

@@ -893,8 +893,13 @@ template <typename A> const Symbol *GetLastSymbol(const A &x) {
   }
 }
 
-// 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();
@@ -903,6 +908,37 @@ template <typename A> semantics::Attrs GetAttrs(const A &x) {
   }
 }
 
+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;
@@ -924,14 +960,8 @@ std::optional<BaseObject> GetBaseObject(const std::optional<A> &x) {
   }
 }
 
-// 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> &);
@@ -946,8 +976,6 @@ 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 &);

flang/lib/Evaluate/tools.cpp

@@ -861,10 +861,12 @@ bool IsBareNullPointer(const Expr<SomeType> *expr) {
 // GetSymbolVector()
 auto GetSymbolVectorHelper::operator()(const Symbol &x) const -> Result {
   if (const auto *details{x.detailsIf<semantics::AssocEntityDetails>()}) {
-    return (*this)(details->expr());
-  } else {
-    return {x.GetUltimate()};
+    if (IsVariable(details->expr()) && !GetProcedureRef(*details->expr())) {
+      // associate(x => variable that is not a pointer returned by a function)
+      return (*this)(details->expr());
+    }
   }
+  return {x.GetUltimate()};
 }
 auto GetSymbolVectorHelper::operator()(const Component &x) const -> Result {
   Result result{(*this)(x.base())};
@@ -1475,14 +1477,14 @@ 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) {

flang/lib/Lower/HostAssociations.cpp

@@ -447,7 +447,7 @@ walkCaptureCategories(T visitor, Fortran::lower::AbstractConverter &converter,
   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);

flang/test/Semantics/associate01.f90

@@ -0,0 +1,45 @@
+! 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