[flang] Relax error into a warning (#107489)

The standard requires that a generic interface with the same name as a
derived type contain only functions. We generally allow a generic
interface to contain both functions and subroutines, since there's never
any ambiguity at the point of call; these is helpful when the specific
procedures of two generics are combined during USE association. Emit a
warning instead of a hard error when a generic interface with the same
name as a derived type contains a subroutine to improve portability of
code from compilers that don't check for this condition.

Author: klausler

flang/docs/Extensions.md

@@ -507,10 +507,7 @@ end
   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.
+  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.

flang/lib/Semantics/resolve-names.cpp

@@ -3639,36 +3639,36 @@ void InterfaceVisitor::CheckGenericProcedures(Symbol &generic) {
     }
     return;
   }
-  const Symbol &firstSpecific{specifics.front()};
-  bool isFunction{firstSpecific.test(Symbol::Flag::Function)};
-  bool isBoth{false};
+  const Symbol *function{nullptr};
+  const Symbol *subroutine{nullptr};
   for (const Symbol &specific : specifics) {
-    if (isFunction != specific.test(Symbol::Flag::Function)) { // C1514
-      if (context().ShouldWarn(
+    if (!function && specific.test(Symbol::Flag::Function)) {
+      function = &specific;
+    } else if (!subroutine && specific.test(Symbol::Flag::Subroutine)) {
+      subroutine = &specific;
+      if (details.derivedType() &&
+          context().ShouldWarn(
               common::LanguageFeature::SubroutineAndFunctionSpecifics)) {
+        SayDerivedType(generic.name(),
+            "Generic interface '%s' should only contain functions due to derived type with same name"_warn_en_US,
+            *details.derivedType()->GetUltimate().scope());
+      }
+    }
+    if (function && subroutine) {
+      if (context().ShouldWarn(common::LanguageFeature::
+                  SubroutineAndFunctionSpecifics)) { // C1514
         auto &msg{Say(generic.name(),
             "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);
-        }
+        msg.Attach(function->name(), "Function declaration"_en_US);
+        msg.Attach(subroutine->name(), "Subroutine 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);
+  if (function && !subroutine) {
+    generic.set(Symbol::Flag::Function);
+  } else if (subroutine && !function) {
+    generic.set(Symbol::Flag::Subroutine);
   }
 }
 

flang/test/Semantics/resolve24.f90

@@ -1,6 +1,6 @@
 ! RUN: %python %S/test_errors.py %s %flang_fc1
 subroutine test1
-  !ERROR: Generic interface 'foo' has both a function and a subroutine
+  !WARNING: Generic interface 'foo' has both a function and a subroutine
   interface foo
     subroutine s1(x)
     end subroutine
@@ -12,7 +12,7 @@ function f()
 end subroutine
 
 subroutine test2
-  !ERROR: Generic interface 'foo' has both a function and a subroutine
+  !WARNING: Generic interface 'foo' has both a function and a subroutine
   interface foo
     function t2f1(x)
     end function
@@ -24,7 +24,7 @@ function t2f2(x, y)
 end subroutine
 
 module test3
-  !ERROR: Generic interface 'foo' has both a function and a subroutine
+  !WARNING: Generic interface 'foo' has both a function and a subroutine
   interface foo
     module procedure s
     module procedure f
@@ -39,7 +39,7 @@ function f()
 subroutine test4
   type foo
   end type
-  !ERROR: Generic interface 'foo' may only contain functions due to derived type with same name
+  !WARNING: Generic interface 'foo' should only contain functions due to derived type with same name
   interface foo
     subroutine s()
     end subroutine