[flang][runtime] Fix SAME_TYPE_AS()/EXTENDS_TYPE_OF() for CLASS(*)

[klausler]

Ensure that the f18Addendum flag is preserved in AllocatableApplyMold(), that raw().type is reinitialized in AllocatableDeallocatePolymorphic(), and that the implementations of SameTypeAs() and ExtendsTypeOf() handle unallocated unlimited polymorphic arguments correctly.

[llvmbot]

@llvm/pr-subscribers-flang-runtime

Changes

Ensure that the f18Addendum flag is preserved in AllocatableApplyMold(), that raw().type is reinitialized in AllocatableDeallocatePolymorphic(), and that the implementations of SameTypeAs() and ExtendsTypeOf() handle unallocated unlimited polymorphic arguments correctly.

---

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

3 Files Affected:

• (modified) flang/runtime/allocatable.cpp (+10-7)
• (modified) flang/runtime/derived-api.cpp (+42-60)
• (modified) flang/runtime/pointer.cpp (+10-7)

diff --git a/flang/runtime/allocatable.cpp b/flang/runtime/allocatable.cpp
index 4b9e438e8a10995..b755974f6400fd5 100644
--- a/flang/runtime/allocatable.cpp
+++ b/flang/runtime/allocatable.cpp
@@ -130,15 +130,17 @@ void RTNAME(AllocatableApplyMold)(
     // 9.7.1.3 Return so the error can be emitted by AllocatableAllocate.
     return;
   }
+  auto *descAddendum{descriptor.Addendum()};
   descriptor = mold;
   descriptor.set_base_addr(nullptr);
   descriptor.raw().attribute = CFI_attribute_allocatable;
   descriptor.raw().rank = rank;
-  if (auto *descAddendum{descriptor.Addendum()}) {
-    if (const auto *moldAddendum{mold.Addendum()}) {
-      if (const auto *derived{moldAddendum->derivedType()}) {
-        descAddendum->set_derivedType(derived);
-      }
+  if (descAddendum) {
+    if (mold.Addendum()) {
+      // it was copied by operator=() above
+    } else {
+      descriptor.raw().f18Addendum = true;
+      descAddendum->set_derivedType(nullptr);
     }
   }
 }
@@ -198,14 +200,15 @@ int RTNAME(AllocatableDeallocatePolymorphic)(Descriptor &descriptor,
   int stat{RTNAME(AllocatableDeallocate)(
       descriptor, hasStat, errMsg, sourceFile, sourceLine)};
   if (stat == StatOk) {
-    DescriptorAddendum *addendum{descriptor.Addendum()};
-    if (addendum) {
+    if (DescriptorAddendum * addendum{descriptor.Addendum()}) {
       addendum->set_derivedType(derivedType);
+      descriptor.raw().type = derivedType ? CFI_type_struct : CFI_type_other;
     } else {
       // Unlimited polymorphic descriptors initialized with
       // AllocatableInitIntrinsic do not have an addendum. Make sure the
       // derivedType is null in that case.
       INTERNAL_CHECK(!derivedType);
+      descriptor.raw().type = CFI_type_other;
     }
   }
   return stat;
diff --git a/flang/runtime/derived-api.cpp b/flang/runtime/derived-api.cpp
index 32d4bb26608b4dd..e2a7ad72e54c593 100644
--- a/flang/runtime/derived-api.cpp
+++ b/flang/runtime/derived-api.cpp
@@ -89,73 +89,55 @@ static const typeInfo::DerivedType *GetDerivedType(const Descriptor &desc) {
 }
 
 bool RTNAME(SameTypeAs)(const Descriptor &a, const Descriptor &b) {
-  // Unlimited polymorphic with intrinsic dynamic type.
-  if (a.raw().type != CFI_type_struct && a.raw().type != CFI_type_other &&
-      b.raw().type != CFI_type_struct && b.raw().type != CFI_type_other)
-    return a.raw().type == b.raw().type;
-
-  const typeInfo::DerivedType *derivedTypeA{GetDerivedType(a)};
-  const typeInfo::DerivedType *derivedTypeB{GetDerivedType(b)};
-
-  // No dynamic type in one or both descriptor.
-  if (derivedTypeA == nullptr || derivedTypeB == nullptr) {
-    return false;
-  }
-
-  // Exact match of derived type.
-  if (derivedTypeA == derivedTypeB) {
-    return true;
+  auto aType{a.raw().type};
+  auto bType{b.raw().type};
+  if ((aType != CFI_type_struct && aType != CFI_type_other) ||
+      (bType != CFI_type_struct && bType != CFI_type_other)) {
+    // If either type is intrinsic, they must match.
+    return aType == bType;
+  } else {
+    const typeInfo::DerivedType *derivedTypeA{GetDerivedType(a)};
+    const typeInfo::DerivedType *derivedTypeB{GetDerivedType(b)};
+    if (derivedTypeA == nullptr || derivedTypeB == nullptr) {
+      // Unallocated/disassociated CLASS(*) never matches.
+      return false;
+    } else if (derivedTypeA == derivedTypeB) {
+      // Exact match of derived type.
+      return true;
+    } else {
+      // Otherwise compare with the name. Note 16.29 kind type parameters are
+      // not considered in the test.
+      return CompareDerivedTypeNames(
+          derivedTypeA->name(), derivedTypeB->name());
+    }
   }
-  // Otherwise compare with the name. Note 16.29 kind type parameters are not
-  // considered in the test.
-  return CompareDerivedTypeNames(derivedTypeA->name(), derivedTypeB->name());
 }
 
 bool RTNAME(ExtendsTypeOf)(const Descriptor &a, const Descriptor &mold) {
-  if (a.raw().type != CFI_type_struct && a.raw().type != CFI_type_other &&
-      mold.raw().type != CFI_type_struct && mold.raw().type != CFI_type_other)
-    return a.raw().type == mold.raw().type;
-
-  const typeInfo::DerivedType *derivedTypeA{GetDerivedType(a)};
-  const typeInfo::DerivedType *derivedTypeMold{GetDerivedType(mold)};
-
-  // If MOLD is unlimited polymorphic and is either a disassociated pointer or
-  // unallocated allocatable, the result is true.
-  // Unlimited polymorphic descriptors are initialized with a CFI_type_other
-  // type.
-  if (mold.type().raw() == CFI_type_other &&
-      (mold.IsAllocatable() || mold.IsPointer()) &&
-      derivedTypeMold == nullptr) {
-    return true;
-  }
-
-  // If A is unlimited polymorphic and is either a disassociated pointer or
-  // unallocated allocatable, the result is false.
-  // Unlimited polymorphic descriptors are initialized with a CFI_type_other
-  // type.
-  if (a.type().raw() == CFI_type_other &&
-      (a.IsAllocatable() || a.IsPointer()) && derivedTypeA == nullptr) {
-    return false;
-  }
-
-  if (derivedTypeA == nullptr || derivedTypeMold == nullptr) {
+  auto aType{a.raw().type};
+  auto moldType{mold.raw().type};
+  if ((aType != CFI_type_struct && aType != CFI_type_other) ||
+      (moldType != CFI_type_struct && moldType != CFI_type_other)) {
+    // If either type is intrinsic, they must match.
+    return aType == moldType;
+  } else if (const typeInfo::DerivedType *
+      derivedTypeMold{GetDerivedType(mold)}) {
+    // If A is unlimited polymorphic and is either a disassociated pointer or
+    // unallocated allocatable, the result is false.
+    // Otherwise if the dynamic type of A or MOLD is extensible, the result is
+    // true if and only if the dynamic type of A is an extension type of the
+    // dynamic type of MOLD.
+    for (const typeInfo::DerivedType *derivedTypeA{GetDerivedType(a)};
+         derivedTypeA; derivedTypeA = derivedTypeA->GetParentType()) {
+      if (CompareDerivedType(derivedTypeA, derivedTypeMold)) {
+        return true;
+      }
+    }
     return false;
-  }
-
-  // Otherwise if the dynamic type of A or MOLD is extensible, the result is
-  // true if and only if the dynamic type of A is an extension type of the
-  // dynamic type of MOLD.
-  if (CompareDerivedType(derivedTypeA, derivedTypeMold)) {
+  } else {
+    // MOLD is unlimited polymorphic and unallocated/disassociated.
     return true;
   }
-  const typeInfo::DerivedType *parent{derivedTypeA->GetParentType()};
-  while (parent) {
-    if (CompareDerivedType(parent, derivedTypeMold)) {
-      return true;
-    }
-    parent = parent->GetParentType();
-  }
-  return false;
 }
 
 void RTNAME(DestroyWithoutFinalization)(const Descriptor &descriptor) {
diff --git a/flang/runtime/pointer.cpp b/flang/runtime/pointer.cpp
index 0320468ffdc7904..29e2634d7be8b8b 100644
--- a/flang/runtime/pointer.cpp
+++ b/flang/runtime/pointer.cpp
@@ -56,15 +56,17 @@ void RTNAME(PointerSetDerivedLength)(
 
 void RTNAME(PointerApplyMold)(
     Descriptor &pointer, const Descriptor &mold, int rank) {
+  auto *pointerAddendum{pointer.Addendum()};
   pointer = mold;
   pointer.set_base_addr(nullptr);
   pointer.raw().attribute = CFI_attribute_pointer;
   pointer.raw().rank = rank;
-  if (auto *pointerAddendum{pointer.Addendum()}) {
-    if (const auto *moldAddendum{mold.Addendum()}) {
-      if (const auto *derived{moldAddendum->derivedType()}) {
-        pointerAddendum->set_derivedType(derived);
-      }
+  if (pointerAddendum) {
+    if (mold.Addendum()) {
+      // it was copied by operator=() above
+    } else {
+      pointer.raw().f18Addendum = true;
+      pointerAddendum->set_derivedType(nullptr);
     }
   }
 }
@@ -183,14 +185,15 @@ int RTNAME(PointerDeallocatePolymorphic)(Descriptor &pointer,
   int stat{RTNAME(PointerDeallocate)(
       pointer, hasStat, errMsg, sourceFile, sourceLine)};
   if (stat == StatOk) {
-    DescriptorAddendum *addendum{pointer.Addendum()};
-    if (addendum) {
+    if (DescriptorAddendum * addendum{pointer.Addendum()}) {
       addendum->set_derivedType(derivedType);
+      pointer.raw().type = derivedType ? CFI_type_struct : CFI_type_other;
     } else {
       // Unlimited polymorphic descriptors initialized with
       // PointerNullifyIntrinsic do not have an addendum. Make sure the
       // derivedType is null in that case.
       INTERNAL_CHECK(!derivedType);
+      pointer.raw().type = CFI_type_other;
     }
   }
   return stat;

[vzakhari]

LGTM

[vzakhari]

nit: Can we just assert that its original derived type is null? As I understand, the LHS is supposed to be unlimited polymorphic here and it is unallocated, so its derived type must have been reset to null elsewhere.

[klausler]

Sure

[vzakhari]

Interesting. I did not think we could do it here, but apparently we can.

Tried this example:

module types
  type :: t1
  end type t1
end module types
program main
  use types
  call test()
contains
  subroutine test()
    class(*), pointer :: x
    type(t1) :: y
    allocate(x,mold=y)
    allocate(x,mold=y)
  end subroutine test
end program main

The compiler nullifies the pointer before calling PointerApplyMold. This seems to be redundant now, since we started initializing pointers (including the components of the derived types) by default.

Thank you for the additional changes!