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 // Utility for dealing with elemental LOGICAL arguments
239 static bool IsLogicalElementTrue(
240     const Descriptor &logical, const SubscriptValue at[]) {
241   // A LOGICAL value is false if and only if all of its bytes are zero.
242   const char *p{logical.Element<char>(at)};
243   for (std::size_t j{logical.ElementBytes()}; j-- > 0; ++p) {
244     if (*p) {
245       return true;
246     }
247   }
248   return false;
249 }
250 
251 // INDEX implementation
252 template <typename CHAR>
253 inline std::size_t Index(const CHAR *x, std::size_t xLen, const CHAR *want,
254     std::size_t wantLen, bool back) {
255   if (xLen < wantLen) {
256     return 0;
257   }
258   if (xLen == 0) {
259     return 1; // wantLen is also 0, so trivial match
260   }
261   if (back) {
262     // If wantLen==0, returns xLen + 1 per standard (and all other compilers)
263     std::size_t at{xLen - wantLen + 1};
264     for (; at > 0; --at) {
265       std::size_t j{1};
266       for (; j <= wantLen; ++j) {
267         if (x[at + j - 2] != want[j - 1]) {
268           break;
269         }
270       }
271       if (j > wantLen) {
272         return at;
273       }
274     }
275     return 0;
276   }
277   // Non-trivial forward substring search: use a simplified form of
278   // Boyer-Moore substring searching.
279   for (std::size_t at{1}; at + wantLen - 1 <= xLen;) {
280     // Compare x(at:at+wantLen-1) with want(1:wantLen).
281     // The comparison proceeds from the ends of the substrings forward
282     // so that we can skip ahead by multiple positions on a miss.
283     std::size_t j{wantLen};
284     CHAR ch;
285     for (; j > 0; --j) {
286       ch = x[at + j - 2];
287       if (ch != want[j - 1]) {
288         break;
289       }
290     }
291     if (j == 0) {
292       return at; // found a match
293     }
294     // Suppose we have at==2:
295     // "THAT FORTRAN THAT I RAN" <- the string (x) in which we search
296     //   "THAT I RAN"            <- the string (want) for which we search
297     //          ^------------------ j==7, ch=='T'
298     // We can shift ahead 3 positions to at==5 to align the 'T's:
299     // "THAT FORTRAN THAT I RAN"
300     //      "THAT I RAN"
301     std::size_t shift{1};
302     for (; shift < j; ++shift) {
303       if (want[j - shift - 1] == ch) {
304         break;
305       }
306     }
307     at += shift;
308   }
309   return 0;
310 }
311 
312 // SCAN and VERIFY implementation help.  These intrinsic functions
313 // do pretty much the same thing, so they're templatized with a
314 // distinguishing flag.
315 
316 enum class CharFunc { Index, Scan, Verify };
317 
318 template <typename CHAR, CharFunc FUNC>
319 inline std::size_t ScanVerify(const CHAR *x, std::size_t xLen, const CHAR *set,
320     std::size_t setLen, bool back) {
321   std::size_t at{back ? xLen : 1};
322   int increment{back ? -1 : 1};
323   for (; xLen-- > 0; at += increment) {
324     CHAR ch{x[at - 1]};
325     bool inSet{false};
326     // TODO: If set is sorted, could use binary search
327     for (std::size_t j{0}; j < setLen; ++j) {
328       if (set[j] == ch) {
329         inSet = true;
330         break;
331       }
332     }
333     if (inSet != (FUNC == CharFunc::Verify)) {
334       return at;
335     }
336   }
337   return 0;
338 }
339 
340 // Specialization for one-byte characters
341 template <bool IS_VERIFY = false>
342 inline std::size_t ScanVerify(const char *x, std::size_t xLen, const char *set,
343     std::size_t setLen, bool back) {
344   std::size_t at{back ? xLen : 1};
345   int increment{back ? -1 : 1};
346   if (xLen > 0) {
347     std::uint64_t bitSet[256 / 64]{0};
348     std::uint64_t one{1};
349     for (std::size_t j{0}; j < setLen; ++j) {
350       unsigned setCh{static_cast<unsigned char>(set[j])};
351       bitSet[setCh / 64] |= one << (setCh % 64);
352     }
353     for (; xLen-- > 0; at += increment) {
354       unsigned ch{static_cast<unsigned char>(x[at - 1])};
355       bool inSet{((bitSet[ch / 64] >> (ch % 64)) & 1) != 0};
356       if (inSet != IS_VERIFY) {
357         return at;
358       }
359     }
360   }
361   return 0;
362 }
363 
364 template <typename INT, typename CHAR, CharFunc FUNC>
365 static void GeneralCharFunc(Descriptor &result, const Descriptor &string,
366     const Descriptor &arg, const Descriptor *back,
367     const Terminator &terminator) {
368   int rank{string.rank() ? string.rank()
369           : arg.rank()   ? arg.rank()
370           : back         ? back->rank()
371                          : 0};
372   SubscriptValue lb[maxRank], ub[maxRank], stringAt[maxRank], argAt[maxRank],
373       backAt[maxRank];
374   SubscriptValue elements{1};
375   for (int j{0}; j < rank; ++j) {
376     lb[j] = 1;
377     ub[j] = string.rank() ? string.GetDimension(j).Extent()
378         : arg.rank()      ? arg.GetDimension(j).Extent()
379         : back            ? back->GetDimension(j).Extent()
380                           : 1;
381     elements *= ub[j];
382     stringAt[j] = argAt[j] = backAt[j] = 1;
383   }
384   result.Establish(TypeCategory::Integer, sizeof(INT), nullptr, rank, ub,
385       CFI_attribute_allocatable);
386   if (result.Allocate(lb, ub) != CFI_SUCCESS) {
387     terminator.Crash("SCAN/VERIFY: could not allocate storage for result");
388   }
389   std::size_t stringElementChars{string.ElementBytes() >> shift<CHAR>};
390   std::size_t argElementChars{arg.ElementBytes() >> shift<CHAR>};
391   for (SubscriptValue resultAt{0}; elements-- > 0; resultAt += sizeof(INT),
392        string.IncrementSubscripts(stringAt), arg.IncrementSubscripts(argAt),
393        back && back->IncrementSubscripts(backAt)) {
394     if constexpr (FUNC == CharFunc::Index) {
395       *result.OffsetElement<INT>(resultAt) =
396           Index<CHAR>(string.Element<CHAR>(stringAt), stringElementChars,
397               arg.Element<CHAR>(argAt), argElementChars,
398               back && IsLogicalElementTrue(*back, backAt));
399     } else if constexpr (FUNC == CharFunc::Scan) {
400       *result.OffsetElement<INT>(resultAt) =
401           ScanVerify<CHAR, CharFunc::Scan>(string.Element<CHAR>(stringAt),
402               stringElementChars, arg.Element<CHAR>(argAt), argElementChars,
403               back && IsLogicalElementTrue(*back, backAt));
404     } else if constexpr (FUNC == CharFunc::Verify) {
405       *result.OffsetElement<INT>(resultAt) =
406           ScanVerify<CHAR, CharFunc::Verify>(string.Element<CHAR>(stringAt),
407               stringElementChars, arg.Element<CHAR>(argAt), argElementChars,
408               back && IsLogicalElementTrue(*back, backAt));
409     } else {
410       static_assert(FUNC == CharFunc::Index || FUNC == CharFunc::Scan ||
411           FUNC == CharFunc::Verify);
412     }
413   }
414 }
415 
416 template <typename CHAR, CharFunc FUNC>
417 static void GeneralCharFuncKind(Descriptor &result, const Descriptor &string,
418     const Descriptor &arg, const Descriptor *back, int kind,
419     const Terminator &terminator) {
420   switch (kind) {
421   case 1:
422     GeneralCharFunc<std::int8_t, CHAR, FUNC>(
423         result, string, arg, back, terminator);
424     break;
425   case 2:
426     GeneralCharFunc<std::int16_t, CHAR, FUNC>(
427         result, string, arg, back, terminator);
428     break;
429   case 4:
430     GeneralCharFunc<std::int32_t, CHAR, FUNC>(
431         result, string, arg, back, terminator);
432     break;
433   case 8:
434     GeneralCharFunc<std::int64_t, CHAR, FUNC>(
435         result, string, arg, back, terminator);
436     break;
437   case 16:
438     GeneralCharFunc<common::uint128_t, CHAR, FUNC>(
439         result, string, arg, back, terminator);
440     break;
441   default:
442     terminator.Crash("INDEX/SCAN/VERIFY: bad KIND=%d", kind);
443   }
444 }
445 
446 template <typename TO, typename FROM>
447 static void CopyAndPad(
448     TO *to, const FROM *from, std::size_t toChars, std::size_t fromChars) {
449   if constexpr (sizeof(TO) != sizeof(FROM)) {
450     std::size_t copyChars{std::min(toChars, fromChars)};
451     for (std::size_t j{0}; j < copyChars; ++j) {
452       to[j] = from[j];
453     }
454     for (std::size_t j{copyChars}; j < toChars; ++j) {
455       to[j] = static_cast<TO>(' ');
456     }
457   } else if (toChars <= fromChars) {
458     std::memcpy(to, from, toChars * shift<TO>);
459   } else {
460     std::memcpy(to, from, fromChars * shift<TO>);
461     for (std::size_t j{fromChars}; j < toChars; ++j) {
462       to[j] = static_cast<TO>(' ');
463     }
464   }
465 }
466 
467 template <typename CHAR, bool ISMIN>
468 static void MaxMinHelper(Descriptor &accumulator, const Descriptor &x,
469     const Terminator &terminator) {
470   RUNTIME_CHECK(terminator,
471       accumulator.rank() == 0 || x.rank() == 0 ||
472           accumulator.rank() == x.rank());
473   SubscriptValue lb[maxRank], ub[maxRank], xAt[maxRank];
474   SubscriptValue elements{1};
475   std::size_t accumChars{accumulator.ElementBytes() >> shift<CHAR>};
476   std::size_t xChars{x.ElementBytes() >> shift<CHAR>};
477   std::size_t chars{std::max(accumChars, xChars)};
478   bool reallocate{accumulator.raw().base_addr == nullptr ||
479       accumChars != xChars || (accumulator.rank() == 0 && x.rank() > 0)};
480   int rank{std::max(accumulator.rank(), x.rank())};
481   for (int j{0}; j < rank; ++j) {
482     lb[j] = 1;
483     if (x.rank() > 0) {
484       ub[j] = x.GetDimension(j).Extent();
485       xAt[j] = x.GetDimension(j).LowerBound();
486       if (accumulator.rank() > 0) {
487         SubscriptValue accumExt{accumulator.GetDimension(j).Extent()};
488         if (accumExt != ub[j]) {
489           terminator.Crash("Character MAX/MIN: operands are not "
490                            "conforming on dimension %d (%jd != %jd)",
491               j + 1, static_cast<std::intmax_t>(accumExt),
492               static_cast<std::intmax_t>(ub[j]));
493         }
494       }
495     } else {
496       ub[j] = accumulator.GetDimension(j).Extent();
497       xAt[j] = 1;
498     }
499     elements *= ub[j];
500   }
501   void *old{nullptr};
502   const CHAR *accumData{accumulator.OffsetElement<CHAR>()};
503   if (reallocate) {
504     old = accumulator.raw().base_addr;
505     accumulator.set_base_addr(nullptr);
506     accumulator.raw().elem_len = chars << shift<CHAR>;
507     RUNTIME_CHECK(terminator, accumulator.Allocate(lb, ub) == CFI_SUCCESS);
508   }
509   for (CHAR *result{accumulator.OffsetElement<CHAR>()}; elements-- > 0;
510        accumData += accumChars, result += chars, x.IncrementSubscripts(xAt)) {
511     const CHAR *xData{x.Element<CHAR>(xAt)};
512     int cmp{Compare(accumData, xData, accumChars, xChars)};
513     if constexpr (ISMIN) {
514       cmp = -cmp;
515     }
516     if (cmp < 0) {
517       CopyAndPad(result, xData, chars, xChars);
518     } else if (result != accumData) {
519       CopyAndPad(result, accumData, chars, accumChars);
520     }
521   }
522   FreeMemory(old);
523 }
524 
525 template <bool ISMIN>
526 static void MaxMin(Descriptor &accumulator, const Descriptor &x,
527     const char *sourceFile, int sourceLine) {
528   Terminator terminator{sourceFile, sourceLine};
529   RUNTIME_CHECK(terminator, accumulator.raw().type == x.raw().type);
530   switch (accumulator.raw().type) {
531   case CFI_type_char:
532     MaxMinHelper<char, ISMIN>(accumulator, x, terminator);
533     break;
534   case CFI_type_char16_t:
535     MaxMinHelper<char16_t, ISMIN>(accumulator, x, terminator);
536     break;
537   case CFI_type_char32_t:
538     MaxMinHelper<char32_t, ISMIN>(accumulator, x, terminator);
539     break;
540   default:
541     terminator.Crash(
542         "Character MAX/MIN: result does not have a character type");
543   }
544 }
545 
546 extern "C" {
547 
548 void RTNAME(CharacterConcatenate)(Descriptor &accumulator,
549     const Descriptor &from, const char *sourceFile, int sourceLine) {
550   Terminator terminator{sourceFile, sourceLine};
551   RUNTIME_CHECK(terminator,
552       accumulator.rank() == 0 || from.rank() == 0 ||
553           accumulator.rank() == from.rank());
554   int rank{std::max(accumulator.rank(), from.rank())};
555   SubscriptValue lb[maxRank], ub[maxRank], fromAt[maxRank];
556   SubscriptValue elements{1};
557   for (int j{0}; j < rank; ++j) {
558     lb[j] = 1;
559     if (accumulator.rank() > 0 && from.rank() > 0) {
560       ub[j] = accumulator.GetDimension(j).Extent();
561       SubscriptValue fromUB{from.GetDimension(j).Extent()};
562       if (ub[j] != fromUB) {
563         terminator.Crash("Character array concatenation: operands are not "
564                          "conforming on dimension %d (%jd != %jd)",
565             j + 1, static_cast<std::intmax_t>(ub[j]),
566             static_cast<std::intmax_t>(fromUB));
567       }
568     } else {
569       ub[j] =
570           (accumulator.rank() ? accumulator : from).GetDimension(j).Extent();
571     }
572     elements *= ub[j];
573     fromAt[j] = 1;
574   }
575   std::size_t oldBytes{accumulator.ElementBytes()};
576   void *old{accumulator.raw().base_addr};
577   accumulator.set_base_addr(nullptr);
578   std::size_t fromBytes{from.ElementBytes()};
579   accumulator.raw().elem_len += fromBytes;
580   std::size_t newBytes{accumulator.ElementBytes()};
581   if (accumulator.Allocate(lb, ub) != CFI_SUCCESS) {
582     terminator.Crash(
583         "CharacterConcatenate: could not allocate storage for result");
584   }
585   const char *p{static_cast<const char *>(old)};
586   char *to{static_cast<char *>(accumulator.raw().base_addr)};
587   for (; elements-- > 0;
588        to += newBytes, p += oldBytes, from.IncrementSubscripts(fromAt)) {
589     std::memcpy(to, p, oldBytes);
590     std::memcpy(to + oldBytes, from.Element<char>(fromAt), fromBytes);
591   }
592   FreeMemory(old);
593 }
594 
595 void RTNAME(CharacterConcatenateScalar1)(
596     Descriptor &accumulator, const char *from, std::size_t chars) {
597   Terminator terminator{__FILE__, __LINE__};
598   RUNTIME_CHECK(terminator, accumulator.rank() == 0);
599   void *old{accumulator.raw().base_addr};
600   accumulator.set_base_addr(nullptr);
601   std::size_t oldLen{accumulator.ElementBytes()};
602   accumulator.raw().elem_len += chars;
603   RUNTIME_CHECK(
604       terminator, accumulator.Allocate(nullptr, nullptr) == CFI_SUCCESS);
605   std::memcpy(accumulator.OffsetElement<char>(oldLen), from, chars);
606   FreeMemory(old);
607 }
608 
609 void RTNAME(CharacterAssign)(Descriptor &lhs, const Descriptor &rhs,
610     const char *sourceFile, int sourceLine) {
611   Terminator terminator{sourceFile, sourceLine};
612   int rank{lhs.rank()};
613   RUNTIME_CHECK(terminator, rhs.rank() == 0 || rhs.rank() == rank);
614   SubscriptValue ub[maxRank], lhsAt[maxRank], rhsAt[maxRank];
615   SubscriptValue elements{1};
616   std::size_t lhsBytes{lhs.ElementBytes()};
617   std::size_t rhsBytes{rhs.ElementBytes()};
618   bool reallocate{lhs.IsAllocatable() &&
619       (lhs.raw().base_addr == nullptr || lhsBytes != rhsBytes)};
620   for (int j{0}; j < rank; ++j) {
621     lhsAt[j] = lhs.GetDimension(j).LowerBound();
622     if (rhs.rank() > 0) {
623       SubscriptValue lhsExt{lhs.GetDimension(j).Extent()};
624       SubscriptValue rhsExt{rhs.GetDimension(j).Extent()};
625       ub[j] = lhsAt[j] + rhsExt - 1;
626       if (lhsExt != rhsExt) {
627         if (lhs.IsAllocatable()) {
628           reallocate = true;
629         } else {
630           terminator.Crash("Character array assignment: operands are not "
631                            "conforming on dimension %d (%jd != %jd)",
632               j + 1, static_cast<std::intmax_t>(lhsExt),
633               static_cast<std::intmax_t>(rhsExt));
634         }
635       }
636       rhsAt[j] = rhs.GetDimension(j).LowerBound();
637     } else {
638       ub[j] = lhs.GetDimension(j).UpperBound();
639     }
640     elements *= ub[j] - lhsAt[j] + 1;
641   }
642   void *old{nullptr};
643   if (reallocate) {
644     old = lhs.raw().base_addr;
645     lhs.set_base_addr(nullptr);
646     lhs.raw().elem_len = lhsBytes = rhsBytes;
647     if (rhs.rank() > 0) {
648       // When the RHS is not scalar, the LHS acquires its bounds.
649       for (int j{0}; j < rank; ++j) {
650         lhsAt[j] = rhsAt[j];
651         ub[j] = rhs.GetDimension(j).UpperBound();
652       }
653     }
654     RUNTIME_CHECK(terminator, lhs.Allocate(lhsAt, ub) == CFI_SUCCESS);
655   }
656   switch (lhs.raw().type) {
657   case CFI_type_char:
658     switch (rhs.raw().type) {
659     case CFI_type_char:
660       for (; elements-- > 0;
661            lhs.IncrementSubscripts(lhsAt), rhs.IncrementSubscripts(rhsAt)) {
662         CopyAndPad(lhs.Element<char>(lhsAt), rhs.Element<char>(rhsAt), lhsBytes,
663             rhsBytes);
664       }
665       break;
666     case CFI_type_char16_t:
667       for (; elements-- > 0;
668            lhs.IncrementSubscripts(lhsAt), rhs.IncrementSubscripts(rhsAt)) {
669         CopyAndPad(lhs.Element<char>(lhsAt), rhs.Element<char16_t>(rhsAt),
670             lhsBytes, rhsBytes >> 1);
671       }
672       break;
673     case CFI_type_char32_t:
674       for (; elements-- > 0;
675            lhs.IncrementSubscripts(lhsAt), rhs.IncrementSubscripts(rhsAt)) {
676         CopyAndPad(lhs.Element<char>(lhsAt), rhs.Element<char32_t>(rhsAt),
677             lhsBytes, rhsBytes >> 2);
678       }
679       break;
680     default:
681       terminator.Crash(
682           "RHS of character assignment does not have a character type");
683     }
684     break;
685   case CFI_type_char16_t:
686     switch (rhs.raw().type) {
687     case CFI_type_char:
688       for (; elements-- > 0;
689            lhs.IncrementSubscripts(lhsAt), rhs.IncrementSubscripts(rhsAt)) {
690         CopyAndPad(lhs.Element<char16_t>(lhsAt), rhs.Element<char>(rhsAt),
691             lhsBytes >> 1, rhsBytes);
692       }
693       break;
694     case CFI_type_char16_t:
695       for (; elements-- > 0;
696            lhs.IncrementSubscripts(lhsAt), rhs.IncrementSubscripts(rhsAt)) {
697         CopyAndPad(lhs.Element<char16_t>(lhsAt), rhs.Element<char16_t>(rhsAt),
698             lhsBytes >> 1, rhsBytes >> 1);
699       }
700       break;
701     case CFI_type_char32_t:
702       for (; elements-- > 0;
703            lhs.IncrementSubscripts(lhsAt), rhs.IncrementSubscripts(rhsAt)) {
704         CopyAndPad(lhs.Element<char16_t>(lhsAt), rhs.Element<char32_t>(rhsAt),
705             lhsBytes >> 1, rhsBytes >> 2);
706       }
707       break;
708     default:
709       terminator.Crash(
710           "RHS of character assignment does not have a character type");
711     }
712     break;
713   case CFI_type_char32_t:
714     switch (rhs.raw().type) {
715     case CFI_type_char:
716       for (; elements-- > 0;
717            lhs.IncrementSubscripts(lhsAt), rhs.IncrementSubscripts(rhsAt)) {
718         CopyAndPad(lhs.Element<char32_t>(lhsAt), rhs.Element<char>(rhsAt),
719             lhsBytes >> 2, rhsBytes);
720       }
721       break;
722     case CFI_type_char16_t:
723       for (; elements-- > 0;
724            lhs.IncrementSubscripts(lhsAt), rhs.IncrementSubscripts(rhsAt)) {
725         CopyAndPad(lhs.Element<char32_t>(lhsAt), rhs.Element<char16_t>(rhsAt),
726             lhsBytes >> 2, rhsBytes >> 1);
727       }
728       break;
729     case CFI_type_char32_t:
730       for (; elements-- > 0;
731            lhs.IncrementSubscripts(lhsAt), rhs.IncrementSubscripts(rhsAt)) {
732         CopyAndPad(lhs.Element<char32_t>(lhsAt), rhs.Element<char32_t>(rhsAt),
733             lhsBytes >> 2, rhsBytes >> 2);
734       }
735       break;
736     default:
737       terminator.Crash(
738           "RHS of character assignment does not have a character type");
739     }
740     break;
741   default:
742     terminator.Crash(
743         "LHS of character assignment does not have a character type");
744   }
745   if (reallocate) {
746     FreeMemory(old);
747   }
748 }
749 
750 int RTNAME(CharacterCompareScalar)(const Descriptor &x, const Descriptor &y) {
751   Terminator terminator{__FILE__, __LINE__};
752   RUNTIME_CHECK(terminator, x.rank() == 0);
753   RUNTIME_CHECK(terminator, y.rank() == 0);
754   RUNTIME_CHECK(terminator, x.raw().type == y.raw().type);
755   switch (x.raw().type) {
756   case CFI_type_char:
757     return Compare(x.OffsetElement<char>(), y.OffsetElement<char>(),
758         x.ElementBytes(), y.ElementBytes());
759   case CFI_type_char16_t:
760     return Compare(x.OffsetElement<char16_t>(), y.OffsetElement<char16_t>(),
761         x.ElementBytes() >> 1, y.ElementBytes() >> 1);
762   case CFI_type_char32_t:
763     return Compare(x.OffsetElement<char32_t>(), y.OffsetElement<char32_t>(),
764         x.ElementBytes() >> 2, y.ElementBytes() >> 2);
765   default:
766     terminator.Crash("CharacterCompareScalar: bad string type code %d",
767         static_cast<int>(x.raw().type));
768   }
769   return 0;
770 }
771 
772 int RTNAME(CharacterCompareScalar1)(
773     const char *x, const char *y, std::size_t xChars, std::size_t yChars) {
774   return Compare(x, y, xChars, yChars);
775 }
776 
777 int RTNAME(CharacterCompareScalar2)(const char16_t *x, const char16_t *y,
778     std::size_t xChars, std::size_t yChars) {
779   return Compare(x, y, xChars, yChars);
780 }
781 
782 int RTNAME(CharacterCompareScalar4)(const char32_t *x, const char32_t *y,
783     std::size_t xChars, std::size_t yChars) {
784   return Compare(x, y, xChars, yChars);
785 }
786 
787 void RTNAME(CharacterCompare)(
788     Descriptor &result, const Descriptor &x, const Descriptor &y) {
789   Terminator terminator{__FILE__, __LINE__};
790   RUNTIME_CHECK(terminator, x.raw().type == y.raw().type);
791   switch (x.raw().type) {
792   case CFI_type_char:
793     Compare<char>(result, x, y, terminator);
794     break;
795   case CFI_type_char16_t:
796     Compare<char16_t>(result, x, y, terminator);
797     break;
798   case CFI_type_char32_t:
799     Compare<char32_t>(result, x, y, terminator);
800     break;
801   default:
802     terminator.Crash("CharacterCompareScalar: bad string type code %d",
803         static_cast<int>(x.raw().type));
804   }
805 }
806 
807 std::size_t RTNAME(CharacterAppend1)(char *lhs, std::size_t lhsBytes,
808     std::size_t offset, const char *rhs, std::size_t rhsBytes) {
809   if (auto n{std::min(lhsBytes - offset, rhsBytes)}) {
810     std::memcpy(lhs + offset, rhs, n);
811     offset += n;
812   }
813   return offset;
814 }
815 
816 void RTNAME(CharacterPad1)(char *lhs, std::size_t bytes, std::size_t offset) {
817   if (bytes > offset) {
818     std::memset(lhs + offset, ' ', bytes - offset);
819   }
820 }
821 
822 // Intrinsic function entry points
823 
824 void RTNAME(AdjustL)(Descriptor &result, const Descriptor &string,
825     const char *sourceFile, int sourceLine) {
826   AdjustLR<false>(result, string, sourceFile, sourceLine);
827 }
828 
829 void RTNAME(AdjustR)(Descriptor &result, const Descriptor &string,
830     const char *sourceFile, int sourceLine) {
831   AdjustLR<true>(result, string, sourceFile, sourceLine);
832 }
833 
834 std::size_t RTNAME(Index1)(const char *x, std::size_t xLen, const char *set,
835     std::size_t setLen, bool back) {
836   return Index<char>(x, xLen, set, setLen, back);
837 }
838 std::size_t RTNAME(Index2)(const char16_t *x, std::size_t xLen,
839     const char16_t *set, std::size_t setLen, bool back) {
840   return Index<char16_t>(x, xLen, set, setLen, back);
841 }
842 std::size_t RTNAME(Index4)(const char32_t *x, std::size_t xLen,
843     const char32_t *set, std::size_t setLen, bool back) {
844   return Index<char32_t>(x, xLen, set, setLen, back);
845 }
846 
847 void RTNAME(Index)(Descriptor &result, const Descriptor &string,
848     const Descriptor &substring, const Descriptor *back, int kind,
849     const char *sourceFile, int sourceLine) {
850   Terminator terminator{sourceFile, sourceLine};
851   switch (string.raw().type) {
852   case CFI_type_char:
853     GeneralCharFuncKind<char, CharFunc::Index>(
854         result, string, substring, back, kind, terminator);
855     break;
856   case CFI_type_char16_t:
857     GeneralCharFuncKind<char16_t, CharFunc::Index>(
858         result, string, substring, back, kind, terminator);
859     break;
860   case CFI_type_char32_t:
861     GeneralCharFuncKind<char32_t, CharFunc::Index>(
862         result, string, substring, back, kind, terminator);
863     break;
864   default:
865     terminator.Crash(
866         "INDEX: bad string type code %d", static_cast<int>(string.raw().type));
867   }
868 }
869 
870 std::size_t RTNAME(LenTrim1)(const char *x, std::size_t chars) {
871   return LenTrim(x, chars);
872 }
873 std::size_t RTNAME(LenTrim2)(const char16_t *x, std::size_t chars) {
874   return LenTrim(x, chars);
875 }
876 std::size_t RTNAME(LenTrim4)(const char32_t *x, std::size_t chars) {
877   return LenTrim(x, chars);
878 }
879 
880 void RTNAME(LenTrim)(Descriptor &result, const Descriptor &string, int kind,
881     const char *sourceFile, int sourceLine) {
882   Terminator terminator{sourceFile, sourceLine};
883   switch (string.raw().type) {
884   case CFI_type_char:
885     LenTrimKind<char>(result, string, kind, terminator);
886     break;
887   case CFI_type_char16_t:
888     LenTrimKind<char16_t>(result, string, kind, terminator);
889     break;
890   case CFI_type_char32_t:
891     LenTrimKind<char32_t>(result, string, kind, terminator);
892     break;
893   default:
894     terminator.Crash("LEN_TRIM: bad string type code %d",
895         static_cast<int>(string.raw().type));
896   }
897 }
898 
899 std::size_t RTNAME(Scan1)(const char *x, std::size_t xLen, const char *set,
900     std::size_t setLen, bool back) {
901   return ScanVerify<char, CharFunc::Scan>(x, xLen, set, setLen, back);
902 }
903 std::size_t RTNAME(Scan2)(const char16_t *x, std::size_t xLen,
904     const char16_t *set, std::size_t setLen, bool back) {
905   return ScanVerify<char16_t, CharFunc::Scan>(x, xLen, set, setLen, back);
906 }
907 std::size_t RTNAME(Scan4)(const char32_t *x, std::size_t xLen,
908     const char32_t *set, std::size_t setLen, bool back) {
909   return ScanVerify<char32_t, CharFunc::Scan>(x, xLen, set, setLen, back);
910 }
911 
912 void RTNAME(Scan)(Descriptor &result, const Descriptor &string,
913     const Descriptor &set, const Descriptor *back, int kind,
914     const char *sourceFile, int sourceLine) {
915   Terminator terminator{sourceFile, sourceLine};
916   switch (string.raw().type) {
917   case CFI_type_char:
918     GeneralCharFuncKind<char, CharFunc::Scan>(
919         result, string, set, back, kind, terminator);
920     break;
921   case CFI_type_char16_t:
922     GeneralCharFuncKind<char16_t, CharFunc::Scan>(
923         result, string, set, back, kind, terminator);
924     break;
925   case CFI_type_char32_t:
926     GeneralCharFuncKind<char32_t, CharFunc::Scan>(
927         result, string, set, back, kind, terminator);
928     break;
929   default:
930     terminator.Crash(
931         "SCAN: bad string type code %d", static_cast<int>(string.raw().type));
932   }
933 }
934 
935 void RTNAME(Repeat)(Descriptor &result, const Descriptor &string,
936     std::size_t ncopies, const char *sourceFile, int sourceLine) {
937   Terminator terminator{sourceFile, sourceLine};
938   std::size_t origBytes{string.ElementBytes()};
939   result.Establish(string.type(), origBytes * ncopies, nullptr, 0, nullptr,
940       CFI_attribute_allocatable);
941   if (result.Allocate(nullptr, nullptr) != CFI_SUCCESS) {
942     terminator.Crash("REPEAT could not allocate storage for result");
943   }
944   const char *from{string.OffsetElement()};
945   for (char *to{result.OffsetElement()}; ncopies-- > 0; to += origBytes) {
946     std::memcpy(to, from, origBytes);
947   }
948 }
949 
950 void RTNAME(Trim)(Descriptor &result, const Descriptor &string,
951     const char *sourceFile, int sourceLine) {
952   Terminator terminator{sourceFile, sourceLine};
953   std::size_t resultBytes{0};
954   switch (string.raw().type) {
955   case CFI_type_char:
956     resultBytes =
957         LenTrim(string.OffsetElement<const char>(), string.ElementBytes());
958     break;
959   case CFI_type_char16_t:
960     resultBytes = LenTrim(string.OffsetElement<const char16_t>(),
961                       string.ElementBytes() >> 1)
962         << 1;
963     break;
964   case CFI_type_char32_t:
965     resultBytes = LenTrim(string.OffsetElement<const char32_t>(),
966                       string.ElementBytes() >> 2)
967         << 2;
968     break;
969   default:
970     terminator.Crash(
971         "TRIM: bad string type code %d", static_cast<int>(string.raw().type));
972   }
973   result.Establish(string.type(), resultBytes, nullptr, 0, nullptr,
974       CFI_attribute_allocatable);
975   RUNTIME_CHECK(terminator, result.Allocate(nullptr, nullptr) == CFI_SUCCESS);
976   std::memcpy(result.OffsetElement(), string.OffsetElement(), resultBytes);
977 }
978 
979 std::size_t RTNAME(Verify1)(const char *x, std::size_t xLen, const char *set,
980     std::size_t setLen, bool back) {
981   return ScanVerify<char, CharFunc::Verify>(x, xLen, set, setLen, back);
982 }
983 std::size_t RTNAME(Verify2)(const char16_t *x, std::size_t xLen,
984     const char16_t *set, std::size_t setLen, bool back) {
985   return ScanVerify<char16_t, CharFunc::Verify>(x, xLen, set, setLen, back);
986 }
987 std::size_t RTNAME(Verify4)(const char32_t *x, std::size_t xLen,
988     const char32_t *set, std::size_t setLen, bool back) {
989   return ScanVerify<char32_t, CharFunc::Verify>(x, xLen, set, setLen, back);
990 }
991 
992 void RTNAME(Verify)(Descriptor &result, const Descriptor &string,
993     const Descriptor &set, const Descriptor *back, int kind,
994     const char *sourceFile, int sourceLine) {
995   Terminator terminator{sourceFile, sourceLine};
996   switch (string.raw().type) {
997   case CFI_type_char:
998     GeneralCharFuncKind<char, CharFunc::Verify>(
999         result, string, set, back, kind, terminator);
1000     break;
1001   case CFI_type_char16_t:
1002     GeneralCharFuncKind<char16_t, CharFunc::Verify>(
1003         result, string, set, back, kind, terminator);
1004     break;
1005   case CFI_type_char32_t:
1006     GeneralCharFuncKind<char32_t, CharFunc::Verify>(
1007         result, string, set, back, kind, terminator);
1008     break;
1009   default:
1010     terminator.Crash(
1011         "VERIFY: bad string type code %d", static_cast<int>(string.raw().type));
1012   }
1013 }
1014 
1015 void RTNAME(CharacterMax)(Descriptor &accumulator, const Descriptor &x,
1016     const char *sourceFile, int sourceLine) {
1017   MaxMin<false>(accumulator, x, sourceFile, sourceLine);
1018 }
1019 
1020 void RTNAME(CharacterMin)(Descriptor &accumulator, const Descriptor &x,
1021     const char *sourceFile, int sourceLine) {
1022   MaxMin<true>(accumulator, x, sourceFile, sourceLine);
1023 }
1024 
1025 // TODO: Character MAXVAL/MINVAL
1026 // TODO: Character MAXLOC/MINLOC
1027 }
1028 } // namespace Fortran::runtime
1029