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 "stat.h"
12 #include "terminator.h"
13 #include "type-info.h"
14 
15 namespace Fortran::runtime {
16 
17 int Initialize(const Descriptor &instance, const typeInfo::DerivedType &derived,
18     Terminator &terminator, bool hasStat, const Descriptor *errMsg) {
19   const Descriptor &componentDesc{derived.component()};
20   std::size_t elements{instance.Elements()};
21   std::size_t byteStride{instance.ElementBytes()};
22   int stat{StatOk};
23   // Initialize data components in each element; the per-element iteration
24   // constitutes the inner loops, not outer
25   std::size_t myComponents{componentDesc.Elements()};
26   for (std::size_t k{0}; k < myComponents; ++k) {
27     const auto &comp{
28         *componentDesc.ZeroBasedIndexedElement<typeInfo::Component>(k)};
29     if (comp.genre() == typeInfo::Component::Genre::Allocatable ||
30         comp.genre() == typeInfo::Component::Genre::Automatic) {
31       for (std::size_t j{0}; j < elements; ++j) {
32         Descriptor &allocDesc{*instance.OffsetElement<Descriptor>(
33             j * byteStride + comp.offset())};
34         comp.EstablishDescriptor(allocDesc, instance, terminator);
35         allocDesc.raw().attribute = CFI_attribute_allocatable;
36         if (comp.genre() == typeInfo::Component::Genre::Automatic) {
37           stat = ReturnError(terminator, allocDesc.Allocate(), errMsg, hasStat);
38           if (stat == StatOk) {
39             stat = Initialize(allocDesc, derived, terminator, hasStat, errMsg);
40           }
41           if (stat != StatOk) {
42             break;
43           }
44         }
45       }
46     } else if (const void *init{comp.initialization()}) {
47       // Explicit initialization of data pointers and
48       // non-allocatable non-automatic components
49       std::size_t bytes{comp.SizeInBytes(instance)};
50       for (std::size_t j{0}; j < elements; ++j) {
51         char *ptr{instance.OffsetElement<char>(j * byteStride + comp.offset())};
52         std::memcpy(ptr, init, bytes);
53       }
54     } else if (comp.genre() == typeInfo::Component::Genre::Data &&
55         comp.derivedType() && !comp.derivedType()->noInitializationNeeded()) {
56       // Default initialization of non-pointer non-allocatable/automatic
57       // data component.  Handles parent component's elements.  Recursive.
58       SubscriptValue extent[maxRank];
59       const typeInfo::Value *bounds{comp.bounds()};
60       for (int dim{0}; dim < comp.rank(); ++dim) {
61         typeInfo::TypeParameterValue lb{
62             bounds[2 * dim].GetValue(&instance).value_or(0)};
63         typeInfo::TypeParameterValue ub{
64             bounds[2 * dim + 1].GetValue(&instance).value_or(0)};
65         extent[dim] = ub >= lb ? ub - lb + 1 : 0;
66       }
67       StaticDescriptor<maxRank, true, 0> staticDescriptor;
68       Descriptor &compDesc{staticDescriptor.descriptor()};
69       const typeInfo::DerivedType &compType{*comp.derivedType()};
70       for (std::size_t j{0}; j < elements; ++j) {
71         compDesc.Establish(compType,
72             instance.OffsetElement<char>(j * byteStride + comp.offset()),
73             comp.rank(), extent);
74         stat = Initialize(compDesc, compType, terminator, hasStat, errMsg);
75         if (stat != StatOk) {
76           break;
77         }
78       }
79     }
80   }
81   // Initialize procedure pointer components in each element
82   const Descriptor &procPtrDesc{derived.procPtr()};
83   std::size_t myProcPtrs{procPtrDesc.Elements()};
84   for (std::size_t k{0}; k < myProcPtrs; ++k) {
85     const auto &comp{
86         *procPtrDesc.ZeroBasedIndexedElement<typeInfo::ProcPtrComponent>(k)};
87     for (std::size_t j{0}; j < elements; ++j) {
88       auto &pptr{*instance.OffsetElement<typeInfo::ProcedurePointer>(
89           j * byteStride + comp.offset)};
90       pptr = comp.procInitialization;
91     }
92   }
93   return stat;
94 }
95 
96 static const typeInfo::SpecialBinding *FindFinal(
97     const typeInfo::DerivedType &derived, int rank) {
98   const typeInfo::SpecialBinding *elemental{nullptr};
99   const Descriptor &specialDesc{derived.special()};
100   std::size_t totalSpecialBindings{specialDesc.Elements()};
101   for (std::size_t j{0}; j < totalSpecialBindings; ++j) {
102     const auto &special{
103         *specialDesc.ZeroBasedIndexedElement<typeInfo::SpecialBinding>(j)};
104     switch (special.which()) {
105     case typeInfo::SpecialBinding::Which::Final:
106       if (special.rank() == rank) {
107         return &special;
108       }
109       break;
110     case typeInfo::SpecialBinding::Which::ElementalFinal:
111       elemental = &special;
112       break;
113     case typeInfo::SpecialBinding::Which::AssumedRankFinal:
114       return &special;
115     default:;
116     }
117   }
118   return elemental;
119 }
120 
121 static void CallFinalSubroutine(
122     const Descriptor &descriptor, const typeInfo::DerivedType &derived) {
123   if (const auto *special{FindFinal(derived, descriptor.rank())}) {
124     // The following code relies on the fact that finalizable objects
125     // must be contiguous.
126     if (special->which() == typeInfo::SpecialBinding::Which::ElementalFinal) {
127       std::size_t byteStride{descriptor.ElementBytes()};
128       std::size_t elements{descriptor.Elements()};
129       if (special->IsArgDescriptor(0)) {
130         StaticDescriptor<maxRank, true, 8 /*?*/> statDesc;
131         Descriptor &elemDesc{statDesc.descriptor()};
132         elemDesc = descriptor;
133         elemDesc.raw().attribute = CFI_attribute_pointer;
134         elemDesc.raw().rank = 0;
135         auto *p{special->GetProc<void (*)(const Descriptor &)>()};
136         for (std::size_t j{0}; j < elements; ++j) {
137           elemDesc.set_base_addr(
138               descriptor.OffsetElement<char>(j * byteStride));
139           p(elemDesc);
140         }
141       } else {
142         auto *p{special->GetProc<void (*)(char *)>()};
143         for (std::size_t j{0}; j < elements; ++j) {
144           p(descriptor.OffsetElement<char>(j * byteStride));
145         }
146       }
147     } else if (special->IsArgDescriptor(0)) {
148       StaticDescriptor<maxRank, true, 8 /*?*/> statDesc;
149       Descriptor &tmpDesc{statDesc.descriptor()};
150       tmpDesc = descriptor;
151       tmpDesc.raw().attribute = CFI_attribute_pointer;
152       tmpDesc.Addendum()->set_derivedType(&derived);
153       auto *p{special->GetProc<void (*)(const Descriptor &)>()};
154       p(tmpDesc);
155     } else {
156       auto *p{special->GetProc<void (*)(char *)>()};
157       p(descriptor.OffsetElement<char>());
158     }
159   }
160 }
161 
162 // The order of finalization follows Fortran 2018 7.5.6.2, with
163 // deallocation of non-parent components (and their consequent finalization)
164 // taking place before parent component finalization.
165 void Destroy(const Descriptor &descriptor, bool finalize,
166     const typeInfo::DerivedType &derived) {
167   if (finalize) {
168     CallFinalSubroutine(descriptor, derived);
169   }
170   const Descriptor &componentDesc{derived.component()};
171   std::size_t myComponents{componentDesc.Elements()};
172   std::size_t elements{descriptor.Elements()};
173   std::size_t byteStride{descriptor.ElementBytes()};
174   // If there's a finalizable parent component, handle it last, as required
175   // by the Fortran standard (7.5.6.2), and do so recursively with the same
176   // descriptor so that the rank is preserved.  Otherwise, destroy the parent
177   // component like any other.
178   const auto *parentType{derived.GetParentType()};
179   bool recurse{finalize && parentType && !parentType->noDestructionNeeded()};
180   for (auto k{recurse
181                ? std::size_t{1} /* skip first component, it's the parent */
182                : 0};
183        k < myComponents; ++k) {
184     const auto &comp{
185         *componentDesc.ZeroBasedIndexedElement<typeInfo::Component>(k)};
186     if (comp.genre() == typeInfo::Component::Genre::Allocatable ||
187         comp.genre() == typeInfo::Component::Genre::Automatic) {
188       if (const typeInfo::DerivedType * compType{comp.derivedType()}) {
189         if (!compType->noDestructionNeeded()) {
190           for (std::size_t j{0}; j < elements; ++j) {
191             Destroy(*descriptor.OffsetElement<Descriptor>(
192                         j * byteStride + comp.offset()),
193                 finalize, *compType);
194           }
195         }
196       }
197       for (std::size_t j{0}; j < elements; ++j) {
198         descriptor.OffsetElement<Descriptor>(j * byteStride + comp.offset())
199             ->Deallocate();
200       }
201     } else if (comp.genre() == typeInfo::Component::Genre::Data &&
202         comp.derivedType() && !comp.derivedType()->noDestructionNeeded()) {
203       SubscriptValue extent[maxRank];
204       const typeInfo::Value *bounds{comp.bounds()};
205       for (int dim{0}; dim < comp.rank(); ++dim) {
206         extent[dim] = bounds[2 * dim].GetValue(&descriptor).value_or(0) -
207             bounds[2 * dim + 1].GetValue(&descriptor).value_or(0) + 1;
208       }
209       StaticDescriptor<maxRank, true, 0> staticDescriptor;
210       Descriptor &compDesc{staticDescriptor.descriptor()};
211       const typeInfo::DerivedType &compType{*comp.derivedType()};
212       for (std::size_t j{0}; j < elements; ++j) {
213         compDesc.Establish(compType,
214             descriptor.OffsetElement<char>(j * byteStride + comp.offset()),
215             comp.rank(), extent);
216         Destroy(compDesc, finalize, compType);
217       }
218     }
219   }
220   if (recurse) {
221     Destroy(descriptor, finalize, *parentType);
222   }
223 }
224 
225 // TODO: Assign()
226 
227 } // namespace Fortran::runtime
228