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
  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 void RTNAME(AllocatableInitIntrinsicForAllocate)(Descriptor &descriptor,
  45     TypeCategory category, int kind, int rank, int corank) {
  46   if (descriptor.IsAllocated()) {
  47     return;
  48   }
  49   RTNAME(AllocatableInitIntrinsic)(descriptor, category, kind, rank, corank);
  50 }
  51
  52 void RTNAME(AllocatableInitCharacterForAllocate)(Descriptor &descriptor,
  53     SubscriptValue length, int kind, int rank, int corank) {
  54   if (descriptor.IsAllocated()) {
  55     return;
  56   }
  57   RTNAME(AllocatableInitCharacter)(descriptor, length, kind, rank, corank);
  58 }
  59
  60 void RTNAME(AllocatableInitDerivedForAllocate)(Descriptor &descriptor,
  61     const typeInfo::DerivedType &derivedType, int rank, int corank) {
  62   if (descriptor.IsAllocated()) {
  63     return;
  64   }
  65   RTNAME(AllocatableInitDerived)(descriptor, derivedType, rank, corank);
  66 }
  67
  68 std::int32_t RTNAME(MoveAlloc)(Descriptor &to, Descriptor &from,
  69     const typeInfo::DerivedType *derivedType, bool hasStat,
  70     const Descriptor *errMsg, const char *sourceFile, int sourceLine) {
  71   Terminator terminator{sourceFile, sourceLine};
  72
  73   // If to and from are the same allocatable they must not be allocated
  74   // and nothing should be done.
  75   if (from.raw().base_addr == to.raw().base_addr && from.IsAllocated()) {
  76     return ReturnError(
  77         terminator, StatMoveAllocSameAllocatable, errMsg, hasStat);
  78   }
  79
  80   if (to.IsAllocated()) {
  81     int stat{
  82         to.Destroy(/*finalize=*/true, /*destroyPointers=*/false, &terminator)};
  83     if (stat != StatOk) {
  84       return ReturnError(terminator, stat, errMsg, hasStat);
  85     }
  86   }
  87
  88   // If from isn't allocated, the standard defines that nothing should be done.
  89   if (from.IsAllocated()) {
  90     to = from;
  91     from.raw().base_addr = nullptr;
  92
  93     // Carry over the dynamic type.
  94     if (auto *toAddendum{to.Addendum()}) {
  95       if (const auto *fromAddendum{from.Addendum()}) {
  96         if (const auto *derived{fromAddendum->derivedType()}) {
  97           toAddendum->set_derivedType(derived);
  98         }
  99       }
 100     }
 101
 102     // Reset from dynamic type if needed.
 103     if (auto *fromAddendum{from.Addendum()}) {
 104       if (derivedType) {
 105         fromAddendum->set_derivedType(derivedType);
 106       }
 107     }
 108   }
 109
 110   return StatOk;
 111 }
 112
 113 void RTNAME(AllocatableSetBounds)(Descriptor &descriptor, int zeroBasedDim,
 114     SubscriptValue lower, SubscriptValue upper) {
 115   INTERNAL_CHECK(zeroBasedDim >= 0 && zeroBasedDim < descriptor.rank());
 116   descriptor.GetDimension(zeroBasedDim).SetBounds(lower, upper);
 117   // The byte strides are computed when the object is allocated.
 118 }
 119
 120 void RTNAME(AllocatableSetDerivedLength)(
 121     Descriptor &descriptor, int which, SubscriptValue x) {
 122   DescriptorAddendum *addendum{descriptor.Addendum()};
 123   INTERNAL_CHECK(addendum != nullptr);
 124   addendum->SetLenParameterValue(which, x);
 125 }
 126
 127 void RTNAME(AllocatableApplyMold)(
 128     Descriptor &descriptor, const Descriptor &mold, int rank) {
 129   if (descriptor.IsAllocated()) {
 130     // 9.7.1.3 Return so the error can be emitted by AllocatableAllocate.
 131     return;
 132   }
 133   descriptor.ApplyMold(mold, rank);
 134 }
 135
 136 int RTNAME(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   }
 142   if (descriptor.IsAllocated()) {
 143     return ReturnError(terminator, StatBaseNotNull, errMsg, hasStat);
 144   }
 145   int stat{ReturnError(terminator, descriptor.Allocate(), errMsg, hasStat)};
 146   if (stat == StatOk) {
 147     if (const DescriptorAddendum * addendum{descriptor.Addendum()}) {
 148       if (const auto *derived{addendum->derivedType()}) {
 149         if (!derived->noInitializationNeeded()) {
 150           stat = Initialize(descriptor, *derived, terminator, hasStat, errMsg);
 151         }
 152       }
 153     }
 154   }
 155   return stat;
 156 }
 157
 158 int RTNAME(AllocatableAllocateSource)(Descriptor &alloc,
 159     const Descriptor &source, bool hasStat, const Descriptor *errMsg,
 160     const char *sourceFile, int sourceLine) {
 161   int stat{RTNAME(AllocatableAllocate)(
 162       alloc, hasStat, errMsg, sourceFile, sourceLine)};
 163   if (stat == StatOk) {
 164     Terminator terminator{sourceFile, sourceLine};
 165     DoFromSourceAssign(alloc, source, terminator);
 166   }
 167   return stat;
 168 }
 169
 170 int RTNAME(AllocatableDeallocate)(Descriptor &descriptor, bool hasStat,
 171     const Descriptor *errMsg, const char *sourceFile, int sourceLine) {
 172   Terminator terminator{sourceFile, sourceLine};
 173   if (!descriptor.IsAllocatable()) {
 174     return ReturnError(terminator, StatInvalidDescriptor, errMsg, hasStat);
 175   }
 176   if (!descriptor.IsAllocated()) {
 177     return ReturnError(terminator, StatBaseNull, errMsg, hasStat);
 178   }
 179   return ReturnError(terminator,
 180       descriptor.Destroy(
 181           /*finalize=*/true, /*destroyPointers=*/false, &terminator),
 182       errMsg, hasStat);
 183 }
 184
 185 int RTNAME(AllocatableDeallocatePolymorphic)(Descriptor &descriptor,
 186     const typeInfo::DerivedType *derivedType, bool hasStat,
 187     const Descriptor *errMsg, const char *sourceFile, int sourceLine) {
 188   int stat{RTNAME(AllocatableDeallocate)(
 189       descriptor, hasStat, errMsg, sourceFile, sourceLine)};
 190   if (stat == StatOk) {
 191     if (DescriptorAddendum * addendum{descriptor.Addendum()}) {
 192       addendum->set_derivedType(derivedType);
 193       descriptor.raw().type = derivedType ? CFI_type_struct : CFI_type_other;
 194     } else {
 195       // Unlimited polymorphic descriptors initialized with
 196       // AllocatableInitIntrinsic do not have an addendum. Make sure the
 197       // derivedType is null in that case.
 198       INTERNAL_CHECK(!derivedType);
 199       descriptor.raw().type = CFI_type_other;
 200     }
 201   }
 202   return stat;
 203 }
 204
 205 void RTNAME(AllocatableDeallocateNoFinal)(
 206     Descriptor &descriptor, const char *sourceFile, int sourceLine) {
 207   Terminator terminator{sourceFile, sourceLine};
 208   if (!descriptor.IsAllocatable()) {
 209     ReturnError(terminator, StatInvalidDescriptor);
 210   } else if (!descriptor.IsAllocated()) {
 211     ReturnError(terminator, StatBaseNull);
 212   } else {
 213     ReturnError(terminator,
 214         descriptor.Destroy(
 215             /*finalize=*/false, /*destroyPointers=*/false, &terminator));
 216   }
 217 }
 218
 219 // TODO: AllocatableCheckLengthParameter
 220 }
 221 } // namespace Fortran::runtime