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 "assign.h" 11 #include "derived.h" 12 #include "stat.h" 13 #include "terminator.h" 14 #include "type-info.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(AllocatableAllocateSource)(Descriptor &alloc, 92 const Descriptor &source, bool hasStat, const Descriptor *errMsg, 93 const char *sourceFile, int sourceLine) { 94 if (alloc.Elements() == 0) { 95 return StatOk; 96 } 97 int stat{RTNAME(AllocatableAllocate)( 98 alloc, hasStat, errMsg, sourceFile, sourceLine)}; 99 if (stat == StatOk) { 100 Terminator terminator{sourceFile, sourceLine}; 101 // 9.7.1.2(7) 102 Assign(alloc, source, terminator, /*skipRealloc=*/true); 103 } 104 return stat; 105 } 106 107 int RTNAME(AllocatableDeallocate)(Descriptor &descriptor, bool hasStat, 108 const Descriptor *errMsg, const char *sourceFile, int sourceLine) { 109 Terminator terminator{sourceFile, sourceLine}; 110 if (!descriptor.IsAllocatable()) { 111 return ReturnError(terminator, StatInvalidDescriptor, errMsg, hasStat); 112 } 113 if (!descriptor.IsAllocated()) { 114 return ReturnError(terminator, StatBaseNull, errMsg, hasStat); 115 } 116 return ReturnError(terminator, descriptor.Destroy(true), errMsg, hasStat); 117 } 118 119 int RTNAME(AllocatableDeallocatePolymorphic)(Descriptor &descriptor, 120 const typeInfo::DerivedType *derivedType, bool hasStat, 121 const Descriptor *errMsg, const char *sourceFile, int sourceLine) { 122 int stat{RTNAME(AllocatableDeallocate)( 123 descriptor, hasStat, errMsg, sourceFile, sourceLine)}; 124 if (stat == StatOk) { 125 DescriptorAddendum *addendum{descriptor.Addendum()}; 126 INTERNAL_CHECK(addendum != nullptr); 127 addendum->set_derivedType(derivedType); 128 } 129 return stat; 130 } 131 132 void RTNAME(AllocatableDeallocateNoFinal)( 133 Descriptor &descriptor, const char *sourceFile, int sourceLine) { 134 Terminator terminator{sourceFile, sourceLine}; 135 if (!descriptor.IsAllocatable()) { 136 ReturnError(terminator, StatInvalidDescriptor); 137 } else if (!descriptor.IsAllocated()) { 138 ReturnError(terminator, StatBaseNull); 139 } else { 140 ReturnError(terminator, descriptor.Destroy(false)); 141 } 142 } 143 144 // TODO: AllocatableCheckLengthParameter 145 } 146 } // namespace Fortran::runtime 147