[flang][runtime] fix intrinsics case of extends_type_of

flang-rt/include/flang-rt/runtime/descriptor.h

@@ -227,6 +227,7 @@ class Descriptor {
   RT_API_ATTRS bool IsPointer() const {
     return raw_.attribute == CFI_attribute_pointer;
   }
+  RT_API_ATTRS bool IsAssociated() const { return raw_.base_addr != nullptr; }
   RT_API_ATTRS bool IsAllocatable() const {
     return raw_.attribute == CFI_attribute_allocatable;
   }

flang-rt/lib/runtime/derived-api.cpp

@@ -118,29 +118,43 @@ bool RTDEF(SameTypeAs)(const Descriptor &a, const Descriptor &b) {
 }
 
 bool RTDEF(ExtendsTypeOf)(const Descriptor &a, const Descriptor &mold) {
+  // The wording of the standard indicates the order in which each case
+  // is checked. If performance becomes an issue, there are less maintainable
+  // versions of this code that would probably execute faster.
+  // F'23 16.9.86 p 5
+  // If MOLD is unlimited polymorphic and is either a disassociated pointer or
+  // unallocated allocatable variable, the result is true;
+  if ((mold.IsPointer() && !mold.IsAssociated()) ||
+      (mold.IsAllocatable() && !mold.IsAllocated())) {
+    return true;
+  } else if ((a.IsPointer() && !mold.IsAssociated()) ||
+      (a.IsAllocatable() && !a.IsAllocated())) {
+    return false;
+  }
   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 (derivedTypeA == derivedTypeMold) {
-        return true;
+  if (aType == CFI_type_struct && moldType == CFI_type_struct) {
+    if (const auto *derivedTypeMold{GetDerivedType(mold)}) {
+      // 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 (derivedTypeA == derivedTypeMold) {
+          return true;
+        }
       }
+      return false;
     }
-    return false;
-  } else {
     // MOLD is unlimited polymorphic and unallocated/disassociated.
+    // This might be impossible to reach since the case is now handled
+    // explicitly above.
     return true;
+  } else {
+    // F'23: otherwise, the result is processor dependent.
+    // extension, if types are not extensible, true if they match.
+    return aType != CFI_type_other && moldType != CFI_type_other &&
+        aType == moldType;
   }
 }
 

flang-rt/lib/runtime/pointer.cpp

@@ -259,7 +259,7 @@ int RTDEF(PointerDeallocatePolymorphic)(Descriptor &pointer,
 }
 
 bool RTDEF(PointerIsAssociated)(const Descriptor &pointer) {
-  return pointer.raw().base_addr != nullptr;
+  return pointer.IsAssociated();
 }
 
 bool RTDEF(PointerIsAssociatedWith)(