[flang] Correct disambiguation of possible statement function definitions

[klausler]

Summary

The statement "A(J) = expr" could be an assignment to an element of an
array A, an assignment to the target of a pointer-valued function A, or
the definition of a new statement function in the local scope named A,
depending on whether it appears in (what might still be) the specification
part of a program or subprogram and what other declarations and definitions
for A might exist in the local scope or have been imported into it.

The standard requires that the name of a statement function appear in
an earlier type declaration statement if it is also the name of an
entity in the enclosing scope. Some other Fortran compilers mistakenly
enforce that rule in the case of an assignment to the target of a
pointer-valued function in the containing scope, after misinterpreting
the assignment as a new local statement function definition.

This patch cleans up the handling of the various possibilities and
resolves what was a crash in the case of a statement function definition
whose name was the same as that of a procedure in the outer scope whose
result is *not* a pointer.

[PeteSteinfeld]

All builds and tests correctly and looks good.

flang/include/flang/Semantics/tools.h

void WarnOnDeferredLengthCharacterScalar(SemanticsContext &, const SomeExpr *,
     parser::CharBlock at, const char *what);
 
 inline const parser::Name *getDesignatorNameIfDataRef(
     const parser::Designator &designator) {
   const auto *dataRef{std::get_if<parser::DataRef>(&designator.u)};
   return dataRef ? std::get_if<parser::Name>(&dataRef->u) : nullptr;
 }
 
+bool CouldBeDataPointerValuedFunction(const Symbol *);
+
 } // namespace Fortran::semantics
 #endif // FORTRAN_SEMANTICS_TOOLS_H_

flang/lib/Semantics/resolve-names.cpp

public:
   bool BeginMpSubprogram(const parser::Name &);
   void PushBlockDataScope(const parser::Name &);
   void EndSubprogram(std::optional<parser::CharBlock> stmtSource = std::nullopt,
       const std::optional<parser::LanguageBindingSpec> * = nullptr,
       const ProgramTree::EntryStmtList * = nullptr);
 
 protected:
   // Set when we see a stmt function that is really an array element assignment
-  bool badStmtFuncFound_{false};
+  bool misparsedStmtFuncFound_{false};
 
 private:
   // Edits an existing symbol created for earlier calls to a subprogram or ENTRY
   // so that it can be replaced by a later definition.
   bool HandlePreviousCalls(const parser::Name &, Symbol &, Symbol::Flag);
   void CheckExtantProc(const parser::Name &, Symbol::Flag);
   // Create a subprogram symbol in the current scope and push a new scope.
   Symbol &PushSubprogramScope(const parser::Name &, Symbol::Flag,
if (auto *symbol{scope.symbol()}) {
         } else {
           newSymbol.set_details(MiscDetails{MiscDetails::Kind::ScopeName});
         }
       }
     }
   }
 }
 void ScopeHandler::PopScope() {
+  CHECK(currScope_ && !currScope_->IsGlobal());
   // Entities that are not yet classified as objects or procedures are now
   // assumed to be objects.
   // TODO: Statement functions
   for (auto &pair : currScope()) {
     ConvertToObjectEntity(*pair.second);
   }
   funcResultStack_.Pop();
   // If popping back into a global scope, pop back to the main global scope.

 // SubprogramVisitor implementation
 
 // Return false if it is actually an assignment statement.
 bool SubprogramVisitor::HandleStmtFunction(const parser::StmtFunctionStmt &x) {
   const auto &name{std::get<parser::Name>(x.t)};
   const DeclTypeSpec *resultType{nullptr};
   // Look up name: provides return type or tells us if it's an array
   if (auto *symbol{FindSymbol(name)}) {
-    auto *details{symbol->detailsIf<EntityDetails>()};
-    if (!details || symbol->has<ObjectEntityDetails>() ||
-        symbol->has<ProcEntityDetails>()) {
-      badStmtFuncFound_ = true;
+    Symbol &ultimate{symbol->GetUltimate()};
+    if (ultimate.has<ObjectEntityDetails>() ||
+        CouldBeDataPointerValuedFunction(&ultimate)) {
+      misparsedStmtFuncFound_ = true;
       return false;
     }
-    // TODO: check that attrs are compatible with stmt func
-    resultType = details->type();
-    symbol->details() = UnknownDetails{}; // will be replaced below
+    if (DoesScopeContain(&ultimate.owner(), currScope())) {
+      Say(name,
+          "Name '%s' from host scope should have a type declaration before its local statement function definition"_port_en_US);
+      MakeSymbol(name, Attrs{}, UnknownDetails{});
+    } else if (auto *entity{ultimate.detailsIf<EntityDetails>()};
+               entity && !ultimate.has<ProcEntityDetails>()) {
+      resultType = entity->type();
+      ultimate.details() = UnknownDetails{}; // will be replaced below
+    } else {
+      misparsedStmtFuncFound_ = true;
+    }
   }
-  if (badStmtFuncFound_) {
-    Say(name, "'%s' has not been declared as an array"_err_en_US);
+  if (misparsedStmtFuncFound_) {
+    Say(name,
+        "'%s' has not been declared as an array or pointer-valued function"_err_en_US);
     return false;
   }
   auto &symbol{PushSubprogramScope(name, Symbol::Flag::Function)};
   symbol.set(Symbol::Flag::StmtFunction);
   EraseSymbol(symbol); // removes symbol added by PushSubprogramScope
   auto &details{symbol.get<SubprogramDetails>()};
   for (const auto &dummyName : std::get<std::list<parser::Name>>(x.t)) {
     ObjectEntityDetails dummyDetails{true};
if (&existing->owner() == &currScope()) {
       EraseSymbol(*existing);
     }
   }
   info.Resolve(&MakeSymbol(symbolName, Attrs{}, std::move(genericDetails)));
 }
 
 void ResolveNamesVisitor::FinishSpecificationPart(
     const std::list<parser::DeclarationConstruct> &decls) {
-  badStmtFuncFound_ = false;
+  misparsedStmtFuncFound_ = false;
   funcResultStack().CompleteFunctionResultType();
   CheckImports();
   bool inModule{currScope().kind() == Scope::Kind::Module};
   for (auto &pair : currScope()) {
     auto &symbol{*pair.second};
     if (NeedsExplicitType(symbol)) {
       ApplyImplicitRules(symbol);
     }

 // specification part have been fully declared and implicitly typed.
 // (Statement function references are not allowed in specification
 // expressions, so it's safe to defer processing their definitions.)
 void ResolveNamesVisitor::AnalyzeStmtFunctionStmt(
     const parser::StmtFunctionStmt &stmtFunc) {
   const auto &name{std::get<parser::Name>(stmtFunc.t)};
   Symbol *symbol{name.symbol};
   auto *details{symbol ? symbol->detailsIf<SubprogramDetails>() : nullptr};
-  if (!details || !symbol->scope()) {
-    return;
+  if (!details || !symbol->scope() ||
+      &symbol->scope()->parent() != &currScope()) {
+    return; // error recovery
   }
   // Resolve the symbols on the RHS of the statement function.
   PushScope(*symbol->scope());
   const auto &parsedExpr{std::get<parser::Scalar<parser::Expr>>(stmtFunc.t)};
   Walk(parsedExpr);
   PopScope();
   if (auto expr{AnalyzeExpr(context(), stmtFunc)}) {
     if (auto type{evaluate::DynamicType::From(*symbol)}) {

 void ResolveNamesVisitor::Post(const parser::TypeGuardStmt &x) {
   DeclTypeSpecVisitor::Post(x);
   ConstructVisitor::Post(x);
 }
 bool ResolveNamesVisitor::Pre(const parser::StmtFunctionStmt &x) {
   if (HandleStmtFunction(x)) {
     return false;
   } else {
-    // This is an array element assignment: resolve names of indices
+    // This is an array element or pointer-valued function assignment:
+    // resolve the names of indices/arguments
     const auto &names{std::get<std::list<parser::Name>>(x.t)};
     for (auto &name : names) {
       ResolveName(name);
     }
     return true;
   }
 }
 

flang/lib/Semantics/tools.cpp

if (const Symbol *
         context.Say(at,
             "The deferred length allocatable character scalar variable '%s' may be reallocated to a different length under the new Fortran 202X standard semantics for %s"_port_en_US,
             symbol->name(), what);
       }
     }
   }
 }
 
+bool CouldBeDataPointerValuedFunction(const Symbol *original) {
+  if (original) {
+    const Symbol &ultimate{original->GetUltimate()};
+    if (const Symbol * result{FindFunctionResult(ultimate)}) {
+      return IsPointer(*result) && !IsProcedure(*result);
+    }
+    if (const auto *generic{ultimate.detailsIf<GenericDetails>()}) {
+      for (const SymbolRef &ref : generic->specificProcs()) {
+        if (CouldBeDataPointerValuedFunction(&*ref)) {
+          return true;
+        }
+      }
+    }
+  }
+  return false;
+}
+
 } // namespace Fortran::semantics

flang/test/Semantics/resolve08.f90

 ! RUN: %python %S/test_errors.py %s %flang_fc1
 integer :: g(10)
 f(i) = i + 1  ! statement function
-g(i) = i + 2  ! mis-parsed array assignment
-!ERROR: 'h' has not been declared as an array
+g(i) = i + 2  ! mis-parsed assignment
+!ERROR: 'h' has not been declared as an array or pointer-valued function
 h(i) = i + 3
 end

flang/test/Semantics/stmt-func02.f90

+! RUN: %python %S/test_errors.py %s %flang_fc1
+module m
+  real, target :: x = 1.
+ contains
+  function rpf(x)
+    real, intent(in out), target :: x
+    real, pointer :: rpf
+    rpf => x
+  end
+  real function rf(x)
+    rf = x
+  end
+  subroutine test1
+    ! This is a valid assignment, not a statement function.
+    ! Every other Fortran compiler misinterprets it!
+    rpf(x) = 2. ! statement function or indirect assignment?
+    print *, x
+  end
+  subroutine test2
+    !PORTABILITY: Name 'rf' from host scope should have a type declaration before its local statement function definition
+    rf(x) = 3.
+  end
+  subroutine test3
+    external sf
+    !ERROR: 'sf' has not been declared as an array or pointer-valued function
+    sf(x) = 4.
+  end
+end