1 //===-- 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 "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 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*/, Descriptor * /*errMsg*/, const char * /*sourceFile*/,
44     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 int RTNAME(AllocatableAllocate)(Descriptor &descriptor, bool hasStat,
57     Descriptor *errMsg, const char *sourceFile, int sourceLine) {
58   Terminator terminator{sourceFile, sourceLine};
59   if (!descriptor.IsAllocatable()) {
60     return ReturnError(terminator, StatInvalidDescriptor, errMsg, hasStat);
61   }
62   if (descriptor.IsAllocated()) {
63     return ReturnError(terminator, StatBaseNotNull, errMsg, hasStat);
64   }
65   return ReturnError(terminator, descriptor.Allocate(), errMsg, hasStat);
66 }
67 
68 int RTNAME(AllocatableDeallocate)(Descriptor &descriptor, bool hasStat,
69     Descriptor *errMsg, const char *sourceFile, int sourceLine) {
70   Terminator terminator{sourceFile, sourceLine};
71   if (!descriptor.IsAllocatable()) {
72     return ReturnError(terminator, StatInvalidDescriptor, errMsg, hasStat);
73   }
74   if (!descriptor.IsAllocated()) {
75     return ReturnError(terminator, StatBaseNull, errMsg, hasStat);
76   }
77   return ReturnError(terminator, descriptor.Deallocate(), errMsg, hasStat);
78 }
79 }
80 } // namespace Fortran::runtime
81