1 //===-- runtime/derived-api.cpp 2 //-----------------------------------------------===// 3 // 4 // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. 5 // See https://llvm.org/LICENSE.txt for license information. 6 // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception 7 // 8 //===----------------------------------------------------------------------===// 9 10 #include "flang/Runtime/derived-api.h" 11 #include "derived.h" 12 #include "terminator.h" 13 #include "type-info.h" 14 #include "flang/Runtime/descriptor.h" 15 16 namespace Fortran::runtime { 17 18 extern "C" { 19 20 void RTNAME(Initialize)( 21 const Descriptor &descriptor, const char *sourceFile, int sourceLine) { 22 if (const DescriptorAddendum * addendum{descriptor.Addendum()}) { 23 if (const auto *derived{addendum->derivedType()}) { 24 if (!derived->noInitializationNeeded()) { 25 Terminator terminator{sourceFile, sourceLine}; 26 Initialize(descriptor, *derived, terminator); 27 } 28 } 29 } 30 } 31 32 void RTNAME(Destroy)(const Descriptor &descriptor) { 33 if (const DescriptorAddendum * addendum{descriptor.Addendum()}) { 34 if (const auto *derived{addendum->derivedType()}) { 35 if (!derived->noDestructionNeeded()) { 36 Destroy(descriptor, true, *derived); 37 } 38 } 39 } 40 } 41 42 bool RTNAME(ClassIs)( 43 const Descriptor &descriptor, const typeInfo::DerivedType &derivedType) { 44 if (const DescriptorAddendum * addendum{descriptor.Addendum()}) { 45 if (const auto *derived{addendum->derivedType()}) { 46 if (derived == &derivedType) { 47 return true; 48 } 49 const typeInfo::DerivedType *parent{derived->GetParentType()}; 50 while (parent) { 51 if (parent == &derivedType) { 52 return true; 53 } 54 parent = parent->GetParentType(); 55 } 56 } 57 } 58 return false; 59 } 60 61 static bool CompareDerivedTypeNames(const Descriptor &a, const Descriptor &b) { 62 if (a.raw().version == CFI_VERSION && 63 a.type() == TypeCode{TypeCategory::Character, 1} && 64 a.ElementBytes() > 0 && a.rank() == 0 && a.OffsetElement() != nullptr && 65 a.raw().version == CFI_VERSION && 66 b.type() == TypeCode{TypeCategory::Character, 1} && 67 b.ElementBytes() > 0 && b.rank() == 0 && b.OffsetElement() != nullptr && 68 a.ElementBytes() == b.ElementBytes() && 69 memcmp(a.OffsetElement(), b.OffsetElement(), a.ElementBytes()) == 0) { 70 return true; 71 } 72 return false; 73 } 74 75 inline bool CompareDerivedType( 76 const typeInfo::DerivedType *a, const typeInfo::DerivedType *b) { 77 return a == b || CompareDerivedTypeNames(a->name(), b->name()); 78 } 79 80 static const typeInfo::DerivedType *GetDerivedType(const Descriptor &desc) { 81 if (const DescriptorAddendum * addendum{desc.Addendum()}) { 82 if (const auto *derived{addendum->derivedType()}) { 83 return derived; 84 } 85 } 86 return nullptr; 87 } 88 89 bool RTNAME(SameTypeAs)(const Descriptor &a, const Descriptor &b) { 90 // Unlimited polymorphic with intrinsic dynamic type. 91 if (a.raw().type != CFI_type_struct && a.raw().type != CFI_type_other && 92 b.raw().type != CFI_type_struct && b.raw().type != CFI_type_other) 93 return a.raw().type == b.raw().type; 94 95 const typeInfo::DerivedType *derivedTypeA{GetDerivedType(a)}; 96 const typeInfo::DerivedType *derivedTypeB{GetDerivedType(b)}; 97 98 // No dynamic type in one or both descriptor. 99 if (derivedTypeA == nullptr || derivedTypeB == nullptr) { 100 return false; 101 } 102 103 // Exact match of derived type. 104 if (derivedTypeA == derivedTypeB) { 105 return true; 106 } 107 // Otherwise compare with the name. Note 16.29 kind type parameters are not 108 // considered in the test. 109 return CompareDerivedTypeNames(derivedTypeA->name(), derivedTypeB->name()); 110 } 111 112 bool RTNAME(ExtendsTypeOf)(const Descriptor &a, const Descriptor &mold) { 113 if (a.raw().type != CFI_type_struct && a.raw().type != CFI_type_other && 114 mold.raw().type != CFI_type_struct && mold.raw().type != CFI_type_other) 115 return a.raw().type == mold.raw().type; 116 117 const typeInfo::DerivedType *derivedTypeA{GetDerivedType(a)}; 118 const typeInfo::DerivedType *derivedTypeMold{GetDerivedType(mold)}; 119 120 // If MOLD is unlimited polymorphic and is either a disassociated pointer or 121 // unallocated allocatable, the result is true. 122 // Unlimited polymorphic descriptors are initialized with a CFI_type_other 123 // type. 124 if (mold.type().raw() == CFI_type_other && 125 (mold.IsAllocatable() || mold.IsPointer()) && 126 derivedTypeMold == nullptr) { 127 return true; 128 } 129 130 // If A is unlimited polymorphic and is either a disassociated pointer or 131 // unallocated allocatable, the result is false. 132 // Unlimited polymorphic descriptors are initialized with a CFI_type_other 133 // type. 134 if (a.type().raw() == CFI_type_other && 135 (a.IsAllocatable() || a.IsPointer()) && derivedTypeA == nullptr) { 136 return false; 137 } 138 139 if (derivedTypeA == nullptr || derivedTypeMold == nullptr) { 140 return false; 141 } 142 143 // Otherwise if the dynamic type of A or MOLD is extensible, the result is 144 // true if and only if the dynamic type of A is an extension type of the 145 // dynamic type of MOLD. 146 if (CompareDerivedType(derivedTypeA, derivedTypeMold)) { 147 return true; 148 } 149 const typeInfo::DerivedType *parent{derivedTypeA->GetParentType()}; 150 while (parent) { 151 if (CompareDerivedType(parent, derivedTypeMold)) { 152 return true; 153 } 154 parent = parent->GetParentType(); 155 } 156 return false; 157 } 158 159 void RTNAME(DestroyWithoutFinalization)(const Descriptor &descriptor) { 160 if (const DescriptorAddendum * addendum{descriptor.Addendum()}) { 161 if (const auto *derived{addendum->derivedType()}) { 162 if (!derived->noDestructionNeeded()) { 163 Destroy(descriptor, /*finalize=*/false, *derived); 164 } 165 } 166 } 167 } 168 169 } // extern "C" 170 } // namespace Fortran::runtime 171