llvm-project
172 строки · 5.8 Кб
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
17namespace Fortran::runtime {18
19extern "C" {20RT_EXT_API_GROUP_BEGIN
21
22void RTDEF(Initialize)(23const Descriptor &descriptor, const char *sourceFile, int sourceLine) {24if (const DescriptorAddendum * addendum{descriptor.Addendum()}) {25if (const auto *derived{addendum->derivedType()}) {26if (!derived->noInitializationNeeded()) {27Terminator terminator{sourceFile, sourceLine};28Initialize(descriptor, *derived, terminator);29}30}31}32}
33
34void RTDEF(Destroy)(const Descriptor &descriptor) {35if (const DescriptorAddendum * addendum{descriptor.Addendum()}) {36if (const auto *derived{addendum->derivedType()}) {37if (!derived->noDestructionNeeded()) {38// TODO: Pass source file & line information to the API39// so that a good Terminator can be passed40Destroy(descriptor, true, *derived, nullptr);41}42}43}44}
45
46void RTDEF(Finalize)(47const Descriptor &descriptor, const char *sourceFile, int sourceLine) {48if (const DescriptorAddendum * addendum{descriptor.Addendum()}) {49if (const auto *derived{addendum->derivedType()}) {50if (!derived->noFinalizationNeeded()) {51Terminator terminator{sourceFile, sourceLine};52Finalize(descriptor, *derived, &terminator);53}54}55}56}
57
58bool RTDEF(ClassIs)(59const Descriptor &descriptor, const typeInfo::DerivedType &derivedType) {60if (const DescriptorAddendum * addendum{descriptor.Addendum()}) {61if (const auto *derived{addendum->derivedType()}) {62if (derived == &derivedType) {63return true;64}65const typeInfo::DerivedType *parent{derived->GetParentType()};66while (parent) {67if (parent == &derivedType) {68return true;69}70parent = parent->GetParentType();71}72}73}74return false;75}
76
77static RT_API_ATTRS bool CompareDerivedTypeNames(78const Descriptor &a, const Descriptor &b) {79if (a.raw().version == CFI_VERSION &&80a.type() == TypeCode{TypeCategory::Character, 1} &&81a.ElementBytes() > 0 && a.rank() == 0 && a.OffsetElement() != nullptr &&82a.raw().version == CFI_VERSION &&83b.type() == TypeCode{TypeCategory::Character, 1} &&84b.ElementBytes() > 0 && b.rank() == 0 && b.OffsetElement() != nullptr &&85a.ElementBytes() == b.ElementBytes() &&86Fortran::runtime::memcmp(87a.OffsetElement(), b.OffsetElement(), a.ElementBytes()) == 0) {88return true;89}90return false;91}
92
93inline RT_API_ATTRS bool CompareDerivedType(94const typeInfo::DerivedType *a, const typeInfo::DerivedType *b) {95return a == b || CompareDerivedTypeNames(a->name(), b->name());96}
97
98static RT_API_ATTRS const typeInfo::DerivedType *GetDerivedType(99const Descriptor &desc) {100if (const DescriptorAddendum * addendum{desc.Addendum()}) {101if (const auto *derived{addendum->derivedType()}) {102return derived;103}104}105return nullptr;106}
107
108bool RTDEF(SameTypeAs)(const Descriptor &a, const Descriptor &b) {109auto aType{a.raw().type};110auto bType{b.raw().type};111if ((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.114return aType == bType;115} else {116const typeInfo::DerivedType *derivedTypeA{GetDerivedType(a)};117const typeInfo::DerivedType *derivedTypeB{GetDerivedType(b)};118if (derivedTypeA == nullptr || derivedTypeB == nullptr) {119// Unallocated/disassociated CLASS(*) never matches.120return false;121} else if (derivedTypeA == derivedTypeB) {122// Exact match of derived type.123return true;124} else {125// Otherwise compare with the name. Note 16.29 kind type parameters are126// not considered in the test.127return CompareDerivedTypeNames(128derivedTypeA->name(), derivedTypeB->name());129}130}131}
132
133bool RTDEF(ExtendsTypeOf)(const Descriptor &a, const Descriptor &mold) {134auto aType{a.raw().type};135auto moldType{mold.raw().type};136if ((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.139return aType == moldType;140} else if (const typeInfo::DerivedType *141derivedTypeMold{GetDerivedType(mold)}) {142// If A is unlimited polymorphic and is either a disassociated pointer or143// unallocated allocatable, the result is false.144// Otherwise if the dynamic type of A or MOLD is extensible, the result is145// true if and only if the dynamic type of A is an extension type of the146// dynamic type of MOLD.147for (const typeInfo::DerivedType *derivedTypeA{GetDerivedType(a)};148derivedTypeA; derivedTypeA = derivedTypeA->GetParentType()) {149if (CompareDerivedType(derivedTypeA, derivedTypeMold)) {150return true;151}152}153return false;154} else {155// MOLD is unlimited polymorphic and unallocated/disassociated.156return true;157}158}
159
160void RTDEF(DestroyWithoutFinalization)(const Descriptor &descriptor) {161if (const DescriptorAddendum * addendum{descriptor.Addendum()}) {162if (const auto *derived{addendum->derivedType()}) {163if (!derived->noDestructionNeeded()) {164Destroy(descriptor, /*finalize=*/false, *derived, nullptr);165}166}167}168}
169
170RT_EXT_API_GROUP_END
171} // extern "C"172} // namespace Fortran::runtime173