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-exception
6//
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_BEGIN
41
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 machines
48 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_END
84
85// Shift count to use when converting between character lengths
86// 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 { // ADJUSTL
146 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 implementation
272template <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 match
280 }
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 of
316 // 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 forward
320 // 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 match
331 }
332 // Suppose we have at==2:
333 // "THAT FORTRAN THAT I RAN" <- the string (x) in which we search
334 // "THAT I RAN" <- the string (want) for which we search
335 // ^------------------ 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 functions
351// do pretty much the same thing, so they're templatized with a
352// 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 search
365 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 characters
379template <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("SCAN/VERIFY: could not allocate storage for result");
432 }
433 std::size_t stringElementChars{string.ElementBytes() >> shift<CHAR>};
434 std::size_t argElementChars{arg.ElementBytes() >> shift<CHAR>};
435 for (SubscriptValue resultAt{0}; elements-- > 0; resultAt += sizeof(INT),
436 string.IncrementSubscripts(stringAt), arg.IncrementSubscripts(argAt),
437 back && back->IncrementSubscripts(backAt)) {
438 if constexpr (FUNC == CharFunc::Index) {
439 *result.OffsetElement<INT>(resultAt) =
440 Index<CHAR>(string.Element<CHAR>(stringAt), stringElementChars,
441 arg.Element<CHAR>(argAt), argElementChars,
442 back && IsLogicalElementTrue(*back, backAt));
443 } else if constexpr (FUNC == CharFunc::Scan) {
444 *result.OffsetElement<INT>(resultAt) =
445 ScanVerify<CHAR, CharFunc::Scan>(string.Element<CHAR>(stringAt),
446 stringElementChars, arg.Element<CHAR>(argAt), argElementChars,
447 back && IsLogicalElementTrue(*back, backAt));
448 } else if constexpr (FUNC == CharFunc::Verify) {
449 *result.OffsetElement<INT>(resultAt) =
450 ScanVerify<CHAR, CharFunc::Verify>(string.Element<CHAR>(stringAt),
451 stringElementChars, arg.Element<CHAR>(argAt), argElementChars,
452 back && IsLogicalElementTrue(*back, backAt));
453 } else {
454 static_assert(FUNC == CharFunc::Index || FUNC == CharFunc::Scan ||
455 FUNC == CharFunc::Verify);
456 }
457 }
458}
459
460template <typename CHAR, CharFunc FUNC>
461static RT_API_ATTRS void GeneralCharFuncKind(Descriptor &result,
462 const Descriptor &string, const Descriptor &arg, const Descriptor *back,
463 int kind, const Terminator &terminator) {
464 switch (kind) {
465 case 1:
466 GeneralCharFunc<CppTypeFor<TypeCategory::Integer, 1>, CHAR, FUNC>(
467 result, string, arg, back, terminator);
468 break;
469 case 2:
470 GeneralCharFunc<CppTypeFor<TypeCategory::Integer, 2>, CHAR, FUNC>(
471 result, string, arg, back, terminator);
472 break;
473 case 4:
474 GeneralCharFunc<CppTypeFor<TypeCategory::Integer, 4>, CHAR, FUNC>(
475 result, string, arg, back, terminator);
476 break;
477 case 8:
478 GeneralCharFunc<CppTypeFor<TypeCategory::Integer, 8>, CHAR, FUNC>(
479 result, string, arg, back, terminator);
480 break;
481 case 16:
482 GeneralCharFunc<CppTypeFor<TypeCategory::Integer, 16>, CHAR, FUNC>(
483 result, string, arg, back, terminator);
484 break;
485 default:
486 terminator.Crash("not yet implemented: CHARACTER(KIND=%d) in "
487 "INDEX/SCAN/VERIFY intrinsic",
488 kind);
489 }
490}
491
492template <typename CHAR, bool ISMIN>
493static RT_API_ATTRS void MaxMinHelper(Descriptor &accumulator,
494 const Descriptor &x, const Terminator &terminator) {
495 RUNTIME_CHECK(terminator,
496 accumulator.rank() == 0 || x.rank() == 0 ||
497 accumulator.rank() == x.rank());
498 SubscriptValue ub[maxRank], xAt[maxRank];
499 SubscriptValue elements{1};
500 std::size_t accumChars{accumulator.ElementBytes() >> shift<CHAR>};
501 std::size_t xChars{x.ElementBytes() >> shift<CHAR>};
502 std::size_t chars{std::max(a: accumChars, b: xChars)};
503 bool reallocate{accumulator.raw().base_addr == nullptr ||
504 accumChars != chars || (accumulator.rank() == 0 && x.rank() > 0)};
505 int rank{std::max(accumulator.rank(), x.rank())};
506 for (int j{0}; j < rank; ++j) {
507 if (x.rank() > 0) {
508 ub[j] = x.GetDimension(j).Extent();
509 if (accumulator.rank() > 0) {
510 SubscriptValue accumExt{accumulator.GetDimension(j).Extent()};
511 if (accumExt != ub[j]) {
512 terminator.Crash("Character MAX/MIN: operands are not "
513 "conforming on dimension %d (%jd != %jd)",
514 j + 1, static_cast<std::intmax_t>(accumExt),
515 static_cast<std::intmax_t>(ub[j]));
516 }
517 }
518 } else {
519 ub[j] = accumulator.GetDimension(j).Extent();
520 }
521 elements *= ub[j];
522 }
523 x.GetLowerBounds(xAt);
524 void *old{nullptr};
525 const CHAR *accumData{accumulator.OffsetElement<CHAR>()};
526 if (reallocate) {
527 old = accumulator.raw().base_addr;
528 accumulator.set_base_addr(nullptr);
529 accumulator.raw().elem_len = chars << shift<CHAR>;
530 for (int j{0}; j < rank; ++j) {
531 accumulator.GetDimension(j).SetBounds(1, ub[j]);
532 }
533 RUNTIME_CHECK(
534 terminator, accumulator.Allocate(kNoAsyncObject) == CFI_SUCCESS);
535 }
536 for (CHAR *result{accumulator.OffsetElement<CHAR>()}; elements-- > 0;
537 accumData += accumChars, result += chars, x.IncrementSubscripts(xAt)) {
538 const CHAR *xData{x.Element<CHAR>(xAt)};
539 int cmp{CharacterScalarCompare(accumData, xData, accumChars, xChars)};
540 if constexpr (ISMIN) {
541 cmp = -cmp;
542 }
543 if (cmp < 0) {
544 CopyAndPad(result, xData, chars, xChars);
545 } else if (result != accumData) {
546 CopyAndPad(result, accumData, chars, accumChars);
547 }
548 }
549 FreeMemory(old);
550}
551
552template <bool ISMIN>
553static RT_API_ATTRS void MaxMin(Descriptor &accumulator, const Descriptor &x,
554 const char *sourceFile, int sourceLine) {
555 Terminator terminator{sourceFile, sourceLine};
556 RUNTIME_CHECK(terminator, accumulator.raw().type == x.raw().type);
557 switch (accumulator.raw().type) {
558 case CFI_type_char:
559 MaxMinHelper<char, ISMIN>(accumulator, x, terminator);
560 break;
561 case CFI_type_char16_t:
562 MaxMinHelper<char16_t, ISMIN>(accumulator, x, terminator);
563 break;
564 case CFI_type_char32_t:
565 MaxMinHelper<char32_t, ISMIN>(accumulator, x, terminator);
566 break;
567 default:
568 terminator.Crash(
569 "Character MAX/MIN: result does not have a character type");
570 }
571}
572
573extern "C" {
574RT_EXT_API_GROUP_BEGIN
575
576void RTDEF(CharacterConcatenate)(Descriptor &accumulator,
577 const Descriptor &from, const char *sourceFile, int sourceLine) {
578 Terminator terminator{sourceFile, sourceLine};
579 RUNTIME_CHECK(terminator,
580 accumulator.rank() == 0 || from.rank() == 0 ||
581 accumulator.rank() == from.rank());
582 int rank{std::max(accumulator.rank(), from.rank())};
583 SubscriptValue ub[maxRank], fromAt[maxRank];
584 SubscriptValue elements{1};
585 for (int j{0}; j < rank; ++j) {
586 if (accumulator.rank() > 0 && from.rank() > 0) {
587 ub[j] = accumulator.GetDimension(j).Extent();
588 SubscriptValue fromUB{from.GetDimension(j).Extent()};
589 if (ub[j] != fromUB) {
590 terminator.Crash("Character array concatenation: operands are not "
591 "conforming on dimension %d (%jd != %jd)",
592 j + 1, static_cast<std::intmax_t>(ub[j]),
593 static_cast<std::intmax_t>(fromUB));
594 }
595 } else {
596 ub[j] =
597 (accumulator.rank() ? accumulator : from).GetDimension(j).Extent();
598 }
599 elements *= ub[j];
600 }
601 std::size_t oldBytes{accumulator.ElementBytes()};
602 void *old{accumulator.raw().base_addr};
603 accumulator.set_base_addr(nullptr);
604 std::size_t fromBytes{from.ElementBytes()};
605 accumulator.raw().elem_len += fromBytes;
606 std::size_t newBytes{accumulator.ElementBytes()};
607 for (int j{0}; j < rank; ++j) {
608 accumulator.GetDimension(j).SetBounds(1, ub[j]);
609 }
610 if (accumulator.Allocate(kNoAsyncObject) != CFI_SUCCESS) {
611 terminator.Crash(
612 "CharacterConcatenate: could not allocate storage for result");
613 }
614 const char *p{static_cast<const char *>(old)};
615 char *to{static_cast<char *>(accumulator.raw().base_addr)};
616 from.GetLowerBounds(fromAt);
617 for (; elements-- > 0;
618 to += newBytes, p += oldBytes, from.IncrementSubscripts(fromAt)) {
619 std::memcpy(dest: to, src: p, n: oldBytes);
620 std::memcpy(to + oldBytes, from.Element<char>(fromAt), fromBytes);
621 }
622 FreeMemory(old);
623}
624
625void RTDEF(CharacterConcatenateScalar1)(
626 Descriptor &accumulator, const char *from, std::size_t chars) {
627 Terminator terminator{__FILE__, __LINE__};
628 RUNTIME_CHECK(terminator, accumulator.rank() == 0);
629 void *old{accumulator.raw().base_addr};
630 accumulator.set_base_addr(nullptr);
631 std::size_t oldLen{accumulator.ElementBytes()};
632 accumulator.raw().elem_len += chars;
633 RUNTIME_CHECK(
634 terminator, accumulator.Allocate(kNoAsyncObject) == CFI_SUCCESS);
635 std::memcpy(accumulator.OffsetElement<char>(oldLen), from, chars);
636 FreeMemory(old);
637}
638
639int RTDEF(CharacterCompareScalar)(const Descriptor &x, const Descriptor &y) {
640 Terminator terminator{__FILE__, __LINE__};
641 RUNTIME_CHECK(terminator, x.rank() == 0);
642 RUNTIME_CHECK(terminator, y.rank() == 0);
643 RUNTIME_CHECK(terminator, x.raw().type == y.raw().type);
644 switch (x.raw().type) {
645 case CFI_type_char:
646 return CharacterScalarCompare<char>(x.OffsetElement<char>(),
647 y.OffsetElement<char>(), x.ElementBytes(), y.ElementBytes());
648 case CFI_type_char16_t:
649 return CharacterScalarCompare<char16_t>(x.OffsetElement<char16_t>(),
650 y.OffsetElement<char16_t>(), x.ElementBytes() >> 1,
651 y.ElementBytes() >> 1);
652 case CFI_type_char32_t:
653 return CharacterScalarCompare<char32_t>(x.OffsetElement<char32_t>(),
654 y.OffsetElement<char32_t>(), x.ElementBytes() >> 2,
655 y.ElementBytes() >> 2);
656 default:
657 terminator.Crash("CharacterCompareScalar: bad string type code %d",
658 static_cast<int>(x.raw().type));
659 }
660 return 0;
661}
662
663int RTDEF(CharacterCompareScalar1)(
664 const char *x, const char *y, std::size_t xChars, std::size_t yChars) {
665 return CharacterScalarCompare(x, y, xChars, yChars);
666}
667
668int RTDEF(CharacterCompareScalar2)(const char16_t *x, const char16_t *y,
669 std::size_t xChars, std::size_t yChars) {
670 return CharacterScalarCompare(x, y, xChars, yChars);
671}
672
673int RTDEF(CharacterCompareScalar4)(const char32_t *x, const char32_t *y,
674 std::size_t xChars, std::size_t yChars) {
675 return CharacterScalarCompare(x, y, xChars, yChars);
676}
677
678void RTDEF(CharacterCompare)(
679 Descriptor &result, const Descriptor &x, const Descriptor &y) {
680 Terminator terminator{__FILE__, __LINE__};
681 RUNTIME_CHECK(terminator, x.raw().type == y.raw().type);
682 switch (x.raw().type) {
683 case CFI_type_char:
684 Compare<char>(result, x, y, terminator);
685 break;
686 case CFI_type_char16_t:
687 Compare<char16_t>(result, x, y, terminator);
688 break;
689 case CFI_type_char32_t:
690 Compare<char32_t>(result, x, y, terminator);
691 break;
692 default:
693 terminator.Crash("CharacterCompareScalar: bad string type code %d",
694 static_cast<int>(x.raw().type));
695 }
696}
697
698std::size_t RTDEF(CharacterAppend1)(char *lhs, std::size_t lhsBytes,
699 std::size_t offset, const char *rhs, std::size_t rhsBytes) {
700 if (auto n{std::min(lhsBytes - offset, rhsBytes)}) {
701 std::memcpy(lhs + offset, rhs, n);
702 offset += n;
703 }
704 return offset;
705}
706
707void RTDEF(CharacterPad1)(char *lhs, std::size_t bytes, std::size_t offset) {
708 if (bytes > offset) {
709 std::memset(lhs + offset, ' ', bytes - offset);
710 }
711}
712
713// Intrinsic function entry points
714
715void RTDEF(Adjustl)(Descriptor &result, const Descriptor &string,
716 const char *sourceFile, int sourceLine) {
717 AdjustLR<false>(result, string, sourceFile, sourceLine);
718}
719
720void RTDEF(Adjustr)(Descriptor &result, const Descriptor &string,
721 const char *sourceFile, int sourceLine) {
722 AdjustLR<true>(result, string, sourceFile, sourceLine);
723}
724
725std::size_t RTDEF(Index1)(const char *x, std::size_t xLen, const char *set,
726 std::size_t setLen, bool back) {
727 return Index<char>(x, xLen, set, setLen, back);
728}
729std::size_t RTDEF(Index2)(const char16_t *x, std::size_t xLen,
730 const char16_t *set, std::size_t setLen, bool back) {
731 return Index<char16_t>(x, xLen, set, setLen, back);
732}
733std::size_t RTDEF(Index4)(const char32_t *x, std::size_t xLen,
734 const char32_t *set, std::size_t setLen, bool back) {
735 return Index<char32_t>(x, xLen, set, setLen, back);
736}
737
738void RTDEF(Index)(Descriptor &result, const Descriptor &string,
739 const Descriptor &substring, const Descriptor *back, int kind,
740 const char *sourceFile, int sourceLine) {
741 Terminator terminator{sourceFile, sourceLine};
742 switch (string.raw().type) {
743 case CFI_type_char:
744 GeneralCharFuncKind<char, CharFunc::Index>(
745 result, string, substring, back, kind, terminator);
746 break;
747 case CFI_type_char16_t:
748 GeneralCharFuncKind<char16_t, CharFunc::Index>(
749 result, string, substring, back, kind, terminator);
750 break;
751 case CFI_type_char32_t:
752 GeneralCharFuncKind<char32_t, CharFunc::Index>(
753 result, string, substring, back, kind, terminator);
754 break;
755 default:
756 terminator.Crash(
757 "INDEX: bad string type code %d", static_cast<int>(string.raw().type));
758 }
759}
760
761std::size_t RTDEF(LenTrim1)(const char *x, std::size_t chars) {
762 return LenTrim(x, chars);
763}
764std::size_t RTDEF(LenTrim2)(const char16_t *x, std::size_t chars) {
765 return LenTrim(x, chars);
766}
767std::size_t RTDEF(LenTrim4)(const char32_t *x, std::size_t chars) {
768 return LenTrim(x, chars);
769}
770
771void RTDEF(LenTrim)(Descriptor &result, const Descriptor &string, int kind,
772 const char *sourceFile, int sourceLine) {
773 Terminator terminator{sourceFile, sourceLine};
774 switch (string.raw().type) {
775 case CFI_type_char:
776 LenTrimKind<char>(result, string, kind, terminator);
777 break;
778 case CFI_type_char16_t:
779 LenTrimKind<char16_t>(result, string, kind, terminator);
780 break;
781 case CFI_type_char32_t:
782 LenTrimKind<char32_t>(result, string, kind, terminator);
783 break;
784 default:
785 terminator.Crash("LEN_TRIM: bad string type code %d",
786 static_cast<int>(string.raw().type));
787 }
788}
789
790std::size_t RTDEF(Scan1)(const char *x, std::size_t xLen, const char *set,
791 std::size_t setLen, bool back) {
792 return ScanVerify<char, CharFunc::Scan>(x, xLen, set, setLen, back);
793}
794std::size_t RTDEF(Scan2)(const char16_t *x, std::size_t xLen,
795 const char16_t *set, std::size_t setLen, bool back) {
796 return ScanVerify<char16_t, CharFunc::Scan>(x, xLen, set, setLen, back);
797}
798std::size_t RTDEF(Scan4)(const char32_t *x, std::size_t xLen,
799 const char32_t *set, std::size_t setLen, bool back) {
800 return ScanVerify<char32_t, CharFunc::Scan>(x, xLen, set, setLen, back);
801}
802
803void RTDEF(Scan)(Descriptor &result, const Descriptor &string,
804 const Descriptor &set, const Descriptor *back, int kind,
805 const char *sourceFile, int sourceLine) {
806 Terminator terminator{sourceFile, sourceLine};
807 switch (string.raw().type) {
808 case CFI_type_char:
809 GeneralCharFuncKind<char, CharFunc::Scan>(
810 result, string, set, back, kind, terminator);
811 break;
812 case CFI_type_char16_t:
813 GeneralCharFuncKind<char16_t, CharFunc::Scan>(
814 result, string, set, back, kind, terminator);
815 break;
816 case CFI_type_char32_t:
817 GeneralCharFuncKind<char32_t, CharFunc::Scan>(
818 result, string, set, back, kind, terminator);
819 break;
820 default:
821 terminator.Crash(
822 "SCAN: bad string type code %d", static_cast<int>(string.raw().type));
823 }
824}
825
826void RTDEF(Repeat)(Descriptor &result, const Descriptor &string,
827 std::int64_t ncopies, const char *sourceFile, int sourceLine) {
828 Terminator terminator{sourceFile, sourceLine};
829 if (ncopies < 0) {
830 terminator.Crash(
831 "REPEAT has negative NCOPIES=%jd", static_cast<std::intmax_t>(ncopies));
832 }
833 std::size_t origBytes{string.ElementBytes()};
834 result.Establish(string.type(), origBytes * ncopies, nullptr, 0, nullptr,
835 CFI_attribute_allocatable);
836 if (result.Allocate(kNoAsyncObject) != CFI_SUCCESS) {
837 terminator.Crash("REPEAT could not allocate storage for result");
838 }
839 const char *from{string.OffsetElement()};
840 for (char *to{result.OffsetElement()}; ncopies-- > 0; to += origBytes) {
841 std::memcpy(to, from, origBytes);
842 }
843}
844
845void RTDEF(Trim)(Descriptor &result, const Descriptor &string,
846 const char *sourceFile, int sourceLine) {
847 Terminator terminator{sourceFile, sourceLine};
848 std::size_t resultBytes{0};
849 switch (string.raw().type) {
850 case CFI_type_char:
851 resultBytes =
852 LenTrim(string.OffsetElement<const char>(), string.ElementBytes());
853 break;
854 case CFI_type_char16_t:
855 resultBytes = LenTrim(string.OffsetElement<const char16_t>(),
856 string.ElementBytes() >> 1)
857 << 1;
858 break;
859 case CFI_type_char32_t:
860 resultBytes = LenTrim(string.OffsetElement<const char32_t>(),
861 string.ElementBytes() >> 2)
862 << 2;
863 break;
864 default:
865 terminator.Crash(
866 "TRIM: bad string type code %d", static_cast<int>(string.raw().type));
867 }
868 result.Establish(string.type(), resultBytes, nullptr, 0, nullptr,
869 CFI_attribute_allocatable);
870 RUNTIME_CHECK(terminator, result.Allocate(kNoAsyncObject) == CFI_SUCCESS);
871 std::memcpy(result.OffsetElement(), string.OffsetElement(), resultBytes);
872}
873
874std::size_t RTDEF(Verify1)(const char *x, std::size_t xLen, const char *set,
875 std::size_t setLen, bool back) {
876 return ScanVerify<char, CharFunc::Verify>(x, xLen, set, setLen, back);
877}
878std::size_t RTDEF(Verify2)(const char16_t *x, std::size_t xLen,
879 const char16_t *set, std::size_t setLen, bool back) {
880 return ScanVerify<char16_t, CharFunc::Verify>(x, xLen, set, setLen, back);
881}
882std::size_t RTDEF(Verify4)(const char32_t *x, std::size_t xLen,
883 const char32_t *set, std::size_t setLen, bool back) {
884 return ScanVerify<char32_t, CharFunc::Verify>(x, xLen, set, setLen, back);
885}
886
887void RTDEF(Verify)(Descriptor &result, const Descriptor &string,
888 const Descriptor &set, const Descriptor *back, int kind,
889 const char *sourceFile, int sourceLine) {
890 Terminator terminator{sourceFile, sourceLine};
891 switch (string.raw().type) {
892 case CFI_type_char:
893 GeneralCharFuncKind<char, CharFunc::Verify>(
894 result, string, set, back, kind, terminator);
895 break;
896 case CFI_type_char16_t:
897 GeneralCharFuncKind<char16_t, CharFunc::Verify>(
898 result, string, set, back, kind, terminator);
899 break;
900 case CFI_type_char32_t:
901 GeneralCharFuncKind<char32_t, CharFunc::Verify>(
902 result, string, set, back, kind, terminator);
903 break;
904 default:
905 terminator.Crash(
906 "VERIFY: bad string type code %d", static_cast<int>(string.raw().type));
907 }
908}
909
910void RTDEF(CharacterMax)(Descriptor &accumulator, const Descriptor &x,
911 const char *sourceFile, int sourceLine) {
912 MaxMin<false>(accumulator, x, sourceFile, sourceLine);
913}
914
915void RTDEF(CharacterMin)(Descriptor &accumulator, const Descriptor &x,
916 const char *sourceFile, int sourceLine) {
917 MaxMin<true>(accumulator, x, sourceFile, sourceLine);
918}
919
920RT_EXT_API_GROUP_END
921}
922} // namespace Fortran::runtime
923

source code of flang-rt/lib/runtime/character.cpp