[flang] Better error handling and testing of generics with homonymous specifics or derived types

[klausler]

Summary

Fortran allows a generic procedure interface to have the same name as a derived
type in the same scope or the same name as one of its specific procedures.
(It can't have both since a derived type and specific procedure can't have the
same name in a scope.)

Some popular compilers allow generic interfaces with distinct accessible homonymous
specific procedures to be merged by USE association. Thsi compiler does not,
and for good reason: it leads to ambiguity in cases where a procedure name appears
outside a reference, such as in a PROCEDURE declaration statement as the procedure's
interface, the target of a procedure pointer assignment statement, or as an
actual argument.

This patch cleans up the code that handles these cases, improves some error
messages, and adds more tests.

Resolves https://github.com/llvm/llvm-project/issues/60228.

[klausler]

Fix test included in patch.

[PeteSteinfeld]

All builds and tests correctly and looks good.

[klausler]

Further investigation shows that this is not actually valid Fortran usage. Will replace with better error messages and tests.

[klausler]

Previous patch was wrong, as was the bug report. This usage is not good Fortran. Improve error messages and tests.

flang/lib/Semantics/resolve-names.cpp

if (symbol->CanReplaceDetails(details)) {
       SetExplicitAttrs(*symbol, attrs);
       return *symbol;
     } else {
       if (!CheckPossibleBadForwardRef(*symbol)) {
         if (name.empty() && symbol->name().empty()) {
           // report the error elsewhere
           return *symbol;
         }
-        SayAlreadyDeclared(name, *symbol);
+        Symbol &errSym{*symbol};
+        if (auto *d{symbol->detailsIf<GenericDetails>()}) {
+          if (d->specific()) {
+            errSym = *d->specific();
+          } else if (d->derivedType()) {
+            errSym = *d->derivedType();
+          }
+        }
+        SayAlreadyDeclared(name, errSym);
       }
       // replace the old symbol with a new one with correct details
       EraseSymbol(*symbol);
       auto &result{MakeSymbol(name, attrs, std::move(details))};
       context().SetError(result);
       return result;
     }
   }
void ModuleVisitor::DoAddUse(SourceName location, SourceName localName,
   const Symbol &useUltimate{useSymbol.GetUltimate()};
   if (&localUltimate == &useUltimate) {
     // use-associating the same symbol again -- ok
     return;
   }
 
   auto checkAmbiguousDerivedType{[this, location, localName](
                                      const Symbol *t1, const Symbol *t2) {
-    if (!t1 || !t2) {
-      return true;
-    } else {
+    if (t1 && t2) {
       t1 = &t1->GetUltimate();
       t2 = &t2->GetUltimate();
       if (&t1 != &t2) {
         Say(location,
             "Generic interface '%s' has ambiguous derived types from modules '%s' and '%s'"_err_en_US,
             localName, t1->owner().GetName().value(),
             t2->owner().GetName().value());
         return false;
       }
     }
+    return true;
   }};
 
   auto *localGeneric{localUltimate.detailsIf<GenericDetails>()};
   const auto *useGeneric{useUltimate.detailsIf<GenericDetails>()};
   auto combine{false};
   if (localGeneric) {
     if (useGeneric) {
-      if (!checkAmbiguousDerivedType(
-              localGeneric->derivedType(), useGeneric->derivedType())) {
-        return;
-      }
-      combine = true;
+      combine = checkAmbiguousDerivedType(
+          localGeneric->derivedType(), useGeneric->derivedType());
     } else if (useUltimate.has<DerivedTypeDetails>()) {
-      if (checkAmbiguousDerivedType(
-              &useUltimate, localGeneric->derivedType())) {
-        combine = true;
-      } else {
-        return;
-      }
+      combine =
+          checkAmbiguousDerivedType(&useUltimate, localGeneric->derivedType());
     } else if (&useUltimate == &BypassGeneric(localUltimate).GetUltimate()) {
       return; // nothing to do; used subprogram is local's specific
     }
   } else if (useGeneric) {
     if (localUltimate.has<DerivedTypeDetails>()) {
-      if (checkAmbiguousDerivedType(
-              &localUltimate, useGeneric->derivedType())) {
-        combine = true;
-      } else {
-        return;
-      }
+      combine =
+          checkAmbiguousDerivedType(&localUltimate, useGeneric->derivedType());
     } else if (&localUltimate == &BypassGeneric(useUltimate).GetUltimate()) {
       // Local is the specific of the used generic; replace it.
       EraseSymbol(localSymbol);
       Symbol &newSymbol{MakeSymbol(localName,
           useUltimate.attrs() & ~Attrs{Attr::PUBLIC, Attr::PRIVATE},
           UseDetails{localName, useUltimate})};
       newSymbol.flags() = useSymbol.flags();
       return;
void ModuleVisitor::DoAddUse(SourceName location, SourceName localName,
 
   // Two items are being use-associated from different modules
   // to the same local name.  At least one of them must be a generic,
   // and the other one can be a generic or a derived type.
   // (It could also have been the specific of the generic, but those
   // cases are handled above without needing to make a local copy of the
   // generic.)
 
+  std::optional<parser::MessageFixedText> msg;
   if (localGeneric) {
     if (localSymbol.has<UseDetails>()) {
       // Create a local copy of a previously use-associated generic so that
       // it can be locally extended without corrupting the original.
       GenericDetails generic;
       generic.CopyFrom(*localGeneric);
-      if (localGeneric->specific()) {
-        generic.set_specific(*localGeneric->specific());
+      if (Symbol * spec{localGeneric->specific()};
+          spec && !spec->attrs().test(Attr::PRIVATE)) {
+        generic.set_specific(*spec);
+      } else if (Symbol * dt{generic.derivedType()};
+                 dt && dt->attrs().test(Attr::PRIVATE)) {
+        generic.clear_derivedType();
       }
       EraseSymbol(localSymbol);
       Symbol &newSymbol{MakeSymbol(
           localSymbol.name(), localSymbol.attrs(), std::move(generic))};
       newSymbol.flags() = localSymbol.flags();
       localGeneric = &newSymbol.get<GenericDetails>();
       localGeneric->AddUse(localSymbol);
     }
     if (useGeneric) {
       // Combine two use-associated generics
       localSymbol.attrs() =
           useSymbol.attrs() & ~Attrs{Attr::PUBLIC, Attr::PRIVATE};
       localSymbol.flags() = useSymbol.flags();
       AddGenericUse(*localGeneric, localName, useUltimate);
       localGeneric->CopyFrom(*useGeneric);
-      if (useGeneric->specific()) {
-        if (!localGeneric->specific()) {
-          localGeneric->set_specific(
-              *const_cast<Symbol *>(useGeneric->specific()));
+      if (const Symbol * useSpec{useGeneric->specific()};
+          useSpec && !useSpec->attrs().test(Attr::PRIVATE)) {
+        if (localGeneric->derivedType()) {
+          msg =
+              "Cannot use-associate generic interface '%s' with specific procedure of the same name when another such interface and derived type are in scope"_err_en_US;
+        } else if (!localGeneric->specific()) {
+          localGeneric->set_specific(*const_cast<Symbol *>(useSpec));
         } else if (&localGeneric->specific()->GetUltimate() !=
-            &useGeneric->specific()->GetUltimate()) {
-          Say(location,
-              "Cannot use-associate generic interface '%s' with specific procedure of the same name when another such generic is in scope"_err_en_US,
-              localName)
-              .Attach(
-                  localSymbol.name(), "Previous USE of '%s'"_en_US, localName);
+            &useSpec->GetUltimate()) {
+          msg =
+              "Cannot use-associate generic interface '%s' with specific procedure of the same name when another such interface and procedure are in scope"_err_en_US;
+        }
+      } else if (const Symbol * useDT{useGeneric->derivedType()};
+                 useDT && !useDT->attrs().test(Attr::PRIVATE)) {
+        if (localGeneric->specific()) {
+          msg =
+              "Cannot use-associate generic interface '%s' with derived type of the same name when another such interface and procedure are in scope"_err_en_US;
+        } else if (!localGeneric->derivedType()) {
+          localGeneric->set_derivedType(*const_cast<Symbol *>(useDT));
+        } else if (&localGeneric->derivedType()->GetUltimate() !=
+            &useDT->GetUltimate()) {
+          msg =
+              "Cannot use-associate generic interface '%s' with derived type of the same name when another such interface and derived type are in scope"_err_en_US;
         }
       }
     } else {
       CHECK(useUltimate.has<DerivedTypeDetails>());
+      if (!localGeneric->derivedType()) {
         localGeneric->set_derivedType(
             AddGenericUse(*localGeneric, localName, useUltimate));
+      } else if (&localGeneric->derivedType()->GetUltimate() != &useUltimate) {
+        msg =
+            "Cannot use-associate derived type '%s' when a generic interface and derived type of the same name are in scope"_err_en_US;
+      }
     }
   } else {
     CHECK(useGeneric && localUltimate.has<DerivedTypeDetails>());
     CHECK(localSymbol.has<UseDetails>());
     // Create a local copy of the use-associated generic, then extend it
     // with the local derived type.
+    if (!useGeneric->derivedType() ||
+        &useGeneric->derivedType()->GetUltimate() == &localUltimate) {
       GenericDetails generic;
       generic.CopyFrom(*useGeneric);
-    if (useGeneric->specific()) {
-      generic.set_specific(*const_cast<Symbol *>(useGeneric->specific()));
-    }
       EraseSymbol(localSymbol);
       Symbol &newSymbol{MakeSymbol(localName,
           useUltimate.attrs() & ~Attrs{Attr::PUBLIC, Attr::PRIVATE},
           std::move(generic))};
       newSymbol.flags() = useUltimate.flags();
       auto &newUseGeneric{newSymbol.get<GenericDetails>()};
       AddGenericUse(newUseGeneric, localName, useUltimate);
       newUseGeneric.AddUse(localSymbol);
       newUseGeneric.set_derivedType(localSymbol);
+    } else if (useGeneric->derivedType()) {
+      msg =
+          "Cannot use-associate generic interface '%s' with derived type of the same name when another such derived type is in scope"_err_en_US;
+    }
+  }
+  if (msg) {
+    Say(location, std::move(*msg), localName)
+        .Attach(localSymbol.name(), "Previous USE of '%s'"_en_US, localName);
   }
 }
 
 void ModuleVisitor::AddUse(const GenericSpecInfo &info) {
   if (useModuleScope_) {
     const auto &name{info.symbolName()};
     auto rename{AddUse(name, name, FindInScope(*useModuleScope_, name))};
     info.Resolve(rename.use);

flang/test/Semantics/resolve17.f90

interface g
     module procedure g
   end interface
 contains
   subroutine g()
   end
 end module
 subroutine s9a
   use m9a
-  !ERROR: Cannot use-associate generic interface 'g' with specific procedure of the same name when another such generic is in scope
+  !ERROR: Cannot use-associate generic interface 'g' with specific procedure of the same name when another such interface and procedure are in scope
   use m9b
 end
 subroutine s9b
   !ERROR: USE-associated generic 'g' may not have specific procedures 'g' and 'g' as their interfaces are not distinguishable
   use m9a
-  !ERROR: Cannot use-associate generic interface 'g' with specific procedure of the same name when another such generic is in scope
+  !ERROR: Cannot use-associate generic interface 'g' with specific procedure of the same name when another such interface and procedure are in scope
   use m9c
 end
 
 module m10a
   interface g
     module procedure s
   end interface
   private :: s

flang/test/Semantics/resolve18.f90

contains
   !ERROR: 'foo' is already declared in this scoping unit
   function foo(x)
   end
 end
 ! Even if there is also a generic interface of that name
 module m4b
   type :: foo
   end type
-  !ERROR: 'foo' is already declared in this scoping unit
   interface foo
     procedure :: foo
   end interface foo
 contains
+  !ERROR: 'foo' is already declared in this scoping unit
   function foo(x)
   end
 end
 module m4c
   type :: foo
   end type
   interface foo
     !ERROR: 'foo' is already declared in this scoping unit
interface g8
     subroutine f8()
     end subroutine f8
   end interface g8
 end module m8
 
 module m9
   type f9
   end type f9
-  !ERROR: 'f9' is already declared in this scoping unit
   interface f9
     real function f9()
     end function f9
   end interface f9
 contains
+  !ERROR: 'f9' is already declared in this scoping unit
   function f9(x)
   end function f9
 end module m9
 
 module m10
   type :: t10
   end type t10
   interface f10

  contains
   subroutine gen1(x)
     integer(2) :: x
   end subroutine gen1
   subroutine gen2(x)
     integer(4) :: x
   end subroutine gen2
 end module m15
+
+module m15a
+  interface foo
+    module procedure foo
+  end interface
+ contains
+  function foo()
+  end
+end
+
+module m15b
+  interface foo
+    module procedure foo
+  end interface
+ contains
+  function foo(x)
+  end
+end
+
+subroutine test15
+  use m15a
+  !ERROR: Cannot use-associate generic interface 'foo' with specific procedure of the same name when another such interface and procedure are in scope
+  use m15b
+end
+
+module m16a
+  type foo
+    integer j
+  end type
+  interface foo
+    module procedure bar
+  end interface
+ contains
+  function bar(j)
+  end
+end
+
+module m16b
+  type foo
+    integer j, k
+  end type
+  interface foo
+    module procedure bar
+  end interface
+ contains
+  function bar(x,y)
+  end
+end
+
+subroutine test16
+  use m16a
+  !ERROR: Generic interface 'foo' has ambiguous derived types from modules 'm16a' and 'm16b'
+  use m16b
+end
+
+subroutine test17
+  use m15a
+  !ERROR: Cannot use-associate generic interface 'foo' with derived type of the same name when another such interface and procedure are in scope
+  use m16a
+end
+
+subroutine test18
+  use m16a
+  !ERROR: Cannot use-associate generic interface 'foo' with specific procedure of the same name when another such interface and derived type are in scope
+  use m15a
+end

flang/test/Semantics/symbol27.f90

+! RUN: %python %S/test_symbols.py %s %flang_fc1
+!DEF: /m1a Module
+module m1a
+ !DEF: /m1a/foo PUBLIC DerivedType
+ type :: foo
+  !DEF: /m1a/foo/j ObjectEntity INTEGER(4)
+  integer :: j
+ end type
+end module
+!DEF: /m1b Module
+module m1b
+ !DEF: /m1b/foo PUBLIC (Function) Generic
+ interface foo
+  !DEF: /m1b/bar PUBLIC (Function) Subprogram REAL(4)
+  module procedure :: bar
+ end interface
+contains
+ !REF: /m1b/bar
+ function bar()
+ end function
+end module
+!DEF: /test1a (Subroutine) Subprogram
+subroutine test1a
+ !REF: /m1a
+ use :: m1a
+ !REF: /m1b
+ use :: m1b
+ !DEF: /test1a/foo (Function) Generic
+ !DEF: /test1a/x ObjectEntity TYPE(foo)
+ type(foo) :: x
+ !DEF: /test1a/foo Use
+ !REF: /m1b/bar
+ print *, foo(1), foo()
+end subroutine
+!DEF: /test1b (Subroutine) Subprogram
+subroutine test1b
+ !REF: /m1b
+ use :: m1b
+ !REF: /m1a
+ use :: m1a
+ !DEF: /test1b/foo (Function) Generic
+ !DEF: /test1b/x ObjectEntity TYPE(foo)
+ type(foo) :: x
+ !DEF: /test1b/foo Use
+ !REF: /m1b/bar
+ print *, foo(1), foo()
+end subroutine