1//===-- lib/runtime/allocatable.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/allocatable.h"
10#include "flang-rt/runtime/assign-impl.h"
11#include "flang-rt/runtime/derived.h"
12#include "flang-rt/runtime/descriptor.h"
13#include "flang-rt/runtime/stat.h"
14#include "flang-rt/runtime/terminator.h"
15#include "flang-rt/runtime/type-info.h"
16#include "flang/Common/ISO_Fortran_binding_wrapper.h"
17#include "flang/Runtime/assign.h"
18
19namespace Fortran::runtime {
20extern "C" {
21RT_EXT_API_GROUP_BEGIN
22
23void RTDEF(AllocatableInitIntrinsic)(Descriptor &descriptor,
24 TypeCategory category, int kind, int rank, int corank) {
25 INTERNAL_CHECK(corank == 0);
26 descriptor.Establish(TypeCode{category, kind},
27 Descriptor::BytesFor(category, kind), nullptr, rank, nullptr,
28 CFI_attribute_allocatable);
29}
30
31void RTDEF(AllocatableInitCharacter)(Descriptor &descriptor,
32 SubscriptValue length, int kind, int rank, int corank) {
33 INTERNAL_CHECK(corank == 0);
34 descriptor.Establish(
35 kind, length, nullptr, rank, nullptr, CFI_attribute_allocatable);
36}
37
38void RTDEF(AllocatableInitDerived)(Descriptor &descriptor,
39 const typeInfo::DerivedType &derivedType, int rank, int corank) {
40 INTERNAL_CHECK(corank == 0);
41 descriptor.Establish(
42 derivedType, nullptr, rank, nullptr, CFI_attribute_allocatable);
43}
44
45void RTDEF(AllocatableInitIntrinsicForAllocate)(Descriptor &descriptor,
46 TypeCategory category, int kind, int rank, int corank) {
47 if (!descriptor.IsAllocated()) {
48 RTNAME(AllocatableInitIntrinsic)(descriptor, category, kind, rank, corank);
49 }
50}
51
52void RTDEF(AllocatableInitCharacterForAllocate)(Descriptor &descriptor,
53 SubscriptValue length, int kind, int rank, int corank) {
54 if (!descriptor.IsAllocated()) {
55 RTNAME(AllocatableInitCharacter)(descriptor, length, kind, rank, corank);
56 }
57}
58
59void RTDEF(AllocatableInitDerivedForAllocate)(Descriptor &descriptor,
60 const typeInfo::DerivedType &derivedType, int rank, int corank) {
61 if (!descriptor.IsAllocated()) {
62 RTNAME(AllocatableInitDerived)(descriptor, derivedType, rank, corank);
63 }
64}
65
66std::int32_t RTDEF(MoveAlloc)(Descriptor &to, Descriptor &from,
67 const typeInfo::DerivedType *derivedType, bool hasStat,
68 const Descriptor *errMsg, const char *sourceFile, int sourceLine) {
69 Terminator terminator{sourceFile, sourceLine};
70
71 // If to and from are the same allocatable they must not be allocated
72 // and nothing should be done.
73 if (from.raw().base_addr == to.raw().base_addr && from.IsAllocated()) {
74 return ReturnError(
75 terminator, StatMoveAllocSameAllocatable, errMsg, hasStat);
76 }
77
78 if (to.IsAllocated()) {
79 int stat{
80 to.Destroy(/*finalize=*/true, /*destroyPointers=*/false, &terminator)};
81 if (stat != StatOk) {
82 return ReturnError(terminator, stat, errMsg, hasStat);
83 }
84 }
85
86 // If from isn't allocated, the standard defines that nothing should be done.
87 if (from.IsAllocated()) {
88 to = from;
89 from.raw().base_addr = nullptr;
90
91 // Carry over the dynamic type.
92 if (auto *toAddendum{to.Addendum()}) {
93 if (const auto *fromAddendum{from.Addendum()}) {
94 if (const auto *derived{fromAddendum->derivedType()}) {
95 toAddendum->set_derivedType(derived);
96 }
97 }
98 }
99
100 // Reset from dynamic type if needed.
101 if (auto *fromAddendum{from.Addendum()}) {
102 if (derivedType) {
103 fromAddendum->set_derivedType(derivedType);
104 }
105 }
106 }
107
108 return StatOk;
109}
110
111void RTDEF(AllocatableSetBounds)(Descriptor &descriptor, int zeroBasedDim,
112 SubscriptValue lower, SubscriptValue upper) {
113 INTERNAL_CHECK(zeroBasedDim >= 0 && zeroBasedDim < descriptor.rank());
114 if (descriptor.IsAllocatable() && !descriptor.IsAllocated()) {
115 descriptor.GetDimension(zeroBasedDim).SetBounds(lower, upper);
116 // The byte strides are computed when the object is allocated.
117 }
118}
119
120void RTDEF(AllocatableSetDerivedLength)(
121 Descriptor &descriptor, int which, SubscriptValue x) {
122 if (descriptor.IsAllocatable() && !descriptor.IsAllocated()) {
123 DescriptorAddendum *addendum{descriptor.Addendum()};
124 INTERNAL_CHECK(addendum != nullptr);
125 addendum->SetLenParameterValue(which, x);
126 }
127}
128
129void RTDEF(AllocatableApplyMold)(
130 Descriptor &descriptor, const Descriptor &mold, int rank) {
131 if (descriptor.IsAllocatable() && !descriptor.IsAllocated()) {
132 descriptor.ApplyMold(mold, rank);
133 }
134}
135
136int RTDEF(AllocatableAllocate)(Descriptor &descriptor,
137 std::int64_t *asyncObject, bool hasStat, const Descriptor *errMsg,
138 const char *sourceFile, int sourceLine) {
139 Terminator terminator{sourceFile, sourceLine};
140 if (!descriptor.IsAllocatable()) {
141 return ReturnError(terminator, StatInvalidDescriptor, errMsg, hasStat);
142 } else if (descriptor.IsAllocated()) {
143 return ReturnError(terminator, StatBaseNotNull, errMsg, hasStat);
144 } else {
145 int stat{ReturnError(
146 terminator, descriptor.Allocate(asyncObject), errMsg, hasStat)};
147 if (stat == StatOk) {
148 if (const DescriptorAddendum * addendum{descriptor.Addendum()}) {
149 if (const auto *derived{addendum->derivedType()}) {
150 if (!derived->noInitializationNeeded()) {
151 stat =
152 Initialize(descriptor, *derived, terminator, hasStat, errMsg);
153 }
154 }
155 }
156 }
157 return stat;
158 }
159}
160
161int RTDEF(AllocatableAllocateSource)(Descriptor &alloc,
162 const Descriptor &source, bool hasStat, const Descriptor *errMsg,
163 const char *sourceFile, int sourceLine) {
164 int stat{RTNAME(AllocatableAllocate)(
165 alloc, /*asyncObject=*/nullptr, hasStat, errMsg, sourceFile, sourceLine)};
166 if (stat == StatOk) {
167 Terminator terminator{sourceFile, sourceLine};
168 if (alloc.rank() != source.rank() && source.rank() != 0) {
169 terminator.Crash("ALLOCATE object has rank %d while SOURCE= has rank %d",
170 alloc.rank(), source.rank());
171 }
172 if (int rank{source.rank()}; rank > 0) {
173 SubscriptValue allocExtent[maxRank], sourceExtent[maxRank];
174 alloc.GetShape(allocExtent);
175 source.GetShape(sourceExtent);
176 for (int j{0}; j < rank; ++j) {
177 if (allocExtent[j] != sourceExtent[j]) {
178 if (!hasStat) {
179 terminator.Crash("ALLOCATE object has extent %jd on dimension %d, "
180 "but SOURCE= has extent %jd",
181 static_cast<std::intmax_t>(allocExtent[j]), j + 1,
182 static_cast<std::intmax_t>(sourceExtent[j]));
183 }
184 return StatInvalidExtent;
185 }
186 }
187 }
188 DoFromSourceAssign(alloc, source, terminator);
189 }
190 return stat;
191}
192
193int RTDEF(AllocatableDeallocate)(Descriptor &descriptor, bool hasStat,
194 const Descriptor *errMsg, const char *sourceFile, int sourceLine) {
195 Terminator terminator{sourceFile, sourceLine};
196 if (!descriptor.IsAllocatable()) {
197 return ReturnError(terminator, StatInvalidDescriptor, errMsg, hasStat);
198 } else if (!descriptor.IsAllocated()) {
199 return ReturnError(terminator, StatBaseNull, errMsg, hasStat);
200 } else {
201 return ReturnError(terminator,
202 descriptor.Destroy(
203 /*finalize=*/true, /*destroyPointers=*/false, &terminator),
204 errMsg, hasStat);
205 }
206}
207
208int RTDEF(AllocatableDeallocatePolymorphic)(Descriptor &descriptor,
209 const typeInfo::DerivedType *derivedType, bool hasStat,
210 const Descriptor *errMsg, const char *sourceFile, int sourceLine) {
211 int stat{RTNAME(AllocatableDeallocate)(
212 descriptor, hasStat, errMsg, sourceFile, sourceLine)};
213 if (stat == StatOk) {
214 if (DescriptorAddendum * addendum{descriptor.Addendum()}) {
215 addendum->set_derivedType(derivedType);
216 descriptor.raw().type = derivedType ? CFI_type_struct : CFI_type_other;
217 } else {
218 // Unlimited polymorphic descriptors initialized with
219 // AllocatableInitIntrinsic do not have an addendum. Make sure the
220 // derivedType is null in that case.
221 INTERNAL_CHECK(!derivedType);
222 descriptor.raw().type = CFI_type_other;
223 }
224 }
225 return stat;
226}
227
228void RTDEF(AllocatableDeallocateNoFinal)(
229 Descriptor &descriptor, const char *sourceFile, int sourceLine) {
230 Terminator terminator{sourceFile, sourceLine};
231 if (!descriptor.IsAllocatable()) {
232 ReturnError(terminator, StatInvalidDescriptor);
233 } else if (!descriptor.IsAllocated()) {
234 ReturnError(terminator, StatBaseNull);
235 } else {
236 ReturnError(terminator,
237 descriptor.Destroy(
238 /*finalize=*/false, /*destroyPointers=*/false, &terminator));
239 }
240}
241
242// TODO: AllocatableCheckLengthParameter
243
244RT_EXT_API_GROUP_END
245}
246} // namespace Fortran::runtime
247

source code of flang-rt/lib/runtime/allocatable.cpp