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 const typeInfo::DerivedType *derivedTypeA{GetDerivedType(a)}; 91 const typeInfo::DerivedType *derivedTypeB{GetDerivedType(b)}; 92 if (derivedTypeA == nullptr || derivedTypeB == nullptr) { 93 return false; 94 } 95 // Exact match of derived type. 96 if (derivedTypeA == derivedTypeB) { 97 return true; 98 } 99 // Otherwise compare with the name. Note 16.29 kind type parameters are not 100 // considered in the test. 101 return CompareDerivedTypeNames(derivedTypeA->name(), derivedTypeB->name()); 102 } 103 104 bool RTNAME(ExtendsTypeOf)(const Descriptor &a, const Descriptor &mold) { 105 const typeInfo::DerivedType *derivedTypeA{GetDerivedType(a)}; 106 const typeInfo::DerivedType *derivedTypeMold{GetDerivedType(mold)}; 107 108 // If MOLD is unlimited polymorphic and is either a disassociated pointer or 109 // unallocated allocatable, the result is true. 110 // Unlimited polymorphic descriptors are initialized with a CFI_type_other 111 // type. 112 if (mold.type().raw() == CFI_type_other && 113 (mold.IsAllocatable() || mold.IsPointer()) && 114 derivedTypeMold == nullptr) { 115 return true; 116 } 117 118 // If A is unlimited polymorphic and is either a disassociated pointer or 119 // unallocated allocatable, the result is false. 120 // Unlimited polymorphic descriptors are initialized with a CFI_type_other 121 // type. 122 if (a.type().raw() == CFI_type_other && 123 (a.IsAllocatable() || a.IsPointer()) && derivedTypeA == nullptr) { 124 return false; 125 } 126 127 if (derivedTypeA == nullptr || derivedTypeMold == nullptr) { 128 return false; 129 } 130 131 // Otherwise if the dynamic type of A or MOLD is extensible, the result is 132 // true if and only if the dynamic type of A is an extension type of the 133 // dynamic type of MOLD. 134 if (CompareDerivedType(derivedTypeA, derivedTypeMold)) { 135 return true; 136 } 137 const typeInfo::DerivedType *parent{derivedTypeA->GetParentType()}; 138 while (parent) { 139 if (CompareDerivedType(parent, derivedTypeMold)) { 140 return true; 141 } 142 parent = parent->GetParentType(); 143 } 144 return false; 145 } 146 147 // TODO: Assign() 148 149 } // extern "C" 150 } // namespace Fortran::runtime 151