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
20namespace Fortran::runtime {
21
22template <typename CHAR>
23inline 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
39RT_OFFLOAD_API_GROUP_BEGIN
40
41template <typename CHAR>
42RT_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
75template RT_API_ATTRS int CharacterScalarCompare<char>(
76 const char *x, const char *y, std::size_t xChars, std::size_t yChars);
77template RT_API_ATTRS int CharacterScalarCompare<char16_t>(const char16_t *x,
78 const char16_t *y, std::size_t xChars, std::size_t yChars);
79template 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
82RT_OFFLOAD_API_GROUP_END
83
84// Shift count to use when converting between character lengths
85// and byte counts.
86template <typename CHAR>
87constexpr int shift{common::TrailingZeroBitCount(sizeof(CHAR))};
88
89template <typename CHAR>
90static 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
132template <typename CHAR, bool ADJUSTR>
133static 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
157template <typename CHAR, bool ADJUSTR>
158static 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
185template <bool ADJUSTR>
186RT_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
205template <typename CHAR>
206inline 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
213template <typename INT, typename CHAR>
214static 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
240template <typename CHAR>
241static 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
271template <typename CHAR>
272inline 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
335enum class CharFunc { Index, Scan, Verify };
336
337template <typename CHAR, CharFunc FUNC>
338inline 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
360template <bool IS_VERIFY = false>
361inline 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
383template <typename INT, typename CHAR, CharFunc FUNC>
384static 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
441template <typename CHAR, CharFunc FUNC>
442static 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
473template <typename CHAR, bool ISMIN>
474static 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(a: accumChars, b: 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
532template <bool ISMIN>
533static 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
553extern "C" {
554RT_EXT_API_GROUP_BEGIN
555
556void 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(dest: to, src: p, n: oldBytes);
600 std::memcpy(to + oldBytes, from.Element<char>(fromAt), fromBytes);
601 }
602 FreeMemory(old);
603}
604
605void 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
618int 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
642int 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
647int 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
652int 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
657void 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
677std::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
686void 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
694void RTDEF(Adjustl)(Descriptor &result, const Descriptor &string,
695 const char *sourceFile, int sourceLine) {
696 AdjustLR<false>(result, string, sourceFile, sourceLine);
697}
698
699void RTDEF(Adjustr)(Descriptor &result, const Descriptor &string,
700 const char *sourceFile, int sourceLine) {
701 AdjustLR<true>(result, string, sourceFile, sourceLine);
702}
703
704std::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}
708std::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}
712std::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
717void 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
740std::size_t RTDEF(LenTrim1)(const char *x, std::size_t chars) {
741 return LenTrim(x, chars);
742}
743std::size_t RTDEF(LenTrim2)(const char16_t *x, std::size_t chars) {
744 return LenTrim(x, chars);
745}
746std::size_t RTDEF(LenTrim4)(const char32_t *x, std::size_t chars) {
747 return LenTrim(x, chars);
748}
749
750void 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
769std::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}
773std::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}
777std::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
782void 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
805void 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
824void 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
853std::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}
857std::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}
861std::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
866void 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
889void RTDEF(CharacterMax)(Descriptor &accumulator, const Descriptor &x,
890 const char *sourceFile, int sourceLine) {
891 MaxMin<false>(accumulator, x, sourceFile, sourceLine);
892}
893
894void RTDEF(CharacterMin)(Descriptor &accumulator, const Descriptor &x,
895 const char *sourceFile, int sourceLine) {
896 MaxMin<true>(accumulator, x, sourceFile, sourceLine);
897}
898
899RT_EXT_API_GROUP_END
900}
901} // namespace Fortran::runtime
902

source code of flang/runtime/character.cpp