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.ApplyMold(mold, rank);
  60 }
  61
  62 void RTNAME(PointerAssociateScalar)(Descriptor &pointer, void *target) {
  63   pointer.set_base_addr(target);
  64 }
  65
  66 void RTNAME(PointerAssociate)(Descriptor &pointer, const Descriptor &target) {
  67   pointer = target;
  68   pointer.raw().attribute = CFI_attribute_pointer;
  69 }
  70
  71 void RTNAME(PointerAssociateLowerBounds)(Descriptor &pointer,
  72     const Descriptor &target, const Descriptor &lowerBounds) {
  73   pointer = target;
  74   pointer.raw().attribute = CFI_attribute_pointer;
  75   int rank{pointer.rank()};
  76   Terminator terminator{__FILE__, __LINE__};
  77   std::size_t boundElementBytes{lowerBounds.ElementBytes()};
  78   for (int j{0}; j < rank; ++j) {
  79     Dimension &dim{pointer.GetDimension(j)};
  80     dim.SetLowerBound(dim.Extent() == 0
  81             ? 1
  82             : GetInt64(lowerBounds.ZeroBasedIndexedElement<const char>(j),
  83                   boundElementBytes, terminator));
  84   }
  85 }
  86
  87 void RTNAME(PointerAssociateRemapping)(Descriptor &pointer,
  88     const Descriptor &target, const Descriptor &bounds, const char *sourceFile,
  89     int sourceLine) {
  90   pointer = target;
  91   pointer.raw().attribute = CFI_attribute_pointer;
  92   Terminator terminator{sourceFile, sourceLine};
  93   SubscriptValue byteStride{/*captured from first dimension*/};
  94   std::size_t boundElementBytes{bounds.ElementBytes()};
  95   std::size_t boundsRank{
  96       static_cast<std::size_t>(bounds.GetDimension(1).Extent())};
  97   pointer.raw().rank = boundsRank;
  98   for (unsigned j{0}; j < boundsRank; ++j) {
  99     auto &dim{pointer.GetDimension(j)};
 100     dim.SetBounds(GetInt64(bounds.ZeroBasedIndexedElement<const char>(2 * j),
 101                       boundElementBytes, terminator),
 102         GetInt64(bounds.ZeroBasedIndexedElement<const char>(2 * j + 1),
 103             boundElementBytes, terminator));
 104     if (j == 0) {
 105       byteStride = dim.ByteStride() * dim.Extent();
 106     } else {
 107       dim.SetByteStride(byteStride);
 108       byteStride *= dim.Extent();
 109     }
 110   }
 111   if (pointer.Elements() > target.Elements()) {
 112     terminator.Crash("PointerAssociateRemapping: too many elements in remapped "
 113                      "pointer (%zd > %zd)",
 114         pointer.Elements(), target.Elements());
 115   }
 116   if (auto *pointerAddendum{pointer.Addendum()}) {
 117     if (const auto *targetAddendum{target.Addendum()}) {
 118       if (const auto *derived{targetAddendum->derivedType()}) {
 119         pointerAddendum->set_derivedType(derived);
 120       }
 121     }
 122   }
 123 }
 124
 125 int RTNAME(PointerAllocate)(Descriptor &pointer, bool hasStat,
 126     const Descriptor *errMsg, const char *sourceFile, int sourceLine) {
 127   Terminator terminator{sourceFile, sourceLine};
 128   if (!pointer.IsPointer()) {
 129     return ReturnError(terminator, StatInvalidDescriptor, errMsg, hasStat);
 130   }
 131   int stat{ReturnError(terminator, pointer.Allocate(), errMsg, hasStat)};
 132   if (stat == StatOk) {
 133     if (const DescriptorAddendum * addendum{pointer.Addendum()}) {
 134       if (const auto *derived{addendum->derivedType()}) {
 135         if (!derived->noInitializationNeeded()) {
 136           stat = Initialize(pointer, *derived, terminator, hasStat, errMsg);
 137         }
 138       }
 139     }
 140   }
 141   return stat;
 142 }
 143
 144 int RTNAME(PointerAllocateSource)(Descriptor &pointer, const Descriptor &source,
 145     bool hasStat, const Descriptor *errMsg, const char *sourceFile,
 146     int sourceLine) {
 147   int stat{RTNAME(PointerAllocate)(
 148       pointer, hasStat, errMsg, sourceFile, sourceLine)};
 149   if (stat == StatOk) {
 150     Terminator terminator{sourceFile, sourceLine};
 151     DoFromSourceAssign(pointer, source, terminator);
 152   }
 153   return stat;
 154 }
 155
 156 int RTNAME(PointerDeallocate)(Descriptor &pointer, bool hasStat,
 157     const Descriptor *errMsg, const char *sourceFile, int sourceLine) {
 158   Terminator terminator{sourceFile, sourceLine};
 159   if (!pointer.IsPointer()) {
 160     return ReturnError(terminator, StatInvalidDescriptor, errMsg, hasStat);
 161   }
 162   if (!pointer.IsAllocated()) {
 163     return ReturnError(terminator, StatBaseNull, errMsg, hasStat);
 164   }
 165   return ReturnError(terminator,
 166       pointer.Destroy(/*finalize=*/true, /*destroyPointers=*/true, &terminator),
 167       errMsg, hasStat);
 168 }
 169
 170 int RTNAME(PointerDeallocatePolymorphic)(Descriptor &pointer,
 171     const typeInfo::DerivedType *derivedType, bool hasStat,
 172     const Descriptor *errMsg, const char *sourceFile, int sourceLine) {
 173   int stat{RTNAME(PointerDeallocate)(
 174       pointer, hasStat, errMsg, sourceFile, sourceLine)};
 175   if (stat == StatOk) {
 176     if (DescriptorAddendum * addendum{pointer.Addendum()}) {
 177       addendum->set_derivedType(derivedType);
 178       pointer.raw().type = derivedType ? CFI_type_struct : CFI_type_other;
 179     } else {
 180       // Unlimited polymorphic descriptors initialized with
 181       // PointerNullifyIntrinsic do not have an addendum. Make sure the
 182       // derivedType is null in that case.
 183       INTERNAL_CHECK(!derivedType);
 184       pointer.raw().type = CFI_type_other;
 185     }
 186   }
 187   return stat;
 188 }
 189
 190 bool RTNAME(PointerIsAssociated)(const Descriptor &pointer) {
 191   return pointer.raw().base_addr != nullptr;
 192 }
 193
 194 bool RTNAME(PointerIsAssociatedWith)(
 195     const Descriptor &pointer, const Descriptor *target) {
 196   if (!target) {
 197     return pointer.raw().base_addr != nullptr;
 198   }
 199   if (!target->raw().base_addr ||
 200       (target->raw().type != CFI_type_struct && target->ElementBytes() == 0)) {
 201     return false;
 202   }
 203   int rank{pointer.rank()};
 204   if (pointer.raw().base_addr != target->raw().base_addr ||
 205       pointer.ElementBytes() != target->ElementBytes() ||
 206       rank != target->rank()) {
 207     return false;
 208   }
 209   for (int j{0}; j < rank; ++j) {
 210     const Dimension &pDim{pointer.GetDimension(j)};
 211     const Dimension &tDim{target->GetDimension(j)};
 212     auto pExtent{pDim.Extent()};
 213     if (pExtent == 0 || pExtent != tDim.Extent() ||
 214         (pExtent != 1 && pDim.ByteStride() != tDim.ByteStride())) {
 215       return false;
 216     }
 217   }
 218   return true;
 219 }
 220
 221 // TODO: PointerCheckLengthParameter
 222
 223 } // extern "C"
 224 } // namespace Fortran::runtime