flang/runtime/pointer.cpp

   1 //===-- runtime/pointer.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/pointer.h"
  10 #include "assign-impl.h"
  11 #include "derived.h"
  12 #include "stat.h"
  13 #include "terminator.h"
  14 #include "tools.h"
  15 #include "type-info.h"
  16
  17 namespace Fortran::runtime {
  18 extern "C" {
  19
  20 void RTNAME(PointerNullifyIntrinsic)(Descriptor &pointer, TypeCategory category,
  21     int kind, int rank, int corank) {
  22   INTERNAL_CHECK(corank == 0);
  23   pointer.Establish(TypeCode{category, kind},
  24       Descriptor::BytesFor(category, kind), nullptr, rank, nullptr,
  25       CFI_attribute_pointer);
  26 }
  27
  28 void RTNAME(PointerNullifyCharacter)(Descriptor &pointer, SubscriptValue length,
  29     int kind, int rank, int corank) {
  30   INTERNAL_CHECK(corank == 0);
  31   pointer.Establish(
  32       kind, length, nullptr, rank, nullptr, CFI_attribute_pointer);
  33 }
  34
  35 void RTNAME(PointerNullifyDerived)(Descriptor &pointer,
  36     const typeInfo::DerivedType &derivedType, int rank, int corank) {
  37   INTERNAL_CHECK(corank == 0);
  38   pointer.Establish(derivedType, nullptr, rank, nullptr, CFI_attribute_pointer);
  39 }
  40
  41 void RTNAME(PointerSetBounds)(Descriptor &pointer, int zeroBasedDim,
  42     SubscriptValue lower, SubscriptValue upper) {
  43   INTERNAL_CHECK(zeroBasedDim >= 0 && zeroBasedDim < pointer.rank());
  44   pointer.GetDimension(zeroBasedDim).SetBounds(lower, upper);
  45   // The byte strides are computed when the pointer is allocated.
  46 }
  47
  48 // TODO: PointerSetCoBounds
  49
  50 void RTNAME(PointerSetDerivedLength)(
  51     Descriptor &pointer, int which, SubscriptValue x) {
  52   DescriptorAddendum *addendum{pointer.Addendum()};
  53   INTERNAL_CHECK(addendum != nullptr);
  54   addendum->SetLenParameterValue(which, x);
  55 }
  56
  57 void RTNAME(PointerApplyMold)(
  58     Descriptor &pointer, const Descriptor &mold, int rank) {
  59   pointer = mold;
  60   pointer.set_base_addr(nullptr);
  61   pointer.raw().attribute = CFI_attribute_pointer;
  62   pointer.raw().rank = rank;
  63   if (auto *pointerAddendum{pointer.Addendum()}) {
  64     if (const auto *moldAddendum{mold.Addendum()}) {
  65       if (const auto *derived{moldAddendum->derivedType()}) {
  66         pointerAddendum->set_derivedType(derived);
  67       }
  68     }
  69   }
  70 }
  71
  72 void RTNAME(PointerAssociateScalar)(Descriptor &pointer, void *target) {
  73   pointer.set_base_addr(target);
  74 }
  75
  76 void RTNAME(PointerAssociate)(Descriptor &pointer, const Descriptor &target) {
  77   pointer = target;
  78   pointer.raw().attribute = CFI_attribute_pointer;
  79 }
  80
  81 void RTNAME(PointerAssociateLowerBounds)(Descriptor &pointer,
  82     const Descriptor &target, const Descriptor &lowerBounds) {
  83   pointer = target;
  84   pointer.raw().attribute = CFI_attribute_pointer;
  85   int rank{pointer.rank()};
  86   Terminator terminator{__FILE__, __LINE__};
  87   std::size_t boundElementBytes{lowerBounds.ElementBytes()};
  88   for (int j{0}; j < rank; ++j) {
  89     Dimension &dim{pointer.GetDimension(j)};
  90     dim.SetLowerBound(dim.Extent() == 0
  91             ? 1
  92             : GetInt64(lowerBounds.ZeroBasedIndexedElement<const char>(j),
  93                   boundElementBytes, terminator));
  94   }
  95 }
  96
  97 void RTNAME(PointerAssociateRemapping)(Descriptor &pointer,
  98     const Descriptor &target, const Descriptor &bounds, const char *sourceFile,
  99     int sourceLine) {
 100   pointer = target;
 101   pointer.raw().attribute = CFI_attribute_pointer;
 102   Terminator terminator{sourceFile, sourceLine};
 103   SubscriptValue byteStride{/*captured from first dimension*/};
 104   std::size_t boundElementBytes{bounds.ElementBytes()};
 105   pointer.raw().rank = bounds.rank();
 106   for (int j{0}; j < bounds.rank(); ++j) {
 107     auto &dim{pointer.GetDimension(j)};
 108     dim.SetBounds(GetInt64(bounds.ZeroBasedIndexedElement<const char>(2 * j),
 109                       boundElementBytes, terminator),
 110         GetInt64(bounds.ZeroBasedIndexedElement<const char>(2 * j + 1),
 111             boundElementBytes, terminator));
 112     if (j == 0) {
 113       byteStride = dim.ByteStride() * dim.Extent();
 114     } else {
 115       dim.SetByteStride(byteStride);
 116       byteStride *= dim.Extent();
 117     }
 118   }
 119   if (pointer.Elements() > target.Elements()) {
 120     terminator.Crash("PointerAssociateRemapping: too many elements in remapped "
 121                      "pointer (%zd > %zd)",
 122         pointer.Elements(), target.Elements());
 123   }
 124   if (auto *pointerAddendum{pointer.Addendum()}) {
 125     if (const auto *targetAddendum{target.Addendum()}) {
 126       if (const auto *derived{targetAddendum->derivedType()}) {
 127         pointerAddendum->set_derivedType(derived);
 128       }
 129     }
 130   }
 131 }
 132
 133 int RTNAME(PointerAllocate)(Descriptor &pointer, bool hasStat,
 134     const Descriptor *errMsg, const char *sourceFile, int sourceLine) {
 135   Terminator terminator{sourceFile, sourceLine};
 136   if (!pointer.IsPointer()) {
 137     return ReturnError(terminator, StatInvalidDescriptor, errMsg, hasStat);
 138   }
 139   int stat{ReturnError(terminator, pointer.Allocate(), errMsg, hasStat)};
 140   if (stat == StatOk) {
 141     if (const DescriptorAddendum * addendum{pointer.Addendum()}) {
 142       if (const auto *derived{addendum->derivedType()}) {
 143         if (!derived->noInitializationNeeded()) {
 144           stat = Initialize(pointer, *derived, terminator, hasStat, errMsg);
 145         }
 146       }
 147     }
 148   }
 149   return stat;
 150 }
 151
 152 int RTNAME(PointerAllocateSource)(Descriptor &pointer, const Descriptor &source,
 153     bool hasStat, const Descriptor *errMsg, const char *sourceFile,
 154     int sourceLine) {
 155   if (pointer.Elements() == 0) {
 156     return StatOk;
 157   }
 158   int stat{RTNAME(PointerAllocate)(
 159       pointer, hasStat, errMsg, sourceFile, sourceLine)};
 160   if (stat == StatOk) {
 161     Terminator terminator{sourceFile, sourceLine};
 162     DoFromSourceAssign(pointer, source, terminator);
 163   }
 164   return stat;
 165 }
 166
 167 int RTNAME(PointerDeallocate)(Descriptor &pointer, bool hasStat,
 168     const Descriptor *errMsg, const char *sourceFile, int sourceLine) {
 169   Terminator terminator{sourceFile, sourceLine};
 170   if (!pointer.IsPointer()) {
 171     return ReturnError(terminator, StatInvalidDescriptor, errMsg, hasStat);
 172   }
 173   if (!pointer.IsAllocated()) {
 174     return ReturnError(terminator, StatBaseNull, errMsg, hasStat);
 175   }
 176   return ReturnError(terminator, pointer.Destroy(true, true), errMsg, hasStat);
 177 }
 178
 179 int RTNAME(PointerDeallocatePolymorphic)(Descriptor &pointer,
 180     const typeInfo::DerivedType *derivedType, bool hasStat,
 181     const Descriptor *errMsg, const char *sourceFile, int sourceLine) {
 182   int stat{RTNAME(PointerDeallocate)(
 183       pointer, hasStat, errMsg, sourceFile, sourceLine)};
 184   if (stat == StatOk) {
 185     DescriptorAddendum *addendum{pointer.Addendum()};
 186     if (addendum) {
 187       addendum->set_derivedType(derivedType);
 188     } else {
 189       // Unlimited polymorphic descriptors initialized with
 190       // PointerNullifyIntrinsic do not have an addendum. Make sure the
 191       // derivedType is null in that case.
 192       INTERNAL_CHECK(!derivedType);
 193     }
 194   }
 195   return stat;
 196 }
 197
 198 bool RTNAME(PointerIsAssociated)(const Descriptor &pointer) {
 199   return pointer.raw().base_addr != nullptr;
 200 }
 201
 202 bool RTNAME(PointerIsAssociatedWith)(
 203     const Descriptor &pointer, const Descriptor *target) {
 204   if (!target) {
 205     return pointer.raw().base_addr != nullptr;
 206   }
 207   if (!target->raw().base_addr || target->ElementBytes() == 0) {
 208     return false;
 209   }
 210   int rank{pointer.rank()};
 211   if (pointer.raw().base_addr != target->raw().base_addr ||
 212       pointer.ElementBytes() != target->ElementBytes() ||
 213       rank != target->rank()) {
 214     return false;
 215   }
 216   for (int j{0}; j < rank; ++j) {
 217     const Dimension &pDim{pointer.GetDimension(j)};
 218     const Dimension &tDim{target->GetDimension(j)};
 219     auto pExtent{pDim.Extent()};
 220     if (pExtent == 0 || pExtent != tDim.Extent() ||
 221         (pExtent != 1 && pDim.ByteStride() != tDim.ByteStride())) {
 222       return false;
 223     }
 224   }
 225   return true;
 226 }
 227
 228 // TODO: PointerCheckLengthParameter
 229
 230 } // extern "C"
 231 } // namespace Fortran::runtime