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 static const typeInfo::DerivedType *GetDerivedType(const Descriptor &desc) { 76 if (const DescriptorAddendum * addendum{desc.Addendum()}) { 77 if (const auto *derived{addendum->derivedType()}) { 78 return derived; 79 } 80 } 81 return nullptr; 82 } 83 84 bool RTNAME(SameTypeAs)(const Descriptor &a, const Descriptor &b) { 85 const typeInfo::DerivedType *derivedTypeA{GetDerivedType(a)}; 86 const typeInfo::DerivedType *derivedTypeB{GetDerivedType(b)}; 87 if (derivedTypeA == nullptr || derivedTypeB == nullptr) { 88 return false; 89 } 90 // Exact match of derived type. 91 if (derivedTypeA == derivedTypeB) { 92 return true; 93 } 94 // Otherwise compare with the name. Note 16.29 kind type parameters are not 95 // considered in the test. 96 return CompareDerivedTypeNames(derivedTypeA->name(), derivedTypeB->name()); 97 } 98 99 // TODO: Assign() 100 101 } // extern "C" 102 } // namespace Fortran::runtime 103