[flang] Fix problems determining object/function/subroutine

Convert each Entity to ObjectEntity at the end of each scope.
Add `ConvertToObjectEntity()` to achieve this, similar to
`ConvertToProcEntity()`. Move them both up into `ScopeHandler`
because they need to be called from `PopScope()`.

In a proc-decl, only mark the proc as a function if it has a return type.
If no return type is declared, function vs. subroutine is determined by:
- for a module it is a subroutine (at end of specification-part)
- otherwise it is by usage

If an entity that could otherwise be a function is used as the base of a
structure component, that forces it to be an object. Because we have to
change it to an object entity at that point, the `base` in `FindComponent()`
can't be const, and that propagates to all of its callers.

Remove the name argument to `ApplyImplicitRules` as it is unneeded.

Fixes flang-compiler/f18#191.

Original-commit: flang-compiler/f18@9bd8bf7c3706e501a58b564f316794d023f762b6
Reviewed-on: https://github.com/flang-compiler/f18/pull/194
Tree-same-pre-rewrite: false

diff --git a/flang/lib/semantics/resolve-names.cc b/flang/lib/semantics/resolve-names.cc
index 01d8583..bcaf475 100644 (file)
--- a/flang/lib/semantics/resolve-names.cc
+++ b/flang/lib/semantics/resolve-names.cc
@@ -387,8 +387,10 @@ protected:
   std::optional<SubprogramKind> subpNamesOnly_;
 
   // Apply the implicit type rules to this symbol.
-  void ApplyImplicitRules(const SourceName &, Symbol &);
+  void ApplyImplicitRules(Symbol &);
   std::optional<const DeclTypeSpec> GetImplicitType(Symbol &);
+  bool ConvertToObjectEntity(Symbol &);
+  bool ConvertToProcEntity(Symbol &);
 
 private:
   Scope *currScope_{nullptr};
@@ -583,8 +585,7 @@ private:
   bool HandleAttributeStmt(Attr, const std::list<parser::Name> &);
   Symbol &HandleAttributeStmt(Attr, const SourceName &);
   void DeclareObjectEntity(const SourceName &, Attrs);
-  void DeclareProcEntity(const SourceName &, Attrs, const ProcInterface &);
-  bool ConvertToProcEntity(Symbol &);
+  Symbol &DeclareProcEntity(const SourceName &, Attrs, const ProcInterface &);
   void SetType(const SourceName &, Symbol &, const DeclTypeSpec &);
   const Symbol *ResolveDerivedType(const SourceName &);
   bool CanBeTypeBoundProc(const Symbol &);
@@ -696,12 +697,11 @@ private:
   const parser::Name *GetVariableName(const parser::Expr &);
   const parser::Name *GetVariableName(const parser::Variable &);
   const Symbol *CheckImplicitSymbol(const parser::Name *);
-  const Symbol *ResolveStructureComponent(const parser::StructureComponent &);
-  const Symbol *ResolveArrayElement(const parser::ArrayElement &);
-  const Symbol *ResolveCoindexedNamedObject(
-      const parser::CoindexedNamedObject &);
-  const Symbol *ResolveDataRef(const parser::DataRef &);
-  const Symbol *FindComponent(const Symbol &, const SourceName &);
+  Symbol *ResolveStructureComponent(const parser::StructureComponent &);
+  Symbol *ResolveArrayElement(const parser::ArrayElement &);
+  Symbol *ResolveCoindexedNamedObject(const parser::CoindexedNamedObject &);
+  Symbol *ResolveDataRef(const parser::DataRef &);
+  Symbol *FindComponent(Symbol &, const SourceName &);
   Symbol *FindComponent(const Scope &, const SourceName &);
   bool CheckAccessibleComponent(const Symbol &);
   void CheckImports();
@@ -1215,6 +1215,10 @@ void ScopeHandler::PushScope(Scope &scope) {
   }
 }
 void ScopeHandler::PopScope() {
+  for (auto &pair : currScope()) {
+    auto &symbol{*pair.second};
+    ConvertToObjectEntity(symbol);  // if not a proc by now, it is an object
+  }
   if (currScope_->kind() != Scope::Kind::Block) {
     ImplicitRulesVisitor::PopScope();
   }
@@ -1228,16 +1232,15 @@ void ScopeHandler::EraseSymbol(const SourceName &name) {
   currScope().erase(name);
 }
 
-void ScopeHandler::ApplyImplicitRules(const SourceName &name, Symbol &symbol) {
-  if (symbol.has<UnknownDetails>()) {
-    symbol.set_details(ObjectEntityDetails{});
-  }
-  if (auto *details{symbol.detailsIf<ObjectEntityDetails>()}) {
-    if (!details->type()) {
-      if (const auto type{GetImplicitType(symbol)}) {
-        details->set_type(*type);
-      }
-    }
+void ScopeHandler::ApplyImplicitRules(Symbol &symbol) {
+  ConvertToObjectEntity(symbol);
+  if (symbol.GetType()) {
+    // already has a type
+  } else if (symbol.has<ProcEntityDetails>() &&
+      !symbol.test(Symbol::Flag::Function)) {
+    // a procedure that is not known to be a function
+  } else if (const auto type{GetImplicitType(symbol)}) {
+    symbol.SetType(*type);
   }
 }
 std::optional<const DeclTypeSpec> ScopeHandler::GetImplicitType(
@@ -1252,6 +1255,36 @@ std::optional<const DeclTypeSpec> ScopeHandler::GetImplicitType(
   return type;
 }
 
+// Convert symbol to be a ObjectEntity or return false if it can't be.
+bool ScopeHandler::ConvertToObjectEntity(Symbol &symbol) {
+  if (symbol.has<ObjectEntityDetails>()) {
+    // nothing to do
+  } else if (symbol.has<UnknownDetails>()) {
+    symbol.set_details(ObjectEntityDetails{});
+  } else if (auto *details{symbol.detailsIf<EntityDetails>()}) {
+    symbol.set_details(ObjectEntityDetails{*details});
+  } else {
+    return false;
+  }
+  return true;
+}
+// Convert symbol to be a ProcEntity or return false if it can't be.
+bool ScopeHandler::ConvertToProcEntity(Symbol &symbol) {
+  if (symbol.has<ProcEntityDetails>()) {
+    // nothing to do
+  } else if (symbol.has<UnknownDetails>()) {
+    symbol.set_details(ProcEntityDetails{});
+  } else if (auto *details{symbol.detailsIf<EntityDetails>()}) {
+    symbol.set_details(ProcEntityDetails{*details});
+  } else {
+    return false;
+  }
+  if (symbol.GetType()) {
+    symbol.set(Symbol::Flag::Function);
+  }
+  return true;
+}
+
 // ModuleVisitor implementation
 
 bool ModuleVisitor::Pre(const parser::Only &x) {
@@ -1936,7 +1969,7 @@ void DeclarationVisitor::Post(const parser::EntityDecl &x) {
     if (auto &type{GetDeclTypeSpec()}) {
       SetType(name, symbol, *type);
     }
-    if (attrs.test(Attr::EXTERNAL)) {
+    if (symbol.attrs().test(Attr::EXTERNAL)) {
       ConvertToProcEntity(symbol);
     }
   }
@@ -1957,7 +1990,7 @@ bool DeclarationVisitor::Pre(const parser::NamedConstantDef &x) {
   // TODO: auto &expr{std::get<parser::ConstantExpr>(x.t)};
   // TODO: old-style parameters: type based on expr
   auto &symbol{HandleAttributeStmt(Attr::PARAMETER, name)};
-  ApplyImplicitRules(name, symbol);
+  ApplyImplicitRules(symbol);
   return false;
 }
 bool DeclarationVisitor::Pre(const parser::AsynchronousStmt &x) {
@@ -2024,28 +2057,13 @@ Symbol &DeclarationVisitor::HandleAttributeStmt(
   return symbol;
 }
 
-// Convert symbol to be a ProcEntity or return false if it can't be.
-bool DeclarationVisitor::ConvertToProcEntity(Symbol &symbol) {
-  if (symbol.has<ProcEntityDetails>()) {
-    // nothing to do
-  } else if (symbol.has<UnknownDetails>()) {
-    symbol.set_details(ProcEntityDetails{});
-  } else if (auto *details{symbol.detailsIf<EntityDetails>()}) {
-    symbol.set_details(ProcEntityDetails(*details));
-    symbol.set(Symbol::Flag::Function);
-  } else {
-    return false;
-  }
-  return true;
-}
-
 void DeclarationVisitor::Post(const parser::ObjectDecl &x) {
   CHECK(objectDeclAttr_.has_value());
   const auto &name{std::get<parser::ObjectName>(x.t)};
   DeclareObjectEntity(name.source, Attrs{*objectDeclAttr_});
 }
 
-void DeclarationVisitor::DeclareProcEntity(
+Symbol &DeclarationVisitor::DeclareProcEntity(
     const SourceName &name, Attrs attrs, const ProcInterface &interface) {
   Symbol &symbol{DeclareEntity<ProcEntityDetails>(name, attrs)};
   if (auto *details{symbol.detailsIf<ProcEntityDetails>()}) {
@@ -2058,6 +2076,7 @@ void DeclarationVisitor::DeclareProcEntity(
     }
     details->set_interface(interface);
   }
+  return symbol;
 }
 
 void DeclarationVisitor::DeclareObjectEntity(
@@ -2245,20 +2264,27 @@ void DeclarationVisitor::Post(const parser::ProcInterface &x) {
 }
 
 void DeclarationVisitor::Post(const parser::ProcDecl &x) {
-  const auto &name{std::get<parser::Name>(x.t).source};
+  bool isFunction{false};
+  bool isSubroutine{false};
   ProcInterface interface;
   if (interfaceName_) {
     if (auto *symbol{FindExplicitInterface(*interfaceName_)}) {
       interface.set_symbol(*symbol);
+      isFunction = symbol->test(Symbol::Flag::Function);
+      isSubroutine = symbol->test(Symbol::Flag::Subroutine);
     }
   } else if (auto &type{GetDeclTypeSpec()}) {
     interface.set_type(*type);
+    isFunction = true;
   }
   auto attrs{GetAttrs()};
   if (currScope().kind() != Scope::Kind::DerivedType) {
     attrs.set(Attr::EXTERNAL);
   }
-  DeclareProcEntity(name, attrs, interface);
+  const auto &name{std::get<parser::Name>(x.t).source};
+  auto &symbol{DeclareProcEntity(name, attrs, interface)};
+  symbol.set(Symbol::Flag::Function, isFunction);
+  symbol.set(Symbol::Flag::Subroutine, isSubroutine);
 }
 
 bool DeclarationVisitor::Pre(const parser::TypeBoundProcedurePart &x) {
@@ -2512,21 +2538,21 @@ bool ResolveNamesVisitor::Pre(const parser::StructureComponent &x) {
   return false;
 }
 
-const Symbol *ResolveNamesVisitor::ResolveStructureComponent(
+Symbol *ResolveNamesVisitor::ResolveStructureComponent(
     const parser::StructureComponent &x) {
-  const Symbol *dataRef = ResolveDataRef(x.base);
+  Symbol *dataRef{ResolveDataRef(x.base)};
   return dataRef ? FindComponent(*dataRef, x.component.source) : nullptr;
 }
-const Symbol *ResolveNamesVisitor::ResolveArrayElement(
+Symbol *ResolveNamesVisitor::ResolveArrayElement(
     const parser::ArrayElement &x) {
   return ResolveDataRef(x.base);
 }
-const Symbol *ResolveNamesVisitor::ResolveCoindexedNamedObject(
+Symbol *ResolveNamesVisitor::ResolveCoindexedNamedObject(
     const parser::CoindexedNamedObject &x) {
   return nullptr;  // TODO
 }
 
-const Symbol *ResolveNamesVisitor::ResolveDataRef(const parser::DataRef &x) {
+Symbol *ResolveNamesVisitor::ResolveDataRef(const parser::DataRef &x) {
   return std::visit(
       common::visitors{
           [=](const parser::Name &y) {
@@ -2538,10 +2564,10 @@ const Symbol *ResolveNamesVisitor::ResolveDataRef(const parser::DataRef &x) {
                 auto pair{InclusiveScope().try_emplace(y.source)};
                 CHECK(pair.second);
                 symbol = pair.first->second;
-                ApplyImplicitRules(y.source, *symbol);
+                ApplyImplicitRules(*symbol);
               }
             }
-            return const_cast<const Symbol *>(symbol);
+            return symbol;
           },
           [=](const common::Indirection<parser::StructureComponent> &y) {
             return ResolveStructureComponent(*y);
@@ -2557,17 +2583,15 @@ const Symbol *ResolveNamesVisitor::ResolveDataRef(const parser::DataRef &x) {
 }
 
 // base is a part-ref of a derived type; find the named component in its type.
-const Symbol *ResolveNamesVisitor::FindComponent(
-    const Symbol &base, const SourceName &component) {
-  std::optional<DeclTypeSpec> type;
-  if (auto *details{base.detailsIf<ObjectEntityDetails>()}) {
-    type = details->type();
-  } else {
+Symbol *ResolveNamesVisitor::FindComponent(
+    Symbol &base, const SourceName &component) {
+  if (!ConvertToObjectEntity(base)) {
     Say2(base.lastOccurrence(),
-        "'%s' is not an object of derived type"_err_en_US, base.name(),
-        "Declaration of '%s'"_en_US);
+        "'%s' is an invalid base for a component reference"_err_en_US,
+        base.name(), "Declaration of '%s'"_en_US);
     return nullptr;
   }
+  auto *type{base.GetType()};
   if (!type) {
     return nullptr;  // should have already reported error
   }
@@ -2582,8 +2606,7 @@ const Symbol *ResolveNamesVisitor::FindComponent(
     }
     return nullptr;
   }
-  const DerivedTypeSpec &derivedTypeSpec{type->derivedTypeSpec()};
-  const Scope *scope{derivedTypeSpec.scope()};
+  const Scope *scope{type->derivedTypeSpec().scope()};
   if (!scope) {
     return nullptr;  // previously failed to resolve type
   } else if (auto *result{FindComponent(*scope, component)}) {
@@ -2657,10 +2680,7 @@ void ResolveNamesVisitor::Post(const parser::ProcedureDesignator &x) {
       // error was reported
     } else {
       symbol = &symbol->GetUltimate();
-      if (auto *details{symbol->detailsIf<EntityDetails>()}) {
-        symbol->set_details(ProcEntityDetails(*details));
-        symbol->set(Symbol::Flag::Function);
-      }
+      ConvertToProcEntity(*symbol);
       if (symbol->test(Symbol::Flag::Function) &&
           expectedProcFlag_ == Symbol::Flag::Subroutine) {
         Say2(name->source,
@@ -2673,6 +2693,9 @@ void ResolveNamesVisitor::Post(const parser::ProcedureDesignator &x) {
             symbol->name(), "Declaration of '%s'"_en_US);
       } else if (symbol->has<ProcEntityDetails>()) {
         symbol->set(*expectedProcFlag_);  // in case it hasn't been set yet
+        if (expectedProcFlag_ == Symbol::Flag::Function) {
+          ApplyImplicitRules(*symbol);
+        }
       } else if (symbol->has<SubprogramDetails>()) {
         // OK
       } else if (symbol->has<SubprogramNameDetails>()) {
@@ -2769,22 +2792,25 @@ static bool NeedsExplicitType(const Symbol &symbol) {
 void ResolveNamesVisitor::Post(const parser::SpecificationPart &) {
   badStmtFuncFound_ = false;
   CheckImports();
+  bool inModule{currScope().kind() == Scope::Kind::Module};
   for (auto &pair : currScope()) {
     auto &name{pair.first};
     auto &symbol{*pair.second};
-    if (auto *details{symbol.detailsIf<EntityDetails>()}) {
-      symbol.set_details(ObjectEntityDetails{*details});
-    }
     if (NeedsExplicitType(symbol)) {
       if (isImplicitNoneType()) {
         Say(name, "No explicit type declared for '%s'"_err_en_US);
       } else {
-        ApplyImplicitRules(name, symbol);
+        ApplyImplicitRules(symbol);
       }
     }
     if (symbol.has<GenericDetails>()) {
       CheckGenericProcedures(symbol);
     }
+    if (inModule && symbol.attrs().test(Attr::EXTERNAL) &&
+        !symbol.test(Symbol::Flag::Function)) {
+      // in a module, external proc without return type is subroutine
+      symbol.set(Symbol::Flag::Subroutine);
+    }
   }
 }
 
@@ -2932,7 +2958,7 @@ const Symbol *ResolveNamesVisitor::CheckImplicitSymbol(
         "'%s' from host scoping unit is not accessible due to IMPORT"_err_en_US);
     return nullptr;
   }
-  ApplyImplicitRules(name->source, *symbol);
+  ApplyImplicitRules(*symbol);
   return symbol;
 }
 

diff --git a/flang/test/semantics/resolve09.f90 b/flang/test/semantics/resolve09.f90
index 2dfb5a1..c0b5984 100644 (file)
--- a/flang/test/semantics/resolve09.f90
+++ b/flang/test/semantics/resolve09.f90
@@ -20,7 +20,7 @@ call a  ! OK - can be function or subroutine
 c = a()
 !ERROR: Cannot call function 'b' like a subroutine
 call b
-!ERROR: Use of 'y' as a procedure conflicts with its declaration
+!ERROR: Cannot call function 'y' like a subroutine
 call y
 call x
 !ERROR: Cannot call subroutine 'x' like a function
@@ -36,3 +36,43 @@ contains
   function f()
   end
 end
+
+subroutine s2
+  ! subroutine vs. function is determined by use
+  external :: a, b
+  call a()
+  !ERROR: Cannot call subroutine 'a' like a function
+  x = a()
+  x = b()
+  !ERROR: Cannot call function 'b' like a subroutine
+  call b()
+end
+
+subroutine s3
+  ! subroutine vs. function is determined by use, even in internal subprograms
+  external :: a
+  procedure() :: b
+contains
+  subroutine s3a()
+    x = a()
+    call b()
+  end
+  subroutine s3b()
+    !ERROR: Cannot call function 'a' like a subroutine
+    call a()
+    !ERROR: Cannot call subroutine 'b' like a function
+    x = b()
+  end
+end
+
+module m
+  ! subroutine vs. function is determined at end of specification part
+  external :: a
+  procedure() :: b
+contains
+  subroutine s()
+    call a()
+    !ERROR: Cannot call subroutine 'b' like a function
+    x = b()
+  end
+end

diff --git a/flang/test/semantics/resolve21.f90 b/flang/test/semantics/resolve21.f90
index 0d640b1..90a9b8a 100644 (file)
--- a/flang/test/semantics/resolve21.f90
+++ b/flang/test/semantics/resolve21.f90
@@ -24,14 +24,21 @@ subroutine s1
   type(t) :: x
   !ERROR: Derived type 't2' not found
   type(t2) :: y
+  external :: v
+  type(t) :: v, w
+  external :: w
   !ERROR: 'z' is not an object of derived type; it is implicitly typed
   i = z%i
-  !ERROR: 's1' is not an object of derived type
+  !ERROR: 's1' is an invalid base for a component reference
   i = s1%i
   !ERROR: 'j' is not an object of derived type
   i = j%i
   !ERROR: Component 'j' not found in derived type 't'
   i = x%j
+  !ERROR: 'v' is an invalid base for a component reference
+  i = v%i
+  !ERROR: 'w' is an invalid base for a component reference
+  i = w%i
   i = x%i  !OK
 end subroutine