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(terminator, StatInvalidDescriptor, errMsg, hasStat); 55 } 56 57 if (to.IsAllocated()) { 58 int stat{to.Destroy(/*finalize=*/true)}; 59 if (stat != StatOk) { 60 return ReturnError(terminator, stat, errMsg, hasStat); 61 } 62 } 63 64 // If from isn't allocated, the standard defines that nothing should be done. 65 if (from.IsAllocated()) { 66 to = from; 67 from.raw().base_addr = nullptr; 68 } 69 return StatOk; 70 } 71 72 void RTNAME(AllocatableSetBounds)(Descriptor &descriptor, int zeroBasedDim, 73 SubscriptValue lower, SubscriptValue upper) { 74 INTERNAL_CHECK(zeroBasedDim >= 0 && zeroBasedDim < descriptor.rank()); 75 descriptor.GetDimension(zeroBasedDim).SetBounds(lower, upper); 76 // The byte strides are computed when the object is allocated. 77 } 78 79 void RTNAME(AllocatableSetDerivedLength)( 80 Descriptor &descriptor, int which, SubscriptValue x) { 81 DescriptorAddendum *addendum{descriptor.Addendum()}; 82 INTERNAL_CHECK(addendum != nullptr); 83 addendum->SetLenParameterValue(which, x); 84 } 85 86 void RTNAME(AllocatableApplyMold)( 87 Descriptor &descriptor, const Descriptor &mold) { 88 if (descriptor.IsAllocated()) { 89 // 9.7.1.3 Return so the error can be emitted by AllocatableAllocate. 90 return; 91 } 92 descriptor = mold; 93 descriptor.set_base_addr(nullptr); 94 descriptor.raw().attribute = CFI_attribute_allocatable; 95 } 96 97 int RTNAME(AllocatableAllocate)(Descriptor &descriptor, bool hasStat, 98 const Descriptor *errMsg, const char *sourceFile, int sourceLine) { 99 Terminator terminator{sourceFile, sourceLine}; 100 if (!descriptor.IsAllocatable()) { 101 return ReturnError(terminator, StatInvalidDescriptor, errMsg, hasStat); 102 } 103 if (descriptor.IsAllocated()) { 104 return ReturnError(terminator, StatBaseNotNull, errMsg, hasStat); 105 } 106 int stat{ReturnError(terminator, descriptor.Allocate(), errMsg, hasStat)}; 107 if (stat == StatOk) { 108 if (const DescriptorAddendum * addendum{descriptor.Addendum()}) { 109 if (const auto *derived{addendum->derivedType()}) { 110 if (!derived->noInitializationNeeded()) { 111 stat = Initialize(descriptor, *derived, terminator, hasStat, errMsg); 112 } 113 } 114 } 115 } 116 return stat; 117 } 118 119 int RTNAME(AllocatableAllocateSource)(Descriptor &alloc, 120 const Descriptor &source, bool hasStat, const Descriptor *errMsg, 121 const char *sourceFile, int sourceLine) { 122 if (alloc.Elements() == 0) { 123 return StatOk; 124 } 125 int stat{RTNAME(AllocatableAllocate)( 126 alloc, hasStat, errMsg, sourceFile, sourceLine)}; 127 if (stat == StatOk) { 128 Terminator terminator{sourceFile, sourceLine}; 129 // 9.7.1.2(7) 130 Assign(alloc, source, terminator, /*skipRealloc=*/true); 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 INTERNAL_CHECK(addendum != nullptr); 155 addendum->set_derivedType(derivedType); 156 } 157 return stat; 158 } 159 160 void RTNAME(AllocatableDeallocateNoFinal)( 161 Descriptor &descriptor, const char *sourceFile, int sourceLine) { 162 Terminator terminator{sourceFile, sourceLine}; 163 if (!descriptor.IsAllocatable()) { 164 ReturnError(terminator, StatInvalidDescriptor); 165 } else if (!descriptor.IsAllocated()) { 166 ReturnError(terminator, StatBaseNull); 167 } else { 168 ReturnError(terminator, descriptor.Destroy(false)); 169 } 170 } 171 172 // TODO: AllocatableCheckLengthParameter 173 } 174 } // namespace Fortran::runtime 175