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