[flang] Handle "type(foo) function f" when foo is defined in f

[klausler]

Summary

Fortran allows forward references to derived types, including
function results that are typed in a prefix of a FUNCTION statement.
If a type is defined in the body of the function, a reference to
that type from a prefix on the FUNCTION statement must resolve to
the local symbol, even and especially when that type shadows one
from the host scope.

The solution is to defer the processing of that type until the
end of the function's specification part. But the language doesn't
allow for forward references to other names in the prefix, so defer
the processing of the type only when it is not an intrinsic type.
The data structures in name resolution that track this information
for functions needed to become a stack in order to make this work,
since functions can contain interfaces that are functions.

[PeteSteinfeld]

This is a weird corner of the language.

All build and tests correctly and looks good.

flang/lib/Evaluate/tools.cpp

 }
 
 bool IsFunction(const Symbol &symbol) {
-  return std::visit(
-      common::visitors{
-          [](const SubprogramDetails &x) { return x.isFunction(); },
-          [&](const SubprogramNameDetails &) {
-            return symbol.test(Symbol::Flag::Function);
-          },
-          [](const ProcEntityDetails &x) {
-            const auto &ifc{x.interface()};
-            return ifc.type() || (ifc.symbol() && IsFunction(*ifc.symbol()));
-          },
-          [](const ProcBindingDetails &x) { return IsFunction(x.symbol()); },
-          [](const auto &) { return false; },
-      },
-      symbol.GetUltimate().details());
+  const Symbol &ultimate{symbol.GetUltimate()};
+  return ultimate.test(Symbol::Flag::Function) ||
+      std::visit(common::visitors{
+                     [](const SubprogramDetails &x) { return x.isFunction(); },
+                     [](const ProcEntityDetails &x) {
+                       const auto &ifc{x.interface()};
+                       return ifc.type() ||
+                           (ifc.symbol() && IsFunction(*ifc.symbol()));
+                     },
+                     [](const ProcBindingDetails &x) {
+                       return IsFunction(x.symbol());
+                     },
+                     [](const auto &) { return false; },
+                 },
+          ultimate.details());
 }
 
 bool IsFunction(const Scope &scope) {

flang/lib/Semantics/resolve-names.cpp

 
 class SubprogramVisitor : public virtual ScopeHandler, public InterfaceVisitor {
 public:
+  ~SubprogramVisitor();
   bool HandleStmtFunction(const parser::StmtFunctionStmt &);
   bool Pre(const parser::SubroutineStmt &);
   void Post(const parser::SubroutineStmt &);

   void Post(const parser::InterfaceBody::Function &);
   bool Pre(const parser::Suffix &);
   bool Pre(const parser::PrefixSpec &);
-  void Post(const parser::ImplicitPart &);
 
   bool BeginSubprogram(
       const parser::Name &, Symbol::Flag, bool hasModulePrefix = false);

   void EndSubprogram();
 
 protected:
+  void FinishFunctionResult();
   // Set when we see a stmt function that is really an array element assignment
   bool badStmtFuncFound_{false};
 
 private:
   // Info about the current function: parse tree of the type in the PrefixSpec;
   // name and symbol of the function result from the Suffix; source location.
-  struct {
+  struct FuncInfo {
     const parser::DeclarationTypeSpec *parsedType{nullptr};
     const parser::Name *resultName{nullptr};
     Symbol *resultSymbol{nullptr};
     std::optional<SourceName> source;
-  } funcInfo_;
+    bool inFunctionStmt{false}; // true between Pre/Post of FunctionStmt
+  };
+  std::vector<FuncInfo> funcInfoStack_;
 
   // Edits an existing symbol created for earlier calls to a subprogram or ENTRY
   // so that it can be replaced by a later definition.

   void ResolveSpecificationParts(ProgramTree &);
   void AddSubpNames(ProgramTree &);
   bool BeginScopeForNode(const ProgramTree &);
+  void EndScopeForNode(const ProgramTree &);
   void FinishSpecificationParts(const ProgramTree &);
   void FinishDerivedTypeInstantiation(Scope &);
   void ResolveExecutionParts(const ProgramTree &);

 
 // SubprogramVisitor implementation
 
+SubprogramVisitor::~SubprogramVisitor() { CHECK(funcInfoStack_.empty()); }
+
 // 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)};

 
 bool SubprogramVisitor::Pre(const parser::Suffix &suffix) {
   if (suffix.resultName) {
-    funcInfo_.resultName = &suffix.resultName.value();
+    if (IsFunction(currScope())) {
+      if (!funcInfoStack_.empty()) {
+        FuncInfo &info{funcInfoStack_.back()};
+        if (info.inFunctionStmt) {
+          info.resultName = &suffix.resultName.value();
+        } else {
+          // will check the result name in Post(EntryStmt)
+        }
+      }
+    } else {
+      Message &msg{Say(*suffix.resultName,
+          "RESULT(%s) may appear only in a function"_err_en_US)};
+      if (const Symbol * subprogram{InclusiveScope().symbol()}) {
+        msg.Attach(subprogram->name(), "Containing subprogram"_en_US);
+      }
+    }
   }
   return true;
 }

 bool SubprogramVisitor::Pre(const parser::PrefixSpec &x) {
   // Save this to process after UseStmt and ImplicitPart
   if (const auto *parsedType{std::get_if<parser::DeclarationTypeSpec>(&x.u)}) {
-    if (funcInfo_.parsedType) { // C1543
+    CHECK(!funcInfoStack_.empty());
+    FuncInfo &info{funcInfoStack_.back()};
+    if (info.parsedType) { // C1543
       Say(currStmtSource().value(),
           "FUNCTION prefix cannot specify the type more than once"_err_en_US);
       return false;
     } else {
-      funcInfo_.parsedType = parsedType;
-      funcInfo_.source = currStmtSource();
+      info.parsedType = parsedType;
+      info.source = currStmtSource();
       return false;
     }
   } else {

   }
 }
 
-void SubprogramVisitor::Post(const parser::ImplicitPart &) {
-  // If the function has a type in the prefix, process it now
-  if (funcInfo_.parsedType) {
-    messageHandler().set_currStmtSource(funcInfo_.source);
-    if (const auto *type{ProcessTypeSpec(*funcInfo_.parsedType, true)}) {
-      if (!context().HasError(funcInfo_.resultSymbol)) {
-        funcInfo_.resultSymbol->SetType(*type);
+void SubprogramVisitor::FinishFunctionResult() {
+  // If the function has a type in the prefix, process it now.
+  if (IsFunction(currScope())) {
+    CHECK(!funcInfoStack_.empty());
+    FuncInfo &info{funcInfoStack_.back()};
+    if (info.parsedType) {
+      messageHandler().set_currStmtSource(info.source);
+      if (const auto *type{ProcessTypeSpec(*info.parsedType, true)}) {
+        if (!context().HasError(info.resultSymbol)) {
+          info.resultSymbol->SetType(*type);
+        }
       }
+      info.parsedType = nullptr;
     }
   }
-  funcInfo_ = {};
 }
 
 bool SubprogramVisitor::Pre(const parser::InterfaceBody::Subroutine &x) {

   return BeginAttrs();
 }
 bool SubprogramVisitor::Pre(const parser::FunctionStmt &) {
+  CHECK(!funcInfoStack_.empty());
+  FuncInfo &info{funcInfoStack_.back()};
+  CHECK(!info.inFunctionStmt);
+  info.inFunctionStmt = true;
   return BeginAttrs();
 }
 bool SubprogramVisitor::Pre(const parser::EntryStmt &) { return BeginAttrs(); }

     details.add_dummyArg(dummy);
   }
   const parser::Name *funcResultName;
-  if (funcInfo_.resultName && funcInfo_.resultName->source != name.source) {
+  CHECK(!funcInfoStack_.empty());
+  FuncInfo &info{funcInfoStack_.back()};
+  CHECK(info.inFunctionStmt);
+  info.inFunctionStmt = false;
+  if (info.resultName && info.resultName->source != name.source) {
     // Note that RESULT is ignored if it has the same name as the function.
-    funcResultName = funcInfo_.resultName;
+    funcResultName = info.resultName;
   } else {
     EraseSymbol(name); // was added by PushSubprogramScope
     funcResultName = &name;

     // add function result to function scope
     EntityDetails funcResultDetails;
     funcResultDetails.set_funcResult(true);
-    funcInfo_.resultSymbol =
+    funcInfoStack_.back().resultSymbol =
         &MakeSymbol(*funcResultName, std::move(funcResultDetails));
-    details.set_result(*funcInfo_.resultSymbol);
+    details.set_result(*funcInfoStack_.back().resultSymbol);
   }
-
   // C1560.
-  if (funcInfo_.resultName && funcInfo_.resultName->source == name.source) {
-    Say(funcInfo_.resultName->source,
+  if (info.resultName && info.resultName->source == name.source) {
+    Say(info.resultName->source,
         "The function name should not appear in RESULT, references to '%s' "
-        "inside"
-        " the function will be considered as references to the result only"_en_US,
+        "inside the function will be considered as references to the "
+        "result only"_en_US,
         name.source);
     // RESULT name was ignored above, the only side effect from doing so will be
     // the inability to make recursive calls. The related parser::Name is still
     // resolved to the created function result symbol because every parser::Name
     // should be resolved to avoid internal errors.
-    Resolve(*funcInfo_.resultName, funcInfo_.resultSymbol);
+    Resolve(*info.resultName, info.resultSymbol);
   }
   name.symbol = currScope().symbol(); // must not be function result symbol
   // Clear the RESULT() name now in case an ENTRY statement in the implicit-part
   // has a RESULT() suffix.
-  funcInfo_.resultName = nullptr;
+  info.resultName = nullptr;
+  // If there was a type on the function statement, and it is an intrinsic
+  // type, process that type now so that inquiries in specification expressions
+  // will work.  Derived types are deferred to the end of the specification part
+  // so that they can resolve to a locally declared type.
+  if (info.parsedType &&
+      std::holds_alternative<parser::IntrinsicTypeSpec>(info.parsedType->u)) {
+    FinishFunctionResult();
+  }
 }
 
 SubprogramDetails &SubprogramVisitor::PostSubprogramStmt(

     return;
   }
   const auto &name{std::get<parser::Name>(stmt.t)};
-  const auto *parentDetails{subprogram->detailsIf<SubprogramDetails>()};
-  bool inFunction{parentDetails && parentDetails->isFunction()};
-  const parser::Name *resultName{funcInfo_.resultName};
+  const parser::Name *resultName{nullptr};
+  if (const auto &maybeSuffix{
+          std::get<std::optional<parser::Suffix>>(stmt.t)}) {
+    resultName = common::GetPtrFromOptional(maybeSuffix->resultName);
+  }
+  bool inFunction{IsFunction(currScope())};
   if (resultName) { // RESULT(result) is present
-    funcInfo_.resultName = nullptr;
     if (!inFunction) {
-      Say2(resultName->source,
-          "RESULT(%s) may appear only in a function"_err_en_US,
-          subprogram->name(), "Containing subprogram"_en_US);
+      // error was already emitted for the suffix
     } else if (resultName->source == subprogram->name()) { // C1574
       Say2(resultName->source,
           "RESULT(%s) may not have the same name as the function"_err_en_US,

     if (details.isFunction()) {
       currScope().erase(symbol->name());
       newDetails.set_result(*currScope().CopySymbol(details.result()));
+      funcInfoStack_.emplace_back(); // just to be popped later
     }
   }
   return true;
 }
 
-// A subprogram declared with SUBROUTINE or FUNCTION
+// A subprogram or interface declared with SUBROUTINE or FUNCTION
 bool SubprogramVisitor::BeginSubprogram(
     const parser::Name &name, Symbol::Flag subpFlag, bool hasModulePrefix) {
   if (hasModulePrefix && currScope().IsGlobal()) { // C1547

     return false;
   }
   PushSubprogramScope(name, subpFlag);
+  if (IsFunction(currScope())) {
+    funcInfoStack_.emplace_back();
+  }
   return true;
 }
 
-void SubprogramVisitor::EndSubprogram() { PopScope(); }
+void SubprogramVisitor::EndSubprogram() {
+  if (IsFunction(currScope())) {
+    funcInfoStack_.pop_back();
+  }
+  PopScope();
+}
 
 bool SubprogramVisitor::HandlePreviousCalls(
     const parser::Name &name, Symbol &symbol, Symbol::Flag subpFlag) {

 void ResolveNamesVisitor::FinishSpecificationPart(
     const std::list<parser::DeclarationConstruct> &decls) {
   badStmtFuncFound_ = false;
+  FinishFunctionResult();
   CheckImports();
   bool inModule{currScope().kind() == Scope::Kind::Module};
   for (auto &pair : currScope()) {

     ResolveSpecificationParts(child);
   }
   ExecutionPartSkimmer{*this}.Walk(node.exec());
-  PopScope();
+  EndScopeForNode(node);
   // Ensure that every object entity has a type.
   for (auto &pair : *node.scope()) {
     ApplyImplicitRules(*pair.second);

   }
 }
 
+void ResolveNamesVisitor::EndScopeForNode(const ProgramTree &node) {
+  EndSubprogram();
+}
+
 // Some analyses and checks, such as the processing of initializers of
 // pointers, are deferred until all of the pertinent specification parts
 // have been visited.  This deferred processing enables the use of forward

flang/test/Semantics/resolve108.f90

+! RUN: %python %S/test_errors.py %s %flang_fc1
+! Tests attempts at forward references to local names in a FUNCTION prefix
+
+! This case is not an error, but will elicit bogus errors if the
+! result type of the function is badly resolved.
+module m1
+  type t1
+    sequence
+    integer not_m
+  end type
+ contains
+  type(t1) function foo(n)
+    integer, intent(in) :: n
+    type t1
+      sequence
+      integer m
+    end type
+    foo%m = n
+  end function
+end module
+
+subroutine s1
+  use :: m1, only: foo
+  type t1
+    sequence
+    integer m
+  end type
+  type(t1) x
+  x = foo(234)
+  print *, x
+end subroutine
+
+module m2
+  integer, parameter :: k = kind(1.e0)
+ contains
+  real(kind=k) function foo(n)
+    integer, parameter :: k = kind(1.d0)
+    integer, intent(in) :: n
+    foo = n
+  end function
+end module
+
+subroutine s2
+  use :: m2, only: foo
+  !If we got the type of foo right, this declaration will fail
+  !due to an attempted division by zero.
+  !ERROR: Must be a constant value
+  integer, parameter :: test = 1 / (kind(foo(1)) - kind(1.e0))
+end subroutine
+
+module m3
+  integer, parameter :: k = kind(1.e0)
+ contains
+  real(kind=kind(x)) function foo(x)
+    !ERROR: The type of 'x' has already been implicitly declared
+    real(kind=kind(1.0d0)) x
+    foo = n
+  end function
+end module
+
+module m4
+ contains
+  !ERROR: Must be a constant value
+  real(n) function foo(x)
+    integer, parameter :: n = kind(foo)
+    real(n), intent(in) :: x
+    foo = x
+  end function
+end module