//===-- runtime/edit-input.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 // //===----------------------------------------------------------------------===// #include "edit-input.h" #include "namelist.h" #include "utf.h" #include "flang/Common/optional.h" #include "flang/Common/real.h" #include "flang/Common/uint128.h" #include "flang/Runtime/freestanding-tools.h" #include #include namespace Fortran::runtime::io { RT_OFFLOAD_API_GROUP_BEGIN // Checks that a list-directed input value has been entirely consumed and // doesn't contain unparsed characters before the next value separator. static inline RT_API_ATTRS bool IsCharValueSeparator( const DataEdit &edit, char32_t ch) { char32_t comma{ edit.modes.editingFlags & decimalComma ? char32_t{';'} : char32_t{','}}; return ch == ' ' || ch == '\t' || ch == comma || ch == '/' || (edit.IsNamelist() && (ch == '&' || ch == '$')); } static RT_API_ATTRS bool CheckCompleteListDirectedField( IoStatementState &io, const DataEdit &edit) { if (edit.IsListDirected()) { std::size_t byteCount; if (auto ch{io.GetCurrentChar(byteCount)}) { if (IsCharValueSeparator(edit, *ch)) { return true; } else { const auto &connection{io.GetConnectionState()}; io.GetIoErrorHandler().SignalError(IostatBadListDirectedInputSeparator, "invalid character (0x%x) after list-directed input value, " "at column %d in record %d", static_cast(*ch), static_cast(connection.positionInRecord + 1), static_cast(connection.currentRecordNumber)); return false; } } else { return true; // end of record: ok } } else { return true; } } static inline RT_API_ATTRS char32_t GetSeparatorChar(const DataEdit &edit) { return edit.modes.editingFlags & decimalComma ? char32_t{';'} : char32_t{','}; } template static RT_API_ATTRS bool EditBOZInput( IoStatementState &io, const DataEdit &edit, void *n, std::size_t bytes) { // Skip leading white space & zeroes Fortran::common::optional remaining{io.CueUpInput(edit)}; auto start{io.GetConnectionState().positionInRecord}; Fortran::common::optional next{io.NextInField(remaining, edit)}; if (next.value_or('?') == '0') { do { start = io.GetConnectionState().positionInRecord; next = io.NextInField(remaining, edit); } while (next && *next == '0'); } // Count significant digits after any leading white space & zeroes int digits{0}; int significantBits{0}; const char32_t comma{GetSeparatorChar(edit)}; for (; next; next = io.NextInField(remaining, edit)) { char32_t ch{*next}; if (ch == ' ' || ch == '\t') { if (edit.modes.editingFlags & blankZero) { ch = '0'; // BZ mode - treat blank as if it were zero } else { continue; } } if (ch >= '0' && ch <= '1') { } else if (LOG2_BASE >= 3 && ch >= '2' && ch <= '7') { } else if (LOG2_BASE >= 4 && ch >= '8' && ch <= '9') { } else if (LOG2_BASE >= 4 && ch >= 'A' && ch <= 'F') { } else if (LOG2_BASE >= 4 && ch >= 'a' && ch <= 'f') { } else if (ch == comma) { break; // end non-list-directed field early } else { io.GetIoErrorHandler().SignalError( "Bad character '%lc' in B/O/Z input field", ch); return false; } if (digits++ == 0) { if (ch >= '0' && ch <= '1') { significantBits = 1; } else if (ch >= '2' && ch <= '3') { significantBits = 2; } else if (ch >= '4' && ch <= '7') { significantBits = 3; } else { significantBits = 4; } } else { significantBits += LOG2_BASE; } } auto significantBytes{static_cast(significantBits + 7) / 8}; if (significantBytes > bytes) { io.GetIoErrorHandler().SignalError(IostatBOZInputOverflow, "B/O/Z input of %d digits overflows %zd-byte variable", digits, bytes); return false; } // Reset to start of significant digits io.HandleAbsolutePosition(start); remaining.reset(); // Make a second pass now that the digit count is known std::memset(n, 0, bytes); int increment{isHostLittleEndian ? -1 : 1}; auto *data{reinterpret_cast(n) + (isHostLittleEndian ? significantBytes - 1 : bytes - significantBytes)}; int bitsAfterFirstDigit{(digits - 1) * LOG2_BASE}; int shift{bitsAfterFirstDigit & 7}; if (shift + (significantBits - bitsAfterFirstDigit) > 8) { shift = shift - 8; // misaligned octal } while (digits > 0) { char32_t ch{io.NextInField(remaining, edit).value_or(' ')}; int digit{0}; if (ch == ' ' || ch == '\t') { if (edit.modes.editingFlags & blankZero) { ch = '0'; // BZ mode - treat blank as if it were zero } else { continue; } } --digits; if (ch >= '0' && ch <= '9') { digit = ch - '0'; } else if (ch >= 'A' && ch <= 'F') { digit = ch + 10 - 'A'; } else if (ch >= 'a' && ch <= 'f') { digit = ch + 10 - 'a'; } else { continue; } if (shift < 0) { if (shift + LOG2_BASE > 0) { // misaligned octal *data |= digit >> -shift; } shift += 8; data += increment; } *data |= digit << shift; shift -= LOG2_BASE; } return CheckCompleteListDirectedField(io, edit); } static inline RT_API_ATTRS char32_t GetRadixPointChar(const DataEdit &edit) { return edit.modes.editingFlags & decimalComma ? char32_t{','} : char32_t{'.'}; } // Prepares input from a field, and returns the sign, if any, else '\0'. static RT_API_ATTRS char ScanNumericPrefix(IoStatementState &io, const DataEdit &edit, Fortran::common::optional &next, Fortran::common::optional &remaining) { remaining = io.CueUpInput(edit); next = io.NextInField(remaining, edit); char sign{'\0'}; if (next) { if (*next == '-' || *next == '+') { sign = *next; if (!edit.IsListDirected()) { io.SkipSpaces(remaining); } next = io.NextInField(remaining, edit); } } return sign; } RT_API_ATTRS bool EditIntegerInput(IoStatementState &io, const DataEdit &edit, void *n, int kind, bool isSigned) { RUNTIME_CHECK(io.GetIoErrorHandler(), kind >= 1 && !(kind & (kind - 1))); switch (edit.descriptor) { case DataEdit::ListDirected: if (IsNamelistNameOrSlash(io)) { return false; } break; case 'G': case 'I': break; case 'B': return EditBOZInput<1>(io, edit, n, kind); case 'O': return EditBOZInput<3>(io, edit, n, kind); case 'Z': return EditBOZInput<4>(io, edit, n, kind); case 'A': // legacy extension return EditCharacterInput(io, edit, reinterpret_cast(n), kind); default: io.GetIoErrorHandler().SignalError(IostatErrorInFormat, "Data edit descriptor '%c' may not be used with an INTEGER data item", edit.descriptor); return false; } Fortran::common::optional remaining; Fortran::common::optional next; char sign{ScanNumericPrefix(io, edit, next, remaining)}; if (sign == '-' && !isSigned) { io.GetIoErrorHandler().SignalError("Negative sign in UNSIGNED input field"); return false; } common::UnsignedInt128 value{0}; bool any{!!sign}; bool overflow{false}; const char32_t comma{GetSeparatorChar(edit)}; static constexpr auto maxu128{~common::UnsignedInt128{0}}; for (; next; next = io.NextInField(remaining, edit)) { char32_t ch{*next}; if (ch == ' ' || ch == '\t') { if (edit.modes.editingFlags & blankZero) { ch = '0'; // BZ mode - treat blank as if it were zero } else { continue; } } int digit{0}; if (ch >= '0' && ch <= '9') { digit = ch - '0'; } else if (ch == comma) { break; // end non-list-directed field early } else { if (edit.modes.inNamelist && ch == GetRadixPointChar(edit)) { // Ignore any fractional part that might appear in NAMELIST integer // input, like a few other Fortran compilers do. // TODO: also process exponents? Some compilers do, but they obviously // can't just be ignored. while ((next = io.NextInField(remaining, edit))) { if (*next < '0' || *next > '9') { break; } } if (!next || *next == comma) { break; } } io.GetIoErrorHandler().SignalError( "Bad character '%lc' in INTEGER input field", ch); return false; } static constexpr auto maxu128OverTen{maxu128 / 10}; static constexpr int maxLastDigit{ static_cast(maxu128 - (maxu128OverTen * 10))}; overflow |= value >= maxu128OverTen && (value > maxu128OverTen || digit > maxLastDigit); value *= 10; value += digit; any = true; } if (!any && !remaining) { io.GetIoErrorHandler().SignalError( "Integer value absent from NAMELIST or list-directed input"); return false; } if (isSigned) { auto maxForKind{common::UnsignedInt128{1} << ((8 * kind) - 1)}; overflow |= value >= maxForKind && (value > maxForKind || sign != '-'); } else { auto maxForKind{maxu128 >> (((16 - kind) * 8) + (isSigned ? 1 : 0))}; overflow |= value >= maxForKind; } if (overflow) { io.GetIoErrorHandler().SignalError(IostatIntegerInputOverflow, "Decimal input overflows INTEGER(%d) variable", kind); return false; } if (sign == '-') { value = -value; } if (any || !io.GetIoErrorHandler().InError()) { // The value is stored in the lower order bits on big endian platform. // When memcpy, shift the value to the higher order bit. auto shft{static_cast(sizeof(value.low())) - kind}; // For kind==8 (i.e. shft==0), the value is stored in low_ in big endian. if (!isHostLittleEndian && shft >= 0) { auto l{value.low() << (8 * shft)}; std::memcpy(n, &l, kind); } else { std::memcpy(n, &value, kind); // a blank field means zero } return true; } else { return false; } } // Parses a REAL input number from the input source as a normalized // fraction into a supplied buffer -- there's an optional '-', a // decimal point when the input is not hexadecimal, and at least one // digit. Replaces blanks with zeroes where appropriate. struct ScannedRealInput { // Number of characters that (should) have been written to the // buffer -- this can be larger than the buffer size, which // indicates buffer overflow. Zero indicates an error. int got{0}; int exponent{0}; // adjusted as necessary; binary if isHexadecimal bool isHexadecimal{false}; // 0X... }; static RT_API_ATTRS ScannedRealInput ScanRealInput( char *buffer, int bufferSize, IoStatementState &io, const DataEdit &edit) { Fortran::common::optional remaining; Fortran::common::optional next; int got{0}; Fortran::common::optional radixPointOffset; // The following lambda definition violates the conding style, // but cuda-11.8 nvcc hits an internal error with the brace initialization. auto Put = [&](char ch) -> void { if (got < bufferSize) { buffer[got] = ch; } ++got; }; char sign{ScanNumericPrefix(io, edit, next, remaining)}; if (sign == '-') { Put('-'); } bool bzMode{(edit.modes.editingFlags & blankZero) != 0}; int exponent{0}; if (!next || (!bzMode && *next == ' ') || (!(edit.modes.editingFlags & decimalComma) && *next == ',')) { if (!edit.IsListDirected() && !io.GetConnectionState().IsAtEOF()) { // An empty/blank field means zero when not list-directed. // A fixed-width field containing only a sign is also zero; // this behavior isn't standard-conforming in F'2023 but it is // required to pass FCVS. Put('0'); } return {got, exponent, false}; } char32_t radixPointChar{GetRadixPointChar(edit)}; char32_t first{*next >= 'a' && *next <= 'z' ? *next + 'A' - 'a' : *next}; bool isHexadecimal{false}; if (first == 'N' || first == 'I') { // NaN or infinity - convert to upper case // Subtle: a blank field of digits could be followed by 'E' or 'D', for (; next && ((*next >= 'a' && *next <= 'z') || (*next >= 'A' && *next <= 'Z')); next = io.NextInField(remaining, edit)) { if (*next >= 'a' && *next <= 'z') { Put(*next - 'a' + 'A'); } else { Put(*next); } } if (next && *next == '(') { // NaN(...) Put('('); int depth{1}; while (true) { next = io.NextInField(remaining, edit); if (depth == 0) { break; } else if (!next) { return {}; // error } else if (*next == '(') { ++depth; } else if (*next == ')') { --depth; } Put(*next); } } } else if (first == radixPointChar || (first >= '0' && first <= '9') || (bzMode && (first == ' ' || first == '\t')) || first == 'E' || first == 'D' || first == 'Q') { if (first == '0') { next = io.NextInField(remaining, edit); if (next && (*next == 'x' || *next == 'X')) { // 0X... isHexadecimal = true; next = io.NextInField(remaining, edit); } else { Put('0'); } } // input field is normalized to a fraction if (!isHexadecimal) { Put('.'); } auto start{got}; for (; next; next = io.NextInField(remaining, edit)) { char32_t ch{*next}; if (ch == ' ' || ch == '\t') { if (isHexadecimal) { return {}; // error } else if (bzMode) { ch = '0'; // BZ mode - treat blank as if it were zero } else { continue; // ignore blank in fixed field } } if (ch == '0' && got == start && !radixPointOffset) { // omit leading zeroes before the radix point } else if (ch >= '0' && ch <= '9') { Put(ch); } else if (ch == radixPointChar && !radixPointOffset) { // The radix point character is *not* copied to the buffer. radixPointOffset = got - start; // # of digits before the radix point } else if (isHexadecimal && ch >= 'A' && ch <= 'F') { Put(ch); } else if (isHexadecimal && ch >= 'a' && ch <= 'f') { Put(ch - 'a' + 'A'); // normalize to capitals } else { break; } } if (got == start) { // Nothing but zeroes and maybe a radix point. F'2018 requires // at least one digit, but F'77 did not, and a bare "." shows up in // the FCVS suite. Put('0'); // emit at least one digit } // In list-directed input, a bad exponent is not consumed. auto nextBeforeExponent{next}; auto startExponent{io.GetConnectionState().positionInRecord}; bool hasGoodExponent{false}; if (next) { if (isHexadecimal) { if (*next == 'p' || *next == 'P') { next = io.NextInField(remaining, edit); } else { // The binary exponent is not optional in the standard. return {}; // error } } else if (*next == 'e' || *next == 'E' || *next == 'd' || *next == 'D' || *next == 'q' || *next == 'Q') { // Optional exponent letter. Blanks are allowed between the // optional exponent letter and the exponent value. io.SkipSpaces(remaining); next = io.NextInField(remaining, edit); } } if (next && (*next == '-' || *next == '+' || (*next >= '0' && *next <= '9') || *next == ' ' || *next == '\t')) { bool negExpo{*next == '-'}; if (negExpo || *next == '+') { next = io.NextInField(remaining, edit); } for (; next; next = io.NextInField(remaining, edit)) { if (*next >= '0' && *next <= '9') { hasGoodExponent = true; if (exponent < 10000) { exponent = 10 * exponent + *next - '0'; } } else if (*next == ' ' || *next == '\t') { if (isHexadecimal) { break; } else if (bzMode) { hasGoodExponent = true; exponent = 10 * exponent; } } else { break; } } if (negExpo) { exponent = -exponent; } } if (!hasGoodExponent) { if (isHexadecimal) { return {}; // error } // There isn't a good exponent; do not consume it. next = nextBeforeExponent; io.HandleAbsolutePosition(startExponent); // The default exponent is -kP, but the scale factor doesn't affect // an explicit exponent. exponent = -edit.modes.scale; } // Adjust exponent by number of digits before the radix point. if (isHexadecimal) { // Exponents for hexadecimal input are binary. exponent += radixPointOffset.value_or(got - start) * 4; } else if (radixPointOffset) { exponent += *radixPointOffset; } else { // When no redix point (or comma) appears in the value, the 'd' // part of the edit descriptor must be interpreted as the number of // digits in the value to be interpreted as being to the *right* of // the assumed radix point (13.7.2.3.2) exponent += got - start - edit.digits.value_or(0); } } // Consume the trailing ')' of a list-directed or NAMELIST complex // input value. if (edit.descriptor == DataEdit::ListDirectedImaginaryPart) { if (next && (*next == ' ' || *next == '\t')) { io.SkipSpaces(remaining); next = io.NextInField(remaining, edit); } if (!next) { // NextInField fails on separators like ')' std::size_t byteCount{0}; next = io.GetCurrentChar(byteCount); if (next && *next == ')') { io.HandleRelativePosition(byteCount); } } } else if (remaining) { while (next && (*next == ' ' || *next == '\t')) { next = io.NextInField(remaining, edit); } if (next && (*next != ',' || (edit.modes.editingFlags & decimalComma))) { return {}; // error: unused nonblank character in fixed-width field } } return {got, exponent, isHexadecimal}; } static RT_API_ATTRS void RaiseFPExceptions( decimal::ConversionResultFlags flags) { #undef RAISE #if defined(RT_DEVICE_COMPILATION) Terminator terminator(__FILE__, __LINE__); #define RAISE(e) \ terminator.Crash( \ "not implemented yet: raising FP exception in device code: %s", #e); #else // !defined(RT_DEVICE_COMPILATION) #ifdef feraisexcept // a macro in some environments; omit std:: #define RAISE feraiseexcept #else #define RAISE std::feraiseexcept #endif #endif // !defined(RT_DEVICE_COMPILATION) // Some environment (e.g. emscripten, musl) don't define FE_OVERFLOW as allowed // by c99 (but not c++11) :-/ #if defined(FE_OVERFLOW) || defined(RT_DEVICE_COMPILATION) if (flags & decimal::ConversionResultFlags::Overflow) { RAISE(FE_OVERFLOW); } #endif #if defined(FE_UNDERFLOW) || defined(RT_DEVICE_COMPILATION) if (flags & decimal::ConversionResultFlags::Underflow) { RAISE(FE_UNDERFLOW); } #endif #if defined(FE_INEXACT) || defined(RT_DEVICE_COMPILATION) if (flags & decimal::ConversionResultFlags::Inexact) { RAISE(FE_INEXACT); } #endif #if defined(FE_INVALID) || defined(RT_DEVICE_COMPILATION) if (flags & decimal::ConversionResultFlags::Invalid) { RAISE(FE_INVALID); } #endif #undef RAISE } // If no special modes are in effect and the form of the input value // that's present in the input stream is acceptable to the decimal->binary // converter without modification, this fast path for real input // saves time by avoiding memory copies and reformatting of the exponent. template static RT_API_ATTRS bool TryFastPathRealDecimalInput( IoStatementState &io, const DataEdit &edit, void *n) { if (edit.modes.editingFlags & (blankZero | decimalComma)) { return false; } if (edit.modes.scale != 0) { return false; } const ConnectionState &connection{io.GetConnectionState()}; if (connection.internalIoCharKind > 1) { return false; // reading non-default character } const char *str{nullptr}; std::size_t got{io.GetNextInputBytes(str)}; if (got == 0 || str == nullptr || !connection.recordLength.has_value()) { return false; // could not access reliably-terminated input stream } const char *p{str}; std::int64_t maxConsume{ std::min(got, edit.width.value_or(got))}; const char *limit{str + maxConsume}; decimal::ConversionToBinaryResult converted{ decimal::ConvertToBinary(p, edit.modes.round, limit)}; if (converted.flags & (decimal::Invalid | decimal::Overflow)) { return false; } if (edit.digits.value_or(0) != 0) { // Edit descriptor is Fw.d (or other) with d != 0, which // implies scaling const char *q{str}; for (; q < limit; ++q) { if (*q == '.' || *q == 'n' || *q == 'N') { break; } } if (q == limit) { // No explicit decimal point, and not NaN/Inf. return false; } } if (edit.descriptor == DataEdit::ListDirectedImaginaryPart) { // Need to consume a trailing ')', possibly with leading spaces for (; p < limit && (*p == ' ' || *p == '\t'); ++p) { } if (p < limit && *p == ')') { ++p; } else { return false; } } else if (edit.IsListDirected()) { if (p < limit && !IsCharValueSeparator(edit, *p)) { return false; } } else { for (; p < limit && (*p == ' ' || *p == '\t'); ++p) { } if (edit.width && p < str + *edit.width) { return false; // unconverted characters remain in fixed width field } } // Success on the fast path! *reinterpret_cast *>(n) = converted.binary; io.HandleRelativePosition(p - str); // Set FP exception flags if (converted.flags != decimal::ConversionResultFlags::Exact) { RaiseFPExceptions(converted.flags); } return true; } template RT_API_ATTRS decimal::ConversionToBinaryResult ConvertHexadecimal( const char *&p, enum decimal::FortranRounding rounding, int expo) { using RealType = decimal::BinaryFloatingPointNumber; using RawType = typename RealType::RawType; bool isNegative{*p == '-'}; constexpr RawType one{1}; RawType signBit{0}; if (isNegative) { ++p; signBit = one << (RealType::bits - 1); } RawType fraction{0}; // Adjust the incoming binary P+/- exponent to shift the radix point // to below the LSB and add in the bias. expo += binaryPrecision - 1 + RealType::exponentBias; // Input the fraction. int roundingBit{0}; int guardBit{0}; for (; *p; ++p) { fraction <<= 4; expo -= 4; if (*p >= '0' && *p <= '9') { fraction |= *p - '0'; } else if (*p >= 'A' && *p <= 'F') { fraction |= *p - 'A' + 10; // data were normalized to capitals } else { break; } if (fraction >> binaryPrecision) { while (fraction >> binaryPrecision) { guardBit |= roundingBit; roundingBit = (int)fraction & 1; fraction >>= 1; ++expo; } // Consume excess digits while (*++p) { if (*p == '0') { } else if ((*p >= '1' && *p <= '9') || (*p >= 'A' && *p <= 'F')) { guardBit = 1; } else { break; } } break; } } if (fraction) { // Boost biased expo if too small while (expo < 1) { guardBit |= roundingBit; roundingBit = (int)fraction & 1; fraction >>= 1; ++expo; } // Normalize while (expo > 1 && !(fraction >> (binaryPrecision - 1))) { fraction <<= 1; --expo; guardBit = roundingBit = 0; } } // Rounding bool increase{false}; switch (rounding) { case decimal::RoundNearest: // RN & RP increase = roundingBit && (guardBit | ((int)fraction & 1)); break; case decimal::RoundUp: // RU increase = !isNegative && (roundingBit | guardBit); break; case decimal::RoundDown: // RD increase = isNegative && (roundingBit | guardBit); break; case decimal::RoundToZero: // RZ break; case decimal::RoundCompatible: // RC increase = roundingBit != 0; break; } if (increase) { ++fraction; if (fraction >> binaryPrecision) { fraction >>= 1; ++expo; } } // Package & return result constexpr RawType significandMask{(one << RealType::significandBits) - 1}; int flags{(roundingBit | guardBit) ? decimal::Inexact : decimal::Exact}; if (!fraction) { expo = 0; } else if (expo == 1 && !(fraction >> (binaryPrecision - 1))) { expo = 0; // subnormal flags |= decimal::Underflow; } else if (expo >= RealType::maxExponent) { if (rounding == decimal::RoundToZero || (rounding == decimal::RoundDown && !isNegative) || (rounding == decimal::RoundUp && isNegative)) { expo = RealType::maxExponent - 1; // +/-HUGE() fraction = significandMask; } else { expo = RealType::maxExponent; // +/-Inf fraction = 0; flags |= decimal::Overflow; } } else { fraction &= significandMask; // remove explicit normalization unless x87 } return decimal::ConversionToBinaryResult{ RealType{static_cast(signBit | static_cast(expo) << RealType::significandBits | fraction)}, static_cast(flags)}; } template RT_API_ATTRS bool EditCommonRealInput( IoStatementState &io, const DataEdit &edit, void *n) { constexpr int binaryPrecision{common::PrecisionOfRealKind(KIND)}; if (TryFastPathRealDecimalInput(io, edit, n)) { return CheckCompleteListDirectedField(io, edit); } // Fast path wasn't available or didn't work; go the more general route static constexpr int maxDigits{ common::MaxDecimalConversionDigits(binaryPrecision)}; static constexpr int bufferSize{maxDigits + 18}; char buffer[bufferSize]; auto scanned{ScanRealInput(buffer, maxDigits + 2, io, edit)}; int got{scanned.got}; if (got >= maxDigits + 2) { io.GetIoErrorHandler().Crash("EditCommonRealInput: buffer was too small"); return false; } if (got == 0) { const auto &connection{io.GetConnectionState()}; io.GetIoErrorHandler().SignalError(IostatBadRealInput, "Bad real input data at column %d of record %d", static_cast(connection.positionInRecord + 1), static_cast(connection.currentRecordNumber)); return false; } decimal::ConversionToBinaryResult converted; const char *p{buffer}; if (scanned.isHexadecimal) { buffer[got] = '\0'; converted = ConvertHexadecimal( p, edit.modes.round, scanned.exponent); } else { bool hadExtra{got > maxDigits}; int exponent{scanned.exponent}; if (exponent != 0) { buffer[got++] = 'e'; if (exponent < 0) { buffer[got++] = '-'; exponent = -exponent; } if (exponent > 9999) { exponent = 9999; // will convert to +/-Inf } if (exponent > 999) { int dig{exponent / 1000}; buffer[got++] = '0' + dig; int rest{exponent - 1000 * dig}; dig = rest / 100; buffer[got++] = '0' + dig; rest -= 100 * dig; dig = rest / 10; buffer[got++] = '0' + dig; buffer[got++] = '0' + (rest - 10 * dig); } else if (exponent > 99) { int dig{exponent / 100}; buffer[got++] = '0' + dig; int rest{exponent - 100 * dig}; dig = rest / 10; buffer[got++] = '0' + dig; buffer[got++] = '0' + (rest - 10 * dig); } else if (exponent > 9) { int dig{exponent / 10}; buffer[got++] = '0' + dig; buffer[got++] = '0' + (exponent - 10 * dig); } else { buffer[got++] = '0' + exponent; } } buffer[got] = '\0'; converted = decimal::ConvertToBinary(p, edit.modes.round); if (hadExtra) { converted.flags = static_cast( converted.flags | decimal::Inexact); } } if (*p) { // unprocessed junk after value const auto &connection{io.GetConnectionState()}; io.GetIoErrorHandler().SignalError(IostatBadRealInput, "Trailing characters after real input data at column %d of record %d", static_cast(connection.positionInRecord + 1), static_cast(connection.currentRecordNumber)); return false; } *reinterpret_cast *>(n) = converted.binary; // Set FP exception flags if (converted.flags != decimal::ConversionResultFlags::Exact) { if (converted.flags & decimal::ConversionResultFlags::Overflow) { io.GetIoErrorHandler().SignalError(IostatRealInputOverflow); return false; } RaiseFPExceptions(converted.flags); } return CheckCompleteListDirectedField(io, edit); } template RT_API_ATTRS bool EditRealInput( IoStatementState &io, const DataEdit &edit, void *n) { switch (edit.descriptor) { case DataEdit::ListDirected: if (IsNamelistNameOrSlash(io)) { return false; } return EditCommonRealInput(io, edit, n); case DataEdit::ListDirectedRealPart: case DataEdit::ListDirectedImaginaryPart: case 'F': case 'E': // incl. EN, ES, & EX case 'D': case 'G': return EditCommonRealInput(io, edit, n); case 'B': return EditBOZInput<1>(io, edit, n, common::BitsForBinaryPrecision(common::PrecisionOfRealKind(KIND)) >> 3); case 'O': return EditBOZInput<3>(io, edit, n, common::BitsForBinaryPrecision(common::PrecisionOfRealKind(KIND)) >> 3); case 'Z': return EditBOZInput<4>(io, edit, n, common::BitsForBinaryPrecision(common::PrecisionOfRealKind(KIND)) >> 3); case 'A': // legacy extension return EditCharacterInput(io, edit, reinterpret_cast(n), KIND); default: io.GetIoErrorHandler().SignalError(IostatErrorInFormat, "Data edit descriptor '%c' may not be used for REAL input", edit.descriptor); return false; } } // 13.7.3 in Fortran 2018 RT_API_ATTRS bool EditLogicalInput( IoStatementState &io, const DataEdit &edit, bool &x) { switch (edit.descriptor) { case DataEdit::ListDirected: if (IsNamelistNameOrSlash(io)) { return false; } break; case 'L': case 'G': break; default: io.GetIoErrorHandler().SignalError(IostatErrorInFormat, "Data edit descriptor '%c' may not be used for LOGICAL input", edit.descriptor); return false; } Fortran::common::optional remaining{io.CueUpInput(edit)}; Fortran::common::optional next{io.NextInField(remaining, edit)}; if (next && *next == '.') { // skip optional period next = io.NextInField(remaining, edit); } if (!next) { io.GetIoErrorHandler().SignalError("Empty LOGICAL input field"); return false; } switch (*next) { case 'T': case 't': x = true; break; case 'F': case 'f': x = false; break; default: io.GetIoErrorHandler().SignalError( "Bad character '%lc' in LOGICAL input field", *next); return false; } if (remaining) { // ignore the rest of a fixed-width field io.HandleRelativePosition(*remaining); } else if (edit.descriptor == DataEdit::ListDirected) { while (io.NextInField(remaining, edit)) { // discard rest of field } } return CheckCompleteListDirectedField(io, edit); } // See 13.10.3.1 paragraphs 7-9 in Fortran 2018 template static RT_API_ATTRS bool EditDelimitedCharacterInput( IoStatementState &io, CHAR *x, std::size_t length, char32_t delimiter) { bool result{true}; while (true) { std::size_t byteCount{0}; auto ch{io.GetCurrentChar(byteCount)}; if (!ch) { if (io.AdvanceRecord()) { continue; } else { result = false; // EOF in character value break; } } io.HandleRelativePosition(byteCount); if (*ch == delimiter) { auto next{io.GetCurrentChar(byteCount)}; if (next && *next == delimiter) { // Repeated delimiter: use as character value io.HandleRelativePosition(byteCount); } else { break; // closing delimiter } } if (length > 0) { *x++ = *ch; --length; } } Fortran::runtime::fill_n(x, length, ' '); return result; } template static RT_API_ATTRS bool EditListDirectedCharacterInput( IoStatementState &io, CHAR *x, std::size_t length, const DataEdit &edit) { std::size_t byteCount{0}; auto ch{io.GetCurrentChar(byteCount)}; if (ch && (*ch == '\'' || *ch == '"')) { io.HandleRelativePosition(byteCount); return EditDelimitedCharacterInput(io, x, length, *ch); } if (IsNamelistNameOrSlash(io) || io.GetConnectionState().IsAtEOF()) { return false; } // Undelimited list-directed character input: stop at a value separator // or the end of the current record. while (auto ch{io.GetCurrentChar(byteCount)}) { bool isSep{false}; switch (*ch) { case ' ': case '\t': case '/': isSep = true; break; case '&': case '$': isSep = edit.IsNamelist(); break; case ',': isSep = !(edit.modes.editingFlags & decimalComma); break; case ';': isSep = !!(edit.modes.editingFlags & decimalComma); break; default: break; } if (isSep) { break; } if (length > 0) { *x++ = *ch; --length; } else if (edit.IsNamelist()) { // GNU compatibility break; } io.HandleRelativePosition(byteCount); io.GotChar(byteCount); } Fortran::runtime::fill_n(x, length, ' '); return true; } template RT_API_ATTRS bool EditCharacterInput(IoStatementState &io, const DataEdit &edit, CHAR *x, std::size_t lengthChars) { switch (edit.descriptor) { case DataEdit::ListDirected: return EditListDirectedCharacterInput(io, x, lengthChars, edit); case 'A': case 'G': break; case 'B': return EditBOZInput<1>(io, edit, x, lengthChars * sizeof *x); case 'O': return EditBOZInput<3>(io, edit, x, lengthChars * sizeof *x); case 'Z': return EditBOZInput<4>(io, edit, x, lengthChars * sizeof *x); default: io.GetIoErrorHandler().SignalError(IostatErrorInFormat, "Data edit descriptor '%c' may not be used with a CHARACTER data item", edit.descriptor); return false; } const ConnectionState &connection{io.GetConnectionState()}; std::size_t remainingChars{lengthChars}; // Skip leading characters. // Their bytes don't count towards INQUIRE(IOLENGTH=). std::size_t skipChars{0}; if (edit.width && *edit.width > 0) { remainingChars = *edit.width; if (remainingChars > lengthChars) { skipChars = remainingChars - lengthChars; } } // When the field is wider than the variable, we drop the leading // characters. When the variable is wider than the field, there can be // trailing padding or an EOR condition. const char *input{nullptr}; std::size_t readyBytes{0}; // Transfer payload bytes; these do count. while (remainingChars > 0) { if (readyBytes == 0) { readyBytes = io.GetNextInputBytes(input); if (readyBytes == 0 || (readyBytes < remainingChars && edit.modes.nonAdvancing)) { if (io.CheckForEndOfRecord(readyBytes)) { if (readyBytes == 0) { // PAD='YES' and no more data Fortran::runtime::fill_n(x, lengthChars, ' '); return !io.GetIoErrorHandler().InError(); } else { // Do partial read(s) then pad on last iteration } } else { return !io.GetIoErrorHandler().InError(); } } } std::size_t chunkBytes; std::size_t chunkChars{1}; bool skipping{skipChars > 0}; if (connection.isUTF8) { chunkBytes = MeasureUTF8Bytes(*input); if (skipping) { --skipChars; } else if (auto ucs{DecodeUTF8(input)}) { if ((sizeof *x == 1 && *ucs > 0xff) || (sizeof *x == 2 && *ucs > 0xffff)) { *x++ = '?'; } else { *x++ = *ucs; } --lengthChars; } else if (chunkBytes == 0) { // error recovery: skip bad encoding chunkBytes = 1; } } else if (connection.internalIoCharKind > 1) { // Reading from non-default character internal unit chunkBytes = connection.internalIoCharKind; if (skipping) { --skipChars; } else { char32_t buffer{0}; std::memcpy(&buffer, input, chunkBytes); if ((sizeof *x == 1 && buffer > 0xff) || (sizeof *x == 2 && buffer > 0xffff)) { *x++ = '?'; } else { *x++ = buffer; } --lengthChars; } } else if constexpr (sizeof *x > 1) { // Read single byte with expansion into multi-byte CHARACTER chunkBytes = 1; if (skipping) { --skipChars; } else { *x++ = static_cast(*input); --lengthChars; } } else { // single bytes -> default CHARACTER if (skipping) { chunkBytes = std::min(skipChars, readyBytes); chunkChars = chunkBytes; skipChars -= chunkChars; } else { chunkBytes = std::min(remainingChars, readyBytes); chunkBytes = std::min(lengthChars, chunkBytes); chunkChars = chunkBytes; std::memcpy(x, input, chunkBytes); x += chunkBytes; lengthChars -= chunkChars; } } input += chunkBytes; remainingChars -= chunkChars; if (!skipping) { io.GotChar(chunkBytes); } io.HandleRelativePosition(chunkBytes); readyBytes -= chunkBytes; } // Pad the remainder of the input variable, if any. Fortran::runtime::fill_n(x, lengthChars, ' '); return CheckCompleteListDirectedField(io, edit); } template RT_API_ATTRS bool EditRealInput<2>( IoStatementState &, const DataEdit &, void *); template RT_API_ATTRS bool EditRealInput<3>( IoStatementState &, const DataEdit &, void *); template RT_API_ATTRS bool EditRealInput<4>( IoStatementState &, const DataEdit &, void *); template RT_API_ATTRS bool EditRealInput<8>( IoStatementState &, const DataEdit &, void *); template RT_API_ATTRS bool EditRealInput<10>( IoStatementState &, const DataEdit &, void *); // TODO: double/double template RT_API_ATTRS bool EditRealInput<16>( IoStatementState &, const DataEdit &, void *); template RT_API_ATTRS bool EditCharacterInput( IoStatementState &, const DataEdit &, char *, std::size_t); template RT_API_ATTRS bool EditCharacterInput( IoStatementState &, const DataEdit &, char16_t *, std::size_t); template RT_API_ATTRS bool EditCharacterInput( IoStatementState &, const DataEdit &, char32_t *, std::size_t); RT_OFFLOAD_API_GROUP_END } // namespace Fortran::runtime::io