[flang] More fixes; tests now all pass (with updates to some)

Original-commit: flang-compiler/f18@236ff3a3db
Reviewed-on: https://github.com/flang-compiler/f18/pull/638
Tree-same-pre-rewrite: false

flang/lib/semantics/resolve-names.cc

@@ -763,6 +763,7 @@ public:
       const parser::Name &, const parser::InitialDataTarget &);
   void PointerInitialization(
       const parser::Name &, const parser::ProcPointerInit &);
+  void CheckExplicitInterface(const parser::Name &);
   void CheckBindings(const parser::TypeBoundProcedureStmt::WithoutInterface &);
 
 protected:
@@ -799,8 +800,6 @@ protected:
   const parser::Name *ResolveName(const parser::Name &);
   bool PassesSharedLocalityChecks(const parser::Name &name, Symbol &symbol);
   Symbol *NoteInterfaceName(const parser::Name &);
-  void CheckExplicitInterface(Symbol &);
-  void CheckBinding(Symbol &);
 
 private:
   // The attribute corresponding to the statement containing an ObjectDecl
@@ -845,7 +844,6 @@ private:
   Symbol &DeclareProcEntity(const parser::Name &, Attrs, const ProcInterface &);
   void SetType(const parser::Name &, const DeclTypeSpec &);
   const Symbol *ResolveDerivedType(const parser::Name &);
-  bool CanBeTypeBoundProc(const Symbol &);
   Symbol *MakeTypeSymbol(const SourceName &, Details &&);
   Symbol *MakeTypeSymbol(const parser::Name &, Details &&);
   bool OkToAddComponent(const parser::Name &, const Symbol * = nullptr);
@@ -1660,7 +1658,8 @@ void ScopeHandler::PopScope() {
   // assumed to be objects.
   // TODO: Statement functions
   for (auto &pair : currScope()) {
-    ConvertToObjectEntity(*pair.second);
+    Symbol &symbol{*pair.second};
+    ConvertToObjectEntity(symbol);
   }
   SetScope(currScope_->parent());
 }
@@ -3435,13 +3434,21 @@ void DeclarationVisitor::CheckBindings(
     auto &bindingName{std::get<parser::Name>(declaration.t)};
     if (Symbol * binding{FindInScope(currScope(), bindingName)}) {
       if (auto *details{binding->detailsIf<ProcBindingDetails>()}) {
-        const Symbol &procedure{details->symbol().GetUltimate()};
+        const Symbol *procedure{FindSubprogram(details->symbol())};
         if (!CanBeTypeBoundProc(procedure)) {
-          auto &optName{std::get<std::optional<parser::Name>>(declaration.t)};
+          if (details->symbol().name() != binding->name()) {
-          const parser::Name &procedureName{optName ? *optName : bindingName};
+            Say(binding->name(),
-          SayWithDecl(procedureName, const_cast<Symbol &>(procedure),
+                "The binding of '%s' ('%s') must be either an accessible "
-              "'%s' is not a module procedure or external procedure"
+                "module procedure or an external procedure with "
-              " with explicit interface"_err_en_US);
+                "an explicit interface"_err_en_US,
+                binding->name(), details->symbol().name());
+          } else {
+            Say(binding->name(),
+                "'%s' must be either an accessible module procedure "
+                "or an external procedure with an explicit interface"_err_en_US,
+                binding->name());
+          }
+          context().SetError(*binding);
         }
       }
     }
@@ -4067,55 +4074,23 @@ const Symbol *DeclarationVisitor::ResolveDerivedType(const parser::Name &name) {
   return symbol;
 }
 
-// Check this symbol suitable as a type-bound procedure - C769
-bool DeclarationVisitor::CanBeTypeBoundProc(const Symbol &symbol) {
-  if (symbol.has<SubprogramNameDetails>()) {
-    return symbol.owner().kind() == Scope::Kind::Module;
-  } else if (auto *details{symbol.detailsIf<SubprogramDetails>()}) {
-    return symbol.owner().kind() == Scope::Kind::Module ||
-        details->isInterface();
-  } else if (auto *proc{symbol.detailsIf<ProcEntityDetails>()}) {
-    return !symbol.IsDummy() && !symbol.attrs().test(Attr::POINTER) &&
-        proc->HasExplicitInterface();
-  } else {
-    return false;
-  }
-}
-
 Symbol *DeclarationVisitor::NoteInterfaceName(const parser::Name &name) {
-  // The symbol is checked later by CheckExplicitInterface() or
+  // The symbol is checked later by CheckExplicitInterface() and
-  // CheckBinding() to ensure that it defines an explicit interface
+  // CheckBindings().  It can be a forward reference.
-  // or binds to a procedure.  The name can be a forward reference.
   if (!NameIsKnownOrIntrinsic(name)) {
-    Resolve(name, MakeSymbol(InclusiveScope(), name.source, Attrs{}));
+    Symbol &symbol{MakeSymbol(InclusiveScope(), name.source, Attrs{})};
+    Resolve(name, symbol);
   }
   return name.symbol;
 }
 
-void DeclarationVisitor::CheckExplicitInterface(Symbol &symbol) {
+void DeclarationVisitor::CheckExplicitInterface(const parser::Name &name) {
-  if (const Symbol * interface{FindInterface(symbol)}) {
+  if (const Symbol * symbol{name.symbol}) {
-    const Symbol *subp{FindSubprogram(*interface)};
+    if (!symbol->HasExplicitInterface()) {
-    if (subp == nullptr || !subp->HasExplicitInterface()) {
+      Say(name,
-      Say(symbol.name(),
+          "'%s' must be an abstract interface or a procedure with "
-          "The interface of '%s' ('%s') is not an abstract interface or a "
+          "an explicit interface"_err_en_US,
-          "procedure with an explicit interface"_err_en_US,
+          symbol->name());
-          symbol.name(), interface->name());
-      context().SetError(symbol);
-    }
-  }
-}
-
-void DeclarationVisitor::CheckBinding(Symbol &symbol) {
-  if (const auto *details{symbol.detailsIf<ProcBindingDetails>()}) {
-    const Symbol &binding{details->symbol()};
-    const Symbol *subp{FindSubprogram(binding)};
-    if (subp == nullptr || !subp->HasExplicitInterface() || IsDummy(*subp) ||
-        IsProcedurePointer(*subp)) {
-      Say(symbol.name(),
-          "The binding of '%s' ('%s') is not a "
-          "procedure with an explicit interface"_err_en_US,
-          symbol.name(), binding.name());
-      context().SetError(symbol);
     }
   }
 }
@@ -4764,11 +4739,6 @@ const parser::Name *DeclarationVisitor::ResolveName(const parser::Name &name) {
     }
     return &name;
   }
-  // TODO pmk: if in a variable or component initialization with deferred
-  // semantic analysis, just MakeSymbol() for now and don't apply any
-  // implicit typing rules.  Then do object conversion and implicit
-  // typing (or not) in DeferredInitializationHelper (taking Pointer
-  // out of the name).  Still not sure how to deal with PDT components.
   if (isImplicitNoneType()) {
     Say(name, "No explicit type declared for '%s'"_err_en_US);
     return nullptr;
@@ -5027,7 +4997,7 @@ void DeclarationVisitor::PointerInitialization(
           details.set_init(*targetName->symbol);
         }
       } else {
-        details.set_init(nullptr);  // NULL()
+        details.set_init(nullptr);  // explicit NULL()
       }
     } else {
       Say(name,
@@ -5074,9 +5044,7 @@ void ResolveNamesVisitor::HandleProcedureName(
       }
       MakeExternal(*symbol);
     }
-    if (!symbol->has<ProcEntityDetails>()) {
+    ConvertToProcEntity(*symbol);
-      ConvertToProcEntity(*symbol);
-    }
     SetProcFlag(name, *symbol, flag);
   } else if (symbol->has<UnknownDetails>()) {
     CHECK(!"unexpected UnknownDetails");
@@ -5525,12 +5493,13 @@ bool ResolveNamesVisitor::BeginScope(const ProgramTree &node) {
   }
 }
 
-// The processing of initializers of pointers is deferred until all of
+// Some analyses and checks, such as the processing of initializers of
-// the pertinent specification parts have been visited.  This deferred
+// pointers, is deferred until all of the pertinent specification parts
-// processing enables the use of forward references in those initializers.
+// have been visited.  This deferred processing enables the use of forward
-class DeferredPointerInitializationVisitor {
+// references in these circumstances.
+class DeferredCheckVisitor {
 public:
-  explicit DeferredPointerInitializationVisitor(ResolveNamesVisitor &resolver)
+  explicit DeferredCheckVisitor(ResolveNamesVisitor &resolver)
     : resolver_{resolver} {}
 
   template<typename A> void Walk(const A &x) { parser::Walk(x, *this); }
@@ -5539,7 +5508,7 @@ public:
   template<typename A> void Post(const A &) {}
 
   void Post(const parser::DerivedTypeStmt &x) {
-    auto &name{std::get<parser::Name>(x.t)};
+    const auto &name{std::get<parser::Name>(x.t)};
     if (Symbol * symbol{name.symbol}) {
       if (Scope * scope{symbol->scope()}) {
         if (scope->kind() == Scope::Kind::DerivedType) {
@@ -5556,6 +5525,11 @@ public:
     }
   }
 
+  void Post(const parser::ProcInterface &pi) {
+    if (const auto *name{std::get_if<parser::Name>(&pi.u)}) {
+      resolver_.CheckExplicitInterface(*name);
+    }
+  }
   bool Pre(const parser::EntityDecl &decl) {
     Init(std::get<parser::Name>(decl.t),
         std::get<std::optional<parser::Initialization>>(decl.t));
@@ -5573,6 +5547,9 @@ public:
     }
     return false;
   }
+  void Post(const parser::TypeBoundProcedureStmt::WithInterface &tbps) {
+    resolver_.CheckExplicitInterface(tbps.interfaceName);
+  }
   void Post(const parser::TypeBoundProcedureStmt::WithoutInterface &tbps) {
     if (pushedScope_) {
       resolver_.CheckBindings(tbps);
@@ -5605,14 +5582,12 @@ void ResolveNamesVisitor::FinishSpecificationParts(const ProgramTree &node) {
   // type-bound procedure bindings have not yet been traversed.
   // We do that now, when any (formerly) forward references that appear
   // in those initializers will resolve to the right symbols.
-  DeferredPointerInitializationVisitor{*this}.Walk(node.spec());
+  DeferredCheckVisitor{*this}.Walk(node.spec());
-  DeferredPointerInitializationVisitor{*this}.Walk(node.exec());  // for BLOCK
+  DeferredCheckVisitor{*this}.Walk(node.exec());  // for BLOCK
   for (auto &pair : currScope()) {
     Symbol &symbol{*pair.second};
     if (const auto *details{symbol.detailsIf<GenericDetails>()}) {
       CheckSpecificsAreDistinguishable(symbol, details->specificProcs());
-    } else if (symbol.has<ProcEntityDetails>()) {
-      CheckExplicitInterface(symbol);
     }
   }
   // Finish the definitions of derived types and parameterized derived
@@ -5643,7 +5618,7 @@ static int FindIndexOfName(
   return -1;
 }
 
-// Perform checks on procedure bindings of this type
+// Perform final checks on a derived type and set the pass arguments.
 void ResolveNamesVisitor::FinishDerivedTypeDefinition(Scope &scope) {
   CHECK(scope.IsDerivedType() && scope.symbol());
   for (auto &pair : scope) {
@@ -5652,12 +5627,8 @@ void ResolveNamesVisitor::FinishDerivedTypeDefinition(Scope &scope) {
         common::visitors{
             [&](ProcEntityDetails &x) {
               SetPassArg(comp, x.interface().symbol(), x);
-              CheckExplicitInterface(comp);
-            },
-            [&](ProcBindingDetails &x) {
-              SetPassArg(comp, &x.symbol(), x);
-              CheckBinding(comp);
             },
+            [&](ProcBindingDetails &x) { SetPassArg(comp, &x.symbol(), x); },
             [](auto &) {},
         },
         comp.details());

flang/lib/semantics/scope.cc

@@ -216,7 +216,7 @@ void Scope::add_importName(const SourceName &name) {
 
 // true if name can be imported or host-associated from parent scope.
 bool Scope::CanImport(const SourceName &name) const {
-  if (IsGlobal()) {
+  if (IsGlobal() || parent_.IsGlobal()) {
     return false;
   }
   switch (GetImportKind()) {

flang/lib/semantics/tools.cc

@@ -418,6 +418,23 @@ bool IsSaved(const Symbol &symbol) {
   }
 }
 
+// Check this symbol suitable as a type-bound procedure - C769
+bool CanBeTypeBoundProc(const Symbol *symbol) {
+  if (symbol == nullptr || IsDummy(*symbol) || IsProcedurePointer(*symbol)) {
+    return false;
+  } else if (symbol->has<SubprogramNameDetails>()) {
+    return symbol->owner().kind() == Scope::Kind::Module;
+  } else if (auto *details{symbol->detailsIf<SubprogramDetails>()}) {
+    return symbol->owner().kind() == Scope::Kind::Module ||
+        details->isInterface();
+  } else if (const auto *proc{symbol->detailsIf<ProcEntityDetails>()}) {
+    return !symbol->attrs().test(Attr::INTRINSIC) &&
+        proc->HasExplicitInterface();
+  } else {
+    return false;
+  }
+}
+
 bool IsFinalizable(const Symbol &symbol) {
   if (const DeclTypeSpec * type{symbol.GetType()}) {
     if (const DerivedTypeSpec * derived{type->AsDerived()}) {

flang/lib/semantics/tools.h

@@ -84,6 +84,7 @@ const Symbol *HasEventOrLockPotentialComponent(const DerivedTypeSpec &);
 bool IsOrContainsEventOrLockComponent(const Symbol &);
 // Has an explicit or implied SAVE attribute
 bool IsSaved(const Symbol &);
+bool CanBeTypeBoundProc(const Symbol *);
 
 // Return an ultimate component of type that matches predicate, or nullptr.
 const Symbol *FindUltimateComponent(

flang/test/semantics/allocate08.f90

@@ -119,6 +119,12 @@ end function
 
 program test_typeless
   class(*), allocatable :: x
+  interface
+    subroutine sub
+    end subroutine
+    real function func()
+    end function
+  end interface
   procedure (sub), pointer :: subp => sub
   procedure (func), pointer :: funcp => func
 

flang/test/semantics/dosemantics03.f90

@@ -25,12 +25,6 @@
 ! C1120 -- DO variable (and associated expressions) must be INTEGER.
 ! This is extended by allowing REAL and DOUBLE PRECISION
 
-SUBROUTINE sub()
-END SUBROUTINE sub
-
-FUNCTION ifunc()
-END FUNCTION ifunc
-
 MODULE share
   INTEGER :: intvarshare
   REAL :: realvarshare
@@ -56,6 +50,12 @@ PROGRAM do_issue_458
   REAL, POINTER :: prvar
   DOUBLE PRECISION, POINTER :: pdvar
   LOGICAL, POINTER :: plvar
+  INTERFACE
+    SUBROUTINE sub()
+    END SUBROUTINE sub
+    FUNCTION ifunc()
+    END FUNCTION ifunc
+  END INTERFACE
   PROCEDURE(ifunc), POINTER :: pifunc => NULL()
 
 ! DO variables

flang/test/semantics/resolve20.f90

@@ -22,20 +22,20 @@ module m
   procedure(integer) :: b
   procedure(foo) :: c
   procedure(bar) :: d
-  !ERROR: The interface of 'e' ('missing') is not an abstract interface or a procedure with an explicit interface
+  !ERROR: 'missing' must be an abstract interface or a procedure with an explicit interface
   procedure(missing) :: e
-  !ERROR: The interface of 'f' ('b') is not an abstract interface or a procedure with an explicit interface
+  !ERROR: 'b' must be an abstract interface or a procedure with an explicit interface
   procedure(b) :: f
   procedure(c) :: g
   external :: h
-  !ERROR: The interface of 'i' ('h') is not an abstract interface or a procedure with an explicit interface
+  !ERROR: 'h' must be an abstract interface or a procedure with an explicit interface
   procedure(h) :: i
   procedure(forward) :: j
-  !ERROR: The interface of 'k1' ('bad1') is not an abstract interface or a procedure with an explicit interface
+  !ERROR: 'bad1' must be an abstract interface or a procedure with an explicit interface
   procedure(bad1) :: k1
-  !ERROR: The interface of 'k2' ('bad2') is not an abstract interface or a procedure with an explicit interface
+  !ERROR: 'bad2' must be an abstract interface or a procedure with an explicit interface
   procedure(bad2) :: k2
-  !ERROR: The interface of 'k3' ('bad3') is not an abstract interface or a procedure with an explicit interface
+  !ERROR: 'bad3' must be an abstract interface or a procedure with an explicit interface
   procedure(bad3) :: k3
 
   abstract interface

flang/test/semantics/resolve32.f90

@@ -35,21 +35,21 @@ module m
   type t1
     integer :: c
   contains
-    !ERROR: Procedure 'missing' not found
+    !ERROR: The binding of 'a' ('missing') must be either an accessible module procedure or an external procedure with an explicit interface
     procedure, nopass :: a => missing
     procedure, nopass :: b => s, s2
-    !ERROR: 'c' is not a module procedure or external procedure with explicit interface
+    !ERROR: Type parameter, component, or procedure binding 'c' already defined in this type
     procedure, nopass :: c
     !ERROR: DEFERRED is only allowed when an interface-name is provided
     procedure, nopass, deferred :: d => s
     !Note: s3 not found because it's not accessible -- should we issue a message
     !to that effect?
-    !ERROR: Procedure 's3' not found
+    !ERROR: 's3' must be either an accessible module procedure or an external procedure with an explicit interface
     procedure, nopass :: s3
     procedure, nopass :: foo
-    !ERROR: 'bar' is not a module procedure or external procedure with explicit interface
+    !ERROR: 'bar' must be either an accessible module procedure or an external procedure with an explicit interface
     procedure, nopass :: bar
-    !ERROR: 'i' is not a module procedure or external procedure with explicit interface
+    !ERROR: 'i' must be either an accessible module procedure or an external procedure with an explicit interface
     procedure, nopass :: i
     !ERROR: Type parameter, component, or procedure binding 'b' already defined in this type
     procedure, nopass :: b => s4
@@ -59,7 +59,7 @@ module m
     procedure(foo), nopass, deferred :: f
     !ERROR: DEFERRED is required when an interface-name is provided
     procedure(foo), nopass :: g
-    !ERROR: The interface of 'h' ('bar') is not an abstract interface or a procedure with an explicit interface
+    !ERROR: 'bar' must be an abstract interface or a procedure with an explicit interface
     procedure(bar), nopass, deferred :: h
   end type
   type t2