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

[via flang-commits]

llvmbot wrote:


<!--LLVM PR SUMMARY COMMENT-->

@llvm/pr-subscribers-flang-semantics

Author: Peter Klausler (klausler)

<details>
<summary>Changes</summary>

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.

---
Full diff: https://github.com/llvm/llvm-project/pull/146759.diff


2 Files Affected:

- (modified) flang/lib/Evaluate/type.cpp (+31-16) 
- (added) flang/test/Semantics/bug1092.F90 (+26) 


``````````diff
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

``````````

</details>


https://github.com/llvm/llvm-project/pull/146759