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 DoFromSourceAssign(alloc, source, terminator); 131 } 132 return stat; 133 } 134 135 int RTNAME(AllocatableDeallocate)(Descriptor &descriptor, bool hasStat, 136 const Descriptor *errMsg, const char *sourceFile, int sourceLine) { 137 Terminator terminator{sourceFile, sourceLine}; 138 if (!descriptor.IsAllocatable()) { 139 return ReturnError(terminator, StatInvalidDescriptor, errMsg, hasStat); 140 } 141 if (!descriptor.IsAllocated()) { 142 return ReturnError(terminator, StatBaseNull, errMsg, hasStat); 143 } 144 return ReturnError(terminator, descriptor.Destroy(true), errMsg, hasStat); 145 } 146 147 int RTNAME(AllocatableDeallocatePolymorphic)(Descriptor &descriptor, 148 const typeInfo::DerivedType *derivedType, bool hasStat, 149 const Descriptor *errMsg, const char *sourceFile, int sourceLine) { 150 int stat{RTNAME(AllocatableDeallocate)( 151 descriptor, hasStat, errMsg, sourceFile, sourceLine)}; 152 if (stat == StatOk) { 153 DescriptorAddendum *addendum{descriptor.Addendum()}; 154 if (addendum) { // Unlimited polymorphic allocated from intrinsic type spec 155 // does not have 156 addendum->set_derivedType(derivedType); 157 } else { 158 // Unlimited polymorphic descriptors initialized with 159 // AllocatableInitIntrinsic do not have an addendum. Make sure the 160 // derivedType is null in that case. 161 INTERNAL_CHECK(!derivedType); 162 } 163 } 164 return stat; 165 } 166 167 void RTNAME(AllocatableDeallocateNoFinal)( 168 Descriptor &descriptor, const char *sourceFile, int sourceLine) { 169 Terminator terminator{sourceFile, sourceLine}; 170 if (!descriptor.IsAllocatable()) { 171 ReturnError(terminator, StatInvalidDescriptor); 172 } else if (!descriptor.IsAllocated()) { 173 ReturnError(terminator, StatBaseNull); 174 } else { 175 ReturnError(terminator, descriptor.Destroy(false)); 176 } 177 } 178 179 // TODO: AllocatableCheckLengthParameter 180 } 181 } // namespace Fortran::runtime 182