[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 IsPureProcedure(const Scope &scope) {
   const Symbol *symbol{scope.GetSymbol()};
   return symbol && IsPureProcedure(*symbol);
 }
 
 bool IsFunction(const Symbol &symbol) {
-  return std::visit(
-      common::visitors{
+  const Symbol &ultimate{symbol.GetUltimate()};
+  return ultimate.test(Symbol::Flag::Function) ||
+      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()));
+                       return ifc.type() ||
+                           (ifc.symbol() && IsFunction(*ifc.symbol()));
+                     },
+                     [](const ProcBindingDetails &x) {
+                       return IsFunction(x.symbol());
                      },
-          [](const ProcBindingDetails &x) { return IsFunction(x.symbol()); },
                      [](const auto &) { return false; },
                  },
-      symbol.GetUltimate().details());
+          ultimate.details());
 }
 
 bool IsFunction(const Scope &scope) {
   const Symbol *symbol{scope.GetSymbol()};
   return symbol && IsFunction(*symbol);
 }
 
 bool IsProcedure(const Symbol &symbol) {

flang/lib/Semantics/resolve-names.cpp

std::multimap<Symbol *, std::pair<const parser::Name *, ProcedureKind>>
       specificProcs_;
 
   void AddSpecificProcs(const std::list<parser::Name> &, ProcedureKind);
   void ResolveSpecificsInGeneric(Symbol &generic);
 };
 
 class SubprogramVisitor : public virtual ScopeHandler, public InterfaceVisitor {
 public:
+  ~SubprogramVisitor();
   bool HandleStmtFunction(const parser::StmtFunctionStmt &);
   bool Pre(const parser::SubroutineStmt &);
   void Post(const parser::SubroutineStmt &);
   bool Pre(const parser::FunctionStmt &);
   void Post(const parser::FunctionStmt &);
   bool Pre(const parser::EntryStmt &);
   void Post(const parser::EntryStmt &);
   bool Pre(const parser::InterfaceBody::Subroutine &);
   void Post(const parser::InterfaceBody::Subroutine &);
   bool Pre(const parser::InterfaceBody::Function &);
   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);
   bool BeginMpSubprogram(const parser::Name &);
   void PushBlockDataScope(const parser::Name &);
   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.
   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);
   Symbol *GetSpecificFromGeneric(const parser::Name &);
private:
   void CheckImport(const SourceName &, const SourceName &);
   void HandleCall(Symbol::Flag, const parser::Call &);
   void HandleProcedureName(Symbol::Flag, const parser::Name &);
   bool CheckImplicitNoneExternal(const SourceName &, const Symbol &);
   bool SetProcFlag(const parser::Name &, Symbol &, Symbol::Flag);
   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 &);
 };
 
 // ImplicitRules implementation
 
 bool ImplicitRules::isImplicitNoneType() const {
SayDerivedType(generic.name(),
         " with same name"_err_en_US,
         *details.derivedType()->scope());
   }
   generic.set(isFunction ? Symbol::Flag::Function : Symbol::Flag::Subroutine);
 }
 
 // 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)};
   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) {
bool SubprogramVisitor::HandleStmtFunction(const parser::StmtFunctionStmt &x) {
   // statement function is deferred to FinishSpecificationPart() so that
   // all declarations and implicit typing are complete.
   PopScope();
   return true;
 }
 
 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 {
     return true;
   }
 }
 
-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) {
   const auto &name{std::get<parser::Name>(
       std::get<parser::Statement<parser::SubroutineStmt>>(x.t).statement.t)};
   return BeginSubprogram(name, Symbol::Flag::Subroutine);
 }
 void SubprogramVisitor::Post(const parser::InterfaceBody::Subroutine &) {
   EndSubprogram();
 }
 bool SubprogramVisitor::Pre(const parser::InterfaceBody::Function &x) {
   const auto &name{std::get<parser::Name>(
       std::get<parser::Statement<parser::FunctionStmt>>(x.t).statement.t)};
   return BeginSubprogram(name, Symbol::Flag::Function);
 }
 void SubprogramVisitor::Post(const parser::InterfaceBody::Function &) {
   EndSubprogram();
 }
 
 bool SubprogramVisitor::Pre(const parser::SubroutineStmt &) {
   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(); }
 
 void SubprogramVisitor::Post(const parser::SubroutineStmt &stmt) {
   const auto &name{std::get<parser::Name>(stmt.t)};
   auto &details{PostSubprogramStmt(name)};
   for (const auto &dummyArg : std::get<std::list<parser::DummyArg>>(stmt.t)) {

 void SubprogramVisitor::Post(const parser::FunctionStmt &stmt) {
   const auto &name{std::get<parser::Name>(stmt.t)};
   auto &details{PostSubprogramStmt(name)};
   for (const auto &dummyName : std::get<std::list<parser::Name>>(stmt.t)) {
     Symbol &dummy{MakeSymbol(dummyName, EntityDetails{true})};
     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
   if (details.isFunction()) {
     CHECK(context().HasError(currScope().symbol()));
   } else {
     // 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(
     const parser::Name &name) {
   Symbol &symbol{*currScope().symbol()};
   CHECK(name.source == symbol.name());
   SetBindNameOn(symbol);
   symbol.attrs() |= EndAttrs();
   if (symbol.attrs().test(Attr::MODULE)) {
     symbol.attrs().set(Attr::EXTERNAL, false);
   }
   return symbol.get<SubprogramDetails>();
 }
 
 void SubprogramVisitor::Post(const parser::EntryStmt &stmt) {
   auto attrs{EndAttrs()}; // needs to be called even if early return
   Scope &inclusiveScope{InclusiveScope()};
   const Symbol *subprogram{inclusiveScope.symbol()};
   if (!subprogram) {
     CHECK(context().AnyFatalError());
     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,
           subprogram->name(), "Containing function"_en_US);
     } else if (const Symbol *
         symbol{FindSymbol(inclusiveScope.parent(), *resultName)}) { // C1574
       if (const auto *details{symbol->detailsIf<SubprogramDetails>()}) {
         if (details->entryScope() == &inclusiveScope) {
for (const Symbol *dummyArg : details.dummyArgs()) {
         newDetails.add_alternateReturn();
       } else if (Symbol * copy{currScope().CopySymbol(*dummyArg)}) {
         newDetails.add_dummyArg(*copy);
       }
     }
     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
     Say(name,
         "'%s' is a MODULE procedure which must be declared within a "
         "MODULE or SUBMODULE"_err_en_US);
     return false;
   }
 
   if (hasModulePrefix && !inInterfaceBlock() &&
       !IsSeparateModuleProcedureInterface(
           FindSymbol(currScope().parent(), name))) {
     Say(name, "'%s' was not declared a separate module procedure"_err_en_US);
     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) {
   if (const auto *proc{symbol.detailsIf<ProcEntityDetails>()}; proc &&
       !proc->isDummy() &&
       !symbol.attrs().HasAny(Attrs{Attr::INTRINSIC, Attr::POINTER})) {
     // There's a symbol created for previous calls to this subprogram or
     // ENTRY's name.  We have to replace that symbol in situ to avoid the
if (Symbol * existing{FindInScope(symbolName)}) {
     EraseSymbol(*existing);
   }
   info.Resolve(&MakeSymbol(symbolName, Attrs{}, std::move(genericDetails)));
 }
 
 void ResolveNamesVisitor::FinishSpecificationPart(
     const std::list<parser::DeclarationConstruct> &decls) {
   badStmtFuncFound_ = false;
+  FinishFunctionResult();
   CheckImports();
   bool inModule{currScope().kind() == Scope::Kind::Module};
   for (auto &pair : currScope()) {
     auto &symbol{*pair.second};
     if (NeedsExplicitType(symbol)) {
       ApplyImplicitRules(symbol);
     }
     if (IsDummy(symbol) && isImplicitNoneType() &&
void ResolveNamesVisitor::ResolveSpecificationParts(ProgramTree &node) {
   }
   if (node.IsModule()) {
     ApplyDefaultAccess();
   }
   for (auto &child : node.children()) {
     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);
   }
 }
 
 // Add SubprogramNameDetails symbols for module and internal subprograms and
 // their ENTRY statements.
bool ResolveNamesVisitor::BeginScopeForNode(const ProgramTree &node) {
   case ProgramTree::Kind::Submodule:
     return BeginSubmodule(node.name(), node.GetParentId());
   case ProgramTree::Kind::BlockData:
     PushBlockDataScope(node.name());
     return true;
   }
 }
 
+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
 // references in these circumstances.
 class DeferredCheckVisitor {
 public:
   explicit DeferredCheckVisitor(ResolveNamesVisitor &resolver)
       : resolver_{resolver} {}

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