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
RTNAME(AllocatableInitIntrinsic)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
RTNAME(AllocatableInitCharacter)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
RTNAME(AllocatableInitDerived)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
RTNAME(AllocatableAssign)38 void RTNAME(AllocatableAssign)(Descriptor &to, const Descriptor & /*from*/) {
39 INTERNAL_CHECK(false); // AllocatableAssign is not yet implemented
40 }
41
RTNAME(MoveAlloc)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
RTNAME(AllocatableSetBounds)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
RTNAME(AllocatableAllocate)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
RTNAME(AllocatableDeallocate)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