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