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

[Peter Klausler via flang-commits]

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

>From c465141597cf47f2c5edd116d57aeeeca89bcc3c Mon Sep 17 00:00:00 2001
From: Peter Klausler <pklausler at nvidia.com>
Date: Mon, 5 Aug 2024 11:13:48 -0700
Subject: [PATCH] [flang] Fix derived type compatibility checking in ALLOCATE

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.
---
 flang/include/flang/Evaluate/type.h    |  4 ++-
 flang/lib/Evaluate/type.cpp            |  8 +++++-
 flang/lib/Semantics/check-allocate.cpp |  6 +++--
 flang/test/Semantics/allocate08.f90    | 36 ++++++++++++++++++++++++++
 4 files changed, 50 insertions(+), 4 deletions(-)

diff --git a/flang/include/flang/Evaluate/type.h b/flang/include/flang/Evaluate/type.h
index 16c2b319ff1de..bd8887dbce4e8 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 463ac01da0e29..5ecc3701b4f24 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 8f7a200d23239..a5363a6710d31 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 cc074a149ae9e..b2b88f78b32be 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