[flang-commits] [flang] d46c639 - [flang] Fix derived type compatibility checking in ALLOCATE (#102035)

[via flang-commits]

Author: Peter Klausler
Date: 2024-08-08T11:06:05-07:00
New Revision: d46c639ebf19eacc6bd37240981ff1b1ef497b1b

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

LOG: [flang] Fix derived type compatibility checking in ALLOCATE (#102035)

The derived type compatibility checking for ALLOCATE statements with
SOURCE= or MOLD= was only checking for the same derived type name. That
is a necessary but not sufficient check, and it can produce bogus errors
as well as miss valid errors.

Fixes https://github.com/llvm/llvm-project/issues/101909.

Added: 
    

Modified: 
    flang/include/flang/Evaluate/type.h
    flang/lib/Evaluate/type.cpp
    flang/lib/Semantics/check-allocate.cpp
    flang/test/Semantics/allocate08.f90

Removed: 
    


################################################################################
diff  --git a/flang/include/flang/Evaluate/type.h b/flang/include/flang/Evaluate/type.h
index 16c2b319ff1de6..bd8887dbce4e82 100644
--- a/flang/include/flang/Evaluate/type.h
+++ b/flang/include/flang/Evaluate/type.h
@@ -494,7 +494,9 @@ bool IsCUDAIntrinsicType(const DynamicType &);
 // Determine whether two derived type specs are sufficiently identical
 // to be considered the "same" type even if declared separately.
 bool AreSameDerivedType(
-    const semantics::DerivedTypeSpec &x, const semantics::DerivedTypeSpec &y);
+    const semantics::DerivedTypeSpec &, const semantics::DerivedTypeSpec &);
+bool AreSameDerivedTypeIgnoringTypeParameters(
+    const semantics::DerivedTypeSpec &, const semantics::DerivedTypeSpec &);
 
 // For generating "[extern] template class", &c. boilerplate
 #define EXPAND_FOR_EACH_INTEGER_KIND(M, P, S) \

diff  --git a/flang/lib/Evaluate/type.cpp b/flang/lib/Evaluate/type.cpp
index 463ac01da0e295..5ecc3701b4f246 100644
--- a/flang/lib/Evaluate/type.cpp
+++ b/flang/lib/Evaluate/type.cpp
@@ -505,7 +505,13 @@ bool AreSameDerivedType(
   return AreSameDerivedType(x, y, false, false, inProgress);
 }
 
-bool AreSameDerivedType(
+bool AreSameDerivedTypeIgnoringTypeParameters(
+    const semantics::DerivedTypeSpec &x, const semantics::DerivedTypeSpec &y) {
+  SetOfDerivedTypePairs inProgress;
+  return AreSameDerivedType(x, y, true, true, inProgress);
+}
+
+static bool AreSameDerivedType(
     const semantics::DerivedTypeSpec *x, const semantics::DerivedTypeSpec *y) {
   return x == y || (x && y && AreSameDerivedType(*x, *y));
 }

diff  --git a/flang/lib/Semantics/check-allocate.cpp b/flang/lib/Semantics/check-allocate.cpp
index 8f7a200d23239b..a5363a6710d319 100644
--- a/flang/lib/Semantics/check-allocate.cpp
+++ b/flang/lib/Semantics/check-allocate.cpp
@@ -270,11 +270,13 @@ static bool IsTypeCompatible(
     const DeclTypeSpec &type1, const DerivedTypeSpec &derivedType2) {
   if (const DerivedTypeSpec * derivedType1{type1.AsDerived()}) {
     if (type1.category() == DeclTypeSpec::Category::TypeDerived) {
-      return &derivedType1->typeSymbol() == &derivedType2.typeSymbol();
+      return evaluate::AreSameDerivedTypeIgnoringTypeParameters(
+          *derivedType1, derivedType2);
     } else if (type1.category() == DeclTypeSpec::Category::ClassDerived) {
       for (const DerivedTypeSpec *parent{&derivedType2}; parent;
            parent = parent->typeSymbol().GetParentTypeSpec()) {
-        if (&derivedType1->typeSymbol() == &parent->typeSymbol()) {
+        if (evaluate::AreSameDerivedTypeIgnoringTypeParameters(
+                *derivedType1, *parent)) {
           return true;
         }
       }

diff  --git a/flang/test/Semantics/allocate08.f90 b/flang/test/Semantics/allocate08.f90
index cc074a149ae9ed..b2b88f78b32bea 100644
--- a/flang/test/Semantics/allocate08.f90
+++ b/flang/test/Semantics/allocate08.f90
@@ -95,6 +95,42 @@ subroutine bar
   end subroutine
 end module
 
+module mod1
+  type, bind(C) :: t
+     integer :: n
+  end type
+  type(t), allocatable :: x
+end
+
+module mod2
+  type, bind(C) :: t
+     integer :: n
+  end type
+  type(t), allocatable :: x
+end
+
+module mod3
+  type, bind(C) :: t
+     real :: a
+  end type
+  type(t), allocatable :: x
+end
+
+subroutine same_type
+  use mod1, only: a => x
+  use mod2, only: b => x
+  use mod3, only: c => x
+  allocate(a)
+  allocate(b, source=a) ! ok
+  deallocate(a)
+  allocate(a, source=b) ! ok
+  !ERROR: Allocatable object in ALLOCATE must be type compatible with source expression from MOLD or SOURCE
+  allocate(c, source=a)
+  deallocate(a)
+  !ERROR: Allocatable object in ALLOCATE must be type compatible with source expression from MOLD or SOURCE
+  allocate(a, source=c)
+end
+
 ! Related to C945, check typeless expression are caught
 
 subroutine sub