diff --git a/flang/include/flang/ISO_Fortran_binding.h b/flang/include/flang/ISO_Fortran_binding.h --- a/flang/include/flang/ISO_Fortran_binding.h +++ b/flang/include/flang/ISO_Fortran_binding.h @@ -44,7 +44,6 @@ /* 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 @@ -56,7 +55,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 @@ -80,6 +79,9 @@ #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 */ diff --git a/flang/runtime/ISO_Fortran_binding.cpp b/flang/runtime/ISO_Fortran_binding.cpp --- a/flang/runtime/ISO_Fortran_binding.cpp +++ b/flang/runtime/ISO_Fortran_binding.cpp @@ -17,7 +17,8 @@ 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; @@ -201,6 +202,12 @@ 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; } diff --git a/flang/runtime/character.h b/flang/runtime/character.h --- a/flang/runtime/character.h +++ b/flang/runtime/character.h @@ -21,20 +21,24 @@ 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, @@ -50,11 +54,11 @@ // 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. @@ -70,6 +74,39 @@ // 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_ diff --git a/flang/runtime/character.cpp b/flang/runtime/character.cpp --- a/flang/runtime/character.cpp +++ b/flang/runtime/character.cpp @@ -9,13 +9,15 @@ #include "character.h" #include "descriptor.h" #include "terminator.h" +#include "flang/Common/bit-population-count.h" +#include "flang/Common/uint128.h" #include #include namespace Fortran::runtime { -template -inline int CompareToBlankPadding(const C *x, std::size_t chars) { +template +inline int CompareToBlankPadding(const CHAR *x, std::size_t chars) { for (; chars-- > 0; ++x) { if (*x < ' ') { return -1; @@ -27,26 +29,26 @@ return 0; } -template +template 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; } @@ -55,53 +57,540 @@ } } } - 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); +} + +// Shift count to use when converting between character lengths +// and byte counts. +template +constexpr int shift{common::TrailingZeroBitCount(sizeof(CHAR))}; + +template +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(xUB), + static_cast(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}; + std::size_t yChars{y.ElementBytes() >> shift}; + for (SubscriptValue resultAt{0}; elements-- > 0; + ++resultAt, x.IncrementSubscripts(xAt), y.IncrementSubscripts(yAt)) { + *result.OffsetElement(resultAt) = + Compare(x.Element(xAt), y.Element(yAt), xChars, yChars); + } +} + +template +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 +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(result.OffsetElement(resultAt), + string.Element(stringAt), elementBytes >> shift); + } +} + +template +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(result, string, terminator); + break; + case CFI_type_char16_t: + AdjustLRHelper(result, string, terminator); + break; + case CFI_type_char32_t: + AdjustLRHelper(result, string, terminator); + break; + default: + terminator.Crash("ADJUSTL/R: bad string type code %d", + static_cast(string.raw().type)); + } +} + +template +inline std::size_t LenTrim(const CHAR *x, std::size_t chars) { + while (chars > 0 && x[chars - 1] == ' ') { + --chars; + } + return chars; +} + +template +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}; + for (SubscriptValue resultAt{0}; elements-- > 0; + resultAt += sizeof(INT), string.IncrementSubscripts(stringAt)) { + *result.OffsetElement(resultAt) = + LenTrim(string.Element(stringAt), stringElementChars); + } +} + +template +static void LenTrimKind(Descriptor &result, const Descriptor &string, int kind, + const Terminator &terminator) { + switch (kind) { + case 1: + LenTrim(result, string, terminator); + break; + case 2: + LenTrim(result, string, terminator); + break; + case 4: + LenTrim(result, string, terminator); + break; + case 8: + LenTrim(result, string, terminator); + break; + case 16: + LenTrim(result, string, terminator); + break; + default: + terminator.Crash("LEN_TRIM: bad KIND=%d", kind); + } +} + +template +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(' '); + } + } else if (toChars <= fromChars) { + std::memcpy(to, from, toChars * shift); + } else { + std::memcpy(to, from, fromChars * shift); + for (std::size_t j{fromChars}; j < toChars; ++j) { + to[j] = static_cast(' '); + } + } +} + +template +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}; + std::size_t xChars{x.ElementBytes() >> shift}; + 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(accumExt), + static_cast(ub[j])); + } + } + } else { + ub[j] = accumulator.GetDimension(j).Extent(); + xAt[j] = 1; + } + elements *= ub[j]; + } + void *old{nullptr}; + const CHAR *accumData{accumulator.OffsetElement()}; + if (reallocate) { + old = accumulator.raw().base_addr; + accumulator.set_base_addr(nullptr); + accumulator.raw().elem_len = chars << shift; + RUNTIME_CHECK(terminator, accumulator.Allocate(lb, ub) == CFI_SUCCESS); + } + for (CHAR *result{accumulator.OffsetElement()}; elements-- > 0; + accumData += accumChars, result += chars, x.IncrementSubscripts(xAt)) { + const CHAR *xData{x.Element(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 +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(accumulator, x, terminator); + break; + case CFI_type_char16_t: + MaxMinHelper(accumulator, x, terminator); + break; + case CFI_type_char32_t: + MaxMinHelper(accumulator, x, terminator); + break; + default: + terminator.Crash( + "Character MAX/MIN: result does not have a character type"); + } } extern "C" { -void RTNAME(CharacterConcatenate)(Descriptor & /*temp*/, - const Descriptor & /*operand*/, const char * /*sourceFile*/, - int /*sourceLine*/) { - // TODO +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(ub[j]), + static_cast(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(old)}; + char *to{static_cast(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(fromAt), fromBytes); + } + FreeMemory(old); } -void RTNAME(CharacterConcatenateScalar)( - Descriptor & /*temp*/, const char * /*from*/, std::size_t /*byteLength*/) { - // TODO +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(oldLen), from, chars); + FreeMemory(old); } -void RTNAME(CharacterAssign)(Descriptor & /*lhs*/, const Descriptor & /*rhs*/, - const char * /*sourceFile*/, int /*sourceLine*/) { - // TODO +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(lhsExt), + static_cast(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(lhsAt), rhs.Element(rhsAt), lhsBytes, + rhsBytes); + } + break; + case CFI_type_char16_t: + for (; elements-- > 0; + lhs.IncrementSubscripts(lhsAt), rhs.IncrementSubscripts(rhsAt)) { + CopyAndPad(lhs.Element(lhsAt), rhs.Element(rhsAt), + lhsBytes, rhsBytes >> 1); + } + break; + case CFI_type_char32_t: + for (; elements-- > 0; + lhs.IncrementSubscripts(lhsAt), rhs.IncrementSubscripts(rhsAt)) { + CopyAndPad(lhs.Element(lhsAt), rhs.Element(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(lhsAt), rhs.Element(rhsAt), + lhsBytes >> 1, rhsBytes); + } + break; + case CFI_type_char16_t: + for (; elements-- > 0; + lhs.IncrementSubscripts(lhsAt), rhs.IncrementSubscripts(rhsAt)) { + CopyAndPad(lhs.Element(lhsAt), rhs.Element(rhsAt), + lhsBytes >> 1, rhsBytes >> 1); + } + break; + case CFI_type_char32_t: + for (; elements-- > 0; + lhs.IncrementSubscripts(lhsAt), rhs.IncrementSubscripts(rhsAt)) { + CopyAndPad(lhs.Element(lhsAt), rhs.Element(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(lhsAt), rhs.Element(rhsAt), + lhsBytes >> 2, rhsBytes); + } + break; + case CFI_type_char16_t: + for (; elements-- > 0; + lhs.IncrementSubscripts(lhsAt), rhs.IncrementSubscripts(rhsAt)) { + CopyAndPad(lhs.Element(lhsAt), rhs.Element(rhsAt), + lhsBytes >> 2, rhsBytes >> 1); + } + break; + case CFI_type_char32_t: + for (; elements-- > 0; + lhs.IncrementSubscripts(lhsAt), rhs.IncrementSubscripts(rhsAt)) { + CopyAndPad(lhs.Element(lhsAt), rhs.Element(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 &, const Descriptor &) { - // TODO real soon once there's type codes for character(kind=2 & 4) +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(), y.OffsetElement(), + x.ElementBytes(), y.ElementBytes()); + case CFI_type_char16_t: + return Compare(x.OffsetElement(), y.OffsetElement(), + x.ElementBytes() >> 1, y.ElementBytes() >> 1); + case CFI_type_char32_t: + return Compare(x.OffsetElement(), y.OffsetElement(), + x.ElementBytes() >> 2, y.ElementBytes() >> 2); + default: + terminator.Crash("CharacterCompareScalar: bad string type code %d", + static_cast(x.raw().type)); + } return 0; } int RTNAME(CharacterCompareScalar1)( - const char *x, const char *y, std::size_t xBytes, std::size_t yBytes) { - return Compare(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(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(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(result, x, y, terminator); + break; + case CFI_type_char16_t: + Compare(result, x, y, terminator); + break; + case CFI_type_char32_t: + Compare(result, x, y, terminator); + break; + default: + terminator.Crash("CharacterCompareScalar: bad string type code %d", + static_cast(x.raw().type)); + } } std::size_t RTNAME(CharacterAppend1)(char *lhs, std::size_t lhsBytes, @@ -118,5 +607,101 @@ std::memset(lhs + offset, ' ', bytes - offset); } } + +// Intrinsic functions + +void RTNAME(AdjustL)(Descriptor &result, const Descriptor &string, + const char *sourceFile, int sourceLine) { + AdjustLR(result, string, sourceFile, sourceLine); +} + +void RTNAME(AdjustR)(Descriptor &result, const Descriptor &string, + const char *sourceFile, int sourceLine) { + AdjustLR(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(result, string, kind, terminator); + break; + case CFI_type_char16_t: + LenTrimKind(result, string, kind, terminator); + break; + case CFI_type_char32_t: + LenTrimKind(result, string, kind, terminator); + break; + default: + terminator.Crash("LEN_TRIM: bad string type code %d", + static_cast(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(), string.ElementBytes()); + break; + case CFI_type_char16_t: + resultBytes = LenTrim(string.OffsetElement(), + string.ElementBytes() >> 1) + << 1; + break; + case CFI_type_char32_t: + resultBytes = LenTrim(string.OffsetElement(), + string.ElementBytes() >> 2) + << 2; + break; + default: + terminator.Crash( + "TRIM: bad string type code %d", static_cast(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(accumulator, x, sourceFile, sourceLine); +} + +void RTNAME(CharacterMin)(Descriptor &accumulator, const Descriptor &x, + const char *sourceFile, int sourceLine) { + MaxMin(accumulator, x, sourceFile, sourceLine); +} + +// TODO: Character MAXVAL/MINVAL +// TODO: Character MAXLOC/MINLOC } } // namespace Fortran::runtime diff --git a/flang/runtime/descriptor.h b/flang/runtime/descriptor.h --- a/flang/runtime/descriptor.h +++ b/flang/runtime/descriptor.h @@ -129,6 +129,10 @@ ~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, @@ -137,6 +141,10 @@ 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); @@ -144,10 +152,15 @@ static OwningPtr 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 Create(TypeCategory, int kind, void *p = nullptr, int rank = maxRank, const SubscriptValue *extent = nullptr, ISO::CFI_attribute_t attribute = CFI_attribute_other); + static OwningPtr 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 Create(const DerivedType &dt, void *p = nullptr, int rank = maxRank, const SubscriptValue *extent = nullptr, ISO::CFI_attribute_t attribute = CFI_attribute_other); @@ -182,7 +195,7 @@ 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]); @@ -190,12 +203,12 @@ return offset; } - template A *OffsetElement(std::size_t offset) const { + template A *OffsetElement(std::size_t offset = 0) const { return reinterpret_cast( reinterpret_cast(raw_.base_addr) + offset); } - template A *Element(const SubscriptValue *subscript) const { + template A *Element(const SubscriptValue subscript[]) const { return OffsetElement(SubscriptsToByteOffset(subscript)); } @@ -207,7 +220,7 @@ 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(); } @@ -217,9 +230,9 @@ // 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; @@ -256,8 +269,8 @@ 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; diff --git a/flang/runtime/descriptor.cpp b/flang/runtime/descriptor.cpp --- a/flang/runtime/descriptor.cpp +++ b/flang/runtime/descriptor.cpp @@ -43,38 +43,31 @@ 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::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(AllocateMemoryOrCrash(terminator, bytes))}; @@ -84,22 +77,21 @@ OwningPtr 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(AllocateMemoryOrCrash(terminator, bytes))}; - result->Establish(c, kind, p, rank, extent, attribute, true); - return OwningPtr{result}; + return Create( + TypeCode(c, kind), BytesFor(c, kind), p, rank, extent, attribute); +} + +OwningPtr 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::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(AllocateMemoryOrCrash(terminator, bytes))}; - result->Establish(dt, p, rank, extent, attribute); - return OwningPtr{result}; + return Create(TypeCode{CFI_type_struct}, dt.SizeInBytes(), p, rank, extent, + attribute, dt.lenParameters()); } std::size_t Descriptor::SizeInBytes() const { @@ -117,9 +109,8 @@ 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 } diff --git a/flang/runtime/lock.h b/flang/runtime/lock.h --- a/flang/runtime/lock.h +++ b/flang/runtime/lock.h @@ -12,15 +12,40 @@ #define FORTRAN_RUNTIME_LOCK_H_ #include "terminator.h" + +// Avoid 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 +#else #include +#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(); @@ -29,7 +54,11 @@ } private: +#if USE_PTHREADS + pthread_mutex_t mutex_{}; +#else std::mutex mutex_; +#endif }; class CriticalSection { diff --git a/flang/runtime/transformational.cpp b/flang/runtime/transformational.cpp --- a/flang/runtime/transformational.cpp +++ b/flang/runtime/transformational.cpp @@ -113,7 +113,7 @@ } } // 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); } diff --git a/flang/runtime/type-code.h b/flang/runtime/type-code.h --- a/flang/runtime/type-code.h +++ b/flang/runtime/type-code.h @@ -20,12 +20,12 @@ 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; @@ -37,31 +37,14 @@ 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}; }; diff --git a/flang/runtime/type-code.cpp b/flang/runtime/type-code.cpp --- a/flang/runtime/type-code.cpp +++ b/flang/runtime/type-code.cpp @@ -60,8 +60,16 @@ } 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: diff --git a/flang/unittests/Evaluate/reshape.cpp b/flang/unittests/Evaluate/reshape.cpp --- a/flang/unittests/Evaluate/reshape.cpp +++ b/flang/unittests/Evaluate/reshape.cpp @@ -16,8 +16,7 @@ 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());