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-exception
6//
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_BEGIN
20
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 API
48 // so that a good Terminator can be passed
49 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 those
110 // 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 auto aType{a.raw().type};
122 auto moldType{mold.raw().type};
123 if ((aType != CFI_type_struct && aType != CFI_type_other) ||
124 (moldType != CFI_type_struct && moldType != CFI_type_other)) {
125 // If either type is intrinsic, they must match.
126 return aType == moldType;
127 } else if (const typeInfo::DerivedType *
128 derivedTypeMold{GetDerivedType(mold)}) {
129 // If A is unlimited polymorphic and is either a disassociated pointer or
130 // unallocated allocatable, the result is false.
131 // Otherwise if the dynamic type of A or MOLD is extensible, the result is
132 // true if and only if the dynamic type of A is an extension type of the
133 // dynamic type of MOLD.
134 for (const typeInfo::DerivedType *derivedTypeA{GetDerivedType(a)};
135 derivedTypeA; derivedTypeA = derivedTypeA->GetParentType()) {
136 if (derivedTypeA == derivedTypeMold) {
137 return true;
138 }
139 }
140 return false;
141 } else {
142 // MOLD is unlimited polymorphic and unallocated/disassociated.
143 return true;
144 }
145}
146
147void RTDEF(DestroyWithoutFinalization)(const Descriptor &descriptor) {
148 if (const DescriptorAddendum * addendum{descriptor.Addendum()}) {
149 if (const auto *derived{addendum->derivedType()}) {
150 if (!derived->noDestructionNeeded()) {
151 Destroy(descriptor, /*finalize=*/false, *derived, nullptr);
152 }
153 }
154 }
155}
156
157RT_EXT_API_GROUP_END
158} // extern "C"
159} // namespace Fortran::runtime
160

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