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 // TODO: Pass source file & line information to the API 37 // so that a good Terminator can be passed 38 Destroy(descriptor, true, *derived, nullptr); 39 } 40 } 41 } 42 } 43 44 void RTNAME(Finalize)( 45 const Descriptor &descriptor, const char *sourceFile, int sourceLine) { 46 if (const DescriptorAddendum * addendum{descriptor.Addendum()}) { 47 if (const auto *derived{addendum->derivedType()}) { 48 if (!derived->noFinalizationNeeded()) { 49 Terminator terminator{sourceFile, sourceLine}; 50 Finalize(descriptor, *derived, &terminator); 51 } 52 } 53 } 54 } 55 56 bool RTNAME(ClassIs)( 57 const Descriptor &descriptor, const typeInfo::DerivedType &derivedType) { 58 if (const DescriptorAddendum * addendum{descriptor.Addendum()}) { 59 if (const auto *derived{addendum->derivedType()}) { 60 if (derived == &derivedType) { 61 return true; 62 } 63 const typeInfo::DerivedType *parent{derived->GetParentType()}; 64 while (parent) { 65 if (parent == &derivedType) { 66 return true; 67 } 68 parent = parent->GetParentType(); 69 } 70 } 71 } 72 return false; 73 } 74 75 static bool CompareDerivedTypeNames(const Descriptor &a, const Descriptor &b) { 76 if (a.raw().version == CFI_VERSION && 77 a.type() == TypeCode{TypeCategory::Character, 1} && 78 a.ElementBytes() > 0 && a.rank() == 0 && a.OffsetElement() != nullptr && 79 a.raw().version == CFI_VERSION && 80 b.type() == TypeCode{TypeCategory::Character, 1} && 81 b.ElementBytes() > 0 && b.rank() == 0 && b.OffsetElement() != nullptr && 82 a.ElementBytes() == b.ElementBytes() && 83 memcmp(a.OffsetElement(), b.OffsetElement(), a.ElementBytes()) == 0) { 84 return true; 85 } 86 return false; 87 } 88 89 inline bool CompareDerivedType( 90 const typeInfo::DerivedType *a, const typeInfo::DerivedType *b) { 91 return a == b || CompareDerivedTypeNames(a->name(), b->name()); 92 } 93 94 static const typeInfo::DerivedType *GetDerivedType(const Descriptor &desc) { 95 if (const DescriptorAddendum * addendum{desc.Addendum()}) { 96 if (const auto *derived{addendum->derivedType()}) { 97 return derived; 98 } 99 } 100 return nullptr; 101 } 102 103 bool RTNAME(SameTypeAs)(const Descriptor &a, const Descriptor &b) { 104 auto aType{a.raw().type}; 105 auto bType{b.raw().type}; 106 if ((aType != CFI_type_struct && aType != CFI_type_other) || 107 (bType != CFI_type_struct && bType != CFI_type_other)) { 108 // If either type is intrinsic, they must match. 109 return aType == bType; 110 } else { 111 const typeInfo::DerivedType *derivedTypeA{GetDerivedType(a)}; 112 const typeInfo::DerivedType *derivedTypeB{GetDerivedType(b)}; 113 if (derivedTypeA == nullptr || derivedTypeB == nullptr) { 114 // Unallocated/disassociated CLASS(*) never matches. 115 return false; 116 } else if (derivedTypeA == derivedTypeB) { 117 // Exact match of derived type. 118 return true; 119 } else { 120 // Otherwise compare with the name. Note 16.29 kind type parameters are 121 // not considered in the test. 122 return CompareDerivedTypeNames( 123 derivedTypeA->name(), derivedTypeB->name()); 124 } 125 } 126 } 127 128 bool RTNAME(ExtendsTypeOf)(const Descriptor &a, const Descriptor &mold) { 129 auto aType{a.raw().type}; 130 auto moldType{mold.raw().type}; 131 if ((aType != CFI_type_struct && aType != CFI_type_other) || 132 (moldType != CFI_type_struct && moldType != CFI_type_other)) { 133 // If either type is intrinsic, they must match. 134 return aType == moldType; 135 } else if (const typeInfo::DerivedType * 136 derivedTypeMold{GetDerivedType(mold)}) { 137 // If A is unlimited polymorphic and is either a disassociated pointer or 138 // unallocated allocatable, the result is false. 139 // Otherwise if the dynamic type of A or MOLD is extensible, the result is 140 // true if and only if the dynamic type of A is an extension type of the 141 // dynamic type of MOLD. 142 for (const typeInfo::DerivedType *derivedTypeA{GetDerivedType(a)}; 143 derivedTypeA; derivedTypeA = derivedTypeA->GetParentType()) { 144 if (CompareDerivedType(derivedTypeA, derivedTypeMold)) { 145 return true; 146 } 147 } 148 return false; 149 } else { 150 // MOLD is unlimited polymorphic and unallocated/disassociated. 151 return true; 152 } 153 } 154 155 void RTNAME(DestroyWithoutFinalization)(const Descriptor &descriptor) { 156 if (const DescriptorAddendum * addendum{descriptor.Addendum()}) { 157 if (const auto *derived{addendum->derivedType()}) { 158 if (!derived->noDestructionNeeded()) { 159 Destroy(descriptor, /*finalize=*/false, *derived, nullptr); 160 } 161 } 162 } 163 } 164 165 } // extern "C" 166 } // namespace Fortran::runtime 167