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 std::size_t TrimTrailingSpaces(const char *s, std::size_t n) {
  19   while (n > 0 && s[n - 1] == ' ') {
  20     --n;
  21   }
  22   return n;
  23 }
  24
  25 OwningPtr<char> SaveDefaultCharacter(
  26     const char *s, std::size_t length, const Terminator &terminator) {
  27   if (s) {
  28     auto *p{static_cast<char *>(AllocateMemoryOrCrash(terminator, length + 1))};
  29     std::memcpy(p, s, length);
  30     p[length] = '\0';
  31     return OwningPtr<char>{p};
  32   } else {
  33     return OwningPtr<char>{};
  34   }
  35 }
  36
  37 static bool CaseInsensitiveMatch(
  38     const char *value, std::size_t length, const char *possibility) {
  39   for (; length-- > 0; ++possibility) {
  40     char ch{*value++};
  41     if (ch >= 'a' && ch <= 'z') {
  42       ch += 'A' - 'a';
  43     }
  44     if (*possibility != ch) {
  45       if (*possibility != '\0' || ch != ' ') {
  46         return false;
  47       }
  48       // Ignore trailing blanks (12.5.6.2 p1)
  49       while (length-- > 0) {
  50         if (*value++ != ' ') {
  51           return false;
  52         }
  53       }
  54       return true;
  55     }
  56   }
  57   return *possibility == '\0';
  58 }
  59
  60 int IdentifyValue(
  61     const char *value, std::size_t length, const char *possibilities[]) {
  62   if (value) {
  63     for (int j{0}; possibilities[j]; ++j) {
  64       if (CaseInsensitiveMatch(value, length, possibilities[j])) {
  65         return j;
  66       }
  67     }
  68   }
  69   return -1;
  70 }
  71
  72 void ToFortranDefaultCharacter(
  73     char *to, std::size_t toLength, const char *from) {
  74   std::size_t len{std::strlen(from)};
  75   if (len < toLength) {
  76     std::memcpy(to, from, len);
  77     std::memset(to + len, ' ', toLength - len);
  78   } else {
  79     std::memcpy(to, from, toLength);
  80   }
  81 }
  82
  83 void CheckConformability(const Descriptor &to, const Descriptor &x,
  84     Terminator &terminator, const char *funcName, const char *toName,
  85     const char *xName) {
  86   if (x.rank() == 0) {
  87     return; // scalar conforms with anything
  88   }
  89   int rank{to.rank()};
  90   if (x.rank() != rank) {
  91     terminator.Crash(
  92         "Incompatible array arguments to %s: %s has rank %d but %s has rank %d",
  93         funcName, toName, rank, xName, x.rank());
  94   } else {
  95     for (int j{0}; j < rank; ++j) {
  96       auto toExtent{static_cast<std::int64_t>(to.GetDimension(j).Extent())};
  97       auto xExtent{static_cast<std::int64_t>(x.GetDimension(j).Extent())};
  98       if (xExtent != toExtent) {
  99         terminator.Crash("Incompatible array arguments to %s: dimension %d of "
 100                          "%s has extent %" PRId64 " but %s has extent %" PRId64,
 101             funcName, j + 1, toName, toExtent, xName, xExtent);
 102       }
 103     }
 104   }
 105 }
 106
 107 void CheckIntegerKind(Terminator &terminator, int kind, const char *intrinsic) {
 108   if (kind < 1 || kind > 16 || (kind & (kind - 1)) != 0) {
 109     terminator.Crash(
 110         "not yet implemented: %s: KIND=%d argument", intrinsic, kind);
 111   }
 112 }
 113
 114 void ShallowCopyDiscontiguousToDiscontiguous(
 115     const Descriptor &to, const Descriptor &from) {
 116   SubscriptValue toAt[maxRank], fromAt[maxRank];
 117   to.GetLowerBounds(toAt);
 118   from.GetLowerBounds(fromAt);
 119   std::size_t elementBytes{to.ElementBytes()};
 120   for (std::size_t n{to.Elements()}; n-- > 0;
 121        to.IncrementSubscripts(toAt), from.IncrementSubscripts(fromAt)) {
 122     std::memcpy(
 123         to.Element<char>(toAt), from.Element<char>(fromAt), elementBytes);
 124   }
 125 }
 126
 127 void ShallowCopyDiscontiguousToContiguous(
 128     const Descriptor &to, const Descriptor &from) {
 129   char *toAt{to.OffsetElement()};
 130   SubscriptValue fromAt[maxRank];
 131   from.GetLowerBounds(fromAt);
 132   std::size_t elementBytes{to.ElementBytes()};
 133   for (std::size_t n{to.Elements()}; n-- > 0;
 134        toAt += elementBytes, from.IncrementSubscripts(fromAt)) {
 135     std::memcpy(toAt, from.Element<char>(fromAt), elementBytes);
 136   }
 137 }
 138
 139 void ShallowCopyContiguousToDiscontiguous(
 140     const Descriptor &to, const Descriptor &from) {
 141   SubscriptValue toAt[maxRank];
 142   to.GetLowerBounds(toAt);
 143   char *fromAt{from.OffsetElement()};
 144   std::size_t elementBytes{to.ElementBytes()};
 145   for (std::size_t n{to.Elements()}; n-- > 0;
 146        to.IncrementSubscripts(toAt), fromAt += elementBytes) {
 147     std::memcpy(to.Element<char>(toAt), fromAt, elementBytes);
 148   }
 149 }
 150
 151 void ShallowCopy(const Descriptor &to, const Descriptor &from,
 152     bool toIsContiguous, bool fromIsContiguous) {
 153   if (toIsContiguous) {
 154     if (fromIsContiguous) {
 155       std::memcpy(to.OffsetElement(), from.OffsetElement(),
 156           to.Elements() * to.ElementBytes());
 157     } else {
 158       ShallowCopyDiscontiguousToContiguous(to, from);
 159     }
 160   } else {
 161     if (fromIsContiguous) {
 162       ShallowCopyContiguousToDiscontiguous(to, from);
 163     } else {
 164       ShallowCopyDiscontiguousToDiscontiguous(to, from);
 165     }
 166   }
 167 }
 168
 169 void ShallowCopy(const Descriptor &to, const Descriptor &from) {
 170   ShallowCopy(to, from, to.IsContiguous(), from.IsContiguous());
 171 }
 172 } // namespace Fortran::runtime