[flang] Correct disambiguation of possible statement function definitions

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

diff --git a/flang/include/flang/Semantics/tools.h b/flang/include/flang/Semantics/tools.h
index 8ce7970..acd34e9 100644 (file)
--- a/flang/include/flang/Semantics/tools.h
+++ b/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_

diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp
index f6b1759..dfff045 100644 (file)
--- a/flang/lib/Semantics/resolve-names.cpp
+++ b/flang/lib/Semantics/resolve-names.cpp
@@ -879,7 +879,7 @@ public:
 
 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);

diff --git a/flang/lib/Semantics/tools.cpp b/flang/lib/Semantics/tools.cpp
index 891d23d..e569e7e 100644 (file)
--- a/flang/lib/Semantics/tools.cpp
+++ b/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

diff --git a/flang/test/Semantics/resolve08.f90 b/flang/test/Semantics/resolve08.f90
index b485f4c..e9ada06 100644 (file)
--- a/flang/test/Semantics/resolve08.f90
+++ b/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

diff --git a/flang/test/Semantics/stmt-func02.f90 b/flang/test/Semantics/stmt-func02.f90
new file mode 100644 (file)
index 0000000..5d76890
--- /dev/null
+++ b/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