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

[Peter Klausler via flang-commits]

https://github.com/klausler created https://github.com/llvm/llvm-project/pull/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.

>From a75ff58742b3e7e209c54cda2b842b3689ff5828 Mon Sep 17 00:00:00 2001
From: Peter Klausler <pklausler at nvidia.com>
Date: Wed, 2 Jul 2025 11:33:09 -0700
Subject: [PATCH] [flang] Unify derived types in distinct module files

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.
---
 flang/lib/Evaluate/type.cpp      | 47 +++++++++++++++++++++-----------
 flang/test/Semantics/bug1092.F90 | 26 ++++++++++++++++++
 2 files changed, 57 insertions(+), 16 deletions(-)
 create mode 100644 flang/test/Semantics/bug1092.F90

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