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