[flang-commits] [flang] 2b7e3f6 - [flang] Unify derived types in distinct module files (#146759)

[via flang-commits]

Author: Peter Klausler
Date: 2025-07-03T14:34:16-07:00
New Revision: 2b7e3f6fa6fb1a45a2bf542788325db12666976e

URL: https://github.com/llvm/llvm-project/commit/2b7e3f6fa6fb1a45a2bf542788325db12666976e
DIFF: https://github.com/llvm/llvm-project/commit/2b7e3f6fa6fb1a45a2bf542788325db12666976e.diff

LOG: [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.

Added: 
    flang/test/Semantics/bug1092.F90

Modified: 
    flang/lib/Evaluate/type.cpp

Removed: 
    


################################################################################
diff  --git a/flang/lib/Evaluate/type.cpp b/flang/lib/Evaluate/type.cpp
index 5b5f3c2cd0cf0..99dc8b1e5c676 100644
--- a/flang/lib/Evaluate/type.cpp
+++ b/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();
   }
 }
 

diff  --git a/flang/test/Semantics/bug1092.F90 b/flang/test/Semantics/bug1092.F90
new file mode 100644
index 0000000000000..ef108733fd78b
--- /dev/null
+++ b/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