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