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-impl.h" 11 #include "derived.h" 12 #include "stat.h" 13 #include "terminator.h" 14 #include "type-info.h" 15 #include "flang/ISO_Fortran_binding_wrapper.h" 16 #include "flang/Runtime/assign.h" 17 #include "flang/Runtime/descriptor.h" 18 19 namespace Fortran::runtime { 20 extern "C" { 21 RT_EXT_API_GROUP_BEGIN 22 23 void RTDEF(AllocatableInitIntrinsic)(Descriptor &descriptor, 24 TypeCategory category, int kind, int rank, int corank) { 25 INTERNAL_CHECK(corank == 0); 26 descriptor.Establish(TypeCode{category, kind}, 27 Descriptor::BytesFor(category, kind), nullptr, rank, nullptr, 28 CFI_attribute_allocatable); 29 } 30 31 void RTDEF(AllocatableInitCharacter)(Descriptor &descriptor, 32 SubscriptValue length, int kind, int rank, int corank) { 33 INTERNAL_CHECK(corank == 0); 34 descriptor.Establish( 35 kind, length, nullptr, rank, nullptr, CFI_attribute_allocatable); 36 } 37 38 void RTDEF(AllocatableInitDerived)(Descriptor &descriptor, 39 const typeInfo::DerivedType &derivedType, int rank, int corank) { 40 INTERNAL_CHECK(corank == 0); 41 descriptor.Establish( 42 derivedType, nullptr, rank, nullptr, CFI_attribute_allocatable); 43 } 44 45 void RTDEF(AllocatableInitIntrinsicForAllocate)(Descriptor &descriptor, 46 TypeCategory category, int kind, int rank, int corank) { 47 if (!descriptor.IsAllocated()) { 48 RTNAME(AllocatableInitIntrinsic)(descriptor, category, kind, rank, corank); 49 } 50 } 51 52 void RTDEF(AllocatableInitCharacterForAllocate)(Descriptor &descriptor, 53 SubscriptValue length, int kind, int rank, int corank) { 54 if (!descriptor.IsAllocated()) { 55 RTNAME(AllocatableInitCharacter)(descriptor, length, kind, rank, corank); 56 } 57 } 58 59 void RTDEF(AllocatableInitDerivedForAllocate)(Descriptor &descriptor, 60 const typeInfo::DerivedType &derivedType, int rank, int corank) { 61 if (!descriptor.IsAllocated()) { 62 RTNAME(AllocatableInitDerived)(descriptor, derivedType, rank, corank); 63 } 64 } 65 66 std::int32_t RTDEF(MoveAlloc)(Descriptor &to, Descriptor &from, 67 const typeInfo::DerivedType *derivedType, bool hasStat, 68 const Descriptor *errMsg, const char *sourceFile, int sourceLine) { 69 Terminator terminator{sourceFile, sourceLine}; 70 71 // If to and from are the same allocatable they must not be allocated 72 // and nothing should be done. 73 if (from.raw().base_addr == to.raw().base_addr && from.IsAllocated()) { 74 return ReturnError( 75 terminator, StatMoveAllocSameAllocatable, errMsg, hasStat); 76 } 77 78 if (to.IsAllocated()) { 79 int stat{ 80 to.Destroy(/*finalize=*/true, /*destroyPointers=*/false, &terminator)}; 81 if (stat != StatOk) { 82 return ReturnError(terminator, stat, errMsg, hasStat); 83 } 84 } 85 86 // If from isn't allocated, the standard defines that nothing should be done. 87 if (from.IsAllocated()) { 88 to = from; 89 from.raw().base_addr = nullptr; 90 91 // Carry over the dynamic type. 92 if (auto *toAddendum{to.Addendum()}) { 93 if (const auto *fromAddendum{from.Addendum()}) { 94 if (const auto *derived{fromAddendum->derivedType()}) { 95 toAddendum->set_derivedType(derived); 96 } 97 } 98 } 99 100 // Reset from dynamic type if needed. 101 if (auto *fromAddendum{from.Addendum()}) { 102 if (derivedType) { 103 fromAddendum->set_derivedType(derivedType); 104 } 105 } 106 } 107 108 return StatOk; 109 } 110 111 void RTDEF(AllocatableSetBounds)(Descriptor &descriptor, int zeroBasedDim, 112 SubscriptValue lower, SubscriptValue upper) { 113 INTERNAL_CHECK(zeroBasedDim >= 0 && zeroBasedDim < descriptor.rank()); 114 if (descriptor.IsAllocatable() && !descriptor.IsAllocated()) { 115 descriptor.GetDimension(zeroBasedDim).SetBounds(lower, upper); 116 // The byte strides are computed when the object is allocated. 117 } 118 } 119 120 void RTDEF(AllocatableSetDerivedLength)( 121 Descriptor &descriptor, int which, SubscriptValue x) { 122 if (descriptor.IsAllocatable() && !descriptor.IsAllocated()) { 123 DescriptorAddendum *addendum{descriptor.Addendum()}; 124 INTERNAL_CHECK(addendum != nullptr); 125 addendum->SetLenParameterValue(which, x); 126 } 127 } 128 129 void RTDEF(AllocatableApplyMold)( 130 Descriptor &descriptor, const Descriptor &mold, int rank) { 131 if (descriptor.IsAllocatable() && !descriptor.IsAllocated()) { 132 descriptor.ApplyMold(mold, rank); 133 } 134 } 135 136 int RTDEF(AllocatableAllocate)(Descriptor &descriptor, std::int64_t asyncId, 137 bool hasStat, const Descriptor *errMsg, const char *sourceFile, 138 int sourceLine) { 139 Terminator terminator{sourceFile, sourceLine}; 140 if (!descriptor.IsAllocatable()) { 141 return ReturnError(terminator, StatInvalidDescriptor, errMsg, hasStat); 142 } else if (descriptor.IsAllocated()) { 143 return ReturnError(terminator, StatBaseNotNull, errMsg, hasStat); 144 } else { 145 int stat{ 146 ReturnError(terminator, descriptor.Allocate(asyncId), errMsg, hasStat)}; 147 if (stat == StatOk) { 148 if (const DescriptorAddendum * addendum{descriptor.Addendum()}) { 149 if (const auto *derived{addendum->derivedType()}) { 150 if (!derived->noInitializationNeeded()) { 151 stat = 152 Initialize(descriptor, *derived, terminator, hasStat, errMsg); 153 } 154 } 155 } 156 } 157 return stat; 158 } 159 } 160 161 int RTDEF(AllocatableAllocateSource)(Descriptor &alloc, 162 const Descriptor &source, bool hasStat, const Descriptor *errMsg, 163 const char *sourceFile, int sourceLine) { 164 int stat{RTNAME(AllocatableAllocate)( 165 alloc, /*asyncId=*/-1, hasStat, errMsg, sourceFile, sourceLine)}; 166 if (stat == StatOk) { 167 Terminator terminator{sourceFile, sourceLine}; 168 DoFromSourceAssign(alloc, source, terminator); 169 } 170 return stat; 171 } 172 173 int RTDEF(AllocatableDeallocate)(Descriptor &descriptor, bool hasStat, 174 const Descriptor *errMsg, const char *sourceFile, int sourceLine) { 175 Terminator terminator{sourceFile, sourceLine}; 176 if (!descriptor.IsAllocatable()) { 177 return ReturnError(terminator, StatInvalidDescriptor, errMsg, hasStat); 178 } else if (!descriptor.IsAllocated()) { 179 return ReturnError(terminator, StatBaseNull, errMsg, hasStat); 180 } else { 181 return ReturnError(terminator, 182 descriptor.Destroy( 183 /*finalize=*/true, /*destroyPointers=*/false, &terminator), 184 errMsg, hasStat); 185 } 186 } 187 188 int RTDEF(AllocatableDeallocatePolymorphic)(Descriptor &descriptor, 189 const typeInfo::DerivedType *derivedType, bool hasStat, 190 const Descriptor *errMsg, const char *sourceFile, int sourceLine) { 191 int stat{RTNAME(AllocatableDeallocate)( 192 descriptor, hasStat, errMsg, sourceFile, sourceLine)}; 193 if (stat == StatOk) { 194 if (DescriptorAddendum * addendum{descriptor.Addendum()}) { 195 addendum->set_derivedType(derivedType); 196 descriptor.raw().type = derivedType ? CFI_type_struct : CFI_type_other; 197 } else { 198 // Unlimited polymorphic descriptors initialized with 199 // AllocatableInitIntrinsic do not have an addendum. Make sure the 200 // derivedType is null in that case. 201 INTERNAL_CHECK(!derivedType); 202 descriptor.raw().type = CFI_type_other; 203 } 204 } 205 return stat; 206 } 207 208 void RTDEF(AllocatableDeallocateNoFinal)( 209 Descriptor &descriptor, const char *sourceFile, int sourceLine) { 210 Terminator terminator{sourceFile, sourceLine}; 211 if (!descriptor.IsAllocatable()) { 212 ReturnError(terminator, StatInvalidDescriptor); 213 } else if (!descriptor.IsAllocated()) { 214 ReturnError(terminator, StatBaseNull); 215 } else { 216 ReturnError(terminator, 217 descriptor.Destroy( 218 /*finalize=*/false, /*destroyPointers=*/false, &terminator)); 219 } 220 } 221 222 // TODO: AllocatableCheckLengthParameter 223 224 RT_EXT_API_GROUP_END 225 } 226 } // namespace Fortran::runtime 227