[flang] Respect function vs subroutine distinction in generic matching

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

Differential Revision: https://reviews.llvm.org/D139059

diff --git a/flang/docs/Extensions.md b/flang/docs/Extensions.md
index 039b1f9..a512048 100644 (file)
--- a/flang/docs/Extensions.md
+++ b/flang/docs/Extensions.md
@@ -356,6 +356,15 @@ end
   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
 

diff --git a/flang/include/flang/Semantics/expression.h b/flang/include/flang/Semantics/expression.h
index bb6a14a..8474ec6 100644 (file)
--- a/flang/include/flang/Semantics/expression.h
+++ b/flang/include/flang/Semantics/expression.h
@@ -354,7 +354,8 @@ private:
   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 &,

diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp
index 7b9b367..cd0c717 100644 (file)
--- a/flang/lib/Semantics/expression.cpp
+++ b/flang/lib/Semantics/expression.cpp
@@ -174,8 +174,8 @@ private:
   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);
@@ -2078,7 +2078,8 @@ auto ExpressionAnalyzer::AnalyzeProcedureComponentRef(
             // 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;
           }
         }
@@ -2223,6 +2224,9 @@ std::pair<const Symbol *, bool> ExpressionAnalyzer::ResolveGeneric(
           return IsBareNullPointer(iter->UnwrapExpr());
         }) != actuals.end()};
     for (const Symbol &specific : details->specificProcs()) {
+      if (isSubroutine != !IsFunction(specific)) {
+        continue;
+      }
       if (!ResolveForward(specific)) {
         continue;
       }
@@ -2327,12 +2331,14 @@ const Symbol &ExpressionAnalyzer::AccessSpecific(
 }
 
 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());
 }
 
@@ -2395,7 +2401,7 @@ auto ExpressionAnalyzer::GetCalleeAndArguments(const parser::Name &name,
           std::move(specificCall->arguments)};
     } else {
       if (isGenericInterface) {
-        EmitGenericResolutionError(*symbol, dueToNullActual);
+        EmitGenericResolutionError(*symbol, dueToNullActual, isSubroutine);
       }
       return std::nullopt;
     }
@@ -3654,8 +3660,8 @@ MaybeExpr ArgumentAnalyzer::TryDefinedOp(const char *opr,
       }
     }
     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;
         }
@@ -3773,15 +3779,16 @@ std::optional<ProcedureRef> ArgumentAnalyzer::GetDefinedAssignmentProc() {
     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;
@@ -3863,8 +3870,8 @@ bool ArgumentAnalyzer::AreConformable() const {
 }
 
 // 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;
@@ -3878,9 +3885,10 @@ const Symbol *ArgumentAnalyzer::FindBoundOp(
       [&](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;
 }

diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp
index 510f7cb..980f1b1 100644 (file)
--- a/flang/lib/Semantics/resolve-names.cpp
+++ b/flang/lib/Semantics/resolve-names.cpp
@@ -3246,9 +3246,8 @@ void InterfaceVisitor::ResolveSpecificsInGeneric(Symbol &generic) {
   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>()};
@@ -3271,10 +3270,11 @@ void InterfaceVisitor::CheckGenericProcedures(Symbol &generic) {
   }
   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);
@@ -3282,6 +3282,9 @@ void InterfaceVisitor::CheckGenericProcedures(Symbol &generic) {
         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()) {
@@ -3290,7 +3293,9 @@ void InterfaceVisitor::CheckGenericProcedures(Symbol &generic) {
         " 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

diff --git a/flang/test/Semantics/generic03.f90 b/flang/test/Semantics/generic03.f90
new file mode 100644 (file)
index 0000000..829780f
--- /dev/null
+++ b/flang/test/Semantics/generic03.f90
@@ -0,0 +1,34 @@
+! 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

diff --git a/flang/test/Semantics/resolve62.f90 b/flang/test/Semantics/resolve62.f90
index ee4049f..5d297f0 100644 (file)
--- a/flang/test/Semantics/resolve62.f90
+++ b/flang/test/Semantics/resolve62.f90
@@ -10,7 +10,7 @@ subroutine subr1
   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
 

diff --git a/flang/test/Semantics/resolve68.f90 b/flang/test/Semantics/resolve68.f90
index 0221fbc..28d90a6 100644 (file)
--- a/flang/test/Semantics/resolve68.f90
+++ b/flang/test/Semantics/resolve68.f90
@@ -21,14 +21,14 @@ contains
     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

diff --git a/flang/test/Semantics/resolve77.f90 b/flang/test/Semantics/resolve77.f90
index d762781..1f5e4d4 100644 (file)
--- a/flang/test/Semantics/resolve77.f90
+++ b/flang/test/Semantics/resolve77.f90
@@ -10,7 +10,7 @@ module m
   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)