[flang] Ensure pointer function results are acceptable variables

[klausler]

Summary

Fortran permits a reference to a function whose result is a pointer
to be used as a definable variable in any context where a
designator could appear. This patch wrings out remaining bugs
with such usage and adds more testing.

The utility predicate IsProcedurePointer(expr) had a misleading
name which has been corrected to IsProcedurePointerTarget(expr).

[PeteSteinfeld]

These changes build and look good. When I run the regression tests, I'm now getting four failures, but I get the same failures on the checked in source. Nothing seems to be related to this change.

flang/include/flang/Evaluate/tools.h

 template <typename A> bool IsAllocatableOrPointer(const A &x) {
   return GetAttrs(x).HasAny(
       semantics::Attrs{semantics::Attr::POINTER, semantics::Attr::ALLOCATABLE});
 }
 
 // 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 IsNullPointer(const Expr<SomeType> &);
 bool IsObjectPointer(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
     : public Traverse<GetSymbolVectorHelper, SymbolVector> {

 // while GetAssociationRoot(x) returns y.)
 const Symbol &ResolveAssociations(const Symbol &);
 const Symbol &GetAssociationRoot(const Symbol &);
 
 const Symbol *FindCommonBlockContaining(const Symbol &);
 int CountLenParameters(const DerivedTypeSpec &);
 int CountNonConstantLenParameters(const DerivedTypeSpec &);
 const Symbol &GetUsedModule(const UseDetails &);
+const Symbol *FindFunctionResult(const Symbol &);
 
 } // namespace Fortran::semantics
 
 #endif // FORTRAN_EVALUATE_TOOLS_H_

flang/lib/Evaluate/intrinsics.cpp

if (!type) {
         } else {
           const IntrinsicDummyArgument &nextParam{dummy[j + 1]};
           messages.Say(
               "Typeless (BOZ) not allowed for both '%s=' & '%s=' arguments"_err_en_US, // C7109
               d.keyword, nextParam.keyword);
         }
       } else {
         // NULL(), procedure, or procedure pointer
-        CHECK(IsProcedurePointer(expr));
+        CHECK(IsProcedurePointerTarget(expr));
         if (d.typePattern.kindCode == KindCode::addressable ||
             d.rank == Rank::reduceOperation) {
           continue;
         } else if (d.typePattern.kindCode == KindCode::nullPointerType) {
           continue;
         } else {
           messages.Say(
               "Actual argument for '%s=' may not be a procedure"_err_en_US,
SpecificCall IntrinsicProcTable::Implementation::HandleNull(
   static const char *const keywords[]{"mold", nullptr};
   if (CheckAndRearrangeArguments(arguments, context.messages(), keywords, 1) &&
       arguments[0]) {
     if (Expr<SomeType> * mold{arguments[0]->UnwrapExpr()}) {
       bool goodProcPointer{true};
       if (IsAllocatableOrPointer(*mold)) {
         characteristics::DummyArguments args;
         std::optional<characteristics::FunctionResult> fResult;
-        if (IsProcedurePointer(*mold)) {
+        if (IsProcedurePointerTarget(*mold)) {
           // MOLD= procedure pointer
           const Symbol *last{GetLastSymbol(*mold)};
           CHECK(last);
           auto procPointer{
               characteristics::Procedure::Characterize(*last, context)};
           // procPointer is null if there was an error with the analysis
           // associated with the procedure pointer
           if (procPointer) {

flang/lib/Evaluate/tools.cpp

return std::visit(
           },
       },
       substring.parent());
 }
 
 // IsVariable()
 
 auto IsVariableHelper::operator()(const Symbol &symbol) const -> Result {
-  return !symbol.attrs().test(semantics::Attr::PARAMETER);
+  const Symbol &root{GetAssociationRoot(symbol)};
+  return !IsNamedConstant(root) && root.has<semantics::ObjectEntityDetails>();
 }
 auto IsVariableHelper::operator()(const Component &x) const -> Result {
-  return (*this)(x.base());
+  const Symbol &comp{x.GetLastSymbol()};
+  return (*this)(comp) && (IsPointer(comp) || (*this)(x.base()));
 }
 auto IsVariableHelper::operator()(const ArrayRef &x) const -> Result {
   return (*this)(x.base());
 }
 auto IsVariableHelper::operator()(const Substring &x) const -> Result {
   return (*this)(x.GetBaseObject());
 }
 auto IsVariableHelper::operator()(const ProcedureDesignator &x) const
     -> Result {
-  const Symbol *symbol{x.GetSymbol()};
-  return symbol && IsPointer(*symbol);
+  if (const Symbol * symbol{x.GetSymbol()}) {
+    const Symbol *result{FindFunctionResult(*symbol)};
+    return result && IsPointer(*result) && !IsProcedurePointer(*result);
+  }
+  return false;
 }
 
 // Conversions of COMPLEX component expressions to REAL.
 ConvertRealOperandsResult ConvertRealOperands(
     parser::ContextualMessages &messages, Expr<SomeType> &&x,
     Expr<SomeType> &&y, int defaultRealKind) {
   return std::visit(
       common::visitors{

 bool IsProcedure(const Expr<SomeType> &expr) {
   return std::holds_alternative<ProcedureDesignator>(expr.u);
 }
 bool IsFunction(const Expr<SomeType> &expr) {
   const auto *designator{std::get_if<ProcedureDesignator>(&expr.u)};
   return designator && designator->GetType().has_value();
 }
 
-bool IsProcedurePointer(const Expr<SomeType> &expr) {
+bool IsProcedurePointerTarget(const Expr<SomeType> &expr) {
   return std::visit(common::visitors{
                         [](const NullPointer &) { return true; },
                         [](const ProcedureDesignator &) { return true; },
                         [](const ProcedureRef &) { return true; },
-                        [](const auto &) { return false; },
+                        [&](const auto &) {
+                          const Symbol *last{GetLastSymbol(expr)};
+                          return last && IsProcedurePointer(*last);
+                        },
                     },
       expr.u);
 }
 
 template <typename A> inline const ProcedureRef *UnwrapProcedureRef(const A &) {
   return nullptr;
 }
 
 template <typename T>
 inline const ProcedureRef *UnwrapProcedureRef(const FunctionRef<T> &func) {
   return &func;
 }
 
 template <typename T>
 inline const ProcedureRef *UnwrapProcedureRef(const Expr<T> &expr) {
   return std::visit(
       [](const auto &x) { return UnwrapProcedureRef(x); }, expr.u);
 }
 
 // IsObjectPointer()
 bool IsObjectPointer(const Expr<SomeType> &expr, FoldingContext &context) {
   if (IsNullPointer(expr)) {
     return true;
-  } else if (IsProcedurePointer(expr)) {
+  } else if (IsProcedurePointerTarget(expr)) {
     return false;
-  } else if (const auto *procRef{UnwrapProcedureRef(expr)}) {
-    auto proc{
-        characteristics::Procedure::Characterize(procRef->proc(), context)};
-    return proc && proc->functionResult &&
-        proc->functionResult->attrs.test(
-            characteristics::FunctionResult::Attr::Pointer);
+  } else if (const auto *funcRef{UnwrapProcedureRef(expr)}) {
+    return IsVariable(*funcRef);
   } else if (const Symbol * symbol{GetLastSymbol(expr)}) {
     return IsPointer(symbol->GetUltimate());
   } else {
     return false;
   }
 }
 
 // IsNullPointer()

 
 const Symbol *FindCommonBlockContaining(const Symbol &original) {
   const Symbol &root{GetAssociationRoot(original)};
   const auto *details{root.detailsIf<ObjectEntityDetails>()};
   return details ? details->commonBlock() : nullptr;
 }
 
 bool IsProcedurePointer(const Symbol &original) {
-  const Symbol &symbol{original.GetUltimate()};
+  const Symbol &symbol{GetAssociationRoot(original)};
   return symbol.has<ProcEntityDetails>() && IsPointer(symbol);
 }
 
 bool IsSaved(const Symbol &original) {
   const Symbol &symbol{GetAssociationRoot(original)};
   const Scope &scope{symbol.owner()};
   auto scopeKind{scope.kind()};
   if (symbol.has<AssocEntityDetails>()) {
return std::count_if(
         }
       });
 }
 
 const Symbol &GetUsedModule(const UseDetails &details) {
   return DEREF(details.symbol().owner().symbol());
 }
 
+static const Symbol *FindFunctionResult(
+    const Symbol &original, SymbolSet &seen) {
+  const Symbol &root{GetAssociationRoot(original)};
+  ;
+  if (!seen.insert(root).second) {
+    return nullptr; // don't loop
+  }
+  return std::visit(
+      common::visitors{[](const SubprogramDetails &subp) {
+                         return subp.isFunction() ? &subp.result() : nullptr;
+                       },
+          [&](const ProcEntityDetails &proc) {
+            const Symbol *iface{proc.interface().symbol()};
+            return iface ? FindFunctionResult(*iface, seen) : nullptr;
+          },
+          [&](const ProcBindingDetails &binding) {
+            return FindFunctionResult(binding.symbol(), seen);
+          },
+          [](const auto &) -> const Symbol * { return nullptr; }},
+      root.details());
+}
+
+const Symbol *FindFunctionResult(const Symbol &symbol) {
+  SymbolSet seen;
+  return FindFunctionResult(symbol, seen);
+}
+
 } // namespace Fortran::semantics

flang/lib/Semantics/check-call.cpp

if (auto argChars{characteristics::DummyArgument::FromActual(
               }
             }
           }
         } else {
           messages.Say(
               "Actual argument associated with procedure %s is not a procedure"_err_en_US,
               dummyName);
         }
-      } else if (!(dummyIsPointer && IsNullPointer(*expr))) {
+      } else if (IsNullPointer(*expr)) {
+        if (!dummyIsPointer) {
           messages.Say(
-            "Actual argument associated with procedure %s is not a procedure"_err_en_US,
+              "Actual argument associated with procedure %s is a null pointer"_err_en_US,
               dummyName);
         }
+      } else {
+        messages.Say(
+            "Actual argument associated with procedure %s is typeless"_err_en_US,
+            dummyName);
       }
-    if (interface.HasExplicitInterface()) {
-      if (dummyIsPointer) {
+    }
+    if (interface.HasExplicitInterface() && dummyIsPointer &&
+        proc.intent != common::Intent::In) {
+      const Symbol *last{GetLastSymbol(*expr)};
+      if (!(last && IsProcedurePointer(*last))) {
         // 15.5.2.9(5) -- dummy procedure POINTER
         // Interface compatibility has already been checked above by comparison.
-        if (proc.intent != common::Intent::In && !IsVariable(*expr)) {
-          messages.Say(
-              "Actual argument associated with procedure pointer %s must be a POINTER unless INTENT(IN)"_err_en_US,
-              dummyName);
-        }
-      } else { // 15.5.2.9(4) -- dummy procedure is not POINTER
-        if (!argProcDesignator) {
-          messages.Say(
-              "Actual argument associated with non-POINTER procedure %s must be a procedure (and not a procedure pointer)"_err_en_US,
-              dummyName);
-        }
-      }
     }
   } else {
     messages.Say(
         "Assumed-type argument may not be forwarded as procedure %s"_err_en_US,
         dummyName);
   }
 }
 

flang/lib/Semantics/check-io.cpp

void IoChecker::Enter(const parser::MsgVariable &var) {
   CheckForDefinableVariable(var, "IOMSG");
   SetSpecifier(IoSpecKind::Iomsg);
 }
 
 void IoChecker::Enter(const parser::OutputItem &item) {
   flags_.set(Flag::DataList);
   if (const auto *x{std::get_if<parser::Expr>(&item.u)}) {
     if (const auto *expr{GetExpr(*x)}) {
-      if (IsProcedurePointer(*expr)) {
+      const Symbol *last{GetLastSymbol(*expr)};
+      if (last && IsProcedurePointer(*last)) {
         context_.Say(parser::FindSourceLocation(*x),
             "Output item must not be a procedure pointer"_err_en_US); // C1233
       }
     }
   }
 }
 
 void IoChecker::Enter(const parser::StatusExpr &spec) {
void IoChecker::CheckForProhibitedSpecifier(
   if (condition && specifierSet_.test(specKind)) {
     context_.Say("If %s appears, %s must not appear"_err_en_US, s,
         parser::ToUpperCaseLetters(common::EnumToString(specKind)));
   }
 }
 
 template <typename A>
 void IoChecker::CheckForDefinableVariable(
-    const A &var, const std::string &s) const {
-  const Symbol *sym{
-      GetFirstName(*parser::Unwrap<parser::Variable>(var)).symbol};
-  if (auto whyNot{
-          WhyNotModifiable(*sym, context_.FindScope(*context_.location()))}) {
-    auto at{parser::FindSourceLocation(var)};
+    const A &variable, const std::string &s) const {
+  if (const auto *var{parser::Unwrap<parser::Variable>(variable)}) {
+    if (auto expr{AnalyzeExpr(context_, *var)}) {
+      auto at{var->GetSource()};
+      if (auto whyNot{WhyNotModifiable(at, *expr, context_.FindScope(at))}) {
+        const Symbol *base{GetFirstSymbol(*expr)};
         context_
-        .Say(at, "%s variable '%s' must be definable"_err_en_US, s, sym->name())
-        .Attach(at, std::move(*whyNot), sym->name());
+            .Say(at, "%s variable '%s' must be definable"_err_en_US, s,
+                (base ? base->name() : at).ToString())
+            .Attach(std::move(*whyNot));
+      }
+    }
   }
 }
 
 void IoChecker::CheckForPureSubprogram() const { // C1597
   CHECK(context_.location());
   if (FindPureProcedureContaining(context_.FindScope(*context_.location()))) {
     context_.Say("External I/O is not allowed in a pure subprogram"_err_en_US);
   }
 }
 
 } // namespace Fortran::semantics

flang/lib/Semantics/expression.cpp

return std::visit(
             } else if (auto actualType{actual.GetType()}) {
               return x.type.type().IsTkCompatibleWith(*actualType);
             } else {
               return false;
             }
           },
           [&](const characteristics::DummyProcedure &) {
             const auto *expr{actual.UnwrapExpr()};
-            return expr && IsProcedurePointer(*expr);
+            return expr && IsProcedurePointerTarget(*expr);
           },
           [&](const characteristics::AlternateReturn &) {
             return actual.isAlternateReturn();
           },
       },
       dummy.u);
 }
 

flang/lib/Semantics/tools.cpp

std::optional<parser::MessageFixedText> WhyNotModifiable(
   } else {
     return std::nullopt;
   }
 }
 
 // Modifiability checks for a data-ref
 std::optional<parser::Message> WhyNotModifiable(parser::CharBlock at,
     const SomeExpr &expr, const Scope &scope, bool vectorSubscriptIsOk) {
-  if (!evaluate::IsVariable(expr)) {
-    return parser::Message{at, "Expression is not a variable"_en_US};
-  } else if (auto dataRef{evaluate::ExtractDataRef(expr, true)}) {
+  if (auto dataRef{evaluate::ExtractDataRef(expr, true)}) {
     if (!vectorSubscriptIsOk && evaluate::HasVectorSubscript(expr)) {
       return parser::Message{at, "Variable has a vector subscript"_en_US};
     }
     const Symbol &first{GetAssociationRoot(dataRef->GetFirstSymbol())};
     if (auto maybeWhyFirst{WhyNotModifiableFirst(first, scope)}) {
       return parser::Message{first.name(),
           parser::MessageFormattedText{
               std::move(*maybeWhyFirst), first.name()}};
     }
     const Symbol &last{dataRef->GetLastSymbol()};
     if (auto maybeWhyLast{WhyNotModifiableLast(last, scope)}) {
       return parser::Message{last.name(),
           parser::MessageFormattedText{std::move(*maybeWhyLast), last.name()}};
     }
     if (!GetLastPointerSymbol(*dataRef)) {
       if (auto maybeWhyFirst{WhyNotModifiableIfNoPtr(first, scope)}) {
         return parser::Message{first.name(),
             parser::MessageFormattedText{
                 std::move(*maybeWhyFirst), first.name()}};
       }
     }
+  } else if (!evaluate::IsVariable(expr)) {
+    return parser::Message{
+        at, "'%s' is not a variable"_en_US, expr.AsFortran()};
   } else {
     // reference to function returning POINTER
   }
   return std::nullopt;
 }
 
 class ImageControlStmtHelper {
   using ImageControlStmts = std::variant<parser::ChangeTeamConstruct,

flang/test/Semantics/call02.f90

subroutine badsubr(dummy)
       !ERROR: A dummy procedure may not be ELEMENTAL
       procedure(elem) :: dummy
     end subroutine
   end interface
   intrinsic :: cos
   call subr(cos) ! not an error
   !ERROR: Non-intrinsic ELEMENTAL procedure 'elem' may not be passed as an actual argument
   call subr(elem) ! C1533
-  !ERROR: Actual argument associated with procedure dummy argument 'dummy=' is not a procedure
-  !ERROR: Actual argument associated with non-POINTER procedure dummy argument 'dummy=' must be a procedure (and not a procedure pointer)
+  !ERROR: Actual argument associated with procedure dummy argument 'dummy=' is a null pointer
   call subr(null())
-  !ERROR: Actual argument associated with procedure dummy argument 'dummy=' is not a procedure
-  !ERROR: Actual argument associated with non-POINTER procedure dummy argument 'dummy=' must be a procedure (and not a procedure pointer)
+  !ERROR: Actual argument associated with procedure dummy argument 'dummy=' is typeless
   call subr(B"1010")
 end subroutine
 
 module m01
   procedure(sin) :: elem01
   interface
     elemental real function elem02(x)
       real, value :: x

flang/test/Semantics/call09.f90

subroutine test1 ! 15.5.2.9(5)
     call s01(intprocptr())
     call s01(null()) ! ok
     call s01(null(p)) ! ok
     !ERROR: Actual procedure argument has interface incompatible with dummy argument 'p='
     call s01(null(ip))
     call s01(sin) ! ok
     !ERROR: Actual argument associated with procedure dummy argument 'p=' is not a procedure
     call s01(null(intPtr))
-    !ERROR: Actual argument associated with procedure dummy argument 'p=' is not a procedure
+    !ERROR: Actual argument associated with procedure dummy argument 'p=' is typeless
     call s01(B"0101")
     !ERROR: Actual procedure argument has an implicit interface which is not known to be compatible with dummy argument 'p=' which has an explicit interface
     call s01(extfunc)
     !ERROR: Actual argument associated with procedure pointer dummy argument 'p=' must be a POINTER unless INTENT(IN)
     call s02(realfunc)
     call s02(p) ! ok
     !ERROR: Actual procedure argument has interface incompatible with dummy argument 'p='
     call s02(ip)

flang/test/Semantics/call18.f90

+! RUN: %S/test_errors.sh %s %t %f18
+! Ensure that references to functions that return pointers can serve as
+! "variables" in actual arguments.  All of these uses are conforming and
+! no errors should be reported.
+module m
+  integer, target :: x = 1
+ contains
+  function get() result(p)
+    integer, pointer :: p
+    p => x
+  end function get
+  subroutine increment(n)
+    integer, intent(inout) :: n
+    n = n + 1
+  end subroutine increment
+end module m
+
+use m
+integer, pointer :: q
+get() = 2
+call increment(get())
+q => get()
+read(*) get()
+open(file='file',newunit=get())
+allocate(q,stat=get())
+end

flang/test/Semantics/modifiable01.f90

associate (a => arr([1])) ! vector subscript
       !CHECK: error: Input variable 'a' must be definable
       !CHECK: 'a' is construct associated with an expression
       read(internal,*) a
     end associate
     associate (a => arr(2:1:-1))
       read(internal,*) a ! ok
     end associate
     !CHECK: error: Input variable 'j3' must be definable
-    !CHECK: 'j3' is not a variable
+    !CHECK: '666_4' is not a variable
     read(internal,*) j3
     !CHECK: error: Left-hand side of assignment is not modifiable
     !CHECK: 't2var' is an entity with either an EVENT_TYPE or LOCK_TYPE
     t2var = t2static
     t2var%x2 = 0. ! ok
     !CHECK: error: Left-hand side of assignment is not modifiable
     !CHECK: 'prot' is protected in this scope
     prot = 0.