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 #include "flang/ISO_Fortran_binding.h" 16 #include "flang/Runtime/assign.h" 17 #include "flang/Runtime/descriptor.h" 18 19 namespace Fortran::runtime { 20 extern "C" { 21 22 void RTNAME(AllocatableInitIntrinsic)(Descriptor &descriptor, 23 TypeCategory category, int kind, int rank, int corank) { 24 INTERNAL_CHECK(corank == 0); 25 descriptor.Establish(TypeCode{category, kind}, 26 Descriptor::BytesFor(category, kind), nullptr, rank, nullptr, 27 CFI_attribute_allocatable); 28 } 29 30 void RTNAME(AllocatableInitCharacter)(Descriptor &descriptor, 31 SubscriptValue length, int kind, int rank, int corank) { 32 INTERNAL_CHECK(corank == 0); 33 descriptor.Establish( 34 kind, length, nullptr, rank, nullptr, CFI_attribute_allocatable); 35 } 36 37 void RTNAME(AllocatableInitDerived)(Descriptor &descriptor, 38 const typeInfo::DerivedType &derivedType, int rank, int corank) { 39 INTERNAL_CHECK(corank == 0); 40 descriptor.Establish( 41 derivedType, nullptr, rank, nullptr, CFI_attribute_allocatable); 42 } 43 44 std::int32_t RTNAME(MoveAlloc)(Descriptor &to, Descriptor &from, bool hasStat, 45 const Descriptor *errMsg, const char *sourceFile, int sourceLine) { 46 Terminator terminator{sourceFile, sourceLine}; 47 // Should be handled by semantic analysis 48 RUNTIME_CHECK(terminator, to.type() == from.type()); 49 RUNTIME_CHECK(terminator, to.IsAllocatable() && from.IsAllocatable()); 50 51 // If to and from are the same allocatable they must not be allocated 52 // and nothing should be done. 53 if (from.raw().base_addr == to.raw().base_addr && from.IsAllocated()) { 54 return ReturnError( 55 terminator, StatMoveAllocSameAllocatable, errMsg, hasStat); 56 } 57 58 if (to.IsAllocated()) { 59 int stat{to.Destroy(/*finalize=*/true)}; 60 if (stat != StatOk) { 61 return ReturnError(terminator, stat, errMsg, hasStat); 62 } 63 } 64 65 // If from isn't allocated, the standard defines that nothing should be done. 66 if (from.IsAllocated()) { 67 to = from; 68 from.raw().base_addr = nullptr; 69 } 70 return StatOk; 71 } 72 73 void RTNAME(AllocatableSetBounds)(Descriptor &descriptor, int zeroBasedDim, 74 SubscriptValue lower, SubscriptValue upper) { 75 INTERNAL_CHECK(zeroBasedDim >= 0 && zeroBasedDim < descriptor.rank()); 76 descriptor.GetDimension(zeroBasedDim).SetBounds(lower, upper); 77 // The byte strides are computed when the object is allocated. 78 } 79 80 void RTNAME(AllocatableSetDerivedLength)( 81 Descriptor &descriptor, int which, SubscriptValue x) { 82 DescriptorAddendum *addendum{descriptor.Addendum()}; 83 INTERNAL_CHECK(addendum != nullptr); 84 addendum->SetLenParameterValue(which, x); 85 } 86 87 void RTNAME(AllocatableApplyMold)( 88 Descriptor &descriptor, const Descriptor &mold) { 89 if (descriptor.IsAllocated()) { 90 // 9.7.1.3 Return so the error can be emitted by AllocatableAllocate. 91 return; 92 } 93 descriptor = mold; 94 descriptor.set_base_addr(nullptr); 95 descriptor.raw().attribute = CFI_attribute_allocatable; 96 } 97 98 int RTNAME(AllocatableAllocate)(Descriptor &descriptor, bool hasStat, 99 const Descriptor *errMsg, const char *sourceFile, int sourceLine) { 100 Terminator terminator{sourceFile, sourceLine}; 101 if (!descriptor.IsAllocatable()) { 102 return ReturnError(terminator, StatInvalidDescriptor, errMsg, hasStat); 103 } 104 if (descriptor.IsAllocated()) { 105 return ReturnError(terminator, StatBaseNotNull, errMsg, hasStat); 106 } 107 int stat{ReturnError(terminator, descriptor.Allocate(), errMsg, hasStat)}; 108 if (stat == StatOk) { 109 if (const DescriptorAddendum * addendum{descriptor.Addendum()}) { 110 if (const auto *derived{addendum->derivedType()}) { 111 if (!derived->noInitializationNeeded()) { 112 stat = Initialize(descriptor, *derived, terminator, hasStat, errMsg); 113 } 114 } 115 } 116 } 117 return stat; 118 } 119 120 int RTNAME(AllocatableAllocateSource)(Descriptor &alloc, 121 const Descriptor &source, bool hasStat, const Descriptor *errMsg, 122 const char *sourceFile, int sourceLine) { 123 if (alloc.Elements() == 0) { 124 return StatOk; 125 } 126 int stat{RTNAME(AllocatableAllocate)( 127 alloc, hasStat, errMsg, sourceFile, sourceLine)}; 128 if (stat == StatOk) { 129 Terminator terminator{sourceFile, sourceLine}; 130 // 9.7.1.2(7) 131 Assign(alloc, source, terminator, /*skipRealloc=*/true); 132 } 133 return stat; 134 } 135 136 int RTNAME(AllocatableDeallocate)(Descriptor &descriptor, bool hasStat, 137 const Descriptor *errMsg, const char *sourceFile, int sourceLine) { 138 Terminator terminator{sourceFile, sourceLine}; 139 if (!descriptor.IsAllocatable()) { 140 return ReturnError(terminator, StatInvalidDescriptor, errMsg, hasStat); 141 } 142 if (!descriptor.IsAllocated()) { 143 return ReturnError(terminator, StatBaseNull, errMsg, hasStat); 144 } 145 return ReturnError(terminator, descriptor.Destroy(true), errMsg, hasStat); 146 } 147 148 int RTNAME(AllocatableDeallocatePolymorphic)(Descriptor &descriptor, 149 const typeInfo::DerivedType *derivedType, bool hasStat, 150 const Descriptor *errMsg, const char *sourceFile, int sourceLine) { 151 int stat{RTNAME(AllocatableDeallocate)( 152 descriptor, hasStat, errMsg, sourceFile, sourceLine)}; 153 if (stat == StatOk) { 154 DescriptorAddendum *addendum{descriptor.Addendum()}; 155 if (addendum) { // Unlimited polymorphic allocated from intrinsic type spec 156 // does not have 157 addendum->set_derivedType(derivedType); 158 } else { 159 // Unlimited polymorphic descriptors initialized with 160 // AllocatableInitIntrinsic do not have an addendum. Make sure the 161 // derivedType is null in that case. 162 INTERNAL_CHECK(!derivedType); 163 } 164 } 165 return stat; 166 } 167 168 void RTNAME(AllocatableDeallocateNoFinal)( 169 Descriptor &descriptor, const char *sourceFile, int sourceLine) { 170 Terminator terminator{sourceFile, sourceLine}; 171 if (!descriptor.IsAllocatable()) { 172 ReturnError(terminator, StatInvalidDescriptor); 173 } else if (!descriptor.IsAllocated()) { 174 ReturnError(terminator, StatBaseNull); 175 } else { 176 ReturnError(terminator, descriptor.Destroy(false)); 177 } 178 } 179 180 // TODO: AllocatableCheckLengthParameter 181 } 182 } // namespace Fortran::runtime 183