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

flang/include/flang/Runtime/descriptor.h

@@ -408,6 +408,8 @@ class Descriptor {
       const SubscriptValue *upper = nullptr,
       const SubscriptValue *stride = nullptr);
 
+  RT_API_ATTRS void ApplyMold(const Descriptor &, int rank);
+
   RT_API_ATTRS void Check() const;
 
   void Dump(FILE * = stdout) const;

flang/runtime/allocatable.cpp

@@ -130,17 +130,7 @@ void RTNAME(AllocatableApplyMold)(
     // 9.7.1.3 Return so the error can be emitted by AllocatableAllocate.
     return;
   }
-  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);
-      }
-    }
-  }
+  descriptor.ApplyMold(mold, rank);
 }
 
 int RTNAME(AllocatableAllocate)(Descriptor &descriptor, bool hasStat,
@@ -198,14 +188,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;

flang/runtime/derived-api.cpp

@@ -101,73 +101,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) {

flang/runtime/descriptor.cpp

@@ -243,6 +243,22 @@ RT_API_ATTRS bool Descriptor::EstablishPointerSection(const Descriptor &source,
   return CFI_section(&raw_, &source.raw_, lower, upper, stride) == CFI_SUCCESS;
 }
 
+RT_API_ATTRS void Descriptor::ApplyMold(const Descriptor &mold, int rank) {
+  raw_.elem_len = mold.raw_.elem_len;
+  raw_.rank = rank;
+  raw_.type = mold.raw_.type;
+  for (int j{0}; j < rank && j < mold.raw_.rank; ++j) {
+    GetDimension(j) = mold.GetDimension(j);
+  }
+  if (auto *addendum{Addendum()}) {
+    if (auto *moldAddendum{mold.Addendum()}) {
+      *addendum = *moldAddendum;
+    } else {
+      INTERNAL_CHECK(!addendum->derivedType());
+    }
+  }
+}
+
 RT_API_ATTRS void Descriptor::Check() const {
   // TODO
 }

flang/runtime/pointer.cpp

@@ -56,17 +56,7 @@ void RTNAME(PointerSetDerivedLength)(
 
 void RTNAME(PointerApplyMold)(
     Descriptor &pointer, const Descriptor &mold, int rank) {
-  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);
-      }
-    }
-  }
+  pointer.ApplyMold(mold, rank);
 }
 
 void RTNAME(PointerAssociateScalar)(Descriptor &pointer, void *target) {
@@ -183,14 +173,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;

flang/runtime/type-info.cpp

@@ -251,10 +251,12 @@ FILE *DerivedType::Dump(FILE *f) const {
   std::fprintf(
       f, "\n  special descriptor (byteSize 0x%zx): ", special_.byteSize);
   specialDesc.Dump(f);
-  std::size_t specials{specialDesc.Elements()};
-  for (std::size_t j{0}; j < specials; ++j) {
-    std::fprintf(f, "  [%3zd] ", j);
-    specialDesc.ZeroBasedIndexedElement<SpecialBinding>(j)->Dump(f);
+  if (specialDesc.IsAllocated()) {
+    std::size_t specials{specialDesc.Elements()};
+    for (std::size_t j{0}; j < specials; ++j) {
+      std::fprintf(f, "  [%3zd] ", j);
+      specialDesc.ZeroBasedIndexedElement<SpecialBinding>(j)->Dump(f);
+    }
   }
   return f;
 }