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

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 llvm#60228.

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

Author: klausler

flang/lib/Semantics/resolve-names.cpp

@@ -630,7 +630,15 @@ class ScopeHandler : public ImplicitRulesVisitor {
           // 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);
@@ -2899,9 +2907,7 @@ void ModuleVisitor::DoAddUse(SourceName location, SourceName localName,
 
   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) {
@@ -2912,36 +2918,26 @@ void ModuleVisitor::DoAddUse(SourceName location, SourceName localName,
         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);
@@ -2989,14 +2985,19 @@ void ModuleVisitor::DoAddUse(SourceName location, SourceName localName,
   // 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(
@@ -3012,43 +3013,67 @@ void ModuleVisitor::DoAddUse(SourceName location, SourceName localName,
       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>());
-      localGeneric->set_derivedType(
-          AddGenericUse(*localGeneric, localName, useUltimate));
+      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.
-    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);
+    if (!useGeneric->derivedType() ||
+        &useGeneric->derivedType()->GetUltimate() == &localUltimate) {
+      GenericDetails generic;
+      generic.CopyFrom(*useGeneric);
+      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);
   }
 }
 

flang/test/Semantics/resolve17.f90

@@ -190,13 +190,13 @@ subroutine g()
 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
 

flang/test/Semantics/resolve18.f90

@@ -55,11 +55,11 @@ function foo(x)
 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
@@ -125,12 +125,12 @@ 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
@@ -208,3 +208,69 @@ 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

@@ -0,0 +1,47 @@
+! 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