[flang] Allow forward references to procedure interfaces in derived t…

…ypes (fixing flang-compiler/f18#571 more)

Original-commit: flang-compiler/f18@c1aeeae
Reviewed-on: flang-compiler/f18#580
Tree-same-pre-rewrite: false

flang/lib/semantics/resolve-names.cc

@@ -774,6 +774,7 @@ class DeclarationVisitor : public ArraySpecVisitor,
   const parser::Name *ResolveVariable(const parser::Variable &);
   const parser::Name *ResolveName(const parser::Name &);
   bool PassesSharedLocalityChecks(const parser::Name &name, Symbol &symbol);
+  Symbol *NoteInterfaceName(const parser::Name &);
   void CheckExplicitInterface(Symbol &);
 
 private:
@@ -820,7 +821,6 @@ class DeclarationVisitor : public ArraySpecVisitor,
   void SetType(const parser::Name &, const DeclTypeSpec &);
   const Symbol *ResolveDerivedType(const parser::Name &);
   bool CanBeTypeBoundProc(const Symbol &);
-  Symbol *FindExplicitInterface(const parser::Name &);
   Symbol *MakeTypeSymbol(const SourceName &, Details &&);
   Symbol *MakeTypeSymbol(const parser::Name &, Details &&);
   bool OkToAddComponent(const parser::Name &, const Symbol * = nullptr);
@@ -3195,12 +3195,7 @@ bool DeclarationVisitor::Pre(const parser::ProcPointerInit &x) {
 void DeclarationVisitor::Post(const parser::ProcInterface &x) {
   if (auto *name{std::get_if<parser::Name>(&x.u)}) {
     interfaceName_ = name;
-    // The symbol is checked later to ensure that it defines
-    // an explicit interface.
-    if (!NameIsKnownOrIntrinsic(*name)) {
-      // Forward reference
-      Resolve(*name, MakeSymbol(InclusiveScope(), name->source, Attrs{}));
-    }
+    NoteInterfaceName(*name);
   }
 }
 
@@ -3302,13 +3297,12 @@ void DeclarationVisitor::Post(
   if (!GetAttrs().test(Attr::DEFERRED)) {  // C783
     Say("DEFERRED is required when an interface-name is provided"_err_en_US);
   }
-  Symbol *interface{FindExplicitInterface(x.interfaceName)};
-  if (!interface) {
-    return;
-  }
-  for (auto &bindingName : x.bindingNames) {
-    if (auto *s{MakeTypeSymbol(bindingName, ProcBindingDetails{*interface})}) {
-      SetPassNameOn(*s);
+  if (Symbol * interface{NoteInterfaceName(x.interfaceName)}) {
+    for (auto &bindingName : x.bindingNames) {
+      if (auto *s{
+              MakeTypeSymbol(bindingName, ProcBindingDetails{*interface})}) {
+        SetPassNameOn(*s);
+      }
     }
   }
 }
@@ -3931,32 +3925,27 @@ bool DeclarationVisitor::CanBeTypeBoundProc(const Symbol &symbol) {
   }
 }
 
-void DeclarationVisitor::CheckExplicitInterface(Symbol &symbol) {
-  if (const auto *details{symbol.detailsIf<ProcEntityDetails>()}) {
-    if (const Symbol * interface{details->interface().symbol()}) {
-      if (!interface->HasExplicitInterface() && !context().HasError(symbol)) {
-        if (!context().HasError(*interface)) {
-          Say(symbol.name(),
-              "The interface of '%s' is not an abstract interface or a "
-              "procedure with an explicit interface"_err_en_US);
-        }
-        context().SetError(symbol);
-      }
-    }
+Symbol *DeclarationVisitor::NoteInterfaceName(const parser::Name &name) {
+  // The symbol is checked later by CheckExplicitInterface() to ensure
+  // that it defines an explicit interface.  The name can be a forward
+  // reference.
+  if (!NameIsKnownOrIntrinsic(name)) {
+    Resolve(name, MakeSymbol(InclusiveScope(), name.source, Attrs{}));
   }
+  return name.symbol;
 }
 
-Symbol *DeclarationVisitor::FindExplicitInterface(const parser::Name &name) {
-  auto *symbol{FindSymbol(name)};
-  if (!symbol) {
-    Say(name, "Explicit interface '%s' not found"_err_en_US);
-  } else if (!symbol->HasExplicitInterface()) {
-    SayWithDecl(name, *symbol,
-        "'%s' is not an abstract interface or a procedure with an"
-        " explicit interface"_err_en_US);
-    symbol = nullptr;
+void DeclarationVisitor::CheckExplicitInterface(Symbol &symbol) {
+  if (const Symbol * interface{FindInterface(symbol)}) {
+    const Symbol *subp{FindSubprogram(*interface)};
+    if (subp == nullptr || !subp->HasExplicitInterface()) {
+      Say(symbol.name(),
+          "The interface of '%s' (%s) is not an abstract interface or a "
+          "procedure with an explicit interface"_err_en_US,
+          symbol.name(), interface->name());
+      context().SetError(symbol);
+    }
   }
-  return symbol;
 }
 
 // Create a symbol for a type parameter, component, or procedure binding in
@@ -5207,8 +5196,12 @@ void ResolveNamesVisitor::FinishDerivedType(Scope &scope) {
         common::visitors{
             [&](ProcEntityDetails &x) {
               SetPassArg(comp, x.interface().symbol(), x);
+              CheckExplicitInterface(comp);
+            },
+            [&](ProcBindingDetails &x) {
+              SetPassArg(comp, &x.symbol(), x);
+              CheckExplicitInterface(comp);
             },
-            [&](ProcBindingDetails &x) { SetPassArg(comp, &x.symbol(), x); },
             [](auto &) {},
         },
         comp.details());

flang/lib/semantics/symbol.h

@@ -541,9 +541,15 @@ class Symbol {
             [&](const ProcEntityDetails &x) {
               return attrs_.test(Attr::INTRINSIC) || x.HasExplicitInterface();
             },
+            [](const ProcBindingDetails &x) {
+              return x.symbol().HasExplicitInterface();
+            },
             [](const UseDetails &x) {
               return x.symbol().HasExplicitInterface();
             },
+            [](const HostAssocDetails &x) {
+              return x.symbol().HasExplicitInterface();
+            },
             [](const auto &) { return false; },
         },
         details_);

flang/lib/semantics/tools.cc

@@ -150,6 +150,7 @@ bool IsFunction(const Symbol &symbol) {
             const auto &ifc{x.interface()};
             return ifc.type() || (ifc.symbol() && IsFunction(*ifc.symbol()));
           },
+          [](const ProcBindingDetails &x) { return IsFunction(x.symbol()); },
           [](const UseDetails &x) { return IsFunction(x.symbol()); },
           [](const auto &) { return false; },
       },
@@ -279,15 +280,48 @@ bool ExprTypeKindIsDefault(
       dynamicType->kind() == context.GetDefaultKind(dynamicType->category());
 }
 
+const Symbol *FindInterface(const Symbol &symbol) {
+  return std::visit(
+      common::visitors{
+          [](const ProcEntityDetails &details) {
+            return details.interface().symbol();
+          },
+          [](const ProcBindingDetails &details) { return &details.symbol(); },
+          [](const auto &) -> const Symbol * { return nullptr; },
+      },
+      symbol.details());
+}
+
+const Symbol *FindSubprogram(const Symbol &symbol) {
+  return std::visit(
+      common::visitors{
+          [&](const ProcEntityDetails &details) -> const Symbol * {
+            if (const Symbol * interface{details.interface().symbol()}) {
+              return FindSubprogram(*interface);
+            } else {
+              return &symbol;
+            }
+          },
+          [](const ProcBindingDetails &details) {
+            return FindSubprogram(details.symbol());
+          },
+          [&](const SubprogramDetails &) { return &symbol; },
+          [](const UseDetails &details) {
+            return FindSubprogram(details.symbol());
+          },
+          [](const HostAssocDetails &details) {
+            return FindSubprogram(details.symbol());
+          },
+          [](const auto &) -> const Symbol * { return nullptr; },
+      },
+      symbol.details());
+}
+
 const Symbol *FindFunctionResult(const Symbol &symbol) {
-  if (const auto *procEntity{symbol.detailsIf<ProcEntityDetails>()}) {
-    const ProcInterface &interface{procEntity->interface()};
-    if (interface.symbol() != nullptr) {
-      return FindFunctionResult(*interface.symbol());
-    }
-  } else if (const auto *subp{symbol.detailsIf<SubprogramDetails>()}) {
-    if (subp->isFunction()) {
-      return &subp->result();
+  if (const Symbol * subp{FindSubprogram(symbol)}) {
+    const auto &details{subp->get<SubprogramDetails>()};
+    if (details.isFunction()) {
+      return &details.result();
     }
   }
   return nullptr;

flang/lib/semantics/tools.h

@@ -41,6 +41,8 @@ const Symbol *FindPointerComponent(const Scope &);
 const Symbol *FindPointerComponent(const DerivedTypeSpec &);
 const Symbol *FindPointerComponent(const DeclTypeSpec &);
 const Symbol *FindPointerComponent(const Symbol &);
+const Symbol *FindInterface(const Symbol &);
+const Symbol *FindSubprogram(const Symbol &);
 const Symbol *FindFunctionResult(const Symbol &);
 
 bool IsCommonBlockContaining(const Symbol &block, const Symbol &object);

flang/test/semantics/resolve20.f90

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

flang/test/semantics/resolve32.f90

@@ -57,7 +57,7 @@ subroutine foo
     procedure(foo), nopass, deferred :: f
     !ERROR: DEFERRED is required when an interface-name is provided
     procedure(foo), nopass :: g
-    !ERROR: 'bar' is not an abstract interface or a procedure with an explicit interface
+    !ERROR: The interface of 'h' (bar) is not an abstract interface or a procedure with an explicit interface
     procedure(bar), nopass, deferred :: h
   end type
   type t2