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)(
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
34void 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
46void 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
58bool 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
77static 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
93inline 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
98static 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
108bool 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
133bool 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(a: derivedTypeA, b: 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
160void 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
170RT_EXT_API_GROUP_END
171} // extern "C"
172} // namespace Fortran::runtime
173

source code of flang/runtime/derived-api.cpp