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 
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 
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 
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 
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 
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 
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 
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 
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 
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 
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