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