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