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_OFFLOAD_API_GROUP_END
 177 } // namespace Fortran::runtime