flang/runtime/derived-api.cpp

   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 } // extern "C"
 148 } // namespace Fortran::runtime