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 
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 
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 
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.
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