172 lines · cpp
1//===-- lib/runtime/derived-api.cpp -----------------------------*- C++ -*-===//2//3// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.4// See https://llvm.org/LICENSE.txt for license information.5// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception6//7//===----------------------------------------------------------------------===//8 9#include "flang/Runtime/derived-api.h"10#include "flang-rt/runtime/derived.h"11#include "flang-rt/runtime/descriptor.h"12#include "flang-rt/runtime/terminator.h"13#include "flang-rt/runtime/tools.h"14#include "flang-rt/runtime/type-info.h"15 16namespace Fortran::runtime {17 18extern "C" {19RT_EXT_API_GROUP_BEGIN20 21void RTDEF(Initialize)(22 const Descriptor &descriptor, const char *sourceFile, int sourceLine) {23 if (const DescriptorAddendum * addendum{descriptor.Addendum()}) {24 if (const auto *derived{addendum->derivedType()}) {25 if (!derived->noInitializationNeeded()) {26 Terminator terminator{sourceFile, sourceLine};27 Initialize(descriptor, *derived, terminator);28 }29 }30 }31}32 33void RTDEF(InitializeClone)(const Descriptor &clone, const Descriptor &orig,34 const char *sourceFile, int sourceLine) {35 if (const DescriptorAddendum * addendum{clone.Addendum()}) {36 if (const auto *derived{addendum->derivedType()}) {37 Terminator terminator{sourceFile, sourceLine};38 InitializeClone(clone, orig, *derived, terminator);39 }40 }41}42 43void RTDEF(Destroy)(const Descriptor &descriptor) {44 if (const DescriptorAddendum * addendum{descriptor.Addendum()}) {45 if (const auto *derived{addendum->derivedType()}) {46 if (!derived->noDestructionNeeded()) {47 // TODO: Pass source file & line information to the API48 // so that a good Terminator can be passed49 Destroy(descriptor, true, *derived, nullptr);50 }51 }52 }53}54 55void RTDEF(Finalize)(56 const Descriptor &descriptor, const char *sourceFile, int sourceLine) {57 if (const DescriptorAddendum * addendum{descriptor.Addendum()}) {58 if (const auto *derived{addendum->derivedType()}) {59 if (!derived->noFinalizationNeeded()) {60 Terminator terminator{sourceFile, sourceLine};61 Finalize(descriptor, *derived, &terminator);62 }63 }64 }65}66 67bool RTDEF(ClassIs)(68 const Descriptor &descriptor, const typeInfo::DerivedType &derivedType) {69 if (const DescriptorAddendum * addendum{descriptor.Addendum()}) {70 if (const auto *derived{addendum->derivedType()}) {71 if (derived == &derivedType) {72 return true;73 }74 const typeInfo::DerivedType *parent{derived->GetParentType()};75 while (parent) {76 if (parent == &derivedType) {77 return true;78 }79 parent = parent->GetParentType();80 }81 }82 }83 return false;84}85 86static RT_API_ATTRS const typeInfo::DerivedType *GetDerivedType(87 const Descriptor &desc) {88 if (const DescriptorAddendum * addendum{desc.Addendum()}) {89 if (const auto *derived{addendum->derivedType()}) {90 return derived;91 }92 }93 return nullptr;94}95 96bool RTDEF(SameTypeAs)(const Descriptor &a, const Descriptor &b) {97 auto aType{a.raw().type};98 auto bType{b.raw().type};99 if ((aType != CFI_type_struct && aType != CFI_type_other) ||100 (bType != CFI_type_struct && bType != CFI_type_other)) {101 // If either type is intrinsic, they must match.102 return aType == bType;103 } else if (const typeInfo::DerivedType * derivedTypeA{GetDerivedType(a)}) {104 if (const typeInfo::DerivedType * derivedTypeB{GetDerivedType(b)}) {105 if (derivedTypeA == derivedTypeB) {106 return true;107 } else if (const typeInfo::DerivedType *108 uninstDerivedTypeA{derivedTypeA->uninstantiatedType()}) {109 // There are KIND type parameters, are these the same type if those110 // are ignored?111 const typeInfo::DerivedType *uninstDerivedTypeB{112 derivedTypeB->uninstantiatedType()};113 return uninstDerivedTypeA == uninstDerivedTypeB;114 }115 }116 }117 return false;118}119 120bool RTDEF(ExtendsTypeOf)(const Descriptor &a, const Descriptor &mold) {121 // The wording of the standard indicates null or unallocated checks take122 // precedence over the extension checks which take precedence over any123 // compiler specific behavior.124 // F'23 16.9.86 p 5125 // If MOLD is unlimited polymorphic and is either a disassociated pointer or126 // unallocated allocatable variable, the result is true;127 auto aType{a.raw().type};128 auto moldType{mold.raw().type};129 if ((aType != CFI_type_struct && aType != CFI_type_other) ||130 (moldType != CFI_type_struct && moldType != CFI_type_other)) {131 if (!mold.IsAllocated()) {132 return true;133 } else if (!a.IsAllocated()) {134 return false;135 } else {136 // If either type is intrinsic and not a pointer or allocatable137 // then they must match.138 return aType == moldType;139 }140 } else if (const auto *derivedTypeMold{GetDerivedType(mold)}) {141 // If A is unlimited polymorphic and is either a disassociated pointer or142 // unallocated allocatable, the result is false.143 // Otherwise if the dynamic type of A or MOLD is extensible, the result is144 // true if and only if the dynamic type of A is an extension type of the145 // dynamic type of MOLD.146 for (const typeInfo::DerivedType *derivedTypeA{GetDerivedType(a)};147 derivedTypeA; derivedTypeA = derivedTypeA->GetParentType()) {148 if (derivedTypeA == derivedTypeMold) {149 return true;150 }151 }152 return false;153 } else {154 // MOLD is unlimited polymorphic and unallocated/disassociated.155 return true;156 }157}158 159void RTDEF(DestroyWithoutFinalization)(const Descriptor &descriptor) {160 if (const DescriptorAddendum * addendum{descriptor.Addendum()}) {161 if (const auto *derived{addendum->derivedType()}) {162 if (!derived->noDestructionNeeded()) {163 Destroy(descriptor, /*finalize=*/false, *derived, nullptr);164 }165 }166 }167}168 169RT_EXT_API_GROUP_END170} // extern "C"171} // namespace Fortran::runtime172