[flang] Improve USE merging of homonymous types, interfaces, and proc… (#79364)

…edures

Fortran allows a generic interface to have the same name as a derived
type in the same scope. It also allows a generic interface to have the
same name as one of its specific procedures.

When two modules define the same name, possibly more than once each,
things get exciting. The standard is not clear, and other compilers do
variously different things. We are currently emitting some errors
prematurely for some usage in pfUnit due to how it combines two versions
of a package together via USE association.

This patch handles combinations of derived types and generic interfaces
and their specific procedures in a more principled way. Errors due to
ambiguity are deferred to actual usage of derived types and specific
procedures -- and when they're not used, the program is unambiguous and
no error issues.

Author: klausler

flang/include/flang/Semantics/symbol.h

@@ -637,7 +637,9 @@ class GenericDetails {
   const SymbolVector &uses() const { return uses_; }
 
   // specific and derivedType indicate a specific procedure or derived type
-  // with the same name as this generic. Only one of them may be set.
+  // with the same name as this generic. Only one of them may be set in
+  // a scope that declares them, but both can be set during USE association
+  // when generics are combined.
   Symbol *specific() { return specific_; }
   const Symbol *specific() const { return specific_; }
   void set_specific(Symbol &specific);

flang/include/flang/Semantics/tools.h

@@ -692,5 +692,8 @@ std::string GetModuleOrSubmoduleName(const Symbol &);
 // Return the assembly name emitted for a common block.
 std::string GetCommonBlockObjectName(const Symbol &, bool underscoring);
 
+// Check for ambiguous USE associations
+bool HadUseError(SemanticsContext &, SourceName at, const Symbol *);
+
 } // namespace Fortran::semantics
 #endif // FORTRAN_SEMANTICS_TOOLS_H_

flang/lib/Semantics/expression.cpp

@@ -235,6 +235,9 @@ MaybeExpr ExpressionAnalyzer::Designate(DataRef &&ref) {
     return std::nullopt;
   } else if (MaybeExpr result{AsGenericExpr(std::move(ref))}) {
     return result;
+  } else if (semantics::HadUseError(
+                 context_, GetContextualMessages().at(), &symbol)) {
+    return std::nullopt;
   } else {
     if (!context_.HasError(last) && !context_.HasError(symbol)) {
       AttachDeclaration(

flang/lib/Semantics/resolve-names.cpp

@@ -192,12 +192,10 @@ void GenericDetails::AddSpecificProc(
 }
 void GenericDetails::set_specific(Symbol &specific) {
   CHECK(!specific_);
-  CHECK(!derivedType_);
   specific_ = &specific;
 }
 void GenericDetails::clear_specific() { specific_ = nullptr; }
 void GenericDetails::set_derivedType(Symbol &derivedType) {
-  CHECK(!specific_);
   CHECK(!derivedType_);
   derivedType_ = &derivedType;
 }
@@ -211,7 +209,7 @@ const Symbol *GenericDetails::CheckSpecific() const {
   return const_cast<GenericDetails *>(this)->CheckSpecific();
 }
 Symbol *GenericDetails::CheckSpecific() {
-  if (specific_) {
+  if (specific_ && !specific_->has<UseErrorDetails>()) {
     for (const Symbol &proc : specificProcs_) {
       if (&proc == specific_) {
         return nullptr;

flang/lib/Semantics/symbol.cpp

@@ -1685,4 +1685,21 @@ std::string GetCommonBlockObjectName(const Symbol &common, bool underscoring) {
                       : common.name().ToString();
 }
 
+bool HadUseError(
+    SemanticsContext &context, SourceName at, const Symbol *symbol) {
+  if (const auto *details{
+          symbol ? symbol->detailsIf<UseErrorDetails>() : nullptr}) {
+    auto &msg{context.Say(
+        at, "Reference to '%s' is ambiguous"_err_en_US, symbol->name())};
+    for (const auto &[location, module] : details->occurrences()) {
+      msg.Attach(location, "'%s' was use-associated from module '%s'"_en_US, at,
+          module->GetName().value());
+    }
+    context.SetError(*symbol);
+    return true;
+  } else {
+    return false;
+  }
+}
+
 } // namespace Fortran::semantics

flang/lib/Semantics/tools.cpp

@@ -175,29 +175,14 @@ module m9b
   interface g
     module procedure g
   end interface
-contains
-  subroutine g(x)
-    real :: x
-  end
-end module
-module m9c
-  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 interface and procedure are in scope
-  use m9b
-end
-subroutine s9b
+subroutine s9
   !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 interface and procedure are in scope
-  use m9c
+  use m9b
 end
 
 module m10a
@@ -223,24 +208,6 @@ subroutine s(x)
   end
 end
 
-module m11a
-  interface g
-  end interface
-  type g
-  end type
-end module
-module m11b
-  interface g
-  end interface
-  type g
-  end type
-end module
-module m11c
-  use m11a
-  !ERROR: Generic interface 'g' has ambiguous derived types from modules 'm11a' and 'm11b'
-  use m11b
-end module
-
 module m12a
   interface ga
     module procedure sa

flang/test/Semantics/resolve17.f90

@@ -229,10 +229,10 @@ function foo(x)
 
 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
+  use m15b ! ok
 end
 
+
 module m16a
   type foo
     integer j
@@ -259,18 +259,110 @@ function bar(x,y)
 
 subroutine test16
   use m16a
-  !ERROR: Generic interface 'foo' has ambiguous derived types from modules 'm16a' and 'm16b'
-  use m16b
+  use m16b ! ok
 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
+  use m16a ! ok
 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
+  use m15a ! ok
+end
+
+module m21
+  type foo
+    integer a
+  end type
+  interface foo
+    module procedure f1
+  end interface
+ contains
+  function f1(a)
+    f1 = a
+  end
+end
+
+module m22
+  type foo
+    real b
+  end type
+  interface foo
+    module procedure f2
+  end interface
+ contains
+  function f2(a,b)
+    f2 = a + b
+  end
+end
+
+module m23
+  interface foo
+    module procedure foo
+    module procedure f3
+  end interface
+ contains
+  function foo()
+    foo = 0.
+  end
+  function f3(a,b,c)
+    f3 = a + b + c
+  end
+end
+
+module m24
+  interface foo
+    module procedure foo
+    module procedure f4
+  end interface
+ contains
+  function foo(a)
+    foo = a
+  end
+  function f4(a,b,c,d)
+    f4 = a + b + c +d
+  end
+end
+
+subroutine s_21_22_a
+  use m21
+  use m22
+  print *, foo(1.) ! Intel error
+  print *, foo(1.,2.) ! Intel error
+end
+
+subroutine s_21_22_b
+  use m21
+  use m22
+  !ERROR: 'foo' is not a derived type
+  type(foo) x ! definite error: GNU and Intel catch
+end
+
+subroutine s_21_23
+  use m21
+  use m23
+  type(foo) x ! Intel and NAG error
+  print *, foo(1.) ! Intel error
+  print *, foo(1.,2.,3.) ! Intel error
+  call ext(foo) ! GNU and Intel error
+end
+
+subroutine s_22_23
+  use m22
+  use m23
+  type(foo) x ! Intel and NAG error
+  print *, foo(1.,2.) ! Intel error
+  print *, foo(1.,2.,3.) ! Intel error
+  call ext(foo) ! Intel error
+end
+
+subroutine s_23_24
+  use m23
+  use m24
+  print *, foo(1.,2.,3.) ! NAG error
+  print *, foo(1.,2.,3.,4.) ! XLF error
+  !ERROR: 'foo' is not a specific procedure
+  call ext(foo) ! definite error
 end

flang/test/Semantics/resolve18.f90

@@ -28,7 +28,7 @@ subroutine test1a
  !DEF: /test1a/foo (Function) Generic
  !DEF: /test1a/x ObjectEntity TYPE(foo)
  type(foo) :: x
- !DEF: /test1a/foo Use
+ !REF: /m1a/foo
  !REF: /m1b/bar
  print *, foo(1), foo()
 end subroutine
@@ -41,7 +41,7 @@ subroutine test1b
  !DEF: /test1b/foo (Function) Generic
  !DEF: /test1b/x ObjectEntity TYPE(foo)
  type(foo) :: x
- !DEF: /test1b/foo Use
+ !REF: /m1a/foo
  !REF: /m1b/bar
  print *, foo(1), foo()
 end subroutine