[flang] More Fortran runtime support for CHARACTER operations

[klausler]

Summary

• Remove C++ library dependence from lock.h
• Implement LEN_TRIM, REPEAT, ADJUSTL, ADJUSTR, MAX/MIN intrinsic functions for CHARACTER

[PeteSteinfeld]

I built and tested in-tree, and everything worked like a champ. The out-of-tree build failed, but I assume that's because D82050 hasn't been integrated yet.

flang/include/flang/ISO_Fortran_binding.h

 /*===-- include/flang/ISO_Fortran_binding.h -----------------------*- C++ -*-===
  *
  * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
  * See https://llvm.org/LICENSE.txt for license information.
  * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
  *
  * ===-----------------------------------------------------------------------===
  */

 #define CFI_attribute_pointer 1
 #define CFI_attribute_allocatable 2
 #define CFI_attribute_other 0 /* neither pointer nor allocatable */
 
 typedef signed char CFI_type_t;
 /* These codes are required to be macros (i.e., #ifdef will work).
  * They are not required to be distinct, but neither are they required
  * to have had their synonyms combined.
- * Extension: 128-bit integers are anticipated
  */
 #define CFI_type_signed_char 1
 #define CFI_type_short 2
 #define CFI_type_int 3
 #define CFI_type_long 4
 #define CFI_type_long_long 5
 #define CFI_type_size_t 6
 #define CFI_type_int8_t 7
 #define CFI_type_int16_t 8
 #define CFI_type_int32_t 9
 #define CFI_type_int64_t 10
-#define CFI_type_int128_t 11
+#define CFI_type_int128_t 11 /* extension */
 #define CFI_type_int_least8_t 12
 #define CFI_type_int_least16_t 13
 #define CFI_type_int_least32_t 14
 #define CFI_type_int_least64_t 15
 #define CFI_type_int_least128_t 16
 #define CFI_type_int_fast8_t 17
 #define CFI_type_int_fast16_t 18
 #define CFI_type_int_fast32_t 19
 #define CFI_type_int_fast64_t 20
 #define CFI_type_int_fast128_t 21
 #define CFI_type_intmax_t 22
 #define CFI_type_intptr_t 23
 #define CFI_type_ptrdiff_t 24
 #define CFI_type_float 25
 #define CFI_type_double 26
 #define CFI_type_long_double 27
 #define CFI_type_float_Complex 28
 #define CFI_type_double_Complex 29
 #define CFI_type_long_double_Complex 30
 #define CFI_type_Bool 31
 #define CFI_type_char 32
 #define CFI_type_cptr 33
 #define CFI_type_struct 34
+#define CFI_type_char16_t 35 /* extension: char16_t */
+#define CFI_type_char32_t 36 /* extension: char32_t */
+#define CFI_TYPE_LAST CFI_type_char32_t
 #define CFI_type_other (-1) // must be negative
 
 /* Error code macros */
 #define CFI_SUCCESS 0 /* must be zero */
 #define CFI_ERROR_BASE_ADDR_NULL 1
 #define CFI_ERROR_BASE_ADDR_NOT_NULL 2
 #define CFI_INVALID_ELEM_LEN 3
 #define CFI_INVALID_RANK 4

flang/runtime/ISO_Fortran_binding.cpp

 //===-- runtime/ISO_Fortran_binding.cpp -----------------------------------===//
 //
 // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
 // See https://llvm.org/LICENSE.txt for license information.
 // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
 //
 //===----------------------------------------------------------------------===//
 
 // Implements the required interoperability API from ISO_Fortran_binding.h
 // as specified in section 18.5.5 of Fortran 2018.
 
 #include "../include/flang/ISO_Fortran_binding.h"
 #include "descriptor.h"
 #include <cstdlib>
 
 namespace Fortran::ISO {
 extern "C" {
 
 static inline constexpr bool IsCharacterType(CFI_type_t ty) {
-  return ty == CFI_type_char;
+  return ty == CFI_type_char || ty == CFI_type_char16_t ||
+      ty == CFI_type_char32_t;
 }
 static inline constexpr bool IsAssumedSize(const CFI_cdesc_t *dv) {
   return dv->rank > 0 && dv->dim[dv->rank - 1].extent == -1;
 }
 
 void *CFI_address(
     const CFI_cdesc_t *descriptor, const CFI_index_t subscripts[]) {
   char *p{static_cast<char *>(descriptor->base_addr)};
case CFI_type_long_double_Complex:
     minElemLen = 2 * sizeof(long double);
     break;
   case CFI_type_Bool:
     minElemLen = 1;
     break;
   case CFI_type_cptr:
     minElemLen = sizeof(void *);
     break;
+  case CFI_type_char16_t:
+    minElemLen = sizeof(char16_t);
+    break;
+  case CFI_type_char32_t:
+    minElemLen = sizeof(char32_t);
+    break;
   }
   return minElemLen;
 }
 
 int CFI_establish(CFI_cdesc_t *descriptor, void *base_addr,
     CFI_attribute_t attribute, CFI_type_t type, std::size_t elem_len,
     CFI_rank_t rank, const CFI_index_t extents[]) {
   if (attribute != CFI_attribute_other && attribute != CFI_attribute_pointer &&

flang/runtime/character.h

 //===-- runtime/character.h -------------------------------------*- C++ -*-===//
 //
 // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
 // See https://llvm.org/LICENSE.txt for license information.
 // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
 //
 //===----------------------------------------------------------------------===//
 
 // Defines API between compiled code and the CHARACTER
 // support functions in the runtime library.
 
 #ifndef FORTRAN_RUNTIME_CHARACTER_H_
 #define FORTRAN_RUNTIME_CHARACTER_H_
 #include "entry-names.h"
 #include <cstddef>
 
 namespace Fortran::runtime {
 
 class Descriptor;
 
 extern "C" {
 
 // Appends the corresponding (or expanded) characters of 'operand'
-// to the (elements of) a (re)allocation of 'temp', which must be an
+// to the (elements of) a (re)allocation of 'accumulator', which must be an
 // initialized CHARACTER allocatable scalar or array descriptor -- use
 // AllocatableInitCharacter() to set one up.  Crashes when not
 // conforming.  Assumes independence of data.
-void RTNAME(CharacterConcatenate)(Descriptor &temp, const Descriptor &operand,
-    const char *sourceFile = nullptr, int sourceLine = 0);
+void RTNAME(CharacterConcatenate)(Descriptor &accumulator,
+    const Descriptor &from, const char *sourceFile = nullptr,
+    int sourceLine = 0);
 
-// Convenience specialization for ASCII scalars.
+// Convenience specialization for ASCII scalars concatenation.
 void RTNAME(CharacterConcatenateScalar1)(
-    Descriptor &temp, const char *, std::size_t byteLength);
+    Descriptor &accumulator, const char *from, std::size_t chars);
 
-// Assigns the value(s) of 'rhs' to 'lhs'.  Handles reallocation,
-// truncation, or padding ss necessary.  Crashes when not conforming.
-// Assumes independence of data.
+// Copies the value(s) of 'rhs' to 'lhs'.  Handles reallocation,
+// truncation, or padding ss necessary.  Crashes when not conforming and
+// the LHS is not allocatable.  Assumes independence of data.
+// The LHS and RHS need not have the same kind of character;
+// so when the LHS is a deallocated allocatable temporary result, this
+// function can be used as a simple conversion routine.
 // Call MoveAlloc() instead as an optimization when a temporary value is
 // being assigned to a deferred-length allocatable.
 void RTNAME(CharacterAssign)(Descriptor &lhs, const Descriptor &rhs,
     const char *sourceFile = nullptr, int sourceLine = 0);
 
 // CHARACTER comparisons.  The kinds must match.  Like std::memcmp(),
 // the result is less than zero, zero, or greater than zero if the first
 // argument is less than the second, equal to the second, or greater than
 // the second, respectively.  The shorter argument is treated as if it were
 // padded on the right with blanks.
 // N.B.: Calls to the restricted specific intrinsic functions LGE, LGT, LLE,
 // & LLT are converted into calls to these during lowering; they don't have
 // to be able to be passed as actual procedure arguments.
 int RTNAME(CharacterCompareScalar)(const Descriptor &, const Descriptor &);
 int RTNAME(CharacterCompareScalar1)(
-    const char *x, const char *y, std::size_t xBytes, std::size_t yBytes);
+    const char *x, const char *y, std::size_t xChars, std::size_t yChars);
 int RTNAME(CharacterCompareScalar2)(const char16_t *x, const char16_t *y,
-    std::size_t xBytes, std::size_t yBytes);
+    std::size_t xChars, std::size_t yChars);
 int RTNAME(CharacterCompareScalar4)(const char32_t *x, const char32_t *y,
-    std::size_t xBytes, std::size_t yBytes);
+    std::size_t xChars, std::size_t yChars);
 
 // General CHARACTER comparison; the result is a LOGICAL(KIND=1) array that
 // is established and populated.
 void RTNAME(CharacterCompare)(
     Descriptor &result, const Descriptor &, const Descriptor &);
 
 // Special-case support for optimized ASCII scalar expressions.
 
 // Copies data from 'rhs' to the remaining space (lhsLength - offset)
 // in 'lhs', if any.  Returns the new offset.  Assumes independence.
 std::size_t RTNAME(CharacterAppend1)(char *lhs, std::size_t lhsBytes,
     std::size_t offset, const char *rhs, std::size_t rhsBytes);
 
 // Appends any necessary spaces to a CHARACTER(KIND=1) scalar.
 void RTNAME(CharacterPad1)(char *lhs, std::size_t bytes, std::size_t offset);
+
+// Intrinsic functions
+// The result descriptors below are all established by the runtime.
+void RTNAME(Adjustl)(Descriptor &result, const Descriptor &,
+    const char *sourceFile = nullptr, int sourceLine = 0);
+void RTNAME(Adjustr)(Descriptor &result, const Descriptor &,
+    const char *sourceFile = nullptr, int sourceLine = 0);
+std::size_t RTNAME(LenTrim1)(const char *, std::size_t);
+std::size_t RTNAME(LenTrim2)(const char16_t *, std::size_t);
+std::size_t RTNAME(LenTrim4)(const char32_t *, std::size_t);
+void RTNAME(LenTrim)(Descriptor &result, const Descriptor &, int kind,
+    const char *sourceFile = nullptr, int sourceLine = 0);
+void RTNAME(Repeat)(Descriptor &result, const Descriptor &string,
+    std::size_t ncopies, const char *sourceFile = nullptr, int sourceLine = 0);
+void RTNAME(Trim)(Descriptor &result, const Descriptor &string,
+    const char *sourceFile = nullptr, int sourceLine = 0);
+
+void RTNAME(CharacterMax)(Descriptor &accumulator, const Descriptor &x,
+    const char *sourceFile = nullptr, int sourceLine = 0);
+void RTNAME(CharacterMin)(Descriptor &accumulator, const Descriptor &x,
+    const char *sourceFile = nullptr, int sourceLine = 0);
+void RTNAME(CharacterMaxVal)(Descriptor &result, const Descriptor &x,
+    int dim = 0, const Descriptor *mask = nullptr,
+    const char *sourceFile = nullptr, int sourceLine = 0);
+void RTNAME(CharacterMinVal)(Descriptor &result, const Descriptor &x,
+    int dim = 0, const Descriptor *mask = nullptr,
+    const char *sourceFile = nullptr, int sourceLine = 0);
+void RTNAME(CharacterMaxLoc)(Descriptor &result, const Descriptor &x,
+    int dim = 0, const Descriptor *mask = nullptr, int kind = sizeof(int),
+    bool back = false, const char *sourceFile = nullptr, int sourceLine = 0);
+void RTNAME(CharacterMinLoc)(Descriptor &result, const Descriptor &x,
+    int dim = 0, const Descriptor *mask = nullptr, int kind = sizeof(int),
+    bool back = false, const char *sourceFile = nullptr, int sourceLine = 0);
 }
 } // namespace Fortran::runtime
 #endif // FORTRAN_RUNTIME_CHARACTER_H_

flang/runtime/character.cpp

 //===-- runtime/character.cpp -----------------------------------*- C++ -*-===//
 //
 // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
 // See https://llvm.org/LICENSE.txt for license information.
 // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
 //
 //===----------------------------------------------------------------------===//
 
 #include "character.h"
 #include "descriptor.h"
 #include "terminator.h"
+#include "flang/Common/bit-population-count.h"
+#include "flang/Common/uint128.h"
 #include <algorithm>
 #include <cstring>
 
 namespace Fortran::runtime {
 
-template <typename C>
-inline int CompareToBlankPadding(const C *x, std::size_t chars) {
+template <typename CHAR>
+inline int CompareToBlankPadding(const CHAR *x, std::size_t chars) {
   for (; chars-- > 0; ++x) {
     if (*x < ' ') {
       return -1;
     }
     if (*x > ' ') {
       return 1;
     }
   }
   return 0;
 }
 
-template <typename C, int shift>
+template <typename CHAR>
 static int Compare(
-    const C *x, const C *y, std::size_t xBytes, std::size_t yBytes) {
-  auto minBytes{std::min(xBytes, yBytes)};
-  if constexpr (shift == 0) {
+    const CHAR *x, const CHAR *y, std::size_t xChars, std::size_t yChars) {
+  auto minChars{std::min(xChars, yChars)};
+  if constexpr (sizeof(CHAR) == 1) {
     // don't use for kind=2 or =4, that would fail on little-endian machines
-    int cmp{std::memcmp(x, y, minBytes)};
+    int cmp{std::memcmp(x, y, minChars)};
     if (cmp < 0) {
       return -1;
     }
     if (cmp > 0) {
       return 1;
     }
-    if (xBytes == yBytes) {
+    if (xChars == yChars) {
       return 0;
     }
-    x += minBytes;
-    y += minBytes;
+    x += minChars;
+    y += minChars;
   } else {
-    for (std::size_t n{minBytes >> shift}; n-- > 0; ++x, ++y) {
+    for (std::size_t n{minChars}; n-- > 0; ++x, ++y) {
       if (*x < *y) {
         return -1;
       }
       if (*x > *y) {
         return 1;
       }
     }
   }
-  if (int cmp{CompareToBlankPadding(x, (xBytes - minBytes) >> shift)}) {
+  if (int cmp{CompareToBlankPadding(x, xChars - minChars)}) {
     return cmp;
   }
-  return -CompareToBlankPadding(y, (yBytes - minBytes) >> shift);
+  return -CompareToBlankPadding(y, yChars - minChars);
 }
 
-extern "C" {
-
-void RTNAME(CharacterConcatenate)(Descriptor & /*temp*/,
-    const Descriptor & /*operand*/, const char * /*sourceFile*/,
-    int /*sourceLine*/) {
-  // TODO
+// Shift count to use when converting between character lengths
+// and byte counts.
+template <typename CHAR>
+constexpr int shift{common::TrailingZeroBitCount(sizeof(CHAR))};
+
+template <typename CHAR>
+static void Compare(Descriptor &result, const Descriptor &x,
+    const Descriptor &y, const Terminator &terminator) {
+  RUNTIME_CHECK(
+      terminator, x.rank() == y.rank() || x.rank() == 0 || y.rank() == 0);
+  int rank{std::max(x.rank(), y.rank())};
+  SubscriptValue lb[maxRank], ub[maxRank], xAt[maxRank], yAt[maxRank];
+  SubscriptValue elements{1};
+  for (int j{0}; j < rank; ++j) {
+    lb[j] = 1;
+    if (x.rank() > 0 && y.rank() > 0) {
+      SubscriptValue xUB{x.GetDimension(j).Extent()};
+      SubscriptValue yUB{y.GetDimension(j).Extent()};
+      if (xUB != yUB) {
+        terminator.Crash("Character array comparison: operands are not "
+                         "conforming on dimension %d (%jd != %jd)",
+            j + 1, static_cast<std::intmax_t>(xUB),
+            static_cast<std::intmax_t>(yUB));
+      }
+      ub[j] = xUB;
+    } else {
+      ub[j] = (x.rank() ? x : y).GetDimension(j).Extent();
+    }
+    elements *= ub[j];
+    xAt[j] = yAt[j] = 1;
+  }
+  result.Establish(TypeCategory::Logical, 1, ub, rank);
+  if (result.Allocate(lb, ub) != CFI_SUCCESS) {
+    terminator.Crash("Compare: could not allocate storage for result");
+  }
+  std::size_t xChars{x.ElementBytes() >> shift<CHAR>};
+  std::size_t yChars{y.ElementBytes() >> shift<char>};
+  for (SubscriptValue resultAt{0}; elements-- > 0;
+       ++resultAt, x.IncrementSubscripts(xAt), y.IncrementSubscripts(yAt)) {
+    *result.OffsetElement<char>(resultAt) =
+        Compare(x.Element<CHAR>(xAt), y.Element<CHAR>(yAt), xChars, yChars);
+  }
+}
+
+template <typename CHAR, bool ADJUSTR>
+static void Adjust(CHAR *to, const CHAR *from, std::size_t chars) {
+  if constexpr (ADJUSTR) {
+    std::size_t j{chars}, k{chars};
+    for (; k > 0 && from[k - 1] == ' '; --k) {
+    }
+    while (k > 0) {
+      to[--j] = from[--k];
+    }
+    while (j > 0) {
+      to[--j] = ' ';
+    }
+  } else { // ADJUSTL
+    std::size_t j{0}, k{0};
+    for (; k < chars && from[k] == ' '; ++k) {
+    }
+    while (k < chars) {
+      to[j++] = from[k++];
+    }
+    while (j < chars) {
+      to[j++] = ' ';
+    }
+  }
+}
+
+template <typename CHAR, bool ADJUSTR>
+static void AdjustLRHelper(Descriptor &result, const Descriptor &string,
+    const Terminator &terminator) {
+  int rank{string.rank()};
+  SubscriptValue lb[maxRank], ub[maxRank], stringAt[maxRank];
+  SubscriptValue elements{1};
+  for (int j{0}; j < rank; ++j) {
+    lb[j] = 1;
+    ub[j] = string.GetDimension(j).Extent();
+    elements *= ub[j];
+    stringAt[j] = 1;
+  }
+  std::size_t elementBytes{string.ElementBytes()};
+  result.Establish(string.type(), elementBytes, ub, rank);
+  if (result.Allocate(lb, ub) != CFI_SUCCESS) {
+    terminator.Crash("ADJUSTL/R: could not allocate storage for result");
+  }
+  for (SubscriptValue resultAt{0}; elements-- > 0;
+       resultAt += elementBytes, string.IncrementSubscripts(stringAt)) {
+    Adjust<CHAR, ADJUSTR>(result.OffsetElement<CHAR>(resultAt),
+        string.Element<const CHAR>(stringAt), elementBytes >> shift<CHAR>);
+  }
+}
+
+template <bool ADJUSTR>
+void AdjustLR(Descriptor &result, const Descriptor &string,
+    const char *sourceFile, int sourceLine) {
+  Terminator terminator{sourceFile, sourceLine};
+  switch (string.raw().type) {
+  case CFI_type_char:
+    AdjustLRHelper<char, ADJUSTR>(result, string, terminator);
+    break;
+  case CFI_type_char16_t:
+    AdjustLRHelper<char16_t, ADJUSTR>(result, string, terminator);
+    break;
+  case CFI_type_char32_t:
+    AdjustLRHelper<char32_t, ADJUSTR>(result, string, terminator);
+    break;
+  default:
+    terminator.Crash("ADJUSTL/R: bad string type code %d",
+        static_cast<int>(string.raw().type));
+  }
+}
+
+template <typename CHAR>
+inline std::size_t LenTrim(const CHAR *x, std::size_t chars) {
+  while (chars > 0 && x[chars - 1] == ' ') {
+    --chars;
+  }
+  return chars;
+}
+
+template <typename INT, typename CHAR>
+static void LenTrim(Descriptor &result, const Descriptor &string,
+    const Terminator &terminator) {
+  int rank{string.rank()};
+  SubscriptValue lb[maxRank], ub[maxRank], stringAt[maxRank];
+  SubscriptValue elements{1};
+  for (int j{0}; j < rank; ++j) {
+    lb[j] = 1;
+    ub[j] = string.GetDimension(j).Extent();
+    elements *= ub[j];
+    stringAt[j] = 1;
+  }
+  result.Establish(TypeCategory::Integer, sizeof(INT), ub, rank);
+  if (result.Allocate(lb, ub) != CFI_SUCCESS) {
+    terminator.Crash("LEN_TRIM: could not allocate storage for result");
+  }
+  std::size_t stringElementChars{string.ElementBytes() >> shift<CHAR>};
+  for (SubscriptValue resultAt{0}; elements-- > 0;
+       resultAt += sizeof(INT), string.IncrementSubscripts(stringAt)) {
+    *result.OffsetElement<INT>(resultAt) =
+        LenTrim(string.Element<CHAR>(stringAt), stringElementChars);
+  }
+}
+
+template <typename CHAR>
+static void LenTrimKind(Descriptor &result, const Descriptor &string, int kind,
+    const Terminator &terminator) {
+  switch (kind) {
+  case 1:
+    LenTrim<std::int8_t, CHAR>(result, string, terminator);
+    break;
+  case 2:
+    LenTrim<std::int16_t, CHAR>(result, string, terminator);
+    break;
+  case 4:
+    LenTrim<std::int32_t, CHAR>(result, string, terminator);
+    break;
+  case 8:
+    LenTrim<std::int64_t, CHAR>(result, string, terminator);
+    break;
+  case 16:
+    LenTrim<common::uint128_t, CHAR>(result, string, terminator);
+    break;
+  default:
+    terminator.Crash("LEN_TRIM: bad KIND=%d", kind);
+  }
+}
+
+template <typename TO, typename FROM>
+static void CopyAndPad(
+    TO *to, const FROM *from, std::size_t toChars, std::size_t fromChars) {
+  if constexpr (sizeof(TO) != sizeof(FROM)) {
+    std::size_t copyChars{std::min(toChars, fromChars)};
+    for (std::size_t j{0}; j < copyChars; ++j) {
+      to[j] = from[j];
+    }
+    for (std::size_t j{copyChars}; j < toChars; ++j) {
+      to[j] = static_cast<TO>(' ');
+    }
+  } else if (toChars <= fromChars) {
+    std::memcpy(to, from, toChars * shift<TO>);
+  } else {
+    std::memcpy(to, from, fromChars * shift<TO>);
+    for (std::size_t j{fromChars}; j < toChars; ++j) {
+      to[j] = static_cast<TO>(' ');
+    }
   }
-
-void RTNAME(CharacterConcatenateScalar)(
-    Descriptor & /*temp*/, const char * /*from*/, std::size_t /*byteLength*/) {
-  // TODO
 }
 
-void RTNAME(CharacterAssign)(Descriptor & /*lhs*/, const Descriptor & /*rhs*/,
-    const char * /*sourceFile*/, int /*sourceLine*/) {
-  // TODO
+template <typename CHAR, bool ISMIN>
+static void MaxMinHelper(Descriptor &accumulator, const Descriptor &x,
+    const Terminator &terminator) {
+  RUNTIME_CHECK(terminator,
+      accumulator.rank() == 0 || x.rank() == 0 ||
+          accumulator.rank() == x.rank());
+  SubscriptValue lb[maxRank], ub[maxRank], xAt[maxRank];
+  SubscriptValue elements{1};
+  std::size_t accumChars{accumulator.ElementBytes() >> shift<CHAR>};
+  std::size_t xChars{x.ElementBytes() >> shift<CHAR>};
+  std::size_t chars{std::max(accumChars, xChars)};
+  bool reallocate{accumulator.raw().base_addr == nullptr ||
+      accumChars != xChars || (accumulator.rank() == 0 && x.rank() > 0)};
+  int rank{std::max(accumulator.rank(), x.rank())};
+  for (int j{0}; j < rank; ++j) {
+    lb[j] = 1;
+    if (x.rank() > 0) {
+      ub[j] = x.GetDimension(j).Extent();
+      xAt[j] = x.GetDimension(j).LowerBound();
+      if (accumulator.rank() > 0) {
+        SubscriptValue accumExt{accumulator.GetDimension(j).Extent()};
+        if (accumExt != ub[j]) {
+          terminator.Crash("Character MAX/MIN: operands are not "
+                           "conforming on dimension %d (%jd != %jd)",
+              j + 1, static_cast<std::intmax_t>(accumExt),
+              static_cast<std::intmax_t>(ub[j]));
+        }
+      }
+    } else {
+      ub[j] = accumulator.GetDimension(j).Extent();
+      xAt[j] = 1;
+    }
+    elements *= ub[j];
+  }
+  void *old{nullptr};
+  const CHAR *accumData{accumulator.OffsetElement<CHAR>()};
+  if (reallocate) {
+    old = accumulator.raw().base_addr;
+    accumulator.set_base_addr(nullptr);
+    accumulator.raw().elem_len = chars << shift<CHAR>;
+    RUNTIME_CHECK(terminator, accumulator.Allocate(lb, ub) == CFI_SUCCESS);
+  }
+  for (CHAR *result{accumulator.OffsetElement<CHAR>()}; elements-- > 0;
+       accumData += accumChars, result += chars, x.IncrementSubscripts(xAt)) {
+    const CHAR *xData{x.Element<CHAR>(xAt)};
+    int cmp{Compare(accumData, xData, accumChars, xChars)};
+    if constexpr (ISMIN) {
+      cmp = -cmp;
+    }
+    if (cmp < 0) {
+      CopyAndPad(result, xData, chars, xChars);
+    } else if (result != accumData) {
+      CopyAndPad(result, accumData, chars, accumChars);
+    }
+  }
+  FreeMemory(old);
+}
+
+template <bool ISMIN>
+static void MaxMin(Descriptor &accumulator, const Descriptor &x,
+    const char *sourceFile, int sourceLine) {
+  Terminator terminator{sourceFile, sourceLine};
+  RUNTIME_CHECK(terminator, accumulator.raw().type == x.raw().type);
+  switch (accumulator.raw().type) {
+  case CFI_type_char:
+    MaxMinHelper<char, ISMIN>(accumulator, x, terminator);
+    break;
+  case CFI_type_char16_t:
+    MaxMinHelper<char16_t, ISMIN>(accumulator, x, terminator);
+    break;
+  case CFI_type_char32_t:
+    MaxMinHelper<char32_t, ISMIN>(accumulator, x, terminator);
+    break;
+  default:
+    terminator.Crash(
+        "Character MAX/MIN: result does not have a character type");
+  }
 }
 
-int RTNAME(CharacterCompareScalar)(const Descriptor &, const Descriptor &) {
-  // TODO real soon once there's type codes for character(kind=2 & 4)
+extern "C" {
+
+void RTNAME(CharacterConcatenate)(Descriptor &accumulator,
+    const Descriptor &from, const char *sourceFile, int sourceLine) {
+  Terminator terminator{sourceFile, sourceLine};
+  RUNTIME_CHECK(terminator,
+      accumulator.rank() == 0 || from.rank() == 0 ||
+          accumulator.rank() == from.rank());
+  int rank{std::max(accumulator.rank(), from.rank())};
+  SubscriptValue lb[maxRank], ub[maxRank], fromAt[maxRank];
+  SubscriptValue elements{1};
+  for (int j{0}; j < rank; ++j) {
+    lb[j] = 1;
+    if (accumulator.rank() > 0 && from.rank() > 0) {
+      ub[j] = accumulator.GetDimension(j).Extent();
+      SubscriptValue fromUB{from.GetDimension(j).Extent()};
+      if (ub[j] != fromUB) {
+        terminator.Crash("Character array concatenation: operands are not "
+                         "conforming on dimension %d (%jd != %jd)",
+            j + 1, static_cast<std::intmax_t>(ub[j]),
+            static_cast<std::intmax_t>(fromUB));
+      }
+    } else {
+      ub[j] =
+          (accumulator.rank() ? accumulator : from).GetDimension(j).Extent();
+    }
+    elements *= ub[j];
+    fromAt[j] = 1;
+  }
+  std::size_t oldBytes{accumulator.ElementBytes()};
+  void *old{accumulator.raw().base_addr};
+  accumulator.set_base_addr(nullptr);
+  std::size_t fromBytes{from.ElementBytes()};
+  accumulator.raw().elem_len += fromBytes;
+  std::size_t newBytes{accumulator.ElementBytes()};
+  if (accumulator.Allocate(lb, ub) != CFI_SUCCESS) {
+    terminator.Crash(
+        "CharacterConcatenate: could not allocate storage for result");
+  }
+  const char *p{static_cast<const char *>(old)};
+  char *to{static_cast<char *>(accumulator.raw().base_addr)};
+  for (; elements-- > 0;
+       to += newBytes, p += oldBytes, from.IncrementSubscripts(fromAt)) {
+    std::memcpy(to, p, oldBytes);
+    std::memcpy(to + oldBytes, from.Element<char>(fromAt), fromBytes);
+  }
+  FreeMemory(old);
+}
+
+void RTNAME(CharacterConcatenateScalar1)(
+    Descriptor &accumulator, const char *from, std::size_t chars) {
+  Terminator terminator{__FILE__, __LINE__};
+  RUNTIME_CHECK(terminator, accumulator.rank() == 0);
+  void *old{accumulator.raw().base_addr};
+  accumulator.set_base_addr(nullptr);
+  std::size_t oldLen{accumulator.ElementBytes()};
+  accumulator.raw().elem_len += chars;
+  RUNTIME_CHECK(
+      terminator, accumulator.Allocate(nullptr, nullptr) == CFI_SUCCESS);
+  std::memcpy(accumulator.OffsetElement<char>(oldLen), from, chars);
+  FreeMemory(old);
+}
+
+void RTNAME(CharacterAssign)(Descriptor &lhs, const Descriptor &rhs,
+    const char *sourceFile, int sourceLine) {
+  Terminator terminator{sourceFile, sourceLine};
+  int rank{lhs.rank()};
+  RUNTIME_CHECK(terminator, rhs.rank() == 0 || rhs.rank() == rank);
+  SubscriptValue ub[maxRank], lhsAt[maxRank], rhsAt[maxRank];
+  SubscriptValue elements{1};
+  std::size_t lhsBytes{lhs.ElementBytes()};
+  std::size_t rhsBytes{rhs.ElementBytes()};
+  bool reallocate{lhs.IsAllocatable() &&
+      (lhs.raw().base_addr == nullptr || lhsBytes != rhsBytes)};
+  for (int j{0}; j < rank; ++j) {
+    lhsAt[j] = lhs.GetDimension(j).LowerBound();
+    if (rhs.rank() > 0) {
+      SubscriptValue lhsExt{lhs.GetDimension(j).Extent()};
+      SubscriptValue rhsExt{rhs.GetDimension(j).Extent()};
+      ub[j] = lhsAt[j] + rhsExt - 1;
+      if (lhsExt != rhsExt) {
+        if (lhs.IsAllocatable()) {
+          reallocate = true;
+        } else {
+          terminator.Crash("Character array assignment: operands are not "
+                           "conforming on dimension %d (%jd != %jd)",
+              j + 1, static_cast<std::intmax_t>(lhsExt),
+              static_cast<std::intmax_t>(rhsExt));
+        }
+      }
+      rhsAt[j] = rhs.GetDimension(j).LowerBound();
+    } else {
+      ub[j] = lhs.GetDimension(j).UpperBound();
+    }
+    elements *= ub[j] - lhsAt[j] + 1;
+  }
+  void *old{nullptr};
+  if (reallocate) {
+    old = lhs.raw().base_addr;
+    lhs.set_base_addr(nullptr);
+    lhs.raw().elem_len = lhsBytes = rhsBytes;
+    if (rhs.rank() > 0) {
+      // When the RHS is not scalar, the LHS acquires its bounds.
+      for (int j{0}; j < rank; ++j) {
+        lhsAt[j] = rhsAt[j];
+        ub[j] = rhs.GetDimension(j).UpperBound();
+      }
+    }
+    RUNTIME_CHECK(terminator, lhs.Allocate(lhsAt, ub) == CFI_SUCCESS);
+  }
+  switch (lhs.raw().type) {
+  case CFI_type_char:
+    switch (rhs.raw().type) {
+    case CFI_type_char:
+      for (; elements-- > 0;
+           lhs.IncrementSubscripts(lhsAt), rhs.IncrementSubscripts(rhsAt)) {
+        CopyAndPad(lhs.Element<char>(lhsAt), rhs.Element<char>(rhsAt), lhsBytes,
+            rhsBytes);
+      }
+      break;
+    case CFI_type_char16_t:
+      for (; elements-- > 0;
+           lhs.IncrementSubscripts(lhsAt), rhs.IncrementSubscripts(rhsAt)) {
+        CopyAndPad(lhs.Element<char>(lhsAt), rhs.Element<char16_t>(rhsAt),
+            lhsBytes, rhsBytes >> 1);
+      }
+      break;
+    case CFI_type_char32_t:
+      for (; elements-- > 0;
+           lhs.IncrementSubscripts(lhsAt), rhs.IncrementSubscripts(rhsAt)) {
+        CopyAndPad(lhs.Element<char>(lhsAt), rhs.Element<char32_t>(rhsAt),
+            lhsBytes, rhsBytes >> 2);
+      }
+      break;
+    default:
+      terminator.Crash(
+          "RHS of character assignment does not have a character type");
+    }
+    break;
+  case CFI_type_char16_t:
+    switch (rhs.raw().type) {
+    case CFI_type_char:
+      for (; elements-- > 0;
+           lhs.IncrementSubscripts(lhsAt), rhs.IncrementSubscripts(rhsAt)) {
+        CopyAndPad(lhs.Element<char16_t>(lhsAt), rhs.Element<char>(rhsAt),
+            lhsBytes >> 1, rhsBytes);
+      }
+      break;
+    case CFI_type_char16_t:
+      for (; elements-- > 0;
+           lhs.IncrementSubscripts(lhsAt), rhs.IncrementSubscripts(rhsAt)) {
+        CopyAndPad(lhs.Element<char16_t>(lhsAt), rhs.Element<char16_t>(rhsAt),
+            lhsBytes >> 1, rhsBytes >> 1);
+      }
+      break;
+    case CFI_type_char32_t:
+      for (; elements-- > 0;
+           lhs.IncrementSubscripts(lhsAt), rhs.IncrementSubscripts(rhsAt)) {
+        CopyAndPad(lhs.Element<char16_t>(lhsAt), rhs.Element<char32_t>(rhsAt),
+            lhsBytes >> 1, rhsBytes >> 2);
+      }
+      break;
+    default:
+      terminator.Crash(
+          "RHS of character assignment does not have a character type");
+    }
+    break;
+  case CFI_type_char32_t:
+    switch (rhs.raw().type) {
+    case CFI_type_char:
+      for (; elements-- > 0;
+           lhs.IncrementSubscripts(lhsAt), rhs.IncrementSubscripts(rhsAt)) {
+        CopyAndPad(lhs.Element<char32_t>(lhsAt), rhs.Element<char>(rhsAt),
+            lhsBytes >> 2, rhsBytes);
+      }
+      break;
+    case CFI_type_char16_t:
+      for (; elements-- > 0;
+           lhs.IncrementSubscripts(lhsAt), rhs.IncrementSubscripts(rhsAt)) {
+        CopyAndPad(lhs.Element<char32_t>(lhsAt), rhs.Element<char16_t>(rhsAt),
+            lhsBytes >> 2, rhsBytes >> 1);
+      }
+      break;
+    case CFI_type_char32_t:
+      for (; elements-- > 0;
+           lhs.IncrementSubscripts(lhsAt), rhs.IncrementSubscripts(rhsAt)) {
+        CopyAndPad(lhs.Element<char32_t>(lhsAt), rhs.Element<char32_t>(rhsAt),
+            lhsBytes >> 2, rhsBytes >> 2);
+      }
+      break;
+    default:
+      terminator.Crash(
+          "RHS of character assignment does not have a character type");
+    }
+    break;
+  default:
+    terminator.Crash(
+        "LHS of character assignment does not have a character type");
+  }
+  if (reallocate) {
+    FreeMemory(old);
+  }
+}
+
+int RTNAME(CharacterCompareScalar)(const Descriptor &x, const Descriptor &y) {
+  Terminator terminator{__FILE__, __LINE__};
+  RUNTIME_CHECK(terminator, x.rank() == 0);
+  RUNTIME_CHECK(terminator, y.rank() == 0);
+  RUNTIME_CHECK(terminator, x.raw().type == y.raw().type);
+  switch (x.raw().type) {
+  case CFI_type_char:
+    return Compare(x.OffsetElement<char>(), y.OffsetElement<char>(),
+        x.ElementBytes(), y.ElementBytes());
+  case CFI_type_char16_t:
+    return Compare(x.OffsetElement<char16_t>(), y.OffsetElement<char16_t>(),
+        x.ElementBytes() >> 1, y.ElementBytes() >> 1);
+  case CFI_type_char32_t:
+    return Compare(x.OffsetElement<char32_t>(), y.OffsetElement<char32_t>(),
+        x.ElementBytes() >> 2, y.ElementBytes() >> 2);
+  default:
+    terminator.Crash("CharacterCompareScalar: bad string type code %d",
+        static_cast<int>(x.raw().type));
+  }
   return 0;
 }
 
 int RTNAME(CharacterCompareScalar1)(
-    const char *x, const char *y, std::size_t xBytes, std::size_t yBytes) {
-  return Compare<char, 0>(x, y, xBytes, yBytes);
+    const char *x, const char *y, std::size_t xChars, std::size_t yChars) {
+  return Compare(x, y, xChars, yChars);
 }
 
 int RTNAME(CharacterCompareScalar2)(const char16_t *x, const char16_t *y,
-    std::size_t xBytes, std::size_t yBytes) {
-  return Compare<char16_t, 1>(x, y, xBytes, yBytes);
+    std::size_t xChars, std::size_t yChars) {
+  return Compare(x, y, xChars, yChars);
 }
 
 int RTNAME(CharacterCompareScalar4)(const char32_t *x, const char32_t *y,
-    std::size_t xBytes, std::size_t yBytes) {
-  return Compare<char32_t, 2>(x, y, xBytes, yBytes);
+    std::size_t xChars, std::size_t yChars) {
+  return Compare(x, y, xChars, yChars);
 }
 
 void RTNAME(CharacterCompare)(
-    Descriptor &, const Descriptor &, const Descriptor &) {
-  // TODO real soon once there's type codes for character(kind=2 & 4)
+    Descriptor &result, const Descriptor &x, const Descriptor &y) {
+  Terminator terminator{__FILE__, __LINE__};
+  RUNTIME_CHECK(terminator, x.raw().type == y.raw().type);
+  switch (x.raw().type) {
+  case CFI_type_char:
+    Compare<char>(result, x, y, terminator);
+    break;
+  case CFI_type_char16_t:
+    Compare<char16_t>(result, x, y, terminator);
+    break;
+  case CFI_type_char32_t:
+    Compare<char32_t>(result, x, y, terminator);
+    break;
+  default:
+    terminator.Crash("CharacterCompareScalar: bad string type code %d",
+        static_cast<int>(x.raw().type));
+  }
 }
 
 std::size_t RTNAME(CharacterAppend1)(char *lhs, std::size_t lhsBytes,
     std::size_t offset, const char *rhs, std::size_t rhsBytes) {
   if (auto n{std::min(lhsBytes - offset, rhsBytes)}) {
     std::memcpy(lhs + offset, rhs, n);
     offset += n;
   }
   return offset;
 }
 
 void RTNAME(CharacterPad1)(char *lhs, std::size_t bytes, std::size_t offset) {
   if (bytes > offset) {
     std::memset(lhs + offset, ' ', bytes - offset);
   }
 }
+
+// Intrinsic functions
+
+void RTNAME(AdjustL)(Descriptor &result, const Descriptor &string,
+    const char *sourceFile, int sourceLine) {
+  AdjustLR<false>(result, string, sourceFile, sourceLine);
+}
+
+void RTNAME(AdjustR)(Descriptor &result, const Descriptor &string,
+    const char *sourceFile, int sourceLine) {
+  AdjustLR<true>(result, string, sourceFile, sourceLine);
+}
+
+std::size_t RTNAME(LenTrim1)(const char *x, std::size_t chars) {
+  return LenTrim(x, chars);
+}
+std::size_t RTNAME(LenTrim2)(const char16_t *x, std::size_t chars) {
+  return LenTrim(x, chars);
+}
+std::size_t RTNAME(LenTrim4)(const char32_t *x, std::size_t chars) {
+  return LenTrim(x, chars);
+}
+
+void RTNAME(LenTrim)(Descriptor &result, const Descriptor &string, int kind,
+    const char *sourceFile, int sourceLine) {
+  Terminator terminator{sourceFile, sourceLine};
+  switch (string.raw().type) {
+  case CFI_type_char:
+    LenTrimKind<char>(result, string, kind, terminator);
+    break;
+  case CFI_type_char16_t:
+    LenTrimKind<char16_t>(result, string, kind, terminator);
+    break;
+  case CFI_type_char32_t:
+    LenTrimKind<char32_t>(result, string, kind, terminator);
+    break;
+  default:
+    terminator.Crash("LEN_TRIM: bad string type code %d",
+        static_cast<int>(string.raw().type));
+  }
+}
+
+void RTNAME(Repeat)(Descriptor &result, const Descriptor &string,
+    std::size_t ncopies, const char *sourceFile, int sourceLine) {
+  Terminator terminator{sourceFile, sourceLine};
+  std::size_t origBytes{string.ElementBytes()};
+  result.Establish(string.type(), origBytes * ncopies, nullptr, 0);
+  if (result.Allocate(nullptr, nullptr) != CFI_SUCCESS) {
+    terminator.Crash("REPEAT could not allocate storage for result");
+  }
+  const char *from{string.OffsetElement()};
+  for (char *to{result.OffsetElement()}; ncopies-- > 0; to += origBytes) {
+    std::memcpy(to, from, origBytes);
+  }
+}
+
+void RTNAME(Trim)(Descriptor &result, const Descriptor &string,
+    const char *sourceFile, int sourceLine) {
+  Terminator terminator{sourceFile, sourceLine};
+  std::size_t resultBytes{0};
+  switch (string.raw().type) {
+  case CFI_type_char:
+    resultBytes =
+        LenTrim(string.OffsetElement<const char>(), string.ElementBytes());
+    break;
+  case CFI_type_char16_t:
+    resultBytes = LenTrim(string.OffsetElement<const char16_t>(),
+                      string.ElementBytes() >> 1)
+        << 1;
+    break;
+  case CFI_type_char32_t:
+    resultBytes = LenTrim(string.OffsetElement<const char32_t>(),
+                      string.ElementBytes() >> 2)
+        << 2;
+    break;
+  default:
+    terminator.Crash(
+        "TRIM: bad string type code %d", static_cast<int>(string.raw().type));
+  }
+  result.Establish(string.type(), resultBytes, nullptr, 0);
+  RUNTIME_CHECK(terminator, result.Allocate(nullptr, nullptr) == CFI_SUCCESS);
+  std::memcmp(result.OffsetElement(), string.OffsetElement(), resultBytes);
+}
+
+void RTNAME(CharacterMax)(Descriptor &accumulator, const Descriptor &x,
+    const char *sourceFile, int sourceLine) {
+  MaxMin<false>(accumulator, x, sourceFile, sourceLine);
+}
+
+void RTNAME(CharacterMin)(Descriptor &accumulator, const Descriptor &x,
+    const char *sourceFile, int sourceLine) {
+  MaxMin<true>(accumulator, x, sourceFile, sourceLine);
+}
+
+// TODO: Character MAXVAL/MINVAL
+// TODO: Character MAXLOC/MINLOC
 }
 } // namespace Fortran::runtime

flang/runtime/descriptor.h

 //===-- runtime/descriptor.h ------------------------------------*- C++ -*-===//
 //
 // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
 // See https://llvm.org/LICENSE.txt for license information.
 // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
 //
 //===----------------------------------------------------------------------===//
 
Descriptor() {
     // later if the descriptor is never established.
     raw_.base_addr = nullptr;
     raw_.f18Addendum = false;
   }
   Descriptor(const Descriptor &);
 
   ~Descriptor();
 
+  static constexpr std::size_t BytesFor(TypeCategory category, int kind) {
+    return category == TypeCategory::Complex ? kind * 2 : kind;
+  }
+
   void Establish(TypeCode t, std::size_t elementBytes, void *p = nullptr,
       int rank = maxRank, const SubscriptValue *extent = nullptr,
       ISO::CFI_attribute_t attribute = CFI_attribute_other,
       bool addendum = false);
   void Establish(TypeCategory, int kind, void *p = nullptr, int rank = maxRank,
       const SubscriptValue *extent = nullptr,
       ISO::CFI_attribute_t attribute = CFI_attribute_other,
       bool addendum = false);
+  void Establish(int characterKind, std::size_t characters, void *p = nullptr,
+      int rank = maxRank, const SubscriptValue *extent = nullptr,
+      ISO::CFI_attribute_t attribute = CFI_attribute_other,
+      bool addendum = false);
   void Establish(const DerivedType &dt, void *p = nullptr, int rank = maxRank,
       const SubscriptValue *extent = nullptr,
       ISO::CFI_attribute_t attribute = CFI_attribute_other);
 
   static OwningPtr<Descriptor> Create(TypeCode t, std::size_t elementBytes,
       void *p = nullptr, int rank = maxRank,
       const SubscriptValue *extent = nullptr,
-      ISO::CFI_attribute_t attribute = CFI_attribute_other);
+      ISO::CFI_attribute_t attribute = CFI_attribute_other,
+      int derivedTypeLenParameters = 0);
   static OwningPtr<Descriptor> Create(TypeCategory, int kind, void *p = nullptr,
       int rank = maxRank, const SubscriptValue *extent = nullptr,
       ISO::CFI_attribute_t attribute = CFI_attribute_other);
+  static OwningPtr<Descriptor> Create(int characterKind,
+      SubscriptValue characters, void *p = nullptr, int rank = maxRank,
+      const SubscriptValue *extent = nullptr,
+      ISO::CFI_attribute_t attribute = CFI_attribute_other);
   static OwningPtr<Descriptor> Create(const DerivedType &dt, void *p = nullptr,
       int rank = maxRank, const SubscriptValue *extent = nullptr,
       ISO::CFI_attribute_t attribute = CFI_attribute_other);
 
   ISO::CFI_cdesc_t &raw() { return raw_; }
   const ISO::CFI_cdesc_t &raw() const { return raw_; }
   std::size_t ElementBytes() const { return raw_.elem_len; }
   int rank() const { return raw_.rank; }
public:
   }
 
   std::size_t SubscriptByteOffset(
       int dim, SubscriptValue subscriptValue) const {
     const Dimension &dimension{GetDimension(dim)};
     return (subscriptValue - dimension.LowerBound()) * dimension.ByteStride();
   }
 
-  std::size_t SubscriptsToByteOffset(const SubscriptValue *subscript) const {
+  std::size_t SubscriptsToByteOffset(const SubscriptValue subscript[]) const {
     std::size_t offset{0};
     for (int j{0}; j < raw_.rank; ++j) {
       offset += SubscriptByteOffset(j, subscript[j]);
     }
     return offset;
   }
 
-  template <typename A> A *OffsetElement(std::size_t offset) const {
+  template <typename A = char> A *OffsetElement(std::size_t offset = 0) const {
     return reinterpret_cast<A *>(
         reinterpret_cast<char *>(raw_.base_addr) + offset);
   }
 
-  template <typename A> A *Element(const SubscriptValue *subscript) const {
+  template <typename A> A *Element(const SubscriptValue subscript[]) const {
     return OffsetElement<A>(SubscriptsToByteOffset(subscript));
   }
 
   template <typename A> A *ZeroBasedIndexedElement(std::size_t n) const {
     SubscriptValue at[maxRank];
     if (SubscriptsForZeroBasedElementNumber(at, n)) {
       return Element<A>(at);
     }
     return nullptr;
   }
 
-  void GetLowerBounds(SubscriptValue *subscript) const {
+  void GetLowerBounds(SubscriptValue subscript[]) const {
     for (int j{0}; j < raw_.rank; ++j) {
       subscript[j] = GetDimension(j).LowerBound();
     }
   }
 
   // When the passed subscript vector contains the last (or first)
   // subscripts of the array, these wrap the subscripts around to
   // their first (or last) values and return false.
   bool IncrementSubscripts(
-      SubscriptValue *, const int *permutation = nullptr) const;
+      SubscriptValue[], const int *permutation = nullptr) const;
   bool DecrementSubscripts(
-      SubscriptValue *, const int *permutation = nullptr) const;
+      SubscriptValue[], const int *permutation = nullptr) const;
   // False when out of range.
   bool SubscriptsForZeroBasedElementNumber(SubscriptValue *,
       std::size_t elementNumber, const int *permutation = nullptr) const;
   std::size_t ZeroBasedElementNumber(
       const SubscriptValue *, const int *permutation = nullptr) const;
 
   DescriptorAddendum *Addendum() {
     if (raw_.f18Addendum != 0) {
static constexpr std::size_t SizeInBytes(
     }
     return bytes;
   }
 
   std::size_t SizeInBytes() const;
 
   std::size_t Elements() const;
 
-  int Allocate(const SubscriptValue lb[], const SubscriptValue ub[],
-      std::size_t charLen = 0); // TODO: SOURCE= and MOLD=
+  // TODO: SOURCE= and MOLD=
+  int Allocate(const SubscriptValue lb[], const SubscriptValue ub[]);
   int Deallocate(bool finalize = true);
   void Destroy(char *data, bool finalize = true) const;
 
   bool IsContiguous(int leadingDimensions = maxRank) const {
     auto bytes{static_cast<SubscriptValue>(ElementBytes())};
     for (int j{0}; j < leadingDimensions && j < raw_.rank; ++j) {
       const Dimension &dim{GetDimension(j)};
       if (bytes != dim.ByteStride()) {

flang/runtime/descriptor.cpp

 //===-- runtime/descriptor.cpp --------------------------------------------===//
 //
 // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
 // See https://llvm.org/LICENSE.txt for license information.
 // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
 //
 //===----------------------------------------------------------------------===//
 
void Descriptor::Establish(TypeCode t, std::size_t elementBytes, void *p,
   if (a) {
     new (a) DescriptorAddendum{};
   }
 }
 
 void Descriptor::Establish(TypeCategory c, int kind, void *p, int rank,
     const SubscriptValue *extent, ISO::CFI_attribute_t attribute,
     bool addendum) {
-  std::size_t elementBytes = kind;
-  if (c == TypeCategory::Complex) {
-    elementBytes *= 2;
-  }
-  Terminator terminator{__FILE__, __LINE__};
-  RUNTIME_CHECK(terminator,
-      ISO::CFI_establish(&raw_, p, attribute, TypeCode(c, kind).raw(),
-          elementBytes, rank, extent) == CFI_SUCCESS);
-  raw_.f18Addendum = addendum;
-  DescriptorAddendum *a{Addendum()};
-  RUNTIME_CHECK(terminator, addendum == (a != nullptr));
-  if (a) {
-    new (a) DescriptorAddendum{};
-  }
+  Establish(TypeCode(c, kind), BytesFor(c, kind), p, rank, extent, attribute,
+      addendum);
+
+void Descriptor::Establish(int characterKind, std::size_t characters, void *p,
+    int rank, const SubscriptValue *extent, ISO::CFI_attribute_t attribute,
+    bool addendum) {
+  Establish(TypeCode{TypeCategory::Character, characterKind},
+      characterKind * characters, p, rank, extent, attribute, addendum);
 }
 
 void Descriptor::Establish(const DerivedType &dt, void *p, int rank,
     const SubscriptValue *extent, ISO::CFI_attribute_t attribute) {
-  Terminator terminator{__FILE__, __LINE__};
-  RUNTIME_CHECK(terminator,
-      ISO::CFI_establish(&raw_, p, attribute, CFI_type_struct, dt.SizeInBytes(),
-          rank, extent) == CFI_SUCCESS);
-  raw_.f18Addendum = true;
+  Establish(
+      CFI_type_struct, dt.SizeInBytes(), p, rank, extent, attribute, true);
   DescriptorAddendum *a{Addendum()};
-  RUNTIME_CHECK(terminator, a);
+  Terminator terminator{__FILE__, __LINE__};
+  RUNTIME_CHECK(terminator, a != nullptr);
   new (a) DescriptorAddendum{&dt};
 }
 
 OwningPtr<Descriptor> Descriptor::Create(TypeCode t, std::size_t elementBytes,
     void *p, int rank, const SubscriptValue *extent,
-    ISO::CFI_attribute_t attribute) {
-  std::size_t bytes{SizeInBytes(rank, true)};
+    ISO::CFI_attribute_t attribute, int derivedTypeLenParameters) {
+  std::size_t bytes{SizeInBytes(rank, true, derivedTypeLenParameters)};
   Terminator terminator{__FILE__, __LINE__};
   Descriptor *result{
       reinterpret_cast<Descriptor *>(AllocateMemoryOrCrash(terminator, bytes))};
   result->Establish(t, elementBytes, p, rank, extent, attribute, true);
   return OwningPtr<Descriptor>{result};
 }
 
 OwningPtr<Descriptor> Descriptor::Create(TypeCategory c, int kind, void *p,
     int rank, const SubscriptValue *extent, ISO::CFI_attribute_t attribute) {
-  std::size_t bytes{SizeInBytes(rank, true)};
-  Terminator terminator{__FILE__, __LINE__};
-  Descriptor *result{
-      reinterpret_cast<Descriptor *>(AllocateMemoryOrCrash(terminator, bytes))};
-  result->Establish(c, kind, p, rank, extent, attribute, true);
-  return OwningPtr<Descriptor>{result};
+  return Create(
+      TypeCode(c, kind), BytesFor(c, kind), p, rank, extent, attribute);
+}
+
+OwningPtr<Descriptor> Descriptor::Create(int characterKind,
+    SubscriptValue characters, void *p, int rank, const SubscriptValue *extent,
+    ISO::CFI_attribute_t attribute) {
+  return Create(TypeCode{TypeCategory::Character, characterKind},
+      characterKind * characters, p, rank, extent, attribute);
 }
 
 OwningPtr<Descriptor> Descriptor::Create(const DerivedType &dt, void *p,
     int rank, const SubscriptValue *extent, ISO::CFI_attribute_t attribute) {
-  std::size_t bytes{SizeInBytes(rank, true, dt.lenParameters())};
-  Terminator terminator{__FILE__, __LINE__};
-  Descriptor *result{
-      reinterpret_cast<Descriptor *>(AllocateMemoryOrCrash(terminator, bytes))};
-  result->Establish(dt, p, rank, extent, attribute);
-  return OwningPtr<Descriptor>{result};
+  return Create(TypeCode{CFI_type_struct}, dt.SizeInBytes(), p, rank, extent,
+      attribute, dt.lenParameters());
 }
 
 std::size_t Descriptor::SizeInBytes() const {
   const DescriptorAddendum *addendum{Addendum()};
   return sizeof *this - sizeof(Dimension) + raw_.rank * sizeof(Dimension) +
       (addendum ? addendum->SizeInBytes() : 0);
 }
 
 std::size_t Descriptor::Elements() const {
   int n{rank()};
   std::size_t elements{1};
   for (int j{0}; j < n; ++j) {
     elements *= GetDimension(j).Extent();
   }
   return elements;
 }
 
-int Descriptor::Allocate(
-    const SubscriptValue lb[], const SubscriptValue ub[], std::size_t charLen) {
-  int result{ISO::CFI_allocate(&raw_, lb, ub, charLen)};
+int Descriptor::Allocate(const SubscriptValue lb[], const SubscriptValue ub[]) {
+  int result{ISO::CFI_allocate(&raw_, lb, ub, ElementBytes())};
   if (result == CFI_SUCCESS) {
     // TODO: derived type initialization
   }
   return result;
 }
 
 int Descriptor::Deallocate(bool finalize) {
   if (raw_.base_addr) {

flang/runtime/lock.h

 //===-- runtime/lock.h ------------------------------------------*- C++ -*-===//
 //
 // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
 // See https://llvm.org/LICENSE.txt for license information.
 // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
 //
 //===----------------------------------------------------------------------===//
 
 // Wraps a mutex
 
 #ifndef FORTRAN_RUNTIME_LOCK_H_
 #define FORTRAN_RUNTIME_LOCK_H_
 
 #include "terminator.h"
+
+// Avoid <mutex> if possible to avoid introduction of C++ runtime
+// library dependence.
+#ifndef _WIN32
+#define USE_PTHREADS 1
+#else
+#undef USE_PTHREADS
+#endif
+
+#if USE_PTHREADS
+#include <pthread.h>
+#else
 #include <mutex>
+#endif
 
 namespace Fortran::runtime {
 
 class Lock {
 public:
+#if USE_PTHREADS
+  Lock() { pthread_mutex_init(&mutex_, nullptr); }
+  ~Lock() { pthread_mutex_destroy(&mutex_); }
+  void Take() {
+    while (pthread_mutex_lock(&mutex_)) {
+    }
+  }
+  bool Try() { return pthread_mutex_trylock(&mutex_) == 0; }
+  void Drop() { pthread_mutex_unlock(&mutex_); }
+#else
   void Take() { mutex_.lock(); }
   bool Try() { return mutex_.try_lock(); }
   void Drop() { mutex_.unlock(); }
+#endif
+
   void CheckLocked(const Terminator &terminator) {
     if (Try()) {
       Drop();
       terminator.Crash("Lock::CheckLocked() failed");
     }
   }
 
 private:
+#if USE_PTHREADS
+  pthread_mutex_t mutex_{};
+#else
   std::mutex mutex_;
+#endif
 };
 
 class CriticalSection {
 public:
   explicit CriticalSection(Lock &lock) : lock_{lock} { lock_.Take(); }
   ~CriticalSection() { lock_.Drop(); }
 
 private:
   Lock &lock_;
 };
 } // namespace Fortran::runtime
 
 #endif // FORTRAN_RUNTIME_LOCK_H_

flang/runtime/transformational.cpp

 //===-- runtime/transformational.cpp --------------------------------------===//
 //
 // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
 // See https://llvm.org/LICENSE.txt for license information.
 // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
 //
 //===----------------------------------------------------------------------===//
 
OwningPtr<Descriptor> RESHAPE(const Descriptor &source, const Descriptor &shape,
   if (sourceDerivedType) {
     std::size_t lenParameters{sourceDerivedType->lenParameters()};
     for (std::size_t j{0}; j < lenParameters; ++j) {
       resultAddendum->SetLenParameterValue(
           j, sourceAddendum->LenParameterValue(j));
     }
   }
   // Allocate storage for the result's data.
-  int status{result->Allocate(lowerBound, resultExtent, elementBytes)};
+  int status{result->Allocate(lowerBound, resultExtent)};
   if (status != CFI_SUCCESS) {
     terminator.Crash("RESHAPE: Allocate failed (error %d)", status);
   }
 
   // Populate the result's elements.
   SubscriptValue resultSubscript[maxRank];
   result->GetLowerBounds(resultSubscript);
   SubscriptValue sourceSubscript[maxRank];

flang/runtime/type-code.h

 //===-- runtime/type-code.h -------------------------------------*- C++ -*-===//
 //
 // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
 // See https://llvm.org/LICENSE.txt for license information.
 // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
 //
 //===----------------------------------------------------------------------===//
 
 #ifndef FORTRAN_RUNTIME_TYPE_CODE_H_
 #define FORTRAN_RUNTIME_TYPE_CODE_H_
 
 #include "flang/Common/Fortran.h"
 #include "flang/ISO_Fortran_binding.h"
 
 namespace Fortran::runtime {
 
 using common::TypeCategory;
 
 class TypeCode {
 public:
   TypeCode() {}
   explicit TypeCode(ISO::CFI_type_t t) : raw_{t} {}
-  TypeCode(TypeCategory, int);
+  TypeCode(TypeCategory, int kind);
 
   int raw() const { return raw_; }
 
   constexpr bool IsValid() const {
-    return raw_ >= CFI_type_signed_char && raw_ <= CFI_type_struct;
+    return raw_ >= CFI_type_signed_char && raw_ <= CFI_TYPE_LAST;
   }
   constexpr bool IsInteger() const {
     return raw_ >= CFI_type_signed_char && raw_ <= CFI_type_ptrdiff_t;
   }
   constexpr bool IsReal() const {
     return raw_ >= CFI_type_float && raw_ <= CFI_type_long_double;
   }
   constexpr bool IsComplex() const {
     return raw_ >= CFI_type_float_Complex &&
         raw_ <= CFI_type_long_double_Complex;
   }
-  constexpr bool IsCharacter() const { return raw_ == CFI_type_char; }
+  constexpr bool IsCharacter() const {
+    return raw_ == CFI_type_char || raw_ == CFI_type_char16_t ||
+        raw_ == CFI_type_char32_t;
+  }
   constexpr bool IsLogical() const { return raw_ == CFI_type_Bool; }
   constexpr bool IsDerived() const { return raw_ == CFI_type_struct; }
-
   constexpr bool IsIntrinsic() const { return IsValid() && !IsDerived(); }
 
-  constexpr TypeCategory Categorize() const {
-    if (IsInteger()) {
-      return TypeCategory::Integer;
-    }
-    if (IsReal()) {
-      return TypeCategory::Real;
-    }
-    if (IsComplex()) {
-      return TypeCategory::Complex;
-    }
-    if (IsCharacter()) {
-      return TypeCategory::Character;
-    }
-    if (IsLogical()) {
-      return TypeCategory::Logical;
-    }
-    return TypeCategory::Derived;
-  }
-
 private:
   ISO::CFI_type_t raw_{CFI_type_other};
 };
 } // namespace Fortran::runtime
 #endif // FORTRAN_RUNTIME_TYPE_CODE_H_

flang/runtime/type-code.cpp

 //===-- runtime/type-code.cpp ---------------------------------------------===//
 //
 // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
 // See https://llvm.org/LICENSE.txt for license information.
 // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
 //
 //===----------------------------------------------------------------------===//
 
case 8:
       break;
     case 10:
     case 16:
       raw_ = CFI_type_long_double_Complex;
       break;
     }
     break;
   case TypeCategory::Character:
-    if (kind == 1) {
+    switch (kind) {
+    case 1:
       raw_ = CFI_type_char;
+      break;
+    case 2:
+      raw_ = CFI_type_char16_t;
+      break;
+    case 4:
+      raw_ = CFI_type_char32_t;
+      break;
     }
     break;
   case TypeCategory::Logical:
     switch (kind) {
     case 1:
       raw_ = CFI_type_Bool;
       break;
     case 2:

flang/unittests/Evaluate/reshape.cpp

 #include "testing.h"
 #include "../../runtime/descriptor.h"
 #include "../../runtime/transformational.h"
 #include <cinttypes>
 
 using namespace Fortran::common;
 using namespace Fortran::runtime;
 
 int main() {
   static const SubscriptValue ones[]{1, 1, 1};
   static const SubscriptValue sourceExtent[]{2, 3, 4};
   auto source{Descriptor::Create(TypeCategory::Integer, sizeof(std::int32_t),
       nullptr, 3, sourceExtent, CFI_attribute_allocatable)};
   source->Check();
   MATCH(3, source->rank());
   MATCH(sizeof(std::int32_t), source->ElementBytes());
   TEST(source->IsAllocatable());
   TEST(!source->IsPointer());
-  TEST(source->Allocate(ones, sourceExtent, sizeof(std::int32_t)) ==
-      CFI_SUCCESS);
+  TEST(source->Allocate(ones, sourceExtent) == CFI_SUCCESS);
   TEST(source->IsAllocated());
   MATCH(2, source->GetDimension(0).Extent());
   MATCH(3, source->GetDimension(1).Extent());
   MATCH(4, source->GetDimension(2).Extent());
   MATCH(24, source->Elements());
   for (std::size_t j{0}; j < 24; ++j) {
     *source->OffsetElement<std::int32_t>(j * sizeof(std::int32_t)) = j;
   }