247 lines · cpp
1//===-- lib/runtime/allocatable.cpp -----------------------------*- C++ -*-===//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-exception6//7//===----------------------------------------------------------------------===//8 9#include "flang/Runtime/allocatable.h"10#include "flang-rt/runtime/assign-impl.h"11#include "flang-rt/runtime/derived.h"12#include "flang-rt/runtime/descriptor.h"13#include "flang-rt/runtime/stat.h"14#include "flang-rt/runtime/terminator.h"15#include "flang-rt/runtime/type-info.h"16#include "flang/Common/ISO_Fortran_binding_wrapper.h"17#include "flang/Runtime/assign.h"18 19namespace Fortran::runtime {20extern "C" {21RT_EXT_API_GROUP_BEGIN22 23void 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 31void 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 38void 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 45void RTDEF(AllocatableInitIntrinsicForAllocate)(Descriptor &descriptor,46 TypeCategory category, int kind, int rank, int corank) {47 if (!descriptor.IsAllocated()) {48 RTNAME(AllocatableInitIntrinsic)(descriptor, category, kind, rank, corank);49 }50}51 52void RTDEF(AllocatableInitCharacterForAllocate)(Descriptor &descriptor,53 SubscriptValue length, int kind, int rank, int corank) {54 if (!descriptor.IsAllocated()) {55 RTNAME(AllocatableInitCharacter)(descriptor, length, kind, rank, corank);56 }57}58 59void RTDEF(AllocatableInitDerivedForAllocate)(Descriptor &descriptor,60 const typeInfo::DerivedType &derivedType, int rank, int corank) {61 if (!descriptor.IsAllocated()) {62 RTNAME(AllocatableInitDerived)(descriptor, derivedType, rank, corank);63 }64}65 66std::int32_t RTDEF(MoveAlloc)(Descriptor &to, Descriptor &from,67 const typeInfo::DerivedType *derivedType, bool hasStat,68 const Descriptor *errMsg, const char *sourceFile, int sourceLine) {69 Terminator terminator{sourceFile, sourceLine};70 71 // If to and from are the same allocatable they must not be allocated72 // and nothing should be done.73 if (from.raw().base_addr == to.raw().base_addr && from.IsAllocated()) {74 return ReturnError(75 terminator, StatMoveAllocSameAllocatable, errMsg, hasStat);76 }77 78 if (to.IsAllocated()) {79 int stat{80 to.Destroy(/*finalize=*/true, /*destroyPointers=*/false, &terminator)};81 if (stat != StatOk) {82 return ReturnError(terminator, stat, errMsg, hasStat);83 }84 }85 86 // If from isn't allocated, the standard defines that nothing should be done.87 if (from.IsAllocated()) {88 to = from;89 from.raw().base_addr = nullptr;90 91 // Carry over the dynamic type.92 if (auto *toAddendum{to.Addendum()}) {93 if (const auto *fromAddendum{from.Addendum()}) {94 if (const auto *derived{fromAddendum->derivedType()}) {95 toAddendum->set_derivedType(derived);96 }97 }98 }99 100 // Reset from dynamic type if needed.101 if (auto *fromAddendum{from.Addendum()}) {102 if (derivedType) {103 fromAddendum->set_derivedType(derivedType);104 }105 }106 }107 108 return StatOk;109}110 111void RTDEF(AllocatableSetBounds)(Descriptor &descriptor, int zeroBasedDim,112 SubscriptValue lower, SubscriptValue upper) {113 INTERNAL_CHECK(zeroBasedDim >= 0 && zeroBasedDim < descriptor.rank());114 if (descriptor.IsAllocatable() && !descriptor.IsAllocated()) {115 descriptor.GetDimension(zeroBasedDim).SetBounds(lower, upper);116 // The byte strides are computed when the object is allocated.117 }118}119 120void RTDEF(AllocatableSetDerivedLength)(121 Descriptor &descriptor, int which, SubscriptValue x) {122 if (descriptor.IsAllocatable() && !descriptor.IsAllocated()) {123 DescriptorAddendum *addendum{descriptor.Addendum()};124 INTERNAL_CHECK(addendum != nullptr);125 addendum->SetLenParameterValue(which, x);126 }127}128 129void RTDEF(AllocatableApplyMold)(130 Descriptor &descriptor, const Descriptor &mold, int rank) {131 if (descriptor.IsAllocatable() && !descriptor.IsAllocated()) {132 descriptor.ApplyMold(mold, rank);133 }134}135 136int RTDEF(AllocatableAllocate)(Descriptor &descriptor,137 std::int64_t *asyncObject, bool hasStat, const Descriptor *errMsg,138 const char *sourceFile, int sourceLine) {139 Terminator terminator{sourceFile, sourceLine};140 if (!descriptor.IsAllocatable()) {141 return ReturnError(terminator, StatInvalidDescriptor, errMsg, hasStat);142 } else if (descriptor.IsAllocated()) {143 return ReturnError(terminator, StatBaseNotNull, errMsg, hasStat);144 } else {145 int stat{ReturnError(146 terminator, descriptor.Allocate(asyncObject), 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 =152 Initialize(descriptor, *derived, terminator, hasStat, errMsg);153 }154 }155 }156 }157 return stat;158 }159}160 161int RTDEF(AllocatableAllocateSource)(Descriptor &alloc,162 const Descriptor &source, bool hasStat, const Descriptor *errMsg,163 const char *sourceFile, int sourceLine) {164 int stat{RTNAME(AllocatableAllocate)(165 alloc, /*asyncObject=*/nullptr, hasStat, errMsg, sourceFile, sourceLine)};166 if (stat == StatOk) {167 Terminator terminator{sourceFile, sourceLine};168 if (alloc.rank() != source.rank() && source.rank() != 0) {169 terminator.Crash("ALLOCATE object has rank %d while SOURCE= has rank %d",170 alloc.rank(), source.rank());171 }172 if (int rank{source.rank()}; rank > 0) {173 SubscriptValue allocExtent[maxRank], sourceExtent[maxRank];174 alloc.GetShape(allocExtent);175 source.GetShape(sourceExtent);176 for (int j{0}; j < rank; ++j) {177 if (allocExtent[j] != sourceExtent[j]) {178 if (!hasStat) {179 terminator.Crash("ALLOCATE object has extent %jd on dimension %d, "180 "but SOURCE= has extent %jd",181 static_cast<std::intmax_t>(allocExtent[j]), j + 1,182 static_cast<std::intmax_t>(sourceExtent[j]));183 }184 return StatInvalidExtent;185 }186 }187 }188 DoFromSourceAssign(alloc, source, terminator);189 }190 return stat;191}192 193int RTDEF(AllocatableDeallocate)(Descriptor &descriptor, bool hasStat,194 const Descriptor *errMsg, const char *sourceFile, int sourceLine) {195 Terminator terminator{sourceFile, sourceLine};196 if (!descriptor.IsAllocatable()) {197 return ReturnError(terminator, StatInvalidDescriptor, errMsg, hasStat);198 } else if (!descriptor.IsAllocated()) {199 return ReturnError(terminator, StatBaseNull, errMsg, hasStat);200 } else {201 return ReturnError(terminator,202 descriptor.Destroy(203 /*finalize=*/true, /*destroyPointers=*/false, &terminator),204 errMsg, hasStat);205 }206}207 208int RTDEF(AllocatableDeallocatePolymorphic)(Descriptor &descriptor,209 const typeInfo::DerivedType *derivedType, bool hasStat,210 const Descriptor *errMsg, const char *sourceFile, int sourceLine) {211 int stat{RTNAME(AllocatableDeallocate)(212 descriptor, hasStat, errMsg, sourceFile, sourceLine)};213 if (stat == StatOk) {214 if (DescriptorAddendum * addendum{descriptor.Addendum()}) {215 addendum->set_derivedType(derivedType);216 descriptor.raw().type = derivedType ? CFI_type_struct : CFI_type_other;217 } else {218 // Unlimited polymorphic descriptors initialized with219 // AllocatableInitIntrinsic do not have an addendum. Make sure the220 // derivedType is null in that case.221 INTERNAL_CHECK(!derivedType);222 descriptor.raw().type = CFI_type_other;223 }224 }225 return stat;226}227 228void RTDEF(AllocatableDeallocateNoFinal)(229 Descriptor &descriptor, const char *sourceFile, int sourceLine) {230 Terminator terminator{sourceFile, sourceLine};231 if (!descriptor.IsAllocatable()) {232 ReturnError(terminator, StatInvalidDescriptor);233 } else if (!descriptor.IsAllocated()) {234 ReturnError(terminator, StatBaseNull);235 } else {236 ReturnError(terminator,237 descriptor.Destroy(238 /*finalize=*/false, /*destroyPointers=*/false, &terminator));239 }240}241 242// TODO: AllocatableCheckLengthParameter243 244RT_EXT_API_GROUP_END245}246} // namespace Fortran::runtime247