[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

   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
 

flang/include/flang/Semantics/expression.h

   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 &,

flang/lib/Semantics/expression.cpp

   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);

             // 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;
           }
         }

           return IsBareNullPointer(iter->UnwrapExpr());
         }) != actuals.end()};
     for (const Symbol &specific : details->specificProcs()) {
+      if (isSubroutine != !IsFunction(specific)) {
+        continue;
+      }
       if (!ResolveForward(specific)) {
         continue;
       }

 }
 
 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());
 }
 

           std::move(specificCall->arguments)};
     } else {
       if (isGenericInterface) {
-        EmitGenericResolutionError(*symbol, dueToNullActual);
+        EmitGenericResolutionError(*symbol, dueToNullActual, isSubroutine);
       }
       return std::nullopt;
     }

     }
     for (std::size_t passIndex{0}; passIndex < actuals_.size(); ++passIndex) {
       if (const Symbol *
-          symbol{FindBoundOp(oprName, passIndex, *definedOpSymbolPtr)}) {
+          symbol{FindBoundOp(oprName, passIndex, *definedOpSymbolPtr, false)}) {
         if (MaybeExpr result{TryBoundOp(*symbol, passIndex)}) {
           return result;
         }

     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 *
+        specific{FindBoundOp(oprName, i, definedOpSymbol, true)}) {
       if (const Symbol *
           resolution{GetBindingResolution(GetType(i), *specific)}) {
         proc = resolution;

 }
 
 // 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 &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;
 }

flang/lib/Semantics/resolve-names.cpp

   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>()};

   }
   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);

         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()) {

         " with same name"_err_en_US,
         *details.derivedType()->GetUltimate().scope());
   }
-  generic.set(isFunction ? Symbol::Flag::Function : Symbol::Flag::Subroutine);
+  if (!isBoth) {
+    generic.set(isFunction ? Symbol::Flag::Function : Symbol::Flag::Subroutine);
+  }
 }
 
 // SubprogramVisitor implementation

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

   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
 

flang/test/Semantics/resolve68.f90

     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

   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)