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()};
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{special->GetProc<void (*)(char *)>()};
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->IsArgDescriptor(0)) {
52       auto *p{special->GetProc<void (*)(const Descriptor &)>()};
53       p(descriptor);
54     } else {
55       // Finalizable objects must be contiguous.
56       auto *p{special->GetProc<void (*)(char *)>()};
57       p(descriptor.OffsetElement<char>());
58     }
59   }
60 }
61 
62 // The order of finalization follows Fortran 2018 7.5.6.2, with
63 // deallocation of non-parent components (and their consequent finalization)
64 // taking place before parent component finalization.
65 void Destroy(const Descriptor &descriptor, bool finalize,
66     const typeInfo::DerivedType &derived) {
67   if (finalize) {
68     CallFinalSubroutine(descriptor, derived);
69   }
70   const Descriptor &componentDesc{derived.component()};
71   auto myComponents{static_cast<SubscriptValue>(componentDesc.Elements())};
72   std::size_t elements{descriptor.Elements()};
73   std::size_t byteStride{descriptor.ElementBytes()};
74   for (unsigned k{0}; k < myComponents; ++k) {
75     const auto &comp{
76         *componentDesc.ZeroBasedIndexedElement<typeInfo::Component>(k)};
77     if (comp.genre() == typeInfo::Component::Genre::Allocatable ||
78         comp.genre() == typeInfo::Component::Genre::Automatic) {
79       for (std::size_t j{0}; j < elements; ++j) {
80         descriptor.OffsetElement<Descriptor>(j * byteStride + comp.offset())
81             ->Deallocate(finalize);
82       }
83     } else if (comp.genre() == typeInfo::Component::Genre::Data &&
84         comp.derivedType()) {
85       SubscriptValue extent[maxRank];
86       const typeInfo::Value *bounds{comp.bounds()};
87       for (int dim{0}; dim < comp.rank(); ++dim) {
88         extent[dim] = bounds[2 * dim].GetValue(&descriptor).value_or(0) -
89             bounds[2 * dim + 1].GetValue(&descriptor).value_or(0) + 1;
90       }
91       StaticDescriptor<maxRank, true, 0> staticDescriptor;
92       Descriptor &compDesc{staticDescriptor.descriptor()};
93       const typeInfo::DerivedType &compType{*comp.derivedType()};
94       for (std::size_t j{0}; j < elements; ++j) {
95         compDesc.Establish(compType,
96             descriptor.OffsetElement<char>(j * byteStride + comp.offset()),
97             comp.rank(), extent);
98         Destroy(compDesc, finalize, compType);
99       }
100     }
101   }
102   const Descriptor &parentDesc{derived.parent()};
103   if (const auto *parent{parentDesc.OffsetElement<typeInfo::DerivedType>()}) {
104     Destroy(descriptor, finalize, *parent);
105   }
106 }
107 } // namespace Fortran::runtime
108