flang/runtime/allocatable.cpp

   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-impl.h"
  11 #include "derived.h"
  12 #include "stat.h"
  13 #include "terminator.h"
  14 #include "type-info.h"
  15 #include "flang/ISO_Fortran_binding_wrapper.h"
  16 #include "flang/Runtime/assign.h"
  17 #include "flang/Runtime/descriptor.h"
  18
  19 namespace Fortran::runtime {
  20 extern "C" {
  21 RT_EXT_API_GROUP_BEGIN
  22
  23 void 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
  31 void 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
  38 void 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
  45 void 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
  52 void 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
  59 void 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
  66 std::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 allocated
  72   // 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
 111 void 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
 120 void 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
 129 void RTDEF(AllocatableApplyMold)(
 130     Descriptor &descriptor, const Descriptor &mold, int rank) {
 131   if (descriptor.IsAllocatable() && !descriptor.IsAllocated()) {
 132     descriptor.ApplyMold(mold, rank);
 133   }
 134 }
 135
 136 int RTDEF(AllocatableAllocate)(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   } else if (descriptor.IsAllocated()) {
 142     return ReturnError(terminator, StatBaseNotNull, errMsg, hasStat);
 143   } else {
 144     int stat{ReturnError(terminator, descriptor.Allocate(), errMsg, hasStat)};
 145     if (stat == StatOk) {
 146       if (const DescriptorAddendum * addendum{descriptor.Addendum()}) {
 147         if (const auto *derived{addendum->derivedType()}) {
 148           if (!derived->noInitializationNeeded()) {
 149             stat =
 150                 Initialize(descriptor, *derived, terminator, hasStat, errMsg);
 151           }
 152         }
 153       }
 154     }
 155     return stat;
 156   }
 157 }
 158
 159 int RTDEF(AllocatableAllocateSource)(Descriptor &alloc,
 160     const Descriptor &source, bool hasStat, const Descriptor *errMsg,
 161     const char *sourceFile, int sourceLine) {
 162   int stat{RTNAME(AllocatableAllocate)(
 163       alloc, hasStat, errMsg, sourceFile, sourceLine)};
 164   if (stat == StatOk) {
 165     Terminator terminator{sourceFile, sourceLine};
 166     DoFromSourceAssign(alloc, source, terminator);
 167   }
 168   return stat;
 169 }
 170
 171 int RTDEF(AllocatableDeallocate)(Descriptor &descriptor, bool hasStat,
 172     const Descriptor *errMsg, const char *sourceFile, int sourceLine) {
 173   Terminator terminator{sourceFile, sourceLine};
 174   if (!descriptor.IsAllocatable()) {
 175     return ReturnError(terminator, StatInvalidDescriptor, errMsg, hasStat);
 176   } else if (!descriptor.IsAllocated()) {
 177     return ReturnError(terminator, StatBaseNull, errMsg, hasStat);
 178   } else {
 179     return ReturnError(terminator,
 180         descriptor.Destroy(
 181             /*finalize=*/true, /*destroyPointers=*/false, &terminator),
 182         errMsg, hasStat);
 183   }
 184 }
 185
 186 int RTDEF(AllocatableDeallocatePolymorphic)(Descriptor &descriptor,
 187     const typeInfo::DerivedType *derivedType, bool hasStat,
 188     const Descriptor *errMsg, const char *sourceFile, int sourceLine) {
 189   int stat{RTNAME(AllocatableDeallocate)(
 190       descriptor, hasStat, errMsg, sourceFile, sourceLine)};
 191   if (stat == StatOk) {
 192     if (DescriptorAddendum * addendum{descriptor.Addendum()}) {
 193       addendum->set_derivedType(derivedType);
 194       descriptor.raw().type = derivedType ? CFI_type_struct : CFI_type_other;
 195     } else {
 196       // Unlimited polymorphic descriptors initialized with
 197       // AllocatableInitIntrinsic do not have an addendum. Make sure the
 198       // derivedType is null in that case.
 199       INTERNAL_CHECK(!derivedType);
 200       descriptor.raw().type = CFI_type_other;
 201     }
 202   }
 203   return stat;
 204 }
 205
 206 void RTDEF(AllocatableDeallocateNoFinal)(
 207     Descriptor &descriptor, const char *sourceFile, int sourceLine) {
 208   Terminator terminator{sourceFile, sourceLine};
 209   if (!descriptor.IsAllocatable()) {
 210     ReturnError(terminator, StatInvalidDescriptor);
 211   } else if (!descriptor.IsAllocated()) {
 212     ReturnError(terminator, StatBaseNull);
 213   } else {
 214     ReturnError(terminator,
 215         descriptor.Destroy(
 216             /*finalize=*/false, /*destroyPointers=*/false, &terminator));
 217   }
 218 }
 219
 220 // TODO: AllocatableCheckLengthParameter
 221
 222 RT_EXT_API_GROUP_END
 223 }
 224 } // namespace Fortran::runtime