[flang] Respect function vs subroutine distinction in generic matching

[klausler]

Summary

When checking the specific procedures of a generic interface for a
match against a given set of actual arguments, be sure to not match
a function against a subroutine call or vice versa. (We generally
catch and warn about attempts to declare mixed interfaces, but they
are usually conforming and can be inadvertently created when generics
are merged due to USE and host association.)

[jeanPerier]

Looks good

flang/docs/Extensions.md

* According to 11.1.3.3p1, if a selector of an `ASSOCIATE` or
   We read this to include the case of the variable being a
   pointer-valued function reference.
   No other Fortran compiler seems to handle this correctly for
   `ASSOCIATE`, though NAG gets it right for `SELECT TYPE`.
 * The standard doesn't explicitly require that a named constant that
   appears as part of a complex-literal-constant be a scalar, but
   most compilers emit an error when an array appears.
   f18 supports them with a portability warning.
+* f18 does not enforce a blanket prohibition against generic
+  interfaces containing a mixture of functions and subroutines.
+  Apart from some contexts in which the standard requires all of
+  a particular generic interface to have only all functions or
+  all subroutines as its specific procedures, we allow both to
+  appear, unlike several other Fortran compilers.
+  This is especially desirable when two generics of the same
+  name are combined due to USE association and the mixture may
+  be inadvertent.
 
 ## Behavior in cases where the standard is ambiguous or indefinite
 
 * When an inner procedure of a subprogram uses the value or an attribute
   of an undeclared name in a specification expression and that name does
   not appear in the host, it is not clear in the standard whether that
   name is an implicitly typed local variable of the inner procedure or a
   host association with an implicitly typed local variable of the host.

flang/include/flang/Semantics/expression.h

private:
   std::optional<characteristics::Procedure> CheckCall(
       parser::CharBlock, const ProcedureDesignator &, ActualArguments &);
   using AdjustActuals =
       std::optional<std::function<bool(const Symbol &, ActualArguments &)>>;
   bool ResolveForward(const Symbol &);
   std::pair<const Symbol *, bool /* failure due to NULL() actuals */>
   ResolveGeneric(const Symbol &, const ActualArguments &, const AdjustActuals &,
       bool isSubroutine, bool mightBeStructureConstructor = false);
-  void EmitGenericResolutionError(const Symbol &, bool dueToNullActuals);
+  void EmitGenericResolutionError(
+      const Symbol &, bool dueToNullActuals, bool isSubroutine);
   const Symbol &AccessSpecific(
       const Symbol &originalGeneric, const Symbol &specific);
   std::optional<CalleeAndArguments> GetCalleeAndArguments(const parser::Name &,
       ActualArguments &&, bool isSubroutine = false,
       bool mightBeStructureConstructor = false);
   std::optional<CalleeAndArguments> GetCalleeAndArguments(
       const parser::ProcedureDesignator &, ActualArguments &&,
       bool isSubroutine, bool mightBeStructureConstructor = false);

flang/lib/Semantics/expression.cpp

public:
   void Dump(llvm::raw_ostream &);
 
 private:
   MaybeExpr TryDefinedOp(std::vector<const char *>, parser::MessageFixedText);
   MaybeExpr TryBoundOp(const Symbol &, int passIndex);
   std::optional<ActualArgument> AnalyzeExpr(const parser::Expr &);
   MaybeExpr AnalyzeExprOrWholeAssumedSizeArray(const parser::Expr &);
   bool AreConformable() const;
-  const Symbol *FindBoundOp(
-      parser::CharBlock, int passIndex, const Symbol *&definedOp);
+  const Symbol *FindBoundOp(parser::CharBlock, int passIndex,
+      const Symbol *&definedOp, bool isSubroutine);
   void AddAssignmentConversion(
       const DynamicType &lhsType, const DynamicType &rhsType);
   bool OkLogicalIntegerAssignment(TypeCategory lhs, TypeCategory rhs);
   int GetRank(std::size_t) const;
   bool IsBOZLiteral(std::size_t i) const {
     return evaluate::IsBOZLiteral(GetExpr(i));
   }
   void SayNoMatch(const std::string &, bool isAssignment = false);
if (const Symbol *sym{sc.component.symbol}) {
                 return true;
               }};
           auto pair{ResolveGeneric(*sym, arguments, adjustment, isSubroutine)};
           sym = pair.first;
           if (sym) {
             // re-resolve the name to the specific binding
             sc.component.symbol = const_cast<Symbol *>(sym);
           } else {
-            EmitGenericResolutionError(*sc.component.symbol, pair.second);
+            EmitGenericResolutionError(
+                *sc.component.symbol, pair.second, isSubroutine);
             return std::nullopt;
           }
         }
         std::optional<DataRef> dataRef{ExtractDataRef(std::move(*dtExpr))};
         if (dataRef && !CheckDataRef(*dataRef)) {
           return std::nullopt;
         }
         if (const Symbol *resolution{
if (ultimate.attrs().test(semantics::Attr::INTRINSIC)) {
     }
   }
   if (const auto *details{ultimate.detailsIf<semantics::GenericDetails>()}) {
     bool anyBareNullActual{
         std::find_if(actuals.begin(), actuals.end(), [](auto iter) {
           return IsBareNullPointer(iter->UnwrapExpr());
         }) != actuals.end()};
     for (const Symbol &specific : details->specificProcs()) {
+      if (isSubroutine != !IsFunction(specific)) {
+        continue;
+      }
       if (!ResolveForward(specific)) {
         continue;
       }
       if (std::optional<characteristics::Procedure> procedure{
               characteristics::Procedure::Characterize(
                   ProcedureDesignator{specific}, context_.foldingContext())}) {
         ActualArguments localActuals{actuals};
         if (specific.has<semantics::ProcBindingDetails>()) {
return *const_cast<semantics::Scope &>(scope)
                     semantics::UseDetails{rename, specific})
                 .first->second;
   } else {
     return specific;
   }
 }
 
 void ExpressionAnalyzer::EmitGenericResolutionError(
-    const Symbol &symbol, bool dueToNullActuals) {
+    const Symbol &symbol, bool dueToNullActuals, bool isSubroutine) {
   Say(dueToNullActuals
           ? "One or more NULL() actual arguments to the generic procedure '%s' requires a MOLD= for disambiguation"_err_en_US
           : semantics::IsGenericDefinedOp(symbol)
           ? "No specific procedure of generic operator '%s' matches the actual arguments"_err_en_US
-          : "No specific procedure of generic '%s' matches the actual arguments"_err_en_US,
+          : isSubroutine
+          ? "No specific subroutine of generic '%s' matches the actual arguments"_err_en_US
+          : "No specific function of generic '%s' matches the actual arguments"_err_en_US,
       symbol.name());
 }
 
 auto ExpressionAnalyzer::GetCalleeAndArguments(
     const parser::ProcedureDesignator &pd, ActualArguments &&arguments,
     bool isSubroutine, bool mightBeStructureConstructor)
     -> std::optional<CalleeAndArguments> {
   return common::visit(common::visitors{
if (std::optional<SpecificCall> specificCall{context_.intrinsics().Probe(
             CallCharacteristics{ultimate.name().ToString(), isSubroutine},
             arguments, GetFoldingContext())}) {
       CheckBadExplicitType(*specificCall, *symbol);
       return CalleeAndArguments{
           ProcedureDesignator{std::move(specificCall->specificIntrinsic)},
           std::move(specificCall->arguments)};
     } else {
       if (isGenericInterface) {
-        EmitGenericResolutionError(*symbol, dueToNullActual);
+        EmitGenericResolutionError(*symbol, dueToNullActual, isSubroutine);
       }
       return std::nullopt;
     }
   }
   if (resolution->GetUltimate().has<semantics::DerivedTypeDetails>()) {
     if (mightBeStructureConstructor) {
       return CalleeAndArguments{
           semantics::SymbolRef{*resolution}, std::move(arguments)};
if (!definedOpSymbolPtr) {
     if (Symbol *symbol{scope.FindSymbol(oprName)}) {
       *definedOpSymbolPtr = symbol;
       parser::Name name{symbol->name(), symbol};
       if (auto result{context_.AnalyzeDefinedOp(name, GetActuals())}) {
         return result;
       }
     }
     for (std::size_t passIndex{0}; passIndex < actuals_.size(); ++passIndex) {
-      if (const Symbol *symbol{
-              FindBoundOp(oprName, passIndex, *definedOpSymbolPtr)}) {
+      if (const Symbol *
+          symbol{FindBoundOp(oprName, passIndex, *definedOpSymbolPtr, false)}) {
         if (MaybeExpr result{TryBoundOp(*symbol, passIndex)}) {
           return result;
         }
       }
     }
   }
   if (*definedOpSymbolPtr) {
     SayNoMatch(ToUpperCase((*definedOpSymbolPtr)->name().ToString()));
std::optional<ProcedureRef> ArgumentAnalyzer::GetDefinedAssignmentProc() {
   const Symbol *proc{nullptr};
   const auto &scope{context_.context().FindScope(source_)};
   if (const Symbol *symbol{scope.FindSymbol(oprName)}) {
     ExpressionAnalyzer::AdjustActuals noAdjustment;
     auto pair{context_.ResolveGeneric(*symbol, actuals_, noAdjustment, true)};
     if (pair.first) {
       proc = pair.first;
     } else {
-      context_.EmitGenericResolutionError(*symbol, pair.second);
+      context_.EmitGenericResolutionError(*symbol, pair.second, true);
     }
   }
   int passedObjectIndex{-1};
   const Symbol *definedOpSymbol{nullptr};
   for (std::size_t i{0}; i < actuals_.size(); ++i) {
-    if (const Symbol *specific{FindBoundOp(oprName, i, definedOpSymbol)}) {
-      if (const Symbol *resolution{
-              GetBindingResolution(GetType(i), *specific)}) {
+    if (const Symbol *
+        specific{FindBoundOp(oprName, i, definedOpSymbol, true)}) {
+      if (const Symbol *
+          resolution{GetBindingResolution(GetType(i), *specific)}) {
         proc = resolution;
       } else {
         proc = specific;
         passedObjectIndex = i;
       }
     }
   }
   if (!proc) {

 
 bool ArgumentAnalyzer::AreConformable() const {
   CHECK(actuals_.size() == 2);
   return actuals_[0] && actuals_[1] &&
       evaluate::AreConformable(*actuals_[0], *actuals_[1]);
 }
 
 // Look for a type-bound operator in the type of arg number passIndex.
-const Symbol *ArgumentAnalyzer::FindBoundOp(
-    parser::CharBlock oprName, int passIndex, const Symbol *&definedOp) {
+const Symbol *ArgumentAnalyzer::FindBoundOp(parser::CharBlock oprName,
+    int passIndex, const Symbol *&definedOp, bool isSubroutine) {
   const auto *type{GetDerivedTypeSpec(GetType(passIndex))};
   if (!type || !type->scope()) {
     return nullptr;
   }
   const Symbol *symbol{type->scope()->FindComponent(oprName)};
   if (!symbol) {
     return nullptr;
   }
   definedOp = symbol;
   ExpressionAnalyzer::AdjustActuals adjustment{
       [&](const Symbol &proc, ActualArguments &) {
         return passIndex == GetPassIndex(proc);
       }};
-  auto pair{context_.ResolveGeneric(*symbol, actuals_, adjustment, false)};
+  auto pair{
+      context_.ResolveGeneric(*symbol, actuals_, adjustment, isSubroutine)};
   if (!pair.first) {
-    context_.EmitGenericResolutionError(*symbol, pair.second);
+    context_.EmitGenericResolutionError(*symbol, pair.second, isSubroutine);
   }
   return pair.first;
 }
 
 // If there is an implicit conversion between intrinsic types, make it explicit
 void ArgumentAnalyzer::AddAssignmentConversion(
     const DynamicType &lhsType, const DynamicType &rhsType) {
   if (lhsType.category() == rhsType.category() &&

flang/lib/Semantics/resolve-names.cpp

if (symbolsSeen.insert(ultimate).second /*true if added*/) {
           "Procedure '%s' from module '%s' is already specified in generic '%s'"_err_en_US,
           ultimate.name(), ultimate.owner().GetName().value(),
           MakeOpName(generic.name()));
     }
   }
   specificProcs_.erase(range.first, range.second);
 }
 
-// Check that the specific procedures are all functions or all subroutines.
-// If there is a derived type with the same name they must be functions.
-// Set the corresponding flag on generic.
+// Mixed interfaces are allowed by the standard.
+// If there is a derived type with the same name, they must all be functions.
 void InterfaceVisitor::CheckGenericProcedures(Symbol &generic) {
   ResolveSpecificsInGeneric(generic);
   auto &details{generic.get<GenericDetails>()};
   if (auto *proc{details.CheckSpecific()}) {
     auto msg{
         "'%s' should not be the name of both a generic interface and a"
         " procedure unless it is a specific procedure of the generic"_warn_en_US};
     if (proc->name().begin() > generic.name().begin()) {
       Say(proc->name(), std::move(msg));
     } else {
       Say(generic.name(), std::move(msg));
     }
   }
   auto &specifics{details.specificProcs()};
   if (specifics.empty()) {
     if (details.derivedType()) {
       generic.set(Symbol::Flag::Function);
     }
     return;
   }
   const Symbol &firstSpecific{specifics.front()};
   bool isFunction{firstSpecific.test(Symbol::Flag::Function)};
+  bool isBoth{false};
   for (const Symbol &specific : specifics) {
     if (isFunction != specific.test(Symbol::Flag::Function)) { // C1514
       auto &msg{Say(generic.name(),
-          "Generic interface '%s' has both a function and a subroutine"_err_en_US)};
+          "Generic interface '%s' has both a function and a subroutine"_warn_en_US)};
       if (isFunction) {
         msg.Attach(firstSpecific.name(), "Function declaration"_en_US);
         msg.Attach(specific.name(), "Subroutine declaration"_en_US);
       } else {
         msg.Attach(firstSpecific.name(), "Subroutine declaration"_en_US);
         msg.Attach(specific.name(), "Function declaration"_en_US);
       }
+      isFunction = false;
+      isBoth = true;
+      break;
     }
   }
   if (!isFunction && details.derivedType()) {
     SayDerivedType(generic.name(),
         "Generic interface '%s' may only contain functions due to derived type"
         " with same name"_err_en_US,
         *details.derivedType()->GetUltimate().scope());
   }
+  if (!isBoth) {
     generic.set(isFunction ? Symbol::Flag::Function : Symbol::Flag::Subroutine);
   }
+}
 
 // SubprogramVisitor implementation
 
 // 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

flang/test/Semantics/generic03.f90

+! RUN: %python %S/test_errors.py %s %flang_fc1
+! Exercise function vs subroutine distinction in generics
+module m1
+  type t1
+    integer n
+  end type
+  interface g1
+    integer function f1(x, j)
+      import t1
+      class(t1), intent(in out) :: x
+      integer, intent(in) :: j
+    end
+  end interface
+end module
+
+program test
+  use m1
+  !WARNING: Generic interface 'g1' has both a function and a subroutine
+  interface g1
+    subroutine s1(x, a)
+      import t1
+      class(t1), intent(in out) :: x
+      real, intent(in) :: a
+    end subroutine
+  end interface
+  type(t1) :: x
+  print *, g1(x,1) ! ok
+  !ERROR: No specific function of generic 'g1' matches the actual arguments
+  print *, g1(x,1.)
+  !ERROR: No specific subroutine of generic 'g1' matches the actual arguments
+  call g1(x,1)
+  call g1(x, 1.) ! ok
+ contains
+end

flang/test/Semantics/resolve62.f90

 ! RUN: %python %S/test_errors.py %s %flang_fc1
 ! Resolve generic based on number of arguments
 subroutine subr1
   interface f
     real function f1(x)
       optional :: x
     end
     real function f2(x, y)
     end
   end interface
   z = f(1.0)
   z = f(1.0, 2.0)
-  !ERROR: No specific procedure of generic 'f' matches the actual arguments
+  !ERROR: No specific function of generic 'f' matches the actual arguments
   z = f(1.0, 2.0, 3.0)
 end
 
 ! Elemental and non-element function both match: non-elemental one should be used
 subroutine subr2
   interface f
     logical elemental function f1(x)
       intent(in) :: x

flang/test/Semantics/resolve68.f90

contains
   integer function add_real(x, y)
     class(t), intent(in) :: x
     real, intent(in) :: y
   end
   subroutine test1(x, y, z)
     type(t) :: x
     integer :: y
     integer :: z
-    !ERROR: No specific procedure of generic 'g' matches the actual arguments
+    !ERROR: No specific function of generic 'g' matches the actual arguments
     z = x%g(y)
   end
   subroutine test2(x, y, z)
     type(t) :: x
     real :: y
     integer :: z
-    !ERROR: No specific procedure of generic 'g' matches the actual arguments
+    !ERROR: No specific function of generic 'g' matches the actual arguments
     z = x%g(x, y)
   end
 end

flang/test/Semantics/resolve77.f90

 ! RUN: %python %S/test_errors.py %s %flang_fc1
 ! Tests valid and invalid usage of forward references to procedures
 ! in specification expressions.
 module m
   interface ifn2
     module procedure if2
   end interface
   interface ifn3
     module procedure if3
   end interface
   !ERROR: Automatic data object 'a' may not appear in the specification part of a module
   real :: a(if1(1))
-  !ERROR: No specific procedure of generic 'ifn2' matches the actual arguments
+  !ERROR: No specific function of generic 'ifn2' matches the actual arguments
   real :: b(ifn2(1))
  contains
   subroutine t1(n)
     integer :: iarr(if1(n))
   end subroutine
   pure integer function if1(n)
     integer, intent(in) :: n
     if1 = n