[flang] Relax error into a warning

[klausler]

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.

[llvmbot]

@llvm/pr-subscribers-flang-semantics

Author: Peter Klausler (klausler)

Changes

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.

---

Full diff: https://github.com/llvm/llvm-project/pull/107489.diff

3 Files Affected:

• (modified) flang/docs/Extensions.md (+1-4)
• (modified) flang/lib/Semantics/resolve-names.cpp (+22-22)
• (modified) flang/test/Semantics/resolve24.f90 (+4-4)

diff --git a/flang/docs/Extensions.md b/flang/docs/Extensions.md
index fb57744c215703..340939baca99f0 100644
--- a/flang/docs/Extensions.md
+++ b/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.
diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp
index 2e86e0afc9bd0e..b764678357db31 100644
--- a/flang/lib/Semantics/resolve-names.cpp
+++ b/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);
   }
 }
 
diff --git a/flang/test/Semantics/resolve24.f90 b/flang/test/Semantics/resolve24.f90
index 4af6f202cf4f18..72d6719665bb58 100644
--- a/flang/test/Semantics/resolve24.f90
+++ b/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

[jeanPerier]

LGTM