[flang] Correct disambiguation of possible statement function definit…

…ions

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.

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

flang/include/flang/Semantics/tools.h

@@ -662,5 +662,7 @@ inline const parser::Name *getDesignatorNameIfDataRef(
   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

@@ -879,7 +879,7 @@ class SubprogramVisitor : public virtual ScopeHandler, public InterfaceVisitor {
 
 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
@@ -2313,6 +2313,7 @@ void ScopeHandler::PushScope(Scope &scope) {
   }
 }
 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
@@ -3439,18 +3440,27 @@ bool SubprogramVisitor::HandleStmtFunction(const parser::StmtFunctionStmt &x) {
   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)};
@@ -7847,7 +7857,7 @@ void ResolveNamesVisitor::CreateGeneric(const parser::GenericSpec &x) {
 
 void ResolveNamesVisitor::FinishSpecificationPart(
     const std::list<parser::DeclarationConstruct> &decls) {
-  badStmtFuncFound_ = false;
+  misparsedStmtFuncFound_ = false;
   funcResultStack().CompleteFunctionResultType();
   CheckImports();
   bool inModule{currScope().kind() == Scope::Kind::Module};
@@ -7903,8 +7913,9 @@ void ResolveNamesVisitor::AnalyzeStmtFunctionStmt(
   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());
@@ -8031,7 +8042,8 @@ 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);

flang/lib/Semantics/tools.cpp

@@ -1629,4 +1629,21 @@ void WarnOnDeferredLengthCharacterScalar(SemanticsContext &context,
   }
 }
 
+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

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

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