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 16 namespace Fortran::runtime { 17 extern "C" { 18 19 void RTNAME(AllocatableInitIntrinsic)(Descriptor &descriptor, 20 TypeCategory category, int kind, int rank, int corank) { 21 INTERNAL_CHECK(corank == 0); 22 descriptor.Establish(TypeCode{category, kind}, 23 Descriptor::BytesFor(category, kind), nullptr, rank, nullptr, 24 CFI_attribute_allocatable); 25 } 26 27 void RTNAME(AllocatableInitCharacter)(Descriptor &descriptor, 28 SubscriptValue length, int kind, int rank, int corank) { 29 INTERNAL_CHECK(corank == 0); 30 descriptor.Establish( 31 kind, length, nullptr, rank, nullptr, CFI_attribute_allocatable); 32 } 33 34 void RTNAME(AllocatableInitDerived)(Descriptor &descriptor, 35 const typeInfo::DerivedType &derivedType, int rank, int corank) { 36 INTERNAL_CHECK(corank == 0); 37 descriptor.Establish( 38 derivedType, nullptr, rank, nullptr, CFI_attribute_allocatable); 39 } 40 41 int RTNAME(MoveAlloc)(Descriptor &to, const Descriptor & /*from*/, 42 bool /*hasStat*/, const Descriptor * /*errMsg*/, 43 const char * /*sourceFile*/, int /*sourceLine*/) { 44 INTERNAL_CHECK(false); // TODO: MoveAlloc is not yet implemented 45 return StatOk; 46 } 47 48 void RTNAME(AllocatableSetBounds)(Descriptor &descriptor, int zeroBasedDim, 49 SubscriptValue lower, SubscriptValue upper) { 50 INTERNAL_CHECK(zeroBasedDim >= 0 && zeroBasedDim < descriptor.rank()); 51 descriptor.GetDimension(zeroBasedDim).SetBounds(lower, upper); 52 // The byte strides are computed when the object is allocated. 53 } 54 55 void RTNAME(AllocatableSetDerivedLength)( 56 Descriptor &descriptor, int which, SubscriptValue x) { 57 DescriptorAddendum *addendum{descriptor.Addendum()}; 58 INTERNAL_CHECK(addendum != nullptr); 59 addendum->SetLenParameterValue(which, x); 60 } 61 62 void RTNAME(AllocatableApplyMold)( 63 Descriptor &descriptor, const Descriptor &mold) { 64 if (descriptor.IsAllocated()) { 65 // 9.7.1.3 Return so the error can be emitted by AllocatableAllocate. 66 return; 67 } 68 descriptor = mold; 69 descriptor.set_base_addr(nullptr); 70 descriptor.raw().attribute = CFI_attribute_allocatable; 71 } 72 73 int RTNAME(AllocatableAllocate)(Descriptor &descriptor, bool hasStat, 74 const Descriptor *errMsg, const char *sourceFile, int sourceLine) { 75 Terminator terminator{sourceFile, sourceLine}; 76 if (!descriptor.IsAllocatable()) { 77 return ReturnError(terminator, StatInvalidDescriptor, errMsg, hasStat); 78 } 79 if (descriptor.IsAllocated()) { 80 return ReturnError(terminator, StatBaseNotNull, errMsg, hasStat); 81 } 82 int stat{ReturnError(terminator, descriptor.Allocate(), errMsg, hasStat)}; 83 if (stat == StatOk) { 84 if (const DescriptorAddendum * addendum{descriptor.Addendum()}) { 85 if (const auto *derived{addendum->derivedType()}) { 86 if (!derived->noInitializationNeeded()) { 87 stat = Initialize(descriptor, *derived, terminator, hasStat, errMsg); 88 } 89 } 90 } 91 } 92 return stat; 93 } 94 95 int RTNAME(AllocatableAllocateSource)(Descriptor &alloc, 96 const Descriptor &source, bool hasStat, const Descriptor *errMsg, 97 const char *sourceFile, int sourceLine) { 98 if (alloc.Elements() == 0) { 99 return StatOk; 100 } 101 int stat{RTNAME(AllocatableAllocate)( 102 alloc, hasStat, errMsg, sourceFile, sourceLine)}; 103 if (stat == StatOk) { 104 Terminator terminator{sourceFile, sourceLine}; 105 // 9.7.1.2(7) 106 Assign(alloc, source, terminator, /*skipRealloc=*/true); 107 } 108 return stat; 109 } 110 111 int RTNAME(AllocatableDeallocate)(Descriptor &descriptor, bool hasStat, 112 const Descriptor *errMsg, const char *sourceFile, int sourceLine) { 113 Terminator terminator{sourceFile, sourceLine}; 114 if (!descriptor.IsAllocatable()) { 115 return ReturnError(terminator, StatInvalidDescriptor, errMsg, hasStat); 116 } 117 if (!descriptor.IsAllocated()) { 118 return ReturnError(terminator, StatBaseNull, errMsg, hasStat); 119 } 120 return ReturnError(terminator, descriptor.Destroy(true), errMsg, hasStat); 121 } 122 123 int RTNAME(AllocatableDeallocatePolymorphic)(Descriptor &descriptor, 124 const typeInfo::DerivedType *derivedType, bool hasStat, 125 const Descriptor *errMsg, const char *sourceFile, int sourceLine) { 126 int stat{RTNAME(AllocatableDeallocate)( 127 descriptor, hasStat, errMsg, sourceFile, sourceLine)}; 128 if (stat == StatOk) { 129 DescriptorAddendum *addendum{descriptor.Addendum()}; 130 INTERNAL_CHECK(addendum != nullptr); 131 addendum->set_derivedType(derivedType); 132 } 133 return stat; 134 } 135 136 void RTNAME(AllocatableDeallocateNoFinal)( 137 Descriptor &descriptor, const char *sourceFile, int sourceLine) { 138 Terminator terminator{sourceFile, sourceLine}; 139 if (!descriptor.IsAllocatable()) { 140 ReturnError(terminator, StatInvalidDescriptor); 141 } else if (!descriptor.IsAllocated()) { 142 ReturnError(terminator, StatBaseNull); 143 } else { 144 ReturnError(terminator, descriptor.Destroy(false)); 145 } 146 } 147 148 // TODO: AllocatableCheckLengthParameter 149 } 150 } // namespace Fortran::runtime 151