//===-- 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 <algorithm>
#include <cfenv>
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<unsigned>(*ch),
static_cast<int>(connection.positionInRecord + 1),
static_cast<int>(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 <int LOG2_BASE>
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<int> remaining{io.CueUpInput(edit)};
auto start{io.GetConnectionState().positionInRecord};
Fortran::common::optional<char32_t> 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) {
significantBits = 4;
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<std::size_t>(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<unsigned char *>(n) +
(isHostLittleEndian ? significantBytes - 1 : bytes - significantBytes)};
int shift{((digits - 1) * LOG2_BASE) & 7};
while (digits > 0) {
char32_t ch{*io.NextInField(remaining, edit)};
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<char32_t> &next,
Fortran::common::optional<int> &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) {
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<char *>(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<int> remaining;
Fortran::common::optional<char32_t> next;
char sign{ScanNumericPrefix(io, edit, next, remaining)};
common::UnsignedInt128 value{0};
bool any{!!sign};
bool overflow{false};
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;
}
}
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 maxu128{~common::UnsignedInt128{0}};
static constexpr auto maxu128OverTen{maxu128 / 10};
static constexpr int maxLastDigit{
static_cast<int>(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;
}
auto maxForKind{common::UnsignedInt128{1} << ((8 * kind) - 1)};
overflow |= value >= maxForKind && (value > maxForKind || sign != '-');
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<int>(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<int> remaining;
Fortran::common::optional<char32_t> next;
int got{0};
Fortran::common::optional<int> 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 <int PRECISION>
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<std::int64_t>(got, edit.width.value_or(got))};
const char *limit{str + maxConsume};
decimal::ConversionToBinaryResult<PRECISION> converted{
decimal::ConvertToBinary<PRECISION>(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<decimal::BinaryFloatingPointNumber<PRECISION> *>(n) =
converted.binary;
io.HandleRelativePosition(p - str);
// Set FP exception flags
if (converted.flags != decimal::ConversionResultFlags::Exact) {
RaiseFPExceptions(converted.flags);
}
return true;
}
template <int binaryPrecision>
RT_API_ATTRS decimal::ConversionToBinaryResult<binaryPrecision>
ConvertHexadecimal(
const char *&p, enum decimal::FortranRounding rounding, int expo) {
using RealType = decimal::BinaryFloatingPointNumber<binaryPrecision>;
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<binaryPrecision>{
RealType{static_cast<RawType>(signBit |
static_cast<RawType>(expo) << RealType::significandBits | fraction)},
static_cast<decimal::ConversionResultFlags>(flags)};
}
template <int KIND>
RT_API_ATTRS bool EditCommonRealInput(
IoStatementState &io, const DataEdit &edit, void *n) {
constexpr int binaryPrecision{common::PrecisionOfRealKind(KIND)};
if (TryFastPathRealDecimalInput<binaryPrecision>(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<int>(connection.positionInRecord + 1),
static_cast<int>(connection.currentRecordNumber));
return false;
}
decimal::ConversionToBinaryResult<binaryPrecision> converted;
const char *p{buffer};
if (scanned.isHexadecimal) {
buffer[got] = '\0';
converted = ConvertHexadecimal<binaryPrecision>(
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<binaryPrecision>(p, edit.modes.round);
if (hadExtra) {
converted.flags = static_cast<enum decimal::ConversionResultFlags>(
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<int>(connection.positionInRecord + 1),
static_cast<int>(connection.currentRecordNumber));
return false;
}
*reinterpret_cast<decimal::BinaryFloatingPointNumber<binaryPrecision> *>(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 <int KIND>
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<KIND>(io, edit, n);
case DataEdit::ListDirectedRealPart:
case DataEdit::ListDirectedImaginaryPart:
case 'F':
case 'E': // incl. EN, ES, & EX
case 'D':
case 'G':
return EditCommonRealInput<KIND>(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<char *>(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<int> remaining{io.CueUpInput(edit)};
Fortran::common::optional<char32_t> 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 <typename CHAR>
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 <typename CHAR>
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. Subtlety: the "remaining" count
// here is a dummy that's used to avoid the interpretation of separators
// in NextInField.
Fortran::common::optional<int> remaining{length > 0 ? maxUTF8Bytes : 0};
while (Fortran::common::optional<char32_t> next{
io.NextInField(remaining, edit)}) {
bool isSep{false};
switch (*next) {
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) {
remaining = 0;
} else {
*x++ = *next;
remaining = --length > 0 ? maxUTF8Bytes : 0;
}
}
Fortran::runtime::fill_n(x, length, ' ');
return true;
}
template <typename CHAR>
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<unsigned char>(*input);
--lengthChars;
}
} else { // single bytes -> default CHARACTER
if (skipping) {
chunkBytes = std::min<std::size_t>(skipChars, readyBytes);
chunkChars = chunkBytes;
skipChars -= chunkChars;
} else {
chunkBytes = std::min<std::size_t>(remainingChars, readyBytes);
chunkBytes = std::min<std::size_t>(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
Codebase Browser
llvm