[flang-commits] [flang] f6026f6 - [flang] Compare component types In AreSameComponent()

[Peter Klausler via flang-commits]

Author: Peter Klausler
Date: 2023-07-21T12:01:54-07:00
New Revision: f6026f65be7113953c72720182562c3d67d2312e

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

LOG: [flang] Compare component types In AreSameComponent()

The subroutine AreSameComponent() of the predicate AreSameDerivedType()
had a TODO about checking component types that needed completion in order
to properly detect that two specific procedures of a generic are
distinguishable in the llvm-test-suite/Fortran/gfortran/regression
test import7.f90.

Differential Revision: https://reviews.llvm.org/D155962

Added: 
    flang/test/Semantics/generic05.f90

Modified: 
    flang/lib/Evaluate/type.cpp

Removed: 
    


################################################################################
diff  --git a/flang/lib/Evaluate/type.cpp b/flang/lib/Evaluate/type.cpp
index 9c9daafcce3a45..12e931afddf4dc 100644
--- a/flang/lib/Evaluate/type.cpp
+++ b/flang/lib/Evaluate/type.cpp
@@ -283,18 +283,53 @@ using SetOfDerivedTypePairs =
     std::set<std::pair<const semantics::DerivedTypeSpec *,
         const semantics::DerivedTypeSpec *>>;
 
+static bool AreSameDerivedType(const semantics::DerivedTypeSpec &,
+    const semantics::DerivedTypeSpec &, bool ignoreTypeParameterValues,
+    bool ignoreLenParameters, SetOfDerivedTypePairs &inProgress);
+
+// F2023 7.5.3.2
 static bool AreSameComponent(const semantics::Symbol &x,
-    const semantics::Symbol &y,
-    SetOfDerivedTypePairs & /* inProgress - not yet used */) {
+    const semantics::Symbol &y, SetOfDerivedTypePairs &inProgress) {
   if (x.attrs() != y.attrs()) {
     return false;
   }
   if (x.attrs().test(semantics::Attr::PRIVATE)) {
     return false;
   }
-  // TODO: compare types, parameters, bounds, &c.
-  return x.has<semantics::ObjectEntityDetails>() ==
-      y.has<semantics::ObjectEntityDetails>();
+  if (x.size() && y.size()) {
+    if (x.offset() != y.offset() || x.size() != y.size()) {
+      return false;
+    }
+  }
+  const auto *xObj{x.detailsIf<semantics::ObjectEntityDetails>()};
+  const auto *yObj{y.detailsIf<semantics::ObjectEntityDetails>()};
+  const auto *xProc{x.detailsIf<semantics::ProcEntityDetails>()};
+  const auto *yProc{y.detailsIf<semantics::ProcEntityDetails>()};
+  if (!xObj != !yObj || !xProc != !yProc) {
+    return false;
+  }
+  auto xType{DynamicType::From(x)};
+  auto yType{DynamicType::From(y)};
+  if (xType && yType) {
+    if (xType->category() == TypeCategory::Derived) {
+      if (yType->category() != TypeCategory::Derived ||
+          !xType->IsUnlimitedPolymorphic() !=
+              !yType->IsUnlimitedPolymorphic() ||
+          (!xType->IsUnlimitedPolymorphic() &&
+              !AreSameDerivedType(xType->GetDerivedTypeSpec(),
+                  yType->GetDerivedTypeSpec(), false, false, inProgress))) {
+        return false;
+      }
+    } else if (!xType->IsTkLenCompatibleWith(*yType)) {
+      return false;
+    }
+  } else if (xType || yType || !(xProc && yProc)) {
+    return false;
+  }
+  if (xProc) {
+    // TODO: compare argument types, &c.
+  }
+  return true;
 }
 
 // TODO: These utilities were cloned out of Semantics to avoid a cyclic
@@ -403,6 +438,7 @@ static bool AreTypeParamCompatible(const semantics::DerivedTypeSpec &x,
   return true;
 }
 
+// F2023 7.5.3.2
 static bool AreSameDerivedType(const semantics::DerivedTypeSpec &x,
     const semantics::DerivedTypeSpec &y, bool ignoreTypeParameterValues,
     bool ignoreLenParameters, SetOfDerivedTypePairs &inProgress) {
@@ -413,8 +449,8 @@ static bool AreSameDerivedType(const semantics::DerivedTypeSpec &x,
       !AreTypeParamCompatible(x, y, ignoreLenParameters)) {
     return false;
   }
-  const auto &xSymbol{x.typeSymbol()};
-  const auto &ySymbol{y.typeSymbol()};
+  const auto &xSymbol{x.typeSymbol().GetUltimate()};
+  const auto &ySymbol{y.typeSymbol().GetUltimate()};
   if (xSymbol == ySymbol) {
     return true;
   }
@@ -432,7 +468,7 @@ static bool AreSameDerivedType(const semantics::DerivedTypeSpec &x,
       !(xSymbol.attrs().test(semantics::Attr::BIND_C) &&
           ySymbol.attrs().test(semantics::Attr::BIND_C))) {
     // PGI does not enforce this requirement; all other Fortran
-    // processors do with a hard error when violations are caught.
+    // compilers do with a hard error when violations are caught.
     return false;
   }
   // Compare the component lists in their orders of declaration.

diff  --git a/flang/test/Semantics/generic05.f90 b/flang/test/Semantics/generic05.f90
new file mode 100644
index 00000000000000..885697e4b5a978
--- /dev/null
+++ b/flang/test/Semantics/generic05.f90
@@ -0,0 +1,74 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+module m
+  type :: t1
+    sequence
+    real :: x
+  end type
+  type :: t2
+    sequence
+    real :: x
+  end type
+  type :: t3
+    real :: x
+  end type
+  type :: t4
+    real, private :: x
+  end type
+ contains
+  subroutine s1a(x)
+    type(t1), intent(in) :: x
+  end
+  subroutine s2a(x)
+    type(t2), intent(in) :: x
+  end
+  subroutine s3a(x)
+    type(t3), intent(in) :: x
+  end
+  subroutine s4a(x)
+    type(t4), intent(in) :: x
+  end
+end
+
+program test
+  use m, only: s1a, s2a, s3a, s4a
+  type :: t1
+    sequence
+    integer :: x ! distinct type
+  end type
+  type :: t2
+    sequence
+    real :: x
+  end type
+  type :: t3 ! no SEQUENCE
+    real :: x
+  end type
+  type :: t4
+    real :: x ! not PRIVATE
+  end type
+  interface distinguishable1
+    procedure :: s1a, s1b
+  end interface
+  interface distinguishable2
+    procedure :: s1a, s1b
+  end interface
+  interface distinguishable3
+    procedure :: s1a, s1b
+  end interface
+  !ERROR: Generic 'indistinguishable' may not have specific procedures 's2a' and 's2b' as their interfaces are not distinguishable
+  interface indistinguishable
+    procedure :: s2a, s2b
+  end interface
+ contains
+  subroutine s1b(x)
+    type(t1), intent(in) :: x
+  end
+  subroutine s2b(x)
+    type(t2), intent(in) :: x
+  end
+  subroutine s3b(x)
+    type(t3), intent(in) :: x
+  end
+  subroutine s4b(x)
+    type(t4), intent(in) :: x
+  end
+end