[flang] Compare component types In AreSameComponent()

[klausler]

Summary

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.

[clementval]

LGTM

[probinson]

@klausler this commit added a file generic05.f90 when there was already a file in the same directory named generic05.F90. Note the difference f versus F. This causes checkouts on Windows to be unusable, because it has a case-insensitive filesystem.

Please revert this and change the name of the test file before recommitting. Thanks!

[klausler]

Fixed! Thanks for the clear explanation.

From: Paul Robinson via Phabricator <[e-mail]>
Date: Friday, July 21, 2023 at 14:14
To: Peter Klausler <[e-mail]>, [e-mail] <[e-mail]>, Steve Scalpone <[e-mail]>
Cc: [e-mail] <[e-mail]>, [e-mail] <[e-mail]>, [e-mail] <[e-mail]>, [e-mail] <[e-mail]>, [e-mail] <[e-mail]>, [e-mail] <[e-mail]>, [e-mail] <[e-mail]>, [e-mail] <[e-mail]>, Renaud Kauffmann <[e-mail]>, [e-mail] <[e-mail]>, [e-mail] <[e-mail]>, Peter Steinfeld <[e-mail]>, [e-mail] <[e-mail]>, Jean Perier <[e-mail]>, [e-mail] <[e-mail]>, [e-mail] <[e-mail]>, [e-mail] <[e-mail]>, [e-mail] <[e-mail]>, [e-mail] <[e-mail]>, [e-mail] <[e-mail]>, [e-mail] <[e-mail]>, Slava Zakharin <[e-mail]>, [e-mail] <[e-mail]>, [e-mail] <[e-mail]>, [e-mail] <[e-mail]>, Eric Schweitz <[e-mail]>, [e-mail] <[e-mail]>, [e-mail] <[e-mail]>, [e-mail] <[e-mail]>, [e-mail] <[e-mail]>
Subject: [PATCH] D155962: [flang] Compare component types In AreSameComponent()
External email: Use caution opening links or attachments

probinson added a comment.

@klausler this commit added a file generic05.f90 when there was already a file in the same directory named generic05.F90. Note the difference f versus F. This causes checkouts on Windows to be unusable, because it has a case-insensitive filesystem.

Please revert this and change the name of the test file before recommitting. Thanks!

Repository:

rG LLVM Github Monorepo

CHANGES SINCE LAST ACTION

https://nam11.safelinks.protection.outlook.com/?url=https%3A%2F%2Freviews.llvm.org%2FD155962%2Fnew%2F&data=05%7C01%7Cpklausler%40nvidia.com%7Cb5630cfede9c4f06894708db8a2f6b45%7C43083d15727340c1b7db39efd9ccc17a%7C0%7C0%7C638255708623198307%7CUnknown%7CTWFpbGZsb3d8eyJWIjoiMC4wLjAwMDAiLCJQIjoiV2luMzIiLCJBTiI6Ik1haWwiLCJXVCI6Mn0%3D%7C3000%7C%7C%7C&sdata=Hn%2FNratbSrBNFOWA%2B0xGsY7vr5Kt38QmE%2BsnoLWDt4g%3D&reserved=0<https://reviews.llvm.org/D155962/new/>

https://nam11.safelinks.protection.outlook.com/?url=https%3A%2F%2Freviews.llvm.org%2FD155962&data=05%7C01%7Cpklausler%40nvidia.com%7Cb5630cfede9c4f06894708db8a2f6b45%7C43083d15727340c1b7db39efd9ccc17a%7C0%7C0%7C638255708623198307%7CUnknown%7CTWFpbGZsb3d8eyJWIjoiMC4wLjAwMDAiLCJQIjoiV2luMzIiLCJBTiI6Ik1haWwiLCJXVCI6Mn0%3D%7C3000%7C%7C%7C&sdata=d5pRcKQ7jJXFWPrlQkXKpy0uAnnHSU1QtluiXvWLjnc%3D&reserved=0https://reviews.llvm.org/D155962

flang/lib/Evaluate/type.cpp

 // represent the "same type" in the sense of section 7.5.2.4.
 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
 // dependency and should be repackaged into then "namespace semantics"
 // part of Evaluate/tools.cpp.

     }
   }
   return true;
 }
 
+// F2023 7.5.3.2
 static bool AreSameDerivedType(const semantics::DerivedTypeSpec &x,
     const semantics::DerivedTypeSpec &y, bool ignoreTypeParameterValues,
     bool ignoreLenParameters, SetOfDerivedTypePairs &inProgress) {
   if (&x == &y) {
     return true;
   }
   if (!ignoreTypeParameterValues &&
       !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;
   }
   if (xSymbol.name() != ySymbol.name()) {
     return false;

   const auto &yDetails{ySymbol.get<semantics::DerivedTypeDetails>()};
   if (!(xDetails.sequence() && yDetails.sequence()) &&
       !(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.
   auto xEnd{xDetails.componentNames().cend()};
   auto yComponentName{yDetails.componentNames().cbegin()};

flang/test/Semantics/generic05.f90

+! 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