[flang] Unify derived types in distinct module files (#146759)

When using -fhermetic-module-files it's possible for a derived type to
have multiple distinct definition sites that are being compared for
being the same type, as in argument association. Accept them as being
the same type so long as they have the same names, the same module
names, and identical definitions.

Author: klausler

flang/lib/Evaluate/type.cpp

@@ -299,13 +299,18 @@ static bool AreSameDerivedType(const semantics::DerivedTypeSpec &,
 
 // F2023 7.5.3.2
 static bool AreSameComponent(const semantics::Symbol &x,
-    const semantics::Symbol &y, bool ignoreSequence,
+    const semantics::Symbol &y, bool ignoreSequence, bool sameModuleName,
     SetOfDerivedTypePairs &inProgress) {
   if (x.attrs() != y.attrs()) {
     return false;
   }
-  if (x.attrs().test(semantics::Attr::PRIVATE)) {
-    return false;
+  if (x.attrs().test(semantics::Attr::PRIVATE) ||
+      y.attrs().test(semantics::Attr::PRIVATE)) {
+    if (!sameModuleName ||
+        x.attrs().test(semantics::Attr::PRIVATE) !=
+            y.attrs().test(semantics::Attr::PRIVATE)) {
+      return false;
+    }
   }
   if (x.size() && y.size()) {
     if (x.offset() != y.offset() || x.size() != y.size()) {
@@ -482,9 +487,20 @@ static bool AreSameDerivedType(const semantics::DerivedTypeSpec &x,
           ySymbol.attrs().test(semantics::Attr::BIND_C)) {
     return false;
   }
-  if (!ignoreSequence && !(xDetails.sequence() && yDetails.sequence()) &&
-      !(xSymbol.attrs().test(semantics::Attr::BIND_C) &&
-          ySymbol.attrs().test(semantics::Attr::BIND_C))) {
+  bool sameModuleName{false};
+  const semantics::Scope &xOwner{xSymbol.owner()};
+  const semantics::Scope &yOwner{ySymbol.owner()};
+  if (xOwner.IsModule() && yOwner.IsModule()) {
+    if (auto xModuleName{xOwner.GetName()}) {
+      if (auto yModuleName{yOwner.GetName()}) {
+        if (*xModuleName == *yModuleName) {
+          sameModuleName = true;
+        }
+      }
+    }
+  }
+  if (!sameModuleName && !ignoreSequence && !xDetails.sequence() &&
+      !xSymbol.attrs().test(semantics::Attr::BIND_C)) {
     // PGI does not enforce this requirement; all other Fortran
     // compilers do with a hard error when violations are caught.
     return false;
@@ -502,9 +518,10 @@ static bool AreSameDerivedType(const semantics::DerivedTypeSpec &x,
     const auto xLookup{xSymbol.scope()->find(*xComponentName)};
     const auto yLookup{ySymbol.scope()->find(*yComponentName)};
     if (xLookup == xSymbol.scope()->end() ||
-        yLookup == ySymbol.scope()->end() ||
-        !AreSameComponent(
-            *xLookup->second, *yLookup->second, ignoreSequence, inProgress)) {
+        yLookup == ySymbol.scope()->end()) {
+      return false;
+    } else if (!AreSameComponent(*xLookup->second, *yLookup->second,
+                   ignoreSequence, sameModuleName, inProgress)) {
       return false;
     }
   }
@@ -576,17 +593,15 @@ static bool AreCompatibleTypes(const DynamicType &x, const DynamicType &y,
     const auto yLen{y.knownLength()};
     return x.kind() == y.kind() &&
         (ignoreLengths || !xLen || !yLen || *xLen == *yLen);
-  } else if (x.category() != TypeCategory::Derived) {
-    if (x.IsTypelessIntrinsicArgument()) {
-      return y.IsTypelessIntrinsicArgument();
-    } else {
-      return !y.IsTypelessIntrinsicArgument() && x.kind() == y.kind();
-    }
-  } else {
+  } else if (x.category() == TypeCategory::Derived) {
     const auto *xdt{GetDerivedTypeSpec(x)};
     const auto *ydt{GetDerivedTypeSpec(y)};
     return AreCompatibleDerivedTypes(
         xdt, ydt, x.IsPolymorphic(), ignoreTypeParameterValues, false);
+  } else if (x.IsTypelessIntrinsicArgument()) {
+    return y.IsTypelessIntrinsicArgument();
+  } else {
+    return !y.IsTypelessIntrinsicArgument() && x.kind() == y.kind();
   }
 }
 

flang/test/Semantics/bug1092.F90

@@ -0,0 +1,26 @@
+!RUN: rm -rf %t && mkdir -p %t
+!RUN: %flang_fc1 -DWHICH=1 -fsyntax-only -J%t %s
+!RUN: %flang_fc1 -DWHICH=2 -fsyntax-only -fhermetic-module-files -I%t -J%t %s
+!RUN: %flang_fc1 -fsyntax-only -I%t %s 2>&1 | FileCheck --allow-empty %s
+!CHECK-NOT: error:
+
+#if WHICH == 1
+module bug1092a
+  type t
+  end type
+ contains
+  subroutine subr(x)
+    type(t) x
+  end
+end
+#elif WHICH == 2
+module bug1092b
+  use bug1092a, only: subr
+end
+#else
+use bug1092a, only: t
+use bug1092b, only: subr
+type(t) x
+call subr(x)
+end
+#endif