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