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