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