flang/runtime/character.cpp

   1 //===-- runtime/character.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/character.h"
  10 #include "terminator.h"
  11 #include "tools.h"
  12 #include "flang/Common/bit-population-count.h"
  13 #include "flang/Common/uint128.h"
  14 #include "flang/Runtime/character.h"
  15 #include "flang/Runtime/cpp-type.h"
  16 #include "flang/Runtime/descriptor.h"
  17 #include <algorithm>
  18 #include <cstring>
  19
  20 namespace Fortran::runtime {
  21
  22 template <typename CHAR>
  23 inline RT_API_ATTRS int CompareToBlankPadding(
  24     const CHAR *x, std::size_t chars) {
  25   using UNSIGNED_CHAR = std::make_unsigned_t<CHAR>;
  26   const auto blank{static_cast<UNSIGNED_CHAR>(' ')};
  27   for (; chars-- > 0; ++x) {
  28     const UNSIGNED_CHAR ux{*reinterpret_cast<const UNSIGNED_CHAR *>(x)};
  29     if (ux < blank) {
  30       return -1;
  31     }
  32     if (ux > blank) {
  33       return 1;
  34     }
  35   }
  36   return 0;
  37 }
  38
  39 RT_OFFLOAD_API_GROUP_BEGIN
  40
  41 template <typename CHAR>
  42 RT_API_ATTRS int CharacterScalarCompare(
  43     const CHAR *x, const CHAR *y, std::size_t xChars, std::size_t yChars) {
  44   auto minChars{std::min(xChars, yChars)};
  45   if constexpr (sizeof(CHAR) == 1) {
  46     // don't use for kind=2 or =4, that would fail on little-endian machines
  47     int cmp{Fortran::runtime::memcmp(x, y, minChars)};
  48     if (cmp < 0) {
  49       return -1;
  50     }
  51     if (cmp > 0) {
  52       return 1;
  53     }
  54     if (xChars == yChars) {
  55       return 0;
  56     }
  57     x += minChars;
  58     y += minChars;
  59   } else {
  60     for (std::size_t n{minChars}; n-- > 0; ++x, ++y) {
  61       if (*x < *y) {
  62         return -1;
  63       }
  64       if (*x > *y) {
  65         return 1;
  66       }
  67     }
  68   }
  69   if (int cmp{CompareToBlankPadding(x, xChars - minChars)}) {
  70     return cmp;
  71   }
  72   return -CompareToBlankPadding(y, yChars - minChars);
  73 }
  74
  75 template RT_API_ATTRS int CharacterScalarCompare<char>(
  76     const char *x, const char *y, std::size_t xChars, std::size_t yChars);
  77 template RT_API_ATTRS int CharacterScalarCompare<char16_t>(const char16_t *x,
  78     const char16_t *y, std::size_t xChars, std::size_t yChars);
  79 template RT_API_ATTRS int CharacterScalarCompare<char32_t>(const char32_t *x,
  80     const char32_t *y, std::size_t xChars, std::size_t yChars);
  81
  82 RT_OFFLOAD_API_GROUP_END
  83
  84 // Shift count to use when converting between character lengths
  85 // and byte counts.
  86 template <typename CHAR>
  87 constexpr int shift{common::TrailingZeroBitCount(sizeof(CHAR))};
  88
  89 template <typename CHAR>
  90 static RT_API_ATTRS void Compare(Descriptor &result, const Descriptor &x,
  91     const Descriptor &y, const Terminator &terminator) {
  92   RUNTIME_CHECK(
  93       terminator, x.rank() == y.rank() || x.rank() == 0 || y.rank() == 0);
  94   int rank{std::max(x.rank(), y.rank())};
  95   SubscriptValue ub[maxRank], xAt[maxRank], yAt[maxRank];
  96   SubscriptValue elements{1};
  97   for (int j{0}; j < rank; ++j) {
  98     if (x.rank() > 0 && y.rank() > 0) {
  99       SubscriptValue xUB{x.GetDimension(j).Extent()};
 100       SubscriptValue yUB{y.GetDimension(j).Extent()};
 101       if (xUB != yUB) {
 102         terminator.Crash("Character array comparison: operands are not "
 103                          "conforming on dimension %d (%jd != %jd)",
 104             j + 1, static_cast<std::intmax_t>(xUB),
 105             static_cast<std::intmax_t>(yUB));
 106       }
 107       ub[j] = xUB;
 108     } else {
 109       ub[j] = (x.rank() ? x : y).GetDimension(j).Extent();
 110     }
 111     elements *= ub[j];
 112   }
 113   x.GetLowerBounds(xAt);
 114   y.GetLowerBounds(yAt);
 115   result.Establish(
 116       TypeCategory::Logical, 1, nullptr, rank, ub, CFI_attribute_allocatable);
 117   for (int j{0}; j < rank; ++j) {
 118     result.GetDimension(j).SetBounds(1, ub[j]);
 119   }
 120   if (result.Allocate() != CFI_SUCCESS) {
 121     terminator.Crash("Compare: could not allocate storage for result");
 122   }
 123   std::size_t xChars{x.ElementBytes() >> shift<CHAR>};
 124   std::size_t yChars{y.ElementBytes() >> shift<char>};
 125   for (SubscriptValue resultAt{0}; elements-- > 0;
 126        ++resultAt, x.IncrementSubscripts(xAt), y.IncrementSubscripts(yAt)) {
 127     *result.OffsetElement<char>(resultAt) = CharacterScalarCompare<CHAR>(
 128         x.Element<CHAR>(xAt), y.Element<CHAR>(yAt), xChars, yChars);
 129   }
 130 }
 131
 132 template <typename CHAR, bool ADJUSTR>
 133 static RT_API_ATTRS void Adjust(CHAR *to, const CHAR *from, std::size_t chars) {
 134   if constexpr (ADJUSTR) {
 135     std::size_t j{chars}, k{chars};
 136     for (; k > 0 && from[k - 1] == ' '; --k) {
 137     }
 138     while (k > 0) {
 139       to[--j] = from[--k];
 140     }
 141     while (j > 0) {
 142       to[--j] = ' ';
 143     }
 144   } else { // ADJUSTL
 145     std::size_t j{0}, k{0};
 146     for (; k < chars && from[k] == ' '; ++k) {
 147     }
 148     while (k < chars) {
 149       to[j++] = from[k++];
 150     }
 151     while (j < chars) {
 152       to[j++] = ' ';
 153     }
 154   }
 155 }
 156
 157 template <typename CHAR, bool ADJUSTR>
 158 static RT_API_ATTRS void AdjustLRHelper(Descriptor &result,
 159     const Descriptor &string, const Terminator &terminator) {
 160   int rank{string.rank()};
 161   SubscriptValue ub[maxRank], stringAt[maxRank];
 162   SubscriptValue elements{1};
 163   for (int j{0}; j < rank; ++j) {
 164     ub[j] = string.GetDimension(j).Extent();
 165     elements *= ub[j];
 166     stringAt[j] = 1;
 167   }
 168   string.GetLowerBounds(stringAt);
 169   std::size_t elementBytes{string.ElementBytes()};
 170   result.Establish(string.type(), elementBytes, nullptr, rank, ub,
 171       CFI_attribute_allocatable);
 172   for (int j{0}; j < rank; ++j) {
 173     result.GetDimension(j).SetBounds(1, ub[j]);
 174   }
 175   if (result.Allocate() != CFI_SUCCESS) {
 176     terminator.Crash("ADJUSTL/R: could not allocate storage for result");
 177   }
 178   for (SubscriptValue resultAt{0}; elements-- > 0;
 179        resultAt += elementBytes, string.IncrementSubscripts(stringAt)) {
 180     Adjust<CHAR, ADJUSTR>(result.OffsetElement<CHAR>(resultAt),
 181         string.Element<const CHAR>(stringAt), elementBytes >> shift<CHAR>);
 182   }
 183 }
 184
 185 template <bool ADJUSTR>
 186 RT_API_ATTRS void AdjustLR(Descriptor &result, const Descriptor &string,
 187     const char *sourceFile, int sourceLine) {
 188   Terminator terminator{sourceFile, sourceLine};
 189   switch (string.raw().type) {
 190   case CFI_type_char:
 191     AdjustLRHelper<char, ADJUSTR>(result, string, terminator);
 192     break;
 193   case CFI_type_char16_t:
 194     AdjustLRHelper<char16_t, ADJUSTR>(result, string, terminator);
 195     break;
 196   case CFI_type_char32_t:
 197     AdjustLRHelper<char32_t, ADJUSTR>(result, string, terminator);
 198     break;
 199   default:
 200     terminator.Crash("ADJUSTL/R: bad string type code %d",
 201         static_cast<int>(string.raw().type));
 202   }
 203 }
 204
 205 template <typename CHAR>
 206 inline RT_API_ATTRS std::size_t LenTrim(const CHAR *x, std::size_t chars) {
 207   while (chars > 0 && x[chars - 1] == ' ') {
 208     --chars;
 209   }
 210   return chars;
 211 }
 212
 213 template <typename INT, typename CHAR>
 214 static RT_API_ATTRS void LenTrim(Descriptor &result, const Descriptor &string,
 215     const Terminator &terminator) {
 216   int rank{string.rank()};
 217   SubscriptValue ub[maxRank], stringAt[maxRank];
 218   SubscriptValue elements{1};
 219   for (int j{0}; j < rank; ++j) {
 220     ub[j] = string.GetDimension(j).Extent();
 221     elements *= ub[j];
 222   }
 223   string.GetLowerBounds(stringAt);
 224   result.Establish(TypeCategory::Integer, sizeof(INT), nullptr, rank, ub,
 225       CFI_attribute_allocatable);
 226   for (int j{0}; j < rank; ++j) {
 227     result.GetDimension(j).SetBounds(1, ub[j]);
 228   }
 229   if (result.Allocate() != CFI_SUCCESS) {
 230     terminator.Crash("LEN_TRIM: could not allocate storage for result");
 231   }
 232   std::size_t stringElementChars{string.ElementBytes() >> shift<CHAR>};
 233   for (SubscriptValue resultAt{0}; elements-- > 0;
 234        resultAt += sizeof(INT), string.IncrementSubscripts(stringAt)) {
 235     *result.OffsetElement<INT>(resultAt) =
 236         LenTrim(string.Element<CHAR>(stringAt), stringElementChars);
 237   }
 238 }
 239
 240 template <typename CHAR>
 241 static RT_API_ATTRS void LenTrimKind(Descriptor &result,
 242     const Descriptor &string, int kind, const Terminator &terminator) {
 243   switch (kind) {
 244   case 1:
 245     LenTrim<CppTypeFor<TypeCategory::Integer, 1>, CHAR>(
 246         result, string, terminator);
 247     break;
 248   case 2:
 249     LenTrim<CppTypeFor<TypeCategory::Integer, 2>, CHAR>(
 250         result, string, terminator);
 251     break;
 252   case 4:
 253     LenTrim<CppTypeFor<TypeCategory::Integer, 4>, CHAR>(
 254         result, string, terminator);
 255     break;
 256   case 8:
 257     LenTrim<CppTypeFor<TypeCategory::Integer, 8>, CHAR>(
 258         result, string, terminator);
 259     break;
 260   case 16:
 261     LenTrim<CppTypeFor<TypeCategory::Integer, 16>, CHAR>(
 262         result, string, terminator);
 263     break;
 264   default:
 265     terminator.Crash(
 266         "not yet implemented: CHARACTER(KIND=%d) in LEN_TRIM intrinsic", kind);
 267   }
 268 }
 269
 270 // INDEX implementation
 271 template <typename CHAR>
 272 inline RT_API_ATTRS std::size_t Index(const CHAR *x, std::size_t xLen,
 273     const CHAR *want, std::size_t wantLen, bool back) {
 274   if (xLen < wantLen) {
 275     return 0;
 276   }
 277   if (xLen == 0) {
 278     return 1; // wantLen is also 0, so trivial match
 279   }
 280   if (back) {
 281     // If wantLen==0, returns xLen + 1 per standard (and all other compilers)
 282     std::size_t at{xLen - wantLen + 1};
 283     for (; at > 0; --at) {
 284       std::size_t j{1};
 285       for (; j <= wantLen; ++j) {
 286         if (x[at + j - 2] != want[j - 1]) {
 287           break;
 288         }
 289       }
 290       if (j > wantLen) {
 291         return at;
 292       }
 293     }
 294     return 0;
 295   }
 296   // Non-trivial forward substring search: use a simplified form of
 297   // Boyer-Moore substring searching.
 298   for (std::size_t at{1}; at + wantLen - 1 <= xLen;) {
 299     // Compare x(at:at+wantLen-1) with want(1:wantLen).
 300     // The comparison proceeds from the ends of the substrings forward
 301     // so that we can skip ahead by multiple positions on a miss.
 302     std::size_t j{wantLen};
 303     CHAR ch;
 304     for (; j > 0; --j) {
 305       ch = x[at + j - 2];
 306       if (ch != want[j - 1]) {
 307         break;
 308       }
 309     }
 310     if (j == 0) {
 311       return at; // found a match
 312     }
 313     // Suppose we have at==2:
 314     // "THAT FORTRAN THAT I RAN" <- the string (x) in which we search
 315     //   "THAT I RAN"            <- the string (want) for which we search
 316     //          ^------------------ j==7, ch=='T'
 317     // We can shift ahead 3 positions to at==5 to align the 'T's:
 318     // "THAT FORTRAN THAT I RAN"
 319     //      "THAT I RAN"
 320     std::size_t shift{1};
 321     for (; shift < j; ++shift) {
 322       if (want[j - shift - 1] == ch) {
 323         break;
 324       }
 325     }
 326     at += shift;
 327   }
 328   return 0;
 329 }
 330
 331 // SCAN and VERIFY implementation help.  These intrinsic functions
 332 // do pretty much the same thing, so they're templatized with a
 333 // distinguishing flag.
 334
 335 enum class CharFunc { Index, Scan, Verify };
 336
 337 template <typename CHAR, CharFunc FUNC>
 338 inline RT_API_ATTRS std::size_t ScanVerify(const CHAR *x, std::size_t xLen,
 339     const CHAR *set, std::size_t setLen, bool back) {
 340   std::size_t at{back ? xLen : 1};
 341   int increment{back ? -1 : 1};
 342   for (; xLen-- > 0; at += increment) {
 343     CHAR ch{x[at - 1]};
 344     bool inSet{false};
 345     // TODO: If set is sorted, could use binary search
 346     for (std::size_t j{0}; j < setLen; ++j) {
 347       if (set[j] == ch) {
 348         inSet = true;
 349         break;
 350       }
 351     }
 352     if (inSet != (FUNC == CharFunc::Verify)) {
 353       return at;
 354     }
 355   }
 356   return 0;
 357 }
 358
 359 // Specialization for one-byte characters
 360 template <bool IS_VERIFY = false>
 361 inline RT_API_ATTRS std::size_t ScanVerify(const char *x, std::size_t xLen,
 362     const char *set, std::size_t setLen, bool back) {
 363   std::size_t at{back ? xLen : 1};
 364   int increment{back ? -1 : 1};
 365   if (xLen > 0) {
 366     std::uint64_t bitSet[256 / 64]{0};
 367     std::uint64_t one{1};
 368     for (std::size_t j{0}; j < setLen; ++j) {
 369       unsigned setCh{static_cast<unsigned char>(set[j])};
 370       bitSet[setCh / 64] |= one << (setCh % 64);
 371     }
 372     for (; xLen-- > 0; at += increment) {
 373       unsigned ch{static_cast<unsigned char>(x[at - 1])};
 374       bool inSet{((bitSet[ch / 64] >> (ch % 64)) & 1) != 0};
 375       if (inSet != IS_VERIFY) {
 376         return at;
 377       }
 378     }
 379   }
 380   return 0;
 381 }
 382
 383 template <typename INT, typename CHAR, CharFunc FUNC>
 384 static RT_API_ATTRS void GeneralCharFunc(Descriptor &result,
 385     const Descriptor &string, const Descriptor &arg, const Descriptor *back,
 386     const Terminator &terminator) {
 387   int rank{string.rank() ? string.rank()
 388           : arg.rank()   ? arg.rank()
 389           : back         ? back->rank()
 390                          : 0};
 391   SubscriptValue ub[maxRank], stringAt[maxRank], argAt[maxRank],
 392       backAt[maxRank];
 393   SubscriptValue elements{1};
 394   for (int j{0}; j < rank; ++j) {
 395     ub[j] = string.rank() ? string.GetDimension(j).Extent()
 396         : arg.rank()      ? arg.GetDimension(j).Extent()
 397         : back            ? back->GetDimension(j).Extent()
 398                           : 1;
 399     elements *= ub[j];
 400   }
 401   string.GetLowerBounds(stringAt);
 402   arg.GetLowerBounds(argAt);
 403   if (back) {
 404     back->GetLowerBounds(backAt);
 405   }
 406   result.Establish(TypeCategory::Integer, sizeof(INT), nullptr, rank, ub,
 407       CFI_attribute_allocatable);
 408   for (int j{0}; j < rank; ++j) {
 409     result.GetDimension(j).SetBounds(1, ub[j]);
 410   }
 411   if (result.Allocate() != CFI_SUCCESS) {
 412     terminator.Crash("SCAN/VERIFY: could not allocate storage for result");
 413   }
 414   std::size_t stringElementChars{string.ElementBytes() >> shift<CHAR>};
 415   std::size_t argElementChars{arg.ElementBytes() >> shift<CHAR>};
 416   for (SubscriptValue resultAt{0}; elements-- > 0; resultAt += sizeof(INT),
 417        string.IncrementSubscripts(stringAt), arg.IncrementSubscripts(argAt),
 418        back && back->IncrementSubscripts(backAt)) {
 419     if constexpr (FUNC == CharFunc::Index) {
 420       *result.OffsetElement<INT>(resultAt) =
 421           Index<CHAR>(string.Element<CHAR>(stringAt), stringElementChars,
 422               arg.Element<CHAR>(argAt), argElementChars,
 423               back && IsLogicalElementTrue(*back, backAt));
 424     } else if constexpr (FUNC == CharFunc::Scan) {
 425       *result.OffsetElement<INT>(resultAt) =
 426           ScanVerify<CHAR, CharFunc::Scan>(string.Element<CHAR>(stringAt),
 427               stringElementChars, arg.Element<CHAR>(argAt), argElementChars,
 428               back && IsLogicalElementTrue(*back, backAt));
 429     } else if constexpr (FUNC == CharFunc::Verify) {
 430       *result.OffsetElement<INT>(resultAt) =
 431           ScanVerify<CHAR, CharFunc::Verify>(string.Element<CHAR>(stringAt),
 432               stringElementChars, arg.Element<CHAR>(argAt), argElementChars,
 433               back && IsLogicalElementTrue(*back, backAt));
 434     } else {
 435       static_assert(FUNC == CharFunc::Index || FUNC == CharFunc::Scan ||
 436           FUNC == CharFunc::Verify);
 437     }
 438   }
 439 }
 440
 441 template <typename CHAR, CharFunc FUNC>
 442 static RT_API_ATTRS void GeneralCharFuncKind(Descriptor &result,
 443     const Descriptor &string, const Descriptor &arg, const Descriptor *back,
 444     int kind, const Terminator &terminator) {
 445   switch (kind) {
 446   case 1:
 447     GeneralCharFunc<CppTypeFor<TypeCategory::Integer, 1>, CHAR, FUNC>(
 448         result, string, arg, back, terminator);
 449     break;
 450   case 2:
 451     GeneralCharFunc<CppTypeFor<TypeCategory::Integer, 2>, CHAR, FUNC>(
 452         result, string, arg, back, terminator);
 453     break;
 454   case 4:
 455     GeneralCharFunc<CppTypeFor<TypeCategory::Integer, 4>, CHAR, FUNC>(
 456         result, string, arg, back, terminator);
 457     break;
 458   case 8:
 459     GeneralCharFunc<CppTypeFor<TypeCategory::Integer, 8>, CHAR, FUNC>(
 460         result, string, arg, back, terminator);
 461     break;
 462   case 16:
 463     GeneralCharFunc<CppTypeFor<TypeCategory::Integer, 16>, CHAR, FUNC>(
 464         result, string, arg, back, terminator);
 465     break;
 466   default:
 467     terminator.Crash("not yet implemented: CHARACTER(KIND=%d) in "
 468                      "INDEX/SCAN/VERIFY intrinsic",
 469         kind);
 470   }
 471 }
 472
 473 template <typename CHAR, bool ISMIN>
 474 static RT_API_ATTRS void MaxMinHelper(Descriptor &accumulator,
 475     const Descriptor &x, const Terminator &terminator) {
 476   RUNTIME_CHECK(terminator,
 477       accumulator.rank() == 0 || x.rank() == 0 ||
 478           accumulator.rank() == x.rank());
 479   SubscriptValue ub[maxRank], xAt[maxRank];
 480   SubscriptValue elements{1};
 481   std::size_t accumChars{accumulator.ElementBytes() >> shift<CHAR>};
 482   std::size_t xChars{x.ElementBytes() >> shift<CHAR>};
 483   std::size_t chars{std::max(accumChars, xChars)};
 484   bool reallocate{accumulator.raw().base_addr == nullptr ||
 485       accumChars != chars || (accumulator.rank() == 0 && x.rank() > 0)};
 486   int rank{std::max(accumulator.rank(), x.rank())};
 487   for (int j{0}; j < rank; ++j) {
 488     if (x.rank() > 0) {
 489       ub[j] = x.GetDimension(j).Extent();
 490       if (accumulator.rank() > 0) {
 491         SubscriptValue accumExt{accumulator.GetDimension(j).Extent()};
 492         if (accumExt != ub[j]) {
 493           terminator.Crash("Character MAX/MIN: operands are not "
 494                            "conforming on dimension %d (%jd != %jd)",
 495               j + 1, static_cast<std::intmax_t>(accumExt),
 496               static_cast<std::intmax_t>(ub[j]));
 497         }
 498       }
 499     } else {
 500       ub[j] = accumulator.GetDimension(j).Extent();
 501     }
 502     elements *= ub[j];
 503   }
 504   x.GetLowerBounds(xAt);
 505   void *old{nullptr};
 506   const CHAR *accumData{accumulator.OffsetElement<CHAR>()};
 507   if (reallocate) {
 508     old = accumulator.raw().base_addr;
 509     accumulator.set_base_addr(nullptr);
 510     accumulator.raw().elem_len = chars << shift<CHAR>;
 511     for (int j{0}; j < rank; ++j) {
 512       accumulator.GetDimension(j).SetBounds(1, ub[j]);
 513     }
 514     RUNTIME_CHECK(terminator, accumulator.Allocate() == CFI_SUCCESS);
 515   }
 516   for (CHAR *result{accumulator.OffsetElement<CHAR>()}; elements-- > 0;
 517        accumData += accumChars, result += chars, x.IncrementSubscripts(xAt)) {
 518     const CHAR *xData{x.Element<CHAR>(xAt)};
 519     int cmp{CharacterScalarCompare(accumData, xData, accumChars, xChars)};
 520     if constexpr (ISMIN) {
 521       cmp = -cmp;
 522     }
 523     if (cmp < 0) {
 524       CopyAndPad(result, xData, chars, xChars);
 525     } else if (result != accumData) {
 526       CopyAndPad(result, accumData, chars, accumChars);
 527     }
 528   }
 529   FreeMemory(old);
 530 }
 531
 532 template <bool ISMIN>
 533 static RT_API_ATTRS void MaxMin(Descriptor &accumulator, const Descriptor &x,
 534     const char *sourceFile, int sourceLine) {
 535   Terminator terminator{sourceFile, sourceLine};
 536   RUNTIME_CHECK(terminator, accumulator.raw().type == x.raw().type);
 537   switch (accumulator.raw().type) {
 538   case CFI_type_char:
 539     MaxMinHelper<char, ISMIN>(accumulator, x, terminator);
 540     break;
 541   case CFI_type_char16_t:
 542     MaxMinHelper<char16_t, ISMIN>(accumulator, x, terminator);
 543     break;
 544   case CFI_type_char32_t:
 545     MaxMinHelper<char32_t, ISMIN>(accumulator, x, terminator);
 546     break;
 547   default:
 548     terminator.Crash(
 549         "Character MAX/MIN: result does not have a character type");
 550   }
 551 }
 552
 553 extern "C" {
 554 RT_EXT_API_GROUP_BEGIN
 555
 556 void RTDEF(CharacterConcatenate)(Descriptor &accumulator,
 557     const Descriptor &from, const char *sourceFile, int sourceLine) {
 558   Terminator terminator{sourceFile, sourceLine};
 559   RUNTIME_CHECK(terminator,
 560       accumulator.rank() == 0 || from.rank() == 0 ||
 561           accumulator.rank() == from.rank());
 562   int rank{std::max(accumulator.rank(), from.rank())};
 563   SubscriptValue ub[maxRank], fromAt[maxRank];
 564   SubscriptValue elements{1};
 565   for (int j{0}; j < rank; ++j) {
 566     if (accumulator.rank() > 0 && from.rank() > 0) {
 567       ub[j] = accumulator.GetDimension(j).Extent();
 568       SubscriptValue fromUB{from.GetDimension(j).Extent()};
 569       if (ub[j] != fromUB) {
 570         terminator.Crash("Character array concatenation: operands are not "
 571                          "conforming on dimension %d (%jd != %jd)",
 572             j + 1, static_cast<std::intmax_t>(ub[j]),
 573             static_cast<std::intmax_t>(fromUB));
 574       }
 575     } else {
 576       ub[j] =
 577           (accumulator.rank() ? accumulator : from).GetDimension(j).Extent();
 578     }
 579     elements *= ub[j];
 580   }
 581   std::size_t oldBytes{accumulator.ElementBytes()};
 582   void *old{accumulator.raw().base_addr};
 583   accumulator.set_base_addr(nullptr);
 584   std::size_t fromBytes{from.ElementBytes()};
 585   accumulator.raw().elem_len += fromBytes;
 586   std::size_t newBytes{accumulator.ElementBytes()};
 587   for (int j{0}; j < rank; ++j) {
 588     accumulator.GetDimension(j).SetBounds(1, ub[j]);
 589   }
 590   if (accumulator.Allocate() != CFI_SUCCESS) {
 591     terminator.Crash(
 592         "CharacterConcatenate: could not allocate storage for result");
 593   }
 594   const char *p{static_cast<const char *>(old)};
 595   char *to{static_cast<char *>(accumulator.raw().base_addr)};
 596   from.GetLowerBounds(fromAt);
 597   for (; elements-- > 0;
 598        to += newBytes, p += oldBytes, from.IncrementSubscripts(fromAt)) {
 599     std::memcpy(to, p, oldBytes);
 600     std::memcpy(to + oldBytes, from.Element<char>(fromAt), fromBytes);
 601   }
 602   FreeMemory(old);
 603 }
 604
 605 void RTDEF(CharacterConcatenateScalar1)(
 606     Descriptor &accumulator, const char *from, std::size_t chars) {
 607   Terminator terminator{__FILE__, __LINE__};
 608   RUNTIME_CHECK(terminator, accumulator.rank() == 0);
 609   void *old{accumulator.raw().base_addr};
 610   accumulator.set_base_addr(nullptr);
 611   std::size_t oldLen{accumulator.ElementBytes()};
 612   accumulator.raw().elem_len += chars;
 613   RUNTIME_CHECK(terminator, accumulator.Allocate() == CFI_SUCCESS);
 614   std::memcpy(accumulator.OffsetElement<char>(oldLen), from, chars);
 615   FreeMemory(old);
 616 }
 617
 618 int RTDEF(CharacterCompareScalar)(const Descriptor &x, const Descriptor &y) {
 619   Terminator terminator{__FILE__, __LINE__};
 620   RUNTIME_CHECK(terminator, x.rank() == 0);
 621   RUNTIME_CHECK(terminator, y.rank() == 0);
 622   RUNTIME_CHECK(terminator, x.raw().type == y.raw().type);
 623   switch (x.raw().type) {
 624   case CFI_type_char:
 625     return CharacterScalarCompare<char>(x.OffsetElement<char>(),
 626         y.OffsetElement<char>(), x.ElementBytes(), y.ElementBytes());
 627   case CFI_type_char16_t:
 628     return CharacterScalarCompare<char16_t>(x.OffsetElement<char16_t>(),
 629         y.OffsetElement<char16_t>(), x.ElementBytes() >> 1,
 630         y.ElementBytes() >> 1);
 631   case CFI_type_char32_t:
 632     return CharacterScalarCompare<char32_t>(x.OffsetElement<char32_t>(),
 633         y.OffsetElement<char32_t>(), x.ElementBytes() >> 2,
 634         y.ElementBytes() >> 2);
 635   default:
 636     terminator.Crash("CharacterCompareScalar: bad string type code %d",
 637         static_cast<int>(x.raw().type));
 638   }
 639   return 0;
 640 }
 641
 642 int RTDEF(CharacterCompareScalar1)(
 643     const char *x, const char *y, std::size_t xChars, std::size_t yChars) {
 644   return CharacterScalarCompare(x, y, xChars, yChars);
 645 }
 646
 647 int RTDEF(CharacterCompareScalar2)(const char16_t *x, const char16_t *y,
 648     std::size_t xChars, std::size_t yChars) {
 649   return CharacterScalarCompare(x, y, xChars, yChars);
 650 }
 651
 652 int RTDEF(CharacterCompareScalar4)(const char32_t *x, const char32_t *y,
 653     std::size_t xChars, std::size_t yChars) {
 654   return CharacterScalarCompare(x, y, xChars, yChars);
 655 }
 656
 657 void RTDEF(CharacterCompare)(
 658     Descriptor &result, const Descriptor &x, const Descriptor &y) {
 659   Terminator terminator{__FILE__, __LINE__};
 660   RUNTIME_CHECK(terminator, x.raw().type == y.raw().type);
 661   switch (x.raw().type) {
 662   case CFI_type_char:
 663     Compare<char>(result, x, y, terminator);
 664     break;
 665   case CFI_type_char16_t:
 666     Compare<char16_t>(result, x, y, terminator);
 667     break;
 668   case CFI_type_char32_t:
 669     Compare<char32_t>(result, x, y, terminator);
 670     break;
 671   default:
 672     terminator.Crash("CharacterCompareScalar: bad string type code %d",
 673         static_cast<int>(x.raw().type));
 674   }
 675 }
 676
 677 std::size_t RTDEF(CharacterAppend1)(char *lhs, std::size_t lhsBytes,
 678     std::size_t offset, const char *rhs, std::size_t rhsBytes) {
 679   if (auto n{std::min(lhsBytes - offset, rhsBytes)}) {
 680     std::memcpy(lhs + offset, rhs, n);
 681     offset += n;
 682   }
 683   return offset;
 684 }
 685
 686 void RTDEF(CharacterPad1)(char *lhs, std::size_t bytes, std::size_t offset) {
 687   if (bytes > offset) {
 688     std::memset(lhs + offset, ' ', bytes - offset);
 689   }
 690 }
 691
 692 // Intrinsic function entry points
 693
 694 void RTDEF(Adjustl)(Descriptor &result, const Descriptor &string,
 695     const char *sourceFile, int sourceLine) {
 696   AdjustLR<false>(result, string, sourceFile, sourceLine);
 697 }
 698
 699 void RTDEF(Adjustr)(Descriptor &result, const Descriptor &string,
 700     const char *sourceFile, int sourceLine) {
 701   AdjustLR<true>(result, string, sourceFile, sourceLine);
 702 }
 703
 704 std::size_t RTDEF(Index1)(const char *x, std::size_t xLen, const char *set,
 705     std::size_t setLen, bool back) {
 706   return Index<char>(x, xLen, set, setLen, back);
 707 }
 708 std::size_t RTDEF(Index2)(const char16_t *x, std::size_t xLen,
 709     const char16_t *set, std::size_t setLen, bool back) {
 710   return Index<char16_t>(x, xLen, set, setLen, back);
 711 }
 712 std::size_t RTDEF(Index4)(const char32_t *x, std::size_t xLen,
 713     const char32_t *set, std::size_t setLen, bool back) {
 714   return Index<char32_t>(x, xLen, set, setLen, back);
 715 }
 716
 717 void RTDEF(Index)(Descriptor &result, const Descriptor &string,
 718     const Descriptor &substring, const Descriptor *back, int kind,
 719     const char *sourceFile, int sourceLine) {
 720   Terminator terminator{sourceFile, sourceLine};
 721   switch (string.raw().type) {
 722   case CFI_type_char:
 723     GeneralCharFuncKind<char, CharFunc::Index>(
 724         result, string, substring, back, kind, terminator);
 725     break;
 726   case CFI_type_char16_t:
 727     GeneralCharFuncKind<char16_t, CharFunc::Index>(
 728         result, string, substring, back, kind, terminator);
 729     break;
 730   case CFI_type_char32_t:
 731     GeneralCharFuncKind<char32_t, CharFunc::Index>(
 732         result, string, substring, back, kind, terminator);
 733     break;
 734   default:
 735     terminator.Crash(
 736         "INDEX: bad string type code %d", static_cast<int>(string.raw().type));
 737   }
 738 }
 739
 740 std::size_t RTDEF(LenTrim1)(const char *x, std::size_t chars) {
 741   return LenTrim(x, chars);
 742 }
 743 std::size_t RTDEF(LenTrim2)(const char16_t *x, std::size_t chars) {
 744   return LenTrim(x, chars);
 745 }
 746 std::size_t RTDEF(LenTrim4)(const char32_t *x, std::size_t chars) {
 747   return LenTrim(x, chars);
 748 }
 749
 750 void RTDEF(LenTrim)(Descriptor &result, const Descriptor &string, int kind,
 751     const char *sourceFile, int sourceLine) {
 752   Terminator terminator{sourceFile, sourceLine};
 753   switch (string.raw().type) {
 754   case CFI_type_char:
 755     LenTrimKind<char>(result, string, kind, terminator);
 756     break;
 757   case CFI_type_char16_t:
 758     LenTrimKind<char16_t>(result, string, kind, terminator);
 759     break;
 760   case CFI_type_char32_t:
 761     LenTrimKind<char32_t>(result, string, kind, terminator);
 762     break;
 763   default:
 764     terminator.Crash("LEN_TRIM: bad string type code %d",
 765         static_cast<int>(string.raw().type));
 766   }
 767 }
 768
 769 std::size_t RTDEF(Scan1)(const char *x, std::size_t xLen, const char *set,
 770     std::size_t setLen, bool back) {
 771   return ScanVerify<char, CharFunc::Scan>(x, xLen, set, setLen, back);
 772 }
 773 std::size_t RTDEF(Scan2)(const char16_t *x, std::size_t xLen,
 774     const char16_t *set, std::size_t setLen, bool back) {
 775   return ScanVerify<char16_t, CharFunc::Scan>(x, xLen, set, setLen, back);
 776 }
 777 std::size_t RTDEF(Scan4)(const char32_t *x, std::size_t xLen,
 778     const char32_t *set, std::size_t setLen, bool back) {
 779   return ScanVerify<char32_t, CharFunc::Scan>(x, xLen, set, setLen, back);
 780 }
 781
 782 void RTDEF(Scan)(Descriptor &result, const Descriptor &string,
 783     const Descriptor &set, const Descriptor *back, int kind,
 784     const char *sourceFile, int sourceLine) {
 785   Terminator terminator{sourceFile, sourceLine};
 786   switch (string.raw().type) {
 787   case CFI_type_char:
 788     GeneralCharFuncKind<char, CharFunc::Scan>(
 789         result, string, set, back, kind, terminator);
 790     break;
 791   case CFI_type_char16_t:
 792     GeneralCharFuncKind<char16_t, CharFunc::Scan>(
 793         result, string, set, back, kind, terminator);
 794     break;
 795   case CFI_type_char32_t:
 796     GeneralCharFuncKind<char32_t, CharFunc::Scan>(
 797         result, string, set, back, kind, terminator);
 798     break;
 799   default:
 800     terminator.Crash(
 801         "SCAN: bad string type code %d", static_cast<int>(string.raw().type));
 802   }
 803 }
 804
 805 void RTDEF(Repeat)(Descriptor &result, const Descriptor &string,
 806     std::int64_t ncopies, const char *sourceFile, int sourceLine) {
 807   Terminator terminator{sourceFile, sourceLine};
 808   if (ncopies < 0) {
 809     terminator.Crash(
 810         "REPEAT has negative NCOPIES=%jd", static_cast<std::intmax_t>(ncopies));
 811   }
 812   std::size_t origBytes{string.ElementBytes()};
 813   result.Establish(string.type(), origBytes * ncopies, nullptr, 0, nullptr,
 814       CFI_attribute_allocatable);
 815   if (result.Allocate() != CFI_SUCCESS) {
 816     terminator.Crash("REPEAT could not allocate storage for result");
 817   }
 818   const char *from{string.OffsetElement()};
 819   for (char *to{result.OffsetElement()}; ncopies-- > 0; to += origBytes) {
 820     std::memcpy(to, from, origBytes);
 821   }
 822 }
 823
 824 void RTDEF(Trim)(Descriptor &result, const Descriptor &string,
 825     const char *sourceFile, int sourceLine) {
 826   Terminator terminator{sourceFile, sourceLine};
 827   std::size_t resultBytes{0};
 828   switch (string.raw().type) {
 829   case CFI_type_char:
 830     resultBytes =
 831         LenTrim(string.OffsetElement<const char>(), string.ElementBytes());
 832     break;
 833   case CFI_type_char16_t:
 834     resultBytes = LenTrim(string.OffsetElement<const char16_t>(),
 835                       string.ElementBytes() >> 1)
 836         << 1;
 837     break;
 838   case CFI_type_char32_t:
 839     resultBytes = LenTrim(string.OffsetElement<const char32_t>(),
 840                       string.ElementBytes() >> 2)
 841         << 2;
 842     break;
 843   default:
 844     terminator.Crash(
 845         "TRIM: bad string type code %d", static_cast<int>(string.raw().type));
 846   }
 847   result.Establish(string.type(), resultBytes, nullptr, 0, nullptr,
 848       CFI_attribute_allocatable);
 849   RUNTIME_CHECK(terminator, result.Allocate() == CFI_SUCCESS);
 850   std::memcpy(result.OffsetElement(), string.OffsetElement(), resultBytes);
 851 }
 852
 853 std::size_t RTDEF(Verify1)(const char *x, std::size_t xLen, const char *set,
 854     std::size_t setLen, bool back) {
 855   return ScanVerify<char, CharFunc::Verify>(x, xLen, set, setLen, back);
 856 }
 857 std::size_t RTDEF(Verify2)(const char16_t *x, std::size_t xLen,
 858     const char16_t *set, std::size_t setLen, bool back) {
 859   return ScanVerify<char16_t, CharFunc::Verify>(x, xLen, set, setLen, back);
 860 }
 861 std::size_t RTDEF(Verify4)(const char32_t *x, std::size_t xLen,
 862     const char32_t *set, std::size_t setLen, bool back) {
 863   return ScanVerify<char32_t, CharFunc::Verify>(x, xLen, set, setLen, back);
 864 }
 865
 866 void RTDEF(Verify)(Descriptor &result, const Descriptor &string,
 867     const Descriptor &set, const Descriptor *back, int kind,
 868     const char *sourceFile, int sourceLine) {
 869   Terminator terminator{sourceFile, sourceLine};
 870   switch (string.raw().type) {
 871   case CFI_type_char:
 872     GeneralCharFuncKind<char, CharFunc::Verify>(
 873         result, string, set, back, kind, terminator);
 874     break;
 875   case CFI_type_char16_t:
 876     GeneralCharFuncKind<char16_t, CharFunc::Verify>(
 877         result, string, set, back, kind, terminator);
 878     break;
 879   case CFI_type_char32_t:
 880     GeneralCharFuncKind<char32_t, CharFunc::Verify>(
 881         result, string, set, back, kind, terminator);
 882     break;
 883   default:
 884     terminator.Crash(
 885         "VERIFY: bad string type code %d", static_cast<int>(string.raw().type));
 886   }
 887 }
 888
 889 void RTDEF(CharacterMax)(Descriptor &accumulator, const Descriptor &x,
 890     const char *sourceFile, int sourceLine) {
 891   MaxMin<false>(accumulator, x, sourceFile, sourceLine);
 892 }
 893
 894 void RTDEF(CharacterMin)(Descriptor &accumulator, const Descriptor &x,
 895     const char *sourceFile, int sourceLine) {
 896   MaxMin<true>(accumulator, x, sourceFile, sourceLine);
 897 }
 898
 899 RT_EXT_API_GROUP_END
 900 }
 901 } // namespace Fortran::runtime