1 //===-- runtime/allocatable.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 "flang/Runtime/allocatable.h"
10 #include "derived.h"
11 #include "stat.h"
12 #include "terminator.h"
13 #include "type-info.h"
14 #include "flang/Runtime/assign.h"
15
16 namespace Fortran::runtime {
17 extern "C" {
18
RTNAME(AllocatableInitIntrinsic)19 void RTNAME(AllocatableInitIntrinsic)(Descriptor &descriptor,
20 TypeCategory category, int kind, int rank, int corank) {
21 INTERNAL_CHECK(corank == 0);
22 descriptor.Establish(TypeCode{category, kind},
23 Descriptor::BytesFor(category, kind), nullptr, rank, nullptr,
24 CFI_attribute_allocatable);
25 }
26
RTNAME(AllocatableInitCharacter)27 void RTNAME(AllocatableInitCharacter)(Descriptor &descriptor,
28 SubscriptValue length, int kind, int rank, int corank) {
29 INTERNAL_CHECK(corank == 0);
30 descriptor.Establish(
31 kind, length, nullptr, rank, nullptr, CFI_attribute_allocatable);
32 }
33
RTNAME(AllocatableInitDerived)34 void RTNAME(AllocatableInitDerived)(Descriptor &descriptor,
35 const typeInfo::DerivedType &derivedType, int rank, int corank) {
36 INTERNAL_CHECK(corank == 0);
37 descriptor.Establish(
38 derivedType, nullptr, rank, nullptr, CFI_attribute_allocatable);
39 }
40
RTNAME(MoveAlloc)41 int RTNAME(MoveAlloc)(Descriptor &to, const Descriptor & /*from*/,
42 bool /*hasStat*/, const Descriptor * /*errMsg*/,
43 const char * /*sourceFile*/, int /*sourceLine*/) {
44 INTERNAL_CHECK(false); // TODO: MoveAlloc is not yet implemented
45 return StatOk;
46 }
47
RTNAME(AllocatableSetBounds)48 void RTNAME(AllocatableSetBounds)(Descriptor &descriptor, int zeroBasedDim,
49 SubscriptValue lower, SubscriptValue upper) {
50 INTERNAL_CHECK(zeroBasedDim >= 0 && zeroBasedDim < descriptor.rank());
51 descriptor.GetDimension(zeroBasedDim).SetBounds(lower, upper);
52 // The byte strides are computed when the object is allocated.
53 }
54
RTNAME(AllocatableSetDerivedLength)55 void RTNAME(AllocatableSetDerivedLength)(
56 Descriptor &descriptor, int which, SubscriptValue x) {
57 DescriptorAddendum *addendum{descriptor.Addendum()};
58 INTERNAL_CHECK(addendum != nullptr);
59 addendum->SetLenParameterValue(which, x);
60 }
61
RTNAME(AllocatableApplyMold)62 void RTNAME(AllocatableApplyMold)(
63 Descriptor &descriptor, const Descriptor &mold) {
64 descriptor = mold;
65 descriptor.set_base_addr(nullptr);
66 descriptor.raw().attribute = CFI_attribute_allocatable;
67 }
68
RTNAME(AllocatableAllocate)69 int RTNAME(AllocatableAllocate)(Descriptor &descriptor, bool hasStat,
70 const Descriptor *errMsg, const char *sourceFile, int sourceLine) {
71 Terminator terminator{sourceFile, sourceLine};
72 if (!descriptor.IsAllocatable()) {
73 return ReturnError(terminator, StatInvalidDescriptor, errMsg, hasStat);
74 }
75 if (descriptor.IsAllocated()) {
76 return ReturnError(terminator, StatBaseNotNull, errMsg, hasStat);
77 }
78 int stat{ReturnError(terminator, descriptor.Allocate(), errMsg, hasStat)};
79 if (stat == StatOk) {
80 if (const DescriptorAddendum * addendum{descriptor.Addendum()}) {
81 if (const auto *derived{addendum->derivedType()}) {
82 if (!derived->noInitializationNeeded()) {
83 stat = Initialize(descriptor, *derived, terminator, hasStat, errMsg);
84 }
85 }
86 }
87 }
88 return stat;
89 }
90
RTNAME(AllocatableDeallocate)91 int RTNAME(AllocatableDeallocate)(Descriptor &descriptor, bool hasStat,
92 const Descriptor *errMsg, const char *sourceFile, int sourceLine) {
93 Terminator terminator{sourceFile, sourceLine};
94 if (!descriptor.IsAllocatable()) {
95 return ReturnError(terminator, StatInvalidDescriptor, errMsg, hasStat);
96 }
97 if (!descriptor.IsAllocated()) {
98 return ReturnError(terminator, StatBaseNull, errMsg, hasStat);
99 }
100 return ReturnError(terminator, descriptor.Destroy(true), errMsg, hasStat);
101 }
102
RTNAME(AllocatableDeallocateNoFinal)103 void RTNAME(AllocatableDeallocateNoFinal)(
104 Descriptor &descriptor, const char *sourceFile, int sourceLine) {
105 Terminator terminator{sourceFile, sourceLine};
106 if (!descriptor.IsAllocatable()) {
107 ReturnError(terminator, StatInvalidDescriptor);
108 } else if (!descriptor.IsAllocated()) {
109 ReturnError(terminator, StatBaseNull);
110 } else {
111 ReturnError(terminator, descriptor.Destroy(false));
112 }
113 }
114
115 // TODO: AllocatableCheckLengthParameter, AllocatableAllocateSource
116 }
117 } // namespace Fortran::runtime
118