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 "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