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.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(
  55         terminator, StatMoveAllocSameAllocatable, errMsg, hasStat);
  56   }
  57
  58   if (to.IsAllocated()) {
  59     int stat{to.Destroy(/*finalize=*/true)};
  60     if (stat != StatOk) {
  61       return ReturnError(terminator, stat, errMsg, hasStat);
  62     }
  63   }
  64
  65   // If from isn't allocated, the standard defines that nothing should be done.
  66   if (from.IsAllocated()) {
  67     to = from;
  68     from.raw().base_addr = nullptr;
  69   }
  70   return StatOk;
  71 }
  72
  73 void RTNAME(AllocatableSetBounds)(Descriptor &descriptor, int zeroBasedDim,
  74     SubscriptValue lower, SubscriptValue upper) {
  75   INTERNAL_CHECK(zeroBasedDim >= 0 && zeroBasedDim < descriptor.rank());
  76   descriptor.GetDimension(zeroBasedDim).SetBounds(lower, upper);
  77   // The byte strides are computed when the object is allocated.
  78 }
  79
  80 void RTNAME(AllocatableSetDerivedLength)(
  81     Descriptor &descriptor, int which, SubscriptValue x) {
  82   DescriptorAddendum *addendum{descriptor.Addendum()};
  83   INTERNAL_CHECK(addendum != nullptr);
  84   addendum->SetLenParameterValue(which, x);
  85 }
  86
  87 void RTNAME(AllocatableApplyMold)(
  88     Descriptor &descriptor, const Descriptor &mold, int rank) {
  89   if (descriptor.IsAllocated()) {
  90     // 9.7.1.3 Return so the error can be emitted by AllocatableAllocate.
  91     return;
  92   }
  93   descriptor = mold;
  94   descriptor.set_base_addr(nullptr);
  95   descriptor.raw().attribute = CFI_attribute_allocatable;
  96   descriptor.raw().rank = rank;
  97   if (auto *descAddendum{descriptor.Addendum()}) {
  98     if (const auto *moldAddendum{mold.Addendum()}) {
  99       if (const auto *derived{moldAddendum->derivedType()}) {
 100         descAddendum->set_derivedType(derived);
 101       }
 102     }
 103   }
 104 }
 105
 106 int RTNAME(AllocatableAllocate)(Descriptor &descriptor, bool hasStat,
 107     const Descriptor *errMsg, const char *sourceFile, int sourceLine) {
 108   Terminator terminator{sourceFile, sourceLine};
 109   if (!descriptor.IsAllocatable()) {
 110     return ReturnError(terminator, StatInvalidDescriptor, errMsg, hasStat);
 111   }
 112   if (descriptor.IsAllocated()) {
 113     return ReturnError(terminator, StatBaseNotNull, errMsg, hasStat);
 114   }
 115   int stat{ReturnError(terminator, descriptor.Allocate(), errMsg, hasStat)};
 116   if (stat == StatOk) {
 117     if (const DescriptorAddendum * addendum{descriptor.Addendum()}) {
 118       if (const auto *derived{addendum->derivedType()}) {
 119         if (!derived->noInitializationNeeded()) {
 120           stat = Initialize(descriptor, *derived, terminator, hasStat, errMsg);
 121         }
 122       }
 123     }
 124   }
 125   return stat;
 126 }
 127
 128 int RTNAME(AllocatableAllocateSource)(Descriptor &alloc,
 129     const Descriptor &source, bool hasStat, const Descriptor *errMsg,
 130     const char *sourceFile, int sourceLine) {
 131   if (alloc.Elements() == 0) {
 132     return StatOk;
 133   }
 134   int stat{RTNAME(AllocatableAllocate)(
 135       alloc, hasStat, errMsg, sourceFile, sourceLine)};
 136   if (stat == StatOk) {
 137     Terminator terminator{sourceFile, sourceLine};
 138     DoFromSourceAssign(alloc, source, terminator);
 139   }
 140   return stat;
 141 }
 142
 143 int RTNAME(AllocatableDeallocate)(Descriptor &descriptor, bool hasStat,
 144     const Descriptor *errMsg, const char *sourceFile, int sourceLine) {
 145   Terminator terminator{sourceFile, sourceLine};
 146   if (!descriptor.IsAllocatable()) {
 147     return ReturnError(terminator, StatInvalidDescriptor, errMsg, hasStat);
 148   }
 149   if (!descriptor.IsAllocated()) {
 150     return ReturnError(terminator, StatBaseNull, errMsg, hasStat);
 151   }
 152   return ReturnError(terminator, descriptor.Destroy(true), errMsg, hasStat);
 153 }
 154
 155 int RTNAME(AllocatableDeallocatePolymorphic)(Descriptor &descriptor,
 156     const typeInfo::DerivedType *derivedType, bool hasStat,
 157     const Descriptor *errMsg, const char *sourceFile, int sourceLine) {
 158   int stat{RTNAME(AllocatableDeallocate)(
 159       descriptor, hasStat, errMsg, sourceFile, sourceLine)};
 160   if (stat == StatOk) {
 161     DescriptorAddendum *addendum{descriptor.Addendum()};
 162     if (addendum) { // Unlimited polymorphic allocated from intrinsic type spec
 163                     // does not have
 164       addendum->set_derivedType(derivedType);
 165     } else {
 166       // Unlimited polymorphic descriptors initialized with
 167       // AllocatableInitIntrinsic do not have an addendum. Make sure the
 168       // derivedType is null in that case.
 169       INTERNAL_CHECK(!derivedType);
 170     }
 171   }
 172   return stat;
 173 }
 174
 175 void RTNAME(AllocatableDeallocateNoFinal)(
 176     Descriptor &descriptor, const char *sourceFile, int sourceLine) {
 177   Terminator terminator{sourceFile, sourceLine};
 178   if (!descriptor.IsAllocatable()) {
 179     ReturnError(terminator, StatInvalidDescriptor);
 180   } else if (!descriptor.IsAllocated()) {
 181     ReturnError(terminator, StatBaseNull);
 182   } else {
 183     ReturnError(terminator, descriptor.Destroy(false));
 184   }
 185 }
 186
 187 // TODO: AllocatableCheckLengthParameter
 188 }
 189 } // namespace Fortran::runtime