1 //===-- runtime/derived.cpp -----------------------------------------------===//
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 "derived.h"
10 #include "descriptor.h"
11 #include "type-info.h"
12
13 namespace Fortran::runtime {
14
FindFinal(const typeInfo::DerivedType & derived,int rank)15 static const typeInfo::SpecialBinding *FindFinal(
16 const typeInfo::DerivedType &derived, int rank) {
17 const typeInfo::SpecialBinding *elemental{nullptr};
18 const Descriptor &specialDesc{derived.special.descriptor()};
19 std::size_t totalSpecialBindings{specialDesc.Elements()};
20 for (std::size_t j{0}; j < totalSpecialBindings; ++j) {
21 const auto &special{
22 *specialDesc.ZeroBasedIndexedElement<typeInfo::SpecialBinding>(j)};
23 switch (special.which) {
24 case typeInfo::SpecialBinding::Which::Final:
25 if (special.rank == rank) {
26 return &special;
27 }
28 break;
29 case typeInfo::SpecialBinding::Which::ElementalFinal:
30 elemental = &special;
31 break;
32 case typeInfo::SpecialBinding::Which::AssumedRankFinal:
33 return &special;
34 default:;
35 }
36 }
37 return elemental;
38 }
39
CallFinalSubroutine(const Descriptor & descriptor,const typeInfo::DerivedType & derived)40 static void CallFinalSubroutine(
41 const Descriptor &descriptor, const typeInfo::DerivedType &derived) {
42 if (const auto *special{FindFinal(derived, descriptor.rank())}) {
43 if (special->which == typeInfo::SpecialBinding::Which::ElementalFinal) {
44 std::size_t byteStride{descriptor.ElementBytes()};
45 auto p{reinterpret_cast<void (*)(char *)>(special->proc)};
46 // Finalizable objects must be contiguous.
47 std::size_t elements{descriptor.Elements()};
48 for (std::size_t j{0}; j < elements; ++j) {
49 p(descriptor.OffsetElement<char>(j * byteStride));
50 }
51 } else if (special->isArgDescriptorSet & 1) {
52 auto p{reinterpret_cast<void (*)(const Descriptor &)>(special->proc)};
53 p(descriptor);
54 } else {
55 // Finalizable objects must be contiguous.
56 auto p{reinterpret_cast<void (*)(char *)>(special->proc)};
57 p(descriptor.OffsetElement<char>());
58 }
59 }
60 }
61
GetValue(const typeInfo::Value & value,const Descriptor & descriptor)62 static inline SubscriptValue GetValue(
63 const typeInfo::Value &value, const Descriptor &descriptor) {
64 if (value.genre == typeInfo::Value::Genre::LenParameter) {
65 return descriptor.Addendum()->LenParameterValue(value.value);
66 } else {
67 return value.value;
68 }
69 }
70
71 // The order of finalization follows Fortran 2018 7.5.6.2, with
72 // deallocation of non-parent components (and their consequent finalization)
73 // taking place before parent component finalization.
Destroy(const Descriptor & descriptor,bool finalize,const typeInfo::DerivedType & derived)74 void Destroy(const Descriptor &descriptor, bool finalize,
75 const typeInfo::DerivedType &derived) {
76 if (finalize) {
77 CallFinalSubroutine(descriptor, derived);
78 }
79 const Descriptor &componentDesc{derived.component.descriptor()};
80 std::int64_t myComponents{componentDesc.GetDimension(0).Extent()};
81 std::size_t elements{descriptor.Elements()};
82 std::size_t byteStride{descriptor.ElementBytes()};
83 for (unsigned k{0}; k < myComponents; ++k) {
84 const auto &comp{
85 *componentDesc.ZeroBasedIndexedElement<typeInfo::Component>(k)};
86 if (comp.genre == typeInfo::Component::Genre::Allocatable ||
87 comp.genre == typeInfo::Component::Genre::Automatic) {
88 for (std::size_t j{0}; j < elements; ++j) {
89 descriptor.OffsetElement<Descriptor>(j * byteStride + comp.offset)
90 ->Deallocate(finalize);
91 }
92 } else if (comp.genre == typeInfo::Component::Genre::Data &&
93 comp.derivedType.descriptor().raw().base_addr) {
94 SubscriptValue extent[maxRank];
95 const Descriptor &boundsDesc{comp.bounds.descriptor()};
96 for (int dim{0}; dim < comp.rank; ++dim) {
97 extent[dim] =
98 GetValue(
99 *boundsDesc.ZeroBasedIndexedElement<typeInfo::Value>(2 * dim),
100 descriptor) -
101 GetValue(*boundsDesc.ZeroBasedIndexedElement<typeInfo::Value>(
102 2 * dim + 1),
103 descriptor) +
104 1;
105 }
106 StaticDescriptor<maxRank, true, 0> staticDescriptor;
107 Descriptor &compDesc{staticDescriptor.descriptor()};
108 const auto &compType{*comp.derivedType.descriptor()
109 .OffsetElement<typeInfo::DerivedType>()};
110 for (std::size_t j{0}; j < elements; ++j) {
111 compDesc.Establish(compType,
112 descriptor.OffsetElement<char>(j * byteStride + comp.offset),
113 comp.rank, extent);
114 Destroy(compDesc, finalize, compType);
115 }
116 }
117 }
118 const Descriptor &parentDesc{derived.parent.descriptor()};
119 if (const auto *parent{parentDesc.OffsetElement<typeInfo::DerivedType>()}) {
120 Destroy(descriptor, finalize, *parent);
121 }
122 }
123 } // namespace Fortran::runtime
124