flang/runtime/tools.cpp

   1 //===-- runtime/tools.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 "tools.h"
  10 #include "terminator.h"
  11 #include <algorithm>
  12 #include <cstdint>
  13 #include <cstdlib>
  14 #include <cstring>
  15
  16 namespace Fortran::runtime {
  17
  18 RT_OFFLOAD_API_GROUP_BEGIN
  19
  20 RT_API_ATTRS std::size_t TrimTrailingSpaces(const char *s, std::size_t n) {
  21   while (n > 0 && s[n - 1] == ' ') {
  22     --n;
  23   }
  24   return n;
  25 }
  26
  27 RT_API_ATTRS OwningPtr<char> SaveDefaultCharacter(
  28     const char *s, std::size_t length, const Terminator &terminator) {
  29   if (s) {
  30     auto *p{static_cast<char *>(AllocateMemoryOrCrash(terminator, length + 1))};
  31     std::memcpy(p, s, length);
  32     p[length] = '\0';
  33     return OwningPtr<char>{p};
  34   } else {
  35     return OwningPtr<char>{};
  36   }
  37 }
  38
  39 static RT_API_ATTRS bool CaseInsensitiveMatch(
  40     const char *value, std::size_t length, const char *possibility) {
  41   for (; length-- > 0; ++possibility) {
  42     char ch{*value++};
  43     if (ch >= 'a' && ch <= 'z') {
  44       ch += 'A' - 'a';
  45     }
  46     if (*possibility != ch) {
  47       if (*possibility != '\0' || ch != ' ') {
  48         return false;
  49       }
  50       // Ignore trailing blanks (12.5.6.2 p1)
  51       while (length-- > 0) {
  52         if (*value++ != ' ') {
  53           return false;
  54         }
  55       }
  56       return true;
  57     }
  58   }
  59   return *possibility == '\0';
  60 }
  61
  62 RT_API_ATTRS int IdentifyValue(
  63     const char *value, std::size_t length, const char *possibilities[]) {
  64   if (value) {
  65     for (int j{0}; possibilities[j]; ++j) {
  66       if (CaseInsensitiveMatch(value, length, possibilities[j])) {
  67         return j;
  68       }
  69     }
  70   }
  71   return -1;
  72 }
  73
  74 RT_API_ATTRS void ToFortranDefaultCharacter(
  75     char *to, std::size_t toLength, const char *from) {
  76   std::size_t len{Fortran::runtime::strlen(from)};
  77   if (len < toLength) {
  78     std::memcpy(to, from, len);
  79     std::memset(to + len, ' ', toLength - len);
  80   } else {
  81     std::memcpy(to, from, toLength);
  82   }
  83 }
  84
  85 RT_API_ATTRS void CheckConformability(const Descriptor &to, const Descriptor &x,
  86     Terminator &terminator, const char *funcName, const char *toName,
  87     const char *xName) {
  88   if (x.rank() == 0) {
  89     return; // scalar conforms with anything
  90   }
  91   int rank{to.rank()};
  92   if (x.rank() != rank) {
  93     terminator.Crash(
  94         "Incompatible array arguments to %s: %s has rank %d but %s has rank %d",
  95         funcName, toName, rank, xName, x.rank());
  96   } else {
  97     for (int j{0}; j < rank; ++j) {
  98       auto toExtent{static_cast<std::int64_t>(to.GetDimension(j).Extent())};
  99       auto xExtent{static_cast<std::int64_t>(x.GetDimension(j).Extent())};
 100       if (xExtent != toExtent) {
 101         terminator.Crash("Incompatible array arguments to %s: dimension %d of "
 102                          "%s has extent %" PRId64 " but %s has extent %" PRId64,
 103             funcName, j + 1, toName, toExtent, xName, xExtent);
 104       }
 105     }
 106   }
 107 }
 108
 109 RT_API_ATTRS void CheckIntegerKind(
 110     Terminator &terminator, int kind, const char *intrinsic) {
 111   if (kind < 1 || kind > 16 || (kind & (kind - 1)) != 0) {
 112     terminator.Crash("not yet implemented: INTEGER(KIND=%d) in %s intrinsic",
 113         intrinsic, kind);
 114   }
 115 }
 116
 117 RT_API_ATTRS void ShallowCopyDiscontiguousToDiscontiguous(
 118     const Descriptor &to, const Descriptor &from) {
 119   SubscriptValue toAt[maxRank], fromAt[maxRank];
 120   to.GetLowerBounds(toAt);
 121   from.GetLowerBounds(fromAt);
 122   std::size_t elementBytes{to.ElementBytes()};
 123   for (std::size_t n{to.Elements()}; n-- > 0;
 124        to.IncrementSubscripts(toAt), from.IncrementSubscripts(fromAt)) {
 125     std::memcpy(
 126         to.Element<char>(toAt), from.Element<char>(fromAt), elementBytes);
 127   }
 128 }
 129
 130 RT_API_ATTRS void ShallowCopyDiscontiguousToContiguous(
 131     const Descriptor &to, const Descriptor &from) {
 132   char *toAt{to.OffsetElement()};
 133   SubscriptValue fromAt[maxRank];
 134   from.GetLowerBounds(fromAt);
 135   std::size_t elementBytes{to.ElementBytes()};
 136   for (std::size_t n{to.Elements()}; n-- > 0;
 137        toAt += elementBytes, from.IncrementSubscripts(fromAt)) {
 138     std::memcpy(toAt, from.Element<char>(fromAt), elementBytes);
 139   }
 140 }
 141
 142 RT_API_ATTRS void ShallowCopyContiguousToDiscontiguous(
 143     const Descriptor &to, const Descriptor &from) {
 144   SubscriptValue toAt[maxRank];
 145   to.GetLowerBounds(toAt);
 146   char *fromAt{from.OffsetElement()};
 147   std::size_t elementBytes{to.ElementBytes()};
 148   for (std::size_t n{to.Elements()}; n-- > 0;
 149        to.IncrementSubscripts(toAt), fromAt += elementBytes) {
 150     std::memcpy(to.Element<char>(toAt), fromAt, elementBytes);
 151   }
 152 }
 153
 154 RT_API_ATTRS void ShallowCopy(const Descriptor &to, const Descriptor &from,
 155     bool toIsContiguous, bool fromIsContiguous) {
 156   if (toIsContiguous) {
 157     if (fromIsContiguous) {
 158       std::memcpy(to.OffsetElement(), from.OffsetElement(),
 159           to.Elements() * to.ElementBytes());
 160     } else {
 161       ShallowCopyDiscontiguousToContiguous(to, from);
 162     }
 163   } else {
 164     if (fromIsContiguous) {
 165       ShallowCopyContiguousToDiscontiguous(to, from);
 166     } else {
 167       ShallowCopyDiscontiguousToDiscontiguous(to, from);
 168     }
 169   }
 170 }
 171
 172 RT_API_ATTRS void ShallowCopy(const Descriptor &to, const Descriptor &from) {
 173   ShallowCopy(to, from, to.IsContiguous(), from.IsContiguous());
 174 }
 175
 176 RT_API_ATTRS char *EnsureNullTerminated(
 177     char *str, std::size_t length, Terminator &terminator) {
 178   if (runtime::memchr(str, '\0', length) == nullptr) {
 179     char *newCmd{(char *)AllocateMemoryOrCrash(terminator, length + 1)};
 180     std::memcpy(newCmd, str, length);
 181     newCmd[length] = '\0';
 182     return newCmd;
 183   } else {
 184     return str;
 185   }
 186 }
 187
 188 RT_API_ATTRS bool IsValidCharDescriptor(const Descriptor *value) {
 189   return value && value->IsAllocated() &&
 190       value->type() == TypeCode(TypeCategory::Character, 1) &&
 191       value->rank() == 0;
 192 }
 193
 194 RT_API_ATTRS bool IsValidIntDescriptor(const Descriptor *intVal) {
 195   // Check that our descriptor is allocated and is a scalar integer with
 196   // kind != 1 (i.e. with a large enough decimal exponent range).
 197   return intVal && intVal->IsAllocated() && intVal->rank() == 0 &&
 198       intVal->type().IsInteger() && intVal->type().GetCategoryAndKind() &&
 199       intVal->type().GetCategoryAndKind()->second != 1;
 200 }
 201
 202 RT_API_ATTRS std::int32_t CopyCharsToDescriptor(const Descriptor &value,
 203     const char *rawValue, std::size_t rawValueLength, const Descriptor *errmsg,
 204     std::size_t offset) {
 205
 206   const std::int64_t toCopy{std::min(static_cast<std::int64_t>(rawValueLength),
 207       static_cast<std::int64_t>(value.ElementBytes() - offset))};
 208   if (toCopy < 0) {
 209     return ToErrmsg(errmsg, StatValueTooShort);
 210   }
 211
 212   std::memcpy(value.OffsetElement(offset), rawValue, toCopy);
 213
 214   if (static_cast<std::int64_t>(rawValueLength) > toCopy) {
 215     return ToErrmsg(errmsg, StatValueTooShort);
 216   }
 217
 218   return StatOk;
 219 }
 220
 221 RT_API_ATTRS void StoreIntToDescriptor(
 222     const Descriptor *length, std::int64_t value, Terminator &terminator) {
 223   auto typeCode{length->type().GetCategoryAndKind()};
 224   int kind{typeCode->second};
 225   ApplyIntegerKind<StoreIntegerAt, void>(
 226       kind, terminator, *length, /* atIndex = */ 0, value);
 227 }
 228
 229 template <int KIND> struct FitsInIntegerKind {
 230   RT_API_ATTRS bool operator()([[maybe_unused]] std::int64_t value) {
 231     if constexpr (KIND >= 8) {
 232       return true;
 233     } else {
 234       return value <=
 235           std::numeric_limits<
 236               CppTypeFor<Fortran::common::TypeCategory::Integer, KIND>>::max();
 237     }
 238   }
 239 };
 240
 241 // Utility: establishes & allocates the result array for a partial
 242 // reduction (i.e., one with DIM=).
 243 RT_API_ATTRS void CreatePartialReductionResult(Descriptor &result,
 244     const Descriptor &x, std::size_t resultElementSize, int dim,
 245     Terminator &terminator, const char *intrinsic, TypeCode typeCode) {
 246   int xRank{x.rank()};
 247   if (dim < 1 || dim > xRank) {
 248     terminator.Crash(
 249         "%s: bad DIM=%d for ARRAY with rank %d", intrinsic, dim, xRank);
 250   }
 251   int zeroBasedDim{dim - 1};
 252   SubscriptValue resultExtent[maxRank];
 253   for (int j{0}; j < zeroBasedDim; ++j) {
 254     resultExtent[j] = x.GetDimension(j).Extent();
 255   }
 256   for (int j{zeroBasedDim + 1}; j < xRank; ++j) {
 257     resultExtent[j - 1] = x.GetDimension(j).Extent();
 258   }
 259   result.Establish(typeCode, resultElementSize, nullptr, xRank - 1,
 260       resultExtent, CFI_attribute_allocatable);
 261   for (int j{0}; j + 1 < xRank; ++j) {
 262     result.GetDimension(j).SetBounds(1, resultExtent[j]);
 263   }
 264   if (int stat{result.Allocate()}) {
 265     terminator.Crash(
 266         "%s: could not allocate memory for result; STAT=%d", intrinsic, stat);
 267   }
 268 }
 269
 270 RT_OFFLOAD_API_GROUP_END
 271 } // namespace Fortran::runtime